1/*  Part of SWI-Prolog
   2
   3    Author:        Tom Schrijvers, K.U.Leuven
   4    E-mail:        Tom.Schrijvers@cs.kuleuven.ac.be
   5    WWW:           http://www.swi-prolog.org
   6    Copyright (c)  2004-2016, K.U.Leuven
   7    All rights reserved.
   8
   9    Redistribution and use in source and binary forms, with or without
  10    modification, are permitted provided that the following conditions
  11    are met:
  12
  13    1. Redistributions of source code must retain the above copyright
  14       notice, this list of conditions and the following disclaimer.
  15
  16    2. Redistributions in binary form must reproduce the above copyright
  17       notice, this list of conditions and the following disclaimer in
  18       the documentation and/or other materials provided with the
  19       distribution.
  20
  21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  32    POSSIBILITY OF SUCH DAMAGE.
  33*/
  34
  35:- module(when,
  36          [ when/2                      % +Condition, :Goal
  37          ]).
  38:- set_prolog_flag(generate_debug_info, false).
  39
  40:- meta_predicate
  41    when(+, 0),
  42    suspend_list(+, 0),
  43    trigger(+, 0),
  44    trigger_disj(+, 0),
  45    trigger_conj(+, +, 0).
  46
  47/** <module> Conditional coroutining
  48
  49This library implements the when/2 constraint, delaying a goal until its
  50arguments are sufficiently instantiated.  For   example,  the  following
  51delayes the execution of =:=/2 until the expression is instantiated.
  52
  53    ==
  54        ...
  55        when(ground(Expr), 0 =:= Expr),
  56    ==
  57
  58@author Tom Schrijvers (initial implementation)
  59@author Jan Wielemaker
  60*/
  61
  62%!  when(+Condition, :Goal)
  63%
  64%   Execute Goal when Condition is satisfied. I.e., Goal is executed
  65%   as by call/1  if  Condition  is   true  when  when/2  is called.
  66%   Otherwise  Goal  is  _delayed_  until  Condition  becomes  true.
  67%   Condition is one of the following:
  68%
  69%       * nonvar(X)
  70%       * ground(X)
  71%       * ?=(X,Y)
  72%       * (Cond1,Cond2)
  73%       * (Cond2;Cond2)
  74%
  75%   For example (note the order =a= and =b= are written):
  76%
  77%       ==
  78%       ?- when(nonvar(X), writeln(a)), writeln(b), X = x.
  79%       b
  80%       a
  81%       X = x
  82%       ==
  83
  84when(Condition, Goal) :-
  85    '$eval_when_condition'(Condition, Optimised),
  86    trigger_first(Optimised, Goal).
  87
  88%!  '$eval_when_condition'(+Condition, -Optimised)
  89%
  90%   C-building block defined in pl-attvar.c.   It  pre-processes the
  91%   when-condition, checks it  for   errors  (instantiation  errors,
  92%   domain-errors and cyclic terms) and   simplifies it. Notably, it
  93%   removes already satisfied conditions   from  Condition, unifying
  94%   Optimised to =true= if  there  is   no  need  to suspend. Nested
  95%   disjunctions are reported as or(List).
  96
  97
  98trigger_first(true, Goal) :-
  99    !,
 100    call(Goal).
 101trigger_first(nonvar(X), Goal) :-
 102    !,
 103    '$suspend'(X, when, trigger_nonvar(X, Goal)).
 104trigger_first(Cond, Goal) :-
 105    trigger(Cond, Goal).
 106
 107trigger(nonvar(X),Goal) :-
 108    trigger_nonvar(X,Goal).
 109trigger(ground(X),Goal) :-
 110    trigger_ground(X,Goal).
 111trigger(?=(X,Y),Goal) :-
 112    trigger_determined(X,Y,Goal).
 113trigger((G1,G2),Goal) :-
 114    trigger_conj(G1,G2,Goal).
 115trigger(or(GL),Goal) :-
 116    trigger_disj(GL, check_disj(_DisjID,GL,Goal)).
 117
 118trigger_nonvar(X, Goal) :-
 119    (   nonvar(X)
 120    ->  call(Goal)
 121    ;   '$suspend'(X, when, trigger_nonvar(X, Goal))
 122    ).
 123
 124trigger_ground(X, Goal) :-
 125    term_variables(X, Vs),
 126    (   Vs = [H]
 127    ->  '$suspend'(H, when, trigger_ground(H, Goal))
 128    ;   Vs = [H|_]
 129    ->  T =.. [f|Vs],
 130        '$suspend'(H, when, trigger_ground(T, Goal))
 131    ;   call(Goal)
 132    ).
 133
 134trigger_determined(X, Y, Goal) :-
 135    unifiable(X, Y, Unifier),
 136    !,
 137    (   Unifier == []
 138    ->  call(Goal)
 139    ;   put_attr(Det, when, det(trigger_determined(X,Y,Goal))),
 140        suspend_list(Unifier, wake_det(Det))
 141    ).
 142trigger_determined(_, _, Goal) :-
 143    call(Goal).
 144
 145
 146wake_det(Det) :-
 147    ( var(Det) ->
 148            get_attr(Det,when,Attr),
 149            del_attr(Det,when),
 150            Det = (-),
 151            Attr = det(Goal),
 152            call(Goal)
 153    ;
 154            true
 155    ).
 156
 157trigger_conj(G1,G2,Goal) :-
 158    trigger(G1, trigger(G2,Goal)).
 159
 160trigger_disj([],_).
 161trigger_disj([H|T], G) :-
 162    trigger(H, G),
 163    trigger_disj(T, G).
 164
 165
 166%!  check_disj(DisjVar, Disj, Goal)
 167%
 168%   If there is a disjunctive condition, we share a variable between
 169%   the disjunctions. If the  goal  is  fired   due  to  one  of the
 170%   conditions, the shared variable is boud   to (-). Note that this
 171%   implies that the attributed  variable  is   left  in  place. The
 172%   predicate  when_goal//1  skips  such   goals    on   behalfe  of
 173%   copy_term/3.
 174
 175check_disj(Disj,_,Goal) :-
 176    (   Disj == (-)
 177    ->  true
 178    ;   Disj = (-),
 179        call(Goal)
 180    ).
 181
 182suspend_list([],_Goal).
 183suspend_list([V=W|Unifier],Goal) :-
 184    '$suspend'(V, when, Goal),
 185    (   var(W)
 186    ->  '$suspend'(W, when, Goal)
 187    ;   true
 188    ),
 189    suspend_list(Unifier,Goal).
 190
 191attr_unify_hook(call(Goal), Other) :-
 192    (   get_attr(Other, when, call(GOTher))
 193    ->  del_attr(Other, when),
 194        Goal, GOTher
 195    ;   Goal
 196    ).
 197
 198
 199%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 200attribute_goals(V) -->
 201    { get_attr(V, when, Attr) },
 202    when_goals(Attr).
 203
 204when_goals(det(trigger_determined(X, Y, G))) -->
 205    !,
 206    (   { disj_goal(G, Disj, DG) }
 207    ->  disj_or(Disj, DG)
 208    ;   { G = when:trigger(C, Goal) }
 209    ->  [ when((?=(X,Y),C), Goal) ]
 210    ;   [ when(?=(X,Y), G) ]
 211    ).
 212when_goals(call(Conj)) -->
 213    when_conj_goals(Conj).
 214
 215when_conj_goals((A,B)) -->
 216    !,
 217    when_conj_goals(A),
 218    when_conj_goals(B).
 219when_conj_goals(when:G) -->
 220    when_goal(G).
 221
 222when_goal(trigger_nonvar(X, G)) -->
 223    (   { disj_goal(G, Disj, DG) }
 224    ->  disj_or(Disj, DG)
 225    ;   { G = when:trigger(C, Goal) }
 226    ->  [ when((nonvar(X),C), Goal) ]
 227    ;   [ when(nonvar(X),G) ]
 228    ).
 229when_goal(trigger_ground(X, G)) -->
 230    (   { disj_goal(G, Disj, DG) }
 231    ->  disj_or(Disj, DG)
 232    ;   { G = when:trigger(C, Goal) }
 233    ->  [ when((ground(X),C), Goal) ]
 234    ;   [ when(ground(X),G) ]
 235    ).
 236when_goal(wake_det(_)) -->
 237    [].
 238
 239disj_goal(when:check_disj(X, _, _), [], -) :- X == (-).
 240disj_goal(when:check_disj(-, Or, DG), Or, DG).
 241
 242disj_or([], _) --> [].
 243disj_or(List, DG) -->
 244    { or_list(List, Or) },
 245    [when(Or, DG)].
 246
 247or_list([H], H) :- !.
 248or_list([H|T], (H;OT)) :-
 249    or_list(T, OT).
 250
 251:- multifile sandbox:safe_meta_predicate/1.
 252
 253sandbox:safe_meta_predicate(when:when/2).