whiteline/kekkonen
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

modules

Browse Source
This commit is contained in:
Victor Fors 2021-11-23 19:18:07 +01:00
parent c9468bee67
commit c2d2ac3088
2 changed files with 16 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
kekkonen.scm
View File

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

21
util.scm
View File

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