improved ast generation capabilities by skipping void matchers

parent 2eda0665
......@@ -134,8 +134,8 @@ PSSOURCES = \
language/prolog/modules/library/rbtrees.p \
language/prolog/modules/library/forward_chaining.pl \
language/prolog/modules/ex/att.pl \
language/prolog/modules/examples/cluster.pl \
language/prolog/modules/library/clpb.pl
language/prolog/modules/examples/cluster.pl
# language/prolog/modules/library/clpb.pl
# language/prolog/modules/library/clpfd.pl
# language/prolog/modules/library/apply_macros.pl
......
This diff is collapsed.
......@@ -2,7 +2,8 @@
#:use-module (ice-9 match)
#:export (make-dynlist dynlist-add fold-dynlist-lr fold-dynlist-rl
walk-dynlist-lr walk-dynlist-rl
dynlist-remove))
dynlist-remove
replace-dynlist-lr))
#|
This will functionally build up a tree keeping it balanced and allow for quite
efficient lookup
......@@ -25,13 +26,19 @@ tree:
xi = #(val x)
|#
(define default (case-lambda ((x) #f) ((x y) #f)))
(define (make-dynlist) `(#f -1 #f))
(define default (case-lambda (() #f) ((x) (values #f x)) ((x y) #f)))
(define-inlinable (val-ref x)
(cond
((vector? x) (vector-ref x 0))
((pair? x) (car x))
(else #f)))
(define k `(#f #f -1 #f))
(define (make-dynlist) k)
(define* (dynlist-add tree x #:optional (comp default))
(define val 0)
(define (lp tree x)
(match tree
((l . (and rest (nr data-r . r)))
((l data-all . (and rest (nr data-r . r)))
(if (>= nr 1)
(call-with-values (lambda () (lp l x))
(lambda (l nl data-l fix?)
......@@ -39,66 +46,94 @@ xi = #(val x)
(let ((nnr (+ nl nr))
(dr (comp data-r data-l)))
(values `(,(cons data-l l) ,data-r . ,r) nnr dr #t))
(if fix?
(values `(((#f -1 #f) ,nl ,data-l . ,l) . ,rest)
0 (comp data-l data-r) #f)
(values `(,l . ,rest)
0 (comp data-l data-r) #f)))))
(let ((val (comp x)))
(case nr
((-1)
(values `(,(vector val x) 0 ,val) 0 val #f))
((0)
(let ((vval (comp val (vector-ref l 0))))
(values
`(,(vector val x) . ,l) 2 vval #t)))))))))
(let ((c (comp data-l data-r)))
(if fix?
(values `((,k ,data-l ,nl ,data-l . ,l) ,c . ,rest)
0 c #f)
(values `(,l ,c . ,rest) 0 c #f))))))
(call-with-values (lambda () (comp x))
(lambda (val leaf)
(case nr
((-1)
(values `(,leaf ,val 0 ,val) 0 val #f))
((0)
(let ((vval (comp val (val-ref l))))
(values
`(,leaf . ,l) 2 vval #t))))))))))
(call-with-values (lambda () (lp tree x))
(lambda (tree n d fix?)
(if fix?
`((#f -1 #f) ,n ,d . ,tree)
`(,k ,d ,n ,d . ,tree)
tree))))
(define (fold-dynlist-rl f tree seed)
(define succeed (lambda (x) #t))
(define* (fold-dynlist-rl f tree seed #:optional (dive? succeed))
(define (fold-dynlist-rl-r r seed)
(match r
((l)
(f l seed))
((l . r)
(fold-dynlist-rl-r l (fold-dynlist-rl-r r seed)))
(l (f l seed))))
((d l . r)
(if (dive? d)
(fold-dynlist-rl-r l (fold-dynlist-rl-r r seed))
seed))
(l
(if (dive? (val-ref l))
(f l seed)
seed))))
(let lp ((tree tree) (seed seed))
(match tree
((_ -1)
((_ _ -1 _)
seed)
((l 0)
(f l seed))
((l n)
(lp l seed))
((l n . r)
(lp l (fold-dynlist-rl-r r seed))))))
((l _ 0 d)
(if (dive? d)
(f l seed)
seed))
((l d n d)
(if (dive? d)
(lp l seed)
seed))
((l d n . r)
(if (dive? d)
(lp l (fold-dynlist-rl-r r seed))
seed)))))
(define (fold-dynlist-lr f tree seed)
(define* (fold-dynlist-lr f tree seed #:optional (dive? succeed))
(define (fold-dynlist-lr-r r seed)
(match r
((l)
(f l seed))
((l . r)
(fold-dynlist-lr-r r (fold-dynlist-lr-r l seed)))
(l (f l seed))))
((d l . r)
(if (dive? d)
(fold-dynlist-lr-r r (fold-dynlist-lr-r l seed))
seed))
(l
(if (dive? (val-ref l))
(f l seed)
seed))))
(let lp ((tree tree) (seed seed))
(match tree
((_ -1)
((_ _ -1 _)
seed)
((l 0)
(f l seed))
((l n)
(lp l seed))
((l n . r)
(fold-dynlist-lr-r r (lp l seed)))
(l (f l seed)))))
((l d 0 _)
(if (dive? d)
(f l seed)
seed))
((l d n _)
(if (dive? d)
(lp l seed)
seed))
((l d n . r)
(if (dive? d)
(fold-dynlist-lr-r r (lp l seed))
seed))
(l
(if (dive? (val-ref l))
(f l seed)
seed)))))
(define (rebuild tree)
(fold-dynlist-rl
......@@ -107,30 +142,30 @@ xi = #(val x)
tree
(make-dynlist)))
(define (remove-raw pred tree one?)
(define* (remove-raw pred tree one? #:optional (co default))
(define never (lambda (x) #f))
(define (do-one x v)
(if x
(if (pred x)
(begin
(if one? (set! pred never))
(values #f #t 0 1))
(values v #f 1 1))
(values #f #t 0 1)))
(values #f #t 0 1 (co)))
(values v #f 1 1 (co v)))
(values #f #t 0 1 (co))))
(define-syntax-rule (comb-l x y n)
(define-syntax-rule (comb-l x y n d)
(if x
(if y
`(,x ,n . ,y)
`(,x ,d ,n . ,y)
`(,x 1))
(if y
`((#f -1) ,n . ,y)
`(,k ,d ,n . ,y)
#f)))
(define-syntax-rule (comb-r x y n)
(define-syntax-rule (comb-r x y n d)
(if x
(if y
`(,x . ,y)
`(,d ,x . ,y)
x)
(if y
y
......@@ -138,27 +173,28 @@ xi = #(val x)
(define-syntax-rule (sum tree comb x y N)
(call-with-values (lambda () x)
(lambda (val-x touch-x k-x n-x)
(lambda (val-x touch-x k-x n-x d-x)
(call-with-values (lambda () y)
(lambda (val-y touch-y k-y n-y)
(lambda (val-y touch-y k-y n-y d-y)
(let ((k (+ k-x k-y))
(d (co d-x d-y))
(touch (or touch-x touch-y)))
(if (not touch)
(values tree #f k N)
(if (or val-x val-y)
(values (comb val-x val-y N) #t k N)
(values #f #t 0 1)))))))))
(values (comb val-x val-y N d) #t k N d)
(values #f #t 0 1 (co))))))))))
(define (remove-r tree)
(match tree
((l . r)
((_ l . r)
(sum tree comb-r (remove-r l) (remove-r r) 1))
(l
(do-one l l))))
(define (remove-l tree)
(match tree
((l n . r)
((l _ n . r)
(if (>= n 1)
(sum tree comb-l (remove-raw pred l one?) (remove-r r) n)
(case n
......@@ -180,42 +216,119 @@ xi = #(val x)
(values tree #f)))))
(define (walk-dynlist-lr p f tree)
(define* (walk-dynlist-lr p f tree #:optional (dive? succeed))
(define (lp-r p tree)
(match tree
((l . r)
(lp-r (lambda () (lp-r p r)) l))
((d l . r)
(if (dive? d)
(lp-r (lambda () (lp-r p r)) l)
(p)))
(#f
(p))
(x (f p x))))
(x
(if (dive? (val-ref x))
(f p x)
(p)))))
(define (lp p tree)
(match tree
((#f -1)
((_ _ -1 _)
(p))
((x 0)
(f p x))
((l n . r)
(lp (lambda () (lp-r p r)) l))))
((x d 0 _)
(if (dive? d)
(f p x)
(p)))
((l d n . r)
(if (dive? d)
(lp (lambda () (lp-r p r)) l)
(p)))))
(lp p tree))
(define (walk-dynlist-rl p f tree)
(define* (walk-dynlist-rl p f tree #:optional (dive? succeed))
(define (lp-r p tree)
(match tree
((l . r)
(lp-r (lambda () (lp-r p l)) r))
((d l . r)
(if (dive? d)
(lp-r (lambda () (lp-r p l)) r)
(p)))
(#f
(p))
(x (f p x))))
(x
(if (dive? (val-ref x))
(f p x)
(p)))))
(define (lp p tree)
(match tree
((#f -1)
((_ _ -1 _)
(p))
((x 0)
(f p x))
((l n . r)
(lp-r (lambda () (lp p l)) r))))
((x d 0 _)
(if (dive? d)
(f p x)
(p)))
((l d n . r)
(if (dive? d)
(lp-r (lambda () (lp p l)) r)
(p)))))
(lp p tree))
(define* (replace-dynlist-lr tree replace
#:optional (dive? succeed) (comb default))
(define (lp-r tree)
(match tree
((d l . r)
(if (dive? d)
(call-with-values (lambda () (lp-r l))
(lambda (val-l dl)
(if (eq? val-l l)
(call-with-values (lambda () (lp-r r))
(lambda (val-r dr)
(if (and (eq? val-l l) (eq? val-r r))
(values tree d)
(let ((d (comb dl dr)))
(values (cons* d val-l val-r) d)))))
(let ((d (comb dl (val-ref r))))
(values (cons* d val-l r) d)))))
(values tree d)))
(#f
(values #f (comb)))
(x
(if (dive? (val-ref x))
(let ((val (replace x)))
(values x (val-ref x)))
(values x (val-ref x))))))
(define (lp tree)
(match tree
((_ _ -1 _)
(values tree (comb)))
((x d 0 _)
(if (dive? d)
(let ((x (replace x)))
(values x (val-ref x)))
(values x (val-ref x))))
((l d n . r)
(if (dive? d)
(call-with-values (lambda () (lp l))
(lambda (val-l dl)
(if (eq? val-l l)
(call-with-values (lambda () (lp-r r))
(lambda (val-r dr)
(if (and (eq? val-l l) (eq? val-r r))
(values tree d)
(let ((d (comb dl dr)))
(values (cons* val-l d n val-r) d)))))
(let ((d (comb dl (val-ref r))))
(values (cons* val-l d n r) d)))))
(values tree d)))))
(lp tree))
......@@ -477,7 +477,7 @@
(lambda (s cin cout) cin))
f-ws+))
(define parse
(define parse*
(case-lambda
((str matcher)
(define f
......@@ -510,6 +510,12 @@
(lambda () #f)
(lambda (s p cc) cc))))))
(define parse
(case-lambda
((str matcher)
(parse* str (f-seq f-nl matcher)))
((matcher)
(parse* matcher))))
(define (equalize stream x xl nstart)
(define n (- (rw-fstream-n xl) (length x)))
......@@ -629,7 +635,9 @@
(<p-lambda> (c)
(.. (c1) ((ss f) c))
(.. (c2) ((ss g) c1))
(<p-cc> (cons c1 c2))))))
(if (eq? c1 c)
(<p-cc> c2)
(<p-cc> (cons c1 c2)))))))
(define f-cons*
(f-wrap 'f-cons*
......
......@@ -1114,7 +1114,7 @@
(#((_ x _)) (<pp> x))
(_ <cc>))
(expand_term_0 x y)
;(<pp> `(expand-0-y ,y))
(<pp> `(expand-0-y ,y))
(<recur> lp ((y y) (r '()))
(<<match>> (#:mode - #:name expand) (y)
((x . 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