(*  Title:      HOL/Library/Countable_Set_Type.thy
    Author:     Andrei Popescu, TU Muenchen
    Author:     Andreas Lochbihler, ETH Zurich
    Copyright   2012

Type of (at most) countable sets.
*)

section \<open>Type of (at Most) Countable Sets\<close>

theory Countable_Set_Type
imports Countable_Set Cardinal_Notations Conditionally_Complete_Lattices
begin

subsection\<open>Cardinal stuff\<close>

lemma countable_card_of_nat: "countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
  unfolding countable_def card_of_ordLeq[symmetric] by auto

lemma countable_card_le_natLeq: "countable A \<longleftrightarrow> |A| \<le>o natLeq"
  unfolding countable_card_of_nat using card_of_nat ordLeq_ordIso_trans ordIso_symmetric by blast

lemma countable_or_card_of:
assumes "countable A"
shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
       (infinite A  \<and> |A| =o |UNIV::nat set| )"
by (metis assms countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq
      ordLeq_iff_ordLess_or_ordIso)

lemma countable_cases_card_of[elim]:
  assumes "countable A"
  obtains (Fin) "finite A" "|A| <o |UNIV::nat set|"
        | (Inf) "infinite A" "|A| =o |UNIV::nat set|"
  using assms countable_or_card_of by blast

lemma countable_or:
  "countable A \<Longrightarrow> (\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or> (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
  by (elim countable_enum_cases) fastforce+

lemma countable_cases[elim]:
  assumes "countable A"
  obtains (Fin) f :: "'a\<Rightarrow>nat" where "finite A" "inj_on f A"
        | (Inf) f :: "'a\<Rightarrow>nat" where "infinite A" "bij_betw f A UNIV"
  using assms countable_or by metis

lemma countable_ordLeq:
assumes "|A| \<le>o |B|" and "countable B"
shows "countable A"
using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)

lemma countable_ordLess:
assumes AB: "|A| <o |B|" and B: "countable B"
shows "countable A"
using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .

subsection \<open>The type of countable sets\<close>

typedef 'a cset = "{A :: 'a set. countable A}" morphisms rcset acset
  by (rule exI[of _ "{}"]) simp

setup_lifting type_definition_cset

declare
  rcset_inverse[simp]
  acset_inverse[Transfer.transferred, unfolded mem_Collect_eq, simp]
  acset_inject[Transfer.transferred, unfolded mem_Collect_eq, simp]
  rcset[Transfer.transferred, unfolded mem_Collect_eq, simp]

instantiation cset :: (type) "{bounded_lattice_bot, distrib_lattice, minus}"
begin

lift_definition bot_cset :: "'a cset" is "{}" parametric empty_transfer by simp

lift_definition less_eq_cset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool"
  is subset_eq parametric subset_transfer .

definition less_cset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool"
where "xs < ys \<equiv> xs \<le> ys \<and> xs \<noteq> (ys::'a cset)"

lemma less_cset_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows "((pcr_cset A) ===> (pcr_cset A) ===> op =) op \<subset> op <"
unfolding less_cset_def[abs_def] psubset_eq[abs_def] by transfer_prover

lift_definition sup_cset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset"
is union parametric union_transfer by simp

lift_definition inf_cset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset"
is inter parametric inter_transfer by simp

lift_definition minus_cset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset"
is minus parametric Diff_transfer by simp

instance by standard (transfer; auto)+

end

abbreviation cempty :: "'a cset" where "cempty \<equiv> bot"
abbreviation csubset_eq :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool" where "csubset_eq xs ys \<equiv> xs \<le> ys"
abbreviation csubset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool" where "csubset xs ys \<equiv> xs < ys"
abbreviation cUn :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" where "cUn xs ys \<equiv> sup xs ys"
abbreviation cInt :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" where "cInt xs ys \<equiv> inf xs ys"
abbreviation cDiff :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" where "cDiff xs ys \<equiv> minus xs ys"

lift_definition cin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" is "op \<in>" parametric member_transfer
  .
lift_definition cinsert :: "'a \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is insert parametric Lifting_Set.insert_transfer
  by (rule countable_insert)
abbreviation csingle :: "'a \<Rightarrow> 'a cset" where "csingle x \<equiv> cinsert x cempty"
lift_definition cimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a cset \<Rightarrow> 'b cset" is "op `" parametric image_transfer
  by (rule countable_image)
lift_definition cBall :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Ball parametric Ball_transfer .
lift_definition cBex :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Bex parametric Bex_transfer .
lift_definition cUNION :: "'a cset \<Rightarrow> ('a \<Rightarrow> 'b cset) \<Rightarrow> 'b cset"
  is "UNION" parametric UNION_transfer by simp
definition cUnion :: "'a cset cset \<Rightarrow> 'a cset" where "cUnion A = cUNION A id"

lemma Union_conv_UNION: "\<Union>A = UNION A id"
by auto

lemma cUnion_transfer [transfer_rule]:
  "rel_fun (pcr_cset (pcr_cset A)) (pcr_cset A) Union cUnion"
proof -
  have "rel_fun (pcr_cset (pcr_cset A)) (pcr_cset A) (\<lambda>A. UNION A id) (\<lambda>A. cUNION A id)"
    by transfer_prover
  then show ?thesis by (simp add: cUnion_def [symmetric])
qed

