direct-command
indir-command
+ indir-as-direct-command
loose-direct-command
loose-indir-command
empty-command
action
%high-priority))
+(define* (indir-as-direct-command verbs action #:optional prepositions)
+ (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)))
+ action
+ %high-priority))
+
(define* (loose-indir-command verbs action #:optional prepositions)
(make-command verbs
cmatch-indir-obj
#:use-module (ice-9 match)
#:use-module (oop goops)
#:export (<gameobj>
- gameobj-simple-name-f
gameobj-loc
gameobj-gm
- gameobj-name
gameobj-occupants
gameobj-actions
(remove-occupant! (wrap-apply gameobj-remove-occupant!))
(set-loc! (wrap-apply gameobj-act-set-loc!))
(get-name (wrap-apply gameobj-get-name))
+ (set-name! (wrap-apply gameobj-act-set-name!))
(get-desc (wrap-apply gameobj-get-desc))
(goes-by (wrap-apply gameobj-act-goes-by))
(visible-name (wrap-apply gameobj-visible-name))
(define gameobj-get-name (simple-slot-getter 'name))
+(define-mhandler (gameobj-act-set-name! actor message val)
+ (slot-set! actor 'name val))
+
(define-mhandler (gameobj-get-desc actor message whos-looking)
(define desc-text
(match (slot-ref actor 'desc)
(desc desc)))
(<-reply actor message #:val desc-text))
-(define (gameobj-simple-name-f gameobj)
- "Simplest version: return ourselves for our name."
- (gameobj-name gameobj))
-
(define (gameobj-visible-to-player? gameobj whos-looking)
"Check to see whether we're visible to the player or not.
By default, this is whether or not the generally-visible flag is set."
;; definite and indefinite, but not partitive articles
(define article '(or "the" "a" "an"))
-(define preposition '(or "with" "in" "on" "out of" "at"))
+(define preposition '(or "with" "in" "on" "out of" "at" "as"))
(define indirect-irx
(sre->irregex
#f)))
(define %formless-desc
- "You don't see anything special about it.")
+ "You don't see anything special.")
(define-mhandler (room-look-at room message direct-obj)
"Look at a specific object in the room."
;;; Hotel Bricabrac
(use-modules (mudsync)
+ (mudsync parser)
(8sync systems actors)
(8sync agenda)
(oop goops)
- (ice-9 format))
+ (ice-9 format)
+ (rx irregex))
\f
"a scroll of teletype paper holding the software Four Freedoms"
"a telephone shaped like an orange cartoon cat"))
+(define-class <sign-in-form> (<gameobj>)
+ (commands
+ #:init-value
+ (list
+ (indir-as-direct-command "sign" 'cmd-sign-form
+ '("as"))))
+ (message-handler
+ #:init-value
+ (simple-dispatcher
+ (append
+ (build-actions
+ (cmd-sign-form (wrap-apply sign-cmd-sign-in)))
+ gameobj-actions))))
+
+
+(define name-sre
+ (sre->irregex '(: alpha (** 1 14 (or alphanum "-" "_")))))
+
+(define forbidden-words
+ (append article preposition
+ '("and" "or" "but" "admin")))
+
+(define (valid-name? name)
+ (and (irregex-match name-sre name)
+ (not (member name forbidden-words))))
+
+(define-mhandler (sign-cmd-sign-in actor message direct-obj indir-obj)
+ (define old-name
+ (message-ref
+ (<-wait actor (message-from message) 'get-name)
+ 'val))
+ (define name indir-obj)
+ (if (valid-name? indir-obj)
+ (begin
+ (<-wait actor (message-from message) 'set-name!
+ #:val name)
+ (<- actor (slot-ref actor 'loc) 'tell-room
+ #:text (format #f "~a signs the form!\n~a is now known as ~a\n"
+ old-name old-name name)))
+ (<- actor (message-from message) 'tell
+ "Sorry, that's not a valid name.
+Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic
+character.")))
+
+
(define lobby
(lol
('room:lobby
(format #f " The curio cabinet is full of all sorts of oddities!
Something catches your eye!
Ooh, ~a!" (random-choice random-bricabrac))))
-
+ ('thing:sign-in-form
+ <sign-in-form> 'room:lobby
+ #:name "sign-in form"
+ #:goes-by '("sign-in form" "form" "signin form")
+ #:desc "It looks like you could sign this form and set your name.")
;; Object: desk
;; - Object: bell
;; - Object: sign in form
projects / mudsync.git / commitdiff