|
|
@@ -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) |
|
|
|