diff --git a/kekkonen.scm b/kekkonen.scm index 74d193d..c112631 100644 --- a/kekkonen.scm +++ b/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) - (let loop ((ln ln)) - (case (length ln) - ((0) '()) - ((1) (list (symbol->string (car ln)))) - (else (string-append (symbol->string (car ln)) "-" (loop (cdr ln))))))) + (string->symbol + (let loop ((ln ln)) + (case (length ln) + ((0) '()) + ((1) (symbol->string (car 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)