staged-miniKanren/tests/applications/metamk.rkt at main · namin/staged-miniKanren · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
#lang racket/base

(require racket/pretty
         "../../all.rkt")

;; simplified https://github.com/namin/metamk/blob/master/cycler-tests.scm
;; Prolog-style meta-interpreters in miniKanren

(defrel/staged/fallback (edgeo x y)
  (conde
    ((== x 'a) (== y 'b))
    ((== x 'b) (== y 'c))
    ((== x 'c) (== y 'a))))

(defrel/staged/fallback (clause head tail)
  (fresh (x y)
    (== head `(patho ,x ,y))
    (conde
      ((edgeo x y) (== tail '()))
      ((fresh (z)
         (edgeo x z)
         (== tail `((patho ,z ,y))))))))

(defrel/staged/fallback (solve* goals trace-in trace-out)
  (conde
    ((== goals '())
     (== trace-in trace-out))
    ((fresh (first-goal other-goals first-body trace-out-body)
       (== (cons first-goal other-goals) goals)
       (absento first-goal trace-in)
       (clause first-goal first-body)
       (solve* first-body (cons first-goal trace-in) trace-out-body)
       (solve* other-goals trace-out-body trace-out)))))

(defrel/staged/fallback (cycler* goals trace)
  (solve* goals '()  trace))

(defrel/staged/fallback (cycler goal trace)
  (cycler* (list goal) trace))

(run* (q)
  (fresh (head tail)
    (== q `(to prove ,head prove ,tail))
    (clause head tail)))

(run* (x y t)
  (cycler `(patho ,x ,y) t))

(run 1 (t)
  (staged
   (cycler `(patho c c) t)))

(pretty-print (generated-code))