1:- module(tor,
    2	[(tor)/2
    3	,op(1100,xfy,tor)
    4	,op(1150,fx,tor)
    5	,search/1
    6	,tor_handlers/3
    7	,tor_before_handlers/3
    8        ,tor_merge/2
    9        ,dbs_tree/1
   10        ,dbs/2
   11        ,dibs_tree/1
   12        ,dibs/2
   13        ,id/1
   14        ,nbs/2
   15        ,nbs_tree/1
   16        ,bab/2
   17        ,lds/1
   18        ,dbs/3
   19        ,iterate/1
   20	,tor_statistics/1
   21	,solution_count/2
   22	,node_count/2
   23	,failure_count/2
   24        ,log/1
   25        ,parallel/1
   26	]).

Tor infrastructure and many handlers.

This module contains the basic Tor infrastructure for hookable disjunction as well as the definition of the search strategies.

*/

   35:- use_module(library(apply)).  
   36:- use_module(library(lists)).  
   37:- use_module(library(terms)).  
   38:- use_module(library(mutable_variables)).   39:- use_module(library(clpfd)).   40:- use_module(library(unix)).   41
   42%-------------------------------------------------------------------------------
   43% Tor hookable disjunction
   44%-------------------------------------------------------------------------------
   45
   46:- meta_predicate tor(0,0).
 tor(+G1, +G2)
Hookable disjunction. This operator should be used instead of normal disjunction.
   52G1 tor G2 :-
   53       ( b_getval(left,Left),
   54         call(Left,G1)
   55       ; b_getval(right,Right),
   56         call(Right,G2)
   57       ).
   58
   59%-------------------------------------------------------------------------------
   60% Infrastructure
   61%-------------------------------------------------------------------------------
   62
   63:- meta_predicate search(0).   64
   65:- initialization nb_setval(left,call), nb_setval(right, call).
 search(+Goal)
New search scope: sets up the default handler for both hooks, that is, call/1. With this default handler, tor/2 corresponds to plain disjunction.
   72search(Goal) :-
   73  b_getval(left,OldLeft),
   74  b_getval(right,OldRight),
   75  b_setval(left,call),
   76  b_setval(right,call),
   77  call(Goal),
   78  b_setval(left,OldLeft),
   79  b_setval(right,OldRight).
   80
   81:- meta_predicate tor_handlers(0,1,1).
 tor_handlers(+Goal, +Left, +Right)
Around advice. This predicate composes the currently installed handlers with the new ones provided. Then, it runs the provided goal and finally, it resets the installed handlers.
   88tor_handlers(Goal,Left,Right) :-
   89  b_getval(left,LeftHandler),
   90  b_getval(right,RightHandler),
   91  b_setval(left,compose(LeftHandler,Left)),
   92  b_setval(right,compose(RightHandler,Right)),
   93  call(Goal),
   94  b_setval(left,LeftHandler),
   95  b_setval(right,RightHandler).
   96
   97
   98:- meta_predicate compose(1,1,0).   99
  100% Conceptually: G1(G2(Goal))
  101compose(G1,G2,Goal) :- call(G1,call(G2,Goal)).
  102
  103:- meta_predicate tor_before_handlers(0,0,0).  104
  105% tor_before_handlers(+Goal, +Left, +Right)
  106%
  107% Before advice: in case the handler only needs to precede the actual branch
  108% goal by its own goal.
  109tor_before_handlers(Goal,Left,Right) :-
  110  tor_handlers(Goal,before(Left),before(Right)).
  111
  112:- meta_predicate before(0,0).  113
  114before(G1,G2) :- G1, G2.
  115
  116% :- meta_predicate tor_merge(0,0).
 tor_merge(+Heuristic, +Goal)
