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