(* 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

   val add: Tactic.T -> Istate_Def.T * Proof.context -> Calc.T -> Test_Out.T

   val add_general: Tactic.T -> Istate_Def.T * Proof.context -> Calc.T -> Test_Out.T

   val s_add_general: State_Steps.T ->

     Ctree.ctree * Pos.pos' list * Pos.pos' -> Ctree.ctree * Pos.pos' list * Pos.pos'

   val add_hard:

     theory -> Tactic.T -> Pos.pos' -> Ctree.ctree -> Test_Out.T

   val get_ruleset: 'a -> Pos.pos' -> Ctree.ctree ->

     string * ThyC.id * Rewrite_Ord.id * Rule_Def.rule_set * bool

   val get_eval: string -> Pos.pos' -> Ctree.ctree -> string * ThyC.id * Eval.ml

 \<^isac_test>\<open>

   val rew_info: Rule_Def.rule_set -> string * Rule_Def.rule_set * Eval.ml_from_prog list

 \<close>

 end

 (**)

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

 struct

 (**)

 (** get data from Calc.T **)

 (* the source is the parent node, either a problem or a Rule_Set (with inter_steps) *)

 fun rew_info (Rule_Def.Repeat {asm_rls, rew_ord = (rew_ord, _), calc = ca, ...}) =

     (rew_ord, asm_rls, ca)

   | rew_info (Rule_Set.Sequence {asm_rls, rew_ord = (rew_ord, _), calc = ca, ...}) =

     (rew_ord, asm_rls, ca)

   | rew_info (Rule_Set.Rrls {asm_rls, rew_ord = (rew_ord, _), calc = ca, ...}) =

     (rew_ord, asm_rls, ca)

   | rew_info rls = raise ERROR ("rew_info called with '" ^ Rule_Set.id rls ^ "'");

 fun get_ruleset _ (pos as (p, _)) pt = 

   let 

     val (pbl, p', rls', ctxt) = LItool.parent_node pt pos

   in                                                      

     if pbl

     then 

       let 

         val thy' = Ctree.get_obj Ctree.g_domID pt p'

         val {rew_ord, asm_rls, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt p')              

 	    in ("OK", thy', rew_ord, asm_rls, false) end

      else 

       let

         val thy' = Ctree.get_obj Ctree.g_domID pt (Ctree.par_pblobj pt p)

 		    val (rew_ord, asm_rls, _) = rew_info rls'

 		  in ("OK", thy', rew_ord, asm_rls, false) end

   end;

 fun get_eval scrop (pos as (p, _)) pt = 

   let

     val (pbl, p', rls', ctxt) =  LItool.parent_node pt pos

   in

     if pbl

     then

       let

         val thy' = Ctree.get_obj Ctree.g_domID pt p'

         val {calc = scr_isa_fns, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt p')

         val opt = assoc (scr_isa_fns, scrop)

 	    in

 	      case opt of

 	        SOME isa_fn => ("OK", thy', isa_fn)

 	      | NONE => ("applicable_in Calculate: unknown '" ^ scrop ^ "'", "", ("", Eval.ml_fun_empty))

 	    end

     else 

 		  let

 		    val thy' = Ctree.get_obj Ctree.g_domID pt (Ctree.par_pblobj pt p);

 		    val (_, _,(*_,*)scr_isa_fns) = rew_info rls'(*rls*)

 		  in

 		    case assoc (scr_isa_fns, scrop) of

 		      SOME isa_fn => ("OK",thy',isa_fn)

 		    | NONE => ("applicable_in Calculate: unknown '" ^ scrop ^ "'", "", ("", Eval.ml_fun_empty))

 		  end

   end;

 (** get context reliably at switch_specify_solve **)

 fun at_begin_program (is, Pos.Res) = last_elem is = 0

   | at_begin_program _ = false;

 (* strange special case at Apply_Method *)

 fun get_ctxt_from_PblObj pt (p_, Pos.Res) =

     let

       val pp = Ctree.par_pblobj pt p_ (*drops the "0"*)

       val {ctxt, ...} = Ctree.get_obj I pt pp |> Ctree.rep_specify_data

     in ctxt end

   | get_ctxt_from_PblObj _ _ = raise ERROR "get_ctxt_from_PblObj called by PrfObj or EmptyPtree";

 fun get_ctxt pt (p_, Pos.Pbl) =

     let

       val pp = Ctree.par_pblobj pt p_ (*drops the "0"*)

       val {ctxt, ...} = Ctree.get_obj I pt pp |> Ctree.rep_specify_data

     in ctxt end

   | get_ctxt pt pos =

     if at_begin_program pos

     then get_ctxt_from_PblObj pt pos

     else Ctree.get_ctxt pt pos

 (** Solve_Step.check **)

 (*

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

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

 *)

 fun check (Tactic.Apply_Method mI) (pt, (p, _)) =

       let

         val (dI, pI, probl, ctxt) = case Ctree.get_obj I pt p of

           Ctree.PblObj {origin = (_, (dI, pI, _), _), probl, ctxt, ...} => (dI, pI, probl, ctxt)

         | _ => raise ERROR "Solve_Step.check Apply_Method: uncovered case Ctree.get_obj"

         val {model, where_rls, where_, ...} = Problem.from_store ctxt pI

         val checked = Pre_Conds.check ctxt where_rls where_ (model, probl)

         val true_only = checked 

           |> snd

           |> map (fn (true, prec) => [prec] | (false, _) => [])

           |> flat

         val ctxt = if ContextC.is_empty ctxt (*only in case of input by user*)

           then dI 

             |> Know_Store.get_via_last_thy

             |> Proof_Context.init_global

             |> ContextC.insert_assumptions true_only

           else ctxt

       in

         Applicable.Yes (Tactic.Apply_Method' (mI, NONE, Istate_Def.empty (*filled later*), ctxt))

       end

   | check (Tactic.Calculate op_) (cs as (pt, pos)) =

       let 

         val (msg, thy', isa_fn) = get_eval op_ pos pt;

         val ctxt = Ctree.get_ctxt pt pos

         val f = Calc.current_formula cs;

       in

         if msg = "OK"

         then

     	    case Rewrite.calculate_ ctxt 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, pos)) = 

       let

         val (msg, _, ro, rls', _) = get_ruleset thm pos pt;

         val ctxt = Ctree.get_ctxt pt pos

         val thy = ctxt |> Proof_Context.theory_of

         val f = Calc.current_formula cs;

       in

         if msg = "OK" 

         then

           case Rewrite.rewrite_ ctxt (get_rew_ord ctxt ro) rls' false (snd thm) f of

             SOME (f',asm) =>

               Applicable.Yes (Tactic.Rewrite' (ThyC.id_of 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, pos as (p, _))) = 

       let 

         val pp = Ctree.par_pblobj pt p;

         val ctxt = Ctree.get_loc pt pos |> snd

         val thy = Proof_Context.theory_of ctxt

         val {rew_ord = ro', asm_rls = asm_rls, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt pp);

         val f = Calc.current_formula cs;

         val subst = Tactic.subst_adapt_to_type ctxt subs; 

       in 

         case Rewrite.rewrite_inst_ ctxt (get_rew_ord ctxt ro') asm_rls false subst (snd thm) f of

           SOME (f', asm) =>

             Applicable.Yes (Tactic.Rewrite_Inst' 

               (Context.theory_name thy, ro', asm_rls, false, subst, thm, f, (f', asm)))

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

       end

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

       let 

         val ctxt = Ctree.get_loc pt pos |> snd

         val thy' = ctxt |> Proof_Context.theory_of |> Context.theory_name

         val f = Calc.current_formula cs;

       in

         case Rewrite.rewrite_set_ ctxt false (get_rls ctxt rls) f of

           SOME (f', asm)

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

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

       end

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

       let 

         val ctxt = Ctree.get_loc pt pos |> snd

         val thy' = ctxt |> Proof_Context.theory_of |> Context.theory_name

         val f = Calc.current_formula cs;

     	  val subst = Tactic.subst_adapt_to_type ctxt subs; 

       in 

         case Rewrite.rewrite_set_inst_ ctxt false subst (get_rls ctxt rls) f of

           SOME (f', asm)

             => Applicable.Yes

                  (Tactic.Rewrite_Set_Inst' (thy', false, subst, get_rls ctxt rls, f, (f', asm)))

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

       end

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

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

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

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

       let

         val pp = Ctree.par_pblobj pt p

         val ctxt = Ctree.get_loc pt pos |> snd

         val f = Calc.current_formula cs;

 		    val {rew_ord, asm_rls, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt pp)

 		    val subte = Prog_Tac.Substitute_adapt_to_type' ctxt sube

 		    val ro = get_rew_ord ctxt rew_ord

 		  in

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

 		    then (*1*)

 		      let val f' = subst_atomic (Subst.T_from_string_eqs ctxt sube) f

 		      in if f = f'

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

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

 		      end

 		    else (*2*)

 		      case Rewrite.rewrite_terms_ ctxt ro asm_rls subte f of

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

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

 		  end

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

       let 

         val ctxt = Ctree.get_ctxt pt pos

         val thy = ctxt |> Proof_Context.theory_of

         val f = Calc.current_formula cs;

         val f' = UnparseC.term ctxt f

       in

         Applicable.Yes (Tactic.Tac_ (thy, f', id, f'))

       end

   | check (Tactic.Take str) (pt, pos) =

     let

       val ctxt = (*Solve_Step.*)get_ctxt pt pos

       val t = Prog_Tac.Take_adapt_to_type ctxt str

     in Applicable.Yes (Tactic.Take' t) end

   | 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 "Tactic.End_Trans not applicable at the beginning of a transitive sequence"

   | check Tactic.End_Proof' _ =

       Applicable.Yes Tactic.End_Proof'' (*TODO! check Post_Cond first !*)

   | check m (pt, pos) =

     let

       val ctxt = (*Solve_Step.*)get_ctxt pt pos

     in

       raise ERROR ("Solve_Step.check called for " ^ Tactic.input_to_string ctxt m)

     end;

 (** Solve_Step.add **)

 fun add (Tactic.Apply_Method' (_, topt, is, _)) (_, ctxt) (pt, pos as (p, _)) = 

     (case topt of 

       SOME t => 

         let val (pt, c) = Ctree.cappend_form pt p (is, ctxt) t

         in (pos, c, Test_Out.EmptyMout, pt) end

     | NONE => (pos, [], Test_Out.EmptyMout, pt))

   | add (Tactic.Take' t) (l as (_, ctxt)) (pt, (p, _)) = (* val (Take' t) = m; *)

     let

       val p =

         let val (ps, p') = split_last p (* no connex to prev.ppobj *)

 	      in if p' = 0 then ps @ [1] else p end

       val (pt, c) = Ctree.cappend_form pt p l t

     in

       ((p, Pos.Frm), c, Test_Out.FormKF (UnparseC.term ctxt t), pt)

     end

   | add (Tactic.Begin_Trans' t) (l as (_, ctxt)) (pt, (p, Pos.Frm)) =

     let

       val (pt, c) = Ctree.cappend_form pt p l t

       val pt = Ctree.update_branch pt p Ctree.TransitiveB (*040312*)

       (* replace the old PrfOjb ~~~~~ *)

       val p = (Pos.lev_on o Pos.lev_dn (* starts with [...,0] *)) p

       val (pt, c') = Ctree.cappend_form pt p l t (*FIXME.0402 same istate ???*)

     in

       ((p, Pos.Frm), c @ c', Test_Out.FormKF (UnparseC.term ctxt t), pt)

     end

   | add (Tactic.Begin_Trans' t) l (pt, (p, Pos.Res)) = 

     (*append after existing PrfObj    vvvvvvvvvvvvv*)

     add (Tactic.Begin_Trans' t) l (pt, (Pos.lev_on p, Pos.Frm))

   | add (Tactic.End_Trans' tasm) (l as (_, _(*ctxt*))) (pt, (p, _)) =

     let

       val p' = Pos.lev_up p

       val (pt, c) = Ctree.append_result pt p' l tasm Ctree.Complete

     in

       ((p', Pos.Res), c, Test_Out.FormKF "DUMMY" (*UnparseC.term ctxt t*), pt)

     end

   | add (Tactic.Rewrite_Inst' (_, _, _, _, subs', thm', f, (f', asm))) (is, ctxt) (pt, (p, _)) =

     let

       val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f

         (Tactic.Rewrite_Inst (Subst.T_to_input ctxt subs', thm')) (f',asm) Ctree.Complete;

       val pt = Ctree.update_branch pt p Ctree.TransitiveB

     in

       ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt f'), pt)

     end

  | add (Tactic.Rewrite' (_, _, _, _, thm', f, (f', asm))) (is, ctxt) (pt, (p, _)) =

    let

      val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f (Tactic.Rewrite thm') (f', asm) Ctree.Complete

      val pt = Ctree.update_branch pt p Ctree.TransitiveB

    in

     ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt f'), pt)

    end

   | add (Tactic.Rewrite_Set_Inst' (_, _, subs', rls', f, (f', asm))) (is, ctxt) (pt, (p, _)) =

     let

       val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f 

         (Tactic.Rewrite_Set_Inst (Subst.T_to_input ctxt subs', Rule_Set.id rls')) (f', asm) Ctree.Complete

       val pt = Ctree.update_branch pt p Ctree.TransitiveB

     in

       ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt f'), pt)

     end

   | add (Tactic.Rewrite_Set' (_, _, rls', f, (f', asm))) (is, ctxt) (pt, (p, _)) =

     let

       val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f 

         (Tactic.Rewrite_Set (Rule_Set.id rls')) (f', asm) Ctree.Complete

       val pt = Ctree.update_branch pt p Ctree.TransitiveB

     in

       ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt f'), pt)

     end

   | add (Tactic.Check_Postcond' (_, scval)) (l as (_, ctxt)) (pt, (p, _)) =

       let

         val (pt, c) = Ctree.append_result pt p l (scval, []) Ctree.Complete

       in

         ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt scval), pt)

       end

   | add (Tactic.Calculate' (_, op_, f, (f', _))) (l as (_, ctxt)) (pt, (p, _)) =

       let

         val (pt,c) = Ctree.cappend_atomic pt p l f (Tactic.Calculate op_) (f', []) Ctree.Complete

       in

         ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt f'), pt)

       end

   | add (Tactic.Check_elementwise' (consts, pred, (f', asm))) (l as (_, ctxt)) (pt, (p, _)) =

       let

         val (pt,c) = Ctree.cappend_atomic pt p l consts (Tactic.Check_elementwise pred) (f', asm) Ctree.Complete

       in

         ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt f'), pt)

       end

   | add (Tactic.Or_to_List' (ors, list)) (l as (_, ctxt)) (pt, (p, _)) =

       let

         val (pt,c) = Ctree.cappend_atomic pt p l ors Tactic.Or_to_List (list, []) Ctree.Complete

       in

         ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt list), pt)

       end

   | add (Tactic.Substitute' (_, _, subte, t, t')) (l as (_, ctxt)) (pt, (p, _)) =

       let

         val (pt, c) =

           Ctree.cappend_atomic pt p l t

             (Tactic.Substitute (Subst.eqs_to_input ctxt subte)) (t',[]) Ctree.Complete

         in ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term ctxt t'), pt) 

         end

   | add (Tactic.Tac_ (_, f, id, f')) l (pt, pos as (p, _)) =

       let

         val ctxt = Ctree.get_ctxt pt pos

         val (pt, c) = Ctree.cappend_atomic pt p l

           (ParseC.term_opt ctxt f |> the) (Tactic.Tac id) (ParseC.term_opt ctxt f' |> the, [])

             Ctree.Complete

       in

         ((p,Pos.Res), c, Test_Out.FormKF f', pt)

       end

   | add (Tactic.Subproblem' ((domID, pblID, metID), oris, hdl, fmz_, ctxt_specify, f))

       (l as (_, ctxt)) (pt, (p, _)) =

       let

   	    val (pt, c) = Ctree.cappend_problem pt p l (fmz_, (domID, pblID, metID))

   	      (oris, (domID, pblID, metID), hdl, ctxt_specify)

   	    val f = Syntax.string_of_term ctxt f

       in

         ((p, Pos.Pbl), c, Test_Out.FormKF f, pt)

       end

   | add m' (_, ctxt) (_, pos) =

       raise ERROR ("Solve_Step.add: not impl.for " ^ Tactic.string_of ctxt m' ^ " at " ^ Pos.pos'2str pos)

 (* LI switches between solve-phase and specify-phase *)

 fun add_general tac ic cs =

   if Tactic.for_specify' tac

   then Specify_Step.add tac ic cs

   else add tac ic cs

 (* the order of State_Steps is reversed: insert last element first  *)

 fun s_add_general [] ptp = ptp

   | s_add_general tacis (pt, c, _) = 

     let

       val (tacis', (_, tac_, (p, is))) = split_last tacis

 	    val (p', c', _, pt') = add_general tac_ is (pt, p)

     in

       s_add_general tacis' (pt', c@c', p')

     end

 (* a still undeveloped concept: do a calculation without LI *)

 fun add_hard _(*thy*) m' (p, p_) pt =

   let  

     val p = case p_ of

       Pos.Frm => p | Pos.Res => Pos.lev_on p

     | _ => raise ERROR ("generate_hard: call by " ^ Pos.pos'2str (p,p_))

   in

     add_general m' (Istate_Def.empty, ContextC.empty) (pt, (p, p_))

   end

 (**)end(**);