header {* HOLCF Utility lemmas *}
theory HOLCFUtils
imports HOLCF
begin

text {*
We use @{theory HOLCF} to define the denotational semantics. By default, HOLCF does not turn the regular @{text set} type into a partial order, so this is done here. Some of the lemmas here are contributed by Brian Huffman.

We start by making the type @{text bool} a pointed chain-complete partial order.
*}

instantiation bool :: po
begin
definition
  "x \<sqsubseteq> y \<longleftrightarrow> (x \<longrightarrow> y)"
instance by (default, unfold below_bool_def, fast+)
end

instance bool :: chfin
apply default
apply (drule finite_range_imp_finch)
apply (rule finite)
apply (simp add: finite_chain_def)
done

instance bool :: pcpo
proof
  have "\<forall>y. False \<sqsubseteq> y" by (simp add: below_bool_def)
  thus "\<exists>x::bool. \<forall>y. x \<sqsubseteq> y" ..
qed

lemma is_lub_bool: "S <<| (True \<in> S)"
  unfolding is_lub_def is_ub_def below_bool_def by auto

lemma lub_bool: "lub S = (True \<in> S)"
  using is_lub_bool by (rule lub_eqI)

lemma bottom_eq_False[simp]: "\<bottom> = False"
by (rule below_antisym [OF minimal], simp add: below_bool_def)

text {*
To convert between the squared syntax used by @{theory HOLCF} and the regular, round syntax for sets, we state some of the equivalencies.
*}

instantiation set :: (type) po
begin
definition
  "A \<sqsubseteq> B \<longleftrightarrow> A \<subseteq> B"
instance by (default, unfold below_set_def, fast+)
end

lemma sqsubset_is_subset: "A \<sqsubseteq> B \<longleftrightarrow> A \<subseteq> B"
  by (fact below_set_def)

lemma is_lub_set: "S <<| \<Union>S"
  unfolding is_lub_def is_ub_def below_set_def by fast

lemma lub_is_union: "lub S = \<Union>S"
  using is_lub_set by (rule lub_eqI)

instance set :: (type) cpo
  by (default, fast intro: is_lub_set)

lemma emptyset_is_bot[simp]: "{} \<sqsubseteq> S"
  by (simp add:sqsubset_is_subset)

instance set :: (type) pcpo
  by (default, fast intro: emptyset_is_bot)

lemma bot_bool_is_emptyset[simp]: "\<bottom> = {}"
  using emptyset_is_bot by (rule bottomI [symmetric])

text {*
To actually use these instance in @{text fixrec} definitions or fixed-point inductions, we need continuity requrements for various boolean and set operations.
*}

lemma cont2cont_disj [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x \<or> g x)"
apply (rule cont_apply [OF f])
apply (rule chfindom_monofun2cont)
apply (rule monofunI, simp add: below_bool_def)
apply (rule cont_compose [OF _ g])
apply (rule chfindom_monofun2cont)
apply (rule monofunI, simp add: below_bool_def)
done

lemma cont2cont_imp[simp, cont2cont]:
  assumes f: "cont (\<lambda>x. \<not> f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x \<longrightarrow> g x)"
unfolding imp_conv_disj by (rule cont2cont_disj[OF f g])

lemma cont2cont_Collect [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f x y)"
  shows "cont (\<lambda>x. {y. f x y})"
apply (rule contI)
apply (subst cont2contlubE [OF assms], assumption)
apply (auto simp add: is_lub_def is_ub_def below_set_def lub_bool)
done

lemma cont2cont_mem [simp, cont2cont]:
  assumes "cont (\<lambda>x. f x)"
  shows "cont (\<lambda>x. y \<in> f x)"
apply (rule cont_compose [OF _ assms])
apply (rule contI)
apply (auto simp add: is_lub_def is_ub_def below_bool_def lub_is_union)
done

lemma cont2cont_union [simp, cont2cont]:
  "cont (\<lambda>x. f x) \<Longrightarrow> cont (\<lambda>x. g x)
\<Longrightarrow> cont (\<lambda>x. f x \<union> g x)"
unfolding Un_def by simp

lemma cont2cont_insert [simp, cont2cont]:
  assumes "cont (\<lambda>x. f x)"
  shows "cont (\<lambda>x. insert y (f x))"
unfolding insert_def using assms
by (intro cont2cont)

