:- op(1100, xfx, <-).

:- ensure_loaded(library(lists)).

:- dynamic acc/4.

:- multifile portray/1.

%%% portray(X) :-
%%%   portray_record(X).
%%% portray(X) :-
%%%   portray_list(X).

/***********************************************************************
*                         THE RECORD COMPILER                          *
***********************************************************************/

compile_declarations :-
  compile_definition(_).

% ----------------------------------------------------------------------
% compile_definitions/1 is used to compile a specific set of
% definitions given a list of their names.
% ----------------------------------------------------------------------

compile_definitions([]).
compile_definitions([Name | Names]) :-
  compile_definition(Name),
  compile_definitions(Names).

% ----------------------------------------------------------------------
% compile_definition(Name)
%
% Compile a definitions with a given name, or all definition if the
% argument is unbound.  The various definitions for the name are
% rehearsed with a failure-driven loop.
% ----------------------------------------------------------------------

compile_definition(Name) :-
  dcl(Name, Definition),
  retractall(acc(Name, _, _, _)),
  length(Definition, Length),
  nth(Arg0, Definition, Field),        % Compile field in position Arg0.
  functor(Form1, Name, Length),
  functor(Form2, Name, Length),
                                       % Copy other fields.
  partial_copy(Form1, Form2, Arg0, 1, Length),
  arg(Arg0, Form1, Value1),
  arg(Arg0, Form2, Value2),
  compile_items(Field, Name, Value1, Value2, Form1, Form2),
  fail.
compile_definition(_).

% ----------------------------------------------------------------------
                                       % The field has various names.
                                       % Compile accessors for all.
compile_items(Specs, Name, Value1, Value2, Form1, Form2) :-
  is_list(Specs),
  !,
  member(Spec, Specs),
  compile_item(Name, Spec, Value1, Value2, Form1, Form2).
                                       % Compile accessor for one name.
compile_items(Spec, Name, Value1, Value2, Form1, Form2) :-
  compile_item(Name, Spec, Value1, Value2, Form1, Form2).

% ----------------------------------------------------------------------
                                       % Subrecord with subfields.
compile_item(Name, (Specs <- Rec, Subfields), Value1, Value2, Form1, Form2) :-
  !,
  compile_subfields(Name, Rec, Subfields, Value1, Value2, Form1, Form2),
  compile_record_fields(Specs, Rec, Name, Value1, Value2, Form1, Form2).
                                       % Subrecord without subfields.
compile_item(Name, (Specs <- Rec), Value1, Value2, Form1, Form2) :-
  !,
  compile_record_fields(Specs, Rec, Name, Value1, Value2, Form1, Form2).
                                       % Simple accessor.
compile_item(Name, Spec, Value1, _, Form1, Form2) :-
  nv_write(acc(Name, Spec=Value1, Form1, Form2)).

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

compile_record_fields(Specs, Rec, Name, Value1, Value2, Form1, Form2):-
  is_list(Specs),
  !,
  member(Spec, Specs),
  compile_record_field(Spec, Rec, Name, Value1, Value2, Form1, Form2).
compile_record_fields(Spec, Rec, Name, Value1, Value2, Form1, Form2):-
  compile_record_field(Spec, Rec, Name, Value1, Value2, Form1, Form2).

compile_record_field(Spec, Rec, Name, Value1, _, Form1, Form2):-
  nv_write((acc(Name, Spec=Value1, Form1, Form2) :- acc(Rec, _, Value1, _))).

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

compile_subfields(Name, Rec, (Field, Fields), Value1, Value2, Form1, Form2) :-
  !,
  compile_subfield(Name, Rec, Field, Value1, Value2, Form1, Form2),
  compile_subfields(Name, Rec, Fields, Value1, Value2, Form1, Form2).
compile_subfields(Name, Rec, Field, Value1, Value2, Form1, Form2) :-
  compile_subfield(Name, Rec, Field, Value1, Value2, Form1, Form2).

compile_subfield(Name, Rec, Field=Field1, Value1, Value2, Form1, Form2) :-
  !,
  nv_write((acc(Name, Field=V, Form1, Form2) :- acc(Rec, Field1=V, Value1, Value2))).
compile_subfield(Name, Rec, Field, Value1, Value2, Form1, Form2) :-
  nv_write((acc(Name, Field=V, Form1, Form2) :- acc(Rec, Field=V, Value1, Value2))).

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

partial_copy(_, _, _, I, Length) :-
  I>Length,
  !.
partial_copy(Term1, Term2, I, I, Length) :-
  !,
  J is I+1,
  partial_copy(Term1, Term2, I, J, Length).
partial_copy(Term1, Term2, Arg, I, Length) :-
  arg(I, Term1, X),
  arg(I, Term2, X),
  J is I+1,
  partial_copy(Term1, Term2, Arg, J, Length).

% nv_write(X):-
%   numbervars(X, 0, _),
%   write(X),
%   nl,
%   fail.
nv_write(X) :-
  assert(X).

/***********************************************************************
*                         THE RECORD PRINTER                           *
***********************************************************************/