Extracts left and right handler definitions from the source code of a high-level search heuristic definition and invokes tor_handlers.
  122tor_merge(Heuristic,Goal) :-
  123  % For a correct translation, we need to have a head that only contains free variables
  124  construct_template(Heuristic,FreeHead),
  125  clause(FreeHead,Body),
  126  % Do translation
  127  % BVarPos is a list of positions at which we need we need a mutable variable
  128  translate(FreeHead,Body, HandlerLeft, HandlerRight, HandlerLeftHeadVars, HandlerRightHeadVars, BVarPos),
  129  % Assert handlers
  130  assert_handler(HandlerLeftHeadVars, HandlerLeft, LeftSym),
  131  assert_handler(HandlerRightHeadVars, HandlerRight, RightSym),
  132  % Create and initialize mutable variables
  133  maplist(create_bvar(Heuristic),BVarPos,MutableVariables),
  134  install_handlers(Heuristic, MutableVariables, BVarPos, LeftSym, RightSym, InstallLeft, InstallRight),
  135  tor_handlers(Goal,InstallLeft,InstallRight).
  136
  137% Asserts handler under a unique name
  138% Mode: + + -
  139assert_handler(HandlerHeadVars, HandlerBody, Sym) :-
  140  gensym('handler',Sym),
  141  Head =.. [Sym|HandlerHeadVars],
  142  assert((Head :- HandlerBody)).
  143
  144% Gets argument at given position in head and initializes a new mutable variable with it.
  145% Designed to be used with maplist/3
  146create_bvar(Head,Pos,MutableVariable) :-
  147  Head =.. [_|ArgList],
  148  nth0(Pos,ArgList,Value),
  149  new_bvar(Value,MutableVariable).
  150
  151% Installs both handlers
  152% Mode: + + + + + - -
  153install_handlers(Heuristic, MutableVariables, BVarPos, LeftSym, RightSym, InstallLeft, InstallRight) :-
  154  % Construct the list of arguments for the handler terms that we are going to install
  155  % Do this by merging mutable variables and normal variables. Handlers must only be partially applied. Tor_handlers does the rest.
  156  Heuristic =.. [_|AllArgs],
  157  merge_by_pos(AllArgs,MutableVariables,BVarPos,InstallArgs),
  158  InstallLeft =.. [LeftSym|InstallArgs],
  159  InstallRight =.. [RightSym|InstallArgs].
  160
  161% Creates ListOut by taking the elements of List1, except for the positions mentioned in PosList, where the first element of List2 is used that has not been used so far.
  162% Counting starts from zero.
  163% Much more efficient to use this instead of merge_by_pos(List1, List2, PosList, ListOut, []).
  164merge_by_pos(List1,List2,PosList,ListOut) :-
  165  merge_by_pos_(List1,List2,PosList,0,ListOut).
  166
  167merge_by_pos_([],_List2,_PosList,_Pos,[]).
  168merge_by_pos_([X|Xs],[],_PosList,_Pos,[X|Xs]).
  169merge_by_pos_([X|Xs],[Y|Ys],PosList,Pos,[Z|Zs]) :-
  170  Pos1 is Pos + 1,
  171  ( memberchk(Pos,PosList) ->
  172    Z = Y,
  173    merge_by_pos_(Xs,Ys,PosList,Pos1,Zs)
  174  ; Z = X,
  175    merge_by_pos_(Xs,[Y|Ys],PosList,Pos1,Zs)
  176  ).
  177
  178% Creates a difference list by taking the elements of List1, except for the positions mentioned in PosList, where the first element of List2 is used that has not been used so far.
  179% Mode: + + + - -
  180% Counting starts from zero.
  181% Should only be used if TailOut is not [] (for efficiency).
  182merge_by_pos(List1,List2,PosList,ListOut,TailOut) :-
  183  merge_by_pos_(List1,List2,PosList,0,ListOut,TailOut).
  184
  185merge_by_pos_([],_List2,_PosList,_Pos,X,X).
  186% Extra case for efficiency: don't bother about updating pos - it still is not terribly efficient since we can only add a single element at a time.
  187merge_by_pos_([X|Xs],[],_PosList,_Pos,[X|HO],TO) :- !,
  188    merge_by_pos_(Xs,[],dummy,dummy,HO,TO).
  189merge_by_pos_([X|Xs],[Y|Ys],PosList,Pos,[Z|HO],TO) :-
  190  Pos1 is Pos + 1,
  191  ( memberchk(Pos,PosList) ->
  192    Z = Y,
  193    merge_by_pos_(Xs,Ys,PosList,Pos1,HO,TO)
  194  ; Z = X,
  195    merge_by_pos_(Xs,[Y|Ys],PosList,Pos1,HO,TO)
  196  ).
  197
  198% Derives left and right handler definitions from a high-level heuristic definition.
  199% This process involves:
  200% - splitting into left and right handler by finding tor operator
  201% - replacing regular parameters with mutable variables
  202% - adding b_get and b_put for those variables
  203% - eliminating explicit recursive calls 
  204translate(Head, Body, HandlerLeft, HandlerRight,HandlerLeftHeadVars,HandlerRightHeadVars, DiffPos) :-
  205  split_handlers(Body, Left, Right),
  206  % Find out what to b_get: that is, we need to look at all the recursive calls and if a parameter changes between the head and the recursive call, we need to use a mutable variable and a b_get.
  207  % First find all recursive calls
  208  functor(Head,HeadName,HeadArity),
  209  find_goals(HeadName, HeadArity, Body, RecursiveCalls),
  210  % For each recursive call: check in which argument positions head and call have different variables.
  211  maplist(differentVariablePosList(Head),RecursiveCalls,ListListDiffPos),
  212  foldl(union,ListListDiffPos,[],DiffPos),
  213  % Translate left and right handler seperately.
  214  translate_handler(Head, Left, DiffPos, HandlerLeft, HandlerLeftHeadVars),
  215  translate_handler(Head, Right, DiffPos, HandlerRight, HandlerRightHeadVars).
  216
  217% Returns a list of positions in which different variables were found
  218differentVariablePosList(Head1,Head2, DifferentPos) :-
  219  Head1 =.. [_|Args1],
  220  Head2 =.. [_|Args2],
  221  differentVariablePosList_(Args1,Args2,0,DifferentPos-[]).
  222
  223differentVariablePosList_([],[],_,X-X).
  224differentVariablePosList_([X|Xs], [Y|Ys], Nr, List-Tail) :-
  225  ( X \== Y ->
  226     List = [Nr|Tail1]
  227  ;
  228    Tail1 = List
  229  ),
  230  Pos1 is Nr + 1,
  231  differentVariablePosList_(Xs, Ys, Pos1, Tail1-Tail).
  232
  233% Construct template: a predicate with the same name and arity, but containing only free variables
  234construct_template(Predicate,Template) :-
  235  functor(Predicate, Name, Arity),
  236  functor(Template, Name, Arity).
  237
  238% Does translation for a single handler
  239% Parameters:
  240% - Head
  241% - Body: handler code to transform (does not contain tor disjunctions anymore)
  242% - MutableVarsPositions: list of positions, starting from zero, that indicate which head variables need to become mutable variables.
  243translate_handler(Head, Body, MutableVarsPositions, Handler, HandlerHeadVars) :-
  244  % Construct template for recursive call and replace it by a free variable in Body, resulting in Body2.
  245  construct_template(Head,TemplateRecursive),
  246  replace_goal(TemplateRecursive, Body,Free,Body2),  
  247  % Generalized adding of b_get here:
  248  % Make a conjunction of b_gets, and one of b_puts
  249  % Use a pair for the first argument, since maplist/6 is not defined anymore, but maplist/5 is
  250  Head =.. [_|Args],
  251  TemplateRecursive =.. [_|Args2],
  252  maplist(make_bgetput_arg_pos(Args-Args2),MutableVarsPositions,MutableVars,BGetList,BPutList),
  253  list_to_conj(BGetList,BGetConj),
  254  list_to_conj(BPutList,BPutConj),
  255  % Add b_gets and b_puts to handlers.
  256  % list_to_conj gives true in case of empty list, avoid to insert these
  257  empty_different(BGetList,Handler,(BGetConj,Body2),Body2),
  258  empty_different(BPutList,Free,(BPutConj,call(Goal)),call(Goal)),
  259  % Now create the head variables for the handler by combining free variables that must become mutable variables and regular arguments.
  260  merge_by_pos(Args,MutableVars,MutableVarsPositions,HandlerHeadVars, [Goal]). % We should be able to use argument from recursive call instead and get the same result.
  261
  262% Binds Variable to Nonempty if List is non-empty, else binds Variable to Empty.
  263empty_different(List,Variable,Nonempty,Empty) :-
  264  (List = [] ->
  265    Variable = Empty
  266  ;
  267    Variable = Nonempty
  268  ).
  269
  270% For use with maplist/5
  271% Gets argument nr. Position from Args and Args2
  272% Intented "results": MutableVariable, b_get(MutableVariable,Argument) and b_put(MutableVariable,Argument2).
  273make_bgetput_arg_pos(Args-Args2,Position,MutableVariable,b_get(MutableVariable,Arg),b_put(MutableVariable,Arg2)) :-
  274  nth0(Position,Args,Arg),
  275  nth0(Position,Args2,Arg2).
  276
  277find_goals(PredicateName, Arity, Term, ResultList) :-
  278  find_goals_(PredicateName, Arity, Term, ResultList-[]).
  279
  280% Does term contain conjunction, disjunction or tor disjunction?
  281% If yes, Arg1 and Arg2 are both operands, and Operator is the operator.
  282has_selected_binary_operator(Term, Operator, Arg1, Arg2) :-
  283  Term =.. [Operator,Arg1, Arg2],
  284  memberchk(Operator,[',', ';', 'tor']).
  285
  286% Does term contain conjunction, disjunction?
  287% If yes, Arg1 and Arg2 are both operands, and Operator is the operator.
  288has_selected_binary_operator2(Term, Operator, Arg1, Arg2) :-
  289  Term =.. [Operator,Arg1, Arg2],
  290  memberchk(Operator,[',', ';']).
  291
  292% Does not look in test - needs to be tested before disjunction
  293find_goals_(PredicateName, Arity, (_Test -> Term1 ; Term2), List-Tail) :- !,
  294  find_goals_(PredicateName, Arity, Term1, List-Tail1),
  295  find_goals_(PredicateName, Arity, Term2, Tail1-Tail).
  296find_goals_(PredicateName, Arity, Term, List-Tail) :-
  297  has_selected_binary_operator(Term, _Operator, Term1, Term2), !, % Mind the place of the cut
  298  find_goals_(PredicateName, Arity, Term1, List-Tail1),
  299  find_goals_(PredicateName, Arity, Term2, Tail1-Tail).
  300find_goals_(PredicateName, Arity, Term, List-Tail) :- !,
  301  functor(Template,PredicateName, Arity),
  302  ( (nonvar(Term), Term = Template) ->
  303     % Add to difflist
  304     List = [Template|Tail]
  305     ;
  306     List = Tail
  307  ).
  308
  309% In a term that is
  310% - a conjunction of subterms
  311% - a disjunction of subterms
  312% - an if containing two subterms (test not investigated further),
  313% replace goal that matches given template by free variable
  314% Must be before disjunction
  315replace_goal(Template,(Test -> Term1 ; Term2),Free, (Test -> Result1 ; Result2)) :- !,
  316  replace_goal(Template,Term1,Free,Result1),
  317  replace_goal(Template,Term2,Free,Result2).
  318replace_goal(Template,Term,Free,Result) :- 
  319  has_selected_binary_operator(Term,Operator,Term1,Term2), !, % Mind the place of the cut
  320  replace_goal(Template,Term1,Free,Result1),
  321  replace_goal(Template,Term2,Free,Result2),
  322  Result =.. [Operator,Result1,Result2].
  323replace_goal(Template,Term,Free,Result) :-
  324  ((nonvar(Term), Template = Term) ->
  325    % Found match!
  326    Result = Free
  327  ;
  328    Result = Term
  329  ).
  330
  331% Must be before disjunction
  332split_handlers((Term1,Term2),(Result1,Result2),(Result3,Result4)) :- !,
  333  split_handlers(Term1,Result1,Result3),
  334  split_handlers(Term2,Result2,Result4).
  335split_handlers((Test -> Term1 ; Term2), (Test -> Result1 ; Result2), (Test -> Result3 ; Result4)) :- !,
  336  split_handlers(Term1,Result1,Result3),
  337  split_handlers(Term2,Result2,Result4).
  338split_handlers((Term1;Term2),(Result1;Result2),(Result3;Result4)) :- !,
  339  split_handlers(Term1,Result1,Result3),
  340  split_handlers(Term2,Result2,Result4).
  341split_handlers(Term,Result,Result2) :-
  342  ((nonvar(Term), tor(X,Y) = Term) ->
  343    % Found match!
  344    Result = X,
  345    Result2 = Y
  346  ;
  347    Result = Term,
  348    Result2 = Term
  349  ).
  350
  351
  352% Converts a list of conjuncts to a conjunction.
  353list_to_conj([],true) :- ! .
  354list_to_conj([X],X) :- ! .
  355list_to_conj([X1,X2],(X1,X2)) :- ! .
  356list_to_conj([X|Xs],(X,Ys)) :-
  357  list_to_conj(Xs,Ys).
  358
  359%-------------------------------------------------------------------------------
  360% Search Methods listed in the paper
  361%-------------------------------------------------------------------------------
 dbs_tree(+Depth)