lemmas cset_eqI = set_eqI[Transfer.transferred]
lemmas cset_eq_iff[no_atp] = set_eq_iff[Transfer.transferred]
lemmas cBallI[intro!] = ballI[Transfer.transferred]
lemmas cbspec[dest?] = bspec[Transfer.transferred]
lemmas cBallE[elim] = ballE[Transfer.transferred]
lemmas cBexI[intro] = bexI[Transfer.transferred]
lemmas rev_cBexI[intro?] = rev_bexI[Transfer.transferred]
lemmas cBexCI = bexCI[Transfer.transferred]
lemmas cBexE[elim!] = bexE[Transfer.transferred]
lemmas cBall_triv[simp] = ball_triv[Transfer.transferred]
lemmas cBex_triv[simp] = bex_triv[Transfer.transferred]
lemmas cBex_triv_one_point1[simp] = bex_triv_one_point1[Transfer.transferred]
lemmas cBex_triv_one_point2[simp] = bex_triv_one_point2[Transfer.transferred]
lemmas cBex_one_point1[simp] = bex_one_point1[Transfer.transferred]
lemmas cBex_one_point2[simp] = bex_one_point2[Transfer.transferred]
lemmas cBall_one_point1[simp] = ball_one_point1[Transfer.transferred]
lemmas cBall_one_point2[simp] = ball_one_point2[Transfer.transferred]
lemmas cBall_conj_distrib = ball_conj_distrib[Transfer.transferred]
lemmas cBex_disj_distrib = bex_disj_distrib[Transfer.transferred]
lemmas cBall_cong = ball_cong[Transfer.transferred]
lemmas cBex_cong = bex_cong[Transfer.transferred]
lemmas csubsetI[intro!] = subsetI[Transfer.transferred]
lemmas csubsetD[elim, intro?] = subsetD[Transfer.transferred]
lemmas rev_csubsetD[no_atp,intro?] = rev_subsetD[Transfer.transferred]
lemmas csubsetCE[no_atp,elim] = subsetCE[Transfer.transferred]
lemmas csubset_eq[no_atp] = subset_eq[Transfer.transferred]
lemmas contra_csubsetD[no_atp] = contra_subsetD[Transfer.transferred]
lemmas csubset_refl = subset_refl[Transfer.transferred]
lemmas csubset_trans = subset_trans[Transfer.transferred]
lemmas cset_rev_mp = set_rev_mp[Transfer.transferred]
lemmas cset_mp = set_mp[Transfer.transferred]
lemmas csubset_not_fsubset_eq[code] = subset_not_subset_eq[Transfer.transferred]
lemmas eq_cmem_trans = eq_mem_trans[Transfer.transferred]
lemmas csubset_antisym[intro!] = subset_antisym[Transfer.transferred]
lemmas cequalityD1 = equalityD1[Transfer.transferred]
lemmas cequalityD2 = equalityD2[Transfer.transferred]
lemmas cequalityE = equalityE[Transfer.transferred]
lemmas cequalityCE[elim] = equalityCE[Transfer.transferred]
lemmas eqcset_imp_iff = eqset_imp_iff[Transfer.transferred]
lemmas eqcelem_imp_iff = eqelem_imp_iff[Transfer.transferred]
lemmas cempty_iff[simp] = empty_iff[Transfer.transferred]
lemmas cempty_fsubsetI[iff] = empty_subsetI[Transfer.transferred]
lemmas equals_cemptyI = equals0I[Transfer.transferred]
lemmas equals_cemptyD = equals0D[Transfer.transferred]
lemmas cBall_cempty[simp] = ball_empty[Transfer.transferred]
lemmas cBex_cempty[simp] = bex_empty[Transfer.transferred]
lemmas cInt_iff[simp] = Int_iff[Transfer.transferred]
lemmas cIntI[intro!] = IntI[Transfer.transferred]
lemmas cIntD1 = IntD1[Transfer.transferred]
lemmas cIntD2 = IntD2[Transfer.transferred]
lemmas cIntE[elim!] = IntE[Transfer.transferred]
lemmas cUn_iff[simp] = Un_iff[Transfer.transferred]
lemmas cUnI1[elim?] = UnI1[Transfer.transferred]
lemmas cUnI2[elim?] = UnI2[Transfer.transferred]
lemmas cUnCI[intro!] = UnCI[Transfer.transferred]
lemmas cuUnE[elim!] = UnE[Transfer.transferred]
lemmas cDiff_iff[simp] = Diff_iff[Transfer.transferred]
lemmas cDiffI[intro!] = DiffI[Transfer.transferred]
lemmas cDiffD1 = DiffD1[Transfer.transferred]
lemmas cDiffD2 = DiffD2[Transfer.transferred]
lemmas cDiffE[elim!] = DiffE[Transfer.transferred]
lemmas cinsert_iff[simp] = insert_iff[Transfer.transferred]
lemmas cinsertI1 = insertI1[Transfer.transferred]
lemmas cinsertI2 = insertI2[Transfer.transferred]
lemmas cinsertE[elim!] = insertE[Transfer.transferred]
lemmas cinsertCI[intro!] = insertCI[Transfer.transferred]
lemmas csubset_cinsert_iff = subset_insert_iff[Transfer.transferred]
lemmas cinsert_ident = insert_ident[Transfer.transferred]
lemmas csingletonI[intro!,no_atp] = singletonI[Transfer.transferred]
lemmas csingletonD[dest!,no_atp] = singletonD[Transfer.transferred]
lemmas fsingletonE = csingletonD [elim_format]
lemmas csingleton_iff = singleton_iff[Transfer.transferred]
lemmas csingleton_inject[dest!] = singleton_inject[Transfer.transferred]
lemmas csingleton_finsert_inj_eq[iff,no_atp] = singleton_insert_inj_eq[Transfer.transferred]
lemmas csingleton_finsert_inj_eq'[iff,no_atp] = singleton_insert_inj_eq'[Transfer.transferred]
lemmas csubset_csingletonD = subset_singletonD[Transfer.transferred]
lemmas cDiff_single_cinsert = Diff_single_insert[Transfer.transferred]
lemmas cdoubleton_eq_iff = doubleton_eq_iff[Transfer.transferred]
lemmas cUn_csingleton_iff = Un_singleton_iff[Transfer.transferred]
lemmas csingleton_cUn_iff = singleton_Un_iff[Transfer.transferred]
lemmas cimage_eqI[simp, intro] = image_eqI[Transfer.transferred]
lemmas cimageI = imageI[Transfer.transferred]
lemmas rev_cimage_eqI = rev_image_eqI[Transfer.transferred]
lemmas cimageE[elim!] = imageE[Transfer.transferred]
lemmas Compr_cimage_eq = Compr_image_eq[Transfer.transferred]
lemmas cimage_cUn = image_Un[Transfer.transferred]
lemmas cimage_iff = image_iff[Transfer.transferred]
lemmas cimage_csubset_iff[no_atp] = image_subset_iff[Transfer.transferred]
lemmas cimage_csubsetI = image_subsetI[Transfer.transferred]
lemmas cimage_ident[simp] = image_ident[Transfer.transferred]
lemmas if_split_cin1 = if_split_mem1[Transfer.transferred]
lemmas if_split_cin2 = if_split_mem2[Transfer.transferred]
lemmas cpsubsetI[intro!,no_atp] = psubsetI[Transfer.transferred]
lemmas cpsubsetE[elim!,no_atp] = psubsetE[Transfer.transferred]
lemmas cpsubset_finsert_iff = psubset_insert_iff[Transfer.transferred]
lemmas cpsubset_eq = psubset_eq[Transfer.transferred]
lemmas cpsubset_imp_fsubset = psubset_imp_subset[Transfer.transferred]
lemmas cpsubset_trans = psubset_trans[Transfer.transferred]
lemmas cpsubsetD = psubsetD[Transfer.transferred]
lemmas cpsubset_csubset_trans = psubset_subset_trans[Transfer.transferred]
lemmas csubset_cpsubset_trans = subset_psubset_trans[Transfer.transferred]
lemmas cpsubset_imp_ex_fmem = psubset_imp_ex_mem[Transfer.transferred]
lemmas csubset_cinsertI = subset_insertI[Transfer.transferred]
lemmas csubset_cinsertI2 = subset_insertI2[Transfer.transferred]
lemmas csubset_cinsert = subset_insert[Transfer.transferred]
lemmas cUn_upper1 = Un_upper1[Transfer.transferred]
lemmas cUn_upper2 = Un_upper2[Transfer.transferred]
lemmas cUn_least = Un_least[Transfer.transferred]
lemmas cInt_lower1 = Int_lower1[Transfer.transferred]
lemmas cInt_lower2 = Int_lower2[Transfer.transferred]
lemmas cInt_greatest = Int_greatest[Transfer.transferred]
lemmas cDiff_csubset = Diff_subset[Transfer.transferred]
lemmas cDiff_csubset_conv = Diff_subset_conv[Transfer.transferred]
lemmas csubset_cempty[simp] = subset_empty[Transfer.transferred]
lemmas not_cpsubset_cempty[iff] = not_psubset_empty[Transfer.transferred]
lemmas cinsert_is_cUn = insert_is_Un[Transfer.transferred]
lemmas cinsert_not_cempty[simp] = insert_not_empty[Transfer.transferred]
lemmas cempty_not_cinsert = empty_not_insert[Transfer.transferred]
lemmas cinsert_absorb = insert_absorb[Transfer.transferred]
lemmas cinsert_absorb2[simp] = insert_absorb2[Transfer.transferred]
lemmas cinsert_commute = insert_commute[Transfer.transferred]
lemmas cinsert_csubset[simp] = insert_subset[Transfer.transferred]
lemmas cinsert_cinter_cinsert[simp] = insert_inter_insert[Transfer.transferred]
lemmas cinsert_disjoint[simp,no_atp] = insert_disjoint[Transfer.transferred]
lemmas disjoint_cinsert[simp,no_atp] = disjoint_insert[Transfer.transferred]
lemmas cimage_cempty[simp] = image_empty[Transfer.transferred]
lemmas cimage_cinsert[simp] = image_insert[Transfer.transferred]
lemmas cimage_constant = image_constant[Transfer.transferred]
lemmas cimage_constant_conv = image_constant_conv[Transfer.transferred]
lemmas cimage_cimage = image_image[Transfer.transferred]
lemmas cinsert_cimage[simp] = insert_image[Transfer.transferred]
lemmas cimage_is_cempty[iff] = image_is_empty[Transfer.transferred]
lemmas cempty_is_cimage[iff] = empty_is_image[Transfer.transferred]
lemmas cimage_cong = image_cong[Transfer.transferred]
lemmas cimage_cInt_csubset = image_Int_subset[Transfer.transferred]
lemmas cimage_cDiff_csubset = image_diff_subset[Transfer.transferred]
lemmas cInt_absorb = Int_absorb[Transfer.transferred]
lemmas cInt_left_absorb = Int_left_absorb[Transfer.transferred]
lemmas cInt_commute = Int_commute[Transfer.transferred]
lemmas cInt_left_commute = Int_left_commute[Transfer.transferred]
lemmas cInt_assoc = Int_assoc[Transfer.transferred]
lemmas cInt_ac = Int_ac[Transfer.transferred]
lemmas cInt_absorb1 = Int_absorb1[Transfer.transferred]
lemmas cInt_absorb2 = Int_absorb2[Transfer.transferred]
lemmas cInt_cempty_left = Int_empty_left[Transfer.transferred]
lemmas cInt_cempty_right = Int_empty_right[Transfer.transferred]
lemmas disjoint_iff_cnot_equal = disjoint_iff_not_equal[Transfer.transferred]
lemmas cInt_cUn_distrib = Int_Un_distrib[Transfer.transferred]
lemmas cInt_cUn_distrib2 = Int_Un_distrib2[Transfer.transferred]
lemmas cInt_csubset_iff[no_atp, simp] = Int_subset_iff[Transfer.transferred]
lemmas cUn_absorb = Un_absorb[Transfer.transferred]
lemmas cUn_left_absorb = Un_left_absorb[Transfer.transferred]
lemmas cUn_commute = Un_commute[Transfer.transferred]
lemmas cUn_left_commute = Un_left_commute[Transfer.transferred]
lemmas cUn_assoc = Un_assoc[Transfer.transferred]
lemmas cUn_ac = Un_ac[Transfer.transferred]
lemmas cUn_absorb1 = Un_absorb1[Transfer.transferred]
lemmas cUn_absorb2 = Un_absorb2[Transfer.transferred]
lemmas cUn_cempty_left = Un_empty_left[Transfer.transferred]
lemmas cUn_cempty_right = Un_empty_right[Transfer.transferred]
lemmas cUn_cinsert_left[simp] = Un_insert_left[Transfer.transferred]
lemmas cUn_cinsert_right[simp] = Un_insert_right[Transfer.transferred]
lemmas cInt_cinsert_left = Int_insert_left[Transfer.transferred]
lemmas cInt_cinsert_left_if0[simp] = Int_insert_left_if0[Transfer.transferred]
lemmas cInt_cinsert_left_if1[simp] = Int_insert_left_if1[Transfer.transferred]
lemmas cInt_cinsert_right = Int_insert_right[Transfer.transferred]
lemmas cInt_cinsert_right_if0[simp] = Int_insert_right_if0[Transfer.transferred]
lemmas cInt_cinsert_right_if1[simp] = Int_insert_right_if1[Transfer.transferred]
lemmas cUn_cInt_distrib = Un_Int_distrib[Transfer.transferred]
lemmas cUn_cInt_distrib2 = Un_Int_distrib2[Transfer.transferred]
lemmas cUn_cInt_crazy = Un_Int_crazy[Transfer.transferred]
lemmas csubset_cUn_eq = subset_Un_eq[Transfer.transferred]
lemmas cUn_cempty[iff] = Un_empty[Transfer.transferred]
lemmas cUn_csubset_iff[no_atp, simp] = Un_subset_iff[Transfer.transferred]
lemmas cUn_cDiff_cInt = Un_Diff_Int[Transfer.transferred]
lemmas cDiff_cInt2 = Diff_Int2[Transfer.transferred]
lemmas cUn_cInt_assoc_eq = Un_Int_assoc_eq[Transfer.transferred]
lemmas cBall_cUn = ball_Un[Transfer.transferred]
lemmas cBex_cUn = bex_Un[Transfer.transferred]
lemmas cDiff_eq_cempty_iff[simp,no_atp] = Diff_eq_empty_iff[Transfer.transferred]
lemmas cDiff_cancel[simp] = Diff_cancel[Transfer.transferred]
lemmas cDiff_idemp[simp] = Diff_idemp[Transfer.transferred]
lemmas cDiff_triv = Diff_triv[Transfer.transferred]
lemmas cempty_cDiff[simp] = empty_Diff[Transfer.transferred]
lemmas cDiff_cempty[simp] = Diff_empty[Transfer.transferred]
lemmas cDiff_cinsert0[simp,no_atp] = Diff_insert0[Transfer.transferred]
lemmas cDiff_cinsert = Diff_insert[Transfer.transferred]
lemmas cDiff_cinsert2 = Diff_insert2[Transfer.transferred]
lemmas cinsert_cDiff_if = insert_Diff_if[Transfer.transferred]
lemmas cinsert_cDiff1[simp] = insert_Diff1[Transfer.transferred]
lemmas cinsert_cDiff_single[simp] = insert_Diff_single[Transfer.transferred]
lemmas cinsert_cDiff = insert_Diff[Transfer.transferred]
lemmas cDiff_cinsert_absorb = Diff_insert_absorb[Transfer.transferred]
lemmas cDiff_disjoint[simp] = Diff_disjoint[Transfer.transferred]
lemmas cDiff_partition = Diff_partition[Transfer.transferred]
lemmas double_cDiff = double_diff[Transfer.transferred]
lemmas cUn_cDiff_cancel[simp] = Un_Diff_cancel[Transfer.transferred]
lemmas cUn_cDiff_cancel2[simp] = Un_Diff_cancel2[Transfer.transferred]
lemmas cDiff_cUn = Diff_Un[Transfer.transferred]
lemmas cDiff_cInt = Diff_Int[Transfer.transferred]
lemmas cUn_cDiff = Un_Diff[Transfer.transferred]
lemmas cInt_cDiff = Int_Diff[Transfer.transferred]
lemmas cDiff_cInt_distrib = Diff_Int_distrib[Transfer.transferred]
lemmas cDiff_cInt_distrib2 = Diff_Int_distrib2[Transfer.transferred]
lemmas cset_eq_csubset = set_eq_subset[Transfer.transferred]
lemmas csubset_iff[no_atp] = subset_iff[Transfer.transferred]
lemmas csubset_iff_pfsubset_eq = subset_iff_psubset_eq[Transfer.transferred]
lemmas all_not_cin_conv[simp] = all_not_in_conv[Transfer.transferred]
lemmas ex_cin_conv = ex_in_conv[Transfer.transferred]
lemmas cimage_mono = image_mono[Transfer.transferred]
lemmas cinsert_mono = insert_mono[Transfer.transferred]
lemmas cunion_mono = Un_mono[Transfer.transferred]
lemmas cinter_mono = Int_mono[Transfer.transferred]
lemmas cminus_mono = Diff_mono[Transfer.transferred]
lemmas cin_mono = in_mono[Transfer.transferred]
lemmas cLeast_mono = Least_mono[Transfer.transferred]
lemmas cequalityI = equalityI[Transfer.transferred]
lemmas cUN_iff [simp] = UN_iff[Transfer.transferred]
lemmas cUN_I [intro] = UN_I[Transfer.transferred]
lemmas cUN_E [elim!] = UN_E[Transfer.transferred]
lemmas cUN_upper = UN_upper[Transfer.transferred]
lemmas cUN_least = UN_least[Transfer.transferred]
lemmas cUN_cinsert_distrib = UN_insert_distrib[Transfer.transferred]
lemmas cUN_empty [simp] = UN_empty[Transfer.transferred]
lemmas cUN_empty2 [simp] = UN_empty2[Transfer.transferred]
lemmas cUN_absorb = UN_absorb[Transfer.transferred]
lemmas cUN_cinsert [simp] = UN_insert[Transfer.transferred]
lemmas cUN_cUn [simp] = UN_Un[Transfer.transferred]
lemmas cUN_cUN_flatten = UN_UN_flatten[Transfer.transferred]
lemmas cUN_csubset_iff = UN_subset_iff[Transfer.transferred]
lemmas cUN_constant [simp] = UN_constant[Transfer.transferred]
lemmas cimage_cUnion = image_Union[Transfer.transferred]
lemmas cUNION_cempty_conv [simp] = UNION_empty_conv[Transfer.transferred]
lemmas cBall_cUN = ball_UN[Transfer.transferred]
lemmas cBex_cUN = bex_UN[Transfer.transferred]
lemmas cUn_eq_cUN = Un_eq_UN[Transfer.transferred]
lemmas cUN_mono = UN_mono[Transfer.transferred]
lemmas cimage_cUN = image_UN[Transfer.transferred]
lemmas cUN_csingleton [simp] = UN_singleton[Transfer.transferred]

subsection \<open>Additional lemmas\<close>

subsubsection \<open>\<open>cempty\<close>\<close>

lemma cemptyE [elim!]: "cin a cempty \<Longrightarrow> P" by simp

subsubsection \<open>\<open>cinsert\<close>\<close>

lemma countable_insert_iff: "countable (insert x A) \<longleftrightarrow> countable A"
by (metis Diff_eq_empty_iff countable_empty countable_insert subset_insertI uncountable_minus_countable)

lemma set_cinsert:
  assumes "cin x A"
  obtains B where "A = cinsert x B" and "\<not> cin x B"
using assms by transfer(erule Set.set_insert, simp add: countable_insert_iff)

lemma mk_disjoint_cinsert: "cin a A \<Longrightarrow> \<exists>B. A = cinsert a B \<and> \<not> cin a B"
  by (rule exI[where x = "cDiff A (csingle a)"]) blast

subsubsection \<open>\<open>cimage\<close>\<close>

