# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1484059197 0
# Node ID 1bb893fae2bc67ff0647d1be36f4757cd4f34ce6
# Parent  ba7381ecdf83af6e1c10e31fe1645912d5e2aeea
Add tracery bindings

diff -r ba7381ecdf83 -r 1bb893fae2bc .lispwords
--- a/.lispwords	Mon Jan 09 22:04:47 2017 +0000
+++ b/.lispwords	Tue Jan 10 14:39:57 2017 +0000
@@ -4,3 +4,4 @@
 (1 bdd-case)
 (1 sanity-check)
 (1 scancode-case)
+(1 bind bind*)
diff -r ba7381ecdf83 -r 1bb893fae2bc src/story.lisp
--- a/src/story.lisp	Mon Jan 09 22:04:47 2017 +0000
+++ b/src/story.lisp	Tue Jan 10 14:39:57 2017 +0000
@@ -67,40 +67,77 @@
   (separate contents))
 
 (defun string-post (contents)
-  (apply #'cat contents))
+  (apply #'cat (mapcar #'aesthetic-string contents)))
 
 
 (defparameter *rule-types* (make-hash-table))
+(defparameter *bindings* nil)
+(defparameter *environment* nil)
 
 
-(defun evaluate-combination (list environment)
+(defun evaluate-combination (list)
   (-<> list
-    (funcall (getf environment :combination-pre) <>)
-    (mapcar% (rcurry #'evaluate-expression environment) <>)
-    (funcall (getf environment :combination-post) <>)))
+    (funcall (getf *environment* :combination-pre) <>)
+    (mapcar% #'evaluate-expression <>)
+    (funcall (getf *environment* :combination-post) <>)))
 
-(defun evaluate-modifiers (vector environment)
+(defun evaluate-modifiers (vector)
   (reduce (flip #'funcall) vector
           :start 1
-          :initial-value (evaluate-expression (aref vector 0) environment)))
+          :initial-value (evaluate-expression (aref vector 0))))
+
+(defun create-binding (binding)
+  (destructuring-bind (symbol expr) binding
+    (list symbol (evaluate-expression expr))))
+
+(defun evaluate-bind (bindings expr)
+  (let* ((new-bindings (mapcan (rcurry #'create-binding) bindings))
+         (*bindings* (cons new-bindings *bindings*)))
+    (evaluate-expression expr)))
 
-(defun evaluate-expression (expr environment)
+(defun evaluate-bind* (bindings expr)
+  (destructuring-bind (binding . remaining-bindings) bindings
+    (let ((*bindings* (cons (create-binding binding)
+                            *bindings*)))
+      (if remaining-bindings
+        (evaluate-bind* remaining-bindings expr)
+        (evaluate-expression expr)))))
+
+(defun lookup-binding (symbol)
+  (iterate (for frame :in *bindings*)
+           (for value = (getf frame symbol 'not-found))
+           (unless (eq value 'not-found)
+             (return (values value t)))
+           (finally (return (values nil nil)))))
+
+(defun evaluate-symbol (symbol)
+  (if-found value (lookup-binding symbol)
+    value
+    (funcall symbol)))
+
+(defun evaluate-lisp (expr)
+  (eval expr))
+
+(defun evaluate-expression (expr)
   (typecase expr
     ((or string keyword null) expr)
-    (symbol (funcall expr))
-    (vector (evaluate-modifiers expr environment))
-    (list (if (eq (first expr) 'quote)
-            (second expr)
-            (evaluate-combination expr environment)))
+    (symbol (evaluate-symbol expr))
+    (vector (evaluate-modifiers expr))
+    (cons (case (first expr)
+            (quote (second expr))
+            (bind (evaluate-bind (second expr) (cddr expr)))
+            (bind* (evaluate-bind* (second expr) (cddr expr)))
+            (lisp (evaluate-lisp (second expr)))
+            (t (evaluate-combination expr))))
     (t expr)))
 
 
 (defmacro define-rule (name-and-options &rest expressions)
   (destructuring-bind (name &key type) name-and-options
     `(defun ,name ()
-       (evaluate-expression
-         (random-elt ,(coerce expressions 'vector))
-         (gethash ,type *rule-types*)))))
+       (let ((*environment* (gethash ,type *rule-types*)))
+         (evaluate-expression
+           (random-elt ,(coerce expressions 'vector)))))))
 
 (defun add-rule-type (type &key combination-pre combination-post)
   (setf (gethash type *rule-types*)
@@ -223,6 +260,32 @@
   ("The" #(animal s) "were" activity "in the" nature-noun :. "."))
 
 
+(define-string pronoun
+  "he" "she")
+
+(define-string posessive-pronoun
+  "his" "her")
+
+(define-string omen
+  "good omen"
+  "bad omen")
+
+
+(define-string story%
+  ("There once was" #(color a) animal "named"  hero :. "."
+   cap-pro "journeyed to a distant" nature-noun "to find" #(animal a) :. "."
+   "On the way" pronoun "saw" (lisp (random-range 10 20)) #(animal s) activity :. "."
+   hero "considered this to be a" omen :. ".")
+  (bind ((victim animal))
+    (hero "came upon a sick" victim :. "."
+     cap-pro "touched the" victim "and" posessive-pronoun "wounds were healed.")))
+
+(define-string story
+  (bind* ((hero #(name cap-all))
+          (pronoun pronoun)
+          (cap-pro #(pronoun cap)))
+    (story%)))
+
 ; (iterate (repeat 30) (pr (sentence)))
 
 (define-data monster-type
@@ -286,4 +349,4 @@
    :loot loot))
 
 
-(iterate (repeat 30) (pr (encounter)))
+; (iterate (repeat 30) (pr (encounter)))