├── .dockerignore ├── .editorconfig ├── .gitignore ├── Dockerfile ├── LICENSE ├── README.md ├── compile.sh ├── examples ├── custom-alt.lisp ├── differential-line.lisp ├── lines.lisp ├── load.lisp └── rel-neigh.lisp ├── run-tests.sh ├── src ├── auxiliary │ ├── convex.lisp │ ├── dat.lisp │ └── obj.lisp ├── config.lisp ├── distance │ ├── kdtree.lisp │ └── zonemap.lisp ├── draw │ ├── bzspl.lisp │ ├── cpath.lisp │ ├── draw-svg.lisp │ ├── hatch.lisp │ ├── jpath.lisp │ ├── lin-path.lisp │ ├── line-remove.lisp │ ├── sandpaint-extra.lisp │ └── sandpaint.lisp ├── fn.lisp ├── graph │ ├── edge-set.lisp │ ├── main.lisp │ ├── mst-cycle.lisp │ └── paths.lisp ├── gridfont │ ├── main.lisp │ └── smooth.json ├── hset.lisp ├── math │ ├── curvature.lisp │ ├── math.lisp │ ├── path.lisp │ └── simplify-path.lisp ├── packages.lisp ├── parallel │ └── main.lisp ├── pigment │ ├── extra.lisp │ ├── non-alpha.lisp │ └── pigment.lisp ├── project │ ├── ortho.lisp │ └── perspective.lisp ├── rnd │ ├── 3rnd.lisp │ ├── extra.lisp │ ├── rnd.lisp │ └── walkers.lisp ├── state.lisp ├── various.lisp ├── vec │ ├── 3vec.lisp │ ├── avec.lisp │ ├── base.lisp │ ├── checks.lisp │ └── vec.lisp └── weir │ ├── 3alterations.lisp │ ├── 3vert-utils.lisp │ ├── alterations.lisp │ ├── paths.lisp │ ├── planar-cycles.lisp │ ├── props.lisp │ ├── vert-utils.lisp │ ├── weir-extra.lisp │ ├── weir-macro.lisp │ ├── weir-with-macro.lisp │ └── weir.lisp ├── system-index.txt ├── test ├── bzspl.lisp ├── chromatic.lisp ├── chromatic.png ├── curvature.lisp ├── data │ ├── pix-overlap.png │ ├── plot-cpath.svg │ ├── plot-jpath.svg │ ├── plot-outline-path.svg │ ├── plot-simplify.svg │ ├── plot.svg │ ├── sandpaint-16.png │ ├── sandpaint-8.png │ ├── sandpaint-circ.png │ ├── sandpaint-rnd.png │ └── weir-loops.svg ├── graph.lisp ├── hset.lisp ├── kdtree.lisp ├── linear-path.lisp ├── math.lisp ├── ortho.lisp ├── parallel.lisp ├── pigment.lisp ├── pix-overlap.lisp ├── plot-cpath.lisp ├── plot-jpath.lisp ├── plot-outline-path.lisp ├── plot-paths.lisp ├── plot-simplify.lisp ├── plot.lisp ├── rnd.lisp ├── sandpaint.lisp ├── test.lisp ├── vec.lisp ├── weir-loop.lisp ├── weir.lisp └── weir3.lisp └── weir.asd /.dockerignore: -------------------------------------------------------------------------------- 1 | .git 2 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://EditorConfig.org 2 | 3 | # top-most EditorConfig file 4 | root = true 5 | 6 | # Unix-style newlines with a newline ending every file 7 | [*] 8 | end_of_line = lf 9 | insert_final_newline = true 10 | charset = utf-8 11 | indent_style = space 12 | indent_size = 2 13 | trim_trailing_whitespace = true 14 | 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.png 2 | *.svg 3 | *.dat 4 | *.obj 5 | *.mp4 6 | *.tmp 7 | *.gif 8 | *weir.core 9 | tmp.lisp 10 | system-index.txt 11 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # This image is only intended to run the tests 2 | 3 | FROM ubuntu:latest AS base 4 | 5 | RUN apt-get -qq update &&\ 6 | apt-get -qq dist-upgrade -y &&\ 7 | apt-get -qq install -y sbcl curl gcc libpng-dev 8 | 9 | WORKDIR /opt 10 | RUN curl -s 'https://beta.quicklisp.org/quicklisp.lisp' > /opt/quicklisp.lisp 11 | RUN sbcl --noinform --load /opt/quicklisp.lisp\ 12 | --eval '(quicklisp-quickstart:install :path "/opt/quicklisp")'\ 13 | --eval '(sb-ext:quit)' 14 | 15 | RUN mkdir -p /root/quicklisp &&\ 16 | ln -s /opt/quicklisp/setup.lisp /root/quicklisp/setup.lisp 17 | RUN mkdir -p /opt/data 18 | RUN apt-get -qq remove curl -y &&\ 19 | apt-get -qq autoremove -y &&\ 20 | apt-get -qq autoclean -y 21 | 22 | from base AS build 23 | 24 | WORKDIR /opt 25 | ADD src /opt/src 26 | ADD test /opt/test 27 | ADD weir.asd /opt 28 | ADD run-tests.sh /opt 29 | 30 | CMD ["bash", "./run-tests.sh"] 31 | 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This code is released under the MIT license(see below). Unless otherwise noted. 2 | 3 | Most prominent exceptions are: 4 | 5 | 1. Some utilities from On Lisp by Paul Graham (in src/various.lisp). They are 6 | bound by this notice: 7 | 8 | --- 9 | This code is copyright 1993 by Paul Graham, but anyone who wants 10 | to use the code in any nonprofit activity, or distribute free 11 | verbatim copies (including this notice), is encouraged to do so. 12 | --- 13 | 14 | 2. Some modified code by Victor Anyakin in (in src/auxiliary/dat.lisp): 15 | 16 | --- 17 | Copyright (c) 2013-2018 Victor Anyakin 18 | All rights reserved. 19 | 20 | Redistribution and use in source and binary forms, with or without 21 | modification, are permitted provided that the following conditions are met: 22 | * Redistributions of source code must retain the above copyright 23 | notice, this list of conditions and the following disclaimer. 24 | * Redistributions in binary form must reproduce the above copyright 25 | notice, this list of conditions and the following disclaimer in the 26 | documentation and/or other materials provided with the distribution. 27 | * Neither the name of the organization nor the 28 | names of its contributors may be used to endorse or promote products 29 | derived from this software without specific prior written permission. 30 | 31 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 32 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 33 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 34 | DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDER BE LIABLE FOR ANY 35 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 36 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 37 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 38 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 39 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 40 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 41 | --- 42 | 43 | 3. Some code suggested by @lispm (in src/auxiliary/dat.lisp, src/various.lisp). There 44 | are links to the original suggestions 45 | 46 | --------- 47 | 48 | The MIT License (MIT) 49 | 50 | Copyright 2020 ANDERS HOFF 51 | 52 | Permission is hereby granted, free of charge, to any person obtaining a copy of 53 | this software and associated documentation files (the "Software"), to deal in 54 | the Software without restriction, including without limitation the rights to 55 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 56 | of the Software, and to permit persons to whom the Software is furnished to do 57 | so, subject to the following conditions: 58 | 59 | The above copyright notice and this permission notice shall be included in all 60 | copies or substantial portions of the Software. 61 | 62 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 63 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 64 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 65 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 66 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 67 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 68 | SOFTWARE. 69 | -------------------------------------------------------------------------------- /compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | touch ./weir.asd 5 | sbcl --quit \ 6 | --eval '(load "~/quicklisp/setup.lisp")'\ 7 | --eval '(load "weir.asd")'\ 8 | --eval '(handler-case (ql:quickload :weir :verbose t) 9 | (error (c) (print c) (sb-ext:quit :unix-status 2)))'\ 10 | >compile.sh.tmp 2>&1 11 | -------------------------------------------------------------------------------- /examples/custom-alt.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/sbcl --script 2 | 3 | ; set your path to sbcl above. i would use env, but it does not appear to work 4 | ; with the --script argument. alternately, delete the shebang and the load 5 | ; below. and run from repl. let me know if you have a better suggestion for 6 | ; making this easily runnable from terminal 7 | 8 | (load "load") 9 | 10 | ; custom alteration 11 | ; add new vert inside rad of c if there is no collision 12 | (defun vert-if-no-collision? (c rad xy) 13 | (lambda (wer) 14 | (when (<= (length (weir:verts-in-rad wer xy rad)) 1) 15 | (weir::-valid-vert ((weir::weir-num-verts wer) c :err nil) 16 | (weir:add-vert! wer xy))))) 17 | 18 | 19 | ; some kind of non-colliding random walk 20 | (defun random-walk (wer psvg rad) 21 | (loop with curr = (weir:add-vert! wer 22 | (rnd:in-circ 200d0 :xy (vec:rep 500d0))) 23 | repeat 100 24 | do (weir:build-zonemap wer rad) 25 | (weir:with (wer % :db t) 26 | (% (lambda () (print :e)) :arg (:e)) 27 | ; the result of this alteration will be available 28 | ; inside this context as :v 29 | (% (vert-if-no-collision? curr rad 30 | (rnd:in-circ rad 31 | :xy (weir:get-vert wer curr))) :res :v) 32 | ; this alteration references (:v), and the result will 33 | ; be avilable as :e (it is used below) 34 | (% (weir:add-edge? :v curr) :res :e :arg (:v)) 35 | 36 | ; lambdas are allowed as well. 37 | ; draw new edge, and update curr. 38 | ; if you provide an argument to lambda it will be wer when it is 39 | ; executed 40 | (% (lambda () (progn (setf curr :v) 41 | (draw-svg:path psvg 42 | (weir:get-verts wer :e)))) 43 | :arg (:v :e))))) 44 | 45 | 46 | (defun main (fn) 47 | (let ((rad 7d0) 48 | (wer (weir:make)) 49 | (psvg (draw-svg:make))) 50 | (loop repeat 50 do (random-walk wer psvg rad)) 51 | (draw-svg:save psvg fn))) 52 | 53 | 54 | (time (main (second (weir-utils:cmd-args)))) 55 | 56 | -------------------------------------------------------------------------------- /examples/differential-line.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/sbcl --script 2 | 3 | ; set your path to sbcl above. i would use env, but it does not appear to work 4 | ; with the --script argument. alternately, delete the shebang and the load 5 | ; below. and run from repl. let me know if you have a better suggestion for 6 | ; making this easily runnable from terminal 7 | 8 | (load "load") 9 | 10 | (defvar signs (list 1d0 -1d0)) 11 | 12 | 13 | (defun init (wer xy) 14 | (weir:add-path! wer (vec:polygon 10 20d0 :xy xy) :closed t)) 15 | 16 | (defun attract (f s attract) 17 | (vec:smult (vec:norm f) (* s attract))) 18 | 19 | (defun reject (rad reject d &aux (l (vec:len d))) 20 | (vec:smult d (* reject (- (/ rad l) 1d0)))) 21 | 22 | (defun jitter (wer r) 23 | (weir:itr-verts (wer i) 24 | (weir:move-vert! wer i (rnd:in-circ r)))) 25 | 26 | 27 | (defun do-step (wer &key attract reject near-limit split-limit rad) 28 | (weir:with (wer %) 29 | ; attract 30 | (weir:itr-edge-verts* (wer e v) 31 | (let ((f (apply #'vec:isub v))) 32 | (loop for i in e and s in signs 33 | if (> (vec:len f) near-limit) 34 | do (% (weir:move-vert? i (attract f s attract)))))) 35 | ; reject 36 | (weir:itr-verts (wer v) 37 | (loop with near = (weir:verts-in-rad wer (weir:get-vert wer v) rad) 38 | for w across near 39 | if (not (= w v)) 40 | do (% (weir:move-vert? v 41 | (reject rad reject 42 | (apply #'vec:sub (weir:get-verts wer (list v w)))))))) 43 | ; split 44 | (weir:itr-edge-verts* (wer e v) 45 | (when (> (apply #'vec:dst v) split-limit) 46 | (% (weir:lsplit-edge? e :xy (vec:lmid v))))))) 47 | 48 | 49 | (defun draw (wer fn &optional i) 50 | (let ((psvg (draw-svg:make*)) 51 | (sw 1d0) 52 | (fill (pigment:to-hex (pigment:gray 0.13d0)))) 53 | (weir:itr-edges (wer e) 54 | (draw-svg:wpath psvg (weir:get-verts wer e) :stroke "black" 55 | :so 0.95d0 :width 2 :rs 0.8 :sw sw)) 56 | (draw-svg:save psvg (if i (weir-utils:append-number fn i) fn)))) 57 | 58 | 59 | (defun main (size fn) 60 | (let* ((xy (vec:rep 500d0)) 61 | (wer (weir:make :max-verts 100000 :adj-size 100000 :set-size 2)) 62 | (attract 0.0002d0) 63 | (reject 0.007d0) 64 | (near-limit 3d0) 65 | (split-limit 8d0) 66 | (rad 20d0)) 67 | 68 | (init wer xy) 69 | (jitter wer 3d0) 70 | 71 | (loop repeat 1000 72 | for i from 0 73 | do (weir-utils:print-every i 100) 74 | (weir:build-zonemap wer rad) 75 | (do-step wer :attract attract :near-limit near-limit 76 | :reject reject :split-limit split-limit :rad rad) 77 | (jitter wer 0.01d0)) 78 | 79 | (draw wer fn))) 80 | 81 | (time (main 1000 (second (weir-utils:cmd-args)))) 82 | 83 | -------------------------------------------------------------------------------- /examples/lines.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/sbcl --script 2 | 3 | ; set your path to sbcl above. i would use env, but it does not appear to work 4 | ; with the --script argument. alternately, delete the shebang and the load 5 | ; below. and run from repl. let me know if you have a better suggestion for 6 | ; making this easily runnable from terminal 7 | 8 | (load "load") 9 | 10 | 11 | (defun main (size fn) 12 | (let ((mid (* 0.5d0 size)) 13 | (repeat 15) 14 | (grains 3) 15 | (itt 1000) 16 | (sand (sandpaint:make :size size 17 | :fg (pigment:black 0.01d0) 18 | :bg (pigment:white)))) 19 | 20 | (loop for i in (math:linspace repeat 100d0 900d0) 21 | for j from 0 to repeat do 22 | (weir-utils:print-every j 4) 23 | (let ((wer (weir:make)) 24 | (va (vec:vec 0d0 0d0)) 25 | (vb (vec:vec 0d0 0d0)) 26 | (p1 (vec:vec 100d0 i)) 27 | (p2 (vec:vec 900d0 i))) 28 | 29 | (loop for s in (math:linspace itt 0d0 1d0) do 30 | (let ((v1 (weir:add-vert! wer (vec:on-line s p1 p2))) 31 | (v2 (weir:add-vert! wer (vec:add va (vec:on-line s p1 p2))))) 32 | 33 | (setf va (vec:add va (rnd:in-circ (* 0.7d0 j)))) 34 | (setf vb (vec:add vb (rnd:in-circ (* 0.001d0 j)))) 35 | 36 | (weir:with (wer %) 37 | (weir:itr-grp-verts (wer v :collect nil) 38 | (% (weir:move-vert? v (vec:add (rnd:in-circ 0.1d0) vb)))) 39 | (% (weir:add-edge? v1 v2))) 40 | 41 | (weir:itr-edges (wer e) 42 | (sandpaint:stroke sand (weir:get-verts wer e) grains)) 43 | (sandpaint:pix sand (weir:get-all-verts wer)))))) 44 | 45 | (sandpaint:save sand fn))) 46 | 47 | (time (main 1000 (second (weir-utils:cmd-args)))) 48 | 49 | -------------------------------------------------------------------------------- /examples/load.lisp: -------------------------------------------------------------------------------- 1 | (load "~/quicklisp/setup.lisp") 2 | 3 | ; set the path to the folder containing weir.asd: 4 | #+quicklisp (push "~/x/weir" ql:*local-project-directories*) 5 | 6 | (ql:quickload :weir) 7 | 8 | -------------------------------------------------------------------------------- /examples/rel-neigh.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/sbcl --script 2 | 3 | ; set your path to sbcl above. i would use env, but it does not appear to work 4 | ; with the --script argument. alternately, delete the shebang and the load 5 | ; below. and run from repl. let me know if you have a better suggestion for 6 | ; making this easily runnable from terminal 7 | 8 | (load "load") 9 | 10 | (defun -dot-split (wer e xp plane-point plane-vec g) 11 | (weir:ldel-edge! wer e :g g) 12 | (destructuring-bind (a b) e 13 | (if (> (vec:3dot plane-vec (vec:3sub (weir:3get-vert wer a) plane-point)) 0d0) 14 | (progn (weir:add-edge! wer (weir:3add-vert! wer xp) b :g g) 15 | (weir:add-edge! wer (weir:3add-vert! wer xp) a :g g)) 16 | (progn (weir:add-edge! wer (weir:3add-vert! wer xp) a :g g) 17 | (weir:add-edge! wer (weir:3add-vert! wer xp) b :g g))))) 18 | 19 | 20 | (defun plane-intersect (wer &key plane-point plane-vec (a 0d0) (dst 0d0) dot-split g) 21 | (let* ((rv (hset:make)) 22 | (do-split (if dot-split 23 | (lambda (e xp) 24 | (-dot-split wer e xp plane-point plane-vec g)) 25 | (lambda (e xp) 26 | (list (weir:3lsplit-edge! wer e :xy xp)))))) 27 | (weir:itr-grp-verts (wer v :g g) 28 | (when (> (vec:3dot plane-vec (vec:3sub (weir:3get-vert wer v) 29 | plane-point)) 30 | 0d0) 31 | (hset:add rv v))) 32 | 33 | (weir:itr-edges (wer e :g g) 34 | (multiple-value-bind (x d xp) (vec:3planex plane-vec plane-point 35 | (weir:3get-verts wer e)) 36 | (when (and x (< 0d0 d 1d0)) 37 | (hset:add* rv (funcall do-split e xp))))) 38 | 39 | (weir:3transform! wer (hset:to-list rv) 40 | (lambda (vv) (vec:3ladd* (vec:3lrot* vv plane-vec a :xy plane-point) 41 | (vec:3smult plane-vec dst)))))) 42 | 43 | 44 | 45 | (defun get-width (d) 46 | (* 4d0 (expt (- 1d0 (max 0d0 (min (/ d 1500d0) 1d0))) 2d0))) 47 | 48 | 49 | (defun dst-draw (wer proj psvg) 50 | (loop with lr = (line-remove:make :cnt 8 :rs 2d0 :is 1.5d0) 51 | for e in (weir:get-edges wer) 52 | do (let* ((point-dst (ortho:project* proj (weir:3get-verts wer e))) 53 | (dsts (math:lpos point-dst :fx #'second))) 54 | (loop for path across 55 | (line-remove:path-split lr 56 | (list (cpath:cpath (weir-utils:to-vector (math:lpos point-dst)) 57 | (loop for d in dsts collect (get-width d)) 58 | (ceiling (* 2.2d0 (get-width (apply #'max dsts))))))) 59 | do (draw-svg:path psvg path :sw 0.8d0 :so 0.9d0 :stroke "black"))) 60 | finally (print (line-remove:stats lr)))) 61 | 62 | 63 | (defun init-cube (n m s) 64 | (let* ((dots (weir-utils:to-vector (rnd:3nin-cube m s))) 65 | (dt (kdtree:make (weir-utils:to-list dots))) 66 | (res (weir-utils:make-adjustable-vector))) 67 | 68 | (loop for rad in (rnd:nrnd 3 500d0) 69 | for mid in (math:nrep 3 (rnd:3on-sphere :rad 300d0)) 70 | do (loop for p in (math:nrep n (rnd:3on-sphere :rad rad :xy mid)) 71 | if (> (vec:3dst p (aref dots (kdtree:nn dt p ))) 72 | 90d0) 73 | do (weir-utils:vextend p res))) 74 | (weir-utils:to-list res))) 75 | 76 | 77 | (defun main (size fn) 78 | (let* ((psvg (draw-svg:make*)) 79 | (wer (weir:make :dim 3 :max-verts 200000)) 80 | (mid (vec:rep 500d0)) 81 | (st (state:make)) 82 | (proj (ortho:make :s 0.5d0 83 | :xy mid 84 | :cam (rnd:3on-sphere :rad 1000d0) 85 | :look vec:*3zero*))) 86 | 87 | (loop repeat 2 do (plane-intersect wer 88 | :plane-point (rnd:3in-cube 500d0) 89 | :plane-vec (rnd:3on-sphere) 90 | :a (rnd:rnd 0.5d0) :dst 100d0 91 | :dot-split t)) 92 | 93 | (weir:3add-verts! wer (init-cube 7000 800 500d0)) 94 | 95 | (weir:3relative-neighborhood! wer 500d0) 96 | 97 | (loop repeat 2 do (plane-intersect wer :plane-point (rnd:3in-cube 300d0) 98 | :plane-vec (rnd:3on-sphere) 99 | :a (rnd:rnd 0.3d0) 100 | :dst 250d0 101 | :dot-split t)) 102 | 103 | (dst-draw wer proj psvg) 104 | (draw-svg:save psvg fn))) 105 | 106 | (time (main 1000 (second (weir-utils:cmd-args)))) 107 | 108 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | sbcl --quit \ 5 | --eval '(load "~/quicklisp/setup.lisp")'\ 6 | --eval '(load "weir.asd")'\ 7 | --eval '(handler-case (ql:quickload :weir :verbose nil) 8 | (error (c) (print c) (sb-ext:quit :unix-status 2)))'\ 9 | --eval '(asdf:test-system :weir)' | tee run-tests.sh.tmp 10 | 11 | -------------------------------------------------------------------------------- /src/auxiliary/convex.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :convex 3 | (:use :common-lisp) 4 | (:export split) 5 | (:import-from :common-lisp-user 6 | :make-adjustable-vector 7 | :to-vector 8 | :vextend)) 9 | 10 | 11 | (in-package :convex) 12 | 13 | 14 | (defun -get-splits (n pts &aux (n- (1- n))) 15 | (let ((len (loop for i from 0 below (1- n) and ii from 1 16 | summing (vec:dst (aref pts i) (aref pts ii))))) 17 | (flet ((lenok (i) (< (rnd:rnd) 18 | (/ (vec:dst (aref pts i) (aref pts (1+ i))) len)))) 19 | (loop with a with b 20 | do (setf a (rnd:rndi n-) 21 | b (rnd:rndi n-)) 22 | until (and (not (= a b)) 23 | (funcall #'lenok a) 24 | (funcall #'lenok b)) 25 | finally (return (sort (list a b) #'<)))))) 26 | 27 | 28 | (defun -split-get-left (n a b) 29 | (let ((res (make-adjustable-vector))) 30 | (loop for i from 0 31 | while (<= i a) 32 | do (vextend i res)) 33 | (vextend (list a (1+ a)) res) 34 | (vextend (list b (1+ b)) res) 35 | (loop for i from (1+ b) 36 | while (< i n) 37 | do (vextend (mod i (1- n)) res)) 38 | res)) 39 | 40 | 41 | (defun -split-get-right (n a b) 42 | (let ((res (make-adjustable-vector))) 43 | (loop for i from (1+ a) 44 | while (<= i b) 45 | do (vextend i res)) 46 | (vextend (list b (1+ b)) res) 47 | (vextend (list a (1+ a)) res) 48 | (loop for i from (1+ a) 49 | while (<= (mod i n) (1+ a)) 50 | do (vextend i res)) 51 | res)) 52 | 53 | 54 | (defun -split-ind-to-pts (pts inds s) 55 | (to-vector (loop for i across inds 56 | collect (if (eql (type-of i) 'cons) 57 | (destructuring-bind (a b) 58 | (mapcar (lambda (i*) (aref pts i*)) i) 59 | (vec:from a (vec:sub b a) s)) 60 | (aref pts i))))) 61 | 62 | 63 | (defun split (pts &key (s 0.5d0) (lim 0d0) &aux (n (length pts))) 64 | (if (< (loop for i from 0 below (1- n) 65 | minimizing (vec:dst (aref pts i) (aref pts (1+ i)))) lim) 66 | (return-from split (list pts nil))) 67 | 68 | (destructuring-bind (a b) (-get-splits n pts) 69 | (list (-split-ind-to-pts pts (-split-get-left n a b) s) 70 | (-split-ind-to-pts pts (-split-get-right n a b) s)))) 71 | 72 | -------------------------------------------------------------------------------- /src/auxiliary/obj.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :obj) 3 | 4 | 5 | (defstruct obj 6 | (verts nil :type vector :read-only t) 7 | (faces nil :type vector :read-only t) 8 | (lines nil :type vector :read-only t) 9 | (num-verts 0 :type fixnum :read-only nil) 10 | (num-lines 0 :type fixnum :read-only nil) 11 | (num-faces 0 :type fixnum :read-only nil)) 12 | 13 | 14 | (defun make () 15 | (make-obj :verts (make-adjustable-vector) 16 | :lines (make-adjustable-vector) 17 | :faces (make-adjustable-vector))) 18 | 19 | 20 | (defun add-verts (o new) 21 | (declare (obj o) (list new)) 22 | (with-struct (obj- verts) o 23 | (setf (obj-num-verts o) (incf (obj-num-verts o) (length new))) 24 | (loop with n = (length verts) 25 | for v of-type vec:3vec in new and i from n 26 | do (vextend v verts) 27 | collect i))) 28 | 29 | 30 | (defun add-face (o new) 31 | (declare (obj o) (list new)) 32 | (with-struct (obj- faces) o 33 | (setf (obj-num-faces o) (incf (obj-num-faces o))) 34 | (vextend new faces))) 35 | 36 | 37 | (defun add-line (o new) 38 | (declare (obj o) (list new)) 39 | (with-struct (obj- lines) o 40 | (setf (obj-num-lines o) (incf (obj-num-lines o))) 41 | (vextend new lines))) 42 | 43 | 44 | (defun save (o fn &key (mesh-name "mesh")) 45 | (declare (obj o)) 46 | (with-struct (obj- verts faces lines) o 47 | (with-open-file (fstream (ensure-filename fn ".obj") 48 | :direction :output :if-exists :supersede) 49 | (declare (stream fstream)) 50 | (format fstream "o ~a~%" mesh-name) 51 | (loop for v of-type vec:3vec across verts 52 | do (vec:3with-xy (v x y z) 53 | (format fstream "v ~f ~f ~f~%" x y z))) 54 | (loop for ee of-type list across faces 55 | do (destructuring-bind (a b c) (math:add ee '(1 1 1)) 56 | (declare (fixnum a b c)) 57 | (format fstream "f ~d ~d ~d~%" a b c))) 58 | (loop for ll of-type list across lines 59 | do (format fstream "l") 60 | (loop for l of-type fixnum in ll 61 | do (format fstream " ~d" (1+ l))) 62 | (format fstream "~%"))))) 63 | 64 | -------------------------------------------------------------------------------- /src/config.lisp: -------------------------------------------------------------------------------- 1 | ;;; These are configuration settings for the project. 2 | ;;; 3 | ;;; These settings aren't particularly friendly to projects more 4 | ;;; broadly as they're not "self contained." 5 | 6 | (in-package #:weir) 7 | 8 | (setf *random-state* (make-random-state t)) 9 | (setf *print-pretty* t) 10 | 11 | -------------------------------------------------------------------------------- /src/distance/zonemap.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :zonemap) 3 | 4 | 5 | (deftype int (&optional (bits 31)) 6 | `(signed-byte ,bits)) 7 | 8 | 9 | (declaim (inline -xy-to-zone)) 10 | (defun -xy-to-zone (zwidth x y) 11 | (declare #.*opt-settings* 12 | (double-float zwidth x y)) 13 | (values (the int (floor x zwidth)) 14 | (the int (floor y zwidth)))) 15 | 16 | 17 | (defstruct (zonemap (:constructor -make-zonemap)) 18 | (zwidth nil :type double-float :read-only t) 19 | (num-verts nil :type int :read-only t) 20 | (zone-to-verts nil :type hash-table :read-only t)) 21 | 22 | 23 | (defun make (verts num-verts zwidth) 24 | (declare #.*opt-settings* 25 | (double-float zwidth) (type int num-verts) 26 | (type (simple-array double-float) verts)) 27 | (let ((zone-to-verts (make-hash-table :size 40 :rehash-size 2f0 :test #'equal))) 28 | (loop for v of-type int from 0 below num-verts do 29 | (let ((z (list (floor (aref verts #1=(* 2 v)) zwidth) 30 | (floor (aref verts (1+ #1#)) zwidth)))) 31 | (declare (list z)) 32 | (multiple-value-bind (vals exists) (gethash z zone-to-verts) 33 | (when (not exists) 34 | (setf vals (make-adjustable-vector :type 'int) 35 | (gethash z zone-to-verts) vals)) 36 | (vextend v vals)))) 37 | 38 | (-make-zonemap :zwidth zwidth :num-verts num-verts 39 | :zone-to-verts zone-to-verts))) 40 | 41 | 42 | (defmacro with-verts-in-rad ((zm verts xy rad v) &body body) 43 | (alexandria:with-gensyms (rad2 zm* zwidth zone-to-verts xy* za zai zb 44 | vals verts* exists i j xx yy) 45 | `(let* ((,rad2 (expt ,rad 2d0)) 46 | (,verts* ,verts) 47 | (,xy* ,xy) 48 | (,xx (vec:vec-x ,xy*)) 49 | (,yy (vec:vec-y ,xy*)) 50 | (,zm* ,zm) 51 | (,zwidth (zonemap-zwidth ,zm*)) 52 | (,zone-to-verts (zonemap-zone-to-verts ,zm*))) 53 | (declare (double-float ,rad2 ,zwidth ,xx ,yy) 54 | (type (simple-array double-float) ,verts*) 55 | (hash-table ,zone-to-verts) (vec:vec ,xy*)) 56 | (multiple-value-bind (,za ,zb) (-xy-to-zone ,zwidth ,xx ,yy) 57 | (declare (type int ,za ,zb)) 58 | (loop for ,i of-type int from -1 below 2 do 59 | (loop with ,zai of-type int = (+ ,za ,i) 60 | for ,j of-type int from -1 below 2 do 61 | (multiple-value-bind (,vals ,exists) 62 | (gethash (list ,zai (+ ,j ,zb)) ,zone-to-verts) 63 | (when ,exists 64 | (loop for ,v of-type int across ,vals 65 | if (< (+ (expt (- ,xx (aref ,verts* 66 | (the int (* 2 ,v)))) 2d0) 67 | (expt (- ,yy (aref ,verts* 68 | (the int (1+ (* 2 ,v))))) 2d0)) 69 | ,rad2) 70 | do (progn ,@body)))))))))) 71 | 72 | (declaim (inline verts-in-rad)) 73 | (defun verts-in-rad (zm verts xy rad) 74 | (declare #.*opt-settings* 75 | (type (simple-array double-float) verts) (zonemap zm) 76 | (vec:vec xy) (double-float rad)) 77 | (let ((inds (make-adjustable-vector :type 'int))) 78 | (declare (vector inds)) 79 | (with-verts-in-rad (zm verts xy rad v) (vextend (the int v) inds)) 80 | inds)) 81 | 82 | -------------------------------------------------------------------------------- /src/draw/cpath.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cpath) 3 | 4 | 5 | (defparameter *clim* -0.5d0) 6 | (defparameter *slim* -0.95d0) 7 | 8 | 9 | (defun -scale-offset (w a b &key (fxn #'sin)) 10 | (declare #.*opt-settings* 11 | (double-float w) (vec:vec a b) (function fxn)) 12 | (let ((s (abs (funcall fxn (abs (- (vec:angle a) (vec:angle b))))))) 13 | (declare (double-float s)) 14 | (if (< s 0.05d0) w (/ w s)))) 15 | 16 | 17 | (defun -offset (v o) 18 | (list (vec:add v o) (vec:sub v o))) 19 | 20 | 21 | (defun -chamfer (w diag pa na aa aa-) 22 | (let* ((x (< (vec:cross aa aa-) 0d0)) 23 | (corner (if x (second diag) (first diag))) 24 | (s (-scale-offset w aa- na :fxn #'cos))) 25 | (loop for v in (-offset pa (vec:smult (vec:perp na) s)) 26 | collect (if x (list v corner) (list corner v))))) 27 | 28 | (defun -regular-perp (a b) 29 | (declare #.*opt-settings* (vec:vec a b)) 30 | (vec:perp (vec:norm (vec:add a b)))) 31 | 32 | 33 | (defun -make-test-fxn-closed (angles clim slim) 34 | (declare #.*opt-settings* 35 | (type (simple-array vec:vec) angles) (double-float clim slim)) 36 | (let ((n- (1- (length angles)))) 37 | (lambda (i) (declare (fixnum i)) 38 | (let ((a (aref angles i)) 39 | (a- (aref angles (if (< i 1) n- (1- i))))) 40 | (let ((dt (vec:dot a- a))) 41 | (cond ((<= dt slim) (values :sharp (vec:perp a-))) 42 | ((< dt clim) (values :chamfer (-regular-perp a- a))) 43 | (t (values :regular (-regular-perp a- a))))))))) 44 | 45 | 46 | (defun -make-test-fxn-open (angles clim slim) 47 | (declare #.*opt-settings* 48 | (type (simple-array vec:vec) angles) (double-float clim slim)) 49 | (let ((n- (1- (length angles)))) 50 | (lambda (i) (declare (fixnum i)) 51 | (let ((a (aref angles i))) 52 | (if (> n- i 0) 53 | (let ((dt (vec:dot (aref angles (1- i)) a))) 54 | (cond ((<= dt slim) (values :sharp (vec:perp (aref angles (1- i))))) 55 | ((< dt clim) (values :chamfer (-regular-perp 56 | (aref angles (1- i)) a))) 57 | (t (values :regular (-regular-perp (aref angles (1- i)) a))))) 58 | (values :regular (vec:perp a))))))) 59 | 60 | 61 | (defun -width-fx (widths) 62 | (if (equal (type-of widths) 'double-float) 63 | (lambda (i) (declare (ignore i)) widths) 64 | (let ((w (ensure-vector widths))) 65 | (lambda (i) (aref w i))))) 66 | 67 | 68 | (defun get-diagonals (pts widths clim slim closed) 69 | (let* ((res (make-adjustable-vector)) 70 | (n (length pts)) 71 | (angles (math:path-angles pts)) 72 | (get-width (-width-fx widths)) 73 | (corner-test (if closed (-make-test-fxn-closed angles clim slim) 74 | (-make-test-fxn-open angles clim slim)))) 75 | 76 | (loop for i from 0 below (if closed (1- n) n) do 77 | (multiple-value-bind (corner na) (funcall (the function corner-test) i) 78 | (let* ((p (aref pts i)) 79 | (a (aref angles i)) 80 | (w (funcall get-width i)) 81 | (diag (-offset p (vec:smult na (-scale-offset w a na))))) 82 | (mapcar (lambda (d) (vextend d res)) 83 | (case corner 84 | (:chamfer (-chamfer w diag p na a 85 | (aref angles (math:imod i -1 n)))) 86 | (:regular (list diag)) 87 | (:sharp (list (progn diag) (reverse diag)))))))) 88 | 89 | ;handle last closed path diagonal 90 | (when closed (vextend (aref res 0) res)) 91 | res)) 92 | 93 | 94 | (defun -get-ind (i k i- closed) 95 | (if closed i (if (= (math:mod2 k) 0) i i-))) 96 | 97 | 98 | (defun cpath (pts widths rep &key (slim *slim*) (clim *clim*) closed) 99 | (loop with diagonals = (get-diagonals pts widths clim slim closed) 100 | with n = (length diagonals) 101 | with res of-type vector = (make-adjustable-vector) 102 | for s of-type double-float in (math:linspace rep 0d0 1d0) 103 | and k of-type fixnum from 0 104 | do (loop for i of-type fixnum from 0 below n 105 | and i- of-type fixnum downfrom (1- n) 106 | do (vextend (vec:lon-line s (aref diagonals (-get-ind i k i- closed))) 107 | res)) 108 | finally (return (to-list res)))) 109 | 110 | 111 | (defun outline (pts widths &key closed (clim *clim*) (slim *slim*)) 112 | (declare (list pts)) 113 | (let* ((pts* (to-vector (if closed (math:close-path pts) pts)))) 114 | (math:close-path (cpath pts* widths 2 :closed closed 115 | :clim clim :slim slim)))) 116 | 117 | 118 | (defun path-offset (pts widths &key (s 1d0) closed (clim *clim*) (slim *slim*)) 119 | (let ((diag (get-diagonals (to-vector pts) widths clim slim closed))) 120 | (loop for d across diag collect (vec:lon-line s d)))) 121 | 122 | -------------------------------------------------------------------------------- /src/draw/hatch.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :hatch) 3 | 4 | ; any fixed point will work. this magic number seemed to work well for some 5 | ; cases i tested ... TODO: make magic number configurable? 6 | (defvar *magic* (vec:vec -997799.33333d0 -775577.747362d0)) 7 | 8 | 9 | (defun stitch (lines) 10 | " 11 | randomly mix the hatches in lines according to where the lines intersect. 12 | this is somewhat inefficient 13 | " 14 | (loop with res = (make-adjustable-vector) 15 | for i from 0 below (length lines) 16 | do (let ((ss (make-adjustable-vector)) 17 | (curr (aref lines i))) 18 | 19 | (vextend 0d0 ss) 20 | (vextend 1d0 ss) 21 | 22 | (loop for j from 0 below (length lines) 23 | do (multiple-value-bind (x s) 24 | (vec:segx curr (aref lines j)) 25 | (if x (vextend s ss)))) 26 | 27 | (setf ss (sort ss (rnd:either #'< #'>))) 28 | 29 | (loop for k from (rnd:rndi 2) below (1- (length ss)) by 2 30 | do (vextend (list (vec:lon-line (aref ss k) curr) 31 | (vec:lon-line (aref ss (1+ k)) curr)) 32 | res))) 33 | finally (return res))) 34 | 35 | 36 | (defun -hatch-mid (pts) 37 | (loop with n = (length pts) 38 | with mid = (vec:zero) 39 | repeat (1- n) for p across pts 40 | do (vec:add! mid p) 41 | finally (return (vec:sdiv mid (coerce (1- n) 'double-float))))) 42 | 43 | (defun segdst (mid a esize) 44 | " 45 | find the point along the line with angle a through mid that is closest to an 46 | arbitrary fixed point. this way all hatches with same angle and rs will line 47 | up. 48 | " 49 | (let ((line (vec:rline esize a :xy mid))) 50 | (multiple-value-bind (_ tt) (vec:segdst line *magic*) 51 | (declare (ignore _)) 52 | (vec:dst mid (vec:lon-line tt line))))) 53 | 54 | (defun -get-angle-zero-point-lines (pts a rs esize) 55 | " 56 | get evenly spaced lines along angle line a that always match up for same 57 | (rs angle). 58 | " 59 | (let* ((mid (-hatch-mid pts)) 60 | (va (vec:cos-sin a)) 61 | (rad (+ (* 4 rs) (loop for p across pts maximize (vec:dst mid p)))) 62 | (slide (vec:rline rad (- a (* 0.5 PI)))) 63 | (d (segdst mid a esize)) 64 | (zp- (+ rad (- (mod (- d rad) rs) rs))) 65 | (zp+ (- rad (mod (+ d rad) rs)))) 66 | (loop for mark in 67 | (vec:lon-line* 68 | (math:linspace (1+ (round (+ zp- zp+) rs)) 0d0 1d0 :end t) 69 | (list (vec:sub mid (vec:smult va zp-)) 70 | (vec:add mid (vec:smult va zp+)))) 71 | collect (vec:ladd* slide mark)))) 72 | 73 | 74 | (defun -line-hatch (res line pts) 75 | "make the actual hatches along line" 76 | (let ((ixs (make-adjustable-vector))) 77 | (loop for i from 0 below (1- (length pts)) 78 | do (multiple-value-bind (x s) 79 | (vec:segx line (list (aref pts i) (aref pts (1+ i)))) 80 | (if x (vextend s ixs)))) 81 | (setf ixs (sort ixs #'<)) 82 | (loop for i from 0 below (1- (length ixs)) by 2 83 | do (vextend (list (vec:lon-line (aref ixs i) line) 84 | (vec:lon-line (aref ixs (1+ i)) line)) 85 | res)))) 86 | 87 | 88 | (defun hatch (pts &key (angles 0d0) (rs 3d0) (esize 3000d0) 89 | &aux (pts* (ensure-vector pts))) 90 | "draw hatches at angles inside the area enclosed by the path in pts" 91 | 92 | (when (> (vec:dst (aref pts* 0) (vector-last pts*)) 0.0001d0) 93 | (error "first and last element in pts must be close to each other.")) 94 | (loop with res = (make-adjustable-vector) 95 | for a in (if (equal (type-of angles) 'cons) angles (list angles)) 96 | do (loop for line in (-get-angle-zero-point-lines pts* a rs esize) 97 | do (-line-hatch res line pts*)) 98 | finally (return res))) 99 | 100 | -------------------------------------------------------------------------------- /src/draw/lin-path.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :lin-path) 3 | 4 | 5 | (defstruct path 6 | (n nil :type fixnum :read-only t) 7 | (closed nil :type boolean) 8 | (pts nil :type (simple-array double-float) :read-only t) 9 | (tot nil :type double-float :read-only t) 10 | (lerpfx nil :type function :read-only t) 11 | (weights nil :type (simple-array double-float) :read-only t)) 12 | 13 | 14 | (defun -set-weights (pts weights n &key dstfx) 15 | (declare #.*opt-settings* 16 | (type (simple-array double-float) pts weights) 17 | (fixnum n) 18 | (function dstfx)) 19 | (loop with tot of-type double-float = 20 | (loop for i of-type fixnum from 0 below (1- n) 21 | sum (funcall dstfx pts pts i (1+ i)) into tot of-type double-float 22 | do (setf (aref weights (1+ i)) tot) 23 | finally (return tot)) 24 | for i of-type fixnum from 1 below n 25 | do (setf (aref weights i) (/ (aref weights i) tot)) 26 | finally (return tot))) 27 | 28 | 29 | (defun -find-seg-ind (weights f n) 30 | (declare #.*opt-settings* 31 | (type (simple-array double-float) weights) 32 | (fixnum n) (double-float f)) 33 | (loop with l of-type fixnum = 0 34 | with r of-type fixnum = (- n 1) 35 | with mid of-type fixnum = 0 36 | until (<= (aref weights mid) f (aref weights (1+ mid))) 37 | do (setf mid (floor (+ l r) 2)) 38 | (cond ((> f (aref weights mid)) (setf l mid)) 39 | ((<= f (aref weights mid)) (setf r (1+ mid)))) 40 | finally (return (the fixnum (1+ mid))))) 41 | 42 | 43 | (defun -lerp (pts i s &aux (bi (* 2 i)) (ai (- bi 2))) 44 | (declare #.*opt-settings* 45 | (type (simple-array double-float) pts) 46 | (fixnum i bi ai) (double-float s)) 47 | (vec:vec (+ (aref pts ai) (* (- (aref pts bi) 48 | (aref pts ai)) s)) 49 | (+ (aref pts (1+ ai)) (* (- (aref pts (1+ bi)) 50 | (aref pts (1+ ai))) s)))) 51 | 52 | (defun -lerp3 (pts i s &aux (bi (* 3 i)) (ai (- bi 3))) 53 | (declare #.*opt-settings* 54 | (type (simple-array double-float) pts) 55 | (fixnum i bi ai) (double-float s)) 56 | (vec:3vec (+ (aref pts ai) 57 | (* (- (aref pts bi) 58 | (aref pts ai)) s)) 59 | (+ (aref pts (1+ ai)) 60 | (* (- (aref pts (1+ bi)) 61 | (aref pts (1+ ai))) s)) 62 | (+ (aref pts (+ 2 ai)) 63 | (* (- (aref pts (+ bi 2)) 64 | (aref pts (+ ai 2))) s)))) 65 | 66 | 67 | (defun -scale-weight (a b s) 68 | (declare #.*opt-settings* (double-float a b s)) 69 | (/ (- b a) s)) 70 | 71 | (declaim (inline -mod)) 72 | (defun -dmod (x) 73 | (declare (double-float x)) 74 | (when (<= 0d0 x 1d0) (return-from -dmod x)) 75 | (multiple-value-bind (_ res) (floor x) 76 | (declare (ignore _) (double-float res)) 77 | res)) 78 | 79 | (defun -pos (pts weights n f &key (modf (-dmod f)) lerpfx) 80 | (declare #.*opt-settings* 81 | (type (simple-array double-float) pts weights) 82 | (fixnum n) (double-float f modf) (function lerpfx)) 83 | (let ((i (-find-seg-ind weights modf n))) 84 | (declare (fixnum i)) 85 | (funcall lerpfx pts i 86 | (-scale-weight (aref weights (1- i)) 87 | modf 88 | (- (aref weights i) (aref weights (1- i))))))) 89 | 90 | 91 | (defun pos (pth f) 92 | (declare (path pth) (double-float f)) 93 | (with-struct (path- weights pts lerpfx n) pth 94 | (-pos pts weights n f :lerpfx lerpfx))) 95 | 96 | 97 | (defun pos* (pth ff) 98 | (declare (path pth) (list ff)) 99 | (with-struct (path- weights pts lerpfx n) pth 100 | (mapcar (lambda (f) (declare (double-float f)) 101 | (-pos pts weights n f :lerpfx lerpfx)) 102 | ff))) 103 | 104 | 105 | (defun rndpos (pth n) 106 | (rnd:with-rndspace (n 0d0 1d0 p :collect t) 107 | (pos pth p))) 108 | 109 | 110 | (defun make (pts &key (dim 2) closed) 111 | (declare (list pts) (fixnum dim) (boolean closed)) 112 | (when (not (< 1 dim 4)) (error "dim must be 2 or 3")) 113 | (let* ((n (if closed (+ (length pts) 1) (length pts))) 114 | (p (avec:avec n :dim dim)) 115 | (l (avec:avec n :dim 1)) 116 | (setfx (if (= dim 2) #'avec:setv #'avec:3setv))) 117 | (declare (fixnum n) (type (simple-array double-float) p l) 118 | (function setfx)) 119 | (loop for pt in pts and i of-type fixnum from 0 120 | do (funcall setfx p i pt)) 121 | (when closed (funcall setfx p (1- n) (first pts))) 122 | (make-path :n n :pts p 123 | :weights l 124 | :closed closed 125 | :lerpfx (if (= dim 2) #'-lerp #'-lerp3) 126 | :tot (-set-weights p l n 127 | :dstfx (if (= dim 2) #'avec:dst #'avec:3dst))))) 128 | 129 | -------------------------------------------------------------------------------- /src/draw/line-remove.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :line-remove) 3 | 4 | (deftype pos-int (&optional (bits 31)) 5 | `(unsigned-byte ,bits)) 6 | 7 | 8 | (defstruct line-remove 9 | (counts nil :type hash-table :read-only t) 10 | (cnt 0 :type pos-int :read-only t) 11 | (rs 0d0 :type double-float :read-only t) 12 | (is 0d0 :type double-float :read-only t) 13 | (min-length 0d0 :type double-float :read-only t) 14 | (total-length 0d0 :type double-float :read-only nil) 15 | (saved-length 0d0 :type double-float :read-only nil)) 16 | 17 | 18 | (defun make (&key (cnt 4) (is 1d0) (rs 1.5d0) (min-length 1d0)) 19 | (declare (pos-int cnt) (double-float is rs min-length)) 20 | (when (> is rs) (print "WARN: is should be smaller than rs")) 21 | (make-line-remove :counts (make-hash-table :test #'equal) 22 | :rs rs :cnt cnt :is is :min-length min-length)) 23 | 24 | 25 | (defun stats (lr) 26 | (let ((sl (line-remove-saved-length lr)) 27 | (tl (line-remove-total-length lr))) 28 | (declare (double-float sl tl)) 29 | (list :saved-length sl :total-length tl 30 | :ratio (if (> tl 0d0) (/ sl tl) 0d0)))) 31 | 32 | 33 | (declaim (inline -linearize-line)) 34 | (defun -linearize-line (n is a b) 35 | (declare #.*opt-settings* (pos-int n) (double-float is) (vec:vec a b)) 36 | (math:with-linspace (n 0d0 1d0 s :collect t) 37 | (list s (vec:smult (vec:on-line s a b) is)))) 38 | 39 | 40 | (declaim (inline -distinct-inds)) 41 | (defun -distinct-inds (xy) 42 | (declare #.*opt-settings* (vec:vec xy)) 43 | (vec:with-xy (xy x y) 44 | (list (list #1=(floor x) #2=(floor y)) 45 | (list (1+ #1#) #2#) 46 | (list #1# (1+ #2#)) 47 | (list (1+ #1#) (1+ #2#))))) 48 | 49 | 50 | (declaim (inline -do-inc)) 51 | (defun -do-inc (hits counts xy) 52 | (declare #.*opt-settings* (hash-table hits counts) (vec:vec xy)) 53 | (loop for ind of-type list in (-distinct-inds xy) 54 | do (unless (gethash ind hits) (setf (gethash ind hits) t) 55 | (incf (gethash ind counts 0))))) 56 | 57 | 58 | (declaim (inline -get-count)) 59 | (defun -get-count (counts xy) 60 | (declare #.*opt-settings* (hash-table counts) (vec:vec xy)) 61 | (loop for ind of-type list in (-distinct-inds xy) 62 | maximize (gethash ind counts 0) of-type fixnum)) 63 | 64 | 65 | (defun -do-count (counts is rs a b) 66 | (declare #.*opt-settings* (hash-table counts) (double-float is rs) (vec:vec a b)) 67 | (let* ((d (vec:dst a b)) 68 | (lin (-linearize-line (max 2 (ceiling (* rs d))) is a b)) 69 | (hits (make-hash-table :test #'equal)) 70 | (res (loop for (s xy) in lin collect (list s (-get-count counts xy))))) 71 | (loop for (s xy) of-type (double-float vec:vec) in lin 72 | do (-do-inc hits counts xy)) 73 | res)) 74 | 75 | 76 | (declaim (inline -find-nils)) 77 | (defun -find-nils (pts cnt) 78 | (declare #.*opt-settings* (list pts) (pos-int cnt)) 79 | (loop with res of-type vector = (make-adjustable-vector) 80 | for (_ c) in pts 81 | and i of-type fixnum from 0 82 | do (when (> c cnt) (vextend i res)) 83 | finally (return res))) 84 | 85 | 86 | (declaim (inline -proc)) 87 | (defun -proc (pts cnt min-length len) 88 | (declare #.*opt-settings* (pos-int cnt) (double-float min-length len)) 89 | (let ((pts* (to-vector pts)) 90 | (nils (-find-nils pts cnt))) 91 | (declare (vector pts*) (sequence nils)) 92 | (when (< (length nils) 1) (return-from -proc '((0d0 1d0)))) 93 | (setf nils (concatenate 'list (list -1) nils (list (length pts*)))) 94 | (remove-if (lambda (ss) (declare (list ss)) 95 | (< (* len (abs (apply #'- ss))) min-length)) 96 | (loop for a of-type fixnum in nils 97 | and b of-type fixnum in (cdr nils) 98 | if (> (- b a) 2) 99 | collect (list (first (aref pts* (1+ a))) 100 | (first (aref pts* (1- b)))))))) 101 | 102 | 103 | (defun path-split (lr pts) 104 | " 105 | remove sections of lines that cover too crowded places. 106 | " 107 | (declare #.*opt-settings* (line-remove lr) (sequence pts)) 108 | (with-struct (line-remove- counts cnt is rs min-length) lr 109 | (loop with res of-type vector = (make-adjustable-vector) 110 | for path of-type list across (ensure-vector pts) 111 | do (loop with drawn-length of-type double-float = 0d0 112 | with total-length of-type double-float = 0d0 113 | for a in path and b in (cdr path) 114 | do (let* ((len (vec:dst a b)) 115 | (segments (-proc (-do-count counts is rs a b) 116 | cnt min-length len))) 117 | (incf total-length len) 118 | (when segments 119 | (loop for (si sj) in segments 120 | do (let ((p (vec:on-line si a b)) 121 | (q (vec:on-line sj a b))) 122 | (incf drawn-length (vec:dst p q)) 123 | (vextend (list p q) res))))) 124 | finally (incf (line-remove-total-length lr) total-length) 125 | (incf (line-remove-saved-length lr) 126 | (- total-length drawn-length))) 127 | finally (return res)))) 128 | 129 | -------------------------------------------------------------------------------- /src/draw/sandpaint-extra.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sandpaint) 2 | 3 | 4 | (declaim (inline -clamp)) 5 | (defun -clamp (v) 6 | (declare #.*opt-settings* (double-float v)) 7 | (min 1d0 (the double-float (max 0d0 v)))) 8 | 9 | 10 | (declaim (inline sample)) 11 | (defun sample (sand xy &key (alpha 1d0)) 12 | (-do-op (sand size vals indfx) 13 | (-inside-floor (size xy x y) 14 | (let* ((ind (funcall indfx x y)) 15 | (a (aref vals (+ ind 3)))) 16 | (declare (pos-int ind) (double-float a)) 17 | (pigment:rgb (/ (aref vals ind) a) 18 | (/ (aref vals (1+ ind)) a) 19 | (/ (aref vals (+ ind 2)) a) 20 | alpha))))) 21 | 22 | 23 | (declaim (inline sample-bilin)) 24 | (defun sample-bilin (sand xy) 25 | (declare #.*opt-settings* (sandpaint sand) (vec:vec xy)) 26 | (with-struct (sandpaint- vals size indfx) sand 27 | (multiple-value-bind (ix iy fx fy) (-floor-fract xy) 28 | (declare (fixnum ix iy) (double-float fx fy)) 29 | (multiple-value-bind (s1 s2 s3 s4) (-fract-overlap fx fy) 30 | (declare (double-float s1 s2 s3 s4)) 31 | (let* ((size* (- size 2)) 32 | (ind (funcall indfx (min size* (max ix 0)) 33 | (min size* (max iy 0))))) 34 | (declare (pos-int size* ind)) 35 | (labels ((-sample-channel (i) 36 | (+ (* s1 (aref vals i)) 37 | (* s2 (aref vals (+ i 4))) 38 | (* s3 (aref vals (+ i (* size 4)))) 39 | (* s4 (aref vals (+ i (* size 4) 4)))))) 40 | (pigment::-make-rgba (-sample-channel ind) 41 | (-sample-channel (+ 1 ind)) 42 | (-sample-channel (+ 2 ind)) 43 | (-sample-channel (+ 3 ind))))))))) 44 | 45 | 46 | (defun copy-rgba-array-to-from (target source size) 47 | (declare #.*opt-settings* 48 | (type (simple-array double-float) target source) 49 | (pos-int size)) 50 | (loop for i of-type pos-int from 0 below (* size size 4) 51 | do (setf (aref target i) (the double-float (aref source i))))) 52 | 53 | 54 | (defun copy-scale-rgba-array-to-from (target source scale size) 55 | (declare #.*opt-settings* 56 | (type (simple-array double-float) target source) 57 | (pos-int size)) 58 | (loop for i of-type pos-int from 0 below (* size size 4) 59 | do (if (<= (aref scale i) 0) 60 | (setf (aref target i) (aref source i)) 61 | (setf (aref target i) (/ (aref source i) (aref scale i)))))) 62 | 63 | 64 | (defun cafx-expt (mid s ps) 65 | (lambda (xy) 66 | (let* ((dx (vec:sub xy mid)) 67 | (len (max 1d0 (vec:len dx))) 68 | (ex (/ 1d0 (+ 1 (exp (- (/ len s))))))) 69 | (vec:smult dx (* ps (/ ex s)))))) 70 | 71 | (defun cafx-lin (mid s) 72 | (lambda (xy) (vec:smult (vec:sub xy mid) (/ s)))) 73 | 74 | (defun chromatic-aberration (sand &key (cafx (cafx-expt (vec:rep 1000d0) 1000d0 2d0))) 75 | (declare (sandpaint sand) (function cafx)) 76 | (with-struct (sandpaint- size vals indfx) sand 77 | (declare (pos-int size) (function indfx)) 78 | (let ((new-vals (make-rgba-array size))) 79 | (copy-rgba-array-to-from new-vals vals size) 80 | (labels ((-offset-channel (xi yi channel val) 81 | (setf (aref new-vals (funcall indfx xi yi channel)) val))) 82 | 83 | (-square-loop (x y size) 84 | (let* ((xy (vec:vec (coerce x 'double-float) (coerce y 'double-float))) 85 | (dx (funcall cafx xy))) 86 | (declare (vec:vec xy dx)) 87 | (-offset-channel x y 0 88 | (pigment::rgba-r (sample-bilin sand (vec:sub xy dx)))) 89 | (-offset-channel x y 2 90 | (pigment::rgba-b (sample-bilin sand (vec:add xy dx))))))) 91 | 92 | (copy-rgba-array-to-from vals new-vals size)))) 93 | 94 | (declaim (inline hsv)) 95 | (defun hsv (sand &key (h 0d0) (s 0d0) (v 0d0)) 96 | (declare (sandpaint sand) (double-float h s v)) 97 | (-do-op (sand size vals indfx) 98 | (-square-loop (x y size) 99 | (let ((ind (funcall indfx x y))) 100 | (declare (pos-int ind)) 101 | (destructuring-bind (h* s* v* a) 102 | (pigment:as-hsv (pigment::-make-rgba 103 | (aref vals ind) (aref vals (1+ ind)) 104 | (aref vals (+ ind 2)) (aref vals (+ ind 3)))) 105 | (declare (double-float h* s* v* a)) 106 | (set-pix sand x y (pigment:hsv (mod (+ h h*) 1d0) (-clamp (+ s s*)) 107 | (-clamp (+ v v*)) a))))))) 108 | 109 | 110 | (defun check-integrity (sand) 111 | (declare (sandpaint sand)) 112 | (-do-op (sand size vals indfx) 113 | (-square-loop (x y size) 114 | (let* ((ind (funcall indfx x y)) 115 | (r (aref vals ind)) 116 | (g (aref vals (+ 1 ind))) 117 | (b (aref vals (+ 2 ind))) 118 | (a (aref vals (+ 3 ind)))) 119 | (declare (pos-int ind) (double-float r g b a)) 120 | (when (> a 1d0) (error "invalid alpha value, high")) 121 | (when (< a 0d0) (error "invalid alpha value, low")) 122 | (when (or (< r 0d0) (< g 0d0) (< b 0d0)) 123 | (error "invalid rgb value, negative")) 124 | (when (or (> r a) (> g a) (> b a)) 125 | (error "invalid rgb value, above alpha")))))) 126 | 127 | -------------------------------------------------------------------------------- /src/fn.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :fn) 3 | 4 | " 5 | generate file names using https://github.com/inconvergent/fn 6 | " 7 | 8 | (defun fn () (inferior-shell:run/ss "fn")) 9 | 10 | -------------------------------------------------------------------------------- /src/graph/edge-set.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :graph) 3 | 4 | (defun -sort-edge (e) 5 | (sort e #'<)) 6 | 7 | (defun cycle->edge-set (cycle) 8 | (declare (list cycle)) 9 | (loop for a in cycle and b in (cdr cycle) 10 | collect (-sort-edge (list a b)))) 11 | 12 | 13 | (defun edge-set->graph (es) 14 | (declare (list es)) 15 | (loop with grph = (make) 16 | for (a b) in es do (add grph a b) 17 | finally (return grph))) 18 | 19 | 20 | (defun path->edge-set (path &key closed) 21 | (declare (list path) (boolean closed)) 22 | (loop for a in path 23 | and b in (if closed (cons (first (last path)) path) (cdr path)) 24 | collect (sort (list a b) #'<))) 25 | 26 | 27 | (defun -edge-map (es) 28 | (declare (list es)) 29 | (let ((edge-map (make-hash-table :test #'equal))) 30 | (labels ((-insert (a b) 31 | (multiple-value-bind (_ exists) (gethash a edge-map) 32 | (declare (ignore _)) 33 | (if exists (push b (gethash a edge-map)) 34 | (setf (gethash a edge-map) (list b)))))) 35 | (loop for (a b) in es do (-insert a b) 36 | (-insert b a))) 37 | edge-map)) 38 | 39 | (defun edge-set->path (es) 40 | (declare (list es)) 41 | " 42 | convert edge set: ((3 4) (4 5) (5 6) (1 2) (6 1) (2 3)) 43 | into a path: (4 5 6 1 2 3) 44 | second result is a boolean for whether it is a cycle. 45 | " 46 | 47 | (when (< (length es) 2) 48 | (return-from edge-set->path (values (car es) nil))) 49 | 50 | (let ((edge-map (-edge-map (cdr es)))) 51 | (labels 52 | ((-next-vert-from (a &key but-not) 53 | (car (remove-if (lambda (v) (= v but-not)) 54 | (gethash a edge-map)))) 55 | (-until-dead-end (a but-not) 56 | (loop with prv = a 57 | with res = (list prv) 58 | with nxt = (-next-vert-from a :but-not but-not) 59 | until (equal nxt nil) 60 | do (push nxt res) 61 | (let ((nxt* (-next-vert-from nxt :but-not prv))) 62 | (setf prv nxt nxt nxt*)) 63 | finally (return res)))) 64 | 65 | (destructuring-bind (a b) (car es) 66 | (let ((left (-until-dead-end a b))) 67 | (when (and (= (car left) b) (= (car (last left)) a)) 68 | ; this is a cycle 69 | (return-from edge-set->path (values left t))) 70 | ; not a cycle 71 | (let* ((right (-until-dead-end b a)) 72 | (res (concatenate 'list left (reverse right)))) 73 | ; this isnt an exhaustive manifold test? 74 | ; and it should be configurable whether it fails? 75 | (unless (= (1- (length res)) (length es)) 76 | (error "path is manifold or incomplete. eslen: ~a. pathlen ~a" 77 | (length es) (length res))) 78 | (values res nil))))))) 79 | 80 | 81 | (defun edge-set-symdiff (esa esb) 82 | (declare (list esa esb)) 83 | (remove-if (lambda (e) (and (member e esa :test #'equal) 84 | (member e esb :test #'equal))) 85 | (union esa esb :test #'equal))) 86 | 87 | 88 | (defun cycle-basis->edge-sets (basis) 89 | (declare (list basis)) 90 | (loop for c of-type list in basis collect (cycle->edge-set c))) 91 | 92 | (defun edge-sets->cycle-basis (es) 93 | (declare (list es)) 94 | ; TODO: edge-set->path will only return a cycle 95 | ; if the edge set is a cycle. warn? 96 | (loop for e of-type list in es 97 | collect (math:close-path (edge-set->path e)))) 98 | 99 | (defun -edge-set-weight (es weightfx) 100 | (declare (list es) (function weightfx)) 101 | (loop for e of-type list in es sumMing (apply weightfx e))) 102 | 103 | (defun -sort-edge-sets (edge-sets weightfx) 104 | (declare (list edge-sets) (function weightfx)) 105 | (mapcar #'second 106 | (sort (loop for es of-type list in edge-sets 107 | collect (list (-edge-set-weight es weightfx) es)) 108 | #'> :key #'first))) 109 | 110 | -------------------------------------------------------------------------------- /src/graph/main.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :graph) 3 | 4 | " 5 | a simple (undirected) graph structure based on adjacency lists. 6 | " 7 | 8 | 9 | (deftype pos-int (&optional (bits 31)) 10 | `(unsigned-byte ,bits)) 11 | 12 | 13 | (defvar *inf* 1d8) 14 | 15 | 16 | (defstruct (graph (:constructor -make-graph)) 17 | (size 0 :type pos-int :read-only t) 18 | (num-edges 0 :type pos-int) 19 | (adj nil :type hash-table) 20 | (make-hset #'identity :type function :read-only t)) 21 | 22 | 23 | (defun make (&key (adj-size 4) (adj-inc 2f0) 24 | (set-size 10) (set-inc 2f0)) 25 | (declare #.*opt-settings*) 26 | (-make-graph :num-edges 0 27 | :adj (make-hash-table :test #'eql :size adj-size 28 | :rehash-size adj-inc) 29 | :make-hset (lambda (x) (declare (inline)) 30 | (hset:make :init x :size set-size :inc set-inc)))) 31 | 32 | (defun copy (grph) 33 | (declare #.*opt-settings* (graph grph)) 34 | ; :key is called in the value before setting 35 | ; https://common-lisp.net/project/alexandria/draft/alexandria.html#Hash-Tables 36 | ; TODO: handle adj-size, set-size, set-inc, adj-inc across graph struct 37 | (-make-graph :num-edges (graph-num-edges grph) 38 | :adj (alexandria:copy-hash-table (graph-adj grph) 39 | :key #'hset:copy) 40 | :make-hset (graph-make-hset grph))) 41 | 42 | 43 | (declaim (inline -add)) 44 | (defun -add (makefx adj a b) 45 | (declare #.*opt-settings* (function makefx) (pos-int a b)) 46 | (multiple-value-bind (val exists) (gethash a adj) 47 | (if (not exists) 48 | (progn (setf val (funcall makefx (list b)) 49 | (gethash a adj) val) 50 | t) 51 | (hset:add val b)))) 52 | 53 | 54 | (defun add (grph a b) 55 | (declare #.*opt-settings* (graph grph) (pos-int a b)) 56 | (with-struct (graph- adj make-hset) grph 57 | (declare (function make-hset)) 58 | (let ((ab (-add make-hset adj a b)) 59 | (ba (-add make-hset adj b a))) 60 | (declare (boolean ab ba)) 61 | (when (or ab ba) (incf (graph-num-edges grph) 2) 62 | t)))) 63 | 64 | 65 | (declaim (inline -del)) 66 | (defun -del (adj a b) 67 | (declare #.*opt-settings* (pos-int a b)) 68 | (multiple-value-bind (val exists) (gethash a adj) 69 | (when exists (hset:del val b)))) 70 | 71 | 72 | (declaim (inline -prune)) 73 | (defun -prune (adj a) 74 | (declare #.*opt-settings* (pos-int a)) 75 | (multiple-value-bind (val exists) (gethash a adj) 76 | (when (and exists (< (the pos-int (hset:num val)) 1)) 77 | (remhash a adj)))) 78 | 79 | 80 | (defun del (grph a b) 81 | (declare #.*opt-settings* (graph grph) (pos-int a b)) 82 | (with-struct (graph- adj) grph 83 | (let ((ab (-del adj a b)) 84 | (ba (-del adj b a))) 85 | (declare (boolean ab ba)) 86 | (when (or ab ba) (-prune adj a) 87 | (-prune adj b) 88 | (decf (graph-num-edges grph) 2) 89 | t)))) 90 | 91 | 92 | (defun get-num-edges (grph) 93 | (declare #.*opt-settings* (graph grph)) 94 | (/ (graph-num-edges grph) 2)) 95 | 96 | (defun get-num-verts (grph) 97 | (declare #.*opt-settings* (graph grph)) 98 | (hash-table-count (graph-adj grph))) 99 | 100 | 101 | (defun mem (grph a b) 102 | (declare #.*opt-settings* (graph grph) (pos-int a b)) 103 | (with-struct (graph- adj) grph 104 | (multiple-value-bind (val exists) (gethash a adj) 105 | (when exists (hset:mem val b))))) 106 | 107 | 108 | (defun get-edges (grph) 109 | (declare #.*opt-settings* (graph grph)) 110 | (loop with res of-type list = (list) 111 | with adj of-type hash-table = (graph-adj grph) 112 | for a of-type pos-int being the hash-keys of adj 113 | do (loop for b of-type pos-int being the hash-keys of (gethash a adj) 114 | if (< a b) do (push (list a b) res)) 115 | finally (return res))) 116 | 117 | 118 | (defun get-verts (grph) 119 | (declare #.*opt-settings* (graph grph)) 120 | (loop for v being the hash-keys of (graph-adj grph) 121 | using (hash-value ee) 122 | collect v)) 123 | 124 | 125 | (defun get-incident-edges (grph v) 126 | (declare #.*opt-settings* (graph grph) (pos-int v)) 127 | (with-struct (graph- adj) grph 128 | (let ((a (gethash v adj))) 129 | (when a (loop for w of-type pos-int being the hash-keys of a 130 | collect (sort (list v w) #'<)))))) 131 | 132 | (defun -only-incident-verts (v ee) 133 | (declare (pos-int v) (list ee)) 134 | (remove-if (lambda (i) (= i v)) (alexandria:flatten ee))) 135 | 136 | (defun get-incident-verts (grph v) 137 | (declare (graph grph) (pos-int v)) 138 | (-only-incident-verts v (get-incident-edges grph v))) 139 | 140 | 141 | (defun vmem (grph v) 142 | (declare #.*opt-settings* (graph grph) (pos-int v)) 143 | (if (gethash v (graph-adj grph)) t nil)) 144 | 145 | 146 | (defmacro with-graph-edges ((grph e) &body body) 147 | (alexandria:with-gensyms (adj a b) 148 | `(loop with ,e of-type list 149 | with ,adj of-type hash-table = (graph-adj ,grph) 150 | for ,a of-type pos-int being the hash-keys of ,adj collect 151 | (loop for ,b of-type pos-int being the hash-keys of (gethash ,a ,adj) 152 | if (< ,a ,b) 153 | do (setf ,e (list ,a ,b)) 154 | (progn ,@body))))) 155 | 156 | -------------------------------------------------------------------------------- /src/graph/paths.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :graph) 3 | 4 | 5 | ; STRIP FILAMENTS 6 | 7 | (defun -del-filament (grph v) 8 | (declare (graph grph) (pos-int v)) 9 | (let ((ee (get-incident-edges grph v))) 10 | (when (= (length ee) 1) 11 | (apply #'del grph (first ee))))) 12 | 13 | (defun del-simple-filaments (grph) 14 | (declare (graph grph)) 15 | "recursively remove all simple filament edges until there are none left" 16 | (loop until (notany #'identity 17 | (loop for v in (get-verts grph) 18 | collect (-del-filament grph v)))) 19 | grph) 20 | 21 | ; CONTINOUS PATHS 22 | 23 | ;note: this can possibly be improved if k is an array 24 | (defun -cycle-info (k) 25 | (declare (list k)) 26 | (if (= (first k) (first (last k))) (list (cdr k) t) 27 | (list k nil))) 28 | 29 | (defun -find-segment (grph start curr) 30 | (declare (graph grph) (pos-int start curr)) 31 | (loop with res = (make-adjustable-vector :type 'pos-int :init (list start)) 32 | with prev of-type pos-int = start 33 | while t 34 | do (let* ((incident (get-incident-edges grph curr)) 35 | (n (length incident))) 36 | (declare (pos-int n)) 37 | 38 | ; loop. attach curr to indicate loop 39 | (when (= curr start) 40 | (vextend curr res) 41 | (return-from -find-segment res)) 42 | 43 | ; dead end/multi 44 | (unless (= n 2) 45 | (vextend curr res) 46 | (return-from -find-segment res)) 47 | 48 | ; single connection 49 | (when (= n 2) 50 | (let ((c (remove-if (lambda (i) (= i curr)) 51 | (-only-incident-verts prev incident)))) 52 | (vextend curr res) 53 | (setf prev curr curr (first c))))))) 54 | 55 | (defun -add-visited-verts (visited path) 56 | (loop for v in path do (setf (gethash v visited) t))) 57 | 58 | (defun get-segments (grph &key cycle-info) 59 | (declare (graph grph)) 60 | " 61 | greedily finds segments between multi-intersection points. TODO: rewrite 62 | this to avoid cheching everything multiple times. i'm sorry. 63 | " 64 | (let ((all-paths (make-hash-table :test #'equal)) 65 | (visited (make-hash-table :test #'equal))) 66 | 67 | (labels 68 | ((-incident-not-two (incident) 69 | (declare (list incident)) 70 | (not (= (length incident) 2))) 71 | 72 | (-incident-two (incident) 73 | (declare (list incident)) 74 | (= (length incident) 2)) 75 | 76 | (-do-find-segment (v next) 77 | (declare (pos-int v next)) 78 | (let* ((path (to-list (-find-segment grph v next))) 79 | (key (sort (copy-list path) #'<))) 80 | (declare (list path key)) 81 | (unless (gethash key all-paths) 82 | (-add-visited-verts visited path) 83 | (setf (gethash key all-paths) path)))) 84 | 85 | (-walk-incident-verts (v testfx) 86 | (declare (pos-int v) (function testfx)) 87 | (let ((incident (get-incident-edges grph v))) 88 | (declare (list incident)) 89 | (when (funcall testfx incident) 90 | (loop for next in (-only-incident-verts v incident) 91 | do (-do-find-segment v next)))))) 92 | 93 | (loop for v in (sort (get-verts grph) #'<) 94 | do (-walk-incident-verts v #'-incident-not-two)) 95 | 96 | ; note: this can be improved if we inverted visited, and remove vertices 97 | ; as they are visited 98 | (loop for v in (sort (get-verts grph) #'<) 99 | unless (gethash v visited) 100 | do (-walk-incident-verts v #'-incident-two))) 101 | 102 | (loop with fx = (if cycle-info #'-cycle-info #'identity) 103 | for k of-type list being the hash-values of all-paths 104 | collect (funcall fx k) of-type list))) 105 | 106 | (defun -angle-fx (a b c) 107 | (declare (ignore a b c)) 108 | 1d0) 109 | 110 | (defun walk-graph (grph &key (angle #'-angle-fx)) 111 | (declare (graph grph)) 112 | 113 | (let ((all-edges (loop with res = (make-hash-table :test #'equal) 114 | for e in (get-edges grph) 115 | do (setf (gethash e res) t) 116 | finally (return res)))) 117 | (labels 118 | ((-ic (a b) (if (< a b) (list a b) (list b a))) 119 | (-get-start-edge () 120 | (loop for e being the hash-keys of all-edges 121 | do (return-from -get-start-edge e))) 122 | 123 | (-least-angle (a b vv) 124 | (cadar (sort 125 | (mapcar (lambda (v) 126 | (list (weir-utils:aif 127 | (funcall angle a b v) 128 | weir-utils::it 0d0) 129 | v)) 130 | vv) 131 | #'> :key #'car))) 132 | 133 | (-next-vert-from (a &key but-not) 134 | (-least-angle but-not a (remove-if 135 | (lambda (v) (or (= v but-not) 136 | (not (gethash (-ic a v) all-edges)))) 137 | (get-incident-verts grph a)))) 138 | 139 | (-until-dead-end (a but-not) 140 | (loop with prv = a 141 | with res = (list prv) 142 | with nxt = (-next-vert-from a :but-not but-not) 143 | until (equal nxt nil) 144 | do (push nxt res) 145 | (remhash (-ic prv nxt) all-edges) 146 | (let ((nxt* (-next-vert-from nxt :but-not prv))) 147 | (setf prv nxt nxt nxt*)) 148 | finally (return res)))) 149 | 150 | (loop while (> (hash-table-count all-edges) 0) 151 | collect (let ((start (-get-start-edge))) 152 | (remhash start all-edges) 153 | (destructuring-bind (a b) start 154 | (concatenate 'list 155 | (-until-dead-end a b) 156 | (reverse (-until-dead-end b a))))))))) 157 | 158 | -------------------------------------------------------------------------------- /src/gridfont/main.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :gridfont) 3 | 4 | ; json docs https://common-lisp.net/project/cl-json/cl-json.html 5 | 6 | (defun -jsn-get (jsn k) (cdr (assoc k jsn))) 7 | 8 | (defstruct (gridfont (:constructor -make-gridfont)) 9 | (scale 1d0 :type double-float :read-only nil) 10 | (sp 1d0 :type double-float :read-only nil) 11 | (nl 13d0 :type double-float :read-only nil) 12 | (pos (vec:zero) :type vec:vec :read-only nil) 13 | (prev nil :read-only nil) 14 | (symbols (make-hash-table :test #'equal) :read-only t)) 15 | 16 | (defun make (&key (fn (internal-path-string "src/gridfont/smooth")) 17 | (scale 1d0) (nl 13d0) (sp 1d0) (xy (vec:zero))) 18 | (with-open-file (fstream (ensure-filename fn ".json" t) 19 | :direction :input) 20 | (loop with res = (make-hash-table :test #'equal) 21 | with jsn = (json:decode-json fstream) ; jsn is an alist 22 | with symbols = (-jsn-get jsn :symbols) 23 | for (k . v) in symbols 24 | do (setf (gethash (symbol-name k) res) v) 25 | finally (return (-make-gridfont :symbols res :scale scale 26 | :sp sp :pos xy :nl nl))))) 27 | 28 | (defun -coerce-vec (p &optional (s 1d0)) 29 | (declare (list p) (double-float s)) 30 | (vec:vec* (mapcar (lambda (x) (* s (coerce x 'double-float))) p))) 31 | 32 | (defun -coerce-paths (paths pos s) 33 | (declare (list paths) (vec:vec pos) (double-float s)) 34 | (loop for path in paths 35 | collect (vec:ladd* (loop for p in path 36 | collect (-coerce-vec p s)) pos))) 37 | 38 | (defun -closed (p &key (tol 0.001d0)) 39 | (declare (list p)) 40 | (< (vec:dst (first p) (first (last p))) tol)) 41 | 42 | (defun -detect-closed (paths) 43 | (declare (list paths)) 44 | (loop for p in paths collect (list p (-closed p)))) 45 | 46 | 47 | (defun update (gf &key pos scale sp nl) 48 | (declare (gridfont gf)) 49 | "update gridfont properties" 50 | (when pos (vec:set! (gridfont-pos gf) pos)) 51 | (when scale (setf (gridfont-scale gf) scale)) 52 | (when sp (setf (gridfont-sp gf) sp)) 53 | (when nl (setf (gridfont-nl nl) sp))) 54 | 55 | 56 | (defun nl (gf &key (left 0d0)) 57 | (declare (gridfont gf) (double-float left)) 58 | "write a newline" 59 | (setf (gridfont-prev gf) nil) 60 | (with-struct (gridfont- pos nl scale) gf 61 | (vec:set! pos (vec:vec left (+ (vec:vec-y pos) (* nl scale)))))) 62 | 63 | 64 | (defun -get-meta (symbols c &aux (c* (string c))) 65 | (multiple-value-bind (meta exists) 66 | (gethash (funcall json:*json-identifier-name-to-lisp* c*) symbols) 67 | (unless exists (error "symbol does not exist: ~a (representation: ~a)" c c*)) 68 | meta)) 69 | 70 | (defun wc (gf c &key xy) 71 | (declare (gridfont gf)) 72 | "write single character, c" 73 | (with-struct (gridfont- symbols scale sp pos) gf 74 | (when xy (vec:set! pos xy)) 75 | (let* ((meta (-get-meta symbols c)) 76 | (paths (-jsn-get meta :paths)) 77 | (w (coerce (-jsn-get meta :w) 'double-float)) 78 | (res (-detect-closed (-coerce-paths paths pos scale)))) 79 | (vec:add! pos (vec:vec (* scale (+ w sp)) 0d0)) 80 | (setf (gridfont-prev gf) (string c)) 81 | res))) 82 | 83 | 84 | (defun get-phrase-box (gf str) 85 | (declare (gridfont gf) (string str)) 86 | "width and height of phrase" 87 | (with-struct (gridfont- symbols scale sp) gf 88 | (loop for c across str 89 | summing (+ (-jsn-get (-get-meta symbols c) :w) sp) into width 90 | maximizing (-jsn-get (-get-meta symbols c) :h) into height 91 | finally (return (-coerce-vec (list width height) scale))))) 92 | 93 | 94 | ;TODO: left in make 95 | ; left in nl 96 | ; top in make 97 | 98 | -------------------------------------------------------------------------------- /src/hset.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :hset) 3 | 4 | " 5 | fixnum set 6 | 7 | this is a naive wrapper around hash-map. not sure how efficient it will be? 8 | " 9 | 10 | (defun copy (s &key (size 100) (inc 2f0)) 11 | (declare #.*opt-settings* (fixnum size)) 12 | (let ((ns (make-hash-table :test #'eql :size size :rehash-size inc))) 13 | (loop for k being the hash-keys of s do (setf (gethash k ns) t)) 14 | ns)) 15 | 16 | 17 | (declaim (inline add)) 18 | (defun add (s e) 19 | (declare #.*opt-settings* (fixnum e)) 20 | (multiple-value-bind (val exists) (gethash e s) 21 | (declare (ignore val)) 22 | (if exists nil (setf (gethash e s) t)))) 23 | 24 | (defun add* (s ee) 25 | (declare #.*opt-settings* (hash-table s) (sequence ee)) 26 | (if (equal (type-of ee) 'cons) 27 | (loop for e of-type fixnum in ee collect (add s e)) 28 | (loop for e of-type fixnum across ee collect (add s e)))) 29 | 30 | 31 | (defun make (&key init (size 100) (inc 2f0)) 32 | (declare #.*opt-settings* (fixnum size)) 33 | (let ((s (make-hash-table :test #'eql :size size :rehash-size inc))) 34 | (when init (add* s init)) 35 | s)) 36 | 37 | 38 | (defun del (s e) 39 | (declare (hash-table s) (fixnum e)) 40 | (declare #.*opt-settings* (fixnum e)) 41 | (remhash e s)) 42 | 43 | 44 | (defun del* (s ee) 45 | (declare #.*opt-settings* (hash-table s) (sequence ee)) 46 | (if (equal (type-of ee) 'cons) 47 | (loop for e of-type fixnum in ee collect (remhash e s)) 48 | (loop for e of-type fixnum across ee collect (remhash e s)))) 49 | 50 | 51 | (declaim (inline mem)) 52 | (defun mem (s e) 53 | (declare #.*opt-settings* (hash-table s) (fixnum e)) 54 | (multiple-value-bind (_ exists) (gethash e s) 55 | (declare (ignore _)) 56 | exists)) 57 | 58 | 59 | (defun mem* (s ee) 60 | (declare #.*opt-settings* (hash-table s) (list ee)) 61 | (loop for e of-type fixnum in ee collect 62 | (multiple-value-bind (v exists) (gethash e s) 63 | (declare (ignore v)) 64 | exists))) 65 | 66 | 67 | (defun num (s) 68 | (declare #.*opt-settings* (hash-table s)) 69 | (the fixnum (hash-table-count s))) 70 | 71 | 72 | (defun to-list (s) 73 | (declare #.*opt-settings* (hash-table s)) 74 | (loop for e of-type fixnum being the hash-keys of s collect e)) 75 | 76 | 77 | ; SET OPS (not tested) 78 | 79 | (defun uni (a b) 80 | (declare #.*opt-settings* (hash-table a b)) 81 | (let ((c (copy a))) 82 | (loop for k being the hash-keys of b 83 | do (setf (gethash k c) t)) 84 | c)) 85 | 86 | (defun inter (a b) 87 | (declare #.*opt-settings* (hash-table a b)) 88 | (loop with c = (make) 89 | for k being the hash-keys of a 90 | do (when (mem b k) 91 | (setf (gethash k c) t)) 92 | finally (return c))) 93 | 94 | (defun symdiff (a b) 95 | (declare #.*opt-settings* (hash-table a b)) 96 | (let ((un (uni a b))) 97 | (loop for k being the hash-keys of un 98 | do (when (and (mem a k) (mem b k)) 99 | (remhash k un))) 100 | un)) 101 | 102 | -------------------------------------------------------------------------------- /src/math/curvature.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :curvature) 3 | 4 | (deftype pos-double () `(double-float 0d0 *)) 5 | 6 | (deftype pos-int (&optional (bits 31)) 7 | `(unsigned-byte ,bits)) 8 | 9 | (deftype vec-simple () `(simple-array vec:vec)) 10 | 11 | 12 | ;TODO: add first order estimations on boundary points? 13 | (declaim (inline ddxy)) 14 | (defun ddxy (pts i &aux (n (length pts))) 15 | " 16 | calculate first and second derivatives of pts wrt t 17 | (the parametrisation variable). 18 | assumes that pts is parameterised from 0 to 1, and evenly sampled in t. 19 | " 20 | (declare #.*opt-settings* (vec-simple pts) (pos-int i)) 21 | (let* ((s (/ 2d0 (coerce (1- n) 'double-float))) 22 | (s2 (expt s 2d0)) 23 | (p (aref pts i)) 24 | (p- (aref pts (1- i))) 25 | (p+ (aref pts (1+ i)))) 26 | (declare (vec:vec p- p+ p) (pos-double s s2)) 27 | (values (/ (- (vec:vec-x p+) (vec:vec-x p-)) s) 28 | (/ (- (vec:vec-y p+) (vec:vec-y p-)) s) 29 | (/ (+ (vec:vec-x p+) (vec:vec-x p-) (* -2d0 (vec:vec-x p))) s2) 30 | (/ (+ (vec:vec-y p+) (vec:vec-y p-) (* -2d0 (vec:vec-y p))) s2)))) 31 | 32 | 33 | (declaim (inline kappa)) 34 | (defun kappa (pts i) 35 | "estimate curvature based on pts" 36 | (declare #.*opt-settings* (vec-simple pts) (pos-int i)) 37 | (multiple-value-bind (dx dy ddx ddy) (ddxy pts i) 38 | (declare (double-float dx dy ddx ddy)) 39 | (/ (abs (- (* dx ddy) (* dy ddx))) 40 | (expt (the pos-double (+ (* dx dx) (* dy dy))) 41 | #.(/ 3d0 2d0))))) 42 | 43 | 44 | (declaim (inline -coffset)) 45 | (defun -coffset (pts angles i) 46 | (declare #.*opt-settings* (vec-simple pts) (vec-simple angles) 47 | (pos-int i)) 48 | (let* ((va (aref angles (1- i))) 49 | (vb (aref angles i)) 50 | (ab (vec:angle vb))) 51 | (declare (vec:vec va vb) (double-float ab)) 52 | (list (kappa pts i) (aref pts i) 53 | (if (<= (the double-float (vec:cross va vb)) 0d0) 54 | (vec:cos-sin (+ ab PI5)) 55 | (vec:cos-sin (- ab PI5)))))) 56 | 57 | (declaim (inline -pad-offsets)) 58 | (defun -pad-offsets (pts) 59 | (declare #.*opt-settings* (list pts)) 60 | (concatenate 'list (list (first pts)) pts (last pts))) 61 | 62 | 63 | ; TODO: closed version 64 | (defun offsets (pts) 65 | " 66 | offset pts according to estimated curvature. 67 | pts must be evenly distributed 68 | " 69 | (declare #.*opt-settings* (vec-simple pts)) 70 | (-pad-offsets 71 | (loop with angles of-type vec-simple = (math:path-angles pts) 72 | for i of-type pos-int from 1 below (1- (length pts)) 73 | collect (-coffset pts angles i )))) 74 | 75 | 76 | (declaim (inline -do-split-num)) 77 | (defun -do-split-num (res rs curvefx curr c a b) 78 | (declare #.*opt-settings* (list res) (pos-double rs) (double-float c) 79 | (function curvefx) (pos-int curr) (vec:vec a b)) 80 | (let* ((cw (funcall curvefx c)) 81 | (n (ceiling (the pos-double (* rs cw))))) 82 | (declare (double-float cw) (pos-int n)) 83 | (when (math:list>than res 0) (push (list n cw a b) (first res))) 84 | (when (not (= n curr)) (push (list (list n cw a b)) res)) 85 | (values res n))) 86 | 87 | (declaim (inline -split-num)) 88 | (defun -split-num (offsets rs curvefx) 89 | (declare #.*opt-settings* (list offsets) (pos-double rs) (function curvefx)) 90 | (loop with curr of-type pos-int = 0 91 | with res of-type list = (list) 92 | for (c a b) in offsets 93 | do (multiple-value-bind (res* n) 94 | (-do-split-num res rs curvefx curr c a b) 95 | (declare (list res) (pos-int n)) 96 | (setf curr n res res*)) 97 | finally (return res))) 98 | 99 | 100 | (declaim (inline -curvefx)) 101 | (defun -curvefx (c) 102 | (declare (pos-double c)) 103 | (* 500d0 (expt c 0.6d0))) 104 | 105 | (declaim (inline -spacefx)) 106 | (defun -spacefx (n) 107 | (declare (pos-int n)) 108 | (math:linspace n 0d0 1d0)) 109 | 110 | ; TODO: closed 111 | (defun offset-paths (pts &key (rs 0.1d0) (curvefx #'-curvefx) 112 | (spacefx #'-spacefx)) 113 | " 114 | offset pts according to curvature. 115 | pts must be evenly sampled for this to work properly. 116 | experimental. 117 | " 118 | (declare #.*opt-settings* (vec-simple pts) (pos-double rs) 119 | (function curvefx spacefx)) 120 | (loop with res of-type list = (list) 121 | for offset of-type list in (-split-num (offsets pts) rs curvefx) 122 | do (loop with n of-type pos-int = (caar offset) 123 | for s of-type pos-double in (funcall spacefx n) 124 | do (push 125 | (list n (loop for (_ c a b) in offset 126 | collect (vec:on-line s a (vec:from a b c)) 127 | of-type vec:vec)) 128 | res)) 129 | finally (return res))) 130 | 131 | -------------------------------------------------------------------------------- /src/math/path.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :math) 3 | 4 | 5 | (defun line-from (a r &optional (s 1d0)) 6 | (declare (vec:vec a r) (double-float s)) 7 | (list a (vec:from a r s))) 8 | 9 | 10 | (defun path-tangents (aa &key closed (default vec:*zero*) 11 | &aux (aa* (if (equal (type-of aa) 'cons) 12 | (make-adjustable-vector :init aa :type 'vec:vec) 13 | aa))) 14 | (when closed (vextend (aref aa* 0) aa*)) 15 | (loop with res = (make-adjustable-vector :type 'vec:vec) 16 | for i from 0 below (1- (length aa*)) 17 | do (vextend (vec:nsub (aref aa* (1+ i)) (aref aa* i) 18 | :default default) 19 | res) 20 | finally (return res))) 21 | 22 | 23 | (defun path-angles (pts) 24 | (loop with n of-type pos-int = (1- (length pts)) 25 | with res = (make-array (1+ n) :element-type 'vec:vec 26 | :adjustable nil 27 | :initial-element vec:*zero*) 28 | for i of-type pos-int from 0 below n 29 | do (setf (aref res i) (vec:norm! (vec:sub (aref pts (1+ i)) 30 | (aref pts i)))) 31 | finally (setf (aref res n) (aref res (1- n))) 32 | (return res))) 33 | 34 | 35 | ; TODO: closed? 36 | (defun path-length (path) 37 | (declare (list path)) 38 | (loop for a of-type vec:vec in path 39 | and b of-type vec:vec in (cdr path) 40 | summing (vec:dst a b))) 41 | 42 | (defun 3path-length (path) 43 | (declare (list path)) 44 | (loop for a of-type vec:3vec in path 45 | and b of-type vec:3vec in (cdr path) 46 | summing (vec:3dst a b))) 47 | 48 | 49 | ; ----- STIPPLE ----- 50 | 51 | ; more or less as suggested in 52 | ; https://gist.github.com/evanmiltenburg/dfd571f27372477487cb14f2bdf8b35c 53 | 54 | (defun -stipple-get-lengths (num-lines len) 55 | (loop with lens of-type list = (rnd:nrnd num-lines) 56 | with s of-type double-float = (/ (dsum lens)) 57 | for l in lens collect (* (* l len) s))) 58 | 59 | (defun stipple (num-lines len) 60 | " 61 | draw num-lines stipples between (0 1) the stipples will have a total length 62 | of len 63 | " 64 | (declare #.*opt-settings* (pos-int num-lines) (double-float len)) 65 | (let ((lengths (-stipple-get-lengths num-lines len)) 66 | (gaps (-stipple-get-lengths (1- num-lines) (- 1d0 len)))) 67 | (declare (list lengths gaps)) 68 | (loop with curr of-type double-float = (first lengths) 69 | with res of-type vector = (to-adjustable-vector 70 | (list (list 0d0 curr)) :type 'vec:vec) 71 | for l of-type double-float in (cdr lengths) 72 | and g of-type double-float in gaps 73 | do (vextend (list curr (+ curr l)) res) 74 | (incf curr (+ l g)) 75 | finally (return res)))) 76 | 77 | -------------------------------------------------------------------------------- /src/math/simplify-path.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :simplify-path) 3 | 4 | (deftype pos-int (&optional (bits 31)) 5 | `(unsigned-byte ,bits)) 6 | 7 | (deftype int-vector () `(vector pos-int)) 8 | 9 | (deftype vec-simple () `(simple-array vec:vec)) 10 | 11 | 12 | ;note: it would be better if we could avoid using an adjustable vector. 13 | (defun -simplify (pts lim &key left right) 14 | (declare #.*opt-settings* (double-float lim) 15 | (vec-simple pts) (pos-int left right)) 16 | (let ((res (make-adjustable-vector :type 'pos-int)) 17 | (dmax -1d0) 18 | (index 0)) 19 | (declare (int-vector res) (pos-int index) (double-float dmax)) 20 | 21 | (loop with seg of-type list = (list (aref pts left) (aref pts right)) 22 | for i of-type pos-int from (1+ left) below right 23 | do (let ((d (vec:segdst seg (aref pts i)))) 24 | (declare (double-float d)) 25 | (when (> d dmax) (setf dmax d index i)))) 26 | 27 | (if (> dmax lim) 28 | (progn (loop with ps of-type int-vector = 29 | (-simplify pts lim :left left :right index) 30 | for i from 0 below (1- (length ps)) 31 | do (vextend (aref ps i) res)) 32 | (loop for i across (-simplify pts lim :left index :right right) 33 | do (vextend i res))) 34 | (progn (vextend left res) 35 | (vextend right res))) 36 | (sort res #'<))) 37 | 38 | 39 | ; https://hydra.hull.ac.uk/resources/hull:8338 40 | (defun simplify (pts &key (lim 1d0)) 41 | (declare #.*opt-settings* (vec-simple pts) (double-float lim)) 42 | (loop for i of-type pos-int across 43 | (-simplify pts lim :left 0 :right (1- (length pts))) 44 | collect (aref pts i) of-type vec:vec)) 45 | 46 | -------------------------------------------------------------------------------- /src/parallel/main.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :parallel) 3 | 4 | ;https://z0ltan.wordpress.com/2016/09/09/basic-concurrency-and-parallelism-in-common-lisp-part-4a-parallelism-using-lparallel-fundamentals/ 5 | 6 | 7 | (defun init (&key (cores 4) (name "custom-kernel")) 8 | (setf lparallel:*kernel* 9 | (lparallel:make-kernel cores :name name))) 10 | 11 | 12 | (defun end () 13 | (lparallel:end-kernel :wait t)) 14 | 15 | 16 | (defun info () 17 | (let ((name (lparallel:kernel-name)) 18 | (count (lparallel:kernel-worker-count)) 19 | (context (lparallel:kernel-context)) 20 | (bindings (lparallel:kernel-bindings))) 21 | (format t "kernel name = ~a~%" name) 22 | (format t "worker threads count = ~d~%" count) 23 | (format t "kernel context = ~a~%" context) 24 | (format t "kernel bindings = ~a~%" bindings))) 25 | 26 | 27 | (defun create-channel () 28 | (lparallel:make-channel)) 29 | 30 | 31 | (defun submit-task (channel fx) 32 | (lparallel:submit-task channel fx) 33 | (lparallel:receive-result channel)) 34 | 35 | -------------------------------------------------------------------------------- /src/pigment/extra.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :pigment) 3 | 4 | 5 | (declaim (inline -hex)) 6 | (defun -hex (d) 7 | (declare #.*opt-settings* (double-float d)) 8 | (let ((res (format nil "~X" (min 255 (max 0 (floor (* d 256))))))) 9 | (if (< (length res) 2) (concatenate 'string "0" res) res))) 10 | 11 | (defun to-hex (c) 12 | (declare #.*opt-settings* (rgba c)) 13 | (destructuring-bind (r g b a) (to-list c) 14 | (values (apply #'concatenate 'string (list "#" (-hex r) (-hex g) (-hex b))) 15 | a))) 16 | 17 | 18 | (defun cmyk (c m y k &optional (a 1d0)) 19 | (declare #.*opt-settings* (double-float c m y k a)) 20 | (let ((ik (- 1d0 k))) 21 | (make (* (- 1d0 c) ik) (* (- 1d0 m) ik) (* (- 1d0 y) ik) a))) 22 | 23 | 24 | (declaim (inline hsv)) 25 | (defun hsv (h s v &optional (a 1d0)) 26 | (declare #.*opt-settings* (double-float h s v a)) 27 | (let* ((c (* v s)) 28 | (x (* c (- 1d0 (abs (- (mod (* 6d0 h) 2d0) 1d0))))) 29 | (m (- v c))) 30 | (declare (double-float c x m)) 31 | (multiple-value-bind (r g b) 32 | (case (floor (mod (* h 6d0) 6d0)) 33 | (0 (values (+ c m) (+ x m) m)) 34 | (1 (values (+ x m) (+ c m) m)) 35 | (2 (values m (+ c m) (+ x m))) 36 | (3 (values m (+ x m) (+ c m))) 37 | (4 (values (+ x m) m (+ c m))) 38 | (5 (values (+ c m) m (+ x m))) 39 | (t (values 0d0 0d0 0d0))) 40 | (declare (double-float r g b)) 41 | (make r g b a)))) 42 | 43 | 44 | ;(declaim (inline -mod)) 45 | (defun -mod (ca cb df &optional (p 1d0)) 46 | (declare (double-float ca cb df p)) 47 | ;(mod a b) is remainder of (floor a b) 48 | (multiple-value-bind (_ res) 49 | (floor (the double-float 50 | (+ p (* 0.16666666666666666d0 51 | (/ (the double-float (- ca cb)) df))))) 52 | (declare (ignore _) (fixnum _) (double-float res)) 53 | res)) 54 | 55 | (defun as-hsv (c) 56 | (declare #.*opt-settings* (rgba c)) 57 | (-with (c r g b a) 58 | (let ((rgb (list r g b))) 59 | (destructuring-bind (imn mn) (math:argmin rgb) 60 | (declare (fixnum imn) (double-float mn)) 61 | (destructuring-bind (imx mx) (math:argmax rgb) 62 | (declare (fixnum imx) (double-float mx)) 63 | (let ((df (- mx mn))) 64 | (declare (double-float df)) 65 | (list (cond ((= imn imx) 0d0) 66 | ((= imx 0) (-mod g b df)) 67 | ((= imx 1) (-mod b r df 0.3333333333333333d0)) 68 | ((= imx 2) (-mod r g df 0.6666666666666666d0))) 69 | (if (<= mx 0d0) 0d0 (/ df mx)) 70 | mx 71 | a))))))) 72 | 73 | (defun magenta (&key (sat 0.8d0) (val 0.85d0) (alpha 1d0)) 74 | (hsv #.(/ 281d0 360d0) sat val alpha)) 75 | 76 | (defun cyan (&key (sat 0.8d0) (val 0.85d0) (alpha 1d0)) 77 | (hsv #.(/ 196d0 360d0) sat val alpha)) 78 | 79 | (defun orange (&key (sat 0.8d0) (val 0.85d0) (alpha 1d0)) 80 | (hsv #.(/ 38d0 360d0) sat val alpha)) 81 | 82 | (defun blood (&key (sat 0.8d0) (val 0.85d0) (alpha 1d0)) 83 | (hsv #.(/ 362d0 360d0) sat val alpha)) 84 | 85 | -------------------------------------------------------------------------------- /src/pigment/non-alpha.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :pigment) 3 | 4 | ; these functions ignores the pigment alpha channel. intended for use in eg. 5 | ; raytracing, or if we know that alpha is always 1. 6 | 7 | (declaim (inline -clamp)) 8 | (defun -clamp (v) 9 | (declare #.*opt-settings* (double-float v)) 10 | (min 1d0 (the double-float (max 0d0 v)))) 11 | 12 | 13 | (declaim (inline non-a-scale)) 14 | (defun non-a-scale (c s) 15 | (declare #.*opt-settings* (rgba c) (double-float s)) 16 | (-make-rgba (* (rgba-r c) s) (* (rgba-g c) s) (* (rgba-b c) s) 1d0)) 17 | 18 | (declaim (inline non-a-scale!)) 19 | (defun non-a-scale! (c s) 20 | (declare #.*opt-settings* (rgba c) (double-float s)) 21 | (setf (rgba-r c) (* (rgba-r c) s) (rgba-g c) (* (rgba-g c) s) 22 | (rgba-b c) (* (rgba-b c) s)) 23 | c) 24 | 25 | 26 | (declaim (inline non-a-scale-add)) 27 | (defun non-a-scale-add (v q s) 28 | (declare #.*opt-settings* (rgba v q) (double-float s)) 29 | (-make-rgba (+ (rgba-r v) (* (rgba-r q) s)) (+ (rgba-g v) (* (rgba-g q) s)) 30 | (+ (rgba-b v) (* (rgba-b q) s)) 1d0)) 31 | 32 | (declaim (inline non-a-scale-add!)) 33 | (defun non-a-scale-add! (v q s) 34 | (declare #.*opt-settings* (rgba v q) (double-float s)) 35 | (setf (rgba-r v) (+ (rgba-r v) (* (rgba-r q) s)) 36 | (rgba-g v) (+ (rgba-g v) (* (rgba-g q) s)) 37 | (rgba-b v) (+ (rgba-b v) (* (rgba-b q) s))) 38 | v) 39 | 40 | 41 | (declaim (inline non-a-combine!)) 42 | (defun non-a-combine! (ca cb wa wb) 43 | (declare #.*opt-settings* (rgba ca cb) (double-float wa wb)) 44 | (setf (rgba-r ca) (+ (* wa (rgba-r ca)) (* wb (rgba-r cb))) 45 | (rgba-g ca) (+ (* wa (rgba-g ca)) (* wb (rgba-g cb))) 46 | (rgba-b ca) (+ (* wa (rgba-b ca)) (* wb (rgba-b cb)))) 47 | ca) 48 | 49 | (declaim (inline non-a-combine)) 50 | (defun non-a-combine (ca cb wa wb) 51 | (declare #.*opt-settings* (rgba ca cb) (double-float wa wb)) 52 | (-make-rgba (+ (* wa (rgba-r ca)) (* wb (rgba-r cb))) 53 | (+ (* wa (rgba-g ca)) (* wb (rgba-g cb))) 54 | (+ (* wa (rgba-b ca)) (* wb (rgba-b cb))) 55 | 1d0)) 56 | 57 | 58 | (declaim (inline non-a-gamma!)) 59 | (defun non-a-gamma! (v gamma) 60 | (declare #.*opt-settings* (rgba v) (double-float gamma)) 61 | (setf (rgba-r v) (expt (rgba-r v) gamma) 62 | (rgba-g v) (expt (rgba-g v) gamma) 63 | (rgba-b v) (expt (rgba-b v) gamma)) 64 | v) 65 | 66 | (declaim (inline non-a-add)) 67 | (defun non-a-add (v q &key (a 1d0)) 68 | (declare #.*opt-settings* (rgba v q) (double-float a)) 69 | (-make-rgba (+ (rgba-r v) (rgba-r q)) (+ (rgba-g v) (rgba-g q)) 70 | (+ (rgba-b v) (rgba-b q)) a)) 71 | 72 | (declaim (inline non-a-add!)) 73 | (defun non-a-add! (v q) 74 | (declare #.*opt-settings* (rgba v q)) 75 | (setf (rgba-r v) (+ (rgba-r v) (rgba-r q)) 76 | (rgba-g v) (+ (rgba-g v) (rgba-g q)) 77 | (rgba-b v) (+ (rgba-b v) (rgba-b q))) 78 | v) 79 | 80 | (declaim (inline non-a-clamp)) 81 | (defun non-a-clamp (c) 82 | (declare #.*opt-settings* (rgba c)) 83 | (-make-rgba (-clamp (rgba-r c)) (-clamp (rgba-g c)) 84 | (-clamp (rgba-b c)) 1d0)) 85 | 86 | (declaim (inline non-a-clamp!)) 87 | (defun non-a-clamp! (c) 88 | (declare #.*opt-settings* (rgba c)) 89 | (setf (rgba-r c) (-clamp (rgba-r c)) 90 | (rgba-g c) (-clamp (rgba-g c)) 91 | (rgba-b c) (-clamp (rgba-b c))) 92 | c) 93 | 94 | 95 | (declaim (inline non-a-mult)) 96 | (defun non-a-mult (v q) 97 | (declare #.*opt-settings* (rgba v q)) 98 | (-make-rgba (* (rgba-r v) (rgba-r q)) 99 | (* (rgba-g v) (rgba-g q)) 100 | (* (rgba-b v) (rgba-b q)) 101 | 1d0)) 102 | 103 | (declaim (inline non-a-mult!)) 104 | (defun non-a-mult! (v q) 105 | (declare #.*opt-settings* (rgba v q)) 106 | (setf (rgba-r v) (* (rgba-r v) (rgba-r q)) 107 | (rgba-g v) (* (rgba-g v) (rgba-g q)) 108 | (rgba-b v) (* (rgba-b v) (rgba-b q))) 109 | v) 110 | 111 | -------------------------------------------------------------------------------- /src/pigment/pigment.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :pigment) 3 | 4 | """ 5 | Colors are stored internally with premultiplied alpha. 6 | Package was renamed from 'color' because of a package name collision. 7 | """ 8 | 9 | (defmacro with ((c r g b a) &body body) 10 | (alexandria:with-gensyms (c*) 11 | `(let* ((,c* ,c) 12 | (,r (rgba-r ,c*)) 13 | (,g (rgba-g ,c*)) 14 | (,b (rgba-b ,c*)) 15 | (,a (rgba-a ,c*))) 16 | (declare (double-float ,r ,g ,b ,a)) 17 | (progn ,@body)))) 18 | 19 | 20 | (defmacro -with ((c r g b a) &body body) 21 | (alexandria:with-gensyms (c*) 22 | `(let* ((,c* ,c) 23 | (,a (rgba-a ,c*)) 24 | (,r (/ (rgba-r ,c*) ,a)) 25 | (,g (/ (rgba-g ,c*) ,a)) 26 | (,b (/ (rgba-b ,c*) ,a))) 27 | (declare (double-float ,r ,g ,b ,a)) 28 | (progn ,@body)))) 29 | 30 | 31 | (declaim (inline make-rgba -make-rgba rgba-r rgba-g rgba-b rgba-a)) 32 | (defstruct (rgba (:constructor make-rgba) (:constructor -make-rgba (r g b a))) 33 | (r 0d0 :type double-float :read-only nil) 34 | (g 0d0 :type double-float :read-only nil) 35 | (b 0d0 :type double-float :read-only nil) 36 | (a 1d0 :type double-float :read-only nil)) 37 | 38 | (weir-utils:define-struct-load-form rgba) 39 | #+SBCL(declaim (sb-ext:freeze-type rgba)) 40 | 41 | 42 | (declaim (inline make)) 43 | (defun make (r g b &optional (a 1d0)) 44 | (declare #.*opt-settings* (double-float r g b a)) 45 | (-make-rgba (* a r) (* a g) (* a b) a)) 46 | 47 | (declaim (inline copy)) 48 | (defun copy (c) 49 | (declare #.*opt-settings* (rgba c)) 50 | (-make-rgba (rgba-r c) (rgba-g c) (rgba-b c) (rgba-a c))) 51 | 52 | (defun to-list (c) 53 | (declare #.*opt-settings* (rgba c)) 54 | (let ((a (rgba-a c))) 55 | (list (/ (rgba-r c) a) (/ (rgba-g c) a) (/ (rgba-b c) a) a))) 56 | 57 | (defun to-list* (c) 58 | (declare #.*opt-settings* (rgba c)) 59 | (list (rgba-r c) (rgba-g c) (rgba-b c) (rgba-a c))) 60 | 61 | 62 | (defun white (&optional (a 1d0)) 63 | (declare #.*opt-settings* (double-float a)) 64 | (make 1d0 1d0 1d0 a)) 65 | 66 | (defun black (&optional (a 1d0)) 67 | (declare #.*opt-settings* (double-float a)) 68 | (make 0d0 0d0 0d0 a)) 69 | 70 | (defun red (&optional (a 1d0)) 71 | (declare #.*opt-settings* (double-float a)) 72 | (make 1d0 0d0 0d0 a)) 73 | 74 | (defun green (&optional (a 1d0)) 75 | (declare #.*opt-settings* (double-float a)) 76 | (make 0d0 1d0 0d0 a)) 77 | 78 | (defun blue (&optional (a 1d0)) 79 | (declare #.*opt-settings* (double-float a)) 80 | (make 0d0 0d0 1d0 a)) 81 | 82 | (defun mdark (&optional (a 1d0)) 83 | (declare #.*opt-settings* (double-float a)) 84 | (make 0.3d0 0.3d0 0.3d0 a)) 85 | 86 | (defun dark (&optional (a 1d0)) 87 | (declare #.*opt-settings* (double-float a)) 88 | (make 0.2d0 0.2d0 0.2d0 a)) 89 | 90 | (defun vdark (&optional (a 1d0)) 91 | (declare #.*opt-settings* (double-float a)) 92 | (make 0.1d0 0.1d0 0.1d0 a)) 93 | 94 | (defun gray (v &optional (a 1d0)) 95 | (declare #.*opt-settings* (double-float v a)) 96 | (make v v v a)) 97 | 98 | (defun transparent () 99 | (declare #.*opt-settings*) 100 | (make 0d0 0d0 0d0 0d0)) 101 | 102 | 103 | (declaim (inline rgb)) 104 | (defun rgb (r g b &optional (a 1d0)) 105 | (declare #.*opt-settings* (double-float r g b a)) 106 | (make r g b a)) 107 | 108 | 109 | (declaim (inline scale)) 110 | (defun scale (c s) 111 | (declare #.*opt-settings* (rgba c) (double-float s)) 112 | (-make-rgba (* (rgba-r c) s) (* (rgba-g c) s) 113 | (* (rgba-b c) s) (* (rgba-a c) s))) 114 | 115 | (declaim (inline scale!)) 116 | (defun scale! (c s) 117 | (declare #.*opt-settings* (rgba c) (double-float s)) 118 | (setf (rgba-r c) (* (rgba-r c) s) (rgba-g c) (* (rgba-g c) s) 119 | (rgba-b c) (* (rgba-b c) s) (rgba-a c) (* (rgba-a c) s)) 120 | c) 121 | 122 | 123 | (declaim (inline safe-clamp)) 124 | (defun safe-clamp (c) 125 | (declare #.*opt-settings* (rgba c)) 126 | "clamp between 0, a, since we use pre-mult alpha" 127 | (let ((a (rgba-a c))) 128 | (declare (double-float a)) 129 | (-make-rgba (min a (max 0d0 (rgba-r c))) (min a (max 0d0 (rgba-g c))) 130 | (min a (max 0d0 (rgba-b c))) a) 131 | c)) 132 | 133 | (declaim (inline safe-clamp!)) 134 | (defun safe-clamp! (c) 135 | (declare #.*opt-settings* (rgba c)) 136 | "clamp between 0, a, since we use pre-mult alpha" 137 | (let ((a (rgba-a c))) 138 | (declare (double-float a)) 139 | (setf (rgba-r c) (min a (max 0d0 (rgba-r c))) 140 | (rgba-g c) (min a (max 0d0 (rgba-g c))) 141 | (rgba-b c) (min a (max 0d0 (rgba-b c)))) 142 | c)) 143 | 144 | -------------------------------------------------------------------------------- /src/project/perspective.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :perspective) 3 | 4 | "Naive 3d->2d projection that uses three 2d vectors (a, b, c) as well as center 5 | (xy) and scale (s) for projection" 6 | 7 | 8 | (declaim (inline -make-perspective)) 9 | (defstruct (perspective (:constructor -make-perspective)) 10 | (a nil :type vec:vec :read-only t) 11 | (b nil :type vec:vec :read-only t) 12 | (c nil :type vec:vec :read-only t) 13 | (xy nil :type vec:vec :read-only t) 14 | (s 1d0 :type double-float :read-only t)) 15 | 16 | 17 | (defun -length-norm (ll) 18 | (declare (list ll)) 19 | (loop with len of-type double-float = 20 | (loop for p of-type vec:vec in ll 21 | sum (vec:len p) of-type double-float) 22 | for p of-type vec:vec in ll 23 | collect (vec:smult p (/ len)))) 24 | 25 | (defun make* (abc &key (xy vec:*zero*) (s 1d0)) 26 | (declare (list abc)) 27 | (destructuring-bind (a b c) (-length-norm abc) 28 | (-make-perspective :a a :b b :c c :xy xy :s s))) 29 | 30 | (defun make (a b c &key (xy vec:*zero*) (s 1d0)) 31 | (declare (vec:vec a b c)) 32 | (destructuring-bind (a* b* c*) (-length-norm (list a b c)) 33 | (-make-perspective :a a* :b b* :c c* :xy xy :s s))) 34 | 35 | 36 | (declaim (inline -project)) 37 | (defun -project (a b c s xy pt) 38 | (declare #.*opt-settings* 39 | (vec:vec a b c xy) (double-float s) (vec:3vec pt)) 40 | (vec:3with-xy (pt x y z) 41 | (vec:add xy (vec:lsum (list (vec:smult a (* s x)) 42 | (vec:smult b (* s y)) 43 | (vec:smult c (* s z))))))) 44 | 45 | 46 | (defun project (p pt &key xy s) 47 | (declare #.*opt-settings* 48 | (perspective p)) 49 | (with-struct (perspective- a b c) p 50 | (let ((xy* (if xy xy (perspective-xy p))) 51 | (s* (if s s (perspective-s p)))) 52 | (declare (double-float s*) (vec:vec xy*)) 53 | (if (equal (type-of pt) 'cons) 54 | (loop for p of-type vec:3vec in pt collect (-project a b c s* xy* p)) 55 | (-project a b c s* xy* pt))))) 56 | 57 | 58 | (defun get-projector (&key noise (xy vec:*zero*) (s 1d0) 59 | (angle #.(/ (* PI 7d0) 6d0))) 60 | (make* (loop for a in (math:linspace 3 angle (+ angle PII) :end nil) 61 | collect (vec:cos-sin (+ a (if noise (rnd:rnd* noise) 0d0)))) 62 | :xy xy :s s)) 63 | 64 | -------------------------------------------------------------------------------- /src/rnd/3rnd.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | 5 | (defun 3on-line (a b) 6 | (declare #.*opt-settings* (vec:3vec a b)) 7 | (vec:3from a (vec:3sub b a) (rnd))) 8 | 9 | (defun 3on-line* (ab) 10 | (declare #.*opt-settings* (list ab)) 11 | (apply #'3on-line ab)) 12 | 13 | 14 | (defun 3non-line (n a b) 15 | (declare #.*opt-settings* (fixnum n) (vec:3vec a b)) 16 | (loop with ba = (vec:3sub b a) 17 | repeat n 18 | collect (vec:3from a ba (rnd)))) 19 | 20 | (defun 3non-line* (n ab) 21 | (declare #.*opt-settings* (fixnum n) (list ab)) 22 | (apply #'3non-line n ab)) 23 | 24 | 25 | (declaim (inline -3in-box)) 26 | (defun -3in-box (sx sy sz) 27 | (declare #.*opt-settings* (double-float sx sy sz)) 28 | (vec:3vec (rnd* sx) (rnd* sy) (rnd* sz))) 29 | 30 | (defun 3in-box (sx sy sz &key (xy vec:*3zero*)) 31 | (declare #.*opt-settings* (double-float sx sy sz) (vec:3vec xy)) 32 | (vec:3add! (-3in-box sx sy sz) xy)) 33 | 34 | (defun 3in-cube (s &key (xy vec:*3zero*)) 35 | (declare #.*opt-settings* (double-float s) (vec:3vec xy)) 36 | (vec:3add! (-3in-box s s s) xy)) 37 | 38 | 39 | (defun 3nin-box (n sx sy sz &key (xy vec:*3zero*)) 40 | (declare #.*opt-settings* (fixnum n) (double-float sx sy sz) (vec:3vec xy)) 41 | (loop repeat n collect (3in-box sx sy sz :xy xy))) 42 | 43 | (defun 3nin-cube (n s &key (xy vec:*3zero*)) 44 | (declare #.*opt-settings* (fixnum n) (double-float s) (vec:3vec xy)) 45 | (loop repeat n collect (3in-cube s :xy xy))) 46 | 47 | 48 | (declaim (inline -3norm)) 49 | (defun -3norm (a b c) 50 | (declare #.*opt-settings* (double-float a b c)) 51 | (sqrt (+ (* a a) (* b b) (* c c)))) 52 | 53 | ; TODO: efficient non-sphere 54 | (declaim (inline 3on-sphere)) 55 | (defun 3on-sphere (&key (rad 1d0) (xy vec:*3zero*)) 56 | (declare #.*opt-settings* (double-float rad) (vec:3vec xy)) 57 | (multiple-value-bind (a b) (norm) 58 | (declare (double-float a b)) 59 | (let* ((c (norm)) 60 | (l (/ rad (-3norm a b c)))) 61 | (declare (double-float c l)) 62 | (vec:3vec (+ (vec:3vec-x xy) (* a l)) 63 | (+ (vec:3vec-y xy) (* b l)) 64 | (+ (vec:3vec-z xy) (* c l)))))) 65 | 66 | 67 | (declaim (inline 3in-sphere)) 68 | (defun 3in-sphere (&key (rad 1d0) (xy vec:*3zero*)) 69 | (declare #.*opt-settings* (double-float rad) (vec:3vec xy)) 70 | (loop with cand of-type vec:3vec = (-3in-box 1d0 1d0 1d0) 71 | until (< (vec:3len2 cand) 1d0) 72 | do (setf (vec:3vec-x cand) (rnd*) (vec:3vec-y cand) (rnd*) 73 | (vec:3vec-z cand) (rnd*)) 74 | finally (setf (vec:3vec-x cand) (+ (vec:3vec-x xy) 75 | (* (vec:3vec-x cand) rad)) 76 | (vec:3vec-y cand) (+ (vec:3vec-y xy) 77 | (* (vec:3vec-y cand) rad)) 78 | (vec:3vec-z cand) (+ (vec:3vec-z xy) 79 | (* (vec:3vec-z cand) rad))) 80 | (return cand))) 81 | 82 | -------------------------------------------------------------------------------- /src/rnd/extra.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | 5 | (declaim (inline -swap)) 6 | (defun -swap (a i j) 7 | (declare #.*opt-settings* (vector a) (fixnum i j)) 8 | (let ((tmp (aref a i))) 9 | (setf (aref a i) (aref a j) 10 | (aref a j) tmp))) 11 | 12 | ; https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle 13 | (defun shuffle (a &aux (a* (ensure-vector a)) (n (length a*))) 14 | (declare #.*opt-settings* (sequence a) (vector a*)) 15 | "shuffle a" 16 | (loop for i of-type fixnum from 0 to (- n 2) 17 | do (-swap a* i (rndrngi i n))) 18 | a*) 19 | 20 | 21 | (defun nrnd-u-from (n a) 22 | (declare #.*opt-settings* (fixnum n) (sequence a)) 23 | "n random distinct elements from a" 24 | (let* ((a* (ensure-vector a)) 25 | (resind nil) 26 | (anum (length (the vector a*)))) 27 | (when (> n anum) (error "not enough distinct elements in a.")) 28 | (loop until (>= (hset:num (hset:make :init resind)) n) 29 | do (setf resind (nrndi n anum))) 30 | (loop for i in resind collect (aref a* i)))) 31 | 32 | 33 | (defun nrnd-from (n a) 34 | (declare #.*opt-settings* (fixnum n) (sequence a)) 35 | "n random elements from a." 36 | (loop for i in (nrndi n (length a)) collect (aref a i))) 37 | 38 | 39 | (defun array-split (a p) 40 | (declare #.*opt-settings* (sequence a) (double-float p)) 41 | (let ((res (make-adjustable-vector))) 42 | (vextend (make-adjustable-vector :init (list (aref a 0))) res) 43 | (loop for i of-type fixnum from 1 below (length a) do 44 | (prob p (vextend (make-adjustable-vector :init (list (aref a i))) res) 45 | (vextend (aref a i) (aref res (1- (length res)))))) 46 | res)) 47 | 48 | 49 | ; SHAPES 50 | 51 | ; some version of mitchell's best candidate algorithm 52 | ; https://bl.ocks.org/mbostock/1893974/c5a39633db9c8b1f12c73b069e002c388d4cb9bf 53 | ; TODO: make n the max number instead of the new sample number 54 | (defun max-distance-sample (n fx &key (sample-num 50) (dstfx #'vec:dst2) 55 | (res (weir-utils:make-adjustable-vector))) 56 | (declare (fixnum n sample-num) (function fx dstfx) (array res)) 57 | " 58 | randomly sample a total of n items using (funcall fx sample-num), selecting 59 | the element furthest from existing elemets. 60 | example: 61 | 62 | (rnd:max-distance-sample 100 63 | (lambda (g) (rnd:nin-circ g 400d0))) 64 | " 65 | (labels ((-get-cand (c) (second (first c))) 66 | (-closest (res* c) (loop for v across res* 67 | minimizing (funcall dstfx v c)))) 68 | (loop with wanted-length of-type fixnum = (+ n (length res)) 69 | until (>= (length res) wanted-length) 70 | do (weir-utils:vextend 71 | (-get-cand (sort (loop for c in (funcall fx sample-num) 72 | collect (list (-closest res c) c)) 73 | #'> :key #'first)) 74 | res)) 75 | res)) 76 | 77 | 78 | ; TODO: this can be optimized 79 | (defun on-circ (rad &key (xy vec:*zero*)) 80 | (declare #.*opt-settings* (double-float rad) (vec:vec xy)) 81 | (vec:from xy (vec:cos-sin (rnd PII)) rad)) 82 | 83 | 84 | (defun non-circ (n rad &key (xy vec:*zero*)) 85 | (declare #.*opt-settings* (fixnum n) (double-float rad)) 86 | (loop repeat n collect (on-circ rad :xy xy))) 87 | 88 | 89 | (declaim (inline in-circ)) 90 | (defun in-circ (rad &key (xy vec:*zero*)) 91 | (declare #.*opt-settings* (double-float rad)) 92 | (let ((a (rnd)) 93 | (b (rnd))) 94 | (declare (double-float a b)) 95 | (if (< a b) (setf a (* PII (/ a b)) b (* b rad)) 96 | (let ((d a)) (setf a (* PII (/ b a)) b (* d rad)))) 97 | (vec:vec (+ (vec:vec-x xy) (* (cos a) b)) 98 | (+ (vec:vec-y xy) (* (sin a) b))))) 99 | 100 | 101 | (defun nin-circ (n rad &key (xy vec:*zero*)) 102 | (declare #.*opt-settings* (fixnum n) (double-float rad)) 103 | (loop repeat n collect (in-circ rad :xy xy))) 104 | 105 | 106 | (declaim (inline in-rect)) 107 | (defun in-rect (sx sy &key (xy vec:*zero*)) 108 | (declare #.*opt-settings* (double-float sx sy) (vec:vec xy)) 109 | (vec:vec (+ (vec:vec-x xy) (rnd* sx)) 110 | (+ (vec:vec-y xy) (rnd* sy)))) 111 | 112 | (defun in-square (s &key (xy vec:*zero*)) 113 | (declare #.*opt-settings* (double-float s) (vec:vec xy)) 114 | (vec:vec (+ (vec:vec-x xy) (rnd* s)) 115 | (+ (vec:vec-y xy) (rnd* s)))) 116 | 117 | 118 | (defun nin-rect (n sx sy &key (xy vec:*zero*)) 119 | (declare #.*opt-settings* (fixnum n) (double-float sx sy) (vec:vec xy)) 120 | (loop repeat n collect (in-rect sx sy :xy xy))) 121 | 122 | (defun nin-square (n s &key (xy vec:*zero*)) 123 | (declare #.*opt-settings* (fixnum n) (double-float s) (vec:vec xy)) 124 | (loop repeat n collect (in-square s :xy xy))) 125 | 126 | 127 | ;TODO: improve. avoid extra vec creation 128 | (defun on-line (a b) 129 | (declare #.*opt-settings* (vec:vec a b)) 130 | (vec:from a (vec:sub b a) (rnd))) 131 | 132 | (defun on-line* (ab) 133 | (declare #.*opt-settings* (list ab)) 134 | (apply #'on-line ab)) 135 | 136 | 137 | ;TODO: improve. avoid extra vec creation 138 | (defun non-line (n a b) 139 | (declare #.*opt-settings* (fixnum n) (vec:vec a b)) 140 | (loop with ba = (vec:sub b a) 141 | repeat n 142 | collect (vec:from a ba (rnd)))) 143 | 144 | (defun non-line* (n ab) 145 | (declare #.*opt-settings* (fixnum n) (list ab)) 146 | (apply #'non-line n ab)) 147 | 148 | 149 | (defmacro with-in-circ ((n rad v &key xy) &body body) 150 | (declare (symbol v)) 151 | (alexandria:with-gensyms (rad* xy* m) 152 | `(let* ((,rad* ,rad) 153 | (,xy* ,xy) 154 | (,m (if ,xy* ,xy* vec:*zero*))) 155 | (declare (vec:vec ,m)) 156 | (loop repeat ,n 157 | do (let ((,v (in-circ ,rad* :xy ,m))) 158 | (declare (vec:vec ,v)) 159 | (progn ,@body)))))) 160 | 161 | (defmacro with-in-rect ((n sx sy v &key xy) &body body) 162 | (declare (symbol v)) 163 | (alexandria:with-gensyms (sx* sy* xy* m) 164 | `(let* ((,sx* ,sx) 165 | (,sy* ,sy) 166 | (,xy* ,xy) 167 | (,m (if ,xy* ,xy* vec:*zero*))) 168 | (declare (vec:vec ,m)) 169 | (loop repeat ,n 170 | do (let ((,v (in-rect ,sx* ,sy* :xy ,m))) 171 | (declare (vec:vec ,v)) 172 | (progn ,@body)))))) 173 | 174 | (defmacro with-on-line ((n a b rn) &body body) 175 | (declare (symbol rn)) 176 | (alexandria:with-gensyms (sub a*) 177 | `(let* ((,a* ,a) 178 | (,sub (vec:sub ,b ,a*))) 179 | (loop repeat ,n 180 | do (let ((,rn (vec:from ,a* ,sub (rnd)))) 181 | (declare (vec:vec ,rn)) 182 | (progn ,@body)))))) 183 | 184 | -------------------------------------------------------------------------------- /src/rnd/rnd.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | (deftype pos-double () `(double-float 0d0 *)) 5 | 6 | (defconstant PII (* PI 2d0)) 7 | 8 | 9 | (defun set-rnd-state (i) 10 | (declare (fixnum i)) 11 | #+SBCL ; this is called feature expressions 12 | (setf *random-state* (sb-ext:seed-random-state i)) 13 | 14 | #+(not SBCL) 15 | (warn "rnd:state is only implemented for SBCL. see src/rnd.lisp 16 | to implement state for your environment.")) 17 | 18 | 19 | (defun make-rnd-state () 20 | (setf *random-state* (make-random-state t))) 21 | 22 | 23 | ; NUMBERS AND RANGES 24 | 25 | (declaim (inline rndi)) 26 | (defun rndi (a) 27 | (declare (fixnum a)) 28 | (the fixnum (random a))) 29 | 30 | (declaim (inline nrndi)) 31 | (defun nrndi (n a) 32 | (declare (fixnum n a)) 33 | (loop repeat n collect (rndi a) of-type fixnum)) 34 | 35 | 36 | (declaim (inline rndrngi)) 37 | (defun rndrngi (a b) 38 | (declare (fixnum a b)) 39 | (+ a (rndi (- b a)))) 40 | 41 | (declaim (inline nrndrngi)) 42 | (defun nrndrngi (n a b) 43 | (declare (fixnum n a b)) 44 | (let ((d (- b a))) 45 | (declare (fixnum d)) 46 | (loop repeat n collect (+ a (rndi d)) of-type fixnum))) 47 | 48 | 49 | (declaim (inline rnd)) 50 | (defun rnd (&optional (x 1d0)) 51 | (declare #.*opt-settings* (double-float x)) 52 | (random x)) 53 | 54 | (declaim (inline nrnd)) 55 | (defun nrnd (n &optional (x 1d0)) 56 | (declare #.*opt-settings* (fixnum n) (double-float x)) 57 | (loop repeat n collect (rnd x) of-type double-float)) 58 | 59 | 60 | (declaim (inline rnd*)) 61 | (defun rnd* (&optional (x 1d0)) 62 | (declare #.*opt-settings* (double-float x)) 63 | (- x (rnd (* 2d0 x)))) 64 | 65 | (declaim (inline nrnd*)) 66 | (defun nrnd* (n &optional (x 1d0)) 67 | (declare #.*opt-settings* (fixnum n) (double-float x)) 68 | (loop repeat n collect (rnd* x) of-type double-float)) 69 | 70 | 71 | (declaim (inline rndrng)) 72 | (defun rndrng (a b) 73 | (declare #.*opt-settings* (double-float a b)) 74 | (+ a (rnd (- b a)))) 75 | 76 | (declaim (inline nrndrng)) 77 | (defun nrndrng (n a b) 78 | (declare #.*opt-settings* (fixnum n) (double-float a b)) 79 | (loop repeat n collect (rndrng a b) of-type double-float)) 80 | 81 | 82 | ; https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform 83 | (declaim (inline norm)) 84 | (defun norm (&key (mu 0d0) (sigma 1d0)) 85 | "box-muller transform" 86 | (declare (double-float mu sigma)) 87 | (let ((s (* sigma (the double-float 88 | (sqrt (the pos-double 89 | (* -2d0 (log (rnd)))))))) 90 | (u (* PII (rnd)))) 91 | (declare (double-float s u)) 92 | (values (+ mu (* s (cos u))) 93 | (+ mu (* s (sin u)))))) 94 | 95 | 96 | ; MACROS 97 | 98 | 99 | (defmacro prob (p a &optional b) 100 | "executes body with probability p" 101 | `(if (< (rnd) (the double-float ,p)) ,a ,b)) 102 | 103 | 104 | (defmacro either (a b) 105 | "excecutes either a or b, with a probablility of 0.5" 106 | `(prob 0.5d0 ,a ,b)) 107 | 108 | 109 | (defmacro rcond (&rest clauses) 110 | " 111 | executes the forms in clauses according to the weighted sum of 112 | all p1, p2 ... 113 | clauses should be on this form: 114 | ((p1 form) (p2 form) ...) 115 | " 116 | (alexandria:with-gensyms (val) 117 | (let* ((tot 0d0) 118 | (clauses* (loop for (p . body) in clauses 119 | do (incf tot (the double-float p)) 120 | collect `((< ,val ,tot) ,@body)))) 121 | (declare (double-float tot) (list clauses*)) 122 | `(let ((,val (rnd ,tot))) 123 | (declare (double-float ,val)) 124 | (cond ,@clauses*))))) 125 | 126 | 127 | (defmacro rep (n &body body) 128 | "repeat body at most n-1 times" 129 | `(loop repeat (rndi (the fixnum ,n)) do (progn ,@body))) 130 | 131 | 132 | (defmacro reprng (a b &body body) 133 | "repeat body between [a b) times" 134 | `(loop repeat (rndrngi ,a ,b) do (progn ,@body))) 135 | 136 | 137 | ; TODO: refactor 138 | (defmacro with-rndspace ((n a b rn &key collect) &body body) 139 | "repeat body where rn is n numbers between (a b)" 140 | (declare (symbol rn)) 141 | (alexandria:with-gensyms (d a*) 142 | `(let* ((,a* ,a) 143 | (,d (- ,b ,a*))) 144 | (declare (double-float ,a* ,d)) 145 | (loop repeat ,n ,(if collect 'collect 'do) 146 | (let ((,rn (+ ,a* (rnd ,d)))) 147 | (declare (double-float ,rn)) 148 | (progn ,@body)))))) 149 | 150 | 151 | ; GENERIC 152 | 153 | (defun rndget (l) 154 | (declare #.*opt-settings* (sequence l)) 155 | (if (eql (type-of l) 'cons) (nth (rndi (length l)) l) 156 | (aref l (rndi (length l))))) 157 | 158 | (declaim (inline probsel)) 159 | (defun probsel (p a &aux (a* (ensure-vector a))) 160 | (declare #.*opt-settings* (sequence a) (double-float p)) 161 | (loop with res of-type vector = (make-adjustable-vector) 162 | for e across a* 163 | do (prob p (vextend e res)) 164 | finally (return res))) 165 | 166 | 167 | (defmacro -nrep (n &body body) 168 | (alexandria:with-gensyms (nname) 169 | `(let ((,nname ,n)) 170 | (loop repeat ,nname collect (progn ,@body))))) 171 | 172 | 173 | (declaim (inline rndspace)) 174 | (defun rndspace (n a b &key order &aux (d (- b a))) 175 | (declare #.*opt-settings* (fixnum n) (double-float a b d)) 176 | (if order (sort (the list (-nrep n (+ a (rnd d)))) #'<) 177 | (-nrep n (+ a (rnd d))))) 178 | 179 | 180 | (declaim (inline rndspacei)) 181 | (defun rndspacei (n a b &key order &aux (d (- b a))) 182 | (declare #.*opt-settings* (fixnum n a b d)) 183 | (if order (sort (-nrep n (+ a (rndi d))) #'<) 184 | (-nrep n (+ a (rndi d))))) 185 | 186 | 187 | (declaim (inline bernoulli)) 188 | (defun bernoulli (n p) 189 | (declare #.*opt-settings* (fixnum n) (double-float p)) 190 | (loop repeat n collect (prob p 1d0 0d0) of-type double-float)) 191 | 192 | -------------------------------------------------------------------------------- /src/rnd/walkers.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | 5 | (defun get-lin-walk (&key (x 0d0)) 6 | (declare #.*opt-settings* (double-float x)) 7 | "linear random walker" 8 | (lambda (s) (declare (double-float s)) 9 | (incf x (rnd* s)))) 10 | 11 | 12 | (defun get-lin-walk* (&key (x 0d0)) 13 | (declare #.*opt-settings* (double-float x)) 14 | "linear random walker limited to (0 1)" 15 | (lambda (s) (declare (double-float s)) 16 | (setf x (math:dmod x (rnd* s) 1d0)))) 17 | 18 | 19 | (defun get-acc-lin-walk (&key (x 0d0) (a 0d0)) 20 | (declare #.*opt-settings* (double-float x a)) 21 | "accelerated linear random walker" 22 | (lambda (s) (declare (double-float s)) 23 | (incf x (incf a (rnd* s))))) 24 | 25 | 26 | (defun get-acc-lin-walk* (&key (x 0d0) (a 0d0)) 27 | (declare #.*opt-settings* (double-float x a)) 28 | "accelerated linear random walker limited to (0 1)" 29 | (lambda (s) (declare (double-float s)) 30 | (setf x (math:dmod x (incf a (rnd* s)) 1d0)))) 31 | 32 | 33 | (defun get-circ-walk (&key (xy vec:*zero*)) 34 | (declare #.*opt-settings* (vec:vec xy)) 35 | "random 2d walker" 36 | (lambda (s) (declare (double-float s)) 37 | (setf xy (vec:add xy (in-circ s))))) 38 | 39 | 40 | (defun get-acc-circ-walk (&key (xy vec:*zero*) (a vec:*zero*)) 41 | (declare #.*opt-settings* (vec:vec xy a)) 42 | "random accelerated 2d walker" 43 | (lambda (s) (declare (double-float s)) 44 | (setf xy (vec:add xy (setf a (vec:add a (in-circ s))))))) 45 | 46 | 47 | ; 3D 48 | 49 | (defun 3get-sphere-walk (&key (xy vec:*3zero*)) 50 | (declare #.*opt-settings* (vec:3vec xy)) 51 | "random 3d walker" 52 | (lambda (s) (declare (double-float s)) 53 | (setf xy (vec:3add xy (3in-sphere :rad s))))) 54 | 55 | 56 | (defun 3get-acc-sphere-walk (&key (xy vec:*3zero*) (a vec:*3zero*)) 57 | (declare #.*opt-settings* (vec:3vec xy a)) 58 | "random accelerated 3d walker" 59 | (lambda (s) (declare (double-float s)) 60 | (setf xy (vec:3add xy (setf a (vec:3add a (3in-sphere :rad s))))))) 61 | 62 | -------------------------------------------------------------------------------- /src/state.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :state) 3 | 4 | 5 | (defmacro awith ((st k &key default) &body body) 6 | " 7 | access key of state as state::it, 8 | the final form of body is assigned to state key of state 9 | " 10 | (alexandria:with-gensyms (sname kname res dname s) 11 | `(let* ((,sname ,st) 12 | (,dname ,default) 13 | (,kname ,k) 14 | (,s (state-s ,sname)) 15 | (it (gethash ,kname (state-s ,sname) ,dname)) 16 | (,res (progn ,@body))) 17 | (setf (sget ,sname ,kname) ,res)))) 18 | 19 | 20 | (defstruct (state (:constructor make ())) 21 | (s (make-hash-table :test #'equal) :type hash-table)) 22 | 23 | (defun sget (st k &key default) 24 | "get k of state (or default)" 25 | (declare (state st)) 26 | (gethash k (state-s st) default)) 27 | 28 | (defun -sset (st k v) 29 | "set k of st to v, returns v" 30 | (declare (state st)) 31 | (setf (gethash k (state-s st)) v)) 32 | 33 | (defsetf sget -sset) 34 | 35 | (defun lget (st keys &key default) 36 | "get keys of state (or default)" 37 | (declare (state st) (list keys)) 38 | (loop for k in keys collect (sget st k :default default))) 39 | 40 | (defun lset (st keys v) 41 | "set keys of st to v. returns keys" 42 | (declare (state st) (list keys)) 43 | (loop for k in keys do (setf (sget st k) v))) 44 | 45 | (defun to-list (st) 46 | (declare (state st)) 47 | (loop for k being the hash-keys of (state-s st) using (hash-value v) 48 | collect (list k v))) 49 | 50 | -------------------------------------------------------------------------------- /src/various.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weir-utils) 3 | 4 | (defvar *opt-settings* '(optimize (safety 1) (speed 3) (debug 2) (space 2))) 5 | 6 | 7 | (declaim (type double-float PI* PII PI5)) 8 | 9 | ; changed based on comment in this PR: 10 | ; https://github.com/inconvergent/weir/pull/2 11 | (defconstant PI* #.(coerce pi 'double-float)) 12 | (defconstant PII #.(coerce (* pi 2d0) 'double-float)) 13 | (defconstant PI5 #.(coerce (* pi 0.5d0) 'double-float)) 14 | 15 | (defun v? (&optional silent) 16 | (if silent (slot-value (asdf:find-system 'weir) 'asdf:version) 17 | (format t "~%weir version: ~a~%" 18 | (slot-value (asdf:find-system 'weir) 'asdf:version)))) 19 | 20 | 21 | (defun f? (f) 22 | (declare (symbol f)) 23 | (format t "~%---~%") 24 | (describe f) 25 | (format t "~%---~%") ) 26 | 27 | (defun i? (f) (inspect f)) 28 | 29 | 30 | ;http://cl-cookbook.sourceforge.net/os.html 31 | (defun cmd-args () 32 | (or #+SBCL sb-ext:*posix-argv* 33 | #+LISPWORKS system:*line-arguments-list* 34 | #+CMU extensions:*command-line-words* 35 | nil)) 36 | 37 | 38 | ;https://www.rosettacode.org/wiki/Program_termination#Common_Lisp 39 | (defun terminate (status) 40 | (format t "~%terminated with status: ~a~%" status) 41 | #+sbcl (sb-ext:quit :unix-status status) 42 | #+ccl (ccl:quit status) 43 | #+clisp (ext:quit status) 44 | #+cmu (unix:unix-exit status) 45 | #+abcl (ext:quit:status status) 46 | #+allegro (excl:exit status :quiet t) 47 | #+gcl (common-lisp-user::bye status) 48 | #+ecl (ext:quit status)) 49 | 50 | 51 | ;https://github.com/inconvergent/weir/pull/1/commits/4a1df51914800c78cb34e8194222185ebde12388 52 | (defmacro define-struct-load-form (struct-name) 53 | "Allow the structure named STRUCT-NAME to be dumped to FASL files." 54 | `(defmethod make-load-form ((obj ,struct-name) &optional env) 55 | (make-load-form-saving-slots obj :environment env))) 56 | 57 | 58 | ;from on lisp by pg 59 | (defmacro aif (test-form then-form &optional else-form) 60 | `(let ((it ,test-form)) 61 | (if it ,then-form ,else-form))) 62 | 63 | 64 | ;from on lisp by pg 65 | (defmacro abbrev (short long) 66 | `(defmacro ,short (&rest args) 67 | `(,',long ,@args))) 68 | 69 | 70 | ;from on lisp by pg 71 | (defun mkstr (&rest args) 72 | (with-output-to-string (s) 73 | (dolist (a args) (princ a s)))) 74 | 75 | 76 | ;from on lisp by pg 77 | (defmacro mac (expr) `(pprint (macroexpand-1 ',expr))) 78 | 79 | 80 | ;https://gist.github.com/lispm/6ed292af4118077b140df5d1012ca646 81 | (defun psymb (package &rest args) 82 | (values (intern (apply #'mkstr args) package))) 83 | 84 | 85 | ;https://gist.github.com/lispm/6ed292af4118077b140df5d1012ca646 86 | (defmacro with-struct ((name . fields) struct &body body) 87 | (let ((gs (gensym))) 88 | `(let ((,gs ,struct)) 89 | (let ,(mapcar #'(lambda (f) 90 | `(,f (,(psymb (symbol-package name) name f) ,gs))) 91 | fields) 92 | ,@body)))) 93 | 94 | 95 | (defun append-postfix (fn postfix) 96 | (declare (string fn postfix)) 97 | (concatenate 'string fn postfix)) 98 | 99 | 100 | (defun append-number (fn i) 101 | (declare (string fn) (fixnum i)) 102 | (format nil "~a-~8,'0d" fn i)) 103 | 104 | 105 | (defun ensure-filename (fn &optional (postfix "") (silent nil)) 106 | (let ((fn* (append-postfix (if fn fn "tmp") postfix))) 107 | (declare (string fn*)) 108 | (format (not silent) "~%file: ~a~%~%" fn*) 109 | fn*)) 110 | 111 | 112 | (defun print-every (i &optional (n 1)) 113 | (declare (fixnum i n)) 114 | (when (= 0 (mod i n)) (format t "~%itt: ~a~%" i))) 115 | 116 | 117 | (defun string-list-concat (l) 118 | (declare (list l)) 119 | (format nil "~{~a~}" l)) 120 | 121 | 122 | (defun numshow (a &key (ten 6) (prec 6)) 123 | (declare (double-float a)) 124 | (let ((show (format nil "~~,~af" prec))) 125 | (if (< 1d-6 (the double-float (abs a)) (expt 10 ten)) 126 | (format nil show a) 127 | (format nil "~,1e" a)))) 128 | 129 | 130 | (abbrev vextend vector-push-extend) 131 | 132 | (defun lvextend (xx arr) 133 | (declare (sequence xx) (vector arr)) 134 | (typecase xx (cons (loop for x in xx do (vextend x arr))) 135 | (t (loop for x across xx do (vextend x arr))))) 136 | 137 | 138 | (declaim (inline vector-last)) 139 | (defun vector-last (a) 140 | (declare (vector a)) 141 | (aref a (1- (the fixnum (length a))))) 142 | 143 | 144 | (declaim (inline vector-first)) 145 | (defun vector-first (a) 146 | (declare (vector a)) 147 | (aref a 0)) 148 | 149 | 150 | (defun make-adjustable-vector (&key init (type t) (size 128)) 151 | (let ((res (if init (make-array (length init) :fill-pointer 0 152 | :initial-contents init 153 | :element-type type 154 | :adjustable t) 155 | (make-array size :fill-pointer 0 156 | :element-type type 157 | :adjustable t)))) 158 | (when init (lvextend init res)) 159 | res)) 160 | 161 | 162 | (declaim (inline to-vector)) 163 | (defun to-vector (init &key (type t)) 164 | (declare (list init)) 165 | (make-array (length init) :initial-contents init 166 | :adjustable nil 167 | :element-type type)) 168 | 169 | 170 | (declaim (inline ensure-vector)) 171 | (defun ensure-vector (o &key (type t)) 172 | (declare (sequence o)) 173 | (typecase o (cons (to-vector o :type type)) 174 | (t o))) 175 | 176 | 177 | (defun to-adjustable-vector (init &key (type t)) 178 | (declare (sequence init)) 179 | (make-array (length init) :fill-pointer t 180 | :initial-contents init 181 | :element-type type 182 | :adjustable t)) 183 | 184 | 185 | (declaim (inline to-list)) 186 | (defun to-list (a) 187 | (declare (sequence a)) 188 | (coerce a 'list)) 189 | 190 | (defun undup (e) (delete-duplicates (alexandria:flatten e))) 191 | 192 | (defun internal-path-string (path) 193 | (declare (string path)) 194 | (namestring (asdf:system-relative-pathname :weir path))) 195 | 196 | -------------------------------------------------------------------------------- /src/vec/checks.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :vec) 3 | 4 | 5 | (declaim (inline ptinside)) 6 | (defun ptinside (convex v) 7 | (declare #.*opt-settings* (list convex) (vec v)) 8 | (loop with convex* = (math:close-path* convex) 9 | for a of-type vec in convex* 10 | and b of-type vec in (cdr convex*) 11 | always (>= (cross (sub b a) (sub v b)) 0d0))) 12 | 13 | 14 | (declaim (inline segdst)) 15 | (defun segdst (line v) 16 | " 17 | find distance between line and v. 18 | returns values (distance s) where is is the interpolation value that will 19 | yield the closest point on line. 20 | " 21 | (declare #.*opt-settings* (list line) (vec v)) 22 | (destructuring-bind (va vb) line 23 | (declare (vec va vb)) 24 | (let ((l2 (dst2 va vb))) 25 | (declare (double-float l2)) 26 | (if (<= l2 0d0) 27 | ; line is a point 28 | (values (dst va v) 0d0) 29 | ; else 30 | (let ((tt (/ (+ (* (- (vec-x v) (vec-x va)) (- (vec-x vb) (vec-x va))) 31 | (* (- (vec-y v) (vec-y va)) (- (vec-y vb) (vec-y va)))) 32 | l2))) 33 | (if (> tt 1d0) (setf tt 1d0)) 34 | (if (< tt 0d0) (setf tt 0d0)) 35 | (values (dst v (on-line tt va vb)) tt)))))) 36 | 37 | 38 | ; TODO: this is slowish 39 | (declaim (inline segx)) 40 | (defun segx (aa bb) 41 | (declare #.*opt-settings* (list aa bb)) 42 | " 43 | find intersection between lines aa, bb. 44 | returns isect? p q where p and q is the distance along each line to the 45 | intersection point 46 | " 47 | (destructuring-bind (a1 a2) aa 48 | (declare (vec a1 a2)) 49 | (destructuring-bind (b1 b2) bb 50 | (declare (vec b1 b2)) 51 | (let* ((sa (sub a2 a1)) 52 | (sb (sub b2 b1)) 53 | (u (cross sa sb))) 54 | (declare (vec sa sb) (double-float u)) 55 | (if (<= (abs u) 0d0) 56 | ; return nil if the lines are parallel (nil) 57 | ; this is just a div0 guard. it's not a good way to test. 58 | (values nil 0d0 0d0) 59 | ; otherwise check if they intersect 60 | (let* ((ab (sub a1 b1)) 61 | (p (/ (cross sa ab) u)) 62 | (q (/ (cross sb ab) u))) 63 | (declare (vec ab) (double-float p q)) 64 | ; t if intersection, nil otherwise 65 | (values (and (> p 0d0) (< p 1d0) (> q 0d0) (< q 1d0)) 66 | q p))))))) 67 | 68 | 69 | (deftype array-list () `(simple-array list)) 70 | 71 | (declaim (inline -sweep-line)) 72 | (defun -sweep-line (lines line-points) 73 | (declare #.*opt-settings* (array-list lines) (list line-points)) 74 | "perform sweep line search for intersections along x" 75 | ; add first line index to sweep line state, 76 | ; and set sweep line position 77 | ; TODO: special cases: equal x pos, vertical line 78 | (let ((res (make-array (length lines) :element-type 'list 79 | :initial-element nil 80 | :adjustable nil)) 81 | (q (hset:make :init (list (cdar line-points))))) 82 | (declare (type (simple-array list) res) (hash-table q)) 83 | 84 | (labels 85 | ((-append (i c p) 86 | (declare (fixnum i c) (double-float p)) 87 | (if (aref res i) (push `(,c . ,p) (aref res i)) 88 | (setf (aref res i) `((,c . ,p))))) 89 | 90 | (-isects (i cands) 91 | (declare (fixnum i) (list cands)) 92 | "intersection test" 93 | ; TODO: avoid calling segx, i think this can be improved. 94 | (loop with line of-type list = (aref lines i) 95 | for c of-type fixnum in cands 96 | do (multiple-value-bind (x p qq) (segx line (aref lines c)) 97 | (when x (-append i c p) 98 | (-append c i qq)))))) 99 | 100 | (loop for (_ . i) of-type (double-float . fixnum) in (cdr line-points) 101 | ; if i in q, kick i out of q, 102 | if (hset:mem q i) do (hset:del q i) 103 | ; else check i against all q, add i to q 104 | else do (-isects i (hset:to-list q)) 105 | (hset:add q i))) 106 | res)) 107 | 108 | (declaim (inline -sorted-point-pairs)) 109 | (defun -sorted-point-pairs (lines) 110 | (declare #.*opt-settings* (array-list lines)) 111 | (loop with res of-type list = (list) 112 | for (a b) of-type (vec vec) across lines 113 | for i of-type fixnum from 0 114 | do (push `(,(vec-x a) . ,i) res) 115 | (push `(,(vec-x b) . ,i) res) 116 | finally (return (sort res #'< :key #'car)))) 117 | 118 | (defun lsegx (lines*) 119 | (declare (sequence lines*)) 120 | " 121 | not entirely slow line-line intersection for all lines. this is faster than 122 | comparing all lines when lines are short relative to the area that the lines 123 | cover. it can be improved further by using binary search tree to store 124 | current state. 125 | " 126 | (let ((lines (if (listp lines*) (weir-utils:to-vector lines* :type 'list) 127 | lines*))) 128 | (declare (array-list lines)) 129 | (-sweep-line lines (-sorted-point-pairs lines)))) 130 | 131 | -------------------------------------------------------------------------------- /src/weir/3alterations.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weir) 2 | 3 | (declaim (inline 3add-vert?)) 4 | (defun 3add-vert? (xy) 5 | "add new vert at xy. returns the new vert ind" 6 | (declare (vec:3vec xy)) 7 | (lambda (wer) (3add-vert! wer xy))) 8 | 9 | 10 | (declaim (inline 3vadd-edge?)) 11 | (defun 3vadd-edge? (xya xyb &key g) 12 | "add verts xya and xyb, and creates an edge (in grp g) between them" 13 | (declare (vec:3vec xya xyb)) 14 | (lambda (wer) 15 | (add-edge! wer (add-vert! wer xya) (add-vert! wer xyb) :g g))) 16 | 17 | 18 | (declaim (inline 3move-vert?)) 19 | (defun 3move-vert? (v xy &key (rel t)) 20 | " 21 | move vert v. 22 | if rel: move relative to original position. 23 | else: move to xy. 24 | " 25 | (declare (pos-int v) (vec:3vec xy) (boolean rel)) 26 | (lambda (wer) 27 | (-valid-vert ((weir-num-verts wer) v :err nil) 28 | (3move-vert! wer v xy :rel rel :ret t)))) 29 | 30 | 31 | (declaim (inline 3append-edge?)) 32 | (defun 3append-edge? (v xy &key (rel t) g) 33 | "add edge between vert v and new vert xy" 34 | (declare (pos-int v) (vec:3vec xy) (boolean rel)) 35 | (lambda (wer) 36 | (-valid-vert ((weir-num-verts wer) v :err nil) 37 | (let ((w (if rel (3add-vert! wer (vec:3add (3get-vert wer v) xy)) 38 | (3add-vert! wer xy)))) 39 | (declare (pos-int w)) 40 | (add-edge! wer v w :g g) 41 | w)))) 42 | 43 | 44 | (declaim (inline 3add-edge?)) 45 | (defun 3add-edge? (v w &key g) 46 | "create edge between valid verts v and w (in grp g)" 47 | (declare (pos-int v w)) 48 | (lambda (wer) 49 | (-valid-vert ((weir-num-verts wer) v :err nil) 50 | (-valid-vert ((weir-num-verts wer) w :err nil) 51 | (ladd-edge! wer (list v w) :g g))))) 52 | 53 | (declaim (inline ladd-edge?)) 54 | (defun 3ladd-edge? (ll &key g) 55 | (destructuring-bind (a b) ll 56 | (declare (pos-int a b)) 57 | (add-edge? a b :g g))) 58 | 59 | 60 | (declaim (inline 3del-edge?)) 61 | (defun 3del-edge? (v w &key g) 62 | "del edge (v w) (of grp g)" 63 | (declare (pos-int v w)) 64 | (lambda (wer) 65 | (del-edge! wer v w :g g))) 66 | 67 | (declaim (inline ldel-edge?)) 68 | (defun 3ldel-edge? (ll &key g) 69 | (declare (list ll)) 70 | (destructuring-bind (a b) ll 71 | (declare (pos-int a b)) 72 | (del-edge? a b :g g))) 73 | 74 | 75 | (declaim (inline 3add-path?)) 76 | (defun 3add-path? (points &key g closed) 77 | (declare (list points) (boolean closed)) 78 | (lambda (wer) (3add-path! wer points :g g :closed closed))) 79 | 80 | 81 | (declaim (inline 3split-edge?)) 82 | (defun 3split-edge? (v w &key xy g) 83 | " 84 | insert a vert, v, on edge e = (v w) such that we get edges (a v) and (v b). 85 | v will be positioned at xy. returns the new edges (or nil). 86 | " 87 | (declare (pos-int v w)) 88 | (lambda (wer) 89 | (when (edge-exists wer (list v w) :g g) 90 | (3split-edge! wer v w :xy xy :g g)))) 91 | 92 | (declaim (inline lsplit-edge?)) 93 | (defun 3lsplit-edge? (ll &key xy g) 94 | (declare (list ll)) 95 | (destructuring-bind (a b) ll 96 | (declare (pos-int a b)) 97 | (3split-edge? a b :xy xy :g g))) 98 | 99 | -------------------------------------------------------------------------------- /src/weir/alterations.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (declaim (inline add-grp?)) 6 | (defun add-grp? (&key name type) 7 | (lambda (wer) (add-grp! wer :name name :type type))) 8 | 9 | 10 | (declaim (inline add-vert?)) 11 | (defun add-vert? (xy) 12 | (declare (vec:vec xy)) 13 | "add new vert at xy. returns the new vert ind" 14 | (lambda (wer) (add-vert! wer xy))) 15 | 16 | 17 | (declaim (inline vadd-edge?)) 18 | (defun vadd-edge? (xya xyb &key g) 19 | (declare (vec:vec xya xyb)) 20 | "add verts xya and xyb, and creates an edge (in grp g) between them" 21 | (lambda (wer) (add-edge! wer (add-vert! wer xya) (add-vert! wer xyb) :g g))) 22 | 23 | 24 | (declaim (inline move-vert?)) 25 | (defun move-vert? (v xy &key (rel t)) 26 | (declare (pos-int v) (vec:vec xy) (boolean rel)) 27 | " 28 | move vert v. 29 | if rel: move relative to original position. 30 | else: move to xy. 31 | " 32 | (lambda (wer) 33 | (-valid-vert ((weir-num-verts wer) v :err nil) 34 | (move-vert! wer v xy :rel rel :ret t)))) 35 | 36 | 37 | (declaim (inline append-edge?)) 38 | (defun append-edge? (v xy &key (rel t) g) 39 | (declare (pos-int v) (vec:vec xy) (boolean rel)) 40 | "add edge between vert v and new vert at xy" 41 | (lambda (wer) 42 | (-valid-vert ((weir-num-verts wer) v :err nil) 43 | (let ((w (if rel (add-vert! wer (vec:add (get-vert wer v) xy)) 44 | (add-vert! wer xy)))) 45 | (declare (pos-int w)) 46 | (add-edge! wer v w :g g) 47 | w)))) 48 | 49 | 50 | (declaim (inline add-edge?)) 51 | (defun add-edge? (v w &key g) 52 | (declare (pos-int v w)) 53 | "create edge between valid verts v and w (in grp g)" 54 | (lambda (wer) 55 | (-valid-vert ((weir-num-verts wer) v :err nil) 56 | (-valid-vert ((weir-num-verts wer) w :err nil) 57 | (ladd-edge! wer (list v w) :g g))))) 58 | 59 | (declaim (inline ladd-edge?)) 60 | (defun ladd-edge? (ll &key g) 61 | (destructuring-bind (a b) ll 62 | (declare (pos-int a b)) 63 | (add-edge? a b :g g))) 64 | 65 | 66 | (declaim (inline del-edge?)) 67 | (defun del-edge? (v w &key g) 68 | (declare (pos-int v w)) 69 | "del edge (v w) (of grp g)" 70 | (lambda (wer) (del-edge! wer v w :g g))) 71 | 72 | (declaim (inline ldel-edge?)) 73 | (defun ldel-edge? (ll &key g) 74 | (declare (list ll)) 75 | (destructuring-bind (a b) ll 76 | (declare (pos-int a b)) 77 | (del-edge? a b :g g))) 78 | 79 | 80 | (declaim (inline add-path?)) 81 | (defun add-path? (points &key g closed) 82 | (declare (list points) (boolean closed)) 83 | (lambda (wer) (add-path! wer points :g g :closed closed))) 84 | 85 | 86 | (declaim (inline split-edge-ind?)) 87 | (defun split-edge-ind? (v w &key via g) 88 | (declare (pos-int v w via)) 89 | "del edge (v w), add edges ((v via) (w via)) (of grp g)" 90 | (lambda (wer) (split-edge-ind! wer v w :via via :g g))) 91 | 92 | (declaim (inline lsplit-edge-ind?)) 93 | (defun lsplit-edge-ind? (ll &key via g) 94 | (declare (list ll) (pos-int via)) 95 | (destructuring-bind (a b) ll 96 | (declare (pos-int a b)) 97 | (split-edge-ind? a b :via via :g g))) 98 | 99 | 100 | (declaim (inline split-edge?)) 101 | (defun split-edge? (v w &key xy g) 102 | (declare (pos-int v w)) 103 | " 104 | insert a vert, v, on edge e = (v w) such that we get edges (a v) and (v b). 105 | v will be positioned at xy. returns the new edges (or nil). 106 | " 107 | (lambda (wer) 108 | (when (edge-exists wer (list v w) :g g) 109 | (split-edge! wer v w :xy xy :g g)))) 110 | 111 | (declaim (inline lsplit-edge?)) 112 | (defun lsplit-edge? (ll &key xy g) 113 | (declare (list ll)) 114 | (destructuring-bind (a b) ll 115 | (declare (pos-int a b)) 116 | (split-edge? a b :xy xy :g g))) 117 | 118 | 119 | (defun set-edge-prop? (edge prop &optional (val t)) 120 | (declare (list edge) (symbol prop)) 121 | (lambda (wer) (setf (get-edge-prop wer edge prop) val))) 122 | 123 | (defun lset-edge-prop? (edges prop &optional (val t)) 124 | (declare (list edges) (symbol prop)) 125 | (lambda (wer) (lset-edge-prop wer edges prop val))) 126 | 127 | 128 | (defun set-vert-prop? (v prop &optional (val t)) 129 | (declare (fixnum v) (symbol prop)) 130 | (lambda (wer) (setf (get-vert-prop wer v prop) val))) 131 | 132 | (defun lset-vert-prop? (verts prop &optional (val t)) 133 | (declare (list verts) (symbol prop)) 134 | (lambda (wer) (lset-vert-prop wer verts prop val))) 135 | 136 | 137 | (defun set-grp-prop? (g prop &optional (val t)) 138 | (declare (symbol g) (symbol prop)) 139 | (lambda (wer) (setf (get-grp-prop wer g prop) val))) 140 | 141 | ; alterations that return a value, but don't do anything 142 | ; postfixed with ...% 143 | 144 | (defun get-vert-prop% (v prop) 145 | (declare (fixnum v) (symbol prop)) 146 | (lambda (wer) (get-vert-prop wer v prop))) 147 | 148 | (defun get-edge-prop% (edge prop) 149 | (declare (list edge) (symbol prop)) 150 | (lambda (wer) (get-edge-prop wer edge prop))) 151 | 152 | (defun get-grp-prop% (g prop) 153 | (declare (symbol g) (symbol prop)) 154 | (lambda (wer) (get-grp-prop wer g prop))) 155 | 156 | (defun verts-with-prop% (prop &key val) 157 | (declare (symbol prop)) 158 | (lambda (wer) (verts-with-prop wer prop :val val))) 159 | 160 | (defun edges-with-prop% (prop &key val) 161 | (declare (symbol prop)) 162 | (lambda (wer) (edges-with-prop wer prop :val val))) 163 | 164 | -------------------------------------------------------------------------------- /src/weir/paths.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weir) 2 | 3 | ; SPANNING TREE 4 | 5 | (defun get-spanning-tree (wer &key g edges start) 6 | (with-grp (wer grp g) 7 | (if edges (graph:get-edges 8 | (graph:get-spanning-tree (grp-grph grp) :start start)) 9 | (graph:get-spanning-tree (grp-grph grp) :start start)))) 10 | 11 | 12 | (defun get-min-spanning-tree (wer &key g edges start) 13 | (with-grp (wer grp g) 14 | (let ((grph (grp-grph grp)) 15 | (weigthfx (lambda (a b) (weir:edge-length wer a b)))) 16 | (if edges (graph:get-edges 17 | (graph:get-min-spanning-tree grph 18 | :start start :weightfx weigthfx)) 19 | (graph:get-min-spanning-tree grph 20 | :start start :weightfx weigthfx))))) 21 | 22 | 23 | ; CYCLE BASIS 24 | 25 | (defun get-cycle-basis (wer &key g) 26 | (let ((weightfx (if (= (weir-dim wer) 2) 27 | (lambda (a b) (weir:edge-length wer a b)) 28 | (lambda (a b) (weir:3edge-length wer a b))))) 29 | (declare (function weightfx)) 30 | (with-grp (wer grp g) 31 | (graph:get-cycle-basis (grp-grph grp) :weightfx weightfx)))) 32 | 33 | ; CONTINOUS PATHS 34 | 35 | (defun get-segments (wer &key cycle-info g) 36 | (with-grp (wer grp g) 37 | (graph:get-segments (grp-grph grp) :cycle-info cycle-info))) 38 | 39 | (defun walk-graph (wer &key g) 40 | (labels ((-angle (a b c) 41 | (declare (fixnum a b c)) 42 | (destructuring-bind (va vb vc) (gvs wer (list a b c)) 43 | (declare (vec:vec va vb vc)) 44 | (vec:dot (vec:nsub vb va) (vec:nsub vc vb))))) 45 | (with-grp (wer grp g) 46 | (graph:walk-graph (grp-grph grp) :angle #'-angle)))) 47 | 48 | 49 | ; INTERSECTS 50 | 51 | (deftype array-list () `(simple-array list)) 52 | 53 | (defun intersect-all! (wer &key g) 54 | (declare #.*opt-settings* (weir wer)) 55 | (-dimtest wer) 56 | 57 | (let ((crossing->vert (make-hash-table :test #'equal))) 58 | (declare (hash-table crossing->vert)) 59 | 60 | (labels 61 | ((-ic (i c) (declare (fixnum i c)) (if (< i c) (list i c) (list c i))) 62 | 63 | (-add (line i hits) 64 | (declare (list line hits) (fixnum i)) 65 | (loop for (c . p) in hits 66 | if (not (gethash (the list (-ic i c)) crossing->vert)) 67 | do (setf (gethash (the list (-ic i c)) crossing->vert) 68 | (add-vert! wer (vec:lon-line p line))))) 69 | 70 | (-add-new-verts (edges isects) 71 | (declare (array-list edges isects)) 72 | (loop for hits across isects 73 | for i of-type fixnum from 0 74 | if hits do (-add (gvs wer (aref edges i)) i hits))) 75 | 76 | (-edges-as-lines (edges) 77 | (declare (array-list edges)) 78 | (loop for edge of-type list across edges 79 | collect (gvs wer edge))) 80 | 81 | (-del-hit-edges (edges isects g) 82 | (declare (array-list edges isects)) 83 | (loop for hits of-type list across isects 84 | for i of-type fixnum from 0 85 | if hits do (ldel-edge! wer (aref edges i) :g g) 86 | (loop for (c . p) in hits 87 | do (ldel-edge! wer (aref edges c) :g g)))) 88 | 89 | (-sort-hits (isects) 90 | (loop for i of-type fixnum from 0 below (length isects) 91 | if (aref isects i) 92 | do (setf (aref isects i) (sort (aref isects i) #'< :key #'cdr))) 93 | isects) 94 | 95 | (-add-new-edges (edges isects g) 96 | (declare (array-list edges isects)) 97 | (loop for hits of-type list across isects 98 | for i of-type fixnum from 0 99 | if hits 100 | do (loop with cc = (math:lpos hits) 101 | for a of-type fixnum in cc 102 | and b of-type fixnum in (cdr cc) 103 | initially 104 | (add-edge! wer 105 | (gethash (-ic i (first cc)) crossing->vert) 106 | (first (aref edges i)) :g g) 107 | (add-edge! wer 108 | (gethash (-ic i (last* cc)) crossing->vert) 109 | (last* (aref edges i)) :g g) 110 | do (add-edge! wer 111 | (gethash (-ic i a) crossing->vert) 112 | (gethash (-ic i b) crossing->vert) :g g))))) 113 | 114 | (let* ((edges (to-vector (get-edges wer :g g))) 115 | (lines (to-vector (-edges-as-lines edges))) 116 | (isects (-sort-hits (vec:lsegx lines)))) 117 | (declare (array-list isects edges lines)) 118 | (-del-hit-edges edges isects g) 119 | (-add-new-verts edges isects) 120 | (-add-new-edges edges isects g)))) 121 | nil) 122 | 123 | 124 | -------------------------------------------------------------------------------- /src/weir/props.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (defun -get-prop (wer key prop &key default) 6 | (declare #.*opt-settings* (weir wer) (symbol prop)) 7 | "get first matching prop of key" 8 | (multiple-value-bind (alist exists) (gethash key (weir-props wer)) 9 | (unless exists (return-from -get-prop 10 | (values (if default default nil) nil))) 11 | (let ((res (assoc prop alist))) 12 | (unless res (return-from -get-prop (values (if default default nil) nil))) 13 | (values (cdr res) t)))) 14 | 15 | (defun -set-prop (wer key prop &optional (val t)) 16 | (declare #.*opt-settings* (weir wer) (symbol prop)) 17 | "set prop of key to val. shadows previous entries of prop" 18 | (multiple-value-bind (_ exists) (gethash key (weir-props wer)) 19 | (declare (ignore _)) 20 | (if exists (setf (gethash key (weir-props wer)) 21 | (acons prop val (gethash key (weir-props wer)))) 22 | (setf (gethash key (weir-props wer)) `((,prop . ,val))))) 23 | val) 24 | 25 | (defun -clear-prop (wer key) 26 | (declare #.*opt-settings* (weir wer)) 27 | (remhash key (weir-props wer))) 28 | 29 | 30 | (defun set-edge-prop (wer e prop &optional (val t)) 31 | (declare #.*opt-settings* (weir wer) (list e) (symbol prop)) 32 | "set prop of edge e" 33 | (-set-prop wer (sort e #'<) prop val)) 34 | 35 | (defun lset-edge-prop (wer edges prop &optional (val t)) 36 | (declare #.*opt-settings* (weir wer) (list edges) (symbol prop)) 37 | "set prop of edges" 38 | (loop for e of-type list in edges 39 | do (set-edge-prop wer e prop val))) 40 | 41 | (defun set-vert-prop (wer v prop &optional (val t)) 42 | (declare #.*opt-settings* (weir wer) (fixnum v) (symbol prop)) 43 | "set prop of vert v" 44 | (-set-prop wer v prop val)) 45 | 46 | (defun lset-vert-prop (wer verts prop &optional (val t)) 47 | (declare #.*opt-settings* (weir wer) (list verts) (symbol prop)) 48 | "set prop of verts" 49 | (loop for v of-type fixnum in (remove-duplicates (alexandria:flatten verts)) 50 | do (set-vert-prop wer v prop val))) 51 | 52 | 53 | (defun set-grp-prop (wer g prop &optional (val t)) 54 | (declare #.*opt-settings* (weir wer) (symbol g) (symbol prop)) 55 | "set prop of grp g" 56 | (-set-prop wer g prop val)) 57 | 58 | 59 | (defun get-edge-prop (wer e prop &key default) 60 | (declare #.*opt-settings* (weir wer) (list e) (symbol prop)) 61 | "get prop ov edge e" 62 | (-get-prop wer (sort e #'<) prop :default default)) 63 | 64 | (defun get-vert-prop (wer v prop &key default) 65 | (declare #.*opt-settings* (weir wer) (fixnum v) (symbol prop)) 66 | "get prop of vert v" 67 | (-get-prop wer v prop :default default)) 68 | 69 | (defun get-grp-prop (wer g prop &key default) 70 | (declare #.*opt-settings* (weir wer) (symbol g) (symbol prop)) 71 | "get prop of grp g" 72 | (-get-prop wer g prop :default default)) 73 | 74 | 75 | (defsetf -get-prop -set-prop) 76 | (defsetf get-edge-prop set-edge-prop) 77 | (defsetf get-vert-prop set-vert-prop) 78 | (defsetf get-grp-prop set-grp-prop) 79 | 80 | 81 | (defun edge-has-prop (wer e prop &key val) 82 | (declare #.*opt-settings* (weir wer) (list e) (symbol prop)) 83 | "t if edge e has prop (and val)" 84 | (multiple-value-bind (v exists) (get-edge-prop wer e prop) 85 | (if val (and exists (equal v val)) exists))) 86 | 87 | (defun vert-has-prop (wer v prop &key val) 88 | (declare #.*opt-settings* (weir wer) (fixnum v) (symbol prop)) 89 | "t if vert v has prop (and val)" 90 | (multiple-value-bind (v exists) (get-vert-prop wer v prop) 91 | (if val (and exists (equal v val)) exists))) 92 | 93 | 94 | ;TODO: reverse index for faster lookup? 95 | (defun edges-with-prop (wer prop &key val g &aux (res (list))) 96 | (declare #.*opt-settings* (weir wer) (symbol prop) (list res)) 97 | "find edges with prop (and val)" 98 | (labels ((accept (e) (get-edge-prop wer e prop)) 99 | (acceptval (e) (let ((pv (get-edge-prop wer e prop))) 100 | (and pv (equal pv val))))) 101 | (let ((do-test (if val #'acceptval #'accept))) 102 | (with-grp (wer g* g) 103 | (graph:with-graph-edges ((grp-grph g*) e) 104 | (when (funcall do-test e) (push e res))))) 105 | res)) 106 | 107 | 108 | (defun verts-with-prop (wer prop &key val &aux (res (list))) 109 | (declare #.*opt-settings* (weir wer) (symbol prop) (list res)) 110 | "find verts with prop (and val)" 111 | (labels ((accept (v) (get-vert-prop wer v prop)) 112 | (acceptval (v) (let ((pv (get-vert-prop wer v prop))) 113 | (and pv (equal pv val))))) 114 | (let ((do-test (if val #'acceptval #'accept))) 115 | (loop for v from 0 below (weir-num-verts wer) 116 | do (when (funcall do-test v) (push v res)))) 117 | res)) 118 | 119 | 120 | (defun edge-prop-nxt-vert (wer v prop &key val (except -1) g) 121 | (declare #.*opt-settings* (weir wer) (fixnum v except) (symbol prop)) 122 | " 123 | get first (encountered) incident vert w from v, with prop (and val). 124 | ignores w when w == except. 125 | returns nil if there is no incident vert. 126 | " 127 | (loop for w in (get-incident-verts wer v :g g) 128 | if (not (= except w)) 129 | do (when (edge-has-prop wer (sort (list v w) #'<) prop :val val) 130 | (return-from edge-prop-nxt-vert w))) 131 | nil) 132 | 133 | 134 | (defun all-grps->main! (wer &key g) 135 | (itr-grps (wer g*) 136 | (itr-edges (wer e :g g*) 137 | (set-edge-prop wer (ladd-edge! wer e :g g) g*)))) 138 | 139 | 140 | (defun show-props (wer) 141 | (loop for key being the hash-keys of (weir-props wer) using (hash-value v) 142 | do (format t "~%~%------~%") 143 | (print (list :key key)) 144 | (print v))) 145 | 146 | -------------------------------------------------------------------------------- /src/weir/weir-extra.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weir) 2 | 3 | 4 | (defun cut-to-area! (wer &key top left bottom right g) 5 | " 6 | removes all edges (in g) outside envelope (ox oy), (w h). 7 | all edges intersecting the envelope will be deleted, a new vert will be 8 | inserted on the intersection. connected to the inside vert. 9 | edges inside the envelope will be left as they are. 10 | " 11 | (declare (weir wer) (double-float top left bottom right)) 12 | (labels 13 | ((inside (pt) 14 | (declare (vec:vec pt)) 15 | (vec:with-xy (pt x y) 16 | (and (> x left) (> y top) (< x right) (< y bottom)))) 17 | 18 | (split-line (line &aux (rev nil)) 19 | (declare (list line) (boolean rev)) 20 | (unless (inside (first line)) (setf line (reverse line) rev t)) 21 | (destructuring-bind (a b) line 22 | (declare (vec:vec a b)) 23 | (return-from split-line 24 | (vec:with-xy (a xa ya) 25 | (vec:with-xy (b xb yb) 26 | (list rev (vec:lon-line 27 | (cond ((> xb right) (/ (- right xa) (- xb xa))) 28 | ((> yb bottom) (/ (- bottom ya) (- yb ya))) 29 | ((< xb left) (/ (- left xa) (- xb xa))) 30 | (t (/ (- top ya) (- yb ya)))) ; (< yb top) 31 | line))))))) 32 | 33 | (cutfx (line) 34 | (declare (list line)) 35 | (let ((c (length (remove-if-not #'inside line)))) 36 | (declare (fixnum c)) 37 | (case c (0 (values :none nil (vec:zero))) 38 | (1 (destructuring-bind (rev pt) (split-line line) 39 | (values :split rev pt))) 40 | (t (values :keep nil (vec:zero))))))) 41 | 42 | (with (wer %) 43 | (itr-edges (wer e :g g) 44 | (alexandria:with-gensyms (ae) 45 | (multiple-value-bind (state rev pt) (cutfx (get-verts wer e)) 46 | (declare (symbol state) (boolean rev) (vec:vec pt)) 47 | (case state (:none (% (ldel-edge? e :g g))) 48 | (:split 49 | (% (ldel-edge? e :g g)) 50 | (% (append-edge? 51 | (if rev (second e) (first e)) pt :rel nil :g g) 52 | :res ae) 53 | (% (set-vert-prop? ae :cut) :arg (ae)))))))))) 54 | 55 | -------------------------------------------------------------------------------- /src/weir/weir-macro.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (defmacro with-verts-in-rad ((wer xy rad v) &body body) 6 | (declare (symbol wer)) 7 | (alexandria:with-gensyms (wname) 8 | `(let ((,wname ,wer)) 9 | (zonemap:with-verts-in-rad ((weir-zonemap ,wname) 10 | (weir-verts ,wname) ,xy ,rad ,v) 11 | (progn ,@body))))) 12 | 13 | 14 | (defmacro with-rnd-edge ((wer i &key g) &body body) 15 | (declare (symbol wer)) 16 | " 17 | select an arbitrary edge from a weir instance. the edge will be 18 | available in the context as i. 19 | 20 | if a grp, g, is supplied it will select an edge from g, otherwise it will use 21 | the main grp. 22 | " 23 | (alexandria:with-gensyms (grp edges grph ln) 24 | `(with-grp (,wer ,grp ,g) 25 | (let ((,grph (grp-grph ,grp))) 26 | (let* ((,edges (to-vector (graph:get-edges ,grph))) 27 | (,ln (length ,edges))) 28 | (declare (pos-int ,ln)) 29 | (when (> ,ln 0) (let ((,i (aref ,edges (rnd:rndi ,ln)))) 30 | (declare (list ,i)) 31 | (progn ,@body)))))))) 32 | 33 | 34 | (defmacro with-rnd-vert ((wer i) &body body) 35 | (declare (symbol wer)) 36 | " 37 | select an arbitrary vert from a weir instance. the vert will be available in 38 | the context as i. 39 | " 40 | (alexandria:with-gensyms (num) 41 | `(let ((,num (weir-num-verts ,wer))) 42 | (when (> ,num 0) (let ((,i (rnd:rndi ,num))) 43 | (declare (pos-int ,i)) 44 | (progn ,@body)))))) 45 | 46 | 47 | (defmacro itr-verts ((wer i &key collect) &body body) 48 | (declare (symbol wer) (boolean collect)) 49 | "iterates over ALL verts in wer as i" 50 | (alexandria:with-gensyms (wname) 51 | `(let ((,wname ,wer)) 52 | (loop for ,i of-type pos-int from 0 below (weir-num-verts ,wname) 53 | ,(if collect 'collect 'do) 54 | (progn ,@body))))) 55 | 56 | 57 | (defmacro itr-grp-verts ((wer i &key g collect) &body body) 58 | (declare (symbol wer) (boolean collect)) 59 | " 60 | iterates over all verts in grp g as i. 61 | 62 | NOTE: this will only yield vertices that belong to at least one edge that is 63 | part of g. if you want all vertices in weir you should use itr-verts instead. 64 | itr-verts is also faster, since it does not rely on the underlying graph 65 | structure. 66 | 67 | if g is not provided, the main grp wil be used. 68 | " 69 | (alexandria:with-gensyms (grp) 70 | `(with-grp (,wer ,grp ,g) 71 | (map ',(if collect 'list 'nil) 72 | (lambda (,i) (declare (pos-int ,i)) (progn ,@body)) 73 | (graph:get-verts (grp-grph ,grp)))))) 74 | 75 | 76 | (defmacro itr-edges ((wer i &key g collect) &body body) 77 | (declare (symbol wer) (boolean collect)) 78 | " 79 | iterates over all edges in grp g as i. 80 | if g is not provided, the main grp will be used. 81 | " 82 | (alexandria:with-gensyms (grp grph) 83 | `(with-grp (,wer ,grp ,g) 84 | (let ((,grph (grp-grph ,grp))) 85 | (map ',(if collect 'list 'nil) 86 | (lambda (,i) (declare (list ,i)) (progn ,@body)) 87 | (graph:get-edges ,grph)))))) 88 | 89 | 90 | (defmacro itr-edge-verts ((wer vv &key g) &body body) 91 | (declare (symbol wer)) 92 | " 93 | iterates over all edges (as verts) in grp g as i. 94 | if g is not provided, the main grp will be used. 95 | " 96 | (alexandria:with-gensyms (grp grph e) 97 | `(with-grp (,wer ,grp ,g) 98 | (let ((,vv nil) 99 | (,grph (grp-grph ,grp))) 100 | (graph:with-graph-edges (,grph ,e) 101 | (setf ,vv (gvs ,wer ,e)) 102 | (progn ,@body)))))) 103 | 104 | 105 | (defmacro itr-edge-verts* ((wer ee vv &key g) &body body) 106 | (declare (symbol wer)) 107 | " 108 | iterates over all edges (as verts) in grp g as i. 109 | if g is not provided, the main grp will be used. 110 | " 111 | (alexandria:with-gensyms (grp grph) 112 | `(with-grp (,wer ,grp ,g) 113 | (let ((,vv nil) 114 | (,grph (grp-grph ,grp))) 115 | (graph:with-graph-edges (,grph ,ee) 116 | (setf ,vv (gvs ,wer ,ee)) 117 | (progn ,@body)))))) 118 | 119 | 120 | (defmacro 3itr-edge-verts ((wer vv &key g) &body body) 121 | (declare (symbol wer)) 122 | " 123 | iterates over all edges (as verts) in grp g as i. 124 | if g is not provided, the main grp will be used. 125 | " 126 | (alexandria:with-gensyms (grp grph e) 127 | `(with-grp (,wer ,grp ,g) 128 | (let ((,vv nil) 129 | (,grph (grp-grph ,grp))) 130 | (graph:with-graph-edges (,grph ,e) 131 | (setf ,vv (3gvs ,wer ,e)) 132 | (progn ,@body)))))) 133 | 134 | 135 | (defmacro 3itr-edge-verts* ((wer ee vv &key g) &body body) 136 | (declare (symbol wer)) 137 | " 138 | iterates over all edges (as verts) in grp g as i. 139 | if g is not provided, the main grp will be used. 140 | " 141 | (alexandria:with-gensyms (grp grph) 142 | `(with-grp (,wer ,grp ,g) 143 | (let ((,vv nil) 144 | (,grph (grp-grph ,grp))) 145 | (graph:with-graph-edges (,grph ,ee) 146 | (setf ,vv (3gvs ,wer ,ee)) 147 | (progn ,@body)))))) 148 | 149 | 150 | (defmacro itr-grps ((wer g &key collect main) &body body) 151 | (declare (symbol wer) (boolean collect)) 152 | "iterates over all grps of wer as g" 153 | (alexandria:with-gensyms (grps wname main*) 154 | `(loop with ,wname = ,wer 155 | with ,main* = ,main 156 | with ,grps = (weir-grps ,wname) 157 | for ,g being the hash-keys of ,grps 158 | if (or ,main* ,g) 159 | ,(if collect 'collect 'do) 160 | (progn ,@body)))) 161 | 162 | -------------------------------------------------------------------------------- /system-index.txt: -------------------------------------------------------------------------------- 1 | weir.asd 2 | -------------------------------------------------------------------------------- /test/bzspl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun test-bzspl () 4 | (let ((pts-a (list (vec:vec -20.0d0 99.0d0) 5 | (vec:vec 0.0d0 1.0d0) 6 | (vec:vec 10.0d0 20.0d0) 7 | (vec:vec 100.0d0 100.0d0))) 8 | (pts-b (list (vec:vec -20.0d0 99.0d0) 9 | (vec:vec 0.0d0 1.0d0) 10 | (vec:vec 10.0d0 20.0d0) 11 | (vec:vec 100.0d0 100.0d0) 12 | (vec:vec -3.0d0 -17.0d0) 13 | (vec:vec 0.0d0 4.0d0))) 14 | (pts-c (list (vec:vec -32.0d0 79.0d0) 15 | (vec:vec 0.3d0 3.0d0) 16 | (vec:vec 10.1d0 25.0d0)))) 17 | (do-test 18 | (bzspl:pos* (bzspl:make pts-c) (math:linspace 5 0d0 1d0)) 19 | (list (vec:vec -32.0d0 79.0d0) 20 | (vec:vec -17.256249999999998d0 47.125d0) 21 | (vec:vec -5.324999999999999d0 27.5d0) 22 | (vec:vec 3.7937499999999993d0 20.125d0) 23 | (vec:vec 10.1d0 25.0d0))) 24 | 25 | (do-test 26 | (bzspl:pos* (bzspl:make pts-c :closed t) (math:linspace 5 0d0 1d0)) 27 | 28 | (list (vec:vec -15.85d0 41.0d0) 29 | (vec:vec 2.046875d0 11.5625d0) 30 | (vec:vec 3.6125d0 29.0d0) 31 | (vec:vec -19.150000000000002d0 61.4375d0) 32 | (vec:vec -15.85d0 41.0d0))) 33 | 34 | (do-test 35 | (bzspl:pos* (bzspl:make pts-a) (math:linspace 10 0d0 1d0)) 36 | (list (vec:vec -20.0d0 99.0d0) 37 | (vec:vec -11.851851851851853d0 60.75308641975309d0) 38 | (vec:vec -5.185185185185186d0 33.12345679012346d0) 39 | (vec:vec -8.881784197001252d-16 16.111111111111114d0) 40 | (vec:vec 3.7037037037037024d0 9.716049382716054d0) 41 | (vec:vec 7.160493827160495d0 13.481481481481485d0) 42 | (vec:vec 17.777777777777775d0 24.666666666666664d0) 43 | (vec:vec 36.7901234567901d0 42.814814814814795d0) 44 | (vec:vec 64.19753086419752d0 67.92592592592591d0) 45 | (vec:vec 100.0d0 100.0d0))) 46 | 47 | (do-test 48 | (bzspl:pos* (bzspl:make pts-b) (math:linspace 10 0d0 1d0)) 49 | (list (vec:vec -20.0d0 99.0d0) 50 | (vec:vec -5.185185185185186d0 33.12345679012346d0) 51 | (vec:vec 3.7037037037037024d0 9.716049382716054d0) 52 | (vec:vec 12.777777777777775d0 20.22222222222222d0) 53 | (vec:vec 36.9753086419753d0 43.728395061728385d0) 54 | (vec:vec 70.23456790123457d0 72.91358024691358d0) 55 | (vec:vec 72.11111111111111d0 69.55555555555556d0) 56 | (vec:vec 37.728395061728435d0 29.481481481481524d0) 57 | (vec:vec 8.098765432098773d0 1.0370370370370405d0) 58 | (vec:vec 0.0d0 4.0d0))) 59 | 60 | (do-test 61 | (bzspl:pos* (bzspl:make pts-a :closed t) (math:linspace 10 0d0 1d0)) 62 | (list (vec:vec -10.0d0 50.0d0) 63 | (vec:vec -2.098765432098766d0 18.000000000000004d0) 64 | (vec:vec 3.8271604938271597d0 9.111111111111114d0) 65 | (vec:vec 12.777777777777775d0 20.22222222222222d0) 66 | (vec:vec 36.9753086419753d0 43.728395061728385d0) 67 | (vec:vec 69.81481481481482d0 75.77777777777779d0) 68 | (vec:vec 68.33333333333334d0 95.33333333333331d0) 69 | (vec:vec 27.53086419753091d0 98.79012345679014d0) 70 | (vec:vec -5.061728395061721d0 83.97530864197533d0) 71 | (vec:vec -10.0d0 50.0d0))) 72 | 73 | (do-test 74 | (bzspl:pos* (bzspl:make pts-b :closed t) (math:linspace 10 0d0 1d0)) 75 | (list (vec:vec -10.0d0 50.0d0) 76 | (vec:vec 1.1111111111111107d0 10.666666666666668d0) 77 | (vec:vec 12.777777777777775d0 20.22222222222222d0) 78 | (vec:vec 55.0d0 60.0d0) 79 | (vec:vec 72.11111111111111d0 69.55555555555556d0) 80 | (vec:vec 20.055555555555546d0 10.166666666666655d0) 81 | (vec:vec -1.5d0 -6.5d0) 82 | (vec:vec -4.611111111111104d0 23.9444444444444d0) 83 | (vec:vec -14.444444444444443d0 72.44444444444443d0) 84 | (vec:vec -10.0d0 50.0d0))) 85 | 86 | (rnd:set-rnd-state 1) 87 | 88 | (do-test 89 | (let ((a (list))) 90 | (bzspl:with-rndpos ((bzspl:make pts-b :closed t) 5 v) 91 | (setf a (append a (list v)))) 92 | a) 93 | (list (vec:vec -10.08497035719275d0 51.90358188928061d0) 94 | (vec:vec 72.94161639142136d0 70.67347981875085d0) 95 | (vec:vec -9.972643319179285d0 49.866015920500494d0) 96 | (vec:vec 4.718551216740959d0 -4.763338116541952d0) 97 | (vec:vec 35.77978017789251d0 42.626750166588465d0))) 98 | 99 | (do-test (length (bzspl:adaptive-pos (bzspl:make pts-a))) 31) 100 | 101 | (do-test 102 | (bzspl:adaptive-pos (bzspl:make (list (vec:vec 0d0 0d0) 103 | (vec:vec 1d0 2d0) 104 | (vec:vec -3d0 5d0)))) 105 | (list (vec:vec 0.0d0 0.0d0) 106 | (vec:vec 0.18643209278419098d0 1.0719185917278686d0) 107 | (vec:vec -0.09541948616495921d0 1.9685997925944037d0) 108 | (vec:vec -0.8581716831302144d0 3.0757985486108788d0) 109 | (vec:vec -1.530471900097555d0 3.7746049937079564d0) 110 | (vec:vec -3.0d0 5.0d0))) 111 | 112 | (do-test 113 | (bzspl:adaptive-pos (bzspl:make (list (vec:vec 0d0 0d0) 114 | (vec:vec 1d0 2d0) 115 | (vec:vec -3d0 5d0)) 116 | :closed t)) 117 | (list (vec:vec 0.5d0 1.0d0) 118 | (vec:vec 0.34369428112685496d0 2.1756813817990692d0) 119 | (vec:vec -0.3661101319802346d0 2.980843763395622d0) 120 | (vec:vec -1.9897280476541732d0 4.061850847855913d0) 121 | (vec:vec -2.087899364481774d0 3.648441004667016d0) 122 | (vec:vec -0.907456391822953d0 1.5952742657912453d0) 123 | (vec:vec -0.16395699030197697d0 0.8157890863508436d0) 124 | (vec:vec 0.5d0 1.0d0))) 125 | 126 | (do-test (bzspl:len (bzspl:make pts-a)) 225.04803388452214d0) 127 | 128 | (do-test (bzspl:len (bzspl:make pts-a :closed t)) 275.04416436128014d0))) 129 | 130 | 131 | (define-file-tests tests-bzspl () 132 | (test-title (test-bzspl))) 133 | -------------------------------------------------------------------------------- /test/chromatic.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/sbcl --script 2 | 3 | (load "../examples/load") 4 | 5 | ;TODO: integrate this into the test suite 6 | 7 | (rnd:set-rnd-state 1) 8 | 9 | 10 | (defun main (size fn) 11 | (let ((sand (sandpaint:make :size size 12 | :fg (pigment:white) 13 | :bg (pigment:white)))) 14 | 15 | (sandpaint:clear-fx sand :fx (lambda (xy) 16 | (pigment:hsv 0d0 0d0 (+ 0.9d0 (rnd:rnd 0.1d0))))) 17 | 18 | (loop with ls = (math:linspace 9 200d0 1800d0) 19 | for x in ls 20 | for i from 0 21 | do (loop for y in ls 22 | for j from 0 23 | if (>= i j) 24 | do 25 | 26 | (sandpaint:set-fg sand (pigment:black 0.3d0)) 27 | (sandpaint:circ sand (list (vec:vec x y)) 120d0 300000) 28 | 29 | (sandpaint:set-fg sand (pigment:white 0.1d0)) 30 | (sandpaint:circ sand (list (vec:vec x y)) 100d0 300000) 31 | 32 | (sandpaint:set-fg sand (pigment:white)) 33 | (sandpaint:circ sand (list (vec:vec x y)) 80d0 300000) 34 | )) 35 | 36 | (sandpaint:set-fg sand (pigment:black 0.3d0)) 37 | (sandpaint:circ sand (list (vec:rep 1000d0)) 5d0 30000) 38 | 39 | 40 | (loop for y in (math:linspace 4 100d0 1000d0) 41 | do (loop for x in (math:linspace 200 (+ y 100d0) (+ y 300d0)) 42 | do (sandpaint:stroke sand (list (vec:vec x (- 1700d0 x)) 43 | (vec:vec x (+ x 1800d0))) 44 | 1000))) 45 | 46 | (sandpaint:chromatic-aberration sand 47 | :cafx (sandpaint:cafx-expt (vec:rep 1000d0) 1000d0 5d0)) 48 | 49 | (sandpaint::check-integrity sand) 50 | 51 | (sandpaint:save sand "chromatic"))) 52 | 53 | 54 | (time (main 2000 (second (weir-utils:cmd-args)))) 55 | 56 | -------------------------------------------------------------------------------- /test/chromatic.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weir/beb4f6f47f0538d2c6d73b1d3c9d7f58ac8aa0e9/test/chromatic.png -------------------------------------------------------------------------------- /test/data/pix-overlap.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weir/beb4f6f47f0538d2c6d73b1d3c9d7f58ac8aa0e9/test/data/pix-overlap.png -------------------------------------------------------------------------------- /test/data/sandpaint-16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weir/beb4f6f47f0538d2c6d73b1d3c9d7f58ac8aa0e9/test/data/sandpaint-16.png -------------------------------------------------------------------------------- /test/data/sandpaint-8.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weir/beb4f6f47f0538d2c6d73b1d3c9d7f58ac8aa0e9/test/data/sandpaint-8.png -------------------------------------------------------------------------------- /test/data/sandpaint-circ.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weir/beb4f6f47f0538d2c6d73b1d3c9d7f58ac8aa0e9/test/data/sandpaint-circ.png -------------------------------------------------------------------------------- /test/data/sandpaint-rnd.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weir/beb4f6f47f0538d2c6d73b1d3c9d7f58ac8aa0e9/test/data/sandpaint-rnd.png -------------------------------------------------------------------------------- /test/graph.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %test-graph () 4 | 5 | (let ((grph (graph:make))) 6 | 7 | (do-test (graph:add grph 1 1) t) 8 | (do-test (graph:add grph 1 2) t) 9 | (do-test (graph:add grph 1 2) nil) 10 | (do-test (graph:add grph 2 1) nil) 11 | (do-test (graph:get-num-edges grph) 2) 12 | (do-test (graph:get-edges grph) '((1 2))) 13 | (do-test (graph:add grph 20 5) t) 14 | (do-test (graph:get-edges grph) '((5 20) (1 2))) 15 | (do-test (graph:del grph 1 2) t) 16 | (do-test (graph:del grph 1 2) nil) 17 | (do-test (graph:get-edges grph) '((5 20))) 18 | (do-test (graph:get-num-edges grph) 2) 19 | (do-test (graph:mem grph 1 4) nil) 20 | (do-test (graph:mem grph 1 1) t) 21 | (do-test (sort (graph:get-verts grph) #'<) '(1 5 20)) 22 | (do-test (graph:del grph 1 1) t) 23 | (do-test (graph:get-edges grph) '((5 20))) 24 | (do-test (sort (graph:get-verts grph) #'<) '(5 20)) 25 | (do-test (graph:del grph 5 20) t) 26 | (do-test (sort (graph:get-verts grph) #'<) nil)) 27 | 28 | (do-test (graph:edge-set->path '((3 4) (4 5) (5 6) (1 2) (2 3))) 29 | '(1 2 3 4 5 6) ) 30 | (do-test (graph:edge-set->path '((1 2))) '(1 2)) 31 | (do-test (graph:edge-set->path '()) nil) 32 | (do-test (graph:edge-set->path '((3 4) (4 5))) '(3 4 5)) 33 | 34 | (let ((grph (graph:make))) 35 | ; ensure that mutating one graph does not effect the other 36 | (graph:add grph 2 1) 37 | (graph:add grph 3 2) 38 | (graph:add grph 4 1) 39 | 40 | (let ((new-grph (graph:copy grph))) 41 | (graph:del new-grph 1 4) 42 | 43 | (do-test (length (graph:get-edges grph)) 3) 44 | (do-test (length (graph:get-edges new-grph)) 2))) 45 | 46 | (let ((grph (graph:make))) 47 | (graph:add grph 0 1) 48 | (graph:add grph 3 2) 49 | (graph:add grph 1 3) 50 | (graph:add grph 0 3) 51 | (graph:add grph 1 4) 52 | (graph:add grph 4 5) 53 | (graph:add grph 5 6) 54 | 55 | (do-test (length (graph:get-edges (graph:del-simple-filaments grph))) 3))) 56 | 57 | 58 | (define-file-tests test-graph () 59 | (test-title (%test-graph))) 60 | -------------------------------------------------------------------------------- /test/hset.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %test-hset () 4 | 5 | (let ((hs (hset:make))) 6 | 7 | (do-test (hset:add hs 1) t) 8 | 9 | (do-test (hset:add hs 1) nil) 10 | 11 | (do-test (hset:add hs 20) t) 12 | 13 | (do-test (hset:add hs 40) t) 14 | 15 | (do-test (hset:add hs 73) t) 16 | 17 | (do-test (hset:num hs) 4) 18 | 19 | (do-test (hset:del hs 1) t) 20 | 21 | (do-test (hset:del hs 1) nil) 22 | 23 | (do-test (hset:mem hs 40) t) 24 | 25 | (do-test (hset:mem* hs (list 40 88)) (list t nil)) 26 | 27 | (do-test (sort (hset:to-list hs) #'<) (list 20 40 73))) 28 | 29 | (let ((hs (hset:make :init (list 1 2 3)))) 30 | (do-test (hset:to-list hs) (list 1 2 3)))) 31 | 32 | 33 | 34 | (define-file-tests test-hset () 35 | (test-title (%test-hset))) 36 | -------------------------------------------------------------------------------- /test/kdtree.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun -dst (verts cand) 4 | (loop with hit = 0 5 | with dst = (vec:3dst2 (first verts) cand) 6 | for v in (cdr verts) 7 | for i from 1 8 | do (let ((d (vec:3dst2 v cand))) 9 | (when (< d dst) (setf dst d hit i))) 10 | finally (return hit))) 11 | 12 | (defun -rad (verts cand rad) 13 | (loop with rad2 = (expt rad 2d0) 14 | with res = (make-adjustable-vector :type 'fixnum) 15 | for v in verts 16 | for i from 0 17 | do (let ((d (vec:3dst2 v cand))) 18 | (when (< d rad2) (vextend i res))) 19 | finally (return res))) 20 | 21 | 22 | (defun %test-kdtree () 23 | (let* ((verts (rnd:3nin-cube 100000 500d0)) 24 | (kd (time (kdtree:make verts))) 25 | (cands (rnd:3nin-cube 10000 500d0))) 26 | 27 | ;(print kd) 28 | 29 | (do-test (time (loop for cand in cands collect (kdtree:nn kd cand))) 30 | (time (loop for cand in cands collect (-dst verts cand)))) 31 | 32 | (do-test (time (sort (kdtree:rad kd (vec:3vec 100d0 200d0 41d0) 50d0) #'<)) 33 | (time (sort (-rad verts (vec:3vec 100d0 200d0 41d0) 50d0) #'<))))) 34 | 35 | 36 | 37 | (define-file-tests test-kdtree () 38 | (test-title (%test-kdtree))) 39 | 40 | 41 | ;(require :sb-sprof) 42 | ;(sb-sprof:with-profiling (:max-samples 200000 43 | ; ;:mode :cpu 44 | ; ;:mode :alloc 45 | ; :mode :time 46 | ; :report :graph) 47 | ; (test-kdtree)) 48 | -------------------------------------------------------------------------------- /test/linear-path.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | 4 | (defun %test-linear-path () 5 | (let ((apath (lin-path:make (rnd:nin-rect 33 300d0 300d0)))) 6 | (do-test 7 | (lin-path:pos* apath (rnd:rndspace 20 0d0 1d0)) 8 | (list (vec:vec -9.438347648872167d0 -175.225149152222d0) 9 | (vec:vec 116.89881659438566d0 -26.809245714782996d0) 10 | (vec:vec -65.36161703283702d0 185.74828332183736d0) 11 | (vec:vec -105.48322687473d0 -9.890268437414548d0) 12 | (vec:vec 267.68539603378895d0 81.3043899209714d0) 13 | (vec:vec -132.40421434059442d0 195.15630286314308d0) 14 | (vec:vec -97.44930816032483d0 177.55858394044853d0) 15 | (vec:vec 266.5652538517507d0 -0.12485684153419593d0) 16 | (vec:vec 164.1995002008751d0 105.86496577929238d0) 17 | (vec:vec -26.728304107996706d0 -204.3541153362095d0) 18 | (vec:vec -177.47950464695646d0 150.76511064797404d0) 19 | (vec:vec 14.766557204046116d0 -93.04887526533449d0) 20 | (vec:vec 91.93635520751945d0 -108.1690462450528d0) 21 | (vec:vec 170.5374458058014d0 143.51512360627012d0) 22 | (vec:vec -104.24865074429103d0 64.19229247140761d0) 23 | (vec:vec 13.85574261994833d0 168.04649139453574d0) 24 | (vec:vec 90.01632000058807d0 -106.09734739384757d0) 25 | (vec:vec 33.09742525543997d0 -109.45542035126164d0) 26 | (vec:vec -190.2979189072196d0 196.3589224835634d0) 27 | (vec:vec 125.93727427384897d0 112.82256366840846d0))) 28 | 29 | (do-test 30 | (lin-path:pos* apath (rnd:rndspace 5 0d0 1d0)) 31 | (list (vec:vec -187.5705364827427d0 158.41359771733312d0) 32 | (vec:vec 187.35293276640311d0 -29.852529549097056d0) 33 | (vec:vec -5.522855469879147d0 -168.62858891534736d0) 34 | (vec:vec 55.13044208493619d0 156.21422990619857d0) 35 | (vec:vec 200.2368412092638d0 114.61642591669907d0)))) 36 | 37 | (let ((apath (lin-path:make (rnd:nin-rect 12 300d0 300d0) :closed t))) 38 | (do-test 39 | (lin-path:pos* apath (rnd:rndspace 20 0d0 1d0)) 40 | (list (vec:vec 27.920854552669738d0 72.74990940914415d0) 41 | (vec:vec 20.347116016838214d0 60.03424910291827d0) 42 | (vec:vec 90.54515305308234d0 56.63138904522498d0) 43 | (vec:vec -25.3222203310782d0 -183.1677471273439d0) 44 | (vec:vec 211.41460164089594d0 295.28993948962716d0) 45 | (vec:vec -55.15685103609334d0 -219.1553983499264d0) 46 | (vec:vec 3.5116120355960163d0 -212.55092858244558d0) 47 | (vec:vec 22.934457423851427d0 -210.36444561614667d0) 48 | (vec:vec -16.230443414179007d0 -1.3763499500023784d0) 49 | (vec:vec -114.29745056967332d0 -38.66755954976239d0) 50 | (vec:vec 120.46277829407285d0 -199.3854150955505d0) 51 | (vec:vec 161.48480036064814d0 -188.4310964342001d0) 52 | (vec:vec -250.3371679969546d0 59.6286189885981d0) 53 | (vec:vec 211.5358543713892d0 296.19316067596804d0) 54 | (vec:vec 141.119808254249d0 262.8012870055113d0) 55 | (vec:vec 76.43639032666181d0 -34.81227407014987d0) 56 | (vec:vec -83.50672601072395d0 -3.0479216467079766d0) 57 | (vec:vec 84.97443810482987d0 -186.13693462985242d0) 58 | (vec:vec -66.5778671576494d0 -220.44109345321482d0) 59 | (vec:vec -3.2600089472467175d0 192.22456394293548d0))) 60 | 61 | (do-test 62 | (lin-path:pos* apath (rnd:rndspace 5 0d0 1d0)) 63 | (list (vec:vec -79.39852989264577d0 -107.43017344211452d0) 64 | (vec:vec -55.656453545073305d0 162.25392644684086d0) 65 | (vec:vec 96.08643196039844d0 -190.68148658414955d0) 66 | (vec:vec -87.73518977972896d0 -57.86025399494548d0) 67 | (vec:vec -11.885662338531773d0 5.918166490124946d0))) 68 | 69 | (do-test 70 | (lin-path:rndpos apath 5) 71 | (list (vec:vec 129.62232574809065d0 -187.47570071925472d0) 72 | (vec:vec 196.2965520484057d0 182.6743915136004d0) 73 | (vec:vec 95.34514262347875d0 -186.44790001400926d0) 74 | (vec:vec 201.75690539451068d0 272.4593392134565d0) 75 | (vec:vec 173.48377006092858d0 -193.41669665923908d0))))) 76 | 77 | (define-file-tests test-linear-path () 78 | (test-title (%test-linear-path))) 79 | -------------------------------------------------------------------------------- /test/math.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %test-math () 4 | (do-test (to-list 5 | (math:path-tangents (list (vec:vec 1.0d0 2.0d0) 6 | (vec:vec 1.0d0 2.0d0) 7 | (vec:vec 0.5d0 4.322d0)))) 8 | (list (vec:rep 0d0) 9 | (vec:vec -0.21050655592417808d0 0.977592445711883d0))) 10 | 11 | (do-test (math:imod 20 3 21) 2) 12 | 13 | (do-test (math:dmod 20d0 3d0 21d0) 2d0) 14 | 15 | (do-test (math:linspace 1 0d0 10d0) (list 0.0)) 16 | 17 | (do-test (math:linspace 3 0d0 10d0) (list 0.0 5.0 10.0)) 18 | 19 | (do-test (math:linspace 2 0d0 10d0 :end nil) (list 0.0 5.0)) 20 | 21 | (do-test (math:linspace 2 0d0 10d0 :end t) (list 0.0 10.0)) 22 | 23 | (do-test (math:range 2 5) (list 2 3 4)) 24 | 25 | (do-test (math:range 5) (list 0 1 2 3 4)) 26 | 27 | (do-test (math:argmax '(4 2 3 0 6)) '(4 6)) 28 | (do-test (math:argmax '(4 2 10 0 6)) '(2 10)) 29 | 30 | (do-test (math:argmin '(4 2 3 0 6)) '(3 0)) 31 | (do-test (math:argmin '(-1 2 10 4 9 6)) '(0 -1)) 32 | 33 | (do-test 34 | (let ((a (list))) 35 | (math:with-linspace (10 0d0 7d0 v) 36 | (setf a (append a (list v)))) 37 | a) 38 | '(0.0d0 0.7777777777777778d0 1.5555555555555556d0 2.3333333333333335d0 39 | 3.111111111111111d0 3.888888888888889d0 4.666666666666667d0 40 | 5.444444444444445d0 6.222222222222222d0 7.0d0)) 41 | 42 | (do-test 43 | (let ((a (list))) 44 | (math:with-linspace (10 0d0 7d0 v :end nil) 45 | (setf a (append a (list v)))) 46 | a) 47 | '(0.0d0 0.7d0 1.4d0 2.0999999999999996d0 2.8d0 3.5d0 4.199999999999999d0 48 | 4.8999999999999995d0 5.6d0 6.3d0))) 49 | 50 | 51 | 52 | (define-file-tests test-math () 53 | (test-title (%test-math))) 54 | -------------------------------------------------------------------------------- /test/ortho.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %test-ortho () 4 | (let* ((proj (ortho:make :cam (rnd:3on-sphere :rad 1000d0) 5 | :look (vec:3rep 0d0) 6 | :s 0.3d0 7 | :up (rnd:3on-sphere :rad 1d0) 8 | :xy (vec:rep 500d0))) 9 | (sphere (rnd:3in-sphere :rad 1000d0)) 10 | (pts (math:nrep 10 (rnd:3in-sphere :rad 1000d0))) 11 | (proj2 (ortho:import-data (ortho:export-data proj)))) 12 | 13 | (do-test (ortho:project proj sphere) 14 | #s(vec:vec :x 428.26535543321796d0 :y 413.50713561727366d0)) 15 | 16 | (do-test (ortho:project* proj pts) 17 | '((#s(vec:vec :x 368.74896389212864d0 :y 280.279598957188d0) 1305.1359664407541d0) 18 | (#s(vec:vec :x 422.7747896862477d0 :y 759.894952721563d0) 774.1574761075917d0) 19 | (#s(vec:vec :x 340.1637221124419d0 :y 601.1791164318078d0) 504.2327213069508d0) 20 | (#s(vec:vec :x 584.4022680047473d0 :y 465.60940751781754d0) 605.6901110310558d0) 21 | (#s(vec:vec :x 473.21193676547676d0 :y 530.7950575570878d0) 854.8853502297287d0) 22 | (#s(vec:vec :x 551.8525560829912d0 :y 566.5564812868154d0) 1452.1762487835977d0) 23 | (#s(vec:vec :x 303.8705766210252d0 :y 299.92988593987775d0) 1288.9462886925376d0) 24 | (#s(vec:vec :x 490.33700083746317d0 :y 311.2203720974637d0) 349.7004840498294d0) 25 | (#s(vec:vec :x 428.3508272389861d0 :y 319.37297224061194d0) 821.4113295304979d0) 26 | (#s(vec:vec :x 661.854180254181d0 :y 485.4092153081456d0) 178.85371424194935d0))) 27 | 28 | (do-test (ortho:project* proj pts) 29 | '((#s(vec:vec :x 368.74896389212864d0 :y 280.279598957188d0) 1305.1359664407541d0) 30 | (#s(vec:vec :x 422.7747896862477d0 :y 759.894952721563d0) 774.1574761075917d0) 31 | (#s(vec:vec :x 340.1637221124419d0 :y 601.1791164318078d0) 504.2327213069508d0) 32 | (#s(vec:vec :x 584.4022680047473d0 :y 465.60940751781754d0) 605.6901110310558d0) 33 | (#s(vec:vec :x 473.21193676547676d0 :y 530.7950575570878d0) 854.8853502297287d0) 34 | (#s(vec:vec :x 551.8525560829912d0 :y 566.5564812868154d0) 1452.1762487835977d0) 35 | (#s(vec:vec :x 303.8705766210252d0 :y 299.92988593987775d0) 1288.9462886925376d0) 36 | (#s(vec:vec :x 490.33700083746317d0 :y 311.2203720974637d0) 349.7004840498294d0) 37 | (#s(vec:vec :x 428.3508272389861d0 :y 319.37297224061194d0) 821.4113295304979d0) 38 | (#s(vec:vec :x 661.854180254181d0 :y 485.4092153081456d0) 178.85371424194935d0))))) 39 | 40 | 41 | (define-file-tests test-ortho () 42 | (test-title (%test-ortho))) 43 | -------------------------------------------------------------------------------- /test/parallel.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun test-par () 4 | (parallel:init) 5 | (parallel:info) 6 | (parallel:end)) 7 | 8 | 9 | (define-file-tests test-parallel () 10 | (test-title (test-par))) 11 | -------------------------------------------------------------------------------- /test/pigment.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %test-pigment () 4 | 5 | (do-test (pigment:rgb 0.1d0 1d0 0.5d0) 6 | #s(pigment:rgba :r 0.1d0 :g 1.0d0 :b 0.5d0 :a 1.0d0)) 7 | 8 | (do-test (pigment:to-list (pigment:rgb 0.1d0 1d0 0.5d0 0.2d0)) 9 | (list 0.10000000000000002d0 1.0d0 0.5d0 0.2d0)) 10 | 11 | (do-test (pigment:hsv 0.5d0 1d0 1d0) (pigment:rgb 0d0 1d0 1d0)) 12 | 13 | (do-test (pigment:to-list (pigment:rgb 0d0 1d0 1d0 0.5d0)) 14 | (list 0.0d0 1.0d0 1.0d0 0.5d0)) 15 | 16 | (do-test (pigment:to-list* (pigment:rgb 0d0 1d0 1d0 0.5d0)) 17 | (list 0.0d0 0.5d0 0.5d0 0.5d0)) 18 | 19 | (do-test (pigment:cmyk 1d0 0d0 0d0 0d0) 20 | #s(pigment:rgba :r 0.0d0 :g 1.0d0 :b 1.0d0 :a 1.0d0)) 21 | 22 | (do-test (pigment:cmyk 0.5d0 0d0 0d0 0.5d0) 23 | #s(pigment:rgba :r 0.25d0 :g 0.5d0 :b 0.5d0 :a 1.0d0)) 24 | 25 | (do-test (pigment:to-hex (pigment:rgb 1d0 0d0 1d0)) "#FF00FF") 26 | 27 | (do-test (pigment:to-hex (pigment:rgb 1d0 0.5d0 1d0)) "#FF80FF") 28 | 29 | (do-test (pigment:to-hex (pigment:rgb 0d0 0d0 0d0)) "#000000") 30 | 31 | (do-test (pigment:to-hex (pigment:rgb 0d0 0.03d0 0.01d0)) "#000702") 32 | 33 | (do-test (pigment:scale (pigment:rgb 0.8d0 0.8d0 0.8d0 0.4d0) 0.1d0) 34 | #s(pigment:rgba :r 0.03200000000000001d0 35 | :g 0.03200000000000001d0 36 | :b 0.03200000000000001d0 37 | :a 0.04000000000000001d0)) 38 | 39 | (do-test (pigment:scale! (pigment:rgb 0.8d0 0.8d0 0.8d0 0.4d0) 0.1d0) 40 | #s(pigment:rgba :r 0.03200000000000001d0 41 | :g 0.03200000000000001d0 42 | :b 0.03200000000000001d0 43 | :a 0.04000000000000001d0)) 44 | 45 | (do-test (pigment:safe-clamp! 46 | (pigment:non-a-add (pigment:rgb 0.8d0 0.8d0 0.8d0 0.4d0) 47 | (pigment:red))) 48 | #s(pigment:rgba :r 1.0d0 49 | :g 0.32000000000000006d0 50 | :b 0.32000000000000006d0 51 | :a 1.0d0)) 52 | ;rgb 51, 102, 178, 53 | ;hsv 0.597, 0.71, 0.698 54 | (do-test (pigment:as-hsv (pigment:rgb 0.2d0 0.4d0 0.7d0)) 55 | '(0.6d0 0.7142857142857143d0 0.7d0 1.0d0)) 56 | 57 | (do-test (pigment:as-hsv (pigment:rgb 1d0 0.0d0 0.01d0)) 58 | '(0.9983333333333333d0 1.0d0 1.0d0 1.0d0)) 59 | 60 | (do-test (pigment:as-hsv (pigment:rgb 0d0 1d0 1d0)) 61 | '(0.5d0 1.0d0 1.0d0 1.0d0))) 62 | 63 | 64 | (define-file-tests test-pigment () 65 | (test-title (%test-pigment))) 66 | -------------------------------------------------------------------------------- /test/pix-overlap.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %main-pix-overlap (size) 4 | (let ((sand (sandpaint:make :size size 5 | :fg (pigment:white 1d0) 6 | :bg (pigment:gray 0.1d0)))) 7 | 8 | (sandpaint:pix-overlap sand (list (vec:vec 101.1d0 101.1d0) 9 | (vec:vec 105.0d0 101.1d0) 10 | (vec:vec 111.7d0 101.1d0) 11 | 12 | (vec:vec 101.1d0 105.0d0) 13 | (vec:vec 105.0d0 105.0d0) 14 | (vec:vec 111.7d0 105.0d0) 15 | 16 | (vec:vec 101.1d0 111.7d0) 17 | (vec:vec 105.0d0 111.7d0) 18 | (vec:vec 111.7d0 111.7d0))) 19 | 20 | (sandpaint:set-fg sand (pigment:rgb 0d0 1d0 0d0)) 21 | 22 | (sandpaint:pix-overlap sand (list (vec:vec 151.7d0 151.7d0) 23 | (vec:vec 155.0d0 151.7d0) 24 | (vec:vec 161.1d0 151.7d0) 25 | 26 | (vec:vec 151.7d0 155.0d0) 27 | (vec:vec 155.0d0 155.0d0) 28 | (vec:vec 161.1d0 155.0d0) 29 | 30 | (vec:vec 151.7d0 161.1d0) 31 | (vec:vec 155.0d0 161.1d0) 32 | (vec:vec 161.1d0 161.1d0))) 33 | 34 | (loop for v in (rnd:nin-rect 5000000 50d0 50d0 :xy (vec:rep 240d0)) 35 | do (sandpaint:set-fg sand (pigment:rgb (rnd:rnd) (rnd:rnd) (rnd:rnd))) 36 | (sandpaint:pix-overlap* sand v)) 37 | 38 | (loop for v in (rnd:nin-rect 5000000 50d0 50d0 :xy (vec:rep 240d0)) 39 | do (sandpaint:set-fg sand (pigment:rgb (rnd:rnd) (rnd:rnd) (rnd:rnd))) 40 | (sandpaint:pix-overlap* sand v)) 41 | 42 | (sandpaint:save sand (weir-utils:internal-path-string 43 | "test/data/pix-overlap")))) 44 | 45 | 46 | (define-file-tests test-pix-overlap () 47 | (%main-pix-overlap 300)) 48 | 49 | 50 | 51 | ;; (require :sb-sprof) 52 | ;(sb-sprof:with-profiling (:max-samples 200000 53 | ; :mode :cpu 54 | ; ;:mode :alloc 55 | ; ;:mode :time 56 | ; :report :graph) 57 | ; (%main-pix-overlap 300)) 58 | -------------------------------------------------------------------------------- /test/plot-cpath.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | 4 | (defun make-line (xy s &optional a) 5 | (let ((res (list (vec:add xy (vec:vec 0d0 (- s))) 6 | (vec:add xy (vec:vec 6d0 0d0)) 7 | (vec:add xy (vec:vec 0d0 s))))) 8 | (if a (rot res a xy) res))) 9 | 10 | (defun make-line* (xy s &optional a) 11 | (let ((res (list (vec:add xy (vec:vec 0d0 (+ s))) 12 | (vec:add xy (vec:vec 6d0 0d0)) 13 | (vec:add xy (vec:vec 0d0 (- s)))))) 14 | (if a (rot res a xy) res))) 15 | 16 | 17 | (defun make-box (xy s &optional a) 18 | (let ((res (list (vec:add xy (vec:vec (- s) (- s))) 19 | (vec:add xy (vec:vec s (- s))) 20 | (vec:add xy (vec:vec s s)) 21 | (vec:add xy (vec:vec (- s) s))))) 22 | (if a (rot res a xy) res))) 23 | 24 | (defun make-box* (xy s &optional a) 25 | (let ((res (list (vec:add xy (vec:vec (- s) (- s))) 26 | (vec:add xy (vec:vec (- s) s)) 27 | (vec:add xy (vec:vec s s)) 28 | (vec:add xy (vec:vec s (- s)))))) 29 | (if a (rot res a xy) res))) 30 | 31 | 32 | (defun make-s (xy s &optional a) 33 | (let ((res (list (vec:add xy (vec:vec (- s) (- s))) 34 | (vec:add xy (vec:vec s (- s))) 35 | (vec:add xy (vec:vec s 0d0)) 36 | (vec:add xy (vec:vec (- s) 0d0)) 37 | (vec:add xy (vec:vec (- s) s)) 38 | (vec:add xy (vec:vec s s))))) 39 | (if a (rot res a xy) res))) 40 | 41 | 42 | (defun rot (v a xy) 43 | (loop for b in v collect (vec:rot b a :xy xy))) 44 | 45 | 46 | (defun %main-plot-cpath () 47 | (let ((psvg (draw-svg:make* :stroke-width 1d0 48 | :rep-scale 0.5d0))) 49 | (let ((res (make-adjustable-vector))) 50 | 51 | (loop for a in (math:linspace 15 0d0 (* 2d0 PI)) 52 | and x in (math:linspace 15 60d0 940d0) do 53 | (vextend (list nil (make-box (vec:vec x 100d0) 10d0 a)) res) 54 | (vextend (list nil (make-box* (vec:vec x 200d0) 10d0 a)) res) 55 | 56 | (vextend (list nil (make-line (vec:vec x 490d0) 10d0 a)) res) 57 | (vextend (list nil (make-line* (vec:vec x 510d0) 10d0 a)) res) 58 | 59 | (vextend (list t (make-box (vec:vec x 300d0) 10d0 a)) res) 60 | (vextend (list t (make-box* (vec:vec x 400d0) 10d0 a)) res) 61 | 62 | (vextend (list t (make-s (vec:vec x 700d0) 20d0 (rnd:rnd* PI))) res) 63 | (vextend (list nil (make-s (vec:vec x 600d0) 20d0 (rnd:rnd* PI))) res)) 64 | 65 | (vextend (list t (list (vec:vec 400d0 900d0) 66 | (vec:vec 300d0 900d0) 67 | (vec:vec 300d0 970d0))) res) 68 | (vextend (list nil (list (vec:vec 700d0 900d0) 69 | (vec:vec 500d0 900d0) 70 | (vec:vec 500d0 970d0))) res) 71 | (vextend (list t (list (vec:vec 100d0 800d0) 72 | (vec:vec 300d0 800d0) 73 | (vec:vec 300d0 870d0))) res) 74 | 75 | (vextend (list nil (list (vec:vec 400d0 800d0) 76 | (vec:vec 600d0 800d0) 77 | (vec:vec 600d0 870d0))) res) 78 | 79 | (vextend (list nil (list (vec:vec 800d0 800d0) 80 | (vec:vec 800d0 900d0))) res) 81 | 82 | (vextend (list nil (list (vec:vec 850d0 800d0) 83 | (vec:vec 850d0 850d0) 84 | (vec:vec 850d0 900d0))) res) 85 | 86 | (vextend (list nil (list (vec:vec 750d0 800d0) 87 | (vec:vec 750d0 850d0) 88 | (vec:vec 770d0 840d0) 89 | (vec:vec 750d0 900d0))) res) 90 | 91 | (vextend (list nil (list (vec:vec 700d0 800d0) 92 | (vec:vec 700d0 850d0) 93 | (vec:vec 700.1d0 840d0) 94 | (vec:vec 700d0 900d0))) res) 95 | 96 | (vextend (list nil (list (vec:vec 650d0 800d0) 97 | (vec:vec 650d0 850d0) 98 | (vec:vec 650d0 840d0) 99 | (vec:vec 650d0 900d0))) res) 100 | 101 | 102 | (vextend (list nil (list (vec:vec 900d0 900d0) 103 | (vec:vec 900d0 800d0))) res) 104 | (vextend (list nil (rot (list (vec:vec 900d0 900d0) 105 | (vec:vec 900d0 800d0)) 106 | (rnd:rnd*) 107 | (vec:vec 900d0 900d0))) res) 108 | 109 | ;180 flip 110 | (vextend (list nil (list (vec:vec 20d0 900d0) 111 | (vec:vec 70d0 900d0) 112 | (vec:vec 70d0 970d0) 113 | (vec:vec 90d0 850d0) 114 | (vec:vec 120d0 850d0))) res) 115 | 116 | (loop for (c box) across res do 117 | (draw-svg:cpath psvg (to-list (simplify-path:simplify 118 | (to-vector box :type 'vec:vec) 119 | :lim 1d0)) 120 | :width 15d0 :closed c))) 121 | 122 | (draw-svg:save psvg (weir-utils:internal-path-string 123 | "test/data/plot-cpath")))) 124 | 125 | (define-file-tests test-plot-cpath () 126 | (time (%main-plot-cpath))) 127 | 128 | -------------------------------------------------------------------------------- /test/plot-jpath.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | 4 | (defun jpath-make-line (xy s &optional a) 5 | (let ((res (list (vec:add xy (vec:vec 0d0 (- s))) 6 | (vec:add xy (vec:vec 6d0 0d0)) 7 | (vec:add xy (vec:vec 0d0 s))))) 8 | (if a (rot res a xy) res))) 9 | 10 | (defun jpath-make-line* (xy s &optional a) 11 | (let ((res (list (vec:add xy (vec:vec 0d0 (+ s))) 12 | (vec:add xy (vec:vec 6d0 0d0)) 13 | (vec:add xy (vec:vec 0d0 (- s)))))) 14 | (if a (rot res a xy) res))) 15 | 16 | 17 | (defun jpath-make-box (xy s &optional a) 18 | (let ((res (list (vec:add xy (vec:vec (- s) (- s))) 19 | (vec:add xy (vec:vec s (- s))) 20 | (vec:add xy (vec:vec s s)) 21 | (vec:add xy (vec:vec (- s) s))))) 22 | (if a (rot res a xy) res))) 23 | 24 | (defun jpath-make-box* (xy s &optional a) 25 | (let ((res (list (vec:add xy (vec:vec (- s) (- s))) 26 | (vec:add xy (vec:vec (- s) s)) 27 | (vec:add xy (vec:vec s s)) 28 | (vec:add xy (vec:vec s (- s)))))) 29 | (if a (rot res a xy) res))) 30 | 31 | 32 | (defun jpath-make-s (xy s &optional a) 33 | (let ((res (list (vec:add xy (vec:vec (- s) (- s))) 34 | (vec:add xy (vec:vec s (- s))) 35 | (vec:add xy (vec:vec s 0d0)) 36 | (vec:add xy (vec:vec (- s) 0d0)) 37 | (vec:add xy (vec:vec (- s) s)) 38 | (vec:add xy (vec:vec s s))))) 39 | (if a (rot res a xy) res))) 40 | 41 | 42 | (defun rot% (v a xy) 43 | (loop for b in v collect (vec:rot b a :xy xy))) 44 | 45 | 46 | (defun %main-plot-jpath () 47 | (let ((psvg (draw-svg:make* :stroke-width 1d0 48 | :rep-scale 0.5d0))) 49 | (let ((res (make-adjustable-vector))) 50 | 51 | (loop for a in (math:linspace 15 0d0 (* 2d0 PI)) 52 | and x in (math:linspace 15 60d0 940d0) do 53 | (vextend (list nil (jpath-make-box (vec:vec x 100d0) 10d0 a)) res) 54 | (vextend (list nil (jpath-make-box* (vec:vec x 200d0) 10d0 a)) res) 55 | 56 | (vextend (list nil (jpath-make-line (vec:vec x 490d0) 10d0 a)) res) 57 | (vextend (list nil (jpath-make-line* (vec:vec x 510d0) 10d0 a)) res) 58 | 59 | (vextend (list t (jpath-make-box (vec:vec x 300d0) 10d0 a)) res) 60 | (vextend (list t (jpath-make-box* (vec:vec x 400d0) 10d0 a)) res) 61 | 62 | (vextend (list t (jpath-make-s (vec:vec x 700d0) 20d0 (rnd:rnd* PI))) res) 63 | (vextend (list nil (jpath-make-s (vec:vec x 600d0) 20d0 (rnd:rnd* PI))) res)) 64 | 65 | (vextend (list t (list (vec:vec 400d0 900d0) 66 | (vec:vec 300d0 900d0) 67 | (vec:vec 300d0 970d0))) res) 68 | (vextend (list nil (list (vec:vec 700d0 900d0) 69 | (vec:vec 500d0 900d0) 70 | (vec:vec 500d0 970d0))) res) 71 | (vextend (list t (list (vec:vec 100d0 800d0) 72 | (vec:vec 300d0 800d0) 73 | (vec:vec 300d0 870d0))) res) 74 | 75 | (vextend (list nil (list (vec:vec 400d0 800d0) 76 | (vec:vec 600d0 800d0) 77 | (vec:vec 600d0 870d0))) res) 78 | 79 | (vextend (list nil (list (vec:vec 800d0 800d0) 80 | (vec:vec 800d0 900d0))) res) 81 | 82 | (vextend (list nil (list (vec:vec 850d0 800d0) 83 | (vec:vec 850d0 850d0) 84 | (vec:vec 850d0 900d0))) res) 85 | 86 | (vextend (list nil (list (vec:vec 750d0 800d0) 87 | (vec:vec 750d0 850d0) 88 | (vec:vec 770d0 840d0) 89 | (vec:vec 750d0 900d0))) res) 90 | 91 | (vextend (list nil (list (vec:vec 700d0 800d0) 92 | (vec:vec 700d0 850d0) 93 | (vec:vec 700.1d0 840d0) 94 | (vec:vec 700d0 900d0))) res) 95 | 96 | (vextend (list nil (list (vec:vec 650d0 800d0) 97 | (vec:vec 650d0 850d0) 98 | (vec:vec 650d0 840d0) 99 | (vec:vec 650d0 900d0))) res) 100 | 101 | 102 | (vextend (list nil (list (vec:vec 900d0 900d0) 103 | (vec:vec 900d0 800d0))) res) 104 | (vextend (list nil (rot% (list (vec:vec 900d0 900d0) 105 | (vec:vec 900d0 800d0)) 106 | (rnd:rnd*) 107 | (vec:vec 900d0 900d0))) res) 108 | 109 | ;180 flip 110 | (vextend (list nil (list (vec:vec 20d0 900d0) 111 | (vec:vec 70d0 900d0) 112 | (vec:vec 70d0 970d0) 113 | (vec:vec 90d0 850d0) 114 | (vec:vec 120d0 850d0))) res) 115 | 116 | (loop for (c box) across res do 117 | (draw-svg:jpath psvg (to-list (simplify-path:simplify 118 | (to-vector box :type 'vec:vec) 119 | :lim 1d0)) 120 | :width 15d0 :closed c))) 121 | 122 | (draw-svg:save psvg (weir-utils:internal-path-string 123 | "test/data/plot-jpath")))) 124 | 125 | (define-file-tests test-plot-jpath () 126 | (time (%main-plot-jpath))) 127 | 128 | -------------------------------------------------------------------------------- /test/plot-outline-path.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | 4 | (defun %main-plot-outline-path () 5 | (let ((psvg (draw-svg:make*))) 6 | 7 | (draw-svg:path psvg (cpath:outline (list (vec:vec 100d0 300d0) 8 | (vec:vec 300d0 300d0) 9 | (vec:vec 300d0 100d0) 10 | (vec:vec 100d0 100d0)) 11 | (list 20d0 30d0 40d0 20d0))) 12 | 13 | (draw-svg:path psvg (cpath:outline (list (vec:vec 600d0 500d0) 14 | (vec:vec 500d0 500d0) 15 | (vec:vec 500d0 600d0) 16 | (vec:vec 600d0 600d0)) 17 | (list 20d0 30d0 70d0 20d0) 18 | :closed t)) 19 | 20 | (loop with outline = (cpath:outline (list (vec:vec 800d0 700d0) 21 | (vec:vec 700d0 700d0) 22 | (vec:vec 700d0 800d0) 23 | (vec:vec 800d0 800d0)) 24 | (list 10d0 10d0 30d0 10d0) 25 | :closed t) 26 | for path in (to-list (hatch:hatch (to-vector outline) :rs 2.51d0 27 | :angles (list 0d0 PI5))) 28 | do (draw-svg:path psvg path)) 29 | 30 | (draw-svg:save psvg (weir-utils:internal-path-string 31 | "test/data/plot-outline-path")))) 32 | 33 | (define-file-tests test-plot-outline-path () 34 | (time (%main-plot-outline-path))) 35 | -------------------------------------------------------------------------------- /test/plot-paths.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %main-plot-paths () 4 | 5 | (rnd:set-rnd-state 76) 6 | 7 | (let* ((size 1000d0) 8 | (mid (vec:rep (* 0.5d0 size))) 9 | (psvg (draw-svg:make* :height size :width size)) 10 | (wer (weir:make))) 11 | 12 | (weir:add-path! wer (bzspl:adaptive-pos 13 | (bzspl:make (rnd:nin-circ 5 400d0 :xy mid)) 14 | :lim 2d0) 15 | :closed t) 16 | 17 | (weir:add-path! wer (bzspl:adaptive-pos 18 | (bzspl:make (rnd:nin-circ 5 400d0 :xy mid)) 19 | :lim 2d0) 20 | :closed t) 21 | 22 | (weir:intersect-all! wer) 23 | 24 | (loop for lp in (weir:get-segments wer) 25 | do (draw-svg:path psvg (weir:get-verts wer lp) 26 | :stroke "red" :sw 5d0)) 27 | 28 | (loop for lp in (weir:walk-graph wer) 29 | do (draw-svg:path psvg (weir:get-verts wer lp) 30 | :sw 1d0)) 31 | 32 | (draw-svg:save psvg 33 | (weir-utils:internal-path-string 34 | "test/data/plot-paths")))) 35 | 36 | (define-file-tests test-plot-paths () 37 | (time (%main-plot-paths))) 38 | 39 | -------------------------------------------------------------------------------- /test/plot-simplify.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %main-plot-simplify () 4 | (let ((psvg (draw-svg:make* :width 1000d0 5 | :height 1000d0 6 | :stroke-width 1d0 7 | :rep-scale 0.5d0))) 8 | 9 | (loop for x in (math:linspace 7 80d0 920d0) do 10 | (loop for y in (math:linspace 7 80d0 920d0) do 11 | (let ((path (rnd:nin-rect 5 40d0 40d0 :xy (vec:vec x y)))) 12 | (draw-svg:path psvg (vec:ladd* path (vec:vec 20d0 0d0))) 13 | (draw-svg:cpath psvg (to-list (simplify-path:simplify 14 | (to-vector 15 | (vec:ladd* path (vec:vec -20d0 0d0)) 16 | :type 'vec:vec) 17 | :lim 10d0)) 18 | :width 10d0)))) 19 | 20 | (draw-svg:save psvg (weir-utils:internal-path-string 21 | "test/data/plot-simplify")))) 22 | 23 | (define-file-tests test-plot-simplify () 24 | (time (%main-plot-simplify))) 25 | -------------------------------------------------------------------------------- /test/plot.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %main-plot () 4 | (let ((p (list (vec:vec 100d0 100d0) (vec:vec 200d0 100d0) 5 | (vec:vec 200d0 200d0))) 6 | (psvg (draw-svg:make*))) 7 | 8 | (draw-svg:show-boundary psvg) 9 | (draw-svg:show-crop psvg :len 20d0) 10 | 11 | (draw-svg:path psvg p) 12 | (draw-svg:path psvg (vec:ladd* p (vec:vec 200d0 0d0)) :closed t) 13 | (draw-svg:path psvg (vec:ladd* p (vec:vec 400d0 0d0)) :closed t :sw 10d0) 14 | (draw-svg:path psvg (vec:ladd* p (vec:vec 600d0 0d0)) 15 | :closed t :fill "black") 16 | 17 | (draw-svg:bzspl psvg (vec:ladd* p (vec:vec 0d0 200d0))) 18 | (draw-svg:bzspl psvg (vec:ladd* p (vec:vec 200d0 200d0)) :closed t) 19 | (draw-svg:bzspl psvg (vec:ladd* p (vec:vec 400d0 200d0)) :closed t :sw 10d0) 20 | (draw-svg:bzspl psvg (vec:ladd* p (vec:vec 600d0 200d0)) :closed t 21 | :fill "black") 22 | 23 | (draw-svg:circ psvg (vec:vec 100d0 500d0) 20d0) 24 | (draw-svg:circ psvg (vec:vec 200d0 500d0) 20d0 :sw 10d0) 25 | (draw-svg:circ psvg (vec:vec 300d0 500d0) 20d0 :sw 10d0 :fill "black") 26 | (draw-svg:circ psvg (vec:vec 400d0 500d0) 20d0 :aspath t) 27 | 28 | (draw-svg:carc psvg (vec:vec 500d0 500d0) 20d0 0d0 PI5 :sw 2d0) 29 | (draw-svg:circ psvg (vec:vec 500d0 500d0) 15d0) 30 | 31 | (draw-svg:carc psvg (vec:vec 560d0 500d0) 20d0 0d0 4d0 :sw 3d0) 32 | (draw-svg:circ psvg (vec:vec 560d0 500d0) 15d0) 33 | 34 | (draw-svg:carc psvg (vec:vec 620d0 500d0) 20d0 0.5d0 1d0 :sw 4d0) 35 | (draw-svg:circ psvg (vec:vec 620d0 500d0) 15d0) 36 | 37 | (draw-svg:carc psvg (vec:vec 700d0 500d0) 20d0 3.4d0 5d0 :sw 5d0) 38 | (draw-svg:circ psvg (vec:vec 700d0 500d0) 15d0) 39 | 40 | (draw-svg:wcirc psvg (vec:vec 800d0 500d0) 15d0 :rs 0.7d0) 41 | (draw-svg:wcirc psvg (vec:vec 850d0 500d0) 15d0 :outer-rad 20d0 :rs 0.7d0) 42 | 43 | (draw-svg:wpath psvg (vec:ladd* p (vec:vec 0d0 600d0)) :width 10d0 :rs 0.5d0) 44 | (draw-svg:wpath psvg (vec:ladd* p (vec:vec 200d0 600d0)) :width 10d0 :rs 0.5d0 45 | :cap nil) 46 | (draw-svg:wpath psvg (vec:ladd* p (vec:vec 400d0 600d0)) :width 10d0 :rs 0.5d0 47 | :cap nil 48 | :opposite nil) 49 | 50 | ;(draw-svg:compound psvg (list (list :path (list (vec:vec 700d0 700d0) 51 | ; (vec:vec 720d0 730d0) 52 | ; (vec:vec 730d0 710d0))) 53 | ; (list :bzspl (list (vec:vec 700d0 700d0) 54 | ; (vec:vec 720d0 730d0) 55 | ; (vec:vec 730d0 710d0))))) 56 | 57 | (draw-svg:save psvg (weir-utils:internal-path-string 58 | "test/data/plot")))) 59 | 60 | (define-file-tests test-plot () 61 | (time (%main-plot))) 62 | -------------------------------------------------------------------------------- /test/rnd.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun %test-rnd () 4 | (do-test (length (rnd:rndspace 10 0d0 10d0)) 10) 5 | 6 | (do-test 7 | (rnd:rndspace 10 0d0 10d0) '(8.383887417540674d0 3.704390759927394d0 8 | 4.089044985321939d0 7.5623438794824605d0 9 | 0.5477479401961061d0 3.409356250400757d0 10 | 8.3460946770173d0 1.1737959928376207d0 11 | 2.8077405846385473d0 3.962028297321658d0)) 12 | 13 | (do-test 14 | (rnd:rndspace 10 0d0 10d0 :order t) 15 | '(0.7810904793737161d0 1.700886055024764d0 3.396607010299655d0 16 | 3.8464500251059364d0 6.014897498803242d0 6.268483093269445d0 17 | 7.527788782312825d0 7.562853532104885d0 7.892139712781054d0 18 | 9.365232493948968d0)) 19 | 20 | (do-test (rnd:rndspacei 10 0 10) '(0 5 4 6 9 4 5 1 6 2)) 21 | 22 | (do-test (rnd:rndspacei 10 0 10 :order t) '(0 0 1 3 4 6 6 7 7 8)) 23 | 24 | (do-test (length (rnd:nrndi 9 4)) 9) 25 | 26 | (do-test (length (rnd:nrnd 11 4d0)) 11) 27 | 28 | (do-test (length (rnd:nrnd 12 4d0)) 12) 29 | 30 | (do-test (length (rnd:nrnd* 12 4d0)) 12) 31 | 32 | (do-test (rnd:bernoulli 4 0.5d0) '(1.0d0 1.0d0 1.0d0 0.0d0)) 33 | 34 | (do-test 35 | (let ((a (list))) 36 | (rnd:with-rndspace (10 0d0 7d0 v) 37 | (setf a (append a (list v)))) 38 | a) 39 | '(3.685259713645226d0 4.991448661044605d0 3.539035793913204d0 40 | 5.3387868441394275d0 0.1633726540474778d0 6.973528243894615d0 41 | 1.0330884964197056d0 4.0173212494133175d0 0.8969394201134988d0 42 | 4.974343346335651d0)) 43 | 44 | (do-test 45 | (let ((a (list))) 46 | (rnd:with-on-line (10 (vec:vec 1d0 1d0) (vec:vec 4d0 3d0) v) 47 | (setf a (append a (list v)))) 48 | a) 49 | '(#s(vec:vec :x 3.6510221714119075d0 :y 2.767348114274605d0) 50 | #s(vec:vec :x 3.2788197623070983d0 :y 2.519213174871399d0) 51 | #s(vec:vec :x 2.57752200139861d0 :y 2.0516813342657403d0) 52 | #s(vec:vec :x 2.6295687876114506d0 :y 2.086379191740967d0) 53 | #s(vec:vec :x 2.8081607900724164d0 :y 2.2054405267149444d0) 54 | #s(vec:vec :x 2.6364353670451637d0 :y 2.0909569113634423d0) 55 | #s(vec:vec :x 1.917579631743151d0 :y 1.611719754495434d0) 56 | #s(vec:vec :x 1.471804219412153d0 :y 1.3145361462747687d0) 57 | #s(vec:vec :x 1.0540501192343574d0 :y 1.036033412822905d0) 58 | #s(vec:vec :x 2.2542534559338394d0 :y 1.8361689706225595d0))) 59 | 60 | (do-test 61 | (let ((a (list))) 62 | (rnd:with-in-circ (10 4d0 v) 63 | (setf a (append a (list v)))) 64 | a) 65 | '(#s(vec:vec :x -3.4812725617482108d0 :y -1.4342021415902404d0) 66 | #s(vec:vec :x -3.3258558236239657d0 :y -1.7087563072788825d0) 67 | #s(vec:vec :x 1.4951268602022627d0 :y 2.192229972199324d0) 68 | #s(vec:vec :x 2.253706810614843d0 :y 3.03441459039537d0) 69 | #s(vec:vec :x 0.49135907411120827d0 :y -1.8789342181108328d0) 70 | #s(vec:vec :x -3.713396150291062d0 :y 0.09010719936315531d0) 71 | #s(vec:vec :x 1.6173087868317984d0 :y 0.4103238784840838d0) 72 | #s(vec:vec :x -0.2918348851951156d0 :y 0.26535108277767916d0) 73 | #s(vec:vec :x -2.907379354217956d0 :y 1.2646150403903704d0) 74 | #s(vec:vec :x 0.721218948201519d0 :y 0.4664641316794225d0))) 75 | 76 | (do-test 77 | (rnd:on-line (vec:vec 101d0 204d0) (vec:vec 433d0 454d0)) 78 | '#s(vec:vec :x 168.8180327694698d0 :y 255.06779576014293d0)) 79 | 80 | (do-test 81 | (rnd:on-circ 303d0 :xy (vec:vec 303d0 73d0)) 82 | '#s(vec:vec :x 35.162028047713875d0 :y -68.67505348679558d0)) 83 | 84 | (do-test 85 | (rnd:in-circ 303d0 :xy (vec:vec 303d0 73d0)) 86 | '#s(vec:vec :x 19.70338976631723d0 :y 80.90208708999396d0)) 87 | 88 | (do-test 89 | (rnd:non-line 5 (vec:vec 101d0 204d0) (vec:vec 433d0 454d0)) 90 | '(#s(vec:vec :x 285.8034603362477d0 :y 343.1592321809094d0) 91 | #s(vec:vec :x 256.12514561556054d0 :y 320.81110362617505d0) 92 | #s(vec:vec :x 161.79341742713638d0 :y 249.77817577344607d0) 93 | #s(vec:vec :x 147.5244311387897d0 :y 239.03345718282358d0) 94 | #s(vec:vec :x 378.5032484646158d0 :y 412.9632895064878d0))) 95 | 96 | (do-test 97 | (rnd:nin-circ 5 20d0 :xy (vec:vec 433d0 454d0)) 98 | '(#s(vec:vec :x 441.7151991128114d0 :y 442.14508334151736d0) 99 | #s(vec:vec :x 433.01811203629177d0 :y 442.409624270997d0) 100 | #s(vec:vec :x 431.438760580709d0 :y 471.0048750395453d0) 101 | #s(vec:vec :x 418.4796027137922d0 :y 444.94482543208636d0) 102 | #s(vec:vec :x 442.6150368837021d0 :y 439.81657589291336d0))) 103 | 104 | (do-test (rnd:nrnd* 10 2d0) 105 | '(0.7732920786153752d0 -1.4975206167292585d0 -1.3312763499989444d0 106 | -0.2556656864522502d0 1.0693675499382618d0 1.7120034800835446d0 107 | 0.7654113290558548d0 0.9618451233891179d0 -0.3548773470929323d0 108 | -0.8865187381762034d0))) 109 | 110 | 111 | (define-file-tests test-rnd () 112 | (test-title (%test-rnd))) 113 | -------------------------------------------------------------------------------- /test/sandpaint.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun get-sample-pix (sand) 4 | (let ((vals (sandpaint::sandpaint-vals sand)) 5 | (indfx (sandpaint::sandpaint-indfx sand))) 6 | (alexandria:flatten 7 | (loop for i in '(10 45 45 92 23) 8 | and j in '(39 78 49 92 89) 9 | collect (list (aref vals (funcall indfx i j 0)) 10 | (aref vals (funcall indfx i j 1)) 11 | (aref vals (funcall indfx i j 2)) 12 | (aref vals (funcall indfx i j 3))))))) 13 | 14 | 15 | (defun %test-sandpaint () 16 | (let ((sand (sandpaint:make :size 100 17 | :fg (pigment:green) 18 | :bg (pigment:black)))) 19 | (loop for p in (rnd:nin-rect 500000 30d0 30d0 :xy (vec:vec 50d0 50d0)) do 20 | (sandpaint:set-fg sand (pigment:rgb (rnd:rnd) (rnd:rnd) 21 | (rnd:rnd) 0.004d0)) 22 | (sandpaint:pix sand (list p))) 23 | 24 | (loop for p in (rnd:nin-rect 500000 30d0 30d0 :xy (vec:vec 60d0 50d0)) do 25 | (sandpaint:set-fg sand (pigment:rgb (rnd:rnd) (rnd:rnd) 26 | (rnd:rnd) 0.004d0)) 27 | (sandpaint:pix sand (list p))) 28 | 29 | (loop for p in (rnd:nin-rect 500000 30d0 30d0 :xy (vec:vec 50d0 60d0)) do 30 | (sandpaint:set-fg sand (pigment:rgb (rnd:rnd) (rnd:rnd) 31 | (rnd:rnd) 0.004d0)) 32 | (sandpaint:pix sand (list p))) 33 | 34 | (do-test 35 | (get-sample-pix sand) 36 | '(0.0d0 0.0d0 0.0d0 1.0d0 0.39317154020166095d0 0.4106421499762462d0 37 | 0.3773218130882492d0 1.0d0 0.3975273152203998d0 0.4253778247192912d0 38 | 0.42339799985131144d0 1.0d0 0.0d0 0.0d0 0.0d0 1.0d0 39 | 0.22647985791951575d0 0.2203285988306688d0 0.22192693772741898d0 40 | 1.0d0)) 41 | 42 | (sandpaint:save sand (weir-utils:internal-path-string 43 | "test/data/sandpaint-rnd"))) 44 | 45 | (let ((sand (sandpaint:make :size 100 46 | :fg (pigment:black) 47 | :bg (pigment:transparent)))) 48 | 49 | (sandpaint:set-fg sand (pigment:red 0.1d0)) 50 | (sandpaint:pix sand (rnd:nin-rect 30000 40d0 50d0 :xy (vec:vec 50d0 50d0))) 51 | 52 | (sandpaint:set-fg sand (pigment:green 0.1d0)) 53 | (sandpaint:pix sand (rnd:nin-rect 30000 50d0 20d0 :xy (vec:vec 50d0 50d0))) 54 | 55 | (sandpaint:set-fg sand (pigment:blue 0.1d0)) 56 | (sandpaint:pix sand (rnd:nin-rect 30000 20d0 50d0 :xy (vec:vec 50d0 50d0))) 57 | 58 | (do-test 59 | (get-sample-pix sand) 60 | '(0.11991051555039006d0 0.6513215599000001d0 0.0d0 0.7712320754503901d0 61 | 0.18152935690535107d0 0.0d0 0.6125795110000001d0 0.7941088679053511d0 62 | 0.14013854335308507d0 0.24952897545039007d0 0.5217031000000001d0 63 | 0.911370618803475d0 0.0d0 0.0d0 0.0d0 0.0d0 0.271d0 0.0d0 0.0d0 64 | 0.271d0)) 65 | 66 | (sandpaint:save sand (weir-utils:internal-path-string 67 | "test/data/sandpaint-8")) 68 | (sandpaint:save sand (weir-utils:internal-path-string 69 | "test/data/sandpaint-16") :bits 16)) 70 | 71 | (let ((sand (sandpaint:make :size 300 72 | :fg (pigment:red 0.1d0) 73 | :bg (pigment:white)))) 74 | 75 | (sandpaint:pix sand (rnd:nin-circ 100000 50d0 :xy (vec:vec 0d0 150d0))) 76 | (sandpaint:pix sand (rnd:nin-circ 100000 50d0 :xy (vec:vec 150d0 150d0))) 77 | (sandpaint:pix sand (rnd:nin-circ 100000 50d0 :xy (vec:vec 300d0 150d0))) 78 | 79 | (sandpaint:save sand (weir-utils:internal-path-string 80 | "test/data/sandpaint-circ")))) 81 | 82 | 83 | (define-file-tests test-sandpaint () 84 | (test-title (%test-sandpaint))) 85 | -------------------------------------------------------------------------------- /test/test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:weir-tests 2 | (:use #:common-lisp #:weir-utils) 3 | (:export #:run-tests)) 4 | 5 | (in-package #:weir-tests) 6 | 7 | (defvar *tests*) 8 | (defvar *fails*) 9 | (defvar *passes*) 10 | (defvar *catastrophic*) 11 | 12 | 13 | (defun sort-a-list (a) 14 | (sort a #'string-lessp :key #'(lambda (x) (string (first x))))) 15 | 16 | 17 | ; TODO: should probably find a framework for this ... 18 | ; TODO: approximately similar to 19 | 20 | (defmacro test-title (&body body) 21 | `(progn 22 | (format t " 23 | 24 | 25 | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@> 26 | ~a 27 | 28 | " ',@body) ,@body)) 29 | 30 | 31 | (defmacro do-test (a b) 32 | (alexandria:with-gensyms (aname bname) 33 | `(let ((,aname ,a) 34 | (,bname ,b)) 35 | (incf *tests*) 36 | (if (equalp ,aname ,bname) 37 | (progn 38 | (incf *passes*) 39 | (format t " 40 | 41 | 42 | ~a 43 | 44 | -------------------------------------------------------------------------> pass" 45 | ',a)) 46 | 47 | (progn (incf *fails*) (format t " 48 | 49 | 50 | ~a 51 | 52 | ##########################################################################> fail 53 | -- wanted: 54 | ~a 55 | -- got: 56 | ~a 57 | ------------------------------------------------------------------------------- 58 | 59 | " ',a ,bname ,aname)))))) 60 | 61 | 62 | (defun %tests-summary () 63 | (format t "~% tests: ~a~% fails: ~a~% passes: ~a~%" 64 | *tests* *fails* *passes*) 65 | (when (> *catastrophic* 0) (print "--- at least one catastrophe! ---") 66 | (weir-utils:terminate 1)) 67 | (when (> *fails* 0) (print "--- at least one test failed! ---") 68 | (weir-utils:terminate 3))) 69 | 70 | 71 | ;;; test running for whole project 72 | 73 | (defvar *test-functions* nil) 74 | 75 | (defmacro define-file-tests (name () &body body) 76 | (alexandria:with-gensyms (cname) 77 | `(progn 78 | (defun ,name () 79 | (handler-case (progn ,@body) 80 | (error (,cname) 81 | (incf *catastrophic*) 82 | (warn "! ! ! Error when running file tests ~A.~% ~A" ',name ,cname)))) 83 | (pushnew ',name *test-functions*)))) 84 | 85 | (defun run-tests () 86 | (setf *tests* 0) 87 | (setf *passes* 0) 88 | (setf *fails* 0) 89 | (setf *catastrophic* 0) 90 | (dolist (test *test-functions*) 91 | (fresh-line) 92 | (format t "=============================================~%") 93 | (format t "============== Running file tests ~A~%" test) 94 | (format t "=============================================~2%") 95 | (rnd:set-rnd-state 1) ; Re-seed state before each 96 | ; test. 97 | (let ((*print-pretty* t)) 98 | (funcall test))) 99 | 100 | (%tests-summary)) 101 | 102 | -------------------------------------------------------------------------------- /test/weir-loop.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | 4 | (defun %test-weir-loop (size) 5 | 6 | (rnd:set-rnd-state 76) 7 | 8 | (let* ((mid (vec:rep (* 0.5d0 size))) 9 | (psvg (draw-svg:make* :height size :width size)) 10 | (wer (weir:make))) 11 | 12 | (weir:add-verts! wer (bzspl:adaptive-pos 13 | (bzspl:make (rnd:nin-circ 10 400d0 :xy mid)) 14 | :lim 2d0)) 15 | 16 | (weir:relative-neighborhood! wer 500d0) 17 | (weir:center! wer :xy mid) 18 | 19 | (weir:itr-edges (wer e) 20 | (draw-svg:path psvg (weir:get-verts wer e) :sw 2d0 21 | :stroke "black" :so 0.3d0)) 22 | 23 | (loop for edge in (weir:get-min-spanning-tree wer :start 0 :edges t) 24 | do (draw-svg:path psvg (weir:get-verts wer edge) :stroke "red" 25 | :sw 3d0 :so 1d0)) 26 | 27 | (loop for lp in (weir:get-cycle-basis wer) 28 | do (draw-svg:path psvg (weir:get-verts wer (progn lp)) 29 | :sw 0.5d0) 30 | (draw-svg:hatch psvg (weir:get-verts wer (progn lp)) 31 | :angles (list (rnd:rnd* PI)) 32 | :closed t 33 | :sw 0.3d0 34 | :rs 1d0)) 35 | 36 | (draw-svg:save psvg (weir-utils:internal-path-string 37 | "test/data/weir-loops")))) 38 | 39 | (define-file-tests test-weir-loop-draw () 40 | ;; TODO: other cases: 8407 4445 41 | (time (%test-weir-loop 600d0))) 42 | -------------------------------------------------------------------------------- /test/weir3.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weir-tests) 2 | 3 | (defun test-weir3 (wer) 4 | 5 | (do-test (weir:3add-vert! wer (vec:3vec 0d0 0d0 3d0)) 0) 6 | 7 | (do-test (weir:3add-vert! wer (vec:3vec 10d0 0d0 4d0)) 1) 8 | 9 | (do-test (weir:3add-vert! wer (vec:3vec 3d0 3d0 1d0)) 2) 10 | 11 | (do-test (weir:3add-vert! wer (vec:3vec 4d0 3d0 4d0)) 3) 12 | 13 | (do-test (weir:3add-vert! wer (vec:3vec 7d0 200d0 1d0)) 4) 14 | 15 | (do-test (weir:3add-vert! wer (vec:3vec 2d0 10d0 4d0)) 5) 16 | 17 | (do-test (weir:3get-vert wer 2) (vec:3vec 3d0 3d0 1d0)) 18 | 19 | (do-test (weir:ladd-edge! wer '(0 1)) (list 0 1)) 20 | 21 | (do-test (weir:3ledge-length wer '(0 1)) 10.04987562112089d0) 22 | 23 | (do-test (weir:3move-vert! wer 3 (vec:3vec 1d0 3d0 3d0) :ret t) (vec:3vec 5d0 6d0 7d0)) 24 | 25 | (do-test (weir:3move-vert! wer 4 (vec:3vec 0.5d0 0.6d0 1d0) :rel t :ret t) 26 | (vec:3vec 7.5d0 200.6d0 2d0))) 27 | 28 | 29 | (defun test-weir3-with () 30 | (let ((wer (weir:make :dim 3))) 31 | 32 | (weir:with (wer %) 33 | (% (weir:3add-vert? (vec:3vec 11d0 3d0 9d0))) 34 | (list 4.5 35 | (% (weir:3move-vert? 0 (vec:3vec 1d0 0d0 9d0))) 36 | nil 37 | t 38 | (list 5 (% (weir:3add-vert? (vec:3vec 12d0 3d0 3d0))) 39 | (% (weir:3add-vert? (vec:3vec 13d0 3d0 2d0)))) 40 | (list nil) 41 | (list (list)))) 42 | 43 | (do-test (weir:get-num-verts wer) 3)) 44 | 45 | (let ((wer (weir:make :dim 3))) 46 | 47 | (weir:with (wer %) 48 | (list) 49 | 1 nil 50 | (% (weir:3add-vert? (vec:3vec 12d0 3d0 2d0))) 51 | (% (weir:3add-vert? (vec:3vec 13d0 6d0 3d0))) 52 | (% (weir:3add-vert? (vec:3vec 13d0 3d0 3d0)))) 53 | 54 | (weir:with (wer %) 55 | (% (weir:add-edge? 1 2)) 56 | (% (weir:add-edge? 0 1))) 57 | 58 | (do-test (weir:edge-exists wer '(0 1)) t) 59 | 60 | (do-test (weir:3get-vert wer 2) (vec:3vec 12d0 3d0 2d0)) 61 | (do-test (weir:3get-vert wer 0) (vec:3vec 13d0 3d0 3d0)) 62 | 63 | (do-test (weir:edge-exists wer '(1 2)) t) 64 | (do-test (weir:edge-exists wer '(7 2)) nil))) 65 | 66 | 67 | (defun test-weir3-split () 68 | (let ((wer (weir:make :dim 3))) 69 | 70 | (weir:3add-vert! wer (vec:3vec 0d0 3d0 6d0)) 71 | (weir:3add-vert! wer (vec:3vec 1d0 4d0 7d0)) 72 | (weir:3add-vert! wer (vec:3vec 2d0 5d0 8d0)) 73 | (weir:add-edge! wer 0 1) 74 | (weir:add-edge! wer 1 2) 75 | (weir:add-edge! wer 2 0) 76 | 77 | (weir:with (wer %) 78 | (% (weir:3split-edge? 0 1 :xy (vec:3vec 30d0 20d0 3d0)) :res :a) 79 | (% (weir:3lsplit-edge? '(1 2) :xy (vec:3vec 31d0 23d0 4d0)) :res :b) 80 | (% (weir:3lsplit-edge? '(2 1) :xy (vec:3vec 32d0 24d0 5d0)) :res :c)) 81 | 82 | (do-test (sort-a-list (weir:get-alteration-result-list wer)) 83 | '((:a . 4) (:b) (:c . 3))) 84 | 85 | (do-test (weir:3get-vert wer 3) (vec:3vec 32d0 24d0 5d0)))) 86 | 87 | 88 | (defun test-weir3-kdtree () 89 | (rnd:set-rnd-state 2) 90 | (let ((wer (weir:make :dim 3))) 91 | 92 | (loop repeat 2000 do (weir:3add-vert! wer (rnd:3in-cube 1000d0))) 93 | 94 | (weir:3build-kdtree wer) 95 | 96 | (do-test 97 | (sort (weir:3verts-in-rad wer (vec:3vec 20d0 200d0 43d0) 100d0) #'<) 98 | '#(1340 1541)))) 99 | 100 | 101 | 102 | (define-file-tests test-weir3-galore () 103 | (test-title (test-weir3 (weir:make :dim 3))) 104 | (test-title (test-weir3-with)) 105 | (test-title (test-weir3-split)) 106 | (test-title (test-weir3-kdtree))) 107 | 108 | -------------------------------------------------------------------------------- /weir.asd: -------------------------------------------------------------------------------- 1 | 2 | (asdf:defsystem #:weir 3 | :description "A System for Making Generative Systems" 4 | :version "4.9.1" 5 | :author "anders hoff/inconvergent" 6 | :licence "MIT" 7 | :in-order-to ((asdf:test-op (asdf:test-op #:weir/tests))) 8 | :pathname "src/" 9 | :serial t 10 | :depends-on (#:alexandria 11 | #:cl-json 12 | #:cl-svg 13 | #:inferior-shell 14 | #:lparallel 15 | #:png 16 | #:split-sequence 17 | #:zpng) 18 | :components ((:file "packages") 19 | (:file "config") 20 | (:file "various") 21 | (:file "fn") 22 | (:file "state") 23 | (:file "hset") 24 | (:file "math/math") 25 | (:file "rnd/rnd") 26 | (:file "vec/base") 27 | (:file "vec/vec") 28 | (:file "vec/checks") 29 | (:file "vec/3vec") 30 | (:file "vec/avec") 31 | (:file "parallel/main") 32 | (:file "math/curvature") 33 | (:file "project/perspective") 34 | (:file "project/ortho") 35 | (:file "draw/cpath") 36 | (:file "draw/jpath") 37 | (:file "math/path") 38 | (:file "math/simplify-path") 39 | (:file "draw/hatch") 40 | (:file "draw/line-remove") 41 | (:file "pigment/pigment") 42 | (:file "pigment/non-alpha") 43 | (:file "pigment/extra") 44 | (:file "rnd/extra") 45 | (:file "rnd/3rnd") 46 | (:file "rnd/walkers") 47 | (:file "graph/main") 48 | (:file "graph/paths") 49 | (:file "graph/edge-set") 50 | (:file "graph/mst-cycle") 51 | (:file "auxiliary/dat") 52 | (:file "auxiliary/obj") 53 | (:file "gridfont/main") 54 | (:file "draw/bzspl") 55 | (:file "draw/lin-path") 56 | (:file "draw/sandpaint") 57 | (:file "draw/sandpaint-extra") 58 | (:file "draw/draw-svg") 59 | (:file "distance/zonemap") 60 | (:file "distance/kdtree") 61 | (:file "weir/weir") 62 | (:file "weir/weir-macro") 63 | (:file "weir/props") 64 | (:file "weir/weir-with-macro") 65 | (:file "weir/vert-utils") 66 | (:file "weir/planar-cycles") 67 | (:file "weir/paths") 68 | (:file "weir/3vert-utils") 69 | (:file "weir/alterations") 70 | (:file "weir/3alterations") 71 | (:file "weir/weir-extra"))) 72 | 73 | (asdf:defsystem #:weir/tests 74 | :depends-on (#:weir) 75 | :perform (asdf:test-op (o s) 76 | (uiop:symbol-call ':weir-tests 77 | '#:run-tests)) 78 | :pathname "test/" 79 | :serial t 80 | :components ((:file "test") 81 | (:file "parallel") 82 | (:file "math") 83 | (:file "hset") 84 | (:file "graph") 85 | (:file "rnd") 86 | (:file "vec") 87 | (:file "bzspl") 88 | (:file "kdtree") 89 | (:file "linear-path") 90 | (:file "curvature") 91 | (:file "ortho") 92 | (:file "plot") 93 | (:file "plot-paths") 94 | (:file "plot-simplify") 95 | (:file "plot-cpath") 96 | (:file "plot-jpath") 97 | (:file "plot-outline-path") 98 | (:file "pix-overlap") 99 | (:file "pigment") 100 | (:file "sandpaint") 101 | (:file "weir") 102 | (:file "weir-loop") 103 | (:file "weir3"))) 104 | 105 | --------------------------------------------------------------------------------