--- /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
--- 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.
--- 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")))))
--- 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
+-------
--- 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`.
+
--- 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/
--- /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)))
+
--- 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))
--- 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")))
+
--- /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)))
--- 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
--- 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 ;;;;