# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1484153691 0
# Node ID f31f114d1e79de5790f326aae3e822158c7cd390
# Parent  678e161802f57f8a28f182f5e8a3ce9b704c56c8
Copy over and clean up from my sandbox repo

diff -r 678e161802f5 -r f31f114d1e79 .ffignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.ffignore	Wed Jan 11 16:54:51 2017 +0000
@@ -0,0 +1,1 @@
+docs/build
diff -r 678e161802f5 -r f31f114d1e79 README.markdown
--- a/README.markdown	Wed Jan 11 12:53:13 2017 +0000
+++ b/README.markdown	Wed Jan 11 16:54:51 2017 +0000
@@ -9,8 +9,8 @@
                                              -_-
 ```
 
-Chancery is a library for procedurally generating data in Common Lisp.  It has
-some extra support for strings, and is heavily inspired by [Tracery][].
+Chancery is a library for procedurally generating text and stories in Common
+Lisp.  It's heavily inspired by [Tracery][].
 
 [Tracery]: http://tracery.io/
 
@@ -21,5 +21,3 @@
 
 Chancery focuses on simplicity, correctness, and usability.  Performance is not
 *terrible*, but is not a high priority.
-
-It is currently not thread-safe, but this may happen in the future.
diff -r 678e161802f5 -r f31f114d1e79 chancery.asd
--- a/chancery.asd	Wed Jan 11 12:53:13 2017 +0000
+++ b/chancery.asd	Wed Jan 11 16:54:51 2017 +0000
@@ -1,12 +1,12 @@
 (asdf:defsystem :chancery
-  :description "A library for procedurally generating data, inspired by Tracery."
+  :description "A library for procedurally generating text, inspired by Tracery."
 
   :author "Steve Losh <steve@stevelosh.com>"
 
   :license "MIT/X11"
   :version "1.0.0"
 
-  :depends-on ()
+  :depends-on (:named-readtables)
 
   :serial t
   :components ((:module "vendor" :serial t
@@ -14,4 +14,5 @@
                              (:file "quickutils")))
                (:file "package")
                (:module "src" :serial t
-                :components ((:file "chancery")))))
+                :components ((:file "readtable")
+                             (:file "chancery")))))
diff -r 678e161802f5 -r f31f114d1e79 docs/02-usage.markdown
--- a/docs/02-usage.markdown	Wed Jan 11 12:53:13 2017 +0000
+++ b/docs/02-usage.markdown	Wed Jan 11 16:54:51 2017 +0000
@@ -3,5 +3,21 @@
 
 Chancery is ...
 
+[tutorial]: http://www.crystalcodepalace.com/traceryTut.html
+
 [TOC]
 
+Rules
+-----
+
+Concatenation
+-------------
+
+Modifiers
+---------
+
+Evaluation
+----------
+
+Binding
+-------
diff -r 678e161802f5 -r f31f114d1e79 docs/03-reference.markdown
--- a/docs/03-reference.markdown	Wed Jan 11 12:53:13 2017 +0000
+++ b/docs/03-reference.markdown	Wed Jan 11 16:54:51 2017 +0000
@@ -0,0 +1,71 @@
+# API Reference
+
+The following is a list of all user-facing parts of Chancery.
+
+If there are backwards-incompatible changes to anything listed here, they will
+be noted in the changelog and the author will feel bad.
+
+Anything not listed here is subject to change at any time with no warning, so
+don't touch it.
+
+[TOC]
+
+## Package `CHANCERY`
+
+### `A` (function)
+
+    (A STRING)
+
+Add an indefinite article (a or an) to the front of `string`.
+
+### `CAP` (function)
+
+    (CAP STRING)
+
+Capitalize the first character of `string`.
+
+### `CAP-ALL` (function)
+
+    (CAP-ALL STRING)
+
+Capitalize each word of `string`.
+
+### `DEFINE-RULE` (macro)
+
+    (DEFINE-RULE NAME &REST EXPRESSIONS)
+
+Define a Chancery rule for the symbol `name`.
+
+  Each expression in `expressions` can be any valid Chancery expression.  When
+  the rule is invoked one will be chosen at random and evaluated.
+
+  Examples:
+
+    (define-rule name "Alice" "Bob" "Carol")
+    (define-rule place "forest" "mountain")
+    (define-rule emotion "happy" "sad")
+
+    (define-rule sentence
+      (name "was" emotion :. ".")
+      (name "went to the" place :. "."))
+
+  
+
+### `POS` (function)
+
+    (POS STRING)
+
+Make `string` posessive by adding an apostrophe (and possibly an s).
+
+### `Q` (function)
+
+    (Q STRING)
+
+Wrap `string` in quotation marks.
+
+### `S` (function)
+
+    (S STRING)
+
+Pluralize `string`.
+
diff -r 678e161802f5 -r f31f114d1e79 docs/index.markdown
--- a/docs/index.markdown	Wed Jan 11 12:53:13 2017 +0000
+++ b/docs/index.markdown	Wed Jan 11 16:54:51 2017 +0000
@@ -1,5 +1,5 @@
-Chancery is a library for procedurally generating data in Common Lisp.  It has
-some extra support for strings, and is heavily inspired by [Tracery][].
+Chancery is a library for procedurally generating text and stories in Common
+Lisp.  It's heavily inspired by [Tracery][].
 
 [Tracery]: http://tracery.io/
 
diff -r 678e161802f5 -r f31f114d1e79 examples/story.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/story.lisp	Wed Jan 11 16:54:51 2017 +0000
@@ -0,0 +1,87 @@
+(in-package :chancery)
+(named-readtables:in-readtable :chancery)
+
+(define-rule name
+  "arjun"
+  "yuuma"
+  "jess"
+  "bob smith")
+
+(define-rule nature-noun
+  "ocean"
+  "mountain"
+  "forest"
+  "cloud"
+  "river"
+  "tree"
+  "sky"
+  "sea"
+  "desert")
+
+(define-rule animal
+  "unicorn"
+  "raven"
+  "turkey"
+  "wallaby"
+  "sparrow"
+  "scorpion"
+  "coyote"
+  "eagle"
+  "owl"
+  "lizard"
+  "zebra"
+  "duck"
+  "kitten")
+
+(define-rule color
+  "orange"
+  "blue"
+  "white"
+  "black"
+  "grey"
+  "purple"
+  "indigo"
+  "turquoise")
+
+(define-rule activity
+  "running"
+  "jumping"
+  "flying"
+  "carousing")
+
+(define-rule 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 :. ".")
+  ([nature-noun cap] "air is fresh.")
+  ("The" [animal s] "were" activity "in the" nature-noun :. "."))
+
+
+(define-rule pronoun
+  "he" "she")
+
+(define-rule posessive-pronoun
+  "his" "her")
+
+(define-rule omen
+  "good omen"
+  "bad omen")
+
+
+(define-rule 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" (eval (+ 10 (random 10))) [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-rule story
+  (bind* ((hero [name cap-all])
+          (pronoun pronoun)
+          (cap-pro [pronoun cap]))
+    (story%)))
+
+; (iterate (repeat 30) (pr (sentence)))
+
diff -r 678e161802f5 -r f31f114d1e79 package.lisp
--- a/package.lisp	Wed Jan 11 12:53:13 2017 +0000
+++ b/package.lisp	Wed Jan 11 16:54:51 2017 +0000
@@ -1,4 +1,16 @@
 (defpackage :chancery
   (:use :cl :chancery.quickutils)
   (:export
-    ))
+    :define-rule
+
+    :quote
+    :bind
+    :bind*
+    :eval
+
+    :cap
+    :cap-all
+    :q
+    :a
+    :s
+    :pos))
diff -r 678e161802f5 -r f31f114d1e79 src/chancery.lisp
--- a/src/chancery.lisp	Wed Jan 11 12:53:13 2017 +0000
+++ b/src/chancery.lisp	Wed Jan 11 16:54:51 2017 +0000
@@ -1,1 +1,178 @@
 (in-package :chancery)
+
+;;;; Utils ---------------------------------------------------------------------
+(defun emptyp (string)
+  (zerop (length string)))
+
+(defun cat (&rest strings)
+  "Concatenate `strings` into a string."
+  (apply #'concatenate 'string strings))
+
+(defun ch (string index)
+  "Return the character of `string` at `index`.  Allows negative indices."
+  (if (emptyp string)
+    nil
+    (aref string (if (minusp index)
+                   (+ (length string) index)
+                   index))))
+
+(defun chop (string n)
+  "Chop `n` characters off the end of `string`"
+  (subseq string 0 (max 0 (- (length string) n))))
+
+(defun vowelp (character)
+  (ensure-boolean (member character '(#\a #\e #\i #\o #\u))))
+
+(defun random-elt (seq)
+  (elt seq (random (length seq))))
+
+
+(defmacro -<> (&rest forms)
+  ;; I am going to lose my fucking mind if I have to program lisp without
+  ;; a threading macro, but I don't want to add another dep to this library, so
+  ;; here we are.
+  (if (null forms)
+    '<>
+    `(let ((<> ,(first forms)))
+       (-<> ,@(rest forms)))))
+
+(defmacro assert-nonempty (place message)
+  `(assert (not (emptyp ,place)) (,place) ,message))
+
+
+(defun separate-with-spaces (list)
+  (-<> list
+    (split-sequence :. <>)
+    (mapcar (rcurry #'riffle " ") <>)
+    (apply #'append <>)))
+
+
+;;;; Guts ---------------------------------------------------------------------
+(defparameter *bindings* nil)
+
+
+(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-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)
+  (loop :for frame :in *bindings*
+        :for value = (getf frame symbol 'not-found)
+        :do (unless (eq value 'not-found)
+              (return-from lookup-binding (values value t))))
+  (values nil nil))
+
+
+(defun evaluate-combination (list)
+  (-<> list
+    (separate-with-spaces <>)
+    (mapcar #'evaluate-expression <>)
+    (apply #'cat (mapcar #'princ-to-string <>))))
+
+(defun evaluate-modifiers (vector)
+  (reduce (flip #'funcall) vector
+          :start 1
+          :initial-value (evaluate-expression (aref vector 0))))
+
+(defun evaluate-symbol (symbol)
+  (multiple-value-bind (value found) (lookup-binding symbol)
+    (if found
+      value
+      (if (fboundp symbol)
+        (funcall symbol)
+        (symbol-value symbol)))))
+
+(defun evaluate-lisp (expr)
+  (eval expr))
+
+(defun evaluate-expression (expr)
+  (typecase expr
+    ((or string keyword null) expr)
+    (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)))
+            (eval (evaluate-lisp (second expr)))
+            (t (evaluate-combination expr))))
+    (t expr)))
+
+
+(defmacro define-rule (name &rest expressions)
+  "Define a Chancery rule for the symbol `name`.
+
+  Each expression in `expressions` can be any valid Chancery expression.  When
+  the rule is invoked one will be chosen at random and evaluated.
+
+  Examples:
+
+    (define-rule name \"Alice\" \"Bob\" \"Carol\")
+    (define-rule place \"forest\" \"mountain\")
+    (define-rule emotion \"happy\" \"sad\")
+
+    (define-rule sentence
+      (name \"was\" emotion :. \".\")
+      (name \"went to the\" place :. \".\"))
+
+  "
+  `(defun ,name ()
+     (evaluate-expression
+       (random-elt ,(coerce expressions 'vector)))))
+
+
+;;;; Modifiers ----------------------------------------------------------------
+(defun cap (string)
+  "Capitalize the first character of `string`."
+  (assert-nonempty string "Cannot capitalize an empty string.")
+  (string-capitalize string :end 1))
+
+(defun cap-all (string)
+  "Capitalize each word of `string`."
+  (assert-nonempty string "Cannot capitalize-all an empty string.")
+  (string-capitalize string))
+
+(defun q (string)
+  "Wrap `string` in quotation marks."
+  (cat "\"" string "\""))
+
+(defun a (string)
+  "Add an indefinite article (a or an) to the front of `string`."
+  (assert-nonempty string "Cannot add an article to an empty string.")
+  (cat (if (vowelp (ch string 0))
+         "an "
+         "a ")
+       string))
+
+(defun s (string)
+  "Pluralize `string`."
+  (assert-nonempty string "Cannot pluralize an empty string.")
+  (case (ch string -1)
+    (#\y (if (vowelp (ch string -2))
+           (cat string "s")
+           (cat (chop string 1) "ies")))
+    (#\x (cat (chop string 1) "en"))
+    ((#\z #\h) (cat (chop string 1) "es"))
+    (t (cat string "s"))))
+
+(defun pos (string)
+  "Make `string` posessive by adding an apostrophe (and possibly an s)."
+  (assert-nonempty string "Cannot make an empty string posessive.")
+  (cat string
+       (if (eql #\s (ch string -1))
+         "'"
+         "'s")))
+
diff -r 678e161802f5 -r f31f114d1e79 src/readtable.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/readtable.lisp	Wed Jan 11 16:54:51 2017 +0000
@@ -0,0 +1,11 @@
+(in-package :chancery)
+
+(defun vector-reader (stream char)
+  (declare (ignore char))
+  (coerce (read-delimited-list #\] stream t) 'vector))
+
+
+(named-readtables:defreadtable :chancery
+  (:merge :standard)
+  (:macro-char #\[ #'vector-reader t)
+  (:macro-char #\] (get-macro-character #\) nil)))
diff -r 678e161802f5 -r f31f114d1e79 vendor/make-quickutils.lisp
--- a/vendor/make-quickutils.lisp	Wed Jan 11 12:53:13 2017 +0000
+++ b/vendor/make-quickutils.lisp	Wed Jan 11 16:54:51 2017 +0000
@@ -8,9 +8,12 @@
                :ensure-boolean
                :ensure-gethash
                :ensure-list
+               :flip
                :mkstr
                :once-only
                :rcurry
+               :riffle
+               :split-sequence
                :symb
                :with-gensyms
 
diff -r 678e161802f5 -r f31f114d1e79 vendor/quickutils.lisp
--- a/vendor/quickutils.lisp	Wed Jan 11 12:53:13 2017 +0000
+++ b/vendor/quickutils.lisp	Wed Jan 11 16:54:51 2017 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :MKSTR :ONCE-ONLY :RCURRY :SYMB :WITH-GENSYMS) :ensure-package T :package "CHANCERY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLIP :MKSTR :ONCE-ONLY :RCURRY :RIFFLE :SPLIT-SEQUENCE :SYMB :WITH-GENSYMS) :ensure-package T :package "CHANCERY.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "CHANCERY.QUICKUTILS")
@@ -15,8 +15,9 @@
 (when (boundp '*utilities*)
   (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
                                          :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH
-                                         :ENSURE-LIST :MKSTR :ONCE-ONLY :RCURRY
-                                         :SYMB :STRING-DESIGNATOR :WITH-GENSYMS))))
+                                         :ENSURE-LIST :FLIP :MKSTR :ONCE-ONLY
+                                         :RCURRY :RIFFLE :SPLIT-SEQUENCE :SYMB
+                                         :STRING-DESIGNATOR :WITH-GENSYMS))))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-gensym-list (length &optional (x "G"))
     "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -83,6 +84,12 @@
         (list list)))
   
 
+  (defun flip (f)
+    "Return a function whose argument order of a binary function `f` is reversed."
+    #'(lambda (y x)
+        (funcall f x y)))
+  
+
   (defun mkstr (&rest args)
     "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
 
@@ -140,6 +147,134 @@
         (multiple-value-call fn (values-list more) (values-list arguments)))))
   
 
+  (defun riffle (list obj)
+    "Insert the item `obj` in between each element of `list`."
+    (loop :for (x . xs) :on list
+          :collect x
+          :when xs
+            :collect obj))
+  
+
+  (defun split-from-end (position-fn sequence start end count remove-empty-subseqs)
+    (loop
+      :for right := end :then left
+      :for left := (max (or (funcall position-fn sequence right) -1)
+                        (1- start))
+      :unless (and (= right (1+ left))
+                   remove-empty-subseqs) ; empty subseq we don't want
+        :if (and count (>= nr-elts count))
+          ;; We can't take any more. Return now.
+          :return (values (nreverse subseqs) right)
+      :else
+        :collect (subseq sequence (1+ left) right) into subseqs
+        :and :sum 1 :into nr-elts
+      :until (< left start)
+      :finally (return (values (nreverse subseqs) (1+ left)))))
+
+  (defun split-from-start (position-fn sequence start end count remove-empty-subseqs)
+    (let ((length (length sequence)))
+      (loop
+        :for left := start :then (+ right 1)
+        :for right := (min (or (funcall position-fn sequence left) length)
+                           end)
+        :unless (and (= right left)
+                     remove-empty-subseqs) ; empty subseq we don't want
+          :if (and count (>= nr-elts count))
+            ;; We can't take any more. Return now.
+            :return (values subseqs left)
+        :else
+          :collect (subseq sequence left right) :into subseqs
+          :and :sum 1 :into nr-elts
+        :until (>= right end)
+        :finally (return (values subseqs right)))))
+  
+  (macrolet ((check-bounds (sequence start end)
+               (let ((length (gensym (string '#:length))))
+                 `(let ((,length (length ,sequence)))
+                    (check-type ,start unsigned-byte "a non-negative integer")
+                    (when ,end (check-type ,end unsigned-byte "a non-negative integer or NIL"))
+                    (unless ,end
+                      (setf ,end ,length))
+                    (unless (<= ,start ,end ,length)
+                      (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end))))))
+
+    (defun split-sequence (delimiter sequence &key (start 0) (end nil) (from-end nil)
+                                                   (count nil) (remove-empty-subseqs nil)
+                                                   (test #'eql) (test-not nil) (key #'identity))
+      "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded.  All other keywords
+work analogously to those for CL:SUBSTITUTE.  In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+      (check-bounds sequence start end)
+      (cond
+        ((and (not from-end) (null test-not))
+         (split-from-start (lambda (sequence start)
+                             (position delimiter sequence :start start :key key :test test))
+                           sequence start end count remove-empty-subseqs))
+        ((and (not from-end) test-not)
+         (split-from-start (lambda (sequence start)
+                             (position delimiter sequence :start start :key key :test-not test-not))
+                           sequence start end count remove-empty-subseqs))
+        ((and from-end (null test-not))
+         (split-from-end (lambda (sequence end)
+                           (position delimiter sequence :end end :from-end t :key key :test test))
+                         sequence start end count remove-empty-subseqs))
+        ((and from-end test-not)
+         (split-from-end (lambda (sequence end)
+                           (position delimiter sequence :end end :from-end t :key key :test-not test-not))
+                         sequence start end count remove-empty-subseqs))))
+
+    (defun split-sequence-if (predicate sequence &key (start 0) (end nil) (from-end nil)
+                                                      (count nil) (remove-empty-subseqs nil) (key #'identity))
+      "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded.  All other keywords
+work analogously to those for CL:SUBSTITUTE-IF.  In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+      (check-bounds sequence start end)
+      (if from-end
+          (split-from-end (lambda (sequence end)
+                            (position-if predicate sequence :end end :from-end t :key key))
+                          sequence start end count remove-empty-subseqs)
+          (split-from-start (lambda (sequence start)
+                              (position-if predicate sequence :start start :key key))
+                            sequence start end count remove-empty-subseqs)))
+
+    (defun split-sequence-if-not (predicate sequence &key (count nil) (remove-empty-subseqs nil)
+                                                          (from-end nil) (start 0) (end nil) (key #'identity))
+      "Return a list of subsequences in seq delimited by items satisfying
+\(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded.  All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+      (check-bounds sequence start end)
+      (if from-end
+          (split-from-end (lambda (sequence end)
+                            (position-if-not predicate sequence :end end :from-end t :key key))
+                          sequence start end count remove-empty-subseqs)
+          (split-from-start (lambda (sequence start)
+                              (position-if-not predicate sequence :start start :key key))
+                            sequence start end count remove-empty-subseqs))))
+  
+
   (defun symb (&rest args)
     "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
 
@@ -193,7 +328,8 @@
     `(with-gensyms ,names ,@forms))
   
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(curry ensure-boolean ensure-gethash ensure-list mkstr once-only
-            rcurry symb with-gensyms with-unique-names)))
+  (export '(curry ensure-boolean ensure-gethash ensure-list flip mkstr
+            once-only rcurry riffle split-sequence split-sequence-if
+            split-sequence-if-not symb with-gensyms with-unique-names)))
 
 ;;;; END OF quickutils.lisp ;;;;