1% BEGIN LICENSE BLOCK 2% Version: CMPL 1.1 3% 4% The contents of this file are subject to the Cisco-style Mozilla Public 5% License Version 1.1 (the "License"); you may not use this file except 6% in compliance with the License. You may obtain a copy of the License 7% at www.eclipse-clp.org/license. 8% 9% Software distributed under the License is distributed on an "AS IS" 10% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11% the License for the specific language governing rights and limitations 12% under the License. 13% 14% The Original Code is The ECLiPSe Constraint Logic Programming System. 15% The Initial Developer of the Original Code is Cisco Systems, Inc. 16% Portions created by the Initial Developer are 17% Copyright (C) 2006 Cisco Systems, Inc. All Rights Reserved. 18% 19% Contributor(s): Mark Wallace, IC-Parc 20% 21% END LICENSE BLOCK 22:- module(probe_support). 23 24:- lib(repair). 25:- lib(fd). 26 27:- export iddiff/3, 28 idmemb/2, 29 remove1/3, 30 replace_list/4, 31 set_to_tent/1, 32 set_to_min/1, 33 my_tent_call/4, 34 demon_suspend/4, 35 task_structure/4. 36:- export struct(task(start,duration,resource)). 37:- export struct(options(granularity,priority)). 38 39:- import 40 get_priority/1, 41 set_priority/1 42 from sepia_kernel. 43 44:- tool(demon_suspend/4,demon_suspend/5). 45:- tool(my_tent_call/4, my_tent_call/5). 46 47/************************************************************/ 48/************** Library Predicates ***********************/ 49/************************************************************/ 50 51task_structure(Tasks,Starts,Durations,Resources) :- 52 (foreach(task with [start:S,duration:D,resource:R],Tasks), 53 foreach(S,Starts), 54 foreach(D,Durations), 55 foreach(R,Resources) 56 do check_resource(R) 57 ). 58 59check_resource(R) :- mindomain(R)>0, !. 60check_resource(R) :- 61 write(error,'Error: a task has a potentially zero resource: '), 62 writeln(error,R), 63 abort. 64 65/* 66remove1(+Value,+InList,-OutList) 67Arguments: 68Value - The value or structure to be removed from a list 69InList - The input list from which the value is to be removed 70OutList - The remainder of the list after removing the value 71*/ 72remove1(X,[H|T],T) :- 73 nonvar(H), H=X, !. 74remove1(X,[H|T],[H|R]) :- 75 remove1(X,T,R). 76 77 78/* 79iddiff(+List1,+List2,-OutList) 80Arguments: 81List1 - an (input) list of variables 82List2 - an (input) list of variables 83OutList - an (output) variable 84 85iddiff returns a list of variables occurring in the first list 86 List1, but not in the second list List2 87*/ 88 89iddiff(List1,List2,OutList) :- 90 foreach(Var,List1), 91 fromto([],This,Next,OutList), 92 param(List2) 93 do (idmemb(Var,List2) -> Next=This ; Next=[Var|This]). 94 95/* 96idmemb(?Var,+List) 97Var is a variable 98List is a list 99 100idmemb succeeds if the variable is a member of the list: idmemb uses 101identity to test for membership, rather than unification as used by member. 102*/ 103 104idmemb(Var,[H|_]) :- Var==H, !. 105idmemb(Var,[_|T]) :- idmemb(Var,T). 106 107/* 108replace_list(+VarList,?Term,+ValList,?NewTerm) 109Arguments: 110VarList - a list of variables 111Term - a term (containing some or all of those variables, among others) 112ValList - a list of "things" (variables, atoms, terms) of the same 113 length as the VarList 114NewTerm - an (output) variable 115 116Same as: 117 copy_term_vars(VarList, 118 VarList-Term, 119 ValList-NewTerm), 120but doesn't keep finite domains. 121 122replace_list makes a new term NewTerm from an existing term Term, by 123 replacing all the variables in the VarList by the values in the 124 ValList 125*/ 126replace_list(VarList,Term,ValList,NewTerm) :- 127 foreach(Var,VarList),foreach(Val,ValList), 128 fromto(Term,This,Next,NewTerm) 129 do replace(Var,This,Val,Next). 130 131replace(Var,Term,Val,Val) :- Term==Var, !. 132replace(_Var,Term,_Val,Term) :- (var(Term) ; atomic(Term)), !. 133replace(Var,Term,Val,NewTerm) :- 134 Term=..[F|Args], 135 replace_each(Var,Args,Val,NewArgs), 136 NewTerm=..[F|NewArgs]. 137 138replace_each(Var,List,Val,NewList) :- 139 foreach(El,List), foreach(NewEl,NewList), param(Var,Val) 140 do replace(Var,El,Val,NewEl). 141 142/* Should be an ECLiPSe built-in */ 143set_to_tent(Term) :- 144 Term tent_get Term. 145 146set_to_min(Cost) :- 147 mindomain(Cost,MinCost), 148 Cost=MinCost. 149 150 151 152/* 153demon_suspend(Goal,Prior,Cond,Susp) 154This should probably be a built-in in ECLiPSe. It suspends a 155goal, but it also calls it immediately. 156*/ 157:- inline(demon_suspend/4, tr_demon_suspend/2). 158tr_demon_suspend( 159 demon_suspend(Goal,Prior,Cond,Susp), 160 ( 161 suspend(Goal,Prior,Cond,Susp), 162 schedule_woken([Susp]), 163 wake 164 )). 165 166demon_suspend(Goal,Prior,Cond,Susp,Module) :- 167 suspend(Goal,Prior,Cond,Susp)@Module, 168 schedule_woken([Susp]), 169 wake. 170 171/* 172my_tent_call(?InTerm,?Goal,?OutTerm,+Priority,+Module) 173Arguments: 174InTerm - Any term containing variables whose tentative values are 175 input to the propagation 176Goal - Any goal which can be called in ECLiPSe 177OutTerm - Any term containing variables whose tentative values will be 178 set by this propagation. 179 180my_tent_call sets up two demons, one to perform propagation whenever the 181 tentative values change, and the other to kill the first demon 182 whenever the variables all become instantiated. 183*/ 184my_tent_call(InTerm,Goal,OutTerm,Priority,Module) :- 185 shelf_create(tent_val(nil),GlobVar), 186 term_variables(InTerm,InVars), 187 term_variables(OutTerm,OutVars1), 188 iddiff(OutVars1,InVars,OutVars), 189 replace_list(InVars,Goal,InParams,Goal2), 190 replace_list(OutVars,Goal2,OutParams,NewGoal), 191 Prior is Priority+1, 192 demon_suspend(tent_call_prior(InVars,InParams,NewGoal,GlobVar,OutParams,OutVars,Module),Priority,InVars->ga_chg,Susp), 193 demon_suspend(kill_tent_check(InVars,Goal,Susp,S,Module),Prior,InVars->inst,S). 194 195 196:- demon kill_tent_check/5. 197kill_tent_check(InVars,Goal,Susp,S,Module) :- 198 ground(InVars), !, 199 call(Goal)@Module, 200 kill_suspension(Susp), 201 kill_suspension(S). 202kill_tent_check(_,_,_,_,_). 203 204/* 205tent_call_prior(?InVars,?Goal,?OutVars,+Module) 206Variables occurring in both the InVars and the OutVars are treated as input. 207 The input variables are replaced by their tentative values and the 208 output variables by new variables. The resulting goal is then 209 invoked, and the output values tentatively assigned to the output 210 variables. 211*/ 212:- demon tent_call_prior / 7. 213tent_call_prior(InVars,InParams,NewGoal,GlobVar,OutParams,_OutVars,Module) :- 214 InVars tent_get Value,true, 215 InParams = Value, 216 ( call(NewGoal)@Module -> 217 shelf_set(GlobVar,1,OutParams) ; 218 shelf_set(GlobVar,1,nil) 219 ), fail. 220tent_call_prior(_InVars,_InParams,_NewGoal,GlobVar,_OutParams,OutVars,_Module) :- 221 shelf_get(GlobVar,1,OutParams), 222 (OutVars=nil -> fail ; OutVars tent_set OutParams). 223 224:- comment(categories, ["Constraints","Techniques"]). 225:- comment(summary, "Probe Support Library"). 226:- comment(author, "Mark Wallace, Hani El Sakkout"). 227:- comment(date, "$Date: 2009/07/16 09:11:27 $"). 228:- comment(copyright, "Cisco Systems, Inc."). 229 230:- comment(desc, html(" 231 A library exporting structures and predicates used in probing for scheduling. 232<P> 233The following two structures are exported: 234<PRE> 235task(start,duration,resource) 236options(granularity,priority) 237</PRE> 238<P> 239 ")). 240 241