clpfd compiles

parent 9fc237ac
......@@ -6,7 +6,10 @@ if test "@abs_top_srcdir@" != "@abs_top_builddir@"; then
fi
GUILE_LOAD_COMPILED_PATH=@abs_top_builddir@:$GUILE_LOAD_PATH
PATH=@abs_top_builddir@/bin:$PATH
GUILE_STACK_SIZE=1000000
export GUILE_STACK_SIZE
export GUILE_LOAD_PATH
export GUILE_LOAD_COMPILED_PATH
export PATH
......
......@@ -1464,6 +1464,7 @@ contracting([], Repeat, Vars) :-
( Repeat -> contracting(Vars, false, Vars)
; true
).
contracting([V|Vs], Repeat, Vars) :-
fd_inf(V, Min),
( \+ \+ (V = Min) ->
......@@ -1611,7 +1612,7 @@ sum(Vs, Op, Value) :-
scalar_product(Ones, Vs, Op, Value).
vars_plusterm([], _, T, T).
vars_plusterm([C|Cs], [V|Vs], T0, T) :- vars_plusterm(Cs, Vs, T0+(C* ?(V)), T).
vars_plusterm([C|Cs], [V|Vs], T0, T) :- vars_plusterm(Cs, Vs, T0+(C* '?'(V)), T).
%% scalar_product(+Cs, +Vs, +Rel, ?Expr)
%
......@@ -1636,7 +1637,7 @@ scalar_product(Cs, Vs, Op, Value) :-
sum([], _, Sum, Op, Value) :- call(Op, Sum, Value).
sum([C|Cs], [X|Xs], Acc, Op, Value) :-
?(NAcc) #= Acc + C* ?(X),
'?'(NAcc) #= Acc + C* '?'(X),
sum(Cs, Xs, NAcc, Op, Value).
multiples([], [], _).
......@@ -1645,7 +1646,7 @@ multiples([C|Cs], [V|Vs], Left) :-
( N =\= 1, gcd(C,N) =:= 1 ->
gcd(Cs, N, GCD0),
gcd(Left, GCD0, GCD),
( GCD > 1 -> ?(V) #= GCD * ?(_)
( GCD > 1 -> '?'(V) #= GCD * '?'(_)
; true
)
; true
......@@ -2080,7 +2081,7 @@ matches([
m_c(any(X) #>= any(Y), left_right_linsum_const(X, Y, Cs, Vs, Const)) =>
[g(( Cs = [1], Vs = [A] -> geq(A, Const)
; Cs = [-1], Vs = [A] -> Const1 is -Const, geq(Const1, A)
; Cs = [1,1], Vs = [A,B] -> ?(A) + ?(B) #= ?(S), geq(S, Const)
; Cs = [1,1], Vs = [A,B] -> '?'(A) + '?'(B) #= '?'(S), geq(S, Const)
; Cs = [1,-1], Vs = [A,B] ->
( Const =:= 0 -> geq(A, B)
; C1 is -Const,
......@@ -2092,7 +2093,7 @@ matches([
propagator_init_trigger(x_leq_y_plus_c(A, B, C1))
)
; Cs = [-1,-1], Vs = [A,B] ->
?(A) + ?(B) #= ?(S), Const1 is -Const, geq(Const1, S)
'?'(A) + '?'(B) #= '?'(S), Const1 is Const, geq(Const1, S)
; scalar_product_(#>=, Cs, Vs, Const)
))],
m(any(X) - any(Y) #>= integer(C)) => [d(X, X1), d(Y, Y1), g(C1 is -C), p(x_leq_y_plus_c(Y1, X1, C1))],
......@@ -5751,8 +5752,8 @@ resource_limit(T0, T, Tasks, Bss, L) :-
task_bs(Task, InfStart-Bs) :-
Task = task(Start,D,End,_,_Id),
?(D) #> 0,
?(End) #= ?(Start) + ?(D),
'?'(D) #> 0,
'?'(End) #= '?'(Start) + '?'(D),
maplist(finite_domain, [End,Start,D]),
fd_inf(Start, InfStart),
fd_sup(End, SupEnd),
......@@ -5762,7 +5763,7 @@ task_bs(Task, InfStart-Bs) :-
task_running([], _, _, _).
task_running([B|Bs], Start, End, T) :-
((T #>= Start) #/\ (T #< End)) #<==> ?(B),
((T #>= Start) #/\ (T #< End)) #<==> '?'(B),
T1 is T + 1,
task_running(Bs, Start, End, T1).
......@@ -6286,6 +6287,7 @@ attribute_goals(X) -->
),
attributes_goals(Ps).
/*
clpfd_aux:attribute_goals(_) --> [].
clpfd_aux:attr_unify_hook(_,_) :- false.
......@@ -6303,6 +6305,7 @@ clpfd_relation:attr_unify_hook(_,_) :- false.
clpfd_original:attribute_goals(_) --> [].
clpfd_original:attr_unify_hook(_,_) :- false.
*/
attributes_goals([]) --> [].
attributes_goals([propagator(P, State)|As]) -->
......@@ -6331,21 +6334,21 @@ unwrap_with(Goal, Term0, Term) :-
bare_integer(V0, V) :- ( integer(V0) -> V = V0 ; V = ?(V0) ).
attribute_goal_(presidual(Goal)) --> [Goal].
attribute_goal_(pgeq(A,B)) --> [?(A) #>= ?(B)].
attribute_goal_(pplus(X,Y,Z)) --> [?(X) + ?(Y) #= ?(Z)].
attribute_goal_(pneq(A,B)) --> [?(A) #\= ?(B)].
attribute_goal_(ptimes(X,Y,Z)) --> [?(X) * ?(Y) #= ?(Z)].
attribute_goal_(absdiff_neq(X,Y,C)) --> [abs(?(X) - ?(Y)) #\= C].
attribute_goal_(absdiff_geq(X,Y,C)) --> [abs(?(X) - ?(Y)) #>= C].
attribute_goal_(x_neq_y_plus_z(X,Y,Z)) --> [?(X) #\= ?(Y) + ?(Z)].
attribute_goal_(x_leq_y_plus_c(X,Y,C)) --> [?(X) #=< ?(Y) + C].
attribute_goal_(pdiv(X,Y,Z)) --> [?(X) / ?(Y) #= ?(Z)].
attribute_goal_(pexp(X,Y,Z)) --> [?(X) ^ ?(Y) #= ?(Z)].
attribute_goal_(pabs(X,Y)) --> [?(Y) #= abs(?(X))].
attribute_goal_(pmod(X,M,K)) --> [?(X) mod ?(M) #= ?(K)].
attribute_goal_(prem(X,Y,Z)) --> [?(X) rem ?(Y) #= ?(Z)].
attribute_goal_(pmax(X,Y,Z)) --> [?(Z) #= max(?(X),?(Y))].
attribute_goal_(pmin(X,Y,Z)) --> [?(Z) #= min(?(X),?(Y))].
attribute_goal_(pgeq(A,B)) --> ['?'(A) #>= '?'(B)].
attribute_goal_(pplus(X,Y,Z)) --> ['?'(X) + '?'(Y) #= '?'(Z)].
attribute_goal_(pneq(A,B)) --> ['?'(A) #\= '?'(B)].
attribute_goal_(ptimes(X,Y,Z)) --> ['?'(X) * '?'(Y) #= '?'(Z)].
attribute_goal_(absdiff_neq(X,Y,C)) --> [abs('?'(X) - '?'(Y)) #\= C].
attribute_goal_(absdiff_geq(X,Y,C)) --> [abs('?'(X) - '?'(Y)) #>= C].
attribute_goal_(x_neq_y_plus_z(X,Y,Z)) --> ['?'(X) #\= '?'(Y) + '?'(Z)].
attribute_goal_(x_leq_y_plus_c(X,Y,C)) --> ['?'(X) #=< '?'(Y) + C].
attribute_goal_(pdiv(X,Y,Z)) --> ['?'(X) / '?'(Y) #= '?'(Z)].
attribute_goal_(pexp(X,Y,Z)) --> ['?'(X) ^ '?'(Y) #= '?'(Z)].
attribute_goal_(pabs(X,Y)) --> ['?'(Y) #= abs('?'(X))].
attribute_goal_(pmod(X,M,K)) --> ['?'(X) mod '?'(M) #= '?'(K)].
attribute_goal_(prem(X,Y,Z)) --> ['?'(X) rem '?'(Y) #= '?'(Z)].
attribute_goal_(pmax(X,Y,Z)) --> ['?'(Z) #= max('?'(X),'?'(Y))].
attribute_goal_(pmin(X,Y,Z)) --> ['?'(Z) #= min('?'(X),'?'(Y))].
attribute_goal_(scalar_product_neq([FC|Cs],[FV|Vs],C)) -->
[Left #\= C],
{ coeff_var_term(FC, FV, T0), fold_product(Cs, Vs, T0, Left) }.
......@@ -6402,7 +6405,7 @@ conjunction(A, B, G, D) -->
; [(?(A) #/\ ?(B) #/\ G) #<==> ?(D)]
).
coeff_var_term(C, V, T) :- ( C =:= 1 -> T = ?(V) ; T = C * ?(V) ).
coeff_var_term(C, V, T) :- ( C =:= 1 -> T = '?'(V) ; T = C * '?'(V) ).
fold_product([], [], P, P).
fold_product([C|Cs], [V|Vs], P0, P) :-
......@@ -6438,11 +6441,12 @@ make_clpfd_var('$clpfd_current_propagator') :-
nb_setval('$clpfd_current_propagator', []).
make_clpfd_var('$clpfd_queue_status') :-
nb_setval('$clpfd_queue_status', enabled).
/*
:- multifile user:exception/3.
user:exception(undefined_global_variable, Name, retry) :-
make_clpfd_var(Name), !.
*/
warn_if_bounded_arithmetic :-
( current_prolog_flag(bounded, true) ->
......
......@@ -150,7 +150,7 @@
#{\\=}# #{\\==}# @< @> @>= @=< is op2:
op2+ op2- op1- op1+ #{\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
#{;}# -->
#{;}# --> ? $
*prolog-ops*
*swi-standard-operators*
......
......@@ -110,6 +110,8 @@
(PI x mod))
(((_ _ "/" _) (#:atom f . _) (#:number n _ _) _ _)
(list (cons* module f n)))
(((_ _ "//" _) (#:atom f . _) (#:number n _ _) _ _)
(list (cons* module f n)))
((#:atom f . _)
(list (list #f f)))
((#:list a _ _)
......
......@@ -48,7 +48,7 @@
#{\\=}# #{\\==}# #{\\=@=}# @< @> @>= @=< is
op2+ op2- op1- op1+ #{\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
=.. -->
=.. --> ? $
gop2+ gop2- gop1- gop1+
#{g\\}# gop2* gop2/ g// gop2rem gop2mod
......@@ -299,6 +299,8 @@
(mk-prolog-abstract 'fy ":-" op1:- tr-directive)
(mk-prolog-abstract 'xfx ":-" :- tr-fact)
(mk-prolog-abstract 'xfx "-->" --> tr-dcg)
(mk-prolog-abstract 'fx "?" ? tr-dcg)
(mk-prolog-abstract 'fx "$" $ tr-dcg)
(<define> (<:> module l)
(<let> ((module (ref-module (procedure-name (<lookup> module))))
......
......@@ -529,7 +529,10 @@
(<let> ((n N) (m M))
(xx (c1) (<or> (.. (atom c0))
(.. (qstring c0))
(.. (symbolic-tok c0))))
(.. ((f-and
(f-not (f-seq funop ws l))
symbolic-tok)
c0))))
(.. (c2) (l c1))
(.. (c3) ((f-or expr ws) c2))
(.. (c4) (r c3))
......
......@@ -128,7 +128,7 @@
((@@) (-eval- #`(@wrapper `#,(fget v) '#,li #t S))))))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
(if (string l)
(if (string? l)
(-eval- (compile-lambda stx l s closed?))
(-vector- #:brace (arg stx l))))
......@@ -215,7 +215,7 @@
#,@(map (lambda (x) #``#,x)
(cdr x))))))
(define (vec-arg tag x)
#`,(vector #,tag #,x))
#`,(vector #,tag `#,x))
(mk-mk-arg mk-arg var-arg x_x list-arg eval-arg term-arg vec-arg)
......@@ -251,7 +251,7 @@
#,@(map (lambda (x) #``#,x)
(cdr x)))))
(define (vec-var tag x)
#`,(vector #,tag #,x))
#`,(vector #,tag `#,x))
(mk-mk-arg mk-var var-var x_var list-var eval-var term-var vec-var)
......@@ -277,7 +277,7 @@
(cdr x))))))
(define (vec-term tag x)
#`,(vector #,tag #,x))
#`,(vector #,tag `#,x))
(mk-mk-arg mk-term var-term x_term list-term eval-term term-term vec-term)
......
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