Depth bounded search tree. Use with tor_merge.
  366dbs_tree(D) :-
  367  D > 0, ND is D - 1,
  368  (dbs_tree(ND) tor dbs_tree(ND)).
 dbs(+Depth, +Goal)
Depth bounded search.
  373dbs(Depth, Goal) :-
  374  tor_merge(dbs_tree(Depth),Goal).
 dibs_tree(+Discrepancies)
Discrepancy-bounded search tree. Use with tor_merge. Uses prune instead of fail so it can be used to define lds in terms of it.
  380dibs_tree(D) :-
  381  (
  382    ( D > 0, dibs_tree(D)
  383    tor
  384      D > 0, ND is D - 1, dibs_tree(ND)
  385    )
  386  ;
  387    prune
  388  ).
 dibs(+Discrepancies, +Goal)
Discrepancy-bounded search
  393dibs(Discrepancies, Goal) :-
  394  tor_merge(dibs_tree(Discrepancies),Goal).
 id(Goal)
Iterative deepening.
  399id(Goal) :-
  400  new_nbvar(not_pruned,PVar),
  401  id_loop(Goal,0,PVar).
  402
  403id_loop(Goal,Depth,PVar) :-
  404  nb_put(PVar,not_pruned),
  405  ( tor_merge(id_tree(Depth,PVar),Goal)
  406  ;
  407    nb_get(PVar,Value),
  408    Value == pruned,
  409    NDepth is Depth + 1,
  410    id_loop(Goal,NDepth,PVar)
  411  ).
  412
  413id_tree(Depth,PruneVar) :-
  414  ( Depth > 0 ->
  415    NDepth is Depth - 1
  416  ;
  417    nb_put(PruneVar,pruned), false
  418  ),
  419  ( id_tree(NDepth, PruneVar)
  420  tor
  421    id_tree(NDepth, PruneVar)
  422  ).
 nbs(+NumberOfNodes, +Goal)
