(*  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
begin

subsection\<open>Cardinal stuff\<close>

context
  includes cardinal_syntax
begin

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

end

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) ===> (=)) (\<subset>) (<)"
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 "(\<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 "(`)" 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 cset \<Rightarrow> 'a cset" is Union parametric Union_transfer
  using countable_UN [of _ id] by auto
abbreviation (input) cUNION :: "'a cset \<Rightarrow> ('a \<Rightarrow> 'b cset) \<Rightarrow> 'b cset"
  where "cUNION A f \<equiv> cUnion (cimage f A)"

lemma Union_conv_UNION: "\<Union>A = \<Union>(id ` A)"
  by simp

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 = rev_subsetD[Transfer.transferred]
lemmas cset_mp = subsetD[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>\<open>cUnion\<close>\<close>

lemma cUNION_cimage: "cUNION (cimage f A) g = cUNION A (g \<circ> f)"
  by transfer simp

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 (cimage f A)) (cUnion (cimage g B))"
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 ===> (=)) ===> (=)) cBall cBall"
  unfolding rel_cset_iff rel_fun_def by blast

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

lemma rel_cset_parametric [transfer_rule]:
  "((A ===> B ===> (=)) ===> rel_cset A ===> rel_cset B ===> (=)) 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 ===> (=)) 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 ===> (=)) 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>

context
  includes cardinal_syntax
begin

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

end

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

context
  includes cardinal_syntax
begin

bnf "'a cset"
  map: cimage
  sets: rcset
  bd: "card_suc 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 = (`) f \<circ> rcset" including cset.lifting by transfer' fastforce
next
  show "card_order (card_suc natLeq)" by (rule card_order_card_suc[OF natLeq_card_order])
next
  show "cinfinite (card_suc natLeq)" using Cinfinite_card_suc[OF natLeq_Cinfinite natLeq_card_order]
    by simp
next
  show "regularCard (card_suc natLeq)" using natLeq_card_order natLeq_Cinfinite
    by (rule regularCard_card_suc)
next
  fix C
  have "|rcset C| \<le>o natLeq" including cset.lifting by transfer (unfold countable_card_le_natLeq)
  then show "|rcset C| <o card_suc natLeq"
    using card_suc_greater natLeq_card_order ordLeq_ordLess_trans by blast
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

end


section\<open>Binary Decision Trees\<close>
theory BDT
imports Bool_Func
begin

text\<open>
We first define all operations and properties on binary decision trees.
This has the advantage that we can use a simple, structurally defined type
and the disadvantage that we cannot represent sharing.
\<close>

datatype 'a ifex = Trueif | Falseif | IF 'a "'a ifex" "'a ifex"

text\<open>The type is the same as in Boolean Expression Checkers by Nipkow~\cite{Boolean_Expression_Checkers-AFP}.
Internally, Boolean Expression Checkers transforms the boolean expressions to reduced BDTs of this type.
Tests like being tautology testing are then trivial.
\<close>

fun val_ifex :: "'a ifex \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "val_ifex Trueif s = True" |
  "val_ifex Falseif s = False" |
  "val_ifex (IF n t1 t2) s = (if s n then val_ifex t1 s else val_ifex t2 s)"

fun ifex_vars :: "'a ifex \<Rightarrow> 'a list" where
  "ifex_vars (IF v t e) =  v # ifex_vars t @ ifex_vars e" |
  "ifex_vars Trueif = []" |
  "ifex_vars Falseif = []"

abbreviation "ifex_var_set a \<equiv> set (ifex_vars a)"

definition sat_assns :: "'a ifex \<Rightarrow> ('a \<Rightarrow> bool) set" where
  "sat_assns e = {s. val_ifex e s \<and> (\<forall>v. v \<notin> ifex_var_set e \<longrightarrow> \<not>s v)}"

lemma finite_sat_assns [simp]: "finite (sat_assns e)"
proof (rule finite_subset)
  from finite_set_of_finite_funs[of "ifex_var_set e" UNIV False]
    show "finite {s. \<forall>x. x \<notin> ifex_var_set e \<longrightarrow> \<not>s x}" by simp
qed (auto simp: sat_assns_def)

fun ifex_ordered :: "('a::linorder) ifex \<Rightarrow> bool" where
  "ifex_ordered (IF v t e) = ((\<forall>tv \<in> (ifex_var_set t \<union> ifex_var_set e). v < tv)
                              \<and> ifex_ordered t \<and> ifex_ordered e)" |
  "ifex_ordered Trueif = True" |
  "ifex_ordered Falseif = True"

fun ifex_minimal :: "('a::linorder) ifex \<Rightarrow> bool" where
  "ifex_minimal (IF v t e) \<longleftrightarrow> t \<noteq> e \<and> ifex_minimal t \<and> ifex_minimal e" |
  "ifex_minimal Trueif = True" |
  "ifex_minimal Falseif = True"

abbreviation ro_ifex where "ro_ifex t \<equiv> ifex_ordered t \<and> ifex_minimal t"

definition bf_ifex_rel where
  "bf_ifex_rel = {(a,b). (\<forall>ass. a ass \<longleftrightarrow> val_ifex b ass) \<and> ro_ifex b}"

lemma ifex_var_noinfluence: "x \<notin> ifex_var_set b \<Longrightarrow> val_ifex b (ass(x:=val)) = val_ifex b ass"
  by (induction b, auto)

lemma roifex_var_not_in_subtree:
  assumes "ro_ifex b" and "b = IF v t e"
  shows "v \<notin> ifex_var_set t" and "v \<notin> ifex_var_set e"
using assms by (induction, auto)

lemma roifex_set_var_subtree:
  assumes "ro_ifex b" and "b = IF v t e"
  shows "val_ifex b (ass(v:=True)) = val_ifex t ass"
        "val_ifex b (ass(v:=False)) = val_ifex e ass"
  using assms by (auto intro!: ifex_var_noinfluence dest: roifex_var_not_in_subtree)

lemma roifex_Trueif_unique: "ro_ifex b \<Longrightarrow> \<forall>ass. val_ifex b ass \<Longrightarrow> b = Trueif"
proof(induction b)
  case (IF v b1 b2) with roifex_set_var_subtree[OF \<open>ro_ifex (IF v b1 b2)\<close>] show ?case by force
qed(auto)

lemma roifex_Falseif_unique: "ro_ifex b \<Longrightarrow> \<forall>ass. \<not> val_ifex b ass \<Longrightarrow> b = Falseif"
proof(induction b)
  case (IF v b1 b2) with roifex_set_var_subtree[OF \<open>ro_ifex (IF v b1 b2)\<close>, of v b1 b2] show ?case
    by fastforce
qed(auto)

lemma "(f, b) \<in> bf_ifex_rel \<Longrightarrow>  b = Trueif \<longleftrightarrow> f = (\<lambda>_. True)"
  unfolding bf_ifex_rel_def using roifex_Trueif_unique by auto

lemma "(f, b) \<in> bf_ifex_rel \<Longrightarrow>  b = Falseif \<longleftrightarrow> f = (\<lambda>_. False)"
  unfolding bf_ifex_rel_def using roifex_Falseif_unique by auto

lemma ifex_ordered_not_part: "ifex_ordered  b \<Longrightarrow> b = IF v b1 b2 \<Longrightarrow> w < v \<Longrightarrow> w \<notin> ifex_var_set b"
	using less_asym by fastforce

