# HG changeset patch # User Steve Losh # Date 1483979472 0 # Node ID 5cace362d3184a6ab90ad4f168c94bba7c1876d2 # Parent c034e194a114700305dca14dd1500d2689d55f1e Make Tracery diff -r c034e194a114 -r 5cace362d318 package.lisp --- a/package.lisp Mon Jan 09 12:13:02 2017 +0000 +++ b/package.lisp Mon Jan 09 16:31:12 2017 +0000 @@ -1,6 +1,3 @@ -; (rename-package :charms :hunchentoot '(:ht)) - - (defpackage :sand.utils (:use :cl @@ -84,20 +81,6 @@ :sand.quickutils :sand.utils)) -(defpackage :sand.sketch - (:use - :cl - :losh - :sketch - :iterate - :sand.quickutils - :sand.utils) - (:shadowing-import-from :iterate - :in) - (:shadowing-import-from :sketch - :degrees - :radians)) - (defpackage :sand.markov (:use :cl @@ -240,6 +223,55 @@ (:export )) +(defpackage :sand.story + (:use + :cl + :cl-arrows + :losh + :iterate + :sand.quickutils + :sand.utils) + (:export + )) + +(defpackage :sand.number-letters + (:use + :cl + :cl-arrows + :losh + :iterate + :function-cache + :sand.quickutils + :sand.utils) + (:export + )) + +(defpackage :sand.urn + (:use + :cl + :cl-arrows + :losh + :iterate + :sand.quickutils + :sand.utils) + (:export + )) + + +(defpackage :sand.sketch + (:use + :cl + :losh + :sketch + :iterate + :sand.quickutils + :sand.utils) + (:shadowing-import-from :iterate + :in) + (:shadowing-import-from :sketch + :degrees + :radians)) + (defpackage :sand.mandelbrot (:use :cl @@ -270,30 +302,6 @@ :profile)) -(defpackage :sand.number-letters - (:use - :cl - :cl-arrows - :losh - :iterate - :function-cache - :sand.quickutils - :sand.utils) - (:export - )) - -(defpackage :sand.urn - (:use - :cl - :cl-arrows - :losh - :iterate - :sand.quickutils - :sand.utils) - (:export - )) - - (defpackage :sand.turing-omnibus.wallpaper (:use :cl diff -r c034e194a114 -r 5cace362d318 sand.asd --- a/sand.asd Mon Jan 09 12:13:02 2017 +0000 +++ b/sand.asd Mon Jan 09 16:31:12 2017 +0000 @@ -15,6 +15,7 @@ :cl-arrows :cl-charms :cl-fad + :cl-ppcre :clss :compiler-macro :drakma @@ -72,6 +73,7 @@ :components ((:file "compiler"))) (:file "sketch") (:file "mandelbrot") + (:file "story") (:module "turing-omnibus" :serial t :components ((:file "wallpaper") diff -r c034e194a114 -r 5cace362d318 src/story.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/story.lisp Mon Jan 09 16:31:12 2017 +0000 @@ -0,0 +1,187 @@ +(in-package :sand.story) + +;;; Basically a Lispy version of Tracery https://github.com/galaxykate/tracery +;;; without the nutty string-parsing stuff. +;;; +;;; (define-symbol name ...expressions...) +;;; +;;; strings evaluate to themselves: "foo bar" -> "foo bar" +;;; +;;; symbols funcall their symbol-function: animal -> "mouse" +;;; +;;; vectors evaluate their contents and concatenate them with spaces in between: +;;; #("foo" animal "bar") -> "foo mouse bar" +;;; +;;; the magic keyword :. inside a vector suppresses the space there: +;;; +;;; #("foo" "bar" :. "baz") -> "foo barbaz" +;;; +;;; lists evaluate the head and pipe it through all the functions in the tail: +;;; +;;; (animal capitalize pos) -> "Mouse's" + + +;;;; 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)))) + +(defmacro assert-nonempty (place message) + `(assert (not (emptyp ,place)) (,place) ,message)) + + +;;;; Guts --------------------------------------------------------------------- +(defun separate (list) + (-<> list + (split-sequence:split-sequence :. <>) + (mapcar (rcurry #'riffle " ") <>) + (apply #'append <>))) + +(defun evaluate-vector (vector) + (-<> (coerce vector 'list) + (separate <>) + (mapcar #'evaluate-expression <>) + (apply #'cat <>))) + +(defun evaluate-list (list) + (destructuring-bind (expr &rest modifiers) list + (reduce (flip #'funcall) modifiers + :initial-value (evaluate-expression expr)))) + +(defun evaluate-expression (expr) + (etypecase expr + (string expr) + (vector (evaluate-vector expr)) + (list (evaluate-list expr)) + (symbol (funcall expr)))) + + +(defun generate (symbol) + (evaluate-expression symbol)) + + +(defmacro define-symbol (name &rest expressions) + `(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"))) + + +;;;; Example ------------------------------------------------------------------ +(define-symbol name + "arjun" + "yuuma" + "jess" + "bob smith") + +(define-symbol nature-noun + "ocean" + "mountain" + "forest" + "cloud" + "river" + "tree" + "sky" + "sea" + "desert") + +(define-symbol animal + "unicorn" + "raven" + "turkey" + "wallaby" + "sparrow" + "scorpion" + "coyote" + "eagle" + "owl" + "lizard" + "zebra" + "duck" + "kitten") + +(define-symbol color + "orange" + "blue" + "white" + "black" + "grey" + "purple" + "indigo" + "turquoise") + +(define-symbol activity + "running" + "jumping" + "flying" + "carousing") + +(define-symbol 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 :. ".")) + + +(generate 'sentence) diff -r c034e194a114 -r 5cace362d318 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Mon Jan 09 12:13:02 2017 +0000 +++ b/vendor/make-quickutils.lisp Mon Jan 09 16:31:12 2017 +0000 @@ -8,9 +8,11 @@ :copy-array :curry :define-constant + :ensure-boolean :ensure-gethash :ensure-list :extremum + :flip :hash-table-alist :hash-table-keys :hash-table-plist @@ -23,6 +25,7 @@ :read-file-into-string :required-argument :riffle + :separated-string-append :subdivide :symb :tree-collect diff -r c034e194a114 -r 5cace362d318 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Mon Jan 09 12:13:02 2017 +0000 +++ b/vendor/quickutils.lisp Mon Jan 09 16:31:12 2017 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLIP :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SEPARATED-STRING-APPEND :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "SAND.QUICKUTILS") @@ -15,16 +15,17 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION :COMPOSE :COPY-ARRAY :CURRY - :DEFINE-CONSTANT :ENSURE-GETHASH - :ENSURE-LIST :EXTREMUM - :HASH-TABLE-ALIST :MAPHASH-KEYS + :DEFINE-CONSTANT :ENSURE-BOOLEAN + :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM + :FLIP :HASH-TABLE-ALIST :MAPHASH-KEYS :HASH-TABLE-KEYS :HASH-TABLE-PLIST :MAPHASH-VALUES :HASH-TABLE-VALUES :IOTA :TAKE :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE :READ-FILE-INTO-STRING - :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE + :REQUIRED-ARGUMENT :RIFFLE + :SEPARATED-STRING-APPEND :SUBDIVIDE :MKSTR :SYMB :TREE-COLLECT :STRING-DESIGNATOR :WITH-GENSYMS)))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -155,6 +156,11 @@ ,@(when documentation `(,documentation)))) + (defun ensure-boolean (x) + "Convert `x` into a Boolean value." + (and x t)) + + (defmacro ensure-gethash (key hash-table &optional default) "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default` under key before returning it. Secondary return value is true if key was @@ -216,6 +222,12 @@ :end end))))) + (defun flip (f) + "Return a function whose argument order of a binary function `f` is reversed." + #'(lambda (y x) + (funcall f x y))) + + (defun hash-table-alist (table) "Returns an association list containing the keys and values of hash table `table`." @@ -435,6 +447,34 @@ :collect obj)) + (defun separated-string-append* (separator sequence-of-strings) + "Concatenate all of the strings in SEQUENCE-OF-STRINGS separated + by the string SEPARATOR." + (etypecase sequence-of-strings + (null "") + + (cons (with-output-to-string (*standard-output*) + (mapl #'(lambda (tail) + (write-string (car tail)) + (unless (null (cdr tail)) + (write-string separator))) + sequence-of-strings))) + + (sequence + (let ((length (length sequence-of-strings))) + (with-output-to-string (*standard-output*) + (map nil #'(lambda (string) + (write-string string) + (unless (zerop (decf length)) + (write-string separator))) + sequence-of-strings)))))) + + (defun separated-string-append (separator &rest strings) + "Concatenate the strings STRINGS separated by the string +SEPARATOR." + (separated-string-append* separator strings)) + + (defun subdivide (sequence chunk-size) "Split `sequence` into subsequences of size `chunk-size`." (check-type sequence sequence) @@ -537,10 +577,11 @@ `(with-gensyms ,names ,@forms)) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(compose copy-array curry define-constant ensure-gethash ensure-list - extremum hash-table-alist hash-table-keys hash-table-plist - hash-table-values iota n-grams once-only range rcurry - read-file-into-string required-argument riffle subdivide symb - tree-collect with-gensyms with-unique-names))) + (export '(compose copy-array curry define-constant ensure-boolean + ensure-gethash ensure-list extremum flip hash-table-alist + hash-table-keys hash-table-plist hash-table-values iota n-grams + once-only range rcurry read-file-into-string required-argument + riffle separated-string-append separated-string-append* subdivide + symb tree-collect with-gensyms with-unique-names))) ;;;; END OF quickutils.lisp ;;;;