lemmas adm_subset = adm_below[where ?'b = "'a::type set", unfolded sqsubset_is_subset]

lemma cont2cont_UNION[cont2cont,simp]:
  assumes "cont f"
      and "\<And> y. cont (\<lambda>x. g x y)"
  shows "cont (\<lambda>x. \<Union>y\<in> f x. g x y)"
proof(induct rule: contI2[case_names Mono Limit])
case Mono
  show "monofun (\<lambda>x. \<Union>y\<in>f x. g x y)"
    by (rule monofunI)(auto iff:sqsubset_is_subset dest: monofunE[OF assms(1)[THEN cont2mono]] monofunE[OF assms(2)[THEN cont2mono]])
next
case (Limit Y)
  have "(\<Union>y\<in>f (\<Squnion> i. Y i). g (\<Squnion> j. Y j) y) \<subseteq> (\<Squnion> k. \<Union>y\<in>f (Y k). g (Y k) y)"
  proof
    fix x assume "x \<in> (\<Union>y\<in>f (\<Squnion> i. Y i). g (\<Squnion> j. Y j) y)"
    then obtain y where "y\<in>f (\<Squnion> i. Y i)" and "x\<in> g (\<Squnion> j. Y j) y" by auto
    hence "y \<in> (\<Squnion> i. f (Y i))" and "x\<in> (\<Squnion> j. g (Y j) y)" by (auto simp add: cont2contlubE[OF assms(1) Limit(1)] cont2contlubE[OF assms(2) Limit(1)])
    then obtain i and j where yi: "y\<in> f (Y i)" and xj: "x\<in> g (Y j) y" by (auto simp add:lub_is_union)
    obtain k where "i\<le>k" and "j\<le>k" by (erule_tac x = "max i j" in meta_allE)auto
    from yi and xj have "y \<in> f (Y k)" and "x\<in> g (Y k) y"
      using monofunE[OF assms(1)[THEN cont2mono], OF chain_mono[OF Limit(1) `i\<le>k`]]
        and monofunE[OF assms(2)[THEN cont2mono], OF chain_mono[OF Limit(1) `j\<le>k`]]
      by (auto simp add:sqsubset_is_subset)
    hence "x\<in> (\<Union>y\<in> f (Y k). g (Y k) y)" by auto
    thus "x\<in> (\<Squnion> k. \<Union>y\<in>f (Y k). g (Y k) y)" by (auto simp add:lub_is_union)
  qed
  thus ?case by (simp add:sqsubset_is_subset)
qed

lemma cont2cont_Let_simple[simp,cont2cont]:
  assumes "cont (\<lambda>x. g x t)"
  shows "cont (\<lambda>x. let y = t in g x y)"
unfolding Let_def using assms .

lemma cont2cont_case_list [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_list (f1 x) (f2 x) l)"
using assms
by (cases l) auto

text {* As with the continuity lemmas, we need admissibility lemmas. *}

lemma adm_not_mem:
  assumes "cont (\<lambda>x. f x)"
  shows "adm (\<lambda>x. y \<notin> f x)"
using assms
apply (erule_tac t = f in adm_subst)
proof (rule admI)
fix Y :: "nat \<Rightarrow> 'b set"
assume chain: "chain Y"
assume "\<forall>i. y \<notin> Y i" hence  "(\<Squnion> i. y \<in> Y i) = False"
  by auto
thus "y \<notin> (\<Squnion> i. Y i)"
  using chain unfolding lub_bool lub_is_union by auto
qed

lemma adm_id[simp]: "adm (\<lambda>x . x)"
by (rule adm_chfin)

lemma adm_Not[simp]: "adm Not"
by (rule adm_chfin)

lemma adm_prod_split:
  assumes "adm (\<lambda>p. f (fst p) (snd p))"
  shows "adm (\<lambda>(x,y). f x y)"
using assms unfolding split_def .

lemma adm_ball':
  assumes "\<And> y. adm (\<lambda>x. y \<in> A x \<longrightarrow> P x y)"
  shows "adm (\<lambda>x. \<forall>y \<in> A x . P x y)"
by (subst Ball_def, rule adm_all[OF assms])

lemma adm_not_conj:
  "\<lbrakk>adm (\<lambda>x. \<not> P x); adm (\<lambda>x. \<not> Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> (P x \<and> Q x))"
by simp

lemma adm_single_valued:
 assumes "cont (\<lambda>x. f x)"
 shows "adm (\<lambda>x. single_valued (f x))"
using assms
unfolding single_valued_def
by (intro adm_lemmas adm_not_mem cont2cont adm_subst[of f])

text {*
To match Shivers' syntax we introduce the power-syntax for iterated function application.
*}

abbreviation niceiterate ("(_\<^bsup>_\<^esup>)" [1000] 1000)
  where "niceiterate f i \<equiv> iterate i\<cdot>f"

end


(* Author: Bohua Zhan, with modifications by Tobias Nipkow *)

section \<open>Interval Trees\<close>

theory Interval_Tree
imports
  "HOL-Data_Structures.Cmp"
  "HOL-Data_Structures.List_Ins_Del"
  "HOL-Data_Structures.Isin2"
  "HOL-Data_Structures.Set_Specs"
begin

subsection \<open>Intervals\<close>

text \<open>The following definition of intervals uses the \<^bold>\<open>typedef\<close> command
to define the type of non-empty intervals as a subset of the type of pairs \<open>p\<close>
where @{prop "fst p \<le> snd p"}:\<close>

typedef (overloaded) 'a::linorder ivl =
  "{p :: 'a \<times> 'a. fst p \<le> snd p}" by auto

text \<open>More precisely, @{typ "'a ivl"} is isomorphic with that subset via the function
@{const Rep_ivl}. Hence the basic interval properties are not immediate but
need simple proofs:\<close>

definition low :: "'a::linorder ivl \<Rightarrow> 'a" where
"low p = fst (Rep_ivl p)"

definition high :: "'a::linorder ivl \<Rightarrow> 'a" where
"high p = snd (Rep_ivl p)"

lemma ivl_is_interval: "low p \<le> high p"
by (metis Rep_ivl high_def low_def mem_Collect_eq)

lemma ivl_inj: "low p = low q \<Longrightarrow> high p = high q \<Longrightarrow> p = q"
by (metis Rep_ivl_inverse high_def low_def prod_eqI)

text \<open>Now we can forget how exactly intervals were defined.\<close>

instantiation ivl :: (linorder) linorder begin

definition ivl_less: "(x < y) = (low x < low y | (low x = low y \<and> high x < high y))"
definition ivl_less_eq: "(x \<le> y) = (low x < low y | (low x = low y \<and> high x \<le> high y))"

instance proof
  fix x y z :: "'a ivl"
  show a: "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    using ivl_less ivl_less_eq by force
  show b: "x \<le> x"
    by (simp add: ivl_less_eq)
  show c: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (smt ivl_less_eq dual_order.trans less_trans)
  show d: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    using ivl_less_eq a ivl_inj ivl_less by fastforce
  show e: "x \<le> y \<or> y \<le> x"
    by (meson ivl_less_eq leI not_less_iff_gr_or_eq)
qed end

definition overlap :: "('a::linorder) ivl \<Rightarrow> 'a ivl \<Rightarrow> bool" where
"overlap x y \<longleftrightarrow> (high x \<ge> low y \<and> high y \<ge> low x)"

definition has_overlap :: "('a::linorder) ivl set \<Rightarrow> 'a ivl \<Rightarrow> bool" where
"has_overlap S y \<longleftrightarrow> (\<exists>x\<in>S. overlap x y)"

subsection \<open>Interval Trees\<close>

type_synonym 'a ivl_tree = "('a ivl * 'a) tree"

fun max_hi :: "('a::order_bot) ivl_tree \<Rightarrow> 'a" where
"max_hi Leaf = bot" |
"max_hi (Node _ (_,m) _) = m"

definition max3 :: "('a::linorder) ivl \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"max3 a m n = max (high a) (max m n)"

fun inv_max_hi :: "('a::{linorder,order_bot}) ivl_tree \<Rightarrow> bool" where
"inv_max_hi Leaf \<longleftrightarrow> True" |
"inv_max_hi (Node l (a, m) r) \<longleftrightarrow> (inv_max_hi l \<and> inv_max_hi r \<and> m = max3 a (max_hi l) (max_hi r))"

lemma max_hi_is_max:
  "inv_max_hi t \<Longrightarrow> a \<in> set_tree t \<Longrightarrow> high a \<le> max_hi t"
by (induct t, auto simp add: max3_def max_def)

lemma max_hi_exists:
  "inv_max_hi t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> \<exists>a\<in>set_tree t. high a = max_hi t"
proof (induction t rule: tree2_induct)
  case Leaf
  then show ?case by auto
next
  case N: (Node l v m r)
  then show ?case
  proof (cases l rule: tree2_cases)
    case Leaf
    then show ?thesis
      using N.prems(1) N.IH(2) by (cases r, auto simp add: max3_def max_def le_bot)
  next
    case Nl: Node
    then show ?thesis
    proof (cases r rule: tree2_cases)
      case Leaf
      then show ?thesis
        using N.prems(1) N.IH(1) Nl by (auto simp add: max3_def max_def le_bot)
    next
      case Nr: Node
      obtain p1 where p1: "p1 \<in> set_tree l" "high p1 = max_hi l"
        using N.IH(1) N.prems(1) Nl by auto
      obtain p2 where p2: "p2 \<in> set_tree r" "high p2 = max_hi r"
        using N.IH(2) N.prems(1) Nr by auto
      then show ?thesis
        using p1 p2 N.prems(1) by (auto simp add: max3_def max_def)
    qed
  qed
qed

subsection \<open>Insertion and Deletion\<close>

definition node where
[simp]: "node l a r = Node l (a, max3 a (max_hi l) (max_hi r)) r"

fun insert :: "'a::{linorder,order_bot} ivl \<Rightarrow> 'a ivl_tree \<Rightarrow> 'a ivl_tree" where
"insert x Leaf = Node Leaf (x, high x) Leaf" |
"insert x (Node l (a, m) r) =
  (case cmp x a of
     EQ \<Rightarrow> Node l (a, m) r |
     LT \<Rightarrow> node (insert x l) a r |
     GT \<Rightarrow> node l a (insert x r))"

lemma inorder_insert:
  "sorted (inorder t) \<Longrightarrow> inorder (insert x t) = ins_list x (inorder t)"
by (induct t rule: tree2_induct) (auto simp: ins_list_simps)

lemma inv_max_hi_insert:
  "inv_max_hi t \<Longrightarrow> inv_max_hi (insert x t)"
by (induct t rule: tree2_induct) (auto simp add: max3_def)

fun split_min :: "'a::{linorder,order_bot} ivl_tree \<Rightarrow> 'a ivl \<times> 'a ivl_tree" where
"split_min (Node l (a, m) r) =
  (if l = Leaf then (a, r)
   else let (x,l') = split_min l in (x, node l' a r))"

fun delete :: "'a::{linorder,order_bot} ivl \<Rightarrow> 'a ivl_tree \<Rightarrow> 'a ivl_tree" where
"delete x Leaf = Leaf" |
"delete x (Node l (a, m) r) =
  (case cmp x a of
     LT \<Rightarrow> node (delete x l) a r |
     GT \<Rightarrow> node l a (delete x r) |
     EQ \<Rightarrow> if r = Leaf then l else
           let (a', r') = split_min r in node l a' r')"

lemma split_minD:
  "split_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
by (induct t arbitrary: t' rule: split_min.induct)
   (auto simp: sorted_lems split: prod.splits if_splits)

lemma inorder_delete:
  "sorted (inorder t) \<Longrightarrow> inorder (delete x t) = del_list x (inorder t)"
by (induct t)
   (auto simp: del_list_simps split_minD Let_def split: prod.splits)

lemma inv_max_hi_split_min:
  "\<lbrakk> t \<noteq> Leaf;  inv_max_hi t \<rbrakk> \<Longrightarrow> inv_max_hi (snd (split_min t))"
by (induct t) (auto split: prod.splits)

lemma inv_max_hi_delete:
  "inv_max_hi t \<Longrightarrow> inv_max_hi (delete x t)"
apply (induct t)
 apply simp
using inv_max_hi_split_min by (fastforce simp add: Let_def split: prod.splits)

subsection \<open>Search\<close>

text \<open>Does interval \<open>x\<close> overlap with any interval in the tree?\<close>

fun search :: "'a::{linorder,order_bot} ivl_tree \<Rightarrow> 'a ivl \<Rightarrow> bool" where
"search Leaf x = False" |
"search (Node l (a, m) r) x =
  (if overlap x a then True
   else if l \<noteq> Leaf \<and> max_hi l \<ge> low x then search l x
   else search r x)"

lemma search_correct:
  "inv_max_hi t \<Longrightarrow> sorted (inorder t) \<Longrightarrow> search t x = has_overlap (set_tree t) x"
proof (induction t rule: tree2_induct)
  case Leaf
  then show ?case by (auto simp add: has_overlap_def)
next
  case (Node l a m r)
  have search_l: "search l x = has_overlap (set_tree l) x"
    using Node.IH(1) Node.prems by (auto simp: sorted_wrt_append)
  have search_r: "search r x = has_overlap (set_tree r) x"
    using Node.IH(2) Node.prems by (auto simp: sorted_wrt_append)
  show ?case
  proof (cases "overlap a x")
    case True
    thus ?thesis by (auto simp: overlap_def has_overlap_def)
  next
    case a_disjoint: False
    then show ?thesis
    proof cases
      assume [simp]: "l = Leaf"
      have search_eval: "search (Node l (a, m) r) x = search r x"
        using a_disjoint overlap_def by auto
      show ?thesis
        unfolding search_eval search_r
        by (auto simp add: has_overlap_def a_disjoint)
    next
      assume "l \<noteq> Leaf"
      then show ?thesis
      proof (cases "max_hi l \<ge> low x")
        case max_hi_l_ge: True
        have "inv_max_hi l"
          using Node.prems(1) by auto
        then obtain p where p: "p \<in> set_tree l" "high p = max_hi l"
          using \<open>l \<noteq> Leaf\<close> max_hi_exists by auto
        have search_eval: "search (Node l (a, m) r) x = search l x"
          using a_disjoint \<open>l \<noteq> Leaf\<close> max_hi_l_ge by (auto simp: overlap_def)
        show ?thesis
        proof (cases "low p \<le> high x")
          case True
          have "overlap p x"
            unfolding overlap_def using True p(2) max_hi_l_ge by auto
          then show ?thesis
            unfolding search_eval search_l
            using p(1) by(auto simp: has_overlap_def overlap_def)
        next
          case False
          have "\<not>overlap x rp" if asm: "rp \<in> set_tree r" for rp
          proof -
            have "low p \<le> low rp"
              using asm p(1) Node(4) by(fastforce simp: sorted_wrt_append ivl_less)
            then show ?thesis
              using False by (auto simp: overlap_def)
          qed
          then show ?thesis
            unfolding search_eval search_l
            using a_disjoint by (auto simp: has_overlap_def overlap_def)
        qed
      next
        case False
        have search_eval: "search (Node l (a, m) r) x = search r x"
          using a_disjoint False by (auto simp: overlap_def)
        have "\<not>overlap x lp" if asm: "lp \<in> set_tree l" for lp
          using asm False Node.prems(1) max_hi_is_max
          by (fastforce simp: overlap_def)
        then show ?thesis
          unfolding search_eval search_r
          using a_disjoint by (auto simp: has_overlap_def overlap_def)
      qed
    qed
  qed
qed

definition empty :: "'a ivl_tree" where
"empty = Leaf"

subsection \<open>Specification\<close>

locale Interval_Set = Set +
  fixes has_overlap :: "'t \<Rightarrow> 'a::linorder ivl \<Rightarrow> bool"
  assumes set_overlap: "invar s \<Longrightarrow> has_overlap s x = Interval_Tree.has_overlap (set s) x"

interpretation S: Interval_Set
  where empty = Leaf and insert = insert and delete = delete
  and has_overlap = search and isin = isin and set = set_tree
  and invar = "\<lambda>t. inv_max_hi t \<and> sorted (inorder t)"
proof (standard, goal_cases)
  case 1
  then show ?case by auto
next
  case 2
  then show ?case by (simp add: isin_set_inorder)
next
  case 3
  then show ?case by(simp add: inorder_insert set_ins_list flip: set_inorder)
next
  case 4
  then show ?case by(simp add: inorder_delete set_del_list flip: set_inorder)
next
  case 5
  then show ?case by auto
next
  case 6
  then show ?case by (simp add: inorder_insert inv_max_hi_insert sorted_ins_list)
next
  case 7
  then show ?case by (simp add: inorder_delete inv_max_hi_delete sorted_del_list)
next
  case 8
  then show ?case by (simp add: search_correct)
qed

end


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

theory AbelCoset
imports Coset Ring
begin

subsection \<open>More Lifting from Groups to Abelian Groups\<close>

subsubsection \<open>Definitions\<close>

text \<open>Hiding \<open><+>\<close> from @{theory Sum_Type} until I come
  up with better syntax here\<close>

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)
    \<comment>\<open>Actually defined for groups rather than monoids\<close>
  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"
    \<comment>\<open>the kernel of a homomorphism (additive)\<close>
  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 \<open>Cosets\<close>

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\<open>Really needed?\<close>
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 \<open>Subgroups\<close>

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 \<open>Additive subgroups are normal\<close>

text \<open>Every subgroup of an \<open>abelian_group\<close> is normal\<close>

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 standard (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 fastforce
  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\<open>Alternative characterization of normal subgroups\<close>
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"
  \<comment> \<open>generalizes \<open>subgroup_mult_id\<close>\<close>
by (rule normal.rcosets_mult_eq [OF a_normal,
    folded set_add_def A_RCOSETS_def, simplified monoid_record_simps])

subsubsection \<open>Congruence Relation\<close>

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 \<open>Factorization\<close>

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 \<open>Since the Factorization is based on an \emph{abelian} subgroup, is results in
        a commutative group\<close>
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\<open>The coset map is a homomorphism from @{term G} to the quotient group
  @{term "G Mod H"}\<close>
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 \<open>The isomorphism theorems have been omitted from lifting, at
  least for now\<close>

subsubsection\<open>The First Isomorphism Theorem\<close>

text\<open>The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.\<close>

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 \<open>Homomorphisms\<close>

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\<open>The kernel of a homomorphism is an abelian subgroup\<close>
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\<open>If the homomorphism @{term h} is onto @{term H}, then so is the
homomorphism from the quotient group\<close>
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\<open>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}.\<close>
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 \<open>Cosets\<close>

text \<open>Not eveything from \texttt{CosetExt.thy} is lifted here.\<close>

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])

