|
|
@@ -394,7 +394,55 @@ |
|
|
|
(begin |
|
|
|
(set-description tag description))))) |
|
|
|
|
|
|
|
(define +cardinal-sets+ |
|
|
|
'((north n) |
|
|
|
(northeast ne north-east) |
|
|
|
(east e) |
|
|
|
(southeast se south-east) |
|
|
|
(south s) |
|
|
|
(southwest sw south-west) |
|
|
|
(west w) |
|
|
|
(northwest nw north-west) |
|
|
|
(up u) |
|
|
|
(down d))) |
|
|
|
|
|
|
|
(define +cardinal-opposites+ |
|
|
|
'((north . south) |
|
|
|
(northeast . southwest) |
|
|
|
(east . west) |
|
|
|
(southeast . northwest) |
|
|
|
(south . north) |
|
|
|
(southwest . northeast) |
|
|
|
(west . east) |
|
|
|
(northwest . southeast) |
|
|
|
(up . down) |
|
|
|
(down . up))) |
|
|
|
|
|
|
|
(define (get-cardinal-aliases direction) |
|
|
|
(let loop ((directions +cardinal-sets+)) |
|
|
|
(if (null? directions) |
|
|
|
#f |
|
|
|
(if (member direction (car directions)) |
|
|
|
(remove direction (car directions)) |
|
|
|
(loop (cdr directions)))))) |
|
|
|
|
|
|
|
(define (cardinal-direction? direction) |
|
|
|
(list? (member direction (flatten +cardinal-sets+)))) |
|
|
|
|
|
|
|
(define (get-inverse-direction direction) |
|
|
|
(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)))))) |
|
|
|
|
|
|
|
(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.") |
|
|
|