123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110 |
- ;;; Mudsync --- Live hackable MUD
- ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
- ;;;
- ;;; This file is part of Mudsync.
- ;;;
- ;;; Mudsync is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or
- ;;; (at your option) any later version.
- ;;;
- ;;; Mudsync is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;;; General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with Mudsync. If not, see <http://www.gnu.org/licenses/>.
- (define-module (mudsync parser)
- #:use-module (rx irregex)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:export (match-to-kwargs
- split-verb-and-rest
- article preposition
- cmatch-indir-obj
- cmatch-direct-obj
- cmatch-direct-obj-greedy
- cmatch-empty
- cmatch-greedy))
- (define (match-to-kwargs irx string)
- (let ((rx-match (irregex-match irx string)))
- (if rx-match
- (fold
- (match-lambda*
- (((match-part . idx) prev)
- (cons (symbol->keyword match-part)
- (cons (irregex-match-substring
- rx-match idx)
- prev))))
- '()
- (irregex-match-names rx-match))
- #f)))
- (define (split-verb-and-rest string)
- (let* ((trimmed (string-trim-both string))
- (first-space (string-index trimmed #\space)))
- (if first-space
- (cons (substring trimmed 0 first-space)
- (substring trimmed (+ 1 first-space)))
- (cons trimmed ""))))
- ;; @@: Not currently used
- ;; Borrowed from irregex.scm
- (define match-string
- '(seq #\" (* (or (~ #\\ #\") (seq #\\ any))) #\"))
- ;; definite and indefinite, but not partitive articles
- (define article '(or "the" "a" "an"))
- (define preposition '(or "with" "in" "inside" "into" "on" "out" "out of"
- "at" "as" "to" "about" "from"))
- (define indirect-irx
- (sre->irregex
- `(: (? (: ,preposition (+ space))) ; possibly a preposition
- (? (: ,article (+ space))) ; possibly an article (ignored)
- (=> direct-obj (* any)) ; direct object (kept)
- (+ space)
- (=> preposition ,preposition) ; main preposition (kept)
- (+ space)
- (? (: ,article (+ space))) ; possibly an article (ignored)
- (=> indir-obj (+ any))))) ; indirect object (kept)
- (define (cmatch-indir-obj phrase)
- (match-to-kwargs indirect-irx phrase))
- (define direct-irx
- (sre->irregex
- `(: (? (: ,preposition (+ space))) ; possibly a preposition (ignored)
- (? (: ,article (+ space))) ; possibly an article (ignored)
- (=> direct-obj (+ any))))) ; direct object (kept)
- (define (cmatch-direct-obj phrase)
- (match-to-kwargs direct-irx phrase))
- (define (cmatch-empty phrase)
- (if (equal? (string-trim phrase) "")
- '()
- #f))
- (define (cmatch-direct-obj-greedy phrase)
- ;; Turns out this uses the same semantics as splitting verb/rest
- (match (split-verb-and-rest phrase)
- ((direct-obj . rest)
- (list #:direct-obj direct-obj
- #:rest rest))
- (#f #f)))
- (define (cmatch-greedy phrase)
- `(#:phrase ,phrase))
- ;; (define say-example "say I really need to get going.")
- ;; (define attack-sword-example "hit goblin with sword")
- ;; (define attack-simple-example "hit goblin")
- ;; (define put-book-on-desk "put the book on the desk")
|