lemma subset_cimage_iff: "csubset_eq B (cimage f A) \<longleftrightarrow> (\<exists>AA. csubset_eq AA A \<and> B = cimage f AA)"
by transfer (metis countable_subset image_mono mem_Collect_eq subset_imageE)

subsubsection \<open>bounded quantification\<close>

lemma cBex_simps [simp, no_atp]:
  "\<And>A P Q. cBex A (\<lambda>x. P x \<and> Q) = (cBex A P \<and> Q)"
  "\<And>A P Q. cBex A (\<lambda>x. P \<and> Q x) = (P \<and> cBex A Q)"
  "\<And>P. cBex cempty P = False"
  "\<And>a B P. cBex (cinsert a B) P = (P a \<or> cBex B P)"
  "\<And>A P f. cBex (cimage f A) P = cBex A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> cBex A P) = cBall A (\<lambda>x. \<not> P x)"
by auto

lemma cBall_simps [simp, no_atp]:
  "\<And>A P Q. cBall A (\<lambda>x. P x \<or> Q) = (cBall A P \<or> Q)"
  "\<And>A P Q. cBall A (\<lambda>x. P \<or> Q x) = (P \<or> cBall A Q)"
  "\<And>A P Q. cBall A (\<lambda>x. P \<longrightarrow> Q x) = (P \<longrightarrow> cBall A Q)"
  "\<And>A P Q. cBall A (\<lambda>x. P x \<longrightarrow> Q) = (cBex A P \<longrightarrow> Q)"
  "\<And>P. cBall cempty P = True"
  "\<And>a B P. cBall (cinsert a B) P = (P a \<and> cBall B P)"
  "\<And>A P f. cBall (cimage f A) P = cBall A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> cBall A P) = cBex A (\<lambda>x. \<not> P x)"
by auto

lemma atomize_cBall:
    "(\<And>x. cin x A ==> P x) == Trueprop (cBall A (\<lambda>x. P x))"
apply (simp only: atomize_all atomize_imp)
apply (rule equal_intr_rule)
by (transfer, simp)+

subsubsection \<open>@{const cUnion}\<close>

lemma cUNION_cimage: "cUNION (cimage f A) g = cUNION A (g \<circ> f)"
including cset.lifting by transfer auto

subsection \<open>Setup for Lifting/Transfer\<close>

subsubsection \<open>Relator and predicator properties\<close>

lift_definition rel_cset :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool"
  is rel_set parametric rel_set_transfer .

lemma rel_cset_alt_def:
  "rel_cset R a b \<longleftrightarrow>
   (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
   (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
by(simp add: rel_cset_def rel_set_def)

lemma rel_cset_iff:
  "rel_cset R a b \<longleftrightarrow>
   (\<forall>t. cin t a \<longrightarrow> (\<exists>u. cin u b \<and> R t u)) \<and>
   (\<forall>t. cin t b \<longrightarrow> (\<exists>u. cin u a \<and> R u t))"
by transfer(auto simp add: rel_set_def)

lemma rel_cset_cUNION:
  "\<lbrakk> rel_cset Q A B; rel_fun Q (rel_cset R) f g \<rbrakk>
  \<Longrightarrow> rel_cset R (cUNION A f) (cUNION B g)"
unfolding rel_fun_def by transfer(erule rel_set_UNION, simp add: rel_fun_def)

lemma rel_cset_csingle_iff [simp]: "rel_cset R (csingle x) (csingle y) \<longleftrightarrow> R x y"
by transfer(auto simp add: rel_set_def)

subsubsection \<open>Transfer rules for the Transfer package\<close>

text \<open>Unconditional transfer rules\<close>

context includes lifting_syntax
begin

lemmas cempty_parametric [transfer_rule] = empty_transfer[Transfer.transferred]

lemma cinsert_parametric [transfer_rule]:
  "(A ===> rel_cset A ===> rel_cset A) cinsert cinsert"
  unfolding rel_fun_def rel_cset_iff by blast

lemma cUn_parametric [transfer_rule]:
  "(rel_cset A ===> rel_cset A ===> rel_cset A) cUn cUn"
  unfolding rel_fun_def rel_cset_iff by blast

lemma cUnion_parametric [transfer_rule]:
  "(rel_cset (rel_cset A) ===> rel_cset A) cUnion cUnion"
  unfolding rel_fun_def
  by transfer (auto simp: rel_set_def, metis+)

lemma cimage_parametric [transfer_rule]:
  "((A ===> B) ===> rel_cset A ===> rel_cset B) cimage cimage"
  unfolding rel_fun_def rel_cset_iff by blast

lemma cBall_parametric [transfer_rule]:
  "(rel_cset A ===> (A ===> op =) ===> op =) cBall cBall"
  unfolding rel_cset_iff rel_fun_def by blast

lemma cBex_parametric [transfer_rule]:
  "(rel_cset A ===> (A ===> op =) ===> op =) cBex cBex"
  unfolding rel_cset_iff rel_fun_def by blast

lemma rel_cset_parametric [transfer_rule]:
  "((A ===> B ===> op =) ===> rel_cset A ===> rel_cset B ===> op =) rel_cset rel_cset"
  unfolding rel_fun_def
  using rel_set_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred, where A = A and B = B]
  by simp

text \<open>Rules requiring bi-unique, bi-total or right-total relations\<close>

lemma cin_parametric [transfer_rule]:
  "bi_unique A \<Longrightarrow> (A ===> rel_cset A ===> op =) cin cin"
unfolding rel_fun_def rel_cset_iff bi_unique_def by metis

lemma cInt_parametric [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_cset A ===> rel_cset A ===> rel_cset A) cInt cInt"
unfolding rel_fun_def
using inter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred]
by blast

lemma cDiff_parametric [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_cset A ===> rel_cset A ===> rel_cset A) cDiff cDiff"
unfolding rel_fun_def
using Diff_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma csubset_parametric [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_cset A ===> rel_cset A ===> op =) csubset_eq csubset_eq"
unfolding rel_fun_def
using subset_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

end

lifting_update cset.lifting
lifting_forget cset.lifting

subsection \<open>Registration as BNF\<close>

lemma card_of_countable_sets_range:
fixes A :: "'a set"
shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
apply(rule card_of_ordLeqI[of from_nat_into]) using inj_on_from_nat_into
unfolding inj_on_def by auto

lemma card_of_countable_sets_Func:
"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
unfolding cexp_def Field_natLeq Field_card_of
by (rule ordLeq_ordIso_trans)

lemma ordLeq_countable_subsets:
"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto

lemma finite_countable_subset:
"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
apply (rule iffI)
 apply (erule contrapos_pp)
 apply (rule card_of_ordLeq_infinite)
 apply (rule ordLeq_countable_subsets)
 apply assumption
apply (rule finite_Collect_conjI)
apply (rule disjI1)
apply (erule finite_Collect_subsets)
done

lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
  including cset.lifting
  apply (rule f_the_inv_into_f[unfolded inj_on_def image_iff])
   apply transfer' apply simp
  apply transfer' apply simp
  done

lemma Collect_Int_Times: "{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
by auto

lemma rel_cset_aux:
"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
 ((BNF_Def.Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage fst))\<inverse>\<inverse> OO
   BNF_Def.Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage snd)) a b" (is "?L = ?R")
proof
  assume ?L
  define R' where "R' = the_inv rcset (Collect (case_prod R) \<inter> (rcset a \<times> rcset b))"
    (is "_ = the_inv rcset ?L'")
  have L: "countable ?L'" by auto
  hence *: "rcset R' = ?L'" unfolding R'_def by (intro rcset_to_rcset)
  thus ?R unfolding Grp_def relcompp.simps conversep.simps including cset.lifting
  proof (intro CollectI case_prodI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
    from * \<open>?L\<close> show "a = cimage fst R'" by transfer (auto simp: image_def Collect_Int_Times)
    from * \<open>?L\<close> show "b = cimage snd R'" by transfer (auto simp: image_def Collect_Int_Times)
  qed simp_all
next
  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
    by (simp add: subset_eq Ball_def)(transfer, auto simp add: cimage.rep_eq, metis snd_conv, metis fst_conv)
qed

bnf "'a cset"
  map: cimage
  sets: rcset
  bd: natLeq
  wits: "cempty"
  rel: rel_cset
proof -
  show "cimage id = id" by auto
next
  fix f g show "cimage (g \<circ> f) = cimage g \<circ> cimage f" by fastforce
next
  fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
  thus "cimage f C = cimage g C" including cset.lifting by transfer force
next
  fix f show "rcset \<circ> cimage f = op ` f \<circ> rcset" including cset.lifting by transfer' fastforce
next
  show "card_order natLeq" by (rule natLeq_card_order)
next
  show "cinfinite natLeq" by (rule natLeq_cinfinite)
next
  fix C show "|rcset C| \<le>o natLeq"
    including cset.lifting by transfer (unfold countable_card_le_natLeq)
next
  fix R S
  show "rel_cset R OO rel_cset S \<le> rel_cset (R OO S)"
    unfolding rel_cset_alt_def[abs_def] by fast
next
  fix R
  show "rel_cset R = (\<lambda>x y. \<exists>z. rcset z \<subseteq> {(x, y). R x y} \<and>
    cimage fst z = x \<and> cimage snd z = y)"
  unfolding rel_cset_alt_def[abs_def] rel_cset_aux[unfolded OO_Grp_alt] by simp
qed(simp add: bot_cset.rep_eq)

end


section \<open>$n$-th roots of complex numbers\<close>

theory Complex_Roots
  imports
    Complex_Geometry.More_Complex
    Algebraic_Numbers.Complex_Algebraic_Numbers
    Factor_Algebraic_Polynomial.Roots_via_IA
    "HOL-Library.Product_Lexorder"
begin

subsection \<open>An algorithm to compute all complex roots of (algebraic) complex numbers\<close>

definition all_croots :: "nat \<Rightarrow> complex \<Rightarrow> complex list" where
  "all_croots n x = (if n = 0 then [] else
     if algebraic x then
       (let p = min_int_poly x;
         q = poly_nth_root n p;
         xs = complex_roots_of_int_poly q
         in filter (\<lambda> y. y^n = x) xs)
     else (SOME ys. set ys = {y. y^n = x}))"

lemma all_croots: assumes n0: "n \<noteq> 0" shows "set (all_croots n x) = {y. y^n = x}"
proof (cases "algebraic x")
  case True
  hence id: "(if n = 0 then y else if algebraic x then z else u) = z"
    for y z u :: "complex list" using n0 by auto
  define p where "p = poly_nth_root n (min_int_poly x)"
  show ?thesis unfolding Let_def p_def[symmetric] all_croots_def id
  proof (standard, force, standard, simp)
    fix y
    assume y: "y ^n  = x"
    have "min_int_poly x represents x" using True by auto
    from represents_nth_root[OF n0 y this]
    have "p represents y" unfolding p_def by auto
    thus "y \<in> set (complex_roots_of_int_poly p)"
      by (subst complex_roots_of_int_poly, auto)
  qed
next
  case False
  hence id: "(if n = 0 then y else if algebraic x then z else u) = u"
    for y z u :: "complex list" using n0 by auto
  show ?thesis unfolding Let_def all_croots_def id
    by (rule someI_ex, rule finite_list, insert n0, blast)
qed

text \<open>TODO: One might change @{const complex_roots_of_int_poly} to @{const complex_roots_of_int_poly3}
  in order to avoid an unnecessary factorization of an integer polynomial. However, then
  this change already needs to be performed within the definition of @{const all_croots}.\<close>
lift_definition all_croots_part1 :: "nat \<Rightarrow> complex \<Rightarrow> complex genuine_roots_aux" is
  "\<lambda> n x. if n = 0 \<or> x = 0 \<or> \<not> algebraic x then (1,[],0, filter_fun_complex 1)
         else let p = min_int_poly x;
              q = poly_nth_root n p;
              zeros = complex_roots_of_int_poly q;
              r = Polynomial.monom 1 n - [:x:]
         in (r,zeros, n, filter_fun_complex r)"
  subgoal for n x
  proof (cases "n = 0 \<or> x = 0 \<or> \<not> algebraic x")
    case True
    thus ?thesis by (simp add: filter_fun_complex)
  next
    case False
    hence *: "algebraic x" "n \<noteq> 0" "x \<noteq> 0" by auto
    {
      fix z
      assume zn: "z^n = x"
      from *(1) have repr: "min_int_poly x represents x" by auto
      from represents_nth_root[OF *(2) zn repr]
      have "poly_nth_root n (min_int_poly x) represents z" .
    }
    moreover have "card {z. z ^ n = x} = n"
      by (rule card_nth_roots) (use * in auto)
    ultimately show ?thesis using *
      by (auto simp: Let_def complex_roots_of_int_poly filter_fun_complex poly_monom)
  qed
  done

