lookup functions and tree lookup example is now active

parent b5aec8cb
......@@ -11,6 +11,7 @@
compile-sup-sub
compile-set-representation
mktree
find-matching-sets
))
;; Syntax helpers
......@@ -299,10 +300,18 @@ a natural generational mapping to help in constructing a match tree.
#:i->sups i->sups))))))))
(define compile-set-representation
(case-lambda
((setbits)
(compile-set-representation (fluid-ref *current-set-theory*) setbits))
(case-lambda
(()
(compile-set-representation (fluid-ref *current-set-theory*) ))
((setbits-or-theory)
(if (number? setbits-or-theory)
(compile-set-representation (fluid-ref *current-set-theory*)
setbits-or-theory)
(compile-set-representation setbits-or-theory
(- (get-new setbits-or-theory)
1))))
((theory setbits)
(let ((deps (get-i->subs theory))
(sups (get-i->sups theory)))
......@@ -399,11 +408,15 @@ a natural generational mapping to help in constructing a match tree.
Balanced binary tree compilation
You take a set i, finds it's subs sub and if sub | m, then dive
each if we have a set s and would like to lookup the matches
|#
(define mktree
(case-lambda*
((#:key (setbits #f))
((#:key (setbits (- (get-new (fluid-ref *current-set-theory*)) 1)))
(mktree (fluid-ref *current-set-theory*) #:setbits setbits))
((theory #:key (setbits (- (get-new theory) 1)))
(define (clusterize setbits)
......@@ -412,7 +425,7 @@ a natural generational mapping to help in constructing a match tree.
(if (pair? ss)
(let* ((i (car ss)))
(if (= (logand done i) 0)
(let ((ih (logand setbits (hash-ref i->subs i #f))))
(let ((ih (logand setbits (get-i i->subs i))))
(cons ih (lp (cdr ss) (logior done ih))))
(lp (cdr ss) done)))
'()))))
......@@ -428,7 +441,6 @@ a natural generational mapping to help in constructing a match tree.
(cons a (mktree1 t))))
cls))))
(define (linearize tree)
(let lp ((r tree))
(match r
......@@ -436,7 +448,11 @@ a natural generational mapping to help in constructing a match tree.
(() '())
(x (list x)))))
(define setlist (pk (linearize (mktree1 setbits))))
(define (p x)
(pk (map (lambda (x) (reverse-lookup theory x)) x))
x)
(define setlist (p (linearize (mktree1 setbits))))
(define tree
(let ((i->f (get-i->f theory)))
......@@ -459,12 +475,37 @@ a natural generational mapping to help in constructing a match tree.
Algorithm to lookup the matching sets iiis, preliminary this will be called
from c-land in the indexer.
|#
#;
(define (find-matching-sets i tree)
(let ((ih (hash-ref i-to-subs i 0)))
(fold-dynlist-lr
(lambda (x seed)
(logior (vector-ref x 1) seed))
tree 0
(lambda (x)
(not (= (logand x ih) 0))))))
(define reverse-lookup
(case-lambda
((set)
(lookup (fluid-ref *current-set-theory*) set))
((theory set)
(define (tr x)
(let lp ((x x) (th theory))
(aif (it) (get-parent th)
(lp (get-i (get-j->i th) x) it)
(get-i (get-i->set th) x))))
(tr set))))
(define lookup
(case-lambda
((set)
(lookup (fluid-ref *current-set-theory*) set))
((theory set)
(aif (it) (get-parent theory)
(get-i (get-i->j theory) (lookup it set))
(get-i (get-set->i theory) set)))))
(define (find-matching-sets theory set tree)
(let ((ih (get-i (get-i->subs theory) (lookup theory set))))
(let lp ((l (bits-to-is (fold-dynlist-lr
(lambda (x seed)
(logior (vector-ref x 0) seed))
tree 0
(lambda (x)
(not (= (logand x ih) 0)))))))
(if (pair? l)
(cons (reverse-lookup theory (car l)) (lp (cdr l)))
'()))))
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