% -----------------------------------------------------------------------------
%  (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.
% 
% =============================================================================


/******** INFER: top-level checker command ********/
infer :-
        retract(on_filename(FNAME)),
        file_exists_and_is_readable(FNAME),
        see(FNAME),
        seen,
        see_correct_input_stream,                               /* CFR015 */
        fail.
infer :-
        (
           command_arg(expression, G)
        ;
           prompt_user('INFER -- Type formula to infer.','INFER -- Formula? '),
           rread(GX),
           parse_expression(GX, G)
        ),
        (
           G=c#N,
           conc(N,F)
        ;
           F=G
        ),
        !,
        (
           command_arg(rule, exists),
           !
        ;
           prompt_user('Rulename pattern? '),
           rread(RP),
           parse_rulename(RP)
        ),
        !,
        (
           command_arg(hyplist, HYPLIST),
           !,
           temp_del_hyps(HYPLIST)
        ;
           true
        ),
        !,
        retractall(inf_match),
        (
           try_infer(F,R,[],on),
           novars(F),                                           /* CFR009 */
           (
              typechecking(on),
              (
                 checktype(F, boolean)
              ;
                 write('!!! ERROR: Above formula did not type-check correctly.'),
                 nl,
                 !,
                 fail
              )
           ;
              true
           ),
           nl,
           write('*** '),
           print(F),
           write(' by '),
           print(R),
           write('.'),
           nl,
           nl,
           restore_temp_del_hyps,
           add_new_hyp(F,1),
           (
              G=c#N,
              done(N)
           ;
              true
           )
        ;
           nl,
           !,
           (
              inf_fail(R,F),
              restore_temp_del_hyps
           ;
              restore_temp_del_hyps,
              fail
           )
        ),
        !.


/*** TRY_INFER(F,R,J,D) - try to infer F using rules R, leaving J unproven ***/
try_infer(FORMULA,RULENAME,REMAINING_GOALS,DISPLAY_STATUS) :-
   retractall(type_classification_done),
   retractall(type_classification(_,_)),
   retractall(abandon_search),                                  /* CFR047 */
   retractall(search_count(_)),                                 /* CFR047 */
   (
      novars(FORMULA),
      (
         atom(FORMULA)
      ;
         FORMULA=..[_F|ARGS],
         save_type_classification_list(ARGS),
         asserta(type_classification_done)
      )
   ;
      true
   ),
   !,
   (
      rule_match(RULENAME,FORMULA,GOALS),
      on_filename(FILE),
      ok_type_classification(FORMULA, FILE, RULENAME),
      fulfil(GOALS,UNSATISFIED_GOALS)
   ;
      \+ search_count(_),
      !,
      command_arg(rulename, R),
      nl, write('Cannot infer '), print(FORMULA), write(' using '),
      (
         novars(R),
         write('rule '),
         print(R)
      ;
         var(R),
         write('rule '),
         print(R)
      ;
         nonvar(R),
         R =.. [Rfamily |_ ],
         write('rule-family '),
         print(Rfamily)
      ),
      write('.'), nl,
      !,
      fail
   ),
   (
      abandon_search,                                           /* CFR047 */
      !,                                                        /* CFR047 */
      fail                                                      /* CFR047 */
   ;                                                            /* CFR047 */
      true                                                      /* CFR047 */
   ),                                                           /* CFR047 */
   display_inf_rule(RULENAME,FORMULA,UNSATISFIED_GOALS,DISPLAY_STATUS),
   UNSATISFIED_GOALS=REMAINING_GOALS,
   (
      REMAINING_GOALS=[],
      assertz(logfact(rulematch,
                      ([FILE,RULENAME]: (FORMULA may_be_deduced_from GOALS))))
   ;
      REMAINING_GOALS\=[]
   ).


/*** DISPLAY_INF_RULE(R,F,J,D) - display the rule on the screen if J o.k. ***/
display_inf_rule(R,F,J,D) :-
   (
      D=on,
      (
         display_subgoals_max(N)
      ;
         N=99
      ),
      length(J, LEN),
      LEN =< N
   ;
      D=off
   ),
   (
      display_var_free_only(off),
      TESTED=no
   ;
      var_free(J),
      TESTED=yes
   ),
   nl,
   nl,
   print(R),
   write(': '),
   print(F),
   put_code(32),
   (
      J=[],
      write('may be inferred directly')
   ;
      write('follows from '),
      write_justs(J)
   ),
   (
      (
         TESTED=yes
      ;
         var_free(J)
      ),
      (
         inf_match
      ;
         assertz(inf_match)
      ),
      increment_search_count                                    /* CFR047 */
   ;
      true
   ), !.
display_inf_rule(_R,_F,J,_D) :-
   var_free(J),
   (
      inf_match
   ;
      assertz(inf_match)
   ),
   increment_search_count,                                      /* CFR047 */
   !.
display_inf_rule(_,_,_,_) :- !.


increment_search_count :-                                       /* CFR047 */
        retract(search_count(OLD)),                             /* CFR047 */
        NEW is OLD + 1,                                         /* CFR047 */
        assertz(search_count(NEW)),                             /* CFR047 */
        !,                                                      /* CFR047 */
        (                                                       /* CFR047 */
           NEW = 20,                                            /* CFR047 */
           !,                                                   /* CFR047 */
           ask_user_if_search_should_continue                   /* CFR047 */
        ;                                                       /* CFR047 */
           true                                                 /* CFR047 */
        ),                                                      /* CFR047 */
        !.                                                      /* CFR047 */
increment_search_count :- assertz(search_count(1)), !.          /* CFR047 */


ask_user_if_search_should_continue :-                           /* CFR047 */
        nl, nl,                                                 /* CFR047 */
        write('%%% TWENTY MATCHES FOUND: Do you wish to continue the search?'),
        nl,                                                     /* CFR047 */
        write('    Type Y(es) to continue search, N(o) to abandon it...'),
        nl, nl,                                                 /* CFR047 */
        read_answer('    Continue search', Answer),             /* CFR047 */
        (                                                       /* CFR047 */
           Answer = yes,                                        /* CFR047 */
           retractall(search_count(_))                          /* CFR047 */
        ;                                                       /* CFR047 */
           Answer = no,                                         /* CFR047 */
           assertz(abandon_search)                              /* CFR047 */
        ),                                                      /* CFR047 */
        !.                                                      /* CFR047 */


/*** INF_FAIL(R,F) - called if infer fails to try subgoaling if desired ***/
inf_fail(_R,_F) :-
   (\+ inf_match), !, fail.

inf_fail(R,F) :-
   inf_match,
   !,
   nl,
   nl,
   read_answer('Do you wish to subgoal',Ans),
   !,
   (
      Ans=yes,
      try_infer(F,R,J,off),
      novars(F),                                                /* CFR009 */
      checktype(F, boolean),                                    /* CFR009 */
      var_free(J),
      nl,
      read_answer_once('Use this rule',A),
      A=yes,
      on_filename(FILE),
      assertz(logfact(subgoal, ([FILE,R]: (F may_be_deduced_from J)))),
      restore_temp_del_hyps,
      start_subgoal(F,J,true,'SUBGOALING')
   ;
      Ans=no,
      !,
      fail
   ), !.


/*** RULE_MATCH(R,G,J) - general rule, name R, to match goal G & return J ***/
rule_match(R,F,J) :-
   use_subst_rules_for_equality(on),
   nonvar(F),
   F=(X=Y),
   nonvar(X),
   nonvar(Y),
   X=..[XOP|XArgs],
   Y=..[YOP|YArgs],
   make_up(X1,XOP,XArgs),
   make_up(Y1,YOP,YArgs),
   !,
   X1=..[_|X1Args],
   Y1=..[_|Y1Args],
   fetch_inf_or_subst_rule_for_eq(R,X1,Y1,J1),
   add_conds(XArgs=X1Args,J1,JJ),
   add_conds(YArgs=Y1Args,JJ,J).
rule_match(R,F,J) :-
   nonvar(F),
   F=..[OP|Args],
   make_up(F1,OP,Args),
   !,
   F1=..[_|Args1],
   fetch_inference_rule(R,F1,J1),
   add_conds(Args=Args1,J1,J).


/*** MAKE_UP(F1,OP,Args) - make F1 have functor OP & most general args ***/
make_up(F1,OP,Args) :-
   !,
   generalise(Args,Blanks),
   !,
   F1=..[OP|Blanks],
   !.


/*** GENERALISE(A,Blanks) - create list Blank of vars, same length as A ***/
generalise([],[]) :- !.
generalise([_|T],[_|U]) :- !, generalise(T,U), !.


/*** ADD_CONDS(XL=YL,OJ,NJ) - unify lists XL & YL, creating NJ from OJ ***/
add_conds([]=[],J,J) :- !.
add_conds([C1|T1]=[C1|T2],OJ,NJ) :- !, add_conds(T1=T2,OJ,NJ), !.
add_conds([C1|T1]=[C2|T2],OJ,[C1=C2|NJ]) :- !, add_conds(T1=T2,OJ,NJ), !.


/*** FETCH_INFERENCE_RULE(NAME, FORMULA, JUSTIFICATIONS) ***/
fetch_inference_rule(R,F,J) :-
    use_rulefile(F,FNAME),
    get_term(FNAME,T),
    (
       T=(R: (F may_be_deduced_from J))
    ;
       T=(R: (F may_be_deduced)),
       J=[]
    ),
    \+ banned_rule(FNAME,R),
    is_chosen_rulename(R).


/*** FETCH_INF_OR_SUBST_RULE_FOR_EQ(NAME, LHS, RHS, JUSTIFICATIONS) ***/
fetch_inf_or_subst_rule_for_eq(R,X1,Y1,J) :-
    use_rulefile(_ = _,FNAME),
    get_term(FNAME,T),
    (
       T=(R: (X=Y may_be_deduced_from J1)),                     /* CFR006 */
       add_conds([X1,Y1]=[X,Y],J1,J)                            /* CFR006 */
    ;
       T=(R: (X=Y may_be_deduced)),                             /* CFR006 */
       add_conds([X1,Y1]=[X,Y],[],J)                            /* CFR006 */
    ;
       T=(R: (X1 may_be_replaced_by Y1 if J))
    ;
       T=(R: (Y1 may_be_replaced_by X1 if J))
    ;
       T=(R: (X1 & Y1 are_interchangeable if J))
    ;
       T=(R: (Y1 & X1 are_interchangeable if J))
    ;
       T=(R: (X1 may_be_replaced_by Y1)),
       J=[]
    ;
       T=(R: (Y1 may_be_replaced_by X1)),
       J=[]
    ;
       T=(R: (X1 & Y1 are_interchangeable)),
       J=[]
    ;
       T=(R: (Y1 & X1 are_interchangeable)),
       J=[]
    ),
    \+ banned_rule(FNAME,R),
    is_chosen_rulename(R).

/*** USE_RULEFILE -- finds the rulefile FNAME appropriate for proving F ***/
/*** If FNAME cannot be found, checks to make sure that no rule-family of ***/
/*** requested name exists and prints up an error message.   ***/
use_rulefile(F,FNAME) :-
    (
       find_rulefile(F,FNAME)
    ;
       !,
       command_arg(rulename, R),
       nonvar(R),
       \+ (
               built_in_rulefile(file==_, R)
           ;
               user_rulefile(_, R)
           ;
               special_rulefile(file==_, R)
           ),
       R =.. [Rfamily | _ ],
       nl, write('Could not find rule-family '), print(Rfamily), write('.'),
       nl,
       !,
       fail
    ).

/*** FIND_RULEFILE(F, FNAME) -- get & save rulefile name.  Searches by  ***/
/***                            principle functor ***/
find_rulefile(F,FNAME) :-
    rulefile(F,FNAME),
    atom(FNAME),
    has_matching_rulename(FNAME),
    file_exists_and_is_readable(FNAME),
    see(FNAME),
    seen,
    see_correct_input_stream,                                   /* CFR015 */
    retractall(on_filename(_)),
    asserta(on_filename(FNAME)).
find_rulefile(_F, FNAME) :-
    atom(FNAME),
    \+ file_exists_and_is_readable(FNAME),
    write('Aborted: '),
    print(FNAME),
    write(' does not exist or cannot be read.'),
    nl,
    !,
    close_all_streams,
    halt.

/*** HAS_MATCHING_RULENAME(FNAME) - there's a rule of chosen name in FNAME ***/
has_matching_rulename(FNAME) :-
        clause(command_arg(rulename, R), _),
        rulefile(FNAME, R),
        !.


/*** GET_TERM(FNAME, T) -- read T from FNAME & revert to previous input ***/
get_term(FNAME,T) :-
    repeat,
       seeing(OLDFILE),
       see(FNAME),
       read_unless_abandon_search(T),                           /* CFR047 */
       (
          T\=end_of_file
       ;
          T=end_of_file,
          !,
          seen
       ),
       see(OLDFILE).


read_unless_abandon_search(end_of_file) :- abandon_search, !.   /* CFR047 */
read_unless_abandon_search(T) :- read_term_and_layout(T).       /* CFR047 */


/*****************************************************************************
INFERENCE RULE STRATEGY:
F may_be_deduced_from GOALS.

1. Split GOALS into fully-instantiated-goals (i.e. primary goals) and
   partially-instantiated-goals (i.e. secondary goals).

2. Attempt to satisfy all primary goals.  Cut & branch point.  Either:

   a. All were satisfied.  Then attempt to satisfy secondary goals.
      As soon as one becomes satisfied, split the remainder into primaries
      and secondaries and attempt to satisfy them in the same way (i.e.
      recursively).

   b. Some were not satisfied.  Leave secondary goals and backtrack.

Problems: direct goals.  Eliminate where possible.
*****************************************************************************/


fulfil([], []) :- !.
fulfil(GOALS, UNSATISFIED_GOALS) :-
    split(GOALS, PRIMARIES,SECONDARIES, REST),
    try_to_satisfy(PRIMARIES, UNSATISFIED_PRIMARIES),
    (
       UNSATISFIED_PRIMARIES=[],
       match_up(SECONDARIES, UNSATISFIED_SECONDARIES)
    ;
       UNSATISFIED_PRIMARIES\=[],
       UNSATISFIED_SECONDARIES=SECONDARIES
    ),
    append(UNSATISFIED_PRIMARIES, UNSATISFIED_SECONDARIES, UNSATISFIED_FRONT),
    (
       REST=[],
       UNSATISFIED_GOALS=UNSATISFIED_FRONT
    ;
       REST\=[],
       do_direct_goals(REST, REMAINDER),
       fulfil(REMAINDER, UNSATISFIED_REMAINDER),
       append(UNSATISFIED_FRONT, UNSATISFIED_REMAINDER, UNSATISFIED_GOALS)
    ).

split([],[],[],[]) :- !.
split([G|GOALS],[],[],[G|GOALS]) :-
    nonvar(G),
    G=goal(_),
    !.
split([G|GOALS],[G|PRIMARIES],SECONDARIES,REMAINDER) :-
    novars(G),
    G\=goal(_),
    !,
    split(GOALS,PRIMARIES,SECONDARIES,REMAINDER),
    !.
split([G|GOALS],PRIMARIES,[G|SECONDARIES],REMAINDER) :-
    split(GOALS,PRIMARIES,SECONDARIES,REMAINDER),
    !.

do_direct_goals([G|GOALS],REMAINDER) :-
    nonvar(G),
    G=goal(DIRECT),
    !,
    call(DIRECT),
    do_direct_goals(GOALS,REMAINDER),
    !.
do_direct_goals(REMAINDER,REMAINDER) :-
    !.

try_to_satisfy([],[]) :- !.
try_to_satisfy([G|GOALS],REMAINDER) :-
    nonvar(G),
    G=goal(D),
    !,
    call(D),
    !,
    try_to_satisfy(GOALS,REMAINDER),
    !.
try_to_satisfy([G|GOALS],REMAINDER) :-
    infer(G),
    !,
    try_to_satisfy(GOALS,REMAINDER),
    !.
try_to_satisfy([G|GOALS],[G|REMAINDER]) :-
    try_to_satisfy(GOALS,REMAINDER),
    !.

match_up([],[]) :- !.
match_up(GOALS,UNSATISFIED_GOALS) :-
    seek_solutions([],GOALS,UNSATISFIED),
    split(UNSATISFIED, PRIMARIES, SECONDARIES, REST),
    try_to_satisfy(PRIMARIES, REMAINDER),
    append(SECONDARIES, REST, UNSATISFIED_TAIL),
    append(REMAINDER, UNSATISFIED_TAIL, UNSATISFIED_GOALS).

seek_solutions(PASSED,[G|GOALS],UNSATISFIED_GOALS) :-
    do_satisfy_goal(G),
    seek_solutions(PASSED, GOALS, UNSATISFIED_GOALS).
seek_solutions(PASSED,[G|GOALS],UNSATISFIED_GOALS) :-
    append(PASSED,[G],NOW_PASSED),
    seek_solutions(NOW_PASSED,GOALS,UNSATISFIED_GOALS).
seek_solutions(UNSATISFIED_GOALS,[],UNSATISFIED_GOALS) :- !.

do_satisfy_goal(G) :-
        retractall(current_sat_goal(_)),
        asserta(current_sat_goal(G)),
        !,
        try_satisfy_goal(G, []).


try_satisfy_goal(G, INSTANCE_LIST) :-
        current_sat_goal(GOAL),
        satisfy_goal(GOAL),
        \+ is_in(GOAL, INSTANCE_LIST),
        !,
        (
           G=GOAL
        ;
           try_satisfy_goal(G, [GOAL|INSTANCE_LIST])
        ).


satisfy_goal(A=B) :-
    novars(A),
    simplify(A,X),
    A\=X,
    !,
    satisfy_goal(X=B).
satisfy_goal(A=B) :-
    novars(B),
    simplify(B,X),
    B\=X,
    !,
    satisfy_goal(A=X).

satisfy_goal(A<>B) :-
    novars(A),
    simplify(A,X),
    A\=X,
    !,
    satisfy_goal(X<>B).
satisfy_goal(A<>B) :-
    novars(B),
    simplify(B,X),
    B\=X,
    !,
    satisfy_goal(A<>X).

satisfy_goal(A>=B) :-
    novars(A),
    simplify(A,X),
    A\=X,
    !,
    satisfy_goal(X>=B).
satisfy_goal(A>=B) :-
    novars(B),
    simplify(B,X),
    B\=X,
    !,
    satisfy_goal(A>=X).

satisfy_goal(A<=B) :-
    novars(A),
    simplify(A,X),
    A\=X,
    !,
    satisfy_goal(X<=B).
satisfy_goal(A<=B) :-
    novars(B),
    simplify(B,X),
    B\=X,
    !,
    satisfy_goal(A<=X).

satisfy_goal(A>B) :-
    novars(A),
    simplify(A,X),
    A\=X,
    !,
    satisfy_goal(X>B).
satisfy_goal(A>B) :-
    novars(B),
    simplify(B,X),
    B\=X,
    !,
    satisfy_goal(A>X).

satisfy_goal(A<B) :-
    novars(A),
    simplify(A,X),
    A\=X,
    !,
    satisfy_goal(X<B).
satisfy_goal(A<B) :-
    novars(B),
    simplify(B,X),
    B\=X,
    !,
    satisfy_goal(A<X).

satisfy_goal(G) :-
    var(G),
    !,
    hyp(N,G),
    integer(N).

satisfy_goal(G) :-
    fact(G).

satisfy_goal(not G) :-
    nonvar(G),
    (
       G=(not H)
    ;
       G=(A=B),
       H=(A<>B)
    ;
       G=(A<>B),
       H=(A=B)
    ;
       G=(A>B),
       H=(A<=B)
    ;
       G=(A<B),
       H=(A>=B)
    ;
       G=(A>=B),
       H=(A<B)
    ;
       G=(A<=B),
       H=(A>B)
    ),
    satisfy_goal(H).

satisfy_goal(A and B) :-
    novars(A),
    !,
    infer(A),
    satisfy_goal(B).
satisfy_goal(A and B) :-
    novars(B),
    !,
    infer(B),
    satisfy_goal(A).
satisfy_goal(A and B) :-
    satisfy_goal(A),
    satisfy_goal(B).

satisfy_goal(A or B) :-
    novars(A),
    !,
    (
       infer(A)
    ;
       satisfy_goal(B)
    ).
satisfy_goal(A or B) :-
    novars(B),
    !,
    (
       infer(B)
    ;
       satisfy_goal(A)
    ).
satisfy_goal(A or _B) :-
    satisfy_goal(A).
satisfy_goal(_A or B) :-
    satisfy_goal(B).

satisfy_goal(A -> B) :-
    novars(A),
    !,
    (
       infer(not A)
    ;
       satisfy_goal(B)
    ).

satisfy_goal(A -> B) :-
    novars(B),
    !,
    (
       infer(B)
    ;
       satisfy_goal(not A)
    ).
satisfy_goal(A -> B) :-
    (
       satisfy_goal(not A)
    ;
       satisfy_goal(B)
    ).

satisfy_goal(A <-> B) :-
    satisfy_goal(A -> B),
    satisfy_goal(B -> A).

satisfy_goal(A=B) :-
    (
       novars(B),
       (
          var(A),
          intexp(B),
          \+ integer(B),
          A iss B
       ;
          A=B
       )
    ;
       novars(A),
       (
          var(B),
          intexp(A),
          \+ integer(A),
          B iss A
       ;
          B=A
       )
    ).

satisfy_goal(A<>B) :-
    (
       fact(A>B)
    ;
       fact(A<B)
    ).

satisfy_goal(A>B) :-
    satisfy_goal(A>=B),
    novars(A<>B),
    infer(A<>B).

satisfy_goal(A<B) :-
    satisfy_goal(A<=B),
    novars(A<>B),
    infer(A<>B).

satisfy_goal(A>=B) :-
    (
       fact(A>B)
    ;
       fact(B<A)
    ;
       satisfy_goal(A=B)
    ).

satisfy_goal(A<=B) :-
    (
       fact(A<B)
    ;
       fact(B>A)
    ;
       satisfy_goal(A=B)
    ).

satisfy_goal(X=A+B) :-
        novars(X),
        (
           novars(B),
           A=X-B
        ;
           novars(A),
           B=X-A
        ).

satisfy_goal(X=A-B) :-
        novars(X),
        (
           novars(B),
           A=X+B
        ;
           novars(A),
           B=A-X
        ).


/*** IS_CHOSEN_RULENAME(R) - R matches a rulename specified by user ***/
is_chosen_rulename(R) :-
        nonvar(R),
        !,
        command_arg(rulename, R),
        !.
is_chosen_rulename(R) :-
        command_arg(rulename, R).

/*** OK_TYPE_CLASSIFICATION(FORMULA,FILENAME,RULENAME) ***/
ok_type_classification(F,FNAME,RULENAME) :-
        type_requirements(F,FNAME,RULENAME,TYPES),
        has_type_classification_list(TYPES),
        !.


clear_up_could_facts :-
        retractall(could_infer(_)),
        retractall(could_not_infer(_)),
        !.
%###############################################################################
%END-OF-FILE
