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