added scheme file to setup structures to match acyclic graphs

parent 58bc4f42
(define-module (logic guile-log inheritance)
#:use-module (logic guile-log dynlist)
#:export ())
(define i 1)
(define set-to-i (make-hash-table))
(define i-to-set (make-hash-table))
(define set-to-inher (make-hash-table))
(define i-to-inher (make-hash-table))
(define (new-set set)
(let ((j i))
(set! i (* i 2))
(hash-set! set-to-i set j)
(hash-set! i-to-set j set)
(hash-set! set-to-inher set j)
j))
(define set-to-inher (make-hash-table))
(define (a->-b set-a set-b)
(aif (bh) (hash-ref set-to-inher set-b #f)
(aif (ah) (hash-ref set-to-inher set-a #f)
(aif (i) (hash-ref set-to-i a #f)
(let ((h (logior ah bh)))
(hash-set! i-to-inher u h)
(hash-set! set-to-inher set-a h))))))
(define (get-high-bit x) (ash 1 (- (integer-length x) 1)))
(define (get-all-inh set)
(let ((ih (hash-ref set-to-inher set #f)))
(let lp ((ih ih))
(if (= ih 0)
'()
(let ((high (get-high-bit ih)))
(cons (hash-ref i-to-set high #f) (lp (lognot ih high))))))))
#|
Typically function matchers make use of a subset of the available types
and by restricting the scope of the possible matching sets we can allow
for faster deduction e.g. programs can have 1000 sets and then it is a bit
clumsy to scan all the sets at dispatch.
All this information is dynamicalle created. It would be nice to be able to
create static construction.
We could start naming all static functins and use them in the
formation to avoid dispatch
caching of common formations ans sub matchers is also a very god
task to take on also being able to indicate in/out relations could
enable severe speedups. what about ...
map(F : + X : (list integer),..., Z integer)
F(Z,X:A,...).
+(X:r(A),...,r(A)...Z:integer)
map
+(X:number,...,X:number)
Also we need to indicate that a term is an autocut e.g. no more terms
after this which means quite a lot of
M;M;M
TODO, make this functional
|#
(define (add-set set i sets smap inher)
(aif (r) (hash-ref smap set #f)
(values i sets smap inher)
(let ((j i)
(i (* 2 i)))
(let lp ((sets sets) (ih j))
(if (pair? sets)
(let ((sb (car sets)))
(aaif ((jj (hash-ref set-to-i set #f))
(hh (hash-ref set-to-inher set #f))
(jb (hash-ref smap sb #f))
(jjb (hash-ref set-to-i sb #f))
(hb (hash-ref inher sb #f))
(hhb (hash-ref set-to-inher sb #f)))
(when (> (logand jj hhb) 0)
(hash-set! inher sb (logior hb j)))
(when (> (logand jjb hh) 0)
(set! ih (logior jb ih)))
(lp (cdr sets) ih)))
(begin
(hash-set! smap set j)
(hash-set! inher set ih)
(values j (cons set sets) smap inher)))))))
#|
1 Find individual clusters
|#
(define (clusterize sets smap)
(let ((sets (sort sets (lambda (s1 s2)
(> (hash-ref smap s1 #f)
(hash-ref smap s2 #f))))))
(let lp ((ss sets))
(if (pair? ss)
(let ((cluster (all-in-ih smap (car ss))))
(cons cluster (lp (difference cluster))))
'()))))
(define (mktree1 sets smap)
(let ((cls (clusterize sets smap)))
(map (lambda (cluster) cls)
(if (and (pair cls) (pair? (cdr cls)))
(cons (car cluster) (mktree1 (cdr cluster) smap))
(if (null? cluster)
'()
(car cluster))))))
(define (linearize tree)
(let lp ((r tree))
(match r
((x . y) (append (linearize x) (lenearize y)))
(() '())
(x (list x)))))
(define (mktree2 l)
(define (divide l)
(let ((n (length l)))
(case n
((0)
(values #t #f #f))
((1)
(values #t (car x) #f))
((2)
(values #t (car x) (cadr x)))
(else
(let lp ((l l) (i 0) (r '()) (k (/ n 2)))
(if (< i k)
(lp (cdr l) (+ i 1) (cons (car l) r) k)
(values #f (reverse r) l)))))))
(call-with-values (lambda () (divide l))
(lambda (finish? x y)
(if finish?
(if y
(cons x y)
x)
(cons (mktree2 x) (mktree2 y))))))
(define (attach-or set-to-inh set-to-f tree)
(define (mk-f set) (hash-ref set-to-f set #f))
(define (mk-h h ) (logior (- h) h))
(let lp ((tree tree))
(match tree
((x . y)
(let-values (((px x) (lp x))
((py y) (lp y)))
(values
(cons (cons px x) (cons py y))
(logior px py))))
(#f
(values #f 0))
(x
(aif (h) (hash-ref set-to-inh x #f)
(let ((h (mk-h h)))
(values (vector h (mk-f x) x)
h))
e)))))
(define (add tree set f)
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