From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Fri, 6 May 2016 19:39:54 +0000 (-0500)
Subject: A bunch of stuff so you can set your own username
X-Git-Tag: fosdem-2017~161
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=10ff4122c37899d011ded00c5ebe1333f2477a34;p=mudsync.git

A bunch of stuff so you can set your own username
---

diff --git a/mudsync/command.scm b/mudsync/command.scm
index 3168738..23e21da 100644
--- a/mudsync/command.scm
+++ b/mudsync/command.scm
@@ -33,6 +33,7 @@
 
             direct-command
             indir-command
+            indir-as-direct-command
             loose-direct-command
             loose-indir-command
             empty-command
@@ -101,6 +102,18 @@
                 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
diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 91701ac..c34e89b 100644
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -27,11 +27,9 @@
   #: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
@@ -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))
+   (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))
@@ -217,6 +216,9 @@
 
 (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)
@@ -225,10 +227,6 @@
       (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."
diff --git a/mudsync/parser.scm b/mudsync/parser.scm
index 5da6bc9..ab5a5d7 100644
--- 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"))
-(define preposition '(or "with" "in" "on" "out of" "at"))
+(define preposition '(or "with" "in" "on" "out of" "at" "as"))
 
 (define indirect-irx
   (sre->irregex
diff --git a/mudsync/room.scm b/mudsync/room.scm
index 594d913..11920e2 100644
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -247,7 +247,7 @@ claim to point to."
      #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."
diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm
index 5797785..3584e87 100644
--- a/worlds/bricabrac.scm
+++ b/worlds/bricabrac.scm
@@ -19,10 +19,12 @@
 ;;; Hotel Bricabrac
 
 (use-modules (mudsync)
+             (mudsync parser)
              (8sync systems actors)
              (8sync agenda)
              (oop goops)
-             (ice-9 format))
+             (ice-9 format)
+             (rx irregex))
 
 
 
@@ -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"))
 
+(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
@@ -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))))
-
+   ('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