kekkonen/kekkonen.scm

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

(define (lift fn parser)
  (bind parser (compose result fn)))

(define (is-not x)
  (satisfies (lambda (y)
	       (not (eqv? x y)))))

(define (curry fn a)
  (lambda (b)
    (fn a b)))

(define (applied fn)
  (curry apply fn))

(define-syntax thunk
  (syntax-rules ()
    ((_ exp ...)
     (lambda () exp ...))))

(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 (any-or fn ln thunk)
  (let loop ((ln ln))
    (if (null? ln)
	(thunk)
	(let ((result (fn (car ln))))
	  (if result
	      result
	      (loop (cdr ln)))))))

(define (run-lisp body)

  (define (lisp body environments lisp-exit)
    
    (define (reference symbol)
      (cdr (any-or (curry assoc symbol) (cons lisp-builtins environments) (thunk (lisp-exit (string-append "Undefined reference: " (symbol->string symbol)))))))
    
    (define (lisp-apply function args)
      (cond ((procedure? function)
	     (apply function args))
	    ((list? function)
	     (let ((function-arguments (cadr function))
		   (function-body (cddr function)))
	       (lisp function-body (cons (if (= (length function-arguments) (length argument-values))
					      (map cons function-arguments args)
					      (lisp-exit "Wrong number of arguments to function")) environments) lisp-exit)))
	    (else (lisp-exit "attempt to call atom"))))
    
    (define (lisp-eval body)
      (cond ((symbol? body) (reference body))
	    ((atom? body) body)
	    ((list? body) (let ((ln (map lisp-eval body)))
			    (lisp-apply (car ln) (cdr ln))))
	    (else (lisp-exit "Unknown value type in evaluation."))))
    
    (define (bind name value)
      (set! environments (cons (let loop ((environment (car environments)))
				 (if (null? environment)
				     (list (cons name value))
				     (if (eq? name (caar environment))
					 (cons (cons name value) (cdr environment))
					 (cons (car environment) (loop (cdr environment))))))
			       (cdr environments))))
    
    (define lisp-builtins
      `((test . ,(lambda function-args
		   (show "test function called")))
	(if . ,(lambda function-args
		 (match function-args
		   ((e x y) (if (lisp-eval e)
				(lisp-eval x)
				(lisp-eval y)))
		   (_ (lisp-exit "malformed if expression")))))
	(quote . ,(lambda function-args
		    (match function-args
		      ((v) v)
		      (_ (lisp-exit "malformed quote expression")))))
	(cons . ,(lambda function-args
		   (match function-args
		     ((a b) (cons a b))
		     (_ (lisp-exit "malformed cons expression")))))
	(car . ,(lambda function-args
		  (match function-args
		    ((a) (if (atom? a)
			     (lisp-exit "tried to take car of atom")
			     (car a)))
		    (_ (lisp-exit "malformed car expression")))))
	(cdr . ,(lambda function-args
		  (match function-args
		    ((a) (if (atom? a)
			     (lisp-exit "tried to take cdr of atom")
			     (cdr a)))
		    (_ (lisp-exit "malformed cdr expression")))))
	(atom . ,(lambda function-args
		   (match function-args
		     ((a) (atom? a))
		     (_ (lisp-exit "malformed atom expression")))))
	(eq . ,(lambda function-args
		 (match function-args
		   ((a b) (equal? a b))
		   (_ (lisp-exit "malformed eq expression")))))
	(set . ,(lambda function-args
		  (match function-args
		    ((a b) (if (symbol? a)
			       (bind a b)
			       (lisp-exit "tried to bind to non-symbol")))
		    (_ (lisp-exit "malformed set expression")))))
	(lambda . ,(lambda function-args
		     (match function-args
		       ((args exp . exps)
			(if (and (list? args) (every symbol? args))
			    (cons args (cons exp exps))
			    (lisp-exit "malformed lambda expression"))
			(_ (lisp-exit "malformed lambda expression"))))))))
    
    (lisp-eval body))

  (call/cc (lambda (lisp-exit)
	     (cons #t (lisp body (list) (compose lisp-exit (curry cons #f)))))))

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