theory LetPat
imports "../Nominal2"
begin

atom_decl name

nominal_datatype trm =
  Var "name"
| App "trm" "trm"
| Lam x::"name" t::"trm"       binds x in t
| Let p::"pat" "trm" t::"trm"  binds "bn p" in t
and pat =
  PNil
| PVar "name"
| PTup "pat" "pat"
binder
  bn::"pat \<Rightarrow> atom list"
where
  "bn PNil = []"
| "bn (PVar x) = [atom x]"
| "bn (PTup p1 p2) = bn p1 @ bn p2"

thm trm_pat.eq_iff
thm trm_pat.distinct
thm trm_pat.induct
thm trm_pat.strong_induct[no_vars]
thm trm_pat.exhaust
thm trm_pat.strong_exhaust[no_vars]
thm trm_pat.fv_defs
thm trm_pat.bn_defs
thm trm_pat.perm_simps
thm trm_pat.eq_iff
thm trm_pat.fv_bn_eqvt
thm trm_pat.size

(* Nominal_Abs test *)

lemma alpha_res_alpha_set:
  "(bs, x) \<approx>res op = supp p (cs, y) \<longleftrightarrow>
  (bs \<inter> supp x, x) \<approx>set op = supp p (cs \<inter> supp y, y)"
  using alpha_abs_set_abs_res alpha_abs_res_abs_set by blast

lemma
  fixes x::"'a::fs"
  assumes "(supp x - as) \<sharp>* p"
      and "p \<bullet> x = y"
      and "p \<bullet> (as \<inter> supp x) = bs \<inter> supp y"
  shows "(as, x) \<approx>res (op =) supp p (bs, y)"
  using assms
  unfolding alpha_res_alpha_set
  unfolding alphas
  apply simp
  apply rule
  apply (rule trans)
  apply (rule supp_perm_eq[symmetric, of _ p])
  apply(subst supp_finite_atom_set)
  apply (metis finite_Diff finite_supp)
  apply (simp add: fresh_star_def)
  apply blast
  apply(perm_simp)
  apply(simp)
  done

lemma
  fixes x::"'a::fs"
  assumes "(supp x - as) \<sharp>* p"
      and "p \<bullet> x = y"
      and "p \<bullet> as = bs"
  shows "(as, x) \<approx>set (op =) supp p (bs, y)"
  using assms
  unfolding alphas
  apply simp
  apply (rule trans)
  apply (rule supp_perm_eq[symmetric, of _ p])
  apply(subst supp_finite_atom_set)
  apply (metis finite_Diff finite_supp)
  apply(simp)
  apply(perm_simp)
  apply(simp)
  done

lemma
  fixes x::"'a::fs"
  assumes "(supp x - set as) \<sharp>* p"
      and "p \<bullet> x = y"
      and "p \<bullet> as = bs"
  shows "(as, x) \<approx>lst (op =) supp p (bs, y)"
  using assms
  unfolding alphas
  apply simp
  apply (rule trans)
  apply (rule supp_perm_eq[symmetric, of _ p])
  apply(subst supp_finite_atom_set)
  apply (metis finite_Diff finite_supp)
  apply(simp)
  apply(perm_simp)
  apply(simp)
  done

end


theory closure_algebra
  imports conditions_infinitary
begin

section \<open>Topological Closure Algebras\<close>

(**In this section we examine the traditional notion of topological closure algebras
in the spirit of McKinsey \& Tarski @{cite AOT}, but drawing primarily from the works of Zarycki
@{cite Zarycki-1} and Kuratowski @{cite Kuratowski-1}.*)

(**We define some conditions on unary operations (aka. operators) with type @{type "'w \<sigma>\<Rightarrow>'w \<sigma>"}.
Those operators are aimed at extending Boolean algebras (of propositions) towards different
sorts of topological algebras. Here we examine closure (and their dual: interior) operators.
We follow the naming conventions introduced originally by Kuratowski @{cite Kuratowski-1}
(cf. also @{cite Kuratowski-2}) and Zarycki @{cite Zarycki-1}.*)

subsection \<open>Closure conditions\<close>

