├── LICENSE
├── usage.rkt
├── paper-code.rkt
└── single-file-system.rkt


/LICENSE:
--------------------------------------------------------------------------------
 1 | The MIT License (MIT)
 2 | 
 3 | Copyright (c) 2015 Jason Hemann
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 | 
23 | 


--------------------------------------------------------------------------------
/usage.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require "paper-code.rkt")
  3 | (require rackunit)
  4 | 
  5 | ;; miniKanren wrappers
  6 | (define-syntax disj+
  7 |   (syntax-rules ()
  8 |     ((_ g) g)
  9 |     ((_ g0 g ...) (disj g0 (disj+ g ...)))))
 10 | 
 11 | (define-syntax conj+
 12 |   (syntax-rules ()
 13 |     ((_ g) g)
 14 |     ((_ g0 g ...) (conj g0 (conj+ g ...)))))
 15 | 
 16 | (define-syntax-rule (conde (g0 g ...) (g0* g* ...) ...)
 17 |   (disj+ (conj+ g0 g ...) (conj+ g0* g* ...) ...))
 18 | 
 19 | (define-syntax fresh
 20 |   (syntax-rules ()
 21 |     ((_ () g0 g ...) (conj+ g0 g ...))
 22 |     ((_ (x0 x ...) g0 g ...)
 23 |      (call/fresh (lambda (x0) (fresh (x ...) g0 g ...))))))
 24 | 
 25 | ;; Slightly new run, run interface
 26 | (define-syntax-rule (run n/b (q) g g* ...)
 27 |   (call/initial-state n/b (fresh (q) g g* ...)))
 28 | 
 29 | (define-relation (membero x ls o)
 30 |   (fresh (a d)
 31 |     (== `(,a . ,d) ls)
 32 |     (conde
 33 |       ((== x a) (== ls o))
 34 |       ((=/= x a) (membero x d o)))))
 35 | 
 36 | (test-equal? "membero test1"
 37 |   (run #f (q) (membero 'x '(a x x) q))
 38 |   '((#hasheqv((== . ((2 . 0) (x . 3) ((3 . 4) . 2) ((1 . 2) a x x)))
 39 |             (=/= . ((x . 1)))
 40 |             (absento . ())
 41 |             (symbolo . ())
 42 |             (not-pairo . ())
 43 |             (booleano . ())
 44 |             (listo . ()))
 45 |    .
 46 |    5))) 
 47 | 
 48 | (test-equal? "membero test2"
 49 |   (run #f (q)
 50 |           (fresh (y z)
 51 |                  (== q `(,y ,z))
 52 |                  (membero 'x `(a ,y x) z)))
 53 | '((#hasheqv((== . ((4 . 2) (x . 5) ((5 . 6) . 4) ((3 . 4) a 1 x) (0 1 2)))
 54 |             (=/= . ((x . 3)))
 55 |             (absento . ())
 56 |             (symbolo . ())
 57 |             (not-pairo . ())
 58 |             (booleano . ())
 59 |             (listo . ()))
 60 |    .
 61 |    7)
 62 |   (#hasheqv((==
 63 |              .
 64 |              ((6 . 2)
 65 |               (x . 7)
 66 |               ((7 . 8) . 6)
 67 |               ((5 . 6) . 4)
 68 |               ((3 . 4) a 1 x)
 69 |               (0 1 2)))
 70 |             (=/= . ((x . 5) (x . 3)))
 71 |             (absento . ())
 72 |             (symbolo . ())
 73 |             (not-pairo . ())
 74 |             (booleano . ())
 75 |             (listo . ()))
 76 |    .
 77 |    9)))
 78 | 
 79 | ;; Example from talk
 80 | (define-relation (lookup Γ x τ)
 81 |   (fresh (y τ2 Γ2)
 82 |     (== `((,y . ,τ2) . ,Γ2) Γ)
 83 |     (conde
 84 |       ((== x y) (== τ τ2) (listo Γ2))
 85 |       ((=/= x y) (lookup Γ2 x τ))))) 
 86 | 
 87 | (define-relation (⊢ Γ e τ)
 88 |   (conde
 89 |     ((booleano e) (== τ 'bool) (listo Γ))
 90 |     ((symbolo e) (lookup Γ e τ))
 91 |     ((fresh (x b)
 92 |        (== `(λ (,x) ,b) e)
 93 |        (symbolo x)
 94 |        (fresh (τ1 τ2)
 95 |          (== `(,τ1 -> ,τ2) τ)             
 96 |          (⊢ `((,x . ,τ1) . ,Γ) b τ2))))
 97 |     ((fresh (e1 e2)
 98 |        (== `(,e1 ,e2) e)
 99 |        (fresh (τ1)
100 |          (⊢ Γ e1 `(,τ1 -> τ))
101 |          (⊢ Γ e2 τ1))))))
102 | 
103 | (test-equal? "test ⊢"
104 |   (call/initial-state 1
105 |     (fresh (q) (⊢ '() q '(bool -> bool))))
106 |   '((#hasheqv((== . ((4 . bool) ((3 -> 4) bool -> bool) ((λ (1) 2) . 0)))
107 |               (=/= . ())
108 |               (absento . ())
109 |               (symbolo . (1))
110 |               (not-pairo . ())
111 |               (booleano . (2))
112 |               (listo . (((1 . 3)))))
113 |      .
114 |      5)))
115 | 