lemma ro_ifex_unique: "ro_ifex x \<Longrightarrow> ro_ifex y \<Longrightarrow> (\<And>ass. val_ifex x ass = val_ifex y ass) \<Longrightarrow> x = y"
 proof(induction x arbitrary: y)
  case (IF xv xb1 xb2) note IFind = IF
    from \<open>ro_ifex (IF xv xb1 xb2)\<close>  \<open>ro_ifex y\<close> \<open>\<And>ass. val_ifex (IF xv xb1 xb2) ass = val_ifex y ass\<close>
      show ?case
        proof(induction y)
          case (IF yv yb1 yb2)
            obtain x where x_def: "x = IF xv xb1 xb2" by simp
            obtain y' where y'_def: "y' = IF yv yb1 yb2" by simp
            from y'_def x_def IFind IF have 0: "ro_ifex xb1" "ro_ifex xb2" "ro_ifex yb1"
                                               "ro_ifex yb2" "ro_ifex x" "ro_ifex y'" by auto
            from IF IFind x_def y'_def have 1: "\<And>ass. val_ifex x ass = val_ifex y' ass" by simp
            show ?case
              proof(cases "xv = yv")
                case True
      have "xb1 = yb1"
        by (auto intro: IFind simp add: 0 1 True roifex_set_var_subtree[OF _ y'_def]
                                        roifex_set_var_subtree[OF _ x_def, symmetric])
      moreover have "xb2 = yb2"
        by (auto intro: IFind simp add: 0 1 True roifex_set_var_subtree[OF _ y'_def]
                                        roifex_set_var_subtree[OF _ x_def, symmetric])
      ultimately show ?thesis using True by simp
    next
    case False note uneq = False show ?thesis
      proof(cases "xv < yv")
        case True
          from ifex_ordered_not_part[OF _ y'_def True] ifex_var_noinfluence[of xv y' _ "True"]
               0(6) roifex_set_var_subtree(1)[OF 0(5) x_def] 1
             have 5: "\<And>ass. val_ifex xb1 ass = val_ifex x ass" by blast
          from 0(5) ifex_var_noinfluence[of xv xb1 _ "False"]
                    ifex_var_noinfluence[of xv xb2 _ "False"]
               x_def
            have "\<And>ass. val_ifex xb1 (ass(xv := False)) = val_ifex xb1 ass"
                 "\<And>ass. val_ifex xb2 (ass(xv := False)) = val_ifex xb2 ass" by auto
          from 5 this roifex_set_var_subtree(2)[OF 0(5) x_def]
            have "\<And>ass. val_ifex xb1 ass = val_ifex xb2 ass" by presburger
          from IFind(1)[OF 0(1) 0(2)] this IFind(3) have "False" by auto
          from this show ?thesis ..
      next
        case False
          from this uneq have 6: "yv < xv" by auto
          from ifex_ordered_not_part[OF _ x_def this]
                     ifex_var_noinfluence[of yv x] 0(5)
             have  "\<And>ass val. val_ifex x (ass(yv := val)) = val_ifex x ass"
                   "\<And>ass val. val_ifex x (ass(yv := val)) =  val_ifex x ass" by auto
          from this roifex_set_var_subtree[OF 0(5) x_def]
            have "\<And>ass val. val_ifex x (ass(xv := True, yv := val)) = val_ifex xb1 ass"
                 "\<And>ass val. val_ifex x (ass(xv := False, yv := val)) = val_ifex xb2 ass" by blast+
          from ifex_ordered_not_part[OF _ x_def 6] 0(5) ifex_var_noinfluence[of yv x] 1
               roifex_set_var_subtree[OF 0(6) y'_def]
            have "\<And>ass val. val_ifex x ass = val_ifex yb1 ass"
                 "\<And>ass val. val_ifex x ass = val_ifex yb2 ass" by blast+
          from this IF(1,2) x_def 0(5) y'_def 0(6) have "x = yb1" "x = yb2" by fastforce+
          from this have "yb1 = yb2" by auto
          from 0(6) y'_def this have "False" by auto
          thus ?thesis ..
      qed
  qed
qed (fastforce intro: roifex_Falseif_unique roifex_Trueif_unique)+
qed (fastforce intro: roifex_Falseif_unique[symmetric] roifex_Trueif_unique[symmetric])+

theorem bf_ifex_rel_single: "single_valued bf_ifex_rel" "single_valued (bf_ifex_rel\<inverse>)"
  unfolding single_valued_def bf_ifex_rel_def using ro_ifex_unique by auto

lemma bf_ifex_eq: "(af, at) \<in> bf_ifex_rel \<Longrightarrow> (bf, bt) \<in> bf_ifex_rel \<Longrightarrow> (af = bf) \<longleftrightarrow> (at = bt)"
  unfolding bf_ifex_rel_def using ro_ifex_unique by auto

lemma nonempty_if_var_set: "ifex_vars (IF v t e) \<noteq> []" by auto

fun restrict where
  "restrict (IF v t e) var val = (let rt = restrict t var val; re = restrict e var val in
                   (if v = var then (if val then rt else re) else (IF v rt re)))" |
  "restrict i _ _ = i"

declare Let_def[simp]

lemma not_element_restrict: "var \<notin> ifex_var_set (restrict b var val)"
  by (induction b) auto

lemma restrict_assignment: "val_ifex b (ass(var := val)) \<longleftrightarrow> val_ifex (restrict b var val) ass"
  by (induction b) auto

lemma restrict_variables_subset: "ifex_var_set (restrict b var val) \<subseteq> ifex_var_set b"
  by (induction b) auto

lemma restrict_ifex_ordered_invar: "ifex_ordered b \<Longrightarrow> ifex_ordered (restrict b var val)"
  using restrict_variables_subset by (induction b) (fastforce)+

lemma restrict_val_invar: "\<forall>ass. a ass = val_ifex b ass \<Longrightarrow>
                           (bf_restrict var val a) ass = val_ifex (restrict b var val) ass"
  unfolding bf_restrict_def using restrict_assignment by simp

lemma restrict_untouched_id: "x \<notin> ifex_var_set t \<Longrightarrow> restrict t x val = t" (* inversion should hold, too\<dots> *)
proof(induction t)
  case (IF v t e)
  from IF.prems have "x \<notin> ifex_var_set t" "x \<notin> ifex_var_set e" by simp_all
  note mIH = IF.IH(1)[OF this(1)] IF.IH(2)[OF this(2)]
  from IF.prems have "x \<noteq> v" by simp
  thus ?case unfolding restrict.simps Let_def mIH  by simp
qed simp_all

fun ifex_top_var :: "'a ifex \<Rightarrow> 'a option" where
  "ifex_top_var (IF v t e) = Some v" |
  "ifex_top_var _ = None"

fun restrict_top :: "('a :: linorder) ifex \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a ifex" where
  "restrict_top (IF v t e) var val = (if v = var then (if val then t else e) else (IF v t e))" |
  "restrict_top i _ _ = i"

(* the following four are might be useful eventually\<dots> *)
lemma restrict_top_id: "ifex_ordered e \<Longrightarrow> ifex_top_var e = Some v \<Longrightarrow> v' < v \<Longrightarrow> restrict_top e v' val = e"
  by(induction e) auto

lemma restrict_id: "ifex_ordered e \<Longrightarrow> ifex_top_var e = Some v \<Longrightarrow> v' < v \<Longrightarrow> restrict e v' val = e"
  proof(induction e arbitrary: v)
    case (IF w e1 e2) thus ?case by (cases e1; cases e2; force)
  qed(auto)

lemma restrict_top_IF_id: "ifex_ordered (IF v t e) \<Longrightarrow> v' < v \<Longrightarrow> restrict_top (IF v t e) v' val = (IF v t e)"
  using restrict_top_id by auto

lemma restrict_IF_id: assumes o: "ifex_ordered (IF v t e)" assumes le: "v' < v"
  shows "restrict (IF v t e) v' val = (IF v t e)"
  using restrict_id[OF o, unfolded ifex_top_var.simps, OF refl le, of val] .

lemma restrict_top_eq: "ifex_ordered (IF v t e) \<Longrightarrow> restrict (IF v t e) v val = restrict_top (IF v t e) v val"
	by (auto intro: restrict_untouched_id)

lemma restrict_top_ifex_ordered_invar: "ifex_ordered b \<Longrightarrow> ifex_ordered (restrict_top b var val)"
  by (induction b) simp_all

fun lowest_tops :: "('a :: linorder) ifex list \<Rightarrow> 'a option" where
  "lowest_tops [] = None" |
  "lowest_tops ((IF v _ _)#r) = Some (case lowest_tops r of Some u \<Rightarrow> (min u v) | None \<Rightarrow> v)" |
  "lowest_tops (_#r) = lowest_tops r"

lemma lowest_tops_NoneD: "lowest_tops k = None \<Longrightarrow> (\<not>(\<exists>v t e. ((IF v t e) \<in> set k)))"
  by (induction k rule: lowest_tops.induct) simp_all

lemma lowest_tops_in: "lowest_tops k = Some l \<Longrightarrow> l \<in> set (concat (map ifex_vars k))"
  by(induction k rule: lowest_tops.induct) (simp_all split: option.splits if_splits add: min_def)

definition "IFC v t e \<equiv> (if t = e then t else IF v t e)"

function ifex_ite :: "'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> ('a :: linorder) ifex" where
  "ifex_ite i t e = (case lowest_tops [i, t, e] of Some x \<Rightarrow>
                         (IFC x (ifex_ite (restrict_top i x True) (restrict_top t x True) (restrict_top e x True))
                               (ifex_ite (restrict_top i x False) (restrict_top t x False) (restrict_top e x False)))
                     | None \<Rightarrow> (case i of Trueif \<Rightarrow> t | Falseif \<Rightarrow> e))"
by pat_completeness auto

lemma restrict_size_le: "size (restrict_top k var val) \<le> size k"
  by (induction k, auto)

lemma restrict_size_less: "ifex_top_var k = Some var \<Longrightarrow> size (restrict_top k var val) < size k"
  by (induction k, auto)

lemma lowest_tops_cases:
"lowest_tops [i, t, e] = Some var \<Longrightarrow> ifex_top_var i = Some var \<or> ifex_top_var t
                                      = Some var \<or> ifex_top_var e = Some var"
  by ((cases i; cases t; cases e), auto simp add: min_def)

lemma lowest_tops_lowest: "lowest_tops es = Some a \<Longrightarrow> e \<in> set es \<Longrightarrow> ifex_ordered e \<Longrightarrow> v \<in> ifex_var_set e \<Longrightarrow> a \<le> v"
proof (induction arbitrary: a rule: lowest_tops.induct)
  case 2 thus ?case
  proof(cases e)
    case IF with 2 show ?thesis
     apply (simp add: min_def Ball_def less_imp_le split: if_splits option.splits)
       apply (meson less_imp_le lowest_tops_NoneD order_refl)
      by fastforce+
  qed simp+
qed fastforce+

lemma termlemma2: "lowest_tops [i, t, e] = Some xa \<Longrightarrow>
  (size (restrict_top i xa val) + size (restrict_top t xa val) + size (restrict_top e xa val)) <
  (size i + size t + size e)"
  using restrict_size_le[of i xa val] restrict_size_le[of t xa val]  restrict_size_le[of e xa val]
  by (auto dest!: lowest_tops_cases restrict_size_less[of _ _ val])

lemma termlemma: "lowest_tops [i, t, e] = Some xa \<Longrightarrow>
       (case (restrict_top i xa val, restrict_top t xa val, restrict_top e xa val) of
             (i, t, e) \<Rightarrow> size i + size t + size e) <
       (case (i, t, e) of (i, t, e) \<Rightarrow> size i + size t + size e)"
  using termlemma2 by fast

termination ifex_ite
  by (relation "measure (\<lambda>(i,t,e). size i + size t + size e)", rule wf_measure, unfold in_measure)
     (simp_all only: termlemma)

definition "const x _ = x" (* inspired by Haskell *)
declare const_def[simp]
lemma rel_true_false: "(a, Trueif) \<in> bf_ifex_rel \<Longrightarrow> a = const True" "(a, Falseif) \<in> bf_ifex_rel \<Longrightarrow> a = const False"
  unfolding fun_eq_iff const_def
  unfolding bf_ifex_rel_def
  by simp_all

lemma rel_if: "(a, IF v t e) \<in> bf_ifex_rel \<Longrightarrow> (ta, t) \<in> bf_ifex_rel \<Longrightarrow> (ea, e) \<in> bf_ifex_rel \<Longrightarrow> a = (\<lambda>as. if as v then ta as else ea as)"
  unfolding fun_eq_iff const_def
  unfolding bf_ifex_rel_def
  by simp_all

lemma ifex_ordered_implied: "(a, b) \<in> bf_ifex_rel \<Longrightarrow> ifex_ordered b" unfolding bf_ifex_rel_def by simp
lemma ifex_minimal_implied: "(a, b) \<in> bf_ifex_rel \<Longrightarrow> ifex_minimal b" unfolding bf_ifex_rel_def by simp

lemma ifex_ite_induct2[case_names Trueif Falseif IF]: "
  (\<And>i t e. lowest_tops [i, t, e] = None \<Longrightarrow> i = Trueif \<Longrightarrow> sentence i t e) \<Longrightarrow>
  (\<And>i t e. lowest_tops [i, t, e] = None \<Longrightarrow> i = Falseif \<Longrightarrow> sentence i t e) \<Longrightarrow>
  (\<And>i t e a. sentence (restrict_top i a True) (restrict_top t a True) (restrict_top e a True) \<Longrightarrow>
             sentence (restrict_top i a False) (restrict_top t a False) (restrict_top e a False) \<Longrightarrow>
   lowest_tops [i, t, e] = Some a \<Longrightarrow> sentence i t e) \<Longrightarrow> sentence i t e"
proof(induction i t e rule: ifex_ite.induct, goal_cases)
  case (1 i t e) show ?case
  proof(cases "lowest_tops [i, t, e]")
    case None thus ?thesis by (cases i) (auto intro: 1)
  next
    case (Some a) thus ?thesis by(auto intro: 1)
  qed
qed

lemma ifex_ite_induct[case_names Trueif Falseif IF]: "
  (\<And>i t e. lowest_tops [i, t, e] = None \<Longrightarrow> i = Trueif \<Longrightarrow> P i t e) \<Longrightarrow>
  (\<And>i t e. lowest_tops [i, t, e] = None \<Longrightarrow> i = Falseif \<Longrightarrow> P i t e) \<Longrightarrow>
  (\<And>i t e a. (\<And>val. P (restrict_top i a val) (restrict_top t a val) (restrict_top e a val)) \<Longrightarrow>
   lowest_tops [i, t, e] = Some a \<Longrightarrow> P i t e) \<Longrightarrow> P i t e"
proof(induction i t e rule: ifex_ite_induct2)
  case (IF i t e a)
  have "\<And>val. (P (restrict_top i a val) (restrict_top t a val) (restrict_top e a val))"
    by (case_tac val) (clarsimp, blast intro: IF)+
  with IF show ?case by blast
qed blast+

lemma restrict_top_subset: "x \<in> ifex_var_set (restrict_top i vr vl) \<Longrightarrow> x \<in> ifex_var_set i"
  by(induction i) (simp_all split: if_splits)

lemma ifex_vars_subset: "x \<in> ifex_var_set (ifex_ite i t e) \<Longrightarrow> (x \<in> ifex_var_set i) \<or> (x \<in> ifex_var_set t) \<or> (x \<in> ifex_var_set e)"
proof(induction rule: ifex_ite_induct2)
  case (IF i t e a)
  have "x \<in> {x. x = a} \<or> x \<in> (ifex_var_set (ifex_ite (restrict_top i a True) (restrict_top t a True) (restrict_top e a True))) \<or> x \<in> (ifex_var_set (ifex_ite (restrict_top i a False) (restrict_top t a False) (restrict_top e a False)))"
    using IF by(simp add: IFC_def split: if_splits)
  hence "x = a \<or>
    x \<in> (ifex_var_set (restrict_top i a True )) \<or> x \<in> (ifex_var_set (restrict_top t a True )) \<or> x \<in> (ifex_var_set (restrict_top e a True )) \<or>
    x \<in> (ifex_var_set (restrict_top i a False)) \<or> x \<in> (ifex_var_set (restrict_top t a False)) \<or> x \<in> (ifex_var_set (restrict_top e a False))"
  using IF by blast
  thus ?case
    using restrict_top_subset apply -
    apply(erule disjE)
      subgoal using lowest_tops_in[OF IF(3)] apply(simp only: set_concat set_map set_simps) by blast
    by blast
qed simp_all

lemma three_ins: "i \<in> set [i, t, e]" "t \<in> set [i, t, e]" "e \<in> set [i, t, e]" by simp_all

lemma hlp3: "lowest_tops (IF v uu uv # r) \<noteq> lowest_tops r \<Longrightarrow> lowest_tops (IF v uu uv # r) = Some v"
  by(simp add: min_def split: option.splits if_splits)

lemma hlp2: "IF vi vt ve \<in> set is \<Longrightarrow> lowest_tops is = Some a \<Longrightarrow> a \<le> vi"
  apply(induction "is" arbitrary: vt ve a rule: lowest_tops.induct)
    prefer 2
    subgoal
      apply(auto simp add: min_def split: if_splits option.splits dest: lowest_tops_NoneD)
      by (meson le_cases order_trans)
    by (auto)

lemma hlp1: "i \<in> set is \<Longrightarrow> lowest_tops is = Some a \<Longrightarrow> ifex_ordered i \<Longrightarrow> a \<notin> (ifex_var_set (restrict_top i a val))"
proof(rule ccontr, unfold not_not, goal_cases)
  case 1
  from 1(4) obtain vi vt ve where vi: "i = IF vi vt ve" by(cases i) simp_all
  with 1 have ne: "vi \<noteq> a" by(simp split: if_splits) blast+
  moreover have "vi \<le> a" using 1(3,4) proof(-,goal_cases)
    case 1
    hence "a \<in> (ifex_var_set vt) \<or> a \<in> (ifex_var_set ve)" using ne by(simp add: vi)
    thus ?case using \<open>ifex_ordered i\<close> vi using less_imp_le by auto
    qed
  moreover have "a \<le> vi" using 1(1) unfolding vi using 1(2) hlp2 by metis
  ultimately show False by simp
qed

lemma order_ifex_ite_invar: "ifex_ordered i \<Longrightarrow> ifex_ordered t \<Longrightarrow> ifex_ordered e \<Longrightarrow> ifex_ordered (ifex_ite i t e)"
proof(induction i t e rule: ifex_ite_induct)
  case (IF i t e) note goal1 = IF
  note l = restrict_top_ifex_ordered_invar
  note l[OF goal1(3)] l[OF goal1(4)] l[OF goal1(5)]
  note mIH = goal1(1)[OF this]
  note blubb = lowest_tops_lowest[OF goal1(2) _ _ restrict_top_subset]
  show ?case using mIH
  by (subst ifex_ite.simps,
    auto simp del: ifex_ite.simps
      simp add: IFC_def goal1(2) hlp1[OF three_ins(1) goal1(2) goal1(3)] hlp1[OF three_ins(2) goal1(2) goal1(4)] hlp1[OF three_ins(3) goal1(2) goal1(5)]
      dest: ifex_vars_subset blubb[OF three_ins(1) goal1(3)] blubb[OF three_ins(2) goal1(4)] blubb[OF three_ins(3) goal1(5)]
      intro!: le_neq_trans)
qed simp_all

lemma ifc_split: "P (IFC v t e) \<longleftrightarrow> ((t = e) \<longrightarrow> P t) \<and> (t \<noteq> e \<longrightarrow> P (IF v t e))"
  unfolding IFC_def by simp

lemma restrict_top_ifex_minimal_invar: "ifex_minimal i \<Longrightarrow> ifex_minimal (restrict_top i a val)"
  by(induction i) simp_all

lemma minimal_ifex_ite_invar: "ifex_minimal i \<Longrightarrow> ifex_minimal t \<Longrightarrow> ifex_minimal e \<Longrightarrow> ifex_minimal (ifex_ite i t e)"
  by(induction i t e rule: ifex_ite_induct) (simp_all split: ifc_split option.split add: restrict_top_ifex_minimal_invar)

lemma restrict_top_bf: "i \<in> set is \<Longrightarrow> lowest_tops is = Some vr \<Longrightarrow>
  ifex_ordered i \<Longrightarrow> (\<And>ass. fi ass = val_ifex i ass) \<Longrightarrow> val_ifex (restrict_top i vr vl) ass = bf_restrict vr vl fi ass"
proof(cases i, goal_cases)
  case (3 x31 x32 x33)  note goal3 = 3
  have rr: "restrict_top i vr vl = restrict i vr vl"
  proof(cases "x31 = vr")
    case True
    note uf = restrict_top_eq[OF goal3(3)[unfolded goal3(5)], symmetric, unfolded goal3(5)[symmetric], unfolded True]
    thus ?thesis .
  next
    case False
    have 1: "restrict_top i vr vl = i" by (simp add: False goal3(5))
    have "vr < x31" using le_neq_trans[OF hlp2[OF goal3(1)[unfolded goal3(5)] goal3(2)] False[symmetric]] by blast
    with goal3(3,5) have 2: "restrict i vr vl = i" using restrict_IF_id by blast
    show ?thesis unfolding 1 2 ..
  qed
  show ?case unfolding rr by(simp add: goal3(4) restrict_val_invar[symmetric])
qed (simp_all add: bf_restrict_def)

lemma val_ifex_ite: "
  (\<And>ass. fi ass = val_ifex i ass) \<Longrightarrow>
  (\<And>ass. ft ass = val_ifex t ass) \<Longrightarrow>
  (\<And>ass. fe ass = val_ifex e ass) \<Longrightarrow>
  ifex_ordered i \<Longrightarrow> ifex_ordered t \<Longrightarrow> ifex_ordered e \<Longrightarrow>
  (bf_ite fi ft fe) ass = val_ifex (ifex_ite i t e) ass"
proof(induction i t e arbitrary: fi ft fe rule: ifex_ite_induct)
  case (IF i t e a)
  note mIH = IF(1)[OF refl refl refl
    restrict_top_ifex_ordered_invar[OF IF(6)]
    restrict_top_ifex_ordered_invar[OF IF(7)]
    restrict_top_ifex_ordered_invar[OF IF(8)], symmetric]
  note uf1 = restrict_top_bf[OF three_ins(1) IF(2) \<open>ifex_ordered i\<close>  IF(3)]
             restrict_top_bf[OF three_ins(2) IF(2) \<open>ifex_ordered t\<close>  IF(4)]
             restrict_top_bf[OF three_ins(3) IF(2) \<open>ifex_ordered e\<close>  IF(5)]
  show ?case
    by(rule trans[OF brace90shannon[where i=a]])
      (auto simp: restrict_top_ifex_ordered_invar IF(1,2,6-8) uf1 mIH bf_ite_def[of "\<lambda>l. l a"]
            split: ifc_split)
qed (simp add: bf_ite_def bf_ifex_rel_def)+

theorem ifex_ite_rel_bf: "
  (fi,i) \<in> bf_ifex_rel \<Longrightarrow>
  (ft,t) \<in> bf_ifex_rel \<Longrightarrow>
  (fe,e) \<in> bf_ifex_rel \<Longrightarrow>
  ((bf_ite fi ft fe), (ifex_ite i t e)) \<in> bf_ifex_rel"
by (auto simp add:  bf_ifex_rel_def order_ifex_ite_invar minimal_ifex_ite_invar val_ifex_ite
         simp del: ifex_ite.simps)

definition param_opt where "param_opt i t e =
  (if i = Trueif then Some t else
   if i = Falseif then Some e else
   if t = Trueif \<and> e = Falseif then Some i else
   if t = e then Some t else
   if e = Trueif \<and> i = t then Some Trueif else
   if t = Falseif \<and> i = e then Some Falseif else
   None)"

lemma param_opt_ifex_ite_eq: "ro_ifex i \<Longrightarrow> ro_ifex t \<Longrightarrow> ro_ifex e \<Longrightarrow>
       param_opt i t e = Some r \<Longrightarrow> r = ifex_ite i t e"
  apply(rule ro_ifex_unique)
   subgoal by (subst (asm) param_opt_def) (simp split: split_if_asm)
   subgoal using order_ifex_ite_invar minimal_ifex_ite_invar by (blast)
   by (subst val_ifex_ite[symmetric])
      (auto split: split_if_asm simp add: bf_ite_def param_opt_def val_ifex_ite[symmetric])

function ifex_ite_opt :: "'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> ('a :: linorder) ifex" where
  "ifex_ite_opt i t e = (case param_opt i t e of Some b \<Rightarrow> b | None \<Rightarrow>
                        (case lowest_tops [i, t, e] of Some x \<Rightarrow>
                         (IFC x (ifex_ite_opt (restrict_top i x True) (restrict_top t x True)
                                              (restrict_top e x True))
                                (ifex_ite_opt (restrict_top i x False) (restrict_top t x False)
                                              (restrict_top e x False)))
                     | None \<Rightarrow> (case i of Trueif \<Rightarrow> t | Falseif \<Rightarrow> e)))"
