hellerve/shinu
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

reinlined snek

Browse Source
This commit is contained in:
Veit Heller
2017-03-08 21:56:30 +01:00
parent 7531a0cec4
commit 274c00ad21
19 changed files with 1751 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
snek/src/load.lisp Normal file
View File

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

131
snek/src/lshapes.lisp Normal file
View File

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

143
snek/src/lutils.lisp Normal file
View File

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

187
snek/src/sandpaint.lisp Normal file
View File

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

408
snek/src/snek.lisp Normal file
View File

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

110
snek/src/utils.lisp Normal file
View File

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