new proper guile-kanren test-suite and fixed tr

parent cdd9a66c
......@@ -26,10 +26,12 @@
(lambda (x)
(syntax-case x ()
((_ n . l)
#'(begin
(define-syntax n . l)
(define-values ()
(begin
(free-id-table-set! *guile-log-macros* #'n #t)
(values))))))))
(begin
(free-id-table-set! *guile-log-macros* #'n #t)
#'(begin
(define-syntax n . l)
(define-values ()
(begin
(free-id-table-set! *guile-log-macros* #'n #t)
(values)))))))))
......@@ -148,7 +148,7 @@
r)
(begin
(n-ret-set! (- n 1)
(cons (list (tr (u-scm v)) ...) ret))
(cons (tr (list (u-scm v) ...)) ret))
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
......@@ -481,11 +481,11 @@
(define-syntax <ask>
(syntax-rules ()
((_ code ...)
(umatch #:tag <next> #:name '<ask> ()
((prompt=> (pr <next>)
(parse<> (pr <next> pr (lambda x #t))
(<and> code ...))))
(#f)))))
(let ((cc (lambda (p) #t))
(p (lambda () #f)))
(gp-clear)
(<with-guile-log> (p cc)
(<and> code ...))))))
(define-syntax <define>
(syntax-rules ()
......
......@@ -36,7 +36,10 @@ static inline SCM gp_handle(SCM item, int ret)
}
gp_debug0("non GP car\n");
scm_call_0(SCM_CDR(item));
if(scm_is_false(SCM_CDR(item)))
scm_call_1(SCM_CAR(item),SCM_BOOL_F);
else
scm_call_0(SCM_CDR(item));
return item;
}
else
......@@ -120,7 +123,10 @@ static inline int gp_do_cons(SCM item, int state, SCM *old)
case gp_redo:
*old = SCM_CDR(*old);
}
scm_call_0(SCM_CDR(item));
if(scm_is_false(SCM_CDR(item)))
scm_call_1(SCM_CAR(item),SCM_BOOL_F);
else
scm_call_0(SCM_CDR(item));
return state;
}
......@@ -500,7 +506,11 @@ static int gp_rewind(SCM pp, SCM pend, SCM *ci)
}
else
{
scm_call_0(SCM_CAR(q));
if(scm_is_false(SCM_CDR(q)))
scm_call_1(SCM_CAR(q),SCM_BOOL_T);
else
scm_call_0(SCM_CAR(q));
gp_ci[0] = q;
gp_ci ++;
}
......
......@@ -92,6 +92,10 @@
(define *wind* #f)
(define *states* #t)
(define *store-id* (gp-make-fluid))
(gp-fluid-set! *store-id* 0)
(define-syntax mk-guard
(lambda (x)
(syntax-case x ()
......@@ -103,30 +107,38 @@
(set! s ss) ...
(dyn
;;rewind
(lambda ()
(if (and *wind* (not done))
(begin
(set! done #t)
(push-setup
(let ((ss s) ...)
(lambda ()
(set! done #f)
(if fr
(guard ss ...)
(begin (set! s ss) ...)))))))
(set! s ss) ...)
(lambda ()
(if (and *wind* (not done))
(begin
(set! done #t)
(push-setup
(let ((ss s) ...)
(lambda ()
(set! done #f)
(if fr
(guard ss ...)
(begin (set! s ss) ...)))))))
(set! s so) ...)))))))))
(case-lambda
(()
(error (string-append "this is a one-function-dyn-lambda "
"call with selector!")))
((forward)
(if forward
(begin
(if (and *wind* (not done))
(begin
(set! done #t)
(push-setup
(let ((ss s) ...)
(lambda ()
(set! done #f)
(if fr
(guard ss ...)
(begin (set! s ss) ...)))))))
(set! s ss) ...)
(begin
(if (and *wind* (not done))
(begin
(set! done #t)
(push-setup
(let ((ss s) ...)
(lambda ()
(set! done #f)
(if fr
(guard ss ...)
(begin (set! s ss) ...)))))))
(set! s so) ...))))
;;The second argument is not used here
#f))))))))
(define-syntax with-guarded-states
(lambda (x)
......@@ -323,6 +335,7 @@
;(pk `(umatch*** ,@(syntax->datum #'l)))
#'(umatch***+ . l)))))
#;
(define (mk-failure0 fr code)
(letrec ((base (case-lambda
(()
......@@ -338,6 +351,13 @@
self))))))
base))
(define (mk-failure0 fr code)
(lambda ()
(gp-unwind fr)
(code)))
(define-syntax mk-failure
(syntax-rules ()
((_ fr code)
......
(use-modules (logic guile-log kanren))
(use-modules (logic guile-log examples kanren type-inference))
(define-module (kanren-typecheck)
#:use-module (logic guile-log examples kanren type-inference)
#:use-module (logic guile-log kanren)
#:use-module (logic guile-log umatch)
#:use-module (test-suite lib))
(define (time x) x)
#;
(define-syntax test-check
(syntax-rules ()
((_ title tested-expression expected-result)
......@@ -16,6 +21,15 @@
"(Failed: ~a~%Expected: ~a~%Computed: ~a~%"
'tested-expression expected produced))))))))
(define-syntax test-check
(syntax-rules ()
((_ title x y)
(begin
(gp-clear)
(with-test-prefix "start"
(pass-if (format #f "~a" 'x)
(equal? x y)))))))
(test-check 'test-!-1
(and
(equal?
......
(use-modules (logic guile-log kanren))
(use-modules (logic guile-log))
(use-modules (logic guile-log umatch))
(use-modules (ice-9 pretty-print))
(define-module (kanren)
#:use-module (logic guile-log kanren)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 pretty-print)
#:use-module (test-suite lib))
(define (time x) x)
#;
(define-syntax test-check
(syntax-rules ()
((_ title tested-expression expected-result)
......@@ -17,6 +21,15 @@
"(Failed: ~a~%Expected: ~a~%Computed: ~a~%"
'tested-expression expected produced))))))))
(define-syntax test-check
(syntax-rules ()
((_ title x y)
(begin
(gp-clear)
(with-test-prefix "start"
(pass-if (format #f "~a" 'x)
(equal? x y)))))))
(let*
((parents-of-scouts
......@@ -526,7 +539,7 @@
(solve 6 (q) (concat '(a b c) q '(a b c u v)))
'((u v)))
(equal?
(solve 6 (q) (concat q '(u v) '(a b c u v)))
(solve 6 (q) (concat q '(u v) '(a b c u v)))
'((a b c)))
(equal?
(solve 6 (q r) (concat q r '(a b c u v)))
......@@ -538,7 +551,7 @@
((a b c u v) ())))
(equal?
(solve 6 (q r s) (concat q r s))
(solve 6 (q r s) (concat q r s))
'((() v.0 v.0)
((v.0) v.1 (v.0 . v.1))
((v.0 v.1) v.2 (v.0 v.1 . v.2))
......@@ -549,23 +562,23 @@
(equal?
(solve 6 (q r) (concat q '(u v) `(a b c . ,r)))
'(((a b c) (u v))
((a b c v.0) (v.0 u v))
((a b c v.0 v.1) (v.0 v.1 u v))
((a b c v.0 v.1 v.2) (v.0 v.1 v.2 u v))
((a b c v.0 v.1 v.2 v.3) (v.0 v.1 v.2 v.3 u v))
((a b c v.0 v.1 v.2 v.3 v.4)
(v.0 v.1 v.2 v.3 v.4 u v))))
(solve 6 (q r) (concat q '(u v) `(a b c . ,r)))
'(((a b c) (u v))
((a b c v.0) (v.0 u v))
((a b c v.0 v.1) (v.0 v.1 u v))
((a b c v.0 v.1 v.2) (v.0 v.1 v.2 u v))
((a b c v.0 v.1 v.2 v.3) (v.0 v.1 v.2 v.3 u v))
((a b c v.0 v.1 v.2 v.3 v.4)
(v.0 v.1 v.2 v.3 v.4 u v))))
(equal?
(solve 6 (q) (concat q '() q))
'(()
(v.0)
(v.0 v.1)
(v.0 v.1 v.2)
(v.0 v.1 v.2 v.3)
(v.0 v.1 v.2 v.3 v.4)))))
(solve 6 (q) (concat q '() q))
'(()
(v.0)
(v.0 v.1)
(v.0 v.1 v.2)
(v.0 v.1 v.2 v.3)
(v.0 v.1 v.2 v.3 v.4)))))
#t))
; Extending relations in truly mathematical sense.
......
......@@ -7,15 +7,11 @@
#| Mapping the examples from reasoned schemer to guile-log |#
(define-guile-log pelse
(syntax-rules (else)
((_ w else) (parse<> w <cc>))
((_ w x ) (parse<> w x))))
(define-guile-log <conde>
(syntax-rules ()
((_ w (x y ...) ...)
(parse<> w (<or> (<and> (pelse x) y ...) ...)))))
((_ w (x ...) ...)
(parse<> w (<or> (<and> x ...) ...)))))
(define (translate x) x)
......@@ -150,14 +146,14 @@
(<ask>
(<conde>
(<fail> <cc>)
(else <fail>)))
(<fail>)))
#f)
(check?
(<ask>
(<conde>
(<cc> <cc>)
(else <fail>)))
(<fail>)))
#t)
......@@ -167,7 +163,7 @@
(<conde>
((<=> 'olive x) <cc>)
((<=> 'oil x) <cc>)
(else <fail>)))
(<fail>)))
'(olive oil))
(check?
......@@ -175,7 +171,7 @@
(<conde>
((<=> 'olive x) <cc>)
((<=> 'oil x) <cc>)
(else <fail>)))
(<fail>)))
'(olive))
(gp-clear)
......@@ -186,7 +182,7 @@
((<=> 'olive x) <cc>)
(<cc> <cc>)
((<=> 'oil x) <cc>)
(else <fail>)))
(<fail>)))
'(olive v0 oil))
(check?
......@@ -196,9 +192,8 @@
((<=> 'virgin x) <fail>)
((<=> 'olive x) <cc>)
((<=> 'oil x) <cc>)
(else <fail>)))
(<fail>)))
'(extra olive))
(gp-clear)
(check?
(<run> * (r)
......@@ -214,7 +209,7 @@
(<conde>
((<=> 'split x) (<=> 'pea y))
((<=> '(navy bean) (x y)))
(else <fail>))
(<fail>))
(<=> (,x ,y) r)))
'((split pea) (navy bean)))
......@@ -224,7 +219,7 @@
(<conde>
((<=> 'split x) (<=> 'pea y))
((<=> '(navy bean) (x y)))
(else <fail>))
(<fail>))
(<=> (,x ,y 'soup) r)))
'((split pea soup) (navy bean soup))))
......@@ -343,9 +338,9 @@
(with-test-prefix "cdro"
(check?
(<run> * (r)
(<var> (v)
(cdro '(a c o r n) v)
(caro v r)))
(<var> (v)
(cdro '(a c o r n) v)
(caro v r)))
'(c))
(check?
......@@ -1203,7 +1198,7 @@
(define-guile-log <condi>
(syntax-rules ()
((_ w (x y ...) ...)
(parse<> w (<or-i> (<and> (pelse x) y ...) ...)))))
(parse<> w (<or-i> (<and> x y ...) ...)))))
(with-test-prefix "condi"
(check?
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment