
?- op(700, xfx, ->).

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

% Dimensional Mapping
% -------------------

% Glossary of symbols...
%
% V    = variable
% F    = function
% X    = index
% T    = template
% I, J = variable or template dimension
%
% D, E           = (daughter) node---complicated syntax!
% R, S           = map range---ran(T, Is)
% K, L, M, N     = mappings---[] | [X -> I | K]
% RSynth, Ssynth = map-range-synthesised flag---yes | no
%
% Q    = ``quality'' of pass.  Currently integer.  The larger the value,
%        the weaker the heuristics are being applied in this pass.
 
% Phase I
% -------
%    Decorate tree with home maps.  Instantiate domains at each node.
% This is a post-order traversal.

dimMapDomain(var(V, Ds), var(V, Es, map(_, M)), _, N) :-
    dimMapDomainDaughters(Ds, Es, _, M),
    domain(M, Xs),
    domain(N, Xs).
dimMapDomain(fun(F, Xs, Ds),
             fun(F, Xs, Es, map(R, L), map(R, N)), _, K) :-
    dimMapDomainDaughters(Ds, Es, R, L),
    domain(M, Xs),
    union(L, M, N),
    domain(N, J),
    domain(K, J).
dimMapDomain(arr(Xs, D), arr(Xs, E, map(R, N)), R, K) :-
    dimMapDomain(D, E, _, L),
    domain(M, Xs),
    union(L, M, N),
    subtract(L, M, K).
dimMapDomain(idx(X), idx(X), _, M) :-
    domain(M, [X]).
    
dimMapDomainDaughters([], [], _, []).
dimMapDomainDaughters([D | Ds], [E | Es], R, N) :-
    dimMapDomain(D, E, R, L),
    dimMapDomainDaughters(Ds, Es, R, M),
    union(L, M, N).

domain([], []).
domain([X -> _ | M], [X | Xs]) :- domain(M, Xs).

% Phase II
% --------
%      Attempt to synthesise dimension maps.  If a node map can't be
% synthesised from daughter maps it is unified with the target map
% (``inheritted'').  Note that any mappings not instantiated at the end
% of the traversal are unified with the mapping in the `arr' node scoping
% the index involved.

dimMapSynthesis(Q, var(V, Ds, map(R, M)), SSynth, S, N) :-
    localMap(Q, V, Ds, R, M, SSynth, S, N),
    dimMapSynthesisDaughters(Q, Ds, _, R, M).
dimMapSynthesis(Q, var(_, Ds, map(R, M)), SSynth, S, N) :-
    dimMapSynthesisDaughters(Q, Ds, RSynth, R, M),
    synthOrInheritMap(Q, RSynth, R, M, SSynth, S, N).
dimMapSynthesis(Q, fun(_, _, Ds, map(R, M), map(R, N)), SSynth, S, L) :-
    dimMapSynthesisDaughters(Q, Ds, RSynth, R, M),
    synthOrInheritMap(Q, RSynth, R, N, SSynth, S, L).
dimMapSynthesis(Q, arr(_, D, map(R, M)), RSynth, _, _) :-
    dimMapSynthesis(Q, D, RSynth, R, M).
dimMapSynthesis(_, idx(_), no, _, _).

dimMapSynthesisDaughters(_, [], no, _, _).
dimMapSynthesisDaughters(Q, [D | Ds], RSynth, R, M) :-
    dimMapSynthesis(Q, D, RSynthD, R, M),
    dimMapSynthesisDaughters(Q, Ds, RSynthDs, R, M),
    or(RSynthD, RSynthDs, RSynth).

or( no,  no,  no).
or( no, yes, yes).
or(yes,  no, yes).
or(yes, yes, yes).


localMap(Q, V, Ds, ran(T, Is), N, Usynth, S, K) :-  % Local reference mapping.
    alignment(V, ran(T, Is), M),
    domain(N, Xs),
    domain(L, Xs),
    mapIdxSubscripts(1, Ds, L),
    compose(M, L, N),
    mapDims(Q, Is, N),
    parentMap(ran(T, Is), N, Usynth, S, K).

mapIdxSubscripts(_, [], _).
mapIdxSubscripts(I, [D | Ds], M) :-
    mapIdxSubscript(I, D, M),
    J is I + 1, mapIdxSubscripts(J, Ds, M).

mapIdxSubscript(I, idx(X), M) :- member(X -> I, M).
mapIdxSubscript(_, _, _).

compose(_, [], []).
compose(L, [X -> Y | M], [X -> Z | N]) :-
    ground(Y), !,
    member(Y -> Z, L),
    compose(L, M, N).
compose(L, [X -> _ | M], [X -> _ | N]) :- compose(L, M, N).


synthOrInheritMap(_, no, R, M, no, R, N) :-               % Inherited mapping.
    subset(M, N).
synthOrInheritMap(Q, yes, ran(T, Is), M, Usynth, S, N) :- % Synthesised mapping.
    mapDims(Q, Is, M),
    parentMap(ran(T, Is), M, Usynth, S, N).


parentMap(R, M, yes, R, N) :-       % Try to propagate synthesized mapping up.
    subset(M, N).
parentMap(_, _, no, _, _).          % Else leave daughter/node maps un-unified.


mapDims(_, _, []).
mapDims(Q, Is, [_ -> I | M]) :-      % Align to array dimension
    member(I, Is),
    remove(I, Is, Js),
    mapDims(Q, Js, M).
mapDims(Q, Is, [_ -> ? | M]) :-      % Collapse Q or fewer indices
    Q > 0,
    Q1 is Q - 1,
    mapDims(Q1, Is, M).


% Phase III
% ---------
%      Complete instantiation of mappings at `arr' nodes.  This is a
% pre-order traversal.  It assumes that `Usynth' returned by the previous
% pass was `yes' at the root, so all target templates are instantiated.

