|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638 |
- (import comparse)
- (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)
-
- (define (lift fn parser)
- (bind parser (compose result fn)))
-
- (define (is-not x)
- (satisfies (lambda (y)
- (not (eqv? x y)))))
-
- (define parse-whitespace
- (one-or-more (is #\space)))
-
- (define skip-whitespace
- (skip (zero-or-more (is #\space))))
-
- (define +letter-char-set+
- (string->char-set "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVwXYZ"))
-
- (define +symbol-char-set+
- (char-set-union +letter-char-set+ (string->char-set "-0123456789")))
-
- (define parse-symbol
- (lift (compose string->symbol string-downcase list->string (applied append))
- (sequence (lift list (in +letter-char-set+)) (zero-or-more (in +symbol-char-set+)))))
-
- (define parse-number
- (lift (compose string->number list->string) (one-or-more (in char-set:digit))))
-
- (define parse-string
- (lift list->string (enclosed-by (is #\") (one-or-more (is-not #\")) (is #\"))))
-
- (define (followed-by-consuming parser separator)
- (sequence* ((value parser) (_ separator))
- (result value)))
-
- (define (separated-by separator parser)
- (one-or-more (any-of (followed-by-consuming parser separator) parser)))
-
- (define parse-symbol-or-number-or-string
- (any-of parse-number parse-symbol parse-string))
-
- (define (completely-parse parser)
- (followed-by parser end-of-input))
-
- (define parse-statement
- (all-of skip-whitespace (separated-by parse-whitespace parse-symbol-or-number-or-string)))
-
- (define (just fn)
- (lambda args
- (fn)))
-
- (define (perhaps fn arg)
- (if arg
- (fn arg)
- arg))
-
- (define display-newline
- (compose (just newline) display))
-
- (define (display-lines ln)
- (perhaps (curry map display-newline) ln))
-
- (define (parse-input)
- (parse (completely-parse parse-statement) (read-line)))
-
- (define parse-formatter
- (recursive-parser (one-or-more (any-of (followed-by-consuming (char-seq "<b>") (lift fmt-bold parser))
- (is-not #\<)))))
-
- (define (type-of elem)
- (cond ((pair? elem) 'pair)
- ((symbol? elem) 'symbol)
- ((number? elem) 'number)
- ((char? elem) 'char)
- ((string? elem) 'string)
- ((boolean? elem) 'boolean)))
-
- (define (show str)
- (fmt #t (dsp (wrap-lines str))))
-
- (define (prompt str)
- (newline)
- (let ((result (readline str)))
- (if (equal? "" result)
- (prompt str)
- (begin
- (add-history! result)
- result))))
-
- (define (prompt-yn str)
- (newline)
- (let ((result (string-downcase (readline str))))
- (cond ((equal? "yes" result) #t)
- ((equal? "no" result) #f)
- (else (begin
- (newline)
- (display "Please answer yes or no.")
- (prompt-yn str))))))
-
- (define (prompt-default str default)
- (map stuff-char (string->list default))
- (let loop ()
- (let ((result (readline str)))
- (if (equal? "" result)
- (loop)
- result))))
-
- (define +articles-prepositions+
- '(a an the into on to at as))
-
- (define (adventure-prompt)
- (let ((result (parse (completely-parse parse-statement) (prompt "> "))))
- (if result
- (let ((grug-result (filter (compose not (cut member <> +articles-prepositions+)) result)))
- (if (not (null? grug-result))
- grug-result
- (begin (display "I didn't quite understand that.")
- (adventure-prompt))))
- (begin (display "I didn't quite understand that.")
- (adventure-prompt)))))
-
- (define (compose-symbols . ln)
- (string->symbol
- (let loop ((ln ln))
- (case (length ln)
- ((0) '())
- ((1) (symbol->string (car ln)))
- (else (string-append (symbol->string (car ln)) "-" (loop (cdr ln))))))))
-
- (define *database* '())
-
- (define (database-set name key value)
- (set! *database* (let loop ((kv *database*))
- (if (null? kv)
- (list (cons name (list (cons key value))))
- (if (equal? name (caar kv))
- (cons (cons name (let loop ((kv (cdar kv)))
- (if (null? kv)
- (list (cons key value))
- (if (equal? key (caar kv))
- (cons (cons key value) (cdr kv))
- (cons (car kv) (loop (cdr kv))))))) (cdr kv))
- (cons (car kv) (loop (cdr kv))))))))
-
- (define (database-get name key default)
- (let loop ((kv *database*))
- (if (null? kv)
- default
- (if (equal? name (caar kv))
- (let loop ((kv (cdar kv)))
- (if (null? kv)
- default
- (if (equal? key (caar kv))
- (cdar kv)
- (loop (cdr kv)))))
- (loop (cdr kv))))))
-
- (define (database-save filename)
- (with-output-to-file filename (thunk (write *database*))))
-
- (define (database-load filename)
- (with-input-from-file filename (thunk (set! *database* (car (read-list))))))
-
- (define (database-remove name)
- (let loop ((kv *database*))
- (if (null? kv)
- '()
- (if (equal? name (caar kv))
- (cdr kv)
- (cons (car kv) (loop (cdr kv)))))))
-
-
- (define (get-all-objects)
- (map car *database*))
-
- (define (object-exists? object)
- (member object (get-all-objects)))
-
- (define (has-property? object property)
- (database-get object property #f))
-
- (define (toggle-flag object flag)
- (if (has-property? object flag)
- (database-set object flag #f)
- (database-set object flag #t)))
-
- (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))
-
- (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.")
- (create-object 'forest "A Foreboding Forest" "Tall trees bunch around a winding path.")
- (create-object 'trail "a trail" "A winding trail.")
- (add-alias 'trail 'winding)
- (add-alias 'trail 'north)
- (add-alias 'trail 'n)
- (set-hidden 'trail #t)
- (set-enter-message 'trail "You walk along the winding trail...")
- (move-object 'you 'garden)
- (move-object 'trail 'garden)
- (toggle-fixed 'trail)
- (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*
- (display *database*)
- (adventure)))))
-
- (print-room-description (get-container 'you))
- (adventure)
|