mktree compiles and evals in inheritance

parent 0fb7e38e
(define-module (logic guile-log inheritance)
#:use-module (logic guile-log dynlist)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 match)
#:export
(
bits-to-is get-high-bit get-rest-bits
make-set-theory
new-set a->b a->b-o
print-theory
new-set a->b a->b-o set->f
print-theory print-set
compile-sup-sub
compile-set-representation
mktree
))
;; Syntax helpers
......@@ -56,6 +58,7 @@ This is prepared to make it functional, but currently we mutate
(make-hash-table)
'()
super
(make-hash-table)
(make-hash-table)))))
(define-inlinable (get-set x) (vector-ref x 0))
......@@ -68,6 +71,7 @@ This is prepared to make it functional, but currently we mutate
(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 (get-i->f x) (vector-ref x 9))
(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))
......@@ -107,6 +111,22 @@ This is prepared to make it functional, but currently we mutate
#|
Basic construction and removal of set and set graph relationship,
|#
(define print-set
(case-lambda
(() (print-set (fluid-ref *current-set-theory*)))
((theory)
(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))))
(pk
(let lp ((l (bits-to-is (- (get-new theory) 1))))
(if (pair? l)
(cons (tr (car l)) (lp (cdr l)))
'()))))))
(define print-theory
(case-lambda
(() (print-theory (fluid-ref *current-set-theory*)))
......@@ -134,6 +154,15 @@ Basic construction and removal of set and set graph relationship,
(get-i->set theory))
(pretty-print out))))
(define set->f
(case-lambda
((set f) (set->f (fluid-ref *current-set-theory*) set f))
((theory set f)
(update-set-theory theory
#:i->f (update (get-i->f theory)
(get-i (get-set->i theory) set)
f)))))
(define new-set
(case-lambda
((set)
......@@ -245,7 +274,6 @@ a natural generational mapping to help in constructing a match tree.
(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))
......@@ -367,66 +395,71 @@ a natural generational mapping to help in constructing a match tree.
new-theory))))
#|
#|
Balanced binary tree compilation
You take a set i, finds it's subs sub and if sub | m, then dive
|#
(define (mktree setbits set->f)
(define (clusterize setbits)
(let lp ((ss (bits-to-i setbits)) (done 0))
(if (pair? ss)
(let* ((i (car ss)))
(if (= (logand done i) 0)
(let ((ih (logand setbits (hash-ref i-to-subs i #f))))
(cons ih (lp (cdr ss) (logior done ih))))
(lp (cdr ss) done)))
'())))
(define (mktree1 setbits)
(if (= set-bits 0)
'()
(let ((cls (clusterize setbits)))
(map
(lambda (cluster-bits)
(let ((a (get-high-bit cluster-bits))
(t (get-rest-bits cluster-bits)))
(cons a (mktree1 t)))
cls)))))
(define (linearize tree)
(let lp ((r tree))
(match r
((x . y) (append (linearize x) (lenearize y)))
(() '())
(x (list x)))))
(define setlist (linearize (mktree1 setbits)))
(define tree
(let lp ((l (reverse setlist)) (tree (make-dynlist)))
(if (pair? l)
(let ((i (car l)))
(lp (cdr l)
(dynlist-add tree i
(case-lambda
((x)
(values x (vector x (hash-ref set->f x 0))))
((x y)
(logior x y))
(() 0)))))
tree)))
tree)
(define mktree
(case-lambda*
((#:key (setbits #f))
(mktree (fluid-ref *current-set-theory*) #:setbits setbits))
((theory #:key (setbits (- (get-new theory) 1)))
(define (clusterize setbits)
(let ((i->subs (get-i->subs theory)))
(let lp ((ss (bits-to-is setbits)) (done 0))
(if (pair? ss)
(let* ((i (car ss)))
(if (= (logand done i) 0)
(let ((ih (logand setbits (hash-ref i->subs i #f))))
(cons ih (lp (cdr ss) (logior done ih))))
(lp (cdr ss) done)))
'()))))
(define (mktree1 setbits)
(if (= setbits 0)
'()
(let ((cls (clusterize setbits)))
(map
(lambda (cluster-bits)
(let ((a (get-high-bit cluster-bits))
(t (get-rest-bits cluster-bits)))
(cons a (mktree1 t))))
cls))))
(define (linearize tree)
(let lp ((r tree))
(match r
((x . y) (append (linearize x) (linearize y)))
(() '())
(x (list x)))))
(define setlist (pk (linearize (mktree1 setbits))))
(define tree
(let ((i->f (get-i->f theory)))
(let lp ((l (reverse setlist)) (tree (make-dynlist)))
(if (pair? l)
(let ((i (car l)))
(lp (cdr l)
(dynlist-add tree i
(case-lambda
((x)
(values x
(vector x (get-i i->f x))))
((x y)
(logior x y))
(() 0)))))
tree))))
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
......@@ -435,9 +468,3 @@ from c-land in the indexer.
tree 0
(lambda (x)
(not (= (logand x ih) 0))))))
|#
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