put

kekkonen.scm

@@ -8,8 +8,8 @@
 (import ansi-escape-sequences)
 (import (chicken file))
 
-; (define (lift fn parser)
-;   (bind parser (compose result fn)))
+(define (lift fn parser)
+  (bind parser (compose result fn)))
 
 (define (is-not x)
   (satisfies (lambda (y)
@@ -21,8 +21,15 @@
 (define skip-whitespace
   (skip (zero-or-more (is #\space))))
 
+(define +letter-char-set+
+  (string->char-set "abcdefghijklmnopqrstuvxyzABCDEFGHIJKLMNOPQRSTUVXYZ"))
+
+(define +symbol-char-set+
+  (char-set-union +letter-char-set+ (string->char-set "-0123456789")))
+
 (define parse-symbol
-  (lift (compose string->symbol string-downcase list->string) (one-or-more (in char-set:letter))))
+  (lift (compose string->symbol string-downcase list->string (cut apply append <>))
+	(sequence (lift list (in +letter-char-set+)) (zero-or-more (in +symbol-char-set+)))))
 
 (define parse-number
   (lift (compose string->number list->string) (one-or-more (in char-set:digit))))
@@ -108,6 +115,13 @@
 	(begin (display "I didn't quite understand that.")
 	       (adventure-prompt)))))
 
+(define (compose-symbols . ln)
+  (let loop ((ln ln))
+    (case (length ln)
+      ((0) '())
+      ((1) (list (symbol->string (car ln))))
+      (else (string-append (symbol->string (car ln)) "-" (loop (cdr ln)))))))
+
 (define *database* '())
 
 (define (database-set name key value)
@@ -205,6 +219,9 @@
     (if (member alias aliases)
 	(set-aliases object (remove (cut eq? alias <>) aliases)))))
 
+(define (get-put-message object)
+  (database-get object 'put-message "You put the ~a into the ~a."))
+
 ;; Is development mode enabled?
 
 (define (devmode-enabled?)
@@ -330,6 +347,15 @@
 	      (show (string-append "You drop " (get-name object) "."))
 	      (move-object object (get-container 'you)))))))
 
+(define (do-command-put tag destination-tag)
+  (let ((object (match-object tag (get-contents 'you))))
+    (if (not object)
+	(show "You are not carrying that.")
+	(let ((destination-object (match-object destination-tag (visible-objects 'you))))
+	  (if (not destination-object)
+	      (show "You cannot see that here.")
+	      (move-object object (get-destination destination-object)))))))
+
 (define (do-command-devmode)
   (toggle-devmode)
   (if (devmode-enabled?)
@@ -352,7 +378,7 @@
 	  (show "That object doesn't exist.")
 	  (begin
 	    (set-name tag name)))))
-
++
 (define (do-command-describe tag description)
   (if (not (and (symbol? tag) (string? description)))
       (show "I didn't quite understand that.")