\<comment>"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 \<open>Addition of Subgroups\<close>

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 ThEdu imports Complex_Main
begin

theorem \<open>\<nexists>f :: nat \<Rightarrow> real. surj f\<close>
proof
  assume \<open>\<exists>f :: nat \<Rightarrow> real. surj f\<close>
  show False
  proof -
    from \<open>\<exists>f. surj f\<close> obtain f :: \<open>nat \<Rightarrow> real\<close> where \<open>surj f\<close> ..

    then have assumption: \<open>\<exists>n. f n = z\<close> for z
      unfolding surj_def by metis

    obtain D :: \<open>nat \<Rightarrow> real set\<close> where \<open>(\<Inter>n. D n) \<noteq> {}\<close> \<open>f n \<notin> D n\<close> for n
    proof -
      obtain L R :: \<open>real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real\<close>
        where
          *: \<open>L a b c < R a b c\<close> \<open>{L a b c .. R a b c} \<subseteq> {a .. b}\<close> \<open>c \<notin> {L a b c .. R a b c}\<close>
        if \<open>a < b\<close> for a b c
      proof -
        have \<open>\<exists>x y. a \<le> x \<and> x < y \<and> y \<le> b \<and> \<not> (x \<le> c \<and> c \<le> y)\<close> if \<open>a < b\<close> for a b c :: real
          using that dense less_le_trans not_le not_less_iff_gr_or_eq by (metis (full_types))

        then have \<open>\<exists>x y. x < y \<and> {x .. y} \<subseteq> {a .. b} \<and> c \<notin> {x .. y}\<close> if \<open>a < b\<close> for a b c :: real
          using that by fastforce

        then show ?thesis
          using that by metis
      qed

      define P :: \<open>nat \<Rightarrow> real \<times> real\<close>
        where
          \<open>P \<equiv> rec_nat
               (L 0 1 (f 0),
                R 0 1 (f 0))
               (\<lambda>n (x, y). (L x y (f (Suc n)),
                            R x y (f (Suc n))))\<close>

      with *(1) have 0: \<open>fst (P n) < snd (P n)\<close> for n
        unfolding split_def by (induct n) simp_all

      define I :: \<open>nat \<Rightarrow> real set\<close>
        where
          \<open>I \<equiv> \<lambda>n. {fst (P n) .. snd (P n)}\<close>

      with 0 have \<open>I n \<noteq> {}\<close> for n
        using less_imp_le by fastforce

      moreover from 0 *(2) have \<open>decseq I\<close>
        unfolding I_def P_def split_def decseq_Suc_iff by simp

      ultimately have \<open>finite S \<longrightarrow> (\<Inter>n\<in>S. I n) \<noteq> {}\<close> for S
        using decseqD subset_empty INF_greatest Max_ge by metis

      moreover have \<open>closed (I n)\<close> for n
        unfolding I_def by simp

      moreover have \<open>compact (I n)\<close> for n
        unfolding I_def using compact_Icc compact_Int_closed decseqD inf.absorb_iff2 le0 by simp

      ultimately have \<open>(\<Inter>n. I n) \<noteq> {}\<close>
        using INT_insert compact_imp_fip_image empty_subsetI finite_insert inf.absorb_iff2 by metis

      moreover from 0 *(3) have \<open>f n \<notin> I n\<close> for n
        unfolding I_def P_def split_def by (induct n) simp_all

      ultimately show ?thesis ..
    qed

    then obtain e where \<open>\<nexists>n. f n = e\<close>
      using INT_E UNIV_I ex_in_conv by metis

    moreover from assumption have \<open>\<exists>n. f n = e\<close> .

    ultimately show ?thesis ..
  qed
qed

end \<comment> \<open>Jørgen Villadsen, DTU Denmark - Based on work by Benjamin Porter, NICTA Australia\<close>


theory Basic imports Main begin

lemma conj_rule: "\<lbrakk> P; Q \<rbrakk> \<Longrightarrow> P \<and> (Q \<and> P)"
apply (rule conjI)
 apply assumption
apply (rule conjI)
 apply assumption
apply assumption
done

lemma disj_swap: "P | Q \<Longrightarrow> Q | P"
apply (erule disjE)
 apply (rule disjI2)
 apply assumption