Node-bounded search
  427nbs(Nodes,Goal) :-
  428  new_nbvar(Nodes,NodesVar),
  429  catch(
  430    tor_merge(nbs_tree(NodesVar),Goal),
  431    out_of_nodes(NodesVar),
  432    fail
  433  ).
 nbs_tree(+NodesVar)
Node-bounded search tree. Use with tor_merge. Throws out_of_nodes exception.
  439nbs_tree(Var) :-
  440  nb_get(Var,N),
  441  ( N > 0 ->
  442    N1 is N - 1, nb_put(Var, N1), (nbs_tree(Var) tor nbs_tree(Var))
  443  ;
  444    throw(out_of_nodes(Var))
  445  ).
 bab(+Objective, +Goal)
Branch-and-bound
  450bab(Objective,Goal) :-
  451  fd_inf(Objective,Inf),
  452  LowerBound is Inf - 1,
  453  new_nbvar(LowerBound,BestVar),
  454  Current = inf,
  455  tor_merge(bab_tree(Objective,BestVar,Current),Goal),
  456  nb_put(BestVar,Objective).
  457
  458bab_tree(Objective, BestVar, Current) :-
  459  nb_get(BestVar, Best),
  460  ( Best \= inf, (Current == inf ; Best > Current ) ->
  461    Objective #> Best,
  462    NCurrent = Best
  463  ;
  464    NCurrent = Current
  465  ),
  466  ( bab_tree(Objective, BestVar, NCurrent)
  467  tor
  468    bab_tree(Objective, BestVar, NCurrent)
  469  ).
  470
  471:- meta_predicate lds(0).
 lds(+Goal)
