(* Title:  Specify/pre-conds.sml

   Author: Walther Neuper 110226

   (c) due to copyrigh,t terms

*)

signature PRE_CONDITIONS =

sig

  type T

  type unchecked

  type unchecked_pos

  type checked

  type checked_pos

  type env_subst

  type env_eval

  type input

  val to_string : Proof.context -> T -> string

  val eval: Proof.context -> Rule_Set.T -> bool * term -> bool * term

  val environment: Model_Pattern.T -> Model_Def.i_model -> Env.T

  val make_environments: Model_Pattern.T -> Model_Def.i_model -> Env.T * (env_subst * env_eval)

  val make_envs_preconds: (Model_Pattern.single * Model_Def.i_model_single) list ->

    ((term * term) * (term * term)) list

  val check_pos: Proof.context -> Rule_Set.T -> unchecked_pos -> 

    Model_Pattern.T * Model_Def.i_model -> checked_pos

  val check_internal: Proof.context -> Model_Def.i_model -> (Pos.pos_ * References_Def.id)

    -> checked

  val check_envs: Proof.context -> Rule_Set.T -> unchecked -> Env.T * (env_subst * env_eval)

    -> checked

  val check: Proof.context -> Rule_Set.T -> unchecked ->

    Model_Pattern.T * Model_Def.i_model -> checked

(*/----- from isac_test for Minisubpbl*)

  val get_equal_descr: Model_Def.i_model -> Model_Pattern.single ->

    (Model_Pattern.single * Model_Def.i_model_single) list

  val unchecked_OLD_to: term list -> (term * Position.T) list

  val all_lhs_atoms: term list -> bool

  val handle_lists: term -> Model_Def.values -> Env.T

  val filter_variants': Model_Def.i_model -> Model_Def.variant -> Model_Def.i_model

  val switch_type: Model_Def.descriptor -> term list -> Model_Def.descriptor;

  val discern_feedback: term -> Model_Def.i_model_feedback ->

    ((term * term) * (term * term)) list

  val discern_typ: term -> Model_Def.descriptor * term list ->

    ((term * term) * (term * term)) list

  val mk_env_model: term -> Model_Def.i_model_feedback -> Env.T

  val make_env_model: (Model_Pattern.single * Model_Def.i_model_single) list -> Env.T

  val get_values: Model_Def.i_model_feedback -> Model_Def.values

  val get_descr_vnt: Model_Def.descriptor -> Model_Def.variants -> Model_Def.i_model ->

    Model_Def.i_model_single

  val get_descr_vnt': Model_Def.i_model_feedback -> Model_Def.variants -> O_Model.T ->

    O_Model.T

(*\----- from isac_test for Minisubpbl*)

\<^isac_test>\<open>

(**)

\<close>

end

(**)

structure Pre_Conds(**) : PRE_CONDITIONS(**) =

struct

(**)

open Model_Def

type T = Pre_Conds_Def.T;  (*= (bool * term) list;*)

type unchecked = term list

type unchecked_pos = (term * Position.T) list

type checked = bool * (bool * term) list

type checked_pos = bool * ((bool * (term * Position.T)) list)

(* 

  we have three kinds of Env.T in the specification-phase:

(*1*) Env.T produced by Pre_Conds.make_environments and required to create I_Model.T from

    Model_Pattern.T.

                       Env.T                  / (Constants, fixes)  in Model_Pattern.T

                       e.g.[(fixes, [r = 7])] |

                                              > (Constants, [<r = 7>]) in O/I_Model.T       *)

(*2*) type env_subst = Env.T (*               / 0 < fixes           in Problem.{where_, ...}

                       eg. [(fixes, r)]       |

                                              > 0 < r *)

(*3*) type env_eval =  Env.T (*               |

                       eg. [(r, 7)]           |

                                              > 0 < 7 \<longrightarrow> true

  (*1*) is required to produce (*2*) and (*3*); thus respective code is shifted to Pre_Conds.

  (*2*) and (*3*) are produced from Pre_Conds.make_environments by restricting to "#Given".

  There is a typing problem, probably to be solved by a language for Specification in the future:

  term <fixes> in (*1*) has type "bool list"

  term <fixes> in (*2*) has type "real". So for the transition from (*1*) to (*2..3*)

    fun switch_type is required.

  The transition requires better modelling by a novel language for Specification.

*)

type input = TermC.as_string list;

(** tools **)

fun to_str ctxt (b, t) = pair2str (bool2str b, UnparseC.term ctxt t);

