(*  Title:      HOL/Algebra/AbelCoset.thy
    Author:     Stephan Hohe, TU Muenchen
*)

theory AbelCoset
imports Coset Ring
begin

subsection {* More Lifting from Groups to Abelian Groups *}

subsubsection {* Definitions *}

text {* Hiding @{text "<+>"} from @{theory Sum_Type} until I come
  up with better syntax here *}

no_notation Sum_Type.Plus (infixr "<+>" 65)

definition
  a_r_coset    :: "[_, 'a set, 'a] \<Rightarrow> 'a set"    (infixl "+>\<index>" 60)
  where "a_r_coset G = r_coset \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

definition
  a_l_coset    :: "[_, 'a, 'a set] \<Rightarrow> 'a set"    (infixl "<+\<index>" 60)
  where "a_l_coset G = l_coset \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

definition
  A_RCOSETS  :: "[_, 'a set] \<Rightarrow> ('a set)set"   ("a'_rcosets\<index> _" [81] 80)
  where "A_RCOSETS G H = RCOSETS \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> H"

definition
  set_add  :: "[_, 'a set ,'a set] \<Rightarrow> 'a set" (infixl "<+>\<index>" 60)
  where "set_add G = set_mult \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

definition
  A_SET_INV :: "[_,'a set] \<Rightarrow> 'a set"  ("a'_set'_inv\<index> _" [81] 80)
  where "A_SET_INV G H = SET_INV \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> H"

definition
  a_r_congruent :: "[('a,'b)ring_scheme, 'a set] \<Rightarrow> ('a*'a)set"  ("racong\<index>")
  where "a_r_congruent G = r_congruent \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

definition
  A_FactGroup :: "[('a,'b) ring_scheme, 'a set] \<Rightarrow> ('a set) monoid" (infixl "A'_Mod" 65)
    --{*Actually defined for groups rather than monoids*}
  where "A_FactGroup G H = FactGroup \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> H"

definition
  a_kernel :: "('a, 'm) ring_scheme \<Rightarrow> ('b, 'n) ring_scheme \<Rightarrow>  ('a \<Rightarrow> 'b) \<Rightarrow> 'a set"
    --{*the kernel of a homomorphism (additive)*}
  where "a_kernel G H h =
    kernel \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>
      \<lparr>carrier = carrier H, mult = add H, one = zero H\<rparr> h"

locale abelian_group_hom = G: abelian_group G + H: abelian_group H
    for G (structure) and H (structure) +
  fixes h
  assumes a_group_hom: "group_hom \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>
                                  \<lparr>carrier = carrier H, mult = add H, one = zero H\<rparr> h"

lemmas a_r_coset_defs =
  a_r_coset_def r_coset_def

lemma a_r_coset_def':
  fixes G (structure)
  shows "H +> a \<equiv> \<Union>h\<in>H. {h \<oplus> a}"
unfolding a_r_coset_defs
by simp

lemmas a_l_coset_defs =
  a_l_coset_def l_coset_def

lemma a_l_coset_def':
  fixes G (structure)
  shows "a <+ H \<equiv> \<Union>h\<in>H. {a \<oplus> h}"
unfolding a_l_coset_defs
by simp

lemmas A_RCOSETS_defs =
  A_RCOSETS_def RCOSETS_def

lemma A_RCOSETS_def':
  fixes G (structure)
  shows "a_rcosets H \<equiv> \<Union>a\<in>carrier G. {H +> a}"
unfolding A_RCOSETS_defs
by (fold a_r_coset_def, simp)

lemmas set_add_defs =
  set_add_def set_mult_def

lemma set_add_def':
  fixes G (structure)
  shows "H <+> K \<equiv> \<Union>h\<in>H. \<Union>k\<in>K. {h \<oplus> k}"
unfolding set_add_defs
by simp

lemmas A_SET_INV_defs =
  A_SET_INV_def SET_INV_def

lemma A_SET_INV_def':
  fixes G (structure)
  shows "a_set_inv H \<equiv> \<Union>h\<in>H. {\<ominus> h}"
unfolding A_SET_INV_defs
by (fold a_inv_def)

subsubsection {* Cosets *}

lemma (in abelian_group) a_coset_add_assoc:
     "[| M \<subseteq> carrier G; g \<in> carrier G; h \<in> carrier G |]
      ==> (M +> g) +> h = M +> (g \<oplus> h)"
