├── .dockerignore ├── .editorconfig ├── .gitignore ├── Dockerfile ├── LICENSE ├── README.md ├── compile.sh ├── docs ├── BVH.md ├── BZSPL.md ├── CANVAS.md ├── DAT.md ├── FN.md ├── GRAPH.md ├── GRIDFONT.md ├── HSET.md ├── JPATH.md ├── MATH.md ├── ORTHO.md ├── PARALLEL.md ├── PIGMENT.md ├── RND.md ├── SIMPLIFY.md ├── STATE.md ├── VOXEL.md ├── WEIR.md ├── WEIRD.md └── WSVG.md ├── examples ├── draw.lisp └── ex.lisp ├── img ├── boxes.png ├── scribble.png ├── sun.png ├── symbols.png └── web.png ├── make-docs.lisp ├── run-tests.sh ├── src ├── config.lisp ├── dat.lisp ├── data │ ├── cone.obj │ ├── cube.obj │ ├── ico-hi.obj │ ├── ico.obj │ ├── iso-hi.obj │ ├── iso.obj │ ├── sphere.obj │ ├── teapot.obj │ └── torus.obj ├── docs.lisp ├── draw │ ├── bzspl.lisp │ ├── canvas.lisp │ ├── hatch.lisp │ ├── jpath.lisp │ ├── ortho.lisp │ ├── pigment.lisp │ ├── simplify-path.lisp │ └── svg.lisp ├── fn.lisp ├── graph │ ├── edge-set.lisp │ ├── main.lisp │ ├── mst-cycle.lisp │ └── paths.lisp ├── gridfont │ ├── main.lisp │ └── smooth.json ├── hset.lisp ├── init.lisp ├── math.lisp ├── packages.lisp ├── parallel │ └── main.lisp ├── rnd │ ├── 2rnd.lisp │ ├── 3rnd.lisp │ ├── macros.lisp │ ├── rnd.lisp │ └── walkers.lisp ├── state.lisp ├── utils.lisp ├── voxel │ ├── init.lisp │ └── voxel.lisp └── weir │ ├── 3bvh.lisp │ ├── alteration-defalt-macro.lisp │ ├── alteration-utils.lisp │ ├── alterations.lisp │ ├── bvh-util.lisp │ ├── extra.lisp │ ├── kdtree.lisp │ ├── macros.lisp │ ├── main.lisp │ ├── paths.lisp │ ├── planar-cycles.lisp │ ├── poly-isect.lisp │ ├── poly-modify.lisp │ ├── poly.lisp │ ├── props.lisp │ ├── relneigh.lisp │ ├── vert-utils-init.lisp │ ├── vert-utils.lisp │ └── with-macro.lisp ├── test ├── 3weir.lisp ├── bzspl.lisp ├── graph.lisp ├── hset.lisp ├── math.lisp ├── ortho.lisp ├── rnd.lisp ├── run.lisp ├── weir-grp-prop.lisp ├── weir-with.lisp └── weir.lisp └── weird.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 | *.core 2 | *.dat 3 | *.fasl 4 | *.gif 5 | *.mp4 6 | *.obj 7 | *.png 8 | *.svg 9 | *.tmp 10 | system-index.txt 11 | tmp.lisp 12 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # This image is only intended to run the tests 2 | 3 | FROM ubuntu:22.04 AS base 4 | 5 | RUN apt-get -qq update &&\ 6 | apt-get -qq install -y sbcl curl gcc libpng-dev git 7 | 8 | WORKDIR /opt 9 | RUN curl -s 'https://beta.quicklisp.org/quicklisp.lisp' > /opt/quicklisp.lisp 10 | RUN sbcl --noinform --load /opt/quicklisp.lisp\ 11 | --eval '(quicklisp-quickstart:install :path "/opt/quicklisp")'\ 12 | --eval '(sb-ext:quit)' 13 | 14 | RUN mkdir -p quicklisp 15 | # &&\ 16 | # ln -s /opt/quicklisp/setup.lisp 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 quicklisp/local-projects/weird/src 26 | ADD test quicklisp/local-projects/weird/test 27 | ADD weird.asd quicklisp/local-projects/weird 28 | ADD run-tests.sh quicklisp/local-projects/weird/run-tests.sh 29 | RUN mkdir -p ~/quicklisp/ && ln -s /opt/quicklisp/setup.lisp ~/quicklisp/setup.lisp 30 | 31 | RUN git clone https://github.com/inconvergent/cl-veq.git quicklisp/local-projects/veq 32 | 33 | WORKDIR /opt/quicklisp/local-projects/weird 34 | 35 | CMD ["bash", "./run-tests.sh"] 36 | 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This code is released under the MIT license(see below). Unless otherwise noted. 2 | 3 | Most prominent exceptions are: 4 | 5 | 1. The images. 6 | 7 | 1. Some utilities from On Lisp by Paul Graham. They are bound by this notice: 8 | 9 | --- 10 | This code is copyright 1993 by Paul Graham, but anyone who wants 11 | to use the code in any nonprofit activity, or distribute free 12 | verbatim copies (including this notice), is encouraged to do so. 13 | --- 14 | 15 | 2. Some modified code by Victor Anyakin in (in src/auxiliary/dat.lisp): 16 | 17 | --- 18 | Copyright (c) 2013-2018 Victor Anyakin 19 | All rights reserved. 20 | 21 | Redistribution and use in source and binary forms, with or without 22 | modification, are permitted provided that the following conditions are met: 23 | * Redistributions of source code must retain the above copyright 24 | notice, this list of conditions and the following disclaimer. 25 | * Redistributions in binary form must reproduce the above copyright 26 | notice, this list of conditions and the following disclaimer in the 27 | documentation and/or other materials provided with the distribution. 28 | * Neither the name of the organization nor the 29 | names of its contributors may be used to endorse or promote products 30 | derived from this software without specific prior written permission. 31 | 32 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 33 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 34 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 35 | DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDER BE LIABLE FOR ANY 36 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 37 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 38 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 39 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 40 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 41 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 42 | --- 43 | 44 | --------- 45 | 46 | The MIT License (MIT) 47 | 48 | Copyright 2021 ANDERS HOFF 49 | 50 | Permission is hereby granted, free of charge, to any person obtaining a copy of 51 | this software and associated documentation files (the "Software"), to deal in 52 | the Software without restriction, including without limitation the rights to 53 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 54 | of the Software, and to permit persons to whom the Software is furnished to do 55 | so, subject to the following conditions: 56 | 57 | The above copyright notice and this permission notice shall be included in all 58 | copies or substantial portions of the Software. 59 | 60 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 61 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 62 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 63 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 64 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 65 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 66 | SOFTWARE. 67 | 68 | -------------------------------------------------------------------------------- /compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | touch ./weird.asd 5 | time sbcl --quit \ 6 | --eval '(load "~/quicklisp/setup.lisp")'\ 7 | --eval '(load "weird.asd")'\ 8 | --eval '(handler-case (time (ql:quickload :weird :verbose t)) 9 | (error (c) (print c) (sb-ext:quit :unix-status 2)))'\ 10 | >compile.sh.tmp 2>&1 11 | -------------------------------------------------------------------------------- /docs/BVH.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weird/fb50aa89303f4742787eb681a2f939ac6c99c1f9/docs/BVH.md -------------------------------------------------------------------------------- /docs/BZSPL.md: -------------------------------------------------------------------------------- 1 | #### BZSPL:ADAPTIVE-POS 2 | 3 | ``` 4 | :missing:todo: 5 | 6 | ; BZSPL:ADAPTIVE-POS 7 | ; [symbol] 8 | ; 9 | ; ADAPTIVE-POS names a compiled function: 10 | ; Lambda-list: (BZ &OPTIONAL (LIM *LIM*)) 11 | ; Derived type: (FUNCTION (BZSPL::BZSPL &OPTIONAL SINGLE-FLOAT) *) 12 | ; Source file: /data/x/weird/src/draw/bzspl.lisp 13 | ``` 14 | 15 | #### BZSPL:LEN 16 | 17 | ``` 18 | :missing:todo: 19 | 20 | ; BZSPL:LEN 21 | ; [symbol] 22 | ; 23 | ; LEN names a compiled function: 24 | ; Lambda-list: (BZ &OPTIONAL (LIM *LIM*)) 25 | ; Derived type: (FUNCTION (BZSPL::BZSPL &OPTIONAL T) 26 | ; (VALUES (SINGLE-FLOAT 0.0) &OPTIONAL)) 27 | ; Source file: /data/x/weird/src/draw/bzspl.lisp 28 | ``` 29 | 30 | #### BZSPL:MAKE 31 | 32 | ``` 33 | :missing:todo: 34 | 35 | ; BZSPL:MAKE 36 | ; [symbol] 37 | ; 38 | ; MAKE names a compiled function: 39 | ; Lambda-list: (PTS &KEY CLOSED &AUX (N (2$NUM PTS))) 40 | ; Derived type: (FUNCTION 41 | ; ((SIMPLE-ARRAY SINGLE-FLOAT) &KEY (:CLOSED BOOLEAN)) 42 | ; (VALUES BZSPL::BZSPL &OPTIONAL)) 43 | ; Source file: /data/x/weird/src/draw/bzspl.lisp 44 | ``` 45 | 46 | #### BZSPL:POS 47 | 48 | ``` 49 | :missing:todo: 50 | 51 | ; BZSPL:POS 52 | ; [symbol] 53 | ; 54 | ; POS names a compiled function: 55 | ; Lambda-list: (BZ X) 56 | ; Derived type: (FUNCTION (BZSPL::BZSPL SINGLE-FLOAT) 57 | ; (VALUES SINGLE-FLOAT SINGLE-FLOAT &OPTIONAL)) 58 | ; Source file: /data/x/weird/src/draw/bzspl.lisp 59 | ``` 60 | 61 | #### BZSPL:POS\* 62 | 63 | ``` 64 | :missing:todo: 65 | 66 | ; BZSPL:POS* 67 | ; [symbol] 68 | ; 69 | ; POS* names a compiled function: 70 | ; Lambda-list: (B XX) 71 | ; Derived type: (FUNCTION (BZSPL::BZSPL LIST) 72 | ; (VALUES (SIMPLE-ARRAY SINGLE-FLOAT (*)) &OPTIONAL)) 73 | ; Source file: /data/x/weird/src/draw/bzspl.lisp 74 | ``` 75 | 76 | #### BZSPL:RNDPOS 77 | 78 | ``` 79 | :missing:todo: 80 | 81 | ; BZSPL:RNDPOS 82 | ; [symbol] 83 | ; 84 | ; RNDPOS names a compiled function: 85 | ; Lambda-list: (B N &KEY ORDER) 86 | ; Derived type: (FUNCTION 87 | ; (BZSPL::BZSPL (UNSIGNED-BYTE 31) &KEY (:ORDER T)) *) 88 | ; Source file: /data/x/weird/src/draw/bzspl.lisp 89 | ``` 90 | 91 | -------------------------------------------------------------------------------- /docs/CANVAS.md: -------------------------------------------------------------------------------- 1 | #### CANVAS:CANVAS 2 | 3 | ``` 4 | :missing:todo: 5 | 6 | ; CANVAS:CANVAS 7 | ; [symbol] 8 | ; 9 | ; CANVAS names the structure-class #: 10 | ; Class precedence-list: CANVAS:CANVAS, STRUCTURE-OBJECT, 11 | ; SB-PCL::SLOT-OBJECT, T 12 | ; Direct superclasses: STRUCTURE-OBJECT 13 | ; No subclasses. 14 | ; Slots: 15 | ; CANVAS::SIZE 16 | ; Type: WEIRD:SMALL-IND 17 | ; Initform: NIL 18 | ; CANVAS::VALS 19 | ; Type: VEQ:FVEC 20 | ; Initform: NIL 21 | ; CANVAS::INDFX 22 | ; Type: FUNCTION 23 | ; Initform: NIL 24 | ``` 25 | 26 | #### CANVAS:MAKE 27 | 28 | ``` 29 | make square PNG canvas instance of size to. 30 | 31 | ; CANVAS:MAKE 32 | ; [symbol] 33 | ; 34 | ; MAKE names a compiled function: 35 | ; Lambda-list: (&KEY (SIZE 1000)) 36 | ; Derived type: (FUNCTION (&KEY (:SIZE T)) 37 | ; (VALUES CANVAS:CANVAS &OPTIONAL)) 38 | ; Documentation: 39 | ; make square PNG canvas instance of size to. 40 | ; Source file: /data/x/weird/src/draw/canvas.lisp 41 | ``` 42 | 43 | #### CANVAS:SAVE 44 | 45 | ``` 46 | save as 8 bit PNG file fn with gamma. 47 | 48 | ; CANVAS:SAVE 49 | ; [symbol] 50 | ; 51 | ; SAVE names a compiled function: 52 | ; Lambda-list: (CANV FN &KEY (GAMMA 1.0)) 53 | ; Derived type: (FUNCTION (CANVAS:CANVAS T &KEY (:GAMMA SINGLE-FLOAT)) 54 | ; *) 55 | ; Documentation: 56 | ; save as 8 bit PNG file fn with gamma. 57 | ; Source file: /data/x/weird/src/draw/canvas.lisp 58 | ``` 59 | 60 | #### CANVAS:SET-GRAY-PIX 61 | 62 | ``` 63 | set (i j) to value c where 0.0 =< c =< 1.0. 64 | 65 | ; CANVAS:SET-GRAY-PIX 66 | ; [symbol] 67 | ; 68 | ; SET-GRAY-PIX names a compiled function: 69 | ; Lambda-list: (CANV I J C) 70 | ; Derived type: (FUNCTION 71 | ; (T (UNSIGNED-BYTE 31) (UNSIGNED-BYTE 31) SINGLE-FLOAT) 72 | ; (VALUES NULL &OPTIONAL)) 73 | ; Documentation: 74 | ; set (i j) to value c where 0.0 =< c =< 1.0. 75 | ; Inline proclamation: INLINE (inline expansion available) 76 | ; Source file: /data/x/weird/src/draw/canvas.lisp 77 | ``` 78 | 79 | #### CANVAS:SET-PIX 80 | 81 | ``` 82 | set (i j) to value (r g b) where 0.0 =< r,g,b =< 1.0. 83 | 84 | ; CANVAS:SET-PIX 85 | ; [symbol] 86 | ; 87 | ; SET-PIX names a compiled function: 88 | ; Lambda-list: (CANV I J R G B) 89 | ; Derived type: (FUNCTION 90 | ; (T (UNSIGNED-BYTE 31) (UNSIGNED-BYTE 31) SINGLE-FLOAT 91 | ; SINGLE-FLOAT SINGLE-FLOAT) 92 | ; (VALUES NULL &OPTIONAL)) 93 | ; Documentation: 94 | ; set (i j) to value (r g b) where 0.0 =< r,g,b =< 1.0. 95 | ; Inline proclamation: INLINE (inline expansion available) 96 | ; Source file: /data/x/weird/src/draw/canvas.lisp 97 | ``` 98 | 99 | -------------------------------------------------------------------------------- /docs/DAT.md: -------------------------------------------------------------------------------- 1 | #### DAT:DO-LINES-AS-BUFFER 2 | 3 | ``` 4 | 5 | fx will receive a stream (named in). use it like this: 6 | (loop for x = (read in nil nil) 7 | while x 8 | do something) 9 | 10 | 11 | ; DAT:DO-LINES-AS-BUFFER 12 | ; [symbol] 13 | ; 14 | ; DO-LINES-AS-BUFFER names a compiled function: 15 | ; Lambda-list: (FN FX &KEY (BUFFER-WIDTH 80)) 16 | ; Derived type: (FUNCTION (T FUNCTION &KEY (:BUFFER-WIDTH FIXNUM)) 17 | ; (VALUES NULL &OPTIONAL)) 18 | ; Documentation: 19 | ; 20 | ; fx will receive a stream (named in). use it like this: 21 | ; (loop for x = (read in nil nil) 22 | ; while x 23 | ; do something) 24 | ; 25 | ; Source file: /data/x/weird/src/dat.lisp 26 | ``` 27 | 28 | #### DAT:EXPORT-DATA 29 | 30 | ``` 31 | :missing:todo: 32 | 33 | ; DAT:EXPORT-DATA 34 | ; [symbol] 35 | ; 36 | ; EXPORT-DATA names a compiled function: 37 | ; Lambda-list: (O FN &OPTIONAL (POSTFIX .dat)) 38 | ; Derived type: (FUNCTION (T T &OPTIONAL T) (VALUES T &OPTIONAL)) 39 | ; Source file: /data/x/weird/src/dat.lisp 40 | ``` 41 | 42 | #### DAT:IMPORT-ALL-DATA 43 | 44 | ``` 45 | :missing:todo: 46 | 47 | ; DAT:IMPORT-ALL-DATA 48 | ; [symbol] 49 | ; 50 | ; IMPORT-ALL-DATA names a compiled function: 51 | ; Lambda-list: (FN &OPTIONAL (POSTFIX .dat)) 52 | ; Derived type: (FUNCTION (T &OPTIONAL T) (VALUES LIST &OPTIONAL)) 53 | ; Source file: /data/x/weird/src/dat.lisp 54 | ``` 55 | 56 | #### DAT:IMPORT-DATA 57 | 58 | ``` 59 | :missing:todo: 60 | 61 | ; DAT:IMPORT-DATA 62 | ; [symbol] 63 | ; 64 | ; IMPORT-DATA names a compiled function: 65 | ; Lambda-list: (FN &OPTIONAL (POSTFIX .dat)) 66 | ; Derived type: (FUNCTION (T &OPTIONAL T) (VALUES T &OPTIONAL)) 67 | ; Source file: /data/x/weird/src/dat.lisp 68 | ``` 69 | 70 | -------------------------------------------------------------------------------- /docs/FN.md: -------------------------------------------------------------------------------- 1 | #### FN:FN 2 | 3 | ``` 4 | generate file names using https://github.com/inconvergent/fn 5 | 6 | ; FN:FN 7 | ; [symbol] 8 | ; 9 | ; FN names a compiled function: 10 | ; Lambda-list: () 11 | ; Derived type: (FUNCTION NIL (VALUES T &OPTIONAL)) 12 | ; Documentation: 13 | ; generate file names using https://github.com/inconvergent/fn 14 | ; Source file: /data/x/weird/src/fn.lisp 15 | ``` 16 | 17 | #### FN:SEED 18 | 19 | ``` 20 | :missing:todo: 21 | 22 | ; FN:SEED 23 | ; [symbol] 24 | ; 25 | ; SEED names a compiled function: 26 | ; Lambda-list: (FN) 27 | ; Derived type: (FUNCTION (T) (VALUES T (OR NULL INTEGER) &OPTIONAL)) 28 | ; Source file: /data/x/weird/src/fn.lisp 29 | ``` 30 | 31 | -------------------------------------------------------------------------------- /docs/GRIDFONT.md: -------------------------------------------------------------------------------- 1 | #### GRIDFONT:MAKE 2 | 3 | ``` 4 | :missing:todo: 5 | 6 | ; GRIDFONT:MAKE 7 | ; [symbol] 8 | ; 9 | ; MAKE names a compiled function: 10 | ; Lambda-list: (&KEY (FN (INTERNAL-PATH-STRING src/gridfont/smooth)) 11 | ; (SCALE 2.0) (NL 15.0) (SP 2.0) (XY (LIST 0.0 0.0))) 12 | ; Derived type: (FUNCTION 13 | ; (&KEY (:FN T) (:SCALE T) (:NL T) (:SP T) (:XY T)) 14 | ; (VALUES GRIDFONT::GRIDFONT &OPTIONAL)) 15 | ; Source file: /data/x/weird/src/gridfont/main.lisp 16 | ``` 17 | 18 | #### GRIDFONT:NL 19 | 20 | ``` 21 | write a newline 22 | 23 | ; GRIDFONT:NL 24 | ; [symbol] 25 | ; 26 | ; NL names a compiled function: 27 | ; Lambda-list: (GF &KEY (LEFT (GRIDFONT-LEFT GF))) 28 | ; Derived type: (FUNCTION 29 | ; (GRIDFONT::GRIDFONT &KEY (:LEFT SINGLE-FLOAT)) 30 | ; (VALUES CONS &OPTIONAL)) 31 | ; Documentation: 32 | ; write a newline 33 | ; Source file: /data/x/weird/src/gridfont/main.lisp 34 | ``` 35 | 36 | #### GRIDFONT:UPDATE 37 | 38 | ``` 39 | update gridfont properties 40 | 41 | ; GRIDFONT:UPDATE 42 | ; [symbol] 43 | ; 44 | ; UPDATE names a compiled function: 45 | ; Lambda-list: (GF &KEY XY SCALE SP NL) 46 | ; Derived type: (FUNCTION 47 | ; (GRIDFONT::GRIDFONT &KEY (:XY T) (:SCALE T) (:SP T) 48 | ; (:NL T)) 49 | ; (VALUES (OR NULL SINGLE-FLOAT) &OPTIONAL)) 50 | ; Documentation: 51 | ; update gridfont properties 52 | ; Source file: /data/x/weird/src/gridfont/main.lisp 53 | ``` 54 | 55 | #### GRIDFONT:WC 56 | 57 | ``` 58 | write single character, c 59 | 60 | ; GRIDFONT:WC 61 | ; [symbol] 62 | ; 63 | ; WC names a compiled function: 64 | ; Lambda-list: (GF C &KEY XY) 65 | ; Derived type: (FUNCTION (GRIDFONT::GRIDFONT T &KEY (:XY T)) 66 | ; (VALUES LIST &OPTIONAL)) 67 | ; Documentation: 68 | ; write single character, c 69 | ; Source file: /data/x/weird/src/gridfont/main.lisp 70 | ``` 71 | 72 | -------------------------------------------------------------------------------- /docs/HSET.md: -------------------------------------------------------------------------------- 1 | #### HSET:ADD 2 | 3 | ``` 4 | add e to fixnum set. 5 | 6 | ; HSET:ADD 7 | ; [symbol] 8 | ; 9 | ; ADD names a compiled function: 10 | ; Lambda-list: (S E) 11 | ; Derived type: (FUNCTION (HASH-TABLE FIXNUM) 12 | ; (VALUES BOOLEAN &OPTIONAL)) 13 | ; Documentation: 14 | ; add e to fixnum set. 15 | ; Inline proclamation: INLINE (inline expansion available) 16 | ; Source file: /data/x/weird/src/hset.lisp 17 | ``` 18 | 19 | #### HSET:ADD\* 20 | 21 | ``` 22 | add sequence of fixnums to fixnum set. 23 | 24 | ; HSET:ADD* 25 | ; [symbol] 26 | ; 27 | ; ADD* names a compiled function: 28 | ; Lambda-list: (S EE) 29 | ; Derived type: (FUNCTION (HASH-TABLE SEQUENCE) (VALUES LIST &OPTIONAL)) 30 | ; Documentation: 31 | ; add sequence of fixnums to fixnum set. 32 | ; Source file: /data/x/weird/src/hset.lisp 33 | ``` 34 | 35 | #### HSET:COPY 36 | 37 | ``` 38 | copy fixnum set. 39 | 40 | ; HSET:COPY 41 | ; [symbol] 42 | ; 43 | ; COPY names a compiled function: 44 | ; Lambda-list: (S &KEY (SIZE 100) (INC 2.0)) 45 | ; Derived type: (FUNCTION 46 | ; (HASH-TABLE &KEY (:SIZE FIXNUM) (:INC NUMBER)) 47 | ; (VALUES HASH-TABLE &OPTIONAL)) 48 | ; Documentation: 49 | ; copy fixnum set. 50 | ; Source file: /data/x/weird/src/hset.lisp 51 | ``` 52 | 53 | #### HSET:DEL 54 | 55 | ``` 56 | del e from fixnum set. 57 | 58 | ; HSET:DEL 59 | ; [symbol] 60 | ; 61 | ; DEL names a compiled function: 62 | ; Lambda-list: (S E) 63 | ; Derived type: (FUNCTION (HASH-TABLE FIXNUM) 64 | ; (VALUES BOOLEAN &OPTIONAL)) 65 | ; Documentation: 66 | ; del e from fixnum set. 67 | ; Inline proclamation: INLINE (inline expansion available) 68 | ; Source file: /data/x/weird/src/hset.lisp 69 | ``` 70 | 71 | #### HSET:DEL\* 72 | 73 | ``` 74 | del sequence of fixnum from fixnum set. 75 | 76 | ; HSET:DEL* 77 | ; [symbol] 78 | ; 79 | ; DEL* names a compiled function: 80 | ; Lambda-list: (S EE) 81 | ; Derived type: (FUNCTION (HASH-TABLE SEQUENCE) (VALUES LIST &OPTIONAL)) 82 | ; Documentation: 83 | ; del sequence of fixnum from fixnum set. 84 | ; Source file: /data/x/weird/src/hset.lisp 85 | ``` 86 | 87 | #### HSET:INTER 88 | 89 | ``` 90 | return new fixnum set which contains the intersection of a,b. 91 | 92 | ; HSET:INTER 93 | ; [symbol] 94 | ; 95 | ; INTER names a compiled function: 96 | ; Lambda-list: (A B) 97 | ; Derived type: (FUNCTION (HASH-TABLE HASH-TABLE) 98 | ; (VALUES HASH-TABLE &OPTIONAL)) 99 | ; Documentation: 100 | ; return new fixnum set which contains the intersection of a,b. 101 | ; Source file: /data/x/weird/src/hset.lisp 102 | ``` 103 | 104 | #### HSET:MAKE 105 | 106 | ``` 107 | create fixnum set. init (optional) is a list of integers. 108 | 109 | ; HSET:MAKE 110 | ; [symbol] 111 | ; 112 | ; MAKE names a compiled function: 113 | ; Lambda-list: (&KEY INIT (SIZE 100) (INC 2.0)) 114 | ; Derived type: (FUNCTION (&KEY (:INIT T) (:SIZE FIXNUM) (:INC T)) 115 | ; (VALUES HASH-TABLE &OPTIONAL)) 116 | ; Documentation: 117 | ; create fixnum set. init (optional) is a list of integers. 118 | ; Source file: /data/x/weird/src/hset.lisp 119 | ``` 120 | 121 | #### HSET:MEM 122 | 123 | ``` 124 | t if e is member of fixnum set s. 125 | 126 | ; HSET:MEM 127 | ; [symbol] 128 | ; 129 | ; MEM names a compiled function: 130 | ; Lambda-list: (S E) 131 | ; Derived type: (FUNCTION (HASH-TABLE FIXNUM) 132 | ; (VALUES BOOLEAN &OPTIONAL)) 133 | ; Documentation: 134 | ; t if e is member of fixnum set s. 135 | ; Inline proclamation: INLINE (inline expansion available) 136 | ; Source file: /data/x/weird/src/hset.lisp 137 | ``` 138 | 139 | #### HSET:MEM\* 140 | 141 | ``` 142 | returns list with a boolean for each fixnum in sequence ee. 143 | 144 | ; HSET:MEM* 145 | ; [symbol] 146 | ; 147 | ; MEM* names a compiled function: 148 | ; Lambda-list: (S EE) 149 | ; Derived type: (FUNCTION (HASH-TABLE SEQUENCE) (VALUES LIST &OPTIONAL)) 150 | ; Documentation: 151 | ; returns list with a boolean for each fixnum in sequence ee. 152 | ; Source file: /data/x/weird/src/hset.lisp 153 | ``` 154 | 155 | #### HSET:NUM 156 | 157 | ``` 158 | count elements in fixnum set. 159 | 160 | ; HSET:NUM 161 | ; [symbol] 162 | ; 163 | ; NUM names a compiled function: 164 | ; Lambda-list: (S) 165 | ; Derived type: (FUNCTION (HASH-TABLE) 166 | ; (VALUES (MOD 4611686018427387901) &OPTIONAL)) 167 | ; Documentation: 168 | ; count elements in fixnum set. 169 | ; Source file: /data/x/weird/src/hset.lisp 170 | ``` 171 | 172 | #### HSET:SYMDIFF 173 | 174 | ``` 175 | return new fixnum set which contains the symmetric difference of a,b. 176 | 177 | ; HSET:SYMDIFF 178 | ; [symbol] 179 | ; 180 | ; SYMDIFF names a compiled function: 181 | ; Lambda-list: (A B) 182 | ; Derived type: (FUNCTION (HASH-TABLE HASH-TABLE) 183 | ; (VALUES HASH-TABLE &OPTIONAL)) 184 | ; Documentation: 185 | ; return new fixnum set which contains the symmetric difference of a,b. 186 | ; Source file: /data/x/weird/src/hset.lisp 187 | ``` 188 | 189 | #### HSET:TO-LIST 190 | 191 | ``` 192 | get unordered list of elements in fixnum set. 193 | 194 | ; HSET:TO-LIST 195 | ; [symbol] 196 | ; 197 | ; TO-LIST names a compiled function: 198 | ; Lambda-list: (S) 199 | ; Derived type: (FUNCTION (HASH-TABLE) (VALUES LIST &OPTIONAL)) 200 | ; Documentation: 201 | ; get unordered list of elements in fixnum set. 202 | ; Source file: /data/x/weird/src/hset.lisp 203 | ``` 204 | 205 | #### HSET:UNI 206 | 207 | ``` 208 | return new fixnum set which contains the union of a,b. 209 | 210 | ; HSET:UNI 211 | ; [symbol] 212 | ; 213 | ; UNI names a compiled function: 214 | ; Lambda-list: (A B) 215 | ; Derived type: (FUNCTION (HASH-TABLE HASH-TABLE) 216 | ; (VALUES HASH-TABLE &OPTIONAL)) 217 | ; Documentation: 218 | ; return new fixnum set which contains the union of a,b. 219 | ; Source file: /data/x/weird/src/hset.lisp 220 | ``` 221 | 222 | -------------------------------------------------------------------------------- /docs/JPATH.md: -------------------------------------------------------------------------------- 1 | #### JPATH:JPATH 2 | 3 | ``` 4 | :missing:todo: 5 | 6 | ; JPATH:JPATH 7 | ; [symbol] 8 | ; 9 | ; JPATH names a compiled function: 10 | ; Lambda-list: (PATH W &KEY (REP 3) CLOSED (LIMITS *LIMITS*)) 11 | ; Derived type: (FUNCTION 12 | ; ((SIMPLE-ARRAY SINGLE-FLOAT) SINGLE-FLOAT &KEY 13 | ; (:REP FIXNUM) (:CLOSED BOOLEAN) (:LIMITS T)) 14 | ; *) 15 | ; Source file: /data/x/weird/src/draw/jpath.lisp 16 | ``` 17 | 18 | #### JPATH:PATH->DIAGONALS 19 | 20 | ``` 21 | 22 | return (orientation line) for every point in path. lerp-ing along lines will 23 | return controll points. lerp direction should be flipped when orientation is 24 | nil. sharp or chamfered points correspond to two lines 25 | 26 | 27 | ; JPATH:PATH->DIAGONALS 28 | ; [symbol] 29 | ; 30 | ; PATH->DIAGONALS names a compiled function: 31 | ; Lambda-list: (PATH W &KEY CLOSED (LIMITS *LIMITS*)) 32 | ; Derived type: (FUNCTION 33 | ; ((SIMPLE-ARRAY SINGLE-FLOAT) SINGLE-FLOAT &KEY 34 | ; (:CLOSED BOOLEAN) (:LIMITS T)) 35 | ; (VALUES LIST &OPTIONAL)) 36 | ; Documentation: 37 | ; 38 | ; return (orientation line) for every point in path. lerp-ing along lines will 39 | ; return controll points. lerp direction should be flipped when orientation is 40 | ; nil. sharp or chamfered points correspond to two lines 41 | ; 42 | ; Source file: /data/x/weird/src/draw/jpath.lisp 43 | ``` 44 | 45 | #### JPATH:PATH->JOINTS 46 | 47 | ``` 48 | joints contain information about how to offset around points in path. 49 | 50 | ; JPATH:PATH->JOINTS 51 | ; [symbol] 52 | ; 53 | ; PATH->JOINTS names a compiled function: 54 | ; Lambda-list: (PATH W* &KEY CLOSED &AUX (W (* 0.5 W*)) 55 | ; (N (ROUND (/ (LENGTH PATH) 2)))) 56 | ; Derived type: (FUNCTION 57 | ; ((SIMPLE-ARRAY SINGLE-FLOAT) SINGLE-FLOAT &KEY 58 | ; (:CLOSED BOOLEAN)) 59 | ; (VALUES LIST &OPTIONAL)) 60 | ; Documentation: 61 | ; joints contain information about how to offset around points in path. 62 | ; Source file: /data/x/weird/src/draw/jpath.lisp 63 | ``` 64 | 65 | -------------------------------------------------------------------------------- /docs/ORTHO.md: -------------------------------------------------------------------------------- 1 | #### ORTHO:@CAM 2 | 3 | ``` 4 | :missing:todo: 5 | 6 | ; ORTHO:@CAM 7 | ; [symbol] 8 | ; 9 | ; @CAM names a compiled function: 10 | ; Lambda-list: (PROJ) 11 | ; Derived type: (FUNCTION (T) 12 | ; (VALUES SINGLE-FLOAT SINGLE-FLOAT SINGLE-FLOAT 13 | ; &OPTIONAL)) 14 | ; Inline proclamation: INLINE (inline expansion available) 15 | ; Source file: /data/x/weird/src/draw/ortho.lisp 16 | ``` 17 | 18 | #### ORTHO:@UP 19 | 20 | ``` 21 | :missing:todo: 22 | 23 | ; ORTHO:@UP 24 | ; [symbol] 25 | ; 26 | ; @UP names a compiled function: 27 | ; Lambda-list: (PROJ) 28 | ; Derived type: (FUNCTION (T) 29 | ; (VALUES SINGLE-FLOAT SINGLE-FLOAT SINGLE-FLOAT 30 | ; &OPTIONAL)) 31 | ; Inline proclamation: INLINE (inline expansion available) 32 | ; Source file: /data/x/weird/src/draw/ortho.lisp 33 | ``` 34 | 35 | #### ORTHO:@VPN 36 | 37 | ``` 38 | :missing:todo: 39 | 40 | ; ORTHO:@VPN 41 | ; [symbol] 42 | ; 43 | ; @VPN names a compiled function: 44 | ; Lambda-list: (PROJ) 45 | ; Derived type: (FUNCTION (T) 46 | ; (VALUES SINGLE-FLOAT SINGLE-FLOAT SINGLE-FLOAT 47 | ; &OPTIONAL)) 48 | ; Inline proclamation: INLINE (inline expansion available) 49 | ; Source file: /data/x/weird/src/draw/ortho.lisp 50 | ``` 51 | 52 | #### ORTHO:@XY 53 | 54 | ``` 55 | :missing:todo: 56 | 57 | ; ORTHO:@XY 58 | ; [symbol] 59 | ; 60 | ; @XY names a compiled function: 61 | ; Lambda-list: (PROJ) 62 | ; Derived type: (FUNCTION (T) 63 | ; (VALUES SINGLE-FLOAT SINGLE-FLOAT &OPTIONAL)) 64 | ; Inline proclamation: INLINE (inline expansion available) 65 | ; Source file: /data/x/weird/src/draw/ortho.lisp 66 | ``` 67 | 68 | #### ORTHO:EXPORT-DATA 69 | 70 | ``` 71 | export the neccessary values to recreate ortho 72 | 73 | ; ORTHO:EXPORT-DATA 74 | ; [symbol] 75 | ; 76 | ; EXPORT-DATA names a compiled function: 77 | ; Lambda-list: (P) 78 | ; Derived type: (FUNCTION (ORTHO::ORTHO) (VALUES CONS &OPTIONAL)) 79 | ; Documentation: 80 | ; export the neccessary values to recreate ortho 81 | ; Source file: /data/x/weird/src/draw/ortho.lisp 82 | ``` 83 | 84 | #### ORTHO:IMPORT-DATA 85 | 86 | ``` 87 | recreate proj from an a list exported by ortho:export-data 88 | 89 | ; ORTHO:IMPORT-DATA 90 | ; [symbol] 91 | ; 92 | ; IMPORT-DATA names a compiled function: 93 | ; Lambda-list: (P) 94 | ; Derived type: (FUNCTION (LIST) *) 95 | ; Documentation: 96 | ; recreate proj from an a list exported by ortho:export-data 97 | ; Source file: /data/x/weird/src/draw/ortho.lisp 98 | ``` 99 | 100 | #### ORTHO:MAKE 101 | 102 | ``` 103 | 104 | make projection. 105 | 106 | default up is (0 0 1) 107 | default cam is (1000 1000 1000) 108 | if look and vpn are unset, the camera will look at the origin. 109 | 110 | default scale is 1 111 | default xy is (0 0) 112 | 113 | 114 | ; ORTHO:MAKE 115 | ; [symbol] 116 | ; 117 | ; MAKE names a compiled function: 118 | ; Lambda-list: (&KEY (UP (F3$POINT 0.0 0.0 1.0)) 119 | ; (CAM (F3$POINT 1000.0 1000.0 1000.0)) 120 | ; (XY (F2$POINT 500.0 500.0)) (S 1.0) VPN LOOK 121 | ; (RAYLEN 5000.0)) 122 | ; Derived type: (FUNCTION 123 | ; (&KEY (:UP (SIMPLE-ARRAY SINGLE-FLOAT)) 124 | ; (:CAM (SIMPLE-ARRAY SINGLE-FLOAT)) 125 | ; (:XY (SIMPLE-ARRAY SINGLE-FLOAT)) (:S SINGLE-FLOAT) 126 | ; (:VPN T) (:LOOK T) (:RAYLEN SINGLE-FLOAT)) 127 | ; (VALUES ORTHO::ORTHO &OPTIONAL)) 128 | ; Documentation: 129 | ; 130 | ; make projection. 131 | ; 132 | ; default up is (0 0 1) 133 | ; default cam is (1000 1000 1000) 134 | ; if look and vpn are unset, the camera will look at the origin. 135 | ; 136 | ; default scale is 1 137 | ; default xy is (0 0) 138 | ; 139 | ; Source file: /data/x/weird/src/draw/ortho.lisp 140 | ``` 141 | 142 | #### ORTHO:MAKE-RAYFX 143 | 144 | ``` 145 | cast a ray in direction -vpn from pt 146 | 147 | ; ORTHO:MAKE-RAYFX 148 | ; [symbol] 149 | ; 150 | ; MAKE-RAYFX names a compiled function: 151 | ; Lambda-list: (PROJ) 152 | ; Derived type: (FUNCTION (ORTHO::ORTHO) (VALUES FUNCTION &OPTIONAL)) 153 | ; Documentation: 154 | ; cast a ray in direction -vpn from pt 155 | ; Source file: /data/x/weird/src/draw/ortho.lisp 156 | ``` 157 | 158 | #### ORTHO:PAN-CAM 159 | 160 | ``` 161 | :missing:todo: 162 | 163 | ; ORTHO:PAN-CAM 164 | ; [symbol] 165 | ``` 166 | 167 | #### ORTHO:PAN-XY 168 | 169 | ``` 170 | :missing:todo: 171 | 172 | ; ORTHO:PAN-XY 173 | ; [symbol] 174 | ``` 175 | 176 | #### ORTHO:PROJECT 177 | 178 | ``` 179 | WRAPS: %PROJECT 180 | ARGS: (PROJ (VA 3 PT)) 181 | DOCSTRING: project single point. returns (values x y d) 182 | defined via veq:FVDEF* 183 | 184 | ; ORTHO:PROJECT 185 | ; [symbol] 186 | ; 187 | ; PROJECT names a macro: 188 | ; Lambda-list: (&REST REST) 189 | ; Documentation: 190 | ; WRAPS: %PROJECT 191 | ; ARGS: (PROJ (VA 3 PT)) 192 | ; DOCSTRING: project single point. returns (values x y d) 193 | ; defined via veq:FVDEF* 194 | ; Source file: /data/x/weird/src/draw/ortho.lisp 195 | ``` 196 | 197 | #### ORTHO:PROJECT\* 198 | 199 | ``` 200 | project a path #(x1 y1 z1 x2 y2 z2 ...). 201 | returns projected path and distances: (values #(px1 py1 px2 py2 ...) 202 | #(d1 d2 ...)) 203 | 204 | ; ORTHO:PROJECT* 205 | ; [symbol] 206 | ; 207 | ; PROJECT* names a compiled function: 208 | ; Lambda-list: (PROJ PATH) 209 | ; Derived type: (FUNCTION (ORTHO::ORTHO (SIMPLE-ARRAY SINGLE-FLOAT)) 210 | ; (VALUES (SIMPLE-ARRAY SINGLE-FLOAT . #1=((*))) 211 | ; (SIMPLE-ARRAY SINGLE-FLOAT . #1#) &OPTIONAL)) 212 | ; Documentation: 213 | ; project a path #(x1 y1 z1 x2 y2 z2 ...). 214 | ; returns projected path and distances: (values #(px1 py1 px2 py2 ...) 215 | ; #(d1 d2 ...)) 216 | ; Source file: /data/x/weird/src/draw/ortho.lisp 217 | ``` 218 | 219 | #### ORTHO:PROJECT-OFFSET 220 | 221 | ``` 222 | :missing:todo: 223 | 224 | ; ORTHO:PROJECT-OFFSET 225 | ; [symbol] 226 | ``` 227 | 228 | #### ORTHO:PROJECT-OFFSET\* 229 | 230 | ``` 231 | :missing:todo: 232 | 233 | ; ORTHO:PROJECT-OFFSET* 234 | ; [symbol] 235 | ``` 236 | 237 | #### ORTHO:ROTATE 238 | 239 | ``` 240 | :missing:todo: 241 | 242 | ; ORTHO:ROTATE 243 | ; [symbol] 244 | ``` 245 | 246 | #### ORTHO:UPDATE 247 | 248 | ``` 249 | 250 | update projection parameters. 251 | 252 | use vpn to set view plane normal directly, or look to set view plane normal 253 | relative to camera. 254 | 255 | ensures that internal state is updated appropriately. 256 | 257 | 258 | ; ORTHO:UPDATE 259 | ; [symbol] 260 | ; 261 | ; UPDATE names a compiled function: 262 | ; Lambda-list: (PROJ &KEY S XY UP CAM VPN LOOK) 263 | ; Derived type: (FUNCTION 264 | ; (ORTHO::ORTHO &KEY (:S T) (:XY T) (:UP T) (:CAM T) 265 | ; (:VPN T) (:LOOK T)) 266 | ; (VALUES ORTHO::ORTHO &OPTIONAL)) 267 | ; Documentation: 268 | ; 269 | ; update projection parameters. 270 | ; 271 | ; use vpn to set view plane normal directly, or look to set view plane normal 272 | ; relative to camera. 273 | ; 274 | ; ensures that internal state is updated appropriately. 275 | ; 276 | ; Source file: /data/x/weird/src/draw/ortho.lisp 277 | ``` 278 | 279 | #### ORTHO:ZOOM 280 | 281 | ``` 282 | :missing:todo: 283 | 284 | ; ORTHO:ZOOM 285 | ; [symbol] 286 | ``` 287 | 288 | -------------------------------------------------------------------------------- /docs/PARALLEL.md: -------------------------------------------------------------------------------- 1 | #### PARALLEL:CREATE-CHANNEL 2 | 3 | ``` 4 | :missing:todo: 5 | 6 | ; PARALLEL:CREATE-CHANNEL 7 | ; [symbol] 8 | ; 9 | ; CREATE-CHANNEL names a compiled function: 10 | ; Lambda-list: () 11 | ; Derived type: (FUNCTION NIL *) 12 | ; Source file: /data/x/weird/src/parallel/main.lisp 13 | ``` 14 | 15 | #### PARALLEL:END 16 | 17 | ``` 18 | :missing:todo: 19 | 20 | ; PARALLEL:END 21 | ; [symbol] 22 | ; 23 | ; END names a compiled function: 24 | ; Lambda-list: () 25 | ; Derived type: (FUNCTION NIL *) 26 | ; Source file: /data/x/weird/src/parallel/main.lisp 27 | ``` 28 | 29 | #### PARALLEL:INFO 30 | 31 | ``` 32 | :missing:todo: 33 | 34 | ; PARALLEL:INFO 35 | ; [symbol] 36 | ; 37 | ; INFO names a compiled function: 38 | ; Lambda-list: () 39 | ; Derived type: (FUNCTION NIL (VALUES NULL &OPTIONAL)) 40 | ; Source file: /data/x/weird/src/parallel/main.lisp 41 | ``` 42 | 43 | #### PARALLEL:INIT 44 | 45 | ``` 46 | :missing:todo: 47 | 48 | ; PARALLEL:INIT 49 | ; [symbol] 50 | ; 51 | ; INIT names a compiled function: 52 | ; Lambda-list: (&KEY (CORES 4) (NAME custom-kernel)) 53 | ; Derived type: (FUNCTION (&KEY (:CORES T) (:NAME T)) 54 | ; (VALUES T &OPTIONAL)) 55 | ; Source file: /data/x/weird/src/parallel/main.lisp 56 | ``` 57 | 58 | -------------------------------------------------------------------------------- /docs/SIMPLIFY.md: -------------------------------------------------------------------------------- 1 | #### SIMPLIFY:PATH 2 | 3 | ``` 4 | 5 | simplify path, pts. 6 | lim is the distance of candidate pt to candidate line 7 | returns new path 8 | 9 | 10 | ; SIMPLIFY:PATH 11 | ; [symbol] 12 | ; 13 | ; PATH names a compiled function: 14 | ; Lambda-list: (PTS &KEY (LIM 1.0)) 15 | ; Derived type: (FUNCTION 16 | ; ((SIMPLE-ARRAY SINGLE-FLOAT) &KEY (:LIM SINGLE-FLOAT)) 17 | ; (VALUES T (VECTOR (UNSIGNED-BYTE 31)) &OPTIONAL)) 18 | ; Documentation: 19 | ; 20 | ; simplify path, pts. 21 | ; lim is the distance of candidate pt to candidate line 22 | ; returns new path 23 | ; 24 | ; Source file: /data/x/weird/src/draw/simplify-path.lisp 25 | ``` 26 | 27 | -------------------------------------------------------------------------------- /docs/STATE.md: -------------------------------------------------------------------------------- 1 | #### STATE:AWITH 2 | 3 | ``` 4 | access state[key] as state:it, 5 | the final form of body is assigned back to state[key] 6 | 7 | ; STATE:AWITH 8 | ; [symbol] 9 | ; 10 | ; AWITH names a macro: 11 | ; Lambda-list: ((ST K &KEY DEFAULT) &BODY BODY) 12 | ; Documentation: 13 | ; access state[key] as state:it, 14 | ; the final form of body is assigned back to state[key] 15 | ; Source file: /data/x/weird/src/state.lisp 16 | ``` 17 | 18 | #### STATE:IT 19 | 20 | ``` 21 | :missing:todo: 22 | 23 | ; STATE:IT 24 | ; [symbol] 25 | ``` 26 | 27 | #### STATE:LGET 28 | 29 | ``` 30 | get keys of state (or default) 31 | 32 | ; STATE:LGET 33 | ; [symbol] 34 | ; 35 | ; LGET names a compiled function: 36 | ; Lambda-list: (ST KEYS &KEY DEFAULT) 37 | ; Derived type: (FUNCTION (STATE::STATE LIST &KEY (:DEFAULT T)) 38 | ; (VALUES LIST &OPTIONAL)) 39 | ; Documentation: 40 | ; get keys of state (or default) 41 | ; Source file: /data/x/weird/src/state.lisp 42 | ``` 43 | 44 | #### STATE:LSET 45 | 46 | ``` 47 | set keys of st to v. returns keys 48 | 49 | ; STATE:LSET 50 | ; [symbol] 51 | ; 52 | ; LSET names a compiled function: 53 | ; Lambda-list: (ST KEYS V) 54 | ; Derived type: (FUNCTION (STATE::STATE LIST T) (VALUES NULL &OPTIONAL)) 55 | ; Documentation: 56 | ; set keys of st to v. returns keys 57 | ; Source file: /data/x/weird/src/state.lisp 58 | ``` 59 | 60 | #### STATE:MAKE 61 | 62 | ``` 63 | :missing:todo: 64 | 65 | ; STATE:MAKE 66 | ; [symbol] 67 | ; 68 | ; MAKE names a compiled function: 69 | ; Lambda-list: () 70 | ; Derived type: (FUNCTION NIL (VALUES STATE::STATE &OPTIONAL)) 71 | ; Source file: /data/x/weird/src/state.lisp 72 | ``` 73 | 74 | #### STATE:SGET 75 | 76 | ``` 77 | get k of state (or default) 78 | 79 | ; STATE:SGET 80 | ; [symbol] 81 | ; 82 | ; SGET names a compiled function: 83 | ; Lambda-list: (ST K &KEY DEFAULT) 84 | ; Derived type: (FUNCTION (STATE::STATE T &KEY (:DEFAULT T)) 85 | ; (VALUES T BOOLEAN &OPTIONAL)) 86 | ; Documentation: 87 | ; get k of state (or default) 88 | ; Source file: /data/x/weird/src/state.lisp 89 | ; 90 | ; (SETF SGET) has setf-expansion: STATE::-SSET 91 | ``` 92 | 93 | #### STATE:TO-LIST 94 | 95 | ``` 96 | get state as alist 97 | 98 | ; STATE:TO-LIST 99 | ; [symbol] 100 | ; 101 | ; TO-LIST names a compiled function: 102 | ; Lambda-list: (ST) 103 | ; Derived type: (FUNCTION (STATE::STATE) (VALUES LIST &OPTIONAL)) 104 | ; Documentation: 105 | ; get state as alist 106 | ; Source file: /data/x/weird/src/state.lisp 107 | ``` 108 | 109 | #### STATE:WITH 110 | 111 | ``` 112 | :missing:todo: 113 | 114 | ; STATE:WITH 115 | ; [symbol] 116 | ``` 117 | 118 | -------------------------------------------------------------------------------- /docs/VOXEL.md: -------------------------------------------------------------------------------- 1 | #### VOXEL:GET-MESH 2 | 3 | ``` 4 | reconstruct mesh surounding (fx ...) == t. 5 | 6 | ; VOXEL:GET-MESH 7 | ; [symbol] 8 | ; 9 | ; GET-MESH names a compiled function: 10 | ; Lambda-list: (WER VOXS &KEY W (FX (LAMBDA (V) (>= 0.0 V)))) 11 | ; Derived type: (FUNCTION 12 | ; (T VOXEL::VOXELS &KEY (:W BOOLEAN) (:FX FUNCTION)) 13 | ; (VALUES LIST &OPTIONAL)) 14 | ; Documentation: 15 | ; reconstruct mesh surounding (fx ...) == t. 16 | ; Source file: /data/x/weird/src/voxel/voxel.lisp 17 | ``` 18 | 19 | #### VOXEL:GETVOXEL 20 | 21 | ``` 22 | :missing:todo: 23 | 24 | ; VOXEL:GETVOXEL 25 | ; [symbol] 26 | ; 27 | ; GETVOXEL names a compiled function: 28 | ; Lambda-list: (VOXS IX IY IZ) 29 | ; Derived type: (FUNCTION 30 | ; (VOXEL::VOXELS (UNSIGNED-BYTE 31) (UNSIGNED-BYTE 31) 31 | ; (UNSIGNED-BYTE 31)) 32 | ; (VALUES SINGLE-FLOAT &OPTIONAL)) 33 | ; Source file: /data/x/weird/src/voxel/init.lisp 34 | ``` 35 | 36 | #### VOXEL:MAKE 37 | 38 | ``` 39 | :missing:todo: 40 | 41 | ; VOXEL:MAKE 42 | ; [symbol] 43 | ; 44 | ; MAKE names a compiled function: 45 | ; Lambda-list: (DIM) 46 | ; Derived type: (FUNCTION (LIST) (VALUES VOXEL::VOXELS &OPTIONAL)) 47 | ; Source file: /data/x/weird/src/voxel/init.lisp 48 | ``` 49 | 50 | #### VOXEL:SETVOXEL 51 | 52 | ``` 53 | :missing:todo: 54 | 55 | ; VOXEL:SETVOXEL 56 | ; [symbol] 57 | ; 58 | ; SETVOXEL names a compiled function: 59 | ; Lambda-list: (VOXS IX IY IZ &OPTIONAL (V 1.0)) 60 | ; Derived type: (FUNCTION 61 | ; (VOXEL::VOXELS (UNSIGNED-BYTE 31) (UNSIGNED-BYTE 31) 62 | ; (UNSIGNED-BYTE 31) &OPTIONAL SINGLE-FLOAT) 63 | ; (VALUES SINGLE-FLOAT &OPTIONAL)) 64 | ; Source file: /data/x/weird/src/voxel/init.lisp 65 | ``` 66 | 67 | -------------------------------------------------------------------------------- /examples/draw.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/sbcl --script 2 | 3 | (load "~/quicklisp/setup.lisp") 4 | (ql:quickload :weird) 5 | 6 | 7 | (veq:fvdef main (size fn) 8 | (let ((wer (weir:make)) 9 | (wsvg (wsvg:make*))) 10 | 11 | (weir:2add-path! wer 12 | (f2!@$+ (veq:f$_ '((-1f0 -202f0) (400f0 300f0))) 51f0 700f0)) 13 | (weir:2add-path! wer (veq:f$_ '((401f0 2f0) (4f0 300f0)))) 14 | 15 | (weir:2add-path! wer 16 | (f2!@$+ (veq:f2$square* 52f0) 700f0 700f0)) 17 | (weir:2add-path! wer 18 | (f2!@$+ (veq:f2$polygon 5 100f0) 800f0 800f0) 19 | :closed t) 20 | 21 | (weir:2intersect-all! wer) 22 | 23 | (weir:itr-edges (wer e) 24 | (wsvg:path wsvg (weir:2gvs wer e) :sw 10 :so 0.2)) 25 | 26 | (loop for path in (weir:2walk-graph wer) 27 | do (wsvg:path wsvg (weir:2gvs wer path))) 28 | 29 | (wsvg:rect wsvg 10 100 :xy '(200 200) :sw 3f0 :stroke "red") 30 | (wsvg:rect wsvg 30 10 :xy '(400 200) :fill "black" :fo 0.5) 31 | (wsvg:rect wsvg 10 30 :xy '(400 200) :fill "black" :fo 0.5 :sw 4) 32 | 33 | (wsvg:circ wsvg 10 :xy '(200 200)) 34 | (wsvg:wcirc wsvg 20 :xy '(200 200)) 35 | 36 | (weir:itr-verts (wer v) 37 | (wsvg:circ wsvg 3 :xy (veq:lst (weir:2gv wer v)) :fill "black")) 38 | 39 | (wsvg:save wsvg "draw"))) 40 | 41 | 42 | (time (main 1000 (second (weird:cmd-args)))) 43 | 44 | -------------------------------------------------------------------------------- /examples/ex.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/sbcl --script 2 | 3 | (load "~/quicklisp/setup.lisp") 4 | (ql:quickload :weird) 5 | 6 | 7 | (veq:vdef* init-weir () 8 | (let ((wer (weir:make :max-verts 1000 :name :weirinst))) 9 | (weir:2add-vert! wer 70f0 200f0) 10 | (weir:2add-vert! wer 20f0 300f0) 11 | (weir:2add-verts! wer (f2!@$+ (rnd:2nin-square 20 500f0) 12 | (veq:f2rep 500f0))) 13 | (weir:add-edge! wer 1 2) 14 | (weir:ladd-edge! wer '(0 1)) 15 | (weir:ladd-edge! wer '(3 1)) 16 | (weir:add-edges! wer '((5 6) (7 3))) 17 | wer)) 18 | 19 | ; example definition of custom alteration that creates two vertices, and conenct them 20 | (weir:defalt xadd-edge? (www f2!p f2!q) 21 | (weir:add-edge! www (weir:2add-vert! www f2!p) 22 | (weir:2add-vert! www f2!q))) 23 | 24 | 25 | (veq:fvdef main (size fn) 26 | (let* ((wer (init-weir)) 27 | (wsvg (wsvg:make*)) 28 | (g (weir:add-grp! wer :name :rel))) 29 | 30 | ; silly alteration example. use :db to print alteration code. 31 | (print (weir:get-num-verts wer)) 32 | 33 | ; :mode :warn wil print a warning because a? depends on v?, but v? does not 34 | ; exist for every a?. use :mode :t to ignore, or :mode :strict to throw an 35 | ; error. 36 | (weir:with (wer % :db t :mode :warn) 37 | ; this loop will create all alterations from all the 50 iterations before 38 | ; any of the alterations are applied. for that reason we use with-gs to 39 | ; create distinct names ea?, rad? v?, xedge? for each iterations. these 40 | ; names are used to reference the corresponding results of each 41 | ; alteration. 42 | (loop for i from 0 below 50 43 | do (weir:with-gs (ea? rad? v? xedge?) 44 | ; with prob 0.2 add an edge using xadd-edge? the resulting 45 | ; edge is named xedge? 46 | (rnd:prob* 0.2 (% (xadd-edge? (veq:f3rep (rnd:rnd 1000f0)) 47 | (veq:f2rep (rnd:rnd 1000f0))) 48 | :res xedge?) 49 | (% (set-edge-prop? xedge? :opacity (rnd:rnd)))) 50 | ; with prob 0.4 add a vert named v? 51 | (rnd:prob 0.4 (% (2add-vert? (veq:f2rep (rnd:rnd 1000f0))) :res v?)) 52 | ; with prob 0.7 add an edge (that depends on v?) named ea?, if 53 | ; edge ea? is created, set the vert property of the first vert 54 | ; in a?. the prop is named rad? (but is not used for anything) 55 | (rnd:prob 0.7 56 | (progn (% (add-edge? v? (+ i 1)) :res ea?) 57 | (% (set-vert-prop? (first ea?) :rad (rnd:rnd 20f0)) 58 | :res rad?))) 59 | (% (? (w) (list (weir:get-num-verts w) )))))) 60 | (pprint (weir:get-alteration-result-list wer)) 61 | 62 | (weir:2intersect-all! wer) 63 | (weir:2relneigh! wer 500f0 :g :rel) 64 | (print wer) 65 | 66 | (loop for path in (weir:2walk-graph wer) 67 | do (wsvg:path wsvg (weir:2gvs wer path))) 68 | 69 | (loop for path in (weir:2walk-graph wer :g :rel) 70 | do (wsvg:path wsvg (weir:2gvs wer path) :sw 5f0 :so 0.2)) 71 | 72 | (weir:itr-verts (wer v) 73 | (let ((rad (weird:aif (weir:get-vert-prop wer v :rad) weird:it 5f0))) 74 | (if (= (length (weir:get-incident-verts wer v)) 1) 75 | (wsvg:circ wsvg rad :xy (veq:lst (weir:2gv wer v)) :fill "black") 76 | (wsvg:circ wsvg rad :xy (veq:lst (weir:2gv wer v)))))) 77 | 78 | (wsvg:save wsvg "ex"))) 79 | 80 | 81 | (time (main 1000 (second (weird:cmd-args)))) 82 | 83 | -------------------------------------------------------------------------------- /img/boxes.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weird/fb50aa89303f4742787eb681a2f939ac6c99c1f9/img/boxes.png -------------------------------------------------------------------------------- /img/scribble.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weird/fb50aa89303f4742787eb681a2f939ac6c99c1f9/img/scribble.png -------------------------------------------------------------------------------- /img/sun.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weird/fb50aa89303f4742787eb681a2f939ac6c99c1f9/img/sun.png -------------------------------------------------------------------------------- /img/symbols.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weird/fb50aa89303f4742787eb681a2f939ac6c99c1f9/img/symbols.png -------------------------------------------------------------------------------- /img/web.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/inconvergent/weird/fb50aa89303f4742787eb681a2f939ac6c99c1f9/img/web.png -------------------------------------------------------------------------------- /make-docs.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/sbcl --script 2 | 3 | (load "~/quicklisp/setup.lisp") 4 | (ql:quickload :weird) 5 | 6 | (in-package :weird) 7 | 8 | (defun make-docs () 9 | (loop for (o . rest) in (dat:import-all-data 10 | (weird:internal-path-string "src/packages") ".lisp") 11 | if (eq o 'defpackage) 12 | do (let* ((pkg (weird:mkstr (car rest))) 13 | (fn (weird:internal-path-string (weird:mkstr "docs/" pkg ".md"))) 14 | (s (with-output-to-string (*standard-output*) 15 | (ext-symbols? pkg :pretty)))) 16 | (with-open-file (fstream fn :direction :output :if-exists :supersede) 17 | (format fstream s))))) 18 | 19 | (make-docs) 20 | 21 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | sbcl --quit \ 6 | --eval '(load "~/quicklisp/setup.lisp")'\ 7 | --eval '(handler-case (ql:quickload :weird :verbose t) 8 | (error (c) (format t "STAGE1FAIL: ~a" c) 9 | (sb-ext:quit :unix-status 2)))' 10 | 11 | sbcl --quit \ 12 | --eval '(load "~/quicklisp/setup.lisp")'\ 13 | --eval '(ql:quickload :prove :verbose nil)'\ 14 | --eval '(handler-case (asdf:test-system :weird) 15 | (error (c) (format t "STAGE2FAIL: ~a" c) 16 | (sb-ext:quit :unix-status 3)))' 17 | -------------------------------------------------------------------------------- /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 #:weird) 7 | 8 | (setf *random-state* (make-random-state t) 9 | *print-pretty* t ) 10 | 11 | (declaim (single-float *eps*) (boolean *dev*) (cons *opt*)) 12 | (defparameter *eps* veq::*eps*) 13 | 14 | (init-config (optimize safety (speed 1) debug (space 2)) 15 | (optimize (safety 1) (speed 3) debug space)) 16 | 17 | -------------------------------------------------------------------------------- /src/data/cone.obj: -------------------------------------------------------------------------------- 1 | o Cone 2 | v 0.000000 -1.000000 -1.000000 3 | v 0.195090 -1.000000 -0.980785 4 | v 0.382683 -1.000000 -0.923880 5 | v 0.555570 -1.000000 -0.831470 6 | v 0.707107 -1.000000 -0.707107 7 | v 0.831470 -1.000000 -0.555570 8 | v 0.923880 -1.000000 -0.382683 9 | v 0.980785 -1.000000 -0.195090 10 | v 1.000000 -1.000000 -0.000000 11 | v 0.980785 -1.000000 0.195090 12 | v 0.923880 -1.000000 0.382683 13 | v 0.831470 -1.000000 0.555570 14 | v 0.707107 -1.000000 0.707107 15 | v 0.555570 -1.000000 0.831470 16 | v 0.382683 -1.000000 0.923880 17 | v 0.195090 -1.000000 0.980785 18 | v -0.000000 -1.000000 1.000000 19 | v -0.195091 -1.000000 0.980785 20 | v -0.382684 -1.000000 0.923879 21 | v -0.555571 -1.000000 0.831469 22 | v -0.707107 -1.000000 0.707106 23 | v -0.831470 -1.000000 0.555570 24 | v -0.923880 -1.000000 0.382683 25 | v 0.000000 1.000000 0.000000 26 | v -0.980785 -1.000000 0.195089 27 | v -1.000000 -1.000000 -0.000001 28 | v -0.980785 -1.000000 -0.195091 29 | v -0.923879 -1.000000 -0.382684 30 | v -0.831469 -1.000000 -0.555571 31 | v -0.707106 -1.000000 -0.707108 32 | v -0.555569 -1.000000 -0.831470 33 | v -0.382682 -1.000000 -0.923880 34 | v -0.195089 -1.000000 -0.980786 35 | vt 0.250000 0.490000 36 | vt 0.250000 0.250000 37 | vt 0.296822 0.485388 38 | vt 0.341844 0.471731 39 | vt 0.383337 0.449553 40 | vt 0.419706 0.419706 41 | vt 0.449553 0.383337 42 | vt 0.471731 0.341844 43 | vt 0.485388 0.296822 44 | vt 0.490000 0.250000 45 | vt 0.485388 0.203178 46 | vt 0.471731 0.158156 47 | vt 0.449553 0.116663 48 | vt 0.419706 0.080294 49 | vt 0.383337 0.050447 50 | vt 0.341844 0.028269 51 | vt 0.296822 0.014612 52 | vt 0.250000 0.010000 53 | vt 0.203178 0.014612 54 | vt 0.158156 0.028269 55 | vt 0.116663 0.050447 56 | vt 0.080294 0.080294 57 | vt 0.050447 0.116663 58 | vt 0.028269 0.158156 59 | vt 0.014611 0.203179 60 | vt 0.010000 0.250000 61 | vt 0.014612 0.296822 62 | vt 0.028269 0.341844 63 | vt 0.050447 0.383337 64 | vt 0.080295 0.419706 65 | vt 0.116663 0.449553 66 | vt 0.158156 0.471731 67 | vt 0.203179 0.485389 68 | vt 0.985388 0.296822 69 | vt 0.796822 0.014612 70 | vt 0.514611 0.203179 71 | vt 0.703179 0.485389 72 | vt 0.750000 0.490000 73 | vt 0.796822 0.485388 74 | vt 0.841844 0.471731 75 | vt 0.883337 0.449553 76 | vt 0.919706 0.419706 77 | vt 0.949553 0.383337 78 | vt 0.971731 0.341844 79 | vt 0.990000 0.250000 80 | vt 0.985388 0.203178 81 | vt 0.971731 0.158156 82 | vt 0.949553 0.116663 83 | vt 0.919706 0.080294 84 | vt 0.883337 0.050447 85 | vt 0.841844 0.028269 86 | vt 0.750000 0.010000 87 | vt 0.703178 0.014612 88 | vt 0.658156 0.028269 89 | vt 0.616663 0.050447 90 | vt 0.580294 0.080294 91 | vt 0.550447 0.116663 92 | vt 0.528269 0.158156 93 | vt 0.510000 0.250000 94 | vt 0.514612 0.296822 95 | vt 0.528269 0.341844 96 | vt 0.550447 0.383337 97 | vt 0.580295 0.419706 98 | vt 0.616663 0.449553 99 | vt 0.658156 0.471731 100 | vn 0.0878 0.4455 -0.8910 101 | vn 0.2599 0.4455 -0.8567 102 | vn 0.4220 0.4455 -0.7896 103 | vn 0.5680 0.4455 -0.6921 104 | vn 0.6921 0.4455 -0.5680 105 | vn 0.7896 0.4455 -0.4220 106 | vn 0.8567 0.4455 -0.2599 107 | vn 0.8910 0.4455 -0.0878 108 | vn 0.8910 0.4455 0.0878 109 | vn 0.8567 0.4455 0.2599 110 | vn 0.7896 0.4455 0.4220 111 | vn 0.6921 0.4455 0.5680 112 | vn 0.5680 0.4455 0.6921 113 | vn 0.4220 0.4455 0.7896 114 | vn 0.2599 0.4455 0.8567 115 | vn 0.0878 0.4455 0.8910 116 | vn -0.0878 0.4455 0.8910 117 | vn -0.2599 0.4455 0.8567 118 | vn -0.4220 0.4455 0.7896 119 | vn -0.5680 0.4455 0.6921 120 | vn -0.6921 0.4455 0.5680 121 | vn -0.7896 0.4455 0.4220 122 | vn -0.8567 0.4455 0.2599 123 | vn -0.8910 0.4455 0.0878 124 | vn -0.8910 0.4455 -0.0878 125 | vn -0.8567 0.4455 -0.2599 126 | vn -0.7896 0.4455 -0.4220 127 | vn -0.6921 0.4455 -0.5680 128 | vn -0.5680 0.4455 -0.6921 129 | vn -0.4220 0.4455 -0.7896 130 | vn -0.2599 0.4455 -0.8567 131 | vn -0.0878 0.4455 -0.8910 132 | vn 0.0000 -1.0000 0.0000 133 | usemtl None 134 | s off 135 | f 1/1/1 24/2/1 2/3/1 136 | f 2/3/2 24/2/2 3/4/2 137 | f 3/4/3 24/2/3 4/5/3 138 | f 4/5/4 24/2/4 5/6/4 139 | f 5/6/5 24/2/5 6/7/5 140 | f 6/7/6 24/2/6 7/8/6 141 | f 7/8/7 24/2/7 8/9/7 142 | f 8/9/8 24/2/8 9/10/8 143 | f 9/10/9 24/2/9 10/11/9 144 | f 10/11/10 24/2/10 11/12/10 145 | f 11/12/11 24/2/11 12/13/11 146 | f 12/13/12 24/2/12 13/14/12 147 | f 13/14/13 24/2/13 14/15/13 148 | f 14/15/14 24/2/14 15/16/14 149 | f 15/16/15 24/2/15 16/17/15 150 | f 16/17/16 24/2/16 17/18/16 151 | f 17/18/17 24/2/17 18/19/17 152 | f 18/19/18 24/2/18 19/20/18 153 | f 19/20/19 24/2/19 20/21/19 154 | f 20/21/20 24/2/20 21/22/20 155 | f 21/22/21 24/2/21 22/23/21 156 | f 22/23/22 24/2/22 23/24/22 157 | f 23/24/23 24/2/23 25/25/23 158 | f 25/25/24 24/2/24 26/26/24 159 | f 26/26/25 24/2/25 27/27/25 160 | f 27/27/26 24/2/26 28/28/26 161 | f 28/28/27 24/2/27 29/29/27 162 | f 29/29/28 24/2/28 30/30/28 163 | f 30/30/29 24/2/29 31/31/29 164 | f 31/31/30 24/2/30 32/32/30 165 | f 32/32/31 24/2/31 33/33/31 166 | f 33/33/32 24/2/32 1/1/32 167 | f 8/34/33 16/35/33 25/36/33 168 | f 33/37/33 1/38/33 2/39/33 169 | f 2/39/33 3/40/33 4/41/33 170 | f 4/41/33 5/42/33 6/43/33 171 | f 6/43/33 7/44/33 4/41/33 172 | f 7/44/33 8/34/33 4/41/33 173 | f 8/34/33 9/45/33 10/46/33 174 | f 10/46/33 11/47/33 8/34/33 175 | f 11/47/33 12/48/33 8/34/33 176 | f 12/48/33 13/49/33 16/35/33 177 | f 13/49/33 14/50/33 16/35/33 178 | f 14/50/33 15/51/33 16/35/33 179 | f 16/35/33 17/52/33 18/53/33 180 | f 18/53/33 19/54/33 20/55/33 181 | f 20/55/33 21/56/33 25/36/33 182 | f 21/56/33 22/57/33 25/36/33 183 | f 22/57/33 23/58/33 25/36/33 184 | f 25/36/33 26/59/33 27/60/33 185 | f 27/60/33 28/61/33 29/62/33 186 | f 29/62/33 30/63/33 31/64/33 187 | f 31/64/33 32/65/33 33/37/33 188 | f 33/37/33 2/39/33 4/41/33 189 | f 16/35/33 18/53/33 25/36/33 190 | f 18/53/33 20/55/33 25/36/33 191 | f 25/36/33 27/60/33 33/37/33 192 | f 27/60/33 29/62/33 33/37/33 193 | f 29/62/33 31/64/33 33/37/33 194 | f 33/37/33 4/41/33 8/34/33 195 | f 8/34/33 12/48/33 16/35/33 196 | f 33/37/33 8/34/33 25/36/33 197 | -------------------------------------------------------------------------------- /src/data/cube.obj: -------------------------------------------------------------------------------- 1 | v 1.000000 -1.000000 -1.000000 2 | v 1.000000 -1.000000 1.000000 3 | v -1.000000 -1.000000 1.000000 4 | v -1.000000 -1.000000 -1.000000 5 | v 1.000000 1.000000 -0.999999 6 | v 0.999999 1.000000 1.000001 7 | v -1.000000 1.000000 1.000000 8 | v -1.000000 1.000000 -1.000000 9 | f 2 3 4 10 | f 8 7 6 11 | f 5 6 2 12 | f 6 7 3 13 | f 3 7 8 14 | f 1 4 8 15 | f 1 2 4 16 | f 5 8 6 17 | f 1 5 2 18 | f 2 6 3 19 | f 4 3 8 20 | f 5 1 8 21 | -------------------------------------------------------------------------------- /src/data/ico.obj: -------------------------------------------------------------------------------- 1 | v 0.000000 -1.000000 0.000000 2 | v 0.723600 -0.447215 0.525720 3 | v -0.276385 -0.447215 0.850640 4 | v -0.894425 -0.447215 0.000000 5 | v -0.276385 -0.447215 -0.850640 6 | v 0.723600 -0.447215 -0.525720 7 | v 0.276385 0.447215 0.850640 8 | v -0.723600 0.447215 0.525720 9 | v -0.723600 0.447215 -0.525720 10 | v 0.276385 0.447215 -0.850640 11 | v 0.894425 0.447215 0.000000 12 | v 0.000000 1.000000 0.000000 13 | vn 0.1876 -0.7947 0.5774 14 | vn 0.6071 -0.7947 0.0000 15 | vn -0.4911 -0.7947 0.3568 16 | vn -0.4911 -0.7947 -0.3568 17 | vn 0.1876 -0.7947 -0.5774 18 | vn 0.9822 -0.1876 0.0000 19 | vn 0.3035 -0.1876 0.9342 20 | vn -0.7946 -0.1876 0.5774 21 | vn -0.7946 -0.1876 -0.5774 22 | vn 0.3035 -0.1876 -0.9342 23 | vn 0.7946 0.1876 0.5774 24 | vn -0.3035 0.1876 0.9342 25 | vn -0.9822 0.1876 0.0000 26 | vn -0.3035 0.1876 -0.9342 27 | vn 0.7946 0.1876 -0.5774 28 | vn 0.4911 0.7947 0.3568 29 | vn -0.1876 0.7947 0.5774 30 | vn -0.6071 0.7947 0.0000 31 | vn -0.1876 0.7947 -0.5774 32 | vn 0.4911 0.7947 -0.3568 33 | usemtl None 34 | s off 35 | f 1//1 2//1 3//1 36 | f 2//2 1//2 6//2 37 | f 1//3 3//3 4//3 38 | f 1//4 4//4 5//4 39 | f 1//5 5//5 6//5 40 | f 2//6 6//6 11//6 41 | f 3//7 2//7 7//7 42 | f 4//8 3//8 8//8 43 | f 5//9 4//9 9//9 44 | f 6//10 5//10 10//10 45 | f 2//11 11//11 7//11 46 | f 3//12 7//12 8//12 47 | f 4//13 8//13 9//13 48 | f 5//14 9//14 10//14 49 | f 6//15 10//15 11//15 50 | f 7//16 11//16 12//16 51 | f 8//17 7//17 12//17 52 | f 9//18 8//18 12//18 53 | f 10//19 9//19 12//19 54 | f 11//20 10//20 12//20 55 | -------------------------------------------------------------------------------- /src/docs.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weird) 3 | 4 | (declaim (list *docstring-map*)) 5 | (defvar *docstring-map* (list)) 6 | 7 | 8 | (defun desc (sym) 9 | (declare #.*opt* (symbol sym)) 10 | (let ((d (with-output-to-string (*standard-output*) 11 | (describe sym)))) 12 | (apply #'mkstr (mapcar (lambda (s) (mkstr " ; " s #\Newline)) 13 | (butlast (veq::split-string #\Newline d)))))) 14 | 15 | (defun docstrings (sym) 16 | (apply #'mkstr 17 | (mapcar (lambda (o) (mkstr o #\Newline)) 18 | (remove-if-not #'identity (list (documentation sym 'function) 19 | (documentation sym 'setf)))))) 20 | 21 | 22 | (defun select-docs (sym) 23 | (declare #.*opt* (symbol sym)) 24 | (let* ((docs (find-if (lambda (c) (eq sym c)) *docstring-map* :key #'car)) 25 | (idocs (docstrings sym)) 26 | (skip (find :skip docs)) 27 | (desc (unless (find :nodesc docs) (desc sym)))) 28 | (declare (list docs)) 29 | 30 | (values 31 | (cond (docs (format nil "```~%~a~@[~&~%~a~&~]~&```" (cadr docs) desc)) 32 | ((and idocs (> (length idocs) 0)) 33 | (format nil "```~%~a~@[~&~%~a~&~]~&```" idocs desc)) 34 | (t (format nil "```~%:missing:todo:~%~@[~&~%~a~&~]~&```" desc))) 35 | skip))) 36 | 37 | (defmacro pckgs (pkg) 38 | (awg (sym) 39 | `(sort (loop for ,sym being the external-symbols of (find-package ,pkg) 40 | collect (list (mkstr ,sym) ,sym)) 41 | #'string-lessp :key #'car))) 42 | 43 | 44 | (defun -md-sanitize (d) 45 | (let ((sp (veq::split-string #\* d))) 46 | (apply #'veq::mkstr 47 | (concatenate 'list (mapcar (lambda (s) 48 | (veq::mkstr s #\\ #\*)) (butlast sp)) 49 | (last sp))))) 50 | 51 | (defmacro ext-symbols? (pkg &optional mode) 52 | "list all external symbols in pkg. use :verbose to inlcude docstring. 53 | use :pretty to print verbose output to stdout in a readable form." 54 | (awg (str sym doc skip) 55 | (case mode 56 | (:pretty 57 | `(loop for (,str ,sym) in (pckgs ,pkg) 58 | do (mvb (,doc ,skip) (select-docs ,sym) 59 | (unless ,skip (format t "~&#### ~a:~a~%~%~a~&~%" 60 | (weird:mkstr ,pkg) 61 | (-md-sanitize ,str) 62 | ,doc))))) 63 | (:pairs `(loop for (,str ,sym) in (pckgs ,pkg) 64 | collect (list ,str (select-docs ,sym)))) 65 | (otherwise `(loop for (,str ,sym) in (pckgs ,pkg) collect ,str))))) 66 | 67 | (defun map-docstring (&rest rest) 68 | (declare #.*opt* (list rest)) 69 | "register docs info associated with symbol (car rest)." 70 | (setf *docstring-map* (remove-if (lambda (cand) (eq (car cand) (car rest))) 71 | *docstring-map*)) 72 | (push rest *docstring-map*)) 73 | 74 | -------------------------------------------------------------------------------- /src/draw/bzspl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :bzspl) 3 | 4 | ; http://graphics.cs.ucdavis.edu/~joy/ecs178/Unit-7-Notes/MatrixBSpline.pdf 5 | 6 | (declaim (veq:ff *lim*)) 7 | (defparameter *lim* 0.1) 8 | 9 | (defstruct bzspl 10 | (n nil :type veq:pn :read-only t) 11 | (ns nil :type veq:pn :read-only t) 12 | (closed nil :type boolean :read-only t) 13 | (vpts nil :type veq:fvec :read-only t)) 14 | 15 | 16 | (declaim (inline -do-calc)) 17 | (veq:fvdef -do-calc (vpts seg x) 18 | (declare #.*opt* (veq:fvec vpts) (veq:ff x) (veq:pn seg)) 19 | (veq:xlet ((f!2x (+ x x)) 20 | (f!xe2 (* x x)) 21 | (p!ia (* 2 seg))) 22 | (labels ((fx ((:va 2 va vb vc)) 23 | (f2!@+ (f2!@*. vc xe2) 24 | (f2!@+ (f2!@*. va (+ 1f0 (- 2x) xe2)) 25 | (f2!@*. vb (+ 2x (* -2f0 xe2))))))) 26 | (m@fx (veq:f2$ vpts ia (+ ia 1) (+ ia 2)))))) 27 | 28 | ; TODO: wrap around? 29 | (declaim (inline -get-seg)) 30 | (defun -get-seg (ns x &aux (s (veq:ff ns))) 31 | (declare #.*opt* (veq:pn ns) (veq:ff x s)) 32 | (if (>= x 1f0) (values (1- ns) 1f0) 33 | (truncate (the veq:ff (* x s))))) 34 | 35 | (declaim (inline -x-to-pt)) 36 | (veq:fvdef -x-to-pt (vpts ns x) 37 | (declare #.*opt* (veq:fvec vpts) (veq:pn ns) (veq:ff x)) 38 | (m@-do-calc vpts (-get-seg ns x))) 39 | 40 | 41 | ; TODO: handle closed differently? 42 | (veq:fvdef adaptive-pos (bz &optional (lim *lim*)) 43 | (declare (bzspl bz) (veq:ff lim)) 44 | (with-struct (bzspl- ns vpts) bz 45 | (declare (veq:pn ns) (veq:fvec vpts)) 46 | (labels 47 | ((-to-res (pts) (veq:f$_ (map 'list #'second pts))) 48 | (-resappend (res a (:va 2 av)) 49 | (declare (vector res)) 50 | (if (or (< (length res) 1) 51 | (> a (car (weird:vector-last res)))) 52 | (weird:vextend (list a (list av)) res))) 53 | (-midsample (l r) 54 | (declare (veq:ff l r)) 55 | (+ (* 0.5f0 (+ r l)) (rnd:rnd* (* 0.2f0 (- r l))))) 56 | (-area ((:va 2 a b c)) 57 | (declare (veq:ff a b c)) 58 | (* 0.5f0 (+ (* (:vr a 0) (- (:vr b 1) (:vr c 1))) 59 | (* (:vr b 0) (- (:vr c 1) (:vr a 1))) 60 | (* (:vr c 0) (- (:vr a 1) (:vr b 1)))))) 61 | (-adaptive (l r (:va 2 lv rv) res) 62 | (veq:xlet ((f!m (-midsample l r)) 63 | (f2!mv (-x-to-pt vpts ns m))) 64 | (if (< (abs (-area lv mv rv)) lim) 65 | (progn (-resappend res l lv) 66 | (-resappend res r rv)) 67 | (progn (-adaptive l m lv mv res) 68 | (-adaptive m r mv rv res)))))) 69 | (veq:xlet ((f!m (-midsample 0f0 1f0)) 70 | (res (make-adjustable-vector :type 'list)) 71 | (f2!mv (-x-to-pt vpts ns m))) 72 | (declare (vector res)) 73 | (m@-adaptive 0f0 m (-x-to-pt vpts ns 0f0) mv res) 74 | (m@-adaptive m 1f0 mv (-x-to-pt vpts ns 1f0) res) 75 | (-to-res res))))) 76 | 77 | (veq:fvdef len (bz &optional (lim *lim*)) 78 | (declare (bzspl bz)) 79 | (loop with pts of-type veq:fvec = (adaptive-pos bz lim) 80 | for i from 0 below (1- (veq:f2$num pts)) 81 | summing (veq:f2dst (veq:f2$ pts i (1+ i))) of-type veq:ff)) 82 | 83 | (defun pos (bz x) 84 | (declare #.*opt* (bzspl bz) (veq:ff x)) 85 | (-x-to-pt (bzspl-vpts bz) (bzspl-ns bz) x)) 86 | 87 | (veq:fvdef pos* (b xx) 88 | (declare #.*opt* (bzspl b) (list xx)) 89 | (with-struct (bzspl- ns vpts) b 90 | (declare (veq:pn ns) (veq:fvec vpts)) 91 | (loop with res of-type veq:fvec = (veq:f$make :dim 2 :n (length xx)) 92 | for x of-type veq:ff in xx 93 | for i of-type veq:pn from 0 94 | do (veq:2$vset (res i) (-x-to-pt vpts ns x)) 95 | finally (return res)))) 96 | 97 | (defun rndpos (b n &key order) 98 | (declare #.*opt* (bzspl b) (veq:pn n)) 99 | (pos* b (rnd:rndspace n 0f0 1f0 :order order))) 100 | 101 | (defmacro -set (vpts opts a b) 102 | `(veq:fvprogn (veq:2$vset (,vpts ,b) (veq:f2$ ,opts ,a)))) 103 | 104 | (defmacro -set-mean (vpts opts a b c) 105 | `(veq:fvprogn (veq:2$vset (,vpts ,c) 106 | (f2!@/. (f2!@+ (veq:f2$ ,opts ,a ,b)) 2f0)))) 107 | 108 | (defun -set-vpts-open (vpts pts n &aux (n* (- (* 2 n) 3))) 109 | (declare #.*opt* (veq:pn n n*) (veq:fvec vpts pts)) 110 | (loop for i of-type veq:pn from 0 below 2 111 | and k of-type veq:pn from (- n* 2) 112 | and j of-type veq:pn from (- n 2) 113 | do (-set vpts pts i i) 114 | (-set vpts pts j k)) 115 | (loop for i of-type veq:pn from 1 below (- n 2) 116 | and i+ of-type veq:pn from 1 by 2 117 | do (-set vpts pts i i+) 118 | (-set-mean vpts pts i (+ i 1) (+ i+ 1)))) 119 | 120 | (defun -set-vpts-closed (vpts pts n &aux (n* (+ (* 2 n) 1))) 121 | (declare #.*opt* (veq:pn n n*) (veq:fvec vpts pts)) 122 | (loop for i of-type veq:pn from 0 below n 123 | and ii of-type veq:pn from 0 by 2 124 | do (-set-mean vpts pts i (mod (+ i 1) n) ii) 125 | (-set vpts pts (mod (+ i 1) n) (+ ii 1)) 126 | finally (-set-mean vpts pts 0 1 (- n* 1)))) 127 | 128 | (defun make (pts &key closed &aux (n (veq:2$num pts))) 129 | (declare #.*opt* (veq:fvec pts) (boolean closed) (veq:pn n)) 130 | (assert (>= n 3) (n) "must have at least 3 pts. has ~a." n) 131 | (let ((vpts (veq:f$make :n (if closed (+ (* 2 n) 1) (- (* 2 n) 3)) :dim 2))) 132 | (if closed (-set-vpts-closed vpts pts n) (-set-vpts-open vpts pts n)) 133 | (make-bzspl :n n :ns (if closed n (- n 2)) :vpts vpts :closed closed))) 134 | 135 | -------------------------------------------------------------------------------- /src/draw/canvas.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :canvas) 3 | 4 | 5 | (defmacro -do-op ((canv size vals indfx) &body body) 6 | (declare (symbol canv size vals indfx)) 7 | (alexandria:with-gensyms (sname) 8 | `(let* ((,sname ,canv) 9 | (,size (canvas-size ,sname)) 10 | (,vals (canvas-vals ,sname)) 11 | (,indfx (canvas-indfx ,sname))) 12 | (declare (veq:fvec ,vals) (function ,indfx) (small-ind ,size) 13 | (ignorable ,size)) 14 | (progn ,@body)))) 15 | 16 | (defmacro -square-loop ((x y n) &body body) 17 | (declare (symbol x y n)) 18 | (alexandria:with-gensyms (nname) 19 | `(let ((,nname ,n)) 20 | (loop for ,y of-type small-ind from 0 below ,nname 21 | do (loop for ,x of-type small-ind from 0 below ,nname 22 | do (progn ,@body)))))) 23 | 24 | (defstruct canvas 25 | (size nil :type small-ind :read-only t) 26 | (vals nil :type veq:fvec :read-only t) 27 | (indfx nil :type function :read-only t)) 28 | 29 | 30 | (declaim (inline set-pix)) 31 | (defun set-pix (canv i j r g b) 32 | (declare #.*opt* (veq:pn i j) (veq:ff r g b)) 33 | "set (i j) to value (r g b) where 0.0 =< r,g,b =< 1.0." 34 | (-do-op (canv size vals indfx) 35 | (let ((ind (funcall indfx i j))) 36 | (declare (veq:pn ind)) 37 | (setf (aref vals ind) (max 0f0 (min 1f0 r)) 38 | (aref vals (1+ ind)) (max 0f0 (min 1f0 g)) 39 | (aref vals (+ ind 2)) (max 0f0 (min 1f0 b))) 40 | nil))) 41 | 42 | (declaim (inline set-gray-pix)) 43 | (defun set-gray-pix (canv i j c) 44 | (declare #.*opt* (veq:pn i j) (veq:ff c)) 45 | "set (i j) to value c where 0.0 =< c =< 1.0." 46 | (-do-op (canv size vals indfx) 47 | (let ((ind (funcall indfx i j)) 48 | (c* (max 0f0 (min 1f0 c)))) 49 | (declare (veq:pn ind) (veq:ff c*)) 50 | (setf (aref vals ind) c* 51 | (aref vals (1+ ind)) c* 52 | (aref vals (+ ind 2)) c*) 53 | nil))) 54 | 55 | (defun get-size (canv) (canvas-size canv)) 56 | 57 | (defun -get-indfx (size) 58 | (declare #.*opt* (small-ind size)) 59 | (labels ((-indfx (s x y c) 60 | (declare #.*opt* (small-ind s x y c)) 61 | (+ c (the veq:pn 62 | (* 3 (the veq:pn (+ x (the veq:pn (* s y)))))))) 63 | (indfx (x y &optional (c 0)) 64 | (declare (small-ind x y c)) 65 | (-indfx size x y c))) 66 | #'indfx)) 67 | 68 | (defun make (&key (size 1000)) 69 | (declare #.*opt*) 70 | "make square PNG canvas instance of size to." 71 | (make-canvas 72 | :size size :vals (veq:f3$zero (* size size)) :indfx (-get-indfx size))) 73 | 74 | 75 | (declaim (inline -png-vals)) 76 | (defun -png-vals (indfx vals x y g) 77 | (declare #.*opt* (function indfx) (fixnum x y) (veq:ff g) (veq:fvec vals)) 78 | (labels 79 | ((-scale-convert (v &key (s 1f0) (gamma 1f0)) 80 | (declare (veq:ff v s gamma)) 81 | (setf v (expt (abs (the veq:ff (max 0f0 (the veq:ff (/ v s))))) gamma))) 82 | (-u8 (v) 83 | (declare (veq:ff v)) 84 | (the fixnum (cond ((>= v 1f0) 255) 85 | ((<= v 0f0) 0) 86 | (t (values (floor (the veq:ff (* 255f0 v))))))))) 87 | 88 | (let ((ind (funcall indfx x y))) 89 | (declare (veq:pn ind)) 90 | (values (-u8 (-scale-convert (aref vals ind) :gamma g)) 91 | (-u8 (-scale-convert (aref vals (1+ ind)) :gamma g)) 92 | (-u8 (-scale-convert (aref vals (+ ind 2)) :gamma g)))))) 93 | 94 | (defun -save8 (canv fn &key gamma) 95 | (declare #.*opt*) 96 | (-do-op (canv size vals indfx) 97 | (let ((png (make-instance 'zpng::pixel-streamed-png 98 | :color-type :truecolor :width size :height size))) 99 | (with-open-file (fstream (weird:ensure-filename fn ".png") 100 | :direction :output :if-exists :supersede 101 | :if-does-not-exist :create 102 | :element-type '(unsigned-byte 8)) 103 | (zpng:start-png png fstream) 104 | (-square-loop (x y size) 105 | (weird:mvb (r g b) (-png-vals indfx vals x y gamma) 106 | (declare (fixnum r g b)) 107 | (zpng:write-pixel (list r g b) png))) 108 | (zpng:finish-png png))))) 109 | 110 | (defun save (canv fn &key (gamma 1f0)) 111 | (declare (canvas canv) (veq:ff gamma)) 112 | "save as 8 bit PNG file fn with gamma." 113 | (-save8 canv fn :gamma gamma)) 114 | 115 | -------------------------------------------------------------------------------- /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.33333f0 -775577.747362f0)) 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 0f0 ss) 20 | (vextend 1f0 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) 'veq:ff))))) 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 veq:fpi)))) 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)) 0f0 1f0 :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 0f0) (rs 3f0) (esize 3000f0) 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.0001f0) 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/jpath.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :jpath) 3 | 4 | (defmacro ht () `(make-hash-table :test #'equal)) 5 | 6 | (declaim (veq:ff *pi3* *pi2* *pi23*) (list *limits*)) 7 | (defvar *pi3* #.(/ veq:fpi 3f0)) 8 | (defvar *pi2* #.(/ veq:fpi 2f0)) 9 | (defvar *pi23* #.(* 2f0 (/ veq:fpi 3f0))) 10 | (defvar *limits* `(#.(/ veq:fpi 2.99f0) 11 | #.(/ veq:fpi 3.99f0) 12 | #.(/ veq:fpi 7.99f0))) 13 | 14 | (declaim (inline ori)) 15 | (veq:fvdef ori (a) 16 | (declare (veq:fvec a)) 17 | (> (veq:f2cross (veq:f2$ a 0 1)) #.veq:*eps*)) 18 | 19 | (defstruct (joint (:constructor -make-joint)) 20 | (w 0f0 :type veq:ff :read-only t) 21 | (orientation t :type boolean :read-only t) 22 | (alpha 0f0 :type veq:ff :read-only t) 23 | (in-out nil :type veq:fvec :read-only t) 24 | (mode :joint :type symbol :read-only t) 25 | (grid nil :type vector :read-only t) 26 | (i 0 :type fixnum :read-only t)) 27 | 28 | 29 | (veq:fvdef o++ ((:va 2 p v w)) (f2!@+ (f2!@+ p v) w)) 30 | (veq:fvdef o-- ((:va 2 p v w)) (f2!@- (f2!@- p v) w)) 31 | (veq:fvdef o+- ((:va 2 p v w)) (f2!@- (f2!@+ p v) w)) 32 | (veq:fvdef o-+ ((:va 2 p v w)) (f2!@+ (f2!@- p v) w)) 33 | 34 | (veq:fvdef -make-joint-grid ((:va 2 p) io) 35 | (declare (veq:ff p) (veq:fvec io)) 36 | "8 offset points around p" 37 | (veq:xlet ((f2!z (veq:f2val 0f0)) 38 | (f2!i (veq:f2$ io)) 39 | (f2!o (veq:f2$ io 1))) 40 | (veq:f$~ (2) (o+- p o i) (o+- p z i) (o-- p o i) (o-+ p o z) 41 | (o-+ p o i) (o++ p z i) (o++ p o i) (o++ p o z) 42 | (veq:f2 p)))) 43 | 44 | (veq:fvdef path->joints (path w* &key closed 45 | &aux (w (* 0.5f0 w*)) 46 | (n (round (length path) 2))) 47 | (declare (veq:fvec path) (veq:ff w w*) (boolean closed)) 48 | "joints contain information about how to offset around points in path." 49 | (labels 50 | ((make-joint (i (:va 2 a p b)) 51 | (veq:xlet ((f2!in (veq:f2norm (f2!@- p a))) 52 | (f2!out (veq:f2norm (f2!@- b p))) 53 | (alpha (- veq:fpi (acos (veq:fclamp* (veq:f2dot in out) -1.0 1f0)))) 54 | (s (/ w (veq:ff (sin alpha)))) 55 | (io (veq:f2$line (f2!@*. in s) (f2!@*. out s)))) ; in-out 56 | (-make-joint :w w :i i :alpha alpha :in-out io 57 | :orientation (ori io) 58 | :grid (-make-joint-grid p io)))) ; FIX 59 | 60 | (make-start ((:va 2 p b)) 61 | (veq:xlet ((f2!out (f2!@*. (veq:f2norm (f2!@- b p)) w)) 62 | (io (veq:f2$line (veq:f2rot out *pi2*) out))) 63 | (-make-joint :w w :mode :start :alpha *pi2* 64 | :in-out io :grid (-make-joint-grid p io)))) 65 | 66 | (make-end (i (:va 2 a p)) 67 | (veq:xlet ((f2!in (f2!@*. (veq:f2norm (f2!@- p a)) w)) 68 | (io (veq:f2$line in (veq:f2rot in (- *pi2*))))) 69 | (-make-joint :w w :i i :mode :end :alpha (- *pi2*) 70 | :in-out io :grid (-make-joint-grid p io)))) 71 | 72 | (ci (i) (veq:f2$ path (mod i n))) 73 | (closed-path->joints () 74 | (loop for i from 0 below n 75 | collect (m@make-joint i (ci (1- i)) (ci i) (ci (1+ i))))) 76 | (open-path->joints () 77 | (loop with init = (m@make-end (1- n) (ci (- n 2)) (ci (1- n))) 78 | with res = (list init) 79 | for i from (- n 2) downto 1 80 | do (push (m@make-joint i (ci (1- i)) (ci i) (ci (1+ i))) res) 81 | finally (return (cons (m@make-start (ci 0) (ci 1)) res))))) 82 | 83 | (when (< n (if closed 3 2)) 84 | (error "JPATH: must have at least 2 (open) 85 | or 3 (closed) elements. n: ~a~%closed: ~a" n closed)) 86 | 87 | (if closed (closed-path->joints) (open-path->joints)))) 88 | 89 | (veq:fvdef path->diagonals (path w &key closed (limits *limits*)) 90 | (declare (veq:fvec path) (veq:ff w) (boolean closed)) 91 | "return (orientation line) for every point in path. lerp-ing along lines will 92 | return controll points. lerp direction should be flipped when orientation is 93 | nil. sharp or chamfered points correspond to two lines" 94 | (let ((joints (to-vector (path->joints path w :closed closed))) 95 | (la (first limits)) (lb (second limits)) (lc (third limits)) 96 | (res (list))) 97 | (labels 98 | ((gx (a i) (veq:f2$ (joint-grid (aref joints a)) i)) 99 | (gx* (p u v) (veq:f2$line (gx p u) (gx p v))) 100 | (start (p) (gx* p 1 5 )) (end (p) (gx* p 7 3 )) 101 | (joint (p) (gx* p 4 0)) 102 | (soft-1 (p) (gx* p 3 0)) (soft-2 (p) (gx* p 5 0)) 103 | (chamfer-1 (p) (gx* p 2 0)) (chamfer-2 (p) (gx* p 6 0)) 104 | (sharp-3 (p) (gx* p 2 6)) (sharp-4 (p) (gx* p 6 2)) 105 | (do-joint (i) 106 | (let* ((j (aref joints i)) 107 | (alpha (joint-alpha j)) 108 | (ori (joint-orientation j))) 109 | (cond ((<= alpha lc) (push `(,ori ,(sharp-3 i)) res) 110 | (push `(,ori ,(sharp-4 i)) res)) 111 | ((<= alpha lb) (push `(,ori ,(chamfer-1 i)) res) 112 | (push `(,ori ,(chamfer-2 i)) res)) 113 | ((<= alpha la) (push `(,ori ,(soft-1 i)) res) 114 | (push `(,ori ,(soft-2 i)) res)) 115 | (t (push `(,ori ,(joint i)) res)))))) 116 | 117 | (loop for i from 0 below (length joints) 118 | do (ecase (joint-mode (aref joints i)) 119 | (:end (push `(,t ,(end i)) res)) 120 | (:start (push `(,t ,(start i)) res)) 121 | (:joint (do-joint i)))) 122 | ; diagonals: (#(a b) #(c d) ...) 123 | (reverse res)))) 124 | 125 | (veq:fvdef jpath (path w &key (rep 3) closed (limits *limits*)) 126 | (declare (veq:fvec path) (veq:ff w) (fixnum rep) (boolean closed)) 127 | (let* ((diagonals (to-vector (path->diagonals path w :closed closed :limits limits))) 128 | (n (length diagonals)) 129 | (res (make-adjustable-vector)) 130 | (ss (math:linspace rep 0f0 1f0))) 131 | 132 | (labels 133 | ((flip? (ori s) (if ori s (- 1f0 s))) 134 | (open-ind (i k i-) (if (= (math:mod2 k) 0) i i-)) 135 | (closed-path () 136 | (loop for s in ss 137 | do (vextend (loop for (ori line) across diagonals 138 | collect (veq:lst (veq:f2lerp 139 | (veq:f2$ line 0 1) 140 | (flip? ori s)))) 141 | res))) 142 | (open-path () 143 | (loop for s in ss and k of-type fixnum from 0 144 | do (loop for i of-type fixnum from 0 below n 145 | and i- of-type fixnum downfrom (1- n) 146 | for (ori line) = (aref diagonals (open-ind i k i- )) 147 | do (vextend (veq:lst (veq:f2lerp (veq:f2$ line 0 1) 148 | (flip? ori s))) 149 | res))))) 150 | (if closed (closed-path) (open-path)) 151 | (veq:f$_ (to-list res))))) 152 | 153 | -------------------------------------------------------------------------------- /src/draw/pigment.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :pigment) 3 | 4 | """Colors are stored internally with premultiplied alpha.""" 5 | 6 | ; TODO: consider rewriting to utilize :veq 7 | 8 | (defmacro with ((c r g b a) &body body) 9 | "access pre multiplied values (r g b a) 10 | ex: (with (pigment r g b a) (list r g b a))." 11 | (weird:awg (c*) 12 | `(let* ((,c* ,c) 13 | (,r (rgba-r ,c*)) 14 | (,g (rgba-g ,c*)) 15 | (,b (rgba-b ,c*)) 16 | (,a (rgba-a ,c*))) 17 | (declare (veq:ff ,r ,g ,b ,a)) 18 | (progn ,@body)))) 19 | 20 | 21 | (defmacro with* ((c r g b a) &body body) 22 | "access values (r g b a) 23 | ex: (with (pigment r g b a) (list r g b a))." 24 | (weird:awg (c*) 25 | `(let* ((,c* ,c) 26 | (,a (rgba-a ,c*)) 27 | (,r (/ (rgba-r ,c*) ,a)) 28 | (,g (/ (rgba-g ,c*) ,a)) 29 | (,b (/ (rgba-b ,c*) ,a))) 30 | (declare (veq:ff ,r ,g ,b ,a)) 31 | (progn ,@body)))) 32 | 33 | (defun -print-rgba (c s) 34 | (declare (notinline rgba-r rgba-g rgba-b rgba-a)) 35 | (with* (c r g b a) 36 | (format s "~&@rgba: (r: ~f, g: ~a, b: ~a, a: ~a)~&" r g b a))) 37 | 38 | (defstruct (rgba (:constructor make-rgba) 39 | (:constructor -make-rgba (r g b a)) 40 | (:print-object -print-rgba)) 41 | (r 0f0 :type veq:ff :read-only nil) 42 | (g 0f0 :type veq:ff :read-only nil) 43 | (b 0f0 :type veq:ff :read-only nil) 44 | (a 1f0 :type veq:ff :read-only nil)) 45 | 46 | (weird:define-struct-load-form rgba) 47 | #+SBCL(declaim (sb-ext:freeze-type rgba)) 48 | 49 | (defun rgb (r g b &optional (a 1f0)) 50 | (declare #.*opt* (veq:ff r g b a)) 51 | "synonym for make." 52 | (make r g b a)) 53 | 54 | (defun scale (c s) 55 | (declare #.*opt* (rgba c) (veq:ff s)) 56 | "return a new pigment scaled by s." 57 | (-make-rgba (* (rgba-r c) s) (* (rgba-g c) s) 58 | (* (rgba-b c) s) (* (rgba-a c) s))) 59 | (defun scale! (c s) 60 | (declare #.*opt* (rgba c) (veq:ff s)) 61 | "scale this pigment by s." 62 | (setf (rgba-r c) (* (rgba-r c) s) (rgba-g c) (* (rgba-g c) s) 63 | (rgba-b c) (* (rgba-b c) s) (rgba-a c) (* (rgba-a c) s)) 64 | c) 65 | 66 | (defun make (r g b &optional (a 1f0)) 67 | (declare #.*opt* (veq:ff r g b a)) 68 | "make a colour (pigment) instance with (r g b a). all values should range from 69 | 0.0-1.0. values are stored internally with pre-multiplied alpha." 70 | (-make-rgba (* a r) (* a g) (* a b) a)) 71 | 72 | (defun as-val (c) 73 | (declare #.*opt* (rgba c)) 74 | (with (c r g b a) (values r g b a))) 75 | (defun as-val* (c) 76 | (declare #.*opt* (rgba c)) 77 | (with* (c r g b a) (values r g b a))) 78 | 79 | (defun as-list (c) 80 | (declare #.*opt* (rgba c)) 81 | "return list with (r g b a), (r g b) is pre multiplied" 82 | (with (c r g b a) (list r g b a))) 83 | (defun as-list* (c) 84 | (declare #.*opt* (rgba c)) 85 | "return (r g b a)" 86 | (with* (c r g b a) (list r g b a))) 87 | 88 | (defun copy (c) 89 | (declare #.*opt* (rgba c)) 90 | "copy a pigment instance." 91 | (-make-rgba (rgba-r c) (rgba-g c) (rgba-b c) (rgba-a c))) 92 | 93 | (defun white (&optional (a 1f0)) 94 | (declare #.*opt* (veq:ff a)) 95 | "white with alpha a." 96 | (make 1f0 1f0 1f0 a)) 97 | (defun black (&optional (a 1f0)) 98 | (declare #.*opt* (veq:ff a)) 99 | "black with alpha a." 100 | (make 0f0 0f0 0f0 a)) 101 | (defun red (&optional (a 1f0)) 102 | (declare #.*opt* (veq:ff a)) 103 | "red with alpha a." 104 | (make 1f0 0f0 0f0 a)) 105 | (defun green (&optional (a 1f0)) 106 | (declare #.*opt* (veq:ff a)) 107 | "green with alpha a." 108 | (make 0f0 1f0 0f0 a)) 109 | (defun blue (&optional (a 1f0)) 110 | (declare #.*opt* (veq:ff a)) 111 | (make 0f0 0f0 1f0 a)) 112 | (defun mdark (&optional (a 1f0)) 113 | (declare #.*opt* (veq:ff a)) 114 | "0.3 gray with alpha a." 115 | (make 0.3f0 0.3f0 0.3f0 a)) 116 | 117 | (defun dark (&optional (a 1f0)) 118 | (declare #.*opt* (veq:ff a)) 119 | "0.2 gray with alpha a." 120 | (make 0.2f0 0.2f0 0.2f0 a)) 121 | (defun vdark (&optional (a 1f0)) 122 | (declare #.*opt* (veq:ff a)) 123 | "0.1 gray with alpha a." 124 | (make 0.1f0 0.1f0 0.1f0 a)) 125 | (defun gray (v &optional (a 1f0)) 126 | (declare #.*opt* (veq:ff v a)) 127 | "v gray with alpha a." 128 | (make v v v a)) 129 | 130 | (defun transparent () 131 | (declare #.*opt*) 132 | "fully transparent. by defninition this has no colour." 133 | (make 0f0 0f0 0f0 0f0)) 134 | 135 | (defun as-hex (c) 136 | (declare #.*opt* (rgba c)) 137 | "return pigment colour as hex string." 138 | (labels ((-hex (d) 139 | (declare #.*opt* (veq:ff d)) 140 | (min 255 (max 0 (floor (veq:ff (* d 256))))))) 141 | (with* (c r g b a) 142 | (values (format nil "#~@{~2,'0x~}" (-hex r) (-hex g) (-hex b)) a)))) 143 | 144 | (defun cmyk (c m y k &optional (a 1f0)) 145 | (declare #.*opt* (veq:ff c m y k a)) 146 | "create pigment from (c m y k a). a is optional." 147 | (let ((ik (- 1f0 k))) 148 | (declare (veq:ff ik)) 149 | (make (* (- 1f0 c) ik) (* (- 1f0 m) ik) (* (- 1f0 y) ik) a))) 150 | 151 | (defun hsv (h s v &optional (a 1f0)) 152 | (declare #.*opt* (veq:ff h s v a)) 153 | "create pigment from (h s v a). a is optional." 154 | (let* ((c (* v s)) 155 | (x (* c (- 1f0 (abs (- (mod (* 6f0 h) 2f0) 1f0))))) 156 | (m (- v c))) 157 | (declare (veq:ff c x m)) 158 | (weird:mvb (r g b) 159 | (case (the fixnum (floor (mod (* h 6f0) 6f0))) 160 | (0 (values (+ c m) (+ x m) m)) 161 | (1 (values (+ x m) (+ c m) m)) 162 | (2 (values m (+ c m) (+ x m))) 163 | (3 (values m (+ x m) (+ c m))) 164 | (4 (values (+ x m) m (+ c m))) 165 | (5 (values (+ c m) m (+ x m))) 166 | (t (values 0f0 0f0 0f0))) 167 | (declare (veq:ff r g b)) 168 | (make r g b a)))) 169 | 170 | (defun as-hsv (c) 171 | (declare #.*opt* (rgba c)) 172 | "return pigment as (list h s v a)" 173 | (labels ((-mod (ca cb df p) 174 | (declare #.*opt* (veq:ff ca cb df p)) 175 | ;(mod a b) is remainder of (floor a b) 176 | (weird:mvb (_ res) 177 | (floor (the veq:ff (+ p (* #.(/ 6f0) 178 | (/ (the veq:ff (- ca cb)) df))))) 179 | (declare (ignore _) (veq:ff res)) 180 | res))) 181 | (with* (c r g b a) 182 | (let ((rgb (list r g b))) 183 | (declare (list rgb)) 184 | (weird:mvb (imn mn) (math:argmin rgb) 185 | (declare (fixnum imn) (veq:ff mn)) 186 | (weird:mvb (imx mx) (math:argmax rgb) 187 | (declare (fixnum imx) (veq:ff mx)) 188 | (let ((df (- mx mn))) 189 | (declare (veq:ff df)) 190 | (list (cond ((= imn imx) 0f0) 191 | ((= imx 0) (-mod g b df 1f0)) 192 | ((= imx 1) (-mod b r df #.(/ 3f0))) 193 | ((= imx 2) (-mod r g df #.(/ 2f0 3f0)))) 194 | (if (<= mx 0f0) 0f0 (/ df mx)) 195 | mx a)))))))) 196 | 197 | (defun magenta (&key (sat 1f0) (val 1f0) (alpha 1f0)) 198 | "magenta with sat, val, alpha." 199 | (hsv #.(/ 300f0 360f0) sat val alpha)) 200 | (defun cyan (&key (sat 1f0) (val 1f0) (alpha 1f0)) 201 | "cyan with sat, val, alpha." 202 | (hsv #.(/ 180f0 360f0) sat val alpha)) 203 | 204 | -------------------------------------------------------------------------------- /src/draw/simplify-path.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :simplify) 3 | 4 | (deftype int-vector () `(vector veq:pn)) 5 | 6 | ; TODO: make 3d version similar to vert-utils? 7 | 8 | (veq:fvdef -simplify (pts lim &key left right) 9 | (declare #.*opt* (veq:fvec pts) (veq:ff lim) (veq:pn left right)) 10 | (let ((res (make-adjustable-vector :type 'veq:pn)) 11 | (dmax -1f0) 12 | (index 0)) 13 | (declare (int-vector res) (veq:pn index) (veq:ff dmax)) 14 | 15 | (veq:f2let ((sl (veq:f2$ pts left)) 16 | (sr (veq:f2$ pts right))) 17 | (loop for i of-type veq:pn from (1+ left) below right 18 | do (let ((d (veq:f2segdst sl sr (veq:f2$ pts i)))) 19 | (declare (veq:ff d)) 20 | (when (> d dmax) (setf dmax d index i))))) 21 | 22 | (if (> dmax lim) 23 | (progn (loop with ps of-type int-vector = 24 | (-simplify pts lim :left left :right index) 25 | for i from 0 below (1- (length ps)) 26 | do (vextend (aref ps i) res)) 27 | (loop for i across (-simplify pts lim :left index :right right) 28 | do (vextend i res))) 29 | (progn (vextend left res) 30 | (vextend right res))) 31 | (sort res #'<))) 32 | 33 | 34 | ; https://hydra.hull.ac.uk/resources/hull:8338 35 | (defun path (pts &key (lim 1f0)) 36 | (declare #.*opt* (veq:fvec pts) (veq:ff lim)) 37 | " 38 | simplify path, pts. 39 | lim is the distance of candidate pt to candidate line 40 | returns new path 41 | " 42 | (let ((inds (-simplify pts lim 43 | :left 0 :right (1- (round (/ (length pts) 2)))))) 44 | (declare (vector inds)) 45 | ; this is kind of inefficient. but it works just fine. 46 | (values (veq:f$_ (loop for i of-type veq:pn across inds 47 | collect (veq:lst (veq:f2$ pts i)) of-type list)) 48 | inds))) 49 | 50 | -------------------------------------------------------------------------------- /src/fn.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :fn) 3 | 4 | (defun fn () 5 | "generate file names using https://github.com/inconvergent/fn" 6 | (values (uiop:run-program (list "/usr/bin/fn") 7 | :output '(:string :stripped t)))) 8 | 9 | 10 | ; elem: ("20220426" "104330" "0895f00" "e9ea3593") 11 | (defun seed (fn) 12 | (labels ((lst (l) (declare (list l)) (first (last l))) 13 | (hex (s) (write-to-string (parse-integer (string-upcase s) :radix 16)))) 14 | (let* ((elem (weird:split (lst (weird:split fn "/")) "-")) 15 | (seed (parse-integer ; date proc git 16 | (weird:mkstr (first elem) (hex (fourth elem)) (hex (third elem)))))) 17 | (format t "~&seed: ~a~%" seed) 18 | (rnd:set-rnd-state seed) 19 | (values fn seed)))) 20 | 21 | -------------------------------------------------------------------------------- /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 | "return edge set from cycle. 10 | ex: (1 2 3 4 5 1) -> ((1 2) (2 3) (3 4) (4 5) (1 5))" 11 | (loop for a in cycle and b in (cdr cycle) 12 | collect (-sort-edge (list a b)))) 13 | 14 | 15 | (defun edge-set->graph (es) 16 | (declare (list es)) 17 | "create a graph from edges in edge set." 18 | (loop with grph = (make) 19 | for (a b) in es do (add grph a b) 20 | finally (return grph))) 21 | 22 | 23 | (defun path->edge-set (path &key closed) 24 | (declare (list path) (boolean closed)) 25 | "return edge set from cycle. 26 | ex: (1 2 3 4 5) -> ((1 2) (2 3) (3 4) (4 5)) 27 | if closed is t, (1 5) will be included in the above output." 28 | (loop for a in path 29 | and b in (if closed (cons (first (last path)) path) (cdr path)) 30 | collect (sort (list a b) #'<))) 31 | 32 | 33 | (defun -edge-map (es) 34 | (declare (list es)) 35 | (let ((edge-map (make-hash-table :test #'equal))) 36 | (labels ((-insert (a b) 37 | (multiple-value-bind (_ exists) (gethash a edge-map) 38 | (declare (ignore _)) 39 | (if exists (push b (gethash a edge-map)) 40 | (setf (gethash a edge-map) (list b)))))) 41 | (loop for (a b) in es do (-insert a b) 42 | (-insert b a))) 43 | edge-map)) 44 | 45 | (defun edge-set->path (es) 46 | (declare (list es)) 47 | "convert edge set: ((3 4) (4 5) (5 6) (1 2) (6 1) (2 3)) 48 | into a path: (4 5 6 1 2 3) 49 | second result is a boolean for whether it is a cycle." 50 | 51 | (when (< (length es) 2) 52 | (return-from edge-set->path (values (car es) nil))) 53 | 54 | (let ((edge-map (-edge-map (cdr es)))) 55 | (labels 56 | ((-next-vert-from (a &key but-not) 57 | (car (remove-if (lambda (v) (= v but-not)) 58 | (gethash a edge-map)))) 59 | (-until-dead-end (a but-not) 60 | (loop with prv = a 61 | with res = (list prv) 62 | with nxt = (-next-vert-from a :but-not but-not) 63 | until (equal nxt nil) 64 | do (push nxt res) 65 | (let ((nxt* (-next-vert-from nxt :but-not prv))) 66 | (setf prv nxt nxt nxt*)) 67 | finally (return res)))) 68 | 69 | (destructuring-bind (a b) (car es) 70 | (let ((left (-until-dead-end a b))) 71 | (when (and (= (car left) b) (= (car (last left)) a)) 72 | ; this is a cycle 73 | (return-from edge-set->path (values left t))) 74 | ; not a cycle 75 | (let* ((right (-until-dead-end b a)) 76 | (res (concatenate 'list left (reverse right)))) 77 | ; this isnt an exhaustive manifold test? 78 | ; and it should be configurable whether it fails? 79 | (unless (= (1- (length res)) (length es)) 80 | (error "path is manifold or incomplete:~%~a~% eslen: ~a. pathlen ~a" 81 | res (length es) (length res))) 82 | (values res nil))))))) 83 | 84 | 85 | (defun edge-set-symdiff (a b) 86 | (declare (list a b)) 87 | "symmetric difference of edge set a and b. not very efficient." ; i think? 88 | (remove-if (lambda (e) (and (member e a :test #'equal) 89 | (member e b :test #'equal))) 90 | (union a b :test #'equal))) 91 | 92 | 93 | (defun cycle-basis->edge-sets (basis) 94 | (declare (list basis)) 95 | "return an edge set for every cycle in a cycle basis. 96 | it does not check if the cycle basis is correct. cycles must be closed. 97 | that is, they must begin and end on the same vertex." 98 | (loop for c of-type list in basis collect (cycle->edge-set c))) 99 | 100 | ; TODO: edge-set->path will only return a cycle 101 | ; if the edge set is a cycle. warn? 102 | (defun edge-sets->cycle-basis (es) 103 | (declare (list es)) 104 | "the opposite of cycle-basis->edge-sets." 105 | (loop for e of-type list in es 106 | collect (math:close-path (edge-set->path e)))) 107 | 108 | (defun -edge-set-weight (es weightfx) 109 | (declare (list es) (function weightfx)) 110 | (loop for e of-type list in es sumMing (apply weightfx e))) 111 | 112 | (defun -sort-edge-sets (edge-sets weightfx) 113 | (declare (list edge-sets) (function weightfx)) 114 | (mapcar #'second 115 | (sort (loop for es of-type list in edge-sets 116 | collect (list (-edge-set-weight es weightfx) es)) 117 | #'> :key #'first))) 118 | 119 | -------------------------------------------------------------------------------- /src/graph/mst-cycle.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :graph) 3 | 4 | (declaim (veq:ff *inf*)) 5 | (defvar *inf* 1f8) 6 | 7 | 8 | ; SPANNING TREE 9 | 10 | (defun -do-spanning-tree (grph st visited start) 11 | (declare (graph grph st) (hash-table visited) (fixnum start)) 12 | (loop with curr of-type fixnum = -1 13 | with stack of-type list = (list (list start start)) 14 | while stack 15 | do (destructuring-bind (curr* parent) (pop stack) 16 | (declare (fixnum curr* parent)) 17 | (setf curr curr*) 18 | ; if not visited, visit, and add descendants 19 | (when (hset:add visited curr) 20 | (unless (= curr parent) (graph:add st curr parent)) 21 | (loop for next of-type fixnum 22 | in (get-incident-verts grph curr) 23 | do ; add (next curr) to stack 24 | (setf stack (cons (list next curr) stack)))))) 25 | st) 26 | 27 | (defun get-spanning-tree (grph &key start) 28 | "return all spanning trees (if the graph is disjoint) of grph in a new graph. 29 | if start is provided, it will return a spanning tree starting at start." 30 | (declare (graph grph)) 31 | (let ((visited (hset:make)) 32 | (st (make)) 33 | (num 0)) 34 | (declare (hash-table visited) (graph st) (fixnum num)) 35 | (if start (progn (-do-spanning-tree grph st visited start) 36 | (setf num 1)) 37 | (loop for v of-type fixnum in (get-verts grph) 38 | unless (hset:mem visited v) 39 | do (-do-spanning-tree grph st visited v) 40 | (incf num))) 41 | ; num is the number of subgraphs/trees 42 | (values st num))) 43 | 44 | 45 | ; MIN SPANNING TREE 46 | 47 | (defun -do-min-spanning-tree (grph q weight edge weightfx 48 | &aux (c 0f0) (mst (make))) 49 | (declare (graph grph mst) (hash-table weight edge q) 50 | (function weightfx) (veq:ff c)) 51 | ; some version of prim's algorithm. 52 | ; missing binary heap to find next vertex to add 53 | (labels 54 | ((-find-next-min-edge () 55 | (loop with cv of-type veq:ff = (+ 1f0 *inf*) ; cost 56 | with v of-type fixnum = -1 ; index 57 | for w of-type fixnum being the hash-keys of q 58 | do (when (< (gethash w weight) cv) 59 | ; update minimum: v=w and cv=weight[w] 60 | (setf v w cv (gethash w weight))) 61 | finally (return (values v cv)))) 62 | 63 | (-update-descendant (v w cw) 64 | (multiple-value-bind (_ exists) (gethash w q) 65 | (declare (ignore _) (boolean exists)) 66 | (when (and exists (< cw (gethash w weight))) 67 | ; update: weight[w]=cw and edge[w]=v 68 | (setf (gethash w weight) cw (gethash w edge) v))))) 69 | 70 | (loop while (> (hash-table-count q) 0) 71 | do (multiple-value-bind (v c*) (-find-next-min-edge) 72 | (declare (fixnum v) (veq:ff c*)) 73 | (when (< v 0) (error "mst: hit negative vert")) 74 | ; remove (min) v from q 75 | (remhash v q) 76 | ; when edge exists 77 | (multiple-value-bind (w exists) (gethash v edge) 78 | ; add edge to graph 79 | (when (and exists w) (add mst v w) (incf c c*))) 80 | ; descendants of v 81 | (loop for w of-type fixnum in (get-incident-verts grph v) 82 | do (-update-descendant v w (funcall weightfx v w)))))) 83 | (values mst c)) 84 | 85 | (defun -init-hash-table (keys v) 86 | (declare (list keys)) 87 | (loop with res of-type hash-table = (make-hash-table :test #'eql) 88 | for k of-type fixnum in keys 89 | do (setf (gethash k res) v) 90 | finally (return res))) 91 | 92 | (defun get-min-spanning-tree (grph &key (weightfx (lambda (a b) 93 | (declare (ignore a b)) 1f0)) 94 | (start 0)) 95 | "return all minimal spanning trees of grph in a new graph. 96 | if start is provided, it will return a spanning tree starting at start." 97 | ; TODO: what happens if grph is disjoint? 98 | (declare (graph grph) (fixnum start) (function weightfx)) 99 | (let* ((verts (get-verts grph)) 100 | (weight (-init-hash-table verts *inf*)) ; ht 101 | (edge (-init-hash-table verts nil)) ; ht 102 | (q (-init-hash-table verts t))) ; hset: verts not in tree 103 | (when start (setf (gethash start weight) 0f0)) 104 | (-do-min-spanning-tree grph q weight edge weightfx))) 105 | 106 | -------------------------------------------------------------------------------- /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) (veq:pn 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 | 17 | " 18 | (loop until (notany #'identity 19 | (loop for v in (get-verts grph) 20 | collect (-del-filament grph v)))) 21 | grph) 22 | 23 | ; CONTINOUS PATHS 24 | 25 | ;note: this can possibly be improved if k is an array 26 | (defun -cycle-info (k) 27 | (declare (list k)) 28 | (if (= (first k) (first (last k))) (list (cdr k) t) (list k nil))) 29 | 30 | (defun -find-segment (grph start curr) 31 | (declare (graph grph) (veq:pn start curr)) 32 | (loop with res = (make-adjustable-vector :type 'veq:pn :init (list start)) 33 | with prev of-type veq:pn = start 34 | while t 35 | do (let* ((incident (get-incident-edges grph curr)) 36 | (n (length incident))) 37 | (declare (veq:pn n)) 38 | 39 | ; loop. attach curr to indicate loop 40 | (when (= curr start) 41 | (vextend curr res) 42 | (return-from -find-segment res)) 43 | 44 | ; dead end/multi 45 | (unless (= n 2) 46 | (vextend curr res) 47 | (return-from -find-segment res)) 48 | 49 | ; single connection 50 | (when (= n 2) 51 | (let ((c (remove-if (lambda (i) (= i curr)) 52 | (-only-incident-verts prev incident)))) 53 | (vextend curr res) 54 | (setf prev curr curr (first c))))))) 55 | 56 | (defun -add-visited-verts (visited path) 57 | (loop for v in path do (setf (gethash v visited) t))) 58 | 59 | ; TODO: rewrite this to avoid cheching everything multiple times. 60 | (defun get-segments (grph &key cycle-info) 61 | (declare (graph grph)) 62 | "greedily finds segments :between: multi-intersection points. 63 | 64 | note: by definition this will not return parts of the graph that have no 65 | multi-intersections. consider walk-graph instead." 66 | (let ((all-paths (make-hash-table :test #'equal)) 67 | (visited (make-hash-table :test #'equal))) 68 | 69 | (labels 70 | ((-incident-not-two (incident) 71 | (declare (list incident)) 72 | (not (= (length incident) 2))) 73 | 74 | (-incident-two (incident) 75 | (declare (list incident)) 76 | (= (length incident) 2)) 77 | 78 | (-do-find-segment (v next) 79 | (declare (veq:pn v next)) 80 | (let* ((path (to-list (-find-segment grph v next))) 81 | (key (sort (copy-list path) #'<))) 82 | (declare (list path key)) 83 | (unless (gethash key all-paths) 84 | (-add-visited-verts visited path) 85 | (setf (gethash key all-paths) path)))) 86 | 87 | (-walk-incident-verts (v testfx) 88 | (declare (veq:pn v) (function testfx)) 89 | (let ((incident (get-incident-edges grph v))) 90 | (declare (list incident)) 91 | (when (funcall testfx incident) 92 | (loop for next in (-only-incident-verts v incident) 93 | do (-do-find-segment v next)))))) 94 | 95 | (loop for v in (sort (get-verts grph) #'<) 96 | do (-walk-incident-verts v #'-incident-not-two)) 97 | 98 | ; note: this can be improved if we inverted visited, and remove vertices 99 | ; as they are visited 100 | (loop for v in (sort (get-verts grph) #'<) 101 | unless (gethash v visited) 102 | do (-walk-incident-verts v #'-incident-two))) 103 | 104 | (loop with fx = (if cycle-info #'-cycle-info #'identity) 105 | for k of-type list being the hash-values of all-paths 106 | collect (funcall fx k) of-type list))) 107 | 108 | (defun -angle-fx (a b c) 109 | (declare (ignore a b c)) 110 | 1f0) 111 | 112 | (defun walk-graph (grph &key (angle #'-angle-fx)) 113 | (declare (graph grph)) 114 | "greedily walks the graph so that every edge is returned exactly once. 115 | in multi-intersectinons the walker selects the smallest available angle. 116 | this is useful for exporting a graph as a plotter drawing." 117 | 118 | (let ((all-edges (loop with res = (make-hash-table :test #'equal) 119 | for e in (get-edges grph) 120 | do (setf (gethash e res) t) 121 | finally (return res)))) 122 | (labels 123 | ((-ic (a b) (if (< a b) (list a b) (list b a))) 124 | (-get-start-edge () 125 | (loop for e being the hash-keys of all-edges 126 | do (return-from -get-start-edge e))) 127 | 128 | (-least-angle (a b vv) 129 | (cadar (sort 130 | (mapcar (lambda (v) 131 | (list (weird:aif 132 | (funcall angle a b v) 133 | weird:it 0f0) 134 | v)) 135 | vv) 136 | #'> :key #'car))) 137 | 138 | (-next-vert-from (a &key but-not) 139 | (-least-angle but-not a (remove-if 140 | (lambda (v) (or (= v but-not) 141 | (not (gethash (-ic a v) all-edges)))) 142 | (get-incident-verts grph a)))) 143 | 144 | (-until-dead-end (a but-not) 145 | (loop with prv = a 146 | with res = (list prv) 147 | with nxt = (-next-vert-from a :but-not but-not) 148 | until (equal nxt nil) 149 | do (push nxt res) 150 | (remhash (-ic prv nxt) all-edges) 151 | (let ((nxt* (-next-vert-from nxt :but-not prv))) 152 | (setf prv nxt nxt nxt*)) 153 | finally (return res)))) 154 | 155 | (loop while (> (hash-table-count all-edges) 0) 156 | collect (let ((start (-get-start-edge))) 157 | (remhash start all-edges) 158 | (destructuring-bind (a b) start 159 | (concatenate 'list 160 | (-until-dead-end a b) 161 | (reverse (-until-dead-end b a))))))))) 162 | 163 | -------------------------------------------------------------------------------- /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 1f0 :type veq:ff :read-only nil) 10 | (sp 1f0 :type veq:ff :read-only nil) 11 | (nl 13f0 :type veq:ff :read-only nil) 12 | (xy nil :type list :read-only nil) 13 | (left 0f0 :type veq:ff :read-only nil) 14 | (prev nil :read-only nil) 15 | (symbols (make-hash-table :test #'equal) :read-only t)) 16 | 17 | (defun make (&key (fn (internal-path-string "src/gridfont/smooth")) 18 | (scale 2f0) (nl 15f0) (sp 2f0) (xy (list 0f0 0f0))) 19 | (with-open-file (fstream (ensure-filename fn ".json" t) :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 26 | :symbols res :scale scale :sp sp :xy xy :nl nl 27 | :left (first xy)))))) 28 | 29 | (veq:fvdef -detect-closed (paths) 30 | (declare (list paths)) 31 | (labels ((-closed (p &key (tol 0.001f0)) 32 | (declare (veq:fvec p) (veq:ff tol)) 33 | (< (veq:f2dst (veq:f2$ p) (veq:f2$last p)) tol))) 34 | (loop for p of-type veq:fvec in paths 35 | collect (list p (-closed p))))) 36 | 37 | 38 | (defun update (gf &key xy scale sp nl) 39 | (declare (gridfont gf)) 40 | "update gridfont properties" 41 | (when xy (setf (gridfont-xy gf) xy 42 | (gridfont-left gf) (first xy))) 43 | (when scale (setf (gridfont-scale gf) scale)) 44 | (when sp (setf (gridfont-sp gf) sp)) 45 | (when nl (setf (gridfont-nl nl) sp))) 46 | 47 | 48 | (defun nl (gf &key (left (gridfont-left gf))) 49 | (declare (gridfont gf) (veq:ff left)) 50 | "write a newline" 51 | (setf (gridfont-prev gf) nil) 52 | (with-struct (gridfont- nl scale) gf 53 | (setf (gridfont-xy gf) 54 | (list left (+ (second (gridfont-xy gf)) 55 | (* nl scale)))))) 56 | 57 | 58 | (defun -get-meta (symbols c &aux (c* (string c))) 59 | (multiple-value-bind (meta exists) 60 | (gethash (funcall json:*json-identifier-name-to-lisp* c*) symbols) 61 | (unless exists (error "symbol does not exist: ~a (representation: ~a)" c c*)) 62 | meta)) 63 | 64 | (defun -pos (pp &optional (s 1f0)) 65 | (declare (list pp) (veq:ff s)) 66 | (mapcar (lambda (x) (veq:ff (* s x))) pp)) 67 | 68 | (veq:fvdef -path-to-arr (paths s (:varg 2 x)) 69 | (declare (list paths) (veq:ff s x)) 70 | (loop for path of-type list in paths 71 | collect (f2!@$+ (values (veq:f$_ (loop for p of-type list in path 72 | collect (-pos p s)))) 73 | x))) 74 | 75 | ; TODO: return (values paths width height) 76 | (defun wc (gf c &key xy) 77 | (declare (gridfont gf)) 78 | "write single character, c" 79 | (when xy (setf (gridfont-xy gf) xy)) 80 | (with-struct (gridfont- symbols scale sp xy) gf 81 | (let* ((meta (-get-meta symbols c)) 82 | (paths (-jsn-get meta :paths)) 83 | (w (veq:ff (-jsn-get meta :w))) 84 | (res (-detect-closed (apply #'-path-to-arr paths scale xy)))) 85 | (weird:dsb (x y) xy 86 | (declare (veq:ff x y)) 87 | (setf (gridfont-xy gf) (list (+ x (* scale (+ w sp))) y) 88 | (gridfont-prev gf) (string c))) 89 | res))) 90 | 91 | 92 | (defun get-phrase-box (gf str) 93 | (declare (gridfont gf) (string str)) 94 | "width and height of phrase" 95 | (with-struct (gridfont- symbols scale sp) gf 96 | (loop for c across str 97 | summing (+ (-jsn-get (-get-meta symbols c) :w) sp) into width 98 | maximizing (-jsn-get (-get-meta symbols c) :h) into height 99 | finally (return (-pos (list width height) scale))))) 100 | 101 | -------------------------------------------------------------------------------- /src/hset.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :hset) 3 | 4 | " 5 | fixnum set. this is a naive wrapper around hash-table. not sure how efficient 6 | it will be? 7 | " 8 | 9 | (defun copy (s &key (size 100) (inc 2f0)) 10 | (declare #.*opt* (hash-table s) (fixnum size) (number inc)) 11 | "copy fixnum set." 12 | (let ((ns (make-hash-table :test #'eql :size size :rehash-size inc))) 13 | (declare (hash-table ns)) 14 | (loop for k being the hash-keys of s do (setf (gethash k ns) t)) 15 | ns)) 16 | 17 | (defun make (&key init (size 100) (inc 2f0)) 18 | (declare #.*opt* (fixnum size)) 19 | "create fixnum set. init (optional) is a list of integers." 20 | (let ((s (make-hash-table :test #'eql :size size :rehash-size inc 21 | :rehash-threshold 0.9))) 22 | (when init (add* s init)) 23 | s)) 24 | 25 | 26 | (declaim (inline add)) 27 | (defun add (s e) 28 | (declare #.*opt* (hash-table s) (fixnum e)) 29 | "add e to fixnum set." 30 | (multiple-value-bind (val exists) (gethash e s) 31 | (declare (ignore val)) 32 | (if exists nil (setf (gethash e s) t)))) 33 | 34 | (defun add* (s ee) 35 | (declare #.*opt* (hash-table s) (sequence ee)) 36 | "add sequence of fixnums to fixnum set." 37 | (typecase ee (cons (loop for e of-type fixnum in ee collect (add s e))) 38 | (simple-array (loop for e of-type fixnum 39 | across (the (simple-array fixnum) ee) 40 | collect (add s e))) 41 | (t (error "incorrect type in hset:add*: ~a~%" ee)))) 42 | 43 | (declaim (inline del)) 44 | (defun del (s e) 45 | (declare #.*opt* (hash-table s) (fixnum e)) 46 | "del e from fixnum set." 47 | (remhash e s)) 48 | 49 | (defun del* (s ee) 50 | (declare #.*opt* (hash-table s) (sequence ee)) 51 | "del sequence of fixnum from fixnum set." 52 | (typecase ee (cons (loop for e of-type fixnum in ee collect (del s e))) 53 | (simple-array (loop for e of-type fixnum 54 | across (the (simple-array fixnum) ee) 55 | collect (del s e))) 56 | (t (error "incorrect type in hset:del* ~a~%" ee)))) 57 | 58 | (declaim (inline mem)) 59 | (defun mem (s e) 60 | (declare #.*opt* (hash-table s) (fixnum e)) 61 | "t if e is member of fixnum set s." 62 | (multiple-value-bind (_ exists) (gethash e s) 63 | (declare (ignore _)) 64 | exists)) 65 | 66 | (defun mem* (s ee) 67 | (declare #.*opt* (hash-table s) (sequence ee)) 68 | "returns list with a boolean for each fixnum in sequence ee." 69 | (typecase ee (cons (loop for e of-type fixnum in ee collect (mem s e))) 70 | (simple-array (loop for e of-type fixnum 71 | across (the (simple-array fixnum) ee) 72 | collect (mem s e))) 73 | (t (error "incorrect type in hset:mem* ~a~%" ee)))) 74 | 75 | (defun num (s) 76 | (declare #.*opt* (hash-table s)) 77 | "count elements in fixnum set." 78 | (the fixnum (hash-table-count s))) 79 | 80 | (defun to-list (s) 81 | (declare #.*opt* (hash-table s)) 82 | "get unordered list of elements in fixnum set." 83 | (loop for e of-type fixnum being the hash-keys of s collect e)) 84 | 85 | 86 | ; SET OPS (not well tested) 87 | 88 | (defun uni (a b) 89 | (declare #.*opt* (hash-table a b)) 90 | "return new fixnum set which contains the union of a,b." 91 | (let ((c (copy a))) 92 | (loop for k being the hash-keys of b do (setf (gethash k c) t)) 93 | c)) 94 | 95 | (defun inter (a b) 96 | (declare #.*opt* (hash-table a b)) 97 | "return new fixnum set which contains the intersection of a,b." 98 | (loop with c = (make) 99 | for k being the hash-keys of a 100 | do (when (mem b k) (setf (gethash k c) t)) 101 | finally (return c))) 102 | 103 | (defun symdiff (a b) 104 | (declare #.*opt* (hash-table a b)) 105 | "return new fixnum set which contains the symmetric difference of a,b." 106 | (let ((uni (uni a b))) 107 | (declare (hash-table uni)) 108 | (loop for k being the hash-keys of uni 109 | do (when (and (mem a k) (mem b k)) 110 | (remhash k uni))) 111 | uni)) 112 | 113 | -------------------------------------------------------------------------------- /src/init.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weird) 3 | 4 | ; from: http://cl-cookbook.sourceforge.net/os.html 5 | (defun vgetenv (name &optional default) 6 | #+CMU (let ((x (assoc name ext:*environment-list* :test #'string=))) 7 | (if x (cdr x) default)) 8 | #-CMU (or #+Allegro (sys:getenv name) 9 | #+CLISP (ext:getenv name) 10 | #+ECL (si:getenv name) 11 | #+SBCL (sb-unix::posix-getenv name) 12 | #+LISPWORKS (lispworks:environment-variable name) 13 | default)) 14 | 15 | (defmacro init-config (dev-vals vals) 16 | (if (> (length (string-downcase (vgetenv "DEV" ""))) 0) 17 | `(progn (defvar *dev* t) 18 | (defvar *opt* ',dev-vals) 19 | (format t "~&---------!!!!! WEIRD COMPILED IN DEVMODE !!!!!--------- 20 | --------- ~a~%" ',dev-vals)) 21 | `(progn (defvar *dev* nil) 22 | (defvar *opt* ',vals)))) 23 | -------------------------------------------------------------------------------- /src/math.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :math) 3 | 4 | 5 | (defun last* (l) (declare #.*opt* (list l)) (first (last l))) 6 | 7 | (defun close-path (p) 8 | (declare #.*opt* (list p)) 9 | "append first element of p to end of p." 10 | (append p (subseq p 0 1))) 11 | 12 | (defun close-path* (p) 13 | (declare #.*opt* (list p)) 14 | "append last element of p to front of p." 15 | (cons (last* p) p)) 16 | 17 | 18 | (defmacro nrep (n &body body) 19 | "returns list with body :evaluated: n times." 20 | `(the list (loop repeat (the veq:pn ,n) collect (progn ,@body)))) 21 | 22 | (defun range (a &optional (b nil)) 23 | (declare #.*opt* (fixnum a)) 24 | "fixnums from 0 to a, or a to b." 25 | (if (not b) (loop for x of-type fixnum from 0 below a collect x) 26 | (loop for x of-type fixnum from a below (the fixnum b) 27 | collect x))) 28 | 29 | ; this is kind of silly 30 | (defun lpos (ll &key (fx #'first)) 31 | (declare #.*opt* (list ll) (function fx)) 32 | "apply fx to every element in ll. " 33 | (mapcar fx ll)) 34 | 35 | ; TODO pretty sure there is a better way to do this 36 | (defun ll-transpose (l) 37 | (declare #.*opt* (list l)) 38 | "transpose list of lists. 39 | assumes all initial lists in l have the same length." 40 | (labels ((-reduce (acc v) (loop for a in acc and b in v collect (cons b a)))) 41 | (mapcar #'reverse (reduce #'-reduce l 42 | :initial-value (loop repeat (length (the list (first l))) 43 | collect (list)))))) 44 | 45 | (defun list>than (l n) 46 | (declare #.*opt* (list l) (veq:pn n)) 47 | "list is longer than n?" 48 | (consp (nthcdr n l))) 49 | 50 | 51 | (defun linspace (n a b &key (end t)) 52 | (declare #.*opt* (veq:pn n) (veq:ff a b) (boolean end)) 53 | "n veq:ffs from a to b." 54 | (if (> n 1) 55 | (loop with ban of-type veq:ff = (/ (- b a) (if end (1- n) n)) 56 | for i of-type fixnum from 0 below n 57 | collect (+ a (* (coerce i 'veq:ff) ban)) of-type veq:ff) 58 | (list a))) 59 | 60 | 61 | ; INT LIST MATH 62 | 63 | (defmacro lop (name type &body body) 64 | `(defun ,name (aa bb) 65 | (declare #.*opt* (list aa bb)) 66 | ,(format nil "element wise ~a for two lists of ~a" (car body) type) 67 | (loop for a of-type ,type in aa and b of-type ,type in bb 68 | collect (the ,type (,@body (the ,type a) (the ,type b))) 69 | of-type ,type))) 70 | 71 | (lop add fixnum +) 72 | (lop sub fixnum -) 73 | (lop mult fixnum *) 74 | 75 | (defun mod2 (i) 76 | (declare #.*opt* (fixnum i)) 77 | "(mod i 2) for fixnums." 78 | (mod i 2)) 79 | (defun imod (i inc m) 80 | (declare #.*opt* (fixnum i inc m)) 81 | "(mod (+ i inc) m) for fixnums" 82 | (the fixnum (mod (the fixnum (+ i inc)) m))) 83 | 84 | 85 | ; OTHER 86 | 87 | (defun copy-sort (a fx &key (key #'identity)) 88 | (declare #.*opt* (sequence a)) 89 | "sort a without side effects to a. not very efficent." 90 | (sort (copy-seq a) fx :key key)) 91 | 92 | 93 | (defun range-search (ranges f &aux (n (1- (length ranges))) 94 | (ranges* (ensure-vector ranges))) 95 | "binary range search. range must be sorted in ascending order. f is a value 96 | inside the range you are looking for." 97 | (if (or (< f (aref ranges* 0)) (> f (aref ranges* n))) 98 | (error "querying position outside range: ~a" f)) 99 | 100 | (loop with l of-type fixnum = 0 101 | with r of-type fixnum = n 102 | with m of-type fixnum = 0 103 | until (<= (aref ranges* m) f (aref ranges* (1+ m))) 104 | do (setf m (floor (+ l r) 2)) 105 | (cond ((> f (aref ranges* m)) (setf l (progn m))) 106 | ((< f (aref ranges* m)) (setf r (1+ m)))) 107 | finally (return m))) 108 | 109 | (defun integer-search (aa v &aux (n (length aa))) 110 | (declare #.*opt* (vector aa) (fixnum v n)) 111 | "binary integer search. assumes presorted list of integers" 112 | (loop with l of-type fixnum = 0 113 | with r of-type fixnum = (1- n) 114 | with m of-type fixnum = 0 115 | while (<= l r) 116 | do (setf m (ceiling (+ l r) 2)) 117 | (cond ((< (the fixnum (aref aa m)) v) (setf l (1+ m))) 118 | ((> (the fixnum (aref aa m)) v) (setf r (1- m))) 119 | (t (return-from integer-search m))))) 120 | 121 | 122 | (defun argmax (ll &optional (key #'identity)) 123 | (declare (list ll) (function key)) 124 | "returns (values iv v). 125 | where iv is the index of v and v is the highest value in ll." 126 | (loop with iv = 0 127 | with v = (funcall key (first ll)) 128 | for l in (cdr ll) 129 | and i from 1 130 | if (> (funcall key l) v) 131 | do (setf v (funcall key l) iv i) 132 | finally (return (values iv v)))) 133 | 134 | (defun argmin (ll &optional (key #'identity)) 135 | (declare (list ll) (function key)) 136 | "returns (values iv v). 137 | where iv is the index of v and v is the smallest value in ll." 138 | (loop with iv = 0 139 | with v = (funcall key (first ll)) 140 | for l in (cdr ll) 141 | and i from 1 142 | if (< (funcall key l) v) 143 | do (setf v (funcall key l) iv i) 144 | finally (return (values iv v)))) 145 | 146 | -------------------------------------------------------------------------------- /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 | (defun init (&key (cores 4) (name "custom-kernel")) 7 | (setf lparallel:*kernel* (lparallel:make-kernel cores :name name))) 8 | 9 | (defun end () (lparallel:end-kernel :wait t)) 10 | 11 | (defun info () 12 | (let ((name (lparallel:kernel-name)) 13 | (count (lparallel:kernel-worker-count)) 14 | (context (lparallel:kernel-context)) 15 | (bindings (lparallel:kernel-bindings))) 16 | (format t "~&kernel name = ~a~%worker threads count = ~d~%kernel context = ~a~%kernel bindings = ~a~%" 17 | name count context bindings))) 18 | 19 | (defun create-channel () (lparallel:make-channel)) 20 | 21 | (defun submit-task (channel fx) 22 | (lparallel:submit-task channel fx) 23 | (lparallel:receive-result channel)) 24 | 25 | -------------------------------------------------------------------------------- /src/rnd/2rnd.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | (veq:fvprogn 5 | 6 | (veq:def* 2on-line ((:varg 2 a b)) 7 | (declare #.*opt* (veq:ff a b)) 8 | "random point between a,b." 9 | (veq:f2from a (veq:f2- b a) (rnd))) 10 | 11 | (veq:def* 2non-line (n (:varg 2 a b)) 12 | (declare #.*opt* (veq:pn n) (veq:ff a b)) 13 | "n random points between a,b." 14 | (veq:fwith-arrays (:n n :itr k 15 | :arr ((arr 2)) 16 | :fxs ((f () (2on-line a b))) 17 | :exs ((arr k (f)))) 18 | arr)) 19 | 20 | 21 | (veq:def* 2in-rect ((:varg 2 s)) 22 | (declare #.*opt* (veq:ff s)) 23 | "random point in rectangle of size sx,sy. centered at origin." 24 | (values (rnd* (:vref s 0)) (rnd* (:vref s 1)))) 25 | 26 | (veq:def* 2in-square (&optional (s 1f0)) 27 | (declare #.*opt* (veq:ff s)) 28 | "random point in square of size s. centered at origin." 29 | (2in-rect s s)) 30 | 31 | (veq:def* 2nin-rect (n (:varg 2 s)) 32 | (declare #.*opt* (veq:pn n) (veq:ff s)) 33 | "n random points in rectangle of size sx,sy. centered at origin." 34 | (veq:fwith-arrays (:n n :itr k 35 | :arr ((a 2)) 36 | :fxs ((f () (2in-rect s))) 37 | :exs ((a k (f)))) 38 | a)) 39 | 40 | (veq:def* 2nin-square (n &optional (s 1f0)) 41 | (declare #.*opt* (veq:pn n) (veq:ff s)) 42 | "n random points in square of size s. centered at origin." 43 | (veq:fwith-arrays (:n n :itr k 44 | :arr ((a 2)) 45 | :fxs ((f () (2in-square s))) 46 | :exs ((a k (f)))) 47 | a)) 48 | 49 | 50 | (veq:def* 2on-circ (&optional (r 1f0)) 51 | (declare #.*opt* (veq:ff r)) 52 | "random point on circle with rad r. centered at origin." 53 | (veq:f2scale (veq:fcos-sin (rnd veq:fpii)) r)) 54 | 55 | (veq:def* 2non-circ (n &optional (r 1f0)) 56 | (declare #.*opt* (veq:ff r)) 57 | "n random points on circle with rad r. centered at origin." 58 | (veq:fwith-arrays (:n n :itr k 59 | :arr ((a 2)) 60 | :fxs ((f () (2on-circ r))) 61 | :exs ((a k (f)))) 62 | a)) 63 | 64 | (veq:def* 2in-circ (&optional (r 1f0)) 65 | (declare #.*opt* (veq:ff r)) 66 | "random point in circle with rad r. centered at origin." 67 | (let ((a (rnd)) (b (rnd))) 68 | (declare (veq:ff a b)) 69 | (if (< a b) (setf a (* veq:fpii (/ a b)) b (* b r)) 70 | (let ((d a)) (setf a (* veq:fpii (/ b a)) b (* d r)))) 71 | (values (* (cos a) b) (* (sin a) b)))) 72 | 73 | (veq:def* 2nin-circ (n &optional (r 1f0)) 74 | (declare #.*opt* (veq:ff r)) 75 | "n random points in circle with rad r. centered at origin." 76 | (veq:fwith-arrays (:n n :itr k 77 | :arr ((a 2)) 78 | :fxs ((f () (2in-circ r))) 79 | :exs ((a k (f)))) 80 | a))) 81 | 82 | -------------------------------------------------------------------------------- /src/rnd/3rnd.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | (veq:fvprogn 5 | 6 | (veq:def* 3on-line ((:varg 3 a b)) 7 | (declare #.*opt* (veq:ff a b)) 8 | "random point between a,b." 9 | (veq:f3from a (veq:f3- b a) (rnd))) 10 | 11 | (veq:def* 3non-line (n (:varg 3 a b)) 12 | (declare #.*opt* (veq:ff a b)) 13 | "n random points between a,b." 14 | (veq:fwith-arrays (:n n :itr k 15 | :arr ((arr 3)) 16 | :fxs ((f () (3on-line a b))) 17 | :exs ((arr k (f)))) 18 | arr)) 19 | 20 | 21 | (veq:def* 3in-box ((:varg 3 s)) 22 | (declare #.*opt* (veq:ff s)) 23 | "random point in box of size sx,sy,sz. centered at origin." 24 | (values (rnd* (:vref s 0)) 25 | (rnd* (:vref s 1)) 26 | (rnd* (:vref s 2)))) 27 | 28 | (veq:def* 3in-cube (&optional (s 1f0)) 29 | (declare #.*opt* (veq:ff s)) 30 | "random point in cube of size s. centered at origin." 31 | (3in-box s s s)) 32 | 33 | (veq:def* 3nin-box (n (:va 3 s)) 34 | (declare #.*opt* (veq:ff s)) 35 | "n random points in box of size sx,sy,sz. centered at origin." 36 | (veq:fwith-arrays (:n n :itr k 37 | :arr ((a 3)) 38 | :fxs ((f () (3in-box s))) 39 | :exs ((a k (f)))) 40 | a)) 41 | 42 | (defun 3nin-cube (n &optional (s 1f0)) 43 | (declare #.*opt* (veq:ff s)) 44 | "n random points in cube of size sx. centered at origin." 45 | (veq:fwith-arrays (:n n :itr k 46 | :arr ((a 3)) 47 | :fxs ((f () (3in-cube s))) 48 | :exs ((a k (f)))) 49 | a)) 50 | 51 | 52 | (declaim (inline 3on-sphere-slow)) 53 | (defun 3on-sphere-slow (&optional (r 1f0)) 54 | (declare #.*opt* (veq:ff r)) 55 | "random point on sphere with rad r. centered at origin. slower than 3on-sphere." 56 | (labels ((-norm (&aux (s (sqrt (abs (* 2f0 (log (rnd)))))) 57 | (u (rnd veq:fpii))) 58 | (declare (veq:ff s u)) 59 | (values (* s (cos u)) (* s (sin u))))) 60 | (mvb (a b) (-norm) 61 | (declare (veq:ff a b)) 62 | (let ((c (-norm))) 63 | (declare (veq:ff c)) 64 | (veq:f3scale a b c (/ r (veq:f3len a b c))))))) 65 | 66 | (declaim (inline 3on-sphere)) 67 | (defun 3on-sphere (&optional (r 1f0)) 68 | (declare (optimize speed (safety 0)) (veq:ff r)) 69 | "random point on sphere with rad r. centered at origin." 70 | (let* ((th (* veq:fpii (rnd:rnd))) 71 | (la (- (the veq:ff (acos (- (* 2.0 (rnd:rnd)) 1f0))) veq:fpi5)) 72 | (co (* r (cos la)))) 73 | (declare (veq:ff th la co)) 74 | (values (* co (cos th)) (* co (sin th)) (* r (sin la))))) 75 | 76 | (declaim (inline 3in-sphere)) 77 | (defun 3in-sphere (&optional (r 1f0)) 78 | (declare (optimize speed (safety 0)) (veq:ff r)) 79 | "random point in sphere with rad r. centered at origin." 80 | (veq:f3let ((cand (values 0f0 0f0 0f0))) 81 | (loop while t 82 | do (veq:f3vset (cand) (veq:f3rep (rnd*))) 83 | (when (< (veq:f3len2 cand) 1f0) 84 | (return-from 3in-sphere 85 | (veq:f3scale cand r)))))) 86 | 87 | (defun 3non-sphere (n &optional (r 1f0)) 88 | (declare #.*opt* (veq:ff r)) 89 | "n random points on sphere with rad r. centered at origin." 90 | (veq:fwith-arrays (:n n :itr k 91 | :arr ((a 3)) 92 | :fxs ((f () (3on-sphere r))) 93 | :exs ((a k (f)))) 94 | a)) 95 | 96 | (veq:def* 3nin-sphere (n &optional (r 1f0)) 97 | (declare #.*opt* (veq:ff r)) 98 | "n random points in sphere with rad r. centered at origin." 99 | (veq:fwith-arrays (:n n :itr k 100 | :arr ((a 3)) 101 | :fxs ((f () (3in-sphere r))) 102 | :exs ((a k (f)))) 103 | a))) 104 | 105 | -------------------------------------------------------------------------------- /src/rnd/macros.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | 5 | (defmacro prob (p a &optional b) 6 | "evaluate first form in body with probability p. 7 | second form (optional) is executed with probability 1-p. 8 | ex: (prob 0.1 (print :a) (print :b)) ; returns :a or :b" 9 | `(if (< (rnd) (the veq:ff ,p)) ,a ,b)) 10 | 11 | (defmacro prob* (p &body body) 12 | "evaluate body with probability p. returns the last form as if in a progn. 13 | ex: (prob 0.1 (print :a) (print :b)) ; returns :b" 14 | `(if (< (rnd) (the veq:ff ,p)) (progn ,@body))) 15 | 16 | (defmacro either (a &optional b) 17 | "excecutes either a or b, with a probablility of 0.5. b is optional." 18 | `(prob 0.5f0 ,a ,b)) 19 | 20 | 21 | ; TODO: sum to 1? 22 | (defmacro rcond (&rest clauses) 23 | "executes the forms in clauses according to the probability of the weighted sum 24 | ex: (rcond (0.1 (print :a)) (0.3 (print :b)) ...) 25 | will print :a 1 times out of 4." 26 | (weird:awg (val) 27 | (let* ((tot 0f0) 28 | (clauses (loop for (p . body) in clauses 29 | do (incf tot (veq:ff p)) 30 | collect `((< ,val ,tot) ,@body)))) 31 | (declare (veq:ff tot) (list clauses)) 32 | `(let ((,val (rnd ,tot))) 33 | (declare (veq:ff ,val)) 34 | (cond ,@clauses))))) 35 | 36 | (defmacro rep (a &optional b &body body) 37 | "repeat body at most a times, or between a and b times." 38 | `(loop repeat ,(if (and a b) `(rndrngi ,a ,b) `(rndi ,a)) 39 | do (progn ,@body))) 40 | 41 | -------------------------------------------------------------------------------- /src/rnd/rnd.lisp: -------------------------------------------------------------------------------- 1 | (in-package :rnd) 2 | 3 | 4 | (defun make-rnd-state () 5 | "generate a new random state." 6 | (setf *random-state* (make-random-state t))) 7 | 8 | (defun set-rnd-state (&optional i) 9 | "use this random seed. only implemented for SBCL." 10 | #+SBCL (if i (setf *random-state* (sb-ext:seed-random-state (the number i))) 11 | (make-rnd-state)) 12 | #-SBCL (warn 13 | "rnd:state is only implemented for SBCL. see src/rnd.lisp 14 | to implement state for your environment.")) 15 | 16 | ; NUMBERS AND RANGES 17 | 18 | (declaim (inline rndi)) 19 | (defun rndi (a) 20 | (declare #.*opt* (fixnum a)) 21 | "random fixnum in range (0 a]." 22 | (the fixnum (random a))) 23 | 24 | (declaim (inline nrndi)) 25 | (defun nrndi (n a) 26 | (declare #.*opt* (veq:pn n a)) 27 | "n random fixnums in range: (0 a]." 28 | (loop repeat n collect (rndi a) of-type fixnum)) 29 | 30 | 31 | (declaim (inline rndrngi)) 32 | (defun rndrngi (a b) 33 | (declare #.*opt* (fixnum a b)) 34 | "random fixnum in range (a b]." 35 | (+ a (rndi (- b a)))) 36 | 37 | (declaim (inline nrndrngi)) 38 | (defun nrndrngi (n a b) 39 | (declare #.*opt* (veq:pn n) (fixnum a b)) 40 | "n fixnums in range [a b)." 41 | (let ((d (- b a))) 42 | (declare (fixnum d)) 43 | (loop repeat n collect (+ a (rndi d)) of-type fixnum))) 44 | 45 | 46 | (declaim (inline rnd)) 47 | (defun rnd (&optional (x 1f0)) 48 | (declare (optimize speed (safety 0)) (veq:ff x)) 49 | "random float below x." 50 | (random x)) 51 | 52 | (declaim (inline nrnd)) 53 | (defun nrnd (n &optional (x 1f0)) 54 | (declare #.*opt* (veq:pn n) (veq:ff x)) 55 | "n random floates below x." 56 | (loop repeat n collect (rnd x) of-type veq:ff)) 57 | 58 | 59 | (declaim (inline rnd*)) 60 | (defun rnd* (&optional (x 1f0)) 61 | (declare (optimize speed (safety 0)) (veq:ff x)) 62 | "random float in range (-x x)." 63 | (- x (rnd (* 2f0 x)))) 64 | 65 | (declaim (inline nrnd*)) 66 | (defun nrnd* (n &optional (x 1f0)) 67 | (declare #.*opt* (veq:pn n) (veq:ff x)) 68 | "n random floats in range (x -x)." 69 | (loop repeat n collect (rnd* x) of-type veq:ff)) 70 | 71 | 72 | (declaim (inline rndrng)) 73 | (defun rndrng (a b) 74 | (declare (optimize speed (safety 0)) (veq:ff a b)) 75 | "random float in range (a b)." 76 | (+ a (rnd (- b a)))) 77 | 78 | (declaim (inline nrndrng)) 79 | (defun nrndrng (n a b) 80 | (declare #.*opt* (veq:pn n) (veq:ff a b)) 81 | "n random floats in range (a b)." 82 | (loop repeat n collect (rndrng a b) of-type veq:ff)) 83 | 84 | 85 | ; https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform 86 | (declaim (inline norm)) 87 | (defun norm (&key (mu 0f0) (sigma 1f0)) 88 | (declare #.*opt* (veq:ff mu sigma)) 89 | "two random numbers from normal distribution with (mu 0f0) and (sigma 1f0). 90 | generated using the box-muller transform." 91 | (let ((s (* sigma (the veq:ff 92 | (sqrt (the veq:pos-ff 93 | (* -2f0 (log (rnd)))))))) 94 | (u (rnd veq:fpii))) 95 | (declare (veq:ff s u)) 96 | (values (+ mu (* s (cos u))) 97 | (+ mu (* s (sin u)))))) 98 | 99 | 100 | ; GENERIC 101 | 102 | (defun rndget (l) 103 | (declare #.*opt* (sequence l)) 104 | "get random item from sequence l." 105 | (typecase l (cons (nth (rndi (length (the list l))) l)) 106 | (vector (aref l (rndi (length l)))) 107 | (t (error "incorrect type in rndget: ~a" l)))) 108 | 109 | 110 | (defun rndspace (n a b &key order &aux (d (- b a))) 111 | (declare #.*opt* (veq:pn n) (veq:ff a b d)) 112 | "n random numbers in range (a b). use :order t to sort result." 113 | (if order (sort (loop repeat n collect (+ a (rnd d)) of-type veq:ff) #'<) 114 | (loop repeat n collect (+ a (rnd d)) of-type veq:ff))) 115 | 116 | 117 | (defun rndspacei (n a b &key order &aux (d (- b a))) 118 | (declare #.*opt* (veq:pn n) (fixnum a b d)) 119 | "n random fixnums in range [a b). use order to sort result." 120 | (if order (sort (loop repeat n collect (+ a (rndi d)) of-type fixnum) #'<) 121 | (loop repeat n collect (+ a (rndi d)) of-type fixnum))) 122 | 123 | 124 | (defun bernoulli (n p) 125 | (declare #.*opt* (veq:pn n) (veq:ff p)) 126 | "n random numbers from bernoulli distribution with mean p." 127 | (loop repeat n collect (prob p 1f0 0f0) of-type veq:ff)) 128 | 129 | 130 | ; https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle 131 | (defun shuffle (a* &aux (n (length a*))) 132 | (declare #.*opt* (veq:pn n) (simple-array a*)) 133 | "shuffle a with fisher yates algorithm." 134 | (loop for i of-type veq:pn from 0 to (- n 2) 135 | do (rotatef (aref a* i) (aref a* (rndrngi i n)))) 136 | a*) 137 | 138 | 139 | (defun nrnd-from (n a) 140 | (declare #.*opt* (veq:pn n) (vector a)) 141 | "n random elements from a." 142 | (loop for i in (nrndi n (length a)) collect (aref a i))) 143 | 144 | (defun nrnd-from* (n a) 145 | (declare #.*opt* (veq:pn n) (vector a)) 146 | "n random distinct elements from a. assumes no dupes in a." 147 | (let* ((a* (ensure-vector a)) 148 | (resind nil) 149 | (anum (length (the simple-array a*)))) 150 | (when (> n anum) (error "not enough distinct elements in a.")) 151 | (loop until (>= (hset:num (hset:make :init resind)) n) 152 | do (setf resind (nrndi n anum))) 153 | (loop for i in resind collect (aref a* i)))) 154 | 155 | 156 | ; TODO: port this 157 | ; some version of mitchell's best candidate algorithm 158 | ; https://bl.ocks.org/mbostock/1893974/c5a39633db9c8b1f12c73b069e002c388d4cb9bf 159 | ; TODO: make n the max number instead of the new sample number 160 | ; (defun max-distance-sample (n fx &key (sample-num 50) (dstfx #'vec:dst2) 161 | ; (res (weir-utils:make-adjustable-vector))) 162 | ; (declare (fixnum n sample-num) (function fx dstfx) (array res)) 163 | ; " 164 | ; randomly sample a total of n items using (funcall fx sample-num), selecting 165 | ; the element furthest from existing elemets. 166 | ; example: 167 | 168 | ; (rnd:max-distance-sample 100 169 | ; (lambda (g) (rnd:nin-circ g 400f0))) 170 | ; " 171 | ; (labels ((-get-cand (c) (second (first c))) 172 | ; (-closest (res* c) (loop for v across res* 173 | ; minimizing (funcall dstfx v c)))) 174 | ; (loop with wanted-length of-type fixnum = (+ n (length res)) 175 | ; until (>= (length res) wanted-length) 176 | ; do (weir-utils:vextend 177 | ; (-get-cand (sort (loop for c in (funcall fx sample-num) 178 | ; collect (list (-closest res c) c)) 179 | ; #'> :key #'first)) 180 | ; res)) 181 | ; res)) 182 | 183 | -------------------------------------------------------------------------------- /src/rnd/walkers.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :rnd) 3 | 4 | 5 | (defun walker (&optional (x 0f0)) 6 | (declare #.*opt* (veq:ff x)) 7 | "random walker." 8 | (lambda (s) (declare (veq:ff s)) 9 | (incf x (rnd* s)))) 10 | 11 | (defun walker-acc (&optional (x 0f0) (a 0f0)) 12 | (declare #.*opt* (veq:ff x a)) 13 | "accelerated random walker." 14 | (lambda (s) (declare (veq:ff s)) 15 | (incf a (rnd* s)) 16 | (values (incf x a) a))) 17 | 18 | 19 | (veq:fvdef* 2walker ((:va 2 x)) 20 | (declare #.*opt* (veq:ff x)) 21 | "random 2d walker." 22 | (lambda (s) (declare (veq:ff s)) 23 | (veq:f2vset (x) (veq:f2+ x (2in-circ s))) 24 | (veq:f2 x))) 25 | 26 | (veq:fvdef* 2walker-acc ((:va 2 x a)) 27 | (declare #.*opt* (veq:ff x a)) 28 | "accelerated random 2d walker." 29 | (lambda (s) (declare (veq:ff s)) 30 | (veq:f2vset (a) (veq:f2+ a (2in-circ s))) 31 | (veq:f2vset (x) (veq:f2+ x a)) 32 | (values x a))) 33 | 34 | 35 | (veq:fvdef* 3walker ((:va 3 x)) 36 | (declare #.*opt* (veq:ff x)) 37 | "random 3d walker." 38 | (lambda (s) 39 | (declare (veq:ff s)) 40 | (veq:f3vset (x) (veq:f3+ x (3in-sphere s))) 41 | (veq:f3 x))) 42 | 43 | (veq:fvdef* 3walker-acc ((:va 3 x a)) 44 | (declare #.*opt* (veq:ff x a)) 45 | "accelerated random 3d walker." 46 | (lambda (s) 47 | (declare (veq:ff s)) 48 | (veq:f3vset (a) (veq:f3+ a (3in-sphere s))) 49 | (veq:f3vset (x) (veq:f3+ x a)) 50 | (values x a))) 51 | 52 | -------------------------------------------------------------------------------- /src/state.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :state) 3 | 4 | 5 | (defstruct (state (:constructor make ())) 6 | (s (make-hash-table :test #'equal) :type hash-table)) 7 | 8 | ; TODO: only execute body if key exists 9 | ; TODO: flag to avoid setting result 10 | (defmacro awith ((st k &key default) &body body) 11 | "access state[key] as state:it, 12 | the final form of body is assigned back to state[key]" 13 | (weird:awg (sname kname res dname s) 14 | `(let* ((,sname ,st) 15 | (,dname ,default) 16 | (,kname ,k) 17 | (,s (state-s ,sname)) 18 | (it (gethash ,kname (state-s ,sname) ,dname)) 19 | (,res (progn ,@body))) 20 | (setf (sget ,sname ,kname) ,res)))) 21 | 22 | (defun sget (st k &key default) 23 | "get k of state (or default)" 24 | (declare (state st)) 25 | (gethash k (state-s st) default)) 26 | 27 | (defun -sset (st k v) 28 | "set k of st to v, returns v" 29 | (declare (state st)) 30 | (setf (gethash k (state-s st)) v)) 31 | 32 | (defsetf sget -sset) 33 | 34 | (defun lget (st keys &key default) 35 | "get keys of state (or default)" 36 | (declare (state st) (list keys)) 37 | (loop for k in keys collect (sget st k :default default))) 38 | 39 | (defun lset (st keys v) 40 | "set keys of st to v. returns keys" 41 | (declare (state st) (list keys)) 42 | (loop for k in keys do (setf (sget st k) v))) 43 | 44 | (defun to-list (st) 45 | (declare (state st)) 46 | "get state as alist" 47 | (loop for k being the hash-keys of (state-s st) using (hash-value v) 48 | collect `(,k . ,v))) 49 | 50 | -------------------------------------------------------------------------------- /src/voxel/voxel.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :voxel) 3 | 4 | (declaim (inline -set-imap)) 5 | (defun -set-imap (imap ix iy iz) 6 | (declare #.*opt* (pos-vec imap) (veq:pn ix iy iz)) 7 | (loop for i of-type veq:pn from 0 below 24 by 3 8 | do (setf (aref imap i) (+ ix (aref *offsets* i)) 9 | (aref imap (1+ i)) (+ iy (aref *offsets* (1+ i))) 10 | (aref imap (+ i 2)) (+ iz (aref *offsets* (+ i 2)))))) 11 | 12 | (declaim (inline -get-cubeindex)) 13 | (defun -get-cubeindex (a imap fx) 14 | (declare #.*opt* (veq:fvec a) (pos-vec imap) (function fx)) 15 | (loop with ind of-type veq:pn = 0 16 | for i of-type veq:pn from 0 below 24 by 3 17 | for b of-type veq:pn from 0 18 | do (let ((va (aref a (aref imap i) (aref imap (1+ i)) 19 | (aref imap (+ i 2))))) 20 | ; (when (and (>= hi va lo)) (incf ind (the veq:pn (expt (abs 2) b)))) 21 | (when (funcall fx (the veq:ff va)) (incf ind (the veq:pn (expt (abs 2) b))))) 22 | finally (return ind))) 23 | 24 | (declaim (inline -set-voxel-list)) 25 | (defun -set-voxel-list (voxellist ec) 26 | (declare #.*opt* (pos-vec voxellist) (veq:pn ec)) 27 | (loop for i of-type veq:pn from 0 below 12 28 | for k of-type veq:pn from 0 by 2 29 | do (let ((pow (the veq:pn (expt (abs 2) i)))) 30 | (declare (veq:pn pow)) 31 | (when (= (logand ec pow) pow) 32 | (setf (aref voxellist k) (aref *cubeind* k) 33 | (aref voxellist (1+ k)) (aref *cubeind* (1+ k))))))) 34 | 35 | (declaim (inline -do-global-edge)) 36 | (defun -do-global-edge (imap v &aux (3v (* 3 v))) 37 | (declare #.*opt* (pos-vec imap) (veq:pn v 3v)) 38 | (list (aref imap 3v) (aref imap (1+ 3v)) (aref imap (+ 3v 2)))) 39 | 40 | (declaim (inline -single-ind)) 41 | (defun -single-ind (v) 42 | (declare #.*opt* (list v)) 43 | (veq:dsb (x y z) v 44 | (declare (veq:pn x y z)) 45 | (+ x (the veq:pn 46 | (* *max-voxels* 47 | (the veq:pn (+ y (the veq:pn (* *max-voxels* z))))))))) 48 | 49 | (declaim (inline -hash-edge)) 50 | (defun -hash-edge (edge) 51 | (declare #.*opt* (list edge)) 52 | (sort (mapcar #'-single-ind edge) #'<)) 53 | 54 | 55 | (declaim (inline -get-pos-mid)) 56 | (veq:fvdef -get-pos-mid (a e) 57 | (declare #.*opt* (ignore a) (list e)) 58 | (veq:dsb (ev1 ev2) e 59 | (declare (list ev1 ev2)) 60 | (veq:f3+ (veq:f3mid (veq:ffl ev1) (veq:ffl ev2)) 61 | (veq:f3rep *shift*)))) 62 | 63 | 64 | (veq:fvdef* -intersect ((:va 3 p1 p2) av1 av2 &aux (av1 (abs av1)) (av2 (abs av2))) 65 | (declare #.*opt* (veq:ff p1 p2 av1 av2)) 66 | (if (< (abs (- av2 av1)) *eps*) 67 | (veq:f3mid p1 p2) 68 | (veq:f3iscale (veq:f3+ (veq:f3scale p1 av1) (veq:f3scale p2 av2)) 69 | (+ av1 av2)))) 70 | 71 | 72 | ; (declaim (inline -get-pos-weighted)) 73 | (veq:fvdef -get-pos-weighted (a e) 74 | (declare #.*opt* (veq:fvec a) (list e)) 75 | (veq:dsb (ev1 ev2) e 76 | (declare (list ev1 ev2)) 77 | (veq:f3+ (-intersect (veq:ffl ev1) (veq:ffl ev2) 78 | (apply #'aref a ev1) (apply #'aref a ev2)) 79 | (veq:f3rep *shift*)))) 80 | 81 | ; (declaim (inline -add-poly)) 82 | (defun -add-poly (a edge->vert wer tri posfx) 83 | (declare #.*opt* (veq:fvec a) (hash-table edge->vert) (list tri)) 84 | (weir:add-poly! wer 85 | (loop for e of-type list in tri 86 | collect (let ((h (-hash-edge e))) 87 | (declare (list h)) 88 | (veq:mvb (v exists) (gethash h edge->vert) 89 | (declare (boolean exists)) 90 | (if exists v (setf (gethash h edge->vert) 91 | (weir:3add-vert! wer 92 | (veq:mvc (the function posfx) a e)))))) 93 | of-type veq:pn))) 94 | 95 | ; (declaim (inline -make-poly)) 96 | (defun -make-poly (imap voxellist cubeindex i) 97 | (declare #.*opt* (pos-vec imap voxellist) (veq:pn cubeindex i)) 98 | (loop for k of-type veq:pn from 0 below 3 99 | collect (let ((i2 (* 2 (aref *triangles* cubeindex (+ i k))))) 100 | (declare (veq:pn i2)) 101 | (list (-do-global-edge imap (aref voxellist i2)) 102 | (-do-global-edge imap (aref voxellist (1+ i2))))) 103 | of-type list)) 104 | 105 | ; (declaim (inline -add-polys)) 106 | (defun -add-polys (a edge->vert imap voxellist cubeindex wer posfx) 107 | (declare #.*opt* (veq:fvec a) (pos-vec imap voxellist) 108 | (veq:pn cubeindex) (hash-table edge->vert)) 109 | (loop for i of-type veq:pn from 0 by 3 110 | until (= (aref *triangles* cubeindex i) 99) 111 | collect (-add-poly a edge->vert wer 112 | (-make-poly imap voxellist cubeindex i) 113 | posfx))) 114 | 115 | (defun set-voxels (dims fx) 116 | (declare #.*opt* (list dims) (function fx)) 117 | " dims = (list nx ny nz) " 118 | (veq:dsb (nx ny nz) dims 119 | (declare (veq:pn nx ny nz)) 120 | (loop with voxs = (make dims) 121 | with maxv = -99999f0 122 | with minv = 99999f0 123 | for x of-type veq:pn from 0 below nx do 124 | (loop for y of-type veq:pn from 0 below ny do 125 | (loop for z of-type veq:pn from 0 below nz 126 | do (let ((v (funcall fx x y z))) 127 | (declare (veq:ff v)) 128 | (setvoxel voxs x y z v) 129 | (when (> v maxv) (setf maxv v)) 130 | (when (< v minv) (setf minv v))))) 131 | finally (progn (setf (voxels-maxv voxs) maxv 132 | (voxels-minv voxs) minv) 133 | (return voxs))))) 134 | 135 | (defun get-mesh (wer voxs &key w (fx (lambda (v) (>= 0.0 v )))) 136 | (declare #.*opt* (voxels voxs) (boolean w) (function fx)) 137 | "reconstruct mesh surounding (fx ...) == t." 138 | (let ((imap (-make-pos-vec 24)) 139 | (voxellist (-make-pos-vec 24)) 140 | (a (voxels-a voxs)) 141 | (edge->vert (make-hash-table :test #'equal :size 1024 :rehash-size 2f0)) 142 | (polys (list)) 143 | (posfx (if w #'-get-pos-weighted #'-get-pos-mid))) 144 | (declare (pos-vec imap voxellist) (veq:fvec a) (hash-table edge->vert) 145 | (function posfx)) 146 | (loop for ix of-type veq:pn from 0 to (voxels-nx voxs) 147 | do (loop for iy of-type veq:pn from 0 to (voxels-ny voxs) 148 | do (loop for iz of-type veq:pn from 0 to (voxels-nz voxs) 149 | do (-set-imap imap ix iy iz) 150 | (let* ((cubeindex (-get-cubeindex a imap fx)) 151 | (ec (aref *edges* cubeindex))) 152 | (declare (veq:pn ec cubeindex)) 153 | (unless (or (= ec 0) (= ec 255)) 154 | (-set-voxel-list voxellist ec) 155 | (loop for poly in 156 | (-add-polys a edge->vert imap voxellist 157 | cubeindex wer posfx) 158 | do (push poly polys))))))) 159 | polys)) 160 | 161 | -------------------------------------------------------------------------------- /src/weir/3bvh.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (declaim (inline make-bvhres bvhres-i bvhres-s)) 6 | (defstruct (bvhres) 7 | (i -1 :type fixnum :read-only nil) 8 | (s 900000f0 :type veq:ff :read-only nil)) 9 | (weird:define-struct-load-form bvhres) 10 | 11 | 12 | (declaim (inline %make-polyx)) 13 | (veq:fvdef* make-polyx ((:va 3 v0 v1 v2) &aux (res (veq:f3$zero 3))) 14 | (declare (optimize speed (safety 0)) (veq:ff v0 v1 v2) (veq:fvec res)) 15 | (veq:$nvset (res 9) (veq:f3- v2 v0) (veq:f3- v1 v0) (veq:f3 v0))) 16 | 17 | (veq:fvdef make-bvh (wer &key (num 5) matfx) 18 | (declare #.*opt* (weir wer) (veq:pn num)) 19 | (bvh::make (bvh::-make-objects-and-normals wer) 20 | (lambda (poly) 21 | (declare #.*opt* (list poly)) 22 | ; TODO: find a better way for this ?? what is this? 23 | (make-polyx (veq:f3$ (3gvs wer poly) 0 1 2))) 24 | :matfx matfx 25 | :num num)) 26 | 27 | (declaim (inline get-bvh-res-norm)) 28 | (veq:fvdef get-bvh-res-norm (bvh res) 29 | (declare (optimize speed (safety 0)) (bvh::bvh bvh) (bvhres res)) 30 | (veq:f3$ (bvh::bvh-normals bvh) (bvhres-i res))) 31 | 32 | (declaim (inline get-bvh-res-poly)) 33 | (veq:fvdef get-bvh-res-poly (bvh res) 34 | (declare (optimize speed (safety 0)) (bvh::bvh bvh) (bvhres res)) 35 | (veq:3$ (bvh::bvh-polys bvh) (bvhres-i res))) 36 | 37 | (declaim (inline get-bvh-res-mat)) 38 | (veq:fvdef get-bvh-res-mat (bvh res) 39 | (declare (optimize speed (safety 0)) (bvh::bvh bvh) (bvhres res)) 40 | (veq:2$ (bvh::bvh-mat bvh) (bvhres-i res))) 41 | 42 | (defmacro -eps-div (&rest rest) 43 | `(values ,@(loop for x in rest 44 | collect `(if (> (the veq:ff (abs (the veq:ff ,x))) 45 | (the veq:ff #.*eps*)) 46 | (the veq:ff (/ ,x)) (the veq:ff #.*eps*))))) 47 | 48 | 49 | (veq:fvdef make-raycaster (bvh &aux (res (make-bvhres))) 50 | (declare (optimize speed (safety 0)) (bvh::bvh bvh) (bvhres res)) 51 | (macrolet 52 | ((nodes- (slot) `(aref nodes (the veq:pn (+ ,slot ni)))) 53 | (for-leaves- ((res i3) &body body) 54 | `(loop repeat (nodes- 0) 55 | for i of-type veq:pn from (nodes- 1) 56 | do (let* ((,i3 (the veq:pn (* 9 i))) 57 | (s ,@body)) 58 | (declare (veq:pn ,i3) (veq:ff s)) 59 | (when (and (< (the veq:ff #.*eps*) s) 60 | (< s (bvhres-s ,res))) 61 | (setf (bvhres-s ,res) s (bvhres-i ,res) i))))) 62 | (rec-if- (&rest rest) 63 | `(let ((i ,@rest)) 64 | (declare (veq:pn i)) 65 | (when (> i 0) (rec i) (rec (the veq:pn (+ bvh::+leap+ i))))))) 66 | 67 | (let ((mima (bvh::bvh-mima bvh)) 68 | (polyfx (bvh::bvh-polyfx bvh)) 69 | (nodes (bvh::bvh-nodes bvh))) 70 | (declare (veq:fvec mima polyfx) (veq:pvec nodes)) 71 | (labels 72 | ((raycast ((:va 3 org ll)) 73 | (declare (veq:ff org)) 74 | (veq:f3let ((inv (-eps-div ll))) 75 | (labels 76 | ((rec (ni &aux (ni2 (the veq:pn (* 2 ni)))) 77 | (declare (veq:pn ni ni2)) 78 | (when (bvh::-bbox-test mima (the veq:pn ni2) inv org) ; LEAP? 79 | (for-leaves- (res i3) (bvh::-polyx polyfx i3 org ll)) 80 | (rec-if- (nodes- 2))))) 81 | (setf (bvhres-i res) -1 (bvhres-s res) 900000f0) 82 | (rec 0) 83 | res)))) 84 | #'raycast)))) 85 | 86 | 87 | (veq:fvdef make-short-raycaster (bvh) 88 | (declare (optimize speed (safety 0)) (bvh::bvh bvh)) 89 | (macrolet 90 | ((nodes- (slot) `(aref nodes (the veq:pn (+ ,slot ni)))) 91 | (for-leaves- ((i3) &body body) 92 | `(loop repeat (nodes- 0) 93 | for i of-type veq:pn from (nodes- 1) 94 | do (let* ((,i3 (the veq:pn (* 9 i))) 95 | (s ,@body)) 96 | (declare (veq:pn ,i3) (veq:ff s)) 97 | (when (and (< (the veq:ff #.*eps*) s) (< s 1f0)) 98 | (return-from raycast-short 0f0))))) 99 | (rec-if- (&rest rest) 100 | `(let ((i ,@rest)) 101 | (declare (veq:pn i)) 102 | (when (> i 0) (push-rt i) (push-rt (the veq:pn (+ bvh::+leap+ i))))))) 103 | 104 | (weird:with-fast-stack (rt :n 100 :safe-z 20 :type veq:pn) 105 | (let ((mima (bvh::bvh-mima bvh)) 106 | (polyfx (bvh::bvh-polyfx bvh)) 107 | (nodes (bvh::bvh-nodes bvh))) 108 | (declare (veq:fvec mima polyfx) (veq:pvec nodes)) 109 | (labels 110 | ((raycast-short ((:va 3 org ll)) 111 | (declare (veq:ff org)) 112 | (veq:f3let ((inv (-eps-div ll))) 113 | (nil-rt) 114 | (push-rt 0) 115 | (loop while (con-rt) 116 | do (let* ((ni (pop-rt)) 117 | (ni2 (* 2 ni))) ; LEAP? 118 | (declare (veq:pn ni ni2)) 119 | (when (bvh::-bbox-test mima ni2 inv org) 120 | (for-leaves- (i3) (bvh::-polyx polyfx i3 org ll)) 121 | (rec-if- (nodes- 2))))) 122 | 1f0))) 123 | #'raycast-short))))) 124 | 125 | -------------------------------------------------------------------------------- /src/weir/alteration-defalt-macro.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | ; TODO: ignore nil alts 5 | (defun build-alt (wname pairs aexpr 6 | &key alt-res res db 7 | &aux (wgs (gensym (mkstr wname)))) 8 | (declare #.*opt* (symbol alt-res wname wgs) (list pairs aexpr)) 9 | "helper function used to construct alterations from template. 10 | see defalt macro below." 11 | 12 | ;; eg: expanded alt for (% (add-edge? v? (+ i 1)) :res a?): 13 | 14 | ;; alt body: (ADD-EDGE! W A B G G) 15 | ;; res: A? 16 | ;; wrapped: ((B (+ I 1) OUT-B23) (G NIL OUT-G24)) 17 | ;; futures: ((A V? OUT-A22)) 18 | 19 | ;; (LET ((#:OUT-B23 (+ I 1))) ; <-- create closure for B,G 20 | ;; (LET ((#:OUT-G24 NIL)) 21 | ;; (LAMBDA (#:WER164) 22 | ;; (DECLARE (OPTIMIZE (SAFETY 1) (SPEED 3) DEBUG SPACE) 23 | ;; (WEIR::WEIR #:WER164) 24 | ;; (IGNORABLE #:WER164)) 25 | ;; (CASE (WEIR::-IF-ALL-RESOLVED #:ALT-RES6 V?) ; <-- checks if V? is resolved 26 | ;; (:OK 27 | ;; (VALUES T 28 | ;; (SETF (GETHASH A? #:ALT-RES6) ; <- res is assigned here 29 | ;; (WEIR:ADD-EDGE! #:WER164 ; <-- alt body 30 | ;; (VALUES (GETHASH V? #:ALT-RES6)) 31 | ;; #:OUT-B23 :G #:OUT-G24)))) 32 | ;; (:BAIL (PROGN (SETF (GETHASH A? #:ALT-RES6) NIL) (VALUES T NIL))) 33 | ;; (T (VALUES NIL NIL)))))) 34 | 35 | (labels ((-print-debug (outer futures full) 36 | (format t "~&alt body: ~a~&res: ~a~&wrapped: ~a~&futures: ~a~&" 37 | aexpr res outer futures) 38 | (pprint full) 39 | #+SBCL (when (equal db :verbose) 40 | (format t "~&--- full expansion --->~&") 41 | (pprint (third (sb-cltl2:macroexpand-all 42 | `(veq:vprogn ,full))))) 43 | (format t "~&--------------------~&")) 44 | (select-let (s) 45 | (declare (symbol s)) 46 | (cond ((fdim-symbp s :dim 2) 'veq:f2let) 47 | ((fdim-symbp s :dim 3) 'veq:f3let) 48 | ((fdim-symbp s :dim 4) 'veq:f4let) 49 | (t 'let))) 50 | (wraplet (pairs inner) 51 | (declare (list pairs) (cons inner)) 52 | (loop for (o b a) in (reverse pairs) 53 | do (setf inner `(,(select-let o) ((,a ,b)) ,inner))) 54 | inner) 55 | (replace-inner-symbols (pairs aexpr) 56 | (declare (list pairs) (cons aexpr)) 57 | (loop for (old org new) in pairs 58 | do (setf aexpr (subst new old aexpr))) 59 | aexpr) 60 | (future-s (tree) (tree-find tree #'future-symbp)) 61 | (replace-inner-futures (pairs aexpr) 62 | (declare (list pairs) (cons aexpr)) 63 | (loop for (old org new) in pairs 64 | do (setf aexpr 65 | (subst `(values (gethash ,(future-s org) ,alt-res)) 66 | (future-s org) 67 | (subst org old aexpr)))) 68 | aexpr) 69 | (split-pairs (pairs) 70 | (declare (list pairs)) 71 | (filter-by-predicate 72 | (mapcar (lambda (sv) (declare (optimize speed)) 73 | `(,@sv ,(gensym (mkstr "OUT-" (car sv))))) 74 | (weird:group pairs 2)) 75 | (lambda (s) (declare (optimize speed)) (future-s (second s)))))) 76 | 77 | (mvb (futures outer) (split-pairs pairs) 78 | (declare (list outer futures)) 79 | (let* ((aexpr (subst wgs wname 80 | (replace-inner-futures futures 81 | (replace-inner-symbols outer aexpr)))) 82 | (main (if res `(setf (gethash ,res ,alt-res) ,aexpr) ; assign result 83 | `(progn ,aexpr))) ; unnamed result 84 | (inner (if futures ; if arg 85 | `(case (-if-all-resolved ,alt-res 86 | ,@(mapcar (lambda (l) (future-s (second l))) 87 | futures)) 88 | (:ok (values t ,main)) 89 | (:bail (progn ,(when res `(setf (gethash ,res ,alt-res) nil)) 90 | (values t nil))) 91 | (t (values nil nil))) 92 | `(values t ,main))) 93 | (full (wraplet outer 94 | `(lambda (,wgs) 95 | (declare #.*opt* (weir ,wgs) (ignorable ,wgs)) 96 | ,inner)))) 97 | (declare (list aexpr main inner full)) 98 | (when db (-print-debug outer futures full)) 99 | `(veq:fvprogn ,full))))) 100 | 101 | 102 | (defmacro defalt (name (wname &rest args) 103 | &body body 104 | &aux (rest (gensym "REST"))) 105 | (declare (symbol name wname rest) (list args body)) 106 | "define an alteration. 107 | as an example, the definition of 2add-vert? looks like this: 108 | 109 | (defalt 2add-vert? (f2!p) 110 | (weir:2add-vert! wer f2!p)) 111 | 112 | the prefix f2! is neccessary to indicate that the symbol represents a 113 | (veq:f2 a b) vector. 114 | 115 | defalt is used to define all internal alterations (except ?), and can be used 116 | to define custom alterations outside the :weir package." 117 | (labels ((&-symbp (a) 118 | (and (symbolp a) (member a '(&key &optional &rest &aux)))) 119 | (symb-with-default (a) 120 | (typecase a (symbol `(,a ,a)) 121 | (list `(,(car a) ,a)) 122 | (t (error "bad value in defalt. 123 | requires symbol or list. got: ~a" a)))) 124 | (make-arg-symbs (args) 125 | (loop for a in args 126 | if (&-symbp a) collect a 127 | else collect (symb-with-default a))) 128 | (make-build-alt-pairs (args &aux (res (list))) 129 | "build pairs of symb, value for alteration arguments. 130 | symbol is used in body to build futures." 131 | (loop for a in args 132 | if (listp a) do (push `(quote ,(car a)) res) 133 | (push (car a) res)) 134 | (reverse res)) 135 | (if-weir-internal (margs) 136 | ; a bit hacky, but this is to only export/document 137 | ; when called in weir. 138 | (when (equalp (package-name *package*) "WEIR") 139 | (let ((docs (weird::-docs-sanitize 140 | (format nil "weir alteration.~%args: ~a~%body: ~a" 141 | margs (car body))))) 142 | `((export ',name) (weird::map-docstring ',name 143 | ,docs :weircont :nodesc)))))) 144 | (let* ((args (make-arg-symbs args)) 145 | (margs (loop for a in args if (listp a) collect (cadr a) 146 | else collect a))) ; not listp == eg. &key) 147 | `(progn ,@(if-weir-internal margs) 148 | (defmacro ,name (,margs &rest ,rest) 149 | (apply #'build-alt ',wname (list ,@(make-build-alt-pairs args)) 150 | ',@body ,rest)))))) 151 | 152 | -------------------------------------------------------------------------------- /src/weir/alteration-utils.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (defun get-alteration-result-list (wer &key (all t)) 6 | (declare #.*opt* (weir wer) (boolean all)) 7 | "returns alist with tuples of alteration :res and corresponding value." 8 | (loop for k being the hash-keys of (weir-alt-res wer) 9 | using (hash-value v) 10 | if (or all v) ; TODO: does this do anything with the current approach? 11 | collect `(,k . ,v))) 12 | 13 | (defun get-alteration-result-map (wer) 14 | (declare #.*opt* (weir wer)) 15 | "returns hash-table with results of all alterations by :res." 16 | (weir-alt-res wer)) 17 | 18 | (defun get-alt-res (wer res) 19 | (declare #.*opt* (weir wer) (symbol res)) 20 | (unless (future-symbp res) 21 | (error "invalid alteration result name: ~a~%" res)) 22 | (gethash res (weir-alt-res wer))) 23 | 24 | 25 | (defun -if-all-resolved (alt-res &rest arg) 26 | (declare #.*opt* (hash-table alt-res) (list arg)) 27 | "check if all references of an alteration have been resolved." 28 | (loop for k of-type symbol in arg 29 | do (weird:mvb (res exists) (gethash k alt-res) 30 | (declare (boolean exists)) 31 | ; wait if result is not set 32 | (unless exists (return-from -if-all-resolved :wait)) 33 | ; bail if result exists and is nil 34 | (unless res (return-from -if-all-resolved :bail)))) 35 | :ok) ; result exists and is not nil 36 | 37 | 38 | (defun fdim-symbp (s &key dim) 39 | (declare #.*opt* (veq:pn dim)) 40 | "t if symbol starts with Fd! where d is a positive integer" 41 | (and (symbolp s) 42 | (> (length (symbol-name s)) 3) 43 | (string= (symbol-name s) (mkstr "F" dim "!") :start1 0 :end1 3))) 44 | 45 | (defun future-symbp (s) 46 | (declare #.*opt*) 47 | "t if symbol ends with ?" 48 | (and (symbolp s) 49 | (> (length (symbol-name s)) 1) 50 | (string= (the string (reverse (symbol-name s))) "?" 51 | :start1 0 :end1 1))) 52 | 53 | (defmacro with-gs ((&rest rest) &body body) 54 | `(let (,@(loop for s of-type symbol in rest 55 | collect `(,s (gensym ,(string-upcase (mkstr s)))))) 56 | ,@body)) 57 | 58 | 59 | (defmacro -valid-vert (wer v) `(< -1 (the veq:pn ,v) 60 | (the veq:pn (weir-num-verts ,wer)))) 61 | (defmacro -valid-verts (wer vv) 62 | (weird:awg (num v) 63 | `(let ((,num (weir-num-verts ,wer))) 64 | (declare (veq:pn ,num)) 65 | (every (lambda (,v) (declare (optimize speed) (veq:pn ,v)) 66 | (< -1 ,v ,num)) 67 | ,vv)))) 68 | 69 | -------------------------------------------------------------------------------- /src/weir/alterations.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (defmacro ? ((&rest args) &rest rest) 6 | ; (print args) ((X) (LIST #:WW-X-310 #:WW-Y-311 :A?)) 7 | (apply #'build-alt (caar args) ; caar = w 8 | (loop with res of-type list = (list) 9 | for s of-type symbol in (weird:undup 10 | (weird:tree-find-all (cadr args) 11 | #'future-symbp)) 12 | do (setf res (cons s (cons s res))) 13 | finally (return (reverse res))) 14 | (cadr args) rest)) 15 | 16 | 17 | (defalt add-grp? (wer g) (unless (grp-exists wer :g g) (add-grp! wer g))) 18 | 19 | (defalt add-poly? (wer poly &key g) (add-poly! wer poly :g g)) 20 | (defalt del-poly? (wer poly &key g) (del-poly! wer poly :g g)) 21 | 22 | (defalt add-edge? (wer a b &key g) (add-edge! wer a b :g g)) 23 | (defalt ladd-edge? (wer ab &key g) (ladd-edge! wer ab :g g)) 24 | (defalt del-edge? (wer a b &key g) (del-edge! wer a b :g g)) 25 | (defalt ldel-edge? (wer ab &key g) (ldel-edge! wer ab :g g)) 26 | 27 | (defalt swap-edge? (wer a b &key g from) (swap-edge! wer a b :g g :from from)) 28 | (defalt lswap-edge? (wer ab &key g from) (lswap-edge! wer ab :g g :from from)) 29 | 30 | (defalt 2add-path? (wer l &key g closed) (2add-path! wer l :g g :closed closed)) 31 | (defalt 3add-path? (wer l &key g closed) (3add-path! wer l :g g :closed closed)) 32 | 33 | (defalt del-path? (wer l &key g) (del-path! wer l :g g)) 34 | 35 | (defalt 2add-vert? (wer f2!p) (2add-vert! wer f2!p)) 36 | (defalt 3add-vert? (wer f3!p) (3add-vert! wer f3!p)) 37 | 38 | (defalt 2vadd-edge? (wer f2!p f2!q &key g) (2vadd-edge! wer f2!p f2!q :g g)) 39 | (defalt 3vadd-edge? (wer f3!p f3!q &key g) (3vadd-edge! wer f3!p f3!q :g g)) 40 | 41 | (defalt 2move-vert? (wer i f2!p &key (rel t)) 42 | (when (-valid-vert wer i) 43 | (progn (2move-vert! wer i f2!p :rel rel) i))) 44 | (defalt 3move-vert? (wer i f3!p &key (rel t)) 45 | (when (-valid-vert wer i) 46 | (progn (3move-vert! wer i f3!p :rel rel) i))) 47 | 48 | (defalt 2append-edge? (wer i f2!p &key g (rel t)) 49 | (when (-valid-vert wer i) 50 | (2append-edge! wer i f2!p :rel rel :g g))) 51 | 52 | (defalt 3append-edge? (wer i f3!p &key g (rel t)) 53 | (when (-valid-vert wer i) 54 | (3append-edge! wer i f3!p :rel rel :g g))) 55 | 56 | (defalt 2split-edge? (wer u v f2!p &key g force) 57 | (when (-valid-verts wer (list u v)) 58 | (2split-edge! wer u v f2!p :g g :force force))) 59 | (defalt 2lsplit-edge? (wer uv f2!p &key g force) 60 | (when (-valid-verts wer uv) 61 | (2lsplit-edge! wer uv f2!p :g g :force force))) 62 | 63 | (defalt 3split-edge? (wer u v f3!p &key g force) 64 | (when (-valid-verts wer (list u v)) 65 | (3split-edge! wer u v f3!p :g g :force force))) 66 | (defalt 3lsplit-edge? (wer uv f3!p &key g force) 67 | (when (-valid-verts wer uv) 68 | (3lsplit-edge! wer uv f3!p :g g :force force))) 69 | 70 | (defalt split-edge-ind? (wer u v via &key g force) 71 | (when (-valid-verts wer (list u v)) 72 | (split-edge-ind! wer u v :via via :g g :force force))) 73 | (defalt lsplit-edge-ind? (wer uv via &key g force) 74 | (when (-valid-verts wer uv) 75 | (lsplit-edge-ind! wer uv :via via :g g :force force))) 76 | 77 | (defalt collapse-verts? (wer u v &key g) 78 | (when (-valid-verts wer (u v)) (collapse-verts! wer u v :g g))) 79 | (defalt lcollapse-verts? (wer uv &key g) 80 | (when (-valid-verts wer uv) (lcollapse-verts! wer uv :g g))) 81 | 82 | 83 | (defalt set-edge-prop? (wer e prop &optional (val t)) 84 | (setf (get-edge-prop wer e prop) val)) 85 | (defalt set-vert-prop? (wer v prop &optional (val t)) 86 | (setf (get-vert-prop wer v prop) val)) 87 | (defalt set-grp-prop? (wer g prop &optional (val t)) 88 | (setf (get-grp-prop wer g prop) val)) 89 | 90 | (defalt mset-vert-prop? (wer vv prop &optional (val t)) 91 | (mset-vert-prop wer vv prop val)) 92 | (defalt mset-edge-prop? (wer ee prop &optional (val t)) 93 | (mset-vert-prop wer ee prop val)) 94 | 95 | (defalt copy-edge-props? (wer from to &key clear) 96 | (copy-edge-props wer from to :clear clear)) 97 | (defalt copy-vert-props? (wer from to &key clear) 98 | (copy-vert-props wer from to :clear clear)) 99 | 100 | (defalt mcopy-edge-props? (wer from to &key clear) 101 | (mcopy-edge-props wer from to :clear clear)) 102 | (defalt mcopy-vert-props? (wer from to &key clear) 103 | (mcopy-vert-props wer from to :clear clear)) 104 | 105 | ;; alterations that return a value, but don't do anything. 106 | ;; these should be postfixed with %. 107 | ;; TODO: fix inconsistent use of get in names? 108 | 109 | (defalt get-vert-prop% (_ v prop) (get-vert-prop _ v prop)) 110 | (defalt get-edge-prop% (_ e prop) (get-edge-prop _ e prop)) 111 | (defalt get-grp-prop% (_ g prop) (get-grp-prop _ g prop)) 112 | 113 | (defalt verts-with-prop% (_ prop &key val) 114 | (get-verts-with-prop _ prop :val val)) 115 | (defalt vert-with-prop% (_ prop &key val) 116 | (car (get-verts-with-prop _ prop :val val))) 117 | 118 | (defalt edges-with-prop% (_ prop &key val) 119 | (get-edges-with-prop _ prop :val val)) 120 | (defalt edge-with-prop% (_ prop &key val) 121 | (car (get-edges-with-prop _ prop :val val))) 122 | 123 | (defalt edge-prop-nxt-vert% (_ v prop &key val (except -1) g) 124 | (edge-prop-nxt-vert% _ v prop :val val :except except :g g)) 125 | 126 | -------------------------------------------------------------------------------- /src/weir/extra.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weir) 2 | 3 | ; TODO: copy properties? 4 | ; TODO: copy grps? 5 | (veq:fvdef 3->2 (wer fx &key new) 6 | (declare (weir wer) (function fx)) 7 | (weird:with-struct (weir- verts max-verts num-verts) wer 8 | (let* ((new (if new new (make :max-verts max-verts))) 9 | (new-verts (weir-verts new))) 10 | (declare (weir new) (veq:fvec new-verts)) 11 | (setf (weir-num-verts new) num-verts) 12 | (veq:f3$with-rows (num-verts verts) 13 | (lambda (i (veq:varg 3 x)) 14 | (declare (veq:pn i) (veq:ff x)) 15 | (veq:2$vset (new-verts i) (funcall fx x)))) 16 | (itr-edges (wer e) (ladd-edge! new e)) 17 | new))) 18 | 19 | (veq:fvdef* 2cut-to-area! (wer &key g (top 0f0) (left 0f0) 20 | (bottom 1000f0) (right 1000f0)) 21 | (declare (weir wer) (veq:ff top left bottom right)) 22 | " 23 | removes all edges (in g) outside envelope (ox oy), (w h). 24 | all edges intersecting the envelope will be deleted, a new vert will be 25 | inserted on the intersection. connected to the inside vert. 26 | edges inside the envelope will be left as they are. 27 | " 28 | (labels 29 | ((inside (i) 30 | (declare (veq:pn i)) 31 | (veq:f2let ((p (2$verts wer i))) 32 | (and (> (:vref p 0) left) (> (:vref p 1) top) 33 | (< (:vref p 0) right) (< (:vref p 1) bottom)))) 34 | 35 | (split-line (ai bi &aux (rev nil)) 36 | (declare (veq:pn ai bi) (boolean rev)) 37 | (unless (inside ai) (rotatef ai bi) (setf rev t)) ; swap indices 38 | (veq:f2let ((a (2$verts wer ai)) 39 | (b (2$verts wer bi)) 40 | (ab (veq:f2- b a))) 41 | (mvc #'values rev 42 | (veq:f2lerp a b 43 | (cond ((> (:vref b 0) right) (/ (- right (:vref a 0)) (:vref ab 0))) 44 | ((> (:vref b 1) bottom) (/ (- bottom (:vref a 1)) (:vref ab 1))) 45 | ((< (:vref b 0) left) (/ (- left (:vref a 0)) (:vref ab 0))) 46 | (t (/ (- top (:vref a 1)) (:vref ab 1)))))))) 47 | (cutfx (line) 48 | (declare (list line)) 49 | (case (length (remove-if-not #'inside line)) 50 | (0 (values :outside nil 0f0 0f0)) 51 | (1 (mvc #'values :split (apply #'split-line line))) 52 | (t (values :keep nil 0f0 0f0))))) 53 | 54 | (with (wer %) 55 | (itr-edges (wer e :g g) 56 | (with-gs (ae?) 57 | (mvb (state rev px py) (cutfx e) 58 | (declare (symbol state) (boolean rev) (veq:ff px py)) 59 | (case state 60 | (:outside (% (ldel-edge? e :g g))) 61 | (:split (% (ldel-edge? e :g g)) 62 | (% (2append-edge? 63 | (if rev (second e) (first e)) (veq:f2 px py) :rel nil :g g) 64 | :res ae?) 65 | (% (set-edge-prop? ae? :cut)))))))))) 66 | 67 | -------------------------------------------------------------------------------- /src/weir/kdtree.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | (deftype index-array () `(simple-array fixnum)) 5 | 6 | 7 | (defmacro -ind (a dim i leap) 8 | `(the fixnum (+ (the fixnum (* ,dim (the fixnum (aref ,a ,i)))) ,leap))) 9 | 10 | (defstruct (node (:constructor node (leap ind left right))) 11 | (left nil :read-only t) 12 | (right nil :read-only t) 13 | (leap -1 :type fixnum :read-only t) 14 | (ind -1 :type fixnum :read-only t)) 15 | 16 | (veq:fvdef -qsort-kdtree (argsort a &key dim (leap 0) (lo 0) hi) 17 | "construct a kd tree of dim using quicksort for partitioning. 18 | argsort will contain the index into the spatial data in a." 19 | (declare (index-array argsort) (veq:fvec a) (fixnum dim leap lo hi)) 20 | 21 | (cond ((= hi lo) (return-from -qsort-kdtree (node leap hi nil nil))) 22 | ((> lo hi) (return-from -qsort-kdtree nil))) 23 | 24 | (labels ((leapget (i) 25 | (declare (fixnum i)) 26 | (aref a (-ind argsort dim i leap))) 27 | 28 | (partition (lo hi) 29 | (declare (fixnum lo hi)) 30 | (loop with pivot = (leapget hi) 31 | with i = (- lo 1) 32 | for j from lo to hi 33 | do (when (<= (leapget j) pivot) 34 | (incf i) 35 | (rotatef (aref argsort i) (aref argsort j))) 36 | finally (return-from partition i)))) 37 | 38 | ; p is the index into argsort, used to retrieve the node spatial info in a 39 | (let ((p (partition lo hi)) 40 | (leap* (mod (1+ leap) dim))) 41 | (declare (fixnum p leap*)) 42 | (node leap p 43 | (-qsort-kdtree argsort a :dim dim :leap leap* :lo lo :hi (- p 1)) 44 | (-qsort-kdtree argsort a :dim dim :leap leap* :lo (+ p 1) :hi hi))))) 45 | 46 | 47 | (defstruct (kdtree (:constructor -make-kdtree)) 48 | (argsort #() :type index-array :read-only nil) 49 | (node nil :type node :read-only t) 50 | (dim -1 :type fixnum :read-only t)) 51 | 52 | (defun build-kdtree (wer) 53 | (declare (weir wer)) 54 | (let* ((dim (weir-dim wer)) 55 | (n (get-num-verts wer)) 56 | (argsort (make-array n :adjustable nil :element-type 'fixnum 57 | :initial-contents (loop for i of-type fixnum 58 | from 0 below n collect i)))) 59 | (declare (fixnum dim n) (index-array argsort)) 60 | (setf (weir-kdtree wer) 61 | (-make-kdtree :dim dim :argsort argsort 62 | :node (-qsort-kdtree argsort (weir-verts wer) 63 | :dim dim :hi (1- n)))))) 64 | 65 | ; TODO: 3rad/3nn. 2/3 macro? 66 | 67 | (veq:fvdef* 2rad (wer (:varg 2 x) rad &aux (rad2 (* rad rad)) (res (list))) 68 | "get indices of all verts in rad around x" 69 | (declare #.*opt* (weir wer) (veq:ff x rad rad2) (list res)) 70 | 71 | (with-struct (weir- kdtree verts dim) wer 72 | (declare (veq:fvec verts) (fixnum dim)) 73 | (with-struct (kdtree- argsort) kdtree 74 | (declare (index-array argsort)) 75 | (labels 76 | ((leapget (leap ind) 77 | (declare #.*opt* (fixnum leap ind)) 78 | (aref verts (-ind argsort dim ind leap))) 79 | 80 | (xdst2 (ind) 81 | (declare #.*opt* (fixnum ind)) 82 | (veq:f2dst2 x (veq:f2$ verts (aref argsort ind)))) 83 | 84 | (-rad (node) 85 | (declare #.*opt*) 86 | (when (not node) (return-from -rad)) 87 | (with-struct (node- ind leap left right) node 88 | (declare (veq:pn ind leap)) 89 | (let* ((xv (case leap (0 (:vref x 0)) (otherwise (:vref x 1)))) 90 | (nv (leapget leap ind)) 91 | (axdst2 (expt (- xv nv) 2f0)) 92 | (dst2 (xdst2 ind))) 93 | (declare (veq:ff xv nv axdst2 dst2)) 94 | 95 | (when (< dst2 rad2) (push (aref argsort ind) res)) 96 | (if (> rad2 axdst2) 97 | (progn (-rad left) (-rad right)) 98 | (-rad (if (<= xv nv) left right))))))) 99 | 100 | (-rad (kdtree-node kdtree)) 101 | res)))) 102 | 103 | (veq:fvdef* 2nn (wer (:varg 2 x) &aux (res -1) (resdst2 0f0)) 104 | "get index of nearest neighbour of x." 105 | (declare #.*opt* (weir wer) (veq:ff x resdst2) (fixnum res)) 106 | 107 | (with-struct (weir- kdtree verts dim) wer 108 | (declare (veq:fvec verts) (fixnum dim)) 109 | (with-struct (kdtree- argsort) kdtree 110 | (declare (index-array argsort)) 111 | (labels 112 | ((leapget (leap ind) 113 | (declare #.*opt* (fixnum leap ind)) 114 | (aref verts (-ind argsort dim ind leap))) 115 | 116 | (xdst2 (ind) 117 | (declare #.*opt* (fixnum ind)) 118 | (veq:f2dst2 x (veq:f2$ verts (aref argsort ind)))) 119 | 120 | (-nn (node) 121 | (declare #.*opt*) 122 | (when (not node) (return-from -nn)) 123 | (with-struct (node- ind leap left right) node 124 | (declare (veq:pn ind leap)) 125 | (let* ((xv (case leap (0 (:vref x 0)) (otherwise (:vref x 1)))) 126 | (nv (leapget leap ind)) 127 | (axdst2 (expt (- xv nv) 2f0)) 128 | (dst2 (xdst2 ind))) 129 | (declare (veq:ff xv nv axdst2 dst2)) 130 | 131 | (when (< dst2 resdst2) 132 | (setf res (aref argsort ind) resdst2 dst2)) 133 | (if (> resdst2 axdst2) 134 | (progn (-nn left) (-nn right)) 135 | (-nn (if (<= xv nv) left right))))))) 136 | 137 | (let ((node (kdtree-node kdtree))) 138 | (declare (node node)) 139 | (setf res (aref argsort (node-ind node)) 140 | resdst2 (xdst2 (aref argsort (node-ind node)))) 141 | (-nn node)) 142 | (values res (sqrt resdst2)))))) 143 | 144 | 145 | (veq:fvdef* 3nn (wer (:varg 3 x) &aux (res -1) (resdst2 0f0)) 146 | "get index of nearest neighbour of x." 147 | (declare #.*opt* (weir wer) (veq:ff x resdst2) (fixnum res)) 148 | 149 | (with-struct (weir- kdtree verts dim) wer 150 | (declare (veq:fvec verts) (fixnum dim)) 151 | (with-struct (kdtree- argsort) kdtree 152 | (declare (index-array argsort)) 153 | (labels 154 | ((leapget (leap ind) 155 | (declare #.*opt* (fixnum leap ind)) 156 | (aref verts (-ind argsort dim ind leap))) 157 | 158 | (xdst2 (ind) 159 | (declare #.*opt* (fixnum ind)) 160 | (veq:f3dst2 x (veq:f3$ verts (aref argsort ind)))) 161 | 162 | (-nn (node) 163 | (declare #.*opt*) 164 | (when (not node) (return-from -nn)) 165 | (with-struct (node- ind leap left right) node 166 | (declare (veq:pn ind leap)) 167 | (let* ((xv (case leap (0 (:vref x 0)) 168 | (1 (:vref x 1)) 169 | (otherwise (:vref x 2)))) 170 | (nv (leapget leap ind)) 171 | (axdst2 (expt (- xv nv) 2f0)) 172 | (dst2 (xdst2 ind))) 173 | (declare (veq:ff xv nv axdst2 dst2)) 174 | 175 | (when (< dst2 resdst2) 176 | (setf res (aref argsort ind) resdst2 dst2)) 177 | (if (> resdst2 axdst2) 178 | (progn (-nn left) (-nn right)) 179 | (-nn (if (<= xv nv) left right))))))) 180 | 181 | (let ((node (kdtree-node kdtree))) 182 | (declare (node node)) 183 | (setf res (aref argsort (node-ind node)) 184 | resdst2 (xdst2 (aref argsort (node-ind node)))) 185 | (-nn node)) 186 | (values res (sqrt resdst2)))))) 187 | 188 | -------------------------------------------------------------------------------- /src/weir/macros.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (defmacro with-rnd-edge ((wer ee &key g) &body body) 6 | (declare (symbol wer ee)) 7 | "select an arbitrary edge from a weir instance. the edge will be 8 | available in the context as ee. 9 | 10 | if a grp, g, is supplied it will select an edge from g, otherwise it will use 11 | the main grp." 12 | (weird:awg (grp edges grph ln) 13 | `(with-grp (,wer ,grp ,g) 14 | (let ((,grph (grp-grph ,grp))) 15 | (let* ((,edges (to-vector (graph:get-edges ,grph))) 16 | (,ln (length ,edges))) 17 | (declare (veq:pn ,ln)) 18 | (when (> ,ln 0) (let ((,ee (aref ,edges (rnd:rndi ,ln)))) 19 | (declare (list ,ee)) 20 | (progn ,@body)))))))) 21 | 22 | (defmacro with-rnd-vert ((wer v) &body body) 23 | (declare (symbol wer v)) 24 | "select an arbitrary vert from a weir instance. the vert will be available in 25 | the context as v." 26 | (weird:awg (num) 27 | `(let ((,num (weir-num-verts ,wer))) 28 | (when (> ,num 0) (let ((,v (rnd:rndi ,num))) 29 | (declare (veq:pn ,v)) 30 | (progn ,@body)))))) 31 | 32 | 33 | (defmacro itr-verts ((wer v &key collect) &body body) 34 | (declare (symbol wer v) (boolean collect)) 35 | "iterates over ALL verts in wer as v." 36 | `(loop for ,v of-type veq:pn from 0 below (weir-num-verts ,wer) 37 | ,(if collect 'collect 'do) 38 | (let ((,v ,v)) 39 | (declare (veq:pn ,v)) 40 | ,@body))) 41 | 42 | (defmacro itr-grp-verts ((wer v &key g collect) &body body) 43 | (declare (symbol wer v) (boolean collect)) 44 | "iterates over all verts in grp g as v. 45 | 46 | NOTE: this will only yield vertices that belong to at least one edge that is 47 | part of g. if you want all vertices in weir you should use itr-verts instead. 48 | itr-verts is also faster, since it does not rely on the underlying graph 49 | structure. 50 | 51 | if g is not provided, the main grp wil be used." 52 | (weird:awg (grp res grph) 53 | `(with-grp (,wer ,grp ,g) 54 | (let (,@(when collect `((,res (list)))) 55 | (,grph (grp-grph ,grp))) 56 | (graph:with-graph-verts (,grph ,v) 57 | ,(if collect `(push (progn ,@body) ,res) 58 | `(progn ,@body))) 59 | ,@(when collect `(,res)))))) 60 | 61 | (defmacro itr-edges ((wer ee &key g collect verts) &body body) 62 | (declare (symbol wer ee) (boolean collect)) 63 | "iterates over all edges in grp g as ee. if verts is provided it must be a 64 | list with two symbols. these two symbols will represent the two verts in the 65 | edge. if g is not provided, the main grp will be used." 66 | (when (and verts (not (and (consp verts) 67 | (= (length verts) 2) 68 | (every #'symbolp verts)))) 69 | (error "~&itr-edges error: verts must be on the format (a b). 70 | got: ~a~%" verts)) 71 | (weird:awg (grp grph res) 72 | (let ((body* (if verts `(weird:dsb ,verts ,ee 73 | (declare (veq:pn ,@verts) (ignorable ,@verts)) 74 | (progn ,@body)) 75 | `(progn ,@body)))) 76 | `(with-grp (,wer ,grp ,g) 77 | (let (,@(when collect `((,res (list)))) 78 | (,grph (grp-grph ,grp))) 79 | (graph:with-graph-edges (,grph ,ee) 80 | ,(if collect `(push ,body* ,res) body*)) 81 | ,@(when collect `(,res))))))) 82 | 83 | (defmacro itr-polys ((wer p &key g collect) &body body) 84 | (declare (symbol wer p) (boolean collect)) 85 | `(loop for ,p of-type list 86 | being the hash-keys of (-get-polys-from ,wer :g ,g) 87 | ,(if collect 'collect 'do) 88 | (let ((,p ,p)) 89 | (declare (list ,p)) 90 | (progn ,@body)))) 91 | 92 | (defmacro itr-grps ((wer g &key collect main) &body body) 93 | (declare (symbol wer) (boolean collect)) 94 | "iterates over all grps of wer as g." 95 | (weird:awg (main*) 96 | `(loop with ,main* = ,main 97 | for ,g being the hash-keys of (weir-grps ,wer) 98 | if (or ,main ,g) 99 | ,(if collect 'collect 'do) 100 | (let ((,g ,g)) ,@body)))) 101 | 102 | -------------------------------------------------------------------------------- /src/weir/poly-isect.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weir) 3 | 4 | ; TODO: bi-list can be built directly 5 | (defun -bi-list (isects) 6 | (declare (list isects)) 7 | (let ((edge-d (make-hash-table :test #'equal)) 8 | (edge-poly (make-hash-table :test #'equal)) 9 | (poly-edge (make-hash-table :test #'equal))) 10 | (declare (hash-table edge-d edge-poly poly-edge)) 11 | (loop for (edge poly d) in isects 12 | do (if (gethash edge edge-poly) 13 | (setf (gethash edge edge-poly) 14 | (cons poly (gethash edge edge-poly))) 15 | (setf (gethash edge edge-poly) (list poly))) 16 | (setf (gethash `(,@edge) edge-d) d) 17 | (if (gethash poly poly-edge) 18 | (setf (gethash poly poly-edge) 19 | (cons edge (gethash poly poly-edge))) 20 | (setf (gethash poly poly-edge) (list edge)))) 21 | (values edge-poly poly-edge edge-d))) 22 | 23 | 24 | (defun pop-from-fx (l &key fx) 25 | (declare (list l) (function fx)) 26 | "get first element, e, in l where fx is t. returns (values e (l without e))" 27 | (unless l (return-from pop-from-fx (values nil nil))) 28 | (loop for v in (the list l) ; TODO: split in one pass 29 | if (and v (funcall fx v)) 30 | do (return-from pop-from-fx 31 | (values v (remove-if (lambda (c) (equal c v)) l)))) 32 | (values nil nil)) 33 | 34 | (defun pop-from-key (ht k &key fx keep) 35 | "find first element of ht[k] to match fx. pops this element (e) 36 | from ht[k] and returns (values k e)" 37 | (let ((o (gethash k ht))) 38 | (if o (veq:mvb (popped remaining) (pop-from-fx o :fx fx) 39 | (unless keep (remhash k ht)) 40 | (values k popped remaining)) 41 | (values nil nil nil)))) 42 | 43 | 44 | (defun order-poly-isects (edge-poly-ht poly-edge-ht) 45 | (declare #.*opt* (hash-table edge-poly-ht poly-edge-ht) ) 46 | "reorder (non-trivial) triangle strip constructed by the maps from 47 | edge to poly and poly to edge" 48 | (labels ((pop-first-edge () 49 | "get first key (k) from ht, and pop the first element (e) from 50 | ht[k]. returns (values k e). " 51 | (loop for k being the hash-keys of poly-edge-ht 52 | do (return-from pop-first-edge 53 | (veq:mvb (a b) 54 | (pop-from-key poly-edge-ht k :fx #'identity :keep t) 55 | (values b a))))) 56 | 57 | (pop-next-edge (fe np) 58 | (declare (list fe np)) 59 | (unless (and fe np) (return-from pop-next-edge 60 | (values nil nil nil))) 61 | (pop-from-key poly-edge-ht np 62 | :fx (lambda (c) (not (equal c fe))))) 63 | 64 | (pop-next-poly (fp ne) 65 | (declare (list fp ne)) 66 | (unless (and fp ne) (return-from pop-next-poly 67 | (values nil nil nil))) 68 | (pop-from-key edge-poly-ht ne 69 | :fx (lambda (c) (not (equal c fp))) 70 | :keep t)) 71 | 72 | (closed-loop (res) 73 | "true if the triangle strip has been closed" 74 | (let* ((lst (first (last res))) 75 | (closed (= (length (intersection (first lst) (caar res))) 76 | 2))) 77 | (values (if closed (cdr res) res) closed))) 78 | 79 | (clean-edge-from-poly (p e) 80 | (veq:mvb (edges exists) (gethash p poly-edge-ht) 81 | (when exists 82 | (let ((remaining (remove-if (lambda (e*) (equal e* e)) 83 | edges))) 84 | (when remaining 85 | (setf (gethash p poly-edge-ht) remaining)))))) 86 | 87 | (walk (fe np &key (res (list (list fe np)))) 88 | ; TODO: improve this 89 | (loop while (and fe np) 90 | do (clean-edge-from-poly np fe) 91 | (veq:mvb (fp ne) (pop-next-edge fe np) 92 | (if (and fp ne) 93 | (veq:mvb (fe* np*) (pop-next-poly fp ne) 94 | (if (and fe* np*) 95 | 96 | (progn (push (list fe* np*) res) 97 | (setf fe fe* np np*)) 98 | 99 | (progn (setf fe nil np nil) 100 | (when fe* (push (list fe* np*) res))))) 101 | 102 | (setf fe nil np nil)))) 103 | (closed-loop res)) 104 | 105 | (rec (&optional fe np &rest rest) 106 | (declare (list fe np) (ignore rest)) 107 | "recursively reconstruct the triangle strip as a list of 108 | ((edge poly) ...)" 109 | (unless (and fe np) 110 | (warn "WARNING: early termination order-poly-isects") 111 | (return-from rec (values nil nil))) 112 | 113 | (unless (= 2 (length fe)) (error "bad edge: ~a" fe)) 114 | (-verify-poly np :order-isect-rec) 115 | (veq:mvb (res closed) (walk fe np) 116 | (when closed (return-from rec (values res t))) 117 | (setf res (reverse res)) 118 | (values (walk (caar res) (cadar res) :res res) nil)))) 119 | 120 | (veq:mvc #'rec (pop-first-edge)))) 121 | 122 | (veq:fvdef* poly-isect-proj-plane (wer (:va 3 pt norm)) 123 | (declare (weir wer) (veq:ff pt norm)) 124 | "slice polys of wer with a plane (pt, norm)" 125 | (labels ((poly-edge-isect (poly &aux (res (list))) 126 | (loop for (a b) in (get-poly-edges wer poly) 127 | do (veq:mvb (isect d) 128 | (veq:f3planex norm pt (3$verts wer a b)) 129 | (when (and isect (< 0f0 d 1f0)) 130 | (push `((,a ,b) ,poly ,d) res)))) 131 | res) 132 | (do-all-intersections (&aux (res (list))) 133 | (loop for p in (get-all-polys wer) 134 | collect (loop for i in (poly-edge-isect p) 135 | do (push i res))) 136 | (-bi-list res)) 137 | (until-empty (edge-poly-ht poly-edge-ht) 138 | ; TODO: better termination criteria? 139 | (loop while (and (> (hash-table-count edge-poly-ht) 1) 140 | (> (hash-table-count poly-edge-ht) 0)) 141 | collect (veq:lst (order-poly-isects 142 | edge-poly-ht poly-edge-ht))))) 143 | ; NOTE: if the mesh is concave, there might be more than one disjoint 144 | ; cross sections 145 | ; order-poly-isects returns a list of several lists like this: 146 | ; ( ((v1 v2) (p1 p2 p3) s) ... ). each in an order 147 | ; that traces the outside of the hull(s) created by the intersection of 148 | ; existing polys and the plane (pt, norm) 149 | (veq:mvb (edge-poly-ht poly-edge-ht edge-d) (do-all-intersections) 150 | (values (until-empty edge-poly-ht poly-edge-ht) edge-d)))) 151 | 152 | -------------------------------------------------------------------------------- /src/weir/relneigh.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weir) 2 | 3 | (declaim (inline -2is-rel-neigh)) 4 | (veq:fvdef -2is-rel-neigh (verts u v near) 5 | (declare #.*opt* (veq:fvec verts) (veq:pn u v) (list near)) 6 | (loop with d of-type veq:ff = (veq:f2dst (veq:f2$ verts u v)) 7 | for w of-type veq:pn in near 8 | if (not (> (max (veq:f2dst (veq:f2$ verts u w)) 9 | (veq:f2dst (veq:f2$ verts v w))) 10 | d)) 11 | summing 1 into c of-type veq:pn 12 | ; TODO: avoid this by stripping u from near 13 | if (> c 1) do (return-from -2is-rel-neigh nil)) 14 | t) 15 | 16 | (veq:fvdef 2relneigh! (wer rad &key g (build-kd t)) 17 | (declare #.*opt* (weir wer) (veq:ff rad) (boolean build-kd)) 18 | " 19 | find the relative neigborhood graph (limited by the radius rad) of verts 20 | in wer. the graph is made in grp g. 21 | " 22 | (dimtest wer 2 relneigh!) 23 | (when build-kd (build-kdtree wer)) 24 | (let ((c 0)) 25 | (declare (veq:pn c)) 26 | (itr-verts (wer v) 27 | (loop with verts of-type veq:fvec = (weir-verts wer) 28 | with near of-type list = 29 | (to-list (remove-if (lambda (x) (declare (veq:pn x)) 30 | (= x v)) 31 | (2rad wer (2$verts wer v) rad))) 32 | ; TODO: strip u from near 33 | for u of-type veq:pn in near 34 | if (and (< u v) (-2is-rel-neigh verts u v near)) 35 | do (when (add-edge! wer u v :g g) (incf c)))) 36 | c)) 37 | 38 | -------------------------------------------------------------------------------- /src/weir/vert-utils-init.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | (defun dim-placeholder (root dim) 5 | (declare (character dim)) 6 | (labels ((repl (s dim) (intern (substitute dim #\@ 7 | (string-upcase (weird:mkstr s))) 8 | (symbol-package s)))) 9 | (cond ((symbolp root) (repl root dim)) 10 | ((atom root) root) 11 | (t (cons (dim-placeholder (car root) dim) 12 | (dim-placeholder (cdr root) dim)))))) 13 | 14 | (defmacro dimtemplate ((name &optional docs) &body body) 15 | (declare (symbol name)) 16 | (labels ((docs (exportname) (when docs `(weird::map-docstring ',exportname ,docs))) 17 | (sub (en dim) 18 | (subst dim 'dim 19 | (subst en 'fx 20 | (subst docs 'docs 21 | (dim-placeholder body (digit-char dim)))))) 22 | (sy (dim) (intern (weird:mkstr dim name) 'weir))) 23 | (let ((res (loop for dim in '(2 3) 24 | collect (let ((exportname (sy dim))) 25 | `(progn ,(docs exportname) 26 | (export ',exportname) 27 | ,@(sub exportname dim)))))) 28 | `(progn ,@res)))) 29 | 30 | -------------------------------------------------------------------------------- /src/weir/with-macro.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :weir) 3 | 4 | 5 | (defmacro with ((wer accfx &key db (mode :warn)) 6 | &body body 7 | &aux (weir-symbs (loop for sym being the external-symbols 8 | of (find-package :weir) 9 | collect sym))) 10 | (declare (symbol wer accfx)) 11 | "create context for creating and applying alterations. alterations are 12 | registered with accfx, and will be applied/resolved at the end of the context. 13 | 14 | alterations can depend on the results of other alterations. alteration names 15 | must be keywords that end in ?, eg :a?; or symbols that end in ?, provided 16 | that symbol has an assigned symbol as a value. eg: (let ((a? (gensym))) ...) 17 | 18 | ex: (weir:with (wer %) 19 | (% (2add-vert? (veq:f2 2.0 7.0) :res :a?)) ; result is named :a? 20 | (% (2move-vert? 1 (veq:f2 1.0 3.0))) 21 | (% (add-edge? 1 :a?))) 22 | 23 | it is possible to create dependency situations that cause deadlocks. 24 | use :mode values: 25 | - :warn, to warn and exit on deadlocks; 26 | - :strict, to cause error on deadlock; 27 | - :force, to use no special deadlock handling; or 28 | - t to exit silently on deadlocks. 29 | 30 | use :db t to print the generated code for all alterations. 31 | 32 | see examples/ex.lisp for a more involved example." 33 | (awg (a* a with-res incomp comp 34 | clear-alt-res alt-res alts* 35 | resolve-all resolve-once) 36 | (labels 37 | ((weir-alt-p (s) 38 | (not (not (member (intern (mkstr s) :weir) weir-symbs :test #'eq)))) 39 | (intern-as-weir-or-symb-pkg (s) 40 | (intern (mkstr s) (if (weir-alt-p s) :weir (symbol-package s)))) 41 | (handle-deadlock (&aux (msg "deadlock in weir:with. incomplete: ~a.")) 42 | (case mode 43 | ; error on deadlock 44 | (:strict `(finally (when (< ,comp 1) (error ,msg ,incomp)))) 45 | ; warn and exit on deadlock 46 | (:warn `(finally (when (< ,comp 1) (return (warn ,msg ,incomp))))) 47 | ; this will cause a deadlock unless there is special handling in the 48 | ; futures. might require further changes to defalt or with macros? 49 | (:force nil) 50 | ; exit silently on deadlock 51 | (t `(finally (when (< ,comp 1) (return nil)))))) 52 | 53 | (acc (expr &key res) 54 | (declare (optimize speed) (list expr)) 55 | (when (and res (not (future-symbp res))) 56 | (error "alteration error. invalid :res. got: ~a~%" res)) 57 | 58 | (handler-case 59 | `(,accfx 60 | (,(intern-as-weir-or-symb-pkg (car expr)) 61 | (,@(cdr expr)) :res ,res :alt-res ,alt-res :db ,db)) 62 | (error (e) (error "error when building alt:~%~a~%err: ~a" expr e)))) 63 | 64 | (rec (root) 65 | (declare (optimize speed)) 66 | (cond ((atom root) root) 67 | ((and (listp root) (eq (car root) accfx)) 68 | (apply #'acc (cdr root))) 69 | (t (cons (rec (car root)) (rec (cdr root))))))) 70 | 71 | (let ((body (rec body))) 72 | `(let ((,alt-res (weir-alt-res ,wer)) 73 | (,alts* (list))) 74 | (declare (hash-table ,alt-res) (list ,alts*)) 75 | (labels ((,accfx (,a) (declare #.*opt*) 76 | (let ((,a* ,a)) 77 | (typecase ,a* (function (push ,a* ,alts*))))) 78 | (,clear-alt-res () (declare #.*opt*) (clrhash ,alt-res)) 79 | (,resolve-once () 80 | (declare #.*opt*) 81 | (loop for ,a in ,alts* 82 | if (not (funcall (the function ,a) ,wer)) 83 | collect ,a of-type function 84 | and summing 1 into ,incomp of-type fixnum 85 | else summing 1 into ,comp of-type fixnum 86 | ,@(handle-deadlock))) 87 | (,resolve-all () 88 | (declare #.*opt*) 89 | (loop until (not ,alts*) do (setf ,alts* (,resolve-once))))) 90 | (let ((,with-res (progn ,@body))) 91 | (,clear-alt-res) 92 | (,resolve-all) 93 | ,with-res))))))) 94 | 95 | -------------------------------------------------------------------------------- /test/3weir.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weird-tests) 2 | 3 | (plan 3) 4 | 5 | (veq:vprogn 6 | (subtest "weir3" 7 | (let ((wer (weir:make :dim 3))) 8 | 9 | (is (weir:3add-vert! wer 0f0 0f0 3f0) 0) 10 | (is (weir:3add-vert! wer 10f0 0f0 4f0) 1) 11 | (is (weir:3add-vert! wer 3f0 3f0 1f0) 2) 12 | (is (weir:3add-vert! wer 4f0 3f0 4f0) 3) 13 | (is (weir:3add-vert! wer 7f0 200f0 1f0) 4) 14 | (is (weir:3add-vert! wer 2f0 10f0 4f0) 5) 15 | (is (weir:3get-vert wer 2) 3f0 3f0 1f0) 16 | (is (weir:ladd-edge! wer '(0 1)) (list 0 1)) 17 | (is (weir:3ledge-length wer '(0 1)) 10.04987562112089f0) 18 | (is (weir:3move-vert! wer 3 1f0 3f0 3f0) 5f0 6f0 7f0) 19 | (is (weir:3move-vert! wer 4 0.5f0 0.6f0 1f0 :rel t) 20 | 7.5f0 ))) 21 | 22 | 23 | (subtest "weir 3 with" 24 | (let ((wer (weir:make :dim 3))) 25 | 26 | (weir:with (wer %) 27 | (% (3add-vert? (veq:f3 11f0 3f0 9f0))) 28 | (list 4.5 29 | (% (3move-vert? 0 (veq:f3 1f0 0f0 9f0))) 30 | nil t 31 | (list 5 (% (3add-vert? (veq:f3 12f0 3f0 3f0))) 32 | (% (3add-vert? (veq:f3 13f0 3f0 2f0)))) 33 | (list nil) 34 | (list (list)))) 35 | 36 | (is (weir:get-num-verts wer) 3)) 37 | 38 | (let ((wer (weir:make :dim 3))) 39 | 40 | (weir:with (wer %) 41 | (list) 42 | 1 nil 43 | (% (3add-vert? (veq:f3 12f0 3f0 2f0))) 44 | (% (3add-vert? (veq:f3 13f0 6f0 3f0))) 45 | (% (3add-vert? (veq:f3 13f0 3f0 3f0)))) 46 | 47 | (weir:with (wer %) 48 | (% (add-edge? 1 2)) 49 | (% (add-edge? 0 1))) 50 | 51 | (is (weir:edge-exists wer '(0 1)) t) 52 | (is (weir:3get-vert wer 2) 12f0 3f0 2f0) 53 | (is (weir:3get-vert wer 0) 13f0 3f0 3f0) 54 | (is (weir:edge-exists wer '(1 2)) t) 55 | (is (weir:edge-exists wer '(7 2)) nil))) 56 | 57 | 58 | (subtest "weir 3 split" 59 | (let ((wer (weir:make :dim 3))) 60 | 61 | (weir:3add-vert! wer 0f0 3f0 6f0) 62 | (weir:3add-vert! wer 1f0 4f0 7f0) 63 | (weir:3add-vert! wer 2f0 5f0 8f0) 64 | (weir:add-edge! wer 0 1) 65 | (weir:add-edge! wer 1 2) 66 | (weir:add-edge! wer 2 0) 67 | 68 | (weir:with (wer %) 69 | (% (3split-edge? 0 1 (veq:f3 30f0 20f0 3f0)) :res :a?) 70 | (% (3lsplit-edge? '(1 2) (veq:f3 31f0 23f0 4f0)) :res :b?) 71 | (% (3lsplit-edge? '(2 1) (veq:f3 32f0 24f0 5f0)) :res :c?)) 72 | 73 | (is (flatten-ht (weir:get-alteration-result-map wer)) 74 | '(:C? 3 :B? :A? 4)) 75 | (is (veq:lst (weir:3get-vert wer 3)) '(32f0 24f0 5f0))))) 76 | 77 | (unless (finalize) (error "error in weir 3d tests")) 78 | 79 | -------------------------------------------------------------------------------- /test/bzspl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weird-tests) 3 | 4 | (plan 1) 5 | 6 | (subtest "bzspl" 7 | 8 | (let ((pts-a (veq:f$_ `((-20.0f0 99.0f0) (0.0f0 1.0f0) (10.0f0 20.0f0) 9 | (100.0f0 100.0f0)))) 10 | (pts-b (veq:f$_ `((-20.0f0 99.0f0) (0.0f0 1.0f0) (10.0f0 20.0f0) 11 | (100.0f0 100.0f0) (-3.0f0 -17.0f0) (0.0f0 4.0f0)))) 12 | (pts-c (veq:f$_ `((-32.0f0 79.0f0) (0.3f0 3.0f0) (10.1f0 25.0f0))))) 13 | (is (bzspl:pos* (bzspl:make pts-c) (math:linspace 5 0f0 1f0)) 14 | (veq:f$_ `((-32.0f0 79.0f0) (-17.256249999999998f0 47.125f0) 15 | (-5.324999999999999f0 27.5f0) (3.7937499999999993f0 20.125f0) 16 | (10.1f0 25.0f0))) 17 | :test #'equalp) 18 | 19 | (is (bzspl:pos* (bzspl:make pts-c :closed t) (math:linspace 5 0f0 1f0)) 20 | #(-15.85 41.0 2.0468752 11.5625 3.6125004 29.0 -19.15 61.4375 -15.85 41.0) 21 | :test #'equalp) 22 | 23 | (is (bzspl:pos* (bzspl:make pts-a) (math:linspace 10 0f0 1f0)) 24 | #(-20.0 99.0 -11.851851 60.75309 -5.185185 33.12346 2.3841858e-7 16.11111 25 | 3.7037039 9.716048 7.1604953 13.481483 17.77778 24.666668 26 | 36.790127 42.81482 64.19753 67.92593 100.0 100.0) 27 | :test #'equalp) 28 | 29 | (is (bzspl:pos* (bzspl:make pts-b) (math:linspace 10 0f0 1f0)) 30 | #(-20.0 99.0 -5.185185 33.12346 3.7037039 9.716048 12.777779 20.222223 31 | 36.97531 43.728394 70.23457 72.91358 72.11111 69.55556 37.72839 32 | 29.481476 8.098764 1.0370363 0.0 4.0) 33 | :test #'equalp) 34 | 35 | (is (bzspl:pos* (bzspl:make pts-a :closed t) (math:linspace 10 0f0 1f0)) 36 | #(-10.0 50.0 -2.0987654 18.0 3.8271606 9.111111 12.777779 20.222223 37 | 36.97531 43.728394 69.81482 75.77778 68.33333 95.33334 27.530859 38 | 98.79012 -5.0617294 83.9753 -10.0 50.0) 39 | :test #'equalp) 40 | 41 | (is (bzspl:pos* (bzspl:make pts-b :closed t) (math:linspace 10 0f0 1f0)) 42 | #(-10.0 50.0 1.1111113 10.666667 12.777779 20.222223 55.0 60.0 72.11111 43 | 69.55556 20.055546 10.166655 -1.5 -6.5 -4.611115 23.944466 44 | -14.444447 72.44444 -10.0 50.0) 45 | :test #'equalp) 46 | 47 | ; (is 48 | ; (bzspl:adaptive-pos (bzspl:make ((0f0 0f0) 49 | ; (1f0 2f0) 50 | ; (-3f0 5f0)))) 51 | ; ((0.0f0 0.0f0) 52 | ; (0.18643209278419098f0 1.0719185917278686f0) 53 | ; (-0.09541948616495921f0 1.9685997925944037f0) 54 | ; (-0.8581716831302144f0 3.0757985486108788f0) 55 | ; (-1.530471900097555f0 3.7746049937079564f0) 56 | ; (-3.0f0 5.0f0))) 57 | 58 | ; (is 59 | ; (bzspl:adaptive-pos (bzspl:make ((0f0 0f0) 60 | ; (1f0 2f0) 61 | ; (-3f0 5f0)) 62 | ; :closed t)) 63 | ; ((0.5f0 1.0f0) 64 | ; (0.34369428112685496f0 2.1756813817990692f0) 65 | ; (-0.3661101319802346f0 2.980843763395622f0) 66 | ; (-1.9897280476541732f0 4.061850847855913f0) 67 | ; (-2.087899364481774f0 3.648441004667016f0) 68 | ; (-0.907456391822953f0 1.5952742657912453f0) 69 | ; (-0.16395699030197697f0 0.8157890863508436f0) 70 | ; (0.5f0 1.0f0))) 71 | ; (is (bzspl:len (bzspl:make pts-a)) 225.04803388452214f0) 72 | ; (is (bzspl:len (bzspl:make pts-a :closed t)) 275.04416436128014f0) 73 | )) 74 | 75 | (unless (finalize) (error "error in bzspl tests")) 76 | 77 | -------------------------------------------------------------------------------- /test/graph.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weird-tests) 2 | 3 | (plan 1) 4 | 5 | (subtest "graph" () 6 | 7 | (let ((grph (graph:make))) 8 | 9 | (is (graph:add grph 1 1) t) 10 | (is (graph:add grph 1 2) t) 11 | (is (graph:add grph 1 2) nil) 12 | (is (graph:add grph 2 1) nil) 13 | (is (graph:get-num-edges grph) 2) 14 | (is (graph:get-edges grph) '((1 2))) 15 | (is (graph:add grph 20 5) t) 16 | (is (graph:get-edges grph) '((5 20) (1 2))) 17 | (is (graph:del grph 1 2) t) 18 | (is (graph:del grph 1 2) nil) 19 | (is (graph:get-edges grph) '((5 20))) 20 | (is (graph:get-num-edges grph) 2) 21 | (is (graph:mem grph 1 4) nil) 22 | (is (graph:mem grph 1 1) t) 23 | (is (sort (graph:get-verts grph) #'<) '(1 5 20)) 24 | (is (graph:del grph 1 1) t) 25 | (is (graph:get-edges grph) '((5 20))) 26 | (is (sort (graph:get-verts grph) #'<) '(5 20)) 27 | (is (graph:del grph 5 20) t) 28 | (is (sort (graph:get-verts grph) #'<) nil)) 29 | 30 | (is (graph:edge-set->path '((3 4) (4 5) (5 6) (1 2) (2 3))) 31 | '(1 2 3 4 5 6) ) 32 | (is (graph:edge-set->path '((1 2))) '(1 2)) 33 | (is (graph:edge-set->path '()) nil) 34 | (is (graph:edge-set->path '((3 4) (4 5))) '(3 4 5)) 35 | 36 | (let ((grph (graph:make))) 37 | ; ensure that mutating one graph does not effect the other 38 | (graph:add grph 2 1) 39 | (graph:add grph 3 2) 40 | (graph:add grph 4 1) 41 | 42 | (let ((new-grph (graph:copy grph))) 43 | (graph:del new-grph 1 4) 44 | 45 | (is (length (graph:get-edges grph)) 3) 46 | (is (length (graph:get-edges new-grph)) 2))) 47 | 48 | (let ((grph (graph:make))) 49 | (graph:add grph 0 1) 50 | (graph:add grph 3 2) 51 | (graph:add grph 1 3) 52 | (graph:add grph 0 3) 53 | (graph:add grph 1 4) 54 | (graph:add grph 4 5) 55 | (graph:add grph 5 6) 56 | 57 | (is (length (graph:get-edges (graph:del-simple-filaments grph))) 3))) 58 | 59 | 60 | (unless (finalize) (error "error in graph tests")) 61 | -------------------------------------------------------------------------------- /test/hset.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weird-tests) 2 | 3 | (plan 1) 4 | 5 | (subtest "hset" () 6 | 7 | (let ((hs (hset:make))) 8 | 9 | (is (hset:add hs 1) t) 10 | (is (hset:add hs 1) nil) 11 | (is (hset:add hs 20) t) 12 | (is (hset:add hs 40) t) 13 | (is (hset:add hs 73) t) 14 | (is (hset:num hs) 4) 15 | (is (hset:del hs 1) t) 16 | (is (hset:del hs 1) nil) 17 | (is (hset:mem hs 40) t) 18 | (is (hset:mem* hs (list 40 88)) (list t nil)) 19 | (is (sort (hset:to-list hs) #'<) (list 20 40 73))) 20 | 21 | (let ((hs (hset:make :init (list 1 2 3)))) 22 | (is (hset:to-list hs) (list 1 2 3)))) 23 | 24 | (unless (finalize) (error "error in hset tests")) 25 | -------------------------------------------------------------------------------- /test/math.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:weird-tests) 2 | 3 | (plan 1) 4 | 5 | (subtest "math" () 6 | 7 | (is (math:imod 20 3 21) 2) 8 | (is (math:linspace 1 0f0 10f0) (list 0.0)) 9 | (is (math:linspace 3 0f0 10f0) (list 0.0 5.0 10.0)) 10 | (is (math:linspace 2 0f0 10f0 :end nil) (list 0.0 5.0)) 11 | (is (math:linspace 2 0f0 10f0 :end t) (list 0.0 10.0)) 12 | (is (math:range 2 5) (list 2 3 4)) 13 | (is (math:range 5) (list 0 1 2 3 4))) 14 | 15 | (unless (finalize) (error "error in math tests")) 16 | -------------------------------------------------------------------------------- /test/ortho.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weird-tests) 3 | 4 | (plan 1) 5 | 6 | (subtest "ortho" 7 | 8 | (let ((proj (ortho:make :xy (veq:f2$point 500f0 500f0) 9 | :cam (veq:f3$point 731f0 1003f0 -1000f0) 10 | :look (veq:f3$point 43f0 23f0 -10f0)))) 11 | (is (veq:lst (ortho:project proj -33f0 100f0 -100f0)) 12 | '(606.4451 557.0312 1481.3955)) 13 | 14 | (ortho:update proj :cam (veq:f3$point 731f0 1003f0 -1001f0)) 15 | 16 | (is (veq:lst (ortho:project proj -33f0 100f0 -100f0)) 17 | '(606.4451 556.2605 1482.0327)))) 18 | 19 | 20 | (unless (finalize) (error "error in ortho tests")) 21 | 22 | -------------------------------------------------------------------------------- /test/rnd.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weird-tests) 3 | 4 | (plan 1) 5 | 6 | (veq:vprogn 7 | 8 | (subtest "rnd" () 9 | 10 | (rnd:set-rnd-state 1) 11 | 12 | (is (length (rnd:rndspace 10 0f0 10f0)) 10) 13 | 14 | (is (rnd:rndspace 10 0f0 10f0) 15 | '(1.8467712 7.931614 3.7252033 7.7582145 6.9112134 3.3949196 7.9353485 16 | 8.710781 0.7763338 6.926218)) 17 | 18 | (is (rnd:rndspace 10 0f0 10f0 :order t) 19 | '(0.49096227 0.5477512 0.6882775 3.7043893 4.0890446 4.5915437 20 | 6.2654696 7.5623474 8.383889 8.869057)) 21 | 22 | (is (rnd:rndspacei 10 0 10) '(2 4 7 7 9 1 7 0 6 9)) 23 | (is (rnd:rndspacei 10 0 10 :order t) '(0 1 1 3 6 7 8 8 9 9)) 24 | 25 | (is (length (rnd:nrndi 9 4)) 9) 26 | (is (length (rnd:nrnd 11 4f0)) 11) 27 | (is (length (rnd:nrnd 12 4f0)) 12) 28 | (is (length (rnd:nrnd* 12 4f0)) 12) 29 | 30 | (is (rnd:bernoulli 4 0.5f0) '(1.0 1.0 1.0 0.0)) 31 | 32 | (is (veq:lst (rnd:2on-line 101f0 204f0 433f0 454f0)) '(241.52104 309.81403)) 33 | (is (veq:lst (veq:f2+ 303f0 73f0 (rnd:2on-circ 303f0))) '(433.55383 -200.43134)) 34 | (is (veq:lst (veq:f2+ 303f0 73f0 (rnd:2in-circ 303f0))) '(441.35565 -43.934296)) 35 | 36 | (is (rnd:2non-line 5 101f0 204f0 433f0 454f0) 37 | #(427.40457 449.78656 157.03436 246.19455 136.4327 230.68124 144.76556 38 | 236.95601 150.21408 241.0588) 39 | :test #'equalp) 40 | 41 | (is (f2!@$+ (rnd:2nin-circ 5 20f0) 433f0 454f0 ) 42 | #(433.9736 448.2122 439.11932 471.20563 434.0098 443.6098 424.3462 43 | 457.24042 447.47418 462.05017) 44 | :test #'equalp) 45 | 46 | (is (rnd:nrnd* 10 2f0) 47 | '(-1.599505 0.44479895 -1.9444766 -1.3134341 1.6751962 1.6003728 -0.12388039 48 | 1.7128291 1.6372342 0.6896429)))) 49 | 50 | 51 | (unless (finalize) (error "error in rnd tests")) 52 | -------------------------------------------------------------------------------- /test/run.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:weird-tests (:use #:cl #:prove) (:export #:run-tests)) 3 | (in-package #:weird-tests) 4 | 5 | (setf prove:*enable-colors* nil) 6 | 7 | (defvar *files* `(#P"test/rnd.lisp" #P"test/math.lisp" #P"test/hset.lisp" 8 | #P"test/bzspl.lisp" #P"test/graph.lisp" #P"test/weir.lisp" 9 | #P"test/3weir.lisp" #P"test/weir-grp-prop.lisp" 10 | #P"test/weir-with.lisp" #P"test/ortho.lisp")) 11 | 12 | (defun run-tests () 13 | (loop with fails = 0 14 | for f in *files* 15 | do (format t "~&~%starting tests in: ~a~%" (weird:mkstr f)) 16 | (unless (prove:run f :reporter :fiveam) 17 | (incf fails)) 18 | (format t "~&done: ~a~%" (weird:mkstr f)) 19 | finally (return (unless (< fails 1) 20 | (sb-ext:quit :unix-status 7))))) 21 | 22 | -------------------------------------------------------------------------------- /test/weir-grp-prop.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weird-tests) 3 | (plan 2) 4 | 5 | (subtest "test-weir-grp " 6 | (let ((wer (weir:make :max-verts 22 :adj-size 30))) 7 | 8 | (let ((g1 (weir:add-grp! wer)) 9 | (g2 (weir:add-grp! wer)) 10 | (g3 (weir:add-grp! wer))) 11 | (weir:2add-vert! wer 100f0 200f0) 12 | (weir:2add-vert! wer 200f0 300f0) 13 | (weir:2add-vert! wer 300f0 400f0) 14 | (weir:2add-vert! wer 400f0 500f0) 15 | (weir:2add-vert! wer 600f0 700f0) 16 | (weir:2add-vert! wer 700f0 800f0) 17 | (weir:2add-vert! wer 800f0 900f0) 18 | (weir:2add-vert! wer 500f0 600f0) 19 | (weir:2add-vert! wer 900f0 600f0) 20 | 21 | (weir:ladd-edge! wer '(1 2) :g g1) 22 | (weir:ladd-edge! wer '(1 2)) 23 | (weir:ladd-edge! wer '(1 2) :g g2) 24 | (weir:ladd-edge! wer '(3 2) :g g2) 25 | (weir:ladd-edge! wer '(1 5) :g g3) 26 | 27 | (is (sort (weir:itr-grp-verts (wer i :g g2 :collect t) i) #'<) 28 | '(1 2 3)) 29 | 30 | (is (sort (weir:itr-grp-verts (wer i :g nil :collect t) i) #'<) 31 | '(1 2)) 32 | 33 | (is (sort (alexandria:flatten 34 | (weir:itr-edges (wer e :g g1 :collect t) e)) #'<) 35 | '(1 2)) 36 | 37 | (is (sort (weir:get-vert-inds wer :g g1) #'<) '(1 2)) 38 | 39 | (is (sort (weir:get-vert-inds wer :g g3) #'<) '(1 5)) 40 | 41 | (is (length (weir:get-vert-inds wer)) 2) 42 | 43 | (is (length (weir:itr-grps (wer g :collect t) g)) 3)))) 44 | 45 | ; (defun "test-weir-loop " 46 | ; (let ((wer (weir:make))) 47 | ; (weir:add-path! wer (list (vec:vec 0f0 0f0) (vec:vec 10f0 0f0) 48 | ; (vec:vec 10f0 10f0) (vec:vec 0f0 10f0)) 49 | ; :closed t) 50 | 51 | ; (is (weir:get-west-most-vert wer) 0) 52 | 53 | ; (weir:add-path! wer (list (vec:vec -10f0 -1f0) (vec:vec 10f0 10f0))) 54 | 55 | ; (is (weir:get-west-most-vert wer) 4)) 56 | 57 | ; (let ((wer (weir:make))) 58 | ; (weir:2add-verts! wer (list (vec:vec 0f0 0f0) (vec:vec 1f0 0f0) 59 | ; (vec:vec 1f0 -1f0) (vec:vec 1f0 1f0))) 60 | 61 | ; (weir:add-edge! wer 0 1) 62 | ; (weir:add-edge! wer 0 2) 63 | ; (weir:add-edge! wer 0 3) 64 | 65 | ; (is (weir:get-incident-rotated-vert wer 0 :dir :cw) 2) 66 | ; (is (weir:get-incident-rotated-vert wer 0 :dir :ccw) 3)) 67 | 68 | ; (let ((wer (weir:make))) 69 | ; (weir:2add-verts! wer (bzspl:adaptive-pos 70 | ; (bzspl:make (rnd:nin-circ 10 100f0)) 71 | ; :lim 1f0)) 72 | 73 | ; (is (weir:get-num-verts wer) 95) 74 | 75 | ; (is (weir:get-num-edges wer) 0) 76 | 77 | ; (weir:relative-neighborhood! wer 500f0) 78 | 79 | ; (is (weir:get-num-edges wer) 105) 80 | 81 | ; (weir:add-path! wer (vec:polygon 4 20f0)) 82 | 83 | ; (weir:add-path! wer (vec:polygon 4 20f0) :closed t) 84 | 85 | ; (is (weir:get-planar-cycles wer) 86 | ; `((56 43 44 45 46 47 48 49 50 51 52 53 54 55 56) (60 87 86 85 60) 87 | ; (18 89 62 61 88 87 60 84 16 83 17 18) 88 | ; (11 12 13 14 15 16 84 60 85 59 58 57 42 41 40 39 11) (91 66 65 64 90 20 21 91) 89 | ; (80 92 69 68 67 91 21 22 23 24 80) (101 102 99 100 101) 90 | ; (25 24 23 22 21 20 90 19 89 18 17 83 16 15 14 13 12 11 10 9 8 7 6 5 4 3 25) 91 | ; (1 80 24 25 2 1) (0 71 70 92 80 1 79 0) 92 | ; (30 29 28 27 26 2 25 3 4 5 6 37 36 35 34 33 32 31 30) 93 | ; (75 74 73 72 0 78 77 76 75))) 94 | 95 | ; (is (weir:get-segments wer :cycle-info nil) 96 | ; '((0 71) (0 72) (0 78 77 76 75 74 73 72) (0 79 1) (1 2) (1 80) 97 | ; (2 25) (2 26 27 28 29 30 31 32 33 34 35 36 37 6) (6 5 4 3 25) 98 | ; (6 7 8 9 10) (10 11) (10 38) (11 12 13 14 15 16) (11 39 40 41 42) 99 | ; (16 83 17 18 89) (16 84 60) (20 21) (20 82) (20 90) (21 22) (21 91) 100 | ; (22 23 24) (22 81) (24 25) (24 80) (42 56) (42 57 58 59 85) 101 | ; (56 43 44 45 46 47 48 49 50 51 52 53 54 55 56) (60 85) (60 87) 102 | ; (63 89) (71 70 92) (71 93) (72 94) (80 92) (85 86 87) (87 88 61 62 89) 103 | ; (89 19 90) (90 64 65 66 91) (91 67 68 69 92) 104 | ; (95 96 97 98) (99 102 101 100 99))))) 105 | 106 | (subtest "test-weir-prop " 107 | (let ((wer (weir:make))) 108 | (weir:2add-path! wer (rnd:2nin-circ 5 400f0)) 109 | (setf (weir:get-vert-prop wer 1 :a) 2) 110 | (setf (weir:get-vert-prop wer 1 :a) 4) 111 | (setf (weir:get-vert-prop wer 1 :b) 3) 112 | (setf (weir:get-edge-prop wer '(1 2) :b) 2888) 113 | (setf (weir:get-edge-prop wer '(0 1) :b) 2887) 114 | (setf (weir:get-edge-prop wer '(2 3) :a) 2888) 115 | (setf (weir:get-edge-prop wer '(3 4) :b) 2888) 116 | 117 | (is (weir:get-edge-prop wer '(0 1) :b) 2887) 118 | (is (weir:get-edge-prop wer '(1 2) :b) 2888) 119 | (is (weir:get-edge-prop wer '(1 3) :b) nil) 120 | (is (weir:get-vert-prop wer 1 :b) 3) 121 | (is (weir:vert-has-prop wer 1 :b :val 3) t) 122 | (is (weir:get-edges-with-prop wer :b :val 2888) '((3 4) (1 2))) 123 | 124 | (is (weir:get-edge-props wer '(1 2)) '((:B . 2888))) 125 | (weir:copy-edge-props wer '(2 3) '(1 2)) 126 | (is (weir:get-edge-props wer '(1 2)) '((:A . 2888) (:B . 2888))) 127 | 128 | (is (weir:get-vert-props wer 2) nil) 129 | (weir:copy-vert-props wer 1 2) 130 | (is (weir:get-vert-props wer 2) '((:B . 3) (:A . 4) (:A . 2)))) 131 | 132 | (let ((wer (weir:make))) 133 | (weir:mset-edge-prop wer 134 | (weir:2add-path! wer 135 | (veq:f$_ '((1f0 2f0) (2f0 3f0) (4f0 5f0))) :closed t) 136 | :path) 137 | 138 | (is (veq:lst (weir:edge-prop->path wer :path)) '((2 0 1) T)) 139 | 140 | (veq:vprogn 141 | (weir:with (wer %) 142 | (% (2split-edge? 0 1 (veq:f2 1f0 2f0)) :res :a?) 143 | (% (mcopy-edge-props? '(0 1) (list (list 0 :a?) (list 1 :a?))))) 144 | 145 | (is (veq:lst (weir:edge-prop->path wer :path)) '((2 0 3 1) T))))) 146 | 147 | (unless (finalize) (error "error in weir-grp-prop tests")) 148 | 149 | -------------------------------------------------------------------------------- /test/weir.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:weird-tests) 3 | 4 | (plan 5) 5 | 6 | (defun sort-a-list (a) 7 | (sort a #'string-lessp :key #'(lambda (x) (string (first x))))) 8 | 9 | (defun flatten-ht (ht) 10 | (alexandria:flatten 11 | (loop for k being the hash-keys of ht using (hash-value v) 12 | collect (list k v)))) 13 | 14 | (veq:vprogn 15 | 16 | (subtest "weir" 17 | (let ((wer (weir:make))) 18 | 19 | (is (weir:2add-vert! wer 0f0 0f0) 0) 20 | (is (weir:2add-vert! wer 10f0 0f0) 1) 21 | (is (weir:2add-vert! wer 3f0 3f0) 2) 22 | (is (weir:2add-vert! wer 4f0 3f0) 3) 23 | (is (weir:2add-vert! wer 7f0 200f0) 4) 24 | (is (weir:2add-vert! wer 2f0 10f0) 5) 25 | (is (weir:2add-vert! wer 4f0 11f0) 6) 26 | (is (weir:2add-vert! wer 3f0 10f0) 7) 27 | (is (weir:2add-vert! wer 0f0 0.5f0) 8) 28 | (is (weir:2add-vert! wer 2f0 1.0f0) 9) 29 | (is (weir:2add-vert! wer 3.0f0 10f0) 10) 30 | (is (weir:ladd-edge! wer '(0 0)) nil) 31 | (is (weir:ladd-edge! wer '(0 2)) '(0 2)) 32 | (is (weir:ladd-edge! wer '(0 1)) '(0 1)) 33 | (is (weir:ladd-edge! wer '(5 0)) '(0 5)) 34 | (is (weir:ladd-edge! wer '(1 0)) nil) 35 | (is (weir:ladd-edge! wer '(5 0)) nil) 36 | (is (weir:ladd-edge! wer '(0 2)) nil) 37 | (is (weir:add-edge! wer 5 2) '(2 5)) 38 | (is (weir:add-edge! wer 4 1) '(1 4)) 39 | (is (weir:ladd-edge! wer '(4 0)) '(0 4)) 40 | (is (weir:ladd-edge! wer '(5 1)) '(1 5)) 41 | (is (weir:ladd-edge! wer '(9 9)) nil) 42 | (is (weir:ladd-edge! wer '(3 9)) '(3 9)) 43 | (is (weir:ladd-edge! wer '(0 1)) nil) 44 | (is (weir:ladd-edge! wer '(0 4)) nil) 45 | (is (weir:ladd-edge! wer '(10 9)) '(9 10)) 46 | (is (weir:edge-exists wer '(0 2)) t) 47 | (is (weir:edge-exists wer '(5 0)) t) 48 | (is (weir:edge-exists wer '(9 2)) nil) 49 | (is (weir:edge-exists wer '(2 2)) nil) 50 | (is (veq:lst (weir:2get-vert wer 2)) '(3f0 3.0f0)) 51 | (is (weir:2add-vert! wer 0f0 1f0) 11) 52 | (is (weir:ladd-edge! wer '(0 1)) nil) 53 | (is (weir:2add-vert! wer 0f0 7f0) 12) 54 | (is (weir:2ledge-length wer '(0 4)) 200.12246250733574f0) 55 | (is (weir:2edge-length wer 2 5) 7.0710678118654755f0) 56 | (is (weir:2ledge-length wer '(1 2)) 7.615773105863909f0) 57 | (is (veq:lst (weir:2move-vert! wer 3 1f0 3f0)) '(5f0 6f0)) 58 | (is (veq:lst (weir:2move-vert! wer 3 0.5f0 0.6f0 :rel t)) '(5.5f0 6.6f0)) 59 | (is (weir:2get-vert wer 3) 5.5f0 6.6f0))) 60 | 61 | (subtest "test-weir-2 " 62 | 63 | (let ((wer (weir:make))) 64 | 65 | (is (weir:2add-vert! wer 0f0 0f0) 0) 66 | (is (weir:2add-vert! wer 20f0 20f0) 1) 67 | (is (weir:2add-vert! wer 30f0 30f0) 2) 68 | (is (weir:2add-vert! wer 40f0 40f0) 3) 69 | (is (weir:ladd-edge! wer '(0 1)) '(0 1)) 70 | (is (weir:ladd-edge! wer '(1 2)) '(1 2)) 71 | (is (weir:ladd-edge! wer '(2 3)) '(2 3)) 72 | (is (weir:ladd-edge! wer '(3 1)) '(1 3)) 73 | (is (weir:get-edges wer) '((2 3) (1 3) (1 2) (0 1))) 74 | (is (weir:del-edge! wer 0 1) t) 75 | (is (weir:ldel-edge! wer '(0 1)) nil) 76 | (is (weir:ldel-edge! wer '(3 2)) t) 77 | (is (weir:ldel-edge! wer '(1 2)) t) 78 | (is (weir:2lsplit-edge! wer '(1 2) 1f0 2f0) nil) 79 | (is (weir:2lsplit-edge! wer '(3 1) 1f0 2f0) 4) 80 | (is (weir:get-num-edges wer) 2) 81 | (is (weir:get-num-verts wer) 5))) 82 | 83 | 84 | (subtest "test-weir-3 " 85 | (let ((wer (weir:make))) 86 | (is (weir:2add-vert! wer 10f0 10f0) 0) 87 | (is (weir:2add-vert! wer 20f0 10f0) 1) 88 | (is (weir:2add-vert! wer 30f0 10f0) 2) 89 | (is (weir:2add-vert! wer 40f0 10f0) 3) 90 | (is (weir:ladd-edge! wer '(0 1)) '(0 1)) 91 | (is (weir:ladd-edge! wer '(1 2)) '(1 2)) 92 | (is (weir:ladd-edge! wer '(2 3)) '(2 3)) 93 | (is (weir:ladd-edge! wer '(2 3)) nil)) 94 | 95 | (let ((wer (weir:make :max-verts 12))) 96 | (weir:2add-path! wer (veq:f$_ '((0f0 10f0) (1f0 20f0) (2f0 30f0) ))) 97 | (weir:2add-path! wer (veq:f$_ '((7f0 11f0) (8f0 21f0) (9f0 31f0) )) :closed t) 98 | (weir:2add-path! wer (veq:f$_ '((17f0 13f0) (18f0 23f0) (19f0 33f0) ))) 99 | (is (weir:2get-all-verts wer) 100 | #(0.0 10.0 1.0 20.0 2.0 30.0 7.0 11.0 8.0 21.0 9.0 31.0 17.0 13.0 101 | 18.0 23.0 19.0 33.0) 102 | :test #'equalp) 103 | (is (weir:get-edges wer) '((7 8) (6 7) (4 5) (3 4) (3 5) (1 2) (0 1))) 104 | 105 | (is (loop for lp in (weir:2walk-graph wer) 106 | collect (weir:2gvs wer lp)) 107 | `(#(17.0 13.0 18.0 23.0 19.0 33.0) 108 | #(9.0 31.0 7.0 11.0 8.0 21.0 9.0 31.0) 109 | #(0.0 10.0 1.0 20.0 2.0 30.0)) 110 | :test #'equalp))) 111 | 112 | 113 | (defun init-weir () 114 | (let ((wer (weir:make :max-verts 16))) 115 | (weir:2add-vert! wer 0f0 2f0) ;0 116 | (weir:2add-vert! wer 2f0 3f0) ;1 117 | (weir:2add-vert! wer 3f0 4f0) ;2 118 | (weir:2add-vert! wer 4f0 7f0) ;3 119 | (weir:2add-vert! wer 5f0 4f0) ;4 120 | (weir:2add-vert! wer 0f0 6f0) ;5 121 | (weir:2add-vert! wer -1f0 7f0) ;6 122 | (weir:2add-vert! wer 0f0 8f0) ;7 123 | (weir:2add-vert! wer 0f0 9f0) ;8 124 | (weir:2add-vert! wer 10f0 1f0) ;9 125 | (weir:2add-vert! wer 3f0 1f0) ;10 126 | 127 | (weir:ladd-edge! wer '(1 2)) 128 | (weir:ladd-edge! wer '(0 1)) 129 | (weir:ladd-edge! wer '(3 1)) 130 | (weir:ladd-edge! wer '(5 6)) 131 | (weir:ladd-edge! wer '(7 3)) 132 | wer)) 133 | 134 | 135 | (subtest "test-weir-incident " 136 | (let ((wer (init-weir))) 137 | (is (weir:get-incident-edges wer 1) 138 | '((1 2) (0 1) (1 3))) 139 | (is (weir:get-incident-edges wer 100) nil))) 140 | 141 | (subtest "add-verts" 142 | (let ((wer (init-weir))) 143 | (weir:2add-verts! wer (veq:f2$polygon 3 100f0))) 144 | 145 | (let ((wer (init-weir))) 146 | (weir:2add-verts! wer (veq:f2$polygon 3 100f0)) 147 | (is (weir:2gvs wer (math:range 0 14)) 148 | #(0.0 2.0 2.0 3.0 3.0 4.0 4.0 7.0 5.0 4.0 0.0 6.0 -1.0 7.0 0.0 8.0 149 | 0.0 9.0 10.0 1.0 3.0 1.0 100.0 0.0 -50.000008 86.60254 -49.999992 150 | -86.60255) 151 | :test #'equalp)))) 152 | 153 | (unless (finalize) (error "error in weir tests")) 154 | 155 | -------------------------------------------------------------------------------- /weird.asd: -------------------------------------------------------------------------------- 1 | 2 | 3 | (asdf:defsystem #:weird 4 | :description "A System for Making Generative Systems" 5 | :version "7.1.0" 6 | :author "anders hoff/inconvergent" 7 | :licence "MIT" 8 | :in-order-to ((asdf:test-op (asdf:test-op #:weird/tests))) 9 | :pathname "src/" 10 | :serial nil 11 | :depends-on (#:veq #:lparallel #:alexandria 12 | #:cl-json #:cl-svg #:zpng) 13 | :components ((:file "packages") 14 | (:file "init" :depends-on ("packages")) 15 | (:file "config" :depends-on ("init")) 16 | (:file "utils" :depends-on ("config")) 17 | (:file "parallel/main" :depends-on ("utils")) 18 | (:file "dat" :depends-on ("utils")) 19 | (:file "docs" :depends-on ("dat")) 20 | (:file "state" :depends-on ("utils")) 21 | (:file "hset" :depends-on ("utils")) 22 | (:file "math" :depends-on ("utils")) 23 | (:file "rnd/macros" :depends-on ("utils")) 24 | (:file "rnd/rnd" :depends-on ("rnd/macros")) 25 | (:file "rnd/2rnd" :depends-on ("rnd/rnd")) 26 | (:file "rnd/3rnd" :depends-on ("rnd/rnd")) 27 | (:file "rnd/walkers" :depends-on ("rnd/2rnd" "rnd/3rnd")) 28 | (:file "fn" :depends-on ("rnd/rnd")) 29 | (:file "gridfont/main" :depends-on ("utils")) 30 | (:file "draw/bzspl" :depends-on ("rnd/rnd")) 31 | (:file "draw/pigment" :depends-on ("utils")) 32 | (:file "draw/ortho" :depends-on ("utils")) 33 | (:file "draw/simplify-path" :depends-on ("utils")) 34 | (:file "draw/jpath" :depends-on ("utils")) 35 | (:file "draw/svg" :depends-on ("draw/simplify-path" "draw/jpath")) 36 | (:file "graph/main" :depends-on ("hset")) 37 | (:file "graph/paths" :depends-on ("graph/main")) 38 | (:file "graph/edge-set" :depends-on ("graph/main")) 39 | (:file "graph/mst-cycle" :depends-on ("graph/main")) 40 | (:file "weir/macros" :depends-on ("utils")) 41 | (:file "weir/main" 42 | :depends-on ("graph/paths" "weir/macros" "graph/edge-set")) 43 | (:file "weir/props" :depends-on ("weir/main")) 44 | (:file "weir/vert-utils-init" :depends-on ("weir/main")) 45 | (:file "weir/vert-utils" :depends-on ("weir/vert-utils-init")) 46 | (:file "weir/planar-cycles" 47 | :depends-on ("weir/main" "graph/mst-cycle")) 48 | (:file "weir/paths" 49 | :depends-on ("weir/props" "draw/simplify-path")) 50 | (:file "weir/alteration-utils" :depends-on ("weir/vert-utils")) 51 | (:file "weir/alteration-defalt-macro" 52 | :depends-on ("weir/alteration-utils")) 53 | (:file "weir/alterations" 54 | :depends-on ("weir/alteration-defalt-macro")) 55 | (:file "weir/with-macro" 56 | :depends-on ("weir/alteration-utils")) 57 | (:file "weir/kdtree" :depends-on ("weir/vert-utils")) 58 | (:file "weir/relneigh" :depends-on ("weir/kdtree")) 59 | (:file "weir/poly" :depends-on ("weir/main")) 60 | (:file "weir/poly-isect" :depends-on ("weir/poly")) 61 | (:file "weir/poly-modify" 62 | :depends-on ("weir/poly-isect" "draw/ortho")) 63 | (:file "weir/bvh-util" :depends-on ("weir/macros" "weir/paths")) 64 | (:file "weir/3bvh" :depends-on ("weir/bvh-util")) 65 | (:file "weir/extra" 66 | :depends-on ("weir/props" "weir/vert-utils" "weir/macros")) 67 | (:file "voxel/init" :depends-on ("weir/extra")) 68 | (:file "voxel/voxel" :depends-on ("voxel/init")) 69 | (:file "draw/canvas" :depends-on ("utils")))) 70 | 71 | 72 | (asdf:defsystem #:weird/tests 73 | :depends-on (#:weird #:prove) 74 | :perform (asdf:test-op (o s) (uiop:symbol-call ':weird-tests '#:run-tests)) 75 | :pathname "test/" 76 | :serial t 77 | :components ((:file "run"))) 78 | 79 | --------------------------------------------------------------------------------