kekkonen/kekkonen.scm

(import comparse)
(import srfi-1)
(import srfi-14)
(import (chicken io))
(import srfi-13)
(import matchable)
(import fmt)
(import ansi-escape-sequences)
(import (chicken file))
(import breadline)

(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 (cut apply 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 (cut map display-newline <>) ln))

(define (parse-input)
  (parse (completely-parse parse-statement) (read-line)))

(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 (cut write *database*)))

(define (database-load filename)
  (with-input-from-file filename (lambda () (set! *database* (car (read-list))))))

(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 (cut 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 (cut 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)))
  (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 " ")))) (remove (cut 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 +object-flags+
  '(fixed hidden))

(define (do-command-flag tag flag)
  (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+)))
      (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))))))))

(define (do-command-unflag tag flag)
  (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+)))
      (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))))))))

(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-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 +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 (cut member direction <>) +cardinal-sets+))

(define (get-cardinal-aliases direction)
  (perhaps (cut remove (cut 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 (cut 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))
	       (('message x y z) (do-command-message x y z))
	       (_ (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)