starting to get close in indexing inheritance structures

parent 6b908990
......@@ -72,6 +72,8 @@
(car l)
(lp (cdr l))))
#f)))
(define type? (lambda (x) (eq? x Type)))
#|
Action dynlist array indexed
......@@ -146,6 +148,10 @@ add/run * vlist *
(vector-ref v 5)
(vector-ref v 6)))
(define-inlinable (add-car-cdr! v x y)
(vector-set! v 0 x)
(vector-set! v 1 y))
(define-inlinable (add-all! v x)
(vector-set! v 4 x))
......@@ -306,9 +312,9 @@ add/run * vlist *
(define (compile-inh s y theory)
(match y
(((? (type? s) x) a b c)
(((? set-tag? x) a b c)
(let ((a (compile-inh s a theory))
(c (compile-inh s a theory))
(c (compile-inh s c theory))
(tree (assoc=>tree theory (car b))))
(list x a (cons (car b) tree) c)))
((x . l)
......@@ -317,7 +323,14 @@ add/run * vlist *
(if (and (eq? x xx) (eq? l ll))
y
(cons xx ll))))
(x x)))
(x
(if (vector? x)
(let ((h (compile-inh s (get-car x) theory))
(t (compile-inh s (get-cdr x) theory)))
(if (and (eq? h (get-car x)) (eq? t (get-cdr x)))
x
(begin (add-car-cdr! x h t) x)))
x))))
(define dive
......@@ -337,7 +350,7 @@ add/run * vlist *
(dive x tag))
(else
(case tag
((set-tag) (cons* set-tag dlink (cons '() #f) (make-indexer)))
((set-tag) (list set-tag dlink (cons '() #f) (make-indexer)))
((+-tag) (list +-tag dlink (make-indexer)))
((--tag) (list --tag dlink (make-indexer)))
((and-tag) (list and-tag dlink (make-indexer) (make-indexer)))
......@@ -363,7 +376,7 @@ add/run * vlist *
(cons #t
(cond
((eq? tag set-tag)
(cons* set-tag dlink (cons '() #f) (make-indexer)))
(list set-tag dlink (cons '() #f) (make-indexer)))
((eq? tag +-tag)
(list +-tag dlink (make-indexer)))
......@@ -473,33 +486,30 @@ add/run * vlist *
(((? =..tag?) x)
(bitmap-indexer-add s (vector x) f dlink get-set))
((? (type? s) x)
(let* ((set.data (gp-get-attr x Type s))
(set (car set.data))
(data (cdr set.data)))
(match (dive dlink set-tag)
(((? set-tag?) other set-data data-path)
(list set-tag other
(cons (cons (cons set f) (car set-data)) #f)
(bitmap-indexer-add s f data data-path get-set))))))
(((? type?) x (set . data))
(match (dive dlink set-tag)
(((? set-tag?) other set-data data-path)
(list set-tag other
(cons (cons (cons set f) (car set-data)) #f)
(bitmap-indexer-add s data f data-path get-set)))))
(((? or-tag?) . l)
(let lp ((l l) (dlink (dive dlink)))
(if (pair? l)
(lp (cdr l) (bitmap-indexer-add s f (car l) dlink get-set))
(lp (cdr l) (bitmap-indexer-add s (car l) f dlink get-set))
dlink)))
(((? and-tag?) x y)
(match (dive dlink and-tag)
(((? and-tag?) a b c)
(list and-tag a
(bitmap-indexer-add s f x b get-set)
(bitmap-indexer-add s f y c get-set)))))
(bitmap-indexer-add s x f b get-set)
(bitmap-indexer-add s y f c get-set)))))
(((? not-tag?) x)
(match (dive dlink not-tag)
(((? not-tag?) a b v)
(list not-tag a (bitmap-indexer-add s f x b get-set)
(list not-tag a (bitmap-indexer-add s x f b get-set)
(logior v f)))))
(((? predicate-tag?) pred)
......@@ -581,8 +591,10 @@ add/run * vlist *
(((? or-tag?) e)
(bitmap-indexer-add!- s e f dlink get-set))
(((? and-tag?) e)
(bitmap-indexer-add!- s e f dlink get-set))
(((? or-tag?) . l)
(let lp ((l l))
(if (pair? l)
......@@ -613,17 +625,22 @@ add/run * vlist *
(bitmap-indexer-add!- s x f b get-set)
xx)))
((? (type? s) x)
(let* ((set.data (gp-get-attr x Type s))
(set (car set.data))
(data (cdr set.data)))
(match (dive! dlink set-tag)
(((? set-tag?) other set-data data-path)
(list set-tag other
(cons
(cons (cons (get-set set) f) (car set-data))
#f)
(bitmap-indexer-add!- s f data data-path get-set))))))
(((? type?) x (set . data))
(match (dive! dlink set-tag)
((#f . ((? set-tag?) other (and (set! s) set-data) data-path))
(s (cons
(cons (cons (get-set set) f) (car set-data))
#f))
(bitmap-indexer-add!- s data f data-path get-set)
(cons #f dlink))
((and xx (#t . ((? set-tag?) other (and (set! s) set-data)
data-path)))
(s (cons
(cons (cons (get-set set) f) (car set-data))
#f))
(bitmap-indexer-add!- s data f data-path get-set)
xx)))
(((? predicate-tag?) pred)
......@@ -969,9 +986,11 @@ add/run * vlist *
(el (car e))
(er (cdr e)))
(fluid-set! env (cons (vector (get-tag el) (get-dyn el)
(compile-raw el) (get-li el))
(compile-raw el) (get-li el)
(get-theory el))
(vector (get-tag er) (get-dyn er)
(compile-raw er) (get-li er))))))
(compile-raw er) (get-li er)
(get-theory er))))))
(define (compile-f e)
(let* ((el (car e))
(er (cdr e)))
......@@ -990,13 +1009,13 @@ add/run * vlist *
indexer (mk-get-set! set)))
d
(make-indexer))))
(set! set (compile-set-representation set))
(set! set (pk 'set (compile-set-representation (pk 'set0 set))))
(vector
(get-tag e)
d
(dynlist->vlist (get-ar e) d)
(compile-inh s dyn set)
set)))
(pk 'dyn (compile-inh s (pk 'dyn0 dyn) set))
(pk 'the set))))
(define (compile-index s)
(let ((e (fluid-ref env)))
......@@ -1349,10 +1368,12 @@ add/run * vlist *
((_ s 'x 'l)
(ck s '(x . l)))))
(define (pkk x) (pk 'pkk (syntax->datum x)) x)
(define parse-list
(lambda (x)
(pkk
(let lp ((x x))
(syntax-case x (quote unquote and)
(syntax-case x (@@ quote unquote and)
(#(x ...)
(apply vector (lp #'(x ...))))
((and x y)
......@@ -1366,7 +1387,26 @@ add/run * vlist *
(y
(if (symbol? (syntax->datum #'y))
(list #'unquote #'(gp-make-var))
#'y))))))
#'y)))))))
(define parse-match
(lambda (x)
(pkk
(let lp ((x x))
(syntax-case x (@@ quote unquote and logic guile-log type Type)
((,(@@ (logic guile-log type) Type) var . _)
(lp #'var))
(#(x ...)
(apply vector (lp #'(x ...))))
((and x y)
(lp #'y))
((unquote x)
#'(unquote x))
('x
#'x)
((x . l)
(cons (lp #'x) (lp #'l)))
(y #'y))))))
(define parse-pat-extended
(lambda (x1)
......@@ -1470,26 +1510,30 @@ add/run * vlist *
(define-syntax <lambda-dyn>
(syntax-rules ()
((_ pat code)
(list (lambda () (mk-varpat pat))
(lambda ()
(lambda (a b c cut x)
((<<lambda>> (pat (<with-cut> cut code)))
a b c x)))
(lambda () "true")))
((_ pat code y)
(list (lambda () (mk-varpat pat))
(lambda ()
(lambda (a b c cut x)
((<<lambda>> (pat (<with-cut> cut code)))
a b c x)))
(lambda () y)))
((_ pat)
(<lambda-dyn> pat <cc>))))
(lambda (x)
(syntax-case x ()
((_ pat code)
(with-syntax ((patt (parse-match #'pat)))
#'(list (lambda () (mk-varpat pat))
(lambda ()
(lambda (a b c cut x)
((<<lambda>> (patt (<with-cut> cut code)))
a b c x)))
(lambda () "true"))))
((_ pat code y)
(with-syntax ((patt (parse-match #'pat)))
#'(list (lambda () (mk-varpat pat))
(lambda ()
(lambda (a b c cut x)
((<<lambda>> (patt (<with-cut> cut code)))
a b c x)))
(lambda () y))))
((_ pat)
(with-syntax ((patt (parse-match #'pat)))
#'(<lambda-dyn> patt <cc>))))))
(define-syntax <lambda-dyn-meta>
(syntax-rules ()
((_ pat)
......
......@@ -453,8 +453,10 @@ a natural generational mapping to help in constructing a match tree.
(i->j (get-i->j theory)))
(let lp ((a a) (i->f (make-hash-table)))
(if (pair? a)
(lp (cdr a) (update a (get-i i->j (get-i set->i (caar a))) (cadr a)))
(mktree theory a)))))
(lp (cdr a) (update i->f
(get-i i->j (get-i set->i (caar a)))
(cdar a)))
(mktree theory i->f)))))
(define mktree
(case-lambda*
......@@ -496,12 +498,13 @@ a natural generational mapping to help in constructing a match tree.
(define setlist (p (linearize (mktree1 setbits))))
(define comb (inh-comb i->f))
(define tree
(let lp ((l (reverse setlist)) (tree (make-dynlist)))
(if (pair? l)
(let ((i (car l)))
(lp (cdr l)
(dynlist-add tree i inh-comb)))
(dynlist-add tree i comb)))
tree)))
tree)))
......
......@@ -2,6 +2,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log)
#:use-module (logic guile-log type)
#:use-module (logic guile-log umatch)
#:export (compile-match mockalambda))
......
......@@ -29,7 +29,7 @@
(x
(<let> ((x (<lookup> x)))
(<var> (v)
(<if> (<get-attr> x 12 #;Type v)
(<if> (<get-attr> x Type v)
(<and>
(<values> (vv) (analyze-type v))
(<cc> (list Type x vv)))
......@@ -37,10 +37,11 @@
(<define> (analyze in goal)
(<values> (in) (analyze-type in))
(<pp> in)
(<values> (in.goal extra) (duplicate-term-3 (cons in goal)))
(<let> ((in (car in.goal))
(goal (cdr in.goal)))
(<cc> in (let lp ((l extra))
(if (pair? l)
(vector (list #{,}# (car l) (lp (cdr l))))
(vector (list #{,}# (pk (car l)) (lp (cdr l))))
goal)))))
......@@ -43,7 +43,7 @@ SCM get_set(SCM r, SCM bits)
if(SCM_CONSP(r))
{
SCM cdr = SCM_CDR(r);
if(SCM_CONSP(r))
if(SCM_CONSP(cdr))
{
SCM cddr = SCM_CDR(cdr);
if(SCM_CONSP(cddr))
......@@ -58,7 +58,7 @@ SCM get_set(SCM r, SCM bits)
simple:
{
SCM l = SCM_CAR(r);
SCM d = SCM_CDR(cdr);
SCM d = SCM_CAR(cdr);
if(scm_is_true(scm_equal_p(scm_logand(d, bits),
scm_from_int(0))))
return scm_from_int(0);
......@@ -82,8 +82,11 @@ SCM get_set(SCM r, SCM bits)
if(scm_is_vector(r))
{
if(scm_logand(bits, scm_c_vector_ref(r,0)) != 0)
if(scm_is_false(scm_equal_p(scm_logand(bits, scm_c_vector_ref(r,0)),
scm_from_int(0))))
return scm_c_vector_ref(r, 1);
else
return scm_from_int(0);
}
return scm_from_int(0);
......
......@@ -611,22 +611,30 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus, SCM
set_tag:
{
printf("set-tag\n");
if(scm_is_true(gp_att_rawvar(e,s)))
{
SCM adata = gp_get_attr(e, gp_type_attribute_tag, s);
adata = gp_gp_lookup(adata, s);
//data = (set . args)
printf("a\n");
if(scm_is_true(adata))
{
SCM set = SCM_CAR(adata);
SCM args = SCM_CDR(adata);
printf("b\n");
db = dB(db_);
if(SCM_CONSP(db_))
{
SCM tree = SCM_CADDR(db_);
SCM tree = SCM_CDR(SCM_CADDR(db_));
format1("trset ~a~%", trset);
format1("tree ~a~%", tree);
format1("adata ~a~%", adata);
SCM bits = get_bits_from_set(set, trset);
SCM v = get_set(tree, bits);
format1("bits ~a~%", bits);
SCM v = get_set(tree, bits);
if(SCM_I_INUMP (v))
{
......@@ -655,7 +663,7 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus, SCM
}
}
db_ = SCM_CDDDR(db_);
db_ = SCM_CADDDR(db_);
e = args;
goto redo;
}
......@@ -843,6 +851,25 @@ SCM_DEFINE(scm_get_index_set, "get-index-set", 4, 0, 0,
(SCM s, SCM e, SCM db, SCM trset), "")
#define FUNC_NAME s_scm_get_index_set
{
format1("in trset ~a~%",trset);
if(!scm_is_false(trset))
{
SCM parent = scm_c_vector_ref(trset , 7);
SCM mask = scm_c_vector_ref(trset , 0);
SCM set_to_i = scm_c_vector_ref(parent, 2);
SCM i_to_j = scm_c_vector_ref(trset, 2);
SCM j_to_inh = scm_c_vector_ref(trset , 4);
SCM i_to_inh = scm_c_vector_ref(parent, 4);
SCM v = scm_c_make_vector(5, SCM_BOOL_F);
scm_c_vector_set_x(v, 0, mask);
scm_c_vector_set_x(v, 1, set_to_i);
scm_c_vector_set_x(v, 2, i_to_j);
scm_c_vector_set_x(v, 3, j_to_inh);
scm_c_vector_set_x(v, 4, i_to_inh);
trset = v;
}
return get_index_set(s, e, db, 1, trset);
}
#undef FUNC_NAME
......
#define MINUS(x,k) SCM_PACK((scm_t_bits) (((long) SCM_UNPACK(x)) - (k << 2)))
inline SCM scm_high_bit(SCM x)
{
return scm_from_int(0);
return scm_ash(scm_from_int(1), MINUS(scm_integer_length(x), 1));
}
SCM get_bits_from_set(SCM set, SCM trdata)
SCM get_bits_from_set(SCM set, SCM v)
{
SCM i, ubermap, bits, outbits, mask, map, ijmap, hstar, h, hbits;
i = scm_hash_ref(SCM_CAR(trdata), set, SCM_BOOL_F);
SCM i, bits, outbits, hstar, h, hbits;
SCM mask, set_to_i, i_to_j, j_to_inh, i_to_inh;
if(scm_is_false(v)) return scm_from_int(0);
mask = scm_c_vector_ref(v, 0);
set_to_i = scm_c_vector_ref(v, 1);
i_to_j = scm_c_vector_ref(v, 2);
j_to_inh = scm_c_vector_ref(v, 3);
i_to_inh = scm_c_vector_ref(v, 4);
printf("1\n");
if(scm_is_false(set_to_i)) return scm_from_int(0);
i = scm_hash_ref(set_to_i, set, SCM_BOOL_F);
printf("2\n");
if(scm_is_false(i)) return scm_from_int(0);
if(scm_is_false(scm_eqv_p(scm_logand(i, mask), scm_from_int(0))))
{ //We have a direct mask
SCM j = scm_hash_ref(i_to_j, i, SCM_BOOL_F);
printf("3\n");
if(scm_is_false(j)) return scm_from_int(0);
format1("j = ~a~%",j);
printf("4\n");
return scm_hash_ref(j_to_inh, j, scm_from_int(0));
}
trdata = SCM_CDR(trdata);
ubermap = SCM_CAR(trdata);
bits = scm_hash_ref(ubermap, i, SCM_BOOL_F);
printf("5\n");
bits = scm_hash_ref(i_to_inh, i, SCM_BOOL_F);
if(scm_is_false(bits)) return scm_from_int(0);
printf("6\n");
outbits = scm_from_int(0);
trdata = SCM_CDR(trdata);
mask = SCM_CAR(trdata);
trdata = SCM_CDR (trdata);
ijmap = SCM_CAR (trdata);
map = SCM_CADR(trdata);
bits = scm_logand(mask, bits);
retry:
printf("7\n");
if(scm_is_true(scm_equal_p(scm_from_int(0), bits)))
return outbits;
h = scm_high_bit(bits);
hbits = scm_hash_ref(ubermap, h, SCM_BOOL_F);
hbits = scm_hash_ref(i_to_inh, h, SCM_BOOL_F);
bits = scm_logand(bits, scm_lognot(hbits));
hstar = scm_hash_ref(ijmap, h, SCM_BOOL_F);
outbits = scm_logior(outbits, scm_hash_ref(map, hstar, SCM_BOOL_F));
hstar = scm_hash_ref(i_to_j, h, SCM_BOOL_F);
outbits = scm_logior(outbits, scm_hash_ref(j_to_inh, hstar, SCM_BOOL_F));
goto retry;
}
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