compile subset representation is now available

parent 9441ee1d
......@@ -7,6 +7,7 @@
make-set-theory
new-set a->b
print-theory
compile-set-representation
))
;; Syntax helpers
......@@ -42,27 +43,33 @@
This is prepared to make it functional, but currently we mutate
|#
(define-inlinable (make-set-theory)
(vector 0
1
(make-hash-table)
(make-hash-table)
(make-hash-table)
(make-hash-table)
'()))
(define make-set-theory
(case-lambda
(() (make-set-theory #f))
((super)
(vector 0
1
(make-hash-table)
(make-hash-table)
(make-hash-table)
(make-hash-table)
'()
super))))
(define-inlinable (get-set x) (vector-ref x 0))
(define-inlinable (get-new x) (vector-ref x 1))
(define-inlinable (get-set->i x) (vector-ref x 2))
(define-inlinable (get-i->j x) (vector-ref x 2))
(define-inlinable (get-i->set x) (vector-ref x 3))
(define-inlinable (get-j->i x) (vector-ref x 3))
(define-inlinable (get-i->subs x) (vector-ref x 4))
(define-inlinable (get-i->sups x) (vector-ref x 5))
(define-inlinable (get-parent x) (vector-ref x 7))
(define-inlinable (set-set x v) (vector-set! x 0 v))
(define-inlinable (set-new x v) (vector-set! x 1 v))
(define-inlinable (set-set->i x v) (vector-set! x 2 v))
(define-inlinable (set-i->set x v) (vector-set! x 3 v))
(define-inlinable (set-i->subs x v) (vector-set! x 4 v))
(define-inlinable (set-i->sups x v) (vector-set! x 5 v))
(define-inlinable (put-set->i x k v)
(hash-set! (get-set->i x) k v))
......@@ -101,16 +108,22 @@ Basic construction and removal of set and set graph relationship,
(() (print-theory (fluid-ref *current-set-theory*)))
((theory)
(define out '())
(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))))
(hash-for-each
(lambda (i s)
(define target '())
(set! out
(cons
(list s
(list (tr i) '->
(let lp ((l (bits-to-is (get-i (get-i->subs theory) i))))
(if (pair? l)
(cons
(get-i (get-i->set theory) (car l))
(tr (car l))
(lp (cdr l)))
'())))
out)))
......@@ -167,51 +180,7 @@ Basic construction and removal of set and set graph relationship,
#:subs ->subs
#:sups ->sups))))))
(error "a->b set is not locatable in hash"))))))
#|
Deletion,
|#
#|
(define delete-a->b
(case-lambda
((set-a set-b)
(fluid-set! *current-set-theory*
(a->b (fluid-ref *current-set-theory*) set-a set-b)))
((theory set-a set-b)
(let* ((->i (get-set->i theory))
(->subs (get-i->subs theory))
(->sups (get-i->sups theoury)))
(alet* ((a (get-i ->i set-a))
(b (get-i ->i set-b))
(ah (get-i ->subs a))
(bh (get-i ->subs b))
(ap (get-i ->sups a)))
(when (not (= (logand ap b) 0))
(error (format #f "(a->b ~a ~b) created a circle" set-a set-b)))
(let lp ((l (bits-to-is ap)) (->subs ->subs))
(if (pair? l)
(let ((c (car l)))
(aif (ch) (get-i ->subs c)
(let lp2 ((l2 (bits-to-is (logand ch (lognot bh)))))
(if (pair? l2)
(let ((d (car l2)))
(aif
(lp (cdr l) (update ->subs c (logior bh ch)))
(error "a->b set is not locatable in hash")))
(let lp ((l (bits-to-is bh)) (->sups ->sups))
(if (pair? l)
(let ((c (car l)))
(aif (cp) (get-i ->sups c)
(lp (cdr l) (update ->sups c (logior ap cp)))
(error "a->b set is not locatable in hash")))
(update-set-theory theory
#:subs ->subs
#:sups ->sups)))))
(error "a->b set is not locatable in hash"))))))
|#
#|
Each function has it's own subspace of to how do we know that a set s is
if S->S', then we just move on with S'
......@@ -223,65 +192,105 @@ cause cache this set for later faster lookup
This function introduce a new coding which order the sets and also introduce
a natural generational mapping to help in constructing a match tree.
|#
#|
(define (compile-set-representation setbits)
(define (find-all-leafs)
(let lp ((ss (bits-to-is setbits)) (leafs 0))
(if (pair? ss)
(let ((i (car ss)))
(aif (ih) (hash-ref i-to-inh i #f)
(if (= i (logand setbits ih))
(lp (cdr ss) (logior leafs i))
(lp (cdr ss) leafs))))
leafs)))
(define (find-all-newcombers downbits new-downbits)
(let lp1 ((ss (bits-to-is new-downbits)) (news 0))
(if (pair? ss)
(let ((i (car ss)))
(aif (hi) (hash-ref i-to-sups i #f)
(let lp2 ((js (bits-to-is hi)) (news news))
(if (pair? js)
(let ((j (car js)))
(if (and (not (= j i)) (= (logand j downbits) 0))
(aif (jh) (hash-ref i-to-inh j #f)
(if (= jh (logand ih (logior j downbits)))
(lp2 (cdr js) (logior j news))
(lp2 (cdr js) news))
(error "missing set registratoin in"))
(lp2 (cdr js) news)))
(lp1 (cdr ss) news)))
(error "missing set registratoin in")))
news)))
(define compile-set-representation
(case-lambda
((setbits)
(compile-set-representation (fluid-ref *current-set-theory*) setbits))
((theory setbits)
(let ((deps (get-i->subs theory))
(sups (get-i->sups theory)))
(define (find-all-leafs)
(let lp ((ss (bits-to-is setbits)) (leafs 0))
(if (pair? ss)
(let ((i (car ss)))
(aif (ih) (get-i deps i)
(if (= i (logand setbits ih))
(lp (cdr ss) (logior leafs i))
(lp (cdr ss) leafs))
(error "compile-set-representatoin has nonmatched bit")))
leafs)))
(define (find-all-newcombers downbits new-downbits)
(let lp1 ((ss (bits-to-is new-downbits)) (news 0))
(if (pair? ss)
(let ((i (car ss)))
(aif (hi) (get-i sups i)
(let lp2 ((js (bits-to-is (logand setbits hi)))
(news news))
(if (pair? js)
(let ((j (car js)))
(if (and (not (= j i)) (= (logand j downbits) 0))
(aif (jh) (get-i deps j)
(if (= (logand jh setbits)
(logand (logand jh setbits)
(logior j downbits)))
(lp2 (cdr js) (logior j news))
(lp2 (cdr js) news))
(error "missing set registratoin in"))
(lp2 (cdr js) news)))
(lp1 (cdr ss) news)))
(error "missing set registratoin in")))
news)))
(define old->new (make-hash-table))
(define new->gen (make-hash-table))
(define m 1)
(define (register-new newbits)
(let ((l (bits-to-id newbits)))
(let lp ((ss l))
(if (pair? ss)
(let ((i (car ss)))
(let ((j m))
(set! m (* m 2))
(hash-set! old->new i j)
(lp (cdr ss))))))
(for-each
(lambda (i)
(hash-set! new->gen (hash-ref old->new i #f) m))
l)))
(let ((leafs (find-all-leafs setbits)))
(let lp ((downbits leafs) (new-downbits leafs))
(if (not (= new-downmits 0))
(register-new new-downbits)
(let ((newcoms (find-all-newcombers downbits new-downbits)))
(lp (logior newcoms leafs) newcoms)))))
(define new-theory (make-set-theory theory))
(define (register-new newbits)
(let ((l (bits-to-is newbits))
(s (get-set new-theory)))
(let lp ((ss l)
(m (get-new new-theory))
(i->j (get-i->j new-theory))
(j->i (get-j->i new-theory)))
(if (pair? ss)
(let ((i (car ss)))
(let ((j m))
(lp (cdr ss)
(* 2 m)
(update i->j i j)
(update j->i j i))))
(update-set-theory new-theory
#:set (logior s newbits)
#:new m
#:i->j i->j
#:j->i j->i)))))
(let ((leafs (find-all-leafs)))
(let lp ((downbits leafs) (new-downbits leafs))
(if (not (= new-downbits 0))
(begin
(set! new-theory (register-new new-downbits))
(let ((newcoms (find-all-newcombers downbits new-downbits)))
(lp (logior newcoms leafs) newcoms))))))
(let ((s (get-set new-theory))
(i->j (get-i->j new-theory))
(j->subs (get-i->subs new-theory))
(j->sups (get-i->sups new-theory))
(p->subs (get-i->subs theory))
(p->sups (get-i->sups theory)))
(let lp ((l (bits-to-is s)) (j->subs j->subs) (j->sups j->sups))
(if (pair? l)
(let lp2 ((ll (bits-to-is (logand s (get-i p->subs (car l)))))
(sub 0))
(if (pair? ll)
(lp2 (cdr ll) (logior (get-i i->j (car ll)) sub))
(let lp3 ((ll
(bits-to-is (logand s (get-i p->sups (car l)))))
(sup 0))
(if (pair? ll)
(lp3 (cdr ll) (logior (get-i i->j (car ll)) sup))
(lp (cdr l)
(update j->subs (get-i i->j (car l)) sub)
(update j->sups (get-i i->j (car l)) sup))))))
(set! new-theory
(update-set-theory new-theory
#:subs j->subs
#:sups j->sups)))))
new-theory))))
(values old->new new->gen))
#|
#|
Balanced binary tree compilation
......
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