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

Refactoring finished.

Browse Source
This commit is contained in:
Victor Fors 2021-11-26 20:40:19 +01:00
parent c2d2ac3088
commit 7e005bb7cb
1 changed files with 1 additions and 441 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

442
kekkonen.scm
View File

@ -1,437 +1,9 @@
(import srfi-1)
(import srfi-14)
(import (chicken io))
(import srfi-13)
(import matchable)
(import fmt)
(import fmt-color)
(import fmt-unicode)
(import ansi-escape-sequences)
(import (chicken file))
(import breadline)
(import ncurses)
(import util)
(import lisp)
(import parse)
(import io)
(import database)
(define (type-of elem)
(cond ((pair? elem) 'pair)
((symbol? elem) 'symbol)
((number? elem) 'number)
((char? elem) 'char)
((string? elem) 'string)
((boolean? elem) 'boolean)))
(define (get-location object)
(database-get object 'location #f))
(define (set-name object name)
(database-set object 'name name))
(define (set-description object description)
(database-set object 'description description))
(define (get-name object)
(database-get object 'name (symbol->string object)))
(define (get-description object)
(database-get object 'description "You see the swirling void of creation."))
(define (get-container object)
(database-get object 'container #f))
(define (get-contents object)
(database-get object 'contents '()))
(define (set-destination object destination)
(database-set object 'destination destination))
(define (get-destination object)
(database-get object 'destination #f))
(define (set-enter-message object msg)
(database-set object 'enter-message msg))
(define (get-enter-message object)
(database-get object 'enter-message #f))
(define (get-aliases object)
(database-get object 'aliases '()))
(define (set-aliases object alias-list)
(database-set object 'aliases alias-list))
(define (add-alias object alias)
(let ((aliases (get-aliases object)))
(if (not (member alias aliases))
(set-aliases object (cons alias aliases)))))
(define (remove-alias object alias)
(let ((aliases (get-aliases object)))
(if (member alias aliases)
(set-aliases object (remove (curry eq? alias) aliases)))))
(define (set-hidden object value)
(database-set object 'hidden value))
(define (get-hidden object)
(database-get object 'hidden #f))
(define (set-fixed object value)
(database-set object 'fixed value))
(define (get-fixed object value)
(database-get object 'hidden #f))
(define (get-put-message object)
(database-get object 'put-message "You put the ~a into the ~a."))
;; Is development mode enabled?
(define (devmode-enabled?)
(has-property? 'you 'devmode))
(define (toggle-devmode)
(toggle-flag 'you 'devmode))
;; Is an object fixed in place (e.g. cannot be picked up?)
(define (fixed? object)
(has-property? object 'fixed))
(define (toggle-fixed object)
(toggle-flag object 'fixed))
;; Match a tag against a list of objects, checking for its tag and its aliases.
(define (match-object tag objects)
(let loop ((objects objects))
(if (null? objects)
#f
(let ((taglist (cons (car objects) (get-aliases (car objects)))))
(if (member tag taglist)
(car objects)
(loop (cdr objects)))))))
(define (create-object tag name description)
(set-name tag name)
(set-description tag description))
(define (move-object object container)
(let ((prev-container (get-container object)))
(database-set object 'container container)
(let ((contents (get-contents container)))
(if (not (member object contents))
(begin
(database-set container 'contents (cons object contents))
(database-set prev-container 'contents (remove (curry eq? object) (get-contents prev-container))))))))
;; Determine the objects visible to a source object, zork-style
(define (visible-objects source)
(let ((result (get-container source)))
(if (and result (object-exists? result))
(cons (get-container source) (get-contents (get-container source)))
(error "Tried to determine visible objects for object without a container."))))
(define (print-room-description room)
(newline)
(display (set-text '(bold) (get-name room)))
(if (devmode-enabled?) (display (set-text '(bold fg-green) (string-append " [" (symbol->string room) "]"))))
(newline)
(display " ")
(fmt #t (dsp (wrap-lines (get-description room))))
(newline)
(display "You see: ")
(map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ") (if (devmode-enabled?) (begin (display (set-text '(bold fg-green) (string-append "[" (symbol->string n) "] ")))))))) (remove (curry eq? 'you) (get-contents room)))
(newline))
(define (do-command-enter tag)
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You cannot go that way.")
(let ((destination (get-destination object)))
(if (not destination)
(show "You cannot enter that.")
(begin
(move-object 'you destination)
(perhaps show (get-enter-message object))
(print-room-description (get-container 'you))))))))
(define (do-command-save)
(let ((save-name (prompt-default "Enter save name: " "kekkonen.sav")))
(if (or (not (file-exists? save-name)) (prompt-yn "That file already exists. Overwrite? "))
(begin
(show "Saving database, please wait...")
(database-save save-name)
(show "Done.")))))
(define (do-command-load)
(let ((save-name (prompt-default "Enter save file name to load: " "kekkonen.sav")))
(if (not (file-exists? save-name))
(show "That file does not exist.")
(begin
(show "Loading database, please wait...")
(database-load save-name)
(show "Done.")))))
(define (do-command-look)
(print-room-description (get-container 'you)))
(define (do-command-examine tag)
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You cannot see that here.")
(show (get-description object)))))
(define (do-command-inventory)
(map (compose show get-name) (get-contents 'you)))
(define (do-command-take tag)
(if (not (symbol? tag))
(show "I didn't quite understand that.")
(let ((object (match-object tag (if (devmode-enabled?)
(get-all-objects)
(visible-objects 'you)))))
(if (or (not object) (and (fixed? object) (not (devmode-enabled?))))
(if object
(show "That is fixed in place.")
(show "You cannot see that here."))
(begin
(show (string-append "You get " (get-name object) "."))
(move-object object 'you))))))
(define (do-command-drop tag)
(if (not (symbol? tag))
(show "I didn't quite understand that.")
(let ((object (match-object tag (get-contents 'you))))
(if (not object)
(show "You are not carrying that.")
(begin
(show (string-append "You drop " (get-name object) "."))
(move-object object (get-container 'you)))))))
(define (do-command-put tag destination-tag)
(let ((object (match-object tag (get-contents 'you))))
(if (not object)
(show "You are not carrying that.")
(let ((destination-object (match-object destination-tag (visible-objects 'you))))
(if (not destination-object)
(show "You cannot see that here.")
(move-object object (get-destination destination-object)))))))
(define (do-command-devmode)
(toggle-devmode)
(if (devmode-enabled?)
(show "Development mode enabled.")
(show "Development mode disabled.")))
(define (do-command-create tag name description)
(if (not (and (symbol? tag) (string? name) (string? description)))
(show "I didn't quite understand that.")
(if (object-exists? tag)
(show "That object already exists.")
(begin
(create-object tag name description)
(move-object tag (get-container 'you))))))
(define (do-setter-command tag value type? setter)
(if (not (and (symbol? tag) (type? value)))
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(begin
(setter object value)
(show "You set a value."))))))
(define (do-command-rename tag name)
(do-setter-command tag name string? set-name))
(define (do-command-describe tag description)
(do-setter-command tag description string? set-description))
(define (do-command-flag tag flag)
(if (not (and (symbol? tag) (symbol? flag)))
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(begin
(case flag
((fixed) (set-fixed object #t))
((hidden) (set-hidden object #t))
(else (show "Invalid flag name."))))))))
(define (do-command-unflag tag flag)
(if (not (and (symbol? tag) (symbol? flag)))
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(begin
(case flag
((fixed) (set-fixed object #f))
((hidden) (set-hidden object #f))
(else (show "Invalid flag name."))))))))
(define (do-command-alias tag alias)
(if (not (and (symbol? tag) (symbol? alias)))
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(begin
(add-alias object alias)
(show "You add an alias."))))))
(define (do-command-unalias tag alias)
(if (not (and (symbol? tag) (symbol? alias)))
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(begin
(remove-alias object alias)
(show "You remove an alias."))))))
(define (do-command-destroy tag)
(if (not (symbol? tag))
(show "I didn't quite understand that.")
(database-remove tag)))
(define (do-command-aliases tag)
(if (not (symbol? tag))
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(begin
(newline)
(map (lambda (x) (display x) (display " ")) (get-aliases object))
(newline))))))
(define (do-command-message tag message-tag message)
(if (not (and (symbol? tag) (symbol? message-tag) (string? message)))
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(case message-tag
((enter) (set-enter-message object message))
(else (show "Invalid message name.")))))))
(define (do-command-goto tag)
(if (not (symbol? tag))
(show "I didn't quite understand that.")
(begin
(move-object 'you tag)
(print-room-description (get-container 'you)))))
(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-set direction)
(find (curry member direction) +cardinal-sets+))
(define (get-cardinal-aliases direction)
(perhaps (curry remove (curry eq? direction)) (get-cardinal-set direction)))
(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)
(perhaps car (get-cardinal-set direction)))
(define (do-command-dig direction destination)
(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)
(map (curry add-alias exit-tag) (get-cardinal-set direction))
(show "You create a passage."))))))))
(define (do-command-exit)
(show "Goodbye, see you later...")
(set! *exit-adventure* #t))
(define (alias-transform input)
(match input
(('quit) '(exit))
(('i) '(inventory))
(('inv) '(inventory))
(('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)
(let ((success #t))
(match input
(('look) (do-command-look))
(('save) (do-command-save))
(('load) (do-command-load))
(('devmode) (do-command-devmode))
(('exit) (do-command-exit))
(('enter x) (do-command-enter x))
(('take x) (do-command-take x))
(('drop x) (do-command-drop x))
(('inventory) (do-command-inventory))
(('examine x) (do-command-examine x))
(('put x y) (do-command-put x y))
(_ (if (devmode-enabled?)
(match input
(('create x y z) (do-command-create x y z))
(('rename x y) (do-command-rename x y))
(('describe x y) (do-command-describe x y))
(('dig x y) (do-command-dig x y))
(('flag x y) (do-command-flag x y))
(('unflag x y) (do-command-unflag x y))
(('alias x y) (do-command-alias x y))
(('unalias x y) (do-command-unalias x y))
(('destroy x) (do-command-destroy x))
(('aliases x) (do-command-aliases x))
(('message x y z) (do-command-message x y z))
(('goto x) (do-command-goto x))
(_ (set! success #f)))
(set! success #f))))
success))
(import world)
(create-object 'garden "A Well-Kept Garden" "A french-style garden with topiary in the shape of various animals. A fountain gurgles happily in the middle. A trail leads off into a forest to the north.")
(create-object 'unicorn "a frolicking unicorn" "A white unicorn, with a long spiral horn.")
@ -448,17 +20,5 @@
(set-destination 'trail 'forest)
(move-object 'unicorn 'garden)
(define *exit-adventure* #f)
(define (adventure)
(let ((success (dispatch-command (alias-transform (adventure-prompt)))))
(if (not success)
(begin
(show "I didn't quite understand that.")
(adventure))
(if *exit-adventure*
(show "Exiting..."); (display *database*)
(adventure)))))
(print-room-description (get-container 'you))
(adventure)