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