├── .gitignore ├── LICENSE ├── README.org ├── bbtrees.sls ├── deques.sls ├── deques ├── naive.sls └── private │ └── condition.sls ├── dlists.sls ├── doc └── dlists.scm ├── examples └── queues.scm ├── fingertrees.sls ├── hamts.sls ├── heaps.sls ├── pkg-list.scm ├── private ├── alists.sls ├── bitwise.sls ├── lazy-lists.sls └── vectors.sls ├── psqs.sls ├── queues.sls ├── queues ├── naive.sls └── private │ └── condition.sls ├── runtests ├── sequences.sls ├── sets.sls ├── tests.scm └── tests ├── bbtrees.sls ├── deques.sls ├── fingertrees.sls ├── hamts.sls ├── heaps.sls ├── psqs.sls ├── queues.sls ├── sequences.sls ├── sets.sls └── utils.sls /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/* 2 | private/compiled/* 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2011-2014 Ian Price 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of the author may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Purely Functional Data Structures in Scheme -*- org -*- 2 | 3 | ** About 4 | pfds is a set of purely functional data structures written in R6RS 5 | Scheme. It has been tested with Racket, Guile 2, Vicare Scheme and 6 | IronScheme. Right now it contains 7 | - queues 8 | - deques 9 | - bbtrees 10 | - sets 11 | - dlists 12 | - priority search queues (psqs) 13 | - finger trees 14 | - sequences 15 | - heaps 16 | - hamts 17 | 18 | with more to come, time permitting. 19 | 20 | ** Installation 21 | Just clone it somewhere on your $GUILE_LOAD_PATH and you're 22 | done. Alternatively, a pkg-list.scm file is provided for use with the 23 | dorodango package manager.If you want to run the tests file, you will 24 | need trc-testing from the [[http://gitorious.org/wak][wak project]]. 25 | 26 | ** Documentation 27 | Documentation is provided at the top of the respective files. The 28 | queues and deques are based on the paper [[http://www.eecs.usma.edu/webs/people/okasaki/pubs.html#jfp95]["Simple and Efficient Purely 29 | Functional Queues and Deques"]] by Chris Okasaki. The bbtrees and sets 30 | are based on the paper [[http://groups.csail.mit.edu/mac/users/adams/BB/92-10.ps]["Implementing Sets Efficiently in a Functional 31 | Language"]] by Stephen Adams. 32 | 33 | Dlists are a well known trick in the functional programming community, 34 | going back to at least [[http://www.cs.tufts.edu/~nr/cs257/archive/john-hughes/lists.pdf][“A Novel Representation of Lists and its 35 | application to the Function "Reverse"”]] by John Hughes in 1984, 36 | although he does not give them this name. The trick is likely even 37 | older than that (he points to a paper by Bird), though I have not the 38 | knowledge to confirm this. 39 | 40 | The implementation of priority search queues is described in [[http://www.cs.ox.ac.uk/people/ralf.hinze/publications/UU-CS-2001-09.pdf]["A Simple 41 | Implementation Technique for Priority Search Queues"]] by Ralf Hinze. 42 | 43 | The heaps use a height-biased leftist tree implementation. 44 | 45 | Finger trees are described in [[http://www.soi.city.ac.uk/~ross/papers/FingerTree.html][Finger trees: a simple general-purpose 46 | data structure]] by Ross Paterson and Ralf Hinze. 47 | 48 | Hash Array Map Tries are described in the paper [[http://lampwww.epfl.ch/papers/idealhashtrees.pdf][Ideal Hash Trees]] by 49 | Phil Bagwell. 50 | 51 | ** Thanks 52 | Thanks to [[https://github.com/leppie][Llewellyn Pritchard]] for testing this on [[https://ironscheme.codeplex.com/][IronScheme]], to [[https://github.com/marcomaggi][Marco 53 | Maggi]] for testing on [[https://github.com/marcomaggi/vicare][Vicare Scheme]], and to [[http://wingolog.org/][Andy Wingo]] for pointing out 54 | priority search queues to me, and prodding me into implementing them. 55 | -------------------------------------------------------------------------------- /bbtrees.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; bbtrees.sls --- Bounded Balance trees 3 | 4 | ;; Copyright (C) 2012 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;; Documentation: 15 | ;; 16 | ;; Note: For all procedures which take a key as an argument, the key 17 | ;; must be comparable with the ordering procedure of the bbtree. 18 | ;; 19 | ;; make-bbtree : (any -> any -> boolean) -> bbtree 20 | ;; returns an empty bbtree. bbtrees derived from this one will use the 21 | ;; procedure argument for ordering keys. 22 | ;; 23 | ;; bbtree? : any -> bool 24 | ;; returns #t if the argument is a bbtree, #f otherwise 25 | ;; 26 | ;; bbtree-size : bbtree -> non-negative integer 27 | ;; returns the number of elements in a bbtree 28 | ;; 29 | ;; bbtree-ref : bbtree any [any] -> any 30 | ;; returns the value associated with the key in the bbtree. If the 31 | ;; value is not in the tree, then, if the optional third argument is 32 | ;; passed, it is returned, otherwise an &assertion-violation condition 33 | ;; is raised. 34 | ;; 35 | ;; bbtree-set : bbtree any any -> bbtree 36 | ;; returns a new bbtree with the key associated with the value. If the 37 | ;; key is already in the bbtree, its associated value is replaced with 38 | ;; the new value in the returned bbtree. 39 | ;; 40 | ;; bbtree-update : bbtree any (any -> any) any -> bbtree 41 | ;; returns a new bbtree with the value associated with the key updated 42 | ;; according to the update procedure. If the key was not already in 43 | ;; the bbtree, the update procedure is called on the default value, 44 | ;; and the association is added to the bbtree. 45 | ;; 46 | ;; bbtree-delete : bbtree any -> bbtree 47 | ;; returns a new bbtree with the key and its associated value 48 | ;; removed. If the key is not in the bbtree, the returned bbtree is a 49 | ;; copy of the original 50 | ;; 51 | ;; bbtree-contains? : bbtree any -> boolean 52 | ;; returns #t if there is association for key in the bbtree, false 53 | ;; otherwise 54 | ;; 55 | ;; bbtree-traverse : (any any (any -> any) (any -> any) any) any bbtree -> any 56 | ;; A general tree traversal procedure. Returns the value of applying 57 | ;; the traverser procedure to the current node's key, value, a 58 | ;; procedure to traverse the left subtree, a procedure to traverse the 59 | ;; right subtree, and a base value. The subtree traversal procedures 60 | ;; both take a base argument, and call bbtree-traverse recursively on 61 | ;; the appropriate subtree. It is mostly useful for implementing 62 | ;; other, more specific tree traversal procedures. For example, 63 | ;; (define (l-to-r-pre-order cons base bbtree) 64 | ;; (bbtree-traverse (lambda (key value left right base) 65 | ;; (right (left (cons key value base)))) 66 | ;; base 67 | ;; bbtree)) 68 | ;; implements a left-to-right pre-order traversal variant of bbtree-fold 69 | ;; 70 | ;; bbtree-fold : (any any any -> any) any bbtree -> any 71 | ;; returns the value obtained by the iterating the combine procedure 72 | ;; over each node in the tree. The combine procedure takes three 73 | ;; arguments, the key and value of the current node, and an 74 | ;; accumulator value, and its return value is used as the accumulator 75 | ;; value for the next node. The initial accumulator value is provided 76 | ;; by the base argument. bbtree-fold performs an left-to-right 77 | ;; in-order traversal or "minimum key to maximum key". 78 | ;; 79 | ;; bbtree-fold-right : (any any any -> any) any bbtree -> any 80 | ;; like bbtree-fold, but it performs a right-to-left in-order 81 | ;; traversal instead (i.e. maximum to minimum). 82 | ;; 83 | ;; bbtree-map : (any -> any) bbtree -> bbtree 84 | ;; returns the tree obtained by updating the value of each node with 85 | ;; the result of applying the procedure to its value. 86 | ;; 87 | ;; bbtree->alist : bbtree -> Listof(Pairs) 88 | ;; returns the key value associations of the bbtree as a list of 89 | ;; pairs. The list returned is in sorted order according to the 90 | ;; ordering procedure of the bbtree. A consequence of this is that one 91 | ;; could write a sort procedure for lists of pairs as 92 | ;; (define (alist-sort alist <) 93 | ;; (bbtree->alist (alist->bbtree alist <))) 94 | ;; 95 | ;; alist->bbtree : Listof(Pairs) -> (any any -> boolean) -> bbtree 96 | ;; returns the bbtree containing each of the key value pairs in the 97 | ;; alist, using the < argument as the ordering procedure. 98 | ;; 99 | ;; bbtree-keys : bbtree -> Listof(any) 100 | ;; returns a list containing all the keys of the bbtree. The keys are 101 | ;; sorted according to the bbtree's ordering procedure. 102 | ;; 103 | ;; bbtree-union : bbtree bbtree -> bbtree 104 | ;; returns a bbtree containing the union of the associations in 105 | ;; bbtree1 and bbtree2. Where the same key occurs in both, the value 106 | ;; in bbtree1 is preferred. 107 | ;; 108 | ;; bbtree-difference : bbtree bbtree -> bbtree 109 | ;; returns a bbtree containing the all the associations in bbtree1, 110 | ;; which do not occur in bbtree2. 111 | ;; 112 | ;; bbtree-intersection : bbtree bbtree -> bbtree 113 | ;; returns a bbtree containing all the associations which appear in 114 | ;; both bbtree1 and bbtree2. The value in bbtree1 are preferred over 115 | ;; those in bbtree2. 116 | ;; 117 | ;; bbtree-index bbtree any -> non-negative integer 118 | ;; returns the index of the key in the bbtree. Index is an integer 119 | ;; between 0 and size - 1, with the a key having a lower index than 120 | ;; another if first-key < second-key, according to the bbtree ordering 121 | ;; procedure. 122 | ;; 123 | ;; bbtree-ref/index bbtree non-negative-integer -> any any 124 | ;; returns the key and value of the association in the bbtree at the 125 | ;; given index. 126 | ;; 127 | ;; bbtree-ordering-procedure : bbtree -> (any any -> bool) 128 | ;; returns the ordering procedure used internally to order the 129 | ;; bbtree. 130 | (library (pfds bbtrees) 131 | (export make-bbtree 132 | bbtree? 133 | bbtree-size 134 | bbtree-ref 135 | bbtree-set 136 | bbtree-update 137 | bbtree-delete 138 | bbtree-contains? 139 | bbtree-ordering-procedure 140 | bbtree-traverse 141 | bbtree-fold 142 | bbtree-fold-right 143 | bbtree-map 144 | bbtree->alist 145 | alist->bbtree 146 | bbtree-keys 147 | bbtree-union 148 | bbtree-difference 149 | bbtree-intersection 150 | bbtree-index 151 | bbtree-ref/index 152 | ) 153 | 154 | (import (except (rnrs) min member)) 155 | 156 | (define weight 4) 157 | 158 | ;;; bbtree is the wrapper that you interact with from outside the 159 | ;;; module, so there is no need to deal with empty and node record types 160 | (define-record-type (bbtree %make-bbtree bbtree?) 161 | (fields tree ordering-procedure)) 162 | 163 | (define (update-tree bbtree new-tree) 164 | (%make-bbtree new-tree (bbtree-ordering-procedure bbtree))) 165 | 166 | ;;; inner representation of trees 167 | ;;; all non exposed methods can assume a valid tree 168 | (define-record-type empty) 169 | 170 | (define-record-type node 171 | (fields key value length left right)) 172 | 173 | ;;; smart constructor for nodes, automatically fills in size field 174 | (define (node* key value left right) 175 | (make-node key value (+ 1 (size left) (size right)) left right)) 176 | 177 | (define (size tree) 178 | (if (empty? tree) 179 | 0 180 | (node-length tree))) 181 | 182 | ;; looks key up in the tree, and applies proc to the value if it finds 183 | ;; it, and calls failure otherwise 184 | (define (lookup tree key proc failure <) 185 | (define (search tree) 186 | (cond [(empty? tree) (failure)] 187 | [(< (node-key tree) key) 188 | (search (node-right tree))] 189 | [(< key (node-key tree)) 190 | (search (node-left tree))] 191 | [else (proc tree)])) 192 | (search tree)) 193 | 194 | ;; returns the key and value of the minimum element in the tree 195 | (define (min tree) 196 | (cond [(empty? tree) 197 | (assertion-violation 'min "Can't take the minimum value of an empty tree")] 198 | [(empty? (node-left tree)) 199 | (values (node-key tree) 200 | (node-value tree))] 201 | [else 202 | (min (node-left tree))])) 203 | 204 | ;;; rotations 205 | (define (rotate-left key value left right) 206 | (let ([r-key (node-key right)] 207 | [r-value (node-value right)] 208 | [r-left (node-left right)] 209 | [r-right (node-right right)]) 210 | (node* r-key 211 | r-value 212 | (node* key value left r-left) 213 | r-right))) 214 | 215 | (define (rotate-right key value left right) 216 | (let ([l-key (node-key left)] 217 | [l-value (node-value left)] 218 | [l-left (node-left left)] 219 | [l-right (node-right left)]) 220 | (node* l-key 221 | l-value 222 | l-left 223 | (node* key value l-right right)))) 224 | 225 | (define (rotate-left/double key value left right) 226 | (let ([r-key (node-key right)] 227 | [r-value (node-value right)] 228 | [r-left (node-left right)] 229 | [r-right (node-right right)]) 230 | (let ([rl-key (node-key r-left)] 231 | [rl-value (node-value r-left)] 232 | [rl-left (node-left r-left)] 233 | [rl-right (node-right r-left)]) 234 | (node* rl-key 235 | rl-value 236 | (node* key value left rl-left) 237 | (node* r-key r-value rl-right r-right))))) 238 | 239 | (define (rotate-right/double key value left right) 240 | (let ([l-key (node-key left)] 241 | [l-value (node-value left)] 242 | [l-left (node-left left)] 243 | [l-right (node-right left)]) 244 | (let ([lr-key (node-key l-right)] 245 | [lr-value (node-value l-right)] 246 | [lr-left (node-left l-right)] 247 | [lr-right (node-right l-right)]) 248 | (node* lr-key 249 | lr-value 250 | (node* l-key l-value l-left lr-left) 251 | (node* key value lr-right right))))) 252 | 253 | ;;; smart constructor for after adding/removing a node 254 | (define (T key value left right) 255 | (let ((l-size (size left)) 256 | (r-size (size right))) 257 | (cond [(< (+ l-size r-size) 2) 258 | (node* key value left right)] 259 | [(> r-size (* weight l-size)) 260 | (let ([r-left (node-left right)] 261 | [r-right (node-right right)]) 262 | (if (< (size r-left) (size r-right)) 263 | (rotate-left key value left right) 264 | (rotate-left/double key value left right)))] 265 | [(> l-size (* weight r-size)) 266 | (let ([l-left (node-left left)] 267 | [l-right (node-right left)]) 268 | (if (< (size l-right) (size l-left)) 269 | (rotate-right key value left right) 270 | (rotate-right/double key value left right)))] 271 | [else 272 | (node* key value left right)]))) 273 | 274 | (define (update tree key proc default <) 275 | (define (add-to tree) 276 | (if (empty? tree) 277 | (make-node key (proc default) 1 (make-empty) (make-empty)) 278 | (let ([k (node-key tree)] 279 | [v (node-value tree)] 280 | [l (node-left tree)] 281 | [r (node-right tree)]) 282 | (cond [(< key k) 283 | (T k v (add-to l) r)] 284 | [(< k key) 285 | (T k v l (add-to r))] 286 | [else 287 | (node* key (proc v) l r)])))) 288 | (add-to tree)) 289 | 290 | (define (add tree key value <) 291 | (define (replace _) value) 292 | (update tree key replace #f <)) 293 | 294 | (define (delete tree key <) 295 | (define (delete-from tree) 296 | (if (empty? tree) 297 | tree 298 | (let ([k (node-key tree)] 299 | [v (node-value tree)] 300 | [l (node-left tree)] 301 | [r (node-right tree)]) 302 | (cond [(< key k) 303 | (T k v (delete-from l) r)] 304 | [(< k key) 305 | (T k v l (delete-from r))] 306 | [else 307 | (delete* l r)])))) 308 | (delete-from tree)) 309 | 310 | (define (delete* left right) 311 | (cond ((empty? left) right) 312 | ((empty? right) left) 313 | (else 314 | (let-values (((k v) (min right))) 315 | (T k v left (delete-min right)))))) 316 | 317 | (define (delete-min tree) 318 | (cond ((empty? tree) 319 | (assertion-violation 'delete-min 320 | "Can't delete the minimum value of an empty tree")) 321 | ((empty? (node-left tree)) 322 | (node-right tree)) 323 | (else 324 | (T (node-key tree) 325 | (node-value tree) 326 | (delete-min (node-left tree)) 327 | (node-right tree))))) 328 | 329 | (define (concat3 key value left right lt) 330 | (cond [(empty? left) 331 | (add right key value lt)] 332 | [(empty? right) 333 | (add left key value lt)] 334 | [(< (* weight (size left)) (size right)) 335 | (T (node-key right) 336 | (node-value right) 337 | (concat3 key value left (node-left right) lt) 338 | (node-right right))] 339 | [(< (* weight (size right)) (size left)) 340 | (T (node-key left) 341 | (node-value left) 342 | (node-left left) 343 | (concat3 key value (node-right left) right lt))] 344 | [else 345 | (node* key value left right)])) 346 | 347 | (define (split-lt tree key <) 348 | (cond [(empty? tree) tree] 349 | [(< key (node-key tree)) 350 | (split-lt (node-left tree) key <)] 351 | [(< (node-key tree) key) 352 | (concat3 (node-key tree) 353 | (node-value tree) 354 | (node-left tree) 355 | (split-lt (node-right tree) key <) 356 | <)] 357 | [else (node-left tree)])) 358 | 359 | (define (split-gt tree key <) 360 | (cond [(empty? tree) tree] 361 | [(< key (node-key tree)) 362 | (concat3 (node-key tree) 363 | (node-value tree) 364 | (split-gt (node-left tree) key <) 365 | (node-right tree) 366 | <)] 367 | [(< (node-key tree) key) 368 | (split-gt (node-right tree) key <)] 369 | [else (node-right tree)])) 370 | 371 | (define (difference tree1 tree2 <) 372 | (cond [(empty? tree1) tree1] 373 | [(empty? tree2) tree1] 374 | [else 375 | (let ([l* (split-lt tree1 (node-key tree2) <)] 376 | [r* (split-gt tree1 (node-key tree2) <)]) 377 | (concat (difference l* (node-left tree2) <) 378 | (difference r* (node-right tree2) <)))])) 379 | 380 | (define (concat left right) 381 | (cond [(empty? left) right] 382 | [(empty? right) left] 383 | [(< (* weight (size left)) (size right)) 384 | (T (node-key right) 385 | (node-value right) 386 | (concat left (node-left right)) 387 | (node-right right))] 388 | [(< (* weight (size right)) (size left)) 389 | (T (node-key left) 390 | (node-value left) 391 | (node-left left) 392 | (concat (node-right left) right))] 393 | [else 394 | (let-values (((k v) (min right))) 395 | (T k v left (delete-min right)))])) 396 | 397 | (define (member key tree <) 398 | (define (yes x) #t) 399 | (define (no) #f) 400 | (lookup tree key yes no <)) 401 | 402 | (define (intersection t1 t2 <) 403 | (cond [(empty? t1) t1] 404 | [(empty? t2) t2] 405 | [else 406 | (let ([l* (split-lt t2 (node-key t1) <)] 407 | [r* (split-gt t2 (node-key t1) <)]) 408 | (if (member (node-key t1) t2 <) 409 | (concat3 (node-key t1) 410 | (node-value t1) 411 | (intersection (node-left t1) l* <) 412 | (intersection (node-right t1) r* <) 413 | <) 414 | (concat (intersection (node-left t1) l* <) 415 | (intersection (node-right t1) r* <))))])) 416 | 417 | ;;; hedge union 418 | 419 | ;; ensures that tree is either empty, or root lies in range low--high 420 | (define (trim low high tree <) 421 | (cond [(empty? tree) tree] 422 | [(< low (node-key tree)) 423 | (if (< (node-key tree) high) 424 | tree 425 | (trim low high (node-left tree) <))] 426 | [else 427 | (trim low high (node-right tree) <)])) 428 | 429 | (define (uni-bd tree1 tree2 low high <) 430 | (cond [(empty? tree2) tree1] 431 | [(empty? tree1) 432 | (concat3 (node-key tree2) 433 | (node-value tree2) 434 | (split-gt (node-left tree2) low <) 435 | (split-lt (node-right tree2) high <) 436 | <)] 437 | [else 438 | (let ([key (node-key tree1)]) 439 | (concat3 key 440 | (node-value tree1) 441 | (uni-bd (node-left tree1) (trim low key tree2 <) low key <) 442 | (uni-bd (node-right tree1) (trim key high tree2 <) key high <) 443 | <))])) 444 | 445 | ;; specialisation of trim for high=+infinity 446 | (define (trim-low low tree <) 447 | (cond [(empty? tree) tree] 448 | [(< low (node-key tree)) tree] 449 | [else 450 | (trim-low low (node-right tree) <)])) 451 | 452 | ;; trim for low=-infinity 453 | (define (trim-high high tree <) 454 | (cond [(empty? tree) tree] 455 | [(< (node-key tree) high) tree] 456 | [else 457 | (trim-high high (node-left tree) <)])) 458 | 459 | ;; uni-bd for low=-infinity 460 | (define (uni-high tree1 tree2 high <) 461 | (cond [(empty? tree2) tree1] 462 | [(empty? tree1) 463 | (concat3 (node-key tree2) 464 | (node-value tree2) 465 | (node-left tree2) 466 | (split-lt (node-right tree2) high <) 467 | <)] 468 | [else 469 | (let ([key (node-key tree1)]) 470 | (concat3 key 471 | (node-value tree1) 472 | (uni-high (node-left tree1) (trim-high key tree2 <) key <) 473 | (uni-bd (node-right tree1) (trim key high tree2 <) key high <) 474 | <))])) 475 | 476 | ;; uni-bd for high=+infinity 477 | (define (uni-low tree1 tree2 low <) 478 | (cond [(empty? tree2) tree1] 479 | [(empty? tree1) 480 | (concat3 (node-key tree2) 481 | (node-value tree2) 482 | (split-gt (node-left tree2) low <) 483 | (node-right tree2) 484 | <)] 485 | [else 486 | (let ([key (node-key tree1)]) 487 | (concat3 key 488 | (node-value tree1) 489 | (uni-bd (node-left tree1) (trim low key tree2 <) low key <) 490 | (uni-low (node-right tree1) (trim-low key tree2 <) key <) 491 | <))])) 492 | 493 | (define (hedge-union tree1 tree2 <) 494 | (cond [(empty? tree2) tree1] 495 | [(empty? tree1) tree2] 496 | [else 497 | (let ([key (node-key tree1)]) 498 | (concat3 key 499 | (node-value tree1) 500 | (uni-high (node-left tree1) (trim-high key tree2 <) key <) 501 | (uni-low (node-right tree1) (trim-low key tree2 <) key <) 502 | <))])) 503 | 504 | ;;; rank and indexing 505 | 506 | (define (rank tree key <) 507 | (cond [(empty? tree);; error 508 | (assertion-violation 'rank "Key is not in the tree" key)] 509 | [(< key (node-key tree)) 510 | (rank (node-left tree) key <)] 511 | [(< (node-key tree) key) 512 | (+ (rank (node-right tree) key <) 513 | (size (node-left tree)) 514 | 1)] 515 | [else 516 | (size (node-left tree))])) 517 | 518 | (define (index tree idx) 519 | (if (empty? tree) 520 | (assertion-violation 'index "No value at index" idx) 521 | (let ([l-size (size (node-left tree))]) 522 | (cond [(< idx l-size) 523 | (index (node-left tree) idx)] 524 | [(< l-size idx) 525 | (index (node-right tree) 526 | (- idx l-size 1))] 527 | [else 528 | (values (node-key tree) 529 | (node-value tree))])))) 530 | 531 | ;;; External procedures 532 | 533 | (define (make-bbtree <) 534 | (assert (procedure? <)) 535 | (%make-bbtree (make-empty) <)) 536 | 537 | (define (bbtree-size bbtree) 538 | (assert (bbtree? bbtree)) 539 | (size (bbtree-tree bbtree))) 540 | 541 | (define bbtree-ref 542 | (let ((ref (lambda (bbtree key failure) 543 | (assert (bbtree? bbtree)) 544 | (lookup (bbtree-tree bbtree) 545 | key 546 | node-value 547 | failure 548 | (bbtree-ordering-procedure bbtree))))) 549 | (case-lambda 550 | ((bbtree key) 551 | (define (fail) 552 | (assertion-violation 'bbtree-ref "Key is not in the tree" key)) 553 | (ref bbtree key fail)) 554 | ((bbtree key ret) 555 | (ref bbtree key (lambda () ret)))))) 556 | 557 | (define (bbtree-set bbtree key value) 558 | (assert (bbtree? bbtree)) 559 | (update-tree bbtree 560 | (add (bbtree-tree bbtree) 561 | key 562 | value 563 | (bbtree-ordering-procedure bbtree)))) 564 | 565 | (define (bbtree-update bbtree key proc default) 566 | (assert (bbtree? bbtree)) 567 | (update-tree bbtree 568 | (update (bbtree-tree bbtree) 569 | key 570 | proc 571 | default 572 | (bbtree-ordering-procedure bbtree)))) 573 | 574 | (define (bbtree-delete bbtree key) 575 | (assert (bbtree? bbtree)) 576 | (update-tree bbtree 577 | (delete (bbtree-tree bbtree) 578 | key 579 | (bbtree-ordering-procedure bbtree)))) 580 | 581 | (define (bbtree-contains? bbtree key) 582 | (assert (bbtree? bbtree)) 583 | (lookup (bbtree-tree bbtree) 584 | key 585 | (lambda (_) #t) 586 | (lambda () #f) 587 | (bbtree-ordering-procedure bbtree))) 588 | 589 | ;; iterators 590 | 591 | (define (traverse traverser base tree) 592 | (define (left base) 593 | (traverse traverser base (node-left tree))) 594 | (define (right base) 595 | (traverse traverser base (node-right tree))) 596 | (if (empty? tree) 597 | base 598 | (traverser (node-key tree) 599 | (node-value tree) 600 | left 601 | right 602 | base))) 603 | 604 | (define (bbtree-traverse traverser base bbtree) 605 | (assert (bbtree? bbtree)) 606 | (traverse traverser base (bbtree-tree bbtree))) 607 | 608 | (define (bbtree-fold combine base bbtree) 609 | (assert (bbtree? bbtree)) 610 | (traverse (lambda (k v l r n) 611 | (r (combine k v (l n)))) 612 | base 613 | (bbtree-tree bbtree))) 614 | 615 | (define (bbtree-fold-right combine base bbtree) 616 | (assert (bbtree? bbtree)) 617 | (traverse (lambda (k v l r n) 618 | (l (combine k v (r n)))) 619 | base 620 | (bbtree-tree bbtree))) 621 | 622 | ;; I could do this more efficiently, but is it worth it? 623 | (define (bbtree-map mapper bbtree) 624 | (bbtree-fold (lambda (key value tree) 625 | (bbtree-set tree key (mapper value))) 626 | (make-bbtree (bbtree-ordering-procedure bbtree)) 627 | bbtree)) 628 | 629 | (define (alist-cons a b c) 630 | (cons (cons a b) c)) 631 | 632 | (define (bbtree->alist bbtree) 633 | (bbtree-fold-right alist-cons '() bbtree)) 634 | 635 | (define (alist->bbtree list <) 636 | (fold-left (lambda (tree kv-pair) 637 | (bbtree-set tree (car kv-pair) (cdr kv-pair))) 638 | (make-bbtree <) 639 | list)) 640 | 641 | (define (bbtree-keys bbtree) 642 | (bbtree-fold-right (lambda (key value base) 643 | (cons key base)) 644 | '() 645 | bbtree)) 646 | 647 | (define (bbtree-union bbtree1 bbtree2) 648 | (update-tree bbtree1 649 | (hedge-union (bbtree-tree bbtree1) 650 | (bbtree-tree bbtree2) 651 | (bbtree-ordering-procedure bbtree1)))) 652 | 653 | (define (bbtree-difference bbtree1 bbtree2) 654 | (update-tree bbtree1 655 | (difference (bbtree-tree bbtree1) 656 | (bbtree-tree bbtree2) 657 | (bbtree-ordering-procedure bbtree1)))) 658 | 659 | (define (bbtree-intersection bbtree1 bbtree2) 660 | (update-tree bbtree1 661 | (intersection (bbtree-tree bbtree1) 662 | (bbtree-tree bbtree2) 663 | (bbtree-ordering-procedure bbtree1)))) 664 | 665 | (define (bbtree-index bbtree key) 666 | ;; maybe this should return #f instead of throwing an exception? 667 | (assert (bbtree? bbtree)) 668 | (rank (bbtree-tree bbtree) 669 | key 670 | (bbtree-ordering-procedure bbtree))) 671 | 672 | (define (bbtree-ref/index bbtree idx) 673 | (assert (bbtree? bbtree)) 674 | (let ((tree (bbtree-tree bbtree))) 675 | (unless (and (integer? idx) 676 | (<= 0 idx (- (size tree) 1))) 677 | (assertion-violation 'bbtree-ref/index 678 | "Not a valid index into the bbtree" 679 | idx)) 680 | (index tree idx))) 681 | 682 | ) 683 | -------------------------------------------------------------------------------- /deques.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; deques.sls --- Purely functional deques 3 | 4 | ;; Copyright (C) 2011,2012 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;; Documentation: 15 | ;; 16 | ;; make-deque : () -> deque 17 | ;; returns a deque containing to items 18 | ;; 19 | ;; deque? : any -> boolean 20 | ;; tests if an object is a deque 21 | ;; 22 | ;; deque-length : deque -> non-negative integer 23 | ;; returns the number of items in the deque 24 | ;; 25 | ;; deque-empty? : deque -> boolean 26 | ;; returns true if there are no items in the deque, false otherwise 27 | ;; 28 | ;; enqueue-front : deque any -> deque 29 | ;; returns a new deque with the inserted item at the front 30 | ;; 31 | ;; enqueue-rear : deque any -> deque 32 | ;; returns a new deque with the inserted item at the rear 33 | ;; 34 | ;; dequeue-front : deque -> any queue 35 | ;; returns two values, the item at the front of the deque, and a new 36 | ;; deque containing all the other items 37 | ;; raises a &deque-empty condition if the deque is empty 38 | ;; 39 | ;; dequeue-rear : deque -> any queue 40 | ;; returns two values, the item at the rear of the deque, and a new 41 | ;; deque containing all the other items 42 | ;; raises a &deque-empty condition if the deque is empty 43 | ;; 44 | ;; deque-empty-condition? : object -> boolean 45 | ;; tests if an object is a &deque-empty condition 46 | ;; 47 | ;; deque->list : deque -> listof(any) 48 | ;; returns a list containing all the elements of the deque. The order 49 | ;; of the elements in the list is the same as the order they would be 50 | ;; dequeued from the front of the deque. 51 | ;; 52 | ;; list->deque : listof(any) -> deque 53 | ;; returns a deque containing all of the elements in the list. The 54 | ;; order of the elements in the deque is the same as the order of the 55 | ;; elements in the list. 56 | ;; 57 | (library (pfds deques) 58 | (export make-deque 59 | deque? 60 | deque-length 61 | deque-empty? 62 | enqueue-front 63 | enqueue-rear 64 | dequeue-front 65 | dequeue-rear 66 | deque-empty-condition? 67 | deque->list 68 | list->deque 69 | ) 70 | (import (except (rnrs) cons*) 71 | (pfds deques private condition) 72 | (pfds private lazy-lists)) 73 | 74 | (define c 2) 75 | 76 | (define (rot1 n l r) 77 | (if (>= n c) 78 | (cons* (head l) 79 | (rot1 (- n c) (tail l) (drop c r))) 80 | (rot2 l (drop n r) '()))) 81 | 82 | (define (rot2 l r a) 83 | (if (empty? l) 84 | (append* (rev r) a) 85 | (cons* (head l) 86 | (rot2 (tail l) 87 | (drop c r) 88 | (append* (rev (take c r)) a))))) 89 | 90 | (define-record-type (deque %make-deque deque?) 91 | (fields 92 | (immutable length) 93 | (immutable lenL) 94 | (immutable lenR) 95 | (immutable l) 96 | (immutable r) 97 | (immutable l^) 98 | (immutable r^))) 99 | 100 | (define (make-deque) 101 | (%make-deque 0 0 0 '() '() '() '())) 102 | 103 | (define (deque-empty? deque) 104 | (zero? (deque-length deque))) 105 | 106 | (define (enqueue-front deque item) 107 | (let ((len (deque-length deque)) 108 | (l (deque-l deque)) 109 | (r (deque-r deque)) 110 | (lenL (deque-lenL deque)) 111 | (lenR (deque-lenR deque)) 112 | (l^ (deque-l^ deque)) 113 | (r^ (deque-r^ deque))) 114 | (makedq (+ 1 len) (+ 1 lenL) lenR (cons* item l) r (tail l^) (tail r^)))) 115 | 116 | (define (enqueue-rear deque item) 117 | (let ((len (deque-length deque)) 118 | (l (deque-l deque)) 119 | (r (deque-r deque)) 120 | (lenL (deque-lenL deque)) 121 | (lenR (deque-lenR deque)) 122 | (l^ (deque-l^ deque)) 123 | (r^ (deque-r^ deque))) 124 | (makedq (+ 1 len) lenL (+ 1 lenR) l (cons* item r) (tail l^) (tail r^)))) 125 | 126 | (define (dequeue-front deque) 127 | (when (deque-empty? deque) 128 | (raise (condition 129 | (make-deque-empty-condition) 130 | (make-who-condition 'dequeue-front) 131 | (make-message-condition "There are no elements to remove") 132 | (make-irritants-condition (list deque))))) 133 | (let ((len (deque-length deque)) 134 | (lenL (deque-lenL deque)) 135 | (lenR (deque-lenR deque)) 136 | (l (deque-l deque)) 137 | (r (deque-r deque)) 138 | (l^ (deque-l^ deque)) 139 | (r^ (deque-r^ deque))) 140 | (if (empty? l) 141 | (values (head r) (make-deque)) 142 | (values (head l) 143 | (makedq (- len 1) 144 | (- lenL 1) 145 | lenR 146 | (tail l) 147 | r 148 | (tail (tail l^)) 149 | (tail (tail r^))))))) 150 | 151 | (define (dequeue-rear deque) 152 | (when (deque-empty? deque) 153 | (raise (condition 154 | (make-deque-empty-condition) 155 | (make-who-condition 'dequeue-rear) 156 | (make-message-condition "There are no elements to remove") 157 | (make-irritants-condition (list deque))))) 158 | (let ((len (deque-length deque)) 159 | (lenL (deque-lenL deque)) 160 | (lenR (deque-lenR deque)) 161 | (l (deque-l deque)) 162 | (r (deque-r deque)) 163 | (l^ (deque-l^ deque)) 164 | (r^ (deque-r^ deque))) 165 | (if (empty? r) 166 | (values (head l) (make-deque)) 167 | (values (head r) 168 | (makedq (- len 1) 169 | lenL 170 | (- lenR 1) 171 | l 172 | (tail r) 173 | (tail (tail l^)) 174 | (tail (tail r^))))))) 175 | 176 | 177 | 178 | (define (makedq len lenL lenR l r l^ r^) 179 | (cond ((> lenL (+ 1 (* c lenR))) 180 | (let* ((n (floor (/ (+ lenL lenR) 2))) 181 | (l* (take n l)) 182 | (r* (rot1 n r l))) 183 | (%make-deque len n (- len n) l* r* l* r*))) 184 | ((> lenR (+ 1 (* c lenL))) 185 | (let* ((n (floor (/ (+ lenL lenR) 2))) 186 | (l* (rot1 n l r)) 187 | (r* (take n r))) 188 | (%make-deque len (- len n) n l* r* l* r*))) 189 | (else 190 | (%make-deque len lenL lenR l r l^ r^)))) 191 | 192 | (define (list->deque l) 193 | (fold-left enqueue-rear (make-deque) l)) 194 | 195 | (define (deque->list deq) 196 | (define (recur deq l) 197 | (if (deque-empty? deq) 198 | l 199 | (let-values ([(last deq*) (dequeue-rear deq)]) 200 | (recur deq* (cons last l))))) 201 | (recur deq '())) 202 | 203 | ) 204 | -------------------------------------------------------------------------------- /deques/naive.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; naive.sls --- Purely functional deques. 3 | 4 | ;; Copyright (C) 2013 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; This code shares the same interface as (pfds deques). Please see 17 | ;; that module for documentation of the interface. 18 | 19 | ;; Like (pfds queues naive), this provides a naive version that may be 20 | ;; more expensive in certain access patterns, but can be cheaper in 21 | ;; some common ones. 22 | 23 | ;; As always, if in doubt, benchmark. 24 | 25 | ;;; Code: 26 | (library (pfds deques naive) 27 | (export make-deque 28 | deque? 29 | deque-length 30 | deque-empty? 31 | enqueue-front 32 | enqueue-rear 33 | dequeue-front 34 | dequeue-rear 35 | deque-empty-condition? 36 | deque->list 37 | list->deque 38 | ) 39 | (import (rnrs) 40 | (pfds deques private condition)) 41 | 42 | (define-record-type (deque %make-deque deque?) 43 | (fields length head tail)) 44 | 45 | (define (make-deque) 46 | (%make-deque 0 '() '())) 47 | 48 | (define (deque-empty? deque) 49 | (zero? (deque-length deque))) 50 | 51 | (define (enqueue-front deque object) 52 | (%make-deque (+ 1 (deque-length deque)) 53 | (cons object (deque-head deque)) 54 | (deque-tail deque))) 55 | 56 | (define (enqueue-rear deque object) 57 | (%make-deque (+ 1 (deque-length deque)) 58 | (deque-head deque) 59 | (cons object (deque-tail deque)))) 60 | 61 | (define (dequeue-front deque) 62 | (when (deque-empty? deque) 63 | (raise (condition 64 | (make-deque-empty-condition) 65 | (make-who-condition 'dequeue-front) 66 | (make-message-condition "There are no elements to dequeue") 67 | (make-irritants-condition (list deque))))) 68 | (let ((l (deque-length deque)) 69 | (h (deque-head deque)) 70 | (t (deque-tail deque))) 71 | (if (null? h) 72 | (let ((h* (reverse t))) 73 | (values (car h*) 74 | (%make-deque (- l 1) (cdr h*) '()))) 75 | (values (car h) 76 | (%make-deque (- l 1) (cdr h) t))))) 77 | 78 | (define (dequeue-rear deque) 79 | (when (deque-empty? deque) 80 | (raise (condition 81 | (make-deque-empty-condition) 82 | (make-who-condition 'dequeue-rear) 83 | (make-message-condition "There are no elements to dequeue") 84 | (make-irritants-condition (list deque))))) 85 | (let ((l (deque-length deque)) 86 | (h (deque-head deque)) 87 | (t (deque-tail deque))) 88 | (if (null? t) 89 | (let ((t* (reverse h))) 90 | (values (car t*) 91 | (%make-deque (- l 1) '() (cdr t*)))) 92 | (values (car t) 93 | (%make-deque (- l 1) h (cdr t)))))) 94 | 95 | (define (list->deque l) 96 | (%make-deque (length l) l '())) 97 | 98 | (define (deque->list deque) 99 | (let ((h (deque-head deque)) 100 | (t (deque-tail deque))) 101 | (append h (reverse t)))) 102 | 103 | ) 104 | -------------------------------------------------------------------------------- /deques/private/condition.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; condition.sls --- Deque Conditions 3 | 4 | ;; Copyright (C) 2013 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | (library (pfds deques private condition) 14 | (export &deque-empty 15 | make-deque-empty-condition 16 | deque-empty-condition?) 17 | (import (rnrs conditions)) 18 | 19 | (define-condition-type &deque-empty 20 | &assertion 21 | make-deque-empty-condition 22 | deque-empty-condition?) 23 | 24 | ) 25 | -------------------------------------------------------------------------------- /dlists.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; dlists.sls --- Difference Lists 3 | 4 | ;; Copyright (C) 2012 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | ;; 16 | ;; Repeatedly appending to a list is a common, if inefficient pattern 17 | ;; in functional programs. Usually the trick we use is to build up the 18 | ;; list in reverse, and then to reverse it as the last action of a 19 | ;; function. 20 | ;; 21 | ;; Dlists are a representation of lists as functions that provide for 22 | ;; constant time append to either the front or end of a dlist that may 23 | ;; be used instead. 24 | 25 | ;;; Documentation: 26 | ;; 27 | ;; dlist : any ... -> dlist 28 | ;; returns a dlist containing all its arguments. 29 | ;; 30 | ;; dlist? : any -> boolean 31 | ;; returns #t if its argument is a dlist, #f otherwise. 32 | ;; 33 | ;; dlist-cons : any dlist -> dlist 34 | ;; returns a new dlist created by prepending the element to the head 35 | ;; of the dlist argument. 36 | ;; 37 | ;; dlist-snoc : dlist any -> dlist 38 | ;; returns a new dlist created by appending the element to the tail of 39 | ;; the dlist argument. 40 | ;; 41 | ;; dlist-append : dlist dlist -> dlist 42 | ;; returns a new dlist consisting of all the elements of the first 43 | ;; dlist, followed by all the items of the second dlist. 44 | ;; 45 | ;; dlist->list : dlist -> listof(any) 46 | ;; returns a list consisting of all the elements of the dlist. 47 | ;; 48 | ;; list->dlist : listof(any) -> dlist 49 | ;; returns a dlist consisting of all the elements of the list. 50 | (library (pfds dlists) 51 | (export (rename (%dlist dlist)) 52 | dlist? 53 | dlist-cons 54 | dlist-snoc 55 | dlist-append 56 | dlist->list 57 | list->dlist 58 | ) 59 | (import (rnrs)) 60 | 61 | (define-record-type dlist 62 | (fields 63 | (immutable proc undl))) 64 | 65 | (define (%dlist . args) 66 | (list->dlist args)) 67 | 68 | (define (compose f g) 69 | (lambda (x) 70 | (f (g x)))) 71 | 72 | (define (singleton x) 73 | (list->dlist (list x))) 74 | 75 | (define (dlist-append dl1 dl2) 76 | (make-dlist (compose (undl dl1) (undl dl2)))) 77 | 78 | (define (dlist-cons element dlist) 79 | (dlist-append (singleton element) dlist)) 80 | 81 | (define (dlist-snoc dlist element) 82 | (dlist-append dlist (singleton element))) 83 | 84 | (define (dlist->list dlist) 85 | ((undl dlist) '())) 86 | 87 | (define (list->dlist list) 88 | (make-dlist 89 | (lambda (rest) 90 | (append list rest)))) 91 | 92 | ) 93 | -------------------------------------------------------------------------------- /doc/dlists.scm: -------------------------------------------------------------------------------- 1 | ;; One advantage of dlists is that they allow you to write more 2 | ;; efficient programs, while keeping the lucidity of the less 3 | ;; efficient version. Take the naïve version of 'reverse' 4 | 5 | (define (reverse l) 6 | (if (null? l) 7 | '() 8 | (append (reverse (cdr l)) 9 | (list (car l))))) 10 | 11 | ;; The definition is obviously correct, however it isn't very 12 | ;; efficient. For a given step, the cost of the non-trivial case is 13 | ;; dependant on the size of the list we have gotten from the recursive 14 | ;; call. That is, it takes time proportional to the square of its 15 | ;; input list. 16 | ;; Of course, no self respecting functional programmer would write 17 | ;; reverse in this manner, as the trick of using an accumulating 18 | ;; parameter is so well established. Instead we would write 19 | 20 | (define (reverse l) 21 | (define (reverse-helper from to) 22 | (if (null? from) 23 | to 24 | (reverse-helper (cdr from) 25 | (cons (car from) to)))) 26 | (reverse-helper l '())) 27 | 28 | ;; By introducing this additional parameter, we have reclaimed a more 29 | ;; reasonable complexity of constant time at each recursive call, 30 | ;; giving us linear complexity overall. 31 | ;; This is a big improvement, and with a little practice, it becomes 32 | ;; easy to convince yourself of the correctness of code written in 33 | ;; this manner. 34 | 35 | ;; However, why should you have to practice? Why can't there be a 36 | ;; definition as obviously correct as the former, with the efficiency 37 | ;; of the latter? 38 | ;; Turns out, it is possible to do this, by using a different 39 | ;; representation for lists. 40 | 41 | (define (reverse* l) 42 | (if (null? l) 43 | (dlist) 44 | (dlist-append (reverse* (cdr l)) 45 | (dlist (car l))))) 46 | 47 | (define (reverse l) 48 | (dlist->list (reverse* l))) 49 | 50 | ;; Difference lists, or representing lists as functions, gives us a 51 | ;; constant time version of append, thus reducing the complexity of 52 | ;; reverse* to O(n), and the definition differs from the original, 53 | ;; only in the names we use for the append and list procedures. The 54 | ;; final result of this function, however, is a dlist rather than a 55 | ;; list, so we must convert back. This also has linear complexity, so 56 | ;; the overall complexity is still linear. 57 | 58 | ;; How does this work? Well, let's replace dlist and dlist-append with 59 | ;; their definitions 60 | (define (reverse* l) 61 | (if (null? l) 62 | (lambda (x) (append '() x)) 63 | (compose (reverse* (cdr l)) 64 | (lambda (x) (append (list (car l)) x))))) 65 | 66 | (define (reverse l) 67 | ((reverse* l) '())) 68 | 69 | ;; Now, we replace compose with its definition 70 | (define (reverse* l) 71 | (if (null? l) 72 | (lambda (x) (append '() x)) 73 | (lambda (x) 74 | ((reverse* (cdr l)) 75 | ((lambda (x) (append (list (car l)) x)) x))))) 76 | 77 | (define (reverse l) 78 | ((reverse* l) '())) 79 | 80 | ;; With a few simplifications: substituting x for its definition, 81 | ;; x for (append '() x), and (cons x y) for (append (list x) y) 82 | (define (reverse* l) 83 | (if (null? l) 84 | (lambda (x) x) 85 | (lambda (x) 86 | ((reverse* (cdr l)) 87 | (cons (car l) x))))) 88 | 89 | (define (reverse l) 90 | ((reverse* l) '())) 91 | 92 | ;; Now, if we uncurry reverse* 93 | (define (reverse* l x) 94 | (if (null? l) 95 | x 96 | (reverse* (cdr l) (cons (car l) x)))) 97 | 98 | (define (reverse l) 99 | (reverse* l '())) 100 | 101 | ;; Then, it turns out the dlist version is the traditional O(n) 102 | ;; implementation in disguise. 103 | 104 | ;; As an exercise, you can try doing the same thing for the flatten 105 | ;; function 106 | (define (flatten xs) 107 | (cond ((null? xs) '()) 108 | ((pair? xs) 109 | (append (flatten (car xs)) 110 | (flatten (cdr xs)))) 111 | (else (list xs)))) 112 | -------------------------------------------------------------------------------- /examples/queues.scm: -------------------------------------------------------------------------------- 1 | ;;; Functional Breadth First Search 2 | (import (rnrs) 3 | (pfds queues)) 4 | 5 | ;; This is the traditional solution using Queues, for a more 6 | ;; interesting solution, see "The Under-Appreciated Unfold" by Jeremy 7 | ;; Gibbons and Geraint Jones. 8 | 9 | ;; We'll need a tree type, we'll use #f for an empty child. 10 | (define-record-type tree 11 | (fields value left right)) 12 | 13 | ;; A small section of the Stern-Brocot Tree 14 | ;; https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree 15 | (define stern-brocot 16 | (make-tree 1 17 | (make-tree 1/2 18 | (make-tree 1/3 19 | (make-tree 1/4 #f #f) 20 | (make-tree 2/5 #f #f)) 21 | (make-tree 2/3 22 | (make-tree 3/5 #f #f) 23 | (make-tree 3/4 #f #f))) 24 | (make-tree 2 25 | (make-tree 3/2 26 | (make-tree 4/3 #f #f) 27 | (make-tree 5/3 #f #f)) 28 | (make-tree 3 29 | (make-tree 5/2 #f #f) 30 | (make-tree 4 #f #f))))) 31 | 32 | ;; We'll search it breadth-first for the first fraction expressed in 33 | ;; fifths. 34 | (define (fifth? f) 35 | (= 5 (denominator f))) 36 | 37 | ;; The queue search 38 | (define (bfs p? tree) 39 | (define (step queue) 40 | (if (queue-empty? queue) 41 | #f 42 | (let-values ([(head queue*) (dequeue queue)]) 43 | (cond ((not head) ; empty-tree, skip 44 | (step queue*)) 45 | ((p? (tree-value head)) (tree-value head)) 46 | (else 47 | (step (enqueue (enqueue queue* (tree-left head)) 48 | (tree-right head)))))))) 49 | 50 | (step (enqueue (make-queue) tree))) 51 | 52 | (equal? 2/5 (bfs fifth? stern-brocot)) 53 | -------------------------------------------------------------------------------- /fingertrees.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; fingertrees.sls --- A Simple General-Purpose Data Structure 3 | 4 | ;; Copyright (C) 2012 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | ;; 16 | ;; Fingertrees are a generalised form of deque, that you can parameterise 17 | ;; to compute a value, called the "measure" of a fingertree. This measure 18 | ;; will be updated incrementally as you add and remove elements from the 19 | ;; fingertree. Among other things, this allows fingertrees to be used 20 | ;; where you otherwise might have written a custom data structure. 21 | ;; 22 | ;; To compute the measure, fingertrees require pieces of information: a 23 | ;; converter, a combiner, and an identity. 24 | ;; 25 | ;; The converter is a procedure of one argument, that maps values in the 26 | ;; fingertree to other values which are used for computing the measure. 27 | ;; 28 | ;; The combiner is a procedure of two arguments, and combines these into 29 | ;; one value representing them both. A combiner must be associative 30 | ;; i.e. (combine A (combine B C)) must be equivalent to (combine (combine 31 | ;; A B) C) for all values A, B and C. 32 | ;; 33 | ;; An identity is a value that represents the measure of an empty 34 | ;; fingertree. It must obey the rule that (combine X identity), (combine 35 | ;; identity X) and X are always the same. 36 | ;; 37 | ;; To make things more concrete, a simple use of a fingertree is as a 38 | ;; deque that keeps a running total. In this case, the converter can 39 | ;; simply be the function (lambda (x) x) if it is a deque of integers, 40 | ;; the combiner would be +, and the identity 0. 41 | ;; 42 | ;; (define l '(3 1 4 1 5 9)) 43 | ;; 44 | ;; (define ft (list->fingertree l 0 + (lambda (x) x))) 45 | ;; 46 | ;; (fingertree-measure ft) 47 | ;; ; => 23 48 | ;; (fingertree-measure (fingertree-snoc ft 2)) 49 | ;; ; => 25 50 | ;; (let-values (((head tail) (fingertree-uncons ft))) 51 | ;; (fingertree-measure tail)) 52 | ;; ; => 20 53 | ;; 54 | ;; Mathematically speaking, the _return type_ of the converter, the 55 | ;; combiner and the identity element are expected to form a 56 | ;; monoid. 57 | ;; 58 | ;; Below, I use the slightly incorrect terminology of referring to the 59 | ;; combiner, the converter, and the identity, together as a 60 | ;; monoid. Mathematicians, please forgive me. Programmers please forgive 61 | ;; me even more. If you can provide a better name (from a programmers, 62 | ;; not a mathematicians, point of view) that works in most circumstances, 63 | ;; I will be happy to use it. 64 | ;; 65 | ;; (FWIW the Haskell Data.Fingertree package uses odd name of Measured 66 | ;; (which are expected to be instances of Monoid)) 67 | ;; 68 | ;; fingertree? : any -> bool 69 | ;; returns #t if argument is a fingertree, #f otherwise. 70 | ;; 71 | ;; fingertree-empty? : fingertree -> bool 72 | ;; returns #t if there are no items in the fingertree, #f otherwise. 73 | ;; 74 | ;; make-fingertree : id combine measure -> fingertree 75 | ;; returns a new fingertree, parameterised by the given monoid. 76 | ;; 77 | ;; fingertree-cons : any fingertree -> fingertree 78 | ;; returns the new fingertree created by adding the element to the front 79 | ;; of the argument fingertree. 80 | ;; 81 | ;; fingertree-snoc : fingertree any -> fingertree 82 | ;; returns the new fingertree created by adding the element to the end of 83 | ;; the fingertree. 84 | ;; 85 | ;; fingertree-uncons : fingertree -> any + fingertree 86 | ;; returns two values: the element at the front of the fingertree, and a 87 | ;; new fingertree containing all but the front element. If the fingertree 88 | ;; is empty, a &fingertree-empty condition is raised. 89 | ;; 90 | ;; fingertree-unsnoc : fingertree -> fingertree + any 91 | ;; returns two values: a new fingertree containing all but the rear 92 | ;; element of the argument fingertree, and the rear element itself. If 93 | ;; the fingertree is empty, a &fingertree-empty-condition is raised. 94 | ;; 95 | ;; fingertree-append : fingertree fingertree -> fingertree 96 | ;; returns a new fingertree which contains all of the elements of the 97 | ;; first fingertree argument, followed by all the elements of the 98 | ;; second. The argument fingertrees are assumed to be parameterised by 99 | ;; the same monoid. 100 | ;; 101 | ;; list->fingertree : (list->fingertree l id append convert) 102 | ;; returns a fingertree containing all of the elements of the argument 103 | ;; list, in the same order. 104 | ;; 105 | ;; fingertree->list : fingertree -> Listof(Any) 106 | ;; returns a list of all the elements in the fingertree, in the order 107 | ;; they would be unconsed. 108 | ;; 109 | ;; fingertree-measure : fingertree -> any 110 | ;; returns the measure of the fingertree, as defined by the fingertree's 111 | ;; monoid. 112 | ;; 113 | ;; fingertree-split : (any -> bool) fingertree -> fingertree + fingertree 114 | ;; returns two values: the first is the largest prefix of the fingertree for 115 | ;; which applying the predicate to it's accumulated measure returns 116 | ;; #f. The second values is a fingertree containing all those elements 117 | ;; not in the first fingertree. 118 | ;; 119 | ;; fingertree-split3: (any -> bool) fingertree -> fingertree + value + fingertree 120 | ;; similar to fingertree-split, however, instead of returning the 121 | ;; remainder as the second argument, it returns the head of the remainder 122 | ;; as the second argument, and tail of the remainder as the third 123 | ;; argument. 124 | ;; TODO: what error should I give if the remainder was empty? 125 | ;; 126 | ;; fingertree-fold : (any -> any -> any) any fingertree 127 | ;; returns the value obtained by iterating the combiner procedure over 128 | ;; the fingertree in left-to-right order. This procedure takes two 129 | ;; arguments, the current value from the fingertree, and an accumulator, 130 | ;; and it's return value is used as the accumulator for the next 131 | ;; iteration. The initial value for the accumulator is given by the base 132 | ;; argument. 133 | ;; 134 | ;; fingertree-fold-right : (any -> any -> any) any fingertree 135 | ;; similar to fingertree-fold, but iterates in right-to-left order. 136 | ;; 137 | ;; fingertree-reverse : fingertree -> fingertree 138 | ;; returns a new fingertree in which the elements are in the opposite 139 | ;; order from the argument fingertree. 140 | ;; 141 | ;; fingertree-empty-condition? : condition -> bool 142 | ;; returns #t if the argument is a &fingertree-empty condition, #f otherwise. 143 | ;; 144 | (library (pfds fingertrees) 145 | (export fingertree? 146 | fingertree-empty? 147 | make-fingertree 148 | fingertree-cons 149 | fingertree-snoc 150 | fingertree-uncons 151 | fingertree-unsnoc 152 | fingertree-append 153 | list->fingertree 154 | fingertree->list 155 | fingertree-measure 156 | fingertree-split 157 | fingertree-split3 158 | fingertree-fold 159 | fingertree-fold-right 160 | fingertree-reverse 161 | fingertree-empty-condition? 162 | ) 163 | (import (rnrs)) 164 | 165 | ;;; List helpers 166 | 167 | (define (snoc l val) 168 | (append l (list val))) 169 | 170 | (define (take l n) 171 | (if (or (null? l) (zero? n)) 172 | '() 173 | (cons (car l) 174 | (take (cdr l) (- n 1))))) 175 | 176 | (define (last list) 177 | (if (null? (cdr list)) 178 | (car list) 179 | (last (cdr list)))) 180 | 181 | (define (but-last list) 182 | (if (null? (cdr list)) 183 | '() 184 | (cons (car list) 185 | (but-last (cdr list))))) 186 | 187 | (define (map-reverse f l) 188 | (fold-left (lambda (o n) (cons (f n) o)) '() l)) 189 | 190 | ;;; Node type 191 | 192 | (define-record-type node2 193 | (protocol 194 | (lambda (new) 195 | (lambda (monoid a b) 196 | (define app (mappend monoid)) 197 | (new (app (measure-nodetree a monoid) 198 | (measure-nodetree b monoid)) 199 | a 200 | b)))) 201 | (fields measure a b)) 202 | 203 | (define-record-type node3 204 | (protocol 205 | (lambda (new) 206 | (lambda (monoid a b c) 207 | (define app (mappend monoid)) 208 | (new (app (app (measure-nodetree a monoid) 209 | (measure-nodetree b monoid)) 210 | (measure-nodetree c monoid)) 211 | a 212 | b 213 | c)))) 214 | (fields measure a b c)) 215 | 216 | (define (node-case node k2 k3) 217 | (if (node2? node) 218 | (k2 (node2-a node) (node2-b node)) 219 | (k3 (node3-a node) (node3-b node) (node3-c node)))) 220 | 221 | (define (node-fold-right f base node) 222 | (node-case node 223 | (lambda (a b) 224 | (f a (f b base))) 225 | (lambda (a b c) 226 | (f a (f b (f c base)))))) 227 | 228 | (define (node->list node) 229 | (node-fold-right cons '() node)) 230 | 231 | (define (nodetree-fold-right f base nodetree) 232 | (define (foldr node base) 233 | (cond ((node2? node) 234 | (foldr (node2-a node) 235 | (foldr (node2-b node) base))) 236 | ((node3? node) 237 | (foldr (node3-a node) 238 | (foldr (node3-b node) 239 | (foldr (node3-c node) base)))) 240 | (else (f node base)))) 241 | (foldr nodetree base)) 242 | 243 | (define (nodetree-fold-left f base nodetree) 244 | (define (foldl node base) 245 | (cond ((node2? node) 246 | (foldl (node2-b node) 247 | (foldl (node2-a node) base))) 248 | ((node3? node) 249 | (foldl (node3-c node) 250 | (foldl (node3-b node) 251 | (foldl (node3-a node) base)))) 252 | (else (f node base)))) 253 | (foldl nodetree base)) 254 | 255 | ;;; Tree type 256 | 257 | (define-record-type empty) 258 | 259 | (define-record-type single 260 | (fields value)) 261 | 262 | (define-record-type rib 263 | (protocol 264 | (lambda (new) 265 | (lambda (monoid left middle right) 266 | (define app (mappend monoid)) 267 | (new (app (app (measure-digit left monoid) 268 | (measure-ftree middle monoid)) 269 | (measure-digit right monoid)) 270 | left 271 | middle 272 | right) 273 | ))) 274 | ;; left and right expected to be lists of length 0 < l < 5 275 | (fields measure left middle right)) 276 | 277 | (define (ftree-case ftree empty-k single-k rib-k) 278 | (cond ((empty? ftree) (empty-k)) 279 | ((single? ftree) 280 | (single-k (single-value ftree))) 281 | (else 282 | (rib-k (rib-left ftree) 283 | (rib-middle ftree) 284 | (rib-right ftree))))) 285 | 286 | (define (digits-fold-right f b d) 287 | (fold-right (lambda (ntree base) 288 | (nodetree-fold-right f base ntree)) 289 | b 290 | d)) 291 | 292 | (define (digits-fold-left f b d) 293 | (fold-left (lambda (base ntree) 294 | (nodetree-fold-left f base ntree)) 295 | b 296 | d)) 297 | 298 | (define (ftree-fold-right proc base ftree) 299 | (ftree-case ftree 300 | (lambda () base) 301 | (lambda (x) (nodetree-fold-right proc base x)) 302 | (lambda (l x r) 303 | (define base* (digits-fold-right proc base r)) 304 | (define base** (ftree-fold-right proc base* x)) 305 | (digits-fold-right proc base** l)))) 306 | 307 | (define (ftree-fold-left proc base ftree) 308 | (ftree-case ftree 309 | (lambda () base) 310 | (lambda (x) (nodetree-fold-left proc base x)) 311 | (lambda (l x r) 312 | (define base* (digits-fold-left proc base l)) 313 | (define base** (ftree-fold-left proc base* x)) 314 | (digits-fold-left proc base** r)))) 315 | 316 | (define (insert-front ftree val monoid) 317 | (ftree-case ftree 318 | (lambda () 319 | (make-single val)) 320 | (lambda (a) 321 | (make-rib monoid (list val) (make-empty) (list a))) 322 | (lambda (l m r) 323 | (if (= (length l) 4) 324 | (make-rib monoid 325 | (list val (car l)) 326 | (insert-front m (apply make-node3 monoid (cdr l)) monoid) 327 | r) 328 | (make-rib monoid (cons val l) m r))))) 329 | 330 | (define (view-front ftree empty-k cons-k monoid) 331 | (ftree-case ftree 332 | empty-k 333 | (lambda (a) 334 | (cons-k a (make-empty))) 335 | (lambda (l r m) 336 | (cons-k (car l) 337 | (rib-l (cdr l) r m monoid))))) 338 | 339 | (define (list->tree l monoid) 340 | (fold-right (lambda (val tree) 341 | (insert-front tree val monoid)) 342 | (make-empty) 343 | l)) 344 | 345 | (define (rib-l l m r monoid) 346 | (if (null? l) 347 | (view-front m 348 | (lambda () 349 | (list->tree r monoid)) 350 | (lambda (x xs) 351 | (make-rib monoid 352 | (node->list x) 353 | xs 354 | r)) 355 | monoid) 356 | (make-rib monoid l m r))) 357 | 358 | (define (remove-front ftree monoid) 359 | (view-front ftree 360 | (lambda () 361 | (error 'remove-front "can't remove from an empty tree")) 362 | values 363 | monoid)) 364 | 365 | (define (insert-rear ftree val monoid) 366 | (ftree-case ftree 367 | (lambda () 368 | (make-single val)) 369 | (lambda (a) 370 | (make-rib monoid (list a) (make-empty) (list val))) 371 | (lambda (l m r) 372 | ;; TODO: should r be maintained in reverse order, rather than 373 | ;; normal? 374 | ;; yes! it will make concatenation slightly slower, but will 375 | ;; speed up inserts and removals 376 | (if (= (length r) 4) 377 | (make-rib monoid 378 | l 379 | (insert-rear m (apply make-node3 monoid (take r 3)) monoid) 380 | (list (list-ref r 3) val)) 381 | (make-rib monoid l m (snoc r val)))))) 382 | 383 | (define (remove-rear ftree monoid) 384 | (view-rear ftree 385 | (lambda () 386 | (error 'remove-rear "can't remove from an empty tree")) 387 | values 388 | monoid)) 389 | 390 | (define (view-rear ftree empty-k snoc-k monoid) 391 | (ftree-case ftree 392 | empty-k 393 | (lambda (a) 394 | (snoc-k (make-empty) a)) 395 | (lambda (l r m) 396 | (snoc-k (rib-r l r (but-last m) monoid) 397 | (last m))))) 398 | 399 | (define (rib-r l m r monoid) 400 | (if (null? r) 401 | (view-rear m 402 | (lambda () 403 | (list->tree l monoid)) 404 | (lambda (m* r*) 405 | (make-rib monoid l m* (node->list r*))) 406 | monoid) 407 | (make-rib monoid l m r))) 408 | 409 | (define (insert-front/list tree l monoid) 410 | (fold-right (lambda (val tree) 411 | (insert-front tree val monoid)) 412 | tree 413 | l)) 414 | 415 | (define (insert-rear/list tree l monoid) 416 | (fold-left (lambda (tree val) 417 | (insert-rear tree val monoid)) 418 | tree 419 | l)) 420 | 421 | (define (app3 ftree1 ts ftree2 monoid) 422 | (cond ((empty? ftree1) 423 | (insert-front/list ftree2 ts monoid)) 424 | ((empty? ftree2) 425 | (insert-rear/list ftree1 ts monoid)) 426 | ((single? ftree1) 427 | (insert-front (insert-front/list ftree2 ts monoid) 428 | (single-value ftree1) 429 | monoid)) 430 | ((single? ftree2) 431 | (insert-rear (insert-rear/list ftree1 ts monoid) 432 | (single-value ftree2) 433 | monoid)) 434 | (else 435 | (let ((l1 (rib-left ftree1)) 436 | (m1 (rib-middle ftree1)) 437 | (r1 (rib-right ftree1)) 438 | (l2 (rib-left ftree2)) 439 | (m2 (rib-middle ftree2)) 440 | (r2 (rib-right ftree2))) 441 | (make-rib monoid 442 | l1 443 | (app3 m1 444 | (nodes (append r1 ts l2) monoid) 445 | m2 446 | monoid) 447 | r2))))) 448 | 449 | (define (nodes lst monoid) 450 | ;; *sigh* 451 | (let ((a (car lst)) 452 | (b (cadr lst))) 453 | (cond ((null? (cddr lst)) 454 | (list (make-node2 monoid a b))) 455 | ((null? (cdddr lst)) 456 | (list (make-node3 monoid a b (caddr lst)))) 457 | ((null? (cddddr lst)) 458 | (list (make-node2 monoid a b) 459 | (make-node2 monoid (caddr lst) (cadddr lst)))) 460 | (else 461 | (cons (make-node3 monoid a b (caddr lst)) 462 | (nodes (cdddr lst) monoid)))))) 463 | 464 | (define (reverse-tree tree monoid) 465 | (ftree-case tree 466 | (lambda () (make-empty)) 467 | (lambda (x) (make-single (reverse-nodetree x monoid))) 468 | (lambda (l x r) 469 | (make-rib monoid 470 | (reverse-digit r monoid) 471 | (reverse-tree x monoid) 472 | (reverse-digit l monoid))))) 473 | 474 | (define (reverse-digit l monoid) 475 | (map-reverse (lambda (a) (reverse-nodetree a monoid)) l)) 476 | 477 | (define (reverse-nodetree l monoid) 478 | (cond ((node2? l) 479 | (make-node2 monoid 480 | (reverse-nodetree (node2-b l) monoid) 481 | (reverse-nodetree (node2-a l) monoid))) 482 | ((node3? l) 483 | (make-node3 monoid 484 | (reverse-nodetree (node3-c l) monoid) 485 | (reverse-nodetree (node3-b l) monoid) 486 | (reverse-nodetree (node3-a l) monoid))) 487 | (else l))) 488 | 489 | ;; generalising fingertrees with monoids 490 | 491 | ;; I think I'm going to need a "configuration" type and pass it around 492 | ;; in order to generalize over arbitrary monoids 493 | ;; call the type iMeasured or something 494 | 495 | (define-record-type monoid* 496 | ;; a monoid, but augmented with a procedure to convert objects into the 497 | ;; monoid type 498 | (fields (immutable empty mempty) 499 | (immutable append mappend) 500 | (immutable convert mconvert))) 501 | 502 | (define (measure-digit obj monoid) 503 | (fold-left (lambda (i a) 504 | ((mappend monoid) i (measure-nodetree a monoid))) 505 | (mempty monoid) 506 | obj)) 507 | 508 | (define (measure-ftree obj monoid) 509 | (cond ((empty? obj) 510 | (mempty monoid)) 511 | ((single? obj) 512 | (measure-nodetree (single-value obj) monoid)) 513 | (else 514 | (rib-measure obj)))) 515 | 516 | (define (measure-nodetree obj monoid) 517 | (cond ((node2? obj) (node2-measure obj)) 518 | ((node3? obj) (node3-measure obj)) 519 | (else ((mconvert monoid) obj)))) 520 | 521 | (define (split proc tree monoid) 522 | (if (empty? tree) 523 | (values (make-empty) (make-empty)) 524 | (if (proc (measure-ftree tree monoid)) 525 | (let-values (((l x r) (split-tree proc (mempty monoid) tree monoid))) 526 | (values l (insert-front r x monoid))) 527 | (values tree (make-empty))))) 528 | 529 | (define (split-tree proc i tree monoid) 530 | (ftree-case tree 531 | (lambda () 532 | (error 'split-tree "shouldn't happen?")) 533 | (lambda (a) 534 | (values (make-empty) a (make-empty))) 535 | (lambda (l m r) 536 | (define app (mappend monoid)) 537 | (define vpr (app i (measure-digit l monoid))) 538 | (define vm (app vpr (measure-ftree m monoid))) 539 | (cond ((proc vpr) 540 | (let-values (((l* x* r*) (split-digit proc i l monoid))) 541 | (values (list->tree l* monoid) 542 | x* 543 | (rib-l r* m r monoid)))) 544 | ((proc vm) 545 | (let*-values (((ml xs mr) (split-tree proc vpr m monoid)) 546 | ((l* x* r*) 547 | (split-digit proc 548 | (app vpr (measure-ftree ml monoid)) 549 | (node->list xs) 550 | monoid))) 551 | (values (rib-r l ml l* monoid) 552 | x* 553 | (rib-l r* mr r monoid)))) 554 | (else 555 | (let-values (((l* x* r*) (split-digit proc vm r monoid))) 556 | (values (rib-r l m l* monoid) 557 | x* 558 | (list->tree r* monoid)))))))) 559 | 560 | (define (split-digit proc i xs monoid) 561 | (if (null? (cdr xs)) 562 | (values '() (car xs) '()) 563 | (let ((i* ((mappend monoid) i (measure-nodetree (car xs) monoid)))) 564 | (if (proc i*) 565 | (values '() (car xs) (cdr xs)) 566 | (let-values (((l x r) 567 | (split-digit proc i* (cdr xs) monoid))) 568 | (values (cons (car xs) l) x r)))))) 569 | 570 | ;; exported interface 571 | (define-condition-type &fingertree-empty 572 | &assertion 573 | make-fingertree-empty-condition 574 | fingertree-empty-condition?) 575 | 576 | (define-record-type (fingertree %make-fingertree fingertree?) 577 | (fields tree monoid)) 578 | 579 | (define (%wrap fingertree tree) 580 | (%make-fingertree tree 581 | (fingertree-monoid fingertree))) 582 | 583 | (define (make-fingertree id append convert) 584 | (%make-fingertree (make-empty) 585 | (make-monoid* id append convert))) 586 | 587 | (define (fingertree-cons a fingertree) 588 | ;; TODO: should it obey normal cons interface, or have fingertree 589 | ;; first? 590 | (%wrap fingertree 591 | (insert-front (fingertree-tree fingertree) 592 | a 593 | (fingertree-monoid fingertree)))) 594 | 595 | (define (fingertree-snoc fingertree a) 596 | (%wrap fingertree 597 | (insert-rear (fingertree-tree fingertree) 598 | a 599 | (fingertree-monoid fingertree)))) 600 | 601 | (define (fingertree-uncons fingertree) 602 | (call-with-values 603 | (lambda () 604 | (define t (fingertree-tree fingertree)) 605 | (when (empty? t) 606 | (raise 607 | (condition 608 | (make-fingertree-empty-condition) 609 | (make-who-condition 'fingertree-uncons) 610 | (make-message-condition "There are no elements to uncons") 611 | (make-irritants-condition (list fingertree))))) 612 | (remove-front t (fingertree-monoid fingertree))) 613 | (lambda (val rest) 614 | (values val 615 | (%wrap fingertree rest))))) 616 | 617 | (define (fingertree-unsnoc fingertree) 618 | (call-with-values 619 | (lambda () 620 | (define t (fingertree-tree fingertree)) 621 | (when (empty? t) 622 | (raise 623 | (condition 624 | (make-fingertree-empty-condition) 625 | (make-who-condition 'fingertree-unsnoc) 626 | (make-message-condition "There are no elements to unsnoc") 627 | (make-irritants-condition (list fingertree))))) 628 | (remove-rear t (fingertree-monoid fingertree))) 629 | (lambda (rest val) 630 | (values (%wrap fingertree rest) val)))) 631 | 632 | (define (fingertree-empty? fingertree) 633 | (empty? (fingertree-tree fingertree))) 634 | 635 | (define (fingertree-append fingertree1 fingertree2) 636 | (%wrap fingertree1 637 | (app3 (fingertree-tree fingertree1) 638 | '() 639 | (fingertree-tree fingertree2) 640 | (fingertree-monoid fingertree1)))) 641 | 642 | ;; TODO: fix this 643 | (define (list->fingertree l id append convert) 644 | (define monoid (make-monoid* id append convert)) 645 | (%make-fingertree (list->tree l monoid) monoid)) 646 | 647 | (define (fingertree->list t) 648 | (fingertree-fold-right cons '() t)) 649 | 650 | (define (fingertree-measure fingertree) 651 | (measure-ftree (fingertree-tree fingertree) 652 | (fingertree-monoid fingertree))) 653 | 654 | 655 | (define (fingertree-split p fingertree) 656 | (call-with-values 657 | (lambda () 658 | (split p 659 | (fingertree-tree fingertree) 660 | (fingertree-monoid fingertree))) 661 | (lambda (a b) 662 | (values (%wrap fingertree a) 663 | (%wrap fingertree b))))) 664 | 665 | (define (fingertree-split3 p fingertree) 666 | (call-with-values 667 | (lambda () 668 | (define monoid (fingertree-monoid fingertree)) 669 | (split-tree p 670 | (mempty monoid) 671 | (fingertree-tree fingertree) 672 | monoid)) 673 | (lambda (a b c) 674 | (values (%wrap fingertree a) 675 | b 676 | (%wrap fingertree c))))) 677 | 678 | (define (fingertree-fold f b fingertree) 679 | (ftree-fold-left f b (fingertree-tree fingertree))) 680 | 681 | (define (fingertree-fold-right f b fingertree) 682 | (ftree-fold-right f b (fingertree-tree fingertree))) 683 | 684 | (define (fingertree-reverse fingertree) 685 | (%wrap fingertree 686 | (reverse-tree (fingertree-tree fingertree) 687 | (fingertree-monoid fingertree)))) 688 | 689 | ) 690 | -------------------------------------------------------------------------------- /hamts.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; hamts.sls --- Hash Array Mapped Tries 3 | 4 | ;; Copyright (C) 2014 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;; Documentation: 15 | ;; 16 | ;; Note: For all procedures which take a key as an argument, the key 17 | ;; must be hashable with the hamt hash function, and comparable with 18 | ;; the hamt equivalence predicate. 19 | ;; 20 | ;; make-hamt : (any -> non-negative integer) (any -> any -> boolean) -> hamt 21 | ;; returns a new empty hamt using the given hash and equivalence functions. 22 | ;; 23 | ;; hamt? : any -> boolean 24 | ;; returns #t if argument is a hamt, #f otherwise. 25 | ;; 26 | ;; hamt-size : hamt -> non-negative integer 27 | ;; returns the number of associations in the hamt. 28 | ;; 29 | ;; hamt-ref : hamt any [any] -> any 30 | ;; returns the value associated with the key in the hamt. If there is 31 | ;; no value associated with the key, it returns the default value if 32 | ;; provided, or raises an &assertion-violation if it isn't. 33 | ;; 34 | ;; hamt-contains? : hamt any -> boolean 35 | ;; returns #t if there is an association for the key in the hamt, #f 36 | ;; otherwise. 37 | ;; 38 | ;; hamt-set : hamt any any -> hamt 39 | ;; returns a new hamt with the key associated to the value. If the key 40 | ;; is already associated with a value, it is replaced. 41 | ;; 42 | ;; hamt-update : hamt any (any -> any) any -> hamt 43 | ;; returns a new hamt with the valued associated with the key updated 44 | ;; by the update procedure. If the hamt does not already have a value 45 | ;; associated with the key, then it applies the update procedure to 46 | ;; the default value, and associates the key with that. 47 | ;; 48 | ;; hamt-delete : hamt any -> hamt 49 | ;; returns a hamt with the key and its associated value removed. If 50 | ;; the key is not in the hamt, a copy of the original hamt is 51 | ;; returned. 52 | ;; 53 | ;; hamt-fold : (any any any -> any) any hamt -> hamt 54 | ;; returns the value obtained by iterating the combine procedure over 55 | ;; each key value pair in the hamt. The combine procedure takes three 56 | ;; arguments, the key and value of an association, and an accumulator, 57 | ;; and returns a new accumulator value. The initial value of the 58 | ;; accumulator is provided by the base argument. The order in which 59 | ;; the hamt is traversed is not guaranteed. 60 | ;; 61 | ;; hamt-map : (any -> any) hamt -> hamt 62 | ;; returns the hamt obtained by applying the update procedure to each 63 | ;; of the values in the hamt. 64 | ;; 65 | ;; hamt->alist : hamt -> Listof(Pairs) 66 | ;; returns the key/value associations of the hamt as a list of pairs. 67 | ;; The order of the list is not guaranteed. 68 | ;; 69 | ;; alist->hamt : Listof(Pairs) (any -> non-negative integer) (any -> any -> boolean) -> hamt 70 | ;; returns the hamt containing the associations specified by the pairs 71 | ;; in the alist. If the same key appears in the alist multiple times, 72 | ;; its leftmost value is the one that is used. 73 | ;; 74 | ;; hamt-equivalence-predicate : hamt -> (any -> any -> boolean) 75 | ;; returns the procedure used internally by the hamt to compare keys. 76 | ;; 77 | ;; hamt-hash-function : hamt -> (any -> non-negative integer) 78 | ;; returns the hash procedure used internally by the hamt. 79 | ;; 80 | (library (pfds hamts) 81 | (export make-hamt 82 | hamt? 83 | hamt-size 84 | hamt-ref 85 | hamt-set 86 | hamt-update 87 | hamt-delete 88 | hamt-contains? 89 | hamt-equivalence-predicate 90 | hamt-hash-function 91 | hamt-fold 92 | hamt-map 93 | hamt->alist 94 | alist->hamt 95 | ) 96 | (import (rnrs) 97 | (pfds private vectors) 98 | (pfds private alists) 99 | (pfds private bitwise)) 100 | 101 | ;;; Helpers 102 | 103 | (define cardinality 32) ; 64 104 | 105 | (define (mask key level) 106 | (bitwise-arithmetic-shift-right (bitwise-and key (- (expt 2 5) 1)) level)) 107 | 108 | (define (level-up level) 109 | (+ level 5)) 110 | 111 | (define (ctpop key index) 112 | (bitwise-bit-count (bitwise-arithmetic-shift-right key (+ 1 index)))) 113 | 114 | ;;; Node types 115 | 116 | (define-record-type (subtrie %make-subtrie subtrie?) 117 | (fields size bitmap vector)) 118 | 119 | (define (make-subtrie bitmap vector) 120 | (define vecsize 121 | (vector-fold (lambda (val accum) 122 | (+ (size val) accum)) 123 | 0 124 | vector)) 125 | (%make-subtrie vecsize bitmap vector)) 126 | 127 | (define-record-type leaf 128 | (fields key value)) 129 | 130 | (define-record-type (collision %make-collision collision?) 131 | (fields size hash alist)) 132 | 133 | (define (make-collision hash alist) 134 | (%make-collision (length alist) hash alist)) 135 | 136 | ;;; Main 137 | 138 | (define (lookup vector key default hash eqv?) 139 | (define (handle-subtrie node level) 140 | (define bitmap (subtrie-bitmap node)) 141 | (define vector (subtrie-vector node)) 142 | (define index (mask h level)) 143 | (if (not (bitwise-bit-set? bitmap index)) 144 | default 145 | (let ((node (vector-ref vector (ctpop bitmap index)))) 146 | (cond ((leaf? node) 147 | (handle-leaf node)) 148 | ((collision? node) 149 | (handle-collision node)) 150 | (else 151 | (handle-subtrie node (level-up level))))))) 152 | 153 | (define (handle-leaf node) 154 | (if (eqv? key (leaf-key node)) 155 | (leaf-value node) 156 | default)) 157 | 158 | (define (handle-collision node) 159 | (alist-ref (collision-alist node) key default eqv?)) 160 | 161 | (define h (hash key)) 162 | (define node (vector-ref vector (mask h 0))) 163 | 164 | (cond ((not node) default) 165 | ((leaf? node) (handle-leaf node)) 166 | ((collision? node) (handle-collision node)) 167 | (else 168 | (handle-subtrie node (level-up 0))))) 169 | 170 | (define (insert hvector key update base hash eqv?) 171 | (define (handle-subtrie subtrie level) 172 | (define bitmap (subtrie-bitmap subtrie)) 173 | (define vector (subtrie-vector subtrie)) 174 | (define index (mask h level)) 175 | (define (fixup node) 176 | (make-subtrie bitmap (vector-set vector index node))) 177 | (if (not (bitwise-bit-set? bitmap index)) 178 | (make-subtrie (bitwise-bit-set bitmap index) 179 | (vector-insert vector 180 | (ctpop bitmap index) 181 | (make-leaf key (update base)))) 182 | (let ((node (vector-ref vector (ctpop bitmap index)))) 183 | (cond ((leaf? node) 184 | (fixup (handle-leaf node level))) 185 | ((collision? node) 186 | (fixup (handle-collision node level))) 187 | (else 188 | (fixup (handle-subtrie node (level-up level)))))))) 189 | 190 | (define (handle-leaf node level) 191 | (define lkey (leaf-key node)) 192 | (define khash (bitwise-arithmetic-shift-right h level)) 193 | (define lhash (bitwise-arithmetic-shift-right (hash lkey) level)) 194 | (cond ((eqv? key lkey) 195 | (make-leaf key (update (leaf-value node)))) 196 | ((equal? khash lhash) 197 | (make-collision lhash 198 | (list (cons lkey (leaf-value node)) 199 | (cons key (update base))))) 200 | (else 201 | (handle-subtrie (wrap-subtrie node lhash) (level-up level))))) 202 | 203 | (define (handle-collision node level) 204 | (define khash (bitwise-arithmetic-shift-right h level)) 205 | (define chash (bitwise-arithmetic-shift-right (collision-hash node) level)) 206 | (if (equal? khash chash) 207 | (make-collision (collision-hash node) 208 | (alist-update (collision-alist node) key update base eqv?)) 209 | ;; TODO: there may be a better (more efficient) way to do this 210 | ;; but simple is better for now (see also handle-leaf) 211 | (handle-subtrie (wrap-subtrie node chash) (level-up level)))) 212 | 213 | (define (wrap-subtrie node chash) 214 | (make-subtrie (bitwise-bit-set 0 (mask chash 0)) (vector node))) 215 | 216 | (define h (hash key)) 217 | (define idx (mask h 0)) 218 | (define node (vector-ref hvector idx)) 219 | (define initial-level (level-up 0)) 220 | 221 | (cond ((not node) 222 | (vector-set hvector idx (make-leaf key (update base)))) 223 | ((leaf? node) 224 | (vector-set hvector idx (handle-leaf node initial-level))) 225 | ((collision? node) 226 | (vector-set hvector idx (handle-collision node initial-level))) 227 | (else 228 | (vector-set hvector idx (handle-subtrie node initial-level))))) 229 | 230 | (define (delete vector key hash eqv?) 231 | (define (handle-subtrie subtrie level) 232 | (define bitmap (subtrie-bitmap subtrie)) 233 | (define vector (subtrie-vector subtrie)) 234 | (define index (mask h level)) 235 | (define (fixup node) 236 | (update bitmap vector index node)) 237 | (if (not (bitwise-bit-set? bitmap index)) 238 | subtrie 239 | (let ((node (vector-ref vector (ctpop bitmap index)))) 240 | (cond ((leaf? node) 241 | (fixup (handle-leaf node))) 242 | ((collision? node) 243 | (fixup (handle-collision node))) 244 | (else 245 | (fixup (handle-subtrie node (level-up level)))))))) 246 | 247 | (define (update bitmap vector index value) 248 | (if value 249 | (make-subtrie bitmap (vector-set vector index value)) 250 | (let ((vector* (vector-remove vector index))) 251 | (if (equal? '#() vector) 252 | #f 253 | (make-subtrie (bitwise-bit-unset bitmap index) 254 | vector*))))) 255 | 256 | (define (handle-leaf node) 257 | (if (eqv? key (leaf-key node)) 258 | #f 259 | node)) 260 | 261 | (define (handle-collision node) 262 | (let ((al (alist-delete (collision-alist node) key eqv?))) 263 | (cond ((null? (cdr al)) 264 | (make-leaf (car (car al)) (cdr (car al)))) 265 | (else 266 | (make-collision (collision-hash node) al))))) 267 | 268 | (define h (hash key)) 269 | (define idx (mask h 0)) 270 | (define node (vector-ref vector idx)) 271 | 272 | (cond ((not node) vector) 273 | ((leaf? node) 274 | (vector-set vector idx (handle-leaf node))) 275 | ((collision? node) 276 | (vector-set vector idx (handle-collision node))) 277 | (else 278 | (vector-set vector idx (handle-subtrie node (level-up 0)))))) 279 | 280 | (define (vec-map mapper vector) 281 | (define (handle-subtrie trie) 282 | (make-subtrie (subtrie-bitmap trie) 283 | (vector-map dispatch (subtrie-vector vector)))) 284 | 285 | (define (handle-leaf leaf) 286 | (make-leaf (leaf-key leaf) 287 | (mapper (leaf-value leaf)))) 288 | 289 | (define (handle-collision collision) 290 | (make-collision (collision-hash collision) 291 | (map (lambda (pair) 292 | (cons (car pair) (mapper (cdr pair)))) 293 | (collision-alist collision)))) 294 | 295 | (define (dispatch val) 296 | (cond ((leaf? val) 297 | (handle-leaf val)) 298 | ((collision? val) 299 | (handle-collision val)) 300 | (else 301 | (handle-subtrie val)))) 302 | 303 | (vector-map (lambda (val) 304 | ;; top can have #f values 305 | (and val (dispatch val))) 306 | vector)) 307 | 308 | (define (fold combine initial vector) 309 | (define (handle-subtrie trie accum) 310 | (vector-fold dispatch accum (subtrie-vector vector))) 311 | 312 | (define (handle-leaf leaf accum) 313 | (combine (leaf-key leaf) (leaf-value leaf) accum)) 314 | 315 | (define (handle-collision collision accum) 316 | (fold-right (lambda (pair acc) 317 | (combine (car pair) (cdr pair) acc)) 318 | accum 319 | (collision-alist collision))) 320 | 321 | (define (dispatch val accum) 322 | (cond ((leaf? val) 323 | (handle-leaf val accum)) 324 | ((collision? val) 325 | (handle-collision val accum)) 326 | (else 327 | (handle-subtrie val accum)))) 328 | 329 | (vector-fold (lambda (val accum) 330 | ;; top level can have false values 331 | (if (not val) accum (dispatch val accum))) 332 | initial 333 | vector)) 334 | 335 | (define (size node) 336 | (cond ((not node) 0) 337 | ((leaf? node) 1) 338 | ((collision? node) (collision-size node)) 339 | (else (subtrie-size node)))) 340 | 341 | ;;; Exported Interface 342 | 343 | (define-record-type (hamt %make-hamt hamt?) 344 | (fields size root hash-function equivalence-predicate)) 345 | 346 | (define (wrap-root root hamt) 347 | (define vecsize 348 | (vector-fold (lambda (val accum) 349 | (+ (size val) accum)) 350 | 0 351 | root)) 352 | (%make-hamt vecsize 353 | root 354 | (hamt-hash-function hamt) 355 | (hamt-equivalence-predicate hamt))) 356 | 357 | (define (make-hamt hash eqv?) 358 | (%make-hamt 0 (make-vector cardinality #f) hash eqv?)) 359 | 360 | (define hamt-ref 361 | (case-lambda 362 | ((hamt key) 363 | (define token (cons #f #f)) 364 | (define return-val (hamt-ref hamt key token)) 365 | (when (eqv? token return-val) 366 | (assertion-violation 'hamt-ref "Key is not in the hamt" key)) 367 | return-val) 368 | ((hamt key default) 369 | ;; assert hamt? 370 | (lookup (hamt-root hamt) 371 | key 372 | default 373 | (hamt-hash-function hamt) 374 | (hamt-equivalence-predicate hamt))))) 375 | 376 | (define (hamt-set hamt key value) 377 | (define root 378 | (insert (hamt-root hamt) 379 | key 380 | (lambda (old) value) 381 | 'dummy 382 | (hamt-hash-function hamt) 383 | (hamt-equivalence-predicate hamt))) 384 | (wrap-root root hamt)) 385 | 386 | (define (hamt-update hamt key proc default) 387 | (define root 388 | (insert (hamt-root hamt) 389 | key 390 | proc 391 | default 392 | (hamt-hash-function hamt) 393 | (hamt-equivalence-predicate hamt))) 394 | (wrap-root root hamt)) 395 | 396 | (define (hamt-delete hamt key) 397 | (define root 398 | (delete (hamt-root hamt) 399 | key 400 | (hamt-hash-function hamt) 401 | (hamt-equivalence-predicate hamt))) 402 | (wrap-root root hamt)) 403 | 404 | (define (hamt-contains? hamt key) 405 | (define token (cons #f #f)) 406 | (if (eqv? token (hamt-ref hamt key token)) 407 | #f 408 | #t)) 409 | 410 | (define (hamt-map mapper hamt) 411 | (%make-hamt (hamt-size hamt) 412 | (vec-map mapper (hamt-root hamt)) 413 | (hamt-hash-function hamt) 414 | (hamt-equivalence-predicate hamt))) 415 | 416 | (define (hamt-fold combine initial hamt) 417 | (fold combine initial (hamt-root hamt))) 418 | 419 | (define (hamt->alist hamt) 420 | (hamt-fold (lambda (key value accumulator) 421 | (cons (cons key value) accumulator)) 422 | '() 423 | hamt)) 424 | 425 | (define (alist->hamt alist hash eqv?) 426 | (fold-right (lambda (kv-pair hamt) 427 | (hamt-set hamt (car kv-pair) (cdr kv-pair))) 428 | (make-hamt hash eqv?) 429 | alist)) 430 | 431 | ) 432 | -------------------------------------------------------------------------------- /heaps.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (C) 2012 Ian Price 3 | 4 | ;; Author: Ian Price 5 | 6 | ;; This program is free software, you can redistribute it and/or 7 | ;; modify it under the terms of the new-style BSD license. 8 | 9 | ;; You should have received a copy of the BSD license along with this 10 | ;; program. If not, see . 11 | 12 | ;; Documentation: 13 | ;; 14 | ;; make-heap : (any any -> bool) -> heap 15 | ;; returns a new empty heap which uses the ordering procedure. 16 | ;; 17 | ;; heap : (any any -> bool) any ... -> heap 18 | ;; return a new heap, ordered by the procedure argument, that contains 19 | ;; all the other arguments as elements. 20 | ;; 21 | ;; heap? : any -> bool 22 | ;; returns #t if the argument is a heap, #f otherwise. 23 | ;; 24 | ;; heap-size : heap -> non-negative integer 25 | ;; returns the number of elements in the heap. 26 | ;; 27 | ;; heap-empty? : heap -> bool 28 | ;; returns #t if the heap contains no elements, #f otherwise. 29 | ;; 30 | ;; heap-min : heap -> any 31 | ;; returns the minimum element in the heap, according the heap's 32 | ;; ordering procedure. If there are no elements, a 33 | ;; &heap-empty-condition is raised. 34 | ;; 35 | ;; heap-delete-min : heap -> heap 36 | ;; returns a new heap containing all the elements of the heap 37 | ;; argument, except for the minimum argument, as determined by the 38 | ;; heap's ordering procedure. If there are no elements, a 39 | ;; &heap-empty-condition is raised. 40 | ;; 41 | ;; heap-pop : any + heap 42 | ;; returns two values: the the minimum value, and a heap obtained by 43 | ;; removing the minimum value from the original heap. If the heap is 44 | ;; empty, a &heap-empty-condition is raised. 45 | ;; 46 | ;; heap-insert : heap any -> heap 47 | ;; returns the new heap obtained by adding the element to those in the 48 | ;; argument heap. 49 | ;; 50 | ;; heap->list : heap -> Listof(any) 51 | ;; returns the heap containing all the elements of the heap. The 52 | ;; elements of the list are ordered according to the heap's ordering 53 | ;; procedure. 54 | ;; 55 | ;; list->heap : Listof(any) (any any -> boolean) -> heap 56 | ;; returns the heap containing all the elements of the list, and using 57 | ;; the procedure argument to order the elements. 58 | ;; 59 | ;; heap-merge : heap heap -> heap 60 | ;; returns the heap containing all the elements of the argument 61 | ;; heaps. The argument heaps are assumed to be using the same ordering 62 | ;; procedure. 63 | ;; 64 | ;; heap-sort : (any any -> bool) list -> list 65 | ;; returns a new list that is a permutation of the argument list, such 66 | ;; that all the elements are ordered by the given procedure. 67 | ;; 68 | ;; heap-ordering-procedure : heap -> (any any -> boolean) 69 | ;; returns the ordering procedure used internally by the heap. 70 | ;; 71 | ;; heap-empty-condition? : any -> bool 72 | ;; returns #t if argument is a &heap-empty condition, #f otherwise. 73 | ;; 74 | (library (pfds heaps) 75 | (export make-heap 76 | (rename (%heap heap)) 77 | heap? 78 | heap-size 79 | heap-empty? 80 | heap-min 81 | heap-delete-min 82 | heap-insert 83 | heap-pop 84 | heap->list 85 | list->heap 86 | heap-merge 87 | heap-sort 88 | (rename (heap-ordering-predicate heap-ordering-procedure)) 89 | heap-empty-condition? 90 | ) 91 | (import (rnrs)) 92 | 93 | (define-record-type (node %make-node node?) 94 | (fields size height value left right)) 95 | 96 | (define-record-type leaf) 97 | 98 | (define (height x) 99 | (if (leaf? x) 100 | 0 101 | (node-height x))) 102 | 103 | (define (size x) 104 | (if (leaf? x) 105 | 0 106 | (node-size x))) 107 | 108 | (define (make-node v l r) 109 | (define sl (height l)) 110 | (define sr (height r)) 111 | (define m (+ 1 (min sl sr))) 112 | (define sz (+ 1 (size l) (size r))) 113 | (if (< sl sr) 114 | (%make-node sz m v r l) 115 | (%make-node sz m v l r))) 116 | 117 | (define (singleton v) 118 | (%make-node 1 0 v (make-leaf) (make-leaf))) 119 | 120 | (define (insert tree value prioheap vals <)) 155 | 156 | (define (heap-size heap) 157 | (size (heap-tree heap))) 158 | 159 | (define (heap-empty? heap) 160 | (leaf? (heap-tree heap))) 161 | 162 | (define (heap-min heap) 163 | (when (heap-empty? heap) 164 | (raise (condition 165 | (make-heap-empty-condition) 166 | (make-who-condition 'heap-min) 167 | (make-message-condition "There is no minimum element.") 168 | (make-irritants-condition (list heap))))) 169 | (node-value (heap-tree heap))) 170 | 171 | (define (heap-delete-min heap) 172 | (when (heap-empty? heap) 173 | (raise (condition 174 | (make-heap-empty-condition) 175 | (make-who-condition 'heap-delete-min) 176 | (make-message-condition "There is no minimum element.") 177 | (make-irritants-condition (list heap))))) 178 | (let ((< (heap-ordering-predicate heap))) 179 | (%make-heap (delete-min (heap-tree heap) <) <))) 180 | 181 | (define (heap-pop heap) 182 | (when (heap-empty? heap) 183 | (raise (condition 184 | (make-heap-empty-condition) 185 | (make-who-condition 'heap-pop) 186 | (make-message-condition "There is no minimum element.") 187 | (make-irritants-condition (list heap))))) 188 | (let* ((tree (heap-tree heap)) 189 | (top (node-value tree)) 190 | (< (heap-ordering-predicate heap)) 191 | (rest (delete-min tree <))) 192 | (values top 193 | (%make-heap rest <)))) 194 | 195 | (define (heap-insert heap value) 196 | (assert (heap? heap)) 197 | (let ((< (heap-ordering-predicate heap))) 198 | (%make-heap (insert (heap-tree heap) value <) <))) 199 | 200 | (define (heap->list heap) 201 | (assert (heap? heap)) 202 | (let ((< (heap-ordering-predicate heap))) 203 | (let loop ((tree (heap-tree heap)) (list '())) 204 | (if (leaf? tree) 205 | (reverse list) 206 | (loop (delete-min tree <) 207 | (cons (node-value tree) list)))))) 208 | 209 | (define (list->heap list <) 210 | (%make-heap 211 | (fold-left (lambda (h item) 212 | (insert h item <)) 213 | (make-leaf) 214 | list) 215 | <)) 216 | 217 | (define (heap-merge heap1 heap2) 218 | (define < (heap-ordering-predicate heap1)) 219 | (%make-heap 220 | (merge-trees (heap-tree heap1) 221 | (heap-tree heap2) 222 | <) 223 | <)) 224 | 225 | (define (heap-sort < list) 226 | (heap->list (list->heap list <))) 227 | 228 | (define-condition-type &heap-empty 229 | &assertion 230 | make-heap-empty-condition 231 | heap-empty-condition?) 232 | ) 233 | -------------------------------------------------------------------------------- /pkg-list.scm: -------------------------------------------------------------------------------- 1 | (package (pfds (0 3)) 2 | (depends (wak-trc-testing)) 3 | (synopsis "Purely Functional Data Structures") 4 | (description 5 | "A library of data structures for functional programmers." 6 | "It contains implementations of:" 7 | "- queues" 8 | "- deques" 9 | "- bbtrees" 10 | "- sets" 11 | "- dlists" 12 | "- priority search queues" 13 | "- heaps" 14 | "- hamts" 15 | "- finger trees" 16 | "- sequences") 17 | (homepage "http://github.com/ijp/pfds") 18 | (documentation 19 | "README.org" 20 | "LICENSE") 21 | (libraries 22 | (sls -> "pfds") 23 | ("queues" -> ("pdfs" "queues")) 24 | ("deques" -> ("pdfs" "deques")) 25 | ("private" -> ("pfds" "private")))) 26 | -------------------------------------------------------------------------------- /private/alists.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; alists.sls --- Alist Utilities 3 | 4 | ;; Copyright (C) 2014 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | (library (pfds private alists) 14 | (export alist-ref 15 | alist-set 16 | alist-delete 17 | alist-update 18 | ) 19 | (import (rnrs base) 20 | (only (srfi :1 lists) assoc) 21 | ) 22 | 23 | (define (alist-ref alist key default eqv?) 24 | (cond ((assoc key alist eqv?) => cdr) 25 | (else default))) 26 | 27 | (define (alist-set alist key value eqv?) 28 | ;; TODO: measure to see if it is even worth it 29 | ;; adds key value to alist if key is not in alist 30 | ;; if key is in a list, replaces the association 31 | ;; does not preserve order. 32 | (let loop ((new '()) (old alist)) 33 | (cond ((null? old) 34 | (cons (cons key value) new)) 35 | ((eqv? (car (car old)) key) 36 | (cons (cons key value) 37 | (append (cdr old) new))) 38 | (else (loop (cons (car old) new) (cdr old)))))) 39 | 40 | ;;((al (alist-delete (collision-alist node) key eqv?))) 41 | (define (alist-delete alist key eqv?) 42 | ;; TODO: measure to see if it is even worth it 43 | (let loop ((new '()) (old alist)) 44 | (cond ((null? old) new) 45 | ((eqv? (car (car old)) key) 46 | (append (cdr old) new)) 47 | (else (loop (cons (car old) new) (cdr old)))))) 48 | 49 | (define (alist-update alist key update base eqv?) 50 | (let loop ((new '()) (old alist)) 51 | (cond ((null? old) 52 | (cons (cons key (update base)) new)) 53 | ((eqv? (car (car old)) key) 54 | (cons (cons key (update (cdr (car old)))) 55 | (append (cdr old) new))) 56 | (else (loop (cons (car old) new) (cdr old)))))) 57 | 58 | 59 | ) 60 | -------------------------------------------------------------------------------- /private/bitwise.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; bitwise.sls --- Bitwise Arithmetic Utilities 3 | 4 | ;; Copyright (C) 2014 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | (library (pfds private bitwise) 14 | (export bitwise-bit-set 15 | bitwise-bit-unset 16 | ) 17 | (import (rnrs base) 18 | (rnrs arithmetic bitwise)) 19 | 20 | (define (bitwise-bit-set bits i) 21 | (bitwise-ior bits (bitwise-arithmetic-shift-left 1 i))) 22 | 23 | (define (bitwise-bit-unset bits i) 24 | (bitwise-and bits (bitwise-not (bitwise-arithmetic-shift-left 1 i)))) 25 | 26 | ) 27 | -------------------------------------------------------------------------------- /private/lazy-lists.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; lazy-lists.sls --- odd lazy lists 3 | 4 | ;; Copyright (C) 2011 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; If you want real lazy lists, use SRFI 41, but Okazaki uses 'odd' 17 | ;; lists, so I wrote a quick implementation. 18 | 19 | ;;; Code: 20 | 21 | (library (pfds private lazy-lists) 22 | (export cons* 23 | tail 24 | head 25 | empty? 26 | take 27 | drop 28 | rev 29 | append* 30 | ) 31 | (import (except (rnrs) cons*) 32 | (rnrs r5rs) 33 | ) 34 | 35 | (define-syntax cons* 36 | (syntax-rules () 37 | ((cons* a b) 38 | (cons a (delay b))))) 39 | 40 | (define head car) 41 | 42 | (define empty? null?) 43 | 44 | (define (tail pair) 45 | (if (empty? pair) 46 | pair 47 | (force (cdr pair)))) 48 | 49 | (define (take n l) 50 | (if (zero? n) 51 | '() 52 | (cons* (head l) 53 | (take (- n 1) (tail l))))) 54 | 55 | (define (drop n l) 56 | (if (zero? n) 57 | l 58 | (drop (- n 1) (tail l)))) 59 | 60 | (define (append* x y) 61 | (if (empty? x) 62 | y 63 | (cons* (head x) 64 | (append* (tail x) y)))) 65 | 66 | (define (rev l) 67 | (let loop ((l l) (a '())) 68 | (if (empty? l) 69 | a 70 | (loop (tail l) (cons* (head l) a))))) 71 | 72 | ) 73 | -------------------------------------------------------------------------------- /private/vectors.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; vectors.sls --- Vector Utilities 3 | 4 | ;; Copyright (C) 2014 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | (library (pfds private vectors) 14 | (export vector-set 15 | vector-insert 16 | vector-remove 17 | vector-copy 18 | vector-copy! 19 | vector-fold 20 | ) 21 | (import (rnrs base) 22 | (rnrs control)) 23 | 24 | (define (vector-set h i x) 25 | (let ((v* (vector-copy h))) 26 | (vector-set! v* i x) 27 | v*)) 28 | 29 | (define (vector-remove v i) 30 | (define len (vector-length v)) 31 | (assert (and (<= 0 i) (< i len))) 32 | (let ((newvec (make-vector (- len 1)))) 33 | (vector-copy! v 0 newvec 0 i) 34 | (vector-copy! v (+ i 1) newvec i (- len i 1)) 35 | newvec)) 36 | 37 | (define (vector-insert v i x) 38 | (define len (vector-length v)) 39 | (assert (<= 0 i len)) 40 | (let* ((newvec (make-vector (+ len 1)))) 41 | (vector-set! newvec i x) 42 | (vector-copy! v 0 newvec 0 i) 43 | (vector-copy! v i newvec (+ 1 i) (- len i)) 44 | newvec)) 45 | 46 | (define (vector-copy! source source-start target target-start k) 47 | ;; TODO: assertions 48 | ;; guile has vector-move functions, but rnrs does not :( 49 | (do ((i 0 (+ 1 i))) 50 | ((>= i k)) 51 | (vector-set! target 52 | (+ target-start i) 53 | (vector-ref source (+ source-start i))))) 54 | 55 | (define (vector-copy vector) 56 | (define len (vector-length vector)) 57 | (define v* (make-vector len)) 58 | (vector-copy! vector 0 v* 0 len) 59 | v*) 60 | 61 | ;; vector-fold is left to right 62 | (define (vector-fold combine initial vector) 63 | (define len (vector-length vector)) 64 | (let loop ((index 0) (accum initial)) 65 | (if (>= index len) 66 | accum 67 | (loop (+ index 1) 68 | (combine (vector-ref vector index) accum))))) 69 | 70 | ) 71 | -------------------------------------------------------------------------------- /psqs.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; psqs.sls --- Priority Search Queues 3 | 4 | ;; Copyright (C) 2012 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;;; Documentation 15 | ;; 16 | ;; Priority search queues are a combination of two common abstract 17 | ;; data types: finite maps, and priority queues. As such, it provides 18 | ;; for access, insertion, removal and update on arbitrary keys, as 19 | ;; well as for easy removal of the element with the lowest priority. 20 | ;; 21 | ;; Note: where a procedure takes a key or priority these are expected 22 | ;; to be compatible with the relevant ordering procedures on the psq. 23 | ;; 24 | ;;;; Basic operations 25 | ;; 26 | ;; make-psq : < < -> psq 27 | ;; takes a two ordering procedures, one for keys, and another for 28 | ;; priorities, and returns an empty priority search queue 29 | ;; 30 | ;; psq? : obj -> boolean 31 | ;; returns #t if the object is a priority search queue, #f otherwise. 32 | ;; 33 | ;; psq-empty? : psq -> boolean 34 | ;; returns #t if the priority search queue contains no elements, #f 35 | ;; otherwise. 36 | ;; 37 | ;; psq-size : psq -> non-negative integer 38 | ;; returns the number of associations in the priority search queue 39 | ;; 40 | ;;;; Finite map operations 41 | ;; 42 | ;; psq-ref : psq key -> priority 43 | ;; returns the priority of a key if it is in the priority search 44 | ;; queue. If the key is not in the priority queue an 45 | ;; assertion-violation is raised. 46 | ;; 47 | ;; psq-set : psq key priority -> psq 48 | ;; returns the priority search queue obtained from inserting a key 49 | ;; with a given priority. If the key is already in the priority search 50 | ;; queue, it updates the priority to the new value. 51 | ;; 52 | ;; psq-update : psq key (priority -> priority) priority -> psq 53 | ;; returns the priority search queue obtained by modifying the 54 | ;; priority of key, by the given function. If the key is not in the 55 | ;; priority search queue, it is inserted with the priority obtained by 56 | ;; calling the function on the default value. 57 | ;; 58 | ;; psq-delete : psq key -> psq 59 | ;; returns the priority search queue obtained by removing the 60 | ;; key-priority association from the priority search queue. If the key 61 | ;; is not in the queue, then the returned search queue will be the 62 | ;; same as the original. 63 | ;; 64 | ;; psq-contains? : psq key -> boolean 65 | ;; returns #t if there is an association for the given key in the 66 | ;; priority search queue, #f otherwise. 67 | ;; 68 | ;;;; Priority queue operations 69 | ;; 70 | ;; psq-min : psq -> key 71 | ;; 72 | ;; returns the key of the minimum association in the priority search 73 | ;; queue. If the queue is empty, an assertion violation is raised. 74 | ;; 75 | ;; psq-delete-min : psq -> psq 76 | ;; returns the priority search queue obtained by removing the minimum 77 | ;; association in the priority search queue. If the queue is empty, an 78 | ;; assertion violation is raised. 79 | ;; 80 | ;; psq-pop : psq -> key + psq 81 | ;; returns two values: the minimum key and the priority search queue 82 | ;; obtained by removing the minimum association from the original 83 | ;; queue. If the queue is empty, an assertion violation is raised. 84 | ;; 85 | ;;;; Ranged query functions 86 | ;; 87 | ;; psq-at-most : psq priority -> ListOf(key . priority) 88 | ;; returns an alist containing all the associations in the priority 89 | ;; search queue with priority less than or equal to a given value. The 90 | ;; alist returned is ordered by key according to the predicate for the 91 | ;; psq. 92 | ;; 93 | ;; psq-at-most-range : psq priority key key -> ListOf(key . priority) 94 | ;; Similar to psq-at-most, but it also takes an upper and lower bound, 95 | ;; for the keys it will return. These bounds are inclusive. 96 | ;; 97 | (library (pfds psqs) 98 | (export make-psq 99 | psq? 100 | psq-empty? 101 | psq-size 102 | ;; map operations 103 | psq-ref 104 | psq-set 105 | psq-update 106 | psq-delete 107 | psq-contains? 108 | ;; priority queue operations 109 | psq-min 110 | psq-delete-min 111 | psq-pop 112 | ;; ranged query operations 113 | psq-at-most 114 | psq-at-most-range 115 | ) 116 | (import (except (rnrs) min)) 117 | 118 | ;;; record types 119 | 120 | (define-record-type void) 121 | 122 | (define-record-type winner 123 | (fields key priority loser-tree maximum-key)) 124 | 125 | (define-record-type start) 126 | 127 | (define-record-type (loser %make-loser loser?) 128 | (fields size key priority left split-key right)) 129 | 130 | (define (make-loser key priority left split-key right) 131 | (%make-loser (+ (size left) (size right) 1) 132 | key 133 | priority 134 | left 135 | split-key 136 | right)) 137 | 138 | ;;; functions 139 | (define (maximum-key psq) 140 | (winner-maximum-key psq)) 141 | 142 | (define max-key maximum-key) 143 | 144 | (define empty (make-void)) 145 | 146 | (define (singleton key priority) 147 | (make-winner key priority (make-start) key)) 148 | 149 | (define (play-match psq1 psq2 key r-size (* weight l-size)) 365 | (balance-left key priority left split-key right key l-size (* weight r-size)) 367 | (balance-right key priority left split-key right key 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | ;; 16 | ;; A scheme translation of "Simple and Efficient Purely Functional 17 | ;; Queues and Deques" by Chris Okazaki 18 | ;; 19 | ;; 20 | ;;; Documentation: 21 | ;; 22 | ;; make-queue : () -> queue 23 | ;; returns a queue containing no items 24 | ;; 25 | ;; queue? : any -> boolean 26 | ;; tests if an object is a queue 27 | ;; 28 | ;; queue-length : queue -> non-negative integer 29 | ;; returns the number of items in the queue 30 | ;; 31 | ;; queue-empty? : queue -> boolean 32 | ;; returns true if there are no items in the queue, false otherwise 33 | ;; 34 | ;; enqueue : queue any -> queue 35 | ;; returns a new queue with the enqueued item at the end 36 | ;; 37 | ;; dequeue : queue -> value queue 38 | ;; returns two values, the item at the front of the queue, and a new 39 | ;; queue containing the all the other items 40 | ;; raises a &queue-empty condition if the queue is empty 41 | ;; 42 | ;; queue-empty-condition? : object -> boolean 43 | ;; tests if an object is a &queue-empty condition 44 | ;; 45 | ;; queue->list : queue -> listof(any) 46 | ;; returns a queue containing all the items in the list. The order of 47 | ;; the elements in the queue is the same as the order of the elements 48 | ;; in the list. 49 | ;; 50 | ;; list->queue : listof(any) -> queue 51 | ;; returns a list containing all the items in the queue. The order of 52 | ;; the items in the list is the same as the order in the queue. 53 | ;; For any list l, (equal? (queue->list (list->queue l)) l) is #t. 54 | ;; 55 | (library (pfds queues) 56 | (export make-queue 57 | queue? 58 | queue-length 59 | queue-empty? 60 | enqueue 61 | dequeue 62 | queue-empty-condition? 63 | list->queue 64 | queue->list 65 | ) 66 | (import (except (rnrs) cons*) 67 | (pfds private lazy-lists) 68 | (pfds queues private condition) 69 | (rnrs r5rs)) 70 | 71 | (define (rotate l r a) 72 | (if (empty? l) 73 | (cons* (head r) a) 74 | (cons* (head l) 75 | (rotate (tail l) 76 | (tail r) 77 | (cons* (head r) a))))) 78 | 79 | 80 | ;;; Implementation 81 | 82 | (define-record-type (queue %make-queue queue?) 83 | (fields 84 | (immutable length) 85 | (immutable l) 86 | (immutable r) 87 | (immutable l^))) 88 | 89 | 90 | (define (make-queue) 91 | (%make-queue 0 '() '() '())) 92 | 93 | (define (enqueue queue item) 94 | (let ((len (queue-length queue)) 95 | (l (queue-l queue)) 96 | (r (queue-r queue)) 97 | (l^ (queue-l^ queue))) 98 | (makeq (+ len 1) l (cons* item r) l^))) 99 | 100 | (define (dequeue queue) 101 | (when (queue-empty? queue) 102 | ;; (error 'dequeue "Can't dequeue empty queue") 103 | (raise (condition 104 | (make-queue-empty-condition) 105 | (make-who-condition 'dequeue) 106 | (make-message-condition "There are no elements to dequeue") 107 | (make-irritants-condition (list queue))))) 108 | (let ((len (queue-length queue)) 109 | (l (queue-l queue)) 110 | (r (queue-r queue)) 111 | (l^ (queue-l^ queue))) 112 | (values (head l) 113 | (makeq (- len 1) (tail l) r l^)))) 114 | 115 | (define (makeq length l r l^) 116 | (if (empty? l^) 117 | (let ((l* (rotate l r '()))) 118 | (%make-queue length l* '() l*)) 119 | (%make-queue length l r (tail l^)))) 120 | 121 | (define (queue-empty? queue) 122 | (zero? (queue-length queue))) 123 | 124 | (define (list->queue list) 125 | (fold-left enqueue (make-queue) list)) 126 | 127 | (define (queue->list queue) 128 | (let loop ((rev-list '()) (queue queue)) 129 | (if (queue-empty? queue) 130 | (reverse rev-list) 131 | (let-values (((val queue) (dequeue queue))) 132 | (loop (cons val rev-list) 133 | queue))))) 134 | 135 | ) 136 | -------------------------------------------------------------------------------- /queues/naive.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; queues.sls --- Purely functional queues 3 | 4 | ;; Copyright (C) 2013 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; This code shares the same interface as (pfds queues). Please see 17 | ;; that module for documentation of the interface. The difference is 18 | ;; in performance characteristics. 19 | 20 | ;; The version in (pfds queues) uses memoisation to ensure that a 21 | ;; dequeue operation always takes less than a constant bound, 22 | ;; regardless of access pattern. This module *may* be more expensive 23 | ;; in certain access patterns, due to use of reverse, *but* in the 24 | ;; common stateful pattern of only ever using the most recent version 25 | ;; of the queue, it can be cheaper. 26 | ;; 27 | ;; If in doubt, benchmark. 28 | 29 | ;;; Code: 30 | (library (pfds queues naive) 31 | (export make-queue 32 | queue? 33 | queue-length 34 | queue-empty? 35 | enqueue 36 | dequeue 37 | queue-empty-condition? 38 | list->queue 39 | queue->list 40 | ) 41 | (import (rnrs) 42 | (pfds queues private condition)) 43 | 44 | (define-record-type (queue %make-queue queue?) 45 | (fields length head tail)) 46 | 47 | (define (make-queue) 48 | (%make-queue 0 '() '())) 49 | 50 | (define (queue-empty? queue) 51 | (zero? (queue-length queue))) 52 | 53 | (define (enqueue queue object) 54 | (%make-queue (+ 1 (queue-length queue)) 55 | (queue-head queue) 56 | (cons object (queue-tail queue)))) 57 | 58 | (define (dequeue queue) 59 | (when (queue-empty? queue) 60 | (raise (condition 61 | (make-queue-empty-condition) 62 | (make-who-condition 'dequeue) 63 | (make-message-condition "There are no elements to dequeue") 64 | (make-irritants-condition (list queue))))) 65 | (let ((l (queue-length queue)) 66 | (h (queue-head queue)) 67 | (t (queue-tail queue))) 68 | (if (null? h) 69 | (let ((h* (reverse t))) 70 | (values (car h*) 71 | (%make-queue (- l 1) (cdr h*) '()))) 72 | (values (car h) 73 | (%make-queue (- l 1) (cdr h) t))))) 74 | 75 | (define (list->queue l) 76 | (%make-queue (length l) l '())) 77 | 78 | (define (queue->list queue) 79 | (let ((h (queue-head queue)) 80 | (t (queue-tail queue))) 81 | (append h (reverse t)))) 82 | 83 | ) 84 | -------------------------------------------------------------------------------- /queues/private/condition.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; condition.sls --- Queue Conditions 3 | 4 | ;; Copyright (C) 2013 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | (library (pfds queues private condition) 14 | (export &queue-empty 15 | make-queue-empty-condition 16 | queue-empty-condition?) 17 | (import (rnrs conditions)) 18 | 19 | (define-condition-type &queue-empty 20 | &assertion 21 | make-queue-empty-condition 22 | queue-empty-condition?) 23 | 24 | ) 25 | -------------------------------------------------------------------------------- /runtests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | function run_guile { 4 | guile -L .. -x .sls -x .guile.sls -x .ss tests.scm 5 | } 6 | 7 | function run_racket { 8 | racket tests.scm 9 | } 10 | 11 | case "$1" in 12 | guile) run_guile ;; 13 | racket) run_racket ;; 14 | all) run_guile; run_racket ;; 15 | *) run_guile ;; 16 | esac 17 | -------------------------------------------------------------------------------- /sequences.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; sequences.sls --- Purely Functional Sequences 3 | 4 | ;; Copyright (C) 2012 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; Sequences are a general-purpose, variable-length collection, 17 | ;; similar to lists, however they support efficient addition and 18 | ;; removal from both ends, and random-access. Like other Scheme 19 | ;; collections, sequences are zero-indexed. 20 | ;; 21 | ;; make-sequence : () -> sequence 22 | ;; returns a new empty sequence 23 | ;; 24 | ;; sequence any ... -> sequence 25 | ;; returns a new sequence containing all of the argument elements, in the 26 | ;; same order. 27 | ;; 28 | ;; sequence? : any -> bool 29 | ;; returns #t if the argument is a sequence, #f otherwise. 30 | ;; 31 | ;; sequence-empty? : sequence -> bool 32 | ;; returns #t if the argument sequence contains no elements, #f otherwise. 33 | ;; 34 | ;; sequence-size : sequence -> non-negative integer 35 | ;; returns the number of elements in the sequence 36 | ;; 37 | ;; sequence-cons : any sequence -> sequence 38 | ;; return the new sequence created by adding the element to the front of 39 | ;; the sequence. 40 | ;; 41 | ;; sequence-uncons : sequence -> any sequence 42 | ;; returns two values: the first element of the sequence, and a new 43 | ;; sequence containing all but the first element. If the sequence is 44 | ;; empty, a &sequence-empty condition is raised. 45 | ;; 46 | ;; sequence-snoc : sequence any -> sequence 47 | ;; return the new sequence created by adding the element to the end of 48 | ;; the sequence. 49 | ;; 50 | ;; sequence-unsnoc : sequence -> sequence any 51 | ;; returns two values: a new sequence containing all but the last 52 | ;; element of the sequence, and the last element itself. If the 53 | ;; sequence is empty, a &sequence-empty condition is raised. 54 | ;; 55 | ;; sequence-append : sequence sequence -> sequence 56 | ;; returns a new sequence containing all the elements of the first 57 | ;; sequence, followed by all the elements of the second sequence. 58 | ;; 59 | ;; list->sequence : Listof(Any) -> sequence 60 | ;; returns a new sequence containing all the elements of the argument 61 | ;; list, in the same order. 62 | ;; 63 | ;; sequence->list : sequence -> Listof(Any) 64 | ;; returns a new list containing all the elements of the sequence, in the 65 | ;; same order. 66 | ;; 67 | ;; sequence-split-at sequence integer -> sequence + sequence 68 | ;; returns two new sequences, the first containing the first N elements 69 | ;; of the sequence, the second containing the remaining elements. If N is 70 | ;; negative, it returns the empty sequence as the first argument, and the 71 | ;; original sequence as the second argument. Similarly, if N is greater 72 | ;; than the length of the list, it returns the original sequence as the 73 | ;; first argument, and the empty sequence as the second argument. 74 | ;; 75 | ;; Consequently, (let-values (((a b) (sequence-split-at s i))) 76 | ;; (sequence-append a b)) is equivalent to s for all sequences s, and 77 | ;; integers i. 78 | ;; 79 | ;; sequence-take sequence integer -> sequence 80 | ;; returns a new sequence containing the first N elements of the 81 | ;; argument sequence. If N is negative, the empty sequence is 82 | ;; returned. If N is larger than the length of the sequence, the whole 83 | ;; sequence is returned. 84 | ;; 85 | ;; sequence-drop sequence integer -> sequence 86 | ;; returns a new sequence containing all but the first N elements of the 87 | ;; argument sequence. If N is negative, the whole sequence is 88 | ;; returned. If N is larger than the length of the sequence, the empty 89 | ;; sequence is returned. 90 | ;; 91 | ;; sequence-ref : sequence non-negative-integer -> any 92 | ;; returns the element at the specified index in the sequence. If the 93 | ;; index is outside the range 0 <= i < (sequence-size sequence), an 94 | ;; assertion violation is raised. 95 | ;; 96 | ;; sequence-set : sequence non-negative-integer any -> sequence 97 | ;; returns the new sequence obtained by replacing the element at the 98 | ;; specified index in the sequence with the given value. If the index 99 | ;; is outside the range 0 <= i < (sequence-size sequence), an 100 | ;; assertion violation is raised. 101 | ;; 102 | ;; sequence-fold (any -> any -> any) any sequence 103 | ;; returns the value obtained by iterating the combiner procedure over 104 | ;; the sequence in left-to-right order. The combiner procedure takes two 105 | ;; arguments, the value of the position in the sequence, and an 106 | ;; accumulator, and its return value is used as the value of the 107 | ;; accumulator for the next call. The initial accumulator value is given 108 | ;; by the base argument. 109 | ;; 110 | ;; sequence-fold-right (any -> any -> any) any sequence 111 | ;; Like sequence-fold, but the sequence is traversed in right-to-left 112 | ;; order, rather than left-to-right. 113 | ;; 114 | ;; sequence-reverse : sequence -> sequence 115 | ;; returns a new sequence containing all the arguments of the argument 116 | ;; list, in reverse order. 117 | ;; 118 | ;; sequence-map : (any -> any) sequence -> sequence 119 | ;; returns a new sequence obtained by applying the procedure to each 120 | ;; element of the argument sequence in turn. 121 | ;; 122 | ;; sequence-filter : (any -> bool) sequence -> sequence 123 | ;; returns a new sequence containing all the elements of the argument 124 | ;; sequence for which the predicate is true. 125 | ;; 126 | ;; sequence-empty-condition? : any -> bool 127 | ;; returns #t if an object is a &sequence-empty condition, #f otherwise. 128 | ;; 129 | (library (pfds sequences) 130 | (export make-sequence 131 | sequence? 132 | sequence-empty? 133 | sequence-size 134 | sequence-cons 135 | sequence-uncons 136 | sequence-snoc 137 | sequence-unsnoc 138 | sequence-append 139 | list->sequence 140 | sequence->list 141 | (rename (%sequence sequence)) 142 | sequence-split-at 143 | sequence-take 144 | sequence-drop 145 | sequence-ref 146 | sequence-set 147 | sequence-fold 148 | sequence-fold-right 149 | sequence-reverse 150 | sequence-map 151 | sequence-filter 152 | sequence-empty-condition? 153 | ) 154 | 155 | (import (rnrs) 156 | (pfds fingertrees)) 157 | 158 | ;; Note: as sequences are not a subtype of fingertrees, but rather a 159 | ;; particular instantiation of them, &sequence-empty is not a subtype 160 | ;; of &fingertree-empty 161 | (define-condition-type &sequence-empty 162 | &assertion 163 | make-sequence-empty-condition 164 | sequence-empty-condition?) 165 | 166 | (define-record-type (sequence %make-sequence sequence?) 167 | (fields fingertree)) 168 | 169 | (define (make-sequence) 170 | (%make-sequence (make-fingertree 0 + (lambda (x) 1)))) 171 | 172 | (define (sequence-empty? seq) 173 | (fingertree-empty? (sequence-fingertree seq))) 174 | 175 | (define (sequence-size seq) 176 | (fingertree-measure (sequence-fingertree seq))) 177 | 178 | (define (sequence-cons value seq) 179 | (%make-sequence 180 | (fingertree-cons value (sequence-fingertree seq)))) 181 | 182 | (define (sequence-snoc seq value) 183 | (%make-sequence 184 | (fingertree-snoc (sequence-fingertree seq) value))) 185 | 186 | (define (sequence-uncons seq) 187 | (call-with-values 188 | (lambda () 189 | (define ft (sequence-fingertree seq)) 190 | (when (fingertree-empty? ft) 191 | (raise 192 | (condition 193 | (make-sequence-empty-condition) 194 | (make-who-condition 'sequence-uncons) 195 | (make-message-condition "There are no elements to uncons") 196 | (make-irritants-condition (list seq))))) 197 | (fingertree-uncons ft)) 198 | (lambda (head tree) 199 | (values head (%make-sequence tree))))) 200 | 201 | (define (sequence-unsnoc seq) 202 | (call-with-values 203 | (lambda () 204 | (define ft (sequence-fingertree seq)) 205 | (when (fingertree-empty? ft) 206 | (raise 207 | (condition 208 | (make-sequence-empty-condition) 209 | (make-who-condition 'sequence-unsnoc) 210 | (make-message-condition "There are no elements to unsnoc") 211 | (make-irritants-condition (list seq))))) 212 | (fingertree-unsnoc ft)) 213 | (lambda (tree last) 214 | (values (%make-sequence tree) last)))) 215 | 216 | (define (sequence-append seq1 seq2) 217 | (%make-sequence 218 | (fingertree-append (sequence-fingertree seq1) 219 | (sequence-fingertree seq2)))) 220 | 221 | (define (list->sequence list) 222 | (fold-left sequence-snoc 223 | (make-sequence) 224 | list)) 225 | 226 | (define (sequence->list seq) 227 | (fingertree->list (sequence-fingertree seq))) 228 | 229 | (define (%sequence . args) 230 | (list->sequence args)) 231 | 232 | (define (sequence-split-at seq i) 233 | (let-values (((l r) 234 | (fingertree-split (lambda (x) (< i x)) 235 | (sequence-fingertree seq)))) 236 | (values (%make-sequence l) 237 | (%make-sequence r)))) 238 | 239 | (define (sequence-take seq i) 240 | (let-values (((head tail) 241 | (sequence-split-at seq i))) 242 | head)) 243 | 244 | (define (sequence-drop seq i) 245 | (let-values (((head tail) 246 | (sequence-split-at seq i))) 247 | tail)) 248 | 249 | (define (sequence-ref seq i) 250 | (define size (sequence-size seq)) 251 | (unless (and (<= 0 i) (< i size)) 252 | (assertion-violation 'sequence-ref "Index out of range" i)) 253 | (let-values (((_l x _r) 254 | (fingertree-split3 (lambda (x) (< i x)) 255 | (sequence-fingertree seq)))) 256 | x)) 257 | 258 | (define (sequence-set seq i val) 259 | (define size (sequence-size seq)) 260 | (unless (and (<= 0 i) (< i size)) 261 | (assertion-violation 'sequence-set "Index out of range" i)) 262 | (let-values (((l x r) 263 | (fingertree-split3 (lambda (x) (< i x)) 264 | (sequence-fingertree seq)))) 265 | (%make-sequence 266 | (fingertree-append l (fingertree-cons val r))))) 267 | 268 | (define (sequence-fold proc base seq) 269 | (fingertree-fold proc base (sequence-fingertree seq))) 270 | 271 | (define (sequence-fold-right proc base seq) 272 | (fingertree-fold-right proc base (sequence-fingertree seq))) 273 | 274 | (define (sequence-reverse seq) 275 | (%make-sequence (fingertree-reverse (sequence-fingertree seq)))) 276 | 277 | (define (sequence-map proc seq) 278 | (define (combine element seq) 279 | (sequence-cons (proc element) seq)) 280 | (sequence-fold-right combine (make-sequence) seq)) 281 | 282 | (define (sequence-filter pred? seq) 283 | (define (combine element seq) 284 | (if (pred? element) 285 | (sequence-cons element seq) 286 | seq)) 287 | (sequence-fold-right combine (make-sequence) seq)) 288 | 289 | ) 290 | -------------------------------------------------------------------------------- /sets.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; sets.sls --- Purely Functional Sets 3 | 4 | ;; Copyright (C) 2012 Ian Price 5 | 6 | ;; Author: Ian Price 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;; Documentation: 15 | ;; 16 | ;; set? : any -> boolean 17 | ;; returns #t if the object is a set, #f otherwise 18 | ;; 19 | ;; make-set : (any any -> boolean) -> set 20 | ;; returns a new empty set ordered by the < procedure 21 | ;; 22 | ;; set-member? : set any -> boolean 23 | ;; returns true if element is in the set 24 | ;; 25 | ;; set-insert : set any -> set 26 | ;; returns a new set created by inserting element into the set argument 27 | ;; 28 | ;; set-remove : set element -> set 29 | ;; returns a new set created by removing element from the set 30 | ;; 31 | ;; set-size : set -> non-negative integer 32 | ;; returns the number of elements in the set 33 | ;; 34 | ;; set boolean 35 | ;; returns #t if set1 is a proper subset of set2, #f otherwise. That 36 | ;; is, if all elements of set1 are in set2, and there is at least one 37 | ;; element of set2 not in set1. 38 | ;; 39 | ;; set<=? : set set -> boolean 40 | ;; returns #t if set1 is a subset of set2, #f otherwise, i.e. if all 41 | ;; elements of set1 are in set2. 42 | ;; 43 | ;; set=? : set set -> boolean 44 | ;; returns #t if every element of set1 is in set2, and vice versa, #f 45 | ;; otherwise. 46 | ;; 47 | ;; set>=? : set set -> boolean 48 | ;; returns #t if set2 is a subset of set1, #f otherwise. 49 | ;; 50 | ;; set>? : set set -> boolean 51 | ;; returns #t if set2 is a proper subset of set1, #f otherwise. 52 | ;; 53 | ;; subset? : set set -> boolean 54 | ;; same as set<=? 55 | ;; 56 | ;; proper-subset? : set set -> boolean 57 | ;; same as set any) set -> set 60 | ;; returns the new set created by applying proc to each element of the set 61 | ;; 62 | ;; set-fold : (any any -> any) any set -> any 63 | ;; returns the value obtained by iterating the procedure over each 64 | ;; element of the set and an accumulator value. The value of the 65 | ;; accumulator is initially base, and the return value of proc is used 66 | ;; as the accumulator for the next iteration. 67 | ;; 68 | ;; list->set : Listof(any) (any any -> any) -> set 69 | ;; returns the set containing all the elements of the list, ordered by <. 70 | ;; 71 | ;; set->list : set -> Listof(any) 72 | ;; returns all the elements of the set as a list 73 | ;; 74 | ;; set-union : set set -> set 75 | ;; returns the union of set1 and set2, i.e. contains all elements of 76 | ;; set1 and set2. 77 | ;; 78 | ;; set-intersection : set set -> set 79 | ;; returns the intersection of set1 and set2, i.e. the set of all 80 | ;; items that are in both set1 and set2. 81 | ;; 82 | ;; set-difference : set set -> set 83 | ;; returns the difference of set1 and set2, i.e. the set of all items 84 | ;; in set1 that are not in set2. 85 | ;; 86 | ;; set-ordering-procedure : set -> (any any -> boolean) 87 | ;; returns the ordering procedure used internall by the set. 88 | (library (pfds sets) 89 | (export set? 90 | make-set 91 | set-member? 92 | set-insert 93 | set-remove 94 | set-size 95 | set=? 99 | set>? 100 | subset? 101 | proper-subset? 102 | set-map 103 | set-fold 104 | list->set 105 | set->list 106 | set-union 107 | set-intersection 108 | set-difference 109 | set-ordering-procedure 110 | ) 111 | (import (rnrs) 112 | (pfds bbtrees)) 113 | 114 | (define dummy #f) 115 | 116 | ;;; basic sets 117 | (define-record-type (set %make-set set?) 118 | (fields tree)) 119 | 120 | (define (set-ordering-procedure set) 121 | (bbtree-ordering-procedure (set-tree set))) 122 | 123 | (define (make-set <) 124 | (%make-set (make-bbtree <))) 125 | 126 | ;; provide a (make-equal-set) function? 127 | 128 | (define (set-member? set element) 129 | (bbtree-contains? (set-tree set) element)) 130 | 131 | (define (set-insert set element) 132 | (%make-set (bbtree-set (set-tree set) element dummy))) 133 | 134 | (define (set-remove set element) 135 | (%make-set (bbtree-delete (set-tree set) element))) 136 | 137 | (define (set-size set) 138 | (bbtree-size (set-tree set))) 139 | 140 | ;;; set equality 141 | (define (set<=? set1 set2) 142 | (let ((t (set-tree set2))) 143 | (bbtree-traverse (lambda (k _ l r b) 144 | (and (bbtree-contains? t k) 145 | (l #t) 146 | (r #t))) 147 | #t 148 | (set-tree set1)))) 149 | 150 | (define (set=? set1 set2) 156 | (set<=? set2 set1)) 157 | 158 | (define (set>? set1 set2) 159 | (set=? set1 set2))) 164 | 165 | (define subset? set<=?) 166 | 167 | (define proper-subset? setset list <) 189 | (fold-left (lambda (tree element) 190 | (set-insert tree element)) 191 | (make-set <) 192 | list)) 193 | 194 | (define (set->list set) 195 | (set-fold cons '() set)) 196 | 197 | ;;; set operations 198 | (define (set-union set1 set2) 199 | (%make-set (bbtree-union (set-tree set1) (set-tree set2)))) 200 | 201 | (define (set-intersection set1 set2) 202 | (%make-set (bbtree-intersection (set-tree set1) (set-tree set2)))) 203 | 204 | (define (set-difference set1 set2) 205 | (%make-set (bbtree-difference (set-tree set1) (set-tree set2)))) 206 | 207 | ) 208 | -------------------------------------------------------------------------------- /tests.scm: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (C) 2011-2014 Ian Price 3 | 4 | ;; Author: Ian Price 5 | 6 | ;; This program is free software, you can redistribute it and/or 7 | ;; modify it under the terms of the new-style BSD license. 8 | 9 | ;; You should have received a copy of the BSD license along with this 10 | ;; program. If not, see . 11 | 12 | ;;; Code: 13 | (import (rnrs) 14 | (pfds tests queues) 15 | (pfds tests deques) 16 | (pfds tests bbtrees) 17 | (pfds tests sets) 18 | (pfds tests psqs) 19 | (pfds tests heaps) 20 | (pfds tests fingertrees) 21 | (pfds tests sequences) 22 | (pfds tests hamts) 23 | (pfds tests utils) 24 | (wak trc-testing)) 25 | 26 | ;; Some schemes use lazy loading of modules, and so I can't just use 27 | ;; (run-test pfds) and rely on the side effects in the other modules 28 | ;; to add them to the pfds parent suite. 29 | (define-syntax add-tests! 30 | (syntax-rules () 31 | ((add-tests! suite ...) 32 | (begin (add-test! pfds 'suite suite) ...)))) 33 | 34 | (add-tests! queues deques bbtrees sets psqs 35 | heaps fingertrees sequences hamts) 36 | 37 | (run-test pfds) 38 | -------------------------------------------------------------------------------- /tests/bbtrees.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests bbtrees) 3 | (export bbtrees) 4 | (import (rnrs) 5 | (wak trc-testing) 6 | (pfds tests utils) 7 | (pfds bbtrees)) 8 | 9 | (define-test-suite bbtrees 10 | "Tests for the bounded balance tree imlementation") 11 | 12 | (define-test-case bbtrees empty-tree () 13 | (test-predicate bbtree? (make-bbtree <)) 14 | (test-eqv 0 (bbtree-size (make-bbtree <)))) 15 | 16 | (define-test-case bbtrees bbtree-set () 17 | (let* ([tree1 (bbtree-set (make-bbtree <) 1 'a)] 18 | [tree2 (bbtree-set tree1 2 'b)] 19 | [tree3 (bbtree-set tree2 1 'c )]) 20 | (test-eqv 1 (bbtree-size tree1)) 21 | (test-eqv 'a (bbtree-ref tree1 1)) 22 | (test-eqv 2 (bbtree-size tree2)) 23 | (test-eqv 'b (bbtree-ref tree2 2)) 24 | (test-eqv 2 (bbtree-size tree3)) 25 | (test-eqv 'c (bbtree-ref tree3 1)) 26 | (test-eqv #f (bbtree-ref tree1 #xdeadbeef #f)) 27 | (test-eqv 'not-in (bbtree-ref tree1 #xdeadbeef 'not-in)) 28 | (test-exn assertion-violation? (bbtree-ref tree3 20)))) 29 | 30 | 31 | (define-test-case bbtrees bbtree-update () 32 | (let ([bb (alist->bbtree '(("foo" . 10) ("bar" . 12)) stringbbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) string))) 62 | (test-eqv #t (bbtree-fold-right (lambda args #f) #t (make-bbtree >))) 63 | ;; associative operations 64 | (test-eqv 20 (bbtree-fold (lambda (key value accum) (+ value accum)) 0 bb)) 65 | (test-eqv 20 (bbtree-fold-right (lambda (key value accum) (+ value accum)) 0 bb)) 66 | ;; non-associative operations 67 | (test-equal '("foo" "baz" "bar") 68 | (bbtree-fold (lambda (key value accum) (cons key accum)) '() bb)) 69 | (test-equal '("bar" "baz" "foo") 70 | (bbtree-fold-right (lambda (key value accum) (cons key accum)) '() bb))))) 71 | 72 | (define-test-case bbtrees bbtree-map 73 | (let ((empty (make-bbtree <)) 74 | (bb (alist->bbtree '((#\a . foo) (#\b . bar) (#\c . baz) (#\d . quux)) 75 | charalist (bbtree-map (lambda (x) (cons x x)) bb))) 80 | (test-equal '((#\a . "foo") (#\b . "bar") (#\c . "baz") (#\d . "quux")) 81 | (bbtree->alist (bbtree-map symbol->string bb)))))) 82 | 83 | (define-test-case bbtrees conversion () 84 | (test-eqv '() (bbtree->alist (make-bbtree <))) 85 | (test-eqv 0 (bbtree-size (alist->bbtree '() <))) 86 | (test-equal '(("bar" . 12) ("baz" . 7) ("foo" . 1)) 87 | (bbtree->alist (alist->bbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) stringalist 92 | (alist->bbtree (map (lambda (x) (cons x 'dummy)) 93 | l) 94 | <)))))) 95 | (test-equal (list-sort < l) (tree-sort < l)))) 96 | 97 | (define-test-case bbtrees bbtree-union 98 | (let ([empty (make-bbtree charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) 100 | charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) 102 | charlist "abcdefghijlmnopqrstuvwxyz")] 119 | [b1 (map (lambda (x) (cons x (char->integer x))) l)] 120 | [b2 (map (lambda (x) (cons x #f)) l)]) 121 | (test-equal b1 122 | (bbtree->alist (bbtree-union (alist->bbtree b1 charbbtree b2 charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) 128 | charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) 130 | charalist (bbtree-intersection bbtree1 bbtree2))) 140 | ;; check this holds on larger bbtrees 141 | (let* ([l (string->list "abcdefghijlmnopqrstuvwxyz")] 142 | [b1 (map (lambda (x) (cons x (char->integer x))) l)] 143 | [b2 (map (lambda (x) (cons x #f)) l)]) 144 | (test-equal b1 145 | (bbtree->alist (bbtree-intersection (alist->bbtree b1 charbbtree b2 charalist (bbtree-intersection bbtree1 bbtree2)) 149 | (bbtree->alist 150 | (bbtree-difference bbtree1 151 | (bbtree-difference bbtree1 bbtree2))))))) 152 | 153 | (define-test-case bbtrees bbtree-difference 154 | (let ([empty (make-bbtree charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) 156 | charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) 158 | charalist (bbtree-difference bbtree1 bbtree2))) 166 | (test-equal '((#\p . 12) (#\s . 15)) 167 | (bbtree->alist (bbtree-difference bbtree2 bbtree1)))))) 168 | 169 | (define-test-case bbtrees bbtree-indexing 170 | (let* ([l (string->list "abcdefghijklmno")] 171 | [bb (alist->bbtree (map (lambda (x) (cons x #f)) l) charlist (list->deque list)))) 111 | (l1 '()) 112 | (l2 '(1 2 3)) 113 | (l3 '(4 5 6 7 8 9 10)) 114 | (l4 (string->list "abcdefghijklmnopqrstuvwxyz"))) 115 | (test-equal l1 (id-list l1)) 116 | (test-equal l2 (id-list l2)) 117 | (test-equal l3 (id-list l3)) 118 | (test-equal l4 (id-list l4)))) 119 | 120 | ) 121 | -------------------------------------------------------------------------------- /tests/fingertrees.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests fingertrees) 3 | (export fingertrees) 4 | (import (rnrs) 5 | (wak trc-testing) 6 | (pfds tests utils) 7 | (rename (pfds fingertrees) 8 | (make-fingertree %make-fingertree) 9 | (list->fingertree %list->fingertree)) 10 | ) 11 | 12 | ;; Right now, I am not testing the monoidal parts of fingertrees, so 13 | ;; we use constructor that replaces these with arbitrary values 14 | (define (make-fingertree) 15 | (%make-fingertree 0 (lambda (x y) x) (lambda (x) x))) 16 | 17 | (define (list->fingertree l) 18 | (%list->fingertree l 0 (lambda (x y) x) (lambda (x) x))) 19 | 20 | (define (list->product-tree l) 21 | (%list->fingertree l 1 * values)) 22 | 23 | (define (list->last-tree l) 24 | (define *cookie* (cons 'no 'last)) 25 | (define (pick x y) 26 | (if (eq? *cookie* y) 27 | x 28 | y)) 29 | (%list->fingertree l *cookie* pick values)) 30 | 31 | (define-test-suite fingertrees 32 | "Tests for the fingertree implementation") 33 | 34 | (define-test-case fingertrees empty-tree () 35 | (test-predicate fingertree? (make-fingertree)) 36 | (test-predicate fingertree-empty? (make-fingertree))) 37 | 38 | (define-test-case fingertrees construction 39 | (let ((l1 '(a b c d e f)) 40 | (l2 '((#t . f) (#t . e) (#t . d) (#t . c) (#t . b) (#t . a))) 41 | (l3 '((#f . a) (#f . b) (#f . c) (#f . d) (#f . e) (#f . f))) 42 | (l4 '((#f . b) (#f . c) (#t . a) (#f . d) (#f . e) (#f . f))) 43 | (l5 '((#f . e) (#t . d) (#t . c) (#t . b) (#f . f) (#t . a))) 44 | (make (lambda (alist) 45 | (fold-left (lambda (tree pair) 46 | (if (car pair) 47 | (fingertree-cons (cdr pair) tree) 48 | (fingertree-snoc tree (cdr pair)))) 49 | (make-fingertree) 50 | alist))) 51 | (empty (make-fingertree))) 52 | (test-case construction () 53 | (test-eqv #f (fingertree-empty? (fingertree-cons #f empty))) 54 | (test-eqv #f (fingertree-empty? (fingertree-snoc empty #f))) 55 | (test-equal l1 (fingertree->list (make l2))) 56 | (test-equal l1 (fingertree->list (make l3))) 57 | (test-equal l1 (fingertree->list (make l4))) 58 | (test-equal l1 (fingertree->list (make l5)))))) 59 | 60 | (define-test-case fingertrees removal 61 | (let* ((l1 '(a b c d e f)) 62 | (f1 (list->fingertree l1)) 63 | (f2 (make-fingertree))) 64 | (test-case removal () 65 | (test-exn fingertree-empty-condition? (fingertree-uncons f2)) 66 | (test-exn fingertree-empty-condition? (fingertree-unsnoc f2)) 67 | (let-values (((head tail) (fingertree-uncons f1))) 68 | (test-eqv (car l1) head) 69 | (test-equal (cdr l1) (fingertree->list tail))) 70 | (let*-values (((init last) (fingertree-unsnoc f1)) 71 | ((l*) (reverse l1)) 72 | ((l1-last) (car l*)) 73 | ((l1-init) (reverse (cdr l*)))) 74 | (test-eqv l1-last last) 75 | (test-equal l1-init (fingertree->list init)))))) 76 | 77 | (define-test-case fingertrees conversion 78 | (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 79 | 183 199 254 78 210 14 131 10 220 205 203 125 111 42 249)) 80 | (l2 '(25 168 21 246 39 211 60 83 103 161 192 201 31 253 81 | 156 218 204 186 155 117))) 82 | (test-case conversion () 83 | (test-equal '() (fingertree->list (list->fingertree '()))) 84 | (test-equal l1 (fingertree->list (list->fingertree l1))) 85 | (test-equal l2 (fingertree->list (list->fingertree l2)))))) 86 | 87 | (define-test-case fingertrees ftree-append 88 | (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 89 | 183 199 254 78 210 14 131 10 220 205 203 125 111 42 249)) 90 | (l2 '(25 168 21 246 39 211 60 83 103 161 192 201 31 253 91 | 156 218 204 186 155 117)) 92 | (append* (lambda (a b) 93 | (fingertree->list 94 | (fingertree-append 95 | (list->fingertree a) 96 | (list->fingertree b)))))) 97 | (test-case ftree-append () 98 | (test-equal (append l1 '()) (append* l1 '())) 99 | (test-equal (append '() l1) (append* '() l1)) 100 | (test-equal (append l1 l2) (append* l1 l2)) 101 | (test-equal (append l1 l1) (append* l1 l1)) 102 | (test-equal (append l1 l2) (append* l1 l2))))) 103 | 104 | (define-test-case fingertrees monoidal-operation 105 | (let ((l1 '(31 238 100 129 6 169 239 150 96 141 106 | 207 208 190 45 56 183 199 254 78 210)) 107 | (l2 '((31 238 100 129 6) (169 239 150) (96 141 207 208 190) 108 | () (45 56 183 199) (254 78 210))) 109 | (car/default (lambda (dflt) (lambda (x) (if (pair? x) (car x) dflt)))) 110 | (list->sum-tree (lambda (l1) (%list->fingertree l1 0 + values)))) 111 | (test-case moniodal-operation () 112 | (test-equal 254 (fingertree-measure (%list->fingertree l1 0 max values))) 113 | (test-equal 6 (fingertree-measure (%list->fingertree l1 1000 min values))) 114 | (test-equal l1 (fingertree-measure (%list->fingertree l2 '() append values))) 115 | (test-equal 595 (fingertree-measure 116 | (%list->fingertree l2 0 + (car/default 0)))) 117 | ;; sum of l1 is 4239 118 | (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 0)) 119 | (list->sum-tree l1)))) 120 | (fingertree->list (fingertree-append a b)))) 121 | (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 1000)) 122 | (list->sum-tree l1)))) 123 | (fingertree->list (fingertree-append a b)))) 124 | (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 2000)) 125 | (list->sum-tree l1)))) 126 | (fingertree->list (fingertree-append a b)))) 127 | (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 5000)) 128 | (list->sum-tree l1)))) 129 | (fingertree->list (fingertree-append a b))))))) 130 | 131 | (define-test-case fingertrees fingertree-folds 132 | (let* ((l '(31 238 100 129 6 169 239 150 96 141 133 | 207 208 190 45 56 183 199 254 78 210)) 134 | (lrev (reverse l)) 135 | (total (apply + l)) 136 | (ft (list->fingertree l))) 137 | (test-case fingertree-folds () 138 | ;; empty case 139 | (test-eqv #t (fingertree-fold (lambda _ #f) #t (make-fingertree))) 140 | (test-eqv #t (fingertree-fold-right (lambda _ #f) #t (make-fingertree))) 141 | ;; associative operations 142 | (test-eqv total (fingertree-fold + 0 ft)) 143 | (test-eqv total (fingertree-fold-right + 0 ft)) 144 | ;; non-associative operations 145 | (test-equal lrev (fingertree-fold cons '() ft)) 146 | (test-equal l (fingertree-fold-right cons '() ft))))) 147 | 148 | (define-test-case fingertrees reversal 149 | (let ((rev (lambda (l) 150 | (fingertree->list 151 | (fingertree-reverse (list->fingertree l))))) 152 | (id (lambda (l) 153 | (fingertree->list 154 | (fingertree-reverse 155 | (fingertree-reverse (list->fingertree l)))))) 156 | (l1 '(126 6 48 86 2 119 233 92 230 160)) 157 | (l2 '(25 168 21 246 39 211 60 83 103 161 158 | 192 201 31 253 156 218 204 186 155 117))) 159 | (test-case reversal () 160 | ;; behaves the same as regular reverse on lists 161 | (test-eqv '() (rev '())) 162 | (test-equal '(1) (rev '(1))) 163 | (test-equal '(6 5 4 3 2 1) (rev '(1 2 3 4 5 6))) 164 | (test-equal (reverse l1) (rev l1)) 165 | (test-equal (reverse l2) (rev l2)) 166 | ;; double reversal is the the same list 167 | (test-equal l1 (id l1)) 168 | (test-equal l2 (id l2)) 169 | ;; a fingertree will have the same measure as its reverse if 170 | ;; the monoid is commutative 171 | (test-equal (fingertree-measure (list->product-tree l1)) 172 | (fingertree-measure 173 | (fingertree-reverse (list->product-tree l1)))) 174 | ;; otherwise they are not necessarily the same 175 | ;; in this case, they are the same only if the first and last 176 | ;; elements are the same 177 | (test-not 178 | (equal? (fingertree-measure (list->last-tree l2)) 179 | (fingertree-measure (fingertree-reverse (list->product-tree l2)))))))) 180 | 181 | ) 182 | -------------------------------------------------------------------------------- /tests/hamts.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests hamts) 3 | (export hamts) 4 | (import (rnrs) 5 | (wak trc-testing) 6 | (pfds tests utils) 7 | (pfds hamts)) 8 | 9 | (define (make-string-hamt) 10 | (make-hamt string-hash string=?)) 11 | 12 | (define (compare-string-alist l1 l2) 13 | (lambda (l1 l2) 14 | (define (compare x y) (stringhamt / distinct keys 47 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) 48 | (h (alist->hamt l string-hash string=?))) 49 | (test-equal (list 1 2 3) 50 | (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) 51 | ;; alist->hamt / overlapping keys (leftmost shadows) 52 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("a" . 4))) 53 | (h (alist->hamt l string-hash string=?))) 54 | (test-equal (list 1 2 3) 55 | (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) 56 | ;; hamt->alist / distinct keys means left inverse 57 | (let ((l '(("a" . 1) ("b" . 2) ("c" . 3)))) 58 | (test-compare compare-string-alist l 59 | (hamt->alist (alist->hamt l string-hash string=?))))) 60 | 61 | (define-test-case hamts hamt-folding () 62 | ;; count size 63 | (let ((h (alist->hamt '(("a" . 1) ("b" . 2) ("c" . 3)) string-hash string=?)) 64 | (increment (lambda (k v acc) (+ 1 acc)))) 65 | (test-equal 3 (hamt-fold increment 0 h))) 66 | ;; copy hamt 67 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) 68 | (h (alist->hamt l string-hash string=?)) 69 | (add (lambda (k v acc) (hamt-set acc k v)))) 70 | (test-compare compare-string-alist l 71 | (hamt->alist (hamt-fold add (make-string-hamt) h))))) 72 | 73 | (define-test-case hamts hamt-removal () 74 | ;; removed key exists 75 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) 76 | (h (alist->hamt l string-hash string=?))) 77 | (test-case key-exists () 78 | (test-compare compare-string-alist '(("b" . 2) ("c" . 3)) (hamt-delete h "a")) 79 | (test-eqv (- (hamt-size h) 1) (hamt-size (hamt-delete h "a"))))) 80 | ;; removed key does not exist 81 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) 82 | (h (alist->hamt l string-hash string=?))) 83 | (test-case key-not-exists () 84 | (test-compare compare-string-alist l (hamt-delete h "d")) 85 | (test-eqv (hamt-size h) (hamt-size (hamt-delete h "d")))))) 86 | 87 | (define-test-case hamts hamt-updates () 88 | ;; update non-existent key 89 | (test-eqv 1 (hamt-ref (hamt-update (make-string-hamt) "foo" add1 0) "foo" #f)) 90 | ;; update existing key 91 | (let ((h (hamt-set (make-string-hamt) "foo" 12))) 92 | (test-eqv 13 (hamt-ref (hamt-update h "foo" add1 0) "foo" #f)))) 93 | 94 | (define-test-case hamts hamt-collisions () 95 | ;; a bad hash function does not cause problems 96 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) 97 | (h (alist->hamt l bad-hash string=?))) 98 | (test-compare compare-string-alist l (hamt->alist h))) 99 | ;; stress test, since bigger amounts data usually finds bugs 100 | (let ((insert (lambda (val hamt) (hamt-set hamt val val))) 101 | (hash (lambda (n) (exact (floor (/ n 2)))))) 102 | (test-eqv 100 (hamt-size (foldl insert (make-hamt hash =) (iota 100))))) 103 | ;; collision removal 104 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4))) 105 | (h (alist->hamt l bad-hash string=?))) 106 | (test-compare compare-string-alist '() 107 | (foldl (lambda (str hamt) (hamt-delete hamt str)) 108 | h 109 | '("b" "notexists" "d" "a" "c" "notexists")))) 110 | ;; stress test removal 111 | (let* ((al (map (lambda (x) (cons x #t)) (iota 100))) 112 | (hash (lambda (n) (exact (floor (/ n 2))))) 113 | (h (alist->hamt al hash =))) 114 | (test-eqv 94 (hamt-size (foldl (lambda (s h) (hamt-delete h s)) 115 | h 116 | (list 1 93 72 6 24 48))))) 117 | ;; collision updates 118 | (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) 119 | (h (alist->hamt l bad-hash string=?))) 120 | (test-compare compare-string-alist 121 | '(("a" . 2) ("b" . 3) ("c" . 4)) 122 | (foldl (lambda (key hamt) 123 | (hamt-update hamt key add1 0)) 124 | h 125 | '("a" "b" "c"))))) 126 | 127 | (define-test-case hamts hamt-mapping () 128 | (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) 129 | (h (alist->hamt l string-hash string=?))) 130 | (test-compare compare-string-alist l 131 | (hamt->alist (hamt-map (lambda (x) x) h)))) 132 | (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) 133 | (h (alist->hamt l string-hash string=?)) 134 | (stringify (lambda (n) (string (integer->char n))))) 135 | (test-compare compare-string-alist 136 | '(("a". "a") ("b" . "b") ("c" . "c")) 137 | (hamt->alist (hamt-map stringify h)))) 138 | (let ((h (alist->hamt '(("a" . 97) ("b" . 98) ("c" . 99)) string-hash string=?))) 139 | (test-eqv (hamt-size h) (hamt-size (hamt-map (lambda (x) x) h))))) 140 | 141 | ) 142 | -------------------------------------------------------------------------------- /tests/heaps.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests heaps) 3 | (export heaps) 4 | (import (rnrs) 5 | (wak trc-testing) 6 | (pfds tests utils) 7 | (pfds heaps)) 8 | 9 | (define-test-suite heaps 10 | "Tests for the leftist heap implementation") 11 | 12 | (define-test-case heaps empty-heap () 13 | (test-predicate heap? (make-heap <)) 14 | (test-predicate heap-empty? (make-heap <)) 15 | (test-eqv 0 (heap-size (heap <))) 16 | ) 17 | 18 | (define-test-case heaps heap-insertion 19 | (let ((h1 (heap < 7 1 13 9 5 3 11)) 20 | (h2 (heap < 4 2 8 10 6 0 12))) 21 | (test-case heap-insertion () 22 | (test-equal (+ 1 (heap-size h1)) 23 | (heap-size (heap-insert h1 0))) 24 | (test-equal (+ 1 (heap-size h1)) 25 | (heap-size (heap-insert h1 1))) 26 | (test-equal '(1 2 3 5 7 9 11 13) 27 | (heap->list (heap-insert h1 2))) 28 | (test-equal '(1 3 4 5 7 9 11 13) 29 | (heap->list (heap-insert h1 4))) 30 | (test-equal '(1 3 5 7 9 11 12 13) 31 | (heap->list (heap-insert h1 12))) 32 | (test-equal '(1 3 5 7 9 11 13 100) 33 | (heap->list (heap-insert h1 100))) 34 | (test-equal '(-2 0 2 4 6 8 10 12) 35 | (heap->list (heap-insert h2 -2))) 36 | (test-equal '(0 0 2 4 6 8 10 12) 37 | (heap->list (heap-insert h2 0))) 38 | (test-equal '(0 2 4 6 8 8 10 12) 39 | (heap->list (heap-insert h2 8)))))) 40 | 41 | (define-test-case heaps heap-deletion 42 | (let ((h1 (heap < 7 1 13 9 5 3 11)) 43 | (h2 (heap < 4 2 8 6 0))) 44 | (test-case heap-deletion () 45 | (test-equal (- (heap-size h1) 1) 46 | (heap-size (heap-delete-min h1))) 47 | (test-equal 1 (heap-min h1)) 48 | (test-equal 0 (heap-min h2)) 49 | (test-equal 1 (heap-min (heap-delete-min (heap-insert h1 -10)))) 50 | (test-equal 3 (heap-size (heap-delete-min (heap-delete-min h2)))) 51 | (test-equal 4 (heap-min (heap-delete-min (heap-delete-min h2)))) 52 | (test-equal '(7 9 11 13) 53 | (heap->list 54 | (heap-delete-min (heap-delete-min (heap-delete-min h1))))) 55 | (test-exn heap-empty-condition? (heap-pop (make-heap <))) 56 | (test-exn heap-empty-condition? (heap-delete-min (make-heap <))) 57 | (test-exn heap-empty-condition? (heap-min (make-heap <)))))) 58 | 59 | (define-test-case heaps sorting 60 | (let ((l1 '(129 109 146 175 229 48 225 239 129 41 61 | 38 13 187 15 207 70 64 198 79 125)) 62 | (l2 '(72 17 220 158 164 133 20 78 96 230 25 63 | 19 13 17 58 223 37 214 94 195 93 174))) 64 | (test-case sorting () 65 | (test-equal '() (heap-sort < '())) 66 | (test-equal (list-sort < l1) 67 | (heap-sort < l1)) 68 | (test-equal (list-sort < l2) 69 | (heap-sort < l2))))) 70 | 71 | ) 72 | -------------------------------------------------------------------------------- /tests/psqs.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests psqs) 3 | (export psqs) 4 | (import (rnrs) 5 | (wak trc-testing) 6 | (pfds tests utils) 7 | (pfds psqs)) 8 | 9 | (define (alist->psq alist keypsq '((#\a . 10) (#\b . 33) (#\c . 3)) 51 | charpsq '((#\a . 10) (#\b . 33) (#\c . 3) (#\d . 23) (#\e . 7)) 91 | charpsq alist charqueue list))) 53 | (test-eqv 5 (queue-length queue)) 54 | (test-equal list (queue->list queue)))) 55 | 56 | ) 57 | -------------------------------------------------------------------------------- /tests/sequences.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests sequences) 3 | (export sequences) 4 | (import (rnrs) 5 | (wak trc-testing) 6 | (pfds tests utils) 7 | (pfds sequences)) 8 | 9 | (define-test-suite sequences 10 | "Tests for the sequences implementation") 11 | ;; Note: at the moment, sequences are a trivial instantiation of 12 | ;; fingertrees, and so are pretty much covered by the fingertrees 13 | ;; tests. 14 | 15 | (define-test-case sequences sequences-bugs 16 | (let ((s (sequence 'zero 'one 'two))) 17 | (test-case sequences-bugs () 18 | (test-eqv 'zero (sequence-ref s 0)) 19 | (test-eqv 'two (sequence-ref s 2)) 20 | (test-exn assertion-violation? (sequence-ref s -1)) 21 | (test-exn assertion-violation? (sequence-ref s 3))))) 22 | 23 | ) 24 | -------------------------------------------------------------------------------- /tests/sets.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests sets) 3 | (export sets) 4 | (import (rnrs) 5 | (wak trc-testing) 6 | (pfds tests utils) 7 | (pfds sets)) 8 | 9 | (define-test-suite sets 10 | "Tests for the set implementation") 11 | 12 | (define-test-case sets set-basics 13 | (let ([empty (make-set stringset '("foo" "bar" "baz") stringset '("foo" "bar" "baz" "quux" "zot") stringset '(0 2 5 7 12 2 3 62 5) <)] 50 | [set2 (list->set '(94 33 44 2 73 55 48 92 98 29 51 | 28 98 55 20 69 5 33 53 89 50) 52 | <)] 53 | [sets (list empty set1 set2)]) 54 | (test-case set-operations () 55 | (test (for-all (lambda (x) (set=? x (set-union x x))) sets)) 56 | (test (for-all (lambda (x) (set=? x (set-intersection x x))) sets)) 57 | (test (for-all (lambda (x) (set=? empty (set-difference x x))) sets)) 58 | (test (for-all (lambda (x) (set=? x (set-union empty x))) sets)) 59 | (test (for-all (lambda (x) (set=? empty (set-intersection empty x))) sets)) 60 | (test (for-all (lambda (x) (set=? x (set-difference x empty))) sets)) 61 | (test (for-all (lambda (x) (set=? empty (set-difference empty x))) sets)) 62 | 63 | (test (set=? (set-union set1 set2) (set-union set2 set1))) 64 | (test (set=? (set-union set1 set2) 65 | (list->set '(0 2 3 69 7 73 12 20 89 28 66 | 29 94 5 33 98 92 44 48 50 53 67 | 55 62) 68 | <))) 69 | 70 | (test (set=? (set-intersection set1 set2) (set-intersection set2 set1))) 71 | (test (set=? (set-intersection set1 set2) 72 | (list->set '(2 5) <))) 73 | (test (set=? (set-difference set1 set2) 74 | (list->set '(0 3 12 62 7) <))) 75 | (test (set=? (set-difference set2 set1) 76 | (list->set '(33 98 69 73 44 48 92 50 20 53 77 | 55 89 28 29 94) 78 | <)))))) 79 | 80 | (define-test-case sets set-conversion () 81 | (test-eqv '() (set->list (make-set <))) 82 | (test-eqv 0 (set-size (list->set '() <))) 83 | (test-equal (string->list "abcdefghijklmno") 84 | (list-sort charlist 86 | (list->set (string->list "abcdefghijklmno") charlist (fold-left set-insert (make-set <) '(0 0 0 0))))) 88 | 89 | (define-test-case sets set-iterators () 90 | (test-eqv 0 (set-fold + 0 (list->set '() <))) 91 | (test-eqv 84 (set-fold + 0 (list->set '(3 12 62 7) <))) 92 | (test-eqv 499968 (set-fold * 1 (list->set '(3 12 62 7 8 4) <)))) 93 | 94 | ) 95 | -------------------------------------------------------------------------------- /tests/utils.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (library (pfds tests utils) 3 | (export pfds 4 | test 5 | test-not 6 | test-exn 7 | test-no-exn 8 | add1 9 | foldl 10 | iota 11 | ) 12 | (import (rnrs) 13 | (wak trc-testing)) 14 | 15 | (define-test-suite pfds 16 | "Test suite for libraries under the (pfds) namespace") 17 | 18 | (define-syntax test 19 | (syntax-rules () 20 | ((test body) 21 | (test-eqv #t (and body #t))))) 22 | 23 | (define-syntax test-not 24 | (syntax-rules () 25 | ((test-not body) 26 | (test-eqv #f body)))) 27 | 28 | (define-syntax test-exn 29 | (syntax-rules () 30 | ((test-exn exception-pred? body) 31 | (test-eqv #t 32 | (guard (exn ((exception-pred? exn) #t) 33 | (else #f)) 34 | body 35 | #f))))) 36 | 37 | (define-syntax test-no-exn 38 | (syntax-rules () 39 | ((test-no-exn body) 40 | (test-eqv #t 41 | (guard (exn (else #f)) 42 | body 43 | #t))))) 44 | 45 | (define (add1 x) 46 | (+ x 1)) 47 | 48 | (define (foldl kons knil list) 49 | (if (null? list) 50 | knil 51 | (foldl kons (kons (car list) knil) (cdr list)))) 52 | 53 | (define (iota n) 54 | (define (recur x) 55 | (if (< x n) 56 | (cons x (recur (+ x 1))) 57 | '())) 58 | (assert (integer? n)) 59 | (recur 0)) 60 | 61 | ) 62 | --------------------------------------------------------------------------------