by pat_completeness auto

termination ifex_ite_opt
  by (relation "measure (\<lambda>(i,t,e). size i + size t + size e)", rule wf_measure, unfold in_measure)
     (simp_all only: termlemma)

lemma ifex_ite_opt_eq: "
  ro_ifex i \<Longrightarrow> ro_ifex t \<Longrightarrow> ro_ifex e \<Longrightarrow> ifex_ite_opt i t e = ifex_ite i t e"
  apply(induction i t e rule: ifex_ite_opt.induct)
  apply(subst ifex_ite_opt.simps)
  apply(rename_tac i t e)
  apply(case_tac "\<exists>r. param_opt i t e = Some r")
   subgoal
    apply(simp del: ifex_ite.simps restrict_top.simps lowest_tops.simps)
    apply(rule param_opt_ifex_ite_eq)
    by (auto simp add: bf_ifex_rel_def)
   subgoal for i t e
    apply(clarsimp simp del: restrict_top.simps ifex_ite.simps ifex_ite_opt.simps)
    apply(cases "lowest_tops [i,t,e] = None")
     subgoal by clarsimp
     subgoal
      apply(clarsimp simp del: restrict_top.simps ifex_ite.simps ifex_ite_opt.simps)
      apply(subst ifex_ite.simps)
      apply(rename_tac y)
      apply(subgoal_tac "(ifex_ite_opt (restrict_top i y True) (restrict_top t y True) (restrict_top e y True)) =
                         (ifex_ite (restrict_top i y True) (restrict_top t y True) (restrict_top e y True))")
      apply(subgoal_tac "(ifex_ite_opt (restrict_top i y False) (restrict_top t y False) (restrict_top e y False)) =
                         (ifex_ite (restrict_top i y False) (restrict_top t y False) (restrict_top e y False))")
       subgoal by force
       subgoal using restrict_top_ifex_minimal_invar restrict_top_ifex_ordered_invar by metis
       subgoal using restrict_top_ifex_minimal_invar restrict_top_ifex_ordered_invar by metis
      done
   done
done

lemma ro_ifexI: "(a,b) \<in> bf_ifex_rel \<Longrightarrow> ro_ifex b" by (simp add: ifex_minimal_implied ifex_ordered_implied)

theorem ifex_ite_opt_rel_bf: "
  (fi,i) \<in> bf_ifex_rel \<Longrightarrow>
  (ft,t) \<in> bf_ifex_rel \<Longrightarrow>
  (fe,e) \<in> bf_ifex_rel \<Longrightarrow>
  ((bf_ite fi ft fe), (ifex_ite_opt i t e)) \<in> bf_ifex_rel"
using ifex_ite_rel_bf ifex_ite_opt_eq ro_ifexI by metis

lemma restrict_top_bf_ifex_rel:
"(f, i) \<in> bf_ifex_rel \<Longrightarrow> \<exists>f'. (f', restrict_top i var val) \<in> bf_ifex_rel"
  unfolding bf_ifex_rel_def using restrict_top_ifex_minimal_invar restrict_top_ifex_ordered_invar
by fast

lemma param_opt_lowest_tops_lem: "param_opt i t e = None \<Longrightarrow> \<exists>y. lowest_tops [i,t,e] = Some y"
  by (cases i) (auto simp add: param_opt_def)

fun ifex_sat where
"ifex_sat Trueif = Some (const False)" |
"ifex_sat Falseif = None" |
"ifex_sat (IF v t e) =
  (case ifex_sat e of
    Some a \<Rightarrow> Some (a(v:=False)) |
    None \<Rightarrow> (case ifex_sat t of
      Some a \<Rightarrow> Some (a(v:=True)) |
      None \<Rightarrow> None))
"

lemma ifex_sat_untouched_False: "v \<notin> ifex_var_set i \<Longrightarrow> ifex_sat i = Some a \<Longrightarrow> a v = False"
proof(induction i arbitrary: a)
  case (IF v1 t e)
  have ni: "v \<notin> ifex_var_set t" "v \<notin> ifex_var_set e" using IF.prems(1) by simp_all
  have ne: "v1 \<noteq> v" using IF.prems(1) by force
  show ?case proof(cases "ifex_sat e")
    case (Some as)
    with IF.prems(2) have au: "a = as(v1 := False)" by simp
    moreover from IF.IH(2)[OF ni(2)] have "as v = False" using Some .
    ultimately show ?thesis using ne by simp
  next
    case None
    obtain as where Some: "ifex_sat t = Some as" using None IF.prems(2) by fastforce
    with IF.prems(2) None have au: "a = as(v1 := True)" by(simp)
    moreover from IF.IH(1)[OF ni(1)] have "as v = False" using Some .
    ultimately show ?thesis using ne by simp
  qed (* this proof seems to complicated\<dots> *)
qed(simp_all add: fun_eq_iff)

lemma ifex_upd_other: "v \<notin> ifex_var_set i \<Longrightarrow> val_ifex i (a(v:=any)) = val_ifex i a"
proof(induction i)
  case (IF v1 t e)
  have prems: "v \<notin> ifex_var_set t " "v \<notin> ifex_var_set e" using IF.prems by simp_all
  from IF.prems have ne: "v1 \<noteq> v" by clarsimp
  show ?case by(simp only: val_ifex.simps fun_upd_other[OF ne] ifex_vars.simps IF.IH(1)[OF prems(1)] IF.IH(2)[OF prems(2)] split: if_splits)
qed simp_all

(* something weaker than ifex_ordered *)
fun ifex_no_twice where
"ifex_no_twice (IF v t e) = (
  v \<notin> (ifex_var_set t \<union> ifex_var_set e) \<and>
  ifex_no_twice t \<and> ifex_no_twice e)" |
"ifex_no_twice _ = True"
lemma ordered_ifex_no_twiceI: "ifex_ordered i \<Longrightarrow> ifex_no_twice i"
  by(induction i) (simp_all,blast)

fun ifex_sat_list where
"ifex_sat_list Trueif = Some []" |
"ifex_sat_list Falseif = None" |
"ifex_sat_list (IF v t e) =
  (case ifex_sat_list e of
    Some a \<Rightarrow> Some ((v,False)#a) |
    None \<Rightarrow> (case ifex_sat_list t of
      Some a \<Rightarrow> Some ((v,True)#a) |
      None \<Rightarrow> None))
"

definition "update_assignment_alt u as = (\<lambda>v. case map_of u v of None \<Rightarrow> as v | Some n \<Rightarrow> n)"
fun update_assignment where
"update_assignment ((v,u)#us) as = (update_assignment us as)(v:=u)" |
"update_assignment [] as = as"

lemma update_assignment_notin: "a \<notin> fst ` set us \<Longrightarrow> update_assignment us as a = as a"
by(induction us) clarsimp+

lemma update_assignment_alt: "update_assignment u as = update_assignment_alt u as"
by(induction u arbitrary: as) (clarsimp simp: update_assignment_alt_def fun_eq_iff)+

lemma update_assignment: "distinct (map fst ((v,u)#us)) \<Longrightarrow> update_assignment ((v,u)#us) as = update_assignment us (as(v:=u))"
unfolding update_assignment_alt update_assignment_alt_def
unfolding fun_eq_iff
by(clarsimp split: option.splits) force

lemma ass_upd_same: "update_assignment ((v, u) # a) ass v = u" by simp

lemma ifex_sat_list_subset:  "ifex_sat_list t = Some u \<Longrightarrow> fst ` set u \<subseteq> ifex_var_set t"
proof(induction t arbitrary: u)
  case (IF v t e)
  show ?case
  proof(cases "ifex_sat_list e")
    case (Some ue)
    note IF.IH(2)[OF this]
    hence "fst ` set ue \<subseteq> ifex_var_set (IF v t e)" by simp blast
    moreover have "fst ` set u = insert v (fst ` set ue)" using IF.prems Some by force
    ultimately show ?thesis by simp
  next
    case None
    with IF.prems obtain ut where Some: "ifex_sat_list t = Some ut" by(simp split: option.splits)
    note IF.IH(1)[OF this]
    hence "fst ` set ut \<subseteq> ifex_var_set (IF v t e)" by simp blast
    moreover have "fst ` set u = insert v (fst ` set ut)" using IF.prems None Some by force
    ultimately show ?thesis by simp
  qed
qed simp_all

lemma sat_list_distinct: "ifex_no_twice t \<Longrightarrow> ifex_sat_list t = Some u \<Longrightarrow> distinct (map fst u)"
proof(induction t arbitrary: u)
  case (IF v t e)
  from IF.prems have nt: "ifex_no_twice t" "ifex_no_twice e" by simp_all
  note mIH = IF.IH(1)[OF this(1)] IF.IH(2)[OF this(2)]
  show ?case
  proof(cases "ifex_sat_list e")
    case (Some a)
    note mIH = mIH(2)[OF this]
    thus ?thesis using IF.prems ifex_sat_list.simps Some ifex_sat_list_subset by fastforce
  next
    case None
    with IF.prems obtain ut where Some: "ifex_sat_list t = Some ut" by(simp split: option.splits)
    note mIH(1)[OF this]
    thus ?thesis using IF.prems ifex_sat_list.simps None Some ifex_sat_list_subset by fastforce
  qed
qed simp_all

lemma ifex_sat_list_NoneD: "ifex_sat_list i = None \<Longrightarrow> val_ifex i ass = False"
  by(induction i) (simp_all split: option.splits)
lemma ifex_sat_list_SomeD: "ifex_no_twice i \<Longrightarrow> ifex_sat_list i = Some u \<Longrightarrow> ass = update_assignment u ass' \<Longrightarrow> val_ifex i ass = True"
proof(induction i arbitrary: ass ass' u)
  case (IF v t e)
  have nt: "ifex_no_twice t" "ifex_no_twice e" using IF.prems(1) by simp_all
  have ni: "v \<notin> ifex_var_set t" "v \<notin> ifex_var_set e" using IF.prems(1) by simp_all
  note IF.prems[unfolded ifex_sat.simps]
  thus ?case proof(cases "ifex_sat_list e")
    case (Some a)
    have ef: "u = (v, False) # a" using IF.prems(2) Some by simp
    from IF.prems(3) have au: "ass = update_assignment a (ass'(v := False))" unfolding ef using update_assignment[OF sat_list_distinct[OF IF.prems(1,2), unfolded ef]] by presburger
    have avF: "ass v = False" using IF.prems(3)[symmetric] unfolding ef by clarsimp
    show ?thesis using IF.IH(2)[OF nt(2) Some au] Some IF.prems(2) avF by simp
  next
    case None
    obtain a where Some: "ifex_sat_list t = Some a" using None IF.prems(2) by fastforce
    have ef: "u = (v, True) # a" using IF.prems(2) None Some by simp
    from IF.prems(3) have au: "ass = update_assignment a (ass'(v := True))" unfolding ef using update_assignment[OF sat_list_distinct[OF IF.prems(1,2), unfolded ef]] by presburger
    have avT: "ass v = True" using IF.prems(3)[symmetric] unfolding ef by clarsimp
    show ?thesis using IF.IH(1)[OF nt(1) Some au] Some IF.prems(2) avT by simp
  qed
qed simp_all

fun sat_list_to_bdt where
"sat_list_to_bdt [] = Trueif" |
"sat_list_to_bdt ((v,u)#us) = (if u then IF v (sat_list_to_bdt us) Falseif else IF v Falseif (sat_list_to_bdt us))"

lemma "ifex_sat_list i = Some u \<Longrightarrow> val_ifex (sat_list_to_bdt u) as \<Longrightarrow> val_ifex i as"
proof(induction i arbitrary: u)
  case (IF v t e)
  show ?case proof(cases "ifex_sat_list e")
    case (Some a)
    note mIH = IF.IH(2)[OF this]
    have ef: "u = (v, False) # a" using IF.prems(1) Some by simp
    have avF: "as v = False" using IF.prems(2) unfolding ef by(simp split: if_splits)
    have "val_ifex (sat_list_to_bdt a) as" using IF.prems(2) unfolding ef using avF by simp
    note mIH = mIH[OF this]
    thus ?thesis using avF by simp
  next
    case None
    obtain a where Some: "ifex_sat_list t = Some a" using None IF.prems(1) by fastforce
    have ef: "u = (v, True) # a" using IF.prems(1) Some None by simp
    have avT: "as v = True" using IF.prems(2) unfolding ef by(simp split: if_splits)
    have "val_ifex (sat_list_to_bdt a) as" using IF.prems(2) unfolding ef using avT by simp
    note mIH = IF.IH(1)[OF Some this]
    thus ?thesis using avT by simp
  qed
qed simp_all

function ifex_sat_list_cover where
"ifex_sat_list_cover e = (if ro_ifex e then
	(case ifex_sat_list e of
		None \<Rightarrow> [] |
		Some l \<Rightarrow> let
			le = sat_list_to_bdt l;
			lm = ifex_ite le Falseif e in
			l # ifex_sat_list_cover lm)
	else [])"
by clarsimp+

lemma sat_list_to_bdt_not_false[simp,intro!]: "sat_list_to_bdt l \<noteq> Falseif"
by(cases l) (clarsimp split: if_splits)+
lemmas [simp,intro!] = sat_list_to_bdt_not_false[symmetric]

lemma sat_list_to_bdt_minimal: "ifex_sat_list u = Some l \<Longrightarrow> ifex_minimal (sat_list_to_bdt l)"
by(induction u arbitrary: l) (clarsimp split: option.splits)+

lemma ifex_var_set_sat_list[simp]: "ifex_var_set (sat_list_to_bdt l) = fst ` set l"
by(induction l) (simp, force)

lemma Ball_fst: "(\<forall>x \<in> S. P (fst x)) \<longleftrightarrow> (\<forall>x y. (x, y) \<in> S \<longrightarrow> P x)" by auto (* let's not name this Ball_pair\<dots> *)

inductive sorted_strict :: "('a :: ord) list \<Rightarrow> bool" where (* < instead of \<le>. Is that really not defined anywhere? *)
  Nil [iff]: "sorted_strict []"
| Cons: "\<forall>y\<in>set xs. x < y \<Longrightarrow> sorted_strict xs \<Longrightarrow> sorted_strict (x # xs)"

lemma sat_list_to_bdt_ordered:
	assumes "ifex_ordered u" "ifex_sat_list u = Some l"
	shows "ifex_ordered (sat_list_to_bdt l)"
proof -
	from assms have  "sorted_strict (map fst l)"
		apply(induction u arbitrary: l)
		apply simp_all[2]
		apply(clarsimp split: option.splits)
		apply(fastforce dest: ifex_sat_list_subset intro!: sorted_strict.intros(2))+
	done
	thus ?thesis
		apply(induction l)
		apply simp
		apply(subst(asm) sorted_strict.simps)
		apply(clarsimp simp: sorted_Cons Ball_fst)
	done
qed

lemma sat_list_to_bdt_ro: "\<lbrakk>ifex_sat_list e = Some x2; ro_ifex e\<rbrakk> \<Longrightarrow> ro_ifex (sat_list_to_bdt x2)"
using sat_list_to_bdt_minimal sat_list_to_bdt_ordered by blast

lemma "(a,b) \<in> {(a,b). P a b} = P a b" by simp

lemma val_ifex_ite_subst: "\<lbrakk>ro_ifex i; ro_ifex t; ro_ifex e\<rbrakk> \<Longrightarrow> val_ifex (ifex_ite i t e) = bf_ite (val_ifex i) (val_ifex t) (val_ifex e)"
using val_ifex_ite by blast

lemma all_false_ass[simp]: "(\<forall>v. \<not> ass v) \<longleftrightarrow> ass = (\<lambda>_. False)" by auto

definition "ifex_unrelated_false e ass \<equiv> \<forall>v. v \<notin> ifex_var_set e \<longrightarrow> ass v = False"
lemma "finite {ass. ifex_unrelated_false e ass}"
apply(unfold ifex_unrelated_false_def)
oops

lemma val_sat_list_bdt_updated[intro]: "ifex_no_twice e \<Longrightarrow> ifex_sat_list e = Some x2 \<Longrightarrow> val_ifex (sat_list_to_bdt x2) (update_assignment x2 any)"
	apply(induction e arbitrary: x2)
	apply(simp)
	apply(simp)
	apply(clarsimp split: option.splits)
	apply(subst ifex_upd_other)
	apply(fastforce dest: ifex_sat_list_subset)
	apply blast
	apply(subst ifex_upd_other)
	apply(fastforce dest: ifex_sat_list_subset)
	apply blast
done

lemma threeofeight1:
	"\<lbrakk>val_ifex e' ass; ro_ifex e;
	ifex_sat_list e = Some x;
	e' = ifex_ite (sat_list_to_bdt x) Falseif e\<rbrakk>
	 \<Longrightarrow> val_ifex e ass"
	apply(clarify, subst (asm) val_ifex_ite_subst)
	apply(simp_all add: sat_list_to_bdt_minimal sat_list_to_bdt_ordered bf_ite_def del: ifex_ite.simps split: if_splits)
done
lemma threeofeight3: (* we already had that lemma, this is just a concise reformulation *)
	"\<lbrakk>ro_ifex e;
	ifex_sat_list e = Some x\<rbrakk> \<Longrightarrow>
	val_ifex e (update_assignment x any)"
by (simp add: ifex_sat_list_SomeD ordered_ifex_no_twiceI)
lemma threeofeight2:
	"\<lbrakk>ro_ifex e;
	ifex_sat_list e = Some x;
	e' = ifex_ite (sat_list_to_bdt x) Falseif e\<rbrakk> \<Longrightarrow>
	\<not>val_ifex e' (update_assignment x any)"
	apply(clarify, subst (asm) val_ifex_ite_subst)
	apply(simp_all add: sat_list_to_bdt_minimal sat_list_to_bdt_ordered bf_ite_def del: ifex_ite.simps split: if_splits)
using ordered_ifex_no_twiceI by blast

lemma threeofeight4: (* closer to what was requested *)
  assumes "ro_ifex e" "ifex_sat_list e = Some x"
  defines "e' \<equiv> ifex_ite (sat_list_to_bdt x) Falseif e"
  shows   "\<exists>s\<in>sat_assns e. s \<notin> sat_assns e'"
proof
  def x' \<equiv> "update_assignment x (const False)"
  from ifex_sat_list_subset[OF assms(2)]
    have "\<forall>v. v\<notin>ifex_var_set e \<longrightarrow> \<not>x' v" unfolding x'_def
    by (intro allI impI, subst update_assignment_notin) auto
  moreover from threeofeight3[OF assms(1,2)] have "val_ifex e x'"
    by (simp add: x'_def)
  ultimately show "x' \<in> sat_assns e" by (simp add: sat_assns_def)
  from threeofeight2[OF assms(1,2) meta_eq_to_obj_eq[OF assms(3)]]
    show "x' \<notin> sat_assns e'" by (simp add: sat_assns_def e'_def x'_def del: ifex_ite.simps)
qed

lemma rimp: "(a \<longrightarrow> b) \<longleftrightarrow> (\<not>b \<longrightarrow> \<not>a)" by blast

termination ifex_sat_list_cover
proof (relation "measure (card \<circ> sat_assns)", simp, clarsimp simp del: ifex_ite.simps)
  case (goal1 e xs)
  note [simp del] = ifex_ite.simps
  def e' \<equiv> "ifex_ite (sat_list_to_bdt xs) Falseif e"
  have "sat_assns e' \<subseteq> sat_assns e"
  proof
    fix s assume "s \<in> sat_assns e'"
    hence "val_ifex e' s" by (simp add: sat_assns_def)
    hence "val_ifex e s" by (rule threeofeight1) (insert goal1, simp_all add: e'_def)
    moreover from ifex_sat_list_subset[OF goal1(1)]
      have "ifex_var_set e' \<subseteq> ifex_var_set e"
      by (auto simp: e'_def dest!: ifex_vars_subset)
    ultimately show "s \<in> sat_assns e" using \<open>s \<in> sat_assns e'\<close>
      by (auto simp: sat_assns_def)
  qed
  moreover from goal1 have "\<exists>s\<in>sat_assns e. s \<notin> sat_assns e'" unfolding e'_def
    by (intro threeofeight4) simp_all
  ultimately have "sat_assns e' \<subset> sat_assns e" by blast
  thus "card (sat_assns e') < card (sat_assns e)"
    by (intro psubset_card_mono) simp_all
qed

value "let xor = IF (0::nat) (IF 1 Falseif Trueif) (IF 1 Trueif Falseif) in ifex_sat_list_cover xor"

lemma bf_ifex_rel_consts[simp,intro!]:
  "(bf_True, Trueif) \<in> bf_ifex_rel"
  "(bf_False, Falseif) \<in> bf_ifex_rel"
by(fastforce simp add: bf_ifex_rel_def)+
lemma bf_ifex_rel_lit[simp,intro!]:
  "(bf_lit v, IFC v Trueif Falseif) \<in> bf_ifex_rel"
by(simp add: bf_ifex_rel_def IFC_def bf_lit_def)

lemma bf_ifex_rel_consts_ensured[simp]:
  "(bf_True,x) \<in> bf_ifex_rel \<longleftrightarrow> (x = Trueif)"
  "(bf_False,x) \<in> bf_ifex_rel \<longleftrightarrow> (x = Falseif)"
  by(auto simp add: bf_ifex_rel_def
             intro: roifex_Trueif_unique roifex_Falseif_unique)

(* reverse of the above *)
lemma bf_ifex_rel_consts_ensured_rev[simp]:
  "(x,Trueif) \<in> bf_ifex_rel \<longleftrightarrow> (x = bf_True)"
  "(x,Falseif) \<in> bf_ifex_rel \<longleftrightarrow> (x = bf_False)"
  unfolding fun_eq_iff
  by(simp_all add: bf_ifex_rel_def)

end


(*  Title:      Fast Fourier Transform
    Author:     Clemens Ballarin <ballarin at in.tum.de>, started 12 April 2005
    Maintainer: Clemens Ballarin <ballarin at in.tum.de>
*)

theory FFT
imports Complex_Main
begin

text {* We formalise a functional implementation of the FFT algorithm
  over the complex numbers, and its inverse.  Both are shown
  equivalent to the usual definitions
  of these operations through Vandermonde matrices.  They are also
  shown to be inverse to each other, more precisely, that composition
  of the inverse and the transformation yield the identity up to a
  scalar.

  The presentation closely follows Section 30.2 of Cormen \textit{et
  al.}, \emph{Introduction to Algorithms}, 2nd edition, MIT Press,
  2003. *}

section {* Preliminaries *}

text {* The following two lemmas are useful for experimenting with the
  transformations, at a vector length of four. *}

lemma Ivl4:
  "{0..<4::nat} = {0, 1, 2, 3}"
proof -
  have "{0..<4::nat} = {0..<Suc (Suc (Suc (Suc 0)))}" by (simp add: eval_nat_numeral)
  also have "... = {0, 1, 2, 3}"
    by (simp add: atLeastLessThanSuc eval_nat_numeral insert_commute)
  finally show ?thesis .
qed

lemma Sum4:
  "(\<Sum>i=0..<4::nat. x i) = x 0 + x 1 + x 2 + x 3"
  by (simp add: Ivl4 eval_nat_numeral)

text {* A number of specialised lemmas for the summation operator,
  where the index set is the natural numbers *}

lemma setsum_add_nat_ivl_singleton:
  assumes less: "m < (n::nat)"
  shows "f m + setsum f {m<..<n} = setsum f {m..<n}"
proof -
  have "f m + setsum f {m<..<n} = setsum f ({m} \<union> {m<..<n})"
    by (simp add: setsum.union_disjoint ivl_disj_int)
  also from less have "... = setsum f {m..<n}"
    by (simp only: ivl_disj_un)
  finally show ?thesis .
qed

lemma setsum_add_split_nat_ivl_singleton:
  assumes less: "m < (n::nat)"
    and g: "!!i. [| m < i; i < n |] ==> g i = f i"
  shows "f m + setsum g {m<..<n} = setsum f {m..<n}"
  using less g
  by(simp add: setsum_add_nat_ivl_singleton cong: setsum.strong_cong)

lemma setsum_add_split_nat_ivl:
  assumes le: "m <= (k::nat)" "k <= n"
    and g: "!!i. [| m <= i; i < k |] ==> g i = f i"
    and h: "!!i. [| k <= i; i < n |] ==> h i = f i"
  shows "setsum g {m..<k} + setsum h {k..<n} = setsum f {m..<n}"
  using le g h by (simp add: setsum_add_nat_ivl cong: setsum.strong_cong)

lemma ivl_splice_Un:
  "{0..<2*n::nat} = (op * 2 ` {0..<n}) \<union> ((%i. Suc (2*i)) ` {0..<n})"
  apply (unfold image_def Bex_def)
  apply auto
  apply arith
  done

lemma ivl_splice_Int:
  "(op * 2 ` {0..<n}) \<inter> ((%i. Suc (2*i)) ` {0..<n}) = {}"
  by auto arith

lemma double_inj_on:
  "inj_on (%i. 2*i::nat) A"
  by (simp add: inj_onI)

lemma Suc_double_inj_on:
  "inj_on (%i. Suc (2*i)) A"
  by (rule inj_onI) simp

lemma setsum_splice:
  "(\<Sum>i::nat = 0..<2*n. f i) = (\<Sum>i = 0..<n. f (2*i)) + (\<Sum>i = 0..<n. f (2*i+1))"
proof -
  have "(\<Sum>i::nat = 0..<2*n. f i) =
    setsum f (op * 2 ` {0..<n}) + setsum f ((%i. 2*i+1) ` {0..<n})"
    by (simp add: ivl_splice_Un ivl_splice_Int setsum.union_disjoint)
  also have "... = (\<Sum>i = 0..<n. f (2*i)) + (\<Sum>i = 0..<n. f (2*i+1))"
    by (simp add: setsum.reindex [OF double_inj_on]
      setsum.reindex [OF Suc_double_inj_on])
  finally show ?thesis .
qed

section {* Complex Roots of Unity *}

text {* The function @{term cis} from the complex library returns the
  point on the unity circle corresponding to the argument angle.  It
  is the base for our definition of @{text root}.  The main property,
  De Moirve's formula is already there in the library. *}

definition root :: "nat => complex" where
  "root n == cis (2*pi/(real (n::nat)))"

lemma sin_periodic_pi_diff [simp]: "sin (x - pi) = - sin x"
  by (simp add: sin_diff)

lemma sin_cos_between_zero_two_pi:
  assumes 0: "0 < x" and pi: "x < 2 * pi"
  shows "sin x \<noteq> 0 \<or> cos x \<noteq> 1"
proof -
  { assume "0 < x" and "x < pi"
    then have "sin x \<noteq> 0" by (auto dest: sin_gt_zero_pi) }
  moreover
  { assume "x = pi"
    then have "cos x \<noteq> 1" by simp }
  moreover
  { assume pi1: "pi < x" and pi2: "x < 2 * pi"
    then have "0 < x - pi" and "x - pi < pi" by arith+
    then have "sin (x - pi) \<noteq> 0" by (auto dest: sin_gt_zero_pi)
    with pi1 pi2 have "sin x \<noteq> 0" by simp }
  ultimately show ?thesis using 0 pi by arith
qed

subsection {* Basic Lemmas *}

lemma root_nonzero: "root n \<noteq> 0"
  by (auto simp add: complex_eq_iff root_def dest: sin_zero_abs_cos_one)

lemma root_unity: "root n ^ n = 1"
  by (simp add: complex_eq_iff root_def DeMoivre)

lemma root_cancel: "0 < d ==> root (d * n) ^ (d * k) = root n ^ k"
  apply (unfold root_def)
  apply (simp add: DeMoivre)
  done

lemma root_summation:
  assumes k: "0 < k" "k < n"
  shows "(\<Sum>i=0..<n. (root n ^ k) ^ i) = 0"
proof -
  from k have real0: "0 < real k * (2 * pi) / real n"
    by (simp add: zero_less_divide_iff
      mult_strict_right_mono [where a = 0, simplified])
  from k mult_strict_right_mono [where a = "real k" and
    b = "real n" and c = "2 * pi / real n", simplified]
  have realk: "real k * (2 * pi) / real n < 2 * pi"
    by (simp add: zero_less_divide_iff)
  txt {* Main part of the proof *}
  have "(\<Sum>i=0..<n. (root n ^ k) ^ i) =
    ((root n ^ k) ^ n - 1) / (root n ^ k - 1)"
    unfolding atLeast0LessThan
    apply (rule geometric_sum)
    apply (unfold root_def)
    apply (simp add: DeMoivre)
    using real0 realk sin_cos_between_zero_two_pi
    apply (auto simp add: complex_eq_iff)
    done
  also have "... = ((root n ^ n) ^ k - 1) / (root n ^ k - 1)"
    by (simp add: power_mult [THEN sym] ac_simps)
  also have "... = 0"
    by (simp add: root_unity)
  finally show ?thesis .
qed

lemma root_summation_inv:
  assumes k: "0 < k" "k < n"
  shows "(\<Sum>i=0..<n. ((1 / root n) ^ k) ^ i) = 0"
proof -
  from k have real0: "0 < real k * (2 * pi) / real n"
    by (simp add: zero_less_divide_iff
      mult_strict_right_mono [where a = 0, simplified])
  from k mult_strict_right_mono [where a = "real k" and
    b = "real n" and c = "2 * pi / real n", simplified]
  have realk: "real k * (2 * pi) / real n < 2 * pi"
    by (simp add: zero_less_divide_iff)
  txt {* Main part of the proof *}
  have "(\<Sum>i=0..<n. ((1 / root n) ^ k) ^ i) =
    (((1 / root n) ^ k) ^ n - 1) / ((1 / root n) ^ k - 1)"
    unfolding atLeast0LessThan
    apply (rule geometric_sum)
    apply (simp add: nonzero_inverse_eq_divide [THEN sym] root_nonzero)
    apply (unfold root_def)
    apply (simp add: DeMoivre)
    using real0 realk sin_cos_between_zero_two_pi
    apply (auto simp add: complex_eq_iff)
    done
  also have "... = (((1 / root n) ^ n) ^ k - 1) / ((1 / root n) ^ k - 1)"
    by (simp add: power_mult [THEN sym] ac_simps)
  also have "... = 0"
    by (simp add: power_divide root_unity)
  finally show ?thesis .
qed

lemma root0 [simp]:
  "root 0 = 1"
  by (simp add: complex_eq_iff root_def)

lemma root1 [simp]:
  "root 1 = 1"
  by (simp add: complex_eq_iff root_def)

lemma root2 [simp]:
  "root 2 = -1"
  by (simp add: complex_eq_iff root_def)

lemma root4 [simp]:
  "root 4 = ii"
  by (simp add: complex_eq_iff root_def)

subsection {* Derived Lemmas *}

lemma root_cancel1:
  "root (2 * m) ^ (i * (2 * j)) = root m ^ (i * j)"
proof -
  have "root (2 * m) ^ (i * (2 * j)) = root (2 * m) ^ (2 * (i * j))"
    by (simp add: ac_simps)
  also have "... = root m ^ (i * j)"
    by (simp add: root_cancel)
  finally show ?thesis .
qed

lemma root_cancel2:
  "0 < n ==> root (2 * n) ^ n = - 1"
  txt {* Note the space between @{text "-"} and @{text "1"}. *}
  using root_cancel [where n = 2 and k = 1]
  by (simp add: complex_eq_iff ac_simps)

section {* Discrete Fourier Transformation *}

text {*
  We define operations  @{text DFT} and @{text IDFT} for the discrete
  Fourier Transform and its inverse.  Vectors are simply functions of
  type @{text "nat => complex"}. *}

text {*
  @{text "DFT n a"} is the transform of vector @{text a}
  of length @{text n}, @{text IDFT} its inverse. *}

definition DFT :: "nat => (nat => complex) => (nat => complex)" where
  "DFT n a == (%i. \<Sum>j=0..<n. (root n) ^ (i * j) * (a j))"

definition IDFT :: "nat => (nat => complex) => (nat => complex)" where
  "IDFT n a == (%i. (\<Sum>k=0..<n. (a k) / (root n) ^ (i * k)))"

schematic_lemma "map (DFT 4 a) [0, 1, 2, 3] = ?x"
  by(simp add: DFT_def Sum4)

text {* Lemmas for the correctness proof. *}

lemma DFT_lower:
  "DFT (2 * m) a i =
  DFT m (%i. a (2 * i)) i +
  (root (2 * m)) ^ i * DFT m (%i. a (2 * i + 1)) i"
proof (unfold DFT_def)
  have "(\<Sum>j = 0..<2 * m. root (2 * m) ^ (i * j) * a j) =
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j)) * a (2 * j)) +
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j + 1)) * a (2 * j + 1))"
    (is "?s = _")
    by (simp add: setsum_splice)
  also have "... = (\<Sum>j = 0..<m. root m ^ (i * j) * a (2 * j)) +
    root (2 * m) ^ i *
    (\<Sum>j = 0..<m. root m ^ (i * j) * a (2 * j + 1))"
    (is "_ = ?t")
    txt {* First pair of sums *}
    apply (simp add: root_cancel1)
    txt {* Second pair of sums *}
    apply (simp add: setsum_right_distrib)
    apply (simp add: power_add)
    apply (simp add: root_cancel1)
    apply (simp add: ac_simps)
    done
  finally show "?s = ?t" .
qed

lemma DFT_upper:
  assumes mbound: "0 < m" and ibound: "m <= i"
  shows "DFT (2 * m) a i =
    DFT m (%i. a (2 * i)) (i - m) -
    root (2 * m) ^ (i - m) * DFT m (%i. a (2 * i + 1)) (i - m)"
proof (unfold DFT_def)
  have "(\<Sum>j = 0..<2 * m. root (2 * m) ^ (i * j) * a j) =
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j)) * a (2 * j)) +
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j + 1)) * a (2 * j + 1))"
    (is "?s = _")
    by (simp add: setsum_splice)
  also have "... =
    (\<Sum>j = 0..<m. root m ^ ((i - m) * j) * a (2 * j)) -
    root (2 * m) ^ (i - m) *
    (\<Sum>j = 0..<m. root m ^ ((i - m) * j) * a (2 * j + 1))"
    (is "_ = ?t")
    txt {* First pair of sums *}
    apply (simp add: root_cancel1)
    apply (simp add: root_unity ibound root_nonzero power_diff power_mult)
    txt {* Second pair of sums *}
    apply (simp add: mbound root_cancel2)
    apply (simp add: setsum_right_distrib)
    apply (simp add: power_add)
    apply (simp add: root_cancel1)
    apply (simp add: power_mult)
    apply (simp add: ac_simps)
    done
  finally show "?s = ?t" .
