/**
 * Warranty & Liability
 * To the extent permitted by applicable law and unless explicitly
 * otherwise agreed upon, XLOG Technologies AG makes no warranties
 * regarding the provided information. XLOG Technologies AG assumes
 * no liability that any problems might be solved with the information
 * provided by XLOG Technologies AG.
 *
 * Rights & License
 * All industrial property rights regarding the information - copyright
 * and patent rights in particular - are the sole property of XLOG
 * Technologies AG. If the company was not the originator of some
 * excerpts, XLOG Technologies AG has at least obtained the right to
 * reproduce, change and translate the information.
 *
 * Reproduction is restricted to the whole unaltered document. Reproduction
 * of the information is only allowed for non-commercial uses. Selling,
 * giving away or letting of the execution of the library is prohibited.
 * The library can be distributed as part of your applications and libraries
 * for execution provided this comment remains unchanged.
 *
 * Restrictions
 * Only to be distributed with programs that add significant and primary
 * functionality to the library. Not to be distributed with additional
 * software intended to replace any components of the library.
 *
 * Trademarks
 * Jekejeke is a registered trademark of XLOG Technologies AG.
 */

:- ensure_loaded(library(text/charsio)).

/**
 * tab(N):
 * tab(S, N):
 * The predicate succeeds. As a side effect N spaces are
 * written to the current output. The binary predicate allows
 * specifying the output stream.
 */
% tab(+Integer)
tab(N) :-
   current_output(S),
   sys_tab(N, ' ', S).

% tab(+Steam, +Integer)
tab(S, N) :-
   sys_tab(N, ' ', S).

% sys_tab(+Integer, +Atom, +Stream)
sys_tab(N, A, S) :- N > 0, !,
   put_atom(S, A),
   M is N-1,
   sys_tab(M, A, S).
sys_tab(_, _, _).

/*********************************************************/
/* Format Output                                         */
/*********************************************************/

/**
 * format_atom(T, L, A):
 * The build-in succeeds in writing the list L formatted
 * according to the template T into a new atom A.
 */
% format_atom(+Atom, +List, -Atom)
format_atom(T, L, A) :-
   open_output_atom_stream(K),
   format(K, T, L),
   close_output_atom_stream(K, A).

/**
 * format(T, L):
 * format(S, T, L):
 * The built-in succeeds in writing the list L formatted
 * according to the template T to the standard output. The
 * ternary predicate allows specifying an output stream S.
 */
% format(+Atom, +List)
format(T, L) :-
   current_output(S),
   format(S, T, L).

% format(+Stream, +Atom, +List)
format(S, T, L) :-
   atom_codes(T, C),
   sys_descriptor_specs(D, C, []),
   sys_punch(D, S, L, []), !.
format(_, _, _) :-
   throw(error(syntax_error(aguments_mismatch),_)).

% sys_punch(+List, +Stream, +List, -List)
sys_punch([], _) --> [].
sys_punch([rubber(C)|L], S) --> !,
   {ir_object_current(S, 'flags', F)},
   sys_descriptor_elems([rubber(C)|L], P, Q, F),
   {sys_punch_scatter(P, Q, S)},
   sys_punch(Q, S).
sys_punch([X|L], S) -->
   sys_punch_spec(X, S),
   sys_punch(L, S).

% sys_punch_scatter(+List, +List, +Stream)
sys_punch_scatter(P, [column(N)|_], S) :- !,
   foldl(sys_punch_delta, P, 0, D),
   ir_object_current(S, 'offset', X),
   Y is (N-X)-D,
   length(P, K),
   foldl(sys_punch_spaced(Y,K,S), P, 0, _).
sys_punch_scatter(_, _, _) :-
   throw(error(syntax_error(column_missing),_)).

% sys_punch_delta(+Pair, +Integer, -Integer)
sys_punch_delta(tag(T)-_, N, M) :-
   tag_length(T, L),
   M is N+L.
sys_punch_delta(write(T)-_, N, M) :-
   atom_length(T, L),
   M is N+L.

% sys_punch_spaced(+Integer, +Integer, +Stream, +Pair, +Integer, -Integer)
sys_punch_spaced(Y, K, S, tag(T)-C, M, M2) :-
   H is M+Y,
   divmod(H, K, J, M2),
   sys_tab(J, C, S),
   tag(S, T).
sys_punch_spaced(Y, K, S, write(T)-C, M, M2) :-
   H is M+Y,
   divmod(H, K, J, M2),
   sys_tab(J, C, S),
   write(S, T).

/*******************************************************************/
/* Output Specs                                                     */
/*******************************************************************/

% sys_punch_specs(+Term, +Stream, +List, -List)
sys_punch_specs([], _) --> [].
sys_punch_specs([X|L], S) -->
   sys_punch_spec(X, S),
   sys_punch_specs(L, S).