portray_record(Record) :-
  nonvar(Record),
  functor(Record, F, N),
  dcl(F, Spec),
  length(Spec, N),
  !,
  Record=..[Type | List],
  make_print_list(List, Spec, PrintList),
  line_position(user, P),
  (   P>50
   -> format("~n> ", []),
      P1=3
    ; P1=P
  ),
  (  numbervars(PrintList, 0, _),
     print_list([Type | PrintList], P1)
   ; true
  ).

portray_list(List) :-
  nonvar(List),
  strict_member(Record, List),
  nonvar(Record),
  functor(Record, F, N),
  dcl(F, Spec),
  length(Spec, N),
  !,
  show_list(1, List).

strict_member(_, List) :-
  var(List),
  !,
  fail.
strict_member(X, [X | _]).
strict_member(X, [_ | List]) :-
  strict_member(X, List).

% ----------------------------------------------------------------------
% make_print_list(ValueList, Spec, Pairs)
%
% Given corresponding lists of values and field names, return a list
% of name-value pairs.
% ----------------------------------------------------------------------

make_print_list([], [], []).
          % A a field has multiple names, use the first one.
make_print_list([V | Values], [S0 | Spec], [S-V | PrintList]) :-
  get_print_name(S0, S),
  make_print_list(Values, Spec, PrintList).

get_print_name([Spec | _], Name) :-
  !,
  get_print_name(Spec, Name).
get_print_name((Spec <- _), Name) :-
  !,
  get_print_name(Spec, Name).
get_print_name(Name, Name).

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

print_list([], _).
print_list([S-V], _) :-         % Print the final pair.
  !,
  format("~w = ", [S]),
  print_value(V).
print_list([S], _) :-           % How could this happen?
  !,
  format("~w", [S]).
print_list([S-V | List], P) :-  % Print a nonfinal pair.
  !,
  format("~w = ", [S]),
  print_value(V),
  format("~n~*|", [P]),         % reposition for next pair
  print_list(List, P).
print_list([S | List], P) :-    % How could this happen?
  format("~w~n~*|", [S, P]),
  print_list(List, P).

print_value([H | T]) :-
  !,
  show_list(1, [H | T]).
print_value(V) :-
  print(V).

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

show_list(_, []).
show_list(I, [Goal]) :-
  !,
  format("~w. ~p", [I, Goal]).
show_list(1, [Goal | Goals]) :-   % If it could be a string, display it.
  \+ ( member(C, [Goal | Goals]),
       \+ (integer(C), C<128)
     ),
  !,
  line_position(user, P),
  format("1. ~p ~s~n~*|", [Goal, [Goal | Goals], P]),
  show_list(2, Goals).
show_list(I, [Goal | Goals]) :-
  line_position(user, P),
  format("~w. ~p~n~*|", [I, Goal, P]),
  J is I +1,
  show_list(J, Goals).

/***********************************************************************
*                         THE RECORD TRANSLATOR                        *
***********************************************************************/

translate_goals((Goal, Goals), NewGoals):-
  translate_goal(Goal, NewGoal),
  call(NewGoal),
  !,
  translate_goals(Goals, NewGoals).
translate_goals((Goal, Goals), (Goal, NewGoals)):-
  !,
  translate_goals(Goals, NewGoals).
translate_goals(Goal, true) :-
  translate_goal(Goal, NewGoal),
  call(NewGoal),
  !.
translate_goals(Goal, Goal).

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

translate_goal((Records <- Assignments), (R0=Record0, R=Record)) :-
  nonvar(Records),
  Records=(Record0, Record),
  !,
  make_records(Assignments, R0, R).
translate_goal((Record <- Assignments), (R=Record)) :-
  !,
  make_records(Assignments, R, _).

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

make_records(Assignments, Record0, Record) :-
  nonvar(Assignments),
  Assignments=(Name, Assignments0),
  !,
  make_records(Name, Assignments0, Record0, Record0, Record).
make_records(Name, Record, Record) :-
  access(Name, _, Record, Record).

make_records(Name, (Assignment, Assignments), Record0, Record1, Record) :-
  access(Name, Assignment, Record1, Record2),
  access(Name, Assignment, Record0, _),
  !,
  make_records(Name, Assignments, Record0, Record2, Record).
make_records(Name, Assignment, Record0, Record1, Record) :-
  access(Name, Assignment, Record1, Record),
  access(Name, Assignment, Record0, _).

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

access(RecordType, Field, R, R) :-
  var(Field),
  !,
  acc(RecordType, Field, R, R).
access(_, Field=_, R, R) :-
  var(Field),
  !,
  fail.
access(RecordType, Field, R0, R) :-
  acc(RecordType, Field, R0, R),
  !.
access(RecordType, +Field, R0, R) :-
  acc(RecordType, Field=1, R0, R),
  !.
access(RecordType, -Field, R0, R) :-
  acc(RecordType, Field=0, R0, R),
  !.
access(RecordType, Field, _, _):-
  format("Record definition ~w fails: ~w~n", [RecordType, Field]),
  prolog_load_context(file, F),
  prolog_load_context(term_position, '$stream_position'(_,_,_,P, _)),
  format("  before line ~w in ~w~n", [P, F]),
  fail.
      
% ----------------------------------------------------------------------

(A <- Goals) :-
  translate_goal((A <- Goals), NewGoals),
  call(NewGoals).

term_expansion((Head :- Goals0), (Head :- Goals)) :-
  translate_goals(Goals0, Goals).