├── data-test ├── tests │ └── data │ │ ├── info.rkt │ │ ├── test-docs-complete.rkt │ │ ├── order.rkt │ │ ├── enumerate │ │ └── util.rkt │ │ ├── integer-set.rkt │ │ ├── gvector.rkt │ │ ├── queue.rkt │ │ ├── bit-vector.rkt │ │ ├── heap.rkt │ │ ├── interval-map.rkt │ │ └── ordered-dict.rkt └── info.rkt ├── data-doc ├── data │ ├── info.rkt │ └── scribblings │ │ ├── cite.rkt │ │ ├── data.scrbl │ │ ├── union-find.scrbl │ │ ├── queue.scrbl │ │ ├── gvector.scrbl │ │ ├── bit-vector.scrbl │ │ ├── integer-set.scrbl │ │ ├── splay-tree.scrbl │ │ ├── heap.scrbl │ │ ├── skip-list.scrbl │ │ ├── order.scrbl │ │ └── interval-map.scrbl └── info.rkt ├── .gitignore ├── data-lib ├── data │ ├── heap │ │ └── unsafe.rkt │ ├── union-find.rkt │ ├── gvector.rkt │ ├── order.rkt │ └── heap.rkt └── info.rkt ├── data └── info.rkt ├── data-enumerate-lib ├── info.rkt └── data │ ├── enumerate │ ├── unsafe.rkt │ ├── lib │ │ └── unsafe.rkt │ ├── private │ │ └── unfair.rkt │ ├── compat.rkt │ └── lib.rkt │ └── enumerate.rkt ├── LICENSE └── README.md /data-test/tests/data/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define test-responsibles '(("enumerate.rkt" (maxsnew jay robby)))) 3 | -------------------------------------------------------------------------------- /data-doc/data/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings 4 | '(("scribblings/data.scrbl" (multi-page) ("Data Structures")))) 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /data-lib/data/heap/unsafe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (submod "../heap.rkt" unchecked) 4 | (only-in "../heap.rkt" heap-sort!)) 5 | (provide (all-from-out (submod "../heap.rkt" unchecked)) 6 | heap-sort!) 7 | -------------------------------------------------------------------------------- /data/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("data-lib" "data-enumerate-lib" "data-doc")) 6 | (define implies '("data-lib" "data-enumerate-lib" "data-doc")) 7 | 8 | (define pkg-desc "Data strucutures") 9 | 10 | (define pkg-authors '(ryanc)) 11 | 12 | (define license 13 | '(Apache-2.0 OR MIT)) 14 | -------------------------------------------------------------------------------- /data-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | (define deps '(("base" #:version "6.2.900.6"))) 4 | (define build-deps '("rackunit-lib")) 5 | 6 | (define pkg-desc "implementation (no documentation) part of \"data\"") 7 | 8 | (define pkg-authors '(ryanc)) 9 | 10 | (define version "1.2") 11 | 12 | (define license 13 | '(Apache-2.0 OR MIT)) 14 | -------------------------------------------------------------------------------- /data-test/tests/data/test-docs-complete.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit/docs-complete) 3 | (check-docs (quote data/splay-tree)) 4 | (check-docs (quote data/skip-list)) 5 | (check-docs (quote data/queue)) 6 | (check-docs (quote data/order)) 7 | (check-docs (quote data/interval-map)) 8 | (check-docs (quote data/heap)) 9 | (check-docs (quote data/gvector)) 10 | -------------------------------------------------------------------------------- /data-enumerate-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | (define deps '(("base" #:version "6.8.0.2") 4 | "data-lib" "math-lib")) 5 | (define build-deps '("rackunit-lib")) 6 | 7 | (define pkg-desc "implementation (no documentation) of \"data/enumerate\"") 8 | 9 | (define pkg-authors '(maxsnew jay robby)) 10 | (define version "1.3") 11 | 12 | (define license 13 | '(Apache-2.0 OR MIT)) 14 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/cite.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require scriblib/autobib) 3 | (provide (all-defined-out)) 4 | 5 | (define-cite ~cite citet generate-bibliography) 6 | 7 | (define whats-the-difference 8 | (make-bib 9 | #:title "What's the difference? A Functional Pearl on Subtracting Bijections" 10 | #:author (authors "Brent Yorgey" "Kenneth Foner") 11 | #:date 2018 12 | #:location (proceedings-location "International Conference on Functional Programming"))) 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /data-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base")) 6 | 7 | (define pkg-desc "tests for \"data-lib\"") 8 | 9 | (define pkg-authors '(ryanc)) 10 | (define build-deps '("data-enumerate-lib" 11 | "racket-index" 12 | ["data-lib" #:version "1.2"] 13 | "rackunit-lib" 14 | "math-lib")) 15 | (define update-implies '("data-lib")) 16 | 17 | (define license 18 | '(Apache-2.0 OR MIT)) 19 | -------------------------------------------------------------------------------- /data-enumerate-lib/data/enumerate/unsafe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "private/core.rkt") 4 | (provide 5 | enum? 6 | enum-count 7 | from-nat 8 | to-nat 9 | enum-contract 10 | in-enum 11 | map/e 12 | pam/e 13 | except/e 14 | enum->list 15 | below/e 16 | empty/e 17 | natural/e 18 | or/e 19 | append/e 20 | fin-cons/e 21 | dep/e 22 | thunk/e 23 | list/e 24 | cantor-list/e 25 | box-list/e 26 | prime-length-box-list/e 27 | bounded-list/e 28 | box-tuples/e 29 | below/e 30 | 31 | two-way-enum? 32 | one-way-enum? 33 | flat-enum? 34 | finite-enum? 35 | infinite-enum?) -------------------------------------------------------------------------------- /data-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base")) 6 | 7 | (define pkg-desc "documentation part of \"data\"") 8 | 9 | (define pkg-authors '(ryanc)) 10 | (define build-deps '(["data-lib" #:version "1.2"] 11 | "data-enumerate-lib" 12 | "racket-doc" 13 | "scribble-lib" 14 | "plot-lib" 15 | "math-doc" 16 | "math-lib" 17 | "pict-doc" 18 | "pict-lib")) 19 | (define update-implies '("data-lib" "data-enumerate-lib")) 20 | 21 | (define license 22 | '(Apache-2.0 OR MIT)) 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # data 2 | 3 | This the source for the Racket packages: "data", "data-doc", "data-enumerate-lib", "data-lib", "data-test". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/data/pulls 22 | [issue]: https://github.com/racket/data/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/data.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/base 3 | scribble/manual 4 | (for-syntax racket/base racket/path) 5 | (for-label scribble/base) 6 | "cite.rkt") 7 | 8 | @title[#:tag "data"]{Data: Data Structures} 9 | 10 | This manual documents data structure libraries available in the 11 | @racketidfont{data} collection. 12 | 13 | @local-table-of-contents[#:style 'immediate-only] 14 | 15 | @;{--------} 16 | 17 | @include-section["queue.scrbl"] 18 | @include-section["gvector.scrbl"] 19 | @include-section["order.scrbl"] 20 | @include-section["splay-tree.scrbl"] 21 | @include-section["skip-list.scrbl"] 22 | @include-section["interval-map.scrbl"] 23 | @include-section["heap.scrbl"] 24 | @include-section["integer-set.scrbl"] 25 | @include-section["bit-vector.scrbl"] 26 | @include-section["union-find.scrbl"] 27 | @include-section["enumerate.scrbl"] 28 | 29 | @generate-bibliography[] 30 | -------------------------------------------------------------------------------- /data-enumerate-lib/data/enumerate/lib/unsafe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "../unsafe.rkt") 3 | (provide (all-from-out "../unsafe.rkt")) 4 | (require "../private/more.rkt") 5 | 6 | (provide cons/de 7 | char/e 8 | string/e 9 | integer/e 10 | flonum/e 11 | exact-rational/e 12 | real/e 13 | two-way-real/e 14 | number/e 15 | two-way-number/e 16 | bool/e 17 | symbol/e 18 | delay/e 19 | flip-dep/e 20 | random-index 21 | infinite-sequence/e 22 | set/e 23 | permutations/e 24 | permutations-of-n/e 25 | nat+/e 26 | fold-enum 27 | range/e 28 | listof/e 29 | non-empty-listof/e 30 | listof-n/e 31 | take/e 32 | slice/e 33 | hash-traverse/e 34 | cons/e 35 | vector/e 36 | single/e 37 | fin/e) 38 | -------------------------------------------------------------------------------- /data-test/tests/data/order.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit 3 | data/order) 4 | 5 | ;; for tests 6 | (struct fish (kind) #:transparent) 7 | (struct fowl (kind) #:transparent) 8 | 9 | ;; datum-order tests 10 | 11 | (define-syntax-rule (t cmp x y) 12 | (test-case (format "~s" '(t cmp x y)) 13 | (check-equal? (datum-order x y) 'cmp))) 14 | 15 | (t = 1 1) 16 | (t = +inf.0 +inf.0) 17 | (t = 8.0 8.0) 18 | (t = +nan.0 +nan.0) 19 | (t = +nan.0 (- +inf.0 +inf.0)) 20 | (t = 'apple 'apple) 21 | (t = '(a #:b c) '(a #:b c)) 22 | (t = "apricot" "apricot") 23 | (t = '#(1 2 3) '#(1 2 3)) 24 | (t = (box 'car) (box 'car)) 25 | (t = (box 'car) '#&car) 26 | (t = '#s(point a 1) '#s(point a 1)) 27 | (t = (fish 'alewife) (fish 'alewife)) 28 | 29 | (t < 1 2) 30 | (t > 8.0 5.0) 31 | (t < 'apple 'candy) 32 | (t < '(a #:b c) '(a #:c d c)) 33 | (t > '(5 . 4) '(3 2 1)) 34 | (t < '(a b . c) '(a b . z)) 35 | (t > "apricot" "apple") 36 | (t > '#(1 2 3) '#(1 2)) 37 | (t < '#(1 2 3) '#(1 3)) 38 | (t > (box 'car) (box 'candy)) 39 | (t < '#s(point a 1) '#s(point b 0)) 40 | (t < '#s(A 1 2) '#s(Z 3 4 5)) 41 | (t < (fish 'alewife) (fish 'sockeye)) 42 | 43 | (define-syntax-rule (tc x y) 44 | (test-case (format "~s" '(tc x y)) 45 | (let ([xy (datum-order x y)] 46 | [xy2 (datum-order x y)] 47 | [yx (datum-order y x)] 48 | [xy3 (datum-order x y)]) 49 | ;; check consistency across multiple runs 50 | (check-equal? xy xy2) 51 | (check-equal? xy xy3) 52 | ;; check oppositeness 53 | (check member (list xy yx) '((< >) (> <)))))) 54 | 55 | (tc 1 2.0) 56 | (tc 3+5i 3+2i) 57 | (tc 'apple "zucchini") 58 | (tc '(a b) '(a b . c)) 59 | (tc 0 'zero) 60 | 61 | (tc (fish 'alewife) (fowl 'dodo)) 62 | 63 | (tc (fish 'alewife) 64 | (let () 65 | (struct fish (x)) 66 | (fish 'alewife))) 67 | -------------------------------------------------------------------------------- /data-test/tests/data/enumerate/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require data/enumerate 3 | rackunit 4 | (for-syntax racket/base) 5 | racket/contract) 6 | (provide check-bijection? check-bijection/just-a-few? 7 | check-contract) 8 | 9 | (define (do-check-bijection e confidence) 10 | (for/and ([n (in-range (if (finite-enum? e) 11 | (min (enum-count e) confidence) 12 | confidence))]) 13 | (= n (to-nat e (from-nat e n))))) 14 | (define-simple-check (check-bijection? e) 15 | (do-check-bijection e 1000)) 16 | (define-simple-check (check-bijection/just-a-few? e) 17 | (do-check-bijection e 100)) 18 | 19 | 20 | (define-syntax (check-contract stx) 21 | (syntax-case stx () 22 | [(_ e) 23 | (with-syntax ([line (syntax-line stx)]) 24 | (syntax/loc stx (check-contract/proc line e 'e)))])) 25 | 26 | (define (check-contract/proc line enum enum-code) 27 | (for ([x (in-range (if (finite-enum? enum) 28 | (min (enum-count enum) 100) 29 | 100))]) 30 | (with-handlers ([exn:fail? 31 | (λ (exn) 32 | (printf "exn exercising when x=~a\n" x) 33 | (raise exn))]) 34 | (contract-exercise 35 | (contract (enum-contract enum) 36 | (from-nat enum x) 37 | 'ignore-me 38 | 'whatever 39 | (format "~s, index ~a" enum-code x) 40 | #f)))) 41 | 42 | (when (two-way-enum? enum) 43 | (let/ec give-up-completely 44 | (for ([x (in-range 100)]) 45 | (with-handlers ([exn:fail? 46 | (λ (exn) 47 | (printf "exn generating when x=~a\n" x) 48 | (raise exn))]) 49 | (let/ec give-up-this-attempt 50 | (define value 51 | (contract-random-generate 52 | (enum-contract enum) 53 | 2 54 | (λ (no-generator?) 55 | (cond 56 | [no-generator? 57 | (eprintf "no generator for:\n ~s\n ~s\n" 58 | enum-code 59 | (enum-contract enum)) 60 | (give-up-completely (void))] 61 | [else 62 | (give-up-this-attempt)])))) 63 | (with-handlers ([exn:fail? 64 | (λ (x) 65 | (eprintf "test/data/enumerate: trying ~s\n" value) 66 | (raise x))]) 67 | (to-nat enum value)))))))) 68 | -------------------------------------------------------------------------------- /data-test/tests/data/integer-set.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require data/integer-set 3 | racket/stream 4 | rackunit 5 | racket/sequence) 6 | 7 | (test-equal? "integer-set" 8 | (integer-set-contents (make-integer-set '((-1 . 2) (4 . 10)))) 9 | '((-1 . 2) (4 . 10))) 10 | 11 | (test-true "integer-set?" 12 | (integer-set? (make-integer-set '((-1 . 2) (4 . 10))))) 13 | 14 | (test-equal? "set-integer-set-contents!" 15 | (let ([s (make-integer-set '((-1 . 2) (4 . 10)))]) 16 | (set-integer-set-contents! s '((1 . 1) (3 . 3))) 17 | (integer-set-contents s)) 18 | '((1 . 1) (3 . 3))) 19 | 20 | (test-true "well-formed-set? true" 21 | (well-formed-set? '((-1 . 2) (4 . 10)))) 22 | 23 | (test-false "well-formed-set? false" 24 | (well-formed-set? '((1 . 5) (6 . 7)))) 25 | 26 | (define s1 (make-integer-set '((-1 . 2) (4 . 10)))) 27 | (define s2 (make-integer-set '((1 . 1) (3 . 3)))) 28 | 29 | (check-true (member? 1 (intersect s1 s2))) 30 | (check-false (member? 3 (intersect s1 s2))) 31 | 32 | (check-true (member? 2 (union s1 s2))) 33 | (check-false (member? 15 (union s1 s2))) 34 | 35 | (check-true (member? 4 (subtract s1 s2))) 36 | (check-false (member? 1 (subtract s1 s2))) 37 | 38 | (check-true (member? 4 (symmetric-difference s1 s2))) 39 | (check-true (member? 3 (symmetric-difference s1 s2))) 40 | (check-false (member? 1 (symmetric-difference s1 s2))) 41 | 42 | (check-equal? (count s1) 11) 43 | (check-equal? (count s2) 2) 44 | 45 | (check-true (member? (get-integer s1) s1)) 46 | (check-false (get-integer (make-integer-set '()))) 47 | 48 | (check-equal? (partition (list (make-integer-set '((1 . 2) (5 . 10))) 49 | (make-integer-set '((2 . 2) (6 . 6) (12 . 12))))) 50 | (list (make-integer-set '((2 . 2) (6 . 6))) 51 | (make-integer-set '((12 . 12))) 52 | (make-integer-set '((1 . 1) (5 . 5) (7 . 10))))) 53 | 54 | (check-true (subset? (make-integer-set '((1 . 1))) s2)) 55 | 56 | ;; check gen:stream 57 | (check-equal? (stream-first s1) -1) 58 | (check-equal? (stream-first (stream-rest s1)) 0) 59 | (check-equal? (stream-first (stream-rest s2)) 3) 60 | (check-true (stream-empty? (make-integer-set '()))) 61 | (check-false (stream-empty? s1)) 62 | (check-equal? (stream->list (stream-map add1 s2)) '(2 4)) 63 | 64 | ;; 2013-02-20: checks commit bd1141c670bfc7981761fbfb53f548c2abb1f12d 65 | ;; (previous version results in contract error) 66 | (check-true (well-formed-set? (integer-set-contents (stream-rest (make-range 1 10))))) 67 | (check-true (well-formed-set? (integer-set-contents (sequence-tail (make-range 1 10) 1)))) 68 | -------------------------------------------------------------------------------- /data-enumerate-lib/data/enumerate/private/unfair.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide unfair-n+n->n 3 | unfair-n->n+n 4 | unfair-n*n->n 5 | unfair-n->n*n) 6 | 7 | (define (fllog n) 8 | (let loop ([n n]) 9 | (cond 10 | [(= n 1) 0] 11 | [else (+ 1 (loop (quotient n 2)))]))) 12 | 13 | (define (count-up n) 14 | (let loop ([n n] 15 | [group-size 1]) 16 | (cond 17 | [(<= n 0) 1] 18 | [else 19 | (+ (loop (- n group-size) 20 | (- (* (+ group-size 1) 2) 1)) 21 | 1)]))) 22 | 23 | (define (unfair-n+n->n left? n) 24 | (if left? 25 | (if (zero? n) 26 | 0 27 | (+ n (count-up n))) 28 | (expt 2 n))) 29 | 30 | (define (unfair-n->n+n n) 31 | (cond 32 | [(zero? n) (values #t 0)] 33 | [else 34 | (define f (fllog n)) 35 | (cond 36 | [(= (expt 2 f) n) 37 | (values #f f)] 38 | [else 39 | (values #t (- n (fllog n) 1))])])) 40 | 41 | (define (unfair-n->n*n n) 42 | (define twos 0) 43 | (define leftover 44 | (let loop ([n (+ n 1)]) 45 | (cond 46 | [(and (not (zero? n)) (even? n)) 47 | (set! twos (+ twos 1)) 48 | (loop (/ n 2))] 49 | [else n]))) 50 | (values (/ (- leftover 1) 2) twos)) 51 | 52 | (define (unfair-n*n->n x y) 53 | (- (* (expt 2 y) (+ (* 2 x) 1)) 1)) 54 | 55 | (module+ test 56 | (require rackunit) 57 | 58 | ;; test alternation bijection 59 | (for ([i (in-range 100000)]) 60 | (define-values (left? n) (unfair-n->n+n i)) 61 | (define j (unfair-n+n->n left? n)) 62 | (unless (= i j) 63 | (error 'bad-bijection-fails 64 | "~s => ~s ~s => ~s" 65 | i left? n j))) 66 | 67 | ;; test pairing bijection 68 | (for ([i (in-range 100000)]) 69 | (define-values (x y) (unfair-n->n*n i)) 70 | (define j (unfair-n*n->n x y)) 71 | (unless (= i j) 72 | (error 'bad-bijection-fails "~s => ~s ~s => ~s" 73 | i x y j))) 74 | 75 | ;; make sure that we go left first 76 | ;; important for things like 77 | ;; (define x (thunk/e (or/e (single/e #f) (cons/e x x)))) 78 | (check-true (call-with-values 79 | (λ () (unfair-n->n+n 0)) 80 | (λ (x y) x))) 81 | 82 | ;; make sure that we get more on the left than 83 | ;; the right in the sum combinator. 84 | (check-true (let ([limit 1000]) 85 | (define (get-sum count-left?) 86 | (for/sum ([i (in-range limit)]) 87 | (define-values (left? n) (unfair-n->n+n i)) 88 | (if (equal? count-left? left?) 1 0))) 89 | (< (get-sum #f) (get-sum #t)))) 90 | 91 | ;; make sure we go deeper into the left component than 92 | ;; the right in the pair combinator 93 | (check-true (let ([limit 1000]) 94 | (define (get-pair count-left?) 95 | (for/fold ([deep 0]) ([i (in-range limit)]) 96 | (define-values (left right) (unfair-n->n*n i)) 97 | (max deep (if count-left? left right)))) 98 | (< (get-pair #f) (get-pair #t))))) 99 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/union-find.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label data/union-find 4 | racket/contract 5 | racket/base)) 6 | 7 | @title[#:tag "union-find"]{Union-Find: Sets with only Canonical Elements} 8 | 9 | @(define the-eval (make-base-eval)) 10 | @(the-eval '(require data/union-find)) 11 | 12 | @defmodule[data/union-find] 13 | 14 | The union-find algorithm and data structure provides 15 | an API for representing sets that contain a single, 16 | canonical element. The sets support an (imperative) union 17 | operation (the library picks one of the canonical elements 18 | of the original sets to be the canonical element of the union), 19 | as well as getting and setting the canonical element. 20 | 21 | These operations are not thread-safe. 22 | 23 | @defproc[(uf-new [c any/c]) uf-set?]{ 24 | 25 | Makes a new set with the canonical element @racket[c]. 26 | 27 | This is a constant time operation. 28 | 29 | @examples[#:eval the-eval 30 | (uf-new 'whale) 31 | (uf-new 'dwarf-lantern)] 32 | } 33 | 34 | 35 | @defproc[(uf-set? [x any/c]) boolean?]{ 36 | 37 | Returns @racket[#t] if @racket[x] was created with @racket[uf-new], 38 | and @racket[#f] otherwise. 39 | 40 | This is a constant time operation. 41 | 42 | @examples[#:eval the-eval 43 | (uf-set? (uf-new 'spiny-dogfish)) 44 | (uf-set? "I am not a uf-set")] 45 | } 46 | 47 | @defproc[(uf-find [a uf-set?]) any/c]{ 48 | Returns the canonical element of @racket[a]. 49 | 50 | This is an amortized (essentially) constant time operation. 51 | 52 | @examples[#:eval the-eval 53 | (uf-find (uf-new 'tasselled-wobbegong))] 54 | } 55 | 56 | @defproc[(uf-union! [a uf-set?] [b uf-set?]) void?]{ 57 | 58 | Imperatively unifies @racket[a] and @racket[b], making 59 | them both have the same canonical element. Either 60 | of @racket[a] or @racket[b]'s canonical elements may 61 | become the canonical element for the union. 62 | 63 | This is an amortized (essentially) constant time operation. 64 | 65 | @examples[#:eval the-eval 66 | (define a (uf-new 'sand-devil)) 67 | (define b (uf-new 'pigeye)) 68 | (uf-union! a b) 69 | (uf-find a) 70 | (uf-find b) 71 | ] 72 | } 73 | 74 | @defproc[(uf-same-set? [a uf-set?] [b uf-set?]) boolean?]{ 75 | Returns @racket[#t] if the sets @racket[a] and @racket[b] 76 | have been unioned. 77 | 78 | This is an amortized (essentially) constant time operation. 79 | 80 | @examples[#:eval the-eval 81 | (define a (uf-new 'finetooth)) 82 | (define b (uf-new 'speartooth)) 83 | (uf-same-set? a b) 84 | (uf-union! a b) 85 | (uf-same-set? a b) 86 | ] 87 | 88 | 89 | } 90 | 91 | @defproc[(uf-set-canonical! [a uf-set?] [c any/c]) void?]{ 92 | Changes @racket[a] to have a new canonical element. 93 | 94 | This is an amortized (essentially) constant time operation. 95 | 96 | @examples[#:eval the-eval 97 | (define a (uf-new 'sand-devil)) 98 | (uf-set-canonical! a 'lemon) 99 | (uf-find a) 100 | (define b (uf-new 'pigeye)) 101 | (uf-union! a b) 102 | (uf-set-canonical! b 'sicklefin-lemon) 103 | (uf-find a) 104 | ] 105 | 106 | } 107 | 108 | @close-eval[the-eval] 109 | -------------------------------------------------------------------------------- /data-enumerate-lib/data/enumerate/compat.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (prefix-in : "lib.rkt") 4 | (prefix-in unsafe: "unsafe.rkt") 5 | racket/stream 6 | racket/contract) 7 | 8 | (provide (all-defined-out)) 9 | 10 | (define (map/e f1 f2 . es) 11 | (apply unsafe:map/e f1 f2 #:contract any/c es)) 12 | 13 | (define enum? :enum?) 14 | (define size :enum-count) 15 | (define from-nat :from-nat) 16 | (define to-nat :to-nat) 17 | (define (filter/e . args) (error 'filter/e "this one is gone; don't use it")) 18 | (define except/e :except/e) 19 | (define (to-stream e) 20 | (cond 21 | [(:finite-enum? e) 22 | (let loop ([n 0]) 23 | (cond [(n . >= . (:enum-count e)) 24 | empty-stream] 25 | [else 26 | (stream-cons (:from-nat e n) 27 | (loop (add1 n)))]))] 28 | [else 29 | (let loop ([n 0]) 30 | (stream-cons (:from-nat e n) (loop (add1 n))))])) 31 | (define approximate :enum->list) 32 | (define to-list :enum->list) 33 | (define take/e :take/e) 34 | (define slice/e :slice/e) 35 | (define below/e :below/e) 36 | (define empty/e :empty/e) 37 | (define const/e :fin/e) 38 | (define (from-list/e l) (apply fin/e l)) 39 | (define fin/e :fin/e) 40 | (define nat/e :natural/e) 41 | (define int/e :integer/e) 42 | (define disj-sum/e :or/e) 43 | (define disj-append/e :append/e) 44 | (define fin-cons/e :cons/e) 45 | (define cons/e :cons/e) 46 | (define (elegant-cons/e a b) (cons/e a b)) 47 | (define (traverse/e f xs) (apply :list/e (map f xs))) 48 | (define hash-traverse/e :hash-traverse/e) 49 | (define (dep/e e f) (:cons/de [hd e] [tl (hd) (f hd)])) 50 | (define (dep2/e n e f) (:cons/de [hd e] [tl (hd) (f hd)])) 51 | (define fold-enum :fold-enum) 52 | (define (flip-dep/e e f) (:cons/de [hd (tl) (f tl)] [tl e])) 53 | (define range/e :range/e) 54 | (define thunk/e :thunk/e) 55 | (define fix/e 56 | (case-lambda 57 | [(n f) (define e (:thunk/e (λ () (f e)) #:count n)) e] 58 | [(f) (fix/e f)])) 59 | (define many/e 60 | (case-lambda 61 | [(e n) (:listof-n/e nat/e n)] 62 | [(e) (:listof/e e)])) 63 | (define many1/e :non-empty-listof/e) 64 | (define (cantor-vec/e . args) (apply :vector/e #:ordering 'diagonal args)) 65 | (define vec/e :vector/e) 66 | (define box-vec/e :vector/e) 67 | (define inf-fin-fair-list/e :list/e) 68 | ;; (define mixed-box-tuples/e :mixed-box-tuples/e) this one was strange and not what the docs said 69 | (define inf-fin-cons/e :cons/e) 70 | (define list/e :list/e) 71 | (define nested-cons-list/e :list/e) 72 | (define (cantor-list/e . args) (apply :list/e #:ordering 'diagonal args)) 73 | (define box-list/e :list/e) 74 | (define prime-length-box-list/e :list/e) 75 | (define box-tuples/e unsafe:box-tuples/e) 76 | (define bounded-list/e :bounded-list/e) 77 | (define nat+/e :nat+/e) 78 | ; (define fail/e :fail/e) ;; probably not used 79 | (define char/e :char/e) 80 | (define string/e :string/e) 81 | (define from-1/e (:nat+/e 1)) 82 | (define integer/e :integer/e) 83 | (define float/e :flonum/e) 84 | (define real/e :real/e) 85 | ;; (define non-real/e :non-real/e) ;; hopefully not used 86 | (define num/e :number/e) 87 | (define bool/e :bool/e) 88 | (define symbol/e :symbol/e) 89 | (define base/e (:or/e (:fin/e '()) 90 | (cons :two-way-number/e number?) 91 | :string/e 92 | :bool/e 93 | :symbol/e)) 94 | (define any/e (:delay/e 95 | (:or/e (cons base/e (λ (x) (not (pair? x)))) 96 | (cons (cons/e any/e any/e) pair?)) 97 | #:count +inf.0)) 98 | -------------------------------------------------------------------------------- /data-enumerate-lib/data/enumerate/lib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/bool 3 | racket/list 4 | racket/contract 5 | racket/math 6 | "../enumerate.rkt" 7 | "private/more.rkt" 8 | (prefix-in unsafe: "private/core.rkt")) 9 | 10 | (provide 11 | (all-from-out "../enumerate.rkt") 12 | cons/de 13 | char/e 14 | string/e 15 | integer/e 16 | flonum/e 17 | exact-rational/e 18 | real/e 19 | two-way-real/e 20 | number/e 21 | two-way-number/e 22 | bool/e 23 | symbol/e 24 | delay/e 25 | (contract-out 26 | [flip-dep/e unsafe:dep/e-contract] 27 | [random-index 28 | (-> enum? natural?)] 29 | [infinite-sequence/e 30 | (-> finite-enum? enum?)] 31 | [set/e 32 | (-> enum? enum?)] 33 | [permutations/e 34 | (-> list? enum?)] 35 | [permutations-of-n/e 36 | (-> natural? enum?)] 37 | [nat+/e (-> natural? enum?)] 38 | [fold-enum 39 | (->i ([f (f-range-finite?) 40 | (if (or (unsupplied-arg? f-range-finite?) 41 | (not f-range-finite?)) 42 | (-> list? any/c infinite-enum?) 43 | (-> list? any/c finite-enum?))] 44 | [l list?]) 45 | (#:f-range-finite? [f-range-finite? boolean?]) 46 | [result enum?])] 47 | 48 | [range/e 49 | (->i ([low (or/c exact-integer? -inf.0)] 50 | [high (or/c exact-integer? +inf.0)]) 51 | #:pre (low high) (<= low high) 52 | [res enum?])] 53 | [listof/e listof/e-contract] 54 | [non-empty-listof/e listof/e-contract] 55 | 56 | [listof-n/e (-> enum? natural? enum?)] 57 | [take/e 58 | (->i ([e enum?] 59 | [s (e) 60 | (if (finite-enum? e) 61 | (integer-in 0 (- (enum-count e) 1)) 62 | natural?)]) 63 | (#:contract [c contract?]) 64 | #:pre (c e) 65 | (implies (unsupplied-arg? c) 66 | (and (two-way-enum? e) 67 | (flat-contract? (enum-contract e)))) 68 | [result enum?])] 69 | [slice/e 70 | (->i ([e enum?] [lo natural?] [hi natural?]) 71 | (#:contract [c contract?]) 72 | #:pre (lo hi) (<= lo hi) 73 | #:pre (e hi) (or (infinite-enum? e) (hi . <= . (enum-count e))) 74 | #:pre (c e) 75 | (implies (unsupplied-arg? c) 76 | (and (two-way-enum? e) 77 | (flat-contract? (enum-contract e)))) 78 | [res enum?])] 79 | [hash-traverse/e 80 | (->* ((-> any/c enum?) 81 | hash?) 82 | (#:get-contract (-> any/c contract?) 83 | #:contract contract?) 84 | enum?)] 85 | [cons/e 86 | (->* (enum? enum?) 87 | (#:ordering (or/c 'diagonal 'square)) 88 | enum?)] 89 | [vector/e 90 | (->* () 91 | (#:ordering (or/c 'diagonal 'square)) 92 | #:rest (listof enum?) 93 | enum?)] 94 | [single/e 95 | (->* (any/c) 96 | (#:equal? (-> any/c any/c boolean?)) 97 | finite-enum?)] 98 | 99 | [fin/e 100 | (->i () 101 | #:rest 102 | [elements (listof any/c)] 103 | #:pre/name (elements) 104 | "no duplicate elements" 105 | (let () 106 | (define-values (nums non-nums) (partition number? elements)) 107 | (and (= (length (remove-duplicates nums =)) 108 | (length nums)) 109 | (= (length (remove-duplicates non-nums)) 110 | (length non-nums)))) 111 | [result enum?])] 112 | 113 | [but-not/e 114 | (->i ([big (and/c flat-enum? two-way-enum?)] 115 | [small (and/c finite-enum? flat-enum? two-way-enum?)]) 116 | #:pre/desc (big small) (appears-to-be-a-subset? small big) 117 | [result two-way-enum?])])) 118 | 119 | (define (appears-to-be-a-subset? small big) 120 | (let/ec k 121 | (cond 122 | [(zero? (enum-count small)) #t] 123 | [else 124 | (define ctc (enum-contract big)) 125 | (for ([_ (in-range 10)]) ;; check 10 elements of `small` 126 | (define index (random (min 1000 (enum-count small)))) 127 | (define ele (from-nat small index)) 128 | (unless (ctc ele) 129 | (k (list (format "index ~a in `small` produces:" index) 130 | (format " ~e" ele) 131 | " but that is not enumerated by `big`")))) 132 | #t]))) 133 | 134 | (define listof/e-contract 135 | (->i ([e (simple-recursive?) 136 | (if (or (unsupplied-arg? simple-recursive?) 137 | simple-recursive?) 138 | enum? 139 | infinite-enum?)]) 140 | (#:simple-recursive? [simple-recursive? any/c]) 141 | [res enum?])) 142 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/queue.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval (for-label racket data/queue)) 3 | @(define qeval (make-base-eval)) 4 | @(qeval '(require data/queue)) 5 | 6 | @title{Imperative Queues} 7 | 8 | @defmodule[data/queue] 9 | 10 | @author[@author+email["Carl Eastlund" "cce@racket-lang.org"]] 11 | 12 | This module provides a simple mutable queue representation, 13 | providing first-in/first-out semantics. 14 | 15 | Operations on queues mutate it in a thread-unsafe way. 16 | 17 | @defproc[(make-queue) queue?]{ 18 | Produces an empty queue. 19 | } 20 | 21 | @defproc[(enqueue! [q queue?] [v any/c]) void?]{ 22 | Adds an element to the back of a queue. 23 | 24 | This takes constant time, independent of the number 25 | of elements in @racket[q]. 26 | } 27 | 28 | @defproc[(enqueue-front! [q queue?] [v any/c]) void?]{ 29 | Adds an element to the front of a queue. 30 | 31 | This takes constant time, independent of the number 32 | of elements in @racket[q]. 33 | } 34 | 35 | @defproc[(dequeue! [q non-empty-queue?]) any/c]{ 36 | Removes an element from the front of a non-empty queue, and returns that 37 | element. 38 | 39 | This takes constant time, independent of the number 40 | of elements in @racket[q]. 41 | 42 | @defexamples[#:eval qeval 43 | (define q (make-queue)) 44 | (enqueue! q 1) 45 | (dequeue! q) 46 | (enqueue! q 2) 47 | (enqueue! q 3) 48 | (dequeue! q) 49 | (dequeue! q) 50 | (enqueue! q 2) 51 | (enqueue! q 1) 52 | (enqueue-front! q 3) 53 | (enqueue-front! q 4) 54 | (queue->list q)] 55 | } 56 | 57 | @defproc[(queue-filter! [q queue?] [pred? (-> any/c any/c)]) void?]{ 58 | Applies @racket[pred?] to each element of the queue, 59 | removing any where @racket[pred?] returns @racket[#f]. 60 | 61 | This takes time proportional to the number of elements in @racket[q] 62 | (assuming that @racket[pred?] takes constant time, independent 63 | of the number of elements in @racket[q]). It does not allocate and 64 | it calls @racket[pred?] exactly once for each element of @racket[q]. 65 | 66 | @defexamples[#:eval qeval 67 | (define q (make-queue)) 68 | (enqueue! q 1) 69 | (enqueue! q 2) 70 | (enqueue! q 3) 71 | (enqueue! q 4) 72 | (queue-filter! q even?) 73 | (queue->list q)] 74 | } 75 | 76 | @defproc[(queue->list [q queue?]) (listof any/c)]{ 77 | Returns an immutable list containing the elements of the queue 78 | in the order the elements were added. 79 | 80 | This takes time proportional to the number of elements in @racket[q]. 81 | 82 | @defexamples[#:eval qeval 83 | (define q (make-queue)) 84 | (enqueue! q 8) 85 | (enqueue! q 9) 86 | (enqueue! q 0) 87 | (queue->list q)] 88 | } 89 | 90 | @defproc[(queue-length [q queue?]) exact-nonnegative-integer?]{ 91 | Returns the number of elements in the queue. 92 | 93 | This takes constant time, independent of the number 94 | of elements in @racket[q]. 95 | 96 | @defexamples[#:eval qeval 97 | (define q (make-queue)) 98 | (queue-length q) 99 | (enqueue! q 5) 100 | (enqueue! q 12) 101 | (queue-length q) 102 | (dequeue! q) 103 | (queue-length q)] 104 | } 105 | 106 | @defproc[(queue-empty? [q queue?]) boolean?]{ 107 | Recognizes whether a queue is empty or not. 108 | 109 | This takes constant time, independent of the number 110 | of elements in @racket[q]. 111 | 112 | @defexamples[#:eval qeval 113 | (define q (make-queue)) 114 | (queue-empty? q) 115 | (enqueue! q 1) 116 | (queue-empty? q) 117 | (dequeue! q) 118 | (queue-empty? q)] 119 | } 120 | 121 | @defproc[(queue? [v any/c]) boolean?]{ 122 | This predicate recognizes queues. 123 | 124 | This takes constant time, independent of the 125 | size of the argument @racket[v]. 126 | 127 | @defexamples[#:eval qeval 128 | (queue? (make-queue)) 129 | (queue? 'not-a-queue)] 130 | } 131 | 132 | @defproc[(non-empty-queue? [v any/c]) boolean?]{ 133 | This predicate recognizes non-empty queues. 134 | 135 | This takes constant time, independent of the 136 | size of the argument @racket[v]. 137 | 138 | @defexamples[#:eval qeval 139 | (non-empty-queue? (let ([q (make-queue)]) 140 | (enqueue! q 1) 141 | q)) 142 | (non-empty-queue? (make-queue)) 143 | (non-empty-queue? 'not-a-queue)] 144 | } 145 | 146 | @defproc[(in-queue [q queue?]) 147 | sequence?]{ 148 | 149 | Returns a sequence whose elements are the elements of 150 | @racket[q]. 151 | } 152 | 153 | @deftogether[( 154 | @defthing[queue/c flat-contract?] 155 | @defthing[nonempty-queue/c flat-contract?] 156 | )]{ 157 | These are provided for backwards compatibility. They are 158 | identical to @racket[queue?] and @racket[non-empty-queue?], 159 | respectively. 160 | } 161 | 162 | @close-eval[qeval] 163 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/gvector.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label data/gvector 4 | racket/contract 5 | racket/dict 6 | racket/base 7 | racket/serialize)) 8 | 9 | @title[#:tag "gvector"]{Growable Vectors} 10 | 11 | @(define the-eval (make-base-eval)) 12 | @(the-eval '(require data/gvector)) 13 | @(the-eval '(require racket/dict)) 14 | 15 | @defmodule[data/gvector] 16 | 17 | @author[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] 18 | 19 | A growable vector (gvector) is a mutable sequence whose length can 20 | change over time. A gvector also acts as a dictionary (@racket[dict?] 21 | from @racketmodname[racket/dict]), where the keys are zero-based 22 | indexes and the values are the elements of the gvector. A gvector can 23 | be extended by adding an element to the end, and it can be shrunk by 24 | removing any element, although removal can take time linear in the 25 | number of elements in the gvector. 26 | 27 | Two gvectors are @racket[equal?] if they contain the same number of 28 | elements and if the contain equal elements at each index. 29 | 30 | Operations on gvectors are not thread-safe. 31 | 32 | Additionally, gvectors are serializable with the 33 | @racketmodname[racket/serialize] collection. 34 | 35 | @defproc[(make-gvector [#:capacity capacity exact-positive-integer? 10]) 36 | gvector?]{ 37 | 38 | Creates a new empty gvector with an initial capacity of 39 | @racket[capacity]. 40 | } 41 | 42 | @defproc[(gvector [elem any/c] ...) 43 | gvector?]{ 44 | 45 | Creates a new gvector containing each @racket[elem] in order. 46 | } 47 | 48 | @defproc[(gvector? [x any/c]) boolean?]{ 49 | 50 | Returns @racket[#t] if @racket[x] is a gvector, @racket[#f] otherwise. 51 | } 52 | 53 | @defproc[(gvector-ref [gv gvector?] 54 | [index exact-nonnegative-integer?] 55 | [default any/c (error ....)]) 56 | any/c]{ 57 | 58 | Returns the element at index @racket[index], if @racket[index] is less 59 | than @racket[(gvector-count gv)]. Otherwise, @racket[default] is 60 | invoked if it is a procedure, returned otherwise. 61 | } 62 | 63 | @defproc[(gvector-add! [gv gvector?] 64 | [value any/c] ...) 65 | void?]{ 66 | 67 | Adds each @racket[value] to the end of the gvector @racket[gv]. 68 | Takes (amortized) time proportional to the number of added @racket[value]s. 69 | } 70 | 71 | @defproc[(gvector-insert! [gv gvector] 72 | [index (and/c exact-nonnegative-integer? 73 | (vector [gv gvector?]) 116 | vector?]{ 117 | 118 | Returns a vector of length @racket[(gvector-count gv)] containing the 119 | elements of @racket[gv] in order. 120 | } 121 | 122 | @defproc[(vector->gvector [v vector?]) 123 | gvector?]{ 124 | Returns a gvector of length @racket[(vector-length v)] containing the 125 | elements of @racket[v] in order. 126 | } 127 | 128 | @defproc[(gvector->list [gv gvector?]) 129 | list?]{ 130 | 131 | Returns a list of length @racket[(gvector-count gv)] containing the 132 | elements of @racket[gv] in order. 133 | } 134 | 135 | @defproc[(list->gvector [l list?]) 136 | gvector?]{ 137 | Returns a gvector of length @racket[(length l)] containing the 138 | elements of @racket[l] in order. 139 | } 140 | 141 | @defproc[(in-gvector [gv gvector?]) 142 | sequence?]{ 143 | 144 | Returns a sequence whose elements are the elements of 145 | @racket[gv]. Mutation of @racket[gv] while the sequence is running 146 | changes the elements produced by the sequence. To obtain a sequence 147 | from a snapshot of @racket[gv], use @racket[(in-vector 148 | (gvector->vector gv))] instead. 149 | } 150 | 151 | @deftogether[[ 152 | @defform[(for/gvector (for-clause ...) body ...+)] 153 | @defform[(for*/gvector (for-clause ...) body ...+)]]]{ 154 | 155 | Analogous to @racket[for/list] and @racket[for*/list], but constructs 156 | a gvector instead of a list. 157 | 158 | Unlike @racket[for/list], the @racket[body] may return zero or 159 | multiple values; all returned values are added to the gvector, in 160 | order, on each iteration. 161 | } 162 | 163 | 164 | @close-eval[the-eval] 165 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/bit-vector.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label data/bit-vector 4 | racket/contract 5 | racket/dict 6 | racket/base) 7 | data/bit-vector) 8 | 9 | @title[#:tag "bit-vector"]{Bit Vectors} 10 | 11 | @(define the-eval (make-base-eval)) 12 | @(the-eval '(require data/bit-vector)) 13 | @(the-eval '(require racket/dict)) 14 | 15 | @defmodule[data/bit-vector] 16 | 17 | @author[@author+email["Jens Axel Søgaard" "soegaard@racket-lang.org"]] 18 | 19 | A @deftech{bit vector} is a mutable sequence whose elements 20 | are booleans. A bit vector also acts as a dictionary (@racket[dict?] 21 | from @racketmodname[racket/dict]), where the keys are zero-based 22 | indexes and the values are the elements of the bit-vector. A bit-vector 23 | has a fixed size. 24 | 25 | Two bit-vectors are @racket[equal?] if they contain the same number of 26 | elements and if they contain equal elements at each index. 27 | 28 | @defproc[(make-bit-vector [size exact-integer?] [fill boolean? #f]) 29 | bit-vector?]{ 30 | 31 | Creates a new bit-vector of size @racket[size]. All elements 32 | are initialized to @racket[fill]. 33 | 34 | @examples[#:eval the-eval 35 | (bit-vector-ref (make-bit-vector 3) 2) 36 | (bit-vector-ref (make-bit-vector 3 #t) 2) 37 | ] 38 | } 39 | 40 | @defproc[(bit-vector [elem boolean?] ...) 41 | bit-vector?]{ 42 | 43 | Creates a new bit-vector containing each @racket[elem] in order. 44 | 45 | @examples[#:eval the-eval 46 | (bit-vector-ref (bit-vector #f #t #f) 1) 47 | ] 48 | } 49 | 50 | @defproc[(bit-vector? [v any/c]) boolean?]{ 51 | 52 | Returns @racket[#t] if @racket[v] is a bit-vector, @racket[#f] otherwise. 53 | } 54 | 55 | @defproc[(bit-vector-ref [bv bit-vector?] 56 | [index exact-nonnegative-integer?] 57 | [default any/c (error ....)]) 58 | any/c]{ 59 | 60 | Returns the element at index @racket[index], if @racket[index] is less 61 | than @racket[(bit-vector-length bv)]. Otherwise, @racket[default] is 62 | invoked if it is a procedure, returned otherwise. 63 | 64 | @examples[#:eval the-eval 65 | (bit-vector-ref (bit-vector #f #t) 1) 66 | (bit-vector-ref (bit-vector #f #t) 5 'not-there) 67 | ] 68 | } 69 | 70 | @defproc[(bit-vector-set! 71 | [bv bit-vector?] 72 | [index (and/c exact-nonnegative-integer? 73 | (list 148 | (for/bit-vector ([i '(1 2 3)]) (odd? i))) 149 | (bit-vector->list 150 | (for/bit-vector #:length 2 ([i '(1 2 3)]) (odd? i))) 151 | (bit-vector->list 152 | (for/bit-vector #:length 4 ([i '(1 2 3)]) (odd? i))) 153 | (bit-vector->list 154 | (for/bit-vector #:length 4 #:fill #t ([i '(1 2 3)]) (odd? i))) 155 | ] 156 | 157 | The @racket[for/bit-vector] form may allocate a bit-vector and mutate it 158 | after each iteration of @racket[body], which means that capturing a 159 | continuation during @racket[body] and applying it multiple times may 160 | mutate a shared bit-vector.} 161 | 162 | @defform[(for*/bit-vector maybe-length (for-clause ...) 163 | body-or-break ... body)]{ 164 | 165 | Like @racket[for/bit-vector] but with the implicit nesting of @racket[for*]. 166 | } 167 | 168 | @deftogether[[ 169 | @defproc[(bit-vector->list [bv bit-vector?]) (listof boolean?)] 170 | @defproc[(list->bit-vector [bits (listof boolean?)]) bit-vector?] 171 | @defproc[(bit-vector->string [bv bit-vector?]) (and/c string? #rx"^[01]*$")] 172 | @defproc[(string->bit-vector [s (and/c string? #rx"^[01]*$")]) bit-vector?] 173 | ]]{ 174 | 175 | Converts between bit-vectors and their representations as lists and 176 | strings. 177 | 178 | @examples[#:eval the-eval 179 | (bit-vector->list (string->bit-vector "100111")) 180 | (bit-vector->string (list->bit-vector '(#t #f #t #t))) 181 | ] 182 | } 183 | 184 | @close-eval[the-eval] 185 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/integer-set.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval 4 | (for-label data/integer-set 5 | racket/contract 6 | (except-in racket/base 7 | foldr))) 8 | @(define (racket-tech pre) 9 | (tech #:doc '(lib "scribblings/reference/reference.scrbl") pre)) 10 | 11 | @title[#:tag "integer-set"]{Integer Sets} 12 | 13 | @(define the-eval (make-base-eval)) 14 | @(the-eval '(require data/integer-set)) 15 | 16 | @defmodule[data/integer-set] 17 | 18 | This library provides functions for 19 | working with finite sets of integers. This module is designed for 20 | sets that are compactly represented as groups of intervals, even when 21 | their cardinality is large. For example, the set of integers from 22 | @math{-1000000} to @math{1000000} except for @math{0}, can be represented as 23 | @math{{[-1000000, -1], [1, 1000000]}}. This data structure would not be 24 | a good choice for the set of all odd integers between @math{0} and 25 | @math{1000000}, which would be @math{{[1, 1], [3, 3], ... [999999, 26 | 999999]}}. 27 | 28 | In addition to the @defterm{integer set} abstract type, a 29 | @defterm{well-formed set} is a list of pairs of exact integers, where 30 | each pair represents a closed range of integers, and the entire set is 31 | the union of the ranges. The ranges must be disjoint and increasing. 32 | Further, adjacent ranges must have at least one integer between them. 33 | For example: @racket['((-1 . 2) (4 . 10))] is a well-formed-set as is 34 | @racket['((1 . 1) (3 . 3))], but @racket['((1 . 5) (6 . 7))], 35 | @racket['((1 . 5) (-3 . -1))], @racket['((5 . 1))], and @racket['((1 36 | . 5) (3 . 6))] are not. 37 | 38 | An integer set implements the @racket-tech{stream} and 39 | @racket-tech{sequence} generic interfaces. 40 | 41 | @examples[#:eval the-eval 42 | (for/list ([i (make-integer-set '((2 . 3) 43 | (5 . 6) 44 | (10 . 15)))]) 45 | i)] 46 | 47 | 48 | @defproc[(make-integer-set [wfs well-formed-set?]) integer-set?]{ 49 | 50 | Creates an integer set from a well-formed set.} 51 | 52 | 53 | @defproc[(integer-set-contents [s integer-set?]) well-formed-set?]{ 54 | 55 | Produces a well-formed set from an integer set.} 56 | 57 | 58 | @defproc[(set-integer-set-contents! [s integer-set?][wfs well-formed-set?]) void?]{ 59 | 60 | Mutates an integer set.} 61 | 62 | 63 | @defproc[(integer-set? [v any/c]) boolean?]{ 64 | 65 | Returns @racket[#t] if @racket[v] is an integer set, @racket[#f] 66 | otherwise.} 67 | 68 | @defproc[(well-formed-set? [v any/c]) boolean?]{ 69 | Recognizes @racket[(listof (cons/c exact-integer? exact-integer?))], 70 | where the result of @racket[(flatten v)] is sorted by 71 | @racket[<=], the elements of the pairs in the list 72 | are distinct (and thus strictly increasing), and the 73 | second element in a pair is at least one less than the 74 | first element of the subsequent pair. 75 | 76 | @examples[#:eval the-eval 77 | (well-formed-set? '((-1 . 2) (4 . 10))) 78 | (well-formed-set? '((1 . 1) (3 . 3))) 79 | (well-formed-set? '((1 . 5) (6 . 7))) 80 | (well-formed-set? '((1 . 5) (-3 . -1))) 81 | (well-formed-set? '((5 . 1))) 82 | (well-formed-set? '((1 . 5) (3 . 6)))] 83 | } 84 | 85 | @defproc*[([(make-range) integer-set?] 86 | [(make-range [elem exact-integer?]) integer-set?] 87 | [(make-range [start exact-integer?] 88 | [end exact-integer?]) integer-set?])]{ 89 | 90 | Produces, respectively, an empty integer set, an integer set 91 | containing only @racket[elem], or an integer set containing the 92 | integers from @racket[start] to @racket[end] inclusive, where 93 | @racket[(start . <= . end)].} 94 | 95 | 96 | @defproc[(intersect [x integer-set?][y integer-set?]) integer-set?]{ 97 | 98 | Returns the intersection of the given sets.} 99 | 100 | 101 | @defproc[(subtract [x integer-set?][y integer-set?]) integer-set?]{ 102 | 103 | Returns the difference of the given sets (i.e., elements in @racket[x] 104 | that are not in @racket[y]).} 105 | 106 | 107 | @defproc[(union [x integer-set?][y integer-set?]) integer-set?]{ 108 | 109 | Returns the union of the given sets.} 110 | 111 | 112 | @defproc[(split [x integer-set?][y integer-set?]) 113 | (values integer-set? integer-set? integer-set?)]{ 114 | 115 | Produces three values: the first is the intersection of @racket[x] and 116 | @racket[y], the second is the difference @racket[x] remove @racket[y], 117 | and the third is the difference @racket[y] remove @racket[x].} 118 | 119 | 120 | @defproc[(complement [s integer-set?] 121 | [start exact-integer?] 122 | [end exact-integer?]) integer-set?]{ 123 | 124 | Returns a set containing the elements between @racket[start] to 125 | @racket[end] inclusive that are not in @racket[s], where 126 | @racket[(start-k . <= . end-k)].} 127 | 128 | 129 | @defproc[(symmetric-difference [x integer-set?][y integer-set?]) integer-set?]{ 130 | 131 | Returns an integer set containing every member of @racket[x] 132 | and @racket[y] that is not in both sets.} 133 | 134 | 135 | @defproc[(member? [k exact-integer?][s integer-set?]) boolean?]{ 136 | 137 | Returns @racket[#t] if @racket[k] is in @racket[s], @racket[#f] 138 | otherwise.} 139 | 140 | 141 | @defproc[(get-integer [set integer-set?]) (or/c exact-integer? #f)]{ 142 | 143 | Returns a member of @racket[set], or @racket[#f] if @racket[set] is empty.} 144 | 145 | 146 | @defproc[(foldr [proc (exact-integer? any/c . -> . any/c)] 147 | [base-v any/c] 148 | [s integer-set?]) 149 | any/c]{ 150 | 151 | Applies @racket[proc] to each member of @racket[s] in ascending order, 152 | where the first argument to @racket[proc] is the set member, and the 153 | second argument is the fold result starting with @racket[base-v]. For 154 | example, @racket[(foldr cons null s)] returns a list of all the 155 | integers in @racket[s], sorted in increasing order.} 156 | 157 | 158 | @defproc[(partition [s (listof integer-set?)]) (listof integer-set?)]{ 159 | 160 | Returns the coarsest refinement of the sets in @racket[s] such that 161 | the sets in the result list are pairwise disjoint. For example, 162 | partitioning the sets that represent @racket['((1 . 2) (5 . 10))] and 163 | @racket['((2 . 2) (6 . 6) (12 . 12))] produces the a list containing 164 | the sets for @racket['((1 . 1) (5 . 5) (7 . 10))] @racket['((2 . 2) (6 165 | . 6))], and @racket['((12 . 12))].} 166 | 167 | 168 | @defproc[(count [s integer-set?]) exact-nonnegative-integer?]{ 169 | 170 | Returns the number of integers in the given integer set.} 171 | 172 | 173 | @defproc[(subset? [x integer-set?][y integer-set?]) boolean?]{ 174 | 175 | Returns true if every integer in @racket[x] is also in 176 | @racket[y], otherwise @racket[#f].} 177 | 178 | 179 | @close-eval[the-eval] 180 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/splay-tree.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label data/splay-tree 4 | data/order 5 | racket/contract 6 | racket/dict 7 | racket/base)) 8 | 9 | @title{Splay Trees} 10 | 11 | @(define the-eval (make-base-eval)) 12 | @(the-eval '(require racket/dict data/order data/splay-tree)) 13 | 14 | @defmodule[data/splay-tree] 15 | 16 | @author[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] 17 | 18 | Splay trees are an efficient data structure for mutable dictionaries 19 | with totally ordered keys. They were described in the paper 20 | ``Self-Adjusting Binary Search Trees'' by Daniel Sleator and Robert 21 | Tarjan in Journal of the ACM 32(3) pp652-686. 22 | 23 | A splay-tree is a ordered dictionary (@racket[dict?] and 24 | @racket[ordered-dict?]). 25 | 26 | Operations on splay-trees are not thread-safe. If a key in a 27 | splay-tree is mutated, the splay-tree's internal invariants may be 28 | violated, causing its behavior to become unpredictable. 29 | 30 | 31 | @defproc[(make-splay-tree [ord order? datum-order] 32 | [#:key-contract key-contract contract? any/c] 33 | [#:value-contract value-contract contract? any/c]) 34 | splay-tree?]{ 35 | 36 | Makes a new empty splay-tree. The splay tree uses @racket[ord] to 37 | order keys; in addition, the domain contract of @racket[ord] is 38 | combined with @racket[key-contract] to check keys. 39 | 40 | @examples[#:eval the-eval 41 | (define splay-tree 42 | (make-splay-tree (order 'string-order string? string=? string? [s splay-tree?] [key any/c]) 156 | (or/c #f splay-tree-iter?)] 157 | @defproc[(splay-tree-iterate-least/>=? [s splay-tree?] [key any/c]) 158 | (or/c #f splay-tree-iter?)] 159 | @defproc[(splay-tree-iterate-greatest/?], 167 | @racket[dict-iterate-least/>=?], @racket[dict-iterate-greatest/list [s splay-tree?]) (listof pair?)]{ 178 | 179 | Returns an association list with the keys and values of @racket[s], in 180 | order. 181 | } 182 | 183 | 184 | @close-eval[the-eval] 185 | -------------------------------------------------------------------------------- /data-test/tests/data/gvector.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require data/gvector 3 | racket/dict 4 | rackunit 5 | racket/serialize) 6 | 7 | (test-equal? "gvector" 8 | (gvector->vector (gvector 1 2 3)) 9 | '#(1 2 3)) 10 | 11 | (test-equal? "vector->gvector" 12 | (gvector->vector (vector->gvector #(1 2 3))) 13 | #(1 2 3)) 14 | 15 | (test-equal? "list->gvector" 16 | (gvector->vector (vector->gvector #(1 2 3))) 17 | #(1 2 3)) 18 | 19 | (test-equal? "gvector-add! (one)" 20 | (gvector->vector 21 | (let ([gv (make-gvector)]) 22 | (for ([x '(1 2 3)]) 23 | (gvector-add! gv x)) 24 | gv)) 25 | '#(1 2 3)) 26 | 27 | (test-equal? "gvector-add! (multi)" 28 | (gvector->vector 29 | (let ([gv (make-gvector)]) 30 | (gvector-add! gv 1 2 3) 31 | gv)) 32 | '#(1 2 3)) 33 | 34 | (test-equal? "gvector-add! (lots)" 35 | (let () 36 | (define g (gvector)) 37 | (apply gvector-add! g (build-list 11 values)) 38 | (gvector->vector g)) 39 | (for/vector ([i 11]) i)) 40 | 41 | (test-equal? "gvector-insert! (one)" 42 | (let () 43 | (define g (gvector 1 2 3 4 5 6 7 8 9 10)) 44 | (gvector-insert! g 5 10) 45 | (gvector->vector g)) 46 | #(1 2 3 4 5 10 6 7 8 9 10)) 47 | 48 | (test-equal? "gvector-insert (lots)" 49 | (let () 50 | (define g (gvector 1 2 3 4)) 51 | (for ([i (in-range 11)]) 52 | (gvector-insert! g (+ 2 i) i)) 53 | (gvector->vector g)) 54 | #(1 2 0 1 2 3 4 5 6 7 8 9 10 3 4)) 55 | 56 | (test-equal? "gvector-ref" 57 | (let ([gv (gvector 1 2 3)]) 58 | ;; 3 valid refs + 1 not-found 59 | (for/list ([index '(0 1 2 3)]) 60 | (gvector-ref gv index #f))) 61 | '(1 2 3 #f)) 62 | 63 | (test-equal? "gvector-set! (in range)" 64 | (let ([gv (gvector 1 2 3)]) 65 | (gvector-set! gv 1 'apple) 66 | (gvector->vector gv)) 67 | '#(1 apple 3)) 68 | 69 | (test-equal? "gvector-set! as add" 70 | (let ([gv (gvector 1 2 3)]) 71 | (gvector-set! gv 3 4) 72 | (gvector->vector gv)) 73 | '#(1 2 3 4)) 74 | 75 | (test-equal? "gvector-remove! at end" 76 | (let ([gv (gvector 1 2 3)]) 77 | (gvector-remove! gv 2) 78 | (gvector->vector gv)) 79 | '#(1 2)) 80 | 81 | (test-equal? "gvector-remove! at beginning" 82 | (let ([gv (gvector 1 2 3)]) 83 | (gvector-remove! gv 0) 84 | (gvector->vector gv)) 85 | '#(2 3)) 86 | 87 | (test-equal? "gvector-remove-last!" 88 | (let ([gv (gvector 1 2 3)]) 89 | (check-equal? (gvector-remove-last! gv) 3) 90 | (check-equal? (gvector-remove-last! gv) 2) 91 | (check-equal? (gvector-remove-last! gv) 1) 92 | (gvector->vector gv)) 93 | '#()) 94 | 95 | (test-equal? "gvector-add and gvector-remove-last!" 96 | (let ([gv (gvector)]) 97 | (gvector-add! gv 'rock) 98 | (gvector-add! gv 'paper) 99 | (check-equal? (gvector-remove-last! gv) 'paper) 100 | (gvector-add! gv 'scissor) 101 | (check-equal? (gvector-remove-last! gv) 'scissor) 102 | (check-equal? (gvector-remove-last! gv) 'rock) 103 | (gvector->vector gv)) 104 | '#()) 105 | 106 | (test-equal? "gvector-count" 107 | (gvector-count (gvector 1 2 3)) 108 | 3) 109 | 110 | (test-equal? "gvector-count / add" 111 | (let ([gv (gvector 1 2 3)]) 112 | (gvector-add! gv 4 5 6) 113 | (gvector-count gv)) 114 | 6) 115 | 116 | (test-equal? "in-gvector" 117 | (let ([gv (gvector 1 2 3)]) 118 | (for/list ([x (in-gvector gv)]) x)) 119 | '(1 2 3)) 120 | 121 | (test-equal? "in-gvector expression form" 122 | (let* ([gv (gvector 1 2 3)] 123 | [gv-sequence (in-gvector gv)]) 124 | (for/list ([x gv-sequence]) x)) 125 | '(1 2 3)) 126 | 127 | (test-equal? "gvector as sequence" 128 | (let ([gv (gvector 1 2 3)]) 129 | (for/list ([x gv]) x)) 130 | '(1 2 3)) 131 | 132 | (test-equal? "for/gvector" 133 | (gvector->vector (for/gvector ([x '(1 2 3)]) x)) 134 | '#(1 2 3)) 135 | 136 | (test-case "gvector, lots of adds" 137 | (let ([gv (make-gvector)]) 138 | (for ([x (in-range 0 1000)]) 139 | (gvector-add! gv x)) 140 | (for ([x (in-range 0 1000)]) 141 | (check-equal? (gvector-ref gv x) x)) 142 | (check-equal? (gvector-count gv) 1000))) 143 | 144 | (test-equal? "gvector, dict-map" 145 | (dict-map (gvector 1 2 3) list) 146 | '((0 1) (1 2) (2 3))) 147 | (test-equal? "gvector, dict-ref" 148 | (dict-ref (gvector 1 2 3) 0) 149 | 1) 150 | 151 | (test-equal? "gvector, dict-ref out of range" 152 | (dict-ref (gvector 1 2 3) 5 #f) 153 | #f) 154 | 155 | (test-equal? "gvector, equals, empty" 156 | (gvector) 157 | (make-gvector #:capacity 50)) 158 | 159 | (test-case "gvector, equals" 160 | (let ([g1 (make-gvector)] 161 | [g2 (make-gvector)]) 162 | (for ([x (in-range 1000)]) 163 | (check-equal? g1 g2) 164 | (check-equal? (equal-hash-code g1) (equal-hash-code g2)) 165 | (gvector-add! g1 x) 166 | (gvector-add! g2 x)))) 167 | 168 | (test-case "gvector, equals, w cycles" 169 | (let ([g1 (make-gvector)] 170 | [g2 (make-gvector)]) 171 | (for ([x (in-range 10)]) 172 | (check-equal? g1 g2) 173 | (check-equal? (equal-hash-code g1) (equal-hash-code g2)) 174 | (gvector-add! g1 (if (zero? (modulo x 2)) g1 g2)) 175 | (gvector-add! g2 (if (zero? (modulo x 3)) g1 g2))))) 176 | 177 | (test-case "gvector, not equal, same length" 178 | (check-not-equal? (gvector 1) (gvector 2))) 179 | 180 | (test-case "gvector, not equal, extension" 181 | (check-not-equal? (gvector 1) (gvector 1 2))) 182 | 183 | (test-case "gvector on large list" 184 | (let ([g (apply gvector (for/list ([i 100]) i))]) 185 | (check-pred gvector? g) 186 | (for ([i 100]) 187 | (check-equal? (gvector-ref g i) i)))) 188 | 189 | (test-case "gvector remove all, shrinks" 190 | (let ([g (make-gvector)]) 191 | (for ([i 100]) (gvector-add! g i)) 192 | (for ([i 100]) 193 | (gvector-remove-last! g)) 194 | (check-equal? g (gvector)))) 195 | 196 | (test-equal? "gvector serialize" 197 | (gvector->vector (deserialize (serialize (gvector 1 2 3)))) 198 | #(1 2 3)) 199 | 200 | (test-case "serialize non-atomic data" 201 | (let () 202 | (define x (box #f)) 203 | (define y (box #f)) 204 | (define the-vec (deserialize (serialize (gvector x x y)))) 205 | (check-eq? (gvector-ref the-vec 0) 206 | (gvector-ref the-vec 1)) 207 | (check-not-eq? (gvector-ref the-vec 0) 208 | (gvector-ref the-vec 2)))) 209 | 210 | (test-case "serialize-cycles" 211 | (let () 212 | (define vec (make-gvector)) 213 | (define other-vec (make-gvector)) 214 | (gvector-add! vec vec) 215 | (gvector-add! vec other-vec) 216 | (deserialize (serialize vec)) 217 | (check-eq? vec (gvector-ref vec 0)) 218 | (check-not-eq? vec (gvector-ref vec 1)))) 219 | -------------------------------------------------------------------------------- /data-test/tests/data/queue.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit rackunit/text-ui 4 | data/queue 5 | racket/stream) 6 | 7 | (run-tests 8 | (test-suite "queue.rkt" 9 | (test-suite "queue-empty?" 10 | (test-case "make-queue" 11 | (check-true (queue-empty? (make-queue)))) 12 | (test-case "enqueue! once" 13 | (let* ([q (make-queue)]) 14 | (enqueue! q 1) 15 | (check-false (queue-empty? q)))) 16 | (test-case "enqueue! once / dequeue! once" 17 | (let* ([q (make-queue)]) 18 | (enqueue! q 1) 19 | (dequeue! q) 20 | (check-true (queue-empty? q)))) 21 | (test-case "enqueue! twice" 22 | (let* ([q (make-queue)]) 23 | (enqueue! q 1) 24 | (enqueue! q 2) 25 | (check-false (queue-empty? q)))) 26 | (test-case "enqueue! twice / dequeue! once" 27 | (let* ([q (make-queue)]) 28 | (enqueue! q 1) 29 | (enqueue! q 2) 30 | (dequeue! q) 31 | (check-false (queue-empty? q)))) 32 | (test-case "enqueue! twice / dequeue! twice" 33 | (let* ([q (make-queue)]) 34 | (enqueue! q 1) 35 | (enqueue! q 2) 36 | (dequeue! q) 37 | (dequeue! q) 38 | (check-true (queue-empty? q))))) 39 | (test-suite "length" 40 | (test-case "length empty" 41 | (let* ([queue (make-queue)]) 42 | (check-equal? (queue-length queue) 0))) 43 | (test-case "length enqueue once" 44 | (let* ([queue (make-queue)]) 45 | (enqueue! queue 5) 46 | (check-equal? (queue-length queue) 1))) 47 | (test-case "length enqueue thrice dequeue once" 48 | (let* ([queue (make-queue)]) 49 | (enqueue! queue 5) 50 | (enqueue! queue 9) 51 | (enqueue! queue 12) 52 | (dequeue! queue) 53 | (check-equal? (queue-length queue) 2)))) 54 | (test-suite "dequeue!" 55 | (test-case "make-queue" 56 | (check-exn exn:fail? (lambda () (dequeue! (make-queue))))) 57 | (test-case "enqueue! once" 58 | (let* ([q (make-queue)]) 59 | (enqueue! q 1) 60 | (check-equal? (dequeue! q) 1) 61 | (check-exn exn:fail? (lambda () (dequeue! q))))) 62 | (test-case "enqueue! twice" 63 | (let* ([q (make-queue)]) 64 | (enqueue! q 1) 65 | (enqueue! q 2) 66 | (check-equal? (dequeue! q) 1) 67 | (check-equal? (dequeue! q) 2) 68 | (check-exn exn:fail? (lambda () (dequeue! q))))) 69 | (test-case "don't leak last element" 70 | (let* ([thing (box 'box-that-queue-should-not-hold-onto)] 71 | [wb (make-weak-box thing)] 72 | [q (make-queue)]) 73 | (enqueue! q thing) 74 | (set! thing #f) 75 | (dequeue! q) 76 | (collect-garbage) 77 | (check-false (weak-box-value wb)) 78 | ;; need a reference to 'q' after looking in the 79 | ;; box or else the whole queue gets collected 80 | (check-true (queue? q))))) 81 | (test-suite "queue misc" 82 | (test-case "queue as a sequence" 83 | (let ([queue (make-queue)]) 84 | (enqueue! queue 1) 85 | (enqueue! queue 2) 86 | (enqueue! queue 3) 87 | (check-equal? '(1 2 3) (for/list ([item (in-queue queue)]) item))) 88 | (check-equal? '() (for/list ([item (in-queue (make-queue))]) item))) 89 | (test-case "queue to empty list" 90 | (let ([queue (make-queue)]) 91 | (check-equal? (queue->list queue) '()))) 92 | (test-case "queue length" 93 | (let ([queue (make-queue)]) 94 | (enqueue! queue 1) 95 | (enqueue! queue 2) 96 | (enqueue! queue 3) 97 | (check-equal? (queue->list queue) '(1 2 3))))))) 98 | 99 | ;; try 1000 random tests 100 | (for ([x (in-range 1000)]) 101 | (define lst '()) 102 | (define deq (make-queue)) 103 | (define ops '()) 104 | 105 | ;; try 30 random ops per test 106 | (for ([op-number (in-range 30)]) 107 | 108 | (case (random 5) 109 | [(0) 110 | (define ele (random 100000)) 111 | (set! lst (cons ele lst)) 112 | (enqueue-front! deq ele) 113 | (set! ops (cons `(add-front ,ele) ops))] 114 | [(1) 115 | (define ele (random 100000)) 116 | (set! lst (reverse (cons ele (reverse lst)))) 117 | (enqueue! deq ele) 118 | (set! ops (cons `(add-back ,ele) ops))] 119 | [(2) 120 | (unless (null? lst) 121 | (dequeue! deq) 122 | (set! lst (cdr lst)) 123 | (set! ops (cons `(pop) ops)))] 124 | [(3) 125 | (set! lst (filter even? lst)) 126 | (queue-filter! deq even?) 127 | (set! ops (cons `(filter even?) ops))] 128 | [(4) 129 | (set! lst (filter odd? lst)) 130 | (queue-filter! deq odd?) 131 | (set! ops (cons `(filter odd?) ops))]) 132 | 133 | ;; check to make sure the list 134 | ;; and queue version match up 135 | ;; after each of the ops 136 | (define qlst (queue->list deq)) 137 | (unless (equal? lst qlst) 138 | (error 'queue.rkt 139 | "test failure, elements different: ~s\n => ~s (queue)\n => ~s (list)" 140 | ops 141 | qlst lst)) 142 | (unless (= (length lst) (queue-length deq)) 143 | (error 'queue.rkt 144 | "test failure, lengths different: ~s\n => ~s (queue)\n => ~s (list)" 145 | ops 146 | (length lst) (queue-length deq))))) 147 | -------------------------------------------------------------------------------- /data-test/tests/data/bit-vector.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require data/bit-vector 3 | racket/dict 4 | rackunit 5 | racket/set) 6 | 7 | (define (bit-vector->vector bv) 8 | (for/vector ([b (in-bit-vector bv)]) 9 | b)) 10 | 11 | (test-equal? "bit-vector" 12 | (bit-vector->vector (bit-vector #t #f #t)) 13 | '#(#t #f #t)) 14 | 15 | (test-equal? "make-bit-vector" 16 | (make-bit-vector 3) 17 | (bit-vector #f #f #f)) 18 | 19 | (test-equal? "make-bit-vector" 20 | (make-bit-vector 3 #t) 21 | (bit-vector #t #t #t)) 22 | 23 | (test-equal? "bit-vector-ref" 24 | (let ([bv (bit-vector #t #f #t)]) 25 | ;; 3 valid refs + 1 not-found 26 | (for/list ([index '(0 1 2)]) 27 | (bit-vector-ref bv index))) 28 | '(#t #f #t)) 29 | 30 | (test-equal? "bit-vector-set!" 31 | (let ([bv (bit-vector #t #t #t)]) 32 | (bit-vector-set! bv 1 #f) 33 | (bit-vector->vector bv)) 34 | '#(#t #f #t)) 35 | 36 | (test-equal? "bit-vector-length" 37 | (bit-vector-length (bit-vector #t #f #t)) 38 | 3) 39 | 40 | (test-equal? "in-bit-vector" 41 | (let ([bv (bit-vector #t #f #t)]) 42 | (for/list ([x (in-bit-vector bv)]) x)) 43 | '(#t #f #t)) 44 | 45 | (test-equal? "in-bit-vector expression form" 46 | (let* ([bv (bit-vector #t #f #t)] 47 | [bv-sequence (in-bit-vector bv)]) 48 | (for/list ([x bv-sequence]) x)) 49 | '(#t #f #t)) 50 | 51 | (test-equal? "bit-vector as sequence" 52 | (let ([bv (bit-vector #t #f #t)]) 53 | (for/list ([x bv]) x)) 54 | '(#t #f #t)) 55 | 56 | (test-case "bitvector, lots of sets" 57 | (let ([bv (make-bit-vector 1000)]) 58 | (for ([i (in-range 0 1000)]) 59 | (bit-vector-set! bv i (odd? i))) 60 | (for ([i (in-range 0 1000)]) 61 | (check-equal? (bit-vector-ref bv i) (odd? i))))) 62 | 63 | (test-equal? "bit-vector, dict-map" 64 | (dict-map (bit-vector #t #f #t) list) 65 | '((0 #t) (1 #f) (2 #t))) 66 | 67 | (test-equal? "bit-vector, dict-ref" 68 | (dict-ref (bit-vector #t #f #t) 0) 69 | #t) 70 | 71 | (test-equal? "bit-vector, dict-ref out of range" 72 | (dict-ref (bit-vector #t #f #t) 5 'not-found) 73 | 'not-found) 74 | 75 | (test-case "bit-vector-copy" 76 | (let ([bv (bit-vector #t #f #t #f #t)]) 77 | (check-equal? (bit-vector-copy bv) bv))) 78 | 79 | (test-case "bit-vector, hash-equal" 80 | (check-equal? 81 | (equal-hash-code (bit-vector #t #f #t #f #t)) 82 | (equal-hash-code (bit-vector #t #f #t #f #t)))) 83 | 84 | (test-case "bit-vector, hash-eq" 85 | (check-equal? 86 | (= (eq-hash-code (bit-vector #t #f #t #f #t)) 87 | (eq-hash-code (bit-vector #t #f #t #f #t))) 88 | #f)) 89 | 90 | (test-case "bit-vector, equal-proc (via equal?)" 91 | ;; Zero length bit-vectors are equal... 92 | (equal? (make-bit-vector 0 #t) 93 | (make-bit-vector 0 #t)) 94 | ;; ...even if fill value differed, because it's N/A 95 | (equal? (make-bit-vector 0 #t) 96 | (make-bit-vector 0 #f)) 97 | ;; Check a range of bit lengths spanning a few 8-bit bytes: 98 | (for ([len (in-range 1 24)]) 99 | (check-equal? 100 | (equal? (make-bit-vector len #t) 101 | (make-bit-vector len #t)) 102 | #t) 103 | (check-equal? 104 | (equal? (make-bit-vector len #t) 105 | (make-bit-vector len #f)) 106 | #f)) 107 | ;; Attempt to flush out potential bugs wrt to unused bits 108 | ;; that might be set by a "fill" value (implementation 109 | ;; detail we don't know for sure here), but should 110 | ;; definitely be ignored by equal?. 111 | (let ([x (make-bit-vector 1 #t)] ;#t fill value 112 | [y (make-bit-vector 1 #f)]) ;#f fill value 113 | ;; Set the only bit to #t in both 114 | (bit-vector-set! x 0 #t) 115 | (bit-vector-set! y 0 #t) 116 | ;; Should be equal, regardless of different fill values 117 | ;; in make-bit-vector: 118 | (check-equal? (equal? x y) #t))) 119 | 120 | (test-case "for/bit-vector" 121 | (check-equal? (for/bit-vector ([i 5]) (odd? i)) 122 | (bit-vector #f #t #f #t #f)) 123 | (check-equal? (for/bit-vector #:length 4 ([i 2]) (odd? i)) 124 | (bit-vector #f #t #f #f)) 125 | (check-equal? (for/bit-vector #:length 4 #:fill #t ([i 2]) (odd? i)) 126 | (bit-vector #f #t #t #t)) 127 | (let ([bv (make-bit-vector 1000)]) 128 | (bit-vector-set! bv 400 #t) 129 | (check-equal? bv (for/bit-vector ([i 1000]) (= i 400))))) 130 | 131 | (test-case "bit-vector-popcount" 132 | (let () 133 | (define (test len) 134 | (define fill (odd? (random 2))) 135 | (define bv (make-bit-vector len fill)) 136 | (define ns (list->set (build-list 100 (λ (_) (random len))))) 137 | (for ([n (in-set ns)]) (bit-vector-set! bv n (not fill))) 138 | (define count 139 | (if fill (- len (set-count ns)) (set-count ns))) 140 | (check-equal? (bit-vector-popcount bv) count)) 141 | (for ([i (in-range 100)]) 142 | (test 1000)) 143 | ;; test multiples of possible word sizes 144 | (for ([ws (in-list '(8 30 62))]) 145 | (for ([i (in-range 10)]) 146 | (test (* ws 10)))))) 147 | 148 | (test-case "bit-vector string->list" 149 | (let ([bitstrings '("0" "1" "10" "11" "1010110011100011110000")]) 150 | (for ([s (in-list bitstrings)]) 151 | (check-equal? (bit-vector->string (string->bit-vector s)) s) 152 | (let ([bitlist (for/list ([c (in-string s)]) (eqv? c #\1))]) 153 | (check-equal? (bit-vector->list (string->bit-vector s)) 154 | bitlist) 155 | (check-equal? (string->bit-vector s) 156 | (list->bit-vector bitlist)))))) 157 | 158 | (test-case "bit-vector-set! error" 159 | (define bv (bit-vector #f #f #f)) 160 | 161 | (check-exn #rx"index is out of range" 162 | (λ () (bit-vector-set! bv 4 #t))) 163 | 164 | (check-exn #rx"expected: natural\\?" 165 | (λ () (bit-vector-set! bv -1 #t))) 166 | 167 | (check-exn #rx"expected: bit-vector\\?" 168 | (λ () (bit-vector-set! 1 0 #t)))) 169 | 170 | (test-case "bit-vector-ref error" 171 | (define bv (bit-vector #f #f #f)) 172 | 173 | (check-exn #rx"index is out of range" 174 | (λ () (bit-vector-ref bv 4))) 175 | 176 | (check-exn #rx"expected: natural\\?" 177 | (λ () (bit-vector-ref bv -1))) 178 | 179 | (check-exn #rx"expected: bit-vector\\?" 180 | (λ () (bit-vector-ref 1 0)))) 181 | 182 | ;; Check equality for 2 vector with the same bits, one initiliazed with #f, the other with #t 183 | (test-case "bit-vector #f #t" 184 | (for* ([n (in-range 17)] 185 | [i (in-range n)]) 186 | (define bv1 (make-bit-vector n #false)) 187 | (define bv2 (make-bit-vector n #true)) 188 | (bit-vector-set! bv1 i #true) 189 | (for ([j (in-range n)] #:unless (= i j)) 190 | (bit-vector-set! bv2 j #false)) 191 | (check-equal? bv1 bv2)) 192 | ) -------------------------------------------------------------------------------- /data-test/tests/data/heap.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require rackunit 3 | data/heap 4 | (submod data/heap test-util)) 5 | 6 | ;; Check growth rate of the vectors 7 | (for ([n (in-range 10000)]) 8 | (check <= n (fittest-block-size n)) 9 | (check <= (fittest-block-size n) (max MIN-SIZE (* 2 n)))) 10 | 11 | (define (mkheap) (vector->heap <= (vector 6 2 4 10 8))) 12 | 13 | (test-equal? "heap->vector" 14 | (heap->vector (mkheap)) 15 | '#(2 4 6 8 10)) 16 | 17 | (test-equal? "heap-add! min" 18 | (let ([h (mkheap)]) 19 | (heap-add! h 0) 20 | (heap->vector h)) 21 | '#(0 2 4 6 8 10)) 22 | 23 | (test-equal? "heap-add! mid" 24 | (let ([h (mkheap)]) 25 | (heap-add! h 5) 26 | (heap->vector h)) 27 | '#(2 4 5 6 8 10)) 28 | 29 | (test-equal? "heap-add! multi" 30 | (let ([h (mkheap)]) 31 | (heap-add! h 0 5 12) 32 | (heap->vector h)) 33 | '#(0 2 4 5 6 8 10 12)) 34 | 35 | (test-equal? "heap-remove-min!" 36 | (let ([h (mkheap)]) 37 | (heap-remove-min! h) 38 | (heap->vector h)) 39 | '#(4 6 8 10)) 40 | 41 | (test-equal? "heap-remove!" 42 | (let ([h (mkheap)]) 43 | (heap-remove! h 4) 44 | (heap->vector h)) 45 | '#(2 6 8 10)) 46 | 47 | (test-equal? "heap-remove-eq!" 48 | (let () 49 | (struct node (val)) 50 | (define (node<=? a b) (<= (node-val a) (node-val b))) 51 | (define h (make-heap node<=?)) 52 | (define nds (map node '(6 2 4 10 8))) 53 | (heap-add-all! h nds) 54 | (list 55 | (heap-remove-eq! h (node 6)) 56 | (vector-map node-val (heap->vector h)) ; does not exist 57 | (heap-remove-eq! h (third nds)) 58 | (vector-map node-val (heap->vector h)) ; remove once 59 | (heap-remove-eq! h (third nds)) 60 | (vector-map node-val (heap->vector h)) ; remove twice 61 | (heap-remove-eq! h (first nds)) 62 | (vector-map node-val (heap->vector h)))) 63 | '(#f #(2 4 6 8 10) #t #(2 6 8 10) #f #(2 6 8 10) #t #(2 8 10))) 64 | 65 | (define (rand-test range count1 count2 count3) 66 | (let ([h (make-heap <=)] 67 | [xs null]) ;; mutated 68 | (define (fill! count) 69 | (for ([i (in-range count)]) 70 | (let ([x (random range)]) 71 | (heap-add! h x) 72 | (set! xs (cons x xs)))) 73 | (set! xs (sort xs <))) 74 | 75 | (fill! count1) 76 | 77 | ;; check equal (non-destructive) 78 | (check-equal? (vector->list (heap->vector h)) 79 | xs) 80 | 81 | (for ([i (in-range count2)]) 82 | (let ([xl (car xs)] 83 | [xh (heap-min h)]) 84 | (set! xs (cdr xs)) 85 | (heap-remove-min! h))) 86 | 87 | (fill! count3) 88 | 89 | (for ([x (in-list xs)]) 90 | (check-equal? (heap-min h) x) 91 | (heap-remove-min! h)) 92 | 93 | (check-equal? (heap-count h) 0))) 94 | 95 | (test-case "heap random sparse" 96 | (rand-test 1000 100 50 100)) 97 | 98 | (test-case "heap random dense" 99 | (rand-test 20 100 50 100)) 100 | 101 | (test-equal? "in-heap" 102 | (for/list ([x (in-heap (mkheap))]) x) 103 | '(2 4 6 8 10)) 104 | (test-equal? "post in-heap count" 105 | (let* ([h (mkheap)] 106 | [lst (for/list ([x (in-heap h)]) x)]) 107 | (heap-count h)) 108 | (heap-count (mkheap))) 109 | (test-equal? "in-heap/consume!" 110 | (for/list ([x (in-heap/consume! (mkheap))]) x) 111 | '(2 4 6 8 10)) 112 | (test-equal? "post in-heap/consume! count" 113 | (let* ([h (mkheap)] 114 | [lst (for/list ([x (in-heap/consume! h)]) x)]) 115 | (heap-count h)) 116 | 0) 117 | 118 | (test-equal? "heap-sort" 119 | (let ([v (vector 3 4 2 5 1)]) 120 | (heap-sort! v <=) 121 | v) 122 | '#(1 2 3 4 5)) 123 | 124 | (test-equal? "heap-sort (old arg order)" 125 | (let ([v (vector 3 4 2 5 1)]) 126 | (heap-sort! <= v) 127 | v) 128 | '#(1 2 3 4 5)) 129 | 130 | (let* ([l (for/list ([i 1000]) (random 1000))] 131 | [v (list->vector l)]) 132 | (test-equal? "heap-sort (random)" 133 | (begin (heap-sort! v <=) (vector->list v)) 134 | (sort l <))) 135 | 136 | (define (heap-add!/v h v) 137 | (heap-add! h v) 138 | (unless (valid-heap? h) (error 'heap-add!/v "failed"))) 139 | (define (heap-remove!/v h v) 140 | (heap-remove! h v) 141 | (unless (valid-heap? h) (error 'heap-remove!/v "post failed"))) 142 | (define (heap-remove-min!/v h) 143 | (heap-remove-min! h) 144 | (unless (valid-heap? h) (error 'heap-remove-min!/v "post failed"))) 145 | 146 | ;; test case from PR14651 147 | (let ([h (make-heap <=)]) 148 | (heap-add!/v h 0) 149 | (heap-add!/v h -5942) 150 | (heap-add!/v h 8358) 151 | (heap-add!/v h 569) 152 | (heap-add!/v h 6723) 153 | (heap-add!/v h -151) 154 | (heap-add!/v h 6807) 155 | (heap-add!/v h -1612) 156 | (heap-remove-min!/v h) 157 | (heap-add!/v h -1008) 158 | (heap-add!/v h -7157) 159 | (heap-add!/v h -1734) 160 | (heap-add!/v h 6497) 161 | (heap-add!/v h 1603) 162 | (heap-add!/v h -7927) 163 | (heap-remove!/v h -151) 164 | (heap-add!/v h -349) 165 | (heap-add!/v h -7570) 166 | (heap-remove-min!/v h) 167 | (heap-add!/v h 4008) 168 | (heap-add!/v h 6101) 169 | (heap-add!/v h -9013) 170 | (heap-add!/v h -3447) 171 | (heap-add!/v h -4294) 172 | (heap-add!/v h 8187) 173 | (heap-add!/v h 1465) 174 | (heap-remove-min!/v h) 175 | (heap-add!/v h -1598) 176 | (heap-add!/v h 9730) 177 | (heap-add!/v h -4429) 178 | (heap-add!/v h -846) 179 | (heap-add!/v h 4775) 180 | (heap-add!/v h 3609) 181 | (heap-add!/v h -3881) 182 | (heap-add!/v h 6167) 183 | (heap-add!/v h 6767) 184 | (heap-remove-min!/v h) 185 | (heap-add!/v h 2842) 186 | (heap-add!/v h -4103) 187 | (heap-add!/v h 154) 188 | (heap-add!/v h 3748) 189 | (heap-add!/v h -536) 190 | (heap-add!/v h -5565) 191 | (heap-add!/v h 4970) 192 | (heap-add!/v h 4775) 193 | (heap-add!/v h 4818) 194 | (heap-add!/v h 5124) 195 | (heap-add!/v h -8657) 196 | (heap-add!/v h -6842) 197 | (heap-remove-min!/v h) 198 | (heap-add!/v h 2480) 199 | (heap-add!/v h 8878) 200 | (heap-add!/v h -1806) 201 | (heap-remove-min!/v h) 202 | (heap-add!/v h -8205) 203 | (heap-remove!/v h 9730) 204 | (heap-add!/v h -3164) 205 | (heap-add!/v h 1589) 206 | (heap-add!/v h 8444) 207 | (heap-add!/v h -7839) 208 | (heap-add!/v h -3810) 209 | (heap-remove!/v h 4970) 210 | ; -1612 out of position 211 | (void)) 212 | 213 | ;; simpler test case from PR14651 214 | (let ([heap (make-heap <=)]) 215 | (heap-add!/v heap 43) 216 | (heap-add!/v heap 1) 217 | (heap-add!/v heap 37) 218 | (heap-add!/v heap 81) 219 | (heap-add!/v heap 94) 220 | (heap-add!/v heap 4) 221 | (heap-remove!/v heap 94)) 222 | 223 | (define (random-test) 224 | (define heap (make-heap <=)) 225 | (let loop ([ops '()] 226 | [values '()]) 227 | (cond 228 | [(not (valid-heap? heap)) 229 | (eprintf "crash! ~a ops\n" (length ops)) 230 | (pretty-write `(let ([heap (make-heap <=)]) ,@(reverse ops)) 231 | (current-error-port))] 232 | [(= (length ops) 50) 233 | (void)] 234 | [else 235 | (define (do-an-add) 236 | (define n (random 10)) 237 | (heap-add! heap n) 238 | (loop (cons `(heap-add!/v heap ,n) ops) 239 | (cons n values))) 240 | (case (random 3) 241 | [(0) (do-an-add)] 242 | [(1) 243 | (cond 244 | [(null? values) 245 | (do-an-add)] 246 | [else 247 | (define to-remove (list-ref values (random (length values)))) 248 | (heap-remove! heap to-remove) 249 | (loop (cons `(heap-remove!/v heap ,to-remove) ops) 250 | (remove to-remove values))])] 251 | [(2) 252 | (cond 253 | [(null? values) 254 | (do-an-add)] 255 | [else 256 | (heap-remove-min! heap) 257 | (define smallest (apply min values)) 258 | (loop (cons `(heap-remove-min!/v heap) ops) 259 | (remove smallest values))])])]))) 260 | 261 | (for ([x (in-range 10000)]) 262 | (random-test)) 263 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/heap.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/example 3 | (for-label data/heap 4 | racket/contract 5 | racket/base)) 6 | 7 | @title{Binary Heaps} 8 | 9 | @(define the-eval (make-base-eval)) 10 | @(the-eval '(require data/heap)) 11 | 12 | @defmodule[data/heap] 13 | 14 | @author[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] 15 | 16 | Binary heaps are a simple implementation of priority queues. 17 | For a heap of n elements, @racket[heap-add!] and @racket[heap-remove-min!] take O(log n) time 18 | per added or removed element, 19 | while @racket[heap-min] and @racket[heap-count] take constant time; 20 | @racket[heap-remove!] takes O(n) time, and @racket[heap-remove-eq!] takes O(log n) time 21 | on average; 22 | @racket[heap-sort!] takes O(n log n) time. 23 | 24 | 25 | Operations on binary heaps are not thread-safe. 26 | 27 | All functions are also provided by @racket[data/heap/unsafe] without contracts. 28 | 29 | @defproc[(make-heap [<=? (-> any/c any/c any/c)]) 30 | heap?]{ 31 | 32 | Makes a new empty heap using @racket[<=?] to order elements. 33 | 34 | @examples[#:eval the-eval 35 | (define a-heap-of-strings (make-heap string<=?)) 36 | a-heap-of-strings 37 | @code:comment{With structs:} 38 | (struct node (name val)) 39 | (define (node<=? x y) 40 | (<= (node-val x) (node-val y))) 41 | (define a-heap-of-nodes (make-heap node<=?)) 42 | a-heap-of-nodes] 43 | } 44 | 45 | @defproc[(heap? [x any/c]) boolean?]{ 46 | 47 | Returns @racket[#t] if @racket[x] is a heap, @racket[#f] otherwise. 48 | 49 | @examples[#:eval the-eval 50 | (heap? (make-heap <=)) 51 | (heap? "I am not a heap")] 52 | } 53 | 54 | @defproc[(heap-count [h heap?]) exact-nonnegative-integer?]{ 55 | 56 | Returns the number of elements in the heap. 57 | @examples[#:eval the-eval 58 | (define a-heap (make-heap <=)) 59 | (heap-add-all! a-heap '(7 3 9 1 13 21 15 31)) 60 | (heap-count a-heap) 61 | ] 62 | } 63 | 64 | @defproc[(heap-add! [h heap?] [v any/c] ...) void?]{ 65 | 66 | Adds each @racket[v] to the heap. 67 | 68 | @examples[#:eval the-eval 69 | (define a-heap (make-heap <=)) 70 | (heap-add! a-heap 2009 1009)] 71 | } 72 | 73 | 74 | @defproc[(heap-add-all! [h heap?] [v (or/c list? vector? heap?)]) void?]{ 75 | 76 | Adds each element contained in @racket[v] to the heap, leaving 77 | @racket[v] unchanged. 78 | 79 | @examples[#:eval the-eval 80 | (define heap-1 (make-heap <=)) 81 | (define heap-2 (make-heap <=)) 82 | (define heap-12 (make-heap <=)) 83 | (heap-add-all! heap-1 '(3 1 4 1 5 9 2 6)) 84 | (heap-add-all! heap-2 #(2 7 1 8 2 8 1 8)) 85 | (heap-add-all! heap-12 heap-1) 86 | (heap-add-all! heap-12 heap-2) 87 | (heap-count heap-12)] 88 | } 89 | 90 | @defproc[(heap-min [h heap?]) any/c]{ 91 | 92 | Returns the least element in the heap @racket[h], according to the 93 | heap's ordering. If the heap is empty, an exception is raised. 94 | 95 | @examples[#:eval the-eval 96 | (define a-heap (make-heap string<=?)) 97 | (heap-add! a-heap "sneezy" "sleepy" "dopey" "doc" 98 | "happy" "bashful" "grumpy") 99 | (heap-min a-heap) 100 | 101 | @code:comment{Taking the min of the empty heap is an error:} 102 | (eval:error (heap-min (make-heap <=))) 103 | ] 104 | } 105 | 106 | @defproc[(heap-remove-min! [h heap?]) void?]{ 107 | 108 | Removes the least element in the heap @racket[h]. If the heap is 109 | empty, an exception is raised. 110 | 111 | @examples[#:eval the-eval 112 | (define a-heap (make-heap string<=?)) 113 | (heap-add! a-heap "fili" "fili" "oin" "gloin" "thorin" 114 | "dwalin" "balin" "bifur" "bofur" 115 | "bombur" "dori" "nori" "ori") 116 | (heap-min a-heap) 117 | (heap-remove-min! a-heap) 118 | (heap-min a-heap)] 119 | } 120 | 121 | @defproc[(heap-remove! [h heap?] [v any/c] [#:same? same? (-> any/c any/c any/c) equal?]) boolean?]{ 122 | Removes @racket[v] from the heap @racket[h] if it exists, 123 | and returns @racket[#t] if the removal was successful, @racket[#f] otherwise. 124 | This operation takes O(n) time---see also @racket[heap-remove-eq!]. 125 | @examples[#:eval the-eval 126 | (define a-heap (make-heap string<=?)) 127 | (heap-add! a-heap "a" "b" "c") 128 | (heap-remove! a-heap "b") 129 | (for/list ([a (in-heap a-heap)]) a)] 130 | @history[#:changed "7.6.0.18" @elem{Returns a @racket[boolean?] instead of @racket[void?]}]} 131 | 132 | 133 | @defproc[(heap-remove-eq! [h heap?] [v any/c]) boolean?]{ 134 | 135 | Removes @racket[v] from the heap @racket[h] if it exists according to @racket[eq?], 136 | and returns @racket[#t] if the removal was successful, @racket[#f] otherwise. 137 | This operation takes O(log n) time, plus the indexing cost (which is O(1) on average, 138 | but O(n) in the worst case). The heap must not contain duplicate 139 | elements according to @racket[eq?], otherwise it may not be possible to remove all duplicates 140 | (see the example below). 141 | 142 | @examples[#:eval the-eval 143 | (define h (make-heap string<=?)) 144 | (define elt1 "123") 145 | (define elt2 "abcxyz") 146 | (heap-add! h elt1 elt2) 147 | @code:comment{The element is not found because no element of the heap is `eq?`} 148 | @code:comment{to the provided value:} 149 | (heap-remove-eq! h (string-append "abc" "xyz")) 150 | (heap->vector h) 151 | @code:comment{But this succeeds:} 152 | (heap-remove-eq! h elt2) 153 | (heap->vector h) 154 | @code:comment{Removing duplicate elements (according to `eq?`) may fail:} 155 | (heap-add! h elt2 elt2) 156 | (heap->vector h) 157 | (heap-remove-eq! h elt2) 158 | (heap-remove-eq! h elt2) 159 | (heap->vector h) 160 | @code:comment{But we can resort to the more general `heap-remove!`:} 161 | (heap-remove! h elt2 #:same? string=?) 162 | (heap->vector h)] 163 | @history[#:added "7.8.0.5"]} 164 | 165 | @defproc[(vector->heap [<=? (-> any/c any/c any/c)] [items vector?]) heap?]{ 166 | 167 | Builds a heap with the elements from @racket[items]. The vector is not 168 | modified. 169 | @examples[#:eval the-eval 170 | (struct item (val frequency)) 171 | (define (item<=? x y) 172 | (<= (item-frequency x) (item-frequency y))) 173 | (define some-sample-items 174 | (vector (item #\a 17) (item #\b 12) (item #\c 19))) 175 | (define a-heap (vector->heap item<=? some-sample-items)) 176 | ] 177 | } 178 | 179 | @defproc[(heap->vector [h heap?]) vector?]{ 180 | 181 | Returns a vector containing the elements of heap @racket[h] in the 182 | heap's order. The heap is not modified. 183 | 184 | @examples[#:eval the-eval 185 | (define word-heap (make-heap string<=?)) 186 | (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") 187 | (heap->vector word-heap) 188 | ] 189 | } 190 | 191 | @defproc[(heap-copy [h heap?]) heap?]{ 192 | 193 | Makes a copy of heap @racket[h]. 194 | @examples[#:eval the-eval 195 | (define word-heap (make-heap string<=?)) 196 | (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") 197 | (define a-copy (heap-copy word-heap)) 198 | (heap-remove-min! a-copy) 199 | (heap-count word-heap) 200 | (heap-count a-copy) 201 | ] 202 | } 203 | 204 | @defproc[(in-heap/consume! [heap heap?]) sequence?]{ 205 | Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. 206 | The heap is consumed in the process. Equivalent to repeated calling 207 | @racket[heap-min], then @racket[heap-remove-min!]. 208 | 209 | @examples[#:eval the-eval 210 | (define h (make-heap <=)) 211 | (heap-add-all! h '(50 40 10 20 30)) 212 | 213 | (for ([x (in-heap/consume! h)]) 214 | (displayln x)) 215 | 216 | (heap-count h)] 217 | } 218 | 219 | @defproc[(in-heap [heap heap?]) sequence?]{ 220 | Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. 221 | Equivalent to @racket[in-heap/consume!] except the heap is copied first. 222 | 223 | @examples[#:eval the-eval 224 | (define h (make-heap <=)) 225 | (heap-add-all! h '(50 40 10 20 30)) 226 | 227 | (for ([x (in-heap h)]) 228 | (displayln x)) 229 | 230 | (heap-count h)] 231 | } 232 | 233 | @;{--------} 234 | 235 | @defproc[(heap-sort! [v (and/c vector? (not/c immutable?))] [<=? (-> any/c any/c any/c)]) void?]{ 236 | 237 | Sorts vector @racket[v] using the comparison function @racket[<=?]. 238 | 239 | @examples[#:eval the-eval 240 | (define terms (vector "flock" "hatful" "deal" "batch" "lot" "good deal")) 241 | (heap-sort! terms string<=?) 242 | terms 243 | ] 244 | } 245 | 246 | @close-eval[the-eval] 247 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/skip-list.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label data/skip-list 4 | data/order 5 | racket/contract 6 | racket/dict 7 | racket/base)) 8 | 9 | @title[#:tag "skip-list"]{Skip Lists} 10 | 11 | @(define the-eval (make-base-eval)) 12 | @(the-eval '(require racket/dict data/order data/skip-list)) 13 | 14 | @defmodule[data/skip-list] 15 | 16 | @author[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] 17 | 18 | Skip-lists are a simple, efficient data structure for mutable 19 | dictionaries with totally ordered keys. They were described in the 20 | paper ``Skip Lists: A Probabilistic Alternative to Balanced Trees'' by 21 | William Pugh in Communications of the ACM, June 1990, 33(6) pp668-676. 22 | 23 | A skip-list is an ordered dictionary (@racket[dict?] and 24 | @racket[ordered-dict?]). It also supports extensions of the dictionary 25 | interface for iterator-based search and mutation. 26 | 27 | Operations on skip-lists are not thread-safe. If a key in a skip-list 28 | is mutated, the skip-list's internal invariants may be violated, 29 | causings its behavior to become unpredictable. 30 | 31 | Time complexities are given for many of the operations below. With a 32 | few exceptions, the time complexities below are probabilistic and 33 | assume that key comparison is constant-time. @italic{N} refers to the 34 | number of elements in the skip-list. 35 | 36 | 37 | @defproc[(make-skip-list [ord order? datum-order] 38 | [#:key-contract key-contract contract? any/c] 39 | [#:value-contract value-contract contract? any/c]) 40 | skip-list?]{ 41 | 42 | Makes a new empty skip-list. The skip-list uses @racket[ord] to order 43 | keys; in addition, the domain contract of @racket[ord] is combined 44 | with @racket[key-contract] to check keys. 45 | 46 | @examples[#:eval the-eval 47 | (define skip-list (make-skip-list real-order)) 48 | (skip-list-set! skip-list 3 'apple) 49 | (skip-list-set! skip-list 6 'cherry) 50 | (dict-map skip-list list) 51 | (skip-list-ref skip-list 3) 52 | (skip-list-remove! skip-list 6) 53 | (skip-list-count skip-list) 54 | ] 55 | } 56 | 57 | @defproc[(make-adjustable-skip-list 58 | [#:key-contract key-contract contract? any/c] 59 | [#:value-contract value-contract contract? any/c]) 60 | adjustable-skip-list?]{ 61 | 62 | Makes a new empty skip-list that permits only exact integers as keys 63 | (in addition to any constraints imposed by @racket[key-contract]). The 64 | resulting skip-list answers true to @racket[adjustable-skip-list?] 65 | and supports efficient key adjustment; see 66 | @racket[skip-list-contract!] and @racket[skip-list-expand!]. 67 | } 68 | 69 | @defproc[(skip-list? [v any/c]) boolean?]{ 70 | 71 | Returns @racket[#t] if @racket[v] is a skip-list, @racket[#f] 72 | otherwise. 73 | } 74 | 75 | @defproc[(adjustable-skip-list? [v any/c]) boolean?]{ 76 | 77 | Returns @racket[#t] if @racket[v] is a skip-list that supports key 78 | adjustment; see @racket[skip-list-contract!] and 79 | @racket[skip-list-expand!]. 80 | } 81 | 82 | @deftogether[[ 83 | @defproc[(skip-list-ref [skip-list skip-list?] 84 | [key any/c] 85 | [default any/c (lambda () (error ....))]) 86 | any/c] 87 | @defproc[(skip-list-set! [skip-list skip-list?] 88 | [key any/c] 89 | [value any/c]) 90 | void?] 91 | @defproc[(skip-list-remove! [skip-list skip-list?] 92 | [key any/c]) 93 | void?] 94 | @defproc[(skip-list-count [skip-list skip-list?]) 95 | exact-nonnegative-integer?]]]{ 96 | 97 | Implementations of @racket[dict-ref], @racket[dict-set!], 98 | @racket[dict-remove!], and @racket[dict-count], respectively. 99 | 100 | The @racket[skip-list-ref], @racket[skip-list-set!], and 101 | @racket[skip-list-remove!] operations take @italic{O(log N)} time. The 102 | @racket[skip-list-count] operation takes constant time. 103 | } 104 | 105 | @defproc[(skip-list-remove-range! [skip-list skip-list?] 106 | [from any/c] 107 | [to any/c]) 108 | void?]{ 109 | 110 | Removes all keys in [@racket[from], @racket[to]); that is, all keys 111 | greater than or equal to @racket[from] and less than @racket[to]. 112 | 113 | This operation takes probabilistic @italic{O(log N)} time. 114 | } 115 | 116 | @defproc[(skip-list-contract! [skip-list adjustable-skip-list?] 117 | [from exact-integer?] 118 | [to exact-integer?]) 119 | void?]{ 120 | 121 | Like @racket[skip-list-remove-range!], but also decreases the value 122 | of all keys greater than or equal to @racket[to] by @racket[(- to 123 | from)]. 124 | 125 | This operation takes probabilistic @italic{O(log N)} time. 126 | } 127 | 128 | @defproc[(skip-list-expand! [skip-list adjustable-skip-list?] 129 | [from exact-integer?] 130 | [to exact-integer?]) 131 | void?]{ 132 | 133 | Increases each key greater than or equal to @racket[from] by 134 | @racket[(- to from)]. 135 | 136 | This operation takes probabilistic @italic{O(log N)} time. 137 | } 138 | 139 | @deftogether[[ 140 | @defproc[(skip-list-iterate-first [skip-list skip-list?]) 141 | (or/c skip-list-iter? #f)] 142 | @defproc[(skip-list-iterate-next [skip-list skip-list?] 143 | [iter skip-list-iter?]) 144 | (or/c skip-list-iter? #f)] 145 | @defproc[(skip-list-iterate-key [skip-list skip-list?] 146 | [iter skip-list-iter?]) 147 | any/c] 148 | @defproc[(skip-list-iterate-value [skip-list skip-list?] 149 | [iter skip-list-iter?]) 150 | any/c]]]{ 151 | 152 | Implementations of @racket[dict-iterate-first], 153 | @racket[dict-iterate-next], @racket[dict-iterate-key], and 154 | @racket[dict-iterate-value], respectively. 155 | 156 | A skip-list iterator is invalidated if the entry it points to is 157 | deleted from the skip-list (even if another entry is later inserted 158 | with the same key). The @racket[skip-list-iterate-key] and 159 | @racket[skip-list-iterate-value] operations raise an exception when 160 | called on an invalidated iterator, but @racket[skip-list-iterate-next] 161 | advances to the next undeleted entry that was visible to @racket[iter] 162 | when it was valid. 163 | 164 | These operations take constant time. 165 | } 166 | 167 | @deftogether[[ 168 | @defproc[(skip-list-iterate-least/>? [skip-list skip-list?] 169 | [key any/c]) 170 | (or/c skip-list-iter? #f)] 171 | @defproc[(skip-list-iterate-least/>=? [skip-list skip-list?] 172 | [key any/c]) 173 | (or/c skip-list-iter? #f)] 174 | @defproc[(skip-list-iterate-greatest/?], 186 | @racket[dict-iterate-least/>=?], @racket[dict-iterate-greatest/list [skip-list skip-list?]) (listof pair?)]{ 211 | 212 | Returns an association list with the keys and values of 213 | @racket[skip-list], in order. 214 | 215 | This operation takes @italic{O(N)} time, where @italic{N} is the 216 | number of entries in the skip-list. 217 | } 218 | 219 | 220 | @close-eval[the-eval] 221 | -------------------------------------------------------------------------------- /data-lib/data/union-find.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract) 3 | (provide uf-set? uf-new) 4 | (provide 5 | (contract-out 6 | [uf-union! (-> uf-set? uf-set? void?)] 7 | [uf-find (-> uf-set? any/c)] 8 | [uf-set-canonical! (-> uf-set? any/c void?)] 9 | [uf-same-set? (-> uf-set? uf-set? boolean?)])) 10 | 11 | (struct uf-set (x rank) #:mutable 12 | #:methods gen:custom-write 13 | [(define write-proc 14 | (λ (uf port mode) 15 | (write-string "#" port)))]) 23 | 24 | (define (uf-new x) (uf-set (box x) 0)) 25 | 26 | (define (uf-union! _a _b) 27 | (define a (uf-get-root _a)) 28 | (define b (uf-get-root _b)) 29 | (unless (eq? a b) 30 | (define a-rank (uf-set-rank a)) 31 | (define b-rank (uf-set-rank b)) 32 | (cond 33 | [(< a-rank b-rank) 34 | (set-uf-set-x! a b)] 35 | [else 36 | (set-uf-set-x! b a) 37 | (when (= a-rank b-rank) 38 | (set-uf-set-rank! a (+ a-rank 1)))]))) 39 | 40 | (define (uf-find a) (unbox (uf-get-box a))) 41 | 42 | (define (uf-set-canonical! a b) 43 | (set-box! (uf-get-box a) b)) 44 | 45 | (define (uf-same-set? a b) 46 | (eq? (uf-get-box a) (uf-get-box b))) 47 | 48 | (define (uf-get-box a) (uf-set-x (uf-get-root a))) 49 | 50 | (define (uf-get-root a) 51 | (let loop ([c a] 52 | [p (uf-set-x a)]) 53 | (cond 54 | [(box? p) c] 55 | [else 56 | (define fnd (loop p (uf-set-x p))) 57 | (set-uf-set-x! c fnd) 58 | fnd]))) 59 | 60 | (module+ test 61 | (require rackunit 62 | racket/pretty 63 | racket/set) 64 | 65 | (check-equal? (uf-find (uf-new 1)) 1) 66 | (check-equal? (let ([a (uf-new 1)] 67 | [b (uf-new 2)]) 68 | (uf-union! a b) 69 | (uf-find a)) 70 | 1) 71 | (check-equal? (let ([a (uf-new 1)] 72 | [b (uf-new 2)]) 73 | (uf-union! a b) 74 | (uf-find b)) 75 | 1) 76 | (check-equal? (let ([a (uf-new 1)] 77 | [b (uf-new 2)]) 78 | (uf-union! a b) 79 | (uf-find a) 80 | (uf-find a)) 81 | 1) 82 | (check-equal? (let ([a (uf-new 1)] 83 | [b (uf-new 2)]) 84 | (uf-union! a b) 85 | (uf-find b) 86 | (uf-find b)) 87 | 1) 88 | 89 | (check-equal? (let ([a (uf-new 1)]) 90 | (uf-union! a a) 91 | (uf-find a)) 92 | 1) 93 | 94 | (check-equal? (uf-same-set? (uf-new 1) (uf-new 2)) #f) 95 | (check-equal? (uf-same-set? (uf-new 1) (uf-new 1)) #f) 96 | (check-equal? (let ([a (uf-new 1)] 97 | [b (uf-new 1)]) 98 | (uf-union! a b) 99 | (uf-same-set? a b)) 100 | #t) 101 | (check-equal? (let ([sp (open-output-string)]) 102 | (display (uf-new "x") sp) 103 | (get-output-string sp)) 104 | "#") 105 | (check-equal? (let ([sp (open-output-string)]) 106 | (write (uf-new "x") sp) 107 | (get-output-string sp)) 108 | "#") 109 | (check-equal? (let ([sp (open-output-string)]) 110 | (print (uf-new "x") sp) 111 | (get-output-string sp)) 112 | "#") 113 | (check-equal? (let ([sp (open-output-string)]) 114 | (define x (vector 1)) 115 | (define a (uf-new x)) 116 | (vector-set! x 0 a) 117 | (write x sp) 118 | (get-output-string sp)) 119 | "#0=#(#)") 120 | (check-equal? (let ([sp (open-output-string)]) 121 | (define a (uf-new #f)) 122 | (uf-set-canonical! a a) 123 | (write a sp) 124 | (get-output-string sp)) 125 | "#0=#") 126 | 127 | 128 | (let ([a (uf-new 1)] 129 | [b (uf-new 2)] 130 | [c (uf-new 3)] 131 | [d (uf-new 4)] 132 | [e (uf-new 5)]) 133 | (uf-union! a b) 134 | (uf-union! c d) 135 | (uf-union! b d) 136 | (uf-union! c e) 137 | (check-equal? (uf-find a) 138 | (uf-find e))) 139 | 140 | (let ([a (uf-new 1)] 141 | [b (uf-new 2)] 142 | [c (uf-new 3)] 143 | [d (uf-new 4)] 144 | [e (uf-new 5)]) 145 | (uf-union! a b) 146 | (uf-union! c d) 147 | (uf-union! a c) 148 | (uf-union! c e) 149 | (check-equal? (uf-find a) 150 | (uf-find e))) 151 | 152 | (let ([a (uf-new 1)] 153 | [b (uf-new 2)] 154 | [c (uf-new 3)] 155 | [d (uf-new 4)] 156 | [e (uf-new 5)]) 157 | (uf-union! a b) 158 | (uf-union! c d) 159 | (uf-union! a d) 160 | (uf-union! c e) 161 | (check-equal? (uf-find a) 162 | (uf-find e))) 163 | 164 | (let ([a (uf-new 1)] 165 | [b (uf-new 2)] 166 | [c (uf-new 3)] 167 | [d (uf-new 4)] 168 | [e (uf-new 5)]) 169 | (uf-union! a b) 170 | (uf-union! c d) 171 | (uf-union! b c) 172 | (uf-union! c e) 173 | (check-equal? (uf-find a) 174 | (uf-find e))) 175 | 176 | (check-equal? (let ([a (uf-new 1)] 177 | [b (uf-new 2)] 178 | [c (uf-new 3)] 179 | [d (uf-new 4)]) 180 | (uf-union! a b) 181 | (uf-union! c d) 182 | (uf-union! a c) 183 | (max (uf-set-rank a) 184 | (uf-set-rank b) 185 | (uf-set-rank c) 186 | (uf-set-rank d))) 187 | 2) 188 | 189 | (let ((uf-sets (for/list ((x (in-range 8))) (uf-new x)))) 190 | (uf-union! (list-ref uf-sets 5) (list-ref uf-sets 7)) 191 | (uf-union! (list-ref uf-sets 1) (list-ref uf-sets 6)) 192 | (uf-union! (list-ref uf-sets 6) (list-ref uf-sets 5)) 193 | (uf-union! (list-ref uf-sets 4) (list-ref uf-sets 7)) 194 | (uf-union! (list-ref uf-sets 2) (list-ref uf-sets 0)) 195 | (uf-union! (list-ref uf-sets 2) (list-ref uf-sets 5)) 196 | (check-equal? (uf-find (list-ref uf-sets 4)) 197 | (uf-find (list-ref uf-sets 7)))) 198 | 199 | 200 | (define (run-random-tests) 201 | (define (make-random-sets num-sets) 202 | (define uf-sets 203 | (for/list ([x (in-range num-sets)]) 204 | (uf-new x))) 205 | (define edges (make-hash (build-list num-sets (λ (x) (cons x (set)))))) 206 | (define (add-edge a-num b-num) 207 | (hash-set! edges a-num (set-add (hash-ref edges a-num) b-num))) 208 | (define ops '()) 209 | (for ([op (in-range (random 10))]) 210 | (define a-num (random num-sets)) 211 | (define b-num (random num-sets)) 212 | (define a (list-ref uf-sets a-num)) 213 | (define b (list-ref uf-sets b-num)) 214 | (set! ops (cons `(uf-union! (list-ref uf-sets ,a-num) 215 | (list-ref uf-sets ,b-num)) 216 | ops)) 217 | (uf-union! a b) 218 | (add-edge a-num b-num) 219 | (add-edge b-num a-num)) 220 | (define code `(let ([uf-sets 221 | (for/list ([x (in-range ,num-sets)]) 222 | (uf-new x))]) 223 | ,@(reverse ops))) 224 | (values uf-sets edges code)) 225 | 226 | (define (check-canonical-has-path uf-sets edges code) 227 | (for ([set (in-list uf-sets)] 228 | [i (in-naturals)]) 229 | (define canon (uf-find set)) 230 | (define visited (make-hash)) 231 | (define found? 232 | (let loop ([node i]) 233 | (cond 234 | [(= node canon) #t] 235 | [(hash-ref visited node #f) #f] 236 | [else 237 | (hash-set! visited node #t) 238 | (for/or ([neighbor (in-set (hash-ref edges node))]) 239 | (loop neighbor))]))) 240 | (unless found? 241 | (pretty-print code (current-error-port)) 242 | (error 'union-find.rkt "mismatch; expected a link from ~s to ~s, didn't find it" 243 | i canon)))) 244 | 245 | (define (check-edges-share-canonical uf-sets edges code) 246 | (for ([(src dests) (in-hash edges)]) 247 | (for ([dest (in-set dests)]) 248 | (define sc (uf-find (list-ref uf-sets src))) 249 | (define dc (uf-find (list-ref uf-sets dest))) 250 | (unless (= sc dc) 251 | (pretty-print code (current-error-port)) 252 | (error 'union-find.rkt 253 | "mismatch; expected sets ~s and ~s to have the same canonical element, got ~s and ~s" 254 | src dest 255 | sc dc))))) 256 | 257 | (for ([x (in-range 10000)]) 258 | (define-values (sets edges code) 259 | (make-random-sets (+ 2 (random (+ 1 (floor (/ x 100))))))) 260 | (check-canonical-has-path sets edges code) 261 | (check-edges-share-canonical sets edges code))) 262 | 263 | (run-random-tests) 264 | 265 | (random-seed 0) 266 | (time (run-random-tests))) 267 | -------------------------------------------------------------------------------- /data-doc/data/scribblings/order.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label data/order 4 | racket/contract 5 | racket/dict 6 | racket/base 7 | racket/generic)) 8 | 9 | @title{Orders and Ordered Dictionaries} 10 | 11 | @(define the-eval (make-base-eval)) 12 | @(the-eval '(require racket/dict data/order)) 13 | 14 | @defmodule[data/order] 15 | 16 | @author[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] 17 | 18 | This library defines @deftech{orders} and the @deftech{ordered 19 | dictionary} generic interface. 20 | 21 | @defthing[ordering/c flat-contract?]{ 22 | 23 | Contract for orderings, represented by the symbols @racket['=], 24 | @racket['<], and @racket['>]. 25 | } 26 | 27 | @defthing[gen:ordered-dict any/c]{ 28 | 29 | A generic interface for defining new ordered dictionary types. 30 | Methods can be attached to the @racket[gen:ordered-dict] interface 31 | using the @racket[#:methods] keyword in a structure type definition. 32 | Two ``extrema'' methods and four ``search'' methods should be 33 | implemented. The extrema methods must satisfy @racket[_e/c] and the search 34 | methods must satisfy @racket[_s/c]: 35 | 36 | @racketblock[ 37 | _e/c = (->i ([d ordered-dict?]) 38 | [_ (d) (or/c #f (dict-iter-contract d))]) 39 | _s/c = (->i ([d ordered-dict?] 40 | [k (d) (dict-key-contract d)]) 41 | [_ (d) (or/c #f (dict-iter-contract d))]) 42 | ] 43 | 44 | The methods are implementations of the following generic functions: 45 | 46 | @itemize[ 47 | @item{@racket[dict-iterate-least]} 48 | @item{@racket[dict-iterate-greatest]} 49 | @item{@racket[dict-iterate-least/>?]} 50 | @item{@racket[dict-iterate-least/>=?]} 51 | @item{@racket[dict-iterate-greatest/? [dict ordered-dict?] [key any/c]) 88 | (or/c (dict-iter-contract dict) #f)] 89 | @defproc[(dict-iterate-least/>=? [dict ordered-dict?] [key any/c]) 90 | (or/c (dict-iter-contract dict) #f)] 91 | @defproc[(dict-iterate-greatest/ any/c any/c ordering/c)]) 107 | (and/c order? procedure?)] 108 | [(order [name symbol?] 109 | [domain-contract contract?] 110 | [=? (-> any/c any/c boolean?)] 111 | [ any/c any/c boolean?)] 112 | [>? (-> any/c any/c boolean?) 113 | (lambda (x y) ( any/c any/c ordering/c)]{ 147 | 148 | Extracts the comparator function from an order object. 149 | } 150 | 151 | @defproc[(order-domain-contract [ord order?]) contract?]{ 152 | 153 | Extracts the domain contract from an order object. 154 | } 155 | 156 | @deftogether[[ 157 | @defproc[(order-=? [ord order?]) (-> any/c any/c boolean?)] 158 | @defproc[(order- any/c any/c boolean?)] 159 | ]]{ 160 | 161 | Returns a procedure representing the order's equality relation or 162 | less-than relation, respectively. 163 | } 164 | 165 | @defthing[real-order order?]{ 166 | 167 | The order of the real numbers. The domain of @racket[real-order] 168 | excludes @racket[+nan.0] but includes @racket[+inf.0] and 169 | @racket[-inf.0]. The standard numeric comparisons (@racket[=], 170 | @racket[<]) are used; exact @racket[1] is equal to inexact 171 | @racket[1.0]. 172 | 173 | @examples[#:eval the-eval 174 | (real-order 1.0 1) 175 | (real-order 5 7) 176 | (real-order 9.0 3.4) 177 | (real-order 1 +inf.0) 178 | (real-order 5 -inf.0) 179 | ] 180 | } 181 | 182 | @defthing[datum-order order?]{ 183 | 184 | An ad hoc order that encompasses many built-in Racket data types as 185 | well as prefab structs and fully-transparent structs. The 186 | @racket[datum-order] comparator orders values of the same data type 187 | according to the data type's natural order: @racket[string=?], 188 | @racket[string any/c any/c)] 115 | [default any/c (lambda () (error ....))]) 116 | void?]{ 117 | 118 | Updates @racket[interval-map], associating every position in 119 | [@racket[start], @racket[end]) with the result of applying 120 | @racket[updater] to the position's previously associated value, or to 121 | the default value produced by @racket[default] if no mapping exists. 122 | 123 | Unlike @racket[interval-map-set!], @racket[interval-map-update*!] 124 | preserves existing distinctions within [@racket[start], @racket[end]). 125 | } 126 | 127 | @defproc[(interval-map-remove! [interval-map interval-map?] 128 | [start (or/c exact-integer? -inf.0)] 129 | [end (or/c exact-integer? +inf.0)]) 130 | void?]{ 131 | 132 | Removes the value associated with every position in [@racket[start], 133 | @racket[end]). 134 | } 135 | 136 | @defproc[(interval-map-contract! [interval-map interval-map?] 137 | [start exact-integer?] 138 | [end exact-integer?]) 139 | void?]{ 140 | 141 | Contracts @racket[interval-map]'s domain by removing all mappings on 142 | the interval [@racket[start], @racket[end]) and decreasing intervals 143 | initally after @racket[end] by @racket[(- end start)]. 144 | 145 | If @racket[start] is not less than @racket[end], an exception is raised. 146 | } 147 | 148 | @defproc[(interval-map-expand! [interval-map interval-map?] 149 | [start exact-integer?] 150 | [end exact-integer?]) 151 | void?]{ 152 | 153 | Expands @racket[interval-map]'s domain by introducing a gap 154 | [@racket[start], @racket[end]) and increasing intervals starting at or after 155 | @racket[start] by @racket[(- end start)]. 156 | 157 | If @racket[start] is not less than @racket[end], an exception is raised. 158 | } 159 | 160 | @defproc[(interval-map-cons*! [interval-map interval-map?] 161 | [start any/c] 162 | [end any/c] 163 | [v any/c] 164 | [default any/c null]) 165 | void?]{ 166 | 167 | Same as the following: 168 | @racketblock[ 169 | (interval-map-update*! interval-map start end 170 | (lambda (old) (cons v old)) 171 | default) 172 | ] 173 | } 174 | 175 | 176 | @deftogether[[ 177 | @defproc[(interval-map-iterate-first [interval-map interval-map?]) 178 | (or/c interval-map-iter? #f)] 179 | @defproc[(interval-map-iterate-next [interval-map interval-map?] 180 | [iter interval-map-iter?]) 181 | (or/c interval-map-iter? #f)] 182 | @defproc[(interval-map-iterate-key [interval-map interval-map?] 183 | [iter interval-map-iter?]) 184 | pair?] 185 | @defproc[(interval-map-iterate-value [interval-map interval-map?] 186 | [iter interval-map-iter?]) 187 | any]]]{ 188 | 189 | Implementations of @racket[dict-iterate-first], 190 | @racket[dict-iterate-next], @racket[dict-iterate-key], and 191 | @racket[dict-iterate-value], respectively. 192 | } 193 | 194 | @deftogether[[ 195 | @defproc[(interval-map-iterate-least [interval-map interval-map?]) 196 | (or/c interval-map-iter? #f)] 197 | @defproc[(interval-map-iterate-greatest [interval-map interval-map?]) 198 | (or/c interval-map-iter? #f)]]]{ 199 | 200 | Like @racket[dict-iterate-least] and @racket[dict-iterate-greatest], 201 | respectively, though interval maps do not implement the 202 | @racket[gen:ordered-dict] interface. 203 | 204 | @history[#:added "1.2"]} 205 | 206 | @deftogether[[ 207 | @defproc[(interval-map-iterate-least/start>? [interval-map interval-map?] 208 | [start exact-integer?]) 209 | (or/c interval-map-iter? #f)] 210 | @defproc[(interval-map-iterate-least/start>=? [interval-map interval-map?] 211 | [start exact-integer?]) 212 | (or/c interval-map-iter? #f)] 213 | @defproc[(interval-map-iterate-greatest/start? [interval-map interval-map?] 220 | [end exact-integer?]) 221 | (or/c interval-map-iter? #f)] 222 | @defproc[(interval-map-iterate-least/end>=? [interval-map interval-map?] 223 | [end exact-integer?]) 224 | (or/c interval-map-iter? #f)] 225 | @defproc[(interval-map-iterate-greatest/end?], @racket[dict-iterate-least/>=?], 233 | @racket[dict-iterate-greatest/= (car k) last) 33 | (error 'check-im "overlapping intervals: ~s, ~s" last k)) 34 | (cdr k))) 35 | 36 | ;; ---- 37 | 38 | (define vec (make-vector KEY-MAX 0)) 39 | (define im (make-interval-map)) 40 | 41 | (define (last-key) (vector-length vec)) 42 | 43 | (define (vec-contract! a b) 44 | (define n (- (vector-length vec) (- b a))) 45 | ;; (eprintf "vec-contract!: a = ~s, b = ~s, n = ~s\n" a b n) 46 | (define vec* (make-vector n #f)) 47 | (for ([i n]) 48 | (vector-set! vec* i (vector-ref vec (if (< i a) i (+ i (- b a)))))) 49 | (set! vec vec*)) 50 | 51 | (define (vec-expand! a b) 52 | (define n (+ (vector-length vec) (- b a))) 53 | (define vec* (make-vector n #f)) 54 | (for ([i (vector-length vec)]) 55 | (vector-set! vec* (if (< i a) i (+ i (- b a))) (vector-ref vec i))) 56 | (set! vec vec*)) 57 | 58 | (define (check-all-refs) 59 | ;; (printf "vec ~v\n" (vector->list vec)) 60 | ;; (printf "im ~v\n" (for/list ([i (vector-length vec)]) (interval-map-ref im i #f))) 61 | (check-im im) 62 | (check-equal? (for/last ([(k v) (in-dict im)]) (cdr k)) 63 | (vector-length vec) 64 | "different lengths") 65 | (for ([i (vector-length vec)]) 66 | (check-equal? (interval-map-ref im i #f) 67 | (vector-ref vec i) 68 | "different values"))) 69 | 70 | ;; set up 71 | (interval-map-set! im 0 KEY-MAX 0) 72 | (for ([k INTERVAL-CT]) 73 | (define-values (a b) 74 | (let ([a (random KEY-MAX)] [b (random KEY-MAX)]) 75 | (values (min a b) (max a b)))) 76 | (define v (random VALUE-MAX)) 77 | (unless (= a b) 78 | (for ([i (in-range a b)]) 79 | (vector-set! vec i v)) 80 | (interval-map-set! im a b v))) 81 | 82 | (printf "check set up\n") 83 | (check-all-refs) 84 | 85 | ;; contract! 86 | (printf "check contract!\n") 87 | (for ([i CONTRACT-CT]) 88 | (define a (random (- (last-key) 1 SPREAD))) 89 | (define b (+ a 1 (random SPREAD))) 90 | ;; (eprintf "a = ~s, b = ~s\n" a b) 91 | (interval-map-contract! im a b) 92 | (vec-contract! a b) 93 | (check-all-refs)) 94 | 95 | ;; expand! 96 | (printf "check expand!\n") 97 | (for ([i EXPAND-CT]) 98 | (define a (random (last-key))) 99 | (define b (+ a 1 (random SPREAD))) 100 | ;; (eprintf "a = ~s, b = ~s\n" a b) 101 | (interval-map-expand! im a b) 102 | (vec-expand! a b) 103 | (check-all-refs)) 104 | 105 | ;; tests for interval-map-ref/bounds 106 | (let ([im (make-interval-map '())]) 107 | ;; check ref for empty map 108 | (let-values ([(s e v) 109 | (interval-map-ref/bounds im 5 #t)]) 110 | (check-equal? s #f) 111 | (check-equal? e #f) 112 | (check-equal? v #t))) 113 | (let ([im (make-interval-map '(((5 . 10) . "value")))]) 114 | ;; check refs for map with one value 115 | (let-values ([(s e v) 116 | (interval-map-ref/bounds im 5)]) 117 | (check-equal? s 5) 118 | (check-equal? e 10) 119 | (check-equal? v "value")) 120 | (let-values ([(s e v) 121 | (interval-map-ref/bounds im 10 #t)]) 122 | (check-equal? s #f) 123 | (check-equal? e #f) 124 | (check-equal? v #t)) 125 | (let-values ([(s e v) 126 | (interval-map-ref/bounds im 4 (λ () #t))]) 127 | (check-equal? s #f) 128 | (check-equal? e #f) 129 | (check-equal? v #t))) 130 | (let ([im (make-interval-map '(((5 . 10) . "value") ((20 . 30) . "other")))]) 131 | ;; check refs for map with multiple values 132 | (let-values ([(s e v) 133 | (interval-map-ref/bounds im 4 #t)]) 134 | (check-equal? s #f) 135 | (check-equal? e #f) 136 | (check-equal? v #t)) 137 | (let-values ([(s e v) 138 | (interval-map-ref/bounds im 7)]) 139 | (check-equal? s 5) 140 | (check-equal? e 10) 141 | (check-equal? v "value")) 142 | (let-values ([(s e v) 143 | (interval-map-ref/bounds im 15 #t)]) 144 | (check-equal? s #f) 145 | (check-equal? e #f) 146 | (check-equal? v #t)) 147 | (let-values ([(s e v) 148 | (interval-map-ref/bounds im 22)]) 149 | (check-equal? s 20) 150 | (check-equal? e 30) 151 | (check-equal? v "other")) 152 | (let-values ([(s e v) 153 | (interval-map-ref/bounds im 30 #t)]) 154 | (check-equal? s #f) 155 | (check-equal? e #f) 156 | (check-equal? v #t))) 157 | 158 | (define (check-iter im iter vals) 159 | (check-equal? 160 | (let loop ([iter iter]) 161 | (if iter 162 | (cons (cons (interval-map-iterate-key im iter) 163 | (interval-map-iterate-value im iter)) 164 | (loop (interval-map-iterate-next im iter))) 165 | '())) 166 | vals) 167 | (void)) 168 | 169 | (printf "check iteration\n") 170 | (let* ([vals '([(1 . 2) . a] [(2 . 5) . b] [(10 . 15) c])] 171 | [im (make-interval-map vals)]) 172 | (check-iter im (interval-map-iterate-least im) vals) 173 | (check-iter im (interval-map-iterate-greatest im) (drop vals 2)) 174 | 175 | (check-iter im (interval-map-iterate-least/start>? im 0) vals) 176 | (check-iter im (interval-map-iterate-least/start>? im 1) (drop vals 1)) 177 | (check-iter im (interval-map-iterate-least/start>? im 2) (drop vals 2)) 178 | (check-iter im (interval-map-iterate-least/start>? im 3) (drop vals 2)) 179 | (check-iter im (interval-map-iterate-least/start>? im 5) (drop vals 2)) 180 | (check-iter im (interval-map-iterate-least/start>? im 9) (drop vals 2)) 181 | (check-iter im (interval-map-iterate-least/start>? im 10) '()) 182 | (check-iter im (interval-map-iterate-least/start>? im 13) '()) 183 | (check-iter im (interval-map-iterate-least/start>? im 15) '()) 184 | (check-iter im (interval-map-iterate-least/start>? im 16) '()) 185 | 186 | (check-iter im (interval-map-iterate-least/start>=? im 0) vals) 187 | (check-iter im (interval-map-iterate-least/start>=? im 1) vals) 188 | (check-iter im (interval-map-iterate-least/start>=? im 2) (drop vals 1)) 189 | (check-iter im (interval-map-iterate-least/start>=? im 3) (drop vals 2)) 190 | (check-iter im (interval-map-iterate-least/start>=? im 5) (drop vals 2)) 191 | (check-iter im (interval-map-iterate-least/start>=? im 9) (drop vals 2)) 192 | (check-iter im (interval-map-iterate-least/start>=? im 10) (drop vals 2)) 193 | (check-iter im (interval-map-iterate-least/start>=? im 13) '()) 194 | (check-iter im (interval-map-iterate-least/start>=? im 15) '()) 195 | (check-iter im (interval-map-iterate-least/start>=? im 16) '()) 196 | 197 | (check-iter im (interval-map-iterate-greatest/start? im 0) vals) 220 | (check-iter im (interval-map-iterate-least/end>? im 1) vals) 221 | (check-iter im (interval-map-iterate-least/end>? im 2) (drop vals 1)) 222 | (check-iter im (interval-map-iterate-least/end>? im 3) (drop vals 1)) 223 | (check-iter im (interval-map-iterate-least/end>? im 5) (drop vals 2)) 224 | (check-iter im (interval-map-iterate-least/end>? im 9) (drop vals 2)) 225 | (check-iter im (interval-map-iterate-least/end>? im 10) (drop vals 2)) 226 | (check-iter im (interval-map-iterate-least/end>? im 13) (drop vals 2)) 227 | (check-iter im (interval-map-iterate-least/end>? im 15) '()) 228 | (check-iter im (interval-map-iterate-least/end>? im 16) '()) 229 | 230 | (check-iter im (interval-map-iterate-least/end>=? im 0) vals) 231 | (check-iter im (interval-map-iterate-least/end>=? im 1) vals) 232 | (check-iter im (interval-map-iterate-least/end>=? im 2) vals) 233 | (check-iter im (interval-map-iterate-least/end>=? im 3) (drop vals 1)) 234 | (check-iter im (interval-map-iterate-least/end>=? im 5) (drop vals 1)) 235 | (check-iter im (interval-map-iterate-least/end>=? im 9) (drop vals 2)) 236 | (check-iter im (interval-map-iterate-least/end>=? im 10) (drop vals 2)) 237 | (check-iter im (interval-map-iterate-least/end>=? im 13) (drop vals 2)) 238 | (check-iter im (interval-map-iterate-least/end>=? im 15) (drop vals 2)) 239 | (check-iter im (interval-map-iterate-least/end>=? im 16) '()) 240 | 241 | (check-iter im (interval-map-iterate-greatest/end Void 33 | (define (ensure-free-space! gv needed-free-space) 34 | (define vec (gvector-vec gv)) 35 | (define n (gvector-n gv)) 36 | (define cap (vector-length vec)) 37 | (define needed-cap (+ n needed-free-space)) 38 | (unless (<= needed-cap cap) 39 | (define new-cap 40 | (let loop ([new-cap (max DEFAULT-CAPACITY cap)]) 41 | (if (<= needed-cap new-cap) new-cap (loop (* 2 new-cap))))) 42 | (define new-vec (make-vector new-cap #f)) 43 | (vector-copy! new-vec 0 vec) 44 | (set-gvector-vec! gv new-vec))) 45 | 46 | (define gvector-add! 47 | (case-lambda 48 | [(gv item) 49 | (ensure-free-space! gv 1) 50 | (define n (gvector-n gv)) 51 | (define v (gvector-vec gv)) 52 | (vector-set! v n item) 53 | (set-gvector-n! gv (add1 n))] 54 | [(gv . items) 55 | (define item-count (length items)) 56 | (ensure-free-space! gv item-count) 57 | (define n (gvector-n gv)) 58 | (define v (gvector-vec gv)) 59 | (for ([index (in-naturals n)] [item (in-list items)]) 60 | (vector-set! v index item)) 61 | (set-gvector-n! gv (+ n item-count))])) 62 | 63 | ;; SLOW! 64 | (define (gvector-insert! gv index item) 65 | ;; This does (n - index) redundant copies on resize, but that 66 | ;; happens rarely and I prefer the simpler code. 67 | (define n (gvector-n gv)) 68 | (check-index 'gvector-insert! gv index #t) 69 | (ensure-free-space! gv 1) 70 | (define v (gvector-vec gv)) 71 | (vector-copy! v (add1 index) v index n) 72 | (vector-set! v index item) 73 | (set-gvector-n! gv (add1 n))) 74 | 75 | ;; Shrink when vector length is > SHRINK-ON-FACTOR * #elements 76 | (define SHRINK-ON-FACTOR 4) 77 | ;; ... unless it would shrink to less than SHRINK-MIN 78 | (define SHRINK-MIN 10) 79 | 80 | ;; Shrink by SHRINK-BY-FACTOR 81 | (define SHRINK-BY-FACTOR 2) 82 | 83 | (define (trim! gv) 84 | (define n (gvector-n gv)) 85 | (define v (gvector-vec gv)) 86 | (define cap (vector-length v)) 87 | (define new-cap 88 | (let loop ([new-cap cap]) 89 | (cond [(and (>= new-cap (* SHRINK-ON-FACTOR n)) 90 | (>= (quotient new-cap SHRINK-BY-FACTOR) SHRINK-MIN)) 91 | (loop (quotient new-cap SHRINK-BY-FACTOR))] 92 | [else new-cap]))) 93 | (when (< new-cap cap) 94 | (define new-v (make-vector new-cap #f)) 95 | (vector-copy! new-v 0 v 0 n) 96 | (set-gvector-vec! gv new-v))) 97 | 98 | ;; SLOW! 99 | (define (gvector-remove! gv index) 100 | (define n (gvector-n gv)) 101 | (define v (gvector-vec gv)) 102 | (check-index 'gvector-remove! gv index #f) 103 | (vector-copy! v index v (add1 index) n) 104 | (vector-set! v (sub1 n) #f) 105 | (set-gvector-n! gv (sub1 n)) 106 | (trim! gv)) 107 | 108 | (define (gvector-remove-last! gv) 109 | (let ([n (gvector-n gv)] 110 | [v (gvector-vec gv)]) 111 | (unless (> n 0) (error 'gvector-remove-last! "empty")) 112 | (define last-val (vector-ref v (sub1 n))) 113 | (gvector-remove! gv (sub1 n)) 114 | last-val)) 115 | 116 | (define (gvector-count gv) 117 | (gvector-n gv)) 118 | 119 | (define none (gensym 'none)) 120 | 121 | (define (gvector-ref gv index [default none]) 122 | (unless (exact-nonnegative-integer? index) 123 | (raise-type-error 'gvector-ref "exact nonnegative integer" index)) 124 | (if (< index (gvector-n gv)) 125 | (vector-ref (gvector-vec gv) index) 126 | (cond [(eq? default none) 127 | (check-index 'gvector-ref gv index #f)] 128 | [(procedure? default) (default)] 129 | [else default]))) 130 | 131 | ;; gvector-set! with index = |gv| is interpreted as gvector-add! 132 | (define (gvector-set! gv index item) 133 | (let ([n (gvector-n gv)]) 134 | (check-index 'gvector-set! gv index #t) 135 | (if (= index n) 136 | (gvector-add! gv item) 137 | (vector-set! (gvector-vec gv) index item)))) 138 | 139 | ;; creates a snapshot vector 140 | (define (gvector->vector gv) 141 | (vector-copy (gvector-vec gv) 0 (gvector-n gv))) 142 | 143 | (define (gvector->list gv) 144 | (vector->list (gvector->vector gv))) 145 | 146 | ;; constructs a gvector 147 | (define (vector->gvector v) 148 | (define lv (vector-length v)) 149 | (define gv (make-gvector #:capacity lv)) 150 | (define nv (gvector-vec gv)) 151 | (vector-copy! nv 0 v) 152 | (set-gvector-n! gv lv) 153 | gv) 154 | 155 | (define (list->gvector v) 156 | (vector->gvector (list->vector v))) 157 | 158 | ;; Iteration methods 159 | 160 | ;; A gvector position is represented as an exact-nonnegative-integer. 161 | 162 | (define (gvector-iterate-first gv) 163 | (and (positive? (gvector-n gv)) 0)) 164 | 165 | (define (gvector-iterate-next gv iter) 166 | (check-index 'gvector-iterate-next gv iter #f) 167 | (let ([n (gvector-n gv)]) 168 | (and (< (add1 iter) n) 169 | (add1 iter)))) 170 | 171 | (define (gvector-iterate-key gv iter) 172 | (check-index 'gvector-iterate-key gv iter #f) 173 | iter) 174 | 175 | (define (gvector-iterate-value gv iter) 176 | (check-index 'gvector-iterate-value gv iter #f) 177 | (gvector-ref gv iter)) 178 | 179 | (define (in-gvector gv) 180 | (unless (gvector? gv) 181 | (raise-type-error 'in-gvector "gvector" gv)) 182 | (in-dict-values gv)) 183 | 184 | (define-sequence-syntax in-gvector* 185 | (lambda () #'in-gvector) 186 | (lambda (stx) 187 | (syntax-case stx () 188 | [[(var) (in-gv gv-expr)] 189 | (with-syntax ([gv-expr-c (wrap-expr/c #'gvector? #'gv-expr #:macro #'in-gv)]) 190 | (syntax/loc stx 191 | [(var) 192 | (:do-in ([(gv) gv-expr-c]) 193 | (void) ;; outer-check; handled by contract 194 | ([index 0] [vec (gvector-vec gv)] [n (gvector-n gv)]) ;; loop bindings 195 | (< index n) ;; pos-guard 196 | ([(var) (vector-ref vec index)]) ;; inner bindings 197 | #t ;; pre-guard 198 | #t ;; post-guard 199 | ((add1 index) (gvector-vec gv) (gvector-n gv)))]))] 200 | [[(var ...) (in-gv gv-expr)] 201 | (with-syntax ([gv-expr-c (wrap-expr/c #'gvector? #'gv-expr #:macro #'in-gv)]) 202 | (syntax/loc stx 203 | [(var ...) (in-gvector gv-expr-c)]))] 204 | [_ #f]))) 205 | 206 | (define-syntax (for/gvector stx) 207 | (syntax-case stx () 208 | [(_ (clause ...) . body) 209 | (with-syntax ([((pre-body ...) post-body) (split-for-body stx #'body)]) 210 | (quasisyntax/loc stx 211 | (let ([gv (make-gvector)]) 212 | (for/fold/derived #,stx () (clause ...) 213 | pre-body ... 214 | (call-with-values (lambda () . post-body) 215 | (lambda args (apply gvector-add! gv args) (values)))) 216 | gv)))])) 217 | 218 | (define-syntax (for*/gvector stx) 219 | (syntax-case stx () 220 | [(_ (clause ...) . body) 221 | (with-syntax ([((pre-body ...) post-body) (split-for-body stx #'body)]) 222 | (quasisyntax/loc stx 223 | (let ([gv (make-gvector)]) 224 | (for*/fold/derived #,stx () (clause ...) 225 | pre-body ... 226 | (call-with-values (lambda () . post-body) 227 | (lambda args (apply gvector-add! gv args) (values)))) 228 | gv)))])) 229 | 230 | (struct gvector (vec n) 231 | #:mutable 232 | #:property prop:dict/contract 233 | (list (vector-immutable gvector-ref 234 | gvector-set! 235 | #f ;; set 236 | gvector-remove! 237 | #f ;; remove 238 | gvector-count 239 | gvector-iterate-first 240 | gvector-iterate-next 241 | gvector-iterate-key 242 | gvector-iterate-value) 243 | (vector-immutable exact-nonnegative-integer? 244 | any/c 245 | exact-nonnegative-integer? 246 | #f #f #f)) 247 | #:methods gen:equal+hash 248 | [(define (equal-proc x y recursive-equal?) 249 | (let ([vx (gvector-vec x)] 250 | [vy (gvector-vec y)] 251 | [nx (gvector-n x)] 252 | [ny (gvector-n y)]) 253 | (and (= nx ny) 254 | (for/and ([index (in-range nx)]) 255 | (recursive-equal? (vector-ref vx index) 256 | (vector-ref vy index)))))) 257 | (define (hash-code x hc) 258 | (let ([v (gvector-vec x)] 259 | [n (gvector-n x)]) 260 | (for/fold ([h 1]) ([i (in-range n)]) 261 | ;; FIXME: better way of combining hashcodes 262 | (+ h (hc (vector-ref v i)))))) 263 | (define hash-proc hash-code) 264 | (define hash2-proc hash-code)] 265 | #:methods gen:custom-write 266 | [(define write-proc 267 | (make-constructor-style-printer 268 | (lambda (obj) 'gvector) 269 | (lambda (obj) (gvector->list obj))))] 270 | #:property prop:sequence in-gvector 271 | #:property prop:serializable 272 | (make-serialize-info 273 | (λ (this) 274 | (vector (gvector->vector this))) 275 | (cons 'deserialize-gvector (module-path-index-join '(submod data/gvector deserialize) #f)) 276 | #t 277 | (or (current-load-relative-directory) (current-directory)))) 278 | 279 | (provide/contract 280 | [gvector? 281 | (-> any/c any)] 282 | [rename gvector* gvector 283 | (->* () () #:rest any/c gvector?)] 284 | [make-gvector 285 | (->* () (#:capacity exact-positive-integer?) gvector?)] 286 | [gvector-ref 287 | (->* (gvector? exact-nonnegative-integer?) (any/c) any)] 288 | [gvector-set! 289 | (-> gvector? exact-nonnegative-integer? any/c any)] 290 | [gvector-add! 291 | (->* (gvector?) () #:rest any/c any)] 292 | [gvector-insert! 293 | (-> gvector? exact-nonnegative-integer? any/c any)] 294 | [gvector-remove! 295 | (-> gvector? exact-nonnegative-integer? any)] 296 | [gvector-remove-last! 297 | (-> gvector? any)] 298 | [gvector-count 299 | (-> gvector? any)] 300 | [gvector->vector 301 | (-> gvector? vector?)] 302 | [gvector->list 303 | (-> gvector? list?)] 304 | [vector->gvector 305 | (-> vector? gvector?)] 306 | [list->gvector 307 | (-> list? gvector?)]) 308 | 309 | (provide (rename-out [in-gvector* in-gvector]) 310 | for/gvector 311 | for*/gvector) 312 | 313 | (module+ deserialize 314 | (provide deserialize-gvector) 315 | (define deserialize-gvector 316 | (make-deserialize-info 317 | (λ (vec) 318 | (vector->gvector vec)) 319 | (λ () 320 | (define gvec (make-gvector)) 321 | (values 322 | gvec 323 | (λ (other) 324 | (for ([i (in-gvector other)]) 325 | (gvector-add! gvec i)))))))) 326 | -------------------------------------------------------------------------------- /data-lib/data/order.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/dict 3 | racket/contract/base 4 | racket/string 5 | ffi/unsafe/atomic 6 | racket/private/generic) 7 | 8 | (define ordering/c 9 | (or/c '= '< '>)) 10 | 11 | (provide ordering/c) 12 | 13 | ;; we use the private version here because we need to 14 | ;; provide a backwards compatible interface (just in case) 15 | ;; i.e., exporting prop:ordered-dict as opposed to using a 16 | ;; generated hidden property. 17 | (define-primitive-generics 18 | (ordered-dict gen:ordered-dict 19 | prop:ordered-dict 20 | ordered-methods 21 | ordered-dict? 22 | ordered-dict-implements?) 23 | #:fast-defaults () 24 | #:defaults () 25 | #:fallbacks () 26 | #:derive-properties () 27 | (dict-iterate-least ordered-dict) 28 | (dict-iterate-greatest ordered-dict) 29 | (dict-iterate-least/>? ordered-dict key) 30 | (dict-iterate-least/>=? ordered-dict key) 31 | (dict-iterate-greatest/i ([d ordered-dict?]) 36 | [_r (d) (or/c #f (dict-iter-contract d))])) 37 | 38 | (define search-contract 39 | (->i ([d ordered-dict?] 40 | [k (d) (dict-key-contract d)]) 41 | [_r (d) (or/c #f (dict-iter-contract d))])) 42 | 43 | (define prop:ordered-dict-contract 44 | (let ([e (or/c extreme-contract #f)] ;; generics initializes with #f, 45 | ; then sets the methods 46 | [s (or/c search-contract #f)]) 47 | (vector/c e ;; iterate-least 48 | e ;; iterate-greatest 49 | s ;; iterate-least/>? 50 | s ;; iterate-least/>=? 51 | s ;; iterate-greatest/ any/c boolean?)] 61 | [dict-iterate-least extreme-contract] 62 | [dict-iterate-greatest extreme-contract] 63 | [dict-iterate-least/>? search-contract] 64 | [dict-iterate-least/>=? search-contract] 65 | [dict-iterate-greatest/] 86 | [else (incomparable name x y)])) 87 | = <)] 88 | [(name ctc = < >) 89 | (order name ctc 90 | (lambda (x y) 91 | (cond [(= x y) '=] 92 | [(< x y) '<] 93 | [(> x y) '>] 94 | [else (incomparable name x y)])) 95 | = <)])]) 96 | order)) 97 | 98 | (define (incomparable name x y) 99 | (error name "values are incomparable: ~e ~e" x y)) 100 | 101 | (provide/contract 102 | [rename order* order 103 | (->* (symbol? contract? procedure?) (procedure? procedure?) 104 | order?)] 105 | [order? (-> any/c boolean?)] 106 | [order-comparator 107 | (-> order? procedure?)] 108 | [order- order? procedure?)] 110 | [order-=? 111 | (-> order? procedure?)] 112 | [order-domain-contract 113 | (-> order? contract?)]) 114 | 115 | ;; ============================================================ 116 | 117 | (define (real/not-NaN? x) (and (real? x) (not (eqv? x +nan.0)))) 118 | 119 | (define real-order 120 | (order* 'real-order real/not-NaN? = < >)) 121 | 122 | (provide/contract 123 | [real-order order?]) 124 | 125 | ;; ============================================================ 126 | 127 | #| 128 | natural-cmp : Comparator 129 | datum-cmp : Comparator 130 | 131 | comparators for (most) built-in values 132 | !! May diverge on cyclical input. 133 | 134 | natural-cmp: 135 | * restriction to reals equiv to <,= 136 | 137 | real (exact and inexact, #e1 = #i1, +nan.0 not allowed!) 138 | < complex 139 | < Other 140 | 141 | datum-cmp: 142 | * restriction to reals NOT EQUIV to <,= (separates exact, inexact) 143 | 144 | exact real 145 | < inexact real (+nan.0 > +inf.0) 146 | < complex 147 | < Other 148 | 149 | Other: 150 | 151 | string 152 | < bytes 153 | < keyword 154 | < symbol 155 | < bool 156 | < char 157 | < path 158 | < null 159 | < pair 160 | < vector 161 | < box 162 | < prefab-struct 163 | < fully-transparent-struct 164 | 165 | ;; FIXME: What else to add? regexps (4 kinds?), syntax, ... 166 | 167 | |# 168 | 169 | ;; not exported because I'm not sure it's a good idea and I'm not sure 170 | ;; how to characterize it 171 | (define (natural-cmp x y) 172 | (gen-cmp x y #t)) 173 | 174 | (define (datum-cmp x y) 175 | (gen-cmp x y #f)) 176 | 177 | (define (gen-cmp x y natural?) 178 | (define-syntax-rule (recur x* y*) 179 | (gen-cmp x* y* natural?)) 180 | (cond [(eq? x y) '=] 181 | #| 182 | [(T? x) ...] 183 | ;; at this point, Type(x) > T 184 | [(T? y) 185 | ;; Type(x) > T = Type(y), so: 186 | '>] 187 | Assumes arguments are legal. 188 | |# 189 | [(real? x) 190 | (if (real? y) 191 | (cond [natural? 192 | (cmp* < = x y)] 193 | [else ;; exact < inexact 194 | (cond [(and (exact? x) (exact? y)) 195 | (cmp* < = x y)] 196 | [(exact? x) ;; inexact y 197 | '<] 198 | [(exact? y) ;; inexact x 199 | '>] 200 | [(and (eqv? x +nan.0) (eqv? y +nan.0)) 201 | '=] 202 | [(eqv? x +nan.0) 203 | '>] 204 | [(eqv? y +nan.0) 205 | '<] 206 | [else ;; inexact x, inexact y 207 | (cmp* < = x y)])]) 208 | '<)] 209 | [(real? y) '>] 210 | [(complex? x) 211 | (if (complex? y) 212 | (lexico (recur (real-part x) (real-part y)) 213 | (recur (imag-part x) (imag-part y))) 214 | '<)] 215 | [(complex? y) '>] 216 | [(string? x) 217 | (if (string? y) 218 | (cmp* string] 221 | [(bytes? x) 222 | (if (bytes? y) 223 | (cmp* bytes] 226 | [(keyword? x) 227 | (if (keyword? y) 228 | (cmp* keyword] 231 | [(symbol? x) 232 | (if (symbol? y) 233 | (cmp* symbol] 236 | [(boolean? x) 237 | (if (boolean? y) 238 | (cond [(eq? x y) '=] 239 | [y '<] 240 | [else '>]) 241 | '<)] 242 | [(boolean? y) '>] 243 | [(char? x) 244 | (if (char? y) 245 | (cmp* char] 249 | [(path-for-some-system? x) 250 | (if (path-for-some-system? y) 251 | (cmp* bytesbytes x) (path->bytes y)) 252 | '<)] 253 | [(path-for-some-system? y) 254 | '>] 255 | [(null? x) 256 | (if (null? y) 257 | '= 258 | '<)] 259 | [(null? y) '>] 260 | [(pair? x) 261 | (if (pair? y) 262 | (lexico (recur (car x) (car y)) (recur (cdr x) (cdr y))) 263 | '<)] 264 | [(pair? y) '>] 265 | [(vector? x) 266 | (if (vector? y) 267 | (vector-cmp x y 0 natural?) 268 | '<)] 269 | [(vector? y) '>] 270 | [(box? x) 271 | (if (box? y) 272 | (recur (unbox x) (unbox y)) 273 | '<)] 274 | [(box? y) '>] 275 | [(prefab-struct-key x) 276 | (if (prefab-struct-key y) 277 | (lexico (recur (prefab-struct-key x) (prefab-struct-key y)) 278 | ;; FIXME: use struct-ref to avoid allocation? 279 | (vector-cmp (struct->vector x) (struct->vector y) 1 natural?)) 280 | '<)] 281 | [(prefab-struct-key y) 282 | '>] 283 | [(fully-transparent-struct-type x) 284 | => (lambda (xtype) 285 | (cond [(fully-transparent-struct-type y) 286 | => (lambda (ytype) 287 | ;; could also do another lexico with object-name first 288 | (lexico (object-cmp xtype ytype) 289 | ;; FIXME: use struct-ref to avoid allocation? 290 | (vector-cmp (struct->vector x) (struct->vector y) 291 | 1 natural?)))] 292 | [else '<]))] 293 | [(fully-transparent-struct-type y) 294 | '>] 295 | [else 296 | (raise-type-error 297 | (if natural? 'natural-cmp 'datum-cmp) 298 | (string-join '("number" "string" "bytes" "keyword" "symbol" "boolean" "character" 299 | "path" "null" "pair" "vector" "box" 300 | "prefab struct" "or fully-transparent struct") 301 | ", ") 302 | 0 x y)])) 303 | 304 | (define-syntax-rule (cmp* )))) 307 | 308 | (define-syntax-rule (lexico c1 c2) 309 | (case c1 310 | ((<) '<) 311 | ((=) c2) 312 | ((>) '>))) 313 | 314 | (define (vector-cmp x y i natural?) 315 | (cond [(< i (vector-length x)) 316 | (if (< i (vector-length y)) 317 | (lexico (gen-cmp (vector-ref x i) (vector-ref y i) natural?) 318 | (vector-cmp x y (add1 i) natural?)) 319 | '>)] 320 | [(< i (vector-length y)) 321 | '<] 322 | [else '=])) 323 | 324 | ;; fully-transparent-struct-type : any -> struct-type or #f 325 | (define (fully-transparent-struct-type x) 326 | (parameterize ((current-inspector weak-inspector)) 327 | (let-values ([(x-type x-skipped?) (struct-info x)]) 328 | (and (not x-skipped?) x-type)))) 329 | 330 | ;; weak inspector controls no struct types; 331 | ;; so if it can inspect, must be transparent 332 | (define weak-inspector (make-inspector)) 333 | 334 | ;; Impose an arbitrary (but consistent) ordering on eq?-compared 335 | ;; objects. Use eq? and eq-hash-code for common fast path. Fall back 336 | ;; to table when comparing struct-types *same eq-hash-code* but *not 337 | ;; eq?*. That should be rare. 338 | (define object-order-table (make-weak-hasheq)) 339 | (define object-order-next 0) 340 | (define (object-cmp x y) 341 | (cond [(eq? x y) '=] 342 | [else 343 | (lexico 344 | (cmp* < = (eq-hash-code x) (eq-hash-code y)) 345 | (call-as-atomic 346 | (lambda () 347 | (let ([xi (hash-ref object-order-table x #f)] 348 | [yi (hash-ref object-order-table y #f)]) 349 | (cond [(and xi yi) 350 | ;; x not eq? y, so xi != yi 351 | (if (< xi yi) '< '>)] 352 | [xi '<] 353 | [yi '>] 354 | [else ;; neither one is in table; we only need to add one 355 | (hash-set! object-order-table x object-order-next) 356 | (set! object-order-next (add1 object-order-next)) 357 | '<])))))])) 358 | 359 | (define datum-order 360 | (order* 'datum-order any/c datum-cmp)) 361 | 362 | (provide/contract 363 | [datum-order order?]) 364 | -------------------------------------------------------------------------------- /data-test/tests/data/ordered-dict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit 3 | rackunit/text-ui 4 | racket/contract 5 | racket/dict 6 | data/skip-list 7 | ;; (prefix-in nc: (submod data/skip-list no-contracts)) 8 | data/splay-tree 9 | data/order) 10 | 11 | ;; Tests for ordered dictionaries 12 | ;; - skip-list 13 | ;; - splay-tree (both kinds) 14 | 15 | (define KEY-CT 5000) 16 | (define REM-CT 500) 17 | (define SEARCH-CT 5000) 18 | 19 | (define VAL-LB -100000) 20 | (define VAL-UB 100000) 21 | (define (rand) (+ (random (- VAL-UB VAL-LB)) VAL-LB)) 22 | 23 | (define TEST? #t) 24 | (define LOUD? #f) 25 | (define IDK? #f) 26 | 27 | (define-syntax-rule (time* label body ...) 28 | (let ([f (lambda () body ...)]) (if LOUD? (timef label f) (f)))) 29 | 30 | (define (timef label f) 31 | (let-values ([(vs cpu real gc) (time-apply f null)]) 32 | (printf " ~a: cpu ~s, real ~s, gc ~s\n" label cpu real gc) 33 | (apply values vs))) 34 | 35 | (define-syntax-rule (rand-test dicts ordered? idk? 36 | (-ref 37 | -set! 38 | -remove! 39 | -count 40 | -has-key? 41 | -iterate-key 42 | -iterate-least/>? 43 | -iterate-least/>=? 44 | -iterate-greatest/i (-iterate-least/>? d k0)] 98 | [l>=i (-iterate-least/>=? d k0)] 99 | [g (and l>i (-iterate-key d l>i))] 102 | [l>= (and l>=i (-iterate-key d l>=i))] 103 | [g< (and g= g<= "has, should be same")) 107 | (unless has? 108 | (check-equal? l> l>= "not has, should be same") 109 | (check-equal? g< g<= "not has, should be same")) 110 | (when l> (check > l> k0)) 111 | (when l>= (check >= l>= k0)) 112 | (when g< (check < g< k0)) 113 | (when g<= (check <= g<= k0)) 114 | (when (and IDK? idk? (zero? (modulo c 15))) 115 | (for ([k (in-dict-keys d)]) 116 | (when (and l> (and (> k k0) (< k l>))) (error "l>")) 117 | (when (and l>= (and (>= k k0) (< k l>=))) (error "l>=")) 118 | (when (and g< (and (< k k0) (> k g<))) (error "g<")) 119 | (when (and g<= (and (<= k k0) (> k g<=))) (error "g<=")))))))))) 120 | )) 121 | 122 | ;; Test dict interface 123 | 124 | (define (dict-test dicts ordered? [idk? #f]) 125 | (rand-test dicts ordered? idk? 126 | (dict-ref 127 | dict-set! 128 | dict-remove! 129 | dict-count 130 | dict-has-key? 131 | dict-iterate-key 132 | dict-iterate-least/>? 133 | dict-iterate-least/>=? 134 | dict-iterate-greatest/? 169 | splay-tree-iterate-least/>=? 170 | splay-tree-iterate-greatest/? 196 | skip-list-iterate-least/>=? 197 | skip-list-iterate-greatest/? 222 | nc:skip-list-iterate-least/>=? 223 | nc:skip-list-iterate-greatest/? 251 | '-iterate-least/>=? 252 | '-iterate-greatest/list" 369 | (define t (make-splay-tree)) 370 | (splay-tree-set! t 1 'a) 371 | (splay-tree-set! t 2 'b) 372 | (splay-tree-set! t 3 'c) 373 | (check-equal? (splay-tree->list t) 374 | '((1 . a) (2 . b) (3 . c)))))) 375 | -------------------------------------------------------------------------------- /data-lib/data/heap.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/vector 4 | racket/match) 5 | 6 | (define MIN-SIZE 4) 7 | 8 | (struct heap ([vec #:mutable] [count #:mutable] <=? [elt=>idx #:mutable])) 9 | ;; length(vec)/4 <= size <= length(vec), except size >= MIN-SIZE 10 | ;; size = next available index 11 | 12 | ;; A VT is a binary tree represented as a vector. 13 | 14 | ;; VT Index functions 15 | 16 | (define (vt-root) 0) 17 | 18 | (define (vt-parent n) (quotient (sub1 n) 2)) 19 | (define (vt-leftchild n) (+ (* n 2) 1)) 20 | (define (vt-rightchild n) (+ (* n 2) 2)) 21 | 22 | (define (vt-root? n) (zero? n)) 23 | (define (vt-leftchild? n) (odd? n)) 24 | (define (vt-rightchild? n) (even? n)) 25 | 26 | (define (set-index! elt=>idx k n) 27 | (when elt=>idx (hash-set! elt=>idx k n))) 28 | 29 | (define (remove-index! elt=>idx k) 30 | (when elt=>idx (hash-remove! elt=>idx k))) 31 | 32 | (define (get-index-eq h k) 33 | (define elt=>idx 34 | (or (heap-elt=>idx h) 35 | (match h 36 | [(heap vec size <=? elt=>idx) 37 | (let ([elt=>idx (make-hasheq)]) 38 | (for ([idx (in-range size)] [elt (in-vector vec)]) 39 | (hash-set! elt=>idx elt idx)) 40 | (set-heap-elt=>idx! h elt=>idx) 41 | elt=>idx)]))) 42 | (hash-ref elt=>idx k #f)) 43 | 44 | ;; Operations 45 | 46 | ;; Instead of exchanging the parent and the child at each iteration, 47 | ;; only the child is updated, whereas the parent needs to be update 48 | ;; only once, after the loop. 49 | (define (heapify-up <=? vec n elt=>idx) 50 | (define n-key (vector-ref vec n)) 51 | (define new-n 52 | (let loop ([n n]) 53 | (cond 54 | [(vt-root? n) n] 55 | [else 56 | (define parent (vt-parent n)) 57 | (define parent-key (vector-ref vec parent)) 58 | (cond 59 | [(<=? parent-key n-key) 60 | n] 61 | [else 62 | (vector-set! vec n parent-key) 63 | (set-index! elt=>idx parent-key n) 64 | #;(vector-set! vec parent key) ; this can wait until after the loop 65 | (loop parent)])]))) 66 | (unless (= n new-n) 67 | ; All parent updates are collapsed into this one: 68 | (vector-set! vec new-n n-key) 69 | (set-index! elt=>idx n-key new-n))) 70 | 71 | ;; See comment for heapify-up 72 | (define (heapify-down <=? vec n size elt=>idx) 73 | (define n-key (vector-ref vec n)) 74 | (define new-n 75 | (let loop ([n n]) 76 | (define left (vt-leftchild n)) 77 | (define right (vt-rightchild n)) 78 | (cond 79 | [(< left size) 80 | (define left-key (vector-ref vec left)) 81 | (define-values (child child-key) 82 | (if (< right size) 83 | (let ([right-key (vector-ref vec right)]) 84 | (if (<=? left-key right-key) 85 | (values left left-key) 86 | (values right right-key))) 87 | (values left left-key))) 88 | (cond 89 | [(<=? n-key child-key) n] 90 | [else 91 | (vector-set! vec n child-key) 92 | #;(vector-set! vec child n-key) ; this can wait until after the loop 93 | (set-index! elt=>idx child-key n) 94 | (loop child)])] 95 | [else n]))) 96 | (unless (= n new-n) 97 | (vector-set! vec new-n n-key) 98 | (set-index! elt=>idx n-key new-n))) 99 | 100 | (define (fittest-block-size n) 101 | (max MIN-SIZE 102 | (expt 2 (integer-length (- n 1)) 103 | #;(exact-ceiling (log (max 1 n) 2))))) 104 | 105 | ;; Grow the vector to the fittest 2^n ≥ new-size-min 106 | (define (grow-vector v1 new-size-min) 107 | (define new-size 108 | (max (vector-length v1) 109 | (fittest-block-size new-size-min))) 110 | (define v2 (make-vector new-size #f)) 111 | (vector-copy! v2 0 v1 0) 112 | v2) 113 | 114 | ;; Shrink to the fittest vector of size 2^n ≥ new-size-min 115 | (define (shrink-vector v1 new-size-min) 116 | (define new-size (fittest-block-size new-size-min)) 117 | (define v2 (make-vector new-size #f)) 118 | (vector-copy! v2 0 v1 0 new-size) 119 | v2) 120 | 121 | ;; Heaps 122 | 123 | (define (make-heap <=?) 124 | (heap (make-vector MIN-SIZE #f) 0 <=? #f)) 125 | 126 | (define (list->heap <=? lst) 127 | (vector->heap <=? (list->vector lst))) 128 | 129 | (define (vector->heap <=? vec0 [start 0] [end (vector-length vec0)]) 130 | (define size (- end start)) 131 | (define vec (make-vector (fittest-block-size size) #f)) 132 | ;; size <= length(vec) 133 | (vector-copy! vec 0 vec0 start end) 134 | (for ([n (in-range (sub1 size) -1 -1)]) 135 | (heapify-down <=? vec n size #f)) 136 | (heap vec size <=? #f)) 137 | 138 | (define (heap-copy h) 139 | (match h 140 | [(heap vec count <=? elt=>idx) 141 | ;; Should elt=>idx (if initialized) be copied over too? 142 | ;; Only worthwhile if heap-remove! will be used on new heap, 143 | ;; which it isn't in the in-heap use case. 144 | (heap (vector-copy vec) count <=? #f)])) 145 | 146 | (define (heap-add! h . keys) 147 | (heap-add-all! h (list->vector keys))) 148 | 149 | (define (heap-add-all! h keys) 150 | (let-values ([(keys keys-size) 151 | (cond [(list? keys) 152 | (let ([keys-v (list->vector keys)]) 153 | (values keys-v (vector-length keys-v)))] 154 | [(vector? keys) 155 | (values keys (vector-length keys))] 156 | [(heap? keys) 157 | (values (heap-vec keys) (heap-count keys))])]) 158 | (match h 159 | [(heap vec size <=? elt=>idx) 160 | (let* ([new-size (+ size keys-size)] 161 | [vec (if (> new-size (vector-length vec)) 162 | (let ([vec (grow-vector vec new-size)]) 163 | (set-heap-vec! h vec) 164 | vec) 165 | vec)]) 166 | (vector-copy! vec size keys 0 keys-size) 167 | (for ([n (in-range size new-size)] 168 | [item (in-vector vec size)]) 169 | (set-index! elt=>idx item n) 170 | (heapify-up <=? vec n elt=>idx)) 171 | (set-heap-count! h new-size))]))) 172 | 173 | (define (heap-min h) 174 | (match h 175 | [(heap vec size <=? elt=>idx) 176 | (when (zero? size) 177 | (error 'heap-min "empty heap")) 178 | (vector-ref vec 0)])) 179 | 180 | (define (heap-remove-min! h) 181 | (when (zero? (heap-count h)) 182 | (error 'heap-remove-min! "empty heap")) 183 | (heap-remove-index! h 0)) 184 | 185 | (define (heap-remove-index! h index) 186 | (match h 187 | [(heap vec size <=? elt=>idx) 188 | (unless (< index size) 189 | (if (zero? size) 190 | (error 'heap-remove-index! 191 | "empty heap: ~s" index) 192 | (error 'heap-remove-index! 193 | "index out of bounds [0,~s]: ~s" (sub1 size) index))) 194 | (define sub1-size (sub1 size)) 195 | (define last-item (vector-ref vec sub1-size)) 196 | (define removed-item (vector-ref vec index)) 197 | (vector-set! vec index last-item) 198 | (vector-set! vec sub1-size #f) 199 | (when elt=>idx 200 | (set-index! elt=>idx last-item index) 201 | (remove-index! elt=>idx removed-item)) 202 | (cond 203 | [(= sub1-size index) 204 | ;; easy to remove the right-most leaf 205 | (void)] 206 | [(= index 0) 207 | ;; can only go down when at the root 208 | (heapify-down <=? vec index sub1-size elt=>idx)] 209 | [else 210 | (define index-parent (vt-parent index)) 211 | (cond 212 | ;; if we are in the right relationship with our parent, 213 | ;; try to heapify down 214 | [(<=? (vector-ref vec index-parent) (vector-ref vec index)) 215 | (heapify-down <=? vec index sub1-size elt=>idx)] 216 | [else 217 | ;; otherwise we need to heapify up 218 | (heapify-up <=? vec index elt=>idx)])]) 219 | (when (< MIN-SIZE size (quotient (vector-length vec) 4)) 220 | (set-heap-vec! h (shrink-vector vec size))) 221 | (set-heap-count! h sub1-size)])) 222 | 223 | (define (heap-get-index h v same?) 224 | (match h 225 | [(heap vec size <=? elt=>idx) 226 | (and (not (eq? 0 size)) 227 | (let search ([n 0] [n-key (vector-ref vec 0)]) 228 | (cond 229 | [(same? n-key v) n] 230 | ;; The heap property ensures n-key <= all its children 231 | [else 232 | (define (search-right) 233 | (define right (vt-rightchild n)) 234 | (and (< right size) 235 | (let ([right-key (vector-ref vec right)]) 236 | (and (<=? right-key v) 237 | (search right right-key))))) 238 | ;; Try going left if the left child is <= v 239 | (define left (vt-leftchild n)) 240 | (and (< left size) ;; if no left, there can't be a right. 241 | (let ([left-key (vector-ref vec left)]) 242 | ;; If left <= v, try left side. 243 | (if (<=? left-key v) 244 | (or (search left left-key) (search-right)) 245 | (search-right))))])))])) 246 | 247 | ;; Returns whether the removal was successful, that is, 248 | ;; whether v was indeed in the heap. 249 | (define (heap-remove! h v #:same? [same? equal?]) 250 | (define idx (heap-get-index h v same?)) 251 | (and idx 252 | (begin 253 | (heap-remove-index! h idx) 254 | #t))) 255 | 256 | ;;; Long discussion with comparisons of different approaches here: 257 | ;;; https://github.com/racket/data/pull/16 258 | ;;; https://github.com/racket/data/pull/14 259 | (define (heap-remove-eq! h v) 260 | (define idx (get-index-eq h v)) 261 | (cond [idx 262 | (unless (eq? v (vector-ref (heap-vec h) idx)) 263 | (error 'heap-remove-eq! 264 | (string-append "the key is not at the expected index;\n" 265 | " due to concurrent modification or an internal error\n" 266 | " key: ~e") v)) 267 | (heap-remove-index! h idx) 268 | #t] 269 | [else #f])) 270 | 271 | 272 | (define (in-heap h) 273 | (in-heap/consume! (heap-copy h))) 274 | 275 | (define (in-heap/consume! h) 276 | (make-do-sequence 277 | (lambda () 278 | (values (lambda (_) (heap-min h)) 279 | (lambda (_) (heap-remove-min! h) #t) 280 | #t 281 | (lambda (_) (> (heap-count h) 0)) 282 | (lambda _ #t) 283 | (lambda _ #t))))) 284 | 285 | ;; -------- 286 | 287 | ;; preferred order is (heap-sort vec <=?), but allow old order too 288 | (define (heap-sort! x y) 289 | (cond [(and (vector? x) (procedure? y)) 290 | (heap-sort!* x y)] 291 | [(and (vector? y) (procedure? x)) 292 | (heap-sort!* y x)] 293 | [else 294 | (unless (vector? x) 295 | (raise-argument-error 'heap-sort! "vector?" x)) 296 | (raise-argument-error 'heap-sort! "procedure?" y)])) 297 | 298 | (define (heap-sort!* v <=?) 299 | ;; to get ascending order, need max-heap, so reverse comparison 300 | (define (>=? x y) (<=? y x)) 301 | (define size (vector-length v)) 302 | (for ([n (in-range (sub1 size) -1 -1)]) 303 | (heapify-down >=? v n size #f)) 304 | (for ([last (in-range (sub1 size) 0 -1)]) 305 | (let ([tmp (vector-ref v 0)]) 306 | (vector-set! v 0 (vector-ref v last)) 307 | (vector-set! v last tmp)) 308 | (heapify-down >=? v 0 last #f))) 309 | 310 | (define (heap->vector h) 311 | (match h 312 | [(heap vec size <=? elt=>idx) 313 | (let ([v (vector-copy vec 0 size)]) 314 | (heap-sort!* v <=?) 315 | v)])) 316 | 317 | ;; -------- 318 | 319 | (provide 320 | (contract-out 321 | #:unprotected-submodule unchecked 322 | [make-heap (-> (and (procedure-arity-includes/c 2) 323 | (unconstrained-domain-> any/c)) 324 | heap?)] 325 | [heap? (-> any/c boolean?)] 326 | [heap-count (-> heap? exact-nonnegative-integer?)] 327 | [heap-add! (->* (heap?) () #:rest list? void?)] 328 | [heap-add-all! (-> heap? (or/c list? vector? heap?) void?)] 329 | [heap-min (-> heap? any/c)] 330 | [heap-remove-min! (-> heap? void?)] 331 | [heap-remove! (->* (heap? any/c) [#:same? (-> any/c any/c any/c)] boolean?)] 332 | [heap-remove-eq! (-> heap? any/c boolean?)] 333 | 334 | [vector->heap (-> (and (procedure-arity-includes/c 2) 335 | (unconstrained-domain-> any/c)) 336 | vector? 337 | heap?)] 338 | [heap->vector (-> heap? vector?)] 339 | [heap-copy (-> heap? heap?)] 340 | 341 | [in-heap (-> heap? sequence?)] 342 | [in-heap/consume! (-> heap? sequence?)])) 343 | 344 | (provide heap-sort!) ; checks done in-function 345 | 346 | (module+ test-util 347 | (provide valid-heap? 348 | fittest-block-size 349 | MIN-SIZE) 350 | (define (valid-heap? a-heap) 351 | (match a-heap 352 | [(heap vec size <=? elt=>idx) 353 | (let loop ([i 0] 354 | [parent -inf.0]) 355 | (cond 356 | [(< i size) 357 | (define this (vector-ref vec i)) 358 | (and (<=? parent this) 359 | (loop (vt-leftchild i) this) 360 | (loop (vt-rightchild i) this))] 361 | [else #t]))]))) 362 | -------------------------------------------------------------------------------- /data-enumerate-lib/data/enumerate.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "enumerate/private/core.rkt" 3 | racket/contract 4 | racket/math 5 | racket/list 6 | racket/bool) 7 | 8 | (provide 9 | in-enum 10 | (contract-out 11 | [enum? (-> any/c boolean?)] 12 | [finite-enum? (-> any/c boolean?)] 13 | [infinite-enum? (-> any/c boolean?)] 14 | [two-way-enum? (-> any/c boolean?)] 15 | [one-way-enum? (-> any/c boolean?)] 16 | [flat-enum? (-> any/c boolean?)] 17 | 18 | [from-nat 19 | (->i ([e enum?] 20 | [n natural?]) 21 | #:pre/name (e n) 22 | "n in bounds of enumeration size" 23 | (or (infinite-enum? e) 24 | (< n (enum-count e))) 25 | [res (e) (enum-contract e)])] 26 | [to-nat 27 | (->i ([e two-way-enum?] [v (e) (enum-contract e)]) 28 | [result natural?])] 29 | [enum-count (-> finite-enum? natural?)] 30 | [enum-contract (-> enum? contract?)] 31 | 32 | [enum->list 33 | (->i ([e enum?]) 34 | ([s (e) (if (finite-enum? e) 35 | (integer-in 0 (enum-count e)) 36 | natural?)]) 37 | #:pre (e s) 38 | (implies (unsupplied-arg? s) (finite-enum? e)) 39 | [res (e) (listof (enum-contract e))])] 40 | 41 | [natural/e enum?] 42 | [below/e (-> (or/c natural? +inf.0) enum?)] 43 | [empty/e enum?] 44 | 45 | [map/e 46 | (->i ([in (e es c) 47 | (cond 48 | [(null? es) 49 | (-> (enum-contract e) c)] 50 | [else 51 | (dynamic->* #:mandatory-domain-contracts (map enum-contract (cons e es)) 52 | #:range-contracts (list c))])] 53 | [out (e es c) 54 | (cond 55 | [(null? es) 56 | (-> c (enum-contract e))] 57 | [else 58 | (dynamic->* #:mandatory-domain-contracts (list c) 59 | #:range-contracts (map enum-contract (cons e es)))])] 60 | [e enum?] 61 | #:contract [c contract?]) 62 | #:rest [es (listof enum?)] 63 | #:pre/desc (in out e es) 64 | (appears-to-be-a-bijection? in out (cons e es)) 65 | [result enum?])] 66 | [pam/e (->i ([in (e es c) 67 | (cond 68 | [(null? es) 69 | (-> (enum-contract e) c)] 70 | [else 71 | (dynamic->* #:mandatory-domain-contracts (map enum-contract (cons e es)) 72 | #:range-contracts (list c))])] 73 | [e enum?] 74 | #:contract [c contract?]) 75 | #:rest [es (listof enum?)] 76 | [result one-way-enum?])] 77 | [except/e 78 | (->i ([e two-way-enum?]) 79 | (#:contract [c (or/c #f contract?)]) ;; aka optional #f isn't considered a contract 80 | #:rest [more (e) (listof (enum-contract e))] 81 | [res two-way-enum?])] 82 | 83 | [or/e 84 | (->i () 85 | (#:one-way-enum? [is-one-way-enum? boolean?]) 86 | #:rest 87 | [enums (listof (or/c (cons/c enum? (-> any/c boolean?)) 88 | enum?))] 89 | #:pre/name (enums is-one-way-enum?) 90 | "the enums must either have at least one one-way-enum?\n or must all either be flat-enum? or have predicates" 91 | (or (and is-one-way-enum? 92 | (not (unsupplied-arg? is-one-way-enum?))) 93 | (either-a-one-way-enum-or-all-have-predicates? enums)) 94 | #:pre/desc (enums is-one-way-enum?) 95 | (non-overlapping? enums is-one-way-enum?) 96 | [result enum?])] 97 | [append/e 98 | (->i ([first (or/c (cons/c enum? (-> any/c boolean?)) 99 | enum?)]) 100 | (#:one-way-enum? [is-one-way-enum? boolean?]) 101 | #:rest [rest (listof (or/c (cons/c enum? (-> any/c boolean?)) 102 | enum?))] 103 | #:pre/name (first rest is-one-way-enum?) 104 | "the enums must either have at least one one-way-enum?\n or must all either be flat-enum? or have predicates" 105 | (or (and is-one-way-enum? 106 | (not (unsupplied-arg? is-one-way-enum?))) 107 | (either-a-one-way-enum-or-all-have-predicates? (cons first rest))) 108 | #:pre/desc (first rest is-one-way-enum?) 109 | (non-overlapping? (cons first rest) is-one-way-enum?) 110 | [result enum?])] 111 | [thunk/e 112 | (->i ([mk-e (size is-two-way-enum? is-flat-enum?) 113 | (-> (and/c (if (or (unsupplied-arg? size) (= size +inf.0)) 114 | infinite-enum? 115 | (and/c finite-enum? 116 | (let ([matching-size? (λ (e) (= (enum-count e) size))]) 117 | matching-size?))) 118 | (if (or (unsupplied-arg? is-two-way-enum?) is-two-way-enum?) 119 | two-way-enum? 120 | one-way-enum?) 121 | (if (or (unsupplied-arg? is-flat-enum?) is-flat-enum?) 122 | flat-enum? 123 | (not/c flat-enum?))))]) 124 | (#:count 125 | [size extended-nat/c] 126 | #:two-way-enum? 127 | [is-two-way-enum? boolean?] 128 | #:flat-enum? 129 | [is-flat-enum? boolean?]) 130 | [result enum?])] 131 | [list/e 132 | (->* () 133 | (#:ordering (or/c 'diagonal 'square)) 134 | #:rest (listof enum?) 135 | enum?)] 136 | [bounded-list/e (-> natural? natural? enum?)] 137 | [dep/e dep/e-contract])) 138 | 139 | (define (either-a-one-way-enum-or-all-have-predicates? r) 140 | (cond 141 | [(has-one-way-enum? r) 142 | #t] 143 | [(for/and ([e/p (in-list r)]) 144 | (or (flat-enum? e/p) 145 | (pair? e/p))) 146 | #t] 147 | [else #f])) 148 | 149 | (define (non-overlapping? enum/pairs is-one-way-enum?) 150 | (define upper-limit-to-explore 1000) 151 | (define howmany (length enum/pairs)) 152 | (cond 153 | [(or (and is-one-way-enum? 154 | (not (unsupplied-arg? is-one-way-enum?))) 155 | (has-one-way-enum? enum/pairs)) 156 | #t] 157 | [(< howmany 2) #t] 158 | [else 159 | (define enums 160 | (for/list ([i (in-list enum/pairs)]) 161 | (if (pair? i) (car i) i))) 162 | (define preds 163 | (for/list ([i (in-list enum/pairs)]) 164 | (if (pair? i) (cdr i) (flat-contract-predicate (enum-contract i))))) 165 | (let/ec k 166 | (parameterize ([give-up-escape (λ () (k #t))]) 167 | (for ([x (in-range 10)]) 168 | (define starter-enum-index/zero-based (random howmany)) 169 | (define starter-enum-index/one-based (+ starter-enum-index/zero-based 1)) 170 | (define starter-enum (list-ref enums starter-enum-index/zero-based)) 171 | (when (or (infinite-enum? starter-enum) 172 | (not (zero? (enum-count starter-enum)))) 173 | (define index (random (if (finite-enum? starter-enum) 174 | (min upper-limit-to-explore (enum-count starter-enum)) 175 | upper-limit-to-explore))) 176 | (define value (from-nat starter-enum index)) 177 | (define true-returning-indicies/one-based 178 | (for/list ([pred (in-list preds)] 179 | [i (in-naturals)] 180 | #:when (pred value)) 181 | (+ i 1))) 182 | 183 | (unless (member starter-enum-index/one-based true-returning-indicies/one-based) 184 | (k 185 | (list 186 | (format "enumeration passed as argument ~a has a predicate that does not" 187 | starter-enum-index/one-based) 188 | "accept one of the values that the enumeration itself produces," 189 | (format "index: ~a" index) 190 | (format "value: ~e" value)))) 191 | 192 | (when (> (length true-returning-indicies/one-based) 1) 193 | (define exactly-two? (= 2 (length true-returning-indicies/one-based))) 194 | (define other-enums-indicies 195 | (remove starter-enum-index/one-based true-returning-indicies/one-based)) 196 | (define prefix 197 | (list "new enumeration would not be two-way because of overlapping predicates" 198 | (format 199 | "the enum passed as argument ~a, when passed to `from-nat' with index ~a" 200 | starter-enum-index/one-based 201 | index) 202 | (format "produces ~e," value) 203 | (cond 204 | [exactly-two? 205 | (format "and the enumeration passed as argument ~a also accepts that value" 206 | (car other-enums-indicies))] 207 | [else 208 | (format "and the enumerations passed as arguments~a also accept that value" 209 | (cond 210 | [(= 2 (length other-enums-indicies)) 211 | (format " ~a and ~a" 212 | (car other-enums-indicies) 213 | (cadr other-enums-indicies))] 214 | [else 215 | (apply string-append 216 | (let loop ([is other-enums-indicies]) 217 | (cond 218 | [(null? (cdr is)) 219 | (list (format " and ~a" (car is)))] 220 | [else 221 | (cons (format " ~a," (car is)) 222 | (loop (cdr is)))])))]))]))) 223 | (k (append prefix 224 | (for/list ([i (in-list true-returning-indicies/one-based)]) 225 | (format "arg ~a: ~e" i (list-ref enum/pairs (- i 1))))))))) 226 | #t))])) 227 | 228 | (define (has-one-way-enum? r) 229 | (for/or ([e/p (in-list r)]) 230 | (or (one-way-enum? e/p) 231 | (and (pair? e/p) 232 | (one-way-enum? (car e/p)))))) 233 | 234 | (define extended-nat/c (or/c natural? +inf.0)) 235 | 236 | (define (appears-to-be-a-bijection? in out es) 237 | (cond 238 | [(for/or ([e (in-list es)]) 239 | (zero? (enum-count e))) 240 | ;; can't check bijection on empty enumerations 241 | #t] 242 | [(for/or ([e (in-list es)]) 243 | (one-way-enum? e)) 244 | ;; we aren't going to build a bijection if 245 | ;; we aren't starting with two-way enumerations 246 | #t] 247 | [else 248 | (let/ec k 249 | (parameterize ([give-up-escape (λ () (k #t))]) 250 | (for ([x (in-range 10)]) 251 | (define indicies 252 | (for/list ([e (in-list es)]) 253 | (random (if (infinite-enum? e) 254 | 1000 255 | (min 1000 (enum-count e)))))) 256 | (define elements 257 | (for/list ([i (in-list indicies)] 258 | [e (in-list es)]) 259 | (from-nat e i))) 260 | (define round-trip-elements 261 | (call-with-values 262 | (λ () (out (apply in elements))) 263 | list)) 264 | (define round-trip-indicies 265 | (for/list ([element (in-list round-trip-elements)] 266 | [e (in-list es)]) 267 | (to-nat e element))) 268 | (unless (equal? indicies round-trip-indicies) 269 | (define line1 "new enumeration would not be two-way") 270 | (cond 271 | [(null? (cdr es)) 272 | (k (list line1 273 | (format "passing ~a to `from-nat` produces:" 274 | (car indicies)) 275 | (to-values elements) 276 | "which, when passed through `in' and `out', produces:" 277 | (to-values round-trip-elements) 278 | (format "which, when passed to `to-nat' produces ~a," 279 | (car round-trip-indicies)) 280 | (format "but it should have been ~a" 281 | (car indicies))))] 282 | [else 283 | (k (append 284 | (list line1 285 | "using `from-nat' with these indicies in the given enumerations:" 286 | (to-values indicies) 287 | "produces these values:") 288 | (for/list ([e (in-list elements)]) 289 | (format " ~e" e)) 290 | (list "which, when passed through `in' and `out', produces these values:" 291 | (to-values round-trip-elements) 292 | "which results in these indicies:") 293 | (for/list ([e (in-list elements)]) 294 | (format " ~e" e))))]))) 295 | #t))])) 296 | 297 | 298 | (define (to-values eles) 299 | (apply 300 | string-append 301 | (for/list ([e (in-list eles)]) 302 | (format " ~e" e)))) 303 | --------------------------------------------------------------------------------