qed

lemma IDFT_lower:
  "IDFT (2 * m) a i =
  IDFT m (%i. a (2 * i)) i +
  (1 / root (2 * m)) ^ i * IDFT m (%i. a (2 * i + 1)) i"
proof (unfold IDFT_def)
  have "(\<Sum>j = 0..<2 * m. a j / root (2 * m) ^ (i * j)) =
    (\<Sum>j = 0..<m. a (2 * j) / root (2 * m) ^ (i * (2 * j))) +
    (\<Sum>j = 0..<m. a (2 * j + 1) / root (2 * m) ^ (i * (2 * j + 1)))"
    (is "?s = _")
    by (simp add: setsum_splice)
  also have "... = (\<Sum>j = 0..<m. a (2 * j) / root m ^ (i * j)) +
    (1 / root (2 * m)) ^ i *
    (\<Sum>j = 0..<m. a (2 * j + 1) / root m ^ (i * j))"
    (is "_ = ?t")
    txt {* First pair of sums *}
    apply (simp add: root_cancel1)
    txt {* Second pair of sums *}
    apply (simp add: setsum_right_distrib)
    apply (simp add: power_add)
    apply (simp add: nonzero_power_divide root_nonzero)
    apply (simp add: root_cancel1)
    done
  finally show "?s = ?t" .
