From ae8603b120e71420d808c913a62b6e4159d2f7c0 Mon Sep 17 00:00:00 2001 From: Victor Fors Date: Sun, 19 Sep 2021 23:25:22 +0200 Subject: [PATCH] nya --- kekkonen.scm | 148 +++++++++++++++++++++++++++++++---------------------------- 1 file changed, 79 insertions(+), 69 deletions(-) diff --git a/kekkonen.scm b/kekkonen.scm index 4d41aad..fa1f1a6 100644 --- a/kekkonen.scm +++ b/kekkonen.scm @@ -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))