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))

(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)
  (display str)
  (let ((result (read-line)))
    (if (equal? "" result)
	(prompt str)
	result)))

(define (prompt-yn str)
  (newline)
  (display str)
  (let ((result (string-downcase (read-line))))
    (cond ((equal? "yes" result) #t)
	  ((equal? "no" result) #t)
	  (else (begin
		  (newline)
		  (display "Please answer yes or no.")
		  (prompt-yn str))))))

(define +articles-prepositions+
  '(a an the into on to at))

(define (adventure-prompt)
  (let ((result (parse (completely-parse parse-statement) (prompt "> "))))
    (if result
	(let ((grug-result (filter (lambda (n) (not (member n +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 (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 "Enter save name: ")))
    (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 "Enter save file name to load: ")))
    (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 (if (devmode-enabled?)
				      (get-all-objects)
				      (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-command-rename tag name)
  (if (not (and (symbol? tag) (string? name)))
      (show "I didn't quite understand that.")
      (if (not (object-exists? tag))
	  (show "That object doesn't exist.")
	  (begin
	    (set-name tag 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 +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-aliases direction)
  (let loop ((directions +cardinal-sets+))
    (if (null? directions)
	#f
	(if (member direction (car directions))
	    (remove direction (car directions))
	    (loop (cdr directions))))))

(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)
  (let loop ((directions +cardinal-sets+))
    (if (null? directions)
	#f
	(if (member direction (car directions))
	    (caar directions)
	    (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.")))))

(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))
    (_ 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))
	       (_ (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)