qed

lemma IDFT_upper:
  assumes mbound: "0 < m" and ibound: "m <= i"
  shows "IDFT (2 * m) a i =
    IDFT m (%i. a (2 * i)) (i - m) -
    (1 / root (2 * m)) ^ (i - m) *
    IDFT m (%i. a (2 * i + 1)) (i - m)"
proof (unfold IDFT_def)
  have "(\<Sum>j = 0..<2 * m. a j / root (2 * m) ^ (i * j)) =
    (\<Sum>j = 0..<m. a (2 * j) / root (2 * m) ^ (i * (2 * j))) +
    (\<Sum>j = 0..<m. a (2 * j + 1) / root (2 * m) ^ (i * (2 * j + 1)))"
    (is "?s = _")
    by (simp add: setsum_splice)
  also have "... =
    (\<Sum>j = 0..<m. a (2 * j) / root m ^ ((i - m) * j)) -
    (1 / root (2 * m)) ^ (i - m) *
    (\<Sum>j = 0..<m. a (2 * j + 1) / root m ^ ((i - m) * j))"
    (is "_ = ?t")
    txt {* First pair of sums *}
    apply (simp add: root_cancel1)
    apply (simp add: root_unity ibound root_nonzero power_diff power_mult)
    txt {* Second pair of sums *}
    apply (simp add: nonzero_power_divide root_nonzero)
    apply (simp add: mbound root_cancel2)
    apply (simp add: setsum_divide_distrib)
    apply (simp add: power_add)
    apply (simp add: root_cancel1)
    apply (simp add: power_mult)
    apply (simp add: ac_simps)
    done
  finally show "?s = ?t" .
