nyaa

kekkonen.scm

@@ -5,6 +5,8 @@
 (import srfi-13)
 (import matchable)
 (import fmt)
+(import fmt-color)
+(import fmt-unicode)
 (import ansi-escape-sequences)
 (import (chicken file))
 (import breadline)
@@ -16,6 +18,18 @@
   (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)))
 
@@ -29,7 +43,7 @@
   (char-set-union +letter-char-set+ (string->char-set "-0123456789")))
 
 (define parse-symbol
-  (lift (compose string->symbol string-downcase list->string (cut apply append <>))
+  (lift (compose string->symbol string-downcase list->string (applied append))
 	(sequence (lift list (in +letter-char-set+)) (zero-or-more (in +symbol-char-set+)))))
 
 (define parse-number
@@ -67,11 +81,15 @@
   (compose (just newline) display))
 
 (define (display-lines ln)
-  (perhaps (cut map display-newline <>) ln))
+  (perhaps (curry map display-newline) ln))
 
 (define (parse-input)
   (parse (completely-parse parse-statement) (read-line)))
 
+(define parse-formatter
+  (recursive-parser (one-or-more (any-of (followed-by-consuming (char-seq "<b>") (lift fmt-bold parser))
+					 (is-not #\<)))))
+
 (define (type-of elem)
   (cond ((pair? elem) 'pair)
 	((symbol? elem) 'symbol)
@@ -161,10 +179,19 @@
 	    (loop (cdr kv))))))
 
 (define (database-save filename)
-  (with-output-to-file filename (cut write *database*)))
+  (with-output-to-file filename (thunk (write *database*))))
 
 (define (database-load filename)
-  (with-input-from-file filename (lambda () (set! *database* (car (read-list))))))
+  (with-input-from-file filename (thunk (set! *database* (car (read-list))))))
+
+(define (database-remove name)
+  (let loop ((kv *database*))
+    (if (null? kv)
+	'()
+	(if (equal? name (caar kv))
+	    (cdr kv)
+	    (cons (car kv) (loop (cdr kv)))))))
+
 
 (define (get-all-objects)
   (map car *database*))
@@ -227,7 +254,7 @@
 (define (remove-alias object alias)
   (let ((aliases (get-aliases object)))
     (if (member alias aliases)
-	(set-aliases object (remove (cut eq? alias <>) aliases)))))
+	(set-aliases object (remove (curry eq? alias) aliases)))))
 
 (define (set-hidden object value)
   (database-set object 'hidden value))
@@ -282,24 +309,116 @@
       (if (not (member object contents))
 	  (begin
 	    (database-set container 'contents (cons object contents))
-	    (database-set prev-container 'contents (remove (cut eq? object <>) (get-contents prev-container))))))))
+	    (database-set prev-container 'contents (remove (curry eq? object) (get-contents prev-container))))))))
 
 ;; Determine the objects visible to a source object, zork-style
 (define (visible-objects source)
   (let ((result (get-container source)))
-  (if (and result (object-exists? result))
+    (if (and result (object-exists? result))
-      (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 (lisp body environments exit)
+  (define (eval body)
+    (lisp body environments exit))
+  (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"))))
+	      (else (let ((function (reference function-name environments)))
+		      (let ((function-arguments (car function))
+			    (argument-values (cdr body))
+			    (function-body (cddr function)))
+			(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")))))
+
+(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))))))
 
 (define (print-room-description room)
   (newline)
   (display (set-text '(bold) (get-name room)))
+  (if (devmode-enabled?) (display (set-text '(bold fg-green) (string-append " [" (symbol->string room) "]"))))
   (newline)
   (display "    ")
   (fmt #t (dsp (wrap-lines (get-description room))))
   (newline)
   (display "You see: ")
-  (map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ")))) (remove (cut eq? 'you <>) (get-contents room)))
+  (map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ") (if (devmode-enabled?) (begin (display (set-text '(bold fg-green) (string-append "[" (symbol->string n) "] ")))))))) (remove (curry eq? 'you) (get-contents room)))
   (newline))
 
 (define (do-command-enter tag)
@@ -407,11 +526,8 @@
 (define (do-command-describe tag description)
   (do-setter-command tag description string? set-description))
 
-(define +object-flags+
-  '(fixed hidden))
-
 (define (do-command-flag tag flag)
-  (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+)))
+  (if (not (and (symbol? tag) (symbol? flag)))
       (show "I didn't quite understand that.")
       (let ((object (match-object tag (visible-objects 'you))))
 	(if (not object)
@@ -419,10 +535,11 @@
 	    (begin
 	      (case flag
 		((fixed) (set-fixed object #t))
-		((hidden) (set-hidden object #t))))))))
+		((hidden) (set-hidden object #t))
+		(else (show "Invalid flag name."))))))))
 
 (define (do-command-unflag tag flag)
-  (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+)))
+  (if (not (and (symbol? tag) (symbol? flag)))
       (show "I didn't quite understand that.")
       (let ((object (match-object tag (visible-objects 'you))))
 	(if (not object)
@@ -430,7 +547,8 @@
 	    (begin
 	      (case flag
 		((fixed) (set-fixed object #f))
-		((hidden) (set-hidden object #f))))))))
+		((hidden) (set-hidden object #f))
+		(else (show "Invalid flag name."))))))))
 
 (define (do-command-alias tag alias)
   (if (not (and (symbol? tag) (symbol? alias)))
@@ -452,6 +570,22 @@
 	      (remove-alias object alias)
 	      (show "You remove an alias."))))))
 
+(define (do-command-destroy tag)
+  (if (not (symbol? tag))
+      (show "I didn't quite understand that.")
+      (database-remove tag)))
+
+(define (do-command-aliases tag)
+  (if (not (symbol? tag))
+      (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.")
+	    (begin
+	      (newline)
+	      (map (lambda (x) (display x) (display " ")) (get-aliases object))
+	      (newline))))))
+
 (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")
@@ -487,10 +621,10 @@
     (down . up)))
 
 (define (get-cardinal-set direction)
-  (find (cut member direction <>) +cardinal-sets+))
+  (find (curry member direction) +cardinal-sets+))
 
 (define (get-cardinal-aliases direction)
-  (perhaps (cut remove (cut eq? direction <>) <>) (get-cardinal-set direction)))
+  (perhaps (curry remove (curry eq? direction)) (get-cardinal-set direction)))
 
 (define (cardinal-direction? direction)
   (list? (member direction (flatten +cardinal-sets+))))
@@ -514,7 +648,7 @@
 		    (move-object exit-tag (get-container 'you))
 		    (set-hidden exit-tag #t)
 		    (set-destination exit-tag destination)
-		    (map (cut add-alias exit-tag <>) (get-cardinal-set direction))
+		    (map (curry add-alias exit-tag) (get-cardinal-set direction))
 		    (show "You create a passage."))))))))
       
 (define (do-command-exit)
@@ -530,7 +664,7 @@
     (('go x) `(enter ,x))
     (('get x) `(take ,x))
     ((x) (if (cardinal-direction? x)
-	     `(enter ,x)
+ 	     `(enter ,x)
 	     input))
     (_ input)))
 
@@ -558,6 +692,8 @@
 	       (('unflag x y) (do-command-unflag x y))
 	       (('alias x y) (do-command-alias x y))
 	       (('unalias x y) (do-command-unalias x y))
+	       (('destroy x) (do-command-destroy x))
+	       (('aliases x) (do-command-aliases x))
 	       (('message x y z) (do-command-message x y z))
 	       (_ (set! success #f)))
 	     (set! success #f))))