├── lattice ├── list.scm ├── test.scm ├── test-all.scm ├── test-dict.scm ├── test-eq-linear.scm ├── ordered-set.scm ├── discrete-set.scm ├── dict.scm ├── directed-graph.scm ├── order.scm ├── test-array-mapped-trie.scm ├── test-directed-graph.scm ├── eq-linear.scm ├── array-mapped-trie.scm ├── test-discrete-set.scm ├── algebra.scm ├── real-set.scm └── test-real-set.scm ├── scratch ├── integer-partition.scm └── lch-soon.scm ├── LICENSE ├── README.md ├── interact.scm ├── test-transparent.scm ├── snapshots.scm ├── training-data.scm ├── transparent-evalo-transform.scm ├── transparent-evalo.scm ├── chr.scm ├── lch.scm ├── dkanren-simple-interp.rkt ├── generate.scm ├── dkanren-benchmarks ├── benchmarks.rkt └── raw.rkt ├── core.scm ├── dkanren-arithmetic.rkt ├── dkanren-interp.rkt └── transparent.scm /lattice/list.scm: -------------------------------------------------------------------------------- 1 | (define (list-foldl f acc xs) 2 | (if (null? xs) 3 | acc 4 | (list-foldl f (f (car xs) acc) (cdr xs)))) 5 | (define (list-foldr f acc xs) 6 | (if (null? xs) 7 | acc 8 | (f (car xs) (list-foldr f acc (cdr xs))))) 9 | (define (list-append-map f xs) 10 | (list-foldr append '() (map f xs))) 11 | 12 | (define (list-last xs) (if (null? (cdr xs)) (car xs) (list-last (cdr xs)))) 13 | -------------------------------------------------------------------------------- /lattice/test.scm: -------------------------------------------------------------------------------- 1 | (define-syntax test 2 | (syntax-rules () 3 | ((_ name expr expected-expr) 4 | (begin 5 | (printf "Testing ~s: " name) 6 | (let* ((expected expected-expr) (actual expr)) 7 | (if (equal? expected actual) 8 | (printf "Succeeded.\n") 9 | (printf "\nFailed: ~a\nExpected: ~a\nActual: ~a\n" 10 | 'expr expected actual))))))) 11 | -------------------------------------------------------------------------------- /lattice/test-all.scm: -------------------------------------------------------------------------------- 1 | (printf "\nTesting real-set\n") 2 | (load "test-real-set.scm") 3 | 4 | (printf "\nTesting discrete-set\n") 5 | (load "test-discrete-set.scm") 6 | 7 | (printf "\nTesting dict\n") 8 | (load "test-dict.scm") 9 | 10 | (printf "\nTesting array mapped trie\n") 11 | (load "test-array-mapped-trie.scm") 12 | 13 | (printf "\nTesting directed graphs\n") 14 | (load "test-directed-graph.scm") 15 | 16 | (printf "\nTesting linear equations\n") 17 | (load "test-eq-linear.scm") 18 | -------------------------------------------------------------------------------- /scratch/integer-partition.scm: -------------------------------------------------------------------------------- 1 | ;; M[n, k] = min{i from 1 to n} max(M[i, k - 1], sum(s_j for j from i+1 to n) 2 | ;; M[1, k] = s1, for all k > 0 3 | ;; M[n, 1] = sum(s_i for i from 1 to n) 4 | 5 | (define-syntax iter 6 | (syntax-rules () 7 | ((_ i start end expr) 8 | (map (lambda (i) expr) (range start (+ end 1)))))) 9 | 10 | (define (min* ns) (apply min ns)) 11 | (define (sum n*) (foldl + 0 n*)) 12 | 13 | (define (M n k s*) 14 | (cond ((= 1 n) (car s*)) 15 | ((= 1 k) (sum (take s* n))) 16 | (else (min* (iter i 1 n (max (M i (- k 1) s*) (sum (drop (take s* n) i)))))))) 17 | 18 | (define (integer-partition k s*) (M (length s*) k s*)) 19 | 20 | (displayln (integer-partition 3 '(100 200 300 400 500 600 700 800 900))) 21 | -------------------------------------------------------------------------------- /lattice/test-dict.scm: -------------------------------------------------------------------------------- 1 | (load "test.scm") 2 | (load "dict.scm") 3 | 4 | (define d1 (dict '((a . 1) (5 . 10) (c . 2) (b . 3)))) 5 | (define d2 (dict '((a . 2) (5 . 10) (d . ok) (c . 4)))) 6 | 7 | (define (add-values k x y) (+ x y)) 8 | 9 | (test 'dict-1 10 | d1 11 | '((a . 1) (b . 3) (c . 2) (5 . 10))) 12 | (test 'dict-2 13 | d2 14 | '((a . 2) (c . 4) (d . ok) (5 . 10))) 15 | 16 | (test 'dict-join-1 17 | (dict-join id-value id-value #f dict-empty d1) 18 | d1) 19 | (test 'dict-join-2 20 | (dict-join id-value id-value #f d1 dict-empty) 21 | d1) 22 | (test 'dict-join-3 23 | (dict-join id-value id-value add-values d1 d2) 24 | '((a . 3) (b . 3) (c . 6) (d . ok) (5 . 20))) 25 | 26 | (test 'dict-meet-1 27 | (dict-meet add-values dict-empty d1) 28 | dict-empty) 29 | (test 'dict-meet-2 30 | (dict-meet add-values d1 dict-empty) 31 | dict-empty) 32 | (test 'dict-meet-3 33 | (dict-meet add-values d1 d2) 34 | '((a . 3) (c . 6) (5 . 20))) 35 | 36 | (test 'dict-subtract-1 37 | (dict-subtract d1 '(c 5)) 38 | '((a . 1) (b . 3))) 39 | 40 | (test 'dict-project-1 41 | (dict-project d1 '(c 5)) 42 | '((c . 2) (5 . 10))) 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2017 Gregory L. 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # dKanren 2 | 3 | The purpose of dKanren is to support a model of programming that is as declarative as possible, and that can also be used for logical inference. The current version provides logic programming with symbolic constraints using a first order functional language syntax. Future versions will also provide access to lower level primitives and the scheduler for more direct control. The constraint system is designed to be extensible, to allow plugging in domain-specific solvers. 4 | 5 | 6 | ## Constraint satisfaction 7 | 8 | * symbolic constraints 9 | * numeric constraints and solving 10 | * foundation based on lattices for extensibility 11 | * support for true negation and universal quantification 12 | 13 | 14 | ## Scheduling 15 | 16 | * delayed goals and lazy constraints 17 | * eager following of deterministic paths 18 | * demand-based guess ordering 19 | 20 | 21 | ## Functional logic programming 22 | 23 | * dk-evalo 24 | * implicit pattern negation 25 | 26 | 27 | ## Caveat 28 | 29 | This is still an early work in progress. For now, you'll probably be more interested in miniKanren and Barliman: 30 | 31 | https://github.com/michaelballantyne/faster-miniKanren 32 | 33 | https://github.com/webyrd/Barliman 34 | -------------------------------------------------------------------------------- /interact.scm: -------------------------------------------------------------------------------- 1 | (load "transparent-evalo-transform.scm") 2 | 3 | (define (in) 4 | (define request (read)) 5 | (cond 6 | ((or (eq? 'good-path request) 7 | (eq? 'steps-remaining request) 8 | (and (pair? request) 9 | (eq? 'jump-to-steps-remaining (car request)))) 10 | request) 11 | ((pair? request) 12 | (map (lambda (n) 13 | (cond 14 | ((= 0 n) #t) 15 | ((= 1 n) #f) 16 | (else (error 'in (format "invalid path segment ~s" n))))) 17 | request)) 18 | (else (error 'in (format "unexpected request: ~s" request))))) 19 | 20 | (define (show ss) (printf "~s\n" (cadr (stream-pretty ss)))) 21 | 22 | (define (out response) 23 | (define (bool->bit b) (if b 0 1)) 24 | (define (bools->bits bs) (map bool->bit bs)) 25 | (define output 26 | (cond 27 | ((eq? 'good-path (car response)) (bools->bits (cadr response))) 28 | ((eq? 'follow-path (car response)) (cadr response)) 29 | ((eq? 'steps-remaining (car response)) (map bools->bits (cadr response))) 30 | (else (error 'out (format "unrecognized output: ~s" response))))) 31 | (printf "~s\n" output)) 32 | 33 | (define (read-query/hint) (eval (read))) 34 | 35 | (define ss/hint (read-query/hint)) 36 | (define hint (car ss/hint)) 37 | (define ss (cadr ss/hint)) 38 | 39 | (interact in show out hint (prune #t ss) #f #t) 40 | -------------------------------------------------------------------------------- /lattice/test-eq-linear.scm: -------------------------------------------------------------------------------- 1 | (load "test.scm") 2 | (load "eq-linear.scm") 3 | 4 | ;; v + w = 10 5 | (define e1 (eq-sparse->dense '((0 . 1) (1 . 1) . 10))) 6 | ;; x + y + z = 4 7 | (define e2 (eq-sparse->dense '((2 . 1) (3 . 1) (4 . 1) . 4))) 8 | ;; w + z = 8 9 | (define e3 (eq-sparse->dense '((1 . 1) (4 . 1) . 8))) 10 | ;; 3x + 3y = 6 11 | (define e4 (eq-sparse->dense '((2 . 3) (3 . 3) . 6))) 12 | 13 | (define n1 (eqs-linear-add eqs-empty e1)) 14 | (define eqs1 (eqs-next-eqs n1)) 15 | (define n2 (eqs-linear-add eqs1 e2)) 16 | (define eqs2 (eqs-next-eqs n2)) 17 | (define n3 (eqs-linear-add eqs2 e3)) 18 | (define eqs3 (eqs-next-eqs n3)) 19 | (define n4 (eqs-linear-add eqs3 e4)) 20 | (define eqs4 (eqs-next-eqs n4)) 21 | 22 | (test 'solved-1 23 | (eqs-next-solved n1) 24 | '()) 25 | (test 'solved-2 26 | (eqs-next-solved n2) 27 | '()) 28 | (test 'solved-3 29 | (eqs-next-solved n3) 30 | '()) 31 | (test 'solved-4 32 | (eqs-next-solved n4) 33 | '((0 . 4) (1 . 6) (4 . 2))) ;; v = 4, w = 6, z = 2 34 | 35 | (test 'next-eqs-1 36 | (length eqs1) 37 | 1) 38 | (test 'next-eqs-2 39 | (length eqs2) 40 | 2) 41 | (test 'next-eqs-3 42 | (length eqs3) 43 | 3) 44 | (test 'next-eqs-4 45 | (length eqs4) 46 | 1) ;; x and y are still-unknown 47 | 48 | (test 'next-eqs-size-1 49 | (map eq-size eqs1) 50 | '(2)) 51 | (test 'next-eqs-size-2 52 | (map eq-size eqs2) 53 | '(5 5)) 54 | (test 'next-eqs-size-3 55 | (map eq-size eqs3) 56 | '(5 5 5)) 57 | (test 'next-eqs-size-4 58 | (map eq-size eqs4) 59 | '(2)) ;; x and y are still-unknown 60 | -------------------------------------------------------------------------------- /lattice/ordered-set.scm: -------------------------------------------------------------------------------- 1 | (load "list.scm") 2 | (load "order.scm") 3 | 4 | (define (ordered-set-join xs ys) 5 | (if (null? xs) ys 6 | (if (null? ys) xs 7 | ((any-compare 8 | (car xs) (car ys) 9 | (lambda () (cons (car xs) (ordered-set-join (cdr xs) ys))) 10 | (lambda () (cons (car xs) (ordered-set-join (cdr xs) (cdr ys)))) 11 | (lambda () (cons (car ys) (ordered-set-join xs (cdr ys))))))))) 12 | (define (ordered-set-meet xs ys) 13 | (if (null? xs) '() 14 | (if (null? ys) '() 15 | ((any-compare 16 | (car xs) (car ys) 17 | (lambda () (ordered-set-meet (cdr xs) ys)) 18 | (lambda () (cons (car xs) (ordered-set-meet (cdr xs) (cdr ys)))) 19 | (lambda () (ordered-set-meet xs (cdr ys)))))))) 20 | (define (ordered-set-subtract xs ys) 21 | (if (null? xs) '() 22 | (if (null? ys) xs 23 | ((any-compare 24 | (car xs) (car ys) 25 | (lambda () (cons (car xs) (ordered-set-subtract (cdr xs) ys))) 26 | (lambda () (ordered-set-subtract (cdr xs) (cdr ys))) 27 | (lambda () (ordered-set-subtract xs (cdr ys)))))))) 28 | 29 | (define ordered-set-empty '()) 30 | (define (ordered-set xs) (merge-sort ordered-set-join xs)) 31 | (define (ordered-set-singleton x) (list x)) 32 | 33 | (define (ordered-set-<= xs ys) (null? (ordered-set-subtract xs ys))) 34 | (define (ordered-set-member? xs y) 35 | (ordered-set-<= (ordered-set-singleton y) xs)) 36 | (define (ordered-set-map f xs) (ordered-set (map f xs))) 37 | (define (ordered-set-join-map f xs) (ordered-set (list-append-map f xs))) 38 | -------------------------------------------------------------------------------- /test-transparent.scm: -------------------------------------------------------------------------------- 1 | (load "transparent-evalo.scm") 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | ((_ name expr expected-expr) 6 | (begin 7 | (printf "Testing ~s: " name) 8 | (let* ((expected expected-expr) (actual expr)) 9 | (if (equal? expected actual) 10 | (printf "Succeeded.\n") 11 | (printf "\nFailed: ~a\nExpected: ~a\nActual: ~a\n" 12 | 'expr expected actual))))))) 13 | 14 | (define-relation (appendo l s ls) 15 | (conde 16 | ((== '() l) (== s ls)) 17 | ((fresh (a d res) 18 | (== `(,a . ,d) l) 19 | (== `(,a . ,res) ls) 20 | (appendo d s res))))) 21 | 22 | (test 'appendo-1 23 | (run* (q) (appendo '(a b c) '(d e) q)) 24 | '(((a b c d e)))) 25 | (test 'appendo-2 26 | (run* (q) (appendo '(a b c) q '(a b c d e))) 27 | '(((d e)))) 28 | (test 'appendo-3 29 | (run* (q) (appendo q '(d e) '(a b c d e))) 30 | '(((a b c)))) 31 | (test 'appendo-4 32 | (run* (p q) (appendo p q '(a b c d e))) 33 | '((() (a b c d e)) 34 | ((a) (b c d e)) 35 | ((a b) (c d e)) 36 | ((a b c) (d e)) 37 | ((a b c d) (e)) 38 | ((a b c d e) ()))) 39 | 40 | 41 | (time (test 'evalo-1 42 | (run 1 (q) (evalo q q)) 43 | '(((app 44 | (lambda (list 'app (var ()) (list 'quote (var ())))) 45 | '(lambda (list 'app (var ()) (list 'quote (var ()))))))))) 46 | (time (test 'evalo-step-1 47 | (car (stream-pretty (step 11811 (query (q) (evalo q q))))) 48 | '())) 49 | (time (test 'evalo-step-2 50 | (car (stream-pretty (step 11813 (query (q) (evalo q q))))) 51 | '(((app 52 | (lambda (list 'app (var ()) (list 'quote (var ())))) 53 | '(lambda (list 'app (var ()) (list 'quote (var ()))))))))) 54 | -------------------------------------------------------------------------------- /lattice/discrete-set.scm: -------------------------------------------------------------------------------- 1 | (load "ordered-set.scm") 2 | 3 | ;; A discrete-set may contain: 4 | ;; vectors, pairs, symbols, strings, numbers, booleans, the empty list 5 | ;; For efficiency, we define a total order over these types. Due to the lack of 6 | ;; a portable symbolidx b) (if b 0 1)) 28 | (let loop ((choices (labeled-pretty (labeled-solution* q)))) 29 | (when (pair? choices) 30 | (printf "(~s ~s)\n" (map boolean->idx (caar choices)) (cadar choices)) 31 | (loop (cdr choices))))) 32 | 33 | (define (print-labeled-solution*-hint q-hint q) 34 | (define (boolean->idx b) (if b 0 1)) 35 | (let loop ((choices (labeled-pretty (labeled-solution*-hint q-hint q)))) 36 | (when (pair? choices) 37 | (printf "(~s ~s)\n" (map boolean->idx (caar choices)) (cadar choices)) 38 | (loop (cdr choices))))) 39 | 40 | ;(print-labeled-solution* (q-np 1)) 41 | 42 | ;(print-labeled-solution q-quine) 43 | 44 | 45 | ;; list manipulation examples 46 | 47 | ;; 22 steps 48 | (print-labeled-solution* (q-transform (lambda (x) `(,@x ,@x)) '((a) (b)))) 49 | 50 | ;; 34 steps (takes a moment to synthesize) 51 | ;(print-labeled-solution* (q-transform (lambda (x) `(,@x 3 ,@x)) '((a) (b)))) 52 | 53 | ;; 26 steps 54 | ;(print-labeled-solution*-hint 55 | ;(q-transform-hint 56 | ;(lambda (x) (cons (car x) (cddr x))) 57 | ;'((a b c) (d e f)) 58 | ;'(lambda (cons (car (var ())) (cdr (cdr (var ())))))) 59 | ;(q-transform 60 | ;(lambda (x) (cons (car x) (cddr x))) 61 | ;'((a b c) (d e f)))) 62 | -------------------------------------------------------------------------------- /lattice/dict.scm: -------------------------------------------------------------------------------- 1 | (load "order.scm") 2 | 3 | (define (dict-join fx fy fxy xs ys) 4 | (if (null? xs) ys 5 | (if (null? ys) xs 6 | ((any-compare 7 | (caar xs) (caar ys) 8 | (lambda () (cons (cons (caar xs) (fx (caar xs) (cdar xs))) 9 | (dict-join fx fy fxy (cdr xs) ys))) 10 | (lambda () (cons (cons (caar xs) (fxy (caar xs) (cdar xs) (cdar ys))) 11 | (dict-join fx fy fxy (cdr xs) (cdr ys)))) 12 | (lambda () (cons (cons (caar ys) (fy (caar ys) (cdar ys))) 13 | (dict-join fx fy fxy xs (cdr ys))))))))) 14 | (define (dict-meet fxy xs ys) 15 | (if (null? xs) '() 16 | (if (null? ys) '() 17 | ((any-compare 18 | (caar xs) (caar ys) 19 | (lambda () (dict-meet fxy (cdr xs) ys)) 20 | (lambda () (cons (cons (caar xs) (fxy (caar xs) (cdar xs) (cdar ys))) 21 | (dict-meet fxy (cdr xs) (cdr ys)))) 22 | (lambda () (dict-meet fxy xs (cdr ys)))))))) 23 | (define (dict-subtract xs ys) ;; ys is an ordered-set 24 | (if (null? xs) '() 25 | (if (null? ys) xs 26 | ((any-compare 27 | (caar xs) (car ys) 28 | (lambda () (cons (car xs) (dict-subtract (cdr xs) ys))) 29 | (lambda () (dict-subtract (cdr xs) (cdr ys))) 30 | (lambda () (dict-subtract xs (cdr ys)))))))) 31 | (define (dict-project xs ys) ;; ys is an ordered-set 32 | (define (id-left k x y) x) 33 | (dict-meet id-left xs (map (lambda (k) (cons k #f)) ys))) 34 | 35 | (define (dict-filter f xs) 36 | (cond 37 | ((null? xs) '()) 38 | ((f (cdar xs)) (cons (car xs) (dict-filter f (cdr xs)))) 39 | (else (dict-filter f (cdr xs))))) 40 | (define (dict-map f xs) 41 | (map (lambda (kv) (cons (car kv) (f (cdr kv)))) xs)) 42 | 43 | (define (assoc->dict fx fy fxy xs) 44 | (merge-sort (lambda (a b) (dict-join fx fy fxy a b)) xs)) 45 | 46 | (define (id-value k x) x) 47 | (define (id-value-old k x y) x) 48 | (define (id-value-new k x y) y) 49 | 50 | (define dict-empty '()) 51 | (define (dict xs) 52 | (define (error-not-unique k x y) 53 | (error 'dict 54 | (format "dict given multiple values for the same key: ~s ~s ~s" 55 | k x y))) 56 | (assoc->dict id-value id-value error-not-unique xs)) 57 | 58 | (define (dict-remove xs k) (dict-subtract xs (ordered-set-singleton k))) 59 | (define (dict-set xs k v) 60 | (dict-join id-value id-value id-value-new xs (dict `((,k . ,v))))) 61 | -------------------------------------------------------------------------------- /lattice/directed-graph.scm: -------------------------------------------------------------------------------- 1 | (load "dict.scm") 2 | (load "ordered-set.scm") 3 | 4 | (define dg-empty dict-empty) 5 | 6 | (define (dg-add dg a b) 7 | (define (merge k xs ys) (ordered-set-join xs ys)) 8 | (dict-join id-value id-value merge dg (dict `((,a . (,b)))))) 9 | 10 | (define (dg-remove dg a b) 11 | (define succ (dg-succ dg a)) 12 | (if (ordered-set-member? succ b) 13 | (let ((succ (ordered-set-subtract succ (ordered-set-singleton b)))) 14 | (if (null? succ) (dict-remove dg a) (dict-set dg a succ))) 15 | dg)) 16 | 17 | (define (dg-add-simplify dg a b) 18 | (if (ordered-set-member? (dg-succ* dg a) b) dg 19 | (let* ((pred (dg-pred* dg a)) 20 | (succ (ordered-set-join (dg-succ* dg b) (ordered-set-singleton b))) 21 | (pdg (dict-project dg pred)) 22 | (pdg (dict-map (lambda (xs) (ordered-set-subtract xs succ)) pdg)) 23 | (dg (dict-join id-value id-value id-value-new dg pdg)) 24 | (dg (dict-filter pair? dg))) 25 | (dg-add dg a b)))) 26 | 27 | (define (dg-replace dg xs y) 28 | (define (replace vs) 29 | (if (ormap (lambda (x) (ordered-set-member? vs x)) xs) 30 | (ordered-set-join (ordered-set-subtract vs xs) 31 | (ordered-set-singleton y)) 32 | vs)) 33 | (define succ (ordered-set-subtract 34 | (ordered-set-join-map cdr (dict-project dg xs)) xs)) 35 | (define removed (dict-subtract dg xs)) 36 | (dict-set (dict-map replace removed) y succ)) 37 | 38 | (define (dg-succ dg x) 39 | (define proj (dict-project dg (list x))) 40 | (if (null? proj) '() (cdar proj))) 41 | 42 | (define (dg-pred dg x) 43 | (map car (dict-filter (lambda (xs) (ordered-set-member? xs x)) dg))) 44 | 45 | (define (dg-tc dg r x) 46 | (define immediate (r dg x)) 47 | (if (null? immediate) '() 48 | (ordered-set-join 49 | immediate (ordered-set-join-map 50 | (lambda (y) (dg-tc dg r y)) immediate)))) 51 | 52 | (define (dg-succ* dg x) (dg-tc dg dg-succ x)) 53 | (define (dg-pred* dg x) (dg-tc dg dg-pred x)) 54 | 55 | (define (dg-scc dg a b) 56 | (if (equal? a b) (ordered-set-singleton b) 57 | (let ((scc (ordered-set-join-map (lambda (y) (dg-scc dg a y)) 58 | (dg-succ dg b)))) 59 | (if (null? scc) '() (ordered-set-join scc (ordered-set-singleton b)))))) 60 | 61 | (define (dg-transitive-add dg a b) 62 | (define scc (dg-scc dg a b)) 63 | (if (null? scc) (cons #f (dg-add-simplify dg a b)) 64 | (let ((proxy (any-min scc))) 65 | (cons scc (dg-replace dg scc proxy))))) 66 | -------------------------------------------------------------------------------- /training-data.scm: -------------------------------------------------------------------------------- 1 | (load "transparent-evalo-transform.scm") 2 | 3 | (define (print-labeled-solution*-hint q-hint q) 4 | (define (boolean->idx b) (if b 0 1)) 5 | (let loop ((choices (labeled-pretty (labeled-solution*-hint q-hint q)))) 6 | (when (pair? choices) 7 | (printf "(~s ~s)\n" (map boolean->idx (caar choices)) (cadar choices)) 8 | (loop (cdr choices))))) 9 | 10 | 11 | (define (print x) (printf "~s\n" x)) 12 | 13 | (define (print-example-solutions danswer) 14 | (define lam (car danswer)) 15 | (define ios (q-examples 4 lam)) 16 | (define is (map car ios)) 17 | (define os (map cadr ios)) 18 | (define qh (q/hint lam is os)) 19 | (define q-hint (car qh)) 20 | (define q (cadr qh)) 21 | 22 | ;; Uncomment some of these to see the kinds of examples we're generating. 23 | (print `(q-transform/hint ',lam ',is)) 24 | 25 | ;(print `(lam ,lam)) 26 | ;(print `(ios ,ios)) 27 | ;(print `(inputs ,is)) 28 | ;(print `(outputs ,os)) 29 | ;(print `(with hint ,(reify-initial (car (stream-take 1 q-hint))))) 30 | ;(print `(without hint ,(reify-initial (car (stream-take 1 q))))) 31 | ;(print `(lam ,lam ios ,is ,os)) ; PROBLEM 32 | 33 | ;; Comment this if you uncomment anything above. 34 | ;(print-labeled-solution*-hint q-hint q) 35 | ) 36 | 37 | (define (print-example-solutions/map danswer) 38 | (define (process ios) 39 | (define ioss 40 | (list (list (car ios)) 41 | (list (cadr ios) (caddr ios)) 42 | (list (cadddr ios) (cadddr (cdr ios)) (cadddr (cddr ios))))) 43 | (define iss (map (lambda (ios) (list (map car ios))) ioss)) 44 | (define oss (map (lambda (ios) (map cdr ios)) ioss)) 45 | 46 | (print `(q-transform/hint* Z-map-context '(app (var ()) ,code) 1 ',iss)) 47 | 48 | ;(print `(code ,code)) 49 | ;(print `(ios ,ios)) 50 | ;(print `(inputs ,is)) 51 | ;(print `(outputs ,os)) 52 | ;(print `(with hint ,(reify-initial (car (stream-take 1 hint))))) 53 | ;(print `(without hint ,(reify-initial (car (stream-take 1 q))))) 54 | ;(print `(code ,code ios ,iss ,oss)) ; PROBLEM 55 | ) 56 | (define code (car danswer)) 57 | (define ios (q-examples-exact 6 code)) 58 | ;(displayln `(ios: ,ios code: ,code)) 59 | (when (= 6 (length ios)) (process ios))) 60 | 61 | (define (stream-process n k q) 62 | (let loop ((n n) (q q)) 63 | (cond 64 | ((or (and n (= 0 n)) (null? q)) #f) 65 | ((pair? q) (k (reify-initial (car q))) (loop (and n (- n 1)) (cdr q))) 66 | (else (loop n (stream-next q)))))) 67 | 68 | ;; Change the first argument to #f to generate indefinitely. 69 | (stream-process #f print-example-solutions/map q-transform-defs) 70 | -------------------------------------------------------------------------------- /scratch/lch-soon.scm: -------------------------------------------------------------------------------- 1 | (define (finite-set-map f xs) 2 | ) 3 | (define (finite-set-map-join f xs) 4 | ) 5 | (define (compose2 f g) (lambda (x) (f (g x)))) 6 | 7 | (define (complement a) 8 | (cond 9 | ((bottom? a) top) 10 | ((top? a) bottom) 11 | ((type-union? a) (type-union (complement (tu-pair a)) 12 | (complement (tu-symbol a)) 13 | (complement (tu-number a)) 14 | (complement (tu-nil a)) 15 | (complement (tu-false a)) 16 | (complement (tu-true a)))) 17 | 18 | ;; TODO: all individual types become type unions: 19 | ;; the complement of a specific type includes all the other types! 20 | 21 | ((type-pair? a) 22 | (if (not (equal? finite-set-empty (type-pair-absents a))) 23 | (error 'complement 24 | (format "complement does not support pair absence yet ~s" a)) 25 | (let* ((complement-fd? (not (type-pair-complement-fd? a))) 26 | (fd (type-pair-fd a)) 27 | ;; TODO: need to look up variable lattices when (not complement-fd?). 28 | ;; Otherwise, ignore them. 29 | ;; Actually, when complement-fd?, car and cdr aren't really constrained. 30 | (unit (if complement-fd? 31 | join complemented singletons 32 | (lambda (v) (complement (singleton v))) 33 | singleton))) 34 | (type-pair 35 | (finite-set-map-join (compose2 unit car) fd) 36 | (finite-set-map-join (compose2 unit cdr) fd) 37 | complement-fd? 38 | fd 39 | finite-set-empty)))) 40 | 41 | ((type-symbol? a) 42 | (type-symbol (not (type-symbol-complement-fd?)) (type-symbol-fd a))) 43 | ((type-number? a) 44 | (cond 45 | ((type-number-integer? a) 46 | (error 'complement 47 | (format "complement of integer set is not supported yet ~s" a))) 48 | ((not (equal? finite-set-empty (type-number-arithmetic a))) 49 | (error 'complement 50 | (format "complement does not support arithmetic yet ~s" a))) 51 | (else (type-number 52 | #f 53 | (numeric-set-complement (type-number-set a)) 54 | finite-set-empty)))) 55 | 56 | ((singleton? a) 57 | ;; Subtract from the proper type in type-union-full. 58 | (type-union 59 | ) 60 | ) 61 | (else (error 'complement (format "invalid lattice ~s" a))))) 62 | 63 | ;; Define implicit state monad threading for convenience? 64 | (define (meet a b) 65 | ) 66 | 67 | (define (join a b) 68 | ) 69 | -------------------------------------------------------------------------------- /lattice/order.scm: -------------------------------------------------------------------------------- 1 | (define (vector-compare a b lt eq gt) 2 | (define len-a (vector-length a)) 3 | (define len-b (vector-length b)) 4 | (cond 5 | ((< len-a len-b) lt) 6 | ((> len-a len-b) gt) 7 | (else (pair-compare (vector->list a) (vector->list b) lt eq gt)))) 8 | (define (pair-compare a b lt eq gt) 9 | ((any-compare (car a) (car b) (lambda () lt) 10 | (lambda () (any-compare (cdr a) (cdr b) lt eq gt)) 11 | (lambda () gt)))) 12 | ;; NOTE: this is only sound for non-generated symbols. 13 | (define (symbol-compare a b lt eq gt) 14 | (cond 15 | ((eq? a b) eq) 16 | ((stringstring a) (symbol->string b)) lt) 17 | (else gt))) 18 | (define (string-compare a b lt eq gt) 19 | (cond ((string? a b) gt) (else eq))) 20 | (define (number-compare a b lt eq gt) 21 | (cond ((< a b) lt) ((> a b) gt) (else eq))) 22 | (define (boolean-compare a b lt eq gt) (if a (if b eq gt) (if b lt eq))) 23 | 24 | ;; TODO: auto-generate this. 25 | (define (any-compare a b lt eq gt) 26 | (if (vector? a) (if (vector? b) (vector-compare a b lt eq gt) lt) 27 | (if (vector? b) gt 28 | (if (pair? a) (if (pair? b) (pair-compare a b lt eq gt) lt) 29 | (if (pair? b) gt 30 | (if (symbol? a) (if (symbol? b) (symbol-compare a b lt eq gt) lt) 31 | (if (symbol? b) gt 32 | (if (string? a) (if (string? b) (string-compare a b lt eq gt) lt) 33 | (if (string? b) gt 34 | (if (number? a) 35 | (if (number? b) (number-compare a b lt eq gt) lt) 36 | (if (number? b) gt 37 | (if (boolean? a) 38 | (if (boolean? b) (boolean-compare a b lt eq gt) lt) 39 | (if (boolean? b) gt 40 | (if (and (null? a) (null? b)) eq 41 | (error 'any-compare 42 | (format "unsupported comparison of ~s and ~s" 43 | a b)))))))))))))))) 44 | 45 | (define (any-max xs) 46 | (let loop ((x (car xs)) (xs (cdr xs))) 47 | (if (null? xs) x 48 | (loop (any-compare x (car xs) (car xs) x x) (cdr xs))))) 49 | (define (any-min xs) 50 | (let loop ((x (car xs)) (xs (cdr xs))) 51 | (if (null? xs) x 52 | (loop (any-compare x (car xs) x x (car xs)) (cdr xs))))) 53 | 54 | (define (list-odds xs) 55 | (cond 56 | ((null? xs) '()) 57 | ((null? (cdr xs)) xs) 58 | (else (cons (car xs) (list-odds (cddr xs)))))) 59 | (define (merge-sort merge xs) 60 | (cond 61 | ((null? xs) '()) 62 | ((null? (cdr xs)) xs) 63 | (else (merge (merge-sort merge (list-odds xs)) 64 | (merge-sort merge (list-odds (cdr xs))))))) 65 | -------------------------------------------------------------------------------- /lattice/test-array-mapped-trie.scm: -------------------------------------------------------------------------------- 1 | (load "array-mapped-trie.scm") 2 | (load "test.scm") 3 | 4 | (define t1 (amt-set amt-empty 3 'a)) 5 | (define t2a (amt-set t1 15 'b)) 6 | (define t2b (amt-set t1 16 'c)) 7 | (define t3a (amt-set t2a 16 'c)) 8 | (define t3b (amt-set t2b 15 'b)) 9 | (define t4 (amt-set t3a 0 'z)) 10 | (define t5a (amt-set t3a 15 'd)) 11 | (define t5b (amt-set t4 15 'd)) 12 | (define t6 (amt-set t5b 0 'y)) 13 | 14 | (test 'set-1 15 | t1 16 | (amt-leaf 3 'a)) 17 | (test 'set-2a 18 | t2a 19 | '#(() () () (0 . a) () () () () () () () () () () () (0 . b))) 20 | (test 'set-2b 21 | t2b 22 | '#((1 . c) () () (0 . a))) 23 | (test 'set-3a 24 | t3a 25 | '#((1 . c) () () (0 . a) () () () () () () () () () () () (0 . b))) 26 | (test 'set-3b 27 | (equal? t3a t3b) 28 | #t) 29 | (test 'set-4 30 | t4 31 | '#(#((0 . z) (0 . c)) () () (0 . a) () () () () () () () () () () () (0 . b))) 32 | 33 | (test 'ref-1 34 | (amt-leaf-value (amt-ref t1 3)) 35 | 'a) 36 | (test 'ref-2 37 | (amt-leaf-value (amt-ref t2a 3)) 38 | 'a) 39 | (test 'ref-3 40 | (amt-leaf-value (amt-ref t2a 15)) 41 | 'b) 42 | (test 'ref-4 43 | (amt-leaf-value (amt-ref t2b 3)) 44 | 'a) 45 | (test 'ref-5 46 | (amt-leaf-value (amt-ref t2b 16)) 47 | 'c) 48 | (test 'ref-6 49 | (amt-leaf-value (amt-ref t3a 3)) 50 | 'a) 51 | (test 'ref-7 52 | (amt-leaf-value (amt-ref t3a 15)) 53 | 'b) 54 | (test 'ref-8 55 | (amt-leaf-value (amt-ref t3a 16)) 56 | 'c) 57 | (test 'ref-9 58 | (amt-leaf-value (amt-ref t4 3)) 59 | 'a) 60 | (test 'ref-10 61 | (amt-leaf-value (amt-ref t4 15)) 62 | 'b) 63 | (test 'ref-11 64 | (amt-leaf-value (amt-ref t4 16)) 65 | 'c) 66 | (test 'ref-12 67 | (amt-leaf-value (amt-ref t4 0)) 68 | 'z) 69 | 70 | (test 'ref-missing-1 71 | (amt-ref t1 2) 72 | #f) 73 | (test 'ref-missing-2 74 | (amt-ref t2a 2) 75 | #f) 76 | (test 'ref-missing-3 77 | (amt-ref t2b 2) 78 | #f) 79 | (test 'ref-missing-4 80 | (amt-ref t3a 2) 81 | #f) 82 | (test 'ref-missing-5 83 | (amt-ref t4 2) 84 | #f) 85 | 86 | (test 'set-again-ref-1 87 | (amt-leaf-value (amt-ref t5a 15)) 88 | 'd) 89 | (test 'set-again-ref-2 90 | (amt-leaf-value (amt-ref t5b 15)) 91 | 'd) 92 | (test 'set-again-ref-2 93 | (amt-leaf-value (amt-ref t6 0)) 94 | 'y) 95 | 96 | (test 'remove-1 97 | (amt-remove amt-empty 1) 98 | amt-empty) 99 | (test 'remove-2 100 | (amt-remove (amt-leaf 5 'a) 2) 101 | (amt-leaf 5 'a)) 102 | (test 'remove-3 103 | (amt-remove (amt-leaf 5 'a) 5) 104 | amt-empty) 105 | (test 'remove-4 106 | (amt-remove t2a 3) 107 | (amt-leaf 15 'b)) 108 | (test 'remove-5 109 | (amt-remove t2a 15) 110 | (amt-leaf 3 'a)) 111 | (test 'remove-6 112 | (amt-remove t2b 3) 113 | (amt-leaf 16 'c)) 114 | (test 'remove-7 115 | (amt-remove t2b 16) 116 | (amt-leaf 3 'a)) 117 | (test 'remove-8 118 | (amt-remove (amt-remove (amt-remove t4 16) 3) 15) 119 | (amt-leaf 0 'z)) 120 | (test 'remove-9 121 | (amt-remove (amt-remove (amt-remove t4 0) 15) 3) 122 | (amt-leaf 16 'c)) 123 | -------------------------------------------------------------------------------- /lattice/test-directed-graph.scm: -------------------------------------------------------------------------------- 1 | (load "test.scm") 2 | (load "directed-graph.scm") 3 | 4 | (define dg1 (dg-add dg-empty 'a 'b)) 5 | (define dg2 (dg-add dg1 'a 'c)) 6 | (define dg3 (dg-add dg2 'd 'c)) 7 | (define dg4 (dg-add dg3 'b 'd)) 8 | (define dg5 (dg-add dg4 'e 'b)) 9 | 10 | (test 'add-1 11 | dg1 12 | '((a . (b)))) 13 | (test 'add-2 14 | (dg-add dg1 'a 'b) 15 | '((a . (b)))) 16 | (test 'add-3 17 | dg2 18 | '((a . (b c)))) 19 | (test 'add-4 20 | dg3 21 | '((a . (b c)) (d . (c)))) 22 | (test 'add-5 23 | dg4 24 | '((a . (b c)) (b . (d)) (d . (c)))) 25 | (test 'add-6 26 | (dg-add-simplify dg4 'b 'c) 27 | '((a . (b c)) (b . (d)) (d . (c)))) 28 | (test 'add-7 29 | (dg-add-simplify dg2 'b 'c) 30 | '((a . (b)) (b . (c)))) 31 | (test 'add-8 32 | (dg-add-simplify dg3 'b 'd) 33 | '((a . (b)) (b . (d)) (d . (c)))) 34 | 35 | (test 'remove-1 36 | (dg-remove dg-empty 'x 'y) 37 | dg-empty) 38 | (test 'remove-2 39 | (dg-remove dg1 'a 'b) 40 | dg-empty) 41 | (test 'remove-3 42 | (dg-remove dg1 'a 'c) 43 | '((a . (b)))) 44 | (test 'remove-3 45 | (dg-remove dg2 'a 'b) 46 | '((a . (c)))) 47 | 48 | (test 'replace-1 49 | (dg-replace dg4 '(a b) 'g) 50 | '((d . (c)) (g . (c d)))) 51 | (test 'replace-2 52 | (dg-replace dg5 '(a b) 'g) 53 | '((d . (c)) (e . (g)) (g . (c d)))) 54 | 55 | (test 'succ-1 56 | (dg-succ dg-empty 'a) 57 | '()) 58 | (test 'succ-2 59 | (dg-succ dg1 'a) 60 | '(b)) 61 | (test 'succ-3 62 | (dg-succ dg3 'a) 63 | '(b c)) 64 | (test 'succ-4 65 | (dg-succ dg4 'b) 66 | '(d)) 67 | (test 'succ-5 68 | (dg-succ* dg4 'b) 69 | '(c d)) 70 | 71 | (test 'pred-1 72 | (dg-pred dg-empty 'a) 73 | '()) 74 | (test 'pred-2 75 | (dg-pred dg1 'a) 76 | '()) 77 | (test 'pred-3 78 | (dg-pred dg2 'c) 79 | '(a)) 80 | (test 'pred-4 81 | (dg-pred dg4 'c) 82 | '(a d)) 83 | (test 'pred-5 84 | (dg-pred* dg4 'c) 85 | '(a b d)) 86 | 87 | (test 'scc-1 88 | (dg-scc dg-empty 'c 'b) 89 | '()) 90 | (test 'scc-2 91 | (dg-scc dg1 'c 'b) 92 | '()) 93 | (test 'scc-3 94 | (dg-scc dg2 'c 'b) 95 | '()) 96 | (test 'scc-4 97 | (dg-scc dg3 'c 'b) 98 | '()) 99 | (test 'scc-5 100 | (dg-scc dg4 'c 'b) 101 | '(b c d)) 102 | (test 'scc-5 103 | (dg-scc dg4 'c 'a) 104 | '(a b c d)) 105 | 106 | (define n1 (dg-transitive-add dg-empty 'a 'b)) 107 | (define tdg1 (cdr n1)) 108 | (define n2 (dg-transitive-add tdg1 'a 'c)) 109 | (define tdg2 (cdr n2)) 110 | (define n3 (dg-transitive-add tdg2 'd 'c)) 111 | (define tdg3 (cdr n3)) 112 | (define n4 (dg-transitive-add tdg3 'b 'd)) 113 | (define tdg4 (cdr n4)) 114 | (define n5 (dg-transitive-add tdg4 'e 'b)) 115 | (define tdg5 (cdr n5)) 116 | (define n6 (dg-transitive-add tdg5 'f 'e)) 117 | (define tdg6 (cdr n6)) 118 | 119 | (test 'transitive-add-1 120 | n1 121 | '(#f . ((a . (b))))) 122 | (test 'transitive-add-2 123 | n2 124 | '(#f . ((a . (b c))))) 125 | (test 'transitive-add-3 126 | n3 127 | '(#f . ((a . (b c)) (d . (c))))) 128 | (test 'transitive-add-4 129 | n4 130 | '(#f . ((a . (b)) (b . (d)) (d . (c))))) 131 | (test 'transitive-add-5 132 | n5 133 | '(#f . ((a . (b)) (b . (d)) (d . (c)) (e . (b))))) 134 | (test 'transitive-add-6 135 | n6 136 | '(#f . ((a . (b)) (b . (d)) (d . (c)) (e . (b)) (f . (e))))) 137 | (test 'transitive-add-7 138 | (dg-transitive-add tdg6 'b 'e) 139 | '((b e) . ((a . (b)) (b . (d)) (d . (c)) (f . (b))))) 140 | (test 'transitive-add-8 141 | (dg-transitive-add tdg6 'd 'a) 142 | '((a b d) . ((a . (c)) (e . (a)) (f . (e))))) 143 | -------------------------------------------------------------------------------- /transparent-evalo-transform.scm: -------------------------------------------------------------------------------- 1 | (load "transparent-evalo.scm") 2 | 3 | (define atoms (run* (a) (atomo a))) 4 | (define (atom-random) (list-ref atoms (random (length atoms)))) 5 | 6 | (define-relation (literalo v) 7 | (conde 8 | ((== (atom-random) v)) 9 | ((fresh (a d) (== `(,a . ,d) v) (literalo a) (literalo d))) 10 | ((atomo v)))) 11 | 12 | (define-relation (refo e) 13 | (conde 14 | ((== `(var ()) e)) 15 | ((fresh (ec) (== `(car ,ec) e) (refo ec))) 16 | ((fresh (ec) (== `(cdr ,ec) e) (refo ec))))) 17 | 18 | (define-relation (list-argso a*) 19 | (conde 20 | ((== '() a*)) 21 | ((fresh (a d) 22 | (== `(,a . ,d) a*) 23 | (transformo a) 24 | (list-argso d))))) 25 | 26 | (define-relation (transformo e) 27 | (conde 28 | ((== '(var ()) e)) 29 | ((fresh (a* a d) (== `(,a . ,d) a*) (== `(list . ,a*) e) (list-argso a*))) 30 | ((fresh (ec) (== `(car ,ec) e) (refo ec))) 31 | ((fresh (ec) (== `(cdr ,ec) e) (refo ec))) 32 | ((fresh (q) (== `(quote ,q) e) (literalo q))) 33 | ((fresh (ea ed) (== `(cons ,ea ,ed) e) (transformo ea) (transformo ed))))) 34 | 35 | 36 | (define q-transform-defs 37 | (query (defn) (fresh (body) (== `(lambda ,body) defn) (transformo body)))) 38 | 39 | (define MULTIPLIER 5.0) 40 | 41 | (define (q-examples n defn) 42 | (map (lambda (st) 43 | (caar (run 1 (v) 44 | (== (walk* st var-initial) v) 45 | (literalo v)))) 46 | (stream-take 47 | (* n MULTIPLIER) 48 | (query (input output) (evalo `(app ,defn ',input) output) 49 | (literalo output))))) 50 | 51 | (define (q-examples-exact n defn) 52 | (map (lambda (st) 53 | (caar (run 1 (v) 54 | (== (walk* st var-initial) v) 55 | (literalo v)))) 56 | (stream-take n 57 | (query (input output) (evalo `(app ,defn ',input) output) 58 | (literalo output))))) 59 | 60 | (define (take-random lst) 61 | (if (null? lst) 62 | lst 63 | (if (<= (random 0.999) (/ 1.0 MULTIPLIER)) 64 | (cons (car lst) (take-random (cdr lst))) 65 | (take-random (cdr lst))))) 66 | 67 | (define (q/hint fcode is os) 68 | (define q 69 | (query (defn) 70 | (fresh (body) (== `(lambda ,body) defn) 71 | (evalo `(list . ,(map (lambda (i) `(app ,defn ',i)) is)) os)))) 72 | (list (== (list fcode) var-initial) q)) 73 | 74 | ;; We will interact with uses of this. 75 | (define (q-transform/hint fcode inputs) 76 | (define outputs 77 | (car (car (run 1 (outputs) 78 | (evalo `(list . ,(map (lambda (i) `(app ,fcode ',i)) 79 | inputs)) 80 | outputs))))) 81 | (q/hint fcode inputs outputs)) 82 | 83 | (define (use-app n i* proc) 84 | (if (= 0 n) proc 85 | (use-app (- n 1) (cdr i*) `(app ,proc ',(car i*))))) 86 | 87 | (define (q/hint* code-context code-goal n is os) 88 | (define q 89 | (query (target) 90 | (evalo `(list . ,(map (lambda (i*) 91 | (use-app n i* (code-context target))) 92 | is)) os))) 93 | (list (== (list code-goal) var-initial) q)) 94 | 95 | ;; We will interact with uses of this. 96 | (define (q-transform/hint* code-context code-goal n inputs) 97 | (define code-full (code-context code-goal)) 98 | (define uses (map (lambda (i*) (use-app n i* code-full)) inputs)) 99 | (define outputs 100 | (car (car (run 1 (outputs) (evalo `(list . ,uses) outputs))))) 101 | (q/hint* code-context code-goal n inputs outputs)) 102 | -------------------------------------------------------------------------------- /lattice/eq-linear.scm: -------------------------------------------------------------------------------- 1 | (load "list.scm") 2 | 3 | ;; General equations 4 | (define eqs-empty '()) 5 | (define (eq-size eq) (if (pair? eq) (+ 1 (eq-size (cdr eq))) 0)) 6 | (define (eq< a b) 7 | (cond 8 | ((not (pair? a)) #f) 9 | ((= (car a) (car b)) (eq< (cdr a) (cdr b))) 10 | (else (< (car a) (car b))))) 11 | 12 | (define (eq-zero-rhs eq k-rhs k-fail) 13 | (if (pair? eq) 14 | (if (= 0 (car eq)) 15 | (eq-zero-rhs (cdr eq) k-rhs k-fail) 16 | (k-fail eq)) 17 | (k-rhs eq))) 18 | 19 | (define (eq-zero? eq) 20 | (eq-zero-rhs eq (lambda (rhs) (= 0 rhs)) (lambda (_) #f))) 21 | 22 | (define (eq-satisfiable? eq) 23 | (eq-zero-rhs eq (lambda (rhs) (= 0 rhs)) (lambda (_) #t))) 24 | 25 | (define (eq-expand eq size) 26 | (if (pair? eq) 27 | (cons (car eq) (eq-expand (cdr eq) (- size 1))) 28 | (append (make-list size 0) eq))) 29 | 30 | (define (eq-shrink eq offset cols) 31 | (if (null? cols) eq 32 | (let loop ((eq eq) (offset offset) (col (car cols))) 33 | (if (= offset col) 34 | (eq-shrink (cdr eq) (+ offset 1) (cdr cols)) 35 | (cons (car eq) (loop (cdr eq) (+ 1 offset) col)))))) 36 | 37 | (define (eqs-expand eqs size) 38 | (map (lambda (eq) (eq-expand eq size)) eqs)) 39 | 40 | (define (eqs-shrink eqs cols) 41 | (map (lambda (eq) (eq-shrink eq 0 cols)) eqs)) 42 | 43 | (define (eq-sparse->dense eq) 44 | (let loop ((eq eq) (idx 0)) 45 | (if (pair? eq) 46 | (append (make-list (- (caar eq) idx) 0) 47 | (cons (cdar eq) (loop (cdr eq) (+ 1 (caar eq))))) 48 | eq))) 49 | 50 | (define (eqs-next-solved next) (car next)) 51 | (define (eqs-next-eqs next) (cdr next)) 52 | 53 | ;; Linear equations 54 | (define (eqs-linear-add eqs eq) 55 | (define (eq-linear-simplify a b) 56 | (let loop ((a a) (b b) (rprefix '())) 57 | (define (rebuild factor xs) 58 | (list-foldl (lambda (fst rest) (cons (* factor fst) rest)) xs rprefix)) 59 | (cond 60 | ((not (pair? a)) (rebuild 1 b)) 61 | ((= 0 (car a)) (loop (cdr a) (cdr b) (cons (car b) rprefix))) 62 | ((= 0 (car b)) (rebuild 1 b)) 63 | (else 64 | (let ((fa (car a)) (fb (car b))) 65 | (let loop ((a (cdr a)) (b (cdr b)) (rprefix '(0))) 66 | (define (sb a b) (- (* fa b) (* fb a))) 67 | (if (pair? a) 68 | (loop (cdr a) (cdr b) (cons (sb (car a) (car b)) rprefix)) 69 | (rebuild fa (list-foldl cons (sb a b) rprefix))))))))) 70 | 71 | (define (eqs-linear-simplify eqs eq) 72 | (list-foldl (lambda (eq0 eq) (eq-linear-simplify eq0 eq)) eq eqs)) 73 | 74 | (define (eqs-linear-insert eqs eq) 75 | (cond 76 | ((null? eqs) (list eq)) 77 | ((eq< (car eqs) eq) (cons eq eqs)) 78 | (else (cons (eq-linear-simplify eq (car eqs)) 79 | (eqs-linear-insert (cdr eqs) eq))))) 80 | 81 | (define (eq-linear-solved eq) 82 | (let loop ((eq eq) (idx 0)) 83 | (and (pair? eq) 84 | (if (= 0 (car eq)) 85 | (loop (cdr eq) (+ 1 idx)) 86 | (eq-zero-rhs 87 | (cdr eq) 88 | (lambda (rhs) (list (cons idx (/ rhs (car eq))))) 89 | (lambda (_) '())))))) 90 | 91 | (define (eqs-linear-solved-remove eqs) 92 | (filter (lambda (eq) (null? (eq-linear-solved eq))) eqs)) 93 | 94 | (define (eqs-linear-solve eqs) 95 | (define solved (list-append-map eq-linear-solved eqs)) 96 | (if (null? solved) (cons '() eqs) 97 | (cons solved (eqs-shrink (eqs-linear-solved-remove eqs) 98 | (map car solved))))) 99 | 100 | (define size (max (if (null? eqs) 0 (eq-size (car eqs))) (eq-size eq))) 101 | (define eqs1 (eqs-expand eqs size)) 102 | (define simplified (eqs-linear-simplify eqs1 (eq-expand eq size))) 103 | (if (eq-zero? simplified) 104 | (cons '() eqs) 105 | (and (eq-satisfiable? simplified) 106 | (eqs-linear-solve (eqs-linear-insert eqs1 simplified))))) 107 | -------------------------------------------------------------------------------- /lattice/array-mapped-trie.scm: -------------------------------------------------------------------------------- 1 | ;; Ideally, this implementation would assume (fixnum? index) is always #t, but 2 | ;; load-only portability is challenging at the moment. So use makeshift 3 | ;; definitions in place of fixnum operations for now. 4 | ;; fx=, fx<, fx+, fx-, fxmax, bitwise-and: fxand 5 | ;; Racket: (require racket/fixnum), nsl: fxlshift, nsr: fxrshift 6 | ;; Chez: nsl: fxsll, nsr: fxsra 7 | 8 | (define shift-size 4) 9 | 10 | (define (nsl n sz) (* n (expt 2 sz))) 11 | (define (nsr n sz) (floor (/ n (expt 2 sz)))) 12 | 13 | (define amt-branch-size (nsl 1 shift-size)) 14 | (define local-mask (- amt-branch-size 1)) 15 | (define (shift index) (nsr index shift-size)) 16 | (define (unshift index) (nsl index shift-size)) 17 | (define (local index) (bitwise-and index local-mask)) 18 | 19 | (define amt-empty '()) 20 | (define (amt-empty? amt) (null? amt)) 21 | (define (amt-leaf index value) (cons index value)) 22 | (define (amt-leaf? amt) (pair? amt)) 23 | (define (amt-leaf-index leaf) (car leaf)) 24 | (define (amt-leaf-value leaf) (cdr leaf)) 25 | (define (amt-branch? amt) (vector? amt)) 26 | 27 | (define (amt-branch-new i0 v0) 28 | (define result (make-vector (+ i0 1) amt-empty)) 29 | (vector-set! result i0 v0) 30 | result) 31 | (define (amt-branch-resize branch len) 32 | (define len0 (vector-length branch)) 33 | (if (= len len0) (vector-copy branch) 34 | (let ((result (make-vector len amt-empty))) 35 | (let copy ((ci (- (min len0 len) 1))) 36 | (if (> 0 ci) result 37 | (begin (vector-set! result ci (vector-ref branch ci)) 38 | (copy (- ci 1)))))))) 39 | (define (amt-branch-ref branch idx) 40 | (if (< idx (vector-length branch)) (vector-ref branch idx) amt-empty)) 41 | (define (amt-branch-set branch idx val) 42 | (define result (amt-branch-resize branch (max (vector-length branch) 43 | (+ idx 1)))) 44 | (vector-set! result idx val) 45 | result) 46 | (define (amt-branch-remove branch idx) 47 | (define (size<=? size idx) 48 | (cond ((> 0 idx) #t) 49 | ((amt-empty? (vector-ref branch idx)) (size<=? size (- idx 1))) 50 | ((< 0 size) (size<=? (- size 1) (- idx 1))) 51 | (else #f))) 52 | (define (leaf-or-len size len) 53 | (define idx (- len 1)) 54 | (define amt (vector-ref branch idx)) 55 | (if (and (amt-leaf? amt) (size<=? size (- idx 1))) 56 | (amt-leaf (+ idx (unshift (amt-leaf-index amt))) 57 | (amt-leaf-value amt)) 58 | len)) 59 | (define len0 (vector-length branch)) 60 | (define len1-or-amt 61 | (if (< (+ 1 idx) len0) (leaf-or-len 1 len0) 62 | (let last-idx ((li (- idx 1))) 63 | (cond 64 | ((> 0 li) amt-empty) 65 | ((amt-empty? (vector-ref branch li)) (last-idx (- li 1))) 66 | (else (leaf-or-len 0 (+ li 1))))))) 67 | (if (number? len1-or-amt) 68 | (let ((result (amt-branch-resize branch len1-or-amt))) 69 | (when (< idx len1-or-amt) (vector-set! result idx amt-empty)) 70 | result) 71 | len1-or-amt)) 72 | 73 | (define (amt-size amt) 74 | (cond 75 | ((amt-branch? amt) 76 | (let loop ((ci 0) (sz 0)) 77 | (if (= amt-branch-size ci) sz 78 | (loop (+ ci 1) (+ sz (amt-size (amt-branch-ref amt ci))))))) 79 | ((amt-leaf? amt) 1) 80 | (else 0))) 81 | 82 | (define (amt-ref amt index) 83 | (cond 84 | ((amt-branch? amt) (amt-ref (amt-branch-ref amt (local index)) 85 | (shift index))) 86 | ((amt-leaf? amt) (and (= index (amt-leaf-index amt)) amt)) 87 | (else #f))) 88 | 89 | (define (amt-set amt index val) 90 | (cond 91 | ((amt-branch? amt) 92 | (let ((li (local index))) 93 | (amt-branch-set 94 | amt li (amt-set (amt-branch-ref amt li) (shift index) val)))) 95 | ((amt-leaf? amt) 96 | (let ((index0 (amt-leaf-index amt))) 97 | (if (= index0 index) (amt-leaf index val) 98 | (amt-set (amt-branch-new (local index0) 99 | (amt-leaf (shift index0) (amt-leaf-value amt))) 100 | index val)))) 101 | (else (amt-leaf index val)))) 102 | 103 | (define (amt-remove amt index) 104 | (cond 105 | ((amt-branch? amt) 106 | (let* ((li (local index)) 107 | (child0 (amt-branch-ref amt li)) 108 | (child1 (amt-remove child0 (shift index)))) 109 | (cond 110 | ((eq? child0 child1) amt) 111 | ((amt-empty? child1) (amt-branch-remove amt li)) 112 | (else (amt-branch-set amt li child1))))) 113 | ((amt-leaf? amt) (if (= index (amt-leaf-index amt)) amt-empty amt)) 114 | (else amt-empty))) 115 | -------------------------------------------------------------------------------- /transparent-evalo.scm: -------------------------------------------------------------------------------- 1 | (load "transparent.scm") 2 | 3 | (define (atomo v) 4 | (conde 5 | ((== '() v)) 6 | ((== 'a v)) 7 | ((== 'b v)) 8 | ((== '1 v)) 9 | ((== 'x v)) 10 | ((== 'y v)) 11 | ((== 's v)) 12 | ((== #t v)) 13 | ((== #f v)) 14 | ;; TODO: leave these out for now. 15 | ;((== 'quote v)) 16 | ;((== 'list v)) 17 | ;((== 'cons v)) 18 | ;((== 'car v)) 19 | ;((== 'cdr v)) 20 | ;((== 'var v)) 21 | ;((== 'lambda v)) 22 | ;((== 'app v)) 23 | ;((== 'closure v)) 24 | ;((== 'pair? v)) 25 | ;((== 'if v)) 26 | )) 27 | 28 | (define (not-falseo v) 29 | (conde 30 | ((== '() v)) ((== #t v)) ((== 'a v)) ((== 'b v)) ((== 's v)) 31 | ((== '1 v)) ((== 'x v)) ((== 'y v)) ((== 'quote v)) ((== 'list v)) 32 | ((== 'cons v)) ((== 'car v)) ((== 'cdr v)) ((== 'var v)) ((== 'lambda v)) 33 | ((== 'app v)) ((== 'closure v)) ((== 'pair? v)) ((== 'if v)) 34 | ((fresh (a d) (== `(,a . ,d) v))))) 35 | 36 | (define (evalo expr value) (eval-expo expr '() value)) 37 | (define-relation (eval-expo expr env value) 38 | (conde 39 | ;; Placing lambdas first seems to reduce quoted closures. 40 | ((fresh (body) 41 | (== `(lambda ,body) expr) 42 | (== `(closure ,body ,env) value))) 43 | ((fresh (datum) 44 | (== `(quote ,datum) expr) 45 | (== datum value))) 46 | ((fresh (a*) 47 | (== `(list . ,a*) expr) 48 | (eval-listo a* env value))) 49 | ((fresh (index) 50 | (== `(var ,index) expr) 51 | (lookupo index env value))) 52 | ((fresh (rator rand arg env^ body) 53 | (== `(app ,rator ,rand) expr) 54 | (eval-expo rator env `(closure ,body ,env^)) 55 | (eval-expo rand env arg) 56 | (eval-expo body `(,arg . ,env^) value))) 57 | ((fresh (a d va vd) 58 | (== `(cons ,a ,d) expr) 59 | (== `(,va . ,vd) value) 60 | (eval-expo a env va) 61 | (eval-expo d env vd))) 62 | ((fresh (c va vd) 63 | (== `(car ,c) expr) 64 | (== va value) 65 | (eval-expo c env `(,va . ,vd)))) 66 | ((fresh (c va vd) 67 | (== `(cdr ,c) expr) 68 | (== vd value) 69 | (eval-expo c env `(,va . ,vd)))) 70 | ((fresh (e a d v) 71 | (== `(pair? ,e) expr) 72 | (conde 73 | ((== #t value) (eval-expo e env `(,a . ,d))) 74 | ((== #f value) (eval-expo e env v) (atomo v))))) 75 | ((fresh (c t f v) 76 | (== `(if ,c ,t ,f) expr) 77 | (conde 78 | ((eval-expo c env #f) (eval-expo f env value)) 79 | ((eval-expo c env v) (not-falseo v) (eval-expo t env value))))))) 80 | 81 | (define-relation (lookupo index env value) 82 | (fresh (arg e*) 83 | (== `(,arg . ,e*) env) 84 | (conde 85 | ((== '() index) (== arg value)) 86 | ((fresh (i*) 87 | (== `(s . ,i*) index) 88 | (lookupo i* e* value)))))) 89 | 90 | (define-relation (eval-listo e* env value) 91 | (conde 92 | ((== '() e*) (== '() value)) 93 | ((fresh (ea ed va vd) 94 | (== `(,ea . ,ed) e*) 95 | (== `(,va . ,vd) value) 96 | (eval-expo ea env va) 97 | (eval-listo ed env vd))))) 98 | 99 | ;(define Z0 100 | ;(lambda (f) 101 | ;((lambda (x) (lambda (a) ((f (x x)) a))) 102 | ;(lambda (x) (lambda (a) ((f (x x)) a)))))) 103 | 104 | (define Z 105 | '(lambda 106 | (app (lambda (lambda (app (app (var (s s)) 107 | (app (var (s)) (var (s)))) (var ())))) 108 | (lambda (lambda (app (app (var (s s)) 109 | (app (var (s)) (var (s)))) (var ()))))))) 110 | 111 | ;(define Z0-append 112 | ;(Z0 (lambda (append) 113 | ;(lambda (xs) 114 | ;(lambda (ys) 115 | ;(if (pair? xs) 116 | ;(cons (car xs) ((append (cdr xs)) ys)) 117 | ;ys)))))) 118 | 119 | (define Z-append 120 | `(app ,Z (lambda 121 | (lambda 122 | (lambda 123 | (if (pair? (var (s))) 124 | (cons (car (var (s))) 125 | (app (app (var (s s)) (cdr (var (s)))) (var ()))) 126 | (var ()))))))) 127 | 128 | ;(define Z0-map 129 | ;(Z0 (lambda (map) 130 | ;(lambda (f) 131 | ;(lambda (xs) 132 | ;(if (pair? xs) 133 | ;(cons (f (car xs)) ((map f) (cdr xs))) 134 | ;'())))))) 135 | 136 | (define Z-map 137 | `(app ,Z (lambda 138 | (lambda 139 | (lambda 140 | (if (pair? (var ())) 141 | (cons (app (var (s)) (car (var ()))) 142 | (app (app (var (s s)) (var (s))) (cdr (var ())))) 143 | '())))))) 144 | 145 | (define Z-map-context (lambda (body) `(app (lambda ,body) ,Z-map))) 146 | -------------------------------------------------------------------------------- /lattice/test-discrete-set.scm: -------------------------------------------------------------------------------- 1 | (load "test.scm") 2 | (load "discrete-set.scm") 3 | 4 | (define items '(b a #t #f 3 2 "ok" () "ab" #(1 2 3) (#f 3) #(5 4) (#f 1) ((#t) . 5))) 5 | (define items-ordered 6 | '(#(5 4) #(1 2 3) ((#t) . 5) (#f 1) (#f 3) a b "ab" "ok" 2 3 #f #t ())) 7 | (define with-items (discrete-set-with items)) 8 | (define without-items (discrete-set-without items)) 9 | 10 | (test 'discrete-set-1 11 | with-items 12 | `(#f . ,items-ordered)) 13 | (test 'discrete-set-2 14 | without-items 15 | `(#t . ,items-ordered)) 16 | (test 'discrete-set-3 17 | (discrete-set-complement with-items) 18 | `(#t . ,items-ordered)) 19 | (test 'discrete-set-4 20 | (discrete-set-complement without-items) 21 | `(#f . ,items-ordered)) 22 | 23 | (define items2 '(c a #t 5 2 "ok" "abc" #(5 6) (#f 3) #(1 2 3) (#f 2) ((#t) . 5))) 24 | (define with-items2 (discrete-set-with items2)) 25 | 26 | (define items-all 27 | '(b a c #t 5 #f 3 2 #(1 2 3) #(5 6) #(5 4) "ok" "abc" () "ab" (#f 2) (#f 3) 28 | (#f 1) ((#t) . 5))) 29 | (define with-items-all (discrete-set-with items-all)) 30 | 31 | (define items-missing '(b #f 3 "ab" () #(5 4) (#f 1))) 32 | (define with-items-missing (discrete-set-with items-missing)) 33 | (define without-items-missing (discrete-set-complement with-items-missing)) 34 | 35 | (test 'discrete-set-join-1 36 | (discrete-set-join discrete-set-full discrete-set-full) 37 | discrete-set-full) 38 | (test 'discrete-set-join-2 39 | (discrete-set-join discrete-set-full discrete-set-empty) 40 | discrete-set-full) 41 | (test 'discrete-set-join-3 42 | (discrete-set-join discrete-set-empty discrete-set-full) 43 | discrete-set-full) 44 | (test 'discrete-set-join-4 45 | (discrete-set-join discrete-set-empty discrete-set-empty) 46 | discrete-set-empty) 47 | (test 'discrete-set-join-5 48 | (discrete-set-join with-items discrete-set-empty) 49 | with-items) 50 | (test 'discrete-set-join-6 51 | (discrete-set-join discrete-set-empty with-items) 52 | with-items) 53 | (test 'discrete-set-join-7 54 | (discrete-set-join with-items discrete-set-full) 55 | discrete-set-full) 56 | (test 'discrete-set-join-8 57 | (discrete-set-join discrete-set-full with-items) 58 | discrete-set-full) 59 | (test 'discrete-set-join-9 60 | (discrete-set-join with-items with-items) 61 | with-items) 62 | (test 'discrete-set-join-10 63 | (discrete-set-join with-items without-items) 64 | discrete-set-full) 65 | (test 'discrete-set-join-11 66 | (discrete-set-join without-items with-items) 67 | discrete-set-full) 68 | (test 'discrete-set-join-12 69 | (discrete-set-join with-items with-items2) 70 | with-items-all) 71 | (test 'discrete-set-join-13 72 | (discrete-set-join with-items2 with-items) 73 | with-items-all) 74 | (test 'discrete-set-join-14 75 | (discrete-set-join without-items with-items2) 76 | without-items-missing) 77 | (test 'discrete-set-join-15 78 | (discrete-set-join with-items2 without-items) 79 | without-items-missing) 80 | 81 | (define items-overlapping '(a #t 2 "ok" (#f 3) #(1 2 3) ((#t) . 5))) 82 | (define with-items-overlapping (discrete-set-with items-overlapping)) 83 | 84 | (define items2-only '(c 5 #(5 6) "abc" (#f 2))) 85 | (define with-items2-only (discrete-set-with items2-only)) 86 | 87 | (test 'discrete-set-meet-1 88 | (discrete-set-meet discrete-set-full discrete-set-full) 89 | discrete-set-full) 90 | (test 'discrete-set-meet-2 91 | (discrete-set-meet discrete-set-full discrete-set-empty) 92 | discrete-set-empty) 93 | (test 'discrete-set-meet-3 94 | (discrete-set-meet discrete-set-empty discrete-set-full) 95 | discrete-set-empty) 96 | (test 'discrete-set-meet-4 97 | (discrete-set-meet discrete-set-empty discrete-set-empty) 98 | discrete-set-empty) 99 | (test 'discrete-set-meet-5 100 | (discrete-set-meet with-items discrete-set-empty) 101 | discrete-set-empty) 102 | (test 'discrete-set-meet-6 103 | (discrete-set-meet discrete-set-empty with-items) 104 | discrete-set-empty) 105 | (test 'discrete-set-meet-7 106 | (discrete-set-meet with-items discrete-set-full) 107 | with-items) 108 | (test 'discrete-set-meet-8 109 | (discrete-set-meet discrete-set-full with-items) 110 | with-items) 111 | (test 'discrete-set-meet-9 112 | (discrete-set-meet with-items with-items) 113 | with-items) 114 | (test 'discrete-set-meet-10 115 | (discrete-set-meet with-items without-items) 116 | discrete-set-empty) 117 | (test 'discrete-set-meet-11 118 | (discrete-set-meet without-items with-items) 119 | discrete-set-empty) 120 | (test 'discrete-set-meet-12 121 | (discrete-set-meet with-items with-items2) 122 | with-items-overlapping) 123 | (test 'discrete-set-meet-13 124 | (discrete-set-meet with-items2 with-items) 125 | with-items-overlapping) 126 | (test 'discrete-set-meet-14 127 | (discrete-set-meet without-items with-items2) 128 | with-items2-only) 129 | (test 'discrete-set-meet-15 130 | (discrete-set-meet with-items2 without-items) 131 | with-items2-only) 132 | -------------------------------------------------------------------------------- /chr.scm: -------------------------------------------------------------------------------- 1 | ;; This approach is pretty complicated, and I'm not sure if there are enough 2 | ;; benefits to pursue it. Although the declarative rule specification and 3 | ;; semantics are nice, term-rewriting systems require analyses to ensure 4 | ;; reasonable behavior (e.g., confluence). This is probably because it's a 5 | ;; powerful computational medium on its own. An ideal medium for constraint 6 | ;; handling shouldn't need powerful computation, and in exchange would provide 7 | ;; reasonable behavior for free. I'm leaning towards semilattices for the 8 | ;; monotonicity guarantees. 9 | 10 | ;; TODO: an idemptotent CHR for simplification and constraint handling. 11 | ;; builtins: #f (failure), #t (trivial success), ground (non-variable), == 12 | ;; auto-normalizing rearrangement rules (commutativity, associativity...) 13 | ;; only rearrange when the output is "more normalized" than the input 14 | ;; "more normalized" means lexicographically less-than 15 | ;; w.r.t. ordering on data and variables (oldest first) 16 | ;; primitive operation rule interpretations 17 | ;; disjunctions? 18 | ;; lazy satisfiability, optional path/clause learning to speed up revisits 19 | ;; maybe limited to describing finite domains for simplicity 20 | ;; hooks for external solvers and search 21 | ;; to support complex, possibly recursive, possibly non-terminating goals 22 | ;; e.g., after simplifying `evalo` uses, expand definition in miniKanren 23 | ;; should be able to support these user-defined constraints: 24 | ;; type predicates, =/=, absent, +, *, <=, integer 25 | ;; possibly finite domains 26 | ;; possibly more complex data structure predicates (sets?) 27 | 28 | ;; simpagation with optional host interpretation: 29 | ;; name @ static & input => output(with embedded host expression calculations) 30 | ;; 31 | ;; Input predicates are consumed when a rule fires, static predicates are not. 32 | ;; There's no need to separate builtins from user-defined predicates. 33 | ;; With embedded host calculation, can this even define some of the builtins? 34 | 35 | ;; rule prioritization: 36 | ;; * normalization: input and output only differ by argument rearrangement 37 | ;; * simplification: some inputs are consumed 38 | ;; * propagation: no inputs are consumed 39 | 40 | ;; A normalization rule only triggers if its output will be lexicographically 41 | ;; smaller than its input. 42 | ;; e.g., (b+a=c => a+b=c) only triggers if (a lex< b). 43 | ;; Rule definitions themselves should be automatically normalized as a 44 | ;; preprocessing step. For some rules, this normalization alone is enough to 45 | ;; match all normalized inputs. When this isn't enough, rules will 46 | ;; automatically try all permutations of candidate input arrangements. 47 | ;; e.g., (x+0=y => x=y) becomes (0+x=y -> x=y) due to (b+a=c -> a+b=c). 48 | ;; (-1+0=q) would fail to match the normalized rule, but this rule knows to 49 | ;; try permuting, giving (0+-1=q), which does match, yielding (-1=q). 50 | ;; This example assumes literal values are considered lex< variables. 51 | ;; By normalizing both predicates and rules, matches should be easier to find. 52 | ;; Ultimately, adding rearrangement rules will never result in fewer matches, 53 | ;; and will not risk looping. 54 | 55 | ;; state = 56 | ;; Instead of , we have something more like 57 | ;; Accumulated knowledge is idempotent. This may mean that we need less 58 | ;; propagation history to avoid trivial nontermination. 59 | ;; Accumulated knowledge may have a fancy representation for efficiency. 60 | ;; e.g., idempotent substitution and constraint store 61 | ;; Before moving onto the next, each new predicate is tested against all 62 | ;; relevant rule heads (in prioritized order), stopping and firing at the first 63 | ;; match. Outputs from the matched rule may be processed before remaining new 64 | ;; predicates (LIFO). In fact, it's possible that all new predicates will be 65 | ;; ordered arbitrarily, for efficiency (e.g., processing == first). 66 | ;; mechanism for detecting loops isn't available, a matched rule may be added 67 | ;; to recent-history to detect and reject later matches. 68 | 69 | ;; Incomplete example (several more rules should probably be added) 70 | (rule (add-interpret1 a b c) 71 | (known a) (known b) & (+ a b c) => (= ,(,+ a b) c)) 72 | (rule (add-interpret2 a b c) 73 | (known a) (known c) & (+ a b c) => (= ,(,- c a) b)) 74 | (rule (add-commutativity a b c) 75 | & (+ b a c) => (+ a b c)) ;; & is optional when no statics are present. 76 | (rule (add-reflexivity-right a b c d) 77 | (+ a b c) & (+ a b d) => (= c d)) ;; notice that normalization makes commutative permutation unnecessary in this case. 78 | (rule (add-reflexivity-left a b c d) 79 | (+ a b d) & (+ a c d) => (= b c)) 80 | (rule (add-associativity a b c d e f) 81 | (known a) (known d) (+ a b c) & (+ c d e) => (+ a d f) (+ b f e)) 82 | (rule (add-identity a b) 83 | (+ a 0 b) => (= a b)) ;; preprocessing should normalize this rule. 84 | (rule (add-double a b) 85 | (+ a a b) => (* 2 a b)) 86 | 87 | (rule (mul-interpret1 a b c) 88 | (known a) (known b) & (* a b c) => (= ,(,* a b) c)) 89 | (rule (mul-interpret2 a b c) 90 | (known a) (known c) (=/= 0 a) & (* a b c) => (= ,(,/ c a) c)) 91 | (rule (mul-commutativity a b c) 92 | (* b a c) => (* a b c)) 93 | (rule (mul-reflexivity a b c d) 94 | (* a b c) (* a b d) & => (= c d)) 95 | (rule (mul-associativity a b c d e f) 96 | (known a) (known d) (* a b c) & (* c d e) => (* a d f) (* b f e)) 97 | (rule (mul-identity a b) 98 | (* 1 a b) => (= a b)) 99 | (rule (mul-zero a b) 100 | (* 0 a b) => (= 0 b)) 101 | -------------------------------------------------------------------------------- /lattice/algebra.scm: -------------------------------------------------------------------------------- 1 | (define-syntax defrecord 2 | (syntax-rules () 3 | ((_ name name?) 4 | (begin 5 | (define name (vector 'name)) 6 | (define (name? datum) (eq? name datum)))) 7 | ((_ name name? (field set-field) ...) 8 | (begin 9 | (define (name field ...) (vector 'name field ...)) 10 | (define (name? datum) 11 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 12 | (let () 13 | (define (range-assoc start xs) 14 | (let loop ((xs xs) (idx start)) 15 | (if (null? xs) 16 | '() 17 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 18 | (define (define-field-getter name rassc) 19 | (define idx (cdr (assoc name rassc))) 20 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 21 | (define (define-field-setter name rassc) 22 | (define idx (cdr (assoc name rassc))) 23 | (eval `(define (,name datum value) 24 | (let ((new (vector-copy datum))) 25 | (vector-set! new ,idx value) 26 | new)))) 27 | (let ((fns (range-assoc 1 '(field ...)))) 28 | (begin (define-field-getter 'field fns) ...)) 29 | (let ((set-fns (range-assoc 1 '(set-field ...)))) 30 | (begin (define-field-setter 'set-field set-fns) ...))))) 31 | ((_ name name? field ...) 32 | (begin 33 | (define (name field ...) (vector 'name field ...)) 34 | (define (name? datum) 35 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 36 | (let () 37 | (define (range-assoc start xs) 38 | (let loop ((xs xs) (idx start)) 39 | (if (null? xs) 40 | '() 41 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 42 | (define (define-field-getter name rassc) 43 | (define idx (cdr (assoc name rassc))) 44 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 45 | (let ((fns (range-assoc 1 '(field ...)))) 46 | (begin (define-field-getter 'field fns) ...))))))) 47 | 48 | (defrecord var var? var-index) 49 | (define (var=? t1 t2) 50 | (and (var? t1) (var? t2) (eqv? (var-index t1) (var-index t2)))) 51 | (define (var V = U^W 164 | ;; U - V = W <-> U = W + V 165 | ;; U^2 = V <-> U = +-(sqrt V) 166 | ;; (U + V) * ( U - V) <-> U^2 - V^2 167 | ;; U*V + U*W <-> U * (V + W) 168 | ;; (log W U) + (log W V) <-> (log W (U * V)) 169 | ;; (W^U)^V <-> W^(U*V) 170 | 171 | ;; assumptions: 172 | ;; 1) term being rewritten is least dominating in x 173 | ;; 2) U and V contain x 174 | ;; 3) no other parts contain x 175 | ;; 176 | ;; attraction methods (move occurrences of x closer together) 177 | ;; 178 | ;; W*U + W*V --> W * (U + V) 179 | ;; (log W U) + (log W V) --> (log W (U * V)) 180 | ;; (W^U)^V --> W^(U*V) 181 | ;; U^(V*W) --> (U^V)^W 182 | ;; 183 | ;; collection methods (reduce number of occurrences of x) 184 | ;; 185 | ;; (U + V) * (U - V) --> U^2 - V^2 186 | ;; U*W + U*Y --> U * (W + Y) 187 | ;; 188 | ;; isolation methods (reduce depth of occurrences of x) 189 | ;; 190 | ;; (log W U) = Y --> U = W^Y 191 | ;; U - W = Y --> U = Y + w 192 | ;; U^2 = W --> U = +-(sqrt W) 193 | -------------------------------------------------------------------------------- /lch.scm: -------------------------------------------------------------------------------- 1 | ;; Lattice-based constraint handling 2 | 3 | ;; Approximate orthogonality: 4 | ;; It should be possible to plug in new lattice components without 5 | ;; invalidating existing rules, but those rules may be incomplete on their own 6 | ;; with respect to new components (i.e., too conservative, not noticing some 7 | ;; new unsatisfiable situations). Specifying additional "glue" rules to cover 8 | ;; new combinations should help reduce new sources of incompleteness. 9 | 10 | ;; Supported typed lattices: 11 | ;; * bottom: nothing, represents failure 12 | ;; * singleton: #t, #f, () 13 | ;; * symbol: 14 | ;; finite complement domain (fcd) 15 | ;; > finite domain 16 | ;; > singleton 17 | ;; * number: 18 | ;; int? + numeric-set + arithmetic 19 | ;; > singleton 20 | ;; * pair: 21 | ;; car, cdr sub-lattices + finite complement shape domain + absents 22 | ;; > car, cdr sub-lattices + finite shape domain 23 | ;; > singleton + released finite [complement] shape constraints 24 | ;; * type-union: join of typed lattices 25 | ;; * top: anything 26 | 27 | ;; Supported constraints: 28 | ;; ==, =/=, typeo, integero, +o, *o, <=o 29 | 30 | ;; Finite control operators: 31 | ;; finite-and, finite-or, finite-xor, finite-not 32 | ;; Behind the scenes, these will meet, join, and complement the lattices 33 | ;; involved. In some cases, this works well enough to eliminate the need for 34 | ;; search. Even when search is necessary, approximate constraints can be given 35 | ;; and applied deterministically. Since the purpose is to notice ASAP when 36 | ;; constraints become unsatisfiable, and not to provide a generative model, 37 | ;; search can be lazy, stopping at the first instance of satisfaction. Ideally 38 | ;; we would use watched variables to trigger resumption of satisfiability 39 | ;; checking only on demand. 40 | 41 | ;; These constraints can be expressed with finite control operators: 42 | ;; (not-betweeno x a b): (finite-xor (<=o x a) (<=o b x)) 43 | ;; (withino x a b): (finite-and (<=o a x) (<=o x b)) 44 | 45 | ;; Worries: 46 | ;; Is this going to end up gravitating towards being a general SMT solver? 47 | 48 | (define-syntax defrecord 49 | (syntax-rules () 50 | ((_ name name?) 51 | (begin 52 | (define name (vector 'name)) 53 | (define (name? datum) (eq? name datum)))) 54 | ((_ name name? (field set-field) ...) 55 | (begin 56 | (define (name field ...) (vector 'name field ...)) 57 | (define (name? datum) 58 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 59 | (let () 60 | (define (range-assoc start xs) 61 | (let loop ((xs xs) (idx start)) 62 | (if (null? xs) 63 | '() 64 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 65 | (define (define-field-getter name rassc) 66 | (define idx (cdr (assoc name rassc))) 67 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 68 | (define (define-field-setter name rassc) 69 | (define idx (cdr (assoc name rassc))) 70 | (eval `(define (,name datum value) 71 | (let ((new (vector-copy datum))) 72 | (vector-set! new ,idx value) 73 | new)))) 74 | (let ((fns (range-assoc 1 '(field ...)))) 75 | (begin (define-field-getter 'field fns) ...)) 76 | (let ((set-fns (range-assoc 1 '(set-field ...)))) 77 | (begin (define-field-setter 'set-field set-fns) ...))))) 78 | ((_ name name? field ...) 79 | (begin 80 | (define (name field ...) (vector 'name field ...)) 81 | (define (name? datum) 82 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 83 | (let () 84 | (define (range-assoc start xs) 85 | (let loop ((xs xs) (idx start)) 86 | (if (null? xs) 87 | '() 88 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 89 | (define (define-field-getter name rassc) 90 | (define idx (cdr (assoc name rassc))) 91 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 92 | (let ((fns (range-assoc 1 '(field ...)))) 93 | (begin (define-field-getter 'field fns) ...))))))) 94 | 95 | (define finite-set-empty '()) 96 | 97 | (define top #t) 98 | (define (top? a) (eq? top a)) 99 | (defrecord type-union type-union? 100 | tu-pair tu-symbol tu-number tu-nil tu-false tu-true) 101 | (defrecord type-pair type-pair? 102 | type-pair-car 103 | type-pair-cdr 104 | type-pair-complement-fd? 105 | type-pair-fd 106 | type-pair-absents) 107 | (defrecord type-symbol type-symbol? 108 | type-symbol-complement-fd? 109 | type-symbol-fd) 110 | (defrecord type-number type-number? 111 | type-number-integer? 112 | type-number-set 113 | type-number-arithmetic) 114 | (defrecord singleton singleton? singleton-value) 115 | (define bottom #f) 116 | (define bottom? not) 117 | 118 | ;; These are only intended as intermediate states for lattices. Simplification 119 | ;; will convert full lattices to top and empty lattices to bottom. 120 | (define type-union-full (type-union top top top top top top)) 121 | (define type-union-empty 122 | (type-union bottom bottom bottom bottom bottom bottom)) 123 | (define type-pair-full 124 | (type-pair top top #t finite-set-empty finite-set-empty)) 125 | (define type-pair-empty 126 | (type-pair bottom bottom #f finite-set-empty finite-set-empty)) 127 | (define type-symbol-full (type-symbol #t finite-set-empty)) 128 | (define type-symbol-empty (type-symbol #f finite-set-empty)) 129 | (define type-number-full 130 | (type-number #f numeric-set-full finite-set-empty)) 131 | (define type-number-empty 132 | (type-number #f numeric-set-empty finite-set-empty)) 133 | 134 | (define (simplify nested? a) 135 | (cond 136 | ((type-union? a) 137 | (let ((tu (type-union 138 | (simplify #t (tu-pair a)) 139 | (simplify #t (tu-symbol a)) 140 | (simplify #t (tu-number a)) 141 | (tu-nil a) 142 | (tu-false a) 143 | (tu-true a)))) 144 | (cond 145 | ((equal? type-union-full tu) top) 146 | ((equal? type-union-empty tu) bottom) 147 | (else tu)))) 148 | ((type-pair? a) 149 | (let ((tp-car (simplify #t (type-pair-car a))) 150 | (tp-cdr (simplify #t (type-pair-cdr a)))) 151 | (cond 152 | ((and nested? (equal? type-pair-full a)) top) 153 | ((or (bottom? tp-car) (bottom? tp-cdr)) bottom) 154 | (else (type-pair 155 | tp-car 156 | tp-cdr 157 | (type-pair-complement-fd? a) 158 | (type-pair-fd a) 159 | (type-pair-absents a)))))) 160 | ((type-symbol? a) 161 | (cond 162 | ((and nested? (equal? type-symbol-full a)) top) 163 | ((equal? type-symbol-empty a) bottom) 164 | (else a))) 165 | ((type-number? a) 166 | (cond 167 | ((and nested? (equal? type-number-full a)) top) 168 | ((equal? numeric-set-empty (type-number-set a)) bottom) 169 | (else a))) 170 | (else a))) 171 | -------------------------------------------------------------------------------- /dkanren-simple-interp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | "dkanren.rkt" 4 | ) 5 | 6 | (module+ test 7 | (require 8 | rackunit 9 | ) 10 | 11 | (require racket/pretty) 12 | (define-syntax test 13 | (syntax-rules () 14 | ((_ name expr expected) 15 | (let ((actual expr)) 16 | (when (not (equal? actual expected)) 17 | (display name) 18 | (newline) 19 | (pretty-print actual) 20 | (newline)) 21 | (check-equal? actual expected))))) 22 | 23 | (define-syntax test-time 24 | (syntax-rules () 25 | ((_ test-name query expected) 26 | (begin 27 | (displayln test-name) 28 | (time (test test-name query expected)))))) 29 | 30 | (define-syntax test-any 31 | (syntax-rules () 32 | ((_ name expr expecteds) 33 | (let* ((actual expr) 34 | (found (member actual expecteds)) 35 | (expected (if (not found) (car expecteds) (car found)))) 36 | (test name actual expected))))) 37 | (define-syntax test-time-any 38 | (syntax-rules () 39 | ((_ name body ...) 40 | (begin 41 | (displayln name) 42 | (time (test-any name body ...)))))) 43 | ) 44 | 45 | (define closure-tag (gensym "#%closure")) 46 | 47 | (define (si body) 48 | `(letrec 49 | ((eval 50 | (lambda (expr env) 51 | (let ((bound? (lambda (sym) (in-env? sym env)))) 52 | (match expr 53 | (`(,(and 'quote (not (? bound?))) ,(? quotable? datum)) datum) 54 | (`(,(and 'list (not (? bound?))) . ,a*) (proper-list a* env)) 55 | ((symbol) (lookup expr env)) 56 | (`(,(and op (or (not (symbol)) (? bound?))) ,rand) 57 | (match (eval op env) 58 | (`(,(? ct?) ,x ,body ,env^) 59 | (eval body `((,x . ,(eval rand env)) . ,env^))))) 60 | (`(lambda (,(symbol x)) ,body) 61 | (list ',closure-tag x body env)))))) 62 | 63 | (in-env? (lambda (x env) 64 | (match/lazy env 65 | ('() #f) 66 | (`((,a . ,_) . ,d) 67 | (or (equal? x a) (in-env? x d)))))) 68 | 69 | (lookup (lambda (x env) 70 | (match env 71 | (`((,y . ,v) . ,rest) 72 | (if (equal? x y) 73 | v 74 | (lookup x rest)))))) 75 | 76 | (ct? (lambda (datum) (equal? ',closure-tag datum))) 77 | 78 | (quotable? 79 | (lambda (datum) 80 | (match/lazy datum 81 | (',closure-tag #f) 82 | (`(,a . ,d) (and (quotable? a) (quotable? d))) 83 | (_ #t)))) 84 | 85 | (proper-list 86 | (lambda (expr env) 87 | (match expr 88 | ;; TODO: ultimately, this clause should be: ('() '()) 89 | ;; Until quotas are enforced, we obfuscate the rhs to prevent 90 | ;; unbounded deterministic elimination of this clause. 91 | ('() (car (list '()))) 92 | (`(,a . ,d) `(,(eval a env) . ,(proper-list d env))))))) 93 | ,body)) 94 | 95 | (define (evalo expr result) (dk-evalo (si `(eval ',expr '())) result)) 96 | 97 | (define quinec 98 | '((lambda (_.0) 99 | (list _.0 (list (quote quote) _.0))) 100 | (quote 101 | (lambda (_.0) 102 | (list _.0 (list (quote quote) _.0)))))) 103 | 104 | (define twine1 105 | '((lambda (_.0) (list 'quote (list _.0 (list 'quote _.0)))) 106 | '(lambda (_.0) (list 'quote (list _.0 (list 'quote _.0)))))) 107 | (define twine0 (list 'quote twine1)) 108 | 109 | (define thrine2 110 | '((lambda (_.0) (list 'quote (list 'quote (list _.0 (list 'quote _.0))))) 111 | '(lambda (_.0) (list 'quote (list 'quote (list _.0 (list 'quote _.0))))))) 112 | (define thrine1 (list 'quote thrine2)) 113 | (define thrine0 (list 'quote thrine1)) 114 | 115 | (module+ test 116 | (test "quote" 117 | (run* (q) (evalo '(quote 5) q)) 118 | '((5))) 119 | 120 | (test "list" 121 | (run* (q) (evalo '(list '5 (list '4 '3)) q)) 122 | '(((5 (4 3))))) 123 | 124 | (test "lambda" 125 | (run* (q) (evalo '(lambda (x) x) q)) 126 | `(((,closure-tag x x ())))) 127 | 128 | (test "application-1" 129 | (run* (q) (evalo '((lambda (x) x) '2) q)) 130 | '((2))) 131 | 132 | (test "application-2" 133 | (run* (q) (evalo '(((lambda (x) (lambda (y) x)) '1) '2) q)) 134 | '((1))) 135 | 136 | (test-time "quine parts" 137 | (run 1 (q) (evalo 138 | `((lambda (x) (list x ,q)) 139 | (quote 140 | (lambda (x) (list x ,q)))) 141 | `((lambda (x) (list x ,q)) 142 | (quote 143 | (lambda (x) (list x ,q)))))) 144 | '(((list (quote quote) x)))) 145 | 146 | (test-time "quine more parts" 147 | (run 1 (q) (evalo 148 | `((lambda (x) ,q) 149 | (quote (lambda (x) ,q))) 150 | `((lambda (x) ,q) 151 | (quote (lambda (x) ,q))))) 152 | '(((list x (list (quote quote) x))))) 153 | 154 | ;; TODO: reify constraints on _.0 155 | 156 | (test-time "quine full" 157 | (run 1 (q) (evalo q q)) 158 | `((,quinec))) 159 | 160 | (test-time-any "twine" 161 | (run 1 (p q) (=/= p q) (evalo p q) (evalo q p)) 162 | `(((,twine0 ,twine1)) 163 | ((,twine1 ,twine0)))) 164 | 165 | (test-time-any "thrine" 166 | (run 1 (p q r) (=/= p q) (=/= q r) (=/= r p) 167 | (evalo p q) (evalo q r) (evalo r p)) 168 | `(((,thrine0 ,thrine1 ,thrine2)) 169 | ((,thrine2 ,thrine0 ,thrine1)) 170 | ((,thrine1 ,thrine2 ,thrine0)))) 171 | 172 | ;(time 173 | ;(test "tetrine" 174 | ;(run 1 (p q r s) (=/= s p) (=/= s q) (=/= s r) (=/= p q) (=/= q r) (=/= r p) 175 | ;(evalo p q) (evalo q r) (evalo r s) (evalo s p)) 176 | ;`(ok))) 177 | ;(time 178 | ;(test "pentine" 179 | ;(run 1 (p q r s t) (=/= t p) (=/= t q) (=/= t r) (=/= t s) (=/= s p) (=/= s q) (=/= s r) (=/= p q) (=/= q r) (=/= r p) 180 | ;(evalo p q) (evalo q r) (evalo r s) (evalo s t) (evalo t p)) 181 | ;`(ok))) 182 | ;(time 183 | ;(test "hexine" 184 | ;(run 1 (p q r s t u) (=/= u p) (=/= u q) (=/= u r) (=/= u s) (=/= u t) (=/= t p) (=/= t q) (=/= t r) (=/= t s) (=/= s p) (=/= s q) (=/= s r) (=/= p q) (=/= q r) (=/= r p) 185 | ;(evalo p q) (evalo q r) (evalo r s) (evalo s t) (evalo t u) (evalo u p)) 186 | ;`(ok))) 187 | ;(time 188 | ;(test "heptine" 189 | ;(run 1 (p q r s t u v) (=/= v p) (=/= v q) (=/= v r) (=/= v s) (=/= v t) (=/= v u) (=/= u p) (=/= u q) (=/= u r) (=/= u s) (=/= u t) (=/= t p) (=/= t q) (=/= t r) (=/= t s) (=/= s p) (=/= s q) (=/= s r) (=/= p q) (=/= q r) (=/= r p) 190 | ;(evalo p q) (evalo q r) (evalo r s) (evalo s t) (evalo t u) (evalo u v) (evalo v p)) 191 | ;`(ok))) 192 | ;(time 193 | ;(test "octine" 194 | ;(run 1 (p q r s t u v w) (=/= w p) (=/= w q) (=/= w r) (=/= w s) (=/= w t) (=/= w u) (=/= w v) (=/= v p) (=/= v q) (=/= v r) (=/= v s) (=/= v t) (=/= v u) (=/= u p) (=/= u q) (=/= u r) (=/= u s) (=/= u t) (=/= t p) (=/= t q) (=/= t r) (=/= t s) (=/= s p) (=/= s q) (=/= s r) (=/= p q) (=/= q r) (=/= r p) 195 | ;(evalo p q) (evalo q r) (evalo r s) (evalo s t) (evalo t u) (evalo u v) (evalo v w) (evalo w p)) 196 | ;`(ok))) 197 | ) 198 | -------------------------------------------------------------------------------- /generate.scm: -------------------------------------------------------------------------------- 1 | (load "transparent-evalo.scm") 2 | 3 | ;; Max term size is roughly 2^max-term-depth. 4 | (define max-term-depth 2) 5 | 6 | (define lvars 7 | (list ;(var -100) (var -101) (var -102) 8 | )) 9 | 10 | (define atoms 11 | '(() #t #f s quote app var lambda list cons car cdr closure 1 x y)) 12 | 13 | (define-relation (element-from xs x) 14 | (fresh (next rest) 15 | (== `(,next . ,rest) xs) 16 | (conde 17 | ((== next x)) 18 | ((element-from rest x))))) 19 | 20 | (define-relation (term m n x) 21 | (if (<= m n) 22 | (conde 23 | ;; Reorder clauses to control frequency of occurrence. 24 | ((== 1 n) (element-from atoms x)) 25 | ((== 1 n) (element-from lvars x)) ;; Comment this out to disable vars. 26 | ((fresh (a d) 27 | (== `(,a . ,d) x) 28 | (term 1 (- n 1) a) 29 | (term 1 (- n 1) d))) 30 | ((fresh (a d) 31 | (== `(,a . ,d) x) 32 | (term 1 (- n 1) d) 33 | (term 2 (- n 1) a))) 34 | ((term m (- n 1) x)) ;; Remove this clause to enable extreme bushiness. 35 | ) 36 | fail)) 37 | 38 | (define-relation (list-of domain xs) 39 | (conde 40 | ((== '() xs)) 41 | ((fresh (a d) 42 | (== `(,a . ,d) xs) 43 | (domain a) 44 | (list-of domain d))))) 45 | 46 | (define (term-list n xs) (list-of (lambda (x) (term 1 n x)) xs)) 47 | (define (vref x) (list-of (lambda (x) (== 's x)) x)) 48 | 49 | (define-relation (example-lookupo x) 50 | (fresh (index env value) 51 | (== `(lookupo ,index ,env ,value) x) 52 | (vref index) 53 | (term-list max-term-depth env) 54 | (term 1 max-term-depth value))) 55 | 56 | (define-relation (example-eval-expo x) 57 | (fresh (expr env value) 58 | (== `(eval-expo ,expr ,env ,value) x) 59 | (term 1 max-term-depth expr) 60 | (term-list max-term-depth env) 61 | (term 1 max-term-depth value))) 62 | 63 | (define-relation (example-eval-listo x) 64 | (fresh (e* env value) 65 | (== `(eval-listo ,e* ,env ,value) x) 66 | (term-list max-term-depth e*) 67 | (term-list max-term-depth env) 68 | (term 1 max-term-depth value))) 69 | 70 | (define-relation (example-== x) 71 | (conde 72 | ((fresh (a d) 73 | (== `(== ,a ,d) x) 74 | (term 1 max-term-depth a) 75 | (term 1 max-term-depth d))) 76 | ((fresh (a d) 77 | (== `(== ,a ,d) x) 78 | (term 1 max-term-depth d) 79 | (term 2 max-term-depth a))))) 80 | 81 | (define (examples count generate) 82 | (define (test example) 83 | (eval (cons (car example) (map (lambda (x) `(quote ,x)) (cdr example))))) 84 | (define inputs (map car (run count (x) (generate x)))) 85 | (map 86 | (lambda (i) `(,(if (null? (run 1 (q) (test i))) 0 1) ,i)) 87 | inputs)) 88 | 89 | 90 | ;; Lazy example streaming 91 | 92 | (define examples-current '()) 93 | 94 | (define (examples-start generate) 95 | (set! examples-current (query (i) (generate i)))) 96 | 97 | (define (examples-next k) 98 | (define (test example) 99 | (eval (cons (car example) (map (lambda (x) `(quote ,x)) (cdr example))))) 100 | (and (not (null? examples-current)) 101 | (let ((next (stream-next examples-current))) 102 | (and (pair? next) 103 | (set! examples-current (cdr next)) 104 | (let ((input (car (walk* (car next) var-initial)))) 105 | (k `(,(if (null? (run 1 (q) (test input))) 0 1) ,input))) 106 | #t)))) 107 | 108 | 109 | ;; Stream unification examples 110 | 111 | (examples-start example-==) 112 | 113 | (define (print-reified x) (printf "~s\n" (reify 0 state-empty x))) 114 | (define (print-==-as-branch x) 115 | (define branch-var (var -200)) 116 | (when (= 0 (car x)) 117 | (let ((a (cadr (cadr x))) 118 | (c (caddr (cadr x)))) 119 | (print-reified 120 | `(conj (== ,branch-var ,a) 121 | (disj (== ,branch-var ,a) (== ,branch-var ,c))))))) 122 | (define (print-==-as-branch2 x) 123 | (define branch-var1 (var -200)) 124 | (define branch-var2 (var -201)) 125 | (when (= 0 (car x)) 126 | (let ((a (cadr (cadr x))) 127 | (c (caddr (cadr x)))) 128 | (print-reified 129 | `(conj (== (,branch-var1 . ,a) (,branch-var2 . ,branch-var2)) 130 | (disj (== ,branch-var2 ,a) (== ,branch-var1 ,c))))))) 131 | (define (print-==-as-branch3-left x) 132 | (define branch-var1 (var -200)) 133 | (define branch-var2 (var -201)) 134 | (define branch-var3 (var -202)) 135 | (when (= 0 (car x)) 136 | (let ((a (cadr (cadr x))) 137 | (c (caddr (cadr x)))) 138 | ;; left (== var1 var3) 139 | (print-reified 140 | `(conj (== (,branch-var1 . (,a . ,c)) 141 | (,branch-var3 . (,branch-var1 . ,branch-var2))) 142 | (disj (== ,branch-var3 ,a) (== ,branch-var1 ,c)))) 143 | ;; left (== var1 var3) 144 | (print-reified 145 | `(conj (== (,branch-var1 . (,a . ,c)) 146 | (,branch-var3 ,branch-var2 . (,branch-var2 . ,branch-var1))) 147 | (disj (== ,branch-var3 ,c) (== ,branch-var1 ,a)))) 148 | ;; left (== var1 var3) 149 | (print-reified 150 | `(conj (== (,branch-var1 . (,a . ,c)) 151 | (,branch-var3 . (,branch-var1 . ,branch-var2))) 152 | (disj (== ,branch-var1 ,a) (== ,branch-var3 ,c)))) 153 | ;; left (== var1 var3) 154 | (print-reified 155 | `(conj (== (,branch-var1 . (,a . ,c)) 156 | (,branch-var3 ,branch-var2 . (,branch-var2 . ,branch-var1))) 157 | (disj (== ,branch-var1 ,c) (== ,branch-var3 ,a)))) 158 | ;; left (var3 is fresh) 159 | (print-reified 160 | `(conj (== (,branch-var1 . (,a . ,c)) 161 | (,branch-var1 . (,branch-var1 . ,branch-var2))) 162 | (disj (== ,branch-var3 ,c) (== ,branch-var1 ,c)))) 163 | ;; left (var3 is fresh) 164 | (print-reified 165 | `(conj (== (,branch-var1 . (,a . ,c)) 166 | (,branch-var1 . (,branch-var1 . ,branch-var2))) 167 | (disj (== ,branch-var3 ,a) (== ,branch-var2 ,a)))) 168 | ;; left (var3 is fresh) 169 | (print-reified 170 | `(conj (== (,branch-var1 . (,a . ,c)) 171 | (,branch-var1 . (,branch-var1 . ,branch-var2))) 172 | (disj (== ,branch-var1 ,branch-var3) (== ,branch-var2 ,branch-var1)))) 173 | ;; left (== var3 var1) 174 | (print-reified 175 | `(conj (== (,branch-var1 . (,a . ,c)) 176 | (,branch-var3 . (,branch-var1 . ,branch-var2))) 177 | (disj (== ,branch-var2 ,branch-var3) (== ,branch-var3 ,branch-var1)))) 178 | ))) 179 | 180 | (define (print-==-as-branch3-right x) 181 | (define branch-var1 (var -200)) 182 | (define branch-var2 (var -201)) 183 | (define branch-var3 (var -202)) 184 | (when (= 0 (car x)) 185 | (let ((a (cadr (cadr x))) 186 | (c (caddr (cadr x)))) 187 | ;; right (== var1 var3) 188 | (print-reified 189 | `(conj (== (,branch-var1 . (,a . ,c)) 190 | (,branch-var3 ,branch-var2 . (,branch-var2 . ,branch-var1))) 191 | (disj (== ,branch-var3 ,a) (== ,branch-var1 ,c)))) 192 | ;; right (== var1 var3) 193 | (print-reified 194 | `(conj (== (,branch-var1 . (,a . ,c)) 195 | (,branch-var3 . (,branch-var1 . ,branch-var2))) 196 | (disj (== ,branch-var3 ,c) (== ,branch-var1 ,a)))) 197 | ;; right (== var1 var3) 198 | (print-reified 199 | `(conj (== (,branch-var1 . (,a . ,c)) 200 | (,branch-var3 ,branch-var2 . (,branch-var2 . ,branch-var1))) 201 | (disj (== ,branch-var1 ,a) (== ,branch-var3 ,c)))) 202 | ;; right (== var1 var3) 203 | (print-reified 204 | `(conj (== (,branch-var1 . (,a . ,c)) 205 | (,branch-var3 . (,branch-var1 . ,branch-var2))) 206 | (disj (== ,branch-var1 ,c) (== ,branch-var3 ,a)))) 207 | ;; right (var3 is fresh) 208 | (print-reified 209 | `(conj (== (,branch-var1 . (,a . ,c)) 210 | (,branch-var1 . (,branch-var1 . ,branch-var2))) 211 | (disj (== ,branch-var1 ,c) (== ,branch-var3 ,c)))) 212 | ;; right (var3 is fresh) 213 | (print-reified 214 | `(conj (== (,branch-var1 . (,a . ,c)) 215 | (,branch-var1 . (,branch-var1 . ,branch-var2))) 216 | (disj (== ,branch-var2 ,a) (== ,branch-var3 ,a)))) 217 | ;; right (var3 is fresh) 218 | (print-reified 219 | `(conj (== (,branch-var1 . (,a . ,c)) 220 | (,branch-var1 . (,branch-var1 . ,branch-var2))) 221 | (disj (== ,branch-var1 ,branch-var2) (== ,branch-var3 ,branch-var1)))) 222 | ;; right (== var3 var2) 223 | (print-reified 224 | `(conj (== (,branch-var2 . (,a . ,c)) 225 | (,branch-var3 . (,branch-var1 . ,branch-var2))) 226 | (disj (== ,branch-var2 ,branch-var3) (== ,branch-var3 ,branch-var1)))) 227 | ))) 228 | 229 | ;; Optionally set n to the number of desired examples. 230 | (let loop ((n #f)) 231 | (if (and n (= 0 n)) 232 | #f 233 | (begin 234 | (and (examples-next print-==-as-branch3-left) 235 | (loop (and n (- n 1))))))) 236 | -------------------------------------------------------------------------------- /lattice/real-set.scm: -------------------------------------------------------------------------------- 1 | (load "list.scm") 2 | (load "ordered-set.scm") 3 | 4 | ;; A real-set stores sorted, open intervals of the form (lb . ub) where lb 5 | ;; is the lower bound and ub is the upper bound. The bounds may be #f, 6 | ;; representing negative and positive infinity, depending on which side they 7 | ;; are placed. Individual numbers are stored sorted alongside the intervals, 8 | ;; and these represent included points. e.g., the set (2 (4 . 8) 8 (10 . f)) 9 | ;; represents a union of the point or the closed interval [2 2] with the 10 | ;; half-closed interval (4 8] and the open interval (10 +infinity), i.e., all 11 | ;; numbers x such that either x = 2 OR 4 < x <= 8 OR 10 < x). 12 | (define interval-full '(#f . #f)) 13 | (define (interval-complement x) 14 | (cond 15 | ((equal? interval-full x) '()) 16 | ((number? x) `((#f . ,x) (,x . #f))) 17 | ((not (car x)) `(,(cdr x) (,(cdr x) . #f))) 18 | ((not (cdr x)) `((#f . ,(car x)) ,(car x))) 19 | (else `((#f . ,(car x)) ,(car x) ,(cdr x) (,(cdr x) . #f))))) 20 | (define (interval-overlap-join a b) `(,(car a) . ,(cdr b))) 21 | (define (interval-overlap-meet a b) `(,(car b) . ,(cdr a))) 22 | 23 | (define (interval-compare a b 24 | lt 25 | lt-overlap 26 | a-in-b 27 | eq 28 | b-in-a 29 | gt-overlap 30 | gt) 31 | (cond 32 | ((and (number? a) (number? b)) 33 | (cond 34 | ((< a b) lt) 35 | ((> a b) gt) 36 | (else eq))) 37 | ((number? a) 38 | (let ((ba (car b)) (bd (cdr b))) 39 | (cond 40 | ((and ba (<= a ba)) lt) 41 | ((and bd (>= a bd)) gt) 42 | (else a-in-b)))) 43 | ((number? b) 44 | (let ((aa (car a)) (ad (cdr a))) 45 | (cond 46 | ((and aa (<= b aa)) gt) 47 | ((and ad (>= b ad)) lt) 48 | (else b-in-a)))) 49 | (else 50 | (let ((aa (car a)) (ad (cdr a)) (ba (car b)) (bd (cdr b))) 51 | (cond 52 | ((and (eqv? aa ba) (eqv? ad bd)) eq) 53 | ((number? aa) 54 | (cond 55 | ((and bd (>= aa bd)) gt) 56 | ((number? ad) 57 | (cond 58 | ((and ba (<= ad ba)) lt) 59 | ((and ba (<= aa ba)) 60 | (cond 61 | ((and bd (>= ad bd)) b-in-a) 62 | ((and ba (< aa ba)) lt-overlap) 63 | (else a-in-b))) 64 | ((and bd (> ad bd)) gt-overlap) 65 | (else a-in-b))) 66 | ((and ba (<= aa ba)) b-in-a) 67 | ((not bd) a-in-b) 68 | (else gt-overlap))) 69 | ((number? ad) 70 | (cond 71 | ((and bd (>= ad bd)) b-in-a) 72 | ((and ba (<= ad ba)) lt) 73 | ((not ba) a-in-b) 74 | (else lt-overlap))) 75 | (else b-in-a)))))) 76 | 77 | (define real-set-empty '()) 78 | (define real-set-full `(,interval-full)) 79 | 80 | (define (real-set-join a b) 81 | (define (loop a b) 82 | (cond 83 | ((null? a) b) 84 | ((null? b) a) 85 | (else 86 | (let ((ia (car a)) (ib (car b))) 87 | ((interval-compare 88 | ia ib 89 | (lambda () ;; lt 90 | (cons ia (loop (cdr a) b))) 91 | (lambda () ;; lt-overlap 92 | (loop (cdr a) (cons (interval-overlap-join ia ib) (cdr b)))) 93 | (lambda () ;; a-in-b 94 | (loop (cdr a) b)) 95 | (lambda () ;; eq 96 | (cons ia (loop (cdr a) (cdr b)))) 97 | (lambda () ;; b-in-a 98 | (loop (cdr b) a)) 99 | (lambda () ;; gt-overlap 100 | (loop (cdr b) (cons (interval-overlap-join ib ia) (cdr a)))) 101 | (lambda () ;; gt 102 | (cons ib (loop (cdr b) a))))))))) 103 | ;; Consolidate remaining adjacent interval-point-intervals. 104 | ;; (A . n) n (n . B) becomes (A . B) 105 | (let loop ((ns (loop a b))) 106 | (cond 107 | ((null? ns) ns) 108 | ((and (pair? (cdr ns)) (pair? (cddr ns)) 109 | (pair? (car ns)) (number? (cadr ns)) (pair? (caddr ns))) 110 | (let ((i0 (car ns)) (i1 (cadr ns)) (i2 (caddr ns))) 111 | (if (and (= (cdr i0) i1) (= i1 (car i2))) 112 | (loop (cons (cons (car i0) (cdr i2)) (cdddr ns))) 113 | (cons i0 (loop (cdr ns)))))) 114 | (else (cons (car ns) (loop (cdr ns))))))) 115 | 116 | (define (real-set-meet-interval x ns) 117 | (if (null? ns) 118 | '() 119 | (let ((i (car ns))) 120 | ((interval-compare 121 | x i 122 | (lambda () '()) ;; lt 123 | (lambda () (list (interval-overlap-meet x i))) ;; lt-overlap 124 | (lambda () (list x)) ;; a-in-b 125 | (lambda () (list x)) ;; eq 126 | (lambda () ;; b-in-a 127 | (cons i (real-set-meet-interval x (cdr ns)))) 128 | (lambda () ;; gt-overlap 129 | (cons (interval-overlap-meet i x) 130 | (real-set-meet-interval x (cdr ns)))) 131 | (lambda () ;; gt 132 | (real-set-meet-interval x (cdr ns)))))))) 133 | 134 | (define (real-set-meet a b) 135 | (list-foldr 136 | (lambda (x ns) 137 | (real-set-join (real-set-meet-interval x b) ns)) 138 | '() 139 | a)) 140 | 141 | (define (real-set-complement ns) 142 | (list-foldr real-set-meet real-set-full (map interval-complement ns))) 143 | 144 | 145 | (define (real-set< n) `((#f . ,n))) 146 | (define (real-set<= n) `((#f . ,n) ,n)) 147 | (define (real-set>= n) `(,n (,n . #f))) 148 | (define (real-set> n) `((,n . #f))) 149 | 150 | ;; Only use these for defining sets in terms of points. 151 | (define (real-set-with ns) (ordered-set ns)) 152 | (define (real-set-without ns) (real-set-complement (real-set-with ns))) 153 | 154 | (define (real-set-widen rs) 155 | (define fst (car rs)) 156 | (define lst (list-last rs)) 157 | (define lb (if (number? fst) fst (car fst))) 158 | (define ub (if (number? lst) lst (cdr lst))) 159 | (define suffix (cons (cons lb ub) (if (number? lst) (list ub) '()))) 160 | (if (number? fst) (cons lb suffix) suffix)) 161 | 162 | (define (real-set-cross combine cross as bs) 163 | (merge-sort 164 | real-set-join 165 | (list-foldr 166 | (lambda (a rss) 167 | (list-foldr (lambda (b rss) (combine (cross a b) rss)) rss bs)) 168 | '() as))) 169 | 170 | (define (interval+ a b) 171 | (define (ip+ i p) 172 | (cons (and (car i) (+ p (car i))) (and (cdr i) (+ p (cdr i))))) 173 | (if (number? a) 174 | (if (number? b) (+ a b) (ip+ b a)) 175 | (if (number? b) (ip+ a b) 176 | (cons (and (car a) (car b) (+ (car a) (car b))) 177 | (and (cdr a) (cdr b) (+ (cdr a) (cdr b))))))) 178 | (define (interval- a b) (interval+ a (if (number? b) (- b) (interval* b -1)))) 179 | 180 | (define (interval* a b) 181 | (define (ip* i p) 182 | (define ia (and (car i) (* p (car i)))) 183 | (define id (and (cdr i) (* p (cdr i)))) 184 | (cond ((< p 0) (cons id ia)) ((> p 0) (cons ia id)) (else 0))) 185 | (if (number? a) 186 | (if (number? b) (* a b) (ip* b a)) 187 | (if (number? b) (ip* a b) 188 | (let* ((al (car a)) 189 | (au (cdr a)) 190 | (bl (car b)) 191 | (bu (cdr b)) 192 | (apos? (and al (<= 0 al))) 193 | (aneg? (and au (<= au 0))) 194 | (bpos? (and bl (<= 0 bl))) 195 | (bneg? (and bu (<= bu 0)))) 196 | (if apos? 197 | (if bpos? (cons (* al bl) (and au bu (* au bu))) 198 | (if bneg? (cons (and au bl (* au bl)) (* al bu)) 199 | (cons (and au bl (* au bl)) (and au bu (* au bu))))) 200 | (if aneg? 201 | (if bpos? (cons (and al bu (* al bu)) (* au bl)) 202 | (if bneg? (cons (* au bu) (and al bl (* al bl))) 203 | (cons (and al bu (* al bu)) (and al bl (* al bl))))) 204 | (if bpos? 205 | (cons (and bu al (* bu al)) (and bu au (* bu au))) 206 | (if bneg? 207 | (cons (and bl au (* bl au)) (and bl al (* bl al))) 208 | (let ((nn (and al bl (* al bl))) 209 | (pp (and au bu (* au bu))) 210 | (np (and al bu (* al bu))) 211 | (pn (and au bl (* au bl)))) 212 | (cons (and np pn (min np pn)) (and nn pp (max nn pp)))))))))))) 213 | 214 | (define (interval-invert ival) 215 | (define (pinv p) (if p (/ 1 p) 0)) 216 | (cond 217 | ((eqv? 0 ival) '()) 218 | ((number? ival) (list (/ 1 ival))) 219 | (else 220 | (let ((lb (car ival)) (ub (cdr ival))) 221 | (cond 222 | ((or (and lb (< 0 lb)) (and ub (< ub 0))) 223 | (list (cons (pinv ub) (pinv lb)))) 224 | ((eqv? 0 lb) (list (cons (pinv ub) #f))) 225 | ((eqv? 0 ub) (list (cons #f (pinv lb)))) 226 | (else (real-set-join (list (cons #f (pinv lb))) 227 | (list (cons (pinv ub) #f))))))))) 228 | (define (interval/ a b) (real-set* (list a) (interval-invert b))) 229 | 230 | (define (real-set+ as bs) (real-set-cross cons interval+ as bs)) 231 | (define (real-set- as bs) (real-set-cross cons interval- as bs)) 232 | (define (real-set* as bs) (real-set-cross cons interval* as bs)) 233 | (define (real-set/ as bs) (real-set-cross append interval/ as bs)) 234 | -------------------------------------------------------------------------------- /dkanren-benchmarks/benchmarks.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (rename-in "lifted-closure-encoding.rkt" 5 | (term? term-lifted-closure?) 6 | (eval-term eval-term-lifted-closure) 7 | (initial-env initial-env-lifted-closure)) 8 | (rename-in "closure-encoding.rkt" 9 | (term? term-closure-encoded?) 10 | (eval-term eval-term-closure-encoded) 11 | (initial-env initial-env-closure-encoded)) 12 | (rename-in "raw.rkt" 13 | (term? term-raw?) 14 | (eval-term eval-term-raw) 15 | (initial-env initial-env-raw)) 16 | racket/list 17 | racket/match 18 | ) 19 | 20 | (define problem-iterations 100) 21 | (define problem-size 10) 22 | ;; Use this size to differentiate immediate and runtime scheme eval, but 23 | ;; remember to turn off the slow evaluators! 24 | ;(define problem-size 10000) 25 | 26 | (define (run/scheme-eval term) (eval term)) 27 | (define (run/raw-eval term) (eval-term-raw term initial-env-raw)) 28 | (define (run/closure-eval term) (eval-term-closure-encoded term initial-env-closure-encoded)) 29 | (define (run/lifted-closure-eval term) 30 | (let-values (((st v) ((eval-term-lifted-closure term initial-env-lifted-closure) #t))) 31 | v)) 32 | 33 | (define (run/scheme-eval-eval term) (run/eval-eval run/scheme-eval term)) 34 | (define (run/raw-eval-eval term) (run/eval-eval run/raw-eval term)) 35 | (define (run/closure-eval-eval term) (run/eval-eval run/closure-eval term)) 36 | (define (run/lifted-closure-eval-eval term) (run/eval-eval run/lifted-closure-eval term)) 37 | 38 | (define (run/eval-eval run/eval term) 39 | (run/eval 40 | `(let ((closure-tag ',(gensym "#%closure")) 41 | (prim-tag ',(gensym "#%primitive")) 42 | (empty-env '())) 43 | (let ((initial-env 44 | `((cons . (val . (,prim-tag . cons))) 45 | (car . (val . (,prim-tag . car))) 46 | (cdr . (val . (,prim-tag . cdr))) 47 | (null? . (val . (,prim-tag . null?))) 48 | (pair? . (val . (,prim-tag . pair?))) 49 | (symbol? . (val . (,prim-tag . symbol?))) 50 | (not . (val . (,prim-tag . not))) 51 | (equal? . (val . (,prim-tag . equal?))) 52 | (list . (val . (,closure-tag (lambda x x) ,empty-env))) 53 | . ,empty-env)) 54 | (closure-tag? (lambda (v) (equal? v closure-tag))) 55 | (prim-tag? (lambda (v) (equal? v prim-tag)))) 56 | (letrec 57 | ((applicable-tag? (lambda (v) (or (closure-tag? v) (prim-tag? v)))) 58 | (quotable? (lambda (v) 59 | (match v 60 | ((? symbol?) (not (applicable-tag? v))) 61 | (`(,a . ,d) (and (quotable? a) (quotable? d))) 62 | (_ #t)))) 63 | (not-in-params? (lambda (ps sym) 64 | (match ps 65 | ('() #t) 66 | (`(,a . ,d) 67 | (and (not (equal? a sym)) 68 | (not-in-params? d sym)))))) 69 | (param-list? (lambda (x) 70 | (match x 71 | ('() #t) 72 | (`(,(? symbol? a) . ,d) 73 | (and (param-list? d) (not-in-params? d a))) 74 | (_ #f)))) 75 | (params? (lambda (x) 76 | (match x 77 | ((? param-list?) #t) 78 | (x (symbol? x))))) 79 | (in-env? (lambda (env sym) 80 | (match env 81 | ('() #f) 82 | (`((,a . ,_). ,d) 83 | (or (equal? a sym) (in-env? d sym)))))) 84 | (extend-env* 85 | (lambda (params args env) 86 | (match `(,params . ,args) 87 | (`(() . ()) env) 88 | (`((,x . ,dx*) . (,a . ,da*)) 89 | (extend-env* dx* da* `((,x . (val . ,a)) . ,env)))))) 90 | (lookup 91 | (lambda (env sym) 92 | (match env 93 | (`((,y . ,b) . ,rest) 94 | (if (equal? sym y) 95 | (match b 96 | (`(val . ,v) v) 97 | (`(rec . ,lam-expr) `(,closure-tag ,lam-expr ,env))) 98 | (lookup rest sym)))))) 99 | (term? 100 | (lambda (term env) 101 | (letrec 102 | ((term1? (lambda (v) (term? v env))) 103 | (terms? (lambda (ts env) 104 | (match ts 105 | ('() #t) 106 | (`(,t . ,ts) 107 | (and (term? t env) (terms? ts env))))))) 108 | (match term 109 | (#t #t) 110 | (#f #t) 111 | ((? number?) #t) 112 | ((and (? symbol? sym)) (in-env? env sym)) 113 | (`(,(? term1?) . ,rands) (terms? rands env)) 114 | (`(quote ,datum) (quotable? datum)) 115 | (`(if ,c ,t ,f) (and (term1? c) (term1? t) (term1? f))) 116 | (`(lambda ,params ,body) 117 | (and (params? params) 118 | (let ((res 119 | (match params 120 | ((and (not (? symbol?)) params) 121 | (extend-env* params params env)) 122 | (sym `((,sym . (val . ,sym)) . ,env))))) 123 | (term? body res)))) 124 | (`(letrec 125 | ((,p-name ,(and `(lambda ,params ,body) lam-expr))) 126 | ,letrec-body) 127 | (and (params? params) 128 | (let ((res `((,p-name 129 | . (rec . (lambda ,params ,body))) 130 | . ,env))) 131 | (and (term? lam-expr res) 132 | (term? letrec-body res))))) 133 | (_ #f))))) 134 | (eval-prim 135 | (lambda (prim-id args) 136 | (match `(,prim-id . ,args) 137 | (`(cons ,a ,d) `(,a . ,d)) 138 | (`(car (,(and (not (? applicable-tag?)) a) . ,d)) a) 139 | (`(cdr (,(and (not (? applicable-tag?)) a) . ,d)) d) 140 | (`(null? ,v) (match v ('() #t) (_ #f))) 141 | (`(pair? ,v) (match v 142 | (`(,(not (? applicable-tag?)) . ,_) #t) 143 | (_ #f))) 144 | (`(symbol? ,v) (symbol? v)) 145 | (`(number? ,v) (number? v)) 146 | (`(not ,v) (match v (#f #t) (_ #f))) 147 | (`(equal? ,v1 ,v2) (equal? v1 v2))))) 148 | (eval-term-list 149 | (lambda (terms env) 150 | (match terms 151 | ('() '()) 152 | (`(,term . ,terms) 153 | `(,(eval-term term env) . ,(eval-term-list terms env)))))) 154 | (eval-term 155 | (lambda (term env) 156 | (let ((bound? (lambda (sym) (in-env? env sym))) 157 | (term1? (lambda (v) (term? v env)))) 158 | (match term 159 | (#t #t) 160 | (#f #f) 161 | ((? number? num) num) 162 | (`(,(and 'quote (not (? bound?))) ,(? quotable? datum)) 163 | datum) 164 | ((? symbol? sym) (lookup env sym)) 165 | ((and `(,op . ,_) operation) 166 | (match operation 167 | (`(,(or (? bound?) (not (? symbol?))) 168 | . ,rands) 169 | (let ((op (eval-term op env)) 170 | (a* (eval-term-list rands env))) 171 | (match op 172 | (`(,(? prim-tag?) . ,prim-id) 173 | (eval-prim prim-id a*)) 174 | (`(,(? closure-tag?) (lambda ,x ,body) ,env^) 175 | (let ((res (match x 176 | ((and (not (? symbol?)) params) 177 | (extend-env* params a* env^)) 178 | (sym `((,sym . (val . ,a*)) 179 | . ,env^))))) 180 | (eval-term body res)))))) 181 | (`(if ,condition ,alt-true ,alt-false) 182 | (if (eval-term condition env) 183 | (eval-term alt-true env) 184 | (eval-term alt-false env))) 185 | (`(lambda ,params ,body) 186 | `(,closure-tag (lambda ,params ,body) ,env)) 187 | (`(letrec ((,p-name (lambda ,params ,body))) 188 | ,letrec-body) 189 | (eval-term 190 | letrec-body 191 | `((,p-name . (rec . (lambda ,params ,body))) 192 | . ,env)))))))))) 193 | 194 | (let ((program ',term)) (eval-term program initial-env))))))) 195 | 196 | (define ex-append 197 | `(letrec ((append 198 | (lambda (xs ys) 199 | (if (null? xs) ys (cons (car xs) (append (cdr xs) ys)))))) 200 | (list . ,(make-list problem-iterations 201 | `(append ',(range problem-size) '()))))) 202 | (define ex-reverse-quadratic 203 | `(letrec ((append 204 | (lambda (xs ys) 205 | (if (null? xs) ys (cons (car xs) (append (cdr xs) ys)))))) 206 | (letrec ((reverse 207 | (lambda (xs) 208 | (if (null? xs) 209 | '() 210 | (append (reverse (cdr xs)) (list (car xs))))))) 211 | (list . ,(make-list problem-iterations 212 | `(reverse ',(range problem-size))))))) 213 | 214 | (define (benchmark) 215 | (let loop-prog ((programs `((append ,ex-append) 216 | (reverse-quadratic ,ex-reverse-quadratic) 217 | ))) 218 | (when (pair? programs) 219 | (let ((program (car programs)) (programs (cdr programs))) 220 | (newline) 221 | (displayln `(program: ,(car program))) 222 | (let loop-eval ((runners `((scheme-eval-static 223 | ,(eval `(lambda (,(gensym "unused")) 224 | ,(cadr program)))) 225 | (scheme-eval-runtime ,run/scheme-eval) 226 | (closure-eval ,run/closure-eval) 227 | (lifted-closure-eval ,run/lifted-closure-eval) 228 | (raw-eval ,run/raw-eval) 229 | ;; TODO: this needs to require racket/match 230 | ;(scheme-eval-eval ,run/scheme-eval-eval) 231 | (closure-eval-eval ,run/closure-eval-eval) 232 | (lifted-closure-eval-eval ,run/lifted-closure-eval-eval) 233 | (raw-eval-eval ,run/raw-eval-eval) 234 | ))) 235 | (if (null? runners) (loop-prog programs) 236 | (let ((runner (car runners)) (runners (cdr runners))) 237 | (collect-garbage 'major) 238 | (displayln `(evaluator: ,(car runner))) 239 | (time (void ((cadr runner) (cadr program)))) 240 | ;(time (displayln ((cadr runner) (cadr program)))) 241 | (loop-eval runners)))))))) 242 | 243 | (benchmark) 244 | 245 | ; TODO: port these to Chez Scheme 246 | 247 | ; deterministic evaluation benchmark ideas to measure sources of overhead 248 | ; across programs: append, reverse, map, fold, mini interpreter, remove-foo, etc. 249 | ; across program implementations: tailcall, w/ fold, etc. 250 | ; across runtimes: 251 | ; scheme, mk-only, mixed 252 | ; across interpreter architectures: 253 | ; static (scheme only) 254 | ; eval at runtime (scheme only) 255 | ; ahead-of-time compiled (dkanren only) 256 | ; closure encoding (mk would need to support procedure values) 257 | ; de bruin encoding (with and without integer support) 258 | ; raw interpretation 259 | ; original relational interpreter(s) (mk only) 260 | -------------------------------------------------------------------------------- /core.scm: -------------------------------------------------------------------------------- 1 | (define-syntax defrecord 2 | (syntax-rules () 3 | ((_ name name?) 4 | (begin 5 | (define name (vector 'name)) 6 | (define (name? datum) (eq? name datum)))) 7 | ((_ name name? (field set-field) ...) 8 | (begin 9 | (define (name field ...) (vector 'name field ...)) 10 | (define (name? datum) 11 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 12 | (let () 13 | (define (range-assoc start xs) 14 | (let loop ((xs xs) (idx start)) 15 | (if (null? xs) 16 | '() 17 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 18 | (define (define-field-getter name rassc) 19 | (define idx (cdr (assoc name rassc))) 20 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 21 | (define (define-field-setter name rassc) 22 | (define idx (cdr (assoc name rassc))) 23 | (eval `(define (,name datum value) 24 | (let ((new (vector-copy datum))) 25 | (vector-set! new ,idx value) 26 | new)))) 27 | (let ((fns (range-assoc 1 '(field ...)))) 28 | (begin (define-field-getter 'field fns) ...)) 29 | (let ((set-fns (range-assoc 1 '(set-field ...)))) 30 | (begin (define-field-setter 'set-field set-fns) ...))))) 31 | ((_ name name? field ...) 32 | (begin 33 | (define (name field ...) (vector 'name field ...)) 34 | (define (name? datum) 35 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 36 | (let () 37 | (define (range-assoc start xs) 38 | (let loop ((xs xs) (idx start)) 39 | (if (null? xs) 40 | '() 41 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 42 | (define (define-field-getter name rassc) 43 | (define idx (cdr (assoc name rassc))) 44 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 45 | (let ((fns (range-assoc 1 '(field ...)))) 46 | (begin (define-field-getter 'field fns) ...))))))) 47 | 48 | ;; TODO: hash 49 | (define store-empty '()) 50 | (define (store-ref store key . default) 51 | (let ((binding (assoc key store))) 52 | (if binding 53 | (cdr binding) 54 | (if (null? default) 55 | (error 'store-ref (format "missing key ~s in ~s" key store)) 56 | (car default))))) 57 | (define (store-set store key value) `((,key . ,value) . ,store)) 58 | (define (store-remove store key) 59 | (if (null? store) 60 | '() 61 | (if (eqv? key (caar store)) 62 | (store-remove (cdr store) key) 63 | (cons (car store) (store-remove (cdr store) key))))) 64 | (define (store-keys store) (map car store)) 65 | 66 | (define (list-add-unique xs v) (if (member v xs) xs (cons v xs))) 67 | (define (list-append-unique xs ys) 68 | (if (null? xs) 69 | ys 70 | (let ((zs (list-append-unique (cdr xs) ys)) 71 | (x0 (car xs))) 72 | (if (member x0 ys) zs (cons x0 zs))))) 73 | (define (list-remove-unique xs v) 74 | (cond 75 | ((null? xs) '()) 76 | ((equal? v (car xs)) (cdr xs)) 77 | (else (let ((xs1 (list-remove-unique (cdr xs)))) 78 | (if (eq? xs1 (cdr xs)) 79 | xs 80 | (cons (car xs) xs1)))))) 81 | (define (list-subtract xs ys) 82 | (if (null? xs) 83 | '() 84 | (let ((x0 (car xs)) 85 | (xs1 (list-subtract (cdr xs) ys))) 86 | (if (member x0 ys) 87 | xs1 88 | (if (eq? xs1 (cdr xs)) 89 | xs 90 | (cons x0 xs1)))))) 91 | (define (list-overlap? xs ys) 92 | (and (pair? xs) 93 | (or (member (car xs) ys)) 94 | (list-overlap? (cdr xs) ys))) 95 | (define (list-intersect xs ys) 96 | (define rest (list-intersect (cdr xs) ys)) 97 | (if (member (car xs) ys) 98 | (cons (car xs) rest) 99 | rest)) 100 | 101 | (define (value-type-tag value) 102 | (cond 103 | ((pair? value) 'pair) 104 | ((symbol? value) 'symbol) 105 | ((number? value) 'number) 106 | (else value))) 107 | ;; Finite domain lists only for symbols, numbers: (), #f, #t are singletons. 108 | ;; Finite domains are *not* supported for pairs. 109 | ;; #t means list is negative. #f means list represents a finite domain. 110 | (define (domain-type-full tag) `(,tag #t ())) 111 | (define domain-full (map domain-type-full '(pair symbol number () #f #t))) 112 | (define (domain-remove dmn type) 113 | (cond 114 | ((null? dmn) '()) 115 | ((eqv? type (caar dmn)) (cdr dmn)) 116 | (else (let ((dmn-new (domain-remove (cdr dmn) type))) 117 | (if (eq? (cdr dmn) dmn-new) 118 | dmn 119 | (cons (car dmn) dmn-new)))))) 120 | (define (domain-remove-except dmn type) 121 | (cond 122 | ((null? dmn) '()) 123 | ((eqv? type (caar dmn)) (list (car dmn))) 124 | (else (domain-remove-except (cdr dmn) type)))) 125 | (define (domain-type-=/= dt type value) 126 | (define =/=? (cadr dt)) 127 | (define fd (caddr dt)) 128 | (define (finite fd) (and (pair? fd) `(,type #f ,fd))) 129 | (if =/=? 130 | `(,type #t ,(list-add-unique fd value)) 131 | (finite (list-remove-unique fd value)))) 132 | (define (domain-=/= dmn value) 133 | (let ((type (value-type-tag value))) 134 | (let loop ((dmn dmn)) 135 | (if (eqv? type (caar dmn)) 136 | (let ((dt (domain-type-=/= (car dmn) type value))) 137 | (if dt 138 | (cons dt (cdr dmn)) 139 | (cdr dmn))) 140 | (cons (car dmn) (loop (cdr dmn))))))) 141 | (define (domain-=/=-except dmn fd) 142 | (let loop ((dlimit '()) (fd fd)) 143 | (if (null? fd) 144 | (domain-intersect dmn dlimit) 145 | (loop (domain-add dlimit (car fd)) (cdr fd))))) 146 | 147 | ;; Pairs must *not* be added. They do not support finite domains. 148 | (define (domain-type-add dt value) 149 | (define type (car dt)) 150 | (if (or (symbol? value) (number? value)) 151 | `(,type #f ,(list-add-unique (caddr dt) value)) 152 | `(,type #t ()))) 153 | (define (domain-type-set dmn dt) 154 | (define type (car dt)) 155 | (let loop ((dmn dmn) (full domain-full)) 156 | (cond 157 | ((eqv? type (caar dmn)) (cons dt (cdr dmn))) 158 | ((eqv? type (caar full)) (cons dt dmn)) 159 | ((eqv? (caar full) (caar dmn)) (loop (cdr dmn) (cdr full))) 160 | (else (loop dmn (cdr full)))))) 161 | (define (domain-add dmn value) 162 | (let ((dt (or (domain-type-ref dmn (value-type-tag value)) `(,type #f ())))) 163 | (domain-type-set dmn (domain-type-add dt value)))) 164 | (define (domain-type-ref dmn type) 165 | (cond 166 | ((null? dmn) #f) 167 | ((eqv? type (caar dmn)) (car dmn)) 168 | (else (domain-type-ref (cdr dmn) type)))) 169 | (define (domain-has-type? dmn type) 170 | (or (eq? domain-full dmn) (domain-type-ref dmn type))) 171 | (define (domain-has-value? dmn value) 172 | (define (domain-type-has-value? dmn type value) 173 | (define dt (domain-type-ref dmn type)) 174 | ;; TODO: this is wrong for pairs containing vars. 175 | (and dt (let ((=/=? (cadr dt)) (present? (member value (caddr dt)))) 176 | (if =/=? (not present?) present?)))) 177 | (or (eq? domain-full dmn) 178 | (domain-type-has-value? dmn (value-type-tag value) value))) 179 | 180 | ;(define (domain-type-overlap? dt1 dt2) 181 | ;(define =/=1? (cadr dt1)) 182 | ;(define =/=2? (cadr dt2)) 183 | ;(define fd1 (caddr dt1)) 184 | ;(define fd2 (caddr dt2)) 185 | ;(or (and =/=1? =/=2?) 186 | ;(cond 187 | ;(=/=1? (pair? (list-subtract fd2 fd1))) 188 | ;(=/=2? (pair? (list-subtract fd1 fd2))) 189 | ;(else (list-overlap? fd1 fd2))))) 190 | ;(define (domain-overlap? d1 d2) 191 | ;(or (eq? domain-full d1) (eq? domain-full d2) 192 | ;(let loop ((d1 d1) (d2 d2) (full domain-full)) 193 | ;(cond 194 | ;((or (null? d1) (null? d2)) #f) 195 | ;((eqv? (caar d1) (caar d2)) 196 | ;(or (domain-type-overlap? (car d1) (car d2)) 197 | ;(loop (cdr d1) (cdr d2) full))) 198 | ;((eqv? (caar full) (caar d1)) (loop (cdr d1) d2 (cdr full))) 199 | ;((eqv? (caar full) (caar d2)) (loop d1 (cdr d2) (cdr full))) 200 | ;(else (loop d1 d2 (cdr full))))))) 201 | (define (domain-overlap? d1 d2) (pair? (domain-intersect d1 d2))) 202 | 203 | (define (domain-type-intersect dt1 dt2) 204 | (define tag (car dt1)) 205 | (define =/=1? (cadr dt1)) 206 | (define =/=2? (cadr dt2)) 207 | (define fd1 (caddr dt1)) 208 | (define fd2 (caddr dt2)) 209 | (define (finite fd) (and (pair? fd) `(,tag #f ,fd))) 210 | (cond 211 | ((and =/=1? =/=2?) `(,tag #t ,(list-append-unique fd1 fd2))) 212 | (=/=1? (finite (list-subtract fd2 fd1))) 213 | (=/=2? (finite (list-subtract fd1 fd2))) 214 | (else (finite (list-intersect fd1 fd2))))) 215 | (define (domain-intersect d1 d2) 216 | (cond ((eq? domain-full d1) d2) 217 | ((eq? domain-full d2) d1) 218 | (else (let loop ((d1 d1) (d2 d2) (full domain-full)) 219 | (cond 220 | ((or (null? d1) (null? d2)) '()) 221 | ((eqv? (caar d1) (caar d2)) 222 | (let ((di (domain-type-intersect (car d1) (car d2))) 223 | (dis (loop (cdr d1) (cdr d2) full))) 224 | (if di (cons di dis) dis))) 225 | ((eqv? (caar full) (caar d1)) (loop (cdr d1) d2 (cdr full))) 226 | ((eqv? (caar full) (caar d2)) (loop d1 (cdr d2) (cdr full))) 227 | (else (loop d1 d2 (cdr full)))))))) 228 | 229 | (defrecord watched 230 | watched? 231 | (watched-=/=v set-watched-=/=v) 232 | (watched-=/=* set-watched-=/=*)) 233 | (define watched-empty (watched '() '())) 234 | 235 | (defrecord vattr 236 | vattr? 237 | (vattr-domain set-vattr-domain) 238 | (vattr-watched set-vattr-watched)) 239 | (define vattr-empty (vattr domain-full watched-empty)) 240 | 241 | (define scope 242 | (let ((index -1)) 243 | (lambda () 244 | (set! index (+ 1 index)) 245 | index))) 246 | (define scope-bound #f) 247 | (define scope-nonlocal #t) 248 | 249 | (defrecord var var? var-scope var-value) 250 | (define var/scope 251 | (let ((index -1)) 252 | (lambda (scope) 253 | (set! index (+ 1 index)) 254 | (_var scope index)))) 255 | (define var=? eq?) 256 | (define (var-bound? vr) (eq? scope-bound (var-scope vr))) 257 | (define (set-var-value! vr value) 258 | (vector-set! vr 1 scope-bound) 259 | (vector-set! vr 2 value)) 260 | 261 | (define (vattrs-get vs vr) (store-ref vs vr vattr-empty)) 262 | (define (vattrs-set vs vr value) (store-set vs vr value)) 263 | (define (walk-vs vs vr) 264 | (define (compress vs vnew) (vattrs-set vs vr vnew)) 265 | (define (compress-always vs _ vnew) (compress vs vnew)) 266 | (define (compress-if-new vs v0 vnew) 267 | (if (var=? v0 vnew) vs (compress-always vs v0 vnew))) 268 | (define (compress-walk cmpr vs vr2) 269 | (let-values (((vs tm va) (walk-vs vs vr2))) 270 | (values (cmpr vs vr2 tm) tm va))) 271 | (let ((va (vattrs-get vs vr))) 272 | (cond 273 | ((vattr? va) (values vs vr va)) 274 | ((var? va) 275 | (if (var-bound? va) 276 | (let ((value (var-value va))) 277 | (if (var? value) 278 | (compress-walk compress-always vs value) 279 | (values (compress vs value) value #f))) 280 | (compress-walk compress-if-new vs va))) 281 | (else (values vs va #f))))) 282 | 283 | (defrecord state state? (state-scope set-state-scope) (state-vs set-state-vs)) 284 | (define (var/state st) (var/scope (state-scope))) 285 | (define (state-empty) (state (scope) store-empty)) 286 | (define (state-var-get st vr) (vattrs-get (state-vs st) vr)) 287 | (define (state-var-set st vr value) 288 | (state (state-scope st) (vattrs-set (state-vs st) vr value))) 289 | 290 | ;; TODO: manage existing constraints. 291 | (define (state-var-== st vr va value) 292 | (cond 293 | ((eq? vattr-empty va) (state-var-set st vr value)) 294 | ;; TODO: pair disequalities are an issue here. 295 | ;((domain-has-value? (vattr-domain va) value) 296 | ;) 297 | (else #f))) 298 | ;; TODO: manage existing constraints. 299 | (define (state-var-==-var st v1 va1 v2 va2) 300 | (state-var-set st v1 v2)) 301 | 302 | (define (walk st tm) 303 | (if (var? tm) 304 | (if (var-bound? tm) 305 | (walk st (var-value tm)) 306 | (let ((vs (state-vs st))) 307 | (let-values (((vs-new value va) (walk-vs vs tm))) 308 | (values (if (eq? vs vs-new) st (set-state-vs st vs-new)) value va)))) 309 | (values st tm #f))) 310 | 311 | (define (not-occurs? st vr tm) 312 | (if (pair? tm) 313 | (let-values (((st ta _) (walk st (car tm)))) 314 | (let*/and ((st (not-occurs? st vr ta))) 315 | (let-values (((st td _) (walk st (cdr tm)))) 316 | (not-occurs? st vr td)))) 317 | (and (not (var=? vr tm)) st))) 318 | 319 | (define (unify st t1 t2) 320 | (let*-values (((st t1 va1) (walk st t1)) ((st t2 va2) (walk st t2))) 321 | (cond ((eqv? t1 t2) st) 322 | ((var? t1) 323 | (if (var? t2) 324 | (state-var-==-var st t1 va1 t2 va2) 325 | (let*/and ((st (not-occurs? st t1 t2))) 326 | (state-var-== st t1 va1 t2)))) 327 | ((var? t2) 328 | (let*/and ((st (not-occurs? st t2 t1))) 329 | (state-var-== st t2 va2 t1))) 330 | ((and (pair? t1) (pair? t2)) 331 | (let*/and ((st (unify st (car t1) (car t2)))) 332 | (unify st (cdr t1) (cdr t2)))) 333 | (else #f)))) 334 | -------------------------------------------------------------------------------- /lattice/test-real-set.scm: -------------------------------------------------------------------------------- 1 | (load "test.scm") 2 | (load "real-set.scm") 3 | 4 | (test 'interval-compare-1 5 | (interval-compare 6 | '(#f . #f) '(#f . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 7 | 'eq) 8 | (test 'interval-compare-2 9 | (interval-compare 10 | '(2 . #f) '(#f . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 11 | 'a-in-b) 12 | (test 'interval-compare-3 13 | (interval-compare 14 | '(#f . #f) '(3 . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 15 | 'b-in-a) 16 | (test 'interval-compare-4 17 | (interval-compare 18 | '(#f . 10) '(8 . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 19 | 'lt-overlap) 20 | (test 'interval-compare-5 21 | (interval-compare 22 | '(#f . 10) '(10 . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 23 | 'lt) 24 | (test 'interval-compare-6 25 | (interval-compare 26 | '(8 . #f) '(#f . 10) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 27 | 'gt-overlap) 28 | (test 'interval-compare-7 29 | (interval-compare 30 | '(10 . #f) '(#f . 10) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 31 | 'gt) 32 | 33 | (test 'interval-compare-8 34 | (interval-compare 35 | '(0 . 100) '(0 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 36 | 'eq) 37 | (test 'interval-compare-9 38 | (interval-compare 39 | '(2 . 100) '(0 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 40 | 'a-in-b) 41 | (test 'interval-compare-10 42 | (interval-compare 43 | '(0 . 100) '(3 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 44 | 'b-in-a) 45 | (test 'interval-compare-11 46 | (interval-compare 47 | '(0 . 10) '(8 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 48 | 'lt-overlap) 49 | (test 'interval-compare-12 50 | (interval-compare 51 | '(0 . 10) '(10 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 52 | 'lt) 53 | (test 'interval-compare-13 54 | (interval-compare 55 | '(8 . 100) '(0 . 10) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 56 | 'gt-overlap) 57 | (test 'interval-compare-14 58 | (interval-compare 59 | '(10 . 100) '(0 . 10) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 60 | 'gt) 61 | 62 | (test 'interval-compare-15 63 | (interval-compare 64 | 1 '(1 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 65 | 'lt) 66 | (test 'interval-compare-16 67 | (interval-compare 68 | 2 '(1 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 69 | 'a-in-b) 70 | (test 'interval-compare-17 71 | (interval-compare 72 | 100 '(1 . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 73 | 'gt) 74 | (test 'interval-compare-18 75 | (interval-compare 76 | '(1 . 100) 1 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 77 | 'gt) 78 | (test 'interval-compare-19 79 | (interval-compare 80 | '(1 . 100) 99 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 81 | 'b-in-a) 82 | (test 'interval-compare-20 83 | (interval-compare 84 | '(1 . 100) 100 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 85 | 'lt) 86 | 87 | (test 'interval-compare-21 88 | (interval-compare 89 | 1 '(1 . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 90 | 'lt) 91 | (test 'interval-compare-22 92 | (interval-compare 93 | 2 '(1 . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 94 | 'a-in-b) 95 | (test 'interval-compare-23 96 | (interval-compare 97 | 2 '(#f . #f) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 98 | 'a-in-b) 99 | (test 'interval-compare-24 100 | (interval-compare 101 | 100 '(#f . 100) 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 102 | 'gt) 103 | (test 'interval-compare-25 104 | (interval-compare 105 | '(1 . #f) 1 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 106 | 'gt) 107 | (test 'interval-compare-26 108 | (interval-compare 109 | '(#f . 100) 99 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 110 | 'b-in-a) 111 | (test 'interval-compare-27 112 | (interval-compare 113 | '(#f . #f) 99 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 114 | 'b-in-a) 115 | (test 'interval-compare-28 116 | (interval-compare 117 | '(#f . 100) 100 'lt 'lt-overlap 'a-in-b 'eq 'b-in-a 'gt-overlap 'gt) 118 | 'lt) 119 | 120 | (test 'real-set-join-1 121 | (real-set-join '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 122 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 123 | '((#f . #f))) 124 | (test 'real-set-join-2 125 | (real-set-join '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 126 | '(-3 (-3 . 5) (5 . 8) 10 100 (100 . 200) 200)) 127 | '((#f . 8) (8 . #f))) 128 | (test 'real-set-join-3 129 | (real-set-join '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 130 | '(-3 (-3 . 5) (5 . 8) 8 100 (100 . 200) 200)) 131 | '((#f . 10) (10 . #f))) 132 | (test 'real-set-join-4 133 | (real-set-join '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 134 | '(-3 (-3 . 5) (5 . 8) 8 10 (100 . 200) 200)) 135 | '((#f . 100) (100 . #f))) 136 | (test 'real-set-join-5 137 | (real-set-join '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 138 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200))) 139 | '((#f . 200) (200 . #f))) 140 | (test 'real-set-join-6 141 | (real-set-join '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 142 | '((-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 143 | '((#f . -3) (-3 . #f))) 144 | (test 'real-set-join-7 145 | (real-set-join '((#f . -3) 5 (7 . 10) (10 . 100) (200 . #f)) 146 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 147 | '((#f . #f))) 148 | (test 'real-set-join-8 149 | (real-set-join '((#f . -3) 0 5 (8 . 10) (10 . 100) 101 (200 . #f)) 150 | '((-5 . 0) 0 (0 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 151 | '((#f . #f))) 152 | (test 'real-set-join-9 153 | (real-set-join '((#f . -3) 5 (8 . 9) (10 . 100) (200 . #f)) 154 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 155 | '((#f . 9) 10 (10 . #f))) 156 | (test 'real-set-join-10 157 | (real-set-join '((#f . -3) 5 (8 . 10) (10 . 100) (200 . 900)) 158 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 159 | '((#f . 900))) 160 | (test 'real-set-join-11 161 | (real-set-join '((-50 . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 162 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 163 | '((-50 . #f))) 164 | (test 'real-set-join-12 165 | (real-set-join '((-50 . -3) 5 (8 . 10) (10 . 100) (200 . 900)) 166 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 167 | '((-50 . 900))) 168 | 169 | (test 'real-set-meet-1 170 | (real-set-meet '((#f . #f)) 171 | '((#f . #f))) 172 | '((#f . #f))) 173 | (test 'real-set-meet-2 174 | (real-set-meet '((#f . #f)) 175 | '((#f . 8))) 176 | '((#f . 8))) 177 | (test 'real-set-meet-3 178 | (real-set-meet '((9 . #f)) 179 | '((#f . #f))) 180 | '((9 . #f))) 181 | (test 'real-set-meet-4 182 | (real-set-meet '((#f . 12)) 183 | '((7 . #f))) 184 | '((7 . 12))) 185 | (test 'real-set-meet-5 186 | (real-set-meet '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)) 187 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 188 | '()) 189 | (test 'real-set-meet-6 190 | (real-set-meet '((-4 . 6)) 191 | '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 192 | '((-4 . -3) 5)) 193 | (test 'real-set-meet-7 194 | (real-set-meet '(-8 (-4 . 6)) 195 | '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 196 | '(-8 (-4 . -3) 5)) 197 | (test 'real-set-meet-8 198 | (real-set-meet '(-8 (-4 . 6) 15) 199 | '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 200 | '(-8 (-4 . -3) 5 15)) 201 | (test 'real-set-meet-9 202 | (real-set-meet '(-8 (-4 . 6) (15 . 20)) 203 | '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 204 | '(-8 (-4 . -3) 5 (15 . 20))) 205 | (test 'real-set-meet-10 206 | (real-set-meet '(-8 (-4 . 6) (15 . 200)) 207 | '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 208 | '(-8 (-4 . -3) 5 (15 . 100))) 209 | (test 'real-set-meet-11 210 | (real-set-meet '(-8 (-4 . 6) (15 . 201)) 211 | '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 212 | '(-8 (-4 . -3) 5 (15 . 100) (200 . 201))) 213 | 214 | (test 'real-set-complement-1 215 | (real-set-complement '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 216 | '(-3 (-3 . 5) (5 . 8) 8 10 100 (100 . 200) 200)) 217 | (test 'real-set-complement-2 218 | (real-set-complement 219 | (real-set-complement '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f)))) 220 | '((#f . -3) 5 (8 . 10) (10 . 100) (200 . #f))) 221 | 222 | (test 'real-set-inequality-1 223 | (real-set-join (real-set< 100) (real-set> 10)) 224 | real-set-full) 225 | (test 'real-set-inequality-2 226 | (real-set-meet (real-set> 100) (real-set< 10)) 227 | real-set-empty) 228 | (test 'real-set-inequality-3 229 | (real-set-meet (real-set< 100) (real-set> 10)) 230 | '((10 . 100))) 231 | (test 'real-set-inequality-4 232 | (real-set-join (real-set> 100) (real-set< 10)) 233 | '((#f . 10) (100 . #f))) 234 | (test 'real-set-inequality-5 235 | (real-set-complement (real-set-join (real-set> 100) (real-set< 10))) 236 | '(10 (10 . 100) 100)) 237 | (test 'real-set-inequality-6 238 | (real-set-join (real-set<= 100) (real-set>= 10)) 239 | real-set-full) 240 | (test 'real-set-inequality-7 241 | (real-set-meet (real-set>= 100) (real-set<= 10)) 242 | real-set-empty) 243 | (test 'real-set-inequality-8 244 | (real-set-meet (real-set<= 100) (real-set>= 10)) 245 | '(10 (10 . 100) 100)) 246 | (test 'real-set-inequality-9 247 | (real-set-join (real-set>= 100) (real-set<= 10)) 248 | '((#f . 10) 10 100 (100 . #f))) 249 | (test 'real-set-inequality-10 250 | (real-set-complement (real-set-join (real-set>= 100) (real-set<= 10))) 251 | '((10 . 100))) 252 | 253 | (test 'real-set-points-1 254 | (real-set-with '(5 2 23 5 4 18 2)) 255 | '(2 4 5 18 23)) 256 | (test 'real-set-points-2 257 | (real-set-without '(5 2 23 5 4 18 2)) 258 | '((#f . 2) (2 . 4) (4 . 5) (5 . 18) (18 . 23) (23 . #f))) 259 | 260 | (test 'real-set-widen-1 261 | (real-set-widen real-set-full) 262 | real-set-full) 263 | (test 'real-set-widen-2 264 | (real-set-widen '((#f . 1) (2 . #f))) 265 | real-set-full) 266 | (test 'real-set-widen-3 267 | (real-set-widen '((-5 . 1) (2 . 18))) 268 | '((-5 . 18))) 269 | (test 'real-set-widen-4 270 | (real-set-widen '(-10 (-5 . 1) 2 (2 . 18) 18)) 271 | '(-10 (-10 . 18) 18)) 272 | 273 | (test 'real-set+-1 274 | (real-set+ real-set-full real-set-full) 275 | real-set-full) 276 | (test 'real-set+-2 277 | (real-set+ real-set-full real-set-empty) 278 | real-set-empty) 279 | (test 'real-set+-3 280 | (real-set+ real-set-full '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 281 | real-set-full) 282 | (test 'real-set+-4 283 | (real-set+ '(-20 (-15 . -11) (-2 . 2) (3 . 16) 18) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 284 | '(-30 (-25 . -21) (-21 . 24) 26)) 285 | (test 'real-set+-5 286 | (real-set+ '((#f . -22) -20 (-15 . -11) (-2 . 2) (3 . 16) 18) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 287 | '((#f . 24) 26)) 288 | (test 'real-set+-6 289 | (real-set+ '(-20 (-15 . -11) (-2 . 2) (3 . 16) 18 (22 . #f)) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 290 | '(-30 (-25 . -21) (-21 . #f))) 291 | 292 | (test 'real-set--1 293 | (real-set- '((2 . 5)) '((3 . 6))) 294 | '((-4 . 2))) 295 | 296 | (test 'real-set*-1 297 | (real-set* real-set-full real-set-full) 298 | real-set-full) 299 | (test 'real-set*-2 300 | (real-set* real-set-full real-set-empty) 301 | real-set-empty) 302 | (test 'real-set*-3 303 | (real-set* real-set-full '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 304 | real-set-full) 305 | (test 'real-set*-4 306 | (real-set* '(-20 (-15 . -11) (-2 . 2) (3 . 16) 18) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 307 | '(-180 -160 (-160 . 150) 200)) 308 | (test 'real-set*-5 309 | (real-set* '((#f . -22) -20 (-15 . -11) (-2 . 2) (3 . 16) 18) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 310 | real-set-full) 311 | (test 'real-set*-6 312 | (real-set* '(-20 (-15 . -11) (-2 . 2) (3 . 16) 18 (22 . #f)) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 313 | real-set-full) 314 | (test 'real-set*-7 315 | (real-set* '((#f . -22) -20 (-15 . -11) (-2 . 2) (3 . 16) 18) '((2 . 6) 8)) 316 | '((#f . -22) (-16 . 128) 144)) 317 | (test 'real-set*-8 318 | (real-set* '(-20 (-15 . -11) (-2 . 2) (3 . 16) 18 (22 . #f)) '((2 . 6) 8)) 319 | '(-160 (-120 . -22) (-16 . #f))) 320 | 321 | (test 'real-set/-1 322 | (real-set/ real-set-full real-set-full) 323 | real-set-full) 324 | (test 'real-set/-2 325 | (real-set/ real-set-full real-set-empty) 326 | real-set-empty) 327 | (test 'real-set/-3 328 | (real-set/ real-set-full '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 329 | real-set-full) 330 | (test 'real-set/-4 331 | (real-set/ '(-20 (-15 . -11) (-2 . 2) (3 . 16) 18) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 332 | real-set-full) 333 | (test 'real-set/-5 334 | (real-set/ '(-20 (-15 . -11) (3 . 16) 18) '(-10 (-5 . -3) (2 . 6) 8)) 335 | '((-10 . -3/10) (3/8 . 9))) 336 | (test 'real-set/-6 337 | (real-set/ '((#f . -22) -20 (-15 . -11) (3 . 16) 18) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 338 | '((#f . -3/10) (3/8 . #f))) 339 | (test 'real-set/-7 340 | (real-set/ '(-20 (-15 . -11) (3 . 16) 18 (22 . #f)) '(-10 (-5 . -3) (-1 . 1) (2 . 6) 8)) 341 | '((#f . -3/10) (3/8 . #f))) 342 | (test 'real-set/-8 343 | (real-set/ '((#f . -22) -20 (-15 . -11) (-2 . 2) (3 . 16) 18) '((2 . 6) 8)) 344 | '((#f . -11/8) (-1 . 9))) 345 | (test 'real-set/-9 346 | (real-set/ '(-20 (-15 . -11) (-2 . 2) (3 . 16) 18 (22 . #f)) '((2 . 6) 8)) 347 | '((-10 . -11/8) (-1 . #f))) 348 | -------------------------------------------------------------------------------- /dkanren-arithmetic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | arith 4 | build-num 5 | pluso 6 | *o 7 | ) 8 | 9 | (require 10 | "dkanren.rkt" 11 | racket/set 12 | ) 13 | 14 | (module+ test 15 | (require 16 | rackunit 17 | ) 18 | 19 | (define-syntax mk-test-cont 20 | (syntax-rules () 21 | ((_ test-name exact? query expected) 22 | (let* ((result-set (list->set query)) 23 | (expected-set (list->set expected)) 24 | (overlap (set-intersect result-set expected-set))) 25 | (if exact? 26 | (begin 27 | (when (not (equal? result-set expected-set)) 28 | (displayln (format "failed test: ~a" test-name))) 29 | ;(check-equal? (set-subtract expected-set result-set) (set)) 30 | ;(check-equal? (set-subtract result-set expected-set) (set)) 31 | (check-equal? result-set expected-set)) 32 | (check-equal? overlap expected-set)))))) 33 | (define-syntax mk-test 34 | (syntax-rules () 35 | ((_ test-name query expected) 36 | (mk-test-cont test-name #t query expected)))) 37 | (define-syntax mk-test-subsumed 38 | (syntax-rules () 39 | ((_ test-name query expected) 40 | (mk-test-cont test-name #f query expected)))) 41 | (define-syntax mk-test-time 42 | (syntax-rules () 43 | ((_ test-name query expected) 44 | (begin 45 | (displayln test-name) 46 | (time (mk-test-cont test-name #t query expected)))))) 47 | 48 | (require racket/pretty) 49 | (define-syntax test 50 | (syntax-rules () 51 | ((_ name expr expected) 52 | (let ((actual expr)) 53 | (when (not (equal? actual expected)) 54 | (display name) 55 | (newline) 56 | (pretty-print actual) 57 | (newline)) 58 | (check-equal? actual expected))))) 59 | ) 60 | 61 | (define build-num 62 | (lambda (n) 63 | (cond 64 | ((odd? n) 65 | (cons 1 66 | (build-num (quotient (- n 1) 2)))) 67 | ((and (not (zero? n)) (even? n)) 68 | (cons 0 69 | (build-num (quotient n 2)))) 70 | ((zero? n) '())))) 71 | 72 | (define (arith body) 73 | `(letrec ((append (lambda (xs ys) 74 | (if (null? xs) 75 | ys 76 | (cons (car xs) (append (cdr xs) ys))))) 77 | (pos? (lambda (n) (pair? n))) 78 | (>1? (lambda (n) (match n 79 | (`(,a ,ad . ,dd) #t) 80 | (_ #f)))) 81 | (full-adder 82 | (lambda (b x y) 83 | (match `(,b ,x ,y) 84 | ('(0 0 0) '(0 0)) 85 | ('(1 0 0) '(1 0)) 86 | ('(0 1 0) '(1 0)) 87 | ('(1 1 0) '(0 1)) 88 | ('(0 0 1) '(1 0)) 89 | ('(1 0 1) '(0 1)) 90 | ('(0 1 1) '(0 1)) 91 | ('(1 1 1) '(1 1))))) 92 | (adder 93 | (lambda (d n m) 94 | (match `(,d ,n ,m) 95 | (`(0 ,_ () ) n) 96 | (`(0 () (,_ . ,_)) m) 97 | (`(1 ,_ () ) (adder 0 n '(1))) 98 | (`(1 () (,_ . ,_)) (adder 0 '(1) m)) 99 | (`(,_ (1) (1) ) (full-adder d 1 1)) 100 | (`(,_ (1) ,_ ) (gen-adder d n m)) 101 | ;; TODO: ideally, this could be written as two separate 102 | ;; patterns without sacrificing performance. See the 103 | ;; commented clauses. 104 | (`(,_ (,_ ,_ . ,_) ,_) 105 | (match m 106 | ('(1) 107 | (match (adder d '(1) n) 108 | ((and `(,_ ,_ . ,_) r) r))) 109 | (`(,_ ,_ . ,_) (gen-adder d n m)))) 110 | ;; TODO: ideally, these two clauses, which share a common 111 | ;; pattern prefix, would allow the prefix to be learned when 112 | ;; these were the only two clauses remaining. 113 | ;(`(,_ (,_ ,_ . ,_) (1)) 114 | ;(match (adder d '(1) n) 115 | ;((and `(,_ ,_ . ,_) r) r))) 116 | ;(`(,_ (,_ ,_ . ,_) (,_ ,_ . ,_)) (gen-adder d n m)) 117 | ))) 118 | (gen-adder 119 | (lambda (d n m) 120 | (match `(,n ,m) 121 | (`((,a . ,x) (,b . ,(and `(,_ . ,_) y))) 122 | (match (full-adder d a b) 123 | (`(,c ,e) 124 | (match (adder e x y) 125 | ((and `(,_ . ,_) z) `(,c . ,z))))))))) 126 | (plus (lambda (n m) (adder 0 n m))) 127 | (minus (lambda (n m) (fresh (k) 128 | (match `(,(plus m k) ,n) 129 | (`(,e ,e) k) 130 | (_ #f))))) 131 | 132 | (* (lambda (n m) 133 | (match `(,n ,m) 134 | (`(() ,_ ) '()) 135 | (`(,_ () ) '()) 136 | (`((1) ,_ ) m) 137 | (`(,_ (1) ) n) 138 | (`((0 . ,x) ,_ ) `(0 . ,(* x m))) 139 | (`((1 . ,x) (0 . ,y)) (* m n)) 140 | (`((1 . ,x) (1 . ,y)) (odd-* x n m))))) 141 | (odd-* (lambda (x n m) 142 | (let ((q (* x m))) 143 | (let ((p (plus `(0 . ,q) m))) 144 | (and (bound-*? q p n m) p))))) 145 | (bound-*? (lambda (q p n m) 146 | (match `(,q ,p) 147 | (`(() (,_ . ,_)) #t) 148 | (`((,a0 . ,x) (,a1 . ,y)) 149 | (match `(,n ,m) 150 | (`(() (,a2 . ,z)) (bound-*? x y z '())) 151 | (`((,a3 . ,z) ,_) (bound-*? x y z m))))))) 152 | 153 | ;(=l (lambda (n m) 154 | ;(match `(,n ,m) 155 | ;(`(() ()) #t) 156 | ;(`((1) (1)) #t) 157 | ;(`((,a . ,(and `(,_ . ,_) x)) (,b . ,(and `(,_ . ,_) y))) 158 | ;(=l x y)) 159 | ;(_ #f)))) 160 | ;(1o q)) 335 | ;'(((() (_.0 _.1 . _.2) (0 0 1 0 0 0 1))) 336 | ;(((1) (_.0 _.1 . _.2) (1 1 0 0 0 0 1))) 337 | ;(((0 1) (0 1 1) (0 0 1))))) 338 | 339 | ;(mk-test-time "logo 9 answers" 340 | ;(run 9 (b q r) 341 | ;(logo '(0 0 1 0 0 0 1) b q r) 342 | ;(>1o q)) 343 | ;'(((() (_.0 _.1 . _.2) (0 0 1 0 0 0 1))) 344 | ;(((1) (_.0 _.1 . _.2) (1 1 0 0 0 0 1))) 345 | ;(((0 1) (0 1 1) (0 0 1))) 346 | ;(((1 1) (1 1) (1 0 0 1 0 1))) 347 | ;(((0 0 1) (1 1) (0 0 1))) 348 | ;(((0 0 0 1) (0 1) (0 0 1))) 349 | ;(((1 0 1) (0 1) (1 1 0 1 0 1))) 350 | ;(((0 1 1) (0 1) (0 0 0 0 0 1))) 351 | ;(((1 1 1) (0 1) (1 1 0 0 1))))) 352 | ) 353 | -------------------------------------------------------------------------------- /dkanren-interp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | evalo 4 | ) 5 | 6 | (require 7 | "dkanren.rkt" 8 | ) 9 | 10 | ; TODO 11 | ; profile to see what terms are getting all the attention 12 | ; nest all literals under a single match clause to compress their mostly-useless scheduling 13 | ; can a weighted match prioritize symbol lookup unraveling? 14 | ; additional predicates: procedure?, boolean? 15 | 16 | ; evalo solver 17 | ; tag match statements 18 | ; recognize tag groups (confirm via debug printing) 19 | ; design partitions and env analysis 20 | ; force fresh variable names as needed 21 | ; rules 22 | ; unshadowed env 23 | ; literals 24 | ; car/cdr reachables 25 | ; pair? before car/cdr when input type is ambiguous in env/partition 26 | ; rather, car/cdr only allowed on unambiguous pairs 27 | ; conditionals on other type/equality witnesses may create partitions with reduced ambiguity 28 | ; never car/cdr a cons result 29 | ; never type-witness a literal 30 | ; never equate two literals 31 | ; what about generating lambdas/letrecs? 32 | ; (aggressive/permissive) union type system? 33 | 34 | ; other performance enhancement ideas 35 | ; pre-synthesis analysis 36 | ; partially evaluate known portions of program 37 | ; immediately commit to letrec/begin definitions for unknown procedures 38 | ; providing fixed param counts where possible 39 | ; generating unique, concrete parameter names 40 | ; (if desired, these can be converted to logic variables later) 41 | ; type inference and environment analysis of calls to unknown/partially-known procedures 42 | ; group applications by procedure 43 | ; while comparing argument values across applications: 44 | ; identify basic values, then sensible uses of primitives on these 45 | ; suggest conditionals that partition applications 46 | ; i.e., condition must evaluate to: 47 | ; `#f` in at least one env 48 | ; and to `not #f` in at least one other env 49 | ; maybe also use return values/types to identify desirable partitions 50 | ; also see "evalo solver" notes 51 | ; synthesize within post-syntactic-analysis representation to avoid redundant parsing overhead 52 | ; parse initial program to produce something like a de Bruijn program representation 53 | ; maybe also support other streamlining, such as inlined primitive ops 54 | ; perform synthesis 55 | ; project synthesized program back into surface syntax 56 | ; maybe intertwine this projection with synthesis, to get faster feedback 57 | ; when playing tricky syntactic constraint games, like quining 58 | 59 | ; related work 60 | ; escher 61 | ; myth 62 | ; http://leon.epfl.ch/doc/ 63 | ; https://emina.github.io/rosette/ 64 | ; https://people.eecs.berkeley.edu/~bodik/research/pldi07-sketching-stencils.pdf 65 | ; http://acypher.com/wwid/Chapters/07Metamouse.html 66 | ; http://web.media.mit.edu/~lieber/Lieberary/Mondrian/Mondrian.html 67 | ; Chimera? 68 | 69 | (define (letrec-eval-term program) 70 | `(let ((closure-tag ',(gensym "#%closure")) 71 | (prim-tag ',(gensym "#%primitive")) 72 | (empty-env '())) 73 | (let ((initial-env 74 | `((cons . (val . (,prim-tag . cons))) 75 | (car . (val . (,prim-tag . car))) 76 | (cdr . (val . (,prim-tag . cdr))) 77 | (null? . (val . (,prim-tag . null?))) 78 | (pair? . (val . (,prim-tag . pair?))) 79 | (symbol? . (val . (,prim-tag . symbol?))) 80 | (not . (val . (,prim-tag . not))) 81 | (equal? . (val . (,prim-tag . equal?))) 82 | (list . (val . (,closure-tag (lambda x x) ,empty-env))) 83 | . ,empty-env)) 84 | (closure-tag? (lambda (v) (equal? v closure-tag))) 85 | (prim-tag? (lambda (v) (equal? v prim-tag)))) 86 | (letrec 87 | ((applicable-tag? (lambda (v) (or (closure-tag? v) (prim-tag? v)))) 88 | (quotable? (lambda (v) 89 | (match/lazy v 90 | ((? symbol?) (not (applicable-tag? v))) 91 | (`(,a . ,d) (and (quotable? a) (quotable? d))) 92 | (_ #t)))) 93 | (not-in-params? (lambda (ps sym) 94 | (match/lazy ps 95 | ('() #t) 96 | (`(,a . ,d) 97 | (and (not (equal? a sym)) 98 | (not-in-params? d sym)))))) 99 | (param-list? (lambda (x) 100 | (match/lazy x 101 | ('() #t) 102 | (`(,(? symbol? a) . ,d) 103 | (and (param-list? d) (not-in-params? d a))) 104 | (_ #f)))) 105 | (params? (lambda (x) 106 | (match/lazy x 107 | ((? param-list?) #t) 108 | (x (symbol? x))))) 109 | (in-env? (lambda (env sym) 110 | (match/lazy env 111 | ('() #f) 112 | (`((,a . ,_) . ,d) 113 | (or (equal? a sym) (in-env? d sym)))))) 114 | (extend-env* 115 | (lambda (params args env) 116 | (match `(,params . ,args) 117 | (`(() . ()) env) 118 | (`((,x . ,dx*) . (,a . ,da*)) 119 | (extend-env* dx* da* `((,x . (val . ,a)) . ,env)))))) 120 | (lookup 121 | (lambda (env sym) 122 | (match env 123 | (`((,y . ,b) . ,rest) 124 | (if (equal? sym y) 125 | (match b 126 | (`(val . ,v) v) 127 | (`(rec . ,lam-expr) `(,closure-tag ,lam-expr ,env))) 128 | (lookup rest sym)))))) 129 | (term? 130 | (lambda (term env) 131 | (letrec 132 | ((term1? (lambda (v) (term? v env))) 133 | (terms? (lambda (ts env) 134 | (match/lazy ts 135 | ('() #t) 136 | (`(,t . ,ts) 137 | (and (term? t env) (terms? ts env))))))) 138 | (match/lazy term 139 | (#t #t) 140 | (#f #t) 141 | ((number) #t) 142 | ((symbol sym) (in-env? env sym)) 143 | (`(,(? term1?) . ,rands) (terms? rands env)) 144 | (`(quote ,datum) (quotable? datum)) 145 | (`(if ,c ,t ,f) (and (term1? c) (term1? t) (term1? f))) 146 | (`(lambda ,params ,body) 147 | (and (params? params) 148 | (let ((res 149 | (match params 150 | ((and (not (symbol)) params) 151 | (extend-env* params params env)) 152 | (sym `((,sym . (val . ,sym)) . ,env))))) 153 | (term? body res)))) 154 | (`(letrec 155 | ((,p-name ,(and `(lambda ,params ,body) lam-expr))) 156 | ,letrec-body) 157 | (and (params? params) 158 | (let ((res `((,p-name 159 | . (rec . (lambda ,params ,body))) 160 | . ,env))) 161 | (and (term? lam-expr res) 162 | (term? letrec-body res))))) 163 | (_ #f))))) 164 | (eval-prim 165 | (lambda (prim-id args) 166 | (match `(,prim-id . ,args) 167 | (`(cons ,a ,d) `(,a . ,d)) 168 | (`(car (,(and (not (? applicable-tag?)) a) . ,d)) a) 169 | (`(cdr (,(and (not (? applicable-tag?)) a) . ,d)) d) 170 | (`(null? ()) #t) 171 | (`(null? ,_) #f) 172 | (`(pair? (,(not (? applicable-tag?)) . ,_)) #t) 173 | (`(pair? ,_) #f) 174 | (`(symbol? ,(symbol)) #t) 175 | (`(symbol? ,_) #f) 176 | (`(number? ,(number)) #t) 177 | (`(number? ,(number)) #f) 178 | (`(not #f) #t) 179 | (`(not #t) #f) 180 | (`(equal? ,v1 ,v1) #t) 181 | (`(equal? ,_ ,_) #f)))) 182 | (eval-term-list 183 | (lambda (terms env) 184 | (match terms 185 | ('() '()) 186 | (`(,term . ,terms) 187 | `(,(eval-term term env) . ,(eval-term-list terms env)))))) 188 | (eval-term 189 | (lambda (term env) 190 | (let ((bound? (lambda (sym) (in-env? env sym))) 191 | (term1? (lambda (v) (term? v env)))) 192 | (match term 193 | ((symbol sym) (lookup env sym)) 194 | (#t #t) 195 | (#f #f) 196 | ((number num) num) 197 | (`(,(and 'quote (not (? bound?))) ,(? quotable? datum)) 198 | datum) 199 | ((and `(,op . ,_) operation) 200 | (match operation 201 | (`(,(or (not (symbol)) (? bound?)) 202 | . ,rands) 203 | (let ((op (eval-term op env)) 204 | (a* (eval-term-list rands env))) 205 | (match op 206 | (`(,(? prim-tag?) . ,prim-id) 207 | (eval-prim prim-id a*)) 208 | (`(,(? closure-tag?) (lambda ,x ,body) ,env^) 209 | (let ((res (match x 210 | ((and (not (symbol)) params) 211 | (extend-env* params a* env^)) 212 | (sym `((,sym . (val . ,a*)) 213 | . ,env^))))) 214 | (eval-term body res)))))) 215 | (`(if ,condition ,alt-true ,alt-false) 216 | (if (eval-term condition env) 217 | (eval-term alt-true env) 218 | (eval-term alt-false env))) 219 | (`(lambda ,params ,body) 220 | `(,closure-tag (lambda ,params ,body) ,env)) 221 | (`(letrec ((,p-name (lambda ,params ,body))) 222 | ,letrec-body) 223 | (eval-term 224 | letrec-body 225 | `((,p-name . (rec . (lambda ,params ,body))) 226 | . ,env)))))))))) 227 | 228 | (let ((program ',program)) 229 | (let ((_ (match/lazy (term? program initial-env) (#t #t)))) 230 | (eval-term program initial-env))))))) 231 | 232 | (define (evalo program result) 233 | (let ((tm (letrec-eval-term program))) 234 | (dk-evalo tm result))) 235 | 236 | (module+ test 237 | (require 238 | racket/pretty 239 | rackunit 240 | ) 241 | 242 | (define-syntax test 243 | (syntax-rules () 244 | ((_ name expr expected) 245 | (let ((actual expr)) 246 | (when (not (equal? actual expected)) 247 | (display name) 248 | (newline) 249 | (pretty-print actual) 250 | (newline)) 251 | (check-equal? actual expected))))) 252 | 253 | (define (letrec-append body) 254 | `(letrec ((append 255 | (lambda (xs ys) 256 | (if (null? xs) ys (cons (car xs) (append (cdr xs) ys)))))) 257 | ,body)) 258 | 259 | (test "evalo-1" 260 | (run* (q) 261 | (evalo `'(1 2 ,q 4 5) '(1 2 3 4 5))) 262 | '((3))) 263 | (test "evalo-append-0" 264 | (run* (q) 265 | (evalo (letrec-append 266 | '(list (append '() '()) 267 | (append '(foo) '(bar)) 268 | (append '(1 2) '(3 4)))) 269 | q)) 270 | '(((() (foo bar) (1 2 3 4))))) 271 | (test "evalo-append-1" 272 | (run* (q) 273 | (evalo (letrec-append `(append '(1 2 3) '(4 5))) q)) 274 | '(((1 2 3 4 5)))) 275 | (test "evalo-append-2" 276 | (run* (q) 277 | (evalo (letrec-append `(append '(1 2 3) ',q)) '(1 2 3 4 5))) 278 | '(((4 5)))) 279 | (test "evalo-append-3" 280 | (run* (q) 281 | (evalo (letrec-append `(append ',q '(4 5))) '(1 2 3 4 5))) 282 | '(((1 2 3)))) 283 | (test "evalo-append-4" 284 | (run* (q r) 285 | (evalo (letrec-append `(append ',q ',r)) '(1 2 3 4 5))) 286 | '((() (1 2 3 4 5)) 287 | ((1) (2 3 4 5)) 288 | ((1 2) (3 4 5)) 289 | ((1 2 3) (4 5)) 290 | ((1 2 3 4) (5)) 291 | ((1 2 3 4 5) ()))) 292 | 293 | (test "evalo-append-synthesis-1" 294 | (run 1 (q) 295 | (evalo `(letrec 296 | ((append (lambda (xs ys) 297 | (if (null? xs) 298 | ys 299 | (cons (car ,q) (append (cdr xs) ys)))))) 300 | (append '(1 2) '(3 4))) 301 | '(1 2 3 4)) 302 | ) 303 | '((xs))) 304 | (test "evalo-append-synthesis-2" 305 | (run 1 (q) 306 | (evalo `(letrec 307 | ((append (lambda (xs ys) 308 | (if (null? xs) 309 | ys 310 | (cons (car xs) (,q (cdr xs) ys)))))) 311 | (append '(1 2) '(3 4))) 312 | '(1 2 3 4)) 313 | ) 314 | '((append))) 315 | (test "evalo-append-synthesis-3" 316 | (run 1 (q) 317 | (evalo `(letrec 318 | ((append (lambda (xs ys) 319 | (if (,q xs) 320 | ys 321 | (cons (car xs) (append (cdr xs) ys)))))) 322 | (append '(1 2) '(3 4))) 323 | '(1 2 3 4)) 324 | ) 325 | '((null?))) 326 | 327 | ;; TODO: run higher order interpreters in the relational interpreter instead. 328 | ;; This won't work directly due to dKanren's first-order restriction. 329 | ;(define ex-eval-expr 330 | ;'(letrec 331 | ;((eval-expr 332 | ;(lambda (expr env) 333 | ;(match expr 334 | ;(`(quote ,datum) datum) 335 | ;(`(lambda (,(? symbol? x)) ,body) 336 | ;(lambda (a) 337 | ;(eval-expr body (lambda (y) 338 | ;(if (equal? y x) a (env y)))))) 339 | ;((? symbol? x) (env x)) 340 | ;(`(cons ,e1 ,e2) (cons (eval-expr e1 env) (eval-expr e2 env))) 341 | ;(`(,rator ,rand) ((eval-expr rator env) 342 | ;(eval-expr rand env))))))) 343 | ;(list 344 | ;(eval-expr '((lambda (y) y) 'g1) 'initial-env) 345 | ;(eval-expr '(((lambda (z) z) (lambda (v) v)) 'g2) 'initial-env) 346 | ;(eval-expr '(((lambda (a) (a a)) (lambda (b) b)) 'g3) 'initial-env) 347 | ;(eval-expr '(((lambda (c) (lambda (d) c)) 'g4) 'g5) 'initial-env) 348 | ;(eval-expr '(((lambda (f) (lambda (v1) (f (f v1)))) (lambda (e) e)) 'g6) 'initial-env) 349 | ;(eval-expr '((lambda (g) ((g g) g)) (lambda (i) (lambda (j) 'g7))) 'initial-env)))) 350 | ;(test-eval ex-eval-expr '(g1 g2 g3 g4 g6 g7)) 351 | 352 | ;(define ex-eval-expr-dneg 353 | ;'(letrec 354 | ;((eval-expr 355 | ;(lambda (expr env) 356 | ;(match expr 357 | ;(`(,(not (not 'quote)) ,datum) datum) 358 | ;(`(lambda (,(? symbol? x)) ,body) 359 | ;(lambda (a) 360 | ;(eval-expr body (lambda (y) 361 | ;(if (equal? y x) a (env y)))))) 362 | ;((symbol x) (env x)) 363 | ;(`(cons ,e1 ,e2) (cons (eval-expr e1 env) (eval-expr e2 env))) 364 | ;(`(,rator ,rand) ((eval-expr rator env) 365 | ;(eval-expr rand env))))))) 366 | ;(list 367 | ;(eval-expr '((lambda (y) y) 'g1) 'initial-env) 368 | ;(eval-expr '(((lambda (z) z) (lambda (v) v)) 'g2) 'initial-env) 369 | ;(eval-expr '(((lambda (a) (a a)) (lambda (b) b)) 'g3) 'initial-env) 370 | ;(eval-expr '(((lambda (c) (lambda (d) c)) 'g4) 'g5) 'initial-env) 371 | ;(eval-expr '(((lambda (f) (lambda (v1) (f (f v1)))) (lambda (e) e)) 'g6) 'initial-env) 372 | ;(eval-expr '((lambda (g) ((g g) g)) (lambda (i) (lambda (j) 'g7))) 'initial-env)))) 373 | ;(test-eval ex-eval-expr-dneg '(g1 g2 g3 g4 g6 g7)) 374 | ) 375 | -------------------------------------------------------------------------------- /dkanren-benchmarks/raw.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | term? 4 | eval-term 5 | initial-env 6 | ) 7 | 8 | (require 9 | racket/match 10 | ) 11 | 12 | (module+ test 13 | (require 14 | rackunit 15 | )) 16 | 17 | (define closure-tag (gensym "#%closure")) 18 | (define (closure-tag? x) (eq? x closure-tag)) 19 | (define prim-tag (gensym "#%primitive")) 20 | (define (prim-tag? x) (eq? x prim-tag)) 21 | 22 | (define (applicable-tag? v) 23 | (or (equal? closure-tag v) (equal? prim-tag v))) 24 | (define (quotable? v) 25 | (match v 26 | ((? symbol?) (not (applicable-tag? v))) 27 | (`(,a . ,d) (and (quotable? a) (quotable? d))) 28 | (_ #t))) 29 | 30 | (define empty-env '()) 31 | (define initial-env `((val . (cons . (,prim-tag . cons))) 32 | (val . (car . (,prim-tag . car))) 33 | (val . (cdr . (,prim-tag . cdr))) 34 | (val . (null? . (,prim-tag . null?))) 35 | (val . (pair? . (,prim-tag . pair?))) 36 | (val . (symbol? . (,prim-tag . symbol?))) 37 | (val . (number? . (,prim-tag . number?))) 38 | (val . (not . (,prim-tag . not))) 39 | (val . (equal? . (,prim-tag . equal?))) 40 | (val . (list . (,closure-tag (lambda x x) ,empty-env))) 41 | . ,empty-env)) 42 | (define (in-env? env sym) 43 | (match env 44 | ('() #f) 45 | (`((val . (,a . ,_)) . ,d) (or (equal? a sym) (in-env? d sym))) 46 | (`((rec . ,binding*) . ,d) (in-env-rec? binding* d sym)))) 47 | (define (in-env-rec? binding* env sym) 48 | (match binding* 49 | ('() (in-env? env sym)) 50 | (`((,a . ,_) . ,d) (or (equal? a sym) (in-env-rec? d env sym))))) 51 | (define (extend-env* params args env) 52 | (match `(,params . ,args) 53 | (`(() . ()) env) 54 | (`((,x . ,dx*) . (,a . ,da*)) 55 | (extend-env* dx* da* `((val . (,x . ,a)) . ,env))))) 56 | (define (lookup env sym) 57 | (match env 58 | (`((val . (,y . ,b)) . ,rest) (if (equal? sym y) b (lookup rest sym))) 59 | (`((rec . ,binding*) . ,rest) (lookup-rec binding* rest sym env)))) 60 | (define (lookup-rec binding* env sym renv) 61 | (match binding* 62 | ('() (lookup env sym)) 63 | (`((,p-name ,lam-expr) . ,binding*) 64 | (if (equal? sym p-name) 65 | `(,closure-tag ,lam-expr ,renv) 66 | (lookup-rec binding* env sym renv))))) 67 | 68 | (define (not-in-params? ps sym) 69 | (match ps 70 | ('() #t) 71 | (`(,a . ,d) 72 | (and (not (equal? a sym)) (not-in-params? d sym))))) 73 | (define (param-list? x) 74 | (match x 75 | ('() #t) 76 | (`(,(? symbol? a) . ,d) 77 | (and (param-list? d) (not-in-params? d a))) 78 | (_ #f))) 79 | (define (params? x) 80 | (match x 81 | ((? param-list?) #t) 82 | (x (symbol? x)))) 83 | (define (bindings? b*) 84 | (match b* 85 | ('() #t) 86 | (`((,p ,v) . ,b*) (bindings? b*)) 87 | (_ #f))) 88 | (define (split-bindings b*) 89 | (match b* 90 | ('() (values '() '())) 91 | (`((,param ,val) . ,b*) 92 | (let-values (((ps vs) (split-bindings b*))) 93 | (values (cons param ps) (cons val vs)))))) 94 | 95 | (define (pattern-var? b* vname ps) 96 | (match b* 97 | ('() `(,vname . ,ps)) 98 | (`(,name . ,b*) (if (eq? name vname) ps (pattern-var? b* vname ps))))) 99 | (define (pattern-qq? qqpattern ps env) 100 | (match qqpattern 101 | (`(,'unquote ,pat) (pattern? pat ps env)) 102 | (`(,a . ,d) (let ((ps (pattern-qq? a ps env))) 103 | (and ps (pattern-qq? d ps env)))) 104 | ((? quotable?) ps))) 105 | (define (pattern-or? pattern* ps env) 106 | (match pattern* 107 | ('() ps) 108 | (`(,pattern . ,pattern*) 109 | (let ((ps0 (pattern? pattern ps env))) 110 | (and (equal? ps0 (pattern-or? pattern* ps env)) ps0))))) 111 | (define (pattern*? pattern* ps env) 112 | (match pattern* 113 | ('() ps) 114 | (`(,pattern . ,pattern*) 115 | (let ((ps (pattern? pattern ps env))) 116 | (and ps (pattern*? pattern* ps env)))))) 117 | (define (pattern? pattern ps env) 118 | (match pattern 119 | (`(quote ,(? quotable?)) ps) 120 | (`(quasiquote ,qqpat) (pattern-qq? qqpat ps env)) 121 | (`(not . ,pat*) (pattern*? pat* ps env)) 122 | (`(and . ,pat*) (pattern*? pat* ps env)) 123 | (`(or . ,pat*) (pattern-or? pat* ps env)) 124 | (`(? ,predicate . ,pat*) 125 | (and (term? predicate env) (pattern*? pat* ps env))) 126 | ('_ ps) 127 | ((? symbol? vname) (pattern-var? ps vname ps)) 128 | ((? quotable?) ps))) 129 | (define (match-clauses? pt* env) 130 | (match pt* 131 | ('() #t) 132 | (`((,pat ,rhs) . ,pt*) 133 | (let ((ps (pattern? pat '() env))) 134 | (and 135 | ps (term? rhs (extend-env* ps ps env)) (match-clauses? pt* env)))))) 136 | 137 | (define (term-qq? qqterm env) 138 | (match qqterm 139 | (`(,'unquote ,term) (term? term env)) 140 | (`(,a . ,d) (and (term-qq? a env) (term-qq? d env))) 141 | (datum (quotable? datum)))) 142 | (define (term? term env) 143 | (letrec ((term1? (lambda (v) (term? v env))) 144 | (terms? (lambda (ts env) 145 | (match ts 146 | ('() #t) 147 | (`(,t . ,ts) (and (term? t env) (terms? ts env)))))) 148 | (binding-lambdas? 149 | (lambda (binding* env) 150 | (match binding* 151 | ('() #t) 152 | (`((,_ ,(and `(lambda ,_ ,_) t)) . ,b*) 153 | (and (term? t env) (binding-lambdas? b* env))))))) 154 | (match term 155 | (#t #t) 156 | (#f #t) 157 | ((? number?) #t) 158 | ((and (? symbol? sym)) (in-env? env sym)) 159 | (`(,(? term1?) . ,rands) (terms? rands env)) 160 | (`(quote ,datum) (quotable? datum)) 161 | (`(quasiquote ,qqterm) (term-qq? qqterm env)) 162 | (`(if ,c ,t ,f) (and (term1? c) (term1? t) (term1? f))) 163 | (`(lambda ,params ,body) 164 | (and (params? params) 165 | (let ((res (match params 166 | ((not (? symbol? params)) 167 | (extend-env* params params env)) 168 | (sym `((val . (,sym . ,sym)) . ,env))))) 169 | (term? body res)))) 170 | (`(let ,binding* ,let-body) 171 | (and (bindings? binding*) 172 | (let-values (((ps vs) (split-bindings binding*))) 173 | (and (terms? vs env) 174 | (term? let-body (extend-env* ps ps env)))))) 175 | (`(letrec ,binding* ,letrec-body) 176 | (let ((res `((rec . ,binding*) . ,env))) 177 | (and (binding-lambdas? binding* res) (term? letrec-body res)))) 178 | (`(and . ,t*) (terms? t* env)) 179 | (`(or . ,t*) (terms? t* env)) 180 | (`(match ,s . ,pt*) (and (term1? s) (match-clauses? pt* env))) 181 | (_ #f)))) 182 | 183 | (define (eval-pattern-literal literal penv v) (and (equal? literal v) penv)) 184 | (define (eval-pattern-var b* vname penv v) 185 | (match b* 186 | ('() `((,vname ,v) . ,penv)) 187 | (`((,name ,x) . ,b*) 188 | (if (eq? name vname) 189 | (and (equal? x v) penv) 190 | (eval-pattern-var b* vname penv v))))) 191 | (define (eval-pattern-qq qqpattern penv v env) 192 | (match qqpattern 193 | (`(,'unquote ,pat) (eval-pattern pat penv v env)) 194 | (`(,a . ,d) 195 | (and (pair? v) 196 | (let ((penv (eval-pattern-qq a penv (car v) env))) 197 | (and penv (eval-pattern-qq d penv (cdr v) env))))) 198 | ((? quotable? datum) (eval-pattern-literal datum penv v)))) 199 | (define (eval-pattern-or pattern* penv v env) 200 | (match pattern* 201 | ('() #f) 202 | (`(,pattern . ,pattern*) 203 | (let ((penv0 (eval-pattern pattern penv v env))) 204 | (or penv0 (eval-pattern-or pattern* penv v env)))))) 205 | (define (eval-pattern* pattern* penv v env) 206 | (match pattern* 207 | ('() penv) 208 | (`(,pattern . ,pattern*) 209 | (let ((penv (eval-pattern pattern penv v env))) 210 | (and penv (eval-pattern* pattern* penv v env)))))) 211 | (define (eval-pattern pattern penv v env) 212 | (match pattern 213 | (`(quote ,(? quotable? datum)) (eval-pattern-literal datum penv v)) 214 | (`(quasiquote ,qqpat) (eval-pattern-qq qqpat penv v env)) 215 | (`(not . ,pat*) (and (not (eval-pattern* pat* penv v env)) penv)) 216 | (`(and . ,pat*) (eval-pattern* pat* penv v env)) 217 | (`(or . ,pat*) (eval-pattern-or pat* penv v env)) 218 | (`(? ,predicate . ,pat*) 219 | (and (eval-application (eval-term predicate env) (list v)) 220 | (eval-pattern* pat* penv v env))) 221 | ('_ penv) 222 | ((? symbol? vname) (eval-pattern-var penv vname penv v)) 223 | ((? quotable? datum) (eval-pattern-literal datum penv v)))) 224 | (define (eval-match pt* v env) 225 | (match pt* 226 | (`((,pat ,rhs) . ,pt*) 227 | (let ((penv (eval-pattern pat '() v env))) 228 | (if penv 229 | (let-values (((ps vs) (split-bindings penv))) 230 | (eval-term rhs (extend-env* (reverse ps) (reverse vs) env))) 231 | (eval-match pt* v env)))))) 232 | 233 | (define (eval-prim prim-id args) 234 | (match `(,prim-id . ,args) 235 | (`(cons ,a ,d) `(,a . ,d)) 236 | (`(car (,(and (not (? applicable-tag?)) a) . ,d)) a) 237 | (`(cdr (,(and (not (? applicable-tag?)) a) . ,d)) d) 238 | (`(null? ,v) (match v ('() #t) (_ #f))) 239 | (`(pair? ,v) (match v (`(,(not (? applicable-tag?)) . ,_) #t) (_ #f))) 240 | (`(symbol? ,v) (symbol? v)) 241 | (`(number? ,v) (number? v)) 242 | (`(not ,v) (match v (#f #t) (_ #f))) 243 | (`(equal? ,v1 ,v2) (equal? v1 v2)))) 244 | (define (eval-qq qqterm env) 245 | (match qqterm 246 | (`(,'unquote ,term) (eval-term term env)) 247 | (`(,a . ,d) `(,(eval-qq a env) . ,(eval-qq d env))) 248 | ((? quotable? datum) datum))) 249 | (define (eval-and t* env) 250 | (match t* 251 | ('() #t) 252 | (`(,t) (eval-term t env)) 253 | (`(,t . ,t*) (if (eval-term t env) (eval-and t* env) #f)))) 254 | (define (eval-or t* env) 255 | (match t* 256 | ('() #f) 257 | (`(,t) (eval-term t env)) 258 | (`(,t . ,t*) (let ((condition (eval-term t env))) 259 | (if condition condition (eval-or t* env)))))) 260 | (define (eval-application proc a*) 261 | (match proc 262 | (`(,(? prim-tag?) . ,prim-id) (eval-prim prim-id a*)) 263 | (`(,(? closure-tag?) (lambda ,x ,body) ,env^) 264 | (let ((res (match x 265 | ((and (not (? symbol?)) params) 266 | (extend-env* params a* env^)) 267 | (sym `((val . (,sym . ,a*)) . ,env^))))) 268 | (eval-term body res))))) 269 | (define (eval-term-list terms env) 270 | (match terms 271 | ('() '()) 272 | (`(,term . ,terms) 273 | `(,(eval-term term env) . ,(eval-term-list terms env))))) 274 | (define (eval-term term env) 275 | (let ((bound? (lambda (sym) (in-env? env sym)))) 276 | (match term 277 | (#t #t) 278 | (#f #f) 279 | ((? number? num) num) 280 | ((? symbol? sym) (lookup env sym)) 281 | ((and `(,op . ,_) operation) 282 | (match operation 283 | (`(,(or (? bound?) (not (? symbol?))) . ,rands) 284 | (let ((op (eval-term op env)) 285 | (a* (eval-term-list rands env))) 286 | (eval-application op a*))) 287 | (`(quote ,(? quotable? datum)) datum) 288 | (`(quasiquote ,qqterm) (eval-qq qqterm env)) 289 | (`(if ,condition ,alt-true ,alt-false) 290 | (if (eval-term condition env) 291 | (eval-term alt-true env) 292 | (eval-term alt-false env))) 293 | (`(lambda ,params ,body) 294 | `(,closure-tag (lambda ,params ,body) ,env)) 295 | (`(let ,binding* ,let-body) 296 | (let-values (((ps vs) (split-bindings binding*))) 297 | (eval-term let-body 298 | (extend-env* ps (eval-term-list vs env) env)))) 299 | (`(letrec ,binding* ,letrec-body) 300 | (eval-term letrec-body `((rec . ,binding*) . ,env))) 301 | (`(and . ,t*) (eval-and t* env)) 302 | (`(or . ,t*) (eval-or t* env)) 303 | (`(match ,scrutinee . ,pt*) 304 | (eval-match pt* (eval-term scrutinee env) env))))))) 305 | 306 | (module+ test 307 | (check-equal? (eval-term 3 initial-env) 3) 308 | (check-equal? (eval-term '3 initial-env) 3) 309 | (check-equal? (eval-term ''x initial-env) 'x) 310 | (check-equal? (eval-term ''(1 (2) 3) initial-env) '(1 (2) 3)) 311 | (check-equal? (eval-term '(car '(1 (2) 3)) initial-env) 1) 312 | (check-equal? (eval-term '(cdr '(1 (2) 3)) initial-env) '((2) 3)) 313 | (check-equal? (eval-term '(cons 'x 4) initial-env) '(x . 4)) 314 | (check-equal? (eval-term '(null? '()) initial-env) #t) 315 | (check-equal? (eval-term '(null? '(0)) initial-env) #f) 316 | (check-equal? (eval-term '(list 5 6) initial-env) '(5 6)) 317 | (check-equal? (eval-term '(and #f 9 10) initial-env) #f) 318 | (check-equal? (eval-term '(and 8 9 10) initial-env) 10) 319 | (check-equal? (eval-term '(or #f 11 12) initial-env) 11) 320 | (check-equal? (eval-term '(let ((p (cons 8 9))) (cdr p)) initial-env) 9) 321 | 322 | (define ex-append 323 | '(letrec ((append 324 | (lambda (xs ys) 325 | (if (null? xs) ys (cons (car xs) (append (cdr xs) ys)))))) 326 | (list (append '() '()) (append '(foo) '(bar)) (append '(1 2) '(3 4)))) ) 327 | (define ex-append-answer '(() (foo bar) (1 2 3 4))) 328 | (check-true (term? ex-append initial-env)) 329 | (check-equal? (eval-term ex-append initial-env) ex-append-answer) 330 | (check-equal? (eval-term '`(1 ,(car `(,(cdr '(b 2)) 3)) ,'a) initial-env) 331 | '(1 (2) a)) 332 | 333 | (check-equal? 334 | (eval-term 335 | '(match '(1 (b 2)) 336 | (`(1 (a ,x)) 3) 337 | (`(1 (b ,x)) x) 338 | (_ 4)) 339 | initial-env) 340 | 2) 341 | (check-equal? 342 | (eval-term 343 | '(match '(1 1 2) 344 | (`(,a ,b ,a) `(first ,a ,b)) 345 | (`(,a ,a ,b) `(second ,a ,b)) 346 | (_ 4)) 347 | initial-env) 348 | '(second 1 2)) 349 | 350 | (define ex-match 351 | '(match '(1 2 1) 352 | (`(,a ,b ,a) `(first ,a ,b)) 353 | (`(,a ,a ,b) `(second ,a ,b)) 354 | (_ 4))) 355 | (check-true (term? ex-match initial-env)) 356 | (check-equal? 357 | (eval-term ex-match initial-env) 358 | '(first 1 2)) 359 | 360 | (define ex-eval-expr 361 | '(letrec 362 | ((eval-expr 363 | (lambda (expr env) 364 | (match expr 365 | (`(quote ,datum) datum) 366 | (`(lambda (,(? symbol? x)) ,body) 367 | (lambda (a) 368 | (eval-expr body (lambda (y) 369 | (if (equal? y x) a (env y)))))) 370 | ((? symbol? x) (env x)) 371 | (`(cons ,e1 ,e2) (cons (eval-expr e1 env) (eval-expr e2 env))) 372 | (`(,rator ,rand) ((eval-expr rator env) 373 | (eval-expr rand env))))))) 374 | (list 375 | (eval-expr '((lambda (y) y) 'g1) 'initial-env) 376 | (eval-expr '(((lambda (z) z) (lambda (v) v)) 'g2) 'initial-env) 377 | (eval-expr '(((lambda (a) (a a)) (lambda (b) b)) 'g3) 'initial-env) 378 | (eval-expr '(((lambda (c) (lambda (d) c)) 'g4) 'g5) 'initial-env) 379 | (eval-expr '(((lambda (f) (lambda (v1) (f (f v1)))) (lambda (e) e)) 'g6) 'initial-env) 380 | (eval-expr '((lambda (g) ((g g) g)) (lambda (i) (lambda (j) 'g7))) 'initial-env)))) 381 | (check-true (term? ex-eval-expr initial-env)) 382 | (check-equal? 383 | (eval-term ex-eval-expr initial-env) 384 | '(g1 g2 g3 g4 g6 g7)) 385 | 386 | ; the goal is to support something like this interpreter 387 | (define ex-eval-complex 388 | `(let ((closure-tag ',(gensym "#%closure")) 389 | (prim-tag ',(gensym "#%primitive")) 390 | (empty-env '())) 391 | (let ((initial-env 392 | `((cons . (val . (,prim-tag . cons))) 393 | (car . (val . (,prim-tag . car))) 394 | (cdr . (val . (,prim-tag . cdr))) 395 | (null? . (val . (,prim-tag . null?))) 396 | (pair? . (val . (,prim-tag . pair?))) 397 | (symbol? . (val . (,prim-tag . symbol?))) 398 | (not . (val . (,prim-tag . not))) 399 | (equal? . (val . (,prim-tag . equal?))) 400 | (list . (val . (,closure-tag (lambda x x) ,empty-env))) 401 | . ,empty-env)) 402 | (closure-tag? (lambda (v) (equal? v closure-tag))) 403 | (prim-tag? (lambda (v) (equal? v prim-tag)))) 404 | (letrec 405 | ((applicable-tag? (lambda (v) (or (closure-tag? v) (prim-tag? v)))) 406 | (quotable? (lambda (v) 407 | (match v 408 | ((? symbol?) (not (applicable-tag? v))) 409 | (`(,a . ,d) (and (quotable? a) (quotable? d))) 410 | (_ #t)))) 411 | (not-in-params? (lambda (ps sym) 412 | (match ps 413 | ('() #t) 414 | (`(,a . ,d) 415 | (and (not (equal? a sym)) 416 | (not-in-params? d sym)))))) 417 | (param-list? (lambda (x) 418 | (match x 419 | ('() #t) 420 | (`(,(? symbol? a) . ,d) 421 | (and (param-list? d) (not-in-params? d a))) 422 | (_ #f)))) 423 | (params? (lambda (x) 424 | (match x 425 | ((? param-list?) #t) 426 | (x (symbol? x))))) 427 | (in-env? (lambda (env sym) 428 | (match env 429 | ('() #f) 430 | (`((,a . ,_). ,d) 431 | (or (equal? a sym) (in-env? d sym)))))) 432 | (extend-env* 433 | (lambda (params args env) 434 | (match `(,params . ,args) 435 | (`(() . ()) env) 436 | (`((,x . ,dx*) . (,a . ,da*)) 437 | (extend-env* dx* da* `((,x . (val . ,a)) . ,env)))))) 438 | (lookup 439 | (lambda (env sym) 440 | (match env 441 | (`((,y . ,b) . ,rest) 442 | (if (equal? sym y) 443 | (match b 444 | (`(val . ,v) v) 445 | (`(rec . ,lam-expr) `(,closure-tag ,lam-expr ,env))) 446 | (lookup rest sym)))))) 447 | (term? 448 | (lambda (term env) 449 | (letrec 450 | ((term1? (lambda (v) (term? v env))) 451 | (terms? (lambda (ts env) 452 | (match ts 453 | ('() #t) 454 | (`(,t . ,ts) 455 | (and (term? t env) (terms? ts env))))))) 456 | (match term 457 | (#t #t) 458 | (#f #t) 459 | ((? number?) #t) 460 | ((and (? symbol? sym)) (in-env? env sym)) 461 | (`(,(? term1?) . ,rands) (terms? rands env)) 462 | (`(quote ,datum) (quotable? datum)) 463 | (`(if ,c ,t ,f) (and (term1? c) (term1? t) (term1? f))) 464 | (`(lambda ,params ,body) 465 | (and (params? params) 466 | (let ((res 467 | (match params 468 | ((and (not (? symbol?)) params) 469 | (extend-env* params params env)) 470 | (sym `((,sym . (val . ,sym)) . ,env))))) 471 | (term? body res)))) 472 | (`(letrec 473 | ((,p-name ,(and `(lambda ,params ,body) lam-expr))) 474 | ,letrec-body) 475 | (and (params? params) 476 | (let ((res `((,p-name 477 | . (rec . (lambda ,params ,body))) 478 | . ,env))) 479 | (and (term? lam-expr res) 480 | (term? letrec-body res))))) 481 | (_ #f))))) 482 | (eval-prim 483 | (lambda (prim-id args) 484 | (match `(,prim-id . ,args) 485 | (`(cons ,a ,d) `(,a . ,d)) 486 | (`(car (,(and (not (? applicable-tag?)) a) . ,d)) a) 487 | (`(cdr (,(and (not (? applicable-tag?)) a) . ,d)) d) 488 | (`(null? ,v) (match v ('() #t) (_ #f))) 489 | (`(pair? ,v) (match v 490 | (`(,(not (? applicable-tag?)) . ,_) #t) 491 | (_ #f))) 492 | (`(symbol? ,v) (symbol? v)) 493 | (`(number? ,v) (number? v)) 494 | (`(not ,v) (match v (#f #t) (_ #f))) 495 | (`(equal? ,v1 ,v2) (equal? v1 v2))))) 496 | (eval-term-list 497 | (lambda (terms env) 498 | (match terms 499 | ('() '()) 500 | (`(,term . ,terms) 501 | `(,(eval-term term env) . ,(eval-term-list terms env)))))) 502 | (eval-term 503 | (lambda (term env) 504 | (let ((bound? (lambda (sym) (in-env? env sym))) 505 | (term1? (lambda (v) (term? v env)))) 506 | (match term 507 | (#t #t) 508 | (#f #f) 509 | ((? number? num) num) 510 | (`(,(and 'quote (not (? bound?))) ,(? quotable? datum)) 511 | datum) 512 | ((? symbol? sym) (lookup env sym)) 513 | ((and `(,op . ,_) operation) 514 | (match operation 515 | (`(,(or (? bound?) (not (? symbol?))) 516 | . ,rands) 517 | (let ((op (eval-term op env)) 518 | (a* (eval-term-list rands env))) 519 | (match op 520 | (`(,(? prim-tag?) . ,prim-id) 521 | (eval-prim prim-id a*)) 522 | (`(,(? closure-tag?) (lambda ,x ,body) ,env^) 523 | (let ((res (match x 524 | ((and (not (? symbol?)) params) 525 | (extend-env* params a* env^)) 526 | (sym `((,sym . (val . ,a*)) 527 | . ,env^))))) 528 | (eval-term body res)))))) 529 | (`(if ,condition ,alt-true ,alt-false) 530 | (if (eval-term condition env) 531 | (eval-term alt-true env) 532 | (eval-term alt-false env))) 533 | ((? term1? `(lambda ,params ,body)) 534 | `(,closure-tag (lambda ,params ,body) ,env)) 535 | ((? term1? `(letrec ((,p-name (lambda ,params ,body))) 536 | ,letrec-body)) 537 | (eval-term 538 | letrec-body 539 | `((,p-name . (rec . (lambda ,params ,body))) 540 | . ,env)))))))))) 541 | 542 | (let ((program ',ex-append)) 543 | (and (term? program initial-env) 544 | (eval-term program initial-env))))))) 545 | (check-true (term? ex-eval-complex initial-env)) 546 | (check-equal? (eval-term ex-eval-complex initial-env) ex-append-answer) 547 | ) 548 | -------------------------------------------------------------------------------- /transparent.scm: -------------------------------------------------------------------------------- 1 | (define-syntax let*/and 2 | (syntax-rules () 3 | ((_ () rest ...) (and rest ...)) 4 | ((_ ((name expr) ne* ...) rest ...) 5 | (let ((name expr)) 6 | (and name (let*/and (ne* ...) rest ...)))))) 7 | 8 | (define-syntax defrecord 9 | (syntax-rules () 10 | ((_ name name?) 11 | (begin 12 | (define name (vector 'name)) 13 | (define (name? datum) (eq? name datum)))) 14 | ((_ name name? (field set-field) ...) 15 | (begin 16 | (define (name field ...) (vector 'name field ...)) 17 | (define (name? datum) 18 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 19 | (let () 20 | (define (range-assoc start xs) 21 | (let loop ((xs xs) (idx start)) 22 | (if (null? xs) 23 | '() 24 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 25 | (define (define-field-getter name rassc) 26 | (define idx (cdr (assoc name rassc))) 27 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 28 | (define (define-field-setter name rassc) 29 | (define idx (cdr (assoc name rassc))) 30 | (eval `(define (,name datum value) 31 | (let ((new (vector-copy datum))) 32 | (vector-set! new ,idx value) 33 | new)))) 34 | (let ((fns (range-assoc 1 '(field ...)))) 35 | (begin (define-field-getter 'field fns) ...)) 36 | (let ((set-fns (range-assoc 1 '(set-field ...)))) 37 | (begin (define-field-setter 'set-field set-fns) ...))))) 38 | ((_ name name? field ...) 39 | (begin 40 | (define (name field ...) (vector 'name field ...)) 41 | (define (name? datum) 42 | (and (vector? datum) (eq? 'name (vector-ref datum 0)))) 43 | (let () 44 | (define (range-assoc start xs) 45 | (let loop ((xs xs) (idx start)) 46 | (if (null? xs) 47 | '() 48 | (cons (cons (car xs) idx) (loop (cdr xs) (+ idx 1)))))) 49 | (define (define-field-getter name rassc) 50 | (define idx (cdr (assoc name rassc))) 51 | (eval `(define (,name datum) (vector-ref datum ,idx)))) 52 | (let ((fns (range-assoc 1 '(field ...)))) 53 | (begin (define-field-getter 'field fns) ...))))))) 54 | 55 | (define store-empty '()) 56 | (define (store-ref store key . default) 57 | (let ((binding (assoc key store))) 58 | (if binding 59 | (cdr binding) 60 | (if (null? default) 61 | (error 'store-ref (format "missing key ~s in ~s" key store)) 62 | (car default))))) 63 | (define (store-set store key value) `((,key . ,value) . ,store)) 64 | 65 | (defrecord var var? var-index) 66 | (define var/fresh 67 | (let ((index -1)) 68 | (lambda () 69 | (set! index (+ 1 index)) 70 | (var index)))) 71 | ;(define var=? eq?) 72 | (define (var=? t1 t2) 73 | (and (var? t1) (var? t2) (eqv? (var-index t1) (var-index t2)))) 74 | (define (varpath sol) 147 | (let loop-sol ((sol sol) (done '()) (path '())) 148 | (if (null? sol) 149 | (append path done) 150 | (let loop-desc ((ds (caar sol)) (done done) (prefix '()) (suffix path)) 151 | (if (null? ds) 152 | (begin 153 | (loop-sol (cdr sol) done (rappend prefix suffix))) 154 | (let ((desc (car ds)) (rds (cdr ds))) 155 | (cond 156 | ((eq? 'swap desc) 157 | (if (car suffix) 158 | (loop-desc '() done prefix (cons #f (cdr suffix))) 159 | (loop-desc rds done (cons #t prefix) (cdr suffix)))) 160 | ((eq? 'fail desc) (loop-desc '() done prefix (cons #f suffix))) 161 | ((eq? 'ascend desc) 162 | (if (and (pair? suffix) (not (car suffix))) 163 | (let loop-ascend 164 | ((rds rds) (prefix prefix) (suffix (cdr suffix))) 165 | (cond 166 | ((car suffix) 167 | (loop-desc '() done (cons #f prefix) (cdr suffix))) 168 | ((eq? 'succeed (car rds)) 169 | (loop-desc '() done (cons #t prefix) (cons #f (cdr suffix)))) 170 | (else (loop-ascend (cdr rds) 171 | (cons (not (car suffix)) prefix) 172 | (cdr suffix))))) 173 | (loop-desc rds done (cons #t prefix) suffix))) 174 | ((eq? 'succeed desc) 175 | (if (and (pair? suffix) (car suffix)) 176 | (loop-desc '() (append (cdr suffix) done) prefix '(#t)) 177 | (loop-desc '() done prefix suffix))) 178 | (else (error 'solution->path 179 | (format "bad description ~s" desc)))))))))) 180 | 181 | (define (labeled-solution ss) 182 | (define answer1 183 | (begin (solution-clear!) (reify-initial (car (stream-take 1 ss))))) 184 | (define path (solution->path solution-info)) 185 | (define follow (follow-path '() path ss)) 186 | (define leftover (car follow)) 187 | (define answer2 (reify-initial (car (stream-take 1 (cadr follow))))) 188 | (define choices (caddr follow)) 189 | (cond 190 | ((pair? leftover) 191 | (error 'labeled-solution (format "unused path: ~s" leftover))) 192 | ((not (equal? answer1 answer2)) 193 | (error 'labeled-solution 194 | (format "mismatching answers:\nexpected:~s\ncomputed:~s" 195 | answer1 answer2))) 196 | (else choices))) 197 | 198 | (define (labeled-solution* ss) 199 | (define answer1 200 | (begin (solution-clear!) (reify-initial (car (stream-take 1 ss))))) 201 | (define path (solution->path solution-info)) 202 | (define follow (follow-path* follow-ctx0 '() path ss)) 203 | (define leftover (car follow)) 204 | (define answer2 (reify-initial (car (stream-take 1 (cadr follow))))) 205 | (define choices (cadddr follow)) 206 | (cond 207 | ((pair? leftover) 208 | (error 'labeled-solution* (format "unused path: ~s" leftover)) ) 209 | ((not (equal? answer1 answer2)) 210 | (error 'labeled-solution* 211 | (format "mismatching answers:\nexpected:~s\ncomputed:~s" 212 | answer1 answer2))) 213 | (else choices))) 214 | 215 | (define (labeled-solution*-hint ss-hint ss) 216 | (define answer1 217 | (begin (solution-clear!) (reify-initial (car (stream-take 1 ss-hint))))) 218 | (define path (solution->path solution-info)) 219 | (define follow (follow-path* follow-ctx0 '() path ss)) 220 | (define leftover (car follow)) 221 | (define answer2 (reify-initial (car (stream-take 1 (cadr follow))))) 222 | (define choices (cadddr follow)) 223 | (cond 224 | ((pair? leftover) 225 | (error 'labeled-solution*-hint (format "unused path: ~s" leftover))) 226 | ((not (equal? answer1 answer2)) 227 | (error 'labeled-solution*-hint 228 | (format "mismatching answers:\nexpected:~s\ncomputed:~s" 229 | answer1 answer2))) 230 | (else choices))) 231 | 232 | (define (labeled-pretty choices) 233 | (map (lambda (choice) (list (car choice) 234 | (cadr (stream-pretty (cadr choice))))) 235 | choices)) 236 | 237 | (define (fbind/no-fail ss goal) 238 | (cond 239 | ((or (not ss) (state? ss)) (fstart/no-fail ss goal)) 240 | ((pair? ss) (disj (pause (car ss) goal) (conj (cdr ss) goal))) 241 | (else (conj ss goal)))) 242 | (define (fstart/no-fail st goal) 243 | (cond 244 | ((conj? goal) (fbind/no-fail (fstart/no-fail st (conj-c1 goal)) 245 | (conj-c2 goal))) 246 | ((disj? goal) (disj (pause st (disj-c1 goal)) (pause st (disj-c2 goal)))) 247 | ((zzz? goal) (fstart/no-fail st ((zzz-wake goal)))) 248 | ((==? goal) (and st (unify st (==-t1 goal) (==-t2 goal)))))) 249 | 250 | (define (fbind ss goal) 251 | (cond 252 | ((not ss) #f) 253 | ((state? ss) (fstart ss goal)) 254 | ((pair? ss) (disj (pause (car ss) goal) (conj (cdr ss) goal))) 255 | (else (conj ss goal)))) 256 | (define (fstart st goal) 257 | (cond 258 | ((conj? goal) (fbind (fstart st (conj-c1 goal)) (conj-c2 goal))) 259 | ((disj? goal) (disj (pause st (disj-c1 goal)) (pause st (disj-c2 goal)))) 260 | ((zzz? goal) (fstart st ((zzz-wake goal)))) 261 | ((==? goal) (unify st (==-t1 goal) (==-t2 goal))))) 262 | 263 | (define (follow-path choices path ss) 264 | (cond 265 | ((pair? ss) (list path (car ss) choices)) 266 | ((state? ss) (list path ss choices)) 267 | ((null? path) (list '() ss choices)) 268 | ((not ss) (list path #f choices)) 269 | ((conj? ss) 270 | (let* ((result (follow-path choices path (conj-c1 ss))) 271 | (path (car result)) 272 | (ss1 (cadr result)) 273 | (choices (caddr result))) 274 | (follow-path choices path (fbind ss1 (conj-c2 ss))))) 275 | ((disj? ss) 276 | (follow-path (cons (list (car path) ss) choices) (cdr path) 277 | (if (car path) (disj-c1 ss) (disj-c2 ss)))) 278 | ((pause? ss) 279 | (follow-path choices path (fstart (pause-state ss) (pause-goal ss)))) 280 | (else (error 'follow-path (format "bad stream following ~s ~s" path ss))))) 281 | 282 | (define (leaf? ss) 283 | (cond 284 | ((disj? ss) #f) 285 | ((conj? ss) (and (leaf? (conj-c1 ss)) (leaf? (conj-c2 ss)))) 286 | ((pause? ss) (leaf? (pause-goal ss))) 287 | (else #t))) 288 | 289 | (define (follow-ctx0 subpath ss) (list subpath ss)) 290 | 291 | (define (follow-path* ctx choices path ss) 292 | (define (choice-shift k) 293 | (lambda (choice) (ctx (car choice) (conj (cadr choice) k)))) 294 | (define (ctx-disj direction alt-branch) 295 | (lambda (subpath ss) 296 | (ctx (cons direction subpath) 297 | (if ss 298 | (if direction (disj ss alt-branch) (disj alt-branch ss)) 299 | alt-branch)))) 300 | (define (ctx-fill alt) (cadr (ctx '() alt))) 301 | (cond 302 | ((pair? ss) (list path (car ss) (ctx-fill (cdr ss)) choices)) 303 | ((state? ss) (list path ss (ctx-fill #f) choices)) 304 | ((null? path) (list '() ss (ctx-fill #f) choices)) 305 | ((not ss) (list path #f (ctx-fill #f) choices)) 306 | ((conj? ss) 307 | (let* ((result (follow-path* follow-ctx0 '() path (conj-c1 ss))) 308 | (path (car result)) 309 | (ss1 (cadr result)) 310 | (alt-ss (caddr result)) 311 | (alt-ss (and alt-ss (conj alt-ss (conj-c2 ss)))) 312 | (choices (append (map (choice-shift (conj-c2 ss)) (cadddr result)) 313 | choices)) 314 | (ctx (if alt-ss (ctx-disj #t alt-ss) ctx))) 315 | (follow-path* ctx choices path (fbind ss1 (conj-c2 ss))))) 316 | ((disj? ss) 317 | (let* ((dir (car path)) 318 | (branch (if dir (disj-c1 ss) (disj-c2 ss))) 319 | (alt-branch (if dir (disj-c2 ss) (disj-c1 ss)))) 320 | (follow-path* (ctx-disj dir alt-branch) 321 | (if (leaf? branch) (cons (ctx (list dir) ss) choices) 322 | choices) 323 | (cdr path) branch))) 324 | ((pause? ss) 325 | (follow-path* ctx choices path (fstart (pause-state ss) (pause-goal ss)))) 326 | (else (error 'follow-path* (format "bad stream following ~s ~s" path ss))))) 327 | 328 | (define (wake-path path ss) 329 | (cond 330 | ((conj? ss) (conj (wake-path path (conj-c1 ss)) (conj-c2 ss))) 331 | ((disj? ss) 332 | (cond ((null? path) (error 'wake-path (format "path is too short ~s" ss))) 333 | ((car path) (disj (wake-path (cdr path) (disj-c1 ss)) (disj-c2 ss))) 334 | (else (disj (disj-c1 ss) (wake-path (cdr path) (disj-c2 ss)))))) 335 | ((pause? ss) 336 | (cond ((not (zzz? (pause-goal ss))) 337 | (error 'wake-path (format "expected zzz ~s ~s" path ss))) 338 | ((pair? path) 339 | (error 'wake-path (format "path is too long ~s ~s" path ss))) 340 | (else (prune-goal 341 | 50 (pause-state ss) ((zzz-wake (pause-goal ss))))))) 342 | (else (error 'wake-path (format "cannot wake ~s ~s" path ss))))) 343 | 344 | (define (prune force? ss) 345 | (cond 346 | ((conj? ss) (prune-bind force? (prune force? (conj-c1 ss)) (conj-c2 ss))) 347 | ((disj? ss) (prune-mplus force? (prune #f (disj-c1 ss)) (disj-c2 ss))) 348 | ((pause? ss) (prune-goal force? (pause-state ss) (pause-goal ss))) 349 | ((not ss) #f) 350 | (else ss))) 351 | (define (prune-goal force? st goal) 352 | (cond 353 | ((conj? goal) 354 | (prune-bind force? (prune-goal force? st (conj-c1 goal)) (conj-c2 goal))) 355 | ((disj? goal) 356 | (prune force? (disj (pause st (disj-c1 goal)) (pause st (disj-c2 goal))))) 357 | ((zzz? goal) 358 | (if force? 359 | (prune-goal (or (eq? #t force?) (and (< 1 force?) (- force? 1))) 360 | st ((zzz-wake goal))) 361 | (pause st goal))) 362 | ((==? goal) (unify st (==-t1 goal) (==-t2 goal))) 363 | (else (error 'prune-goal (format "unexpected goal: ~s" ss))))) 364 | (define (prune-mplus force? c1 c2) 365 | (define (build c1 c2) 366 | (cond ((pair? c1) (cons (car c1) (build (cdr c1) c2))) 367 | ((state? c1) (cons c1 c2)) 368 | ((pair? c2) (cons (car c2) (build (cdr c2) c1))) 369 | ((state? c2) (cons c2 c1)) 370 | (else (disj c1 c2)))) 371 | (if c1 (let ((c2 (prune #f c2))) 372 | (cond (c2 (build c1 c2)) 373 | (force? (prune force? c1)) 374 | (else c1))) 375 | (prune force? c2))) 376 | (define (prune-bind force? ss goal) 377 | (cond ((not ss) #f) 378 | ((state? ss) (prune-goal force? ss goal)) 379 | ((pair? ss) (prune-mplus force? (prune-goal #f (car ss) goal) 380 | (conj (cdr ss) goal))) 381 | (else (conj ss goal)))) 382 | 383 | (define (expand-path path path-expected ss0) 384 | (define ss (prune #t (wake-path path ss0))) 385 | (list (cond ((not ss) (error 'expand-path (format "no solution ~s" ss0))) 386 | ((or (state? ss) (pair? ss)) 'solved) 387 | ((equal? path path-expected) 'good) 388 | (else 'unknown)) 389 | ss)) 390 | 391 | (define (good-path hint ss g*) 392 | (define (use-hint st) (unify st (==-t1 hint) (==-t2 hint))) 393 | (define (good-path-goal st g g*) 394 | (cond ((conj? g) (good-path-goal st (conj-c1 g) (cons (conj-c2 g) g*))) 395 | ((disj? g) (let ((p1 (good-path-goal st (disj-c1 g) g*))) 396 | (if p1 (cons #t p1) 397 | (let ((p2 (good-path-goal st (disj-c2 g) g*))) 398 | (and p2 (cons #f p2)))))) 399 | ((zzz? g) (and (good-path-goal st ((zzz-wake g)) g*) '())) 400 | ((==? g) 401 | (let ((st (unify st (==-t1 g) (==-t2 g)))) 402 | (and st (or (null? g*) (good-path-goal st (car g*) (cdr g*))) 403 | '()))) 404 | (else (error 'good-path-goal (format "unexpected goal ~s" g))))) 405 | (cond ((conj? ss) (good-path hint (conj-c1 ss) (cons (conj-c2 ss) g*))) 406 | ((disj? ss) (let* ((p1 (good-path hint (disj-c1 ss) g*))) 407 | (if p1 (cons #t p1) 408 | (let ((p2 (good-path hint (disj-c2 ss) g*))) 409 | (and p2 (cons #f p2)))))) 410 | ((pause? ss) (let ((st (use-hint (pause-state ss)))) 411 | (and st (good-path-goal st (pause-goal ss) g*)))) 412 | (else (error 'good-path (format "unexpected stream ~s" ss))))) 413 | 414 | (define (good-paths hint ss) 415 | (define path (good-path hint ss '())) 416 | (define next (expand-path path path ss)) 417 | (define flag (car next)) 418 | (define ss-next (cadr next)) 419 | (cons (cons path ss) (if (eq? 'solved flag) '() (good-paths hint ss-next)))) 420 | 421 | (define (interact in show out hint ss gpath show?) 422 | (define (valid-path? path) 423 | (or (null? path) 424 | (and (pair? path) (or (eqv? #t (car path)) (eqv? #f (car path))) 425 | (valid-path? (cdr path))))) 426 | (define good (if gpath gpath (good-path hint ss '()))) 427 | (when show? (show ss)) 428 | (let ((request (in))) 429 | (when (not (eof-object? request)) 430 | (cond 431 | ((eq? 'good-path request) 432 | (out (list 'good-path good)) 433 | (interact in show out hint ss good #f)) 434 | ((eq? 'steps-remaining request) 435 | (out (list 'steps-remaining (map car (good-paths hint ss)))) 436 | (interact in show out hint ss good #f)) 437 | ((and (pair? request) (eq? 'jump-to-steps-remaining (car request))) 438 | (let* ((remaining (good-paths hint ss)) 439 | (remaining-count (length remaining)) 440 | (drop-count (- remaining-count (cadr request))) 441 | (chosen (and (<= 0 drop-count) 442 | (> remaining-count drop-count) 443 | (list-ref remaining drop-count)))) 444 | (when (> 0 drop-count) 445 | (error 'interact (format "only ~s steps remain: ~s" 446 | remaining-count (cadr request)))) 447 | (when (<= remaining-count drop-count) 448 | (error 'interact "cannot jump to steps-remaining lower than 1")) 449 | (interact in show out hint (cdr chosen) (car chosen) #t))) 450 | ((and (pair? request) (valid-path? request)) 451 | (let* ((result (expand-path request good ss)) 452 | (flag (car result)) 453 | (ss2 (cadr result))) 454 | (out (list 'follow-path flag)) 455 | (when (not (or (eq? 'solved flag) (eq? 'fail-solved flag))) 456 | (interact in show out hint ss2 #f #t)))) 457 | (else (error 'interact (format "invalid request: ~s" request))))))) 458 | 459 | (define (bind ss goal) 460 | (cond 461 | ((not ss) #f) 462 | ((state? ss) (start ss goal)) 463 | ((pair? ss) (disj (pause (car ss) goal) (conj (cdr ss) goal))) 464 | ;; Immediate restart confuses solution->path, so disable this for now. 465 | ;((pair? ss) (mplus (start (car ss) goal) (conj (cdr ss) goal))) 466 | (else (conj ss goal)))) 467 | (define (mplus s1 s2) 468 | (cond 469 | ((not s1) 470 | (solution-describe! 'fail) 471 | s2) 472 | ((state? s1) 473 | (solution-describe! 'succeed) 474 | (cons s1 s2)) 475 | ((pair? s1) 476 | (solution-describe! 'ascend) 477 | (cons (car s1) (disj s2 (cdr s1)))) 478 | (else 479 | (solution-describe! 'swap) 480 | (disj s2 s1)))) 481 | 482 | (define (start st goal) 483 | (cond 484 | ((conj? goal) (bind (start st (conj-c1 goal)) (conj-c2 goal))) 485 | ((disj? goal) (disj (pause st (disj-c1 goal)) (pause st (disj-c2 goal)))) 486 | ((zzz? goal) (start st ((zzz-wake goal)))) 487 | ((==? goal) (unify st (==-t1 goal) (==-t2 goal))) 488 | (else (error 'start (format "invalid goal to start: ~s" goal))))) 489 | 490 | (define (continue ss) 491 | (cond 492 | ((conj? ss) (bind (continue (conj-c1 ss)) (conj-c2 ss))) 493 | ((disj? ss) (mplus (continue (disj-c1 ss)) (disj-c2 ss))) 494 | ((pause? ss) (start (pause-state ss) (pause-goal ss))) 495 | ((not ss) #f) 496 | ((state? ss) (cons ss #f)) 497 | (else (error 'start (format "invalid stream to continue: ~s" ss))))) 498 | 499 | (define (stream-next ps) 500 | (define ss (begin (solution-step! ps) (continue ps))) 501 | (cond 502 | ((not ss) '()) 503 | ((state? ss) (cons ss #f)) 504 | ((pair? ss) 505 | (solution-describe! 'ascend) 506 | ss) 507 | (else (stream-next ss)))) 508 | 509 | (define (stream-take n ps) 510 | (if (and n (= 0 n)) 511 | '() 512 | (let ((ss (stream-next ps))) 513 | (if (pair? ss) 514 | (cons (car ss) (stream-take (and n (- n 1)) (cdr ss))) 515 | '())))) 516 | 517 | (define (goal-pretty goal) 518 | (cond 519 | ((conj? goal) `(conj ,(goal-pretty (conj-c1 goal)) ,(goal-pretty (conj-c2 goal)))) 520 | ((disj? goal) `(disj ,(goal-pretty (disj-c1 goal)) ,(goal-pretty (disj-c2 goal)))) 521 | ((zzz? goal) (zzz-metadata goal)) 522 | ((==? goal) `(== ,(==-t1 goal) ,(==-t2 goal))))) 523 | (define (stream-pretty ss) 524 | (define (pretty ss) 525 | (cond 526 | ((conj? ss) `(conj ,(pretty (conj-c1 ss)) 527 | ,(reify #f state-empty (goal-pretty (conj-c2 ss))))) 528 | ((disj? ss) `(disj ,(pretty (disj-c1 ss)) ,(pretty (disj-c2 ss)))) 529 | ((pause? ss) 530 | (reify #f (pause-state ss) 531 | `(pause (state ,var-initial) ,(goal-pretty (pause-goal ss))))) 532 | (else ss))) 533 | (let loop ((ss ss) (states '())) 534 | (cond 535 | ((state? ss) (loop #f (cons ss states))) 536 | ((pair? ss) (loop (cdr ss) (cons (car ss) states))) 537 | (else (list (map reify-initial (reverse states)) (pretty ss)))))) 538 | 539 | (define (step n ss) 540 | (cond 541 | ((= 0 n) ss) 542 | ((not ss) #f) 543 | ((pair? ss) (cons (car ss) (step n (cdr ss)))) 544 | (else (solution-step! ss) (step (- n 1) (continue ss))))) 545 | 546 | (define succeed (== #t #t)) 547 | (define fail (== #f #t)) 548 | 549 | (define-syntax conj* 550 | (syntax-rules () 551 | ((_) succeed) 552 | ((_ g) g) 553 | ((_ gs ... g-final) (conj (conj* gs ...) g-final)))) 554 | (define-syntax disj* 555 | (syntax-rules () 556 | ((_) fail) 557 | ((_ g) g) 558 | ((_ g0 gs ...) (disj g0 (disj* gs ...))))) 559 | 560 | (define-syntax fresh 561 | (syntax-rules () 562 | ((_ (vr ...) g0 gs ...) (let ((vr (var/fresh)) ...) (conj* g0 gs ...))))) 563 | (define-syntax conde 564 | (syntax-rules () 565 | ((_ (g0 gs ...)) (conj* g0 gs ...)) 566 | ((_ c0 cs ...) (disj (conde c0) (conde cs ...))))) 567 | 568 | (define (run-goal n st goal) (stream-take n (pause st goal))) 569 | 570 | (define (walk* st tm) 571 | (let ((tm (walk st tm))) 572 | (if (pair? tm) 573 | `(,(walk* st (car tm)) . ,(walk* st (cdr tm))) 574 | tm))) 575 | 576 | (define (reify index st tm) 577 | (let loop 578 | ((rvs store-empty) (index index) (tm tm) (k (lambda (rvs i tm) tm))) 579 | (let ((tm (walk st tm))) 580 | (cond 581 | ((var? tm) 582 | (let* ((idx (store-ref rvs tm (or index (var-index tm)))) 583 | (n (string->symbol (string-append "_." (number->string idx))))) 584 | (if (eqv? index idx) 585 | (k (store-set rvs tm index) (+ 1 index) n) 586 | (k rvs index n)))) 587 | ((pair? tm) (loop rvs index (car tm) 588 | (lambda (r i a) 589 | (loop r i (cdr tm) 590 | (lambda (r i d) (k r i `(,a . ,d))))))) 591 | (else (k rvs index tm)))))) 592 | (define (reify-initial st) (reify 0 st var-initial)) 593 | 594 | (define-syntax query 595 | (syntax-rules () 596 | ((_ (vr ...) g0 gs ...) 597 | (let ((goal (fresh (vr ...) (== (list vr ...) var-initial) g0 gs ...))) 598 | (pause state-empty goal))))) 599 | (define-syntax run 600 | (syntax-rules () 601 | ((_ n body ...) (map reify-initial (stream-take n (query body ...)))))) 602 | (define-syntax run* 603 | (syntax-rules () 604 | ((_ body ...) (run #f body ...)))) 605 | --------------------------------------------------------------------------------