qed

text {* @{text DFT} und @{text IDFT} are inverses. *}

declare divide_divide_eq_right [simp del]
  divide_divide_eq_left [simp del]

lemma power_diff_inverse:
  assumes nz: "(a::'a::field) ~= 0"
  shows "m <= n ==> (inverse a) ^ (n-m) = (a^m) / (a^n)"
  apply (induct n m rule: diff_induct)
    apply (simp add: nonzero_power_inverse
      nonzero_inverse_eq_divide [THEN sym] nz)
   apply simp
  apply (simp add: nz)
  done

lemma power_diff_rev_if:
  assumes nz: "(a::'a::field) ~= 0"
  shows "(a^m) / (a^n) = (if n <= m then a ^ (m-n) else (1/a) ^ (n-m))"
proof (cases "n <= m")
  case True with nz show ?thesis
    by (simp add: power_diff)
next
  case False with nz show ?thesis
    by (simp add: power_diff_inverse nonzero_inverse_eq_divide [THEN sym])
qed

lemma power_divides_special:
  "(a::'a::field) ~= 0 ==>
  a ^ (i * j) / a ^ (k * i) = (a ^ j / a ^ k) ^ i"
  by (simp add: nonzero_power_divide power_mult [THEN sym] ac_simps)

theorem DFT_inverse:
  assumes i_less: "i < n"
  shows  "IDFT n (DFT n a) i = of_nat n * a i"
  using [[linarith_split_limit = 0]]
  apply (unfold DFT_def IDFT_def)
  apply (simp add: setsum_divide_distrib)
  apply (subst setsum.commute)
  apply (simp only: times_divide_eq_left [THEN sym])
  apply (simp only: power_divides_special [OF root_nonzero])
  apply (simp add: power_diff_rev_if root_nonzero)
  apply (simp add: setsum_divide_distrib [THEN sym]
    setsum_left_distrib [THEN sym])
  proof -
    from i_less have i_diff: "!!k. i - k < n" by arith
    have diff_i: "!!k. k < n ==> k - i < n" by arith

    let ?sum = "%i j n. setsum (op ^ (if i <= j then root n ^ (j - i)
                  else (1 / root n) ^ (i - j))) {0..<n} * a j"
    let ?sum1 = "%i j n. setsum (op ^ (root n ^ (j - i))) {0..<n} * a j"
    let ?sum2 = "%i j n. setsum (op ^ ((1 / root n) ^ (i - j))) {0..<n} * a j"

    from i_less have "(\<Sum>j = 0..<n. ?sum i j n) =
      (\<Sum>j = 0..<i. ?sum2 i j n) + (\<Sum>j = i..<n. ?sum1 i j n)"
      (is "?s = _")
      by (simp add: root_summation_inv nat_dvd_not_less
        setsum_add_split_nat_ivl [where f = "%j. ?sum i j n"])
    also from i_less i_diff
    have "... = (\<Sum>j = i..<n. ?sum1 i j n)"
      by (simp add: root_summation_inv nat_dvd_not_less)
    also from i_less have "... =
      (\<Sum>j\<in>{i} \<union> {i<..<n}. ?sum1 i j n)"
      by (simp only: ivl_disj_un)
    also have "... =
      (?sum1 i i n + (\<Sum>j\<in>{i<..<n}. ?sum1 i j n))"
      by (simp add: setsum.union_disjoint ivl_disj_int)
    also from i_less diff_i have "... = ?sum1 i i n"
      by (simp add: root_summation nat_dvd_not_less)
    also from i_less have "... = of_nat n * a i" (is "_ = ?t")
      by simp
    finally show "?s = ?t" .
  qed

