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

nya

Browse Source
This commit is contained in:
Victor Fors 2021-09-19 23:25:22 +02:00
parent b35a815aa3
commit ae8603b120
1 changed files with 79 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
kekkonen.scm
View File

@ -327,55 +327,77 @@
result
(loop (cdr ln)))))))
(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)))
(_ (exit "malformed if expression")))))
(quote . ,(lambda (function-args)
(match function-args
((v) v)
(_ (exit "malformed quote expression")))))
(cons . ,(lambda (function-args)
(match function-args
((a b) (cons (eval a) (eval b)))
(_ (exit "malformed cons expression")))))
(car . ,(lambda (function-args)
(match function-args
((a) (let ((ae (eval a)))
(if (atom? ae)
(exit "tried to take car of atom")
(car (eval a)))))
(_ (exit "malformed car expression")))))
(cdr . ,(lambda (function-args)
(match function-args
((a) (cdr (eval a))))))
(atom . ,(lambda (function-args)
(match function-args
((a) (atom? (eval a)))
(_ (exit "malformed atom expression")))))
(eq . ,(lambda (function-args)
(match function-args
((a b) (equal? (eval a) (eval b)))
(_ (exit "malformed eval expression")))))
(set . ,(lambda (function-args)
(match function-args
((a b) (if (symbol? a)
(bind a b))))))
(lambda . ,(lambda (function-args)
match function-args
((args exp . exps)
(if (and (list? args) (every symbol? args))
(cons args (cons exp exps))
(exit "malformed lambda expression"))
(_ (exit "malformed lambda expression")))))))
(define (lisp body environments exit)
(define (eval body)
(lisp body environments exit))
(define (lisp-eval body)
(cond ((atom? body) body)
((symbol? body) (reference body))
((list? body) (let ((ln (map lisp-eval body)))
(apply (car ln) (cdr ln))))
(else (exit "Unknown value type in evaluation."))))
(define (reference symbol)
(cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string symbol))))))
; (define (apply function function-args)
; (if
(if (atom? body)
(if (symbol? body)
(reference body)
body)
(let ((function-name (car body))
(function-args (cdr body)))
(if (symbol? function-name)
(case function-name
((test) (show "test function called"))
((if) (match function-args
((e x y) (if (eval e)
(eval x)
(eval y)))
(_ (exit "malformed if expression"))))
((quote) (match function-args
((v) v)
(_ (exit "malformed quote expression"))))
((cons) (match function-args
((a b) (cons (eval a) (eval b)))
(_ (exit "malformed cons expression"))))
((car) (match function-args
((a) (let ((ae (eval a)))
(if (atom? ae)
(exit "tried to take car of atom")
(car (eval a)))))
(_ (exit "malformed car expression"))))
((cdr) (match function-args
((a) (cdr (eval a)))))
((atom) (match function-args
((a) (atom? (eval a)))
(_ (exit "malformed atom expression"))))
((eq) (match function-args
((a b) (equal? (eval a) (eval b)))
(_ (exit "malformed eval expression"))))
; ((set) (match function-args
; ((a b) (if (
((lambda) (match function-args
((args exp . exps)
(if (and (list? args) (every symbol? args))
(cons args (cons exp exps))
(exit "malformed lambda expression")))
(_ (exit "malformed lambda expression"))))
(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))
(loop (cdr environment)))))
(cdr environments))))
(define (lisp-apply function args)
(if (function? function)
(apply function args)
(case function-name
(else (let ((function (reference function-name environments)))
(let ((function-arguments (car function))
(argument-values (cdr body))
@ -383,31 +405,11 @@
(lisp function-body (cons (if (= (length function-arguments) (length argument-values))
(map cons function-arguments (map eval argument-values))
(exit "Wrong number of arguments to function")) environments exit))))))
(exit "attempt to call atom")))))
(exit "attempt to call atom")))))
(define (run-lisp body)
(call/cc (lambda (exit)
(cons #t (lisp body '(()) (compose exit (curry cons #f)))))))
;; (if (and (list function)
;; (>= (length function) 2)
;; (list function-arguments)
;; (every symbol? (car function)))
(define +script-primitives+
`((if . ,(lambda (condition body1 body2)
(script (if (script condition)
body1
body2))))
(eq . ,(lambda (a b)
(equals? (script a) (script b))))
(and . ,(lambda (a b)
(and (script a) (script b))))
(or . ,(lambda (a b)
(or (script a) (script b))))
(not . ,(lambda (a)
(not (script a))))))
(cons #t (lisp body (list lisp-builtins) (compose exit (curry cons #f)))))))
(define (print-room-description room)
(newline)
@ -588,7 +590,7 @@
(define (do-command-message tag message-tag message)
(if (not (and (symbol? tag) (symbol? message-tag) (string? message)))
(show "I didn't quite understand that")
(show "I didn't quite understand that.")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
@ -596,6 +598,13 @@
((enter) (set-enter-message object message))
(else (show "Invalid message name.")))))))
(define (do-command-goto tag)
(if (not (symbol? tag))
(show "I didn't quite understand that.")
(begin
(move-object 'you tag)
(print-room-description (get-container 'you)))))
(define +cardinal-sets+
'((north n)
(northeast ne north-east)
@ -695,6 +704,7 @@
(('destroy x) (do-command-destroy x))
(('aliases x) (do-command-aliases x))
(('message x y z) (do-command-message x y z))
(('goto x) (do-command-goto x))
(_ (set! success #f)))
(set! success #f))))
success))