diff --git a/kekkonen.scm b/kekkonen.scm index a765049..90a9041 100644 --- a/kekkonen.scm +++ b/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)) diff --git a/util.scm b/util.scm index 8424100..94ee8d4 100644 --- a/util.scm +++ b/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) @@ -13,11 +15,14 @@ ((_ exp ...) (lambda () exp ...)))) -(define (just fn) - (lambda args - (fn))) + (define (just fn) + (lambda args + (fn))) -(define (perhaps fn arg) - (if arg - (fn arg) - arg))) + (define (perhaps fn arg) + (if arg + (fn arg) + arg)) + + (define (compose-symbols . ln) + (string->symbol (string-concatenate (intersperse (map symbol->string ln) "-")))))