all kanren tests succeeds

parent 1a75179b
......@@ -5,8 +5,9 @@
any fails succeeds any-interleave if-some
all-interleave relation fact lift-to-relations
let-gls == query solve solution project project/no-check
predicate *equal? var? _ let-lv
extend-relation intersect-relation exists))
predicate *equal? var? _ let-lv reify partially-eval-sgl
extend-relation extend-relation-with-recur-limit
intersect-relation exists))
(define-syntax mk
......@@ -18,6 +19,10 @@
(lambda (p cc)
(<with-guile-log> (p cc)
(gl-name (a) (... ...))))))))))
(define partially-eval-sgl
(lambda x
(error "partialle eval sgl is not supported in guile-log-kanren")))
(mk all <and>)
(mk all! <and!>)
......@@ -36,21 +41,39 @@
(define sfail fail)
(define var? gp-var?)
(define reify (lambda (x)
(tr 'v. x)))
(define-syntax let-lv
(syntax-rules ()
((_ (id ...) body)
(let ((id (gp-var!)) ...) body))))
(define-syntax extend-relation-with-recur-limit
(syntax-rules ()
((_ limit ids rel ...)
(let ((*counter* (gp-var!)))
(lambda ids
(let ((gl (any (rel . ids) ...)))
(if (gp-var? *counter*)
(begin
(gp-set! *counter* 0)
gl)
(let ((cnt (gp-lookup *counter*)))
(if (<= limit cnt)
sfail
(begin
(gp-set! *counter* (+ cnt 1))
gl))))))))))
; The anonymous variable
(define-syntax _
(lambda (x)
(syntax-case x ()
((_ . l) #'(error "_ cannot be infunction possition"))
(_ #'(gp-var!)))))
;; This part is copied from upstream kanren.ss
;;The following is a direct translation of kanren.ss
(define-syntax id-memv??
(syntax-rules ()
((id-memv?? form (id ...) kt kf)
......
......@@ -250,20 +250,14 @@
(let ((ccc (lambda (Pr) (cc pr))))
(parse<> (cut fi pr ccc) (<and> a ...))))))
(define-syntax and!!
(syntax-rules ()
((_ (cut fi pr cc) ccc a)
(parse<> (cut fi pr (ccc cc)) a))
((_ (cut fi pr cc) ccc a as ...)
(let ((ccc (lambda (pr) (and!! (cut fi pr cc) ccc as ...))))
(parse<> (cut fi pr ccc) a)))))
(define-guile-log <and!!>
(syntax-rules ()
((_ w) (parse<> w <cc>))
((_ (cut fi pr cc) a ...)
(let ((ccc (lambda (cc) (lambda (Pr) (cc pr)))))
(and!! w ccc a ...)))))
((_ meta)
(parse<> meta <cc>))
((_ meta a ...)
(parse<> meta (<and> (<and!> a) ...)))))
;; this will try to make a success and if so reset the state and continue it's a
;; companion to <not>.
......@@ -298,7 +292,7 @@
(define-guile-log <peek-fail>
(syntax-rules ()
((_ (cut fi p cc) pp code ...)
(let (pp p)
(let ((pp p))
(parse<> (cut fi p cc) (<and> code ...))))))
......
......@@ -40,7 +40,7 @@
u-unify! u-scm u-unify-raw! u-cons u-dynwind umatch
gp-copy **um** gp-get-stack
push-setup que-setup
with-guarded-states with-guarded-globals))
with-guarded-states with-guarded-globals gp->scm))
(define gp-module-init #f)
(define gp? #f)
......
This diff is collapsed.
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