compile-sup-sub tested and implemented

parent bbe6a7c8
......@@ -5,8 +5,9 @@
(
bits-to-is get-high-bit get-rest-bits
make-set-theory
new-set a->b
new-set a->b a->b-o
print-theory
compile-sup-sub
compile-set-representation
))
......@@ -54,7 +55,8 @@ This is prepared to make it functional, but currently we mutate
(make-hash-table)
(make-hash-table)
'()
super))))
super
(make-hash-table)))))
(define-inlinable (get-set x) (vector-ref x 0))
(define-inlinable (get-new x) (vector-ref x 1))
......@@ -65,6 +67,7 @@ This is prepared to make it functional, but currently we mutate
(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 (get-i->i x) (vector-ref x 8))
(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))
......@@ -80,8 +83,9 @@ This is prepared to make it functional, but currently we mutate
(define-inlinable (put-i->sups x k v)
(hash-set! (get-i->sups x) k v))
(define-inlinable (get-i ->i i) (hash-ref ->i i #f))
(define-inlinable (update ->i i v) (begin (hash-set! ->i i v) ->i))
(define-inlinable (get-i ->i i) (hash-ref ->i i #f))
(define-inlinable (get-list ->i i) (hash-ref ->i i '()))
(define-inlinable (update ->i i v) (begin (hash-set! ->i i v) ->i))
(define-syntax-rule (update-set-theory th . l)
(let ((ll (list . l)))
......@@ -145,8 +149,21 @@ Basic construction and removal of set and set graph relationship,
#:subs (put-i->subs theory j j)
#:sups (put-i->sups theory j j))))))
(define a->b
(case-lambda*
((set-a set-b)
(fluid-set! *current-set-theory*
(a->b (fluid-ref *current-set-theory*) set-a set-b)))
(define a->b
((theory set-a set-b)
(let* ((set->i (get-set->i theory))
(i->i (get-i->i theory))
(a (get-i set->i set-a))
(b (get-i set->i set-b)))
(update-set-theory theory
#:i->i (update i->i a (cons b (get-i i->i a))))))))
(define a->b-o
(case-lambda*
((set-a set-b)
(fluid-set! *current-set-theory*
......@@ -193,6 +210,66 @@ 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-sup-sub
(case-lambda
(()
(compile-sup-sub (fluid-ref *current-set-theory*)))
((theory)
(let ((i->subs (get-i->subs theory))
(i->sups (get-i->sups theory))
(i->i (get-i->i theory)))
(define (find-leafs)
(let lp ((l (bits-to-is (get-set theory))) (leafs 0))
(if (pair? l)
(if (null? (get-list i->i (car l)))
(lp (cdr l) (logior leafs (car l)))
(lp (cdr l) leafs))
leafs)))
(define (new-generation old)
(let lp ((l (bits-to-is (get-set theory))) (new 0))
(if (pair? l)
(if (= (car l) (logand (car l) old))
(lp (cdr l) new)
(if (let lp2 ((ll (get-list i->i (car l))))
(if (pair? ll)
(if (= (car ll) (logand (car ll) old))
(lp2 (cdr ll))
#f)
#t))
(lp (cdr l) (logior new (car l)))
(lp (cdr l) new)))
new)))
(let ((leafs (find-leafs)))
(let lp ((new leafs) (subs leafs)
(i->subs i->subs) (i->sups i->sups))
(pk 'new new)
(if (not (= new 0))
(let lp2 ((l (bits-to-is new))
(i->subs i->subs) (i->sups i->sups))
(if (pair? l)
(let lp3 ((ll (get-list i->i (car l)))
(i->subs i->subs)
(i->sups i->sups))
(if (pair? ll)
(lp3 (cdr ll)
(update i->subs (car l)
(logior (get-i i->subs (car l))
(get-i i->subs (car ll))))
(update i->sups (car ll)
(logior (get-i i->sups (car ll))
(car l))))
(lp2 (cdr l) i->subs i->sups)))
(let ((subs (logior new subs)))
(lp (new-generation subs) subs i->subs i->sups))))
(update-set-theory theory
#:i->subs i->subs
#:i->sups i->sups))))))))
(define compile-set-representation
(case-lambda
((setbits)
......
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