Limited discrepancy search
  476lds(Goal) :-
  477  iterate(flip(dibs,Goal)).
  478
  479% Level is a number, so should not be module sensitive.
  480% The Method is called with the Goal as extra argument, so meta argument specifier must a 1.
  481:- meta_predicate dbs(+,1,0).
 dbs(+Level, +Method, +Goal)
Variant on depth-bounded search. When the depth bound is reached, it does not prune the remaining subtree, but activates the search method Method.
  487dbs(Level, Method, Goal) :-
  488  new_bvar(yes(Level),Var),
  489  tor_handlers(Goal,dbs_handler(Var,Method)
  490                   ,dbs_handler(Var,Method)).
  491
  492dbs_handler(Var,Method,Goal) :-
  493  b_get(Var,MDepth),
  494  dbs_handler_(MDepth,Var,Method,Goal).
  495
  496dbs_handler_(yes(Depth),Var,Method,Goal) :-
  497  ( Depth > 1 ->
  498      NDepth is Depth - 1,
  499      b_put(Var,yes(NDepth)),
  500      call(Goal)
  501  ;
  502      b_put(Var,no),
  503      call(Method,Goal)
  504  ).
  505dbs_handler_(no,_,_,Goal) :-
  506  call(Goal).
  507
  508%-------------------------------------------------------------------------------
  509% Iteration patterns and pruning
  510%-------------------------------------------------------------------------------
  511
  512prune :-
  513  set_pruned(true),
  514  fail.
  515
  516reset_pruned :-
  517  set_pruned(false).
  518
  519is_pruned :-
  520  get_pruned(true).
  521
  522get_pruned(Flag) :-
  523  nb_getval(pruned,Flag). 
  524
  525set_pruned(Flag) :-
  526  nb_setval(pruned,Flag).
  527
  528scope_pruned(Goal) :-
  529  get_pruned(OldFlag),
  530  ( reset_pruned,
  531    call(Goal)
  532  ;
  533    set_pruned(OldFlag),
  534    fail
  535  ).
  536
  537pruned_union(true,_,true).
  538pruned_union(false,true,true).
  539pruned_union(false,false,false).
  540
  541:- meta_predicate iterate(0).
 iterate(+PGoal)