--------------------------------------------------------------------------------
/paper-code.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require (for-syntax syntax/parse))
  3 | (provide (all-defined-out))
  4 | 
  5 | (define (((make-constraint-goal-constructor key) . terms) S/c)
  6 |   (let ((S (ext-S (car S/c) key terms)))
  7 |     (if (invalid? S) '() (list `(,S . ,(cdr S/c))))))
  8 | 
  9 | (define (ext-S S key terms)
 10 |   (hash-update S key ((curry cons) (apply list* terms))))
 11 | 
 12 | (define-syntax-rule (make-invalid? (cid ...) p ...)
 13 |   (λ (S) 
 14 |     (let ((cid (hash-ref S 'cid)) ...)
 15 |       (cond
 16 |         ((valid-== (hash-ref S '==))
 17 |          => (λ (s) (or (p s) ...)))
 18 |         (else #t)))))
 19 | 
 20 | (define-syntax (make-constraint-system stx)
 21 |   (syntax-parse stx
 22 |     [(_ (cid:id ...) p ...)
 23 |      (with-syntax 
 24 |        ([invalid? (syntax-local-introduce #'invalid?)]
 25 |         [S0 (syntax-local-introduce #'S0)]
 26 |         [== (syntax-local-introduce #'==)])
 27 |        #'(begin 
 28 |            (define invalid? (make-invalid? (cid ...) p ...))
 29 |            (define S0
 30 |              (make-immutable-hasheqv '((==) (cid) ...)))
 31 |            (define == (make-constraint-goal-constructor '==))
 32 |            (define cid (make-constraint-goal-constructor 'cid))
 33 |            ...))]))
 34 | 
 35 | (define (valid-== ==) 
 36 |   (foldr
 37 |     (λ (pr s) 
 38 |       (and s (unify (car pr) (cdr pr) s)))
 39 |     '()
 40 |     ==))
 41 | 
 42 | #| Term ⨯ Term ⨯ Subst ⟶ Bool |#  
 43 | (define (same-s? u v s) (equal? (unify u v s) s))
 44 | 
 45 | #| Term ⨯ Term ⨯ Subst ⟶ Bool |#  
 46 | (define (mem? u v s)
 47 |   (let ((v (walk v s)))
 48 |     (or (same-s? u v s)
 49 |         (and (pair? v)
 50 |              (or (mem? u (car v) s)
 51 |                  (mem? u (cdr v) s))))))
 52 | 
 53 | #| Term ⨯ Subst ⟶ Bool |#  
 54 | (define (walk-to-end x s)
 55 |   (let ((x (walk x s)))
 56 |     (if (pair? x) (walk-to-end (cdr x) s) x)))
 57 | 
 58 | #| Nat ⟶ Var |#
 59 | (define (var n) n)
 60 | 
 61 | #| Term ⟶ Bool |#
 62 | (define (var? n) (number? n))
 63 | 
 64 | #| Var ⨯ Term ⨯ Subst ⟶ Bool |#  
 65 | (define (occurs? x v s)
 66 |   (let ((v (walk v s)))
 67 |     (cond
 68 |       ((var? v) (eqv? x v))
 69 |       ((pair? v) (or (occurs? x (car v) s)
 70 |                      (occurs? x (cdr v) s)))
 71 |       (else #f))))
 72 | 
 73 | #| Var ⨯ Term ⨯ Subst ⟶ Maybe Subst |#
 74 | (define (ext-s x v s) 
 75 |   (cond 
 76 |     ((occurs? x v s) #f) 
 77 |     (else `((,x . ,v) . ,s))))
 78 | 
 79 | #| Term ⨯ Subst ⟶ Term |#  
 80 | (define (walk u s)
 81 |   (let ((pr (assv u s)))
 82 |     (if pr (walk (cdr pr) s) u)))
 83 | 
 84 | #| Term ⨯ Term ⨯ Subst ⟶ Maybe Subst |#  
 85 | (define (unify u v s)
 86 |   (let ((u (walk u s)) (v (walk v s)))
 87 |     (cond
 88 |       ((eqv? u v) s)
 89 |       ((var? u) (ext-s u v s))
 90 |       ((var? v) (ext-s v u s))
 91 | ;o
 92 |       ((and (pair? u) (pair? v))
 93 |        (let ((s (unify (car u) (car v) s)))
 94 |          (and s (unify (cdr u) (cdr v) s))))
 95 |       (else #f))))
 96 | 
 97 | #| (Var ⟶ Goal) ⟶ State ⟶ Stream |#
 98 | (define ((call/fresh f) S/c)
 99 |   (let ((S (car S/c)) (c (cdr S/c)))
100 |     ((f (var c)) `(,S . ,(+ 1 c)))))
101 | 
102 | #| Stream ⟶ Stream ⟶ Stream |#
103 | (define ($append $1 $2)
104 |   (cond
105 |     ((null? $1) $2)
106 |     ((promise? $1) (delay/name ($append $2 (force $1))))
107 |     (else (cons (car $1) ($append (cdr $1) $2)))))
108 | 
109 | #| Goal ⟶ Stream ⟶ Stream |#
110 | (define ($append-map g $)
111 |   (cond
112 |     ((null? $) `())
113 |     ((promise? $) (delay/name ($append-map g (force $))))
114 |     (else ($append (g (car $)) ($append-map g (cdr $))))))
115 | 
116 | #| Goal ⟶ Goal ⟶ Goal |#
117 | (define ((disj g1 g2) S/c) ($append (g1 S/c) (g2 S/c)))
118 | 
119 | #| Goal ⟶ Goal ⟶ Goal |#
120 | (define ((conj g1 g2) S/c) ($append-map g2 (g1 S/c)))
121 | 
122 | #| Stream ⟶ Mature Stream |#
123 | (define (pull $) (if (promise? $) (pull (force $)) $))
124 | 
125 | #| Maybe Nat⁺ ⨯ Mature ⟶ List State |#
126 | (define (take n $)
127 |   (cond
128 |     ((null? $) '())
129 |     ((and n (zero? (- n 1))) (list (car (pull $))))
130 |     (else (cons (car $) 
131 |             (take (and n (- n 1)) (pull (cdr $)))))))
132 | 
133 | #| Maybe Nat⁺ ⨯ Goal ⟶ List State |#
134 | (define (call/initial-state n g)
135 |   (take n (pull (g `(,S0 . 0)))))
136 | 
137 | (define-syntax-rule (define-relation (rid . args) g)
138 |   (define ((rid . args) S/c) (delay/name (g S/c))))
139 | 
140 | (make-constraint-system 
141 |   (=/= absento symbolo not-pairo booleano listo)
142 |   (λ (s)
143 |     (ormap
144 |       (λ (pr) (same-s? (car pr) (cdr pr) s))
145 |       =/=))
146 |   (λ (s)
147 |     (ormap
148 |       (λ (pr) (mem? (car pr) (cdr pr) s))
149 |       absento))
150 |   (λ (s)
151 |     (ormap
152 |       (λ (y)
153 |         (let ((t (walk y s)))
154 |           (not (or (symbol? t) (var? t)))))
155 |       symbolo))
156 |   (λ (s)
157 |     (ormap
158 |       (λ (n)
159 |         (let ((t (walk n s)))
160 |           (not (or (not (pair? t)) (var? t)))))
161 |       not-pairo))
162 |   (let ((not-b
163 |           (λ (s)
164 |             (or (ormap
165 |                   (λ (pr) (same-s? (car pr) (cdr pr) s))
166 |                   =/=)
167 |                 (ormap
168 |                   (λ (pr) (mem? (car pr) (cdr pr) s))
169 |                   absento)))))
170 |     (λ (s)
171 |       (ormap
172 |         (λ (b)
173 |           (let ((s1 (unify b #t s)) (s2 (unify b #f s)))
174 |             (and s1 s2 (not-b s1) (not-b s2))))
175 |         booleano)))
176 |   (λ (s)
177 |     (ormap
178 |       (λ (b)
179 |         (let ((b (walk b s)))
180 |           (not (or (var? b) (boolean? b)))))
181 |       booleano))
182 |   (λ (s)
183 |     (ormap
184 |      (λ (b)
185 |        (ormap
186 |          (λ (y) (same-s? y b s))
187 |          symbolo))
188 |      booleano))
189 |   (λ (s)
190 |     (ormap
191 |       (λ (l)
192 |         (let ((end (walk-to-end l s)))
193 |           (ormap 
194 |             (λ (y) (same-s? y end s))
195 |             symbolo)))
196 |       listo))
197 |   (λ (s)
198 |     (ormap
199 |       (λ (l)
200 |         (let ((end (walk-to-end l s)))
201 |           (ormap 
202 |             (λ (b) (same-s? b end s))
203 |             booleano)))
204 |       listo))
205 |   (λ (s)
206 |     (ormap
207 |       (λ (l)
208 |         (let ((end (walk-to-end l s)))
209 |           (let ((s^ (unify end '() s)))
210 |             (and s^
211 |                  (ormap 
212 |                    (λ (n) (same-s? end n s))
213 |                    not-pairo)
214 |                  (or 
215 |                   (ormap 
216 |                     (λ (pr) (same-s? (car pr) (cdr pr) s^))
217 |                     =/=)
218 |                   (ormap 
219 |                     (λ (pr) (mem? (car pr) (cdr pr) s^))
220 |                     absento))))))
221 |       listo))
222 |   (λ (s)
223 |     (ormap
224 |       (λ (l)
225 |         (let ((end (walk-to-end l s)))
226 |           (ormap
227 |             (λ (pr) 
228 |               (and 
229 |                 (null? (walk (car pr) s)) 
230 |                 (mem? end (cdr pr) s)))
231 |             absento)))
232 |       listo)))
233 | 


--------------------------------------------------------------------------------
/single-file-system.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require (for-syntax syntax/parse))
  3 | (require (for-syntax racket/syntax))
  4 | (provide (all-defined-out))
  5 | 
  6 | ;; miniKanren online play-withable system
  7 | ;; microKanren constraints play-withable system
  8 | ;; Numbers system that uses booleans. 
  9 | 
 10 | (define (((make-constraint-goal-constructor key) . terms) S/c)
 11 |   (let ((S (ext-S (car S/c) key terms)))
 12 |     (if (invalid? S) '() (list `(,S . ,(cdr S/c))))))
 13 | 
 14 | (define (ext-S S key terms)
 15 |   (hash-update S key ((curry cons) (apply list* terms))))
 16 | 
 17 | (define-syntax-rule (make-invalid? (cid ...) p ...)
 18 |   (λ (S) 
 19 |     (let ((cid (hash-ref S 'cid)) ...)
 20 |       (cond
 21 |         ((valid-== (hash-ref S '==))
 22 |          => (λ (s) (or (p s) ...)))
 23 |         (else #t)))))
 24 | 
 25 | (define-syntax (make-constraint-system stx)
 26 |   (syntax-parse stx
 27 |     [(_ (cid:id ...) p ...)
 28 |      (with-syntax 
 29 |        ([invalid? (syntax-local-introduce #'invalid?)]
 30 |         [S0 (syntax-local-introduce #'S0)]
 31 |         [== (syntax-local-introduce #'==)])
 32 |        #'(begin 
 33 |            (define invalid? (make-invalid? (cid ...) p ...))
 34 |            (define S0
 35 |              (make-immutable-hasheqv '((==) (cid) ...)))
 36 |            (define == (make-constraint-goal-constructor '==))
 37 |            (define cid (make-constraint-goal-constructor 'cid))
 38 |            ...))]))
 39 | 
 40 | (define (valid-== ==) 
 41 |   (foldr
 42 |     (λ (pr s) 
 43 |       (and s (unify (car pr) (cdr pr) s)))
 44 |     '()
 45 |     ==))
 46 | 
 47 | #| Term ⨯ Term ⨯ Subst ⟶ Bool |#  
 48 | (define (same-s? u v s) (equal? (unify u v s) s))
 49 | 
 50 | #| Term ⨯ Term ⨯ Subst ⟶ Bool |#  
 51 | (define (mem? u v s)
 52 |   (let ((v (walk v s)))
 53 |     (or (same-s? u v s)
 54 |         (and (pair? v)
 55 |              (or (mem? u (car v) s)
 56 |                  (mem? u (cdr v) s))))))
 57 | 
 58 | #| Term ⨯ Subst ⟶ Bool |#  
 59 | (define (walk-to-end x s)
 60 |   (let ((x (walk x s)))
 61 |     (if (pair? x) (walk-to-end (cdr x) s) x)))
 62 | 
 63 | #| Nat ⟶ Var |#
 64 | (define (var n) n)
 65 | 
 66 | #| Term ⟶ Bool |#
 67 | (define (var? n) (number? n))
 68 | 
 69 | #| Var ⨯ Term ⨯ Subst ⟶ Bool |#  
 70 | (define (occurs? x v s)
 71 |   (let ((v (walk v s)))
 72 |     (cond
 73 |       ((var? v) (eqv? x v))
 74 |       ((pair? v) (or (occurs? x (car v) s)
 75 |                      (occurs? x (cdr v) s)))
 76 |       (else #f))))
 77 | 
 78 | #| Var ⨯ Term ⨯ Subst ⟶ Maybe Subst |#
 79 | (define (ext-s x v s) 
 80 |   (cond 
 81 |     ((occurs? x v s) #f) 
 82 |     (else `((,x . ,v) . ,s))))
 83 | 
 84 | #| Term ⨯ Subst ⟶ Term |#  
 85 | (define (walk u s)
 86 |   (let ((pr (assv u s)))
 87 |     (if pr (walk (cdr pr) s) u)))
 88 | 
 89 | #| Term ⨯ Term ⨯ Subst ⟶ Maybe Subst |#  
 90 | (define (unify u v s)
 91 |   (let ((u (walk u s)) (v (walk v s)))
 92 |     (cond
 93 |       ((eqv? u v) s)
 94 |       ((var? u) (ext-s u v s))
 95 |       ((var? v) (ext-s v u s))
 96 | ;o
 97 |       ((and (pair? u) (pair? v))
 98 |        (let ((s (unify (car u) (car v) s)))
 99 |          (and s (unify (cdr u) (cdr v) s))))
100 |       (else #f))))
101 | 
102 | #| (Var ⟶ Goal) ⟶ State ⟶ Stream |#
103 | (define ((call/fresh f) S/c)
104 |   (let ((S (car S/c)) (c (cdr S/c)))
105 |     ((f (var c)) `(,S . ,(+ 1 c)))))
106 | 
107 | #| Stream ⟶ Stream ⟶ Stream |#
108 | (define ($append $1 $2)
109 |   (cond
110 |     ((null? $1) $2)
111 |     ((promise? $1) (delay/name ($append $2 (force $1))))
112 |     (else (cons (car $1) ($append (cdr $1) $2)))))
113 | 
114 | #| Goal ⟶ Stream ⟶ Stream |#
115 | (define ($append-map g $)
116 |   (cond
117 |     ((null? $) `())
118 |     ((promise? $) (delay/name ($append-map g (force $))))
119 |     (else ($append (g (car $)) ($append-map g (cdr $))))))
120 | 
121 | #| Goal ⟶ Goal ⟶ Goal |#
122 | (define ((disj g1 g2) S/c) ($append (g1 S/c) (g2 S/c)))
123 | 
124 | #| Goal ⟶ Goal ⟶ Goal |#
125 | (define ((conj g1 g2) S/c) ($append-map g2 (g1 S/c)))
126 | 
127 | #| Stream ⟶ Mature Stream |#
128 | (define (pull $) (if (promise? $) (pull (force $)) $))
129 | 
130 | #| Maybe Nat⁺ ⨯ Mature ⟶ List State |#
131 | (define (take n $)
132 |   (cond
133 |     ((null? $) '())
134 |     ((and n (zero? (- n 1))) (list (car (pull $))))
135 |     (else (cons (car $) 
136 |             (take (and n (- n 1)) (pull (cdr $)))))))
137 | 
138 | #| Maybe Nat⁺ ⨯ Goal ⟶ List State |#
139 | (define (call/initial-state n g)
140 |   (take n (pull (g `(,S0 . 0)))))
141 | 
142 | (define-syntax-rule (define-relation (rid . args) g)
143 |   (define ((rid . args) S/c) (delay/name (g S/c))))
144 | 
145 | (make-constraint-system 
146 |   (=/= absento symbolo not-pairo booleano listo)
147 |   (λ (s)
148 |     (ormap
149 |       (λ (pr) (same-s? (car pr) (cdr pr) s))
150 |       =/=))
151 |   (λ (s)
152 |     (ormap
153 |       (λ (pr) (mem? (car pr) (cdr pr) s))
154 |       absento))
155 |   (λ (s)
156 |     (ormap
157 |       (λ (y)
158 |         (let ((t (walk y s)))
159 |           (not (or (symbol? t) (var? t)))))
160 |       symbolo))
161 |   (λ (s)
162 |     (ormap
163 |       (λ (n)
164 |         (let ((t (walk n s)))
165 |           (not (or (not (pair? t)) (var? t)))))
166 |       not-pairo))
167 |   (let ((not-b
168 |           (λ (s)
169 |             (or (ormap
170 |                   (λ (pr) (same-s? (car pr) (cdr pr) s))
171 |                   =/=)
172 |                 (ormap
173 |                   (λ (pr) (mem? (car pr) (cdr pr) s))
174 |                   absento)))))
175 |     (λ (s)
176 |       (ormap
177 |         (λ (b)
178 |           (let ((s1 (unify b #t s)) (s2 (unify b #f s)))
179 |             (and s1 s2 (not-b s1) (not-b s2))))
180 |         booleano)))
181 |   (λ (s)
182 |     (ormap
183 |       (λ (b)
184 |         (let ((b (walk b s)))
185 |           (not (or (var? b) (boolean? b)))))
186 |       booleano))
187 |   (λ (s)
188 |     (ormap
189 |      (λ (b)
190 |        (ormap
191 |          (λ (y) (same-s? y b s))
192 |          symbolo))
193 |      booleano))
194 |   (λ (s)
195 |     (ormap
196 |       (λ (l)
197 |         (let ((end (walk-to-end l s)))
198 |           (ormap 
199 |             (λ (y) (same-s? y end s))
200 |             symbolo)))
201 |       listo))
202 |   (λ (s)
203 |     (ormap
204 |       (λ (l)
205 |         (let ((end (walk-to-end l s)))
206 |           (ormap 
207 |             (λ (b) (same-s? b end s))
208 |             booleano)))
209 |       listo))
210 |   (λ (s)
211 |     (ormap
212 |       (λ (l)
213 |         (let ((end (walk-to-end l s)))
214 |           (let ((s^ (unify end '() s)))
215 |             (and s^
216 |                  (ormap 
217 |                    (λ (n) (same-s? end n s))
218 |                    not-pairo)
219 |                  (or 
220 |                   (ormap 
221 |                     (λ (pr) (same-s? (car pr) (cdr pr) s^))
222 |                     =/=)
223 |                   (ormap 
224 |                     (λ (pr) (mem? (car pr) (cdr pr) s^))
225 |                     absento))))))
226 |       listo))
227 |   (λ (s)
228 |     (ormap
229 |       (λ (l)
230 |         (let ((end (walk-to-end l s)))
231 |           (ormap
232 |             (λ (pr) 
233 |               (and 
234 |                 (null? (walk (car pr) s)) 
235 |                 (mem? end (cdr pr) s)))
236 |             absento)))
237 |       listo)))
238 | 
239 | 
240 | (define-syntax disj+
241 |   (syntax-rules ()
242 |     ((_ g) g)
243 |     ((_ g0 g ...) (disj g0 (disj+ g ...)))))
244 | 
245 | (define-syntax conj+
246 |   (syntax-rules ()
247 |     ((_ g) g)
248 |     ((_ g0 g ...) (conj g0 (conj+ g ...)))))
249 | 
250 | (define-syntax-rule (conde (g0 g ...) (g0* g* ...) ...)
251 |   (disj+ (conj+ g0 g ...) (conj+ g0* g* ...) ...))
252 |      
253 | (define-syntax ifte*
254 |   (syntax-rules ()
255 |     ((_ g) g)
256 |     ((_ (g0 g1) (g0* g1*) ... g)
257 |      (ifte g0 g1 (ifte* (g0* g1*) ... g)))))
258 |      
259 | (define-syntax-rule (conda (g0 g1 g ...) ... (gn0 gn ...))
260 |   (ifte* (g0 (conj+ g1 g ...)) ... (conj+ gn0 gn ...)))
261 | 
262 | (define-syntax-rule (condu (g0 g1 g ...) ... (gn0 gn ...))
263 |   (conda ((once g0) g ...) ... ((once gn0) gn ...)))
264 |   
265 | (define ((ifte g0 g1 g2) s/c)
266 |   (let loop (($ (g0 s/c)))
267 |     (cond
268 |      ((null? $) (g2 s/c))
269 |      ((promise? $) (delay/name (loop (force $))))
270 |      (else ($append-map g1 $)))))
271 |      
272 | (define ((once g) s/c)
273 |   (let loop (($ (g s/c)))
274 |     (cond
275 |      ((null? $) '())
276 |      ((promise? $) (delay/name (loop (force $))))
277 |      (else (list (car $))))))
278 | 
279 | (define (apply-subst v s)
280 |   (let ((v (walk v s)))
281 |     (cond
282 |       ((var? v) v)
283 |       ((pair? v) (cons (apply-subst (car v) s)
284 |                        (apply-subst (cdr v) s)))
285 |       (else v))))
286 | 
287 | (define (build-r v s c)
288 |   (cond
289 |     ((var? v) `((,v . ,(+ (length s) c)) . ,s))
290 |     ((pair? v) (build-r (cdr v) (build-r (car v) s c) c))
291 |     (else s)))
292 | 
293 | (define (project-var0 s/c)
294 |   (let ((v (apply-subst (var 0) (car s/c))))
295 |     (let ((v (apply-subst v (build-r v '() (cdr s/c)))))
296 |       (apply-subst v (build-r v '() 0)))))
297 | 
298 | (define-syntax-rule (run n (q) g0 g ...)
299 |   (call/initial-state n (fresh (q) g0 g ...)))
300 | 
301 | (define-syntax fresh
302 |   (syntax-rules ()
303 |     ((_ () g0 g ...) (conj+ g0 g ...))
304 |     ((_ (x0 x ...) g0 g ...)
305 |      (call/fresh (lambda (x0) (fresh (x ...) g0 g ...))))))
306 | 
307 | ;; (define-syntax-rule (program-and-query ((n (λ args gexp)) ...) q)
308 | ;;   (letrec ((n (λ args (λ (s/c) (delay/name (gexp s/c))))) ...) q))
309 | 
310 | (define syntax->list
311 |   (lambda (e)
312 |     (syntax-case e ()
313 |       [() '()]
314 |       [(x . r) (cons #'x (syntax->list #'r))])))
315 | 
316 | (define-syntax defmatche
317 |   (lambda (stx)
318 |     (syntax-case stx ()
319 |       [(defmatche (name args ...) clause ...)
320 |        #'(define-relation (name args ...)
321 |            (matche (args ...) clause ...))])))
322 | 
323 | (define-syntax lambdae
324 |   (syntax-rules ()
325 |     ((_ (x ...) c c* ...)
326 |      (lambda (x ...) (matche (x ...) c c* ...)))))
327 | 
328 | (define-syntax matche
329 |   (lambda (stx)    
330 |     (syntax-case stx ()
331 |       [(matche (v ...) ([pat ...] g ...) ...)
332 |        (let ()
333 |          (define remove-duplicates
334 |            (lambda (ls eq-pred)
335 |              (cond
336 |                [(null? ls) '()]
337 |                [(memf (lambda (x) (eq-pred (car ls) x)) (cdr ls))
338 |                 (remove-duplicates (cdr ls) eq-pred)]
339 |                [else (cons (car ls) (remove-duplicates (cdr ls) eq-pred))])))
340 |          (define parse-pattern
341 |            (lambda (args pat)
342 |              (syntax-case #`(#,args #,pat) ()
343 |                [(() ()) #'(() () ())]
344 |                [((a args ...) [p pat ...])
345 |                 (with-syntax ([(p^ (c ...) (x ...))
346 |                                (parse-patterns-for-arg #'a #'p)])
347 |                   (with-syntax ([([pat^ ...] (c^ ...) (x^ ...))
348 |                                  (parse-pattern #'(args ...) #'[pat ...])])
349 |                     #'([p^ pat^ ...] (c ... c^ ...) (x ... x^ ...))))]
350 |                [x (error 'parse-pattern "bad syntax ~s ~s" args pat)])))
351 |          (define parse-patterns-for-arg
352 |            (lambda (v pat)
353 |              (define loop
354 |                (lambda (pat)
355 |                  (syntax-case pat (unquote ?? ?) ; ?? is the new _, since _ isn't legal in R6
356 |                    [(unquote ??)
357 |                     (with-syntax ([_new (generate-temporary #'?_)])
358 |                       #'((unquote _new) () (_new)))]
359 |                    [(unquote x)
360 |                     (when (free-identifier=? #'x v)
361 |                       (error 'matche "argument ~s appears in pattern at an invalid depth"
362 |                              (syntax->datum #'x)))
363 |                     #'((unquote x) () (x))]
364 |                    [(unquote (? c x))
365 |                     (when (free-identifier=? #'x v)
366 |                       (error 'matche "argument ~s appears in pattern at an invalid depth"
367 |                              (syntax->datum #'x)))
368 |                     #'((unquote x) ((c x)) (x))]
369 |                    [(a . d)
370 |                     (with-syntax ([((pat1 (c1 ...) (x1 ...))
371 |                                     (pat2 (c2 ...) (x2 ...)))
372 |                                    (map loop (syntax->list #'(a d)))])
373 |                       #'((pat1 . pat2) (c1 ... c2 ...) (x1 ... x2 ...)))]
374 |                    [x #'(x () ())])))
375 |              (syntax-case pat (unquote ?)
376 |                [(unquote u)
377 |                 (cond
378 |                   [(and (identifier? #'u)
379 |                         (free-identifier=? v #'u))
380 |                    #'((unquote u) () ())]
381 |                   [else (loop pat)])]
382 |                [(unquote (? c u))
383 |                 (cond
384 |                   [(and (identifier? #'u)
385 |                         (free-identifier=? v #'u))
386 |                    #'((unquote u) ((c x)) ())]
387 |                   [else (loop pat)])]
388 |                [else (loop pat)])))
389 |          (unless
390 |              (andmap (lambda (y) (= (length (syntax->datum #'(v ...))) (length y)))
391 |                      (syntax->datum #'([pat ...] ...)))
392 |            (error 'matche "pattern wrong length blah"))
393 |          (with-syntax ([(([pat^ ...] (c ...) (x ...)) ...)
394 |                         (map (lambda (y) (parse-pattern #'(v ...) y))
395 |                              (syntax->list #'([pat ...] ...)))])
396 |            (with-syntax ([((x^ ...) ...)
397 |                           (map (lambda (ls)
398 |                                  (remove-duplicates (syntax->list ls) free-identifier=?))
399 |                                (syntax->list #'((x ...) ...)))])
400 |              (with-syntax ([body
401 |                             #'(conde
402 |                                 [(fresh (x^ ...) c ... (== `[pat^ ...] ls) g ...)]
403 |                                 ...)])
404 |                #'(let ([ls (list v ...)]) body)))))]
405 |       [(matche v (pat g ...) ...)
406 |        #'(matche (v) ([pat] g ...) ...)])))
407 | 
408 | (defmatche (append l₁ l₂ l₁++l₂)
409 |   ((() ,b ,b))
410 |   (((,h . ,t₁) ,b (,h . ,t₂)) (append t₁ b t₂)))
411 | 
412 | (defmatche (nrev l₁ l₂) 
413 |   ((() ()))
414 |   (((,h . ,t) ,l₂) 
415 |    (fresh (r)
416 |      (nrev t r) (append r `(,h) l₂))))
417 | 
418 | (let ((u/v* (hash-ref (caar (run 1 (q) (nrev '(a b c) q))) '==)))
419 |   (let ((u* (map car u/v*))
420 |         (v* (map cdr u/v*)))
421 |     (project-var0 (cons (unify u* v* '()) 25))))
422 | 


--------------------------------------------------------------------------------