lemma all_croots_code[code]:
  "all_croots n x = (if n = 0 then [] else if x = 0 then [0]
     else if algebraic x then genuine_roots_impl (all_croots_part1 n x)
     else Code.abort (STR ''all_croots invoked on non-algebraic number'') (\<lambda> _. all_croots n x))"
proof (cases "n = 0")
  case True
  thus ?thesis unfolding all_croots_def by simp
next
  case n: False
  show ?thesis
  proof (cases "x = 0")
    case x: False
    show ?thesis
    proof (cases "algebraic x")
      case False
      with n x show ?thesis by simp
    next
      case True
      define t where "t = ?thesis"
      have "t \<longleftrightarrow> filter (\<lambda>y. y ^ n = x)
                (complex_roots_of_int_poly (poly_nth_root n (min_int_poly x)))
            = genuine_roots_impl (all_croots_part1 n x)"
        unfolding t_def
        by (subst all_croots_def[of n x], unfold Let_def, insert n x True, auto)
      also have "\<dots>" using n x True unfolding genuine_roots_impl_def
        by (transfer, simp add: Let_def genuine_roots_def poly_monom)
      finally show ?thesis unfolding t_def by simp
    qed
  next
    case x: True
    have "set (all_croots n 0) = {0}" unfolding all_croots[OF n] using n by simp
    moreover have "distinct (all_croots n 0)" unfolding all_croots_def using n
      by (auto intro!: distinct_filter complex_roots_of_int_poly)
    ultimately have "all_croots n 0 = [0]"
      by (smt (verit, del_insts) distinct.simps(2) distinct_singleton insert_ident list.set_cases list.set_intros(1) list.simps(15) mem_Collect_eq set_empty singleton_conv)
    moreover have "?thesis \<longleftrightarrow> all_croots n 0 = [0]" using n x by simp
    ultimately show ?thesis by auto
  qed
qed

subsection \<open>A definition of \emph{the} complex root of a complex number\<close>

text \<open>While the definition of the complex root is quite natural and easy,
  the main task is a criterion to determine which of all possible roots of a
  complex number is the chosen one.\<close>

definition croot :: "nat \<Rightarrow> complex \<Rightarrow> complex" where
  "croot n x = (rcis (root n (cmod x)) (Arg x / of_nat n))"

lemma croot_0[simp]: "croot n 0 = 0" "croot 0 x = 0"
  unfolding croot_def by auto

lemma croot_power: assumes n: "n \<noteq> 0"
  shows "(croot n x) ^ n = x"
  unfolding croot_def DeMoivre2
  by (subst real_root_pow_pos2, insert n, auto simp: rcis_cmod_Arg)

lemma Arg_of_real: "Arg (of_real x) =
  (if x < 0 then pi else 0)"
proof (cases "x = 0")
  case False
  hence "x < 0 \<or> x > 0" by auto
  thus ?thesis by (intro cis_Arg_unique, auto
      simp: complex_sgn_def scaleR_complex.ctr complex_eq_iff)
qed (auto simp: Arg_def)

lemma Arg_rcis_cis[simp]: assumes "x > 0"
  shows "Arg (rcis x y) = Arg (cis y)"
  using assms unfolding rcis_def by simp

lemma cis_Arg_1[simp]: "cis (Arg 1) = 1"
  using Arg_of_real[of 1] by simp

lemma cis_Arg_power[simp]: assumes "x \<noteq> 0"
  shows "cis (Arg (x ^ n)) = cis (Arg x * real n)"
proof (induct n)
  case (Suc n)
  show ?case unfolding power.simps
  proof (subst cis_arg_mult)
    show "cis (Arg x + Arg (x ^ n)) = cis (Arg x * real (Suc n))"
      unfolding mult.commute[of "Arg x"] DeMoivre[symmetric]
      unfolding power.simps using Suc
      by (metis DeMoivre cis_mult mult.commute)
    show "x * x ^ n \<noteq> 0" using assms by auto
  qed
qed simp

lemma Arg_croot[simp]: "Arg (croot n x) = Arg x / real n"
proof (cases "n = 0 \<or> x = 0")
  case True
  thus ?thesis by (auto simp: Arg_def)
next
  case False
  hence n: "n \<noteq> 0" and x: "x \<noteq> 0" by auto
  let ?root = "croot n x"
  from n have n1: "real n \<ge> 1" "real n > 0" "real n \<noteq> 0" by auto
  have bounded: "- pi < Arg x / real n \<and> Arg x / real n \<le> pi"
  proof (cases "Arg x < 0")
    case True
    from Arg_bounded[of x] have "- pi < Arg x" by auto
    also have "\<dots> \<le> Arg x / real n" using n1 True
      by (smt (z3) div_by_1 divide_minus_left frac_le)
    finally have one: "- pi < Arg x / real n" .
    have "Arg x / real n \<le> 0" using True n1
      by (smt (verit) divide_less_0_iff)
    also have "\<dots> \<le> pi" by simp
    finally show ?thesis using one by auto
  next
    case False
    hence ax: "Arg x \<ge> 0" by auto
    have "Arg x / real n \<le> Arg x" using n1 ax
      by (smt (verit) div_by_1 frac_le)
    also have "\<dots> \<le> pi" using Arg_bounded[of x] by simp
    finally have one: "Arg x / real n \<le> pi" .
    have "-pi < 0" by simp
    also have "\<dots> \<le> Arg x / real n" using ax n1 by simp
    finally show ?thesis using one by auto
  qed
  have "Arg ?root = Arg (cis (Arg x / real n))"
    unfolding croot_def using x n by simp
  also have "\<dots> = Arg x / real n"
    by (rule cis_Arg_unique, force, insert bounded, auto)
  finally show ?thesis .
qed

lemma cos_abs[simp]: "cos (abs x :: real) = cos x"
proof (cases "x < 0")
  case True
  hence abs: "abs x = - x" by simp
  show ?thesis unfolding abs by simp
qed simp

lemma cos_mono_le: assumes "abs x \<le> pi"
  and "abs y \<le> pi"
shows "cos x \<le> cos y \<longleftrightarrow> abs y \<le> abs x"
proof -
  have "cos x \<le> cos y \<longleftrightarrow> cos (abs x) \<le> cos (abs y)" by simp
  also have "\<dots> \<longleftrightarrow> abs y \<le> abs x"
    by (subst cos_mono_le_eq, insert assms, auto)
  finally show ?thesis .
qed

lemma abs_add_2_mult_bound: fixes x :: "'a :: linordered_idom"
  assumes xy: "\<bar>x\<bar> \<le> y"
  shows "\<bar>x\<bar> \<le> \<bar>x + 2 * of_int i * y\<bar>"
proof (cases "i = 0")
  case i: False
  let ?oi = "of_int :: int \<Rightarrow> 'a"
  from xy have y: "y \<ge> 0" by auto
  consider (pp) "x \<ge> 0" "i \<ge> 0"
    | (nn) "x \<le> 0" "i \<le> 0"
    | (pn) "x \<ge> 0" "i \<le> 0"
    | (np) "x \<le> 0" "i \<ge> 0"
    by linarith
  thus ?thesis
  proof cases
    case pp
    thus ?thesis using y by simp
  next
    case nn
    have "x \<ge> x + 2 * ?oi i * y"
      using nn y by (simp add: mult_nonneg_nonpos2)
    with nn show ?thesis by linarith
  next
    case pn
    with i have "0 \<le> x" "i < 0" by auto
    define j where "j = nat (-i) - 1"
    define z where "z = x - 2 * y"
    define u where "u = 2 * ?oi (nat j) * y"
    have u: "u \<ge> 0" unfolding u_def using y by auto
    have i: "i = - int (Suc j)"
      using \<open>i < 0\<close> unfolding j_def by simp
    have id: "x + 2 * ?oi i * y = z - u"
      unfolding i z_def u_def by (simp add: field_simps)
    have z: "z \<le> 0" "abs z \<ge> x" using xy y pn(1)
      unfolding z_def by auto
    show ?thesis unfolding id using pn(1) z u by simp
  next
    case np
    with i have "0 \<ge> x" "i > 0" by auto
    define j where "j = nat i - 1"
    have i: "i = int (Suc j)"
      using \<open>i > 0\<close> unfolding j_def by simp
    define u where "u = 2 * ?oi (nat j) * y"
    have u: "u \<ge> 0" unfolding u_def using y by auto
    define z where "z = - x - 2 * y"
    have id: "x + 2 * ?oi i * y = - z + u"
      unfolding i z_def u_def by (simp add: field_simps)
    have z: "z \<le> 0" "abs z \<ge> - x" using xy y np(1)
      unfolding z_def by auto
    show ?thesis unfolding id using np(1) z u by simp
  qed
qed simp

lemma abs_eq_add_2_mult: fixes y :: "'a :: linordered_idom"
  assumes abs_id: "\<bar>x\<bar> = \<bar>x + 2 * of_int i * y\<bar>"
  and xy: "- y < x" "x \<le> y"
  and i: "i \<noteq> 0"
shows "x = y \<and> i = -1"
proof -
  let ?oi = "of_int :: int \<Rightarrow> 'a"
  from xy have y: "y > 0" by auto
  consider (pp) "x \<ge> 0" "i \<ge> 0"
    | (nn) "x < 0" "i \<le> 0"
    | (pn) "x \<ge> 0" "i \<le> 0"
    | (np) "x < 0" "i \<ge> 0"
    by linarith
  hence "?thesis \<or> x = ?oi (- i) * y"
  proof cases
    case pp
    thus ?thesis using y abs_id xy i by simp
  next
    case nn
    hence "\<bar>x + 2 * ?oi i * y\<bar> =
      - (x + 2 * ?oi i * y)"
      using y nn
      by (intro abs_of_nonpos add_nonpos_nonpos,
          force, simp, intro mult_nonneg_nonpos, auto)
    thus ?thesis using y abs_id xy i nn
      by auto
  next
    case pn
    with i have "0 \<le> x" "i < 0" by auto
    define j where "j = nat (-i) - 1"
    define z where "z = x - 2 * y"
    define u where "u = 2 * ?oi (nat j) * y"
    have u: "u \<ge> 0" unfolding u_def using y by auto
    have i: "i = - int (Suc j)"
      using \<open>i < 0\<close> unfolding j_def by simp
    have id: "x + 2 * ?oi i * y = z - u"
      unfolding i z_def u_def by (simp add: field_simps)
    have z: "z \<le> 0" "abs z \<ge> x" using xy y pn(1)
      unfolding z_def by auto
    from abs_id[unfolded id] have "z - u = -x "
      using z u pn by auto
    from this[folded id] have "x = of_int (-i) * y"
      by auto
    thus ?thesis by auto
  next
    case np
    with i have "0 \<ge> x" "i > 0" by auto
    define j where "j = nat i - 1"
    have i: "i = int (Suc j)"
      using \<open>i > 0\<close> unfolding j_def by simp
    define u where "u = 2 * ?oi (nat j) * y"
    have u: "u \<ge> 0" unfolding u_def using y by auto
    define z where "z = - x - 2 * y"
    have id: "x + 2 * ?oi i * y = - z + u"
      unfolding i z_def u_def by (simp add: field_simps)
    have z: "z \<le> 0"
      using xy y np(1) unfolding z_def by auto
    from abs_id[unfolded id] have "- z + u = - x"
      using u z np by auto
    from this[folded id] have "x = of_int (- i) * y"
      by auto
    thus ?thesis by auto
  qed
  thus ?thesis
  proof
    assume "x = ?oi (- i) * y"
    with xy i y
    show ?thesis
      by (smt (verit, ccfv_SIG) less_le minus_less_iff mult_le_cancel_right2 mult_minus1_right mult_minus_left mult_of_int_commute of_int_hom.hom_one of_int_le_1_iff of_int_minus)
  qed
qed

text \<open>This is the core lemma. It tells us that @{const croot} will choose the
  principal root, i.e. the root with
  largest real part and if there are two roots with identical real part, then the largest imaginary part.
  This criterion will be crucial for implementing @{const croot}.\<close>

lemma croot_principal: assumes n: "n \<noteq> 0"
  and y: "y ^ n = x"
  and neq: "y \<noteq> croot n x"
shows "Re y < Re (croot n x) \<or> Re y = Re (croot n x) \<and> Im y < Im (croot n x)"
proof (cases "x = 0")
  case True
  with neq y have False by auto
  thus ?thesis ..
