diff --git a/kekkonen.scm b/kekkonen.scm index 975929c..143cb9b 100644 --- a/kekkonen.scm +++ b/kekkonen.scm @@ -385,7 +385,8 @@ (if (not object) (show "You can't see that here.") (begin - (setter tag value)))))) + (setter object value) + (show "You set a value.")))))) (define (do-command-rename tag name) (do-setter-command tag name string? set-name)) @@ -417,13 +418,11 @@ (up . down) (down . up))) +(define (get-cardinal-set direction) + (find (cut member direction <>) +cardinal-sets+)) + (define (get-cardinal-aliases direction) - (let loop ((directions +cardinal-sets+)) - (if (null? directions) - #f - (if (member direction (car directions)) - (remove (cut eq? direction <>) (car directions)) - (loop (cdr directions)))))) + (perhaps (cut remove (cut eq? direction <>) <>) (get-cardinal-set direction))) (define (cardinal-direction? direction) (list? (member direction (flatten +cardinal-sets+)))) @@ -432,12 +431,7 @@ (perhaps cdr (assoc direction +cardinal-opposites+))) (define (get-canonical-cardinal-direction-name direction) - (let loop ((directions +cardinal-sets+)) - (if (null? directions) - #f - (if (member direction (car directions)) - (caar directions) - (loop (cdr directions)))))) + (perhaps car (get-cardinal-set direction))) (define (do-command-dig direction destination) (if (not (and (symbol? direction) (symbol? destination))) @@ -452,8 +446,7 @@ (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)) + (map (cut add-alias exit-tag <>) (get-cardinal-set direction)) (show "You create a passage.")))))))) (define (do-command-exit)