nya

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