60b451e2a6eb

Function serialization
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Mon, 07 Aug 2017 22:16:41 -0400
parents 6589f828689b
children 0ac280dfa75f
branches/tags (none)
files package.lisp sand.asd src/serializing-functions.lisp src/story.lisp

Changes

--- 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)))