# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1483999487 0
# Node ID ba7381ecdf83af6e1c10e31fe1645912d5e2aeea
# Parent  452b599e2613d3649625cf6f3c2f8da9326a8aee
We need to go deeper

diff -r 452b599e2613 -r ba7381ecdf83 src/story.lisp
--- a/src/story.lisp	Mon Jan 09 19:28:03 2017 +0000
+++ b/src/story.lisp	Mon Jan 09 22:04:47 2017 +0000
@@ -44,6 +44,14 @@
 (defun vowelp (character)
   (ensure-boolean (member character '(#\a #\e #\i #\o #\u))))
 
+(defun mapcar% (function list)
+  (typecase list
+    (null nil)
+    (cons (cons (funcall function (car list))
+                (mapcar% function (cdr list))))
+    (t (funcall function list))))
+
+
 (defmacro assert-nonempty (place message)
   `(assert (not (emptyp ,place)) (,place) ,message))
 
@@ -62,45 +70,57 @@
   (apply #'cat contents))
 
 
-(defparameter *combination-pre* #'identity)
-(defparameter *combination-post* #'identity)
+(defparameter *rule-types* (make-hash-table))
 
 
-(defun evaluate-combination (list)
+(defun evaluate-combination (list environment)
   (-<> list
-    (funcall *combination-pre* <>)
-    (mapcar #'evaluate-expression <>)
-    (funcall *combination-post* <>)))
+    (funcall (getf environment :combination-pre) <>)
+    (mapcar% (rcurry #'evaluate-expression environment) <>)
+    (funcall (getf environment :combination-post) <>)))
 
-(defun evaluate-modifiers (vector)
+(defun evaluate-modifiers (vector environment)
   (reduce (flip #'funcall) vector
           :start 1
-          :initial-value (evaluate-expression (aref vector 0))))
+          :initial-value (evaluate-expression (aref vector 0) environment)))
 
-(defun evaluate-expression (expr)
+(defun evaluate-expression (expr environment)
   (typecase expr
     ((or string keyword null) expr)
     (symbol (funcall expr))
-    (vector (evaluate-modifiers expr))
+    (vector (evaluate-modifiers expr environment))
     (list (if (eq (first expr) 'quote)
             (second expr)
-            (evaluate-combination expr)))
+            (evaluate-combination expr environment)))
     (t expr)))
 
 
-(defun generate (expression)
-  (evaluate-expression expression))
+(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*)))))
 
-(defun generate-string (expression)
-  (let ((*combination-pre* #'string-pre)
-        (*combination-post* #'string-post))
-    (evaluate-expression expression)))
+(defun add-rule-type (type &key combination-pre combination-post)
+  (setf (gethash type *rule-types*)
+        `(:combination-pre ,combination-pre :combination-post ,combination-post))
+  (values))
 
 
-(defmacro define-rule (name &rest expressions)
-  `(defun ,name ()
-     (evaluate-expression
-       (random-elt ,(coerce expressions 'vector)))))
+(add-rule-type :string
+               :combination-pre #'string-pre
+               :combination-post #'string-post)
+
+(add-rule-type :data
+               :combination-pre #'identity
+               :combination-post #'identity)
+
+(defmacro define-string (name &rest body)
+  `(define-rule (,name :type :string) ,@body))
+
+(defmacro define-data (name &rest body)
+  `(define-rule (,name :type :data) ,@body))
 
 
 ;;;; Modifiers ----------------------------------------------------------------
@@ -147,13 +167,13 @@
 
 
 ;;;; Example ------------------------------------------------------------------
-(define-rule name
+(define-string name
   "arjun"
   "yuuma"
   "jess"
   "bob smith")
 
-(define-rule nature-noun
+(define-string nature-noun
   "ocean"
   "mountain"
   "forest"
@@ -164,7 +184,7 @@
   "sea"
   "desert")
 
-(define-rule animal
+(define-string animal
   "unicorn"
   "raven"
   "turkey"
@@ -179,7 +199,7 @@
   "duck"
   "kitten")
 
-(define-rule color
+(define-string color
   "orange"
   "blue"
   "white"
@@ -189,13 +209,13 @@
   "indigo"
   "turquoise")
 
-(define-rule activity
+(define-string activity
   "running"
   "jumping"
   "flying"
   "carousing")
 
-(define-rule sentence
+(define-string sentence
   ("The" color animal "of the" nature-noun "is called" #(name cap-all q) :. ".")
   ("The" animal "was" activity "in the" #(nature-noun s) :. ".")
   (#(name cap-all pos) "favorite color is" color :. ".")
@@ -203,66 +223,67 @@
   ("The" #(animal s) "were" activity "in the" nature-noun :. "."))
 
 
-; (iterate (repeat 30) (pr (generate-string 'sentence)))
+; (iterate (repeat 30) (pr (sentence)))
+
+(define-data monster-type
+  :bat :kobold :goblin)
 
-(define-rule monster
-  :bat
-  :kobold
-  :goblin)
+(define-data monster-health
+  #(50 random))
 
-(define-rule size
+(define-data monster
+  (monster-type :hp monster-health))
+
+(define-data amount
   5 6 7 8 9 10)
 
-(define-rule money
+(define-data money
   (#(100 random) :gold)
   (#(500 random) :silver))
 
-(define-rule potion-type
+(define-string potion-type
   "healing"
   "levitation"
   "detect magic"
   "confusion")
 
-(define-rule potion-quality
-  "strong"
-  "weak"
-  "small")
+(define-string potion-quality
+  "strong" "weak" "small")
 
-(define-rule potion
+(define-string potion
   (potion-quality "potion of" potion-type)
   ("potion of" potion-type))
 
-(define-rule enchant
-  "+1"
-  "+2"
-  "+3")
+(define-string enchant
+  "+1" "+2" "+3")
 
-(define-rule armor-piece
+(define-string armor-piece
   "shield"
   "breastplate"
   "suit of chain mail"
   "belt"
   "helmet")
 
-(define-rule armor
+(define-string armor
   armor-piece
   (enchant armor-piece))
 
-(define-rule item%
+(define-string item
   armor
   potion)
 
-(defun item ()
-  (generate-string #(item% a)))
-
-(define-rule loot
+(define-data single-loot
   money
   item)
 
-(define-rule room%
-  (:size size
-   :loot loot
-   :monster monster))
+(define-data loot
+  (single-loot)
+  (single-loot . loot))
+
+(define-data encounter
+  (:monster monster
+   :amount amount
+   :loot loot))
 
 
-; (iterate (repeat 30) (pr (funcall #'generate 'room%)))
+(iterate (repeat 30) (pr (encounter)))