next
  case x: False
  let ?root = "croot n x"
  from n have n1: "real n \<ge> 1" "real n > 0" "real n \<noteq> 0" by auto
  from x y n have y0: "y \<noteq> 0" by auto
  from croot_power[OF n, of x] y
  have id: "?root ^ n = y ^ n" by simp
  hence "cmod (?root ^ n) = cmod (y ^ n)" by simp
  hence norm_eq: "cmod ?root = cmod y" using n unfolding norm_power
    by (meson gr_zeroI norm_ge_zero power_eq_imp_eq_base)
  have "cis (Arg y * real n) = cis (Arg (y^n))" by (subst cis_Arg_power[OF y0], simp)
  also have "\<dots> = cis (Arg x)" using y by simp
  finally have ciseq: "cis (Arg y * real n) = cis (Arg x)" by simp
  from cis_eq[OF ciseq] obtain i where
    "Arg y * real n - Arg x = 2 * real_of_int i * pi"
    by auto
  hence "Arg y * real n = Arg x + 2 * real_of_int i * pi" by auto
  from arg_cong[OF this, of "\<lambda> x. x / real n"] n1
  have Argy: "Arg y = Arg ?root + 2 * real_of_int i * pi / real n"
    by (auto simp: field_simps)
  have i0: "i \<noteq> 0"
  proof
    assume "i = 0"
    hence "Arg y = Arg ?root" unfolding Argy by simp
    with norm_eq have "?root = y" by (metis rcis_cmod_Arg)
    with neq show False by simp
  qed
  from y0 have cy0: "cmod y > 0" by auto
  from Arg_bounded[of x] have abs_pi: "abs (Arg x) \<le> pi" by auto
  have "Re y \<le> Re ?root \<longleftrightarrow> Re y / cmod y \<le> Re ?root / cmod y"
    using cy0 unfolding divide_le_cancel by simp
  also have cosy: "Re y / cmod y = cos (Arg y)" unfolding cos_arg[OF y0] ..
  also have cosrt: "Re ?root / cmod y = cos (Arg ?root)"
    unfolding norm_eq[symmetric] by (subst cos_arg, insert norm_eq cy0, auto)
  also have "cos (Arg y) \<le> cos (Arg ?root) \<longleftrightarrow> abs (Arg ?root) \<le> abs (Arg y)"
    by (rule cos_mono_le, insert Arg_bounded[of y] Arg_bounded[of ?root], auto)
  also have "\<dots> \<longleftrightarrow> abs (Arg ?root) * real n \<le> abs (Arg y) * real n"
    unfolding mult_le_cancel_right using n1 by simp
  also have "\<dots> \<longleftrightarrow> abs (Arg x) \<le> \<bar>Arg x + 2 * real_of_int i * pi\<bar>"
    unfolding Argy using n1 by (simp add: field_simps)
  also have "\<dots>" using abs_pi
    by (rule abs_add_2_mult_bound)
  finally have le: "Re y \<le> Re (croot n x)" .
  show ?thesis
  proof (cases "Re y = Re (croot n x)")
    case False
    with le show ?thesis by auto
  next
    case True
    hence "Re y / cmod y = Re ?root / cmod y" by simp
    hence "cos (Arg y) = cos (Arg ?root)" unfolding cosy cosrt .
    hence "cos (abs (Arg y)) = cos (abs (Arg ?root))" unfolding cos_abs .
    from cos_inj_pi[OF _ _ _ _ this]
    have "abs (Arg y) = abs (Arg ?root)"
      using Arg_bounded[of y] Arg_bounded[of ?root] by auto
    hence "abs (Arg y) * real n = abs (Arg ?root) * real n" by simp
    hence "abs (Arg x) = \<bar>Arg x + 2 * real_of_int i * pi\<bar>" unfolding Argy
      using n1 by (simp add: field_simps)
    from abs_eq_add_2_mult[OF this _ _ \<open>i \<noteq> 0\<close>] Arg_bounded[of x]
    have Argx: "Arg x = pi" and i: "i = -1" by auto
    have Argy: "Arg y = -pi / real n"
      unfolding Argy Arg_croot i Argx by simp
    have "Im ?root > Im y \<longleftrightarrow> Im ?root / cmod ?root > Im y / cmod y"
      unfolding norm_eq using cy0
      by (meson divide_less_cancel divide_strict_right_mono)
    also have "\<dots> \<longleftrightarrow> sin (Arg ?root) > sin (Arg y)"
      by (subst (1 2) sin_arg, insert y0 norm_eq, auto)
    also have "\<dots> \<longleftrightarrow> sin (- pi / real n) < sin (pi / real n)"
      unfolding Argy Arg_croot Argx by simp
    also have \<dots>
    proof -
      have "sin (- pi / real n) < 0"
        using n1 by (smt (verit) Arg_bounded Argy divide_neg_pos sin_gt_zero sin_minus)
      also have "\<dots> < sin (pi / real n)"
        using n1 calculation by fastforce
      finally show ?thesis .
    qed
    finally show ?thesis using le by auto
  qed
qed

lemma croot_unique: assumes n: "n \<noteq> 0"
  and y: "y ^ n = x"
  and y_max_Re_Im: "\<And> z. z ^ n = x \<Longrightarrow>
      Re z < Re y \<or> Re z = Re y \<and> Im z \<le> Im y"
shows "croot n x = y"
proof (rule ccontr)
  assume "croot n x \<noteq> y"
  from croot_principal[OF n y this[symmetric]]
  have "Re y < Re (croot n x) \<or>
    Re y = Re (croot n x) \<and> Im y < Im (croot n x)" .
  with y_max_Re_Im[OF croot_power[OF n]]
  show False by auto
qed

lemma csqrt_is_croot_2: "csqrt = croot 2"
proof
  fix x
  show "csqrt x = croot 2 x"
  proof (rule sym, rule croot_unique, force, force)
    let ?p = "[:-x,0,1:]"
    let ?cx = "csqrt x"
    have p: "?p = [:?cx,1:] * [:-?cx,1:]"
      by (simp add: power2_eq_square[symmetric])
    fix y
    assume "y^2 = x"
    hence "True \<longleftrightarrow> poly ?p y = 0"
      by (auto simp: power2_eq_square)
    also have "\<dots> \<longleftrightarrow> y = - ?cx \<or> y = ?cx"
      unfolding p poly_mult mult_eq_0_iff poly_root_factor by auto
    finally have "y = - ?cx \<or> y = ?cx" by simp
    thus "Re y < Re ?cx \<or> Re y = Re ?cx \<and> Im y \<le> Im ?cx"
    proof
      assume y: "y = - ?cx"
      show ?thesis
      proof (cases "Re ?cx = 0")
        case False
        with csqrt_principal[of x] have "Re ?cx > 0" by simp
        thus ?thesis unfolding y by simp
      next
        case True
        with csqrt_principal[of x] have "Im ?cx \<ge> 0" by simp
        thus ?thesis unfolding y using True by auto
      qed
    qed auto
  qed
qed

lemma croot_via_root_selection: assumes roots: "set ys = { y. y^n = x}"
  and n: "n \<noteq> 0"
shows "croot n x = arg_min_list (\<lambda> y. (- Re y, - Im y)) ys"
  (is "_ = arg_min_list ?f ys")
proof (rule croot_unique[OF n])
  let ?y = "arg_min_list ?f ys"
  have rt: "croot n x ^ n = x" using n by (rule croot_power)
  hence "croot n x \<in> set ys" unfolding roots by auto
  hence ys: "ys \<noteq> []" by auto
  from arg_min_list_in[OF this] have "?y \<in> set ys" by auto
  from this[unfolded roots]
  show "?y^n = x" by auto
  fix z
  assume "z^n = x"
  hence z: "z \<in> set ys" unfolding roots by auto
  from f_arg_min_list_f[OF ys, of ?f] z
  have "?f ?y \<le> ?f z" by simp
  thus "Re z < Re ?y \<or> Re z = Re ?y \<and> Im z \<le> Im ?y" by auto
qed

lemma croot_impl[code]: "croot n x = (if n = 0 then 0 else
  arg_min_list (\<lambda> y. (- Re y, - Im y)) (all_croots n x))"
proof (cases "n = 0")
  case n0: False
  hence id: "(if n = 0 then y else z) = z"
    for y z u :: complex by auto
  show ?thesis unfolding id Let_def
    by (rule croot_via_root_selection[OF _ n0], rule all_croots[OF n0])
qed auto

end


(*
    File:      Partial_Summation.thy
    Author:    Manuel Eberl, TU München

    The partial summation rule as given by Apostol in "Introduction to Analytic Number Theory"
*)
section \<open>Partial summation\<close>
theory Partial_Summation
  imports
    "HOL-Analysis.Analysis"
    Arithmetic_Summatory
begin

lemma finite_vimage_real_of_nat_greaterThanAtMost: "finite (real -` {y<..x})"
proof (rule finite_subset)
  show "real -` {y<..x} \<subseteq> {nat \<lfloor>y\<rfloor>..nat \<lceil>x\<rceil>}"
    by (cases "x \<ge> 0"; cases "y \<ge> 0")
        (auto simp: nat_le_iff le_nat_iff le_ceiling_iff floor_le_iff)
qed auto

context
  fixes a :: "nat \<Rightarrow> 'a :: {banach, real_normed_algebra}"
  fixes f f' :: "real \<Rightarrow> 'a"
  fixes A
  fixes X :: "real set"
  fixes x y :: real
  defines "A \<equiv> sum_upto a"
  assumes fin: "finite X"
  assumes xy: "0 \<le> y" "y < x"
  assumes deriv: "\<And>z. z \<in> {y..x} - X \<Longrightarrow> (f has_vector_derivative f' z) (at z)"
  assumes cont_f: "continuous_on {y..x} f"
begin

