section \<open>Basic Parametricity Reasoning\<close>
theory Param_Tool
imports Relators
begin

  subsection \<open>Auxiliary Lemmas\<close>
  lemma tag_both: "\<lbrakk> (Let x f,Let x' f')\<in>R \<rbrakk> \<Longrightarrow> (f x,f' x')\<in>R" by simp
  lemma tag_rhs: "\<lbrakk> (c,Let x f)\<in>R \<rbrakk> \<Longrightarrow> (c,f x)\<in>R" by simp
  lemma tag_lhs: "\<lbrakk> (Let x f,a)\<in>R \<rbrakk> \<Longrightarrow> (f x,a)\<in>R" by simp

  lemma tagged_fun_relD_both:
    "\<lbrakk> (f,f')\<in>A\<rightarrow>B; (x,x')\<in>A \<rbrakk> \<Longrightarrow> (Let x f,Let x' f')\<in>B"
    and tagged_fun_relD_rhs: "\<lbrakk> (f,f')\<in>A\<rightarrow>B; (x,x')\<in>A \<rbrakk> \<Longrightarrow> (f x,Let x' f')\<in>B"
    and tagged_fun_relD_lhs: "\<lbrakk> (f,f')\<in>A\<rightarrow>B; (x,x')\<in>A \<rbrakk> \<Longrightarrow> (Let x f,f' x')\<in>B"
    and tagged_fun_relD_none: "\<lbrakk> (f,f')\<in>A\<rightarrow>B; (x,x')\<in>A \<rbrakk> \<Longrightarrow> (f x,f' x')\<in>B"
    by (simp_all add: fun_relD)

  subsection \<open>ML-Setup\<close>

  ML \<open>
    signature PARAMETRICITY = sig
      type param_ruleT = {
        lhs: term,
        rhs: term,
        R: term,
        rhs_head: term,
        arity: int
      }

      val dest_param_term: term -> param_ruleT
      val dest_param_rule: thm -> param_ruleT
      val dest_param_goal: int -> thm -> param_ruleT

      val safe_fun_relD_tac: Proof.context -> tactic'

      val adjust_arity: int -> thm -> thm
      val adjust_arity_tac: int -> Proof.context -> tactic'
      val unlambda_tac: Proof.context -> tactic'
      val prepare_tac: Proof.context -> tactic'

      val fo_rule: thm -> thm

      (*** Basic tactics ***)
      val param_rule_tac: Proof.context -> thm -> tactic'
      val param_rules_tac: Proof.context -> thm list -> tactic'
      val asm_param_tac: Proof.context -> tactic'

      (*** Nets of parametricity rules ***)
      type param_net
      val net_empty: param_net
      val net_add: thm -> param_net -> param_net
      val net_del: thm -> param_net -> param_net
      val net_add_int: Context.generic -> thm -> param_net -> param_net
      val net_del_int: Context.generic -> thm -> param_net -> param_net
      val net_tac: param_net -> Proof.context -> tactic'

      (*** Default parametricity rules ***)
      val add_dflt: thm -> Context.generic -> Context.generic
      val add_dflt_attr: attribute
      val del_dflt: thm -> Context.generic -> Context.generic
      val del_dflt_attr: attribute
      val get_dflt: Proof.context -> param_net

      (** Configuration **)
      val cfg_use_asm: bool Config.T
      val cfg_single_step: bool Config.T

      (** Setup **)
      val setup: theory -> theory
    end

    structure Parametricity : PARAMETRICITY = struct
      type param_ruleT = {
        lhs: term,
        rhs: term,
        R: term,
        rhs_head: term,
        arity: int
      }

      fun dest_param_term t =
        case
          strip_all_body t |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop
        of
          @{mpat "(?lhs,?rhs):?R"} => let
            val (rhs_head,arity) =
              case strip_comb rhs of
                (c as Const _,l) => (c,length l)
              | (c as Free _,l) => (c,length l)
              | (c as Abs _,l) => (c,length l)
              | _ => raise TERM ("dest_param_term: Head",[t])
          in
            { lhs = lhs, rhs = rhs, R=R, rhs_head = rhs_head, arity = arity }
          end
        | t => raise TERM ("dest_param_term: Expected (_,_):_",[t])

      val dest_param_rule = dest_param_term o Thm.prop_of
      fun dest_param_goal i st =
        if i > Thm.nprems_of st then
          raise THM ("dest_param_goal",i,[st])
        else
          dest_param_term (Logic.concl_of_goal (Thm.prop_of st) i)

      fun safe_fun_relD_tac ctxt = let
        fun t a b = fo_resolve_tac [a] ctxt THEN' resolve_tac ctxt [b]
      in
        DETERM o (
          t @{thm tag_both} @{thm tagged_fun_relD_both} ORELSE'
          t @{thm tag_rhs} @{thm tagged_fun_relD_rhs} ORELSE'
          t @{thm tag_lhs} @{thm tagged_fun_relD_lhs} ORELSE'
          resolve_tac ctxt @{thms tagged_fun_relD_none}
        )
      end

      fun adjust_arity i thm =
        if i = 0 then thm
        else if i<0 then funpow (~i) (fn thm => thm RS @{thm fun_relI}) thm
        else funpow i (fn thm => thm RS @{thm fun_relD}) thm

      fun NTIMES k tac =
        if k <= 0 then K all_tac
        else tac THEN' NTIMES (k-1) tac

      fun adjust_arity_tac n ctxt i st =
        (if n = 0 then K all_tac
        else if n>0 then NTIMES n (DETERM o resolve_tac ctxt @{thms fun_relI})
        else NTIMES (~n) (safe_fun_relD_tac ctxt)) i st

      fun unlambda_tac ctxt i st =
        case try (dest_param_goal i) st of
          NONE => Seq.empty
        | SOME g => let
            val n = Term.strip_abs (#rhs_head g) |> #1 |> length
          in NTIMES n (resolve_tac ctxt @{thms fun_relI}) i st end

      fun prepare_tac ctxt =
        Subgoal.FOCUS (K (PRIMITIVE (Drule.eta_contraction_rule))) ctxt
        THEN' unlambda_tac ctxt

      fun could_param_rl rl i st =
        if i > Thm.nprems_of st then NONE
        else (
          case (try (dest_param_goal i) st, try dest_param_term rl) of
            (SOME g, SOME r) =>
              if Term.could_unify (#rhs_head g, #rhs_head r) then
                SOME (#arity r - #arity g)
              else NONE
          | _ => NONE
        )

      fun param_rule_tac_aux ctxt rl i st =
        case could_param_rl (Thm.prop_of rl) i st of
          SOME adj => (adjust_arity_tac adj ctxt THEN' resolve_tac ctxt [rl]) i st
        | _ => Seq.empty

      fun param_rule_tac ctxt rl =
        prepare_tac ctxt THEN' param_rule_tac_aux ctxt rl

      fun param_rules_tac ctxt rls =
        prepare_tac ctxt THEN' FIRST' (map (param_rule_tac_aux ctxt) rls)

      fun asm_param_tac_aux ctxt i st =
        if i > Thm.nprems_of st then Seq.empty
        else let
          val prems = Logic.prems_of_goal (Thm.prop_of st) i |> tag_list 1

          fun tac (n,t) i st = case could_param_rl t i st of
            SOME adj => (adjust_arity_tac adj ctxt THEN' rprem_tac n ctxt) i st
          | NONE => Seq.empty
        in
          FIRST' (map tac prems) i st
        end

      fun asm_param_tac ctxt = prepare_tac ctxt THEN' asm_param_tac_aux ctxt

      type param_net = (param_ruleT * thm) Item_Net.T

      local
        val param_get_key = single o #rhs_head o #1
      in
        val net_empty = Item_Net.init (Thm.eq_thm o apply2 #2) param_get_key
      end

      fun wrap_pr_op f context thm = case try (`dest_param_rule) thm of
        NONE =>
          let
            val msg = "Ignoring invalid parametricity theorem: "
              ^ Thm.string_of_thm (Context.proof_of context) thm
            val _ = warning msg
          in I end
      | SOME p => f p

      val net_add_int = wrap_pr_op Item_Net.update
      val net_del_int = wrap_pr_op Item_Net.remove

      val net_add = Item_Net.update o `dest_param_rule
      val net_del = Item_Net.remove o `dest_param_rule

      fun net_tac_aux net ctxt i st =
        if i > Thm.nprems_of st then
          Seq.empty
        else
          let
            val g = dest_param_goal i st
            val rls = Item_Net.retrieve net (#rhs_head g)

            fun tac (r,thm) =
              adjust_arity_tac (#arity r - #arity g) ctxt
              THEN' DETERM o resolve_tac ctxt [thm]
          in
            FIRST' (map tac rls) i st
          end

      fun net_tac net ctxt = prepare_tac ctxt THEN' net_tac_aux net ctxt

      structure dflt_rules = Generic_Data (
        type T = param_net
        val empty = net_empty
        val extend = I
        val merge = Item_Net.merge
      )

      fun add_dflt thm context = dflt_rules.map (net_add_int context thm) context
      fun del_dflt thm context = dflt_rules.map (net_del_int context thm) context
      val add_dflt_attr = Thm.declaration_attribute add_dflt
      val del_dflt_attr = Thm.declaration_attribute del_dflt

      val get_dflt = dflt_rules.get o Context.Proof

      val cfg_use_asm =
        Attrib.setup_config_bool @{binding param_use_asm} (K true)
      val cfg_single_step =
        Attrib.setup_config_bool @{binding param_single_step} (K false)

      local
        open Refine_Util

        val param_modifiers =
          [Args.add -- Args.colon >> K (Method.modifier add_dflt_attr \<^here>),
           Args.del -- Args.colon >> K (Method.modifier del_dflt_attr \<^here>),
           Args.$$$ "only" -- Args.colon >>
            K {init = Context.proof_map (dflt_rules.map (K net_empty)),
                attribute = add_dflt_attr, pos = \<^here>}]

        val param_flags =
           parse_bool_config "use_asm" cfg_use_asm
        || parse_bool_config "single_step" cfg_single_step

      in

        val parametricity_method =
          parse_paren_lists param_flags |-- Method.sections param_modifiers >>
          (fn _ => fn ctxt =>
            let
              val net2 = get_dflt ctxt
              val asm_tac =
                if Config.get ctxt cfg_use_asm then
                  asm_param_tac ctxt
                else K no_tac

              val RPT =
                if Config.get ctxt cfg_single_step then I
                else REPEAT_ALL_NEW_FWD

            in
              SIMPLE_METHOD' (
                RPT (
                  (assume_tac ctxt
                    ORELSE' net_tac net2 ctxt
                    ORELSE' asm_tac)
                )
              )
            end
          )
      end

      fun fo_rule thm = case Thm.concl_of thm of
            @{mpat "Trueprop ((_,_)\<in>_\<rightarrow>_)"} => fo_rule (thm RS @{thm fun_relD})
          | _ => thm

      val param_fo_attr = Scan.succeed (Thm.rule_attribute [] (K fo_rule))

      val setup = I
        #> Attrib.setup @{binding param}
            (Attrib.add_del add_dflt_attr del_dflt_attr)
            "declaration of parametricity theorem"
        #> Global_Theory.add_thms_dynamic (@{binding param},
             map #2 o Item_Net.content o dflt_rules.get)
        #> Method.setup @{binding parametricity} parametricity_method
             "Parametricity solver"
        #> Attrib.setup @{binding param_fo} param_fo_attr
             "Parametricity: Rule in first-order form"

    end
\<close>

  setup Parametricity.setup

  subsection \<open>Convenience Tools\<close>

  ML \<open>
    (* Prefix p_ or wrong type supresses generation of relAPP *)

    fun cnv_relAPP t = let
      fun consider (Var ((name,_),T)) =
        if String.isPrefix "p_" name then false
        else (
          case T of
            Type(@{type_name set},[Type(@{type_name prod},_)]) => true
          | _ => false)
      | consider _ = true

      fun strip_rcomb u : term * term list =
        let
          fun stripc (x as (f$t, ts)) =
            if consider t then stripc (f, t::ts) else x
          | stripc  x =  x
        in  stripc(u,[])  end;

      val (f,a) = strip_rcomb t
    in
      Relators.list_relAPP a f
    end

    fun to_relAPP_conv ctxt = Refine_Util.f_tac_conv ctxt
      cnv_relAPP
      (ALLGOALS (simp_tac
        (put_simpset HOL_basic_ss ctxt addsimps @{thms relAPP_def})))

    val to_relAPP_attr = Thm.rule_attribute [] (fn context => let
      val ctxt = Context.proof_of context
    in
      Conv.fconv_rule (Conv.arg1_conv (to_relAPP_conv ctxt))
    end)
\<close>

  attribute_setup to_relAPP = \<open>Scan.succeed (to_relAPP_attr)\<close>
    "Convert relator definition to prefix-form"

end


(* A particular case of the second calculus, with policy constant on types: *)
theory Mcalc2C
imports Mcalc2
begin

subsection\<open>Constant policy on types\<close>

text\<open>Currently our soundness proof only covers the case of the calculus
having different extension policies for different predicates, but not
for differnt types versus the same predicate. This is sufficient for our purpose
of proving soundness of the guard encodings.\<close>

locale ProblemIkPolMcalc2C =
ProblemIkPolMcalc2 wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and pol and grdOf
+ assumes pol_ct: "pol \<sigma>1 P = pol \<sigma>2 P"

context ProblemIkPolMcalc2C begin

definition "polC \<equiv> pol any"

lemma pol_polC: "pol \<sigma> P = polC P"
unfolding polC_def using pol_ct by auto

lemma nv2L_simps[simp]:
"nv2L (Pos (Pr p Tl)) = (case polC p of Fext \<Rightarrow> \<Union> (set (map nv2T Tl)) |_ \<Rightarrow> {})"
"nv2L (Neg (Pr p Tl)) = (case polC p of Text \<Rightarrow> \<Union> (set (map nv2T Tl)) |_ \<Rightarrow> {})"
by (auto split: epol.splits simp: pol_polC)

declare nv2L.simps(3,4)[simp del]

lemma isGuard_simps[simp]:
"isGuard x (Pos (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> (set (map nv2T Tl)) \<and> polC p = Text"
"isGuard x (Neg (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> (set (map nv2T Tl)) \<and> polC p = Fext"
by (auto simp: pol_polC)

declare isGuard.simps(3,4)[simp del]

end (* context  ProblemIkPolMcalc2 *)

locale ModelIkPolMcalc2C =
ModelIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp intT intF intP +
ProblemIkPolMcalc2C wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp pol and grdOf and intT and intF and intP

subsection\<open>Extension of a structure to an infinte structure
by adding indistinguishable elements\<close>

context ModelIkPolMcalc2C begin

(* The projection from univ to a structure: *)
definition proj where "proj \<sigma> a \<equiv> if intT \<sigma> a then a else pickT \<sigma>"

lemma intT_proj[simp]: "intT \<sigma> (proj \<sigma> a)"
unfolding proj_def using pickT by auto

lemma proj_id[simp]: "intT \<sigma> a \<Longrightarrow> proj \<sigma> a = a"
unfolding proj_def by auto

lemma map_proj_id[simp]:
assumes "list_all2 intT \<sigma>l al"
shows "map2 proj \<sigma>l al = al"
apply(rule nth_equalityI)
using assms unfolding list_all2_length by auto

lemma surj_proj:
assumes "intT \<sigma> a"   shows "\<exists> b. proj \<sigma> b = a"
using assms by (intro exI[of _ a]) simp

definition "I_intT \<sigma> (a::univ) \<equiv> infTp \<sigma> \<longrightarrow> intT \<sigma> a"
definition "I_intF f al \<equiv> intF f (map2 proj (arOf f) al)"
definition
"I_intP p al \<equiv>
 case polC p of
   Cext \<Rightarrow> intP p (map2 proj (parOf p) al)
  |Text \<Rightarrow> if list_all2 intT (parOf p) al then intP p al else True
  |Fext \<Rightarrow> if list_all2 intT (parOf p) al then intP p al else False"

lemma not_infTp_I_intT[simp]: "\<not> infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a"
unfolding I_intT_def by simp

lemma infTp_I_intT[simp]: "infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a = intT \<sigma> a"
unfolding I_intT_def by simp

lemma NE_I_intT: "NE (I_intT \<sigma>)"
using NE_intT by (cases "infTp \<sigma>", auto)

lemma I_intP_Cext[simp]:
"polC p = Cext \<Longrightarrow> I_intP p al = intP p (map2 proj (parOf p) al)"
unfolding I_intP_def by simp

lemma I_intP_Text_imp[simp]:
assumes "polC p = Text" and "intP p al"
shows "I_intP p al"
using assms unfolding I_intP_def by auto

lemma I_intP_Fext_imp[simp]:
assumes "polC p = Fext" and "\<not> intP p al"
shows "\<not> I_intP p al"
using assms unfolding I_intP_def by (cases "list_all2 intT (parOf p) al", auto)

lemma I_intP_intT[simp]:
assumes "list_all2 intT (parOf p) al"
shows "I_intP p al = intP p al"
using assms unfolding I_intP_def by (cases "polC p") auto

lemma I_intP_Text_not_intT[simp]:
assumes "polC p = Text" and "\<not> list_all2 intT (parOf p) al"
shows "I_intP p al"
using assms unfolding I_intP_def by auto

lemma I_intP_Fext_not_intT[simp]:
assumes "polC p = Fext" and "\<not> list_all2 intT (parOf p) al"
shows "\<not> I_intP p al"
using assms unfolding I_intP_def by auto

lemma I_intF:
assumes f: "wtFsym f" and al: "list_all2 I_intT (arOf f) al"
shows "I_intT (resOf f) (I_intF f al)"
unfolding I_intT_def I_intF_def apply safe apply(rule intF[OF f])
using al unfolding list_all2_length by auto

lemma Tstruct_I_intT: "Tstruct I_intT"
by standard (rule NE_I_intT)

lemma inf_I_intT: "infinite {a. I_intT \<sigma> a}"
by (cases "infTp \<sigma>", auto)

lemma InfStruct: "IInfStruct I_intT I_intF I_intP"
apply standard using NE_I_intT I_intF Tstruct_I_intT inf_I_intT by auto

end (* context ModelIkPolMcalc2C *)

sublocale ModelIkPolMcalc2C < InfStruct where
intT = I_intT and intF = I_intF and intP = I_intP
using InfStruct .

subsection\<open>The soundness of the calculus\<close>

(* In what follows, ``Ik" stands for the original
(augmented with infiniteness-knowledge)
and ``I" for the infinite structure constructed from it
through the above sublocale statement. *)

context ModelIkPolMcalc2C begin
(* The environment translation along the projection: *)
definition "transE \<xi> \<equiv> \<lambda> x. proj (tpOfV x) (\<xi> x)"

lemma wtE_transE[simp]: "I.wtE \<xi> \<Longrightarrow> Ik.wtE (transE \<xi>)"
unfolding Ik.wtE_def I.wtE_def transE_def by auto

abbreviation "Ik_intT \<equiv> intT"
abbreviation "Ik_intF \<equiv> intF"
abbreviation "Ik_intP \<equiv> intP"

lemma Ik_intT_int:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>"
and nv2T: "infTp (Ik.tpOf T) \<or> (\<forall> x \<in> nv2T T. tpOfV x \<noteq> Ik.tpOf T)"
shows "Ik_intT (Ik.tpOf T) (I.int \<xi> T)"
proof(cases "\<exists> x. T = Var x")
  case True then obtain x where T: "T = Var x" by auto
  show ?thesis proof(cases "infTp (tpOf T)")
    case True thus ?thesis using T using wtE_transE[OF \<xi>]
    by (metis I.wt_int I_intT_def \<xi> wt)
  next
    case False hence "\<forall> x \<in> nv2T T. tpOfV x \<noteq> tpOf T" using nv2T by auto
    hence "Ik.full (tpOf T)" using T by (cases T, simp_all)
    thus ?thesis unfolding Ik.full_def by simp
  qed
next
  case False hence nonVar: "\<not> (\<exists> x. T = Var x)" by (cases T, auto)
  thus ?thesis using nonVar wt apply(induct T, force)
  unfolding I_intF_def tpOf.simps int.simps
  apply(rule Ik.intF, simp) apply(rule listAll2_map2I) by auto
qed

lemma int_transE_proj:
  assumes wt: "Ik.wt T"
  shows "Ik.int (transE \<xi>) T = proj (tpOf T) (I.int \<xi> T)"
  using wt proof (induct T)
  case (Fn f Tl)
  have 0: "Ik_intT (resOf f) (I_intF f (map (int \<xi>) Tl))" (is "Ik_intT ?\<sigma> ?a")
    unfolding I_intF_def apply(rule Ik.intF)
    using Fn unfolding list_all2_length list_all_iff by auto
  have 1: "proj ?\<sigma> ?a = ?a" using proj_id[OF 0] .
  show ?case
    using [[unfold_abs_def = false]]
    unfolding Ik.int.simps int.simps tpOf.simps 1
    unfolding I_intF_def apply(rule arg_cong[of _ _ "intF f"])
  proof (rule nth_equalityI)
    have l[simp]: "length (arOf f) = length Tl" using Fn by simp
    fix i assume "i < length (map (Ik.int (transE \<xi>)) Tl)"
    hence i[simp]: "i < length Tl" by simp
    have 0: "arOf f ! i = tpOf (Tl ! i)" using Fn by simp
    have [simp]: "Ik.int (transE \<xi>) (Tl ! i) = proj (arOf f ! i) (I.int \<xi> (Tl ! i))"
      unfolding 0 using Fn by (auto simp: list_all_length transE_def)
    show "map (Ik.int (transE \<xi>)) Tl ! i =
          map2 proj (arOf f) (map (I.int \<xi>) Tl) ! i"
      using Fn unfolding list_all_length by simp
  qed(insert Fn, simp)
qed simp

lemma int_transE_nv2T:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>"
and nv2T: "infTp (Ik.tpOf T) \<or> (\<forall> x \<in> nv2T T. tpOfV x \<noteq> Ik.tpOf T)"
shows "Ik.int (transE \<xi>) T = I.int \<xi> T"
unfolding int_transE_proj[OF wt] apply(rule proj_id)
using Ik_intT_int[OF wt \<xi> nv2T] .

lemma isGuard_not_satL_intT:
assumes wtL: "Ik.wtL l"
and (* crucial hypothesis--the essence of guarding:*) ns: "\<not> I.satL \<xi> l"
and g: "isGuard x l" and \<xi>: "I.wtE \<xi>"
shows "Ik_intT (tpOfV x) (\<xi> x)" (is "Ik_intT ?\<sigma> (\<xi> x)")
(* "proj \<sigma> (\<xi> \<sigma> x) = \<xi> \<sigma> x" *)
(* "Ik.int (transE \<xi>) (Var \<sigma> x) = I.int \<xi> (Var \<sigma> x)" *)
proof(cases l)
  case (Pos at)  show ?thesis proof(cases at)
    case (Pr p Tl)
    then obtain T where Tin: "T \<in> set Tl" and x: "x \<in> nv2T T" and pol: "polC p = Text"
    using g unfolding Pos Pr by auto
    hence T: "T = Var x" by (simp add: in_nv2T)
    obtain i where i: "i < length Tl" and Ti: "T = Tl!i" using Tin
    by (metis in_set_conv_nth)
    hence 0 : "wt T" "parOf p ! i = ?\<sigma>" using wtL unfolding Pos Pr T
    apply (simp_all add: list_all_iff) by (metis T x in_nv2T tpOf.simps)
    have "list_all2 Ik_intT (parOf p) (map (I.int \<xi>) Tl)" (is ?phi)
    using ns unfolding Pos Pr using pol by (cases ?phi, auto)
    hence "Ik_intT ?\<sigma> (I.int \<xi> T)"
    using ns 0 i Ti unfolding Pos Pr by (auto simp add: list_all2_length nth_map)
    thus ?thesis unfolding T by simp
  qed(insert g, unfold Pos, simp)
next
  case (Neg at)  show ?thesis proof(cases at)
    case (Eq T1 T2)
    hence 0: "T1 = Var x \<or> T2 = Var x" using g unfolding Neg by auto
    hence wt1: "Ik.wt T1" "Ik.tpOf T1 = tpOfV x"
    and wt2: "Ik.wt T2" "Ik.tpOf T2 = tpOfV x"
    using wtL unfolding Neg Eq by auto
    have eq: "I.int \<xi> T1 = I.int \<xi> T2" using ns unfolding Neg Eq by simp
    show ?thesis proof(cases "T1 = Var x")
      case True note T1 = True obtain f Tl where "T2 = Fn f Tl"
      using g T1 Eq unfolding Neg by auto
      hence "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nv2T T2. tpOfV x \<noteq> \<sigma>)" by auto
      hence 1: "I.int \<xi> T2 = Ik.int (transE \<xi>) T2" using int_transE_nv2T wt2 \<xi> by auto
      have "Ik_intT ?\<sigma> (I.int \<xi> T1)" unfolding eq 1 using wt2 \<xi> Ik.wt_int by force
      thus ?thesis unfolding T1 by simp
    next
      case False then obtain f Tl where T2: "T2 = Var x" and "T1 = Fn f Tl"
      using Eq Neg g by auto
      hence "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nv2T T1. tpOfV x \<noteq> \<sigma>)" by simp
      hence 1: "I.int \<xi> T1 = Ik.int (transE \<xi>) T1" using int_transE_nv2T wt1 \<xi> by auto
      have "Ik_intT ?\<sigma> (I.int \<xi> T2)" unfolding eq[symmetric] 1
      using wt1 \<xi> Ik.wt_int by force
      thus ?thesis unfolding T2 by simp
    qed
  next
    case (Pr p Tl)
    then obtain T where Tin: "T \<in> set Tl" and x: "x \<in> nv2T T" and pol: "polC p = Fext"
    using g unfolding Neg Pr by auto
    hence T: "T = Var x" by (simp add: in_nv2T)
    obtain i where i: "i < length Tl" and Ti: "T = Tl!i" using Tin
    by (metis in_set_conv_nth)
    hence 0 : "wt T" "parOf p ! i = ?\<sigma>" using wtL unfolding Neg Pr T
    apply (simp_all add: list_all_iff) by (metis T x in_nv2T tpOf.simps)
    have "list_all2 Ik_intT (parOf p) (map (I.int \<xi>) Tl)" (is ?phi)
    using ns unfolding Neg Pr using pol by (cases ?phi, auto)
    hence "Ik_intT ?\<sigma> (I.int \<xi> T)"
    using ns 0 i Ti unfolding Neg Pr by (auto simp add: list_all2_length nth_map)
    thus ?thesis unfolding T by simp
  qed
qed

lemma int_transE[simp]:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "Ik.int (transE \<xi>) T = I.int \<xi> T"
proof(cases "infTp (Ik.tpOf T) \<or> (\<forall> x \<in> nv2T T. tpOfV x \<noteq> Ik.tpOf T)")
  case True
  thus ?thesis using int_transE_nv2T[OF wt \<xi>] by auto
next
  define \<sigma> where "\<sigma> = Ik.tpOf T"
  case False then obtain x where i: "\<not> infTp \<sigma>" and x: "x \<in> nv2T T"
  unfolding \<sigma>_def by auto
  hence T: "T = Var x" by (simp add: in_nv2T)
  hence \<sigma>: "\<sigma> = tpOfV x" unfolding \<sigma>_def by simp
  obtain l where 0: "Ik.wtL l" "\<not> I.satL \<xi> l" "isGuard x l"
  using nv2T[OF i[unfolded \<sigma>] x] by auto
  show ?thesis unfolding T using isGuard_not_satL_intT[OF 0 \<xi>] by simp
qed

lemma intT_int_transE[simp]:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "Ik_intT (Ik.tpOf T) (I.int \<xi> T)"
proof-
  have 0: "I.int \<xi> T = Ik.int (transE \<xi>) T" using int_transE[OF assms] by simp
  show ?thesis unfolding 0 using Ik.wt_int[OF wtE_transE[OF \<xi>] wt] .
qed

lemma map_int_transE_nv2T[simp]:
assumes wt: "list_all Ik.wt Tl" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); \<exists>T\<in>set Tl. x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "map (Ik.int (transE \<xi>)) Tl = map (I.int \<xi>) Tl"
apply(rule nth_equalityI) using assms by (force simp: list_all_iff intro: int_transE)+

lemma list_all2_intT_int_transE_nv2T[simp]:
assumes wt: "list_all Ik.wt Tl" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); \<exists>T\<in>set Tl. x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "list_all2 Ik_intT (map Ik.tpOf Tl) (map (I.int \<xi>) Tl)"
unfolding list_all2_length using assms
unfolding list_all_iff apply simp_all by (metis intT_int_transE nth_mem)

lemma map_proj_transE[simp]:
assumes wt: "list_all wt Tl"
shows "map (Ik.int (transE \<xi>)) Tl =
       map2 proj (map tpOf Tl) (map (I.int \<xi>) Tl)"
apply(rule nth_equalityI) using assms
using int_transE_proj unfolding list_all_length by auto

lemma satL_transE[simp]:
assumes wtL: "Ik.wtL l" and \<xi>: "I.wtE \<xi>" and
nv2T:  "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); x \<in> nv2L l\<rbrakk> \<Longrightarrow>
             \<exists> l'. Ik.wtL l' \<and> \<not> I.satL \<xi> l' \<and> isGuard x l'"
and "Ik.satL (transE \<xi>) l"
shows "I.satL \<xi> l"
proof(cases l)
  case (Pos at) show ?thesis proof (cases at)
    case (Pr p Tl) show ?thesis using assms unfolding Pos Pr
    apply(cases "polC p")
      apply force
      apply(cases "list_all2 intT (map Ik.tpOf Tl) (map (I.int \<xi>) Tl)", force, force)
      by simp
  qed(insert assms, unfold Pos, simp)
next
  case (Neg at) show ?thesis proof (cases at)
    case (Pr p Tl) show ?thesis using assms unfolding Neg Pr
    apply(cases "polC p")
      apply force apply force
      by (cases "list_all2 intT (map Ik.tpOf Tl) (map (I.int \<xi>) Tl)", force, force)
  qed(insert assms int_transE_proj, unfold Neg, auto)
qed

lemma satPB_transE[simp]:
assumes \<xi>: "I.wtE \<xi>"  shows "I.satPB \<xi> \<Phi>"
unfolding I.satPB_def proof safe
  fix c assume cin: "c \<in> \<Phi>"  let ?thesis = "I.satC \<xi> c"
  have mc: "\<And> \<sigma>. \<sigma> \<turnstile>2 c" using mcalc2[OF cin] .
  have c: "Ik.satC (transE \<xi>) c"
  using sat_\<Phi> wtE_transE[OF \<xi>] cin unfolding Ik.satPB_def by auto
  have wtC: "Ik.wtC c" using wt_\<Phi> cin unfolding wtPB_def by auto
  obtain l where lin: "l \<in> set c" and l: "Ik.satL (transE \<xi>) l"
  using c unfolding Ik.satC_iff_set by auto
  have wtL: "Ik.wtL l" using wtC unfolding wtC_def
  by (metis (lifting) lin list_all_iff)
  {assume "\<not> ?thesis"
   hence 0: "\<And> l'. l' \<in> set c \<Longrightarrow> \<not> I.satL \<xi> l'" unfolding I.satC_iff_set by auto
   have "I.satL \<xi> l"
   proof (rule satL_transE[OF wtL \<xi> _ l])
     fix x let ?\<sigma> = "tpOfV x"
     assume \<sigma>: "\<not> infTp ?\<sigma>" and x: "x \<in> nv2L l"
     hence g: "isGuard x (grdOf c l x)" using mc[of ?\<sigma>] lin unfolding mcalc2_iff by simp
     show "\<exists> l'. Ik.wtL l' \<and> \<not> I.satL \<xi> l' \<and> isGuard x l'"
     apply(rule exI[of _ "grdOf c l x"]) apply safe
     using g \<sigma> cin lin wtL_grdOf x 0 grdOf x by auto
   qed
   hence False using 0 lin by auto
   hence ?thesis by simp
  }
  thus ?thesis by auto
qed

lemma I_SAT: "I.SAT \<Phi>"
unfolding I.SAT_def by simp

lemma InfModel: "IInfModel I_intT I_intF I_intP"
  by standard (rule I_SAT)

end (* context ModelIkPolMcalc2C *)

sublocale ModelIkPolMcalc2C < inf?: InfModel where
intT = I_intT and intF = I_intF and intP = I_intP
using InfModel .

context ProblemIkPolMcalc2C begin

abbreviation
"MModelIkPolMcalc2C \<equiv> ModelIkPolMcalc2C wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf"

end (* context ProblemIkPolMcalc2 *)

text\<open>Final theorem in sublocale form: Any problem that passes the
  monotonicity calculus is monotonic:\<close>
sublocale ProblemIkPolMcalc2C < MonotProblem
by standard (rule monot)

end


section \<open>Proper Iterators\<close>
theory Proper_Iterator
imports
  SetIteratorOperations
  Automatic_Refinement.Refine_Lib
begin
  text \<open>
    Proper iterators provide a way to obtain polymorphic iterators even
    inside locale contexts.

    For this purpose, an iterator that converts the set to a list is fixed
    inside the locale, and polymorphic iterators are described by folding
    over the generated list.

    In order to ensure efficiency, it is shown that folding over the generated
    list is equivalent to directly iterating over the set, and this equivalence
    is set up as a code preprocessing rule.
\<close>

  subsection \<open>Proper Iterators\<close>

  text \<open>A proper iterator can be expressed as a fold over a list, where
    the list does only depend on the set. In particular, it does not depend
    on the type of the state. We express this by the following definition,
    using two iterators with different types:\<close>

  definition proper_it
    :: "('x,'\<sigma>1) set_iterator \<Rightarrow> ('x,'\<sigma>2) set_iterator \<Rightarrow> bool"
    where "proper_it it it' \<equiv> (\<exists>l. it=foldli l \<and> it'=foldli l)"

  lemma proper_itI[intro?]:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    assumes "it=foldli l \<and> it'=foldli l"
    shows "proper_it it it'"
    using assms unfolding proper_it_def by auto

  lemma proper_itE:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    assumes "proper_it it it'"
    obtains l where "it=foldli l" and "it'=foldli l"
    using assms unfolding proper_it_def by auto

  lemma proper_it_parE:
    fixes it :: "'a \<Rightarrow> ('x,'\<sigma>1) set_iterator"
    and it' :: "'a \<Rightarrow> ('x,'\<sigma>2) set_iterator"
    assumes "\<forall>x. proper_it (it x) (it' x)"
    obtains f where "it = (\<lambda>x. foldli (f x))" and "it' = (\<lambda>x. foldli (f x))"
    using assms unfolding proper_it_def
    by metis

  definition
    proper_it'
    where "proper_it' it it' \<equiv> \<forall>s. proper_it (it s) (it' s)"

  lemma proper_it'I:
    "\<lbrakk>\<And>s. proper_it (it s) (it' s)\<rbrakk> \<Longrightarrow> proper_it' it it'"
    unfolding proper_it'_def by blast

  lemma proper_it'D:
    "proper_it' it it' \<Longrightarrow> proper_it (it s) (it' s)"
    unfolding proper_it'_def by blast

  subsubsection \<open>Properness Preservation\<close>
  ML \<open>
    structure Icf_Proper_Iterator = struct

      structure icf_proper_iteratorI = Named_Thms
        ( val name = @{binding icf_proper_iteratorI_raw}
          val description = "ICF (internal): Rules to show properness of iterators" )

      val get = icf_proper_iteratorI.get

      fun add_thm thm = icf_proper_iteratorI.add_thm thm

      val add = Thm.declaration_attribute add_thm

      fun del_thm thm = icf_proper_iteratorI.del_thm thm

      val del = Thm.declaration_attribute del_thm

      val setup = I
        #> icf_proper_iteratorI.setup
        #> Attrib.setup @{binding icf_proper_iteratorI}
          (Attrib.add_del add del)
          ("ICF: Rules to show properness of iterators")
        #> Global_Theory.add_thms_dynamic (@{binding icf_proper_iteratorI},
             get o Context.proof_of
            )

    end
\<close>
  setup \<open>Icf_Proper_Iterator.setup\<close>

  lemma proper_iterator_trigger:
    "proper_it it it' \<Longrightarrow> proper_it it it'"
    "proper_it' itf itf' \<Longrightarrow> proper_it' itf itf'" .

  declaration \<open>
    Tagged_Solver.declare_solver @{thms proper_iterator_trigger}
      @{binding proper_iterator} "Proper iterator solver"
      (fn ctxt => REPEAT_ALL_NEW (resolve_tac ctxt (Icf_Proper_Iterator.get ctxt)))
\<close>

  lemma pi_foldli[icf_proper_iteratorI]:
    "proper_it (foldli l :: ('a,'\<sigma>) set_iterator) (foldli l)"
    unfolding proper_it_def
    by auto

  lemma pi_foldri[icf_proper_iteratorI]:
    "proper_it (foldri l :: ('a,'\<sigma>) set_iterator) (foldri l)"
    unfolding proper_it_def foldri_def by auto

  lemma pi'_foldli[icf_proper_iteratorI]:
    "proper_it' (foldli o tsl) (foldli o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  lemma pi'_foldri[icf_proper_iteratorI]:
    "proper_it' (foldri o tsl) (foldri o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  text \<open>Iterator combinators preserve properness\<close>
  lemma pi_emp[icf_proper_iteratorI]:
    "proper_it set_iterator_emp set_iterator_emp"
    unfolding proper_it_def set_iterator_emp_def[abs_def]
    by (auto intro!: ext exI[where x="[]"])

  lemma pi_sng[icf_proper_iteratorI]:
    "proper_it (set_iterator_sng x) (set_iterator_sng x)"
    unfolding proper_it_def set_iterator_sng_def[abs_def]
    by (auto intro!: ext exI[where x="[x]"])

  lemma pi_union[icf_proper_iteratorI]:
    assumes PA: "proper_it it_a it_a'"
    assumes PB: "proper_it it_b it_b'"
    shows "proper_it (set_iterator_union it_a it_b)
      (set_iterator_union it_a' it_b')"
    unfolding set_iterator_union_def
    apply (rule proper_itE[OF PA])
    apply (rule proper_itE[OF PB])
    apply (rule_tac l="l@la" in proper_itI)
    apply simp
    apply (intro conjI ext)
    apply (simp_all add: foldli_append)
    done

  lemma pi_product[icf_proper_iteratorI]:
    fixes it_a :: "('a,'\<sigma>a) set_iterator"
    fixes it_b :: "'a \<Rightarrow> ('b,'\<sigma>a) set_iterator"
    assumes PA: "proper_it it_a it_a'"
    and PB: "\<And>x. proper_it (it_b x) (it_b' x)"
    shows "proper_it (set_iterator_product it_a it_b)
      (set_iterator_product it_a' it_b')"
  proof -
    from PB have PB': "\<forall>x. proper_it (it_b x) (it_b' x)" ..
    show ?thesis
      unfolding proper_it_def
      apply (rule proper_itE[OF PA])
      apply (rule proper_it_parE[OF PB'])
      apply (auto simp add: set_iterator_product_foldli_conv)
      done
  qed

  lemma pi_image_filter[icf_proper_iteratorI]:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    and g :: "'x \<Rightarrow> 'y option"
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image_filter g it)
      (set_iterator_image_filter g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    apply (auto simp: set_iterator_image_filter_foldli_conv)
    done

  lemma pi_filter[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_filter P it)
      (set_iterator_filter P it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_filter_foldli_conv)

  lemma pi_image[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image g it)
      (set_iterator_image g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_image_foldli_conv)

  lemma pi_dom[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (map_iterator_dom it)
      (map_iterator_dom it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: map_iterator_dom_foldli_conv)

  lemma set_iterator_product_eq2:
    assumes "\<forall>a\<in>set la. itb a = itb' a"
    shows "set_iterator_product (foldli la) itb
    = set_iterator_product (foldli la) itb'"
  proof (intro ext)
    fix c f \<sigma>
    show "set_iterator_product (foldli la) itb c f \<sigma>
      = set_iterator_product (foldli la) itb' c f \<sigma>"
      using assms
      unfolding set_iterator_product_def
      apply (induct la arbitrary: \<sigma>)
      apply (auto)
      done
  qed

subsubsection \<open>Optimizing Folds\<close>
  text \<open>
    Using an iterator to create a list. The optimizations will
    match the pattern \<open>foldli (it_to_list it s)\<close>
\<close>
  definition "it_to_list it s \<equiv> (it s) (\<lambda>_. True) (\<lambda>x l. l@[x]) []"

  lemma map_it_to_list_genord_correct:
    assumes A: "map_iterator_genord (it s) m (\<lambda>(k,_) (k',_). R k k')"
    shows "map_of (it_to_list it s) = m
      \<and> distinct (map fst (it_to_list it s))
      \<and> sorted_wrt R ((map fst (it_to_list it s)))"
    unfolding it_to_list_def
    apply (rule map_iterator_genord_rule_insert_P[OF A, where I="
      \<lambda>it l. map_of l = m |` it
        \<and> distinct (map fst l)
        \<and> sorted_wrt R ((map fst l))
      "])
    apply auto
    apply (auto simp: restrict_map_def) []
    apply (metis Some_eq_map_of_iff restrict_map_eq(2))
    apply (auto simp add: sorted_wrt_append)
    by (metis (lifting) restrict_map_eq(2) weak_map_of_SomeI)

  lemma (in linorder) map_it_to_list_linord_correct:
    assumes A: "map_iterator_linord (it s) m"
    shows "map_of (it_to_list it s) = m
      \<and> distinct (map fst (it_to_list it s))
      \<and> sorted ((map fst (it_to_list it s)))"
    using map_it_to_list_genord_correct[where it=it,
      OF A[unfolded set_iterator_map_linord_def]]
    by (simp add: sorted_sorted_wrt)

end