new proper guile-kanren test-suite and fixed tr

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