by (rule group.coset_mult_assoc [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_add_zero [simp]:
  "M \<subseteq> carrier G ==> M +> \<zero> = M"
by (rule group.coset_mult_one [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_add_inv1:
     "[| M +> (x \<oplus> (\<ominus> y)) = M;  x \<in> carrier G ; y \<in> carrier G;
         M \<subseteq> carrier G |] ==> M +> x = M +> y"
by (rule group.coset_mult_inv1 [OF a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_add_inv2:
     "[| M +> x = M +> y;  x \<in> carrier G;  y \<in> carrier G;  M \<subseteq> carrier G |]
      ==> M +> (x \<oplus> (\<ominus> y)) = M"
by (rule group.coset_mult_inv2 [OF a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_join1:
     "[| H +> x = H;  x \<in> carrier G;  subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> |] ==> x \<in> H"
by (rule group.coset_join1 [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_solve_equation:
    "\<lbrakk>subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>; x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> \<exists>h\<in>H. y = h \<oplus> x"
by (rule group.solve_equation [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_repr_independence:
     "\<lbrakk>y \<in> H +> x;  x \<in> carrier G; subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> \<rbrakk> \<Longrightarrow> H +> x = H +> y"
by (rule group.repr_independence [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_join2:
     "\<lbrakk>x \<in> carrier G;  subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>; x\<in>H\<rbrakk> \<Longrightarrow> H +> x = H"
by (rule group.coset_join2 [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_monoid) a_r_coset_subset_G:
     "[| H \<subseteq> carrier G; x \<in> carrier G |] ==> H +> x \<subseteq> carrier G"
by (rule monoid.r_coset_subset_G [OF a_monoid,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_rcosI:
     "[| h \<in> H; H \<subseteq> carrier G; x \<in> carrier G|] ==> h \<oplus> x \<in> H +> x"
by (rule group.rcosI [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_rcosetsI:
     "\<lbrakk>H \<subseteq> carrier G; x \<in> carrier G\<rbrakk> \<Longrightarrow> H +> x \<in> a_rcosets H"
by (rule group.rcosetsI [OF a_group,
    folded a_r_coset_def A_RCOSETS_def, simplified monoid_record_simps])

text{*Really needed?*}
lemma (in abelian_group) a_transpose_inv:
     "[| x \<oplus> y = z;  x \<in> carrier G;  y \<in> carrier G;  z \<in> carrier G |]
      ==> (\<ominus> x) \<oplus> z = y"
by (rule group.transpose_inv [OF a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

(*
--"duplicate"
lemma (in abelian_group) a_rcos_self:
     "[| x \<in> carrier G; subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> |] ==> x \<in> H +> x"
by (rule group.rcos_self [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])
*)

subsubsection {* Subgroups *}

locale additive_subgroup =
  fixes H and G (structure)
  assumes a_subgroup: "subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

lemma (in additive_subgroup) is_additive_subgroup:
  shows "additive_subgroup H G"
by (rule additive_subgroup_axioms)

lemma additive_subgroupI:
  fixes G (structure)
  assumes a_subgroup: "subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  shows "additive_subgroup H G"
by (rule additive_subgroup.intro) (rule a_subgroup)

lemma (in additive_subgroup) a_subset:
     "H \<subseteq> carrier G"
by (rule subgroup.subset[OF a_subgroup,
    simplified monoid_record_simps])

lemma (in additive_subgroup) a_closed [intro, simp]:
     "\<lbrakk>x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> x \<oplus> y \<in> H"
by (rule subgroup.m_closed[OF a_subgroup,
    simplified monoid_record_simps])

lemma (in additive_subgroup) zero_closed [simp]:
     "\<zero> \<in> H"
by (rule subgroup.one_closed[OF a_subgroup,
    simplified monoid_record_simps])

lemma (in additive_subgroup) a_inv_closed [intro,simp]:
     "x \<in> H \<Longrightarrow> \<ominus> x \<in> H"
by (rule subgroup.m_inv_closed[OF a_subgroup,
    folded a_inv_def, simplified monoid_record_simps])

subsubsection {* Additive subgroups are normal *}

text {* Every subgroup of an @{text "abelian_group"} is normal *}

locale abelian_subgroup = additive_subgroup + abelian_group G +
  assumes a_normal: "normal H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

lemma (in abelian_subgroup) is_abelian_subgroup:
  shows "abelian_subgroup H G"
by (rule abelian_subgroup_axioms)

lemma abelian_subgroupI:
  assumes a_normal: "normal H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
      and a_comm: "!!x y. [| x \<in> carrier G; y \<in> carrier G |] ==> x \<oplus>\<^bsub>G\<^esub> y = y \<oplus>\<^bsub>G\<^esub> x"
  shows "abelian_subgroup H G"
proof -
  interpret normal "H" "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
    by (rule a_normal)

  show "abelian_subgroup H G"
    by default (simp add: a_comm)
qed

lemma abelian_subgroupI2:
  fixes G (structure)
  assumes a_comm_group: "comm_group \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
      and a_subgroup: "subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  shows "abelian_subgroup H G"
proof -
  interpret comm_group "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
    by (rule a_comm_group)
  interpret subgroup "H" "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
    by (rule a_subgroup)

  show "abelian_subgroup H G"
    apply unfold_locales
  proof (simp add: r_coset_def l_coset_def, clarsimp)
    fix x
    assume xcarr: "x \<in> carrier G"
    from a_subgroup have Hcarr: "H \<subseteq> carrier G"
      unfolding subgroup_def by simp
    from xcarr Hcarr show "(\<Union>h\<in>H. {h \<oplus>\<^bsub>G\<^esub> x}) = (\<Union>h\<in>H. {x \<oplus>\<^bsub>G\<^esub> h})"
      using m_comm [simplified] by fast
  qed
qed

lemma abelian_subgroupI3:
  fixes G (structure)
  assumes asg: "additive_subgroup H G"
      and ag: "abelian_group G"
  shows "abelian_subgroup H G"
apply (rule abelian_subgroupI2)
 apply (rule abelian_group.a_comm_group[OF ag])
apply (rule additive_subgroup.a_subgroup[OF asg])
done

lemma (in abelian_subgroup) a_coset_eq:
     "(\<forall>x \<in> carrier G. H +> x = x <+ H)"
by (rule normal.coset_eq[OF a_normal,
    folded a_r_coset_def a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_inv_op_closed1:
  shows "\<lbrakk>x \<in> carrier G; h \<in> H\<rbrakk> \<Longrightarrow> (\<ominus> x) \<oplus> h \<oplus> x \<in> H"
by (rule normal.inv_op_closed1 [OF a_normal,
    folded a_inv_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_inv_op_closed2:
  shows "\<lbrakk>x \<in> carrier G; h \<in> H\<rbrakk> \<Longrightarrow> x \<oplus> h \<oplus> (\<ominus> x) \<in> H"
by (rule normal.inv_op_closed2 [OF a_normal,
    folded a_inv_def, simplified monoid_record_simps])

text{*Alternative characterization of normal subgroups*}
lemma (in abelian_group) a_normal_inv_iff:
     "(N \<lhd> \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>) =
      (subgroup N \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> & (\<forall>x \<in> carrier G. \<forall>h \<in> N. x \<oplus> h \<oplus> (\<ominus> x) \<in> N))"
      (is "_ = ?rhs")
by (rule group.normal_inv_iff [OF a_group,
    folded a_inv_def, simplified monoid_record_simps])

lemma (in abelian_group) a_lcos_m_assoc:
     "[| M \<subseteq> carrier G; g \<in> carrier G; h \<in> carrier G |]
      ==> g <+ (h <+ M) = (g \<oplus> h) <+ M"
by (rule group.lcos_m_assoc [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_lcos_mult_one:
     "M \<subseteq> carrier G ==> \<zero> <+ M = M"
by (rule group.lcos_mult_one [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_coset_subset_G:
     "[| H \<subseteq> carrier G; x \<in> carrier G |] ==> x <+ H \<subseteq> carrier G"
by (rule group.l_coset_subset_G [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_coset_swap:
     "\<lbrakk>y \<in> x <+ H;  x \<in> carrier G;  subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>\<rbrakk> \<Longrightarrow> x \<in> y <+ H"
by (rule group.l_coset_swap [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_coset_carrier:
     "[| y \<in> x <+ H;  x \<in> carrier G;  subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> |] ==> y \<in> carrier G"
by (rule group.l_coset_carrier [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_repr_imp_subset:
  assumes y: "y \<in> x <+ H" and x: "x \<in> carrier G" and sb: "subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  shows "y <+ H \<subseteq> x <+ H"
apply (rule group.l_repr_imp_subset [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])
apply (rule y)
apply (rule x)
apply (rule sb)
done

lemma (in abelian_group) a_l_repr_independence:
  assumes y: "y \<in> x <+ H" and x: "x \<in> carrier G" and sb: "subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  shows "x <+ H = y <+ H"
apply (rule group.l_repr_independence [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])
apply (rule y)
apply (rule x)
apply (rule sb)
done

lemma (in abelian_group) setadd_subset_G:
     "\<lbrakk>H \<subseteq> carrier G; K \<subseteq> carrier G\<rbrakk> \<Longrightarrow> H <+> K \<subseteq> carrier G"
by (rule group.setmult_subset_G [OF a_group,
    folded set_add_def, simplified monoid_record_simps])

lemma (in abelian_group) subgroup_add_id: "subgroup H \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> \<Longrightarrow> H <+> H = H"
by (rule group.subgroup_mult_id [OF a_group,
    folded set_add_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_inv:
  assumes x:     "x \<in> carrier G"
  shows "a_set_inv (H +> x) = H +> (\<ominus> x)"
by (rule normal.rcos_inv [OF a_normal,
  folded a_r_coset_def a_inv_def A_SET_INV_def, simplified monoid_record_simps]) (rule x)

lemma (in abelian_group) a_setmult_rcos_assoc:
     "\<lbrakk>H \<subseteq> carrier G; K \<subseteq> carrier G; x \<in> carrier G\<rbrakk>
      \<Longrightarrow> H <+> (K +> x) = (H <+> K) +> x"
by (rule group.setmult_rcos_assoc [OF a_group,
    folded set_add_def a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_rcos_assoc_lcos:
     "\<lbrakk>H \<subseteq> carrier G; K \<subseteq> carrier G; x \<in> carrier G\<rbrakk>
      \<Longrightarrow> (H +> x) <+> K = H <+> (x <+ K)"
by (rule group.rcos_assoc_lcos [OF a_group,
     folded set_add_def a_r_coset_def a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_sum:
     "\<lbrakk>x \<in> carrier G; y \<in> carrier G\<rbrakk>
      \<Longrightarrow> (H +> x) <+> (H +> y) = H +> (x \<oplus> y)"
by (rule normal.rcos_sum [OF a_normal,
    folded set_add_def a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) rcosets_add_eq:
  "M \<in> a_rcosets H \<Longrightarrow> H <+> M = M"
  -- {* generalizes @{text subgroup_mult_id} *}
by (rule normal.rcosets_mult_eq [OF a_normal,
    folded set_add_def A_RCOSETS_def, simplified monoid_record_simps])

subsubsection {* Congruence Relation *}

lemma (in abelian_subgroup) a_equiv_rcong:
   shows "equiv (carrier G) (racong H)"
by (rule subgroup.equiv_rcong [OF a_subgroup a_group,
    folded a_r_congruent_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_l_coset_eq_rcong:
  assumes a: "a \<in> carrier G"
  shows "a <+ H = racong H `` {a}"
by (rule subgroup.l_coset_eq_rcong [OF a_subgroup a_group,
    folded a_r_congruent_def a_l_coset_def, simplified monoid_record_simps]) (rule a)

lemma (in abelian_subgroup) a_rcos_equation:
  shows
     "\<lbrakk>ha \<oplus> a = h \<oplus> b; a \<in> carrier G;  b \<in> carrier G;
        h \<in> H;  ha \<in> H;  hb \<in> H\<rbrakk>
      \<Longrightarrow> hb \<oplus> a \<in> (\<Union>h\<in>H. {h \<oplus> b})"
by (rule group.rcos_equation [OF a_group a_subgroup,
    folded a_r_congruent_def a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_disjoint:
  shows "\<lbrakk>a \<in> a_rcosets H; b \<in> a_rcosets H; a\<noteq>b\<rbrakk> \<Longrightarrow> a \<inter> b = {}"
by (rule group.rcos_disjoint [OF a_group a_subgroup,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_self:
  shows "x \<in> carrier G \<Longrightarrow> x \<in> H +> x"
by (rule group.rcos_self [OF a_group _ a_subgroup,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcosets_part_G:
  shows "\<Union>(a_rcosets H) = carrier G"
by (rule group.rcosets_part_G [OF a_group a_subgroup,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_cosets_finite:
     "\<lbrakk>c \<in> a_rcosets H;  H \<subseteq> carrier G;  finite (carrier G)\<rbrakk> \<Longrightarrow> finite c"
by (rule group.cosets_finite [OF a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_group) a_card_cosets_equal:
     "\<lbrakk>c \<in> a_rcosets H;  H \<subseteq> carrier G; finite(carrier G)\<rbrakk>
      \<Longrightarrow> card c = card H"
by (rule group.card_cosets_equal [OF a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_group) rcosets_subset_PowG:
     "additive_subgroup H G  \<Longrightarrow> a_rcosets H \<subseteq> Pow(carrier G)"
by (rule group.rcosets_subset_PowG [OF a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps],
    rule additive_subgroup.a_subgroup)

theorem (in abelian_group) a_lagrange:
     "\<lbrakk>finite(carrier G); additive_subgroup H G\<rbrakk>
      \<Longrightarrow> card(a_rcosets H) * card(H) = order(G)"
by (rule group.lagrange [OF a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps order_def, folded order_def])
    (fast intro!: additive_subgroup.a_subgroup)+

subsubsection {* Factorization *}

lemmas A_FactGroup_defs = A_FactGroup_def FactGroup_def

lemma A_FactGroup_def':
  fixes G (structure)
  shows "G A_Mod H \<equiv> \<lparr>carrier = a_rcosets\<^bsub>G\<^esub> H, mult = set_add G, one = H\<rparr>"
unfolding A_FactGroup_defs
by (fold A_RCOSETS_def set_add_def)

lemma (in abelian_subgroup) a_setmult_closed:
     "\<lbrakk>K1 \<in> a_rcosets H; K2 \<in> a_rcosets H\<rbrakk> \<Longrightarrow> K1 <+> K2 \<in> a_rcosets H"
by (rule normal.setmult_closed [OF a_normal,
    folded A_RCOSETS_def set_add_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_setinv_closed:
     "K \<in> a_rcosets H \<Longrightarrow> a_set_inv K \<in> a_rcosets H"
by (rule normal.setinv_closed [OF a_normal,
    folded A_RCOSETS_def A_SET_INV_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcosets_assoc:
     "\<lbrakk>M1 \<in> a_rcosets H; M2 \<in> a_rcosets H; M3 \<in> a_rcosets H\<rbrakk>
      \<Longrightarrow> M1 <+> M2 <+> M3 = M1 <+> (M2 <+> M3)"
by (rule normal.rcosets_assoc [OF a_normal,
    folded A_RCOSETS_def set_add_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_subgroup_in_rcosets:
     "H \<in> a_rcosets H"
by (rule subgroup.subgroup_in_rcosets [OF a_subgroup a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcosets_inv_mult_group_eq:
     "M \<in> a_rcosets H \<Longrightarrow> a_set_inv M <+> M = H"
by (rule normal.rcosets_inv_mult_group_eq [OF a_normal,
    folded A_RCOSETS_def A_SET_INV_def set_add_def, simplified monoid_record_simps])

theorem (in abelian_subgroup) a_factorgroup_is_group:
  "group (G A_Mod H)"
by (rule normal.factorgroup_is_group [OF a_normal,
    folded A_FactGroup_def, simplified monoid_record_simps])

text {* Since the Factorization is based on an \emph{abelian} subgroup, is results in
        a commutative group *}
theorem (in abelian_subgroup) a_factorgroup_is_comm_group:
  "comm_group (G A_Mod H)"
apply (intro comm_group.intro comm_monoid.intro) prefer 3
  apply (rule a_factorgroup_is_group)
 apply (rule group.axioms[OF a_factorgroup_is_group])
apply (rule comm_monoid_axioms.intro)
apply (unfold A_FactGroup_def FactGroup_def RCOSETS_def, fold set_add_def a_r_coset_def, clarsimp)
apply (simp add: a_rcos_sum a_comm)
done

lemma add_A_FactGroup [simp]: "X \<otimes>\<^bsub>(G A_Mod H)\<^esub> X' = X <+>\<^bsub>G\<^esub> X'"
by (simp add: A_FactGroup_def set_add_def)

lemma (in abelian_subgroup) a_inv_FactGroup:
     "X \<in> carrier (G A_Mod H) \<Longrightarrow> inv\<^bsub>G A_Mod H\<^esub> X = a_set_inv X"
by (rule normal.inv_FactGroup [OF a_normal,
    folded A_FactGroup_def A_SET_INV_def, simplified monoid_record_simps])

text{*The coset map is a homomorphism from @{term G} to the quotient group
  @{term "G Mod H"}*}
lemma (in abelian_subgroup) a_r_coset_hom_A_Mod:
  "(\<lambda>a. H +> a) \<in> hom \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> (G A_Mod H)"
by (rule normal.r_coset_hom_Mod [OF a_normal,
    folded A_FactGroup_def a_r_coset_def, simplified monoid_record_simps])

text {* The isomorphism theorems have been omitted from lifting, at
  least for now *}

subsubsection{*The First Isomorphism Theorem*}

text{*The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.*}

lemmas a_kernel_defs =
  a_kernel_def kernel_def

lemma a_kernel_def':
  "a_kernel R S h = {x \<in> carrier R. h x = \<zero>\<^bsub>S\<^esub>}"
by (rule a_kernel_def[unfolded kernel_def, simplified ring_record_simps])

subsubsection {* Homomorphisms *}

lemma abelian_group_homI:
  assumes "abelian_group G"
  assumes "abelian_group H"
  assumes a_group_hom: "group_hom \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>
                                  \<lparr>carrier = carrier H, mult = add H, one = zero H\<rparr> h"
  shows "abelian_group_hom G H h"
proof -
  interpret G: abelian_group G by fact
  interpret H: abelian_group H by fact
  show ?thesis
    apply (intro abelian_group_hom.intro abelian_group_hom_axioms.intro)
      apply fact
     apply fact
    apply (rule a_group_hom)
    done
qed

lemma (in abelian_group_hom) is_abelian_group_hom:
  "abelian_group_hom G H h"
  ..

lemma (in abelian_group_hom) hom_add [simp]:
  "[| x : carrier G; y : carrier G |]
        ==> h (x \<oplus>\<^bsub>G\<^esub> y) = h x \<oplus>\<^bsub>H\<^esub> h y"
by (rule group_hom.hom_mult[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) hom_closed [simp]:
  "x \<in> carrier G \<Longrightarrow> h x \<in> carrier H"
by (rule group_hom.hom_closed[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) zero_closed [simp]:
  "h \<zero> \<in> carrier H"
by (rule group_hom.one_closed[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) hom_zero [simp]:
  "h \<zero> = \<zero>\<^bsub>H\<^esub>"
by (rule group_hom.hom_one[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) a_inv_closed [simp]:
  "x \<in> carrier G ==> h (\<ominus>x) \<in> carrier H"
by (rule group_hom.inv_closed[OF a_group_hom,
    folded a_inv_def, simplified ring_record_simps])

lemma (in abelian_group_hom) hom_a_inv [simp]:
  "x \<in> carrier G ==> h (\<ominus>x) = \<ominus>\<^bsub>H\<^esub> (h x)"
by (rule group_hom.hom_inv[OF a_group_hom,
    folded a_inv_def, simplified ring_record_simps])

lemma (in abelian_group_hom) additive_subgroup_a_kernel:
  "additive_subgroup (a_kernel G H h) G"
apply (rule additive_subgroup.intro)
apply (rule group_hom.subgroup_kernel[OF a_group_hom,
       folded a_kernel_def, simplified ring_record_simps])
done

text{*The kernel of a homomorphism is an abelian subgroup*}
lemma (in abelian_group_hom) abelian_subgroup_a_kernel:
  "abelian_subgroup (a_kernel G H h) G"
apply (rule abelian_subgroupI)
apply (rule group_hom.normal_kernel[OF a_group_hom,
       folded a_kernel_def, simplified ring_record_simps])
apply (simp add: G.a_comm)
done

lemma (in abelian_group_hom) A_FactGroup_nonempty:
  assumes X: "X \<in> carrier (G A_Mod a_kernel G H h)"
  shows "X \<noteq> {}"
by (rule group_hom.FactGroup_nonempty[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps]) (rule X)

lemma (in abelian_group_hom) FactGroup_the_elem_mem:
  assumes X: "X \<in> carrier (G A_Mod (a_kernel G H h))"
  shows "the_elem (h`X) \<in> carrier H"
by (rule group_hom.FactGroup_the_elem_mem[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps]) (rule X)

lemma (in abelian_group_hom) A_FactGroup_hom:
     "(\<lambda>X. the_elem (h`X)) \<in> hom (G A_Mod (a_kernel G H h))
          \<lparr>carrier = carrier H, mult = add H, one = zero H\<rparr>"
by (rule group_hom.FactGroup_hom[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps])

lemma (in abelian_group_hom) A_FactGroup_inj_on:
     "inj_on (\<lambda>X. the_elem (h ` X)) (carrier (G A_Mod a_kernel G H h))"
by (rule group_hom.FactGroup_inj_on[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps])

text{*If the homomorphism @{term h} is onto @{term H}, then so is the
homomorphism from the quotient group*}
lemma (in abelian_group_hom) A_FactGroup_onto:
  assumes h: "h ` carrier G = carrier H"
  shows "(\<lambda>X. the_elem (h ` X)) ` carrier (G A_Mod a_kernel G H h) = carrier H"
by (rule group_hom.FactGroup_onto[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps]) (rule h)

text{*If @{term h} is a homomorphism from @{term G} onto @{term H}, then the
 quotient group @{term "G Mod (kernel G H h)"} is isomorphic to @{term H}.*}
theorem (in abelian_group_hom) A_FactGroup_iso:
  "h ` carrier G = carrier H
   \<Longrightarrow> (\<lambda>X. the_elem (h`X)) \<in> (G A_Mod (a_kernel G H h)) \<cong>
          \<lparr>carrier = carrier H, mult = add H, one = zero H\<rparr>"
by (rule group_hom.FactGroup_iso[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps])

subsubsection {* Cosets *}

text {* Not eveything from \texttt{CosetExt.thy} is lifted here. *}

lemma (in additive_subgroup) a_Hcarr [simp]:
  assumes hH: "h \<in> H"
  shows "h \<in> carrier G"
by (rule subgroup.mem_carrier [OF a_subgroup,
    simplified monoid_record_simps]) (rule hH)

lemma (in abelian_subgroup) a_elemrcos_carrier:
  assumes acarr: "a \<in> carrier G"
      and a': "a' \<in> H +> a"
  shows "a' \<in> carrier G"
by (rule subgroup.elemrcos_carrier [OF a_subgroup a_group,
    folded a_r_coset_def, simplified monoid_record_simps]) (rule acarr, rule a')

lemma (in abelian_subgroup) a_rcos_const:
  assumes hH: "h \<in> H"
  shows "H +> h = H"
by (rule subgroup.rcos_const [OF a_subgroup a_group,
    folded a_r_coset_def, simplified monoid_record_simps]) (rule hH)

lemma (in abelian_subgroup) a_rcos_module_imp:
  assumes xcarr: "x \<in> carrier G"
      and x'cos: "x' \<in> H +> x"
  shows "(x' \<oplus> \<ominus>x) \<in> H"
by (rule subgroup.rcos_module_imp [OF a_subgroup a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps]) (rule xcarr, rule x'cos)

lemma (in abelian_subgroup) a_rcos_module_rev:
  assumes "x \<in> carrier G" "x' \<in> carrier G"
      and "(x' \<oplus> \<ominus>x) \<in> H"
  shows "x' \<in> H +> x"
using assms
by (rule subgroup.rcos_module_rev [OF a_subgroup a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_module:
  assumes "x \<in> carrier G" "x' \<in> carrier G"
  shows "(x' \<in> H +> x) = (x' \<oplus> \<ominus>x \<in> H)"
using assms
by (rule subgroup.rcos_module [OF a_subgroup a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

--"variant"
lemma (in abelian_subgroup) a_rcos_module_minus:
  assumes "ring G"
  assumes carr: "x \<in> carrier G" "x' \<in> carrier G"
  shows "(x' \<in> H +> x) = (x' \<ominus> x \<in> H)"
proof -
  interpret G: ring G by fact
  from carr
  have "(x' \<in> H +> x) = (x' \<oplus> \<ominus>x \<in> H)" by (rule a_rcos_module)
  with carr
  show "(x' \<in> H +> x) = (x' \<ominus> x \<in> H)"
    by (simp add: minus_eq)
qed

lemma (in abelian_subgroup) a_repr_independence':
  assumes y: "y \<in> H +> x"
      and xcarr: "x \<in> carrier G"
  shows "H +> x = H +> y"
  apply (rule a_repr_independence)
    apply (rule y)
   apply (rule xcarr)
  apply (rule a_subgroup)
  done

lemma (in abelian_subgroup) a_repr_independenceD:
  assumes ycarr: "y \<in> carrier G"
      and repr:  "H +> x = H +> y"
  shows "y \<in> H +> x"
by (rule group.repr_independenceD [OF a_group a_subgroup,
    folded a_r_coset_def, simplified monoid_record_simps]) (rule ycarr, rule repr)

lemma (in abelian_subgroup) a_rcosets_carrier:
  "X \<in> a_rcosets H \<Longrightarrow> X \<subseteq> carrier G"
by (rule subgroup.rcosets_carrier [OF a_subgroup a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps])

subsubsection {* Addition of Subgroups *}

lemma (in abelian_monoid) set_add_closed:
  assumes Acarr: "A \<subseteq> carrier G"
      and Bcarr: "B \<subseteq> carrier G"
  shows "A <+> B \<subseteq> carrier G"
by (rule monoid.set_mult_closed [OF a_monoid,
    folded set_add_def, simplified monoid_record_simps]) (rule Acarr, rule Bcarr)

lemma (in abelian_group) add_additive_subgroups:
  assumes subH: "additive_subgroup H G"
      and subK: "additive_subgroup K G"
  shows "additive_subgroup (H <+> K) G"
apply (rule additive_subgroup.intro)
apply (unfold set_add_def)
apply (intro comm_group.mult_subgroups)
  apply (rule a_comm_group)
 apply (rule additive_subgroup.a_subgroup[OF subH])
apply (rule additive_subgroup.a_subgroup[OF subK])
done

end


theory TTTree
imports Main "HOL-Data_Structures.Set_Specs"

begin

nitpick_params[verbose, timeout = 1000]

(*Necessary Datatypes*)

datatype 'a tttree = Empty | SmallNode "'a tttree" 'a  "'a tttree" |
     LargeNode "'a tttree"  'a  "'a tttree"  'a "'a tttree"

datatype 'a TempDel =  Hole "'a tttree" |Nor "'a tttree"

datatype 'a TempIns =  Norm "'a tttree"  | KickUp "'a tttree" 'a "'a tttree"

datatype Eval = Smaller | Larger | Bet

datatype 'a May = None | Option 'a

datatype Emp = Em | Na

(*Lookup function*)

primrec contains :: "('a::linorder) \<Rightarrow> 'a tttree \<Rightarrow> bool" where
"contains a Empty = False" |
"contains a (SmallNode l v r)  =
        (if a < v then contains a l
        else if a > v then contains a r
        else True)" |
"contains a (LargeNode l lv m rv r) =
        (if a = lv  then True
        else if a = rv then True
        else if a < lv then contains a l
        else if a > rv then contains a r
        else contains a m)"

(*Helper Functions*)

definition eval :: "('a::linorder) \<Rightarrow> ('a::linorder) \<Rightarrow> 'a May  \<Rightarrow> Eval" where
"eval a v t  = (case t of
                None \<Rightarrow> (if a <v then Smaller
            else if a > v then Larger
            else Bet)|
                (Option l) \<Rightarrow> if (a <v) then Smaller
            else if a > l then Larger
            else Bet)"

primrec elements :: "'a tttree \<Rightarrow> 'a list" where
"elements Empty = []"|
"elements (SmallNode l v r) = (elements l) @ [v] @ (elements r)"|
"elements (LargeNode l lv m rv r) = (elements l) @ [lv] @ (elements m) @ [rv] @ (elements r)"

definition empty :: "'a tttree  \<Rightarrow> Emp"  where
"empty a  = (if (a = Empty) then Em
             else Na)"

(*Insert and aux functions*)

fun insert:: "('a::linorder) \<Rightarrow> 'a tttree \<Rightarrow> 'a TempIns" where
"insert a Empty = (KickUp (Empty) a (Empty))"|
"insert a (SmallNode l v r) =  (case eval a v None of
                   Smaller \<Rightarrow> (case insert a l of
                              (Norm a) \<Rightarrow> (Norm (SmallNode a v r))|
                              (KickUp ll vv rr) \<Rightarrow> (Norm(LargeNode ll vv rr v r )))|
                   Larger \<Rightarrow> (case insert a  r of
                              (Norm a) \<Rightarrow> (Norm (SmallNode l v a))|
                              (KickUp ll vv rr) \<Rightarrow> (Norm(LargeNode l v ll vv rr )))|
                   Bet \<Rightarrow> (Norm ((SmallNode l v r)))) "|
"insert a (LargeNode l lv m rv r) = (case eval a lv (Option rv) of
             Smaller \<Rightarrow> (case insert a l of
                        (Norm a) \<Rightarrow> (Norm (LargeNode a lv m rv r))|
                        (KickUp ll vv rr) \<Rightarrow> (KickUp (SmallNode ll vv rr) lv (SmallNode m rv r)))|
             Larger \<Rightarrow> (case insert a r of
                       (Norm a) \<Rightarrow> (Norm (LargeNode l lv m rv a))|
                       (KickUp ll vv rr) \<Rightarrow> (KickUp (SmallNode l lv m) rv (SmallNode ll vv rr)))|
             Bet \<Rightarrow> (case insert a m of
                       (Norm a) \<Rightarrow> (Norm (LargeNode l lv a rv r))|
                       (KickUp ll vv rr) \<Rightarrow> (KickUp (SmallNode l lv ll) vv (SmallNode rr rv r))))"

definition convertKick :: "'a TempIns \<Rightarrow> 'a tttree " where
"convertKick k = (case k of
    (Norm a) \<Rightarrow> a|
    (KickUp ll vv rr) \<Rightarrow> (SmallNode ll vv rr))"

(*Checks if the value to be inserted is already present in the tree,
 if it is skip the insertion*)
fun ins :: "('a::linorder) \<Rightarrow> 'a tttree \<Rightarrow> 'a tttree" where
"ins a t =( case (contains a t) of
           True \<Rightarrow> t|
           False \<Rightarrow> (convertKick(TTTree.insert a t)))"

(* ========================================== Delete and aux functions =========================================*)

(*Checks if the value to delete is in the current node*)

primrec nxt :: "'a list \<Rightarrow> ('a::linorder) \<Rightarrow> 'a May" where
"nxt [] a = None"|
"nxt (x#xs) a = (if x > a then (Option x)
               else (nxt xs a))"

primrec replace :: "('a::linorder) \<Rightarrow> ('a::linorder) \<Rightarrow> 'a tttree \<Rightarrow> 'a tttree" where
"replace _ _ Empty = Empty"|
"replace old new (SmallNode l v r) = (case old = v of
                                     True \<Rightarrow> (SmallNode l new r)|
                                     False \<Rightarrow> (if old < v then (SmallNode (replace old new l) v r)
                                              else (SmallNode l v (replace old new r))))"|
"replace old new (LargeNode l lv m rv r) = (case old = lv of
                                     True \<Rightarrow> (LargeNode l new m rv r)|
                                     False \<Rightarrow> (case old = rv of
                                                  True \<Rightarrow>  (LargeNode l new m rv r)|
                                                  False \<Rightarrow> (if old < lv then (LargeNode (replace old new l) lv m rv r)
                                                            else if old > rv then  (LargeNode l lv m rv (replace old new r ))
                                                            else (LargeNode l lv (replace old new m) rv r))))"

(*Delete successor, then replace the value to be deleted from the result of that with the successor *)

fun small_large :: "'a tttree \<Rightarrow> 'a tttree \<Rightarrow> 'a  \<Rightarrow> 'a TempDel" where
" small_large Empty _ _ = Hole Empty"|
" small_large (SmallNode  ll vv rr) c v = (Hole (LargeNode ll vv rr v c ))"|
" small_large (LargeNode   lll llv mm rrv rrr) c v = (Nor (SmallNode (SmallNode lll llv mm) rrv (SmallNode rrr v c)))"

fun small_small :: "'a tttree \<Rightarrow> 'a tttree \<Rightarrow> 'a \<Rightarrow> 'a TempDel" where
 "small_small Empty _ _ = (Hole Empty)"|
 " small_small (SmallNode  ll vv rr) c v = (Hole (LargeNode c v ll vv rr ))"|
 "small_small (LargeNode lll llv mm rrv rrr) c v = (Nor (SmallNode (SmallNode c v lll) llv (SmallNode mm rrv rrr)))"

primrec large_large :: "'a tttree \<Rightarrow>'a tttree \<Rightarrow> 'a tttree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a TempDel" where
" large_large Empty _ _ _ _= (Hole Empty)"|
"large_large (SmallNode  ll v rr) c l lv rv = (Nor(SmallNode l lv (LargeNode ll v rr rv c)))"|
" large_large (LargeNode ll llv mm rrv rr) c l lv rv = (Nor (LargeNode l lv (SmallNode ll llv mm) rrv (SmallNode rr rv c) ))"

primrec large_small :: " 'a tttree \<Rightarrow> 'a tttree \<Rightarrow> 'a tttree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a TempDel" where
"large_small Empty _ _ _ _ = (Hole Empty)"|
"large_small(SmallNode ll v rr) c r lv rv =  Nor(SmallNode (LargeNode c lv ll v rr) rv r)"|
"large_small (LargeNode ll llv mm rrv rr) c r lv rv = Nor (LargeNode (SmallNode c lv ll) llv (SmallNode mm rrv rr) rv r)"

primrec large_mid ::  " 'a tttree \<Rightarrow> 'a tttree \<Rightarrow> 'a tttree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a TempDel" where
"large_mid Empty _ _ _ _ = (Hole Empty)"|
"large_mid (SmallNode  ll v rr) c r lv rv  = Nor (SmallNode (LargeNode ll v rr lv c) rv r)"|
"large_mid (LargeNode ll llv mm rrv rr) c r lv rv = Nor (LargeNode (SmallNode ll llv mm) rrv (SmallNode rr lv c) rv r)"

(*TODO : Add removal of elements from non-terminal nodes*)
fun delete:: "('a::linorder) \<Rightarrow> 'a tttree \<Rightarrow> 'a TempDel" where
"delete a Empty = Hole Empty"|
"delete a (SmallNode l v r) =  (case (eval a v None) of
                             Larger \<Rightarrow> (case (delete a r) of
                                       (Nor c) \<Rightarrow> Nor (SmallNode l v c)|
                                       (Hole c) \<Rightarrow> (small_large l c v))  |
                             Smaller \<Rightarrow> (case (delete a l) of
                                       (Nor b) \<Rightarrow> Nor (SmallNode b v r)|
                                       (Hole c) \<Rightarrow>(small_small r c v)) |
                             Bet \<Rightarrow> Nor (SmallNode l v r))"|
"delete a (LargeNode l lv m rv r) = (case (empty l) of
          Em \<Rightarrow> (if a = lv then (Nor(SmallNode Empty rv Empty))
                   else (Nor(SmallNode Empty lv Empty)))|
          Na \<Rightarrow> (case (eval a lv (Option rv)) of
                            Larger \<Rightarrow> (case (delete a r) of
                                      (Nor c) \<Rightarrow> Nor (LargeNode l lv m rv c)|
                                      (Hole c) \<Rightarrow> (large_large m c l lv rv ))|
                            Smaller \<Rightarrow> (case (delete a l) of
                                       (Nor c) \<Rightarrow> Nor (LargeNode c lv m rv r)|
                                       (Hole c) \<Rightarrow> large_small m c r lv rv)|
                            Bet \<Rightarrow> (case (delete a m) of
                                   (Nor c) \<Rightarrow> Nor (LargeNode l lv c rv r)|
                                   (Hole c) \<Rightarrow> large_mid l c r lv rv)))"

definition convertHole:: "'a TempDel \<Rightarrow> 'a tttree" where
"convertHole a = (case a of
                 (Nor b) \<Rightarrow> b|
                 (Hole b) \<Rightarrow> b)"

primrec leaf :: "('a::linorder) \<Rightarrow> 'a tttree \<Rightarrow> bool" where
"leaf a Empty = False" |
"leaf a (SmallNode l v r)  =
        (if a < v then leaf a l
        else if a > v then leaf a r
        else (if l = Empty then True else False))" |
"leaf a (LargeNode l lv m rv r) =
        (if a = lv  then (if l = Empty then True else False)
        else if a = rv then (if r = Empty then True else False)
        else if a < lv then leaf a l
        else if a > rv then leaf a r
        else leaf a m)"

definition del :: "('a::linorder) \<Rightarrow> 'a tttree \<Rightarrow> 'a tttree" where
"del a t = (case contains a t of
                False \<Rightarrow> t|
                True \<Rightarrow>(case leaf a t of
                             True \<Rightarrow> convertHole (delete a t)|
                             False \<Rightarrow>(case (nxt (elements t) a) of
                                     None \<Rightarrow> t|
                                     Option b \<Rightarrow>replace a b (convertHole(delete b t)))))"

(*==========================================Auxilliary functions for proving========================================================*)

fun heightTree :: "'a tttree \<Rightarrow> nat" where
"heightTree Empty = 0"|
"heightTree (SmallNode l v r) = (max (heightTree l) (heightTree r)) + 1"|
"heightTree (LargeNode l lv m rv r) = (max (heightTree l) (max(heightTree m) (heightTree r))) + 1 "

primrec TT :: "'a tttree \<Rightarrow> bool" where
"TT Empty = True"|
"TT (SmallNode l _ r) = ((heightTree l = heightTree r) & (TT l) & (TT r) )"|
"TT (LargeNode l _ m _ r) = (((heightTree l  = heightTree r) \<and> (heightTree l = heightTree m)) \<and> (TT l) \<and> (TT m) \<and> (TT r))"

fun kickHeight:: "'a TempIns \<Rightarrow> nat" where
"kickHeight (Norm a) = heightTree a"|
"kickHeight (KickUp l _ r) = (max (heightTree l) (heightTree r))"

(*============================================================PROOFS===============================================================*)
(*============================================================Correctness of contains================================================*)

theorem cont_corr_set : "sorted(elements t) \<Longrightarrow> contains a t = (a \<in> set (elements t))"
proof (induct t)
  case Empty
  then show ?case by simp
next
  case (SmallNode l v r)
  then show ?case by (simp add: isin_simps) (auto)
next
  case (LargeNode l lv m rv r)
  then show ?case by (simp add: isin_simps) (meson UnCI not_less_iff_gr_or_eq)
qed
(* apply(induct t)
   apply(simp)
   apply(simp_all add:isin_simps)
   apply auto
   by (meson UnCI not_less_iff_gr_or_eq) *)

(*===============================================================Insertion proofs order====================================================*)

theorem ins_order : "\<lbrakk>a \<notin> set( elements t) ;sorted (elements t); distinct (elements t); (TT t) = True\<rbrakk> \<Longrightarrow>  elements (convertKick (insert a t)) =  ins_list a (elements t)"
proof (induct t)
  case Empty
  then show ?case by (simp add: convertKick_def)
next
  case (SmallNode l v r)
  then show ?case by (simp add: convertKick_def ins_list_simps sorted_Cons_iff eval_def split: TempIns.splits)
next
  case (LargeNode l lv m rv r)
  then show ?case by (simp add: convertKick_def ins_list_simps sorted_Cons_iff eval_def split: TempIns.splits)
qed
(*  apply(induct t)
  apply(simp_all add:  ins_list_simps TTTree.eval_def sorted_Cons_iff  convertKick_def split: TempIns.splits )
  done *)

lemma ins_list_same : "\<lbrakk> a \<in> set l;sorted l\<rbrakk> \<Longrightarrow> ins_list a l = l"
  apply(induction l)
  apply(simp_all)
  using less_imp_not_less sorted_Cons_iff by blast

(*Necessary ??*)
theorem insert_order : "\<lbrakk>sorted (elements t);distinct (elements t) ;(TT t) = True\<rbrakk> \<Longrightarrow>  elements(ins a t) =  ins_list a (elements t)"
  apply(simp split: bool.splits)
  apply(simp add: cont_corr_set ins_list_same)
  apply(simp add: ins_order cont_corr_set)
  done

(*===============================================================Insertion proofs full====================================================*)
lemma complete_ins : "\<lbrakk>a \<notin> set( elements t) ;TT t\<rbrakk> \<Longrightarrow> (TT (convertKick (insert a t))) \<and> heightTree t = kickHeight (insert a t)"
proof (induct t)
  case Empty
  then show ?case by (simp add:convertKick_def)
next
  case (SmallNode l _ r)
  then show ?case by (auto split:  TempIns.splits May.splits Eval.splits) (simp_all add: convertKick_def)
next
  case (LargeNode l _ m _ r)
  then show ?case by (auto split:  TempIns.splits May.splits Eval.splits) (simp_all add: convertKick_def)
qed
(*
  apply(induct t)
  apply (auto split!: TempIns.splits May.splits Eval.splits)
  apply(simp_all add: convertKick_def )
  done*)

lemma complete_insert : "\<lbrakk>sorted(elements t); TT t\<rbrakk> \<Longrightarrow> TT (ins a t) "
  apply(simp split: bool.splits)
  apply(simp_all add:convertKick_def)
  by (metis complete_ins cont_corr_set convertKick_def)

(*===============================================================Deletion proofs order====================================================*)

lemma empty_height : "(empty t = Em) = (heightTree t = 0)"
  apply(induct t)
  apply(simp_all add: empty_def)
  done

lemma small_large_ord : "\<lbrakk>l \<noteq> Empty\<rbrakk> \<Longrightarrow>  (elements (convertHole (small_large l r val)) =  elements(l) @ val # elements (r) )"
  apply(induct l)
   apply(auto simp: convertHole_def)
  done

lemma small_small_ord : "\<lbrakk>l \<noteq> Empty\<rbrakk> \<Longrightarrow>  (elements (convertHole (small_small l r val)) =  elements(r) @ val # elements (l) ) "
  apply(induct l)
   apply(auto simp: convertHole_def)
  done

lemma large_large_ord : "\<lbrakk>t1 \<noteq> Empty\<rbrakk> \<Longrightarrow>  elements (convertHole (large_large t1 t2 t3  val1 val2)) =  elements(t3) @ val1 # elements (t1) @val2 # elements t2"
  apply(induct t1)
   apply(auto simp: convertHole_def)
  done

lemma large_small_ord : "\<lbrakk>t1 \<noteq> Empty\<rbrakk> \<Longrightarrow>  elements (convertHole (large_small t1 t2 t3  val1 val2)) =  elements(t2) @ val1 # elements (t1) @val2 # elements t3"
  apply(induct t1)
   apply(auto simp: convertHole_def)
  done

lemma large_mid_ord : "\<lbrakk>t1 \<noteq> Empty\<rbrakk> \<Longrightarrow>  elements (convertHole (large_mid t1 t2 t3  val1 val2)) =  elements(t1) @ val1 # elements (t2) @val2 # elements t3"
  apply(induct t1)
   apply(auto simp: convertHole_def)
  done

thm sorted_snoc_iff

theorem delete_ord : "\<lbrakk>sorted (elements t); leaf a t;distinct(elements(t)); TT t \<rbrakk> \<Longrightarrow> (elements(convertHole (delete a t))) = (del_list a (elements t))"
  apply(induct t)
  apply( simp_all split!: TempDel.splits Eval.splits Emp.splits)
  apply( simp_all add: sorted_Cons_iff del_list_simps sorted_snoc_iff convertHole_def )
  apply(simp_all add: empty_height)
  apply auto[1]
  sorry

lemma del_ord : "\<lbrakk>sorted (elements t);distinct(elements(t)); (TT t) = True \<rbrakk> \<Longrightarrow> (elements(del a t)) = (del_list a (elements t))"
  apply(simp add: del_def)
  apply(auto split : bool.splits)
     apply(simp add: delete_ord)
    apply(simp_all add: cont_corr_set)
    apply (simp_all add: del_list_idem)
  apply(simp split: May.splits)
  apply auto
  oops

(*==========================================Join========================================================================*)

fun join_aux :: "('a::linorder) list \<Rightarrow> ('a :: linorder) tttree \<Rightarrow> 'a tttree " where
"join_aux [] t = t"|
"join_aux (a#b) t = join_aux b (ins a t)"

definition join :: "('a::linorder) tttree \<Rightarrow> ('a::linorder)tttree \<Rightarrow> 'a tttree" where
"join a b =  join_aux (elements a) b "

(*Reformulate lemma in correct way*)
lemma join_aux_ord : " \<lbrakk>sorted l ;sorted(elements t)\<rbrakk> \<Longrightarrow> elements (join_aux l t ) = l@(elements t)"
  apply(induct l)
  apply auto
  apply(simp split: bool.split)
  apply rule
  apply rule
  apply (simp_all add: sorted_Cons_iff)
   apply auto
   defer
  sorry

theorem join_ord : "\<lbrakk>TT t1;distinct (elements (t2)) ;TT t2; sorted (elements t1);  sorted (elements t2) \<rbrakk> \<Longrightarrow>sorted (elements( join t1 t2)) "
  apply(simp add: join_def)
  apply(simp add: join_aux_ord)

  oops

export_code contains empty insert convertKick ins  delete convertHole leaf replace  del in Haskell module_name TTTree

end


theory bin_plus
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus2 :: "Bin => Bin => Bin" where
"plus2 (One) y = s y"
| "plus2 (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus2 (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus2 z ys)"
| "plus2 (ZeroAnd z) (OneAnd xs) = OneAnd (plus2 z xs)"
| "plus2 (OneAnd x2) (One) = s (OneAnd x2)"
| "plus2 (OneAnd x2) (ZeroAnd zs) = OneAnd (plus2 x2 zs)"
| "plus2 (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus2 x2 ys2))"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun toNat :: "Bin => Nat" where
"toNat (One) = S Z"
| "toNat (ZeroAnd xs) = plus (toNat xs) (toNat xs)"
| "toNat (OneAnd ys) = S (plus (toNat ys) (toNat ys))"

(*hipster s plus*)
lemma lemma_a [thy_expl]: "ZeroAnd x2 = plus2 x2 x2"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_aa [thy_expl]: "plus2 x2 One = s x2"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ab [thy_expl]: "s (plus2 x2 y2) = plus2 x2 (s y2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ac [thy_expl]: "plus2 (s x2) y2 = plus2 x2 (s y2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ad [thy_expl]: "plus2 (plus2 x1 x1) x1 = plus2 x1 (plus2 x1 x1)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ae [thy_expl]: "plus2 (s x2) (plus2 y2 z2) = plus2 (plus2 x2 y2) (s z2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_af [thy_expl]: "plus2 (s x2) (plus2 y2 z2) = plus2 (plus2 y2 z2) (s x2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ag [thy_expl]: "plus2 (plus2 x2 x2) (plus2 x2 y2) = plus2 (plus2 x2 y2) (plus2 x2 x2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ah [thy_expl]: "plus2 (plus2 x2 x2) (plus2 y2 x2) = plus2 (plus2 y2 x2) (plus2 x2 x2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ai [thy_expl]: "plus2 (plus2 x2 x2) (plus2 y2 y2) = ZeroAnd (plus2 y2 x2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_aj [thy_expl]: "plus2 x1 y1 = plus2 y1 x1"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_ak [thy_expl]: "plus2 x2 (plus2 y2 z2) = plus2 y2 (plus2 x2 z2)"
by (hipster_induct_schemes s.simps plus2.simps)

lemma lemma_al [thy_expl]: "plus2 (plus2 x2 y2) (plus2 z2 y2) = plus2 (plus2 x2 z2) (plus2 y2 y2)"
by (hipster_induct_schemes s.simps plus2.simps)

theorem x0 :
  "!! (x :: Bin) (y :: Bin) .
     (toNat (plus2 x y)) = (plus (toNat x) (toNat y))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_BSortIsSort
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "int list => int list => int list" where
  "pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "int list => int list => int list" where
  "stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

fun insert :: "int => int list => int list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if y <= z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
  by pat_completeness auto

(*fun did not finish the proof*)
function bmerge :: "int list => int list => int list" where
  "bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: int list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "int list => int list" where
  "bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "((bsort xs) = (isort xs))"
  oops

end


section\<open>CNOT in QHLProver\<close>

theory CNOT
  imports QHLProver.Gates
  QHLProver.Partial_State
  QHLProver.Quantum_Hoare
  QHLProver.Quantum_Program
  QHLProver.Grover
  QHLProver.Complex_Matrix
begin

subsection\<open>Environment Settings\<close>

locale cnot_state = state_sig +
  fixes n :: nat  (* number of qubits *)
  assumes n: "n = (2::nat)"
  assumes dims_def: "dims = [2,2]"
begin

definition N where
  "N = (2::nat) ^ n"

lemma N_4:
  "N == 4" using N_def n by auto

lemma d_4:
  "d == 4"
  using d_def dims_def by auto

lemma N_d:
  "N == d"
  using d_4 N_4 by auto

subsection\<open>State Vectors and Properties\<close>

abbreviation proj :: "complex vec \<Rightarrow> complex mat" where
  "proj v \<equiv> outer_prod v v"

definition ket_10 :: "complex vec" where
  "ket_10 = Matrix.vec N (\<lambda>i . if i = 2 then 1 else 0)"

lemma ket_10_dim [simp]:
  "ket_10 \<in> carrier_vec N"
  "dim_vec ket_10 = N"
  by (simp add: ket_10_def)+

lemma ket_10_eval:
  "i < N \<Longrightarrow> ket_10 $ i = (if i = 2 then 1 else 0)"
  by (simp add: ket_10_def)

definition ket_11 :: "complex vec" where
  "ket_11 = Matrix.vec N (\<lambda>i. if i = 3 then 1 else 0)"

lemma ket_11_dim [simp]:
  "ket_11 \<in> carrier_vec N"
  "dim_vec ket_11 = N"
  by (simp add: ket_11_def)+

lemma ket_11_eval:
  "i < N \<Longrightarrow> ket_11 $ i = (if i = 3 then 1 else 0)"
  by (simp add: ket_11_def)

subsection\<open>Precondition and Postcondition\<close>
definition proj_10 where
  "proj_10 = proj ket_10"

lemma norm_pre:
  "inner_prod ket_10 ket_10 = 1"
  unfolding ket_10_def
  apply (simp add: scalar_prod_def)
  using sum_only_one_neq_0[of "{0..<N}" 2 "\<lambda>i. (if i = 2 then 1 else 0) * cnj (if i = 2 then 1 else 0)"] N_def
  n by auto

lemma qp_pre:
  "is_quantum_predicate proj_10"
  unfolding is_quantum_predicate_def
proof (intro conjI)
  show "proj_10 \<in> carrier_mat d d" using proj_10_def ket_10_def N_d by auto
  show "positive proj_10"
    using positive_same_outer_prod
    unfolding proj_10_def ket_10_def
    by auto
  show "proj_10 \<le>\<^sub>L 1\<^sub>m d"
    unfolding proj_10_def
    using norm_pre N_d outer_prod_le_one ket_10_def
    by auto
qed

definition proj_11 where
  "proj_11 = proj ket_11"

lemma norm_post:
  "inner_prod ket_11 ket_11 = 1"
  unfolding ket_11_def
  apply (simp add: scalar_prod_def)
  using sum_only_one_neq_0[of "{0..<N}" 3 "\<lambda>i. (if i = 3 then 1 else 0) * cnj (if i = 3 then 1 else 0)"] N_def
  n by auto

lemma qp_post:
  "is_quantum_predicate proj_11"
  unfolding is_quantum_predicate_def
proof (intro conjI)
  show "proj_11 \<in> carrier_mat d d" using proj_11_def ket_11_def N_d by auto
  show "positive proj_11"
    using positive_same_outer_prod
    unfolding proj_11_def ket_11_def
    by auto
  show "proj_11 \<le>\<^sub>L 1\<^sub>m d"
    unfolding proj_11_def
    using norm_post N_d outer_prod_le_one ket_11_def
    by auto
qed

subsection\<open>CNOT Gate and Properties\<close>
definition cnot :: "complex mat" where
  "cnot = mat N N (\<lambda>(i,j).
    if i=j then
      (if (i=0 \<or> i=1) then 1 else 0)
      else (if (i=2 \<and> j=3) \<or> (i=3 \<and> j=2)
        then 1 else 0))"

lemma cnot_dim:
   "cnot \<in> carrier_mat N N"
  unfolding cnot_def by auto

lemma hermitian_cnot:
  "hermitian cnot"
  by (auto simp add: hermitian_def cnot_def adjoint_eval)

lemma cnot_cnot_eq_id:
  shows "cnot *  cnot = 1\<^sub>m N"
  apply(rule eq_matI,simp)
  apply(auto simp add: carrier_matD[OF cnot_dim] scalar_prod_def)
  unfolding cnot_def
  apply(simp_all)
  apply(case_tac "j = 3")
  subgoal for j
    unfolding N_4
    by (simp add: sum_only_one_neq_0[of _ "2"])
  apply (case_tac "j = 2")
  subgoal for j
    unfolding N_4
    by (simp add: sum_only_one_neq_0[of _ "3"])
  apply (case_tac "j = 1")
  subgoal for j
    unfolding N_4
    by (simp add: sum_only_one_neq_0[of _ "1"])
  subgoal for j
    unfolding N_4
    by (simp add: sum_only_one_neq_0[of _ "0"])
  done

lemma unitary_cnot:
  "unitary cnot"
proof -
  have "cnot \<in> carrier_mat N N"
    using cnot_dim by auto
  moreover have "cnot * adjoint cnot = cnot * cnot"
    using hermitian_cnot unfolding hermitian_def by auto
  moreover have "cnot * cnot = 1\<^sub>m N"
    using cnot_cnot_eq_id by auto
  ultimately show ?thesis
    unfolding unitary_def inverts_mat_def by auto
qed

definition cnot_circ :: "com" where
  "cnot_circ = Utrans cnot"

lemma well_com_cnot:
  "well_com cnot_circ"
  unfolding cnot_circ_def
  using unitary_cnot cnot_dim N_4 d_4
  by auto

subsection\<open>Deduction\<close>
subsubsection\<open>Sanity Check with Identity\<close>
definition id :: "complex mat" where
  "id = mat N N (\<lambda>(i,j). if i=j then 1 else 0)"

lemma id_times_11:
  "id *\<^sub>v ket_11 = ket_11"
  by (auto simp add: id_def ket_11_def
    scalar_prod_def sum_only_one_neq_0)

thm scalar_prod_def
thm sum_only_one_neq_0[of _ "1" "\<lambda>i. i+ 5"]

subsubsection\<open>CNOT Correctness Deductions\<close>
lemma cnot_times_11:
  "cnot *\<^sub>v ket_11 = ket_10"
  apply (rule eq_vecI, simp)
  apply(auto simp add: carrier_matD[OF cnot_dim] scalar_prod_def)
  unfolding cnot_def ket_11_def ket_10_def N_4 scalar_prod_def
    by (simp add: sum_only_one_neq_0[of _ "3"])

(*
Alternate attempt
lemma sub:
  "k \<noteq> 2 \<Longrightarrow> (cnot *\<^sub>v ket_11) $ k = 0"
  using cnot_def ket_11_def scalar_prod_def by auto

lemma sub2:
  "k = 2 \<Longrightarrow> (cnot *\<^sub>v ket_11) $ k = 1"
  by (auto simp add: cnot_def ket_11_def
  scalar_prod_def)

proof -
  have "dim_vec (cnot *\<^sub>v ket_11) = dim_vec ket_10"
    using cnot_def by auto
  moreover have "\<And>i. i < dim_vec ket_10 \<Longrightarrow>
         (cnot *\<^sub>v ket_11) $ i = ket_10 $ i"
    using ket_10_def sub sub2 by auto
  ultimately show ?thesis by auto
qed
*)

lemma cnot_times_post_is_pre:
  "adjoint cnot * proj_11 * cnot = proj_10"
proof -
  let ?m = "cnot"
  have eq: "adjoint ?m = ?m"
    using hermitian_def hermitian_cnot by auto
  {
    let ?p = "proj_11"
    have "?m * ?p * ?m = outer_prod ket_10 ket_10"
      unfolding proj_11_def
      using ket_11_def cnot_dim cnot_times_11 eq
      apply (subst outer_prod_left_right_mat[of _ N _ N  _ N _ N])
      by auto
  }
  note p = this
  have "adjoint cnot * proj_11 * cnot = ?m * proj_11 *?m"
    using eq by auto
  also have "... = proj_10"
    unfolding proj_10_def
    using p
    by auto
  finally show ?thesis by auto
qed

lemma adjoint_deduction:
  "\<turnstile>\<^sub>p
   {adjoint cnot * proj_11 * cnot}
    cnot_circ
   {proj_11}"
  unfolding cnot_circ_def using
  hoare_partial.intros(2)
  unitary_cnot qp_post
  by auto

lemma prog_partial_deduct:
  "\<turnstile>\<^sub>p
   {proj_10}
    cnot_circ
   {proj_11}"
  using cnot_times_post_is_pre adjoint_deduction by auto

theorem prog_partial_correct:
  "\<Turnstile>\<^sub>p
   {proj_10}
    cnot_circ
   {proj_11}"
  using
  prog_partial_deduct
  well_com_cnot qp_pre qp_post
  hoare_partial_sound by auto

end

end


section \<open>Introsort (roughly libstdc++ version)\<close>
theory Sorting_Introsort
imports
  Sorting_Final_insertion_Sort Sorting_Heapsort Sorting_Log2
  Sorting_Quicksort_Partition
  Sorting_Strings
begin

context weak_ordering begin

  (* Assemble an introsort loop, using the partitioner and heap-sort *)

  definition introsort_aux4 :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list nres" where "introsort_aux4 xs l h d \<equiv> RECT (\<lambda>introsort_aux (xs,l,h,d). doN {
    ASSERT (l\<le>h);
    if h-l > is_threshold then doN {
      if d=0 then
        heapsort xs l h
      else doN {
        (xs,m)\<leftarrow>partition_pivot xs l h;
        xs \<leftarrow> introsort_aux (xs,l,m,d-1);
        xs \<leftarrow> introsort_aux (xs,m,h,d-1);
        RETURN xs
      }
    }
    else
      RETURN xs
  }) (xs,l,h,d)"

  lemma introsort_aux4_refine: "introsort_aux4 xs l h d \<le> (introsort_aux3 xs l h d)"
    unfolding introsort_aux4_def introsort_aux3_def
    apply (rule refine_IdD)
    apply (refine_rcg heapsort_correct' partition_pivot_correct)
    apply refine_dref_type
    apply simp_all
    done

  lemmas introsort_aux4_correct = order_trans[OF introsort_aux4_refine introsort_aux3_correct, THEN refine_IdI]

  definition "introsort4 xs l h \<equiv> doN {
    ASSERT(l\<le>h);
    if h-l>1 then doN {
      xs \<leftarrow> introsort_aux4 xs l h (Discrete.log (h-l)*2);
      xs \<leftarrow> final_insertion_sort2 xs l h;
      RETURN xs
    } else RETURN xs
  }"

  lemma introsort4_refine: "introsort4 xs l h \<le> introsort3 xs l h"
    unfolding introsort4_def introsort3_def
    apply (rule refine_IdD)
    apply (refine_rcg introsort_aux4_correct final_insertion_sort2_correct[THEN refine_IdI])
    by auto

  lemmas introsort4_correct = order_trans[OF introsort4_refine introsort3_correct]

end

lemma introsort_depth_limit_in_bounds_aux: (* TODO: Move depth-computation into own (inline) function *)
  assumes "n < max_snat N" "1<N" shows "Discrete.log (n) * 2 < max_snat N"
proof (cases "n=0")
  case True thus ?thesis using assms by auto
next
  case [simp]: False
  have ?thesis if "Discrete.log (n) < max_snat (N-1)"
    using that \<open>1<N\<close> unfolding max_snat_def
    by (metis nat_mult_power_less_eq pos2 semiring_normalization_rules(33))
  moreover have "Discrete.log (n) < max_snat (N-1)"
    apply (rule discrete_log_ltI)
    using assms apply (auto simp: max_snat_def)
    by (smt Suc_diff_Suc leI le_less_trans n_less_equal_power_2 nat_power_less_imp_less not_less_eq numeral_2_eq_2 numeral_2_eq_2 zero_order(3))
  ultimately show ?thesis .
qed

context sort_impl_context begin

sepref_register introsort_aux4
sepref_def introsort_aux_impl is "uncurry3 (PR_CONST introsort_aux4)" :: "(arr_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  unfolding introsort_aux4_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

sepref_register introsort4
sepref_def introsort_impl is "uncurry2 (PR_CONST introsort4)" :: "(arr_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  unfolding introsort4_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  supply [intro!] = introsort_depth_limit_in_bounds_aux
  by sepref

lemma introsort4_refine_ss_spec: "(PR_CONST introsort4, slice_sort_spec (\<^bold><))\<in>Id\<rightarrow>Id\<rightarrow>Id\<rightarrow>\<langle>Id\<rangle>nres_rel"
  using introsort4_correct by (auto intro: nres_relI)

theorem introsort_impl_correct: "(uncurry2 introsort_impl, uncurry2 (slice_sort_spec (\<^bold><))) \<in> arr_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  using introsort_impl.refine[FCOMP introsort4_refine_ss_spec] .

end

context parameterized_weak_ordering begin
  (* TODO: Move *)
  lemmas heapsort_param_refine'[refine] = heapsort_param_refine[unfolded heapsort1.refine[OF WO.weak_ordering_axioms, symmetric]]

  definition introsort_aux_param :: "'cparam \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list nres" where
    "introsort_aux_param cparam xs l h d \<equiv> RECT (\<lambda>introsort_aux (xs,l,h,d). doN {
    ASSERT (l\<le>h);
    if h-l > is_threshold then doN {
      if d=0 then
        heapsort_param cparam xs l h
      else doN {
        (xs,m)\<leftarrow>partition_pivot_param cparam xs l h;
        xs \<leftarrow> introsort_aux (xs,l,m,d-1);
        xs \<leftarrow> introsort_aux (xs,m,h,d-1);
        RETURN xs
      }
    }
    else
      RETURN xs
  }) (xs,l,h,d)"

  lemma introsort_aux_param_refine[refine]:
    "\<lbrakk> (xs',xs)\<in>cdom_list_rel cparam; (l',l)\<in>Id; (h',h)\<in>Id; (d',d)\<in>Id
    \<rbrakk> \<Longrightarrow> introsort_aux_param cparam xs' l' h' d' \<le>\<Down>(cdom_list_rel cparam) (WO.introsort_aux4 cparam xs l h d)"
    unfolding introsort_aux_param_def WO.introsort_aux4_def
    supply [refine_dref_RELATES] = RELATESI[of "cdom_list_rel cparam"]
    apply (refine_rcg)
    apply refine_dref_type
    apply simp_all
    done

  definition "introsort_param cparam xs l h \<equiv> doN {
    ASSERT(l\<le>h);
    if h-l>1 then doN {
      xs \<leftarrow> introsort_aux_param cparam xs l h (Discrete.log (h-l)*2);
      xs \<leftarrow> final_insertion_sort_param cparam xs l h;
      RETURN xs
    } else RETURN xs
  }"

  lemma introsort_param_refine:
    "\<lbrakk> (xs',xs)\<in>cdom_list_rel cparam; (l',l)\<in>Id; (h',h)\<in>Id
    \<rbrakk> \<Longrightarrow> introsort_param cparam xs' l' h' \<le> \<Down>(cdom_list_rel cparam) (WO.introsort4 cparam xs l h)"
    unfolding introsort_param_def WO.introsort4_def
    apply (refine_rcg)
    by auto

  lemma introsort_param_correct:
    assumes "(xs',xs)\<in>Id" "(l',l)\<in>Id" "(h',h)\<in>Id"
    shows "introsort_param cparam xs' l' h' \<le> pslice_sort_spec cdom pless cparam xs l h"
  proof -
    note introsort_param_refine
    also note WO.introsort4_correct
    also note slice_sort_spec_xfer
    finally show ?thesis
      unfolding pslice_sort_spec_def
      apply refine_vcg
      using assms unfolding cdom_list_rel_alt
      by (simp add: in_br_conv)

  qed

  lemma introsort_param_correct':
    shows "(PR_CONST introsort_param, PR_CONST (pslice_sort_spec cdom pless)) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
    using introsort_param_correct
    apply (intro fun_relI nres_relI)
    by simp

end

context parameterized_sort_impl_context begin

sepref_register introsort_aux_param
sepref_def introsort_aux_param_impl is "uncurry4 (PR_CONST introsort_aux_param)"
  :: "cparam_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  unfolding introsort_aux_param_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

sepref_register introsort_param
sepref_def introsort_param_impl is "uncurry3 (PR_CONST introsort_param)" :: "cparam_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  unfolding introsort_param_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  supply [intro!] = introsort_depth_limit_in_bounds_aux
  by sepref

lemma introsort_param_impl_correct: "(uncurry3 introsort_param_impl, uncurry3 (PR_CONST (pslice_sort_spec cdom pless)))
        \<in> cparam_assn\<^sup>k *\<^sub>a arr_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  using introsort_param_impl.refine[FCOMP introsort_param_correct'] .

end

end


theory T142
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T114
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


subsection "Swapping Indicies"
theory Reindex
  imports Debruijn
begin

context includes poly_mapping.lifting begin

definition "swap i j x = (if x = i then j else if x = j then i else x)"

lemma swap_swap : "swap i j (swap i j x) = x"
  unfolding swap_def by auto

lemma finite_swap_ne: "finite {x. f x \<noteq> c} \<Longrightarrow> finite {x. f (swap b i x) \<noteq> c}"
proof -
  assume finset: "finite {x. f x \<noteq> c}"
  let ?A = "{x. f x \<noteq> c}"
  let ?B = "{x. f (swap b i x) \<noteq> c}"
  have finsubset: "finite (?A - {i, b})" using finset by auto
  have sames: "(?A - {i, b}) = (?B - {i, b})"
    unfolding swap_def by auto
  then have "finite (?B - {i, b})"
    using finsubset by auto
  then have finBset: "finite ((?B - {i, b}) \<union> {i, b})" by auto
  then have "?B \<subseteq> ((?B - {i, b}) \<union> {i, b})" by auto
  then show ?thesis using finBset by auto
qed

lift_definition swap0::"nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a::zero)"
  is "\<lambda>b i p x. p (swap b i x)::'a"
proof -
  fix b i::nat and p::"nat \<Rightarrow> 'a"
  assume "finite {x. p x \<noteq> 0}"
  then have "finite {x. p (swap b i x) \<noteq> 0}"
    by (rule finite_swap_ne)
  from _ this show "finite {x. p (swap b i x)  \<noteq> 0}"
    by (rule finite_subset) auto
qed

lemma swap0_swap0: "swap0 n i (swap0 n i x) = x"
  by transfer (force simp: swap_def)

lemma inj_swap: "inj (swap b i)"
  using swap_swap
  by (rule inj_on_inverseI)

lemma inj_swap0: "inj (swap0 b i)"
  using swap0_swap0
  by (rule inj_on_inverseI)

lemma swap0_eq: "lookup (swap0 b i p) x = lookup p (swap b i x)"
  by (simp_all add: swap0.rep_eq)

lemma eq_onp_swap : "eq_onp (\<lambda>f. finite {x. f x \<noteq> 0}) (\<lambda>x. lookup m (swap b i x))
   (\<lambda>x. lookup m (swap b i x))"
  unfolding eq_onp_def apply simp
  apply(rule finite_swap_ne)
  by auto

lemma keys_swap: "keys (swap0 b i m) = swap b i ` keys m"
  apply safe
  subgoal for x
    unfolding swap0_def apply simp
    unfolding keys.abs_eq[OF eq_onp_swap]
    by (metis (mono_tags, lifting) Reindex.swap_swap image_eqI lookupNotIn mem_Collect_eq)
  subgoal for x y
    unfolding swap0_def apply simp
    unfolding keys.abs_eq[OF eq_onp_swap]
    by (metis (mono_tags, lifting) Reindex.swap_swap lookup_eq_zero_in_keys_contradict mem_Collect_eq)
  done

context includes fmap.lifting begin

lift_definition swap\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> (nat, 'a) fmap \<Rightarrow> (nat, 'a::zero) fmap"
  is "\<lambda>b i p x. p (swap b i x)"
proof -
  fix b i::nat and p::"nat \<Rightarrow> 'a option"
  assume "finite (dom p)"
  then have "finite {x. p x \<noteq> None}" by (simp add: dom_def)

  have "dom (\<lambda>x. p (swap b i x)) = {x. p (swap b i x) \<noteq> None}"
    by auto
  also have "finite \<dots>"
    by (rule finite_swap_ne) fact
  finally
  have "finite (dom (\<lambda>x. p (swap b i x)))" .
  from _ this
  show "finite (dom (\<lambda>x. p (swap b i x)))"
    by (rule finite_subset) (auto split: if_splits)
qed

lemma compute_swap\<^sub>f[code]: "swap\<^sub>f b i (fmap_of_list xs) =
  fmap_of_list (map (\<lambda>(k, v). (swap b i k, v)) xs)"
proof -
  have *: "map_of (map (\<lambda>(k, y). (swap b i k, y)) (xs)) x =
    map_of xs (swap b i x)"
    for x
    apply (rule map_of_map_key_inverse_fun_eq)
    unfolding swap_swap by auto
  show ?thesis
    unfolding swap\<^sub>f_def apply simp
    unfolding fmlookup_of_list
    unfolding Finite_Map.fmap_of_list.abs_eq
    using map_of_map_key_inverse_fun_eq[where f="swap b i", where g="swap b i", where xs=xs]
    unfolding swap_swap
    apply simp
    by presburger
qed

lemma compute_swap[code]: "swap0 n i (Pm_fmap xs) = Pm_fmap (swap\<^sub>f n i xs)"
  apply(rule poly_mapping_eqI)
  by  (auto simp: swap\<^sub>f.rep_eq swap0.rep_eq fmlookup_default_def swap_def
      split: option.splits)

lift_definition swapPoly\<^sub>0::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0'a::zero) \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0 'a)" is
  "\<lambda>b i (mp::(nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>'a) mon. mp (swap0 b i mon)"
proof -
  fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a"
  assume "finite {x. mp x \<noteq> 0}"
  have "{x. mp (swap0 b i x) \<noteq> 0} = (swap0 b i -` {x. mp x \<noteq> 0})"
    (is "?set = ?vimage")
    by auto
  also
  from finite_vimageI[OF \<open>finite _\<close> inj_swap0]
  have "finite ?vimage" .
  finally show "finite ?set" .
qed

lemma swap_zero[simp]: "swap0 b i 0 = 0"
  by transfer auto

context includes fmap.lifting begin

lift_definition swapPoly\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a::zero)fmap \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a)fmap" is
  "\<lambda>b i (mp::((nat\<Rightarrow>\<^sub>0nat)\<rightharpoonup>'a)) mon::(nat\<Rightarrow>\<^sub>0nat). mp (swap0 b i mon)"
proof -\<comment> \<open>TODO: this is exactly the same proof as the one for \<open>lowerPoly\<^sub>0\<close>\<close>
  fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a option"
  assume "finite (dom mp)"
  also have "dom mp = {x. mp x \<noteq> None}" by auto
  finally have "finite {x. mp x \<noteq> None}" .
  have "(dom (\<lambda>mon. mp (swap0 b i mon))) = {mon. mp (swap0 b i mon) \<noteq> None}"
    (is "?set = _")
    by (auto split: if_splits)
  also have "\<dots> = swap0 b i -` {x. mp x \<noteq> None}" (is "_ = ?vimage")
    by auto
  also
  from finite_vimageI[OF \<open>finite {x. mp x \<noteq> None}\<close> inj_swap0]
  have "finite ?vimage" .
  finally show "finite ?set" .
qed

lemma keys_swap\<^sub>0: "keys (swapPoly\<^sub>0 b i mp) = swap0 b i ` (keys mp)"
  apply (auto )
  subgoal for x
    apply (rule image_eqI[where x="swap0 b i x"])
    by (auto simp: swap0_swap0 in_keys_iff swapPoly\<^sub>0.rep_eq)
  subgoal for x
    apply (auto simp: in_keys_iff swapPoly\<^sub>0.rep_eq)
    by (simp add: swap0_swap0)
  done

end

lemma compute_swapPoly\<^sub>0[code]: "swapPoly\<^sub>0 n i (Pm_fmap m) = Pm_fmap (swapPoly\<^sub>f n i m)"
  by (auto simp: swapPoly\<^sub>0.rep_eq fmlookup_default_def swapPoly\<^sub>f.rep_eq
      split: option.splits
      intro!: poly_mapping_eqI)

lemma compute_swapPoly\<^sub>f[code]: "swapPoly\<^sub>f n i (fmap_of_list xs) =
  (fmap_of_list (map (\<lambda>(mon, c). (swap0 n i mon, c))
    xs))"
  apply (rule sym)
  apply (rule fmap_ext)
  unfolding swapPoly\<^sub>f.rep_eq fmlookup_of_list
  apply (subst map_of_map_key_inverse_fun_eq[where g="swap0 n i"])
  unfolding swap0_swap0 by auto

end
end

lift_definition swap_poly::"nat \<Rightarrow> nat \<Rightarrow> 'a::zero mpoly \<Rightarrow> 'a mpoly" is swapPoly\<^sub>0 .

value "swap_poly 0 1 (Var 0 :: real mpoly)"

lemma coeff_swap_poly: "MPoly_Type.coeff (swap_poly b i mp) x = MPoly_Type.coeff mp (swap0 b i x)"
  by (transfer') (simp add: swapPoly\<^sub>0.rep_eq)

lemma monomials_swap_poly: "monomials (swap_poly b i mp) = swap0 b i ` (monomials mp) "
  by transfer' (simp add: keys_swap\<^sub>0)

fun swap_atom :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom" where
  "swap_atom a b (Eq p) = Eq (swap_poly a b p)"|
  "swap_atom a b (Less p) = Less (swap_poly a b p)"|
  "swap_atom a b (Leq p) = Leq (swap_poly a b p)"|
  "swap_atom a b (Neq p) = Neq (swap_poly a b p)"

fun swap_fm :: "nat \<Rightarrow> nat \<Rightarrow> atom fm \<Rightarrow> atom fm" where
  "swap_fm a b TrueF = TrueF"|
  "swap_fm a b FalseF = FalseF"|
  "swap_fm a b (Atom At) = Atom(swap_atom a b At)"|
  "swap_fm a b (And A B) = And(swap_fm a b A)(swap_fm a b B)"|
  "swap_fm a b (Or A B) = Or(swap_fm a b A)(swap_fm a b B)"|
  "swap_fm a b (Neg A) = Neg(swap_fm a b A)"|
  "swap_fm a b (ExQ A) = ExQ(swap_fm (a+1) (b+1) A)"|
  "swap_fm a b (AllQ A) = AllQ(swap_fm (a+1) (b+1) A)"|
  "swap_fm a b (ExN i A) = ExN i (swap_fm (a+i) (b+i) A)"|
  "swap_fm a b (AllN i A) = AllN i (swap_fm (a+i) (b+i) A)"

fun swap_list :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"where
  "swap_list i j l = l[j := nth l i, i := nth l j]"

lemma swap_list_cons: "swap_list (Suc a) (Suc b) (x # L) = x # swap_list a b L"
  by auto

lemma inj_on : "inj_on (swap0 a b) (monomials p)"
  unfolding inj_on_def
  by (metis swap0_swap0)

lemma inj_on' : "inj_on (swap a b) (keys m)"
  unfolding inj_on_def
  by (meson Reindex.inj_swap injD)

lemma swap_list :
  assumes  "a < length L"
  assumes "b < length L"
  shows "nth_default 0 (L[b := L ! a, a := L ! b]) (swap a b xa) = nth_default 0 L xa"
  using assms unfolding swap_def apply auto
  apply (simp_all add: nth_default_nth)
  by (simp add: nth_default_def)

lemma swap_poly :
  assumes "length L > a"
  assumes "length L > b"
  shows "insertion (nth_default 0 L) p = insertion (nth_default 0 (swap_list a b L)) (swap_poly a b p)"
  unfolding insertion_code apply auto
  unfolding monomials.abs_eq
  unfolding coeff_swap_poly monomials_swap_poly apply auto
  unfolding Groups_Big.comm_monoid_add_class.sum.reindex[OF inj_on] apply simp
  unfolding swap0_swap0
  unfolding keys_swap
  unfolding Groups_Big.comm_monoid_mult_class.prod.reindex[OF inj_on']
  apply simp
  unfolding swap0_eq swap_swap swap_list[OF assms] by auto

lemma swap_fm :
  assumes "length L > a"
  assumes "length L > b"
  shows "eval F L = eval (swap_fm a b F) (swap_list a b L)"
  using assms proof(induction F arbitrary: a b L)
  case TrueF
  then show ?case by auto
next
  case FalseF
  then show ?case by auto
next
  case (Atom At)
  then show ?case apply(cases At) using swap_poly[OF Atom(1) Atom(2)] by auto
next
  case (And F1 F2)
  show ?case using And(1)[OF And(3-4)] And(2)[OF And(3-4)] by auto
next
  case (Or F1 F2)
  then show ?case using Or(1)[OF Or(3-4)] Or(2)[OF Or(3-4)] by auto
next
  case (Neg F)
  then show ?case using Neg(1)[OF Neg(2-3)] by auto
next
  case (ExQ F)
  show ?case apply simp
    apply(rule ex_cong1)
    subgoal for x
      using ExQ(1)[of "Suc a" "x#L" "Suc b"] unfolding swap_list_cons using ExQ(2-3) by simp
    done
next
  case (AllQ F)
  then show ?case apply simp
    apply(rule all_cong1)
    subgoal for x
      using AllQ(1)[of "Suc a" "x#L" "Suc b"] unfolding swap_list_cons using AllQ(2-3) by simp
    done
next
  case (ExN i F)
  show ?case
    apply simp
    apply(rule ex_cong1)
    subgoal for l
      using ExN(1)[of "a+i" "l@L" "b+i"]
      by (smt (verit, del_insts) ExN.prems(1) ExN.prems(2) add.commute add_diff_cancel_right' add_less_cancel_left length_append list_update_append not_add_less2 nth_append swap_list.elims)
    done
next
  case (AllN i F)
  then show ?case
    apply simp apply(rule all_cong1)
    by (smt (z3) add.commute add_diff_cancel_right' le_add2 length_append less_diff_conv2 list_update_append not_add_less2 nth_append)
qed

lemma "eval (ExQ (ExQ F)) L = eval (ExQ (ExQ (swap_fm 0 1 F))) L"
  apply simp
  apply safe
  subgoal for i j
    apply(rule exI[where x=j])
    apply(rule exI[where x=i])
    using swap_fm[of 0 "j # i # L" "Suc 0" F]
    by simp
  subgoal for i j
    apply(rule exI[where x=j])
    apply(rule exI[where x=i])
    using swap_fm[of 0 "i # j # L" "Suc 0" F]
    by simp
  done

lemma swap_atom:
  assumes "length L > a"
  assumes "length L > b"
  shows "aEval F L = aEval (swap_atom a b F) (swap_list a b L)"
  using swap_fm[OF assms, of "Atom F"] by auto
end


(*  Title:      HOL/Fun_Def.thy
    Author:     Alexander Krauss, TU Muenchen
*)

section {* Function Definitions and Termination Proofs *}

theory Fun_Def
imports Basic_BNF_LFPs Partial_Function SAT
keywords "function" "termination" :: thy_goal and "fun" "fun_cases" :: thy_decl
begin

subsection {* Definitions with default value *}

definition
  THE_default :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "THE_default d P = (if (\<exists>!x. P x) then (THE x. P x) else d)"

lemma THE_defaultI': "\<exists>!x. P x \<Longrightarrow> P (THE_default d P)"
  by (simp add: theI' THE_default_def)

lemma THE_default1_equality:
    "\<lbrakk>\<exists>!x. P x; P a\<rbrakk> \<Longrightarrow> THE_default d P = a"
  by (simp add: the1_equality THE_default_def)

lemma THE_default_none:
    "\<not>(\<exists>!x. P x) \<Longrightarrow> THE_default d P = d"
  by (simp add:THE_default_def)

lemma fundef_ex1_existence:
  assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "G x (f x)"
  apply (simp only: f_def)
  apply (rule THE_defaultI')
  apply (rule ex1)
  done

lemma fundef_ex1_uniqueness:
  assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  assumes elm: "G x (h x)"
  shows "h x = f x"
  apply (simp only: f_def)
  apply (rule THE_default1_equality [symmetric])
   apply (rule ex1)
  apply (rule elm)
  done

lemma fundef_ex1_iff:
  assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "(G x y) = (f x = y)"
  apply (auto simp:ex1 f_def THE_default1_equality)
  apply (rule THE_defaultI')
  apply (rule ex1)
  done

lemma fundef_default_value:
  assumes f_def: "f == (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes graph: "\<And>x y. G x y \<Longrightarrow> D x"
  assumes "\<not> D x"
  shows "f x = d x"
proof -
  have "\<not>(\<exists>y. G x y)"
  proof
    assume "\<exists>y. G x y"
    hence "D x" using graph ..
    with `\<not> D x` show False ..
  qed
  hence "\<not>(\<exists>!y. G x y)" by blast

  thus ?thesis
    unfolding f_def
    by (rule THE_default_none)
qed

definition in_rel_def[simp]:
  "in_rel R x y == (x, y) \<in> R"

lemma wf_in_rel:
  "wf R \<Longrightarrow> wfP (in_rel R)"
  by (simp add: wfP_def)

ML_file "Tools/Function/function_core.ML"
ML_file "Tools/Function/mutual.ML"
ML_file "Tools/Function/pattern_split.ML"
ML_file "Tools/Function/relation.ML"
ML_file "Tools/Function/function_elims.ML"

method_setup relation = {*
  Args.term >> (fn t => fn ctxt => SIMPLE_METHOD' (Function_Relation.relation_infer_tac ctxt t))
*} "prove termination using a user-specified wellfounded relation"

ML_file "Tools/Function/function.ML"
ML_file "Tools/Function/pat_completeness.ML"

method_setup pat_completeness = {*
  Scan.succeed (SIMPLE_METHOD' o Pat_Completeness.pat_completeness_tac)
*} "prove completeness of (co)datatype patterns"

ML_file "Tools/Function/fun.ML"
ML_file "Tools/Function/induction_schema.ML"

method_setup induction_schema = {*
  Scan.succeed (NO_CASES oo Induction_Schema.induction_schema_tac)
*} "prove an induction principle"

subsection {* Measure functions *}

inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
where is_measure_trivial: "is_measure f"

named_theorems measure_function "rules that guide the heuristic generation of measure functions"
ML_file "Tools/Function/measure_functions.ML"

lemma measure_size[measure_function]: "is_measure size"
by (rule is_measure_trivial)

lemma measure_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
by (rule is_measure_trivial)
lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
by (rule is_measure_trivial)

ML_file "Tools/Function/lexicographic_order.ML"

method_setup lexicographic_order = {*
  Method.sections clasimp_modifiers >>
  (K (SIMPLE_METHOD o Lexicographic_Order.lexicographic_order_tac false))
*} "termination prover for lexicographic orderings"

subsection {* Congruence rules *}

lemma let_cong [fundef_cong]:
  "M = N \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x = g x) \<Longrightarrow> Let M f = Let N g"
  unfolding Let_def by blast

lemmas [fundef_cong] =
  if_cong image_cong INF_cong SUP_cong
  bex_cong ball_cong imp_cong map_option_cong Option.bind_cong

lemma split_cong [fundef_cong]:
  "(\<And>x y. (x, y) = q \<Longrightarrow> f x y = g x y) \<Longrightarrow> p = q
    \<Longrightarrow> split f p = split g q"
  by (auto simp: split_def)

lemma comp_cong [fundef_cong]:
  "f (g x) = f' (g' x') \<Longrightarrow> (f o g) x = (f' o g') x'"
  unfolding o_apply .

subsection {* Simp rules for termination proofs *}

declare
  trans_less_add1[termination_simp]
  trans_less_add2[termination_simp]
  trans_le_add1[termination_simp]
  trans_le_add2[termination_simp]
  less_imp_le_nat[termination_simp]
  le_imp_less_Suc[termination_simp]

lemma size_prod_simp[termination_simp]:
  "size_prod f g p = f (fst p) + g (snd p) + Suc 0"
by (induct p) auto

subsection {* Decomposition *}

lemma less_by_empty:
  "A = {} \<Longrightarrow> A \<subseteq> B"
and  union_comp_emptyL:
  "\<lbrakk> A O C = {}; B O C = {} \<rbrakk> \<Longrightarrow> (A \<union> B) O C = {}"
and union_comp_emptyR:
  "\<lbrakk> A O B = {}; A O C = {} \<rbrakk> \<Longrightarrow> A O (B \<union> C) = {}"
and wf_no_loop:
  "R O R = {} \<Longrightarrow> wf R"
by (auto simp add: wf_comp_self[of R])

subsection {* Reduction pairs *}

definition
  "reduction_pair P = (wf (fst P) \<and> fst P O snd P \<subseteq> fst P)"

lemma reduction_pairI[intro]: "wf R \<Longrightarrow> R O S \<subseteq> R \<Longrightarrow> reduction_pair (R, S)"
unfolding reduction_pair_def by auto

lemma reduction_pair_lemma:
  assumes rp: "reduction_pair P"
  assumes "R \<subseteq> fst P"
  assumes "S \<subseteq> snd P"
  assumes "wf S"
  shows "wf (R \<union> S)"
proof -
  from rp `S \<subseteq> snd P` have "wf (fst P)" "fst P O S \<subseteq> fst P"
    unfolding reduction_pair_def by auto
  with `wf S` have "wf (fst P \<union> S)"
    by (auto intro: wf_union_compatible)
  moreover from `R \<subseteq> fst P` have "R \<union> S \<subseteq> fst P \<union> S" by auto
  ultimately show ?thesis by (rule wf_subset)
qed

definition
  "rp_inv_image = (\<lambda>(R,S) f. (inv_image R f, inv_image S f))"

lemma rp_inv_image_rp:
  "reduction_pair P \<Longrightarrow> reduction_pair (rp_inv_image P f)"
  unfolding reduction_pair_def rp_inv_image_def split_def
  by force

subsection {* Concrete orders for SCNP termination proofs *}

definition "pair_less = less_than <*lex*> less_than"
definition "pair_leq = pair_less^="
definition "max_strict = max_ext pair_less"
definition "max_weak = max_ext pair_leq \<union> {({}, {})}"
definition "min_strict = min_ext pair_less"
definition "min_weak = min_ext pair_leq \<union> {({}, {})}"

lemma wf_pair_less[simp]: "wf pair_less"
  by (auto simp: pair_less_def)

text {* Introduction rules for @{text pair_less}/@{text pair_leq} *}
lemma pair_leqI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_leqI2: "a \<le> b \<Longrightarrow> s \<le> t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_lessI1: "a < b  \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  and pair_lessI2: "a \<le> b \<Longrightarrow> s < t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  unfolding pair_leq_def pair_less_def by auto

text {* Introduction rules for max *}
lemma smax_emptyI:
  "finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> ({}, Y) \<in> max_strict"
  and smax_insertI:
  "\<lbrakk>y \<in> Y; (x, y) \<in> pair_less; (X, Y) \<in> max_strict\<rbrakk> \<Longrightarrow> (insert x X, Y) \<in> max_strict"
  and wmax_emptyI:
  "finite X \<Longrightarrow> ({}, X) \<in> max_weak"
  and wmax_insertI:
  "\<lbrakk>y \<in> YS; (x, y) \<in> pair_leq; (XS, YS) \<in> max_weak\<rbrakk> \<Longrightarrow> (insert x XS, YS) \<in> max_weak"
unfolding max_strict_def max_weak_def by (auto elim!: max_ext.cases)

text {* Introduction rules for min *}
lemma smin_emptyI:
  "X \<noteq> {} \<Longrightarrow> (X, {}) \<in> min_strict"
  and smin_insertI:
  "\<lbrakk>x \<in> XS; (x, y) \<in> pair_less; (XS, YS) \<in> min_strict\<rbrakk> \<Longrightarrow> (XS, insert y YS) \<in> min_strict"
  and wmin_emptyI:
  "(X, {}) \<in> min_weak"
  and wmin_insertI:
  "\<lbrakk>x \<in> XS; (x, y) \<in> pair_leq; (XS, YS) \<in> min_weak\<rbrakk> \<Longrightarrow> (XS, insert y YS) \<in> min_weak"
by (auto simp: min_strict_def min_weak_def min_ext_def)

text {* Reduction Pairs *}

lemma max_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "max_ext R O (max_ext S \<union> {({},{})}) \<subseteq> max_ext R"
using assms
apply auto
apply (elim max_ext.cases)
apply rule
apply auto[3]
apply (drule_tac x=xa in meta_spec)
apply simp
apply (erule bexE)
apply (drule_tac x=xb in meta_spec)
by auto

lemma max_rpair_set: "reduction_pair (max_strict, max_weak)"
  unfolding max_strict_def max_weak_def
apply (intro reduction_pairI max_ext_wf)
apply simp
apply (rule max_ext_compat)
by (auto simp: pair_less_def pair_leq_def)

lemma min_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "min_ext R O  (min_ext S \<union> {({},{})}) \<subseteq> min_ext R"
using assms
apply (auto simp: min_ext_def)
apply (drule_tac x=ya in bspec, assumption)
apply (erule bexE)
apply (drule_tac x=xc in bspec)
apply assumption
by auto

lemma min_rpair_set: "reduction_pair (min_strict, min_weak)"
  unfolding min_strict_def min_weak_def
apply (intro reduction_pairI min_ext_wf)
apply simp
apply (rule min_ext_compat)
by (auto simp: pair_less_def pair_leq_def)

subsection {* Tool setup *}

ML_file "Tools/Function/termination.ML"
ML_file "Tools/Function/scnp_solve.ML"
ML_file "Tools/Function/scnp_reconstruct.ML"
ML_file "Tools/Function/fun_cases.ML"

ML_val -- "setup inactive"
{*
  Context.theory_map (Function_Common.set_termination_prover
    (ScnpReconstruct.decomp_scnp_tac [ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS]))
*}

end