Factors out the common iteration part of iterative deepening and limited discrepancy search.
  547iterate(PGoal) :-
  548  scope_pruned(
  549    iterate_loop(0,PGoal)).
  550
  551:- meta_predicate iterate_loop(+,1).  552
  553iterate_loop(N,PGoal) :-
  554  ( 
  555    call(PGoal,N)
  556  ; 
  557    is_pruned,
  558    reset_pruned,
  559    M is N + 1,
  560    iterate_loop(M,PGoal) 
  561  ).
  562
  563% The third argument is a number, which is not module-sensitive.
  564% Using 0 instead of + therefore is wrong.
  565:- meta_predicate flip(0,0,+).  566
  567flip(BaseStrategy, Goal, Number) :-
  568  call(BaseStrategy,Number, Goal).
  569
  570%-------------------------------------------------------------------------------
  571% Statistics and visualisation
  572%-------------------------------------------------------------------------------
  573
  574:- meta_predicate tor_statistics(0).
 tor_statistics(+Goal)
Prints statistics about the search:
  582tor_statistics(Goal) :-
  583  new_nbvar(0,SolutionVar),
  584  new_nbvar(0,NodeVar),
  585  new_nbvar(0,FailureVar),
  586  Vars  = [SolutionVar,NodeVar,FailureVar],
  587  Names = ['solutions','nodes','failures'],
  588  ( solution_count(SolutionVar,node_count(NodeVar,failure_count(FailureVar,Goal))),
  589    maplist(nb_report,Vars,Names)
  590  ;
  591    maplist(nb_report,Vars,Names)
  592  ).
  593
  594nb_report(Var,Name) :-
  595  nb_get(Var,Value),
  596  format('% Number of ~w: ~`.t ~d~34|~n',[Name,Value]).
  597
  598:- meta_predicate solution_count(+,0).
 solution_count(+SolutionVar, +Goal)
