(* Title:  Specify/solve-step.sml

    Author: Walther Neuper

    (c) due to copyright terms

 Code for the solve-phase in analogy to structure Specify_Step for the specify-phase.

 *)

 signature SOLVE_STEP =

 sig

   val check: Tactic.input -> Calc.T -> Applicable.T

 (* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)

   (*NONE*)                                                     

 (*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )

   (*NONE*)                                                     

 ( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)

 end

 (**)

 structure Solve_Step(** ): SOLVE_STEP( **) =

 struct

 (**)

 (*

   check tactics (input by the user, mostly) for applicability

   and determine as much of the result of the tactic as possible initially.

 *)

 fun check (Tactic.Calculate op_) (cs as (pt, (p, _))) =

       let 

         val (msg, thy', isa_fn) = ApplicableOLD.from_pblobj_or_detail_calc op_ p pt;

         val f = Calc.current_formula cs;

       in

         if msg = "OK"

         then

     	    case Rewrite.calculate_ (ThyC.get_theory thy') isa_fn f of

     	      SOME (f', (id, thm))

     	        => Applicable.Yes (Tactic.Calculate' (thy', op_, f, (f', (id, thm))))

     	    | NONE => Applicable.No ("'calculate " ^ op_ ^ "' not applicable") 

         else Applicable.No msg                                              

       end

   | check (Tactic.Check_Postcond pI) (_, _) = (*TODO: only applicable, if evaluating to True*)

       Applicable.Yes (Tactic.Check_Postcond' (pI, TermC.empty))

   | check (Tactic.Check_elementwise pred) cs =

       let 

         val f = Calc.current_formula cs;

       in

         Applicable.Yes (Tactic.Check_elementwise' (f, pred, (f, [])))

       end

   | check Tactic.Empty_Tac _ = Applicable.No "Empty_Tac is not applicable"

   | check (Tactic.Free_Solve) _ = Applicable.Yes (Tactic.Free_Solve')

   | check Tactic.Or_to_List cs =

        let 

         val f = Calc.current_formula cs;

         val ls = Prog_Expr.or2list f;

       in

         Applicable.Yes (Tactic.Or_to_List' (f, ls))

       end

   | check (Tactic.Rewrite thm) (cs as (pt, (p, _))) = 

       let

         val (msg, thy', ro, rls', _) = ApplicableOLD.from_pblobj_or_detail_thm thm p pt;

         val thy = ThyC.get_theory thy';

         val f = Calc.current_formula cs;

       in

         if msg = "OK" 

         then

           case Rewrite.rewrite_ thy (Rewrite_Ord.assoc_rew_ord ro) rls' false (snd thm) f of

             SOME (f',asm) => Applicable.Yes (Tactic.Rewrite' (thy', ro, rls', false, thm, f, (f', asm)))

           | NONE => Applicable.No ((thm |> fst |> quote) ^ " not applicable") 

         else Applicable.No msg

       end

   | check (Tactic.Rewrite_Inst (subs, thm)) (cs as (pt, (p, _))) = 

       let 

         val pp = Ctree.par_pblobj pt p;

         val thy' = Ctree.get_obj Ctree.g_domID pt pp;

         val thy = ThyC.get_theory thy';

         val {rew_ord' = ro', erls = erls, ...} = Specify.get_met (Ctree.get_obj Ctree.g_metID pt pp);

         val f = Calc.current_formula cs;

         val subst = Subst.T_from_input thy subs; (*TODO: input requires parse _: _ -> _ option*)

       in 

         case Rewrite.rewrite_inst_ thy (Rewrite_Ord.assoc_rew_ord ro') erls false subst (snd thm) f of

           SOME (f', asm) =>

             Applicable.Yes (Tactic.Rewrite_Inst' (thy', ro', erls, false, subst, thm, f, (f', asm)))

         | NONE => Applicable.No (fst thm ^ " not applicable")

       end

   | check (Tactic.Rewrite_Set rls) (cs as (pt, (p, _))) =

       let 

         val pp = Ctree.par_pblobj pt p; 

         val thy' = Ctree.get_obj Ctree.g_domID pt pp;

         val f = Calc.current_formula cs;

       in

         case Rewrite.rewrite_set_ (ThyC.get_theory thy') false (assoc_rls rls) f of

           SOME (f', asm)

             => Applicable.Yes (Tactic.Rewrite_Set' (thy', false, assoc_rls rls, f, (f', asm)))

           | NONE => Applicable.No (rls ^ " not applicable")

       end

   | check (Tactic.Rewrite_Set_Inst (subs, rls)) (cs as (pt, (p, _))) =

       let 

         val pp = Ctree.par_pblobj pt p;

         val thy' = Ctree.get_obj Ctree.g_domID pt pp;

         val thy = ThyC.get_theory thy';

         val f = Calc.current_formula cs;

     	  val subst = Subst.T_from_input thy subs; (*TODO: input requires parse _: _ -> _ option*)

       in 

         case Rewrite.rewrite_set_inst_ thy false subst (assoc_rls rls) f of

           SOME (f', asm)

             => Applicable.Yes (Tactic.Rewrite_Set_Inst' (thy', false, subst, assoc_rls rls, f, (f', asm)))

         | NONE => Applicable.No (rls ^ " not applicable")

       end

   | check (Tactic.Subproblem (domID, pblID)) (_, _) = 

       Applicable.Yes (Tactic.Subproblem' ((domID, pblID, Method.id_empty), [], 

 			  TermC.empty, [], ContextC.empty, Auto_Prog.subpbl domID pblID))

    | check (Tactic.Substitute sube) (cs as (pt, (p, _))) =

       let

         val pp = Ctree.par_pblobj pt p

         val thy = ThyC.get_theory (Ctree.get_obj Ctree.g_domID pt pp)

         val f = Calc.current_formula cs;

 		    val {rew_ord', erls, ...} = Specify.get_met (Ctree.get_obj Ctree.g_metID pt pp)

 		    val subte = Subst.input_to_terms sube (*TODO: input requires parse _: _ -> _ option*)

 		    val subst = Subst.T_from_string_eqs thy sube

 		    val ro = Rewrite_Ord.assoc_rew_ord rew_ord'

 		  in

 		    if foldl and_ (true, map TermC.contains_Var subte)

 		    then (*1*)

 		      let val f' = subst_atomic subst f

 		      in if f = f'

 		        then Applicable.No (Subst.string_eqs_to_string sube ^ " not applicable")

 		        else Applicable.Yes (Tactic.Substitute' (ro, erls, subte, f, f'))

 		      end

 		    else (*2*)

 		      case Rewrite.rewrite_terms_ thy ro erls subte f of

 		        SOME (f', _) =>  Applicable.Yes (Tactic.Substitute' (ro, erls, subte, f, f'))

 		      | NONE => Applicable.No (Subst.string_eqs_to_string sube ^ " not applicable")

 		  end

   | check (Tactic.Tac id) (cs as (pt, (p, _))) =

       let 

         val pp = Ctree.par_pblobj pt p; 

         val thy' = Ctree.get_obj Ctree.g_domID pt pp;

         val thy = ThyC.get_theory thy';

         val f = Calc.current_formula cs;

       in case id of

         "subproblem_equation_dummy" =>

     	  if TermC.is_expliceq f

     	  then Applicable.Yes (Tactic.Tac_ (thy, UnparseC.term f, id, "subproblem_equation_dummy (" ^ UnparseC.term f ^ ")"))

     	  else Applicable.No "applicable only to equations made explicit"

       | "solve_equation_dummy" =>

     	  let val (id', f') = ApplicableOLD.split_dummy (UnparseC.term f);

     	  in

     	    if id' <> "subproblem_equation_dummy"

     	    then Applicable.No "no subproblem"

     	    else if (ThyC.to_ctxt thy, f') |-> TermC.parseNEW |> the |> TermC.is_expliceq

     		    then Applicable.Yes (Tactic.Tac_ (thy, UnparseC.term f, id, "[" ^ f' ^ "]"))

     		    else error ("Solve_Step.check: f= " ^ f')

         end

       | _ => Applicable.Yes (Tactic.Tac_ (thy, UnparseC.term f, id, UnparseC.term f))

       end

   | check (Tactic.Take str) _ = Applicable.Yes (Tactic.Take' (TermC.str2term str)) (* always applicable ?*)

   | check (Tactic.Begin_Trans) cs =

       Applicable.Yes (Tactic.Begin_Trans' (Calc.current_formula cs))

   | check (Tactic.End_Trans) (pt, (p, p_)) = (*TODO: check parent branches*)

     if p_ = Pos.Res 

 	  then Applicable.Yes (Tactic.End_Trans' (Ctree.get_obj Ctree.g_result pt p))

     else Applicable.No "'End_Trans' is not applicable at the beginning of a transitive sequence"

   | check Tactic.End_Proof' _ = Applicable.Yes Tactic.End_Proof''

   | check m _ = raise ERROR ("Solve_Step.check called for " ^ Tactic.input_to_string m);

 (**)end(**);