%% --------------------------------------------------------------------
%% Program for untupling
%% run under SICStus 3.5 and upper.
%% By: Cohavit Taboch
%% Last updated: Feb 9 2000
%% --------------------------------------------------------------------
/*

The program performs the untupling transformation of a given
logic program.
It works in two modes:

* Untupling by answer patterns - which corresponds to the `untupling +
  specialization' transformation described in the paper.
  This transformation ensures the preservation of answer patterns.

  The predicates to use in this case are:

  %% untuple(File).
  %% untuple(InFile,OutFile).

* Untupling by call patterns - which is very similar to the simple
  untupling transformation described in the paper. However, in this case
  the untupled predicates are not detected from the program text, but
  by a call pattern analysis (which improves precision).
  This transformation ensures the preservation of both call and answer
  patterns, wrt a given initial (concrete) call pattern.

  The predicates to use in this case are:

  untuple_by_call(File,Call).
  untuple_by_call(File,OutFile,Call).

%% --------------------------------------------------------------------

The general description of the transformation (in both modes)
is the following:

1. Perform a `pattern' analysis. In the first mode we detect the most
   general (concrete) answers that can be generated. In the second mode
   we detect the most general call patterns.
   The result of the analysis is a set of `pattern' atoms (at most one
   atom for each predicate) which are used to transform the program.
   They are printed by the analyser under the title: `Most general
   patterns'.

2. Using the patterns obtained in phase 1, the program clauses are
   transformed to a set of untupled clauses and `entry points'.

%% --------------------------------------------------------------------
Comments:

* Currently the program supports a limited set of builtin predicates.
  Additional built in predicates can be added by the users (by using
  built_in/2 predicate).
* The analyser tests for undefined predicates.
  You can change this behavior by choosing a different option for the
  predicate undefined_predicates/1.
  For example, selecting undefined_predicates(ignore) will affect the
  results of the analysis in the following way:

  p :- a,b,c,d. (1)
  a.            (2)
  b.            (3)
  d.            (4)

  in the above program c is undefined.
  Therefore, if you are untupling by answer patterns, you will
  have no untupled clause for (1) because it cannot suceed.
  If you untuple by call patterns (and an initial call 'p'),
  then you will not have any untupled clause for (4) since
  'd' is never called.

* Currently the analyser does not support meta control predicates, such as
  disjunction, if-then, if-then-else.

* For each untupled predicate p/n, the new predicate name is
  p_UUn. Name conflicts can occur if the original program has predicates
  of this form.
*/
%% --------------------------------------------------------------------

:- use_module(library(charsio), [format_to_chars/3]).
:- use_module(library(lists), [append/3, member/2]).
:- use_module(library(terms), [term_subsumer/3, subsumes_chk/2]).

%% --------------------------------------------------------------------

:- dynamic(flag/0).
:- dynamic(fact/1).
:- dynamic(query/1).
:- dynamic(user_clause/2).
:- dynamic(all_clauses/1).
:- dynamic(map_pred/2).

%% --------------------------------------------------------------------
%% Uncomment the option that should be applied for undefined predicates.

%% This option raises an error if an undefined predicate is used
undefined_predicates(check).

%% This option ignores undefined predicates. Evaluating clauses which
%% contain them will fail.
%% undefined_predicates(ignore).

%% This option asserts each undefined predicate as a 'flat' fact so that
%% evaluating all caluses with undefined predicates will succeed.
%% undefined_predicates(assert).

%% --------------------------------------------------------------------
%% untuple(File) - read a prolog file and perform untupling which
%% preserves answer patterns.

untuple(File) :-
    clean, input_file(File), iterate_facts,
    format("/*~n",[]), show_patterns, format("*/~n",[]),
    format("~n%% Untupled Program ~w~n~n",[File]),
    display_transformed_program(fact).

untuple(InFile,OutFile) :-
    clean, input_file(InFile), iterate_facts,
    tell(OutFile),
    format("/*~n",[]), show_patterns, format("*/~n",[]),
    format("~n%% Untupled Program ~w~n~n",[InFile]),
    display_transformed_program(fact),
    told.

%% --------------------------------------------------------------------
%% untuple_by_call(File,Call) - read a prolog file and perform untupling
%% which preserves callpatterns (with respect to a given intial call).

