1% ----------------------------------------------------------------------
2% BEGIN LICENSE BLOCK
3% Version: CMPL 1.1
4%
5% The contents of this file are subject to the Cisco-style Mozilla Public
6% License Version 1.1 (the "License"); you may not use this file except
7% in compliance with the License.  You may obtain a copy of the License
8% at www.eclipse-clp.org/license.
9%
10% Software distributed under the License is distributed on an "AS IS"
11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
12% the License for the specific language governing rights and limitations
13% under the License.
14%
15% The Original Code is  The ECLiPSe Constraint Logic Programming System.
16% The Initial Developer of the Original Code is  Cisco Systems, Inc.
17% Portions created by the Initial Developer are
18% Copyright (C) 1989-2006 Cisco Systems, Inc.  All Rights Reserved.
19%
20% Contributor(s): ECRC GmbH
21%
22% END LICENSE BLOCK
23%
24% System:	ECLiPSe Constraint Logic Programming System
25% Version:	$Id: fd_elipsys.pl,v 1.2 2013/06/17 19:34:44 jschimpf Exp $
26% ----------------------------------------------------------------------
27
28/*
29 * IDENTIFICATION:      scheduling.pl
30 *
31 * AUTHOR:		Andre Veron
32 *			Micha Meier
33 *
34 * DESCRIPTION:         This file contains the Prolog part of Elipsys
35			finite domain constraints available in ECLiPSe
36
37 * CONTENTS:	        disjunctive/3
38                        disjunction/5
39			disjunction_choose/5
40			contigs/5
41			sequences/4
42
43 *
44 * REVISION HISTORY:
45	May 1993        Created the file
46	January 1994	Ported to 3.4 [Micha Meier]
47
48 * BUGS:                No type checking on the arguments of disjunctive/3
49                        No type checking on the arguments of disjunction/5
50 */
51
52
53:- module(fd_elipsys).
54
55:- import fd_arith.
56:- import fd_chip.
57
58:- export
59    disjunctive/3,
60    disjunction/5,
61    disjunction_choose/5.
62% These seem broken, and also conflict with the global_gac versions
63%    contigs/5,
64%    sequence/4.
65
66:- import
67	contigs_interface/6,
68	disjunctive_interface/4,
69	disjunction_choose_interface/6,
70	sequences_interface/5,
71	setarg/3
72    from sepia_kernel.
73
74disjunctive(Starts,Durations,Flags):-
75	% Same number of starting dates and durations
76	length(Starts,Ls),
77	length(Durations,Ld),
78	Ls = Ld,
79
80	% Create the arrays (structures) used by the constraint
81	% Array of starting dates
82	% Array of durations
83	% Array of flags/orientations
84
85	SStarts =.. [starts|Starts],
86	SDurations =.. [durations|Durations],
87	SS is Ls * Ls,
88	functor(SFlags,flags,SS),
89
90	% The elementary disjunctions monitoring the scheduling within
91	% pairs of tasks.
92
93	setup_disjunctions(Starts,Durations,Flags,SFlags),
94
95	% The actual constraint
96	disjunctive(SStarts,SDurations,Flags,SFlags),
97	true.
98
99disjunctive(Starts,Durations,Flags,SFlags):-
100
101	% Perform a reduction
102 	disjunctive_interface(Starts,Durations,SFlags, List),
103	handle_requests(List),
104
105	% Resuspend the constraint
106	make_suspension(disjunctive(Starts,Durations,Flags,SFlags), 4, Susp),
107	insert_suspension(Flags, Susp, inst of suspend, suspend).
108
109
110
111setup_disjunctions(Starts,Durations,Flags,SFlags):-
112	length(Starts,Arity),
113	setup_disjunctions(Starts,Durations,Flags,SFlags,0,1,Arity).
114
115setup_disjunctions([],[],[],_,_,_,_).
116setup_disjunctions([S|Ss],[D|Ds],Flags,SFlags,I,J,Arity):-
117        setup_disjunctions(Ss,S,Ds,D,Flags,FlagsTail,SFlags,I,J,Arity),
118	I1 is I + 1,
119	J1 is I1 + 1,
120        setup_disjunctions(Ss,Ds,FlagsTail,SFlags,I1,J1,Arity).
121
122setup_disjunctions([],_,[],_,Flags,Flags,_,_,_,_).
123setup_disjunctions([S|Ss],SS,[D|Ds],DD,[Flag|Flags],FlagsOut,SFlags,I,J,Arity):-
124	Flag :: 1..2,
125
126	% Set up one elementary disjunction
127	disjunction_choose(SS,DD,S,D,Flag),
128%	disjunction(SS,DD,S,D,Flag),
129
130	% Put the flag in the structure so that it can be accessed by the main
131	% constraint.
132	% Flag of disjunction between Task_I and Task_J (I < J, I,J in [0..nstarts-1]) is the
133	% (I*n_starts + J + 1)-th argument of the structure.
134
135	P is I*Arity + J + 1,
136	arg(P,SFlags,Flag),
137	J1 is J + 1,
138        setup_disjunctions(Ss,SS,Ds,DD,Flags,FlagsOut,SFlags,I,J1,Arity).
139
140disjunction_choose(X1,D1,X2,D2,F) :-
141    Goal = disjunction_choose(X1,D1,X2,D2,F),
142    check_integer(D1, Goal),
143    check_integer(D2, Goal),
144    check_domain(X1, Goal),
145    check_domain(X2, Goal),
146    check_var(F, Goal),
147
148    F :: 1 .. 2,
149    disjunction_choose_1(X1,D1,X2,D2,F).
150
151disjunction_choose_1(X1,D1,X2,D2,F):-
152	disjunction_choose_interface(X1,D1,X2,D2,F, List),
153	handle_requests(List),
154
155	(var(F) ->
156	    % Resuspend the constraint
157	    make_suspension(disjunction_choose_1(X1,D1,X2,D2,F), 3, Susp),
158	    insert_suspension(X1-X2, Susp, min of fd, fd),
159	    insert_suspension(X1-X2, Susp, max of fd, fd),
160	    insert_suspension(F, Susp, inst of suspend, suspend)
161	;
162	    % else we are done
163	    true
164	).
165
166check_integer(X, _) :-
167    integer(X),
168    !.
169check_integer(X, Goal) :-
170    var(X),
171    !,
172    error(4, Goal).
173check_integer(_, Goal) :-
174    error(5, Goal).
175
176check_domain(X, _) :-
177    integer(X),
178    !.
179check_domain(X, _) :-
180    is_integer_domain(X),
181    !.
182check_domain(X, Goal) :-
183    var(X),
184    !,
185    error(4, Goal).
186check_domain(_, Goal) :-
187    error(5, Goal).
188
189check_var(X, _) :-
190    integer(X),
191    !.
192check_var(X, _) :-
193    var(X),
194    !.
195check_var(_, Goal) :-
196    error(5, Goal).
197
198
199/* The contigs/5 constraint of ElipSys */
200
201
202contigs(ListItems,Item,MaxSequences,Occurences,Contigs):-
203
204	% Missing type checking - The list must be built with integers or
205	% with finite domain variables over integers
206
207	% Array of items to speed up the accesses
208	ArrayItems =.. [items|ListItems],
209
210	% Trivial reductions
211
212	length(ListItems,Temp1),
213	Temp2 :: 0 .. Temp1,
214	Temp2 = MaxSequences,
215
216	Temp3 :: 0 .. Temp1,
217	Temp3 = Occurences,
218
219	Temp4 is fix((Temp1 + 1)/2),
220	Temp5 :: 1 .. Temp4,
221	Contigs = Temp5,
222
223
224	contigs_1(ArrayItems,MaxSequences,Item,Occurences,Contigs).
225
226contigs_1(ArrayItems,MaxSequences,Item,Occurences,Contigs):-
227
228	contigs_interface(ArrayItems,MaxSequences,Item,Occurences,Contigs, List),
229	handle_requests(List),
230
231	% Resuspend the constraint
232
233	make_suspension(contigs_1(ArrayItems,MaxSequences,Item,Occurences,Contigs), 4, Susp),
234	insert_suspension(ArrayItems-MaxSequences-Occurences-Contigs, Susp, bound of suspend, suspend),
235	insert_suspension(ArrayItems-MaxSequences-Occurences-Contigs, Susp, min of fd, fd),
236	insert_suspension(ArrayItems-MaxSequences-Occurences-Contigs, Susp, max of fd, fd).
237
238sequence(ListItems,Item,MaxSequences,Occurences):-
239
240	% Missing type checking - The list must be built with integers or
241	% with finite domain variables over integers
242
243	% Array of items to speed up the accesses
244	ArrayItems =.. [items|ListItems],
245
246	% Trivial reductions
247
248	length(ListItems,Temp1),
249	Temp2 :: 0 .. Temp1,
250	Temp2 = MaxSequences,
251
252	Temp3 :: 0 .. Temp1,
253	Temp3 = Occurences,
254
255	sequence_1(ArrayItems,MaxSequences,Item,Occurences).
256
257sequence_1(ArrayItems,MaxSequences,Item,Occurences):-
258
259	sequences_interface(ArrayItems,MaxSequences,Item,Occurences, List),
260	handle_requests(List),
261
262	% Resuspend the constraint
263
264	make_suspension(sequence_1(ArrayItems,MaxSequences,Item,Occurences), 4, Susp),
265	insert_suspension(ArrayItems-MaxSequences-Occurences, Susp, bound of suspend, suspend),
266	insert_suspension(ArrayItems-MaxSequences-Occurences, Susp, min of fd, fd),
267	insert_suspension(ArrayItems-MaxSequences-Occurences, Susp, max of fd, fd).
268
269disjunction(Aa, Ad, Ba, Bd,Flag) :-
270    (integer(Flag) ->
271	( Flag == 1 ->
272	    Aa + Ad #<= Ba;
273	Flag == 2 ->
274	    Ba + Bd #<= Aa;
275	fail
276	)
277    ;
278
279    domain_copy(Aa, Aa1),
280    domain_copy(Ba, Ba1),
281    subcall(Aa1 + Ad #<= Ba1, _) ->
282	(domain_copy(Aa, Aa2),
283	domain_copy(Ba, Ba2),
284	subcall(Ba2 + Bd #<= Aa2, _) ->
285	    % Both possibilities are valid
286	    dvar_domain(Aa1, DA1),
287	    dvar_domain(Aa2, DA2),
288	    dvar_domain(Ba1, DB1),
289	    dvar_domain(Ba2, DB2),
290	    dom_union(DA1, DA2, DAU, _),
291	    dom_union(DB1, DB2, DBU, _),
292	    dvar_update(Aa, DAU),
293	    dvar_update(Ba, DBU),
294	    make_suspension(disjunction(Aa, Ad, Ba, Bd,Flag), 4, Susp),
295	    insert_suspension(Flag, Susp, inst of suspend, suspend),
296	    insert_suspension([Aa|Ba], Susp, min of fd, fd),
297	    insert_suspension([Aa|Ba], Susp, max of fd, fd)
298	; %%% second case failed
299	    Aa + Ad #<= Ba,
300	    Flag = 1
301	)
302    ; %%% first case failed
303	Ba + Bd #<= Aa,
304	Flag = 2
305    ).
306
307domain_copy(Domain, New) :-
308	is_domain(Domain),
309	!,
310	dvar_domain(Domain, D),
311	var_fd(New, D).
312domain_copy(X, X).
313
314
315handle_requests([]) :-
316    wake.
317handle_requests([R|L]) :-
318    handle_request(R),
319    handle_requests(L).
320
321handle_request(update_min(Val,Var)) :- !,
322	update_min(Val, Var),
323	true.
324handle_request(update_max(Val,Var)):- !,
325	update_max(Val, Var),
326	true.
327handle_request(update_any(Val,Var)):- !,
328	update_any(Val, Var),
329	true.
330handle_request(greatereq(Var1,Var2,Val)):- !,
331	Var1 #>= Var2 + Val,
332	true.
333
334update_min(_, X):-
335	nonvar(X),!.
336update_min(Val, Var) :-
337	Var #>= Val,
338	true.
339
340update_max(_, X) :-
341	nonvar(X),!.
342update_max(Val, Var) :-
343	Var #<= Val,
344	true.
345
346update_any(_, X) :-
347	nonvar(X),!.
348update_any(_Val, _{fd:Attr}) :-
349	-?->
350	Attr = fd with any:Any,
351	schedule_woken(Any),
352	setarg(any of fd, Attr, []).
353