Fix code for going someplace that doesn't exist
[mudsync.git] / 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-1)
23   #:use-module (srfi srfi-9)
24
25   #:export (match-to-kwargs
26             split-verb-and-rest
27             article preposition
28
29             cmatch-indir-obj
30             cmatch-direct-obj
31             cmatch-direct-obj-greedy
32             cmatch-empty
33             cmatch-greedy))
34
35 (define (match-to-kwargs irx string)
36   (let ((rx-match (irregex-match irx string)))
37     (if rx-match
38         (fold
39          (match-lambda*
40            (((match-part . idx) prev)
41             (cons (symbol->keyword match-part)
42                   (cons (irregex-match-substring
43                          rx-match idx)
44                         prev))))
45          '()
46          (irregex-match-names rx-match))
47         #f)))
48
49 (define (split-verb-and-rest string)
50   (let* ((trimmed (string-trim-both string))
51          (first-space (string-index trimmed #\space)))
52     (if first-space
53         (cons (substring trimmed 0 first-space)
54               (substring trimmed (+ 1 first-space)))
55         (cons trimmed ""))))
56
57 ;; @@: Not currently used
58 ;; Borrowed from irregex.scm
59 (define match-string
60   '(seq #\" (* (or (~ #\\ #\") (seq #\\ any))) #\"))
61
62 ;; definite and indefinite, but not partitive articles
63 (define article '(or "the" "a" "an"))
64 (define preposition '(or "with" "in" "on" "out of" "at" "as"))
65
66 (define indirect-irx
67   (sre->irregex
68    `(: (? (: ,preposition (+ space)))  ; possibly a preposition (ignored)
69        (? (: ,article (+ space)))      ; possibly an article (ignored)
70        (=> direct-obj (* any))      ; direct object (kept)
71        (+ space)
72        (=> preposition ,preposition)   ; main preposition (kept)
73        (+ space)
74        (? (: ,article (+ space)))      ; possibly an article (ignored)
75        (=> indir-obj (+ any))))) ; indirect object (kept)
76
77 (define (cmatch-indir-obj phrase)
78   (match-to-kwargs indirect-irx phrase))
79
80 (define direct-irx
81   (sre->irregex
82    `(: (? (: ,preposition (+ space)))  ; possibly a preposition (ignored)
83        (? (: ,article (+ space)))     ; possibly an article (ignored)
84        (=> direct-obj (+ any)))))  ; direct object (kept)
85
86 (define (cmatch-direct-obj phrase)
87   (match-to-kwargs direct-irx phrase))
88
89 (define (cmatch-empty phrase)
90   (if (equal? (string-trim phrase) "")
91       '()
92       #f))
93
94 (define (cmatch-direct-obj-greedy phrase)
95   ;; Turns out this uses the same semantics as splitting verb/rest
96   (match (split-verb-and-rest phrase)
97     ((direct-obj . rest)
98      (list #:direct-obj direct-obj
99            #:rest rest))
100     (#f #f)))
101
102 (define (cmatch-greedy phrase)
103   `(#:phrase ,phrase))
104
105 ;; (define say-example "say I really need to get going.")
106 ;; (define attack-sword-example "hit goblin with sword")
107 ;; (define attack-simple-example "hit goblin")
108 ;; (define put-book-on-desk "put the book on the desk")