% sys_punch_spec(+Term, +Stream, +List, -List)
sys_punch_spec(fill(A), S) --> !,
   {put_atom(S, A)}.
sys_punch_spec(tilde, S) --> !,
   {put_atom(S, '~')}.
sys_punch_spec(newline, S) --> !,
   {nl(S)}.
sys_punch_spec(column(N), S) --> !,
   {ir_object_current(S, 'offset', X), Y is N-X, tab(S, Y)}.
sys_punch_spec(escape, S) --> [X], !,
   {xml_escape(X, A), put_atom(S, A)}.
sys_punch_spec(percent, S) --> [X], !,
   {percent_encode(X, A), put_atom(S, A)}.
sys_punch_spec(number, S) --> [X], !,
   {H is X, sys_print_unquote(S, H)}.
sys_punch_spec(float(P,N), S) --> [X], !,
   {H is X, sys_number_unquote(H, P, N, A), sys_print_unquote(S, A)}.
sys_punch_spec(canon, S) --> [X], !,
   {write_canonical(S, X)}.
sys_punch_spec(quote, S) --> [X], !,
   {sys_print_quote(S, X)}.
sys_punch_spec(radix(P,N), S) --> [X], !,
   {H is X, sys_integer_unquote(H, P, N, A), write(S, A)}.
sys_punch_spec(write, S) --> [X], !,
   {write(S, X)}.
sys_punch_spec(_, _) -->
   {throw(error(syntax_error(aguments_mismatch),_))}.

% sys_number_unquote(+Number, +Atom, +Integer, -Atomic)
sys_number_unquote(H, T, N, A) :- float(H), !,
   sys_number_atom(H, T, N, A).
sys_number_unquote(H, T, N, A) :- integer(H), !,
   sys_number_atom(H, T, N, A).
sys_number_unquote(H, _, _, H).

% sys_integer_unquote(+Number, +Atom, +Integer, -Atomic)
sys_integer_unquote(H, T, N, A) :- integer(H), !,
   sys_integer_atom(H, T, N, A).
sys_integer_unquote(H, _, _, H).

% sys_print_quote(+Stream, +Term)
sys_print_quote(Stream, Term) :-
   ir_object_current(Stream, 'flags', F), F /\ 12 =\= 0, !,
   display_term(Stream, Term, [numbervars(true), quoted(true)]).
sys_print_quote(Stream, Term) :-
   writeq(Stream, Term).

% sys_print_unquote(+Stream, +Atom)
sys_print_unquote(Stream, Term) :-
   ir_object_current(Stream, 'flags', F), F /\ 12 =\= 0, !,
   display_term(Stream, Term, [numbervars(true)]).
sys_print_unquote(Stream, Term) :-
   write(Stream, Term).

/*******************************************************************/
/* Parse Groups                                                    */
/*******************************************************************/

% sys_descriptor_elems(+List, -List, -List, +Integer, +List, -List)
sys_descriptor_elems([rubber(C)|L], [Y-C|P], Q, F) --> !,
   {sys_descriptor_elem(L, X, R)},
   sys_punch_markup(X, Y, F),
   sys_descriptor_elems(R, P, Q, F).
sys_descriptor_elems(L, [], L, _) --> [].

% sys_descriptor_elem(+List, -List, -List)
sys_descriptor_elem(L, [X|P], Q) :-
   sys_descriptor_item(L, X, R), !,
   sys_descriptor_elem(R, P, Q).
sys_descriptor_elem(L, [], L).

% sys_descriptor_item(+List, -Term, -List)
sys_descriptor_item([rubber(_)|_], _, _) :- !, fail.
sys_descriptor_item([column(_)|_], _, _) :- !, fail.
sys_descriptor_item([X|L], X, L).

% sys_punch_markup(+List, -Atom, +Integer, +List, -List)
sys_punch_markup(D, tag(A), M) --> {M /\ 12 =\= 0}, !,
   {open_output_atom_stream(K),
   dom_output_new(K, J),
   ir_object_current(J, 'flags', F),
   G is (F /\ \ 12) \/ M,
   ir_object_set(J, 'flags', G)},
   sys_punch_specs(D, J),
   {flush_output(J),
   close_output_atom_stream(K, A)}.
sys_punch_markup(D, write(A), _) -->
   {open_output_atom_stream(K)},
   sys_punch_specs(D, K),
   {close_output_atom_stream(K, A)}.

/*******************************************************************/
/* Parse Specs                                                     */
/*******************************************************************/

% sys_descriptor_specs(-List, +List, -List)
sys_descriptor_specs([X|R]) --> "~", !,
   sys_descriptor_char(C),
   sys_descriptor_spec(C, X),
   sys_descriptor_specs(R).
