Prolog "format"
/**
* 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.').