modules

kekkonen.scm

@@ -13,6 +13,8 @@
 (import util)
 (import lisp)
 (import parse)
+(import io)
+(import database)
 
 (define (type-of elem)
   (cond ((pair? elem) 'pair)
@@ -22,115 +24,6 @@
 	((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-line (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))
 
@@ -564,7 +457,7 @@
 	  (show "I didn't quite understand that.")
 	  (adventure))
 	(if *exit-adventure*
-	    (display *database*)
+	    (show "Exiting..."); (display *database*)
 	    (adventure)))))
 
 (print-room-description (get-container 'you))

util.scm

@@ -1,5 +1,7 @@
-(module util (curry applied thunk just perhaps)
+(module util (curry applied thunk just perhaps compose-symbols)
   (import scheme)
+  (import chicken.base)
+  (import srfi-13)
 
   (define (curry fn a)
   (lambda (b)
@@ -20,4 +22,7 @@
   (define (perhaps fn arg)
     (if arg
 	(fn arg)
-      arg)))
+	arg))
+
+  (define (compose-symbols . ln)
+    (string->symbol (string-concatenate (intersperse (map symbol->string ln) "-")))))