% -----------------------------------------------------------------------------
%  (C) Altran Praxis Limited
% -----------------------------------------------------------------------------
% 
%  The SPARK toolset is free software; you can redistribute it and/or modify it
%  under terms of the GNU General Public License as published by the Free
%  Software Foundation; either version 3, or (at your option) any later
%  version. The SPARK toolset is distributed in the hope that it will be
%  useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
%  Public License for more details. You should have received a copy of the GNU
%  General Public License distributed with the SPARK toolset; see file
%  COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
%  the license.
% 
% =============================================================================


/******** TRAVERSE: top-level checker command ********/
traverse :-
        (
           command_arg(expression, EXPRESSION)
        ;
           prompt_user('TRAVERSE -- Please specify expression to be traversed.', 'Expression? '),
           rread(EXPRN),
           parse_expression(EXPRN, EXPRESSION)
        ),
        !,
        traverse(EXPRESSION).


/*** traverse(EXPRESSION) -- setup expression and enter tv environment! ***/
traverse(HORC#N) :-
        (
           HORC=h,
           HC=hyp
        ;
           HORC=c,
           HC=conc
        ),
        X=..[HC,N,E],
        call(X),
        !,
        traverse(E),
        !.
traverse(X) :-
        novars(X),
        !,
        retractall(tv_depth(_)),
        retractall(tv_expr(_,_)),
        retractall(tv_trace(_)),
        retractall(tv_cmd_buffer(_)),
        !,
        asserta(tv_depth(0)),
        asserta(tv_expr(0,X)),
        asserta(tv_trace([])),
        !,
        tv_environment,
        !.


tv_environment :-
        tv_process_command(redisplay),
        !,
        repeat,
           tv_get_command(COMMAND),
           tv_process_command(COMMAND),
        /* until */ COMMAND = exit,
        !.


/*----------------------------------------------------------------------------*/


tv_get_command(COMMAND) :-
        retract(tv_cmd_buffer(COMMAND)),
        !.
tv_get_command(_) :-
        prompt_user('Traverse-Command>>'),                      /* CFR1334 */
        tv_read_line_of_chars(LINE_OF_CHARS),
        tv_process_line_of_chars(LINE_OF_CHARS),
        !,
        fail.


tv_read_line_of_chars(LINE) :-
        lget0(CHAR),                                            /* CFR015 */
        !,
        (
           tv_cmd_terminator(CHAR),
           LINE = []
        ;
           tv_blank_char(CHAR),
           !,
           tv_read_line_of_chars(LINE)
        ;
           LINE=[CH|REST],
           tv_make_atom(CHAR, CH),
           !,
           tv_read_line_of_chars(REST)
        ),
        !.

tv_cmd_terminator(13).
tv_cmd_terminator(EOL) :- eol_char(EOL).
tv_cmd_terminator(EOF) :- eof_char(EOF), see_correct_input_stream, !.           /* CFR015 */


tv_blank_char(32).
tv_blank_char(8).
tv_blank_char(46).


tv_make_atom(CHAR, CH) :-
        CHAR>64,
        CHAR<91,                        /* so in A..Z */
        CHAR1 is CHAR+32,
        !,
        name(CH, [CHAR1]),
        !.
tv_make_atom(45, u) :- !.               /* "-" synonymous with "up"   */
tv_make_atom(43, d) :- !.               /* "+" synonymous with "down" */
tv_make_atom(63, h) :- !.               /* "?" synonymous with "help" */
tv_make_atom(CHAR, CH) :-
        name(CH, [CHAR]),               /* o.k. otherwise */
        !.


tv_process_line_of_chars([x|_]) :-
        assertz(tv_cmd_buffer(exit)),
        !.
tv_process_line_of_chars([t|REST]) :-
        assertz(tv_cmd_buffer(type)),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([l,b|REST]) :-
        assertz(tv_cmd_buffer(locate(brief))),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([l,f|REST]) :-
        assertz(tv_cmd_buffer(locate(full))),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([l|REST]) :-
        assertz(tv_cmd_buffer(locate(brief))),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([u|REST]) :-
        assertz(tv_cmd_buffer(up)),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([d|REST]) :-
        tv_fetch_number(REST, NUMBER, REMAINDER),
        !,
        assertz(tv_cmd_buffer(down(NUMBER))),
        !,
        tv_process_line_of_chars(REMAINDER),
        !.
tv_process_line_of_chars([h|REST]) :-
        assertz(tv_cmd_buffer('help')),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([r|REST]) :-
        assertz(tv_cmd_buffer(redisplay)),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([s|REST]) :-
        assertz(tv_cmd_buffer(showtop)),
        !,
        tv_process_line_of_chars(REST),
        !.
tv_process_line_of_chars([]) :- !.
tv_process_line_of_chars(REST) :-
        assertz(tv_cmd_buffer(error(REST))),
        !.


/*----------------------------------------------------------------------------*/


tv_process_command(redisplay) :-
        tv_depth(DEPTH),
        is_inverse_video(INV),
        is_normal_video(NORM),
        write('Depth: '),
        print(DEPTH),
        write(',       Trace: '),
        tv_trace(TRACE),
        wnl(TRACE),
        tv_expr(DEPTH, EXPRESSION),
        write('*** '),
        wnl(EXPRESSION),
        write('Principal functor: '),
        EXPRESSION =.. [FUNCTOR|ARGUMENTS],
        !,
        print(INV), print(FUNCTOR), print(NORM),
        length(ARGUMENTS, LENGTH),
        !,
        tv_display_arg_info(LENGTH, ARGUMENTS),
        !.
tv_process_command(up) :-
        tv_depth(OLDDEPTH),
        OLDDEPTH > 0,
        !,
        retractall(tv_depth(_)),
        retractall(tv_expr(OLDDEPTH, _)),
        NEWDEPTH is OLDDEPTH - 1,
        asserta(tv_depth(NEWDEPTH)),
        tv_trace(OLDTRACE),
        retractall(tv_trace(_)),
        gen_append(NEWTRACE, [_], OLDTRACE),
        asserta(tv_trace(NEWTRACE)),
        tv_expr(NEWDEPTH, NEWEXPRESSION),
        (
           (
              NEWEXPRESSION = for_all(V:T, _)
           ;
              NEWEXPRESSION = for_some(V:T, _)
           ),
           find_core_type(T, CT),
           retractall(var_const(V, CT, tv))
        ;
           true
        ),
        !,
        tv_process_command(redisplay),
        !.
tv_process_command(up) :-
        tv_cmd_buffer(_),
        !,
        wnl('CANNOT "UP" AT TOP-LEVEL.  (Rest of command-line ignored)'),
        retractall(tv_cmd_buffer(_)),
        !.
tv_process_command(up) :-
        wnl('CANNOT "UP" AT TOP-LEVEL.'),
        !.
tv_process_command(down(N)) :-
        tv_depth(OLDDEPTH),
        tv_expr(OLDDEPTH, OLDEXPRESSION),
        \+ atomic(OLDEXPRESSION),
        tv_trace(OLDTRACE),
        !,
        NEWDEPTH is OLDDEPTH + 1,
        functor(OLDEXPRESSION, _, ARITY),
        (
           (
              integer(N),
              N >= 1,
              N =< ARITY,
              NN = N
           ;
              N = -1,
              ARITY = 1,
              NN = 1
           ),
           !,
           arg(NN, OLDEXPRESSION, NEWEXPRESSION),
           retractall(tv_depth(_)),
           asserta(tv_depth(NEWDEPTH)),
           asserta(tv_expr(NEWDEPTH, NEWEXPRESSION)),
           retractall(tv_trace(_)),
           append(OLDTRACE, [NN], NEWTRACE),
           asserta(tv_trace(NEWTRACE)),
           (
              (
                 OLDEXPRESSION = for_all(V:T, _)
              ;
                 OLDEXPRESSION = for_some(V:T, _)
              ),
              find_core_type(T, CT),
              assertz(var_const(V, CT, tv))
           ;
              true
           ),
           !,
           tv_process_command(redisplay)
        ;
           tv_cmd_buffer(_),
           wnl('"DOWN" NON-EXISTENT ARGUMENT.  (Rest of command-line ignored)'),
           retractall(tv_cmd_buffer(_))
        ;
           wnl('"DOWN" NON-EXISTENT ARGUMENT.')
        ),
        !.
tv_process_command(down(_)) :-
        tv_cmd_buffer(_),
        !,
        wnl('CANNOT "DOWN" AT TREE-LEAF.  (Rest of command-line ignored)'),
        retractall(tv_cmd_buffer(_)),
        !.
tv_process_command(down(_)) :-
        !,
        wnl('CANNOT "DOWN" AT TREE-LEAF.'),
        !.
tv_process_command(type) :-
        tv_depth(DEPTH),
        tv_expr(DEPTH, EXPRESSION),
        !,
        tv_show_type_template(EXPRESSION),
        !.
tv_process_command(locate(B_OR_F)) :-
        tv_build_locate_expr(EXPRESSION, B_OR_F),
        !,
        wnl(EXPRESSION),
        !.
tv_process_command('help') :-
        wnl(' TRAVERSE ENVIRONMENT COMMANDS:'),
        wnl(' ------------------------------'),
        wnl(' u (or -)   UP (ascend a level in expression tree)'),
        wnl(' d (or +)   DOWN (descend a level); must be followed by argument no.'),
        wnl('                 (e.g. d2 = descend argument 2)'),
        wnl(' l          LOCATION of current level w.r.t. original expression'),
        wnl('                 (follow by "f" for FULL or ["b"] (default) BRIEF)'),
        wnl(' t          TYPE information for current level'),
        wnl(' r          REDISPLAY current level'),
        wnl(' s          SHOW top-level expression (in full)'),
        wnl(' h (or ?)   HELP -- displays this message'),
        wnl(' x          EXIT from traverse command environment'),  /* CFR031 */
        nl,
        !.
tv_process_command(showtop) :-
        tv_expr(0, TOP_EXPR),
        wnl('TOPLEVEL EXPRESSION:'),
        wnl(TOP_EXPR),
        !.
tv_process_command(exit) :-
        retractall(var_const(_, _, tv)),
        !.
tv_process_command(error(LIST)) :-
        !,
        write('ERROR(S) IN COMMAND SEQUENCE:  '),
        tv_write_list(LIST),
        wnl('Please retype command-line.'),
        !.

wnl(X) :- print(X), nl, !.


/*----------------------------------------------------------------------------*/


tv_fetch_number(REST, NUMBER, REMAINDER) :-
        tv_fetch_digits(REST, DIGITS, REMAINDER),
        tv_form_number(DIGITS, 0, NUMBER),
        !.


tv_fetch_digits([FIRST|REST], [FIRST|DIGITS], REMAINDER) :-
        integer(FIRST), 0 =< FIRST, FIRST =< 9,
        !,
        tv_fetch_digits(REST, DIGITS, REMAINDER),
        !.
tv_fetch_digits(REMAINDER, [], REMAINDER) :- !.


tv_form_number([N], S, R) :- R is 10 * S + N, !.
tv_form_number([N|L], S, R) :-
        S1 is 10 * S + N,
        !,
        tv_form_number(L, S1, R),
        !.
tv_form_number([], _, -1) :- !.         /* error case: d~ */


tv_display_arg_info(0, _ARGUMENTS) :-
        wnl('  (atomic object: leaf of expression tree)'),
        !.
tv_display_arg_info(LENGTH, ARGUMENTS) :-
        write('  ('),
        print(LENGTH),
        wnl(' arguments)'),
        !,
        tv_display_arguments(ARGUMENTS, 1),
        !.


tv_display_arguments([ARG|ARGUMENTS], N) :-
        is_inverse_video(INV),
        is_normal_video(NORM),
        print(INV),
        write('ARG'),
        print(N),
        write(':'),
        print(NORM),
        write('  '),
        wnl(ARG),
        N1 is N+1,
        !,
        tv_display_arguments(ARGUMENTS, N1),
        !.
tv_display_arguments([], _) :- !.


tv_show_type_template(EXPRESSION) :-
        atomic(EXPRESSION),
        !,
        (
           checktype(EXPRESSION, TYPE)
        ;
           is_a_valid_type(EXPRESSION),
           TYPE = '{type-identifier}'
        ;
           type_alias(EXPRESSION, _),
           TYPE = '{type-identifier}'
        ),
        !,
        wnl('Type information for atomic object:'),
        !,
        tv_print_type_data(EXPRESSION, TYPE),
        !.
tv_show_type_template(update(A, I, X)) :-
        checktype(A, ARRAYTYPE),
        type(ARRAYTYPE, array(INDEXTYPES, ELEM_TYPE)),
        checktypes(I, INDEXTYPES),
        checktype(X, ELEM_TYPE),
        !,
        tv_print_function_name(update),
        !,
        tv_print_type_data(update(ARRAYTYPE,INDEXTYPES,ELEM_TYPE), ARRAYTYPE),
        !.
tv_show_type_template(element(A, I)) :-
        checktype(A, ARRAYTYPE),
        type(ARRAYTYPE, array(INDEXTYPES, ELEM_TYPE)),
        checktypes(I, INDEXTYPES),
        !,
        tv_print_function_name(element),
        !,
        tv_print_type_data(element(ARRAYTYPE, INDEXTYPES), ELEM_TYPE),
        !.
tv_show_type_template([X|Y]) :-
        checktype([X|Y], TYPE),
        type(TYPE, sequence(ELEM_TYPE)),
        !,
        tv_print_function_name('.'),
        !,
        tv_print_type_data([ELEM_TYPE|TYPE], TYPE),
        !.
tv_show_type_template([X|Y]) :-
        checktypes([X|Y], TYPES),
        !,
        tv_print_function_name('.'),
        !,
        tv_print_type_data(TYPES, '{list}'),
        !.
tv_show_type_template(set X) :-
        checktype(set X, TYPE),
        type(TYPE, set(_ELEM_TYPE)),
        !,
        tv_print_function_name('set'),
        !,
        tv_print_type_data((set '{list}'), TYPE),
        !.
tv_show_type_template(for_all(X, Y)) :-
        checktype(for_all(X, Y), boolean),
        !,
        tv_print_function_name(for_all),
        !,
        tv_print_type_data(for_all('{binding}', boolean), boolean),
        !.
tv_show_type_template(for_some(X, Y)) :-
        checktype(for_some(X, Y), boolean),
        !,
        tv_print_function_name(for_some),
        !,
        tv_print_type_data(for_some('{binding}', boolean), boolean),
        !.
tv_show_type_template(X:Y) :-
        atom(X),
        (
           is_a_valid_type(Y)
        ;
           type_alias(Y, _)
        ),
        !,
        tv_print_function_name(':'),
        !,
        tv_print_type_data('{ {identifier} : {type} }', '{binding}'),
        !.
tv_show_type_template(EXPRESSION) :-
        function_template(EXPRESSION, VARS, FUNCTION_NAME),
        function(FUNCTION_NAME, TYPES, RESULT_TYPE),
        !,
        checktypes(VARS, TYPES),
        !,
        function_template(TYPE_MATCH, TYPES, FUNCTION_NAME),
        !,
        tv_print_function_name(FUNCTION_NAME),
        !,
        tv_print_type_data(TYPE_MATCH, RESULT_TYPE),
        !.
tv_show_type_template(EXPRESSION) :-
        checktype(EXPRESSION, RESULT_TYPE),                     /* CFR029 */
        record_function(_, EXPRESSION, _, XXX, VARS, RESULT_TYPE), /* 029 */
        functor(EXPRESSION, FUNCTION_NAME, _),
        function(FUNCTION_NAME, TYPES, RESULT_TYPE),
        !,
        checktypes(VARS, TYPES),
        !,
        record_function(_, TYPE_MATCH, _, XXX, TYPES, RESULT_TYPE), /*029 */
        !,
        tv_print_function_name(FUNCTION_NAME),
        !,
        tv_print_type_data(TYPE_MATCH, RESULT_TYPE),
        !.
tv_show_type_template(EXPRESSION) :-
        EXPRESSION =.. [FUNCTION_NAME | VARS],
        checktype(EXPRESSION, RESULT_TYPE),
        !,
        checktypes(VARS, TYPES),
        !,
        TYPE_MATCH =.. [FUNCTION_NAME | TYPES],
        !,
        tv_print_function_name(FUNCTION_NAME),
        !,
        tv_print_type_data(TYPE_MATCH, RESULT_TYPE),
        !.


tv_print_function_name(FUNCTION_NAME) :-
        write('Type information for function '),
        is_inverse_video(INV),
        is_normal_video(NORM),
        print(INV),
        print(FUNCTION_NAME),
        print(NORM),
        wnl(':'),
        !.


tv_print_type_data(TYPE_MATCH, RESULT_TYPE) :-
        print(TYPE_MATCH),
        write(': '),
        print(RESULT_TYPE),
        wnl('.'),
        !.


tv_build_locate_expr(EXPRESSION, B_OR_F) :-
        tv_trace(TRACE),
        tv_expr(0, START_EXPR),
        tv_build_expr(TRACE, START_EXPR, EXPRESSION, B_OR_F),
        !.


tv_build_expr([ARG|TRACE], START_EXPR, EXPRESSION, B_OR_F) :-
        functor(START_EXPR, F, A),
        functor(EXPRESSION, F, A),
        !,
        tv_instantiate(EXPRESSION, ARG, 1, A, B_OR_F, START_EXPR),
        arg(ARG, START_EXPR, NEW_START),
        arg(ARG, EXPRESSION, NEW_EXPR),
        !,
        tv_build_expr(TRACE, NEW_START, NEW_EXPR, B_OR_F),
        !.
tv_build_expr([], _, EXPRESSION, _B_OR_F) :-
        is_inverse_video(INV),
        is_normal_video(NORM),
        name(INV, IL),
        name(NORM, NL),
        append(IL, [42,72,69,82,69,42|NL], EL),         /* "*HERE*" ! */
        !,
        name(EXPRESSION, EL),
        !.


tv_instantiate(_EXPRESSION, ARG, ARG, ARG, _B_OR_F, _) :- !.
tv_instantiate(EXPRESSION, ARG, ARG, UPP, B_OR_F, START_EXPR) :-
        LOW is ARG + 1,
        !,
        tv_instantiate(EXPRESSION, ARG, LOW, UPP, B_OR_F, START_EXPR),
        !.
tv_instantiate(EXPRESSION, _ARG, UPP, UPP, brief, _) :-
        arg(UPP, EXPRESSION, '...'),
        !.
tv_instantiate(EXPRESSION, _ARG, UPP, UPP, full, START_EXPR) :-
        arg(UPP, START_EXPR, XXX),
        arg(UPP, EXPRESSION, XXX),
        !.
tv_instantiate(EXPRESSION, ARG, LOW, UPP, brief, _) :-
        arg(LOW, EXPRESSION, '...'),
        LO_ is LOW + 1,
        !,
        tv_instantiate(EXPRESSION, ARG, LO_, UPP, brief, []),
        !.
tv_instantiate(EXPRESSION, ARG, LOW, UPP, full, START_EXPR) :-
        arg(LOW, START_EXPR, XXX),
        arg(LOW, EXPRESSION, XXX),
        LO_ is LOW + 1,
        !,
        tv_instantiate(EXPRESSION, ARG, LO_, UPP, full, START_EXPR),
        !.


tv_write_list([HEAD|TAIL]) :-
        print(HEAD),
        !,
        tv_write_list(TAIL),
        !.
tv_write_list([]) :- nl, !.


is_inverse_video(INV) :- inverse_video(L), !, name(INV, L), !.


is_normal_video(NORM) :- normal_video(L), !, name(NORM, L), !.
%###############################################################################
%END-OF-FILE
