├── .gitignore ├── LICENSE ├── README.md ├── alphaKanren-version ├── alphaKanren │ ├── LICENSE │ ├── README.md │ ├── alphaKanren.scm │ └── tests.scm ├── nbe-tests.scm └── nbe.scm ├── miniKanren-version ├── deBruijn │ ├── nbe-extended-tests.scm │ ├── nbe-extended.scm │ ├── nbe-tests.scm │ └── nbe.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 │ ├── private-unstable.rkt │ ├── 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 └── naive │ ├── nbe-tests.scm │ ├── nbe-untagged-extended-infer-tests.scm │ ├── nbe-untagged-extended-infer.scm │ ├── nbe-untagged-extended-tests.scm │ ├── nbe-untagged-extended.scm │ ├── nbe-untagged-full-tests.scm │ ├── nbe-untagged-full.scm │ ├── nbe-untagged-tests.scm │ ├── nbe-untagged.scm │ ├── nbe.scm │ ├── rbe-depth-limited.scm │ ├── rbe.scm │ ├── rbe2.scm │ ├── rbe3-depth-limited.scm │ ├── rbe3.scm │ └── rbe4.scm ├── original-edward-kmett-code ├── N.hs ├── N2.hs └── deBruijn │ ├── NB.hs │ └── NB2.hs ├── scheme-helpers ├── pmatch.scm └── test-macro.scm ├── scheme-version └── nbe.scm └── wills-notes.md /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2020 William E. Byrd and Edward Kmett 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 | # normalization-by-evaluation 2 | 3 | Relational normalization-by-evaluation (nbe) in miniKanren/alphaKanren. 4 | 5 | The Scheme, miniKanren, and alphaKanren code is based on Edward Kmett's (non-relational) Haskell code, presented to Will Byrd during a mini-tutorial on nbe. 6 | 7 | Edward live codes a normalization-by-evaluation system in this video [YOW! Lambda Jam 2020 - Edward Kmett - Cadenza Building Fast Functional Languages Fast](https://www.youtube.com/watch?v=25RmUl88jSw), starting at 6:30 8 | 9 | This repository includes the code from Michael Ballyntyne's 'faster-miniKanren' repo--please see the 'faster-miniKanren/LICENSE' file for the license for that code. For all other code in this repository, please see the 'LICENSE' file in the top-level directory of this repository. 10 | 11 | Thank you to Michael Arntzenius for a previous tutorial on normalization-by-evaluation, and a separate attempt at implementing normalization-by-evaluation relationally. 12 | 13 | Thanks to Nada Amin for suggesting improved file names, for adding tests, and for discussing normalization-by-evaluation, and its connections to relational programming. 14 | 15 | During a hacking session with Michael Ballantyne, Michael found and fixed a subtle tagging error in the naive miniKanren implementation; we also implemented the `fresh` variable generation used in the naive miniKanren implementation during that session, which seems to side-step the need for nominal logic programming or de Bruijn representation of variables. 16 | 17 | Nada Amin asked whether, using this "naive" freshness technique, `(lambda (x) x)` and `(lambda (y) y)` normalize to the name expression. This led to a conversation about using nbe using the "naive" freshness implementation for nominal-logic style relational programming. 18 | 19 | 20 | Currently the most interesting relational versions seem to be the "naive" versions, especially `miniKanren-version/naive/nbe-untagged.scm` and `miniKanren-version/naive/nbe-untagged-extended.scm`. The `miniKanren-version/naive/nbe-untagged-full.scm` interpreter is work-in-progress, but (hopefully!) will eventually contain the entire unoptimized Barliman-style relational interpeter. 21 | 22 | The nominal logic programming version of nbe using alphaKanren does not seem to work fully relationally. Also, I think the implementation of alphaKanren itself may rely on a subtle use of `eq?` which is sound in R5RS, but whose behavior is undefined in R6RS. Beware! If anything, this code is probably most useful for trying to understand possible issues and limitations with relational programming in alphaKanren, since I've never gotten this style of interpreter to work fully relationally. 23 | 24 | Also, please be careful with the non-"naive" versions of the relational code in general, since some of these versions are half-finished experiments. The untagged "naive" versions of the code are the most appealing to me, anyway, and are closest in spirit to the "classic" relational Scheme interpreters in miniKanren. 25 | 26 | 27 | Code in this repository: 28 | 29 | ##### `original-edward-kmett-code` 30 | ###### `N.hs` (nbe for untyped call-by-value lambda-calculus in Haskell, from Edward Kmett's mini-tutorial for Will Byrd) 31 | ###### `N1.hs` (nbe for typed call-by-value lambda-calculus in Haskell, from Edward Kmett's mini-tutorial for Will Byrd) 32 | ###### `deBruijn` 33 | ####### `NB.hs` (nbe for untyped call-by-value lambda-calculus in Haskell, using de Bruijn representation of variables, from Edward Kmett's mini-tutorial for Will Byrd) 34 | ####### `NB2.hs` (nbe for typed call-by-value lambda-calculus in Haskell, using de Bruijn representation of variables, from Edward Kmett's mini-tutorial for Will Byrd) 35 | ##### `scheme-version` (Scheme version of Edward Kmett's Haskell nbe code) 36 | ###### `nbe.scm` (Will Byrd's translation of `N.hs` into Scheme, using the `pmatch` pattern matcher; tested under Chez Scheme) 37 | ###### `pmatch.scm` (Oleg Kiselyov's simple pattern matcher, implemented using continuation-passing macros) 38 | ##### `miniKanren-version` (miniKanren versions of Edward Kmett's Haskell nbe code) 39 | ###### `naive` (relational nbe code) 40 | ####### `nbe.scm` (naive relational nbe code, with tagging of expressions and values) 41 | ####### `nbe-tests.scm` 42 | ####### `nbe-untagged.scm` (naive relational nbe code, with extra tagging removed) 43 | ####### `nbe-untagged-tests.scm` 44 | ####### `nbe-untagged-extended.scm` (naive relational nbe code, with extra tagging removed, and the language extended) 45 | ####### `nbe-untagged-extended-tests.scm` 46 | ###### `deBruijn` (relational nbe code using de Bruijn notation for variables) 47 | ####### `nbe.scm` (nbe code using de Bruijn notation) 48 | ####### `nbe-tests.scm` 49 | ####### `nbe-extended.scm` (nbe code using de Bruijn notation, with the language extended) 50 | ####### `nbe-extended-tests.scm` 51 | ###### `faster-miniKanren` (Michael Ballantyne's implementation of [faster-miniKanren](https://github.com/michaelballantyne/faster-miniKanren)) 52 | ##### `alphaKanren-version` (*broken* nominal logic programming version of relational nbe code) 53 | ###### `nbe.scm` (Will Byrd's translation of miniKanren `nbe.scm` into alphaKanren; tested under Chez Scheme) 54 | ###### `nbe-tests.scm` (Will Byrd's tests for the alphaKanren version of `nbe.scm`; tested under Chez Scheme) 55 | ###### `alphaKanren` (Dan Friedman and Will Byrd's implementation of [alphaKanren](https://github.com/webyrd/alphaKanren)) 56 | ##### `scheme-helpers` (helper code that might be useful in multiple Scheme-related directories) 57 | ###### `test-macro.scm` (simple test macro, adapted from Oleg Kislyov's test macro used in the original Kanren) 58 | ###### `pmatch.scm` (Oleg Kiselyov's simple pattern-matching macro) 59 | 60 | Useful tutorials on normalization-by-evaluation: 61 | 62 | ['Cadenza Building Fast Functional Languages Fast' by Edward Kmett, YOW! Lambda Jam 2020](https://www.youtube.com/watch?v=25RmUl88jSw), starting at 6:30 63 | 64 | ['Checking Dependent Types with Normalization by Evaluation: A Tutorial' by David Thrane Christiansen](http://www.davidchristiansen.dk/tutorials/nbe/) 65 | 66 | [Normalization by Evaluation - David Christiansen (PL Wonks)](https://www.youtube.com/watch?v=CpADWJa-f28) 67 | -------------------------------------------------------------------------------- /alphaKanren-version/alphaKanren/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 William E. Byrd 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | 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, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /alphaKanren-version/alphaKanren/README.md: -------------------------------------------------------------------------------- 1 | alphaKanren 2 | =========== 3 | 4 | WEB -- Revised 31 August 02020. 5 | 6 | In the alphaKanren on GitHub, 7 | 8 | (fresh (a) (exist (x) (hash x a) (== a x))) 9 | 10 | and 11 | 12 | (fresh (a) (exist (x) (== a x) (hash x a))) 13 | 14 | have identical behavior--both signal errors. 15 | 16 | I have changed the alphaKanren code so that `hash` projects its 17 | first argument, making (fresh (a) (exist (x) (== a x) (hash x a))) 18 | legal but (fresh (a) (exist (x) (hash x a) (== a x))) illegal. 19 | This is inherently unrelational. Is there a way to fix this 20 | behavior? 21 | 22 | `tie` does not project its first argument. The first argument to 23 | `tie` must be a nom/atom, not a unification variable bound to a 24 | nom/atom. 25 | 26 | ------- 27 | 28 | Improved version of the nominal logic programming extensions to miniKanren, based on alphaProlog. 29 | Importantly, this version signals an error if the first argument to hash or tie is not a ground nom (atom). 30 | 31 | Original code is described in: 32 | 33 | William E. Byrd and Daniel P. Friedman 34 | alphaKanren: A Fresh Name in Nominal Logic Programming 35 | In Proceedings of the 2007 Workshop on Scheme and Functional Programming, 36 | Universite Laval Technical Report DIUL-RT-0701, pp. 79-90 37 | 38 | Revised version of the paper: 39 | 40 | http://webyrd.net/alphamk/alphamk.pdf 41 | -------------------------------------------------------------------------------- /alphaKanren-version/nbe.scm: -------------------------------------------------------------------------------- 1 | (load "alphaKanren/alphaKanren.scm") 2 | 3 | (define lookupo 4 | (lambda (a env val) 5 | (exist (y v env^) 6 | (== `((,y . ,v) . ,env^) env) 7 | (conde 8 | ((== a y) (== v val)) 9 | ((lookupo a env^ val) 10 | ;; Non-relational warning! This call to `hash` should come 11 | ;; after the call to lookupo, since the first argument to 12 | ;; hash *must* be a ground (a nom, or a unification variable 13 | ;; bound to nom). Perhaps fix this using delayed goals. 14 | ;; Thought: with delayed goals, would it be sound to unify 15 | ;; the first argument to a hash or tie with a fresh nom, if 16 | ;; no other goals are left to be run other than the fresh/nom 17 | ;; calls? 18 | (hash a y) ;; a =/= y 19 | ))))) 20 | 21 | (define eval-expro 22 | (lambda (env expr val) 23 | (conde 24 | ((exist (x) 25 | (== `(Var ,x) expr) 26 | (lookupo x env val))) 27 | ((exist (e1 e2 f v) 28 | (== `(App ,e1 ,e2) expr) 29 | (eval-expro env e1 f) 30 | (eval-expro env e2 v) 31 | (apply-expro f v val))) 32 | ((fresh (a) 33 | (exist (body) 34 | (hash a env) 35 | (== `(Lam ,(tie a body)) expr) 36 | (== `(Closure ,env ,(tie a body)) val))))))) 37 | 38 | (define apply-expro 39 | (lambda (f v val) 40 | (conde 41 | ((fresh (a) 42 | (exist (env body) 43 | (== `(Closure ,env ,(tie a body)) f) 44 | (eval-expro `((,a . ,v) . ,env) body val)))) 45 | ((exist (n) 46 | (== `(N ,n) f) 47 | (== `(N (NApp ,n ,v)) val)))))) 48 | 49 | (define uneval-valueo 50 | (lambda (v expr) 51 | (conde 52 | ((fresh (a a^) 53 | (exist (env body body^ bv) 54 | (== `(Closure ,env ,(tie a body)) v) 55 | (== `(Lam ,(tie a^ body^)) expr) 56 | (eval-expro `((,a . (N (NVar ,a^))) . ,env) body bv) 57 | (uneval-valueo bv body^)))) 58 | ((exist (n) 59 | (== `(N ,n) v) 60 | (uneval-neutralo n expr)))))) 61 | 62 | (define uneval-neutralo 63 | (lambda (n expr) 64 | (conde 65 | ((exist (x) 66 | (== `(NVar ,x) n) 67 | (== `(Var ,x) expr))) 68 | ((exist (n^ v ne ve) 69 | (== `(NApp ,n^ ,v) n) 70 | (== `(App ,ne ,ve) expr) 71 | (uneval-neutralo n^ ne) 72 | (uneval-valueo v ve)))))) 73 | 74 | (define nfo 75 | (lambda (env t expr) 76 | (exist (v) 77 | (eval-expro env t v) 78 | (uneval-valueo v expr)))) 79 | 80 | (define main 81 | (lambda () 82 | (run* (result) 83 | (exist (id_ const_) 84 | (fresh (a) 85 | (eval-expro '() `(Lam ,(tie a `(Var ,a))) id_)) 86 | (fresh (a b) 87 | (eval-expro '() `(Lam ,(tie a `(Lam ,(tie b `(Var ,a))))) const_)) 88 | (fresh (a b) 89 | (eval-expro `((,a . ,id_) (,b . ,const_)) `(App (Var ,b) (Var ,a)) result)))))) 90 | 91 | ;; (printf "~s\n" (main)) 92 | ;; ((Closure ((a.0 Closure () (tie-tag a.1 (Var a.1)))) (tie-tag a.2 (Var a.0)))) 93 | -------------------------------------------------------------------------------- /miniKanren-version/deBruijn/nbe-extended-tests.scm: -------------------------------------------------------------------------------- 1 | (load "nbe-extended.scm") 2 | (load "../../scheme-helpers/test-macro.scm") 3 | 4 | (test "nfo-#f" 5 | (run* (q) 6 | (nfo '() (parse '#f) q)) 7 | '(#f)) 8 | 9 | (test "nfo-#t" 10 | (run* (q) 11 | (nfo '() (parse '#t) q)) 12 | '(#t)) 13 | 14 | (test "nfo-()-0" 15 | (run* (q) 16 | (nfo '() (parse '(quote ())) q)) 17 | '((quote ()))) 18 | 19 | (test "nfo-cons-0" 20 | (run* (q) 21 | (nfo '() (parse '(cons 3 4)) q)) 22 | '((cons 3 4))) 23 | 24 | (test "nfo-cons-1" 25 | (run* (q) 26 | (nfo '() (parse '(cons 3 (quote ()))) q)) 27 | '((cons 3 (quote ())))) 28 | 29 | (test "nfo-cons-2" 30 | (run* (q) 31 | (nfo '() (parse '(cons (cons 4 5) (quote ()))) q)) 32 | '((cons (cons 4 5) (quote ())))) 33 | 34 | (test "nfo-cons-3" 35 | (run* (q) 36 | (nfo '() (parse '(lambda (x) (cons (cons x 5) x))) q)) 37 | '((Lam (cons (cons (Var z) 5) (Var z))))) 38 | 39 | (test "nfo-car-0" 40 | (run* (q) 41 | (nfo '() (parse '(car (cons 3 4))) q)) 42 | '(3)) 43 | 44 | (test "nfo-car-1" 45 | (run* (q) 46 | (nfo '() (parse '(car (cons 3 (quote ())))) q)) 47 | '(3)) 48 | 49 | (test "nfo-car-2" 50 | (run* (q) 51 | (nfo '() (parse '(car (cons (cons 4 5) (quote ())))) q)) 52 | '((cons 4 5))) 53 | 54 | (test "nfo-car-3" 55 | (run* (q) 56 | (nfo '() (parse '(lambda (x) (car (cons (cons x 5) x)))) q)) 57 | '((Lam (cons (Var z) 5)))) 58 | 59 | (test "nfo-car-4" 60 | (run* (q) 61 | (nfo '() (parse '(lambda (x) (car x))) q)) 62 | '((Lam (car (Var z))))) 63 | 64 | (test "nfo-cdr-0" 65 | (run* (q) 66 | (nfo '() (parse '(cdr (cons 3 4))) q)) 67 | '(4)) 68 | 69 | (test "nfo-cdr-1" 70 | (run* (q) 71 | (nfo '() (parse '(cdr (cons 3 (quote ())))) q)) 72 | '((quote ()))) 73 | 74 | (test "nfo-cdr-2" 75 | (run* (q) 76 | (nfo '() (parse '(cdr (cons (cons 4 5) (quote ())))) q)) 77 | '((quote ()))) 78 | 79 | (test "nfo-cdr-3" 80 | (run* (q) 81 | (nfo '() (parse '(lambda (x) (cdr (cons (cons x 5) x)))) q)) 82 | '((Lam (Var z)))) 83 | 84 | (test "nfo-cdr-4" 85 | (run* (q) 86 | (nfo '() (parse '(lambda (x) (cdr x))) q)) 87 | '((Lam (cdr (Var z))))) 88 | 89 | (test "nfo-null?-0" 90 | (run* (q) 91 | (nfo '() (parse '(null? (quote ()))) q)) 92 | '(#t)) 93 | 94 | (test "nfo-null?-1" 95 | (run* (q) 96 | (nfo '() (parse '(null? 5)) q)) 97 | '(#f)) 98 | 99 | (test "nfo-null?-2" 100 | (run* (q) 101 | (nfo '() (parse '(null? #t)) q)) 102 | '(#f)) 103 | 104 | (test "nfo-null?-3" 105 | (run* (q) 106 | (nfo '() (parse '(null? (lambda (x) x))) q)) 107 | '(#f)) 108 | 109 | (test "nfo-null?-4" 110 | (run* (q) 111 | (nfo '() (parse '(null? (cons 3 4))) q)) 112 | '(#f)) 113 | 114 | (test "nfo-pair?-0" 115 | (run* (q) 116 | (nfo '() (parse '(pair? (quote ()))) q)) 117 | '(#f)) 118 | 119 | (test "nfo-pair?-1" 120 | (run* (q) 121 | (nfo '() (parse '(pair? 5)) q)) 122 | '(#f)) 123 | 124 | (test "nfo-pair?-2" 125 | (run* (q) 126 | (nfo '() (parse '(pair? #t)) q)) 127 | '(#f)) 128 | 129 | (test "nfo-pair?-3" 130 | (run* (q) 131 | (nfo '() (parse '(pair? (lambda (x) x))) q)) 132 | '(#f)) 133 | 134 | (test "nfo-pair?-4" 135 | (run* (q) 136 | (nfo '() (parse '(pair? (cons 3 4))) q)) 137 | '(#t)) 138 | 139 | (test "nfo-if-0" 140 | (run* (q) 141 | (nfo '() (parse '(if #f 5 6)) q)) 142 | '(6)) 143 | 144 | (test "nfo-if-1" 145 | (run* (q) 146 | (nfo '() (parse '(if #t 5 6)) q)) 147 | '(5)) 148 | 149 | (test "nfo-if-2" 150 | (run* (q) 151 | (nfo '() (parse '(if (if #t #f #t) 5 6)) q)) 152 | '(6)) 153 | 154 | (test "nfo-if-3" 155 | (run* (q) 156 | (nfo '() (parse '(if (if #f #f #t) 5 6)) q)) 157 | '(5)) 158 | 159 | (test "nfo-if-4" 160 | (run* (q) 161 | (nfo '() (parse '(if (if #f #f #t) (if #f 5 6) (if #t 7 8))) q)) 162 | '(6)) 163 | 164 | (test "nfo-if-5" 165 | (run* (q) 166 | (nfo '() (parse '(if (if #t #f #t) (if #f 5 6) (if #t 7 8))) q)) 167 | '(7)) 168 | 169 | (test "nfo-if-6" 170 | (run* (q) 171 | (nfo '() (parse '(lambda (x) (if x (if #f 5 6) (if #t 7 8)))) q)) 172 | '((Lam (if (Var z) 6 7)))) 173 | 174 | (test "nfo-if/null?-0" 175 | (run* (q) 176 | (nfo '() 177 | (parse '(lambda (x) (if (null? x) (if #f 5 6) (if #t 7 8)))) 178 | q)) 179 | '((Lam (if (null? (Var z)) 6 7)))) 180 | 181 | (test "nfo-if/pair?-0" 182 | (run* (q) 183 | (nfo '() 184 | (parse '(lambda (x) (if (pair? x) (if #f 5 6) (if #t 7 8)))) 185 | q)) 186 | '((Lam (if (pair? (Var z)) 6 7)))) 187 | -------------------------------------------------------------------------------- /miniKanren-version/deBruijn/nbe-extended.scm: -------------------------------------------------------------------------------- 1 | ;; evaluator for extended lambda-calculus 2 | 3 | (load "../faster-miniKanren/mk-vicare.scm") 4 | (load "../faster-miniKanren/mk.scm") 5 | (load "../../scheme-helpers/pmatch.scm") 6 | 7 | (define ntho 8 | (lambda (n xs val) 9 | (conde 10 | ((== 'z n) 11 | (fresh (rest) 12 | (== `(,val . ,rest) xs))) 13 | ((fresh (n-1 y rest) 14 | (== `(s ,n-1) n) 15 | (== `(,y . ,rest) xs) 16 | (ntho n-1 rest val)))))) 17 | 18 | (define evalo 19 | (lambda (env expr val) 20 | (conde 21 | ((== #f expr) (== #f val)) 22 | ((== #t expr) (== #t val)) 23 | ((== '(quote ()) expr) (== '() val)) 24 | ((numbero expr) (== expr val)) 25 | ((fresh (body) 26 | (== `(Lam ,body) expr) 27 | (== `(Clo ,env ,body) val))) 28 | ((fresh (x) 29 | (== `(Var ,x) expr) 30 | (ntho x env val))) 31 | ((fresh (e v) 32 | (== `(null? ,e) expr) 33 | (evalo env e v) 34 | (nullo env v val))) 35 | ((fresh (e v) 36 | (== `(pair? ,e) expr) 37 | (evalo env e v) 38 | (pairo env v val))) 39 | ((fresh (e v) 40 | (== `(car ,e) expr) 41 | (evalo env e v) 42 | (caro env v val))) 43 | ((fresh (e v) 44 | (== `(cdr ,e) expr) 45 | (evalo env e v) 46 | (cdro env v val))) 47 | ((fresh (e1 e2 v1 v2) 48 | (== `(cons ,e1 ,e2) expr) 49 | (== `(Pair ,v1 ,v2) val) 50 | (evalo env e1 v1) 51 | (evalo env e2 v2))) 52 | ((fresh (e1 e2 e3 v1) 53 | (== `(if ,e1 ,e2 ,e3) expr) 54 | (evalo env e1 v1) 55 | (ifo env v1 e2 e3 val))) 56 | ((fresh (f x fv xv) 57 | (== `(App ,f ,x) expr) 58 | (evalo env f fv) 59 | (evalo env x xv) 60 | (appo fv xv val)))))) 61 | 62 | (define appo 63 | (lambda (f v val) 64 | (conde 65 | ((fresh (n) 66 | (== `(N ,n) f) 67 | (== `(N (NApp ,n ,v)) val))) 68 | ((fresh (env body) 69 | (== `(Clo ,env ,body) f) 70 | (evalo `(,v . ,env) body val)))))) 71 | 72 | (define nullo 73 | (lambda (env v val) 74 | (conde 75 | ((== '() v) (== #t val)) 76 | ((== #f v) (== #f val)) 77 | ((== #t v) (== #f val)) 78 | ((numbero v) (== #f val)) 79 | ((fresh (v1 v2) 80 | (== `(Pair ,v1 ,v2) v) 81 | (== #f val))) 82 | ((fresh (env^ body) 83 | (== `(Clo ,env^ ,body) v) 84 | (== #f val))) 85 | ((fresh (n) 86 | (== `(N ,n) v) 87 | (== `(N (NNull? ,n)) val)))))) 88 | 89 | (define pairo 90 | (lambda (env v val) 91 | (conde 92 | ((fresh (v1 v2) 93 | (== `(Pair ,v1 ,v2) v) 94 | (== #t val))) 95 | ((== '() v) (== #f val)) 96 | ((== #f v) (== #f val)) 97 | ((== #t v) (== #f val)) 98 | ((numbero v) (== #f val)) 99 | ((fresh (env^ body) 100 | (== `(Clo ,env^ ,body) v) 101 | (== #f val))) 102 | ((fresh (n) 103 | (== `(N ,n) v) 104 | (== `(N (NPair? ,n)) val)))))) 105 | 106 | (define caro 107 | (lambda (env v val) 108 | (conde 109 | ((fresh (v1 v2) 110 | (== `(Pair ,v1 ,v2) v) 111 | (== v1 val))) 112 | ((fresh (n) 113 | (== `(N ,n) v) 114 | (== `(N (NCar ,n)) val)))))) 115 | 116 | (define cdro 117 | (lambda (env v val) 118 | (conde 119 | ((fresh (v1 v2) 120 | (== `(Pair ,v1 ,v2) v) 121 | (== v2 val))) 122 | ((fresh (n) 123 | (== `(N ,n) v) 124 | (== `(N (NCdr ,n)) val)))))) 125 | 126 | (define ifo 127 | (lambda (env v1 e2 e3 val) 128 | (conde 129 | ((== #t v1) 130 | (evalo env e2 val)) 131 | ((== #f v1) 132 | (evalo env e3 val)) 133 | ((fresh (n1 v2 v3) 134 | (== `(N ,n1) v1) 135 | (== `(N (NIf ,n1 ,v2 ,v3)) val) 136 | (evalo env e2 v2) 137 | (evalo env e3 v3)))))) 138 | 139 | (define unevalo 140 | (lambda (d val expr) 141 | (conde 142 | ((== #f val) (== #f expr)) 143 | ((== #t val) (== #t expr)) 144 | ((== '() val) (== '(quote ()) expr)) 145 | ((numbero val) (== val expr)) 146 | ((fresh (n) 147 | (== `(N ,n) val) 148 | (unevalNo d n expr))) 149 | ((fresh (v1 v2 e1 e2) 150 | (== `(Pair ,v1 ,v2) val) 151 | (== `(cons ,e1 ,e2) expr) 152 | (unevalo d v1 e1) 153 | (unevalo d v2 e2))) 154 | ((fresh (env body v expr^) 155 | (== `(Clo ,env ,body) val) 156 | (== `(Lam ,expr^) expr) 157 | (evalo `((N (NVar ,d)) . ,env) body v) 158 | (unevalo `(s ,d) v expr^)))))) 159 | 160 | (define unevalNo 161 | (lambda (d n expr) 162 | (conde 163 | ((fresh (n^ d-1 d-n-1) 164 | (== `(NVar ,n^) n) 165 | (== `(Var ,d-n-1) expr) 166 | (== `(s ,d-1) d) 167 | (minuso d-1 n^ d-n-1))) 168 | ((fresh (n1 e1) 169 | (== `(NNull? ,n1) n) 170 | (== `(null? ,e1) expr) 171 | (unevalNo d n1 e1))) 172 | ((fresh (n1 e1) 173 | (== `(NPair? ,n1) n) 174 | (== `(pair? ,e1) expr) 175 | (unevalNo d n1 e1))) 176 | ((fresh (n1 e1) 177 | (== `(NCar ,n1) n) 178 | (== `(car ,e1) expr) 179 | (unevalNo d n1 e1))) 180 | ((fresh (n1 e1) 181 | (== `(NCdr ,n1) n) 182 | (== `(cdr ,e1) expr) 183 | (unevalNo d n1 e1))) 184 | ((fresh (f x fe xe) 185 | (== `(NApp ,f ,x) n) 186 | (== `(App ,fe ,xe) expr) 187 | (unevalNo d f fe) 188 | (unevalo d x xe))) 189 | ((fresh (n1 v2 v3 e1 e2 e3) 190 | (== `(NIf ,n1 ,v2 ,v3) n) 191 | (== `(if ,e1 ,e2 ,e3) expr) 192 | (unevalNo d n1 e1) 193 | (unevalo d v2 e2) 194 | (unevalo d v3 e3)))))) 195 | 196 | (define minuso 197 | (lambda (n m n-m) 198 | (conde 199 | ((== 'z m) (== n n-m)) 200 | ((fresh (m-1 n-1) 201 | (== `(s ,m-1) m) 202 | (== `(s ,n-1) n) 203 | (minuso n-1 m-1 n-m)))))) 204 | 205 | (define nfo 206 | (lambda (env expr expr^) 207 | (fresh (v) 208 | (evalo env expr v) 209 | (unevalo 'z v expr^)))) 210 | 211 | 212 | ;;; `parse` only handles closed terms. 213 | (define parse 214 | (lambda (expr) 215 | (letrec ((parse 216 | (lambda (expr env) 217 | (pmatch expr 218 | (#f #f) 219 | (#t #t) 220 | ((quote ()) '(quote ())) 221 | (,n (guard (number? n)) n) 222 | (,x (guard (symbol? x)) 223 | (let ((v (member x env))) 224 | (unless v 225 | (error 'parse 226 | "parser only handles closed terms")) 227 | (let ((n (- (length env) (length v)))) 228 | (let ((pn (peano n))) 229 | `(Var ,pn))))) 230 | ((lambda (,x) ,body) 231 | `(Lam ,(parse body `(,x . ,env)))) 232 | ((null? ,e) 233 | `(null? ,(parse e env))) 234 | ((pair? ,e) 235 | `(pair? ,(parse e env))) 236 | ((car ,e) 237 | `(car ,(parse e env))) 238 | ((cdr ,e) 239 | `(cdr ,(parse e env))) 240 | ((cons ,e1 ,e2) 241 | `(cons ,(parse e1 env) ,(parse e2 env))) 242 | ((if ,e1 ,e2 ,e3) 243 | `(if ,(parse e1 env) 244 | ,(parse e2 env) 245 | ,(parse e3 env))) 246 | ((,e1 ,e2) 247 | `(App ,(parse e1 env) ,(parse e2 env))))))) 248 | (parse expr '())))) 249 | 250 | ;; `peano` assumes `n` is non-negative 251 | (define peano 252 | (lambda (n) 253 | (cond 254 | ((zero? n) 'z) 255 | (else `(s ,(peano (sub1 n))))))) 256 | 257 | (define main 258 | (lambda () 259 | (run 1 (expr^) 260 | (fresh (id_ const_) 261 | (evalo '() `(Lam (Var z)) id_) 262 | (evalo '() `(Lam (Lam (Var (s z)))) const_) 263 | (nfo `(,id_ ,const_) `(App (Var (s z)) (Var z)) expr^))))) 264 | -------------------------------------------------------------------------------- /miniKanren-version/deBruijn/nbe-tests.scm: -------------------------------------------------------------------------------- 1 | (load "nbe.scm") 2 | (load "../../scheme-helpers/test-macro.scm") 3 | 4 | 5 | (test "peano-0" 6 | (peano 0) 7 | 'z) 8 | 9 | (test "peano-1" 10 | (peano 1) 11 | '(s z)) 12 | 13 | (test "peano-2" 14 | (peano 2) 15 | '(s (s z))) 16 | 17 | (test "peano-5" 18 | (peano 5) 19 | '(s (s (s (s (s z)))))) 20 | 21 | 22 | (test "parse-0" 23 | (parse '((lambda (x) (lambda (y) (lambda (z) z))) (lambda (w) w))) 24 | '(App (Lam (Lam (Lam (Var z)))) (Lam (Var z)))) 25 | 26 | (test "parse-1" 27 | (parse '(lambda (a) (lambda (b) b))) 28 | '(Lam (Lam (Var z)))) 29 | 30 | (test "parse-2" 31 | (parse '(lambda (a) (lambda (a) a))) 32 | '(Lam (Lam (Var z)))) 33 | 34 | (test "parse-3" 35 | (parse '((lambda (z) (lambda (z) (lambda (z) z))) (lambda (z) z))) 36 | '(App (Lam (Lam (Lam (Var z)))) (Lam (Var z)))) 37 | 38 | 39 | (test "ntho-1" 40 | (run* (q) (ntho 'z '() q)) 41 | '()) 42 | 43 | (test "ntho-2" 44 | (run* (q) (ntho 'z '(42) q)) 45 | '(42)) 46 | 47 | (test "ntho-3" 48 | (run* (q) (ntho 'z '(42 137) q)) 49 | '(42)) 50 | 51 | (test "ntho-4" 52 | (run* (q) (ntho '(s z) '(42 137) q)) 53 | '(137)) 54 | 55 | (test "ntho-5" 56 | (run* (q) (ntho '(s z) '(42) q)) 57 | '()) 58 | 59 | (test "ntho-6" 60 | (run* (q) (ntho '(s (s z)) '(42 137 31) q)) 61 | '(31)) 62 | 63 | (test "ntho-7" 64 | (run* (q) (ntho q '(42 137 31) 31)) 65 | '((s (s z)))) 66 | 67 | (test "ntho-8" 68 | (run* (q) (ntho '(s (s z)) q 31)) 69 | '((_.0 _.1 31 . _.2))) 70 | 71 | 72 | (test "minuso-1" 73 | (run* (q) 74 | (minuso '(s (s (s (s (s z))))) '(s (s (s z))) q)) 75 | '((s (s z)))) 76 | 77 | (test "minuso-2" 78 | (run* (q) 79 | (minuso '(s (s (s z))) q '(s (s (s (s (s z))))))) 80 | '()) 81 | 82 | (test "minuso-3" 83 | (run 3 (n) 84 | (minuso n n 'z)) 85 | '(z (s z) (s (s z)))) 86 | 87 | #| 88 | ;;; WEB - diverges instead of fails, alas 89 | (test "minuso-4" 90 | (run 1 (n n2) 91 | (minuso n n '(s ,n2))) 92 | '???) 93 | |# 94 | 95 | 96 | (test "evalo-1" 97 | (run* (q) (evalo '() '(Lam (Var z)) q)) 98 | '((Clo () (Var z)))) 99 | 100 | (test "evalo-2" 101 | (run* (q) (evalo '() '(Lam (App (Lam (Var z)) (Lam (Var z)))) q)) 102 | '((Clo () (App (Lam (Var z)) (Lam (Var z)))))) 103 | 104 | (test "evalo-3" 105 | (run* (q) (evalo '((Lam (Var z))) '(Var z) q)) 106 | '((Lam (Var z)))) 107 | 108 | (test "evalo-4" 109 | (run* (q) (evalo '((Lam (Var z)) (Clo () (App (Lam (Var z)) (Lam (Var z))))) '(Var (s z)) q)) 110 | '((Clo () (App (Lam (Var z)) (Lam (Var z)))))) 111 | 112 | (test "evalo-5" 113 | (run* (q) (evalo '() '(App (Lam (Var z)) (Lam (Var z))) q)) 114 | '((Clo () (Var z)))) 115 | 116 | 117 | (test "unevalo-1" 118 | (run* (q) (unevalo 'z '(Clo () (Var z)) q)) 119 | '((Lam (Var z)))) 120 | 121 | (test "unevalo-2" 122 | (run 1 (v1 v2 n1 n2 e) 123 | (=/= v1 v2) 124 | (fresh (e^) 125 | (== `(App . ,e^) e)) 126 | (unevalo n1 v1 e) 127 | (unevalo n2 v2 e)) 128 | '(((N (NApp (NVar z) (N (NVar z)))) 129 | (N (NApp (NVar (s z)) (N (NVar (s z))))) 130 | (s _.0) 131 | (s (s _.0)) 132 | (App (Var _.0) (Var _.0))))) 133 | 134 | #| 135 | ;;; WEB -- I claim that this should diverge! 136 | (test "unevalo-3" 137 | (run 1 (v1 v2 e) 138 | (=/= v1 v2) 139 | (fresh (e^) 140 | (== `(App . ,e^) e)) 141 | (unevalo 'z v1 e) 142 | (unevalo 'z v2 e)) 143 | '???) 144 | |# 145 | 146 | 147 | (test "nfo-1" 148 | (run 10 (q) (nfo '() q '(Lam (Var z)))) 149 | '((Lam (Var z)) 150 | (App (Lam (Lam (Var z))) (Lam _.0)) 151 | (Lam (App (Lam (Var (s z))) (Lam _.0))) ;; (lambda (x) ((lambda (y) x) (lambda . _.0))) 152 | (Lam (App (Lam (Var z)) (Var z))) 153 | (App (Lam (Var z)) (Lam (Var z))) 154 | (Lam (App (Lam (Var (s z))) (Var z))) 155 | (App (Lam (Lam (App (Lam (Var (s z))) (Lam _.0)))) (Lam _.1)) 156 | (Lam (App (Lam (App (Lam (Var (s (s z)))) (Lam _.0))) (Lam _.1))) 157 | (App (Lam (Lam (App (Lam (Var z)) (Var z)))) (Lam _.0)) 158 | (App (Lam (Lam (App (Lam (Var (s z))) (Var z)))) (Lam _.0)))) 159 | 160 | (test "nfo-2" 161 | (run 10 (e1 e2 ne) 162 | (=/= e1 e2) 163 | (=/= e1 ne) 164 | (=/= e2 ne) 165 | (nfo '() e1 ne) 166 | (nfo '() e2 ne)) 167 | '((((App (Lam (Lam (Var z))) (Lam _.0)) 168 | (App (Lam (Lam (Var z))) (Lam _.1)) 169 | (Lam (Var z))) 170 | (=/= ((_.0 _.1)))) 171 | ((App (Lam (Lam (Var z))) (Lam _.0)) 172 | (Lam (App (Lam (Var (s z))) (Lam _.1))) 173 | (Lam (Var z))) 174 | ((App (Lam (Lam (Var z))) (Lam _.0)) 175 | (Lam (App (Lam (Var z)) (Var z))) 176 | (Lam (Var z))) 177 | ((App (Lam (Lam (Var z))) (Lam _.0)) 178 | (App (Lam (Var z)) (Lam (Var z))) 179 | (Lam (Var z))) 180 | ((App (Lam (Lam (Var z))) (Lam _.0)) 181 | (Lam (App (Lam (Var (s z))) (Var z))) 182 | (Lam (Var z))) 183 | ((App (Lam (Lam (Var z))) (Lam _.0)) 184 | (App (Lam (Lam (App (Lam (Var (s z))) (Lam _.1)))) (Lam _.2)) 185 | (Lam (Var z))) 186 | ((App (Lam (Lam (Var z))) (Lam _.0)) 187 | (Lam (App (Lam (App (Lam (Var (s (s z)))) (Lam _.1))) (Lam _.2))) 188 | (Lam (Var z))) 189 | ((App (Lam (Var z)) (Lam (Var z))) 190 | (App (Lam (Lam (Var z))) (Lam _.0)) 191 | (Lam (Var z))) 192 | ((App (Lam (Var z)) (Lam (Var z))) 193 | (Lam (App (Lam (Var (s z))) (Lam _.0))) 194 | (Lam (Var z))) 195 | ((App (Lam (Lam (Var z))) (Lam _.0)) 196 | (App (Lam (Lam (App (Lam (Var z)) (Var z)))) (Lam _.1)) 197 | (Lam (Var z))))) 198 | 199 | (test "nfo-3" 200 | (run 5 (e1 e2 ne) 201 | (=/= e1 e2) 202 | (=/= e1 ne) 203 | (=/= e2 ne) 204 | (=/= `(Lam (Var z)) ne) 205 | (nfo '() e1 ne) 206 | (nfo '() e2 ne)) 207 | '((((App (Lam (Lam (Lam (Var z)))) (Lam _.0)) 208 | (App (Lam (Lam (Lam (Var z)))) (Lam _.1)) 209 | (Lam (Lam (Var z)))) 210 | (=/= ((_.0 _.1)))) 211 | ((App (Lam (Lam (Lam (Var z)))) (Lam _.0)) 212 | (Lam (Lam (App (Lam (Var (s z))) (Lam _.1)))) 213 | (Lam (Lam (Var z)))) 214 | ((App (Lam (Lam (Lam (Var z)))) (Lam _.0)) 215 | (Lam (App (Lam (Lam (Var z))) (Lam _.1))) 216 | (Lam (Lam (Var z)))) 217 | ((App (Lam (Lam (Lam (Var z)))) (Lam _.0)) 218 | (Lam (Lam (App (Lam (Var z)) (Var z)))) 219 | (Lam (Lam (Var z)))) 220 | ((App (Lam (Lam (Lam (Var z)))) (Lam _.0)) 221 | (App (Lam (Var z)) (Lam (Lam (Var z)))) 222 | (Lam (Lam (Var z)))))) 223 | 224 | (test "nfo-4" 225 | (run 5 (e1 e2 ne) 226 | (=/= e1 e2) 227 | (=/= e1 ne) 228 | (=/= e2 ne) 229 | (=/= `(Lam (Var z)) ne) 230 | (=/= `(Lam (Lam (Var z))) ne) 231 | (nfo '() e1 ne) 232 | (nfo '() e2 ne)) 233 | '((((App (Lam (Lam (Lam (Var (s z))))) (Lam _.0)) 234 | (App (Lam (Lam (Lam (Var (s z))))) (Lam _.1)) 235 | (Lam (Lam (Var (s z))))) 236 | (=/= ((_.0 _.1)))) 237 | ((App (Lam (Lam (Lam (Var (s z))))) (Lam _.0)) 238 | (Lam (Lam (App (Lam (Var (s (s z)))) (Lam _.1)))) 239 | (Lam (Lam (Var (s z))))) 240 | ((App (Lam (Lam (Lam (Var (s z))))) (Lam _.0)) 241 | (Lam (App (Lam (Lam (Var (s (s z))))) (Lam _.1))) 242 | (Lam (Lam (Var (s z))))) 243 | ((App (Lam (Lam (Lam (Var (s z))))) (Lam _.0)) 244 | (App (Lam (Var z)) (Lam (Lam (Var (s z))))) 245 | (Lam (Lam (Var (s z))))) 246 | ((App (Lam (Lam (Lam (Var (s z))))) (Lam _.0)) 247 | (Lam (Lam (App (Lam (Var (s (s z)))) (Var z)))) 248 | (Lam (Lam (Var (s z))))))) 249 | 250 | (test "nfo-5" 251 | (run 5 (e1 e2 ne) 252 | (=/= e1 e2) 253 | (=/= e1 ne) 254 | (=/= e2 ne) 255 | (=/= `(Lam (Var z)) ne) 256 | (=/= `(Lam (Lam (Var z))) ne) 257 | (=/= `(Lam (Lam (Var (s z)))) ne) 258 | (nfo '() e1 ne) 259 | (nfo '() e2 ne)) 260 | '((((App (Lam (Lam (Lam (Lam (Var z))))) (Lam _.0)) 261 | (App (Lam (Lam (Lam (Lam (Var z))))) (Lam _.1)) 262 | (Lam (Lam (Lam (Var z))))) 263 | (=/= ((_.0 _.1)))) 264 | ((App (Lam (Lam (Lam (Lam (Var z))))) (Lam _.0)) 265 | (Lam (App (Lam (Lam (Lam (Var z)))) (Lam _.1))) 266 | (Lam (Lam (Lam (Var z))))) 267 | ((App (Lam (Lam (Lam (Lam (Var z))))) (Lam _.0)) 268 | (Lam (Lam (Lam (App (Lam (Var (s z))) (Lam _.1))))) 269 | (Lam (Lam (Lam (Var z))))) 270 | ((App (Lam (Lam (Lam (Lam (Var z))))) (Lam _.0)) 271 | (Lam (Lam (App (Lam (Lam (Var z))) (Lam _.1)))) 272 | (Lam (Lam (Lam (Var z))))) 273 | ((App (Lam (Lam (Lam (Lam (Var z))))) (Lam _.0)) 274 | (App (Lam (Var z)) (Lam (Lam (Lam (Var z))))) 275 | (Lam (Lam (Lam (Var z))))))) 276 | 277 | #| 278 | ;;; WEB -- I claim that this should diverge! 279 | (test "nfo-6" 280 | (run 1 (e1 e2 ne e) 281 | (=/= e1 e2) 282 | (=/= e1 ne) 283 | (=/= e2 ne) 284 | (== `(App . ,e) ne) 285 | (nfo '() e1 ne) 286 | (nfo '() e2 ne)) 287 | '???) 288 | |# 289 | 290 | 291 | (test "nfo-8" 292 | ;; Show these two expressions have the same normal form: 293 | ;; 294 | ;; ((lambda (x) (lambda (y) (lambda (z) z))) (lambda (w) w)) 295 | ;; (lambda (a) (lambda (b) b)) 296 | ;; 297 | (run* (nf1 nf2) 298 | (nfo '() '(App (Lam (Lam (Lam (Var z)))) (Lam (Var z))) nf1) 299 | (nfo '() '(Lam (Lam (Var z))) nf2)) 300 | '(((Lam (Lam (Var z))) (Lam (Lam (Var z))))) 301 | ) 302 | 303 | (test "nfo-9" 304 | ;; Show these two expressions have the same normal form: 305 | ;; 306 | ;; ((lambda (x) (lambda (y) (lambda (z) z))) (lambda (w) w)) 307 | ;; (lambda (a) (lambda (b) b)) 308 | ;; 309 | (run* (nf1 nf2) 310 | (nfo '() (parse '((lambda (x) (lambda (y) (lambda (z) z))) (lambda (w) w))) nf1) 311 | (nfo '() (parse '(lambda (a) (lambda (b) b))) nf2)) 312 | '(((Lam (Lam (Var z))) (Lam (Lam (Var z))))) 313 | ) 314 | 315 | (test "nfo-10" 316 | ;; Show these two expressions have the same normal form: 317 | ;; 318 | ;; ((lambda (z) (lambda (z) (lambda (z) z))) (lambda (z) z)) 319 | ;; (lambda (a) (lambda (a) a)) 320 | ;; 321 | (run* (nf1 nf2) 322 | (nfo '() (parse '((lambda (z) (lambda (z) (lambda (z) z))) (lambda (z) z))) nf1) 323 | (nfo '() (parse '(lambda (a) (lambda (a) a))) nf2)) 324 | '(((Lam (Lam (Var z))) (Lam (Lam (Var z))))) 325 | ) 326 | 327 | 328 | (test "nfo-11" 329 | (run* (q) (nfo '() (parse '((lambda (x) x) (lambda (x) (x x)))) q)) 330 | '((Lam (App (Var z) (Var z))))) 331 | 332 | (test "nfo-11b" 333 | (run* (q) (nfo '() (parse '(lambda (x) (x x))) q)) 334 | '((Lam (App (Var z) (Var z))))) 335 | 336 | (test "nfo-11c" 337 | (run* (q) (nfo '() '(Lam (App (Var z) (Var z))) q)) 338 | '((Lam (App (Var z) (Var z))))) 339 | 340 | 341 | (test "evalo-b1" 342 | (run* (q) (evalo '() '(Lam (App (Var z) (Var z))) q)) 343 | '((Clo () (App (Var z) (Var z))))) 344 | 345 | (test "unevalo-b1" 346 | (run* (q) (unevalo 'z '(Clo () (App (Var z) (Var z))) q)) 347 | '((Lam (App (Var z) (Var z))))) 348 | 349 | (test "evalo-b2" 350 | (run* (q) (evalo `((N (NVar z))) '(App (Var z) (Var z)) q)) 351 | '((N (NApp (NVar z) (N (NVar z)))))) 352 | 353 | (test "unevalo-b2" 354 | (run* (q) (unevalo '(s z) '(N (NApp (NVar z) (N (NVar z)))) q)) 355 | '((App (Var z) (Var z)))) 356 | 357 | (test "unevalNo-b1" 358 | (run* (q) (unevalNo '(s z) '(NApp (NVar z) (N (NVar z))) q)) 359 | '((App (Var z) (Var z)))) 360 | 361 | 362 | 363 | 364 | (test "appo-0" 365 | (run 3 (f v val) 366 | (appo f v val)) 367 | '(((N _.0) _.1 (N (NApp _.0 _.1))) 368 | ((Clo _.0 (Lam _.1)) _.2 (Clo (_.2 . _.0) _.1)) 369 | ((Clo _.0 (Var z)) _.1 _.1))) 370 | 371 | (test "appo-1" 372 | (run 1 (f v) 373 | (appo f v '(Clo () (Var z)))) 374 | '(((Clo _.0 (Var z)) (Clo () (Var z))))) 375 | 376 | (test "appo-2" 377 | (run 3 (f v n) 378 | (appo f v `(N (NApp ,n ,v)))) 379 | '(((N _.0) _.1 _.0) 380 | ((Clo ((N (NApp _.0 _.1)) . _.2) (Var (s z))) _.1 _.0) 381 | ((Clo (_.0 (N (NApp _.1 _.2)) . _.3) (Var (s (s z)))) _.2 _.1))) 382 | 383 | (test "appo-3" 384 | (run* (f v n val) 385 | (== `(N ,n) f) 386 | (appo f v val)) 387 | '(((N _.0) _.1 _.0 (N (NApp _.0 _.1))))) 388 | 389 | (test "nfo-capture" 390 | (run* (q) 391 | (nfo 392 | '() 393 | `(Lam 394 | (App (Lam (Lam (Var (s z)))) 395 | (Var z))) 396 | q)) 397 | '((Lam (Lam (Var (s z)))))) 398 | -------------------------------------------------------------------------------- /miniKanren-version/deBruijn/nbe.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../../scheme-helpers/pmatch.scm") 4 | 5 | (define ntho 6 | (lambda (n xs val) 7 | (conde 8 | ((== 'z n) 9 | (fresh (rest) 10 | (== `(,val . ,rest) xs))) 11 | ((fresh (n-1 y rest) 12 | (== `(s ,n-1) n) 13 | (== `(,y . ,rest) xs) 14 | (ntho n-1 rest val)))))) 15 | 16 | (define evalo 17 | (lambda (env expr val) 18 | (conde 19 | ((fresh (body) 20 | (== `(Lam ,body) expr) 21 | (== `(Clo ,env ,body) val))) 22 | ((fresh (x) 23 | (== `(Var ,x) expr) 24 | (ntho x env val))) 25 | ((fresh (f x fv xv) 26 | (== `(App ,f ,x) expr) 27 | (evalo env f fv) 28 | (evalo env x xv) 29 | (appo fv xv val)))))) 30 | 31 | (define appo 32 | (lambda (f v val) 33 | (conde 34 | ((fresh (n) 35 | (== `(N ,n) f) 36 | (== `(N (NApp ,n ,v)) val))) 37 | ((fresh (env body) 38 | (== `(Clo ,env ,body) f) 39 | (evalo `(,v . ,env) body val)))))) 40 | 41 | (define unevalo 42 | (lambda (d val expr) 43 | (conde 44 | ((fresh (n) 45 | (== `(N ,n) val) 46 | (unevalNo d n expr))) 47 | ((fresh (env body v expr^) 48 | (== `(Clo ,env ,body) val) 49 | (== `(Lam ,expr^) expr) 50 | (evalo `((N (NVar ,d)) . ,env) body v) 51 | (unevalo `(s ,d) v expr^)))))) 52 | 53 | (define unevalNo 54 | (lambda (d n expr) 55 | (conde 56 | ((fresh (n^ d-1 d-n-1) 57 | (== `(NVar ,n^) n) 58 | (== `(Var ,d-n-1) expr) 59 | (== `(s ,d-1) d) 60 | (minuso d-1 n^ d-n-1))) 61 | ((fresh (f x fe xe) 62 | (== `(NApp ,f ,x) n) 63 | (== `(App ,fe ,xe) expr) 64 | (unevalNo d f fe) 65 | (unevalo d x xe)))))) 66 | 67 | (define minuso 68 | (lambda (n m n-m) 69 | (conde 70 | ((== 'z m) (== n n-m)) 71 | ((fresh (m-1 n-1) 72 | (== `(s ,m-1) m) 73 | (== `(s ,n-1) n) 74 | (minuso n-1 m-1 n-m)))))) 75 | 76 | (define nfo 77 | (lambda (env expr expr^) 78 | (fresh (v) 79 | (evalo env expr v) 80 | (unevalo 'z v expr^)))) 81 | 82 | 83 | 84 | ;;; `parse` only handles closed terms. 85 | (define parse 86 | (lambda (expr) 87 | (letrec ((parse 88 | (lambda (expr env) 89 | (pmatch expr 90 | (,x (guard (symbol? x)) 91 | (let ((v (member x env))) 92 | (unless v 93 | (error 'parse 94 | "parser only handles closed terms")) 95 | (let ((n (- (length env) (length v)))) 96 | (let ((pn (peano n))) 97 | `(Var ,pn))))) 98 | ((lambda (,x) ,body) 99 | `(Lam ,(parse body `(,x . ,env)))) 100 | ((,e1 ,e2) 101 | `(App ,(parse e1 env) ,(parse e2 env))))))) 102 | (parse expr '())))) 103 | 104 | ;; `peano` assumes `n` is non-negative 105 | (define peano 106 | (lambda (n) 107 | (cond 108 | ((zero? n) 'z) 109 | (else `(s ,(peano (sub1 n))))))) 110 | 111 | (define main 112 | (lambda () 113 | (run 1 (expr^) 114 | (fresh (id_ const_) 115 | (evalo '() `(Lam (Var z)) id_) 116 | (evalo '() `(Lam (Lam (Var (s z)))) const_) 117 | (nfo `(,id_ ,const_) `(App (Var (s z)) (Var z)) expr^))))) 118 | -------------------------------------------------------------------------------- /miniKanren-version/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 | (defrel (appendo l s out) 22 | (conde 23 | [(== '() l) (== s out)] 24 | [(fresh (a d res) 25 | (== `(,a . ,d) l) 26 | (== `(,a . ,res) out) 27 | (appendo d s res))])) 28 | 29 | (test "4" 30 | (run* (q) (appendo '(a b c) '(d e) q)) 31 | '((a b c d e))) 32 | 33 | (test "5" 34 | (run* (q) (appendo q '(d e) '(a b c d e))) 35 | '((a b c))) 36 | 37 | (test "6" 38 | (run* (q) (appendo '(a b c) q '(a b c d e))) 39 | '((d e))) 40 | 41 | (test "7" 42 | (run 5 (q) 43 | (fresh (l s out) 44 | (appendo l s out) 45 | (== `(,l ,s ,out) q))) 46 | '((() _.0 _.0) 47 | ((_.0) _.1 (_.0 . _.1)) 48 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 49 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 50 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)))) 51 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/chez.scm: -------------------------------------------------------------------------------- 1 | (eval-when (compile) (optimize-level 3)) 2 | 3 | (module mk (run run* defrel == =/= fresh conde symbolo numbero stringo 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 | -------------------------------------------------------------------------------- /miniKanren-version/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 4))) 70 | '()) 71 | 72 | (test "=/=-10" 73 | (run* (q) 74 | (fresh (x y z) 75 | (== x y) 76 | (== y z) 77 | (== z 4) 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 4))) 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 () 276 | (defrel (foo x) 277 | (fresh (a) 278 | (=/= x a))) 279 | (run* (q) (fresh (a) (foo a)))) 280 | '(_.0)) 281 | 282 | (test "=/=-36" 283 | (let () 284 | (defrel (foo x) 285 | (fresh (a) 286 | (=/= x a))) 287 | (run* (q) (fresh (b) (foo b)))) 288 | '(_.0)) 289 | 290 | (test "=/=-37" 291 | (run* (q) 292 | (fresh (x y) 293 | (== `(,x ,y) q) 294 | (=/= x y))) 295 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 296 | 297 | (test "=/=-37b" 298 | (run* (q) 299 | (fresh (a d) 300 | (== `(,a . ,d) q) 301 | (=/= q `(5 . 6)))) 302 | '(((_.0 . _.1) (=/= ((_.0 5) (_.1 6)))))) 303 | 304 | (test "=/=-37c" 305 | (run* (q) 306 | (fresh (a d) 307 | (== `(,a . ,d) q) 308 | (=/= q `(5 . 6)) 309 | (== a 3))) 310 | '((3 . _.0))) 311 | 312 | (test "=/=-38" 313 | (run* (q) 314 | (fresh (x y) 315 | (== `(,x ,y) q) 316 | (=/= y x))) 317 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 318 | 319 | (test "=/=-39" 320 | (run* (q) 321 | (fresh (x y) 322 | (== `(,x ,y) q) 323 | (=/= x y) 324 | (=/= y x))) 325 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 326 | 327 | (test "=/=-40" 328 | (run* (q) 329 | (fresh (x y) 330 | (== `(,x ,y) q) 331 | (=/= x y) 332 | (=/= x y))) 333 | '(((_.0 _.1) (=/= ((_.0 _.1)))))) 334 | 335 | (test "=/=-41" 336 | (run* (q) (=/= q 5) (=/= 5 q)) 337 | '((_.0 (=/= ((_.0 5)))))) 338 | 339 | (test "=/=-42" 340 | (run* (q) 341 | (fresh (x y) 342 | (== `(,x ,y) q) 343 | (=/= `(,x ,y) `(5 6)) 344 | (=/= x 5))) 345 | '(((_.0 _.1) (=/= ((_.0 5)))))) 346 | 347 | (test "=/=-43" 348 | (run* (q) 349 | (fresh (x y) 350 | (== `(,x ,y) q) 351 | (=/= x 5) 352 | (=/= `(,x ,y) `(5 6)))) 353 | '(((_.0 _.1) (=/= ((_.0 5)))))) 354 | 355 | (test "=/=-44" 356 | (run* (q) 357 | (fresh (x y) 358 | (=/= x 5) 359 | (=/= `(,x ,y) `(5 6)) 360 | (== `(,x ,y) q))) 361 | '(((_.0 _.1) (=/= ((_.0 5)))))) 362 | 363 | (test "=/=-45" 364 | (run* (q) 365 | (fresh (x y) 366 | (=/= 5 x) 367 | (=/= `(,x ,y) `(5 6)) 368 | (== `(,x ,y) q))) 369 | '(((_.0 _.1) (=/= ((_.0 5)))))) 370 | 371 | (test "=/=-46" 372 | (run* (q) 373 | (fresh (x y) 374 | (=/= 5 x) 375 | (=/= `( ,y ,x) `(6 5)) 376 | (== `(,x ,y) q))) 377 | '(((_.0 _.1) (=/= ((_.0 5)))))) 378 | 379 | (test "=/=-47" 380 | (run* (x) 381 | (fresh (y z) 382 | (=/= x `(,y 2)) 383 | (== x `(,z 2)))) 384 | '((_.0 2))) 385 | 386 | (test "=/=-48" 387 | (run* (x) 388 | (fresh (y z) 389 | (=/= x `(,y 2)) 390 | (== x `((,z) 2)))) 391 | '(((_.0) 2))) 392 | 393 | (test "=/=-49" 394 | (run* (x) 395 | (fresh (y z) 396 | (=/= x `((,y) 2)) 397 | (== x `(,z 2)))) 398 | '((_.0 2))) 399 | 400 | (defrel (distincto l) 401 | (conde 402 | ((== l '())) 403 | ((fresh (a) (== l `(,a)))) 404 | ((fresh (a ad dd) 405 | (== l `(,a ,ad . ,dd)) 406 | (=/= a ad) 407 | (distincto `(,a . ,dd)) 408 | (distincto `(,ad . ,dd)))))) 409 | 410 | (test "=/=-50" 411 | (run* (q) 412 | (distincto `(2 3 ,q))) 413 | '((_.0 (=/= ((_.0 2)) ((_.0 3)))))) 414 | 415 | (defrel (rembero1 x ls out) 416 | (conde 417 | ((== '() ls) (== '() out)) 418 | ((fresh (a d res) 419 | (== `(,a . ,d) ls) 420 | (rembero1 x d res) 421 | (conde 422 | ((== a x) (== out res)) 423 | ((== `(,a . ,res) out))))))) 424 | 425 | (test "=/=-51" 426 | (run* (q) (rembero1 '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) (rembero1 'a '(a b c) '(a b c))) 431 | '(_.0)) 432 | 433 | (defrel (rembero2 x ls out) 434 | (conde 435 | ((== '() ls) (== '() out)) 436 | ((fresh (a d res) 437 | (== `(,a . ,d) ls) 438 | (rembero2 x d res) 439 | (conde 440 | ((== a x) (== out res)) 441 | ((=/= a x) (== `(,a . ,res) out))))))) 442 | 443 | (test "=/=-53" 444 | (run* (q) (rembero2 'a '(a b a c) q)) 445 | '((b c))) 446 | 447 | (test "=/=-54" 448 | (run* (q) (rembero2 'a '(a b c) '(a b c))) 449 | '()) 450 | 451 | (test "=/=-55" 452 | (run 1 (q) (=/= q #f)) 453 | '((_.0 (=/= ((_.0 #f)))))) 454 | 455 | (test "non watch-var pair implies satisfied" 456 | (run 1 (a b c d) 457 | (=/= (cons a c) 458 | (cons b d)) 459 | (== c '(1 . 2)) 460 | (== d '(1 . 3))) 461 | '((_.0 _.1 (1 . 2) (1 . 3)))) 462 | 463 | (test "null, pair, and atomic types order correctly in =/= reification" 464 | (run 1 (q) 465 | (=/= q '()) 466 | (=/= q '(foo)) 467 | (=/= q 5)) 468 | '((_.0 (=/= ((_.0 5)) 469 | ((_.0 ())) 470 | ((_.0 (foo))))))) 471 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/full-interp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "main.rkt") 4 | 5 | (provide evalo) 6 | 7 | (include "full-interp.scm") 8 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | #'(defrel (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 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/mk-guile.scm: -------------------------------------------------------------------------------- 1 | (define-module (faster-minikanren mk-guile) 2 | #:export (run run* defrel 3 | == =/= 4 | fresh 5 | conde 6 | symbolo numbero stringo 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 and-map) 25 | (define ormap or-map) 26 | 27 | (define generate-temporary gensym) 28 | 29 | (include-from-path "faster-minikanren/matche.scm") 30 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide run run* defrel 4 | == =/= 5 | fresh 6 | conde 7 | symbolo numbero stringo 8 | absento 9 | project 10 | var? 11 | always-wrap-reified?) 12 | 13 | (require "private-unstable.rkt") 14 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/numbers.scm: -------------------------------------------------------------------------------- 1 | (defrel (appendo l s out) 2 | (conde 3 | [(== '() l) (== s out)] 4 | [(fresh (a d res) 5 | (== `(,a . ,d) l) 6 | (== `(,a . ,res) out) 7 | (appendo d s res))])) 8 | 9 | (define build-num 10 | (lambda (n) 11 | (cond 12 | ((odd? n) 13 | (cons 1 14 | (build-num (quotient (- n 1) 2)))) 15 | ((and (not (zero? n)) (even? n)) 16 | (cons 0 17 | (build-num (quotient n 2)))) 18 | ((zero? n) '())))) 19 | 20 | (defrel (zeroo n) 21 | (== '() n)) 22 | 23 | (defrel (poso n) 24 | (fresh (a d) 25 | (== `(,a . ,d) n))) 26 | 27 | (defrel (>1o n) 28 | (fresh (a ad dd) 29 | (== `(,a ,ad . ,dd) n))) 30 | 31 | (defrel (full-addero b x y r c) 32 | (conde 33 | ((== 0 b) (== 0 x) (== 0 y) (== 0 r) (== 0 c)) 34 | ((== 1 b) (== 0 x) (== 0 y) (== 1 r) (== 0 c)) 35 | ((== 0 b) (== 1 x) (== 0 y) (== 1 r) (== 0 c)) 36 | ((== 1 b) (== 1 x) (== 0 y) (== 0 r) (== 1 c)) 37 | ((== 0 b) (== 0 x) (== 1 y) (== 1 r) (== 0 c)) 38 | ((== 1 b) (== 0 x) (== 1 y) (== 0 r) (== 1 c)) 39 | ((== 0 b) (== 1 x) (== 1 y) (== 0 r) (== 1 c)) 40 | ((== 1 b) (== 1 x) (== 1 y) (== 1 r) (== 1 c)))) 41 | 42 | (defrel (addero d n m r) 43 | (conde 44 | ((== 0 d) (== '() m) (== n r)) 45 | ((== 0 d) (== '() n) (== m r) 46 | (poso m)) 47 | ((== 1 d) (== '() m) 48 | (addero 0 n '(1) r)) 49 | ((== 1 d) (== '() n) (poso m) 50 | (addero 0 '(1) m r)) 51 | ((== '(1) n) (== '(1) m) 52 | (fresh (a c) 53 | (== `(,a ,c) r) 54 | (full-addero d 1 1 a c))) 55 | ((== '(1) n) (gen-addero d n m r)) 56 | ((== '(1) m) (>1o n) (>1o r) 57 | (addero d '(1) n r)) 58 | ((>1o n) (gen-addero d n m r)))) 59 | 60 | (defrel (gen-addero d n m r) 61 | (fresh (a b c e x y z) 62 | (== `(,a . ,x) n) 63 | (== `(,b . ,y) m) (poso y) 64 | (== `(,c . ,z) r) (poso z) 65 | (full-addero d a b c e) 66 | (addero e x y z))) 67 | 68 | (defrel (pluso n m k) 69 | (addero 0 n m k)) 70 | 71 | (defrel (minuso n m k) 72 | (pluso m k n)) 73 | 74 | (defrel (*o n m p) 75 | (conde 76 | ((== '() n) (== '() p)) 77 | ((poso n) (== '() m) (== '() p)) 78 | ((== '(1) n) (poso m) (== m p)) 79 | ((>1o n) (== '(1) m) (== n p)) 80 | ((fresh (x z) 81 | (== `(0 . ,x) n) (poso x) 82 | (== `(0 . ,z) p) (poso z) 83 | (>1o m) 84 | (*o x m z))) 85 | ((fresh (x y) 86 | (== `(1 . ,x) n) (poso x) 87 | (== `(0 . ,y) m) (poso y) 88 | (*o m n p))) 89 | ((fresh (x y) 90 | (== `(1 . ,x) n) (poso x) 91 | (== `(1 . ,y) m) (poso y) 92 | (odd-*o x n m p))))) 93 | 94 | (defrel (odd-*o x n m p) 95 | (fresh (q) 96 | (bound-*o q p n m) 97 | (*o x m q) 98 | (pluso `(0 . ,q) m p))) 99 | 100 | (defrel (bound-*o q p n m) 101 | (conde 102 | ((== '() q) (poso p)) 103 | ((fresh (a0 a1 a2 a3 x y z) 104 | (== `(,a0 . ,x) q) 105 | (== `(,a1 . ,y) p) 106 | (conde 107 | ((== '() n) 108 | (== `(,a2 . ,z) m) 109 | (bound-*o x y z '())) 110 | ((== `(,a3 . ,z) n) 111 | (bound-*o x y z m))))))) 112 | 113 | (defrel (=lo n m) 114 | (conde 115 | ((== '() n) (== '() m)) 116 | ((== '(1) n) (== '(1) m)) 117 | ((fresh (a x b y) 118 | (== `(,a . ,x) n) (poso x) 119 | (== `(,b . ,y) m) (poso y) 120 | (=lo x y))))) 121 | 122 | (defrel (1o m)) 126 | ((fresh (a x b y) 127 | (== `(,a . ,x) n) (poso x) 128 | (== `(,b . ,y) m) (poso y) 129 | (1o b) (=lo n b) (pluso r b n)) 207 | ((== '(1) b) (poso q) (pluso r '(1) n)) 208 | ((== '() b) (poso q) (== r n)) 209 | ((== '(0 1) b) 210 | (fresh (a ad dd) 211 | (poso dd) 212 | (== `(,a ,ad . ,dd) n) 213 | (exp2 n '() q) 214 | (fresh (s) 215 | (splito n dd r s)))) 216 | ((fresh (a ad add ddd) 217 | (conde 218 | ((== '(1 1) b)) 219 | ((== `(,a ,ad ,add . ,ddd) b)))) 220 | (1o n) (== '(1) q) 251 | (fresh (s) 252 | (splito n b s '(1)))) 253 | ((fresh (q1 b2) 254 | (== `(0 . ,q1) q) 255 | (poso q1) 256 | (1o q) 272 | (fresh (q1 nq1) 273 | (pluso q1 '(1) q) 274 | (repeated-mul n q1 nq1) 275 | (*o nq1 n nq))))) 276 | 277 | (defrel (expo b q n) 278 | (logo n b q '())) 279 | 280 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/private-unstable.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require racket/list 6 | racket/include) 7 | 8 | ;; extra stuff for racket 9 | ;; due mostly to samth 10 | (module compatibility racket/base 11 | (provide (all-defined-out)) 12 | 13 | (require racket/list) 14 | 15 | (define (list-sort f l) (sort l f)) 16 | 17 | (define (remp f l) (filter-not f l)) 18 | 19 | (define (call-with-string-output-port f) 20 | (define p (open-output-string)) 21 | (f p) 22 | (get-output-string p)) 23 | 24 | (define (exists f l) (ormap f l)) 25 | 26 | (define for-all andmap) 27 | 28 | (define (find f l) 29 | (cond [(memf f l) => car] [else #f])) 30 | 31 | (define memp memf)) 32 | 33 | (require (submod "." compatibility)) 34 | 35 | (define empty-intmap (hasheq)) 36 | (define (intmap-count m) (hash-count m)) 37 | (define (intmap-ref m k) (hash-ref m k (lambda () unbound))) 38 | (define (intmap-set m k v) (hash-set m k v)) 39 | 40 | (include "mk.scm") 41 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/simple-interp.scm: -------------------------------------------------------------------------------- 1 | (defrel (evalo expr val) 2 | (eval-expro expr '() val)) 3 | 4 | (defrel (eval-expro expr env val) 5 | (conde 6 | ((fresh (rator rand x body env^ a) 7 | (== `(,rator ,rand) expr) 8 | (eval-expro rator env `(closure ,x ,body ,env^)) 9 | (eval-expro rand env a) 10 | (eval-expro body `((,x . ,a) . ,env^) val))) 11 | ((fresh (x body) 12 | (== `(lambda (,x) ,body) expr) 13 | (symbolo x) 14 | (== `(closure ,x ,body ,env) val) 15 | (not-in-envo 'lambda env))) 16 | ((symbolo expr) (lookupo expr env val)))) 17 | 18 | (defrel (not-in-envo x env) 19 | (conde 20 | ((== '() env)) 21 | ((fresh (y v rest) 22 | (== `((,y . ,v) . ,rest) env) 23 | (=/= y x) 24 | (not-in-envo x rest))))) 25 | 26 | (defrel (lookupo x env t) 27 | (conde 28 | ((fresh (y v rest) 29 | (== `((,y . ,v) . ,rest) env) (== y x) 30 | (== v t))) 31 | ((fresh (y v rest) 32 | (== `((,y . ,v) . ,rest) env) (=/= y x) 33 | (lookupo x rest t))))) 34 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 "simple-interp.scm") 32 | (load "test-simple-interp.scm") 33 | 34 | (printf "test-quines\n") 35 | (load "test-quines.scm") 36 | 37 | (printf "test-numbers\n") 38 | (load "numbers.scm") 39 | (load "test-numbers.scm") 40 | 41 | (load "full-interp.scm") 42 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/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 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/test-infer.scm: -------------------------------------------------------------------------------- 1 | (defrel (!- exp env t) 2 | (conde 3 | [(symbolo exp) (lookupo exp env t)] 4 | [(fresh (x e t-x t-e) 5 | (== `(lambda (,x) ,e) exp) 6 | (symbolo x) 7 | (not-in-envo 'lambda env) 8 | (== `(-> ,t-x ,t-e) t) 9 | (!- e `((,x . ,t-x) . ,env) t-e))] 10 | [(fresh (rator rand t-x) 11 | (== `(,rator ,rand) exp) 12 | (!- rator env `(-> ,t-x ,t)) 13 | (!- rand env t-x))])) 14 | 15 | (defrel (lookupo x env t) 16 | (fresh (rest y v) 17 | (== `((,y . ,v) . ,rest) env) 18 | (conde 19 | ((== y x) (== v t)) 20 | ((=/= y x) (lookupo x rest t))))) 21 | 22 | (defrel (not-in-envo x env) 23 | (conde 24 | ((== '() env)) 25 | ((fresh (y v rest) 26 | (== `((,y . ,v) . ,rest) env) 27 | (=/= y x) 28 | (not-in-envo x rest))))) 29 | 30 | (test "types" 31 | (run 10 (q) (fresh (t exp) (!- exp '() t) (== `(,exp => ,t) q))) 32 | '((((lambda (_.0) _.0) => (-> _.1 _.1)) (sym _.0)) 33 | (((lambda (_.0) (lambda (_.1) _.1)) 34 | => 35 | (-> _.2 (-> _.3 _.3))) 36 | (=/= ((_.0 lambda))) 37 | (sym _.0 _.1)) 38 | (((lambda (_.0) (lambda (_.1) _.0)) 39 | => 40 | (-> _.2 (-> _.3 _.2))) 41 | (=/= ((_.0 _.1)) ((_.0 lambda))) 42 | (sym _.0 _.1)) 43 | ((((lambda (_.0) _.0) (lambda (_.1) _.1)) => (-> _.2 _.2)) 44 | (sym _.0 _.1)) 45 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.2))) 46 | => 47 | (-> _.3 (-> _.4 (-> _.5 _.5)))) 48 | (=/= ((_.0 lambda)) ((_.1 lambda))) 49 | (sym _.0 _.1 _.2)) 50 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.1))) 51 | => 52 | (-> _.3 (-> _.4 (-> _.5 _.4)))) 53 | (=/= ((_.0 lambda)) ((_.1 _.2)) ((_.1 lambda))) 54 | (sym _.0 _.1 _.2)) 55 | (((lambda (_.0) (_.0 (lambda (_.1) _.1))) 56 | => 57 | (-> (-> (-> _.2 _.2) _.3) _.3)) 58 | (=/= ((_.0 lambda))) 59 | (sym _.0 _.1)) 60 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.0))) 61 | => 62 | (-> _.3 (-> _.4 (-> _.5 _.3)))) 63 | (=/= ((_.0 _.1)) ((_.0 _.2)) ((_.0 lambda)) ((_.1 lambda))) 64 | (sym _.0 _.1 _.2)) 65 | (((lambda (_.0) (lambda (_.1) (_.1 _.0))) 66 | => 67 | (-> _.2 (-> (-> _.2 _.3) _.3))) 68 | (=/= ((_.0 _.1)) ((_.0 lambda))) 69 | (sym _.0 _.1)) 70 | ((((lambda (_.0) _.0) (lambda (_.1) (lambda (_.2) _.2))) 71 | => 72 | (-> _.3 (-> _.4 _.4))) 73 | (=/= ((_.1 lambda))) 74 | (sym _.0 _.1 _.2)))) 75 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/test-numbers.scm: -------------------------------------------------------------------------------- 1 | (test "test 1" 2 | (let ((N2 (build-num 2)) 3 | (N3 (build-num 3))) 4 | (run* (q) (*o N2 N3 q))) 5 | '((0 1 1))) 6 | 7 | (test "test 2" 8 | (let ((N6 (build-num 6))) 9 | (run* (q) 10 | (fresh (n m) 11 | (*o n m N6) 12 | (== `(,n ,m) q)))) 13 | '(((1) (0 1 1)) ((0 1 1) (1)) ((0 1) (1 1)) ((1 1) (0 1)))) 14 | 15 | (test "sums" 16 | (run 5 (q) 17 | (fresh (x y z) 18 | (pluso x y z) 19 | (== `(,x ,y ,z) q))) 20 | '((_.0 () _.0) 21 | (() (_.0 . _.1) (_.0 . _.1)) 22 | ((1) (1) (0 1)) 23 | ((1) (0 _.0 . _.1) (1 _.0 . _.1)) 24 | ((1) (1 1) (0 0 1)))) 25 | 26 | (test "factors" 27 | (let ((N24 (build-num 24))) 28 | (run* (q) 29 | (fresh (x y) 30 | (*o x y N24) 31 | (== `(,x ,y ,N24) q)))) 32 | '(((1) (0 0 0 1 1) (0 0 0 1 1)) 33 | ((0 0 0 1 1) (1) (0 0 0 1 1)) 34 | ((0 1) (0 0 1 1) (0 0 0 1 1)) 35 | ((0 0 1) (0 1 1) (0 0 0 1 1)) 36 | ((0 0 0 1) (1 1) (0 0 0 1 1)) 37 | ((1 1) (0 0 0 1) (0 0 0 1 1)) 38 | ((0 1 1) (0 0 1) (0 0 0 1 1)) 39 | ((0 0 1 1) (0 1) (0 0 0 1 1)))) 40 | 41 | (defrel (number-primo exp env val) 42 | (fresh (n) 43 | (== `(intexp ,n) exp) 44 | (== `(intval ,n) val) 45 | (not-in-envo 'numo env))) 46 | 47 | (defrel (sub1-primo exp env val) 48 | (fresh (e n n-1) 49 | (== `(sub1 ,e) exp) 50 | (== `(intval ,n-1) val) 51 | (not-in-envo 'sub1 env) 52 | (eval-expo e env `(intval ,n)) 53 | (minuso n '(1) n-1))) 54 | 55 | (defrel (zero?-primo exp env val) 56 | (fresh (e n) 57 | (== `(zero? ,e) exp) 58 | (conde 59 | ((zeroo n) (== #t val)) 60 | ((poso n) (== #f val))) 61 | (not-in-envo 'zero? env) 62 | (eval-expo e env `(intval ,n)))) 63 | 64 | (defrel (*-primo 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 | (defrel (if-primo exp env val) 74 | (fresh (e1 e2 e3 t) 75 | (== `(if ,e1 ,e2 ,e3) exp) 76 | (not-in-envo 'if env) 77 | (eval-expo e1 env t) 78 | (conde 79 | ((== #t t) (eval-expo e2 env val)) 80 | ((== #f t) (eval-expo e3 env val))))) 81 | 82 | (defrel (boolean-primo exp env val) 83 | (conde 84 | ((== #t exp) (== #t val)) 85 | ((== #f exp) (== #f val)))) 86 | 87 | (defrel (eval-expo exp env val) 88 | (conde 89 | ((boolean-primo exp env val)) 90 | ((number-primo exp env val)) 91 | ((sub1-primo exp env val)) 92 | ((zero?-primo exp env val)) 93 | ((*-primo exp env val)) 94 | ((if-primo exp env val)) 95 | ((symbolo exp) (lookupo exp env val)) 96 | ((fresh (rator rand x body env^ a) 97 | (== `(,rator ,rand) exp) 98 | (eval-expo rator env `(closure ,x ,body ,env^)) 99 | (eval-expo rand env a) 100 | (eval-expo body `((,x . ,a) . ,env^) val))) 101 | ((fresh (x body) 102 | (== `(lambda (,x) ,body) exp) 103 | (symbolo x) 104 | (== `(closure ,x ,body ,env) val) 105 | (not-in-envo 'lambda env))))) 106 | 107 | (defrel (not-in-envo x env) 108 | (conde 109 | ((fresh (y v rest) 110 | (== `((,y . ,v) . ,rest) env) 111 | (=/= y x) 112 | (not-in-envo x rest))) 113 | ((== '() env)))) 114 | 115 | (defrel (lookupo x env t) 116 | (fresh (rest y v) 117 | (== `((,y . ,v) . ,rest) env) 118 | (conde 119 | ((== y x) (== v t)) 120 | ((=/= y x) (lookupo x rest t))))) 121 | 122 | (test "push-down problems 2" 123 | (run* (q) 124 | (fresh (x a d) 125 | (absento 'intval x) 126 | (== 'intval a) 127 | (== `(,a . ,d) x))) 128 | '()) 129 | 130 | (test "push-down problems 3" 131 | (run* (q) 132 | (fresh (x a d) 133 | (== `(,a . ,d) x) 134 | (absento 'intval x) 135 | (== 'intval a))) 136 | '()) 137 | 138 | (test "push-down problems 4" 139 | (run* (q) 140 | (fresh (x a d) 141 | (== `(,a . ,d) x) 142 | (== 'intval a) 143 | (absento 'intval x))) 144 | '()) 145 | 146 | (test "push-down problems 6" 147 | (run* (q) 148 | (fresh (x a d) 149 | (== 'intval a) 150 | (== `(,a . ,d) x) 151 | (absento 'intval x))) 152 | '()) 153 | 154 | (test "push-down problems 1" 155 | (run* (q) 156 | (fresh (x a d) 157 | (absento 'intval x) 158 | (== `(,a . ,d) x) 159 | (== 'intval a))) 160 | '()) 161 | 162 | (test "push-down problems 5" 163 | (run* (q) 164 | (fresh (x a d) 165 | (== 'intval a) 166 | (absento 'intval x) 167 | (== `(,a . ,d) x))) 168 | '()) 169 | 170 | (test "zero?" 171 | (let ((N1 (build-num 1))) 172 | (run 1 (q) 173 | (eval-expo `(zero? (sub1 (intexp ,N1))) '() q))) 174 | '(#t)) 175 | 176 | (test "*" 177 | (let ((N2 (build-num 2)) 178 | (N3 (build-num 3)) 179 | (N6 (build-num 6))) 180 | (run 1 (q) 181 | (eval-expo `(* (intexp ,N3) (intexp ,N2)) '() `(intval ,N6)))) 182 | '(_.0)) 183 | 184 | (test "sub1" 185 | (let ((N6 (build-num 6)) 186 | (N7 (build-num 7))) 187 | (run 1 (q) 188 | (eval-expo q '() `(intval ,N6)) (== `(sub1 (intexp ,N7)) q))) 189 | '((sub1 (intexp (1 1 1))))) 190 | 191 | (test "sub1 bigger WAIT a minute" 192 | (let ((N6 (build-num 6)) 193 | (N8 (build-num 8))) 194 | (run 1 (q) 195 | (eval-expo q '() `(intval ,N6)) 196 | (== `(sub1 (sub1 (intexp ,N8))) q))) 197 | '((sub1 (sub1 (intexp (0 0 0 1)))))) 198 | 199 | (test "sub1 biggest WAIT a minute" 200 | (let ((N6 (build-num 6)) 201 | (N9 (build-num 9))) 202 | (run 1 (q) 203 | (eval-expo q '() `(intval ,N6)) 204 | (== `(sub1 (sub1 (sub1 (intexp ,N9)))) q))) 205 | '((sub1 (sub1 (sub1 (intexp (1 0 0 1))))))) 206 | 207 | (test "lots of programs to make a 6" 208 | (let ((N6 (build-num 6))) 209 | (run 12 (q) (eval-expo q '() `(intval ,N6)))) 210 | '((intexp (0 1 1)) 211 | (sub1 (intexp (1 1 1))) 212 | (* (intexp (1)) (intexp (0 1 1))) 213 | (* (intexp (0 1 1)) (intexp (1))) 214 | (if #t (intexp (0 1 1)) _.0) 215 | (* (intexp (0 1)) (intexp (1 1))) 216 | (if #f _.0 (intexp (0 1 1))) 217 | (sub1 (* (intexp (1)) (intexp (1 1 1)))) 218 | (((lambda (_.0) (intexp (0 1 1))) #t) 219 | (=/= ((_.0 numo))) 220 | (sym _.0)) 221 | (sub1 (* (intexp (1 1 1)) (intexp (1)))) 222 | (sub1 (sub1 (intexp (0 0 0 1)))) 223 | (sub1 (if #t (intexp (1 1 1)) _.0)))) 224 | 225 | (define rel-fact5 226 | (let ((N5 (build-num 5)) 227 | (N1 (build-num 1))) 228 | `((lambda (f) 229 | ((f f) (intexp ,N5))) 230 | (lambda (f) 231 | (lambda (n) 232 | (if (zero? n) 233 | (intexp ,N1) 234 | (* n ((f f) (sub1 n))))))))) 235 | 236 | (test "rel-fact5" 237 | (run* (q) (eval-expo rel-fact5 '() q)) 238 | (let ((N120 (build-num 120))) 239 | `((intval ,N120)))) 240 | 241 | (test "rel-fact5-backwards" 242 | (let ((N5 (build-num 5)) 243 | (N1 (build-num 1)) 244 | (N120 (build-num 120))) 245 | (run 1 (q) 246 | (eval-expo 247 | `((lambda (f) 248 | ((f ,q) (intexp ,N5))) 249 | (lambda (f) 250 | (lambda (n) 251 | (if (zero? n) 252 | (intexp ,N1) 253 | (* n ((f f) (sub1 n))))))) 254 | '() 255 | `(intval ,N120)))) 256 | `(f)) 257 | -------------------------------------------------------------------------------- /miniKanren-version/faster-miniKanren/test-simple-interp.scm: -------------------------------------------------------------------------------- 1 | (test "running backwards" 2 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 3 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 4 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 5 | (((lambda (x) (lambda (y) x)) 6 | ((lambda (_.0) _.0) (lambda (z) z))) 7 | (sym _.0)) 8 | (((lambda (_.0) _.0) 9 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 10 | (sym _.0)) 11 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 12 | (lambda (z) z)) 13 | (sym _.0)))) 14 | 15 | (test "eval-exp-lc 1" 16 | (run* (q) (evalo '(((lambda (x) (lambda (y) x)) (lambda (z) z)) (lambda (a) a)) q)) 17 | '((closure z z ()))) 18 | 19 | (test "eval-exp-lc 2" 20 | (run* (q) (evalo '((lambda (x) (lambda (y) x)) (lambda (z) z)) q)) 21 | '((closure y x ((x . (closure z z ())))))) 22 | 23 | (test "fully-running-backwards" 24 | (run 5 (q) 25 | (fresh (e v) 26 | (evalo e v) 27 | (== `(,e ==> ,v) q))) 28 | '((((lambda (_.0) _.1) 29 | ==> (closure _.0 _.1 ())) (sym _.0)) 30 | ((((lambda (_.0) _.0) (lambda (_.1) _.2)) 31 | ==> 32 | (closure _.1 _.2 ())) 33 | (sym _.0 _.1)) 34 | ((((lambda (_.0) (lambda (_.1) _.2)) (lambda (_.3) _.4)) 35 | ==> 36 | (closure _.1 _.2 ((_.0 . (closure _.3 _.4 ()))))) 37 | (=/= ((_.0 lambda))) 38 | (sym _.0 _.1 _.3)) 39 | ((((lambda (_.0) (_.0 _.0)) (lambda (_.1) _.1)) 40 | ==> 41 | (closure _.1 _.1 ())) 42 | (sym _.0 _.1)) 43 | ((((lambda (_.0) (_.0 _.0)) 44 | (lambda (_.1) (lambda (_.2) _.3))) 45 | ==> 46 | (closure _.2 _.3 ((_.1 . (closure _.1 (lambda (_.2) _.3) ()))))) 47 | (=/= ((_.1 lambda))) 48 | (sym _.0 _.1 _.2)))) 49 | -------------------------------------------------------------------------------- /miniKanren-version/naive/nbe-tests.scm: -------------------------------------------------------------------------------- 1 | (load "nbe.scm") 2 | (load "../faster-miniKanren/test-check.scm") 3 | 4 | (test "main" 5 | (run* (result) 6 | (fresh (id_ const_) 7 | (eval-expro '(Lam x (Var x)) '() id_) 8 | (eval-expro '(Lam x (Lam y (Var x))) '() const_) 9 | (eval-expro '(App (Var const) (Var id)) `((id . ,id_) (const . ,const_)) result))) 10 | '((Closure y (Var x) ((x Closure x (Var x) ()))))) 11 | 12 | (test "eval-expro-1" 13 | (run* (val) 14 | (eval-expro `(Lam z (Var z)) '() val)) 15 | '((Closure z (Var z) ()))) 16 | 17 | (test "eval-expro-2" 18 | (run* (val) 19 | (eval-expro 20 | `(App (Lam x (Lam y (Var x))) 21 | (Lam z (Var z))) 22 | '() 23 | val)) 24 | '((Closure y (Var x) ((x Closure z (Var z) ()))))) 25 | 26 | (test "uneval-valueo-0" 27 | (run 6 (val expr) 28 | (uneval-valueo '() val expr)) 29 | '(((N (NVar _.0)) 30 | (Var _.0)) 31 | ((N (NApp (NVar _.0) (N (NVar _.1)))) 32 | (App (Var _.0) (Var _.1))) 33 | (((Closure _.0 (Var _.0) _.1) 34 | (Lam _.2 (Var _.2))) 35 | (sym _.0 _.2)) 36 | (((Closure _.0 (Var _.1) ((_.1 N (NVar _.2)) . _.3)) 37 | (Lam _.4 (Var _.2))) 38 | (=/= ((_.0 _.1))) 39 | (sym _.0 _.1 _.4)) 40 | ((N (NApp (NApp (NVar _.0) (N (NVar _.1))) (N (NVar _.2)))) 41 | (App (App (Var _.0) (Var _.1)) (Var _.2))) 42 | (((Closure _.0 (Lam _.1 (Var _.1)) _.2) 43 | (Lam _.3 (Lam _.4 (Var _.4)))) 44 | (=/= ((_.3 _.4))) 45 | (sym _.0 _.1 _.3 _.4)))) 46 | 47 | (test "uneval-valueo-1" 48 | (run* (expr) 49 | (uneval-valueo '() '(Closure y (Var x) ((x Closure z (Var z) ()))) expr)) 50 | '(((Lam _.0 (Lam _.1 (Var _.1))) 51 | (=/= ((_.0 _.1))) 52 | (sym _.0 _.1)))) 53 | 54 | (test "eval-expro/uneval-valueo-2" 55 | (run* (result) 56 | (fresh (val) 57 | (eval-expro 58 | `(App (Lam x (Lam y (Var x))) 59 | (Lam z (Var z))) 60 | '() 61 | val) 62 | (uneval-valueo '() val result))) 63 | '(((Lam _.0 (Lam _.1 (Var _.1))) 64 | (=/= ((_.0 _.1))) (sym _.0 _.1)))) 65 | 66 | #| 67 | (test "eval-expro/uneval-valueo-2" 68 | (run* (result) 69 | (exist (val) 70 | (fresh (a b) 71 | (eval-expro 72 | '() 73 | `(App (Lam ,(tie a `(Lam ,(tie b `(Var ,a))))) 74 | (Lam ,(tie a `(Var ,a)))) 75 | val)) 76 | (uneval-valueo val result))) 77 | '((Lam (tie-tag a.0 (Lam (tie-tag a.1 (Var a.1))))))) 78 | |# 79 | 80 | (test "eval-expro/uneval-valueo-3" 81 | (run* (expr) 82 | (nfo 83 | `(Lam y 84 | (App (Lam x (Lam y (Var x))) 85 | (Var y))) 86 | '() 87 | expr)) 88 | '(((Lam _.0 (Lam _.1 (Var _.0))) 89 | (=/= ((_.0 _.1))) (sym _.0 _.1)))) 90 | 91 | (test "eval-expro/uneval-valueo-4" 92 | (run* (q) 93 | (nfo 94 | `(Lam y 95 | (App (Lam x (Lam y (Var x))) 96 | (Var y))) 97 | '() 98 | `(Lam y (Lam y (Var y))))) 99 | '()) 100 | 101 | (test "eval-expro/uneval-valueo-4-expressed" 102 | (run* (q) 103 | (nfo 104 | `(Lam y 105 | (App (Lam x (Lam y (Var x))) 106 | (Var y))) 107 | '() 108 | `(Lam y (Lam z (Var y))))) 109 | '(_.0)) 110 | -------------------------------------------------------------------------------- /miniKanren-version/naive/nbe-untagged-extended.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | (define lookupo 6 | (lambda (x env val) 7 | (fresh (y v env^) 8 | (== `((,y . ,v) . ,env^) env) 9 | (symbolo x) 10 | (symbolo y) 11 | (conde 12 | ((== x y) (== v val)) 13 | ((=/= x y) 14 | (lookupo x env^ val)))))) 15 | 16 | (define eval-expro 17 | (lambda (expr env val) 18 | (conde 19 | ((== #f expr) (== #f val)) 20 | ((== #t expr) (== #t val)) 21 | ((numbero expr) (== expr val)) 22 | ((== `(quote ,val) expr) 23 | (absento 'closure val) 24 | (absento 'N val)) 25 | ((fresh (x body) 26 | (== `(lambda (,x) ,body) expr) 27 | (== `(closure (,x) ,body ,env) val) 28 | (symbolo x))) 29 | ((symbolo expr) (lookupo expr env val)) 30 | ((fresh (e v) 31 | (== `(null? ,e) expr) 32 | (eval-expro e env v) 33 | (eval-nullo v val))) 34 | ((fresh (e v) 35 | (== `(pair? ,e) expr) 36 | (eval-expro e env v) 37 | (eval-pairo v val))) 38 | ((fresh (e v) 39 | (== `(number? ,e) expr) 40 | (eval-expro e env v) 41 | (eval-numbero v val))) 42 | ((fresh (e v) 43 | (== `(symbol? ,e) expr) 44 | (eval-expro e env v) 45 | (eval-symbolo v val))) 46 | ((fresh (e v) 47 | (== `(car ,e) expr) 48 | (eval-expro e env v) 49 | (eval-caro v val))) 50 | ((fresh (e v) 51 | (== `(cdr ,e) expr) 52 | (eval-expro e env v) 53 | (eval-cdro v val))) 54 | ((fresh (e1 e2 v1 v2) 55 | (== `(cons ,e1 ,e2) expr) 56 | (== `(,v1 . ,v2) val) 57 | (eval-expro e1 env v1) 58 | (eval-expro e2 env v2))) 59 | ((fresh (e1 e2 e3 v1) 60 | (== `(if ,e1 ,e2 ,e3) expr) 61 | (eval-expro e1 env v1) 62 | (eval-ifo env v1 e2 e3 val))) 63 | ((fresh (e1 e2 f v) 64 | (== `(,e1 ,e2) expr) 65 | (eval-expro e1 env f) 66 | (eval-expro e2 env v) 67 | (apply-expro f v val)))))) 68 | 69 | (define eval-nullo 70 | (lambda (v val) 71 | (conde 72 | ((== '() v) (== #t val)) 73 | ((== #f v) (== #f val)) 74 | ((== #t v) (== #f val)) 75 | ((numbero v) (== #f val)) 76 | ((symbolo v) (== #f val)) 77 | ((fresh (v1 v2) 78 | (== `(,v1 . ,v2) v) 79 | (=/= 'closure v1) 80 | (=/= 'N v1) 81 | (== #f val))) 82 | ((fresh (x env body) 83 | (== `(closure (,x) ,env ,body) v) 84 | (== #f val))) 85 | ((fresh (n) 86 | (== `(N ,n) v) 87 | (== `(N (NNull? ,n)) val)))))) 88 | 89 | (define eval-pairo 90 | (lambda (v val) 91 | (conde 92 | ((fresh (v1 v2) 93 | (== `(,v1 . ,v2) v) 94 | (=/= 'closure v1) 95 | (=/= 'N v1) 96 | (== #t val))) 97 | ((== '() v) (== #f val)) 98 | ((== #f v) (== #f val)) 99 | ((== #t v) (== #f val)) 100 | ((numbero v) (== #f val)) 101 | ((symbolo v) (== #f val)) 102 | ((fresh (x env body) 103 | (== `(closure (,x) ,env ,body) v) 104 | (== #f val))) 105 | ((fresh (n) 106 | (== `(N ,n) v) 107 | (== `(N (NPair? ,n)) val)))))) 108 | 109 | (define eval-numbero 110 | (lambda (v val) 111 | (conde 112 | ((numbero v) (== #t val)) 113 | ((== #f v) (== #f val)) 114 | ((== #t v) (== #f val)) 115 | ((== '() v) (== #f val)) 116 | ((symbolo v) (== #f val)) 117 | ((fresh (v1 v2) 118 | (== `(,v1 . ,v2) v) 119 | (=/= 'closure v1) 120 | (=/= 'N v1) 121 | (== #f val))) 122 | ((fresh (x env body) 123 | (== `(closure (,x) ,env ,body) v) 124 | (== #f val))) 125 | ((fresh (n) 126 | (== `(N ,n) v) 127 | (== `(N (NNumber? ,n)) val)))))) 128 | 129 | (define eval-symbolo 130 | (lambda (v val) 131 | (conde 132 | ((symbolo v) (== #t val)) 133 | ((== #f v) (== #f val)) 134 | ((== #t v) (== #f val)) 135 | ((== '() v) (== #f val)) 136 | ((numbero v) (== #f val)) 137 | ((fresh (v1 v2) 138 | (== `(,v1 . ,v2) v) 139 | (=/= 'closure v1) 140 | (=/= 'N v1) 141 | (== #f val))) 142 | ((fresh (x env body) 143 | (== `(closure (,x) ,env ,body) v) 144 | (== #f val))) 145 | ((fresh (n) 146 | (== `(N ,n) v) 147 | (== `(N (NSymbol? ,n)) val)))))) 148 | 149 | 150 | (define eval-caro 151 | (lambda (v val) 152 | (conde 153 | ((fresh (v1 v2) 154 | (== `(,v1 . ,v2) v) 155 | (== v1 val) 156 | (=/= 'closure v1) 157 | (=/= 'N v1))) 158 | ((fresh (n) 159 | (== `(N ,n) v) 160 | (== `(N (NCar ,n)) val)))))) 161 | 162 | (define eval-cdro 163 | (lambda (v val) 164 | (conde 165 | ((fresh (v1 v2) 166 | (== `(,v1 . ,v2) v) 167 | (== v2 val) 168 | (=/= 'closure v1) 169 | (=/= 'N v1))) 170 | ((fresh (n) 171 | (== `(N ,n) v) 172 | (== `(N (NCdr ,n)) val)))))) 173 | 174 | 175 | (define eval-ifo 176 | (lambda (env v1 e2 e3 val) 177 | (conde 178 | ((== #t v1) 179 | (eval-expro e2 env val)) 180 | ((== #f v1) 181 | (eval-expro e3 env val)) 182 | ((fresh (n1 v2 v3) 183 | (== `(N ,n1) v1) 184 | (== `(N (NIf ,n1 ,v2 ,v3)) val) 185 | (eval-expro e2 env v2) 186 | (eval-expro e3 env v3)))))) 187 | 188 | 189 | (define apply-expro 190 | (lambda (f v val) 191 | (conde 192 | ((fresh (n) 193 | (== `(N ,n) f) 194 | (== `(N (NApp ,n ,v)) val))) 195 | ((fresh (x body env) 196 | (== `(closure (,x) ,body ,env) f) 197 | (symbolo x) 198 | (eval-expro body `((,x . ,v) . ,env) val)))))) 199 | 200 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 201 | ;; Rather than compute a renamed variable, we just describe the constraints. 202 | (define fresho 203 | (lambda (xs x^) 204 | (fresh () 205 | (symbolo x^) 206 | (absento x^ xs)))) 207 | 208 | (define quoted-or-self-quotingo 209 | (lambda (expr datum) 210 | (conde 211 | ((== #f expr) (== expr datum)) 212 | ((== #t expr) (== expr datum)) 213 | ((numbero expr) (== expr datum)) 214 | ((== `(quote ,datum) expr))))) 215 | 216 | (define not-quoted-and-not-self-quotingo 217 | (lambda (expr) 218 | (conde 219 | ((symbolo expr)) 220 | ((== '() expr)) 221 | ((fresh (a d) 222 | (== `(,a . ,d) expr) 223 | (=/= 'quote a)))))) 224 | 225 | (define uneval-valueo 226 | (lambda (xs v expr) 227 | (conde 228 | ((== #f v) (== #f expr)) 229 | ((== #t v) (== #t expr)) 230 | ((numbero v) (== v expr)) 231 | ((== '() v) (== '(quote ()) expr)) 232 | ((symbolo v) 233 | (== `(quote ,v) expr) 234 | (=/= 'closure v) 235 | (=/= 'N v)) 236 | ((fresh (n) 237 | (== `(N ,n) v) 238 | (uneval-neutralo xs n expr))) 239 | ((fresh (x body env x^ body^ bv) 240 | (== `(closure (,x) ,body ,env) v) 241 | (== `(lambda (,x^) ,body^) expr) 242 | (symbolo x) 243 | (symbolo x^) 244 | (fresho xs x^) 245 | (eval-expro body `((,x . (N (NVar ,x^))) . ,env) bv) 246 | (uneval-valueo `(,x^ . ,xs) bv body^))) 247 | ((fresh (v1 v2 e1 e2) 248 | (== `(,v1 . ,v2) v) 249 | (=/= 'closure v1) 250 | (=/= 'N v1) 251 | (absento 'closure expr) 252 | (absento 'N expr) 253 | (conde 254 | ((fresh (d1 d2) 255 | (== `(quote (,d1 . ,d2)) expr) 256 | (quoted-or-self-quotingo e1 d1) 257 | (quoted-or-self-quotingo e2 d2))) 258 | ((== `(cons ,e1 ,e2) expr) 259 | (conde 260 | ((not-quoted-and-not-self-quotingo e1)) 261 | ((fresh (d1) 262 | (quoted-or-self-quotingo e1 d1) 263 | (not-quoted-and-not-self-quotingo e2)))))) 264 | (uneval-valueo xs v1 e1) 265 | (uneval-valueo xs v2 e2)))))) 266 | 267 | (define uneval-neutralo 268 | (lambda (xs n expr) 269 | (conde 270 | ((== `(NVar ,expr) n) 271 | (symbolo expr)) 272 | ((fresh (n1 e1) 273 | (== `(NNull? ,n1) n) 274 | (== `(null? ,e1) expr) 275 | (uneval-neutralo xs n1 e1))) 276 | ((fresh (n1 e1) 277 | (== `(NPair? ,n1) n) 278 | (== `(pair? ,e1) expr) 279 | (uneval-neutralo xs n1 e1))) 280 | ((fresh (n1 e1) 281 | (== `(NNumber? ,n1) n) 282 | (== `(number? ,e1) expr) 283 | (uneval-neutralo xs n1 e1))) 284 | ((fresh (n1 e1) 285 | (== `(NSymbol? ,n1) n) 286 | (== `(symbol? ,e1) expr) 287 | (uneval-neutralo xs n1 e1))) 288 | ((fresh (n1 e1) 289 | (== `(NCar ,n1) n) 290 | (== `(car ,e1) expr) 291 | (uneval-neutralo xs n1 e1))) 292 | ((fresh (n1 e1) 293 | (== `(NCdr ,n1) n) 294 | (== `(cdr ,e1) expr) 295 | (uneval-neutralo xs n1 e1))) 296 | ((fresh (n^ v ne ve) 297 | (== `(NApp ,n^ ,v) n) 298 | (== `(,ne ,ve) expr) 299 | (uneval-neutralo xs n^ ne) 300 | (uneval-valueo xs v ve))) 301 | ((fresh (n1 v2 v3 e1 e2 e3) 302 | (== `(NIf ,n1 ,v2 ,v3) n) 303 | (== `(if ,e1 ,e2 ,e3) expr) 304 | (uneval-neutralo xs n1 e1) 305 | (uneval-valueo xs v2 e2) 306 | (uneval-valueo xs v3 e3)))))) 307 | 308 | (define nfo 309 | (lambda (t env expr) 310 | (fresh (v) 311 | (eval-expro t env v) 312 | (uneval-valueo '() v expr)))) 313 | 314 | (define main 315 | (lambda () 316 | (run* (result) 317 | (fresh (id_ const_) 318 | (eval-expro '(lambda (x) x) '() id_) 319 | (eval-expro '(lambda (x) (lambda (y) x)) '() const_) 320 | (eval-expro '(const id) `((id . ,id_) (const . ,const_)) result))))) 321 | 322 | 323 | (test "main" 324 | (main) 325 | '((closure (y) x ((x . (closure (x) x ())))))) 326 | 327 | ;; nf [] (Lam "x" (App (Lam "y" (App (Var "x") (Var "y"))) (Lam "x" (Var "x")))) 328 | ;; => 329 | ;; Lam "x" (App (Var "x") (Lam "x'" (Var "x'"))) 330 | (test "nf-0" 331 | (run* (expr) 332 | (nfo '(lambda (x) ((lambda (y) (x y)) (lambda (x) x))) '() expr)) 333 | '(((lambda (_.0) (_.0 (lambda (_.1) _.1))) 334 | (=/= ((_.0 _.1))) 335 | (sym _.0 _.1)))) 336 | -------------------------------------------------------------------------------- /miniKanren-version/naive/nbe-untagged-tests.scm: -------------------------------------------------------------------------------- 1 | (load "nbe-untagged.scm") 2 | (load "../faster-miniKanren/test-check.scm") 3 | 4 | (test "main" 5 | (run* (result) 6 | (fresh (id_ const_) 7 | (eval-expro '(lambda (x) x) '() id_) 8 | (eval-expro '(lambda (x) (lambda (y) x)) '() const_) 9 | (eval-expro '(const id) `((id . ,id_) (const . ,const_)) result))) 10 | '((closure (y) x ((x . (closure (x) x ())))))) 11 | 12 | (test "eval-expro-1" 13 | (run* (val) 14 | (eval-expro `(lambda (z) z) '() val)) 15 | '((closure (z) z ()))) 16 | 17 | (test "eval-expro-2" 18 | (run* (val) 19 | (eval-expro 20 | `((lambda (x) (lambda (y) x)) 21 | (lambda (z) z)) 22 | '() 23 | val)) 24 | '((closure (y) x ((x . (closure (z) z ())))))) 25 | 26 | (test "uneval-valueo-0" 27 | (run 6 (val expr) 28 | (uneval-valueo '() val expr)) 29 | '((((N (NVar _.0)) 30 | _.0) 31 | (sym _.0)) 32 | (((N (NApp (NVar _.0) (N (NVar _.1)))) 33 | (_.0 _.1)) 34 | (sym _.0 _.1)) 35 | (((closure (_.0) _.0 _.1) 36 | (lambda (_.2) _.2)) 37 | (sym _.0 _.2)) 38 | (((N (NApp (NApp (NVar _.0) (N (NVar _.1))) (N (NVar _.2)))) 39 | ((_.0 _.1) _.2)) 40 | (sym _.0 _.1 _.2)) 41 | (((closure (_.0) _.1 ((_.1 N (NVar _.2)) . _.3)) 42 | (lambda (_.4) _.2)) 43 | (=/= ((_.0 _.1))) 44 | (sym _.0 _.1 _.2 _.4)) 45 | (((closure (_.0) (lambda (_.1) _.1) _.2) 46 | (lambda (_.3) (lambda (_.4) _.4))) 47 | (=/= ((_.3 _.4))) 48 | (sym _.0 _.1 _.3 _.4)))) 49 | 50 | (test "uneval-valueo-1" 51 | (run* (expr) 52 | (uneval-valueo '() '(closure (y) x ((x . (closure (z) z ())))) expr)) 53 | '(((lambda (_.0) (lambda (_.1) _.1)) 54 | (=/= ((_.0 _.1))) 55 | (sym _.0 _.1)))) 56 | 57 | (test "eval-expro/uneval-valueo-2" 58 | (run* (result) 59 | (fresh (val) 60 | (eval-expro 61 | `((lambda (x) (lambda (y) x)) 62 | (lambda (z) z)) 63 | '() 64 | val) 65 | (uneval-valueo '() val result))) 66 | '(((lambda (_.0) (lambda (_.1) _.1)) 67 | (=/= ((_.0 _.1))) (sym _.0 _.1)))) 68 | 69 | (test "eval-expro/uneval-valueo-3" 70 | (run* (expr) 71 | (nfo 72 | `(lambda (y) 73 | ((lambda (x) (lambda (y) x)) 74 | y)) 75 | '() 76 | expr)) 77 | '(((lambda (_.0) (lambda (_.1) _.0)) 78 | (=/= ((_.0 _.1))) (sym _.0 _.1)))) 79 | 80 | (test "eval-expro/uneval-valueo-4" 81 | (run* (q) 82 | (nfo 83 | `(lambda (y) 84 | ((lambda (x) (lambda (y) x)) 85 | y)) 86 | '() 87 | `(lambda (y) (lambda (y) y)))) 88 | '()) 89 | 90 | (test "eval-expro/uneval-valueo-4-expressed" 91 | (run* (q) 92 | (nfo 93 | `(lambda (y) 94 | ((lambda (x) (lambda (y) x)) 95 | y)) 96 | '() 97 | `(lambda (y) (lambda (z) y)))) 98 | '(_.0)) 99 | -------------------------------------------------------------------------------- /miniKanren-version/naive/nbe-untagged.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | (define lookupo 6 | (lambda (x env val) 7 | (fresh (y v env^) 8 | (== `((,y . ,v) . ,env^) env) 9 | (symbolo x) 10 | (symbolo y) 11 | (conde 12 | ((== x y) (== v val)) 13 | ((=/= x y) 14 | (lookupo x env^ val)))))) 15 | 16 | (define eval-expro 17 | (lambda (expr env val) 18 | (conde 19 | ((fresh (x body) 20 | (== `(lambda (,x) ,body) expr) 21 | (== `(closure (,x) ,body ,env) val) 22 | (symbolo x))) 23 | ((symbolo expr) (lookupo expr env val)) 24 | ((fresh (e1 e2 f v) 25 | (== `(,e1 ,e2) expr) 26 | (eval-expro e1 env f) 27 | (eval-expro e2 env v) 28 | (apply-expro f v val)))))) 29 | 30 | (define apply-expro 31 | (lambda (f v val) 32 | (conde 33 | ((fresh (n) 34 | (== `(N ,n) f) 35 | (== `(N (NApp ,n ,v)) val))) 36 | ((fresh (x body env) 37 | (== `(closure (,x) ,body ,env) f) 38 | (symbolo x) 39 | (eval-expro body `((,x . ,v) . ,env) val)))))) 40 | 41 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 42 | ;; Rather than compute a renamed variable, we just describe the constraints. 43 | (define fresho 44 | (lambda (xs x^) 45 | (fresh () 46 | (symbolo x^) 47 | (absento x^ xs)))) 48 | 49 | (define uneval-valueo 50 | (lambda (xs v expr) 51 | (conde 52 | ((fresh (n) 53 | (== `(N ,n) v) 54 | (uneval-neutralo xs n expr))) 55 | ((fresh (x body env x^ body^ bv) 56 | (== `(closure (,x) ,body ,env) v) 57 | (== `(lambda (,x^) ,body^) expr) 58 | (symbolo x) 59 | (symbolo x^) 60 | (fresho xs x^) 61 | (eval-expro body 62 | `((,x . (N (NVar ,x^))) . ,env) 63 | bv) 64 | (uneval-valueo `(,x^ . ,xs) bv body^)))))) 65 | 66 | (define uneval-neutralo 67 | (lambda (xs n expr) 68 | (conde 69 | ((== `(NVar ,expr) n) 70 | (symbolo expr)) 71 | ((fresh (n^ v ne ve) 72 | (== `(NApp ,n^ ,v) n) 73 | (== `(,ne ,ve) expr) 74 | (uneval-neutralo xs n^ ne) 75 | (uneval-valueo xs v ve)))))) 76 | 77 | (define nfo 78 | (lambda (t env expr) 79 | (fresh (v) 80 | (eval-expro t env v) 81 | (uneval-valueo '() v expr)))) 82 | 83 | (define main 84 | (lambda () 85 | (run* (result) 86 | (fresh (id_ const_) 87 | (eval-expro '(lambda (x) x) '() id_) 88 | (eval-expro '(lambda (x) (lambda (y) x)) '() const_) 89 | (eval-expro '(const id) `((id . ,id_) (const . ,const_)) result))))) 90 | 91 | 92 | (test "main" 93 | (main) 94 | '((closure (y) x ((x . (closure (x) x ())))))) 95 | 96 | ;; nf [] (Lam "x" (App (Lam "y" (App (Var "x") (Var "y"))) (Lam "x" (Var "x")))) 97 | ;; => 98 | ;; Lam "x" (App (Var "x") (Lam "x'" (Var "x'"))) 99 | (test "nf-0" 100 | (run* (expr) 101 | (nfo '(lambda (x) ((lambda (y) (x y)) (lambda (x) x))) '() expr)) 102 | '(((lambda (_.0) (_.0 (lambda (_.1) _.1))) 103 | (=/= ((_.0 _.1))) 104 | (sym _.0 _.1)))) 105 | -------------------------------------------------------------------------------- /miniKanren-version/naive/nbe.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | (define lookupo 6 | (lambda (x env val) 7 | (fresh (y v env^) 8 | (== `((,y . ,v) . ,env^) env) 9 | (symbolo x) 10 | (symbolo y) 11 | (conde 12 | ((== x y) (== v val)) 13 | ((=/= x y) 14 | (lookupo x env^ val)))))) 15 | 16 | (define eval-expro 17 | (lambda (expr env val) 18 | (conde 19 | ((fresh (x body) 20 | (== `(Lam ,x ,body) expr) 21 | (== `(Closure ,x ,body ,env) val) 22 | (symbolo x))) 23 | ((fresh (x) 24 | (== `(Var ,x) expr) 25 | (symbolo x) 26 | (lookupo x env val))) 27 | ((fresh (e1 e2 f v) 28 | (== `(App ,e1 ,e2) expr) 29 | (eval-expro e1 env f) 30 | (eval-expro e2 env v) 31 | (apply-expro f v val)))))) 32 | 33 | (define apply-expro 34 | (lambda (f v val) 35 | (conde 36 | ((fresh (n) 37 | (== `(N ,n) f) 38 | (== `(N (NApp ,n ,v)) val))) 39 | ((fresh (x body env) 40 | (== `(Closure ,x ,body ,env) f) 41 | (symbolo x) 42 | (eval-expro body `((,x . ,v) . ,env) val)))))) 43 | 44 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 45 | ;; Rather than compute a renamed variable, we just describe the constraints. 46 | (define fresho 47 | (lambda (xs x^) 48 | (fresh () 49 | (symbolo x^) 50 | (absento x^ xs)))) 51 | 52 | (define uneval-valueo 53 | (lambda (xs v expr) 54 | (conde 55 | ((fresh (n) 56 | (== `(N ,n) v) 57 | (uneval-neutralo xs n expr))) 58 | ((fresh (x body env x^ body^ bv) 59 | (== `(Closure ,x ,body ,env) v) 60 | (== `(Lam ,x^ ,body^) expr) 61 | (symbolo x) 62 | (symbolo x^) 63 | (fresho xs x^) 64 | (eval-expro body `((,x . (N (NVar ,x^))) . ,env) bv) 65 | (uneval-valueo `(,x^ . ,xs) bv body^)))))) 66 | 67 | (define uneval-neutralo 68 | (lambda (xs n expr) 69 | (conde 70 | ((fresh (x) 71 | (== `(NVar ,x) n) 72 | (== `(Var ,x) expr))) 73 | ((fresh (n^ v ne ve) 74 | (== `(NApp ,n^ ,v) n) 75 | (== `(App ,ne ,ve) expr) 76 | (uneval-neutralo xs n^ ne) 77 | (uneval-valueo xs v ve)))))) 78 | 79 | (define nfo 80 | (lambda (t env expr) 81 | (fresh (v) 82 | (eval-expro t env v) 83 | (uneval-valueo '() v expr)))) 84 | 85 | (define main 86 | (lambda () 87 | (run* (result) 88 | (fresh (id_ const_) 89 | (eval-expro '(Lam x (Var x)) '() id_) 90 | (eval-expro '(Lam x (Lam y (Var x))) '() const_) 91 | (eval-expro '(App (Var const) (Var id)) `((id . ,id_) (const . ,const_)) result))))) 92 | 93 | 94 | (test "main" 95 | (main) 96 | '((Closure y (Var x) ((x Closure x (Var x) ()))))) 97 | 98 | ;; nf [] (Lam "x" (App (Lam "y" (App (Var "x") (Var "y"))) (Lam "x" (Var "x")))) 99 | ;; => 100 | ;; Lam "x" (App (Var "x") (Lam "x'" (Var "x'"))) 101 | (test "nf-0" 102 | (run* (expr) 103 | (nfo '(Lam x (App (Lam y (App (Var x) (Var y))) (Lam x (Var x)))) '() expr)) 104 | '(((Lam _.0 (App (Var _.0) (Lam _.1 (Var _.1)))) 105 | (=/= ((_.0 _.1))) 106 | (sym _.0 _.1)))) 107 | -------------------------------------------------------------------------------- /miniKanren-version/naive/rbe-depth-limited.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | ;; reduction by evaluation, in order to synthesize 6 | ;; fixpoint combinators 7 | 8 | ;; Michael Ballantyne and Will Byrd, 22 Feb 02023 9 | 10 | (define MAX_DEPTH_LIMIT '(s s s s s s)) 11 | 12 | (define lookupo 13 | (lambda (x env val) 14 | (fresh (y v env^) 15 | (== `((,y . ,v) . ,env^) env) 16 | (symbolo x) 17 | (symbolo y) 18 | (conde 19 | ((== x y) (== v val)) 20 | ((=/= x y) 21 | (lookupo x env^ val)))))) 22 | 23 | (define eval-expro 24 | (lambda (expr env val depth-limit) 25 | (conde 26 | ((fresh (x body) 27 | (== `(lambda (,x) ,body) expr) 28 | (== `(closure (,x) ,body ,env) val) 29 | (symbolo x))) 30 | ((symbolo expr) (lookupo expr env val)) 31 | ((fresh (e1 e2 f v depth-limit-1) 32 | (== `(,e1 ,e2) expr) 33 | (== `(s . ,depth-limit-1) depth-limit) 34 | (eval-expro e1 env f depth-limit-1) 35 | (eval-expro e2 env v depth-limit-1) 36 | (apply-expro f v val depth-limit-1)))))) 37 | 38 | (define apply-expro 39 | (lambda (f v val depth-limit) 40 | (conde 41 | ((== `(NApp ,f ,v) val)) 42 | ((fresh (x body env depth-limit-1) 43 | (== `(closure (,x) ,body ,env) f) 44 | (symbolo x) 45 | (== `(s . ,depth-limit-1) depth-limit) 46 | (eval-expro body `((,x . ,v) . ,env) val depth-limit-1)))))) 47 | 48 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 49 | ;; Rather than compute a renamed variable, we just describe the constraints. 50 | (define fresho 51 | (lambda (xs x^) 52 | (fresh () 53 | (symbolo x^) 54 | (absento x^ xs)))) 55 | 56 | (define uneval-valueo 57 | (lambda (xs v expr) 58 | (conde 59 | ((== `(NVar ,expr) v) 60 | (symbolo expr)) 61 | ((fresh (n^ v^ ne ve) 62 | (== `(NApp ,n^ ,v^) v) 63 | (== `(,ne ,ve) expr) 64 | (uneval-valueo xs n^ ne) 65 | (uneval-valueo xs v^ ve))) 66 | ((fresh (x body env x^ body^ bv) 67 | (== `(closure (,x) ,body ,env) v) 68 | (== `(lambda (,x^) ,body^) expr) 69 | (symbolo x) 70 | (symbolo x^) 71 | (fresho xs x^) 72 | (eval-expro body 73 | `((,x . (NVar ,x^)) . ,env) 74 | bv 75 | MAX_DEPTH_LIMIT) 76 | (uneval-valueo `(,x^ . ,xs) bv body^)))))) 77 | 78 | (define rfo 79 | (lambda (t expr) 80 | (fresh (v) 81 | (eval-expro t '() v MAX_DEPTH_LIMIT) 82 | (uneval-valueo '() v expr)))) 83 | 84 | (run 5 (q) 85 | (rfo q '(lambda (x) x))) 86 | ;; => 87 | '(((lambda (_.0) _.0) 88 | (sym _.0)) 89 | (((lambda (_.0) (lambda (_.1) _.1)) (lambda (_.2) _.3)) 90 | (sym _.0 _.1 _.2)) 91 | ((lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.3))) 92 | (=/= ((_.0 _.1))) 93 | (sym _.0 _.1 _.2)) 94 | (((lambda (_.0) _.0) (lambda (_.1) _.1)) (sym _.0 _.1)) 95 | ((lambda (_.0) ((lambda (_.1) _.1) _.0)) (sym _.0 _.1))) 96 | 97 | (run* (q) 98 | (rfo '(lambda (x) ((lambda (y) x) (lambda (z) w))) q)) 99 | ;; => 100 | '(((lambda (_.0) _.0) (sym _.0))) 101 | 102 | (run 1 (q) 103 | (fresh (t) 104 | (eval-expro 105 | `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) 106 | '() 107 | q 108 | MAX_DEPTH_LIMIT))) 109 | ;; => 110 | '((closure (x) ((lambda (y) x) (lambda (z) w)) ())) 111 | 112 | (run 2 (q) 113 | (eval-expro 114 | '((lambda (y) x) (lambda (z) w)) 115 | '((x . (NVar x^))) 116 | q 117 | MAX_DEPTH_LIMIT)) 118 | ;; => 119 | '((NApp 120 | (closure (y) x ((x NVar x^))) 121 | (closure (z) w ((x NVar x^)))) 122 | (NVar x^)) 123 | 124 | (run 3 (t1 t2) 125 | (fresh (t) 126 | (== `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) t1) 127 | (rfo t1 t2))) 128 | ;; => 129 | '((((lambda (x) ((lambda (y) x) (lambda (z) _.0))) 130 | (lambda (_.1) _.1)) 131 | (sym _.1)) 132 | (((lambda (x) ((lambda (y) x) (lambda (z) z))) 133 | (lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.2)))) 134 | (=/= ((_.0 _.1)) ((_.0 _.2))) 135 | (sym _.0 _.1 _.2)) 136 | (((lambda (x) ((lambda (y) x) (lambda (z) x))) 137 | (lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.0)))) 138 | (=/= ((_.0 _.1)) ((_.0 _.2))) 139 | (sym _.0 _.1 _.2))) 140 | 141 | (run 3 (t1 t2) 142 | (fresh (t) 143 | (== t1 t2) 144 | (== `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) t1) 145 | (rfo t1 t2))) 146 | ;; => 147 | '(((lambda (x) ((lambda (y) x) (lambda (z) z))) 148 | (lambda (x) ((lambda (y) x) (lambda (z) z)))) 149 | ((lambda (x) ((lambda (y) x) (lambda (z) x))) 150 | (lambda (x) ((lambda (y) x) (lambda (z) x)))) 151 | (((lambda (x) 152 | ((lambda (y) x) (lambda (z) (lambda (_.0) _.0)))) 153 | (lambda (x) 154 | ((lambda (y) x) (lambda (z) (lambda (_.0) _.0))))) 155 | (=/= ((_.0 x)) ((_.0 z))) 156 | (sym _.0))) 157 | 158 | #| 159 | (run 1 (Y t) 160 | (rfo `(lambda (f) (,Y f)) t) 161 | (rfo `(lambda (f) (f (,Y f))) t)) 162 | |# 163 | 164 | #| 165 | ;; Call-by-name Y combinator 166 | (lambda (f) 167 | ((lambda (x) (f (x x))) 168 | (lambda (x) (f (x x))))) 169 | |# 170 | 171 | (run 1 (Y t) 172 | (== '(lambda (f) 173 | ((lambda (x) (f (x x))) 174 | (lambda (x) (f (x x))))) 175 | Y) 176 | (rfo `(lambda (f) (,Y f)) t) 177 | (rfo `(lambda (f) (f (,Y f))) t)) 178 | ;; => 179 | '((((lambda (f) 180 | ((lambda (x) (f (x x))) 181 | (lambda (x) (f (x x))))) 182 | (lambda (_.0) 183 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 184 | (lambda (_.2) (_.0 (_.2 _.2))))))) 185 | (=/= ((_.0 _.1)) ((_.0 _.2))) 186 | (sym _.0 _.1 _.2))) 187 | 188 | (run 1 (Y t) 189 | (fresh (?) 190 | (== `(lambda (f) 191 | ((lambda (x) (f (x x))) 192 | (lambda (x) (f (,? ,?))))) 193 | Y)) 194 | (rfo `(lambda (f) (,Y f)) t) 195 | (rfo `(lambda (f) (f (,Y f))) t)) 196 | ;; => 197 | '((((lambda (f) 198 | ((lambda (x) (f (x x))) (lambda (x) (f (x x))))) 199 | (lambda (_.0) 200 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 201 | (lambda (_.2) (_.0 (_.2 _.2))))))) 202 | (=/= ((_.0 _.1)) ((_.0 _.2))) 203 | (sym _.0 _.1 _.2))) 204 | 205 | (run 1 (Y t) 206 | (fresh (?) 207 | (== `(lambda (f) 208 | ((lambda (x) (f ,?)) 209 | (lambda (x) (f (x x))))) 210 | Y)) 211 | (rfo `(lambda (f) (,Y f)) t) 212 | (rfo `(lambda (f) (f (,Y f))) t)) 213 | ;; => 214 | '((((lambda (f) 215 | ((lambda (x) (f (x x))) (lambda (x) (f (x x))))) 216 | (lambda (_.0) 217 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 218 | (lambda (_.2) (_.0 (_.2 _.2))))))) 219 | (=/= ((_.0 _.1)) ((_.0 _.2))) 220 | (sym _.0 _.1 _.2))) 221 | 222 | ;; Omega reduces to itself 223 | (run 2 (t1 t2) 224 | (== '((lambda (x) (x x)) 225 | (lambda (x) (x x))) 226 | t1) 227 | (rfo t1 t2)) 228 | ;; => 229 | '(((((lambda (x) (x x)) (lambda (x) (x x))) 230 | ((lambda (_.0) (_.0 _.0)) (lambda (_.1) (_.1 _.1)))) 231 | (sym _.0 _.1)) 232 | ((((lambda (x) (x x)) (lambda (x) (x x))) 233 | ((lambda (_.0) (_.0 _.0)) (lambda (_.1) (_.1 _.1)))) 234 | (sym _.0 _.1))) 235 | 236 | ;; Challenge: how to generate Omega? 237 | ;; MB suggests that using De Bruijn 238 | ;; would work. 239 | (run 1 (t1 t2) 240 | (=/= t1 t2) 241 | (rfo t1 t2) 242 | (rfo t2 t1)) 243 | ;; => 244 | '((((lambda (_.0) _.0) 245 | (lambda (_.1) _.1)) 246 | (=/= ((_.0 _.1))) 247 | (sym _.0 _.1))) 248 | 249 | (run 1 (t1 t2) 250 | (fresh (e1 e2) 251 | (== `(,e1 ,e2) t1)) 252 | (=/= t1 t2) 253 | (rfo t1 t2) 254 | (rfo t2 t1)) 255 | ;; => 256 | '(((((lambda (_.0) _.0) (lambda (_.1) _.1)) 257 | ((lambda (_.2) _.2) (lambda (_.3) _.3))) 258 | (=/= ((_.0 _.2) (_.1 _.3))) 259 | (sym _.0 _.1 _.2 _.3))) 260 | 261 | 262 | ;; From Michael: 263 | ;; From wiki: https://en.wikipedia.org/wiki/Fixed-point_combinator 264 | (run 1 (theta) 265 | (== '((lambda (x) (lambda (y) (y ((x x) y)))) 266 | (lambda (x) (lambda (y) (y ((x x) y))))) 267 | theta) 268 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f))))) 269 | ;; => 270 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 271 | (lambda (x) (lambda (y) (y ((x x) y)))))) 272 | ;; Doesn't seem to help re synthesizing bigger terms as you add holes, though. 273 | -------------------------------------------------------------------------------- /miniKanren-version/naive/rbe.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | ;; reduction by evaluation, in order to synthesize 6 | ;; fixpoint combinators 7 | 8 | ;; Michael Ballantyne and Will Byrd, 22 Feb 02023 9 | 10 | (define lookupo 11 | (lambda (x env val) 12 | (fresh (y v env^) 13 | (== `((,y . ,v) . ,env^) env) 14 | (symbolo x) 15 | (symbolo y) 16 | (conde 17 | ((== x y) (== v val)) 18 | ((=/= x y) 19 | (lookupo x env^ val)))))) 20 | 21 | (define eval-expro 22 | (lambda (expr env val) 23 | (conde 24 | ((fresh (x body) 25 | (== `(lambda (,x) ,body) expr) 26 | (== `(closure (,x) ,body ,env) val) 27 | (symbolo x))) 28 | ((symbolo expr) (lookupo expr env val)) 29 | ((fresh (e1 e2 f v) 30 | (== `(,e1 ,e2) expr) 31 | (eval-expro e1 env f) 32 | (eval-expro e2 env v) 33 | (apply-expro f v val)))))) 34 | 35 | (define apply-expro 36 | (lambda (f v val) 37 | (conde 38 | ((== `(NApp ,f ,v) val)) 39 | ((fresh (x body env) 40 | (== `(closure (,x) ,body ,env) f) 41 | (symbolo x) 42 | (eval-expro body `((,x . ,v) . ,env) val)))))) 43 | 44 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 45 | ;; Rather than compute a renamed variable, we just describe the constraints. 46 | (define fresho 47 | (lambda (xs x^) 48 | (fresh () 49 | (symbolo x^) 50 | (absento x^ xs)))) 51 | 52 | (define uneval-valueo 53 | (lambda (xs v expr) 54 | (conde 55 | ((== `(NVar ,expr) v) 56 | (symbolo expr)) 57 | ((fresh (n^ v^ ne ve) 58 | (== `(NApp ,n^ ,v^) v) 59 | (== `(,ne ,ve) expr) 60 | (uneval-valueo xs n^ ne) 61 | (uneval-valueo xs v^ ve))) 62 | ((fresh (x body env x^ body^ bv) 63 | (== `(closure (,x) ,body ,env) v) 64 | (== `(lambda (,x^) ,body^) expr) 65 | (symbolo x) 66 | (symbolo x^) 67 | (fresho xs x^) 68 | (eval-expro body 69 | `((,x . (NVar ,x^)) . ,env) 70 | bv) 71 | (uneval-valueo `(,x^ . ,xs) bv body^)))))) 72 | 73 | (define rfo 74 | (lambda (t expr) 75 | (fresh (v) 76 | (eval-expro t '() v) 77 | (uneval-valueo '() v expr)))) 78 | 79 | (run 5 (q) 80 | (rfo q '(lambda (x) x))) 81 | ;; => 82 | '(((lambda (_.0) _.0) 83 | (sym _.0)) 84 | (((lambda (_.0) (lambda (_.1) _.1)) (lambda (_.2) _.3)) 85 | (sym _.0 _.1 _.2)) 86 | ((lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.3))) 87 | (=/= ((_.0 _.1))) 88 | (sym _.0 _.1 _.2)) 89 | (((lambda (_.0) _.0) (lambda (_.1) _.1)) (sym _.0 _.1)) 90 | ((lambda (_.0) ((lambda (_.1) _.1) _.0)) (sym _.0 _.1))) 91 | 92 | (run* (q) 93 | (rfo '(lambda (x) ((lambda (y) x) (lambda (z) w))) q)) 94 | ;; => 95 | '(((lambda (_.0) _.0) (sym _.0))) 96 | 97 | (run 1 (q) 98 | (fresh (t) 99 | (eval-expro `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) '() q))) 100 | ;; => 101 | '((closure (x) ((lambda (y) x) (lambda (z) w)) ())) 102 | 103 | (run 2 (q) 104 | (eval-expro '((lambda (y) x) (lambda (z) w)) '((x . (NVar x^))) q)) 105 | ;; => 106 | '((NApp 107 | (closure (y) x ((x NVar x^))) 108 | (closure (z) w ((x NVar x^)))) 109 | (NVar x^)) 110 | 111 | (run 3 (t1 t2) 112 | (fresh (t) 113 | (== `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) t1) 114 | (rfo t1 t2))) 115 | ;; => 116 | '((((lambda (x) ((lambda (y) x) (lambda (z) _.0))) 117 | (lambda (_.1) _.1)) 118 | (sym _.1)) 119 | (((lambda (x) ((lambda (y) x) (lambda (z) z))) 120 | (lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.2)))) 121 | (=/= ((_.0 _.1)) ((_.0 _.2))) 122 | (sym _.0 _.1 _.2)) 123 | (((lambda (x) ((lambda (y) x) (lambda (z) x))) 124 | (lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.0)))) 125 | (=/= ((_.0 _.1)) ((_.0 _.2))) 126 | (sym _.0 _.1 _.2))) 127 | 128 | (run 3 (t1 t2) 129 | (fresh (t) 130 | (== t1 t2) 131 | (== `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) t1) 132 | (rfo t1 t2))) 133 | ;; => 134 | '(((lambda (x) ((lambda (y) x) (lambda (z) z))) 135 | (lambda (x) ((lambda (y) x) (lambda (z) z)))) 136 | ((lambda (x) ((lambda (y) x) (lambda (z) x))) 137 | (lambda (x) ((lambda (y) x) (lambda (z) x)))) 138 | (((lambda (x) 139 | ((lambda (y) x) (lambda (z) (lambda (_.0) _.0)))) 140 | (lambda (x) 141 | ((lambda (y) x) (lambda (z) (lambda (_.0) _.0))))) 142 | (=/= ((_.0 x)) ((_.0 z))) 143 | (sym _.0))) 144 | 145 | #| 146 | (run 1 (Y t) 147 | (rfo `(lambda (f) (,Y f)) t) 148 | (rfo `(lambda (f) (f (,Y f))) t)) 149 | |# 150 | 151 | #| 152 | ;; Call-by-name Y combinator 153 | (lambda (f) 154 | ((lambda (x) (f (x x))) 155 | (lambda (x) (f (x x))))) 156 | |# 157 | 158 | (run 1 (Y t) 159 | (== '(lambda (f) 160 | ((lambda (x) (f (x x))) 161 | (lambda (x) (f (x x))))) 162 | Y) 163 | (rfo `(lambda (f) (,Y f)) t) 164 | (rfo `(lambda (f) (f (,Y f))) t)) 165 | ;; => 166 | '((((lambda (f) 167 | ((lambda (x) (f (x x))) 168 | (lambda (x) (f (x x))))) 169 | (lambda (_.0) 170 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 171 | (lambda (_.2) (_.0 (_.2 _.2))))))) 172 | (=/= ((_.0 _.1)) ((_.0 _.2))) 173 | (sym _.0 _.1 _.2))) 174 | 175 | (run 1 (Y t) 176 | (fresh (?) 177 | (== `(lambda (f) 178 | ((lambda (x) (f (x x))) 179 | (lambda (x) (f (,? ,?))))) 180 | Y)) 181 | (rfo `(lambda (f) (,Y f)) t) 182 | (rfo `(lambda (f) (f (,Y f))) t)) 183 | ;; => 184 | '((((lambda (f) 185 | ((lambda (x) (f (x x))) (lambda (x) (f (x x))))) 186 | (lambda (_.0) 187 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 188 | (lambda (_.2) (_.0 (_.2 _.2))))))) 189 | (=/= ((_.0 _.1)) ((_.0 _.2))) 190 | (sym _.0 _.1 _.2))) 191 | 192 | #| 193 | (run 1 (Y t) 194 | (fresh (?) 195 | (== `(lambda (f) 196 | ((lambda (x) (f ,?)) 197 | (lambda (x) (f (x x))))) 198 | Y)) 199 | (rfo `(lambda (f) (,Y f)) t) 200 | (rfo `(lambda (f) (f (,Y f))) t)) 201 | |# 202 | 203 | ;; Omega reduces to itself 204 | (run 2 (t1 t2) 205 | (== '((lambda (x) (x x)) 206 | (lambda (x) (x x))) 207 | t1) 208 | (rfo t1 t2)) 209 | ;; => 210 | '(((((lambda (x) (x x)) (lambda (x) (x x))) 211 | ((lambda (_.0) (_.0 _.0)) (lambda (_.1) (_.1 _.1)))) 212 | (sym _.0 _.1)) 213 | ((((lambda (x) (x x)) (lambda (x) (x x))) 214 | ((lambda (_.0) (_.0 _.0)) (lambda (_.1) (_.1 _.1)))) 215 | (sym _.0 _.1))) 216 | 217 | ;; Challenge: how to generate Omega? 218 | ;; MB suggests that using De Bruijn 219 | ;; would work. 220 | (run 1 (t1 t2) 221 | (=/= t1 t2) 222 | (rfo t1 t2) 223 | (rfo t2 t1)) 224 | ;; => 225 | '((((lambda (_.0) _.0) 226 | (lambda (_.1) _.1)) 227 | (=/= ((_.0 _.1))) 228 | (sym _.0 _.1))) 229 | 230 | (run 1 (t1 t2) 231 | (fresh (e1 e2) 232 | (== `(,e1 ,e2) t1)) 233 | (=/= t1 t2) 234 | (rfo t1 t2) 235 | (rfo t2 t1)) 236 | ;; => 237 | '(((((lambda (_.0) _.0) (lambda (_.1) _.1)) 238 | ((lambda (_.2) _.2) (lambda (_.3) _.3))) 239 | (=/= ((_.0 _.2) (_.1 _.3))) 240 | (sym _.0 _.1 _.2 _.3))) 241 | 242 | 243 | ;; From Michael: 244 | ;; From wiki: https://en.wikipedia.org/wiki/Fixed-point_combinator 245 | (run 1 (theta) 246 | (== '((lambda (x) (lambda (y) (y ((x x) y)))) 247 | (lambda (x) (lambda (y) (y ((x x) y))))) 248 | theta) 249 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f))))) 250 | ;; => 251 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 252 | (lambda (x) (lambda (y) (y ((x x) y)))))) 253 | ;; Doesn't seem to help re synthesizing bigger terms as you add holes, though. 254 | -------------------------------------------------------------------------------- /miniKanren-version/naive/rbe2.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | ;; reduction by evaluation, in order to synthesize 6 | ;; fixpoint combinators 7 | 8 | ;; Michael Ballantyne and Will Byrd, 22 Feb 02023 9 | 10 | ;; This version: inlined and distributed apply-expro to better connect to output 11 | 12 | (define lookupo 13 | (lambda (x env val) 14 | (fresh (y v env^) 15 | (== `((,y . ,v) . ,env^) env) 16 | (symbolo x) 17 | (symbolo y) 18 | (conde 19 | ((== x y) (== v val)) 20 | ((=/= x y) 21 | (lookupo x env^ val)))))) 22 | 23 | (define eval-expro 24 | (lambda (expr env val) 25 | (conde 26 | ((fresh (x body) 27 | (== `(lambda (,x) ,body) expr) 28 | (== `(closure (,x) ,body ,env) val) 29 | (symbolo x))) 30 | ((symbolo expr) (lookupo expr env val)) 31 | 32 | ((fresh (e1 e2 f v) 33 | (== `(,e1 ,e2) expr) 34 | (== `(NApp ,f ,v) val) 35 | (eval-expro e1 env f) 36 | (eval-expro e2 env v))) 37 | ((fresh (e1 e2 f v x body env^) 38 | (== `(,e1 ,e2) expr) 39 | (== `(closure (,x) ,body ,env^) f) 40 | (symbolo x) 41 | (eval-expro e1 env f) 42 | (eval-expro e2 env v) 43 | (eval-expro body `((,x . ,v) . ,env^) val)))))) 44 | 45 | 46 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 47 | ;; Rather than compute a renamed variable, we just describe the constraints. 48 | (define fresho 49 | (lambda (xs x^) 50 | (fresh () 51 | (symbolo x^) 52 | (absento x^ xs)))) 53 | 54 | (define uneval-valueo 55 | (lambda (xs v expr) 56 | (conde 57 | ((== `(NVar ,expr) v) 58 | (symbolo expr)) 59 | ((fresh (n^ v^ ne ve) 60 | (== `(NApp ,n^ ,v^) v) 61 | (== `(,ne ,ve) expr) 62 | (uneval-valueo xs n^ ne) 63 | (uneval-valueo xs v^ ve))) 64 | ((fresh (x body env x^ body^ bv) 65 | (== `(closure (,x) ,body ,env) v) 66 | (== `(lambda (,x^) ,body^) expr) 67 | (symbolo x) 68 | (symbolo x^) 69 | (fresho xs x^) 70 | (eval-expro body 71 | `((,x . (NVar ,x^)) . ,env) 72 | bv) 73 | (uneval-valueo `(,x^ . ,xs) bv body^)))))) 74 | 75 | (define rfo 76 | (lambda (t expr) 77 | (fresh (v) 78 | (eval-expro t '() v) 79 | (uneval-valueo '() v expr)))) 80 | 81 | (run 5 (q) 82 | (rfo q '(lambda (x) x))) 83 | ;; => 84 | '(((lambda (_.0) _.0) 85 | (sym _.0)) 86 | (((lambda (_.0) (lambda (_.1) _.1)) (lambda (_.2) _.3)) 87 | (sym _.0 _.1 _.2)) 88 | ((lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.3))) 89 | (=/= ((_.0 _.1))) 90 | (sym _.0 _.1 _.2)) 91 | (((lambda (_.0) _.0) (lambda (_.1) _.1)) (sym _.0 _.1)) 92 | ((lambda (_.0) ((lambda (_.1) _.1) _.0)) (sym _.0 _.1))) 93 | 94 | (run* (q) 95 | (rfo '(lambda (x) ((lambda (y) x) (lambda (z) w))) q)) 96 | ;; => 97 | '(((lambda (_.0) _.0) (sym _.0))) 98 | 99 | (run 1 (q) 100 | (fresh (t) 101 | (eval-expro `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) '() q))) 102 | ;; => 103 | '((closure (x) ((lambda (y) x) (lambda (z) w)) ())) 104 | 105 | (run 2 (q) 106 | (eval-expro '((lambda (y) x) (lambda (z) w)) '((x . (NVar x^))) q)) 107 | ;; => 108 | '((NApp 109 | (closure (y) x ((x NVar x^))) 110 | (closure (z) w ((x NVar x^)))) 111 | (NVar x^)) 112 | 113 | (run 3 (t1 t2) 114 | (fresh (t) 115 | (== `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) t1) 116 | (rfo t1 t2))) 117 | ;; => 118 | '((((lambda (x) ((lambda (y) x) (lambda (z) _.0))) 119 | (lambda (_.1) _.1)) 120 | (sym _.1)) 121 | (((lambda (x) ((lambda (y) x) (lambda (z) z))) 122 | (lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.2)))) 123 | (=/= ((_.0 _.1)) ((_.0 _.2))) 124 | (sym _.0 _.1 _.2)) 125 | (((lambda (x) ((lambda (y) x) (lambda (z) x))) 126 | (lambda (_.0) ((lambda (_.1) _.0) (lambda (_.2) _.0)))) 127 | (=/= ((_.0 _.1)) ((_.0 _.2))) 128 | (sym _.0 _.1 _.2))) 129 | 130 | (run 3 (t1 t2) 131 | (fresh (t) 132 | (== t1 t2) 133 | (== `(lambda (x) ((lambda (y) x) (lambda (z) ,t))) t1) 134 | (rfo t1 t2))) 135 | ;; => 136 | '(((lambda (x) ((lambda (y) x) (lambda (z) z))) 137 | (lambda (x) ((lambda (y) x) (lambda (z) z)))) 138 | ((lambda (x) ((lambda (y) x) (lambda (z) x))) 139 | (lambda (x) ((lambda (y) x) (lambda (z) x)))) 140 | (((lambda (x) 141 | ((lambda (y) x) (lambda (z) (lambda (_.0) _.0)))) 142 | (lambda (x) 143 | ((lambda (y) x) (lambda (z) (lambda (_.0) _.0))))) 144 | (=/= ((_.0 x)) ((_.0 z))) 145 | (sym _.0))) 146 | 147 | #| 148 | (run 1 (Y t) 149 | (rfo `(lambda (f) (,Y f)) t) 150 | (rfo `(lambda (f) (f (,Y f))) t)) 151 | |# 152 | 153 | #| 154 | ;; Call-by-name Y combinator 155 | (lambda (f) 156 | ((lambda (x) (f (x x))) 157 | (lambda (x) (f (x x))))) 158 | |# 159 | 160 | (run 1 (Y t) 161 | (== '(lambda (f) 162 | ((lambda (x) (f (x x))) 163 | (lambda (x) (f (x x))))) 164 | Y) 165 | (rfo `(lambda (f) (,Y f)) t) 166 | (rfo `(lambda (f) (f (,Y f))) t)) 167 | ;; => 168 | '((((lambda (f) 169 | ((lambda (x) (f (x x))) 170 | (lambda (x) (f (x x))))) 171 | (lambda (_.0) 172 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 173 | (lambda (_.2) (_.0 (_.2 _.2))))))) 174 | (=/= ((_.0 _.1)) ((_.0 _.2))) 175 | (sym _.0 _.1 _.2))) 176 | 177 | (run 1 (Y t) 178 | (fresh (?) 179 | (== `(lambda (f) 180 | ((lambda (x) (f (x x))) 181 | (lambda (x) (f (,? ,?))))) 182 | Y)) 183 | (rfo `(lambda (f) (,Y f)) t) 184 | (rfo `(lambda (f) (f (,Y f))) t)) 185 | ;; => 186 | '((((lambda (f) 187 | ((lambda (x) (f (x x))) (lambda (x) (f (x x))))) 188 | (lambda (_.0) 189 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 190 | (lambda (_.2) (_.0 (_.2 _.2))))))) 191 | (=/= ((_.0 _.1)) ((_.0 _.2))) 192 | (sym _.0 _.1 _.2))) 193 | 194 | #| 195 | (run 1 (Y t) 196 | (fresh (?) 197 | (== `(lambda (f) 198 | ((lambda (x) (f ,?)) 199 | (lambda (x) (f (x x))))) 200 | Y)) 201 | (rfo `(lambda (f) (,Y f)) t) 202 | (rfo `(lambda (f) (f (,Y f))) t)) 203 | |# 204 | 205 | ;; Omega reduces to itself 206 | (run 2 (t1 t2) 207 | (== '((lambda (x) (x x)) 208 | (lambda (x) (x x))) 209 | t1) 210 | (rfo t1 t2)) 211 | ;; => 212 | '(((((lambda (x) (x x)) (lambda (x) (x x))) 213 | ((lambda (_.0) (_.0 _.0)) (lambda (_.1) (_.1 _.1)))) 214 | (sym _.0 _.1)) 215 | ((((lambda (x) (x x)) (lambda (x) (x x))) 216 | ((lambda (_.0) (_.0 _.0)) (lambda (_.1) (_.1 _.1)))) 217 | (sym _.0 _.1))) 218 | 219 | ;; Challenge: how to generate Omega? 220 | ;; MB suggests that using De Bruijn 221 | ;; would work. 222 | (run 1 (t1 t2) 223 | (=/= t1 t2) 224 | (rfo t1 t2) 225 | (rfo t2 t1)) 226 | ;; => 227 | '((((lambda (_.0) _.0) 228 | (lambda (_.1) _.1)) 229 | (=/= ((_.0 _.1))) 230 | (sym _.0 _.1))) 231 | 232 | (run 1 (t1 t2) 233 | (fresh (e1 e2) 234 | (== `(,e1 ,e2) t1)) 235 | (=/= t1 t2) 236 | (rfo t1 t2) 237 | (rfo t2 t1)) 238 | ;; => 239 | '(((((lambda (_.0) _.0) (lambda (_.1) _.1)) 240 | ((lambda (_.2) _.2) (lambda (_.3) _.3))) 241 | (=/= ((_.0 _.2) (_.1 _.3))) 242 | (sym _.0 _.1 _.2 _.3))) 243 | 244 | 245 | ;; theta from wiki: https://en.wikipedia.org/wiki/Fixed-point_combinator 246 | (test "check theta" 247 | (run 1 (theta) 248 | (== '((lambda (x) (lambda (y) (y ((x x) y)))) 249 | (lambda (x) (lambda (y) (y ((x x) y))))) 250 | theta) 251 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f))))) 252 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 253 | (lambda (x) (lambda (y) (y ((x x) y))))))) 254 | 255 | (test "synthesize a little bit of theta" 256 | (time 257 | (run 1 (theta) 258 | (fresh (?) 259 | (== `((lambda (x) (lambda (y) (y (,? y)))) 260 | (lambda (x) (lambda (y) (y ((x x) y))))) 261 | theta)) 262 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f)))))) 263 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 264 | (lambda (x) (lambda (y) (y ((x x) y))))))) 265 | 266 | -------------------------------------------------------------------------------- /miniKanren-version/naive/rbe3-depth-limited.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | ;; reduction by evaluation, in order to synthesize 6 | ;; fixpoint combinators 7 | 8 | ;; Michael Ballantyne and Will Byrd, 22 Feb 02023 9 | 10 | ;; This version: combine eval and uneval into reduceo, which is used whenever 11 | ;; the eval is being done for immediate uneval. This better connects to the output reduced expression. 12 | 13 | (define MAX_DEPTH_LIMIT '(s s s s s s s s s s)) 14 | 15 | (define lookupo 16 | (lambda (x env val) 17 | (fresh (y v env^) 18 | (== `((,y . ,v) . ,env^) env) 19 | (symbolo x) 20 | (symbolo y) 21 | (conde 22 | ((== x y) (== v val)) 23 | ((=/= x y) 24 | (lookupo x env^ val)))))) 25 | 26 | (define eval-expro 27 | (lambda (expr env val depth-limit) 28 | (conde 29 | ((fresh (x body) 30 | (== `(lambda (,x) ,body) expr) 31 | (== `(closure (,x) ,body ,env) val) 32 | (symbolo x))) 33 | ((symbolo expr) (lookupo expr env val)) 34 | ((fresh (e1 e2 f v x body env^ depth-limit-1) 35 | (== `(,e1 ,e2) expr) 36 | (== `(s . ,depth-limit-1) depth-limit) 37 | (== `(closure (,x) ,body ,env^) f) 38 | (symbolo x) 39 | (eval-expro e1 env f depth-limit-1) 40 | (eval-expro e2 env v depth-limit-1) 41 | (eval-expro body `((,x . ,v) . ,env^) val depth-limit-1)))))) 42 | 43 | 44 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 45 | ;; Rather than compute a renamed variable, we just describe the constraints. 46 | (define fresho 47 | (lambda (xs x^) 48 | (fresh () 49 | (symbolo x^) 50 | (absento x^ xs)))) 51 | 52 | 53 | (define (reduceo xs expr env expr^ depth-limit) 54 | (conde 55 | ;; lambda stays a lambda 56 | [(fresh (x body x^ body^ depth-limit-1) 57 | (== `(lambda (,x) ,body) expr) 58 | (== `(lambda (,x^) ,body^) expr^) 59 | (== `(s . ,depth-limit-1) depth-limit) 60 | (symbolo x) 61 | (symbolo x^) 62 | (fresho xs x^) 63 | (reduceo `(,x^ . ,xs) 64 | body 65 | `((,x . (NVar ,x^)) . ,env) 66 | body^ 67 | depth-limit-1))] 68 | ;; var stays a var 69 | [(symbolo expr) 70 | (symbolo expr^) 71 | (lookupo expr env `(NVar ,expr^))] 72 | 73 | ;; var looks up to a closure 74 | [(fresh (x body x^ body^ env^ depth-limit-1) 75 | (symbolo expr) 76 | (== `(lambda (,x^) ,body^) expr^) 77 | (== `(s . ,depth-limit-1) depth-limit) 78 | (symbolo x^) 79 | (fresho xs x^) 80 | (lookupo expr env `(closure (,x) ,body ,env^)) 81 | (reduceo `(,x^ . ,xs) 82 | body 83 | `((,x . (NVar ,x^)) . ,env) 84 | body^ 85 | depth-limit-1))] 86 | 87 | ;; app stays an app 88 | [(fresh (e1 e2 e1^ e2^ depth-limit-1) 89 | (== `(,e1 ,e2) expr) 90 | (== `(,e1^ ,e2^) expr^) 91 | (== `(s . ,depth-limit-1) depth-limit) 92 | (reduceo xs e1 env e1^ depth-limit-1) 93 | (reduceo xs e2 env e2^ depth-limit-1))] 94 | 95 | ;; app reduces 96 | 97 | ;; It makes sense that to reduce an appplication, we have to 98 | ;; obtain a value for the rator. But, we also force the operand 99 | ;; to reduce. I think this means that this version is implementing 100 | ;; Beta-value reduction, not general beta. 101 | [(fresh (e1 e2 f v x body env^ depth-limit-1) 102 | (== `(,e1 ,e2) expr) 103 | (== `(closure (,x) ,body ,env^) f) 104 | (== `(s . ,depth-limit-1) depth-limit) 105 | (symbolo x) 106 | (eval-expro e1 env f depth-limit-1) 107 | (eval-expro e2 env v depth-limit-1) 108 | (reduceo xs body `((,x . ,v) . ,env^) expr^ depth-limit-1))])) 109 | 110 | (define rfo 111 | (lambda (e e^) 112 | (reduceo '() e '() e^ MAX_DEPTH_LIMIT))) 113 | 114 | 115 | ;; theta from wiki: https://en.wikipedia.org/wiki/Fixed-point_combinator 116 | (test "check theta" 117 | (run 1 (theta) 118 | (== '((lambda (x) (lambda (y) (y ((x x) y)))) 119 | (lambda (x) (lambda (y) (y ((x x) y))))) 120 | theta) 121 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f))))) 122 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 123 | (lambda (x) (lambda (y) (y ((x x) y))))))) 124 | 125 | (test "synthesize a little bit of theta" 126 | (time 127 | (run 1 (theta) 128 | (fresh (?) 129 | (== `((lambda (x) (lambda (y) (y (,? y)))) 130 | (lambda (x) (lambda (y) (y ((x x) y))))) 131 | theta)) 132 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f)))))) 133 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 134 | (lambda (x) (lambda (y) (y ((x x) y))))))) 135 | 136 | (test "synthesize theta" 137 | (time 138 | (run 1 (theta) 139 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f)))))) 140 | '((((lambda (_.0) (lambda (_.1) (_.1 ((_.0 _.0) _.1)))) 141 | (lambda (_.2) (lambda (_.3) (_.3 ((_.2 _.2) _.3))))) 142 | (=/= ((_.0 _.1)) ((_.0 f)) ((_.1 f)) ((_.2 _.3)) ((_.2 f)) 143 | ((_.3 f))) 144 | (sym _.0 _.1 _.2 _.3)))) 145 | 146 | (test "synthesize Y from (lambda (F) (,? ,?)), where ? is the U combinator" 147 | (time (run 1 (Y t) 148 | (fresh (?) 149 | (== `(lambda (f) (,? ,?)) Y)) 150 | (rfo `(lambda (f) (,Y f)) t) 151 | (rfo `(lambda (f) (f (,Y f))) t))) 152 | '((((lambda (f) 153 | ((lambda (_.0) (f (_.0 _.0))) (lambda (_.0) (f (_.0 _.0))))) 154 | (lambda (_.1) 155 | (_.1 (_.1 ((lambda (_.2) (_.1 (_.2 _.2))) 156 | (lambda (_.3) (_.1 (_.3 _.3)))))))) 157 | (=/= ((_.0 f)) ((_.1 _.2)) ((_.1 _.3))) 158 | (sym _.0 _.1 _.2 _.3)))) 159 | ;; (time (run 1 ...)) 160 | ;; 1680 collections 161 | ;; 152.811652658s elapsed cpu time, including 12.961612693s collecting 162 | ;; 152.823347000s elapsed real time, including 12.968673000s collecting 163 | ;; 14080950784 bytes allocated, including 13852423440 bytes reclaimed 164 | 165 | ;; This version seems to take a long time... 166 | #| 167 | (time (run 1 (Y t) 168 | (fresh (?1 ?2) 169 | (== `(lambda (f) (,?1 ,?2)) Y)) 170 | (rfo `(lambda (f) (,Y f)) t) 171 | (rfo `(lambda (f) (f (,Y f))) t))) 172 | |# 173 | 174 | (run 1 (Y t) 175 | (== '(lambda (f) 176 | ((lambda (x) (f (x x))) 177 | (lambda (x) (f (x x))))) 178 | Y) 179 | (rfo `(lambda (f) (,Y f)) t) 180 | (rfo `(lambda (f) (f (,Y f))) t)) 181 | 182 | 183 | (test "Y-3" 184 | (time 185 | (run 1 (Y t) 186 | (fresh (?1 ?2) 187 | (== `(lambda (f) 188 | ((lambda (x) (f (x ,?2))) 189 | ,?1)) Y)) 190 | (rfo `(lambda (f) (f (,Y f))) t) 191 | (rfo `(lambda (f) (,Y f)) t))) 192 | '((((lambda (f) 193 | ((lambda (x) (f (x x))) (lambda (_.0) (f (_.0 _.0))))) 194 | (lambda (_.1) 195 | (_.1 ((lambda (_.2) (_.1 (_.2 _.2))) 196 | (lambda (_.3) (_.1 (_.3 _.3))))))) 197 | (=/= ((_.0 f)) ((_.1 _.2)) ((_.1 _.3))) 198 | (sym _.0 _.1 _.2 _.3)))) 199 | #| 200 | (time (run 1 ...)) 201 | 43 collections 202 | 0.397799458s elapsed cpu time, including 0.024703532s collecting 203 | 0.397874000s elapsed real time, including 0.024787000s collecting 204 | 360975696 bytes allocated, including 357558832 bytes reclaimed 205 | |# 206 | 207 | ;; TODO 208 | ;; * try synthesizing Z combinator 209 | ;; * try to do general beta reduction instead of just beta value 210 | ;; (MB hypothesizes this will require introducing neutral terms to the evaluator) 211 | ;; * add eta 212 | ;; * create De Bruijn version, which should make it easier to represent 213 | ;; Omega synthesis, for example 214 | ;; * merge conde clauses, reorder, etc., if helpful 215 | ;; * add depth limited search 216 | ;; * write a pearl! 217 | -------------------------------------------------------------------------------- /miniKanren-version/naive/rbe3.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | ;; reduction by evaluation, in order to synthesize 6 | ;; fixpoint combinators 7 | 8 | ;; Michael Ballantyne and Will Byrd, 22 Feb 02023 9 | 10 | ;; This version: combine eval and uneval into reduceo, which is used whenever 11 | ;; the eval is being done for immediate uneval. This better connects to the output reduced expression. 12 | 13 | (define lookupo 14 | (lambda (x env val) 15 | (fresh (y v env^) 16 | (== `((,y . ,v) . ,env^) env) 17 | (symbolo x) 18 | (symbolo y) 19 | (conde 20 | ((== x y) (== v val)) 21 | ((=/= x y) 22 | (lookupo x env^ val)))))) 23 | 24 | (define eval-expro 25 | (lambda (expr env val) 26 | (conde 27 | ((fresh (x body) 28 | (== `(lambda (,x) ,body) expr) 29 | (== `(closure (,x) ,body ,env) val) 30 | (symbolo x))) 31 | ((symbolo expr) (lookupo expr env val)) 32 | ((fresh (e1 e2 f v x body env^) 33 | (== `(,e1 ,e2) expr) 34 | (== `(closure (,x) ,body ,env^) f) 35 | (symbolo x) 36 | (eval-expro e1 env f) 37 | (eval-expro e2 env v) 38 | (eval-expro body `((,x . ,v) . ,env^) val)))))) 39 | 40 | 41 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 42 | ;; Rather than compute a renamed variable, we just describe the constraints. 43 | (define fresho 44 | (lambda (xs x^) 45 | (fresh () 46 | (symbolo x^) 47 | (absento x^ xs)))) 48 | 49 | 50 | (define (reduceo xs expr env expr^) 51 | (conde 52 | ;; lambda stays a lambda 53 | [(fresh (x body x^ body^) 54 | (== `(lambda (,x) ,body) expr) 55 | (== `(lambda (,x^) ,body^) expr^) 56 | (symbolo x) 57 | (symbolo x^) 58 | (fresho xs x^) 59 | (reduceo `(,x^ . ,xs) 60 | body 61 | `((,x . (NVar ,x^)) . ,env) 62 | body^))] 63 | 64 | ;; var stays a var 65 | [(symbolo expr) 66 | (symbolo expr^) 67 | (lookupo expr env `(NVar ,expr^))] 68 | 69 | ;; var looks up to a closure 70 | [(fresh (x body x^ body^ env^) 71 | (symbolo expr) 72 | (== `(lambda (,x^) ,body^) expr^) 73 | (symbolo x^) 74 | (fresho xs x^) 75 | (lookupo expr env `(closure (,x) ,body ,env^)) 76 | (reduceo `(,x^ . ,xs) 77 | body 78 | `((,x . (NVar ,x^)) . ,env) 79 | body^))] 80 | 81 | ;; app stays an app 82 | [(fresh (e1 e2 e1^ e2^) 83 | (== `(,e1 ,e2) expr) 84 | (== `(,e1^ ,e2^) expr^) 85 | (reduceo xs e1 env e1^) 86 | (reduceo xs e2 env e2^))] 87 | 88 | ;; app reduces 89 | 90 | ;; It makes sense that to reduce an appplication, we have to 91 | ;; obtain a value for the rator. But, we also force the operand 92 | ;; to reduce. I think this means that this version is implementing 93 | ;; Beta-value reduction, not general beta. 94 | [(fresh (e1 e2 f v x body env^) 95 | (== `(,e1 ,e2) expr) 96 | (== `(closure (,x) ,body ,env^) f) 97 | (symbolo x) 98 | (eval-expro e1 env f) 99 | (eval-expro e2 env v) 100 | (reduceo xs body `((,x . ,v) . ,env^) expr^))])) 101 | 102 | (define rfo 103 | (lambda (e e^) 104 | (reduceo '() e '() e^))) 105 | 106 | (test "check it's Beta-v" 107 | (run* (q) (rfo '(lambda (f) ((lambda (x) x) ((lambda (x) (x x)) f))) q)) 108 | '( 109 | ;; reduced in operand; note that (_.0 _.0) cannot be further reduced because the value of the variable is unknown 110 | ((lambda (_.0) ((lambda (_.1) _.1) (_.0 _.0))) 111 | (=/= ((_.0 _.1))) 112 | (sym _.0 _.1)) 113 | 114 | ;; not reduced at all 115 | ((lambda (_.0) 116 | ((lambda (_.1) _.1) ((lambda (_.2) (_.2 _.2)) _.0))) 117 | (=/= ((_.0 _.1)) ((_.0 _.2))) 118 | (sym _.0 _.1 _.2)) 119 | 120 | ;; no additional answer where the top-level application is reduced 121 | )) 122 | 123 | ;; theta from wiki: https://en.wikipedia.org/wiki/Fixed-point_combinator 124 | (test "check theta" 125 | (run 1 (theta) 126 | (== '((lambda (x) (lambda (y) (y ((x x) y)))) 127 | (lambda (x) (lambda (y) (y ((x x) y))))) 128 | theta) 129 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f))))) 130 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 131 | (lambda (x) (lambda (y) (y ((x x) y))))))) 132 | 133 | (test "synthesize a little bit of theta" 134 | (time 135 | (run 1 (theta) 136 | (fresh (?) 137 | (== `((lambda (x) (lambda (y) (y (,? y)))) 138 | (lambda (x) (lambda (y) (y ((x x) y))))) 139 | theta)) 140 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f)))))) 141 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 142 | (lambda (x) (lambda (y) (y ((x x) y))))))) 143 | 144 | (test "synthesize theta" 145 | (time 146 | (run 1 (theta) 147 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f)))))) 148 | '((((lambda (_.0) (lambda (_.1) (_.1 ((_.0 _.0) _.1)))) 149 | (lambda (_.2) (lambda (_.3) (_.3 ((_.2 _.2) _.3))))) 150 | (=/= ((_.0 _.1)) ((_.0 f)) ((_.1 f)) ((_.2 _.3)) ((_.2 f)) 151 | ((_.3 f))) 152 | (sym _.0 _.1 _.2 _.3)))) 153 | 154 | (test "synthesize Y from (lambda (F) (,? ,?)), where ? is the U combinator" 155 | (time (run 1 (Y t) 156 | (fresh (?) 157 | (== `(lambda (f) (,? ,?)) Y)) 158 | (rfo `(lambda (f) (,Y f)) t) 159 | (rfo `(lambda (f) (f (,Y f))) t))) 160 | '((((lambda (f) 161 | ((lambda (_.0) (f (_.0 _.0))) (lambda (_.0) (f (_.0 _.0))))) 162 | (lambda (_.1) 163 | (_.1 (_.1 ((lambda (_.2) (_.1 (_.2 _.2))) 164 | (lambda (_.3) (_.1 (_.3 _.3)))))))) 165 | (=/= ((_.0 f)) ((_.1 _.2)) ((_.1 _.3))) 166 | (sym _.0 _.1 _.2 _.3)))) 167 | ;; (time (run 1 ...)) 168 | ;; 1680 collections 169 | ;; 152.811652658s elapsed cpu time, including 12.961612693s collecting 170 | ;; 152.823347000s elapsed real time, including 12.968673000s collecting 171 | ;; 14080950784 bytes allocated, including 13852423440 bytes reclaimed 172 | 173 | ;; This version seems to take a long time... 174 | #| 175 | (time (run 1 (Y t) 176 | (fresh (?1 ?2) 177 | (== `(lambda (f) (,?1 ,?2)) Y)) 178 | (rfo `(lambda (f) (,Y f)) t) 179 | (rfo `(lambda (f) (f (,Y f))) t))) 180 | |# 181 | 182 | ;; Note that the (f (,Y f)) term coming before (,Y f) 183 | ;; speeds up at least some of these tests 184 | (test "synthesize Y, 2" 185 | (time 186 | (run 1 (Y t) 187 | (fresh (?1 ?2) 188 | (== `(lambda (f) 189 | (,?1 190 | (lambda (x) (f (x ,?2))))) Y)) 191 | (rfo `(lambda (f) (f (,Y f))) t) 192 | (rfo `(lambda (f) (,Y f)) t))) 193 | '((((lambda (f) 194 | ((lambda (_.0) (_.0 _.0)) (lambda (x) (f (x x))))) 195 | (lambda (_.1) 196 | (_.1 (_.1 ((lambda (_.2) (_.1 (_.2 _.2))) 197 | (lambda (_.3) (_.1 (_.3 _.3)))))))) 198 | (=/= ((_.1 _.2)) ((_.1 _.3))) 199 | (sym _.0 _.1 _.2 _.3)))) 200 | ;; (time (run 1 ...)) 201 | ;; 512 collections 202 | ;; 8.432182553s elapsed cpu time, including 2.167394615s collecting 203 | ;; 8.432332000s elapsed real time, including 2.168518000s collecting 204 | ;; 4292458960 bytes allocated, including 4751902880 bytes reclaimed 205 | 206 | ;; seems to take a long time 207 | #| 208 | (time 209 | (run 1 (Y t) 210 | (fresh (?1 ?2) 211 | (== `(lambda (f) 212 | (,?1 213 | (lambda (x) (f ,?2)))) Y)) 214 | (rfo `(lambda (f) (f (,Y f))) t) 215 | (rfo `(lambda (f) (,Y f)) t))) 216 | |# 217 | 218 | (test "Y-4" 219 | (time 220 | (run 1 (Y t) 221 | (fresh (body ?1 ?2) 222 | (== `(lambda (f) 223 | ((lambda (x) ,?1) 224 | (lambda (x) (f (x ,?2))))) Y) 225 | (== `(lambda (f) ,body) t) 226 | (rfo `((lambda (f) (f (,Y f))) (lambda (f) (,Y f))) 227 | `(,t ,t)) 228 | (rfo `(lambda (f) (f (,Y f))) t) 229 | (rfo `(lambda (f) (,Y f)) t)))) 230 | '((((lambda (f) ((lambda (x) (x x)) (lambda (x) (f (x x))))) 231 | (lambda (f) 232 | (f (f ((lambda (_.0) (f (_.0 _.0))) 233 | (lambda (_.1) (f (_.1 _.1)))))))) 234 | (=/= ((_.0 f)) ((_.1 f))) 235 | (sym _.0 _.1)))) 236 | ;; (time (run 1 ...)) 237 | ;; 929 collections 238 | ;; 13.202181094s elapsed cpu time, including 2.718599906s collecting 239 | ;; 13.203039000s elapsed real time, including 2.720404000s collecting 240 | ;; 7812939584 bytes allocated, including 7615335136 bytes reclaimed 241 | 242 | 243 | 244 | ;; TODO 245 | ;; * try synthesizing Z combinator 246 | ;; * try to do general beta reduction instead of just beta value 247 | ;; (MB hypothesizes this will require introducing neutral terms to the evaluator) 248 | ;; * add eta 249 | ;; * create De Bruijn version, which should make it easier to represent 250 | ;; Omega synthesis, for example 251 | ;; * merge conde clauses, reorder, etc., if helpful 252 | ;; * add depth limited search 253 | ;; * write a pearl! 254 | -------------------------------------------------------------------------------- /miniKanren-version/naive/rbe4.scm: -------------------------------------------------------------------------------- 1 | (load "../faster-miniKanren/mk-vicare.scm") 2 | (load "../faster-miniKanren/mk.scm") 3 | (load "../faster-miniKanren/test-check.scm") 4 | 5 | ;; reduction by evaluation, in order to synthesize 6 | ;; fixpoint combinators 7 | 8 | ;; Michael Ballantyne and Will Byrd, 22 Feb 02023 9 | 10 | ;; This version: combine eval and uneval into reduceo, which is used whenever 11 | ;; the eval is being done for immediate uneval. This better connects to the output reduced expression. 12 | 13 | (define lookupo 14 | (lambda (x env val) 15 | (fresh (y v env^) 16 | (== `((,y . ,v) . ,env^) env) 17 | (symbolo x) 18 | (symbolo y) 19 | (conde 20 | ((== x y) (== v val)) 21 | ((=/= x y) 22 | (lookupo x env^ val)))))) 23 | 24 | (define eval-expro 25 | (lambda (expr env val) 26 | (conde 27 | ((fresh (x body) 28 | (== `(lambda (,x) ,body) expr) 29 | (== `(closure (,x) ,body ,env) val) 30 | (symbolo x))) 31 | ((symbolo expr) (lookupo expr env val)) 32 | ((fresh (e1 e2 f v x body env^) 33 | (== `(,e1 ,e2) expr) 34 | (== `(closure (,x) ,body ,env^) f) 35 | (symbolo x) 36 | (eval-expro e1 env f) 37 | (eval-expro e2 env v) 38 | (eval-expro body `((,x . ,v) . ,env^) val)))))) 39 | 40 | 41 | ;; Fast and simple fresho definition (written with Michael Ballantyne) 42 | ;; Rather than compute a renamed variable, we just describe the constraints. 43 | (define fresho 44 | (lambda (xs x^) 45 | (fresh () 46 | (symbolo x^) 47 | (absento x^ xs)))) 48 | 49 | 50 | (define (reduceo xs expr env expr^) 51 | (conde 52 | 53 | ;; var stays a var 54 | [(symbolo expr) 55 | (symbolo expr^) 56 | (lookupo expr env `(NVar ,expr^))] 57 | 58 | ;; lambda stays a lambda 59 | [(fresh (x body x^ body^) 60 | (== `(lambda (,x) ,body) expr) 61 | (== `(lambda (,x^) ,body^) expr^) 62 | (symbolo x) 63 | (symbolo x^) 64 | (fresho xs x^) 65 | (reduceo `(,x^ . ,xs) 66 | body 67 | `((,x . (NVar ,x^)) . ,env) 68 | body^))] 69 | 70 | ;; var looks up to a closure 71 | [(fresh (x body x^ body^ env^) 72 | (symbolo expr) 73 | (== `(lambda (,x^) ,body^) expr^) 74 | (symbolo x^) 75 | (fresho xs x^) 76 | (lookupo expr env `(closure (,x) ,body ,env^)) 77 | (reduceo `(,x^ . ,xs) 78 | body 79 | `((,x . (NVar ,x^)) . ,env) 80 | body^))] 81 | 82 | ;; app stays an app 83 | [(fresh (e1 e2 e1^ e2^) 84 | (== `(,e1 ,e2) expr) 85 | (== `(,e1^ ,e2^) expr^) 86 | (reduceo xs e1 env e1^) 87 | (reduceo xs e2 env e2^))] 88 | 89 | ;; app reduces 90 | 91 | ;; It makes sense that to reduce an appplication, we have to 92 | ;; obtain a value for the rator. But, we also force the operand 93 | ;; to reduce. I think this means that this version is implementing 94 | ;; Beta-value reduction, not general beta. 95 | [(fresh (e1 e2 f v x body env^) 96 | (== `(,e1 ,e2) expr) 97 | (== `(closure (,x) ,body ,env^) f) 98 | (symbolo x) 99 | (eval-expro e1 env f) 100 | (eval-expro e2 env v) 101 | (reduceo xs body `((,x . ,v) . ,env^) expr^))])) 102 | 103 | (define rfo 104 | (lambda (e e^) 105 | (reduceo '() e '() e^))) 106 | 107 | 108 | ;; theta from wiki: https://en.wikipedia.org/wiki/Fixed-point_combinator 109 | (test "check theta" 110 | (run 1 (theta) 111 | (== '((lambda (x) (lambda (y) (y ((x x) y)))) 112 | (lambda (x) (lambda (y) (y ((x x) y))))) 113 | theta) 114 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f))))) 115 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 116 | (lambda (x) (lambda (y) (y ((x x) y))))))) 117 | 118 | (test "synthesize a little bit of theta" 119 | (time 120 | (run 1 (theta) 121 | (fresh (?) 122 | (== `((lambda (x) (lambda (y) (y (,? y)))) 123 | (lambda (x) (lambda (y) (y ((x x) y))))) 124 | theta)) 125 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f)))))) 126 | '(((lambda (x) (lambda (y) (y ((x x) y)))) 127 | (lambda (x) (lambda (y) (y ((x x) y))))))) 128 | 129 | (test "synthesize theta" 130 | (time 131 | (run 1 (theta) 132 | (rfo `(lambda (f) (,theta f)) `(lambda (f) (f (,theta f)))))) 133 | '((((lambda (_.0) (lambda (_.1) (_.1 ((_.0 _.0) _.1)))) 134 | (lambda (_.2) (lambda (_.3) (_.3 ((_.2 _.2) _.3))))) 135 | (=/= ((_.0 _.1)) ((_.0 f)) ((_.1 f)) ((_.2 _.3)) ((_.2 f)) 136 | ((_.3 f))) 137 | (sym _.0 _.1 _.2 _.3)))) 138 | 139 | (test "synthesize Y from (lambda (F) (,? ,?)), where ? is the U combinator" 140 | (time (run 1 (Y t) 141 | (fresh (?) 142 | (== `(lambda (f) (,? ,?)) Y)) 143 | (rfo `(lambda (f) (,Y f)) t) 144 | (rfo `(lambda (f) (f (,Y f))) t))) 145 | '((((lambda (f) 146 | ((lambda (_.0) (f (_.0 _.0))) (lambda (_.0) (f (_.0 _.0))))) 147 | (lambda (_.1) 148 | (_.1 (_.1 ((lambda (_.2) (_.1 (_.2 _.2))) 149 | (lambda (_.3) (_.1 (_.3 _.3)))))))) 150 | (=/= ((_.0 f)) ((_.1 _.2)) ((_.1 _.3))) 151 | (sym _.0 _.1 _.2 _.3)))) 152 | ;; (time (run 1 ...)) 153 | ;; 1680 collections 154 | ;; 152.811652658s elapsed cpu time, including 12.961612693s collecting 155 | ;; 152.823347000s elapsed real time, including 12.968673000s collecting 156 | ;; 14080950784 bytes allocated, including 13852423440 bytes reclaimed 157 | 158 | ;; This version seems to take a long time... 159 | #| 160 | (time (run 1 (Y t) 161 | (fresh (?1 ?2) 162 | (== `(lambda (f) (,?1 ,?2)) Y)) 163 | (rfo `(lambda (f) (,Y f)) t) 164 | (rfo `(lambda (f) (f (,Y f))) t))) 165 | |# 166 | 167 | ;; Note that the (f (,Y f)) term coming before (,Y f) 168 | ;; speeds up at least some of these tests 169 | (test "synthesize Y, 2" 170 | (time 171 | (run 1 (Y t) 172 | (fresh (?1 ?2) 173 | (== `(lambda (f) 174 | (,?1 175 | (lambda (x) (f (x ,?2))))) Y)) 176 | (rfo `(lambda (f) (f (,Y f))) t) 177 | (rfo `(lambda (f) (,Y f)) t))) 178 | '((((lambda (f) 179 | ((lambda (_.0) (_.0 _.0)) (lambda (x) (f (x x))))) 180 | (lambda (_.1) 181 | (_.1 (_.1 ((lambda (_.2) (_.1 (_.2 _.2))) 182 | (lambda (_.3) (_.1 (_.3 _.3)))))))) 183 | (=/= ((_.1 _.2)) ((_.1 _.3))) 184 | (sym _.0 _.1 _.2 _.3)))) 185 | ;; (time (run 1 ...)) 186 | ;; 512 collections 187 | ;; 8.432182553s elapsed cpu time, including 2.167394615s collecting 188 | ;; 8.432332000s elapsed real time, including 2.168518000s collecting 189 | ;; 4292458960 bytes allocated, including 4751902880 bytes reclaimed 190 | 191 | ;; seems to take a long time 192 | #| 193 | (time 194 | (run 1 (Y t) 195 | (fresh (?1 ?2) 196 | (== `(lambda (f) 197 | (,?1 198 | (lambda (x) (f ,?2)))) Y)) 199 | (rfo `(lambda (f) (f (,Y f))) t) 200 | (rfo `(lambda (f) (,Y f)) t))) 201 | |# 202 | 203 | (test "Y-4" 204 | (time 205 | (run 1 (Y t) 206 | (fresh (body ?1 ?2) 207 | (== `(lambda (f) 208 | ((lambda (x) ,?1) 209 | (lambda (x) (f (x ,?2))))) Y) 210 | (== `(lambda (f) ,body) t) 211 | (rfo `((lambda (f) (f (,Y f))) (lambda (f) (,Y f))) 212 | `(,t ,t)) 213 | (rfo `(lambda (f) (f (,Y f))) t) 214 | (rfo `(lambda (f) (,Y f)) t)))) 215 | '((((lambda (f) ((lambda (x) (x x)) (lambda (x) (f (x x))))) 216 | (lambda (f) 217 | (f (f ((lambda (_.0) (f (_.0 _.0))) 218 | (lambda (_.1) (f (_.1 _.1)))))))) 219 | (=/= ((_.0 f)) ((_.1 f))) 220 | (sym _.0 _.1)))) 221 | ;; (time (run 1 ...)) 222 | ;; 929 collections 223 | ;; 13.202181094s elapsed cpu time, including 2.718599906s collecting 224 | ;; 13.203039000s elapsed real time, including 2.720404000s collecting 225 | ;; 7812939584 bytes allocated, including 7615335136 bytes reclaimed 226 | 227 | 228 | (test "Is this equivalent to Y???" 229 | (time 230 | (run 1 (Y t) 231 | (fresh (?1 ?2) 232 | (== `(lambda (f) 233 | ((lambda (x) ,?1) 234 | (lambda (x) (f ,?2)))) Y) 235 | (rfo `(lambda (f) (f (,Y f))) t) 236 | (rfo `(lambda (f) (,Y f)) t)))) 237 | '((((lambda (f) 238 | ((lambda (x) (x x)) 239 | (lambda (x) (f ((lambda (_.0) (_.0 _.0)) x))))) 240 | (lambda (_.1) 241 | (_.1 ((lambda (_.2) (_.2 _.2)) 242 | (lambda (_.3) (_.1 (_.3 _.3))))))) 243 | (=/= ((_.1 _.2)) ((_.1 _.3))) 244 | (sym _.0 _.1 _.2 _.3)))) 245 | ;; (time (run 1 ...)) 246 | ;; 1133 collections 247 | ;; 20.336744548s elapsed cpu time, including 5.535748777s collecting 248 | ;; 20.342381000s elapsed real time, including 5.540460000s collecting 249 | ;; 9503583280 bytes allocated, including 9546430240 bytes reclaimed 250 | 251 | (test "Is this equivalent to Y??? 2" 252 | (time 253 | (run 1 (Y t) 254 | (fresh (?) 255 | (== `(lambda (f) 256 | ((lambda (x) (x x)) 257 | (lambda (x) (f ,?)))) Y) 258 | (rfo `(lambda (f) (f (,Y f))) t) 259 | (rfo `(lambda (f) (,Y f)) t)))) 260 | '((((lambda (f) ((lambda (x) (x x)) (lambda (x) (f (x x))))) 261 | (lambda (_.0) 262 | (_.0 ((lambda (_.1) (_.0 (_.1 _.1))) 263 | (lambda (_.2) (_.0 (_.2 _.2))))))) 264 | (=/= ((_.0 _.1)) ((_.0 _.2))) 265 | (sym _.0 _.1 _.2)))) 266 | ;; (time (run 1 ...)) 267 | ;; 3 collections 268 | ;; 0.042179431s elapsed cpu time, including 0.001822860s collecting 269 | ;; 0.042174000s elapsed real time, including 0.001832000s collecting 270 | ;; 31568176 bytes allocated, including 25000224 bytes reclaimed 271 | 272 | ;; TODO 273 | ;; * try synthesizing Z combinator 274 | ;; * try to do general beta reduction instead of just beta value 275 | ;; (MB hypothesizes this will require introducing neutral terms to the evaluator) 276 | ;; * add eta 277 | ;; * create De Bruijn version, which should make it easier to represent 278 | ;; Omega synthesis, for example 279 | ;; * merge conde clauses, reorder, etc., if helpful 280 | ;; * add depth limited search 281 | ;; * write a pearl! 282 | -------------------------------------------------------------------------------- /original-edward-kmett-code/N.hs: -------------------------------------------------------------------------------- 1 | type Name = String 2 | 3 | data Expr 4 | = Var Name 5 | | App Expr Expr 6 | | Lam Name Expr 7 | deriving Show 8 | 9 | type Env = [(Name,Value)] 10 | 11 | data Value 12 | = Closure Env Name Expr 13 | | N Neutral 14 | deriving Show 15 | 16 | data Neutral 17 | = NVar Name 18 | | NApp Neutral Value 19 | deriving Show 20 | 21 | eval :: MonadFail m => Env -> Expr -> m Value 22 | eval e (Var x) = case lookup x e of 23 | Nothing -> fail "uhoh" 24 | Just v -> pure v 25 | eval e (App f x) = do 26 | vf <- eval e f 27 | vx <- eval e x 28 | apply vf vx 29 | eval e (Lam x b) = pure $ Closure e x b 30 | 31 | apply :: MonadFail m => Value -> Value -> m Value 32 | apply (Closure e x b) v = eval ((x,v):e) b 33 | apply (N n) v = pure (N (NApp n v)) 34 | 35 | fresh :: [Name] -> Name -> Name 36 | fresh xs x 37 | | elem x xs = fresh xs (x++"'") 38 | | otherwise = x 39 | 40 | uneval :: MonadFail m => [Name] -> Value -> m Expr 41 | uneval xs (Closure e x b) = do 42 | let x' = fresh xs x 43 | bv <- eval ((x,N $ NVar x'):e) b 44 | b' <- uneval (x':xs) bv 45 | pure (Lam x' b') 46 | uneval xs (N n) = unevalN xs n 47 | 48 | unevalN :: MonadFail m => [Name] -> Neutral -> m Expr 49 | unevalN _ (NVar x') = pure $ Var x' 50 | unevalN xs (NApp n v) = do 51 | ne <- unevalN xs n 52 | ve <- uneval xs v 53 | pure (App ne ve) 54 | 55 | nf :: MonadFail m => Env -> Expr -> m Expr 56 | nf e t = do 57 | v <- eval e t 58 | uneval [] v 59 | 60 | main = do 61 | id_ <- eval [] (Lam "x" (Var "x")) 62 | const_ <- eval [] (Lam "x" (Lam "y" (Var "x"))) 63 | result <- eval [("id",id_),("const",const_)] (App (Var "const") (Var "id")) 64 | print result 65 | -------------------------------------------------------------------------------- /original-edward-kmett-code/N2.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Fail as Monad 2 | 3 | import Control.Monad (unless) 4 | import Data.Maybe 5 | 6 | type Name = String 7 | 8 | data Expr 9 | = Var Name 10 | | App Expr Expr 11 | | Lam Name Expr 12 | 13 | | LitBool Bool 14 | | If Expr Expr Expr 15 | 16 | | Zero 17 | | Succ Expr 18 | | Rec Type Expr Expr Expr 19 | 20 | | Ann Expr Type 21 | deriving Show 22 | 23 | data Type 24 | = Bool 25 | | Nat 26 | | Type :-> Type 27 | deriving (Show, Eq) 28 | 29 | type Env a = [(Name,a)] 30 | 31 | data Value 32 | = Closure (Env Value) Name Expr 33 | | N Neutral 34 | | VLitBool Bool 35 | | VZero 36 | | VSucc Value 37 | deriving Show 38 | 39 | data Neutral 40 | = NVar Name 41 | | NApp Neutral Value 42 | | NRec Type Neutral Value Value 43 | | NIf Neutral Value Value 44 | deriving Show 45 | 46 | fresh :: [Name] -> Name -> Name 47 | fresh xs x 48 | | elem x xs = fresh xs (x ++ "'") 49 | | otherwise = x 50 | 51 | extend :: Name -> a -> Env a -> Env a 52 | extend x v xs = (x,v):xs 53 | 54 | lookupVar :: MonadFail m => Name -> Env a -> m a 55 | lookupVar x xs = case lookup x xs of 56 | Nothing -> Monad.fail "bad var" 57 | Just v -> pure v 58 | 59 | infer :: MonadFail m => Env Type -> Expr -> m Type 60 | infer e (Var x) = lookupVar x e 61 | infer e (App f x) = do 62 | σ :-> τ <- infer e f 63 | τ <$ check e x σ 64 | infer _ Zero = pure Nat 65 | infer _ (LitBool _) = pure Bool 66 | infer e (If c tb eb) = do 67 | check e c Bool 68 | tt <- infer e tb 69 | tt <$ check e eb tt 70 | infer e (Ann t τ) = τ <$ check e t τ 71 | infer e (Succ n) = Nat <$ check e n Nat 72 | infer e (Rec τ n z s) = do 73 | check e n Nat 74 | check e z τ 75 | τ <$ check e s (τ :-> τ) 76 | infer _ t = Monad.fail $ "unable to infer type for " ++ show t 77 | 78 | check :: MonadFail m => Env Type -> Expr -> Type -> m () 79 | check e (Lam x b) (σ :-> τ) = check (extend x σ e) b τ 80 | check e tm τ = do 81 | τ' <- infer e tm 82 | unless (τ == τ') $ Monad.fail "type mismatch" 83 | 84 | eval :: Env Value -> Expr -> Value 85 | eval e (Var x) = fromJust $ lookupVar x e 86 | eval e (App f x) = apply (eval e f) (eval e x) 87 | eval e (Lam x b) = Closure e x b 88 | eval _ (LitBool b) = VLitBool b 89 | eval _ Zero = VZero 90 | eval e (Succ t) = VSucc (eval e t) 91 | eval e (If c tb eb) = if_ e (eval e c) tb eb 92 | eval e (Rec τ n z s) = rec e τ (eval e n) (eval e z) s 93 | 94 | apply :: Value -> Value -> Value 95 | apply (Closure e x b) v = eval (extend x v e) b 96 | apply (N n) v = N (NApp n v) 97 | 98 | if_ :: Env Value -> Value -> Expr -> Expr -> Value 99 | if_ e (VLitBool c) tb eb = eval e $ if c then tb else eb 100 | if_ e (N n) tb eb = N $ NIf n (eval e tb) (eval e eb) 101 | 102 | rec :: Env Value -> Type -> Value -> Value -> Expr -> Value 103 | rec e _ VZero z _ = z 104 | rec e τ (VSucc n) z s = rec e τ n (apply (eval e s) z) s 105 | rec e τ (N n) z s = N $ NRec τ n z (eval e s) 106 | 107 | uneval :: [Name] -> Value -> Expr 108 | uneval xs VZero = Zero 109 | uneval xs (VSucc n) = Succ $ uneval xs n 110 | uneval xs (VLitBool b) = LitBool b 111 | uneval xs (Closure e x b) = 112 | let x' = fresh xs x in 113 | Lam x' $ uneval (x':xs) $ eval (extend x (N $ NVar x') e) b 114 | uneval xs (N n) = go n where 115 | go (NVar x) = Var x 116 | go (NApp n v) = App (go n) (uneval xs v) 117 | go (NRec τ n z s) = Rec τ (go n) (uneval xs z) (uneval xs s) 118 | go (NIf n tv ev) = If (go n) (uneval xs tv) (uneval xs ev) 119 | 120 | program :: MonadFail m => Env Expr -> m (Env Type, Env Value) 121 | program = go [] [] where 122 | go ctx e [] = pure (ctx,e) 123 | go ctx e ((x,tm):xs) = do 124 | ty <- infer ctx tm 125 | let v = eval e tm 126 | go (extend x ty ctx) (extend x v e) xs 127 | 128 | nf :: Env Value -> Expr -> Expr 129 | nf e t = uneval [] (eval e t) 130 | 131 | example :: MonadFail m => m Expr 132 | example = do 133 | (ctx,e) <- program 134 | [ ("id", Ann (Lam "x" $ Var "x") $ Nat :-> Nat) 135 | , ("const", Ann (Lam "x" $ Lam "y" $ Var "x") $ (Nat :-> Nat) :-> Bool :-> (Nat :-> Nat)) 136 | ] 137 | let tm = App (Var "const") (Var "id") 138 | infer ctx tm 139 | pure $ nf e tm 140 | 141 | main :: IO () 142 | main = example >>= print 143 | -------------------------------------------------------------------------------- /original-edward-kmett-code/deBruijn/NB.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language StrictData #-} 3 | 4 | data Expr 5 | = Var Int 6 | | Lam Expr 7 | | App Expr Expr 8 | deriving (Eq,Show) 9 | 10 | type Env = [Val] 11 | 12 | data Val 13 | = Clo Env Expr -- (Val -> Val) 14 | | N Neutral 15 | 16 | data Neutral 17 | = NVar Int 18 | | NApp Neutral Val 19 | 20 | nth :: Int -> [a] -> a 21 | nth 0 (x:_) = x 22 | nth n (_:xs) = nth (n-1) xs 23 | 24 | eval :: Env -> Expr -> Val 25 | eval e (Var x) = nth x e 26 | eval e (App f x) = app (eval e f) (eval e x) 27 | --eval e (Lam n b) = Clo n \v -> eval (v:e) b 28 | eval e (Lam b) = Clo e b 29 | 30 | app :: Val -> Val -> Val 31 | --app (Clo _ f) v = f v 32 | app (Clo e b) v = eval (v:e) b 33 | app (N n) v = N (NApp n v) 34 | 35 | uneval :: Int -> Val -> Expr 36 | uneval d (Clo e b) = Lam (uneval (d+1) (eval (N (NVar d):e) b)) 37 | uneval d (N n) = unevalN d n 38 | 39 | unevalN :: Int -> Neutral -> Expr 40 | unevalN d (NVar n) = Var (d-n-1) 41 | unevalN d (NApp f x) = App (unevalN d f) (uneval d x) 42 | 43 | nf :: Env -> Expr -> Expr 44 | nf e t = uneval 0 (eval e t) 45 | 46 | main = do 47 | let id_ = eval [] (Lam $ Var 0) 48 | let const_ = eval [] (Lam $ Lam $ Var 1) 49 | print $ nf [id_,const_] $ App (Var 1) (Var 0) 50 | 51 | -------------------------------------------------------------------------------- /original-edward-kmett-code/deBruijn/NB2.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language StrictData #-} 3 | 4 | data Expr 5 | = Var Int 6 | | Lam Expr 7 | | App Expr Expr 8 | deriving Show 9 | 10 | type Env = [Val] 11 | 12 | data Val 13 | = VLam Env Expr 14 | | VVar Int Spine 15 | 16 | data Spine 17 | = SNil 18 | | SApp Spine Val 19 | 20 | nth :: Int -> [a] -> a 21 | nth 0 (x:_) = x 22 | nth n (_:xs) = nth (n-1) xs 23 | 24 | eval :: Env -> Expr -> Val 25 | eval e (Var x) = nth x e 26 | eval e (App f x) = app (eval e f) (eval e x) 27 | eval e (Lam b) = VLam e b 28 | 29 | app :: Val -> Val -> Val 30 | app (VLam e b) v = eval (v:e) b 31 | app (VVar n s) v = VVar n (SApp s v) 32 | 33 | uneval :: Int -> Val -> Expr 34 | uneval d (VLam e b) = Lam (uneval (d+1) (eval (VVar d SNil:e) b)) 35 | uneval d (VVar n s) = unevalSp d (Var (d-n-1)) s 36 | 37 | unevalSp :: Int -> Expr -> Spine -> Expr 38 | unevalSp d e SNil = e 39 | unevalSp d e (SApp xs x) = App (unevalSp d e xs) (uneval d x) 40 | 41 | nf :: Env -> Expr -> Expr 42 | nf e t = uneval 0 (eval e t) 43 | 44 | main = do 45 | let id_ = eval [] (Lam $ Var 0) 46 | let const_ = eval [] (Lam $ Lam $ Var 1) 47 | print $ nf [id_,const_] $ App (Var 1) (Var 0) 48 | 49 | -------------------------------------------------------------------------------- /scheme-helpers/pmatch.scm: -------------------------------------------------------------------------------- 1 | ;; This is a new version of pmatch (August 8, 2012). 2 | ;; It has two important new features: 3 | ;; 1. It allows for a name to be given to the pmatch if an error ensues. 4 | ;; 2. A line from the specification has been removed. (see below). Without 5 | ;; that line removed, it was impossible for a pattern to be (quote ,x), 6 | ;; which might be worth having especially when we write an interpreter 7 | ;; for Scheme, which includes quote as a language form. 8 | 9 | ;;; Code written by Oleg Kiselyov 10 | ;; (http://pobox.com/~oleg/ftp/) 11 | ;;; 12 | ;;; Taken from leanTAP.scm 13 | ;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log 14 | 15 | ; A simple linear pattern matcher 16 | ; It is efficient (generates code at macro-expansion time) and simple: 17 | ; it should work on any R5RS (and R6RS) Scheme system. 18 | 19 | ; (pmatch exp ...[]) 20 | ; ::= ( exp ...) 21 | ; ::= (else exp ...) 22 | ; ::= boolean exp | () 23 | ; :: = 24 | ; ,var -- matches always and binds the var 25 | ; pattern must be linear! No check is done 26 | ; _ -- matches always 27 | ; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012) 28 | ; exp -- comparison with exp (using equal?) 29 | ; ( ...) -- matches the list of patterns 30 | ; ( . ) -- ditto 31 | ; () -- matches the empty list 32 | 33 | (define-syntax pmatch 34 | (syntax-rules (else guard) 35 | ((_ v (e ...) ...) 36 | (pmatch-aux #f v (e ...) ...)) 37 | ((_ v name (e ...) ...) 38 | (pmatch-aux name v (e ...) ...)))) 39 | 40 | (define-syntax pmatch-aux 41 | (syntax-rules (else guard) 42 | ((_ name (rator rand ...) cs ...) 43 | (let ((v (rator rand ...))) 44 | (pmatch-aux name v cs ...))) 45 | ((_ name v) 46 | (begin 47 | (if 'name 48 | (printf "pmatch ~s failed\n~s\n" 'name v) 49 | (printf "pmatch failed\n ~s\n" v)) 50 | (error 'pmatch "match failed"))) 51 | ((_ name v (else e0 e ...)) (begin e0 e ...)) 52 | ((_ name v (pat (guard g ...) e0 e ...) cs ...) 53 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 54 | (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) 55 | ((_ name v (pat e0 e ...) cs ...) 56 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 57 | (ppat v pat (begin e0 e ...) (fk)))))) 58 | 59 | (define-syntax ppat 60 | (syntax-rules (? comma unquote) 61 | ((_ v ? kt kf) kt) 62 | ((_ v () kt kf) (if (null? v) kt kf)) 63 | ; ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) 64 | ((_ v (unquote var) kt kf) (let ((var v)) kt)) 65 | ((_ v (x . y) kt kf) 66 | (if (pair? v) 67 | (let ((vx (car v)) (vy (cdr v))) 68 | (ppat vx x (ppat vy y kt kf) kf)) 69 | kf)) 70 | ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) 71 | -------------------------------------------------------------------------------- /scheme-helpers/test-macro.scm: -------------------------------------------------------------------------------- 1 | ;; Adapted from Oleg Kislyov's test macro 2 | (define-syntax test 3 | (syntax-rules () 4 | ((_ title tested-expression expected-result) 5 | (begin 6 | (printf "Testing ~s\n" title) 7 | (let* ((expected expected-result) 8 | (produced tested-expression)) 9 | (or (equal? expected produced) 10 | (printf "Failed: ~a\nExpected: ~a\nComputed: ~a\n" 11 | 'tested-expression expected produced))))))) 12 | -------------------------------------------------------------------------------- /scheme-version/nbe.scm: -------------------------------------------------------------------------------- 1 | (load "../scheme-helpers/pmatch.scm") 2 | (load "../scheme-helpers/test-macro.scm") 3 | 4 | ;; just to be safe 5 | (define eval 'eval-undefined) 6 | (define apply 'apply-undefined) 7 | 8 | (define lookup 9 | (lambda (x env) 10 | (pmatch env 11 | [() (error 'lookup (format "Unbound variable ~s" x))] 12 | [((,y . ,v) . ,env^) 13 | (cond 14 | ((equal? x y) v) 15 | (else (lookup x env^)))]))) 16 | 17 | (define eval-expr 18 | (lambda (env expr) 19 | (pmatch expr 20 | [(Var ,x) (lookup x env)] 21 | [(App ,f ,x) 22 | (let ((vf (eval-expr env f))) 23 | (let ((vx (eval-expr env x))) 24 | (apply-expr vf vx)))] 25 | [(Lam ,x ,b) `(Closure ,env ,x ,b)]))) 26 | 27 | (define apply-expr 28 | (lambda (f v) 29 | (pmatch f 30 | [(Closure ,env ,x ,b) 31 | (eval-expr `((,x . ,v) . ,env) b)] 32 | [(N ,n) `(N (NApp ,n ,v))]))) 33 | 34 | (define fresh 35 | (lambda (xs x) 36 | (cond 37 | ((member x xs) 38 | (fresh xs (string->symbol (string-append (symbol->string x) "^")))) 39 | (else x)))) 40 | 41 | (define uneval-value 42 | (lambda (xs v) 43 | (pmatch v 44 | [(Closure ,env ,x ,b) 45 | (let ((x^ (fresh xs x))) 46 | (let ((bv (eval-expr `((,x . (N (NVar ,x^))) . ,env) b))) 47 | (let ((b^ (uneval-value `(,x^ . ,xs) bv))) 48 | `(Lam ,x^ ,b^))))] 49 | [(N ,n) (uneval-neutral xs n)]))) 50 | 51 | (define uneval-neutral 52 | (lambda (xs n) 53 | (pmatch n 54 | [(NVar ,x^) `(Var ,x^)] 55 | [(NApp ,n ,v) 56 | (let ((ne (uneval-neutral xs n))) 57 | (let ((ve (uneval-value xs v))) 58 | `(App ,ne ,ve)))]))) 59 | 60 | (define nf 61 | (lambda (env t) 62 | (let ((v (eval-expr env t))) 63 | (uneval-value '() v)))) 64 | 65 | (define main 66 | (lambda () 67 | (let ((id_ (eval-expr '() '(Lam x (Var x))))) 68 | (let ((const_ (eval-expr '() '(Lam x (Lam y (Var x)))))) 69 | (let ((result (eval-expr `((id . ,id_) (const . ,const_)) '(App (Var const) (Var id))))) 70 | result))))) 71 | 72 | (test "main" 73 | (main) 74 | '(Closure ((x Closure () x (Var x))) y (Var x))) 75 | 76 | ;; nf [] (Lam "x" (App (Lam "y" (App (Var "x") (Var "y"))) (Lam "x" (Var "x")))) 77 | ;; => 78 | ;; Lam "x" (App (Var "x") (Lam "x'" (Var "x'"))) 79 | (test "nf-0" 80 | (nf '() '(Lam x (App (Lam y (App (Var x) (Var y))) (Lam x (Var x))))) 81 | '(Lam x (App (Var x) (Lam x^ (Var x^))))) 82 | 83 | -------------------------------------------------------------------------------- /wills-notes.md: -------------------------------------------------------------------------------- 1 | # Will's Notes 2 | 3 | ``` 4 | (((lambda (f) 5 | ((lambda (x) (f (lambda (v) ((x x) v)))) 6 | (lambda (x) (f (lambda (v) ((x x) v)))))) 7 | (lambda (list?) 8 | (lambda (l) 9 | (if (null? l) 10 | #t 11 | (if (pair? l) 12 | (list? (cdr l)) 13 | #f))))) 14 | '(1 2 3)) 15 | => #t 16 | ``` 17 | 18 | ``` 19 | > (define Z 20 | (lambda (f) 21 | ((lambda (x) (f (lambda (v) ((x x) v)))) 22 | (lambda (x) (f (lambda (v) ((x x) v))))))) 23 | > (define F 24 | (lambda (list?) 25 | (lambda (l) 26 | (if (null? l) 27 | #t 28 | (if (pair? l) 29 | (list? (cdr l)) 30 | #f))))) 31 | > (Z F) 32 | # 33 | > (F (Z F)) 34 | # 35 | > ((Z F) '(1 2 3)) 36 | #t 37 | > ((F (Z F)) '(1 2 3)) 38 | #t 39 | > ((F (Z F)) '(1 2 3 4 5 6 7)) 40 | #t 41 | ``` 42 | 43 | If I uneval the closure resulting from `(Z F)` and from `(F (Z F))`, do I get the same `lambda` expression? 44 | 45 | That is, is `(uneval (eval '(Z F)))` equal to `(uneval (eval '(F (Z F))))` 46 | 47 | If so, I might be able to synthesize `Z` using the relational `eval` and `uneval`. 48 | 49 | 50 | 51 | The new hotness is the de Bruijn + nbe version! 52 | 53 | Things to try: 54 | 55 | 1) table `evalo` and/or `unevalo`. Try tabling on normal forms, as well as on expr + env. 56 | 57 | 2) big-step relational abstract interpretation 58 | 59 | 3) try implementing small-step reducer using de Bruijn + nbe, if that makes sense 60 | 61 | 4) try simultaneously doing big-step interp and small-step reduction, with the idea that the small-step reducer can detect loops, find fixpoints, etc. 62 | 63 | 64 | 65 | 66 | 67 | * Is it possible to avoid having to write/use `uneval` in miniKanren, by instead running `evalo` backwards? Would this sidestep the fresh names issues? [I don't think so. `evalo` and `unevalo` do different things.] 68 | 69 | * Seems like we still need to reason about alpha-equivalence of lambda terms, even with `uneval`. Try implementing `nbe.scm` in both alpha-Kanren, and in lambda-Kanren. [done!] 70 | 71 | * Is there a way to side-step the need for nominal unification or higher-order unification, and still get the proper equality behavior? [yes! de Bruijn + nbe! Thanks, Edward!] 72 | 73 | * Is my definition of `fresho` correct in the miniKanren version of `nbe.scm`? Even if `fresho` is correct, that isn't sufficient to deal with alpha-equivalence. Could try De Bruijn notation, as Edward suggested. 74 | 75 | * See my comment at the top of `alphaKanren/nbe-tests.scm` about the annoying restrictions on the use of unification variables. Is there a way around these restrictions? What is the impact of these restrictions? 76 | --------------------------------------------------------------------------------