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