121 lines
3.7 KiB
Scheme
121 lines
3.7 KiB
Scheme
(import (scheme base)
|
|
(scheme lazy)
|
|
(scheme write)
|
|
(picrin logic)
|
|
(picrin test))
|
|
|
|
(define-syntax Zzz
|
|
(syntax-rules ()
|
|
((_ g) (lambda (s/c) (lambda () (g s/c))))))
|
|
|
|
(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 fresh
|
|
(syntax-rules ()
|
|
((_ () g0 g ...) (conj+ g0 g ...))
|
|
((_ (x0 x ...) g0 g ...)
|
|
(call/fresh
|
|
(lambda (x0)
|
|
(fresh (x ...) g0 g ...))))))
|
|
|
|
(define-syntax conde
|
|
(syntax-rules ()
|
|
((_ (g0 g ...) ...) (disj+ (conj+ g0 g ...) ...))))
|
|
|
|
(define-syntax run
|
|
(syntax-rules ()
|
|
((_ n (x ...) g0 g ...)
|
|
(run-goal n (fresh (x ...) g0 g ...)))))
|
|
|
|
(define-syntax run*
|
|
(syntax-rules ()
|
|
((_ (x ...) g0 g ...)
|
|
(run-goal* (fresh (x ...) g0 g ...)))))
|
|
|
|
(define (appendo l s out)
|
|
(conde
|
|
((is '() l) (is s out))
|
|
((fresh (a d res)
|
|
(is `(,a . ,d) l)
|
|
(is `(,a . ,res) out)
|
|
(appendo d s res)))))
|
|
|
|
(test '((() (1 2 3 4 5))
|
|
((1) (2 3 4 5))
|
|
((1 2) (3 4 5))
|
|
((1 2 3) (4 5))
|
|
((1 2 3 4) (5))
|
|
((1 2 3 4 5) ()))
|
|
(run* (q) (fresh (x y) (is `(,x ,y) q) (appendo x y '(1 2 3 4 5)))))
|
|
|
|
(test '((() (1 2 3 4 5))
|
|
((1) (2 3 4 5))
|
|
((1 2) (3 4 5))
|
|
((1 2 3) (4 5))
|
|
((1 2 3 4) (5))
|
|
((1 2 3 4 5) ()))
|
|
(run* (q x y) (is `(,x ,y) q) (appendo x y '(1 2 3 4 5))))
|
|
|
|
(test '((1 2 8 3 4 5)
|
|
(1 2 8 3 4 5 8)
|
|
(1 2 8 3 4 8 5)
|
|
(1 2 8 3 8 4 5)
|
|
(1 2 8 8 3 4 5)
|
|
(1 2 8 8 3 4 5)
|
|
(1 8 2 8 3 4 5)
|
|
(8 1 2 8 3 4 5))
|
|
(letrec
|
|
((rember*o (lambda (tr o)
|
|
(conde
|
|
((is '() tr) (is '() o))
|
|
((fresh (a d)
|
|
(is `(,a . ,d) tr)
|
|
(conde
|
|
((fresh (aa da)
|
|
(is `(,aa . ,da) a)
|
|
(fresh (a^ d^)
|
|
(rember*o a a^)
|
|
(rember*o d d^)
|
|
(is `(,a^ . ,d^) o))))
|
|
((is a 8) (rember*o d o))
|
|
((fresh (d^)
|
|
(rember*o d d^)
|
|
(is `(,a . ,d^) o))))))))))
|
|
(run 8 (q) (rember*o q '(1 2 8 3 4 5)))))
|
|
|
|
(test '((1 (2 8 3 4) 5)
|
|
(1 (2 8 3 4) 5 8)
|
|
(1 (2 8 3 4) 5 8 8)
|
|
(1 (2 8 3 4) 8 5)
|
|
(1 8 (2 8 3 4) 5)
|
|
(8 1 (2 8 3 4) 5)
|
|
(1 (2 8 3 4) 5 8 8 8)
|
|
(1 (2 8 3 4) 5 8 8 8 8)
|
|
(1 (2 8 3 4) 5 8 8 8 8 8))
|
|
(letrec
|
|
((rember*o (lambda (tr o)
|
|
(conde
|
|
((is '() tr) (is '() o))
|
|
((fresh (a d)
|
|
(is `(,a . ,d) tr)
|
|
(conde
|
|
((fresh (aa da)
|
|
(is `(,aa . ,da) a)
|
|
(fresh (a^ d^)
|
|
(is `(,a^ . ,d^) o)
|
|
(rember*o d d^)
|
|
(rember*o a a^))))
|
|
((is a 8) (rember*o d o))
|
|
((fresh (d^)
|
|
(is `(,a . ,d^) o)
|
|
(rember*o d d^))))))))))
|
|
(run 9 (q) (rember*o q '(1 (2 8 3 4) 5)))))
|