apply (rule disjI1)
apply assumption
done

lemma conj_swap: "P \<and> Q \<Longrightarrow> Q \<and> P"
apply (rule conjI)
 apply (drule conjunct2)
 apply assumption
apply (drule conjunct1)
apply assumption
done

lemma imp_uncurry: "P \<longrightarrow> Q \<longrightarrow> R \<Longrightarrow> P \<and> Q \<longrightarrow> R"
apply (rule impI)
apply (erule conjE)
apply (drule mp)
 apply assumption
apply (drule mp)
  apply assumption
 apply assumption
done

text \<open>
by eliminates uses of assumption and done
\<close>

lemma imp_uncurry': "P \<longrightarrow> Q \<longrightarrow> R \<Longrightarrow> P \<and> Q \<longrightarrow> R"
apply (rule impI)
apply (erule conjE)
apply (drule mp)
 apply assumption
by (drule mp)

text \<open>
substitution

@{thm[display] ssubst}
\rulename{ssubst}
\<close>

lemma "\<lbrakk> x = f x; P(f x) \<rbrakk> \<Longrightarrow> P x"
by (erule ssubst)

text \<open>
also provable by simp (re-orients)
\<close>

text \<open>
the subst method

@{thm[display] mult.commute}
\rulename{mult.commute}

this would fail:
apply (simp add: mult.commute)
\<close>

lemma "\<lbrakk>P x y z; Suc x < y\<rbrakk> \<Longrightarrow> f z = x*y"
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (subst mult.commute)
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

(*exercise involving THEN*)
lemma "\<lbrakk>P x y z; Suc x < y\<rbrakk> \<Longrightarrow> f z = x*y"
apply (rule mult.commute [THEN ssubst])
oops

lemma "\<lbrakk>x = f x; triple (f x) (f x) x\<rbrakk> \<Longrightarrow> triple x x x"
apply (erule ssubst)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
back \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
back \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
back \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
back \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
done

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
apply (erule ssubst, assumption)
done

text\<open>
or better still
\<close>

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
by (erule ssubst)

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
apply (erule_tac P="\<lambda>u. triple u u x" in ssubst)
apply (assumption)
done

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
by (erule_tac P="\<lambda>u. triple u u x" in ssubst)

text \<open>
negation

@{thm[display] notI}
\rulename{notI}

@{thm[display] notE}
\rulename{notE}

@{thm[display] classical}
\rulename{classical}

@{thm[display] contrapos_pp}
\rulename{contrapos_pp}

@{thm[display] contrapos_pn}
\rulename{contrapos_pn}

@{thm[display] contrapos_np}
\rulename{contrapos_np}

@{thm[display] contrapos_nn}
\rulename{contrapos_nn}
\<close>

lemma "\<lbrakk>\<not>(P\<longrightarrow>Q); \<not>(R\<longrightarrow>Q)\<rbrakk> \<Longrightarrow> R"
apply (erule_tac Q="R\<longrightarrow>Q" in contrapos_np)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (intro impI)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
by (erule notE)

text \<open>
@{thm[display] disjCI}
\rulename{disjCI}
\<close>

lemma "(P \<or> Q) \<and> R \<Longrightarrow> P \<or> Q \<and> R"
apply (intro disjCI conjI)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>

apply (elim conjE disjE)
 apply assumption
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>

by (erule contrapos_np, rule conjI)
text\<open>
proof\ {\isacharparenleft}prove{\isacharparenright}{\isacharcolon}\ step\ {\isadigit{6}}\isanewline
\isanewline
goal\ {\isacharparenleft}lemma{\isacharparenright}{\isacharcolon}\isanewline
{\isacharparenleft}P\ {\isasymor}\ Q{\isacharparenright}\ {\isasymand}\ R\ {\isasymLongrightarrow}\ P\ {\isasymor}\ Q\ {\isasymand}\ R\isanewline
\ {\isadigit{1}}{\isachardot}\ {\isasymlbrakk}R{\isacharsemicolon}\ Q{\isacharsemicolon}\ {\isasymnot}\ P{\isasymrbrakk}\ {\isasymLongrightarrow}\ Q\isanewline
\ {\isadigit{2}}{\isachardot}\ {\isasymlbrakk}R{\isacharsemicolon}\ Q{\isacharsemicolon}\ {\isasymnot}\ P{\isasymrbrakk}\ {\isasymLongrightarrow}\ R
\<close>

text\<open>rule_tac, etc.\<close>

lemma "P&Q"
apply (rule_tac P=P and Q=Q in conjI)
oops

text\<open>unification failure trace\<close>

declare [[unify_trace_failure = true]]

lemma "P(a, f(b, g(e,a), b), a) \<Longrightarrow> P(a, f(b, g(c,a), b), a)"
txt\<open>
@{subgoals[display,indent=0,margin=65]}
apply assumption
Clash: e =/= c

Clash: == =/= Trueprop
\<close>
oops

lemma "\<forall>x y. P(x,y) --> P(y,x)"
apply auto
txt\<open>
@{subgoals[display,indent=0,margin=65]}
apply assumption

Clash: bound variable x (depth 1) =/= bound variable y (depth 0)

Clash: == =/= Trueprop
Clash: == =/= Trueprop
\<close>
oops

declare [[unify_trace_failure = false]]

text\<open>Quantifiers\<close>

text \<open>
@{thm[display] allI}
\rulename{allI}

@{thm[display] allE}
\rulename{allE}

@{thm[display] spec}
\rulename{spec}
\<close>

lemma "\<forall>x. P x \<longrightarrow> P x"
apply (rule allI)
by (rule impI)

lemma "(\<forall>x. P \<longrightarrow> Q x) \<Longrightarrow> P \<longrightarrow> (\<forall>x. Q x)"
apply (rule impI, rule allI)
apply (drule spec)
by (drule mp)

text\<open>rename_tac\<close>
lemma "x < y \<Longrightarrow> \<forall>x y. P x (f y)"
apply (intro allI)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rename_tac v w)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
oops

lemma "\<lbrakk>\<forall>x. P x \<longrightarrow> P (h x); P a\<rbrakk> \<Longrightarrow> P(h (h a))"
apply (frule spec)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (drule mp, assumption)
apply (drule spec)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
by (drule mp)

lemma "\<lbrakk>\<forall>x. P x \<longrightarrow> P (f x); P a\<rbrakk> \<Longrightarrow> P(f (f a))"
by blast

text\<open>
the existential quantifier\<close>

text \<open>
@{thm[display]"exI"}
\rulename{exI}

@{thm[display]"exE"}
\rulename{exE}
\<close>

text\<open>
instantiating quantifiers explicitly by rule_tac and erule_tac\<close>

lemma "\<lbrakk>\<forall>x. P x \<longrightarrow> P (h x); P a\<rbrakk> \<Longrightarrow> P(h (h a))"
apply (frule spec)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (drule mp, assumption)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (drule_tac x = "h a" in spec)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
by (drule mp)

text \<open>
@{thm[display]"dvd_def"}
\rulename{dvd_def}
\<close>

lemma mult_dvd_mono: "\<lbrakk>i dvd m; j dvd n\<rbrakk> \<Longrightarrow> i*j dvd (m*n :: nat)"
apply (simp add: dvd_def)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule exE)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule exE)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rename_tac l)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule_tac x="k*l" in exI)
        \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply simp
done

text\<open>
Hilbert-epsilon theorems\<close>

text\<open>
@{thm[display] the_equality[no_vars]}
\rulename{the_equality}

@{thm[display] some_equality[no_vars]}
\rulename{some_equality}

@{thm[display] someI[no_vars]}
\rulename{someI}

@{thm[display] someI2[no_vars]}
\rulename{someI2}

@{thm[display] someI_ex[no_vars]}
\rulename{someI_ex}

needed for examples

@{thm[display] inv_def[no_vars]}
\rulename{inv_def}

@{thm[display] Least_def[no_vars]}
\rulename{Least_def}

@{thm[display] order_antisym[no_vars]}
\rulename{order_antisym}
\<close>

lemma "inv Suc (Suc n) = n"
by (simp add: inv_def)

text\<open>but we know nothing about inv Suc 0\<close>

theorem Least_equality:
     "\<lbrakk> P (k::nat);  \<forall>x. P x \<longrightarrow> k \<le> x \<rbrakk> \<Longrightarrow> (LEAST x. P(x)) = k"
apply (simp add: Least_def)

txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>

apply (rule the_equality)

txt\<open>
@{subgoals[display,indent=0,margin=65]}

first subgoal is existence; second is uniqueness
\<close>
by (auto intro: order_antisym)

theorem axiom_of_choice:
     "(\<forall>x. \<exists>y. P x y) \<Longrightarrow> \<exists>f. \<forall>x. P x (f x)"
apply (rule exI, rule allI)

txt\<open>
@{subgoals[display,indent=0,margin=65]}

state after intro rules
\<close>
apply (drule spec, erule exE)

txt\<open>
@{subgoals[display,indent=0,margin=65]}

applying @text{someI} automatically instantiates
\<^term>\<open>f\<close> to \<^term>\<open>\<lambda>x. SOME y. P x y\<close>
\<close>