(*Defining axioms*)
abbreviation "Cl_1 \<phi> \<equiv> ADDI \<phi>" (* 1st Kuratowski condition = MONO + Cl_1' *)
abbreviation "Cl_1' \<phi> \<equiv> ADDI\<^sup>a \<phi>" (* Given MONO, this is the essence of Cl_1 *)
abbreviation "iCl_1 \<phi> \<equiv> iADDI(\<phi>)"   (* infinitary variant of Cl_1 *)
abbreviation "iCl_1' \<phi> \<equiv> iADDI\<^sup>a(\<phi>)" (* infinitary variant of Cl_1' *)
abbreviation "Cl_2 \<phi> \<equiv> EXPN \<phi>"  (* 2nd Kuratowski condition: expansiveness/increasingness *)
abbreviation "Cl_3 \<phi>  \<equiv> NORM \<phi>" (* 3rd Kuratowski condition, sometimes called "normality" *)
abbreviation "Cl_4 \<phi> \<equiv> IDEM \<phi>" (* 4th Kuratowski condition: idempotence = EXPN + Cl_4' *)
abbreviation "Cl_4' \<phi> \<equiv> IDEM\<^sup>b \<phi>" (* Given EXPN, this is the essence of Cl_4 *)

(*Some interesting entailed properties*)
abbreviation "Cl_5 \<phi>  \<equiv> DNRM \<phi>" (*the dual of NORM*)
abbreviation "Cl_6 \<phi> \<equiv> DISTR\<^sub>\<rightarrow>\<^sup>d \<phi>"  (* decreasing distribution over implication *)
abbreviation "Cl_7 \<phi> \<equiv> DISTR\<^sub>\<leftharpoonup>\<^sup>d \<phi>"  (* decreasing distribution over difference *)
definition "Cl_8 \<phi>  \<equiv> \<forall>A B. \<phi>(\<phi> A \<^bold>\<and> \<phi> B) \<approx> (\<phi> A) \<^bold>\<and> (\<phi> B)"
definition "Cl_9 \<phi>  \<equiv> \<forall>A B.  A \<preceq> (\<phi> B) \<longrightarrow> (\<phi> A) \<preceq> (\<phi> B)"

(**As for Cl-8 and Cl-9 we show which axioms entail them*)
lemma PC8: "MONO \<phi> \<Longrightarrow> Cl_2 \<phi> \<Longrightarrow> Cl_4 \<phi> \<Longrightarrow> Cl_8 \<phi>" by (smt (verit, del_insts) Cl_8_def EXPN_def IDEM_def MONO_MULTa MULT_a_def setequ_def setequ_equ)
lemma PC9: "MONO \<phi> \<Longrightarrow> Cl_4 \<phi> \<Longrightarrow> Cl_9 \<phi>" by (metis Cl_9_def IDEM_def MONO_def setequ_equ)

(**@{text "\<phi>"} is a topological closure operator in the strict sense (@{text "\<CC>(\<phi>)"})
iff it satisfies the four Kuratowski conditions 1-4 (cf. @{cite Kuratowski-1} @{cite Kuratowski-2}).*)
abbreviation "\<CC> \<phi>  \<equiv> Cl_1 \<phi> \<and> Cl_2 \<phi> \<and> Cl_3  \<phi> \<and> Cl_4 \<phi>"

(*This characterization is shown consistent by generating a generating non-trivial model.*)
lemma "\<CC> \<phi>" nitpick[satisfy, card 'w=3] oops (*model found: characterization is consistent*)

subsection \<open>Interior conditions\<close>

(*Defining axioms*)
abbreviation "Int_1 \<phi>  \<equiv> MULT \<phi>" (* (dual of) 1st Kuratowski condition = MONO + Int_1' *)
abbreviation "Int_1' \<phi> \<equiv> MULT\<^sup>b \<phi>" (* Given MONO, this is the essence of Int_1 *)
abbreviation "iInt_1' \<phi> \<equiv> iMULT\<^sup>b(\<phi>)" (* infinitary variant of Int_1 *)
abbreviation "iInt_1 \<phi> \<equiv> iMULT(\<phi>)"   (* infinitary variant of Int_1' *)
abbreviation "Int_2 \<phi>  \<equiv> CNTR \<phi>"  (* (dual of) 2th Kuratowski condition: contractiveness *)
abbreviation "Int_3 \<phi>  \<equiv> DNRM \<phi>"  (* (dual of) 3th Kuratowski condition: 'dual normality'*)
abbreviation "Int_4 \<phi>  \<equiv> IDEM \<phi>" (* (dual of) 4th Kuratowski condition = CNTR + Int_4' *)
abbreviation "Int_4' \<phi> \<equiv> IDEM\<^sup>a \<phi>" (* Given CNTR, this is the essence of Int_4 *)

(*Some interesting entailed properties*)
abbreviation "Int_5 \<phi>  \<equiv> NORM \<phi>"    (* 3th Kuratowski condition: 'normality'*)
abbreviation "Int_6 \<phi>  \<equiv> DISTR\<^sub>\<leftharpoonup>\<^sup>i \<phi>" (* increasing distribution over difference *)
abbreviation "Int_7 \<phi>  \<equiv> DISTR\<^sub>\<rightarrow>\<^sup>i \<phi>" (* increasing distribution over implication *)
definition "Int_8 \<phi>  \<equiv> \<forall>A B. \<phi>(\<phi> A \<^bold>\<or> \<phi> B) \<approx> (\<phi> A) \<^bold>\<or> (\<phi> B)" (* dual of Cl-8 *)
definition "Int_9 \<phi>  \<equiv> \<forall>A B. \<phi> A \<preceq> B \<longrightarrow> (\<phi> A) \<preceq> (\<phi> B)"   (* dual of Cl-9 *)

(**As for Int-8 and Int-9 we show which axioms entail them*)
lemma PI8: "MONO \<phi> \<Longrightarrow> Int_2 \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Int_8 \<phi>" by (metis ADDI_b_def CNTR_def IDEM_def Int_8_def MONO_ADDIb setequ_def setequ_equ)
lemma PI9: "MONO \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Int_9 \<phi>" by (metis IDEM_def Int_9_def MONO_def setequ_equ)

(**@{text "\<phi>"} is an interior operator in the strict sense (@{text "\<II>(\<phi>)"})
iff it satisfies the interior conditions 1-4 above (cf. @{cite Zarycki-1} and also @{cite Kuratowski-2}).*)
abbreviation "\<II> \<phi> \<equiv> Int_1 \<phi> \<and> Int_2 \<phi> \<and> Int_3 \<phi> \<and> Int_4 \<phi>"

(**This characterization is also shown consistent by generating a non-trivial model.*)
lemma "\<II> \<phi>" nitpick[satisfy, card 'w=3] oops (*model found: characterization is consistent*)

section \<open>Closure algebra\<close>
(**We define a topological Boolean algebra with a primitive closure operator and verify a few properties.
We write \<C> for a unary operator intended as a closure-like operator (though unconstrained by default)*)

(**Interior operator as derived from closure.*)
abbreviation Int_cl::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<I>[_]")
  where "\<I>[\<C>] \<equiv> \<C>\<^sup>d"

(**Frontier (aka. 'boundary') operator as derived from closure.
 (cf. 'Grenze' @{cite Hausdorff}, 'fronti\`ere' @{cite Zarycki-1} @{cite Kuratowski-2})*)
definition Fr_cl::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<F>[_]")
  where "\<F>[\<C>] \<equiv> \<lambda>A. \<C> A \<^bold>\<and> \<C> (\<^bold>\<midarrow>A)"

(**Border operator as derived from closure (cf. 'Rand' @{cite Hausdorff}, 'bord' @{cite Zarycki-1})*)
definition Br_cl::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<B>[_]")
  where "\<B>[\<C>] \<equiv> \<lambda>A. A \<^bold>\<and> \<C> (\<^bold>\<midarrow>A)"

(**(Hausdorff's) Residue operator as derived from closure (via border).*)
definition Rs_cl::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<R>[_]")
  where "\<R>[\<C>] \<equiv> \<lambda>A. \<B>[\<C>](\<^bold>\<midarrow>(\<B>[\<C>](\<^bold>\<midarrow>A)))"

subsection \<open>Basic properties\<close>

(**The results below are well known in the literature.
Here we try to uncover the minimal conditions on the operator \<C> under which they hold.*)

(**The frontier operator is in fact symmetric wrt. complement*)
lemma F_symm: "\<forall>A. (\<F>[\<C>] A) = (\<F>[\<C>] (\<^bold>\<midarrow>A))" unfolding Fr_cl_def conn by auto

(**Fixed-point and other operators are interestingly related.
Note that below only the second Kuratowski condition for \<C> (expansiveness) is required.*)
lemma fp1: "Cl_2 \<C> \<Longrightarrow> \<I>[\<C>]\<^sup>f\<^sup>p \<cong> \<B>[\<C>]\<^sup>c" by (smt (verit, del_insts) Br_cl_def CNTR_def EXPN_CNTR_dual2 compl_def dimpl_char fixpoint_op_def meet_def op_compl_def op_dual_def op_equal_def setequ_char subset_def)
lemma fp2: "Cl_2 \<C> \<Longrightarrow> \<B>[\<C>]\<^sup>f\<^sup>p \<cong> \<I>[\<C>]\<^sup>c" by (metis comp_symm fp1 ofp_c ofp_invol op_equal_equ)
lemma fp3: "Cl_2 \<C> \<Longrightarrow> \<C>\<^sup>f\<^sup>p \<cong> \<B>[\<C>]\<^sup>d" by (metis dual_invol fp2 ofp_d ofp_invol op_equal_equ)
lemma fp4: "Cl_2 \<C> \<Longrightarrow> (\<B>[\<C>]\<^sup>d)\<^sup>f\<^sup>p \<cong> \<C>" by (metis fp3 ofp_invol op_equal_equ)
lemma fp5: "Cl_2 \<C> \<Longrightarrow> \<F>[\<C>]\<^sup>f\<^sup>p \<cong> (\<lambda>X. (\<B>[\<C>] X) \<^bold>\<or> (\<C>\<^sup>c X))"  by (smt (verit, del_insts) Br_cl_def EXPN_def Fr_cl_def compl_def dimpl_char fixpoint_op_def join_def meet_def op_compl_def op_equal_def setequ_char subset_def)

(**Define some fixed-point predicates and prove some properties.*)
abbreviation closedset ("Cl[_]") where "Cl[\<C>] \<equiv> fp \<C>"
abbreviation openset ("Op[_]") where "Op[\<C>] \<equiv> fp \<I>[\<C>]"
abbreviation borderset ("Br[_]") where "Br[\<C>] \<equiv> fp \<B>[\<C>]"
abbreviation frontierset ("Fr[_]") where "Fr[\<C>] \<equiv> fp \<F>[\<C>]"
abbreviation residueset ("Rs[_]") where "Rs[\<C>] \<equiv> fp \<R>[\<C>]"

lemma Int_Open: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Op[\<C>](\<I>[\<C>] A)" by (metis (full_types) IDEM_def IDEM_dual fixpoint_pred_def setequ_equ)
lemma Cl_Closed: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Cl[\<C>](\<C> A)" by (simp add: IDEM_def fixpoint_pred_def setequ_equ)
lemma Cl_Frontier: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> \<forall>A. Cl[\<C>](\<F>[\<C>] A)" by (metis Cl_8_def EXPN_def Fr_cl_def IDEM_b_def IDEM_def PC8 fixpoint_pred_def setequ_def)
lemma Br_Border: "MONO \<C> \<Longrightarrow> \<forall>A. Br[\<C>](\<B>[\<C>] A)" by (smt (verit, ccfv_threshold) BA_deMorgan2 Br_cl_def L12 L3 L4 L5 L6 MONO_def fixpoint_pred_def setequ_def)
(**In contrast, there are no analogous fixed-point results for frontier and residue:*)
lemma "\<CC> \<C> \<Longrightarrow> \<forall>A. Fr[\<C>](\<F>[\<C>] A)" nitpick oops (*counterexample even if assuming all closure conditions*)
lemma "\<CC> \<C> \<Longrightarrow> \<forall>A. Rs[\<C>](\<R>[\<C>] A)" nitpick oops (*counterexample even if assuming all closure conditions*)

lemma OpCldual: "\<forall>A. Cl[\<C>] A \<longleftrightarrow> Op[\<C>](\<^bold>\<midarrow>A)" by (simp add: BA_dn fp_d)
lemma ClOpdual: "\<forall>A. Op[\<C>] A \<longleftrightarrow> Cl[\<C>] (\<^bold>\<midarrow>A)" by (simp add: fp_d)
lemma Op_Bempty: "Cl_2 \<C> \<Longrightarrow> \<forall>A. Op[\<C>] A \<longleftrightarrow> \<B>[\<C>] A \<approx> \<^bold>\<bottom>" by (metis comp_symm fp1 fp_c_rel ofp_d ofp_dc op_equal_equ)
lemma Cl_Bempty: "Cl_2 \<C> \<Longrightarrow> \<forall>A. Cl[\<C>] A \<longleftrightarrow> \<B>[\<C>] (\<^bold>\<midarrow>A) \<approx> \<^bold>\<bottom>" using OpCldual Op_Bempty by blast
lemma Br_Iempty: "Cl_2 \<C> \<Longrightarrow> \<forall>A. Br[\<C>] A \<longleftrightarrow> \<I>[\<C>] A \<approx> \<^bold>\<bottom>" by (metis comp_invol fp2 fp_c_rel ofp_c op_equal_equ)
lemma Fr_ClBr: "Cl_2 \<C> \<Longrightarrow> \<forall>A. Fr[\<C>] A \<longleftrightarrow> (Cl[\<C>] A \<and> Br[\<C>] A)" by (smt (verit, best) Br_cl_def EXPN_def Fr_cl_def compl_def fixpoint_pred_def meet_def setequ_def setequ_equ subset_def)

lemma Int_join_closed: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> join_closed Op[\<C>]" using fp_inf_closed_cond3 fp_meet_join_closed_dual inf_closed_char inf_meet_closed by auto
lemma Int_sup_closed: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> supremum_closed Op[\<C>]" by (simp add: fp_inf_closed_cond3 fp_inf_sup_closed_dual)

lemma pFI: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> \<forall>A. \<F>[\<C>](\<I>[\<C>] A) \<preceq> \<F>[\<C>] A" by (simp add: BA_dn CNTR_def EXPN_CNTR_dual2 Fr_cl_def IDEM_b_def L12 MONO_def op_dual_def)
lemma pFC: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> \<forall>A. \<F>[\<C>](\<C> A) \<preceq> \<F>[\<C>] A" by (metis BA_dn F_symm op_dual_def pFI)
lemma pBI: "Cl_4' \<C> \<Longrightarrow> \<forall>A. \<B>[\<C>](\<I>[\<C>] A) \<preceq> \<B>[\<C>] A" by (smt (verit, best) BA_dn Br_cl_def IDEM_b_def compl_def meet_def op_dual_def subset_def)
lemma "\<CC> \<C> \<Longrightarrow> \<forall>A. \<B>[\<C>](\<C> A) \<preceq> \<B>[\<C>] A" nitpick oops
lemma pRB: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> \<forall>A. \<R>[\<C>] A \<preceq> \<B>[\<C>] A" oops (** as exercise (evtl. without using Cl-2) *)

(**Properties involving disjointness*)
lemma Disj_IF: "\<forall>A. Disj (\<I>[\<C>] A) (\<F>[\<C>] A)" by (simp add: Disj_def Fr_cl_def bottom_def compl_def meet_def op_dual_def setequ_char)
lemma Disj_B: "\<forall>A. Disj (\<B>[\<C>] A) (\<B>[\<C>] (\<^bold>\<midarrow>A))" by (simp add: Br_cl_def Disj_def bottom_def compl_def meet_def setequ_char)
lemma Disj_I: "Cl_2 \<C> \<Longrightarrow> \<forall>A. Disj (\<I>[\<C>] A) (\<^bold>\<midarrow>A)" by (smt (verit, best) Disj_def EXPN_def bottom_def compl_def meet_def op_dual_def setequ_char subset_def)
lemma Disj_BCI: "\<forall>A. Disj (\<B>[\<C>] (\<C> A)) (\<I>[\<C>] (\<^bold>\<midarrow>A))" by (simp add: Br_cl_def Disj_def bottom_def compl_def meet_def op_dual_def setequ_char)
lemma Disj_FCI: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Disj (\<F>[\<C>] (\<C> A)) (\<I>[\<C>] (\<^bold>\<midarrow>A))" by (metis Br_cl_def Disj_BCI Fr_cl_def IDEM_def setequ_equ)
lemma Disj_CRI: "MONO \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> \<forall>A. Disj (\<C> (\<B>[\<C>] (\<^bold>\<midarrow>A))) (\<I>[\<C>] (\<^bold>\<midarrow>A))" unfolding Disj_def by (smt (verit, ccfv_threshold) Br_cl_def Cl_9_def L3 L5 PC9 compl_def op_dual_def subset_def)
lemma Disj_Rcompl: "MONO \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> \<forall>A. Disj (\<R>[\<C>] A) (\<^bold>\<midarrow>A)" by (smt (verit, del_insts) BA_dn Br_cl_def Disj_CRI Disj_def Rs_cl_def compl_def meet_def op_dual_def setequ_char)

(**Closure and Interior can be interestingly characterized using the notion of disjointness*)
lemma CI_Disj_rel_a: "\<forall>A p. (\<forall>E. (\<I>[\<C>] E) p \<longrightarrow> \<not>Disj E A) \<longrightarrow> (\<C> A) p" by (metis BA_deMorgan1 BA_dn Br_cl_def Disj_BCI L1 compl_def op_dual_def)
lemma CI_Disj_rel_b: "MONO \<C> \<Longrightarrow> \<forall>A p. (\<C> A) p \<longrightarrow> (\<forall>E. (\<I>[\<C>] E) p \<longrightarrow> \<not>Disj E A)" unfolding MONO_def Disj_def op_dual_def by (metis bottom_def compl_def meet_def setequ_equ subset_def)
lemma CI_Disj_rel: "MONO \<C> \<Longrightarrow> \<forall>A. \<C> A = (\<lambda>p. \<forall>E. (\<I>[\<C>] E) p \<longrightarrow> \<not>Disj E A)" by (metis CI_Disj_rel_a CI_Disj_rel_b)

(**Closure and interior can be characterised in terms of their fixed points.*)
lemma C_fp_def: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C>
                  \<Longrightarrow> \<forall>A. \<C> A \<approx> \<^bold>\<And>(\<lambda>S. Cl[\<C>] S \<and> A \<preceq> S)"
  using inf_char unfolding setequ_def by (smt (verit, del_insts) Cl_Closed EXPN_def IDEM_a_def IDEM_char MONO_def fixpoint_pred_def setequ_equ)

lemma I_fp_def: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C>
                   \<Longrightarrow> \<forall>A. \<I>[\<C>] A \<approx> \<^bold>\<Or>(\<lambda>S. Op[\<C>] S \<and> S \<preceq> A)"
  using iDM_b op_dual_def setequ_char by (smt (z3) BA_cp BA_dn C_fp_def EXPN_def IDEM_b_def Int_sup_closed MONO_def MONO_dual OpCldual fixpoint_pred_def setequ_def setequ_equ subset_def sup_char supremum_closed_def)

end


(*  Title:       Analysis of OPT2
    Author:      Max Haslbeck
*)

section "OPT2"

theory OPT2
imports
Partial_Cost_Model
RExp_Var
begin

subsection "Definition"

fun OPT2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> (nat * nat list) list" where
  "OPT2 [] [x,y] = []"
| "OPT2 [a] [x,y] = [(0,[])]"
| "OPT2 (a#b#\<sigma>') [x,y] =  (if a=x then (0,[]) # (OPT2 (b#\<sigma>') [x,y])
                                  else (if b=x then (0,[])# (OPT2 (b#\<sigma>') [x,y])
                                               else (1,[])# (OPT2 (b#\<sigma>') [y,x])))"

lemma OPT2_length: "length (OPT2 \<sigma> [x, y]) = length \<sigma>"
apply(induct \<sigma> arbitrary: x y)
  apply(simp)
  apply(case_tac \<sigma>) by(auto)

lemma OPT2x: "OPT2 (x#\<sigma>') [x,y] = (0,[])#(OPT2 \<sigma>' [x,y])"
apply(cases \<sigma>') by (simp_all)

lemma swapOpt: "T\<^sub>p_opt [x,y] \<sigma> \<le> 1 + T\<^sub>p_opt [y,x] \<sigma>"
proof -
  show ?thesis
  proof (cases "length \<sigma> > 0")
    case True

    have "T\<^sub>p_opt [y,x] \<sigma> \<in> {T\<^sub>p [y, x] \<sigma> as |as. length as = length \<sigma>}"
    unfolding T_opt_def
      apply(rule Inf_nat_def1)
      apply(auto) by (rule Ex_list_of_length)

    then obtain asyx where costyx: "T\<^sub>p [y,x] \<sigma> asyx = T\<^sub>p_opt [y,x] \<sigma>"
                       and lenyx: "length asyx = length \<sigma>"
              unfolding T_opt_def by auto

    from True lenyx have "length asyx > 0" by auto
    then obtain A asyx' where aa: "asyx = A # asyx'" using list.exhaust by blast
    then obtain m1 a1 where AA: "A = (m1,a1)" by fastforce

    let ?asxy = "(m1,a1@[0]) # asyx'"

    from True obtain q \<sigma>' where qq: "\<sigma> = q # \<sigma>'" using list.exhaust by blast

    have t: "t\<^sub>p [x, y] q (m1, a1@[0]) = Suc (t\<^sub>p [y, x] q (m1, a1))"
    unfolding t\<^sub>p_def
    apply(simp) unfolding swap_def by (simp)

    have s: "step [x, y] q (m1, a1 @ [0]) = step [y, x] q (m1, a1)"
    unfolding step_def mtf2_def by(simp add: swap_def)

    have T: "T\<^sub>p [x,y] \<sigma> ?asxy = 1 + T\<^sub>p [y,x] \<sigma> asyx" unfolding qq aa AA by(auto simp add: s t)

    have l: "1 + T\<^sub>p_opt [y,x] \<sigma> = T\<^sub>p [x, y] \<sigma> ?asxy" using T costyx by simp
    have "length ?asxy = length \<sigma>" using lenyx aa by auto
    then have inside: "?asxy \<in> {as. size as = size \<sigma>}" by force
    then have b: "T\<^sub>p [x, y] \<sigma> ?asxy \<in> {T\<^sub>p [x, y] \<sigma> as | as. size as = size \<sigma>}" by auto

    then show ?thesis unfolding l unfolding T_opt_def
      apply(rule cInf_lower) by simp
  qed (simp add: T_opt_def)
qed

lemma tt: "a \<in> {x,y} \<Longrightarrow> OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))
       = tl (OPT2 (a # rest1) [x, y])"
apply(cases rest1) by(auto simp add: step_def mtf2_def swap_def)

lemma splitqsallg: "Strat \<noteq> [] \<Longrightarrow> a \<in> {x,y} \<Longrightarrow>
         t\<^sub>p [x, y] a (hd (Strat)) +
          (let L=step [x,y] a (hd (Strat))
              in T\<^sub>p L (rest1) (tl Strat)) =  T\<^sub>p [x, y] (a # rest1) Strat"
proof -
  assume ne: "Strat \<noteq> []"
  assume axy: "a \<in> {x,y}" (* not needed *)
  have "T\<^sub>p [x, y] (a # rest1) (Strat)
        = T\<^sub>p [x, y] (a # rest1) ((hd (Strat)) # (tl (Strat)))"
        by(simp only: List.list.collapse[OF ne])
  then show ?thesis by auto
qed

lemma splitqs: "a \<in> {x,y} \<Longrightarrow> T\<^sub>p [x, y] (a # rest1) (OPT2 (a # rest1) [x, y])
        =  t\<^sub>p [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
          (let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y]))
              in T\<^sub>p L (rest1) (OPT2 (rest1) L))"
proof -
  assume axy: "a \<in> {x,y}"
  have ne: "OPT2 (a # rest1) [x, y] \<noteq> []" apply(cases rest1) by(simp_all)
  have "T\<^sub>p [x, y] (a # rest1) (OPT2 (a # rest1) [x, y])
        = T\<^sub>p [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (tl (OPT2 (a # rest1) [x, y])))"
        by(simp only: List.list.collapse[OF ne])
  also have "\<dots> = T\<^sub>p [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))))"
      by(simp only: tt[OF axy])
  also have "\<dots> =   t\<^sub>p [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
          (let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y]))
              in T\<^sub>p L (rest1) (OPT2 (rest1) L))" by(simp)
  finally show ?thesis .
qed

lemma tpx: "t\<^sub>p [x, y] x (hd (OPT2 (x # rest1) [x, y])) = 0"
by (simp add: OPT2x t\<^sub>p_def)

lemma yup: "T\<^sub>p [x, y] (x # rest1) (OPT2 (x # rest1) [x, y])
        = (let L=step [x,y] x (hd (OPT2 (x # rest1) [x, y]))
              in T\<^sub>p L (rest1) (OPT2 (rest1) L))"
by (simp add: splitqs tpx)

lemma swapsxy: "A \<in> { [x,y], [y,x]} \<Longrightarrow> swaps sws A \<in> { [x,y], [y,x]}"
apply(induct sws)
  apply(simp)
  apply(simp) unfolding swap_def by auto

lemma mtf2xy: "A \<in> { [x,y], [y,x]} \<Longrightarrow> r\<in>{x,y} \<Longrightarrow> mtf2 a r A \<in> { [x,y], [y,x]}"
by (metis mtf2_def swapsxy)

lemma stepxy: assumes "q \<in> {x,y}" "A \<in> { [x,y], [y,x]}"
    shows "step A q a \<in> { [x,y], [y,x]}"
unfolding step_def apply(simp only: split_def Let_def)
apply(rule mtf2xy)
  apply(rule swapsxy) by fact+

subsection "Proof of Optimality"

lemma OPT2_is_lb: "set \<sigma> \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] \<sigma> (OPT2 \<sigma> [x,y]) \<le> T\<^sub>p_opt [x,y] \<sigma>"
proof (induct "length \<sigma>" arbitrary: x y \<sigma> rule: less_induct)
  case (less)
  show ?case
  proof (cases \<sigma>)
    case (Cons a \<sigma>')
    note Cons1=Cons
    show ?thesis unfolding Cons
      proof(cases "a=x") (* case that the element in front is requested *)
        case True
        from True Cons have qsform: "\<sigma> = x#\<sigma>'" by auto
        have up: "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (x # \<sigma>')"
          unfolding True
          unfolding T_opt_def apply(rule cInf_greatest)
            apply(simp add: Ex_list_of_length)
            proof -
              fix el
              assume "el \<in> {T\<^sub>p [x, y] (x # \<sigma>') as |as. length as = length (x # \<sigma>')}"
              then obtain Strat where lStrat: "length Strat = length (x # \<sigma>')"
                        and el: "T\<^sub>p [x, y] (x # \<sigma>') Strat = el" by auto
              then have ne: "Strat \<noteq> []" by auto
              let ?LA="step [x,y] x (hd (OPT2 (x # \<sigma>') [x, y]))"

              have  E0:  "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y])
                            =T\<^sub>p ?LA (\<sigma>') (OPT2 (\<sigma>') ?LA)" using yup by auto
              also have E1: "\<dots> = T\<^sub>p [x,y] (\<sigma>') (OPT2 (\<sigma>') [x,y])" by (simp add: OPT2x step_def)
              also have E2: "\<dots> \<le>  T\<^sub>p_opt [x,y] \<sigma>'" apply(rule less(1)) using Cons less(2,3) by auto
              also have "\<dots> \<le> T\<^sub>p [x, y] (x # \<sigma>') Strat"
                   proof (cases "(step [x, y] x (hd Strat)) = [x,y]")
                      case True
                      have aha: "T\<^sub>p_opt [x, y] \<sigma>' \<le> T\<^sub>p [x, y] \<sigma>' (tl Strat)"
                        unfolding T_opt_def apply(rule cInf_lower)
                          apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto

                      also have E4: "\<dots> \<le> t\<^sub>p [x, y] x (hd Strat) + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)"
                        unfolding True by(simp)
                      also have E5: "\<dots> = T\<^sub>p [x, y] (x # \<sigma>') Strat" using splitqsallg[of Strat x x y \<sigma>', OF ne, simplified]
                        by (auto)
                      finally show ?thesis by auto
                   next
                      case False
                      have tp1: "t\<^sub>p [x, y] x (hd Strat) \<ge> 1"
                      proof (rule ccontr)
                        let ?a = "hd Strat"
                        assume "\<not> 1 \<le> t\<^sub>p [x, y] x ?a"
                        then have tp0: "t\<^sub>p [x, y] x ?a = 0" by auto
                        then have "size (snd ?a) = 0" unfolding t\<^sub>p_def by(simp add: split_def)
                        then have nopaid: "(snd ?a) = []" by auto
                        have "step [x, y] x ?a = [x, y]"
                          unfolding step_def apply(simp add: split_def nopaid)
                          unfolding mtf2_def by(simp)
                        then show "False" using False by auto
                      qed

                      from False have yx: "step [x, y] x (hd Strat) = [y, x]"
                        using stepxy[where x=x and y=y and a="hd Strat"] by auto

                      have E3: "T\<^sub>p_opt [x, y] \<sigma>' \<le> 1 + T\<^sub>p_opt [y, x] \<sigma>'" using swapOpt by auto
                      also have E4: "\<dots> \<le> 1 + T\<^sub>p [y, x] \<sigma>' (tl Strat)"
                        apply(simp) unfolding T_opt_def apply(rule cInf_lower)
                          apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto
                      also have E5: "\<dots> = 1 + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)" using yx by auto
                      also have E6: "\<dots> \<le> t\<^sub>p [x, y] x (hd Strat) + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)" using tp1 by auto

                      also have E7: "\<dots> = T\<^sub>p [x, y] (x # \<sigma>') Strat" using splitqsallg[of Strat x x y \<sigma>', OF ne, simplified]
                         by (auto)
                      finally show ?thesis by auto
                   qed
              also have "\<dots> = el" using True el by simp
              finally show "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y]) \<le> el" by auto
            qed
         then show "T\<^sub>p [x, y] (a # \<sigma>') (OPT2 (a # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (a # \<sigma>')"
         using True by simp
      next

        case False (* case 2: element at back is requested first *)
        with less Cons have ay: "a=y" by auto
        show "T\<^sub>p [x, y] (a # \<sigma>') (OPT2 (a # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (a # \<sigma>')" unfolding ay
        proof(cases \<sigma>')
          case Nil
          have up: "T\<^sub>p_opt [x, y] [y] \<ge> 1"
            unfolding T_opt_def apply(rule cInf_greatest)
            apply(simp add: Ex_list_of_length)
            proof -
              fix el
              assume "el \<in> {T\<^sub>p [x, y] [y] as |as. length as = length [y]}"
              then obtain Strat where Strat: "length Strat = length [y]" and
                            el: "el = T\<^sub>p [x, y] [y] Strat " by auto
              from Strat obtain a where a: "Strat = [a]" by (metis Suc_length_conv length_0_conv)
              show "1 \<le> el" unfolding el a apply(simp) unfolding t\<^sub>p_def apply(simp add: split_def)
                apply(cases "snd a")
                  apply(simp add: less(3))
                  by(simp)
            qed

          show "T\<^sub>p [x, y] (y # \<sigma>') (OPT2 (y # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (y # \<sigma>')" unfolding Nil
            apply(simp add: t\<^sub>p_def) using less(3) apply(simp)
            using up by(simp)
        next
          case (Cons b rest2)

          show up: "T\<^sub>p [x, y] (y # \<sigma>') (OPT2 (y # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (y # \<sigma>')"
            unfolding Cons
          proof (cases "b=x")
            case True

            show "T\<^sub>p [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y]) \<le> T\<^sub>p_opt [x, y] (y # b # rest2)"
              unfolding True
              unfolding T_opt_def apply(rule cInf_greatest)
                apply(simp add: Ex_list_of_length)
                proof -
                  fix el
                  assume "el \<in> {T\<^sub>p [x, y] (y # x # rest2) as |as. length as = length (y # x # rest2)}"
                  then obtain Strat where lenStrat: "length Strat = length (y # x # rest2)" and
                               Strat: "el = T\<^sub>p [x, y] (y # x # rest2) Strat" by auto
                  have v: " set rest2 \<subseteq> {x, y}" using less(2)[unfolded Cons1 Cons] by auto

                  let ?L1 = "(step [x, y] y (hd Strat))"
                  let ?L2 = "(step ?L1 x (hd (tl Strat)))"

                  (* lets work on how Strat can look like: *)
                  let ?a1 = "hd Strat"
                  let ?a2 = "hd (tl Strat)"
                  let ?r = "tl (tl Strat)"

                  have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)

                  have 1: "T\<^sub>p [x, y] (y # x # rest2) Strat
                        = t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p ?L2 rest2 (tl (tl Strat))"
                    proof -
                      have a: "Strat \<noteq> []" using lenStrat by auto
                      have b: "(tl Strat) \<noteq> []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

                      have 1: "T\<^sub>p [x, y] (y # x # rest2) Strat
                                = t\<^sub>p [x, y] y (hd Strat) + T\<^sub>p ?L1 (x # rest2) (tl Strat)"
                                  using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
                      have tt: "step [x, y] y (hd Strat) \<noteq> [x, y] \<Longrightarrow> step [x, y] y (hd Strat) = [y,x]"
                        using stepxy[where A="[x,y]"] by blast

                      have 2: "T\<^sub>p ?L1 (x # rest2) (tl Strat) = t\<^sub>p ?L1 x (hd (tl Strat)) +  T\<^sub>p ?L2 (rest2) (tl (tl Strat))"
                                  apply(cases "?L1=[x,y]")
                                    using splitqsallg[OF b, where a=x and x=x and y=y, simplified] apply(auto)
                                    using tt splitqsallg[OF b, where a=x and x=y and y=x, simplified] by auto
                      from 1 2 show ?thesis by auto
                    qed

                  have " T\<^sub>p [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y])
                    =  1 +  T\<^sub>p [x, y] (rest2) (OPT2 (rest2) [x, y])"
                    unfolding True
                    using less(3) by(simp add: t\<^sub>p_def step_def OPT2x)
                  also have "\<dots> \<le> 1 +  T\<^sub>p_opt [x, y] (rest2)" apply(simp)
                    apply(rule less(1))
                      apply(simp add: less(2) Cons1 Cons)
                      apply(fact) by fact
                  also

                  have "\<dots> \<le> T\<^sub>p [x, y] (y # x # rest2) Strat"
                  proof (cases "?L2 = [x,y]")
                    case True
                    have 2: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p [x,y] rest2 (tl (tl Strat)) \<ge> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p_opt [x,y] rest2" apply(simp)
                            unfolding T_opt_def apply(rule cInf_lower)
                            apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
                    have 3: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p_opt [x,y] rest2 \<ge> 1 + T\<^sub>p_opt [x,y] rest2" apply(simp)
                            proof -
                              have "t\<^sub>p [x, y] y (hd Strat) \<ge> 1"
                              unfolding t\<^sub>p_def apply(simp add: split_def)
                              apply(cases "snd (hd Strat)") by (simp_all add: less(3))
                              then show "Suc 0 \<le> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))" by auto
                            qed
                    from 1 2 3 True show ?thesis by auto
                  next
                    case False
                    note L2F=this
                    have L1: "?L1 \<in> {[x, y], [y, x]}" apply(rule stepxy) by simp_all
                    have "?L2 \<in> {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
                    with False have 2: "?L2 = [y,x]" by auto

                    have k: "T\<^sub>p [x, y] (y # x # rest2) Strat
                        =   t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat)) +
                            T\<^sub>p [y,x] rest2 (tl (tl Strat))" using 1 2 by auto

                    have l: "t\<^sub>p [x, y] y (hd Strat) > 0"
                        using less(3) unfolding t\<^sub>p_def apply(cases "snd (hd Strat) = []")
                          by (simp_all add: split_def)

                    have r: "T\<^sub>p [x, y] (y # x # rest2) Strat \<ge> 2 + T\<^sub>p [y,x] rest2 (tl (tl Strat))"
                    proof (cases "?L1 = [x,y]")
                      case True
                      note T=this
                      then have "t\<^sub>p ?L1 x (hd (tl Strat)) > 0" unfolding True
                        proof(cases "snd (hd (tl Strat)) = []")
                          case True
                          have "?L2 = [x,y]" unfolding T  apply(simp add: split_def step_def)
                          unfolding True mtf2_def by(simp)
                          with L2F have "False" by auto
                          then show "0 < t\<^sub>p [x, y] x (hd (tl Strat))" ..
                        next
                          case False
                          then show "0 < t\<^sub>p [x, y] x (hd (tl Strat))"
                            unfolding t\<^sub>p_def by(simp add: split_def)
                        qed
                      with l have " t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat)) \<ge> 2" by auto
                      with k show ?thesis by auto
                    next
                      case False
                      from L1 False have 2: "?L1 = [y,x]" by auto
                      { fix k sws T
                        have "T\<in>{[x,y],[y,x]} \<Longrightarrow> mtf2 k x T = [y,x] \<Longrightarrow> T = [y,x]"
                          apply(rule ccontr) by (simp add: less(3) mtf2_def)
                      }
                      have t1: "t\<^sub>p [x, y] y (hd Strat) \<ge> 1" unfolding t\<^sub>p_def apply(simp add: split_def)
                        apply(cases "(snd (hd Strat))") using \<open>x \<noteq> y\<close> by auto
                      have t2: "t\<^sub>p [y,x] x (hd (tl Strat)) \<ge> 1" unfolding t\<^sub>p_def apply(simp add: split_def)
                        apply(cases "(snd (hd (tl Strat)))") using \<open>x \<noteq> y\<close> by auto
                      have "T\<^sub>p [x, y] (y # x # rest2) Strat
                          = t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p (step [x, y] y (hd Strat)) x (hd (tl Strat)) + T\<^sub>p [y, x] rest2 (tl (tl Strat))"
                            by(rule k)
                      with t1 t2 2 show ?thesis by auto
                    qed
                    have t: "T\<^sub>p [y, x] rest2 (tl (tl Strat)) \<ge> T\<^sub>p_opt [y, x] rest2"
                      unfolding T_opt_def apply(rule cInf_lower)
                      apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
                    show ?thesis
                    proof -
                      have "1 + T\<^sub>p_opt [x, y] rest2 \<le> 2 + T\<^sub>p_opt [y, x] rest2"
                      using  swapOpt by auto
                      also have "\<dots> \<le> 2 + T\<^sub>p [y, x] rest2 (tl (tl Strat))" using t by auto
                      also have "\<dots> \<le> T\<^sub>p [x, y] (y # x # rest2) Strat" using r by auto
                      finally show ?thesis .
                    qed

                  qed
                  also have "\<dots> = el" using Strat by auto
                  finally show "T\<^sub>p [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y]) \<le> el" .
                qed

          next
            case False
            with Cons1 Cons less(2) have bisy: "b=y" by auto
            with less(3) have "OPT2 (y # b # rest2) [x, y] = (1,[])# (OPT2 (b#rest2) [y,x])" by simp
            show "T\<^sub>p [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y]) \<le> T\<^sub>p_opt [x, y] (y # b # rest2)"
              unfolding bisy
              unfolding T_opt_def apply(rule cInf_greatest)
                apply(simp add: Ex_list_of_length)
                proof -
                  fix el
                  assume "el \<in> {T\<^sub>p [x, y] (y # y # rest2) as |as. length as = length (y # y # rest2)}"
                  then obtain Strat where lenStrat: "length Strat = length (y # y # rest2)" and
                               Strat: "el = T\<^sub>p [x, y] (y # y # rest2) Strat" by auto
                  have v: " set rest2 \<subseteq> {x, y}" using less(2)[unfolded Cons1 Cons] by auto

                  let ?L1 = "(step [x, y] y (hd Strat))"
                  let ?L2 = "(step ?L1 y (hd (tl Strat)))"

                  (* lets work on how Strat can look like: *)
                  let ?a1 = "hd Strat"
                  let ?a2 = "hd (tl Strat)"
                  let ?r = "tl (tl Strat)"

                  have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)

                  have 1: "T\<^sub>p [x, y] (y # y # rest2) Strat
                        = t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p ?L2 rest2 (tl (tl Strat))"
                    proof -
                      have a: "Strat \<noteq> []" using lenStrat by auto
                      have b: "(tl Strat) \<noteq> []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

                      have 1: "T\<^sub>p [x, y] (y # y # rest2) Strat
                                = t\<^sub>p [x, y] y (hd Strat) + T\<^sub>p ?L1 (y # rest2) (tl Strat)"
                                  using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
                      have tt: "step [x, y] y (hd Strat) \<noteq> [x, y] \<Longrightarrow> step [x, y] y (hd Strat) = [y,x]"
                        using stepxy[where A="[x,y]"] by blast

                      have 2: "T\<^sub>p ?L1 (y # rest2) (tl Strat) = t\<^sub>p ?L1 y (hd (tl Strat)) +  T\<^sub>p ?L2 (rest2) (tl (tl Strat))"
                                  apply(cases "?L1=[x,y]")
                                    using splitqsallg[OF b, where a=y and x=x and y=y, simplified] apply(auto)
                                    using tt splitqsallg[OF b, where a=y and x=y and y=x, simplified] by auto
                      from 1 2 show ?thesis by auto
                    qed

                  have " T\<^sub>p [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y])
                    =  1 +  T\<^sub>p [y, x] (rest2) (OPT2 (rest2) [y, x])"
                    using less(3) by(simp add: t\<^sub>p_def step_def mtf2_def swap_def OPT2x)
                  also have "\<dots> \<le> 1 +  T\<^sub>p_opt [y, x] (rest2)" apply(simp)
                    apply(rule less(1))
                      apply(simp add: less(2) Cons1 Cons)
                      using v less(3) by(auto)
                  also

                  have "\<dots> \<le> T\<^sub>p [x, y] (y # y # rest2) Strat"
                  proof (cases "?L2 = [y,x]")
                    case True
                    have 2: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p [y,x] rest2 (tl (tl Strat)) \<ge> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p_opt [y,x] rest2" apply(simp)
                            unfolding T_opt_def apply(rule cInf_lower)
                            apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
                    have 3: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p_opt [y,x] rest2 \<ge> 1 + T\<^sub>p_opt [y,x] rest2" apply(simp)
                            proof -
                              have "t\<^sub>p [x, y] y (hd Strat) \<ge> 1"
                              unfolding t\<^sub>p_def apply(simp add: split_def)
                              apply(cases "snd (hd Strat)") by (simp_all add: less(3))
                              then show "Suc 0 \<le> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))" by auto
                            qed
                    from 1 2 3 True show ?thesis by auto
                  next
                    case False
                    note L2F=this
                    have L1: "?L1 \<in> {[x, y], [y, x]}" apply(rule stepxy) by simp_all
                    have "?L2 \<in> {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
                    with False have 2: "?L2 = [x,y]" by auto

                    have k: "T\<^sub>p [x, y] (y # y # rest2) Strat
                        =   t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat)) +
                            T\<^sub>p [x,y] rest2 (tl (tl Strat))" using 1 2 by auto

                    have l: "t\<^sub>p [x, y] y (hd Strat) > 0"
                        using less(3) unfolding t\<^sub>p_def apply(cases "snd (hd Strat) = []")
                          by (simp_all add: split_def)

                    have r: "T\<^sub>p [x, y] (y # y # rest2) Strat \<ge> 2 + T\<^sub>p [x,y] rest2 (tl (tl Strat))"
                    proof (cases "?L1 = [y,x]")
                      case False
                      from L1 False have "?L1 = [x,y]" by auto
                      note T=this
                      then have "t\<^sub>p ?L1 y (hd (tl Strat)) > 0" unfolding T
                      unfolding t\<^sub>p_def apply(simp add: split_def)
                        apply(cases "snd (hd (tl Strat)) = []")
                          using \<open>x \<noteq> y\<close> by auto
                      with l k show ?thesis by auto
                    next

                      case True
                      note T=this

                        have "t\<^sub>p ?L1 y (hd (tl Strat)) > 0" unfolding T
                        proof(cases "snd (hd (tl Strat)) = []")
                          case True
                          have "?L2 = [y,x]" unfolding T  apply(simp add: split_def step_def)
                          unfolding True mtf2_def by(simp)
                          with L2F have "False" by auto
                          then show "0 < t\<^sub>p [y, x] y (hd (tl Strat))" ..
                        next
                          case False
                          then show "0 < t\<^sub>p [y, x] y (hd (tl Strat))"
                            unfolding t\<^sub>p_def by(simp add: split_def)
                        qed
                      with l have " t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat)) \<ge> 2" by auto
                      with k show ?thesis by auto

                    qed
                    have t: "T\<^sub>p [x, y] rest2 (tl (tl Strat)) \<ge> T\<^sub>p_opt [x, y] rest2"
                      unfolding T_opt_def apply(rule cInf_lower)
                      apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
                    show ?thesis
                    proof -
                      have "1 + T\<^sub>p_opt [y, x] rest2 \<le> 2 + T\<^sub>p_opt [x, y] rest2"
                      using  swapOpt by auto
                      also have "\<dots> \<le> 2 + T\<^sub>p [x, y] rest2 (tl (tl Strat))" using t by auto
                      also have "\<dots> \<le> T\<^sub>p [x, y] (y # y # rest2) Strat" using r by auto
                      finally show ?thesis .
                    qed

                  qed
                  also have "\<dots> = el" using Strat by auto
                  finally show "T\<^sub>p [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y]) \<le> el" .
                qed
          qed
        qed
     qed
  qed (simp add: T_opt_def)
qed

lemma OPT2_is_ub: "set qs \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) \<ge> T\<^sub>p_opt [x,y] qs"
  unfolding T_opt_def apply(rule cInf_lower)
            apply(simp) apply(rule exI[where x="(OPT2 qs [x, y])"])
            by (auto simp add: OPT2_length)

lemma OPT2_is_opt: "set qs \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = T\<^sub>p_opt [x,y] qs"
by (simp add: OPT2_is_lb OPT2_is_ub antisym)

subsection "Performance on the four phase forms"

lemma OPT2_A: assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = 1"
proof -
  from assms(2) obtain u v where qs: "qs=u@v" and u: "u=[x] \<or> u=[]" and v: "v = [y,y]" by (auto simp: conc_def)
  from u have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x t\<^sub>p_def step_def)

  have ende: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1" unfolding v using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

  from pref1 ende qs show ?thesis by auto
qed

lemma OPT2_A': assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = 1"
using OPT2_A[OF assms] by simp

lemma OPT2_B: assumes "x \<noteq> y" "qs=u@v" "u=[] \<or> u=[x]" "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
proof -
  from assms(3) have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x t\<^sub>p_def step_def)

  from assms(4) obtain a w where v: "v=a@w" and "a\<in>lang (Times (Atom y) (Atom x))" and w: "w\<in>lang (seq[Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto)
  from this(2) have aa: "a=[y,x]" by(simp add: conc_def)

  from assms(1) this v have pref2: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1 + T\<^sub>p [x,y] w (OPT2 w [x,y])"
   by(simp add: t\<^sub>p_def step_def OPT2x)

  from w obtain c d where w2: "w=c@d" and c: "c \<in> lang (Star (Times (Atom y) (Atom x)))" and d: "d \<in> lang (Times (Atom y) (Atom y))" by auto
  then have dd: "d=[y,y]" by auto

  from c[simplified] have star: "T\<^sub>p [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) +  T\<^sub>p [x,y] d (OPT2 d [x,y])"
    proof(induct c rule: star_induct)
      case (append r s)
      then have r: "r=[y,x]" by auto
      then have "T\<^sub>p [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = T\<^sub>p [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
      also have "\<dots> = 1 + T\<^sub>p [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
        using assms(1) by(simp add: t\<^sub>p_def step_def OPT2x)
      also have "\<dots> =  1 + length s div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using append by simp
      also have "\<dots> =  length (r @ s) div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using r by auto
      finally show ?case .
    qed simp

  have ende: "T\<^sub>p [x,y] d (OPT2 d [x,y]) = 1" unfolding dd using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

  have vv: "v = [y,x]@c@[y,y]" using w2 dd v aa by auto

  from pref1 pref2 star w2 ende have
    "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2 + 1" unfolding assms(2) by auto
  also have "\<dots> = (length v div 2)" using vv by auto
  finally show ?thesis .
qed

lemma OPT2_B1: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = length qs / 2"
proof -
  from assms(2) have qs: "qs \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
    by(simp add: conc_assoc)
  have "(length qs) mod 2 = 0"
  proof -
    from assms(2) have "qs \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "qs=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length qs = 4+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)
    from a b show ?thesis by auto
  qed
  with OPT2_B[where u="[]", OF assms(1) _ _ qs] show ?thesis by auto
qed

lemma OPT2_B2: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = ((length qs - 1) / 2)"
proof -
  from assms(2) obtain v where
      qsv: "qs = [x]@v" and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by (auto simp add: conc_def)
  have "(length v) mod 2 = 0"
  proof -
    from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by(auto simp add: conc_def)
    with pqr have a: "length v = 4+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)
    from a b show ?thesis by auto
  qed
  with OPT2_B[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis by(auto)
qed

lemma OPT2_C: assumes "x \<noteq> y" "qs=u@v" "u=[] \<or> u=[x]"
  and "v \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
proof -
  from assms(3) have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x t\<^sub>p_def step_def)

  from assms(4) obtain a w where v: "v=a@w" and aa: "a=[y,x]" and w: "w\<in>lang (seq[Star(Times (Atom y) (Atom x)), Atom x])" by(auto simp: conc_def)

  from assms(1) this v have pref2: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1 + T\<^sub>p [x,y] w (OPT2 w [x,y])"
   by(simp add: t\<^sub>p_def step_def OPT2x)

  from w obtain c d where w2: "w=c@d" and c: "c \<in> lang (Star (Times (Atom y) (Atom x)))" and d: "d \<in> lang (Atom x)" by auto
  then have dd: "d=[x]" by auto

  from c[simplified] have star: "T\<^sub>p [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) +  T\<^sub>p [x,y] d (OPT2 d [x,y]) \<and> (length c) mod 2 = 0"
    proof(induct c rule: star_induct)
      case (append r s)
      from append have mod: "length s mod 2 = 0" by simp
      from append have r: "r=[y,x]" by auto
      then have "T\<^sub>p [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = T\<^sub>p [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
      also have "\<dots> = 1 + T\<^sub>p [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
        using assms(1) by(simp add: t\<^sub>p_def step_def OPT2x)
      also have "\<dots> =  1 + length s div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using append by simp
      also have "\<dots> =  length (r @ s) div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using r by auto
      finally show ?case by(simp add: mod r)
    qed simp

  have ende: "T\<^sub>p [x,y] d (OPT2 d [x,y]) = 0" unfolding dd using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

  have vv: "v = [y,x]@c@[x]" using w2 dd v aa by auto

  from pref1 pref2 star w2 ende have
    "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2" unfolding assms(2) by auto
  also have "\<dots> = (length v div 2)" using vv star by auto
  finally show ?thesis .
qed

lemma OPT2_C1: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = (length qs - 1) / 2"
proof -
  from assms(2) have qs: "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
    by(simp add: conc_assoc)
  have "(length qs) mod 2 = 1"
  proof -
    from assms(2) have "qs \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "qs=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[x]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[x]" by auto
    with pqr have a: "length qs = 3+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)
    from a b show ?thesis by auto
  qed
  with OPT2_C[where u="[]", OF assms(1) _ _ qs] show ?thesis apply auto
      by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral)
qed

lemma OPT2_C2: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = ((length qs - 2) / 2)"
proof -
  from assms(2) obtain v where
      qsv: "qs = [x]@v" and vv: "v \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])" by (auto simp add: conc_def)
  have "(length v) mod 2 = 1"
  proof -
    from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[x]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[x]" by(auto simp add: conc_def)
    with pqr have a: "length v = 3+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)
    from a b show ?thesis by auto
  qed
  with OPT2_C[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis apply(auto)
      by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral)
qed

lemma OPT2_ub: "set qs \<subseteq> {x,y} \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) \<le> length qs"
proof(induct qs arbitrary: x y)
  case (Cons q qs)
  then have "set qs \<subseteq> {x,y}" "q\<in>{x,y}" by auto
  note Cons1=Cons this
  show ?case
  proof (cases qs)
    case Nil
    with Cons1 show "T\<^sub>p [x,y] (q # qs) (OPT2 (q # qs) [x,y]) \<le> length (q # qs)"
        apply(simp add: t\<^sub>p_def) by blast
  next
    case (Cons q' qs')
    with Cons1 have "q'\<in>{x,y}" by auto
    note Cons=Cons this

    from Cons1 Cons have T: "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) \<le> length qs"
                            "T\<^sub>p [y, x] qs (OPT2 qs [y, x]) \<le> length qs" by auto
    show "T\<^sub>p [x,y] (q # qs) (OPT2 (q # qs) [x,y]) \<le> length (q # qs)"
          unfolding Cons apply(simp only: OPT2.simps)
          apply(split if_splits(1))
            apply(safe)
            proof (goal_cases)
              case 1
              have "T\<^sub>p [x, y] (x # q' # qs') ((0, []) # OPT2 (q' # qs') [x, y])
                      = t\<^sub>p [x, y] x (0,[]) + T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
                        by(simp add: step_def Cons)
              also have "\<dots> \<le> t\<^sub>p [x, y] x (0,[]) + length qs" using T by auto
              also have "\<dots> \<le> length (x # q' # qs')" using Cons by(simp add: t\<^sub>p_def)
              finally show ?case .
            next
              case 2
              with Cons1 Cons show ?case
                apply(split if_splits(1))
                apply(safe)
                proof (goal_cases)
                  case 1
                  then have "T\<^sub>p [x, y] (y # x # qs') ((0, []) # OPT2 (x # qs') [x, y])
                          = t\<^sub>p [x, y] y (0,[]) + T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
                            by(simp add: step_def)
                  also have "\<dots> \<le> t\<^sub>p [x, y] y (0,[]) + length qs" using T by auto
                  also have "\<dots> \<le> length (y # x # qs')" using Cons by(simp add: t\<^sub>p_def)
                  finally show ?case .
                next
                  case 2
                  then have "T\<^sub>p [x, y] (y # y # qs') ((1, []) # OPT2 (y # qs') [y, x])
                          = t\<^sub>p [x, y] y (1,[]) + T\<^sub>p [y, x] qs (OPT2 qs [y, x])"
                            by(simp add: step_def mtf2_def swap_def)
                  also have "\<dots> \<le> t\<^sub>p [x, y] y (1,[]) + length qs" using T by auto
                  also have "\<dots> \<le> length (y # y # qs')" using Cons by(simp add: t\<^sub>p_def)
                  finally show ?case .
                qed
           qed
  qed
qed simp

lemma OPT2_padded: "R\<in>{[x,y],[y,x]} \<Longrightarrow> set qs \<subseteq> {x,y}
      \<Longrightarrow>  T\<^sub>p R (qs@[x,x]) (OPT2 (qs@[x,x]) R)
              \<le> T\<^sub>p R (qs@[x]) (OPT2 (qs@[x]) R) + 1"
apply(induct qs arbitrary: R)
  apply(simp)
    apply(case_tac "R=[x,y]")
      apply(simp add: step_def t\<^sub>p_def )
      apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
  proof (goal_cases)
    case (1 a qs R)
    then have a: "a \<in> {x,y}" by auto
    with 1 show ?case
      apply(cases qs)
        apply(cases "a=x")
          apply(cases "R=[x,y]")
            apply(simp add: step_def t\<^sub>p_def)
            apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
          apply(cases "R=[x,y]")
            apply(simp add: step_def t\<^sub>p_def)
            apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
      proof (goal_cases)
        case (1 p ps)
        show ?case
          apply(cases "a=x")
            apply(cases "R=[x,y]")
              apply(simp add: OPT2x step_def) using 1 apply(simp)
              using 1(2) apply(simp)
                apply(cases qs)
                  apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
                  using 1 by(auto simp add: swap_def mtf2_def step_def)
       qed
qed

lemma  OPT2_split11:
  assumes xy: "x\<noteq>y"
  shows "R\<in>{[x,y],[y,x]} \<Longrightarrow> set xs \<subseteq> {x,y} \<Longrightarrow> set ys \<subseteq> {x,y} \<Longrightarrow> OPT2 (xs@[x,x]@ys) R = OPT2 (xs@[x,x]) R @ OPT2 ys [x,y]"
proof (induct xs arbitrary: R)
  case Nil
  then show ?case
  apply(simp)
  apply(cases ys)
    apply(simp)
    apply(cases "R=[x,y]")
      apply(simp)
      by(simp)
next
  case (Cons a as)
  note iH=this
  then have AS: "set as \<subseteq> {x,y}" and A: "a \<in> {x,y}" by auto
  note iH=Cons(1)[where R="[y,x]", simplified, OF AS Cons(4)]
  note iH'=Cons(1)[where R="[x,y]", simplified, OF AS Cons(4)]
  show ?case
  proof (cases "R=[x,y]")
    case True
    note R=this
    from iH iH' show ?thesis
    apply(cases "a=x")
      apply(simp add: R OPT2x)
      using A apply(simp)
      apply(cases as)
        apply(simp add: R)
        using AS apply(simp)
        apply(case_tac "aa=x")
          by(simp_all add: R)
  next
    case False
    with Cons(2) have R: "R=[y,x]" by auto
    from iH iH' show ?thesis
    apply(cases "a=y")
      apply(simp add: R OPT2x)
      using A apply(simp)
      apply(cases as)
        apply(simp add: R)
        apply(case_tac "aa=y")
          by (simp_all add: R)
   qed
qed

subsection "The function steps"

lemma steps_append: "length qs = length as \<Longrightarrow> steps s (qs@[q]) (as@[a]) = step (steps s qs as) q a"
apply(induct qs as arbitrary: s rule: list_induct2) by simp_all

end


theory SolverInfer
  imports InferSound InferComplete SolverP3
begin

fun no_mem_val where
  "no_mem_val (VarExp x) = (case x of
    VarType x \<Rightarrow> True
    | LocType x y \<Rightarrow> False
  )"
| "no_mem_val (PairExp e1 e2) = (no_mem_val e1 \<and> no_mem_val e2)"
| "no_mem_val (IfExp e1 e2 e3) = (no_mem_val e1 \<and> no_mem_val e2 \<and> no_mem_val e3)"
| "no_mem_val (LamExp x e) = no_mem_val e"
| "no_mem_val (AppExp e1 e2) = (no_mem_val e1 \<and> no_mem_val e2)"
| "no_mem_val e = True"

definition unique_env where
  "unique_env env_v = (\<forall> x. case env_v x of
    None \<Rightarrow> True
    | Some a \<Rightarrow> (\<forall> y. case env_v y of
      None \<Rightarrow> True
      | Some b \<Rightarrow> x = y \<or> a \<noteq> b
    )
  )"

definition dom_cover where
  "dom_cover env_v ds = (\<forall> x. x \<in> ds \<longrightarrow> env_v x \<noteq> None)"

definition dom_ex_cover where
  "dom_ex_cover env_v ds = (\<forall> x. (x \<in> ds) = (env_v x \<noteq> None))"

definition same_dom_env where
  "same_dom_env env_v env = (\<forall> x. (env_v x = None) = (env x = None))"

definition rev_map where
  "rev_map env_v = (\<lambda> a. { x | x. env_v x = Some a })"

definition unique_rev_map where
  "unique_rev_map f f' = (\<forall> a. f a \<subseteq> {f' a})"

lemma unique_rev_map_ex: "\<lbrakk> unique_env env_v \<rbrakk> \<Longrightarrow> (\<exists> f. unique_rev_map (rev_map env_v) f)"
  apply (simp add: unique_rev_map_def)
  apply (rule_tac Hilbert_Choice.choice)
  apply (auto)
  apply (simp add: unique_env_def)
  apply (case_tac "\<exists> x. env_v x = Some a")
   apply (auto)
   apply (erule_tac x="x" in allE)
   apply (auto)
   apply (rule_tac x="x" in exI)
   apply (simp add: rev_map_def)
   apply (auto)
   apply (erule_tac x="xa" in allE)
   apply (auto)
  apply (simp add: rev_map_def)
  done

lemma unique_spec_env: "\<lbrakk> same_dom_env env_v env; unique_env env_v \<rbrakk> \<Longrightarrow> (\<exists> t_sub. spec_env env_v env t_sub)"
  apply (cut_tac env_v="env_v" in unique_rev_map_ex)
   apply (auto)
  apply (rule_tac x="\<lambda> x. env (f x)" in exI)
  apply (simp add: spec_env_def)
  apply (auto)
  apply (simp add: same_dom_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "env_v x")
   apply (auto)
  apply (simp add: unique_rev_map_def)
  apply (simp add: rev_map_def)
  apply (erule_tac x="a" in allE)
  apply (auto)
  done

lemma restr_spec_env: "\<lbrakk> spec_env env_v env t_sub; sub_range env_v ds \<rbrakk> \<Longrightarrow> \<exists> t_subx. (spec_env env_v env t_subx \<and> tsub_dom t_subx ds)"
  apply (rule_tac x="\<lambda> x. if x \<in> ds then t_sub x else None" in exI)
  apply (auto)
   apply (simp add: spec_env_def)
   apply (auto)
   apply (erule_tac x="x" in allE)
   apply (case_tac "env_v x")
    apply (auto)
   apply (simp add: sub_range_def)
   apply (erule_tac x="x" in allE)
   apply (auto)
  apply (simp add: tsub_dom_def)
  done

definition set_restr_env where
  "set_restr_env env ds = (\<lambda> x. if x \<in> ds then env x else None)"

fun all_vars :: "p_exp \<Rightarrow> res_id set" where
  "all_vars (ConstExp c) = {}"
| "all_vars (OpExp xop) = {}"
| "all_vars (VarExp v) = (case v of
  VarType x \<Rightarrow> {Var x}
  | LocType x y \<Rightarrow> {Loc x, Loc y}
)"
| "all_vars (PairExp e1 e2) = all_vars e1 \<union> all_vars e2"
| "all_vars (IfExp e1 e2 e3) = all_vars e1 \<union> all_vars e2 \<union> all_vars e3"
| "all_vars (LamExp x e) = all_vars e - {Var x}"
| "all_vars (AppExp e1 e2) = all_vars e1 \<union> all_vars e2"

lemma add_set_restr_env: "add_env (set_restr_env env ds) x tau = set_restr_env (add_env env x tau) (ds \<union> {x})"
  apply (case_tac "\<forall> x'. add_env (set_restr_env env ds) x tau x' = set_restr_env (add_env env x tau) (ds \<union> {x}) x'")
   apply (auto)
  apply (simp add: add_env_def)
  apply (simp add: set_restr_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: set_restr_env_def)
  apply (case_tac "x' \<in> ds")
   apply (auto)
  done

lemma well_typed_set_restr: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; all_vars e \<subseteq> ds \<rbrakk> \<Longrightarrow>
  well_typed (set_restr_env env ds) r_s1 e tau r_s2 rx"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx ds)
        apply (auto)
    (* var case *)
       apply (simp add: set_restr_env_def)
       apply (case_tac x)
        apply (auto)
      apply (simp add: set_restr_env_def)
      apply (case_tac x)
       apply (auto)
    (* pair case *)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (auto)
    (* if case *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="r_s2a" in exI)
    apply (auto)
    apply (rule_tac x="rx1" in exI)
    apply (auto)
    apply (rule_tac x="rx2" in exI)
    apply (auto)
    (* lam case *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="r_end" in exI)
   apply (rule_tac x="r_s'" in exI)
   apply (simp add: add_set_restr_env)
   apply (case_tac "\<not> (all_vars e \<subseteq> ds \<union> {Var x1a})")
    apply (auto)
    (* app case *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (auto)
  done

lemma add_dom_cover: "\<lbrakk> dom_cover (add_env env x tau) ds \<rbrakk> \<Longrightarrow> dom_cover env (ds - {x})"
  apply (simp add: dom_cover_def)
  apply (auto)
  apply (simp add: add_env_def)
  apply (erule_tac x="xa" in allE)
  apply (auto)
  done

lemma well_typed_dom_cover: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> dom_cover env (all_vars e)"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* const + op + var cases *)
        apply (simp add: dom_cover_def)
       apply (simp add: dom_cover_def)
      apply (simp add: dom_cover_def)
      apply (auto)
      apply (case_tac x)
       apply (auto)
    (* pair case *)
     apply (simp add: dom_cover_def)
    (* if case *)
    apply (simp add: dom_cover_def)
    (* lam case *)
   apply (rule_tac tau="t1" in add_dom_cover)
   apply (auto)
    (* app case *)
  apply (simp add: dom_cover_def)
  done

lemma cover_same_dom_env: "\<lbrakk> dom_ex_cover env_v ds; dom_cover (set_restr_env env ds) ds \<rbrakk> \<Longrightarrow> same_dom_env env_v (set_restr_env env ds)"
  apply (simp add: same_dom_env_def)
  apply (auto)
  apply (simp add: dom_ex_cover_def)
  apply (simp add: set_restr_env_def)
  apply (simp add: set_restr_env_def)
  apply (case_tac "x \<in> ds")
   apply (auto)
   apply (simp add: dom_cover_def)
   apply (erule_tac x="x" in allE)
   apply (auto)
  apply (simp add: dom_ex_cover_def)
  done

lemma append_no_mv_crn: "\<lbrakk> no_mv_crn cl1; no_mv_crn cl2 \<rbrakk> \<Longrightarrow> no_mv_crn (cl1 @ cl2)"
  apply (induct cl1)
   apply (auto)
  apply (case_tac a)
       apply (auto)
  done

lemma disj_no_mv_crn: "no_mv_crn (disj_crn r_s r_x d)"
  apply (induct d)
   apply (auto)
  done

lemma semi_disj_no_mv_crn: "no_mv_crn (semi_disj_crn r_s r_x d)"
  apply (induct d)
   apply (auto)
  done

lemma aff_no_mv_crn: "no_mv_crn (aff_crn r_s r d)"
  apply (induct d)
   apply (auto)
  done

lemma infer_no_mem_val_crn: "\<lbrakk> no_mem_val e; infer_type env_v ds e tau_v r_sv r_xv r_mv c_list ds' \<rbrakk> \<Longrightarrow> no_mv_crn c_list"
  apply (induct e arbitrary: env_v ds tau_v r_sv r_xv r_mv c_list ds')
        apply (auto)
    (* const case *)
       apply (case_tac x)
                   apply (auto)
    (* var case *)
      apply (case_tac x)
       apply (auto)
    (* pair case *)
     apply (rule_tac append_no_mv_crn)
      apply (rule_tac disj_no_mv_crn)
     apply (rule_tac append_no_mv_crn)
      apply (rule_tac semi_disj_no_mv_crn)
     apply (rule_tac append_no_mv_crn)
      apply (rule_tac semi_disj_no_mv_crn)
     apply (rule_tac append_no_mv_crn)
      apply (auto)
    (* if case *)
    apply (rule_tac append_no_mv_crn)
     apply (rule_tac semi_disj_no_mv_crn)
    apply (rule_tac append_no_mv_crn)
     apply (simp)
    apply (rule_tac append_no_mv_crn)
     apply (auto)
    (* lam case *)
   apply (rule_tac append_no_mv_crn)
    apply (rule_tac aff_no_mv_crn)
   apply (simp)
    (* app case *)
   apply (rule_tac append_no_mv_crn)
   apply (rule_tac disj_no_mv_crn)
  apply (rule_tac append_no_mv_crn)
   apply (rule_tac semi_disj_no_mv_crn)
  apply (rule_tac append_no_mv_crn)
   apply (rule_tac semi_disj_no_mv_crn)
  apply (rule_tac append_no_mv_crn)
   apply (auto)
  done

    (* requires e to not have memory values, and for env_v / ds to be constructed under certain constraints *)
lemma infer_unsat: "\<lbrakk> infer_type env_v ds e tau_v r_sv r_xv r_mv c_list ds'; no_mem_val e;
  dom_ex_cover env_v (all_vars e); unique_env env_v; sub_range env_v ds; \<not> solve_crn_list c_list \<rbrakk> \<Longrightarrow>
  \<not> well_typed env r_s1 e tau r_s2 rx"
  apply (auto)
    (* first we want to restrict env to only free variables *)
  apply (cut_tac env="env" and e="e" and ds="all_vars e" in well_typed_set_restr)
    apply (auto)
    (* using this we can show that env_v is a specialization of env *)
  apply (cut_tac env_v="env_v" and env="set_restr_env env (all_vars e)" in unique_spec_env)
    apply (rule_tac cover_same_dom_env)
     apply (simp)
    apply (rule_tac well_typed_dom_cover)
    apply (auto)
    (* we improve the specialization so that its domain fits in ds *)
  apply (cut_tac env_v="env_v" and env="set_restr_env env (all_vars e)" and t_sub="t_sub" and ds="ds" in restr_spec_env)
    apply (auto)
    (* next we manipulate the permission bounds of e to call the inference lemma *)
  apply (cut_tac env="set_restr_env env (all_vars e)" and ?r_s1.0="r_s1" and e="e" and tau="tau" and ?r_s2.0="r_s2" and rx="rx" in well_typed_end_perm_lbound)
   apply (auto)
  apply (cut_tac env="set_restr_env env (all_vars e)" and r_s="r_s1" and r_ex="r_s1" and r_x="diff_use_env rx r_s1" and e="e"
      and env_v="env_v" and ds="ds" and c_list="c_list" in ivr_partial)
       apply (auto)
    (* since our solver returns false, the constraints are unsolvable, a contradiction *)
  apply (cut_tac t_sub="dir_list_add_env t_subx l" and p_sub="p_sub" and c_list="c_list" in solve_crn_list_unsat)
    apply (auto)
  apply (rule_tac infer_no_mem_val_crn)
   apply (auto)
  done

lemma infer_sat: "\<lbrakk> infer_type env_v ds e tau_v r_sv r_xv r_mv c_list ds'; no_mem_val e; solve_crn_list c_list \<rbrakk> \<Longrightarrow>
  (\<exists> env r_s1 tau r_s2 rx. well_typed env r_s1 e tau r_s2 rx)"
  apply (cut_tac c_list="c_list" in solve_crn_list_sat)
    apply (auto)
   apply (rule_tac infer_no_mem_val_crn)
    apply (auto)
  apply (cut_tac tau_n="IntTy" in infer_valid_left)
     apply (auto)
  apply (rule_tac x="dir_subst_tenv (fill_tsub t_sub IntTy) env_v" in exI)
  apply (auto)
  done

end


theory IHT_Reverse
imports "../SepLogicTime/SLTC_Main" "../Asymptotics/Asymptotics_Recurrences"
begin

fun rev'_fun :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "rev'_fun xs ys 0 = ys"
| "rev'_fun xs ys (Suc n) = (let ys' = rev'_fun xs ys n
                              in
                                ys'[n:=(xs!(length xs - Suc n))])"
setup \<open>fold add_rewrite_rule @{thms rev'_fun.simps}\<close>

lemma length_rev'_fun[rewrite]: "length xs = length ys \<Longrightarrow> n\<le>length xs \<Longrightarrow> length (rev'_fun xs ys n) = length ys"
  by(induct n, auto)

setup \<open>add_rewrite_rule @{thm rev_nth}\<close>

lemma rev'_fun_rev_aux: "length xs = length ys \<Longrightarrow> n \<le> length xs \<Longrightarrow>
    i < n  \<Longrightarrow> rev'_fun xs ys n ! i = rev xs ! i"
@proof @induct n arbitrary i @qed

lemma rev'_fun_correct[rewrite]: "length xs = length ys \<Longrightarrow> rev'_fun xs ys (length ys) = rev xs"
  by(auto simp add: rev'_fun_rev_aux list_eq_iff_nth_eq length_rev'_fun)

fun rev_impl' :: "('a::heap) array \<Rightarrow> 'a array \<Rightarrow> nat \<Rightarrow> unit Heap"  where
  "rev_impl' p q 0 = return ()"
| "rev_impl' p q (Suc n) = do {
        rev_impl' p q n;
        len \<leftarrow> Array_Time.len p;
        e \<leftarrow> Array_Time.nth p (len - Suc n);
        Array_Time.upd n e q;
        return ()
      }"

fun rev'_time :: "nat \<Rightarrow> nat" where
  "rev'_time 0 = 1"
| "rev'_time (Suc n) = rev'_time n + 4"
setup \<open>fold add_rewrite_rule @{thms rev'_time.simps}\<close>

lemma rev'_time_closed: "rev'_time n = 1 + n*4"
  by(induct n, auto)

lemma "rev'_time \<in> \<Theta>(\<lambda>n. n)"
  unfolding rev'_time_closed by auto2

lemma rev'_time_bound[asym_bound]: "rev'_time \<in> \<Theta>(\<lambda>n. n)"
  by(rule bigTheta_linear_recurrence_const[where g="\<lambda>_.4" and N=3], auto)

lemma rev'_rule[hoare_triple]:
    "length xs = length ys \<Longrightarrow> n \<le> length xs \<Longrightarrow>
          <p \<mapsto>\<^sub>a xs * q \<mapsto>\<^sub>a ys * $(rev'_time n)>
            rev_impl' p q n
          <%_. p \<mapsto>\<^sub>a xs * q \<mapsto>\<^sub>a rev'_fun xs ys n>\<^sub>t"
@proof @fun_induct "rev'_fun xs ys n" @qed

definition rev_impl where
  "rev_impl p = do {
      len \<leftarrow> Array_Time.len p;
      q \<leftarrow> Array_Time.new len undefined;
      rev_impl' p q len;
      return q
    }"

definition rev_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "rev_time n = n + rev'_time n + 3"

lemma rev_impl_time_mono: "x\<le>y \<Longrightarrow> rev_time x \<le> rev_time y"
  unfolding rev_time_def rev'_time_closed by auto

lemma rev_impl_time_bound[asym_bound]: "rev_time \<in> \<Theta>(\<lambda>n. n)"
  unfolding rev_time_def by auto2

lemma rev_impl_rule[hoare_triple]:
    "length xs = length ys \<Longrightarrow>
          <p \<mapsto>\<^sub>a xs * $(rev_time (length xs))>
            rev_impl p
          <%r. p \<mapsto>\<^sub>a xs * r \<mapsto>\<^sub>a rev xs>\<^sub>t"
  by auto2

setup \<open>del_prfstep_thm @{thm rev_time_def}\<close>

end


theory Build_Incredible_Tree
imports Incredible_Trees Natural_Deduction
begin

text \<open>
This theory constructs an incredible tree (with freshness checked only locally) from a natural
deduction tree.
\<close>

lemma image_eq_to_f:
  assumes  "f1 ` S1 = f2 ` S2"
  obtains f where "\<And> x. x \<in> S2 \<Longrightarrow> f x \<in> S1 \<and> f1 (f x) = f2 x"
proof (atomize_elim)
  from assms
  have "\<forall>x. x \<in> S2 \<longrightarrow> (\<exists> y. y \<in> S1 \<and> f1 y = f2 x)" by (metis image_iff)
  thus "\<exists>f. \<forall>x. x \<in> S2 \<longrightarrow> f x \<in> S1 \<and> f1 (f x) = f2 x" by metis
qed

context includes fset.lifting
begin
lemma fimage_eq_to_f:
  assumes  "f1 |`| S1 = f2 |`| S2"
  obtains f where "\<And> x. x |\<in>| S2 \<Longrightarrow> f x |\<in>| S1 \<and> f1 (f x) = f2 x"
using assms apply transfer using image_eq_to_f by metis
end

context Abstract_Task
begin

lemma build_local_iwf:
  fixes t :: "('form entailment \<times> ('rule \<times> 'form) NatRule) tree"
  assumes "tfinite t"
  assumes "wf t"
  shows "\<exists> it. local_iwf it (fst (root t))"
using assms
proof(induction)
  case (tfinite t)
  from \<open>wf t\<close>
  have "snd (root t) \<in> R" using wf.simps by blast

  from \<open>wf t\<close>
  have "eff (snd (root t)) (fst (root t)) ((fst \<circ> root) |`| cont t)" using wf.simps by blast

  from \<open>wf t\<close>
  have "\<And> t'. t' |\<in>| cont t \<Longrightarrow> wf t'" using wf.simps by blast
  hence IH: "\<And> \<Gamma>' t'. t' |\<in>| cont t \<Longrightarrow> (\<exists>it'. local_iwf it' (fst (root t')))" using tfinite(2) by blast
  then obtain its where its: "\<And> t'. t' |\<in>| cont t \<Longrightarrow> local_iwf (its t') (fst (root t'))" by metis

  from \<open>eff _ _ _\<close>
  show ?case
  proof(cases rule: eff.cases[case_names Axiom NatRule Cut])
  case (Axiom c \<Gamma>)
    show ?thesis
    proof (cases "c |\<in>| ass_forms")
      case True (* Global assumption *)
      then  have "c \<in> set assumptions"  by (auto simp add:  ass_forms_def)

      let "?it" = "INode (Assumption c) c undefined undefined [] ::  ('form, 'rule, 'subst, 'var) itree"

      from \<open>c \<in> set assumptions\<close>
      have "local_iwf ?it (\<Gamma> \<turnstile> c)"
        by (auto intro!: iwf local_fresh_check.intros)

      thus ?thesis unfolding Axiom..
    next
      case False
      obtain s where "subst s anyP = c" by atomize_elim (rule anyP_is_any)
      hence [simp]: "subst s (freshen undefined anyP) = c" by (simp add: lconsts_anyP freshen_closed)

      let "?it" = "HNode undefined s [] ::  ('form, 'rule, 'subst, 'var) itree"

      from  \<open>c |\<in>| \<Gamma>\<close> False
      have "local_iwf ?it (\<Gamma> \<turnstile> c)" by (auto intro: iwfH)
      thus ?thesis unfolding Axiom..
    qed
  next
  case (NatRule rule c ants \<Gamma> i s)
    from \<open>natEff_Inst rule c ants\<close>
    have "snd rule = c"  and [simp]: "ants = f_antecedent (fst rule)" and "c \<in> set (consequent (fst rule))"
      by (auto simp add: natEff_Inst.simps)

    from \<open>(fst \<circ> root) |`| cont t = (\<lambda>ant. (\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant))) |`| ants\<close>
    obtain to_t where "\<And> ant. ant |\<in>| ants \<Longrightarrow> to_t ant |\<in>| cont t \<and> (fst \<circ> root) (to_t ant) = ((\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant)))"
      by (rule fimage_eq_to_f) (rule that)
    hence to_t_in_cont: "\<And> ant. ant |\<in>| ants \<Longrightarrow> to_t ant |\<in>| cont t"
      and to_t_root: "\<And> ant. ant |\<in>| ants \<Longrightarrow>  fst (root (to_t ant)) = ((\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant)))"
      by auto

    let ?ants' = "map (\<lambda> ant. its (to_t ant)) (antecedent (fst rule))"
    let "?it" = "INode (Rule (fst rule)) c i s ?ants' ::  ('form, 'rule, 'subst, 'var) itree"

    from \<open>snd (root t) \<in> R\<close>
    have "fst rule \<in> sset rules"
      unfolding NatRule
      by (auto simp add: stream.set_map n_rules_def no_empty_conclusions )
    moreover
    from \<open>c \<in> set (consequent (fst rule))\<close>
    have "c |\<in>| f_consequent (fst rule)" by (simp add: f_consequent_def)
    moreover
    { fix ant
      assume "ant \<in> set (antecedent (fst rule))"
      hence "ant |\<in>| ants" by (simp add: f_antecedent_def)
      from its[OF to_t_in_cont[OF this]]
      have "local_iwf (its (to_t ant)) (fst (root (to_t ant)))".
      also have "fst (root (to_t ant)) =
        ((\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant)))"
        by (rule to_t_root[OF \<open>ant |\<in>| ants\<close>])
      also have "\<dots> =
        ((\<lambda>h. subst s (freshen i (labelsOut (Rule (fst rule)) h))) |`| hyps_for (Rule (fst rule)) ant |\<union>| \<Gamma>
         \<turnstile> subst s (freshen i (a_conc ant)))"
         using \<open>ant |\<in>| ants\<close>
         by auto
      finally
      have "local_iwf (its (to_t ant))
           ((\<lambda>h. subst s (freshen i (labelsOut (Rule (fst rule)) h))) |`| hyps_for (Rule (fst rule)) ant |\<union>|
            \<Gamma>  \<turnstile> subst s (freshen i (a_conc ant)))".
    }
    moreover
    from NatRule(5,6)
    have "local_fresh_check (Rule (fst rule)) i s (\<Gamma> \<turnstile> subst s (freshen i c))"
      by (fastforce intro!: local_fresh_check.intros simp add: all_local_vars_def fmember.rep_eq)
    ultimately
    have "local_iwf ?it ((\<Gamma> \<turnstile> subst s (freshen i c)))"
      by (intro iwf ) (auto simp add: list_all2_map2 list_all2_same)
    thus ?thesis unfolding NatRule..
  next
  case (Cut \<Gamma> con)
    obtain s where "subst s anyP = con" by atomize_elim (rule anyP_is_any)
    hence  [simp]: "subst s (freshen undefined anyP) = con" by (simp add: lconsts_anyP freshen_closed)

    from \<open>(fst \<circ> root) |`| cont t = {|\<Gamma> \<turnstile> con|}\<close>
    obtain t'  where "t' |\<in>| cont t" and [simp]: "fst (root t') = (\<Gamma> \<turnstile> con)"
      by (cases "cont t") auto

    from \<open>t' |\<in>| cont t\<close> obtain "it'" where "local_iwf it' (\<Gamma> \<turnstile> con)" using IH by force

    let "?it" = "INode Helper anyP undefined s [it'] ::  ('form, 'rule, 'subst, 'var) itree"

    from \<open>local_iwf it' (\<Gamma> \<turnstile> con)\<close>
    have "local_iwf ?it (\<Gamma> \<turnstile> con)" by (auto intro!: iwf local_fresh_check.intros)
    thus ?thesis unfolding Cut..
  qed
qed

definition to_it :: "('form entailment \<times> ('rule \<times> 'form) NatRule) tree \<Rightarrow> ('form,'rule,'subst,'var) itree" where
  "to_it t = (SOME it. local_iwf it (fst (root t)))"

lemma iwf_to_it:
  assumes "tfinite t" and "wf t"
  shows "local_iwf (to_it t) (fst (root t))"
unfolding to_it_def using build_local_iwf[OF assms] by (rule someI2_ex)
end
end


(* Author:     Giampaolo Bella, Catania University
*)

section{*Theory of smartcards*}

theory Smartcard
imports EventSC "../All_Symmetric"
begin

text{*
As smartcards handle long-term (symmetric) keys, this theoy extends and
supersedes theory Private.thy

An agent is bad if she reveals her PIN to the spy, not the shared key that
is embedded in her card. An agent's being bad implies nothing about her
smartcard, which independently may be stolen or cloned.
*}

axiomatization
  shrK    :: "agent => key" and  (*long-term keys saved in smart cards*)
  crdK    :: "card  => key" and  (*smart cards' symmetric keys*)
  pin     :: "agent => key" and  (*pin to activate the smart cards*)

  (*Mostly for Shoup-Rubin*)
  Pairkey :: "agent * agent => nat" and
  pairK   :: "agent * agent => key"
where
  inj_shrK: "inj shrK" and  --{*No two smartcards store the same key*}
  inj_crdK: "inj crdK" and  --{*Nor do two cards*}
  inj_pin : "inj pin" and   --{*Nor do two agents have the same pin*}

  (*pairK is injective on each component, if we assume encryption to be a PRF
    or at least collision free *)
  inj_pairK    [iff]: "(pairK(A,B) = pairK(A',B')) = (A = A' & B = B')" and
  comm_Pairkey [iff]: "Pairkey(A,B) = Pairkey(B,A)" and

  (*long-term keys differ from each other*)
  pairK_disj_crdK [iff]: "pairK(A,B) \<noteq> crdK C" and
  pairK_disj_shrK [iff]: "pairK(A,B) \<noteq> shrK P" and
  pairK_disj_pin [iff]:  "pairK(A,B) \<noteq> pin P" and
  shrK_disj_crdK [iff]:  "shrK P \<noteq> crdK C" and
  shrK_disj_pin [iff]:  "shrK P \<noteq> pin Q" and
  crdK_disj_pin [iff]:   "crdK C \<noteq> pin P"

definition legalUse :: "card => bool" ("legalUse (_)") where
  "legalUse C == C \<notin> stolen"

primrec illegalUse :: "card  => bool" where
  illegalUse_def: "illegalUse (Card A) = ( (Card A \<in> stolen \<and> A \<in> bad)  \<or>  Card A \<in> cloned )"

text{*initState must be defined with care*}

overloading
  initState \<equiv> initState
begin

primrec initState where
(*Server knows all long-term keys; adding cards' keys may be redundant but
  helps prove crdK_in_initState and crdK_in_used to distinguish cards' keys
  from fresh (session) keys*)
  initState_Server:  "initState Server =
        (Key`(range shrK \<union> range crdK \<union> range pin \<union> range pairK)) \<union>
        (Nonce`(range Pairkey))" |

(*Other agents know only their own*)
  initState_Friend:  "initState (Friend i) = {Key (pin (Friend i))}" |

(*Spy knows bad agents' pins, cloned cards' keys, pairKs, and Pairkeys *)
  initState_Spy: "initState Spy  =
                 (Key`((pin`bad) \<union> (pin `{A. Card A \<in> cloned}) \<union>
                                      (shrK`{A. Card A \<in> cloned}) \<union>
                        (crdK`cloned) \<union>
                        (pairK`{(X,A). Card A \<in> cloned})))
           \<union> (Nonce`(Pairkey`{(A,B). Card A \<in> cloned & Card B \<in> cloned}))"

end

text{*Still relying on axioms*}
axiomatization where
  Key_supply_ax:  "finite KK \<Longrightarrow> \<exists> K. K \<notin> KK & Key K \<notin> used evs" and

  (*Needed because of Spy's knowledge of Pairkeys*)
  Nonce_supply_ax: "finite NN \<Longrightarrow> \<exists> N. N \<notin> NN & Nonce N \<notin> used evs"

subsection{*Basic properties of shrK*}

(*Injectiveness: Agents' long-term keys are distinct.*)
declare inj_shrK [THEN inj_eq, iff]
declare inj_crdK [THEN inj_eq, iff]
declare inj_pin  [THEN inj_eq, iff]

lemma invKey_K [simp]: "invKey K = K"
apply (insert isSym_keys)
apply (simp add: symKeys_def)
done

lemma analz_Decrypt' [dest]:
     "\<lbrakk> Crypt K X \<in> analz H;  Key K  \<in> analz H \<rbrakk> \<Longrightarrow> X \<in> analz H"
by auto

text{*Now cancel the @{text dest} attribute given to
 @{text analz.Decrypt} in its declaration.*}
declare analz.Decrypt [rule del]

text{*Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.*}

text{*Added to extend initstate with set of nonces*}
lemma parts_image_Nonce [simp]: "parts (Nonce`N) = Nonce`N"
apply auto
apply (erule parts.induct)
apply auto
done

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C", auto)
done

(*Specialized to shared-key model: no @{term invKey}*)
lemma keysFor_parts_insert:
     "\<lbrakk> K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) \<rbrakk>
     \<Longrightarrow> K \<in> keysFor (parts (G \<union> H)) | Key K \<in> parts H"
by (force dest: EventSC.keysFor_parts_insert)

lemma Crypt_imp_keysFor: "Crypt K X \<in> H \<Longrightarrow> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

subsection{*Function "knows"*}

(*Spy knows the pins of bad agents!*)
lemma Spy_knows_bad [intro!]: "A \<in> bad \<Longrightarrow> Key (pin A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split add: event.split)
done

(*Spy knows the long-term keys of cloned cards!*)
lemma Spy_knows_cloned [intro!]:
     "Card A \<in> cloned \<Longrightarrow>  Key (crdK (Card A)) \<in> knows Spy evs &
                           Key (shrK A) \<in> knows Spy evs &
                           Key (pin A)  \<in> knows Spy evs &
                          (\<forall> B. Key (pairK(B,A)) \<in> knows Spy evs)"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split add: event.split)
done

lemma Spy_knows_cloned1 [intro!]: "C \<in> cloned \<Longrightarrow> Key (crdK C) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split add: event.split)
done

lemma Spy_knows_cloned2 [intro!]: "\<lbrakk> Card A \<in> cloned; Card B \<in> cloned \<rbrakk>
   \<Longrightarrow> Nonce (Pairkey(A,B))\<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split add: event.split)
done

(*Spy only knows pins of bad agents!*)
lemma Spy_knows_Spy_bad [intro!]: "A\<in> bad \<Longrightarrow> Key (pin A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split add: event.split)
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad:
  "\<lbrakk> Crypt (pin A) X \<in> analz (knows Spy evs);  A\<in>bad \<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
apply (force dest!: analz.Decrypt)
done

(** Fresh keys never clash with other keys **)

lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState Server"
apply (induct_tac "A")
apply auto
done

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma crdK_in_initState [iff]: "Key (crdK A) \<in> initState Server"
apply (induct_tac "A")
apply auto
done

lemma crdK_in_used [iff]: "Key (crdK A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma pin_in_initState [iff]: "Key (pin A) \<in> initState A"
apply (induct_tac "A")
apply auto
done

lemma pin_in_used [iff]: "Key (pin A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma pairK_in_initState [iff]: "Key (pairK X) \<in> initState Server"
apply (induct_tac "X")
apply auto
done

lemma pairK_in_used [iff]: "Key (pairK X) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range shrK"
by blast

lemma shrK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> shrK B \<noteq> K"
by blast

lemma crdK_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range crdK"
apply clarify
done

lemma crdK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> crdK C \<noteq> K"
apply clarify
done

lemma pin_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range pin"
apply clarify
done

lemma pin_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> pin A \<noteq> K"
apply clarify
done

lemma pairK_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range pairK"
apply clarify
done

lemma pairK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> pairK(A,B) \<noteq> K"
apply clarify
done

declare shrK_neq [THEN not_sym, simp]
declare crdK_neq [THEN not_sym, simp]
declare pin_neq [THEN not_sym, simp]
declare pairK_neq [THEN not_sym, simp]

subsection{*Fresh nonces*}

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState (Friend i))"
by auto

(*This lemma no longer holds of smartcard protocols, where the cards can store
  nonces.

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
apply (simp (no_asm) add: used_Nil)
done

So, we must use old-style supply fresh nonce theorems relying on the appropriate axiom*)

subsection{*Supply fresh nonces for possibility theorems.*}

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
apply (rule finite.emptyI [THEN Nonce_supply_ax, THEN exE], blast)
done

lemma Nonce_supply2:
  "\<exists>N N'. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' & N \<noteq> N'"
apply (cut_tac evs = evs in finite.emptyI [THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs' in finite.emptyI [THEN finite.insertI, THEN Nonce_supply_ax])
apply auto
done

lemma Nonce_supply3: "\<exists>N N' N''. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' &
                    Nonce N'' \<notin> used evs'' & N \<noteq> N' & N' \<noteq> N'' & N \<noteq> N''"
apply (cut_tac evs = evs in finite.emptyI [THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs' and a1 = N in finite.emptyI [THEN finite.insertI, THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs'' and a1 = Na and a2 = N in finite.emptyI [THEN finite.insertI, THEN finite.insertI, THEN Nonce_supply_ax])
apply blast
done

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule finite.emptyI [THEN Nonce_supply_ax, THEN exE])
apply (rule someI, blast)
done

text{*Unlike the corresponding property of nonces, we cannot prove
    @{term "finite KK \<Longrightarrow> \<exists>K. K \<notin> KK & Key K \<notin> used evs"}.
    We have infinitely many agents and there is nothing to stop their
    long-term keys from exhausting all the natural numbers.  Instead,
    possibility theorems must assume the existence of a few keys.*}

subsection{*Specialized Rewriting for Theorems About @{term analz} and Image*}

lemma subset_Compl_range_shrK: "A \<subseteq> - (range shrK) \<Longrightarrow> shrK x \<notin> A"
by blast

lemma subset_Compl_range_crdK: "A \<subseteq> - (range crdK) \<Longrightarrow> crdK x \<notin> A"
apply blast
done

lemma subset_Compl_range_pin: "A \<subseteq> - (range pin) \<Longrightarrow> pin x \<notin> A"
apply blast
done

lemma subset_Compl_range_pairK: "A \<subseteq> - (range pairK) \<Longrightarrow> pairK x \<notin> A"
apply blast
done
lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key`(insert K KK) \<union> C"
by blast

(** Reverse the normal simplification of "image" to build up (not break down)
    the set of keys.  Use analz_insert_eq with (Un_upper2 RS analz_mono) to
    erase occurrences of forwarded message components (X). **)

lemmas analz_image_freshK_simps =
       simp_thms mem_simps --{*these two allow its use with @{text "only:"}*}
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN [2] rev_subsetD]
       insert_Key_singleton subset_Compl_range_shrK subset_Compl_range_crdK
       subset_Compl_range_pin subset_Compl_range_pairK
       Key_not_used insert_Key_image Un_assoc [THEN sym]

(*Lemma for the trivial direction of the if-and-only-if*)
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) \<longrightarrow> (K \<in> nE | Key K \<in> analz H)  \<Longrightarrow>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsection{*Tactics for possibility theorems*}

ML
{*
structure Smartcard =
struct

(*Omitting used_Says makes the tactic much faster: it leaves expressions
    such as  Nonce ?N \<notin> used evs that match Nonce_supply*)
fun possibility_tac ctxt =
   (REPEAT
    (ALLGOALS (simp_tac (ctxt
      delsimps @{thms used_Cons_simps}
      setSolver safe_solver))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac [refl, conjI, @{thm Nonce_supply}])))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac [refl, conjI]))

val analz_image_freshK_ss =
  simpset_of
   (@{context} delsimps [image_insert, image_Un]
               delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
               addsimps @{thms analz_image_freshK_simps})
end
*}

(*Lets blast_tac perform this step without needing the simplifier*)
lemma invKey_shrK_iff [iff]:
     "(Key (invKey K) \<in> X) = (Key K \<in> X)"
by auto

(*Specialized methods*)

method_setup analz_freshK = {*
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac [allI, ballI, impI]),
          REPEAT_FIRST (rtac @{thm analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Smartcard.analz_image_freshK_ss ctxt))]))) *}
    "for proving the Session Key Compromise theorem"

method_setup possibility = {*
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartcard.possibility_tac ctxt)) *}
    "for proving possibility theorems"

method_setup basic_possibility = {*
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartcard.basic_possibility_tac ctxt)) *}
    "for proving possibility theorems"

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (induct e) (auto simp: knows_Cons)

(*Needed for actual protocols that will follow*)
declare shrK_disj_crdK[THEN not_sym, iff]
declare shrK_disj_pin[THEN not_sym, iff]
declare pairK_disj_shrK[THEN not_sym, iff]
declare pairK_disj_crdK[THEN not_sym, iff]
declare pairK_disj_pin[THEN not_sym, iff]
declare crdK_disj_pin[THEN not_sym, iff]

declare legalUse_def [iff] illegalUse_def [iff]

end