A bunch of stuff so you can set your own username

diff --git a/mudsync/command.scm b/mudsync/command.scm
index 31687389cf9a17af83e2f02e318d2f28b377100b..23e21dac8f85fc75645cc18620e0613dba0818d9 100644 (file)
--- a/mudsync/command.scm
+++ b/mudsync/command.scm
@@ -33,6 +33,7 @@
 
             direct-command
             indir-command
 
             direct-command
             indir-command

+            indir-as-direct-command

             loose-direct-command
             loose-indir-command
             empty-command
             loose-direct-command
             loose-indir-command
             empty-command


@@ -101,6 +102,18 @@
                 action
                 %high-priority))
 
                 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
 (define* (loose-indir-command verbs action #:optional prepositions)
   (make-command verbs
                 cmatch-indir-obj

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 91701ac4ccd28e34edc63028e6ce6db8151cec4b..c34e89bb5540a90308686c64ec7e3fc6caf58b98 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -27,11 +27,9 @@
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:export (<gameobj>
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:export (<gameobj>

-            gameobj-simple-name-f

 
             gameobj-loc
             gameobj-gm
 
             gameobj-loc
             gameobj-gm

-            gameobj-name

 
             gameobj-occupants
             gameobj-actions
 
             gameobj-occupants
             gameobj-actions


@@ -52,6 +50,7 @@
    (remove-occupant! (wrap-apply gameobj-remove-occupant!))
    (set-loc! (wrap-apply gameobj-act-set-loc!))
    (get-name (wrap-apply gameobj-get-name))
    (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))
    (get-desc (wrap-apply gameobj-get-desc))
    (goes-by (wrap-apply gameobj-act-goes-by))
    (visible-name (wrap-apply gameobj-visible-name))


@@ -217,6 +216,9 @@
 
 (define gameobj-get-name (simple-slot-getter '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)
 (define-mhandler (gameobj-get-desc actor message whos-looking)
   (define desc-text
     (match (slot-ref actor 'desc)


@@ -225,10 +227,6 @@
       (desc desc)))
   (<-reply actor message #:val desc-text))
 
       (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."
 (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."

diff --git a/mudsync/parser.scm b/mudsync/parser.scm
index 5da6bc9f8c6c8c0ee8dd0f38a68891abfa2eca67..ab5a5d7d61dc2328f3e41b48b2385d48c9fa9f2b 100644 (file)
--- a/mudsync/parser.scm
+++ b/mudsync/parser.scm
@@ -61,7 +61,7 @@
 
 ;; definite and indefinite, but not partitive articles
 (define article '(or "the" "a" "an"))
 
 ;; 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
 
 (define indirect-irx
   (sre->irregex

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 594d913b0e0a50991641d93ea854f9371cb42e44..11920e2d04100b2420226eae915893a519725d24 100644 (file)
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -247,7 +247,7 @@ claim to point to."
      #f)))
 
 (define %formless-desc
      #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."
 
 (define-mhandler (room-look-at room message direct-obj)
   "Look at a specific object in the room."

diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm
index 5797785579950f23f596cd8ace21b1f3f1ddb190..3584e87c15dd0376bf91e3b5d16edfbd1936c6fc 100644 (file)
--- a/worlds/bricabrac.scm
+++ b/worlds/bricabrac.scm
@@ -19,10 +19,12 @@
 ;;; Hotel Bricabrac
 
 (use-modules (mudsync)
 ;;; Hotel Bricabrac
 
 (use-modules (mudsync)

+             (mudsync parser)

              (8sync systems actors)
              (8sync agenda)
              (oop goops)
              (8sync systems actors)
              (8sync agenda)
              (oop goops)

-             (ice-9 format))
+             (ice-9 format)
+             (rx irregex))

 
 
 \f
 
 
 \f


@@ -117,6 +119,51 @@ or 'skribe'?  Now *that's* composition!"))
     "a scroll of teletype paper holding the software Four Freedoms"
     "a telephone shaped like an orange cartoon cat"))
 
     "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
 (define lobby
   (lol
    ('room:lobby


@@ -180,7 +227,11 @@ Classy!"
              (format #f "  The curio cabinet is full of all sorts of oddities!
 Something catches your eye!
 Ooh, ~a!" (random-choice random-bricabrac))))
              (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
    ;; Object: desk
    ;;  - Object: bell
    ;;  - Object: sign in form