by (rule someI)

(*both can be done by blast, which however hasn't been introduced yet*)
lemma "[| P (k::nat);  \<forall>x. P x \<longrightarrow> k \<le> x |] ==> (LEAST x. P(x)) = k"
apply (simp add: Least_def)
by (blast intro: order_antisym)

theorem axiom_of_choice': "(\<forall>x. \<exists>y. P x y) \<Longrightarrow> \<exists>f. \<forall>x. P x (f x)"
apply (rule exI [of _  "\<lambda>x. SOME y. P x y"])
by (blast intro: someI)

text\<open>end of Epsilon section\<close>

lemma "(\<exists>x. P x) \<or> (\<exists>x. Q x) \<Longrightarrow> \<exists>x. P x \<or> Q x"
apply (elim exE disjE)
 apply (intro exI disjI1)
 apply assumption
apply (intro exI disjI2)
apply assumption
done

lemma "(P\<longrightarrow>Q) \<or> (Q\<longrightarrow>P)"
apply (intro disjCI impI)
apply (elim notE)
apply (intro impI)
apply assumption
done

lemma "(P\<or>Q)\<and>(P\<or>R) \<Longrightarrow> P \<or> (Q\<and>R)"
apply (intro disjCI conjI)
apply (elim conjE disjE)
apply blast
apply blast
apply blast
apply blast
(*apply elim*)
done

lemma "(\<exists>x. P \<and> Q x) \<Longrightarrow> P \<and> (\<exists>x. Q x)"
apply (erule exE)
apply (erule conjE)
apply (rule conjI)
 apply assumption
apply (rule exI)
 apply assumption
done

lemma "(\<exists>x. P x) \<and> (\<exists>x. Q x) \<Longrightarrow> \<exists>x. P x \<and> Q x"
apply (erule conjE)
apply (erule exE)
apply (erule exE)
apply (rule exI)
apply (rule conjI)
 apply assumption
oops

lemma "\<forall>y. R y y \<Longrightarrow> \<exists>x. \<forall>y. R x y"
apply (rule exI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule allI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (drule spec)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
oops

lemma "\<forall>x. \<exists>y. x=y"
apply (rule allI)
apply (rule exI)
apply (rule refl)
done

lemma "\<exists>x. \<forall>y. x=y"
apply (rule exI)
apply (rule allI)
oops

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.*)
  theory TIP_sort_nat_HSort2IsSort
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "Nat => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "Nat list => Nat list" where
  "hsort2 x = toList (toHeap2 x)"

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

end


(*<*)
theory Trace
  imports "HOL-Library.Stream"
begin
(*>*)

section \<open>Traces and trace prefixes\<close>

subsection \<open>Infinite traces\<close>

coinductive ssorted :: "'a :: linorder stream \<Rightarrow> bool" where
  "shd s \<le> shd (stl s) \<Longrightarrow> ssorted (stl s) \<Longrightarrow> ssorted s"

lemma ssorted_siterate[simp]: "(\<And>n. n \<le> f n) \<Longrightarrow> ssorted (siterate f n)"
  by (coinduction arbitrary: n) auto

lemma ssortedD: "ssorted s \<Longrightarrow> s !! i \<le> stl s !! i"
  by (induct i arbitrary: s) (auto elim: ssorted.cases)

lemma ssorted_sdrop: "ssorted s \<Longrightarrow> ssorted (sdrop i s)"
  by (coinduction arbitrary: i s) (auto elim: ssorted.cases ssortedD)

lemma ssorted_monoD: "ssorted s \<Longrightarrow> i \<le> j \<Longrightarrow> s !! i \<le> s !! j"
proof (induct "j - i" arbitrary: j)
  case (Suc x)
  from Suc(1)[of "j - 1"] Suc(2-4) ssortedD[of s "j - 1"]
    show ?case by (cases j) (auto simp: le_Suc_eq Suc_diff_le)
qed simp

lemma sorted_stake: "ssorted s \<Longrightarrow> sorted (stake i s)"
  by (induct i arbitrary: s)
    (auto elim: ssorted.cases simp: in_set_conv_nth
      intro!: ssorted_monoD[of _ 0, simplified, THEN order_trans, OF _ ssortedD])

lemma ssorted_monoI: "\<forall>i j. i \<le> j \<longrightarrow> s !! i \<le> s !! j \<Longrightarrow> ssorted s"
  by (coinduction arbitrary: s)
    (auto dest: spec2[of _ "Suc _" "Suc _"] spec2[of _ 0 "Suc 0"])

lemma ssorted_iff_mono: "ssorted s \<longleftrightarrow> (\<forall>i j. i \<le> j \<longrightarrow> s !! i \<le> s !! j)"
  using ssorted_monoI ssorted_monoD by metis

lemma ssorted_iff_le_Suc: "ssorted s \<longleftrightarrow> (\<forall>i. s !! i \<le> s !! Suc i)"
  using mono_iff_le_Suc[of "snth s"] by (simp add: mono_def ssorted_iff_mono)

definition "sincreasing s = (\<forall>x. \<exists>i. x < s !! i)"

lemma sincreasingI: "(\<And>x. \<exists>i. x < s !! i) \<Longrightarrow> sincreasing s"
  by (simp add: sincreasing_def)

lemma sincreasing_grD:
  fixes x :: "'a :: semilattice_sup"
  assumes "sincreasing s"
  shows "\<exists>j>i. x < s !! j"
proof -
  let ?A = "insert x {s !! n | n. n \<le> i}"
  from assms obtain j where *: "Sup_fin ?A < s !! j"
    by (auto simp: sincreasing_def)
  then have "x < s !! j"
    by (rule order.strict_trans1[rotated]) (auto intro: Sup_fin.coboundedI)
  moreover have "i < j"
  proof (rule ccontr)
    assume "\<not> i < j"
    then have "s !! j \<in> ?A" by (auto simp: not_less)
    then have "s !! j \<le> Sup_fin ?A"
      by (auto intro: Sup_fin.coboundedI)
    with * show False by simp
  qed
  ultimately show ?thesis by blast
qed

lemma sincreasing_siterate_nat[simp]:
  fixes n :: nat
  assumes "(\<And>n. n < f n)"
  shows "sincreasing (siterate f n)"
unfolding sincreasing_def proof
  fix x
  show "\<exists>i. x < siterate f n !! i"
  proof (induction x)
    case 0
    have "0 < siterate f n !! 1"
      using order.strict_trans1[OF le0 assms] by simp
    then show ?case ..
  next
    case (Suc x)
    then obtain i where "x < siterate f n !! i" ..
    then have "Suc x < siterate f n !! Suc i"
      using order.strict_trans1[OF _ assms] by (simp del: snth.simps)
    then show ?case ..
  qed
qed

lemma sincreasing_stl: "sincreasing s \<Longrightarrow> sincreasing (stl s)" for s :: "'a :: semilattice_sup stream"
  by (auto 0 4 simp: gr0_conv_Suc intro!: sincreasingI dest: sincreasing_grD[of s 0])

typedef 'a trace = "{s :: ('a set \<times> nat) stream. ssorted (smap snd s) \<and> sincreasing (smap snd s)}"
  by (intro exI[of _ "smap (\<lambda>i. ({}, i)) nats"])
    (auto simp: stream.map_comp stream.map_ident cong: stream.map_cong)

setup_lifting type_definition_trace

lift_definition \<Gamma> :: "'a trace \<Rightarrow> nat \<Rightarrow> 'a set" is
  "\<lambda>s i. fst (s !! i)" .
lift_definition \<tau> :: "'a trace \<Rightarrow> nat \<Rightarrow> nat" is
  "\<lambda>s i. snd (s !! i)" .

lemma stream_eq_iff: "s = s' \<longleftrightarrow> (\<forall>n. s !! n = s' !! n)"
  by (metis stream.map_cong0 stream_smap_nats)

lemma trace_eqI: "(\<And>i. \<Gamma> \<sigma> i = \<Gamma> \<sigma>' i) \<Longrightarrow> (\<And>i. \<tau> \<sigma> i = \<tau> \<sigma>' i) \<Longrightarrow> \<sigma> = \<sigma>'"
  by transfer (auto simp: stream_eq_iff intro!: prod_eqI)

lemma \<tau>_mono[simp]: "i \<le> j \<Longrightarrow> \<tau> s i \<le> \<tau> s j"
  by transfer (auto simp: ssorted_iff_mono)

lemma ex_le_\<tau>: "\<exists>j\<ge>i. x \<le> \<tau> s j"
  by (transfer fixing: i x) (auto dest!: sincreasing_grD[of _ i x] less_imp_le)

lemma le_\<tau>_less: "\<tau> \<sigma> i \<le> \<tau> \<sigma> j \<Longrightarrow> j < i \<Longrightarrow> \<tau> \<sigma> i = \<tau> \<sigma> j"
  by (simp add: antisym)

lemma less_\<tau>D: "\<tau> \<sigma> i < \<tau> \<sigma> j \<Longrightarrow> i < j"
  by (meson \<tau>_mono less_le_not_le not_le_imp_less)

abbreviation "\<Delta> s i \<equiv> \<tau> s i - \<tau> s (i - 1)"

