;;; Mudsync --- Live hackable MUD
-;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of Mudsync.
;;;
(define-module (mudsync command)
#:use-module (mudsync parser)
- #:use-module (8sync systems actors)
+ #:use-module (mudsync utils)
+ #:use-module (8sync actors)
+ #:use-module (8sync rmeta-slot)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (ice-9 control)
command-action
command-priority
+ build-commands
+
direct-command
prep-indir-command
prep-direct-command
;; (define command-priority sixth)
(define-record-type <command>
- (make-command verbs matcher should-handle action priority)
+ (make-command verbs matcher should-handle action priority obvious?)
command?
(verbs command-verbs)
(matcher command-matcher)
(should-handle command-should-handle)
(action command-action)
- (priority command-priority))
-
-
-(define (direct-command verbs action)
+ (priority command-priority)
+ (obvious? command-obvious?))
+
+(define-syntax %build-command
+ (syntax-rules ()
+ ((_ (verb ...) ((cmd-proc action-sym args ...) ...))
+ (list (cons verb
+ (list (cmd-proc (list verb ...)
+ (quote action-sym)
+ args ...)
+ ...))
+ ...))
+ ((_ verb ((cmd-proc action-sym args ...) ...))
+ (list (cons verb
+ (list (cmd-proc (list verb)
+ (quote action-sym)
+ args ...)
+ ...))))))
+
+(define-syntax-rule (build-commands (verb-or-verbs cmd-defs ...) ...)
+ (build-rmeta-slot
+ (append (%build-command verb-or-verbs cmd-defs ...) ...)))
+
+
+(define* (direct-command verbs action #:key (obvious? #t))
(make-command verbs
cmatch-direct-obj
;; @@: Should we allow fancier matching than this?
;; Let the actor itself pass along this whole method?
(lambda* (goes-by #:key direct-obj)
- (member direct-obj goes-by))
+ (ci-member direct-obj goes-by))
action
- %default-priority))
+ %default-priority
+ obvious?))
-(define (loose-direct-command verbs action)
+(define* (loose-direct-command verbs action #:key (obvious? #t))
(make-command verbs
cmatch-direct-obj
;; @@: Should we allow fancier matching than this?
;; Let the actor itself pass along this whole method?
(const #t)
action
- %default-priority))
+ %default-priority
+ obvious?))
-(define* (prep-indir-command verbs action #:optional prepositions)
+(define* (prep-indir-command verbs action #:optional prepositions
+ #:key (obvious? #t))
(make-command verbs
cmatch-indir-obj
(lambda* (goes-by #:key direct-obj indir-obj preposition)
(if prepositions
(and
- (member indir-obj goes-by)
- (member preposition prepositions))
- (member indir-obj goes-by)))
+ (ci-member indir-obj goes-by)
+ (ci-member preposition prepositions))
+ (ci-member indir-obj goes-by)))
action
- %high-priority))
+ %high-priority
+ obvious?))
-(define* (prep-direct-command verbs action #:optional prepositions)
+(define* (prep-direct-command verbs action #:optional prepositions
+ #:key (obvious? #t))
(make-command verbs
cmatch-indir-obj
(lambda* (goes-by #:key direct-obj indir-obj preposition)
(if prepositions
(and
- (member direct-obj goes-by)
- (member preposition prepositions))
- (member direct-obj goes-by)))
+ (ci-member direct-obj goes-by)
+ (ci-member preposition prepositions))
+ (ci-member direct-obj goes-by)))
action
- %high-priority))
+ %high-priority
+ obvious?))
-(define* (loose-prep-command verbs action #:optional prepositions)
+(define* (loose-prep-command verbs action #:optional prepositions
+ #:key (obvious? #t))
(make-command verbs
cmatch-indir-obj
(const #t)
action
- %high-priority))
+ %high-priority
+ obvious?))
-(define (empty-command verbs action)
+(define* (empty-command verbs action
+ #:key (obvious? #t))
(make-command verbs
cmatch-empty
(const #t)
action
- %low-priority))
+ %low-priority
+ obvious?))
-(define (greedy-command verbs action)
+(define* (greedy-command verbs action
+ #:key (obvious? #t))
(make-command verbs
cmatch-greedy
(const #t)
action
- %low-priority))
+ %low-priority
+ obvious?))
-(define (direct-greedy-command verbs action)
+(define* (direct-greedy-command verbs action
+ #:key (obvious? #t))
"greedy commands but which match the direct object"
(make-command verbs
cmatch-direct-obj-greedy
(lambda* (goes-by #:key direct-obj rest)
- (member direct-obj goes-by))
+ (ci-member direct-obj goes-by))
action
- %low-priority))
+ %low-priority
+ obvious?))
;; @@: We should probably ONLY allow these to go to users!
(define* (custom-command verbs matcher should-handle action
- #:optional (priority %default-priority))
+ #:optional (priority %default-priority)
+ #:key (obvious? #t))
"Full-grained customizable command."
- (make-command verbs matcher should-handle action priority))
+ (make-command verbs matcher should-handle action priority obvious?))