dimMapArr(Q, var(_, Ds, _), _)                 :- dimMapArrDaughters(Q, Ds, _).
dimMapArr(Q, fun(_, _, Ds, map(_, M), _), _)   :- dimMapArrDaughters(Q, Ds, M).
dimMapArr(Q, arr(_, D, map(ran(_, Is), M)), N) :-
    union(N, M, L),
    mapDims(Q, Is, L),
    dimMapArr(Q, D, M).
dimMapArr(_, idx(_), _).

dimMapArrDaughters(_, [], _).
dimMapArrDaughters(Q, [D | Ds], M) :-
    dimMapArr(Q, D, M),
    dimMapArrDaughters(Q, Ds, M).

% %-----------------------------------------------------------------
% 
% % Embedding
% % ---------
% 
% % Phase I
% % -------
% %   Decorate tree with ``embedding'' records, and unify node embeddings
% % with parent embeddings of node daughters.
% 
% embedDecorate(fun(F, I, D, map(ran(V, R), M), map(ran(W, S), N)),
%               fun(F, I, E, embedding(DomM, target(V, HomeSubs)), 
%                            embedding(DomM, target(W, TargSubs))),
%               W, MapPar, ParSubs) :-
%     domain(M, DomHome),
%     homeSubscripts(R, M, HomeSubs),
%     embedDecorateDaughters(D, E, V, M, HomeSubs),
%     targetSubcripts(1, DomHome, DomPar, ParSubs, TargSubs).
% 
% homeSubscripts([], _, []).
% homeSubscripts([I | R], M, [S | L]) :-
%     homeSubscripts(I, M, S),
%     homeSubscripts(R, M, L).
% 
% homeSubscript(I, M, map(X)) :-
%     member (X -> I, M),
%     !.
% homeSubscript(_, _, _).
% 
% targetSubscripts([], _, _, [], []).
% targetSubscripts([I | R], DomHome, MapPar, [S | L], [T | M]) :-
%     targetSubscript(I, DomHome, MapPar, S, T),
%     targetSubscripts(R, DomHome, MapPar, L, M).
%   
% targetSubscript(I, DomHome, MapPar, map(X), _) :-
%     member(X -> I, MapPar),
%     member(X, DomHome),
%     !.
% targetSubscript(I, DomHome, MapPar, rep, _) :-
%     member(X -> I, MapPar),
%     !.
% targetSubscript(_, _, _, S, S).

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

% Miscellaneous ``set'' operations.

union([], X, X).
union([X | R], Y, Z) :- member(X, Y), !, union(R, Y, Z). 
union([X | R], Y, [X | Z]) :- union(R, Y, Z).

subtract(M, [], M).
subtract(M, [X | I], N) :- remove(X, M, P), subtract(P, I, N).

member(X, [X | _]).
member(X, [_ | Y]) :- member(X, Y).

notMember(_, []).
notMember(X, [X | _]) :- !, fail.
notMember(X, [_ | L]) :- notMember(X, L).

remove(_, [], []).
remove(X, [X | L], L)       :- !.
remove(X, [Y | L], [Y | M]) :- remove(X, L, M).

subset([], _).
subset([X | M], N) :- member(X, N), !, subset(M, N).

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

% Allow successively more ``undefined'' (presumably collapsed)
% dimension-mappings, until success.

alignMap(P) :- alignMapping(0, P).
%alignMap(P) :- alignMapping(1, P).

alignMapping(Q, P) :-
    dimMapSynthesis(Q, P, yes, _, _),
    dimMapArr(Q, P, _).
alignMapping(Q, P) :-
    R is Q + 1,
    alignMapping(R, P).

% Run the whole mapping procedure, reading the program from a file.

run(Tree, Alignments, Q) :-
    [Alignments],
    !,
    go(Tree, Q).
run(_, Alignments, _) :- printString("Failed to load file "), write(Alignments).

go(Tree, Q) :-
    see(Tree),
    getNode(P),
    !,
    seen,
    nl,
    dimMapDomain(P, Q, _, _),
    alignMap(Q),
    nl,
    printAssocs(0, Q).
go(Tree, _) :- printString("Failed to parse file "), write(Tree), seen.