lift_definition map_\<Gamma> :: "('a set \<Rightarrow> 'b set) \<Rightarrow> 'a trace \<Rightarrow> 'b trace" is
  "\<lambda>f s. smap (\<lambda>(x, i). (f x, i)) s"
  by (auto simp: stream.map_comp prod.case_eq_if cong: stream.map_cong)

lemma \<Gamma>_map_\<Gamma>[simp]: "\<Gamma> (map_\<Gamma> f s) i = f (\<Gamma> s i)"
  by transfer (simp add: prod.case_eq_if)

lemma \<tau>_map_\<Gamma>[simp]: "\<tau> (map_\<Gamma> f s) i = \<tau> s i"
  by transfer (simp add: prod.case_eq_if)

lemma map_\<Gamma>_id[simp]: "map_\<Gamma> id s = s"
  by transfer (simp add: stream.map_id)

lemma map_\<Gamma>_comp: "map_\<Gamma> g (map_\<Gamma> f s) = map_\<Gamma> (g \<circ> f) s"
  by transfer (simp add: stream.map_comp comp_def prod.case_eq_if case_prod_beta')

lemma map_\<Gamma>_cong: "\<sigma>\<^sub>1 = \<sigma>\<^sub>2 \<Longrightarrow> (\<And>x. f\<^sub>1 x = f\<^sub>2 x) \<Longrightarrow> map_\<Gamma> f\<^sub>1 \<sigma>\<^sub>1 = map_\<Gamma> f\<^sub>2 \<sigma>\<^sub>2"
  by transfer (auto intro!: stream.map_cong)

subsection \<open>Finite trace prefixes\<close>

typedef 'a prefix = "{p :: ('a set \<times> nat) list. sorted (map snd p)}"
  by (auto intro!: exI[of _ "[]"])

setup_lifting type_definition_prefix

lift_definition pmap_\<Gamma> :: "('a set \<Rightarrow> 'b set) \<Rightarrow> 'a prefix \<Rightarrow> 'b prefix" is
  "\<lambda>f. map (\<lambda>(x, i). (f x, i))"
  by (simp add: split_beta comp_def)

lift_definition last_ts :: "'a prefix \<Rightarrow> nat" is
  "\<lambda>p. (case p of [] \<Rightarrow> 0 | _ \<Rightarrow> snd (last p))" .

lift_definition first_ts :: "nat \<Rightarrow> 'a prefix \<Rightarrow> nat" is
  "\<lambda>n p. (case p of [] \<Rightarrow> n | _ \<Rightarrow> snd (hd p))" .

lift_definition pnil :: "'a prefix" is "[]" by simp

lift_definition plen :: "'a prefix \<Rightarrow> nat" is "length" .

lift_definition psnoc :: "'a prefix \<Rightarrow> 'a set \<times> nat \<Rightarrow> 'a prefix" is
  "\<lambda>p x. if (case p of [] \<Rightarrow> 0 | _ \<Rightarrow> snd (last p)) \<le> snd x then p @ [x] else []"
proof (goal_cases sorted_psnoc)
  case (sorted_psnoc p x)
  then show ?case
    by (induction p) (auto split: if_splits list.splits)
qed

instantiation prefix :: (type) order begin

lift_definition less_eq_prefix :: "'a prefix \<Rightarrow> 'a prefix \<Rightarrow> bool" is
  "\<lambda>p q. \<exists>r. q = p @ r" .

definition less_prefix :: "'a prefix \<Rightarrow> 'a prefix \<Rightarrow> bool" where
  "less_prefix x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof (standard, goal_cases less refl trans antisym)
  case (less x y)
  then show ?case unfolding less_prefix_def ..
next
  case (refl x)
  then show ?case by transfer auto
next
  case (trans x y z)
  then show ?case by transfer auto
next
  case (antisym x y)
  then show ?case by transfer auto
qed

end

lemma psnoc_inject[simp]:
  "last_ts p \<le> snd x \<Longrightarrow> last_ts q \<le> snd y \<Longrightarrow> psnoc p x = psnoc q y \<longleftrightarrow> (p = q \<and> x = y)"
  by transfer auto

lift_definition prefix_of :: "'a prefix \<Rightarrow> 'a trace \<Rightarrow> bool" is "\<lambda>p s. stake (length p) s = p" .

lemma prefix_of_pnil[simp]: "prefix_of pnil \<sigma>"
  by transfer auto

lemma plen_pnil[simp]: "plen pnil = 0"
  by transfer auto

lemma prefix_of_pmap_\<Gamma>[simp]: "prefix_of \<pi> \<sigma> \<Longrightarrow> prefix_of (pmap_\<Gamma> f \<pi>) (map_\<Gamma> f \<sigma>)"
  by transfer auto

lemma plen_mono: "\<pi> \<le> \<pi>' \<Longrightarrow> plen \<pi> \<le> plen \<pi>'"
  by transfer auto

lemma prefix_of_psnocE: "prefix_of (psnoc p x) s \<Longrightarrow> last_ts p \<le> snd x \<Longrightarrow>
  (prefix_of p s \<Longrightarrow> \<Gamma> s (plen p) = fst x \<Longrightarrow> \<tau> s (plen p) = snd x \<Longrightarrow> P) \<Longrightarrow> P"
  by transfer (simp del: stake.simps add: stake_Suc)

lemma le_pnil[simp]: "pnil \<le> \<pi>"
  by transfer auto

lift_definition take_prefix :: "nat \<Rightarrow> 'a trace \<Rightarrow> 'a prefix" is stake
  by (auto dest: sorted_stake)

lemma plen_psnoc[simp]: "last_ts \<pi> \<le> snd x \<Longrightarrow> plen (psnoc \<pi> x) = plen \<pi> + 1"
  by transfer auto

lemma prefix_of_take_prefix[simp]: "prefix_of (take_prefix i \<sigma>) \<sigma>"
  by transfer auto

lift_definition pdrop :: "nat \<Rightarrow> 'a prefix \<Rightarrow> 'a prefix" is drop
  by (auto simp: drop_map[symmetric] sorted_wrt_drop)

lemma pdrop_0[simp]: "pdrop 0 \<pi> = \<pi>"
  by transfer auto

lemma prefix_of_antimono: "\<pi> \<le> \<pi>' \<Longrightarrow> prefix_of \<pi>' s \<Longrightarrow> prefix_of \<pi> s"
  by transfer (auto simp del: stake_add simp add: stake_add[symmetric])

lemma prefix_of_imp_linear: "prefix_of \<pi> \<sigma> \<Longrightarrow> prefix_of \<pi>' \<sigma> \<Longrightarrow> \<pi> \<le> \<pi>' \<or> \<pi>' \<le> \<pi>"
proof transfer
  fix \<pi> \<pi>' and \<sigma> :: "('a set \<times> nat) stream"
  assume assms: "stake (length \<pi>) \<sigma> = \<pi>" "stake (length \<pi>') \<sigma> = \<pi>'"
  show "(\<exists>r. \<pi>' = \<pi> @ r) \<or> (\<exists>r. \<pi> = \<pi>' @ r)"
  proof (cases "length \<pi>" "length \<pi>'" rule: le_cases)
    case le
    then have "\<pi>' = take (length \<pi>) \<pi>' @ drop (length \<pi>) \<pi>'"
      by simp
    moreover have "take (length \<pi>) \<pi>' = \<pi>"
      using assms le by (metis min.absorb1 take_stake)
    ultimately show ?thesis by auto
  next
    case ge
    then have "\<pi> = take (length \<pi>') \<pi> @ drop (length \<pi>') \<pi>"
      by simp
    moreover have "take (length \<pi>') \<pi> = \<pi>'"
      using assms ge by (metis min.absorb1 take_stake)
    ultimately show ?thesis by auto
  qed
qed

