diff --git a/kekkonen.scm b/kekkonen.scm index 8d7b4b5..40d2445 100644 --- a/kekkonen.scm +++ b/kekkonen.scm @@ -102,7 +102,7 @@ (prompt-yn str)))))) (define +articles-prepositions+ - '(a an the into on to at)) + '(a an the into on to at as)) (define (adventure-prompt) (let ((result (parse (completely-parse parse-statement) (prompt "> ")))) @@ -378,21 +378,20 @@ (create-object tag name description) (move-object tag (get-container 'you)))))) -(define (do-command-rename tag name) - (if (not (and (symbol? tag) (string? name))) +(define (define-setter-command tag value type? setter) + (if (not (and (symbol? tag) (type? value))) (show "I didn't quite understand that.") - (if (not (object-exists? tag)) - (show "That object doesn't exist.") - (begin - (set-name tag name))))) + (let ((object (match-object tag (visible-objects 'you)))) + (if (not object) + (show "You can't see that here.") + (begin + (setter tag value)))))) + +(define (do-command-rename tag name) + (define-setter-command tag name string? set-name)) (define (do-command-describe tag description) - (if (not (and (symbol? tag) (string? description))) - (show "I didn't quite understand that.") - (if (not (object-exists? tag)) - (show "That object doesn't exist.") - (begin - (set-description tag description))))) + (define-setter-command tag description string? set-description)) (define +cardinal-sets+ '((north n) @@ -423,7 +422,7 @@ (if (null? directions) #f (if (member direction (car directions)) - (remove direction (car directions)) + (remove (cut eq? direction <>) (car directions)) (loop (cdr directions)))))) (define (cardinal-direction? direction) @@ -441,18 +440,22 @@ (loop (cdr directions)))))) (define (do-command-dig direction destination) - (if (not (and (symbol? direction) (symbol? destination) - (member direction '( - (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."))))) - + (if (not (and (symbol? direction) (symbol? destination))) + (show "I didn't quite understand that.") + (if (not (cardinal-direction? direction)) + (show "You must specify a compass rose direction or up and down.") + (let ((canonical-direction (get-canonical-cardinal-direction-name direction))) + (let ((exit-tag (compose-symbols canonical-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 canonical-direction) + (map (cut add-alias exit-tag <>) (get-cardinal-aliases canonical-direction)) + (show "You create a passage.")))))))) + (define (do-command-exit) (show "Goodbye, see you later...") (set! *exit-adventure* #t)) @@ -465,6 +468,9 @@ (('look x) `(examine ,x)) (('go x) `(enter ,x)) (('get x) `(take ,x)) + ((x) (if (cardinal-direction? x) + `(enter ,x) + input)) (_ input))) (define (dispatch-command input)