├── .gitignore ├── LICENSE ├── README.md ├── cons ├── cons-tests.scm └── cons.scm ├── faster-miniKanren ├── ==-tests.scm ├── LICENSE ├── README.md ├── absento-closure-tests.scm ├── absento-tests.scm ├── chez.scm ├── disequality-tests.scm ├── full-interp.rkt ├── full-interp.scm ├── info.rkt ├── main.rkt ├── matche.rkt ├── matche.scm ├── mk-guile.scm ├── mk-vicare.scm ├── mk.rkt ├── mk.scm ├── numbero-tests.scm ├── numbers.rkt ├── numbers.scm ├── simple-interp.rkt ├── simple-interp.scm ├── stringo-tests.scm ├── symbolo-numbero-tests.scm ├── symbolo-tests.scm ├── test-all.rktl ├── test-all.scm ├── test-check.scm ├── test-guile.scm ├── test-infer.scm ├── test-numbers.scm ├── test-quines.scm └── test-simple-interp.scm ├── miniKanren-in-miniKanren ├── core-mk-combined │ ├── core-mk-complex.scm │ ├── core-mk-simple-and-complex-tests.scm │ └── core-mk-simple.scm ├── core-mk-explicit-unification-failure-streams │ ├── core-mk-explicit-unification-failure-streams-tests.scm │ ├── core-mk-explicit-unification-failure-streams.scm │ └── notes.txt ├── core-mk-explicit-unification-failure │ ├── core-mk-explicit-unification-failure-tests.scm │ └── core-mk-explicit-unification-failure.scm ├── core-mk-explicit-unification │ ├── core-mk-explicit-unification-tests.scm │ └── core-mk-explicit-unification.scm └── core-mk-implicit-unification │ ├── core-mk-implicit-unification-tests.scm │ └── core-mk-implicit-unification.scm └── primer.scm /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.ss~ 3 | *.ss#* 4 | .#*.ss 5 | *.scm~ 6 | *.scm#* 7 | .#*.scm 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 William E. Byrd 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 | # scheme-primer 2 | Interactive Scheme Primer, written in Scheme. 3 | 4 | *Work in progress* 5 | 6 | Inspired by the primer in 'The Diamond Age', spaced repetition, 'Remembering the Kanji', Rocksmith, Zarf's 'Lists and Lists', Spock's test at the beginning of 'Star Trek IV: The Voyage Home', 'The Little Schemer', Dan Friedman's C311 course, and my experience teaching Scheme over many years. 7 | 8 | To run the Scheme Primer, please load the file `primer.scm` in Chez Scheme (https://cisco.github.io/ChezScheme/): 9 | 10 | ``` 11 | Chez Scheme Version 9.5.3 12 | Copyright 1984-2019 Cisco Systems, Inc. 13 | 14 | > (load "primer.scm") 15 | Welcome to the Scheme Primer. 16 | ``` 17 | 18 | The Scheme Primer may also work in other implementations of Scheme. -------------------------------------------------------------------------------- /cons/cons-tests.scm: -------------------------------------------------------------------------------- 1 | (load "cons.scm") 2 | 3 | (run 10 (e v) 4 | (evalo/proper-or-improper-list e v)) 5 | 6 | (run* (e) 7 | (evalo/proper-or-improper-list e '())) 8 | 9 | (run* (e) 10 | (evalo/proper-or-improper-list e '(cat))) 11 | 12 | (run* (e) 13 | (evalo/proper-or-improper-list e '(dog rat))) 14 | 15 | (run* (e) 16 | (evalo/proper-or-improper-list e '(cat (dog) . rat))) 17 | 18 | (run* (e) 19 | (evalo/proper-or-improper-list e '(cat (((dog))) rat))) 20 | 21 | (run* (e) 22 | (evalo/proper-or-improper-list e '(((cat) (((dog)))) (rat)))) 23 | 24 | 25 | 26 | (run* (e v) 27 | (evalo/proper-or-improper-list-cons-count-symbols e animals 'z 'z v)) 28 | 29 | (run* (e v) 30 | (evalo/proper-or-improper-list-cons-count-symbols e animals '(s z) 'z v)) 31 | 32 | (run* (e v) 33 | (evalo/proper-or-improper-list-cons-count-symbols e animals '(s (s z)) 'z v)) 34 | 35 | 36 | (run 10 (e v) 37 | (evalo/proper-or-improper-list-symbols e animals v)) 38 | 39 | (run 10 (e v) 40 | (evalo/proper-list-symbols e animals v)) 41 | 42 | (run 10 (e v) 43 | (evalo/flat-proper-list-symbols e animals v)) 44 | 45 | (run 10 (e v) 46 | (evalo/flat-proper-list-distinct-symbols e animals v)) 47 | 48 | (run 10 (e v) 49 | (evalo/deep-proper-list-distinct-symbols e animals animals v)) 50 | 51 | (run 10 (e v) 52 | (evalo/deep-proper-non-empty-list-distinct-symbols e animals animals v)) 53 | 54 | (run 10 (e v) 55 | (fresh (animals^) 56 | (evalo/deep-proper-non-empty-list-deep-distinct-symbols e animals animals^ v))) 57 | 58 | 59 | (run* (e v) 60 | (fresh (animals^) 61 | (evalo/deep-proper-non-empty-list-deep-distinct-symbols-count e animals animals^ 'z 'z v))) 62 | 63 | (run* (e v) 64 | (fresh (animals^) 65 | (evalo/deep-proper-non-empty-list-deep-distinct-symbols-count e animals animals^ '(s z) 'z v))) 66 | 67 | (run* (e v) 68 | (fresh (animals^) 69 | (evalo/deep-proper-non-empty-list-deep-distinct-symbols-count e animals animals^ '(s (s z)) 'z v))) 70 | 71 | (run* (e v) 72 | (fresh (animals^) 73 | (evalo/deep-proper-non-empty-list-deep-distinct-symbols-count e animals animals^ '(s (s (s z))) 'z v))) 74 | 75 | 76 | 77 | 78 | (run 10 (e v) 79 | (fresh (animals^) 80 | (evalo/deep-proper-list-deep-distinct-symbols e animals animals^ v))) 81 | 82 | 83 | (run* (e v) 84 | (fresh (animals^) 85 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ 'z 'z v))) 86 | 87 | (run* (e v) 88 | (fresh (animals^) 89 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s z) 'z v))) 90 | 91 | (run* (e v) 92 | (fresh (animals^) 93 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s (s z)) 'z v))) 94 | 95 | (run* (e v) 96 | (fresh (animals^) 97 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s (s (s z))) 'z v))) 98 | 99 | (length 100 | (run* (e v) 101 | (fresh (animals^) 102 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s (s (s z))) 'z v)))) 103 | 104 | (map cadr 105 | (run* (e v) 106 | (fresh (animals^) 107 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s (s (s z))) 'z v)))) 108 | 109 | (length 110 | (run* (e v) 111 | (fresh (animals^) 112 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s (s (s (s z)))) 'z v)))) 113 | 114 | (map cadr 115 | (run* (e v) 116 | (fresh (animals^) 117 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s (s (s (s z)))) 'z v)))) 118 | 119 | (andmap (lambda (e/v) (let ((e (car e/v)) (v (cadr e/v))) (equal? (eval e) v))) 120 | (run* (e v) 121 | (fresh (animals^) 122 | (evalo/deep-proper-list-deep-distinct-symbols-count e animals animals^ '(s (s (s (s z)))) 'z v)))) 123 | 124 | (run* (e v) 125 | (fresh (letters^) 126 | (evalo/deep-proper-list-deep-distinct-symbols-count e letters letters^ '(s (s (s z))) 'z v))) 127 | 128 | (run* (e v) 129 | (fresh (dan-scheme^) 130 | (evalo/deep-proper-list-deep-distinct-symbols-count e dan-scheme dan-scheme^ '(s (s (s z))) 'z v))) 131 | 132 | (run* (e v) 133 | (fresh (symbols symbols^) 134 | (membero symbols (list animals letters dan-scheme)) 135 | (evalo/deep-proper-list-deep-distinct-symbols-count e symbols symbols^ '(s (s z)) 'z v))) 136 | 137 | (map cadr 138 | (run* (e v) 139 | (fresh (symbols symbols^) 140 | (membero symbols (list animals letters dan-scheme)) 141 | (evalo/deep-proper-list-deep-distinct-symbols-count e symbols symbols^ '(s (s z)) 'z v)))) 142 | 143 | (andmap 144 | (lambda (e/v) 145 | (let ((e (car e/v)) 146 | (v (cadr e/v))) 147 | (and (equal? (eval e) v) 148 | (equal? (run* (q) (evalo/proper-or-improper-list q v)) (list e))))) 149 | (run* (e v) 150 | (fresh (symbols symbols^) 151 | (membero symbols (list animals letters dan-scheme)) 152 | (evalo/deep-proper-list-deep-distinct-symbols-count e symbols symbols^ '(s (s z)) 'z v)))) 153 | 154 | 155 | (let ((e/v* (run* (e v) 156 | (fresh (symbols symbols^) 157 | (membero symbols (list animals letters dan-scheme)) 158 | (evalo/deep-proper-list-deep-distinct-symbols-count e symbols symbols^ '(s (s z)) 'z v))))) 159 | (let ((e/v*-length (length e/v*))) 160 | (let ((num-problems 5) 161 | (start-time (current-time 'time-monotonic))) 162 | (let loop ((i 1) 163 | (pass 0) 164 | (fail 0)) 165 | (cond 166 | ((= i num-problems) 167 | (let ((end-time (current-time 'time-monotonic))) 168 | (let ((duration/seconds (time-second (time-difference end-time start-time)))) 169 | (printf "\n-----------------------\n\n") 170 | (printf "finished!\n") 171 | (printf "elapsed time: ~s seconds\n" duration/seconds) 172 | (printf "passed: ~s of ~s" pass (+ pass fail)) 173 | (when (not (zero? (+ pass fail))) 174 | (printf " (~s%)" (exact->inexact (* (/ pass (+ pass fail)) 100)))) 175 | (newline)))) 176 | (else 177 | (let ((e/v (list-ref e/v* (random e/v*-length)))) 178 | (let ((e (car e/v)) 179 | (v (cadr e/v))) 180 | (printf "\n-----------------------\n\n") 181 | (printf "problem ~s of ~s\n\n" i num-problems) 182 | (printf "enter an expression containing only 'cons', 'quote', symbols, and the empty list ()\n") 183 | (printf "or enter 'exit'\n\n") 184 | (printf "~s\n\n" v) 185 | (let ((entered-e (read))) 186 | (cond 187 | ((or (equal? 'exit entered-e) (equal? '(quote exit) entered-e)) 188 | (loop num-problems 189 | pass 190 | fail)) 191 | (else 192 | (newline) 193 | (let-values (((pass fail) (if (equal? entered-e e) 194 | (begin 195 | (printf "correct!\n") 196 | (values (add1 pass) fail)) 197 | (begin 198 | (printf "incorrect!\n\n") 199 | (printf "correct answer: ~a\n" e) 200 | (values pass (add1 fail)))))) 201 | (newline) 202 | (printf "passed: ~s of ~s\n" pass (+ pass fail)) 203 | (loop (add1 i) 204 | pass 205 | fail))))))))))))) 206 | -------------------------------------------------------------------------------- /cons/cons.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | 4 | (define evalo/proper-or-improper-list 5 | (lambda (expr val) 6 | (conde 7 | ((== `(quote ,val) expr) 8 | (conde 9 | ((== '() val)) 10 | ((symbolo val)))) 11 | ((fresh (e1 e2 v1 v2) 12 | (== `(cons ,e1 ,e2) expr) 13 | (== `(,v1 . ,v2) val) 14 | (evalo/proper-or-improper-list e1 v1) 15 | (evalo/proper-or-improper-list e2 v2)))))) 16 | 17 | (define evalo/proper-or-improper-list-cons-count-symbols 18 | (lambda (expr symbols cons-count cons-count^ val) 19 | (conde 20 | ((== `(quote ,val) expr) 21 | (== cons-count cons-count^) 22 | (conde 23 | ((== '() val)) 24 | ((membero val symbols)))) 25 | ((fresh (e1 e2 v1 v2 cons-count-1 cons-count^^) 26 | (== `(cons ,e1 ,e2) expr) 27 | (== `(,v1 . ,v2) val) 28 | (== `(s ,cons-count-1) cons-count) 29 | (evalo/proper-or-improper-list-cons-count-symbols e1 symbols cons-count-1 cons-count^^ v1) 30 | (evalo/proper-or-improper-list-cons-count-symbols e2 symbols cons-count^^ cons-count^ v2)))))) 31 | 32 | (define evalo/proper-or-improper-list-symbols 33 | (lambda (expr symbols val) 34 | (conde 35 | ((== `(quote ,val) expr) 36 | (conde 37 | ((== '() val)) 38 | ((membero val symbols)))) 39 | ((fresh (e1 e2 v1 v2) 40 | (== `(cons ,e1 ,e2) expr) 41 | (== `(,v1 . ,v2) val) 42 | (evalo/proper-or-improper-list-symbols e1 symbols v1) 43 | (evalo/proper-or-improper-list-symbols e2 symbols v2)))))) 44 | 45 | (define evalo/proper-list-symbols 46 | (lambda (expr symbols val) 47 | (conde 48 | ((== `(quote ,val) expr) 49 | (== '() val)) 50 | ((fresh (e1 e2 v1 v2) 51 | (== `(cons ,e1 ,e2) expr) 52 | (== `(,v1 . ,v2) val) 53 | (evalo/proper-or-improper-list-symbols e1 symbols v1) 54 | (evalo/proper-list-symbols e2 symbols v2)))))) 55 | 56 | (define evalo/flat-proper-list-symbols 57 | (lambda (expr symbols val) 58 | (conde 59 | ((== `(quote ,val) expr) 60 | (== '() val)) 61 | ((fresh (e1 e2 v1 v2) 62 | (== `(cons ,e1 ,e2) expr) 63 | (== `(,v1 . ,v2) val) 64 | (== `(quote ,v1) e1) 65 | (membero v1 symbols) 66 | (evalo/flat-proper-list-symbols e2 symbols v2)))))) 67 | 68 | (define evalo/flat-proper-list-distinct-symbols 69 | (lambda (expr symbols val) 70 | (conde 71 | ((== `(quote ,val) expr) 72 | (== '() val)) 73 | ((fresh (e1 e2 v1 v2 symbols^) 74 | (== `(cons ,e1 ,e2) expr) 75 | (== `(,v1 . ,v2) val) 76 | (== `(quote ,v1) e1) 77 | (remove-exactly-oneo v1 symbols symbols^) 78 | (evalo/flat-proper-list-distinct-symbols e2 symbols^ v2)))))) 79 | 80 | (define evalo/deep-proper-list-distinct-symbols 81 | (lambda (expr all-symbols symbols-at-this-level val) 82 | (conde 83 | ((== `(quote ,val) expr) 84 | (== '() val)) 85 | ((fresh (e1 e2 v1 v2 symbols-at-this-level^) 86 | (== `(cons ,e1 ,e2) expr) 87 | (== `(,v1 . ,v2) val) 88 | (conde 89 | ((== `(quote ,v1) e1) 90 | (remove-exactly-oneo v1 symbols-at-this-level symbols-at-this-level^)) 91 | ((== symbols-at-this-level symbols-at-this-level^) 92 | (evalo/deep-proper-list-distinct-symbols e1 all-symbols all-symbols v1))) 93 | (evalo/deep-proper-list-distinct-symbols e2 all-symbols symbols-at-this-level^ v2)))))) 94 | 95 | (define evalo/deep-proper-non-empty-list-distinct-symbols 96 | (lambda (expr all-symbols symbols-at-this-level val) 97 | (conde 98 | ((fresh (v symbols-at-this-level^) 99 | (== `(cons (quote ,v) (quote ())) expr) 100 | (== `(,v . ()) val) 101 | (remove-exactly-oneo v symbols-at-this-level symbols-at-this-level^))) 102 | ((fresh (e1 e2 v1 v2 symbols-at-this-level^) 103 | (== `(cons ,e1 ,e2) expr) 104 | (== `(,v1 . ,v2) val) 105 | (conde 106 | ((== `(quote ,v1) e1) 107 | (remove-exactly-oneo v1 symbols-at-this-level symbols-at-this-level^)) 108 | ((== symbols-at-this-level symbols-at-this-level^) 109 | (evalo/deep-proper-non-empty-list-distinct-symbols e1 all-symbols all-symbols v1))) 110 | (evalo/deep-proper-non-empty-list-distinct-symbols e2 all-symbols symbols-at-this-level^ v2)))))) 111 | 112 | (define evalo/deep-proper-non-empty-list-deep-distinct-symbols 113 | (lambda (expr symbols symbols^ val) 114 | (conde 115 | ((fresh (v) 116 | (== `(cons (quote ,v) (quote ())) expr) 117 | (== `(,v . ()) val) 118 | (remove-exactly-oneo v symbols symbols^))) 119 | ((fresh (e1 e2 v1 v2 symbols^^) 120 | (== `(cons ,e1 ,e2) expr) 121 | (== `(,v1 . ,v2) val) 122 | (conde 123 | ((== `(quote ,v1) e1) 124 | (remove-exactly-oneo v1 symbols symbols^^)) 125 | ((evalo/deep-proper-non-empty-list-deep-distinct-symbols e1 symbols symbols^^ v1))) 126 | (evalo/deep-proper-non-empty-list-deep-distinct-symbols e2 symbols^^ symbols^ v2)))))) 127 | 128 | (define evalo/deep-proper-non-empty-list-deep-distinct-symbols-count 129 | (lambda (expr symbols symbols^ cons-count cons-count^ val) 130 | (conde 131 | ((fresh (v) 132 | (== `(cons (quote ,v) (quote ())) expr) 133 | (== `(s ,cons-count^) cons-count) 134 | (== `(,v . ()) val) 135 | (remove-exactly-oneo v symbols symbols^))) 136 | ((fresh (e1 e2 v1 v2 symbols^^ cons-count-1 cons-count^^) 137 | (== `(cons ,e1 ,e2) expr) 138 | (== `(,v1 . ,v2) val) 139 | (== `(s ,cons-count-1) cons-count) 140 | (conde 141 | ((== `(quote ,v1) e1) 142 | (== cons-count^^ cons-count-1) 143 | (remove-exactly-oneo v1 symbols symbols^^)) 144 | ((evalo/deep-proper-non-empty-list-deep-distinct-symbols-count e1 symbols symbols^^ cons-count-1 cons-count^^ v1))) 145 | (evalo/deep-proper-non-empty-list-deep-distinct-symbols-count e2 symbols^^ symbols^ cons-count^^ cons-count^ v2)))))) 146 | 147 | (define evalo/deep-proper-list-deep-distinct-symbols-count 148 | (lambda (expr symbols symbols^ cons-count cons-count^ val) 149 | (conde 150 | ((== `(quote ,val) expr) 151 | (== '() val) 152 | (== symbols symbols^) 153 | (== cons-count cons-count^)) 154 | ((fresh (e1 e2 v1 v2 symbols^^ cons-count-1 cons-count^^) 155 | (== `(cons ,e1 ,e2) expr) 156 | (== `(,v1 . ,v2) val) 157 | (== `(s ,cons-count-1) cons-count) 158 | (conde 159 | ((== `(quote ,v1) e1) 160 | (== cons-count^^ cons-count-1) 161 | (remove-exactly-oneo v1 symbols symbols^^)) 162 | ((evalo/deep-proper-list-deep-distinct-symbols-count e1 symbols symbols^^ cons-count-1 cons-count^^ v1))) 163 | (evalo/deep-proper-list-deep-distinct-symbols-count e2 symbols^^ symbols^ cons-count^^ cons-count^ v2)))))) 164 | 165 | (define evalo/deep-proper-list-deep-distinct-symbols 166 | (lambda (expr symbols symbols^ val) 167 | (conde 168 | ((== `(quote ,val) expr) 169 | (== '() val) 170 | (== symbols symbols^)) 171 | ((fresh (e1 e2 v1 v2 symbols^^) 172 | (== `(cons ,e1 ,e2) expr) 173 | (== `(,v1 . ,v2) val) 174 | (conde 175 | ((== `(quote ,v1) e1) 176 | (remove-exactly-oneo v1 symbols symbols^^)) 177 | ((evalo/deep-proper-list-deep-distinct-symbols e1 symbols symbols^^ v1))) 178 | (evalo/deep-proper-list-deep-distinct-symbols e2 symbols^^ symbols^ v2)))))) 179 | 180 | 181 | (define animals 182 | '(cat 183 | dog 184 | fox 185 | pig 186 | rat 187 | ant 188 | bat)) 189 | 190 | (define letters 191 | '(a 192 | b 193 | c 194 | d 195 | e 196 | f 197 | g)) 198 | 199 | (define dan-scheme 200 | '(quote 201 | null? 202 | equal? 203 | cons 204 | car 205 | cdr 206 | lambda 207 | cond)) 208 | 209 | (define membero 210 | (lambda (x ls) 211 | (fresh (y rest) 212 | (== `(,y . ,rest) ls) 213 | (conde 214 | ((== y x)) 215 | ((=/= y x) 216 | (membero x rest)))))) 217 | 218 | (define remove-exactly-oneo 219 | (lambda (x ls ls-x) 220 | (fresh (y rest) 221 | (== `(,y . ,rest) ls) 222 | (conde 223 | ((== y x) 224 | (== rest ls-x)) 225 | ((=/= y x) 226 | (remove-exactly-oneo x rest ls-x)))))) 227 | 228 | (define removeo 229 | (lambda (x ls ls-x) 230 | (conde 231 | ((== '() ls) (== '() ls-x)) 232 | ((fresh (y rest) 233 | (== `(,y . ,rest) ls) 234 | (conde 235 | ((== y x) 236 | (== rest ls-x)) 237 | ((=/= y x) 238 | (removeo x rest ls-x)))))))) 239 | -------------------------------------------------------------------------------- /faster-miniKanren/==-tests.scm: -------------------------------------------------------------------------------- 1 | (test "1" 2 | (run 1 (q) (== 5 q)) 3 | '(5)) 4 | 5 | (test "2" 6 | (run* (q) 7 | (conde 8 | [(== 5 q)] 9 | [(== 6 q)])) 10 | '(5 6)) 11 | 12 | (test "3" 13 | (run* (q) 14 | (fresh (a d) 15 | (conde 16 | [(== 5 a)] 17 | [(== 6 d)]) 18 | (== `(,a . ,d) q))) 19 | '((5 . _.0) (_.0 . 6))) 20 | 21 | (define appendo 22 | (lambda (l s out) 23 | (conde 24 | [(== '() l) (== s out)] 25 | [(fresh (a d res) 26 | (== `(,a . ,d) l) 27 | (== `(,a . ,res) out) 28 | (appendo d s res))]))) 29 | 30 | (test "4" 31 | (run* (q) (appendo '(a b c) '(d e) q)) 32 | '((a b c d e))) 33 | 34 | (test "5" 35 | (run* (q) (appendo q '(d e) '(a b c d e))) 36 | '((a b c))) 37 | 38 | (test "6" 39 | (run* (q) (appendo '(a b c) q '(a b c d e))) 40 | '((d e))) 41 | 42 | (test "7" 43 | (run 5 (q) 44 | (fresh (l s out) 45 | (appendo l s out) 46 | (== `(,l ,s ,out) q))) 47 | '((() _.0 _.0) 48 | ((_.0) _.1 (_.0 . _.1)) 49 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 50 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 51 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)))) 52 | -------------------------------------------------------------------------------- /faster-miniKanren/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 William E. Byrd 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 | 23 | -------------------------------------------------------------------------------- /faster-miniKanren/README.md: -------------------------------------------------------------------------------- 1 | # miniKanren-with-symbolic-constraints 2 | 3 | A revision of https://github.com/webyrd/miniKanren-with-symbolic-constraints/ for better performance. Up to 10x faster for large queries involving heavy use of constraints. 4 | 5 | Includes `==`, `=/=`, `symbolo`, `numbero`, and `absento`. 6 | 7 | *** Update (WEB, 21 August 02018): `absento` is now general--the first argument can be any legal miniKanren term, and needn't be ground. Previously, `faster-miniKanren` required the first argument to `absento` be an `eqv?`-comparable ground atom. Thanks to Michael Ballantyne for pointing out how to remove this restriction. 8 | 9 | Eigen was removed. 10 | 11 | ## Running 12 | 13 | ### Racket 14 | 15 | #### From the Package Server 16 | 17 | This is available on the [Racket package server](https://pkgn.racket-lang.org/package/faster-minikanren), so it can be installed with Racket's package manager: 18 | 19 | ``` 20 | raco pkg install faster-minikanren 21 | ``` 22 | 23 | After which you can import it in a Racket module with 24 | 25 | ``` 26 | (require minikanren) 27 | ``` 28 | 29 | #### From a checkout of this repository 30 | 31 | Alternatively the files from this repository can be used directly: 32 | 33 | ``` 34 | (require "mk.rkt") 35 | ``` 36 | 37 | to load tests: 38 | 39 | ``` 40 | racket test-all.rktl 41 | ``` 42 | 43 | ### Vicare and Chez Scheme 44 | 45 | ``` 46 | (load "mk-vicare.scm") 47 | (load "mk.scm") 48 | ``` 49 | 50 | To run tests: 51 | 52 | ``` 53 | (load "mk-vicare.scm") 54 | (load "mk.scm") 55 | (load "test-all.scm") 56 | ``` 57 | 58 | ### Guile 59 | 60 | After putting the directory in Guile's load path: 61 | 62 | ``` 63 | (use-modules (faster-miniKanren mk-guile)) 64 | ``` 65 | 66 | To run tests: 67 | 68 | ``` 69 | guile test-guile.scm 70 | ``` 71 | 72 | ## Other code 73 | 74 | `numbers.scm` includes the relational number system described in The Reasoned Schemer. 75 | 76 | `simple-interp.scm` includes a small relational interpreter capable of generating quines, as presented in "miniKanren, Live and Untagged" (http://webyrd.net/quines/quines.pdf) 77 | 78 | `full-interp.scm` includes a more advanced relation interpreter supporting function definition with `letrec` and a relational pattern matcher. 79 | 80 | `matche.scm` includes a pattern matching syntax that expands to unification. 81 | 82 | Each of these files is also wrapped in a corresponding `.rkt` file as a Racket module. 83 | 84 | 85 | ## What makes it fast? 86 | 87 | The https://github.com/webyrd/miniKanren-with-symbolic-constraints/ implementation doesn't make much effort to be fast. 88 | 89 | This version uses faster data representations and a different algorithm for checking constraints. It also drops some features I don't understand and don't know how to implement efficiently: eigen, and the more general version of absento. 90 | 91 | ### Substitution Representation 92 | 93 | We use a persistent map with log time access and update rather than an association list. On Racket we use the built-in immutable hash to take advantage of its C-level implementation in the runtime (mk.rkt). On other Scheme systems we use a trie implementation that organizes elements according to the binary digits of a fixnum identifying the variable (`mk-vicare.scm`). Note that the tree starts lookup at the low-order bits, so it should remain well-balanced as variables with sequential identifiers are added. The lookup is more expensive for more recently added variables (with higher-valued identities), however. 94 | 95 | Using a log-time persistent map seems to be better than an association list when the substitution is larger than about 100 elements in size. The improvement from linear time to log time is very important for large substitutions. Association lists are faster for small substitutions, but the effect here is only constant time. As such we prefer the log-time persistent map for more reliable performance across workloads. 96 | 97 | Plenty of other miniKanren use log-time persistent maps for their substitutions; core.logic (https://github.com/clojure/core.logic) and veneer (https://github.com/tca/veneer) certainly do. 98 | 99 | These particular data structure choices may not be optimal; we haven't recently evaluated a broad array of map types. There's a paper on it concluding that skew binary random access lists might be the best: https://users.soe.ucsc.edu/~lkuper/papers/walk.pdf 100 | 101 | ### set-var-val! 102 | 103 | Regardless of the choice of substitution representation, lookup is somewhat expensive. In certain circumstances we can avoid storing the value of a logic variable in the substitution at all and avoid that cost. 104 | 105 | Consider the implementation of `appendo`: 106 | 107 | ``` 108 | (define (appendo l s out) 109 | (conde 110 | [(== l '()) (== s out)] 111 | [(fresh (a d res) 112 | (== `(,a . ,d) l) 113 | (== `(,a . ,res) out) 114 | (appendo d s res))])) 115 | ``` 116 | 117 | Note that `a`, `d`, and `res` are used in unifications directly after they are allocated with `fresh`. Depending on the modality of the use of `appendo`, these variables may immediately receive values during those unifications. In that case, it is not possible for the variable to take on different values in different branches of the search tree; they receive their value before the search tree branches. 118 | 119 | Based on this observation, we store the values of variables that are assigned values immediately after they are allocated (before the computation branches from a `conde`) within a field of the variable object itself, rather than within the substitution. Variables are represented by a vector holding: 120 | 121 | 1. a value field, which initially contains an "unbound" value indicating that the variable is either unbound or bound in the substitution, but is mutated when a value is assigned in this optimized way. 122 | 2. a scope number, used to determine whether the search tree has branched since the variable was allocated. A scope counter is passed through the search and incremented whenever it branches; when a variable is allocated the current scope counter is stored in the variable. 123 | 3. a numeric id, used as a key for the binary trie substitution representation discussed above. 124 | 125 | I'm not aware of this optimization being used in other miniKanren implementations. Unification in prolog certainly avoids expensive lookups by direct mutation, but prolog implementations don't maintain substitutions for multiple branches of the search in the same way miniKanren does. 126 | 127 | ### Constraint Representation and Solving 128 | 129 | The key optimization is in the representation of disequality, absento, and type constraints. All constraint data is stored in a map associating variables with constraints that they participate in, and constraints are only processed when a variable's domain has been constrained in a way that may violate the constraint. This is related to the attributed variable feature found in prolog systems. 130 | 131 | In contrast, other miniKanren implementations often just keep a big list of constraints and recheck and simplify the whole list every time a unification happens, which gets very expensive when there are many constraints. I know that https://github.com/webyrd/miniKanren-with-symbolic-constraints/ and https://github.com/tca/veneer take this approach. I don't understand core.logic's implementation well enough to be sure what is done there, but I think it does the same but with a little extra logic to specify the dependencies between constraint types. The big list of constraints approach does allow for easier extensibility with user-defined constraints. 132 | 133 | In our implementation, each logic variable has constraint information associated with it with three parts: type, disequality, and absento constraint information. Every time a variable is instantiated, its constraint information is examined. Constraints attached to other variables that are not instantiated, however, do not need to be checked. 134 | 135 | #### Type constraints 136 | 137 | `symbolo` and `numbero` assert that a term will be of a particular atomic type. Because there are infinitely many values of each of these types, this constraint thankfully doesn't interact with disequality; there is no way that adding the fact that a term is a symbol or a number on top of existing disequality constraints (but not other type constraints or specific values) can cause failure. 138 | 139 | Thus these constraints just check that the term is not already a ground value with the wrong type and that the constraint store does not already record a conflicting type. If that passes and the term is still a variable, then the type is recorded in the type part of the variable's entry in the constraint store. See `type-constraint` in the implementation. 140 | 141 | #### Disequality 142 | 143 | A disequality constraint should fail if its arguments are instantiated such that there is no longer any way for them to be distinct. It can be discarded as satisfied if its arguments are instantiated such that they must definitely be distinct. 144 | 145 | Given the other constraints available in this implementation, the only way for a disequality to fail is if the arguments are instantiated to be fully ground and equal, again because it is not possible to constrict the range of a logic variable to a finite range of values without fully instantiating it. 146 | 147 | Disequality constraints can be normalized as a disjunction of component atomic parts. Each atomic constraint states a disequality between one fresh logic variable and a term (which may be another fresh logic variable, or may be another type of term). The overall constraint succeeds as long as at least one of its component disequalities is true, and fails if every one of its component disequalities is false. 148 | 149 | Consider this disequality: 150 | 151 | ``` 152 | (fresh (a b c d) 153 | (=/= `(,a . ,b) `(,c . ,d))) 154 | ``` 155 | 156 | The component disequalities are: 157 | 158 | ``` 159 | (=/= a c) 160 | ``` 161 | 162 | and 163 | 164 | ``` 165 | (=/= b d) 166 | ``` 167 | 168 | If we find out that `a` is `5 and `c is `8`, then that component disequality is true and the overall disequality is true, regardless of the values of `b` and `d`. 169 | 170 | If instead we found out that `a` is `5` and `c` is also `5`, then the value of the overall constraint is still unknown. As long as `b` and `d` are still uninstantiated, the constraint should not fail. 171 | 172 | A consequence of these properties is that we only need to attach information about the constraint to the logic variables involved in one of the component disequalities. No matter what happens with the other components, if the logic variables in the selected component disequality remain uninstantiated the constraint does not need to fail. Limiting the variables that we attach the disequality to reduces the cost associated with re-checking the constraints as unifications happen. 173 | 174 | If the component disequality involves a variable and a non-variable term we only need to attach information to the variable, as it can only become equal to the non-variable term by becoming instantiated. If the component disequality involves a variable and another variable, we must attach information to *both* variables, as a unification of the two could instantiate either variable to point to the other. 175 | 176 | The component disequalities can be found by attempting unification of the arguments to the disequality and recording the associations that would be added to the substitution. 177 | 178 | #### Absento 179 | 180 | Information about absento constraints is attached to each uninstantiated variable in a term. Here the overall constraint is a *conjunction* of individual components; if the atom specified in the constraint is found in any part of the term, the constraint must fail. When a variable with absento information is instantiated, it may: 181 | 182 | * eliminite the component if the new value is an atom that is different than the atom specified by the constraint 183 | * cause failure if the new value is the same atom as that specified by the constraint 184 | * propagate the constraint to component parts if the new value is a pair 185 | 186 | Again, the constraint is only examined when a variable that it concerns is instantiated. 187 | -------------------------------------------------------------------------------- /faster-miniKanren/absento-closure-tests.scm: -------------------------------------------------------------------------------- 1 | (test "absento 'closure-1a" 2 | (run* (q) (absento 'closure q) (== q 'closure)) 3 | '()) 4 | 5 | (test "absento 'closure-1b" 6 | (run* (q) (== q 'closure) (absento 'closure q)) 7 | '()) 8 | 9 | (test "absento 'closure-2a" 10 | (run* (q) (fresh (a d) (== q 'closure) (absento 'closure q))) 11 | '()) 12 | 13 | (test "absento 'closure-2b" 14 | (run* (q) (fresh (a d) (absento 'closure q) (== q 'closure))) 15 | '()) 16 | 17 | (test "absento 'closure-3a" 18 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q))) 19 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 20 | 21 | (test "absento 'closure-3b" 22 | (run* (q) (fresh (a d) (== `(,a . ,d) q) (absento 'closure q))) 23 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 24 | 25 | (test "absento 'closure-4a" 26 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure a))) 27 | '()) 28 | 29 | (test "absento 'closure-4b" 30 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure a) (== `(,a . ,d) q))) 31 | '()) 32 | 33 | (test "absento 'closure-4c" 34 | (run* (q) (fresh (a d) (== 'closure a) (absento 'closure q) (== `(,a . ,d) q))) 35 | '()) 36 | 37 | (test "absento 'closure-4d" 38 | (run* (q) (fresh (a d) (== 'closure a) (== `(,a . ,d) q) (absento 'closure q))) 39 | '()) 40 | 41 | (test "absento 'closure-5a" 42 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure d))) 43 | '()) 44 | 45 | (test "absento 'closure-5b" 46 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure d) (== `(,a . ,d) q))) 47 | '()) 48 | 49 | (test "absento 'closure-5c" 50 | (run* (q) (fresh (a d) (== 'closure d) (absento 'closure q) (== `(,a . ,d) q))) 51 | '()) 52 | 53 | (test "absento 'closure-5d" 54 | (run* (q) (fresh (a d) (== 'closure d) (== `(,a . ,d) q) (absento 'closure q))) 55 | '()) 56 | 57 | (test "absento 'closure-6" 58 | (run* (q) 59 | (== `(3 (closure x (x x) ((y . 7))) #t) q) 60 | (absento 'closure q)) 61 | '()) 62 | -------------------------------------------------------------------------------- /faster-miniKanren/chez.scm: -------------------------------------------------------------------------------- 1 | (eval-when (compile) (optimize-level 3)) 2 | 3 | (module mk (run run* == =/= fresh conde symbolo numbero absento test) 4 | (import (except scheme subst)) 5 | (implicit-exports #t) 6 | (include "./mk-vicare.scm") 7 | (include "./mk.scm") 8 | (include "./test-check.scm")) 9 | 10 | -------------------------------------------------------------------------------- /faster-miniKanren/disequality-tests.scm: -------------------------------------------------------------------------------- 1 | (test "=/=-0" 2 | (run* (q) (=/= 5 q)) 3 | '((_.0 (=/= ((_.0 5)))))) 4 | 5 | (test "=/=-1" 6 | (run* (q) 7 | (=/= 3 q) 8 | (== q 3)) 9 | '()) 10 | 11 | (test "=/=-2" 12 | (run* (q) 13 | (== q 3) 14 | (=/= 3 q)) 15 | '()) 16 | 17 | (test "=/=-3" 18 | (run* (q) 19 | (fresh (x y) 20 | (=/= x y) 21 | (== x y))) 22 | '()) 23 | 24 | (test "=/=-4" 25 | (run* (q) 26 | (fresh (x y) 27 | (== x y) 28 | (=/= x y))) 29 | '()) 30 | 31 | (test "=/=-5" 32 | (run* (q) 33 | (fresh (x y) 34 | (=/= x y) 35 | (== 3 x) 36 | (== 3 y))) 37 | '()) 38 | 39 | (test "=/=-6" 40 | (run* (q) 41 | (fresh (x y) 42 | (== 3 x) 43 | (=/= x y) 44 | (== 3 y))) 45 | '()) 46 | 47 | (test "=/=-7" 48 | (run* (q) 49 | (fresh (x y) 50 | (== 3 x) 51 | (== 3 y) 52 | (=/= x y))) 53 | '()) 54 | 55 | (test "=/=-8" 56 | (run* (q) 57 | (fresh (x y) 58 | (== 3 x) 59 | (== 3 y) 60 | (=/= y x))) 61 | '()) 62 | 63 | (test "=/=-9" 64 | (run* (q) 65 | (fresh (x y z) 66 | (== x y) 67 | (== y z) 68 | (=/= x 4) 69 | (== z (+ 2 2)))) 70 | '()) 71 | 72 | (test "=/=-10" 73 | (run* (q) 74 | (fresh (x y z) 75 | (== x y) 76 | (== y z) 77 | (== z (+ 2 2)) 78 | (=/= x 4))) 79 | '()) 80 | 81 | (test "=/=-11" 82 | (run* (q) 83 | (fresh (x y z) 84 | (=/= x 4) 85 | (== y z) 86 | (== x y) 87 | (== z (+ 2 2)))) 88 | '()) 89 | 90 | (test "=/=-12" 91 | (run* (q) 92 | (fresh (x y z) 93 | (=/= x y) 94 | (== x `(0 ,z 1)) 95 | (== y `(0 1 1)))) 96 | '(_.0)) 97 | 98 | (test "=/=-13" 99 | (run* (q) 100 | (fresh (x y z) 101 | (=/= x y) 102 | (== x `(0 ,z 1)) 103 | (== y `(0 1 1)) 104 | (== z 1) 105 | (== `(,x ,y) q))) 106 | '()) 107 | 108 | (test "=/=-14" 109 | (run* (q) 110 | (fresh (x y z) 111 | (=/= x y) 112 | (== x `(0 ,z 1)) 113 | (== y `(0 1 1)) 114 | (== z 0))) 115 | '(_.0)) 116 | 117 | (test "=/=-15" 118 | (run* (q) 119 | (fresh (x y z) 120 | (== z 0) 121 | (=/= x y) 122 | (== x `(0 ,z 1)) 123 | (== y `(0 1 1)))) 124 | '(_.0)) 125 | 126 | (test "=/=-16" 127 | (run* (q) 128 | (fresh (x y z) 129 | (== x `(0 ,z 1)) 130 | (== y `(0 1 1)) 131 | (=/= x y))) 132 | '(_.0)) 133 | 134 | (test "=/=-17" 135 | (run* (q) 136 | (fresh (x y z) 137 | (== z 1) 138 | (=/= x y) 139 | (== x `(0 ,z 1)) 140 | (== y `(0 1 1)))) 141 | '()) 142 | 143 | (test "=/=-18" 144 | (run* (q) 145 | (fresh (x y z) 146 | (== z 1) 147 | (== x `(0 ,z 1)) 148 | (== y `(0 1 1)) 149 | (=/= x y))) 150 | '()) 151 | 152 | (test "=/=-19" 153 | (run* (q) 154 | (fresh (x y) 155 | (=/= `(,x 1) `(2 ,y)) 156 | (== x 2))) 157 | '(_.0)) 158 | 159 | (test "=/=-20" 160 | (run* (q) 161 | (fresh (x y) 162 | (=/= `(,x 1) `(2 ,y)) 163 | (== y 1))) 164 | '(_.0)) 165 | 166 | (test "=/=-21" 167 | (run* (q) 168 | (fresh (x y) 169 | (=/= `(,x 1) `(2 ,y)) 170 | (== x 2) 171 | (== y 1))) 172 | '()) 173 | 174 | (test "=/=-22" 175 | (run* (q) 176 | (fresh (x y) 177 | (=/= `(,x 1) `(2 ,y)) 178 | (== `(,x ,y) q))) 179 | '(((_.0 _.1) (=/= ((_.0 2) (_.1 1)))))) 180 | 181 | (test "=/=-23" 182 | (run* (q) 183 | (fresh (x y) 184 | (=/= `(,x 1) `(2 ,y)) 185 | (== x 2) 186 | (== `(,x ,y) q))) 187 | '(((2 _.0) (=/= ((_.0 1)))))) 188 | 189 | (test "=/=-24" 190 | (run* (q) 191 | (fresh (x y) 192 | (=/= `(,x 1) `(2 ,y)) 193 | (== x 2) 194 | (== y 9) 195 | (== `(,x ,y) q))) 196 | '((2 9))) 197 | 198 | (test "=/=-24b" 199 | (run* (q) 200 | (fresh (a d) 201 | (== `(,a . ,d) q) 202 | (=/= q `(5 . 6)) 203 | (== a 5) 204 | (== d 6))) 205 | '()) 206 | 207 | (test "=/=-25" 208 | (run* (q) 209 | (fresh (x y) 210 | (=/= `(,x 1) `(2 ,y)) 211 | (== x 2) 212 | (== y 1) 213 | (== `(,x ,y) q))) 214 | '()) 215 | 216 | (test "=/=-26" 217 | (run* (q) 218 | (fresh (a x z) 219 | (=/= a `(,x 1)) 220 | (== a `(,z 1)) 221 | (== x z))) 222 | '()) 223 | 224 | (test "=/=-27" 225 | (run* (q) 226 | (fresh (a x z) 227 | (=/= a `(,x 1)) 228 | (== a `(,z 1)) 229 | (== x 5) 230 | (== `(,x ,z) q))) 231 | '(((5 _.0) (=/= ((_.0 5)))))) 232 | 233 | (test "=/=-28" 234 | (run* (q) 235 | (=/= 3 4)) 236 | '(_.0)) 237 | 238 | (test "=/=-29" 239 | (run* (q) 240 | (=/= 3 3)) 241 | '()) 242 | 243 | (test "=/=-30" 244 | (run* (q) (=/= 5 q) 245 | (=/= 6 q) 246 | (== q 5)) 247 | '()) 248 | 249 | (test "=/=-31" 250 | (run* (q) 251 | (fresh (a d) 252 | (== `(,a . ,d) q) 253 | (=/= q `(5 . 6)) 254 | (== a 5))) 255 | '(((5 . _.0) (=/= ((_.0 6)))))) 256 | 257 | (test "=/=-32" 258 | (run* (q) 259 | (fresh (a) 260 | (== 3 a) 261 | (=/= a 4))) 262 | '(_.0)) 263 | 264 | (test "=/=-33" 265 | (run* (q) 266 | (=/= 4 q) 267 | (=/= 3 q)) 268 | '((_.0 (=/= ((_.0 3)) ((_.0 4)))))) 269 | 270 | (test "=/=-34" 271 | (run* (q) (=/= q 5) (=/= q 5)) 272 | '((_.0 (=/= ((_.0 5)))))) 273 | 274 | (test "=/=-35" 275 | (let ((foo (lambda (x) 276 | (fresh (a) 277 | (=/= x a))))) 278 | (run* (q) (fresh (a) (foo a)))) 279 | '(_.0)) 280 | 281 | (test "=/=-36" 282 | (let ((foo (lambda (x) 283 | (fresh (a) 284 | (=/= x a))))) 285 | (run* (q) (fresh (b) (foo b)))) 286 | '(_.0)) 287 | 288 | (test "=/=-37" 289 | (run* (q) 290 | (fresh (x y) 291 | (== `(,x ,y) q) 292 | (=/= x y))) 293 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 294 | 295 | (test "=/=-37b" 296 | (run* (q) 297 | (fresh (a d) 298 | (== `(,a . ,d) q) 299 | (=/= q `(5 . 6)))) 300 | '(((_.0 . _.1) (=/= ((_.0 5) (_.1 6)))))) 301 | 302 | (test "=/=-37c" 303 | (run* (q) 304 | (fresh (a d) 305 | (== `(,a . ,d) q) 306 | (=/= q `(5 . 6)) 307 | (== a 3))) 308 | '((3 . _.0))) 309 | 310 | (test "=/=-38" 311 | (run* (q) 312 | (fresh (x y) 313 | (== `(,x ,y) q) 314 | (=/= y x))) 315 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 316 | 317 | (test "=/=-39" 318 | (run* (q) 319 | (fresh (x y) 320 | (== `(,x ,y) q) 321 | (=/= x y) 322 | (=/= y x))) 323 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 324 | 325 | (test "=/=-40" 326 | (run* (q) 327 | (fresh (x y) 328 | (== `(,x ,y) q) 329 | (=/= x y) 330 | (=/= x y))) 331 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 332 | 333 | (test "=/=-41" 334 | (run* (q) (=/= q 5) (=/= 5 q)) 335 | '((_.0 (=/= ((_.0 5)))))) 336 | 337 | (test "=/=-42" 338 | (run* (q) 339 | (fresh (x y) 340 | (== `(,x ,y) q) 341 | (=/= `(,x ,y) `(5 6)) 342 | (=/= x 5))) 343 | '(((_.0 _.1) (=/= ((_.0 5)))))) 344 | 345 | (test "=/=-43" 346 | (run* (q) 347 | (fresh (x y) 348 | (== `(,x ,y) q) 349 | (=/= x 5) 350 | (=/= `(,x ,y) `(5 6)))) 351 | '(((_.0 _.1) (=/= ((_.0 5)))))) 352 | 353 | (test "=/=-44" 354 | (run* (q) 355 | (fresh (x y) 356 | (=/= x 5) 357 | (=/= `(,x ,y) `(5 6)) 358 | (== `(,x ,y) q))) 359 | '(((_.0 _.1) (=/= ((_.0 5)))))) 360 | 361 | (test "=/=-45" 362 | (run* (q) 363 | (fresh (x y) 364 | (=/= 5 x) 365 | (=/= `(,x ,y) `(5 6)) 366 | (== `(,x ,y) q))) 367 | '(((_.0 _.1) (=/= ((_.0 5)))))) 368 | 369 | (test "=/=-46" 370 | (run* (q) 371 | (fresh (x y) 372 | (=/= 5 x) 373 | (=/= `( ,y ,x) `(6 5)) 374 | (== `(,x ,y) q))) 375 | '(((_.0 _.1) (=/= ((_.0 5)))))) 376 | 377 | (test "=/=-47" 378 | (run* (x) 379 | (fresh (y z) 380 | (=/= x `(,y 2)) 381 | (== x `(,z 2)))) 382 | '((_.0 2))) 383 | 384 | (test "=/=-48" 385 | (run* (x) 386 | (fresh (y z) 387 | (=/= x `(,y 2)) 388 | (== x `((,z) 2)))) 389 | '(((_.0) 2))) 390 | 391 | (test "=/=-49" 392 | (run* (x) 393 | (fresh (y z) 394 | (=/= x `((,y) 2)) 395 | (== x `(,z 2)))) 396 | '((_.0 2))) 397 | 398 | (define distincto 399 | (lambda (l) 400 | (conde 401 | ((== l '())) 402 | ((fresh (a) (== l `(,a)))) 403 | ((fresh (a ad dd) 404 | (== l `(,a ,ad . ,dd)) 405 | (=/= a ad) 406 | (distincto `(,a . ,dd)) 407 | (distincto `(,ad . ,dd))))))) 408 | 409 | (test "=/=-50" 410 | (run* (q) 411 | (distincto `(2 3 ,q))) 412 | '((_.0 (=/= ((_.0 2)) ((_.0 3)))))) 413 | 414 | (define rembero 415 | (lambda (x ls out) 416 | (conde 417 | ((== '() ls) (== '() out)) 418 | ((fresh (a d res) 419 | (== `(,a . ,d) ls) 420 | (rembero x d res) 421 | (conde 422 | ((== a x) (== out res)) 423 | ((== `(,a . ,res) out)))))))) 424 | 425 | (test "=/=-51" 426 | (run* (q) (rembero 'a '(a b a c) q)) 427 | '((b c) (b a c) (a b c) (a b a c))) 428 | 429 | (test "=/=-52" 430 | (run* (q) (rembero 'a '(a b c) '(a b c))) 431 | '(_.0)) 432 | 433 | (define rembero 434 | (lambda (x ls out) 435 | (conde 436 | ((== '() ls) (== '() out)) 437 | ((fresh (a d res) 438 | (== `(,a . ,d) ls) 439 | (rembero x d res) 440 | (conde 441 | ((== a x) (== out res)) 442 | ((=/= a x) (== `(,a . ,res) out)))))))) 443 | 444 | (test "=/=-53" 445 | (run* (q) (rembero 'a '(a b a c) q)) 446 | '((b c))) 447 | 448 | (test "=/=-54" 449 | (run* (q) (rembero 'a '(a b c) '(a b c))) 450 | '()) 451 | 452 | (test "=/=-55" 453 | (run 1 (q) (=/= q #f)) 454 | '((_.0 (=/= ((_.0 #f)))))) 455 | 456 | (test "non watch-var pair implies satisfied" 457 | (run 1 (a b c d) 458 | (=/= (cons a c) 459 | (cons b d)) 460 | (== c '(1 . 2)) 461 | (== d '(1 . 3))) 462 | '((_.0 _.1 (1 . 2) (1 . 3)))) 463 | -------------------------------------------------------------------------------- /faster-miniKanren/full-interp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "main.rkt") 4 | 5 | (provide evalo) 6 | 7 | (include "full-interp.scm") 8 | -------------------------------------------------------------------------------- /faster-miniKanren/full-interp.scm: -------------------------------------------------------------------------------- 1 | ;; The definition of 'letrec' is based based on Dan Friedman's code, 2 | ;; using the "half-closure" approach from Reynold's definitional 3 | ;; interpreters. 4 | 5 | (define (evalo expr val) 6 | (eval-expo expr initial-env val)) 7 | 8 | (define (eval-expo expr env val) 9 | (conde 10 | ((== `(quote ,val) expr) 11 | (absento 'closure val) 12 | (absento 'prim val) 13 | (not-in-envo 'quote env)) 14 | 15 | ((numbero expr) (== expr val)) 16 | 17 | ((symbolo expr) (lookupo expr env val)) 18 | 19 | ((fresh (x body) 20 | (== `(lambda ,x ,body) expr) 21 | (== `(closure (lambda ,x ,body) ,env) val) 22 | (conde 23 | ;; Variadic 24 | ((symbolo x)) 25 | ;; Multi-argument 26 | ((list-of-symbolso x))) 27 | (not-in-envo 'lambda env))) 28 | 29 | ((fresh (rator x rands body env^ a* res) 30 | (== `(,rator . ,rands) expr) 31 | ;; variadic 32 | (symbolo x) 33 | (== `((,x . (val . ,a*)) . ,env^) res) 34 | (eval-expo rator env `(closure (lambda ,x ,body) ,env^)) 35 | (eval-expo body res val) 36 | (eval-listo rands env a*))) 37 | 38 | ((fresh (rator x* rands body env^ a* res) 39 | (== `(,rator . ,rands) expr) 40 | ;; Multi-argument 41 | (eval-expo rator env `(closure (lambda ,x* ,body) ,env^)) 42 | (eval-listo rands env a*) 43 | (ext-env*o x* a* env^ res) 44 | (eval-expo body res val))) 45 | 46 | ((fresh (rator x* rands a* prim-id) 47 | (== `(,rator . ,rands) expr) 48 | (eval-expo rator env `(prim . ,prim-id)) 49 | (eval-primo prim-id a* val) 50 | (eval-listo rands env a*))) 51 | 52 | ((handle-matcho expr env val)) 53 | 54 | ((fresh (p-name x body letrec-body) 55 | ;; single-function variadic letrec version 56 | (== `(letrec ((,p-name (lambda ,x ,body))) 57 | ,letrec-body) 58 | expr) 59 | (conde 60 | ; Variadic 61 | ((symbolo x)) 62 | ; Multiple argument 63 | ((list-of-symbolso x))) 64 | (not-in-envo 'letrec env) 65 | (eval-expo letrec-body 66 | `((,p-name . (rec . (lambda ,x ,body))) . ,env) 67 | val))) 68 | 69 | ((prim-expo expr env val)) 70 | 71 | )) 72 | 73 | (define empty-env '()) 74 | 75 | (define (lookupo x env t) 76 | (fresh (y b rest) 77 | (== `((,y . ,b) . ,rest) env) 78 | (conde 79 | ((== x y) 80 | (conde 81 | ((== `(val . ,t) b)) 82 | ((fresh (lam-expr) 83 | (== `(rec . ,lam-expr) b) 84 | (== `(closure ,lam-expr ,env) t))))) 85 | ((=/= x y) 86 | (lookupo x rest t))))) 87 | 88 | (define (not-in-envo x env) 89 | (conde 90 | ((== empty-env env)) 91 | ((fresh (y b rest) 92 | (== `((,y . ,b) . ,rest) env) 93 | (=/= y x) 94 | (not-in-envo x rest))))) 95 | 96 | (define (eval-listo expr env val) 97 | (conde 98 | ((== '() expr) 99 | (== '() val)) 100 | ((fresh (a d v-a v-d) 101 | (== `(,a . ,d) expr) 102 | (== `(,v-a . ,v-d) val) 103 | (eval-expo a env v-a) 104 | (eval-listo d env v-d))))) 105 | 106 | ;; need to make sure lambdas are well formed. 107 | ;; grammar constraints would be useful here!!! 108 | (define (list-of-symbolso los) 109 | (conde 110 | ((== '() los)) 111 | ((fresh (a d) 112 | (== `(,a . ,d) los) 113 | (symbolo a) 114 | (list-of-symbolso d))))) 115 | 116 | (define (ext-env*o x* a* env out) 117 | (conde 118 | ((== '() x*) (== '() a*) (== env out)) 119 | ((fresh (x a dx* da* env2) 120 | (== `(,x . ,dx*) x*) 121 | (== `(,a . ,da*) a*) 122 | (== `((,x . (val . ,a)) . ,env) env2) 123 | (symbolo x) 124 | (ext-env*o dx* da* env2 out))))) 125 | 126 | (define (eval-primo prim-id a* val) 127 | (conde 128 | [(== prim-id 'cons) 129 | (fresh (a d) 130 | (== `(,a ,d) a*) 131 | (== `(,a . ,d) val))] 132 | [(== prim-id 'car) 133 | (fresh (d) 134 | (== `((,val . ,d)) a*) 135 | (=/= 'closure val))] 136 | [(== prim-id 'cdr) 137 | (fresh (a) 138 | (== `((,a . ,val)) a*) 139 | (=/= 'closure a))] 140 | [(== prim-id 'not) 141 | (fresh (b) 142 | (== `(,b) a*) 143 | (conde 144 | ((=/= #f b) (== #f val)) 145 | ((== #f b) (== #t val))))] 146 | [(== prim-id 'equal?) 147 | (fresh (v1 v2) 148 | (== `(,v1 ,v2) a*) 149 | (conde 150 | ((== v1 v2) (== #t val)) 151 | ((=/= v1 v2) (== #f val))))] 152 | ;; FIXME (webyrd) -- symbol?, and perhaps other type predicates, doesn't handle booleans (fails) 153 | [(== prim-id 'symbol?) 154 | (fresh (v) 155 | (== `(,v) a*) 156 | (conde 157 | ((symbolo v) (== #t val)) 158 | ((numbero v) (== #f val)) 159 | ((fresh (a d) 160 | (== `(,a . ,d) v) 161 | (== #f val)))))] 162 | [(== prim-id 'null?) 163 | (fresh (v) 164 | (== `(,v) a*) 165 | (conde 166 | ((== '() v) (== #t val)) 167 | ((=/= '() v) (== #f val))))])) 168 | 169 | (define (prim-expo expr env val) 170 | (conde 171 | ((boolean-primo expr env val)) 172 | ((and-primo expr env val)) 173 | ((or-primo expr env val)) 174 | ((if-primo expr env val)))) 175 | 176 | (define (boolean-primo expr env val) 177 | (conde 178 | ((== #t expr) (== #t val)) 179 | ((== #f expr) (== #f val)))) 180 | 181 | (define (and-primo expr env val) 182 | (fresh (e*) 183 | (== `(and . ,e*) expr) 184 | (not-in-envo 'and env) 185 | (ando e* env val))) 186 | 187 | (define (ando e* env val) 188 | (conde 189 | ((== '() e*) (== #t val)) 190 | ((fresh (e) 191 | (== `(,e) e*) 192 | (eval-expo e env val))) 193 | ((fresh (e1 e2 e-rest v) 194 | (== `(,e1 ,e2 . ,e-rest) e*) 195 | (conde 196 | ((== #f v) 197 | (== #f val) 198 | (eval-expo e1 env v)) 199 | ((=/= #f v) 200 | (eval-expo e1 env v) 201 | (ando `(,e2 . ,e-rest) env val))))))) 202 | 203 | (define (or-primo expr env val) 204 | (fresh (e*) 205 | (== `(or . ,e*) expr) 206 | (not-in-envo 'or env) 207 | (oro e* env val))) 208 | 209 | (define (oro e* env val) 210 | (conde 211 | ((== '() e*) (== #f val)) 212 | ((fresh (e) 213 | (== `(,e) e*) 214 | (eval-expo e env val))) 215 | ((fresh (e1 e2 e-rest v) 216 | (== `(,e1 ,e2 . ,e-rest) e*) 217 | (conde 218 | ((=/= #f v) 219 | (== v val) 220 | (eval-expo e1 env v)) 221 | ((== #f v) 222 | (eval-expo e1 env v) 223 | (oro `(,e2 . ,e-rest) env val))))))) 224 | 225 | (define (if-primo expr env val) 226 | (fresh (e1 e2 e3 t) 227 | (== `(if ,e1 ,e2 ,e3) expr) 228 | (not-in-envo 'if env) 229 | (eval-expo e1 env t) 230 | (conde 231 | ((=/= #f t) (eval-expo e2 env val)) 232 | ((== #f t) (eval-expo e3 env val))))) 233 | 234 | (define initial-env `((list . (val . (closure (lambda x x) ,empty-env))) 235 | (not . (val . (prim . not))) 236 | (equal? . (val . (prim . equal?))) 237 | (symbol? . (val . (prim . symbol?))) 238 | (cons . (val . (prim . cons))) 239 | (null? . (val . (prim . null?))) 240 | (car . (val . (prim . car))) 241 | (cdr . (val . (prim . cdr))) 242 | . ,empty-env)) 243 | 244 | (define handle-matcho 245 | (lambda (expr env val) 246 | (fresh (against-expr mval clause clauses) 247 | (== `(match ,against-expr ,clause . ,clauses) expr) 248 | (not-in-envo 'match env) 249 | (eval-expo against-expr env mval) 250 | (match-clauses mval `(,clause . ,clauses) env val)))) 251 | 252 | (define (not-symbolo t) 253 | (conde 254 | ((== #f t)) 255 | ((== #t t)) 256 | ((== '() t)) 257 | ((numbero t)) 258 | ((fresh (a d) 259 | (== `(,a . ,d) t))))) 260 | 261 | (define (not-numbero t) 262 | (conde 263 | ((== #f t)) 264 | ((== #t t)) 265 | ((== '() t)) 266 | ((symbolo t)) 267 | ((fresh (a d) 268 | (== `(,a . ,d) t))))) 269 | 270 | (define (self-eval-literalo t) 271 | (conde 272 | ((numbero t)) 273 | ((booleano t)))) 274 | 275 | (define (literalo t) 276 | (conde 277 | ((numbero t)) 278 | ((symbolo t) (=/= 'closure t)) 279 | ((booleano t)) 280 | ((== '() t)))) 281 | 282 | (define (booleano t) 283 | (conde 284 | ((== #f t)) 285 | ((== #t t)))) 286 | 287 | (define (regular-env-appendo env1 env2 env-out) 288 | (conde 289 | ((== empty-env env1) (== env2 env-out)) 290 | ((fresh (y v rest res) 291 | (== `((,y . (val . ,v)) . ,rest) env1) 292 | (== `((,y . (val . ,v)) . ,res) env-out) 293 | (regular-env-appendo rest env2 res))))) 294 | 295 | (define (match-clauses mval clauses env val) 296 | (fresh (p result-expr d penv) 297 | (== `((,p ,result-expr) . ,d) clauses) 298 | (conde 299 | ((fresh (env^) 300 | (p-match p mval '() penv) 301 | (regular-env-appendo penv env env^) 302 | (eval-expo result-expr env^ val))) 303 | ((p-no-match p mval '() penv) 304 | (match-clauses mval d env val))))) 305 | 306 | (define (var-p-match var mval penv penv-out) 307 | (fresh (val) 308 | (symbolo var) 309 | (=/= 'closure mval) 310 | (conde 311 | ((== mval val) 312 | (== penv penv-out) 313 | (lookupo var penv val)) 314 | ((== `((,var . (val . ,mval)) . ,penv) penv-out) 315 | (not-in-envo var penv))))) 316 | 317 | (define (var-p-no-match var mval penv penv-out) 318 | (fresh (val) 319 | (symbolo var) 320 | (=/= mval val) 321 | (== penv penv-out) 322 | (lookupo var penv val))) 323 | 324 | (define (p-match p mval penv penv-out) 325 | (conde 326 | ((self-eval-literalo p) 327 | (== p mval) 328 | (== penv penv-out)) 329 | ((var-p-match p mval penv penv-out)) 330 | ((fresh (var pred val) 331 | (== `(? ,pred ,var) p) 332 | (conde 333 | ((== 'symbol? pred) 334 | (symbolo mval)) 335 | ((== 'number? pred) 336 | (numbero mval))) 337 | (var-p-match var mval penv penv-out))) 338 | ((fresh (quasi-p) 339 | (== (list 'quasiquote quasi-p) p) 340 | (quasi-p-match quasi-p mval penv penv-out))))) 341 | 342 | (define (p-no-match p mval penv penv-out) 343 | (conde 344 | ((self-eval-literalo p) 345 | (=/= p mval) 346 | (== penv penv-out)) 347 | ((var-p-no-match p mval penv penv-out)) 348 | ((fresh (var pred val) 349 | (== `(? ,pred ,var) p) 350 | (== penv penv-out) 351 | (symbolo var) 352 | (conde 353 | ((== 'symbol? pred) 354 | (conde 355 | ((not-symbolo mval)) 356 | ((symbolo mval) 357 | (var-p-no-match var mval penv penv-out)))) 358 | ((== 'number? pred) 359 | (conde 360 | ((not-numbero mval)) 361 | ((numbero mval) 362 | (var-p-no-match var mval penv penv-out))))))) 363 | ((fresh (quasi-p) 364 | (== (list 'quasiquote quasi-p) p) 365 | (quasi-p-no-match quasi-p mval penv penv-out))))) 366 | 367 | (define (quasi-p-match quasi-p mval penv penv-out) 368 | (conde 369 | ((== quasi-p mval) 370 | (== penv penv-out) 371 | (literalo quasi-p)) 372 | ((fresh (p) 373 | (== (list 'unquote p) quasi-p) 374 | (p-match p mval penv penv-out))) 375 | ((fresh (a d v1 v2 penv^) 376 | (== `(,a . ,d) quasi-p) 377 | (== `(,v1 . ,v2) mval) 378 | (=/= 'unquote a) 379 | (quasi-p-match a v1 penv penv^) 380 | (quasi-p-match d v2 penv^ penv-out))))) 381 | 382 | (define (quasi-p-no-match quasi-p mval penv penv-out) 383 | (conde 384 | ((=/= quasi-p mval) 385 | (== penv penv-out) 386 | (literalo quasi-p)) 387 | ((fresh (p) 388 | (== (list 'unquote p) quasi-p) 389 | (=/= 'closure mval) 390 | (p-no-match p mval penv penv-out))) 391 | ((fresh (a d) 392 | (== `(,a . ,d) quasi-p) 393 | (=/= 'unquote a) 394 | (== penv penv-out) 395 | (literalo mval))) 396 | ((fresh (a d v1 v2 penv^) 397 | (== `(,a . ,d) quasi-p) 398 | (=/= 'unquote a) 399 | (== `(,v1 . ,v2) mval) 400 | (conde 401 | ((quasi-p-no-match a v1 penv penv^)) 402 | ((quasi-p-match a v1 penv penv^) 403 | (quasi-p-no-match d v2 penv^ penv-out))))))) 404 | -------------------------------------------------------------------------------- /faster-miniKanren/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "minikanren") 4 | (define version "1.0") 5 | (define deps '("base")) 6 | 7 | (define compile-omit-paths 'all) 8 | (define compile-include-files 9 | '("main.rkt" 10 | "numbers.rkt" 11 | "matche.rkt" 12 | "simple-interp.rkt" 13 | "full-interp.rkt")) 14 | 15 | (define test-omit-paths '(#rx".*[.](scm)")) 16 | (define test-include-paths '("test-all.rktl")) 17 | -------------------------------------------------------------------------------- /faster-miniKanren/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "mk.rkt") 4 | 5 | (provide (all-from-out "mk.rkt") 6 | quote quasiquote unquote 7 | define 8 | #%datum 9 | #%app 10 | let) 11 | -------------------------------------------------------------------------------- /faster-miniKanren/matche.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "mk.rkt") 3 | (require (for-syntax racket/syntax)) 4 | 5 | (provide matche lambdae defmatche) 6 | 7 | (define-for-syntax memp memf) 8 | 9 | (include "matche.scm") 10 | -------------------------------------------------------------------------------- /faster-miniKanren/matche.scm: -------------------------------------------------------------------------------- 1 | ; new version of matche 2 | ; fixes depth related issues, and works with dots 3 | ; 4 | ; https://github.com/calvis/cKanren/blob/dev/cKanren/matche.rkt#L54 5 | 6 | ; Note that this definition is available at syntax phase in chez and vicare due to implicit 7 | ; phasing, but not in Racket (which uses explicit phasing). Racket already has a version available 8 | ; by default though, so that's fine. This definition isn't just isn't used in Racket. 9 | (define syntax->list 10 | (lambda (e) 11 | (syntax-case e () 12 | [() '()] 13 | [(x . r) (cons #'x (syntax->list #'r))]))) 14 | 15 | (define-syntax defmatche 16 | (lambda (stx) 17 | (syntax-case stx () 18 | [(defmatche (name args ...) clause ...) 19 | #'(define (name args ...) 20 | (matche (args ...) clause ...))]))) 21 | 22 | (define-syntax lambdae 23 | (syntax-rules () 24 | ((_ (x ...) c c* ...) 25 | (lambda (x ...) (matche (x ...) c c* ...))))) 26 | 27 | (define-syntax matche 28 | (lambda (stx) 29 | (syntax-case stx () 30 | [(matche (v ...) ([pat ...] g ...) ...) 31 | (let () 32 | (define remove-duplicates 33 | (lambda (ls eq-pred) 34 | (cond 35 | [(null? ls) '()] 36 | [(memp (lambda (x) (eq-pred (car ls) x)) (cdr ls)) 37 | (remove-duplicates (cdr ls) eq-pred)] 38 | [else (cons (car ls) (remove-duplicates (cdr ls) eq-pred))]))) 39 | (define parse-pattern 40 | (lambda (args pat) 41 | (syntax-case #`(#,args #,pat) () 42 | [(() ()) #'(() () ())] 43 | [((a args ...) [p pat ...]) 44 | (with-syntax ([(p^ (c ...) (x ...)) 45 | (parse-patterns-for-arg #'a #'p)]) 46 | (with-syntax ([([pat^ ...] (c^ ...) (x^ ...)) 47 | (parse-pattern #'(args ...) #'[pat ...])]) 48 | #'([p^ pat^ ...] (c ... c^ ...) (x ... x^ ...))))] 49 | [x (error 'parse-pattern "bad syntax ~s ~s" args pat)]))) 50 | (define parse-patterns-for-arg 51 | (lambda (v pat) 52 | (define loop 53 | (lambda (pat) 54 | (syntax-case pat (unquote ?? ?) ; ?? is the new _, since _ isn't legal in R6 55 | [(unquote ??) 56 | (with-syntax ([_new (generate-temporary #'?_)]) 57 | #'((unquote _new) () (_new)))] 58 | [(unquote x) 59 | (when (free-identifier=? #'x v) 60 | (error 'matche "argument ~s appears in pattern at an invalid depth" 61 | (syntax->datum #'x))) 62 | #'((unquote x) () (x))] 63 | [(unquote (? c x)) 64 | (when (free-identifier=? #'x v) 65 | (error 'matche "argument ~s appears in pattern at an invalid depth" 66 | (syntax->datum #'x))) 67 | #'((unquote x) ((c x)) (x))] 68 | [(a . d) 69 | (with-syntax ([((pat1 (c1 ...) (x1 ...)) 70 | (pat2 (c2 ...) (x2 ...))) 71 | (map loop (syntax->list #'(a d)))]) 72 | #'((pat1 . pat2) (c1 ... c2 ...) (x1 ... x2 ...)))] 73 | [x #'(x () ())]))) 74 | (syntax-case pat (unquote ?) 75 | [(unquote u) 76 | (cond 77 | [(and (identifier? #'u) 78 | (free-identifier=? v #'u)) 79 | #'((unquote u) () ())] 80 | [else (loop pat)])] 81 | [(unquote (? c u)) 82 | (cond 83 | [(and (identifier? #'u) 84 | (free-identifier=? v #'u)) 85 | #'((unquote u) ((c x)) ())] 86 | [else (loop pat)])] 87 | [else (loop pat)]))) 88 | (unless 89 | (andmap (lambda (y) (= (length (syntax->datum #'(v ...))) (length y))) 90 | (syntax->datum #'([pat ...] ...))) 91 | (error 'matche "pattern wrong length blah")) 92 | (with-syntax ([(([pat^ ...] (c ...) (x ...)) ...) 93 | (map (lambda (y) (parse-pattern #'(v ...) y)) 94 | (syntax->list #'([pat ...] ...)))]) 95 | (with-syntax ([((x^ ...) ...) 96 | (map (lambda (ls) 97 | (remove-duplicates (syntax->list ls) free-identifier=?)) 98 | (syntax->list #'((x ...) ...)))]) 99 | (with-syntax ([body 100 | #'(conde 101 | [(fresh (x^ ...) c ... (== `[pat^ ...] ls) g ...)] 102 | ...)]) 103 | #'(let ([ls (list v ...)]) body)))))] 104 | [(matche v (pat g ...) ...) 105 | #'(matche (v) ([pat] g ...) ...)]))) 106 | -------------------------------------------------------------------------------- /faster-miniKanren/mk-guile.scm: -------------------------------------------------------------------------------- 1 | (define-module (faster-miniKanren mk-guile) 2 | #:export (run run* 3 | == =/= 4 | fresh 5 | conde 6 | symbolo numbero 7 | absento 8 | matche)) 9 | 10 | (import (rnrs (6))) 11 | (import (rnrs records syntactic (6))) 12 | 13 | (define sub1 1-) 14 | (define add1 1+) 15 | 16 | (define fx= fx=?) 17 | (define fxsla fxarithmetic-shift-left) 18 | (define fxsra fxarithmetic-shift-right) 19 | (define fxsll bitwise-arithmetic-shift-left) 20 | 21 | (include-from-path "faster-miniKanren/mk-vicare.scm") 22 | (include-from-path "faster-miniKanren/mk.scm") 23 | 24 | (define (andmap proc . args) 25 | (let ((l (length (car args)))) 26 | (when (pair? (filter (lambda (x) (not (= l (length x)))) args)) 27 | (error 'andmap "Lists of unequal length" args))) 28 | (let rec 29 | ((result '()) 30 | (args args)) 31 | (if (equal? (car args) '()) 32 | (reverse result) 33 | (let ((val (apply proc (map car args)))) 34 | (if (not val) 35 | (reverse result) 36 | (rec (cons val result) 37 | (map cdr args))))))) 38 | 39 | (define generate-temporary gensym) 40 | 41 | (include-from-path "faster-miniKanren/matche.scm") 42 | -------------------------------------------------------------------------------- /faster-miniKanren/mk-vicare.scm: -------------------------------------------------------------------------------- 1 | ; This file needs to be loaded before mk.scm for Vicare. I can't figure 2 | ; out how to do loads relative to a source file rather than the working 3 | ; directory, else this file would load mk.scm. 4 | 5 | ; Trie implementation. The initial original trie version was due to Abdulaziz Ghuloum. 6 | ; Greg Rosenblatt changed it to an N-way Trie to reduce depth. 7 | 8 | ;;; subst ::= (empty) 9 | ;;; | (node even odd) 10 | ;;; | (data idx val) 11 | 12 | (define-record-type node (fields e o)) 13 | (define-record-type data (fields idx val)) 14 | 15 | (define shift (lambda (n) (fxsra n 1))) 16 | (define unshift (lambda (n i) (fx+ (fxsll n 1) i))) 17 | 18 | (define shift-size 4) 19 | (define node-size (fxsll 1 shift-size)) 20 | (define local-mask (fx- node-size 1)) 21 | (define (shift-n xi) (fxsra xi shift-size)) 22 | (define (local-n xi) (fxand xi local-mask)) 23 | (define node-n? vector?) 24 | (define (node-n-new i0 v0) 25 | (define result (make-vector (fx+ i0 1) '())) 26 | (vector-set! result i0 v0) 27 | result) 28 | (define (node-n-get nd idx) 29 | (if (fx= xi 0)) 71 | (error 't:bind "index must be a fixnum, got ~s" xi)) 72 | (nwt:bind s xi v))) 73 | 74 | (define t:lookup 75 | (lambda (xi s) 76 | (unless (and (fixnum? xi) (>= xi 0)) 77 | (error 't:lookup "index must be a fixnum, got ~s" xi)) 78 | (nwt:lookup s xi))) 79 | 80 | 81 | ; intmap 82 | 83 | (define empty-intmap '()) 84 | (define (intmap-count m) (t:size m)) 85 | (define (intmap-ref m k) 86 | (let ([res (t:lookup k m)]) 87 | (if res 88 | (data-val res) 89 | unbound))) 90 | (define (intmap-set m k v) (t:bind k v m)) 91 | 92 | 93 | ; Misc. missing functions 94 | 95 | (define (remove-duplicates l) 96 | (cond ((null? l) 97 | '()) 98 | ((member (car l) (cdr l)) 99 | (remove-duplicates (cdr l))) 100 | (else 101 | (cons (car l) (remove-duplicates (cdr l)))))) 102 | 103 | (define (foldl f init seq) 104 | (if (null? seq) 105 | init 106 | (foldl f 107 | (f (car seq) init) 108 | (cdr seq)))) 109 | 110 | (define (filter-map f l) (filter (lambda (x) x) (map f l))) 111 | 112 | (define (append* l*) (apply append l*)) 113 | -------------------------------------------------------------------------------- /faster-miniKanren/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/list 4 | racket/include) 5 | 6 | (provide run run* 7 | == =/= 8 | fresh 9 | conde 10 | symbolo numbero stringo 11 | absento 12 | project 13 | var? 14 | always-wrap-reified?) 15 | 16 | (define empty-intmap (hasheq)) 17 | (define (intmap-count m) (hash-count m)) 18 | (define (intmap-ref m k) (hash-ref m k (lambda () unbound))) 19 | (define (intmap-set m k v) (hash-set m k v)) 20 | 21 | ;; extra stuff for racket 22 | ;; due mostly to samth 23 | (define (list-sort f l) (sort l f)) 24 | 25 | (define (remp f l) (filter-not f l)) 26 | 27 | (define (call-with-string-output-port f) 28 | (define p (open-output-string)) 29 | (f p) 30 | (get-output-string p)) 31 | 32 | (define (exists f l) (ormap f l)) 33 | 34 | (define for-all andmap) 35 | 36 | (define (find f l) 37 | (cond [(memf f l) => car] [else #f])) 38 | 39 | (define memp memf) 40 | 41 | (define (var*? v) (var? (car v))) 42 | 43 | (include "mk.scm") 44 | -------------------------------------------------------------------------------- /faster-miniKanren/numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "numbero-1" 2 | (run* (q) (numbero q)) 3 | '((_.0 (num _.0)))) 4 | 5 | (test "numbero-2" 6 | (run* (q) (numbero q) (== 5 q)) 7 | '(5)) 8 | 9 | (test "numbero-3" 10 | (run* (q) (== 5 q) (numbero q)) 11 | '(5)) 12 | 13 | (test "numbero-4" 14 | (run* (q) (== 'x q) (numbero q)) 15 | '()) 16 | 17 | (test "numbero-5" 18 | (run* (q) (numbero q) (== 'x q)) 19 | '()) 20 | 21 | (test "numbero-6" 22 | (run* (q) (numbero q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "numbero-7" 26 | (run* (q) (== `(1 . 2) q) (numbero q)) 27 | '()) 28 | 29 | (test "numbero-8" 30 | (run* (q) (fresh (x) (numbero x))) 31 | '(_.0)) 32 | 33 | (test "numbero-9" 34 | (run* (q) (fresh (x) (numbero x))) 35 | '(_.0)) 36 | 37 | (test "numbero-10" 38 | (run* (q) (fresh (x) (numbero x) (== x q))) 39 | '((_.0 (num _.0)))) 40 | 41 | (test "numbero-11" 42 | (run* (q) (fresh (x) (numbero q) (== x q) (numbero x))) 43 | '((_.0 (num _.0)))) 44 | 45 | (test "numbero-12" 46 | (run* (q) (fresh (x) (numbero q) (numbero x) (== x q))) 47 | '((_.0 (num _.0)))) 48 | 49 | (test "numbero-13" 50 | (run* (q) (fresh (x) (== x q) (numbero q) (numbero x))) 51 | '((_.0 (num _.0)))) 52 | 53 | (test "numbero-14-a" 54 | (run* (q) (fresh (x) (numbero q) (== 5 x))) 55 | '((_.0 (num _.0)))) 56 | 57 | (test "numbero-14-b" 58 | (run* (q) (fresh (x) (numbero q) (== 5 x) (== x q))) 59 | '(5)) 60 | 61 | (test "numbero-15" 62 | (run* (q) (fresh (x) (== q x) (numbero q) (== 'y x))) 63 | '()) 64 | 65 | (test "numbero-16-a" 66 | (run* (q) (numbero q) (=/= 'y q)) 67 | '((_.0 (num _.0)))) 68 | 69 | (test "numbero-16-b" 70 | (run* (q) (=/= 'y q) (numbero q)) 71 | '((_.0 (num _.0)))) 72 | 73 | (test "numbero-17" 74 | (run* (q) (numbero q) (=/= `(1 . 2) q)) 75 | '((_.0 (num _.0)))) 76 | 77 | (test "numbero-18" 78 | (run* (q) (numbero q) (=/= 5 q)) 79 | '((_.0 (=/= ((_.0 5))) (num _.0)))) 80 | 81 | (test "numbero-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (numbero x) 85 | (numbero y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (num _.0 _.1)))) 88 | 89 | (test "numbero-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (numbero x) 94 | (numbero y))) 95 | '(((_.0 _.1) (num _.0 _.1)))) 96 | 97 | (test "numbero-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (numbero x) 102 | (numbero x))) 103 | '(((_.0 _.1) (num _.0)))) 104 | 105 | (test "numbero-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (numbero x) 109 | (numbero x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (num _.0)))) 112 | 113 | (test "numbero-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (numbero x) 117 | (== `(,x ,y) q) 118 | (numbero x))) 119 | '(((_.0 _.1) (num _.0)))) 120 | 121 | (test "numbero-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (numbero w) 126 | (numbero z))) 127 | '(_.0)) 128 | 129 | (test "numbero-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (numbero w) 134 | (numbero z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (num _.0 _.3)))) 139 | 140 | (test "numbero-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (numbero w) 145 | (numbero y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (num _.0 _.2)))) 150 | 151 | (test "numbero-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (numbero w) 156 | (numbero y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (num _.0)))) 162 | 163 | (test "numbero-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(a . b)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 a) (_.1 b)))))) 169 | 170 | (test "numbero-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(a . b)) 174 | (numbero w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (num _.0)))) 177 | 178 | (test "numbero-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (numbero w) 182 | (=/= `(,w . ,x) `(a . b)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (num _.0)))) 185 | 186 | (test "numbero-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (numbero w) 190 | (=/= `(a . b) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (num _.0)))) 193 | 194 | (test "numbero-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (numbero w) 198 | (=/= `(a . ,x) `(,w . b)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (num _.0)))) 201 | 202 | (test "numbero-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (numbero w) 206 | (=/= `(5 . ,x) `(,w . b)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 b))) (num _.0)))) 209 | 210 | (test "numbero-31" 211 | (run* (q) 212 | (fresh (x y z a b) 213 | (numbero x) 214 | (numbero y) 215 | (numbero z) 216 | (numbero a) 217 | (numbero b) 218 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 219 | (== q `(,x ,y ,z ,a ,b)))) 220 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 221 | 222 | (test "numbero-32" 223 | (run* (q) 224 | (fresh (x y z a b) 225 | (== q `(,x ,y ,z ,a ,b)) 226 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 227 | (numbero x) 228 | (numbero a))) 229 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 230 | -------------------------------------------------------------------------------- /faster-miniKanren/numbers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "main.rkt") 4 | 5 | (include "numbers.scm") 6 | 7 | (provide (except-out (all-defined-out) appendo)) 8 | -------------------------------------------------------------------------------- /faster-miniKanren/numbers.scm: -------------------------------------------------------------------------------- 1 | (define appendo 2 | (lambda (l s out) 3 | (conde 4 | [(== '() l) (== s out)] 5 | [(fresh (a d res) 6 | (== `(,a . ,d) l) 7 | (== `(,a . ,res) out) 8 | (appendo d s res))]))) 9 | 10 | (define build-num 11 | (lambda (n) 12 | (cond 13 | ((odd? n) 14 | (cons 1 15 | (build-num (quotient (- n 1) 2)))) 16 | ((and (not (zero? n)) (even? n)) 17 | (cons 0 18 | (build-num (quotient n 2)))) 19 | ((zero? n) '())))) 20 | 21 | (define zeroo 22 | (lambda (n) 23 | (== '() n))) 24 | 25 | (define poso 26 | (lambda (n) 27 | (fresh (a d) 28 | (== `(,a . ,d) n)))) 29 | 30 | (define >1o 31 | (lambda (n) 32 | (fresh (a ad dd) 33 | (== `(,a ,ad . ,dd) n)))) 34 | 35 | (define full-addero 36 | (lambda (b x y r c) 37 | (conde 38 | ((== 0 b) (== 0 x) (== 0 y) (== 0 r) (== 0 c)) 39 | ((== 1 b) (== 0 x) (== 0 y) (== 1 r) (== 0 c)) 40 | ((== 0 b) (== 1 x) (== 0 y) (== 1 r) (== 0 c)) 41 | ((== 1 b) (== 1 x) (== 0 y) (== 0 r) (== 1 c)) 42 | ((== 0 b) (== 0 x) (== 1 y) (== 1 r) (== 0 c)) 43 | ((== 1 b) (== 0 x) (== 1 y) (== 0 r) (== 1 c)) 44 | ((== 0 b) (== 1 x) (== 1 y) (== 0 r) (== 1 c)) 45 | ((== 1 b) (== 1 x) (== 1 y) (== 1 r) (== 1 c))))) 46 | 47 | (define addero 48 | (lambda (d n m r) 49 | (conde 50 | ((== 0 d) (== '() m) (== n r)) 51 | ((== 0 d) (== '() n) (== m r) 52 | (poso m)) 53 | ((== 1 d) (== '() m) 54 | (addero 0 n '(1) r)) 55 | ((== 1 d) (== '() n) (poso m) 56 | (addero 0 '(1) m r)) 57 | ((== '(1) n) (== '(1) m) 58 | (fresh (a c) 59 | (== `(,a ,c) r) 60 | (full-addero d 1 1 a c))) 61 | ((== '(1) n) (gen-addero d n m r)) 62 | ((== '(1) m) (>1o n) (>1o r) 63 | (addero d '(1) n r)) 64 | ((>1o n) (gen-addero d n m r))))) 65 | 66 | (define gen-addero 67 | (lambda (d n m r) 68 | (fresh (a b c e x y z) 69 | (== `(,a . ,x) n) 70 | (== `(,b . ,y) m) (poso y) 71 | (== `(,c . ,z) r) (poso z) 72 | (full-addero d a b c e) 73 | (addero e x y z)))) 74 | 75 | (define pluso 76 | (lambda (n m k) 77 | (addero 0 n m k))) 78 | 79 | (define minuso 80 | (lambda (n m k) 81 | (pluso m k n))) 82 | 83 | (define *o 84 | (lambda (n m p) 85 | (conde 86 | ((== '() n) (== '() p)) 87 | ((poso n) (== '() m) (== '() p)) 88 | ((== '(1) n) (poso m) (== m p)) 89 | ((>1o n) (== '(1) m) (== n p)) 90 | ((fresh (x z) 91 | (== `(0 . ,x) n) (poso x) 92 | (== `(0 . ,z) p) (poso z) 93 | (>1o m) 94 | (*o x m z))) 95 | ((fresh (x y) 96 | (== `(1 . ,x) n) (poso x) 97 | (== `(0 . ,y) m) (poso y) 98 | (*o m n p))) 99 | ((fresh (x y) 100 | (== `(1 . ,x) n) (poso x) 101 | (== `(1 . ,y) m) (poso y) 102 | (odd-*o x n m p)))))) 103 | 104 | (define odd-*o 105 | (lambda (x n m p) 106 | (fresh (q) 107 | (bound-*o q p n m) 108 | (*o x m q) 109 | (pluso `(0 . ,q) m p)))) 110 | 111 | (define bound-*o 112 | (lambda (q p n m) 113 | (conde 114 | ((== '() q) (poso p)) 115 | ((fresh (a0 a1 a2 a3 x y z) 116 | (== `(,a0 . ,x) q) 117 | (== `(,a1 . ,y) p) 118 | (conde 119 | ((== '() n) 120 | (== `(,a2 . ,z) m) 121 | (bound-*o x y z '())) 122 | ((== `(,a3 . ,z) n) 123 | (bound-*o x y z m)))))))) 124 | 125 | (define =lo 126 | (lambda (n m) 127 | (conde 128 | ((== '() n) (== '() m)) 129 | ((== '(1) n) (== '(1) m)) 130 | ((fresh (a x b y) 131 | (== `(,a . ,x) n) (poso x) 132 | (== `(,b . ,y) m) (poso y) 133 | (=lo x y)))))) 134 | 135 | (define 1o m)) 140 | ((fresh (a x b y) 141 | (== `(,a . ,x) n) (poso x) 142 | (== `(,b . ,y) m) (poso y) 143 | (1o b) (=lo n b) (pluso r b n)) 227 | ((== '(1) b) (poso q) (pluso r '(1) n)) 228 | ((== '() b) (poso q) (== r n)) 229 | ((== '(0 1) b) 230 | (fresh (a ad dd) 231 | (poso dd) 232 | (== `(,a ,ad . ,dd) n) 233 | (exp2 n '() q) 234 | (fresh (s) 235 | (splito n dd r s)))) 236 | ((fresh (a ad add ddd) 237 | (conde 238 | ((== '(1 1) b)) 239 | ((== `(,a ,ad ,add . ,ddd) b)))) 240 | (1o n) (== '(1) q) 272 | (fresh (s) 273 | (splito n b s '(1)))) 274 | ((fresh (q1 b2) 275 | (== `(0 . ,q1) q) 276 | (poso q1) 277 | (1o q) 294 | (fresh (q1 nq1) 295 | (pluso q1 '(1) q) 296 | (repeated-mul n q1 nq1) 297 | (*o nq1 n nq)))))) 298 | 299 | (define expo 300 | (lambda (b q n) 301 | (logo n b q '()))) 302 | 303 | -------------------------------------------------------------------------------- /faster-miniKanren/simple-interp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "main.rkt") 4 | 5 | (provide evalo) 6 | 7 | (include "simple-interp.scm") 8 | 9 | -------------------------------------------------------------------------------- /faster-miniKanren/simple-interp.scm: -------------------------------------------------------------------------------- 1 | (define evalo 2 | (lambda (expr val) 3 | (eval-expro expr '() val))) 4 | 5 | (define eval-expro 6 | (lambda (expr env val) 7 | (conde 8 | ((fresh (rator rand x body env^ a) 9 | (== `(,rator ,rand) expr) 10 | (eval-expro rator env `(closure ,x ,body ,env^)) 11 | (eval-expro rand env a) 12 | (eval-expro body `((,x . ,a) . ,env^) val))) 13 | ((fresh (x body) 14 | (== `(lambda (,x) ,body) expr) 15 | (symbolo x) 16 | (== `(closure ,x ,body ,env) val) 17 | (not-in-envo 'lambda env))) 18 | ((symbolo expr) (lookupo expr env val))))) 19 | 20 | (define not-in-envo 21 | (lambda (x env) 22 | (conde 23 | ((== '() env)) 24 | ((fresh (y v rest) 25 | (== `((,y . ,v) . ,rest) env) 26 | (=/= y x) 27 | (not-in-envo x rest)))))) 28 | 29 | (define lookupo 30 | (lambda (x env t) 31 | (conde 32 | ((fresh (y v rest) 33 | (== `((,y . ,v) . ,rest) env) (== y x) 34 | (== v t))) 35 | ((fresh (y v rest) 36 | (== `((,y . ,v) . ,rest) env) (=/= y x) 37 | (lookupo x rest t)))))) 38 | -------------------------------------------------------------------------------- /faster-miniKanren/stringo-tests.scm: -------------------------------------------------------------------------------- 1 | (test "stringo-1" 2 | (run* (q) (stringo q)) 3 | '((_.0 (str _.0)))) 4 | 5 | (test "stringo-2" 6 | (run* (q) (stringo q) (== "x" q)) 7 | '("x")) 8 | 9 | (test "stringo-3" 10 | (run* (q) (== "x" q) (stringo q)) 11 | '("x")) 12 | 13 | (test "stringo-4" 14 | (run* (q) (== 5 q) (stringo q)) 15 | '()) 16 | 17 | (test "stringo-5" 18 | (run* (q) (stringo q) (== 5 q)) 19 | '()) 20 | 21 | (test "stringo-6" 22 | (run* (q) (stringo q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "stringo-7" 26 | (run* (q) (== `(1 . 2) q) (stringo q)) 27 | '()) 28 | 29 | (test "stringo-8" 30 | (run* (q) (fresh (x) (stringo x))) 31 | '(_.0)) 32 | 33 | (test "stringo-9" 34 | (run* (q) (fresh (x) (stringo x))) 35 | '(_.0)) 36 | 37 | (test "stringo-10" 38 | (run* (q) (fresh (x) (stringo x) (== x q))) 39 | '((_.0 (str _.0)))) 40 | 41 | (test "stringo-11" 42 | (run* (q) (fresh (x) (stringo q) (== x q) (stringo x))) 43 | '((_.0 (str _.0)))) 44 | 45 | (test "stringo-12" 46 | (run* (q) (fresh (x) (stringo q) (stringo x) (== x q))) 47 | '((_.0 (str _.0)))) 48 | 49 | (test "stringo-13" 50 | (run* (q) (fresh (x) (== x q) (stringo q) (stringo x))) 51 | '((_.0 (str _.0)))) 52 | 53 | (test "stringo-14-a" 54 | (run* (q) (fresh (x) (stringo q) (== "y" x))) 55 | '((_.0 (str _.0)))) 56 | 57 | (test "stringo-14-b" 58 | (run* (q) (fresh (x) (stringo q) (== "y" x) (== x q))) 59 | '("y")) 60 | 61 | (test "stringo-15" 62 | (run* (q) (fresh (x) (== q x) (stringo q) (== 5 x))) 63 | '()) 64 | 65 | (test "stringo-16-a" 66 | (run* (q) (stringo q) (=/= 5 q)) 67 | '((_.0 (str _.0)))) 68 | 69 | (test "stringo-16-b" 70 | (run* (q) (=/= 5 q) (stringo q)) 71 | '((_.0 (str _.0)))) 72 | 73 | (test "stringo-17" 74 | (run* (q) (stringo q) (=/= `(1 . 2) q)) 75 | '((_.0 (str _.0)))) 76 | 77 | (test "stringo-18" 78 | (run* (q) (stringo q) (=/= "y" q)) 79 | '((_.0 (=/= ((_.0 "y"))) (str _.0)))) 80 | 81 | (test "stringo-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (stringo x) 85 | (stringo y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (str _.0 _.1)))) 88 | 89 | (test "stringo-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (stringo x) 94 | (stringo y))) 95 | '(((_.0 _.1) (str _.0 _.1)))) 96 | 97 | (test "stringo-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (stringo x) 102 | (stringo x))) 103 | '(((_.0 _.1) (str _.0)))) 104 | 105 | (test "stringo-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (stringo x) 109 | (stringo x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (str _.0)))) 112 | 113 | (test "stringo-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (stringo x) 117 | (== `(,x ,y) q) 118 | (stringo x))) 119 | '(((_.0 _.1) (str _.0)))) 120 | 121 | (test "stringo-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (stringo w) 126 | (stringo z))) 127 | '(_.0)) 128 | 129 | (test "stringo-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (stringo w) 134 | (stringo z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (str _.0 _.3)))) 139 | 140 | (test "stringo-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (stringo w) 145 | (stringo y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (str _.0 _.2)))) 150 | 151 | (test "stringo-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (stringo w) 156 | (stringo y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (str _.0)))) 162 | 163 | (test "stringo-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(5 . 6)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 6)))))) 169 | 170 | (test "stringo-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(5 . 6)) 174 | (stringo w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (str _.0)))) 177 | 178 | (test "stringo-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (stringo w) 182 | (=/= `(,w . ,x) `(5 . 6)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (str _.0)))) 185 | 186 | (test "stringo-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (stringo w) 190 | (=/= `(5 . 6) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (str _.0)))) 193 | 194 | (test "stringo-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (stringo w) 198 | (=/= `(5 . ,x) `(,w . 6)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (str _.0)))) 201 | 202 | (test "stringo-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (stringo w) 206 | (=/= `("z" . ,x) `(,w . 6)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 "z") (_.1 6))) (str _.0)))) 209 | 210 | (test "stringo-31-a" 211 | (run* (q) 212 | (fresh (w x y z) 213 | (== x 5) 214 | (=/= `(,w ,y) `(,x ,z)) 215 | (== w 5) 216 | (== `(,w ,x ,y ,z) q))) 217 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 218 | 219 | (test "stringo-31-b" 220 | (run* (q) 221 | (fresh (w x y z) 222 | (=/= `(,w ,y) `(,x ,z)) 223 | (== w 5) 224 | (== x 5) 225 | (== `(,w ,x ,y ,z) q))) 226 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 227 | 228 | (test "stringo-31-c" 229 | (run* (q) 230 | (fresh (w x y z) 231 | (== w 5) 232 | (=/= `(,w ,y) `(,x ,z)) 233 | (== `(,w ,x ,y ,z) q) 234 | (== x 5))) 235 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 236 | 237 | (test "stringo-31-d" 238 | (run* (q) 239 | (fresh (w x y z) 240 | (== w 5) 241 | (== x 5) 242 | (=/= `(,w ,y) `(,x ,z)) 243 | (== `(,w ,x ,y ,z) q))) 244 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 245 | 246 | 247 | (test "stringo-32-a" 248 | (run* (q) 249 | (fresh (w x y z) 250 | (== x 'a) 251 | (=/= `(,w ,y) `(,x ,z)) 252 | (== w 'a) 253 | (== `(,w ,x ,y ,z) q))) 254 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 255 | 256 | (test "stringo-32-b" 257 | (run* (q) 258 | (fresh (w x y z) 259 | (=/= `(,w ,y) `(,x ,z)) 260 | (== w 'a) 261 | (== x 'a) 262 | (== `(,w ,x ,y ,z) q))) 263 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 264 | 265 | (test "stringo-32-c" 266 | (run* (q) 267 | (fresh (w x y z) 268 | (== w 'a) 269 | (=/= `(,w ,y) `(,x ,z)) 270 | (== `(,w ,x ,y ,z) q) 271 | (== x 'a))) 272 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 273 | 274 | (test "stringo-32-d" 275 | (run* (q) 276 | (fresh (w x y z) 277 | (== w 'a) 278 | (== x 'a) 279 | (=/= `(,w ,y) `(,x ,z)) 280 | (== `(,w ,x ,y ,z) q))) 281 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 282 | 283 | (test "string-diseq-ordering" 284 | (run* (q) 285 | (=/= q "!") 286 | (=/= q '!)) 287 | '((_.0 (=/= ((_.0 "!")) ((_.0 !)))))) 288 | 289 | (test "string-diseq-ordering" 290 | (run* (q) 291 | (=/= q 'a) 292 | (=/= q "a")) 293 | '((_.0 (=/= ((_.0 "a")) ((_.0 a)))))) 294 | -------------------------------------------------------------------------------- /faster-miniKanren/symbolo-numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-numbero-1" 2 | (run* (q) (symbolo q) (numbero q)) 3 | '()) 4 | 5 | (test "symbolo-numbero-2" 6 | (run* (q) (numbero q) (symbolo q)) 7 | '()) 8 | 9 | (test "symbolo-numbero-3" 10 | (run* (q) 11 | (fresh (x) 12 | (numbero x) 13 | (symbolo x))) 14 | '()) 15 | 16 | (test "symbolo-numbero-4" 17 | (run* (q) 18 | (fresh (x) 19 | (symbolo x) 20 | (numbero x))) 21 | '()) 22 | 23 | (test "symbolo-numbero-5" 24 | (run* (q) 25 | (numbero q) 26 | (fresh (x) 27 | (symbolo x) 28 | (== x q))) 29 | '()) 30 | 31 | (test "symbolo-numbero-6" 32 | (run* (q) 33 | (symbolo q) 34 | (fresh (x) 35 | (numbero x) 36 | (== x q))) 37 | '()) 38 | 39 | (test "symbolo-numbero-7" 40 | (run* (q) 41 | (fresh (x) 42 | (numbero x) 43 | (== x q)) 44 | (symbolo q)) 45 | '()) 46 | 47 | (test "symbolo-numbero-7" 48 | (run* (q) 49 | (fresh (x) 50 | (symbolo x) 51 | (== x q)) 52 | (numbero q)) 53 | '()) 54 | 55 | (test "symbolo-numbero-8" 56 | (run* (q) 57 | (fresh (x) 58 | (== x q) 59 | (symbolo x)) 60 | (numbero q)) 61 | '()) 62 | 63 | (test "symbolo-numbero-9" 64 | (run* (q) 65 | (fresh (x) 66 | (== x q) 67 | (numbero x)) 68 | (symbolo q)) 69 | '()) 70 | 71 | (test "symbolo-numbero-10" 72 | (run* (q) 73 | (symbolo q) 74 | (fresh (x) 75 | (numbero x))) 76 | '((_.0 (sym _.0)))) 77 | 78 | (test "symbolo-numbero-11" 79 | (run* (q) 80 | (numbero q) 81 | (fresh (x) 82 | (symbolo x))) 83 | '((_.0 (num _.0)))) 84 | 85 | (test "symbolo-numbero-12" 86 | (run* (q) 87 | (fresh (x y) 88 | (symbolo x) 89 | (== `(,x ,y) q))) 90 | '(((_.0 _.1) (sym _.0)))) 91 | 92 | (test "symbolo-numbero-13" 93 | (run* (q) 94 | (fresh (x y) 95 | (numbero x) 96 | (== `(,x ,y) q))) 97 | '(((_.0 _.1) (num _.0)))) 98 | 99 | (test "symbolo-numbero-14" 100 | (run* (q) 101 | (fresh (x y) 102 | (numbero x) 103 | (symbolo y) 104 | (== `(,x ,y) q))) 105 | '(((_.0 _.1) (num _.0) (sym _.1)))) 106 | 107 | (test "symbolo-numbero-15" 108 | (run* (q) 109 | (fresh (x y) 110 | (numbero x) 111 | (== `(,x ,y) q) 112 | (symbolo y))) 113 | '(((_.0 _.1) (num _.0) (sym _.1)))) 114 | 115 | (test "symbolo-numbero-16" 116 | (run* (q) 117 | (fresh (x y) 118 | (== `(,x ,y) q) 119 | (numbero x) 120 | (symbolo y))) 121 | '(((_.0 _.1) (num _.0) (sym _.1)))) 122 | 123 | (test "symbolo-numbero-17" 124 | (run* (q) 125 | (fresh (x y) 126 | (== `(,x ,y) q) 127 | (numbero x) 128 | (symbolo y)) 129 | (fresh (w z) 130 | (== `(,w ,z) q))) 131 | '(((_.0 _.1) (num _.0) (sym _.1)))) 132 | 133 | (test "symbolo-numbero-18" 134 | (run* (q) 135 | (fresh (x y) 136 | (== `(,x ,y) q) 137 | (numbero x) 138 | (symbolo y)) 139 | (fresh (w z) 140 | (== `(,w ,z) q) 141 | (== w 5))) 142 | '(((5 _.0) (sym _.0)))) 143 | 144 | (test "symbolo-numbero-19" 145 | (run* (q) 146 | (fresh (x y) 147 | (== `(,x ,y) q) 148 | (numbero x) 149 | (symbolo y)) 150 | (fresh (w z) 151 | (== 'a z) 152 | (== `(,w ,z) q))) 153 | '(((_.0 a) (num _.0)))) 154 | 155 | (test "symbolo-numbero-20" 156 | (run* (q) 157 | (fresh (x y) 158 | (== `(,x ,y) q) 159 | (numbero x) 160 | (symbolo y)) 161 | (fresh (w z) 162 | (== `(,w ,z) q) 163 | (== 'a z))) 164 | '(((_.0 a) (num _.0)))) 165 | 166 | (test "symbolo-numbero-21" 167 | (run* (q) 168 | (fresh (x y) 169 | (== `(,x ,y) q) 170 | (=/= `(5 a) q))) 171 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 a)))))) 172 | 173 | (test "symbolo-numbero-22" 174 | (run* (q) 175 | (fresh (x y) 176 | (== `(,x ,y) q) 177 | (=/= `(5 a) q) 178 | (symbolo x))) 179 | '(((_.0 _.1) (sym _.0)))) 180 | 181 | (test "symbolo-numbero-23" 182 | (run* (q) 183 | (fresh (x y) 184 | (== `(,x ,y) q) 185 | (symbolo x) 186 | (=/= `(5 a) q))) 187 | '(((_.0 _.1) (sym _.0)))) 188 | 189 | (test "symbolo-numbero-24" 190 | (run* (q) 191 | (fresh (x y) 192 | (symbolo x) 193 | (== `(,x ,y) q) 194 | (=/= `(5 a) q))) 195 | '(((_.0 _.1) (sym _.0)))) 196 | 197 | (test "symbolo-numbero-25" 198 | (run* (q) 199 | (fresh (x y) 200 | (=/= `(5 a) q) 201 | (symbolo x) 202 | (== `(,x ,y) q))) 203 | '(((_.0 _.1) (sym _.0)))) 204 | 205 | (test "symbolo-numbero-26" 206 | (run* (q) 207 | (fresh (x y) 208 | (=/= `(5 a) q) 209 | (== `(,x ,y) q) 210 | (symbolo x))) 211 | '(((_.0 _.1) (sym _.0)))) 212 | 213 | (test "symbolo-numbero-27" 214 | (run* (q) 215 | (fresh (x y) 216 | (== `(,x ,y) q) 217 | (=/= `(5 a) q) 218 | (numbero y))) 219 | '(((_.0 _.1) (num _.1)))) 220 | 221 | (test "symbolo-numbero-28" 222 | (run* (q) 223 | (fresh (x y) 224 | (== `(,x ,y) q) 225 | (numbero y) 226 | (=/= `(5 a) q))) 227 | '(((_.0 _.1) (num _.1)))) 228 | 229 | (test "symbolo-numbero-29" 230 | (run* (q) 231 | (fresh (x y) 232 | (numbero y) 233 | (== `(,x ,y) q) 234 | (=/= `(5 a) q))) 235 | '(((_.0 _.1) (num _.1)))) 236 | 237 | (test "symbolo-numbero-30" 238 | (run* (q) 239 | (fresh (x y) 240 | (=/= `(5 a) q) 241 | (numbero y) 242 | (== `(,x ,y) q))) 243 | '(((_.0 _.1) (num _.1)))) 244 | 245 | (test "symbolo-numbero-31" 246 | (run* (q) 247 | (fresh (x y) 248 | (=/= `(5 a) q) 249 | (== `(,x ,y) q) 250 | (numbero y))) 251 | '(((_.0 _.1) (num _.1)))) 252 | 253 | (test "symbolo-numbero-32" 254 | (run* (q) 255 | (fresh (x y) 256 | (=/= `(,x ,y) q) 257 | (numbero x) 258 | (symbolo y))) 259 | '(_.0)) 260 | 261 | (test "symbolo-numbero-33" 262 | (run* (q) 263 | (fresh (x y) 264 | (numbero x) 265 | (=/= `(,x ,y) q) 266 | (symbolo y))) 267 | '(_.0)) 268 | 269 | (test "symbolo-numbero-34" 270 | (run* (q) 271 | (fresh (x y) 272 | (numbero x) 273 | (symbolo y) 274 | (=/= `(,x ,y) q))) 275 | '(_.0)) 276 | -------------------------------------------------------------------------------- /faster-miniKanren/symbolo-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-1" 2 | (run* (q) (symbolo q)) 3 | '((_.0 (sym _.0)))) 4 | 5 | (test "symbolo-2" 6 | (run* (q) (symbolo q) (== 'x q)) 7 | '(x)) 8 | 9 | (test "symbolo-3" 10 | (run* (q) (== 'x q) (symbolo q)) 11 | '(x)) 12 | 13 | (test "symbolo-4" 14 | (run* (q) (== 5 q) (symbolo q)) 15 | '()) 16 | 17 | (test "symbolo-5" 18 | (run* (q) (symbolo q) (== 5 q)) 19 | '()) 20 | 21 | (test "symbolo-6" 22 | (run* (q) (symbolo q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "symbolo-7" 26 | (run* (q) (== `(1 . 2) q) (symbolo q)) 27 | '()) 28 | 29 | (test "symbolo-8" 30 | (run* (q) (fresh (x) (symbolo x))) 31 | '(_.0)) 32 | 33 | (test "symbolo-9" 34 | (run* (q) (fresh (x) (symbolo x))) 35 | '(_.0)) 36 | 37 | (test "symbolo-10" 38 | (run* (q) (fresh (x) (symbolo x) (== x q))) 39 | '((_.0 (sym _.0)))) 40 | 41 | (test "symbolo-11" 42 | (run* (q) (fresh (x) (symbolo q) (== x q) (symbolo x))) 43 | '((_.0 (sym _.0)))) 44 | 45 | (test "symbolo-12" 46 | (run* (q) (fresh (x) (symbolo q) (symbolo x) (== x q))) 47 | '((_.0 (sym _.0)))) 48 | 49 | (test "symbolo-13" 50 | (run* (q) (fresh (x) (== x q) (symbolo q) (symbolo x))) 51 | '((_.0 (sym _.0)))) 52 | 53 | (test "symbolo-14-a" 54 | (run* (q) (fresh (x) (symbolo q) (== 'y x))) 55 | '((_.0 (sym _.0)))) 56 | 57 | (test "symbolo-14-b" 58 | (run* (q) (fresh (x) (symbolo q) (== 'y x) (== x q))) 59 | '(y)) 60 | 61 | (test "symbolo-15" 62 | (run* (q) (fresh (x) (== q x) (symbolo q) (== 5 x))) 63 | '()) 64 | 65 | (test "symbolo-16-a" 66 | (run* (q) (symbolo q) (=/= 5 q)) 67 | '((_.0 (sym _.0)))) 68 | 69 | (test "symbolo-16-b" 70 | (run* (q) (=/= 5 q) (symbolo q)) 71 | '((_.0 (sym _.0)))) 72 | 73 | (test "symbolo-17" 74 | (run* (q) (symbolo q) (=/= `(1 . 2) q)) 75 | '((_.0 (sym _.0)))) 76 | 77 | (test "symbolo-18" 78 | (run* (q) (symbolo q) (=/= 'y q)) 79 | '((_.0 (=/= ((_.0 y))) (sym _.0)))) 80 | 81 | (test "symbolo-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (symbolo x) 85 | (symbolo y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (sym _.0 _.1)))) 88 | 89 | (test "symbolo-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (symbolo x) 94 | (symbolo y))) 95 | '(((_.0 _.1) (sym _.0 _.1)))) 96 | 97 | (test "symbolo-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (symbolo x) 102 | (symbolo x))) 103 | '(((_.0 _.1) (sym _.0)))) 104 | 105 | (test "symbolo-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (symbolo x) 109 | (symbolo x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (sym _.0)))) 112 | 113 | (test "symbolo-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (symbolo x) 117 | (== `(,x ,y) q) 118 | (symbolo x))) 119 | '(((_.0 _.1) (sym _.0)))) 120 | 121 | (test "symbolo-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (symbolo w) 126 | (symbolo z))) 127 | '(_.0)) 128 | 129 | (test "symbolo-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (symbolo w) 134 | (symbolo z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (sym _.0 _.3)))) 139 | 140 | (test "symbolo-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (symbolo w) 145 | (symbolo y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (sym _.0 _.2)))) 150 | 151 | (test "symbolo-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (symbolo w) 156 | (symbolo y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (sym _.0)))) 162 | 163 | (test "symbolo-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(5 . 6)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 6)))))) 169 | 170 | (test "symbolo-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(5 . 6)) 174 | (symbolo w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (sym _.0)))) 177 | 178 | (test "symbolo-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (symbolo w) 182 | (=/= `(,w . ,x) `(5 . 6)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (sym _.0)))) 185 | 186 | (test "symbolo-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (symbolo w) 190 | (=/= `(5 . 6) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (sym _.0)))) 193 | 194 | (test "symbolo-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (symbolo w) 198 | (=/= `(5 . ,x) `(,w . 6)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (sym _.0)))) 201 | 202 | (test "symbolo-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (symbolo w) 206 | (=/= `(z . ,x) `(,w . 6)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 z) (_.1 6))) (sym _.0)))) 209 | 210 | (test "symbolo-31-a" 211 | (run* (q) 212 | (fresh (w x y z) 213 | (== x 5) 214 | (=/= `(,w ,y) `(,x ,z)) 215 | (== w 5) 216 | (== `(,w ,x ,y ,z) q))) 217 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 218 | 219 | (test "symbolo-31-b" 220 | (run* (q) 221 | (fresh (w x y z) 222 | (=/= `(,w ,y) `(,x ,z)) 223 | (== w 5) 224 | (== x 5) 225 | (== `(,w ,x ,y ,z) q))) 226 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 227 | 228 | (test "symbolo-31-c" 229 | (run* (q) 230 | (fresh (w x y z) 231 | (== w 5) 232 | (=/= `(,w ,y) `(,x ,z)) 233 | (== `(,w ,x ,y ,z) q) 234 | (== x 5))) 235 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 236 | 237 | (test "symbolo-31-d" 238 | (run* (q) 239 | (fresh (w x y z) 240 | (== w 5) 241 | (== x 5) 242 | (=/= `(,w ,y) `(,x ,z)) 243 | (== `(,w ,x ,y ,z) q))) 244 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 245 | 246 | 247 | (test "symbolo-32-a" 248 | (run* (q) 249 | (fresh (w x y z) 250 | (== x 'a) 251 | (=/= `(,w ,y) `(,x ,z)) 252 | (== w 'a) 253 | (== `(,w ,x ,y ,z) q))) 254 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 255 | 256 | (test "symbolo-32-b" 257 | (run* (q) 258 | (fresh (w x y z) 259 | (=/= `(,w ,y) `(,x ,z)) 260 | (== w 'a) 261 | (== x 'a) 262 | (== `(,w ,x ,y ,z) q))) 263 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 264 | 265 | (test "symbolo-32-c" 266 | (run* (q) 267 | (fresh (w x y z) 268 | (== w 'a) 269 | (=/= `(,w ,y) `(,x ,z)) 270 | (== `(,w ,x ,y ,z) q) 271 | (== x 'a))) 272 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 273 | 274 | (test "symbolo-32-d" 275 | (run* (q) 276 | (fresh (w x y z) 277 | (== w 'a) 278 | (== x 'a) 279 | (=/= `(,w ,y) `(,x ,z)) 280 | (== `(,w ,x ,y ,z) q))) 281 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 282 | -------------------------------------------------------------------------------- /faster-miniKanren/test-all.rktl: -------------------------------------------------------------------------------- 1 | #lang racket/load 2 | 3 | (require "main.rkt") 4 | 5 | (load "test-all.scm") 6 | 7 | (when test-failed 8 | (exit 1)) 9 | -------------------------------------------------------------------------------- /faster-miniKanren/test-all.scm: -------------------------------------------------------------------------------- 1 | (load "test-check.scm") 2 | 3 | (printf "==-tests\n") 4 | (load "==-tests.scm") 5 | 6 | (printf "symbolo-tests\n") 7 | (load "symbolo-tests.scm") 8 | 9 | (printf "numbero-tests\n") 10 | (load "numbero-tests.scm") 11 | 12 | (printf "symbolo-numbero-tests\n") 13 | (load "symbolo-numbero-tests.scm") 14 | 15 | (printf "stringo-tests.scm\n") 16 | (load "stringo-tests.scm") 17 | 18 | (printf "disequality-tests\n") 19 | (load "disequality-tests.scm") 20 | 21 | (printf "absento-closure-tests\n") 22 | (load "absento-closure-tests.scm") 23 | 24 | (printf "absento-tests\n") 25 | (load "absento-tests.scm") 26 | 27 | (printf "test-infer\n") 28 | (load "test-infer.scm") 29 | 30 | (printf "test-simple-interp\n") 31 | (load "test-simple-interp.scm") 32 | 33 | (printf "test-quines\n") 34 | (load "test-quines.scm") 35 | 36 | (printf "test-numbers\n") 37 | (load "numbers.scm") 38 | (load "test-numbers.scm") 39 | -------------------------------------------------------------------------------- /faster-miniKanren/test-check.scm: -------------------------------------------------------------------------------- 1 | (define test-failed #f) 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | ((_ title tested-expression expected-result) 6 | (begin 7 | (printf "Testing ~s\n" title) 8 | (let* ((expected expected-result) 9 | (produced tested-expression)) 10 | (or (equal? expected produced) 11 | (begin 12 | (set! test-failed #t) 13 | (printf "Failed: ~s~%Expected: ~s~%Computed: ~s~%" 14 | 'tested-expression expected produced)))))))) 15 | -------------------------------------------------------------------------------- /faster-miniKanren/test-guile.scm: -------------------------------------------------------------------------------- 1 | (use-modules (faster-miniKanren mk-guile)) 2 | 3 | (define (printf . args) 4 | (apply format #t args)) 5 | 6 | (include "test-all.scm") 7 | -------------------------------------------------------------------------------- /faster-miniKanren/test-infer.scm: -------------------------------------------------------------------------------- 1 | (define !- 2 | (lambda (exp env t) 3 | (conde 4 | [(symbolo exp) (lookupo exp env t)] 5 | [(fresh (x e t-x t-e) 6 | (== `(lambda (,x) ,e) exp) 7 | (symbolo x) 8 | (not-in-envo 'lambda env) 9 | (== `(-> ,t-x ,t-e) t) 10 | (!- e `((,x . ,t-x) . ,env) t-e))] 11 | [(fresh (rator rand t-x) 12 | (== `(,rator ,rand) exp) 13 | (!- rator env `(-> ,t-x ,t)) 14 | (!- rand env t-x))]))) 15 | 16 | (define lookupo 17 | (lambda (x env t) 18 | (fresh (rest y v) 19 | (== `((,y . ,v) . ,rest) env) 20 | (conde 21 | ((== y x) (== v t)) 22 | ((=/= y x) (lookupo x rest t)))))) 23 | 24 | (define not-in-envo 25 | (lambda (x env) 26 | (conde 27 | ((== '() env)) 28 | ((fresh (y v rest) 29 | (== `((,y . ,v) . ,rest) env) 30 | (=/= y x) 31 | (not-in-envo x rest)))))) 32 | 33 | (test "types" 34 | (run 10 (q) (fresh (t exp) (!- exp '() t) (== `(,exp => ,t) q))) 35 | '((((lambda (_.0) _.0) => (-> _.1 _.1)) (sym _.0)) 36 | (((lambda (_.0) (lambda (_.1) _.1)) 37 | => 38 | (-> _.2 (-> _.3 _.3))) 39 | (=/= ((_.0 lambda))) 40 | (sym _.0 _.1)) 41 | (((lambda (_.0) (lambda (_.1) _.0)) 42 | => 43 | (-> _.2 (-> _.3 _.2))) 44 | (=/= ((_.0 _.1)) ((_.0 lambda))) 45 | (sym _.0 _.1)) 46 | ((((lambda (_.0) _.0) (lambda (_.1) _.1)) => (-> _.2 _.2)) 47 | (sym _.0 _.1)) 48 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.2))) 49 | => 50 | (-> _.3 (-> _.4 (-> _.5 _.5)))) 51 | (=/= ((_.0 lambda)) ((_.1 lambda))) 52 | (sym _.0 _.1 _.2)) 53 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.1))) 54 | => 55 | (-> _.3 (-> _.4 (-> _.5 _.4)))) 56 | (=/= ((_.0 lambda)) ((_.1 _.2)) ((_.1 lambda))) 57 | (sym _.0 _.1 _.2)) 58 | (((lambda (_.0) (_.0 (lambda (_.1) _.1))) 59 | => 60 | (-> (-> (-> _.2 _.2) _.3) _.3)) 61 | (=/= ((_.0 lambda))) 62 | (sym _.0 _.1)) 63 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.0))) 64 | => 65 | (-> _.3 (-> _.4 (-> _.5 _.3)))) 66 | (=/= ((_.0 _.1)) ((_.0 _.2)) ((_.0 lambda)) ((_.1 lambda))) 67 | (sym _.0 _.1 _.2)) 68 | (((lambda (_.0) (lambda (_.1) (_.1 _.0))) 69 | => 70 | (-> _.2 (-> (-> _.2 _.3) _.3))) 71 | (=/= ((_.0 _.1)) ((_.0 lambda))) 72 | (sym _.0 _.1)) 73 | ((((lambda (_.0) _.0) (lambda (_.1) (lambda (_.2) _.2))) 74 | => 75 | (-> _.3 (-> _.4 _.4))) 76 | (=/= ((_.1 lambda))) 77 | (sym _.0 _.1 _.2)))) 78 | -------------------------------------------------------------------------------- /faster-miniKanren/test-numbers.scm: -------------------------------------------------------------------------------- 1 | (test "test 1" 2 | (run* (q) (*o (build-num 2) (build-num 3) q)) 3 | '((0 1 1))) 4 | 5 | (test "test 2" 6 | (run* (q) 7 | (fresh (n m) 8 | (*o n m (build-num 6)) 9 | (== `(,n ,m) q))) 10 | '(((1) (0 1 1)) ((0 1 1) (1)) ((0 1) (1 1)) ((1 1) (0 1)))) 11 | 12 | (test "sums" 13 | (run 5 (q) 14 | (fresh (x y z) 15 | (pluso x y z) 16 | (== `(,x ,y ,z) q))) 17 | '((_.0 () _.0) 18 | (() (_.0 . _.1) (_.0 . _.1)) 19 | ((1) (1) (0 1)) 20 | ((1) (0 _.0 . _.1) (1 _.0 . _.1)) 21 | ((1) (1 1) (0 0 1)))) 22 | 23 | (test "factors" 24 | (run* (q) 25 | (fresh (x y) 26 | (*o x y (build-num 24)) 27 | (== `(,x ,y ,(build-num 24)) q))) 28 | '(((1) (0 0 0 1 1) (0 0 0 1 1)) 29 | ((0 0 0 1 1) (1) (0 0 0 1 1)) 30 | ((0 1) (0 0 1 1) (0 0 0 1 1)) 31 | ((0 0 1) (0 1 1) (0 0 0 1 1)) 32 | ((0 0 0 1) (1 1) (0 0 0 1 1)) 33 | ((1 1) (0 0 0 1) (0 0 0 1 1)) 34 | ((0 1 1) (0 0 1) (0 0 0 1 1)) 35 | ((0 0 1 1) (0 1) (0 0 0 1 1)))) 36 | 37 | (define number-primo 38 | (lambda (exp env val) 39 | (fresh (n) 40 | (== `(intexp ,n) exp) 41 | (== `(intval ,n) val) 42 | (not-in-envo 'numo env)))) 43 | 44 | (define sub1-primo 45 | (lambda (exp env val) 46 | (fresh (e n n-1) 47 | (== `(sub1 ,e) exp) 48 | (== `(intval ,n-1) val) 49 | (not-in-envo 'sub1 env) 50 | (eval-expo e env `(intval ,n)) 51 | (minuso n '(1) n-1)))) 52 | 53 | (define zero?-primo 54 | (lambda (exp env val) 55 | (fresh (e n) 56 | (== `(zero? ,e) exp) 57 | (conde 58 | ((zeroo n) (== #t val)) 59 | ((poso n) (== #f val))) 60 | (not-in-envo 'zero? env) 61 | (eval-expo e env `(intval ,n))))) 62 | 63 | (define *-primo 64 | (lambda (exp env val) 65 | (fresh (e1 e2 n1 n2 n3) 66 | (== `(* ,e1 ,e2) exp) 67 | (== `(intval ,n3) val) 68 | (not-in-envo '* env) 69 | (eval-expo e1 env `(intval ,n1)) 70 | (eval-expo e2 env `(intval ,n2)) 71 | (*o n1 n2 n3)))) 72 | 73 | (define if-primo 74 | (lambda (exp env val) 75 | (fresh (e1 e2 e3 t) 76 | (== `(if ,e1 ,e2 ,e3) exp) 77 | (not-in-envo 'if env) 78 | (eval-expo e1 env t) 79 | (conde 80 | ((== #t t) (eval-expo e2 env val)) 81 | ((== #f t) (eval-expo e3 env val)))))) 82 | 83 | (define boolean-primo 84 | (lambda (exp env val) 85 | (conde 86 | ((== #t exp) (== #t val)) 87 | ((== #f exp) (== #f val))))) 88 | 89 | (define eval-expo 90 | (lambda (exp env val) 91 | (conde 92 | ((boolean-primo exp env val)) 93 | ((number-primo exp env val)) 94 | ((sub1-primo exp env val)) 95 | ((zero?-primo exp env val)) 96 | ((*-primo exp env val)) 97 | ((if-primo exp env val)) 98 | ((symbolo exp) (lookupo exp env val)) 99 | ((fresh (rator rand x body env^ a) 100 | (== `(,rator ,rand) exp) 101 | (eval-expo rator env `(closure ,x ,body ,env^)) 102 | (eval-expo rand env a) 103 | (eval-expo body `((,x . ,a) . ,env^) val))) 104 | ((fresh (x body) 105 | (== `(lambda (,x) ,body) exp) 106 | (symbolo x) 107 | (== `(closure ,x ,body ,env) val) 108 | (not-in-envo 'lambda env)))))) 109 | 110 | (define not-in-envo 111 | (lambda (x env) 112 | (conde 113 | ((fresh (y v rest) 114 | (== `((,y . ,v) . ,rest) env) 115 | (=/= y x) 116 | (not-in-envo x rest))) 117 | ((== '() env))))) 118 | 119 | (define lookupo 120 | (lambda (x env t) 121 | (fresh (rest y v) 122 | (== `((,y . ,v) . ,rest) env) 123 | (conde 124 | ((== y x) (== v t)) 125 | ((=/= y x) (lookupo x rest t)))))) 126 | 127 | (test "push-down problems 2" 128 | (run* (q) 129 | (fresh (x a d) 130 | (absento 'intval x) 131 | (== 'intval a) 132 | (== `(,a . ,d) x))) 133 | '()) 134 | 135 | (test "push-down problems 3" 136 | (run* (q) 137 | (fresh (x a d) 138 | (== `(,a . ,d) x) 139 | (absento 'intval x) 140 | (== 'intval a))) 141 | '()) 142 | 143 | (test "push-down problems 4" 144 | (run* (q) 145 | (fresh (x a d) 146 | (== `(,a . ,d) x) 147 | (== 'intval a) 148 | (absento 'intval x))) 149 | '()) 150 | 151 | (test "push-down problems 6" 152 | (run* (q) 153 | (fresh (x a d) 154 | (== 'intval a) 155 | (== `(,a . ,d) x) 156 | (absento 'intval x))) 157 | '()) 158 | 159 | (test "push-down problems 1" 160 | (run* (q) 161 | (fresh (x a d) 162 | (absento 'intval x) 163 | (== `(,a . ,d) x) 164 | (== 'intval a))) 165 | '()) 166 | 167 | (test "push-down problems 5" 168 | (run* (q) 169 | (fresh (x a d) 170 | (== 'intval a) 171 | (absento 'intval x) 172 | (== `(,a . ,d) x))) 173 | '()) 174 | 175 | (test "zero?" 176 | (run 1 (q) 177 | (eval-expo `(zero? (sub1 (intexp ,(build-num 1)))) '() q)) 178 | '(#t)) 179 | 180 | (test "*" 181 | (run 1 (q) 182 | (eval-expo `(* (intexp ,(build-num 3)) (intexp ,(build-num 2))) '() `(intval ,(build-num 6)))) 183 | '(_.0)) 184 | 185 | (test "sub1" 186 | (run 1 (q) 187 | (eval-expo q '() `(intval ,(build-num 6))) (== `(sub1 (intexp ,(build-num 7))) q)) 188 | '((sub1 (intexp (1 1 1))))) 189 | 190 | (test "sub1 bigger WAIT a minute" 191 | (run 1 (q) 192 | (eval-expo q '() `(intval ,(build-num 6))) 193 | (== `(sub1 (sub1 (intexp ,(build-num 8)))) q)) 194 | '((sub1 (sub1 (intexp (0 0 0 1)))))) 195 | 196 | (test "sub1 biggest WAIT a minute" 197 | (run 1 (q) 198 | (eval-expo q '() `(intval ,(build-num 6))) 199 | (== `(sub1 (sub1 (sub1 (intexp ,(build-num 9))))) q)) 200 | '((sub1 (sub1 (sub1 (intexp (1 0 0 1))))))) 201 | 202 | (test "lots of programs to make a 6" 203 | (run 12 (q) (eval-expo q '() `(intval ,(build-num 6)))) 204 | '((intexp (0 1 1)) (sub1 (intexp (1 1 1))) 205 | (* (intexp (1)) (intexp (0 1 1))) 206 | (* (intexp (0 1 1)) (intexp (1))) 207 | (if #t (intexp (0 1 1)) _.0) 208 | (* (intexp (0 1)) (intexp (1 1))) 209 | (if #f _.0 (intexp (0 1 1))) 210 | (sub1 (* (intexp (1)) (intexp (1 1 1)))) 211 | (((lambda (_.0) (intexp (0 1 1))) #t) 212 | (=/= ((_.0 numo))) 213 | (sym _.0)) 214 | (sub1 (* (intexp (1 1 1)) (intexp (1)))) 215 | (sub1 (sub1 (intexp (0 0 0 1)))) 216 | (sub1 (if #t (intexp (1 1 1)) _.0)))) 217 | 218 | (define rel-fact5 219 | `((lambda (f) 220 | ((f f) (intexp ,(build-num 5)))) 221 | (lambda (f) 222 | (lambda (n) 223 | (if (zero? n) 224 | (intexp ,(build-num 1)) 225 | (* n ((f f) (sub1 n)))))))) 226 | 227 | (test "rel-fact5" 228 | (run* (q) (eval-expo rel-fact5 '() q)) 229 | `((intval ,(build-num 120)))) 230 | 231 | (test "rel-fact5-backwards" 232 | (run 1 (q) 233 | (eval-expo 234 | `((lambda (f) 235 | ((f ,q) (intexp ,(build-num 5)))) 236 | (lambda (f) 237 | (lambda (n) 238 | (if (zero? n) 239 | (intexp ,(build-num 1)) 240 | (* n ((f f) (sub1 n))))))) 241 | '() 242 | `(intval ,(build-num 120)))) 243 | `(f)) 244 | -------------------------------------------------------------------------------- /faster-miniKanren/test-simple-interp.scm: -------------------------------------------------------------------------------- 1 | (load "simple-interp.scm") 2 | 3 | (test "running backwards" 4 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 5 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 6 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 7 | (((lambda (x) (lambda (y) x)) 8 | ((lambda (_.0) _.0) (lambda (z) z))) 9 | (sym _.0)) 10 | (((lambda (_.0) _.0) 11 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 12 | (sym _.0)) 13 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 14 | (lambda (z) z)) 15 | (sym _.0)))) 16 | 17 | (define lookupo 18 | (lambda (x env t) 19 | (fresh (rest y v) 20 | (== `((,y . ,v) . ,rest) env) 21 | (conde 22 | ((== y x) (== v t)) 23 | ((=/= y x) (lookupo x rest t)))))) 24 | 25 | (test "eval-exp-lc 1" 26 | (run* (q) (evalo '(((lambda (x) (lambda (y) x)) (lambda (z) z)) (lambda (a) a)) q)) 27 | '((closure z z ()))) 28 | 29 | (test "eval-exp-lc 2" 30 | (run* (q) (evalo '((lambda (x) (lambda (y) x)) (lambda (z) z)) q)) 31 | '((closure y x ((x . (closure z z ())))))) 32 | 33 | (test "running backwards" 34 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 35 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 36 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 37 | (((lambda (x) (lambda (y) x)) 38 | ((lambda (_.0) _.0) (lambda (z) z))) 39 | (sym _.0)) 40 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 41 | (lambda (z) z)) 42 | (sym _.0)) 43 | (((lambda (_.0) _.0) 44 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 45 | (sym _.0)))) 46 | 47 | (test "fully-running-backwards" 48 | (run 5 (q) 49 | (fresh (e v) 50 | (evalo e v) 51 | (== `(,e ==> ,v) q))) 52 | '((((lambda (_.0) _.1) 53 | ==> (closure _.0 _.1 ())) (sym _.0)) 54 | ((((lambda (_.0) _.0) (lambda (_.1) _.2)) 55 | ==> 56 | (closure _.1 _.2 ())) 57 | (sym _.0 _.1)) 58 | ((((lambda (_.0) (lambda (_.1) _.2)) (lambda (_.3) _.4)) 59 | ==> 60 | (closure _.1 _.2 ((_.0 . (closure _.3 _.4 ()))))) 61 | (=/= ((_.0 lambda))) 62 | (sym _.0 _.1 _.3)) 63 | ((((lambda (_.0) (_.0 _.0)) (lambda (_.1) _.1)) 64 | ==> 65 | (closure _.1 _.1 ())) 66 | (sym _.0 _.1)) 67 | ((((lambda (_.0) (_.0 _.0)) 68 | (lambda (_.1) (lambda (_.2) _.3))) 69 | ==> 70 | (closure _.2 _.3 ((_.1 . (closure _.1 (lambda (_.2) _.3) ()))))) 71 | (=/= ((_.1 lambda))) 72 | (sym _.0 _.1 _.2)))) 73 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-combined/core-mk-complex.scm: -------------------------------------------------------------------------------- 1 | ;;; Code from `core-mk-explicit-unification-failure-streams` 2 | 3 | ;; Relational environment-passing, substitution-passing interpreter 4 | ;; for a subset of miniKanren, written in miniKanren. 5 | ;; 6 | ;; This version of the interpreter explicitly represents failure, in 7 | ;; addition to success, and explicitly represents streams. 8 | 9 | #| 10 | Grammar: 11 | 12 | ;; run* expression 13 | run1-expr ::= (run* () ) 14 | 15 | ;; goal expression 16 | ::= (== ) | 17 | (fresh () ) | 18 | (fresh () ) | 19 | (conde () ()) 20 | 21 | ;; Scheme expression 22 | ::= | 23 | (quote ) | 24 | (cons ) 25 | 26 | ;; Scheme lexical variable 27 | ::= 28 | 29 | ;; quoted datum 30 | ::= | 31 | () | 32 | ( . ) 33 | |# 34 | 35 | ;; Logic variables are represented as tagged lists of the form `(var ,c)` 36 | ;; where `c` is a Peano numeral of the form `z`, `(s z)`, `(s (s z))`, etc. 37 | ;; Logic variables that remain fresh are reified as themselves, rather than 38 | ;; being replaced with `_.0`, `_.1`, etc. 39 | 40 | 41 | ;; TODO: 42 | ;; 43 | ;; Think about reification of fresh logic variables--should it work 44 | ;; like in regular mk, by using some kind of fake subst? If so, would 45 | ;; you be able to tell whether '_.0' came from miniKanren, or the 46 | ;; language being interpreted? 47 | ;; 48 | ;; Support =/=, symbolo, numbero, and absento 49 | ;; 50 | ;; Support helpers and recursion 51 | 52 | (define mzero-complex '()) 53 | (define (unit-complex s/c) (cons s/c mzero-complex)) 54 | 55 | (define (mko-complex expr out) 56 | (fresh (q ge $) 57 | (== `(run* (,q) ,ge) expr) 58 | (symbolo q) 59 | (eval-mko-complex 60 | ;; goal expression 61 | ge 62 | ;; initial env 63 | `((,q . (var z))) 64 | ;; initial s/c 65 | '(() . (s z)) 66 | ;; resulting stream of s/c's 67 | $) 68 | (map-walk*o-complex `(var z) $ out))) 69 | 70 | (define (eval-mko-complex expr env s/c $) 71 | (conde 72 | ((fresh (e1 e2 t1 t2 s s^ c) 73 | (== `(== ,e1 ,e2) expr) 74 | (== `(,s . ,c) s/c) 75 | (evalo-complex e1 env t1) 76 | (evalo-complex e2 env t2) 77 | (conde 78 | ((== #f s^) (== mzero-complex $)) 79 | ((=/= #f s^) (== (unit-complex `(,s^ . (s ,c))) $))) 80 | (unifyo-complex t1 t2 s s^))) 81 | ((fresh (x ge s c) 82 | (== `(fresh (,x) ,ge) expr) 83 | (symbolo x) 84 | (== `(,s . ,c) s/c) 85 | (eval-mko-complex ge `((,x . (var ,c)) . ,env) `(,s . (s ,c)) $))) 86 | ((fresh (x ge1 ge2 env^ s c $^) 87 | (== `(fresh (,x) ,ge1 ,ge2) expr) 88 | (symbolo x) 89 | (== `(,s . ,c) s/c) 90 | (== `((,x . (var ,c)) . ,env) env^) 91 | (eval-mko-complex ge1 env^ `(,s . (s ,c)) $^) 92 | (bindo-complex $^ ge2 env^ $))) 93 | ((fresh (ge1 ge2 $1 $2) 94 | (== `(conde (,ge1) (,ge2)) expr) 95 | (eval-mko-complex ge1 env s/c $1) 96 | (eval-mko-complex ge2 env s/c $2) 97 | (mpluso-complex $1 $2 $))))) 98 | 99 | (define (mpluso-complex $1 $2 $^) 100 | (conde 101 | ((== '() $1) (== $2 $^)) 102 | ;; 103 | ;; no procedure/delayed clause 104 | ;; 105 | ;; TODO: do we need the procedure/delayed clause? If so, how to 106 | ;; implement it? Using `evalo-complex`? 107 | ;; 108 | ((fresh (a d res) 109 | (== `(,a . ,d) $1) 110 | (== `(,a . ,res) $^) 111 | (mpluso-complex d $2 res))))) 112 | 113 | (define (bindo-complex $ g env $^) 114 | (conde 115 | ((== '() $) (== mzero-complex $^)) 116 | ;; 117 | ;; no procedure/delayed clause 118 | ;; 119 | ;; TODO: do we need the procedure/delayed clause? If so, how to 120 | ;; implement it? Using `evalo-complex`? 121 | ;; 122 | ((fresh (a d $1^ $2^) 123 | (== `(,a . ,d) $) 124 | ;; we need to use `eval-mko-complex`, which takes `env`, 125 | ;; to keep everything relational 126 | (eval-mko-complex g env a $1^) 127 | (bindo-complex d g env $2^) 128 | (mpluso-complex $1^ $2^ $^))))) 129 | 130 | (define (evalo-complex expr env val) 131 | (conde 132 | ((== `(quote ,val) expr) 133 | (absento 'var val)) 134 | ((symbolo expr) (lookupo-complex expr env val)) 135 | ((fresh (e1 e2 v1 v2) 136 | (== `(cons ,e1 ,e2) expr) 137 | (== `(,v1 . ,v2) val) 138 | (evalo-complex e1 env v1) 139 | (evalo-complex e2 env v2))))) 140 | 141 | (define (lookupo-complex x env val) 142 | (fresh (y v rest) 143 | (== `((,y . ,v) . ,rest) env) 144 | (conde 145 | ((== x y) (== v val)) 146 | ((=/= x y) 147 | (lookupo-complex x rest val))))) 148 | 149 | (define (unifyo-complex t1 t2 subst subst^) 150 | (fresh (t1^ t2^) 151 | (walko-complex t1 subst t1^) 152 | (walko-complex t2 subst t2^) 153 | (conde 154 | ;; ----- symbols ------- 155 | ;; symbol with symbol 156 | ((symbolo t1^) (symbolo t2^) 157 | (conde 158 | ((== t1^ t2^) (== subst subst^)) 159 | ((=/= t1^ t2^) (== #f subst^)))) 160 | ;; symbol with empty list 161 | ((symbolo t1^) (== '() t2^) 162 | (== #f subst^)) 163 | ((symbolo t2^) (== '() t1^) 164 | (== #f subst^)) 165 | ;; symbol with pair 166 | ((fresh (a2 d2) 167 | (symbolo t1^) 168 | (== `(,a2 . ,d2) t2^) 169 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 170 | (== #f subst^))) 171 | ((fresh (a1 d1) 172 | (symbolo t2^) 173 | (== `(,a1 . ,d1) t1^) 174 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 175 | (== #f subst^))) 176 | ;; symbol with var 177 | ((fresh (c1) 178 | (== `(var ,c1) t1^) 179 | (symbolo t2^) ;; t2^ is a literal symbol, not a var 180 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 181 | ((fresh (c2) 182 | (== `(var ,c2) t2^) 183 | (symbolo t1^) ;; t1^ is a literal symbol, not a var 184 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 185 | ;; ----- empty list ------- 186 | ;; empty list with empty list 187 | ((== '() t1^) (== '() t2^) (== subst subst^)) 188 | ;; empty list with symbol -- handled above 189 | ;; empty list with pair 190 | ((fresh (a2 d2) 191 | (== '() t1^) 192 | (== `(,a2 . ,d2) t2^) 193 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 194 | (== #f subst^))) 195 | ((fresh (a1 d1) 196 | (== '() t2^) 197 | (== `(,a1 . ,d1) t1^) 198 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 199 | (== #f subst^))) 200 | ;; empty list with var 201 | ((fresh (c1) 202 | (== `(var ,c1) t1^) 203 | (== '() t2^) 204 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 205 | ((fresh (c2) 206 | (== `(var ,c2) t2^) 207 | (== '() t1^) 208 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 209 | ;; ----- var ------- 210 | ;; var and var 211 | ((fresh (c1 c2) 212 | (== `(var ,c1) t1^) 213 | (== `(var ,c2) t2^) 214 | (conde 215 | ((== c1 c2) (== subst subst^)) 216 | ((=/= c1 c2) (== `(((var ,c1) . (var ,c2)) . ,subst) subst^))))) 217 | ;; var with symbol -- handled above 218 | ;; var with empty list -- handled above 219 | ;; var with pair 220 | ((fresh (c1 a2 d2) 221 | (== `(var ,c1) t1^) 222 | (== `(,a2 . ,d2) t2^) 223 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 224 | (conde 225 | ((== `(((var ,c1) . (,a2 . ,d2)) . ,subst) subst^) 226 | (not-occurso-complex t1^ t2^)) 227 | ((== #f subst^) 228 | (occurso-complex t1^ t2^))))) 229 | ((fresh (c2 a1 d1) 230 | (== `(var ,c2) t2^) 231 | (== `(,a1 . ,d1) t1^) 232 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 233 | (conde 234 | ((== `(((var ,c2) . (,a1 . ,d1)) . ,subst) subst^) 235 | (not-occurso-complex t2^ t1^)) 236 | ((== #f subst^) 237 | (occurso-complex t2^ t1^))))) 238 | ;; ----- pair ------- 239 | ;; pair with pair 240 | ((fresh (a1 d1 a2 d2 subst^^) 241 | (== `(,a1 . ,d1) t1^) 242 | (== `(,a2 . ,d2) t2^) 243 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 244 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 245 | (unifyo-complex a1 a2 subst subst^^) 246 | (conde 247 | ((== #f subst^^) 248 | (== #f subst^)) 249 | ((=/= #f subst^^) 250 | (unifyo-complex d1 d2 subst^^ subst^))))) 251 | ;; pair with symbol -- handled above 252 | ;; pair with empty list -- handled above 253 | ;; pair with var -- handled above 254 | ))) 255 | 256 | (define (occurso-complex x t) 257 | (fresh (c) 258 | (== `(var ,c) x) 259 | (conde 260 | ((== `(var ,c) t)) 261 | ((fresh (a d) 262 | (== `(,a . ,d) t) 263 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 264 | (conde 265 | ((occurso-complex x a)) 266 | ((not-occurso-complex x a) 267 | (occurso-complex x d)))))))) 268 | 269 | (define (not-occurso-complex x t) 270 | (fresh (c) 271 | (== `(var ,c) x) 272 | (conde 273 | ((symbolo t)) 274 | ((== '() t)) 275 | ((fresh (c^) 276 | (== `(var ,c^) t) 277 | (=/= c c^))) 278 | ((fresh (a d) 279 | (== `(,a . ,d) t) 280 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 281 | (not-occurso-complex x a) 282 | (not-occurso-complex x d)))))) 283 | 284 | (define (walko-complex t subst t^) 285 | (letrec ((walk-varo 286 | (lambda (t s t^) 287 | (conde 288 | ((== '() s) (== t t^)) 289 | ((fresh (c u rest) 290 | (== `(((var ,c) . ,u) . ,rest) s) 291 | (conde 292 | ((== `(var ,c) t) (walko-complex u subst t^)) 293 | ((=/= `(var ,c) t) (walk-varo t rest t^))))))))) 294 | (conde 295 | ((symbolo t) (== t t^)) 296 | ((== '() t) (== t t^)) 297 | ((fresh (a d) 298 | (== `(,a . ,d) t) 299 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 300 | (== t t^))) 301 | ((fresh (c) 302 | (== `(var ,c) t) 303 | (walk-varo t subst t^)))))) 304 | 305 | (define (walk*o-complex t subst t^) 306 | (fresh (t^^) 307 | (walko-complex t subst t^^) 308 | (conde 309 | ((symbolo t^^) (== t^^ t^)) 310 | ((== '() t^^) (== t^^ t^)) 311 | ((fresh (c) 312 | (== `(var ,c) t^^) 313 | (== t^^ t^))) 314 | ((fresh (a d a^ d^) 315 | (== `(,a . ,d) t^^) 316 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 317 | (== `(,a^ . ,d^) t^) 318 | (walk*o-complex a subst a^) 319 | (walk*o-complex d subst d^)))))) 320 | 321 | (define (map-walk*o-complex t $ out) 322 | (conde 323 | ((== '() $) (== '() out)) 324 | ((fresh (s c rest res t^) 325 | (== `((,s . ,c) . ,rest) $) 326 | (== `(,t^ . ,res) out) 327 | (walk*o-complex t s t^) 328 | (map-walk*o-complex t rest res))))) 329 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-combined/core-mk-simple-and-complex-tests.scm: -------------------------------------------------------------------------------- 1 | (load "../../faster-miniKanren/mk-vicare.scm") 2 | (load "../../faster-miniKanren/mk.scm") 3 | (load "../../faster-miniKanren/test-check.scm") 4 | (load "core-mk-simple.scm") 5 | (load "core-mk-complex.scm") 6 | 7 | (define (membero x ls) 8 | (fresh (y rest) 9 | (== `(,y . ,rest) ls) 10 | (conde 11 | ((== x y)) 12 | ((=/= x y) 13 | (membero x rest))))) 14 | 15 | ;; mko-simple tests 16 | (test "mko-simple backwards-2" 17 | (run 1 (e) 18 | (mko-simple e 'cat) 19 | (mko-simple e 'dog)) 20 | '(((run 1 (_.0) 21 | (conde 22 | ((== 'cat _.0)) 23 | ((== 'dog _.0)))) 24 | (sym _.0)))) 25 | 26 | (test "mko-simple forwards unclosed 0" 27 | (run 1 (expr) 28 | (fresh (e) 29 | (== `(run 1 (x) 30 | (conde 31 | ((== 'cat x)) 32 | ((conde 33 | ((== 'dog x)) 34 | ((== 'fish x)))))) 35 | expr) 36 | (mko-simple expr 'cat) 37 | (mko-simple expr 'dog))) 38 | '((run 1 (x) 39 | (conde 40 | ((== 'cat x)) 41 | ((conde ((== 'dog x)) ((== 'fish x)))))))) 42 | 43 | (test "mko-simple forwards unclosed 1" 44 | (run 1 (expr) 45 | (fresh (e) 46 | (== `(run 1 (x) 47 | (conde 48 | ((== 'cat x)) 49 | ((conde 50 | ((== 'dog x)) 51 | (,e))))) 52 | expr) 53 | (mko-simple expr 'cat) 54 | (mko-simple expr 'dog))) 55 | '((run 1 (x) 56 | (conde 57 | ((== 'cat x)) 58 | ((conde 59 | ((== 'dog x)) 60 | (_.0))))))) 61 | 62 | 63 | ;; mko-complex tests 64 | #| 65 | ;; too slow to run! 66 | (test "mko-complex backwards-2" 67 | (run 1 (e) (mko-complex e '(cat dog))) 68 | '???) 69 | |# 70 | 71 | (test "mko-complex forwards unclosed 0a" 72 | (run* (expr) 73 | (fresh (e) 74 | (== `(run* (x) 75 | (conde 76 | ((== 'cat x)) 77 | ((conde 78 | ((== 'dog x)) 79 | ((== 'fish x)))))) 80 | expr) 81 | (mko-complex expr '(cat dog fish)))) 82 | '((run* (x) 83 | (conde 84 | ((== (quote cat) x)) 85 | ((conde 86 | ((== (quote dog) x)) 87 | ((== (quote fish) x)))))))) 88 | 89 | (test "mko-complex forwards unclosed 0b" 90 | (run* (expr) 91 | (fresh (e) 92 | (== `(run* (x) 93 | (conde 94 | ((== 'cat x)) 95 | ((conde 96 | ((== 'dog x)) 97 | ((== 'fish x)))))) 98 | expr) 99 | (mko-complex expr '(cat dog)))) 100 | '()) 101 | 102 | (test "mko-complex forwards unclosed 1a" 103 | (run 1 (expr) 104 | (fresh (e) 105 | (== `(run* (x) 106 | (conde 107 | ((== 'cat x)) 108 | ((conde 109 | ((== 'dog x)) 110 | (,e))))) 111 | expr) 112 | (mko-complex expr '(cat dog fish)))) 113 | '((run* (x) 114 | (conde 115 | ((== 'cat x)) 116 | ((conde 117 | ((== 'dog x)) 118 | ((== 'fish x)))))))) 119 | 120 | (test "mko-complex forwards unclosed 1b" 121 | (run 1 (expr) 122 | (fresh (e) 123 | (== `(run* (x) 124 | (conde 125 | ((== 'cat x)) 126 | ((conde 127 | ((== 'dog x)) 128 | (,e))))) 129 | expr) 130 | (mko-complex expr '(cat dog)))) 131 | '(((run* (x) 132 | (conde 133 | ((== 'cat x)) 134 | ((conde 135 | ((== 'dog x)) 136 | ((== '_.0 '_.1)))))) 137 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var))) 138 | (sym _.0 _.1)))) 139 | 140 | 141 | 142 | ;; combined mko-simple and mko-complex closed tests 143 | (test "mko-simple and mko-complex combined tests 1a" 144 | (run 1 (e) 145 | (fresh (simple-expr complex-expr) 146 | (== `(run 1 (x) ,e) simple-expr) 147 | (== `(run* (x) ,e) complex-expr) 148 | (mko-simple simple-expr 'cat) 149 | (mko-simple simple-expr 'dog) 150 | (mko-complex complex-expr '(cat dog)))) 151 | '((conde 152 | ((== 'cat x)) 153 | ((== 'dog x))))) 154 | 155 | ;; thanks for the test, Nada! 156 | (test "mko-simple and mko-complex combined tests 1b" 157 | (run 1 (e) 158 | (fresh (simple-expr complex-expr) 159 | (== `(run 1 (x) ,e) simple-expr) 160 | (== `(run* (x) ,e) complex-expr) 161 | (mko-simple simple-expr 'dog) 162 | (mko-simple simple-expr 'cat) 163 | (mko-complex complex-expr '(cat dog)))) 164 | '((conde 165 | ((== 'cat x)) 166 | ((== 'dog x))))) 167 | 168 | (test "mko-simple and mko-complex combined tests 1c" 169 | (run 1 (ge) 170 | (fresh (simple-expr complex-expr) 171 | (== `(run 1 (x) ,ge) simple-expr) 172 | (== `(run* (x) ,ge) complex-expr) 173 | (mko-simple simple-expr 'cat) 174 | (mko-simple simple-expr 'dog) 175 | (mko-complex complex-expr '(dog cat)))) 176 | '((conde 177 | ((== 'dog x)) 178 | ((== 'cat x))))) 179 | 180 | (test "mko-simple and mko-complex combined tests 1d" 181 | (run 5 (ge) 182 | (fresh (simple-expr complex-expr l e1 e2) 183 | (== `(run 1 (x) ,ge) simple-expr) 184 | (== `(run* (x) ,ge) complex-expr) 185 | (mko-simple simple-expr 'cat) 186 | (mko-simple simple-expr 'dog) 187 | (== (list e1 e2) l) 188 | (membero 'cat l) 189 | (membero 'dog l) 190 | (mko-complex complex-expr l))) 191 | '((conde 192 | ((== 'cat x)) 193 | ((== 'dog x))) 194 | (conde 195 | ((== 'cat x)) 196 | ((== x 'dog))) 197 | (conde 198 | ((== 'dog x)) 199 | ((== 'cat x))) 200 | (conde 201 | ((== x 'dog)) 202 | ((== 'cat x))) 203 | ((conde 204 | ((== 'cat x)) 205 | ((fresh (_.0) 206 | (== 'dog x)))) 207 | (=/= ((_.0 x))) 208 | (sym _.0)))) 209 | 210 | (test "mko-simple and mko-complex combined tests 1e" 211 | ;; no membero needed! 212 | (run 5 (e) 213 | (fresh (simple-expr complex-expr l e1 e2) 214 | (== `(run 1 (x) ,e) simple-expr) 215 | (== `(run* (x) ,e) complex-expr) 216 | (mko-simple simple-expr 'cat) 217 | (mko-simple simple-expr 'dog) 218 | (== (list e1 e2) l) 219 | (mko-complex complex-expr l))) 220 | '((conde 221 | ((== 'cat x)) 222 | ((== 'dog x))) 223 | (conde 224 | ((== 'cat x)) 225 | ((== x 'dog))) 226 | (conde 227 | ((== 'dog x)) 228 | ((== 'cat x))) 229 | (conde 230 | ((== x 'dog)) 231 | ((== 'cat x))) 232 | ((conde 233 | ((== 'cat x)) 234 | ((fresh (_.0) 235 | (== 'dog x)))) 236 | (=/= ((_.0 x))) 237 | (sym _.0)))) 238 | 239 | (test "mko-simple and mko-complex combined tests 1f" 240 | (run 5 (e) 241 | (fresh (simple-expr complex-expr l e1 e2) 242 | (== `(run 1 (x) ,e) simple-expr) 243 | (== `(run* (x) ,e) complex-expr) 244 | (=/= e1 e2) 245 | (mko-simple simple-expr e1) 246 | (mko-simple simple-expr e2) 247 | (== (list e1 e2) l) 248 | (mko-complex complex-expr l))) 249 | '(((conde 250 | ((== '_.0 '_.0)) 251 | ((== '_.1 x))) 252 | (=/= ((_.0 var)) ((_.1 var))) 253 | (sym _.0 _.1)) 254 | ((conde 255 | ((== '_.0 '_.0)) 256 | ((== x '_.1))) 257 | (=/= ((_.0 var)) ((_.1 var))) 258 | (sym _.0 _.1)) 259 | ((conde 260 | ((== '_.0 '_.0)) 261 | ((== '() x))) 262 | (=/= ((_.0 var))) 263 | (sym _.0)) 264 | ((conde 265 | ((== '_.0 '_.0)) 266 | ((== '(_.1 . _.2) x))) 267 | (=/= ((_.0 var)) ((_.1 var)) ((_.2 var))) 268 | (sym _.0 _.1 _.2)) 269 | ((conde 270 | ((== '_.0 '_.0)) 271 | ((== '(_.1) x))) 272 | (=/= ((_.0 var)) ((_.1 var))) 273 | (sym _.0 _.1)))) 274 | 275 | (test "mko-simple and mko-complex combined tests 1g" 276 | (run 5 (e) 277 | (fresh (simple-expr complex-expr l e1 e2) 278 | (== `(run 1 (x) ,e) simple-expr) 279 | (== `(run* (x) ,e) complex-expr) 280 | (symbolo e1) 281 | (symbolo e2) 282 | (=/= e1 e2) 283 | (mko-simple simple-expr e1) 284 | (mko-simple simple-expr e2) 285 | (== (list e1 e2) l) 286 | (mko-complex complex-expr l))) 287 | '(((conde 288 | ((== '_.0 x)) 289 | ((== '_.1 x))) 290 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var))) 291 | (sym _.0 _.1)) 292 | ((conde 293 | ((== '_.0 x)) 294 | ((== x '_.1))) 295 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var))) 296 | (sym _.0 _.1)) 297 | ((conde 298 | ((== '_.0 x)) 299 | ((fresh (_.1) 300 | (== '_.2 x)))) 301 | (=/= ((_.0 _.2)) ((_.0 var)) ((_.1 x)) ((_.2 var))) 302 | (sym _.0 _.1 _.2)) 303 | ((conde 304 | ((== '_.0 x)) 305 | ((conde 306 | ((== '_.1 x)) 307 | ((== '_.2 '_.3))))) 308 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var)) ((_.2 _.3)) 309 | ((_.2 var)) ((_.3 var))) 310 | (sym _.0 _.1 _.2 _.3)) 311 | ((conde 312 | ((== '_.0 x)) 313 | ((conde 314 | ((== '_.1 x)) 315 | ((== '_.2 '()))))) 316 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var)) ((_.2 var))) 317 | (sym _.0 _.1 _.2)))) 318 | 319 | (test "mko-simple and mko-complex combined tests 1h" 320 | (run 5 (e) 321 | (fresh (simple-expr complex-expr l e1 e2 e3) 322 | (== `(run 1 (x) ,e) simple-expr) 323 | (== `(run* (x) ,e) complex-expr) 324 | (mko-simple simple-expr 'cat) 325 | (mko-simple simple-expr 'dog) 326 | (=/= e1 e2) 327 | (=/= e1 e3) 328 | (=/= e2 e3) 329 | (symbolo e3) 330 | (mko-simple simple-expr e3) 331 | (== (list e1 e2 e3) l) 332 | (mko-complex complex-expr l))) 333 | '(((conde 334 | ((== 'cat x)) 335 | ((conde 336 | ((== 'dog x)) 337 | ((== '_.0 x))))) 338 | (=/= ((_.0 cat)) ((_.0 dog)) ((_.0 var))) 339 | (sym _.0)) 340 | ((conde 341 | ((== 'cat x)) 342 | ((conde 343 | ((== '_.0 '_.0)) 344 | ((== 'dog x))))) 345 | (=/= ((_.0 var))) 346 | (sym _.0)) 347 | ((conde 348 | ((== 'cat x)) 349 | ((conde 350 | ((== 'dog x)) 351 | ((== x '_.0))))) 352 | (=/= ((_.0 cat)) ((_.0 dog)) ((_.0 var))) 353 | (sym _.0)) 354 | ((conde 355 | ((== 'cat x)) 356 | ((conde 357 | ((fresh (_.0) 358 | (== '_.1 '_.1))) 359 | ((== 'dog x))))) 360 | (=/= ((_.1 var))) 361 | (sym _.0 _.1)) 362 | (conde 363 | ((== 'cat x)) 364 | ((conde 365 | ((== '() '())) 366 | ((== 'dog x))))))) 367 | 368 | (test "mko-simple and mko-complex combined tests 2" 369 | (run 1 (e) 370 | (fresh (simple-expr complex-expr) 371 | (== `(run 1 (x) ,e) simple-expr) 372 | (== `(run* (x) ,e) complex-expr) 373 | (== '(conde 374 | ((== 'cat x)) 375 | ((== 'dog x))) 376 | e) 377 | (mko-simple simple-expr 'cat) 378 | (mko-simple simple-expr 'dog) 379 | (mko-complex complex-expr '(cat dog)))) 380 | '((conde 381 | ((== (quote cat) x)) 382 | ((== (quote dog) x))))) 383 | 384 | (test "mko-simple and mko-complex combined tests 3" 385 | (run 1 (e) 386 | (fresh (simple-expr complex-expr) 387 | (== `(run 1 (x) ,e) simple-expr) 388 | (== `(run* (x) ,e) complex-expr) 389 | (== '(conde 390 | ((== 'cat x)) 391 | ((conde 392 | ((== 'dog x)) 393 | ((== 'fish x))))) 394 | e) 395 | (mko-simple simple-expr 'cat) 396 | (mko-simple simple-expr 'dog) 397 | (mko-complex complex-expr '(cat dog)))) 398 | '()) 399 | 400 | (test "mko-simple and mko-complex combined tests 4" 401 | (run 1 (e) 402 | (fresh (simple-expr complex-expr) 403 | (== `(run 1 (x) ,e) simple-expr) 404 | (== `(run* (x) ,e) complex-expr) 405 | (== '(conde 406 | ((== 'cat x)) 407 | ((conde 408 | ((== 'dog x)) 409 | ((== 'fish 'bat))))) 410 | e) 411 | (mko-simple simple-expr 'cat) 412 | (mko-simple simple-expr 'dog) 413 | (mko-complex complex-expr '(cat dog)))) 414 | '((conde 415 | ((== 'cat x)) 416 | ((conde 417 | ((== 'dog x)) 418 | ((== 'fish 'bat))))))) 419 | 420 | (test "mko-simple and mko-complex combined tests 5" 421 | (run 1 (e) 422 | (fresh (simple-expr complex-expr) 423 | (== `(run 1 (x) ,e) simple-expr) 424 | (== `(run* (x) ,e) complex-expr) 425 | (mko-simple simple-expr 'cat) 426 | (mko-simple simple-expr 'dog) 427 | (mko-simple simple-expr 'fish) 428 | (mko-complex complex-expr '(cat dog fish)))) 429 | '((conde 430 | ((== 'cat x)) 431 | ((conde 432 | ((== 'dog x)) 433 | ((== 'fish x))))))) 434 | 435 | (test "mko-simple and mko-complex combined tests 6a" 436 | (run 1 (e) 437 | (fresh (simple-expr complex-expr) 438 | (== `(run 1 (x) ,e) simple-expr) 439 | (== `(run* (x) ,e) complex-expr) 440 | (fresh (e^) 441 | (== `(conde 442 | ((== 'cat x)) 443 | ((conde 444 | ((== 'dog x)) 445 | (,e^)))) 446 | e)) 447 | (mko-simple simple-expr 'cat) 448 | (mko-simple simple-expr 'dog) 449 | (mko-complex complex-expr '(cat dog)))) 450 | '(((conde 451 | ((== 'cat x)) 452 | ((conde 453 | ((== 'dog x)) 454 | ((== '_.0 '_.1))))) 455 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var))) 456 | (sym _.0 _.1)))) 457 | 458 | (test "mko-simple and mko-complex combined tests 6b" 459 | (run 1 (ge) 460 | (fresh (simple-expr complex-expr) 461 | (== `(run 1 (x) ,ge) simple-expr) 462 | (== `(run* (x) ,ge) complex-expr) 463 | (fresh (ge^) 464 | (== `(conde 465 | ((== 'cat x)) 466 | ((conde 467 | ((== 'dog x)) 468 | (,ge^)))) 469 | ge)) 470 | (mko-simple simple-expr 'dog) 471 | (mko-simple simple-expr 'cat) 472 | (mko-complex complex-expr '(cat dog)))) 473 | '(((conde 474 | ((== 'cat x)) 475 | ((conde 476 | ((== 'dog x)) 477 | ((== '_.0 '_.1))))) 478 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var))) 479 | (sym _.0 _.1)))) 480 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-combined/core-mk-simple.scm: -------------------------------------------------------------------------------- 1 | ;;; Code from `core-mk-explicit-unification` 2 | 3 | ;; Relational environment-passing, substitution-passing interpreter 4 | ;; for a subset of miniKanren, written in miniKanren. 5 | ;; 6 | ;; The `mko` driver relation simulates non-deterministic evaluation of 7 | ;; a `run 1` expression (not a `run*` expression!), as a single value 8 | ;; is associated with the query variable upon success. 9 | ;; 10 | ;; In order to simulate full `run*` behavior, I think it would be 11 | ;; necessary to implement the notions of success and failure 12 | ;; explicitly. This implementation represents failure metacircularly, 13 | ;; as failure at the host-level miniKanren. Similarly, this 14 | ;; interpreter represents `conde` and the miniKanren search 15 | ;; metacircularly, using the host `conde`. There seems to be tradeoff 16 | ;; in expressiveness vs. convenience: this interpreter can't express 17 | ;; that a miniKanren program *doesn't* produce a certain answer, for 18 | ;; example. Also, this interpreter can't be used to reason about 19 | ;; setof/bagof-style 2nd order relations, since the "collected" answers 20 | ;; are collected through the host `run`, rather than through a `run*` 21 | ;; in the object miniKanren. Indeed, the object `run` can only express 22 | ;; (non-deterministic) `run 1` semantics, rather than `run*` semantics. 23 | 24 | #| 25 | Grammar: 26 | 27 | ;; run 1 expression 28 | run1-expr ::= (run 1 () ) 29 | 30 | ;; goal expression 31 | ::= (== ) | 32 | (fresh () ) | 33 | (fresh () ) | 34 | (conde () ()) 35 | 36 | ;; Scheme expression 37 | ::= | 38 | (quote ) | 39 | (cons ) 40 | 41 | ;; Scheme lexical variable 42 | ::= 43 | 44 | ;; quoted datum 45 | ::= | 46 | () | 47 | ( . ) 48 | |# 49 | 50 | ;; Logic variables are represented as tagged lists of the form `(var ,c)` 51 | ;; where `c` is a Peano numeral of the form `z`, `(s z)`, `(s (s z))`, etc. 52 | ;; Logic variables that remain fresh are reified as themselves, rather than 53 | ;; being replaced with `_.0`, `_.1`, etc. 54 | 55 | 56 | ;; TODO: 57 | ;; 58 | ;; Think about reification of fresh logic variables--should it work 59 | ;; like in regular mk, by using some kind of fake subst? If so, would 60 | ;; you be able to tell whether '_.0' came from miniKanren, or the 61 | ;; language being interpreted? 62 | ;; 63 | ;; Support =/=, symbolo, numbero, and absento 64 | ;; 65 | ;; Support helpers and recursion 66 | 67 | (define mko-simple 68 | (lambda (expr out) 69 | (fresh (q ge count^ subst^) 70 | (== `(run 1 (,q) ,ge) expr) 71 | (symbolo q) 72 | (eval-mko-simple ge `((,q . (var z))) `(s z) count^ '() subst^) 73 | (walk*o-simple `(var z) subst^ out)))) 74 | 75 | (define eval-mko-simple 76 | (lambda (expr env count count^ subst subst^) 77 | (conde 78 | ((fresh (e1 e2 t1 t2) 79 | (== `(== ,e1 ,e2) expr) 80 | (evalo-simple e1 env t1) 81 | (evalo-simple e2 env t2) 82 | (unifyo-simple t1 t2 subst subst^))) 83 | ((fresh (x ge subst^^) 84 | (== `(fresh (,x) ,ge) expr) 85 | (symbolo x) 86 | (eval-mko-simple ge `((,x . (var ,count)) . ,env) `(s ,count) count^ subst subst^))) 87 | ((fresh (x ge1 ge2 count^^ subst^^) 88 | (== `(fresh (,x) ,ge1 ,ge2) expr) 89 | (symbolo x) 90 | (eval-mko-simple ge1 `((,x . (var ,count)) . ,env) `(s ,count) count^^ subst subst^^) 91 | (eval-mko-simple ge2 `((,x . (var ,count)) . ,env) count^^ count^ subst^^ subst^))) 92 | ((fresh (ge1 ge2) 93 | (== `(conde (,ge1) (,ge2)) expr) 94 | (conde 95 | ((eval-mko-simple ge1 env count count^ subst subst^)) 96 | ((eval-mko-simple ge2 env count count^ subst subst^)))))))) 97 | 98 | (define evalo-simple 99 | (lambda (expr env val) 100 | (conde 101 | ((== `(quote ,val) expr) 102 | (absento 'var val)) 103 | ((symbolo expr) (lookupo-simple expr env val)) 104 | ((fresh (e1 e2 v1 v2) 105 | (== `(cons ,e1 ,e2) expr) 106 | (== `(,v1 . ,v2) val) 107 | (evalo-simple e1 env v1) 108 | (evalo-simple e2 env v2)))))) 109 | 110 | (define lookupo-simple 111 | (lambda (x env val) 112 | (fresh (y v rest) 113 | (== `((,y . ,v) . ,rest) env) 114 | (conde 115 | ((== x y) (== v val)) 116 | ((=/= x y) 117 | (lookupo-simple x rest val)))))) 118 | 119 | (define unifyo-simple 120 | (lambda (t1 t2 subst subst^) 121 | (fresh (t1^ t2^) 122 | (walko-simple t1 subst t1^) 123 | (walko-simple t2 subst t2^) 124 | (conde 125 | ((symbolo t1^) (symbolo t2^) (== t1^ t2^) (== subst subst^)) 126 | ((== '() t1^) (== '() t2^) (== subst subst^)) 127 | ((fresh (c1 c2) 128 | (== `(var ,c1) t1^) 129 | (== `(var ,c2) t2^) 130 | (conde 131 | ((== c1 c2) (== subst subst^)) 132 | ((=/= c1 c2) (== `(((var ,c1) . (var ,c2)) . ,subst) subst^))))) 133 | ((fresh (c1) 134 | (== `(var ,c1) t1^) 135 | (symbolo t2^) ;; t2^ is a literal symbol, not a var 136 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 137 | ((fresh (c2) 138 | (== `(var ,c2) t2^) 139 | (symbolo t1^) ;; t1^ is a literal symbol, not a var 140 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 141 | ((fresh (c1) 142 | (== `(var ,c1) t1^) 143 | (== '() t2^) 144 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 145 | ((fresh (c2) 146 | (== `(var ,c2) t2^) 147 | (== '() t1^) 148 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 149 | ((fresh (c1 a2 d2) 150 | (== `(var ,c1) t1^) 151 | (== `(,a2 . ,d2) t2^) 152 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 153 | (== `(((var ,c1) . (,a2 . ,d2)) . ,subst) subst^) 154 | (absento t1^ t2^) ;; use absento to implement the occurs check 155 | )) 156 | ((fresh (c2 a1 d1) 157 | (== `(var ,c2) t2^) 158 | (== `(,a1 . ,d1) t1^) 159 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 160 | (== `(((var ,c2) . (,a1 . ,d1)) . ,subst) subst^) 161 | (absento t2^ t1^) ;; use absento to implement the occurs check 162 | )) 163 | ((fresh (a1 d1 a2 d2 subst^^) 164 | (== `(,a1 . ,d1) t1^) 165 | (== `(,a2 . ,d2) t2^) 166 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 167 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 168 | (unifyo-simple a1 a2 subst subst^^) 169 | (unifyo-simple d1 d2 subst^^ subst^))))))) 170 | 171 | (define walko-simple 172 | (lambda (t subst t^) 173 | (letrec ((walk-varo 174 | (lambda (t s t^) 175 | (conde 176 | ((== '() s) (== t t^)) 177 | ((fresh (c u rest) 178 | (== `(((var ,c) . ,u) . ,rest) s) 179 | (conde 180 | ((== `(var ,c) t) (walko-simple u subst t^)) 181 | ((=/= `(var ,c) t) (walk-varo t rest t^))))))))) 182 | (conde 183 | ((symbolo t) (== t t^)) 184 | ((== '() t) (== t t^)) 185 | ((fresh (a d) 186 | (== `(,a . ,d) t) 187 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 188 | (== t t^))) 189 | ((fresh (c) 190 | (== `(var ,c) t) 191 | (walk-varo t subst t^))))))) 192 | 193 | (define walk*o-simple 194 | (lambda (t subst t^) 195 | (fresh (t^^) 196 | (walko-simple t subst t^^) 197 | (conde 198 | ((symbolo t^^) (== t^^ t^)) 199 | ((== '() t^^) (== t^^ t^)) 200 | ((fresh (c) 201 | (== `(var ,c) t^^) 202 | (== t^^ t^))) 203 | ((fresh (a d a^ d^) 204 | (== `(,a . ,d) t^^) 205 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 206 | (== `(,a^ . ,d^) t^) 207 | (walk*o-simple a subst a^) 208 | (walk*o-simple d subst d^))))))) 209 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-explicit-unification-failure-streams/core-mk-explicit-unification-failure-streams.scm: -------------------------------------------------------------------------------- 1 | (load "../../faster-miniKanren/mk-vicare.scm") 2 | (load "../../faster-miniKanren/mk.scm") 3 | 4 | ;; Relational environment-passing, substitution-passing interpreter 5 | ;; for a subset of miniKanren, written in miniKanren. 6 | ;; 7 | ;; This version of the interpreter explicitly represents failure, in 8 | ;; addition to success, and explicitly represents streams. 9 | 10 | #| 11 | Grammar: 12 | 13 | ;; run* expression 14 | run1-expr ::= (run* () ) 15 | 16 | ;; goal expression 17 | ::= (== ) | 18 | (fresh () ) | 19 | (fresh () ) | 20 | (conde () ()) 21 | 22 | ;; Scheme expression 23 | ::= | 24 | (quote ) | 25 | (cons ) 26 | 27 | ;; Scheme lexical variable 28 | ::= 29 | 30 | ;; quoted datum 31 | ::= | 32 | () | 33 | ( . ) 34 | |# 35 | 36 | ;; Logic variables are represented as tagged lists of the form `(var ,c)` 37 | ;; where `c` is a Peano numeral of the form `z`, `(s z)`, `(s (s z))`, etc. 38 | ;; Logic variables that remain fresh are reified as themselves, rather than 39 | ;; being replaced with `_.0`, `_.1`, etc. 40 | 41 | 42 | ;; TODO: 43 | ;; 44 | ;; Think about reification of fresh logic variables--should it work 45 | ;; like in regular mk, by using some kind of fake subst? If so, would 46 | ;; you be able to tell whether '_.0' came from miniKanren, or the 47 | ;; language being interpreted? 48 | ;; 49 | ;; Support =/=, symbolo, numbero, and absento 50 | ;; 51 | ;; Support helpers and recursion 52 | 53 | (define mzero '()) 54 | (define (unit s/c) (cons s/c mzero)) 55 | 56 | (define (mko expr out) 57 | (fresh (q ge $) 58 | (== `(run* (,q) ,ge) expr) 59 | (symbolo q) 60 | (eval-mko 61 | ;; goal expression 62 | ge 63 | ;; initial env 64 | `((,q . (var z))) 65 | ;; initial s/c 66 | '(() . (s z)) 67 | ;; resulting stream of s/c's 68 | $) 69 | (map-walk*o `(var z) $ out))) 70 | 71 | (define (eval-mko expr env s/c $) 72 | (conde 73 | ((fresh (e1 e2 t1 t2 s s^ c) 74 | (== `(== ,e1 ,e2) expr) 75 | (== `(,s . ,c) s/c) 76 | (evalo e1 env t1) 77 | (evalo e2 env t2) 78 | (conde 79 | ((== #f s^) (== mzero $)) 80 | ((=/= #f s^) (== (unit `(,s^ . (s ,c))) $))) 81 | (unifyo t1 t2 s s^))) 82 | ((fresh (x ge s c) 83 | (== `(fresh (,x) ,ge) expr) 84 | (symbolo x) 85 | (== `(,s . ,c) s/c) 86 | (eval-mko ge `((,x . (var ,c)) . ,env) `(,s . (s ,c)) $))) 87 | ((fresh (x ge1 ge2 env^ s c $^) 88 | (== `(fresh (,x) ,ge1 ,ge2) expr) 89 | (symbolo x) 90 | (== `(,s . ,c) s/c) 91 | (== `((,x . (var ,c)) . ,env) env^) 92 | (eval-mko ge1 env^ `(,s . (s ,c)) $^) 93 | (bindo $^ ge2 env^ $))) 94 | ((fresh (ge1 ge2 $1 $2) 95 | (== `(conde (,ge1) (,ge2)) expr) 96 | (eval-mko ge1 env s/c $1) 97 | (eval-mko ge2 env s/c $2) 98 | (mpluso $1 $2 $))))) 99 | 100 | (define (mpluso $1 $2 $^) 101 | (conde 102 | ((== '() $1) (== $2 $^)) 103 | ;; 104 | ;; no procedure/delayed clause 105 | ;; 106 | ;; TODO: do we need the procedure/delayed clause? If so, how to 107 | ;; implement it? Using `evalo`? 108 | ;; 109 | ((fresh (a d res) 110 | (== `(,a . ,d) $1) 111 | (== `(,a . ,res) $^) 112 | (mpluso d $2 res))))) 113 | 114 | (define (bindo $ g env $^) 115 | (conde 116 | ((== '() $) (== mzero $^)) 117 | ;; 118 | ;; no procedure/delayed clause 119 | ;; 120 | ;; TODO: do we need the procedure/delayed clause? If so, how to 121 | ;; implement it? Using `evalo`? 122 | ;; 123 | ((fresh (a d $1^ $2^) 124 | (== `(,a . ,d) $) 125 | ;; we need to use `eval-mko`, which takes `env`, 126 | ;; to keep everything relational 127 | (eval-mko g env a $1^) 128 | (bindo d g env $2^) 129 | (mpluso $1^ $2^ $^))))) 130 | 131 | (define (evalo expr env val) 132 | (conde 133 | ((== `(quote ,val) expr) 134 | (absento 'var val)) 135 | ((symbolo expr) (lookupo expr env val)) 136 | ((fresh (e1 e2 v1 v2) 137 | (== `(cons ,e1 ,e2) expr) 138 | (== `(,v1 . ,v2) val) 139 | (evalo e1 env v1) 140 | (evalo e2 env v2))))) 141 | 142 | (define (lookupo x env val) 143 | (fresh (y v rest) 144 | (== `((,y . ,v) . ,rest) env) 145 | (conde 146 | ((== x y) (== v val)) 147 | ((=/= x y) 148 | (lookupo x rest val))))) 149 | 150 | (define (unifyo t1 t2 subst subst^) 151 | (fresh (t1^ t2^) 152 | (walko t1 subst t1^) 153 | (walko t2 subst t2^) 154 | (conde 155 | ;; ----- symbols ------- 156 | ;; symbol with symbol 157 | ((symbolo t1^) (symbolo t2^) 158 | (conde 159 | ((== t1^ t2^) (== subst subst^)) 160 | ((=/= t1^ t2^) (== #f subst^)))) 161 | ;; symbol with empty list 162 | ((symbolo t1^) (== '() t2^) 163 | (== #f subst^)) 164 | ((symbolo t2^) (== '() t1^) 165 | (== #f subst^)) 166 | ;; symbol with pair 167 | ((fresh (a2 d2) 168 | (symbolo t1^) 169 | (== `(,a2 . ,d2) t2^) 170 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 171 | (== #f subst^))) 172 | ((fresh (a1 d1) 173 | (symbolo t2^) 174 | (== `(,a1 . ,d1) t1^) 175 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 176 | (== #f subst^))) 177 | ;; symbol with var 178 | ((fresh (c1) 179 | (== `(var ,c1) t1^) 180 | (symbolo t2^) ;; t2^ is a literal symbol, not a var 181 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 182 | ((fresh (c2) 183 | (== `(var ,c2) t2^) 184 | (symbolo t1^) ;; t1^ is a literal symbol, not a var 185 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 186 | ;; ----- empty list ------- 187 | ;; empty list with empty list 188 | ((== '() t1^) (== '() t2^) (== subst subst^)) 189 | ;; empty list with symbol -- handled above 190 | ;; empty list with pair 191 | ((fresh (a2 d2) 192 | (== '() t1^) 193 | (== `(,a2 . ,d2) t2^) 194 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 195 | (== #f subst^))) 196 | ((fresh (a1 d1) 197 | (== '() t2^) 198 | (== `(,a1 . ,d1) t1^) 199 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 200 | (== #f subst^))) 201 | ;; empty list with var 202 | ((fresh (c1) 203 | (== `(var ,c1) t1^) 204 | (== '() t2^) 205 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 206 | ((fresh (c2) 207 | (== `(var ,c2) t2^) 208 | (== '() t1^) 209 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 210 | ;; ----- var ------- 211 | ;; var and var 212 | ((fresh (c1 c2) 213 | (== `(var ,c1) t1^) 214 | (== `(var ,c2) t2^) 215 | (conde 216 | ((== c1 c2) (== subst subst^)) 217 | ((=/= c1 c2) (== `(((var ,c1) . (var ,c2)) . ,subst) subst^))))) 218 | ;; var with symbol -- handled above 219 | ;; var with empty list -- handled above 220 | ;; var with pair 221 | ((fresh (c1 a2 d2) 222 | (== `(var ,c1) t1^) 223 | (== `(,a2 . ,d2) t2^) 224 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 225 | (conde 226 | ((== `(((var ,c1) . (,a2 . ,d2)) . ,subst) subst^) 227 | (not-occurso t1^ t2^)) 228 | ((== #f subst^) 229 | (occurso t1^ t2^))))) 230 | ((fresh (c2 a1 d1) 231 | (== `(var ,c2) t2^) 232 | (== `(,a1 . ,d1) t1^) 233 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 234 | (conde 235 | ((== `(((var ,c2) . (,a1 . ,d1)) . ,subst) subst^) 236 | (not-occurso t2^ t1^)) 237 | ((== #f subst^) 238 | (occurso t2^ t1^))))) 239 | ;; ----- pair ------- 240 | ;; pair with pair 241 | ((fresh (a1 d1 a2 d2 subst^^) 242 | (== `(,a1 . ,d1) t1^) 243 | (== `(,a2 . ,d2) t2^) 244 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 245 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 246 | (unifyo a1 a2 subst subst^^) 247 | (conde 248 | ((== #f subst^^) 249 | (== #f subst^)) 250 | ((=/= #f subst^^) 251 | (unifyo d1 d2 subst^^ subst^))))) 252 | ;; pair with symbol -- handled above 253 | ;; pair with empty list -- handled above 254 | ;; pair with var -- handled above 255 | ))) 256 | 257 | (define (occurso x t) 258 | (fresh (c) 259 | (== `(var ,c) x) 260 | (conde 261 | ((== `(var ,c) t)) 262 | ((fresh (a d) 263 | (== `(,a . ,d) t) 264 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 265 | (conde 266 | ((occurso x a)) 267 | ((not-occurso x a) 268 | (occurso x d)))))))) 269 | 270 | (define (not-occurso x t) 271 | (fresh (c) 272 | (== `(var ,c) x) 273 | (conde 274 | ((symbolo t)) 275 | ((== '() t)) 276 | ((fresh (c^) 277 | (== `(var ,c^) t) 278 | (=/= c c^))) 279 | ((fresh (a d) 280 | (== `(,a . ,d) t) 281 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 282 | (not-occurso x a) 283 | (not-occurso x d)))))) 284 | 285 | (define (walko t subst t^) 286 | (letrec ((walk-varo 287 | (lambda (t s t^) 288 | (conde 289 | ((== '() s) (== t t^)) 290 | ((fresh (c u rest) 291 | (== `(((var ,c) . ,u) . ,rest) s) 292 | (conde 293 | ((== `(var ,c) t) (walko u subst t^)) 294 | ((=/= `(var ,c) t) (walk-varo t rest t^))))))))) 295 | (conde 296 | ((symbolo t) (== t t^)) 297 | ((== '() t) (== t t^)) 298 | ((fresh (a d) 299 | (== `(,a . ,d) t) 300 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 301 | (== t t^))) 302 | ((fresh (c) 303 | (== `(var ,c) t) 304 | (walk-varo t subst t^)))))) 305 | 306 | (define (walk*o t subst t^) 307 | (fresh (t^^) 308 | (walko t subst t^^) 309 | (conde 310 | ((symbolo t^^) (== t^^ t^)) 311 | ((== '() t^^) (== t^^ t^)) 312 | ((fresh (c) 313 | (== `(var ,c) t^^) 314 | (== t^^ t^))) 315 | ((fresh (a d a^ d^) 316 | (== `(,a . ,d) t^^) 317 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 318 | (== `(,a^ . ,d^) t^) 319 | (walk*o a subst a^) 320 | (walk*o d subst d^)))))) 321 | 322 | (define (map-walk*o t $ out) 323 | (conde 324 | ((== '() $) (== '() out)) 325 | ((fresh (s c rest res t^) 326 | (== `((,s . ,c) . ,rest) $) 327 | (== `(,t^ . ,res) out) 328 | (walk*o t s t^) 329 | (map-walk*o t rest res))))) 330 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-explicit-unification-failure-streams/notes.txt: -------------------------------------------------------------------------------- 1 | I implemented 3 interps on Sunday night (18 October 02020), with varying levels of metacircularity. 2 | 3 | The most complex one (in this directory) is microKanren-ish: it uses bind and mplus, but currently doesn't support inc. 4 | The complex version implements run* semantics, and associates an expression with a list of values. 5 | 6 | The simplest interpreter is much more metacircular--it implements conde using conde, for example. 7 | 8 | I use tagged peano numerals to represent logic variables in all three versions and use explicit environments and substitutions 9 | 10 | The simplest interpreter only can express successful unification--it uses absento to implement the occurs check. 11 | 12 | The most complicated version can express unification succeeding or failing, and the occur check succeeding or failing. 13 | 14 | The simple version implements a non-deterministic run 1 semantics. That is, it associates an expression with *one* value that might be produced from a run 1, were conde to be non-deterministic. This version can express that the miniKanren expression must produce an answer, but can't express that no other answers may be returned. 15 | 16 | I think we've played around with this sort of interpreter before. 17 | 18 | The most interesting part, to me, is that the microKanreny implementation is expressive but slow, while the simple version is fast but not as expressive. However, we can write a query that uses both interpreters on the same miniKanren expression, combining speed with expressiveness. This seems to work well in my simple examples. I haven't added support for recursive functions yet. That's when it will become more interesting. 19 | 20 | --------------- 21 | 22 | How can we make synthesis of miniKanren expressions much faster? 23 | 24 | An idea! We shoul be able to combine the `mko` relations from `core-mk.scm`, `core-mk-explicit-failure`, and `core-mk-explicit-failure-streams.scm`. This should let us combine efficiency with expressiveness. 25 | 26 | For example, 27 | 28 | (run 1 (e) 29 | (mko `(run 1 (q) ,e) 'cat) ;; mko from core-mk.scm 30 | (mko `(run 1 (q) ,e) 'dog) ;; mko from core-mk.scm 31 | (mko `(run* (q) ,e) '(cat dog)) ;; mko from core-mk-explicit-failure-streams-tests.scm 32 | ) 33 | 34 | The idea here is that the first two mko calls from core-mk.scm can efficiently generate the conde and unifications, as in the "mko backwards-2" test in core-mk-tests.scm. The mko call from core-mk-explicit-failure-streams-tests.scm can then be used to specify that the synthesized expression must not produce any other values that 'cat and 'dog (although the expression could contain an arbitrary number of failing conde branches). 35 | 36 | See the "mko forwards unclosed" tests in core-mk-tests.scm to see how the expressions can't be "closed" in the core-mk-tests.scm code--there is no way to expression that the run expression should be capable of producting 'cat' and 'dog' as answers, but *nothing else*. The "mko forwards unclosed" tests in core-mk-explicit-failure-streams-tests.scm allow for proper "closing". 37 | 38 | 39 | Check that this does indeed work... 40 | 41 | *this does appear to work--see the tests in `core-mk-simple-and-complex`* We combine two *very* different relational mk interpreters to combine speed with expressiveness. 42 | 43 | 44 | Compare this version with Michael Ballantyne's: 45 | 46 | https://github.com/michaelballantyne/meta-minikanren/blob/master/mk-in-mk.scm 47 | 48 | MB's version includes explicit incs, which this implementation does not. There are other differences as well. How well does it do in synthesizing code from the desired behavior? Does it implement run* semantics? Or can you specify run n? 49 | 50 | Compare also to implementing microKanren in Scheme in the Barliman interpreter. Staging might help. 51 | 52 | 53 | 54 | Try synthesizing the Judea Pearl Rifleman causal inference examples, using the code from Nada and Jeremy. 55 | 56 | Try playing with declarative `findall`, like in Prolog. 57 | 58 | Should run return a set rather than a list? Or a bag, perhaps? 59 | 60 | Try implementing run n in addition to run*. 61 | 62 | Once we support recursive relations, run* may diverge. In this case, the run 1 semantics of the simpler, more meta-circular mko may be especially useful. Perhaps we really need to return a stream rather than a list. Can we use co-inductive logic programming? 63 | 64 | Seems like this implementation, and probably MB's, makes it work revisiting tabling for abstract interpretation, since we can get access to the entire list/set/bag of answers at once. 65 | 66 | Try adding inc. 67 | 68 | Try implementing the microKanren that includes disequality constraints. 69 | 70 | Can we play similar tricks with multiple versions of Scheme interpreters, and/or type-inferencers? 71 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-explicit-unification-failure/core-mk-explicit-unification-failure-tests.scm: -------------------------------------------------------------------------------- 1 | (load "core-mk-explicit-unification-failure.scm") 2 | (load "../../faster-miniKanren/test-check.scm") 3 | 4 | (test "mko-0" 5 | (run* (q) 6 | (mko `(run 1 (x) 7 | (fresh (y) 8 | (== (cons y y) x))) 9 | q)) 10 | '((((var (s z)) . (var (s z)))))) 11 | 12 | (test "mko-1" 13 | (run* (q) (mko '(run 1 (x) 14 | (== x 'cat)) 15 | q)) 16 | '((cat))) 17 | 18 | ;; run 2 diverges (didn't diverge when we didn't support explicit failure) 19 | ;; 20 | ;; can we do better? 21 | (test "mko-1b" 22 | (run 1 (e) 23 | (mko `(run 1 (x) 24 | (== ',e x)) 25 | '(cat))) 26 | '(cat)) 27 | 28 | ;; `run 2` appears to diverge, which is expected, since there are 29 | ;; infinitely many expressions `e`, and only 'cat will satisfy the 30 | ;; `==` constraint. 31 | (test "mko-1c" 32 | (run 1 (e) 33 | (mko `(run 1 (x) 34 | (== ,e x)) 35 | '(cat))) 36 | '('cat)) 37 | 38 | (test "mko occur check violation-1" 39 | (run* (q) 40 | (mko `(run 1 (x) 41 | (== (cons x x) x)) 42 | q)) 43 | '(())) 44 | 45 | (test "mko occur check violation-2" 46 | (run* (q) 47 | (mko `(run 1 (x) 48 | (== (cons x x) x)) 49 | '())) 50 | '(_.0)) 51 | 52 | (test "mko fail backwards-0" 53 | (run 1 (e) 54 | (mko `(run 1 (x) 55 | (== (cons ,e ,e) x)) 56 | '())) 57 | '(x)) 58 | 59 | (test "mko fail backwards-1" 60 | (run 8 (e) 61 | (mko `(run 1 (x) 62 | (== ,e x)) 63 | '())) 64 | '(((cons '_.0 x) (=/= ((_.0 var))) (sym _.0)) 65 | (cons '() x) 66 | ((cons '(_.0 . _.1) x) 67 | (=/= ((_.0 var)) ((_.1 var))) 68 | (sym _.0 _.1)) 69 | ((cons '(_.0) x) 70 | (=/= ((_.0 var))) (sym _.0)) 71 | ((cons '(() . _.0) x) 72 | (=/= ((_.0 var))) (sym _.0)) 73 | (cons '(()) x) 74 | ((cons x '_.0) ;; a nice theorem! 75 | (absento (var _.0))) 76 | ((cons '(_.0 _.1 . _.2) x) 77 | (=/= ((_.0 var)) ((_.1 var)) ((_.2 var))) 78 | (sym _.0 _.1 _.2)))) 79 | 80 | (test "mko fail backwards-2" 81 | (run 8 (e) 82 | (mko `(run 1 (q) ,e) '())) 83 | '(((== '_.0 '_.1) 84 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var))) 85 | (sym _.0 _.1)) 86 | ((== '_.0 '()) 87 | (=/= ((_.0 var))) 88 | (sym _.0)) 89 | ((== '() '_.0) 90 | (=/= ((_.0 var))) 91 | (sym _.0)) 92 | ((fresh (_.0) (== '_.1 '_.2)) 93 | (=/= ((_.1 _.2)) ((_.1 var)) ((_.2 var))) 94 | (sym _.0 _.1 _.2)) 95 | ((fresh (_.0) (== '_.1 '())) 96 | (=/= ((_.1 var))) 97 | (sym _.0 _.1)) 98 | ((== '_.0 '(_.1 . _.2)) 99 | (=/= ((_.0 var))) 100 | (sym _.0) 101 | (absento (var _.1) (var _.2))) 102 | ((fresh (_.0) (== '() '_.1)) 103 | (=/= ((_.1 var))) 104 | (sym _.0 _.1)) 105 | ((== '(_.0 . _.1) '_.2) 106 | (=/= ((_.2 var))) 107 | (sym _.2) 108 | (absento (var _.0) (var _.1))))) 109 | 110 | 111 | (test "mko-2" 112 | (run* (q) (mko '(run 1 (x) 113 | (conde 114 | ((== x 'cat)) 115 | ((== 'dog x)))) 116 | q)) 117 | '((cat) (dog))) 118 | 119 | (test "mko-3" 120 | (run* (q) (mko '(run 1 (x) 121 | (== 'cat 'cat)) 122 | q)) 123 | '(((var z)))) 124 | 125 | (test "mko-4" 126 | (run* (q) (mko '(run 1 (x) 127 | (fresh (y) 128 | (== 'cat 'cat))) 129 | q)) 130 | '(((var z)))) 131 | 132 | (test "mko-5" 133 | (run* (q) (mko '(run 1 (x) 134 | (fresh (y) 135 | (== x 'cat))) 136 | q)) 137 | '((cat))) 138 | 139 | (test "mko-6" 140 | (run* (q) (mko '(run 1 (x) 141 | (fresh (x) 142 | (== x 'cat))) 143 | q)) 144 | '(((var z)))) 145 | 146 | (test "mko-7" 147 | (run* (q) (mko '(run 1 (x) 148 | (fresh (y) 149 | (== y 'cat))) 150 | q)) 151 | '(((var z)))) 152 | 153 | (test "mko-8" 154 | (run* (q) (mko '(run 1 (x) 155 | (fresh (y) 156 | (== y 'cat) 157 | (== x y))) 158 | q)) 159 | '((cat))) 160 | 161 | (test "mko-9" 162 | (run* (q) (mko '(run 1 (x) 163 | (fresh (y) 164 | (== x y) 165 | (== y 'cat))) 166 | q)) 167 | '((cat))) 168 | 169 | (test "mko-10" 170 | (run* (q) (mko '(run 1 (x) 171 | (fresh (y) 172 | (fresh (z) 173 | (== (cons y z) x) 174 | (== z 'cat)) 175 | (== y 'dog))) 176 | q)) 177 | '(((dog . cat)))) 178 | 179 | (test "mko-11a" 180 | (run* (q) (mko '(run 1 (x) 181 | (== '() x)) 182 | q)) 183 | '((()))) 184 | 185 | (test "mko-11" 186 | (run* (q) (mko '(run 1 (x) 187 | (fresh (y) 188 | (fresh (z) 189 | (== (cons y (cons z '())) x) 190 | (== z 'cat)) 191 | (== y 'dog))) 192 | q)) 193 | '(((dog cat)))) 194 | 195 | (test "mko-12" 196 | (run* (q) (mko '(run 1 (x) (== '(cat) x)) q)) 197 | '(((cat)))) 198 | 199 | (test "mko-13" 200 | (run* (q) (mko '(run 1 (x) (== '(cat dog fish) x)) q)) 201 | '(((cat dog fish)))) 202 | 203 | (test "mko-14" 204 | (run* (q) (mko '(run 1 (x) (== '(cat dog . fish) x)) q)) 205 | '(((cat dog . fish)))) 206 | 207 | (test "mko-15" 208 | (run* (q) (mko '(run 1 (x) (== '(cat dog . fish) (cons x '(dog . fish)))) q)) 209 | '((cat))) 210 | 211 | (test "mko-16" 212 | (run* (q) (mko '(run 1 (x) (== (cons x '(dog . fish)) '(cat dog . fish))) q)) 213 | '((cat))) 214 | 215 | 216 | (test "mko unify x with itself" 217 | (run* (q) (mko '(run 1 (x) (== x x)) q)) 218 | '(((var z)))) 219 | 220 | (test "mko unify x with (cons y y)" 221 | (run* (q) 222 | (mko '(run 1 (x) 223 | (fresh (y) 224 | (== (cons y y) x))) 225 | q)) 226 | '((((var (s z)) var (s z))))) 227 | 228 | (test "mko occur-check-1" 229 | (run* (q) (mko '(run 1 (x) (== (cons x x) x)) q)) 230 | '(())) 231 | 232 | (test "mko occur-check-2" 233 | (run* (q) (mko '(run 1 (x) (== x (cons x x))) q)) 234 | '(())) 235 | 236 | (test "mko occur-check-3" 237 | (run* (q) 238 | (mko '(run 1 (x) 239 | (fresh (y) 240 | (== (cons y y) x) 241 | (== x y))) 242 | q)) 243 | '(())) 244 | 245 | (test "mko occur-check-4" 246 | (run* (q) 247 | (mko '(run 1 (x) 248 | (fresh (y) 249 | (== x y) 250 | (== (cons y y) x))) 251 | q)) 252 | '(())) 253 | 254 | (test "mko backwards-1" 255 | (run 10 (e) (mko e '(cat))) 256 | '(((run 1 (_.0) (== 'cat _.0)) 257 | (sym _.0)) ((run 1 (_.0) (== _.0 'cat)) (sym _.0)) 258 | ((run 1 (_.0) 259 | (conde 260 | ((== 'cat _.0)) 261 | (_.1))) 262 | (sym _.0)) 263 | ((run 1 (_.0) 264 | (conde 265 | (_.1) 266 | ((== 'cat _.0)))) 267 | (sym _.0)) 268 | ((run 1 (_.0) 269 | (conde 270 | ((== _.0 'cat)) 271 | (_.1))) 272 | (sym _.0)) 273 | ((run 1 (_.0) 274 | (conde 275 | (_.1) 276 | ((== _.0 'cat)))) 277 | (sym _.0)) 278 | ((run 1 (_.0) 279 | (fresh (_.1) 280 | (== '_.2 '_.2) 281 | (fresh (_.3) 282 | (== 'cat _.3)))) 283 | (=/= ((_.2 var))) 284 | (sym _.0 _.1 _.2 _.3)) 285 | ((run 1 (_.0) 286 | (fresh (_.1) 287 | (fresh (_.2) (== '_.3 '_.3)) 288 | (fresh (_.4) (== 'cat _.4)))) 289 | (=/= ((_.3 var))) 290 | (sym _.0 _.1 _.2 _.3 _.4)) 291 | ((run 1 (_.0) 292 | (fresh (_.1) 293 | (== '_.2 '_.2) 294 | (fresh (_.3) (== _.3 'cat)))) 295 | (=/= ((_.2 var))) 296 | (sym _.0 _.1 _.2 _.3)) 297 | ((run 1 (_.0) 298 | (fresh (_.1) (== 'cat _.0))) 299 | (=/= ((_.0 _.1))) 300 | (sym _.0 _.1)))) 301 | 302 | (test "mko backwards-2" 303 | (run 1 (e) 304 | (mko e '(cat)) 305 | (mko e '(dog))) 306 | '(((run 1 (_.0) 307 | (conde 308 | ((== 'cat _.0)) 309 | ((== 'dog _.0)))) 310 | (sym _.0)))) 311 | 312 | 313 | (test "eval-mko 0" 314 | (run 1 (subst^) 315 | (fresh (c) 316 | (eval-mko '(== 'cat 'cat) '() 'z c '() subst^))) 317 | '(())) 318 | 319 | (test "eval-mko 1" 320 | (run 1 (expr subst^) 321 | (fresh (c) 322 | (eval-mko expr '() 'z c '() subst^))) 323 | '((((== (quote _.0) (quote _.1)) #f) 324 | (=/= ((_.0 _.1)) ((_.0 var)) ((_.1 var))) 325 | (sym _.0 _.1)))) 326 | 327 | (test "eval-mko 2" 328 | (run* (subst^) 329 | (fresh (c) 330 | (eval-mko '(== 'cat 'cat) '() 'z c '() subst^))) 331 | '(())) 332 | 333 | (test "eval-mko 3" 334 | (run* (subst^) 335 | (fresh (c) 336 | (eval-mko '(== 'cat 'dog) '() 'z c '() subst^))) 337 | '(#f)) 338 | 339 | (test "eval-mko 4" 340 | (run* (subst^) 341 | (fresh (c) 342 | (eval-mko '(fresh (x) 343 | (== x 'cat) 344 | (== 'dog 'dog)) 345 | '() 'z c '() subst^))) 346 | '((((var z) . cat)))) 347 | 348 | (test "eval-mko 5" 349 | (run* (subst^) 350 | (fresh (c) 351 | (eval-mko '(fresh (x) 352 | (== x 'cat) 353 | (== 'cat x)) 354 | '() 'z c '() subst^))) 355 | '((((var z) . cat)))) 356 | 357 | (test "eval-mko 6" 358 | (run* (subst^) 359 | (fresh (c) 360 | (eval-mko '(fresh (x) 361 | (== x 'cat) (== 'dog x)) 362 | '() 'z c '() subst^))) 363 | '(#f)) 364 | 365 | (test "eval-mko 7" 366 | (run* (subst^) 367 | (fresh (c) 368 | (eval-mko '(fresh (x) 369 | (conde 370 | ((== x 'cat)) 371 | ((== x 'dog)))) 372 | '() 'z c '() subst^))) 373 | '((((var z) . cat)) (((var z) . dog)))) 374 | 375 | (test "eval-mko 8" 376 | (run* (subst^) 377 | (fresh (c) 378 | (eval-mko '(fresh (x) 379 | (conde 380 | ((== 'cat 'cat)) 381 | ((== x 'dog)))) 382 | '() 'z c '() subst^))) 383 | '(() (((var z) . dog)))) 384 | 385 | (test "eval-mko 9" 386 | (run* (subst^) 387 | (fresh (c) 388 | (eval-mko '(conde 389 | ((== 'cat 'cat)) 390 | ((== 'dog 'dog))) 391 | '() 'z c '() subst^))) 392 | '(() ())) 393 | 394 | (test "eval-mko 10" 395 | (run* (subst^) 396 | (fresh (c) 397 | (eval-mko '(fresh (x) 398 | (conde 399 | ((fresh (y) 400 | (== y 'cat) 401 | (== 'fish y))) 402 | ((== x 'dog)))) 403 | '() 'z c '() subst^))) 404 | '((((var z) . dog)) #f)) 405 | 406 | (test "eval-mko 11" 407 | (run* (subst^) 408 | (fresh (c) 409 | (eval-mko '(fresh (x) 410 | (conde 411 | ((== x 'dog)) 412 | ((fresh (y) 413 | (== 'fish y) 414 | (== y 'cat))))) 415 | '() 'z c '() subst^))) 416 | '((((var z) . dog)) #f)) 417 | 418 | (test "eval-mko backwards-1" 419 | (run 2 (expr) 420 | (fresh (c) 421 | (eval-mko expr '() 'z c '() '(((var z) . dog))))) 422 | '(((fresh (_.0) (== 'dog _.0)) 423 | (sym _.0)) 424 | ((fresh (_.0) (== _.0 'dog)) 425 | (sym _.0)))) 426 | 427 | (test "eval-mko backwards-2" 428 | (run 10 (expr) 429 | (fresh (c) 430 | (eval-mko expr '() 'z c '() '(((var z) . dog))))) 431 | '(((fresh (_.0) (== 'dog _.0)) 432 | (sym _.0)) 433 | ((fresh (_.0) (== _.0 'dog)) 434 | (sym _.0)) 435 | ((fresh (_.0) 436 | (== '_.1 '_.1) 437 | (== 'dog _.0)) 438 | (=/= ((_.1 var))) 439 | (sym _.0 _.1)) 440 | ((fresh (_.0) 441 | (== '_.1 '_.1) 442 | (== _.0 'dog)) 443 | (=/= ((_.1 var))) 444 | (sym _.0 _.1)) 445 | ((fresh (_.0) 446 | (fresh (_.1) 447 | (== '_.2 '_.2)) 448 | (== 'dog _.0)) 449 | (=/= ((_.2 var))) 450 | (sym _.0 _.1 _.2)) 451 | ((fresh (_.0) 452 | (fresh (_.1) 453 | (== 'dog _.0))) 454 | (=/= ((_.0 _.1))) 455 | (sym _.0 _.1)) 456 | ((fresh (_.0) 457 | (conde 458 | ((== 'dog _.0)) 459 | (_.1))) 460 | (sym _.0)) 461 | ((conde 462 | ((fresh (_.0) 463 | (== 'dog _.0))) 464 | (_.1)) 465 | (sym _.0)) 466 | ((conde 467 | (_.0) 468 | ((fresh (_.1) (== 'dog _.1)))) 469 | (sym _.1)) 470 | ((fresh (_.0) 471 | (conde 472 | (_.1) 473 | ((== 'dog _.0)))) 474 | (sym _.0)))) 475 | 476 | 477 | (test "walko the dog" 478 | (run* (q) (walko 'dog '(((var z) . cat)) q)) 479 | '(dog)) 480 | 481 | (test "walko the dogs" 482 | (run* (q) (walko '(dog . dog) '(((var z) . cat)) q)) 483 | '((dog . dog))) 484 | 485 | (test "walko the vars" 486 | (run* (q) (walko '((var z) . (var z)) '(((var z) . cat)) q)) 487 | '(((var z) var z))) 488 | 489 | (test "walko 1" 490 | (run* (q) (walko '(var z) '(((var z) . cat)) q)) 491 | '(cat)) 492 | 493 | (test "walko 2" 494 | (run* (q) (walko '(var (s (s (s z)))) '(((var (s (s (s z)))) . cat)) q)) 495 | '(cat)) 496 | 497 | (test "walko 3" 498 | (run* (q) (walko '(var (s (s (s z)))) '(((var (s (s z))) . cat)) q)) 499 | '((var (s (s (s z)))))) 500 | 501 | 502 | 503 | (test "walk*o the vars" 504 | (run* (q) (walk*o '((var z) . (var z)) '(((var z) . cat)) q)) 505 | '((cat . cat))) 506 | 507 | 508 | 509 | (test "unifyo 1" 510 | (run* (subst^) 511 | (unifyo 'cat 'cat '() subst^)) 512 | '(())) 513 | 514 | (test "unifyo 2" 515 | (run* (subst^) 516 | (unifyo 'cat 'dog '() subst^)) 517 | '(#f)) 518 | 519 | (test "unifyo 3" 520 | (run* (subst^) 521 | (unifyo '(var z) '((var (s z))) '() subst^)) 522 | '((((var z) (var (s z)))))) 523 | 524 | (test "unifyo 4" 525 | (run* (subst^) 526 | (unifyo '(var z) '((var z)) '() subst^)) 527 | '(#f)) 528 | 529 | (test "unifyo 5" 530 | (run* (subst^) 531 | (unifyo '(var z) '(var z) '() subst^)) 532 | '(())) 533 | 534 | (test "unifyo 6" 535 | (run* (subst^) 536 | (unifyo '(var z) '(var (s z)) '() subst^)) 537 | '((((var z) . (var (s z)))))) 538 | 539 | (test "unifyo 7" 540 | (run* (subst^) 541 | (unifyo '(var z) '((var z)) '() subst^)) 542 | '(#f)) 543 | 544 | (test "unifyo 8" 545 | (run* (subst^) 546 | (unifyo '((var z)) '(var z) '() subst^)) 547 | '(#f)) 548 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-explicit-unification-failure/core-mk-explicit-unification-failure.scm: -------------------------------------------------------------------------------- 1 | (load "../../faster-miniKanren/mk-vicare.scm") 2 | (load "../../faster-miniKanren/mk.scm") 3 | 4 | ;; Relational environment-passing, substitution-passing interpreter 5 | ;; for a subset of miniKanren, written in miniKanren. 6 | ;; 7 | ;; This version of the interpreter explicitly represents failure 8 | ;; (represented as #f), in addition to success (represented as a 9 | ;; substitution) 10 | ;; 11 | ;; The `mko` driver relation simulates non-deterministic evaluation of 12 | ;; a `run 1` expression (not a `run*` expression!). 13 | ;; 14 | ;; This interpreter represents `conde` and the miniKanren search 15 | ;; metacircularly, using the host `conde`. There seems to be tradeoff 16 | ;; in expressiveness vs. convenience: this interpreter can't express 17 | ;; that a miniKanren program *doesn't* produce a certain answer, for 18 | ;; example. Also, this interpreter can't be used to reason about 19 | ;; setof/bagof-style 2nd order relations, since the "collected" answers 20 | ;; are collected through the host `run`, rather than through a `run*` 21 | ;; in the object miniKanren. Indeed, the object `run` can only express 22 | ;; (non-deterministic) `run 1` semantics, rather than `run*` semantics. 23 | 24 | #| 25 | Grammar: 26 | 27 | ;; run 1 expression 28 | run1-expr ::= (run 1 () ) 29 | 30 | ;; goal expression 31 | ::= (== ) | 32 | (fresh () ) | 33 | (fresh () ) | 34 | (conde () ()) 35 | 36 | ;; Scheme expression 37 | ::= | 38 | (quote ) | 39 | (cons ) 40 | 41 | ;; Scheme lexical variable 42 | ::= 43 | 44 | ;; quoted datum 45 | ::= | 46 | () | 47 | ( . ) 48 | |# 49 | 50 | ;; Logic variables are represented as tagged lists of the form `(var ,c)` 51 | ;; where `c` is a Peano numeral of the form `z`, `(s z)`, `(s (s z))`, etc. 52 | ;; Logic variables that remain fresh are reified as themselves, rather than 53 | ;; being replaced with `_.0`, `_.1`, etc. 54 | 55 | 56 | ;; TODO: 57 | ;; 58 | ;; Think about reification of fresh logic variables--should it work 59 | ;; like in regular mk, by using some kind of fake subst? If so, would 60 | ;; you be able to tell whether '_.0' came from miniKanren, or the 61 | ;; language being interpreted? 62 | ;; 63 | ;; Support =/=, symbolo, numbero, and absento 64 | ;; 65 | ;; Support helpers and recursion 66 | 67 | (define mko 68 | (lambda (expr out) 69 | (fresh (q ge count^ s) 70 | (== `(run 1 (,q) ,ge) expr) 71 | (symbolo q) 72 | (eval-mko ge `((,q . (var z))) `(s z) count^ '() s) 73 | ;; this goal ordering is unfortunate! 74 | (conde 75 | ((== #f s) (== '() out)) 76 | ((=/= #f s) 77 | (fresh (t) 78 | (== (list t) out) 79 | (walk*o `(var z) s t))))))) 80 | 81 | (define eval-mko 82 | (lambda (expr env count count^ subst subst^) 83 | (conde 84 | ((fresh (e1 e2 t1 t2 s) 85 | (== `(== ,e1 ,e2) expr) 86 | (evalo e1 env t1) 87 | (evalo e2 env t2) 88 | (conde 89 | ((== #f s) (== #f subst^)) 90 | ((=/= #f s) (== s subst^))) 91 | (unifyo t1 t2 subst s))) 92 | ((fresh (x ge subst^^) 93 | (== `(fresh (,x) ,ge) expr) 94 | (symbolo x) 95 | (eval-mko ge `((,x . (var ,count)) . ,env) `(s ,count) count^ subst subst^))) 96 | ((fresh (x ge1 ge2 count^^ s) 97 | (== `(fresh (,x) ,ge1 ,ge2) expr) 98 | (symbolo x) 99 | (eval-mko ge1 `((,x . (var ,count)) . ,env) `(s ,count) count^^ subst s) 100 | (conde 101 | ((== #f s) (== #f subst^)) 102 | ((=/= #f s) 103 | (eval-mko ge2 `((,x . (var ,count)) . ,env) count^^ count^ s subst^))))) 104 | ((fresh (ge1 ge2) 105 | (== `(conde (,ge1) (,ge2)) expr) 106 | (conde 107 | ((eval-mko ge1 env count count^ subst subst^)) 108 | ((eval-mko ge2 env count count^ subst subst^)))))))) 109 | 110 | (define evalo 111 | (lambda (expr env val) 112 | (conde 113 | ((== `(quote ,val) expr) 114 | (absento 'var val)) 115 | ((symbolo expr) (lookupo expr env val)) 116 | ((fresh (e1 e2 v1 v2) 117 | (== `(cons ,e1 ,e2) expr) 118 | (== `(,v1 . ,v2) val) 119 | (evalo e1 env v1) 120 | (evalo e2 env v2)))))) 121 | 122 | (define lookupo 123 | (lambda (x env val) 124 | (fresh (y v rest) 125 | (== `((,y . ,v) . ,rest) env) 126 | (conde 127 | ((== x y) (== v val)) 128 | ((=/= x y) 129 | (lookupo x rest val)))))) 130 | 131 | (define unifyo 132 | (lambda (t1 t2 subst subst^) 133 | (fresh (t1^ t2^) 134 | (walko t1 subst t1^) 135 | (walko t2 subst t2^) 136 | (conde 137 | ;; ----- symbols ------- 138 | ;; symbol with symbol 139 | ((symbolo t1^) (symbolo t2^) 140 | (conde 141 | ((== t1^ t2^) (== subst subst^)) 142 | ((=/= t1^ t2^) (== #f subst^)))) 143 | ;; symbol with empty list 144 | ((symbolo t1^) (== '() t2^) 145 | (== #f subst^)) 146 | ((symbolo t2^) (== '() t1^) 147 | (== #f subst^)) 148 | ;; symbol with pair 149 | ((fresh (a2 d2) 150 | (symbolo t1^) 151 | (== `(,a2 . ,d2) t2^) 152 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 153 | (== #f subst^))) 154 | ((fresh (a1 d1) 155 | (symbolo t2^) 156 | (== `(,a1 . ,d1) t1^) 157 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 158 | (== #f subst^))) 159 | ;; symbol with var 160 | ((fresh (c1) 161 | (== `(var ,c1) t1^) 162 | (symbolo t2^) ;; t2^ is a literal symbol, not a var 163 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 164 | ((fresh (c2) 165 | (== `(var ,c2) t2^) 166 | (symbolo t1^) ;; t1^ is a literal symbol, not a var 167 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 168 | ;; ----- empty list ------- 169 | ;; empty list with empty list 170 | ((== '() t1^) (== '() t2^) (== subst subst^)) 171 | ;; empty list with symbol -- handled above 172 | ;; empty list with pair 173 | ((fresh (a2 d2) 174 | (== '() t1^) 175 | (== `(,a2 . ,d2) t2^) 176 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 177 | (== #f subst^))) 178 | ((fresh (a1 d1) 179 | (== '() t2^) 180 | (== `(,a1 . ,d1) t1^) 181 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 182 | (== #f subst^))) 183 | ;; empty list with var 184 | ((fresh (c1) 185 | (== `(var ,c1) t1^) 186 | (== '() t2^) 187 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 188 | ((fresh (c2) 189 | (== `(var ,c2) t2^) 190 | (== '() t1^) 191 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 192 | ;; ----- var ------- 193 | ;; var and var 194 | ((fresh (c1 c2) 195 | (== `(var ,c1) t1^) 196 | (== `(var ,c2) t2^) 197 | (conde 198 | ((== c1 c2) (== subst subst^)) 199 | ((=/= c1 c2) (== `(((var ,c1) . (var ,c2)) . ,subst) subst^))))) 200 | ;; var with symbol -- handled above 201 | ;; var with empty list -- handled above 202 | ;; var with pair 203 | ((fresh (c1 a2 d2) 204 | (== `(var ,c1) t1^) 205 | (== `(,a2 . ,d2) t2^) 206 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 207 | (conde 208 | ((== `(((var ,c1) . (,a2 . ,d2)) . ,subst) subst^) 209 | (not-occurso t1^ t2^)) 210 | ((== #f subst^) 211 | (occurso t1^ t2^))))) 212 | ((fresh (c2 a1 d1) 213 | (== `(var ,c2) t2^) 214 | (== `(,a1 . ,d1) t1^) 215 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 216 | (conde 217 | ((== `(((var ,c2) . (,a1 . ,d1)) . ,subst) subst^) 218 | (not-occurso t2^ t1^)) 219 | ((== #f subst^) 220 | (occurso t2^ t1^))))) 221 | ;; ----- pair ------- 222 | ;; pair with pair 223 | ((fresh (a1 d1 a2 d2 subst^^) 224 | (== `(,a1 . ,d1) t1^) 225 | (== `(,a2 . ,d2) t2^) 226 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 227 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 228 | (unifyo a1 a2 subst subst^^) 229 | (conde 230 | ((== #f subst^^) 231 | (== #f subst^)) 232 | ((=/= #f subst^^) 233 | (unifyo d1 d2 subst^^ subst^))))) 234 | ;; pair with symbol -- handled above 235 | ;; pair with empty list -- handled above 236 | ;; pair with var -- handled above 237 | )))) 238 | 239 | (define occurso 240 | (lambda (x t) 241 | (fresh (c) 242 | (== `(var ,c) x) 243 | (conde 244 | ((== `(var ,c) t)) 245 | ((fresh (a d) 246 | (== `(,a . ,d) t) 247 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 248 | (conde 249 | ((occurso x a)) 250 | ((not-occurso x a) 251 | (occurso x d))))))))) 252 | 253 | (define not-occurso 254 | (lambda (x t) 255 | (fresh (c) 256 | (== `(var ,c) x) 257 | (conde 258 | ((symbolo t)) 259 | ((== '() t)) 260 | ((fresh (c^) 261 | (== `(var ,c^) t) 262 | (=/= c c^))) 263 | ((fresh (a d) 264 | (== `(,a . ,d) t) 265 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 266 | (not-occurso x a) 267 | (not-occurso x d))))))) 268 | 269 | (define walko 270 | (lambda (t subst t^) 271 | (letrec ((walk-varo 272 | (lambda (t s t^) 273 | (conde 274 | ((== '() s) (== t t^)) 275 | ((fresh (c u rest) 276 | (== `(((var ,c) . ,u) . ,rest) s) 277 | (conde 278 | ((== `(var ,c) t) (walko u subst t^)) 279 | ((=/= `(var ,c) t) (walk-varo t rest t^))))))))) 280 | (conde 281 | ((symbolo t) (== t t^)) 282 | ((== '() t) (== t t^)) 283 | ((fresh (a d) 284 | (== `(,a . ,d) t) 285 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 286 | (== t t^))) 287 | ((fresh (c) 288 | (== `(var ,c) t) 289 | (walk-varo t subst t^))))))) 290 | 291 | (define walk*o 292 | (lambda (t subst t^) 293 | (fresh (t^^) 294 | (walko t subst t^^) 295 | (conde 296 | ((symbolo t^^) (== t^^ t^)) 297 | ((== '() t^^) (== t^^ t^)) 298 | ((fresh (c) 299 | (== `(var ,c) t^^) 300 | (== t^^ t^))) 301 | ((fresh (a d a^ d^) 302 | (== `(,a . ,d) t^^) 303 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 304 | (== `(,a^ . ,d^) t^) 305 | (walk*o a subst a^) 306 | (walk*o d subst d^))))))) 307 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-explicit-unification/core-mk-explicit-unification-tests.scm: -------------------------------------------------------------------------------- 1 | (load "core-mk-explicit-unification.scm") 2 | (load "../../faster-miniKanren/test-check.scm") 3 | 4 | (test "mko-1" 5 | (run* (q) (mko '(run 1 (x) 6 | (== x 'cat)) 7 | q)) 8 | '(cat)) 9 | 10 | (test "mko-1b" 11 | (run* (e) 12 | (mko `(run 1 (x) 13 | (== ',e x)) 14 | 'cat)) 15 | '(cat)) 16 | 17 | ;; `run 2` appears to diverge, which is expected, since there are 18 | ;; infinitely many expressions `e`, and only 'cat will satisfy the 19 | ;; `==` constraint. 20 | (test "mko-1c" 21 | (run 1 (e) 22 | (mko `(run 1 (x) 23 | (== ,e x)) 24 | 'cat)) 25 | '('cat)) 26 | 27 | (test "mko-2" 28 | (run* (q) (mko '(run 1 (x) 29 | (conde 30 | ((== x 'cat)) 31 | ((== 'dog x)))) 32 | q)) 33 | '(cat dog)) 34 | 35 | (test "mko-3" 36 | (run* (q) (mko '(run 1 (x) 37 | (== 'cat 'cat)) 38 | q)) 39 | '((var z))) 40 | 41 | (test "mko-4" 42 | (run* (q) (mko '(run 1 (x) 43 | (fresh (y) 44 | (== 'cat 'cat))) 45 | q)) 46 | '((var z))) 47 | 48 | (test "mko-5" 49 | (run* (q) (mko '(run 1 (x) 50 | (fresh (y) 51 | (== x 'cat))) 52 | q)) 53 | '(cat)) 54 | 55 | (test "mko-6" 56 | (run* (q) (mko '(run 1 (x) 57 | (fresh (x) 58 | (== x 'cat))) 59 | q)) 60 | '((var z))) 61 | 62 | (test "mko-7" 63 | (run* (q) (mko '(run 1 (x) 64 | (fresh (y) 65 | (== y 'cat))) 66 | q)) 67 | '((var z))) 68 | 69 | (test "mko-8" 70 | (run* (q) (mko '(run 1 (x) 71 | (fresh (y) 72 | (== y 'cat) 73 | (== x y))) 74 | q)) 75 | '(cat)) 76 | 77 | (test "mko-9" 78 | (run* (q) (mko '(run 1 (x) 79 | (fresh (y) 80 | (== x y) 81 | (== y 'cat))) 82 | q)) 83 | '(cat)) 84 | 85 | (test "mko-10" 86 | (run* (q) (mko '(run 1 (x) 87 | (fresh (y) 88 | (fresh (z) 89 | (== (cons y z) x) 90 | (== z 'cat)) 91 | (== y 'dog))) 92 | q)) 93 | '((dog . cat))) 94 | 95 | (test "mko-11a" 96 | (run* (q) (mko '(run 1 (x) 97 | (== '() x)) 98 | q)) 99 | '(())) 100 | 101 | (test "mko-11" 102 | (run* (q) (mko '(run 1 (x) 103 | (fresh (y) 104 | (fresh (z) 105 | (== (cons y (cons z '())) x) 106 | (== z 'cat)) 107 | (== y 'dog))) 108 | q)) 109 | '((dog cat))) 110 | 111 | (test "mko-12" 112 | (run* (q) (mko '(run 1 (x) (== '(cat) x)) q)) 113 | '((cat))) 114 | 115 | (test "mko-13" 116 | (run* (q) (mko '(run 1 (x) (== '(cat dog fish) x)) q)) 117 | '((cat dog fish))) 118 | 119 | (test "mko-14" 120 | (run* (q) (mko '(run 1 (x) (== '(cat dog . fish) x)) q)) 121 | '((cat dog . fish))) 122 | 123 | (test "mko-15" 124 | (run* (q) (mko '(run 1 (x) (== '(cat dog . fish) (cons x '(dog . fish)))) q)) 125 | '(cat)) 126 | 127 | (test "mko-16" 128 | (run* (q) (mko '(run 1 (x) (== (cons x '(dog . fish)) '(cat dog . fish))) q)) 129 | '(cat)) 130 | 131 | 132 | (test "mko unify x with itself" 133 | (run* (q) (mko '(run 1 (x) (== x x)) q)) 134 | '((var z))) 135 | 136 | (test "mko unify x with (cons y y)" 137 | (run* (q) 138 | (mko '(run 1 (x) 139 | (fresh (y) 140 | (== (cons y y) x))) 141 | q)) 142 | '(((var (s z)) var (s z)))) 143 | 144 | (test "mko occur-check-1" 145 | (run* (q) (mko '(run 1 (x) (== (cons x x) x)) q)) 146 | '()) 147 | 148 | (test "mko occur-check-2" 149 | (run* (q) (mko '(run 1 (x) (== x (cons x x))) q)) 150 | '()) 151 | 152 | (test "mko occur-check-3" 153 | (run* (q) 154 | (mko '(run 1 (x) 155 | (fresh (y) 156 | (== (cons y y) x) 157 | (== x y))) 158 | q)) 159 | '()) 160 | 161 | (test "mko occur-check-4" 162 | (run* (q) 163 | (mko '(run 1 (x) 164 | (fresh (y) 165 | (== x y) 166 | (== (cons y y) x))) 167 | q)) 168 | '()) 169 | 170 | (test "mko backwards-1" 171 | (run 10 (e) (mko e 'cat)) 172 | '(((run 1 (_.0) (== 'cat _.0)) 173 | (sym _.0)) 174 | ((run 1 (_.0) (== _.0 'cat)) 175 | (sym _.0)) 176 | ((run 1 (_.0) 177 | (fresh (_.1) 178 | (== 'cat _.0))) 179 | (=/= ((_.0 _.1))) 180 | (sym _.0 _.1)) 181 | ((run 1 (_.0) 182 | (conde 183 | ((== 'cat _.0)) 184 | (_.1))) 185 | (sym _.0)) 186 | ((run 1 (_.0) 187 | (conde 188 | (_.1) 189 | ((== 'cat _.0)))) 190 | (sym _.0)) 191 | ((run 1 (_.0) 192 | (== '(_.1 . cat) (cons '_.1 _.0))) 193 | (=/= ((_.1 var))) 194 | (sym _.0 _.1)) 195 | ((run 1 (_.0) 196 | (conde 197 | ((== _.0 'cat)) 198 | (_.1))) 199 | (sym _.0)) 200 | ((run 1 (_.0) 201 | (conde 202 | (_.1) 203 | ((== _.0 'cat)))) 204 | (sym _.0)) 205 | ((run 1 (_.0) 206 | (== '(cat . _.1) (cons _.0 '_.1))) 207 | (=/= ((_.1 var))) 208 | (sym _.0 _.1)) 209 | ((run 1 (_.0) 210 | (== '(() . cat) (cons '() _.0))) 211 | (sym _.0)))) 212 | 213 | (test "mko backwards-2" 214 | (run 1 (e) 215 | (mko e 'cat) 216 | (mko e 'dog)) 217 | '(((run 1 (_.0) 218 | (conde 219 | ((== 'cat _.0)) 220 | ((== 'dog _.0)))) 221 | (sym _.0)))) 222 | 223 | ;; there is no way to make this test fail using core.mk.scm, since we 224 | ;; can only use mko to express which values *must* be produced, and 225 | ;; cannot express that these must be the only values produced 226 | (test "mko forwards unclosed 0" 227 | (run 1 (expr) 228 | (fresh (e) 229 | (== `(run 1 (x) 230 | (conde 231 | ((== 'cat x)) 232 | ((conde 233 | ((== 'dog x)) 234 | ((== 'fish x)))))) 235 | expr) 236 | (mko expr 'cat) 237 | (mko expr 'dog))) 238 | '((run 1 (x) 239 | (conde 240 | ((== 'cat x)) 241 | ((conde ((== 'dog x)) ((== 'fish x)))))))) 242 | 243 | (test "mko forwards unclosed 1" 244 | (run 1 (expr) 245 | (fresh (e) 246 | (== `(run 1 (x) 247 | (conde 248 | ((== 'cat x)) 249 | ((conde 250 | ((== 'dog x)) 251 | (,e))))) 252 | expr) 253 | (mko expr 'cat) 254 | (mko expr 'dog))) 255 | '((run 1 (x) 256 | (conde 257 | ((== 'cat x)) 258 | ((conde 259 | ((== 'dog x)) 260 | (_.0))))))) 261 | 262 | 263 | (test "eval-mko 0" 264 | (run 1 (subst^) 265 | (fresh (c) 266 | (eval-mko '(== 'cat 'cat) '() 'z c '() subst^))) 267 | '(())) 268 | 269 | (test "eval-mko 1" 270 | (run 1 (expr subst^) 271 | (fresh (c) 272 | (eval-mko expr '() 'z c '() subst^))) 273 | '((((== '_.0 '_.0) ()) 274 | (=/= ((_.0 var))) (sym _.0)))) 275 | 276 | 277 | (test "eval-mko 2" 278 | (run* (subst^) 279 | (fresh (c) 280 | (eval-mko '(== 'cat 'cat) '() 'z c '() subst^))) 281 | '(())) 282 | 283 | (test "eval-mko 3" 284 | (run* (subst^) 285 | (fresh (c) 286 | (eval-mko '(== 'cat 'dog) '() 'z c '() subst^))) 287 | '()) 288 | 289 | 290 | (test "eval-mko 4" 291 | (run* (subst^) 292 | (fresh (c) 293 | (eval-mko '(fresh (x) 294 | (== x 'cat) 295 | (== 'dog 'dog)) 296 | '() 'z c '() subst^))) 297 | '((((var z) . cat)))) 298 | 299 | (test "eval-mko 5" 300 | (run* (subst^) 301 | (fresh (c) 302 | (eval-mko '(fresh (x) 303 | (== x 'cat) 304 | (== 'cat x)) 305 | '() 'z c '() subst^))) 306 | '((((var z) . cat)))) 307 | 308 | (test "eval-mko 6" 309 | (run* (subst^) 310 | (fresh (c) 311 | (eval-mko '(fresh (x) 312 | (== x 'cat) (== 'dog x)) 313 | '() 'z c '() subst^))) 314 | '()) 315 | 316 | (test "eval-mko 7" 317 | (run* (subst^) 318 | (fresh (c) 319 | (eval-mko '(fresh (x) 320 | (conde 321 | ((== x 'cat)) 322 | ((== x 'dog)))) 323 | '() 'z c '() subst^))) 324 | '((((var z) . cat)) (((var z) . dog)))) 325 | 326 | (test "eval-mko 8" 327 | (run* (subst^) 328 | (fresh (c) 329 | (eval-mko '(fresh (x) 330 | (conde 331 | ((== 'cat 'cat)) 332 | ((== x 'dog)))) 333 | '() 'z c '() subst^))) 334 | '(() (((var z) . dog)))) 335 | 336 | (test "eval-mko 9" 337 | (run* (subst^) 338 | (fresh (c) 339 | (eval-mko '(conde 340 | ((== 'cat 'cat)) 341 | ((== 'dog 'dog))) 342 | '() 'z c '() subst^))) 343 | '(() ())) 344 | 345 | (test "eval-mko 10" 346 | (run* (subst^) 347 | (fresh (c) 348 | (eval-mko '(fresh (x) 349 | (conde 350 | ((fresh (y) 351 | (== y 'cat) 352 | (== 'fish y))) 353 | ((== x 'dog)))) 354 | '() 'z c '() subst^))) 355 | '((((var z) . dog)))) 356 | 357 | (test "eval-mko 11" 358 | (run* (subst^) 359 | (fresh (c) 360 | (eval-mko '(fresh (x) 361 | (conde 362 | ((== x 'dog)) 363 | ((fresh (y) 364 | (== 'fish y) 365 | (== y 'cat))))) 366 | '() 'z c '() subst^))) 367 | '((((var z) . dog)))) 368 | 369 | (test "eval-mko backwards-1" 370 | (run 2 (expr) 371 | (fresh (c) 372 | (eval-mko expr '() 'z c '() '(((var z) . dog))))) 373 | '(((fresh (_.0) (== 'dog _.0)) 374 | (sym _.0)) 375 | ((fresh (_.0) (== _.0 'dog)) 376 | (sym _.0)))) 377 | 378 | (test "eval-mko backwards-2" 379 | (run 10 (expr) 380 | (fresh (c) 381 | (eval-mko expr '() 'z c '() '(((var z) . dog))))) 382 | '(((fresh (_.0) (== 'dog _.0)) 383 | (sym _.0)) 384 | ((fresh (_.0) (== _.0 'dog)) 385 | (sym _.0)) 386 | ((fresh (_.0) 387 | (== '_.1 '_.1) 388 | (== 'dog _.0)) 389 | (=/= ((_.1 var))) 390 | (sym _.0 _.1)) 391 | ((fresh (_.0) 392 | (== '_.1 '_.1) 393 | (== _.0 'dog)) 394 | (=/= ((_.1 var))) 395 | (sym _.0 _.1)) 396 | ((fresh (_.0) 397 | (fresh (_.1) 398 | (== '_.2 '_.2)) 399 | (== 'dog _.0)) 400 | (=/= ((_.2 var))) 401 | (sym _.0 _.1 _.2)) 402 | ((fresh (_.0) 403 | (== 'dog _.0) 404 | (== '_.1 '_.1)) 405 | (=/= ((_.1 var))) 406 | (sym _.0 _.1)) 407 | ((fresh (_.0) 408 | (fresh (_.1) 409 | (== '_.2 '_.2)) 410 | (== _.0 'dog)) 411 | (=/= ((_.2 var))) 412 | (sym _.0 _.1 _.2)) 413 | ((fresh (_.0) 414 | (fresh (_.1) 415 | (== 'dog _.0))) 416 | (=/= ((_.0 _.1))) 417 | (sym _.0 _.1)) 418 | ((fresh (_.0) 419 | (conde 420 | ((== 'dog _.0)) 421 | (_.1))) 422 | (sym _.0)) 423 | ((conde 424 | ((fresh (_.0) 425 | (== 'dog _.0))) 426 | (_.1)) 427 | (sym _.0)))) 428 | 429 | 430 | 431 | (test "walko the dog" 432 | (run* (q) (walko 'dog '(((var z) . cat)) q)) 433 | '(dog)) 434 | 435 | (test "walko the dogs" 436 | (run* (q) (walko '(dog . dog) '(((var z) . cat)) q)) 437 | '((dog . dog))) 438 | 439 | (test "walko the vars" 440 | (run* (q) (walko '((var z) . (var z)) '(((var z) . cat)) q)) 441 | '(((var z) var z))) 442 | 443 | (test "walko 1" 444 | (run* (q) (walko '(var z) '(((var z) . cat)) q)) 445 | '(cat)) 446 | 447 | (test "walko 2" 448 | (run* (q) (walko '(var (s (s (s z)))) '(((var (s (s (s z)))) . cat)) q)) 449 | '(cat)) 450 | 451 | (test "walko 3" 452 | (run* (q) (walko '(var (s (s (s z)))) '(((var (s (s z))) . cat)) q)) 453 | '((var (s (s (s z)))))) 454 | 455 | 456 | 457 | (test "walk*o the vars" 458 | (run* (q) (walk*o '((var z) . (var z)) '(((var z) . cat)) q)) 459 | '((cat . cat))) 460 | 461 | 462 | 463 | (test "unifyo 1" 464 | (run 1 (subst^) 465 | (unifyo 'cat 'cat '() subst^)) 466 | '(())) 467 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-explicit-unification/core-mk-explicit-unification.scm: -------------------------------------------------------------------------------- 1 | (load "../../faster-miniKanren/mk-vicare.scm") 2 | (load "../../faster-miniKanren/mk.scm") 3 | 4 | ;; Relational environment-passing, substitution-passing interpreter 5 | ;; for a subset of miniKanren, written in miniKanren. 6 | ;; 7 | ;; The `mko` driver relation simulates non-deterministic evaluation of 8 | ;; a `run 1` expression (not a `run*` expression!), as a single value 9 | ;; is associated with the query variable upon success. 10 | ;; 11 | ;; In order to simulate full `run*` behavior, I think it would be 12 | ;; necessary to implement the notions of success and failure 13 | ;; explicitly. This implementation represents failure metacircularly, 14 | ;; as failure at the host-level miniKanren. Similarly, this 15 | ;; interpreter represents `conde` and the miniKanren search 16 | ;; metacircularly, using the host `conde`. There seems to be tradeoff 17 | ;; in expressiveness vs. convenience: this interpreter can't express 18 | ;; that a miniKanren program *doesn't* produce a certain answer, for 19 | ;; example. Also, this interpreter can't be used to reason about 20 | ;; setof/bagof-style 2nd order relations, since the "collected" answers 21 | ;; are collected through the host `run`, rather than through a `run*` 22 | ;; in the object miniKanren. Indeed, the object `run` can only express 23 | ;; (non-deterministic) `run 1` semantics, rather than `run*` semantics. 24 | 25 | #| 26 | Grammar: 27 | 28 | ;; run 1 expression 29 | run1-expr ::= (run 1 () ) 30 | 31 | ;; goal expression 32 | ::= (== ) | 33 | (fresh () ) | 34 | (fresh () ) | 35 | (conde () ()) 36 | 37 | ;; Scheme expression 38 | ::= | 39 | (quote ) | 40 | (cons ) 41 | 42 | ;; Scheme lexical variable 43 | ::= 44 | 45 | ;; quoted datum 46 | ::= | 47 | () | 48 | ( . ) 49 | |# 50 | 51 | ;; Logic variables are represented as tagged lists of the form `(var ,c)` 52 | ;; where `c` is a Peano numeral of the form `z`, `(s z)`, `(s (s z))`, etc. 53 | ;; Logic variables that remain fresh are reified as themselves, rather than 54 | ;; being replaced with `_.0`, `_.1`, etc. 55 | 56 | 57 | ;; TODO: 58 | ;; 59 | ;; Think about reification of fresh logic variables--should it work 60 | ;; like in regular mk, by using some kind of fake subst? If so, would 61 | ;; you be able to tell whether '_.0' came from miniKanren, or the 62 | ;; language being interpreted? 63 | ;; 64 | ;; Support =/=, symbolo, numbero, and absento 65 | ;; 66 | ;; Support helpers and recursion 67 | 68 | (define mko 69 | (lambda (expr out) 70 | (fresh (q ge count^ subst^) 71 | (== `(run 1 (,q) ,ge) expr) 72 | (symbolo q) 73 | (eval-mko ge `((,q . (var z))) `(s z) count^ '() subst^) 74 | (walk*o `(var z) subst^ out)))) 75 | 76 | (define eval-mko 77 | (lambda (expr env count count^ subst subst^) 78 | (conde 79 | ((fresh (e1 e2 t1 t2) 80 | (== `(== ,e1 ,e2) expr) 81 | (evalo e1 env t1) 82 | (evalo e2 env t2) 83 | (unifyo t1 t2 subst subst^))) 84 | ((fresh (x ge subst^^) 85 | (== `(fresh (,x) ,ge) expr) 86 | (symbolo x) 87 | (eval-mko ge `((,x . (var ,count)) . ,env) `(s ,count) count^ subst subst^))) 88 | ((fresh (x ge1 ge2 count^^ subst^^) 89 | (== `(fresh (,x) ,ge1 ,ge2) expr) 90 | (symbolo x) 91 | (eval-mko ge1 `((,x . (var ,count)) . ,env) `(s ,count) count^^ subst subst^^) 92 | (eval-mko ge2 `((,x . (var ,count)) . ,env) count^^ count^ subst^^ subst^))) 93 | ((fresh (ge1 ge2) 94 | (== `(conde (,ge1) (,ge2)) expr) 95 | (conde 96 | ((eval-mko ge1 env count count^ subst subst^)) 97 | ((eval-mko ge2 env count count^ subst subst^)))))))) 98 | 99 | (define evalo 100 | (lambda (expr env val) 101 | (conde 102 | ((== `(quote ,val) expr) 103 | (absento 'var val)) 104 | ((symbolo expr) (lookupo expr env val)) 105 | ((fresh (e1 e2 v1 v2) 106 | (== `(cons ,e1 ,e2) expr) 107 | (== `(,v1 . ,v2) val) 108 | (evalo e1 env v1) 109 | (evalo e2 env v2)))))) 110 | 111 | (define lookupo 112 | (lambda (x env val) 113 | (fresh (y v rest) 114 | (== `((,y . ,v) . ,rest) env) 115 | (conde 116 | ((== x y) (== v val)) 117 | ((=/= x y) 118 | (lookupo x rest val)))))) 119 | 120 | (define unifyo 121 | (lambda (t1 t2 subst subst^) 122 | (fresh (t1^ t2^) 123 | (walko t1 subst t1^) 124 | (walko t2 subst t2^) 125 | (conde 126 | ((symbolo t1^) (symbolo t2^) (== t1^ t2^) (== subst subst^)) 127 | ((== '() t1^) (== '() t2^) (== subst subst^)) 128 | ((fresh (c1 c2) 129 | (== `(var ,c1) t1^) 130 | (== `(var ,c2) t2^) 131 | (conde 132 | ((== c1 c2) (== subst subst^)) 133 | ((=/= c1 c2) (== `(((var ,c1) . (var ,c2)) . ,subst) subst^))))) 134 | ((fresh (c1) 135 | (== `(var ,c1) t1^) 136 | (symbolo t2^) ;; t2^ is a literal symbol, not a var 137 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 138 | ((fresh (c2) 139 | (== `(var ,c2) t2^) 140 | (symbolo t1^) ;; t1^ is a literal symbol, not a var 141 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 142 | ((fresh (c1) 143 | (== `(var ,c1) t1^) 144 | (== '() t2^) 145 | (== `(((var ,c1) . ,t2^) . ,subst) subst^))) 146 | ((fresh (c2) 147 | (== `(var ,c2) t2^) 148 | (== '() t1^) 149 | (== `(((var ,c2) . ,t1^) . ,subst) subst^))) 150 | ((fresh (c1 a2 d2) 151 | (== `(var ,c1) t1^) 152 | (== `(,a2 . ,d2) t2^) 153 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 154 | (== `(((var ,c1) . (,a2 . ,d2)) . ,subst) subst^) 155 | (absento t1^ t2^) ;; use absento to implement the occurs check 156 | )) 157 | ((fresh (c2 a1 d1) 158 | (== `(var ,c2) t2^) 159 | (== `(,a1 . ,d1) t1^) 160 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 161 | (== `(((var ,c2) . (,a1 . ,d1)) . ,subst) subst^) 162 | (absento t2^ t1^) ;; use absento to implement the occurs check 163 | )) 164 | ((fresh (a1 d1 a2 d2 subst^^) 165 | (== `(,a1 . ,d1) t1^) 166 | (== `(,a2 . ,d2) t2^) 167 | (=/= 'var a1) ;; don't mistake tagged vars for regular pairs 168 | (=/= 'var a2) ;; don't mistake tagged vars for regular pairs 169 | (unifyo a1 a2 subst subst^^) 170 | (unifyo d1 d2 subst^^ subst^))))))) 171 | 172 | (define walko 173 | (lambda (t subst t^) 174 | (letrec ((walk-varo 175 | (lambda (t s t^) 176 | (conde 177 | ((== '() s) (== t t^)) 178 | ((fresh (c u rest) 179 | (== `(((var ,c) . ,u) . ,rest) s) 180 | (conde 181 | ((== `(var ,c) t) (walko u subst t^)) 182 | ((=/= `(var ,c) t) (walk-varo t rest t^))))))))) 183 | (conde 184 | ((symbolo t) (== t t^)) 185 | ((== '() t) (== t t^)) 186 | ((fresh (a d) 187 | (== `(,a . ,d) t) 188 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 189 | (== t t^))) 190 | ((fresh (c) 191 | (== `(var ,c) t) 192 | (walk-varo t subst t^))))))) 193 | 194 | (define walk*o 195 | (lambda (t subst t^) 196 | (fresh (t^^) 197 | (walko t subst t^^) 198 | (conde 199 | ((symbolo t^^) (== t^^ t^)) 200 | ((== '() t^^) (== t^^ t^)) 201 | ((fresh (c) 202 | (== `(var ,c) t^^) 203 | (== t^^ t^))) 204 | ((fresh (a d a^ d^) 205 | (== `(,a . ,d) t^^) 206 | (=/= 'var a) ;; don't mistake tagged vars for regular pairs 207 | (== `(,a^ . ,d^) t^) 208 | (walk*o a subst a^) 209 | (walk*o d subst d^))))))) 210 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-implicit-unification/core-mk-implicit-unification-tests.scm: -------------------------------------------------------------------------------- 1 | (load "core-mk-implicit-unification.scm") 2 | (load "../../faster-miniKanren/test-check.scm") 3 | 4 | (test "mko-1" 5 | (run* (q) (mko '(run 1 (x) 6 | (== x 'cat)) 7 | q)) 8 | '(cat)) 9 | 10 | (test "mko-1b" 11 | (run* (e) 12 | (mko `(run 1 (x) 13 | (== ',e x)) 14 | 'cat)) 15 | '(cat)) 16 | 17 | ;;; hmmm--because the logic variables are represented as host logic 18 | ;;; variables, this test returns a second answer---*anything goes*. 19 | ;;; This second answer is ruled out in the implementations with tagged 20 | ;;; representations of variables. Probably we do want to rule out the 21 | ;;; second answer, if we want to use the interpreter for program 22 | ;;; synthesis. Otherwise, miniKanren can just synthesize programs 23 | ;;; that never extend the substitution. 24 | ;; 25 | ;; run 3 appears to diverge 26 | (test "mko-1c" 27 | (run 2 (e) 28 | (mko `(run 1 (x) 29 | (== ,e x)) 30 | 'cat)) 31 | '('cat 32 | x)) 33 | 34 | (test "mko-1c2" 35 | (run* (v) 36 | (mko `(run 1 (x) 37 | (== x x)) 38 | v)) 39 | '(_.0)) 40 | 41 | (test "mko-1c3" 42 | (run* (e) 43 | (mko `(run 1 (x) 44 | (== ',e x)) 45 | 'cat)) 46 | '(cat)) 47 | 48 | (test "mko-1c4" 49 | (run 1 (e) 50 | (mko `(run 1 (x) 51 | ,e) 52 | 'cat)) 53 | '((== '_.0 '_.0))) 54 | -------------------------------------------------------------------------------- /miniKanren-in-miniKanren/core-mk-implicit-unification/core-mk-implicit-unification.scm: -------------------------------------------------------------------------------- 1 | (load "../../faster-miniKanren/mk-vicare.scm") 2 | (load "../../faster-miniKanren/mk.scm") 3 | 4 | ;; Relational environment-passing interpreter for a subset of 5 | ;; miniKanren, written in miniKanren. 6 | ;; 7 | ;; The `mko` driver relation simulates non-deterministic evaluation of 8 | ;; a `run 1` expression (not a `run*` expression!), as a single value 9 | ;; is associated with the query variable upon success. 10 | ;; 11 | ;; In order to simulate full `run*` behavior, I think it would be 12 | ;; necessary to implement the notions of success and failure 13 | ;; explicitly. This implementation represents failure metacircularly, 14 | ;; as failure at the host-level miniKanren. Similarly, this 15 | ;; interpreter represents `conde` and the miniKanren search 16 | ;; metacircularly, using the host `conde`. There seems to be tradeoff 17 | ;; in expressiveness vs. convenience: this interpreter can't express 18 | ;; that a miniKanren program *doesn't* produce a certain answer, for 19 | ;; example. Also, this interpreter can't be used to reason about 20 | ;; setof/bagof-style 2nd order relations, since the "collected" answers 21 | ;; are collected through the host `run`, rather than through a `run*` 22 | ;; in the object miniKanren. Indeed, the object `run` can only express 23 | ;; (non-deterministic) `run 1` semantics, rather than `run*` semantics. 24 | 25 | #| 26 | Grammar: 27 | 28 | ;; run 1 expression 29 | run1-expr ::= (run 1 () ) 30 | 31 | ;; goal expression 32 | ::= (== ) | 33 | (fresh () ) | 34 | (fresh () ) | 35 | (conde () ()) 36 | 37 | ;; Scheme expression 38 | ::= | 39 | (quote ) | 40 | (cons ) 41 | 42 | ;; Scheme lexical variable 43 | ::= 44 | 45 | ;; quoted datum 46 | ::= | 47 | () | 48 | ( . ) 49 | |# 50 | 51 | ;; Logic variables are represented metacircularly, as regular 52 | ;; miniKanren logic variables in the host miniKanren. 53 | 54 | (define mko 55 | (lambda (expr out) 56 | (fresh (q ge) 57 | (== `(run 1 (,q) ,ge) expr) 58 | (symbolo q) 59 | (eval-mko ge `((,q . ,out)))))) 60 | 61 | (define eval-mko 62 | (lambda (expr env) 63 | (conde 64 | ((fresh (e1 e2 t) 65 | (== `(== ,e1 ,e2) expr) 66 | (evalo e1 env t) 67 | (evalo e2 env t))) 68 | ((fresh (x x^ ge) 69 | (== `(fresh (,x) ,ge) expr) 70 | (symbolo x) 71 | (eval-mko ge `((,x . ,x^) . ,env)))) 72 | ((fresh (x x^ ge1 ge2) 73 | (== `(fresh (,x) ,ge1 ,ge2) expr) 74 | (symbolo x) 75 | (eval-mko ge1 `((,x . ,x^) . ,env)) 76 | (eval-mko ge2 `((,x . ,x^) . ,env)))) 77 | ((fresh (ge1 ge2) 78 | (== `(conde (,ge1) (,ge2)) expr) 79 | (conde 80 | ((eval-mko ge1 env)) 81 | ((eval-mko ge2 env)))))))) 82 | 83 | (define evalo 84 | (lambda (expr env val) 85 | (conde 86 | ((== `(quote ,val) expr)) 87 | ((symbolo expr) (lookupo expr env val)) 88 | ((fresh (e1 e2 v1 v2) 89 | (== `(cons ,e1 ,e2) expr) 90 | (== `(,v1 . ,v2) val) 91 | (evalo e1 env v1) 92 | (evalo e2 env v2)))))) 93 | 94 | (define lookupo 95 | (lambda (x env val) 96 | (fresh (y v rest) 97 | (== `((,y . ,v) . ,rest) env) 98 | (conde 99 | ((== x y) (== v val)) 100 | ((=/= x y) 101 | (lookupo x rest val)))))) 102 | -------------------------------------------------------------------------------- /primer.scm: -------------------------------------------------------------------------------- 1 | ;; Scheme Primer 2 | 3 | (define primer-version-string "0.00000001") 4 | 5 | (define print-greeting 6 | (lambda () 7 | (display "Welcome to the Scheme Primer, version ") 8 | (display primer-version-string) 9 | (newline) 10 | (newline) 11 | (display "Scheme is a programming language, and is a dialect of the LISP family of languages.") 12 | (newline) 13 | (newline) 14 | (display "This interactive Scheme Primer will teach you Scheme, and challenge you to write Scheme code of increasing complexity.") 15 | (newline) 16 | (newline) 17 | (display "The Scheme Primer will automatically adjust the difficulty of the exercises depending on how well you have performed on previous exercises.") 18 | (newline) 19 | (newline) 20 | (display "The Scheme Primer is itself written in Scheme. The Scheme Primer will teach you how to implement enough Scheme to run the Primer in your own Scheme implementation (\"Meta-circular Primer\"/\"Primer-ception\").") 21 | (newline) 22 | (newline) 23 | (display "The Scheme Primer also allows you to jump to specific lessons or pratice exercises.") 24 | (newline) 25 | (newline))) 26 | 27 | (define exit-primer 28 | (lambda (menu-item-name) 29 | (display "exiting Scheme Primer") 30 | (newline))) 31 | 32 | (define unimplemented-menu-item 33 | (lambda (menu-item-name) 34 | (display "Sorry--this menu item, \"") 35 | (display menu-item-name) 36 | (display "\", has not been implemented yet.") 37 | (newline) 38 | (display "Please choose a different menu item.") 39 | (newline) 40 | (newline) 41 | (main-menu))) 42 | 43 | (define main-menu-items 44 | `(("exit Scheme Primer" . ,exit-primer) 45 | ("parentheses practice" . ,unimplemented-menu-item) 46 | ("'cons' practice" . ,unimplemented-menu-item) 47 | ("'car' and 'cdr' practice" . ,unimplemented-menu-item) 48 | ("box-and-pointers practice" . ,unimplemented-menu-item) 49 | ("conditionals practice" . ,unimplemented-menu-item) 50 | ("'lambda' and application practice" . ,unimplemented-menu-item) 51 | ("variables, scope, binding, and shadowing practice" . ,unimplemented-menu-item) 52 | ("point-wise programming practice" . ,unimplemented-menu-item) 53 | ("simple recursion practice" . ,unimplemented-menu-item) 54 | ("'quasiquote', 'unquote', and 'unquote-splicing' practice" . ,unimplemented-menu-item) 55 | ("pattern-matching practice" . ,unimplemented-menu-item) 56 | )) 57 | 58 | (define iota 59 | (lambda (n) 60 | (let loop ((i 0)) 61 | (cond 62 | ((= i n) '()) 63 | (else (cons i (loop (add1 i)))))))) 64 | 65 | (define main-menu 66 | (lambda () 67 | (display "Main Menu") 68 | (newline) 69 | (display "----------") 70 | (newline) 71 | (for-each (lambda (pr i) 72 | (display "(") 73 | (display i) 74 | (display ") ") 75 | (display (car pr)) 76 | (newline)) 77 | main-menu-items 78 | (iota (length main-menu-items))) 79 | (display "----------") 80 | (newline) 81 | (display "Please enter the number of your choice from the menu above:") 82 | (newline) 83 | (let ((choice (read))) 84 | (cond 85 | ((and (number? choice) 86 | (integer? choice) 87 | (>= choice 0) 88 | (< choice (length main-menu-items))) 89 | (let ((pr (list-ref main-menu-items choice))) 90 | (let ((menu-item-name (car pr)) 91 | (handle-menu-item-procedure (cdr pr))) 92 | (newline) 93 | (display "You chose (") 94 | (display choice) 95 | (display "), ") 96 | (display menu-item-name) 97 | (display ".") 98 | (newline) 99 | (newline) 100 | (display "Come on! Here we go!") 101 | (newline) 102 | (newline) 103 | (handle-menu-item-procedure menu-item-name)))) 104 | (else 105 | (newline) 106 | (display "Sorry--I didn't understand your choice!") 107 | (newline) 108 | (display "Please try again! Please enter a number between 0 and ") 109 | (display (sub1 (length main-menu-items))) 110 | (display ", inclusive.") 111 | (newline) 112 | (newline) 113 | (main-menu)))))) 114 | 115 | (print-greeting) 116 | 117 | (main-menu) 118 | 119 | ;; self-evaluating literals 120 | 121 | ;; cons 122 | 123 | ;; car, cdr 124 | 125 | ;; quote 126 | 127 | ;; box and pointers 128 | 129 | ;; s-expressions 130 | 131 | ;; boolean expressions 132 | 133 | ;; arithmetic 134 | 135 | ;; conditionals 136 | 137 | ;; definitions 138 | 139 | ;; variables, scope, binding, and shadowing 140 | 141 | ;; lambda and application 142 | 143 | ;; what does this expression evaluate to? 144 | 145 | ;; recursion 146 | 147 | ;; quasiquote and unquote 148 | 149 | ;; pattern-matching 150 | 151 | ;; interpreters 152 | 153 | ;; macros 154 | --------------------------------------------------------------------------------