lemma partial_summation_strong:
  "((\<lambda>t. A t * f' t) has_integral
       (A x * f x - A y * f y - (\<Sum>n \<in> real -` {y<..x}. a n * f n))) {y..x}"
proof -
  define chi :: "nat \<Rightarrow> real \<Rightarrow> real" where "chi = (\<lambda>n t. if n \<le> t then 1 else 0)"
  have "((\<lambda>t. sum_upto (\<lambda>n. a n * (chi n t *\<^sub>R f' t)) x) has_integral
          (sum_upto (\<lambda>n. a n * (f x - f (max n y))) x)) {y..x}" (is "(_ has_integral ?I) _")
    unfolding sum_upto_def
  proof (intro has_integral_sum ballI finite_Nats_le_real, goal_cases)
    case (1 n)
    have "(f' has_integral (f x - f (max n y))) {max n y..x}"
      using xy 1
      by (intro fundamental_theorem_of_calculus_strong[OF fin])
         (auto intro!: continuous_on_subset[OF cont_f] deriv)
    also have "?this \<longleftrightarrow> ((\<lambda>t. (if t \<in> {max n y..x} then 1 else 0) *\<^sub>R f' t)
                  has_integral (f x - f (max n y))) {max n y..x}"
      by (intro has_integral_cong) (simp_all add: chi_def)
    finally have "((\<lambda>t. (if t \<in> {max n y..x} then 1 else 0) *\<^sub>R f' t)
                     has_integral (f x - f (max n y))) {y..x}"
      by (rule has_integral_on_superset) auto
    also have "?this \<longleftrightarrow> ((\<lambda>t. chi n t *\<^sub>R f' t) has_integral (f x - f (max n y))) {y..x}"
      by (intro has_integral_cong) (auto simp: chi_def)
    finally show ?case by (intro has_integral_mult_right)
  qed
  also have "?this \<longleftrightarrow> ((\<lambda>t. A t * f' t) has_integral ?I) {y..x}"
    unfolding sum_upto_def A_def chi_def sum_distrib_right using xy
    by (intro has_integral_cong sum.mono_neutral_cong_right finite_Nats_le_real) auto
  also have "sum_upto (\<lambda>n. a n * (f x - f (max (real n) y))) x =
               A x * f x - (\<Sum>n | n > 0 \<and> real n \<le> x.  a n * f (max (real n) y))"
    by (simp add: sum_upto_def ring_distribs sum_subtractf sum_distrib_right A_def)
  also have "{n. n > 0 \<and> real n \<le> x} = {n. n > 0 \<and> real n \<le> y} \<union> real -` {y<..x}"
    using xy by auto
  also have "sum (\<lambda>n. a n * f (max (real n) y)) \<dots> =
               (\<Sum>n | 0 < n \<and> real n \<le> y. a n * f (max (real n) y)) +
               (\<Sum>n \<in> real -` {y<..x}. a n * f (max (real n) y))" (is "_ = ?S1 + ?S2")
    by (intro sum.union_disjoint finite_Nats_le_real finite_vimage_real_of_nat_greaterThanAtMost)
       auto
  also have "?S1 = sum_upto (\<lambda>n. a n * f y) y" unfolding sum_upto_def
    by (intro sum.cong refl) (auto simp: max_def)
  also have "\<dots> = A y * f y" by (simp add: A_def sum_upto_def sum_distrib_right)
  also have "?S2 = (\<Sum>n \<in> real -` {y<..x}. a n * f n)"
    by (intro sum.cong refl) (auto simp: max_def)
  finally show ?thesis by (simp add: algebra_simps)
qed

lemma partial_summation_integrable_strong:
        "(\<lambda>t. A t * f' t) integrable_on {y..x}"
  and partial_summation_strong':
        "(\<Sum>n\<in>real -` {y<..x}. a n * f n) =
            A x * f x - A y * f y - integral {y..x} (\<lambda>t. A t * f' t)"
  using partial_summation_strong by (simp_all add: has_integral_iff algebra_simps)

end

context
  fixes a :: "nat \<Rightarrow> 'a :: {banach, real_normed_algebra}"
  fixes f f' :: "real \<Rightarrow> 'a"
  fixes A
  fixes X :: "real set"
  fixes x :: real
  defines "A \<equiv> sum_upto a"
  assumes fin: "finite X"
  assumes x: "x > 0"
  assumes deriv: "\<And>z. z \<in> {0..x} - X \<Longrightarrow> (f has_vector_derivative f' z) (at z)"
  assumes cont_f: "continuous_on {0..x} f"
begin

lemma partial_summation_sum_upto_strong:
  "((\<lambda>t. A t * f' t) has_integral (A x * f x - sum_upto (\<lambda>n. a n * f n) x)) {0..x}"
proof -
  have "(\<Sum>n\<in>real -` {0<..x}. a n * f n) = sum_upto (\<lambda>n. a n * f n) x"
    unfolding sum_upto_def by (intro sum.cong refl) auto
  thus ?thesis
  using partial_summation_strong[OF fin order.refl x deriv cont_f, of a]
  by (simp_all add: A_def)
qed

lemma partial_summation_integrable_sum_upto_strong:
        "(\<lambda>t. A t * f' t) integrable_on {0..x}"
  and partial_summation_sum_upto_strong':
        "sum_upto (\<lambda>n. a n * f n) x =
            A x * f x - integral {0..x} (\<lambda>t. A t * f' t)"
  using partial_summation_sum_upto_strong by (simp_all add: has_integral_iff algebra_simps)

end

end


theory Tut09
  imports "HOL-IMP.Hoare_Sound_Complete"
begin

paragraph "Step 1"

definition Max :: "com"  where
  "Max = IF Less (V ''a'') (V ''b'') THEN ''c'' ::= V ''b'' ELSE ''c'' ::= V ''a''"

paragraph "Step 2"

lemma max_right[simp]: "(a::int)<b \<Longrightarrow> max a b = b"
  by simp

lemma max_left[simp]: "\<not>(a::int)<b \<Longrightarrow> max a b = a"
  by simp

lemma "\<turnstile> {\<lambda>s. True} Max {\<lambda>s. s ''c'' = max (s ''a'') (s ''b'')}"
  unfolding Max_def by(rule If Assign' | simp)+

paragraph "Step 3"

definition MUL :: "com"  where
  "MUL =
    ''z'' ::= N 0;;
  ''i'' ::= N 0;;
  WHILE Less (V ''i'') (V ''y'') DO
  (
    ''z'' ::= Plus (V ''z'') (V ''x'');;
    ''i'' ::= Plus (V ''i'') (N 1)
  )"

paragraph "Step 4"

lemmas Seq_bwd = Seq[rotated]

lemma "\<turnstile> {\<lambda>s. 0 \<le> s ''y''} MUL {\<lambda>s. s ''z'' = s ''x'' * s ''y''}"
  unfolding MUL_def
  by(rule Seq_bwd Assign Assign'
      While'[where P="\<lambda>s. s ''z'' = s ''i'' * s ''x'' \<and> s ''i'' \<le> s ''y''"]
      | auto simp: algebra_simps)+

lemmas hoare_rule[intro?] = Seq_bwd Assign Assign' If

paragraph "Step 5"

definition "MAX_wrong = (''a''::=N 0;;''b''::=N 0;;''c''::= N 0)"

lemma "\<turnstile> {\<lambda>s. True} MAX_wrong {\<lambda>s. s ''c'' = max (s ''a'') (s ''b'')}"
  unfolding MAX_wrong_def by(rule Seq_bwd Assign Assign' | simp)+

lemma "\<turnstile> {\<lambda>s. a=s ''a'' \<and> b=s ''b''}
  Max {\<lambda>s. s ''c'' = max a b \<and> a = s ''a'' \<and> b = s ''b''}"
  unfolding Max_def by(rule If Assign' | simp)+

lemma "\<turnstile> {\<lambda>s. 0 \<le> s ''y'' \<and> x = s ''x'' \<and> y = s ''y''} MUL {\<lambda>s. s ''z'' = x * y \<and> s ''x'' = x \<and> s ''y'' = y}"
  unfolding MUL_def by(rule Seq_bwd Assign Assign'
      While'[where P="\<lambda>s. s ''z'' = s ''i'' * s ''x'' \<and> s ''i'' \<le> s ''y'' \<and> x = s ''x'' \<and> y = s ''y''"]
      | auto simp: algebra_simps)+

lemma fwd_Assign: "\<turnstile> {P} x::=a {\<lambda>s. \<exists>s'. P s' \<and> s'[a/x] = s}"
  apply(rule hoare_complete)
  unfolding hoare_valid_def by auto

lemmas fwd_Assign' = weaken_post[OF fwd_Assign]

lemma "\<turnstile> {\<lambda>s. True} Max {\<lambda>s. s ''c'' = max (s ''a'') (s ''b'')}"
  sorry

lemma "\<turnstile> {\<lambda>s. 0 \<le> s ''y''} MUL {\<lambda>s. s ''z'' = s ''x'' * s ''y''}"
  sorry

end


theory Chap3_1
imports Main
begin

type_synonym vname = string

datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n"
| "aval (V v) s = s v"
| "aval (Plus e1 e2) s = aval e1 s + aval e2 s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>_. 0)"

value "aval (Plus (Plus (N 3) (V ''x'')) (V ''y'')) (((\<lambda>_. 0)(''x'' := 1))(''y'' := 2))"

value "aval (Plus (Plus (N 3) (V ''x'')) (V ''y'')) <''x'' := 1, ''y'' := 2>"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n"
| "asimp_const (V x) = V x"
| "asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
    (N n1, N n2) \<Rightarrow> N (n1 + n2)
    | (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  apply (induction a)
  by (auto split: aexp.split)

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N (i1 + i2)"
| "plus (N i) a = (if i=0 then a else Plus (N i) a)"
| "plus a (N i) = (if i=0 then a else Plus a (N i))"
| "plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction rule: plus.induct)
  by auto

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n"
| "asimp (V x) = V x"
| "asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
  apply (induction a)
  by (auto simp add: aval_plus)

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N n) = True"
| "optimal (V x) = True"
| "optimal (Plus a1 a2) =
  (case (a1, a2) of
    (N _, N _) \<Rightarrow> False
    | _ \<Rightarrow> optimal a1 \<and> optimal a2)"

lemma "optimal (asimp_const a)"
  apply (induction a)
    apply simp+
  apply (case_tac "asimp_const a1")
    apply simp_all
  apply (case_tac "asimp_const a2")
  by simp+

fun nplus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"nplus (N n1) (N n2) = N (n1 + n2)"
| "nplus (N n1) (Plus a (N n2)) = Plus a (N (n1 + n2))"
| "nplus (N n) a = Plus a (N n)"
| "nplus (Plus a (N n1)) (N n2) = Plus a (N (n1 + n2))"
| "nplus (Plus a1 (N n1)) (Plus a2 (N n2)) = Plus (Plus a1 a2) (N (n1 + n2))"
| "nplus (Plus a1 (N n)) a2 = Plus (Plus a1 a2) (N n)"
| "nplus a1 (Plus a2 (N n)) = Plus (Plus a1 a2) (N n)"
| "nplus a1 a2 = Plus a1 a2"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N n) = N n"
| "full_asimp (V x) = V x"
| "full_asimp (Plus a1 a2) = nplus (full_asimp a1) (full_asimp a2)"

lemma "full_asimp (Plus (N 1) (Plus (V x) (N 2))) = Plus (V x) (N 3)"
  by simp

fun without_N :: "aexp \<Rightarrow> bool" where
"without_N (N _) = False"
| "without_N (V _) = True"
| "without_N (Plus a1 a2) = (without_N a1 \<and> without_N a2)"

fun in_normal_form :: "aexp \<Rightarrow> bool" where
"in_normal_form (N _) = True"
| "in_normal_form (V _) = True"
| "in_normal_form (Plus a1 a2) = (without_N a1 \<and> (without_N a2 \<or> (\<exists>n. a2 = N n)))"

lemma nplus_normal:
  "\<lbrakk> in_normal_form a1; in_normal_form a2 \<rbrakk> \<Longrightarrow> in_normal_form (nplus a1 a2)"
  apply (cases "(a1, a2)" rule: nplus.cases)
  by auto

lemma "in_normal_form (full_asimp a)"
  apply (induction a)
    apply simp+
  using nplus_normal by blast

lemma "aval (full_asimp a) s = aval a s"
  apply (induction a)
    apply simp+
  apply (case_tac "(full_asimp a1, full_asimp a2)" rule: nplus.cases)
  by auto

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = (N n)"
| "subst x a (V y) = (if x = y then a else V y)"
| "subst x a (Plus a1 a2) = Plus (subst x a a1) (subst x a a2)"

lemma subst_comm: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply (induction e)
  by simp+

lemma "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply (induction e)
  (*using [[simp_trace]]*)
  by simp+

datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | PostInc aexp2 | Div aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val * state) option" where
"aval2 (N2 n) s = Some (n, s)"
| "aval2 (V2 x) s = Some (s x, s)"
| "aval2 (Plus2 a1 a2) s =
  (case aval2 a1 s of
    None \<Rightarrow> None
    | Some (v1, s') \<Rightarrow>
      (case aval2 a2 s' of
        None \<Rightarrow> None
        | Some (v2, s'') \<Rightarrow> Some (v1 + v2, s'')
      )
  )"
| "aval2 (PostInc (V2 x)) s = Some (s x, s(x := (s x)+1))"
| "aval2 (Div a1 a2) s =
  (case aval2 a1 s of
    None \<Rightarrow> None
    | Some (v1, s') \<Rightarrow>
      (case aval2 a2 s' of
        None \<Rightarrow> None
        | Some (v2, s'') \<Rightarrow> if v2=0 then None else Some (v1 div v2, s'')
      )
  )"

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl n) _ = n"
| "lval (Vl x) s = s x"
| "lval (Plusl a1 a2) s = lval a1 s + lval a2 s"
| "lval (LET x a e) s = lval e (s(x := lval a s))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n) = N n"
| "inline (Vl x) = V x"
| "inline (Plusl a1 a2) = Plus (inline a1) (inline a2)"
| "inline (LET x a e) = subst x (inline a) (inline e)"

value "inline (LET ''x'' (Vl ''y'') (LET ''y'' (Nl 0) (Vl ''x'')))"

lemma "aval (inline e) s = lval e s"
  apply (induction e arbitrary: s)
     apply simp+
  using subst_comm by presburger

end


(* Author: Tobias Nipkow *)

subsection \<open>Soundness and Completeness\<close>

theory Hoare_Sound_Complete
imports Hoare
begin

subsubsection "Soundness"

lemma hoare_sound: "\<turnstile> {P}c{Q}  \<Longrightarrow>  \<Turnstile> {P}c{Q}"
proof(induction rule: hoare.induct)
  case (While P b c)
  { fix s t
    have "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow>  P s  \<Longrightarrow>  P t \<and> \<not> bval b t"
    proof(induction "WHILE b DO c" s t rule: big_step_induct)
      case WhileFalse thus ?case by blast
    next
      case WhileTrue thus ?case
        using While.IH unfolding hoare_valid_def by blast
    qed
  }
  thus ?case unfolding hoare_valid_def by blast
qed (auto simp: hoare_valid_def)

subsubsection "Weakest Precondition"

definition wp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
"wp c Q = (\<lambda>s. \<forall>t. (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"

lemma wp_SKIP[simp]: "wp SKIP Q = Q"
by (rule ext) (auto simp: wp_def)

lemma wp_Ass[simp]: "wp (x::=a) Q = (\<lambda>s. Q(s[a/x]))"
by (rule ext) (auto simp: wp_def)

lemma wp_Seq[simp]: "wp (c\<^sub>1;;c\<^sub>2) Q = wp c\<^sub>1 (wp c\<^sub>2 Q)"
by (rule ext) (auto simp: wp_def)

lemma wp_If[simp]:
 "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q =
 (\<lambda>s. if bval b s then wp c\<^sub>1 Q s else wp c\<^sub>2 Q s)"
by (rule ext) (auto simp: wp_def)

lemma wp_While_If:
 "wp (WHILE b DO c) Q s =
  wp (IF b THEN c;;WHILE b DO c ELSE SKIP) Q s"
unfolding wp_def by (metis unfold_while)

lemma wp_While_True[simp]: "bval b s \<Longrightarrow>
  wp (WHILE b DO c) Q s = wp (c;; WHILE b DO c) Q s"
by(simp add: wp_While_If)

lemma wp_While_False[simp]: "\<not> bval b s \<Longrightarrow> wp (WHILE b DO c) Q s = Q s"
by(simp add: wp_While_If)

subsubsection "Completeness"

lemma wp_is_pre: "\<turnstile> {wp c Q} c {Q}"
proof(induction c arbitrary: Q)
  case If thus ?case by(auto intro: conseq)
next
  case (While b c)
  let ?w = "WHILE b DO c"
  show "\<turnstile> {wp ?w Q} ?w {Q}"
  proof(rule While')
    show "\<turnstile> {\<lambda>s. wp ?w Q s \<and> bval b s} c {wp ?w Q}"
    proof(rule strengthen_pre[OF _ While.IH])
      show "\<forall>s. wp ?w Q s \<and> bval b s \<longrightarrow> wp c (wp ?w Q) s" by auto
    qed
    show "\<forall>s. wp ?w Q s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
  qed
qed auto

lemma hoare_complete: assumes "\<Turnstile> {P}c{Q}" shows "\<turnstile> {P}c{Q}"
proof(rule strengthen_pre)
  show "\<forall>s. P s \<longrightarrow> wp c Q s" using assms
    by (auto simp: hoare_valid_def wp_def)
  show "\<turnstile> {wp c Q} c {Q}" by(rule wp_is_pre)
qed

corollary hoare_sound_complete: "\<turnstile> {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q}"
by (metis hoare_complete hoare_sound)

end


section \<open>Auxiliary Lemmas\<close>

(*<*)
theory Auxiliary
  imports
    "HOL-Library.Multiset"
    "Nested_Multisets_Ordinals.Signed_Multiset"
    "HOL-Library.Linear_Temporal_Logic_on_Streams"
begin
(*>*)

unbundle multiset.lifting

subsection\<open>General\<close>

lemma sum_list_hd_tl:
  fixes xs :: "(_ :: group_add) list"
  shows "xs \<noteq> [] \<Longrightarrow> sum_list (tl xs) = (- hd xs) + sum_list xs"
  by (cases xs) simp_all

lemma finite_distinct_bounded: "finite A \<Longrightarrow> finite {xs. distinct xs \<and> set xs \<subseteq> A}"
  apply (rule finite_subset[of _ "\<Union>n \<in> {0 .. card A}. {xs.  length xs = n \<and> distinct xs \<and> set xs \<subseteq> A}"])
  subgoal by clarsimp (metis card_mono distinct_card)
  subgoal by auto
  done

subsection\<open>Sums\<close>

lemma Sum_eq_pick_changed_elem:
  assumes "finite M"
    and "m \<in> M" "f m = g m + \<Delta>"
    and "\<And>n. n \<noteq> m \<and> n \<in> M \<Longrightarrow> f n = g n"
  shows "(\<Sum>x\<in>M. f x) = (\<Sum>x\<in>M. g x) + \<Delta>"
  using assms
proof (induct M arbitrary: m rule: finite_induct)
  case empty
  then show ?case by simp
next
  case (insert x F)
  then show ?case
  proof (cases "x=m")
    case True
    with insert have "sum f F = sum g F"
      by (intro sum.cong[OF refl]) force
    with insert True show ?thesis
      by (auto simp: add.commute add.left_commute)
  next
    case False
    with insert show ?thesis
      by (auto simp: add.assoc)
  qed
qed

lemma sum_pos_ex_elem_pos: "(0::int) < (\<Sum>m\<in>M. f m) \<Longrightarrow> \<exists>m\<in>M. 0 < f m"
  by (meson not_le sum_nonpos)

lemma sum_if_distrib_add: "finite A \<Longrightarrow> b \<in> A \<Longrightarrow> (\<Sum>a\<in>A. if a=b then X b + Y a else X a) = (\<Sum>a\<in>A. X a) + Y b"
  by (simp add: Sum_eq_pick_changed_elem)

subsection\<open>Partial Orders\<close>

lemma (in order) order_finite_set_exists_foundation:
  fixes   t :: 'a
  assumes "finite M"
    and   "t \<in> M"
  shows   "\<exists>s\<in>M. s \<le> t \<and> (\<forall>u\<in>M. \<not> u < s)"
  using assms
  by (simp add: dual_order.strict_iff_order finite_has_minimal2)

lemma order_finite_set_obtain_foundation:
  fixes   t :: "_ :: order"
  assumes "finite M"
    and   "t \<in> M"
  obtains s where "s \<in> M" "s \<le> t" "\<forall>u\<in>M. \<not> u < s"
  using assms order_finite_set_exists_foundation by blast

subsection\<open>Multisets\<close>

lemma finite_nonzero_count: "finite {t. count M t > 0}"
  using count by auto

lemma finite_count[simp]: "finite {t. count M t > i}"
  by (rule finite_subset[OF _ finite_nonzero_count[of M]]) (auto simp only: set_mset_def)

subsection\<open>Signed Multisets\<close>

lemma zcount_zmset_of_nonneg[simp]: "0 \<le> zcount (zmset_of M) t"
  by simp

lemma finite_zcount_pos[simp]: "finite {t. zcount M t > 0}"
  apply transfer
  subgoal for M
    apply (rule finite_subset[OF _ finite_Un[THEN iffD2, OF conjI[OF finite_nonzero_count finite_nonzero_count]], of _ "fst M" "snd M"])
    apply (auto simp only: set_mset_def fst_conv snd_conv split: prod.splits)
    done
  done

lemma finite_zcount_neg[simp]: "finite {t. zcount M t < 0}"
  apply transfer
  subgoal for M
    apply (rule finite_subset[OF _ finite_Un[THEN iffD2, OF conjI[OF finite_nonzero_count finite_nonzero_count]], of _ "fst M" "snd M"])
    apply (auto simp only: set_mset_def fst_conv snd_conv split: prod.splits)
    done
  done

lemma pos_zcount_in_zmset: "0 < zcount M x \<Longrightarrow> x \<in>#\<^sub>z M"
  by (simp add: zcount_inI)

lemma zmset_elem_nonneg: "x \<in>#\<^sub>z M \<Longrightarrow> (\<And>x. x \<in>#\<^sub>z M \<Longrightarrow> 0 \<le> zcount M x) \<Longrightarrow> 0 < zcount M x"
  by (simp add: order.order_iff_strict zcount_eq_zero_iff)

lemma zero_le_sum_single: "0 \<le> zcount (\<Sum>x\<in>M. {#f x#}\<^sub>z) t"
  by (induct M rule: infinite_finite_induct) auto

lemma mem_zmset_of[simp]: "x \<in>#\<^sub>z zmset_of M \<longleftrightarrow> x \<in># M"
  by (simp add: set_zmset_def)

lemma mset_neg_minus: "mset_neg (abs_zmultiset (Mp,Mn)) = Mn-Mp"
  by (simp add: mset_neg.abs_eq)

lemma mset_pos_minus: "mset_pos (abs_zmultiset (Mp,Mn)) = Mp-Mn"
  by (simp add: mset_pos.abs_eq)

lemma mset_neg_sum_set: "(\<And>m. m \<in> M \<Longrightarrow> mset_neg (f m) = {#}) \<Longrightarrow> mset_neg (\<Sum>m\<in>M. f m) = {#}"
  by (induct M rule: infinite_finite_induct) auto

lemma mset_neg_empty_iff: "mset_neg M = {#} \<longleftrightarrow> (\<forall>t. 0 \<le> zcount M t)"
  apply rule
  subgoal
    by (metis add.commute add.right_neutral mset_pos_as_neg zcount_zmset_of_nonneg zmset_of_empty)
  subgoal
    apply (induct rule: zmultiset.abs_induct)
    subgoal for y
      apply (induct y)
      apply (subst mset_neg_minus)
      apply transfer'
      apply (simp add: Diff_eq_empty_iff_mset mset_subset_eqI)
      done
    done
  done

lemma mset_neg_zcount_nonneg: "mset_neg M = {#} \<Longrightarrow> 0 \<le> zcount M t"
  by (subst (asm) mset_neg_empty_iff) simp

lemma in_zmset_conv_pos_neg_disj: "x \<in>#\<^sub>z M \<longleftrightarrow> x \<in># mset_pos M \<or> x \<in># mset_neg M"
  by (metis count_mset_pos in_diff_zcount mem_zmset_of mset_pos_neg_partition nat_code(2) not_in_iff zcount_ne_zero_iff)

lemma in_zmset_notin_mset_pos[simp]: "x \<in>#\<^sub>z M \<Longrightarrow> x \<notin># mset_pos M \<Longrightarrow> x \<in># mset_neg M"
  by (auto simp: in_zmset_conv_pos_neg_disj)

lemma in_zmset_notin_mset_neg[simp]: "x \<in>#\<^sub>z M \<Longrightarrow> x \<notin># mset_neg M \<Longrightarrow> x \<in># mset_pos M"
  by (auto simp: in_zmset_conv_pos_neg_disj)

lemma in_mset_pos_in_zmset: "x \<in># mset_pos M \<Longrightarrow> x \<in>#\<^sub>z M"
  by (auto intro: iffD2[OF in_zmset_conv_pos_neg_disj])

lemma in_mset_neg_in_zmset: "x \<in># mset_neg M \<Longrightarrow> x \<in>#\<^sub>z M"
  by (auto intro: iffD2[OF in_zmset_conv_pos_neg_disj])

lemma set_zmset_eq_set_mset_union: "set_zmset M = set_mset (mset_pos M) \<union> set_mset (mset_neg M)"
  by (auto dest: in_mset_pos_in_zmset in_mset_neg_in_zmset)

lemma member_mset_pos_iff_zcount: "x \<in># mset_pos M \<longleftrightarrow> 0 < zcount M x"
  using not_in_iff pos_zcount_in_zmset by force

lemma member_mset_neg_iff_zcount: "x \<in># mset_neg M \<longleftrightarrow> zcount M x < 0"
  by (metis member_mset_pos_iff_zcount mset_pos_uminus neg_le_0_iff_le not_le zcount_uminus)

lemma mset_pos_mset_neg_disjoint[simp]: "set_mset (mset_pos \<Delta>) \<inter> set_mset (mset_neg \<Delta>) = {}"
  by (auto simp: member_mset_pos_iff_zcount member_mset_neg_iff_zcount)

lemma zcount_sum: "zcount (\<Sum>M\<in>MM. f M) t = (\<Sum>M\<in>MM. zcount (f M) t)"
  by (induct MM rule: infinite_finite_induct) auto

lemma zcount_filter_invariant: "zcount {# t'\<in>#\<^sub>zM. t'=t #} t = zcount M t"
  by auto

lemma in_filter_zmset_in_zmset[simp]: "x \<in>#\<^sub>z filter_zmset P M \<Longrightarrow> x \<in>#\<^sub>z M"
  by (metis count_filter_zmset zcount_ne_zero_iff)

lemma pos_filter_zmset_pos_zmset[simp]: "0 < zcount (filter_zmset P M) x \<Longrightarrow> 0 < zcount M x"
  by (metis (full_types) count_filter_zmset less_irrefl)

lemma neg_filter_zmset_neg_zmset[simp]: "0 > zcount (filter_zmset P M) x \<Longrightarrow> 0 > zcount M x"
  by (metis (full_types) count_filter_zmset less_irrefl)

lift_definition update_zmultiset :: "'t zmultiset \<Rightarrow> 't \<Rightarrow> int \<Rightarrow> 't zmultiset" is
  "\<lambda>(A,B) T D.(if D>0 then (A + replicate_mset (nat D) T, B)
                    else (A,B + replicate_mset (nat (-D)) T))"
  by (auto simp: equiv_zmset_def if_split)

lemma zcount_update_zmultiset: "zcount (update_zmultiset M t n) t' = zcount M t' + (if t = t' then n else 0)"
  by transfer auto

lemma (in order) order_zmset_exists_foundation:
  fixes   t :: 'a
  assumes "0 < zcount M t"
  shows   "\<exists>s. s \<le> t \<and> 0 < zcount M s \<and> (\<forall>u. 0 < zcount M u \<longrightarrow> \<not> u < s)"
  using assms
proof -
  let ?M = "{t. 0 < zcount M t}"
  from assms have "t \<in> ?M"
    by simp
  then have "\<exists>s\<in>?M. s \<le> t \<and> (\<forall>u\<in>?M. \<not> u < s)"
    by - (drule order_finite_set_exists_foundation[rotated 1], auto)
  then show ?thesis by auto
qed

lemma (in order) order_zmset_exists_foundation':
  fixes   t :: 'a
  assumes "0 < zcount M t"
  shows   "\<exists>s. s \<le> t \<and> 0 < zcount M s \<and> (\<forall>u<s. zcount M u \<le> 0)"
  using assms order_zmset_exists_foundation
  by (meson le_less_linear)

lemma (in order) order_zmset_exists_foundation_neg:
  fixes   t :: 'a
  assumes "zcount M t < 0"
  shows   "\<exists>s. s \<le> t \<and> zcount M s < 0 \<and> (\<forall>u. zcount M u < 0 \<longrightarrow> \<not> u < s)"
  using assms
proof -
  let ?M = "{t. zcount M t < 0}"
  from assms have "t \<in> ?M"
    by simp
  then have "\<exists>s\<in>?M. s \<le> t \<and> (\<forall>u\<in>?M. \<not> u < s)"
    by - (drule order_finite_set_exists_foundation[rotated 1], auto)
  then show ?thesis by auto
qed

lemma (in order) order_zmset_exists_foundation_neg':
  fixes   t :: 'a
  assumes "zcount M t < 0"
  shows   "\<exists>s. s \<le> t \<and> zcount M s < 0 \<and> (\<forall>u<s. 0 \<le> zcount M u)"
  using assms order_zmset_exists_foundation_neg
  by (meson le_less_linear)

lemma (in order) elem_order_zmset_exists_foundation:
  fixes x :: 'a
  assumes "x \<in>#\<^sub>z M"
  shows   "\<exists>s\<in>#\<^sub>zM. s \<le> x \<and> (\<forall>u\<in>#\<^sub>zM. \<not> u < s)"
  by (rule order_finite_set_exists_foundation[OF finite_set_zmset, OF assms(1)])

subsubsection\<open>Image of a Signed Multiset\<close>

lift_definition image_zmset :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a zmultiset \<Rightarrow> 'b zmultiset" is
  "\<lambda>f (M, N). (image_mset f M, image_mset f N)"
  by (auto simp: equiv_zmset_def simp flip: image_mset_union)

syntax (ASCII)
  "_comprehension_zmset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b zmultiset \<Rightarrow> 'a zmultiset"  ("({#_/. _ :#z _#})")
syntax
  "_comprehension_zmset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b zmultiset \<Rightarrow> 'a zmultiset"  ("({#_/. _ \<in>#\<^sub>z _#})")
translations
  "{#e. x \<in>#\<^sub>z M#}" \<rightleftharpoons> "CONST image_zmset (\<lambda>x. e) M"

lemma image_zmset_empty[simp]: "image_zmset f {#}\<^sub>z = {#}\<^sub>z"
  by transfer (auto simp: equiv_zmset_def)

lemma image_zmset_single[simp]: "image_zmset f {#x#}\<^sub>z = {#f x#}\<^sub>z"
  by transfer (simp add: equiv_zmset_def)

lemma image_zmset_union[simp]: "image_zmset f (M + N) = image_zmset f M + image_zmset f N"
  by transfer (auto simp: equiv_zmset_def)

lemma image_zmset_Diff[simp]: "image_zmset f (A - B) = image_zmset f A - image_zmset f B"
proof -
  have "image_zmset f (A - B + B) = image_zmset f (A - B) + image_zmset f B"
    using image_zmset_union by blast
  then show ?thesis by simp
qed

lemma mset_neg_image_zmset: "mset_neg M = {#} \<Longrightarrow> mset_neg (image_zmset f M) = {#}"
  unfolding multiset_eq_iff count_empty
  by transfer (auto simp add: image_mset_subseteq_mono mset_subset_eqI mset_subset_eq_count)

lemma nonneg_zcount_image_zmset[simp]: "(\<And>t. 0 \<le> zcount M t) \<Longrightarrow> 0 \<le> zcount (image_zmset f M) t"
  by (meson mset_neg_empty_iff mset_neg_image_zmset)

lemma image_zmset_add_zmset[simp]: "image_zmset f (add_zmset t M) = add_zmset (f t) (image_zmset f M)"
  by transfer (auto simp: equiv_zmset_def)

lemma pos_zcount_image_zmset[simp]: "(\<And>t. 0 \<le> zcount M t) \<Longrightarrow> 0 < zcount M t \<Longrightarrow> 0 < zcount (image_zmset f M) (f t)"
  apply transfer
  subgoal for M t f
    apply (induct M)
    subgoal for Mp Mn
      apply simp
      apply (metis count_diff count_image_mset_ge_count image_mset_Diff less_le_trans subseteq_mset_def zero_less_diff)
      done
    done
  done

lemma set_zmset_transfer[transfer_rule]:
  "(rel_fun (pcr_zmultiset (=)) (rel_set (=)))
   (\<lambda>(Mp, Mn). set_mset Mp \<union> set_mset Mn - {x. count Mp x = count Mn x}) set_zmset"
  by (auto simp: rel_fun_def pcr_zmultiset_def cr_zmultiset_def
      rel_set_eq multiset.rel_eq set_zmset_def zcount.abs_eq count_eq_zero_iff[symmetric]
      simp del: zcount_ne_zero_iff)

lemma zcount_image_zmset:
  "zcount (image_zmset f M) x = (\<Sum>y \<in> f -` {x} \<inter> set_zmset M. zcount M y)"
  apply (transfer fixing: f x)
  subgoal for M
    apply (cases M; clarify)
    subgoal for Mp Mn
      unfolding count_image_mset int_sum
    proof -
      have "(\<Sum>x\<in>f -` {x} \<inter> set_mset Mp. int (count Mp x)) =
        (\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn). int (count Mp x))" (is "?S1 = _")
        by (subst sum.same_carrier[where C="f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn)"])
          (auto simp: count_eq_zero_iff)
      moreover
      have "(\<Sum>x\<in>f -` {x} \<inter> set_mset Mn. int (count Mn x)) =
        (\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn). int (count Mn x))"(is "?S2 = _")
        by (subst sum.same_carrier[where C="f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn)"])
          (auto simp: count_eq_zero_iff)
      moreover
      have "(\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn - {x. count Mp x = count Mn x}). int (count Mp x) - int (count Mn x))
        = (\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn). int (count Mp x) - int (count Mn x))"
        (is "?S = _")
        by (subst sum.same_carrier[where C="f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn)"]) auto
      ultimately show "?S1 - ?S2 = ?S"
        by (auto simp: sum_subtractf)
    qed
    done
  done

lemma zmset_empty_image_zmset_empty: "(\<And>t. zcount M t = 0) \<Longrightarrow> zcount (image_zmset f M) t = 0"
  by (auto simp: zcount_image_zmset)

lemma in_image_zmset_in_zmset: "t \<in>#\<^sub>z image_zmset f M \<Longrightarrow> \<exists>t. t \<in>#\<^sub>z M"
  by (rule ccontr) simp

lemma zcount_image_zmset_zero: "(\<And>m. m \<in>#\<^sub>z M \<Longrightarrow> f m \<noteq> x) \<Longrightarrow> x \<notin>#\<^sub>z image_zmset f M"
  unfolding set_zmset_def
  by (simp add: zcount_image_zmset) (metis Int_emptyI sum.empty vimage_singleton_eq)

lemma image_zmset_pre: "t \<in>#\<^sub>z image_zmset f M \<Longrightarrow> \<exists>m. m \<in>#\<^sub>z M \<and> f m = t"
proof (rule ccontr)
  assume t: "t \<in>#\<^sub>z image_zmset f M"
  assume "\<nexists>m. m \<in>#\<^sub>z M \<and> f m = t"
  then have "m \<in>#\<^sub>z M \<Longrightarrow> \<not> f m = t" for m
    by blast
  then have "zcount (image_zmset f M) t = 0"
    by (meson t zcount_image_zmset_zero)
  with t show False
    by (meson zcount_ne_zero_iff)
qed

lemma pos_image_zmset_obtain_pre:
  "(\<And>t. 0 \<le> zcount M t) \<Longrightarrow> 0 < zcount (image_zmset f M) t \<Longrightarrow> \<exists>m. 0 < zcount M m \<and> f m = t"
proof -
  assume nonneg: "0 \<le> zcount M t" for t
  assume "0 < zcount (image_zmset f M) t"
  then have "t \<in>#\<^sub>z image_zmset f M"
    by (simp add: pos_zcount_in_zmset)
  then obtain x where x: "x \<in>#\<^sub>z M" "f x = t"
    by (auto dest: image_zmset_pre)
  with nonneg have "0 < zcount M x"
    by (meson zmset_elem_nonneg)
  with x show ?thesis
    by auto
qed

subsection\<open>Streams\<close>

definition relates :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> bool" where
  "relates \<phi> s = \<phi> (shd s) (shd (stl s))"

lemma relatesD[dest]: "relates P s \<Longrightarrow> P (shd s) (shd (stl s))"
  unfolding relates_def by simp

lemma alw_relatesD[dest]: "alw (relates P) s \<Longrightarrow> P (shd s) (shd (stl s))"
  by auto

lemma relatesI[intro]: "P (shd s) (shd (stl s)) \<Longrightarrow> relates P s"
  by (auto simp: relates_def)

lemma alw_holds_smap_conv_comp: "alw (holds P) (smap f s) = alw (\<lambda>s. (P o f) (shd s)) s"
  apply (rule iffI)
   apply (coinduction arbitrary: s)
   apply auto []
  apply (coinduction arbitrary: s)
  apply auto
  done

lemma alw_relates: "alw (relates P) s \<longleftrightarrow> P (shd s) (shd (stl s)) \<and> alw (relates P) (stl s)"
  apply (rule iffI)
   apply (auto simp: relates_def dest: alwD) []
  apply (coinduction arbitrary: s)
  apply (auto simp: relates_def)
  done

subsection\<open>Notation\<close>

no_notation AND  (infix "aand" 60)
no_notation OR   (infix "or" 60)
no_notation IMPL (infix "imp" 60)

notation AND  (infixr "aand" 70)
notation OR   (infixr "or" 65)
notation IMPL (infixr "imp" 60)

lifting_update multiset.lifting
lifting_forget multiset.lifting

(*<*)
end
(*>*)


theory tutorial_1
imports Main
begin

lemma 1: "(P ⟶ (Q ⟶ R)) ⟶ ((P ⟶ Q) ⟶ (P ⟶ R))"
  apply (rule impI)+
  apply (erule impE)
   apply assumption
  apply (erule mp)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma 2: "¬¬P ⟶ P"
  apply (rule impI)+
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma 3: "(P ⟶ Q ∧ R) ⟶ ((P ⟶ Q) ∧ (P ⟶ R))"
  apply (rule impI)
  apply (rule conjI)
   apply (rule impI)
   apply (erule impE)
  apply assumption
   apply (erule conjE)
   apply assumption
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply (erule conjE)
  apply assumption
  done

lemma 4: "(¬P ⟶ Q) ⟶ (¬Q ⟶ P)"
  apply (rule impI)+
  apply (rule classical)
  apply (erule notE)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma excluded_middle: "P ∨ ¬P"
  apply (rule classical)
  apply (rule disjI1)
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI2  apply (erule notE)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma excluded_middle: "P ∨ ¬P"
  apply (rule classical)
  apply (rule disjI1)
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

lemma 6: "(R ⟶ P) ⟶ (((¬R ∨ P) ⟶ (Q ⟶ S)) ⟶ (Q ⟶ S))"
  apply (rule impI)
  apply (rule impI)
  apply (rule impI)
  apply (rule ccontr)
  apply (erule impE)
  apply (rule ccontr)
  apply (erule impE)
  apply (rule disjI1)
  apply assumption
  apply (erule impE)
  apply assumption
  apply (rule notE)
  apply assumption
  apply assumption
  apply (erule impE)
  apply (rule disjI2)
  apply assumption
  apply (erule impE)
  apply assumption
  apply (erule notE)
  apply assumption
  done

lemma 6: "(R ⟶ P) ⟶ (((¬R ∨ P) ⟶ (Q ⟶ S)) ⟶ (Q ⟶ S))"
  apply (rule impI)
  apply (rule impI)
  apply (rule impI)
  apply (rule ccontr)
  apply (erule impE)
  apply (rule ccontr)
  apply (erule impE)
  apply (rule disjI1)
  apply assumption
  apply (erule impE)
  apply assumption
  apply (rule notE)
  apply assumption
  apply assumption
  apply (erule impE)
  apply (rule disjI2)
  apply assumption
  apply (erule impE)
  apply assumption
  apply (erule notE)
  apply assumption
  done