source: project/chicken/tags/0.1071/examples/schelog-macros.scm @ 17995

Last change on this file since 17995 was 17995, checked in by felix winkelmann, 9 years ago

imported historic version of chicken (0.1071)

File size: 3.7 KB
Line 
1;;;; schelog-macros.scm
2
3
4;%let introduces new logic variables
5
6(define-macro (%let xx . ee)
7  `(let ,(map (lambda (x) `(,x (schelog:make-ref))) xx)
8     ,@ee))
9
10
11;disjunction
12
13(define-macro (%or . gg)
14  `(lambda (__fk)
15     (call-with-current-continuation
16      (lambda (__sk)
17        ,@(map (lambda (g)
18                 `(call-with-current-continuation
19                   (lambda (__fk)
20                     (__sk ((schelog:deref* ,g) __fk)))))
21               gg)
22        (__fk 'fail)))))
23
24;conjunction
25
26(define-macro (%and . gg)
27  `(lambda (__fk)
28     (let* ,(map (lambda (g) `(__fk ((schelog:deref* ,g) __fk))) gg)
29       __fk)))
30
31;cut
32
33(define-macro (%cut-delimiter g)
34    `(lambda (__fk)
35       (let ((! (lambda (__fk2) __fk)))
36         ((schelog:deref* ,g) __fk))))
37
38
39;Prolog-like sugar
40
41(define-macro (%rel vv . cc)
42    `(lambda __fmls
43       (lambda (__fk)
44         (call-with-current-continuation
45          (lambda (__sk)
46            (let ((! (lambda (fk1) __fk)))
47              (%let ,vv
48                    ,@(map (lambda (c)
49                             `(call-with-current-continuation
50                               (lambda (__fk)
51                                 (let* ((__fk ((%=/2 __fmls (list ,@(car c))) __fk))
52                                        ,@(map (lambda (sg)
53                                                 `(__fk ((schelog:deref* ,sg) __fk)))
54                                               (cdr c)))
55                                   (__sk __fk)))))
56                           cc)
57                    (__fk 'fail))))))))
58
59
60;for structures ("functors"), use Scheme's list and vector
61;functions and anything that's built using them.
62
63;arithmetic
64
65(define-macro (%is/2 v e)
66    (letrec ((%is-help (lambda (e fk)
67                         (cond ((pair? e)
68                                (cond ((eq? (car e) 'quote) e)
69                                      (else
70                                       (map (lambda (e1)
71                                              (%is-help e1 fk)) e))))
72                               (else
73                                `(if (and (schelog:ref? ,e)
74                                          (schelog:unbound-ref? ,e))
75                                     (,fk 'fail) (schelog:deref* ,e)))))))
76      `(lambda (__fk)
77         ((%=/2 ,v ,(%is-help e '__fk)) __fk))))
78
79(define-macro (%assert rel-name vv . cc)
80    `(set! ,rel-name
81           (let ((__old-rel ,rel-name)
82                 (__new-addition (%rel ,vv ,@cc)))
83             (lambda __fmls
84               (%or (apply __old-rel __fmls)
85                    (apply __new-addition __fmls))))))
86
87(define-macro (%assert-a rel-name vv . cc)
88    `(set! ,rel-name
89           (let ((__old-rel ,rel-name)
90                 (__new-addition (%rel ,vv ,@cc)))
91             (lambda __fmls
92               (%or (apply __new-addition __fmls)
93                    (apply __old-rel __fmls))))))
94
95(define-macro (%free-vars vv g)
96    `(cons 'schelog:goal-with-free-vars
97           (cons (list ,@vv) ,g)))
98
99;user interface
100
101;(%which (v ...) query) returns #f if query fails and instantiations
102;of v ... if query succeeds.  In the latter case, type (%more) to
103;retry query for more instantiations.
104
105(define-macro (%which vv g)
106    `(%let ,vv
107           (call-with-current-continuation
108            (lambda (__qk)
109              (set! schelog:*more-k* __qk)
110              (set! schelog:*more-fk*
111                    ((schelog:deref* ,g)
112                     (lambda (d)
113                       (set! schelog:*more-fk* #f)
114                       (schelog:*more-k* #f))))
115              (schelog:*more-k*
116               (map (lambda (nam val) (list nam (schelog:deref* val)))
117                    ',vv
118                    (list ,@vv)))))))
119
120; deprecated names -- retained here for backward-compatibility
121
122(define-macro (%cut . e)
123    `(%cut-delimiter ,@e))
124
125(define-macro (%exists vv g) g)
Note: See TracBrowser for help on using the repository browser.