Various improvements + dynamic goals works well with strings

parent 70ddc90e
......@@ -174,7 +174,7 @@ partition_(Diff, _, _, _, _, _, _) :-
maplist(Goal, List) :-
maplist_(List, Goal).
maplist_([], _).
maplist_([], _) :- !.
maplist_([Elem|Tail], Goal) :-
call(Goal, Elem),
maplist_(Tail, Goal).
......@@ -186,7 +186,7 @@ maplist_([Elem|Tail], Goal) :-
maplist(Goal, List1, List2) :-
maplist_(List1, List2, Goal).
maplist_([], [], _).
maplist_([], [], _) :- !.
maplist_([Elem1|Tail1], [Elem2|Tail2], Goal) :-
call(Goal, Elem1, Elem2),
maplist_(Tail1, Tail2, Goal).
......@@ -198,7 +198,7 @@ maplist_([Elem1|Tail1], [Elem2|Tail2], Goal) :-
maplist(Goal, List1, List2, List3) :-
maplist_(List1, List2, List3, Goal).
maplist_([], [], [], _).
maplist_([], [], [], _) :- !.
maplist_([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], Goal) :-
call(Goal, Elem1, Elem2, Elem3),
maplist_(Tail1, Tail2, Tail3, Goal).
......@@ -212,7 +212,7 @@ maplist_([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], Goal) :-
maplist(Goal, List1, List2, List3, List4) :-
maplist_(List1, List2, List3, List4, Goal).
maplist_([], [], [], [], _).
maplist_([], [], [], [], _) :- !.
maplist_([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], [Elem4|Tail4], Goal) :-
call(Goal, Elem1, Elem2, Elem3, Elem4),
maplist_(Tail1, Tail2, Tail3, Tail4, Goal).
......@@ -240,7 +240,7 @@ maplist_([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], [Elem4|Tail4], Goal) :-
foldl(Goal, List, V0, V) :-
foldl_(List, Goal, V0, V).
foldl_([], _, V, V).
foldl_([], _, V, V) :- !.
foldl_([H|T], Goal, V0, V) :-
call(Goal, H, V0, V1),
foldl_(T, Goal, V1, V).
......@@ -249,7 +249,7 @@ foldl_([H|T], Goal, V0, V) :-
foldl(Goal, List1, List2, V0, V) :-
foldl_(List1, List2, Goal, V0, V).
foldl_([], [], _, V, V).
foldl_([], [], _, V, V) :- !.
foldl_([H1|T1], [H2|T2], Goal, V0, V) :-
call(Goal, H1, H2, V0, V1),
foldl_(T1, T2, Goal, V1, V).
......@@ -258,7 +258,7 @@ foldl_([H1|T1], [H2|T2], Goal, V0, V) :-
foldl(Goal, List1, List2, List3, V0, V) :-
foldl_(List1, List2, List3, Goal, V0, V).
foldl_([], [], [], _, V, V).
foldl_([], [], [], _, V, V) :- !.
foldl_([H1|T1], [H2|T2], [H3|T3], Goal, V0, V) :-
call(Goal, H1, H2, H3, V0, V1),
foldl_(T1, T2, T3, Goal, V1, V).
......@@ -267,7 +267,7 @@ foldl_([H1|T1], [H2|T2], [H3|T3], Goal, V0, V) :-
foldl(Goal, List1, List2, List3, List4, V0, V) :-
foldl_(List1, List2, List3, List4, Goal, V0, V).
foldl_([], [], [], [], _, V, V).
foldl_([], [], [], [], _, V, V) :- !.
foldl_([H1|T1], [H2|T2], [H3|T3], [H4|T4], Goal, V0, V) :-
call(Goal, H1, H2, H3, H4, V0, V1),
foldl_(T1, T2, T3, T4, Goal, V1, V).
......
This diff is collapsed.
......@@ -5,6 +5,7 @@
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog gc-call)
#:use-module (language prolog modules boot dcg)
#:pure
#:duplicates (last replace)
......
(define-module (language prolog modules library vhash)
#:use-module (logic guile-log)
#:use-module (srfi srfi-9)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log vlist)
#:export (empty_assoc put_assoc get_assoc assoc_to_list))
#:export (empty_assoc put_assoc put_assoc_x get_assoc assoc_to_list
clear_assoc mk_node))
(<define> (mk_node nd . l)
(<=> nd ,(map (lambda (x) (<lookup> x)) l)))
(define-record-type <h>
(mk val)
h?
(val r s!))
(<define> (clear_assoc X)
(<let> ((H (<lookup> X)))
(<code> (s! H vlist-null))))
(<define> (empty_assoc X)
(<let> ((vh vlist-null))
(<let> ((vh (mk vlist-null)))
(<=> X vh)))
(<define> (put_assoc HEntry H0 Node H)
(<let> ((HEntry (<scm> HEntry))
(H0 (r (<lookup> H0))))
(<=> H ,(mk (vhash-cons HEntry (<lookup> Node) H0)))))
(<define> (put_assoc_x HEntry H0 Node)
(<let> ((HEntry (<scm> HEntry))
(H0 (<lookup> H0)))
(<=> H ,(vhash-cons HEntry Node H0))))
(<code> (s! H0 (vhash-cons HEntry (<lookup> Node)
(r H0))))))
(<define> (get_assoc HEntry H0 Node)
(<let*> ((HEntry (<scm> HEntry))
(H0 (<lookup> H0))
(H0 (r (<lookup> H0)))
(V (vhash-ref H0 HEntry #f)))
(when V (<=> Node V))))
(if V
(<and>
(<=> Node V))
(<and>
<fail>))))
(<define> (assoc_to_list H L)
......
......@@ -104,8 +104,12 @@
gp-put-attr
gp-put-attr-guarded
gp-put-attr-weak-guarded
gp-put-attr!
gp-put-attr-guarded!
gp-put-attr-weak-guarded!
gp-get-attr
gp-del-attr
gp-del-attr!
gp-att-put-data
gp-set-attribute-trampoline
gp-att-raw-var
......
......@@ -40,7 +40,7 @@ add/run * vlist *
(define (pp x) (pretty-print x) x)
(define (ppp a x) (pretty-print (list a (syntax->datum x))) x)
(define (make-indexer) #(#f #f 0 #f 0))
(define (make-indexer) #(#f #f 0 #f 0 #f #f))
(define-inlinable (get-car v)
(vector-ref v 0))
......@@ -52,6 +52,10 @@ add/run * vlist *
(vector-ref v 3))
(define-inlinable (get-all v)
(vector-ref v 4))
(define-inlinable (get-in-strings v)
(vector-ref v 5))
(define-inlinable (get-strings v)
(vector-ref v 6))
(define-inlinable (add-vars-all v x y)
(vector
......@@ -59,15 +63,19 @@ add/run * vlist *
(vector-ref v 1)
x
(vector-ref v 3)
y))
y
(vector-ref v 5)
(vector-ref v 6)))
(define-inlinable (add-atoms-all v x y)
(define-inlinable (add-atoms-all v x y z w)
(vector
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
x
y))
y
z
w))
(define-inlinable (add-car-cdr-all v x y z)
(vector
......@@ -75,7 +83,9 @@ add/run * vlist *
y
(vector-ref v 2)
(vector-ref v 3)
z))
z
(vector-ref v 5)
(vector-ref v 6)))
......@@ -135,22 +145,98 @@ add/run * vlist *
;; car cdr atoms vars
(begin
(define (get-nlist-from-atom a dlink)
(let* ((r (get-atoms dlink)))
(if r
(let ((x (vhash-assoc a r)))
(if x
(values r (cdr x))
(values r (make-empty))))
(values vlist-null (make-empty)))))
(let* ((r1 (get-atoms dlink))
(r2 (get-in-strings dlink))
(r3 (get-strings dlink)))
(cond
((string? a)
(if r2
(let ((x (vhash-assoc a r2))
(y (vhash-assoc a r3)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc a r3)))
(values r1 vlist-null r3 (make-empty)
(if x (cdr x) (make-empty))))
(values r1 vlist-null vlist-null (make-empty) (make-empty)))))
((procedure? a)
(let ((s (symbol->string (procedure-name a))))
(if r1
(let ((x (vhash-assoc a r1))
(y (vhash-assoc s r3)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc s r3)))
(values vlist-null
r2 r3
(make-empty)
(if x (cdr x) (make-empty))))
(values vlist-null
r2
vlist-null
(make-empty)
(make-empty))))))
(else
(if r1
(let ((x (vhash-assoc a r1)))
(if x
(values r1 r2 r3 (cdr x) #f)
(values r1 r2 r3 (make-empty) #f)))
(values vlist-null r2 r3 (make-empty) #f))))))
(define (get-nlist-from-atom! a dlink)
(let* ((r (get-atoms dlink)))
(if r
(let ((x (vhash-assoc a r)))
(if x
(values r (cdr x))
(values r #f)))
(values vlist-null #f))))
(let* ((r1 (get-atoms dlink))
(r2 (get-in-strings dlink))
(r3 (get-strings dlink)))
(define (make-empty) #f)
(cond
((string? a)
(if r2
(let ((x (vhash-assoc a r2))
(y (vhash-assoc a r3)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc a r3)))
(values r1 vlist-null r3 (make-empty)
(if x (cdr x) (make-empty))))
(values r1 vlist-null vlist-null (make-empty) (make-empty)))))
((procedure? a)
(let ((s (symbol->string (procedure-name a))))
(if r1
(let ((x (vhash-assoc a r1))
(y (vhash-assoc s r3)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc s r3)))
(values vlist-null
r2 r3
(make-empty)
(if x (cdr x) (make-empty))))
(values vlist-null
r2
vlist-null
(make-empty)
(make-empty))))))
(else
(if r1
(let ((x (vhash-assoc a r1)))
(if x
(values r1 r2 r3 (cdr x) #f)
(values r1 r2 r3 (make-empty) #f)))
(values vlist-null r2 r3 (make-empty) #f))))))
(define (index-remove s tag e dlink)
(if dlink
......@@ -175,10 +261,27 @@ add/run * vlist *
(difference (get-vars dlink) tag)
(difference (get-all dlink) tag))
(call-with-values (lambda () (get-nlist-from-atom a dlink))
(lambda (r k)
(add-atoms-all dlink
(vhash-cons a (difference k tag) r)
(difference (get-all dlink) tag)))))))
(lambda (r1 r2 r3 k1 k2)
(cond
((procedure? a)
(let ((s (symbol->string (procedure-name a))))
(add-atoms-all dlink
(vhash-cons a (difference k1 tag) r1)
(difference (get-all dlink) tag)
r2
(vhash-cons s (difference k2 tag) r3))))
((string? a)
(add-atoms-all dlink
r1
(difference (get-all dlink) tag)
(vhash-cons a (difference k1 tag) r2)
(vhash-cons a (difference k2 tag) r3)))
(else
(add-atoms-all dlink
(vhash-cons a (difference k1 tag) r1)
(difference (get-all dlink) tag)
r2 r3))))))))
#f))
(define (bitmap-indexer-add s e f dlink)
......@@ -207,10 +310,28 @@ add/run * vlist *
(union f (get-all dlink)))
(call-with-values (lambda () (get-nlist-from-atom a dlink))
(lambda (r k)
(add-atoms-all dlink
(vhash-cons a (union k f) r)
(union f (get-all dlink)))))))))
(lambda (r1 r2 r3 k1 k2)
(cond
((procedure? a)
(let ((s (symbol->string (procedure-name a))))
(add-atoms-all dlink
(vhash-cons a (union k1 f) r1)
(union f (get-all dlink))
r2
(vhash-cons s (union k2 f) r3))))
((string? a)
(add-atoms-all dlink
r1
(union f (get-all dlink))
(vhash-cons a (union k1 f) r2)
(vhash-cons a (union k2 f) r3)))
(else
(add-atoms-all dlink
(vhash-cons a (union k1 f) r1)
(union f (get-all dlink))
r2 r3)))))))))
(define (bitmap-indexer-add! s e f dlink)
(match e
......@@ -238,13 +359,40 @@ add/run * vlist *
(union f (get-all dlink)))
(call-with-values (lambda () (get-nlist-from-atom! a dlink))
(lambda (r v)
(add-atoms-all dlink
(with-fluids ((init-block-size 128))
(if v
(vhash-set! a (union f v) r)
(vhash-set! a f r)))
(union f (get-all dlink)))))))))
(lambda (r1 r2 r3 v1 v2)
(with-fluids ((init-block-size 128))
(cond
((procedure? a)
(let ((s (symbol->string (procedure-name a))))
(add-atoms-all dlink
(if v1
(vhash-set! a (union f v1) r1)
(vhash-set! a f r1))
(union f (get-all dlink))
r2
(if v2
(vhash-set! s (union f v2) r3)
(vhash-set! s f r3)))))
((string? a)
(add-atoms-all dlink
r1
(union f (get-all dlink))
(if v1
(vhash-set! a (union f v1) r2)
(vhash-set! a f r2))
(if v2
(vhash-set! a (union f v2) r3)
(vhash-set! a f r3))))
(else
(add-atoms-all dlink
(if v1
(vhash-set! a (union f v1) r1)
(vhash-set! a f r1))
(union f (get-all dlink))
r2 r3))))))))))
(define (get-fs-from-atoms a dlink)
(let ((r (get-atoms dlink)))
......
......@@ -9,10 +9,11 @@
#:use-module (logic guile-log vlist)
#:re-export (multibute)
#:export (attvar put_attr put_attr_guarded put_attr_weak_guarded
get_attr get_attrs del_attr raw_attvar
put_attr_x put_attr_guarded_x put_attr_weak_guarded_x
get_attr get_attrs del_attr del_attr_x raw_attvar
construct_attr attribute_cstor attach_attribute_cstor
call_residue_vars build_attribut_representation
attribute_prefix))
attribute_prefix del_attrs del_attrs_x))
(<define> (build_attribut_representation res tail x)
(<let> ((x (<lookup> x)))
......@@ -100,9 +101,12 @@
(type_error Mod atom)))
(representation_error Var)))))
(mkput put_attr <put-attr>)
(mkput put_attr_guarded <put-attr-guarded>)
(mkput put_attr_weak_guarded <put-attr-weak-guarded>)
(mkput put_attr <put-attr>)
(mkput put_attr_guarded <put-attr-guarded>)
(mkput put_attr_weak_guarded <put-attr-weak-guarded>)
(mkput put_attr_x <put-attr!>)
(mkput put_attr_guarded_x <put-attr-guarded!>)
(mkput put_attr_weak_guarded_X <put-attr-weak-guarded!>)
(<define> (get_attr Var Mod Val)
(<let> ((Mod (<lookup> Mod))
......@@ -141,3 +145,22 @@
(<del-attr> Var Mod)
(type_error Mod atom))))
(<define> (del_attr_x Var Mod)
(<let> ((Mod (<lookup> Mod)))
(<if> (atom CUT Mod)
(<del-attr!> Var Mod)
(type_error Mod atom))))
(<define> (del_attrs Var)
(<let> ((x (<lookup> Var)))
(if (gp-attvar-raw? x S)
(<var> (v)
(<set> x v))
<cc>)))
(<define> (del_attrs_x Var)
(<let> ((x (<lookup> Var)))
(if (gp-attvar-raw? x S)
(<var> (v)
(<set!> x v))
<cc>)))
(define-module (logic guile-log guile-prolog gc-call)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog goal-functors)
#:export (gc_call))
#:export (gc_call gc_scm_call gc_list_call))
(<define> (gc_call Var Code)
(<gc-call> Var '() (<lambda> () (goal-eval Code))))
(<define> (gc_scm_call Var Code)
(<gc-scm-call> Var (<lambda> () (goal-eval Code))))
(<define> (gc_list_call Var Code)
(<gc-list-call> Var (<lambda> () (goal-eval Code))))
......@@ -2,8 +2,8 @@
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
<cut> <wrap> <state-ref> <state-set!> <continue>
<code> <scm> <stall> <case-lambda> <cc>
<newframe> <=> <and> <lambda> <apply> <pp> S))
<code> <scm> <stall> <case-lambda> <cc> <set>
<newframe> <=> <and> <lambda> <apply> <pp> S P))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (logic guile-log vlist)
......@@ -341,8 +341,9 @@ HELP FOR PROLOG COMMANDS
(namespace-lexical? x))
S))))
(<define> (set_once) (<set> *once* P))
(<define> (if_once Y Z)
(if (eq? (<lookup> *once*) S)
(if (eq? (<lookup> *once*) P)
(goal-eval Y)
(goal-eval Z)))
......@@ -470,7 +471,7 @@ more :-
empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
solve(V,N,X) :- X,
solve(V,N,X) :- set_once,X,
if_once(output_and_more(V,N,#f),output_and_more(V,N,#t)).
.
")
......
......@@ -10,7 +10,7 @@
let-with-lr-guard)
#:export (<or-i> <or-union> <and-i>
<//> <update> <update-val> <zip> <call>
<set!> <gc-call>))
<gc-call> <gc-scm-call> <gc-list-call>))
(define-guile-log <or-i>
(syntax-rules ()
......@@ -197,12 +197,6 @@ and-interleave
(set! r (cons (mk-cont p2 ss) r))
(loop ss p2 g2 gs)))))))))
(define-guile-log <set!>
(syntax-rules ()
((_ meta s v)
(parse<> meta (<code> (set! s v))))))
(define-syntax-rule (cont-set! g p sin wind)
(let ((cont #f))
(set! g (lambda () (cont)))
......@@ -305,6 +299,21 @@ and-interleave
(<code> (<unwind> pr))
(<=> X res))))
(<define> (<gc-scm-call> X Lam)
(<let> ((pr (<newframe>)))
(Lam)
(<let> ((res (<scm> X)))
(<code> (<unwind> pr))
(<=> X res))))
(<define> (<gc-list-call> X Lam)
(<let> ((pr (<newframe>)))
(Lam)
(<let> ((res (->list S X)))
(<pp> (length res))
(<code> (<unwind> pr))
(<=> X res))))
(define-syntax-rule (fcall-m nm)
(define (nm s p cc lam x l f)
(let-with-lr-guard s wind lguard rguard ((cc cc))
......
......@@ -68,7 +68,7 @@
pairs_keys_values
same_length
same_term
transpose
;; guile-log
macro multibute
......
......@@ -24,7 +24,7 @@
<and!> <and!!> <succeds>
<format> <code> <ret>
<def> <def-> <<define>> <<define->> <dynwind>
parse<>
parse<> ->list
let<> <_>
<state-ref> <state-set!> <lv*> <clear>
tr S P CC CUT <scm>
......@@ -38,8 +38,9 @@
<with-bind>
<attvar?> attvar?
<put-attr> <put-attr-guarded> <put-attr-weak-guarded>
<get-attr> <del-attr> <get-attrs>
<raw-attvar> <attvar-raw?> <set>
<put-attr!> <put-attr-guarded!> <put-attr-weak-guarded!>
<get-attr> <del-attr> <del-attr!> <get-attrs>
<raw-attvar> <attvar-raw?> <set> <set!>
))
(define (<wrap> f . l)
......@@ -1036,7 +1037,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(if (pair? l)
(cons (car l) (->list s (cdr l)))
(if (gp-pair- l s)
(cons (gp-car l s) (->list s (gp-cdr l s)))
(cons (gp-lookup (gp-car l s) s) (->list s (gp-cdr l s)))
'()))))
(define-syntax def00
......@@ -1245,6 +1246,15 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<define> (<put-attr-weak-guarded> x m v)
(<code> (gp-put-attr-weak-guarded x m v S)))
(<define> (<put-attr!> x m v)
(<code> (gp-put-attr! x m v S)))
(<define> (<put-attr-guarded!> x m v)
(<code> (gp-put-attr-guarded! x m v S)))
(<define> (<put-attr-weak-guarded!> x m v)
(<code> (gp-put-attr-weak-guarded! x m v S)))
(<define> (<get-attrs> x m v)
(<let> ((x (<lookup> x)))
(when (gp-attvar-raw? x S)
......@@ -1267,7 +1277,8 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<r=> v ret)
(doit_on))))
(<define> (<del-attr> x m) (<code> (gp-del-attr x m S)))
(<define> (<del-attr> x m) (<code> (gp-del-attr x m S)))
(<define> (<del-attr!> x m) (<code> (gp-del-attr! x m S)))
(define (tr-meta f fnew)
......@@ -1297,6 +1308,10 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<define> (<set> x y)
(if (gp? x)
(<with-s> (gp-set! x y S) <cc>)))
(<define> (<set!> x y)
(if (gp? x)
(<code> (gp-var-set! x y))))
......
......@@ -102,8 +102,8 @@
(<define> (trace-fkn b f lev . l)
(if (<= lev trace-level )
(<and>
(<pp-dyn> `(,b enter ,f) `(,b leave ,f))
((@ (logic guile-log iso-prolog) write) (list 'trace f l))
;(<pp-dyn> `(,b enter ,f) `(,b leave ,f))
((@ (logic guile-log iso-prolog) write) (list b 'trace f #;l))
((@ (logic guile-log iso-prolog) nl)))
<cc>))
......
......@@ -939,12 +939,11 @@ floor(x) (floor x)
(<let> ((v (<lookup> v)))
(if (<var?> v)
(instantiation_error)
(<and>
(<code> (gp-var-set *call-expression* v S))
(goal-eval v)
(<code> (gp-var-set *once* S S))
<cut>))))
(<let> ((p P))
(<code> (gp-var-set *call-expression* v S))
(goal-eval v)
(<with-fail> p <cc>)))))
(<define-guile-log-rule> (once-mac v) (once-f v))
(mk-prolog-term-1 tr-once once once-mac a)
......
......@@ -142,7 +142,8 @@
#:use-module (logic guile-log)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog gc-call)
#:use-module (language prolog modules boot dcg)
#:pure
#:duplicates (last replace)
......
......@@ -36,7 +36,8 @@
pairs_keys
pairs_keys_values
same_length
same_term))
same_term
transpose))
(define term_variables
(<case-lambda>
......@@ -389,3 +390,22 @@
(<define> (same_term x y) (if (eq? (<lookup> x) (<lookup> y)) <cc>))
(<define> (transpose x y)