--- a/package.lisp Tue Mar 14 13:40:08 2017 +0000
+++ b/package.lisp Mon Aug 07 22:16:41 2017 -0400
@@ -197,16 +197,6 @@
(:export
))
-(defpackage :sand.story
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
-
(defpackage :sand.number-letters
(:use
:cl
@@ -278,6 +268,16 @@
(:export
))
+(defpackage :sand.serializing-functions
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils)
+ (:export
+ ))
+
(defpackage :sand.sketch
(:use
--- a/sand.asd Tue Mar 14 13:40:08 2017 +0000
+++ b/sand.asd Mon Aug 07 22:16:41 2017 -0400
@@ -17,6 +17,7 @@
:cl-ppcre
:clss
:compiler-macro
+ :cl-conspack
:drakma
:easing
:flexi-streams
@@ -30,6 +31,7 @@
:sanitize
:sketch
:split-sequence
+ :storable-functions
:trivia
:trivial-main-thread
:vex
@@ -51,6 +53,7 @@
(:file "graphviz")
(:file "hanoi")
(:file "urn")
+ (:file "serializing-functions")
(:file "random-numbers")
(:file "generic-arithmetic")
(:file "ropes")
@@ -73,7 +76,6 @@
:components ((:file "compiler")))
(:file "sketch")
(:file "mandelbrot")
- (:file "story")
(:file "qud")
(:file "istruct")
(:file "names")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/serializing-functions.lisp Mon Aug 07 22:16:41 2017 -0400
@@ -0,0 +1,152 @@
+(in-package :sand.serializing-functions)
+
+(conspack:defencoding st-fun::function-referrer
+ st-fun::function-info
+ st-fun::root)
+
+(conspack:defencoding st-fun:code-information)
+
+(conspack:defencoding st-fun::function-info)
+
+(conspack:defencoding st-fun::lambda-info
+ st-fun::body
+ st-fun::lambda-list)
+
+(conspack:defencoding st-fun::named-lambda-info
+ st-fun::name
+ st-fun::body
+ st-fun::lambda-list)
+
+(conspack:defencoding st-fun::function-call-info
+ st-fun::function-name
+ st-fun::values)
+
+(conspack:defencoding st-fun::quoted-function-info
+ st-fun::body)
+
+;;;; Closures -----------------------------------------------------------------
+(defun get-closure-info-children (info)
+ (st-fun::unset-weak-list (st-fun::info-children-weak-list info))
+ (unwind-protect (copy-list (st-fun::info-children-weak-list info))
+ (st-fun::set-weak-list (st-fun::info-children-weak-list info))))
+
+
+(defmethod conspack:encode-object ((object st-fun::closure-info)
+ &key &allow-other-keys)
+ (acons 'st-fun::children
+ (get-closure-info-children object)
+ (conspack:slots-to-alist (object)
+ st-fun::type
+ st-fun::declarations)))
+
+(defmethod conspack:decode-object ((class (eql 'st-fun::closure-info)) alist
+ &key &allow-other-keys)
+ (conspack:alist-to-slots (alist :class st-fun::closure-info)
+ st-fun::type
+ st-fun::declarations
+ st-fun::children))
+
+
+(defmethod conspack:encode-object ((object st-fun::flet-closure-info)
+ &key &allow-other-keys)
+ (acons 'st-fun::children
+ (get-closure-info-children object)
+ (conspack:slots-to-alist (object)
+ st-fun::type
+ st-fun::functions
+ st-fun::declarations)))
+
+(defmethod conspack:decode-object ((class (eql 'st-fun::flet-closure-info)) alist
+ &key &allow-other-keys)
+ (st-fun:restore-code-info
+ (conspack:alist-to-slots (alist :class st-fun::flet-closure-info)
+ st-fun::type
+ st-fun::functions
+ st-fun::declarations
+ st-fun::children)))
+
+
+(defmethod conspack:encode-object ((object st-fun::macro-closure-info)
+ &key &allow-other-keys)
+ (acons 'st-fun::children
+ (get-closure-info-children object)
+ (conspack:slots-to-alist (object)
+ st-fun::type
+ st-fun::macros
+ st-fun::declarations)))
+
+(defmethod conspack:decode-object ((class (eql 'st-fun::macro-closure-info)) alist
+ &key &allow-other-keys)
+ (st-fun:restore-code-info
+ (conspack:alist-to-slots (alist :class st-fun::macro-closure-info)
+ st-fun::type
+ st-fun::macros
+ st-fun::declarations
+ st-fun::children)))
+
+
+(defmethod conspack:encode-object ((object st-fun::let-closure-info)
+ &key &allow-other-keys)
+ (-<> (conspack:slots-to-alist (object)
+ st-fun::type
+ st-fun::declarations
+ st-fun::variables)
+ (acons 'st-fun::values
+ (funcall (st-fun::info-values-accessor object) object)
+ <>)
+ (acons 'st-fun::children
+ (get-closure-info-children object)
+ <>)))
+
+(defmethod conspack:decode-object ((class (eql 'st-fun::let-closure-info)) alist
+ &key &allow-other-keys)
+ (st-fun:restore-code-info
+ (conspack:alist-to-slots (alist :class st-fun::let-closure-info)
+ st-fun::type
+ st-fun::values
+ st-fun::declarations
+ st-fun::variables
+ st-fun::children)))
+
+
+;;;; Main Encoding Entry Point ------------------------------------------------
+(defmethod conspack:encode-object
+ ((object function) &key &allow-other-keys)
+ (let ((ref (st-fun:get-function-referrer object)))
+ (if ref
+ (acons 'referrer ref nil)
+ (error "Function ~A is not storable." object))))
+
+(defmethod conspack:decode-object
+ ((class (eql 'function)) alist &key &allow-other-keys)
+ (let ((ref (cdr (assoc 'referrer alist))))
+ (st-fun:restore-code-info ref)))
+
+
+;;;; Scratch ------------------------------------------------------------------
+
+(defparameter *test*
+ (st-fun:st-let
+ ((acc 0))
+ (st-fun:st-flet
+ ((add (x) (incf acc x))
+ (sub (x) (decf acc x)))
+ (cons #'add #'sub))))
+
+(funcall (car *test*) 1)
+(funcall (cdr *test*) 1)
+
+(defparameter *encoded*
+ (st-fun:with-storable-functions-storage ()
+ (conspack:tracking-refs ()
+ (conspack:encode *test*))))
+
+(conspack:explain *encoded*)
+
+(defparameter *decoded*
+ (st-fun:with-storable-functions-restorage ()
+ (conspack:tracking-refs ()
+ (conspack:decode *encoded*))))
+
+(funcall (car *decoded*) 1)
+(funcall (cdr *decoded*) 1)
--- a/src/story.lisp Tue Mar 14 13:40:08 2017 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,352 +0,0 @@
-(in-package :sand.story)
-
-;;; Basically a Lispy version of Tracery https://github.com/galaxykate/tracery
-;;; without the nutty string-parsing stuff.
-;;;
-;;; (define-rule name ...expressions...)
-;;;
-;;; strings evaluate to themselves: "foo bar" -> "foo bar"
-;;;
-;;; symbols funcall their symbol-function: animal -> "mouse"
-;;;
-;;; lists evaluate their contents and concatenate them with spaces in between:
-;;; ("foo" animal "bar") -> "foo mouse bar"
-;;;
-;;; the magic keyword :. inside a list suppresses the space there:
-;;;
-;;; ("foo" "bar" :. "baz") -> "foo barbaz"
-;;;
-;;; vectors 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))))
-
-(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))
-
-
-;;;; Guts ---------------------------------------------------------------------
-(defun separate (list)
- (-<> list
- (split-sequence:split-sequence :. <>)
- (mapcar (rcurry #'riffle " ") <>)
- (apply #'append <>)))
-
-(defun string-pre (contents)
- (separate contents))
-
-(defun string-post (contents)
- (apply #'cat (mapcar #'aesthetic-string contents)))
-
-
-(defparameter *rule-types* (make-hash-table))
-(defparameter *bindings* nil)
-(defparameter *environment* nil)
-
-
-(defun evaluate-combination (list)
- (-<> list
- (funcall (getf *environment* :combination-pre) <>)
- (mapcar% #'evaluate-expression <>)
- (funcall (getf *environment* :combination-post) <>)))
-
-(defun evaluate-modifiers (vector)
- (reduce (flip #'funcall) vector
- :start 1
- :initial-value (evaluate-expression (aref vector 0))))
-
-(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)
- (iterate (for frame :in *bindings*)
- (for value = (getf frame symbol 'not-found))
- (unless (eq value 'not-found)
- (return (values value t)))
- (finally (return (values nil nil)))))
-
-(defun evaluate-symbol (symbol)
- (if-found value (lookup-binding symbol)
- value
- (funcall 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)))
- (lisp (evaluate-lisp (second expr)))
- (t (evaluate-combination expr))))
- (t expr)))
-
-
-(defmacro define-rule (name-and-options &rest expressions)
- (destructuring-bind (name &key type) name-and-options
- `(defun ,name ()
- (let ((*environment* (gethash ,type *rule-types*)))
- (evaluate-expression
- (random-elt ,(coerce expressions 'vector)))))))
-
-(defun add-rule-type (type &key combination-pre combination-post)
- (setf (gethash type *rule-types*)
- `(:combination-pre ,combination-pre :combination-post ,combination-post))
- (values))
-
-
-(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 ----------------------------------------------------------------
-(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-string name
- "arjun"
- "yuuma"
- "jess"
- "bob smith")
-
-(define-string nature-noun
- "ocean"
- "mountain"
- "forest"
- "cloud"
- "river"
- "tree"
- "sky"
- "sea"
- "desert")
-
-(define-string animal
- "unicorn"
- "raven"
- "turkey"
- "wallaby"
- "sparrow"
- "scorpion"
- "coyote"
- "eagle"
- "owl"
- "lizard"
- "zebra"
- "duck"
- "kitten")
-
-(define-string color
- "orange"
- "blue"
- "white"
- "black"
- "grey"
- "purple"
- "indigo"
- "turquoise")
-
-(define-string activity
- "running"
- "jumping"
- "flying"
- "carousing")
-
-(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 :. ".")
- (#(nature-noun cap) "air is fresh.")
- ("The" #(animal s) "were" activity "in the" nature-noun :. "."))
-
-
-(define-string pronoun
- "he" "she")
-
-(define-string posessive-pronoun
- "his" "her")
-
-(define-string omen
- "good omen"
- "bad omen")
-
-
-(define-string 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" (lisp (random-range 10 20)) #(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-string story
- (bind* ((hero #(name cap-all))
- (pronoun pronoun)
- (cap-pro #(pronoun cap)))
- (story%)))
-
-; (iterate (repeat 30) (pr (sentence)))
-
-(define-data monster-type
- :bat :kobold :goblin)
-
-(define-data monster-health
- #(50 random))
-
-(define-data monster
- (monster-type :hp monster-health))
-
-(define-data amount
- 5 6 7 8 9 10)
-
-(define-data money
- (#(100 random) :gold)
- (#(500 random) :silver))
-
-(define-string potion-type
- "healing"
- "levitation"
- "detect magic"
- "confusion")
-
-(define-string potion-quality
- "strong" "weak" "small")
-
-(define-string potion
- (potion-quality "potion of" potion-type)
- ("potion of" potion-type))
-
-(define-string enchant
- "+1" "+2" "+3")
-
-(define-string armor-piece
- "shield"
- "breastplate"
- "suit of chain mail"
- "belt"
- "helmet")
-
-(define-string armor
- armor-piece
- (enchant armor-piece))
-
-(define-string item
- armor
- potion)
-
-(define-data single-loot
- money
- item)
-
-(define-data loot
- (single-loot)
- (single-loot . loot))
-
-(define-data encounter
- (:monster monster
- :amount amount
- :loot loot))
-
-
-; (iterate (repeat 30) (pr (encounter)))