forked from calvis/cKanren
-
Notifications
You must be signed in to change notification settings - Fork 4
/
never-true.scm
62 lines (51 loc) · 1.46 KB
/
never-true.scm
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
54
55
56
57
58
59
60
61
62
(library
(cKanren never-true)
(export never-trueo never-pairo requiredo allowedo)
(import (rnrs) (cKanren ck))
(define never-true-c
(lambda (pred? x)
(lambdam@ (a : s c)
(let ((x (walk x s)))
(cond
((pred? x) #f)
(else ((update-c (build-oc never-true-c pred? x)) a)))))))
(define never-trueo
(lambda (pred? x)
(goal-construct (never-true-c pred? x))))
(define never-pairo
(lambda (x)
(never-trueo pair? x)))
(define requiredo
(lambda (pred? x)
(goal-construct (required-c pred? x))))
(define required-c
(lambda (pred? x)
(lambdam@ (a : s c)
(let ((x (walk* x s)))
(cond
((pred? x) a)
(else ((update-c (build-oc required-c pred? x)) a)))))))
(define required-enforceo
(lambda (x)
(goal-construct
(lambdam@ (a : s c)
(and (not (find (lambda (oc) (eq? 'required-c (oc->rator oc))) c))
a)))))
(define allowedo
(lambda (pred? x)
(goal-construct (allowed-c pred? x))))
(define allowed-c
(lambda (pred? x)
(lambdam@ (a : s c)
(let ((x (walk* x s)))
(cond
((pred? x) a)
(else ((update-c (build-oc allowed-c pred? x)) a)))))))
(define reified-allowed
(lambda (v r c)
(let ((c (filter (lambda (oc) (eq? (oc->rator oc) 'allowed-c)) c)))
(let ((c (walk* (map oc->rands c) r)))
`((allowed . ,c))))))
(extend-enforce-fns 'required required-enforceo)
(extend-reify-fns 'allowed reified-allowed)
)