whiteline/kekkonen
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

programmation

Browse Source
This commit is contained in:
Victor Fors 2020-10-06 17:17:45 +02:00
parent 1c7b62ce01
commit 488af550de
1 changed files with 32 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
kekkonen.scm
View File

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