1 files changed, 140 insertions, 0 deletions
diff --git a/scheme/uk.scm b/scheme/uk.scm
new file mode 100644
index 0000000..6d2a0f4
--- /dev/null
+++ b/scheme/uk.scm
@@ -0,0 +1,140 @@
+
+; microKanren core from 2013 microKanren paper
+
+; http://webyrd.net/scheme-2013/papers/HemannMuKanren2013.pdf
+
+
+(import (rnrs lists))
+
+
+(define (var c) (vector c))
+(define (var? x) (vector? x))
+(define (var=? x1 x2) (= (vector-ref x1 0) (vector-ref x2 0)))
+
+(define (walk u s)
+  (let ((pr (and (var? u) (assp (lambda (v) (var=? u v)) s))))
+    (if pr (walk (cdr pr) s) u)))
+
+(define (ext-s x v s) `((,x . ,v) . ,s))
+
+(define (== u v)
+  (lambda (sc)
+    (let ((s (unify u v (car sc))))
+      (if s (unit `(,s . ,(cdr sc))) mzero))))
+
+(define (unit sc) (cons sc mzero))
+(define mzero '())
+
+(define (unify u v s)
+  (let ((u (walk u s))
+        (v (walk v s)))
+    (cond
+      ((and (var? u) (var? v) (var=? u v)) s)
+      ((var? u) (ext-s u v s))
+      ((var? v) (ext-s v u s))
+      ((and (pair? u) (pair? v))
+        (let ((s (unify (car u) (car v) s)))
+          (and s (unify (cdr u) (cdr v) s))))
+      (else (and (eqv? u v) s)))))
+
+(define (call/fresh f)
+  (lambda (sc)
+    (let ((c (cdr sc)))
+      ((f (var c)) `(,(car sc) . ,(+ c 1))))))
+
+(define (disj g1 g2) (lambda (sc) (mplus (g1 sc) (g2 sc))))
+(define (conj g1 g2) (lambda (sc) (bind (g1 sc) g2)))
+
+(define (mplus s1 s2)
+  (cond
+    ((null? s1) s2)
+    ((procedure? s1) (lambda () (mplus s2 (s1))))
+    (else (cons (car s1) (mplus (cdr s1) s2)))))
+
+(define (bind s g)
+  (cond
+    ((null? s) mzero)
+    ((procedure? s) (lambda () (bind (s) g)))
+    (else (mplus (g (car s)) (bind (cdr s) g)))))
+
+(define-syntax zzz
+  (syntax-rules ()
+    ((_ g) (lambda (sc) (lambda () (g sc))))))
+
+(define-syntax conj+
+  (syntax-rules ()
+    ((_ g) (zzz g))
+    ((_ g0 g ...) (conj (zzz g0) (conj+ g ...)))))
+
+(define-syntax disj+
+  (syntax-rules ()
+    ((_ g) (zzz g))
+    ((_ g0 g ...) (disj (zzz g0) (disj+ g ...)))))
+
+(define-syntax conde
+  (syntax-rules ()
+    ((_ (g0 g ...) ...) (disj+ (conj+ g0 g ...) ...))))
+
+(define-syntax fresh
+  (syntax-rules ()
+    ((_ () g0 g ...) (conj+ g0 g ...))
+    ((_ (x0 x ...) g0 g ...)
+      (call/fresh (lambda (x0) (fresh (x ...) g0 g ...))))))
+
+(define (pull s) (if (procedure? s) (pull (s)) s))
+
+(define (take-all s)
+  (let ((s (pull s)))
+    (if (null? s) '() (cons (car s) (take-all (cdr s))))))
+
+(define (take n s)
+  (if (zero? n) '()
+    (let ((s (pull s)))
+      (cond
+        ((null? s) '())
+        (else (cons (car s) (take (- n 1) (cdr s))))))))
+
+(define (mk-reify sc*)
+  (map reify-state/1st-var sc*))
+
+(define (reify-state/1st-var sc)
+  (let ((v (walk* (var 0) (car sc))))
+    (walk* v (reify-s v '()))))
+
+(define (reify-s v s)
+  (let ((v (walk v s)))
+    (cond
+      ((var? v)
+        (let ((n (reify-name (length s))))
+          (cons `(,v . ,n) s)))
+      ((pair? v) (reify-s (cdr v) (reify-s (car v) s)))
+      (else s))))
+
+(define (reify-name n)
+  (string->symbol
+    (string-append "_" "." (number->string n))))
+
+(define (walk* v s)
+  (let ((v (walk v s)))
+    (cond
+      ((var? v) v)
+      ((pair? v) (cons (walk* (car v) s) (walk* (cdr v) s)))
+      (else v))))
+
+(define empty-state '(() . 0))
+(define (call/empty-state g) (g empty-state))
+
+(define-syntax run
+  (syntax-rules ()
+    ((_ n (x ...) g0 g ...)
+      (mk-reify (take n (call/empty-state (fresh (x ...) g0 g ...)))))))
+
+(define-syntax run*
+  (syntax-rules ()
+    ((_ (x ...) g0 g ...)
+      (mk-reify (take-all (call/empty-state (fresh (x ...) g0 g ...)))))))
+
+(define succeed (== #f #f))
+(define fail (== #f #t))
+
+