/*  SDO_OUTPUT.PL  */
 
 
:- module sdo_output.
 
 
:- public pretty/3,
          add_should_separate/1,
          del_should_separate/1.
 
 
/*
SPECIFICATION
-------------
 
These are the parts of the SDO system that are needed during
pretty-printing, but not during rule-translation. If you use
sdo_rewrite, you can consult the file thus generated, load this module,
and pretty-print, without needing the contents of SDO.PL. You should
have read the specification part of SDO before coming here.
 
 
PUBLIC pretty( Cat+, LineLength+, Tag+ ):
-----------------------------------------       
 
Cat is some rule head of an SDO grammar. Pretty-prints according to
to Cat, on lines of maximum length LineLength. Undefined (bug) if Cat
fails. Usually, Cat will be a structure with at least one argument.
 
Tag can be any term (should be ground). It's used to determine when two
tokens should be separated by space - see below.
 
 
add_should_separate( P+ ):
del_should_separate( P+ ):
--------------------------
 
add_should_separate(P) ensures there is a clause
    should_separate( Tag, C1, C2 ) :- P( Tag, C1, C2 )
asserted. should_separate is used to determine whether a space should be
written between characters C1 and C2, when C1 is the previous token
written and C2 is the current one. Tag is the fourth argument of pretty.
 
Example:
    ?- add_should_separate( myss ).
    myss( sdo1, C1, C2 ) :-
        is_letter_char( C1 ),
        is_letter_char( C2 ).
    myss( fred, 33, 65 ).
    myss( fred, 33, 66 ).
Given the definitions for myss, you link them to should_separate by
calling add_should_separate. The first clause will be used whenever you
call
    ?- pretty( ... , sdo1 ).
and the second, when you call
    ?- pretty( ... , fred ).
 
So now, any rules pretty-printed with tag sdo1 will put a space between
tokens that end and start with a letter. And any rules pretty-printed
with tag fred will put a space between any token ending in ! (ASCII 33),
and any starting with A or B (ASCII 65 and 66).
 
If should_separate fails, it means no space should go between the tokens.
*/
 
 
/*
IMPLEMENTATION
--------------
 
See SDO.PL for implementation details.
*/
 
 
:- needs
    add_linking_clause / 3,
    append / 3,
    assertion / 3,
    bug / 2,
    del_linking_clause / 3,
    last / 2,
    output / 1,
    output_to_chars / 2.
 
 
:- dynamic should_separate/3.
 
 
/* PRETTY */
 
 
pretty( Cat, Max, Tag ) :-
   Cat =.. List,
   append(List,[env(0,promised(0),Max,'$none',Tag),_],New),
   Goal =.. New,
   ( call(Goal) -> true ; bug('pretty: goal failed', Goal ) ).
 
 
/*  TOKEN OUTPUT  */
 
 
/*  sdo_output( Tokens+, Env0+, Env- ):
        Env is the result of outputting token list Tokens in writing-
        environment Tokens.
*/
sdo_output( [], Env, Env ) :- !.
 
sdo_output( [H|T], Env0, Env ) :-
    sdo_token( H, Env0, Env1 ),
    sdo_output( T, Env1, Env ).
 
 
/*  The predicates below implement the special terms nl etc.  */
 
 
/*  Emit a newline and set a promise to space up to the left margin */
sdo_newline( env(M,_,L,_,Tag),
             env(M,promised(M),L,'$none',Tag)
           ) :-
    output( nl_ ).
    /*  We update the last-token-written to indicate that there
        is none on the new line.
    */
 
 
/*  Indent the left margin by N.  */
sdo_indent( N, env(M,promised(_),L,C,Tag),
               env(MN,promised(MN),L,C,Tag)
          ) :-
    !,
    MN is M + N.
 
sdo_indent( N, env(M,_,L,C,Tag),
               env(MN,MN,L,C,Tag)
          ) :-
    MN is M + N.
 
 
/*  Edent the left margin by N.  */
sdo_edent( N, env(M,promised(_),L,C,Tag),
              env(MN,promised(MN),L,C,Tag)
         ) :-
    !,
    MN is M - N.
 
sdo_edent( N, env(M,_,L,C,Tag),
              env(MN,MN,L,C,Tag)
         ) :-
    MN is M - N.
 
 
/*  Set the left margin to M.  */
sdo_set_margin( M, env(_,promised(_),L,C,Tag),
                   env(M,promised(M),L,C,Tag)
              ) :- !.
 
sdo_set_margin( M, env(_,Here,L,C,Tag),
                   env(M,Here,L,C,Tag)
              ).
 
 
/*  Unify M with the left margin.  */
sdo_get_margin( M, env(M,Here,L,C,Tag),
                   env(M,Here,L,C,Tag)
              ).
 
 
/*  Move to character position N.  */
sdo_set_position( N, Env0
                     Env
                ) :-
    sdo_force_promise( Env0, Env1 ),
    Env1 = env( _, Here, _, _, _ ),
    assertion( Here=<N, 'sdo_moveto: too far on', [Here,N] ),
    SpacesNeeded is N-Here,
    sdo_spaces( SpacesNeeded, Env1, Env ).
 
 
/*  Unify P with the current position.  */
sdo_get_position( P, env(M,promised(P),L,C,Tag),
                     env(M,promised(P),L,C,Tag)
                ) :- !.
 
sdo_get_position( P, env(M,P,L,C,Tag),
                     env(M,P,L,C,Tag)
                ).
 
 
/*  Emit N spaces.  */
sdo_spaces( 0, Env, Env ) :- !.
 