fun to_string ctxt pres = strs2str' (map (linefeed o (to_str ctxt)) pres);

fun eval _ _ (false, where_) = (false, where_) (*NOT ALL Free's have been substituted*)

  | eval ctxt where_rls (true, where_) =

    if Rewrite.eval_true ctxt [where_] where_rls

    then (true, where_)

    else (false, where_);

(** find the maximal variant within an I_Model.T **)

fun get_equal_descr i_model (m_patt_single as (_, (descr, _))) =

  let

    val equal_descr = 

      filter (fn i_single => case get_descr_opt i_single of

          NONE => false

        | SOME descr' => descr' = descr) i_model

    in

      (map (pair m_patt_single) equal_descr)

    end

fun get_values (Cor (_, values)) = values

  | get_values (Syn _) = raise ERROR "Pre_Conds.get_values not for Syn"

  | get_values (Inc (_, values)) = values

  | get_values (Sup (_, values)) = values

(*

  get an appropriate (description, variant)-item from i_model, otherwise return empty item,

  i.e. this function produces items with Sup.

*)

fun get_descr_vnt descr vnts i_model =

  let

    val equal_descr = filter (fn (_, _, _, _, (feedb, _)) => case get_dscr_opt feedb of NONE => false

      | SOME descr' => if descr = descr' then true else false) i_model 

  in

    case filter (fn (_, vnts', _, _, _) => inter op= vnts' vnts <> []) equal_descr of

      [] => (0, [], false, "i_model_empty", (Sup (descr, []), Position.none))

    | items => Library.the_single items (*only applied to model_patt, which has each descr once*)

  end

(*

  get an appropriate (description, variant) item from o_model;

  called in case of item in met_imod is_empty_single

  (i.e. was not transferred pbl_mod by \<open>fun get_descr_vnt\<close>).

*)

fun get_descr_vnt' feedb vnts o_model =

  filter (fn (_, vnts', _, descr', _) =>

    case get_dscr_opt feedb of

      SOME descr => if descr' = descr andalso inter op= vnts' vnts <> [] then true else false

    | NONE => false) o_model

(*  all_lhs_atoms: term list -> bool*)

fun all_lhs_atoms ts = fold (curry and_) (map (fn t =>

  if can TermC.lhs t andalso not (TermC.is_num (TermC.lhs t))

  then TermC.is_atom (TermC.lhs t)

  else false) ts) true

fun handle_lists id values = [(id, values_to_present values)]

fun mk_env_model _ (Model_Def.Cor (_, [])) = []

  | mk_env_model id (Model_Def.Cor (_, ts)) = handle_lists id ts

  | mk_env_model _ (Model_Def.Syn _) = [] (*TODO handle correct list elements*)

  | mk_env_model _ (Model_Def.Inc (_, [])) = []

  | mk_env_model id (Model_Def.Inc (_, ts)) = handle_lists id ts

  | mk_env_model _ (Model_Def.Sup _) = []

fun make_env_model equal_descr_pairs =

  map (fn ((_, (_, id)), (_, _, _, _, (feedb, _)))

        => (mk_env_model id feedb)) equal_descr_pairs

  |> flat

fun switch_type descr [] = descr

  | switch_type (Free (id_string, _)) ts =

    Free (id_string, ts |> hd |> TermC.lhs |> type_of)

  | switch_type descr _ = raise ERROR ("switch_type undefined argument " ^

      quote (UnparseC.term (ContextC.for_ERROR ()) descr))

fun discern_typ _ (_, []) = []

  | discern_typ id (descr, ts) =

(*TODO.md "review (descriptor, ts)" REMOVE--------------------------------------\*)

    let

      val ts = if Model_Def.is_list_descr descr

        then if TermC.is_list (hd ts)

          then ts |> map TermC.isalist2list |> flat

          else ts

        else ts

    in

(*TODO.md "review (descriptor, ts)" REMOVE--------------------------------------/*)

  if Model_Pattern.typ_of_element descr = HOLogic.boolT andalso all_lhs_atoms ts

  then

    if length ts > 1

    then (writeln "model items of type 'bool' in lists with 'lengt ts > 1' NOT YET IMPLEMENTED";

      [])

    else [((switch_type id ts, TermC.lhs (hd ts)), 

           (TermC.lhs (hd ts), TermC.rhs (hd ts)))]

  else []

(*TODO.md "review (descriptor, ts)" REMOVE--------------------------------------\*)

    end

(*TODO.md "review (descriptor, ts)" REMOVE--------------------------------------/*)

(*Tnew*)

fun discern_feedback id (Model_Def.Cor (descr, ts)) = discern_typ id (descr, ts)

  | discern_feedback _ (Model_Def.Syn _) = [] (*TODO: handle correct elements*)

  | discern_feedback id (Model_Def.Inc (descr, ts)) = discern_typ id (descr, ts)

  | discern_feedback _ (Model_Def.Sup _) = []

fun make_envs_preconds equal_givens =

  map (fn ((_, (_, id)), (_, _, _, _, (feedb, _))) => discern_feedback id feedb) equal_givens

  |> flat

fun make_environments model_patt i_model =

  let

    val equal_descr_pairs = map (get_equal_descr i_model) model_patt

      |> flat

    val env_model = make_env_model equal_descr_pairs

    val equal_givens = filter (fn ((m_field, _), _) => m_field = "#Given") equal_descr_pairs

    val subst_eval_list = make_envs_preconds equal_givens

    val (env_subst, env_eval) = split_list subst_eval_list

  in

    (env_model, (env_subst, env_eval))

  end 

fun check_internal ctxt i_model (pbl_met, id) =

  let

    val (model, where_rls, where_) = case pbl_met of

        Pos.Pbl => let val {model, where_rls, where_, ...} = Problem.from_store ctxt id

          in (model, where_rls, where_) end

      | Pos.Met => let val {model, where_rls, where_, ...} = MethodC.from_store ctxt id

          in (model, where_rls, where_) end

      | _ => raise ERROR ("Pre_Conds.check_internal calles with " ^ Pos.pos_2str pbl_met)

    val (env_model, (env_subst, env_eval)) = make_environments model

      ((*filter (fn (_, _, _, m_field ,_) => m_field = "#Given")*) i_model)

    val pres_subst = map (TermC.subst_atomic_all env_subst) where_;

    val pres_subst_other = map (TermC.subst_atomic_all env_model) (map #2 pres_subst);

    val full_subst = if env_eval = [] then pres_subst_other

      else map (TermC.subst_atomic_all env_eval) (map #2 pres_subst_other)

    val evals = map (eval ctxt where_rls) full_subst

  in

      (foldl and_ (true, map fst evals), pres_subst_other)

  end;

(*extract one environment rom make_environments *)

fun environment model_patt i_model = make_environments model_patt i_model |> #1

(** check pre-conditions **)

fun check_pos ctxt where_rls where_ (model_patt, i_model) =

    let

      val (_, (_, env_eval)) = make_environments model_patt 

        (filter (fn (_, _, _, m_field ,_) => m_field = "#Given") i_model)

      val full_subst = if env_eval = []

        then map (fn (t, pos) => ((true, t), pos)) where_

        else map (fn (t, pos) => (TermC.subst_atomic_all env_eval t, pos)) where_

      val evals = map (fn ((bool_t), pos) => (eval ctxt where_rls bool_t, pos)) full_subst;

      val display = map (fn ((t, pos), ((bool, _), _)) => (bool, (t, pos))) (where_ ~~ evals)

    in

      (foldl and_ (true, map (fn ((bool, _: term), _: Position.T) => bool) evals), display)

    end;

(*takes the envs resulting from make_environments*)

fun check_envs ctxt where_rls where_ (env_model, (env_subst, env_eval)) =

  let

      val pres_subst = map (TermC.subst_atomic_all env_subst) where_;

      val pres_subst_other = map (TermC.subst_atomic_all env_model) (map #2 pres_subst);

      val full_subst = if env_eval = [] then pres_subst_other

        else map (TermC.subst_atomic_all env_eval) (map #2 pres_subst_other)

      val evals = map (eval ctxt where_rls) full_subst

  in

      (foldl and_ (true, map fst evals), pres_subst_other)

  end

(*expects the precondition from Problem, ie. needs substitution by env_model*)

fun check _ _ [] _  = (true, [])

  | check ctxt where_rls where_ (model_patt, i_model) =

    let

      val (env_model, (env_subst, env_eval)) = make_environments model_patt i_model

      val pres_subst = map (TermC.subst_atomic_all env_subst) where_;

      val pres_subst_other = map (TermC.subst_atomic_all env_model) (map #2 pres_subst);

      val full_subst = if env_eval = [] then pres_subst_other

        else map (TermC.subst_atomic_all env_eval) (map #2 pres_subst_other)

      val evals = map (eval ctxt where_rls) full_subst

    in

      (foldl and_ (true, map fst evals), pres_subst_other)

    end;

fun unchecked_OLD_to pres = map (fn t => (t, Position.none)) pres

(**)end(**)