├── .gitignore ├── README.md ├── cKanren ├── absento.rkt ├── attributes.rkt ├── ck.rkt ├── copy.rkt ├── eigen.rkt ├── info.rkt ├── lang │ └── reader.rkt ├── main.rkt ├── matche.rkt ├── miniKanren.rkt ├── neq.rkt ├── src │ ├── base.rkt │ ├── constraint-store.rkt │ ├── constraints.rkt │ ├── debugging.rkt │ ├── errors.rkt │ ├── events.rkt │ ├── framework.rkt │ ├── helpers.rkt │ ├── infs.rkt │ ├── lex.rkt │ ├── macros.rkt │ ├── mk-structs.rkt │ ├── operators.rkt │ ├── package.rkt │ ├── queue.rkt │ ├── running.rkt │ ├── substitution.rkt │ ├── syntax-classes.rkt │ ├── triggers.rkt │ └── variables.rkt ├── testall.rkt ├── tester.rkt ├── tests │ ├── absento.rkt │ ├── ak.rkt │ ├── comp.rkt │ ├── fd.rkt │ ├── framework.rkt │ ├── infer.rkt │ ├── interp.rkt │ ├── lazy-appendo.rkt │ ├── mk-struct.rkt │ ├── mk.rkt │ ├── neq.rkt │ ├── no-closure.rkt │ ├── nominal │ │ ├── alphaleantap.rkt │ │ └── nnf.rkt │ ├── numbero.rkt │ ├── quines.rkt │ ├── sets.rkt │ ├── symbolo-numbero.rkt │ ├── symbolo.rkt │ └── tree-unify.rkt ├── tree-unify.rkt └── unstable │ ├── ak.rkt │ ├── doc │ └── manual.scrbl │ ├── fd.rkt │ ├── finite-domain.rkt │ ├── interval-domain.rkt │ └── sets.rkt └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/* 2 | cKanren/compiled/* 3 | cKanren/tests/compiled/* 4 | cKanren/tests/nominal/compiled* 5 | cKanren/doc/compiled/* 6 | cKanren/doc/*.js 7 | cKanren/doc/*.css 8 | cKanren/doc/manual/* 9 | cKanren/src/compiled/* 10 | cKanren/lang/compiled* 11 | cKanren/unstable/compiled* 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Copyright (C) 2013-4 Claire Alvis 2 | 3 | Copyright (C) 2011-2013 Daniel P. Friedman, Oleg Kiselyov, 4 | Claire E. Alvis, Jeremiah J. Willcock, Kyle M. Carter, William E. Byrd 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in 14 | all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 22 | THE SOFTWARE. 23 | 24 | ---------------------------------------------------------------------------- 25 | 26 | cKanren 27 | ======= 28 | 29 | This library implements miniKanren (http://minikanren.org) with an 30 | extensible framework for defining constraints. 31 | 32 | How to install 33 | -------------- 34 | 35 | cKanren can be installed as a collection within Racket (http://racket-lang.org) 36 | as follows: 37 | 38 | * `git clone git://github.com/calvis/cKanren.git` 39 | * `cd cKanren/cKanren` 40 | * `raco link .` 41 | * `raco setup cKanren` 42 | 43 | After setup finishes, you will be able to use miniKanren, `#lang 44 | cKanren`, and all constraint libraries that ship with cKanren. 45 | 46 | For users 47 | --------- 48 | 49 | If you are interested in writing miniKanren programs, you can 50 | `(require cKanren/miniKanren)` for standard miniKanren definitions. 51 | You can also require constraint libraries like `neq` as `(require 52 | cKanren/neq)`. 53 | 54 | Stable constraint libraries 55 | --------------------------- 56 | 57 | The following libraries have been tested extensively. 58 | 59 | * Tree unification `cKanren/tree-unify` 60 | * Disequality constraints `cKanren/neq` 61 | * Absento, symbolo, and numbero `cKanren/absento` 62 | 63 | All other constraints libraries are experimental. 64 | 65 | -------------------------------------------------------------------------------- /cKanren/absento.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Based on code provided by Jason Hemann and Dan Friedman 4 | ;; See: https://github.com/jasonhemann/miniKanren 5 | 6 | (require "ck.rkt" "tree-unify.rkt" (only-in "neq.rkt" =/= !=/prefix) 7 | "src/helpers.rkt" "attributes.rkt" 8 | "src/framework.rkt" "src/events.rkt" "src/constraints.rkt") 9 | (provide absento mem-check term=) 10 | 11 | ;; absento 12 | 13 | (define (symbol-constrained? v attrs) 14 | (ormap (curry eq? symbol) attrs)) 15 | (define (number-constrained? v attrs) 16 | (ormap (curry eq? number) attrs)) 17 | 18 | (define-constraint (absento [u walk*] v) 19 | #:reified 20 | #:package (a [s c e]) 21 | #:reaction 22 | [(unify-change (list (cons u v))) 23 | ;; (printf "absento: u: ~a v: ~a\n" u v) 24 | (cond 25 | [(or (symbol? v) 26 | (number? v) 27 | (cond 28 | [(get-attributes v c e) 29 | => (lambda (attrs) 30 | (or (symbol-constrained? v attrs) 31 | (number-constrained? v attrs)))] 32 | [else #f])) 33 | (cond 34 | [(pair? u) succeed] 35 | [else (=/= u v)])] 36 | [(pair? v) (absento-split u v)] 37 | [(not (var? v)) (=/= u v)] 38 | [(eq? u v) fail] 39 | [(mem-check v u s c e) succeed] 40 | [else (add-constraint (absento u v))])]) 41 | 42 | (define-constraint-interaction 43 | [(absento u v) (absento u^ v^)] 44 | #:package [a [s c e]] 45 | [(subsumes? (cons u v) (cons u^ v^) s c e) 46 | [(absento u v)]]) 47 | 48 | (define (subsumes? p p^ s c e) 49 | (and (mem-check (car p) (car p^) s c e) 50 | (mem-check (cdr p) (cdr p^) s c e))) 51 | 52 | (define mem-check 53 | (lambda (u t s c e) 54 | (or (term= u t s c e) 55 | (and (pair? t) 56 | (or (mem-check u (car t) s c e) 57 | (mem-check u (cdr t) s c e)))))) 58 | 59 | (define term= 60 | (lambda (u t s c e) 61 | (cond 62 | [(unify `((,u . ,t)) s c e) => 63 | (lambda (s/c) (eq? (car s/c) s))] 64 | [else #f]))) 65 | 66 | (define (absento-split u v) 67 | (conj 68 | (absento u (car v)) 69 | (absento u (cdr v)) 70 | (=/= u v))) 71 | 72 | (define-constraint-interaction 73 | [(!=/prefix prefix) (absento u v)] 74 | #:package (a [s c e]) 75 | [(ormap 76 | (lambda (u/v) 77 | (or (term= (cons u v) u/v s c e) 78 | (term= (cons v u) u/v s c e))) 79 | prefix) 80 | [(let ([p^ (filter-not 81 | (lambda (u/v) ;; can I find u/v subsumed by abesntos 82 | (or (term= (cons u v) u/v s c e) 83 | (term= (cons v u) u/v s c e))) ;; TODO dumb 84 | prefix)]) 85 | (conj 86 | (cond 87 | [(null? p^) succeed] 88 | [else (!=/prefix p^)]) 89 | (absento u v)))]]) 90 | 91 | -------------------------------------------------------------------------------- /cKanren/attributes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Based on code provided by Jason Hemann and Dan Friedman 4 | ;; See: https://github.com/jasonhemann/miniKanren 5 | 6 | (require "ck.rkt" "src/helpers.rkt" "src/events.rkt" "src/framework.rkt" 7 | "src/constraints.rkt" "src/constraint-store.rkt" "src/macros.rkt") 8 | (require (for-syntax racket/syntax syntax/parse "src/framework.rkt")) 9 | 10 | (provide (all-defined-out)) 11 | 12 | (define-constraint-type attribute-constraint walk*) 13 | 14 | (define attributes-uw? 15 | (make-parameter '())) 16 | (define extend-attributes-uw? 17 | (extend-parameter attributes-uw?)) 18 | 19 | ;; returns #t if attributes are ok 20 | (define (check-attributes u v s c e) 21 | (let ([uattr (get-attributes u c e)] 22 | [vattr (get-attributes v c e)]) 23 | ;; four possibilities: 24 | ;; 1. u and v both have attributes 25 | ;; 2, 3. either u or v does not have attributes 26 | ;; 4. neither u nor v has attributes 27 | 28 | ;; (printf "check-attributes: ~a ~a ~a ~a\n" u uattr v vattr) 29 | (and (or (not uattr) (no-conflicts? uattr v vattr)) 30 | (or (not vattr) (no-conflicts? vattr u uattr))))) 31 | 32 | (define (get-attributes x c e) 33 | (define ocs (filter-something/rator attribute-constraint? c)) 34 | (define events (filter (match-lambda 35 | [(add-attribute-constraint-event rator (list y)) 36 | (eq? x y)] 37 | [else #f]) 38 | e)) 39 | (append (filter-map (match-lambda [(oc rator (list y)) (and (eq? x y) rator)]) ocs) 40 | (map (match-lambda [(constraint-event rator rands) rator]) events))) 41 | 42 | ;; [List-of Rator] Value [List-of Rator] -> Boolean 43 | (define (no-conflicts? vattr u uattr) 44 | (andmap (lambda (rator) ((attr-oc-uw? rator) u uattr)) vattr)) 45 | 46 | ;; AtributeConstraintRator -> Boolean 47 | (define (attr-oc-uw? rator) 48 | (cdr (assq rator (attributes-uw?)))) 49 | 50 | (define-syntax (define-attribute stx) 51 | (syntax-parse stx 52 | [(define-attribute name 53 | (~or (~once (~seq #:satisfied-when pred?:id)) 54 | (~optional (~seq #:incompatible-attributes (inc-attrs ...)) 55 | #:defaults ([(inc-attrs 1) '()])) 56 | (~optional (~seq #:causes (cause-attrs ...)) 57 | #:defaults ([(cause-attrs 1) '()]))) 58 | ...) 59 | (define/with-syntax (name-fail-incompatible ...) 60 | (map (lambda (incompat) 61 | (format-id #'name "~a-~a-fail" 62 | (syntax-e #'name) 63 | (syntax-e incompat))) 64 | (syntax-e #'(inc-attrs ...)))) 65 | (define/with-syntax name-unique 66 | (format-id #'name "~a-unique" (syntax-e #'name))) 67 | #'(begin 68 | (define-attribute-constraint (name x) 69 | #:package (a [s c e]) 70 | #:reified 71 | (define body 72 | (cond 73 | [(var? x) 74 | (add-constraint (name x))] 75 | [(pred? x) succeed] 76 | [else fail])) 77 | (cond 78 | [(empty-event? e) 79 | (conj (cause-attrs x) ... body)] 80 | [else body])) 81 | (define-constraint-interaction 82 | name-fail-incompatible 83 | [(name x) (inc-attrs x)] => [fail]) 84 | ... 85 | (define-constraint-interaction 86 | name-unique 87 | [(name x) (name x)] => [(name x)]) 88 | ;; (printf "~a: ~a\n" 'name x) 89 | 90 | ;; Value [List-of Attribute] -> Boolean 91 | (define (symbol-unifies-with? x attrs) 92 | (define incompatible (list inc-attrs ...)) 93 | (define incompatible? (curryr memq incompatible)) 94 | (cond 95 | [(var? x) 96 | (or (not attrs) 97 | (andmap (compose not incompatible?) attrs))] 98 | [else (pred? x)])) 99 | (extend-attributes-uw? name symbol-unifies-with?))])) 100 | 101 | (define-attribute symbol 102 | #:satisfied-when symbol? 103 | #:incompatible-attributes (number string)) 104 | 105 | (define-attribute number 106 | #:satisfied-when number? 107 | #:incompatible-attributes (symbol string)) 108 | 109 | (define-attribute string 110 | #:satisfied-when string? 111 | #:incompatible-attributes (number symbol)) 112 | 113 | -------------------------------------------------------------------------------- /cKanren/ck.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "src/base.rkt") 4 | (provide (all-from-out "src/base.rkt")) 5 | -------------------------------------------------------------------------------- /cKanren/eigen.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "src/base.rkt" "tree-unify.rkt" 4 | "attributes.rkt" "neq.rkt" "src/mk-structs.rkt" 5 | "src/framework.rkt" "src/triggers.rkt") 6 | (require "tester.rkt") 7 | 8 | ;; a "fresh" for EigenVars 9 | (provide eigen) 10 | 11 | ;; an EigenVar is just a special kind of Var 12 | (define-var-type eigenvar "ev" 13 | #:methods gen:unifiable 14 | [(define (compatible? ev v s c e) 15 | (and (var? v) (in-scope? ev v c e))) 16 | (define (gen-unify ev v p s c e) 17 | (unify p (ext-s v ev s) c e))]) 18 | 19 | ;; a macro for introducing new EigenVars 20 | (define-syntax-rule (eigen (x ...) g ...) 21 | (fresh-aux eigenvar (x ...) 22 | (track-eigen x '()) ... 23 | (conj g ...) 24 | (leave-eigen x) ...)) 25 | 26 | ;; EigenVar [List-of Var] -> ConstraintTransformer 27 | ;; fails when x is involved in unification of variables not in scope 28 | (define-constraint (track-eigen x [in-scope update-scope]) 29 | ;; track any change in scope by responding to #f 30 | #:reaction 31 | [(enter-scope #f) 32 | => (lambda (y) (add-constraint (track-eigen x (cons y in-scope))))] 33 | #:reaction 34 | [(leave-scope #f) 35 | => (lambda (y) (add-constraint (track-eigen x (remq y in-scope))))] 36 | 37 | ;; track associations to x 38 | #:reaction 39 | [(any-association-event x) 40 | => (lambda (p) 41 | (conj (add-constraint (track-eigen x in-scope)) 42 | (check-associations x p in-scope)))]) 43 | 44 | ;; [List-of Value] -> [List-of Var] 45 | ;; updates the EigenVar scope list 46 | (define (update-scope x . rest) 47 | (filter*/var? (apply walk x rest))) 48 | 49 | ;; EigenVar SubstitutionPrefix [List-of Var] -> ConstraintTransformer 50 | ;; the prefix is a list of either (x . something) or (somevar . x) 51 | (define (check-associations x prefix in-scope) 52 | (transformer 53 | #:package (a [s c e]) 54 | (if (andmap (prefix-okay? x s in-scope) prefix) succeed fail))) 55 | 56 | (define (prefix-okay? x s in-scope) 57 | (match-lambda 58 | [(cons u v) 59 | (cond 60 | ;; a binding (x . something) 61 | [(and (eq? u x) (not (eq? v x))) #f] 62 | ;; a binding (somevar . x) 63 | [(memq u in-scope) 64 | (define p^ 65 | (filter (lambda (p) (memq u (filter*/var? (cdr p)))) s)) 66 | (andmap (curryr memq in-scope) p^)] 67 | [else #f])])) 68 | 69 | ;; TODO: this should just be #:persistent 70 | (define-constraint (leave-eigen x) 71 | (add-constraint (leave-eigen x))) 72 | 73 | ;; when you leave scope, get rid of both constraints 74 | (define-constraint-interaction 75 | [(track-eigen x ls) (leave-eigen x)] => [succeed]) 76 | 77 | ;; if you try to unify a symbol/number with an EigenVar, fails 78 | (define-constraint-interaction 79 | [(track-eigen x ls) (symbol x)] => [fail]) 80 | (define-constraint-interaction 81 | [(track-eigen x ls) (number x)] => [fail]) 82 | 83 | ;; EigenVar Var ConstraintStore Event -> Boolean 84 | ;; returns #t iff it is okay to unify ev and v based on ev's scope 85 | ;; TODO: should check event 86 | (define (in-scope? ev v c e) 87 | (define eigen-rands 88 | (filter/rator track-eigen c)) 89 | (define the-rands 90 | (findf (lambda (rands) (eq? (car rands) ev)) 91 | eigen-rands)) 92 | (memq v (cadr the-rands))) 93 | 94 | ;; Test the eigen variable implementation in miniKanren 95 | 96 | (module+ test 97 | ;; there exists q st. forall x, x = q 98 | (test (run* (q) (eigen (x) (== x q))) '()) 99 | 100 | ;; forall x, there exists y st. x = y 101 | (test (run* (q) (eigen (x) (fresh (y) (== x y)))) '(_.0)) 102 | 103 | (test (run* (q) (eigen (x) (fresh (y) (== x y) (== q y)))) '()) 104 | (test (run* (q) (eigen (x) (fresh (y) (== x y) (== y q)))) '()) 105 | 106 | (test (run* (q) (eigen (x) (symbol x))) '()) 107 | 108 | (test (run* (q) (eigen (x) (number x))) '()) 109 | 110 | (test (run* (q) (eigen (e) (fresh (x) (number x) (== x e)))) '()) 111 | 112 | (test (run* (q) (eigen (e) (fresh (x) (== x e) (number x)))) '()) 113 | 114 | (test (run* (q) (eigen (e) (fresh (x) (== x e)))) '(_.0)) 115 | 116 | (test (run* (q) (eigen (e) (symbol e))) '()) 117 | 118 | (test (run* (q) (eigen (e1) (== e1 5))) '()) 119 | 120 | (test (run* (q) (eigen (e1 e2) (== e1 e2))) '()) 121 | 122 | (test 123 | (run* (q) 124 | (eigen (e1) 125 | (fresh (x y) 126 | (== e1 `(,x . ,y))))) 127 | '()) 128 | 129 | (test (run* (q) (eigen (x) (== q x))) '()) 130 | 131 | (test (run* (q) (eigen (x) (fresh (r) (== r x)))) '(_.0)) 132 | 133 | (test (run* (q) (eigen (a) (fresh (x) (== `(1 2 3 ,x 4) a)))) 134 | '()) 135 | 136 | (test (run* (q) (fresh (x) (eigen (a) (== `(1 2 3 ,x 4) a)))) 137 | '()) 138 | 139 | ;; HARD 140 | (test 141 | (run* (q) 142 | (eigen (x) 143 | (fresh (y) 144 | (== `(,x) y) 145 | (== y q)))) 146 | '()) 147 | 148 | (test (run* (q) (eigen (e) (fresh (y) (== `(,y) q) (== y e)))) '()) 149 | 150 | (test (run* (q) (eigen (e) (fresh (y) (== y e) (== `(,y) q)))) '()) 151 | 152 | ;; there exists x st. forall a, `(1 2 3 ,a 4) is x 153 | (test (run* (q) (fresh (x) (eigen (a) (== `(1 2 3 ,a 4) x)))) 154 | '()) 155 | 156 | ;; forall e, there exists a list `(1 2 3 ,e 4) 157 | (test (run* (q) (eigen (e) (fresh (x) (== `(1 2 3 ,e 4) x)))) 158 | '(_.0)) 159 | 160 | 161 | (test (run* (q) (eigen (e1) (eigen (e2) (fresh (x y) (== x e1) (== y e2) (== x y))))) 162 | '()) 163 | 164 | (test 165 | (run* (q) (eigen (e1) (eigen (e2) (fresh (x y) (== x y) (== x e1) (== y e2))))) 166 | '()) 167 | 168 | (test 169 | (run* (q) (eigen (e1) (eigen (e2) (fresh (x y) (== x e1) (== x y) (== y e2))))) 170 | '()) 171 | 172 | (test 173 | (run* (q) 174 | (eigen (e e2) 175 | (fresh (x) 176 | (== `(,x . ,x) `(,e . ,e2))))) 177 | '()) 178 | 179 | (test 180 | (run* (q) 181 | (eigen (e) 182 | (fresh (x) 183 | (== `(,e . ,q) `(,x . ,x))))) 184 | '()) 185 | 186 | ;; Tests below this point fail. 187 | 188 | #; 189 | (test "eigen test 9" 190 | (run 1 (q) (eigen (x) (absento x q))) 191 | '(_.0)) 192 | 193 | ;; there exists q st. forall x, x != q 194 | (test (run* (q) (eigen (x) (=/= x q))) '()) 195 | 196 | (test (run* (q) (eigen (e) (=/= 5 e))) '()) 197 | 198 | (test (run* (q) (eigen (e1 e2) (=/= e1 e2))) '()) 199 | 200 | (test "eigen-=/=-1" 201 | ;; exists Q . forall E . Q =/= E 202 | ;; false (pick E = Q) 203 | (run 1 (q) (eigen (e) (=/= q e))) 204 | '()) 205 | 206 | (test "eigen-=/=-2" 207 | ;; forall E . exists X . E =/= X 208 | ;; true (pick X =/= E) 209 | (run 1 (q) (eigen (e) (fresh (x) (=/= e x)))) 210 | '(_.0)) 211 | 212 | (test "eigen-=/=-3a" 213 | ;; forall E1 E2 . E1 =/= E2 214 | ;; false (pick E1 = E2) 215 | (run 1 (q) (eigen (e1 e2) (=/= e1 e2))) 216 | '()) 217 | 218 | (test "eigen-=/=-3b" 219 | ;; forall E1 . forall E2 . E1 =/= E2 220 | ;; false (pick E2 = E1) 221 | (run 1 (q) (eigen (e1) (eigen (e2) (=/= e1 e2)))) 222 | '()) 223 | 224 | (test "eigen-=/=-4" 225 | ;; forall E1 . E1 =/= E1 226 | ;; false (pick any legal term for E1) 227 | (run 1 (q) (eigen (e1) (=/= e1 e1))) 228 | '()) 229 | 230 | (test "eigen-=/=-5" 231 | ;; forall E1 . E1 =/= 5 232 | ;; false (pick E1 = 5) 233 | (run 1 (q) (eigen (e1) (=/= e1 5))) 234 | '()) 235 | 236 | (test "eigen-=/=-list-1" 237 | ;; forall A . exists X . `(1 2 3 ,A 4) =/= X 238 | ;; true (pick X to be any non-list value, for example) 239 | (run 1 (q) (eigen (a) (fresh (x) (=/= `(1 2 3 ,a 4) x)))) 240 | '(_.0)) 241 | 242 | (test "eigen-=/=-list-2" 243 | ;; forall A . exists X . `(1 2 3 ,X 4) =/= A 244 | ;; true (if A is `(1 2 3 ,Y 4), choose X =/= Y) 245 | (run 1 (q) (eigen (a) (fresh (x) (=/= `(1 2 3 ,x 4) a)))) 246 | '(_.0)) 247 | 248 | (test "eigen-=/=-list-3" 249 | ;; exists X . forall A . `(1 2 3 ,A 4) =/= X 250 | ;; true (pick X to be any non-list value, for example) 251 | (run 1 (q) (fresh (x) (eigen (a) (=/= `(1 2 3 ,a 4) x)))) 252 | '(_.0)) 253 | 254 | (test "eigen-=/=-list-4" 255 | ;; exists X . forall A . `(1 2 3 ,X 4) =/= A 256 | ;; false (if X is any legal term, choose A = `(1 2 3 ,X 4)) 257 | (run 1 (q) (fresh (x) (eigen (a) (=/= `(1 2 3 ,x 4) a)))) 258 | '()) 259 | ) 260 | -------------------------------------------------------------------------------- /cKanren/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define deps (list)) 4 | 5 | ;; (define scribblings '(("doc/manual.scrbl" ()))) 6 | 7 | -------------------------------------------------------------------------------- /cKanren/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | 3 | cKanren 4 | 5 | #:read read 6 | #:read-syntax read-syntax 7 | 8 | 9 | -------------------------------------------------------------------------------- /cKanren/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "ck.rkt") 4 | (require (for-syntax "ck.rkt" racket/syntax racket/base)) 5 | 6 | (provide (all-from-out "ck.rkt")) 7 | (provide (except-out (all-from-out racket/base) #%app string)) 8 | ;; (provide (for-syntax (all-from-out racket/base) search-strategy)) 9 | (provide (rename-out [#%app-safe #%app])) 10 | 11 | -------------------------------------------------------------------------------- /cKanren/matche.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require cKanren/ck cKanren/tree-unify cKanren/tester) 4 | (require (for-syntax racket racket/syntax syntax/parse)) 5 | 6 | (provide defmatche lambdae matche) 7 | 8 | (define-syntax (defmatche stx) 9 | (syntax-parse stx 10 | [(defmatche (name:id args:id ...) clause ...) 11 | (syntax/loc stx 12 | (define (name args ...) 13 | (matche (args ...) clause ...)))])) 14 | 15 | (define-syntax lambdae 16 | (syntax-rules () 17 | ((_ (x ...) c c* ...) 18 | (lambda (x ...) (matche (x ...) c c* ...))))) 19 | 20 | (define-syntax (matche stx) 21 | (syntax-parse stx 22 | [(matche (v:id ...) ([pat ...] g ...) ...) 23 | (define v-length (length (syntax-e #'(v ...)))) 24 | (for ([a-pat (syntax->list (syntax/loc stx ([pat ...] ...)))]) 25 | (unless (= (length (syntax->list a-pat)) v-length) 26 | (raise-syntax-error 27 | 'matche 28 | (format "expected pattern of length ~a" v-length) 29 | a-pat))) 30 | (define/with-syntax (([pat^ ...] (c ...) (x ...)) ...) 31 | (map (curry parse-pattern #'(v ...)) 32 | (syntax-e #'([pat ...] ...)))) 33 | (define/with-syntax ((x^ ...) ...) 34 | (map (compose (curryr remove-duplicates free-identifier=?) syntax-e) 35 | (syntax-e #'((x ...) ...)))) 36 | (define/with-syntax body 37 | #'(conde 38 | [(fresh (x^ ...) c ... (== `[pat^ ...] ls) g ...)] 39 | ...)) 40 | (syntax/loc stx (let ([ls (list v ...)]) body))] 41 | [(matche v:id (pat g ...) ...) 42 | (syntax/loc stx (matche (v) ([pat] g ...) ...))])) 43 | 44 | (define-for-syntax (parse-pattern args pat) 45 | (syntax-parse #`(#,args #,pat) 46 | [(() ()) #'(() () ())] 47 | [((a args ...) [p pat ...]) 48 | (define/with-syntax (p^ (c ...) (x ...)) 49 | (parse-patterns-for-arg #'a #'p)) 50 | (define/with-syntax ([pat^ ...] (c^ ...) (x^ ...)) 51 | (parse-pattern #'(args ...) #'[pat ...])) 52 | #'([p^ pat^ ...] (c ... c^ ...) (x ... x^ ...))] 53 | [x (error 'parse-pattern "bad syntax ~s ~s" args pat)])) 54 | 55 | (define-for-syntax (parse-patterns-for-arg v pat) 56 | (define (loop pat) 57 | (syntax-parse pat 58 | [((~literal unquote) (~literal _)) 59 | (define/with-syntax _new (generate-temporary #'?_)) 60 | #'((unquote _new) () (_new))] 61 | [((~literal unquote) x:id) 62 | (when (free-identifier=? #'x v) 63 | (error 'matche "argument ~s appears in pattern at an invalid depth" 64 | (syntax-e #'x))) 65 | #'((unquote x) () (x))] 66 | [((~literal unquote) ((~literal ?) c:expr)) 67 | (define/with-syntax _new (generate-temporary #'?_)) 68 | #'((unquote _new) ((c _new)) (_new))] 69 | [((~literal unquote) ((~literal ?) c:expr x:id)) 70 | (when (free-identifier=? #'x v) 71 | (error 'matche "argument ~s appears in pattern at an invalid depth" 72 | (syntax-e #'x))) 73 | #'((unquote x) ((c x)) (x))] 74 | [(a . d) 75 | (define/with-syntax 76 | ((pat1 (c1 ...) (x1 ...)) 77 | (pat2 (c2 ...) (x2 ...))) 78 | (map loop (syntax-e #'(a d)))) 79 | #'((pat1 . pat2) (c1 ... c2 ...) (x1 ... x2 ...))] 80 | [x #'(x () ())])) 81 | (syntax-parse pat 82 | [((~literal unquote) u:id) 83 | (cond 84 | [(and (identifier? #'u) 85 | (free-identifier=? v #'u)) 86 | #'((unquote u) () ())] 87 | [else (loop pat)])] 88 | [((~literal unquote) ((~literal ?) c:id u:id)) 89 | (cond 90 | [(and (identifier? #'u) 91 | (free-identifier=? v #'u)) 92 | #'((unquote u) ((c x)) ())] 93 | [else (loop pat)])] 94 | [else (loop pat)])) 95 | 96 | (module+ test 97 | 98 | (let () 99 | (defmatche (foo a b) 100 | [[5 5]]) 101 | (test 102 | (run* (q) (foo 5 5)) 103 | '(_.0)) 104 | (test 105 | (run* (q) (foo q 5)) 106 | '(5)) 107 | (test 108 | (run* (x y) (foo x y)) 109 | '((5 5)))) 110 | 111 | (let () 112 | (defmatche (bar a) 113 | [[(,x . ,y)] 114 | (== x y)]) 115 | (test 116 | (run* (q) (bar q)) 117 | '((_.0 . _.0)))) 118 | 119 | (let () 120 | (defmatche (baby-rembero x ls out) 121 | [[,x () ()]]) 122 | (test 123 | (run* (q) (baby-rembero 'x '() '())) 124 | '(_.0)))) 125 | 126 | 127 | 128 | -------------------------------------------------------------------------------- /cKanren/neq.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "ck.rkt" (only-in "tree-unify.rkt" unify unify-change) "src/events.rkt" 4 | "src/framework.rkt") 5 | (provide =/= !=/prefix reify-prefix-dot (rename-out [=/= !=]) subsumes?) 6 | 7 | ;;; little helpers 8 | 9 | (define (recover/vars p) 10 | (cond 11 | [(null? p) '()] 12 | [else 13 | (let ([x (car (car p))] 14 | [v (cdr (car p))] 15 | [r (recover/vars (cdr p))]) 16 | (cond 17 | [(var? v) (ext/vars v (ext/vars x r))] 18 | [else (ext/vars x r)]))])) 19 | 20 | (define (ext/vars x r) 21 | (cond 22 | ((memq x r) r) 23 | (else (cons x r)))) 24 | 25 | ;;; serious functions 26 | 27 | (define reify-prefix-dot 28 | (make-parameter #t)) 29 | 30 | (define (remove-dots p) 31 | (cond 32 | [(reify-prefix-dot) p] 33 | [else (list (car p) (cdr p))])) 34 | 35 | (define (sort-p p) 36 | (sort-by-lex<= 37 | (map (lambda (a) (sort-diseq (car a) (cdr a))) p))) 38 | 39 | (define (sort-diseq u v) 40 | (cond 41 | ((char 53 | (match-lambda 54 | [(cons new-p c) 55 | ;; (printf "\n!=/prefix: ~a ~a ~a\n" new-p c e) 56 | (cond 57 | [(null? new-p) fail] 58 | [else (add-constraint (!=/prefix new-p))])] 59 | [#f succeed])] 60 | #:reification-function 61 | (lambda (v r) (reified-constraint '=/= (sort-p p) r))) 62 | 63 | ;; how to read this: 64 | ;; neq-subsume defines an interaction between !=/prefix constraints 65 | ;; if there are two !=/prefix constraints with prefixes p and p^ 66 | ;; in the constraint store, if the first subsumes the second, keep 67 | ;; only the first constraint. this is reflexive by default. 68 | (define-constraint-interaction neq-subsume 69 | [(!=/prefix p) (!=/prefix p^)] 70 | #:package (a [s c e]) 71 | [(subsumes? p p^ c) [(!=/prefix p)]]) 72 | 73 | (define (subsumes? p p^ c) 74 | (cond 75 | [(unify p p^ empty-c empty-e) => 76 | (lambda (s/c) (eq? (car s/c) p^))] 77 | [else #f])) 78 | 79 | ;;; goals 80 | 81 | (define (=/= u v) 82 | (transformer 83 | #:package (a [s c e]) 84 | (cond 85 | [(unify `((,u . ,v)) s c e) 86 | => (lambda (s/c) 87 | (!=/prefix (prefix-s s (car s/c))))] 88 | [else succeed]))) 89 | 90 | 91 | -------------------------------------------------------------------------------- /cKanren/src/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; This file provides the minimum core of cKanren functionalities 4 | 5 | (require "macros.rkt") 6 | (provide define-constraint-type transformer) 7 | 8 | (provide define-constraint 9 | constraint 10 | add-constraint-event 11 | remove-constraint-event) 12 | 13 | ;; constraints 14 | (require "constraints.rkt") 15 | (provide succeed fail transformer? #%app-safe) 16 | 17 | ;; debugging 18 | (require "debugging.rkt") 19 | 20 | (require "events.rkt") 21 | (provide define-event send-event) 22 | 23 | ;; framework 24 | (require "framework.rkt") 25 | (provide add-association add-constraint constraint update-package run run* 26 | sort-by-lex<= lex<= define-constraint-interaction) 27 | ;; (provide (for-syntax search-strategy)) 28 | 29 | ;; lex 30 | (require "lex.rkt") 31 | (provide sort-by-lex<= lex<=) 32 | 33 | ;; mk-structs 34 | (require "mk-structs.rkt") 35 | (provide gen:mk-struct mk-struct? default-mk-struct? recur constructor 36 | reify-mk-struct override-occurs-check? reify-term any/var? 37 | any-relevant/var? walk* same-default-type?) 38 | 39 | ;; operators 40 | (require "operators.rkt") 41 | (provide conj disj conde fresh fresh-aux) 42 | (provide ifu condu ifa conda project onceo) 43 | (provide debug debug-conde prt prtm prtt) 44 | (provide for/disj for/conj) 45 | 46 | ;; package 47 | (require "package.rkt") 48 | (provide empty-a make-a) 49 | (provide occurs-check walk prefix-s ext-s ext-s*) 50 | (provide empty-c ext-c remq-c filter/rator filter-memq/rator) 51 | 52 | ;; running 53 | (require "running.rkt") 54 | (provide run run* run/lazy define-constraint-interaction 55 | start/ir extend/ir enforce/ir reify/ir reifyc/ir exit/ir exitc/ir) 56 | 57 | ;; variables 58 | (require "variables.rkt") 59 | (provide var var? var-x define-var-type define-cvar-type) 60 | -------------------------------------------------------------------------------- /cKanren/src/constraint-store.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "constraints.rkt") 4 | 5 | ;; == CONSTRAINT STORE ========================================================= 6 | ;; 7 | ;; A ConstraintStore is a [Hasheq Rator [List-of Rands]] 8 | 9 | (provide 10 | ;; Value -> Boolean 11 | ;; returns #t iff the value is a ConstraintStore (superfluously) 12 | constraint-store? 13 | 14 | ;; ConstraintStore 15 | ;; an empty ConstraintStore 16 | empty-c 17 | 18 | ;; Oc ConstraintStore -> ConstraintStore 19 | ;; adds oc to the constraint store 20 | ext-c 21 | 22 | ;; Oc ConstraintStore -> ConstraintStore 23 | ;; removes the oc from the constraint store 24 | remq-c 25 | 26 | ;; ConstraintStore ConstraintStore -> [List-of Ocs] 27 | prefix-c 28 | 29 | ;; Rator ConstraintStore -> [List-of Rands] 30 | ;; returns all the rands that have rator as a key 31 | filter/rator 32 | 33 | ;; [List-of Rator] ConstraintStore -> [List-of Rands] 34 | ;; returns all the rands that have a rator in the given list 35 | filter-memq/rator 36 | 37 | ;; [Rator -> Boolean] ConstraintStore -> [List-of Oc] 38 | ;; it filters something????? 39 | filter-something/rator) 40 | 41 | (define constraint-store? hash?) 42 | 43 | (define empty-c (hasheq)) 44 | 45 | (define (ext-c new-oc c) 46 | (match-define (oc rator rands) new-oc) 47 | (hash-update c rator (curry cons rands) '())) 48 | 49 | (define (remq-c new-oc c) 50 | (match-define (oc rator rands) new-oc) 51 | (hash-update c rator (curry remq rands) '())) 52 | 53 | (define (prefix-c c c^) 54 | (for/fold 55 | ([prefix '()]) 56 | ([(rator rands*^) c^]) 57 | (define rands* (hash-ref c rator '())) 58 | (define (prefix-loop rands*^ prefix) 59 | (cond 60 | [(eq? rands* rands*^) prefix] 61 | [else 62 | (define new-prefix (cons (oc rator (car rands*^)) prefix)) 63 | (prefix-loop (cdr rands*^) new-prefix)])) 64 | (prefix-loop rands*^ prefix))) 65 | 66 | (define (filter/rator rator c) 67 | (hash-ref c rator '())) 68 | 69 | (define (filter-memq/rator symls c) 70 | (apply append (for/list ([key symls]) (hash-ref c key '())))) 71 | 72 | ;; TODO: wow such name so good 73 | (define (filter-something/rator pred? c) 74 | (apply append 75 | (for/list ([(rator rands*) c]) 76 | (cond 77 | [(pred? rator) 78 | (map (curry oc rator) rands*)] 79 | [else '()])))) 80 | 81 | 82 | -------------------------------------------------------------------------------- /cKanren/src/constraints.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "variables.rkt" "helpers.rkt" "infs.rkt" "errors.rkt") 4 | (require (for-syntax syntax/parse racket/syntax racket/match)) 5 | 6 | (provide (all-defined-out)) 7 | 8 | ;; calling a constraint returns a structure that could be applied or 9 | ;; stored in the constraint store 10 | (struct -constraint (fn reaction reifyfn add rem) 11 | #:property prop:procedure 12 | (lambda (this . args) 13 | (oc this args))) 14 | 15 | ;; applying an oc acts like just calling the constraint on the 16 | ;; arguments; also has enough information to store in constraint store 17 | (struct oc (rator rands) 18 | #:transparent 19 | #:methods gen:custom-write 20 | [(define (write-proc this port mode) 21 | ((parse-mode mode) (format "#oc~a" (cons (oc-rator this) (oc-rands this))) port))] 22 | #:property prop:procedure 23 | (lambda (this a) 24 | (match-define (oc rator rands) this) 25 | (bindm a (apply (-constraint-fn rator) rands)))) 26 | 27 | ;; a transformer takes a package and returns a package 28 | (struct -transformer (fn) 29 | #:property prop:procedure (struct-field-index fn) 30 | #:methods gen:custom-write 31 | [(define (write-proc this port mode) 32 | ((parse-mode mode) "#" port))]) 33 | (define transformer? -transformer?) 34 | 35 | ;; splitting up the package 36 | (define-syntax (lambda@ stx) 37 | (syntax-parse stx 38 | [(k (a:id) body:expr ...) 39 | (define/with-syntax src (build-srcloc-stx #'k)) 40 | (syntax/loc stx 41 | (let () 42 | (define a-lambda@ 43 | (case-lambda 44 | [(a) (let () body ...)] 45 | [r (raise 46 | (exn:goal-as-fn 47 | (format "~s: misused lambda@" (format-source src)) 48 | (current-continuation-marks)))])) 49 | (-transformer a-lambda@)))] 50 | [(_ (a [s:id c:id q:id t:id e:id]) body:expr ...) 51 | (syntax/loc stx 52 | (lambda@ (a) 53 | (let ([s (a-s a)] 54 | [c (a-c a)] 55 | [q (a-q a)] 56 | [t (a-t a)] 57 | [e (a-e a)]) 58 | body ...)))])) 59 | 60 | ;; the failure value 61 | (define mzerom (mzerof)) 62 | 63 | ;; applies a goal to an a-inf and returns an a-inf 64 | (define (bindm a-inf g) 65 | (case-inf a-inf 66 | [() (mzerof)] 67 | [(f) (delay (bindm (f) g))] 68 | [(a) (app-goal g a)] 69 | [(a f) (mplusm (app-goal g a) (delay (bindm (f) g)))])) 70 | 71 | ;; performs a conjunction over goals applied to an a-inf 72 | (define-syntax (bindm* stx) 73 | (syntax-parse stx 74 | [(bindm* a-inf) 75 | (syntax/loc stx a-inf)] 76 | [(bindm* a-inf g g* ...) 77 | (syntax/loc stx 78 | (bindm* (bindm a-inf g) g* ...))])) 79 | 80 | ;; combines a-inf and f, returning an a-inf 81 | (define mplusm 82 | (lambda (a-inf f) 83 | (case-inf a-inf 84 | (() (f)) 85 | ((f^) (delay (mplusm (f) f^))) 86 | ((a) (choiceg a f)) 87 | ((a f^) (choiceg a (delay (mplusm (f) f^))))))) 88 | 89 | ;; shorthand for combining a-infs 90 | (define-syntax mplusm* 91 | (syntax-rules () 92 | ((_ a-inf) a-inf) 93 | ((_ a-inf a-inf* ...) 94 | (mplusm a-inf (delay (mplusm* a-inf* ...)))))) 95 | 96 | #; 97 | (define-syntax (app-goal x) 98 | (syntax-case x () 99 | [(_ g a) #`((wrap-goal g #,(build-srcloc-stx #'g)) a)])) 100 | 101 | (define-syntax (app-goal stx) 102 | (syntax-parse stx 103 | [(app-goal g a) (syntax/loc stx (g a))])) 104 | 105 | (define (non-goal-error-msg val) 106 | (string-append 107 | "expression evaluated to non-ct where a ct was expected" 108 | (format "\n value: ~s" val))) 109 | 110 | (define (wrap-goal val src) 111 | (cond 112 | [(transformer? val) val] 113 | [(format-source src) => 114 | (lambda (loc) (error loc (non-goal-error-msg val)))] 115 | [else (error (non-goal-error-msg val))])) 116 | 117 | (define-syntax (start stx) 118 | (syntax-parse stx 119 | [(start a g g* ...) 120 | (syntax/loc stx (bindm* (app-goal g a) g* ...))])) 121 | 122 | ;; This is a version of application that will catch when users have 123 | ;; misplaced goals. 124 | 125 | ;; If the user is trying to apply a goal to something that is not a 126 | ;; package, or trying to apply a goal to zero or many things, they 127 | ;; will get an goal-as-fn-exn. This will fix the stupid "incorrect 128 | ;; number of arguments to #" errors. 129 | 130 | (struct exn:goal-as-fn exn:fail ()) 131 | (define (raise-goal-as-fn-exn src) 132 | (raise 133 | (exn:goal-as-fn 134 | (format "~s: goal applied as a procedure" (format-source src)) 135 | (current-continuation-marks)))) 136 | 137 | ;; The only correct application of a goal g is to a package a; i.e. (g a). 138 | (define-for-syntax (valid-app?-pred fn args) 139 | (syntax-case args () 140 | [(a) #`(or (not (oc? #,fn)) (a? a))] 141 | [(a* ...) #`(not (oc? #,fn))])) 142 | 143 | (define-syntax (#%app-safe x) 144 | (syntax-case x () 145 | [(_ fn arg ...) 146 | (with-syntax* ([(fn^ arg^ ...) 147 | (generate-temporaries #'(fn arg ...))] 148 | [src (build-srcloc-stx #'fn)] 149 | [valid-app? (valid-app?-pred #'fn^ #'(arg^ ...))]) 150 | (syntax/loc x 151 | (let ([fn^ fn]) 152 | (let ([arg^ arg] ...) 153 | (cond 154 | [valid-app? (#%app fn^ arg^ ...)] 155 | [else (raise-goal-as-fn-exn src)])))))])) 156 | 157 | -------------------------------------------------------------------------------- /cKanren/src/debugging.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "helpers.rkt") 4 | 5 | (provide (all-defined-out)) 6 | 7 | ;; wrapper for the tree 8 | (struct path (t) 9 | #:methods gen:custom-write 10 | [(define (write-proc . args) (apply write-path args))]) 11 | 12 | ;; writes a path 13 | (define (write-path path port mode) 14 | (let ([fn (lambda (s) ((parse-mode mode) s port))]) 15 | (fn "#path[" ) 16 | (unless (null? (path-t path)) (fn " ")) 17 | (for ([br (reverse (path-t path))]) 18 | (fn (format "~s " br))) 19 | (fn "]"))) 20 | 21 | ;; an empty tree 22 | (define empty-t (path '())) 23 | 24 | ;; adds a level to the tree with label l if it exists, a gensym otherwise 25 | (define (add-level p l) 26 | (cond 27 | [l (path (cons l (path-t p)))] 28 | [else (path (cons (gensym 'tr) (path-t p)))])) 29 | 30 | -------------------------------------------------------------------------------- /cKanren/src/errors.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (for-syntax build-srcloc build-srcloc-stx)) 4 | (provide format-source) 5 | 6 | ;; == ERROR CHECKING =========================================================== 7 | 8 | (define cd (current-directory)) 9 | 10 | (define-for-syntax (build-srcloc stx) 11 | (srcloc 12 | (syntax-source stx) 13 | (syntax-line stx) 14 | (syntax-column stx) 15 | (syntax-position stx) 16 | (syntax-span stx))) 17 | 18 | (define-for-syntax (build-srcloc-stx stx) 19 | #`(srcloc 20 | '#,(syntax-source stx) 21 | '#,(syntax-line stx) 22 | '#,(syntax-column stx) 23 | '#,(syntax-position stx) 24 | '#,(syntax-span stx))) 25 | 26 | (define (format-source src) 27 | (define source (srcloc-source src)) 28 | (cond 29 | [(path? source) 30 | (define absolute-path (path->string source)) 31 | (define location (find-relative-path cd absolute-path)) 32 | (define line (srcloc-line src)) 33 | (define column (srcloc-column src)) 34 | (string->symbol (format "~a:~s:~s" location line column))] 35 | [else #f])) 36 | 37 | -------------------------------------------------------------------------------- /cKanren/src/events.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "variables.rkt" "constraints.rkt") 4 | (require racket/generic) 5 | (require (for-syntax syntax/parse racket/syntax racket/match racket/pretty racket/function)) 6 | (provide (all-defined-out)) 7 | 8 | ;; a generic interface for Events 9 | (define-generics event 10 | ;; Event Event -> [Maybe Event] 11 | ;; optimistically merges event and e, which cancels out events 12 | ;; wherever possible. additional constraint that (e< event e) holds. 13 | (gen-optimistic-merge event e relation) 14 | 15 | ;; Event Event -> Event 16 | ;; pessimistically merges event and e, which just shoves them 17 | ;; together into a single event. cannot fail. 18 | (gen-pessimistic-merge event e) 19 | 20 | ;; [Event -> Boolean] Event [Maybe Event] -> [Maybe Event] 21 | ;; finds an event inside the argument event that satisfies fn, if it exists 22 | ;; will look inside chain events off of ce if building a chain for ce 23 | (gen-findf fn event ce) 24 | 25 | ;; [Event -> Boolean] Event -> [List-of Event] 26 | ;; returns a list of all sub-events of event that satisfy fn 27 | (gen-filter fn event) 28 | 29 | ;; [List-of Event] Event -> Event 30 | ;; unchains any events in event whose heads are in solid 31 | (gen-solidify solid event) 32 | 33 | ;; Event -> Event 34 | ;; removes all of the unfounded chains from an event about to be sent 35 | (gen-remove-chains event) 36 | 37 | #:fallbacks 38 | [(define (gen-optimistic-merge e e^ relation) 39 | #f) 40 | (define (gen-pessimistic-merge e e^) 41 | (make-composite-event (list e e^))) 42 | (define (gen-findf fn e ce) 43 | (and (fn e) e)) 44 | (define (gen-filter fn e) 45 | (if (fn e) (list e) (list))) 46 | (define (gen-solidify solid e) e) 47 | (define (gen-remove-chains e) e)]) 48 | 49 | (define-generics compound-event) 50 | 51 | (define-generics association-event 52 | (contains-relevant-var? association-event vars) 53 | (walk/shortcut u association-event)) 54 | 55 | ;; Event Event -> [Maybe Event] 56 | (define (optimistic-merge e e^ [relation eq?]) 57 | (cond 58 | [( Event 63 | (define (pessimistic-merge e e^) 64 | (cond 65 | [(empty-event? e) e^] 66 | [(empty-event? e^) e] 67 | [( Boolean] Event -> [Maybe Event] 72 | (define (findf fn e [ce #f]) 73 | (or (and (fn e) e) (gen-findf fn e ce))) 74 | 75 | ;; [Event -> Boolean] Event -> [List-of Event] 76 | (define (filter fn e) 77 | (cond 78 | [(compound-event? e) 79 | (gen-filter fn e)] 80 | [(fn e) (list e)] 81 | [else '()])) 82 | 83 | ;; orders priority of events 84 | ;; where: chain-events > running-event > composite-event > anything else 85 | (define ( (lambda (e^) 128 | (cond 129 | [(empty-event? e^) (cdr es)] 130 | [else (cons e^ (cdr es))]))] 131 | [(map-maybe fn (cdr es)) 132 | => (curry cons (car es))] 133 | [else #f])) 134 | 135 | (struct composite-event (es) 136 | #:transparent 137 | #:methods gen:event 138 | [(define (gen-optimistic-merge e e^ relation) 139 | (match-define (composite-event es) e) 140 | (cond 141 | [(map-maybe (lambda (e) (optimistic-merge e e^ relation)) es) 142 | => (curry make-composite-event)] 143 | [else #f])) 144 | (define (gen-pessimistic-merge e e^) 145 | (match-define (composite-event es) e) 146 | (cond 147 | [(empty-event? e^) e] 148 | [else (make-composite-event (cons e^ es))])) 149 | (define (gen-findf fn e ce) 150 | (match-define (composite-event es) e) 151 | (ormap (lambda (e) (findf fn e ce)) es)) 152 | (define (gen-filter fn e) 153 | (match-define (composite-event es) e) 154 | (append-map (curry filter fn) es)) 155 | (define (gen-solidify solid e) 156 | (match-define (composite-event es) e) 157 | (for/fold ([new-e (empty-event)]) ([e es]) 158 | (compose-events new-e (solidify solid e)))) 159 | (define (gen-remove-chains e) 160 | (match-define (composite-event es) e) 161 | (for/fold ([new-e (empty-event)]) ([e es]) 162 | (compose-events new-e (remove-chains e))))] 163 | #:methods gen:compound-event []) 164 | 165 | (struct add-substitution-prefix-event (p) 166 | #:transparent 167 | #:methods gen:event 168 | [(define (gen-optimistic-merge e e^ relation) 169 | (match-define (add-substitution-prefix-event p) e) 170 | (match e^ 171 | [(add-substitution-prefix-event p^) 172 | (add-substitution-prefix-event (append p p^))] 173 | [_ #f]))] 174 | #:methods gen:association-event 175 | [(define (contains-relevant-var? e vars) 176 | (match-define (add-substitution-prefix-event p) e) 177 | (define ((assoc-contains-var? u/v) x) (eq? x (car u/v))) 178 | (ormap (lambda (u/v) (ormap (assoc-contains-var? u/v) vars)) p)) 179 | (define (walk/shortcut u e) 180 | (match-define (add-substitution-prefix-event p) e) 181 | (cond [(assq u p) => cdr] [else #f]))]) 182 | 183 | (define ( (curryr running-event w)] 203 | [(optimistic-merge w e^ relation) 204 | => (curry running-event r)] 205 | [else #f])) 206 | (define (gen-pessimistic-merge e e^) 207 | (match-define (running-event r w) e) 208 | (running-event r (pessimistic-merge w e^))) 209 | (define (gen-findf fn e ce) 210 | (match-define (running-event r w) e) 211 | (findf fn r ce)) 212 | (define (gen-filter fn e) 213 | (match-define (running-event r w) e) 214 | (filter fn r))] 215 | #:methods gen:compound-event []) 216 | 217 | (define (relevant? x e) 218 | (and (association-event? e) 219 | (contains-relevant-var? e (list x)))) 220 | 221 | (struct constraint-event (rator rands) 222 | #:transparent 223 | #:methods gen:event []) 224 | 225 | (struct add-constraint-event/internal constraint-event () 226 | #:transparent 227 | #:methods gen:event 228 | [(define (gen-optimistic-merge e e^ relation) 229 | (match-define (add-constraint-event/internal rator rands) e) 230 | (match e^ 231 | [(remove-constraint-event/internal rator^ rands^) 232 | (and (eq? rator rator^) (relation rands rands^) (empty-event))] 233 | [_ #f]))]) 234 | 235 | (struct remove-constraint-event/internal constraint-event () 236 | #:transparent 237 | #:methods gen:event 238 | [(define (gen-optimistic-merge e e^ relation) 239 | (match-define (remove-constraint-event/internal rator rands) e) 240 | (match e^ 241 | [(add-constraint-event/internal rator^ rands^) 242 | (and (eq? rator rator^) (relation rands rands^) (empty-event))] 243 | [_ #f]))]) 244 | 245 | (define-syntax (define-constraint-events stx) 246 | (syntax-parse stx 247 | [(define-new-constraint-event add-name:id remove-name:id) 248 | #'(begin 249 | (struct add-name add-constraint-event/internal () 250 | #:transparent) 251 | (struct remove-name remove-constraint-event/internal () 252 | #:transparent))])) 253 | 254 | (struct build-chain-event running-event (trigger new) 255 | #:transparent 256 | #:methods gen:event 257 | [(define (gen-optimistic-merge e e^ relation) 258 | (match-define (build-chain-event r w tr new) e) 259 | (cond 260 | ;; only if we have totally removed the trigger can we 261 | ;; cancel the chain build 262 | [(empty-event? (optimistic-merge tr e^ relation)) 263 | (running-event (optimistic-merge r e^ relation) 264 | (compose-events w new))] 265 | [(optimistic-merge new e^ equal?) 266 | => (curry build-chain-event r w tr)] 267 | [else #f])) 268 | ;; we can only be here if we have willingly gone into the 269 | ;; waiting event of a running event. so continue on. 270 | (define (gen-findf fn e ce) 271 | (match-define (build-chain-event r w tr new) e) 272 | (or (findf fn r) (findf fn new) (findf fn w tr))) 273 | (define (gen-pessimistic-merge e e^) 274 | (match-define (build-chain-event r w tr new) e) 275 | (build-chain-event r w tr (pessimistic-merge new e^))) 276 | (define (gen-filter fn e) 277 | (match-define (running-event r w) e) 278 | (filter fn r))]) 279 | 280 | (struct chain-event (head tail) 281 | #:transparent 282 | #:methods gen:event 283 | [(define (gen-findf fn e ce) 284 | (match-define (chain-event head tail) e) 285 | (and ce (eq? ce head) (findf fn tail ce))) 286 | (define (gen-solidify solid e) 287 | (match-define (chain-event head tail) e) 288 | (cond 289 | [(memq head solid) (solidify solid tail)] 290 | [else (empty-event)] 291 | ;; [else (chain-event head (solidify solid tail))] 292 | )) 293 | (define (gen-remove-chains e) 294 | (empty-event))] 295 | #:methods gen:compound-event []) 296 | 297 | ;; Event -> Event 298 | ;; replace trigger with (chain-event trigger stored) 299 | (define (apply-chain e) 300 | (match-define (build-chain-event r w tr new) e) 301 | (running-event r (compose-events w (chain-event tr new)))) 302 | 303 | ;; [List-of Event] Event -> Event 304 | (define (solidify solid e) 305 | (gen-solidify solid e)) 306 | 307 | (struct enter-scope-event (x) 308 | #:transparent 309 | #:methods gen:event []) 310 | 311 | (struct leave-scope-event (x) 312 | #:transparent 313 | #:methods gen:event []) 314 | 315 | (define-syntax-rule (define-event name (args ...)) 316 | (struct name (args ...) 317 | #:transparent 318 | #:methods gen:event [])) 319 | 320 | 321 | (struct enforce-event (xs) 322 | #:methods gen:event []) 323 | 324 | (struct enforce-in-event enforce-event ()) 325 | (struct enforce-out-event enforce-event ()) 326 | 327 | -------------------------------------------------------------------------------- /cKanren/src/framework.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "constraints.rkt" 4 | "package.rkt" 5 | "mk-structs.rkt" 6 | "variables.rkt" 7 | "errors.rkt" 8 | "infs.rkt" 9 | "helpers.rkt" 10 | "operators.rkt" 11 | "events.rkt" 12 | "substitution.rkt" 13 | "lex.rkt" 14 | "syntax-classes.rkt" 15 | "triggers.rkt") 16 | 17 | (require syntax/parse 18 | racket/syntax) 19 | 20 | (require (for-syntax 21 | racket 22 | syntax/parse 23 | racket/syntax 24 | racket/match 25 | racket/function 26 | "syntax-classes.rkt")) 27 | 28 | (provide send-event 29 | fresh-aux 30 | fresh 31 | sum 32 | update-package 33 | add-constraint 34 | remove-constraint 35 | add-association 36 | enforce 37 | reify 38 | reifyc 39 | reify-s 40 | extend-rs 41 | default-reify 42 | reified-constraint) 43 | 44 | (define (sum lsct) 45 | (for/fold ([out succeed]) ([ct lsct]) 46 | (conj ct out))) 47 | 48 | ;; defines a macro to create new unconstrained variables 49 | (define-syntax fresh-aux 50 | (syntax-rules () 51 | [(_ constructor (x ...) g g* ...) 52 | (let ([x (constructor (gensym 'x))] ...) 53 | (conj 54 | (send-event (enter-scope-event x)) ... 55 | g g* ... 56 | (send-event (leave-scope-event x)) ...))])) 57 | 58 | ;; miniKanren's "fresh" defined in terms of fresh-aux over vars 59 | (define-syntax-rule (fresh (x ...) g g* ...) 60 | (fresh-aux var (x ...) g g* ...)) 61 | 62 | ;; Event -> ConstraintTransformer 63 | ;; runs all the constraints on the event in the store, 64 | ;; accumulating all their new events and then recurring 65 | (define (send-event new-e) 66 | (lambda@ (a [s c q t e-orig]) 67 | (cond 68 | ;; is the thing we are trying to send empty? if so, why send it 69 | [(empty-event? new-e) a] 70 | ;; if e-orig is empty we can run! 71 | [(empty-event? e-orig) 72 | (define store c) 73 | (define running-e (start-running new-e)) 74 | (define send-to-all (conj send-to-running send-to-store solidify-event)) 75 | (bindm (make-a s c q t running-e) send-to-all)] 76 | ;; if we are already running, don't try to run again. just add 77 | ;; the event we are trying to send to the waiting events 78 | [(running-event? e-orig) 79 | (make-a s c q t (compose-events new-e e-orig))]))) 80 | 81 | ;; ConstraintTransformer 82 | ;; sends each running event to all other running events 83 | (define send-to-running 84 | (lambda@ (a [s c q t e]) 85 | (match-define (running-event r w) e) 86 | (cond 87 | [(composite-event? r) 88 | (bindm a (send-to-comp-event r))] 89 | [else a]))) 90 | 91 | ;; Event -> ConstraintTransformer 92 | (define (send-to-comp-event r) 93 | (match-define (composite-event es) r) 94 | (define (loop pre post) 95 | (match post 96 | [(list) succeed] 97 | [(cons (add-constraint-event/internal rator rands) rest) 98 | (conj (send-to-other-events rator rands (append pre rest)) 99 | (loop (cons (car post) pre) rest))] 100 | [(cons e rest) 101 | (loop (cons e pre) rest)])) 102 | (loop (list) es)) 103 | 104 | ;; Rator Rands [List-of Event] -> ConstraintTransformer 105 | (define (send-to-other-events rator rands es) 106 | (define reaction (-constraint-reaction rator)) 107 | (cond 108 | ;; is our kind of constraint generally interested in anything 109 | ;; inside of the event we have? 110 | [(reaction (composite-event es)) 111 | => ;; Response -> ConstraintTransformer 112 | (lambda (response) 113 | (run-response response rator (list rands)))] 114 | ;; if not, just use the accumulator 115 | [else succeed])) 116 | 117 | ;; ConstraintTransformer 118 | (define solidify-event 119 | (lambda@ (a [s c q t e]) 120 | (match-define (running-event r w) e) 121 | (define old-r 122 | (cond 123 | [(composite-event? r) 124 | (composite-event-es r)] 125 | [else (list r)])) 126 | (define new-r (solidify old-r w)) 127 | (bindm (make-a s c q t (empty-event)) 128 | (conj (sum (map solidify-atomic-event old-r)) 129 | (send-event new-r))))) 130 | 131 | ;; Event ConstraintStore -> ConstraintTransformer 132 | (define send-to-store 133 | (lambda@ (a [s c q t e]) 134 | (define store c) 135 | (define ct 136 | (for/fold 137 | ([ct succeed]) 138 | ([(rator rands*) store]) 139 | (lambda@ (a [s c q t e]) 140 | (match-define (running-event r w) e) 141 | (define reaction (-constraint-reaction rator)) 142 | (cond 143 | ;; is our kind of constraint generally interested in anything 144 | ;; inside of the event we have? 145 | [(reaction r) 146 | => ;; Response -> ConstraintTransformer 147 | (lambda (response) 148 | (bindm a (conj (run-response response rator rands*) ct)))] 149 | ;; if not, just use the accumulator 150 | [else (bindm a ct)])))) 151 | (bindm a ct))) 152 | 153 | ;; Response Rator [List-of Rands] -> ConstraintTransformer 154 | (define (run-response r rator rands* [removing-self-input #f]) 155 | (for/fold ([ct succeed]) ([rands rands*]) 156 | (lambda@ (a [s c q t e]) ;; we need the e? 157 | (define removing-self? 158 | (or removing-self-input 159 | (match-lambda 160 | [(remove-constraint-event/internal rator^ rands^) 161 | (eq? rands rands^)] 162 | [else #f]))) 163 | (define answer 164 | (cond 165 | ;; are we witnessing ourself be removed 166 | [(findf removing-self? e) ct] 167 | ;; is our constraint actually subscribed to our event? 168 | [(apply-response r rands a) 169 | => (match-lambda 170 | [(list (cons tr* ct*) ...) 171 | ;; run-response-ct performs the changes the constraint 172 | ;; would like to see given the trigger. our goal is to 173 | ;; capture what events it causes and chain them after the 174 | ;; trigger. 175 | (conj (for/fold 176 | ([answer succeed]) 177 | ([tr (reverse tr*)] [real-response (reverse ct*)]) 178 | (cond 179 | ;; if the event we are trying to subscribe to still exists in the 180 | ;; current event, then we run the responses from our rands 181 | [(findf (curry eq? tr) e) 182 | (conj 183 | (chain tr) 184 | (remove-constraint (oc rator rands)) 185 | real-response 186 | (unchain removing-self? answer))] 187 | [else answer])) 188 | ct)])] 189 | [else ct])) 190 | (bindm a answer)))) 191 | 192 | (define (chain tr) 193 | (lambda@ (a [s c q t e]) 194 | (match-define (running-event r w) e) 195 | (define new-e (build-chain-event r w tr (empty-event))) 196 | (make-a s c q t new-e))) 197 | 198 | (define (unchain rs? ct) 199 | (lambda@ (a [s c q t e]) 200 | (match e 201 | [(build-chain-event r w tr new) 202 | (define new-e (apply-chain e)) 203 | (define new-a (make-a s c q t new-e)) 204 | (cond 205 | [(findf rs? new) new-a] 206 | [else (bindm new-a ct)])] 207 | [(running-event r w) a]))) 208 | 209 | (define (apply-response r rands a) 210 | ((apply r rands) a)) 211 | 212 | (define (add-association x v) 213 | (lambda@ (a [s c q t e]) 214 | (let ([x (walk x s c e)] [v (walk v s c e)]) 215 | (let ([x (if (var? x) x v)] 216 | [v (if (var? x) v x)]) 217 | (cond 218 | [(eq? x v) a] 219 | [(not (var? x)) #f] 220 | [else (bindm a (send-event (add-substitution-prefix-event `((,x . ,v)))))]))))) 221 | 222 | (define (add-constraint an-oc) 223 | (match-define (oc rator rands) an-oc) 224 | (send-event ((-constraint-add rator) rator rands))) 225 | 226 | (define update-s 227 | (case-lambda 228 | [(u v) 229 | (lambda@ (a [s c q t e]) 230 | (make-a (ext-s (walk u s) (walk v s) s) c q t e))] 231 | [(p) 232 | (lambda@ (a [s c q t e]) 233 | (make-a (ext-s* (walk* p s) s) c q t e))])) 234 | 235 | (define (update-c new-oc) 236 | (lambda@ (a [s c q t e]) 237 | (make-a s (ext-c new-oc c) q t e))) 238 | 239 | (define (remove-from-c old-oc) 240 | (lambda@ (a [s c q t e]) 241 | (make-a s (remq-c old-oc c) q t e))) 242 | 243 | (define (remove-constraint an-oc) 244 | (match-define (oc rator rands) an-oc) 245 | (send-event ((-constraint-rem rator) rator rands))) 246 | 247 | (define (enforce x) 248 | (lambda@ (a [s c q t e]) 249 | (define xs (filter*/var? (walk* x s))) 250 | (define ct 251 | (conj (send-event (enforce-in-event xs)) 252 | (onceo (send-event (enforce-out-event xs))))) 253 | (bindm a ct))) 254 | 255 | (define (reify x) 256 | (lambda@ (a [s c q t e]) 257 | (define v (walk* x s c e)) 258 | (define r (reify-s v empty-s)) 259 | (define v^ (reify-term v r)) 260 | (cond 261 | [(null? r) v^] 262 | [else (reify-constraints v^ r c)]))) 263 | 264 | ;; reifies the substitution, returning the reified substitution 265 | (define (reify-s v^ s) 266 | (define v (walk v^ s)) 267 | (cond 268 | [(cvar? v) 269 | (extend-rs v s)] 270 | [(mk-struct? v) 271 | (define (k a d) 272 | (reify-s d (reify-s a s))) 273 | (recur v k)] 274 | [else s])) 275 | 276 | (define (extend-rs v s) 277 | `((,v . ,(reify-n v (size-s s))) . ,s)) 278 | 279 | (define (reifyc) 280 | (lambda@ (a [s c q t e]) 281 | ;; get all of the variables mentioned in the constraint store and 282 | ;; make a reified substitution for them 283 | (define v (walk* (filter*/var? (hash->list c)) s c e)) 284 | (define r (reify-s v empty-s)) 285 | 286 | ;; then sort and return a reified version of all constraints 287 | (sort-store (run-reify-fns v r c #f)))) 288 | 289 | (define (reify-constraints v r store) 290 | (define store^ (run-reify-fns v r store)) 291 | (cond 292 | [(null? store^) v] 293 | [#t `(,v : . ,(sort-store store^))] 294 | [else `(,v . ,(sort-store store^))])) 295 | 296 | ;; sorts the constraint store by lex<= 297 | (define (sort-store ocs) (sort ocs lex<= #:key car)) 298 | 299 | (struct reified-constraint (sym ans r) 300 | #:transparent) 301 | 302 | (define (run-reify-fns v r store [with-vars-check? #t]) 303 | (define-values (hash-store r^) 304 | (for*/fold 305 | ([h (hash)] [r r]) 306 | ([(rator rands*) store] 307 | #:when (-constraint-reifyfn rator) 308 | [rands (sort rands* lex<=)]) 309 | (cond 310 | [(or (not with-vars-check?) (any/var? rands)) 311 | (match ((apply (-constraint-reifyfn rator) rands) v r) 312 | [(reified-constraint sym ans r) 313 | (cond 314 | [(not sym) (values h r)] 315 | [(any/var? ans) (values h r)] 316 | [else 317 | (define updatefn (curry insert-in-lex-order ans)) 318 | (values (hash-update h sym updatefn '()) r)])] 319 | [_ (values h r)])] 320 | [else (values h r)]))) 321 | 322 | (hash->list 323 | (for/fold 324 | ([h (hash)]) 325 | ([(rator rands*) hash-store]) 326 | (cond 327 | [(pair? rator) 328 | (define updatefn (curry insert-in-lex-order rands*)) 329 | (hash-update h (car rator) updatefn '())] 330 | [else (hash-set h rator rands*)])))) 331 | 332 | ;; given a new substitution and constraint store, adds the prefixes of 333 | ;; each to the existing substitution and constraint store. the 334 | ;; constraints in c-prefix still need to run 335 | (define (update-package s^ c^) 336 | (lambda@ (a [s c q t e]) 337 | (define s-prefix 338 | (map (match-lambda [(cons x v) (if (var? x) (cons x v) (cons v x))]) 339 | (prefix-s s s^))) 340 | (define c-prefix (prefix-c c c^)) 341 | (define add-event (add-substitution-prefix-event s-prefix)) 342 | (cond 343 | [(null? s-prefix) a] 344 | [else (bindm a (conj (send-event add-event) (sum c-prefix)))]))) 345 | 346 | ;; Event -> ConstraintTransformer 347 | (define/match (solidify-atomic-event e) 348 | [((add-substitution-prefix-event p)) (update-s p)] 349 | [((add-constraint-event/internal rator rands)) 350 | (update-c (oc rator rands))] 351 | [((remove-constraint-event/internal rator rands)) 352 | (remove-from-c (oc rator rands))] 353 | [((empty-event)) succeed] 354 | [(e) succeed]) 355 | 356 | (define (default-reify sym . args) 357 | (lambda (v r) 358 | (define reified-rands 359 | (cond 360 | [(null? args) args] 361 | [(null? (cdr args)) (car args)] 362 | [else args])) 363 | (reified-constraint sym reified-rands r))) 364 | 365 | 366 | 367 | -------------------------------------------------------------------------------- /cKanren/src/helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base)) 4 | 5 | (provide debug? parse-mode attr-tag extend-parameter) 6 | (provide (for-syntax expand-debug?)) 7 | 8 | (begin-for-syntax 9 | (define expand-debug? (make-parameter #f))) 10 | 11 | ;; when debug?ging is turned on, print out the path as well 12 | (define debug? (make-parameter #f)) 13 | 14 | ;; parses the input to a write-proc 15 | (define (parse-mode mode) 16 | (case mode [(#t) display] [(#f) display] [else display])) 17 | 18 | (define attr-tag 'attr) 19 | 20 | (define ((extend-parameter param) tag fn) 21 | (let ((fns (param))) 22 | (when (assq tag fns) 23 | (error 'extend-parameter "duplicate tag: ~s" tag)) 24 | (param (cons `(,tag . ,fn) fns)))) 25 | 26 | -------------------------------------------------------------------------------- /cKanren/src/infs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "helpers.rkt") 4 | 5 | ;; == STREAMS ================================================================== 6 | ;; 7 | ;; A Stream is an A-Inf 8 | ;; An A-Inf is one of: 9 | ;; - Inc 10 | ;; - Choiceg 11 | ;; - [Maybe Package-Internal] 12 | ;; A Package-Internal is a (make-a Any Any Any Any Any) 13 | ;; A Choiceg is a (cons Package-Internal A-Inf) 14 | ;; An Inc is a (lambda () A-Inf) 15 | 16 | (provide 17 | ;; Any Any Any Any Any -> Package-Internal 18 | ;; the parts of the Package are defined later, for now, they can be anything 19 | make-a/internal 20 | 21 | ;; the various parts of the Package-Internal 22 | a? a-s a-c a-q a-t a-e 23 | 24 | ;; -> Stream 25 | ;; returns the failing Stream when called 26 | mzerof 27 | 28 | ;; Package-Internal A-Inf -> Stream 29 | ;; returns a choice between the package and the a-inf 30 | choiceg 31 | 32 | case-inf 33 | delay) 34 | 35 | ;; the stream miniKanren runs on 36 | ;; (struct a-inf ()) 37 | 38 | ;; the simple manifestations of the stream 39 | ;; (struct mzerof a-inf ()) 40 | ;; (struct choiceg a-inf (a f)) 41 | ;; (struct inc a-inf (e) 42 | ;; #:property prop:procedure (struct-field-index e) 43 | ;; #:methods gen:custom-write 44 | ;; [(define (write-proc i port mode) 45 | ;; ((parse-mode mode) "#" port))]) 46 | 47 | (define mzerof (lambda () #f)) 48 | (define choiceg cons) 49 | 50 | (struct a #;a-inf (s c q t e) 51 | #:transparent 52 | #:extra-constructor-name make-a/internal 53 | #:methods gen:custom-write 54 | [(define (write-proc . args) (apply write-package args))]) 55 | 56 | ;; controls how packages are displayed 57 | (define (write-package a port mode) 58 | (let ([fn (lambda (s) ((parse-mode mode) s port))]) 59 | (if (debug?) 60 | (fn (format "#a{ ~s ~a ~a ~a }" (a-t a) (a-s a) (a-c a) (a-e a))) 61 | (fn (format "#a{ ~a ~a ~a }" (a-s a) (a-c a) (a-e a)))))) 62 | 63 | ;; macro that delays expressions 64 | (define-syntax lambdaf@ 65 | (syntax-rules () 66 | ((_ () e) (let () (define (a-delay) e) a-delay)))) 67 | 68 | ;; delays an expression 69 | (define-syntax delay 70 | (syntax-rules () 71 | ;; [(_ e) (inc (lambdaf@ () e))] 72 | [(_ e) (lambdaf@ () e)])) 73 | 74 | (define empty-f (delay (mzerof))) 75 | 76 | ;; convenience macro for dispatching on the type of a-inf 77 | 78 | #; 79 | (define-syntax case-inf 80 | (syntax-rules () 81 | ((_ e (() e0) ((f^) e1) ((a^) e2) ((a f) e3)) 82 | (let ([a-inf e]) 83 | (cond 84 | [(mzerof? a-inf) e0] 85 | [(inc? a-inf) (let ([f^ (inc-e a-inf)]) e1)] 86 | [(a? a-inf) (let ([a^ a-inf]) e2)] 87 | [(choiceg? a-inf) (let ([a (choiceg-a a-inf)] [f (choiceg-f a-inf)]) e3)] 88 | [else (error 'case-inf "not an a-inf ~s" e)]))))) 89 | 90 | (define-syntax case-inf 91 | (syntax-rules () 92 | ((_ e (() e0) ((f^) e1) ((a^) e2) ((a f) e3)) 93 | (let ((a-inf e)) 94 | (cond 95 | [(not a-inf) e0] 96 | [(procedure? a-inf) 97 | (let ([f^ a-inf]) e1)] 98 | [(not (and (pair? a-inf) 99 | (procedure? (cdr a-inf)))) 100 | (let ([a^ a-inf]) e2)] 101 | [else (let ([a (car a-inf)] [f (cdr a-inf)]) 102 | e3)]))))) 103 | 104 | 105 | 106 | -------------------------------------------------------------------------------- /cKanren/src/lex.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | ;; sorts a list by lex<= 6 | (define (sort-by-lex<= l) (sort l lex<=)) 7 | 8 | ;; for pretty reification: 9 | ;; vector? <= 10 | ;; port? 11 | ;; procedure? 12 | ;; boolean? 13 | ;; null? 14 | ;; char? 15 | ;; number? 16 | ;; string? 17 | ;; symbol? 18 | ;; pair? 19 | (define lex<= 20 | (lambda (x y) 21 | (cond 22 | ((vector? x) #t) 23 | ((vector? y) #f) 24 | ((port? x) #t) 25 | ((port? y) #f) 26 | ((procedure? x) #t) 27 | ((procedure? y) #f) 28 | ((boolean? x) 29 | (cond 30 | ((boolean? y) (or (not x) (eq? x y))) 31 | (else #t))) 32 | ((boolean? y) #f) 33 | ((null? x) #t) 34 | ((null? y) #f) 35 | ((char? x) 36 | (cond 37 | ((char? y) (char<=? x y)) 38 | (else #t))) 39 | ((char? y) #f) 40 | ((number? x) 41 | (cond 42 | ((number? y) (<= x y)) 43 | (else #t))) 44 | ((number? y) #f) 45 | ((string? x) 46 | (cond 47 | ((string? y) (string<=? x y)) 48 | (else #t))) 49 | ((string? y) #f) 50 | ((symbol? x) 51 | (cond 52 | ((symbol? y) 53 | (string<=? (symbol->string x) 54 | (symbol->string y))) 55 | (else #t))) 56 | ((symbol? y) #f) 57 | ((pair? x) 58 | (cond 59 | ((pair? y) 60 | (cond 61 | ((equal? (car x) (car y)) 62 | (lex<= (cdr x) (cdr y))) 63 | (else (lex<= (car x) (car y))))))) 64 | ((pair? y) #f) 65 | (else #t)))) 66 | 67 | (define (insert-in-lex-order x ls) 68 | (cond 69 | [(null? ls) (list x)] 70 | [(lex<= x (car ls)) (cons x ls)] 71 | [else (cons (car ls) (insert-in-lex-order x (cdr ls)))])) 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /cKanren/src/mk-structs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/generic racket/vector) 4 | (require "substitution.rkt" "variables.rkt" "events.rkt") 5 | 6 | (provide (all-defined-out)) 7 | 8 | ;; ============================================================================= 9 | 10 | (define-generics mk-struct 11 | ;; recur allows generic traversing of mk-structs. k should be a 12 | ;; procedure expecting two arguments, the first thing to process, 13 | ;; and a list of remaining things to process. 14 | (recur mk-struct k) 15 | 16 | ;; returns a function that will create a new mk-struct given 17 | ;; arguments like the arguments to k 18 | (constructor mk-struct) 19 | 20 | ;; for reification 21 | (reify-mk-struct mk-struct r) 22 | 23 | ;; structs also have the option of overriding the occurs-check for 24 | ;; variables if it's okay to unify a variable to a struct with the 25 | ;; same variable inside (ex. sets) 26 | (override-occurs-check? mk-struct) 27 | 28 | #:fallbacks 29 | [(define (override-occurs-check? mk) #f)] 30 | 31 | #:defaults 32 | ([pair? 33 | (define (recur p k) 34 | (k (car p) (cdr p))) 35 | (define (constructor p) cons) 36 | (define (reify-mk-struct p r) 37 | (reify-pair p r))] 38 | [vector? 39 | (define (recur v k) 40 | (let ([v (vector->list v)]) 41 | (k (car v) (cdr v)))) 42 | (define (constructor v) 43 | (compose list->vector cons)) 44 | (define (reify-mk-struct v r) 45 | (reify-vector v r))])) 46 | 47 | (define (reify-term t r) 48 | (cond 49 | [(mk-struct? t) 50 | (reify-mk-struct t r)] 51 | [else (walk/internal t r #f)])) 52 | 53 | (define (default-mk-struct? x) 54 | (or (pair? x) (vector? x))) 55 | 56 | (define (same-default-type? x y) 57 | (or (and (pair? x) (pair? y)) 58 | (and (vector? x) (vector? y)))) 59 | 60 | (define (reify-pair p r) 61 | (cons (reify-term (car p) r) 62 | (reify-term (cdr p) r))) 63 | 64 | (define (reify-vector v r) 65 | (vector-map (lambda (t) (reify-term t r)) v)) 66 | 67 | ;; returns #t if p contains any variables 68 | (define (any/var? x) 69 | (cond 70 | ((mk-struct? x) 71 | (recur x (lambda (a d) (or (any/var? a) (any/var? d))))) 72 | (else (var? x)))) 73 | 74 | ;; returns #t if t constains variables in x* 75 | (define (any-relevant/var? t x*) 76 | (cond 77 | ((mk-struct? t) 78 | (recur t (lambda (a d) (or (any-relevant/var? a x*) 79 | (any-relevant/var? d x*))))) 80 | (else (and (var? t) (memq t x*))))) 81 | 82 | (define (filter*/var? t) 83 | (cond 84 | [(var? t) `(,t)] 85 | [(mk-struct? t) 86 | (define (k a d) 87 | (append (filter*/var? a) 88 | (filter*/var? d))) 89 | (recur t k)] 90 | [else `()])) 91 | 92 | ;; walks an entire mk-struct 93 | (define walk* 94 | (case-lambda 95 | [(u s) 96 | (define v (walk u s)) 97 | (cond 98 | [(mk-struct? v) 99 | (define (k a d) 100 | ((constructor v) (walk* a s) (walk* d s))) 101 | (recur v k)] 102 | [else v])] 103 | [(u s c e) 104 | (define v (walk u s c e)) 105 | (cond 106 | [(mk-struct? v) 107 | (define (k a d) 108 | ((constructor v) (walk* a s c e) (walk* d s c e))) 109 | (recur v k)] 110 | [else v])])) 111 | 112 | -------------------------------------------------------------------------------- /cKanren/src/operators.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "helpers.rkt" 4 | "infs.rkt" 5 | "errors.rkt" 6 | "variables.rkt" 7 | "mk-structs.rkt" 8 | "debugging.rkt" 9 | "constraints.rkt" 10 | racket/stxparam) 11 | 12 | (require 13 | (for-syntax "helpers.rkt" 14 | "errors.rkt" 15 | syntax/parse)) 16 | 17 | (provide (all-defined-out)) 18 | 19 | ;; succeed and fail are the simplest succeeding and failing ct 20 | (define succeed (lambda@ (a) a)) 21 | (define fail (lambda@ (a) mzerom)) 22 | 23 | (define onceo (lambda (g) (condu (g)))) 24 | 25 | (define (succeed-iff bool) 26 | (if bool succeed fail)) 27 | 28 | ;; ============================================================================= 29 | 30 | ;; shorthand for conjunction 31 | (define-syntax conj 32 | (syntax-rules () 33 | [(_ g) g] 34 | [(_ g g* ...) 35 | (lambda@ (a) (delay (start a g g* ...)))])) 36 | 37 | (define-syntax disj 38 | (syntax-rules () 39 | [(_ g) g] 40 | [(_ g g* ...) 41 | (conde [g] [g*] ...)])) 42 | 43 | (define-syntax-parameter conde 44 | (lambda (stx) 45 | (syntax-parse stx 46 | [(_ ((~optional (~seq #:name branch-name)) g g* ...) ...+) 47 | (cond 48 | [(expand-debug?) 49 | (with-syntax ([(branches ...) (attribute branch-name)]) 50 | #'(debug-conde [#:name branches g g* ...] ...))] 51 | [else 52 | #'(lambda@ (a) 53 | (delay (mplusm* (start a g g* ...) ...)))])]))) 54 | 55 | (define-syntax (debug-conde stx) 56 | (syntax-parse stx 57 | [(_ ((~optional (~seq #:name branch-name)) g g* ...) ...+) 58 | (with-syntax ([(labels ...) (attribute branch-name)]) 59 | #'(lambda@ (a [s c q t e]) 60 | (delay 61 | (mplusm* 62 | (let ([a (make-a s c q (add-level t 'labels))]) 63 | (start a g g* ...)) 64 | ...))))])) 65 | 66 | (define-syntax (debug stx) 67 | (syntax-parse stx 68 | [(debug #:on) 69 | (begin (expand-debug? #t) #'(debug? #t))] 70 | [(debug #:off) 71 | (begin (expand-debug? #f) #'(debug? #f))] 72 | [(debug expr ...+) 73 | #'(syntax-parameterize 74 | ([conde (... (syntax-rules () 75 | ([_ clauses ...] 76 | (debug-conde clauses ...))))]) 77 | (parameterize ([debug? #t]) 78 | expr ...))])) 79 | 80 | (define-syntax-rule (conda (g0 g ...) (g1 g^ ...) ...) 81 | (lambda@ (a) 82 | (delay (ifa ((app-goal g0 a) g ...) 83 | ((app-goal g1 a) g^ ...) ...)))) 84 | 85 | (define-syntax ifa 86 | (syntax-rules () 87 | ((_) mzerom) 88 | ((_ (e g ...) b ...) 89 | (let loop ((a-inf e)) 90 | (case-inf a-inf 91 | (() (ifa b ...)) 92 | ((f) (delay (loop (f)))) 93 | ((a) (bindm* a-inf g ...)) 94 | ((a f) (bindm* a-inf g ...))))))) 95 | 96 | (define-syntax-rule (condu (g0 g ...) (g1 g^ ...) ...) 97 | (lambda@ (a) 98 | (delay 99 | (ifu ((start a g0) g ...) 100 | ((start a g1) g^ ...) ...)))) 101 | 102 | (define-syntax ifu 103 | (syntax-rules () 104 | ((_) mzerom) 105 | ((_ (e g ...) b ...) 106 | (let loop ((a-inf e)) 107 | (case-inf a-inf 108 | (() (ifu b ...)) 109 | ((f) (delay (loop (f)))) 110 | ((a) (bindm* a-inf g ...)) 111 | ((a f) (bindm* a g ...))))))) 112 | 113 | (define-syntax-rule (project (x ...) g g* ...) 114 | (lambda@ (a : s) 115 | (let ((x (walk*-internal x s)) ...) 116 | (bindm a (conj g g* ...))))) 117 | 118 | ;; for debugging, a goal that prints the substitution and a goal 119 | ;; that prints a message. both succeed. 120 | 121 | (define prt 122 | (lambda@ (a) (begin (printf "~a\n" a) a))) 123 | 124 | (require racket/pretty) 125 | (define pprt 126 | (lambda@ (a [s c q t e]) 127 | (begin (pretty-print a) a))) 128 | 129 | (define (prtm . m) 130 | (lambda@ (a) (begin (apply printf m) a))) 131 | 132 | (define (prtt . m) 133 | (lambda@ (a [s c q t e]) 134 | (begin (display t) (display " ") (apply printf m) a))) 135 | 136 | (define diaf 137 | (lambda@ (a) (error 'diaf "dying: ~s" a))) 138 | 139 | (define-syntax-rule (for/disj (for-clause ...) body) 140 | (for/fold ([ct fail]) (for-clause ...) 141 | (disj body ct))) 142 | 143 | (define-syntax-rule (for/conj (for-clause ...) body) 144 | (for/fold ([ct succeed]) (for-clause ...) 145 | (conj body ct))) 146 | -------------------------------------------------------------------------------- /cKanren/src/package.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "constraint-store.rkt" "substitution.rkt" "queue.rkt" 4 | "debugging.rkt" "infs.rkt" "events.rkt") 5 | 6 | (provide (struct-out path)) 7 | 8 | (provide (all-from-out "constraint-store.rkt")) 9 | (provide (all-from-out "substitution.rkt")) 10 | (provide (all-from-out "queue.rkt")) 11 | (provide (all-from-out "debugging.rkt")) 12 | (provide empty-a) 13 | 14 | (provide 15 | #; 16 | (contract-out 17 | [make-a 18 | (-> (flat-contract substitution?) 19 | (flat-contract constraint-store?) 20 | any/c 21 | any/c 22 | (flat-contract event?) 23 | (flat-contract a?))]) 24 | make-a) 25 | 26 | ;; == PACKAGE ================================================================== 27 | 28 | ;; the empty package 29 | (define empty-a 30 | (make-a/internal empty-s empty-c empty-q empty-t empty-e)) 31 | 32 | (define make-a make-a/internal) 33 | 34 | -------------------------------------------------------------------------------- /cKanren/src/queue.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "operators.rkt") 4 | 5 | (provide empty-q empty-q? ext-q) 6 | 7 | ;; == QUEUE ==================================================================== 8 | 9 | ;; an empty queue 10 | (define empty-q succeed) 11 | (define empty-q? ((curry eq?) empty-q)) 12 | 13 | (define (ext-q q q^) (conj q q^)) 14 | 15 | -------------------------------------------------------------------------------- /cKanren/src/running.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (for-syntax syntax/parse 4 | racket/syntax 5 | "framework.rkt" 6 | "syntax-classes.rkt") 7 | "framework.rkt" 8 | syntax/parse 9 | racket/syntax 10 | racket/pretty 11 | "helpers.rkt" 12 | "operators.rkt" 13 | "constraints.rkt" 14 | "events.rkt" 15 | "package.rkt" 16 | "syntax-classes.rkt" 17 | racket/generator 18 | "infs.rkt" 19 | "macros.rkt" 20 | "variables.rkt") 21 | 22 | (provide (all-defined-out)) 23 | 24 | (define-syntax (run/internal stx) 25 | (syntax-parse stx 26 | [(run/internal n:expr g:expr ...+) 27 | (define/with-syntax initialize-interactions 28 | #'(spawn-constraint-interactions)) 29 | (define/with-syntax prog #'(conj g ...)) 30 | (define/with-syntax initial-a-inf 31 | #'(delay (bindm empty-a (conj initialize-interactions prog)))) 32 | (syntax/loc #'stx 33 | (take n (generator () (take/lazy initial-a-inf))))])) 34 | 35 | (define-syntax (run/lazy stx) 36 | (syntax-parse stx 37 | [(run/lazy () g:expr ...) 38 | (define/with-syntax initialize-interactions 39 | #'(spawn-constraint-interactions)) 40 | (define/with-syntax prog 41 | #'(let ([x (var 'x)]) 42 | (conj g ... (enforce x) (reifyc)))) 43 | (define/with-syntax initial-a-inf 44 | #'(delay (bindm empty-a (conj initialize-interactions prog)))) 45 | (syntax/loc #'stx 46 | (let ([a-inf initial-a-inf]) 47 | (generator () (take/lazy a-inf))))] 48 | [(run/lazy (x:id) g:expr ...) 49 | (define/with-syntax initialize-interactions 50 | #'(spawn-constraint-interactions)) 51 | (define/with-syntax prog 52 | #'(let ([x (var 'x)]) 53 | (conj g ... (enforce x) (reify x)))) 54 | (define/with-syntax initial-a-inf 55 | #'(delay (bindm empty-a (conj initialize-interactions prog)))) 56 | (syntax/loc #'stx 57 | (let ([a-inf initial-a-inf]) 58 | (generator () (take/lazy a-inf))))])) 59 | 60 | ;; convenience macro to integrate Scheme and cKanren, 61 | ;; returns n answers to the goals g0 g1 ... where x is fresh 62 | (define-syntax (run stx) 63 | (syntax-parse stx 64 | [(_ n:expr () g0:expr g1:expr ...) 65 | (syntax/loc stx 66 | (let ([stream (run/lazy () g0 g1 ...)]) 67 | (take n stream)))] 68 | [(_ n:expr (x:id) g0:expr g1:expr ...) 69 | (syntax/loc stx 70 | (let ([stream (run/lazy (x) g0 g1 ...)]) 71 | (take n stream)))] 72 | [(_ n:expr (x:id ...) g:expr ...) 73 | (syntax/loc stx 74 | (run n (q) (fresh (x ...) (add-association q `(,x ...)) g ...)))])) 75 | 76 | ;; RUNS ALL THE THINGS 77 | (define-syntax (run* stx) 78 | (syntax-parse stx 79 | [(_ (x ...) g ...) 80 | (syntax/loc stx (run #f (x ...) g ...))])) 81 | 82 | (define-syntax (case/lazy stx) 83 | (syntax-parse stx 84 | [(_ gen [() no-answer-clause:expr] [(x:id g:id) an-answer-clause:expr]) 85 | (syntax/loc stx 86 | (let ([g gen]) 87 | (call-with-values (lambda () (g)) 88 | (case-lambda 89 | [() no-answer-clause] 90 | [(x) an-answer-clause]))))])) 91 | 92 | ;; given a number n and a stream, takes n answers from f 93 | (define (take n stream) 94 | (cond 95 | [(and n (zero? n)) '()] 96 | [else 97 | (case/lazy stream 98 | [() '()] 99 | [(a _) (cons a (take (and n (- n 1)) stream))])])) 100 | 101 | (define (take/lazy f) 102 | (case-inf (f) 103 | [() (yield)] 104 | [(f) (take/lazy f)] 105 | [(a) (yield a)] 106 | [(a f) (begin (yield a) (take/lazy f))])) 107 | 108 | (struct running (x a-inf) 109 | #:methods gen:custom-write 110 | [(define (write-proc ra port mode) 111 | ((parse-mode mode) "#" port))]) 112 | 113 | (struct enforced running () 114 | #:methods gen:custom-write 115 | [(define (write-proc ra port mode) 116 | ((parse-mode mode) "#" port))]) 117 | 118 | (define-syntax (start/ir stx) 119 | (syntax-parse stx 120 | [(_ g ...) 121 | (define/with-syntax initialize-interactions 122 | #'(spawn-constraint-interactions)) 123 | (define/with-syntax initial-a-inf 124 | #'(delay (bindm empty-a (conj initialize-interactions prog)))) 125 | #'(let ([x (var 'x)]) 126 | (running x (delay (bindm empty-a (conj initialize-interactions g ...)))))])) 127 | 128 | (define-syntax (extend/ir stx) 129 | (syntax-parse stx 130 | [(extend/ir state 131 | (~optional (~seq #:var x) 132 | #:defaults ([x (generate-temporary #'?x)])) 133 | g ...) 134 | #'(let ([st state]) 135 | (let ([x (running-x st)] 136 | [a-inf (running-a-inf st)]) 137 | (running x (bindm a-inf (conj succeed g ...)))))])) 138 | 139 | (define-syntax-rule 140 | (enforce/ir state) 141 | (let ([st state]) 142 | (let ([x (running-x st)] 143 | [a-inf (running-a-inf st)]) 144 | (enforced x (bindm a-inf (enforce x)))))) 145 | 146 | (define-syntax-rule 147 | (reify/ir state) 148 | (let ([st state]) 149 | (unless (enforced? st) 150 | (error 'reify/ir "trying to reify an unenforced state ~s" st)) 151 | (let ([x (running-x st)] 152 | [a-inf (running-a-inf st)]) 153 | (bindm a-inf (reify x))))) 154 | 155 | (define-syntax-rule 156 | (reifyc/ir state) 157 | (let ([st state]) 158 | (unless (enforced? st) 159 | (error 'reify/ir "trying to reify an unenforced state ~s" st)) 160 | (let ([x (running-x st)] 161 | [a-inf (running-a-inf st)]) 162 | (bindm a-inf (reifyc))))) 163 | 164 | (define-syntax (exit/ir stx) 165 | (syntax-parse stx 166 | [(exit/ir st) 167 | #'(exit/ir #f st)] 168 | [(exit/ir n state) 169 | #'(let ([stream 170 | (generator 171 | () 172 | (take/lazy 173 | (let ([st state]) 174 | (reify/ir 175 | (cond 176 | [(enforced? st) st] 177 | [else (enforce/ir st)])))))]) 178 | (take n stream))])) 179 | 180 | (define-syntax-rule (exit*/ir state) (exit/ir #f state)) 181 | 182 | (define-syntax (exitc/ir stx) 183 | (syntax-parse stx 184 | [(exitc/ir st) 185 | #'(exitc/ir #f st)] 186 | [(exitc/ir n state) 187 | #'(let ([stream 188 | (generator 189 | () 190 | (take/lazy 191 | (let ([st state]) 192 | (reifyc/ir 193 | (cond 194 | [(enforced? st) st] 195 | [else (enforce/ir st)])))))]) 196 | (take n stream))])) 197 | 198 | -------------------------------------------------------------------------------- /cKanren/src/substitution.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (only-in "variables.rkt" cvar? var?) 4 | (only-in "events.rkt" relevant? findf walk/shortcut)) 5 | 6 | ;; == SUBSTITUTIONS ============================================================ 7 | ;; 8 | ;; A Substitution is a [List-of Association] 9 | ;; An Association is a (cons Var Value) 10 | ;; A SubstitutionPrefix is Subsitution 11 | 12 | (provide 13 | ;; Value -> Boolean 14 | ;; returns #t iff the value is a Subsitution 15 | substitution? 16 | 17 | ;; Substitution 18 | ;; the empty subsitution 19 | empty-s 20 | 21 | ;; Var Value Subsitution -> Subsitution 22 | ;; extends the given subsitution with a binding (cons Var Value) 23 | ext-s 24 | 25 | ;; SubsitutionPrefix Subsitution -> Subsitution 26 | ;; appends the associations in the prefix onto the given subsitution 27 | ext-s* 28 | 29 | ;; Subsitution -> Number 30 | ;; returns the size of the substitution 31 | size-s 32 | 33 | ;; Substitution Substitution -> Substitution 34 | ;; returns the prefix of the first substitution that is not contained 35 | ;; in the second subsitution (it is an error to send two completely 36 | ;; unrelated substitutions) 37 | prefix-s 38 | 39 | ;; Var Value Subsitution -> Value 40 | ;; checks if the variable appears in the value (given the associations 41 | ;; in the substitution) 42 | occurs-check 43 | 44 | ;; Var Substitution -> Value 45 | ;; Var Substitution ConstraintStore Event -> Value 46 | ;; returns the association for the variable in the substitution or in 47 | ;; the event (when given), or returns the variable unchanged if it has 48 | ;; no association 49 | walk 50 | 51 | ;; Var Substitution -> Value 52 | ;; returns the association for the variable in the substitution or 53 | ;; returns the variable unchanged if it has no association 54 | walk/internal 55 | ) 56 | 57 | (define substitution? list?) 58 | 59 | ;; the empty association list, abbreviated s 60 | (define empty-s '()) 61 | (define empty-s? null?) 62 | 63 | (define (ext-s x v s) (cons `(,x . ,v) s)) 64 | (define (ext-s* p s) (append p s)) 65 | 66 | (define (size-s s) (length s)) 67 | 68 | (define (prefix-s s s^) 69 | (define (loop s^) 70 | (cond 71 | [(eq? s^ s) '()] 72 | [else (cons (car s^) (loop (cdr s^)))])) 73 | (if (empty-s? s) s^ (loop s^))) 74 | 75 | (define (occurs-check x v^ s) 76 | (define v (walk/internal v^ s #f)) 77 | (cond 78 | [(var? v) (eq? v x)] 79 | [(pair? v) 80 | (or (occurs-check x (car v) s) 81 | (occurs-check x (cdr v) s))] 82 | [else #f])) 83 | 84 | (define walk 85 | (case-lambda 86 | [(u s) 87 | (walk/internal u s #f)] 88 | [(u s c e) 89 | (walk/internal u s e)])) 90 | 91 | (define (walk/internal v s e) 92 | (cond 93 | [(and (cvar? v) (assq v s)) 94 | => (lambda (a) (walk/internal (cdr a) s e))] 95 | [(and (cvar? v) e (findf (curry relevant? v) e)) 96 | => (lambda (e^) (walk/internal (walk/shortcut v e^) s e))] 97 | [else v])) 98 | -------------------------------------------------------------------------------- /cKanren/src/syntax-classes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (for-syntax syntax/parse racket/syntax)) 4 | 5 | (provide (all-defined-out)) 6 | (provide (for-syntax (all-defined-out))) 7 | 8 | (define (identity-update-fn x . rest) x) 9 | 10 | (begin-for-syntax 11 | 12 | (define-splicing-syntax-class package-keyword 13 | #:attributes (package) 14 | (pattern (~seq #:package (a:id [s:id c:id e:id])) 15 | #:with package #'(a [s c e])) 16 | (pattern (~seq #:package a:id) 17 | #:with (s c e) (generate-temporaries #'(?s ?c ?e)) 18 | #:with package #'(a [s c e])) 19 | (pattern (~seq) 20 | #:with (a s c e) (generate-temporaries #'(?a ?s ?c ?e)) 21 | #:with package #'(a [s c e]))) 22 | 23 | (define-syntax-class (argument default-fn) 24 | #:attributes (arg fn) 25 | (pattern [arg:id #:constant] 26 | #:with fn #'identity-update-fn) 27 | (pattern [arg:id fn]) 28 | (pattern arg:id 29 | #:with fn default-fn)) 30 | 31 | ;; constructor keyword matching 32 | (define-splicing-syntax-class constructor-keyword 33 | #:attributes (constructor) 34 | (pattern (~seq #:constructor constructor:id)) 35 | (pattern (~seq) #:with constructor (generate-temporary #'?constfn))) 36 | 37 | (define-splicing-syntax-class persistent-keyword 38 | #:attributes (persistent?) 39 | (pattern (~seq (~and #:persistent persistent?:keyword))) 40 | (pattern (~seq) #:with persistent? #'#f)) 41 | 42 | (define-splicing-syntax-class reification-keyword 43 | #:attributes (reified) 44 | (pattern (~seq #:reified) 45 | #:with reified #'#t) 46 | (pattern (~seq #:reification-function _reify-expr:expr) 47 | #:with reified #'(#f _reify-expr)) 48 | (pattern (~seq #:reify reify-expr:expr) 49 | #:with reified #'(#t reify-expr)) 50 | (pattern (~seq) #:with reified #'#f)) 51 | 52 | (define-splicing-syntax-class unique-keyword 53 | #:attributes (unique) 54 | (pattern (~seq #:unique) 55 | #:with unique #'#t) 56 | (pattern (~seq) #:with unique #'#f)) 57 | 58 | ) 59 | -------------------------------------------------------------------------------- /cKanren/src/triggers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (for-syntax syntax/parse racket/syntax "syntax-classes.rkt") 4 | "syntax-classes.rkt" 5 | "constraints.rkt" 6 | "events.rkt" 7 | "mk-structs.rkt") 8 | 9 | (require (rename-in (only-in racket filter) [filter ls:filter])) 10 | 11 | (provide (struct-out trigger) 12 | define-trigger) 13 | 14 | ;; some predefined triggers 15 | (provide enter-scope 16 | leave-scope 17 | any-association-event 18 | any-enforce) 19 | 20 | (struct trigger (subs interp)) 21 | 22 | ;; TODO, weird scope of package (should be an error to try to use it 23 | ;; in event-names) 24 | (define-syntax (define-trigger stx) 25 | (syntax-parse stx 26 | [(define-trigger (name args ...) 27 | (~seq (~or (~once pkgkw:package-keyword)) 28 | ...) 29 | [(event-name:id event-arg ...) 30 | (~optional ((~literal =>) abort) 31 | #:defaults ([abort (generate-temporary #'?abort)])) 32 | answer answer* ...] 33 | ...) 34 | (define/with-syntax (a [s c e]) #'pkgkw.package) 35 | (define/with-syntax subs 36 | #'(match-lambda [(struct event-name _) #t] ... [_ #f])) 37 | (define/with-syntax interp 38 | #'(lambda (args ...) 39 | (lambda@ (a [s c q t e]) 40 | (match-lambda 41 | [(event-name event-arg ...) 42 | (=> abort) 43 | (let ([result (let () answer answer* ...)]) 44 | (list result))] 45 | ... 46 | [_ #f])))) 47 | #'(define name (trigger subs interp))])) 48 | 49 | (define-trigger (enter-scope x) 50 | [(enter-scope-event y) 51 | (=> abort) (unless (or (not x) (eq? x y)) (abort)) y]) 52 | 53 | (define-trigger (leave-scope x) 54 | [(leave-scope-event y) 55 | (=> abort) (unless (or (not x) (eq? x y)) (abort)) y]) 56 | 57 | (define-trigger (any-association-event x) 58 | [(add-substitution-prefix-event p) 59 | (=> abort) 60 | (define (assoc-contains-var? u/v) 61 | (or (eq? x (car u/v)) (memq x (filter*/var? (cdr u/v))))) 62 | (cond 63 | [(ls:filter assoc-contains-var? p) 64 | => (lambda (p) (when (null? p) (abort)) p)] 65 | [else (abort)])]) 66 | 67 | (define-trigger (any-enforce ls) 68 | [(enforce-in-event ls^) 69 | (=> abort) 70 | (unless (ormap (curryr memq ls) ls^) (abort))] 71 | [(enforce-out-event ls^) 72 | (=> abort) 73 | (when (ormap (curryr memq ls) ls^) (abort))]) 74 | -------------------------------------------------------------------------------- /cKanren/src/variables.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/generic (for-syntax syntax/parse racket/syntax)) 4 | (require "helpers.rkt") 5 | 6 | (provide cvar? var var? var-x define-cvar-type define-var-type reify-n reified-var?) 7 | 8 | ;; normal miniKanren vars are actually an instance of a more general 9 | ;; "constrained var", or cvar for short. 10 | (struct cvar (str x) 11 | #:methods gen:custom-write 12 | [(define (write-proc . args) (apply write-cvar args))]) 13 | 14 | ;; defines a normal miniKanren var as a cvar that is printed with "_" 15 | (struct -var cvar ()) 16 | (define (var x) (-var "_" x)) 17 | (define (var? x) (-var? x)) 18 | (define var-x cvar-x) 19 | 20 | (define-syntax (define-cvar-type stx) 21 | (syntax-parse stx 22 | [(define-cvar-type name str rest ...) 23 | (define/with-syntax name? 24 | (format-id #'name "~a?" (syntax-e #'name))) 25 | #'(begin 26 | (struct -name cvar () rest ...) 27 | (define (name x) (-name str x)) 28 | (define name? -name?))])) 29 | 30 | (define-syntax (define-var-type stx) 31 | (syntax-parse stx 32 | [(define-var-type name str rest ...) 33 | (define/with-syntax name? 34 | (format-id #'name "~a?" (syntax-e #'name))) 35 | #'(begin 36 | (struct -name -var () rest ...) 37 | (define (name x) (-name str x)) 38 | (define name? -name?))])) 39 | 40 | ;; write-var controls how variables are displayed 41 | (define (write-cvar var port mode) 42 | ((parse-mode mode) (format "#~a(~s)" (cvar-str var) (cvar-x var)) port)) 43 | 44 | (define (reified-var? v) 45 | (and (symbol? v) 46 | (match (string->list (symbol->string v)) 47 | [(list #\_ #\. n) (number? n)] 48 | [else #f]))) 49 | 50 | (define (reify-n cvar n) 51 | (string->symbol (format "~a.~a" (cvar-str cvar) (number->string n)))) 52 | 53 | -------------------------------------------------------------------------------- /cKanren/testall.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "tests/absento.rkt" 5 | ;; "tests/ak.rkt" 6 | ;; "tests/comp.rkt" 7 | ;; "tests/fd.rkt" 8 | ;; "tests/framework.rkt" 9 | ;; "tests/infer.rkt" 10 | ;; "tests/interp.rkt" 11 | ;; "tests/mk-struct.rkt" 12 | ;; "tests/mk.rkt" 13 | "tests/neq.rkt" 14 | "tests/numbero.rkt" 15 | ;; "tests/no-closure.rkt" 16 | ;; "tests/quines.rkt" 17 | ;; "tests/sets.rkt" 18 | "tests/symbolo-numbero.rkt" 19 | "tests/symbolo.rkt" 20 | "tests/tree-unify.rkt" 21 | ) 22 | 23 | (define (run-all) 24 | (test-tree-unify) 25 | ;; (test-mk) 26 | ;; 27 | (test-absento) 28 | ;; (test-ak) 29 | ;; (test-fd) 30 | ;; (test-infer) 31 | ;; (test-interp) 32 | ;; (test-mk-struct) 33 | (test-neq) 34 | (test-number) 35 | ;; (test-no-closure) 36 | ;; (test-quines) 37 | ;; (test-sets) 38 | (test-symbol) 39 | (test-symbol-number) 40 | ;; (test-comp) 41 | ) 42 | 43 | (define (run-all-long) 44 | ;; (test-mk-long) 45 | ;; 46 | ;; (test-absento-long) 47 | ;; (test-ak-long) 48 | ;; (test-fd-long) 49 | ;; (test-infer-long) 50 | ;; (test-interp-long) 51 | ;; (test-mk-struct-long) 52 | ;; (test-neq-long) 53 | ;; (test-number-long) 54 | ;; (test-no-closure-long) 55 | ;; (test-sets-long) 56 | ;; (test-symbol-long) 57 | ;; (test-symbol-number-long) 58 | ;; (test-comp-long) 59 | ;; 60 | ;; (test-quines-long) 61 | (void) 62 | ) 63 | 64 | (module+ main (run-all)) 65 | 66 | (module+ test (run-all-long)) 67 | 68 | 69 | -------------------------------------------------------------------------------- /cKanren/tester.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "src/errors.rkt") 4 | (provide test 5 | (rename-out [test test-check]) 6 | test-divergence 7 | test-disable 8 | test-any-order 9 | test-highlight) 10 | 11 | (define max-ticks 10000000) 12 | 13 | (define-syntax (test x) 14 | (define (test-syntax te er) 15 | (define new-te 16 | (quasisyntax/loc x 17 | (with-handlers 18 | ([(lambda (x) #t) 19 | (lambda (e) 20 | (cond 21 | [(format-source #,(build-srcloc-stx x)) 22 | => (lambda (loc) (printf "encountered exception while running ~a\n" loc))]) 23 | (raise e))]) 24 | #,te))) 25 | (quasisyntax/loc x 26 | (let ([expected #,er] [produced #,new-te]) 27 | (cond 28 | [(equal? expected produced) (void)] 29 | [else 30 | (make-error #,(build-srcloc-stx x) 31 | (string-append 32 | "error while running tests\n" 33 | "expression: ~a~%expected: ~a~%computed: ~a~%") 34 | '#,te expected produced)])))) 35 | (syntax-case x () 36 | ((_ title tested-expression expected-result) 37 | (quasisyntax/loc x 38 | (begin 39 | (printf "warning: depricated testing format in ~a\n" title) 40 | #,(test-syntax #'tested-expression #'expected-result)))) 41 | ((_ tested-expression expected-result) 42 | (quasisyntax/loc x 43 | #,(test-syntax #'tested-expression #'expected-result))))) 44 | 45 | (define-syntax (test-highlight x) 46 | (syntax-case x () 47 | [(k stuff ...) 48 | (syntax/loc x 49 | (begin (printf (make-string 80 #\=)) 50 | (newline) 51 | (test stuff ...) 52 | (printf (make-string 80 #\=)) 53 | (newline)))])) 54 | 55 | (define (make-error src msg . exprs) 56 | (cond 57 | [(format-source src) 58 | => (lambda (loc) (apply error loc msg exprs))] 59 | [else (apply error 'test msg exprs)])) 60 | 61 | (define-syntax test-divergence 62 | (syntax-rules () 63 | ((_ title tested-expression) 64 | (begin 65 | (printf "testing ~a (engine with ~s ticks fuel)\n" title max-ticks) 66 | (let ((eng (make-engine (lambda () tested-expression)))) 67 | (eng max-ticks 68 | (lambda (t v) 69 | (error 'test-divergence 70 | "infinite loop returned ~s after ~s ticks" 71 | v (- max-ticks t))) 72 | (lambda (e^) (void)))))))) 73 | 74 | (define-syntax test-disable 75 | (syntax-rules () 76 | ((_ title tested-expression expected-result) 77 | (printf "disable testing ~s\n" title)))) 78 | 79 | (define-syntax (test-any-order x) 80 | (define (test-syntax te er) 81 | (quasisyntax/loc x 82 | (let ([expected #,er] [produced #,te]) 83 | (cond 84 | [(and (= (length expected) 85 | (length produced)) 86 | (for/and 87 | ([e expected]) 88 | (member e produced))) 89 | (void)] 90 | [else 91 | (make-error #,(build-srcloc-stx x) 92 | (string-append 93 | "error while running tests\n" 94 | "expression: ~a~%expected: ~a~%computed: ~a~%") 95 | '#,te expected produced)])))) 96 | (syntax-case x () 97 | ((_ title tested-expression expected-result) 98 | (quasisyntax/loc x 99 | (begin 100 | (printf "testing ~a\n" title) 101 | #,(test-syntax #'tested-expression #'expected-result)))) 102 | ((_ tested-expression expected-result) 103 | (quasisyntax/loc x 104 | #,(test-syntax #'tested-expression #'expected-result))))) 105 | -------------------------------------------------------------------------------- /cKanren/tests/comp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../unstable/fd.rkt" 6 | "../neq.rkt" 7 | "../tree-unify.rkt" 8 | "../tester.rkt") 9 | 10 | (provide test-comp test-comp-long) 11 | 12 | ;; (define n-queenso 13 | ;; (lambda (q n) 14 | ;; (let loop ((i n) (l '())) 15 | ;; (cond 16 | ;; ((zero? i) 17 | ;; (conj 18 | ;; (== q l) 19 | ;; (distinctfd l) 20 | ;; (diagonalso n l))) 21 | ;; (else 22 | ;; (fresh (x) 23 | ;; (infd x (range 1 n)) 24 | ;; (loop (- i 1) (cons x l)))))))) 25 | ;; 26 | ;; (define diagonalso 27 | ;; (lambda (n l) 28 | ;; (let loop ((r l) (s (cdr l)) (i 0) (j 1)) 29 | ;; (cond 30 | ;; ((or (null? r) (null? (cdr r))) succeed) 31 | ;; ((null? s) (loop (cdr r) (cddr r) (+ i 1) (+ i 2))) 32 | ;; (else 33 | ;; (let ((qi (car r)) (qj (car s))) 34 | ;; (conj 35 | ;; (diago qi qj (- j i) (range 0 (* 2 n))) 36 | ;; (loop r (cdr s) i (+ j 1))))))))) 37 | ;; 38 | ;; (define diago 39 | ;; (lambda (qi qj d rng) 40 | ;; (fresh (si sj) 41 | ;; (infd si sj rng) 42 | ;; (=/=fd qi sj) 43 | ;; (plusfd qi d si) 44 | ;; (=/=fd qj si) 45 | ;; (plusfd qj d sj)))) 46 | ;; 47 | ;; (define distincto 48 | ;; (lambda (l) 49 | ;; (conde 50 | ;; ((== l '())) 51 | ;; ((fresh (a) (== l `(,a)))) 52 | ;; ((fresh (a ad dd) 53 | ;; (== l `(,a ,ad . ,dd)) 54 | ;; (=/= a ad) 55 | ;; (distincto `(,a . ,dd)) 56 | ;; (distincto `(,ad . ,dd))))))) 57 | ;; 58 | (define (test-comp) 59 | ;; 60 | ;; (test-check "Distinct Queens 2" 61 | ;; (let ((answers (run* (q) (n-queenso q 4)))) 62 | ;; (run* (q) (distincto answers))) 63 | ;; '(_.0)) 64 | ;; 65 | ;; (test-check "infd/Distinct 1" 66 | ;; (run* (q) (infd q '(2 3 4)) (distincto `(a 3 ,q))) 67 | ;; '(2 4)) 68 | (void)) 69 | 70 | (define (test-comp-long) 71 | ;; (test-comp) 72 | ;; 73 | ;; (test-check "Distinct Queens 1" 74 | ;; (run* (q) 75 | ;; (fresh (x) 76 | ;; (n-queenso x 8) 77 | ;; (distincto x))) 78 | ;; '(_.0)) 79 | (void)) 80 | 81 | (module+ main 82 | (test-comp-long)) 83 | 84 | -------------------------------------------------------------------------------- /cKanren/tests/fd.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../tree-unify.rkt" 6 | "../unstable/fd.rkt" 7 | "../tester.rkt") 8 | 9 | (provide test-fd test-fd-long) 10 | 11 | ;; (define add-digitso 12 | ;; (lambda (augend addend carry-in carry digit) 13 | ;; (fresh (partial-sum sum) 14 | ;; (infd partial-sum (range 0 18)) 15 | ;; (infd sum (range 0 19)) 16 | ;; (plusfd augend addend partial-sum) 17 | ;; (plusfd partial-sum carry-in sum) 18 | ;; (conde 19 | ;; (( ,t-x ,t-e) t) 22 | (!- e `((,x . ,t-x) . ,env) t-e))] 23 | [(fresh (rator rand t-x) 24 | (== `(,rator ,rand) exp) 25 | (!- rator env `(-> ,t-x ,t)) 26 | (!- rand env t-x))]))) 27 | 28 | (define lookupo 29 | (lambda (x env t) 30 | (fresh (rest y v) 31 | (== `((,y . ,v) . ,rest) env) 32 | (conde 33 | ((== y x) (== v t)) 34 | ((=/= y x) (lookupo x rest t)))))) 35 | 36 | (define not-in-envo 37 | (lambda (x env) 38 | (conde 39 | ((== '() env)) 40 | ((fresh (y v rest) 41 | (== `((,y . ,v) . ,rest) env) 42 | (=/= y x) 43 | (not-in-envo x rest)))))) 44 | 45 | (test-check "types" 46 | (run 10 (q) (fresh (t exp) (!- exp '() t) (== `(,exp => ,t) q))) 47 | '((((lambda (_.0) _.0) => (-> _.1 _.1)) (sym _.0)) 48 | (((lambda (_.0) (lambda (_.1) _.1)) => (-> _.2 (-> _.3 _.3))) (=/= ((_.0 lambda))) (sym _.0 _.1)) 49 | (((lambda (_.0) (lambda (_.1) _.0)) => (-> _.2 (-> _.3 _.2))) (=/= ((_.0 _.1)) ((_.0 lambda))) (sym _.0 _.1)) 50 | ((((lambda (_.0) _.0) (lambda (_.1) _.1)) => (-> _.2 _.2)) (sym _.0 _.1)) 51 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.2))) => (-> _.3 (-> _.4 (-> _.5 _.5)))) (=/= ((_.0 lambda)) ((_.1 lambda))) (sym _.0 _.1 _.2)) 52 | (((lambda (_.0) (_.0 (lambda (_.1) _.1))) => (-> (-> (-> _.2 _.2) _.3) _.3)) (=/= ((_.0 lambda))) (sym _.0 _.1)) 53 | ((((lambda (_.0) _.0) (lambda (_.1) (lambda (_.2) _.2))) => (-> _.3 (-> _.4 _.4))) (=/= ((_.1 lambda))) (sym _.0 _.1 _.2)) 54 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.1))) => (-> _.3 (-> _.4 (-> _.5 _.4)))) (=/= ((_.0 lambda)) ((_.1 _.2)) ((_.1 lambda))) (sym _.0 _.1 _.2)) 55 | (((lambda (_.0) ((lambda (_.1) _.1) _.0)) => (-> _.2 _.2)) (=/= ((_.0 lambda))) (sym _.0 _.1)) 56 | ((((lambda (_.0) (lambda (_.1) _.1)) (lambda (_.2) _.2)) => (-> _.3 _.3)) (=/= ((_.0 lambda))) (sym _.0 _.1 _.2)))) 57 | 58 | ) 59 | 60 | (define (test-infer-long) 61 | (test-infer)) 62 | 63 | (module+ main 64 | (test-infer-long)) 65 | 66 | -------------------------------------------------------------------------------- /cKanren/tests/interp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../tree-unify.rkt" 6 | "../neq.rkt" 7 | "../absento.rkt" 8 | "../attributes.rkt" 9 | "../tester.rkt") 10 | (provide test-interp test-interp-long) 11 | 12 | (define (test-interp) 13 | (define not-in-envo 14 | (lambda (x env) 15 | (conde 16 | ((== '() env)) 17 | ((fresh (y v rest) 18 | (== `((,y . ,v) . ,rest) env) 19 | (=/= y x) 20 | (not-in-envo x rest)))))) 21 | 22 | (define lookupo-old 23 | (lambda (x env t) 24 | (conde 25 | ((fresh (y v rest) 26 | (== `((,y . ,v) . ,rest) env) (== y x) 27 | (== v t))) 28 | ((fresh (y v rest) 29 | (== `((,y . ,v) . ,rest) env) (=/= y x) 30 | (lookupo-old x rest t)))))) 31 | 32 | (define eval-expo-old 33 | (lambda (exp env val) 34 | (conde 35 | ((fresh (rator rand x body env^ a) 36 | (== `(,rator ,rand) exp) 37 | (eval-expo-old rator env `(closure ,x ,body ,env^)) 38 | (eval-expo-old rand env a) 39 | (eval-expo-old body `((,x . ,a) . ,env^) val))) 40 | ((fresh (x body) 41 | (== `(lambda (,x) ,body) exp) 42 | (symbol x) 43 | (== `(closure ,x ,body ,env) val) 44 | (not-in-envo 'lambda env))) 45 | ((symbol exp) 46 | (lookupo-old exp env val))))) 47 | 48 | (test-check "running backwards" 49 | (run 5 (q) (eval-expo-old q '() '(closure y x ((x . (closure z z ())))))) 50 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 51 | (((lambda (x) ((lambda (_.0) _.0) (lambda (y) x))) (lambda (z) z)) (sym _.0)) 52 | (((lambda (_.0) _.0) ((lambda (x) (lambda (y) x)) (lambda (z) z))) (sym _.0)) 53 | (((lambda (x) (lambda (y) x)) ((lambda (_.0) _.0) (lambda (z) z))) (sym _.0)) 54 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)))) 55 | 56 | (define eval-expo 57 | (lambda (exp env val) 58 | (conde 59 | ((fresh (rator rand x body env^ a) 60 | (== `(,rator ,rand) exp) 61 | (eval-expo rator env `(closure ,x ,body ,env^)) 62 | (eval-expo rand env a) 63 | (eval-expo body `((,x . ,a) . ,env^) val))) 64 | ((fresh (x body) 65 | (== `(lambda (,x) ,body) exp) 66 | (symbol x) 67 | (== `(closure ,x ,body ,env) val) 68 | (not-in-envo 'lambda env))) 69 | ((symbol exp) (lookupo exp env val))))) 70 | 71 | (define lookupo 72 | (lambda (x env t) 73 | (fresh (rest y v) 74 | (== `((,y . ,v) . ,rest) env) 75 | (conde 76 | ((== y x) (== v t)) 77 | ((=/= y x) (lookupo x rest t)))))) 78 | 79 | (test-check "eval-exp-lc 1" 80 | (run* (q) (eval-expo '(((lambda (x) (lambda (y) x)) 81 | (lambda (z) z)) (lambda (a) a)) '() q)) 82 | '((closure z z ()))) 83 | 84 | (test-check "eval-exp-lc 2" 85 | (run* (q) (eval-expo '((lambda (x) (lambda (y) x)) (lambda (z) z)) '() q)) 86 | '((closure y x ((x . (closure z z ())))))) 87 | 88 | (test-check "running backwards" 89 | (run 5 (q) (eval-expo q '() '(closure y x ((x . (closure z z ())))))) 90 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 91 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 92 | (((lambda (x) (lambda (y) x)) ((lambda (_.0) _.0) (lambda (z) z))) (sym _.0)) 93 | (((lambda (_.0) _.0) ((lambda (x) (lambda (y) x)) (lambda (z) z))) (sym _.0)) 94 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) (lambda (z) z)) (sym _.0)))) 95 | 96 | (test-check "fully-running-backwards" 97 | (run 5 (q) 98 | (fresh (e v) 99 | (eval-expo e '() v) 100 | (== `(,e ==> ,v) q))) 101 | '((((lambda (_.0) _.1) 102 | ==> (closure _.0 _.1 ())) (sym _.0)) 103 | ((((lambda (_.0) _.0) (lambda (_.1) _.2)) 104 | ==> 105 | (closure _.1 _.2 ())) 106 | (sym _.0 _.1)) 107 | ((((lambda (_.0) (lambda (_.1) _.2)) (lambda (_.3) _.4)) 108 | ==> 109 | (closure _.1 _.2 ((_.0 . (closure _.3 _.4 ()))))) 110 | (=/= ((_.0 lambda))) 111 | (sym _.0 _.1 _.3)) 112 | ((((lambda (_.0) (_.0 _.0)) (lambda (_.1) _.1)) 113 | ==> 114 | (closure _.1 _.1 ())) 115 | (sym _.0 _.1)) 116 | ((((lambda (_.0) (_.0 _.0)) 117 | (lambda (_.1) (lambda (_.2) _.3))) 118 | ==> 119 | (closure _.2 _.3 ((_.1 . (closure _.1 (lambda (_.2) _.3) ()))))) 120 | (=/= ((_.1 lambda))) 121 | (sym _.0 _.1 _.2)))) 122 | ) 123 | 124 | (define (test-interp-long) 125 | (test-interp)) 126 | 127 | (module+ main 128 | (test-interp)) 129 | -------------------------------------------------------------------------------- /cKanren/tests/lazy-appendo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../tree-unify.rkt" 6 | "../attributes.rkt" 7 | "../neq.rkt" 8 | "../tester.rkt" 9 | (for-syntax "../ck.rkt")) 10 | 11 | ;; (search-strategy 'bfs) 12 | ;; (begin-for-syntax 13 | ;; (search-strategy 'dfs) 14 | ;;) 15 | 16 | (define ;;-lazy-goal 17 | (syms* t out) 18 | (conde 19 | [(== t '()) 20 | (== out '())] 21 | [(symbol t) 22 | (== out `(,t))] 23 | [(fresh (a d a^ d^) 24 | (appendo a^ d^ out) 25 | (syms* a a^) 26 | (syms* d d^) 27 | (== t `(,a . ,d)))])) 28 | 29 | (define ;;-lazy-goal 30 | (appendo ls1 ls2 out) 31 | (conde 32 | [(== ls1 '()) 33 | (== ls2 out)] 34 | [(fresh (a d res) 35 | (appendo d ls2 res) 36 | (== ls1 `(,a . , d)) 37 | (== out `(,a . ,res)))])) 38 | 39 | (module+ test 40 | (test "appendo" 41 | (run* (q) (appendo '(a b) '(c d) q)) 42 | '((a b c d))) 43 | 44 | (test "symb* 1" 45 | (run* (q) (syms* '(a) q)) 46 | '((a))) 47 | 48 | (test "symb* 2" 49 | (run* (q) (syms* '(a (b)) q)) 50 | '((a b))) 51 | 52 | (test "symb* 3" 53 | (run* (q) (syms* '((a (b) c)) q)) 54 | '((a b c)))) 55 | -------------------------------------------------------------------------------- /cKanren/tests/mk-struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/base 5 | "../ck.rkt" 6 | "../tree-unify.rkt" 7 | "../tester.rkt") 8 | 9 | (provide test-mk-struct test-mk-struct-long) 10 | 11 | (define (test-mk-struct) 12 | (test "sanity test 1" 13 | (run* (q) succeed) 14 | '(_.0)) 15 | 16 | (test "sanity test 2" 17 | (run* (q) (== 5 5)) 18 | '(_.0)) 19 | 20 | (test-check "1" 21 | (run* (q) 22 | (fresh (x y) 23 | (== q (vector x y)) 24 | (== y 2))) 25 | `(#(_.0 2))) 26 | 27 | (test-check "2" 28 | (run* (q) 29 | (fresh (x y) 30 | (== (vector x 2) (vector 1 y)) 31 | (== q `(,x ,y)))) 32 | `((1 2))) 33 | 34 | (test-check "3" 35 | (run* (q) 36 | (== (vector 1 2) (list 1 2))) 37 | `()) 38 | 39 | (struct my-struct (a) 40 | #:methods gen:mk-struct 41 | [(define (recur my k) (k (my-struct-a my) `())) 42 | (define (constructor my) (lambda (a d) (my-struct a))) 43 | (define (reify-mk-struct my r) 44 | `(my-struct ,(reify-term (my-struct-a my) r))) 45 | (define (override-occurs-check? my) #f)] 46 | #:methods gen:unifiable 47 | [(define (compatible? my x s c) 48 | (or (var? x) (my-struct? x))) 49 | (define (gen-unify my x p s c e) 50 | (cond 51 | [(var? x) (unify p (ext-s x my s) c e)] 52 | [else (unify-two (my-struct-a my) x p s c e)]))]) 53 | 54 | (struct my-other-struct my-struct (b) 55 | #:methods gen:mk-struct 56 | [(define (recur my k) (k (my-struct-a my) `(,(my-other-struct-b my)))) 57 | (define (constructor my) (lambda (a d) (my-other-struct a (car d)))) 58 | (define (reify-mk-struct my r) 59 | `(my-struct ,(reify-term (my-struct-a my) r))) 60 | (define (override-occurs-check? my) #f)] 61 | #:methods gen:unifiable 62 | [(define (compatible? my x s c) 63 | (or (var? x) (my-other-struct? x))) 64 | (define (gen-unify my x p s c e) 65 | (cond 66 | [(var? x) (unify p (ext-s x my s) c e)] 67 | [else 68 | (let ([my-a (my-struct-a my)] 69 | [x-a (my-struct-a x)] 70 | [my-b (my-other-struct-b my)] 71 | [x-b (my-other-struct-b x)]) 72 | (unify-two my-a x-a `((,my-b . ,x-b) . ,p) s c e))]))]) 73 | 74 | (test-check "4" (run* (q) (== q (my-struct 'x))) `((my-struct x))) 75 | (test-check "5" (run* (q) (== q (my-other-struct 'x 'y))) `((my-struct x))) 76 | 77 | (test-check "5.1" 78 | (run* (q) 79 | (fresh (x y) 80 | (== (my-other-struct x 2) 81 | (my-other-struct 1 y)) 82 | (== q `(,x ,y)))) 83 | `((1 2))) 84 | 85 | (test-check "6" 86 | (run* (q) (== (my-struct 'x) (my-other-struct 'x 'y))) 87 | `()) 88 | 89 | (test-check "7" 90 | (run* (q) (== (my-other-struct 'x 'y) (my-struct 'x))) 91 | `()) 92 | 93 | (void)) 94 | 95 | (define (test-mk-struct-long) 96 | (test-mk-struct)) 97 | 98 | (module+ main 99 | (test-mk-struct)) 100 | -------------------------------------------------------------------------------- /cKanren/tests/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../miniKanren.rkt" 5 | "../absento.rkt" 6 | "../attributes.rkt" 7 | "../neq.rkt" 8 | "../tester.rkt") 9 | (provide test-mk test-mk-long) 10 | 11 | (define number-primo 12 | (lambda (exp env val) 13 | (fresh (n) 14 | (== `(intexp ,n) exp) 15 | (== `(intval ,n) val) 16 | (not-in-envo 'numo env)))) 17 | 18 | (define sub1-primo 19 | (lambda (exp env val) 20 | (fresh (e n n-1) 21 | (== `(sub1 ,e) exp) 22 | (== `(intval ,n-1) val) 23 | (not-in-envo 'sub1 env) 24 | (eval-expo e env `(intval ,n)) 25 | (minuso n '(1) n-1)))) 26 | 27 | (define zero?-primo 28 | (lambda (exp env val) 29 | (fresh (e n) 30 | (== `(zero? ,e) exp) 31 | (conde 32 | ((zeroo n) (== #t val)) 33 | ((poso n) (== #f val))) 34 | (not-in-envo 'zero? env) 35 | (eval-expo e env `(intval ,n))))) 36 | 37 | (define *-primo 38 | (lambda (exp env val) 39 | (fresh (e1 e2 n1 n2 n3) 40 | (== `(* ,e1 ,e2) exp) 41 | (== `(intval ,n3) val) 42 | (not-in-envo '* env) 43 | (eval-expo e1 env `(intval ,n1)) 44 | (eval-expo e2 env `(intval ,n2)) 45 | (*o n1 n2 n3)))) 46 | 47 | (define if-primo 48 | (lambda (exp env val) 49 | (fresh (e1 e2 e3 t) 50 | (== `(if ,e1 ,e2 ,e3) exp) 51 | (not-in-envo 'if env) 52 | (eval-expo e1 env t) 53 | (conde 54 | ((== #t t) (eval-expo e2 env val)) 55 | ((== #f t) (eval-expo e3 env val)))))) 56 | 57 | (define boolean-primo 58 | (lambda (exp env val) 59 | (conde 60 | ((== #t exp) (== #t val)) 61 | ((== #f exp) (== #f val))))) 62 | 63 | (define eval-expo 64 | (lambda (exp env val) 65 | (conde 66 | ((boolean-primo exp env val)) 67 | ((number-primo exp env val)) 68 | ((sub1-primo exp env val)) 69 | ((zero?-primo exp env val)) 70 | ((*-primo exp env val)) 71 | ((if-primo exp env val)) 72 | ((symbol exp) (lookupo exp env val)) 73 | ((fresh (rator rand x body env^ a) 74 | (== `(,rator ,rand) exp) 75 | (eval-expo rator env `(closure ,x ,body ,env^)) 76 | (eval-expo rand env a) 77 | (eval-expo body `((,x . ,a) . ,env^) val))) 78 | ((fresh (x body) 79 | (== `(lambda (,x) ,body) exp) 80 | (symbol x) 81 | (== `(closure ,x ,body ,env) val) 82 | (not-in-envo 'lambda env)))))) 83 | 84 | (define not-in-envo 85 | (lambda (x env) 86 | (conde 87 | ((fresh (y v rest) 88 | (== `((,y . ,v) . ,rest) env) 89 | (=/= y x) 90 | (not-in-envo x rest))) 91 | ((== '() env))))) 92 | 93 | (define lookupo 94 | (lambda (x env t) 95 | (fresh (rest y v) 96 | (== `((,y . ,v) . ,rest) env) 97 | (conde 98 | ((== y x) (== v t)) 99 | ((=/= y x) (lookupo x rest t)))))) 100 | 101 | 102 | (define (test-mk) 103 | (test-check "0" 104 | (run* (q) succeed) 105 | '(_.0)) 106 | 107 | (test-check "1" 108 | (run 1 (q) (== 5 q)) 109 | '(5)) 110 | 111 | (test-check "2" 112 | (run* (q) 113 | (conde 114 | [(== 5 q)] 115 | [(== 6 q)])) 116 | '(5 6)) 117 | 118 | (test-check "3" 119 | (run* (q) 120 | (fresh (a d) 121 | (conde 122 | [(== 5 a)] 123 | [(== 6 d)]) 124 | (== `(,a . ,d) q))) 125 | '((5 . _.0) (_.0 . 6))) 126 | 127 | (test-check "4" 128 | (run* (q) (appendo '(a b c) '(d e) q)) 129 | '((a b c d e))) 130 | 131 | (test-check "5" 132 | (run* (q) (appendo q '(d e) '(a b c d e))) 133 | '((a b c))) 134 | 135 | (test-check "6" 136 | (run* (q) (appendo '(a b c) q '(a b c d e))) 137 | '((d e))) 138 | 139 | (test-check "7" 140 | (run 5 (q) 141 | (fresh (l s out) 142 | (appendo l s out) 143 | (== `(,l ,s ,out) q))) 144 | '((() _.0 _.0) 145 | ((_.0) _.1 (_.0 . _.1)) 146 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 147 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 148 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)))) 149 | 150 | (test-check "test 1" 151 | (run* (q) (*o (build-num 2) (build-num 3) q)) 152 | '((0 1 1))) 153 | 154 | (test-check "test 2" 155 | (run* (q) 156 | (fresh (n m) 157 | (*o n m (build-num 6)) 158 | (== `(,n ,m) q))) 159 | '(((1) (0 1 1)) ((0 1 1) (1)) ((0 1) (1 1)) ((1 1) (0 1)))) 160 | 161 | (test-check "push-down problems 2" 162 | (run* (q) 163 | (fresh (x a d) 164 | (absento 'intval x) 165 | (== 'intval a) 166 | (== `(,a . ,d) x))) 167 | '()) 168 | 169 | (test-check "push-down problems 3" 170 | (run* (q) 171 | (fresh (x a d) 172 | (== `(,a . ,d) x) 173 | (absento 'intval x) 174 | (== 'intval a))) 175 | '()) 176 | 177 | (test-check "push-down problems 4" 178 | (run* (q) 179 | (fresh (x a d) 180 | (== `(,a . ,d) x) 181 | (== 'intval a) 182 | (absento 'intval x))) 183 | '()) 184 | 185 | (test-check "push-down problems 6" 186 | (run* (q) 187 | (fresh (x a d) 188 | (== 'intval a) 189 | (== `(,a . ,d) x) 190 | (absento 'intval x))) 191 | '()) 192 | 193 | (test-check "push-down problems 1" 194 | (run* (q) 195 | (fresh (x a d) 196 | (absento 'intval x) 197 | (== `(,a . ,d) x) 198 | (== 'intval a))) 199 | '()) 200 | 201 | (test-check "push-down problems 5" 202 | (run* (q) 203 | (fresh (x a d) 204 | (== 'intval a) 205 | (absento 'intval x) 206 | (== `(,a . ,d) x))) 207 | '()) 208 | 209 | (test-check "zero?" 210 | (run 1 (q) 211 | (eval-expo `(zero? (sub1 (intexp ,(build-num 1)))) '() q)) 212 | '(#t)) 213 | 214 | (test-check "*" 215 | (run 1 (q) 216 | (eval-expo `(* (intexp ,(build-num 3)) (intexp ,(build-num 2))) 217 | '() 218 | `(intval ,(build-num 6)))) 219 | '(_.0)) 220 | 221 | (test-check "sub1" 222 | (run 1 (q) 223 | (eval-expo q '() `(intval ,(build-num 6))) (== `(sub1 (intexp ,(build-num 7))) q)) 224 | '((sub1 (intexp (1 1 1))))) 225 | 226 | (test-check "sub1 bigger WAIT a minute" 227 | (run 1 (q) 228 | (eval-expo q '() `(intval ,(build-num 6))) 229 | (== `(sub1 (sub1 (intexp ,(build-num 8)))) q)) 230 | '((sub1 (sub1 (intexp (0 0 0 1)))))) 231 | 232 | (test-check "sub1 biggest WAIT a minute" 233 | (run 1 (q) 234 | (eval-expo q '() `(intval ,(build-num 6))) 235 | (== `(sub1 (sub1 (sub1 (intexp ,(build-num 9))))) q)) 236 | '((sub1 (sub1 (sub1 (intexp (1 0 0 1))))))) 237 | 238 | (test-check "lots of programs to make a 6" 239 | (run 12 (q) (eval-expo q '() `(intval ,(build-num 6)))) 240 | '((intexp (0 1 1)) 241 | (sub1 (intexp (1 1 1))) 242 | (* (intexp (1)) (intexp (0 1 1))) 243 | (* (intexp (0 1 1)) (intexp (1))) 244 | (if #t (intexp (0 1 1)) _.0) 245 | (* (intexp (0 1)) (intexp (1 1))) 246 | (if #f _.0 (intexp (0 1 1))) 247 | (sub1 (* (intexp (1)) (intexp (1 1 1)))) 248 | (sub1 (* (intexp (1 1 1)) (intexp (1)))) 249 | (* (intexp (1 1)) (intexp (0 1))) 250 | (sub1 (if #t (intexp (1 1 1)) _.0)) 251 | (((lambda (_.0) (intexp (0 1 1))) #t) (=/= ((_.0 numo))) (sym _.0))) 252 | #; 253 | '((intexp (0 1 1)) 254 | (sub1 (intexp (1 1 1))) 255 | (* (intexp (1)) (intexp (0 1 1))) 256 | (* (intexp (0 1 1)) (intexp (1))) 257 | (* (intexp (0 1)) (intexp (1 1))) 258 | (if #t (intexp (0 1 1)) _.0) 259 | (sub1 (sub1 (intexp (0 0 0 1)))) 260 | (* (intexp (1 1)) (intexp (0 1))) 261 | (sub1 (* (intexp (1)) (intexp (1 1 1)))) 262 | (if #f _.0 (intexp (0 1 1))) 263 | (sub1 (* (intexp (1 1 1)) (intexp (1)))) 264 | (((lambda (_.0) (intexp (0 1 1))) #t) (=/= ((_.0 numo))) (sym _.0)))) 265 | 266 | (define rel-fact5 267 | `((lambda (f) 268 | ((f f) (intexp ,(build-num 5)))) 269 | (lambda (f) 270 | (lambda (n) 271 | (if (zero? n) 272 | (intexp ,(build-num 1)) 273 | (* n ((f f) (sub1 n)))))))) 274 | 275 | (test-check "rel-fact5" 276 | (run* (q) (eval-expo rel-fact5 '() q)) 277 | `((intval ,(build-num 120)))) 278 | 279 | (test-check "rel-fact5-backwards" 280 | (run 1 (q) 281 | (eval-expo 282 | `((lambda (f) 283 | ((f ,q) (intexp ,(build-num 5)))) 284 | (lambda (f) 285 | (lambda (n) 286 | (if (zero? n) 287 | (intexp ,(build-num 1)) 288 | (* n ((f f) (sub1 n))))))) 289 | '() 290 | `(intval ,(build-num 120)))) 291 | `(f)) 292 | ) 293 | 294 | (define (test-mk-long) 295 | (test-mk)) 296 | 297 | (module+ main 298 | (test-mk-long)) 299 | 300 | -------------------------------------------------------------------------------- /cKanren/tests/neq.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../tester.rkt" 5 | "../ck.rkt" 6 | "../tree-unify.rkt" 7 | "../neq.rkt" 8 | "../matche.rkt" 9 | "../src/operators.rkt") 10 | 11 | (provide distincto rembero test-neq test-neq-long) 12 | 13 | (defmatche (distincto l) 14 | [[()]] 15 | [[(,a)]] 16 | [[(,a ,ad . ,dd)] 17 | (=/= a ad) 18 | (distincto `(,a . ,dd)) 19 | (distincto `(,ad . ,dd))]) 20 | 21 | (defmatche (rembero x ls out) 22 | [[,x () ()]] 23 | [[,x (,x . ,d) ,out] 24 | (rembero x d out)] 25 | [[,x (,a . ,d) ,out] 26 | (=/= a x) 27 | (fresh (res) 28 | (rembero x d res) 29 | (== `(,a . ,res) out))]) 30 | 31 | (define (test-neq) 32 | 33 | ;; SIMPLE 34 | 35 | (test (run* (q) (=/= 5 6)) '(_.0)) 36 | 37 | (test (run* (q) (=/= 3 3)) '()) 38 | 39 | (test (run* (q) (== q 3) (=/= 3 q)) 40 | '()) 41 | 42 | (test (run* (q) (=/= 3 q) (== q 3)) 43 | '()) 44 | 45 | (test (run* (x y) (== x y) (=/= x y)) 46 | '()) 47 | 48 | (test (run* (x y) (=/= x y) (== x y)) 49 | '()) 50 | 51 | (test (run* (q) (=/= q q)) 52 | '()) 53 | 54 | (test (run* (q) (fresh (a) (=/= a a))) 55 | '()) 56 | 57 | (test 58 | (run* (x y) 59 | (=/= x y) 60 | (== 3 x) 61 | (== 3 y)) 62 | '()) 63 | 64 | (test 65 | (run* (x y) 66 | (== 3 x) 67 | (=/= x y) 68 | (== 3 y)) 69 | '()) 70 | 71 | (test 72 | (run* (x y) 73 | (== 3 x) 74 | (== 3 y) 75 | (=/= x y)) 76 | '()) 77 | 78 | (test 79 | (run* (x y) 80 | (== 3 x) 81 | (== 3 y) 82 | (=/= y x)) 83 | '()) 84 | 85 | (test 86 | (run* (x y z) 87 | (== x y) 88 | (== y z) 89 | (=/= x 4) 90 | (== z (+ 2 2))) 91 | '()) 92 | 93 | (test 94 | (run* (x y z) 95 | (== x y) 96 | (== y z) 97 | (== z (+ 2 2)) 98 | (=/= x 4)) 99 | '()) 100 | 101 | (test 102 | (run* (x y z) 103 | (=/= x 4) 104 | (== y z) 105 | (== x y) 106 | (== z (+ 2 2))) 107 | '()) 108 | 109 | (test 110 | (run* (x y z) 111 | (=/= x y) 112 | (== x `(0 ,z 1)) 113 | (== y `(0 1 1)) 114 | (== z 1)) 115 | '()) 116 | 117 | (test 118 | (run* (x y z) 119 | (== z 1) 120 | (=/= x y) 121 | (== x `(0 ,z 1)) 122 | (== y `(0 1 1))) 123 | '()) 124 | 125 | (test 126 | (run* (x y z) 127 | (== z 1) 128 | (== x `(0 ,z 1)) 129 | (== y `(0 1 1)) 130 | (=/= x y)) 131 | '()) 132 | 133 | (test 134 | (run* (q) 135 | (fresh (x y z) 136 | (=/= x y) 137 | (== x `(0 ,z 1)) 138 | (== y `(0 1 1)) 139 | (== z 0))) 140 | '(_.0)) 141 | 142 | (test 143 | (run* (x y) 144 | (=/= `(,x 1) `(2 ,y)) 145 | (== x 2) 146 | (== y 1)) 147 | '()) 148 | 149 | (test 150 | (run* (a x z) 151 | (=/= a `(,x 1)) 152 | (== a `(,z 1)) 153 | (== x z)) 154 | '()) 155 | 156 | (test 157 | (run* (x y) 158 | (=/= `(,x 1) `(2 ,y)) 159 | (== x 2) 160 | (== y 1)) 161 | '()) 162 | 163 | (test 164 | (run* (q) 165 | (fresh (x y z) 166 | (== z 0) 167 | (=/= x y) 168 | (== x `(0 ,z 1)) 169 | (== y `(0 1 1)))) 170 | '(_.0)) 171 | 172 | (test 173 | (run* (q) 174 | (fresh (x y z) 175 | (== x `(0 ,z 1)) 176 | (== y `(0 1 1)) 177 | (=/= x y))) 178 | '(_.0)) 179 | 180 | (test 181 | (run* (q) 182 | (fresh (x y) 183 | (=/= `(,x 1) `(2 ,y)) 184 | (== x 2))) 185 | '(_.0)) 186 | 187 | (test 188 | (run* (q) 189 | (fresh (x y) 190 | (=/= `(,x 1) `(2 ,y)) 191 | (== y 1))) 192 | '(_.0)) 193 | 194 | (test 195 | (run* (x y z) 196 | (=/= `(,x 2 ,z) `(1 ,z 3)) 197 | (=/= `(,x 6 ,z) `(4 ,z 6)) 198 | (=/= `(,x ,y ,z) `(7 ,z 9)) 199 | (== x z)) 200 | '((_.0 _.1 _.0))) 201 | 202 | (test 203 | (run* (x y) 204 | (=/= `(,x 1) `(2 ,y)) 205 | (== x 2) 206 | (== y 9)) 207 | '((2 9))) 208 | 209 | (test 210 | (run* (q) 211 | (fresh (a) 212 | (== 3 a) 213 | (=/= a 4))) 214 | '(_.0)) 215 | 216 | ;; MEDIUM 217 | 218 | ;; these test reification 219 | (test 220 | (run* (q) (=/= q #f)) 221 | '((_.0 : (=/= ((_.0 . #f)))))) 222 | 223 | (test 224 | (run* (x y) (=/= x y)) 225 | '(((_.0 _.1) : (=/= ((_.0 . _.1)))))) 226 | 227 | ;; this tests the constraint-interaction 228 | (test 229 | (run* (q) 230 | (=/= q 5) 231 | (=/= 5 q)) 232 | '((_.0 : (=/= ((_.0 . 5)))))) 233 | 234 | (test 235 | (run* (x y) 236 | (=/= y x)) 237 | '(((_.0 _.1) : (=/= ((_.0 . _.1)))))) 238 | 239 | (test 240 | (run* (x y) 241 | (=/= x y) 242 | (=/= x y)) 243 | '(((_.0 _.1) : (=/= ((_.0 . _.1)))))) 244 | 245 | (test 246 | (run* (x y) 247 | (=/= x y) 248 | (=/= y x)) 249 | '(((_.0 _.1) : (=/= ((_.0 . _.1)))))) 250 | 251 | (test 252 | (run* (x y) 253 | (=/= `(,x 1) `(2 ,y))) 254 | '(((_.0 _.1) : (=/= ((_.0 . 2) (_.1 . 1)))))) 255 | 256 | (test 257 | (run* (q) 258 | (=/= 4 q) 259 | (=/= 3 q)) 260 | '((_.0 : (=/= ((_.0 . 3)) ((_.0 . 4)))))) 261 | 262 | (test 263 | (run* (q) (=/= q 5) (=/= q 5)) 264 | '((_.0 : (=/= ((_.0 . 5)))))) 265 | 266 | ;; HARD 267 | 268 | (test 269 | (run* (x y) 270 | (=/= `(,x 1) `(2 ,y)) 271 | (== x 2)) 272 | '(((2 _.0) : (=/= ((_.0 . 1)))))) 273 | 274 | (test 275 | (run* (q) 276 | (fresh (a x z) 277 | (=/= a `(,x 1)) 278 | (== a `(,z 1)) 279 | (== x 5) 280 | (== `(,x ,z) q))) 281 | '(((5 _.0) : (=/= ((_.0 . 5)))))) 282 | 283 | (test 284 | (run* (x y) 285 | (=/= `(,x ,y) `(5 6)) 286 | (=/= x 5)) 287 | '(((_.0 _.1) : (=/= ((_.0 . 5)))))) 288 | 289 | (test 290 | (run* (x y) 291 | (=/= x 5) 292 | (=/= `(,x ,y) `(5 6))) 293 | '(((_.0 _.1) : (=/= ((_.0 . 5)))))) 294 | 295 | (test 296 | (run* (x y) 297 | (=/= 5 x) 298 | (=/= `( ,y ,x) `(6 5))) 299 | '(((_.0 _.1) : (=/= ((_.0 . 5)))))) 300 | 301 | (test 302 | (run* (x) 303 | (fresh (y z) 304 | (=/= x `(,y 2)) 305 | (== x `(,z 2)))) 306 | '((_.0 2))) 307 | 308 | (test 309 | (run* (x) 310 | (fresh (y z) 311 | (=/= x `(,y 2)) 312 | (== x `((,z) 2)))) 313 | '(((_.0) 2))) 314 | 315 | (test 316 | (run* (x) 317 | (fresh (y z) 318 | (=/= x `((,y) 2)) 319 | (== x `(,z 2)))) 320 | '((_.0 2))) 321 | 322 | (test 323 | (run* (q) 324 | (distincto `(2 3 ,q))) 325 | '((_.0 : (=/= ((_.0 . 2)) ((_.0 . 3)))))) 326 | 327 | (test 328 | (run* (q) (rembero 'x '() q)) 329 | '(())) 330 | 331 | (test 332 | (run* (q) (rembero 'x '(x) '())) 333 | '(_.0)) 334 | 335 | (test 336 | (run* (q) (rembero 'a '(a b a c) q)) 337 | '((b c))) 338 | 339 | (test 340 | (run* (q) (rembero 'a '(a b c) '(a b c))) 341 | '()) 342 | 343 | (test 344 | (run* (w x y z) 345 | (=/= `(,w . ,x) `(,y . ,z))) 346 | '(((_.0 _.1 _.2 _.3) 347 | : 348 | (=/= ((_.0 . _.2) (_.1 . _.3)))))) 349 | 350 | (test 351 | (run* (w x y z) 352 | (=/= `(,w . ,x) `(,y . ,z)) 353 | (== w y)) 354 | '(((_.0 _.1 _.0 _.2) 355 | : 356 | (=/= ((_.1 . _.2)))))) 357 | ) 358 | 359 | (define (test-neq-long) 360 | (test-neq)) 361 | 362 | (module+ main 363 | (test-neq-long)) 364 | 365 | -------------------------------------------------------------------------------- /cKanren/tests/no-closure.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../absento.rkt" 6 | "../tree-unify.rkt" 7 | "../tester.rkt") 8 | (provide test-no-closure test-no-closure-long) 9 | 10 | (define (test-no-closure) 11 | (test-check "absento 'closure-1a" 12 | (run 1 (q) (absento 'closure q) (== q 'closure)) 13 | '()) 14 | 15 | (test-check "absento 'closure-1b" 16 | (run 1 (q) (== q 'closure) (absento 'closure q)) 17 | '()) 18 | 19 | (test-check "absento 'closure-2a" 20 | (run 1 (q) (fresh (a d) (== q 'closure) (absento 'closure q))) 21 | '()) 22 | 23 | (test-check "absento 'closure-2b" 24 | (run 1 (q) (fresh (a d) (absento 'closure q) (== q 'closure))) 25 | '()) 26 | 27 | (test-check "absento 'closure-3a" 28 | (run 1 (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q))) 29 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 30 | 31 | 32 | (test-check "absento 'closure-3b" 33 | (run 1 (q) (fresh (a d) (== `(,a . ,d) q) (absento 'closure q))) 34 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 35 | 36 | 37 | (test-check "absento 'closure-4a" 38 | (run 1 (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure a))) 39 | '()) 40 | 41 | (test-check "absento 'closure-4b" 42 | (run 1 (q) (fresh (a d) (absento 'closure q) (== 'closure a) (== `(,a . ,d) q))) 43 | '()) 44 | 45 | (test-check "absento 'closure-4c" 46 | (run 1 (q) (fresh (a d) (== 'closure a) (absento 'closure q) (== `(,a . ,d) q))) 47 | '()) 48 | 49 | (test-check "absento 'closure-4d" 50 | (run 1 (q) (fresh (a d) (== 'closure a) (== `(,a . ,d) q) (absento 'closure q))) 51 | '()) 52 | 53 | (test-check "absento 'closure-5a" 54 | (run 1 (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure d))) 55 | '()) 56 | 57 | (test-check "absento 'closure-5b" 58 | (run 1 (q) (fresh (a d) (absento 'closure q) (== 'closure d) (== `(,a . ,d) q))) 59 | '()) 60 | 61 | (test-check "absento 'closure-5c" 62 | (run 1 (q) (fresh (a d) (== 'closure d) (absento 'closure q) (== `(,a . ,d) q))) 63 | '()) 64 | 65 | (test-check "absento 'closure-5d" 66 | (run 1 (q) (fresh (a d) (== 'closure d) (== `(,a . ,d) q) (absento 'closure q))) 67 | '()) 68 | 69 | (test-check "absento 'closure-6" 70 | (run 1 (q) 71 | (== `(3 (closure x (x x) ((y . 7))) #t) q) 72 | (absento 'closure q)) 73 | '()) 74 | ) 75 | 76 | (define (test-no-closure-long) 77 | (test-no-closure)) 78 | 79 | (module+ main 80 | (test-no-closure-long)) 81 | -------------------------------------------------------------------------------- /cKanren/tests/nominal/alphaleantap.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | (rename-in "../../unstable/ak.rkt" [nominal-== ==]) 5 | "nnf.rkt" 6 | (only-in "../../ck.rkt" conde fresh project run)) 7 | (provide proveo do-prove-th A E) 8 | 9 | ;; substitution 10 | (define subst 11 | (lambda (fml env out) 12 | (conde 13 | ((fresh (l r) 14 | (== `(pos ,l) fml) 15 | (== `(pos ,r) out) 16 | (subst-fmlo l env r))) 17 | ((fresh (l r) 18 | (== `(neg ,l) fml) 19 | (== `(neg ,r) out) 20 | (subst-fmlo l env r)))))) 21 | 22 | (define subst-fmlo 23 | (lambda (fml env out) 24 | (conde 25 | ((fresh (a) 26 | (== `(var ,a) fml) 27 | (lookupo a env out))) 28 | ((fresh (a) 29 | (== `(sym ,a) fml) 30 | (== fml out))) 31 | ((fresh (f d r) 32 | (== `(app ,f . ,d) fml) 33 | (== `(app ,f . ,r) out) 34 | (subst-tm* d env r)))))) 35 | 36 | (define subst-tm* 37 | (lambda (tm* env out) 38 | (conde 39 | ((== '() tm*) (== '() out)) 40 | ((fresh (a d r1 r2) 41 | (== `(,a . ,d) tm*) 42 | (== `(,r1 . ,r2) out) 43 | (subst-fmlo a env r1) 44 | (subst-tm* d env r2)))))) 45 | 46 | (define lookupo 47 | (lambda (x env out) 48 | (fresh (a d va vd) 49 | (conde 50 | ((== `((,x . ,out) . ,d) env)) 51 | ((== `(,a . ,d) env) 52 | (lookupo x d out)))))) 53 | 54 | (define negateo 55 | (lambda (fml neg) 56 | (fresh (lit) 57 | (conde 58 | ((== `(pos ,lit) fml) 59 | (== `(neg ,lit) neg)) 60 | ((== `(neg ,lit) fml) 61 | (== `(pos ,lit) neg)))))) 62 | 63 | 64 | (define proveo 65 | (lambda (fml unexp lits env proof) 66 | (conde 67 | ((fresh (a b p1) 68 | (== `(and ,a ,b) fml) 69 | (== `(conj . ,p1) proof) 70 | (proveo a (cons b unexp) lits env p1))) 71 | ((fresh (a b p1 p2) 72 | (== `(or ,a ,b) fml) 73 | (== `(split ,p1 ,p2) proof) 74 | (proveo a unexp lits env p1) 75 | (proveo b unexp lits env p2))) 76 | ((fresh-nom (v) 77 | (fresh (x1 b unexp1 p1) 78 | (== `(forall ,(tie v b)) fml) 79 | (== `(univ . ,p1) proof) 80 | (appendo unexp (list fml) unexp1) 81 | (proveo b unexp1 lits 82 | `((,v . ,x1) . ,env) p1)))) 83 | ((fresh (lit new-lit) 84 | (== `(lit ,lit) fml) 85 | (subst lit env new-lit) 86 | (conde 87 | ((fresh (l rest neg p1) 88 | (== `(,l . ,rest) lits) 89 | (== `(close) proof) 90 | (negateo new-lit neg) 91 | (membero neg lits))) 92 | ((fresh (next unexp1 p1) 93 | (== `(,next . ,unexp1) unexp) 94 | (== `(savefml . ,p1) proof) 95 | (proveo next unexp1 96 | (cons new-lit lits) env p1))))))))) 97 | 98 | (define membero 99 | (lambda (x ls) 100 | (conde 101 | ((fresh (d) 102 | (==-check `(,x . ,d) ls))) 103 | ((fresh (a d) 104 | (== `(,a . ,d) ls) 105 | (membero x d)))))) 106 | 107 | (define appendo 108 | (lambda (l1 l2 l3) 109 | (conde 110 | ((== '() l1) (== l2 l3)) 111 | ((fresh (x l11 l31) 112 | (== l1 (cons x l11)) 113 | (== l3 (cons x l31)) 114 | (appendo l11 l2 l31)))))) 115 | 116 | (define (do-prove-th axioms theorem) 117 | (let* ((nf (prepare axioms theorem))) 118 | (let ((pr (run 1 (q) (proveo nf '() '() '() q)))) 119 | (when (null? pr) (error 'prove "failure!")) 120 | (car pr)))) 121 | 122 | 123 | 124 | -------------------------------------------------------------------------------- /cKanren/tests/nominal/nnf.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../../unstable/ak.rkt") 4 | (provide nnf prepare A E) 5 | 6 | ;; NNF taken from Oleg Kiselyov's translation of leanTAP 7 | ;; see http://kanren.sourceforge.net/ 8 | ;; this adaptation positions noms in the right places 9 | 10 | (define-syntax A 11 | (syntax-rules () 12 | ((A var body) `(forall var ,(lambda (var) `body))))) 13 | 14 | (define-syntax E 15 | (syntax-rules () 16 | ((E var body) `(ex var ,(lambda (var) `body))))) 17 | 18 | (define (show-formula fml) 19 | (cond 20 | ((not (pair? fml)) fml) 21 | ((eq? (car fml) 'var) fml) 22 | ((eq? (car fml) 'forall) (let ((var (cadr fml))) 23 | `(A ,var ,(show-formula ((caddr fml) var))))) 24 | ((eq? (car fml) 'ex) (let ((var (cadr fml))) 25 | `(E ,var ,(show-formula ((caddr fml) var))))) 26 | (else (cons (car fml) (map show-formula (cdr fml)))))) 27 | 28 | (define-syntax match-case-simple 29 | (syntax-rules () 30 | ((_ exp clause ...) 31 | (let ((val-to-match exp)) 32 | (match-case-simple* val-to-match clause ...))))) 33 | 34 | (define (match-failure val) 35 | (error 'match-failure "failed match ~s" val)) 36 | 37 | (define-syntax match-case-simple* 38 | (syntax-rules (else) 39 | ((_ val (else exp ...)) 40 | (let () exp ...)) 41 | ((_ val) 42 | (match-failure val)) 43 | ((_ val (pattern () exp ...) . clauses) 44 | (let ((fail (lambda () (match-case-simple* val . clauses)))) 45 | ;; note that match-pattern may do binding. Here, 46 | ;; other clauses are outside of these binding 47 | (match-pattern val pattern (let () exp ...) (fail)))) 48 | ((_ val (pattern guard exp ...) . clauses) 49 | (let ((fail (lambda () (match-case-simple* val . clauses)))) 50 | (match-pattern val pattern 51 | (if guard (let () exp ...) (fail)) 52 | (fail)))) 53 | )) 54 | 55 | 56 | ;; (match-pattern val pattern kt kf) 57 | (define-syntax match-pattern 58 | (syntax-rules (? quote unquote) 59 | ((_ val ? kt kf) kt) 60 | ((_ val () kt kf) 61 | (if (null? val) kt kf)) 62 | ((_ val (quote lit) kt kf) 63 | (if (equal? val (quote lit)) kt kf)) 64 | ((_ val (unquote var) kt kf) 65 | (let ((var val)) kt)) 66 | ((_ val (x . y) kt kf) 67 | (if (pair? val) 68 | (let ((valx (car val)) 69 | (valy (cdr val))) 70 | (match-pattern valx x 71 | (match-pattern valy y kt kf) 72 | kf)) 73 | kf)) 74 | ((_ val lit kt kf) 75 | (if (equal? val (quote lit)) kt kf)))) 76 | 77 | (define (nnf fml) 78 | (match-case-simple fml 79 | 80 | ;; trivial re-writing using the standard tautologies 81 | ((not (not ,a)) () 82 | (nnf a)) 83 | ((not (forall ,var ,gfml)) () 84 | (nnf `(ex ,var ,(lambda (x) `(not ,(gfml x)))))) 85 | ((not (ex ,var ,gfml)) () 86 | (nnf `(forall ,var ,(lambda (x) `(not ,(gfml x)))))) 87 | ((not (and . ,fmls)) () 88 | (nnf `(or ,@(map (lambda (x) `(not ,x)) fmls)))) 89 | ((not (or . ,fmls)) () 90 | (nnf `(and ,@(map (lambda (x) `(not ,x)) fmls)))) 91 | ((=> ,a ,b) () 92 | (nnf `(or (not ,a) ,b))) 93 | ((not (=> ,a ,b)) () 94 | (nnf `(and ,a (not ,b)))) 95 | ((<=> ,a ,b) () 96 | (nnf `(or (and ,a ,b) (and (not ,a) (not ,b))))) 97 | ((not (<=> ,a ,b)) () 98 | (nnf `(or (and (not ,a) ,b) (and ,a (not ,b))))) 99 | 100 | 101 | ;; propagate inside 102 | ((forall ,x ,gfml) () 103 | (let ((v (nom x))) 104 | `(forall ,(tie v (nnf (gfml `(var ,v))))))) 105 | ((and . ,fmls) () 106 | `(and ,@(map (lambda (x) (nnf x)) fmls))) 107 | ((or . ,fmls) () 108 | `(or ,@(map (lambda (x) (nnf x)) fmls))) 109 | 110 | ;; skolemization. See the paper 111 | ((ex ,v ,gfml) () 112 | (let* ((fvars (rem-dups (fv (show-formula `(ex ,v ,gfml))))) 113 | (fml-ex `(,(gensym) . ,fvars)) 114 | (fml-sk (gfml fml-ex))) 115 | (nnf fml-sk))) 116 | ((ex ? ,gfml) () 117 | ;; replace quantified var with a constant. We use `sk' for clarity 118 | (let* ((fml-ex `(sk ,(show-formula (gfml 'ex)))) 119 | (fml-sk (gfml fml-ex))) ;; replace qu. var. with skolem function 120 | (nnf fml-sk))) 121 | 122 | ;; handle literals 123 | ((not ,l) () `(lit (neg ,(handle-lit l)))) 124 | (else `(lit (pos ,(handle-lit fml)))))) 125 | 126 | (define handle-lit 127 | (lambda (lit) 128 | (match-case-simple lit 129 | [(var ,x) (nom? x) `(var ,x)] 130 | [,x (symbol? x) `(sym ,x)] 131 | [(,f . ,d) (symbol? f) `(app ,f . ,(map handle-lit d))]))) 132 | 133 | (define fv 134 | (lambda (fml) 135 | (match-case-simple fml 136 | [(var ,x) (nom? x) (list `(var ,x))] 137 | [(not ,x) () (fv x)] 138 | [(,op ,x ,y) (member op '(and or => <=>)) (append (fv x) (fv y))] 139 | [(forall ,x ,t) () (remq x (fv t))] 140 | [(exist ,x ,t) () (remq x (fv t))] 141 | [(,f . ,args) () (apply append (map fvt args))] 142 | [else '()]))) 143 | 144 | (define fvt 145 | (lambda (fml) 146 | (match-case-simple fml 147 | [(var ,x) (nom? x) (list `(var ,x))] 148 | [(,f . ,args) () (apply append (map fvt args))] 149 | [else '()]))) 150 | 151 | (define rem-dups 152 | (lambda (ls) 153 | (cond 154 | [(null? ls) '()] 155 | [(member (car ls) (cdr ls)) (rem-dups (cdr ls))] 156 | [else (cons (car ls) (rem-dups (cdr ls)))]))) 157 | 158 | 159 | (define prepare 160 | (lambda (axioms theorem) 161 | (let* ((neg-formula (if (null? axioms) 162 | `(not ,theorem) 163 | (build-and (cons `(not ,theorem) axioms)))) 164 | (nf (nnf neg-formula))) 165 | nf))) 166 | 167 | (define build-and 168 | (lambda (ax) 169 | (cond 170 | [(null? ax) '()] 171 | [(null? (cdr ax)) (car ax)] 172 | [else `(and ,(car ax) ,(build-and (cdr ax)))]))) 173 | 174 | 175 | -------------------------------------------------------------------------------- /cKanren/tests/numbero.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../attributes.rkt" 6 | "../tree-unify.rkt" 7 | "../neq.rkt" 8 | "../tester.rkt") 9 | 10 | (provide test-number test-number-long) 11 | 12 | (define (test-number) 13 | (test 14 | (run* (q) (number q)) 15 | '((_.0 : (number _.0)))) 16 | 17 | (test 18 | (run* (q) (number q) (== 5 q)) 19 | '(5)) 20 | 21 | (test 22 | (run* (q) (== 5 q) (number q)) 23 | '(5)) 24 | 25 | (test 26 | (run* (q) (== 'x q) (number q)) 27 | '()) 28 | 29 | (test 30 | (run* (q) (number q) (== 'x q)) 31 | '()) 32 | 33 | (test 34 | (run* (q) (number q) (== `(1 . 2) q)) 35 | '()) 36 | 37 | (test 38 | (run* (q) (== `(1 . 2) q) (number q)) 39 | '()) 40 | 41 | (test 42 | (run* (q) (fresh (x) (number x))) 43 | '(_.0)) 44 | 45 | (test 46 | (run* (q) (fresh (x) (number x))) 47 | '(_.0)) 48 | 49 | (test 50 | (run* (q) (fresh (x) (number x) (== x q))) 51 | '((_.0 : (number _.0)))) 52 | 53 | (test 54 | (run* (q) (fresh (x) (number q) (== x q) (number x))) 55 | '((_.0 : (number _.0)))) 56 | 57 | (test 58 | (run* (q) (fresh (x) (number q) (number x) (== x q))) 59 | '((_.0 : (number _.0)))) 60 | 61 | (test 62 | (run* (q) (fresh (x) (== x q) (number q) (number x))) 63 | '((_.0 : (number _.0)))) 64 | 65 | (test 66 | (run* (q) (fresh (x) (number q) (== 5 x))) 67 | '((_.0 : (number _.0)))) 68 | 69 | (test 70 | (run* (q) (fresh (x) (number q) (== 5 x) (== x q))) 71 | '(5)) 72 | 73 | (test 74 | (run* (q) (fresh (x) (== q x) (number q) (== 'y x))) 75 | '()) 76 | 77 | (test 78 | (run* (q) (number q) (=/= 'y q)) 79 | '((_.0 : (number _.0)))) 80 | 81 | (test 82 | (run* (q) (=/= 'y q) (number q)) 83 | '((_.0 : (number _.0)))) 84 | 85 | (test 86 | (run* (q) (number q) (=/= `(1 . 2) q)) 87 | '((_.0 : (number _.0)))) 88 | 89 | (test 90 | (run* (q) (number q) (=/= 5 q)) 91 | '((_.0 : (=/= ((_.0 . 5))) (number _.0)))) 92 | 93 | (test 94 | (run* (x y) 95 | (number x) 96 | (number y)) 97 | '(((_.0 _.1) : (number _.0 _.1)))) 98 | 99 | (test 100 | (run* (x y) 101 | (number x) 102 | (number x)) 103 | '(((_.0 _.1) : (number _.0)))) 104 | 105 | (test 106 | (run* (q) 107 | (fresh (w x y z) 108 | (=/= `(,w . ,x) `(,y . ,z)) 109 | (number w) 110 | (number z))) 111 | '(_.0)) 112 | 113 | (test 114 | (run* (w x y z) 115 | (=/= `(,w . ,x) `(,y . ,z)) 116 | (number w) 117 | (number z)) 118 | '(((_.0 _.1 _.2 _.3) 119 | : 120 | (=/= ((_.0 . _.2) (_.1 . _.3))) 121 | (number _.0 _.3)))) 122 | 123 | (test 124 | (run* (w x y z) 125 | (=/= `(,w . ,x) `(,y . ,z)) 126 | (number w) 127 | (number y)) 128 | '(((_.0 _.1 _.2 _.3) 129 | : 130 | (=/= ((_.0 . _.2) (_.1 . _.3))) 131 | (number _.0 _.2)))) 132 | 133 | (test 134 | (run* (w x y z) 135 | (=/= `(,w . ,x) `(,y . ,z)) 136 | (number w) 137 | (number y) 138 | (== w y)) 139 | '(((_.0 _.1 _.0 _.2) 140 | : 141 | (=/= ((_.1 . _.2))) 142 | (number _.0)))) 143 | 144 | (test 145 | (run* (w x) (=/= `(,w . ,x) `(a . b))) 146 | '(((_.0 _.1) : (=/= ((_.0 . a) (_.1 . b)))))) 147 | 148 | (test 149 | (run* (w x) 150 | (=/= `(,w . ,x) `(a . b)) 151 | (number w)) 152 | '(((_.0 _.1) : (number _.0)))) 153 | 154 | (test 155 | (run* (w x) 156 | (number w) 157 | (=/= `(,w . ,x) `(a . b))) 158 | '(((_.0 _.1) : (number _.0)))) 159 | 160 | (test 161 | (run* (w x) 162 | (number w) 163 | (=/= `(a . b) `(,w . ,x))) 164 | '(((_.0 _.1) : (number _.0)))) 165 | 166 | (test 167 | (run* (w x) 168 | (number w) 169 | (=/= `(a . ,x) `(,w . b))) 170 | '(((_.0 _.1) : (number _.0)))) 171 | 172 | (test 173 | (run* (w x) 174 | (number w) 175 | (=/= `(5 . ,x) `(,w . b))) 176 | '(((_.0 _.1) : (=/= ((_.0 . 5) (_.1 . b))) (number _.0)))) 177 | 178 | (test 179 | (run* (x y z a b) 180 | (number x) 181 | (number y) 182 | (number z) 183 | (number a) 184 | (number b) 185 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a))) 186 | '(((_.0 _.0 _.0 _.1 _.1) : (number _.0 _.1)))) 187 | 188 | (test 189 | (run* (x y z a b) 190 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 191 | (number x) 192 | (number a)) 193 | '(((_.0 _.0 _.0 _.1 _.1) : (number _.0 _.1)))) 194 | ) 195 | 196 | (define (test-number-long) 197 | (test-number)) 198 | 199 | (module+ main 200 | (test-number-long)) 201 | -------------------------------------------------------------------------------- /cKanren/tests/quines.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../absento.rkt" 6 | "../attributes.rkt" 7 | "../tree-unify.rkt" 8 | "../neq.rkt" 9 | "../tester.rkt" 10 | (for-syntax "../ck.rkt")) 11 | 12 | (provide test-quines test-quines-long) 13 | 14 | ;; (begin-for-syntax 15 | ;; (define strat 'dfs) 16 | ;; (search-strategy strat)) 17 | 18 | ;; (define-lazy-goal (eval-expo exp env val) 19 | (define (eval-expo exp env val) 20 | (conde 21 | ((fresh (v) 22 | (== `(quote ,v) exp) 23 | (not-in-envo 'quote env) 24 | (absento 'closure v) 25 | (== v val))) 26 | ((fresh (a*) 27 | (== `(list . ,a*) exp) 28 | (not-in-envo 'list env) 29 | (absento 'closure a*) 30 | (proper-listo a* env val))) 31 | ((symbol exp) (lookupo exp env val)) 32 | ((fresh (rator rand x body env^ a) 33 | (== `(,rator ,rand) exp) 34 | (eval-expo rator env `(closure ,x ,body ,env^)) 35 | (eval-expo rand env a) 36 | (eval-expo body `((,x . ,a) . ,env^) val))) 37 | ((fresh (x body) 38 | (== `(lambda (,x) ,body) exp) 39 | (symbol x) 40 | (not-in-envo 'lambda env) 41 | (== `(closure ,x ,body ,env) val))))) 42 | 43 | (define not-in-envo 44 | (lambda (x env) 45 | (conde 46 | ((fresh (y v rest) 47 | (== `((,y . ,v) . ,rest) env) 48 | (=/= y x) 49 | (not-in-envo x rest))) 50 | ((== '() env))))) 51 | 52 | ;; (define-lazy-goal proper-listo 53 | (define proper-listo 54 | (lambda (exp env val) 55 | (conde 56 | ((== '() exp) 57 | (== '() val)) 58 | ((fresh (a d t-a t-d) 59 | (== `(,t-a . ,t-d) val) 60 | (== `(,a . ,d) exp) 61 | (eval-expo a env t-a) 62 | (proper-listo d env t-d)))))) 63 | 64 | (define lookupo 65 | (lambda (x env t) 66 | (fresh (rest y v) 67 | (== `((,y . ,v) . ,rest) env) 68 | (conde 69 | ((== y x) (== v t)) 70 | ((=/= y x) (lookupo x rest t)))))) 71 | 72 | (define (test-quines) 73 | (test "1 quine" 74 | (time (run 1 (q) (eval-expo q '() q))) 75 | '((((lambda (_.0) (list _.0 (list 'quote _.0))) 76 | '(lambda (_.0) (list _.0 (list 'quote _.0)))) 77 | (=/= ((_.0 closure)) ((_.0 list)) ((_.0 quote))) 78 | (sym _.0)))) 79 | 80 | (test "2 quines" 81 | (time (length (run 2 (q) (eval-expo q '() q)))) 82 | 2) 83 | 84 | (test "3 quines" 85 | (time (length (run 3 (q) (eval-expo q '() q)))) 86 | 3)) 87 | 88 | (define (test-quines-long) 89 | (test-quines) 90 | 91 | (test-check "5 quines" 92 | (time (length (run 5 (q) (eval-expo q '() q)))) 93 | 5) 94 | 95 | (test-check "10 quines" 96 | (time (length (run 10 (q) (eval-expo q '() q)))) 97 | 10) 98 | 99 | (test-check "40 quines" 100 | (time (length (run 40 (q) (eval-expo q '() q)))) 101 | 40) 102 | 103 | (test-check "2 twines" 104 | (time (length (run 2 (x) (fresh (p q) 105 | (=/= p q) 106 | (eval-expo p '() q) 107 | (eval-expo q '() p) 108 | (== `(,p ,q) x))))) 109 | 2) 110 | 111 | (test-check "4 thrines" 112 | (time (length (run 4 (x) 113 | (fresh (p q r) 114 | (=/= p q) 115 | (=/= q r) 116 | (=/= r p) 117 | (eval-expo p '() q) 118 | (eval-expo q '() r) 119 | (eval-expo r '() p) 120 | (== `(,p ,q ,r) x))))) 121 | 4)) 122 | 123 | (module+ main 124 | (test-quines-long)) 125 | -------------------------------------------------------------------------------- /cKanren/tests/symbolo-numbero.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../tree-unify.rkt" 6 | "../attributes.rkt" 7 | "../neq.rkt" 8 | "../tester.rkt") 9 | 10 | (provide test-symbol-number 11 | test-symbol-number-long) 12 | 13 | (define (test-symbol-number) 14 | (test 15 | (run* (q) (symbol q) (number q)) 16 | '()) 17 | 18 | (test 19 | (run* (q) (number q) (symbol q)) 20 | '()) 21 | 22 | (test 23 | (run* (q) 24 | (fresh (x) 25 | (number x) 26 | (symbol x))) 27 | '()) 28 | 29 | (test 30 | (run* (q) 31 | (fresh (x) 32 | (symbol x) 33 | (number x))) 34 | '()) 35 | 36 | (test 37 | (run* (q) 38 | (number q) 39 | (fresh (x) 40 | (symbol x) 41 | (== x q))) 42 | '()) 43 | 44 | (test 45 | (run* (q) 46 | (symbol q) 47 | (fresh (x) 48 | (number x) 49 | (== x q))) 50 | '()) 51 | 52 | (test 53 | (run* (q) 54 | (fresh (x) 55 | (number x) 56 | (== x q)) 57 | (symbol q)) 58 | '()) 59 | 60 | (test 61 | (run* (q) 62 | (fresh (x) 63 | (symbol x) 64 | (== x q)) 65 | (number q)) 66 | '()) 67 | 68 | (test 69 | (run* (q) 70 | (fresh (x) 71 | (== x q) 72 | (symbol x)) 73 | (number q)) 74 | '()) 75 | 76 | (test 77 | (run* (q) 78 | (fresh (x) 79 | (== x q) 80 | (number x)) 81 | (symbol q)) 82 | '()) 83 | 84 | (test 85 | (run* (q) 86 | (symbol q) 87 | (fresh (x) 88 | (number x))) 89 | '((_.0 : (symbol _.0)))) 90 | 91 | (test 92 | (run* (q) 93 | (number q) 94 | (fresh (x) 95 | (symbol x))) 96 | '((_.0 : (number _.0)))) 97 | 98 | (test 99 | (run* (q) 100 | (fresh (x y) 101 | (symbol x) 102 | (== `(,x ,y) q))) 103 | '(((_.0 _.1) : (symbol _.0)))) 104 | 105 | (test 106 | (run* (q) 107 | (fresh (x y) 108 | (number x) 109 | (== `(,x ,y) q))) 110 | '(((_.0 _.1) : (number _.0)))) 111 | 112 | (test 113 | (run* (q) 114 | (fresh (x y) 115 | (number x) 116 | (symbol y) 117 | (== `(,x ,y) q))) 118 | '(((_.0 _.1) : (number _.0) (symbol _.1)))) 119 | 120 | (test 121 | (run* (q) 122 | (fresh (x y) 123 | (number x) 124 | (== `(,x ,y) q) 125 | (symbol y))) 126 | '(((_.0 _.1) : (number _.0) (symbol _.1)))) 127 | 128 | (test 129 | (run* (q) 130 | (fresh (x y) 131 | (== `(,x ,y) q) 132 | (number x) 133 | (symbol y))) 134 | '(((_.0 _.1) : (number _.0) (symbol _.1)))) 135 | 136 | (test 137 | (run* (q) 138 | (fresh (x y) 139 | (== `(,x ,y) q) 140 | (number x) 141 | (symbol y)) 142 | (fresh (w z) 143 | (== `(,w ,z) q))) 144 | '(((_.0 _.1) : (number _.0) (symbol _.1)))) 145 | 146 | (test 147 | (run* (q) 148 | (fresh (x y) 149 | (== `(,x ,y) q) 150 | (number x) 151 | (symbol y)) 152 | (fresh (w z) 153 | (== `(,w ,z) q) 154 | (== w 5))) 155 | '(((5 _.0) : (symbol _.0)))) 156 | 157 | (test 158 | (run* (q) 159 | (fresh (x y) 160 | (== `(,x ,y) q) 161 | (number x) 162 | (symbol y)) 163 | (fresh (w z) 164 | (== 'a z) 165 | (== `(,w ,z) q))) 166 | '(((_.0 a) : (number _.0)))) 167 | 168 | (test 169 | (run* (q) 170 | (fresh (x y) 171 | (== `(,x ,y) q) 172 | (number x) 173 | (symbol y)) 174 | (fresh (w z) 175 | (== `(,w ,z) q) 176 | (== 'a z))) 177 | '(((_.0 a) : (number _.0)))) 178 | 179 | (test 180 | (run* (q) 181 | (fresh (x y) 182 | (== `(,x ,y) q) 183 | (=/= `(5 a) q))) 184 | '(((_.0 _.1) : (=/= ((_.0 . 5) (_.1 . a)))))) 185 | 186 | (test 187 | (run* (q) 188 | (fresh (x y) 189 | (== `(,x ,y) q) 190 | (=/= `(5 a) q) 191 | (symbol x))) 192 | '(((_.0 _.1) : (symbol _.0)))) 193 | 194 | (test 195 | (run* (q) 196 | (fresh (x y) 197 | (== `(,x ,y) q) 198 | (symbol x) 199 | (=/= `(5 a) q))) 200 | '(((_.0 _.1) : (symbol _.0)))) 201 | 202 | (test 203 | (run* (q) 204 | (fresh (x y) 205 | (symbol x) 206 | (== `(,x ,y) q) 207 | (=/= `(5 a) q))) 208 | '(((_.0 _.1) : (symbol _.0)))) 209 | 210 | (test 211 | (run* (q) 212 | (fresh (x y) 213 | (=/= `(5 a) q) 214 | (symbol x) 215 | (== `(,x ,y) q))) 216 | '(((_.0 _.1) : (symbol _.0)))) 217 | 218 | (test 219 | (run* (q) 220 | (fresh (x y) 221 | (=/= `(5 a) q) 222 | (== `(,x ,y) q) 223 | (symbol x))) 224 | '(((_.0 _.1) : (symbol _.0)))) 225 | 226 | (test 227 | (run* (q) 228 | (fresh (x y) 229 | (== `(,x ,y) q) 230 | (=/= `(5 a) q) 231 | (number y))) 232 | '(((_.0 _.1) : (number _.1)))) 233 | 234 | (test 235 | (run* (q) 236 | (fresh (x y) 237 | (== `(,x ,y) q) 238 | (number y) 239 | (=/= `(5 a) q))) 240 | '(((_.0 _.1) : (number _.1)))) 241 | 242 | (test 243 | (run* (q) 244 | (fresh (x y) 245 | (number y) 246 | (== `(,x ,y) q) 247 | (=/= `(5 a) q))) 248 | '(((_.0 _.1) : (number _.1)))) 249 | 250 | (test 251 | (run* (q) 252 | (fresh (x y) 253 | (=/= `(5 a) q) 254 | (number y) 255 | (== `(,x ,y) q))) 256 | '(((_.0 _.1) : (number _.1)))) 257 | 258 | (test 259 | (run* (q) 260 | (fresh (x y) 261 | (=/= `(5 a) q) 262 | (== `(,x ,y) q) 263 | (number y))) 264 | '(((_.0 _.1) : (number _.1)))) 265 | 266 | (test 267 | (run* (q) 268 | (fresh (x y) 269 | (=/= `(,x ,y) q) 270 | (number x) 271 | (symbol y))) 272 | '(_.0)) 273 | 274 | (test 275 | (run* (q) 276 | (fresh (x y) 277 | (number x) 278 | (=/= `(,x ,y) q) 279 | (symbol y))) 280 | '(_.0)) 281 | 282 | (test 283 | (run* (q) 284 | (fresh (x y) 285 | (number x) 286 | (symbol y) 287 | (=/= `(,x ,y) q))) 288 | '(_.0)) 289 | ) 290 | 291 | (define (test-symbol-number-long) 292 | (test-symbol-number)) 293 | 294 | (module+ main 295 | (test-symbol-number-long)) 296 | 297 | -------------------------------------------------------------------------------- /cKanren/tests/symbolo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ck.rkt" 5 | "../tree-unify.rkt" 6 | "../attributes.rkt" 7 | "../neq.rkt" 8 | "../tester.rkt" 9 | "../src/operators.rkt") 10 | 11 | (provide test-symbol test-symbol-long) 12 | 13 | (define (test-symbol) 14 | 15 | (test 16 | (run* (q) (symbol q)) 17 | '((_.0 : (symbol _.0)))) 18 | 19 | (test 20 | (run* (q) (symbol q) (symbol q)) 21 | '((_.0 : (symbol _.0)))) 22 | 23 | (test 24 | (run* (x y) (symbol x) (symbol y)) 25 | '(((_.0 _.1) : (symbol _.0 _.1)))) 26 | 27 | (test 28 | (run* (q) (symbol q) (== 'x q)) 29 | '(x)) 30 | 31 | (test 32 | (run* (q) (== 'x q) (symbol q)) 33 | '(x)) 34 | 35 | (test 36 | (run* (q) (== 5 q) (symbol q)) 37 | '()) 38 | 39 | (test 40 | (run* (q) (symbol q) (== 5 q)) 41 | '()) 42 | 43 | (test 44 | (run* (q) (== `(1 . 2) q) (symbol q)) 45 | '()) 46 | 47 | (test 48 | (run* (q) (symbol q) (== `(1 . 2) q)) 49 | '()) 50 | 51 | (test 52 | (run* (q) (fresh (x) (symbol x))) 53 | '(_.0)) 54 | 55 | (test 56 | (run* (q) (fresh (x) (== x q) (symbol x))) 57 | '((_.0 : (symbol _.0)))) 58 | 59 | (test 60 | (run* (q) (fresh (x) (symbol x) (== x q))) 61 | '((_.0 : (symbol _.0)))) 62 | 63 | (test 64 | (run* (q) (fresh (x) (== x q) (symbol q) (symbol x))) 65 | '((_.0 : (symbol _.0)))) 66 | 67 | (test 68 | (run* (q) (fresh (x) (symbol q) (== x q) (symbol x))) 69 | '((_.0 : (symbol _.0)))) 70 | 71 | (test 72 | (run* (q) (fresh (x) (symbol q) (symbol x) (== x q))) 73 | '((_.0 : (symbol _.0)))) 74 | 75 | (test 76 | (run* (q) (fresh (x) (symbol q) (== 'y x))) 77 | '((_.0 : (symbol _.0)))) 78 | 79 | (test 80 | (run* (q) (fresh (x) (symbol q) (== 'y x) (== x q))) 81 | '(y)) 82 | 83 | (test 84 | (run* (q) (fresh (x) (== q x) (symbol q) (== 5 x))) 85 | '()) 86 | 87 | (test 88 | (run* (q) (symbol q) (=/= 5 q)) 89 | '((_.0 : (symbol _.0)))) 90 | 91 | (test 92 | (run* (q) (=/= 5 q) (symbol q)) 93 | '((_.0 : (symbol _.0)))) 94 | 95 | (test 96 | (run* (q) (symbol q) (=/= `(1 . 2) q)) 97 | '((_.0 : (symbol _.0)))) 98 | 99 | (test 100 | (run* (q) (symbol q) (=/= 'y q)) 101 | '((_.0 : (=/= ((_.0 . y))) (symbol _.0)))) 102 | 103 | (test 104 | (run* (x y) 105 | (symbol x) 106 | (symbol y)) 107 | '(((_.0 _.1) : (symbol _.0 _.1)))) 108 | 109 | (test 110 | (run* (w x y z) 111 | (=/= `(,w . ,x) `(,y . ,z)) 112 | (symbol z)) 113 | '(((_.0 _.1 _.2 _.3) 114 | : 115 | (=/= ((_.0 . _.2) (_.1 . _.3))) 116 | (symbol _.3)))) 117 | 118 | (test 119 | (run* (q) 120 | (fresh (w x y z) 121 | (=/= `(,w . ,x) `(,y . ,z)) 122 | (symbol w) 123 | (symbol z))) 124 | '(_.0)) 125 | 126 | (test 127 | (run* (w x y z) 128 | (=/= `(,w . ,x) `(,y . ,z)) 129 | (symbol w) 130 | (symbol z)) 131 | '(((_.0 _.1 _.2 _.3) 132 | : 133 | (=/= ((_.0 . _.2) (_.1 . _.3))) 134 | (symbol _.0 _.3)))) 135 | 136 | (test 137 | (run* (w x y z) 138 | (=/= `(,w . ,x) `(,y . ,z)) 139 | (symbol w) 140 | (symbol y)) 141 | '(((_.0 _.1 _.2 _.3) 142 | : 143 | (=/= ((_.0 . _.2) (_.1 . _.3))) 144 | (symbol _.0 _.2)))) 145 | 146 | (test 147 | (run* (w x y z) 148 | (=/= `(,w . ,x) `(,y . ,z)) 149 | (symbol w) 150 | (symbol y) 151 | (== w y)) 152 | '(((_.0 _.1 _.0 _.2) 153 | : 154 | (=/= ((_.1 . _.2))) 155 | (symbol _.0)))) 156 | 157 | (test 158 | (run* (w x) 159 | (=/= `(,w . ,x) `(5 . 6)) 160 | (symbol w)) 161 | '(((_.0 _.1) : (symbol _.0)))) 162 | 163 | (test 164 | (run* (w x) 165 | (symbol w) 166 | (=/= `(,w . ,x) `(5 . 6))) 167 | '(((_.0 _.1) : (symbol _.0)))) 168 | 169 | (test 170 | (run* (w x) 171 | (symbol w) 172 | (=/= `(5 . 6) `(,w . ,x))) 173 | '(((_.0 _.1) : (symbol _.0)))) 174 | 175 | (test 176 | (run* (w x) 177 | (symbol w) 178 | (=/= `(5 . ,x) `(,w . 6))) 179 | '(((_.0 _.1) : (symbol _.0)))) 180 | 181 | (test 182 | (run* (w x) 183 | (symbol w) 184 | (=/= `(z . ,x) `(,w . 6))) 185 | '(((_.0 _.1) : (=/= ((_.0 . z) (_.1 . 6))) (symbol _.0)))) 186 | 187 | (test 188 | (run* (w x y z) 189 | (== x 5) 190 | (=/= `(,w ,y) `(,x ,z)) 191 | (== w 5)) 192 | '(((5 5 _.0 _.1) : (=/= ((_.0 . _.1)))))) 193 | 194 | (test 195 | (run* (w x y z) 196 | (=/= `(,w ,y) `(,x ,z)) 197 | (== w 5) 198 | (== x 5)) 199 | '(((5 5 _.0 _.1) : (=/= ((_.0 . _.1)))))) 200 | 201 | (test 202 | (run* (w x y z) 203 | (== w 5) 204 | (=/= `(,w ,y) `(,x ,z)) 205 | (== x 5)) 206 | '(((5 5 _.0 _.1) : (=/= ((_.0 . _.1)))))) 207 | 208 | (test 209 | (run* (w x y z) 210 | (== w 5) 211 | (== x 5) 212 | (=/= `(,w ,y) `(,x ,z))) 213 | '(((5 5 _.0 _.1) : (=/= ((_.0 . _.1)))))) 214 | 215 | 216 | (test 217 | (run* (w x y z) 218 | (== x 'a) 219 | (=/= `(,w ,y) `(,x ,z)) 220 | (== w 'a)) 221 | '(((a a _.0 _.1) : (=/= ((_.0 . _.1)))))) 222 | 223 | (test 224 | (run* (w x y z) 225 | (=/= `(,w ,y) `(,x ,z)) 226 | (== w 'a) 227 | (== x 'a)) 228 | '(((a a _.0 _.1) : (=/= ((_.0 . _.1)))))) 229 | 230 | (test 231 | (run* (w x y z) 232 | (== w 'a) 233 | (=/= `(,w ,y) `(,x ,z)) 234 | (== x 'a)) 235 | '(((a a _.0 _.1) : (=/= ((_.0 . _.1)))))) 236 | 237 | (test 238 | (run* (w x y z) 239 | (== w 'a) 240 | (== x 'a) 241 | (=/= `(,w ,y) `(,x ,z))) 242 | '(((a a _.0 _.1) : (=/= ((_.0 . _.1)))))) 243 | ) 244 | 245 | (define (test-symbol-long) 246 | (test-symbol)) 247 | 248 | (module+ main 249 | (test-symbol-long)) 250 | 251 | -------------------------------------------------------------------------------- /cKanren/tests/tree-unify.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../ck.rkt" 4 | "../tester.rkt" 5 | "../tree-unify.rkt") 6 | 7 | (provide test-tree-unify) 8 | 9 | (define (test-tree-unify) 10 | (test (run* (q) (== 5 6)) '()) 11 | (test (run* (q) (== 5 5)) '(_.0)) 12 | 13 | (test (run 1 (q) (== q 5)) '(5)) 14 | (test (run* (q) (== q 5)) '(5)) 15 | 16 | (test (run* (q) (== q '(1 2))) 17 | '((1 2))) 18 | 19 | (test (run* (x y) (== `(,x 1) `(2 ,y))) 20 | '((2 1))) 21 | ) 22 | 23 | (module+ main 24 | (test-tree-unify)) 25 | -------------------------------------------------------------------------------- /cKanren/tree-unify.rkt: -------------------------------------------------------------------------------- 1 | #lang cKanren 2 | 3 | (require (except-in racket == string) racket/generic) 4 | 5 | (require cKanren/attributes 6 | cKanren/src/constraint-store 7 | cKanren/src/triggers 8 | cKanren/src/mk-structs 9 | (only-in cKanren/src/events 10 | add-substitution-prefix-event 11 | empty-event)) 12 | 13 | (provide == unify unify-two unify-walked unify-change) 14 | (provide gen:unifiable gen-unify compatible? unifiable?) 15 | 16 | ;; a generic that defines when things are unifiable! 17 | (define-generics unifiable 18 | (compatible? unifiable v s c e) 19 | (gen-unify unifiable v p s c e) 20 | #:defaults 21 | (;; vars are compatible with structs that it does not appear in, or 22 | ;; structs that override the occurs check (ex. sets). 23 | [var? 24 | (define (compatible? u v s c e) 25 | (and (check-attributes u v s c e) 26 | (cond 27 | [(mk-struct? v) 28 | (or (override-occurs-check? v) 29 | (not (occurs-check u v s)))] 30 | [else #t]))) 31 | (define (gen-unify u v p s c e) 32 | (cond 33 | [(var? v) (unify p (ext-s u v s) c e)] 34 | [else (unify-walked v u p s c e)]))] 35 | ;; anything that is a default mk-struct will unify just fine if 36 | ;; unified with something of the same type 37 | [default-mk-struct? 38 | (define (compatible? p v s c e) 39 | (or (var? v) (same-default-type? p v))) 40 | (define (gen-unify u v p s c e) 41 | (mk-struct-unify u v p s c e))] 42 | ;; mostly for constants: strings, numbers, booleans, etc. 43 | ;; they unify if they are eq? or equal? 44 | [(lambda (x) #t) 45 | (define (compatible? u v s c e) 46 | (or (var? v) (eq? u v) (equal? u v))) 47 | (define (gen-unify u v p s c e) 48 | (cond 49 | [(var? v) (unify p (ext-s v (walk* u s c e) s) c e)] 50 | [else (unify p s c e)]))])) 51 | 52 | (define (== u v) 53 | (transformer 54 | #:package (a [s c e]) 55 | (cond 56 | [(unify `((,u . ,v)) s c e) 57 | => (match-lambda 58 | [(cons s c) (update-package s c)])] 59 | [else fail]))) 60 | 61 | (define (unify p s c e) 62 | (cond 63 | [(null? p) (cons s c)] 64 | [else (unify-two (caar p) (cdar p) (cdr p) s c e)])) 65 | 66 | ;; unifies two things, u and v 67 | (define-syntax-rule (unify-two u v p s c e) 68 | (let ([u^ (walk u s c e)] [v^ (walk v s c e)]) 69 | (cond 70 | [(and (var? u^) (not (var? u^))) 71 | (unify-walked v^ u^ p s c e)] 72 | [else (unify-walked u^ v^ p s c e)]))) 73 | 74 | (define (unify-walked u v p s c e) 75 | (cond 76 | [(eq? u v) (unify p s c e)] 77 | [else 78 | (and (unifiable? u) 79 | (unifiable? v) 80 | (compatible? u v s c e) 81 | (compatible? v u s c e) 82 | (gen-unify u v p s c e))])) 83 | 84 | ;; unifies mk-structs that are the same type 85 | (define (mk-struct-unify u v p s c e) 86 | (cond 87 | [(var? v) (unify p (ext-s v (walk* u s c e) s) c e)] 88 | [else 89 | (recur u 90 | (lambda (ua ud) 91 | (recur v 92 | (lambda (va vd) 93 | (unify-two ua va `((,ud . ,vd) . ,p) s c e)))))])) 94 | 95 | (define (unify-new-prefix thing s c e) 96 | (match (unify (walk* thing s c e) s c e) 97 | [(cons s^ c^) 98 | (cons (prefix-s s s^) (prefix-c c c^))] 99 | [#f #f])) 100 | 101 | (define-trigger (unify-change thing) 102 | #:package (a [s c e]) 103 | [(add-substitution-prefix-event p) 104 | (=> abort) 105 | (unless (ormap (lambda (x) (memq (car x) (filter*/var? thing))) p) 106 | (abort)) 107 | (unify-new-prefix thing s c e)] 108 | [(add-attribute-constraint-event rator (list x)) 109 | (=> abort) 110 | (unless (memq x (filter*/var? thing)) 111 | (abort)) 112 | (unify-new-prefix thing s c e)] 113 | [(empty-event) ;; empty is not synonymous to new 114 | (unify-new-prefix thing s c e)]) 115 | 116 | -------------------------------------------------------------------------------- /cKanren/unstable/ak.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (except-in cKanren/ck walk walk* occurs-check) 4 | cKanren/src/constraints 5 | cKanren/src/framework 6 | (rename-in cKanren/src/events [findf e:findf])) 7 | (provide 8 | nom ==-check fresh-nom hash (rename-out [make-tie tie]) unify-s get-sus nom? 9 | (prefix-out nominal- walk) 10 | (prefix-out nominal- ==)) 11 | 12 | (define-var-type nom "a") 13 | 14 | (define-syntax-rule (fresh-nom (n ...) g g* ...) 15 | (fresh-aux nom (n ...) g g* ...)) 16 | 17 | (define (sus-constrained? x oc) 18 | (and (eq? (oc-rator oc) 'sus-c) 19 | (eq? (sus-constraint-v oc) x))) 20 | 21 | (define (sus-constraint-v oc) (car (oc-rands oc))) 22 | 23 | (define (sus? x) 24 | (and (pair? x) (eq? (car x) 'sus))) 25 | 26 | (define (get-sus x c e) 27 | (or (let ([rands* (filter/rator sus-c c)]) 28 | (let ([rands (findf (match-lambda [(list v pi) (eq? v x)] [else #f]) rands*)]) 29 | (and rands (cons 'sus rands)))) 30 | (e:findf (match-lambda 31 | [(add-constraint-event/internal rator (list v pi)) 32 | (and (eq? sus-c rator) 33 | (eq? v x))] 34 | [else #f]) 35 | e))) 36 | 37 | (define (sus-v s) (cadr s)) 38 | (define (sus-pi s) (caddr s)) 39 | 40 | (define-constraint (sus-c v [pi #:constant]) 41 | (add-constraint (sus-c v pi))) 42 | 43 | (struct tie (a t) 44 | #:transparent 45 | #:extra-constructor-name make-tie 46 | #:methods gen:mk-struct 47 | [(define (recur tie k) 48 | (k (tie-a tie) (list (tie-t tie)))) 49 | (define (constructor tie) 50 | (lambda (a t-ls) 51 | (make-tie a (car t-ls)))) 52 | (define (override-occurs-check? tie) #f) 53 | (define (reify-mk-struct tie r) 54 | (reify-tie tie r))]) 55 | 56 | (define (reify-tie t r) 57 | `(tie ,(reify-term (tie-a t) r) 58 | ,(reify-term (tie-t t) r))) 59 | 60 | (define (sus x pi) 61 | (sus-c x pi)) 62 | 63 | (define (== u v) 64 | (unify-s u v)) 65 | 66 | (define-constraint (unify-s u v) 67 | #:package (a [s c e]) 68 | (cond 69 | ((eq? u v) succeed) 70 | ((sus? u) 71 | (add-association (sus-v u) (apply-pi (sus-pi u) v c e))) 72 | ((get-sus u c e) 73 | => (lambda (s) 74 | (add-association u (apply-pi (sus-pi s) v c e)))) 75 | ((sus? v) 76 | (add-association (sus-v v) (apply-pi (sus-pi v) u c e))) 77 | ((get-sus v c e) 78 | => (lambda (s) 79 | (add-association v (apply-pi (sus-pi s) u c e)))) 80 | ((and (tie? u) (tie? v)) 81 | (let ((au (tie-a u)) (av (tie-a v)) 82 | (tu (tie-t u)) (tv (tie-t v))) 83 | (if (eq? au av) 84 | (unify-s tu tv) 85 | (conj 86 | (hash au tv) 87 | (unify-s tu (apply-pi `((,au . ,av)) tv c e)))))) 88 | ((and (pair? u) (pair? v)) 89 | (conj 90 | (unify-s (car u) (car v)) 91 | (unify-s (cdr u) (cdr v)))) 92 | ((and (var? u) (not (nom? u))) 93 | (conj 94 | (sus u `()) 95 | (add-association u (apply-pi `() v c e)))) 96 | ((and (var? v) (not (nom? v))) 97 | (conj 98 | (sus v `()) 99 | (add-association v (apply-pi `() u c e)))) 100 | ((or (nom? u) (nom? v)) fail) 101 | ((equal? u v) succeed) 102 | (else fail))) 103 | 104 | (define (==-check u v) 105 | (unify-s-check u v)) 106 | 107 | (define-constraint (unify-s-check u v) 108 | #:package (a [s c e]) 109 | (cond 110 | ((eq? u v) succeed) 111 | ((sus? u) 112 | (ext-s-check (cadr u) (apply-pi (caddr u) v c e))) 113 | ((get-sus u c e) 114 | => (lambda (oc) 115 | (ext-s-check u (apply-pi (sus-pi oc) v c e)))) 116 | ((sus? v) 117 | (ext-s-check (cadr v) (apply-pi (caddr v) u c e))) 118 | ((get-sus v c e) 119 | => (lambda (oc) 120 | (ext-s-check v (apply-pi (sus-pi oc) u c e)))) 121 | ((and (tie? u) (tie? v)) 122 | (let ((au (tie-a u)) (av (tie-a v)) 123 | (tu (tie-t u)) (tv (tie-t v))) 124 | (if (eq? au av) 125 | (unify-s-check tu tv) 126 | (conj 127 | (hash au tv) 128 | (unify-s-check tu (apply-pi `((,au . ,av)) tv c e)))))) 129 | ((and (pair? u) (pair? v)) 130 | (conj 131 | (unify-s-check (car u) (car v)) 132 | (unify-s-check (cdr u) (cdr v)))) 133 | ((and (var? u) (not (nom? u))) 134 | (conj 135 | (sus u `()) 136 | (ext-s-check u (apply-pi `() v c e)))) 137 | ((and (var? v) (not (nom? v))) 138 | (conj 139 | (sus v `()) 140 | (ext-s-check v (apply-pi `() u c e)))) 141 | ((or (nom? u) (nom? v)) fail) 142 | ((equal? u v) succeed) 143 | (else fail))) 144 | 145 | (define (ext-s-check x u) 146 | (transformer 147 | #:package (a [s c e]) 148 | (cond 149 | [(occurs-check x u s c e) 150 | (add-association x u)] 151 | [else fail]))) 152 | 153 | (define (occurs-check x t s c e) 154 | (let rec ([t t]) 155 | (let ([t (walk (tie-t* t) s c e)]) 156 | (cond 157 | [(sus? t) (not (eq? x (sus-v t)))] 158 | [(get-sus t c e) 159 | => (lambda (sus-c) 160 | (not (eq? x (sus-v sus-c))))] 161 | [(pair? t) (and (rec (car t)) (rec (cdr t)))] 162 | [else #t])))) 163 | 164 | (define-constraint (hash b t) 165 | #:package (a [s c e]) 166 | #:reification-function 167 | (lambda (ans r) 168 | (let ((lhs b) 169 | (rhs t)) 170 | (let ((rhs (if (sus? rhs) (cadr rhs) rhs))) 171 | `(hash (,lhs ,rhs))))) 172 | (let rec ((t t)) 173 | (let ((t (walk t s c e))) 174 | (cond 175 | ((eq? b t) fail) 176 | ((sus? t) 177 | (let ((lhs (apply-pi (caddr t) b c e))) 178 | (add-constraint (hash lhs t)))) 179 | ((get-sus t c e) 180 | => (lambda (sus-c) 181 | (let ((lhs (apply-pi (sus-pi sus-c) b c e))) 182 | (add-constraint (hash lhs t))))) 183 | ((tie? t) 184 | (if (eq? b (tie-a t)) succeed (rec (tie-t t)))) 185 | ((pair? t) 186 | (conj (rec (car t)) (rec (cdr t)))) 187 | ((and (var? t) (not (nom? t))) 188 | (conj (sus t `()) (rec t))) 189 | (else succeed))))) 190 | 191 | (define (tie-t* t) 192 | (if (tie? t) (tie-t* (tie-t t)) t)) 193 | 194 | (define (walk x s c e) 195 | (let f ((x x) (pi '())) 196 | (cond 197 | ((sus? x) 198 | (cond 199 | ((assq (sus-v x) s) 200 | => (lambda (a) (f (cdr a) (compose-pis (sus-pi x) pi)))) 201 | (else (apply-pi pi x c e)))) 202 | ((get-sus x c e) 203 | => (lambda (sus-c) 204 | (cond 205 | ((assq x s) 206 | => (lambda (a) 207 | (f (cdr a) 208 | (compose-pis (sus-pi sus-c) pi)))) 209 | (else (apply-pi pi x c e))))) 210 | (else (apply-pi pi x c e))))) 211 | 212 | (define compose-pis append) 213 | 214 | (define (get-noms pi s) 215 | (define (with n s) (if (memq n s) s (cons n s))) 216 | (cond 217 | ((null? pi) s) 218 | (else (get-noms (cdr pi) (with (caar pi) (with (cdar pi) s)))))) 219 | 220 | (define (pi-ds pi1 pi2 c e) 221 | (for/fold ([s '()]) 222 | ([nom (get-noms pi1 (get-noms pi2 '()))]) 223 | (cond 224 | ((eq? (apply-pi pi1 nom c e) (apply-pi pi2 nom c e)) s) 225 | (else (cons nom s))))) 226 | 227 | (define (id-pi? pi c e) (null? (pi-ds pi '() c e))) 228 | 229 | (define (app pi a) 230 | (let ((pi (reverse pi))) 231 | (cond 232 | ((null? pi) a) 233 | ((eq? (caar pi) a) 234 | (app (cdr pi) (cdar pi))) 235 | ((eq? (cdar pi) a) 236 | (app (cdr pi) (caar pi))) 237 | (else (app (cdr pi) a))))) 238 | 239 | (define (apply-pi pi t c e) 240 | (let rec ((t t)) 241 | (cond 242 | ((nom? t) (app pi t)) 243 | ((sus? t) 244 | (let ((pi (compose-pis pi (caddr t)))) 245 | (if (id-pi? pi c e) t `(sus ,(cadr t) ,pi)))) 246 | ((get-sus t c e) 247 | => (lambda (sus-c) 248 | (let ((pi (compose-pis pi (sus-pi sus-c)))) 249 | (if (id-pi? pi c e) t `(sus ,t ,pi))))) 250 | ((var? t) 251 | (if (id-pi? pi c e) t `(sus ,t ,pi))) 252 | ((tie? t) 253 | (make-tie (app pi (tie-a t)) 254 | (rec (tie-t t)))) 255 | ((pair? t) (cons (rec (car t)) (rec (cdr t)))) 256 | (else t)))) 257 | 258 | #; 259 | (define (reify-alpha-constraints v r c) 260 | (let ((c (filter-memq/rator '(sus-c hash) c))) 261 | (let ((c (reify-alpha r c))) 262 | (if (null? c) c `((alpha . ,c)))))) 263 | 264 | #; 265 | (define (reify-alpha r c) 266 | (for/fold ([c^ '()]) 267 | ([oc c]) 268 | (cond 269 | ((reify-oc oc r) 270 | => (lambda (oc-sym) 271 | (if (member oc-sym c^) c^ (cons oc-sym c^)))) 272 | (else c^)))) 273 | 274 | 275 | -------------------------------------------------------------------------------- /cKanren/unstable/doc/manual.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require (except-in scribble/manual var) 4 | racket/base 5 | scribble/eval 6 | racket/contract) 7 | 8 | @(require (for-label cKanren/ck) 9 | (for-label racket/base)) 10 | 11 | @title{cKanren} 12 | 13 | cKanren is a framework for defining constraints in miniKanren. The 14 | following is a description of all building blocks available to 15 | constraint writers, and convenience definitions that can be 16 | re-exported for the user. 17 | 18 | @(define ck-eval (make-base-eval)) 19 | @(interaction-eval #:eval ck-eval (require cKanren/ck)) 20 | 21 | @section{Variables} 22 | @(declare-exporting cKanren/ck) 23 | 24 | @defproc[(var [x symbol?]) var?] 25 | Creates a new variable. Use sparingly. 26 | 27 | @defproc[(var? [x any/c?]) boolean]{ Returns @racket[#t] if @racket[x] 28 | is a @racket[var], @racket[#f] otherwise. } 29 | 30 | @defform[#:literals (name) 31 | (define-var-type name display-str)] 32 | 33 | Defines a new kind of constrained variable that displays 34 | @racket[display-str] before it's value. This should be used instead 35 | of @racket[var] wherever possible. 36 | 37 | @examples[ 38 | #:eval ck-eval 39 | (define-var-type nom "a") 40 | (define new-nom (nom 'my-nom)) 41 | new-nom 42 | (and (var? new-nom) (nom? new-nom)) 43 | ] 44 | 45 | @section{Goals} 46 | @(declare-exporting cKanren/ck) 47 | 48 | A function that operates on values in cKanren is called a 49 | @deftech{goal}. Each goal takes the state of the program as an 50 | argument, and returns a possibly infinite stream of new states. A 51 | goal that produces at least one new state @deftech{succeeds}, whereas 52 | an unsatisfiable goal @deftech{fails} and produces no answers. The 53 | state is represented as a @tech{package} of information, the structure 54 | of which we will discuss later on. 55 | 56 | @defform*[#:literals (:) 57 | [(lambdag@ (a) body ...+) 58 | (lambdag@ (a : s) body ...+) 59 | (lambdag@ (a : s c) body ...+)]]{ 60 | 61 | Produces a goal. The current package, @racket[a], can be split up 62 | into its individual parts by providing identifiers for @racket[s] and 63 | @racket[c]. } 64 | 65 | @defproc[(goal? [x any/c]) boolean]{ Returns @racket[#t] if 66 | @racket[x] is a goal created with @racket[lambdag@], @racket[#f] 67 | otherwise. } 68 | 69 | @defthing[succeed goal?]{ The simplest goal that @tech{succeeds}. } 70 | @defthing[fail goal?]{ The simplest goal that @tech{fails}. } 71 | 72 | @defthing[prt goal?]{ A goal that print out the current state of the 73 | program and succeeds. } 74 | 75 | @defproc*[([(prtm [str string?]) goal?] 76 | [(prtm [format-str string?] [args any/c?] ...) goal?])]{ 77 | 78 | Returns a goal that prints @racket[str] or the result of 79 | @racket[(printf format-str args ...)] and then succeeds. } 80 | 81 | @defform[(run num (q) goal ...+)] 82 | 83 | Runs each @racket[goal] with a new variable @racket[q]. The result is 84 | either a list containing @racket[num] values for @racket[q], or all 85 | possible answers for @racket[q] when @racket[num] is @racket[#f]. 86 | 87 | @defform[(run* (q) goal ...)] 88 | Short-hand for @racket[(run #f (q) goal ...)] 89 | 90 | @examples[ 91 | #:eval ck-eval 92 | (run* (q) fail) 93 | (run* (q) succeed) 94 | (run* (q) (prtm "(╯°□°）╯︵ ┻━┻")) 95 | (run* (q) "I am not a goal :(") 96 | (run* (q) (lambdag@ (a) (printf "here's an empty a: ~s\n" a) a)) 97 | ] 98 | 99 | The result @racket['()] means that there are no values for @racket[q] 100 | that satisfy the goals in the body. Alternatively, @racket['(__.0)] 101 | means that when the program finishes, @racket[q] can be anything. 102 | This answer makes sense because @racket[succeed] does not contain any 103 | information. 104 | 105 | @defform[(fresh (x ...) goal ...+)]{ 106 | 107 | Produces a new goal that is the conjunction of the goals in the body 108 | where each @racket[x] is a @deftech{fresh} (read "unconstrained") 109 | lexically-scoped variable. } 110 | 111 | @defform[(fresh-aux constructor (x ...) goal ...+)]{ 112 | 113 | Introduces each @racket[x] as @racket[(constructor 'x)] instead of as 114 | a normal cKanren variable. } 115 | 116 | @examples[ 117 | #:eval ck-eval 118 | (define-var-type pony "mlp") 119 | (define-syntax-rule (new-pony (anypony ...) goals ...) 120 | (fresh-aux pony (anypony ...) goals ...)) 121 | (run* (q) 122 | (new-pony (pinkie-pie rainbow-dash) 123 | (prtm "~s\n" (list pinkie-pie rainbow-dash)))) 124 | ] 125 | 126 | @defform/subs[(conde clause ...+) 127 | ([clause [goal ...+] [#:name id goal ...+]])]{ 128 | 129 | Branches and evaluates each @racket[clause] independently. The named 130 | clause form is described in a later section. } 131 | 132 | @examples[ 133 | #:eval ck-eval 134 | (run* (q) 135 | (conde 136 | [(prtm "this line generates one answer\n")] 137 | [(prtm "this line generates another!\n")])) 138 | ] 139 | Note that both answers are returned together at the end. 140 | 141 | @section{Constraints} 142 | @(declare-exporting cKanren/ck) 143 | 144 | A @deftech{constraint} is simply imitation-@tech{goal} that can 145 | return at most one output state. This implies any language feature 146 | that returns a goal, like @racket[fresh] and @racket[conde], cannot be 147 | used inside a constraint. Unlike goals, constraints can be stored for 148 | later evaluation. 149 | 150 | @defform*[#:literals (:) 151 | [(lambdam@ (a) body ...+) 152 | (lambdam@ (a : s) body ...+) 153 | (lambdam@ (a : s c) body ...+)]]{ 154 | 155 | Equivalent to @racket[lambdag@] except that a constraint is produced 156 | instead of a goal. } 157 | 158 | @defthing[identitym constraint?] 159 | The simplest succeeding constraint. 160 | 161 | @defthing[mzerom constraint?] 162 | The simplest failing constraint. 163 | 164 | @defproc[(bindm [a a?] [fm constraint?]) (maybe a?)]{ Functionally 165 | equivalent to @racket[(fm a)], but so much prettier. } 166 | 167 | @defproc[(composem [fm constraint?] ...) constraint?]{ Composes an 168 | arbitrary number of constraints together, threading through the state 169 | from left to right. } 170 | 171 | @defstruct[oc ([proc constraint?] [rator symbol?] [rands list?])]{ 172 | 173 | The stored version of a constraint. @racket[proc] is an instance of 174 | the constraint @racket[rator] called on @racket[rands]. When an 175 | @racket[oc] is printed out, the @racket[proc] is hidden. } 176 | 177 | @defform[(build-oc op args ...)]{ 178 | 179 | Builds an @racket[oc], where @racket[proc] is @racket[(op args ...)], 180 | @racket[rator] is @racket['op], and @racket[rands] is @racket[`(,args 181 | ...)]. } 182 | 183 | @examples[ 184 | #:eval ck-eval 185 | (define (my-constraint x y) identitym) 186 | (build-oc my-constraint 5 6) 187 | ] 188 | 189 | @section{The Package} 190 | @(declare-exporting cKanren/ck) 191 | 192 | All of the information generated by a cKanren program is contained in 193 | a @deftech{package}. There are at most four parts to any package: the 194 | @tech{substitution}, @tech{constraint store}, @tech{queue}, and 195 | @tech{path}. These structures will be talked about in more depth in 196 | the section about @secref{Constraints}. 197 | 198 | @subsection{Substitution} 199 | 200 | The @deftech{substitution} (abbreviated @racket[s]) contains all 201 | mappings of variables to ground terms. It contains at most one 202 | binding for every variable, but it is not idempotent. An association 203 | list can always be used as a substitution, but the internal 204 | representation may change. 205 | 206 | @defproc[(walk [v any/c?] [s s?]) any]{ 207 | 208 | Retrieves the binding for @racket[v] in @racket[s]. If @racket[v] is 209 | not a @racket[var?], or has no binding in @racket[s], it is returned 210 | unchanged. If @racket[v] is bound to a variable @racket[u] in 211 | @racket[s], then @racket[(walk v s)] is returned. } 212 | 213 | @examples[ 214 | #:eval ck-eval 215 | (let ([x (var 'x)] [y (var 'y)] [z (var 'z)]) 216 | (walk x `((,x . ,y) (,z . 5) (,y . ,z)))) 217 | ] 218 | 219 | @defproc[(update-s [u any/c?] [v any/c?]) constraint?]{ 220 | 221 | Safely extends the substitution with a binding of @racket[u] to 222 | @racket[v] when @racket[u] is a @racket[var?]. If neither @racket[u] 223 | nor @racket[v] are variables, @racket[update-s] will fail if @racket[u] and 224 | @racket[v] are not @racket[equal?]. 225 | 226 | Successfully extending the substitution will trigger any constraints 227 | that reference @racket[u] or @racket[v], a process that will be 228 | described in a later section. } 229 | 230 | @examples[ 231 | #:eval ck-eval 232 | (run* (q) (update-s q 5)) 233 | (run* (q) 234 | (conde 235 | [(update-s q 'x)] 236 | [(update-s q 'y)])) 237 | (define (best-pony pony) 238 | (update-s pony 'pinkie-pie)) 239 | (run* (q) (best-pony q)) 240 | (run* (q) (best-pony q) (update-s q 'fluttershy)) 241 | ] 242 | 243 | The last example fails because @racket[q] cannot be 244 | @racket['pinkie-pie] and @racket['fluttershy] simultaneously. 245 | 246 | If you think @racket[(update-s _arg ...)] can get a little wordy, 247 | you're right! cKanren ships with a much more expressive 248 | way to update the substitution called @deftech{unification}, which 249 | will be described in an appendix of this guide at some point. 250 | 251 | @subsection{Constraint Store} 252 | 253 | The @deftech{constraint store} holds constraints stored as 254 | @racket[oc]s. 255 | 256 | @defproc[(update-c [oc oc?]) constraint?]{ Adds @racket[oc] to the 257 | constraint store if it contains any unground @racket[var?]s. } 258 | 259 | @examples[ 260 | #:eval ck-eval 261 | (define (fail-if-ground x) 262 | (lambdam@ (a : s) 263 | (let ([x (walk x s)]) 264 | (cond 265 | [(not (var? x)) #f] 266 | [else (bindm a (update-c (build-oc fail-if-ground x)))])))) 267 | (run* (q) (fail-if-ground q) prt) ] 268 | 269 | What happens if @racket[q] is ground after a @racket[fail-if-ground] 270 | constraint is placed in the constraint store? How is our stored 271 | constraint notified that @racket[q] is changed? 272 | 273 | @defproc[(run-constraints [x* list?] [ocs list?]) constriant?]{ 274 | 275 | Runs any constraint in @racket[ocs] that mentions any variable in 276 | @racket[x*]. } 277 | 278 | @examples[ 279 | #:eval ck-eval 280 | (run* (q) 281 | (fail-if-ground q) 282 | prt 283 | (update-s q 5)) 284 | ] 285 | 286 | Updating the substitution with a new binding will rerun the 287 | @racket[fail-if-ground] @racket[oc] that contains @racket[q]. 288 | 289 | @defproc[(replace-c [new-c c?]) constraint?]{ Wipes out the existing 290 | constraint store and replaces it with @racket[new-c]. Use with 291 | caution.} 292 | 293 | @defproc[(filter/rator [sym symbol?] [c c?]) list?]{ Returns a list of 294 | every @racket[oc] such that @racket[(eq? (oc-rator oc) sym)]. } 295 | 296 | @defproc[(filter-not/rator [sym symbol?] [c c?]) list?]{ Returns a list of 297 | every @racket[oc] such that @racket[(not (eq? (oc-rator oc) sym))]. } 298 | 299 | @defproc[(filter-memq/rator [symls list?] [c c?]) list?]{ Returns a 300 | list of every @racket[oc] such that @racket[(memq (oc-rator oc) 301 | symls)]. } 302 | 303 | @defproc[(filter-not-memq/rator [sym symbol?] [c c?]) list?]{ Returns a list of 304 | every @racket[oc] such that @racket[(not (memq (oc-rator oc) symls))]. } 305 | 306 | @subsection{Queue} 307 | 308 | The @deftech{queue} is where all lazy goals are stored. As a 309 | constraint writer or user, you do not have to think about this. 310 | 311 | @subsection{Path} The @deftech{path} is a list of the path the package 312 | has taken through the program. It will be empty until it passes 313 | through a @racket[conde] in @racket[debug] mode. 314 | 315 | @defform[(debug expr ...)]{ Turns on debugging (path-tracking) for 316 | condes inside the expression. Any packages printed within will also 317 | display the path they took through the program. } 318 | 319 | @examples[ 320 | #:eval ck-eval 321 | (debug 322 | (run* (q) 323 | (conde 324 | [#:name first 325 | (update-s q 5) 326 | prt] 327 | [#:name second 328 | (update-s q 6)]))) 329 | ] 330 | 331 | The package that is displayed indicates the answer with @racket[q] 332 | bound to @racket[5] traveled through the @racket[conde] clause named 333 | @racket[first]. 334 | 335 | -------------------------------------------------------------------------------- /cKanren/unstable/fd.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require cKanren/unstable/interval-domain 4 | cKanren/ck 5 | cKanren/src/framework 6 | cKanren/src/events 7 | cKanren/src/constraints 8 | cKanren/src/triggers 9 | cKanren/src/operators) 10 | 11 | (provide (all-defined-out)) 12 | 13 | ;; domains 14 | 15 | (define-syntax-rule (infd x0 x ... e) 16 | (let ([n* e]) 17 | (conj (domfd x0 n*) (domfd x n*) ...))) 18 | 19 | (define (domfd x n*) 20 | (dom x (make-dom n*))) 21 | 22 | (define-constraint (dom v [d #:constant]) 23 | #:reaction 24 | [(any-enforce (list v)) 25 | (force-ans v d)] 26 | #:package (a [s c e]) 27 | (cond 28 | [(and (value-dom? v) (memv-dom? v d)) succeed] 29 | [(var? v) 30 | (cond 31 | [(null-dom? d) fail] 32 | [(singleton-dom? d) 33 | (add-association v (singleton-element-dom d))] 34 | [else (add-constraint (dom v d))])] 35 | [else fail])) 36 | 37 | (define-constraint-interaction 38 | [(dom x d) (dom x d^)] => [(dom x (intersection-dom d d^))]) 39 | 40 | (define (force-ans v d) 41 | (map-sum (curry add-association v) d)) 42 | 43 | (define ( (lambda (oc) (cadr (oc-rands oc)))) 86 | ;; (else #f)))) 87 | ;; 88 | ;; (define (force-ans x) 89 | ;; (lambdam@ (a : s c) 90 | ;; (let ([x (walk x s)]) 91 | ;; (bindm a 92 | ;; (cond 93 | ;; [(and (var? x) (get-dom x c)) 94 | ;; => (map-sum 95 | ;; (lambda (v) 96 | ;; (update-s x v)))] 97 | ;; [(pair? x) 98 | ;; (conj 99 | ;; (force-ans (car x)) 100 | ;; (force-ans (cdr x)))] 101 | ;; [else identitym]))))) 102 | ;; 103 | ;; (define-syntax let-dom 104 | ;; (syntax-rules (:) 105 | ;; ((_ (s c) ([u : d_u] ...) body) 106 | ;; (let ([u (walk u s)] ...) 107 | ;; (let ([d_u 108 | ;; (cond 109 | ;; ((var? u) (get-dom u c)) 110 | ;; (else (make-dom `(,u))))] 111 | ;; ...) 112 | ;; body))))) 113 | ;; 114 | 115 | (define-constraint (=/=fd u v) 116 | (cond 117 | [(and (value-dom? u) (value-dom? v)) 118 | (succeed-iff (not (eq? u v)))] 119 | [else (add-constraint (=/=fd u v))])) 120 | 121 | (define-constraint-interaction 122 | [(=/=fd u v) (dom u d) (dom v d^)] 123 | [(disjoint-dom? d d^) [(dom u d) (dom v d^)]]) 124 | 125 | (define-constraint-interaction 126 | [(=/=fd u v) (dom u d)] 127 | [(value-dom? v) [(dom u (remq-dom v d))]]) 128 | 129 | ;; (define (distinctfd-c v*) 130 | ;; (lambdam@ (a : s c) 131 | ;; (let ([v* (walk* v* s)]) 132 | ;; (cond 133 | ;; ((not (list? v*)) 134 | ;; (let ((oc (build-oc distinctfd-c v*))) 135 | ;; ((update-c oc) a))) 136 | ;; (else 137 | ;; (let-values (((x* n*) (partition var? v*))) 138 | ;; (let ((n* (sort n* <))) 139 | ;; (cond 140 | ;; ((list-sorted? < n*) 141 | ;; ((distinct/fd-c x* n*) a)) 142 | ;; (else mzerom))))))))) 143 | ;; 144 | ;; (define (distinct/fd-c y* n*) 145 | ;; (lambdam@ (a : s c) 146 | ;; (let loop ([y* y*] [n* n*] [x* '()]) 147 | ;; (cond 148 | ;; ((null? y*) 149 | ;; (let* ((oc (build-oc distinct/fd-c x* n*))) 150 | ;; ((conj 151 | ;; (update-c oc) 152 | ;; (exclude-from-dom (make-dom n*) c x*)) 153 | ;; a))) 154 | ;; (else 155 | ;; (let ((y (walk (car y*) s))) 156 | ;; (cond 157 | ;; ((var? y) 158 | ;; (loop (cdr y*) n* (cons y x*))) 159 | ;; ;; n* is NOT A DOM 160 | ;; ((memv y n*) mzerom) 161 | ;; (else 162 | ;; (let ((n* (list-insert < y n*))) 163 | ;; (loop (cdr y*) n* x*)))))))))) 164 | ;; 165 | ;; (define (exclude-from-dom dom1 c x*) 166 | ;; (for/fold ([fn identitym]) 167 | ;; ([x x*]) 168 | ;; (cond 169 | ;; [(get-dom x c) 170 | ;; => (lambda (dom2) 171 | ;; (conj 172 | ;; (process-dom x (diff-dom dom2 dom1)) 173 | ;; fn))] 174 | ;; [else fn]))) 175 | ;; 176 | ;; (define-syntax c-op 177 | ;; (syntax-rules (:) 178 | ;; ((_ op ([u : d_u] ...) body) 179 | ;; (lambdam@ (a : s c) 180 | ;; (let-dom (s c) ([u : d_u] ...) 181 | ;; (let ([oc (build-oc op u ...)]) 182 | ;; ((conj 183 | ;; (update-c oc) 184 | ;; (cond 185 | ;; [(and d_u ...) body] 186 | ;; [else identitym])) 187 | ;; a))))))) 188 | ;; 189 | 190 | (define-constraint (=fd u v) 191 | (cond 192 | [(and (value-dom? u) (value-dom? v)) 193 | (succeed-iff (eq? u v))] 194 | [(value-dom? v) 195 | (add-association u v)] 196 | [else (add-constraint (=fd u v))])) 197 | 198 | (define-constraint-interaction 199 | =fd-interaction 200 | [(=fd u v) (dom u d) (dom v d^)] 201 | => 202 | [(dom u (intersection-dom d d^)) 203 | (dom v (intersection-dom d d^))]) 204 | 205 | 206 | (define-constraint (<=fd u v) 207 | (cond 208 | [(and (value-dom? u) (value-dom? v)) 209 | (succeed-iff (<= u v))] 210 | [else (add-constraint (<=fd u v))])) 211 | 212 | ;; if there are impossible elements in the high ranges of u's domain 213 | ;; or the low ranges of v's dom, removes them 214 | (define-constraint-interaction 215 | [(<=fd u v) (dom u du) (dom v dv)] 216 | [(let ([du^ (copy-before-dom (curry < (max-dom dv)) du)] 217 | [dv^ (drop-before-dom (curry <= (min-dom du)) dv)]) 218 | (or (not (equal? du du^)) 219 | (not (equal? dv dv^)))) 220 | [add (dom u (copy-before-dom (curry < (max-dom dv)) du)) 221 | (dom v (drop-before-dom (curry <= (min-dom du)) dv))]]) 222 | 223 | (define-constraint-interaction 224 | [(<=fd u v) (dom u du)] 225 | [(value-dom? v) [(dom u (copy-before-dom (curry < v) du))]]) 226 | 227 | (define-constraint-interaction 228 | [(<=fd u v) (dom v dv)] 229 | [(value-dom? u) [(dom v (drop-before-dom (curry <= u) dv))]]) 230 | 231 | #; 232 | (define-constraint (+fd u v w) 233 | (cond 234 | [(andmap value-dom? (list u v w)) 235 | (succeed-iff (= (+ u v) w))] 236 | [else (add-constraint (+fd u v w))]) 237 | 238 | #; 239 | (c-op +fd-c ([u : d_u] [v : d_v] [w : d_w]) 240 | (let ([wmin (min-dom d_w)] [wmax (max-dom d_w)] 241 | [umin (min-dom d_u)] [umax (max-dom d_u)] 242 | [vmin (min-dom d_v)] [vmax (max-dom d_v)]) 243 | (let ([new-w-dom (range (+ umin vmin) (+ umax vmax))] 244 | [new-u-dom (range (- wmin vmax) (- wmax vmin))] 245 | [new-v-dom (range (- wmin umax) (- wmax umin))]) 246 | (conj 247 | (process-dom w new-w-dom) 248 | (process-dom u new-u-dom) 249 | (process-dom v new-v-dom)))))) 250 | 251 | ;; 252 | ;; (define (timesfd-c u v w) 253 | ;; (let ((safe-div (lambda (n c a) (if (zero? n) c (quotient a n))))) 254 | ;; (c-op timesfd-c ([u : d_u] [v : d_v] [w : d_w]) 255 | ;; (let ([wmin (min-dom d_w)] [wmax (max-dom d_w)] 256 | ;; [umin (min-dom d_u)] [umax (max-dom d_u)] 257 | ;; [vmin (min-dom d_v)] [vmax (max-dom d_v)]) 258 | ;; (let ([new-w-dom 259 | ;; (range (* umin vmin) (* umax vmax))] 260 | ;; [new-u-dom 261 | ;; (range 262 | ;; (safe-div vmax umin wmin) 263 | ;; (safe-div vmin umax wmax))] 264 | ;; [new-v-dom 265 | ;; (range 266 | ;; (safe-div umax vmin wmin) 267 | ;; (safe-div umin vmax wmax))]) 268 | ;; (conj 269 | ;; (process-dom w new-w-dom) 270 | ;; (process-dom u new-u-dom) 271 | ;; (process-dom v new-v-dom))))))) 272 | ;; 273 | ;; (define (enforce-constraintsfd x) 274 | ;; (define (domfd-c->var domfd-c) 275 | ;; (car (oc-rands domfd-c))) 276 | ;; (conj 277 | ;; (force-ans x) 278 | ;; (lambdam@ (a : s c) 279 | ;; (let ([domains (filter/rator 'domfd-c c)]) 280 | ;; (let ([bound-x* (map domfd-c->var domains)]) 281 | ;; (verify-all-bound s c bound-x*) 282 | ;; ((conj 283 | ;; (onceo (force-ans bound-x*)) 284 | ;; (lambdam@ (a^) a)) 285 | ;; a)))))) 286 | ;; 287 | ;; (define fd-cs '(=/=fd-c distinctfd-c distinct/fd-c 288 | ;; <=fd-c =fd-c +fd-c timesfd-c)) 289 | ;; (define (fd-c? oc) (memq (oc-rator oc) fd-cs)) 290 | ;; 291 | ;; (define (verify-all-bound s c bound-x*) 292 | ;; (define (bound? x) (memq x bound-x*)) 293 | ;; (for ([oc (c->list c)] #:when (fd-c? oc)) 294 | ;; (define oc-vars (filter var? (oc-rands oc))) 295 | ;; (cond 296 | ;; ((findf (compose not bound?) oc-vars) 297 | ;; => (lambda (x) 298 | ;; (unless (value-dom? (walk x s)) 299 | ;; (error 'verify-all-bound 300 | ;; "constrained variable ~s without domain" x))))))) 301 | ;; 302 | ;; ;;; helpers 303 | ;; 304 | ;; (define (list-sorted? pred ls) 305 | ;; (cond 306 | ;; ((or (null? ls) (null? (cdr ls))) #t) 307 | ;; ((pred (car ls) (cadr ls)) 308 | ;; (list-sorted? pred (cdr ls))) 309 | ;; (else #f))) 310 | ;; 311 | ;; (define (list-insert pred x ls) 312 | ;; (cond 313 | ;; ((null? ls) (cons x '())) 314 | ;; ((pred x (car ls)) (cons x ls)) 315 | ;; (else (cons (car ls) (list-insert pred x (cdr ls)))))) 316 | ;; 317 | ;; ;;; 318 | ;; 319 | ;; (extend-enforce-fns 'fd enforce-constraintsfd) 320 | ;; 321 | -------------------------------------------------------------------------------- /cKanren/unstable/finite-domain.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require cKanren/ck) 4 | (provide range value-dom? 5 | map-sum null-dom? singleton-dom? singleton-element-dom 6 | min-dom max-dom memv-dom? intersection-dom diff-dom 7 | copy-before drop-before disjoint-dom? make-dom) 8 | 9 | ;;; domains (sorted lists of integers) 10 | 11 | (define range 12 | (lambda (lb ub) 13 | (cond 14 | ((< lb ub) (cons lb (range (+ lb 1) ub))) 15 | (else (cons lb '()))))) 16 | 17 | (define value-dom? 18 | (lambda (v) 19 | (and (integer? v) (<= 0 v)))) 20 | 21 | ;; n* should be a non-empty sorted (small to large) list 22 | ;; of value-doms?, with no duplicates. 23 | (define make-dom (lambda (n*) n*)) 24 | 25 | (define map-sum 26 | (lambda (f) 27 | (letrec 28 | ((loop 29 | (lambda (ls) 30 | (cond 31 | ((null? ls) 32 | fail) 33 | (else 34 | (conde 35 | ((f (car ls))) 36 | ((loop (cdr ls))))))))) 37 | loop))) 38 | 39 | (define null-dom? 40 | (lambda (x) 41 | (null? x))) 42 | 43 | (define singleton-dom? 44 | (lambda (dom) 45 | (null? (cdr dom)))) 46 | 47 | (define singleton-element-dom 48 | (lambda (dom) 49 | (car dom))) 50 | 51 | (define min-dom 52 | (lambda (dom) 53 | (car dom))) 54 | 55 | (define max-dom 56 | (lambda (dom) 57 | (cond 58 | ((null? (cdr dom)) (car dom)) 59 | (else (max-dom (cdr dom)))))) 60 | 61 | (define memv-dom? 62 | (lambda (v dom) 63 | (and (value-dom? v) (memv v dom)))) 64 | 65 | (define intersection-dom 66 | (lambda (dom1 dom2) 67 | (cond 68 | ((or (null? dom1) (null? dom2)) '()) 69 | ((= (car dom1) (car dom2)) 70 | (cons (car dom1) 71 | (intersection-dom (cdr dom1) (cdr dom2)))) 72 | ((< (car dom1) (car dom2)) 73 | (intersection-dom (cdr dom1) dom2)) 74 | (else (intersection-dom dom1 (cdr dom2)))))) 75 | 76 | (define diff-dom 77 | (lambda (dom1 dom2) 78 | (cond 79 | ((or (null? dom1) (null? dom2)) dom1) 80 | ((= (car dom1) (car dom2)) 81 | (diff-dom (cdr dom1) (cdr dom2))) 82 | ((< (car dom1) (car dom2)) 83 | (cons (car dom1) (diff-dom (cdr dom1) dom2))) 84 | (else (diff-dom dom1 (cdr dom2)))))) 85 | 86 | (define copy-before 87 | (lambda (pred dom) 88 | (cond 89 | ((null? dom) '()) 90 | ((pred (car dom)) '()) 91 | (else (cons (car dom) (copy-before pred (cdr dom))))))) 92 | 93 | (define drop-before 94 | (lambda (pred dom) 95 | (cond 96 | ((null? dom) '()) 97 | ((pred (car dom)) dom) 98 | (else (drop-before pred (cdr dom)))))) 99 | 100 | (define disjoint-dom? 101 | (lambda (dom1 dom2) 102 | (cond 103 | ((or (null? dom1) (null? dom2)) #t) 104 | ((= (car dom1) (car dom2)) #f) 105 | ((< (car dom1) (car dom2)) 106 | (disjoint-dom? (cdr dom1) dom2)) 107 | (else (disjoint-dom? dom1 (cdr dom2)))))) 108 | 109 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define version "0.0") 4 | 5 | (define collection 'multi) 6 | (define deps '("base" 7 | "rackunit-lib")) 8 | --------------------------------------------------------------------------------