section {* Discrete, Fast Fourier Transformation *}

text {* @{text "FFT k a"} is the transform of vector @{text a}
  of length @{text "2 ^ k"}, @{text IFFT} its inverse. *}

primrec FFT :: "nat => (nat => complex) => (nat => complex)" where
  "FFT 0 a = a"
| "FFT (Suc k) a =
     (let (x, y) = (FFT k (%i. a (2*i)), FFT k (%i. a (2*i+1)))
      in (%i. if i < 2^k
            then x i + (root (2 ^ (Suc k))) ^ i * y i
            else x (i- 2^k) - (root (2 ^ (Suc k))) ^ (i- 2^k) * y (i- 2^k)))"

primrec IFFT :: "nat => (nat => complex) => (nat => complex)" where
  "IFFT 0 a = a"
| "IFFT (Suc k) a =
     (let (x, y) = (IFFT k (%i. a (2*i)), IFFT k (%i. a (2*i+1)))
      in (%i. if i < 2^k
            then x i + (1 / root (2 ^ (Suc k))) ^ i * y i
            else x (i - 2^k) -
              (1 / root (2 ^ (Suc k))) ^ (i - 2^k) * y (i - 2^k)))"

text {* Finally, for vectors of length @{text "2 ^ k"},
  @{text DFT} and @{text FFT}, and @{text IDFT} and
  @{text IFFT} are equivalent. *}