untuple_by_call(File, Call) :-
    clean, input_file(File), iterate_facts, iterate_calls(Call),
    numbervars(Call,0,_),
    format("/* ~n",[]), show_patterns, format("*/ ~n",[]),
    format("~n%% Untupled Program ~w (by initial call ~w)~n~n",[File,Call]),
    display_transformed_program(query).

untuple_by_call(File, OutFile, Call) :-
    clean, input_file(File), iterate_facts, iterate_calls(Call),
    numbervars(Call,0,_),
    tell(OutFile),
    format("/* ~n",[]), show_patterns, format("*/ ~n",[]),
    format("~n%% Untupled Program ~w (by initial call ~w)~n~n",[File,Call]),
    display_transformed_program(query),
    told.

%% --------------------------------------------------------------------
%% Display the most general pattern atoms as detected by the analysis

show_patterns :-
    format("~nMost general patterns:~n",[]),
    listing(fact), nl, listing(query).

%% --------------------------------------------------------------------
%% Remove all dynamic predicates used by the analysis

clean :-
    retractall(user_clause(_,_)),
    retractall(fact(_)),
    retractall(query(_)),
    retractall(flag),
    retractall(all_clauses(_)),
    retractall(map_pred(_,_)).

%% --------------------------------------------------------------------
%% interpreter for computing call patterns.

iterate_calls(Call) :- cond_assert(query,Call), iterate_calls.

iterate_calls :- tp_calls, fail. 
iterate_calls :- retract(flag), iterate_calls.
iterate_calls.

tp_calls :-
    query(Head),
    user_clause(Head, Body),
    solve_calls(Body).

solve_calls([]).
solve_calls([B|Bs]) :-
    (
        built_in(B,C) ->
        call(C) ;
        (cond_assert(query,B), fact(B))
    ),
    solve_calls(Bs).

%% --------------------------------------------------------------------
%% interpreter for computing answer patterns.

iterate_facts :- tp, fail. 
iterate_facts :- retract(flag), iterate_facts.
iterate_facts.

tp :- 
    user_clause(Head, Body),
    solve(Body),
    cond_assert(fact,Head).

solve([]).
solve([B|Bs]) :- 
    (built_in(B,C) -> call(C) ; fact(B)), solve(Bs).

%% --------------------------------------------------------------------
%% conditional assertion to the database. Asserts the most specific
%% generalization of the current atom and a previous atom from the
%% database. Obj can be 'fact' or 'query' and F is the atom.

cond_assert(Obj,F) :-
    functor(F,N,A), functor(F1,N,A),
    FF1 =.. [Obj,F1],
    FF1,!,
    term_subsumer(F1,F,GF),
    (
        subsumes_chk(F1,GF) -> 
        true ; 
        retract(FF1),
        FGF =.. [Obj,GF],
        assert(FGF),
        raise_flag
    ).

cond_assert(Obj, F) :- FF =.. [Obj,F], assert(FF), raise_flag.

raise_flag :- flag, !.
raise_flag :- assert(flag).

%% --------------------------------------------------------------------
%% perform the transformation. First display all the original clauses
%% and the new (untupled) ones.
%% In the second stage it writes all the "entry points" of the form
%% OldPred :- NewPred.
%% ObjType is either 'fact' or 'query' indicating in which mode the
%% transformation is made.

display_transformed_program(ObjType) :-
    all_clauses(Clauses),
    untuple_clauses(Clauses,ObjType),
    entrypoints(ObjType).


%% --------------------------------------------------------------------
%% Display all transformed clauses.

untuple_clauses([],_).
untuple_clauses([C|Cs], Obj) :-
    untuple_clause(C,Obj),!, untuple_clauses(Cs,Obj).

%% --------------------------------------------------------------------
%% transform one clause, display both the original and the new clause
%% and generate an entry point if the head of the clause was transformed.

untuple_clause(clause((H:-B),Vs),Obj) :-
    (
        Obj = fact ->
        untuple_clause1((H,B,Vs),(OldH,OldB,OldVs),(H1,B1,Vs1)) ;
        untuple_clause2((H,B,Vs),(OldH,OldB,OldVs),(H1,B1,Vs1))
    ),
    format("/*~n",[]),
    format_clause((OldH:-OldB),OldVs), format(" ==> ~n*/~n",[]),
    format_clause((H1:-B1),Vs1), nl, nl.

