1/*  Part of Extended Tools for SWI-Prolog
    2
    3    Author:        Edison Mera Menendez
    4    E-mail:        efmera@gmail.com
    5    WWW:           https://github.com/edisonm/xtools
    6    Copyright (C): 2015, Process Design Center, Breda, The Netherlands.
    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(argument_chains,
   36          [gen_argument_chains/2,
   37           argument_chain/2,
   38           unlinked_arg/4,
   39           arg_id/6,
   40           lead_to_root/1,
   41           linked_arg/2]).   42
   43:- use_module(library(codewalk)).   44
   45:- dynamic
   46    clause_db/1,
   47    unlinked_arg/4,
   48    linked_arg/2,
   49    arg_id/6,
   50    counter/1.   51
   52counter(1).
   53
   54count(Curr) :-
   55    retract(counter(Curr)),
   56    succ(Curr, Next),
   57    assertz(counter(Next)).
   58
   59gen_argument_chains(AIL, Options1) :-
   60    retractall(clause_db(_)),
   61    retractall(arg_id(_, _, _, _, _, _)),
   62    retractall(linked_arg(_, _)),
   63    retractall(unlinked_arg(_, _, _, _)),
   64    forall(member(AI, AIL),
   65           record_linked(AI, 0 )),
   66    merge_options(Options1, [source(false)], Options),
   67    check_argument_fixpoint(0, Options).
   68
   69record_linked(IM:F/A-Pos, Stage) :-
   70    functor(H, F, A),
   71    record_linked(H, IM, _, Pos, Stage, 0).
   72
   73check_argument_fixpoint(Stage, Options) :-
   74    succ(Stage, NStage),
   75    findall(P, ( arg_id(H, M, Idx, Pos, Stage, _),
   76                 functor(H, F, A),
   77                 ( nonvar(Idx)
   78                 ->P = M:F/A-Idx/Pos
   79                 ; P = M:F/A-Pos
   80                 )
   81               ), L),
   82    length(L, N),
   83    print_message(information, format("Stage ~w: Checking ~w argument positions", [NStage, N])),
   84    walk_code([source(false), on_trace(propagate_argument_1(Stage, NStage))|Options]),
   85    print_message(information, format("Stage ~w: Collecting unlinked arguments", [NStage])),
   86    findall(Clause, retract(clause_db(Clause)), ClauseU),
   87    sort(ClauseU, ClauseL),
   88    walk_code([source(false),
   89               clauses(ClauseL),
   90               on_trace(propagate_argument_2(Stage, NStage))|Options]),
   91    ( \+ arg_id(_, _, _, _, NStage, _)
   92    ->true
   93    ; check_argument_fixpoint(NStage, Options)
   94    ).
   95
   96:- public propagate_argument_1/5.   97
   98propagate_argument_1(Stage, NStage, MGoal, MCaller, From) :-
   99    propagate_argument(argument_cond_1(Id), record_callee_1(Id), Stage, NStage, MGoal, MCaller, From).
  100
  101argument_cond_1(Id, Goal, M, Pos, Stage, _, _) :-
  102    arg_id(Goal, M, _, Pos, Stage, Id),
  103    \+ ( arg_id(Goal, M, _, Pos, PStage, _),
  104         PStage < Stage
  105       ).
  106
  107record_callee_1(Id, _, _, _, Ref, Id) :- assertz(clause_db(Ref)).
  108
  109:- public propagate_argument_2/5.  110
  111propagate_argument_2(Stage, NStage, MGoal, MCaller, From) :-
  112    propagate_argument(argument_cond_2, record_callee_2, Stage, NStage, MGoal, MCaller, From).
  113
  114argument_cond_2(Goal, M, Pos, _, NStage, CM:H-Idx/CPos) :-
  115    \+ arg_id(Goal, M, _, Pos, _, _),
  116    arg_id(H, CM, Idx, CPos, NStage, _).
  117
  118record_callee_2(Goal, M, Pos, _, Id) :-
  119    functor(Goal, F, A),
  120    functor(H,    F, A),
  121    record_unlinked(H, M, Pos, Id).
  122
  123record_unlinked(H, M, Pos, Id) :-
  124    ( unlinked_arg(H, M, Pos, Id)
  125    ->true
  126    ; count(Id),
  127      assertz(unlinked_arg(H, M, Pos, Id))
  128    ).
  129
  130record_linked(H, M, Idx, Pos, Stage, Id) :-
  131    ( arg_id(H, M, Idx, Pos, _, Ref)
  132    ->true
  133    ; ( retract(unlinked_arg(H, M, Pos, Ref))
  134      ->true
  135      ; count(Ref)
  136      ),
  137      assertz(arg_id(H, M, Idx, Pos, Stage, Ref))
  138    ),
  139    ( linked_arg(Id, Ref)
  140    ->true
  141    ; assertz(linked_arg(Id, Ref))
  142    ).
  143
  144:- meta_predicate propagate_argument(6,5,?,?,?,?,?).  145propagate_argument(GoalCondition, RecordCallee, Stage, NStage, MGoal, MCaller, From) :-
  146    MGoal = _:Goal,
  147    compound(Goal),
  148    predicate_property(MGoal, implementation_module(IM)),
  149    MCaller = CM:Caller,
  150    compound(Caller),
  151    functor(Caller, F, A),
  152    functor(H, F, A),
  153    From = clause(CRef),
  154    nth_clause(_, Idx, CRef),
  155    arg(Pos, Goal, Arg),
  156    \+ ( nonvar(Arg),
  157         predicate_property(MGoal, meta_predicate(Meta)),
  158         arg(Pos, Meta, 0 )
  159       ),
  160    call(GoalCondition, Goal, IM, Pos, Stage, NStage, CM:H-Idx/CPos),
  161    arg(CPos, Caller, CArg),
  162    \+ ( arg_id(H, CM, Idx, CPos, PStage, _),
  163         PStage < NStage
  164       ),
  165    ( term_variables(CArg, CVL),
  166      term_variables(Arg, VL),
  167      member(C, CVL),
  168      member(V, VL),
  169      C==V
  170    ->call(RecordCallee, Goal, IM, Pos, CRef, Id),
  171      record_linked(H, CM, Idx, CPos, NStage, Id)
  172    ),
  173    fail.
  174
  175argument_chain(M:F/A-Idx/Pos, Chain) :-
  176    functor(H, F, A),
  177    arg_id(H, M, Idx, Pos, _, Id),
  178    argument_chain_rec(Id, Chain).
  179
  180argument_chain_rec(Id, [M:F/A-Idx/Pos|Chain]) :-
  181    arg_id(H, M, Idx, Pos, _, Id), !,
  182    functor(H, F, A),
  183    linked_arg(Ref, Id),
  184    argument_chain_rec(Ref, Chain).
  185argument_chain_rec(_, []).
  186
  187lead_to_root(Chain) :-
  188    lead_to_root([], Chain).
  189
  190lead_to_root(Chain1, Chain) :-
  191    linked_arg(0, Id),
  192    lead_to_root(Id, Chain1, Chain).
  193
  194lead_to_root(Id, Chain, [Id|Chain]).
  195lead_to_root(Id, Chain1, Chain) :-
  196    linked_arg(Id, Id2),
  197    \+ memberchk(Id2, [Id|Chain1 ]),
  198    lead_to_root(Id2, [Id|Chain1 ], Chain)