constructors for attributed variables added to copy_term

parent 134ee5b9
......@@ -17,14 +17,23 @@ runner2(N,A,S) :- N > 0 -> (vhashq_ref(A,N,V),
SS is S + V,
NN is N - 1,
runner2(NN,A,SS)) ; (write(res(S)), nl).
runner4(N,A,S) :- N > 0 -> (vhash_ref(A,N,V),
SS is S + V,
NN is N - 1,
runner4(NN,A,SS)) ; (write(res(S)), nl).
ltoh([],H).
ltoh([K-V|L],H) :- vhashq_cons(H,K,V), ltoh(L,H).
ltoh4([],H).
ltoh4([K-V|L],H) :- vhash_cons(H,K,V), ltoh4(L,H).
do1(N,M,A) :- M > 0 -> (runner1(N,A,0), MM is M - 1, do1(N,MM,A)) ; true.
do2(N,M,A) :- M > 0 -> (runner2(N,A,0), MM is M - 1, do2(N,MM,A)) ; true.
do4(N,M,A) :- M > 0 -> (runner4(N,A,0), MM is M - 1, do4(N,MM,A)) ; true.
run1(N,M) :- once((f(L,N), list_to_assoc(L,A), do1(N,M,A))).
run2(N,M) :- once((f(L,N), make_vhash(A), ltoh(L,A), do2(N,M,A))).
run4(N,M) :- once((f(L,N), make_vhash(A), ltoh4(L,A), do4(N,M,A))).
")
(<define> (run3 n m)
......
......@@ -2069,7 +2069,6 @@ geq(A, B) :-
simpler constraints on their own, these simpler versions must be
handled separately and must occur before.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
match_expand(#>=, clpfd_geq_).
match_expand(#=, clpfd_equal_).
match_expand(#\=, clpfd_neq).
......@@ -6233,22 +6232,6 @@ goals_entail(Goals, E) :-
Unification hook and constraint projection
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
clfpdId(clpfd_attr(_,_,_,Dom,Ps), Other, #t) :-
( nonvar(Other) ->
( integer(Other) -> true
; type_error(integer, Other)
),
domain_contains(Dom, Other),
trigger_props(Ps),
do_queue
; fd_get(Other, OD, OPs),
domains_intersection(OD, Dom, Dom1),
append_propagators(Ps, OPs, Ps1),
fd_put(Other, Dom1, Ps1),
trigger_props(Ps1),
do_queue
).
append_propagators(fd_props(Gs0,Bs0,Os0), fd_props(Gs1,Bs1,Os1), fd_props(Gs,Bs,Os)) :-
maplist(append, [Gs0,Bs0,Os0], [Gs1,Bs1,Os1], [Gs,Bs,Os]).
......@@ -6278,6 +6261,7 @@ intervals_to_drep([A0-B0|Rest], Drep0, Drep) :-
),
intervals_to_drep(Rest, Drep0 \/ D1, Drep).
-attribute_cstor.
attribute_goals(X) -->
% { get_attr(X, clpfdId, Attr), format("A: ~w\n", [Attr]) },
{ get_attr(X, clpfdId, clpfd_attr(_,_,_,Dom,fd_props(Gs,Bs,Os))),
......@@ -6289,31 +6273,72 @@ attribute_goals(X) -->
),
attributes_goals(Ps).
-attach_attribute_cstor(attribute_goals).
clpfdId(clpfd_attr(_,_,_,Dom,Ps), Other, #t) :-
( nonvar(Other) ->
( integer(Other) -> true
; type_error(integer, Other)
),
domain_contains(Dom, Other),
trigger_props(Ps),
do_queue
; fd_get(Other, OD, OPs),
domains_intersection(OD, Dom, Dom1),
append_propagators(Ps, OPs, Ps1),
fd_put(Other, Dom1, Ps1),
trigger_props(Ps1),
do_queue
).
-attribute_cstor.
clpfd_aux_attribute_goals(_) --> [].
-attach_attribute_cstor(clpfd_aux_attribute_goals).
clpfd_auxId(_,_,_) :- false.
-attribute_cstor.
clpfd_gcc_vs_attribute_goals(_) --> [].
-attach_attribute_cstor(clpfd_gcc_vs_attribute_goals).
clpfd_gcc_vsId(_,_,_) :- false.
-attribute_cstor.
clpfd_gcc_num_attribute_goals(_) --> [].
-attach_attribute_cstor(clpfd_gcc_num_attribute_goals).
clpfd_gcc_numId(_,_,_) :- false.
clpfd_gcc_occurredId(_,_,_) :- false.
clpfd_relationId(_,_,_) :- false.
clpfd_originalId(_,_,_) :- false.
/*
clpfd_aux:attribute_goals(_) --> [].
clpfd_gcc_vs:attribute_goals(_) --> [].
-attribute_cstor.
clpfd_gcc_occurred_attribute_goals(_) --> [].
-attach_attribute_cstor(clpfd_gcc_occurred_attribute_goals).
clpfd_gcc_occurredId(_,_,_) :- false.
clpfd_gcc_num:attribute_goals(_) --> [].
-attribute_cstor.
clpfd_relation_attribute_goals(_) --> [].
clpfd_gcc_occurred:attribute_goals(_) --> [].
-attach_attribute_cstor(clpfd_relation_attribute_goals).
clpfd_relationId(_,_,_) :- false.
clpfd_relation:attribute_goals(_) --> [].
-attribute_cstor.
clpfd_original_attribute_goals(_) --> [].
clpfd_original:attribute_goals(_) --> [].
*/
-attach_attribute_cstor(clpfd_original_attribute_goals).
clpfd_originalId(_,_,_) :- false.
attributes_goals([]) --> [].
attributes_goals([propagator(P, State)|As]) -->
......
......@@ -49,3 +49,4 @@
(define (delayed-attribute lam)
(set-object-property! lam (@@ (logic guile-log code-load) delayed-id) #t))
......@@ -3,10 +3,31 @@
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log attributed)
#:re-export (multibute)
#:export (attvar put_attr get_attr get_attrs del_attr raw_attvar
construct_attr))
construct_attr attribute_cstor attach_attribute_cstor))
(define (attribute_cstor cstor)
(<lambda> (x)
(<var> (in out)
(cstor in out x)
(<recur> lp ((in in))
(<match> (#:mode -) (in)
((x . l)
(<cut>
(lp x)
(lp l)))
(()
(<cut> <cc>))
(x
(<cut>
(goal-eval x))))))))
(define (attach_attribute_cstor f cstor)
(set-attribute-cstor! f cstor)
f)
#|
(<define> (all_attvars V)
......
......@@ -442,3 +442,4 @@
(set! (@@ (logic guile-log prolog names) is-a-num?) is-a-num?)
(set! (@@ (logic guile-log prolog names) check-num) check-num)
(set! (@@ (logic guile-log prolog names) get-flag ) get-flag)
(set! (@@ (logic guile-log prolog modules) op) op)
......@@ -631,7 +631,9 @@ floor(x) (floor x)
;; COPY_TERM
(<define-guile-log-rule> (<copy_term> x l)
(<=> ,l ,(<cp> x)))
(<=> ,l ,(<cp> x))
(do-attribute-constructors))
(mk-prolog-term-2 tr-cp copy_term <copy_term> a a)
;;FINDALL
......
......@@ -24,7 +24,7 @@
ref-module-name
ref-module))
(define op #f)
(define *ops* (@@ (logic guile-log prolog parser) *prolog-ops*))
(define (source-file stx)
......@@ -479,7 +479,8 @@
(pre-compile-prolog-file 'ff)
(set-module! '#,(datum->syntax stx nm) (resolve-module 'f2)))
(with-fluids ((*ops* (fluid-ref *ops*)))
(process-use_module '((f2))))))))
(process-use_module '((f2))))
(use-pub-ops (resolve-module 'f2) (fluid-ref *current-stack*))))))
((name imports)
(let* ((g (-> name))
......@@ -507,7 +508,8 @@
(process-use_module
'((#,f
#:select
#,(datum->syntax stx (map ff (imp l)))))))))))))))
#,(datum->syntax stx (map ff (imp l)))))))
(use-pub-ops (resolve-module 'f2) (fluid-ref *current-stack*))))))))))
(lp l)))
......@@ -560,6 +562,20 @@
(<apply> use_module_ l)
(<code> (gp-var-set *once* S S)))
(define (use-pub-ops mod s)
(if (module-defined? mod '*public-module-operators*)
(let lp ((l (module-ref
mod
'*public-module-operators*)))
(if (pair? l)
(begin
(apply op
s
(lambda x x)
(lambda x x)
(car l))
(lp (cdr l)))))))
(define use_module_
(<case-lambda>
......@@ -608,7 +624,8 @@
(set-module! mname mod)
(with-fluids ((*ops* (fluid-ref *ops*))
(*current-stack* S))
(process-use_module `((,f2 #:select syms))))))))))
(process-use_module `((,f2 #:select syms))))
(use-pub-ops mod S)))))))
((x)
......@@ -635,15 +652,16 @@
((*current-language*
(lookup-language 'scheme)))
(resolve-module f2)))))
(set-module! mname mod)
(module-for-each (lambda x
(set-module! mname mod)
(module-for-each (lambda x
((undef-symbols mod)
(list (car x))))
mod))
mod)
(with-fluids ((*ops* (fluid-ref *ops*))
(*current-stack* S))
(process-use_module `((,f2)))))))))))))
(with-fluids ((*ops* (fluid-ref *ops*))
(*current-stack* S))
(process-use_module `((,f2))))
(use-pub-ops mod S)))))))))))
(define (parse-out-module stx x)
......
......@@ -113,6 +113,9 @@
add-new-unwind-hook
doit_on
doit_off
do-attribute-constructors
set-attribute-cstor!
#;gp-unwind))
......@@ -781,7 +784,32 @@
(define gp-einstein -einstein)
(define gp-next-to -next-to)
(define (gp-cp . x) (apply (fluid-ref *gp-cp*) x))
(define *cp-constructors* (make-fluid '()))
(define (gp-cp . x)
(fluid-set! *cp-constructors* '())
(apply (fluid-ref *gp-cp*) x))
(define (attribute-cstor-ref id)
(object-property id 'attribute-cstor))
(define (set-attribute-cstor! id val)
(set-object-property! id 'attribute-cstor val))
(define (do-attribute-constructors s p cc)
(let lp1 ((l (fluid-ref *cp-constructors*)) (s s) (p p))
(if (pair? l)
(let ((var (car l)))
(if (gp-attvar-raw? var s)
(let ((data (gp-att-data var s)))
(let lp2 ((data data) (s s) (p p))
(if (pair? data)
(let ((cstr (attribute-cstor-ref (caar data))))
(cstr s p (lambda (s p . x)
(lp2 (cdr data) s p))
var))
(lp1 (cdr l) s p))))
(lp1 (cdr l) s p)))
(cc s p))))
(define *gp->scm* (make-fluid gp->scm-))
(define gp->scm
......@@ -836,7 +864,12 @@
(if (not (hashq-ref tr x #f))
(begin
(hashq-set! tr x (gp-make-var))
(gp-att-data x s)))))
(for-each
(lambda (x)
(let ((id (car x)))
(if (not (attribute-cstor-ref id))
(lp x))))
(gp-att-data x s))))))
((gp-pair? x s)
(begin
......@@ -884,7 +917,21 @@
x
(let ((v (hashq-ref tr x 'BUG)))
(if (not (gp-attvar-raw? v s))
(gp-att-put-data v (lp (gp-att-data x s)) s)))))
(let ((l (let lp2 ((data (gp-att-data x s)))
(if (pair? data)
(let ((id (caar data)))
(if (not (attribute-cstor-ref id))
(cons
(lp (car data))
(lp2 (cdr data)))
(lp2 (cdr data))))
'()))))
(fluid-set! *cp-constructors*
(cons v
(fluid-ref *cp-constructors*)))
(gp-att-put-data v l s)))
v)))
((gp-pair? x s)
(cons (lp (gp-car x s))
......
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