reinlined snek

snek/.editorconfig

@@ -0,0 +1,14 @@
+# http://EditorConfig.org
+
+# top-most EditorConfig file
+root = true
+
+# Unix-style newlines with a newline ending every file
+[*]
+end_of_line = lf
+insert_final_newline = true
+charset = utf-8
+indent_style = space
+indent_size = 2
+trim_trailing_whitespace = true
+

snek/LICENSE

@@ -0,0 +1,30 @@
+
+This code is released under the MIT licence. However, parts of utils.lisp
+are from On Lisp by Paul Graham, and they are bound by the following notice:
+
+This code is copyright 1993 by Paul Graham, but anyone who wants 
+to use the code in any nonprofit activity, or distribute free
+verbatim copies (including this notice), is encouraged to do so.
+
+
+MIT License
+
+Copyright (c) 2017 Anders Hoff
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

snek/README.md

@@ -0,0 +1,89 @@
+# SNEK is Not an Acronym
+
+![head](img/img.png?raw=true "head")
+
+## About
+
+`snek` is a simple data structure for working with vertices and edges. More
+importantly it is a programming pattern for applying changes to the structure.
+It is specifically written to be useful for a broad range of ways in which i
+usually write generative algorithms for creating art.
+
+The pattern depends on the concept of `alterations`. In short: an `alteration`
+is a change that will be applied to the structure at the end of a given
+context. `alterations` are further described in
+http://inconvergent.net/snek-is-not-an-acronym/.
+
+Here is and example of manipulating a `snek` instance called `snk` using
+`alterations`:
+
+    ; context start
+    (with-snek (snk)
+      ; iterate
+      (with-all-verts (snk v)
+        ; move alteration
+        (move-vert v (rnd-in-circ))
+        ; w will be an arbitrary
+        ; vertex in snk
+        (with-rnd-vert (snk w)
+          ; join v and w if they are closer than d
+          (if (< (vert-dst snk (v w)) d)
+            ; join vertices alteration
+            (join-verts v w))))
+    ; context end
+    ; alterations have been applied
+
+There are two more examples. They can be executed like this:
+
+    ./run-slope.lisp res/slop.png
+    ./run-lines.lisp res/lines.png
+
+Notice that the resulting image will end up in `res`.
+
+`snek` is used in
+
+  - http://moment.inconvergent.net/
+  - https://twitter.com/sandpaintbot
+  - https://twitter.com/scratchpaintbot
+
+## Dependencies
+
+This code requires `Quicklisp` and `zpng`. Note that the The path to quicklisp
+must be set in `src/load`. `zpng` is automatically installed via `quicklisp`.
+
+ - http://www.xach.com/lisp/zpng/
+ - https://www.quicklisp.org/beta/
+
+
+## Run tests
+
+There are some tests included. Run them like this:
+
+    ./run-test.lisp
+
+
+## Stability changes and Versioning
+
+This code is highly experimental on my part. It is likely to change with no
+warning or explanation. I will keep a note of the version number in `VERSION`.
+
+
+## On Use and Contributions
+
+This code is a tool that I have written for my own use. I release it publicly
+in case people find it useful. It is not however intended as a
+collaboration/Open Source project. As such I am unlikely to accept PRs, reply
+to issues, or take requests.
+
+
+## Todo
+
+ - Randomized order of alteration apply
+ - Maintain list of singly-connected vertices?
+ - zonemaps? kd-tree?
+
+
+## Done
+
+ - Reject/attract force move alterations, or force calc funcs? (sort of)
+

snek/VERSION

@@ -0,0 +1 @@
+0.0.21

snek/run-lines.lisp

@@ -0,0 +1,51 @@
+#!/usr/bin/sbcl --script
+
+(load "src/load")
+
+(setf *print-pretty* t)
+(setf *random-state* (make-random-state t))
+
+
+(defun main (size fn)
+
+  (let ((mid (.5* size))
+        (repeat 15)
+        (grains 4)
+        (itt 1000)
+        (sand (sandpaint*
+                size
+                :active (list 0.0 0.0 0.0 0.01)
+                :bg (list 1.0 1.0 1.0 1.0))))
+
+    (loop for i in (linspace 100 900 repeat)
+          for j from 1 to repeat do
+      (print j)
+      (let ((snk (snek*))
+            (va (list 0 0))
+            (vb (list 0 0))
+            (p1 (list 100 i))
+            (p2 (list 900 i)))
+
+        (loop for k from 1 to itt do
+          (let ((v1 (insert-vert (l-on-line k itt p1 p2) into snk))
+                (v2 (insert-vert (ladd va (l-on-line k itt p1 p2)) into snk)))
+
+            (setf va (ladd va (l-rand-in-circle (* 0.7 j))))
+            (setf vb (ladd vb (l-rand-in-circle (* 0.001 j))))
+
+            (with-snek (snk)
+              (with-all-verts (snk v)
+                (move-vert v (ladd (l-rand-in-circle 0.1) vb)))
+              (join-verts v1 v2))
+
+            (sandpaint-edges sand snk grains)
+            (sandpaint-verts sand snk)))))
+
+
+    (format t "~%writing to ~a" fn)
+    ;(sandpaint-chromatic-aberration sand (list mid mid) 100.0)
+    (sandpaint-save sand fn)))
+
+
+(time (main 1000 (second (cmd-args))))
+

snek/run-slope.lisp

@@ -0,0 +1,52 @@
+#!/usr/bin/sbcl --script
+
+(load "src/load")
+
+(setf *print-pretty* t)
+(setf *random-state* (make-random-state t))
+
+
+(defun main (size fn)
+
+  (let ((p1 (l-rand-in-circle 100 :x 800.0 :y 200.0))
+        (p2 (l-rand-in-circle 100 :x 200.0 :y 800.0)))
+    (let ((va (ladd
+                (lscale
+                   (lnorm
+                     (lmult (reverse (lsub p1 p2)) (list -1.0 1.0)))
+                   40.0)
+                 (l-rand-on-circle 20 :x 0.0 :y 0.0)))
+         (repeat 10)
+         (noise (random 4.0))
+         (grains 70)
+         (itt 6000)
+         (sand (sandpaint*
+                 size
+                 :active (list 0.0 0.0 0.0 0.01)
+                 :bg (list 1.0 1.0 1.0 1.0))))
+
+      (loop for j from 1 to repeat
+        do
+          (print j)
+          (let ((snk (snek*)))
+            (setf va (ladd va (l-rand-in-circle noise :x 0.0 :y 0.0)))
+
+            (loop for k from 1 to itt
+              do
+                (insert-vert (l-rand-on-line p1 p2) into snk)
+                (with-snek (snk)
+                  (with-rnd-vert (snk v)
+                    (append-edge v va))
+                  (with-rnd-vert (snk v)
+                    (with-rnd-vert (snk w)
+                      (join-verts w v)))))
+              (sandpaint-edges sand snk grains)))
+
+
+   (-pixel-hack sand)
+   (format t "~%writing to ~a" fn)
+   (sandpaint-save sand fn))))
+
+
+(time (main 1000 (second (cmd-args))))
+

snek/run-test.lisp

@@ -0,0 +1,524 @@
+#!/usr/bin/sbcl --script
+
+(load "src/load")
+
+(setf *print-pretty* t)
+;(setf *random-state* (make-random-state t))
+
+
+(defmacro do-test (a &optional (b nil))
+  (with-gensyms (aname bname)
+    `(let ((,aname ,a)
+           (,bname ,b))
+      (if (funcall #'equalp ,aname ,bname)
+        (format t "~%~a ~%--> ok" ',a)
+        (format t "~%~a ~%--> not ok. ~%--  wanted: ~% ~a ~%--  got: ~% ~a"
+                ',a
+                ',b
+                ,aname))
+      (format t "~%---------------------------~%"))))
+
+
+(defun test-utils ()
+  (do-test
+    (lnorm '(3 0))
+    '(1.0 0.0))
+
+  (do-test
+    (lsub '(1 2) '(2 3))
+    '(-1 -1))
+
+  (do-test
+    (ladd '(1 2) '(2 3))
+      '(3 5))
+
+  (do-test
+    (lnsub '(1 2) '(2 10))
+    '(-0.12403473 -0.99227786))
+
+  (do-test
+    (llenn '(1 2))
+    5)
+
+  (do-test
+    (llen '(1 2))
+    2.236068)
+
+  (do-test
+    (ldst '(1 2) '(1 3))
+    1.0)
+
+  (do-test
+    (lget '(0 2) '((1 2) (3 4) (5 6)))
+    '((1 2) (5 6))))
+
+
+(defun test-bin ()
+  (let ((edges (make-array
+        (list 10 2)
+        :adjustable nil
+        :initial-contents
+          '((1 0) (1 2) (1 5) (3 4) (10 3) (0 0) (0 0) (0 0) (0 0) (0 0)))))
+
+    (do-test
+      (-binary-edge-insert-search edges '(3 4) 5)
+      4)
+
+    (do-test
+      (-binary-edge-insert-search edges '(0 0) 5)
+      0)
+
+    (do-test
+      (-binary-edge-insert-search edges '(1 6) 5)
+      3)
+
+    (-insert-edge edges '(11 1) 5 5)
+    (-insert-edge edges '(11 0) 5 6)
+
+    (-remove-edge edges 0 7)
+
+    (do-test
+      edges
+      (make-array
+        (list 10 2)
+        :adjustable nil
+        :initial-contents
+          '((1 2) (1 5) (3 4) (10 3) (11 0) (11 1) (0 0) (0 0) (0 0) (0 0)
+            )))))
+
+
+(defun test-snek (s)
+  (do-test
+    (insert-vert '(0 0) into s)
+    0)
+
+  (do-test
+    (insert-vert '(10 0) into s)
+    1)
+
+  (do-test
+    (insert-vert '(3 3) into s)
+    2)
+
+  (do-test
+    (insert-vert '(4 3) into s)
+    3)
+
+  (do-test
+    (insert-edge '(0 0) into s)
+    nil)
+
+  (do-test
+    (insert-edge '(0 2) into s)
+    '(0 2))
+
+  (do-test
+    (insert-edge '(0 1) into s)
+    '(0 1))
+
+  (do-test
+    (insert-edge '(5 0) into s)
+    '(0 5))
+
+  (do-test
+    (insert-edge '(1 0) into s)
+    nil)
+
+  (do-test
+    (insert-edge '(5 0) into s)
+    nil)
+
+  (do-test
+    (insert-edge '(0 2) into s)
+    nil)
+
+  (do-test
+    (insert-edge '(5 2) into s)
+    '(2 5))
+
+  (do-test
+    (insert-edge '(4 1) into s)
+    '(1 4))
+
+  (do-test
+    (insert-edge '(4 0) into s)
+    '(0 4))
+
+  (do-test
+    (insert-edge '(5 1) into s)
+    '(1 5))
+
+  (do-test
+    (insert-edge '(100 100) into s)
+    nil)
+
+  (do-test
+    (insert-edge '(3 100) into s)
+    '(3 100))
+
+  (do-test
+    (insert-edge '(0 1) into s)
+    nil)
+
+  (do-test
+    (insert-edge '(0 4) into s)
+    nil)
+
+  (do-test
+    (insert-edge '(100 99) into s)
+    '(99 100))
+
+  (do-test
+    (get-vert 2 from s)
+    '(3.0 3.0))
+
+  (do-test
+    (insert-vert '(0 1) into s)
+    4)
+
+  (do-test
+    (insert-edge '(0 1) into s)
+    nil)
+
+  (do-test
+    (insert-vert '(0 7) into s)
+    5)
+
+  (do-test
+    (get-one-ring of 5 from s)
+    '((5 0) (5 1) (5 2)))
+
+  (do-test
+    (get-one-ring of 0 from s)
+    '((0 1) (0 2) (0 4) (0 5)))
+
+  (do-test
+    (edge-length s '(0 4))
+    1.0)
+
+  (do-test
+    (edge-length s '(2 5))
+    5.0)
+
+  (do-test
+    (edge-length s '(1 2))
+    7.615773))
+
+
+(defun test-snek-2 (s)
+  (do-test
+    (insert-vert '(0 0) into s)
+    0)
+
+  (do-test
+    (insert-vert '(20 20) into s)
+    1)
+
+  (do-test
+    (insert-vert '(30 30) into s)
+    2)
+
+  (do-test
+    (insert-vert '(40 40) into s)
+    3)
+
+  (do-test
+    (insert-edge '(0 1) into s)
+    '(0 1))
+
+  (do-test
+    (insert-edge '(1 2) into s)
+    '(1 2))
+
+  (do-test
+    (insert-edge '(2 3) into s)
+    '(2 3))
+
+  (do-test
+    (-binary-edge-insert-search (snek-edges s) '(1 2) 2)
+    2)
+
+  (do-test
+    (get-one-ring of 0 from s)
+    '((0 1)))
+
+  (do-test
+    (get-one-ring of 1 from s)
+    '((1 0) (1 2)))
+
+  (do-test
+    (remove-edge '(0 1) from s)
+    2)
+
+  (do-test
+    (remove-edge '(0 1) from s)
+    0)
+
+  (do-test
+    (remove-edge '(3 2) from s)
+    2)
+
+  (do-test
+    (remove-edge '(1 2) from s)
+    2)
+
+  (do-test
+    (snek-num-edges s)
+    0)
+
+  (do-test
+    (snek-num-verts s)
+    4))
+
+
+(defun test-snek-3 (s)
+  (do-test
+    (insert-vert '(10 10) into s)
+    0)
+  (do-test
+    (insert-vert '(20 10) into s)
+    1)
+
+  (do-test
+    (insert-vert '(30 10) into s)
+    2)
+
+  (do-test
+    (insert-vert '(40 10) into s)
+    3)
+
+  (do-test
+    (insert-edge '(0 1) into s)
+    '(0 1))
+  (do-test
+    (insert-edge '(1 2) into s)
+    '(1 2))
+  (do-test
+    (insert-edge '(2 3) into s)
+    '(2 3))
+  (do-test
+    (insert-edge '(2 3) into s)
+    nil)
+
+  (do-test
+    (-binary-edge-search
+      (snek-edges s)
+      '(2 3)
+      (snek-num-edges s))
+    4)
+
+  (do-test
+    (-binary-edge-search
+      (snek-edges s)
+      '(0 1)
+      (snek-num-edges s))
+    0)
+
+  (do-test
+    (-binary-edge-search
+      (snek-edges s)
+      '(10 1)
+      (snek-num-edges s))
+    nil))
+
+(defun init-snek ()
+  (let ((s (snek* 16)))
+    (insert-vert '(0 2) into s)
+    (insert-vert '(2 3) into s)
+    (insert-vert '(3 4) into s)
+    (insert-vert '(4 7) into s)
+    (insert-vert '(5 4) into s)
+    (insert-vert '(0 6) into s)
+    (insert-vert '(-1 7) into s)
+    (insert-vert '(0 8) into s)
+    (insert-vert '(0 9) into s)
+    (insert-vert '(10 1) into s)
+
+    (insert-edge '(1 2) into s)
+    (insert-edge '(0 1) into s)
+    (insert-edge '(3 1) into s)
+    (insert-edge '(5 6) into s)
+    (insert-edge '(7 3) into s)
+    s))
+
+(defun test-snek-move ()
+  (let ((s (init-snek)))
+    (with-snek (s)
+      (move-vert 0 '(3 3))
+      (move-vert 1 '(1 3))
+      (move-vert 3 '(2 3) :rel nil)
+      (move-vert 2 '(3 4)))
+
+    (do-test
+      (get-vert 0 from s)
+      '(3 5))
+
+    (do-test
+      (get-vert 1 from s)
+      '(3 6))
+
+    (do-test
+      (get-vert 3 from s)
+      '(2 3))
+
+    (do-test
+      (get-vert 2 from s)
+      '(6 8))))
+
+(defun test-snek-join ()
+  (let ((s (init-snek)))
+    (with-snek (s)
+      (join-verts 3 3)
+      (join-verts 3 3)
+      (join-verts 3 6)
+      (join-verts 7 1))
+
+  (do-test
+    (snek-num-edges s)
+    14)
+
+  (do-test
+    (snek-edges s)
+    (make-array
+      (list 16 2)
+      :adjustable nil
+      :initial-contents
+        '((0 1) (1 0) (1 2) (1 3) (1 7) (2 1) (3 1) (3 6)
+          (3 7) (5 6) (6 3) (6 5) (7 1) (7 3) (0 0) (0 0))))))
+
+
+(defun test-snek-append ()
+  (let ((s (init-snek)))
+    (with-snek (s)
+      (append-edge 3 '(3 4))
+      (append-edge 3 '(8 5) :rel nil)
+      (append-edge 7 '(1 2)))
+
+  (do-test
+    (snek-num-edges s)
+    16)
+
+  (do-test
+    (snek-num-verts s)
+    13)
+
+  (do-test
+    (snek-edges s)
+    (make-array
+      (list 16 2)
+      :adjustable nil
+      :initial-contents
+        '((0 1) (1 0) (1 2) (1 3) (2 1) (3 1) (3 7) (3 10)
+          (3 11) (5 6) (6 5) (7 3) (7 12) (10 3) (11 3) (12 7))))
+
+  (do-test
+    (snek-verts s)
+    (make-array
+      (list 16 2)
+      :adjustable nil
+      :initial-contents
+        '((0.0 2.0) (2.0 3.0) (3.0 4.0) (4.0 7.0) (5.0 4.0) (0.0 6.0)
+          (-1.0 7.0) (0.0 8.0) (0.0 9.0) (10.0 1.0) (7.0 11.0) (8.0 5.0)
+          (1.0 10.0) (0.0 0.0) (0.0 0.0) (0.0 0.0))))))
+
+
+(defun test-snek-split ()
+  (let ((s (init-snek)))
+    (with-snek (s)
+      (split-edge '(1 2))
+      (split-edge '(1 2))
+      (split-edge '(5 6)))
+
+  (do-test
+    (snek-num-edges s)
+    14)
+
+  (do-test
+    (snek-num-verts s)
+    12)
+
+  (do-test
+    (snek-edges s)
+    (make-array
+      (list 16 2)
+      :adjustable nil
+      :initial-contents
+        '((0 1) (1 0) (1 3) (1 10) (2 10) (3 1) (3 7) (5 11) (6 11)
+          (7 3) (10 1) (10 2) (11 5) (11 6) (0 0) (0 0))))
+
+  (do-test
+    (snek-verts s)
+    (make-array
+      (list 16 2)
+      :adjustable nil
+      :initial-contents
+        '((0.0 2.0) (2.0 3.0) (3.0 4.0) (4.0 7.0) (5.0 4.0) (0.0 6.0)
+          (-1.0 7.0) (0.0 8.0) (0.0 9.0) (10.0 1.0) (2.5 3.5) (-0.5 6.5)
+          (0.0 0.0) (0.0 0.0) (0.0 0.0) (0.0 0.0))))))
+
+
+(defun test-snek-withs ()
+  (let ((s (init-snek)))
+    (with-snek (s)
+      (with-rnd-vert (s v)
+        (append-edge v (list 3 2))
+        (move-vert v (list 2 2))))
+
+    (do-test
+      (snek-num-edges s)
+      12)
+
+    (do-test
+      (snek-num-verts s)
+      11)
+
+    (with-snek (s)
+      (with-all-verts (s v)
+        (move-vert v (list 2 2))))
+
+    (with-snek (s)
+      (with-rnd-edge (s e)
+        (split-edge e)))
+
+    (do-test
+      (snek-num-edges s)
+      14)
+
+    (do-test
+      (snek-num-verts s)
+      12)))
+
+
+(defun main ()
+
+  (format t "~%~%~%--------------------------------------- test utils")
+  (test-utils)
+
+  (format t "~%~%~%--------------------------------------- test bin")
+  (test-bin)
+
+  (format t "~%~%~%--------------------------------------- snek 1")
+  (test-snek (snek*))
+
+  (format t "~%~%~%--------------------------------------- snek 2")
+  (test-snek-2 (snek*))
+
+  (format t "~%~%~%--------------------------------------- snek 3")
+  (test-snek-3 (snek*))
+
+  (format t "~%~%~%--------------------------------------- snek move")
+  (test-snek-move)
+
+  (format t "~%~%~%--------------------------------------- snek join")
+  (test-snek-join)
+
+  (format t "~%~%~%--------------------------------------- snek append")
+  (test-snek-append)
+
+  (format t "~%~%~%--------------------------------------- snek split")
+  (test-snek-split)
+
+  (format t "~%~%~%--------------------------------------- snek with")
+  (test-snek-withs))
+
+(main)

snek/src/load.lisp

@@ -0,0 +1,11 @@
+
+(load "~/quicklisp/setup")
+
+(proclaim '(inline last1 single append1 conc1 mklist))
+(proclaim '(optimize speed))
+
+(load "snek/src/utils")
+(load "snek/src/lutils")
+(load "snek/src/lshapes")
+(load "snek/src/snek")
+(load "snek/src/sandpaint")

snek/src/lshapes.lisp

@@ -0,0 +1,131 @@
+
+
+(defun random-float (&optional (x 1.0))
+  (random (coerce x 'float)))
+
+
+(defun random-float* (&optional (x 1.0))
+  (- x (* 2.0 (random (coerce x 'float)))))
+
+
+
+; geometry
+
+
+(defun l-on-spiral (i itt rad &key (x 0.0) (y 0.0) (rot 1.0))
+  (ladd
+    (list x y)
+    (lscale
+      (cos-sin (* i (/ (* PI rot) itt)))
+      (* (/ i itt) rad))))
+
+
+(defun l-on-circle (i itt rad &key (x 0.0) (y 0.0))
+  (ladd
+    (list x y)
+    (lscale
+      (cos-sin (/ (* i PI 2.0) itt))
+      rad)))
+
+
+(defun l-on-line (i itt x1 x2)
+  (ladd
+    x1
+    (lscale
+      (lsub x2 x1)
+      (/ i itt))))
+
+
+(defun l-rand-on-circle (rad &key (x 0.0) (y 0.0))
+  (ladd
+    (list x y)
+    (lscale
+      (cos-sin (random (* PI 2.0)))
+      rad)))
+
+
+(defun l-rand-in-circle (rad &key (x 0.0) (y 0.0))
+  (let ((ab (sort (list (random 1.0) (random 1.0)) #'<)))
+    (ladd
+      (list x y)
+      (lscale
+        (cos-sin (* 2 pi (apply #'/ ab)))
+        (* (second ab) rad)))))
+
+
+(defun l-rand-in-box (sx sy &key (x 0.0) (y 0.0))
+  (ladd
+    (list (random-float* sx) (random-float* sy))
+    (list x y)))
+
+
+(defun l-rand-on-line (x1 x2)
+  (ladd
+    x1
+    (lscale (lsub x2 x1) (random 1.0))))
+
+
+(defun l-rand-on-spiral (rad &key (x 0.0) (y 0.0) (rot 1.0))
+  (let ((i (random 1.0)))
+    (ladd
+      (list x y)
+        (lscale
+          (cos-sin (* i (* PI rot)))
+          (* i rad)))))
+
+
+(defun l-polygon (n rad &key (x 0.0) (y 0.0) (rot 0.0))
+  (loop for i from 0 to n
+    collect
+      (ladd
+        (list x y)
+        (lscale
+          (cos-sin (+ rot (* (/ i n) 2 pi)))
+          rad))))
+
+
+(defun path-rel-lengths (points)
+  (destructuring-bind
+    (steps total)
+    (loop
+      with l
+      for i from 0 to (2- (length points))
+      do
+        (setf l (ldst (nth i points) (nth (1+ i) points)))
+      sum l into total
+      collect l into steps
+      finally
+        (return (list steps total)))
+
+      (append
+        (list 0)
+        (loop for s in steps
+          sum (/ s total) into summed
+          collect
+            summed))))
+
+
+(defun -diff-scale (a b s) (/ (- b a) s))
+
+(defun path-transform (p points lengths)
+  (let ((ind 0))
+    ; TODO use return instead
+    (loop
+      for n in lengths
+      for i from 0
+      do
+        (setf ind i)
+      until (< p n))
+
+    (let ((s (-diff-scale
+               (nth (1- ind) lengths)
+               p
+               (- (nth ind lengths) (nth (1- ind) lengths))))
+          (pb (nth ind points))
+          (pa (nth (1- ind) points)))
+      (ladd
+        pa
+        (lscale
+          (lsub pb pa)
+          s)))))
+

snek/src/lutils.lisp

@@ -0,0 +1,143 @@
+
+(defmacro cos-sin (a)
+  (with-gensyms (aname)
+    `(let ((,aname ,a))
+        (list (cos ,aname) (sin ,aname)))))
+
+(defmacro sin-cos (a)
+  (with-gensyms (aname)
+    `(let ((,aname ,a))
+        (list (sin ,aname) (cos ,aname)))))
+
+
+(defmacro 2d-square-loop ((x y s) &body body)
+  (with-gensyms (sname)
+    `(let ((,sname ,s))
+      (loop for ,x from 0 below ,sname do
+        (loop for ,y from 0 below ,sname do
+          ,@body)))))
+
+
+(defun lscale (a s)
+  (mapcar (lambda (x) (* x s)) a))
+
+(defun liscale (a s)
+  (mapcar (lambda (x) (/ x s)) a))
+
+
+(defun lsub (a b)
+  (mapcar #'- a b))
+
+
+(defun lisub (a b)
+  (mapcar #'- b a))
+
+
+(defun ladd (a b)
+  (mapcar #'+ a b))
+
+
+(defun lmult (a b)
+  (mapcar #'* a b))
+
+
+(defun ldot (a b)
+  (apply #'+ (lmult a b)))
+
+
+(defun ldiv (a b)
+  (mapcar #'/ a b))
+
+
+(defun lidiv (a b)
+  (mapcar #'/ b a))
+
+
+(defun llenn (a)
+  (reduce #'+ (mapcar (lambda (x) (* x x)) a)))
+
+
+(defun llen (a)
+  (sqrt (llenn a)))
+
+
+(defun ldst (a b)
+  (llen (lsub a b)))
+
+
+(defun lnorm (a)
+  (let ((l (llen a)))
+    (cond
+      ((<= l 0) a)
+      (t (lscale a (/ 1.0 l))))))
+
+
+(defun lnsub (a b)
+  (lnorm (lsub a b)))
+
+
+(defun lnadd (a b)
+  (lnorm (ladd a b)))
+
+
+(defun lmid (a b)
+  (lscale (ladd a b) 0.5))
+
+
+(defun lsum (a)
+  (reduce #'+ a))
+
+
+(defun lround (l)
+  (mapcar #'round l))
+
+
+(defun lget (ii a)
+  (loop for i in ii
+    collect (nth i a)))
+
+
+(defun l-rand-get (l)
+  (nth (random (list-length l)) l))
+
+
+(defun leql (a b)
+  (mapcar #'eql a b))
+
+
+(defun lgeq (a b)
+  (mapcar #'>= a b))
+
+
+(defun lleq (a b)
+  (mapcar #'<= a b))
+
+
+(defun range (n)
+  (loop for x from 0 to (1- n)
+    collect x))
+
+
+(defun linspace (a b n)
+  (loop for i from 0 to (1- n)
+    collect (+ a (* i (/ (- b a) (1- n))))))
+
+
+(defun lget (ii a)
+  (loop for i in ii
+    collect (nth i a)))
+
+
+; TODO: add dim option
+(defun l-get-as-list (arr row)
+  (mapcar
+    (lambda (d) (aref arr row d))
+    (list 0 1)))
+
+
+(defun l-set-from-list (arr row vals)
+  (mapcar
+    (lambda (d v) (setf (aref arr row d) v))
+    (list 0 1)
+    vals))
+

snek/src/sandpaint.lisp

@@ -0,0 +1,187 @@
+
+(defpackage :sandpaint
+  (:use :common-lisp))
+
+
+(ql:quickload "ZPNG")
+
+
+; UTILS
+
+
+(defun -scale-convert (v &key (scale 1.0d0) (gamma 1.0d0))
+  (setf v (expt (/ v scale) gamma)))
+
+
+(defun -unsigned-256 (v)
+  (cond
+    ((> v 1.0d0) 255)
+    ((< v 0.0d0) 0)
+    (t (round (* 255 v)))))
+
+
+(defun to-double-float (l)
+  (mapcar (lambda (x) (coerce x 'double-float)) l))
+
+
+(defun -setf-operator-over (vals x y i -alpha color)
+  (setf
+    (aref vals x y i)
+    (+ (* (aref vals x y i) -alpha) color)))
+
+(defun -operator-over (size vals x y r g b a)
+  (if (and (>= x 0) (< x size) (>= y 0) (< y size))
+    (let ((ia (- 1.0 a)))
+      (-setf-operator-over vals x y 0 ia r)
+      (-setf-operator-over vals x y 1 ia g)
+      (-setf-operator-over vals x y 2 ia b)
+      (-setf-operator-over vals x y 3 ia a))))
+
+
+(defun -sandpaint-edge (vals size num v1 v2 r g b a)
+  (loop for i from 1 to num
+    do
+      (destructuring-bind (x y)
+        (lround (l-rand-on-line v1 v2))
+        (-operator-over size vals x y r g b a))))
+
+
+(defun copy-rgba-array-to-from (target source size)
+  (2d-square-loop (x y size)
+    (loop for i from 0 to 3 do
+      (setf (aref target x y i) (aref source x y i)))))
+
+
+
+; SNEK SAND PAINT
+
+
+(defstruct sandpaint
+  (vals nil :read-only nil)
+  (size -1 :type integer :read-only nil)
+  (r 0.0d0 :type double-float :read-only nil)
+  (g 0.0d0 :type double-float :read-only nil)
+  (b 0.0d0 :type double-float :read-only nil)
+  (a 1.0d0 :type double-float :read-only nil))
+
+
+(defun sandpaint*
+    (size
+     &key
+       (active '(1.0d0 1.0d0 1.0d0 1.0d0))
+       (bg '(0.0d0 0.0d0 0.0d0 1.0d0)))
+  (destructuring-bind (ar ag ab aa br bg bb ba)
+    (mapcar
+      (lambda (c) (coerce c 'double-float))
+      (append active bg))
+
+    (let ((vals (make-rgba-array size)))
+      (2d-square-loop (x y size)
+        (setf (aref vals x y 0) (* ba br))
+        (setf (aref vals x y 1) (* ba bg))
+        (setf (aref vals x y 2) (* ba bb))
+        (setf (aref vals x y 3) ba))
+
+      (make-sandpaint
+        :size size
+        :r (* ar aa)
+        :g (* ag aa)
+        :b (* ab aa)
+        :a aa
+        :vals vals))))
+
+
+(defun sandpaint-set-rgba (sand rgba)
+  (destructuring-bind (r g b a)
+    (to-double-float rgba)
+      (setf (sandpaint-r sand) (* r a))
+      (setf (sandpaint-g sand) (* g a))
+      (setf (sandpaint-b sand) (* b a))
+      (setf (sandpaint-a sand) a)))
+
+
+(defun sandpaint-edges (sand s num)
+  (with-struct (sandpaint- size vals r g b a) sand
+    (with-all-edges (s ee)
+      (destructuring-bind (v1 v2)
+        (get-verts ee from s)
+        (-sandpaint-edge
+          vals size num v1 v2 r g b a)))))
+
+
+; TODO implement wrapper
+;(defun -sandpaint-vert-box (vals size mx my grains w h r g b a)
+;  (loop for i from 0 to grains do
+;    (destructuring-bind (x y)
+;      (mapcar #'round (l-rand-in-box w h :x mx :y my))
+;      (-operator-over size vals x y r g b a))))
+
+(defun -sandpaint-vert (vals size x y r g b a)
+  (-operator-over size vals x y r g b a))
+
+(defun sandpaint-verts (sand s)
+  (with-struct (sandpaint- size vals r g b a) sand
+    (with-all-verts (s v)
+      (destructuring-bind (x y)
+        (get-vert v from s)
+          (-sandpaint-vert vals size (round x) (round y) r g b a)))))
+
+
+(defun -offset-rgba (new-vals old-vals size x y nxy i)
+  (destructuring-bind (nx ny)
+    (mapcar #'round nxy)
+    (if (and (>= nx 0) (< nx size) (>= ny 0) (< ny size))
+      (setf (aref new-vals nx ny i) (aref old-vals x y i)))))
+
+(defun sandpaint-chromatic-aberration (sand C s)
+  (with-struct (sandpaint- size vals) sand
+    (let ((new-vals (make-rgba-array size)))
+      (copy-rgba-array-to-from new-vals vals size)
+
+      (2d-square-loop (x y size)
+        (let* ((xy (list x y))
+               (dx (liscale
+                     (lsub
+                       (ladd (l-rand-in-circle 1.0) xy)
+                       C)
+                     s)))
+          (-offset-rgba new-vals vals size x y (ladd xy dx) 0)
+          (-offset-rgba new-vals vals size x y (lsub xy dx) 2)))
+
+      (setf (sandpaint-vals sand) new-vals))))
+
+
+(defun -pixel-hack (sand)
+  (let ((vals (sandpaint-vals sand)))
+    (setf (aref vals 0 0 3) 0.5d0)))
+
+
+(defun -png-tuple (vals x y gamma)
+  (let ((a (aref vals x y 3)))
+    (list
+      (-unsigned-256 (-scale-convert (aref vals x y 0) :scale a :gamma gamma))
+      (-unsigned-256 (-scale-convert (aref vals x y 1) :scale a :gamma gamma))
+      (-unsigned-256 (-scale-convert (aref vals x y 2) :scale a :gamma gamma))
+      (-unsigned-256 (-scale-convert a :gamma gamma)))))
+
+(defun sandpaint-save (sand name &key (gamma 1.0))
+  (if (not name) (error "missing result file name."))
+  (with-struct (sandpaint- size vals) sand
+    (let ((png
+             (make-instance
+               'zpng::pixel-streamed-png
+               :color-type :truecolor-alpha
+               :width size
+               :height size)))
+
+      (with-open-file
+        (stream name
+          :direction :output
+          :if-exists :supersede
+          :if-does-not-exist :create
+          :element-type '(unsigned-byte 8))
+        (zpng:start-png png stream)
+        (2d-square-loop (x y size)
+          (zpng:write-pixel (-png-tuple vals y x gamma) png))
+        (zpng:finish-png png)))))
+

snek/src/snek.lisp

@@ -0,0 +1,408 @@
+
+(defpackage :snek
+  (:use :common-lisp))
+
+
+
+; MACROS
+
+
+(defmacro insert-vert (v into snk)
+  (declare (ignore into))
+  (with-gensyms (cname vname)
+    `(let ((,vname ,v)
+           (,cname (snek-num-verts ,snk)))
+     (setf (aref (snek-verts ,snk) ,cname 0) (coerce (first ,vname) 'float))
+     (setf (aref (snek-verts ,snk) ,cname 1) (coerce (second ,vname) 'float))
+     (- (incf (snek-num-verts ,snk)) 1))))
+
+
+(defmacro get-vert (v from snk)
+  (declare (ignore from))
+  (with-gensyms (vname)
+    `(let ((,vname ,v))
+      (list (aref (snek-verts ,snk) ,vname 0)
+            (aref (snek-verts ,snk) ,vname 1)))))
+
+
+(defmacro get-verts (vv from snk)
+  (declare (ignore from))
+  (with-gensyms (vname v)
+    `(let ((,vname ,vv))
+       (loop for ,v in ,vname collect
+         (list (aref (snek-verts ,snk) ,v 0)
+               (aref (snek-verts ,snk) ,v 1))))))
+
+
+(defmacro get-edge (e from snk)
+  (declare (ignore from))
+  (with-gensyms (ename)
+    `(let ((,ename ,e))
+      (list (aref (snek-edges, snk) ,ename 0)
+            (aref (snek-edges ,snk) ,ename 1)))))
+
+
+(defmacro insert-edge (e into snk)
+  (declare (ignore into))
+  (with-gensyms (ename edges num)
+    `(let ((,ename ,e)
+           (,edges (snek-edges ,snk))
+           (,num (snek-num-edges ,snk)))
+       (cond
+         ((-binary-edge-search ,edges ,ename ,num)
+          nil)
+         ((eql (first ,ename) (second ,ename))
+          nil)
+         (t
+           (setf (snek-num-edges ,snk) (+ 2 ,num))
+           (-find-insert-edge ,edges ,num ,ename)
+           (sort
+             (-find-insert-edge ,edges (1+ ,num) (reverse ,ename))
+             #'<))))))
+
+
+(defmacro remove-edge (e from snk)
+  (declare (ignore from))
+  (with-gensyms (ename lname edges num)
+    `(let ((,ename ,e)
+           (,edges (snek-edges ,snk))
+           (,num (snek-num-edges ,snk)))
+
+       (setf (snek-num-edges ,snk) (- ,num (loop for ,lname in
+         (list
+           (-find-remove-edge ,edges ,num ,ename)
+           (-find-remove-edge ,edges (1- ,num) (reverse ,ename)))
+         sum ,lname)))
+       (- ,num (snek-num-edges ,snk)))))
+
+
+(defmacro get-one-ring (of v from snk)
+  (declare (ignore from) (ignore of))
+  (with-gensyms (vname)
+    `(let ((,vname ,v))
+       (-one-ring (snek-edges ,snk) ,vname (snek-num-edges ,snk)))))
+
+
+(defmacro with-snek ((snk) &body body)
+  `(do-alts
+     (remove-if-not
+       #'alt-p
+       (flatten (list ,@body))) ,snk))
+
+
+(defmacro with-snek-print ((snk) &body body)
+  (declare (ignore snk))
+  `(print
+     (remove-if-not
+       #'alt-p
+       (flatten (list ,@body)))))
+
+
+(defmacro with-rnd-edge ((snk i) &body body)
+  `(if (> (snek-num-edges ,snk) 0)
+    (let ((,i (l-get-as-list
+                   (snek-edges ,snk)
+                   (random (snek-num-edges ,snk)))))
+        (list ,@body))
+    nil))
+
+
+(defmacro with-rnd-vert ((snk i) &body body)
+  `(let ((,i (random (snek-num-verts ,snk))))
+    (list ,@body)))
+
+
+(defun -get-force-alterations (u v f)
+  (list
+    (move-vert v f)
+    (move-vert u (lscale f -1.0))))
+
+(defmacro force (snk v1 v2 r)
+  (with-gensyms (vname v1name v2name a b aname rname)
+    `(let ((,v1name ,v1)
+           (,v2name ,v2)
+           (,vname (snek-verts ,snk))
+           (,rname ,r))
+        (-get-force-alterations
+          ,v1 ,v2
+          (lscale
+            (lnsub
+              (l-get-as-list ,vname ,v1name)
+              (l-get-as-list ,vname ,v2name))
+            ,rname)))))
+
+
+(defmacro with-rnd-vert-value ((snk i) &body body)
+  `(let ((,i (l-rand-get (snek-verts ,snk))))
+    (list ,@body)))
+
+
+(defmacro with-all-verts ((snk i) &body body)
+  `(loop for ,i from 0 below (snek-num-verts ,snk)
+     collect (list ,@body)))
+
+
+
+(defmacro with-all-edges ((snk i) &body body)
+  (with-gensyms (kname)
+    `(loop
+        with ,i
+        for ,kname from 0 below (snek-num-edges ,snk)
+        do
+          (setf ,i (l-get-as-list (snek-edges ,snk) ,kname))
+        if (< (first ,i) (second ,i))
+        collect (list ,@body))))
+
+
+(defmacro with-prob (p &body body)
+  (with-gensyms (pname)
+    `(let ((,pname ,p))
+       (if (< (random 1.0) ,p)
+         (list ,@body)))))
+
+
+
+; SNEK
+
+(defstruct snek
+  (edges nil :read-only nil)
+  (verts nil :read-only nil)
+  (num-edges 0 :type integer :read-only nil)
+  (num-verts 0 :type integer :read-only nil)
+  (max-num 100000 :type integer :read-only t))
+
+
+(defun snek* (&optional (max-num 100000))
+  (make-snek
+    :edges (make-int-array max-num)
+    :verts (make-float-array max-num)
+    :max-num max-num))
+
+
+(defun -one-ring (edges v num)
+  (loop for i from 0 below num
+    if (eql v (aref edges i 0))
+    collect (l-get-as-list edges i)))
+
+
+(defun -edge-compare (a b c d)
+  (or
+    (and (>= a b) (>= c d))
+    (> a b)))
+
+
+(defun -binary-edge-insert-search (arr target num)
+  (let ((left 0)
+        (right (1- num)))
+    (do () ((< right left) left)
+      (let ((mid (floor (+ left right) 2)))
+        (cond
+          ((not (-edge-compare
+                  (first target)
+                  (aref arr mid 0)
+                  (second target)
+                  (aref arr mid 1)))
+            (setf right (1- mid)))
+          (t
+            (setf left (1+ mid))))))))
+
+
+;TODO: is this tail recursive?
+(defun -binary-edge-search (arr target num &key (left 0) (right nil))
+  (destructuring-bind (a c) target
+    (if (eql right nil)
+      (setf right (1- num)))
+    (let ((mid (floor (+ left right) 2)))
+        (cond
+          ((< right left) nil)
+          ((and
+             (eql a (aref arr mid 0))
+             (eql c (aref arr mid 1)))
+            mid)
+          ((not (-edge-compare a (aref arr mid 0) c (aref arr mid 1)))
+            (-binary-edge-search arr target num :left left :right (1- mid)))
+          (t (-binary-edge-search arr target num :left (1+ mid) :right right))))))
+
+
+(defun -insert-edge (edges edge pos num)
+  (loop for i from 0 below (- num pos) do
+    (let ((left (- num (1+ i)))
+          (right (- num i)))
+      (setf (aref edges right 0) (aref edges left 0))
+      (setf (aref edges right 1) (aref edges left 1))))
+    (setf (aref edges pos 0) (first edge))
+    (setf (aref edges pos 1) (second edge)))
+
+
+(defun -find-insert-edge (edges num e)
+  (-insert-edge
+    edges
+    e
+    (-binary-edge-insert-search edges e num)
+    num)
+  e)
+
+
+(defun -remove-edge (edges pos num)
+  (loop for i from pos to (2- num) do
+    (setf (aref edges i 0) (aref edges (1+ i) 0))
+    (setf (aref edges i 1) (aref edges (1+ i) 1)))
+  (l-set-from-list edges (1- num) (list 0 0)))
+
+
+(defun -find-remove-edge (edges num e)
+  (let ((p (-binary-edge-search edges e num)))
+    (if p
+      (progn
+       (-remove-edge edges p num) 1)
+      0)))
+
+
+
+; ALTERATIONS
+
+
+; MOVE VERT
+
+(defstruct (move-vert-alt
+    (:constructor move-vert (v xy &key (rel t))))
+  (rel t :type boolean :read-only t)
+  (xy nil :type list :read-only t)
+  (v -1 :type integer :read-only t))
+
+
+(defun do-move-vert-alt (a snk)
+  (let ((verts (snek-verts snk)))
+    (with-struct (move-vert-alt- v xy rel) a
+      (if rel
+        (l-set-from-list
+          verts v
+          (ladd
+            (l-get-as-list verts v)
+            xy))
+        (l-set-from-list verts v xy)))))
+
+
+
+; APPEND EDGE
+
+(defstruct (append-edge-alt
+    (:constructor append-edge (v xy &key (rel t))))
+  (xy nil :type list :read-only t)
+  (v -1 :type integer :read-only t)
+  (rel t :type boolean :read-only t))
+
+
+(defun do-append-edge-alt (a snk)
+  (with-struct (append-edge-alt- v xy rel) a
+    (cond
+      (rel
+        (insert-vert (ladd (get-vert v from snk) xy) into snk))
+      (t
+        (insert-vert xy into snk)))
+
+      (insert-edge
+        (list
+          v
+          (1- (snek-num-verts snk)))
+        into snk)))
+
+
+; JOIN VERTS
+
+(defstruct (join-verts-alt
+    (:constructor join-verts (v1 v2)))
+  (v1 -1 :type integer :read-only t)
+  (v2 -1 :type integer :read-only t))
+
+
+(defun do-join-verts-alt (a snk)
+  (with-struct (join-verts-alt- v1 v2) a
+    (insert-edge (list v1 v2) into snk)))
+
+
+; SPLIT EDGE
+
+(defstruct (split-edge-alt
+    (:constructor split-edge (e)))
+  (e nil :type list :read-only t))
+
+
+(defun do-split-edge-alt (a snk)
+  (with-struct (split-edge-alt- e) a
+    (let ((res (remove-edge e from snk))
+          (verts (snek-verts snk)))
+      (destructuring-bind (a b) e
+        (if (> res 1)
+          (let ((c (insert-vert
+                      (lmid (l-get-as-list verts a)
+                            (l-get-as-list verts b))
+                      into snk)))
+            (insert-edge (list a c) into snk)
+            (insert-edge (list c b) into snk)))))))
+
+
+; ALTERATION UTILS
+
+(defun do-alt (a snk)
+  (cond
+    ((append-edge-alt-p a) (do-append-edge-alt a snk))
+    ((move-vert-alt-p a) (do-move-vert-alt a snk))
+    ((join-verts-alt-p a) (do-join-verts-alt a snk))
+    ((split-edge-alt-p a) (do-split-edge-alt a snk))))
+
+
+(defun do-alts (alts snk)
+  (dolist (a alts) (do-alt a snk)))
+
+
+(defun alt-p (a)
+  (cond
+    ((append-edge-alt-p a) t)
+    ((move-vert-alt-p a) t)
+    ((join-verts-alt-p a) t)
+    ((split-edge-alt-p a) t)
+    (t nil)))
+
+
+
+; OTHER UTILS
+
+(defun edge-length (snk e)
+  (with-struct (snek- verts) snk
+    (apply #'ldst (mapcar (lambda (v) (l-get-as-list verts v)) e))))
+
+
+(defun snek-init-circle (snk num rad &key (x 0.0) (y 0.0))
+  (let ((verts (loop for i from 0 below num collect
+    (insert-vert
+      (ladd
+        (list x y)
+        (lscale (cos-sin (/ (* i PI 2.0) num)) rad)) into snk))))
+
+    (loop for i from 0 below num do
+      (insert-edge (list (nth i verts) (nth (mod (1+ i) num) verts))
+                    into snk))))
+
+(defun snek-init-line (snk num a b)
+  (let ((verts (loop for i from 0 below num collect
+    (insert-vert (l-on-line i num a b) into snk))))
+
+    (loop for i from 0 below num do
+      (insert-edge (list (nth i verts) (nth (mod (1+ i) num) verts))
+                    into snk))))
+
+
+(defun show-snek-edges (snk)
+  (let ((edges (snek-edges snk)))
+    (loop for i from 0 below (snek-num-edges snk) do
+      (print (aref edges i 0))
+      (prin1 (aref edges i 1)))))
+
+
+(defun show-snek-verts (snk)
+  (let ((verts (snek-verts snk)))
+    (loop for i from 0 below (snek-num-verts snk) do
+      (print (aref verts i 0))
+      (prin1 (aref verts i 1)))))
+

snek/src/utils.lisp

@@ -0,0 +1,110 @@
+
+(defun .1* (l) (* l 0.1))
+
+(defun .25* (l) (* l 0.25))
+
+(defun .5* (l) (* l 0.5))
+
+(defun 2* (l) (* l 2))
+
+(defun 3* (l) (* l 3))
+
+(defun 4* (l) (* l 4))
+
+(defun 2+ (l) (+ l 2))
+
+(defun 2- (l) (- l 2))
+
+
+(defun make-rgba-array (size)
+  (make-array
+    (list size size 4)
+    :adjustable nil
+    :initial-element 0.0d0
+    :element-type 'double-float))
+
+
+(defun make-float-array (rows &key (cols 2) (initial 0.0))
+  (make-array
+    (list rows cols)
+    :adjustable t
+    :initial-element initial
+    :element-type 'float ))
+
+
+(defun make-int-array (rows  &key (cols 2) (initial 0))
+  (make-array
+    (list rows cols)
+    :adjustable t
+    :initial-element initial
+    :element-type 'integer))
+
+
+;http://cl-cookbook.sourceforge.net/os.html
+(defun cmd-args ()
+  (or #+SBCL *posix-argv*
+      #+LISPWORKS system:*line-arguments-list*
+      #+CMU extensions:*command-line-words*
+       nil))
+
+
+;(defun flatten (l)
+;  (cond
+;    ((null l) nil)
+;    ((atom l) (list l))
+;    (t (loop for a in l appending (flatten a)))))
+
+
+; below code is from from On Lisp by Paul Graham.
+; http://ep.yimg.com/ty/cdn/paulgraham/onlisp.lisp
+
+; This code is copyright 1993 by Paul Graham, but anyone who wants
+; to use the code in any nonprofit activity, or distribute free
+; verbatim copies (including this notice), is encouraged to do so.
+
+
+(defun flatten (x)
+  (labels ((rec (x acc)
+             (cond ((null x) acc)
+                   ((atom x) (cons x acc))
+                   (t (rec (car x) (rec (cdr x) acc))))))
+    (rec x nil)))
+
+
+(defun group (source n)
+  (if (zerop n) (error "zero length"))
+  (labels ((rec (source acc)
+             (let ((rest (nthcdr n source)))
+               (if (consp rest)
+                   (rec rest (cons (subseq source 0 n) acc))
+                   (nreverse (cons source acc))))))
+    (if source (rec source nil) nil)))
+
+
+(defun mkstr (&rest args)
+  (with-output-to-string (s)
+    (dolist (a args) (princ a s))))
+
+
+(defun symb (&rest args)
+  (values (intern (apply #'mkstr args))))
+
+
+(defmacro with-gensyms (syms &body body)
+  `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
+                 syms)
+     ,@body))
+
+
+(defmacro mac (expr)
+  `(pprint (macroexpand-1 ',expr)))
+
+
+(defmacro with-struct ((name . fields) struct &body body)
+  (let ((gs (gensym)))
+    `(let ((,gs ,struct))
+       (let ,(mapcar #'(lambda (f)
+                         `(,f (,(symb name f) ,gs)))
+                     fields)
+         ,@body))))
+