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