dynlist now supports tree data field

parent f173e4ca
......@@ -135,8 +135,8 @@ PSSOURCES = \
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/library/clpfd.pl
language/prolog/modules/library/clpb.pl
# language/prolog/modules/library/clpfd.pl
# language/prolog/modules/library/apply_macros.pl
AM_MAKEINFOFLAGS=--force
......
......@@ -3,31 +3,60 @@
#:export (make-dynlist dynlist-add fold-dynlist-lr fold-dynlist-rl
walk-dynlist-lr walk-dynlist-rl
dynlist-remove))
(define (make-dynlist) `(#f -1))
(define (dynlist-add tree x)
#|
This will functionally build up a tree keeping it balanced and allow for quite
efficient lookup
tree format
tree:
0 : (#f #f -1)
1 : (d1 x1 0)
2 : ((#f #f -1) 2 d12 . (x2 . x1)
3 : ((d3 x3 0) 2 d12 . (x2 . x1)
4 : ((#f #f -1) 4 d1234 . ((d34 x4 . x3) . (d12 x2 . x1)))
5 : ((d5 x5 0) 4 d1234 . ((d43 x4 . x3) . (d12 x2 . x1)))
6 : (((#f #f -1) 2 . (d65 x6 . x5)) 4 d1234 . ((d43 x4 . x3) . (d12 x2 . x1)))
7 : (((d7 x7 0) 2 . (d65 x6 . x5)) 4 d1234 . ((d43 x4 . x3) . (d12 x2 . x1)))
8 : ((#f #f -1) 8 d12345678
(d5678 (d78 x8 . x7) . (d56 x6 . x5))
.
(d1234 (d34 x4 . x3) . (d12 x2 . x1)))
xi = #(val x)
|#
(define default (case-lambda ((x) #f) ((x y) #f)))
(define (make-dynlist) `(#f -1 #f))
(define* (dynlist-add tree x #:optional (comp default))
(define val 0)
(define (lp tree x)
(match tree
((l . (and rest (nr . r)))
((l . (and rest (nr data-r . r)))
(if (>= nr 1)
(call-with-values (lambda () (lp l x))
(lambda (l nl fix?)
(if (= nl nr)
(let ((nnr (+ nl nr)))
(values `(,l . ,r) nnr #t))
(if fix?
(values `(((#f -1) ,nl . ,l) . ,rest) 0 #f)
(values `(,l . ,rest) 0 #f)))))
(case nr
((-1)
(values `(,x 0) 0 #f))
((0)
(values `(,x . ,l) 2 #t)))))))
(call-with-values (lambda () (lp l x))
(lambda (l nl data-l fix?)
(if (= nl nr)
(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)))))))))
(call-with-values (lambda () (lp tree x))
(lambda (tree n fix?)
(lambda (tree n d fix?)
(if fix?
`((#f -1) ,n . ,tree)
`((#f -1 #f) ,n ,d . ,tree)
tree))))
(define (fold-dynlist-rl f tree seed)
......
......@@ -20,6 +20,7 @@
<push-dynamic>
<append-dynamic>
<clause-dynamic>
<clause-dynamic-3>
<retract-dynamic>
<retract-all-dynamic>
<lambda-dyn>
......@@ -725,6 +726,10 @@ add/run * vlist *
(define-syntax-rule (get-a x) (vector-ref x 1))
(define-syntax-rule (get-f x) (vector-ref x 2))
(define-syntax-rule (get-c x) (vector-ref x 3))
(define-syntax-rule (get-g x) (vector-ref x 4))
(define-syntax-rule (set-a x v) (vector-set! x 1 v))
(define-syntax-rule (set-f x v) (vector-set! x 2 v))
(define-syntax-rule (set-c x v) (vector-set! x 3 v))
(define-syntax-rule (get-tag x) (vector-ref x 0))
(define-syntax-rule (get-dyn x) (vector-ref x 1))
......@@ -737,7 +742,7 @@ add/run * vlist *
(define (make-1)
(vector (make-bitmap-tag) (make-dynlist) #f #f))
(define (make) (cons (make-1) (make-1)))
(define (p x) (if (and (procedure? x)
(eq? (car (procedure-minimum-arity x)) 0))
(x)
......@@ -746,20 +751,23 @@ add/run * vlist *
(let ((env (if raw? (make) (make-fluid (make)))))
(define (env-ref) (fluid-ref env))
(define (env-set! e) (fluid-set! env e))
(define (add-raw s a f c e)
(define (add-raw s a f c e g)
(let* ((t (get-tag e))
(d (get-dyn e))
(ar (get-ar e))
(l (get-li e))
(data (if l
(vector t (p a) (p f) (p c))
(vector t a f c))))
(vector (next-bitmap-tag t)
(dynlist-add d data)
(my-list-add ar data)
(if l (bitmap-indexer-add s (p a) t l) l))))
(a (if l a (p a)))
(f (if l f (p f)))
(c (if l c (p c)))
(data (vector t a f c g)))
(values
(vector (next-bitmap-tag t)
(dynlist-add d data)
(my-list-add ar data)
(if l (bitmap-indexer-add s a t l) l))
data)))
(define (xxx-vlist vlist-truncate! x)
(if (vlist? x)
(vlist-truncate! x)))
......@@ -779,7 +787,7 @@ add/run * vlist *
(xxx-hash vhash-truncate! (get-li er))
(xxx-vlist vlist-truncate! (get-ar el))
(xxx-vlist vlist-truncate! (get-ar er))))
(define (xxx-f e vlist-truncate! vhash-truncate!)
(let* ((el (car e))
(er (cdr e)))
......@@ -800,27 +808,35 @@ add/run * vlist *
(define (ref++-f e) (xxx-f e vlist-refcount++ vlist-refcount++))
(define (ref---f e) (xxx-f e vlist-refcount-- vlist-refcount--))
(define (add-l s a f c)
(define (add-l s a f c g)
(let ((e (fluid-ref env)))
(fluid-set! env (cons (add-raw s a f c (car e)) (cdr e)))))
(call-with-values (lambda () (add-raw s a f c (car e) g))
(lambda (v data)
(fluid-set! env (cons v (cdr e)))
data))))
(define (add-l-f e s a f c)
(cons (add-raw s a f c (car e)) (cdr e)))
(define (add-r s a f c)
(define (add-l-f e s a f c g)
(call-with-values (lambda () (add-raw s a f c (car e) g))
(lambda (v data)
(values
(cons v (cdr e))
data))))
(define (add-r s a f c g)
(let ((e (fluid-ref env)))
(fluid-set! env (cons (car e) (add-raw s a f c (cdr e))))))
(define (add-r-f e s a f c)
(cons (car e) (add-raw s a f c (cdr e))))
(define (add-l-e e s a f c)
(cons (add-raw s a f c (car e)) (cdr e)))
(define (add-r-e e s a f c)
(cons (car e) (add-raw s a f c (cdr e))))
(define (rm-raw s f e one?)
(call-with-values (lambda () (add-raw s a f c (cdr e) g))
(lambda (v data)
(fluid-set! env (cons (car e) v))
data))))
(define (add-r-f e s a f c g)
(call-with-values (lambda () (add-raw s a f c (cdr e) g))
(lambda (v data)
(values
(cons (car e) v)
data))))
(define (rm-raw s f e one? g)
(let* ((t (get-tag e))
(d (get-dyn e))
(ar (get-ar e))
......@@ -849,36 +865,36 @@ add/run * vlist *
(if change?
(fold-dynlist-rl
(lambda (x e)
(add-raw s (get-a x) (get-f x) (get-c x) e))
(add-raw s (get-a x) (get-f x) (get-c x) e g))
tree
(make-1))
(vector t tree ar (remove l rems)))))))
(define (rm s f one?)
(define (rm s f one? g)
(let* ((e (fluid-ref env))
(rm? #f)
(a1 (rm-raw s (lambda x
(if (apply f x)
(begin (set! rm? one?) #t)
#f))
(car e) one?))
(a2 (if rm? (cdr e) (rm-raw s f (cdr e) one?))))
(car e) one? g))
(a2 (if rm? (cdr e) (rm-raw s f (cdr e) one? g))))
(fluid-set! env (cons a1 a2))))
(define (rm-f e s f one?)
(define (rm-f e s f one? g)
(let* ((rm? #f)
(a1 (rm-raw s (lambda x
(if (apply f x)
(begin (set! rm? one?) #t)
#f))
(car e) one?))
(a2 (if rm? (cdr e) (rm-raw s f (cdr e) one?))))
(car e) one? g))
(a2 (if rm? (cdr e) (rm-raw s f (cdr e) one? g))))
(cons a1 a2)))
(define (expose a)
(vector-set! a 1 (p (vector-ref a 1)))
(vector-set! a 2 (p (vector-ref a 2)))
(vector-set! a 3 (p (vector-ref a 3))))
(set-a a (p (get-a a)))
(set-f a (p (get-f a)))
(set-c a (p (get-c a))))
(define (compile-raw e)
(let* ((l (get-dyn e))
......@@ -1085,19 +1101,19 @@ add/run * vlist *
(define (dynamic-push s g a f c)
(let ((env (object-property g 'dynamic-data)))
(if env
((vector-ref env 0) s a f c)
((vector-ref env 0) s a f c g)
(error "not a dynamic variable 1" g))))
(define (dynamic-append s g a f c)
(let ((env (object-property g 'dynamic-data)))
(if env
((vector-ref env 1) s a f c)
((vector-ref env 1) s a f c g)
(error "not a dynamic variable 2" g))))
(define (dynamic-remove s f F one?)
(let ((env (object-property f 'dynamic-data)))
(if env
((vector-ref env 2) s F one?)
((vector-ref env 2) s F one? f)
(error "not a dynamic variable 3" f))))
(define (dynamic-compile f)
......@@ -1160,6 +1176,24 @@ add/run * vlist *
(<=> c ,(cons head body))))
s p cc)))))))
(define <clause-dynamic-3>
(lambda (s p cc f head body ref)
(let ((ref (gp-lookup ref s)))
(if (gp-attvar? ref s)
(let ((fr (gp-newframe s)))
((dynamic-walk-lr f)
s p (gp-cp head s)
(lambda (p cut a vec last?)
(let ((p (lambda () (gp-unwind fr) (p))))
((<lambda> ()
(<let> ((c (<cp> (get-c vec))))
(<=> ref vec)
(<=> c ,(cons head body))))
s p cc)))))
(<and> (p s p cc)
(<=> ,(<cp> (get-c ref)) ,(cons head body))
(<=> f ,(get-g ref)))))))
(define-syntax ck-cons
......@@ -1381,15 +1415,27 @@ add/run * vlist *
(module-ref mod sym)))
(<cc> f))))
(<define-guile-log-rule> (<push-dynamic> f dyn-lambda)
(<let> ((g f))
(<values> (g) (create-if-missing g))
(<code> (apply dynamic-push S g dyn-lambda))))
(<define-guile-log-rule> (<append-dynamic> g dyn-lambda)
(<let> ((f g))
(<values> (f) (create-if-missing f))
(<code> (apply dynamic-append S f dyn-lambda))))
(define <push-dynamic>
(<case-lambda>
((f dyn-lambda)
(<let> ((g f))
(<values> (g) (create-if-missing g))
(<code> (apply dynamic-push S g dyn-lambda))))
((f u dyn-lambda)
(<let> ((g f))
(<values> (g) (create-if-missing g))
(<=> u ,(apply dynamic-push S g dyn-lambda))))))
(define <append-dynamic>
(<case-lambda>
((g dyn-lambda)
(<let> ((f g))
(<values> (f) (create-if-missing f))
(<code> (apply dynamic-append S f dyn-lambda))))
((g u dyn-lambda)
(<let> ((f g))
(<values> (f) (create-if-missing f))
(<=> u ,(apply dynamic-append S f dyn-lambda))))))
(<define-guile-log-rule> (<retract-dynamic> f y)
(<code> (dynamic-remove
......
......@@ -3,13 +3,10 @@
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log repr)
#:export (compile-match mockalambda))
(define compile-prolog #f)
(define (pp x) (pretty-print x) x)
(define-syntax-rule (aif (it) p a b) (let ((it p)) (if it a b)))
(define (repr s stx x)
......@@ -301,7 +298,7 @@
table)
temp)
(define (pu x) (pretty-print (syntax->datum x)) x)
(define (pu x) #;(pretty-print (syntax->datum x)) x)
(define (rep comp)
#`((@ (guile) vector) #,@(pu (map (lambda (co) (repr s source? co))
(vector->list comp)))))
......@@ -330,13 +327,13 @@
(lambda ()
#,(case (length fvars)
((0)
#`(let ((co (pp #,(rep comp))))
#`(let ((co #,(rep comp)))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(#,lam cut)))))
((1)
#`(let ((co (pp #,(rep comp))))
#`(let ((co #,(rep comp)))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(<let*> ((f (car external-vars))
......@@ -345,7 +342,7 @@
(#,lam cut v))))))
((2)
#`(let ((co (pp #,(rep comp))))
#`(let ((co #,(rep comp)))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(<let*> ((f1 (car external-vars))
......@@ -357,7 +354,7 @@
(fluid-set! f2 #f))
(#,lam cut v1 v2))))))
(else
#`(let ((co (pp #,(rep comp))))
#`(let ((co #,(rep comp)))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(<let> ((vs (mapi (lambda (x) (fluid-ref x))
......
......@@ -24,8 +24,12 @@
x))
(define-syntax-rule (mk-assert++ asserta <push-dynamic>)
(<define> (asserta Arg ext)
(<<match>> (#:mode - #:name asserta) (Arg)
(define asserta
(<case-lambda>
((Arg ext)
(<var> (U) (asserta Arg U ext)))
((Arg U ext)
(<<match>> (#:mode - #:name asserta) (Arg)
((? <var?>)
(instantiation_error))
......@@ -47,7 +51,7 @@
F
(length (<scm> A))))))
(type_error callable F))
(<push-dynamic> (<lookup> F)
(<push-dynamic> (<lookup> F) U
(catch #t
(lambda ()
(mockalambda #f
......@@ -78,7 +82,7 @@
(type_error callable F))
(<and>
(<push-dynamic> (<lookup> F)
(<push-dynamic> (<lookup> F) U
(catch #t
(lambda ()
(mockalambda #f (<scm> S) (<scm> A) true))
......@@ -90,15 +94,20 @@
(F
(if (procedure? (<lookup> F))
(asserta (vector (list F)) ext)
(type_error callable Arg))))))
(type_error callable Arg))))))))
(mk-assert++ asserta+_ <push-dynamic>)
(mk-assert++ assertz+_ <append-dynamic>)
(define-syntax-rule (mk-assert+ asserta <push-dynamic>)
(<define> (asserta Arg ext)
(<<match>> (#:mode - #:name asserta) (Arg)
(define asserta
(<case-lambda>
((Arg ext)
(<var> (u)
(asserta Arg u ext)))
((Arg U ext)
(<<match>> (#:mode - #:name asserta) (Arg)
((? <var?>)
(instantiation_error))
......@@ -120,7 +129,7 @@
F
(length (<scm> A))))))
(type_error callable F))
(<push-dynamic> (<lookup> F)
(<push-dynamic> (<lookup> F) U
(catch #t
(lambda ()
(compile-prolog (<scm> S)
......@@ -163,7 +172,7 @@
(F
(if (procedure? (<lookup> F))
(asserta (vector (list F)) ext)
(type_error callable Arg))))))
(type_error callable Arg))))))))
(mk-assert+ asserta_ <push-dynamic>)
(mk-assert+ assertz_ <append-dynamic>)
......@@ -329,47 +338,70 @@
(mk-assert++source asserta-source+ <push-dynamic>)
(mk-assert++source assertz-source+ <append-dynamic>)
(<define> (asserta x . l)
(asserta_ x (if (null? l) #f l)))
(<define> (assertz x . l)
(assertz_ x (if (null? l) #f l)))
(<define> (assertaf x . l)
(asserta+_ x (if (null? l) #f l)))
(<define> (assertzf x . l)
(assertz+_ x (if (null? l) #f l)))
(<define> (clause Head Body)
(<let> ((Head (<lookup> Head)))
(cond
((<var?> Head)
(instantiation_error))
((procedure? Head)
(clause (vector (list Head)) Body))
(else
(<var> (F A)
(<if> (<or> (<=> Head ,(vector (cons F A)))
(<and> (<=> Head F) (<=> A ())))
(<recur> lp ((FF (<lookup> F)))
(cond
((dynamic? FF)
(<clause-dynamic> FF A Body))
((procedure? FF)
(if (object-property FF 'prolog-symbol)
(lp (FF))
(permission_error access private_procedure
(vector
(list divide
FF
(length (<scm> A)))))))
(else
(type_error callable F))))
(<define*> (asserta x #:optional (u #f) #:key (ext #f))
(if u
(asserta_ x u ext)
(asserta_ x ext)))
(<define*> (assertz x #:optional (u #f) #:key (ext #f))
(if u
(assertz_ x u ext)
(assertz_ x ext)))
(<define*> (assertaf x #:optional (u #f) #:key (ext #f))
(if u
(asserta+_ x u ext)
(asserta+_ x ext)))
(<define*> (assertzf x #:optional (u #f) #:key (ext #f))
(if u
(assertz+_ x u ext)
(assertz+_ x ext)))
(define clause
(<case-lambda>
((clause Head Body)
(clause Head Body #f))
((clause Head Body Ref)
(if (or (not Ref) (attvar? Ref))
(<let> ((Head (<lookup> Head)))
(cond
((<var?> Head)
(instantiation_error))
((procedure? Head)
(clause (vector (list Head)) Body))
(else
(<var> (F A)
(<if> (<or> (<=> Head ,(vector (cons F A)))
(<and> (<=> Head F) (<=> A ())))
(<recur> lp ((FF (<lookup> F)))
(cond
((dynamic? FF)
(if Ref
(<clause-dynamic-3> FF A Body Ref)
(<clause-dynamic> FF A Body)))
((procedure? FF)
(if (object-property FF 'prolog-symbol)
(lp (FF))
(permission_error access private_procedure
(vector
(list divide
FF
(length (<scm> A)))))))
(else
(type_error callable F))))
(type_error callable Head)))))))
(type_error callable Head))))))
(<var> (F A)
(<clause-dynamic-3> F A Body Ref)
(if (null? A)
(<=> Head F)
(<=> Head ,(vector (cons F A)))))))))
(<define> (retract Arg)
(<let> ((Arg (<lookup> Arg)))
......@@ -490,4 +522,4 @@
(_
(type_error predicate_indicator X))))
(set! (@@ (logic guile-log prolog parser) assertz-source+) assertz-source+)
(set! (@@ (logic guile-log prolog parser) assertz-source+) assertz-source)
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