% failed to untuple clause
untuple_clause(clause((H:-B),Vs),_Obj) :-
    format("/*~n",[]),
    format_clause((H:-B),Vs), format(" ==> ~n*/~n",[]),
    format("%% No untupled clause ~n~n", []).

%% Display original goals in the program (module declarations, prolog flags
%% etc.) as they are.
untuple_clause(clause((:-B),Vs),_Obj) :-
    format_clause((:-B),Vs).

%% --------------------------------------------------------------------
%% Mode 1: untuplng by answer patterns
%% --------------------------------------------------------------------

%% In this mode we untuple all the atoms in the clause (both head and
%% body atoms). This can be done since we expect that if the clause
%% is relevant, then all body atoms have computed answer patterns, and
%% therfore also the head atom has a computed answer pattern.

untuple_clause1((H,B,Vs),(OldH,OldB,OldVs),(H1,B1,Vs)) :-
    copy_term((H,B,Vs),(OldH,OldB,OldVs)),
    untuple_atoms1([H|B],[H1|B1]),!.

%% --------------------------------------------------------------------
%% untuple a list of atoms in the following way.
%% untuple_atom1(A,FA,NA): A is the original atom, FA is the most general
%% answer pattern for this predicate and NA is the new atom with the
%% distinct variables from FA as arguments. After all patterns from the
%% database are obtained, they are unified with the original atoms and
%% applying the substitution on each NA results in the new atom.

untuple_atoms1(As,NAs) :-
    untuple_atoms1(As,FAs,NAs), As = FAs.

untuple_atoms1([],[],[]).
untuple_atoms1([A|As],[FA|FAs],[NA|NAs]) :-
    untuple_atom1(A,FA,NA), untuple_atoms1(As,FAs,NAs).

%% In case this is a builtin - no transformation is needed.
untuple_atom1(A,A,A) :- built_in(A,_),!.
% In case there is a pattern in db
untuple_atom1(A,FA,NA) :-
    functor(A,Pred,Arity),
    functor(FA,Pred,Arity),
    fact(FA),!,
    (flat_atom(FA) -> NewPred = Pred ; get_new_pred_name(A, NewPred)),
    term_vars(FA,NArgsA),
    NA =.. [NewPred|NArgsA].
%% If we untuple by facts and there is no success pattern - fails.

%% --------------------------------------------------------------------
%% Mode 2: untuplng by call patterns
%% --------------------------------------------------------------------

%% In this mode we untuple only the head atom. The body atoms should not
%% be untupled, because this may affect call patterns. Calls from 'old'
%% body atoms to clauses with untupled head atoms, are made throught the
%% entry point clauses.

untuple_clause2((H,B,Vs),(OldH,OldB,OldVs),(H1,B1,Vs)) :-
    copy_term((H,B,Vs),(OldH,OldB,OldVs)),
    untuple_atom2(H,H1),
    B1 = B.

% In case that a call pattern exists...
untuple_atom2(A,NA) :-
    functor(A,Pred,Arity),
    functor(FA,Pred,Arity),
    query(FA),!,
    (flat_atom(FA)-> NewPred = Pred ; get_new_pred_name(FA,NewPred)),
    term_vars(FA,NArgsA),
    NA =.. [NewPred|NArgsA],
    A = FA.

%% --------------------------------------------------------------------
%% Entry points
%% --------------------------------------------------------------------

entrypoints(Obj) :-
    findall(EP, entrypoint(Obj,EP),EntryPoints), 
    (EntryPoints = [] -> true ;
        (format("~n%% Entry Points:~n~n",[]),
         format_entrypoints(EntryPoints)
     )).

entrypoint(Obj,EP) :-
    FF =.. [Obj,PatF],
    FF,
    (
        flat_atom(PatF) -> fail ;
        (
            get_new_pred_name(PatF, NewPred),
            term_vars(PatF,NewArgs),
            NewF =.. [NewPred|NewArgs],
            EP = clause((PatF :- [NewF]),[])
        )
    ).

%% --------------------------------------------------------------------
%% Display all entry points which lead from old to new predicates.

format_entrypoints([]).
format_entrypoints([clause(C,V)|Cs]) :-
    format_clause(C,V), nl,
    format_entrypoints(Cs).

