better match, better unify

parent 27c23d49
* Enabled unification on scheme vectors
* Added support for customized setters and getters in <match>
* Fixed Bug that prevented <match> to work correclt on cons variables
\ No newline at end of file
......@@ -15,10 +15,11 @@
<and-i> and-interleave interleave tr S P CC CUT
<set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip>
<with-generators> <next-generator-value>
<cons> <values> <windlevel>
<cons> <values> <windlevel> _
<//> <update> <update-val> <fluid-let-syntax>
<let-with-guard> <let-with-lr-guard> let-with-guard let-with-lr-guard
<car> <cdr> <logical++> <logical-->)
<car> <cdr> <logical++> <logical-->
<f-vector> <vector>)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
......@@ -27,6 +28,11 @@
(define-syntax P (lambda (x) (error "P should be bound by fluid-let")))
(define-syntax CC (lambda (x) (error "CC should be bound by fluid-let")))
(define-syntax CUT (lambda (x) (error "CUT should be bound by fluid-let")))
(define-syntax _
(lambda (x)
(syntax-case x ()
((_ . _) (error "_ in guile-log is not a function"))
(_ #'(gp-var! S)))))
(define-syntax-rule (<scm> x) (gp->scm x S))
(define-syntax-rule (<cons> x y) (gp-cons! x y S))
......@@ -588,8 +594,8 @@
(define-syntax <define>
(syntax-rules ()
((_ (name a ...) code ...)
(define (name <S> <Cut> <CC> a ...)
((_ (name . a) code ...)
(define (name <S> <Cut> <CC> . a)
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...))))))
......@@ -710,15 +716,6 @@
((_ w () code ...)
(parse<> w (<and> code ...)))))
(define-syntax letify
(lambda (x)
(syntax-case x ()
((_ w ((m f) pat val) code ...)
#`(let<>0 w (m #,(tr-pat #'pat) (f val)) code ...))
((_ w (m pat val) code ...)
#`(let<>0 w (m #,(tr-pat #'pat) val) code ...)))))
(define (tr-pat x)
(syntax-case x (quote unquote)
......@@ -731,6 +728,15 @@
#'x)
( x #'(unquote x))))
(define-syntax letify
(lambda (x)
(syntax-case x ()
((_ w ((m f) pat val) code ...)
#`(let<>0 w (m #,(tr-pat #'pat) (f val)) code ...))
((_ w (m pat val) code ...)
#`(let<>0 w (m #,(tr-pat #'pat) val) code ...)))))
;;TODO, this will unify with a cyclic check!
;;Not possible to use a pure raw form here
......@@ -979,3 +985,20 @@
(parse<> w <cc>)))))
(<define> (<f-vector> f . x)
(<recur> loop ((x x) (l '()))
(if (pair? x)
(<var> (y)
(<=> y ,(car x))
(loop (cdr x) (cons y l)))
(f (apply vector (reverse l))))))
(<define> (<vector> r . x)
(<recur> loop ((x x) (l '()))
(if (pair? x)
(<var> (y)
(<=> y ,(car x))
(loop (cdr x) (cons y l)))
(<=> r ,(apply vector (reverse l))))))
......@@ -850,7 +850,7 @@ SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
// unify under + means unification - means just match
static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struct gp_stack *gp)
{
SCM * stack[20];
SCM * stack[110];
int sp;
sp = 0;
......@@ -982,7 +982,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
#define DO_CONS \
{ \
gp_debug0("unify> cons\n"); \
if(SCM_UNLIKELY(sp >= 18)) \
if(SCM_UNLIKELY(sp >= 100)) \
{ \
l = gp_unify(GP_CAR(id1), GP_CAR(id2) \
, raw, gp_plus_unify,l,gp); \
......@@ -1032,8 +1032,39 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
return (SCM) 0;
}
gp_debug2("unify> (equal ~x ~x)\n", GP_SCM(id1), GP_SCM(id2));
if(scm_is_true(scm_equal_p(GP_SCM(id1), GP_SCM(id2))))
SCM scm1 = GP_SCM(id1);
SCM scm2 = GP_SCM(id2);
scm_check:
if(SCM_I_IS_VECTOR(scm1) && SCM_I_IS_VECTOR(scm2))
{
int n = SCM_I_VECTOR_LENGTH(scm1);
if(n == SCM_I_VECTOR_LENGTH(scm2))
{
if(2*n > 100) return (SCM) 0;
if(2*n + sp > 100)
{
l = gp_unify(GP_GETREF(scm1), GP_GETREF(scm2),
raw, gp_plus_unify,l,gp);
if(!l) return (SCM) 0;
U_NEXT;
}
int i = 0;
for(; i<n ; i++)
{
stack[sp++] = GP_GETREF(SCM_SIMPLE_VECTOR_REF(scm1,i));
stack[sp++] = GP_GETREF(SCM_SIMPLE_VECTOR_REF(scm2,i));
}
U_NEXT;
}
else
return (SCM) 0;
}
gp_debug2("unify> (equal ~x ~x)\n", scm1, scm2);
if(scm_is_true(scm_equal_p(scm1, scm2)))
{U_NEXT;}
else
return (SCM) 0;
......@@ -1059,7 +1090,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
#define DO_CONS2 \
{ \
gp_debug0("unify> cons\n"); \
if(SCM_UNLIKELY(sp >= 18)) \
if(SCM_UNLIKELY(sp >= 100)) \
{ \
l = gp_unify(QCAR(id1),QCAR(id2),raw, gp_plus_unify, l, gp); \
if(!l) \
......@@ -1093,9 +1124,9 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
if(QCONSP(id2)) return (SCM) 0;
if(scm_is_true(scm_equal_p(GP_UNREF(id1),GP_UNREF(id2))))
{U_NEXT;}
return (SCM) 0;
scm1 = GP_UNREF(id1);
scm2 = GP_UNREF(id2);
goto scm_check;
u01:
{
......@@ -1154,10 +1185,9 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
return (SCM) 0;
}
if(scm_is_true(scm_equal_p(GP_SCM(id1),GP_UNREF(id2))))
{U_NEXT;}
else
return (SCM) 0;
scm1 = GP_SCM(id1);
scm2 = GP_UNREF(id2);
goto scm_check;
unbound_10:
gp_debug0("unify> unbound1\n");
......@@ -1409,6 +1439,7 @@ static inline SCM ggp_set(SCM var, SCM val, SCM s)
}
int _gp_newframe(SCM **spp, int nargs, SCM *cl, SCM *max)
{
SCM *sp = *spp;
......
......@@ -166,7 +166,7 @@
(define-syntax id-12345
(syntax-rules ()
((_ x s) x)
((_ x s) (gp-lookup x s))
((_ x) x)))
(define-syntax-rule (ppair? x s)
......@@ -179,13 +179,22 @@
(define-syntax-rule (ccar x s) (car x))
(define-syntax-rule (ccdr x s) (cdr x))
(define-syntax-rule (uset x s v) (gp-set! x v s))
(define-syntax-rule (uset-car x s v) (gp-set-car! x v s))
(define-syntax-rule (uset-cdr x s v) (gp-set-cdr! x v s))
(define-syntax-rule (cset-car x s v) (gp-set! (car x) v s))
(define-syntax-rule (cset-cdr x s v) (gp-set! (cdr x) v s))
(make-phd-matcher umatch0
( (gp-car gp-cdr gp-pair+ gp-null!? gp-unify! id-12345)
( (+ (gp-car gp-cdr gp-pair+ gp-null!? gp-unify! id-12345))
(++ (gp-car gp-cdr gp-pair+ gp-null!? gp-unify-raw! id-12345))
(- (gp-car gp-cdr gp-pair- gp-null? gp-m-unify! id-12345))
(* ( ccar ccdr gp-pair* nnull? eequal? id-12345)))))
( (gp-car gp-cdr gp-pair+ gp-null!? gp-unify! id-12345
(uset-car uset-cdr uset))
( (+ (gp-car gp-cdr gp-pair+ gp-null!? gp-unify! id-12345
(uset-car uset-cdr uset)))
(++ (gp-car gp-cdr gp-pair+ gp-null!? gp-unify-raw! id-12345
(uset-car uset-cdr uset)))
(- (gp-car gp-cdr gp-pair- gp-null? gp-m-unify! id-12345
(uset-car uset-cdr uset)))
(* ( ccar ccdr gp-pair* nnull? eequal? id-12345
(cset-car cset-cdr uset))))))
(define-syntax umatch
(lambda (x)
......
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