sys_descriptor_specs([fill(A)|R]) --> [X], !,
   sys_descriptor_fill(F),
   {atom_codes(A, [X|F])},
   sys_descriptor_specs(R).
sys_descriptor_specs([]) --> [].

% sys_descriptor_char(-Integer, +List, -List)
sys_descriptor_char(C) --> [C], !.
sys_descriptor_char(_) -->
   {throw(error(syntax_error(format_missing),_))}.

% sys_descriptor_fill(-List, +List, -List)
sys_descriptor_fill([X|F]) --> [X], {X \== 0'~}, !,
   sys_descriptor_fill(F).
sys_descriptor_fill([]) --> [].

% sys_descriptor_spec(+Integer, -Term, +List, -List)
sys_descriptor_spec(C, R) --> {0'0 =< C, C =< 0'9}, !,
   {N is C-0'0},
   sys_descriptor_char(D),
   sys_descriptor_number(D, N, R).
sys_descriptor_spec(0'`, R) --> !,
   sys_descriptor_char(N),
   sys_descriptor_char(D),
   sys_descriptor_alpha(D, N, R).
sys_descriptor_spec(0'~, tilde) --> !.
sys_descriptor_spec(0'n, newline) --> !.
sys_descriptor_spec(0't, rubber(' ')) --> !.
sys_descriptor_spec(0'|, column(0)) --> !.
sys_descriptor_spec(0'a, escape) --> !.
sys_descriptor_spec(0'c, percent) --> !.
sys_descriptor_spec(0'd, number) --> !.
sys_descriptor_spec(0'e, float('e',6)) --> !.
sys_descriptor_spec(0'E, float('E',6)) --> !.
sys_descriptor_spec(0'f, float('f',6)) --> !.
sys_descriptor_spec(0'F, float('F',6)) --> !.
sys_descriptor_spec(0'g, float('g',6)) --> !.
sys_descriptor_spec(0'G, float('G',6)) --> !.
sys_descriptor_spec(0'k, canon) --> !.
sys_descriptor_spec(0'q, quote) --> !.
sys_descriptor_spec(0'r, radix('r',8)) --> !.
sys_descriptor_spec(0'R, radix('R',8)) --> !.
sys_descriptor_spec(0'w, write) --> !.
sys_descriptor_spec(C, _) -->
   {char_code(S, C), throw(error(existence_error(format_character,S),_))}.

% sys_descriptor_number(+Integer, +Integer, -Term, +List, -List)
sys_descriptor_number(C, N, R) --> {0'0 =< C, C =< 0'9}, !,
   {M is N*10+C-0'0},
   sys_descriptor_char(D),
   sys_descriptor_number(D, M, R).
sys_descriptor_number(0'|, N, column(N)) --> !.
sys_descriptor_number(0'e, N, float('e',N)) --> !.
sys_descriptor_number(0'E, N, float('E',N)) --> !.
sys_descriptor_number(0'f, N, float('f',N)) --> !.
sys_descriptor_number(0'F, N, float('F',N)) --> !.
sys_descriptor_number(0'g, N, float('g',N)) --> !.
sys_descriptor_number(0'G, N, float('G',N)) --> !.
sys_descriptor_number(0'r, N, radix('r',N)) --> !.
sys_descriptor_number(0'R, N, radix('R',N)) --> !.
sys_descriptor_number(C, _, _) -->
   {char_code(S, C), throw(error(existence_error(format_character,S),_))}.

% sys_descriptor_alpha(+Integer, +Integer, -Term, +List, -List)
sys_descriptor_alpha(0't, N, rubber(C)) --> {char_code(C, N)}, !.
sys_descriptor_alpha(C, _, _) -->
   {char_code(S, C), throw(error(existence_error(format_character,S),_))}.

/*******************************************************************/
/* Foreign Predicates                                              */
/*******************************************************************/

% sys_number_atom(F, S, N, A):
% defined in foreign(strlib)

:- ensure_loaded(foreign(text/strlib)).

/****************************************************************/
/* Error Texts                                                  */
/****************************************************************/

% strings(+Atom, +Atom, -Atom)
:- multifile(strings/3).
strings('syntax_error.aguments_mismatch', de, 'Anzahl der Argumente stimmt nicht überein.').
strings('syntax_error.format_missing', de, 'Formatzeichen fehlt.').
strings('syntax_error.column_missing', de, 'Spaltengrenze fehlt.').

strings('existence_error.format_character', de, 'Unbekannter Formatbezeichner ~q.').

strings('syntax_error.aguments_mismatch', '', 'Number of arguments does not match.').
strings('syntax_error.format_missing', '', 'Format character missing.').
strings('syntax_error.column_missing', '', 'Column boundary missing.').

strings('existence_error.format_character', '', 'Unknown format specifier ~q.').