sdo_spaces( N, Env0, Env ) :-
    sdo_force_promise( Env0, Env1 ),
    sdo_check_length( N, spaces(N), Env1, Env2 ),
    sdo_force_promise( Env2, Env3 ),
    output( spaces_(N) ),
    sdo_position_plus( N, Env3, Env4 ),
    sdo_have_written( " ", Env4, Env ).
 
sdo_spaces( N, Env0, Env ) :-
    bug( 'sdo_spaces failed.', [N,Env0,Env] ).
 
 
/*  Emit Token.  */
sdo_token( Token, Env0, Env ) :-
    output_to_chars( Token, TokenAsChars ),
    assertion( TokenAsChars\=[], 'sdo_token: token must not be null', Token ),
    sdo_force_promise( Env0, Env1 ),
    sdo_check_separators( TokenAsChars, Env1, Env2 ),
    xlength( TokenAsChars, Length ),
    sdo_check_length( Length, Token, Env2, Env3 ),
    sdo_force_promise( Env3, Env4 ),
    output( puts_(TokenAsChars) ),
    sdo_position_plus( Length, Env4, Env5 ),
    sdo_have_written( TokenAsChars, Env5, Env ).
 
sdo_token( Token, Env0, Env ) :-
    bug( 'sdo_token failed.', [Token,Env0,Env] ).
 
 
/*  Set the last-written token to Last.  */
sdo_have_written( Last, env(M,Here,Max,_,Tag),
                        env(M,Here,Max,Last,Tag)
            ).
 
 
/*  Increment the new character position by L. Unlike sdo_set_position,
    this does not involve any movement: it just updates a field.
*/
sdo_position_plus( L, env(M,Old,Max,Last,Tag),
                      env(M,New,Max,Last,Tag)
                 ) :-
    New is L + Old.
 
 
/*  sdo_check_separators( Token: character_list+, Env0+, Env- ):
        If Token needs to be separated from the last token written,
        write a space. Update Env0 accordingly into Env.
*/
sdo_check_separators( _, env(A,B,C,'$none',Tag),
                         env(A,B,C,'$none',Tag)
                    ) :- !.
 
sdo_check_separators( Current, env(A,B,C,Last,Tag),
                               Env
                    ) :-
    last( C1, Last ),
    Current = [C2|_],
    sdo_check_separators( env(A,B,C,Last,Tag), Env, C1, C2 ).
 
sdo_check_separators( Token, Env0, Env ) :-
    bug( 'sdo_check_separators failed.', [Token,Env0,Env] ).
 
 
sdo_check_separators( Env0, Env, C1, C2 ) :-
    Env0 = env(_,_,_,_,Tag),
    should_separate( Tag, C1, C2 ),
    !,
    sdo_spaces( 1, Env0, Env ).
 
sdo_check_separators( Env, Env, C1, C2 ).
 
 
/*  sdo_check_length( Length+, Token+, Env0+, Env- ):
        Length is the length of the token about to be written. If it
        would run off the current line, take a newline, else do nothing.
        Declaratively: Env is Env0 adjusted in such a way that there's
        room for a token of length Length on the line it describes. The
        side effect is to produce that line.
 
        If the token won't fit on the line at all, I write it out
        anyway. This is needed for the long strings found in SPIN and
        DEPRESSION. What I used to do was to report a bug: that clause
        is now commented out.
 
        You may want to alter the action here so it's cleverer about
        preserving aesthetics for long tokens.
*/
 
/*
sdo_check_length( L, Token,
                     env(M,Here,Max,C,Tag),
                     env(M,M,Max,C,Tag)
                ) :-
    Excess is L-Max,
    Excess > 0,
    !,
    bug( 'sdo_check_length: token too long', [L,Token] ).
    See comment above.
*/
 
sdo_check_length( L, _,
                     env(M,Here,Max,C,Tag),
                     env(NewM,NewHere,Max,NewC,Tag)
                ) :-
    End is Here+L,
    End > Max,
    sdo_newline( env(M,Here,Max,C,Tag), env(NewM,NewHere,Max,NewC,Tag) ).
 
sdo_check_length( L, _,
                     Env,
                     Env
                ).
 
 
sdo_force_promise( env(M,promised(Here),Max,Last,Tag),
                   env(M,Here,Max,Last,Tag)
                 ) :-
    !,
    output( spaces_(Here) ).
 
sdo_force_promise( Env,
                   Env
                 ).
 
 
/*
Utility.
--------
 
The Poplog built-in length/2 crashes on large recursion depths. This
used to kill PP.SDO, because it had to check the length of very large
character lists. To avoid this, I've defined xlength, which takes list
elements 10 at a time to reduce recursion. Note that it also uses
a number-accumulator argument to make it tail-recursive.        
*/
 
 
/*  xlength( L+, N- ):
        List L has length N.
*/
xlength( L, N ) :-
    xlength( L, 0, N ).
 
 
xlength( [], N, N ) :- !.
 
xlength( [_,_,_,_,_,_,_,_,_,_|T], SoFar, N ) :-
    !,
    Next is SoFar + 10,
    xlength( T, Next, N ).
 
xlength( [_|T], SoFar, N ) :-
    Next is SoFar + 1,
    xlength( T, Next, N ).
 
 
/*
Adding clauses for should_separate.                     
-----------------------------------
*/
 
 
add_should_separate( P ) :-
    add_linking_clause( should_separate, P, 3 ).
 
 
del_should_separate( P ) :-
    del_linking_clause( should_separate, P, 3 ).
 
 
:- endmodule.
