mudsync/parser.scm

   1 ;;; Mudsync --- Live hackable MUD
   2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of Mudsync.
   5 ;;;
   6 ;;; Mudsync is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; Mudsync is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (mudsync parser)
  20   #:use-module (rx irregex)
  21   #:use-module (ice-9 match)
  22   #:use-module (srfi srfi-9))
  23
  24
  25 (define (match-to-kwargs irx string)
  26   (let ((rx-match (irregex-match irx string)))
  27     (if rx-match
  28         (map (match-lambda
  29                ((match-part . idx)
  30                 (cons match-part
  31                       (irregex-match-substring
  32                        rx-match idx))))
  33              (irregex-match-names rx-match))
  34         #f)))
  35
  36 (define (split-verb-and-rest string)
  37   (let* ((trimmed (string-trim-both string))
  38          (first-space (string-index trimmed #\space)))
  39     (if first-space
  40         `((verb . ,(substring trimmed 0 first-space))
  41           (rest . ,(substring trimmed (+ 1 first-space))))
  42         `((verb . ,trimmed)
  43           (rest . "")))))
  44
  45 ;; @@: Not currently used
  46 ;; Borrowed from irregex.scm
  47 (define match-string
  48   '(seq #\" (* (or (~ #\\ #\") (seq #\\ any))) #\"))
  49
  50 ;; definite and indefinite, but not partitive articles
  51 (define article '(or "the" "a" "an"))
  52 (define preposition '(or "with" "in" "on" "out of" "at"))
  53
  54 (define indirect-irx
  55   (sre->irregex
  56    `(: (? (: ,preposition (+ space)))  ; possibly a preposition (ignored)
  57        (? (: ,article (+ space)))      ; possibly an article (ignored)
  58        (=> direct-object (* any))      ; direct object (kept)
  59        (+ space)
  60        (=> preposition ,preposition)   ; main preposition (kept)
  61        (+ space)
  62        (? (: ,article (+ space)))      ; possibly an article (ignored)
  63        (=> indirect-object (+ any))))) ; indirect object (kept)
  64
  65 (define (indirect-matcher phrase)
  66   (match-to-kwargs indirect-irx phrase))
  67
  68 (define direct-irx
  69   (sre->irregex
  70    `(: (? (: ,preposition (+ space)))  ; possibly a preposition (ignored)
  71        (? (: ,article (+ space)))     ; possibly an article (ignored)
  72        (=> direct-object (* any)))))  ; direct object (kept)
  73
  74 (define (direct-matcher phrase)
  75   (match-to-kwargs direct-irx phrase))
  76
  77 (define say-example "say I really need to get going.")
  78 (define attack-sword-example "hit goblin with sword")
  79 (define attack-simple-example "hit goblin")
  80 (define put-book-on-desk "put the book on the desk")
  81
  82 (define-record-type <command-handler>
  83   (make-command-handler matcher should-handle action)
  84   command-handler?
  85   (matcher command-handler-matcher)
  86   (should-handle command-handler-should-handle?)
  87   (action command-handler-action))
  88
  89 (define command-handler make-command-handler)
  90