%% --------------------------------------------------------------------
%% succeeds if the atom argument is a set of distinct variables

flat_atom(FA) :-
    FA =.. [_|Args],
    term_vars(Args,Vars),!,
    Args == Vars.

%% --------------------------------------------------------------------
%% Generate a new name for an untupled predicate

get_new_pred_name(Atom, NewPredName) :-
    functor(Atom, Pred, _Arity),
    map_pred(Pred, NewPredName),!.

get_new_pred_name(Atom, NewPredName) :-
    functor(Atom, Pred, Arity),
    concat_atoms(Pred, '_UU', Temp),
    concat_atoms(Temp, Arity, NewPredName),
    assert(map_pred(Pred, NewPredName)).

%% --------------------------------------------------------------------

concat_atoms(A1,A2,A12) :-
    name(A1,SA1), name(A2,SA2),
    append(SA1,SA2,SA12), name(A12,SA12).

%% --------------------------------------------------------------------
%% check that all predicates in all clauses are defined in the program
%% or built ins.

check_undefined_preds :-
    findall(user_clause(A,B), user_clause(A,B), L),
    check_undefined_preds(L).

check_undefined_preds([]).
check_undefined_preds([user_clause(_,B)|Cs]) :-
    check_atoms(B),
    check_undefined_preds(Cs).

check_atoms([]).
check_atoms([A|As]) :-
    functor(A,Name,Arity), functor(A1,Name,Arity),
    user_clause(A1,_),!,
    check_atoms(As).
check_atoms([A|As]) :-
    built_in(A,_),!,
    check_atoms(As).

check_atoms([_|As]) :-
    undefined_predicates(ignore),!,
    check_atoms(As).
check_atoms([A|As]) :-
    undefined_predicates(assert),!,
    functor(A,Name,Arity), functor(A1,Name,Arity),
    cond_assert(fact,A1),
    check_atoms(As).
%% All other cases are handeled as for undefined_predicates(check)
check_atoms([A|_]) :-
    functor(A,Name,Arity),
    format_to_chars("undefined predicate ~w/~w", [Name,Arity], Chars),
    name(Exception, Chars),
    raise_exception(Exception).

%% --------------------------------------------------------------------
%% read all clauses from a file and assert as
%% user_clause(Head, [B1,...,Bn]). Also save all clauses with original
%% variable names in all_clauses/1.

input_file(File) :-
    open(File,read,Stream),
    all_clauses(Stream, AllClauses),
    check_undefined_preds,
    assert(all_clauses(AllClauses)),
    close(Stream).

all_clauses(Stream, Clauses) :-
    read_term(Stream,T, [variable_names(Ns), singletons(Ss)]),
    append(Ns,Ss,Vs),
    (T == end_of_file -> Clauses = [] ;
     remember(T,T1), Clauses = [clause(T1,Vs)|Cs], all_clauses(Stream,Cs)).

remember((H :- B), (H :- B1)) :-
    !, body2list(B,B1), assert(user_clause(H,B1)).
remember((:- op(A,B,C)),(:- [op(A,B,C)])) :- !, op(A,B,C).
remember((:- B), (:- B1)) :- body2list(B,B1), !.
remember(H, (H :- [])) :- assert(user_clause(H,[])).

body2list(B,[call(B)]) :- var(B), !.
body2list((B,Bs),[call(B)|Bs1]) :- var(B),!, body2list(Bs,Bs1).
body2list((B,Bs),[B|Bs1]) :- !, body2list(Bs,Bs1).
body2list(B,[B]).

%% --------------------------------------------------------------------
%% display a clause with all possible original variable names.

format_clause(C,Vs) :-
    assign_varnames(Vs),
    term_vars(C,Vars),
    assign_varnames1(Vars,Vs,0),
    format_clause(C).

assign_varnames([]).
assign_varnames([NVar = Var|Vs]) :- NVar = Var,!, assign_varnames(Vs).
assign_varnames([_|Vs]) :- assign_varnames(Vs).

assign_varnames1([],_,_).
assign_varnames1([V|Vs],Vars,Num) :-
    concat_atoms('XX', Num, NewV),
    \+ member(_ = NewV,Vars),!,
    V = NewV,
    Num1 is Num+1,
    assign_varnames1(Vs,Vars,Num1).
