diggy diggy hole

kekkonen.scm

@@ -22,7 +22,7 @@
   (skip (zero-or-more (is #\space))))
 
 (define +letter-char-set+
-  (string->char-set "abcdefghijklmnopqrstuvxyzABCDEFGHIJKLMNOPQRSTUVXYZ"))
+  (string->char-set "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVwXYZ"))
 
 (define +symbol-char-set+
   (char-set-union +letter-char-set+ (string->char-set "-0123456789")))
@@ -116,11 +116,12 @@
 	       (adventure-prompt)))))
 
 (define (compose-symbols . ln)
+  (string->symbol
    (let loop ((ln ln))
      (case (length ln)
        ((0) '())
-      ((1) (list (symbol->string (car ln))))
+       ((1) (symbol->string (car ln)))
-      (else (string-append (symbol->string (car ln)) "-" (loop (cdr ln)))))))
+       (else (string-append (symbol->string (car ln)) "-" (loop (cdr ln))))))))
 
 (define *database* '())
 
@@ -219,6 +220,12 @@
     (if (member alias aliases)
 	(set-aliases object (remove (cut eq? alias <>) aliases)))))
 
+(define (set-hidden object value)
+  (database-set object 'hidden value))
+
+(define (get-hidden object)
+  (database-get object 'hidden #f))
+
 (define (get-put-message object)
   (database-get object 'put-message "You put the ~a into the ~a."))
 
@@ -269,6 +276,17 @@
       (cons (get-container source) (get-contents (get-container source)))
       (error "Tried to determine visible objects for object without a container."))))
 
+(define (print-room-description room)
+  (newline)
+  (display (set-text '(bold) (get-name room)))
+  (newline)
+  (display "    ")
+  (fmt #t (dsp (wrap-lines (get-description room))))
+  (newline)
+  (display "You see: ")
+  (map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ")))) (remove (cut eq? 'you <>) (get-contents room)))
+  (newline))
+
 (define (do-command-enter tag)
   (let ((object (match-object tag (visible-objects 'you))))
     (if (not object)
@@ -281,17 +299,6 @@
 	      (perhaps show (get-enter-message object))
 	      (print-room-description (get-container 'you))))))))
 
-(define (print-room-description room)
-  (newline)
-  (display (set-text '(bold) (get-name room)))
-  (newline)
-  (display "    ")
-  (fmt #t (dsp (wrap-lines (get-description room))))
-  (newline)
-  (display "You see: ")
-  (map (lambda (n) (display n) (display " ")) (map get-name (remove (cut eq? 'you <>) (get-contents room))))
-  (newline))
-
 (define (do-command-save)
   (let ((save-name (prompt "Enter save name: ")))
     (if (or (not (file-exists? save-name)) (prompt-yn "That file already exists. Overwrite? "))
@@ -378,7 +385,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.")
@@ -387,8 +394,16 @@
 	  (begin
 	    (set-description tag description)))))
 
-;;(define (do-command-dig direction destination)
+(define (do-command-dig direction destination)
-;;  (
+  (let ((exit-tag (compose-symbols direction (get-container 'you) destination)))
+    (if (object-exists? exit-tag)
+	(show "An exit like that already exists.")
+	(begin
+	  (move-object exit-tag (get-container 'you))
+	  (set-hidden exit-tag #t)
+	  (set-destination exit-tag destination)
+	  (add-alias exit-tag direction)
+	  (show "You create a passage.")))))
 
 (define (do-command-exit)
   (show "Goodbye, see you later...")
@@ -423,16 +438,19 @@
 	       (('create x y z) (do-command-create x y z))
 	       (('rename x y) (do-command-rename x y))
 	       (('describe x y) (do-command-describe x y))
-	       (('dig x y) (do-command dig x y))
+	       (('dig x y) (do-command-dig x y))
 	       (_ (set! success #f)))
 	     (set! success #f))))
     success))
 
-(create-object 'garden "A Well-Kept Garden" "A french-style garden with topiary in the shape of various animals. A fountain gurgles happily in the middle.")
+(create-object 'garden "A Well-Kept Garden" "A french-style garden with topiary in the shape of various animals. A fountain gurgles happily in the middle. A trail leads off into a forest to the north.")
 (create-object 'unicorn "a frolicking unicorn" "A white unicorn, with a long spiral horn.")
 (create-object 'forest "A Foreboding Forest" "Tall trees bunch around a winding path.")
 (create-object 'trail "a trail" "A winding trail.")
 (add-alias 'trail 'winding)
+(add-alias 'trail 'north)
+(add-alias 'trail 'n)
+(set-hidden 'trail #t)
 (set-enter-message 'trail "You walk along the winding trail...")
 (move-object 'you 'garden)
 (move-object 'trail 'garden)