Selaa lähdekoodia

add code from µKanren paper.

at least as far as i read it.
Lucas Stadler 12 vuotta sitten
vanhempi
commit
8c28359d39
1 muutettua tiedostoa jossa 81 lisäystä ja 0 poistoa
  1. 81 0
      scm/mukanren.scm

+ 81 - 0
scm/mukanren.scm

@ -0,0 +1,81 @@
1
; µKanren - http://webyrd.net/scheme-2013/papers/HemannMuKanren2013.pdf
2
3
; to use this in guile: ,import (rnrs lists)
4
5
(define empty-state '(() . 0))
6
7
(define (var x)  (vector x))
8
(define (var? x) (vector? x))
9
(define (var=? x y) (= (vector-ref x 0) (vector-ref y 0)))
10
11
(define (walk u s)
12
  (let ((pr (and (var? u) (assp (lambda (v) (var=? u v)) s))))
13
    (if pr (walk (cdr pr) s) u))) ; recursion b/c vars can refer to other vars?
14
15
(define (ext-s x v s) `((,x . ,v) . ,s))
16
17
(define (≡ u v)
18
  (lambda (s/c)
19
    (let ((s (unify u v (car s/c))))
20
      (if s (unit `(,s . ,(cdr s/c))) mzero))))
21
22
(define (unit s/c) (cons s/c mzero))
23
(define mzero '())
24
25
(define (unify u v s)
26
  (let ((u (walk u s)) (v (walk v s)))
27
    (cond
28
      ((and (var? u) (var? v) (var=? u v)) s)
29
      ((var? u) (ext-s u v s))
30
      ((var? v) (ext-s v u s))
31
      ((and (pair? u) (pair? v))
32
       (let ((s (unify (car u) (car v) s)))
33
         (and s (unify (cdr u) (cdr v) s))))
34
      (else (and (eqv? u v) s)))))
35
36
(define (call/fresh f)
37
  (lambda (s/c)
38
    (let ((c (cdr s/c)))
39
      ((f (var c)) `(,(car s/c) . ,(+ c 1))))))
40
41
(define (disj g1 g2) (lambda (s/c) (mplus (g1 s/c) (g2 s/c))))
42
(define (conj g1 g2) (lambda (s/c) (bind (g1 s/c) g2)))
43
44
;; 4.1 finite depth first search
45
46
(define (mplus $1 $2)
47
  (cond
48
    ((null? $1) $2)
49
    (else (cons (car $1) (mplus (cdr $1) $2)))))
50
51
(define (bind $ g)
52
  (cond
53
    ((null? $) mzero)
54
    (else (mplus (g (car $)) (bind (cdr $) g)))))
55
56
; is this a concept or a real example?
57
(define (fives x) (disj (≡ x 5) (fives x)))
58
;((call/fresh fives) empty-state) ;=> infinite loop
59
60
((call/fresh (lambda (v) (disj (≡ v 0) (≡ v 42)))) empty-state)
61
62
;; 4.2 infinite streams
63
64
(define (mplus $1 $2)
65
  (cond
66
    ((null? $1) $2)
67
    ((procedure? $1) (lambda () (mplus ($1) $2)))
68
    (else (cons (car $1) (mplus (cdr $1) $2)))))
69
70
(define (bind $ g)
71
  (cond
72
    ((null? $) mzero)
73
    ((procedure? $) (lambda () (bind ($) g)))
74
    (else (mplus (g (car $)) (bind (cdr $) g)))))
75
76
(define (fives x)
77
  (disj (≡ x 5) (lambda (s/c) (lambda () ((fives x) s/c)))))
78
79
((call/fresh fives) empty-state)
80
81
;; 4.3 interleaved streams