├── .gitignore ├── .siph ├── AUTHORS ├── COPYING ├── ChangeLog ├── INSTALL ├── Makefile.am ├── NEWS ├── README ├── README.md ├── bench ├── Makefile ├── bench.lisp └── stlbench.cpp ├── configure.ac ├── example.lisp ├── share ├── load-quicklisp.lisp ├── run-test.lisp ├── run-test.sh └── test.lisp └── src ├── array.lisp ├── binary.lisp ├── cgen.lisp ├── fuzz-test.lisp ├── heap.lisp ├── interfaces.lisp ├── package.lisp ├── queue.lisp ├── regress.lisp ├── rope.lisp ├── sycamore.asd ├── tree.lisp ├── trie.lisp ├── trim.lisp ├── ttree.lisp ├── util.lisp └── wb-tree.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | /stlbench 2 | /bench/stlbench 3 | /Makefile 4 | /Makefile.in 5 | /aclocal.m4 6 | /autom4te.cache/ 7 | /config.log 8 | /config.status 9 | /configure 10 | /install-sh 11 | /missing 12 | /sycamore-*.tar.gz 13 | /share/run-test.sh.log 14 | /share/run-test.sh.trs 15 | /test-driver 16 | /test-suite.log 17 | -------------------------------------------------------------------------------- /.siph: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2011-2014, Georgia Tech Research Corporation 2 | # Copyright (c) 2015-2016, Rice University 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions are 7 | # met: 8 | # 9 | # * Redistributions of source code must retain the above copyright 10 | # notice, this list of conditions and the following disclaimer. 11 | # 12 | # * Redistributions in binary form must reproduce the above copyright 13 | # notice, this list of conditions and the following disclaimer in the 14 | # documentation and/or other materials provided with the distribution. 15 | # 16 | # * Neither the name of copyright holder the names of its contributors 17 | # may be used to endorse or promote products derived from this 18 | # software without specific prior written permission. 19 | # 20 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | SIPH_PKG_NAME="sycamore" 33 | SIPH_PKG_REPO="https://github.com/ndantam/sycamore.git" 34 | SIPH_PKG_BRANCH="master" 35 | 36 | SIPH_PKG_DEPS_DEB="" 37 | 38 | 39 | siph_pkg_deps() { 40 | siph_deps_deb 41 | siph_install_quicklisp 42 | } 43 | 44 | 45 | siph_pkg_compile() { 46 | true 47 | } 48 | 49 | siph_pkg_test() { 50 | ./share/run-test.sh 51 | } 52 | 53 | siph_pkg_install() { 54 | siph_find_quicklisp 55 | siph_msg "Installing under '$SIPH_QUICKLISP'" 56 | 57 | mkdir -p "$SIPH_BLD_DESTDIR/$SIPH_QUICKLISP/local-projects" 58 | ln -vs "$SIPH_BLD_SRCDIR/src/sycamore.asd" "$SIPH_BLD_DESTDIR/$SIPH_QUICKLISP/local-projects" 59 | } 60 | 61 | # Local Variables: 62 | # mode: shell-script 63 | # End: 64 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | This project developed at the 2 | Georgia Tech Humanoid Robotics Lab 3 | Under Direction of Prof. Mike Stilman 4 | 5 | 6 | NAME: Email Address: 7 | --------------------------------- 8 | Neil Dantam 9 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011-2014, Georgia Tech Research Corporation 2 | Copyright (c) 2015-2016, Rice University 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | * Neither the name of copyright holder the names of its contributors 17 | may be used to endorse or promote products derived from this 18 | software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | See the git log for changes: 2 | 3 | `$ git log' 4 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | SYCAMORE INSTALLATION 2 | 3 | 4 | 0. INSTALL DEPENDENCIES 5 | ======================= 6 | 7 | * Quicklisp is strongly recommended to install dependencies 8 | (https://www.quicklisp.org). 9 | 10 | * Assuming you are using SBCL (recommended), you can install quicklisp 11 | as follows: 12 | 13 | wget https://beta.quicklisp.org/quicklisp.lisp 14 | sbcl --load quicklisp.lisp \ 15 | --eval '(quicklisp-quickstart:install)' \ 16 | --eval '(ql:add-to-init-file)' \ 17 | --eval '(quit)' 18 | 19 | 1. INSTALL SYCAMORE 20 | =================== 21 | 22 | Next, create the symlink for ASDF 23 | (https://common-lisp.net/project/asdf/) to find the sycamore source 24 | files: 25 | 26 | mkdir --parents ~/.local/share/common-lisp/source/ 27 | ln -s $(pwd)/src/sycamore.asd ~/.local/share/common-lisp/source/ 28 | 29 | 30 | 3. LOAD SYCAMORE 31 | ================ 32 | 33 | To directly load and use Sycamore, run either of the following from 34 | the Lisp REPL: 35 | 36 | * Via quicklisp: 37 | 38 | (ql:quickload :sycamore) 39 | 40 | * Otherwise: 41 | 42 | (require :sycamore) 43 | -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | EXTRA_DIST = \ 2 | src/sycamore.asd \ 3 | src/array.lisp \ 4 | src/binary.lisp \ 5 | src/cgen.lisp \ 6 | src/fuzz-test.lisp \ 7 | src/heap.lisp \ 8 | src/interfaces.lisp \ 9 | src/package.lisp \ 10 | src/queue.lisp \ 11 | src/regress.lisp \ 12 | src/rope.lisp \ 13 | src/sycamore.asd \ 14 | src/tree.lisp \ 15 | src/trie.lisp \ 16 | src/trim.lisp \ 17 | src/ttree.lisp \ 18 | src/util.lisp \ 19 | src/wb-tree.lisp \ 20 | example.lisp \ 21 | share/run-test.sh \ 22 | share/load-quicklisp.lisp \ 23 | share/test.lisp 24 | 25 | AM_TESTS_ENVIRONMENT=\ 26 | TOP_SRCDIR=$(top_srcdir) 27 | 28 | TESTS = share/run-test.sh 29 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | See the git log for news: 2 | 3 | `$ git log' 4 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | SYCAMORE 2 | ======== 3 | 4 | A fast, purely functional data structure library in Common Lisp. 5 | 6 | API Documentation: http://ndantam.github.io/sycamore 7 | 8 | Features 9 | ======== 10 | * Fast, purely functional weight-balanced binary trees. 11 | - http://en.wikipedia.org/wiki/Weight-balanced_tree 12 | - Leaf nodes are simple-vectors, greatly reducing tree height. 13 | * Interfaces for tree Sets and Maps (dictionaries). 14 | * Ropes 15 | - http://en.wikipedia.org/wiki/Rope_(data_structure) 16 | * Purely functional pairing heaps 17 | - http://en.wikipedia.org/wiki/Pairing_heap 18 | * Purely functional amortized queue 19 | 20 | Installation 21 | ============ 22 | 23 | * Sycamore uses ASDF (https://common-lisp.net/project/asdf/) 24 | * See `INSTALL` file for details 25 | 26 | Examples 27 | ======== 28 | 29 | See also `./example.lisp` 30 | 31 | Sets 32 | ---- 33 | 34 | Define an ordering function: 35 | 36 | CL-USER> (defun compare (a b) 37 | (cond ((< a b) -1) 38 | ((> a b) 1) 39 | (t 0))) 40 | 41 | COMPARE 42 | 43 | Create a set for integers: 44 | 45 | CL-USER> (sycamore:tree-set #'compare 1 2 -10 40) 46 | 47 | # 48 | 49 | Insertion: 50 | 51 | CL-USER> (sycamore:tree-set-insert (sycamore:tree-set #'compare 1 2) 52 | 0) 53 | # 54 | 55 | Removal: 56 | 57 | CL-USER> (sycamore:tree-set-remove (sycamore:tree-set #'compare 1 2 0) 58 | 0) 59 | # 60 | 61 | Union operation: 62 | 63 | CL-USER> (sycamore:tree-set-union (sycamore:tree-set #'compare 1 2) 64 | (sycamore:tree-set #'compare 1 0 3)) 65 | 66 | # 67 | 68 | Intersection operation: 69 | 70 | CL-USER> (sycamore:tree-set-intersection (sycamore:tree-set #'compare 1 2) 71 | (sycamore:tree-set #'compare 1 0 3)) 72 | 73 | # 74 | 75 | Difference operation: 76 | 77 | CL-USER> (sycamore:tree-set-difference (sycamore:tree-set #'compare 1 2) 78 | (sycamore:tree-set #'compare 1 0 3)) 79 | 80 | # 81 | 82 | Map set: 83 | 84 | CL-USER> (sycamore:map-tree-set 'list #'1+ 85 | (sycamore:tree-set #'compare 1 0 10 2)) 86 | 87 | (1 2 3 11) 88 | 89 | Fold set: 90 | 91 | CL-USER> (sycamore:fold-tree-set (lambda (list item) (cons item list)) 92 | nil 93 | (sycamore:tree-set #'compare 1 0 10 2)) 94 | 95 | (10 2 1 0) 96 | 97 | Ropes 98 | ----- 99 | 100 | Create a Rope: 101 | 102 | CL-USER> (sycamore:rope "Hello" #\Space 'World!) 103 | 104 | # 105 | 106 | Also works on lists: 107 | 108 | CL-USER> (sycamore:rope (list "Hello" #\Space 'World!)) 109 | 110 | # 111 | 112 | And arrays: 113 | 114 | CL-USER> (sycamore:rope (vector "Hello" #\Space 'World!)) 115 | 116 | # 117 | 118 | Rope to string: 119 | 120 | CL-USER> (sycamore:rope-string (sycamore:rope "Hello" #\Space 'World!)) 121 | 122 | "Hello WORLD!" 123 | 124 | Print a rope: 125 | 126 | CL-USER> (sycamore:rope-write (sycamore:rope "Hello" #\Space 'World!) 127 | :escape nil :stream *standard-output*) 128 | 129 | Hello WORLD! 130 | 131 | Alternatives 132 | ============ 133 | 134 | There are many other Common Lisp data structure libraries. Here are a 135 | few alternatives and their trade-offs relative to Sycamore. 136 | 137 | FSet 138 | ---- 139 | https://common-lisp.net/project/fset/Site/FSet-CL.html 140 | 141 | FSet implements finite sets with a CLOS-based set interface, while 142 | Sycamore's finite sets take a parameter for a comparison function. 143 | Both used weight-balanced trees with minor algorithmic differences. 144 | Generic vs. explicit comparison functions is both an aesthetic and 145 | performance issue. FSet's generic comparison functions do not need to 146 | be passed explicitly, while Sycamore's explicit comparison function 147 | parameter makes it easier to compare the same type differently if 148 | needed, e.g., lexicographic vs. fast string comparison. 149 | 150 | Included benchmarks show that Sycamore is 30-50% faster than FSet. 151 | 152 | CL-Containers 153 | ------------- 154 | https://github.com/gwkkwg/cl-containers 155 | 156 | CL-Containers is stateful/mutable/imperative, while Sycamore is 157 | purely-functional/persistent. 158 | 159 | Lisp Interface Library (LIL) 160 | ---------------------------- 161 | https://github.com/fare/lisp-interface-library 162 | 163 | Lisp Interface Library (LIL) provides abstracted data structures using 164 | Interface Passing Style, while Sycamore provides a few concrete data 165 | structures. LIL's Interface Passing Style presumably improves 166 | flexibility at the cost of runtime overhead and API complexity. 167 | Sycamore's explicit data structures have low-overhead, optimized 168 | implementations and a simple, documented API. 169 | 170 | 171 | References 172 | ========== 173 | 174 | * Okasaki, Chris. "Purely Functional Data Structures." Cambridge 175 | University Press. June 1999. ISBN: 978-0521663502. 176 | 177 | * Boehm, H.J., Atkinson, R. and Plass, M., 1995. Ropes: an alternative 178 | to strings. Software: Practice and Experience, 25(12), pp.1315-1330. 179 | 180 | * Adams, Stephen., 1992. Implementing sets efficiently in a functional 181 | language. University of Southampton. Tech Report CSTR 92-10. 182 | 183 | 184 | Name 185 | ==== 186 | http://en.wikipedia.org/wiki/Platanus_occidentalis 187 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | README -------------------------------------------------------------------------------- /bench/Makefile: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | default: 5 | 6 | stlbench: stlbench.cpp 7 | $(CXX) stlbench.cpp -O2 -o stlbench -lrt 8 | 9 | 10 | clean: 11 | rm -f stlbench 12 | 13 | check: check-sbcl check-ccl check-clisp check-ecl 14 | 15 | 16 | check-sbcl: 17 | @echo "-------- SBCL --------" 18 | sbcl --script run-test.lisp 19 | @echo "" 20 | 21 | check-clisp: 22 | @echo "-------- CLISP --------" 23 | clisp run-test.lisp 24 | 25 | check-ccl: 26 | @echo "-------- CCL --------" 27 | ccl --quiet --load run-test.lisp 28 | 29 | check-ecl: 30 | @echo "-------- ECL --------" 31 | ecl -load run-test.lisp -eval '(quit)' 32 | -------------------------------------------------------------------------------- /bench/bench.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | 41 | (defparameter *bench-data-file-1* 42 | (make-pathname :directory '(:absolute "tmp") :name "sycamore-bench-1" :type "dat")) 43 | 44 | (defparameter *bench-data-file-2* 45 | (make-pathname :directory '(:absolute "tmp") :name "sycamore-bench-2" :type "dat")) 46 | 47 | (defun bench-generate-data (&key 48 | (output-1 *bench-data-file-1*) 49 | (output-2 *bench-data-file-2*) 50 | (count-1 (expt 2 18)) 51 | (max-1 (* 2 count-1)) 52 | (count-2 count-1) 53 | (max-2 max-1)) 54 | (flet ((emit (count max output) 55 | (with-open-file (s output :direction :output :if-exists :supersede :if-does-not-exist :create) 56 | (format s "~{~&~D~}" 57 | (loop for i below count 58 | collect (random max)))))) 59 | (emit count-1 max-1 output-1) 60 | (emit count-2 max-2 output-2))) 61 | 62 | (defun bench-load (pathname) 63 | (with-open-file (s pathname :direction :input) 64 | (loop for i = (read s nil nil) 65 | while i 66 | collect i))) 67 | 68 | (defun time-general (build 69 | &key 70 | (list-1 (bench-load *bench-data-file-1*)) 71 | (list-2 (bench-load *bench-data-file-2*)) 72 | insert remove union intersection difference (output *standard-output*) name) 73 | (let ((*standard-output* output) 74 | (obj-1) 75 | (obj-2)) 76 | (labels ((pre-test (test-name) 77 | (format output "~&~%: ~A: ~A :" name test-name) 78 | #+sbcl 79 | (sb-ext:gc))) 80 | (if name 81 | (format t "~&: Benchmarks Results for ~A :" name) 82 | (format t "~&: Benchmarks Results :" )) 83 | ;; build 84 | (pre-test "build object 1") 85 | (setq obj-1 (time (funcall build list-1))) 86 | 87 | (pre-test "build object 2") 88 | (setq obj-2 (time (funcall build list-2))) 89 | 90 | ;; insert 91 | (when insert 92 | (pre-test "insert 2 into 1") 93 | (time (loop for x in list-2 94 | for y = (funcall insert obj-1 x) then 95 | (funcall insert y x))) 96 | 97 | (pre-test "insert 1 into 2") 98 | (time (loop for x in list-1 99 | for y = (funcall insert obj-2 x) then 100 | (funcall insert y x)))) 101 | ;; remove 102 | (when insert 103 | (pre-test "remove 2 from 1") 104 | (time (loop for x in list-2 105 | for y = (funcall remove obj-1 x) then 106 | (funcall insert y x))) 107 | 108 | (pre-test "remove 1 from 2") 109 | (time (loop for x in list-1 110 | for y = (funcall remove obj-2 x) then 111 | (funcall insert y x)))) 112 | 113 | ;; union 114 | 115 | (when union 116 | (pre-test "union 1 2") 117 | (time (funcall union obj-1 obj-2)) 118 | (pre-test "union 2 1") 119 | (time (funcall union obj-2 obj-1))) 120 | 121 | ;; intersection 122 | (when intersection 123 | (pre-test "intersection 1 2") 124 | (time (funcall intersection obj-1 obj-2)) 125 | (pre-test "intersection 2 1") 126 | (time (funcall intersection obj-2 obj-1))) 127 | 128 | ;; difference 129 | (when difference 130 | (pre-test "difference 1 2") 131 | (time (funcall difference obj-1 obj-2)) 132 | (pre-test "difference 2 1") 133 | (time (funcall difference obj-2 obj-1))) 134 | )) 135 | nil) 136 | 137 | 138 | 139 | (defun time-wb () 140 | ;; build 141 | (let ((compare (lambda (a b) 142 | (declare (type fixnum a b)) 143 | (- a b)))) 144 | (time-general (lambda (a) (build-wb-tree compare 145 | nil a)) 146 | :insert (lambda (obj x) 147 | (wb-tree-insert obj x compare)) 148 | :remove (lambda (obj x) 149 | (wb-tree-remove obj x compare)) 150 | :union (lambda (x y) 151 | (wb-tree-union x y compare)) 152 | :intersection (lambda (x y) 153 | (wb-tree-intersection x y compare)) 154 | :difference (lambda (x y) 155 | (wb-tree-difference x y compare)) 156 | :name "SYCAMORE:WB"))) 157 | 158 | 159 | (defun time-fset () 160 | (time-general (lambda (a) (fold #'fset:with (fset:empty-set) a)) 161 | :insert (lambda (obj x) 162 | (fset:with obj x)) 163 | :remove (lambda (obj x) 164 | (fset:less obj x)) 165 | :union #'fset:union 166 | :intersection #'fset:intersection 167 | :difference #'fset:set-difference-2 168 | :name "FSET")) 169 | 170 | (defun time-all (&key count (max count)) 171 | (when (and count max) 172 | (bench-generate-data :count-1 count :max-1 max)) 173 | (time-wb) 174 | (time-fset) 175 | nil) 176 | -------------------------------------------------------------------------------- /bench/stlbench.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012, Georgia Tech Research Corporation 3 | * All rights reserved. 4 | * 5 | * Author(s): Neil T. Dantam 6 | * Georgia Tech Humanoid Robotics Lab 7 | * Under Direction of Prof. Mike Stilman 8 | * 9 | * This file is provided under the following "BSD-style" License: 10 | * 11 | * Redistribution and use in source and binary forms, with or 12 | * without modification, are permitted provided that the following 13 | * conditions are met: 14 | * * Redistributions of source code must retain the above 15 | * copyright notice, this list of conditions and the following 16 | * disclaimer. 17 | * * Redistributions in binary form must reproduce the above 18 | * copyright notice, this list of conditions and the following 19 | * disclaimer in the documentation and/or other materials 20 | * provided with the distribution. 21 | * 22 | * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 23 | * CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 24 | * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 25 | * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 27 | * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 28 | * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 29 | * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 31 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 32 | * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 33 | * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 34 | * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | */ 36 | 37 | #include 38 | #include 39 | #include 40 | #include 41 | #include 42 | #include 43 | 44 | /* Benchmark STL sets. 45 | * 46 | * Note: it is difficult to measure the performance cost of heap 47 | * allocation here. GLIBC malloc() will be very fast. GLIBC free() 48 | * will usually be very fast because it batches work. Occasionally, 49 | * free() will reorganize the heap (and be very slow). 50 | */ 51 | 52 | using namespace std; 53 | 54 | #define MODULO(a,b) (((a) % (b)) + (b)) % (b); 55 | 56 | static struct timespec aa_tick_tock_start; 57 | 58 | static inline struct timespec 59 | aa_tm_make( time_t sec, long nsec ) { 60 | struct timespec t; 61 | t.tv_sec = sec; 62 | t.tv_nsec = nsec; 63 | return t; 64 | } 65 | 66 | static inline struct timespec 67 | aa_tm_make_norm( time_t sec, long nsec ) { 68 | long nsp = MODULO( (long)nsec, (long)1000000000 ); 69 | return aa_tm_make( sec + (nsec - nsp)/1e9, nsp ); 70 | } 71 | 72 | static inline struct timespec 73 | aa_tm_sub( const struct timespec a, const struct timespec b ) { 74 | return aa_tm_make_norm( a.tv_sec - b.tv_sec, 75 | a.tv_nsec - b.tv_nsec ); 76 | } 77 | 78 | static void tic() 79 | { 80 | clock_gettime( CLOCK_MONOTONIC, &aa_tick_tock_start ); 81 | } 82 | 83 | struct timespec toc( const char fmt[], ...) 84 | { 85 | struct timespec now; 86 | clock_gettime( CLOCK_MONOTONIC, &now ); 87 | struct timespec t = aa_tm_sub( now, aa_tick_tock_start ); 88 | double dt = (double)t.tv_sec + (double)t.tv_nsec / 1e9; 89 | 90 | va_list argp; 91 | va_start( argp, fmt ); 92 | vfprintf( stderr, fmt, argp ); 93 | va_end( argp ); 94 | 95 | 96 | fprintf( stderr, ": %f s\n", (double)t.tv_sec + (double)t.tv_nsec/1e9 ); 97 | return t; 98 | } 99 | 100 | 101 | 102 | static void load_data( const char *fname, vector &dat ) { 103 | FILE * f = fopen(fname, "r"); 104 | int d; 105 | while( 1 == fscanf(f, "%d", &d) ) { 106 | dat.push_back(d); 107 | } 108 | fclose(f); 109 | } 110 | 111 | static void build( vector &dat, set &tree ) { 112 | for( vector::iterator p = dat.begin(); p != dat.end(); p++ ) { 113 | tree.insert(*p); 114 | } 115 | } 116 | 117 | 118 | static void insert( set &tree1, const set &tree2 ) { 119 | for( set::iterator p = tree2.begin(); p != tree2.end(); p++ ) { 120 | tree1.insert(*p); 121 | } 122 | } 123 | 124 | 125 | static void do_tree_union( const set &tree1, const set &tree2, set tree_union ) { 126 | 127 | vector vec_union(tree1.size() + tree2.size() ); 128 | vector::iterator it = set_union( tree1.begin(), tree1.end(), 129 | tree2.begin(), tree2.end(), 130 | vec_union.begin() ); 131 | tree_union = set(vec_union.begin(), it ); 132 | } 133 | 134 | static void do_tree_intersection( const set &tree1, const set &tree2, set tree ) { 135 | vector vec(std::min(tree1.size() , tree2.size()) ); 136 | vector::iterator it = set_intersection( tree1.begin(), tree1.end(), 137 | tree2.begin(), tree2.end(), 138 | vec.begin() ); 139 | tree = set(vec.begin(), it ); 140 | } 141 | 142 | /* Benchmark the STL for operations we care about */ 143 | int main(int argc, char **argv) { 144 | int d; 145 | 146 | printf("CLOCKS_PER_SEC: %lu\n", CLOCKS_PER_SEC); 147 | 148 | // read data 149 | vector dat1, dat2; 150 | load_data("/tmp/sycamore-bench-1.dat", dat1); 151 | load_data("/tmp/sycamore-bench-2.dat", dat2); 152 | 153 | printf("data size 1: %lu\n", dat1.size() ); 154 | printf("data size 2: %lu\n", dat2.size() ); 155 | 156 | // build map 157 | set tree1, tree2; 158 | tic(); 159 | build( dat1, tree1 ); 160 | toc("build 1"); 161 | 162 | tic(); 163 | build( dat2, tree2 ); 164 | toc("build 2"); 165 | 166 | printf("\n"); 167 | printf("set size 1: %lu\n", tree1.size() ); 168 | printf("set size 2: %lu\n", tree2.size() ); 169 | 170 | vector vec1(tree1.begin(), tree1.end()); 171 | vector vec2(tree2.begin(), tree2.end()); 172 | 173 | printf("vec size 1: %lu\n", vec1.size() ); 174 | printf("vec size 2: %lu\n", vec2.size() ); 175 | 176 | printf("t1_0: %d, v1_0: %d\n", *tree1.begin(), *vec1.begin()); 177 | printf("t2_0: %d, v2_0: %d\n", *tree2.begin(), *vec2.begin()); 178 | 179 | printf("t1_1: %d, v1_1: %d\n", *(--tree1.end()), *(--vec1.end())); 180 | printf("t2_1: %d, v2_1: %d\n", *(--tree2.end()), *(--vec2.end())); 181 | 182 | printf("\n"); 183 | // Insert 184 | { 185 | set copy1 = tree1; 186 | set copy2 = tree2; 187 | tic(); 188 | insert( copy1, tree2 ); 189 | toc("Insert 2 into 1"); 190 | tic(); 191 | insert( copy2, tree1 ); 192 | toc("Insert 1 into 2"); 193 | } 194 | 195 | printf("\n"); 196 | // Union 197 | { 198 | set u1, u2; 199 | { 200 | tic(); 201 | do_tree_union( tree1, tree2, u1 ); 202 | toc("Tree Union 2 into 1"); 203 | 204 | tic(); 205 | do_tree_union( tree2, tree1, u2 ); 206 | toc("Tree Union 1 into 2"); 207 | } 208 | 209 | { 210 | tic(); 211 | vector dat(tree1.size() + tree2.size() ); 212 | vector::iterator it1 = set_union( vec1.begin(), vec1.end(), 213 | vec2.begin(), vec2.end(), 214 | dat.begin() ); 215 | toc( "Vec Union 1 2" ); 216 | } 217 | 218 | tic(); 219 | { 220 | vector dat(tree1.size() + tree2.size() ); 221 | vector::iterator it2 = set_union( vec2.begin(), vec2.end(), 222 | vec1.begin(), vec1.end(), 223 | dat.begin() ); 224 | toc( "Vec Union 2 1" ); 225 | } 226 | } 227 | 228 | printf("\n"); 229 | // Intersection 230 | { 231 | set u1, u2; 232 | { 233 | tic(); 234 | do_tree_intersection( tree1, tree2, u1 ); 235 | toc("Tree Intersection 1 2"); 236 | 237 | tic(); 238 | do_tree_intersection( tree2, tree1, u2 ); 239 | toc("Tree Intersection 2 1"); 240 | } 241 | 242 | { 243 | tic(); 244 | vector dat(std::min(tree1.size() , tree2.size() )); 245 | vector::iterator it1 = set_intersection( vec1.begin(), vec1.end(), 246 | vec2.begin(), vec2.end(), 247 | dat.begin() ); 248 | toc( "Vec Intersection 1 2" ); 249 | } 250 | 251 | tic(); 252 | { 253 | vector dat(std::min(tree1.size() , tree2.size() )); 254 | vector::iterator it2 = set_intersection( vec2.begin(), vec2.end(), 255 | vec1.begin(), vec1.end(), 256 | dat.begin() ); 257 | toc( "Vec Intersection 2 1" ); 258 | } 259 | } 260 | 261 | printf("\n"); 262 | // difference 263 | { 264 | { 265 | tic(); 266 | vector dat(tree1.size()); 267 | vector::iterator it1 = set_difference( vec1.begin(), vec1.end(), 268 | vec2.begin(), vec2.end(), 269 | dat.begin() ); 270 | set d(dat.begin(), it1); 271 | toc( "Set Difference 1 2" ); 272 | } 273 | 274 | tic(); 275 | { 276 | vector dat(tree1.size()); 277 | vector::iterator it2 = set_difference( vec2.begin(), vec2.end(), 278 | vec1.begin(), vec1.end(), 279 | dat.begin() ); 280 | set d(dat.begin(), it2); 281 | toc( "Set Difference 2 1" ); 282 | } 283 | 284 | { 285 | tic(); 286 | vector dat(tree1.size()); 287 | vector::iterator it1 = set_difference( vec1.begin(), vec1.end(), 288 | vec2.begin(), vec2.end(), 289 | dat.begin() ); 290 | toc( "Vec Difference 1 2" ); 291 | } 292 | 293 | tic(); 294 | { 295 | vector dat(tree1.size()); 296 | vector::iterator it2 = set_difference( vec2.begin(), vec2.end(), 297 | vec1.begin(), vec1.end(), 298 | dat.begin() ); 299 | toc( "Vec Difference 2 1" ); 300 | } 301 | } 302 | 303 | 304 | // // search map 305 | // vector dat1(dat.size()); 306 | // t0 = clock(); 307 | // for( size_t i = 0; i < dat.size(); i++ ) { 308 | // dat1[i] = (tree.find(dat[i]) != tree.end()); 309 | // } 310 | // t1 = clock(); 311 | // printf("Search Time for %d elements: %fs\n", dat.size(), ((double)(t1-t0)) / CLOCKS_PER_SEC); 312 | 313 | // // // union maps 314 | // set tree0, tree1; 315 | // for( size_t i = 0; i < dat.size() / 2; i++ ) 316 | // tree0.insert(dat[i]); 317 | // for( size_t i = dat.size()/2; i < dat.size() ; i++ ) 318 | // tree1.insert(dat[i]); 319 | 320 | // vector vec_union(dat.size()); 321 | // t0 = clock(); 322 | // vector::iterator it = set_union( tree0.begin(), tree0.end(), 323 | // tree1.begin(), tree1.end(), 324 | // vec_union.begin() ); 325 | // set tree_union(vec_union.begin(), it ); 326 | // t1 = clock(); 327 | // printf("Union Time for %d elements: %fs\n", dat.size(), ((double)(t1-t0)) / CLOCKS_PER_SEC); 328 | } 329 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # -*- Autoconf -*- 2 | # Process this file with autoconf to produce a configure script. 3 | 4 | AC_PREREQ([2.65]) 5 | AC_INIT([sycamore], [0.0.20160428], [ntd@rice.edu]) 6 | 7 | AM_INIT_AUTOMAKE([subdir-objects]) 8 | m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])]) 9 | 10 | AC_CONFIG_SRCDIR([src/sycamore.asd]) 11 | 12 | 13 | AC_CONFIG_FILES([Makefile]) 14 | AC_OUTPUT 15 | -------------------------------------------------------------------------------- /example.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2015, Rice University 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Redistribution and use in source and binary forms, with or 7 | ;;;; without modification, are permitted provided that the following 8 | ;;;; conditions are met: 9 | ;;;; 10 | ;;;; * Redistributions of source code must retain the above 11 | ;;;; copyright notice, this list of conditions and the following 12 | ;;;; disclaimer. 13 | ;;;; * Redistributions in binary form must reproduce the above 14 | ;;;; copyright notice, this list of conditions and the following 15 | ;;;; disclaimer in the documentation and/or other materials 16 | ;;;; provided with the distribution. 17 | ;;;; * Neither the name of copyright holder the names of its 18 | ;;;; contributors may be used to endorse or promote products 19 | ;;;; derived from this software without specific prior written 20 | ;;;; permission. 21 | ;;;; 22 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 23 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 24 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 25 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 27 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 28 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 29 | ;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 30 | ;;;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 31 | ;;;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | ;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | ;;;; POSSIBILITY OF SUCH DAMAGE. 35 | 36 | 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | ;;;; EXAMPLE USAGE FOR SYCAMORE ;;;; 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | 42 | ;;;;;;;;;;;;; 43 | ;;; ROPES ;;; 44 | ;;;;;;;;;;;;; 45 | 46 | ;; Make a rope 47 | (sycamore:rope "Hello" #\Space 'World!) 48 | 49 | ;; Also works on lists 50 | (sycamore:rope (list "Hello" #\Space 'World!)) 51 | 52 | ;; and arrays 53 | (sycamore:rope (vector "Hello" #\Space 'World!)) 54 | 55 | ;; Rope to string 56 | (sycamore:rope-string (sycamore:rope "Hello" #\Space 'World!)) 57 | 58 | ;; Write a rope 59 | (sycamore:rope-write (sycamore:rope "Hello" #\Space 'World!) 60 | :escape nil :stream *standard-output*) 61 | 62 | ;;;;;;;;;;;;;;;;; 63 | ;;; TREE SETS ;;; 64 | ;;;;;;;;;;;;;;;;; 65 | 66 | ;; Define an ordering function 67 | (defun compare (a b) 68 | (cond ((< a b) -1) 69 | ((> a b) 1) 70 | (t 0))) 71 | 72 | ;; Create a set for integers 73 | (sycamore:tree-set #'compare 1 2 -10 40) 74 | 75 | ;; Insertion 76 | (sycamore:tree-set-insert (sycamore:tree-set #'compare 1 2) 77 | 0) 78 | 79 | ;; Removal 80 | (sycamore:tree-set-remove (sycamore:tree-set #'compare 1 2 0) 81 | 0) 82 | 83 | ;; Union operation 84 | (sycamore:tree-set-union (sycamore:tree-set #'compare 1 2) 85 | (sycamore:tree-set #'compare 1 0 3)) 86 | 87 | ;; Intersection operation 88 | (sycamore:tree-set-intersection (sycamore:tree-set #'compare 1 2) 89 | (sycamore:tree-set #'compare 1 0 3)) 90 | 91 | ;; Difference operation 92 | (sycamore:tree-set-difference (sycamore:tree-set #'compare 1 2) 93 | (sycamore:tree-set #'compare 1 0 3)) 94 | 95 | ;; Map set 96 | (sycamore:map-tree-set 'list #'1+ 97 | (sycamore:tree-set #'compare 1 0 10 2)) 98 | 99 | ;; Fold set 100 | (sycamore:fold-tree-set (lambda (list item) (cons item list)) 101 | nil 102 | (sycamore:tree-set #'compare 1 0 10 2)) 103 | -------------------------------------------------------------------------------- /share/load-quicklisp.lisp: -------------------------------------------------------------------------------- 1 | (unless (find-package :quicklisp) 2 | (let ((ql (find-if #'probe-file 3 | (append (map 'list (lambda (setup) (merge-pathnames setup (user-homedir-pathname))) 4 | '("quicklisp/setup.lisp" ".quicklisp/setup.lisp" "Quicklisp/setup.lisp")) 5 | '("/usr/local/quicklisp/setup.lisp" 6 | "/usr/local/src/quicklisp/setup.lisp" 7 | "/usr/quicklisp/setup.lisp" 8 | "/usr/src/quicklisp/setup.lisp" 9 | "/opt/quicklisp/setup.lisp"))))) 10 | (if ql 11 | (progn 12 | (format t "~&Loading QL from ~A~&" ql) 13 | (load ql)) 14 | (progn 15 | (format *error-output* "~&QL not found!~&") 16 | (error "No quicklisp"))))) 17 | -------------------------------------------------------------------------------- /share/run-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | 39 | ;; Try to load quicklisp 40 | (unless (find-package :quicklisp) 41 | (let ((ql0 (merge-pathnames "quicklisp/setup.lisp" 42 | (user-homedir-pathname))) 43 | (ql1 (merge-pathnames ".quicklisp/setup.lisp" 44 | (user-homedir-pathname)))) 45 | (cond 46 | ((probe-file ql0) 47 | (load ql0)) 48 | ((probe-file ql1) 49 | (load ql1))))) 50 | 51 | ;; Try to ASDF load this Package 52 | (require :asdf) 53 | 54 | (push (make-pathname :directory '(:relative "src")) 55 | asdf:*central-registry*) 56 | 57 | (ql:quickload :sycamore) 58 | (ql:quickload :lisp-unit) 59 | 60 | (load "test.lisp") 61 | 62 | 63 | ;; Run the tests 64 | (in-package :sycamore) 65 | 66 | (lisp-unit:run-tests) 67 | 68 | 69 | #+sbcl 70 | (sb-ext:quit) 71 | 72 | #+ccl 73 | (ccl:quit) 74 | -------------------------------------------------------------------------------- /share/run-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ -z "$TOP_SRCDIR" ]; then 4 | TOP_SRCDIR=`pwd` 5 | else 6 | TOP_SRCDIR=`realpath "$TOP_SRCDIR"` 7 | fi 8 | 9 | sbcl --script < 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | (in-package :sycamore) 38 | 39 | (defvar *test-list-1*) 40 | (defvar *test-list-2*) 41 | (defvar *test-sort-1*) 42 | (defvar *test-sort-2*) 43 | (defvar *test-wb-1*) 44 | (defvar *test-wb-2*) 45 | 46 | ;; number of fuzz test iterations 47 | #-(or clisp ecl) 48 | (defparameter *test-iterations* 1000) 49 | #+ecl 50 | (defparameter *test-iterations* 100) 51 | #+clisp 52 | (defparameter *test-iterations* 10) 53 | 54 | 55 | (defun make-test-vars (list1 list2) 56 | (setq *test-list-1* list1 57 | *test-list-2* list2 58 | *test-sort-1* (remove-duplicates (sort (copy-list list1) #'<)) 59 | *test-sort-2* (remove-duplicates (sort (copy-list list2) #'<)) 60 | *test-wb-1* (fold (wb-tree-builder #'-) nil list1) 61 | *test-wb-2* (fold (wb-tree-builder #'-) nil list2))) 62 | 63 | 64 | (defun test-list (count &optional (max 100)) 65 | (loop for i below count collect (random max))) 66 | 67 | (defun test-wb (count &optional (max 100)) 68 | (fold (wb-tree-builder #'-) nil (test-list count max))) 69 | 70 | (lisp-unit:define-test array 71 | ;; remove 72 | (let ((v (vector 1 2 3 4 5))) 73 | (lisp-unit:assert-equalp (vector 1 2 4 5) 74 | (array-tree-remove v 3 #'-)) 75 | (lisp-unit:assert-equalp (vector 2 3 4 5) 76 | (array-tree-remove v 1 #'-)) 77 | (lisp-unit:assert-equalp (vector 1 2 3 4) 78 | (array-tree-remove v 5 #'-))) 79 | (let ((v (vector 1 2 3 4))) 80 | (lisp-unit:assert-equalp (vector 2 3 4 ) 81 | (array-tree-remove v 1 #'-)) 82 | (lisp-unit:assert-equalp (vector 1 3 4) 83 | (array-tree-remove v 2 #'-)) 84 | (lisp-unit:assert-equalp (vector 1 2 4) 85 | (array-tree-remove v 3 #'-)) 86 | (lisp-unit:assert-equalp (vector 1 2 3) 87 | (array-tree-remove v 4 #'-))) 88 | 89 | ;; insert 90 | (dotimes (i *test-iterations*) 91 | (let* ((list (loop for i below (random 100) collect (random 100))) 92 | (sort (remove-duplicates (sort (copy-list list) #'<))) 93 | (array (fold (array-tree-builder #'-) (vector) list))) 94 | (lisp-unit:assert-equal (map 'list #'identity array) 95 | sort))) 96 | 97 | ;; split 98 | (multiple-value-bind (l p r) 99 | (array-tree-split (vector 1 2 4 5) 3 #'-) 100 | (lisp-unit:assert-equalp (vector 1 2) l) 101 | (lisp-unit:assert-equalp (vector 4 5) r) 102 | (lisp-unit:assert-false p) 103 | ) 104 | 105 | (multiple-value-bind (l p r) 106 | (array-tree-split (vector 1 2 4 5) 4 #'-) 107 | (lisp-unit:assert-equalp (vector 1 2) l) 108 | (lisp-unit:assert-equalp (vector 5) r) 109 | (lisp-unit:assert-true p)) 110 | 111 | (multiple-value-bind (l p r) 112 | (array-tree-split (vector 94 96 97 99 111) 101 #'-) 113 | (lisp-unit:assert-equalp (vector 94 96 97 99) l) 114 | (lisp-unit:assert-equalp (vector 111) r) 115 | (lisp-unit:assert-false p)) 116 | 117 | 118 | ) 119 | 120 | 121 | 122 | (lisp-unit:define-test tree 123 | 124 | ;; equal 125 | (let ((a (binary-tree-from-list '(2 (1) (3))))) 126 | (lisp-unit:assert-true (binary-tree-equal a 127 | (binary-tree-from-list '(1 nil (3 (2)))) 128 | #'-)) 129 | (lisp-unit:assert-true (binary-tree-equal a 130 | (binary-tree-from-list '(1 nil (2 nil (3)))) 131 | #'-)) 132 | (lisp-unit:assert-true (binary-tree-equal a 133 | (binary-tree-from-list '(3 (2 (1)))) 134 | #'-)) 135 | 136 | (lisp-unit:assert-false (binary-tree-equal a 137 | (binary-tree-from-list '(1 (0) (3 (2)))) 138 | #'-)) 139 | (lisp-unit:assert-false (binary-tree-equal a 140 | (binary-tree-from-list '(1 nil (3 (2) (4)))) 141 | #'-)) 142 | (lisp-unit:assert-false (binary-tree-equal a 143 | (binary-tree-from-list '(3 (2 (1 (0))))) 144 | #'-)) 145 | ) 146 | 147 | ;; wb-tree 148 | 149 | (let ((a (make-wb-tree nil 1 nil)) 150 | (b (make-wb-tree nil 3 nil)) 151 | (c (make-wb-tree nil 5 nil)) 152 | (d (make-wb-tree nil 7 nil))) 153 | (let ((bal (make-wb-tree (make-wb-tree a 2 b) 4 (make-wb-tree c 6 d))) 154 | (right-right (make-wb-tree a 2 (make-wb-tree b 4 (make-wb-tree c 6 d)))) 155 | (right-left (make-wb-tree a 2 (make-wb-tree (make-wb-tree b 4 c) 6 d))) 156 | (left-left (make-wb-tree (make-wb-tree (make-wb-tree a 2 b) 4 c) 6 d)) 157 | (left-right (make-wb-tree (make-wb-tree a 2 (make-wb-tree b 4 c)) 6 d)) ) 158 | (let ((bal-right-right (left-wb-tree (binary-tree-left right-right) 159 | (binary-tree-value right-right) 160 | (binary-tree-right right-right))) 161 | (bal-right-left (left-right-wb-tree (binary-tree-left right-left) 162 | (binary-tree-value right-left) 163 | (binary-tree-right right-left))) 164 | (bal-left-left (right-wb-tree (binary-tree-left left-left) 165 | (binary-tree-value left-left) 166 | (binary-tree-right left-left))) 167 | (bal-left-right (right-left-wb-tree (binary-tree-left left-right) 168 | (binary-tree-value left-right) 169 | (binary-tree-right left-right)))) 170 | (lisp-unit:assert-equalp bal bal-right-right) 171 | (lisp-unit:assert-equalp bal bal-left-right) 172 | (lisp-unit:assert-equalp bal bal-right-left) 173 | (lisp-unit:assert-equalp bal bal-left-left)))) 174 | 175 | (dotimes (i *test-iterations*) 176 | (let* ((list-1 (loop for i below 50 collect (random 100))) 177 | (list-2 (loop for i below 100 collect (+ 110 (random 100)))) 178 | (sort-1 (remove-duplicates (sort (copy-list list-1) #'<))) 179 | (sort-2 (remove-duplicates (sort (copy-list list-2) #'<))) 180 | (wb-tree-1 (fold (wb-tree-builder #'-) nil list-1)) 181 | (wb-tree-2 (fold (wb-tree-builder #'-) nil list-2)) 182 | (wb-tree-12 (fold (lambda (a x) (wb-tree-insert a x #'-)) wb-tree-1 list-2)) 183 | (wb-tree-cat (wb-tree-concatenate wb-tree-1 wb-tree-2 #'-))) 184 | (make-test-vars list-1 list-2) 185 | ;; construction 186 | (lisp-unit:assert-equal sort-1 (wb-tree-list wb-tree-1)) 187 | (lisp-unit:assert-equal sort-2 (wb-tree-list wb-tree-2)) 188 | 189 | ;; concatenate 190 | (lisp-unit:assert-equal (wb-tree-list wb-tree-cat) 191 | (append sort-1 sort-2)) 192 | (lisp-unit:assert-equal (wb-tree-list wb-tree-cat) 193 | (wb-tree-list wb-tree-12)) 194 | 195 | ;; equal 196 | (lisp-unit:assert-true (binary-tree-equal wb-tree-cat wb-tree-12 #'-)) 197 | 198 | (lisp-unit:assert-true (not (binary-tree-equal wb-tree-1 wb-tree-2 #'-))) 199 | 200 | ;; subset 201 | (lisp-unit:assert-true (wb-tree-subset wb-tree-1 wb-tree-12 #'-)) 202 | (lisp-unit:assert-true (wb-tree-subset wb-tree-2 wb-tree-12 #'-)) 203 | (lisp-unit:assert-true (wb-tree-subset wb-tree-cat wb-tree-12 #'-)) 204 | 205 | (lisp-unit:assert-true (not (wb-tree-subset wb-tree-12 wb-tree-1 #'-))) 206 | (lisp-unit:assert-true (not (wb-tree-subset wb-tree-12 wb-tree-2 #'-))) 207 | 208 | ;; min 209 | (lisp-unit:assert-equal (car sort-1) 210 | (binary-tree-min wb-tree-1)) 211 | (lisp-unit:assert-equal (car sort-2) 212 | (binary-tree-min wb-tree-2)) 213 | 214 | ;; remove-min 215 | (loop 216 | with tree = wb-tree-1 217 | for sort on sort-1 218 | do (multiple-value-bind (tree-x min) (wb-tree-remove-min tree) 219 | (lisp-unit:assert-equal (cdr sort) 220 | (wb-tree-list tree-x)) 221 | (lisp-unit:assert-equal (car sort) 222 | min) 223 | (setq tree tree-x))) 224 | 225 | (multiple-value-bind (tree x) (wb-tree-remove-min wb-tree-1) 226 | (lisp-unit:assert-equal (cdr sort-1) (wb-tree-list tree)) 227 | (lisp-unit:assert-equal (car sort-1) x)) 228 | 229 | (multiple-value-bind (tree x) (wb-tree-remove-min wb-tree-2) 230 | (lisp-unit:assert-equal (cdr sort-2) (wb-tree-list tree)) 231 | (lisp-unit:assert-equal (car sort-2) x)) 232 | 233 | ;; remove-max 234 | (loop 235 | with tree = wb-tree-1 236 | for sort on (reverse sort-1) 237 | do (multiple-value-bind (tree-x max) (wb-tree-remove-max tree) 238 | (lisp-unit:assert-equal (reverse (cdr sort)) 239 | (wb-tree-list tree-x)) 240 | (lisp-unit:assert-equal (car sort) 241 | max) 242 | (setq tree tree-x))) 243 | 244 | (multiple-value-bind (tree x) (wb-tree-remove-max wb-tree-1) 245 | (lisp-unit:assert-equal (wb-tree-list tree) 246 | (subseq sort-1 0 (1- (length sort-1)))) 247 | (lisp-unit:assert-equal x (car (last sort-1)))) 248 | 249 | (multiple-value-bind (tree x) (wb-tree-remove-max wb-tree-2) 250 | (lisp-unit:assert-equal (wb-tree-list tree) 251 | (subseq sort-2 0 (1- (length sort-2)))) 252 | (lisp-unit:assert-equal x (car (last sort-2)))) 253 | 254 | ;; remove 255 | (let ((list (append sort-1 sort-2))) 256 | (dotimes (i 10) 257 | (let ((i (random (length list)))) 258 | (lisp-unit:assert-equal (wb-tree-list (wb-tree-remove wb-tree-cat (elt list i) #'-)) 259 | (append (subseq list 0 i) 260 | (subseq list (1+ i))))))) 261 | 262 | 263 | ;; split 264 | (multiple-value-bind (left present right) 265 | (wb-tree-split wb-tree-12 101 #'-) 266 | (lisp-unit:assert-equal sort-1 (wb-tree-list left)) 267 | (lisp-unit:assert-equal sort-2 (wb-tree-list right)) 268 | (lisp-unit:assert-false present) 269 | ) 270 | ))) 271 | 272 | (lisp-unit:define-test wb-tree-compare 273 | ;; divide and conquer 274 | (lisp-unit:assert-true (= 0 275 | (wb-tree-compare (wb-tree #'- 1 3 5 7) 276 | (wb-tree #'- 1 3 5 7) #'-))) 277 | (lisp-unit:assert-true (> 0 278 | (wb-tree-compare (wb-tree #'- 1 3 5 7) 279 | (wb-tree #'- 1 3 5 7 9) #'-))) 280 | (lisp-unit:assert-true (< 0 281 | (wb-tree-compare (wb-tree #'- 1 3 5 7 9) 282 | (wb-tree #'- 1 3 5 7) #'-))) 283 | 284 | (lisp-unit:assert-true (< 0 285 | (wb-tree-compare (wb-tree #'- 2 3 5 7) 286 | (wb-tree #'- 1 3 5 7) #'-))) 287 | (lisp-unit:assert-true (> 0 288 | (wb-tree-compare (wb-tree #'- 1 3 5 7) 289 | (wb-tree #'- 2 3 5 7) #'-))) 290 | 291 | (lisp-unit:assert-true (< 0 292 | (wb-tree-compare (wb-tree #'- 1 3 5 9) 293 | (wb-tree #'- 1 3 5 7) #'-))) 294 | (lisp-unit:assert-true (> 0 295 | (wb-tree-compare (wb-tree #'- 1 3 5 7) 296 | (wb-tree #'- 1 3 5 9) #'-))) 297 | (lisp-unit:assert-true (< 0 298 | (wb-tree-compare (wb-tree #'- 1 3 6 7 9) 299 | (wb-tree #'- 1 3 5 7 9) #'-))) 300 | (lisp-unit:assert-true (> 0 301 | (wb-tree-compare (wb-tree #'- 1 3 5 7 9) 302 | (wb-tree #'- 1 3 6 7 9) #'-))) 303 | 304 | 305 | ) 306 | 307 | 308 | 309 | (lisp-unit:define-test set 310 | (dotimes (i *test-iterations*) 311 | (let* ((list-1 (loop for i below (random 100) collect (random 100))) 312 | (list-2 (loop for i below (random 100) collect (random 100))) 313 | (list-set-1 (remove-duplicates (sort (copy-list list-1) #'<))) 314 | (set-1 (apply #'tree-set #'- list-1)) 315 | (set-2 (apply #'tree-set #'- list-2))) 316 | ;; union 317 | (lisp-unit:assert-equal (remove-duplicates (sort (copy-list (union list-1 list-2)) #'<)) 318 | (map-tree-set 'list #'identity (tree-set-union set-1 set-2))) 319 | ;; intersection 320 | (lisp-unit:assert-equal (remove-duplicates (sort (copy-list (intersection list-1 list-2)) #'<)) 321 | (map-tree-set 'list #'identity (tree-set-intersection set-1 set-2))) 322 | ;; difference 323 | (lisp-unit:assert-equal (remove-duplicates (sort (copy-list (set-difference list-1 list-2)) #'<)) 324 | (map-tree-set 'list #'identity (tree-set-difference set-1 set-2))) 325 | ;; member 326 | (dolist (x list-1) 327 | (lisp-unit:assert-true (tree-set-member-p set-1 x))) 328 | (dolist (x list-2) 329 | (lisp-unit:assert-true (tree-set-member-p set-2 x))) 330 | (let ((set-i (tree-set-difference set-1 set-2))) 331 | (dolist (x list-2) 332 | (lisp-unit:assert-false (tree-set-member-p set-i x)))) 333 | ;; remove 334 | (lisp-unit:assert-equal (remove-duplicates (sort (copy-list (set-difference list-1 list-2)) #'<)) 335 | (map-tree-set 'list #'identity (fold #'tree-set-remove set-1 list-2))) 336 | 337 | ;; subset 338 | (lisp-unit::assert-true (tree-set-subset-p set-1 (tree-set-union set-1 set-2))) 339 | (lisp-unit::assert-true (tree-set-subset-p set-2 (tree-set-union set-1 set-2))) 340 | 341 | (if (subsetp list-1 list-2) 342 | (lisp-unit::assert-true (subsetp list-1 list-2)) 343 | (lisp-unit::assert-false (tree-set-subset-p set-1 set-2))) 344 | (if (subsetp list-2 list-1) 345 | (lisp-unit::assert-true (tree-set-subset-p set-2 set-1)) 346 | (lisp-unit::assert-false (tree-set-subset-p set-2 set-1))) 347 | ;; position 348 | (loop 349 | for i from 0 350 | for x in list-set-1 351 | do 352 | (lisp-unit::assert-equal x (tree-set-ref set-1 i)) 353 | (lisp-unit::assert-equal i (tree-set-position set-1 x))) 354 | ))) 355 | 356 | ;; (lisp-unit:define-test t-tree 357 | ;; (dotimes (i 20) 358 | ;; (let* ((list-1 (loop for i below 1000 collect (random 100000))) 359 | ;; (list-2 (loop for i below 1000 collect (random 1000000))) 360 | ;; (s-1 (remove-duplicates (sort (copy-list list-1) #'<))) 361 | ;; (s-2 (remove-duplicates (sort (copy-list list-2) #'<))) 362 | ;; (t-1 (fold (lambda (a x) (t-tree-insert a x #'-)) nil list-1)) 363 | ;; (t-2 (fold (lambda (a x) (t-tree-insert a x #'-)) nil list-2))) 364 | ;; (lisp-unit:assert-equalp s-1 365 | ;; (map-t-tree 'list #'identity t-1)) 366 | ;; (lisp-unit:assert-equalp s-2 367 | ;; (map-t-tree 'list #'identity t-2))))) 368 | 369 | 370 | (lisp-unit:define-test heap 371 | (dotimes (i (ash *test-iterations* -2)) 372 | (let* ((list-1 (loop for i below 1000 collect (random 100000))) 373 | (list-2 (loop for i below 1000 collect (random 1000000))) 374 | ;(s-1 (remove-duplicates (sort (copy-list list-1) #'<))) 375 | ;(s-2 (remove-duplicates (sort (copy-list list-2) #'<))) 376 | ;(t-1 (fold #'tree-heap-insert (make-tree-heap #'identity) list-1)) 377 | ;(t-2 (fold #'tree-heap-insert (make-tree-heap #'identity) list-2)) 378 | (p-1 (fold (pairing-heap-builder #'-) nil list-1)) 379 | (p-2 (fold (pairing-heap-builder #'-) nil list-2)) 380 | ) 381 | (labels ( 382 | ; (heap-list (heap) 383 | ; (map 'list #'cdr (wb-tree-list (tree-heap-root heap)))) 384 | ) 385 | ;(lisp-unit:assert-equalp s-1 386 | ;(heap-list t-1)) 387 | ;(lisp-unit:assert-equalp s-2 388 | ;(heap-list t-2)) 389 | 390 | ;; ;; find min 391 | ;; (lisp-unit:assert-equalp (car s-1) (tree-heap-find-min t-1)) 392 | 393 | ;; ;; find max 394 | ;; (lisp-unit:assert-equalp (car (last s-1)) (tree-heap-find-max t-1)) 395 | 396 | ;; remove min 397 | ;; (multiple-value-bind (tree value) (tree-heap-remove-min t-1) 398 | ;; (lisp-unit:assert-equalp (cdr s-1) 399 | ;; (heap-list tree)) 400 | ;; (lisp-unit:assert-equalp (car s-1) value)) 401 | 402 | ;; remove max 403 | ;; (multiple-value-bind (tree value) (tree-heap-remove-max t-1) 404 | ;; (lisp-unit:assert-equalp (subseq s-1 0 (1- (length s-1))) 405 | ;; (heap-list tree)) 406 | ;; (lisp-unit:assert-equalp (car (last s-1)) value)) 407 | 408 | (lisp-unit:assert-equalp (pairing-heap-list p-1 #'-) 409 | (sort (copy-list list-1) #'<)) 410 | (lisp-unit:assert-equalp (pairing-heap-list p-2 #'-) 411 | (sort (copy-list list-2) #'<)) 412 | )))) 413 | 414 | 415 | 416 | (lisp-unit:define-test map 417 | (let ((data '((1 . a) (2 . b) (3 . c) (4 . d))) 418 | (map (make-tree-map #'-))) 419 | (loop for (key . value) in data 420 | do (setq map (tree-map-insert map key value))) 421 | (loop for (key . value) in data 422 | do (lisp-unit:assert-true (eq value (tree-map-find map key)))))) 423 | 424 | 425 | (lisp-unit:define-test regression 426 | ;; remove min/max with null 427 | (lisp-unit:assert-equal '((2 3 4 5) 1) 428 | (multiple-value-bind (tree min) 429 | (wb-tree-remove-min (make-wb-tree nil 1 (vector 2 3 4 5))) 430 | (list (wb-tree-list tree) min))) 431 | 432 | (lisp-unit:assert-equal '((1 2 3 4) 5) 433 | (multiple-value-bind (tree min) 434 | (wb-tree-remove-max (make-wb-tree (vector 1 2 3 4) 5 nil)) 435 | (list (wb-tree-list tree) min)))) 436 | 437 | ;; (lisp-unit:define-test red-black 438 | ;; ;; red-black 439 | ;; (let ((bal (make-red-black t 440 | ;; (make-red-black nil 'a 'x 'b) 441 | ;; 'y 442 | ;; (make-red-black nil 'c 'z 'd)))) 443 | 444 | ;; (lisp-unit:assert-equalp bal 445 | ;; (balance-red-black nil (make-red-black t 'a 446 | ;; 'x 447 | ;; (make-red-black t 'b 'y 'c)) 448 | ;; 'z 'd)) 449 | ;; (lisp-unit:assert-equalp bal 450 | ;; (balance-red-black t 451 | ;; (make-red-black nil 'a 'x 'b) 452 | ;; 'y 453 | ;; (make-red-black nil 'c 'z 'd))) 454 | 455 | ;; (lisp-unit:assert-equalp bal 456 | ;; (balance-red-black nil 457 | ;; (make-red-black t (make-red-black t 'a 'x 'b) 458 | ;; 'y 459 | ;; 'c) 460 | ;; 'z 461 | ;; 'd)) 462 | ;; (lisp-unit:assert-equalp bal 463 | ;; (balance-red-black nil 464 | ;; 'a 465 | ;; 'x 466 | ;; (make-red-black t 467 | ;; 'b 468 | ;; 'y 469 | ;; (make-red-black t 'c 'z 'd)))) 470 | ;; (lisp-unit:assert-equalp bal 471 | ;; (balance-red-black nil 'a 'x 472 | ;; (make-red-black t (make-red-black t 'b 'y 'c) 473 | ;; 'z 'd))))) 474 | -------------------------------------------------------------------------------- /src/array.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | ;(declaim (optimize (speed 3) (safety 0))) 41 | 42 | ;;;;;;;;;;;; 43 | ;; Arrays ;; 44 | ;;;;;;;;;;; 45 | 46 | (defun array-tree-position (vector value compare &optional (start 0) (end (length vector))) 47 | (declare (type function compare) 48 | (type fixnum start end) 49 | (type simple-vector vector)) 50 | (labels ((rec (start end) 51 | (declare (type fixnum start end)) 52 | (if (>= start end) 53 | nil 54 | (let* ((i (ash (+ start end) -1)) 55 | (c (funcall compare value (aref vector i)))) 56 | (declare (type fixnum c)) 57 | (cond 58 | ((< c 0) (rec start i)) 59 | ((> c 0) (rec (1+ i) end)) 60 | (t i)))))) 61 | (declare (dynamic-extent (function rec))) 62 | (rec start end))) 63 | 64 | 65 | (defun array-tree-search (vector value compare &optional (start 0) (end (length vector))) 66 | (declare (type simple-vector vector)) 67 | (let ((i (array-tree-position vector value compare start end))) 68 | (if i 69 | (values (aref vector i) t) 70 | (values nil nil)))) 71 | 72 | 73 | (defun array-tree-set (vector value i) 74 | (declare (type fixnum i) 75 | (type simple-vector vector)) 76 | (let ((new-vector (make-array (length vector)))) 77 | (replace new-vector vector :end2 i) 78 | (setf (aref new-vector i) value) 79 | (replace new-vector vector :start1 (1+ i) :start2 (1+ i)) 80 | new-vector)) 81 | 82 | (defun array-tree-insert-at (vector value i &optional (start 0) (end (length vector))) 83 | (declare (type simple-vector vector) 84 | (type fixnum i start end)) 85 | (let ((new-vector (make-array (1+ (- end start)))) 86 | (j (- i start))) 87 | (when (> i start) 88 | (replace new-vector vector :start2 start :end2 i)) 89 | (setf (aref new-vector j) value) 90 | (when (< i end) 91 | (replace new-vector vector :start1 (1+ j) :start2 i :end2 end)) 92 | new-vector)) 93 | 94 | (defun array-tree-insert-position (vector value compare &optional (start 0) (end (length vector))) 95 | (declare (type fixnum start end) 96 | (type simple-vector vector) 97 | (type function compare)) 98 | (if (>= start end) 99 | (values start nil) 100 | (let* ((i (ash (+ start end) -1)) 101 | (c (funcall compare value (aref vector i)))) 102 | (declare (type fixnum i c)) 103 | (cond 104 | ((< c 0) (array-tree-insert-position vector value compare start i)) 105 | ((> c 0) (array-tree-insert-position vector value compare (1+ i) end)) 106 | (t (values i t)))))) 107 | 108 | (defun array-tree-insert (vector value compare) 109 | "Insert `value' in order into `original-array', nondestructive." 110 | (multiple-value-bind (position present) (array-tree-insert-position vector value compare) 111 | (if present 112 | vector 113 | (array-tree-insert-at vector value position)))) 114 | 115 | (defun array-tree-replace (vector value compare) 116 | "Insert `value' in order into `original-array', nondestructive." 117 | (multiple-value-bind (position present) (array-tree-insert-position vector value compare) 118 | (if present 119 | (array-tree-set vector value position) 120 | (array-tree-insert-at vector value position)))) 121 | 122 | (defun array-tree-builder (compare) 123 | (lambda (array value) 124 | (array-tree-insert array value compare))) 125 | 126 | (defun array-tree-remove-position (vector i) 127 | "Remove I'th element of VECTOR." 128 | (declare (type simple-vector vector) 129 | (type fixnum i)) 130 | (let ((n (length vector))) 131 | (if (and (= n 1) (= i 0)) 132 | nil 133 | (let* ((n1 (1- n)) 134 | (new-array (make-array n1))) 135 | (when (> i 0) 136 | (replace new-array vector :end1 i)) 137 | (when (< i n1) 138 | (replace new-array vector :start1 i :start2 (1+ i))) 139 | new-array)))) 140 | 141 | (defun array-tree-remove (vector value compare) 142 | "Remove VALUE from VECTOR." 143 | (let ((i (array-tree-position vector value compare))) 144 | (if i 145 | (array-tree-remove-position vector i) 146 | vector))) 147 | 148 | (defun array-tree-count-unique (vector-1 vector-2 compare) 149 | "Count number of unique elements between VECTOR-1 and VECTOR-2" 150 | (declare (type simple-vector vector-1 vector-2) 151 | (type function compare)) 152 | (labels ((rec (i j count) 153 | (declare (type fixnum i j count)) 154 | (cond 155 | ((= i (length vector-1)) 156 | (+ count (- (length vector-2) j))) 157 | ((= j (length vector-2)) 158 | (+ count (- (length vector-1) i))) 159 | (t 160 | (let ((c (funcall compare (aref vector-1 i) (aref vector-2 j)))) 161 | (declare (type fixnum c)) 162 | (cond 163 | ((< c 0) (rec (1+ i) j (1+ count))) 164 | ((> c 0) (rec i (1+ j) (1+ count))) 165 | (t (rec (1+ i) (1+ j) count)))))))) 166 | (declare (dynamic-extent (function rec))) 167 | (rec 0 0 0))) 168 | 169 | (defmacro with-array-tree ((left value right) tree &body body) 170 | (with-gensyms (tree-sym n i) 171 | `(multiple-value-bind (,left ,value ,right) 172 | (let* ((,tree-sym ,tree) 173 | (,n (length ,tree-sym)) 174 | (,i (ash (length ,tree-sym) -1))) 175 | (values (when (> ,i 0) (subseq ,tree-sym 0 ,i)) 176 | (aref ,tree-sym ,i) 177 | (when (< ,i (1- ,n)) 178 | (subseq ,tree-sym (1+ ,i))))) 179 | ,@body))) 180 | 181 | (defun array-tree-split-at (tree position 182 | &optional (start 0) (end (length tree))) 183 | (declare (type simple-vector tree) 184 | (type fixnum position start end)) 185 | (values (when (> position start) (subseq tree start position)) 186 | (aref tree position) 187 | (when (< position (1- end)) 188 | (subseq tree (1+ position) end)))) 189 | 190 | (defun array-tree-split (tree x compare) 191 | (declare (type simple-vector tree) 192 | (type function compare)) 193 | (let ((n (length tree))) 194 | (multiple-value-bind (position present) (array-tree-insert-position tree x compare) 195 | (declare (type fixnum position)) 196 | (values (when (> position 0) (subseq tree 0 position)) 197 | present 198 | (let ((i (if present (1+ position) position))) 199 | (when (< i n) 200 | (subseq tree i))))))) 201 | 202 | (defun array-tree-intersection (tree1 tree2 compare) 203 | (declare (type simple-vector tree1 tree2) 204 | (type function compare)) 205 | (let ((array (make-array (min (length tree1) (length tree2)) 206 | :fill-pointer 0))) 207 | (labels ((rec (i j) 208 | (when (and (< i (length tree1)) 209 | (< j (length tree2))) 210 | (let ((c (funcall compare (aref tree1 i) (aref tree2 j)))) 211 | (declare (fixnum c)) 212 | (cond ((< c 0) 213 | (rec (1+ i) j)) 214 | ((> c 0) 215 | (rec i (1+ j))) 216 | (t 217 | (vector-push (aref tree1 i) array) 218 | (rec (1+ i) (1+ j)))))))) 219 | (declare (dynamic-extent (function rec))) 220 | (rec 0 0) 221 | ;; make it a simple array 222 | (let ((n (length array))) 223 | (if (> n 0) 224 | (replace (make-array n) array) 225 | nil))))) 226 | 227 | 228 | 229 | 230 | ;; (defun array-tree-insert-split (array value compare) 231 | ;; (let* ((n (length array)) 232 | ;; (n/2 (ash n -1))) 233 | ;; (i (array-tree-position value array compare))) 234 | ;; (if (and i (< i n/2)) 235 | ;; (values (array-tree-insert value array compare 0 n/2 i) 236 | ;; (subseq array n/2)) 237 | ;; (values (subseq array 0 n/2) 238 | ;; (array-tree-insert value array compare n/2 n i))))) 239 | 240 | (defun array-tree-compare (vector-1 vector-2 compare) 241 | (declare (type simple-vector vector-1 vector-2) 242 | (type function compare)) 243 | (let ((n1 (length vector-1)) 244 | (n2 (length vector-2))) 245 | (cond ;; first, order by count since that's O(1) 246 | ((< n1 n2) -1) 247 | ((> n1 n2) 1) 248 | (t 249 | (labels ((rec (start end) 250 | (declare (type fixnum start end)) 251 | (if (>= start end) 252 | 0 253 | (let ((i (+ start (ash (- end start) -1)))) 254 | (declare (type fixnum i)) 255 | (or-compare (funcall compare (aref vector-1 i) (aref vector-2 i)) 256 | (rec start i) 257 | (rec (1+ i) end)))))) 258 | (declare (dynamic-extent (function rec))) 259 | (rec 0 n1)))))) 260 | -------------------------------------------------------------------------------- /src/binary.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | ;;(declaim (optimize (speed 3) (safety 0))) 41 | 42 | 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;; 45 | ;; BASIC BINARY TREES ;; 46 | ;;;;;;;;;;;;;;;;;;;;;;;; 47 | 48 | 49 | (defstruct (binary-tree (:constructor make-binary-tree (left value right))) 50 | left 51 | value 52 | right) 53 | 54 | 55 | (defun map-binary-tree-inorder (function tree) 56 | (declare (type function function)) 57 | (etypecase tree 58 | (binary-tree 59 | (map-binary-tree-inorder function (binary-tree-left tree)) 60 | (funcall function (binary-tree-value tree)) 61 | (map-binary-tree-inorder function (binary-tree-right tree))) 62 | (simple-vector 63 | (dotimes (i (length tree)) 64 | (funcall function (aref tree i)))) 65 | (null nil))) 66 | 67 | (defun map-binary-tree-preorder (function tree) 68 | (declare (type function function)) 69 | (when tree 70 | (funcall function (binary-tree-value tree)) 71 | (map-binary-tree-preorder function (binary-tree-left tree)) 72 | (map-binary-tree-preorder function (binary-tree-right tree)))) 73 | 74 | (defun map-binary-tree-postorder (function tree) 75 | (declare (type function function)) 76 | (when tree 77 | (map-binary-tree-postorder function (binary-tree-left tree)) 78 | (map-binary-tree-postorder function (binary-tree-right tree)) 79 | (funcall function (binary-tree-value tree)))) 80 | 81 | (defun map-binary-tree-nil (order function tree) 82 | (declare (type function function)) 83 | (ecase order 84 | (:inorder (map-binary-tree-inorder function tree)) 85 | (:postorder (map-binary-tree-postorder function tree)) 86 | (:preorder (map-binary-tree-preorder function tree)))) 87 | 88 | (defun map-binary-tree-list (order function tree) 89 | (declare (type function function)) 90 | (let* ((c (cons nil nil)) 91 | (k c)) 92 | (flet ((helper (x) 93 | (rplacd k (cons (funcall function x) nil)) 94 | (setq k (cdr k)))) 95 | (declare (dynamic-extent (function helper))) 96 | (map-binary-tree-nil order #'helper tree)) 97 | (cdr c))) 98 | 99 | (defun map-binary-tree (order result-type function tree) 100 | "Map elements of tree. 101 | ORDER: (or :inorder :preorder :postorder) 102 | RESULT-TYPE: (or 'list nil)" 103 | (cond 104 | ((null result-type) 105 | (map-binary-tree-nil order function tree)) 106 | ((eq 'list result-type) 107 | (map-binary-tree-list order function tree)) 108 | (t (error "Unknown result-type: ~A" result-type)))) 109 | 110 | (defun fold-binary-tree (order function initial-value tree) 111 | (declare (type function function)) 112 | (let ((v initial-value)) 113 | (flet ((helper (x) 114 | (setq v (funcall function v x)))) 115 | (declare (dynamic-extent (function helper))) 116 | (map-binary-tree-nil order #'helper tree)) 117 | v)) 118 | 119 | (defun binary-tree-search-node (tree value compare) 120 | (declare (type function compare)) 121 | "Return the node of TREE containing VALUE or NIL if not present." 122 | (labels ((rec (tree) 123 | (etypecase tree 124 | (binary-tree 125 | (let ((c (funcall compare value (binary-tree-value tree)))) 126 | (declare (type fixnum c)) 127 | (cond ((< c 0) (rec (binary-tree-left tree))) 128 | ((> c 0) (rec (binary-tree-right tree))) 129 | (t tree)))) 130 | (simple-vector 131 | (when (array-tree-position tree value compare) 132 | tree)) 133 | (null nil)))) 134 | (rec tree))) 135 | 136 | ;; (do* ((c 1 (funcall compare value (binary-tree-value tree-1))) 137 | ;; (tree-1 tree 138 | ;; (cond ((< c 0) (binary-tree-left tree-1)) 139 | ;; ((> c 0) (binary-tree-right tree-1)) 140 | ;; (t tree-1)))) 141 | ;; ((or (zerop c) (null tree-1)) tree-1)) 142 | 143 | (defun binary-tree-find (tree value compare) 144 | (declare (type function compare)) 145 | "Return the node of TREE containing VALUE or NIL if not present." 146 | (labels ((rec (tree) 147 | (etypecase tree 148 | (binary-tree 149 | (cond-compare (value (binary-tree-value tree) compare) 150 | (rec (binary-tree-left tree)) 151 | (values (binary-tree-value tree) t) 152 | (rec (binary-tree-right tree)))) 153 | (simple-vector 154 | (let ((i (array-tree-position tree value compare))) 155 | (if i 156 | (values (aref tree i) t) 157 | (values nil nil)))) 158 | (null (values nil nil))))) 159 | (rec tree))) 160 | 161 | 162 | (defun binary-tree-member-p (tree value compare) 163 | (multiple-value-bind (value present) 164 | (binary-tree-find tree value compare) 165 | (declare (ignore value)) 166 | present)) 167 | 168 | (defun binary-tree-left-left (tree) 169 | (binary-tree-left (binary-tree-left tree))) 170 | 171 | (defun binary-tree-left-right (tree) 172 | (binary-tree-left (binary-tree-right tree))) 173 | 174 | (defun binary-tree-right-left (tree) 175 | (binary-tree-right (binary-tree-left tree))) 176 | 177 | (defun binary-tree-right-right (tree) 178 | (binary-tree-right (binary-tree-right tree))) 179 | 180 | (defun binary-tree-value-left (tree) 181 | (binary-tree-value (binary-tree-left tree))) 182 | 183 | (defun binary-tree-value-right (tree) 184 | (binary-tree-value (binary-tree-right tree))) 185 | 186 | (defun binary-tree-leaf-p (tree) 187 | (and (null (binary-tree-left tree)) 188 | (null (binary-tree-right tree)))) 189 | 190 | (defun binary-tree-half-leaf-p (tree) 191 | (or (and (null (binary-tree-left tree)) 192 | (binary-tree-right tree)) 193 | (and (binary-tree-left tree) 194 | (null (binary-tree-right tree))))) 195 | 196 | 197 | (defun binary-tree-depth (tree) 198 | (etypecase tree 199 | (binary-tree 200 | (let ((l (binary-tree-depth (binary-tree-left tree))) 201 | (r (binary-tree-depth (binary-tree-right tree)))) 202 | (declare (type fixnum l r)) 203 | (1+ (max l r)))) 204 | (array 1) 205 | (null 0))) 206 | 207 | 208 | 209 | (defun binary-tree-dot (tree &key output (node-label-function #'binary-tree-value)) 210 | (output-dot output 211 | (lambda (s) 212 | (let ((i -1)) 213 | (labels ((helper (parent tree) 214 | (let ((x (incf i))) 215 | (etypecase tree 216 | (binary-tree (format s "~& ~A[label=\"~A\"];~&" 217 | x (funcall node-label-function tree))) 218 | (null (format s "~& ~A[label=\"nil\" shape=none];~&" x)) 219 | (simple-vector 220 | (format s "~& ~A[label=\"(~A): ~{~A~^, ~}\",shape=box];~&" 221 | x (length tree) (loop for k across tree collect k)))) 222 | (when parent 223 | (format s "~& ~A -> ~A;~&" 224 | parent x)) 225 | (when (binary-tree-p tree) 226 | (helper x (binary-tree-left tree)) 227 | (helper x (binary-tree-right tree)))))) 228 | (format s "~&digraph { ~&") 229 | (helper nil tree) 230 | (format s "~&}~&")))))) 231 | 232 | (defun binary-tree-min (tree) 233 | "Return minimum (leftmost) value of TREE." 234 | (etypecase tree 235 | (binary-tree 236 | (binary-tree-min (binary-tree-left tree))) 237 | (simple-vector (svref tree 0)) 238 | (null nil))) 239 | 240 | (defun binary-tree-max (tree) 241 | "Return maximum (rightmost) value of TREE." 242 | (etypecase tree 243 | (binary-tree 244 | (binary-tree-max (binary-tree-right tree))) 245 | (simple-vector (svref tree (1- (length tree)))) 246 | (null nil))) 247 | 248 | 249 | (defun binary-tree-count (tree) 250 | "Number of elements in TREE." 251 | (if tree 252 | (let ((l (binary-tree-count (binary-tree-left tree))) 253 | (r (binary-tree-count (binary-tree-right tree)))) 254 | (declare (type fixnum l r)) 255 | (+ 1 l r)) 256 | 0)) 257 | 258 | 259 | (declaim (ftype (function ((or array binary-tree null) (or array binary-tree null) function) 260 | fixnum) 261 | binary-tree-compare)) 262 | (defun binary-tree-compare (tree-1 tree-2 compare) 263 | (declare (type function compare)) 264 | (cond 265 | ((eq tree-1 tree-2) (return-from binary-tree-compare 0)) 266 | ((null tree-1) (return-from binary-tree-compare -1)) 267 | ((null tree-2) (return-from binary-tree-compare 1))) 268 | ;; O(log(n)) space, O(min(m,n)) time 269 | ;;(declare (optimize (speed 3) (safety 0))) 270 | (let ((stack (make-array 0;(ash (wb-tree-count tree-1) (- 0 +wb-tree-max-array-length+ 1)) 271 | :fill-pointer 0 :adjustable t)) 272 | (i 0)) 273 | (declare (type fixnum i)) 274 | (labels ((push-left (k) 275 | (etypecase k 276 | (binary-tree 277 | (vector-push-extend k stack) 278 | (push-left (binary-tree-left k))) 279 | (simple-vector 280 | (when (< 0 (length k)) (vector-push-extend k stack ))) 281 | (null))) 282 | (pop-val () 283 | (let ((val (aref stack (1- (length stack))))) 284 | (etypecase val 285 | (binary-tree 286 | (let ((tree (vector-pop stack))) 287 | (push-left (binary-tree-right tree)) 288 | (binary-tree-value tree))) 289 | (simple-vector 290 | (prog1 (aref val i) 291 | (incf i) 292 | (when (>= i (length val)) 293 | (setq i 0) 294 | (vector-pop stack)))))))) 295 | (push-left tree-1) 296 | (map-binary-tree-inorder (lambda (y) 297 | (when (zerop (length stack)) ;; tree-1 was shorter 298 | (return-from binary-tree-compare 1)) 299 | (let ((c (funcall compare (pop-val) y))) 300 | (declare (type fixnum c)) 301 | (unless (zerop c) 302 | (return-from binary-tree-compare c)))) 303 | tree-2)) 304 | (if (zerop (length stack)) 305 | ;; equal sizes 306 | 0 307 | ;; tree-1 taller 308 | -1))) 309 | 310 | 311 | (defun binary-tree-equal (tree-1 tree-2 compare) 312 | (zerop (the fixnum (binary-tree-compare tree-1 tree-2 compare)))) 313 | 314 | 315 | 316 | ;; (labels ((collect-left (k list) 317 | ;; (if k 318 | ;; (collect-left (binary-tree-left k) (cons k list)) 319 | ;; list)) 320 | ;; (rec (tree list) 321 | ;; (if (null tree) 322 | ;; list 323 | ;; (let ((list (rec (binary-tree-left tree) list))) ; left 324 | ;; (if (and list 325 | ;; (zerop (funcall compare (binary-tree-value tree) 326 | ;; (binary-tree-value (car list))))) ; root 327 | ;; (rec (binary-tree-right tree) ;right 328 | ;; (collect-left (binary-tree-right (car list)) (cdr list))) 329 | ;; t))))) 330 | ;; (not (rec tree-1 (collect-left tree-2 nil)))) 331 | 332 | 333 | (defun binary-tree-from-list (list) 334 | (when list 335 | (destructuring-bind (value &optional left right) list 336 | (make-binary-tree (binary-tree-from-list left) 337 | value 338 | (binary-tree-from-list right))))) 339 | 340 | (defun binary-tree-every (predicate tree) 341 | (declare (type function predicate)) 342 | (or (null tree) 343 | (and (funcall predicate (binary-tree-value tree)) 344 | (binary-tree-every predicate (binary-tree-left tree)) 345 | (binary-tree-every predicate (binary-tree-left tree))))) 346 | 347 | (defun binary-tree-some (predicate tree) 348 | (declare (type function predicate)) 349 | (and tree 350 | (or (funcall predicate (binary-tree-value tree)) 351 | (binary-tree-some predicate (binary-tree-left tree)) 352 | (binary-tree-some predicate (binary-tree-right tree))))) 353 | -------------------------------------------------------------------------------- /src/cgen.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2015, Rice University 2 | ;;;; 3 | ;;;; Redistribution and use in source and binary forms, with or 4 | ;;;; without modification, are permitted provided that the following 5 | ;;;; conditions are met: 6 | ;;;; 7 | ;;;; * Redistributions of source code must retain the above 8 | ;;;; copyright notice, this list of conditions and the following 9 | ;;;; disclaimer. 10 | ;;;; * Redistributions in binary form must reproduce the above 11 | ;;;; copyright notice, this list of conditions and the following 12 | ;;;; disclaimer in the documentation and/or other materials 13 | ;;;; provided with the distribution. 14 | ;;;; * Neither the name of copyright holder the names of its 15 | ;;;; contributors may be used to endorse or promote products 16 | ;;;; derived from this software without specific prior written 17 | ;;;; permission. 18 | ;;;; 19 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 20 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 21 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 22 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 24 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | ;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 27 | ;;;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 28 | ;;;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | ;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | ;;;; POSSIBILITY OF SUCH DAMAGE. 32 | 33 | (in-package :sycamore-cgen) 34 | 35 | (defparameter *cgen-indent-mark* #\Tab) 36 | (defparameter *cgen-indent* "") 37 | (defparameter *cgen-newline-indent* #\Newline) 38 | 39 | (defmacro with-cgen-indent (&body body) 40 | `(let* ((*cgen-indent* (rope *cgen-indent-mark* *cgen-indent*)) 41 | (*cgen-newline-indent* (rope #\Newline *cgen-indent*))) 42 | ,@body)) 43 | 44 | (defun cgen-stmt (stmt) (rope stmt #\;)) 45 | 46 | 47 | (defun cgen-return (value) (cgen-stmt (rope "return " value))) 48 | 49 | ;; TODO: escape 50 | (defun cgen-string (value) (rope #\" value #\")) 51 | 52 | (defstruct cgen-block 53 | header 54 | stmts) 55 | 56 | (defmethod object-rope ((object cgen-block)) 57 | (let ((body 58 | (rope #\{ 59 | (with-cgen-indent 60 | (rope (loop for s in (cgen-block-stmts object) 61 | collect (rope *cgen-newline-indent* s)))) 62 | *cgen-newline-indent* 63 | #\}))) 64 | (if-let ((header (cgen-block-header object))) 65 | (rope *cgen-newline-indent* header " " *cgen-newline-indent* body) 66 | body))) 67 | 68 | (defun cgen-defun (result name args body) 69 | (sycamore-cgen::make-cgen-block 70 | :header (rope result #\Space name (rope-parenthesize args)) 71 | :stmts (flatten body))) 72 | 73 | (defun cgen-declare-fun (result name args) 74 | (rope result #\Space name (rope-parenthesize args) #\;)) 75 | 76 | (defun cgen-block (&rest stmts) 77 | (make-cgen-block :stmts (flatten (ensure-list stmts)))) 78 | 79 | (defun cgen-while (test &rest body) 80 | (make-cgen-block :header (rope "while (" test ")") 81 | :stmts (flatten (ensure-list body)))) 82 | 83 | (defun cgen-if (test &rest body) 84 | (make-cgen-block :header (rope "if (" test ")") 85 | :stmts (flatten (ensure-list body)))) 86 | 87 | (defmacro def-cgen-binop (symbol) 88 | (with-gensyms (a b) 89 | `(defun ,(intern (concatenate 'string "CGEN-" (string symbol))) 90 | (,a ,b) 91 | (cgen-binop ',symbol ,a ,b)))) 92 | 93 | (def-cgen-binop *) 94 | (def-cgen-binop /) 95 | (def-cgen-binop +) 96 | (def-cgen-binop -) 97 | 98 | (defun cgen-sizeof (arg) 99 | (cgen-call "sizeof" arg)) 100 | 101 | (let ((hash (alist-hash-table 102 | '((post-++ . 1) 103 | (post--- . 1) 104 | (|()| . 1) 105 | ([] . 1) 106 | (\. . 1) 107 | (-> . 1) 108 | 109 | (pre-++ . 2) 110 | (pre--- . 2) 111 | (! . 2) 112 | (~ . 2) 113 | (unary-+ . 2) 114 | (unary-- . 2) 115 | (cast . 2) 116 | (deref . 2) 117 | (addr . 2) 118 | (align . 2) 119 | 120 | (* . 3) 121 | (/ . 3) 122 | (% . 3) 123 | 124 | (+ . 4) 125 | (- . 4) 126 | 127 | (<< . 5) 128 | (>> . 5) 129 | 130 | (< . 6) 131 | (> . 6) 132 | (<= . 6) 133 | (>= . 6) 134 | 135 | (== . 7) 136 | (!= . 7) 137 | 138 | (& . 8) 139 | (^ . 9) 140 | (\| . 10) 141 | (&& . 11) 142 | (\|\| . 12) 143 | 144 | (|?:| . 12) 145 | 146 | (= . 14) 147 | (+= . 14) 148 | (-= . 14) 149 | (*= . 14) 150 | (/= . 14) 151 | (%= . 14) 152 | (<<= . 14) 153 | (>>= . 14) 154 | (&= . 14) 155 | (^= . 14) 156 | (\|= . 14) 157 | 158 | (|,| . 15) 159 | 160 | )))) 161 | (defun op-precedence (op) 162 | (if-let ((p (gethash op hash))) 163 | p 164 | (error "Unrecognized operator '~A'" op)))) 165 | 166 | (defun cgen-op-symbol (op) 167 | "Return the canonical symbol of op" 168 | (declare (type symbol op)) 169 | (let ((op (case op 170 | ((or :or :lor) '\|\|) 171 | ((and :and :land) '&&) 172 | ((:bor) '\|) 173 | ((:band) '&) 174 | ((:= =) '=) 175 | ((:->) '->) 176 | ((:.) '|.|) 177 | ((:[]) '[]) 178 | ((:addr addr) 'addr) 179 | ((:deref deref ) 'deref) 180 | (otherwise op)))) 181 | (assert (op-precedence op)) 182 | op)) 183 | 184 | 185 | ;; TODO: sanity check that operators are valid for the pre/post unary/binary type 186 | 187 | (defstruct cgen-op 188 | op) 189 | 190 | (defun precedence (e) 191 | (etypecase e 192 | (cgen-op (op-precedence (cgen-op-op e))) 193 | (number 0) 194 | (rope 0))) 195 | 196 | (defun cgen-op-rope (op) 197 | "Return the C rope of op" 198 | (cgen-op-symbol (cgen-op-op op))) 199 | 200 | (defstruct (cgen-unop-pre (:include cgen-op) 201 | (:constructor %cgen-unop-pre (op a))) 202 | a) 203 | 204 | (defun cgen-unop-pre (op a) 205 | (%cgen-unop-pre (cgen-op-symbol op) 206 | a)) 207 | 208 | (defstruct (cgen-unop-post (:include cgen-op) 209 | (:constructor %cgen-unop-post (a op))) 210 | a) 211 | 212 | (defun cgen-unop-post (a op) 213 | (%cgen-unop-post a 214 | (cgen-op-symbol op))) 215 | 216 | (defstruct (cgen-binop (:include cgen-op) 217 | (:constructor %cgen-binop (op a b))) 218 | a b) 219 | 220 | (defun cgen-binop (op a b) 221 | (%cgen-binop (cgen-op-symbol op) 222 | a b)) 223 | 224 | 225 | (defun cgen-parenthesize (parent child) 226 | ;(format t "~&parent: ~A:~D" parent (precedence parent)) 227 | ;(format t "~&child: ~A:~D" child (precedence child)) 228 | (if (> (precedence child) (precedence parent)) 229 | (rope-parenthesize child) 230 | (rope child))) 231 | 232 | (defmethod object-rope ((object cgen-unop-pre)) 233 | ;; TODO: avoid redundant parenthesis 234 | (rope (cgen-op-rope object) 235 | (cgen-parenthesize object 236 | (cgen-unop-pre-a object)))) 237 | 238 | (defmethod object-rope ((object cgen-unop-post)) 239 | ;; TODO: avoid redundant parenthesis 240 | (rope (cgen-parenthesize object (cgen-unop-post-a object)) 241 | (cgen-op-rope object))) 242 | 243 | 244 | 245 | 246 | (defmethod object-rope ((object cgen-binop)) 247 | ;; TODO: avoid redundant parenthesis 248 | (rope (cgen-parenthesize object (cgen-binop-a object)) 249 | " " (cgen-op-rope object) " " 250 | (cgen-parenthesize object (cgen-binop-b object)))) 251 | 252 | 253 | (defun cgen-equal (a b) 254 | (cgen-binop '== a b)) 255 | 256 | (defun cgen-assign (a b) 257 | (cgen-binop '= a b)) 258 | 259 | 260 | (defstruct (cgen-subscript (:include cgen-binop))) 261 | (defun cgen-subscript (array index) 262 | (make-cgen-subscript :op '[] :a array :b index)) 263 | 264 | (defmethod object-rope ((object cgen-subscript)) 265 | (rope (cgen-subscript-a object) 266 | #\[ (cgen-subscript-b object) #\])) 267 | 268 | ;; (defun cgen-op (op args) 269 | ;; (print (cons op args)) 270 | 271 | 272 | (defun cgen-identifier (rope &key case) 273 | (let ((string (rope-string rope))) 274 | (setq string (substitute #\_ #\- string)) 275 | (case case 276 | (:upper (string-upcase string)) 277 | (:lower (string-downcase string)) 278 | (otherwise string)))) 279 | 280 | 281 | 282 | 283 | (defun cgen-include-local (thing) 284 | (rope "#include \"" thing "\"" #\Newline)) 285 | 286 | (defun cgen-include-system (thing) 287 | (rope "#include \<" thing "\>" #\Newline)) 288 | 289 | (defun cgen-define-constant (symbol &optional value) 290 | (rope "#define " symbol 291 | (if value 292 | (rope " " value) 293 | ""))) 294 | 295 | (defun cgen-comment (value) 296 | ;; TODO: escape 297 | (rope "/*" value "*/")) 298 | 299 | (defun cgen-line-comment (value) 300 | (cgen-comment (rope " " value " "))) 301 | 302 | (defun cgen-call-list (function args) 303 | (rope function "(" 304 | (rope-split ", " args) 305 | ")")) 306 | 307 | (defun cgen-call (function &rest args) 308 | (cgen-call-list function args)) 309 | 310 | (defun cgen-call-stmt (function &rest args) 311 | (cgen-stmt (cgen-call-list function args))) 312 | 313 | (defun cgen-addr (e) 314 | (cgen-unop-pre :addr e)) 315 | 316 | (defun cgen-deref (e) 317 | (cgen-unop-pre :deref e)) 318 | 319 | (defun cgen-assign-stmt (a b) 320 | (cgen-stmt (cgen-assign a b))) 321 | 322 | (defun cgen-declare (type name &optional initial-value) 323 | (cgen-stmt (rope type " " name 324 | (if initial-value 325 | (rope " = " initial-value) 326 | "")))) 327 | 328 | (defun cgen-array-initializer (values) 329 | (rope "{" 330 | (rope-split ", " values) 331 | "}")) 332 | 333 | (defun cgen-double-float (value) 334 | (format nil "~Fd" value)) 335 | 336 | (defun cgen-single-float (value) 337 | (format nil "~Ff" value)) 338 | 339 | (defun cgen-declare-array (type name values-or-size) 340 | (cgen-stmt (rope type " " name 341 | "[" 342 | (etypecase values-or-size 343 | (number values-or-size) 344 | (list (length values-or-size)) 345 | (array (length values-or-size))) 346 | 347 | "]" 348 | (when (or (listp values-or-size) 349 | (arrayp values-or-size)) 350 | (rope " = " (cgen-array-initializer values-or-size)))))) 351 | 352 | 353 | (defun cgen-exp (e) 354 | (labels ((rec-0 (nullary unary op args) 355 | (if (null args) 356 | nullary 357 | (rec-1 unary op (car args) (cdr args)))) 358 | (rec-1 (unary op a args) 359 | (if (null args) 360 | unary 361 | (rec-2 op a (car args) (cdr args)))) 362 | (rec-2 (op a b args) 363 | ;; right associative 364 | (let ((child (cgen-binop op (rec-e a) (rec-e b)))) 365 | (if args 366 | (rec-op op (cons child args)) 367 | child))) 368 | (rec-op (op args) 369 | (ecase (cgen-op-symbol op) 370 | (! (assert (null (cdr args))) 371 | (cgen-unop-pre op (car args))) 372 | (+ (rec-0 0 (car args) op args)) 373 | (* (rec-0 1 (car args) op args)) 374 | (&& (rec-0 1 (car args) op args)) 375 | (& (rec-0 1 (car args) op args)) 376 | (\|\| (rec-0 0 (car args) op args)) 377 | (\| (rec-0 0 (car args) op args)) 378 | (== (print args) 379 | (destructuring-bind (a b &rest args) args 380 | (rec-2 op a b args))) 381 | ([] 382 | (assert (= 2 (length args))) 383 | (cgen-subscript (rec-e (first args)) 384 | (rec-e (second args)))) 385 | ((= -> |.|) 386 | (assert (= 2 (length args))) 387 | (cgen-binop op 388 | (rec-e (first args)) 389 | (rec-e (second args)))))) 390 | (rec-e (e) 391 | (if (listp e) 392 | (rec-op (car e) (cdr e)) 393 | e))) 394 | (rec-e e))) 395 | -------------------------------------------------------------------------------- /src/fuzz-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | (in-package :sycamore) 38 | 39 | 40 | ;;;;;;;;;;; 41 | ;; QUEUE ;; 42 | ;;;;;;;;;;; 43 | (defun queue-fuzz-generator () 44 | (loop for i below (random (expt 2 10)) 45 | collect 46 | (if (zerop (random 2)) 47 | `(:enqueue ,(random (expt 2 10))) 48 | '(:dequeue)))) 49 | 50 | (defun queue-fuzz-tester (fuzz) 51 | (fuzz::do-operations 52 | ((queue list) (list (make-amortized-queue) nil)) 53 | fuzz 54 | ((:enqueue arg) 55 | (list (amortized-enqueue queue arg) 56 | (append list (list arg)))) 57 | ((:dequeue) 58 | (multiple-value-bind (q v) (amortized-dequeue queue) 59 | (and (equal v (car list)) 60 | (list q (cdr list))))))) 61 | 62 | (defun run-queue-tests (&key (count 1)) 63 | (fuzz:run-tests #'queue-fuzz-generator 64 | #'queue-fuzz-tester 65 | :count count)) 66 | 67 | ;;;;;;;;;; 68 | ;; Heap ;; 69 | ;;;;;;;;;; 70 | 71 | ;; (defun heap-fuzz-generator () 72 | ;; (loop for i below (random (expt 2 12)) 73 | ;; collect 74 | ;; (case (random 3) 75 | ;; (0 `(:insert ,(random (expt 2 12)))) 76 | ;; (1 '(:find-min)) 77 | ;; (2 `(:remove-min))))) 78 | 79 | ;; (defun heap-fuzz-tester (fuzz) 80 | ;; (fuzz::do-operations 81 | ;; ((list pairing-heap tree-heap) (list nil nil (make-tree-heap #'identity))) 82 | ;; fuzz 83 | ;; ((:insert arg) 84 | ;; (list (cons arg list) 85 | ;; (pairing-heap-insert pairing-heap arg #'-) 86 | ;; (tree-heap-insert tree-heap arg))) 87 | ;; ((:find-min) 88 | ;; (if list 89 | ;; (let ((new-list (sort list #'<))) 90 | ;; (and (equal (car new-list) 91 | ;; (pairing-heap-find-min pairing-heap)) 92 | ;; (equal (car new-list) 93 | ;; (tree-heap-find-min tree-heap)) 94 | ;; (list new-list pairing-heap tree-heap))) 95 | ;; (and (null pairing-heap) 96 | ;; (tree-heap-empty-p tree-heap) 97 | ;; (list list pairing-heap tree-heap)))) 98 | ;; ((:remove-min) 99 | ;; (if list 100 | ;; (multiple-value-bind (ph-1 pmin) (pairing-heap-remove-min pairing-heap #'-) 101 | ;; (multiple-value-bind (th-1 tmin) (tree-heap-remove-min tree-heap) 102 | ;; (destructuring-bind (lmin &rest lh-1) (sort list #'<) 103 | ;; (and (equal lmin pmin) 104 | ;; (equal lmin tmin) 105 | ;; (list lh-1 ph-1 th-1))))) 106 | ;; (and (null pairing-heap) 107 | ;; (tree-heap-empty-p tree-heap) 108 | ;; (list list pairing-heap tree-heap)))))) 109 | 110 | ;; (defun run-heap-tests (&key (count 1)) 111 | ;; (fuzz:run-tests #'heap-fuzz-generator 112 | ;; #'heap-fuzz-tester 113 | ;; :count count)) 114 | 115 | 116 | 117 | ;;;;;;;;; 118 | ;; BAG ;; 119 | ;;;;;;;;; 120 | 121 | (defun bag-fuzz-generator () 122 | (loop 123 | for i below (1+ (random (expt 2 10))) 124 | collect 125 | (random 32))) 126 | 127 | 128 | (defun bag-fuzz-tester (fuzz) 129 | (let ((bag (fuzz:test-true 'produce-bag 130 | (lambda () 131 | (fold #'tree-bag-insert (tree-bag #'fixnum-compare) fuzz)))) 132 | (hash (fuzz:test-true 'produce-hash 133 | (lambda () 134 | (fold (lambda (h x) 135 | (setf (gethash x h) (1+ (gethash x h 0))) 136 | h) 137 | (make-hash-table) 138 | fuzz))))) 139 | (loop for k being the hash-keys of hash 140 | do 141 | (fuzz:test= 'bag-count= 142 | (lambda () (gethash k hash)) 143 | (lambda () (tree-bag-count bag k)))))) 144 | 145 | (defun run-bag-tests (&key (count 1)) 146 | (fuzz:run-tests #'bag-fuzz-generator 147 | #'bag-fuzz-tester 148 | :formatter #'identity 149 | :count count)) 150 | 151 | ;;;;;;;;;;;;;; 152 | ;; TREE-SET ;; 153 | ;;;;;;;;;;;;;; 154 | 155 | (defun tree-set-fuzz-generator () 156 | (loop for i below 2 157 | collect (loop 158 | for i below (1+ (random (expt 2 12))) 159 | collect 160 | (random (expt 2 10))))) 161 | 162 | (defun tree-set-fuzz-tester (fuzz) 163 | (let* ((list-1 (remove-duplicates (first fuzz))) 164 | (list-2 (remove-duplicates (second fuzz))) 165 | (compare #'fixnum-compare) 166 | (set-1 (fuzz:test-true 'build-wb-1 167 | (lambda () (build-wb-tree compare nil list-1)))) 168 | (set-2 (fuzz:test-true 'build-wb-2 169 | (lambda () (build-wb-tree compare nil list-2)))) 170 | (set-p-1)) 171 | (labels ((set-sort (x) (sort (copy-list x) #'<)) 172 | (set-result (x) 173 | (setq set-p-1 x) 174 | (wb-tree-list x))) 175 | 176 | 177 | 178 | ;; constructed sets 179 | (fuzz:do-test ('wb-elements-1 :test #'equal) 180 | (set-sort list-1) 181 | (wb-tree-list set-1)) 182 | (fuzz:do-test ('wb-elements-2 :test #'equal) 183 | (set-sort list-2) 184 | (wb-tree-list set-2)) 185 | 186 | ;; balance 187 | (fuzz:test-true 'wb-balanced-1 (lambda () (wb-tree-balanced-p set-1))) 188 | (fuzz:test-true 'wb-balanced-2 (lambda () (wb-tree-balanced-p set-2))) 189 | (fuzz:test-true 'wb-balanced-sorted-1 190 | (lambda () (wb-tree-balanced-p 191 | (build-wb-tree #'fixnum-compare nil (set-sort list-1))))) 192 | (fuzz:test-true 'wb-balanced-sorted-2 193 | (lambda () (wb-tree-balanced-p 194 | (build-wb-tree #'fixnum-compare nil (set-sort list-2))))) 195 | 196 | ;; join balance 197 | (map-binary-tree :inorder nil 198 | (lambda (x) 199 | (with-wb-tree-split (l p r) set-1 x compare 200 | (assert p) 201 | (fuzz:test-true 'join-balanced 202 | (lambda () (wb-tree-balanced-p (join-wb-tree l x r 203 | compare)))))) 204 | set-1) 205 | (map-binary-tree :inorder nil 206 | (lambda (x) 207 | (with-wb-tree-split (l p r) set-2 x compare 208 | (assert p) 209 | (fuzz:test-true 'join-balanced 210 | (lambda () (wb-tree-balanced-p (join-wb-tree l x r 211 | compare)))))) 212 | set-2) 213 | 214 | 215 | ;; union 216 | (fuzz:do-test ('wb-union :test #'equal) 217 | (set-sort (union list-1 list-2)) 218 | (set-result (wb-tree-union set-1 set-2 #'fixnum-compare))) 219 | (fuzz:test-true 'wb-union-balanced-1 (lambda () (wb-tree-balanced-p set-p-1))) 220 | 221 | ;; intersection 222 | (fuzz:do-test ('wb-intersection :test #'equal) 223 | (set-sort (intersection list-1 list-2)) 224 | (set-result (wb-tree-intersection set-1 set-2 #'fixnum-compare))) 225 | (fuzz:test-true 'wb-intersection-balanced-1 (lambda () (wb-tree-balanced-p set-p-1))) 226 | 227 | ;; difference 228 | (fuzz:do-test ('wb-difference :test #'equal) 229 | (set-sort (set-difference list-1 list-2)) 230 | (set-result (wb-tree-difference set-1 set-2 #'fixnum-compare))) 231 | (fuzz:test-true 'wb-difference-balanced-1 (lambda () (wb-tree-balanced-p set-p-1)))))) 232 | 233 | (defun run-tree-set-tests (&key (count 1)) 234 | (fuzz:run-tests #'tree-set-fuzz-generator 235 | #'tree-set-fuzz-tester 236 | :formatter #'identity 237 | :count count)) 238 | -------------------------------------------------------------------------------- /src/heap.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | ;;;;;;;;;;;;;;;;;; 41 | ;; Pairing Heap ;; 42 | ;;;;;;;;;;;;;;;;;; 43 | 44 | (defstruct (pairing-heap) 45 | root 46 | next 47 | children) 48 | 49 | ;; Invariants: 50 | ;; - all values in children after root 51 | ;; - values in next possibly before root 52 | 53 | (defconstant +pairing-heap-max-array-length+ 8) 54 | 55 | (defun pairing-heap-find-min (heap) 56 | (pairing-heap-root heap)) 57 | 58 | (defun root-pairing-heap (root children) 59 | (make-pairing-heap :root root 60 | :children children)) 61 | 62 | (defun pairing-heap-merge (heap1 heap2 compare &optional next) 63 | (declare (type (or null pairing-heap) heap1 heap2) 64 | (type function compare)) 65 | (cond 66 | ((null heap1) heap2) 67 | ((null heap2) heap1) 68 | (t (multiple-value-bind (root-heap child-heap) 69 | (if-less-eq-compare ((pairing-heap-find-min heap1) (pairing-heap-find-min heap2) compare) 70 | (values heap1 heap2) 71 | (values heap2 heap1)) 72 | (make-pairing-heap :root (pairing-heap-root root-heap) 73 | :children (make-pairing-heap :root (pairing-heap-root child-heap) 74 | :children (pairing-heap-children child-heap) 75 | :next (pairing-heap-children root-heap)) 76 | :next next))))) 77 | 78 | (defun pairing-heap-insert (heap element compare) 79 | (etypecase heap 80 | (null 81 | (root-pairing-heap element nil)) 82 | (pairing-heap 83 | (let ((c (funcall compare element (pairing-heap-root heap)))) 84 | (if (<= c 0) 85 | (root-pairing-heap element heap) 86 | (root-pairing-heap (pairing-heap-root heap) 87 | ;; TODO: In this case, we could save 1 word/value 88 | ;; by consing onto the next slot instead of making 89 | ;; a new pairing heap struct. Update merge-pairs accordingly 90 | (make-pairing-heap :root element 91 | :next (pairing-heap-children heap)))))))) 92 | 93 | (defun pairing-heap-builder (compare) 94 | (lambda (heap element) (pairing-heap-insert heap element compare))) 95 | 96 | (defun pairing-heap-merge-pairs (heaps compare) 97 | (declare (type (or null pairing-heap) heaps) 98 | (type function compare)) 99 | (labels ((merge-left (pairs heaps) 100 | (if heaps 101 | (let ((h2 (pairing-heap-next heaps))) 102 | (if h2 103 | (merge-left (pairing-heap-merge heaps h2 compare pairs) 104 | (pairing-heap-next h2)) 105 | (merge-right (pairing-heap-merge heaps pairs compare (when pairs (pairing-heap-next pairs)))))) 106 | (when pairs (merge-right pairs)))) 107 | (merge-right (heaps) 108 | (assert heaps) 109 | (let ((h2 (pairing-heap-next heaps))) 110 | (if h2 111 | (merge-right (pairing-heap-merge heaps h2 compare (pairing-heap-next h2))) 112 | heaps)))) 113 | (merge-left nil heaps))) 114 | 115 | (defun pairing-heap-remove-min (heap compare) 116 | (let ((value (pairing-heap-root heap))) 117 | (values (pairing-heap-merge-pairs (pairing-heap-children heap) compare) 118 | value))) 119 | 120 | (defun pairing-heap-list (heap compare) 121 | (loop for h = heap then (pairing-heap-remove-min h compare) 122 | while h 123 | collect (pairing-heap-find-min h))) 124 | -------------------------------------------------------------------------------- /src/interfaces.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | ;(declaim (optimize (speed 3) (safety 0))) 41 | 42 | ;;;;;;;;;;;;;;;;;;;; 43 | ;; Top containter ;; 44 | ;;;;;;;;;;;;;;;;;;;; 45 | (defstruct (root-tree (:constructor %make-aux-tree (%compare root))) 46 | %compare 47 | (root nil)) 48 | 49 | 50 | (defun make-aux-compare (compare) 51 | (declare (type function compare)) 52 | (lambda (pair-1 pair-2) 53 | (funcall compare (car pair-1) (car pair-2)))) 54 | 55 | 56 | ;;;;;;;;;;;;;;; 57 | ;; TREE-MAPS ;; 58 | ;;;;;;;;;;;;;;; 59 | 60 | (defstruct (tree-map (:constructor %make-tree-map (compare root))) 61 | compare 62 | (root nil)) 63 | 64 | (defun make-tree-map (compare) 65 | "Create a new tree-map." 66 | (declare (type function compare)) 67 | (%make-tree-map (make-aux-compare compare) 68 | nil)) 69 | 70 | 71 | (defun empty-tree-map (tree-map) 72 | "Create a new empty tree-map." 73 | (%make-tree-map (tree-map-compare tree-map) 74 | nil)) 75 | 76 | (defun tree-map-insert (tree-map key value) 77 | "Insert KEY=>VALUE into TREE-MAP, returning the new tree-map." 78 | (%make-tree-map (tree-map-compare tree-map) 79 | (wb-tree-replace (tree-map-root tree-map) 80 | (cons key value) 81 | (tree-map-compare tree-map)))) 82 | 83 | (defun (setf tree-map-find) (value map key) 84 | "Destructively insert value item into map." 85 | (setf (tree-map-root map) 86 | (wb-tree-replace (tree-map-root map) 87 | (cons key value) 88 | (tree-map-compare map)))) 89 | 90 | 91 | (defmacro tree-map-insertf (place key value) 92 | "Insert KEY=>VALUE into the tree map at PLACE, store at place." 93 | `(progn 94 | (setf ,place 95 | (tree-map-insert ,place ,key ,value)))) 96 | 97 | (defun tree-map-remove (tree-map key) 98 | "Insert KEY from TREE-MAP, returning the new tree-map." 99 | (%make-tree-map (tree-map-compare tree-map) 100 | (wb-tree-remove (tree-map-root tree-map) 101 | (cons key nil) 102 | (tree-map-compare tree-map)))) 103 | 104 | (defun tree-map-find (tree-map key &optional default) 105 | "Find value indexed by KEY in TREE-MAP." 106 | (let ((map-key (cons key nil))) 107 | (declare (dynamic-extent map-key)) 108 | (multiple-value-bind (cons present) 109 | (binary-tree-find (tree-map-root tree-map) 110 | map-key 111 | (tree-map-compare tree-map)) 112 | (if present 113 | (values (cdr cons) (car cons) t) 114 | (values default key nil))))) 115 | 116 | (defun tree-map-contains (tree-map key) 117 | "Test if a key is present in tree-map" 118 | (let ((key (cons key nil))) 119 | (declare (dynamic-extent key)) 120 | (binary-tree-member-p (tree-map-root tree-map) 121 | key 122 | (tree-map-compare tree-map)))) 123 | 124 | (defun map-tree-map (order result-type function tree-map) 125 | "Apply FUNCTION to all elements in TREE-MAP. 126 | ORDER: (or :inorder :preorder :postorder). 127 | RESULT-TYPE: (or nil 'list). 128 | FUNCTION: (lambda (key value))." 129 | (declare (type function function)) 130 | (let ((result 131 | (flet ((helper (pair) 132 | (funcall function (car pair) (cdr pair)))) 133 | (declare (dynamic-extent (function helper))) 134 | (map-binary-tree order (if (eq result-type 'tree-map) 135 | 'list 136 | result-type) 137 | #'helper 138 | (tree-map-root tree-map))))) 139 | (when result-type 140 | (ecase result-type 141 | (list result) 142 | (treemap 143 | (assert nil)))))) 144 | 145 | (defmacro do-tree-map (((key value) map &optional result) &body body) 146 | `(progn 147 | (map-tree-map :inorder nil 148 | (lambda (,key ,value) 149 | ,@body) 150 | ,map) 151 | ,result)) 152 | 153 | (defun fold-tree-map (function initial-value tree-map) 154 | "Fold FUNCTION over members of the map 155 | FUNCTION: (lambda (accumulated-value key value))." 156 | (declare (type function function)) 157 | (flet ((helper (accum pair) 158 | (funcall function accum (car pair) (cdr pair)))) 159 | (declare (dynamic-extent (function helper))) 160 | (fold-binary-tree :inorder #'helper 161 | initial-value (tree-map-root tree-map)))) 162 | 163 | (defun tree-map-count (map) 164 | "Number of elements in MAP." 165 | (wb-tree-count (tree-map-root map))) 166 | 167 | (defun tree-map-insert-map (tree-map other-map) 168 | "Insert all elements of OTHER-MAP into TREE-MAP" 169 | (assert (eq (tree-map-compare tree-map) 170 | (tree-map-compare other-map))) 171 | (fold-tree-map (lambda (map key value) 172 | (tree-map-insert map key value)) 173 | tree-map 174 | other-map)) 175 | 176 | (defun tree-map-insert-alist (tree-map alist) 177 | "Insert all elements of ALIST into TREE-MAP" 178 | (fold (lambda (map elt) (tree-map-insert map (car elt) (cdr elt))) 179 | tree-map alist)) 180 | 181 | (defun alist-tree-map (alist compare) 182 | "Returns a tree-map containing the keys and values of the association list ALIST." 183 | (tree-map-insert-alist (make-tree-map compare) 184 | alist)) 185 | 186 | (defun tree-map-insert-hash-table (tree-map hash-table) 187 | "Insert all elements of HASH-TABLE into TREE-MAP" 188 | (flet ((helper (key value) 189 | (setf (tree-map-find tree-map key) value))) 190 | (declare (dynamic-extent (function helper))) 191 | (maphash #'helper hash-table)) 192 | tree-map) 193 | 194 | (defun hash-table-tree-map (hash-table compare) 195 | "Returns a tree-map containing the keys and values of the hash-table list HASH-TABLE." 196 | (tree-map-insert-hash-table (make-tree-map compare) hash-table)) 197 | 198 | (defun tree-map-alist (tree-map) 199 | "Returns an association list containging the keys and values of tree-map TREE-MAP." 200 | (declare (type tree-map tree-map)) 201 | (map-tree-map :inorder 'list #'cons tree-map)) 202 | 203 | (defun tree-map-hash-table (tree-map &rest hash-table-initargs) 204 | "Returns a hash table containing the keys and values of the tree-map TREE-MAP. 205 | Hash table is initialized using the HASH-TABLE-INITARGS." 206 | (declare (type tree-map tree-map) 207 | (dynamic-extent hash-table-initargs)) 208 | (fold-tree-map (lambda (hash key value) 209 | (setf (gethash key hash) value) 210 | hash) 211 | (apply #'make-hash-table hash-table-initargs) 212 | tree-map)) 213 | 214 | 215 | (defun tree-map-values (tree-map) 216 | (fold-tree-map (lambda (a k v) 217 | (declare (ignore k)) 218 | (cons v a)) 219 | nil tree-map)) 220 | 221 | (defun tree-map-keys (tree-map) 222 | (fold-tree-map (lambda (a k v) 223 | (declare (ignore v)) 224 | (cons k a)) 225 | nil tree-map)) 226 | 227 | 228 | (defmethod print-object ((object tree-map) stream) 229 | (print-unreadable-object (object stream :type t :identity nil) 230 | 231 | ;; (write (tree-map-alist object) 232 | ;; :stream stream) 233 | 234 | ;; (format stream "~@<{~;~:{{~A: ~A}~^ ~}~;}~:@>" 235 | ;; (map-tree-map :inorder 'list #'list object)) 236 | 237 | (pprint-logical-block (stream (map-tree-map :inorder 'list #'list object) 238 | :prefix "{" :suffix "}") 239 | (do () (nil) 240 | (pprint-exit-if-list-exhausted) 241 | (let ((x (pprint-pop))) 242 | (pprint-newline :fill stream) 243 | (pprint-indent :block 0 stream) 244 | (pprint-logical-block (stream x) 245 | (write (car x) :stream stream) 246 | (write-char #\: stream) 247 | (write-char #\Space stream) 248 | (write (cadr x) :stream stream)) 249 | (pprint-exit-if-list-exhausted) 250 | (write-char #\, stream) 251 | (write-char #\Space stream)))))) 252 | 253 | ;;;;;;;;;;;;;;; 254 | ;; TREE-SET ;; 255 | ;;;;;;;;;;;;;;; 256 | 257 | (defstruct (tree-set (:constructor %make-tree-set (%compare %root))) 258 | %compare 259 | %root) 260 | 261 | (defun tree-set-root (set) 262 | (etypecase set 263 | (tree-set (tree-set-%root set)))) 264 | 265 | (defun make-tree-set (compare) 266 | "Create a new tree-set." 267 | (%make-tree-set compare nil)) 268 | 269 | (defun empty-tree-set (tree-set) 270 | "Create a new empty tree-set." 271 | (%make-tree-set (tree-set-%compare tree-set) 272 | nil)) 273 | 274 | (defun tree-set (compare &rest args) 275 | "Create a new tree-set containing all items in ARGS." 276 | (flet ((helper (tree x) 277 | (wb-tree-insert tree x compare))) 278 | (declare (dynamic-extent (function helper))) 279 | (%make-tree-set compare 280 | (fold #'helper nil args)))) 281 | 282 | (defun tree-set-count (set) 283 | "Number of elements in SET." 284 | (wb-tree-count (tree-set-root set))) 285 | 286 | (defun map-tree-set (result-type function set) 287 | "Apply FUNCTION to every element of SET." 288 | (map-binary-tree :inorder result-type function (when set (tree-set-root set)))) 289 | 290 | (defmacro do-tree-set ((var set &optional result) &body body) 291 | (with-gensyms (helper) 292 | `(progn 293 | (flet ((,helper (,var) 294 | ,@body)) 295 | (declare (dynamic-extent (function ,helper))) 296 | (map-tree-set nil #',helper ,set)) 297 | ,result))) 298 | 299 | (defun fold-tree-set (function initial-value set) 300 | "Fold FUNCTION over every element of SET." 301 | (fold-binary-tree :inorder function initial-value (tree-set-root set))) 302 | 303 | 304 | (defun tree-set-remove-min (set) 305 | "Remove minimum element of SET." 306 | (declare (type tree-set set)) 307 | (multiple-value-bind (tree item) (wb-tree-remove-min (tree-set-root set)) 308 | (values (%make-tree-set (tree-set-%compare set) tree) 309 | item))) 310 | 311 | (defun tree-set-remove-max (set) 312 | "Remove maximum element of SET." 313 | (multiple-value-bind (tree item) (wb-tree-remove-max (tree-set-root set)) 314 | (values (%make-tree-set (tree-set-%compare set) tree) 315 | item))) 316 | 317 | (defun tree-set-remove-position (set i) 318 | "Remove element of SET and position I." 319 | (multiple-value-bind (tree item) 320 | (wb-tree-remove-position (tree-set-root set) i (tree-set-%compare set)) 321 | (values (%make-tree-set (tree-set-%compare set) tree) 322 | item))) 323 | 324 | 325 | (defmacro def-tree-set-item-op (name implementation-name doc) 326 | `(defun ,name (set item) 327 | ,doc 328 | (%make-tree-set (tree-set-%compare set) 329 | (,implementation-name (tree-set-root set) 330 | item 331 | (tree-set-%compare set))))) 332 | 333 | (def-tree-set-item-op tree-set-insert wb-tree-insert 334 | "Insert ITEM into SET.") 335 | 336 | (def-tree-set-item-op tree-set-replace wb-tree-replace 337 | "Replace ITEM into SET.") 338 | 339 | (def-tree-set-item-op tree-set-remove wb-tree-remove 340 | "Remove ITEM from SET.") 341 | 342 | (defmacro tree-set-insertf (place item) 343 | "Insert INTER into the tree set at PLACE, store at PLACE." 344 | `(progn 345 | (setf ,place 346 | (tree-set-insert ,place ,item)))) 347 | 348 | (defun (setf tree-set-find) (item set) 349 | "Destructively insert item into set." 350 | (setf (tree-set-%root set) 351 | (wb-tree-replace (tree-set-%root set) item 352 | (tree-set-%compare set)))) 353 | 354 | (defun tree-set-member-p (set item) 355 | "Is ITEM a member of SET?" 356 | (binary-tree-member-p (tree-set-root set) item (tree-set-%compare set))) 357 | 358 | (defun tree-set-find (set item) 359 | "Find ITEM in SET" 360 | (binary-tree-find (tree-set-root set) item (tree-set-%compare set))) 361 | 362 | (defun tree-set-intern (set item) 363 | "Add item to set, unless it already exists. 364 | RETURNS: (values NEW-SET NEW-ITEM)" 365 | (multiple-value-bind (set-item exists) 366 | (tree-set-find set item) 367 | (if exists 368 | (values set set-item) 369 | (values (tree-set-insert set item) 370 | item)))) 371 | 372 | 373 | (defmacro def-tree-set-binop (name implementation-name doc) 374 | `(defun ,name (set-1 set-2) 375 | ,doc 376 | (%make-tree-set (tree-set-%compare set-1) 377 | (,implementation-name (tree-set-root set-1) 378 | (tree-set-root set-2) 379 | (tree-set-%compare set-1))))) 380 | 381 | (def-tree-set-binop tree-set-union wb-tree-union 382 | "Union of SET-1 and SET-2.") 383 | (def-tree-set-binop tree-set-intersection wb-tree-intersection 384 | "Intersection of SET-1 and SET-2.") 385 | (def-tree-set-binop tree-set-difference wb-tree-difference 386 | "Difference of SET-1 and SET-2.") 387 | 388 | (defun tree-set-intersection-difference (tree-1 tree-2) 389 | "Simultanously compute intersection and difference." 390 | (let ((compare (tree-set-%compare tree-1))) 391 | (multiple-value-bind (i d) 392 | (wb-tree-intersection-difference (tree-set-root tree-1) 393 | (tree-set-root tree-2) 394 | compare) 395 | (values (%make-tree-set compare i) 396 | (%make-tree-set compare d))))) 397 | 398 | (defun tree-set-equal-p (set-1 set-2) 399 | "Do SET-1 and SET-2 contain the same elements?" 400 | (binary-tree-equal (tree-set-root set-1) 401 | (tree-set-root set-2) 402 | (tree-set-%compare set-1))) 403 | 404 | (defun tree-set-subset-p (set-1 set-2) 405 | "Is SET-1 as subset of SET-2?" 406 | (wb-tree-subset (tree-set-root set-1) 407 | (tree-set-root set-2) 408 | (tree-set-%compare set-1))) 409 | 410 | ;(declaim (ftype (function (tree-set tree-set) fixnum) tree-set-compare)) 411 | (defun tree-set-compare (tree-1 tree-2) 412 | "Order relation on sets." 413 | (wb-tree-compare (tree-set-root tree-1) (tree-set-root tree-2) 414 | (tree-set-%compare tree-1))) 415 | 416 | (defun tree-set-list (set) 417 | "Return list of elements in `SET' in comparison order." 418 | (let ((c (cons nil nil))) 419 | (declare (dynamic-extent c)) 420 | (fold-tree-set (lambda (cons x) 421 | (let ((cons-2 (cons x nil))) 422 | (rplacd cons cons-2) 423 | cons-2)) 424 | c set) 425 | (cdr c))) 426 | 427 | (defun tree-set-position (set value) 428 | "Return the position of `VALUE' in `SET' or NIL." 429 | (wb-tree-position (tree-set-root set) value (tree-set-%compare set))) 430 | 431 | (defun tree-set-ref (set subscript) 432 | "Return the element of `SET' at position `SUBSCRIPT'." 433 | (wb-tree-ref (tree-set-root set) subscript)) 434 | 435 | (defun tree-set-max (set) 436 | "Return the greatest item in SET." 437 | (binary-tree-max (tree-set-root set))) 438 | 439 | (defun tree-set-min (set) 440 | "Return the lest item in SET." 441 | (binary-tree-min (tree-set-root set))) 442 | 443 | (defmethod print-object ((object tree-set) stream) 444 | (print-unreadable-object (object stream :type t :identity nil) 445 | ;(print (tree-set-list object)) 446 | ;; Use format instead 447 | ;; (pprint-logical-block (stream (tree-set-list object) :prefix "{" :suffix "}") 448 | ;; (pprint-logical-block (stream (tree-set-list object) :prefix "{" :suffix "}") 449 | ;; (do () (nil) 450 | ;; (pprint-exit-if-list-exhausted) 451 | ;; (let ((x (pprint-pop))) 452 | ;; (pprint-newline :fill stream) 453 | ;; (pprint-indent :block 0 stream) 454 | ;; (write-char #\Space stream) 455 | ;; (write x :stream stream))))) 456 | 457 | ;; Doesn't get the spaces right 458 | ;; (do-tree-set (x object) 459 | ;; (pprint-newline :fill stream) 460 | ;; (pprint-indent :block 0 stream) 461 | ;; (write-char #\Space stream) 462 | ;; (write x :stream stream)) 463 | 464 | (format stream "~@<{~;~{~A~^ ~}~;}~:@>" 465 | (tree-set-list object)))) 466 | 467 | 468 | ;;;;;;;;;;;;;;; 469 | ;; Tree-Bag ;; 470 | ;;;;;;;;;;;;;;; 471 | 472 | (defstruct (tree-bag (:constructor %make-tree-bag (%compare root)) 473 | (:include root-tree))) 474 | 475 | (defun tree-bag-increment (value) 476 | (values 477 | (let ((key (car value)) 478 | (count (cdr value))) 479 | (declare (type unsigned-fixnum count)) 480 | (cons key (1+ count))) 481 | ;; always present 482 | t)) 483 | 484 | (defun tree-bag-decrement (value) 485 | (let ((key (car value)) 486 | (count (cdr value))) 487 | (declare (type unsigned-fixnum count)) 488 | (if (= count 0) 489 | (values nil nil) 490 | (values (cons key (1- count)))))) 491 | 492 | (defun %tree-bag-insert (tree compare x) 493 | (let ((x (cons x 0))) 494 | (wb-tree-modify tree x compare #'tree-bag-increment x))) 495 | 496 | (defun tree-bag (compare &rest args) 497 | (let ((compare (make-aux-compare compare))) 498 | (%make-tree-bag compare 499 | (fold (lambda (tree x) (%tree-bag-insert tree compare x)) 500 | nil 501 | args)))) 502 | 503 | (defun tree-bag-insert (tb x) 504 | (let ((x (cons x 0)) 505 | (compare (tree-bag-%compare tb))) 506 | (%make-tree-bag compare 507 | (wb-tree-modify (tree-bag-root tb) 508 | x compare #'tree-bag-increment x)))) 509 | 510 | (defun tree-bag-count (bag key) 511 | "Return count of `KEY' in `BAG'." 512 | (multiple-value-bind (cons present) 513 | (let ((key (cons key 0))) 514 | (binary-tree-find (tree-bag-root bag) key (tree-bag-%compare bag))) 515 | (if present 516 | (cdr cons) 517 | 0))) 518 | 519 | 520 | ;;;;;;;;;;;;;;; 521 | ;; Tree-Heap ;; 522 | ;;;;;;;;;;;;;;; 523 | 524 | ;;; This was a bad idea 525 | 526 | ;; (defstruct (tree-heap (:constructor %make-tree-heap (root cost))) 527 | ;; root 528 | ;; cost) 529 | 530 | ;; (defun new-tree-heap (heap root) 531 | ;; (%make-tree-heap root (tree-heap-cost heap))) 532 | 533 | ;; (defun make-tree-heap (cost-function) 534 | ;; (%make-tree-heap nil cost-function)) 535 | 536 | ;; (defun tree-heap-compare (a b) 537 | ;; (let ((c-a (car a)) 538 | ;; (c-b (car b))) 539 | ;; (cond 540 | ;; ((> c-a c-b) 1) 541 | ;; ((< c-a c-b) -1) 542 | ;; ((equalp (cdr a) (cdr b)) 0) 543 | ;; (t -1)))) 544 | 545 | ;; (defun tree-heap-empty-p (heap) 546 | ;; "Is HEAP empty?" 547 | ;; (null (tree-heap-root heap))) 548 | 549 | ;; (defun tree-heap-insert (heap value &optional (cost (funcall (tree-heap-cost heap) value))) 550 | ;; "Insert VALUE into HEAP." 551 | ;; (new-tree-heap heap 552 | ;; (wb-tree-reinsert (tree-heap-root heap) 553 | ;; (cons cost value) 554 | ;; #'tree-heap-compare))) 555 | 556 | ;; (defun tree-heap-find-min (heap) 557 | ;; (cdr (binary-tree-min (tree-heap-root heap)))) 558 | 559 | ;; (defun tree-heap-find-max (heap) 560 | ;; (cdr (binary-tree-max (tree-heap-root heap)))) 561 | 562 | ;; (defun tree-heap-remove-min (heap) 563 | ;; (multiple-value-bind (root value) (wb-tree-remove-min (tree-heap-root heap)) 564 | ;; (values (new-tree-heap heap root) (cdr value)))) 565 | 566 | ;; (defun tree-heap-remove-max (heap) 567 | ;; (multiple-value-bind (root value ) (wb-tree-remove-max (tree-heap-root heap)) 568 | ;; (values (new-tree-heap heap root) (cdr value)))) 569 | 570 | ;; (defun tree-heap-construct (cost-function elements) 571 | ;; (fold #'tree-heap-insert (make-tree-heap cost-function) 572 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | (defpackage :sycamore-util 38 | (:use :cl :alexandria) 39 | (:export 40 | unsigned-fixnum 41 | fixnum-compare 42 | double-compare 43 | string-compare 44 | bit-vector-compare 45 | fixnum-compare 46 | gsymbol-compare 47 | fold-n 48 | fold 49 | 50 | cond-compare 51 | if-less-eq-compare 52 | or-compare 53 | 54 | output-dot 55 | 56 | with-temp-array 57 | with-timing 58 | )) 59 | 60 | 61 | (defpackage :sycamore 62 | (:use :cl :sycamore-util :alexandria) 63 | (:export 64 | ;; tree sets 65 | make-tree-set tree-set tree-set-p 66 | map-tree-set fold-tree-set do-tree-set 67 | empty-tree-set 68 | tree-set-list 69 | tree-set-count 70 | tree-set-ref tree-set-position 71 | tree-set-insert tree-set-remove 72 | tree-set-replace 73 | tree-set-insertf 74 | tree-set-remove-min tree-set-remove-max tree-set-remove-position 75 | tree-set-union tree-set-intersection tree-set-difference 76 | tree-set-member-p tree-set-find 77 | tree-set-equal-p tree-set-subset-p tree-set-compare 78 | tree-set-intersection-difference 79 | tree-set-intern 80 | tree-set-max tree-set-min 81 | ;; tree map 82 | tree-map 83 | make-tree-map tree-map-insert tree-map-remove tree-map-find 84 | empty-tree-map 85 | tree-map-contains 86 | tree-map-insertf 87 | map-tree-map tree-map-count 88 | fold-tree-map 89 | do-tree-map 90 | alist-tree-map hash-table-tree-map 91 | tree-map-alist tree-map-hash-table 92 | tree-map-keys tree-map-values 93 | tree-map-insert-map 94 | tree-map-insert-alist 95 | tree-map-insert-hash-table 96 | ;; queues 97 | make-amortized-queue amortized-queue amortized-queue-empty-p 98 | amortized-enqueue amortized-dequeue amortized-queue-push 99 | amortized-queue-list 100 | ;; Ropes 101 | *rope-print* 102 | %rope rope ropep 103 | subrope 104 | rope-length rope-ref 105 | rope-string rope-write 106 | rope-pathname 107 | rope-compare-lexographic rope-compare-fast 108 | sexp-rope 109 | object-rope 110 | rope-map 111 | rope-split 112 | rope-parenthesize 113 | output-rope 114 | :rope= 115 | :rope/= 116 | :rope< 117 | :rope<= 118 | :rope> 119 | :rope>= 120 | ;; misc 121 | or-compare)) 122 | 123 | (defpackage :sycamore-cgen 124 | (:use :cl :sycamore-util :sycamore :alexandria) 125 | (:export 126 | :cgen-include-local 127 | :cgen-include-system 128 | :cgen-call 129 | :cgen-defun 130 | :cgen-exp 131 | :cgen-if 132 | :cgen-while 133 | :cgen-block 134 | :cgen-equal 135 | :cgen-assign 136 | :cgen-stmt 137 | :cgen-return 138 | :cgen-string 139 | :cgen-declare 140 | :cgen-declare-array 141 | :cgen-array-initializer 142 | :cgen-double-float 143 | :cgen-single-float 144 | :cgen-= 145 | :cgen-+ 146 | :cgen-- 147 | :cgen-* 148 | :cgen-/ 149 | :cgen-&& 150 | :cgen-& 151 | :cgen-addr 152 | :cgen-deref 153 | :cgen-sizeof 154 | :cgen-subscript 155 | :cgen-identifier 156 | :cgen-bit-or 157 | :cgen-log-or 158 | :cgen-comment 159 | :cgen-line-comment 160 | ;; convenience 161 | :cgen-call-stmt 162 | :cgen-assign-stmt 163 | :cgen-declare-fun 164 | )) 165 | -------------------------------------------------------------------------------- /src/queue.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | 41 | 42 | ;; From Okasaki "Purely Functional Data Structures" 43 | 44 | (defstruct (amortized-queue 45 | (:constructor %make-amortized-queue (forward reverse))) 46 | (forward nil :type list) 47 | (reverse nil :type list)) 48 | 49 | (defun make-amortized-queue () 50 | "Make a new queue." 51 | (%make-amortized-queue nil nil)) 52 | 53 | (defun amortized-queue (&rest args) 54 | "Create an amortized queue of ARGS." 55 | (%make-amortized-queue (copy-list args) nil)) 56 | 57 | (defun amortized-queue-empty-p (queue) 58 | "Is the queue empty?" 59 | (not (or (amortized-queue-forward queue) 60 | (amortized-queue-reverse queue)))) 61 | 62 | (defun amortized-enqueue (queue element) 63 | "Add ELEMENT to QUEUE. 64 | RETURNS: new-queue" 65 | (%make-amortized-queue (amortized-queue-forward queue) 66 | (cons element (amortized-queue-reverse queue)))) 67 | 68 | (defun amortized-dequeue (queue) 69 | "Remove first element of QUEUE. 70 | RETURNS: (VALUES new-queue element)" 71 | (let ((original-forward (amortized-queue-forward queue))) 72 | (multiple-value-bind (forward reverse) 73 | (if original-forward 74 | (values original-forward (amortized-queue-reverse queue)) 75 | (values (reverse (amortized-queue-reverse queue)) nil)) 76 | (values (%make-amortized-queue (cdr forward) reverse) 77 | (car forward))))) 78 | 79 | (defun amortized-queue-push (queue element) 80 | "Add ELEMENT to the front of QUEUE." 81 | (%make-amortized-queue (cons element (amortized-queue-forward queue)) 82 | (amortized-queue-reverse queue))) 83 | 84 | (defun amortized-queue-list (queue) 85 | "Return an inorder list of elements in QUEUE." 86 | (let (v) 87 | (loop until (amortized-queue-empty-p queue) 88 | do (multiple-value-setq (queue v) 89 | (amortized-dequeue queue)) 90 | collect v))) 91 | -------------------------------------------------------------------------------- /src/rope.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2015, Rice University 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Redistribution and use in source and binary forms, with or 7 | ;;;; without modification, are permitted provided that the following 8 | ;;;; conditions are met: 9 | ;;;; 10 | ;;;; * Redistributions of source code must retain the above 11 | ;;;; copyright notice, this list of conditions and the following 12 | ;;;; disclaimer. 13 | ;;;; * Redistributions in binary form must reproduce the above 14 | ;;;; copyright notice, this list of conditions and the following 15 | ;;;; disclaimer in the documentation and/or other materials 16 | ;;;; provided with the distribution. 17 | ;;;; * Neither the name of copyright holder the names of its 18 | ;;;; contributors may be used to endorse or promote products 19 | ;;;; derived from this software without specific prior written 20 | ;;;; permission. 21 | ;;;; 22 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 23 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 24 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 25 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 27 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 28 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 29 | ;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 30 | ;;;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 31 | ;;;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | ;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | ;;;; POSSIBILITY OF SUCH DAMAGE. 35 | 36 | (in-package :sycamore) 37 | 38 | ;;(declaim (optimize (speed 3) (safety 0))) 39 | 40 | ;;; TODO: optimizations 41 | ;;; - collapse small ropes into simple-strings 42 | ;;; - height-balance ropes 43 | ;;; - use heap-based stack for very deep ropes 44 | 45 | (deftype rope () 46 | `(or string symbol rope-node character null)) 47 | 48 | (defun ropep (object) 49 | (typep object 'rope)) 50 | 51 | (deftype rope-length-type () `non-negative-fixnum) 52 | (deftype rope-height-type () `(integer 1 #.most-positive-fixnum)) 53 | 54 | (defstruct rope-node 55 | (length 0 :type rope-length-type) 56 | (height 1 :type rope-height-type) 57 | (left nil :type rope) 58 | (right nil :type rope)) 59 | 60 | (declaim (inline object-rope-check)) 61 | (defgeneric object-rope (object)) 62 | 63 | (defun object-rope-check (object) 64 | "Call (OBJECT-ROPE OBJECT) and check that result is a rope" 65 | (let ((result (object-rope object))) 66 | (check-type result rope) 67 | result)) 68 | 69 | 70 | (declaim (ftype (function (rope) rope-length-type) rope-length)) 71 | (defun rope-length (rope) 72 | "Return the number of characters in rope" 73 | (etypecase rope 74 | (rope-node (rope-node-length rope)) 75 | (simple-string (length rope)) 76 | (string (length rope)) 77 | (null 0) 78 | (symbol (length (symbol-name rope))) 79 | (character 1))) 80 | 81 | (declaim (ftype (function (rope) non-negative-fixnum) rope-height)) 82 | (defun rope-height (rope) 83 | "Return height of rope" 84 | (etypecase rope 85 | ((or string symbol character) 0) 86 | (rope-node (rope-node-height rope)))) 87 | 88 | (declaim (inline %rope-helper)) 89 | (defun %rope-helper (rope) 90 | (labels ((rope-node-helper (rope) 91 | (values rope 92 | (rope-node-length rope) 93 | (rope-node-height rope))) 94 | (rec (rope) 95 | (etypecase rope 96 | (rope-node (rope-node-helper rope)) 97 | (simple-string 98 | (values rope (length rope) 0)) 99 | (string 100 | (values rope (length rope) 0)) 101 | (null 102 | (values nil 0 0)) 103 | (symbol 104 | (values rope 105 | (length (symbol-name rope)) 106 | 0)) 107 | (character (values rope 1 0)) 108 | (list 109 | (rec (rope-list-cat rope))) 110 | (array 111 | (rec (rope-array-cat rope))) 112 | (t (rec (object-rope-check rope)))))) 113 | (rec rope))) 114 | 115 | (declaim (ftype (function (t t) rope) %rope)) 116 | 117 | (defun %rope (first second) 118 | "Construct a rope from FIRST and SECOND. 119 | FIRST: an object of rope or sequence type 120 | SECOND: an object of rope or sequence type 121 | RETURNS: a rope concatenating FIRST and SECOND" 122 | (multiple-value-bind (first length-1 height-1) 123 | (%rope-helper first) 124 | (multiple-value-bind (second length-2 height-2) 125 | (%rope-helper second) 126 | (cond ((zerop length-1) 127 | second) 128 | ((zerop length-2) 129 | first) 130 | (t 131 | (make-rope-node :length (+ length-1 length-2) 132 | :height (1+ (max height-1 height-2)) 133 | :left first 134 | :right second)))))) 135 | 136 | (declaim (ftype (function (list) rope) rope-list-cat)) 137 | (defun rope-list-cat (list) 138 | (if (null (cddr list)) 139 | (%rope (first list) (second list)) 140 | (rope-list-cat (loop for rest = list then (cddr rest) 141 | while rest 142 | collect (%rope (first rest) (second rest)))))) 143 | 144 | (declaim (ftype (function (array &key 145 | (:start fixnum) 146 | (:end fixnum)) 147 | rope) 148 | rope-array-cat)) 149 | 150 | (defun rope-array-cat (array 151 | &key 152 | (start 0) 153 | (end (length array))) 154 | (declare (type non-negative-fixnum start end) 155 | (type array array)) 156 | (cond 157 | ((= (1+ start) end) 158 | (aref array start)) 159 | ((>= start end) 160 | nil) 161 | (t 162 | (let ((midpoint (truncate (+ start end) 2))) 163 | (%rope (rope-array-cat array :start start :end midpoint) 164 | (rope-array-cat array :start midpoint :end end)))))) 165 | 166 | 167 | (declaim (inline rope) 168 | (ftype (function * rope) rope)) 169 | (defun rope (&rest args) 170 | "Concatenate all ropes in ARGS. 171 | 172 | Arguments of sequence type will be flattened and concatanted into the 173 | rope. Other non-rope arguments will be coerced to a rope type by 174 | calling the OBJECT-ROPE generic function. 175 | 176 | 177 | RETURNS: a rope" 178 | (declare (dynamic-extent args)) 179 | (when args (rope-list-cat args))) 180 | 181 | (declaim (ftype (function (t) rope) rope-1)) 182 | (defun rope-1 (rope) 183 | (etypecase rope 184 | (rope rope) 185 | (list 186 | (rope-list-cat rope)) 187 | (array 188 | (rope-array-cat rope)) 189 | (t (object-rope-check rope)))) 190 | 191 | 192 | (declaim (inline rope-2)) 193 | (defun rope-2 (a1 a2) 194 | (%rope a1 a2)) 195 | 196 | (defun rope-3 (a1 a2 a3) 197 | (%rope a1 198 | (%rope a2 a3))) 199 | 200 | (defun rope-4 (a1 a2 a3 a4) 201 | (%rope (%rope a1 a2) 202 | (%rope a3 a4))) 203 | (defun rope-5 (a1 a2 a3 a4 a5) 204 | (%rope (%rope a1 a2) 205 | (%rope a3 206 | (%rope a4 a5)))) 207 | (defun rope-6 (a1 a2 a3 a4 a5 a6) 208 | (%rope (%rope a1 a2) 209 | (%rope (%rope a3 a4) 210 | (%rope a5 211 | a6)))) 212 | (defun rope-7 (a1 a2 a3 a4 a5 a6 a7) 213 | (%rope (%rope a1 214 | (%rope a2 a3)) 215 | (%rope (%rope a4 a5) 216 | (%rope a6 a7)))) 217 | (defun rope-8 (a1 a2 a3 a4 a5 a6 a7 a8) 218 | (%rope (%rope (%rope a1 a2) 219 | (%rope a3 a4)) 220 | (%rope (%rope a5 a6) 221 | (%rope a7 a8)))) 222 | 223 | ;; A compiler macro to reduce dispatching when constructing ropes 224 | (define-compiler-macro rope (&whole form &rest args) 225 | (case (length args) 226 | (0 nil) 227 | (1 `(rope-1 ,(car args))) 228 | (2 `(rope-2 ,@args)) 229 | (3 `(rope-3 ,@args)) 230 | (4 `(rope-4 ,@args)) 231 | (5 `(rope-5 ,@args)) 232 | (6 `(rope-6 ,@args)) 233 | (7 `(rope-7 ,@args)) 234 | (8 `(rope-8 ,@args)) 235 | (otherwise form))) 236 | 237 | (declaim (ftype (function (rope &key (:element-type symbol)) simple-string) 238 | rope-string)) 239 | (defun rope-string (rope &key (element-type 'character)) 240 | "Convert the rope to a string." 241 | (let ((string (make-string (rope-length rope) 242 | :element-type element-type))) 243 | (labels ((visit-string (rope i) 244 | (replace string rope :start1 i) 245 | (+ i (length rope))) 246 | (visit (rope i) 247 | (etypecase rope 248 | (rope-node 249 | (visit (rope-node-right rope) 250 | (visit (rope-node-left rope) i))) 251 | (simple-string 252 | (visit-string rope i)) 253 | (string 254 | (visit-string rope i)) 255 | (null i) 256 | (symbol (visit-string (symbol-name rope) i)) 257 | (character 258 | (setf (schar string i) rope) 259 | (1+ i))))) 260 | (declare (dynamic-extent #'visit-string #'visit)) 261 | (visit rope 0)) 262 | string)) 263 | 264 | 265 | (declaim (ftype (function ((or rope pathname)) pathname) 266 | rope-pathname)) 267 | 268 | (defun rope-pathname (rope) 269 | "Convert the rope to a pathname." 270 | (if (pathnamep rope) 271 | rope 272 | (pathname (rope-string rope)))) 273 | 274 | (defun subrope (rope &key 275 | (start 0) 276 | end 277 | copy) 278 | "Return the subrope of ROPE, 279 | beginning with element number START 280 | and continuing up to element number END. 281 | 282 | START: initial element number of the subrope 283 | END: one past the final element number of the subrope 284 | COPY: if true, copy leaf strings" 285 | (declare (type fixnum start) 286 | (type (or fixnum null) end)) 287 | ;; (print (list rope start end)) 288 | (let ((helper (if copy 289 | #'subseq 290 | (lambda (rope start end) 291 | (make-array (- (or end (length rope)) start) 292 | :element-type (array-element-type rope) 293 | :displaced-to rope 294 | :displaced-index-offset start))))) 295 | (etypecase rope 296 | (simple-string (funcall helper rope start end)) 297 | (string (funcall helper rope start end)) 298 | (null (unless (and (zerop start) (zerop end)) 299 | (error "Cannot find subrope of ~A" rope)) 300 | rope) 301 | (symbol (subseq (symbol-name rope) start end)) 302 | (rope-node 303 | (let* ((end (or end (rope-node-length rope))) 304 | (left (rope-node-left rope)) 305 | (right (rope-node-right rope)) 306 | (left-count (rope-length left))) 307 | (cond 308 | ((<= end left-count) 309 | (subrope left :start start :end end :copy copy)) 310 | ((>= start left-count) 311 | (subrope right 312 | :start (- start left-count) 313 | :end (- end left-count) 314 | :copy copy)) 315 | (t (rope (subrope left :start start :end left-count :copy copy) 316 | (subrope right :start 0 :end (- end left-count) :copy copy))))))))) 317 | 318 | 319 | 320 | (defun rope-ref (rope i) 321 | "Return the character at position I." 322 | (declare (type rope rope) 323 | (type non-negative-fixnum i)) 324 | (etypecase rope 325 | (rope-node 326 | (let* ((left (rope-node-left rope)) 327 | (left-length (rope-length left))) 328 | (if (< i left-length) 329 | (rope-ref left i) 330 | (rope-ref (rope-node-right rope) 331 | (- i left-length))))) 332 | (simple-string (aref rope i)) 333 | (string (aref rope i)) 334 | (symbol (aref (symbol-name rope) i)))) 335 | 336 | (defun rope-write (rope &key 337 | (escape *print-escape*) 338 | (stream *standard-output*)) 339 | "Write ROPE to STREAM." 340 | (labels ((rec (rope) 341 | (etypecase rope 342 | (rope-node (rec (rope-node-left rope)) 343 | (rec (rope-node-right rope))) 344 | (simple-string (write-sequence rope stream)) 345 | (string (write-sequence rope stream)) 346 | (null nil) 347 | (symbol (write-sequence (symbol-name rope) stream)) 348 | (character (write-char rope stream)) 349 | (sequence (map nil #'rec rope))))) 350 | (declare (dynamic-extent #'rec)) 351 | (if escape 352 | (progn (write-char #\" stream) 353 | (rec rope) 354 | (write-char #\" stream)) 355 | (rec rope))) 356 | (values)) 357 | 358 | (defun output-rope (object place 359 | &key 360 | ;directory 361 | if-exists) 362 | (let ((object (rope object))) 363 | (labels ((helper (place) 364 | (rope-write object :stream place :escape nil) 365 | (values)) 366 | (path-helper (place) 367 | (ensure-directories-exist place) 368 | (with-open-file (s place :direction :output 369 | :if-exists if-exists 370 | :if-does-not-exist :create) 371 | (helper s)))) 372 | (cond 373 | ((streamp place) 374 | (helper place)) 375 | ((eq place t) 376 | (helper *standard-output*)) 377 | ((null place) 378 | object) 379 | ((ropep place) 380 | (path-helper (rope-string place))) 381 | ((pathnamep place) 382 | (path-helper place)) 383 | (t (error "Unknown place type: ~A" place)))))) 384 | 385 | (defvar *rope-print* :rope 386 | "How to print ropes, one of (or :rope :string :structure)") 387 | (declaim (type (member :rope :string :structure) *rope-print*)) 388 | 389 | (defmethod print-object ((object rope-node) stream) 390 | (ecase *rope-print* 391 | (:rope (print-unreadable-object (object stream :type nil :identity nil) 392 | (princ "ROPE " stream) 393 | (rope-write object :stream stream :escape t))) 394 | (:string (rope-write object :stream stream)) 395 | (:structure (call-next-method object stream)))) 396 | 397 | ;;; Iteration ;;; 398 | (defstruct rope-iterator 399 | (i 0 :type non-negative-fixnum) 400 | (stack nil :type list)) 401 | 402 | (defun rope-iterator-push (itr rope) 403 | (declare (type rope rope)) 404 | (etypecase rope 405 | (null itr) 406 | (string 407 | (push rope (rope-iterator-stack itr)) 408 | itr) 409 | (symbol 410 | (push (symbol-name rope) (rope-iterator-stack itr)) 411 | itr) 412 | (rope-node 413 | (push rope (rope-iterator-stack itr)) 414 | (rope-iterator-push itr (rope-node-left rope))))) 415 | 416 | (defun rope-iterator-pop (itr) 417 | (let* ((popped (pop (rope-iterator-stack itr))) 418 | (top (car (rope-iterator-stack itr)))) 419 | (when (stringp popped) 420 | (assert (= (length popped) (rope-iterator-i itr))) 421 | (setf (rope-iterator-i itr) 0)) 422 | (if (null top) 423 | itr 424 | (let ((left (rope-node-left top)) 425 | (right (rope-node-right top))) 426 | (cond 427 | ((eq popped left) 428 | (rope-iterator-push itr right)) 429 | ((eq popped right) 430 | (rope-iterator-pop itr)) 431 | (t (error "Popped node is orphaned."))))))) 432 | 433 | (defun rope-iterator-next (itr) 434 | (let ((top (car (rope-iterator-stack itr))) 435 | (i (rope-iterator-i itr))) 436 | (declare (type (or null string) top)) 437 | (cond 438 | ((null top) nil) 439 | ((= i (length top)) 440 | (rope-iterator-next (rope-iterator-pop itr))) 441 | ((< i (length top)) 442 | (prog1 (aref top i) 443 | (incf (rope-iterator-i itr)))) 444 | (t (error "Invalid index during rope iteration."))))) 445 | 446 | (defun rope-iterator (rope) 447 | (rope-iterator-push (make-rope-iterator) rope)) 448 | 449 | ;;; Comparisons ;;; 450 | 451 | (defun rope-compare-lexographic (rope-1 rope-2) 452 | "Compare ropes lexographically." 453 | (let ((itr-1 (rope-iterator rope-1)) 454 | (itr-2 (rope-iterator rope-2))) 455 | 456 | (loop 457 | for a = (rope-iterator-next itr-1) 458 | for b = (rope-iterator-next itr-2) 459 | while (and (and a b) 460 | (eql a b)) 461 | finally (return (if a 462 | (if b 463 | (- (char-code a) 464 | (char-code b)) 465 | 1) 466 | (if b -1 0)))))) 467 | 468 | (defun rope-compare-fast (rope-1 rope-2) 469 | "Compare ropes quickly. 470 | 471 | The resulting order is not necessarily lexographic." 472 | (if (eq rope-1 rope-2) 473 | 0 474 | (let ((n-1 (rope-length rope-1)) 475 | (n-2 (rope-length rope-2))) 476 | (if (= n-1 n-2) 477 | ;; Compare equal length ropes lexigraphically 478 | (rope-compare-lexographic rope-1 rope-2) 479 | ;; Compare different length ropes by size 480 | (- n-1 n-2))))) 481 | 482 | (defun rope= (rope-1 rope-2) 483 | (zerop (rope-compare-fast rope-1 rope-2))) 484 | 485 | (defun rope/= (rope-1 rope-2) 486 | (not (rope= rope-1 rope-2))) 487 | 488 | (defun rope< (rope-1 rope-2) 489 | (< (rope-compare-lexographic rope-1 rope-2) 0)) 490 | 491 | (defun rope<= (rope-1 rope-2) 492 | (<= (rope-compare-lexographic rope-1 rope-2) 0)) 493 | 494 | (defun rope> (rope-1 rope-2) 495 | (> (rope-compare-lexographic rope-1 rope-2) 0)) 496 | 497 | (defun rope>= (rope-1 rope-2) 498 | (>= (rope-compare-lexographic rope-1 rope-2) 0)) 499 | 500 | 501 | (declaim (ftype (function (list &key (:symbol-function function)) rope) 502 | sexp-rope)) 503 | (defun sexp-rope (sexp &key 504 | symbol-function) 505 | "Construct a rope representing S-Expression SEXP. 506 | 507 | SYMBOL-FUNCTION: A function to transform symbols in the rope. 508 | (lambda (symbol)) => rope 509 | RETURNS: a rope" 510 | 511 | (declare (type list sexp) 512 | (type (or function null) symbol-function)) 513 | (let ((rope '|(| )) 514 | (loop 515 | for rest on sexp 516 | for first = (car rest) 517 | do 518 | (setq rope 519 | (rope rope 520 | (etypecase first 521 | (cons (sexp-rope first :symbol-function symbol-function)) 522 | (symbol 523 | (if symbol-function 524 | (funcall symbol-function first) 525 | first)) 526 | (string first) 527 | (rope first) 528 | (fixnum (format nil "~D" first))) 529 | (if (cdr rest) 530 | '| | 531 | '|)|)))) 532 | rope)) 533 | 534 | 535 | (defmethod object-rope ((object string)) 536 | object) 537 | 538 | (defmethod object-rope ((object rope-node)) 539 | object) 540 | 541 | (defmethod object-rope ((object character)) 542 | object) 543 | 544 | (defmethod object-rope ((object symbol)) 545 | object) 546 | 547 | (defmethod object-rope ((object list)) 548 | (rope-list-cat object)) 549 | 550 | (defmethod object-rope ((object array)) 551 | (rope-array-cat object)) 552 | 553 | (defmethod object-rope ((object float)) 554 | (format nil "~F" object)) 555 | 556 | (defmethod object-rope ((object double-float)) 557 | (format nil "~F" object)) 558 | 559 | (defmethod object-rope ((object pathname)) 560 | (namestring object)) 561 | 562 | ;; default to using the lisp printer to get a string 563 | (defmethod object-rope ((object t)) 564 | (princ-to-string object)) 565 | 566 | (defun rope-split (separator sequence 567 | &key 568 | (start 0) 569 | (end (length sequence))) 570 | (if (<= end start) 571 | nil 572 | (flet ((f (a b) 573 | (rope a separator b))) 574 | (declare (dynamic-extent #'f)) 575 | (reduce #'f sequence :start start :end end :from-end t)))) 576 | 577 | 578 | (defun rope-map (function sequence 579 | &key 580 | (start 0) 581 | (end (length sequence)) 582 | separator) 583 | "Apply FUNCTION to each element of SEQUENCE and collect results into a rope. 584 | 585 | FUNCTION: (lambda (x)) => ROPE 586 | SEQUENCE: a sequence 587 | START: initial position in SEQUENCE 588 | END: final position in SEQUENCE 589 | SEPARATOR: a rope to splice between the items of SEQUENCE 590 | 591 | RETURNS: a rope" 592 | (declare (type function function)) 593 | (if (>= start end) 594 | "" 595 | (flet ((map-sep (item) 596 | (%rope separator (funcall function item)))) 597 | (declare (dynamic-extent #'map-sep)) 598 | (let ((sep-fun (if separator #'map-sep function))) 599 | (with-temp-array (tmp (- end start)) 600 | (etypecase sequence 601 | (list (let ((begin (nthcdr start sequence))) 602 | (setf (aref tmp 0) 603 | (funcall function (first begin))) 604 | (loop 605 | for i from 1 below (length tmp) 606 | for x in (cdr begin) 607 | do (setf (aref tmp i) 608 | (funcall sep-fun x))))) 609 | (array (setf (aref tmp 0) 610 | (funcall function (aref sequence start))) 611 | (loop for i from 1 612 | for j from (1+ start) below end 613 | do (setf (aref tmp i) 614 | (funcall sep-fun (aref sequence j)))))) 615 | (rope-array-cat tmp)))))) 616 | 617 | (defun rope-parenthesize (rope) 618 | "Return the parenthesized ROPE." 619 | (rope #\( rope #\))) 620 | -------------------------------------------------------------------------------- /src/sycamore.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | 39 | 40 | (asdf:defsystem sycamore 41 | :version "0.0.20120604" 42 | :description "A fast, purely functional data structure library" 43 | :depends-on (:cl-ppcre :alexandria) 44 | :license :bsd-3 45 | :homepage "http://ndantam.github.io/sycamore" 46 | :source-control "https://github.com/ndantam/sycamore" 47 | :author "Neil T. Dantam" 48 | :weakly-depends-on (:lisp-unit :cl-fuzz) 49 | :components ((:file "package") 50 | (:file "util" :depends-on ("package")) 51 | (:file "heap" :depends-on ("util")) 52 | (:file "queue" :depends-on ("util")) 53 | (:file "array" :depends-on ("util")) 54 | (:file "binary" :depends-on ("util" "array")) 55 | (:file "wb-tree" :depends-on ("binary" "array")) 56 | ;;(:file "ttree" :depends-on ("avl")) 57 | (:file "interfaces" :depends-on ("wb-tree")) 58 | (:file "rope" :depends-on ("util")) 59 | (:file "cgen" :depends-on ("rope"))) 60 | :long-description 61 | "Sycamore is a purely functional data structure library in Common 62 | Lisp. It include fast, weight-balanced binary trees, set and 63 | map (dictionary) interfaces, pairing heaps, and amortized queues." ) 64 | -------------------------------------------------------------------------------- /src/tree.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | ;;(declaim (optimize (speed 3) (safety 0))) 41 | 42 | 43 | ;;;;;;;;;;;;;;; 44 | ;; RED-BLACK ;; 45 | ;;;;;;;;;;;;;;; 46 | 47 | ;; Based on Chris Okasaki's Functional red-black trees 48 | ;; (defstruct (red-black 49 | ;; (:include binary-tree) 50 | ;; (:constructor make-red-black (red left value right))) 51 | ;; (red nil :type boolean)) 52 | 53 | ;; (defun red-black-redp (tree) 54 | ;; (red-black-red tree)) 55 | 56 | ;; (defun red-black-blackp (tree) 57 | ;; (not (red-black-redp tree))) 58 | 59 | ;; (defun red-black-color (red tree) 60 | ;; (make-red-black red 61 | ;; (red-black-left tree) 62 | ;; (red-black-value tree) 63 | ;; (red-black-right tree))) 64 | 65 | ;; (defun balance-red-black (red left value right) 66 | ;; (labels ((when-red (tree) 67 | ;; (when (red-black-p tree) (red-black-redp tree))) 68 | ;; (balanced-tree (a x b y c z d) 69 | ;; ;(declare (type red-black a b c d)) 70 | ;; (make-red-black t 71 | ;; (make-red-black nil a x b) 72 | ;; y 73 | ;; (make-red-black nil c z d)))) 74 | ;; (let* ((b (null red)) 75 | ;; (l (when-red left)) 76 | ;; (r (when-red right)) 77 | ;; (ll (when-red (when (red-black-p left) (red-black-left left )))) 78 | ;; (lr (when-red (when (red-black-p left) (red-black-right left)))) 79 | ;; (rl (when-red (when (red-black-p right) (red-black-left right)))) 80 | ;; (rr (when-red (when (red-black-p right) (red-black-right right))))) 81 | ;; (declare (type boolean b l r ll lr rl rr)) 82 | ;; (cond 83 | ;; ((and b l ll) 84 | ;; (balanced-tree (binary-tree-left-left left) 85 | ;; (binary-tree-value-left left) 86 | ;; (binary-tree-right-left left) 87 | ;; (binary-tree-value left) 88 | ;; (binary-tree-right left) 89 | ;; value 90 | ;; right)) 91 | ;; ((and b l lr) 92 | ;; (balanced-tree (binary-tree-left left) 93 | ;; (binary-tree-value left) 94 | ;; (binary-tree-left-right left) 95 | ;; (binary-tree-value-right left) 96 | ;; (binary-tree-right-right left) 97 | ;; value 98 | ;; right )) 99 | ;; ((and b r rl) 100 | ;; (balanced-tree left 101 | ;; value 102 | ;; (binary-tree-left-left right) 103 | ;; (binary-tree-value-left right) 104 | ;; (binary-tree-right-left right) 105 | ;; (binary-tree-value right) 106 | ;; (binary-tree-right right))) 107 | ;; ((and b r rr) 108 | ;; (balanced-tree left 109 | ;; value 110 | ;; (binary-tree-left right) 111 | ;; (binary-tree-value right) 112 | ;; (binary-tree-left-right right) 113 | ;; (binary-tree-value-right right) 114 | ;; (binary-tree-right-right right))) 115 | ;; (t 116 | ;; (make-red-black red left value right)))))) 117 | 118 | ;; (defun red-black-insert (value tree compare test) 119 | ;; (labels ((ins (tree) 120 | ;; (cond 121 | ;; ((null tree) (make-red-black t nil value nil)) 122 | ;; ((funcall compare value (red-black-value tree)) 123 | ;; (balance-red-black (red-black-red tree) 124 | ;; (ins (red-black-left tree)) 125 | ;; (red-black-value tree) 126 | ;; (red-black-right tree))) 127 | ;; ((funcall test value (red-black-value tree)) 128 | ;; tree) 129 | ;; (t (balance-red-black (red-black-red tree) 130 | ;; (red-black-left tree) 131 | ;; (red-black-value tree) 132 | ;; (ins (red-black-right tree))))))) 133 | ;; (red-black-color nil (ins tree)))) 134 | -------------------------------------------------------------------------------- /src/trie.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sycamore) 2 | 3 | 4 | (defstruct trie 5 | prefix 6 | suffixes 7 | present 8 | value 9 | ) 10 | 11 | (defun trie-value-node (prefix present value suffixes) 12 | (make-trie :prefix prefix 13 | :present present 14 | :value value 15 | :suffixes suffixes)) 16 | 17 | 18 | (defun make-trie-compare (compare-element) 19 | (lambda (trie-a trie-b) 20 | (labels ((get-element (trie) 21 | (etypecase trie 22 | (list (car trie)) 23 | (trie (car (trie-prefix trie)))))) 24 | (funcall compare-element (get-element trie-a) (get-element trie-b))))) 25 | 26 | (defun prefix-split (a b &optional (test #'eql)) 27 | "Split the common prefixes and disjoint suffixes in A and B." 28 | (declare (type function test) 29 | (type list a b)) 30 | (let ((a-suffix nil) 31 | (b-suffix nil)) 32 | (let ((new-prefix 33 | (loop 34 | for a-rest on a 35 | for b-rest on b 36 | for aa = (car a-rest) 37 | for bb = (car b-rest) 38 | for test-res = (funcall test aa bb) 39 | while test-res 40 | collect aa 41 | finally (if test-res 42 | (setq a-suffix (cdr a-rest) 43 | b-suffix (cdr b-rest)) 44 | (setq a-suffix a-rest 45 | b-suffix b-rest))))) 46 | (values new-prefix a-suffix b-suffix)))) 47 | 48 | (defun trie-insert (trie key &key value compare (test #'eql)) 49 | (labels ((rec-cons (trie key) 50 | (multiple-value-bind (new-prefix trie-suffix key-suffix) 51 | (prefix-split trie key test) 52 | (trie-value-node new-prefix 53 | (or (null trie-suffix) (null key-suffix)) 54 | nil 55 | (cond ((null trie-suffix) key-suffix) 56 | ((null key-suffix) trie-suffix) 57 | (t (cond-compare ((car trie-suffix) (car key-suffix) compare) 58 | (vector trie-suffix key-suffix) 59 | (error "Invalid comparison result") 60 | (vector key-suffix trie-suffix))))))) 61 | (rec-trie (trie key value) 62 | (multiple-value-bind (new-prefix trie-suffix key-suffix) 63 | (prefix-split (trie-prefix trie) key test) 64 | (cond 65 | ((null key-suffix) 66 | ;; insert key into this node 67 | (trie-value-node new-prefix 68 | t 69 | value 70 | (rec (trie-suffixes trie) trie-suffix (trie-value trie)))) 71 | ;; This node retains its key and value 72 | ((null trie-suffix) 73 | (trie-value-node new-prefix 74 | (trie-present trie) 75 | (trie-value trie) 76 | (rec (trie-suffixes trie) key-suffix value))) 77 | ;; push this key and value down to suffixes 78 | (t 79 | (rec (rec (trie-suffixes trie) key-suffix (trie-value trie)) 80 | key 81 | value))))) 82 | (rec-array (trie key value) 83 | (wb-tree-modify-vector trie key (make-trie-compare compare) 84 | (lambda (trie) 85 | (values (rec trie key value) 86 | t)) 87 | nil)) 88 | (rec-tree (trie key value) 89 | (wb-tree-modify trie value (make-trie-compare compare) 90 | (lambda (trie) 91 | (values (rec trie key value) 92 | t)))) 93 | (rec (trie key value) 94 | (if key 95 | (etypecase trie 96 | (null (if value 97 | (trie-value-node key t value nil) 98 | key)) 99 | (cons 100 | (assert (null value) () "Cannot insert value into list trie") 101 | (rec-cons trie key)) 102 | (trie 103 | (rec-trie trie key value)) 104 | (simple-vector 105 | (rec-array trie key value)) 106 | (wb-tree 107 | (rec-tree trie key value)))))) 108 | 109 | ;; null key 110 | (rec trie key value))) 111 | -------------------------------------------------------------------------------- /src/trim.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (defun wb-tree-trim (tree lo hi compare) 39 | "Return subtree rooted between `lo' and `hi'." 40 | (declare (type function compare)) 41 | ;(declare (optimize (speed 3) (safety 0))) 42 | (cond 43 | ((null tree) nil) 44 | ((< (the fixnum (funcall compare (binary-tree-value tree) lo)) 0) 45 | (wb-tree-trim (binary-tree-right tree) lo hi compare)) 46 | ((< (the fixnum (funcall compare hi (binary-tree-value tree))) 0) 47 | (wb-tree-trim (binary-tree-left tree) lo hi compare)) 48 | (t tree))) 49 | 50 | ;; root between lo and +infinity 51 | (defun wb-tree-trim-lo (tree lo compare) 52 | (declare (type function compare)) 53 | (cond 54 | ((null tree) nil) 55 | ((< (funcall compare lo (binary-tree-value tree)) 0) 56 | tree) 57 | (t (wb-tree-trim-lo (wb-tree-right tree) lo compare)))) 58 | 59 | 60 | ;; root between -infinity and hi 61 | (defun wb-tree-trim-hi (tree hi compare) 62 | (declare (type function compare)) 63 | (cond 64 | ((null tree) nil) 65 | ((> (funcall compare hi (binary-tree-value tree)) 0) 66 | tree) 67 | (t (wb-tree-trim-hi (wb-tree-left tree) hi compare)))) 68 | 69 | 70 | (defun wb-tree-split-less (tree x compare) 71 | "Everything in tree before than x" 72 | (declare (type function compare)) 73 | (cond-wb-tree-compare (x tree compare) 74 | nil 75 | (wb-tree-split-less (binary-tree-left tree) x compare) 76 | (binary-tree-left tree) 77 | (join-wb-tree (binary-tree-left tree) 78 | (binary-tree-value tree) 79 | (wb-tree-split-less (binary-tree-right tree) x compare) 80 | compare))) 81 | 82 | 83 | (defun wb-tree-split-greater (tree x compare) 84 | "Everything in tree after than x" 85 | (declare (type function compare)) 86 | ;(declare (optimize (speed 3) (safety 0))) 87 | (cond-wb-tree-compare (x tree compare) 88 | nil 89 | (join-wb-tree (wb-tree-split-greater (binary-tree-left tree) x compare) 90 | (binary-tree-value tree) 91 | (binary-tree-right tree) 92 | compare) 93 | (binary-tree-right tree) 94 | (wb-tree-split-greater (binary-tree-right tree) x compare))) 95 | 96 | 97 | ;; tree-2 rooted between lo and hi 98 | (defun wb-tree-uni-bd (tree-1 tree-2 lo hi compare) 99 | (declare (type function compare)) 100 | (let ((tree-2 (wb-tree-trim tree-2 lo hi compare))) 101 | (cond 102 | ((null tree-2) tree-1) 103 | ((null tree-1) 104 | (join-wb-tree (wb-tree-split-greater (wb-tree-left tree-2) lo compare) 105 | (wb-tree-value tree-2) 106 | (wb-tree-split-less (wb-tree-right tree-2) hi compare) 107 | compare)) 108 | (t (join-wb-tree (wb-tree-uni-bd (wb-tree-left tree-1) 109 | tree-2 lo (wb-tree-value tree-1) compare) 110 | (wb-tree-value tree-1) 111 | (wb-tree-uni-bd (wb-tree-right tree-1) 112 | tree-2 (wb-tree-value tree-1) hi compare) 113 | compare))))) 114 | 115 | ;; tree-2 between -inf and hi 116 | (defun wb-tree-uni-hi (tree-1 tree-2 hi compare) 117 | (let ((tree-2 (wb-tree-trim-hi tree-2 hi compare))) 118 | (cond 119 | ((null tree-2) tree-1) 120 | ((null tree-1) (wb-tree-split-less tree-2 hi compare)) 121 | (t (join-wb-tree (wb-tree-uni-hi (wb-tree-left tree-1) tree-2 (wb-tree-value tree-1) compare) 122 | (wb-tree-value tree-1) 123 | (wb-tree-uni-bd (wb-tree-right tree-1) tree-2 (wb-tree-value tree-1) hi compare) 124 | compare))))) 125 | 126 | ;; tree-2 between lo and +inf 127 | (defun wb-tree-uni-lo (tree-1 tree-2 lo compare) 128 | (let ((tree-2 (wb-tree-trim-lo tree-2 lo compare))) 129 | (cond 130 | ((null tree-2) tree-1) 131 | ((null tree-1) (wb-tree-split-greater tree-2 lo compare)) 132 | (t (join-wb-tree (wb-tree-uni-bd (wb-tree-left tree-1) tree-2 lo (wb-tree-value tree-1) compare) 133 | (wb-tree-value tree-1) 134 | (wb-tree-uni-lo (wb-tree-right tree-1) tree-2 (wb-tree-value tree-1) compare) 135 | compare))))) 136 | 137 | (defun wb-tree-hedge-union (tree-1 tree-2 compare) 138 | (declare (type function compare)) 139 | (cond 140 | ((null tree-1) tree-2) 141 | ((null tree-2) tree-1) 142 | (t (with-wb-tree (l1 v1 r1) tree-1 143 | (join-wb-tree (wb-tree-uni-hi l1 tree-2 v1 compare) 144 | v1 145 | (wb-tree-uni-lo r1 tree-2 v1 compare) 146 | compare))))) 147 | -------------------------------------------------------------------------------- /src/ttree.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | 38 | (in-package :sycamore) 39 | 40 | ;;;;;;;;;;;;;;; 41 | ;; T Trees ;; 42 | ;;;;;;;;;;;;;;; 43 | 44 | ;; Reuse the WB-Tree structure 45 | ;; The binary-tree value slot now holds a sorted array of values 46 | 47 | (defconstant +t-tree-max-array-length+ 8) 48 | 49 | (defun make-t-tree (left data right) 50 | (declare (type simple-vector data)) 51 | (%make-wb-tree (+ (length data) (wb-tree-count left) (wb-tree-count right)) 52 | left data right)) 53 | 54 | (defun map-t-tree-nil (function tree) 55 | (when tree 56 | (map-t-tree-nil function (binary-tree-left tree)) 57 | (map nil function (binary-tree-value tree)) 58 | (map-t-tree-nil function (binary-tree-right tree)))) 59 | 60 | (defun map-t-tree (result-type function tree) 61 | (cond 62 | ((null result-type) 63 | (map-t-tree-nil function tree)) 64 | ((eq 'list result-type) 65 | (let* ((c (cons nil nil)) 66 | (k c)) 67 | (map-t-tree-nil (lambda (x) 68 | (rplacd k (cons (funcall function x) nil)) 69 | (setq k (cdr k))) 70 | tree) 71 | (cdr c))) 72 | (t (error "Unknown result-type: ~A" result-type)))) 73 | 74 | 75 | 76 | (defun find-t-tree (value tree compare) 77 | (declare (type function compare)) 78 | (if (null tree) 79 | nil 80 | (let* ((d (binary-tree-value tree)) 81 | (len (1- (length d))) 82 | (c0 (funcall compare value (aref d 0))) 83 | (c1 (funcall compare value (aref d len)))) 84 | (declare (type fixnum c0 c1 len) 85 | (type simple-vector d)) 86 | (cond 87 | ((< c0 0) (find-t-tree (binary-tree-left tree) value compare)) 88 | ((> c1 0) (find-t-tree (binary-tree-right tree) value compare)) 89 | ((= c0 0) (aref d 0)) 90 | ((= c1 0) (aref d len)) 91 | (t (array-tree-search d value compare 1 len)))))) 92 | 93 | (defun t-tree-array-insert-split (array value position) 94 | (declare (type simple-vector array) 95 | (type fixnum position)) 96 | (let* ((n (length array)) 97 | (n/2 (ash n -1))) 98 | (if (< position (1+ n/2)) 99 | (values (array-tree-insert-at array value position 0 n/2) 100 | (subseq array n/2 n)) 101 | (values (subseq array 0 n/2) 102 | (array-tree-insert-at array value position n/2))))) 103 | 104 | (defun balance-t-tree (left value right) 105 | (balance-general-wb-tree #'make-t-tree 3 left value right)) 106 | 107 | (defun t-tree-insert (tree value compare) 108 | "Insert `value' into `tree' returning new tree." 109 | (declare (type function compare)) 110 | ;;(declare (optimize (speed 3) (safety 0))) 111 | (if (null tree) 112 | (make-t-tree nil (vector value) nil) 113 | (labels ((insert (tree value) 114 | (with-wb-tree (l d r) tree 115 | (declare (type simple-vector d)) 116 | (let* ((len (length d)) 117 | (c0 (funcall compare value (aref d 0))) 118 | (c1 (funcall compare value (aref d (1- len))))) 119 | (declare (type fixnum len c0 c1)) 120 | (cond 121 | ;; recurse left 122 | ((and l (< c0 0)) 123 | (balance-t-tree (insert l value) d r)) 124 | ;; recurse right 125 | ((and r (> c1 0)) 126 | (balance-t-tree l d (insert r value))) 127 | ;; insert here 128 | (t 129 | (multiple-value-bind (position present) (array-tree-insert-position d value compare) 130 | (cond 131 | ;; replace element 132 | (present 133 | (make-t-tree l (array-tree-set d value position) r)) 134 | ;; insert into array 135 | ((< len +t-tree-max-array-length+) 136 | (make-t-tree l (array-tree-insert-at d value position) r)) 137 | ;; split left 138 | ((null l) 139 | (multiple-value-bind (a0 a1) (t-tree-array-insert-split d value position) 140 | (balance-t-tree (make-t-tree nil a0 nil) 141 | a1 r))) 142 | ;; split right 143 | ((null r) 144 | (multiple-value-bind (a0 a1) (t-tree-array-insert-split d value position) 145 | (balance-t-tree l a0 (make-t-tree nil a1 nil)))) 146 | ;; insert min to left 147 | ((wb-tree-smaller l r) 148 | (balance-t-tree (insert l (aref d 0)) 149 | (array-tree-insert-at d value position 1) 150 | r)) 151 | ;; insert max to right 152 | (t 153 | (balance-t-tree l (array-tree-insert-at d value position 0 (1- len)) 154 | (insert r (aref d (1- len))))))))))))) 155 | (insert tree value)))) 156 | 157 | 158 | (defun t-tree-builder (compare) 159 | (lambda (tree value) (t-tree-insert tree value compare))) 160 | 161 | ;; (defun absorb-t-tree (left value right) 162 | ;; (let ((len (length value))) 163 | ;; (cond 164 | ;; ;; absorb left leaf 165 | ;; ((and left (binary-tree-leaf-p left) 166 | ;; (<= (+ len (length (binary-tree-value left))) 167 | ;; +t-tree-max-array-length+)) 168 | ;; ) 169 | ;; ;; absorb right leaf 170 | ;; ((and right (binary-tree-leaf-p left) 171 | ;; (<= (+ len (length (binary-tree-value left))) 172 | ;; +t-tree-max-array-length+)) 173 | ;; ) 174 | 175 | ;; ;; absorb left half-leaf 176 | ;; ;; absorb right half-leaf 177 | 178 | ;; (defun t-tree-remove-pos (tree value pos) 179 | ;; (cond 180 | ;; ;; delete empty leaf 181 | ;; ((and (null l) (null r) (= 1 len)) nil) 182 | ;; ;; absorb half left 183 | ;; ;; absorb half right 184 | 185 | 186 | ;; remove from inner 187 | ;; above min - done 188 | ;; below min - pull in a leaf 189 | ;; remove from half leaf 190 | ;; leaf-mergable 191 | ;; above min 192 | ;; below min 193 | ;; remove from leaf 194 | ;; above min 195 | ;; empty leaf 196 | ;; below min 197 | 198 | 199 | ;; (defun t-tree-remove (tree value compare) 200 | ;; "Remove `value' from `tree' returning new tree." 201 | ;; (when tree 202 | ;; (with-wb-tree (l d r) tree 203 | ;; (let* ((len (length d)) 204 | ;; (c0 (funcall compare value (aref d 0))) 205 | ;; (c1 (funcall compare value (aref d (1- len))))) 206 | ;; (cond 207 | ;; ;; recurse left 208 | ;; ((< c0 0) 209 | ;; (balance-wb-tree (t-tree-remove l value compare) d r)) 210 | ;; ;; recurse right 211 | ;; ((> c1 0) 212 | ;; (balance-wb-tree l d (t-tree-remove r value compare))) 213 | ;; (t 214 | ;; (let ((pos (position-if (lambda (x) (zerop (funcall compare value x))) d))) 215 | ;; (if pos 216 | ;; (cond 217 | ;; ;; delete empty leaf 218 | ;; ((and (null l) (null r) (= 1 len)) nil) 219 | ;; ) 220 | ;; ;; not in tree 221 | ;; tree)))))))) 222 | 223 | 224 | (defun t-tree-dot (tree &key output) 225 | (output-dot output 226 | (lambda (s) 227 | (let ((i -1)) 228 | (labels ((helper (parent tree) 229 | (let ((x (incf i))) 230 | (format s "~& ~A[label=\"~{~A~^, ~} (~D)\"~:[shape=none~;shape=box~]];~&" 231 | x (if tree 232 | (map 'list #'identity (binary-tree-value tree)) 233 | nil) 234 | (wb-tree-count tree) 235 | tree) 236 | (when parent 237 | (format s "~& ~A -> ~A;~&" 238 | parent x)) 239 | (when tree 240 | (helper x (binary-tree-left tree)) 241 | (helper x (binary-tree-right tree)))))) 242 | (format s "~&digraph { ~&") 243 | (helper nil tree) 244 | (format s "~&}~&")))))) 245 | -------------------------------------------------------------------------------- /src/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Copyright (c) 2012, Georgia Tech Research Corporation 4 | ;;;; All rights reserved. 5 | ;;;; 6 | ;;;; Author(s): Neil T. Dantam 7 | ;;;; Georgia Tech Humanoid Robotics Lab 8 | ;;;; Under Direction of Prof. Mike Stilman 9 | ;;;; 10 | ;;;; This file is provided under the following "BSD-style" License: 11 | ;;;; 12 | ;;;; Redistribution and use in source and binary forms, with or 13 | ;;;; without modification, are permitted provided that the following 14 | ;;;; conditions are met: 15 | ;;;; * Redistributions of source code must retain the above 16 | ;;;; copyright notice, this list of conditions and the following 17 | ;;;; disclaimer. 18 | ;;;; * Redistributions in binary form must reproduce the above 19 | ;;;; copyright notice, this list of conditions and the following 20 | ;;;; disclaimer in the documentation and/or other materials 21 | ;;;; provided with the distribution. 22 | ;;;; 23 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | ;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 30 | ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 33 | ;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 34 | ;;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 35 | ;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | (in-package :sycamore-util) 38 | 39 | 40 | ;;(declaim (optimize (speed 3) (safety 0))) 41 | 42 | (deftype unsigned-fixnum () 43 | `(integer 0 ,most-positive-fixnum)) 44 | 45 | (defun fixnum-compare (a b) 46 | "Compare two fixnums" 47 | (declare (type fixnum a b)) 48 | (cond ((< a b) -1) 49 | ((> a b) 1) 50 | (t 0))) 51 | 52 | (defun double-compare (a b) 53 | "Compare two doubles" 54 | (declare (type double-float a b)) 55 | (cond ((< a b) -1) 56 | ((> a b) 1) 57 | (t 0))) 58 | 59 | (defun fold-n (function initial-value sequences) 60 | "Fold `FUNCTION' over each sequence in `SEQUENCES'." 61 | (declare (type function function)) 62 | (let ((value initial-value)) 63 | (flet ((fun2 (&rest args) 64 | (declare (dynamic-extent args)) 65 | (setq value (apply function value args)))) 66 | (apply #'map nil #'fun2 sequences) 67 | value))) 68 | 69 | (defun fold-1 (function initial-value sequence) 70 | "Fold `FUNCTION' over each value in `SEQUENCE'." 71 | (declare (type function function)) 72 | (etypecase sequence 73 | (list 74 | (let ((y initial-value)) 75 | (dolist (x sequence) 76 | (setq y (funcall function y x))) 77 | y)) 78 | (simple-vector 79 | (let ((y initial-value)) 80 | (dotimes (i (length sequence)) 81 | (setq y (funcall function y (svref sequence i)))) 82 | y)) 83 | (sequence 84 | (reduce function sequence :initial-value initial-value)))) 85 | 86 | (declaim (inline fold)) 87 | (defun fold (function initial-value &rest sequences) 88 | (declare (type function function) 89 | (dynamic-extent sequences)) 90 | (destructuring-bind (sequence . more-sequences) sequences 91 | (if more-sequences 92 | (fold-n function initial-value sequences) 93 | (fold-1 function initial-value sequence)))) 94 | 95 | (defmacro cond-compare ((value1 value2 compare) lt-case eq-case gt-case) 96 | (with-gensyms (c) 97 | `(let ((,c (funcall ,compare ,value1 ,value2))) 98 | (declare (type fixnum ,c)) 99 | (cond 100 | ((< ,c 0) 101 | ,lt-case) 102 | ((> ,c 0) 103 | ,gt-case) 104 | (t ,eq-case))))) 105 | 106 | (defmacro if-less-eq-compare ((value1 value2 compare) lt-eq-case gt-case) 107 | `(if (<= (funcall ,compare ,value1 ,value2) 0) 108 | (progn ,lt-eq-case) 109 | (progn ,gt-case))) 110 | 111 | (defmacro or-compare (&rest comparisons) 112 | "Short-circuit evaluatation of arguments, returning the first one that is nonzero." 113 | (cond 114 | ((null comparisons) 0) 115 | ((null (cdr comparisons)) 116 | (car comparisons)) 117 | (t 118 | (with-gensyms (i) 119 | `(let ((,i ,(car comparisons))) 120 | (declare (type fixnum ,i)) 121 | (if (zerop ,i) 122 | (or-compare ,@(cdr comparisons)) 123 | ,i)))))) 124 | 125 | (defun vector-range (start end) 126 | (apply #'vector (loop for i from start below end collect i))) 127 | 128 | 129 | (declaim (inline string-compare-inline)) 130 | (defun string-compare-inline (a b) 131 | (let ((n-a (length a)) 132 | (n-b (length b))) 133 | (dotimes (i (min n-a n-b)) 134 | (let ((c-a (aref a i)) 135 | (c-b (aref b i))) 136 | (unless (eql c-a c-b) 137 | (return-from string-compare-inline (- (char-code c-a) 138 | (char-code c-b)))))) 139 | (- n-a n-b))) 140 | 141 | (defun string-compare (a b) 142 | (etypecase a 143 | (simple-string 144 | (etypecase b 145 | (simple-string (string-compare-inline a b)) 146 | (string (string-compare-inline a b)))) 147 | (string 148 | (etypecase b 149 | (simple-string (string-compare-inline a b)) 150 | (string (string-compare-inline a b)))))) 151 | 152 | (defun simple-string-compare (a b) 153 | (declare (type simple-string a b)) 154 | (string-compare-inline a b)) 155 | 156 | 157 | (defun bit-vector-compare (a b) 158 | "Compare bitvectors `A' and `B'." 159 | (declare (type simple-bit-vector a b) 160 | (optimize (speed 3) (safety 0))) 161 | (let* ((n-a (length a)) 162 | (n-b (length b))) 163 | (or-compare (fixnum-compare n-a n-b) 164 | (let ((i (mismatch a b))) 165 | (if i 166 | (let ((x (aref a i)) 167 | (y (aref b i))) 168 | (- x y)) 169 | 0))))) 170 | 171 | 172 | 173 | (defun gsymbol-compare-atom (a b) 174 | (declare (optimize (speed 3) (safety 0))) 175 | (if (eq a b) 176 | 0 177 | (etypecase a 178 | (fixnum 179 | (etypecase b 180 | (fixnum (if (< a b) -1 1)) 181 | (character 1) 182 | (string 1) 183 | (symbol 1))) 184 | (character 185 | (etypecase b 186 | (fixnum -1) 187 | (character (if (< (char-code a) (char-code b)) 188 | -1 1)) 189 | (string 1) 190 | (symbol 1))) 191 | (string 192 | (etypecase b 193 | (fixnum -1) 194 | (character -1) 195 | (string (string-compare a b)) 196 | (symbol 1))) 197 | (symbol 198 | (etypecase b 199 | (fixnum -1) 200 | (character -1) 201 | (string -1) 202 | (symbol (cond ((string< a b) -1) 203 | ((string> a b) 1) 204 | (t 0)))))))) 205 | 206 | (defun gsymbol-compare (a b) 207 | (etypecase a 208 | (null (if b -1 0)) 209 | (atom (etypecase b 210 | (null 1) 211 | (atom (gsymbol-compare-atom a b)) 212 | (list -1))) 213 | (cons 214 | (etypecase b 215 | (atom 1) 216 | (list (or-compare (gsymbol-compare (car a) (car b)) 217 | (gsymbol-compare (cdr a) (cdr b)))))))) 218 | 219 | 220 | (defun strcat (&rest args) 221 | (apply #'concatenate 'string (map 'list #'string args))) 222 | 223 | #+sbcl 224 | (defun output-dot-file (program output function lang) 225 | "Run `dot' on the output of FUNCTION. 226 | OUTPUT: output filename 227 | FUNCTION: (lambda (stream)) => nil, prints dot on STREAM 228 | LANG: language output for dot, (or pdf ps eps png)" 229 | (let ((p (sb-ext:run-program program (list (concatenate 'string "-T" lang)) 230 | :wait nil :search t :input :stream :output output 231 | :if-output-exists :supersede))) 232 | (funcall function (sb-ext:process-input p)) 233 | (close (sb-ext:process-input p)) 234 | (sb-ext:process-wait p) 235 | (sb-ext:process-close p))) 236 | 237 | 238 | (defun output-dot (output function &key 239 | (program "dot") 240 | (lang (and (stringp output) (car (last (ppcre:split "\\." output)))))) 241 | "Produce graphiz output, dispatching on type of OUTPUT. 242 | OUTPUT: (or filename stream t nil) 243 | FUNCTION: (lambda (stream)) => nil, prints dot text on STREAM 244 | LANG: language output for dot, (or pdf ps eps png)" 245 | (cond 246 | ((streamp output) 247 | (funcall function output)) 248 | ((null output) 249 | (with-output-to-string (s) (output-dot s function))) 250 | ((eq output t) (output-dot *standard-output* function)) 251 | ((stringp output) 252 | (if (equalp lang "dot") 253 | (with-open-file (s output :direction :output :if-exists :supersede) 254 | (funcall function s)) 255 | (output-dot-file program output function lang))) 256 | (t (error "Unknown output: ~A" output)))) 257 | 258 | 259 | (defmacro with-temp-array ((name length &key (dynamic-extent-limit 1024)) 260 | &body body) 261 | "Create a temprary array and attempt to stack allocate 262 | if size is below dynamic-extent-limit." 263 | ;; SBCL will stack-allocate arrays with length below 4095 264 | (with-gensyms (fun s-length) 265 | `(flet ((,fun (,name) 266 | ,@body)) 267 | (let ((,s-length ,length)) 268 | (if (< ,s-length ,dynamic-extent-limit) 269 | (let ((,name (make-array ,s-length))) 270 | (declare (dynamic-extent ,name)) 271 | (,fun ,name)) 272 | (,fun (make-array ,s-length))))))) 273 | 274 | 275 | (defmacro with-timing (&body body) 276 | "Evaluate all forms in body, computing the real and run time. 277 | 278 | Returns: (values `(progn ,@body) RUN-TIME REAL-TIME)" 279 | (with-gensyms (real-0 real-1 run-0 run-1 result) 280 | `(let* ((,real-0 (get-internal-real-time)) 281 | (,run-0 (get-internal-run-time)) 282 | (,result (progn ,@body)) 283 | (,real-1 (get-internal-real-time)) 284 | (,run-1 (get-internal-run-time))) 285 | (values ,result 286 | (coerce (/ (- ,run-1 ,run-0) 287 | internal-time-units-per-second) 288 | 'double-float) 289 | (coerce (/ (- ,real-1 ,real-0) 290 | internal-time-units-per-second) 291 | 'double-float))))) 292 | --------------------------------------------------------------------------------