theorem DFT_FFT:
  "!!a i. i < 2 ^ k ==> DFT (2 ^ k) a i = FFT k a i"
proof (induct k)
  case 0
  then show ?case by (simp add: DFT_def)
next
  case (Suc k)
  assume i: "i < 2 ^ Suc k"
  show ?case proof (cases "i < 2 ^ k")
    case True
    then show ?thesis apply simp apply (simp add: DFT_lower)
      apply (simp add: Suc) done
  next
    case False
    from i have "i - 2 ^ k < 2 ^ k" by simp
    with False i show ?thesis apply simp apply (simp add: DFT_upper)
      apply (simp add: Suc) done
  qed
qed

theorem IDFT_IFFT:
  "!!a i. i < 2 ^ k ==> IDFT (2 ^ k) a i = IFFT k a i"
proof (induct k)
  case 0
  then show ?case by (simp add: IDFT_def)
next
  case (Suc k)
  assume i: "i < 2 ^ Suc k"
  show ?case proof (cases "i < 2 ^ k")
    case True
    then show ?thesis apply simp apply (simp add: IDFT_lower)
      apply (simp add: Suc) done
  next
    case False
    from i have "i - 2 ^ k < 2 ^ k" by simp
    with False i show ?thesis apply simp apply (simp add: IDFT_upper)
      apply (simp add: Suc) done
  qed
qed

schematic_lemma "map (FFT (Suc (Suc 0)) a) [0, 1, 2, 3] = ?x"
  by simp

end