assign_varnames1([V|Vs],Vars,Num) :-
    Num1 is Num+1,
    assign_varnames1([V|Vs],Vars,Num1).
    
format_clause((H :- [])) :- !,format("~w.", [H]).
format_clause((H :- B)) :- !,format("~w :-~n", [H]), format_body(B).
format_clause((:- B)) :- !, format(":- ", []), format_body1(B).

format_body([B]) :- !, format("    ~w.~n",[B]).
format_body([B|Bs]) :- format("    ~w,~n",[B]), format_body(Bs).

format_body1([B]) :- !, format("~w.~n",[B]).
format_body1([B|Bs]) :- format("~w,~n",[B]), format_body1(Bs).


%% --------------------------------------------------------------------
%% get all variables in a term.

term_vars(T,V) :- term_vars(T,[],V).

term_vars(V,VIn,VOut) :- var(V),!, add_var(V,VIn,VOut).
term_vars(A,VIn,VIn) :- atom(A),!.
term_vars(T,VIn,VOut) :- T =.. [_|Args], term_vars_list(Args,VIn,VOut).

term_vars_list([],VIn,VIn).
term_vars_list([T|Ts],VIn,VOut) :-
    term_vars(T,VIn,V1),
    term_vars_list(Ts,V1,VOut).

add_var(V,[],[V]).
add_var(V,[V1|Vs],[V1|Vs]) :- V == V1,!.
add_var(V,[V1|Vs], [V1|V2s]) :- add_var(V,Vs,V2s).

%% --------------------------------------------------------------------
%% This is a representative set of Prolog built in predicates, which can
%% be extended easily.
%% builtin(A,B) - A is a flat atom constructed with the builtin predicate
%% and B is the goal to be executed if the predicate can be evaluated
%% bottom-up. This can be done only in rare cases, such as in
%% equations. In all other cases we have B=true.
%% --------------------------------------------------------------------

built_in(@<(_,_),true).
built_in(@>(_,_),true).
built_in(@=<(_,_),true).
built_in(@>=(_,_),true).
built_in(<(_,_),true).
built_in(>(_,_),true).
built_in(=<(_,_),true).
built_in(>=(_,_),true).
built_in(=(A,B),(A=B)).
built_in(=..(_,_),true).
built_in(=:=(_,_),true).
built_in(==(_,_),true).
built_in(=\=(_,_),true).
built_in(\==(_,_),true).
built_in(\+(_),true).
built_in(+(_,_),true).
built_in(-(_,_),true).
built_in(/(_,_),true).
built_in(*(_,_),true).
built_in(abort,true).
built_in(abolish(_),true).
built_in(arg(_,_,_),true).
built_in(assert(X),cond_assert(fact,X)).
built_in(asserta(X),cond_assert(fact,X)).
built_in(atom(_),true).
built_in(atomic(_),true).
built_in(compare(_,_,_),true).
built_in(compound(_),true).
built_in(display(_),true).
built_in(erase(_),true).
built_in(fail, fail).
built_in(false,true).
built_in(format(_,_),true).
built_in(format(_,_,_),true).
built_in(functor(_,_,_),true).
built_in(get0(_),true).
built_in(ground(_),true).
built_in(integer(_),true).
built_in(keysort(_,_),true).
built_in(is(_,_),true).
built_in(name(_,_),true).
built_in(nl,true).
built_in(nonvar(_),true).
built_in(not(_),true).
built_in(number(_),true).
built_in(numbervars(_,_,_),true).
built_in(print(_),true).
built_in(put(_),true).
built_in(read(_),true).
built_in(recorda(_,_,_),true).
built_in(recorded(_,_,_),true).
built_in(repeat,true).
built_in(retract(_),true).
built_in(sort(_,_),true).
built_in(statistics(_,_),true).
built_in(tab(_),true).
built_in(true,true).
built_in(ttynl,true).
built_in(ttyput(_),true).
built_in(var(_),true).
built_in(write(_),true).
built_in(!,true).
built_in(call(_),true).
built_in(listing(_),true).
built_in(retractall(_),true).
built_in(tell(_),true).
built_in(told,true).
built_in(close(_),true).
built_in(open(_,_,_),true).
built_in(read_term(_,_,_),true).
built_in(op(_,_,_),true).

%% --------------------------------------------------------------------