Count solutions using provided nonbacktrackable variable
  603solution_count(SolutionVar,Goal) :-
  604  call(Goal),
  605  nb_inc(SolutionVar).
  606
  607:- meta_predicate node_count(+,0).  608
  609% node_count(+NodeVar, +Goal)
  610%
  611% Count number of nodes processed using provided nonbacktrackable variable
  612node_count(NodeVar,Goal) :-
  613  tor_before_handlers(Goal,nb_inc(NodeVar),nb_inc(NodeVar)).
  614
  615nb_inc(Var) :-
  616  nb_get(Var,Value),
  617  NValue is Value + 1,
  618  nb_put(Var,NValue).
  619
  620:- meta_predicate failure_count(+,0).  621
  622% failure_count(+FailureVar, +Goal)
  623%
  624% Count number of failures using provided nonbacktrackable variable
  625failure_count(FailureVar,Goal) :-
  626  tor_handlers(Goal,failure_handler(FailureVar),failure_handler(FailureVar)).
  627
  628failure_handler(Var,Goal) :-
  629  ( call(Goal) *->
  630      true
  631  ;
  632      nb_inc(Var),
  633      fail
  634  ).
 log(+Goal)
Emits a textual representation of the search tree. This log can be turned into a PDF image using the provided tool.
  640log(Goal) :-
  641  tor_merge(log_tree, Goal),
  642  writeln(solution).
  643
  644log_tree :-
  645  ( ( writeln(left)
  646    tor
  647      writeln(right)
  648    ),
  649    log_tree
  650  ;
  651    writeln(false),
  652    false
  653  ).
  654
  655%-------------------------------------------------------------------------------
  656% Parallel infrastructure
  657%-------------------------------------------------------------------------------
 parallel(+Goal)
