|
@@ -11,6 +11,8 @@ |
|
|
(import (chicken file)) |
|
|
(import (chicken file)) |
|
|
(import breadline) |
|
|
(import breadline) |
|
|
(import ncurses) |
|
|
(import ncurses) |
|
|
|
|
|
(import util) |
|
|
|
|
|
(import lisp) |
|
|
|
|
|
|
|
|
(define (lift fn parser) |
|
|
(define (lift fn parser) |
|
|
(bind parser (compose result fn))) |
|
|
(bind parser (compose result fn))) |
|
@@ -19,18 +21,6 @@ |
|
|
(satisfies (lambda (y) |
|
|
(satisfies (lambda (y) |
|
|
(not (eqv? x y))))) |
|
|
(not (eqv? x y))))) |
|
|
|
|
|
|
|
|
(define (curry fn a) |
|
|
|
|
|
(lambda (b) |
|
|
|
|
|
(fn a b))) |
|
|
|
|
|
|
|
|
|
|
|
(define (applied fn) |
|
|
|
|
|
(curry apply fn)) |
|
|
|
|
|
|
|
|
|
|
|
(define-syntax thunk |
|
|
|
|
|
(syntax-rules () |
|
|
|
|
|
((_ exp ...) |
|
|
|
|
|
(lambda () exp ...)))) |
|
|
|
|
|
|
|
|
|
|
|
(define parse-whitespace |
|
|
(define parse-whitespace |
|
|
(one-or-more (is #\space))) |
|
|
(one-or-more (is #\space))) |
|
|
|
|
|
|
|
@@ -319,111 +309,6 @@ |
|
|
(cons (get-container source) (get-contents (get-container source))) |
|
|
(cons (get-container source) (get-contents (get-container source))) |
|
|
(error "Tried to determine visible objects for object without a container.")))) |
|
|
(error "Tried to determine visible objects for object without a container.")))) |
|
|
|
|
|
|
|
|
(define (any-or fn ln thunk) |
|
|
|
|
|
(let loop ((ln ln)) |
|
|
|
|
|
(if (null? ln) |
|
|
|
|
|
(thunk) |
|
|
|
|
|
(let ((result (fn (car ln)))) |
|
|
|
|
|
(if result |
|
|
|
|
|
result |
|
|
|
|
|
(loop (cdr ln))))))) |
|
|
|
|
|
|
|
|
|
|
|
(define (run-lisp body) |
|
|
|
|
|
|
|
|
|
|
|
(define (lisp body environments lisp-exit) |
|
|
|
|
|
|
|
|
|
|
|
(define (reference symbol) |
|
|
|
|
|
(cdr (any-or (curry assoc symbol) (cons lisp-builtins environments) (thunk (lisp-exit (string-append "Undefined reference: " (symbol->string symbol))))))) |
|
|
|
|
|
|
|
|
|
|
|
(define (lisp-apply function args) |
|
|
|
|
|
(cond ((procedure? function) |
|
|
|
|
|
(apply function args)) |
|
|
|
|
|
((list? function) |
|
|
|
|
|
(let ((function-arguments (car function)) |
|
|
|
|
|
(function-body (cdr function))) |
|
|
|
|
|
(lisp function-body (cons (if (= (length function-arguments) (length args)) |
|
|
|
|
|
(map cons function-arguments args) |
|
|
|
|
|
(lisp-exit "Wrong number of arguments to function")) environments) lisp-exit))) |
|
|
|
|
|
(else (lisp-exit "attempt to call atom")))) |
|
|
|
|
|
|
|
|
|
|
|
(define (lisp-eval body) |
|
|
|
|
|
(cond ((symbol? body) (reference body)) |
|
|
|
|
|
((atom? body) body) |
|
|
|
|
|
((list? body) (lisp-apply (lisp-eval (car body)) (cdr body))) |
|
|
|
|
|
(else (lisp-exit "Unknown value type in evaluation.")))) |
|
|
|
|
|
|
|
|
|
|
|
(define (bind name value) |
|
|
|
|
|
(set! environments (cons (let loop ((environment (car environments))) |
|
|
|
|
|
(if (null? environment) |
|
|
|
|
|
(list (cons name value)) |
|
|
|
|
|
(if (eq? name (caar environment)) |
|
|
|
|
|
(cons (cons name value) (cdr environment)) |
|
|
|
|
|
(cons (car environment) (loop (cdr environment)))))) |
|
|
|
|
|
(cdr environments)))) |
|
|
|
|
|
|
|
|
|
|
|
(define lisp-builtins |
|
|
|
|
|
`((test . ,(lambda function-args |
|
|
|
|
|
(show "test function called"))) |
|
|
|
|
|
(if . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((e x y) (if (lisp-eval e) |
|
|
|
|
|
(lisp-eval x) |
|
|
|
|
|
(lisp-eval y))) |
|
|
|
|
|
(_ (lisp-exit "malformed if expression"))))) |
|
|
|
|
|
(quote . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((v) v) |
|
|
|
|
|
(_ (lisp-exit "malformed quote expression"))))) |
|
|
|
|
|
(cons . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((a b) (cons (lisp-eval a) (lisp-eval b))) |
|
|
|
|
|
(_ (lisp-exit "malformed cons expression"))))) |
|
|
|
|
|
(car . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((a) (let ((e (lisp-eval a))) |
|
|
|
|
|
(if (atom? e) |
|
|
|
|
|
(lisp-exit "tried to take car of atom") |
|
|
|
|
|
(car e)))) |
|
|
|
|
|
(_ (lisp-exit "malformed car expression"))))) |
|
|
|
|
|
(cdr . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((a) (let ((e (lisp-eval a))) |
|
|
|
|
|
(if (atom? e) |
|
|
|
|
|
(lisp-exit "tried to take cdr of atom") |
|
|
|
|
|
(cdr e)))) |
|
|
|
|
|
(_ (lisp-exit "malformed cdr expression"))))) |
|
|
|
|
|
(atom . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((a) (let ((e (lisp-eval a))) |
|
|
|
|
|
(atom? e))) |
|
|
|
|
|
(_ (lisp-exit "malformed atom expression"))))) |
|
|
|
|
|
(eq . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((a b) (let ((ea (eval a)) |
|
|
|
|
|
(eb (eval b))) |
|
|
|
|
|
(equal? ea eb))) |
|
|
|
|
|
(_ (lisp-exit "malformed eq expression"))))) |
|
|
|
|
|
(set . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((a b) (let ((ea (eval a)) |
|
|
|
|
|
(eb (eval b))) |
|
|
|
|
|
(if (symbol? a) |
|
|
|
|
|
(bind a b) |
|
|
|
|
|
(lisp-exit "tried to bind to non-symbol")))) |
|
|
|
|
|
(_ (lisp-exit "malformed set expression"))))) |
|
|
|
|
|
(lambda . ,(lambda function-args |
|
|
|
|
|
(match function-args |
|
|
|
|
|
((args exp . exps) |
|
|
|
|
|
(if (and (list? args) (every symbol? args)) |
|
|
|
|
|
(cons args (cons exp exps)) |
|
|
|
|
|
(lisp-exit "malformed lambda expression"))) |
|
|
|
|
|
(_ (lisp-exit "malformed lambda expression"))))))) |
|
|
|
|
|
|
|
|
|
|
|
(lisp-eval body)) |
|
|
|
|
|
|
|
|
|
|
|
(call/cc (lambda (lisp-exit) |
|
|
|
|
|
(cons #t (lisp body (list) (compose lisp-exit (curry cons #f))))))) |
|
|
|
|
|
|
|
|
|
|
|
(define (print-room-description room) |
|
|
(define (print-room-description room) |
|
|
(newline) |
|
|
(newline) |
|
|
(display (set-text '(bold) (get-name room))) |
|
|
(display (set-text '(bold) (get-name room))) |
|
|