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) 1993-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: elipsys_fd.pl,v 1.1 2008/06/30 17:43:45 jschimpf Exp $
26% ----------------------------------------------------------------------
27
28/*
29 * IDENTIFICATION:      scheduling.pl
30 *
31 * AUTHOR:		Andre Veron
32 *
33 * DESCRIPTION:
34
35 * CONTENTS:	        disjunctive/3
36                        disjunction/5
37
38 *
39 * REVISION HISTORY:
40	May 1993        Created the file
41	January 1994	Ported to 3.4 [Micha Meier]
42
43 * BUGS:                No type checking on the arguments of disjunctive/3
44                        No type checking on the arguments of disjunction/5
45 */
46
47
48:- module(elipsys_fd).
49
50:- use_module(library(fd)).
51
52:- export
53    disjunctive/3,
54    disjunction/5,
55    disjunction_choose/5,
56    contigs/5,
57    sequence/4.
58
59:- import
60	setarg/3,
61	symbol_address/2
62    from sepia_kernel.
63
64:-  set_error_handler(211, fail/0),
65    (symbol_address(p_elipsys_fd_init, _) ->
66	true
67    ;
68	get_flag(installation_directory, Dir),
69	get_flag(hostarch, Arch),
70	get_flag(object_suffix, O),
71	concat_string([Dir, "/lib/", Arch, "/elipsys_fd.", O], OpLoad),
72	load(OpLoad)
73    ),
74    reset_error_handler(211).
75
76:- external(elipsys_fd_init/5, p_elipsys_fd_init).
77:- external(disjunctive_ / 4, disjunctive_interface).
78:- external(disjunction_choose_ / 6, disjunction_choose_interface).
79:- external(contigs_/6, contigs_interface).
80:- external(sequence_/5, sequences_interface).
81
82:- elipsys_fd_init(fd with [], domain of fd, min of fd, max of fd, any of fd).
83
84disjunctive(Starts,Durations,Flags):-
85
86	% Same number of starting dates and durations
87	length(Starts,Ls),
88	length(Durations,Ld),
89	Ls = Ld,
90
91	% Create the arrays (structures) used by the constraint
92	% Array of starting dates
93	% Array of durations
94	% Array of flags/orientations
95
96	SStarts =.. [starts|Starts],
97	SDurations =.. [durations|Durations],
98	SS is Ls * Ls,
99	functor(SFlags,flags,SS),
100
101	% The elementary disjunctions monitoring the scheduling within
102	% pairs of tasks.
103
104	setup_disjunctions(Starts,Durations,Flags,SFlags),
105
106	% The actual constraint
107	disjunctive(SStarts,SDurations,Flags,SFlags),
108	true.
109
110disjunctive(Starts,Durations,Flags,SFlags):-
111
112	% Perform a reduction
113 	disjunctive_(Starts,Durations,SFlags, List),
114	handle_requests(List),
115
116	% Resuspend the constraint
117	make_suspension(disjunctive(Starts,Durations,Flags,SFlags), 4, Susp),
118	insert_suspension(Flags, Susp, inst of suspend, suspend).
119
120
121
122setup_disjunctions(Starts,Durations,Flags,SFlags):-
123	length(Starts,Arity),
124	setup_disjunctions(Starts,Durations,Flags,SFlags,0,1,Arity).
125
126setup_disjunctions([],[],[],_,_,_,_).
127setup_disjunctions([S|Ss],[D|Ds],Flags,SFlags,I,J,Arity):-
128        setup_disjunctions(Ss,S,Ds,D,Flags,FlagsTail,SFlags,I,J,Arity),
129	I1 is I + 1,
130	J1 is I1 + 1,
131        setup_disjunctions(Ss,Ds,FlagsTail,SFlags,I1,J1,Arity).
132
133setup_disjunctions([],_,[],_,Flags,Flags,_,_,_,_).
134setup_disjunctions([S|Ss],SS,[D|Ds],DD,[Flag|Flags],FlagsOut,SFlags,I,J,Arity):-
135	Flag :: 1..2,
136
137	% Set up one elementary disjunction
138	disjunction_choose(SS,DD,S,D,Flag),
139%	disjunction(SS,DD,S,D,Flag),
140
141	% Put the flag in the structure so that it can be accessed by the main
142	% constraint.
143	% Flag of disjunction between Task_I and Task_J (I < J, I,J in [0..nstarts-1]) is the
144	% (I*n_starts + J + 1)-th argument of the structure.
145
146	P is I*Arity + J + 1,
147	arg(P,SFlags,Flag),
148	J1 is J + 1,
149        setup_disjunctions(Ss,SS,Ds,DD,Flags,FlagsOut,SFlags,I,J1,Arity).
150
151disjunction_choose(X1,D1,X2,D2,F):-
152
153	% Missing type checking
154
155	Temp1 :: 1 .. 2,
156	F = Temp1,
157
158	disjunction_choose_1(X1,D1,X2,D2,F).
159
160disjunction_choose_1(X1,D1,X2,D2,F):-
161	disjunction_choose_(X1,D1,X2,D2,F, List),
162	handle_requests(List),
163
164	(var(F) ->
165	    % Resuspend the constraint
166	    make_suspension(disjunction_choose_1(X1,D1,X2,D2,F), 3, Susp),
167	    insert_suspension(X1-X2, Susp, min of fd, fd),
168	    insert_suspension(X1-X2, Susp, max of fd, fd),
169	    insert_suspension(F, Susp, inst of suspend, suspend)
170	;
171	    % else we are done
172	    true
173	).
174
175
176/* The contigs/5 constraint of ElipSys */
177
178
179contigs(ListItems,Item,MaxSequences,Occurences,Contigs):-
180
181	% Missing type checking - The list must be built with integers or
182	% with finite domain variables over integers
183
184	% Array of items to speed up the accesses
185	ArrayItems =.. [items|ListItems],
186
187	% Trivial reductions
188
189	length(ListItems,Temp1),
190	Temp2 :: 0 .. Temp1,
191	Temp2 = MaxSequences,
192
193	Temp3 :: 0 .. Temp1,
194	Temp3 = Occurences,
195
196	Temp4 is fix((Temp1 + 1)/2),
197	Temp5 :: 1 .. Temp4,
198	Contigs = Temp5,
199
200
201	contigs_1(ArrayItems,MaxSequences,Item,Occurences,Contigs).
202
203contigs_1(ArrayItems,MaxSequences,Item,Occurences,Contigs):-
204
205	contigs_(ArrayItems,MaxSequences,Item,Occurences,Contigs, List),
206	handle_requests(List),
207
208	% Resuspend the constraint
209
210	make_suspension(contigs_1(ArrayItems,MaxSequences,Item,Occurences,Contigs), 4, Susp),
211	insert_suspension(ArrayItems-MaxSequences-Occurences-Contigs, Susp, bound of suspend, suspend),
212	insert_suspension(ArrayItems-MaxSequences-Occurences-Contigs, Susp, min of fd, fd),
213	insert_suspension(ArrayItems-MaxSequences-Occurences-Contigs, Susp, max of fd, fd).
214
215sequence(ListItems,Item,MaxSequences,Occurences):-
216
217	% Missing type checking - The list must be built with integers or
218	% with finite domain variables over integers
219
220	% Array of items to speed up the accesses
221	ArrayItems =.. [items|ListItems],
222
223	% Trivial reductions
224
225	length(ListItems,Temp1),
226	Temp2 :: 0 .. Temp1,
227	Temp2 = MaxSequences,
228
229	Temp3 :: 0 .. Temp1,
230	Temp3 = Occurences,
231
232	sequence_1(ArrayItems,MaxSequences,Item,Occurences).
233
234sequence_1(ArrayItems,MaxSequences,Item,Occurences):-
235
236	sequence_(ArrayItems,MaxSequences,Item,Occurences, List),
237	handle_requests(List),
238
239	% Resuspend the constraint
240
241	make_suspension(sequence_1(ArrayItems,MaxSequences,Item,Occurences), 4, Susp),
242	insert_suspension(ArrayItems-MaxSequences-Occurences, Susp, bound of suspend, suspend),
243	insert_suspension(ArrayItems-MaxSequences-Occurences, Susp, min of fd, fd),
244	insert_suspension(ArrayItems-MaxSequences-Occurences, Susp, max of fd, fd).
245
246disjunction(Aa, Ad, Ba, Bd,Flag) :-
247	(integer(Flag) ->
248	    (
249		( Flag == 1 ->
250		    Aa + Ad #<= Ba;
251		    ( Flag == 2 ->
252			Ba + Bd #<= Aa;
253			fail
254			)
255		    )
256		)
257	    ;
258
259	( domain_copy(Aa, Aa1),
260	    domain_copy(Ba, Ba1),
261	    subcall(Aa1 + Ad #<= Ba1, _)
262	->
263	( domain_copy(Aa, Aa2),
264	    domain_copy(Ba, Ba2),
265	    subcall(Ba2 + Bd #<= Aa2, _)
266	   ->
267	    mindomain(Aa1, Aa1m), mindomain(Aa2, Aa2m), min(Aa1m, Aa2m, NAam),
268	    maxdomain(Aa1, Aa1M), maxdomain(Aa2, Aa2M), max(Aa1M, Aa2M, NAaM),
269	    mindomain(Aa, Aam), maxdomain(Aa, AaM),
270	    ( (NAam \== Aam ; NAaM \== AaM)
271	     ->
272	      New_Aa :: NAam..NAaM,
273	      Aa = New_Aa
274	    ; true
275	    ),
276	    mindomain(Ba1, Ba1m), mindomain(Ba2, Ba2m), min(Ba1m, Ba2m, NBam),
277	    maxdomain(Ba1, Ba1M), maxdomain(Ba2, Ba2M), max(Ba1M, Ba2M, NBaM),
278	    mindomain(Ba, Bam), maxdomain(Ba, BaM),
279	    ( (NBam \== Bam ; NBaM \== BaM)
280	     ->
281	      New_Ba :: NBam..NBaM,
282	      Ba = New_Ba
283	    ; true
284	    ),
285	    make_suspension(disjunction(Aa, Ad, Ba, Bd,Flag), 4, Susp),
286	    insert_suspension(Flag, Susp, inst of suspend, suspend),
287	    insert_suspension([Aa|Ba], Susp, min of fd, fd),
288	    insert_suspension([Aa|Ba], Susp, max of fd, fd)
289	  ; %%% second case failed
290	    Aa + Ad #<= Ba
291 	    , Flag = 1
292	  )
293        ; %%% first case failed
294	  Ba + Bd #<= Aa
295          , Flag = 2
296        )
297    ).
298
299domain_copy(Domain, New) :-
300	is_domain(Domain),
301	!,
302	dvar_domain(Domain, D),
303	var_fd(New, D).
304domain_copy(X, X).
305
306
307handle_requests([]) :-
308    wake.
309handle_requests([R|L]) :-
310    handle_request(R),
311    handle_requests(L).
312
313handle_request(update_min(Val,Var)) :- !,
314	update_min(Val, Var),
315	true.
316handle_request(update_max(Val,Var)):- !,
317	update_max(Val, Var),
318	true.
319handle_request(update_any(Val,Var)):- !,
320	update_any(Val, Var),
321	true.
322handle_request(greatereq(Var1,Var2,Val)):- !,
323	Var1 #>= Var2 + Val,
324	true.
325
326update_min(_, X):-
327	nonvar(X),!.
328update_min(Val, Var) :-
329	Var #>= Val,
330	true.
331
332update_max(_, X) :-
333	nonvar(X),!.
334update_max(Val, Var) :-
335	Var #<= Val,
336	true.
337
338update_any(_, X) :-
339	nonvar(X),!.
340update_any(_Val, _{fd:Attr}) :-
341	-?->
342	Attr = fd with any:Any,
343	schedule_woken(Any),
344	setarg(any of fd, Attr, []).
345
346
347
348
349