diff --git a/snek/.editorconfig b/snek/.editorconfig new file mode 100644 index 0000000..0a50d3d --- /dev/null +++ b/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 + diff --git a/snek/.genlog/20170101-113919-781846-c9e400c-e1b5208.png b/snek/.genlog/20170101-113919-781846-c9e400c-e1b5208.png new file mode 100644 index 0000000..c1b78e9 Binary files /dev/null and b/snek/.genlog/20170101-113919-781846-c9e400c-e1b5208.png differ diff --git a/snek/.genlog/20170101-131957-836422-aca6e05-a340cf7.png b/snek/.genlog/20170101-131957-836422-aca6e05-a340cf7.png new file mode 100644 index 0000000..4be4919 Binary files /dev/null and b/snek/.genlog/20170101-131957-836422-aca6e05-a340cf7.png differ diff --git a/snek/.genlog/20170101-153502-522871-790a81d-3f28e41.png b/snek/.genlog/20170101-153502-522871-790a81d-3f28e41.png new file mode 100644 index 0000000..277ce24 Binary files /dev/null and b/snek/.genlog/20170101-153502-522871-790a81d-3f28e41.png differ diff --git a/snek/.genlog/20170101-212125-779175-1da5a41-7208651.png b/snek/.genlog/20170101-212125-779175-1da5a41-7208651.png new file mode 100644 index 0000000..a78658b Binary files /dev/null and b/snek/.genlog/20170101-212125-779175-1da5a41-7208651.png differ diff --git a/snek/LICENSE b/snek/LICENSE new file mode 100644 index 0000000..abbb85b --- /dev/null +++ b/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. diff --git a/snek/README.md b/snek/README.md new file mode 100644 index 0000000..6ce23b6 --- /dev/null +++ b/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) + diff --git a/snek/VERSION b/snek/VERSION new file mode 100644 index 0000000..236c7ad --- /dev/null +++ b/snek/VERSION @@ -0,0 +1 @@ +0.0.21 diff --git a/snek/img/img.png b/snek/img/img.png new file mode 100644 index 0000000..98d8486 Binary files /dev/null and b/snek/img/img.png differ diff --git a/snek/res/.empty b/snek/res/.empty new file mode 100644 index 0000000..e69de29 diff --git a/snek/run-lines.lisp b/snek/run-lines.lisp new file mode 100755 index 0000000..95e2f06 --- /dev/null +++ b/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)))) + diff --git a/snek/run-slope.lisp b/snek/run-slope.lisp new file mode 100755 index 0000000..e3721fc --- /dev/null +++ b/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)))) + diff --git a/snek/run-test.lisp b/snek/run-test.lisp new file mode 100755 index 0000000..34297d3 --- /dev/null +++ b/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) diff --git a/snek/src/load.lisp b/snek/src/load.lisp new file mode 100644 index 0000000..ff8855a --- /dev/null +++ b/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") diff --git a/snek/src/lshapes.lisp b/snek/src/lshapes.lisp new file mode 100644 index 0000000..e72f38e --- /dev/null +++ b/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))))) + diff --git a/snek/src/lutils.lisp b/snek/src/lutils.lisp new file mode 100644 index 0000000..2214774 --- /dev/null +++ b/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)) + diff --git a/snek/src/sandpaint.lisp b/snek/src/sandpaint.lisp new file mode 100644 index 0000000..926d4f6 --- /dev/null +++ b/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))))) + diff --git a/snek/src/snek.lisp b/snek/src/snek.lisp new file mode 100644 index 0000000..7ee9bbb --- /dev/null +++ b/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))))) + diff --git a/snek/src/utils.lisp b/snek/src/utils.lisp new file mode 100644 index 0000000..88f25ae --- /dev/null +++ b/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)))) +