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

refactor into modules

Browse Source
This commit is contained in:
Victor Fors 2021-11-18 14:52:15 +01:00
parent b6a3daaa13
commit 6aac70e78f
3 changed files with 127 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
kekkonen.scm
View File

@ -11,6 +11,8 @@
(import (chicken file))
(import breadline)
(import ncurses)
(import util)
(import lisp)
(define (lift fn parser)
(bind parser (compose result fn)))
@ -19,18 +21,6 @@
(satisfies (lambda (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
(one-or-more (is #\space)))
@ -319,111 +309,6 @@
(cons (get-container source) (get-contents (get-container source)))
(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)
(newline)
(display (set-text '(bold) (get-name room)))

111
lisp.scm Normal file
View File

@ -0,0 +1,111 @@
(module lisp (run-lisp)
(import scheme)
(import chicken.base)
(import matchable)
(import srfi-1)
(import util)
(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
(display "test function called")
(newline)))
(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 ((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))
(append (list args 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 (list)) (compose lisp-exit (curry cons #f))))))))

14
util.scm Normal file
View File

@ -0,0 +1,14 @@
(module util (curry applied thunk)
(import scheme)
(define (curry fn a)
(lambda (b)
(fn a b)))
(define (applied fn)
(curry apply fn))
(define-syntax thunk
(syntax-rules ()
((_ exp ...)
(lambda () exp ...)))))