Parallel search
  662parallel(Goal) :-
  663        open('num_threads', write, Stream1, [lock(exclusive)]),
  664        format(Stream1, "0.\n", []),
  665        close(Stream1),
  666        general_tor_hook(Goal, tor_fork, tor_fork).
  667
  668tor_fork(Goal) :-
  669        wait_for_slot,
  670        fork(PID),
  671        (   PID == child -> Goal
  672        ;   false
  673        ).
  674
  675wait_for_slot :-
  676        open(mylock, write, Lock, [lock(exclusive)]),
  677        repeat,
  678           catch(open('num_threads', read, Stream, []),
  679                 E,
  680                 (   writeln(E), false)),
  681           read(Stream, Num),
  682           close(Stream),
  683           integer(Num),
  684           format("num: ~w\n", [Num]),
  685           (   Num > 5 -> sleep(0.5), false
  686           ;   true
  687           ),
  688           !,
  689        Num1 is Num + 1,
  690        open('num_threads', write, Stream1, [lock(exclusive)]),
  691        format(Stream1, "~w.\n", [Num1]),
  692        close(Stream1),
  693        close(Lock).
  694
  695general_tor_hook(Goal,Left,Right) :-
  696  b_getval(left,LeftHook),
  697  b_getval(right,RightHook),
  698  b_setval(left,compose(LeftHook,Left)),
  699  b_setval(right,compose(RightHook,Right)),
  700  call(Goal),
  701  b_setval(left,LeftHook),
  702  b_setval(right,RightHook).
  703
  704%-------------------------------------------------------------------------------
  705% tor/1 declaration
  706%-------------------------------------------------------------------------------
  707% The declaration `:- tor Pred/Arity.' replaces the implicit disjunctions
  708% between the clauses of Pred/Arity by explicit calls to tor/2 disjunction.
  709%
  710%   TODO
  711%     - perform substitations to simplify the unifier
  712%     - eliminate unifications with singleton variables from the unifier
  713%
  714
  715:- multifile user:term_expansion/2.  716:- dynamic '$tor_predicate'/3.  717:- dynamic '$tor_clause'/5.  718
  719tor_expansion((:- tor F/A), File, []) :-
  720  assertz('$tor_predicate'(F,A,File)).
  721tor_expansion(Head,File,[]) :-
  722  functor(Head,F,A),
  723  '$tor_predicate'(F,A,File),
  724  assertz('$tor_clause'(F,A,File,Head,true)).
  725tor_expansion((Head :- Body),File,[]) :-
  726  functor(Head,F,A),
  727  '$tor_predicate'(F,A,File),
  728  assertz('$tor_clause'(F,A,File,Head,Body)).
  729tor_expansion(end_of_file,File,Clauses) :-
  730  findall(Clause,(retract('$tor_predicate'(F,A,File)), merge_tor_clauses(F,A,File,Clause)),Clauses).
  731
  732merge_tor_clauses(F,A,File,Head :- Body) :-
  733  findall(Term-TermBody,retract('$tor_clause'(F,A,File,Term,TermBody)),TermBodyPairs),
  734  merge_tor_head(TermBodyPairs,Head),
  735  reverse(TermBodyPairs,RTermBodyPairs),
  736  merge_tor_bodies(RTermBodyPairs,Head,Body).
  737
  738merge_tor_head([Term-_|Terms],Head) :-
  739  merge_tor_head_(Terms,Term,Head).
  740
  741merge_tor_head_([],Head,Head).
  742merge_tor_head_([Term-_|Terms],Acc,Head) :-
  743  term_subsumer(Term,Acc,NAcc),
  744  merge_tor_head_(Terms,NAcc,Head).
  745
  746merge_tor_bodies([Term-TermBody|Terms],Head,Body) :-
  747  head_matcher(Head,Term,Matcher),
  748  optimize_conjunction(Matcher,TermBody,Goal),
  749  merge_tor_bodies_(Terms,Head,Goal,Body).
  750
  751merge_tor_bodies_([],_Head,Body,Body).
  752merge_tor_bodies_([Term-TermBody|Terms],Head,Acc,Body) :-
  753  head_matcher(Head,Term,Matcher),
  754  optimize_conjunction(Matcher,TermBody,Goal),
  755  merge_tor_bodies_(Terms,Head,(Goal tor Acc),Body).
  756
  757head_matcher(Head,Term,Matcher) :-
  758  unifiable(Head,Term,Unifier),
  759  head_matcher(Unifier,Matcher).
  760
  761head_matcher([],true).
  762head_matcher([G],Body) :- !,
  763  Body = G.
  764head_matcher([G|Gs],(G,Matcher)) :-
  765  head_matcher(Gs,Matcher).
  766
  767optimize_conjunction(G1,G2,NG) :-
  768  ( G1 == true ->
  769     NG = G2
  770  ; G1 == false ->
  771     NG = false
  772  ; G2 == true ->
  773     NG = G1
  774  ;
  775     NG = (G1,G2)
  776  ).
  777
  778%-------------------------------------------------------------------------------
  779% tor/1 declaration
  780%-------------------------------------------------------------------------------
  781%
  782% Save term_expansion for the end of the file.
  783%
  784%  (thanks to Jan Wielemaker)
  785
  786user:term_expansion(TermIn, TermOut) :-
  787	\+ current_prolog_flag(xref, true),
  788	prolog_load_context(source, File),	
  789	tor_expansion(TermIn, File, TermOut)