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