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 @@ ...@@ -15,10 +15,11 @@
<and-i> and-interleave interleave tr S P CC CUT <and-i> and-interleave interleave tr S P CC CUT
<set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip> <set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip>
<with-generators> <next-generator-value> <with-generators> <next-generator-value>
<cons> <values> <windlevel> <cons> <values> <windlevel> _
<//> <update> <update-val> <fluid-let-syntax> <//> <update> <update-val> <fluid-let-syntax>
<let-with-guard> <let-with-lr-guard> let-with-guard let-with-lr-guard <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?) (re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
...@@ -27,13 +28,18 @@ ...@@ -27,13 +28,18 @@
(define-syntax P (lambda (x) (error "P should be bound by fluid-let"))) (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 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 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 (<scm> x) (gp->scm x S))
(define-syntax-rule (<cons> x y) (gp-cons! x y S)) (define-syntax-rule (<cons> x y) (gp-cons! x y S))
(define-syntax-rule (<car> x) (gp-car (gp-lookup x S) S)) (define-syntax-rule (<car> x) (gp-car (gp-lookup x S) S))
(define-syntax-rule (<cdr> x) (gp-cdr (gp-lookup x S) S)) (define-syntax-rule (<cdr> x) (gp-cdr (gp-lookup x S) S))
(define-syntax-rule (<lookup> x) (gp-lookup x S)) (define-syntax-rule (<lookup> x) (gp-lookup x S))
(define-syntax let-values* (define-syntax let-values*
(syntax-rules () (syntax-rules ()
...@@ -588,8 +594,8 @@ ...@@ -588,8 +594,8 @@
(define-syntax <define> (define-syntax <define>
(syntax-rules () (syntax-rules ()
((_ (name a ...) code ...) ((_ (name . a) code ...)
(define (name <S> <Cut> <CC> a ...) (define (name <S> <Cut> <CC> . a)
(<with-guile-log> (<S> <Cut> <CC>) (<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...)))))) (<and> code ...))))))
...@@ -710,15 +716,6 @@ ...@@ -710,15 +716,6 @@
((_ w () code ...) ((_ w () code ...)
(parse<> w (<and> 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) (define (tr-pat x)
(syntax-case x (quote unquote) (syntax-case x (quote unquote)
...@@ -730,6 +727,15 @@ ...@@ -730,6 +727,15 @@
(eq? '_ (syntax->datum #'x)) (eq? '_ (syntax->datum #'x))
#'x) #'x)
( x #'(unquote 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! ;;TODO, this will unify with a cyclic check!
...@@ -979,3 +985,20 @@ ...@@ -979,3 +985,20 @@
(parse<> w <cc>))))) (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), ...@@ -850,7 +850,7 @@ SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
// unify under + means unification - means just match // 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) 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; int sp;
sp = 0; sp = 0;
...@@ -982,7 +982,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc ...@@ -982,7 +982,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
#define DO_CONS \ #define DO_CONS \
{ \ { \
gp_debug0("unify> cons\n"); \ gp_debug0("unify> cons\n"); \
if(SCM_UNLIKELY(sp >= 18)) \ if(SCM_UNLIKELY(sp >= 100)) \
{ \ { \
l = gp_unify(GP_CAR(id1), GP_CAR(id2) \ l = gp_unify(GP_CAR(id1), GP_CAR(id2) \
, raw, gp_plus_unify,l,gp); \ , 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 ...@@ -1032,8 +1032,39 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
return (SCM) 0; return (SCM) 0;
} }
gp_debug2("unify> (equal ~x ~x)\n", GP_SCM(id1), GP_SCM(id2)); SCM scm1 = GP_SCM(id1);
if(scm_is_true(scm_equal_p(GP_SCM(id1), GP_SCM(id2)))) 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;} {U_NEXT;}
else else
return (SCM) 0; return (SCM) 0;
...@@ -1059,7 +1090,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc ...@@ -1059,7 +1090,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
#define DO_CONS2 \ #define DO_CONS2 \
{ \ { \
gp_debug0("unify> cons\n"); \ 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); \ l = gp_unify(QCAR(id1),QCAR(id2),raw, gp_plus_unify, l, gp); \
if(!l) \ if(!l) \
...@@ -1092,10 +1123,10 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc ...@@ -1092,10 +1123,10 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
} }
if(QCONSP(id2)) return (SCM) 0; if(QCONSP(id2)) return (SCM) 0;
if(scm_is_true(scm_equal_p(GP_UNREF(id1),GP_UNREF(id2)))) scm1 = GP_UNREF(id1);
{U_NEXT;} scm2 = GP_UNREF(id2);
return (SCM) 0; goto scm_check;
u01: u01:
{ {
...@@ -1153,12 +1184,11 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc ...@@ -1153,12 +1184,11 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM l, struc
else else
return (SCM) 0; return (SCM) 0;
} }
if(scm_is_true(scm_equal_p(GP_SCM(id1),GP_UNREF(id2)))) scm1 = GP_SCM(id1);
{U_NEXT;} scm2 = GP_UNREF(id2);
else goto scm_check;
return (SCM) 0;
unbound_10: unbound_10:
gp_debug0("unify> unbound1\n"); gp_debug0("unify> unbound1\n");
if(!raw && QCONSP(id2) && gp_recurent(id1,id2,l)) return (SCM) 0; if(!raw && QCONSP(id2) && gp_recurent(id1,id2,l)) return (SCM) 0;
...@@ -1409,6 +1439,7 @@ static inline SCM ggp_set(SCM var, SCM val, SCM s) ...@@ -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) int _gp_newframe(SCM **spp, int nargs, SCM *cl, SCM *max)
{ {
SCM *sp = *spp; SCM *sp = *spp;
......
...@@ -166,7 +166,7 @@ ...@@ -166,7 +166,7 @@
(define-syntax id-12345 (define-syntax id-12345
(syntax-rules () (syntax-rules ()
((_ x s) x) ((_ x s) (gp-lookup x s))
((_ x) x))) ((_ x) x)))
(define-syntax-rule (ppair? x s) (define-syntax-rule (ppair? x s)
...@@ -179,13 +179,22 @@ ...@@ -179,13 +179,22 @@
(define-syntax-rule (ccar x s) (car x)) (define-syntax-rule (ccar x s) (car x))
(define-syntax-rule (ccdr x s) (cdr 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 (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! id-12345)) (uset-car uset-cdr uset))
(++ (gp-car gp-cdr gp-pair+ gp-null!? gp-unify-raw! id-12345)) ( (+ (gp-car gp-cdr gp-pair+ gp-null!? gp-unify! id-12345
(- (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))))) (++ (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 (define-syntax umatch
(lambda (x) (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