-(use-modules (rx irregex)
- (ice-9 match))
+;;; 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
- (map (match-lambda
- ((match-part . idx)
- (cons match-part
- (irregex-match-substring
- rx-match idx))))
- (irregex-match-names 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)))
-
-;; definite and indefinite, but not partitive articles
-(define article '(or "the" "a" "an"))
-(define preposition '(or "with" "in" "on" "out of" "at"))
-
-(define split-verb-and-rest-irx
- (sre->irregex
- `(: (* space) (=> verb (+ alphanum))
- (? (+ space) (=> rest (* any))))))
-
-;; TODO: we could make this MUCH FASTER if we didn't use irregex
-;; for this step!
(define (split-verb-and-rest string)
(let* ((trimmed (string-trim-both string))
(first-space (string-index trimmed #\space)))
(if first-space
- `((verb . ,(substring trimmed 0 first-space))
- (rest . ,(substring trimmed (+ 1 first-space))))
- `((verb . ,trimmed)
- (rest . "")))))
+ (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" "on" "out of" "at" "as" "to"
+ "about"))
+
(define indirect-irx
(sre->irregex
- `(: (? (: ,article (+ space))) ; possibly an article (ignored)
- (=> direct-object (* any)) ; direct object
- (+ space) (=> preposition ,preposition) (+ space)
- (? (: ,article (+ space)))
- (=> indirect-object (+ any)))))
+ `(: (? (: ,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
- `(: (? (: ,article (+ space))) ; possibly an article (ignored)
- (=> direct-object (* any)))) ; direct object
+ (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")
+;; (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")
projects / mudsync.git / blobdiff