From 7e005bb7cb178ebd2383ef681d5677def4064db6 Mon Sep 17 00:00:00 2001
From: Victor Fors <krakow89@gmail.com>
Date: Fri, 26 Nov 2021 20:40:19 +0100
Subject: [PATCH] Refactoring finished.

---
 kekkonen.scm | 442 +----------------------------------------------------------
 1 file changed, 1 insertion(+), 441 deletions(-)

diff --git a/kekkonen.scm b/kekkonen.scm
index 90a9041..761bb3c 100644
--- a/kekkonen.scm
+++ b/kekkonen.scm
@@ -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)