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))))))
(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,17 +440,21 @@
(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...")
@ -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)