lemma ex_prefix_of: "\<exists>s. prefix_of p s"
proof (transfer, intro bexI CollectI conjI)
  fix p :: "('a set \<times> nat) list"
  assume *: "sorted (map snd p)"
  let ?\<sigma> = "p @- smap (Pair undefined) (fromN (snd (last p)))"
  show "stake (length p) ?\<sigma> = p" by (simp add: stake_shift)
  have le_last: "snd (p ! i) \<le> snd (last p)" if "i < length p" for i
    using sorted_nth_mono[OF *, of i "length p - 1"] that
    by (cases p) (auto simp: last_conv_nth nth_Cons')
  with * show "ssorted (smap snd ?\<sigma>)"
    by (force simp: ssorted_iff_mono sorted_iff_nth_mono shift_snth)
  show "sincreasing (smap snd ?\<sigma>)"
  proof (rule sincreasingI)
    fix x
    have "x < smap snd ?\<sigma> !! Suc (length p + x)"
      by simp (metis Suc_pred add.commute diff_Suc_Suc length_greater_0_conv less_add_Suc1 less_diff_conv)
    then show "\<exists>i. x < smap snd ?\<sigma> !! i" ..
  qed
qed

lemma \<tau>_prefix_conv: "prefix_of p s \<Longrightarrow> prefix_of p s' \<Longrightarrow> i < plen p \<Longrightarrow> \<tau> s i = \<tau> s' i"
  by transfer (simp add: stake_nth[symmetric])

lemma \<Gamma>_prefix_conv: "prefix_of p s \<Longrightarrow> prefix_of p s' \<Longrightarrow> i < plen p \<Longrightarrow> \<Gamma> s i = \<Gamma> s' i"
  by transfer (simp add: stake_nth[symmetric])

lemma sincreasing_sdrop:
  fixes s :: "('a :: semilattice_sup) stream"
  assumes "sincreasing s"
  shows "sincreasing (sdrop n s)"
proof (rule sincreasingI)
  fix x
  obtain i where "n < i" and "x < s !! i"
    using sincreasing_grD[OF assms] by blast
  then have "x < sdrop n s !! (i - n)"
    by (simp add: sdrop_snth)
  then show "\<exists>i. x < sdrop n s !! i" ..
qed

lemma ssorted_shift:
  "ssorted (xs @- s) = (sorted xs \<and> ssorted s \<and> (\<forall>x\<in>set xs. \<forall>y\<in>sset s. x \<le> y))"
proof safe
  assume *: "ssorted (xs @- s)"
  then show "sorted xs"
    by (auto simp: ssorted_iff_mono shift_snth sorted_iff_nth_mono split: if_splits)
  from ssorted_sdrop[OF *, of "length xs"] show "ssorted s"
    by (auto simp: sdrop_shift)
  fix x y assume "x \<in> set xs" "y \<in> sset s"
  then obtain i j where "i < length xs" "xs ! i = x" "s !! j = y"
    by (auto simp: set_conv_nth sset_range)
  with ssorted_monoD[OF *, of i "j + length xs"] show "x \<le> y" by auto
next
  assume "sorted xs" "ssorted s" "\<forall>x\<in>set xs. \<forall>y\<in>sset s. x \<le> y"
  then show "ssorted (xs @- s)"
  proof (coinduction arbitrary: xs s)
    case (ssorted xs s)
    with \<open>ssorted s\<close> show ?case
      by (subst (asm) ssorted.simps) (auto 0 4 simp: neq_Nil_conv shd_sset intro: exI[of _ "_ # _"])
  qed
qed

lemma sincreasing_shift:
  assumes "sincreasing s"
  shows "sincreasing (xs @- s)"
proof (rule sincreasingI)
  fix x
  from assms obtain i where "x < s !! i"
    unfolding sincreasing_def by blast
  then have "x < (xs @- s) !! (length xs + i)"
    by simp
  then show "\<exists>i. x < (xs @- s) !! i" ..
qed

lift_definition replace_prefix :: "'a prefix \<Rightarrow> 'a trace \<Rightarrow> 'a trace" is
   "\<lambda>\<pi> \<sigma>. if ssorted (smap snd (\<pi> @- sdrop (length \<pi>) \<sigma>)) then
     \<pi> @- sdrop (length \<pi>) \<sigma> else smap (\<lambda>i. ({}, i)) nats"
  by (auto split: if_splits simp: stream.map_comp stream.map_ident sdrop_smap[symmetric]
    simp del: sdrop_smap intro!: sincreasing_shift sincreasing_sdrop cong: stream.map_cong)

lemma prefix_of_replace_prefix:
  "prefix_of (pmap_\<Gamma> f \<pi>) \<sigma> \<Longrightarrow> prefix_of \<pi> (replace_prefix \<pi> \<sigma>)"
proof (transfer; safe; goal_cases)
  case (1 f \<pi> \<sigma>)
  then show ?case
    by (subst (asm) (2) stake_sdrop[symmetric, of _ "length \<pi>"])
      (auto 0 3 simp: ssorted_shift split_beta o_def stake_shift sdrop_smap[symmetric]
        ssorted_sdrop not_le simp del: sdrop_smap)
qed

lemma map_\<Gamma>_replace_prefix:
  "\<forall>x. f (f x) = f x \<Longrightarrow> prefix_of (pmap_\<Gamma> f \<pi>) \<sigma> \<Longrightarrow> map_\<Gamma> f (replace_prefix \<pi> \<sigma>) = map_\<Gamma> f \<sigma>"
proof (transfer; safe; goal_cases)
  case (1 f \<pi> \<sigma>)
  then show ?case
    by (subst (asm) (2) stake_sdrop[symmetric, of \<sigma> "length \<pi>"],
        subst (3) stake_sdrop[symmetric, of \<sigma> "length \<pi>"])
      (auto simp: ssorted_shift split_beta o_def stake_shift sdrop_smap[symmetric] ssorted_sdrop
        not_le simp del: sdrop_smap cong: map_cong)
qed

lemma prefix_of_pmap_\<Gamma>_D:
  assumes "prefix_of (pmap_\<Gamma> f \<pi>) \<sigma>"
  shows "\<exists>\<sigma>'. prefix_of \<pi> \<sigma>' \<and> prefix_of (pmap_\<Gamma> f \<pi>) (map_\<Gamma> f \<sigma>')"
proof -
  from assms(1) obtain \<sigma>' where 1: "prefix_of \<pi> \<sigma>'"
    using ex_prefix_of by blast
  then have "prefix_of (pmap_\<Gamma> f \<pi>) (map_\<Gamma> f \<sigma>')"
    by transfer simp
  with 1 show ?thesis by blast
qed

lemma prefix_of_map_\<Gamma>_D:
  assumes "prefix_of \<pi>' (map_\<Gamma> f \<sigma>)"
  shows "\<exists>\<pi>''. \<pi>' = pmap_\<Gamma> f \<pi>'' \<and> prefix_of \<pi>'' \<sigma>"
  using assms
  by transfer (auto intro!: exI[of _ "stake (length _) _"] elim: sym dest: sorted_stake)

lift_definition pts :: "'a prefix \<Rightarrow> nat list" is "map snd" .

lemma pts_pmap_\<Gamma>[simp]: "pts (pmap_\<Gamma> f \<pi>) = pts \<pi>"
  by (transfer fixing: f) (simp add: split_beta)

(*<*)
end
(*>*)


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_47
  imports "../../Test_Base"
begin

datatype 'a Tree = Leaf | Node "'a Tree" "'a" "'a Tree"

datatype Nat = Z | S "Nat"

fun mirror :: "'a Tree => 'a Tree" where
  "mirror (Leaf) = Leaf"
| "mirror (Node l y r) = Node (mirror r) y (mirror l)"

fun max :: "Nat => Nat => Nat" where
  "max (Z) y = y"
| "max (S z) (Z) = S z"
| "max (S z) (S x2) = S (max z x2)"

fun height :: "'a Tree => Nat" where
  "height (Leaf) = Z"
| "height (Node l y r) = S (max (height l) (height r))"

theorem property0 :
  "((height (mirror a1)) = (height a1))"
  oops

end


section \<open>Ribbon proof interfaces\<close>

theory Ribbons_Interfaces imports
  Ribbons_Basic
  Proofchain
  "HOL-Library.FSet"
begin

text \<open>Interfaces are the top and bottom boundaries through which diagrams
  can be connected into a surrounding context. For instance, when composing two
  diagrams vertically, the bottom interface of the upper diagram must match the
  top interface of the lower diagram.

  We define a datatype of concrete interfaces. We then quotient by the
  associativity, commutativity and unity properties of our
  horizontal-composition operator.\<close>

subsection \<open>Syntax of interfaces\<close>

datatype conc_interface =
  Ribbon_conc "assertion"
| HComp_int_conc "conc_interface" "conc_interface" (infix "\<otimes>\<^sub>c" 50)
| Emp_int_conc ("\<epsilon>\<^sub>c")
| Exists_int_conc "string" "conc_interface"

text \<open>We define an equivalence on interfaces. The first three rules make this
  an equivalence relation. The next three make it a congruence. The next two
  identify interfaces up to associativity and commutativity of @{term "(\<otimes>\<^sub>c)"}
  The final two make @{term "\<epsilon>\<^sub>c"} the left and right unit of @{term "(\<otimes>\<^sub>c)"}.
\<close>
inductive
  equiv_int :: "conc_interface \<Rightarrow> conc_interface \<Rightarrow> bool" (infix "\<simeq>" 45)
where
  refl: "P \<simeq> P"
| sym: "P \<simeq> Q \<Longrightarrow> Q \<simeq> P"
| trans: "\<lbrakk>P \<simeq> Q; Q \<simeq> R\<rbrakk> \<Longrightarrow> P \<simeq> R"
| cong_hcomp1: "P \<simeq> Q \<Longrightarrow> P' \<otimes>\<^sub>c P \<simeq> P' \<otimes>\<^sub>c Q"
| cong_hcomp2: "P \<simeq> Q \<Longrightarrow> P \<otimes>\<^sub>c P' \<simeq> Q \<otimes>\<^sub>c P'"
| cong_exists: "P \<simeq> Q \<Longrightarrow> Exists_int_conc x P \<simeq> Exists_int_conc x Q"
| hcomp_conc_assoc: "P \<otimes>\<^sub>c (Q \<otimes>\<^sub>c R) \<simeq> (P \<otimes>\<^sub>c Q) \<otimes>\<^sub>c R"
| hcomp_conc_comm: "P \<otimes>\<^sub>c Q \<simeq> Q \<otimes>\<^sub>c P"
| hcomp_conc_unit1: "\<epsilon>\<^sub>c \<otimes>\<^sub>c P \<simeq> P"
| hcomp_conc_unit2: "P \<otimes>\<^sub>c \<epsilon>\<^sub>c \<simeq> P"

lemma equiv_int_cong_hcomp:
  "\<lbrakk> P \<simeq> Q ; P' \<simeq> Q' \<rbrakk> \<Longrightarrow> P \<otimes>\<^sub>c P' \<simeq> Q \<otimes>\<^sub>c Q'"
by (metis cong_hcomp1 cong_hcomp2 equiv_int.trans)

quotient_type interface = "conc_interface" / "equiv_int"
apply (intro equivpI)
apply (intro reflpI, simp add: equiv_int.refl)
apply (intro sympI, simp add: equiv_int.sym)
apply (intro transpI, elim equiv_int.trans, simp add: equiv_int.refl)
done

lift_definition
  Ribbon :: "assertion \<Rightarrow> interface"
is "Ribbon_conc" .

lift_definition
  Emp_int :: "interface" ("\<epsilon>")
is "\<epsilon>\<^sub>c" .

lift_definition
  Exists_int :: "string \<Rightarrow> interface \<Rightarrow> interface"
is "Exists_int_conc"
by (rule equiv_int.cong_exists)

lift_definition
  HComp_int :: "interface \<Rightarrow> interface \<Rightarrow> interface" (infix "\<otimes>" 50)
is "HComp_int_conc" by (rule equiv_int_cong_hcomp)

lemma hcomp_comm:
  "(P \<otimes> Q) = (Q \<otimes> P)"
by (rule hcomp_conc_comm[Transfer.transferred])

lemma hcomp_assoc:
  "(P \<otimes> (Q \<otimes> R)) = ((P \<otimes> Q) \<otimes> R)"
by (rule hcomp_conc_assoc[Transfer.transferred])

lemma emp_hcomp:
  "\<epsilon> \<otimes> P = P"
by (rule hcomp_conc_unit1[Transfer.transferred])

lemma hcomp_emp:
  "P \<otimes> \<epsilon> = P"
by (rule hcomp_conc_unit2[Transfer.transferred])

lemma comp_fun_commute_hcomp:
  "comp_fun_commute (\<otimes>)"
by standard (simp add: hcomp_assoc fun_eq_iff, metis hcomp_comm)

subsection \<open>An iterated horizontal-composition operator\<close>

definition iter_hcomp :: "('a fset) \<Rightarrow> ('a \<Rightarrow> interface) \<Rightarrow> interface"
where
  "iter_hcomp X f \<equiv> ffold ((\<otimes>) \<circ> f) \<epsilon> X"

syntax "iter_hcomp_syntax" ::
  "'a \<Rightarrow> ('a fset) \<Rightarrow> ('a \<Rightarrow> interface) \<Rightarrow> interface"
      ("(\<Otimes>_|\<in>|_. _)" [0,0,10] 10)
translations "\<Otimes>x|\<in>|M. e" == "CONST iter_hcomp M (\<lambda>x. e)"

term "\<Otimes>P|\<in>|Ps. f P" \<comment> \<open>this is eta-expanded, so prints in expanded form\<close>
term "\<Otimes>P|\<in>|Ps. f" \<comment> \<open>this isn't eta-expanded, so prints as written\<close>

lemma iter_hcomp_cong:
  assumes "\<forall>v \<in> fset vs. \<phi> v = \<phi>' v"
  shows "(\<Otimes>v|\<in>|vs. \<phi> v) = (\<Otimes>v|\<in>|vs. \<phi>' v)"
using assms unfolding iter_hcomp_def
by (auto simp add: fmember.rep_eq comp_fun_commute.comp_comp_fun_commute comp_fun_commute_hcomp
  intro: ffold_cong)

lemma iter_hcomp_empty:
  shows "(\<Otimes>x |\<in>| {||}. p x) = \<epsilon>"
by (metis comp_fun_commute.ffold_empty comp_fun_commute_hcomp iter_hcomp_def)

lemma iter_hcomp_insert:
  assumes "v |\<notin>| ws"
  shows "(\<Otimes>x |\<in>| finsert v ws. p x) = (p v \<otimes> (\<Otimes>x |\<in>| ws. p x))"
proof -
  interpret comp_fun_commute "((\<otimes>) \<circ> p)"
  by (metis comp_fun_commute.comp_comp_fun_commute comp_fun_commute_hcomp)
  from assms show ?thesis unfolding iter_hcomp_def by auto
qed

lemma iter_hcomp_union:
  assumes "vs |\<inter>| ws = {||}"
  shows "(\<Otimes>x |\<in>| vs |\<union>| ws. p x) = ((\<Otimes>x |\<in>| vs. p x) \<otimes> (\<Otimes>x |\<in>| ws. p x))"
using assms
by (induct vs) (auto simp add: emp_hcomp iter_hcomp_empty iter_hcomp_insert hcomp_assoc)

subsection \<open>Semantics of interfaces\<close>

text \<open>The semantics of an interface is an assertion.\<close>
fun
  conc_asn :: "conc_interface \<Rightarrow> assertion"
where
  "conc_asn (Ribbon_conc p) = p"
| "conc_asn (P \<otimes>\<^sub>c Q) = (conc_asn P) \<star> (conc_asn Q)"
| "conc_asn (\<epsilon>\<^sub>c) = Emp"
| "conc_asn (Exists_int_conc x P) = Exists x (conc_asn P)"

lift_definition
  asn :: "interface \<Rightarrow> assertion"
is "conc_asn"
by (induct_tac rule:equiv_int.induct) (auto simp add: star_assoc star_comm star_rot emp_star)

lemma asn_simps [simp]:
  "asn (Ribbon p) = p"
  "asn (P \<otimes> Q) = (asn P) \<star> (asn Q)"
  "asn \<epsilon> = Emp"
  "asn (Exists_int x P) = Exists x (asn P)"
by (transfer, simp)+

subsection \<open>Program variables mentioned in an interface.\<close>

fun
  rd_conc_int :: "conc_interface \<Rightarrow> string set"
where
  "rd_conc_int (Ribbon_conc p) = rd_ass p"
| "rd_conc_int (P \<otimes>\<^sub>c Q) = rd_conc_int P \<union> rd_conc_int Q"
| "rd_conc_int (\<epsilon>\<^sub>c) = {}"
| "rd_conc_int (Exists_int_conc x P) = rd_conc_int P"

lift_definition
  rd_int :: "interface \<Rightarrow> string set"
is "rd_conc_int"
by (induct_tac rule: equiv_int.induct) auto

text \<open>The program variables read by an interface are the same as those read
  by its corresponding assertion.\<close>

lemma rd_int_is_rd_ass:
  "rd_ass (asn P) = rd_int P"
by (transfer, induct_tac P, auto simp add: rd_star rd_exists rd_emp)

text \<open>Here is an iterated version of the Hoare logic sequencing rule.\<close>

lemma seq_fold:
  "\<And>\<Pi>. \<lbrakk> length cs = chainlen \<Pi> ; p1 = asn (pre \<Pi>) ; p2 = asn (post \<Pi>) ;
  \<And>i. i < chainlen \<Pi> \<Longrightarrow> prov_triple
  (asn (fst3 (nthtriple \<Pi> i)), cs ! i, asn (thd3 (nthtriple \<Pi> i))) \<rbrakk>
  \<Longrightarrow> prov_triple (p1, foldr (;;) cs Skip, p2)"
proof (induct cs arbitrary: p1 p2)
  case Nil
  thus ?case
  by (cases \<Pi>, auto simp add: prov_triple.skip)
next
  case (Cons c cs)
  obtain p x \<Pi>' where \<Pi>_def: "\<Pi> = \<lbrace> p \<rbrace> \<cdot> x \<cdot> \<Pi>'"
  by (metis Cons.prems(1) chain.exhaust chainlen.simps(1) impossible_Cons le0)
  show ?case
  apply (unfold foldr_Cons o_def)
  apply (rule prov_triple.seq[where q = "asn (pre \<Pi>')"])
  apply (unfold Cons.prems(2) Cons.prems(3) \<Pi>_def pre.simps post.simps)
  apply (subst nth_Cons_0[of c cs, symmetric])
  apply (subst fst3_simp[of p x "pre \<Pi>'", symmetric])
  apply (subst(2) thd3_simp[of p x "pre \<Pi>'", symmetric])
  apply (subst(1 2) nthtriple.simps(1)[of p x "\<Pi>'", symmetric])
  apply (fold \<Pi>_def, intro Cons.prems(4), simp add: \<Pi>_def)
  apply (intro Cons.hyps, insert \<Pi>_def Cons.prems(1), auto)
  apply (fold nth_Cons_Suc[of c cs] nthtriple.simps(2)[of p x "\<Pi>'"])
  apply (fold \<Pi>_def, intro Cons.prems(4), simp add: \<Pi>_def)
  done
qed

end