├── LICENSE ├── README.md ├── bcat.rkt ├── csv2tsv.rkt ├── dbk.rkt ├── dbk ├── abstract-syntax.rkt ├── codec.rkt ├── common.rkt ├── concrete-syntax-extended.rkt ├── concrete-syntax.rkt ├── config.rkt ├── constraint.rkt ├── data.rkt ├── database.rkt ├── dsv.rkt ├── enumerator.rkt ├── example-concrete-syntax-extended.rkt ├── heap.rkt ├── io.rkt ├── logging.rkt ├── misc.rkt ├── mk.rkt ├── old │ ├── abstract-syntax.rkt │ ├── example │ │ ├── base.rkt │ │ ├── counters.rkt │ │ ├── path.rkt │ │ ├── quorum.rkt │ │ └── shortest-path.rkt │ ├── parse.rkt │ └── process.rkt ├── order.rkt ├── safe-unsafe.rkt ├── semantics.rkt ├── storage.rkt ├── stream.rkt ├── syntax.rkt └── table.rkt ├── experiment ├── data.rkt ├── example.rkt ├── io2.rkt ├── syntax.rkt └── test-sort.rkt └── test ├── .gitignore ├── benchmark-compression ├── frame-of-reference-decode.c ├── frame-of-reference-decode.rkt ├── frame-of-reference-encode.rkt ├── share-prefix-with-previous-decode.c ├── share-prefix-with-previous-decode.rkt ├── text-fsst-compression.rkt └── text-no-compression-decode.rkt ├── benchmark-file-io ├── count-lines.c ├── count-lines.rkt ├── count-lines.scm ├── materialize-sorted-deduped-tuples.rkt ├── notes │ ├── scratch.scm │ ├── transcript-uncached-read.scm │ └── transcript.rkt ├── old-parse-tsv.rkt └── parse-tsv.rkt ├── benchmark-old └── run-benchmark.rkt ├── benchmark-sorting ├── radix-sort.rkt └── string-sort.rkt ├── btreetrie.rkt ├── chinook ├── .gitignore ├── README.md └── build.sh ├── codec.rkt ├── datalog ├── basic-naive.rkt ├── compile.rkt ├── kanren-notation-micro.rkt ├── micro-plus.rkt ├── micro-with-sets.rkt ├── micro.rkt ├── test-basic.rkt ├── test-kanren-micro.rkt ├── test-semantics.rkt ├── test-unmanaged-micro-plus.rkt ├── test-unmanaged-micro.rkt ├── unmanaged-notation-micro-plus.rkt └── unmanaged-notation-micro.rkt ├── equivalence-database.rkt ├── high-low-level.rkt ├── microbenchmarks ├── integer-bytes-throughput.rkt ├── place1.rkt ├── place2.rkt └── shared.rkt ├── old-0 └── test-mk.rkt ├── old-1 ├── test-dataflow.rkt ├── test-ingest-example-simple.rkt └── test-ingest-example.rkt ├── old-2 ├── test-database-small.rkt ├── test-low-level.rkt └── test-storage.rkt └── test-equivalence-database.rkt /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2020 Gregory Rosenblatt 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /bcat.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "dbk/codec.rkt" racket/pretty racket/port) 3 | 4 | (module+ main 5 | (define argv (current-command-line-arguments)) 6 | (define arg-names '#(DATA-TYPE)) 7 | (unless (= (vector-length argv) (vector-length arg-names)) 8 | (error "invalid arguments" 'expected arg-names 'given argv)) 9 | (define type (with-input-from-string (vector-ref argv 0) read)) 10 | (define in (current-input-port)) 11 | (define out (current-output-port)) 12 | (with-handlers (((lambda (e) 13 | (and (exn:fail:filesystem:errno? e) 14 | (equal? (exn:fail:filesystem:errno-errno e) 15 | '(32 . posix)))) 16 | void)) 17 | (let loop () 18 | (unless (eof-object? (peek-byte in)) 19 | (pretty-write (decode in type)) 20 | (loop))))) 21 | -------------------------------------------------------------------------------- /csv2tsv.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "dbk/io.rkt") 3 | 4 | (module+ main 5 | (let ((in (current-input-port)) (out (current-output-port))) 6 | (with-handlers (((lambda (e) 7 | (and (exn:fail:filesystem:errno? e) 8 | (equal? (exn:fail:filesystem:errno-errno e) 9 | '(32 . posix)))) 10 | void)) 11 | (let loop () 12 | (let ((row (csv:read in))) 13 | (unless (eof-object? row) 14 | (tsv:write out row) 15 | (loop))))))) 16 | -------------------------------------------------------------------------------- /dbk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | (all-from-out 4 | "dbk/codec.rkt" "dbk/config.rkt" "dbk/dsv.rkt" "dbk/misc.rkt" "dbk/mk.rkt" 5 | "dbk/order.rkt" "dbk/stream.rkt" "dbk/table.rkt")) 6 | (require 7 | "dbk/codec.rkt" "dbk/config.rkt" "dbk/dsv.rkt" "dbk/misc.rkt" "dbk/mk.rkt" 8 | "dbk/order.rkt" "dbk/stream.rkt" "dbk/table.rkt") 9 | -------------------------------------------------------------------------------- /dbk/abstract-syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | f:query f:true f:false f:relate f:imply f:iff f:or f:and f:not f:exist f:all 4 | t:query t:quote t:var t:prim t:app t:lambda t:if t:let 5 | scm->term) 6 | (require "misc.rkt" (except-in racket/match ==) racket/set) 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Abstract syntax 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (define-variant formula? 13 | (f:query result param f) ; TODO: omit this class of formula? 14 | (f:true) 15 | (f:false) 16 | ;; TODO: local relation definitions, to express subqueries 17 | ;; but this may be macro-expressible without a dedicated AST node? 18 | ;(f:letrec defs) ; defs ::= list-of (name params f) 19 | (f:relate relation args) ; finite position built-in? #f for infinite relations 20 | ;; TODO: 21 | ;(f:relate relation arg) ; switch to single argument for apply-relation, where variadic version is sugar 22 | 23 | ;(f:meta thunk) 24 | 25 | ;; or maybe just aggregate via forall/not-exists/any<=o enumeration 26 | (f:imply if then) 27 | (f:iff f1 f2) 28 | (f:or f1 f2) 29 | (f:and f1 f2) 30 | (f:not f) 31 | 32 | ;; TODO: single-param versions of f:exist and f:all: 33 | ;(f:exist param body) 34 | ;(f:all param body) 35 | 36 | (f:exist params body) 37 | (f:all params body)) 38 | 39 | (define-variant term? 40 | ;; TODO: simplify, removing t:query, t:lambda, t:if, t:let, t:prim, t:app 41 | ;; replace t:app with t:cons and t:vector 42 | (t:query name formula) 43 | (t:quote value) 44 | (t:var name) 45 | (t:prim name) 46 | (t:app proc args) 47 | (t:lambda params body) 48 | (t:if c t f) 49 | (t:let bpairs body)) 50 | 51 | (define (t:cons a d) (t:app (t:prim 'cons) (list a d))) 52 | (define (t:list->vector xs) (t:app (t:prim 'list->vector) (list xs))) 53 | 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | ;; Values and term conversion 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | 58 | (define (atom? x) 59 | (or (null? x) (boolean? x) (symbol? x) (string? x) (bytes? x) (and (real? x) (exact? x)) (void? x))) 60 | 61 | (define (scm->term x) 62 | (cond ((term? x) x) 63 | ((pair? x) (t:cons (scm->term (car x)) 64 | (scm->term (cdr x)))) 65 | ((vector? x) (t:list->vector (scm->term (vector->list x)))) 66 | ((atom? x) (t:quote x)) 67 | ((and (real? x) 68 | (inexact? x)) (scm->term (inexact->exact x))) 69 | (else (error "invalid dbk value:" x)))) 70 | 71 | (define (f-relations f) 72 | (match f 73 | ((f:query _ _ f) (f-relations f)) 74 | ;; TODO: no need for t-relations* if we lift all uses of t:query 75 | ;((f:relate relation args) (set-add (t-relations* args) relation)) 76 | ((f:relate relation _) (set relation)) 77 | ((f:imply f1 f2) (set-union (f-relations f1) (f-relations f2))) 78 | ((f:iff f1 f2) (set-union (f-relations f1) (f-relations f2))) 79 | ((f:or f1 f2) (set-union (f-relations f1) (f-relations f2))) 80 | ((f:and f1 f2) (set-union (f-relations f1) (f-relations f2))) 81 | ((f:not f) (f-relations f)) 82 | ((f:exist _ body) (f-relations body)) 83 | ((f:all _ body) (f-relations body)) 84 | ((or (f:true) (f:false)) (set)))) 85 | -------------------------------------------------------------------------------- /dbk/codec.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide encode decode sizeof nat-type/max) 3 | (require racket/list racket/match) 4 | 5 | (define (exact-number? x) (and (number? x) (exact? x))) 6 | (define (<< i s) (arithmetic-shift i s)) 7 | (define (>> i s) (arithmetic-shift i (- s))) 8 | (define (& a b) (bitwise-and a b)) 9 | (define (\| a b) (bitwise-ior a b)) 10 | (define (^ a b) (bitwise-xor a b)) 11 | 12 | (match-define (list t.bytes t.string t.symbol t.array t.pair 13 | t.true t.false t.null t.number 14 | ;; TODO: support more efficient numeric representations 15 | ;; is a separate rat type (for rationals) superfluous? 16 | t.nat t.int t.rat) 17 | (range (length '(t.bytes t.string t.symbol t.array t.pair 18 | t.true t.false t.null t.number 19 | t.nat t.int t.rat)))) 20 | 21 | (define (nat-type/max max-nat) `#(nat ,(- (sizeof 'nat max-nat) 1))) 22 | 23 | (define (sizeof type v) 24 | (match type 25 | (#f (sizeof-any v)) 26 | (`#(nat ,size) (sizeof-nat size v)) 27 | (`#(string ,len) (sizeof-string len v)) 28 | (`#(symbol ,len) (sizeof-symbol len v)) 29 | (`#(bytes ,len) (sizeof-bytes len v)) 30 | (`#(array ,len ,t) (sizeof-array len t v)) 31 | (`#(list ,len ,t) (sizeof-list len t v)) 32 | (`#(tuple ,@ts) (sizeof-tuple ts v)) 33 | (`(,ta . ,td) (sizeof-pair ta td v)) 34 | ('nat (sizeof-nat #f v)) 35 | ('string (sizeof-string #f v)) 36 | ('symbol (sizeof-symbol #f v)) 37 | ('bytes (sizeof-bytes #f v)) 38 | ('array (sizeof-array #f #f v)) 39 | ('list (sizeof-list #f #f v)) 40 | ('number (sizeof-number v)) 41 | ((or 'true 'false '()) 0))) 42 | (define (sizeof-any v) 43 | (define value-size 44 | (cond ((vector? v) (sizeof-array #f #f v)) 45 | ((string? v) (sizeof-string #f v)) 46 | ((bytes? v) (sizeof-bytes #f v)) 47 | ((pair? v) (sizeof-pair #f #f v)) 48 | ((exact-number? v) (sizeof-number v)) 49 | ((symbol? v) (sizeof-symbol #f v)) 50 | ((or (null? v) (eqv? #t v) (not v)) 0) 51 | ((void? v) #f) 52 | (else (error "sizeof-any; invalid type:" v)))) 53 | (and value-size (+ 1 value-size))) 54 | (define (sizeof-nat size n) 55 | (cond (size size) 56 | ((void? n) #f) 57 | (else (+ 1 (cond ((< n (<< 1 32)) (if (< n (<< 1 16)) 58 | (if (< n (<< 1 8)) 1 2) 59 | (if (< n (<< 1 24)) 3 4))) 60 | ((< n (<< 1 40)) 5) 61 | ((< n (<< 1 48)) 6) 62 | ((< n (<< 1 56)) 7) 63 | ((< n (<< 1 64)) 8) 64 | (else (error "sizeof-nat; too large:" n))))))) 65 | ;; TODO: consider exponent representations, which may be more compact 66 | (define (sizeof-number v) (sizeof-string #f (if (void? v) v 67 | (number->string v)))) 68 | (define (sizeof-bytes l v) (or l (and (not (void? v)) 69 | (let ((len (bytes-length v))) 70 | (+ len (sizeof-nat #f len)))))) 71 | (define (sizeof-symbol l v) (or l (sizeof-string l (if (void? v) v 72 | (symbol->string v))))) 73 | (define (sizeof-string l v) (or l (sizeof-bytes l (if (void? v) v 74 | (string->bytes/utf-8 v))))) 75 | (define (sizeof-pair ta td v) (let ((za (sizeof ta (if (void? v) v (car v)))) 76 | (zd (sizeof td (if (void? v) v (cdr v))))) 77 | (and za zd (+ za zd)))) 78 | (define (sizeof-tuple ts v) (sizeof ts (if (void? v) v (vector->list v)))) 79 | (define (sizeof-list l t v) 80 | (if l (sizeof-tuple (make-list l t) v) 81 | (and (not (void? v)) (let* ((l (length v)) 82 | (z (sizeof-list l t v))) 83 | (and z (+ (sizeof-nat #f l) z)))))) 84 | (define (sizeof-array l t v) 85 | (if l (sizeof-tuple (make-list l t) v) 86 | (and (not (void? v)) (let ((z (sizeof-array (vector-length v) t v))) 87 | (and z (+ (sizeof-nat #f (vector-length v)) z)))))) 88 | 89 | (define (encode out type v) 90 | (match type 91 | (#f (encode-any out v)) 92 | (`#(nat ,size) (encode-nat out size v)) 93 | (`#(string ,len) (encode-string out len v)) 94 | (`#(symbol ,len) (encode-symbol out len v)) 95 | (`#(bytes ,len) (encode-bytes out len v)) 96 | (`#(array ,len ,t) (encode-array out len t v)) 97 | (`#(list ,len ,t) (encode-list out len t v)) 98 | (`#(tuple ,@ts) (encode-tuple out ts v)) 99 | (`(,ta . ,td) (encode-pair out ta td v)) 100 | ('nat (encode-nat out #f v)) 101 | ('int (encode-int out v)) 102 | ('string (encode-string out #f v)) 103 | ('symbol (encode-symbol out #f v)) 104 | ('bytes (encode-bytes out #f v)) 105 | ('array (encode-array out #f #f v)) 106 | ('list (encode-list out #f #f v)) 107 | ('number (encode-number out v)) 108 | ((or 'true 'false '()) 0))) 109 | (define (encode-any out v) 110 | (define (tag t) (encode-nat out 1 t)) 111 | (cond ((vector? v) (tag t.array) (encode-array out #f #f v)) 112 | ((string? v) (tag t.string) (encode-string out #f v)) 113 | ((bytes? v) (tag t.bytes) (encode-bytes out #f v)) 114 | ((pair? v) (tag t.pair) (encode-pair out #f #f v)) 115 | ((exact-number? v) (tag t.number) (encode-number out v)) 116 | ((symbol? v) (tag t.symbol) (encode-symbol out #f v)) 117 | ((null? v) (tag t.null)) 118 | ((eqv? #t v) (tag t.true)) 119 | ((not v) (tag t.false)) 120 | (else (error "encode-any; invalid type:" v)))) 121 | (define (encode-nat out size n) 122 | (define (enc/size sz) (unless (= sz 0) 123 | (write-byte (& #xFF (>> n (* 8 (- sz 1)))) out) 124 | (enc/size (- sz 1)))) 125 | (define (enc sz) (encode-nat out 1 sz) (enc/size sz)) 126 | (cond (size (enc/size size)) 127 | ((< n (<< 1 32)) (if (< n (<< 1 16)) 128 | (if (< n (<< 1 8)) (enc 1) (enc 2)) 129 | (if (< n (<< 1 24)) (enc 3) (enc 4)))) 130 | ((< n (<< 1 40)) (enc 5)) 131 | ((< n (<< 1 48)) (enc 6)) 132 | ((< n (<< 1 56)) (enc 7)) 133 | ((< n (<< 1 64)) (enc 8)) 134 | (else (error "encode-nat; too large:" n)))) 135 | (define (encode-int out v) 136 | (encode-nat out #f (+ (<< v 1) (if (< v 0) 1 0)))) 137 | ;; TODO: consider exponent representations, which may be more compact 138 | (define (encode-number out n) (encode-string out #f (number->string n))) 139 | (define (encode-bytes out len bs) 140 | (unless len (encode-nat out #f (bytes-length bs))) 141 | (write-bytes bs out)) 142 | (define (encode-symbol out len s) (encode-string out len (symbol->string s))) 143 | (define (encode-string out len s) 144 | (encode-bytes out len (string->bytes/utf-8 s))) 145 | (define (encode-pair out ta td v) 146 | (encode out ta (car v)) (encode out td (cdr v))) 147 | (define (encode-tuple out ts v) (for ((t (in-list ts)) (v (in-vector v))) 148 | (encode out t v))) 149 | (define (encode-list out l t v) 150 | (unless l (encode-nat out #f (length v))) 151 | (for ((v (in-list v))) (encode out t v))) 152 | (define (encode-array out l t v) 153 | (unless l (encode-nat out #f (vector-length v))) 154 | (for ((v (in-vector v))) (encode out t v))) 155 | 156 | (define (decode in type) 157 | (match type 158 | (#f (decode-any in)) 159 | (`#(nat ,size) (decode-nat in size)) 160 | (`#(string ,len) (decode-string in len)) 161 | (`#(symbol ,len) (decode-symbol in len)) 162 | (`#(bytes ,len) (decode-bytes in len)) 163 | (`#(array ,len ,t) (decode-array in len t)) 164 | (`#(list ,len ,t) (decode-list in len t)) 165 | (`#(tuple ,@ts) (decode-tuple in ts)) 166 | (`(,ta . ,td) (decode-pair in ta td)) 167 | ('nat (decode-nat in #f)) 168 | ('int (decode-int in)) 169 | ('string (decode-string in #f)) 170 | ('symbol (decode-symbol in #f)) 171 | ('bytes (decode-bytes in #f)) 172 | ('array (decode-array in #f #f)) 173 | ('list (decode-list in #f #f)) 174 | ('number (decode-number in)) 175 | ('true #t) 176 | ('false #f) 177 | ('() '()))) 178 | (define (decode-any in) 179 | (define tag (decode-nat in 1)) 180 | (define (? t) (= tag t)) 181 | (cond ((? t.array) (decode-array in #f #f)) 182 | ((? t.string) (decode-string in #f)) 183 | ((? t.bytes) (decode-bytes in #f)) 184 | ((? t.pair) (decode-pair in #f #f)) 185 | ((? t.number) (decode-number in)) 186 | ((? t.symbol) (decode-symbol in #f)) 187 | ((? t.null) '()) 188 | ((? t.true) #t) 189 | ((? t.false) #f) 190 | (else (error "decode-any; invalid tag:" tag)))) 191 | (define (decode-nat in size) 192 | (if size (let loop ((n 0) (sz size)) 193 | (if (= sz 0) n 194 | (loop (+ (<< n 8) (read-byte in)) (- sz 1)))) 195 | (let ((size (decode-nat in 1))) (decode-nat in size)))) 196 | (define (decode-int in) 197 | (define nat (decode-nat in #f)) 198 | (* (if (odd? nat) -1 1) (>> nat 1))) 199 | ;; TODO: consider exponent representations, which may be more compact 200 | (define (decode-number in) (string->number (decode-string in #f))) 201 | (define (decode-bytes in l) (if l (read-bytes l in) 202 | (decode-bytes in (decode-nat in #f)))) 203 | (define (decode-symbol in l) (string->symbol (decode-string in l))) 204 | (define (decode-string in l) (bytes->string/utf-8 (decode-bytes in l))) 205 | (define (decode-pair in ta td) (cons (decode in ta) (decode in td))) 206 | (define (decode-tuple in ts) (list->vector (decode in ts))) 207 | (define (decode-list in l t) (if l (decode in (make-list l t)) 208 | (decode-list in (decode-nat in #f) t))) 209 | (define (decode-array in l t) (if l (decode-tuple in (make-list l t)) 210 | (decode-array in (decode-nat in #f) t))) 211 | -------------------------------------------------------------------------------- /dbk/common.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide symbolo numbero stringo byteso pairo vectoro booleano integero 3 | not-symbolo not-numbero not-stringo not-byteso 4 | not-pairo not-vectoro not-booleano not-integero 5 | vector==listo bytes==listo <=o vector (dbk:quasiquote/level level (q ...)))) 87 | ((_ level quasiquote) (raise-syntax-error #f "misplaced quasiquote" stx)) 88 | ((_ level unquote) (raise-syntax-error #f "misplaced unquote" stx)) 89 | ((_ level unquote-splicing) (raise-syntax-error #f "misplaced unquote-splicing" stx)) 90 | ((_ level q) #'(dbk:term (quote q))))) 91 | 92 | (define-syntax-rule (dbk:quasiquote q) (dbk:quasiquote/level () q)) 93 | -------------------------------------------------------------------------------- /dbk/config.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide current-config config.default file->config current-config-ref 3 | current-config-set current-config-set/alist 4 | current-config-set! current-config-set!/alist 5 | current-config-relation-path config-ref config-set config-set/alist 6 | policy-allow? logf logf/date) 7 | (require racket/date racket/string) 8 | 9 | (define config.default 10 | (make-immutable-hash 11 | '((relation-root-path . #f) ;; root path for materialized relations 12 | (temporary-root-path . #f) ;; root path for temporary caches 13 | (buffer-size . 100000) 14 | (progress-logging-threshold . 100000) ;; number of rows per log message 15 | ;; interactive, always, never 16 | (update-policy . interactive) ;; rebuild stale tables 17 | (cleanup-policy . interactive) ;; remove unspecified indexes 18 | (migrate-policy . interactive) ;; migrate to new data format 19 | (allow-missing-data-policy . interactive) ;; ignore missing data 20 | ;; biased-interleaving (default), depth-first 21 | (search-strategy . #f)))) 22 | 23 | (define (valid-config?! cfg) 24 | (define (valid-policy? policy) (member policy '(always never interactive))) 25 | (define (valid-path? p) (or (not p) (string? p) (path? p))) 26 | (define-syntax validate! 27 | (syntax-rules () 28 | ((_ (test ... key) ...) 29 | (begin (unless (test ... (hash-ref cfg 'key)) 30 | (error "invalid config:" 'key (hash-ref cfg 'key))) ...)))) 31 | (validate! (valid-path? relation-root-path) 32 | (valid-path? temporary-root-path) 33 | (< 0 buffer-size) 34 | (< 0 progress-logging-threshold) 35 | (valid-policy? update-policy) 36 | (valid-policy? cleanup-policy) 37 | (valid-policy? migrate-policy)) 38 | cfg) 39 | 40 | (define (config-ref cfg key) (hash-ref cfg key)) 41 | (define (config-set cfg key value) (valid-config?! (hash-set cfg key value))) 42 | (define (config-set/alist cfg kvs) 43 | (valid-config?! (foldl (lambda (kv cfg) (hash-set cfg (car kv) (cdr kv))) 44 | cfg kvs))) 45 | (define (file->config path) 46 | (config-set/alist config.default (with-input-from-file path read))) 47 | 48 | (define current-config (make-parameter config.default)) 49 | (define (current-config-ref key) (config-ref (current-config) key)) 50 | (define (current-config-set key value) (config-set (current-config) key value)) 51 | (define (current-config-set/alist kvs) (config-set/alist (current-config) kvs)) 52 | (define (current-config-set! key value) 53 | (current-config (current-config-set key value))) 54 | (define (current-config-set!/alist kvs) 55 | (current-config (current-config-set/alist kvs))) 56 | (define (current-config-relation-path path) 57 | (cond ((and (string? path) (string-prefix? path "/")) path) 58 | (else (define relation-root-path 59 | (current-config-ref 'relation-root-path)) 60 | (if relation-root-path 61 | (path->string (build-path relation-root-path path)) 62 | path)))) 63 | 64 | (define (policy-allow? policy describe prompt-message prompt-args) 65 | (case policy 66 | ((interactive) 67 | (describe) 68 | (apply printf (string-append prompt-message " [y/n]: ") prompt-args) 69 | (case (read) 70 | ((y Y yes Yes YES) #t) 71 | (else #f))) 72 | ((always) #t) 73 | (else #f))) 74 | 75 | (define (pad2 n) (let ((s (number->string n))) 76 | (if (<= 2 (string-length s)) s 77 | (string-append "0" s)))) 78 | 79 | (define (logf/date message . args) 80 | (define msg (string-append "[~a/~a/~a - ~a:~a:~a] " message)) 81 | (define d (current-date)) 82 | (define stamp (list (date-month d) (date-day d) 83 | (date-hour d) (date-minute d) (date-second d))) 84 | (apply eprintf msg (date-year d) (append (map pad2 stamp) args))) 85 | 86 | (define (logf message . args) 87 | (define msg (string-append "[~a:~a:~a] " message)) 88 | (define d (current-date)) 89 | (define stamp (list (date-hour d) (date-minute d) (date-second d))) 90 | (apply eprintf msg (append (map pad2 stamp) args))) 91 | 92 | ;; TODO: job system 93 | ;; single worker thread 94 | ;; jobs w/ independent loggers (port, file, in-memory, or null) 95 | 96 | ;(define (thread/wait proc) 97 | ; (define t (thread proc)) 98 | ; (plumber-add-flush! (current-plumber) 99 | ; (lambda (h) (thread-wait t))) 100 | ; t) 101 | -------------------------------------------------------------------------------- /dbk/dsv.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide tsv->stream dsv->stream csv->stream 3 | path->format format->header/port->stream) 4 | (require racket/function racket/list racket/string) 5 | 6 | ;; Informal grammar for tab-separated values (no escapes supported) 7 | ;FIELD-SEPARATOR ::= \t 8 | ;RECORD-SEPARATOR ::= \r\n | \n | \r 9 | ;record-stream ::= EOF | record EOF | record RECORD-SEPARATOR record-stream 10 | ;record ::= field | field FIELD-SEPARATOR record 11 | ;field ::= CONTENT* 12 | ;CONTENT includes anything other than \t, \n, \r 13 | 14 | (define (tsv->stream header? in) 15 | (valid-header?! in header? "\t") 16 | (let loop () (thunk (define l (read-line in 'any)) 17 | (if (eof-object? l) '() 18 | (cons (string-split l "\t" #:trim? #f) (loop)))))) 19 | 20 | ;; Informal grammar for delimiter-separated values (escapes via double quote) 21 | ;RECORD-SEPARATOR ::= \r\n | \n | \r 22 | ;record-stream ::= EOF | record EOF | record RECORD-SEPARATOR record-stream 23 | ;record ::= field | field FIELD-SEPARATOR record 24 | ;field ::= \" inner-content* \" | CONTENT* 25 | ;inner-content ::= CONTENT | \"\" | FIELD-SEPARATOR | WHITESPACE 26 | ;CONTENT includes anything other than double-quote, field separator, whitespace 27 | 28 | (define (csv->stream header? in) (dsv->stream #\, header? in)) 29 | 30 | (define (dsv->stream field-separator header? in) 31 | (define (field) 32 | (define ch (peek-char in)) 33 | (cond ((eqv? ch field-separator) (read-char in) "") 34 | ((or (eqv? ch #\newline) (eqv? ch #\return) (eof-object? ch)) "") 35 | ((eqv? ch #\") 36 | (read-char in) 37 | (let loop ((i 0)) 38 | (define ch (peek-char in i)) 39 | (cond ((eqv? ch #\") 40 | (if (eqv? (peek-char in (+ i 1)) #\") (loop (+ i 2)) 41 | (let ((qs (bytes->string/utf-8 (read-bytes i in)))) 42 | (read-char in) 43 | (when (eqv? (peek-char in) field-separator) 44 | (read-char in)) 45 | (string-replace qs "\"\"" "\"")))) 46 | (else (loop (+ i 1)))))) 47 | (else (let loop ((i 1)) 48 | (define ch (peek-char in i)) 49 | (cond ((eqv? ch field-separator) 50 | (define s (bytes->string/utf-8 (read-bytes i in))) 51 | (read-char in) s) 52 | ((or (eqv? ch #\newline) (eqv? ch #\return) (eof-object? ch)) 53 | (bytes->string/utf-8 (read-bytes i in))) 54 | (else (loop (+ i 1)))))))) 55 | (define (record) 56 | (cons (field) 57 | (let ((ch (peek-char in))) 58 | (cond ((eqv? ch #\return) (read-char in) 59 | (when (eqv? (peek-char in) #\newline) 60 | (read-char in)) 61 | '()) 62 | ((eqv? ch #\newline) (read-char in) '()) 63 | ((eof-object? ch) '()) 64 | (else (record)))))) 65 | (valid-header?! in header? (make-string 1 field-separator)) 66 | (let loop () (thunk (if (eof-object? (peek-char in)) '() 67 | (cons (record) (loop)))))) 68 | 69 | (define (valid-header?! in header delimiter) 70 | (define found (and header (read-line in 'any))) 71 | (define expected (and header (cond ((eq? header #t) found) 72 | ((string? header) header) 73 | (else (string-join header delimiter))))) 74 | (unless (equal? found expected) 75 | (error "invalid header:" 'found: found 'expected: expected))) 76 | 77 | (define (path->format path) 78 | (define fname (if (path? path) (path->string path) path)) 79 | (case (last (string-split fname "." #:trim? #f)) 80 | (("tsv") 'tsv) 81 | (("csv") 'csv) 82 | (else #f))) 83 | 84 | (define (format->header/port->stream format) 85 | (case format 86 | ((tsv) tsv->stream) 87 | ((csv) csv->stream) 88 | (else (error "invalid format:" format)))) 89 | -------------------------------------------------------------------------------- /dbk/enumerator.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide enumerator-append 3 | list->enumerator enumerator->rlist enumerator->list 4 | s->enumerator enumerator->s 5 | vector->enumerator unsafe-vector->enumerator enumerator->rvector enumerator->vector 6 | generator->enumerator 7 | enumerator/2->enumerator 8 | enumerator->enumerator/2 9 | hash->enumerator/2) 10 | (require racket/control racket/unsafe/ops) 11 | 12 | (define ((enumerator-append e.0 e.1) yield) 13 | (e.0 yield) 14 | (e.1 yield)) 15 | 16 | (define ((list->enumerator xs) yield) (for-each yield xs)) 17 | 18 | (define (enumerator->rlist en) 19 | (define xs '()) 20 | (en (lambda (x) (set! xs (cons x xs)))) 21 | xs) 22 | 23 | (define (enumerator->list en) 24 | (reverse (enumerator->rlist en))) 25 | 26 | (define ((s->enumerator s) yield) 27 | (let loop ((s s)) 28 | (cond ((null? s) (void)) 29 | ((pair? s) (yield (car s)) (loop (cdr s))) 30 | (else (loop (s)))))) 31 | 32 | (define ((enumerator->s en)) 33 | (define tag (make-continuation-prompt-tag)) 34 | (reset-at tag 35 | (en (lambda (x) 36 | (shift-at tag k (cons x (lambda () (k (void))))))) 37 | '())) 38 | 39 | (define (enumerator->rvector en) 40 | (list->vector (enumerator->rlist en))) 41 | 42 | (define (enumerator->vector en) 43 | (list->vector (enumerator->list en))) 44 | 45 | (define (vector->enumerator v (start 0) (end (vector-length v))) 46 | (define len (min end (vector-length v))) 47 | (unsafe-vector->enumerator v (min start len) len)) 48 | 49 | (define ((unsafe-vector->enumerator v (start 0) (end (unsafe-vector*-length v))) yield) 50 | (let loop ((i start)) 51 | (when (unsafe-fx< i end) 52 | (yield (unsafe-vector*-ref v i)) 53 | (loop (unsafe-fx+ i 1))))) 54 | 55 | (define ((generator->enumerator gen stop?) yield) 56 | (let loop () 57 | (define x (gen)) 58 | (unless (stop? x) 59 | (yield x) 60 | (loop)))) 61 | 62 | ;; An enumerator/2 expects its iteratee to take two arguments 63 | (define ((enumerator/2->enumerator en) yield) 64 | (en (lambda (a b) (yield (cons a b))))) 65 | 66 | (define ((enumerator->enumerator/2 en) yield) 67 | (en (lambda (x&y) (yield (car x&y) (cdr x&y))))) 68 | 69 | (define ((hash->enumerator/2 kvs) yield) (hash-for-each kvs yield)) 70 | -------------------------------------------------------------------------------- /dbk/example-concrete-syntax-extended.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;(provide foo bar) 3 | 4 | (require "concrete-syntax-extended.rkt") 5 | 6 | (define-relations 7 | (rule (foo x) (== x 5) (bar x 1 2)) 8 | (table (bar id s o) "somewhere/bar")) 9 | 10 | ((relation-method foo) 'apply 888) 11 | bar 12 | 13 | ;(define-relation (foo x) (== x 5) (bar x 1 2)) 14 | 15 | ;(define-relation/table (bar id s o) "somewhere/bar") 16 | 17 | ;(with-formula-vocabulary (foo 11)) 18 | 19 | ;(foo 'apply 12) 20 | 21 | ;(== 1 2) 22 | ;(with-formula-vocabulary (== 1 2)) 23 | ;== 24 | ;;) 25 | -------------------------------------------------------------------------------- /dbk/heap.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | heap-top 4 | heap! 5 | heap-remove! 6 | heap-replace! 7 | heap-sink! 8 | heap-add! 9 | ) 10 | 11 | (define (heap-top h) (vector-ref h 0)) 12 | (define (heap! date seconds #f)) 16 | (list seconds 'UTC 17 | (date-year d) (date-month d) (date-day d) 18 | (date-hour d) (date-minute d) (date-second d))) 19 | 20 | (define (pretty-log/port out . args) (pretty-write (cons (pretty-timestamp) args) out)) 21 | (define (pretty-logf/port out message . args) (pretty-log/port out (apply format message args))) 22 | 23 | (define current-log-port (make-parameter (current-error-port))) 24 | 25 | (define (pretty-log . args) (apply pretty-log/port (current-log-port) args)) 26 | (define (pretty-logf . args) (apply pretty-logf/port (current-log-port) args)) 27 | 28 | (define-syntax-rule (time/pretty-log body ...) 29 | (let-values (((results time.cpu time.real time.gc) (time-apply (lambda () body ...) '()))) 30 | (pretty-log `(time cpu ,time.cpu real ,time.real gc ,time.gc)) 31 | (apply values results))) 32 | -------------------------------------------------------------------------------- /dbk/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide (all-from-out "common.rkt") (all-from-out "syntax.rkt") 3 | (all-from-out "constraint.rkt") 4 | query->stream 5 | run^ run run* run/steps run*/steps 6 | run/set run*/set run/set/steps run*/set/steps) 7 | (require "common.rkt" "config.rkt" "constraint.rkt" "stream.rkt" "syntax.rkt" 8 | (except-in racket/match ==)) 9 | 10 | (define (query->stream q) 11 | ((match (or (current-config-ref 'search-strategy) 'biased-interleaving) 12 | ('biased-interleaving bis:query->stream) 13 | ('depth-first dfs:query->stream) 14 | (strategy (error "invalid search strategy:" strategy))) 15 | q)) 16 | 17 | (define-syntax run^ 18 | (syntax-rules () ((_ body ...) (query->stream (query body ...))))) 19 | (define-syntax run 20 | (syntax-rules () ((_ n body ...) (s-take n (run^ body ...))))) 21 | (define-syntax run* 22 | (syntax-rules () ((_ body ...) (run #f body ...)))) 23 | (define-syntax run/steps 24 | (syntax-rules () ((_ steps n body ...) (s-take/steps steps n (run^ body ...))))) 25 | (define-syntax run*/steps 26 | (syntax-rules () ((_ steps body ...) (run/steps steps #f body ...)))) 27 | 28 | (define-syntax run/set 29 | (syntax-rules () ((_ n body ...) (s-take/set n (run^ body ...))))) 30 | (define-syntax run*/set 31 | (syntax-rules () ((_ body ...) (run/set #f body ...)))) 32 | (define-syntax run/set/steps 33 | (syntax-rules () ((_ steps n body ...) (s-take/set/steps steps n (run^ body ...))))) 34 | (define-syntax run*/set/steps 35 | (syntax-rules () ((_ steps body ...) (run/set/steps steps #f body ...)))) 36 | 37 | ;; TODO: special case aggregation operators that could be implemented more 38 | ;; efficiently than post-processing `run*` results: 39 | ;; * run/min, run/max, run/count 40 | -------------------------------------------------------------------------------- /dbk/old/example/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide m.base) 3 | 4 | (define-dbk m.base 5 | (<<= (== u u)) 6 | (<<= (=/= u v) (not (== u u))) 7 | (<<= (any<= u v) (== #t (any<= u v))) 8 | (<<= (any< u v) (=/= u v) (any<= u v)) 9 | (<<= (any>= u v) (any<= v u)) 10 | (<<= (any> u v) (any< v u)) 11 | 12 | (relation (member x ys) 13 | modes ((ys))) ;; this mode could be inferred 14 | (<<= (member x (cons x ys))) 15 | (<<= (member x (cons y ys)) 16 | (=/= x y) (member x ys)) 17 | ;; member can also be defined with a single rule: 18 | ;(<<= (member x ys) 19 | ; (exist (a d) 20 | ; (== ys `(,a . ,d)) 21 | ; (or (== x a) 22 | ; (and (=/= x a) (member x d))))) 23 | 24 | (relation (append xs ys xsys) 25 | modes ((xs) (xsys))) ;; these modes could be inferred 26 | (<<= (append '() ys ys)) 27 | (<<= (append `(,x . ,xs) ys `(,x . ,xsys)) 28 | (append xs ys xsys)) 29 | 30 | ;; Can this theorem be proven? 31 | ;(assert (all (xs ys) 32 | ; (iff (append xs ys ys) 33 | ; (== xs '())))) 34 | ) 35 | -------------------------------------------------------------------------------- /dbk/old/example/counters.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide dbk.counters) 3 | (require "base.rkt" 4 | 5 | (define-dbk dbk.counters 6 | (module 'foo 7 | (<<+ (foo (+ n 1)) (foo n))) 8 | (module 'bar 9 | (<<+ (bar (+ n 1)) (bar n))) 10 | (module 'initialize 11 | (<<+ (foo 0)) 12 | (<<+ (bar 0))) 13 | (module 'clean 14 | (<<- (foo n) (bar n)) 15 | (<<- (bar n) (foo n)))) 16 | -------------------------------------------------------------------------------- /dbk/old/example/path.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide m.path m.edge.acyclic m.edge.cycles) 3 | (require "base.rkt") 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Define program modules 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | 9 | (define-dbk m.path 10 | (relation (edge source target) 11 | indexes ((target source))) 12 | 13 | (<<= (path s t) (edge s t)) 14 | (<<= (path s t) (exist (mid) 15 | (edge s mid) (path mid t)))) 16 | 17 | (define-dbk m.edge.acyclic 18 | (link m.base) 19 | (<<+ (edge s t) (member (list s t) 20 | '((1 2) 21 | (2 4) 22 | (1 3) 23 | (3 5) 24 | (2 6) 25 | (3 6) 26 | (6 4))))) 27 | 28 | (define-dbk m.edge.cycles 29 | (link m.base) 30 | (<<+ (edge s t) (member (list s t) 31 | '((1 1) 32 | (5 1))))) 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | ;; Run example 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (define p (process m.path)) 39 | 40 | ;; edge relation is empty 41 | (p 'eval '(query (s t) (path s t))) 42 | ;; ==> 43 | ;; () 44 | 45 | ;; insert acyclic edge data 46 | (p 'program-set! (link m.path m.edge.acyclic)) 47 | (p 'tick!) 48 | (p 'program-set! m.path) 49 | 50 | (p 'eval '(query (s t) (path s t))) 51 | ;; ==> 52 | ;; ? TODO 53 | 54 | ;; insert extra edges that form cycles 55 | (p 'program-set! (link m.path m.edge.cycles)) 56 | (p 'tick!) 57 | (p 'program-set! m.path) 58 | 59 | (p 'eval '(query (s t) (path s t))) 60 | ;; ==> 61 | ;; ? TODO 62 | -------------------------------------------------------------------------------- /dbk/old/example/quorum.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide m.quorum-vote) 3 | (require "base.rkt") 4 | 5 | ;; Based on figures 2 and 3 in: Logic and Lattices for Distributed Programming 6 | ;; https://dsf.berkeley.edu/papers/socc12-blooml.pdf 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Define program modules 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (define-dbk m.quorum-vote 13 | (<<+ (vote id) (vote.in id)) 14 | 15 | ;; Demonstrate intermediate term definitions 16 | (define vote-count (set-count (query id (vote id)))) 17 | (define quorum? (<= quorum-size count)) 18 | (<<~ (result.out 'success) (== #t quorum?)) 19 | 20 | ;; This is what it looks like without intermediate definitions 21 | ;(<<~ (result.out 'success) 22 | ; (== #t (<= quorum-size (set-count (query id (vote id)))))) 23 | 24 | ;; And this is an alternative where <= is used as a relation instead 25 | ;(<<~ (result.out 'success) 26 | ; (<= quorum-size (set-count (query id (vote id))))) 27 | ) 28 | 29 | (define pipe.result (dbk:pipe)) 30 | 31 | (define program 32 | (link m.quorum-vote 33 | ;; Factored out so that m.quorum-vote is reusable 34 | (dbk 35 | (parameter quorum-size 3) 36 | (input (vote.in id) _) ; TODO: fill _ with an actual input device 37 | (output (result.out x) (out:pipe pipe.result))))) 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | ;; Run example 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | 43 | (define p (process program)) 44 | 45 | ;; Loop until enough votes arrive (assumes vote.in input device is populated concurrently) 46 | (let loop () 47 | (unless (s-member '(success) (pipe-get pipe.result)) 48 | (p 'tick!) 49 | (loop))) 50 | -------------------------------------------------------------------------------- /dbk/old/example/shortest-path.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide m.shortest-path) 3 | (require "base.rkt") 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Define program modules 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | 9 | (define-dbk m.shortest-path 10 | (link m.base) 11 | 12 | (relation (edge source target distance) 13 | indexes ((target source))) 14 | 15 | ;; Guard against cyclic data 16 | (<<= (reachable s t) (edge s t _)) 17 | (<<= (reachable s t) (exist (mid) 18 | (edge s mid _) (reachable mid t))) 19 | (assert (not (exist (x) (reachable x x)))) 20 | 21 | ;; This relation will be infinitely large if edge describes a cyclic graph. 22 | ;; To support cyclic data, we can rewrite this to stratify across time steps, 23 | ;; stopping when there are no more improvements made during a single tick. 24 | ;; TODO: It might be possible to avoid stratifying over time by expressing 25 | ;; shortest-path directly using lattice operations for computing distance, 26 | ;; allowing recursion within aggregation due to monotonicity. 27 | (<<= (path s t d) (edge s t d)) 28 | (<<= (path s t (+ d.e d.p)) 29 | (exist (mid) 30 | (edge s mid d.e) 31 | (path mid t d.p))) 32 | 33 | (<<= (shortest-path s t distance) 34 | (=/= distance #f) 35 | (== distance (merge min #f (query distance (path s t distance))))) 36 | 37 | (<<= (edge s t distance) 38 | (member (list s t distance) 39 | '((a b 2) 40 | (b c 5) 41 | (b c 1) 42 | (c d 3) 43 | (c e 5) 44 | (d e 1) 45 | (e f 2))))) 46 | 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;; Run examples 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | 51 | (define p (process m.shortest-path)) 52 | 53 | (p 'eval '(query (s t c) (path s t c))) 54 | ;; ==> 55 | ;; ? TODO 56 | 57 | (p 'eval '(query (s t c) (shortest-path s t c))) 58 | ;; ==> 59 | ;; ? TODO 60 | -------------------------------------------------------------------------------- /dbk/old/process.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | ) 4 | (require "abstract-syntax.rkt" "misc.rkt" "parse.rkt" 5 | racket/list racket/match racket/set) 6 | 7 | (record pstate (dbms history data program) #:prefab) 8 | (define (pstate:new dbms prg) (pstate (dbms dbms) 9 | (history prg) 10 | (data 'TODO) 11 | (program prg))) 12 | 13 | ;; TODO: 14 | (define (pstate-query pst params formula) 15 | (set)) 16 | 17 | ;; TODO: include stepping as a modification? 18 | (define-variant pmod? 19 | (pmod:merge pstates) 20 | (pmod:move path.old path.new) 21 | (pmod:wrap path) 22 | (pmod:unwrap path) 23 | (pmod:rename vocab name.old name.new)) 24 | 25 | (define (pmod:remove path) (pmod:move path #f)) 26 | (define (pmod:hide vocab name) (pmod:rename vocab name #f)) 27 | 28 | (define (pstate-modify pst.0 pm) 29 | ;; TODO: record new pstate using dbms 30 | (define pst (pstate:set pst.0 (history (cons pm (pstate-history pst.0))))) 31 | (define prg (pstate-program pst)) 32 | (define m (program-module prg)) 33 | (define env (program-env prg)) 34 | ;; TODO: produce renamings for public names that are shared across pstates 35 | (define (public-renamings envs) 36 | (hash)) 37 | (define (module-rename m) 38 | ;; TODO: traverse (parameterized) formulas and terms 39 | #f) 40 | (define (data-rename d n=>n) 41 | ;; TODO: 42 | #f) 43 | (define (data-union . ds) 44 | ;; TODO: 45 | #f) 46 | (match pm 47 | ((pmod:merge pstates) (define dbms (pstate-dbms pst)) 48 | (unless (andmap (lambda (s) (eqv? dbms (pstate-dbms s))) pstates) 49 | (error "cannot merge processes managed by a different dbms:" 50 | dbms (map pstate-dbms pstates))) 51 | (with-fresh-names 52 | (define n=>n.0 (public-renamings (map (lambda (ps) (program-env (pstate-program ps))) 53 | (cons pst pstates)))) 54 | (apply (lambda (ms es ds) 55 | (pstate:set pst 56 | (program (program:set program.empty 57 | (module (m:link ms)) 58 | (env (apply env-union es)))) 59 | (data (apply data-union ds)))) 60 | (apply map list 61 | (map (lambda (ps) 62 | (define prg (pstate-program ps)) 63 | (match-define (cons m n=>n) (module-rename (program-module prg) n=>n.0)) 64 | (define env (env-rename (program-env prg) n=>n)) 65 | (define data (data-rename (pstate-data ps) n=>n)) 66 | (list m env data)) 67 | (cons pst pstates)))))) 68 | ((pmod:move path.old path.new) (define m.1 (module-remove m path.old)) 69 | (define m.new (if path.new 70 | (module-add m.1 path.new (module-ref m path.old)) 71 | m.1)) 72 | (pstate:set pst (program (program:set prg (module m.new))))) 73 | ((pmod:wrap path) (pstate:set pst (program (program:set prg (module (module-wrap m path)))))) 74 | ((pmod:unwrap path) (pstate:set pst (program (program:set prg (module (module-unwrap m path)))))) 75 | ((pmod:rename vocab n.old n.new) (define env.1 (env-set env vocab n.old #f)) 76 | (define env.new (if n.new 77 | (env-set env.1 vocab n.new (env-ref env vocab n.old)) 78 | env.1)) 79 | (pstate:set pst (program (program:set prg (env env.new))))))) 80 | 81 | ;; TODO: return #f if quiescent 82 | (define (pstate-step pst) 83 | #f) 84 | 85 | (define (process name state) 86 | (define dbms (pstate-dbms state)) 87 | (method-lambda 88 | ((state) state) 89 | ((branch name.new) (dbms-process-add! dbms name.new state) 90 | (process name.new state)) 91 | ((move name.new) (dbms-process-move! dbms name name.new) 92 | (set! name name.new)) 93 | ((modify pm) (define state.new (pstate-modify state pm)) 94 | (dbms-process-set! dbms name state.new) 95 | (set! state state.new)) 96 | ((step) (define state.new (pstate-step state)) 97 | (and state.new (dbms-process-set! dbms name state.new))) 98 | ((query . args) (apply pstate-query state args)))) 99 | 100 | (define (process-query p . args) (apply p 'query args)) 101 | (define (process-branch p name.new) (p 'branch name.new)) 102 | (define (process-move! p name.new) (p 'move name.new)) 103 | (define (process-step! p) (p 'step)) 104 | (define (process-modify! p pm) (p 'modify pm)) 105 | 106 | (define (process-merge! p ps) 107 | (process-modify! p (pmod:merge (map (lambda (p) (p 'state)) ps)))) 108 | 109 | (define (merge-processes name ps) 110 | (when (null? ps) (error "cannot merge empty list of processes:" name)) 111 | (define p (process-branch (car ps) name)) 112 | (process-merge! p (cdr ps)) 113 | p) 114 | 115 | ;; TODO: 116 | (define (dbms-process-ref dbms name) 117 | #f) 118 | 119 | (define (dbms-process-set! dbms name pst) 120 | (void)) 121 | 122 | (define (dbms-process-add! dbms name pst) 123 | (void)) 124 | 125 | (define (dbms-process-move! dbms name.old name.new) 126 | (void)) 127 | 128 | (define (dbms-process-remove! dbms name pst.validation) 129 | (void)) 130 | 131 | (define (dbms-export! dbms renamings path.out) 132 | (void)) 133 | 134 | (define (dbms-import! dbms renamings path.in) 135 | (void)) 136 | 137 | (define (dbms-clean! dbms) 138 | (void)) 139 | -------------------------------------------------------------------------------- /dbk/safe-unsafe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | unsafe-list-ref 4 | unsafe-car 5 | unsafe-cdr 6 | unsafe-fxmin 7 | unsafe-fxmax 8 | unsafe-fx= 9 | unsafe-fx<= 10 | unsafe-fx< 11 | unsafe-fx+ 12 | unsafe-fx- 13 | unsafe-fx* 14 | unsafe-fxand 15 | unsafe-fxior 16 | unsafe-fxxor 17 | unsafe-fxnot 18 | unsafe-fxlshift 19 | unsafe-fxrshift 20 | unsafe-fxquotient 21 | unsafe-fxremainder 22 | unsafe-bytes-length 23 | unsafe-bytes-ref 24 | unsafe-bytes-set! 25 | unsafe-bytes-copy! 26 | unsafe-vector*-length 27 | unsafe-vector*-ref 28 | unsafe-vector*-set! 29 | unsafe-fxvector-length 30 | unsafe-fxvector-ref 31 | unsafe-fxvector-set!) 32 | (require racket/fixnum) 33 | 34 | (define unsafe-list-ref list-ref) 35 | (define unsafe-car car) 36 | (define unsafe-cdr cdr) 37 | (define unsafe-fxmin fxmin) 38 | (define unsafe-fxmax fxmax) 39 | (define unsafe-fx= fx=) 40 | (define unsafe-fx<= fx<=) 41 | (define unsafe-fx< fx<) 42 | (define unsafe-fx+ fx+) 43 | (define unsafe-fx- fx-) 44 | (define unsafe-fx* fx*) 45 | (define unsafe-fxand fxand) 46 | (define unsafe-fxior fxior) 47 | (define unsafe-fxxor fxxor) 48 | (define unsafe-fxnot fxnot) 49 | (define unsafe-fxlshift fxlshift) 50 | (define unsafe-fxrshift fxrshift) 51 | (define unsafe-fxquotient fxquotient) 52 | (define unsafe-fxremainder fxremainder) 53 | (define unsafe-bytes-length bytes-length) 54 | (define unsafe-bytes-ref bytes-ref) 55 | (define unsafe-bytes-set! bytes-set!) 56 | (define unsafe-bytes-copy! bytes-copy!) 57 | (define unsafe-vector*-length vector-length) 58 | (define unsafe-vector*-ref vector-ref) 59 | (define unsafe-vector*-set! vector-set!) 60 | (define unsafe-fxvector-length fxvector-length) 61 | (define unsafe-fxvector-ref fxvector-ref) 62 | (define unsafe-fxvector-set! fxvector-set!) 63 | -------------------------------------------------------------------------------- /dbk/stream.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide s-next s-force s-split s-drop 3 | s-take/set/steps s-take/set s-take/steps s-take 4 | s-each s-foldr s-foldl s-split-foldl s-scan 5 | s-append/interleaving s-append*/interleaving 6 | s-append s-append* s-map/append s-map s-filter s-group s-memo s-lazy 7 | s-length s-enumerate s-dedup s-skip s-limit 8 | s-chunk s-unchunk s->list list->s) 9 | (require ;"safe-unsafe.rkt" 10 | racket/unsafe/ops 11 | racket/function racket/match racket/set racket/vector) 12 | 13 | (define (s-next s) (if (procedure? s) (s) s)) 14 | (define (s-force s) (if (procedure? s) (s-force (s)) s)) 15 | 16 | ;; lazy variant of s-drop 17 | (define (s-skip n s) 18 | (cond ((= n 0) s) 19 | ((pair? s) (s-skip (- n 1) (cdr s))) 20 | (else (thunk (s-skip n (s)))))) 21 | ;; lazy variant of s-take 22 | (define (s-limit n s) 23 | (cond ((or (= n 0) (null? s)) '()) 24 | ((pair? s) (cons (car s) (s-limit (- n 1) (cdr s)))) 25 | (else (thunk (s-limit n (s)))))) 26 | 27 | (define (s-foldl f acc s) 28 | (let loop ((acc acc) (s s)) 29 | (cond ((null? s) acc) 30 | ((procedure? s) (loop acc (s))) 31 | (else (loop (f (car s) acc) (cdr s)))))) 32 | 33 | (define (s-split-foldl n f acc s) 34 | (let loop ((n n) (acc acc) (s s)) 35 | (cond ((= n 0) (values acc s)) 36 | ((null? s) (values acc '())) 37 | ((procedure? s) (loop n acc (s))) 38 | (else (loop (- n 1) (f (car s) acc) (cdr s)))))) 39 | 40 | (define (s-split n s) 41 | (let-values (((rx* s.remaining) (s-split-foldl n cons '() s))) 42 | (values (reverse rx*) s.remaining))) 43 | 44 | (define (s-take/set/steps steps n s) 45 | (if (and n (= n 0)) (set) 46 | (let loop ((steps steps) (s s) (acc (set))) 47 | (match s 48 | ((? procedure? s) (if (and steps (= steps 0)) 49 | acc 50 | (loop (and steps (- steps 1)) (s) acc))) 51 | ('() acc) 52 | ((cons x s) (define xs (set-add acc x)) 53 | (if (and n (= n (set-count xs))) 54 | xs 55 | (loop steps s xs))))))) 56 | 57 | (define (s-take/steps steps n s) 58 | (if (and n (= n 0)) '() 59 | (match s 60 | ((? procedure? s) (if (and steps (= steps 0)) 61 | '() 62 | (s-take/steps (and steps (- steps 1)) n (s)))) 63 | ('() '()) 64 | ((cons x s) (cons x (s-take/steps steps (and n (- n 1)) s)))))) 65 | 66 | (define (s-take/set n s) (s-take/set/steps #f n s)) 67 | (define (s-take n s) (s-take/steps #f n s)) 68 | (define (s-drop n s) (let-values (((_ s) (s-split-foldl n (lambda (_ acc) #t) #t s))) s)) 69 | 70 | ;; equivalent to (s-take #f s) 71 | (define (s->list s) 72 | (cond ((null? s) '()) 73 | ((pair? s) (cons (car s) (s->list (cdr s)))) 74 | (else (s->list (s))))) 75 | ;; equivalent to s-lazy for a list 76 | (define (list->s xs) 77 | (thunk (if (null? xs) 78 | '() 79 | (cons (car xs) (list->s (cdr xs)))))) 80 | 81 | ;; TODO: generalize to multiple streams 82 | (define (s-foldr f acc s) 83 | (cond ((null? s) acc) 84 | ((pair? s) (f (car s) (s-foldr f acc (cdr s)))) 85 | (else (thunk (s-foldr f acc (s)))))) 86 | 87 | (define (s-append*/interleaving s*) (s-foldr s-append/interleaving '() s*)) 88 | ;; TODO: generalize to multiple streams 89 | (define (s-append/interleaving s1 s2) 90 | (cond ((null? s1) (s2)) 91 | ((procedure? s1) (thunk (s-append/interleaving (s2) s1))) 92 | (else (define d1 (cdr s1)) 93 | (define s1^ (if (procedure? d1) d1 (thunk d1))) 94 | (cons (car s1) (thunk (s-append/interleaving (s2) s1^)))))) 95 | 96 | (define (s-append* ss) (s-foldr s-append '() ss)) 97 | ;; TODO: generalize to multiple streams 98 | (define (s-append a b) (s-foldr cons b a)) 99 | (define (s-filter ? s) (s-foldr (lambda (x acc) (if (? x) (cons x acc) acc)) 100 | '() s)) 101 | 102 | (define s-map 103 | (case-lambda 104 | ((f s) 105 | (let loop ((s s)) 106 | (cond ((null? s) '()) 107 | ((procedure? s) (lambda () (loop (s)))) 108 | (else (cons (f (car s)) (loop (cdr s))))))) 109 | ((f s . s*) 110 | (let loop.outer ((s s) (s* s*)) 111 | (cond ((null? s) '()) 112 | ((procedure? s) (lambda () (loop.outer (s) s*))) 113 | (else (let loop ((s*-pending s*) (rs* '())) 114 | (if (null? s*-pending) 115 | (let ((s* (reverse rs*))) 116 | (cons (apply f (car s) (map car s*)) 117 | (loop.outer (cdr s) (map cdr s*)))) 118 | (let next ((s*0 (car s*-pending))) 119 | (cond ((procedure? s*0) (lambda () (next (s*0)))) 120 | (else (loop (cdr s*-pending) (cons s*0 rs*))))))))))))) 121 | 122 | ;; TODO: generalize to multiple streams 123 | (define (s-map/append f s) 124 | (s-foldr (lambda (x rest) (s-append (f x) rest)) 125 | '() s)) 126 | 127 | (define (s-each p s) (let ((s (s-force s))) 128 | (unless (null? s) (p (car s)) (s-each p (cdr s))))) 129 | 130 | (define (s-scan s acc f) 131 | (cons acc (cond ((null? s) '()) 132 | ((pair? s) (s-scan (cdr s) (f (car s) acc) f)) 133 | (else (thunk (s-scan (s) acc f)))))) 134 | 135 | (define (s-length s) (s-foldl (lambda (_ l) (+ l 1)) 0 s)) 136 | 137 | (define (s-group s ? @) 138 | (let ((@ (or @ (lambda (x) x)))) 139 | (cond ((null? s) '()) 140 | ((procedure? s) (thunk (s-group (s) ? @))) 141 | (else (let next ((x (@ (car s))) (s s)) 142 | (let loop ((g (list (car s))) (s (cdr s))) 143 | (cond ((null? s) (list g)) 144 | ((procedure? s) (thunk (loop g (s)))) 145 | (else (let ((y (@ (car s)))) 146 | (if (? y x) (loop (cons (car s) g) (cdr s)) 147 | (cons g (next y s)))))))))))) 148 | 149 | (define (s-chunk s len.chunk) 150 | (cond 151 | ((<= len.chunk 0) (error "chunk length must be positive" len.chunk)) 152 | ((= len.chunk 1) (s-map vector s)) 153 | (else (let new ((s s)) 154 | (cond ((null? s) '()) 155 | ((procedure? s) (lambda () (new (s)))) 156 | (else (let ((chunk (make-vector len.chunk))) 157 | (unsafe-vector*-set! chunk 0 (car s)) 158 | (let loop ((s (cdr s)) (i 1)) 159 | (cond 160 | ((null? s) (list (vector-copy chunk 0 i))) 161 | ((procedure? s) (lambda () (loop (s) i))) 162 | (else (unsafe-vector*-set! chunk i (car s)) 163 | (let ((i (unsafe-fx+ i 1))) 164 | (if (unsafe-fx< i len.chunk) 165 | (loop (cdr s) i) 166 | (cons chunk (new (cdr s))))))))))))))) 167 | 168 | (define (s-unchunk s) 169 | (let next ((s s)) 170 | (cond ((null? s) '()) 171 | ((procedure? s) (lambda () (next (s)))) 172 | (else (let* ((x* (car s)) (len.chunk (vector-length x*))) 173 | (let loop ((i 0)) 174 | (if (unsafe-fx< i len.chunk) 175 | (cons (unsafe-vector*-ref x* i) (loop (unsafe-fx+ i 1))) 176 | (next (cdr s))))))))) 177 | 178 | (define (s-memo s) 179 | (cond ((procedure? s) (let ((v #f) (s s)) 180 | (thunk (when s (set! v (s-memo (s))) (set! s #f)) 181 | v))) 182 | ((null? s) '()) 183 | (else (cons (car s) (s-memo (cdr s)))))) 184 | 185 | (define (s-lazy s) 186 | (define (return s) 187 | (cond ((null? s) '()) 188 | (else (cons (car s) (s-lazy (cdr s)))))) 189 | (thunk (cond ((procedure? s) (let retry ((s (s))) 190 | (cond ((procedure? s) (thunk (retry (s)))) 191 | (else (return s))))) 192 | (else (return s))))) 193 | 194 | (define (s-enumerate i s) 195 | (cond ((null? s) '()) 196 | ((pair? s) (cons (cons i (car s)) (s-enumerate (+ i 1) (cdr s)))) 197 | (else (thunk (s-enumerate i (s)))))) 198 | 199 | ;; NOTE: only adjacent duplicates are removed 200 | (define (s-dedup s) 201 | (define (loop x s) 202 | (cond ((null? s) (list x)) 203 | ((pair? s) (if (equal? x (car s)) (loop x (cdr s)) 204 | (cons x (loop (car s) (cdr s))))) 205 | (else (thunk (loop x (s)))))) 206 | (cond ((null? s) '()) 207 | ((pair? s) (loop (car s) (cdr s))) 208 | (else (thunk (s-dedup (s)))))) 209 | -------------------------------------------------------------------------------- /dbk/syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | (struct-out make-query) 4 | (struct-out disj) 5 | (struct-out conj) 6 | (struct-out constrain) 7 | (struct-out ==/use) 8 | (struct-out var) 9 | (struct-out term/vars) 10 | relate 11 | 12 | make-relation relations relations-ref relations-set! relations-set*! 13 | relation letrec-relation define-relation 14 | conj* disj* fresh conde :== query 15 | == =/= any<=o flooro +o *o string==byteso symbol==stringo functiono 16 | vector-lengtho vector-refo bytes-lengtho bytes-refo 17 | 18 | ground? term-vars 19 | make-pretty pretty) 20 | (require racket/match racket/set racket/vector) 21 | 22 | (struct query (term formula) #:prefab #:name make-query 23 | #:constructor-name make-query) 24 | ;; formulas 25 | (struct disj (f1 f2) #:prefab) 26 | (struct conj (f1 f2) #:prefab) 27 | (struct constrain (op terms) #:prefab) 28 | (struct ==/use (lhs-term args rhs-proc desc) #:prefab) 29 | ;; terms 30 | ; term: pair or vector with embedded variables 31 | ; vars: optional; set of variables found somewhere within term 32 | (struct term/vars (term vars)) 33 | (struct var (name)) 34 | 35 | (define-syntax define-constraint 36 | (syntax-rules () 37 | ((_ (op params ...)) (define (op params ...) 38 | (constrain 'op (list params ...)))))) 39 | (define-constraint (== t1 t2)) 40 | (define-constraint (=/= t1 t2)) 41 | (define-constraint (any<=o t1 t2)) 42 | (define-constraint (flooro t1 t2)) 43 | (define-constraint (+o t1 t2 t3)) 44 | (define-constraint (*o t1 t2 t3)) 45 | (define-constraint (vector-lengtho t l)) 46 | (define-constraint (vector-refo t i x)) 47 | (define-constraint (bytes-lengtho t l)) 48 | (define-constraint (bytes-refo t i x)) 49 | (define-constraint (symbol==stringo t1 t2)) 50 | (define-constraint (string==byteso t1 t2)) ;; as utf-8 51 | (define-constraint (functiono t1 t2)) ;; uninterpreted functional dependency 52 | (define (relate proc args) (constrain proc args)) 53 | 54 | (define relation-registry (make-weak-hasheq '())) 55 | (define (relations) (hash->list relation-registry)) 56 | (define (relations-ref proc) (hash-ref relation-registry proc)) 57 | (define (relations-set! proc k v) (relations-set*! proc `((,k . ,v)))) 58 | (define (relations-set*! proc alist) 59 | (hash-set! relation-registry proc 60 | (foldl (lambda (kv acc) (hash-set acc (car kv) (cdr kv))) 61 | (relations-ref proc) alist))) 62 | (define (make-relation name attributes) 63 | (define n ((make-syntax-introducer) (datum->syntax #f name))) 64 | (define r (eval-syntax #`(letrec ((#,n (lambda args (relate #,n args)))) 65 | #,n))) 66 | (hash-set! relation-registry r (make-immutable-hash 67 | `((name . ,name) 68 | (attribute-names . ,attributes)))) 69 | r) 70 | 71 | (define-syntax relation 72 | (syntax-rules () 73 | ((_ name (param ...) f ...) 74 | (let ((r (make-relation 'name '(param ...)))) 75 | (relations-set! r 'expand (lambda (param ...) (fresh () f ...))) 76 | r)))) 77 | (define-syntax letrec-relation 78 | (syntax-rules () 79 | ((_ (((name param ...) f ...) ...) body ...) 80 | (letrec ((name (relation name (param ...) f ...)) ...) body ...)))) 81 | (define-syntax define-relation 82 | (syntax-rules () 83 | ((_ (name param ...) f ...) 84 | (define name (relation name (param ...) f ...))))) 85 | (define success (== #t #t)) 86 | (define failure (== #f #t)) 87 | (define (conj* . fs) 88 | (if (null? fs) success 89 | (foldl (lambda (f2 f1) (conj f1 f2)) (car fs) (cdr fs)))) 90 | (define (disj* . fs) 91 | (if (null? fs) failure 92 | (let loop ((f (car fs)) (fs (cdr fs))) 93 | (if (null? fs) f 94 | (disj f (loop (car fs) (cdr fs))))))) 95 | (define-syntax let/fresh 96 | (syntax-rules () 97 | ((_ (x ...) e ...) (let ((x (var 'x)) ...) e ...)))) 98 | (define-syntax fresh 99 | (syntax-rules () 100 | ((_ (x ...) f0 fs ...) (let/fresh (x ...) (conj* f0 fs ...))))) 101 | (define-syntax conde 102 | (syntax-rules () 103 | ((_ (f fs ...) (h hs ...) ...) 104 | (disj* (conj* f fs ...) (conj* h hs ...) ...)))) 105 | (define-syntax :== 106 | (syntax-rules () 107 | ((_ t (x ...) body ...) (==/use t (list x ...) (lambda (x ...) body ...) 108 | `((x ...) body ...))))) 109 | (define-syntax query 110 | (syntax-rules () 111 | ((_ (x ...) f0 fs ...) 112 | (let/fresh (x ...) (make-query (list x ...) (conj* f0 fs ...)))) 113 | ((_ x f0 fs ...) 114 | (let/fresh (x) (make-query x (conj* f0 fs ...)))))) 115 | 116 | (define seteq.empty (seteq)) 117 | (define (term-vars t) 118 | (cond ((var? t) (seteq t)) 119 | ((pair? t) (set-union (term-vars (car t)) (term-vars (cdr t)))) 120 | ((vector? t) (apply set-union seteq.empty (map term-vars (vector->list t)))) 121 | (else seteq.empty))) 122 | (define (ground? t) 123 | (cond ((var? t) #f) 124 | ((pair? t) (and (ground? (car t)) (ground? (cdr t)))) 125 | ((vector? t) (andmap ground? (vector->list t))) 126 | (else #t))) 127 | 128 | (define (make-pretty) 129 | (define var=>id (make-hash)) 130 | (define (pretty-term t) 131 | (cond ((pair? t) (cons (pretty-term (car t)) (pretty-term (cdr t)))) 132 | ((vector? t) (vector-map pretty-term t)) 133 | ((var? t) `#s(var ,(let ((id (hash-ref var=>id t #f)) 134 | (c (hash-count var=>id))) 135 | (or id (begin (hash-set! var=>id t c) c))))) 136 | (else (pretty-formula t)))) 137 | (define (pretty-formula f) 138 | (match f 139 | (`#s(disj ,f1 ,f2) `#s(disj ,(pretty-formula f1) 140 | ,(pretty-formula f2))) 141 | (`#s(conj ,f1 ,f2) `#s(conj ,(pretty-formula f1) 142 | ,(pretty-formula f2))) 143 | (`#s(constrain ,op ,terms) `(,op . ,(map pretty-term terms))) 144 | (`#s(==/use ,lhs ,args ,rhs ,desc) 145 | (define (pretty-arg t) (pretty-term t)) 146 | `(:== ,(pretty-term lhs) 147 | #s(let ,(map list (car desc) (map pretty-arg args)) 148 | ,@(cdr desc)))) 149 | (_ f))) 150 | (lambda (x) 151 | (match x 152 | (`#s(query ,t ,f) 153 | `#s(query ,(pretty-term t) ,(pretty-formula f))) 154 | (_ (if (or (disj? x) (conj? x) (constrain? x) (==/use? x)) 155 | (pretty-formula x) (pretty-term x)))))) 156 | (define (pretty x) ((make-pretty) x)) 157 | -------------------------------------------------------------------------------- /experiment/syntax.rkt: -------------------------------------------------------------------------------- 1 | (relation* +o *o edge path appendo) 2 | (term* append + * some-constant) 3 | 4 | 5 | ;; Both terms and relations can use define. They are syntactically distinguished: 6 | ;; - term definition: (define ,identifier ,term ,formula ...) 7 | ;; - relation definition: (define (,identifier ,parameter ...) ,formula ...) 8 | 9 | (define (appendo x* y x*y) 10 | (conde 11 | ((== x* '()) (== x*y* y)) 12 | ((exist (w w* w*y) 13 | (== x* (cons w w*)) 14 | (== x*y (cons w w*y)) 15 | (appendo w* y w*y))))) 16 | 17 | (define some-constant '(this is a constant term)) 18 | 19 | 20 | quantification might be broken for bi-implication 21 | 22 | 23 | (define append 24 | (case-lambda 25 | ((a) a) 26 | ((a b) c (appendo a b c)) 27 | ((a b c . rest*) (append a (append b c . rest*))))) 28 | 29 | (define + 30 | (case-lambda 31 | ((a) a) 32 | ((a b) c (+o a b c)) 33 | ((a b c . rest*) (+ (+ a b) c . rest*)))) 34 | 35 | (define map 36 | (lambda (f x*) 37 | y* 38 | (local 39 | ((rule* 40 | ((mapo '() '())) 41 | ((mapo (cons a a*) (cons (f a) b*)) 42 | (mapo a* b*)))) 43 | (mapo x* y*)))) 44 | 45 | (define another-constant (map (lambda (x) (+ x 1)) '(6 7 8))) 46 | 47 | (fact* 48 | (edge 49 | (a b) 50 | (a c) 51 | (a d) 52 | (b e) 53 | (c e) 54 | (d f) 55 | (e g))) 56 | 57 | (rule* 58 | ((path a b) (edge a b)) 59 | ((path a c) (path a b) (path b c)) 60 | ;; another way to define appendo 61 | ((appendo '() y y)) 62 | ((appendo (cons w w*) y (cons w w*y)) 63 | (appendo w* y w*y)) 64 | ;; we can also add more facts as rules 65 | ((edge 'g some-constant))) 66 | 67 | ;; NOTE: if implicit quantification seems unpleasant, but still want the convenient notation of 68 | ;; parameter patterns, we can instead add outer universal quantifiers. 69 | ;; For instance: 70 | ; 71 | ;(all (c y* a* b* w w* w*y) ; These are all the local variables mentioned in any rule or definition. 72 | ; (define append 73 | ; (case-lambda 74 | ; ((a) a) 75 | ; ((a b) c (appendo a b c)) 76 | ; ((a b c . rest*) (append a (append b c . rest*))))) 77 | ; 78 | ; (define + 79 | ; (case-lambda 80 | ; ((a) a) 81 | ; ((a b) c (+o a b c)) 82 | ; ((a b c . rest*) (+ (+ a b) c . rest*)))) 83 | ; 84 | ; (define map 85 | ; (lambda (f x*) 86 | ; y* 87 | ; (local 88 | ; ((rule* 89 | ; ((mapo '() '())) 90 | ; ((mapo (cons a a*) (cons (f a) b*)) 91 | ; (mapo a* b*)))) 92 | ; (mapo x* y*)))) 93 | ; 94 | ; (rule* 95 | ; ((path a b) (edge a b)) 96 | ; ((path a c) (path a b) (path b c)) 97 | ; ;; another way to define appendo 98 | ; ((appendo '() y y)) 99 | ; ((appendo (cons w w*) y (cons w w*y)) 100 | ; (appendo w* y w*y)) 101 | ; ;; we can also add more facts as rules 102 | ; ((edge 'g some-constant)) 103 | ; ) 104 | ; 105 | ; ;; etc. 106 | ; ) 107 | -------------------------------------------------------------------------------- /experiment/test-sort.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../dbk/safe-unsafe.rkt" racket/fixnum racket/pretty) 3 | 4 | (define (unsafe-fxvector-copy! vec.out out.start vec.in in.start in.end) 5 | (let loop ((in in.start) (out out.start)) 6 | (when (unsafe-fx< in in.end) 7 | (unsafe-fxvector-set! vec.out out (unsafe-fxvector-ref vec.in in)) 8 | (loop (unsafe-fx+ in 1) (unsafe-fx+ out 1))))) 9 | 10 | (define (unsafe-fxvector-sort! z* start end) (unsafe-fxvector-sort!/ 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | struct timeval timespec_start, timespec_end; 9 | void time_start() { 10 | if (gettimeofday(×pec_start, 0) != 0) { 11 | printf("time_start failed\n"); 12 | exit(1); 13 | } 14 | } 15 | void time_end() { 16 | if (gettimeofday(×pec_end, 0) != 0) { 17 | printf("time_end failed\n"); 18 | exit(1); 19 | } 20 | time_t delta_sec = timespec_end.tv_sec - timespec_start.tv_sec; 21 | suseconds_t delta_usec = timespec_end.tv_usec - timespec_start.tv_usec; 22 | delta_usec += delta_sec * 1000000; 23 | delta_sec = delta_usec / 1000000; 24 | delta_usec = delta_usec % 1000000; 25 | printf("%ld.%06d elapsed seconds\n", delta_sec, delta_usec); 26 | } 27 | 28 | typedef unsigned long long u64; 29 | typedef long long s64; 30 | typedef unsigned char u8; 31 | 32 | void show_u8(u8* vec, u64 start, u64 end) { 33 | for (u64 i = start; i < end; ++i) { 34 | printf("%hhu ", vec[i]); 35 | } 36 | printf("\n"); 37 | } 38 | void show_s64(s64* vec, u64 start, u64 end) { 39 | for (u64 i = start; i < end; ++i) { 40 | printf("%lld ", vec[i]); 41 | } 42 | printf("\n"); 43 | } 44 | 45 | u64 min_bits(u64 n) { 46 | u64 bits = 0; 47 | while (0 < n) { 48 | bits += 1; 49 | n >>= 1; 50 | } 51 | return bits; 52 | } 53 | u64 min_bytes(u64 n) { 54 | u64 bits = min_bits(n); 55 | return (bits / 8) + (((bits % 8) == 0) ? 0 : 1); 56 | } 57 | static inline u64 max(u64 a, u64 b) { return (a < b) ? b : a; } 58 | u64 nat_min_byte_width(u64 n_max) { return max(min_bytes(n_max), 1); } 59 | 60 | s64 v_min, v_max; 61 | u64 expected_byte_width, count, byte_width, size, bw2, bw3, bw4; 62 | u8 *input; 63 | s64* output; 64 | 65 | void init() { 66 | // Fit into 4 bytes 67 | /*#define nat_set nat_set4*/ 68 | /*#define nat_ref nat_ref4*/ 69 | /*expected_byte_width = 4;*/ 70 | /*v_min = -16250000;*/ 71 | /*v_max = 16250000;*/ 72 | 73 | #define nat_set nat_set4 74 | #define nat_ref nat_ref4 75 | expected_byte_width = 4; 76 | v_min = -10000000; 77 | v_max = 10000000; 78 | 79 | // Fit into 3 bytes 80 | /*#define nat_set nat_set3*/ 81 | /*#define nat_ref nat_ref3*/ 82 | /*expected_byte_width = 3;*/ 83 | /*v_min = -8000000;*/ 84 | /*v_max = 8000000;*/ 85 | 86 | count = v_max - v_min; 87 | byte_width = nat_min_byte_width(count); 88 | size = count * byte_width; 89 | bw2 = byte_width * 2; 90 | bw3 = byte_width * 3; 91 | bw4 = byte_width * 4; 92 | 93 | input = malloc(size); 94 | output = malloc(count * sizeof(s64)); 95 | } 96 | 97 | static inline u64 encode(s64 n) { return n - v_min; } 98 | static inline s64 decode(u64 n) { return n + v_min; } 99 | 100 | static inline void nat_set3(u8* bvec, u64 i, u64 n) { 101 | bvec[i] = ((n >> 16) & 255); 102 | bvec[i+1] = ((n >> 8) & 255); 103 | bvec[i+2] = (n & 255); 104 | } 105 | 106 | static inline u64 nat_ref3(u8* bvec, u64 i) { 107 | return 108 | ((bvec[i] << 16) + 109 | (bvec[i+1] << 8) + 110 | bvec[i+2]); 111 | } 112 | 113 | static inline void nat_set4(u8* bvec, u64 i, u64 n) { 114 | bvec[i] = ((n >> 24) & 255); 115 | bvec[i+1] = ((n >> 16) & 255); 116 | bvec[i+2] = ((n >> 8) & 255); 117 | bvec[i+3] = (n & 255); 118 | } 119 | 120 | static inline u64 nat_ref4(u8* bvec, u64 i) { 121 | return 122 | ((bvec[i] << 24) + 123 | (bvec[i+1] << 16) + 124 | (bvec[i+2] << 8) + 125 | bvec[i+3]); 126 | } 127 | 128 | void generate_input() { 129 | time_start(); 130 | u64 start = 0; 131 | for (s64 i = v_min; i < v_max; ++i, start += byte_width) { 132 | nat_set(input, start, encode(i)); 133 | } 134 | time_end(); 135 | } 136 | 137 | void decode_input() { 138 | time_start(); 139 | for (u64 i = 0, start = 0; i < count; ++i, start += byte_width) { 140 | output[i] = decode(nat_ref(input, start)); 141 | } 142 | time_end(); 143 | } 144 | 145 | void multi_decode_input() { 146 | time_start(); 147 | for (u64 i = 0, start = 0; i < count; i += 2, start += bw2) { 148 | output[i] = decode(nat_ref(input, start)); 149 | output[i+1] = decode(nat_ref(input, start + byte_width)); 150 | } 151 | // 4x unrolled seems to perform the same as 2x. 152 | /*for (u64 i = 0, start = 0; i < count; i += 4, start += bw4) {*/ 153 | /*output[i] = decode(nat_ref(input, start));*/ 154 | /*output[i+1] = decode(nat_ref(input, start + byte_width));*/ 155 | /*output[i+2] = decode(nat_ref(input, start + bw2));*/ 156 | /*output[i+3] = decode(nat_ref(input, start + bw3));*/ 157 | /*}*/ 158 | time_end(); 159 | } 160 | 161 | u64 throwaway = 0; 162 | 163 | void pretend_decode_input() { 164 | time_start(); 165 | for (u64 i = 0, start = 0; i < count; ++i, start += byte_width) { 166 | ++throwaway; 167 | //output[i] = decode(nat_ref(input, start)); 168 | } 169 | time_end(); 170 | } 171 | 172 | void pretend_decode_input_more() { 173 | time_start(); 174 | for (u64 i = 0, start = 0; i < count; ++i, start += byte_width) { 175 | throwaway += decode(nat_ref(input, start)); 176 | //output[i] = ; 177 | } 178 | time_end(); 179 | } 180 | 181 | int main() { 182 | assert(sizeof(u64) == 8); 183 | assert(sizeof(s64) == 8); 184 | assert(sizeof(u8) == 1); 185 | assert(byte_width == expected_byte_width); 186 | 187 | init(); 188 | printf("count: %llu byte-width: %llu\n", count, byte_width); 189 | 190 | // count: 16000000 byte-width: 3 191 | // 0.047094 elapsed seconds 192 | // 0.000000 elapsed seconds 193 | // 0.018841 elapsed seconds 194 | // 0.099701 elapsed seconds 195 | // 0.024144 elapsed seconds 196 | // count: 20000000 byte-width: 4 197 | // 0.073569 elapsed seconds 198 | // 0.000001 elapsed seconds 199 | // 0.030951 elapsed seconds 200 | // 0.130310 elapsed seconds 201 | // 0.037042 elapsed seconds 202 | // count: 32500000 byte-width: 4 203 | // 0.117449 elapsed seconds 204 | // 0.000000 elapsed seconds 205 | // 0.052090 elapsed seconds 206 | // 0.205715 elapsed seconds 207 | // 0.063819 elapsed seconds 208 | generate_input(); 209 | pretend_decode_input(); 210 | pretend_decode_input_more(); 211 | decode_input(); 212 | multi_decode_input(); 213 | 214 | show_u8(input, 0, 100); 215 | show_u8(input, 10000, 10100); 216 | show_s64(output, 0, 10); 217 | show_s64(output, count-10, count); 218 | return 0; 219 | } 220 | -------------------------------------------------------------------------------- /test/benchmark-compression/share-prefix-with-previous-decode.c: -------------------------------------------------------------------------------- 1 | // gcc -O2 -o share-prefix-with-previous.out share-prefix-with-previous.c && ./share-prefix-with-previous.out && rm share-prefix-with-previous.out 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | struct timeval timespec_start, timespec_end; 10 | void time_start() { 11 | if (gettimeofday(×pec_start, 0) != 0) { 12 | printf("time_start failed\n"); 13 | exit(1); 14 | } 15 | } 16 | void time_end() { 17 | if (gettimeofday(×pec_end, 0) != 0) { 18 | printf("time_end failed\n"); 19 | exit(1); 20 | } 21 | time_t delta_sec = timespec_end.tv_sec - timespec_start.tv_sec; 22 | suseconds_t delta_usec = timespec_end.tv_usec - timespec_start.tv_usec; 23 | delta_usec += delta_sec * 1000000; 24 | delta_sec = delta_usec / 1000000; 25 | delta_usec = delta_usec % 1000000; 26 | printf("%ld.%06d elapsed seconds\n", delta_sec, delta_usec); 27 | } 28 | 29 | typedef unsigned long long u64; 30 | typedef unsigned int u32; 31 | typedef unsigned char u8; 32 | 33 | void show(u8* vec, u64 start, u64 end) { 34 | for (u64 i = start; i < end; ++i) { 35 | u8 ch = vec[i]; 36 | if (31 < ch && ch < 128) { 37 | printf("%c", ch); 38 | } else { 39 | printf("\\%x", ch); 40 | } 41 | } 42 | printf("\n"); 43 | } 44 | 45 | #define COUNT 10000000 46 | #define DIGIT_COUNT 7 47 | #define LEN_PREFIX 6 48 | #define LEN (DIGIT_COUNT + LEN_PREFIX) 49 | u8* prefix = (u8*)"SHARE:"; 50 | u64 count = COUNT; 51 | u64 digit_count = DIGIT_COUNT; 52 | u64 len_prefix = LEN_PREFIX; 53 | u64 len = LEN; 54 | u64 size = LEN * COUNT; 55 | u8 input[LEN * COUNT], output[LEN * COUNT]; 56 | u64 lengths[COUNT], shared_prefix_lengths[COUNT]; 57 | void init() { 58 | for (u64 i = 0; i < count; ++i) { lengths[i] = len; } 59 | } 60 | 61 | static inline void copy(u8* out, u8* in, u64 size) { 62 | for (u64 i = 0; i < size; ++i) { out[i] = in[i]; } 63 | } 64 | 65 | void generate_input() { 66 | time_start(); 67 | u64 pos = 0; 68 | u8 buf1[LEN], buf2[LEN]; 69 | u8 *previous = buf1, *next = buf2; 70 | for (u64 i = 0; i < len; ++i) { previous[i] = 0; } 71 | for (u64 i = 0; i < count; ++i) { 72 | for (u64 i = 0; i < len; ++i) { next[i] = '0'; } 73 | copy(next, prefix, len_prefix); 74 | for (u64 n = i, j = len - 1; 0 < n; n /= 10, --j) { 75 | next[j] = '0' + (n % 10); 76 | } 77 | u64 shared_prefix_length = 0; 78 | { 79 | u64 j = 0; 80 | for (; (j < len) && (previous[j] == next[j]); ++j) { } 81 | shared_prefix_length = j; 82 | } 83 | shared_prefix_lengths[i] = shared_prefix_length; 84 | u64 diff_len = len-shared_prefix_length; 85 | copy(input+pos, next+shared_prefix_length, diff_len); 86 | pos += diff_len; 87 | u8 *temp = previous; 88 | previous = next; 89 | next = temp; 90 | } 91 | time_end(); 92 | } 93 | 94 | void decode_input() { 95 | time_start(); 96 | for (u64 i = 0, start_in = 0, start_out = 0, prev_out = 0; i < count; ++i, start_out += len) { 97 | u64 shared_prefix_length = shared_prefix_lengths[i]; 98 | u64 diff_len = len - shared_prefix_length; 99 | copy(output+start_out, output+prev_out, shared_prefix_length); 100 | copy(output+start_out+shared_prefix_length, input+start_in, diff_len); 101 | start_in += diff_len; 102 | prev_out = start_out; 103 | } 104 | time_end(); 105 | } 106 | 107 | void pretend_decode_input() { 108 | time_start(); 109 | for (u64 i = 0, start_in = 0, start_out = 0, prev_out = 0; i < count; ++i, start_out += len) { 110 | u64 shared_prefix_length = shared_prefix_lengths[i]; 111 | u64 diff_len = len - shared_prefix_length; 112 | /*copy(output+start_out, output+prev_out, shared_prefix_length);*/ 113 | /*copy(output+start_out+shared_prefix_length, input+start_in, diff_len);*/ 114 | start_in += diff_len; 115 | prev_out = start_out; 116 | } 117 | time_end(); 118 | } 119 | 120 | int main() { 121 | assert(sizeof(u64) == 8); 122 | assert(sizeof(u32) == 4); 123 | assert(sizeof(u8) == 1); 124 | init(); 125 | 126 | // 0.376858 elapsed seconds 127 | generate_input(); 128 | 129 | // 0.152725 elapsed seconds 130 | time_start(); 131 | memcpy(output, input, size); // slower than any of the loops with O2 optimization 132 | time_end(); 133 | // 0.020945 elapsed seconds 134 | time_start(); 135 | copy(output, input, size); 136 | time_end(); 137 | // 0.021991 elapsed seconds 138 | time_start(); 139 | for (u64 i = 0; i < size; ++i) { output[i] = input[i]; } 140 | time_end(); 141 | // For some reason, unrolling any of the following loops by 2x, 4x, or 8x is 142 | // slower than not unrolling. 143 | /*time_start();*/ 144 | /*for (u64 i = 0; i < size; i+=2) {*/ 145 | /*output[i] = input[i];*/ 146 | /*output[i+1] = input[i+1];*/ 147 | /*}*/ 148 | /*time_end();*/ 149 | // 0.019748 elapsed seconds 150 | { 151 | time_start(); 152 | u32* in32 = (u32*)input; 153 | u32* out32 = (u32*)output; 154 | u64 size32 = size/sizeof(u32); 155 | for (u64 i = 0; i < size32; ++i) { out32[i] = in32[i]; } 156 | time_end(); 157 | } 158 | // 0.028728 elapsed seconds 159 | { 160 | time_start(); 161 | u64* in64 = (u64*)input; 162 | u64* out64 = (u64*)output; 163 | u64 size64 = size/sizeof(u64); 164 | for (u64 i = 0; i < size64; ++i) { out64[i] = in64[i]; } 165 | time_end(); 166 | } 167 | 168 | // 0.000000 elapsed seconds 169 | pretend_decode_input(); 170 | // 0.137580 elapsed seconds 171 | decode_input(); 172 | 173 | show(input, 0, 100); 174 | show(input, 10000, 10100); 175 | show(output, 0, 100); 176 | show(output, size-100, size); 177 | return 0; 178 | } 179 | -------------------------------------------------------------------------------- /test/benchmark-compression/share-prefix-with-previous-decode.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe/vm racket/fixnum racket/pretty) 3 | (require 4 | ;"../../dbk/safe-unsafe.rkt" 5 | racket/unsafe/ops 6 | ) 7 | 8 | ;;; Prefix compression relative to previous value 9 | 10 | (define enable-interrupts (vm-primitive 'enable-interrupts)) 11 | (define disable-interrupts (vm-primitive 'disable-interrupts)) 12 | 13 | (define bytevector-u32-native-ref (vm-primitive 'bytevector-u32-native-ref)) 14 | (define bytevector-u32-native-set! (vm-primitive 'bytevector-u32-native-set!)) 15 | (define bytevector-u64-native-ref (vm-primitive 'bytevector-u64-native-ref)) 16 | (define bytevector-u64-native-set! (vm-primitive 'bytevector-u64-native-set!)) 17 | 18 | (define prefix #"SHARE:") 19 | (define digit-count 7) 20 | (define len.prefix (bytes-length prefix)) 21 | (define len (+ len.prefix digit-count)) 22 | 23 | (define count 10000000) 24 | (define size (* len count)) 25 | (define input (make-bytes size)) 26 | (define output (make-bytes size)) 27 | 28 | (define length* (make-fxvector count len)) 29 | (define shared-prefix-length* (make-fxvector count)) 30 | 31 | (define ch.zero (char->integer #\0)) 32 | 33 | (define (generate-input) 34 | (time (let loop ((i 0) (pos 0) (previous (make-bytes len 0))) 35 | (when (unsafe-fx< i count) 36 | (let ((next (make-bytes len ch.zero))) 37 | (unsafe-bytes-copy! next 0 prefix) 38 | (let loop ((i i) (j (unsafe-fx- len 1))) 39 | (let-values (((q r) (quotient/remainder i 10))) 40 | (unsafe-bytes-set! next j (unsafe-fx+ ch.zero r)) 41 | (when (unsafe-fx< 0 q) (loop q (unsafe-fx- j 1))))) 42 | (let ((shared-prefix-length 43 | (let loop ((i 0)) 44 | (cond ((unsafe-fx= len i) len) 45 | ((eq? (unsafe-bytes-ref previous i) 46 | (unsafe-bytes-ref next i)) 47 | (loop (unsafe-fx+ i 1))) 48 | (else i))))) 49 | (unsafe-fxvector-set! shared-prefix-length* i shared-prefix-length) 50 | (unsafe-bytes-copy! input pos next shared-prefix-length len) 51 | (loop (unsafe-fx+ i 1) 52 | (unsafe-fx+ pos (unsafe-fx- len shared-prefix-length)) 53 | next))))))) 54 | 55 | (define (decode-input) 56 | (time (let loop ((i 0) (start.in 0) (start.out 0) (prev.out 0)) 57 | (when (unsafe-fx< i count) 58 | (let* ((shared-prefix-length (unsafe-fxvector-ref shared-prefix-length* i)) 59 | (end.in (unsafe-fx+ start.in (unsafe-fx- len shared-prefix-length)))) 60 | (unsafe-bytes-copy! output start.out output prev.out 61 | (unsafe-fx+ prev.out shared-prefix-length)) 62 | (unsafe-bytes-copy! output (unsafe-fx+ start.out shared-prefix-length) input start.in 63 | end.in) 64 | (loop (unsafe-fx+ i 1) end.in (unsafe-fx+ start.out len) start.out)))))) 65 | 66 | (define (pretend-decode-input) 67 | (time (let loop ((i 0) (start.in 0) (start.out 0) (prev.out 0)) 68 | (when (unsafe-fx< i count) 69 | (let* ((shared-prefix-length (unsafe-fxvector-ref shared-prefix-length* i)) 70 | (end.in (unsafe-fx+ start.in (unsafe-fx- len shared-prefix-length)))) 71 | ;(unsafe-bytes-copy! output start.out output prev.out 72 | ;(unsafe-fx+ prev.out shared-prefix-length)) 73 | ;(unsafe-bytes-copy! output (unsafe-fx+ start.out shared-prefix-length) input start.in 74 | ;end.in) 75 | (loop (unsafe-fx+ i 1) end.in (unsafe-fx+ start.out len) start.out)))))) 76 | 77 | (define enumerated (make-vector count)) 78 | (define fxenumerated (make-fxvector count)) 79 | (define one (box 0)) 80 | 81 | (define (enumerate-output) 82 | (time (let loop ((i 0) (start.out 0) (acc 0)) 83 | (if (unsafe-fx< i count) 84 | (let ((v (make-bytes len)) 85 | (end.out (unsafe-fx+ start.out len))) 86 | (unsafe-bytes-copy! v 0 output start.out end.out) 87 | 88 | ;; cpu time: 146 real time: 149 gc time: 1 89 | ;(set-box! one v) 90 | 91 | ;; cpu time: 921 real time: 929 gc time: 759 92 | ;; or interrupts disabled: 93 | ;; cpu time: 283 real time: 286 gc time: 0 94 | ;; #"SHARE:9999999" 95 | ;; cpu time: 370 real time: 377 gc time: 370 96 | ;(unsafe-vector*-set! enumerated i v) 97 | 98 | ;; cpu time: 126 real time: 129 gc time: 1 99 | ;; or interrupts disabled: 100 | ;; cpu time: 248 real time: 254 gc time: 0 101 | ;; #"SHARE:9999999" 102 | ;; cpu time: 2 real time: 2 gc time: 1 103 | (unsafe-fxvector-set! fxenumerated i 104 | (unsafe-fx+ (unsafe-bytes-ref v 0) 105 | (unsafe-bytes-ref v (unsafe-fx- len 1)))) 106 | 107 | (loop (unsafe-fx+ i 1) end.out v)) 108 | acc)))) 109 | 110 | ;; cpu time: 4157 real time: 4168 gc time: 426 111 | (generate-input) 112 | 113 | ;; cpu time: 23 real time: 23 gc time: 0 114 | (time (unsafe-bytes-copy! output 0 input)) 115 | ;; cpu time: 281 real time: 288 gc time: 0 116 | (time (let loop ((i 0)) 117 | (when (unsafe-fx< i size) 118 | (unsafe-bytes-set! output i (unsafe-bytes-ref input i)) 119 | (loop (unsafe-fx+ i 1))))) 120 | ;; cpu time: 278 real time: 280 gc time: 0 121 | (time (let loop ((i 0)) 122 | (when (unsafe-fx< i size) 123 | (bytevector-u32-native-set! output i (bytevector-u32-native-ref input i)) 124 | (loop (unsafe-fx+ i 4))))) 125 | ;; cpu time: 180 real time: 182 gc time: 0 126 | (time (let loop ((i 0)) 127 | (when (unsafe-fx< i size) 128 | (bytevector-u64-native-set! output i (bytevector-u64-native-ref input i)) 129 | (loop (unsafe-fx+ i 8))))) 130 | 131 | ;; cpu time: 20 real time: 20 gc time: 0 132 | (pretend-decode-input) 133 | 134 | ;; cpu time: 237 real time: 242 gc time: 0 135 | (decode-input) 136 | 137 | (pretty-write (subbytes input 0 100)) 138 | (pretty-write (subbytes input 10000 10100)) 139 | (pretty-write (subbytes output 0 100)) 140 | (pretty-write (subbytes output (unsafe-fx- size 100) size)) 141 | 142 | ;(disable-interrupts) 143 | (enumerate-output) 144 | ;(time (enable-interrupts)) 145 | -------------------------------------------------------------------------------- /test/benchmark-compression/text-fsst-compression.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/pretty) 3 | (require 4 | "../../dbk/safe-unsafe.rkt" 5 | ;racket/unsafe/ops 6 | ) 7 | 8 | (define ch.zero (char->integer #\0)) 9 | 10 | (define prefix #"SHARE:") 11 | (define digit-count 7) 12 | (define len.prefix (bytes-length prefix)) 13 | (define len (+ len.prefix digit-count)) 14 | 15 | (define count 10000000) 16 | (define size (* len count)) 17 | (define input (make-bytes size)) 18 | (define encoded (make-bytes (* 2 size))) 19 | 20 | ;(define output (make-vector count)) 21 | 22 | (define (generate-input) 23 | (time (let loop ((i 0) (pos 0)) 24 | (when (unsafe-fx< i count) 25 | (let ((next (make-bytes len ch.zero))) 26 | (unsafe-bytes-copy! next 0 prefix) 27 | (let loop ((i i) (j (unsafe-fx- len 1))) 28 | (let-values (((q r) (quotient/remainder i 10))) 29 | (unsafe-bytes-set! next j (unsafe-fx+ ch.zero r)) 30 | (when (unsafe-fx< 0 q) (loop q (unsafe-fx- j 1))))) 31 | (unsafe-bytes-copy! input pos next 0 len) 32 | (loop (unsafe-fx+ i 1) (unsafe-fx+ pos len))))))) 33 | 34 | ;; TODO: treat input as a collection of text values rather than a single one 35 | 36 | counts of 37 | symbols (up to 256 of these) 38 | individual bytes (up to 256 of these) 39 | symbols extended with next byte (there can be up to 256 times 256 of these) 40 | pairs of symbols (there can be up to 256 times 256 of these) 41 | 42 | ;; use a heap as a finite priority queue 43 | 44 | 45 | ;(define (build-symbol-table st t*) 46 | ;) 47 | 48 | (define (encode 49 | ) 50 | ) 51 | 52 | 53 | ;(define (decode-input-baseline) 54 | ;(time (let loop ((i 0) (pos 0)) 55 | ;(when (unsafe-fx< i count) 56 | ;(let ((pos.next (unsafe-fx+ pos len))) 57 | ;(unsafe-bytes-copy! output.baseline pos input pos pos.next) 58 | ;(loop (unsafe-fx+ i 1) pos.next)))))) 59 | 60 | ;(define (decode-input) 61 | ;(time (let loop ((i 0) (pos 0)) 62 | ;(when (unsafe-fx< i count) 63 | ;(let ((t (make-bytes len)) 64 | ;(pos.next (unsafe-fx+ pos len))) 65 | ;(unsafe-bytes-copy! t 0 input pos pos.next) 66 | ;(unsafe-vector*-set! output i t) 67 | ;(loop (unsafe-fx+ i 1) pos.next)))))) 68 | 69 | ;; cpu time: 4037 real time: 4053 gc time: 499 70 | (generate-input) 71 | 72 | ;; cpu time: 108 real time: 112 gc time: 0 73 | (decode-input-baseline) 74 | 75 | ;; cpu time: 850 real time: 857 gc time: 690 76 | ;; or interrupts disabled: 77 | ;; cpu time: 330 real time: 333 gc time: 0 78 | ;; cpu time: 371 real time: 374 gc time: 371 79 | ;(disable-interrupts) 80 | (decode-input) 81 | ;(time (enable-interrupts)) 82 | 83 | (pretty-write (subbytes input 0 100)) 84 | (pretty-write (subbytes input 10000 10100)) 85 | (pretty-write (subbytes output.baseline 0 100)) 86 | (pretty-write (subbytes output.baseline (unsafe-fx- size 100) size)) 87 | (pretty-write (map (lambda (i) (vector-ref output i)) (range 10))) 88 | (pretty-write (map (lambda (i) (vector-ref output (- (vector-length output) (+ 1 i)))) (reverse (range 10)))) 89 | -------------------------------------------------------------------------------- /test/benchmark-compression/text-no-compression-decode.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require ffi/unsafe/vm racket/list racket/pretty) 3 | (require 4 | ;"../../dbk/safe-unsafe.rkt" 5 | racket/unsafe/ops 6 | ) 7 | 8 | (define enable-interrupts (vm-primitive 'enable-interrupts)) 9 | (define disable-interrupts (vm-primitive 'disable-interrupts)) 10 | 11 | (define prefix #"SHARE:") 12 | (define digit-count 7) 13 | (define len.prefix (bytes-length prefix)) 14 | (define len (+ len.prefix digit-count)) 15 | 16 | (define count 10000000) 17 | (define size (* len count)) 18 | (define input (make-bytes size)) 19 | (define output.baseline (make-bytes size)) 20 | (define output (make-vector count)) 21 | 22 | (define ch.zero (char->integer #\0)) 23 | 24 | (define (generate-input) 25 | (time (let loop ((i 0) (pos 0)) 26 | (when (unsafe-fx< i count) 27 | (let ((next (make-bytes len ch.zero))) 28 | (unsafe-bytes-copy! next 0 prefix) 29 | (let loop ((i i) (j (unsafe-fx- len 1))) 30 | (let-values (((q r) (quotient/remainder i 10))) 31 | (unsafe-bytes-set! next j (unsafe-fx+ ch.zero r)) 32 | (when (unsafe-fx< 0 q) (loop q (unsafe-fx- j 1))))) 33 | (unsafe-bytes-copy! input pos next 0 len) 34 | (loop (unsafe-fx+ i 1) (unsafe-fx+ pos len))))))) 35 | 36 | (define (decode-input-baseline) 37 | (time (let loop ((i 0) (pos 0)) 38 | (when (unsafe-fx< i count) 39 | (let ((pos.next (unsafe-fx+ pos len))) 40 | (unsafe-bytes-copy! output.baseline pos input pos pos.next) 41 | (loop (unsafe-fx+ i 1) pos.next)))))) 42 | 43 | (define (decode-input) 44 | (time (let loop ((i 0) (pos 0)) 45 | (when (unsafe-fx< i count) 46 | (let ((t (make-bytes len)) 47 | (pos.next (unsafe-fx+ pos len))) 48 | (unsafe-bytes-copy! t 0 input pos pos.next) 49 | (unsafe-vector*-set! output i t) 50 | (loop (unsafe-fx+ i 1) pos.next)))))) 51 | 52 | ;; cpu time: 4037 real time: 4053 gc time: 499 53 | (generate-input) 54 | 55 | ;; cpu time: 108 real time: 112 gc time: 0 56 | (decode-input-baseline) 57 | 58 | ;; cpu time: 850 real time: 857 gc time: 690 59 | ;; or interrupts disabled: 60 | ;; cpu time: 330 real time: 333 gc time: 0 61 | ;; cpu time: 371 real time: 374 gc time: 371 62 | ;(disable-interrupts) 63 | (decode-input) 64 | ;(time (enable-interrupts)) 65 | 66 | (pretty-write (subbytes input 0 100)) 67 | (pretty-write (subbytes input 10000 10100)) 68 | (pretty-write (subbytes output.baseline 0 100)) 69 | (pretty-write (subbytes output.baseline (unsafe-fx- size 100) size)) 70 | (pretty-write (map (lambda (i) (vector-ref output i)) (range 10))) 71 | (pretty-write (map (lambda (i) (vector-ref output (- (vector-length output) (+ 1 i)))) (reverse (range 10)))) 72 | -------------------------------------------------------------------------------- /test/benchmark-file-io/count-lines.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #define BUFFER_SIZE (16 * 1024) 6 | //#define BUFFER_SIZE 16777216 7 | //char buffer[BUFFER_SIZE]; 8 | 9 | long count_lines(int fd) { 10 | ssize_t read_size; 11 | long count; 12 | char buffer[BUFFER_SIZE]; 13 | //unsigned char buffer[BUFFER_SIZE]; 14 | 15 | count = 0; 16 | while ((read_size = read(fd, buffer, BUFFER_SIZE)) > 0) { 17 | //if ((read_size = read(fd, buffer, BUFFER_SIZE)) > 0) { 18 | for (int i = 0; i < read_size; ++i) { 19 | 20 | count += (((unsigned char)(buffer[i])) - 10); 21 | 22 | //count += (buffer[i] - 10); 23 | 24 | /*if (buffer[i] == '\n') {*/ 25 | /*count += 1;*/ 26 | /*}*/ 27 | 28 | } 29 | } 30 | if (read_size == -1) { 31 | return -1; 32 | } 33 | return count; 34 | } 35 | 36 | int main() { 37 | int fd = open("rtx-kg2-s3/rtx-kg2_nodes_2.8.1.tsv", O_RDONLY); 38 | //int fd = open("rtx-kg2-s3/rtx-kg2_edges_2.8.1.tsv", O_RDONLY); 39 | printf("%ld\n", count_lines(fd)); 40 | close(fd); 41 | } 42 | -------------------------------------------------------------------------------- /test/benchmark-file-io/count-lines.scm: -------------------------------------------------------------------------------- 1 | ;; 37GB 2 | ;(define in (open-file-input-port "rtx-kg2-s3/rtx-kg2_edges_2.8.1.tsv" (file-options) 'none)) 3 | ;; 4.8GB 4 | (define in (open-file-input-port "rtx-kg2-s3/rtx-kg2_nodes_2.8.1.tsv" (file-options) 'none)) 5 | 6 | ;(#%$assembly-output #t) 7 | (optimize-level 3) 8 | 9 | (let () 10 | ;(define buffer-size 65536) 11 | ;(define buffer-size 32768) 12 | (define buffer-size 16384) 13 | ;(define buffer-size 8192) 14 | ;(define buffer-size 4096) 15 | (write 16 | (time (let ((buffer (make-bytevector buffer-size))) 17 | (let loop.outer ((count 0)) 18 | (let ((size (get-bytevector-some! in buffer 0 buffer-size))) 19 | (if (eof-object? size) 20 | count 21 | (let loop.inner ((i 0) (count count)) 22 | (if (fx= i size) 23 | (loop.outer count) 24 | (let ((b (bytevector-u8-ref buffer i))) 25 | (loop.inner (fx+ i 1) (fx+ count (fx- b 10))))) 26 | )))))))) 27 | 28 | ;(let () 29 | ; ;(define buffer-size 65536) 30 | ; ;(define buffer-size 32768) 31 | ; (define buffer-size 16384) 32 | ; ;(define buffer-size 8192) 33 | ; ;(define buffer-size 4096) 34 | ; (write 35 | ; (time (let ((buffer (make-bytevector buffer-size))) 36 | ; (let loop.outer ((count 0)) 37 | ; (let ((size (get-bytevector-some! in buffer 0 buffer-size))) 38 | ; (if (eof-object? size) 39 | ; count 40 | ; (let loop.inner ((i 0) (count count)) 41 | ; (if (fx= i size) 42 | ; (loop.outer count) 43 | ; (let ((b (bytevector-u8-ref buffer i))) 44 | ; (loop.inner (fx+ i 1) (if (fx= b 10) (fx+ count 1) count)))) 45 | ; )))))))) 46 | 47 | ;(let () 48 | ; ;(define buffer-size 65536) 49 | ; ;(define buffer-size 32768) 50 | ; (define buffer-size 16384) 51 | ; ;(define buffer-size 8192) 52 | ; ;(define buffer-size 4096) 53 | ; (write 54 | ; (time (let ((buffer (make-bytevector buffer-size))) 55 | ; (let loop.outer ((count.outer 0)) 56 | ; (let ((size (get-bytevector-some! in buffer 0 buffer-size))) 57 | ; (if (eof-object? size) 58 | ; count.outer 59 | ; (let loop.inner ((i 0) (count 0)) 60 | ; (if (fx= i size) 61 | ; (loop.outer (fx+ count count.outer)) 62 | ; (let ((b (bytevector-u8-ref buffer i))) 63 | ; (loop.inner (fx+ i 1) (if (fx= b 10) (fx+ count 1) count)))) 64 | ; )))))))) 65 | -------------------------------------------------------------------------------- /test/benchmark-file-io/notes/scratch.scm: -------------------------------------------------------------------------------- 1 | (define out (open-output-file "test.txt")) 2 | (define in (open-input-file "test.txt")) 3 | (define in2 (open-input-file "test.txt")) 4 | 5 | (file-position out 500) 6 | (file-position out) 7 | (write-byte 111 out) 8 | (flush-output out) 9 | 10 | ll test.txt 11 | -rw-r--r-- 1 greg staff 501B Mar 14 14:02 test.txt 12 | -rw-r--r-- 1 greg staff 10B Mar 12 14:22 test.txt 13 | -rw-r--r-- 1 greg staff 10B Mar 12 14:22 test.txt 14 | 15 | (file-stream-buffer-mode in2) 16 | (file-stream-buffer-mode out 'none) 17 | (file-stream-buffer-mode in 'none) 18 | (file-stream-buffer-mode in2 'none) 19 | 20 | (file-position out 0) 21 | (write-bytes (bytes 11 12 13 14 15 16 17 18 19 20) out) 22 | (flush-output out) 23 | 24 | (file-position out 0) 25 | (write-bytes (bytes 21 22 23 24 25 26 27 28 29 30) out) 26 | (flush-output out) 27 | 28 | 29 | (file-position in (file-position in)) 30 | (read-byte in) 31 | 32 | (file-position in2 (file-position in2)) 33 | (read-byte in2) 34 | 35 | 36 | hexdump -C test.txt 37 | hexdump -x test.txt 38 | hexdump -d test.txt 39 | 40 | decdump test.txt 41 | decdump -v test.txt 42 | 000000000000 021 022 023 024 025 026 027 028 029 030 000 000 000 000 000 000 |................| 43 | 000000000016 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 44 | 000000000032 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 45 | 000000000048 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 46 | 000000000064 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 47 | 000000000080 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 48 | 000000000096 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 49 | 000000000112 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 50 | 000000000128 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 51 | 000000000144 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 52 | 000000000160 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 53 | 000000000176 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 54 | 000000000192 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 55 | 000000000208 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 56 | 000000000224 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 57 | 000000000240 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 58 | 000000000256 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 59 | 000000000272 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 60 | 000000000288 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 61 | 000000000304 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 62 | 000000000320 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 63 | 000000000336 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 64 | 000000000352 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 65 | 000000000368 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 66 | 000000000384 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 67 | 000000000400 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 68 | 000000000416 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 69 | 000000000432 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 70 | 000000000448 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 71 | 000000000464 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 72 | 000000000480 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 73 | 000000000496 000 000 000 000 111 |....o| 74 | 75 | 000000000000 021 022 023 024 025 026 027 028 029 030 000 000 000 000 000 000 |................| 76 | 000000000016 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 |................| 77 | * 78 | 000000000496 000 000 000 000 111 |....o| 79 | 80 | 000000000000 021 022 023 024 025 026 027 028 029 030 |..........| 81 | 82 | hexdump -e '/1 "%3d "' test.txt 83 | 21 22 23 24 25 26 27 28 29 30 84 | 85 | hexdump -e '/1 "%03d "' test.txt 86 | 021 022 023 024 025 026 027 028 029 030 87 | 88 | hexdump -e '/1 "%02d "' test.txt 89 | 21 22 23 24 25 26 27 28 29 30 90 | 91 | 0000000 15 16 17 18 19 1a 1b 1c 1d 1e 92 | 000000a 93 | 94 | 00000000 15 16 17 18 19 1a 1b 1c 1d 1e |..........| 95 | 0000000a 96 | 97 | 0000000 1615 1817 1a19 1c1b 1e1d 98 | 000000a 99 | 100 | 00000000 15 16 17 18 19 1a 1b 1c 1d 1e |..........| 101 | 0000000a 102 | 103 | 0000000 05653 06167 06681 07195 07709 104 | 000000a 105 | 106 | 0000000 03083 03597 04111 04625 05139 05653 06167 06681 107 | 0000010 07195 07709 108 | 0000014 109 | 110 | 111 | 00000000 0b 0c 0d 0e 0f 10 11 12 13 14 15 16 17 18 19 1a |................| 112 | 00000010 1b 1c 1d 1e |....| 113 | 00000014 114 | 115 | (bytes->list (file->bytes "test.txt")) 116 | -------------------------------------------------------------------------------- /test/benchmark-file-io/notes/transcript-uncached-read.scm: -------------------------------------------------------------------------------- 1 | 14:20:16 (master) greg@greg-mac.local:~/private/repositories/projects/dbKanren/test/medikanren-tests/semmed.db 2 | > ll 3 | total 0 4 | drwxr-xr-x 46 greg staff 1.5K Nov 7 2022 block/ 5 | drwxr-xr-x 3 greg staff 102B Nov 7 2022 metadata/ 6 | drwxr-xr-x 2 greg staff 68B Nov 7 2022 trash/ 7 | 14:20:16 (master) greg@greg-mac.local:~/private/repositories/projects/dbKanren/test/medikanren-tests/semmed.db 8 | > cd trash/^C 9 | 14:20:20 (master) greg@greg-mac.local:~/private/repositories/projects/dbKanren/test/medikanren-tests/semmed.db 10 | > t 11 | . 12 | ├── [1.5K Nov 7 2022] block/ 13 | │   ├── [316M Nov 7 2022] 41 14 | │   ├── [ 33M Nov 7 2022] 42 15 | │   ├── [321M Nov 7 2022] 50 16 | │   ├── [ 24 Nov 7 2022] 51 17 | │   ├── [107M Nov 7 2022] 52 18 | │   ├── [321M Nov 7 2022] 53 19 | │   ├── [2.8M Nov 7 2022] 54 20 | │   ├── [ 12 Nov 7 2022] 55 21 | │   ├── [971K Nov 7 2022] 56 22 | │   ├── [2.8M Nov 7 2022] 57 23 | │   ├── [ 40M Nov 7 2022] 58 24 | │   ├── [ 40M Nov 7 2022] 59 25 | │   ├── [ 24 Nov 7 2022] 60 26 | │   ├── [107M Nov 7 2022] 61 27 | │   ├── [321M Nov 7 2022] 62 28 | │   ├── [ 24 Nov 7 2022] 63 29 | │   ├── [ 23M Nov 7 2022] 64 30 | │   ├── [ 27 Nov 7 2022] 65 31 | │   ├── [321M Nov 7 2022] 66 32 | │   ├── [ 31M Nov 7 2022] 67 33 | │   ├── [432K Nov 7 2022] 68 34 | │   ├── [ 30M Nov 7 2022] 69 35 | │   ├── [432K Nov 7 2022] 70 36 | │   ├── [ 40M Nov 7 2022] 71 37 | │   ├── [ 30M Nov 7 2022] 72 38 | │   ├── [390K Nov 7 2022] 73 39 | │   ├── [ 30M Nov 7 2022] 74 40 | │   ├── [390K Nov 7 2022] 75 41 | │   ├── [ 40M Nov 7 2022] 76 42 | │   ├── [ 30M Nov 7 2022] 77 43 | │   ├── [ 40M Nov 7 2022] 78 44 | │   ├── [432K Nov 7 2022] 79 45 | │   ├── [ 40M Nov 7 2022] 80 46 | │   ├── [ 40M Nov 7 2022] 81 47 | │   ├── [390K Nov 7 2022] 82 48 | │   ├── [ 40M Nov 7 2022] 83 49 | │   ├── [ 12 Nov 7 2022] 84 50 | │   ├── [971K Nov 7 2022] 85 51 | │   ├── [2.8M Nov 7 2022] 86 52 | │   ├── [ 12 Nov 7 2022] 87 53 | │   ├── [1.4M Nov 7 2022] 88 54 | │   ├── [ 21 Nov 7 2022] 89 55 | │   ├── [2.8M Nov 7 2022] 90 56 | │   └── [1.4M Nov 7 2022] 91 57 | ├── [ 102 Nov 7 2022] metadata/ 58 | │   └── [ 32K Nov 7 2022] current.scm 59 | └── [ 68 Nov 7 2022] trash/ 60 | 61 | 3 directories, 45 files 62 | 14:20:21 (master) greg@greg-mac.local:~/private/repositories/projects/dbKanren/test/medikanren-tests/semmed.db 63 | > cd block/ 64 | 14:20:26 (master) greg@greg-mac.local:~/private/repositories/projects/dbKanren/test/medikanren-tests/semmed.db/block 65 | > racket 66 | Welcome to Racket v8.4 [cs]. 67 | > (define (time-read fname size) 68 | (call-with-input-file fname 69 | (lambda (in) 70 | (file-stream-buffer-mode in 'none) 71 | (let ((bv.target (make-bytes size))) 72 | (time (read-bytes! bv.target in 0 size)))))) 73 | > (define 1kb 1024) 74 | > (define 1mb (* 1kb 1024)) 75 | > (define 64kb (* 1kb 64)) 76 | > (define 4kb (* 1kb 4)) 77 | > (define 16kb (* 1kb 16)) 78 | > (define 16mb (* 1mb 16)) 79 | > (define 4mb (* 1mb 4)) 80 | > (time-read "41" 4mb) 81 | cpu time: 2 real time: 4 gc time: 0 82 | 4194304 83 | > (time-read "42" 1mb) 84 | cpu time: 0 real time: 2 gc time: 0 85 | 1048576 86 | > (time-read "80" 1mb) 87 | cpu time: 0 real time: 2 gc time: 0 88 | 1048576 89 | > (define 2mb (* 1mb 2)) 90 | > (time-read "91" 2mb) 91 | cpu time: 0 real time: 2 gc time: 0 92 | 1475616 93 | > (time-read "50" 64kb) 94 | cpu time: 0 real time: 1 gc time: 0 95 | 65536 96 | > (time-read "51" 16kb) 97 | cpu time: 0 real time: 0 gc time: 0 98 | 24 99 | > (time-read "90" 2mb) 100 | cpu time: 1 real time: 3 gc time: 0 101 | 2097152 102 | > (time-read "52" 16kb) 103 | cpu time: 0 real time: 1 gc time: 0 104 | 16384 105 | > 106 | 14:31:06 (master) greg@greg-mac.local:~/private/repositories/projects/dbKanren/test/medikanren-tests/semmed.db/block 107 | > scheme 108 | Chez Scheme Version 9.4.1 109 | Copyright 1984-2016 Cisco Systems, Inc. 110 | 111 | > (define 1kb 1024) 112 | > (define 4kb (* 1kb 4)) 113 | > (define 16kb (* 1kb 16)) 114 | > (define 64kb (* 1kb 64)) 115 | > (define 1mb (* 1kb 1024)) 116 | > (define 2mb (* 1mb 2)) 117 | > (define 4mb (* 1mb 4)) 118 | > (define 16mb (* 1mb 16)) 119 | > (define (time-read fname size) 120 | (call-with-input-file fname 121 | (lambda (in) 122 | (let ((bv.target (make-bytevector size))) 123 | (time (get-bytevector-some! in bv.target 0 size)))) 124 | 'unbuffered)) 125 | > (time-read "51" 16kb) 126 | Exception in get-bytevector-some!: # is not a binary input port 127 | Type (debug) to enter the debugger. 128 | > (define (time-read fname size) 129 | (let ((in (open-file-input-port name (file-options) 'none)) 130 | (bv.target (make-bytevector size))) 131 | (let ((result (time (get-bytevector-some! in bv.target 0 size)))) 132 | (close-port in) 133 | result))) 134 | > (time-read "51" 16kb) 135 | Exception: variable name is not bound 136 | Type (debug) to enter the debugger. 137 | > (define (time-read fname size) 138 | (let ((in (open-file-input-port fname (file-options) 'none)) 139 | (bv.target (make-bytevector size))) 140 | (let ((result (time (get-bytevector-some! in bv.target 0 size)))) 141 | (close-port in) 142 | result))) 143 | > (time-read "51" 16kb) 144 | (time (get-bytevector-some! in ...)) 145 | no collections 146 | 0.000010000s elapsed cpu time 147 | 0.000010000s elapsed real time 148 | 112 bytes allocated 149 | 24 150 | > (time-read "41" 16kb) 151 | (time (get-bytevector-some! in ...)) 152 | no collections 153 | 0.000044000s elapsed cpu time 154 | 0.000041000s elapsed real time 155 | 112 bytes allocated 156 | 16384 157 | > (time-read "42" 16kb) 158 | (time (get-bytevector-some! in ...)) 159 | no collections 160 | 0.000042000s elapsed cpu time 161 | 0.000042000s elapsed real time 162 | 112 bytes allocated 163 | 16384 164 | > (time-read "42" 1mb) 165 | (time (get-bytevector-some! in ...)) 166 | no collections 167 | 0.001215000s elapsed cpu time 168 | 0.001274000s elapsed real time 169 | 112 bytes allocated 170 | 1048576 171 | > (time-read "42" 4kb) 172 | (time (get-bytevector-some! in ...)) 173 | no collections 174 | 0.000017000s elapsed cpu time 175 | 0.000013000s elapsed real time 176 | 112 bytes allocated 177 | 4096 178 | > (time-read "60" 4kb) 179 | (time (get-bytevector-some! in ...)) 180 | no collections 181 | 0.000111000s elapsed cpu time 182 | 0.000919000s elapsed real time 183 | 112 bytes allocated 184 | 24 185 | > (time-read "61" 16kb) 186 | (time (get-bytevector-some! in ...)) 187 | no collections 188 | 0.000157000s elapsed cpu time 189 | 0.001002000s elapsed real time 190 | 112 bytes allocated 191 | 16384 192 | > (time-read "62" 64kb) 193 | (time (get-bytevector-some! in ...)) 194 | no collections 195 | 0.000193000s elapsed cpu time 196 | 0.001161000s elapsed real time 197 | 112 bytes allocated 198 | 65536 199 | > (define 256kb (* 1kb 256)) 200 | > (time-read "63" 256kb) 201 | (time (get-bytevector-some! in ...)) 202 | no collections 203 | 0.000113000s elapsed cpu time 204 | 0.001004000s elapsed real time 205 | 112 bytes allocated 206 | 24 207 | > (time-read "64" 256kb) 208 | (time (get-bytevector-some! in ...)) 209 | no collections 210 | 0.000333000s elapsed cpu time 211 | 0.001556000s elapsed real time 212 | 112 bytes allocated 213 | 262144 214 | > (time-read "65" 4kb) 215 | (time (get-bytevector-some! in ...)) 216 | no collections 217 | 0.000120000s elapsed cpu time 218 | 0.000976000s elapsed real time 219 | 112 bytes allocated 220 | 27 221 | > (time-read "65" 1mb) 222 | (time (get-bytevector-some! in ...)) 223 | no collections 224 | 0.000011000s elapsed cpu time 225 | 0.000009000s elapsed real time 226 | 112 bytes allocated 227 | 27 228 | > (time-read "66" 1mb) 229 | (time (get-bytevector-some! in ...)) 230 | no collections 231 | 0.001409000s elapsed cpu time 232 | 0.003386000s elapsed real time 233 | 112 bytes allocated 234 | 1048576 235 | > (define 512kb (* 1kb 512)) 236 | > (time-read "66" 512kb) 237 | (time (get-bytevector-some! in ...)) 238 | no collections 239 | 0.000153000s elapsed cpu time 240 | 0.000154000s elapsed real time 241 | 112 bytes allocated 242 | 524288 243 | > (time-read "67" 512kb) 244 | (time (get-bytevector-some! in ...)) 245 | no collections 246 | 0.000499000s elapsed cpu time 247 | 0.001823000s elapsed real time 248 | 112 bytes allocated 249 | 524288 250 | > (define 128kb (* 1kb 128)) 251 | > (time-read "68" 128kb) 252 | (time (get-bytevector-some! in ...)) 253 | no collections 254 | 0.000215000s elapsed cpu time 255 | 0.001263000s elapsed real time 256 | 112 bytes allocated 257 | 131072 258 | > (time-read "69" 4kb) 259 | (time (get-bytevector-some! in ...)) 260 | no collections 261 | 0.000114000s elapsed cpu time 262 | 0.000962000s elapsed real time 263 | 112 bytes allocated 264 | 4096 265 | > (time-read "70" 4mb) 266 | (time (get-bytevector-some! in ...)) 267 | no collections 268 | 0.000492000s elapsed cpu time 269 | 0.001836000s elapsed real time 270 | 112 bytes allocated 271 | 442773 272 | > (time-read "71" 4mb) 273 | (time (get-bytevector-some! in ...)) 274 | no collections 275 | 0.001858000s elapsed cpu time 276 | 0.005316000s elapsed real time 277 | 112 bytes allocated 278 | 4194304 279 | > (time-read "72" 2mb) 280 | (time (get-bytevector-some! in ...)) 281 | no collections 282 | 0.002822000s elapsed cpu time 283 | 0.003951000s elapsed real time 284 | 112 bytes allocated 285 | 2097152 286 | > (time-read "74" 4mb) 287 | (time (get-bytevector-some! in ...)) 288 | no collections 289 | 0.004336000s elapsed cpu time 290 | 0.006845000s elapsed real time 291 | 112 bytes allocated 292 | 4194304 293 | > (time-read "88" 1mb) 294 | (time (get-bytevector-some! in ...)) 295 | no collections 296 | 0.001257000s elapsed cpu time 297 | 0.002910000s elapsed real time 298 | 112 bytes allocated 299 | 1048576 300 | > 301 | -------------------------------------------------------------------------------- /test/benchmark-file-io/notes/transcript.rkt: -------------------------------------------------------------------------------- 1 | Welcome to Racket v8.4 [cs]. 2 | > (define out (open-output-file "test.txt")) 3 | > (define in (open-input-file "test.txt")) 4 | > (read-byte in) 5 | # 6 | > (read-byte in) 7 | # 8 | > (write-bytes (bytes 1 2 3 4 5) out) 9 | 5 10 | > (read-byte in) 11 | # 12 | > (read-byte in) 13 | # 14 | > (read-byte in) 15 | # 16 | > (read-byte in) 17 | # 18 | > (read-byte in) 19 | # 20 | > (flush-output out) 21 | > (read-byte in) 22 | 1 23 | > (read-byte in) 24 | 2 25 | > (file-position out 3) 26 | > (write-bytes (bytes 6 7 8 9 10) out) 27 | 5 28 | > (flush-output out) 29 | > (read-byte in) 30 | 3 31 | > (read-byte in) 32 | 4 33 | > (read-byte in) 34 | 5 35 | > (read-byte in) 36 | 8 37 | > (file-position out 0) 38 | > (write-bytes (bytes 1 2 3 4 5) out) 39 | 5 40 | > (flush-output out) 41 | > (file-position in 0) 42 | > (read-byte in) 43 | 1 44 | > (read-byte in) 45 | 2 46 | > (read-byte in) 47 | 3 48 | > (file-position out 0) 49 | > (write-bytes (bytes 6 7 8 9 10) out) 50 | 5 51 | > (flush-output out) 52 | > (file-position in 0) 53 | > (read-byte in) 54 | 6 55 | > (read-byte in) 56 | 7 57 | > (read-byte in) 58 | 8 59 | > (file-position out 0) 60 | > (write-bytes (bytes 1 2 3 4 5) out) 61 | 5 62 | > (flush-output out) 63 | > (file-position in) 64 | 3 65 | > (file-position in 3) 66 | > (read-byte in) 67 | 4 68 | > (file-position out 0) 69 | > (file-position in 0) 70 | > (write-bytes (bytes 11 12 13 14 15 16 17 18 19 20) out) 71 | 10 72 | > (flush-output out) 73 | > (file-position in) 74 | 0 75 | > (read-byte in) 76 | 11 77 | > (write-bytes (bytes 21 22 23 24 25 26 27 28 29 30) out) 78 | 10 79 | > (flush-output out) 80 | > (read-byte in) 81 | 12 82 | > (file-position in (file-position in)) 83 | > (read-byte in) 84 | 13 85 | > (read-byte in) 86 | 14 87 | > (file-position in) 88 | 4 89 | > (file-position in 4) 90 | > (read-byte in) 91 | 15 92 | > (file-position in) 93 | 5 94 | > (file-position in 4) 95 | > (file-position in 5) 96 | > (read-byte in) 97 | 16 98 | > (file-stream-buffer-mode in) 99 | block 100 | > (file-stream-buffer-mode in 'none) 101 | > (read-byte in) 102 | 17 103 | > (file-position in 4) 104 | > (file-position in 5) 105 | > (read-byte in) 106 | 16 107 | > (read-byte in) 108 | 17 109 | > (define in2 (open-input-file "test.txt")) 110 | > (file-position in) 111 | 7 112 | > (file-position in2 7) 113 | > (read-byte in2) 114 | 18 115 | > (read-byte in) 116 | 18 117 | > hexdump -d test.txt 118 | hexdump: undefined; 119 | cannot reference an identifier before its definition 120 | in module: top-level 121 | [,bt for context] 122 | -d: undefined; 123 | cannot reference an identifier before its definition 124 | in module: top-level 125 | [,bt for context] 126 | test.txt: undefined; 127 | cannot reference an identifier before its definition 128 | in module: top-level 129 | [,bt for context] 130 | > (file->bytes "test.txt") 131 | #"\v\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36" 132 | > (bytes->list (file->bytes "test.txt")) 133 | (11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30) 134 | > 135 | 136 | Welcome to Racket v8.4 [cs]. 137 | > (define out (open-output-file "test.txt")) 138 | > (define in (open-input-file "test.txt")) 139 | > (define in2 (open-input-file "test.txt")) 140 | > (read-byte in) 141 | # 142 | > (write-bytes (bytes 11 12 13 14 15 16 17 18 19 20) out) 143 | 10 144 | > (flush-output out) 145 | > (read-byte in) 146 | 11 147 | > (write-bytes (bytes 21 22 23 24 25 26 27 28 29 30) out) 148 | 10 149 | > (flush-output out) 150 | > (read-byte in2) 151 | 11 152 | > 153 | 154 | Welcome to Racket v8.4 [cs]. 155 | > (define out (open-output-file "test.txt")) 156 | > (define in (open-input-file "test.txt")) 157 | > (define in2 (open-input-file "test.txt")) 158 | > (file-position out 0) 159 | > (write-bytes (bytes 11 12 13 14 15 16 17 18 19 20) out) 160 | 10 161 | > (flush-output out) 162 | > (read-byte in) 163 | 11 164 | > (file-position out 0) 165 | > (write-bytes (bytes 21 22 23 24 25 26 27 28 29 30) out) 166 | 10 167 | > (flush-output out) 168 | > (read-byte in2) 169 | 21 170 | > (read-byte in) 171 | 12 172 | > (read-byte in2) 173 | 22 174 | > (read-byte in) 175 | 13 176 | > (read-byte in) 177 | 14 178 | > (file-position in (file-position in)) 179 | > (read-byte in) 180 | 25 181 | > (read-byte in2) 182 | 23 183 | > (read-byte in2) 184 | 24 185 | > (read-byte in2) 186 | 25 187 | > (file-position out 500) 188 | > (flush-output out) 189 | > (file-position out) 190 | 500 191 | > (write-byte 111 out) 192 | > (flush-output out) 193 | > 194 | -------------------------------------------------------------------------------- /test/benchmark-old/run-benchmark.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../dbk.rkt" racket/function racket/list racket/pretty) 3 | (print-as-expression #f) 4 | (pretty-print-abbreviate-read-macros #f) 5 | 6 | (define-syntax-rule (test name e expected) 7 | (begin (printf "Testing ~s:\n" name) 8 | (pretty-print 'e) 9 | (let ((answer (time e))) 10 | (unless (equal? answer expected) 11 | (printf "FAILED ~s:\n" name) 12 | (printf " ANSWER:\n") 13 | (pretty-print answer) 14 | (printf " EXPECTED:\n") 15 | (pretty-print expected))))) 16 | 17 | (for-each (lambda (key) (current-config-set! key 'always)) 18 | '(update-policy cleanup-policy migrate-policy)) 19 | 20 | 21 | ;; Benchmark reference: http://users.informatik.uni-halle.de/~brass/botup/ 22 | 23 | (define-relation/table Q 24 | 'path "data/Q" 25 | 'source-stream (value/syntax 26 | (map (lambda (i) (list i (+ i 1))) (range 1 5001))) 27 | 'attribute-names '(a b) 28 | 'attribute-types '(nat nat) 29 | ;; optionally preload into memory 30 | 'retrieval-type 'scm 31 | ) 32 | 33 | (define-relation/table R 34 | 'path "data/R" 35 | 'source-stream (value/syntax 36 | (map (lambda (i) (list i i)) (range 1 5001))) 37 | 'attribute-names '(a b) 38 | 'attribute-types '(nat nat) 39 | ;; optionally preload into memory 40 | 'retrieval-type 'scm 41 | ) 42 | 43 | (define-relation (P3.1 b y) (fresh (x) (P2.1 b x) (Q x y))) 44 | (define-relation (P2.1 c w) (fresh (v) (P1.1 c v) (Q v w))) 45 | (define-relation (P1.1 d u) (fresh (t) (P0.1 d t) (Q t u))) 46 | (define-relation (P0.1 e s) (R e s)) 47 | 48 | ;; disk: ~8000ms 49 | ;; scm: ~1400ms 50 | (test 'benchmark-1 51 | (length (run* (a z) (P3.1 a z))) 52 | ;; smallest: (1 4) 53 | ;; largest: (4998 5001) 54 | 4998) 55 | 56 | (define-relation (P3.2 x z) (fresh (y) (Q x y) (P2.2 y z))) 57 | (define-relation (P2.2 x z) (fresh (y) (Q x y) (P1.2 y z))) 58 | (define-relation (P1.2 x z) (fresh (y) (Q x y) (P0.2 y z))) 59 | (define-relation (P0.2 x y) (R x y)) 60 | 61 | ;; disk: ~8000ms 62 | ;; scm: ~1400ms 63 | (test 'benchmark-2 64 | (length (run* (x z) (P3.2 x z))) 65 | ;; smallest: (1 4) 66 | ;; largest: (4997 5000) 67 | 4997) 68 | 69 | 70 | ;; TODO: improve performance 71 | 72 | ;(define-relation/table Q.large 73 | ; 'path "benchmark1/Q.large" 74 | ; 'source-stream (value/syntax 75 | ; (map (lambda (i) (list i (+ i 1))) (range 1 1000001))) 76 | ; 'attribute-names '(a b) 77 | ; 'attribute-types '(nat nat) 78 | ; ;; optionally preload into memory 79 | ; 'retrieval-type 'scm 80 | ; ) 81 | ; 82 | ;(define-relation/table R.large 83 | ; 'path "benchmark1/R.large" 84 | ; 'source-stream (value/syntax 85 | ; (map (lambda (i) (list i i)) (range 1 1000001))) 86 | ; 'attribute-names '(a b) 87 | ; 'attribute-types '(nat nat) 88 | ; ;; optionally preload into memory 89 | ; 'retrieval-type 'scm 90 | ; ) 91 | ; 92 | ;(define-relation (P3.2.large x z) (fresh (y) (Q.large x y) (P2.2.large y z))) 93 | ;(define-relation (P2.2.large x z) (fresh (y) (Q.large x y) (P1.2.large y z))) 94 | ;(define-relation (P1.2.large x z) (fresh (y) (Q.large x y) (P0.2.large y z))) 95 | ;(define-relation (P0.2.large x y) (R.large x y)) 96 | ; 97 | ;;; disk: ? 98 | ;;; scm: ? 99 | ;(test 'benchmark-2-large 100 | ; (length (run* (x z) (P3.2.large x z))) 101 | ; '?) 102 | 103 | 104 | ;; TODO: improve performance 105 | 106 | ;(define-relation/table S 107 | ; 'path "benchmark1/S" 108 | ; 'source-stream (value/syntax (map list (range 1 50001))) 109 | ; 'attribute-names '(a) 110 | ; 'attribute-types '(nat) 111 | ; ;; optionally preload into memory 112 | ; 'retrieval-type 'scm 113 | ; ) 114 | 115 | ;(define-relation (P1.3 a) (S a)) 116 | ;(define-relation (P2.3 a b) (P1.3 a) (membero b '(1 2))) 117 | ;(define-relation (P3.3 a b c) (P2.3 a b) (membero c '(1 2))) 118 | ;(define-relation (P4.3 a b c d) (P3.3 a b c) (membero d '(1 2))) 119 | ;(define-relation (P5.3 a b c d e) (P4.3 a b c d) (membero e '(1 2))) 120 | ;(define-relation (P6.3 a b c d e f) (P5.3 a b c d e) (membero f '(1 2))) 121 | ;(define-relation (P7.3 a b c d e f g) (P6.3 a b c d e f) (membero g '(1 2))) 122 | 123 | ;;; disk: ? 124 | ;;; scm: ? 125 | ;(test 'benchmark-3 126 | ; (length (run* (a b c d e f g) (P7.3 a b c d e f g))) 127 | ; (* 50000 (expt 2 6))) 128 | 129 | 130 | ;; TODO: fixed-point computations 131 | 132 | ;(define-relation/table edge 133 | ; 'path "benchmark1/edge" 134 | ; 'source-stream (value/syntax 135 | ; (map (lambda (i) (list i (+ i 1))) (range 1 1001))) 136 | ; 'attribute-names '(a b) 137 | ; 'attribute-types '(nat nat) 138 | ; ;; optionally preload into memory 139 | ; 'retrieval-type 'scm 140 | ; ) 141 | ; 142 | ;(define-relation (path x z) 143 | ; (conde ((edge x z)) 144 | ; ((fresh (y) (edge x y) (path y z))))) 145 | ; 146 | ;;; disk: ? 147 | ;;; scm: ? 148 | ;(test 'benchmark-fixed-point 149 | ; (length (run* (a b) (path a b))) 150 | ; (/ (* 1000 (+ 1000 1)) 2)) 151 | -------------------------------------------------------------------------------- /test/benchmark-sorting/string-sort.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list racket/pretty racket/unsafe/ops racket/vector) 3 | 4 | ;; TODO: pre-allocate a buffer for all the threshold merge sorts to share 5 | ;; TODO: try MSD-radix-sort with a threshold for switching to q3sort! ? 6 | ;; TODO: try burst/trie sort? 7 | 8 | ;; multi-key (aka 3-way) quicksort 9 | (define (q3sort! max-depth? x&depth->cmp cmp (unsafe-vector*-ref v (random start end)) 52 | depth) 53 | (lambda (i.low i.mid) 54 | (loop.current-depth start i.low) 55 | (loop.current-depth i.mid end) 56 | (loop.next-depth (unsafe-fx+ depth 1) i.low i.mid))))))))) 57 | 58 | (define (vector-bytes-sort! v (start 0) (end (vector-length v))) 59 | (define (ref x d) (unsafe-bytes-ref x d)) 60 | (q3sort! 61 | (lambda (x depth) (unsafe-fx<= (unsafe-bytes-length x) depth)) 62 | (lambda (x depth) (let ((n (bytes-ref x depth))) 63 | (lambda (y) 64 | (let ((m (bytes-ref y depth))) 65 | (cond ((unsafe-fx< m n) -1) 66 | ((unsafe-fx= m n) 0) 67 | (else 1)))))) 68 | bytesstring (map (lambda (_) (integer->char (random 128))) (range (random 200))))) 90 | 91 | (define (string-sort-and-verify v) 92 | (define v.expected (time (vector-sort v stringbytes (map (lambda (_) (random 128)) (range (random 300 500))))) 99 | 100 | (define (bytes-sort-and-verify v) 101 | ;(define v.expected (time (vector-sort v bytesvector (map (lambda (_) (random-string)) (range test-size))))) 115 | (bytes-sort-and-verify (time (list->vector (map (lambda (_) (random-bytes)) (range test-size))))) 116 | -------------------------------------------------------------------------------- /test/chinook/.gitignore: -------------------------------------------------------------------------------- 1 | /Chinook_Sqlite.sql 2 | /Album.tsv 3 | /Artist.tsv 4 | /Customer.tsv 5 | /Employee.tsv 6 | /Genre.tsv 7 | /Invoice.tsv 8 | /InvoiceLine.tsv 9 | /MediaType.tsv 10 | /Playlist.tsv 11 | /PlaylistTrack.tsv 12 | /Track.tsv 13 | -------------------------------------------------------------------------------- /test/chinook/README.md: -------------------------------------------------------------------------------- 1 | # Chinook database testing 2 | 3 | Download or create Chinook_Sqlite.sql. For instructions, go here: https://github.com/lerocha/chinook-database 4 | 5 | Run `build.sh` to generate TSV files for import. 6 | 7 | ## TODO 8 | 9 | Build a database using the generated TSV files. 10 | 11 | Run test queries using the database. 12 | -------------------------------------------------------------------------------- /test/chinook/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -eufo pipefail 3 | 4 | # To download or create Chinook_Sqlite.sql, see: https://github.com/lerocha/chinook-database 5 | 6 | here="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" 7 | 8 | cd "$here" 9 | 10 | dos2unix Chinook_Sqlite.sql 11 | sqlite3 -init Chinook_Sqlite.sql chinook.sqlite < /dev/null 12 | 13 | for table in Customer Employee Invoice InvoiceLine Genre Album Artist Playlist PlaylistTrack Track MediaType; do 14 | printf ".mode tabs\n.headers on\n.output $table.tsv\nselect * from $table;" | sqlite3 chinook.sqlite 15 | done 16 | 17 | rm chinook.sqlite 18 | -------------------------------------------------------------------------------- /test/datalog/basic-naive.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | facts 4 | == 5 | fresh 6 | conde 7 | run* 8 | define-relation) 9 | (require racket/list racket/match racket/set racket/struct) 10 | 11 | ;; A naive Datalog implementation that can be used as a baseline 12 | 13 | ;; Terms: 14 | ;; - Constants and variables 15 | ;; Formulas: 16 | ;; - Existential quantification, conjunction, disjunction 17 | ;; - via fresh and conde 18 | ;; - Negation is not supported in this basic implementation 19 | ;; - Relation calls 20 | ;; - Equality constraints 21 | ;; - run* 22 | ;; Relations: 23 | ;; - via define-relation and define-relation/facts (for convenience) 24 | 25 | ;; Variables should not be nested within data structures, but this is not checked. 26 | ;; All relations should be range restricted for safety, but this is not checked. 27 | 28 | (struct var (name) #:prefab) 29 | 30 | (define subst.empty (hash)) 31 | (define (unpack subst names) 32 | (map (lambda (n) (hash-ref subst n (lambda () (error "unbound variable" n)))) names)) 33 | (define (shadow subst names) 34 | (foldl (lambda (n s) (hash-remove s n)) subst names)) 35 | (define (assign subst x t) 36 | (and (not (occurs? subst x t)) 37 | (hash-set subst (var-name x) t))) 38 | (define (walk subst x) 39 | (let loop ((x x)) 40 | (if (var? x) 41 | (let ((y (hash-ref subst (var-name x) x))) 42 | (if (equal? x y) 43 | x 44 | (loop y))) 45 | x))) 46 | (define (occurs? subst x t) 47 | (let ((x (walk subst x)) (t (walk subst t))) 48 | (or (equal? x t) 49 | (and (pair? t) 50 | (or (occurs? subst x (car t)) 51 | (occurs? subst x (cdr t)))) 52 | (and (vector? t) 53 | (occurs? subst x (vector->list t)))))) 54 | (define (unify subst u v) 55 | (let ((u (walk subst u)) (v (walk subst v))) 56 | (cond ((eqv? u v) subst) 57 | ((var? u) (if (and (var? v) (equal? (var-name u) (var-name v))) 58 | subst 59 | (assign subst u v))) 60 | ((var? v) (assign subst v u)) 61 | ((pair? u) (and (pair? v) 62 | (let ((subst (unify subst (car u) (car v)))) 63 | (and subst 64 | (unify subst (cdr u) (cdr v)))))) 65 | ((vector? u) (and (vector? v) 66 | (unify subst (vector->list u) (vector->list v)))) 67 | (else (and (equal? u v) subst))))) 68 | 69 | (struct relation (name attrs box.current qthunk) 70 | #:methods gen:custom-write 71 | ((define write-proc (make-constructor-style-printer 72 | (lambda (r) 'relation) 73 | (lambda (r) (list (cons (relation-name r) (relation-attrs r))))))) 74 | #:property prop:procedure 75 | (lambda (r . args) 76 | (unless (= (length (relation-attrs r)) (length args)) 77 | (error "relation called with invalid number of arguments" r args)) 78 | `(relate ,r ,args))) 79 | 80 | (define (relation-current r) (unbox (relation-box.current r))) 81 | (define (relation-next r) (query-eval (relation-query r))) 82 | (define (relation-query r) ((relation-qthunk r))) 83 | 84 | (define (query-dependencies q) 85 | (let loop ((fm q) (rs (set))) 86 | (match fm 87 | (`(and . ,fms) (foldl loop rs fms)) 88 | (`(or . ,fms) (foldl loop rs fms)) 89 | (`(relate ,r ,_) (if (set-member? rs r) 90 | rs 91 | (loop (relation-query r) (set-add rs r)))) 92 | (`(exist ,_ ,fm) (loop fm rs)) 93 | (`(query ,_ ,fm) (loop fm rs)) 94 | (`(== ,_ ,_) rs)))) 95 | 96 | (define (query-eval q) 97 | (match q 98 | (`(query ,var-names ,fm) 99 | (list->set 100 | (map (lambda (subst) (unpack subst var-names)) 101 | (let loop ((fm fm) (subst subst.empty)) 102 | (match fm 103 | (`(and ,fm . ,fms) (let ((substs (loop fm subst))) 104 | (append* (map (lambda (subst) (loop `(and . ,fms) subst)) 105 | substs)))) 106 | ('(and) (list subst)) 107 | (`(or . ,fms) (append* (map (lambda (fm) (loop fm subst)) fms))) 108 | (`(relate ,r ,args) (filter-not not (set-map (relation-current r) 109 | (lambda (tuple) (unify subst args tuple))))) 110 | (`(exist ,ns ,fm) (map (lambda (subst) (shadow subst ns)) 111 | (loop fm (shadow subst ns)))) 112 | (`(== ,u ,v) (let ((subst (unify subst u v))) 113 | (if subst 114 | (list subst) 115 | '())))))))))) 116 | 117 | (define (query-run q) 118 | (let ((r.deps (set->list (query-dependencies q)))) 119 | (for-each (lambda (r) (set-box! (relation-box.current r) (set))) r.deps) 120 | (let loop () 121 | (when (foldl (lambda (r changed?) 122 | (let ((current (relation-current r)) 123 | (next (relation-next r))) 124 | (if (= (set-count current) (set-count next)) 125 | changed? 126 | (begin (set-box! (relation-box.current r) next) 127 | #t)))) 128 | #f r.deps) 129 | (loop))) 130 | (query-eval q))) 131 | 132 | ;;;;;;;;;;;;;; 133 | ;;; Syntax ;;; 134 | ;;;;;;;;;;;;;; 135 | 136 | (define (facts vars tuples) 137 | `(or . ,(map (lambda (tuple) `(== ,vars ,tuple)) tuples))) 138 | 139 | (define (== u v) `(== ,u ,v)) 140 | 141 | (define-syntax-rule 142 | (conde (fm00 fm0* ...) (fm0 fm* ...) ...) 143 | `(or (and ,fm00 ,fm0* ...) (and ,fm0 ,fm* ...) ...)) 144 | (define-syntax-rule 145 | (quantify type (x ...) fm0 fm ...) 146 | (let ((x (var 'x)) ...) 147 | `(type (x ...) (and ,fm0 ,fm ...)))) 148 | (define-syntax-rule 149 | (fresh (x ...) fm0 fm ...) 150 | (quantify exist (x ...) fm0 fm ...)) 151 | (define-syntax-rule 152 | (query (x ...) fm0 fm ...) 153 | (quantify query (x ...) fm0 fm ...)) 154 | (define-syntax run* 155 | (syntax-rules () 156 | ((_ (x ...) fm0 fm ...) (set->list (query-run (query (x ...) fm0 fm ...)))) 157 | ((_ x fm0 fm ...) (map car (run* (x) fm0 fm ...))))) 158 | (define-syntax-rule 159 | (define-relation (name attr ...) fm0 fm ...) 160 | (define name (relation 'name '(attr ...) (box #f) 161 | (lambda () (query (attr ...) fm0 fm ...))))) 162 | -------------------------------------------------------------------------------- /test/datalog/kanren-notation-micro.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | facts fresh conde 4 | define-relation 5 | run*) 6 | (require "micro.rkt") ; Basic micro core with quadratic time fact accumulation 7 | ;(require "micro-with-sets.rkt") ; A faster version of the micro core 8 | 9 | ;;; Formulas are wrapped ambitions which discover their producer dependencies. 10 | 11 | (define (fm:true seen d*) (values seen d* unit)) 12 | (define (fm:false seen d*) (values seen d* fail)) 13 | 14 | (define (fm:and fm0 fm1) 15 | (lambda (seen p*) 16 | (let-values (((seen p* a0) (fm0 seen p*))) 17 | (let-values (((seen p* a1) (fm1 seen p*))) 18 | (values seen p* (conj a0 a1)))))) 19 | (define (fm:or fm0 fm1) 20 | (lambda (seen p*) 21 | (let-values (((seen p* a0) (fm0 seen p*))) 22 | (let-values (((seen p* a1) (fm1 seen p*))) 23 | (values seen p* (disj a0 a1)))))) 24 | 25 | (define (fm:and+ fm0 fm*) 26 | (if (null? fm*) 27 | fm0 28 | (fm:and fm0 (fm:and+ (car fm*) (cdr fm*))))) 29 | (define (fm:or+ fm0 fm*) 30 | (if (null? fm*) 31 | fm0 32 | (fm:or fm0 (fm:or+ (car fm*) (cdr fm*))))) 33 | 34 | (define (fm:and* fm*) 35 | (if (null? fm*) 36 | fm:true 37 | (fm:and+ (car fm*) (cdr fm*)))) 38 | (define (fm:or* fm*) 39 | (if (null? fm*) 40 | fm:false 41 | (fm:or+ (car fm*) (cdr fm*)))) 42 | 43 | (define (fm:== t0 t1) (lambda (seen p*) (values seen p* (== t0 t1)))) 44 | 45 | ;;;;;;;;;;;;;; 46 | ;;; Syntax ;;; 47 | ;;;;;;;;;;;;;; 48 | 49 | ;; TODO: defining facts using == leads to enormous fact production redundancy, 50 | ;; exposing performance problems with unique-append since it is a quadratic 51 | ;; implementation of set union. Since we want to be able to support large 52 | ;; relation definitions, the right way to fix this is for the core to store 53 | ;; facts in efficient sets instead of lists. But we could also reduce 54 | ;; redundancy by stratifying the evaluation of relation dependencies. This 55 | ;; would lead to fact-oriented relations only being evaluated once, at the 56 | ;; start of a run. 57 | (define (facts vars tuples) 58 | (fm:or* (map (lambda (tuple) (fm:== vars tuple)) tuples))) 59 | 60 | ;; TODO: rule safety checking? 61 | (define-syntax-rule 62 | (define-relation (name attr ...) fm0 fm* ...) 63 | (define (name attr ...) 64 | (lambda (seen p*) 65 | (let ((head (list name (var 'attr) ...)) 66 | (fm (fresh (attr ...) fm0 fm* ...)) 67 | (a.call (relate (list name attr ...)))) 68 | (if (member name seen) 69 | (values seen p* a.call) 70 | (let-values (((seen p* a) (fm (cons name seen) p*))) 71 | (values seen (cons (realize head a) p*) a.call))))))) 72 | 73 | (define-syntax-rule 74 | (fresh (x ...) fm0 fm* ...) 75 | (let ((x (var 'x)) ...) (fm:and+ fm0 (list fm* ...)))) 76 | 77 | (define-syntax-rule 78 | (conde (fm00 fm0* ...) 79 | (fm0 fm* ...) ...) 80 | (fm:or+ (fm:and+ fm00 (list fm0* ...)) 81 | (list (fm:and+ fm0 (list fm* ...) ...) ...))) 82 | 83 | (define-syntax run* 84 | (syntax-rules () 85 | ((_ (x ...) fm0 fm* ...) 86 | (let ((x (var 'x)) ...) 87 | (define-relation (query x ...) fm0 fm* ...) 88 | (let-values (((seen p* a) ((query x ...) '() '()))) 89 | (let ((F* (exhaust* p* '()))) 90 | (map cdr (filter (lambda (F) (eq? (car F) query)) F*)))))) 91 | ((_ x fm0 fm* ...) (map car (run* (x) fm0 fm* ...))))) 92 | -------------------------------------------------------------------------------- /test/datalog/micro-plus.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | (struct-out var) 4 | unit fail 5 | conj conj+ conj* 6 | disj disj+ disj* 7 | == relate reject-relate compute reject-compute 8 | realize produce-once* exhaust*) 9 | (require racket/set) 10 | 11 | ;; This version of the micro core supports fact merging for aggregation. 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | ;;; Terms and substitution ;;; 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | (struct var (name) #:prefab) 18 | (define subst.empty '()) 19 | 20 | (define (subst-extend S x t) 21 | (let ((name.x (var-name x))) 22 | (and (not (occurs? S name.x t)) 23 | (cons (cons name.x t) S)))) 24 | 25 | (define (walk S t) 26 | (cond ((var? t) (let ((kv (assoc (var-name t) S))) 27 | (if kv (walk S (cdr kv)) t))) 28 | (else t))) 29 | 30 | (define (walk* S t) 31 | (cond ((var? t) (let ((kv (assoc (var-name t) S))) 32 | (if kv (walk* S (cdr kv)) t))) 33 | ((pair? t) (cons (walk* S (car t)) (walk* S (cdr t)))) 34 | ((vector? t) (list->vector (walk* S (vector->list t)))) 35 | (else t))) 36 | 37 | (define (occurs? S name.x t) 38 | (let ((t (walk S t))) 39 | (or (and (var? t) (equal? name.x (var-name t))) 40 | (and (pair? t) (or (occurs? S name.x (car t)) (occurs? S name.x (cdr t)))) 41 | (and (vector? t) (occurs? S name.x (vector->list t)))))) 42 | 43 | (define (unify S u v) 44 | (let ((u (walk S u)) (v (walk S v))) 45 | (cond ((eqv? u v) S) 46 | ((var? u) (if (and (var? v) (equal? (var-name u) (var-name v))) 47 | S 48 | (subst-extend S u v))) 49 | ((var? v) (subst-extend S v u)) 50 | ((pair? u) (and (pair? v) 51 | (let ((S (unify S (car u) (car v)))) 52 | (and S 53 | (unify S (cdr u) (cdr v)))))) 54 | ((vector? u) (and (vector? v) 55 | (unify S (vector->list u) (vector->list v)))) 56 | (else (and (equal? u v) S))))) 57 | 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | ;;; Goals, ambitions, producers ;;; 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | ;; Goal = S -> S* 63 | ;; Ambition = F* -> Goal 64 | ;; Producer = F* -> F* 65 | 66 | (define (bind S* g) (if (null? S*) '() (append (g (car S*)) (bind (cdr S*) g)))) 67 | 68 | (define unit (lambda (F*) (lambda (S) (list S)))) 69 | (define fail (lambda (F*) (lambda (S) '()))) 70 | (define (== t0 t1) (lambda (F*) (lambda (S) (let ((S (unify S t0 t1))) 71 | (if S (list S) '()))))) 72 | ;; NOTE: use =/= carefully as it currently implements negation-as-failure 73 | (define (=/= t0 t1) (lambda (F*) (lambda (S) (let ((S.new (unify S t0 t1))) 74 | (if S.new '() (list S)))))) 75 | (define (conj a0 a1) (lambda (F*) (let ((g0 (a0 F*)) (g1 (a1 F*))) 76 | (lambda (S) (bind (g0 S) g1))))) 77 | (define (disj a0 a1) (lambda (F*) (let ((g0 (a0 F*)) (g1 (a1 F*))) 78 | (lambda (S) (append (g0 S) (g1 S)))))) 79 | (define (conj+ a a*) (if (null? a*) a (conj a (conj+ (car a*) (cdr a*))))) 80 | (define (disj+ a a*) (if (null? a*) a (disj a (disj+ (car a*) (cdr a*))))) 81 | (define (conj* a*) (if (null? a*) unit (conj+ (car a*) (cdr a*)))) 82 | (define (disj* a*) (if (null? a*) fail (disj+ (car a*) (cdr a*)))) 83 | 84 | (define (relate atom) 85 | (lambda (F*) ; This staging significantly improves performance. 86 | ((disj* (map (lambda (F) (== atom F)) 87 | (filter (lambda (F) (unify subst.empty atom F)) F*))) 88 | 'ignored))) 89 | (define (reject-relate atom) 90 | ;; NOTE: this ambition has a fully-ground mode. 91 | (lambda (F*) 92 | ((conj* (map (lambda (F) (=/= atom F)) 93 | (filter (lambda (F) (unify subst.empty atom F)) F*))) 94 | 'ignored))) 95 | 96 | (define (compute proc args) 97 | (lambda (F*) (lambda (S) ((apply proc (walk* S args)) S)))) 98 | (define (reject-compute proc args) 99 | ;; NOTE: this ambition has a fully-ground mode. 100 | (lambda (F*) (lambda (S) (if (null? ((apply proc (walk* S args)) S)) 101 | (list S) 102 | '())))) 103 | 104 | (define remember (lambda (F*) F*)) 105 | (define (realize atom a) (lambda (F*) (map (lambda (S) (walk* S atom)) 106 | ((a F*) subst.empty)))) 107 | (define (combine p0 p1) (lambda (F*) (append (p0 F*) (p1 F*)))) 108 | (define (combine* p*) (if (null? p*) 109 | remember 110 | (combine (car p*) (combine* (cdr p*))))) 111 | 112 | (define (aggregate predicate=>merge F*) 113 | (let loop ((F* F*) 114 | (F*.skipped '()) 115 | (predicate=>key=>value (make-immutable-hash 116 | (map (lambda (key) (cons key (hash))) 117 | (hash-keys predicate=>merge))))) 118 | (if (null? F*) 119 | (apply append 120 | F*.skipped 121 | (map (lambda (p&k=>v) 122 | (let ((predicate (car p&k=>v))) 123 | (map (lambda (k&v) 124 | (cons predicate 125 | (reverse (cons (cdr k&v) (car k&v))))) 126 | (hash->list (cdr p&k=>v))))) 127 | (hash->list predicate=>key=>value))) 128 | (let* ((F (car F*)) 129 | (predicate (car F)) 130 | (merge (hash-ref predicate=>merge predicate #f))) 131 | (if merge 132 | (loop (cdr F*) F*.skipped 133 | (hash-update 134 | predicate=>key=>value 135 | predicate 136 | (lambda (key=>value) 137 | (let* ((reversed (reverse (cdr F))) 138 | (key (cdr reversed)) 139 | (value (car reversed))) 140 | (hash-set key=>value key 141 | (if (hash-has-key? key=>value key) 142 | (merge (hash-ref key=>value key) value) 143 | value)))))) 144 | (loop (cdr F*) (cons F F*.skipped) predicate=>key=>value)))))) 145 | 146 | 147 | (define (produce-once p predicate=>merge F*) 148 | (list->set (aggregate predicate=>merge (p (set->list F*))))) 149 | 150 | (define (produce-once* p* predicate=>merge F*) 151 | (set->list (produce-once (combine* p*) predicate=>merge (list->set F*)))) 152 | 153 | (define (exhaust p predicate=>merge F*) 154 | (let ((F*.new (produce-once p predicate=>merge F*))) 155 | (if (set=? F* F*.new) 156 | F*.new 157 | (exhaust p predicate=>merge F*.new)))) 158 | 159 | (define (exhaust* p* predicate=>merge F*) 160 | (set->list (exhaust (combine* p*) predicate=>merge (list->set F*)))) 161 | -------------------------------------------------------------------------------- /test/datalog/micro-with-sets.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | (struct-out var) 4 | unit fail 5 | conj conj+ conj* 6 | disj disj+ disj* 7 | == relate 8 | realize exhaust*) 9 | (require racket/set) 10 | 11 | ;; This version of the micro core uses sets to accumulate facts in linear time. 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | ;;; Terms and substitution ;;; 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | (struct var (name) #:prefab) 18 | (define subst.empty '()) 19 | 20 | (define (subst-extend S x t) 21 | (and (not (occurs? S (walk S x) t)) 22 | (cons (cons (var-name x) t) S))) 23 | 24 | (define (walk S t) 25 | (cond ((var? t) (let ((kv (assoc (var-name t) S))) 26 | (if kv (walk S (cdr kv)) t))) 27 | (else t))) 28 | 29 | (define (walk* S t) 30 | (cond ((var? t) (let ((kv (assoc (var-name t) S))) 31 | (if kv (walk* S (cdr kv)) t))) 32 | ((pair? t) (cons (walk* S (car t)) (walk* S (cdr t)))) 33 | ((vector? t) (list->vector (walk* S (vector->list t)))) 34 | (else t))) 35 | 36 | (define (occurs? S x t) 37 | (let ((t (walk S t))) 38 | (or (equal? x t) 39 | (and (pair? t) (or (occurs? S x (car t)) (occurs? S x (cdr t)))) 40 | (and (vector? t) (occurs? S x (vector->list t)))))) 41 | 42 | (define (unify S u v) 43 | (let ((u (walk S u)) (v (walk S v))) 44 | (cond ((eqv? u v) S) 45 | ((var? u) (if (and (var? v) (equal? (var-name u) (var-name v))) 46 | S 47 | (subst-extend S u v))) 48 | ((var? v) (subst-extend S v u)) 49 | ((pair? u) (and (pair? v) 50 | (let ((S (unify S (car u) (car v)))) 51 | (and S 52 | (unify S (cdr u) (cdr v)))))) 53 | ((vector? u) (and (vector? v) 54 | (unify S (vector->list u) (vector->list v)))) 55 | (else (and (equal? u v) S))))) 56 | 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | ;;; Goals, ambitions, producers ;;; 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | 61 | ;; Goal = S -> S* 62 | ;; Ambition = F* -> Goal 63 | ;; Producer = F* -> F* 64 | 65 | (define (bind S* g) (if (null? S*) '() (append (g (car S*)) (bind (cdr S*) g)))) 66 | 67 | (define unit (lambda (F*) (lambda (S) (list S)))) 68 | (define fail (lambda (F*) (lambda (S) '()))) 69 | (define (== t0 t1) (lambda (F*) (lambda (S) (let ((S (unify S t0 t1))) 70 | (if S (list S) '()))))) 71 | (define (conj a0 a1) (lambda (F*) (let ((g0 (a0 F*)) (g1 (a1 F*))) 72 | (lambda (S) (bind (g0 S) g1))))) 73 | (define (disj a0 a1) (lambda (F*) (let ((g0 (a0 F*)) (g1 (a1 F*))) 74 | (lambda (S) (append (g0 S) (g1 S)))))) 75 | (define (conj+ a a*) (if (null? a*) a (conj a (conj+ (car a*) (cdr a*))))) 76 | (define (disj+ a a*) (if (null? a*) a (disj a (disj+ (car a*) (cdr a*))))) 77 | (define (conj* a*) (if (null? a*) unit (conj+ (car a*) (cdr a*)))) 78 | (define (disj* a*) (if (null? a*) fail (disj+ (car a*) (cdr a*)))) 79 | 80 | (define (relate atom) 81 | (lambda (F*) ; This staging significantly improves performance. 82 | ((disj* (map (lambda (F) (== atom F)) 83 | (filter (lambda (F) (unify subst.empty atom F)) 84 | (set->list F*)))) 85 | 'ignored))) 86 | 87 | (define remember (lambda (F*) F*)) 88 | (define (realize atom a) (lambda (F*) 89 | (list->set (map (lambda (S) (walk* S atom)) 90 | ((a F*) subst.empty))))) 91 | (define (combine p0 p1) (lambda (F*) (set-union (p0 F*) (p1 F*)))) 92 | (define (combine* p*) (if (null? p*) 93 | remember 94 | (combine (car p*) (combine* (cdr p*))))) 95 | (define (exhaust p F*) (let ((F*.new (p F*))) 96 | (if (= (set-count F*) (set-count F*.new)) 97 | F* 98 | (exhaust p F*.new)))) 99 | (define (exhaust* p* F*) (set->list (exhaust (combine* p*) (list->set F*)))) 100 | -------------------------------------------------------------------------------- /test/datalog/micro.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | (struct-out var) 4 | unit fail 5 | conj conj+ conj* 6 | disj disj+ disj* 7 | == relate 8 | realize exhaust*) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;;; Terms and substitution ;;; 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | (struct var (name) #:prefab) 15 | (define subst.empty '()) 16 | 17 | (define (subst-extend S x t) 18 | (let ((name.x (var-name x))) 19 | (and (not (occurs? S name.x t)) 20 | (cons (cons name.x t) S)))) 21 | 22 | (define (walk S t) 23 | (cond ((var? t) (let ((kv (assoc (var-name t) S))) 24 | (if kv (walk S (cdr kv)) t))) 25 | (else t))) 26 | 27 | (define (walk* S t) 28 | (cond ((var? t) (let ((kv (assoc (var-name t) S))) 29 | (if kv (walk* S (cdr kv)) t))) 30 | ((pair? t) (cons (walk* S (car t)) (walk* S (cdr t)))) 31 | ((vector? t) (list->vector (walk* S (vector->list t)))) 32 | (else t))) 33 | 34 | (define (occurs? S name.x t) 35 | (let ((t (walk S t))) 36 | (or (and (var? t) (equal? name.x (var-name t))) 37 | (and (pair? t) (or (occurs? S name.x (car t)) (occurs? S name.x (cdr t)))) 38 | (and (vector? t) (occurs? S name.x (vector->list t)))))) 39 | 40 | (define (unify S u v) 41 | (let ((u (walk S u)) (v (walk S v))) 42 | (cond ((eqv? u v) S) 43 | ((var? u) (if (and (var? v) (equal? (var-name u) (var-name v))) 44 | S 45 | (subst-extend S u v))) 46 | ((var? v) (subst-extend S v u)) 47 | ((pair? u) (and (pair? v) 48 | (let ((S (unify S (car u) (car v)))) 49 | (and S 50 | (unify S (cdr u) (cdr v)))))) 51 | ((vector? u) (and (vector? v) 52 | (unify S (vector->list u) (vector->list v)))) 53 | (else (and (equal? u v) S))))) 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | ;;; Goals, ambitions, producers ;;; 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | ;; Goal = S -> S* 60 | ;; Ambition = F* -> Goal 61 | ;; Producer = F* -> F* 62 | 63 | (define (bind S* g) (if (null? S*) '() (append (g (car S*)) (bind (cdr S*) g)))) 64 | 65 | (define unit (lambda (F*) (lambda (S) (list S)))) 66 | (define fail (lambda (F*) (lambda (S) '()))) 67 | (define (== t0 t1) (lambda (F*) (lambda (S) (let ((S (unify S t0 t1))) 68 | (if S (list S) '()))))) 69 | (define (conj a0 a1) (lambda (F*) (let ((g0 (a0 F*)) (g1 (a1 F*))) 70 | (lambda (S) (bind (g0 S) g1))))) 71 | (define (disj a0 a1) (lambda (F*) (let ((g0 (a0 F*)) (g1 (a1 F*))) 72 | (lambda (S) (append (g0 S) (g1 S)))))) 73 | (define (conj+ a a*) (if (null? a*) a (conj a (conj+ (car a*) (cdr a*))))) 74 | (define (disj+ a a*) (if (null? a*) a (disj a (disj+ (car a*) (cdr a*))))) 75 | (define (conj* a*) (if (null? a*) unit (conj+ (car a*) (cdr a*)))) 76 | (define (disj* a*) (if (null? a*) fail (disj+ (car a*) (cdr a*)))) 77 | 78 | (define (relate atom) 79 | (lambda (F*) ; This staging significantly improves performance. 80 | ((disj* (map (lambda (F) (== atom F)) 81 | (filter (lambda (F) (unify subst.empty atom F)) F*))) 82 | 'ignored))) 83 | 84 | (define (unique-cons x xs) (if (member x xs) xs (cons x xs))) 85 | (define (unique-append xs ys) 86 | (if (null? xs) 87 | ys 88 | (unique-cons (car xs) (unique-append (cdr xs) ys)))) 89 | 90 | (define remember (lambda (F*) F*)) 91 | (define (realize atom a) (lambda (F*) (map (lambda (S) (walk* S atom)) 92 | ((a F*) subst.empty)))) 93 | (define (combine p0 p1) (lambda (F*) (unique-append (p0 F*) (p1 F*)))) 94 | (define (combine* p*) (if (null? p*) 95 | remember 96 | (combine (car p*) (combine* (cdr p*))))) 97 | (define (exhaust p F*) (let ((F*.new (p F*))) 98 | (if (eq? F* F*.new) F* (exhaust p F*.new)))) 99 | (define (exhaust* p* F*) (exhaust (combine* p*) F*)) 100 | -------------------------------------------------------------------------------- /test/datalog/test-basic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "basic-naive.rkt" racket/list racket/pretty) 3 | (print-as-expression #f) 4 | ;(pretty-print-abbreviate-read-macros #f) 5 | 6 | (define-syntax-rule 7 | (pretty-results example ...) 8 | (begin (begin (pretty-write 'example) 9 | (pretty-write '==>) 10 | (pretty-write example) 11 | (newline)) ...)) 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;; 14 | ;;; Graph traversal ;;; 15 | ;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | (define-relation (edge a b) 18 | (facts (list a b) 19 | '((a b) 20 | (b c) 21 | (d e) 22 | (e f) 23 | (b f) 24 | (f a) ; comment this edge for an acyclic graph 25 | ))) 26 | 27 | (define-relation (path a b) 28 | (conde ((edge a b)) 29 | ((fresh (mid) 30 | (edge a mid) 31 | (path mid b))))) 32 | 33 | (pretty-results 34 | (run* (x) (path 'a x)) 35 | (run* (x) (path x 'f)) 36 | (run* (x y) (path x y)) 37 | (run* (x y) (edge x y))) 38 | 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;; Finite arithmetic ;;; 42 | ;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (define-relation (+o a b c) 45 | (facts (list a b c) 46 | (append* (map (lambda (a) 47 | (map (lambda (b) (list a b (+ a b))) 48 | (range 100))) 49 | (range 100))))) 50 | 51 | (define-relation (*o a b c) 52 | (facts (list a b c) 53 | (append* (map (lambda (a) 54 | (map (lambda (b) (list a b (* a b))) 55 | (range 100))) 56 | (range 100))))) 57 | 58 | (define-relation () 11 | (pretty-write result) 12 | (newline)) ...)) 13 | 14 | ;;;;;;;;;;;;;;;;;;;;;;; 15 | ;;; Graph traversal ;;; 16 | ;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (define-relation (edge a b) 19 | (facts (list a b) 20 | '((a b) 21 | (b c) 22 | (d e) 23 | (e f) 24 | (b f) 25 | (f a) ; comment this edge for an acyclic graph 26 | ))) 27 | 28 | (define-relation (path a b) 29 | (conde ((edge a b)) 30 | ((fresh (mid) 31 | (edge a mid) 32 | (path mid b))))) 33 | 34 | (pretty-results 35 | (run* (x) (path 'a x)) 36 | (run* (x) (path x 'f)) 37 | (run* (x y) (path x y)) 38 | (run* (x y) (edge x y))) 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;; Finite arithmetic ;;; 42 | ;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (define-relation (+o a b c) 45 | (facts (list a b c) 46 | (apply append (map (lambda (a) 47 | (map (lambda (b) (list a b (+ a b))) 48 | (range 50))) 49 | (range 50))))) 50 | 51 | (define-relation (*o a b c) 52 | (facts (list a b c) 53 | (apply append (map (lambda (a) 54 | (map (lambda (b) (list a b (* a b))) 55 | (range 50))) 56 | (range 50))))) 57 | 58 | (define-relation () 11 | (pretty-write result) 12 | (newline)) ...)) 13 | 14 | (define (run-queries rules.query rules facts) 15 | (let ((facts (run-datalog (append rules.query rules) facts))) 16 | (map (lambda (predicate.query) 17 | (filter (lambda (fact) (eq? (car fact) predicate.query)) facts)) 18 | (map caar rules.query)))) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;; Graph traversal ;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (pretty-results 25 | (run-queries 26 | '(((q1 x) (path 'a x)) 27 | ((q2 x) (path x 'f)) 28 | ((q3 x y) (path x y)) 29 | ((q4 x y) (edge x y))) 30 | '(((path x y) (edge x y)) 31 | ((path x z) (edge x y) (path y z))) 32 | '((edge a b) 33 | (edge b c) 34 | (edge d e) 35 | (edge e f) 36 | (edge b f) 37 | (edge f a) ; comment this edge for an acyclic graph 38 | ))) 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;; Finite arithmetic ;;; 42 | ;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (define facts.+ (apply append (map (lambda (a) 45 | (map (lambda (b) `(+o ,a ,b ,(+ a b))) 46 | (range 50))) 47 | (range 50)))) 48 | (define facts.* (apply append (map (lambda (a) 49 | (map (lambda (b) `(*o ,a ,b ,(* a b))) 50 | (range 50))) 51 | (range 50)))) 52 | (define facts.< (apply append (map (lambda (a) 53 | (apply append (map (lambda (b) (if (< a b) 54 | `((set (map var-name (filter var? atom)))) 6 | 7 | (define (parse-term expr) 8 | (match expr 9 | ((? symbol?) (var expr)) 10 | (`(quote ,c) c) 11 | ((cons _ _) (error "unsupported function call" expr)) 12 | (_ expr))) 13 | 14 | (define (parse-atom expr) (cons (car expr) (map parse-term (cdr expr)))) 15 | 16 | (struct rule (head body+ body-) #:prefab) 17 | 18 | (define (parse-rule expr) 19 | (let ((head (parse-atom (car expr)))) 20 | (let loop ((e* (cdr expr)) (atoms.+ '())) 21 | (define (finish atoms.-) 22 | (let ((r (rule head (reverse atoms.+) atoms.-))) 23 | (let ((vars.+ (apply set-union (set) (map atom-vars (rule-body+ r)))) 24 | (vars.- (apply set-union (set) (map atom-vars (rule-body- r))))) 25 | (unless (subset? (atom-vars (rule-head r)) vars.+) 26 | (error "rule head is not range-restricted" expr)) 27 | (unless (subset? vars.- vars.+) 28 | (error "rule negated body atoms are not range-restricted" expr))) 29 | r)) 30 | (match e* 31 | ('() (finish '())) 32 | ((cons 'not e*) (finish (map parse-atom e*))) 33 | ((cons e e*) (loop e* (cons (parse-atom e) atoms.+))))))) 34 | 35 | (define (run-stratified predicate=>proc predicate=>merge e**.rules F*) 36 | (define (enforce r) 37 | (match-define (rule head atoms.+ atoms.-) r) 38 | (define (+atom->a atom) 39 | (let ((proc (hash-ref predicate=>proc (car atom) #f))) 40 | (if proc 41 | (compute proc (cdr atom)) 42 | (relate atom)))) 43 | (define (-atom->a atom) 44 | (let ((proc (hash-ref predicate=>proc (car atom) #f))) 45 | (if proc 46 | (reject-compute proc (cdr atom)) 47 | (reject-relate atom)))) 48 | (realize head (conj* (append (map +atom->a atoms.+) (map -atom->a atoms.-))))) 49 | (foldr (lambda (c&p* F*) 50 | (match c&p* 51 | (`(run-once . ,p*) (produce-once* p* predicate=>merge F*)) 52 | (`(run-fixed-point . ,p*) (exhaust* p* predicate=>merge F*)))) 53 | F* 54 | (map (lambda (e*.rules) 55 | (define (build e*) (map enforce (map parse-rule e*))) 56 | (match e*.rules 57 | ((cons (and (or 'run-once 'run-fixed-point) cmd) e*.rules) 58 | (cons cmd (build e*.rules))) 59 | (_ (cons 'run-fixed-point (build e*.rules))))) 60 | e**.rules))) 61 | -------------------------------------------------------------------------------- /test/datalog/unmanaged-notation-micro.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide run-datalog) 3 | (require "micro.rkt" (except-in racket/match ==)) 4 | ;(require "micro-with-sets.rkt" (except-in racket/match ==)) 5 | 6 | ;; This example syntax demonstrates how to use the core concepts. This is only 7 | ;; one possible syntax. For instance, you could also implement a Kanren-style 8 | ;; syntax that uses the same core concepts. 9 | 10 | ;; - Programs are made up of rules and facts: 11 | ;; - Atom: a predicate constant followed by zero or more terms 12 | ;; - Rule: a head atom followed by zero or more body atoms 13 | ;; - Fact: a single atom 14 | 15 | ;; - Terms in rules may be variables or constants: 16 | ;; - An unquoted symbol is treated as a variable. 17 | ;; - Any quoted value is treated as a constant. 18 | ;; - All other non-pair values are treated as constants. 19 | ;; - Variables cannot appear nested in other terms. 20 | 21 | ;; - Terms in facts are always unquoted constants, including symbols and pairs. 22 | 23 | ;; - There are no queries. There are only rules and facts. 24 | ;; - e.g., (run-datalog rules facts) ==> more-facts 25 | 26 | (define (atom-vars atom) (filter var? atom)) 27 | 28 | (define (rule-safe?! rule) 29 | (let ((vars.body (apply append (map atom-vars (cdr rule))))) 30 | (for-each (lambda (var.head) (or (member var.head vars.body) 31 | (error "unsafe rule" rule))) 32 | (atom-vars (car rule))))) 33 | 34 | (define (parse-term expr) 35 | (match expr 36 | ((? symbol?) (var expr)) 37 | (`(quote ,c) c) 38 | ((cons _ _) (error "unsupported function call" expr)) 39 | (_ expr))) 40 | 41 | (define (parse-atom expr) (cons (car expr) (map parse-term (cdr expr)))) 42 | (define (parse-rule expr) (let ((rule (map parse-atom expr))) 43 | (rule-safe?! rule) 44 | rule)) 45 | 46 | (define (enforce rule) (realize (car rule) (conj* (map relate (cdr rule))))) 47 | 48 | (define (run-datalog e*.rules F*) 49 | (exhaust* (map enforce (map parse-rule e*.rules)) F*)) 50 | -------------------------------------------------------------------------------- /test/equivalence-database.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide build-equivalence-database) 3 | (require 4 | racket/unsafe/ops 5 | ;"../dbk/safe-unsafe.rkt" 6 | "../dbk/database.rkt" racket/fixnum) 7 | 8 | (define name.equiv-edge 'equivalence-edge) 9 | (define name.equiv-class-member 'equivalence-class-member) 10 | 11 | ;; NOTE: for best performance, the left node of each edge should be the alphabetically smaller text 12 | (define (build-equivalence-database path en.edge*) 13 | (define db.equiv (database path)) 14 | (unless (or (database-relation-name? db.equiv name.equiv-edge) 15 | (database-relation-name? db.equiv name.equiv-class-member)) 16 | (let ((r.equiv-edge (build-enumerator-relation db.equiv '(text text) en.edge*))) 17 | (relation-name-set! r.equiv-edge name.equiv-edge) 18 | (relation-attributes-set! r.equiv-edge '(A B)) 19 | (database-commit! db.equiv))) 20 | (let ((r.equiv-edge (database-relation db.equiv name.equiv-edge))) 21 | (relation-full-compact! r.equiv-edge) 22 | (relation-index-add! r.equiv-edge '(A B)) 23 | (database-commit! db.equiv) 24 | (unless (database-relation-name? db.equiv name.equiv-class-member) 25 | (let-values (((text=>id id=>text) (relation-text-dicts r.equiv-edge #f))) 26 | (let* ((A=>B=>1 (relation-index-dict r.equiv-edge '(A B) #f)) 27 | (count.id* (dict-count id=>text)) 28 | (id=>id (make-fxvector count.id*))) 29 | (define (walk i) 30 | (let loop ((id.child i)) 31 | (let ((id.parent (unsafe-fxvector-ref id=>id id.child))) 32 | (if (unsafe-fx= id.parent id.child) 33 | id.child 34 | (let ((id.top (loop id.parent))) 35 | (unless (unsafe-fx= id.top id.parent) 36 | (unsafe-fxvector-set! id=>id id.child id.top)) 37 | id.top))))) 38 | (range-for-each (lambda (i) (unsafe-fxvector-set! id=>id i i)) count.id*) 39 | ((dict-enumerator A=>B=>1) 40 | (lambda (id.A B=>1) 41 | (let ((current (walk id.A))) 42 | (define (unify! candidate) 43 | (let ((candidate (walk candidate))) 44 | (cond ((unsafe-fx< candidate current) (unsafe-fxvector-set! id=>id current candidate) 45 | (set! current candidate)) 46 | (else (unsafe-fxvector-set! id=>id candidate current))))) 47 | ((dict-key-enumerator B=>1) (lambda (id.B) (unify! id.B)))))) 48 | (range-for-each walk count.id*) ; walk performs path compression 49 | (let ((r.equiv-class-member 50 | (build-enumerator-relation 51 | db.equiv '(text text) 52 | (let ((id->text (lambda (id) 53 | (dict-ref id=>text id (lambda (v) v) 54 | (lambda () (error "invalid text id" id)))))) 55 | (lambda (yield) 56 | (let loop ((i 0)) 57 | (when (< i count.id*) 58 | (yield (list (id->text (unsafe-fxvector-ref id=>id i)) 59 | (id->text i))) 60 | (loop (unsafe-fx+ i 1))))))))) 61 | (relation-name-set! r.equiv-class-member name.equiv-class-member) 62 | (relation-attributes-set! r.equiv-class-member '(representative member)) 63 | (relation-delete! r.equiv-edge) 64 | (database-commit! db.equiv))))) 65 | (let ((r.equiv-class-member (database-relation db.equiv name.equiv-class-member))) 66 | (relation-full-compact! r.equiv-class-member) 67 | (relation-index-add! r.equiv-class-member '(representative member) '(member representative)) 68 | (database-commit! db.equiv)) 69 | (database-trash-empty! db.equiv) 70 | db.equiv)) 71 | 72 | (define (range-for-each p count) 73 | (let loop ((i 0)) (when (< i count) (p i) (loop (unsafe-fx+ i 1))))) 74 | -------------------------------------------------------------------------------- /test/microbenchmarks/integer-bytes-throughput.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | racket/fixnum 4 | racket/unsafe/ops 5 | ) 6 | 7 | (define count 32) 8 | ;(define width 4) 9 | (define width 3) 10 | ;(define width (read)) 11 | (define total (* count width)) 12 | (define bstr (make-bytes total)) 13 | (define vec (make-vector 1)) 14 | 15 | (define (bytes-nat-set! n size __ ___ bs offset) 16 | ;(integer->integer-bytes n size #f #t bs offset) (void) 17 | (let ((end (+ offset size))) 18 | (let loop ((i offset) (shift (* 8 (- size 1)))) 19 | (cond ((< i end) (bytes-set! bs i (fxand 255 (fxrshift n shift))) 20 | (loop (+ i 1) (- shift 8))) 21 | (else bs))))) 22 | ;(define (unsafe-bytes-nat-set! n size __ ___ bs offset) 23 | ;(let ((end (unsafe-fx+ offset size))) 24 | ;(let loop ((i offset) (shift (unsafe-fx* 8 (unsafe-fx- size 1)))) 25 | ;(cond ((unsafe-fx< i end) (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n shift))) 26 | ;(loop (unsafe-fx+ i 1) (unsafe-fx- shift 8))) 27 | ;(else bs))))) 28 | 29 | (define (unsafe-bytes-nat-set! n size __ ___ bs offset) 30 | (let loop ((i offset) 31 | ;(shift (unsafe-fx* 8 (unsafe-fx- size 1))) 32 | (shift (unsafe-fxlshift (unsafe-fx- size 1) 3)) 33 | ) 34 | (when (unsafe-fx<= 0 shift) 35 | (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n shift))) 36 | (loop (unsafe-fx+ i 1) 37 | (unsafe-fx- shift 8))))) 38 | 39 | (define (unrolled-unsafe-bytes-nat-set!/1 n size __ ___ bs i) 40 | ;; assume size=1 41 | (unsafe-bytes-set! bs i n) 42 | ) 43 | 44 | (define (unrolled-unsafe-bytes-nat-set!/2 n size __ ___ bs i) 45 | ;; assume size=2 46 | (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n 8))) 47 | (unsafe-bytes-set! bs (+ i 1) (unsafe-fxand 255 n)) 48 | ) 49 | 50 | (define (unrolled-unsafe-bytes-nat-set!/3 n size __ ___ bs i) 51 | ;; assume size=3 52 | (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n 16))) 53 | (unsafe-bytes-set! bs (+ i 1) (unsafe-fxand 255 (unsafe-fxrshift n 8))) 54 | (unsafe-bytes-set! bs (+ i 2) (unsafe-fxand 255 n)) 55 | ) 56 | 57 | (define (unrolled-unsafe-bytes-nat-set!/4 n size __ ___ bs i) 58 | ;; assume size=4 59 | (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n 24))) 60 | (unsafe-bytes-set! bs (+ i 1) (unsafe-fxand 255 (unsafe-fxrshift n 16))) 61 | (unsafe-bytes-set! bs (+ i 2) (unsafe-fxand 255 (unsafe-fxrshift n 8))) 62 | (unsafe-bytes-set! bs (+ i 3) (unsafe-fxand 255 n)) 63 | ) 64 | 65 | (define (unrolled-unsafe-bytes-nat-set!/5 n size __ ___ bs i) 66 | ;; assume size=5 67 | (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n 32))) 68 | (unsafe-bytes-set! bs (+ i 1) (unsafe-fxand 255 (unsafe-fxrshift n 24))) 69 | (unsafe-bytes-set! bs (+ i 2) (unsafe-fxand 255 (unsafe-fxrshift n 16))) 70 | (unsafe-bytes-set! bs (+ i 3) (unsafe-fxand 255 (unsafe-fxrshift n 8))) 71 | (unsafe-bytes-set! bs (+ i 4) (unsafe-fxand 255 n)) 72 | ) 73 | 74 | (define (unrolled-unsafe-bytes-nat-set!/6 n size __ ___ bs i) 75 | ;; assume size=6 76 | (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n 36))) 77 | (unsafe-bytes-set! bs (+ i 1) (unsafe-fxand 255 (unsafe-fxrshift n 32))) 78 | (unsafe-bytes-set! bs (+ i 2) (unsafe-fxand 255 (unsafe-fxrshift n 24))) 79 | (unsafe-bytes-set! bs (+ i 3) (unsafe-fxand 255 (unsafe-fxrshift n 16))) 80 | (unsafe-bytes-set! bs (+ i 4) (unsafe-fxand 255 (unsafe-fxrshift n 8))) 81 | (unsafe-bytes-set! bs (+ i 5) (unsafe-fxand 255 n)) 82 | ) 83 | 84 | (define (unrolled-unsafe-bytes-nat-set! n size __ ___ bs offset) 85 | (case size 86 | ((1) (unrolled-unsafe-bytes-nat-set!/1 n size __ ___ bs offset)) 87 | ((2) (unsafe-bytes-set! bs offset (unsafe-fxand 255 (unsafe-fxrshift n 8))) 88 | (unsafe-bytes-set! bs (+ offset 1) (unsafe-fxand 255 n))) 89 | ((3) (unrolled-unsafe-bytes-nat-set!/3 n size __ ___ bs offset)) 90 | ((4) (unrolled-unsafe-bytes-nat-set!/4 n size __ ___ bs offset)) 91 | ((5) (unrolled-unsafe-bytes-nat-set!/5 n size __ ___ bs offset)) 92 | ((6) (unrolled-unsafe-bytes-nat-set!/6 n size __ ___ bs offset)) 93 | (else (let loop ((i offset) 94 | ;(shift (unsafe-fx* 8 (unsafe-fx- size 1))) 95 | (shift (unsafe-fxlshift (unsafe-fx- size 1) 3)) 96 | ) 97 | (when (unsafe-fx<= 0 shift) 98 | (unsafe-bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n shift))) 99 | (loop (unsafe-fx+ i 1) 100 | (unsafe-fx- shift 8))))))) 101 | 102 | ;(define (unrolled-unsafe-bytes-nat-set! n size __ ___ bs offset) 103 | ;(case size 104 | ;((1) (unrolled-unsafe-bytes-nat-set!/1 n size __ ___ bs offset)) 105 | ;((2) (unrolled-unsafe-bytes-nat-set!/2 n size __ ___ bs offset)) 106 | ;((3) (unrolled-unsafe-bytes-nat-set!/3 n size __ ___ bs offset)) 107 | ;((4) (unrolled-unsafe-bytes-nat-set!/4 n size __ ___ bs offset)) 108 | ;(else (let loop ((i offset) 109 | ;;(shift (unsafe-fx* 8 (unsafe-fx- size 1))) 110 | ;(shift (unsafe-fxlshift (unsafe-fx- size 1) 3)) 111 | ;) 112 | ;(when (unsafe-fx<= 0 shift) 113 | ;(bytes-set! bs i (unsafe-fxand 255 (unsafe-fxrshift n shift))) 114 | ;(loop (unsafe-fx+ i 1) 115 | ;(unsafe-fx- shift 8))))))) 116 | 117 | ;(define i->ibs integer->integer-bytes) 118 | ;(define i->ibs bytes-nat-set!) 119 | ;(define i->ibs unsafe-bytes-nat-set!) 120 | (define i->ibs unrolled-unsafe-bytes-nat-set!) 121 | 122 | (time 123 | (let repeat ((i 10000000)) 124 | (when (< 0 i) 125 | (let loop ((i (- total width))) 126 | (when (unsafe-fx<= 0 i) 127 | (i->ibs i width #f #f bstr i) 128 | (loop (unsafe-fx- i width)))) 129 | (repeat (unsafe-fx- i 1))))) 130 | 131 | #;(define (unsafe-bytes-byte-width-nat-ref bs width offset) 132 | (let ((end (unsafe-fx+ offset width))) 133 | (let loop ((i offset) (n 0)) 134 | (cond ((unsafe-fx< i end) (loop (unsafe-fx+ i 1) 135 | (unsafe-fx+ (unsafe-fxlshift n 8) 136 | (unsafe-bytes-ref bs i)))) 137 | (else n))))) 138 | 139 | (define (1-unrolled-unsafe-bytes-nat-ref bs i) 140 | (unsafe-bytes-ref bs i)) 141 | (define (2-unrolled-unsafe-bytes-nat-ref bs i) 142 | (unsafe-fx+ (unsafe-fxlshift (unsafe-bytes-ref bs i) 8) 143 | (unsafe-bytes-ref bs (unsafe-fx+ i 1)))) 144 | (define (3-unrolled-unsafe-bytes-nat-ref bs i) 145 | (unsafe-fx+ (unsafe-fxlshift (unsafe-bytes-ref bs i) 16) 146 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 1)) 8) 147 | (unsafe-bytes-ref bs (unsafe-fx+ i 2)))) 148 | (define (4-unrolled-unsafe-bytes-nat-ref bs i) 149 | (unsafe-fx+ (unsafe-fxlshift (unsafe-bytes-ref bs i) 24) 150 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 1)) 16) 151 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 2)) 8) 152 | (unsafe-bytes-ref bs (unsafe-fx+ i 3)))) 153 | (define (5-unrolled-unsafe-bytes-nat-ref bs i) 154 | (unsafe-fx+ (unsafe-fxlshift (unsafe-bytes-ref bs i) 32) 155 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 1)) 24) 156 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 2)) 16) 157 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 3)) 8) 158 | (unsafe-bytes-ref bs (unsafe-fx+ i 4)))) 159 | (define (6-unrolled-unsafe-bytes-nat-ref bs i) 160 | (unsafe-fx+ (unsafe-fxlshift (unsafe-bytes-ref bs i) 40) 161 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 1)) 32) 162 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 2)) 24) 163 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 3)) 16) 164 | (unsafe-fxlshift (unsafe-bytes-ref bs (unsafe-fx+ i 4)) 8) 165 | (unsafe-bytes-ref bs (unsafe-fx+ i 5)))) 166 | 167 | (define (unsafe-bytes-byte-width-nat-ref bs width offset) 168 | (case width 169 | ((1) (1-unrolled-unsafe-bytes-nat-ref bs offset)) 170 | ((2) (2-unrolled-unsafe-bytes-nat-ref bs offset)) 171 | ((3) (3-unrolled-unsafe-bytes-nat-ref bs offset)) 172 | ((4) (4-unrolled-unsafe-bytes-nat-ref bs offset)) 173 | ((5) (5-unrolled-unsafe-bytes-nat-ref bs offset)) 174 | ((6) (6-unrolled-unsafe-bytes-nat-ref bs offset)) 175 | (else (let ((end (unsafe-fx+ offset width))) 176 | (let loop ((i offset) (n 0)) 177 | (cond ((unsafe-fx< i end) (loop (unsafe-fx+ i 1) 178 | (unsafe-fx+ (unsafe-fxlshift n 8) 179 | (unsafe-bytes-ref bs i)))) 180 | (else n))))))) 181 | 182 | (time 183 | (let repeat ((i 10000000)) 184 | (when (< 0 i) 185 | (let loop ((i (- total width))) 186 | (when (unsafe-fx<= 0 i) 187 | (unsafe-vector-set! vec 0 (unsafe-bytes-byte-width-nat-ref bstr width i)) 188 | (loop (unsafe-fx- i width)))) 189 | (repeat (unsafe-fx- i 1))))) 190 | 191 | -------------------------------------------------------------------------------- /test/microbenchmarks/place1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide place-main) 3 | (require "shared.rkt" racket/place) 4 | 5 | (define (place-main c.in) 6 | (displayln "place 1") 7 | (shared-put (+ 1 (shared-get))) 8 | (place-channel-put c.in `(done: ,(shared-get)))) 9 | -------------------------------------------------------------------------------- /test/microbenchmarks/place2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide place-main) 3 | (require racket/place) 4 | 5 | (define (place-main c.in) 6 | (displayln "place 2") 7 | (place-channel-put c.in `(done: ,(cons 'place2 (place-channel-get c.in))))) 8 | -------------------------------------------------------------------------------- /test/microbenchmarks/shared.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide shared-get shared-put) 3 | 4 | (define shared-value 5) 5 | 6 | (define (shared-get) 7 | shared-value) 8 | 9 | (define (shared-put x) 10 | (set! shared-value x)) 11 | -------------------------------------------------------------------------------- /test/old-1/test-dataflow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | "../dbk.rkt" 4 | "../dbk/data.rkt" 5 | "../dbk/enumerator.rkt" 6 | racket/pretty 7 | racket/runtime-path 8 | racket/set) 9 | 10 | (define-relation/table (cprop curie key value) 'path "rtx2/20210204/cprop") 11 | (define-relation/table (edge id subject object) 'path "rtx2/20210204/edge") 12 | (define-relation/table (eprop id key value) 'path "rtx2/20210204/eprop") 13 | 14 | (define (dict-select d key) (d 'ref key (lambda (v) v) (lambda () (error "dict ref failed" key)))) 15 | 16 | (define-runtime-path path.here ".") 17 | 18 | (define db (database (path->string (build-path path.here "rtx-kg2_20210204.db")))) 19 | (define r.cprop (database-relation db '(rtx-kg2 cprop))) 20 | (define r.edge (database-relation db '(rtx-kg2 edge))) 21 | (define r.eprop (database-relation db '(rtx-kg2 eprop))) 22 | 23 | (define preload-index? #f) 24 | (define preload-text? #f) 25 | 26 | (define dict.eprop.eid.value.key (time (relation-index-dict r.eprop '(key value eid) preload-index?))) 27 | (define dict.edge.subject.eid.object (time (relation-index-dict r.edge '(object eid subject) preload-index?))) 28 | (define dict.cprop.value.key.curie (time (relation-index-dict r.cprop '(curie key value) preload-index?))) 29 | (define domain-dicts (time (relation-domain-dicts r.cprop preload-text?))) 30 | (define dict.string=>id (car (hash-ref (car domain-dicts) 'text))) 31 | (define dict.id=>string (car (hash-ref (cdr domain-dicts) 'text))) 32 | 33 | (define (string->id str) (dict-select dict.string=>id str)) 34 | (define (id->string id) (dict-select dict.id=>string id)) 35 | 36 | (define (benchmark-find-treatments curie.target) 37 | (define (run-query yield) 38 | (define curie.nausea.id (string->id curie.target)) 39 | (define ekey.predicate.id (string->id "predicate")) 40 | (define evalue.treats.id (string->id "biolink:treats")) 41 | (define ckey.category.id (string->id "category")) 42 | (define ckey.name.id (string->id "name")) 43 | (define dict.eprop.eid.value (dict-select dict.eprop.eid.value.key ekey.predicate.id)) 44 | (define dict.eprop.eid (dict-select dict.eprop.eid.value evalue.treats.id)) 45 | (define dict.edge.subject.eid (dict-select dict.edge.subject.eid.object curie.nausea.id)) 46 | ((merge-join dict.eprop.eid dict.edge.subject.eid) 47 | (lambda (eid __ dict.edge.subject) 48 | ((merge-join dict.edge.subject dict.cprop.value.key.curie) 49 | (lambda (subject.id __ dict.cprop.value.key) 50 | (define subject (id->string subject.id)) 51 | (define dict.cprop.category (dict-select dict.cprop.value.key ckey.category.id)) 52 | (define dict.cprop.name (dict-select dict.cprop.value.key ckey.name.id)) 53 | ((merge-join dict.cprop.category dict.id=>string) 54 | (lambda (category.id __ category) 55 | ((merge-join dict.cprop.name dict.id=>string) 56 | (lambda (name.id __ name) 57 | (yield (list subject category name))))))))))) 58 | ;; Some nausea timings 59 | ;; cpu time: 1485 real time: 1610 gc time: 19 60 | ;; cpu time: 1539 real time: 1557 gc time: 15 61 | ;; cpu time: 1538 real time: 1556 gc time: 24 62 | (define results.old (time (run* (s cat name) 63 | (fresh (eid) 64 | (edge eid s curie.target) 65 | (cprop s "category" cat) 66 | (cprop s "name" name) 67 | (eprop eid "predicate" "biolink:treats"))))) 68 | ;; Some nausea timings 69 | ;; cpu time: 27 real time: 27 gc time: 0 70 | ;; cpu time: 31 real time: 31 gc time: 0 71 | ;; cpu time: 30 real time: 31 gc time: 0 72 | (define results.new (time (enumerator->rlist run-query))) 73 | ;; 149 results 74 | (pretty-write `(old: ,(length results.old) ,results.old)) 75 | (pretty-write `(new: ,(length results.new) ,results.new)) 76 | (pretty-write `(equal?: ,(equal? (list->set results.old) (list->set results.new))))) 77 | -------------------------------------------------------------------------------- /test/old-1/test-ingest-example-simple.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../dbk/io.rkt" 3 | "../dbk/data.rkt" 4 | "../dbk/stream.rkt" 5 | racket/runtime-path) 6 | 7 | (define-runtime-path path.here ".") 8 | 9 | (define db (database (build-path path.here "example-db"))) 10 | 11 | (unless (database-relation-has? db '(example cprop)) 12 | (database-relation-add! 13 | db '(example cprop) 14 | 'attributes '(curie key value) 15 | 'type '(string string string) 16 | 'source (in:file "example/example.nodeprop.tsv" 'header '(":ID" "propname" "value")))) 17 | 18 | (unless (database-relation-has? db '(example edge)) 19 | (database-relation-add! 20 | db '(example edge) 21 | 'attributes '(eid subject object) 22 | 'type '(nat string string) 23 | 'source (s-map (lambda (row) (cons (string->number (car row)) (cdr row))) 24 | (in:file "example/example.edge.tsv" 'header '(":ID" ":START" ":END"))))) 25 | 26 | (unless (database-relation-has? db '(example eprop)) 27 | (database-relation-add! 28 | db '(example eprop) 29 | 'attributes '(eid key value) 30 | 'type '(nat string string) 31 | 'source (s-map (lambda (row) (cons (string->number (car row)) (cdr row))) 32 | (in:file "example/example.edgeprop.tsv" 'header '(":ID" "propname" "value"))))) 33 | 34 | (define cprop (database-relation db '(example cprop))) 35 | (define edge (database-relation db '(example edge))) 36 | (define eprop (database-relation db '(example eprop))) 37 | 38 | (database-compact! db) 39 | 40 | (relation-index-add! cprop 41 | '(curie key) 42 | '(key value)) 43 | (relation-index-add! edge 44 | '(eid) 45 | '(subject object) 46 | '(subject eid) 47 | '(object eid)) 48 | (relation-index-add! eprop 49 | '(eid key) 50 | '(key value)) 51 | -------------------------------------------------------------------------------- /test/old-1/test-ingest-example.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../dbk/io.rkt" 3 | racket/match) 4 | 5 | ;; TODO: require these 6 | (define file-checksum #f) 7 | (define-syntax-rule (run* body ...) '(TODO: run* body ...)) 8 | (define database #f) 9 | (define database-relation #f) 10 | (define database-update! #f) 11 | (define database-checkpoint! #f) 12 | (define database-index-build! #f) 13 | (define database-compact! #f) 14 | (define relation-database #f) 15 | (define relation-name #f) 16 | (define relation-insert #f) 17 | (define relation-index-add! #f) 18 | (define relation-index-remove! #f) 19 | (define relation-index-build! #f) 20 | 21 | (define db (database "path/to/example/db" 22 | 'immediate-checkpoint? #f 23 | 'immediate-index-build? #f 24 | 'immediate-compact? #f)) 25 | 26 | (define update-history (database-relation 27 | db 28 | 'name 'update-history 29 | 'attributes '(relation-name update-time update-kind file-name file-size file-checksum) 30 | 'type '(#f nat #f string nat string))) 31 | (database-checkpoint! db) 32 | 33 | (define cprop (database-relation 34 | db '(example cprop) 35 | 'attributes '(curie key value) 36 | 'type '(string string string))) 37 | (define eprop (database-relation 38 | db '(example eprop) 39 | 'attributes '(eid key value) 40 | 'type '(nat string string))) 41 | (define edge (database-relation 42 | db '(example edge) 43 | 'attributes '(eid subject object) 44 | 'type '(nat string string))) 45 | (relation-index-add! cprop 46 | '(curie key) 47 | '(key value)) 48 | (relation-index-add! eprop 49 | '(eid key) 50 | '(key value)) 51 | (relation-index-add! edge 52 | '(eid) 53 | '(subject object) 54 | '(object subject)) 55 | (database-checkpoint! db) 56 | 57 | (define (relation-ingest! R path.dir file-name file-params) 58 | (define name.R (relation-name R)) 59 | (define path.file (build-path path.dir file-name)) 60 | (define checksum.file (file-checksum path.file)) 61 | (define size.file (file-size path.file)) 62 | (define file-ingest-history (run* (timestamp size checksum) 63 | (update-history name.R timestamp 'ingest file-name size checksum))) 64 | (if (null? file-ingest-history) 65 | (begin (database-update! 66 | (relation-database R) 67 | (relation-insert update-history (list (list name.R (current-milliseconds) 68 | 'ingest file-name size.file checksum.file))) 69 | (relation-insert R (apply in:file path.file file-params))) 70 | (database-checkpoint! db)) 71 | (unless (ormap (lambda (entry) (match entry 72 | ((list timestamp size checksum) (and (equal? size size.file) 73 | (equal? checksum checksum.file))) 74 | (_ #f))) 75 | file-ingest-history) 76 | (error "inconsistent data ingestion history:" 77 | 'relation-name name.R 78 | 'file-name file-name 79 | 'file-size size.file 80 | 'file-checksum checksum.file 81 | 'history file-ingest-history)))) 82 | 83 | (relation-ingest! cprop "example" "example.nodeprop.tsv" 'header '(":ID" "propname" "value")) 84 | (relation-ingest! eprop "example" "example.edgeprop.tsv" 'header '(":ID" "propname" "value")) 85 | (relation-ingest! edge "example" "example.edge.tsv" 'header '(":ID" ":START" ":END")) 86 | 87 | (database-index-build! db) 88 | (database-compact! db) 89 | -------------------------------------------------------------------------------- /test/old-2/test-database-small.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../dbk/database.rkt" 3 | racket/list racket/pretty racket/runtime-path) 4 | 5 | (define-runtime-path path.here ".") 6 | (define db (database (build-path path.here "small"))) 7 | (auto-empty-trash? #t) 8 | 9 | (define (build-list-relation db type tuples) 10 | (let-values (((insert! finish) (database-relation-builder db type))) 11 | (time (for-each insert! tuples)) 12 | (time (finish)))) 13 | 14 | ;; (- R R) etc. 15 | 16 | (define specs `((main . ,(map list (range 500))) 17 | (lower . ,(map list (range 200))) 18 | (middle . ,(map list (range 200 300))) 19 | (upper . ,(map list (range 300 500))))) 20 | 21 | (for-each (lambda (spec) 22 | (let ((name (car spec)) 23 | (tuples (cdr spec))) 24 | (unless (database-relation-name? db name) 25 | (let ((R (build-list-relation db '(int) tuples))) 26 | (relation-name-set! R name) 27 | (relation-attributes-set! R '(value)) 28 | (database-commit! db))))) 29 | specs) 30 | 31 | (unless (database-relation-name? db 'gone) 32 | (let ((R.gone (database-relation-new db '(int))) 33 | (R.main (database-relation db 'main)) 34 | (R.lower (database-relation db 'lower)) 35 | (R.middle (database-relation db 'middle)) 36 | (R.upper (database-relation db 'upper))) 37 | (relation-assign! R.gone (R- R.main R.main)) 38 | ;(relation-assign! R.gone (R+ R.upper R.lower)) 39 | ;(relation-assign! R.gone (R- (R- R.main R.lower) R.upper)) 40 | ;(relation-assign! R.gone (R- R.main (R+ R.lower R.upper))) 41 | ;(relation-assign! R.gone (R- (R- (R- R.main R.lower) R.upper) R.middle)) 42 | ;(relation-assign! R.gone (R- (R- R.main (R+ R.lower R.upper)) R.middle)) 43 | (relation-name-set! R.gone 'gone) 44 | (database-commit! db))) 45 | 46 | ;(relation-full-compact! (database-relation db 'gone)) 47 | (database-commit! db) 48 | -------------------------------------------------------------------------------- /test/old-2/test-storage.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../dbk/storage.rkt" 3 | racket/pretty 4 | racket/runtime-path) 5 | 6 | (define-runtime-path path.here ".") 7 | 8 | (define stg (storage:filesystem (build-path path.here "example-storage"))) 9 | ;(define stg2 (storage:filesystem (build-path path.here "example-storage"))) 10 | 11 | (storage-block-remove-names! stg '(testing 2) '(new 1) '(new 2.1) '(new 2.2)) 12 | 13 | (storage-checkpoint! stg) 14 | 15 | (pretty-write (storage-description-keys stg)) 16 | (pretty-write (storage-block-names stg)) 17 | 18 | ;(define (sset! . kvs) (apply storage-description-set! stg kvs)) 19 | ;(define (sref . ks) (map cons ks (map (lambda (k) (storage-description-ref stg k)) ks))) 20 | 21 | ;(define out.1 (storage-block-new! stg '(testing 1))) 22 | ;(pretty-write (equal? out.1 (storage-block-out stg '(testing 1)))) 23 | 24 | (storage-block-new! stg '(testing 2)) 25 | 26 | (call-with-output-file 27 | (storage-block-new! stg '(testing 1)) 28 | (lambda (out) (write-string "this is testing 1" out))) 29 | (call-with-output-file 30 | (storage-block-path stg '(testing 2)) 31 | (lambda (out) (write-string "this is testing 2" out))) 32 | 33 | (pretty-write (storage-block-path stg '(testing 2))) 34 | 35 | (storage-block-rename! stg '(testing 1) '(new 1)) 36 | (storage-block-add-names! stg '(testing 2) '(new 2.1) '(new 2.2)) 37 | 38 | (storage-checkpoint! stg) 39 | 40 | (pretty-write (storage-description-keys stg)) 41 | (pretty-write (storage-block-names stg)) 42 | (pretty-write (map (lambda (name) (storage-block-path stg name)) (storage-block-names stg))) 43 | 44 | (pretty-write `(in.1: ,(call-with-input-file (storage-block-path stg '(new 1)) read-line))) 45 | (pretty-write `(in.2: ,(call-with-input-file (storage-block-path stg '(testing 2)) read-line))) 46 | (pretty-write `(in.2.1: ,(call-with-input-file (storage-block-path stg '(new 2.1)) read-line))) 47 | (pretty-write `(in.2.2: ,(call-with-input-file (storage-block-path stg '(new 2.2)) read-line))) 48 | 49 | (storage-block-remove-names! stg '(testing 2) '(new 1) '(new 2.1) '(new 2.2)) 50 | 51 | (storage-revert! stg) 52 | (storage-checkpoint! stg) 53 | 54 | ;(sset! 'hello 1 'world! 2) 55 | 56 | ;(storage-checkpoint! stg) 57 | ;(storage-revert! stg) 58 | ;(pretty-write (storage-checkpoint-count stg)) 59 | ;(pretty-write (sref 'hello 'world!)) 60 | 61 | ;(sset! 'hello 1 'world! 2) 62 | 63 | ;(storage-checkpoint! stg) 64 | ;(storage-revert! stg) 65 | ;(pretty-write (storage-checkpoint-count stg)) 66 | ;(pretty-write (sref 'hello 'world!)) 67 | 68 | ;(sset! 'hello 5 'world! 2) 69 | 70 | ;(storage-revert! stg) 71 | ;(storage-checkpoint! stg) 72 | ;(pretty-write (storage-checkpoint-count stg)) 73 | ;(pretty-write (sref 'hello 'world!)) 74 | 75 | ;(sset! 'hello 5 'world! 2) 76 | 77 | ;(storage-checkpoint! stg) 78 | ;(storage-revert! stg) 79 | ;(pretty-write (storage-checkpoint-count stg)) 80 | ;(pretty-write (sref 'hello 'world!)) 81 | 82 | (storage-trash-empty! stg) 83 | -------------------------------------------------------------------------------- /test/test-equivalence-database.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "equivalence-database.rkt" "../dbk/database.rkt" "../dbk/enumerator.rkt" 3 | racket/pretty racket/runtime-path) 4 | 5 | (define name.equiv-edge 'equivalence-edge) 6 | (define name.equiv-class-member 'equivalence-class-member) 7 | 8 | (define-runtime-path path.here ".") 9 | 10 | (define db.equiv 11 | (build-equivalence-database 12 | (build-path path.here "test-equivalence.db") 13 | (list->enumerator 14 | '((#"A" #"B") 15 | (#"C" #"D") 16 | (#"C" #"H") 17 | (#"B" #"F") 18 | (#"E" #"G") 19 | (#"G" #"H") 20 | (#"L" #"M") 21 | (#"M" #"O") 22 | (#"N" #"O") 23 | (#"F" #"O"))))) 24 | 25 | (define r.equiv-class-member (database-relation db.equiv name.equiv-class-member)) 26 | 27 | (define-values (text=>id id=>text) (relation-text-dicts r.equiv-class-member #f)) 28 | (define (text->id text) (dict-ref text=>id text (lambda (v) v) 29 | (lambda () (error "invalid text" text)))) 30 | (define (id->text id) (dict-ref id=>text id (lambda (v) v) 31 | (lambda () (error "invalid text id" id)))) 32 | 33 | (define rep=>member=>1 (relation-index-dict r.equiv-class-member '(representative member) #f)) 34 | 35 | ((dict-enumerator rep=>member=>1) 36 | (lambda (id.rep member=>1) 37 | (pretty-write `(representative: ,(id->text id.rep))) 38 | ((dict-key-enumerator member=>1) 39 | (lambda (id.member) 40 | (pretty-write `(member: ,(id->text id.member))))) 41 | (newline))) 42 | --------------------------------------------------------------------------------