(*  Title:      HOL/Library/FSet.thy
    Author:     Ondrej Kuncar, TU Muenchen
    Author:     Cezary Kaliszyk and Christian Urban
    Author:     Andrei Popescu, TU Muenchen
*)

section \<open>Type of finite sets defined as a subtype of sets\<close>

theory FSet
imports Main Countable
begin

subsection \<open>Definition of the type\<close>

typedef 'a fset = "{A :: 'a set. finite A}"  morphisms fset Abs_fset
by auto

setup_lifting type_definition_fset

subsection \<open>Basic operations and type class instantiations\<close>

(* FIXME transfer and right_total vs. bi_total *)
instantiation fset :: (finite) finite
begin
instance by (standard; transfer; simp)
end

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

lift_definition bot_fset :: "'a fset" is "{}" parametric empty_transfer by simp

lift_definition less_eq_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" is subset_eq parametric subset_transfer
  .

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

lemma less_fset_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows "((pcr_fset A) ===> (pcr_fset A) ===> (=)) (\<subset>) (<)"
  unfolding less_fset_def[abs_def] psubset_eq[abs_def] by transfer_prover

lift_definition sup_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is union parametric union_transfer
  by simp

lift_definition inf_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is inter parametric inter_transfer
  by simp

lift_definition minus_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is minus parametric Diff_transfer
  by simp

instance
  by (standard; transfer; auto)+

end

abbreviation fempty :: "'a fset" ("{||}") where "{||} \<equiv> bot"
abbreviation fsubset_eq :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subseteq>|" 50) where "xs |\<subseteq>| ys \<equiv> xs \<le> ys"
abbreviation fsubset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subset>|" 50) where "xs |\<subset>| ys \<equiv> xs < ys"
abbreviation funion :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<union>|" 65) where "xs |\<union>| ys \<equiv> sup xs ys"
abbreviation finter :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<inter>|" 65) where "xs |\<inter>| ys \<equiv> inf xs ys"
abbreviation fminus :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|-|" 65) where "xs |-| ys \<equiv> minus xs ys"

instantiation fset :: (equal) equal
begin
definition "HOL.equal A B \<longleftrightarrow> A |\<subseteq>| B \<and> B |\<subseteq>| A"
instance by intro_classes (auto simp add: equal_fset_def)
end

instantiation fset :: (type) conditionally_complete_lattice
begin

context includes lifting_syntax
begin

lemma right_total_Inf_fset_transfer:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set (rel_set A) ===> rel_set A)
    (\<lambda>S. if finite (\<Inter>S \<inter> Collect (Domainp A)) then \<Inter>S \<inter> Collect (Domainp A) else {})
      (\<lambda>S. if finite (Inf S) then Inf S else {})"
    by transfer_prover

lemma Inf_fset_transfer:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Inf A) then Inf A else {})
    (\<lambda>A. if finite (Inf A) then Inf A else {})"
  by transfer_prover

lift_definition Inf_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Inf A) then Inf A else {}"
parametric right_total_Inf_fset_transfer Inf_fset_transfer by simp

lemma Sup_fset_transfer:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Sup A) then Sup A else {})
  (\<lambda>A. if finite (Sup A) then Sup A else {})" by transfer_prover

lift_definition Sup_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Sup A) then Sup A else {}"
parametric Sup_fset_transfer by simp

lemma finite_Sup: "\<exists>z. finite z \<and> (\<forall>a. a \<in> X \<longrightarrow> a \<le> z) \<Longrightarrow> finite (Sup X)"
by (auto intro: finite_subset)

lemma transfer_bdd_below[transfer_rule]: "(rel_set (pcr_fset (=)) ===> (=)) bdd_below bdd_below"
  by auto

end

instance
proof
  fix x z :: "'a fset"
  fix X :: "'a fset set"
  {
    assume "x \<in> X" "bdd_below X"
    then show "Inf X |\<subseteq>| x" by transfer auto
  next
    assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> z |\<subseteq>| x)"
    then show "z |\<subseteq>| Inf X" by transfer (clarsimp, blast)
  next
    assume "x \<in> X" "bdd_above X"
    then obtain z where "x \<in> X" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
      by (auto simp: bdd_above_def)
    then show "x |\<subseteq>| Sup X"
      by transfer (auto intro!: finite_Sup)
  next
    assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
    then show "Sup X |\<subseteq>| z" by transfer (clarsimp, blast)
  }
qed
end

instantiation fset :: (finite) complete_lattice
begin

lift_definition top_fset :: "'a fset" is UNIV parametric right_total_UNIV_transfer UNIV_transfer
  by simp

instance
  by (standard; transfer; auto)

end

instantiation fset :: (finite) complete_boolean_algebra
begin

lift_definition uminus_fset :: "'a fset \<Rightarrow> 'a fset" is uminus
  parametric right_total_Compl_transfer Compl_transfer by simp

instance
  by (standard; transfer) (simp_all add: Inf_Sup Diff_eq)
end

abbreviation fUNIV :: "'a::finite fset" where "fUNIV \<equiv> top"
abbreviation fuminus :: "'a::finite fset \<Rightarrow> 'a fset" ("|-| _" [81] 80) where "|-| x \<equiv> uminus x"

declare top_fset.rep_eq[simp]

subsection \<open>Other operations\<close>

lift_definition finsert :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is insert parametric Lifting_Set.insert_transfer
  by simp

syntax
  "_insert_fset"     :: "args => 'a fset"  ("{|(_)|}")

translations
  "{|x, xs|}" == "CONST finsert x {|xs|}"
  "{|x|}"     == "CONST finsert x {||}"

lift_definition fmember :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<in>|" 50) is Set.member
  parametric member_transfer .

lemma fmember_iff_member_fset: "x |\<in>| A \<longleftrightarrow> x \<in> fset A"
  by (rule fmember.rep_eq)

abbreviation notin_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<notin>|" 50) where "x |\<notin>| S \<equiv> \<not> (x |\<in>| S)"

context includes lifting_syntax
begin

lift_definition ffilter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is Set.filter
  parametric Lifting_Set.filter_transfer unfolding Set.filter_def by simp

lift_definition fPow :: "'a fset \<Rightarrow> 'a fset fset" is Pow parametric Pow_transfer
by (simp add: finite_subset)

lift_definition fcard :: "'a fset \<Rightarrow> nat" is card parametric card_transfer .

lift_definition fimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset" (infixr "|`|" 90) is image
  parametric image_transfer by simp

lift_definition fthe_elem :: "'a fset \<Rightarrow> 'a" is the_elem .

lift_definition fbind :: "'a fset \<Rightarrow> ('a \<Rightarrow> 'b fset) \<Rightarrow> 'b fset" is Set.bind parametric bind_transfer
by (simp add: Set.bind_def)

lift_definition ffUnion :: "'a fset fset \<Rightarrow> 'a fset" is Union parametric Union_transfer by simp

lift_definition fBall :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Ball parametric Ball_transfer .
lift_definition fBex :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Bex parametric Bex_transfer .

lift_definition ffold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a fset \<Rightarrow> 'b" is Finite_Set.fold .

lift_definition fset_of_list :: "'a list \<Rightarrow> 'a fset" is set by (rule finite_set)

lift_definition sorted_list_of_fset :: "'a::linorder fset \<Rightarrow> 'a list" is sorted_list_of_set .

subsection \<open>Transferred lemmas from Set.thy\<close>

lemmas fset_eqI = set_eqI[Transfer.transferred]
lemmas fset_eq_iff[no_atp] = set_eq_iff[Transfer.transferred]
lemmas fBallI[intro!] = ballI[Transfer.transferred]
lemmas fbspec[dest?] = bspec[Transfer.transferred]
lemmas fBallE[elim] = ballE[Transfer.transferred]
lemmas fBexI[intro] = bexI[Transfer.transferred]
lemmas rev_fBexI[intro?] = rev_bexI[Transfer.transferred]
lemmas fBexCI = bexCI[Transfer.transferred]
lemmas fBexE[elim!] = bexE[Transfer.transferred]
lemmas fBall_triv[simp] = ball_triv[Transfer.transferred]
lemmas fBex_triv[simp] = bex_triv[Transfer.transferred]
lemmas fBex_triv_one_point1[simp] = bex_triv_one_point1[Transfer.transferred]
lemmas fBex_triv_one_point2[simp] = bex_triv_one_point2[Transfer.transferred]
lemmas fBex_one_point1[simp] = bex_one_point1[Transfer.transferred]
lemmas fBex_one_point2[simp] = bex_one_point2[Transfer.transferred]
lemmas fBall_one_point1[simp] = ball_one_point1[Transfer.transferred]
lemmas fBall_one_point2[simp] = ball_one_point2[Transfer.transferred]
lemmas fBall_conj_distrib = ball_conj_distrib[Transfer.transferred]
lemmas fBex_disj_distrib = bex_disj_distrib[Transfer.transferred]
lemmas fBall_cong[fundef_cong] = ball_cong[Transfer.transferred]
lemmas fBex_cong[fundef_cong] = bex_cong[Transfer.transferred]
lemmas fsubsetI[intro!] = subsetI[Transfer.transferred]
lemmas fsubsetD[elim, intro?] = subsetD[Transfer.transferred]
lemmas rev_fsubsetD[no_atp,intro?] = rev_subsetD[Transfer.transferred]
lemmas fsubsetCE[no_atp,elim] = subsetCE[Transfer.transferred]
lemmas fsubset_eq[no_atp] = subset_eq[Transfer.transferred]
lemmas contra_fsubsetD[no_atp] = contra_subsetD[Transfer.transferred]
lemmas fsubset_refl = subset_refl[Transfer.transferred]
lemmas fsubset_trans = subset_trans[Transfer.transferred]
lemmas fset_rev_mp = rev_subsetD[Transfer.transferred]
lemmas fset_mp = subsetD[Transfer.transferred]
lemmas fsubset_not_fsubset_eq[code] = subset_not_subset_eq[Transfer.transferred]
lemmas eq_fmem_trans = eq_mem_trans[Transfer.transferred]
lemmas fsubset_antisym[intro!] = subset_antisym[Transfer.transferred]
lemmas fequalityD1 = equalityD1[Transfer.transferred]
lemmas fequalityD2 = equalityD2[Transfer.transferred]
lemmas fequalityE = equalityE[Transfer.transferred]
lemmas fequalityCE[elim] = equalityCE[Transfer.transferred]
lemmas eqfset_imp_iff = eqset_imp_iff[Transfer.transferred]
lemmas eqfelem_imp_iff = eqelem_imp_iff[Transfer.transferred]
lemmas fempty_iff[simp] = empty_iff[Transfer.transferred]
lemmas fempty_fsubsetI[iff] = empty_subsetI[Transfer.transferred]
lemmas equalsffemptyI = equals0I[Transfer.transferred]
lemmas equalsffemptyD = equals0D[Transfer.transferred]
lemmas fBall_fempty[simp] = ball_empty[Transfer.transferred]
lemmas fBex_fempty[simp] = bex_empty[Transfer.transferred]
lemmas fPow_iff[iff] = Pow_iff[Transfer.transferred]
lemmas fPowI = PowI[Transfer.transferred]
lemmas fPowD = PowD[Transfer.transferred]
lemmas fPow_bottom = Pow_bottom[Transfer.transferred]
lemmas fPow_top = Pow_top[Transfer.transferred]
lemmas fPow_not_fempty = Pow_not_empty[Transfer.transferred]
lemmas finter_iff[simp] = Int_iff[Transfer.transferred]
lemmas finterI[intro!] = IntI[Transfer.transferred]
lemmas finterD1 = IntD1[Transfer.transferred]
lemmas finterD2 = IntD2[Transfer.transferred]
lemmas finterE[elim!] = IntE[Transfer.transferred]
lemmas funion_iff[simp] = Un_iff[Transfer.transferred]
lemmas funionI1[elim?] = UnI1[Transfer.transferred]
lemmas funionI2[elim?] = UnI2[Transfer.transferred]
lemmas funionCI[intro!] = UnCI[Transfer.transferred]
lemmas funionE[elim!] = UnE[Transfer.transferred]
lemmas fminus_iff[simp] = Diff_iff[Transfer.transferred]
lemmas fminusI[intro!] = DiffI[Transfer.transferred]
lemmas fminusD1 = DiffD1[Transfer.transferred]
lemmas fminusD2 = DiffD2[Transfer.transferred]
lemmas fminusE[elim!] = DiffE[Transfer.transferred]
lemmas finsert_iff[simp] = insert_iff[Transfer.transferred]
lemmas finsertI1 = insertI1[Transfer.transferred]
lemmas finsertI2 = insertI2[Transfer.transferred]
lemmas finsertE[elim!] = insertE[Transfer.transferred]
lemmas finsertCI[intro!] = insertCI[Transfer.transferred]
lemmas fsubset_finsert_iff = subset_insert_iff[Transfer.transferred]
lemmas finsert_ident = insert_ident[Transfer.transferred]
lemmas fsingletonI[intro!,no_atp] = singletonI[Transfer.transferred]
lemmas fsingletonD[dest!,no_atp] = singletonD[Transfer.transferred]
lemmas fsingleton_iff = singleton_iff[Transfer.transferred]
lemmas fsingleton_inject[dest!] = singleton_inject[Transfer.transferred]
lemmas fsingleton_finsert_inj_eq[iff,no_atp] = singleton_insert_inj_eq[Transfer.transferred]
lemmas fsingleton_finsert_inj_eq'[iff,no_atp] = singleton_insert_inj_eq'[Transfer.transferred]
lemmas fsubset_fsingletonD = subset_singletonD[Transfer.transferred]
lemmas fminus_single_finsert = Diff_single_insert[Transfer.transferred]
lemmas fdoubleton_eq_iff = doubleton_eq_iff[Transfer.transferred]
lemmas funion_fsingleton_iff = Un_singleton_iff[Transfer.transferred]
lemmas fsingleton_funion_iff = singleton_Un_iff[Transfer.transferred]
lemmas fimage_eqI[simp, intro] = image_eqI[Transfer.transferred]
lemmas fimageI = imageI[Transfer.transferred]
lemmas rev_fimage_eqI = rev_image_eqI[Transfer.transferred]
lemmas fimageE[elim!] = imageE[Transfer.transferred]
lemmas Compr_fimage_eq = Compr_image_eq[Transfer.transferred]
lemmas fimage_funion = image_Un[Transfer.transferred]
lemmas fimage_iff = image_iff[Transfer.transferred]
lemmas fimage_fsubset_iff[no_atp] = image_subset_iff[Transfer.transferred]
lemmas fimage_fsubsetI = image_subsetI[Transfer.transferred]
lemmas fimage_ident[simp] = image_ident[Transfer.transferred]
lemmas if_split_fmem1 = if_split_mem1[Transfer.transferred]
lemmas if_split_fmem2 = if_split_mem2[Transfer.transferred]
lemmas pfsubsetI[intro!,no_atp] = psubsetI[Transfer.transferred]
lemmas pfsubsetE[elim!,no_atp] = psubsetE[Transfer.transferred]
lemmas pfsubset_finsert_iff = psubset_insert_iff[Transfer.transferred]
lemmas pfsubset_eq = psubset_eq[Transfer.transferred]
lemmas pfsubset_imp_fsubset = psubset_imp_subset[Transfer.transferred]
lemmas pfsubset_trans = psubset_trans[Transfer.transferred]
lemmas pfsubsetD = psubsetD[Transfer.transferred]
lemmas pfsubset_fsubset_trans = psubset_subset_trans[Transfer.transferred]
lemmas fsubset_pfsubset_trans = subset_psubset_trans[Transfer.transferred]
lemmas pfsubset_imp_ex_fmem = psubset_imp_ex_mem[Transfer.transferred]
lemmas fimage_fPow_mono = image_Pow_mono[Transfer.transferred]
lemmas fimage_fPow_surj = image_Pow_surj[Transfer.transferred]
lemmas fsubset_finsertI = subset_insertI[Transfer.transferred]
lemmas fsubset_finsertI2 = subset_insertI2[Transfer.transferred]
lemmas fsubset_finsert = subset_insert[Transfer.transferred]
lemmas funion_upper1 = Un_upper1[Transfer.transferred]
lemmas funion_upper2 = Un_upper2[Transfer.transferred]
lemmas funion_least = Un_least[Transfer.transferred]
lemmas finter_lower1 = Int_lower1[Transfer.transferred]
lemmas finter_lower2 = Int_lower2[Transfer.transferred]
lemmas finter_greatest = Int_greatest[Transfer.transferred]
lemmas fminus_fsubset = Diff_subset[Transfer.transferred]
lemmas fminus_fsubset_conv = Diff_subset_conv[Transfer.transferred]
lemmas fsubset_fempty[simp] = subset_empty[Transfer.transferred]
lemmas not_pfsubset_fempty[iff] = not_psubset_empty[Transfer.transferred]
lemmas finsert_is_funion = insert_is_Un[Transfer.transferred]
lemmas finsert_not_fempty[simp] = insert_not_empty[Transfer.transferred]
lemmas fempty_not_finsert = empty_not_insert[Transfer.transferred]
lemmas finsert_absorb = insert_absorb[Transfer.transferred]
lemmas finsert_absorb2[simp] = insert_absorb2[Transfer.transferred]
lemmas finsert_commute = insert_commute[Transfer.transferred]
lemmas finsert_fsubset[simp] = insert_subset[Transfer.transferred]
lemmas finsert_inter_finsert[simp] = insert_inter_insert[Transfer.transferred]
lemmas finsert_disjoint[simp,no_atp] = insert_disjoint[Transfer.transferred]
lemmas disjoint_finsert[simp,no_atp] = disjoint_insert[Transfer.transferred]
lemmas fimage_fempty[simp] = image_empty[Transfer.transferred]
lemmas fimage_finsert[simp] = image_insert[Transfer.transferred]
lemmas fimage_constant = image_constant[Transfer.transferred]
lemmas fimage_constant_conv = image_constant_conv[Transfer.transferred]
lemmas fimage_fimage = image_image[Transfer.transferred]
lemmas finsert_fimage[simp] = insert_image[Transfer.transferred]
lemmas fimage_is_fempty[iff] = image_is_empty[Transfer.transferred]
lemmas fempty_is_fimage[iff] = empty_is_image[Transfer.transferred]
lemmas fimage_cong = image_cong[Transfer.transferred]
lemmas fimage_finter_fsubset = image_Int_subset[Transfer.transferred]
lemmas fimage_fminus_fsubset = image_diff_subset[Transfer.transferred]
lemmas finter_absorb = Int_absorb[Transfer.transferred]
lemmas finter_left_absorb = Int_left_absorb[Transfer.transferred]
lemmas finter_commute = Int_commute[Transfer.transferred]
lemmas finter_left_commute = Int_left_commute[Transfer.transferred]
lemmas finter_assoc = Int_assoc[Transfer.transferred]
lemmas finter_ac = Int_ac[Transfer.transferred]
lemmas finter_absorb1 = Int_absorb1[Transfer.transferred]
lemmas finter_absorb2 = Int_absorb2[Transfer.transferred]
lemmas finter_fempty_left = Int_empty_left[Transfer.transferred]
lemmas finter_fempty_right = Int_empty_right[Transfer.transferred]
lemmas disjoint_iff_fnot_equal = disjoint_iff_not_equal[Transfer.transferred]
lemmas finter_funion_distrib = Int_Un_distrib[Transfer.transferred]
lemmas finter_funion_distrib2 = Int_Un_distrib2[Transfer.transferred]
lemmas finter_fsubset_iff[no_atp, simp] = Int_subset_iff[Transfer.transferred]
lemmas funion_absorb = Un_absorb[Transfer.transferred]
lemmas funion_left_absorb = Un_left_absorb[Transfer.transferred]
lemmas funion_commute = Un_commute[Transfer.transferred]
lemmas funion_left_commute = Un_left_commute[Transfer.transferred]
lemmas funion_assoc = Un_assoc[Transfer.transferred]
lemmas funion_ac = Un_ac[Transfer.transferred]
lemmas funion_absorb1 = Un_absorb1[Transfer.transferred]
lemmas funion_absorb2 = Un_absorb2[Transfer.transferred]
lemmas funion_fempty_left = Un_empty_left[Transfer.transferred]
lemmas funion_fempty_right = Un_empty_right[Transfer.transferred]
lemmas funion_finsert_left[simp] = Un_insert_left[Transfer.transferred]
lemmas funion_finsert_right[simp] = Un_insert_right[Transfer.transferred]
lemmas finter_finsert_left = Int_insert_left[Transfer.transferred]
lemmas finter_finsert_left_ifffempty[simp] = Int_insert_left_if0[Transfer.transferred]
lemmas finter_finsert_left_if1[simp] = Int_insert_left_if1[Transfer.transferred]
lemmas finter_finsert_right = Int_insert_right[Transfer.transferred]
lemmas finter_finsert_right_ifffempty[simp] = Int_insert_right_if0[Transfer.transferred]
lemmas finter_finsert_right_if1[simp] = Int_insert_right_if1[Transfer.transferred]
lemmas funion_finter_distrib = Un_Int_distrib[Transfer.transferred]
lemmas funion_finter_distrib2 = Un_Int_distrib2[Transfer.transferred]
lemmas funion_finter_crazy = Un_Int_crazy[Transfer.transferred]
lemmas fsubset_funion_eq = subset_Un_eq[Transfer.transferred]
lemmas funion_fempty[iff] = Un_empty[Transfer.transferred]
lemmas funion_fsubset_iff[no_atp, simp] = Un_subset_iff[Transfer.transferred]
lemmas funion_fminus_finter = Un_Diff_Int[Transfer.transferred]
lemmas ffunion_empty[simp] = Union_empty[Transfer.transferred]
lemmas ffunion_mono = Union_mono[Transfer.transferred]
lemmas ffunion_insert[simp] = Union_insert[Transfer.transferred]
lemmas fminus_finter2 = Diff_Int2[Transfer.transferred]
lemmas funion_finter_assoc_eq = Un_Int_assoc_eq[Transfer.transferred]
lemmas fBall_funion = ball_Un[Transfer.transferred]
lemmas fBex_funion = bex_Un[Transfer.transferred]
lemmas fminus_eq_fempty_iff[simp,no_atp] = Diff_eq_empty_iff[Transfer.transferred]
lemmas fminus_cancel[simp] = Diff_cancel[Transfer.transferred]
lemmas fminus_idemp[simp] = Diff_idemp[Transfer.transferred]
lemmas fminus_triv = Diff_triv[Transfer.transferred]
lemmas fempty_fminus[simp] = empty_Diff[Transfer.transferred]
lemmas fminus_fempty[simp] = Diff_empty[Transfer.transferred]
lemmas fminus_finsertffempty[simp,no_atp] = Diff_insert0[Transfer.transferred]
lemmas fminus_finsert = Diff_insert[Transfer.transferred]
lemmas fminus_finsert2 = Diff_insert2[Transfer.transferred]
lemmas finsert_fminus_if = insert_Diff_if[Transfer.transferred]
lemmas finsert_fminus1[simp] = insert_Diff1[Transfer.transferred]
lemmas finsert_fminus_single[simp] = insert_Diff_single[Transfer.transferred]
lemmas finsert_fminus = insert_Diff[Transfer.transferred]
lemmas fminus_finsert_absorb = Diff_insert_absorb[Transfer.transferred]
lemmas fminus_disjoint[simp] = Diff_disjoint[Transfer.transferred]
lemmas fminus_partition = Diff_partition[Transfer.transferred]
lemmas double_fminus = double_diff[Transfer.transferred]
lemmas funion_fminus_cancel[simp] = Un_Diff_cancel[Transfer.transferred]
lemmas funion_fminus_cancel2[simp] = Un_Diff_cancel2[Transfer.transferred]
lemmas fminus_funion = Diff_Un[Transfer.transferred]
lemmas fminus_finter = Diff_Int[Transfer.transferred]
lemmas funion_fminus = Un_Diff[Transfer.transferred]
lemmas finter_fminus = Int_Diff[Transfer.transferred]
lemmas fminus_finter_distrib = Diff_Int_distrib[Transfer.transferred]
lemmas fminus_finter_distrib2 = Diff_Int_distrib2[Transfer.transferred]
lemmas fUNIV_bool[no_atp] = UNIV_bool[Transfer.transferred]
lemmas fPow_fempty[simp] = Pow_empty[Transfer.transferred]
lemmas fPow_finsert = Pow_insert[Transfer.transferred]
lemmas funion_fPow_fsubset = Un_Pow_subset[Transfer.transferred]
lemmas fPow_finter_eq[simp] = Pow_Int_eq[Transfer.transferred]
lemmas fset_eq_fsubset = set_eq_subset[Transfer.transferred]
lemmas fsubset_iff[no_atp] = subset_iff[Transfer.transferred]
lemmas fsubset_iff_pfsubset_eq = subset_iff_psubset_eq[Transfer.transferred]
lemmas all_not_fin_conv[simp] = all_not_in_conv[Transfer.transferred]
lemmas ex_fin_conv = ex_in_conv[Transfer.transferred]
lemmas fimage_mono = image_mono[Transfer.transferred]
lemmas fPow_mono = Pow_mono[Transfer.transferred]
lemmas finsert_mono = insert_mono[Transfer.transferred]
lemmas funion_mono = Un_mono[Transfer.transferred]
lemmas finter_mono = Int_mono[Transfer.transferred]
lemmas fminus_mono = Diff_mono[Transfer.transferred]
lemmas fin_mono = in_mono[Transfer.transferred]
lemmas fthe_felem_eq[simp] = the_elem_eq[Transfer.transferred]
lemmas fLeast_mono = Least_mono[Transfer.transferred]
lemmas fbind_fbind = bind_bind[Transfer.transferred]
lemmas fempty_fbind[simp] = empty_bind[Transfer.transferred]
lemmas nonfempty_fbind_const = nonempty_bind_const[Transfer.transferred]
lemmas fbind_const = bind_const[Transfer.transferred]
lemmas ffmember_filter[simp] = member_filter[Transfer.transferred]
lemmas fequalityI = equalityI[Transfer.transferred]
lemmas fset_of_list_simps[simp] = set_simps[Transfer.transferred]
lemmas fset_of_list_append[simp] = set_append[Transfer.transferred]
lemmas fset_of_list_rev[simp] = set_rev[Transfer.transferred]
lemmas fset_of_list_map[simp] = set_map[Transfer.transferred]

subsection \<open>Additional lemmas\<close>

subsubsection \<open>\<open>ffUnion\<close>\<close>

lemmas ffUnion_funion_distrib[simp] = Union_Un_distrib[Transfer.transferred]

subsubsection \<open>\<open>fbind\<close>\<close>

lemma fbind_cong[fundef_cong]: "A = B \<Longrightarrow> (\<And>x. x |\<in>| B \<Longrightarrow> f x = g x) \<Longrightarrow> fbind A f = fbind B g"
by transfer force

subsubsection \<open>\<open>fsingleton\<close>\<close>

lemmas fsingletonE = fsingletonD [elim_format]

subsubsection \<open>\<open>femepty\<close>\<close>

lemma fempty_ffilter[simp]: "ffilter (\<lambda>_. False) A = {||}"
by transfer auto

(* FIXME, transferred doesn't work here *)
lemma femptyE [elim!]: "a |\<in>| {||} \<Longrightarrow> P"
  by simp

subsubsection \<open>\<open>fset\<close>\<close>

lemmas fset_simps[simp] = bot_fset.rep_eq finsert.rep_eq

lemma finite_fset [simp]:
  shows "finite (fset S)"
  by transfer simp

lemmas fset_cong = fset_inject

lemma filter_fset [simp]:
  shows "fset (ffilter P xs) = Collect P \<inter> fset xs"
  by transfer auto

lemma notin_fset: "x |\<notin>| S \<longleftrightarrow> x \<notin> fset S"
  by (simp add: fmember_iff_member_fset)

lemmas inter_fset[simp] = inf_fset.rep_eq

lemmas union_fset[simp] = sup_fset.rep_eq

lemmas minus_fset[simp] = minus_fset.rep_eq

subsubsection \<open>\<open>ffilter\<close>\<close>

lemma subset_ffilter:
  "ffilter P A |\<subseteq>| ffilter Q A = (\<forall> x. x |\<in>| A \<longrightarrow> P x \<longrightarrow> Q x)"
  by transfer auto

lemma eq_ffilter:
  "(ffilter P A = ffilter Q A) = (\<forall>x. x |\<in>| A \<longrightarrow> P x = Q x)"
  by transfer auto

lemma pfsubset_ffilter:
  "(\<And>x. x |\<in>| A \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> (x |\<in>| A \<and> \<not> P x \<and> Q x) \<Longrightarrow>
    ffilter P A |\<subset>| ffilter Q A"
  unfolding less_fset_def by (auto simp add: subset_ffilter eq_ffilter)

subsubsection \<open>\<open>fset_of_list\<close>\<close>

lemma fset_of_list_filter[simp]:
  "fset_of_list (filter P xs) = ffilter P (fset_of_list xs)"
  by transfer (auto simp: Set.filter_def)

lemma fset_of_list_subset[intro]:
  "set xs \<subseteq> set ys \<Longrightarrow> fset_of_list xs |\<subseteq>| fset_of_list ys"
  by transfer simp

lemma fset_of_list_elem: "(x |\<in>| fset_of_list xs) \<longleftrightarrow> (x \<in> set xs)"
  by transfer simp

subsubsection \<open>\<open>finsert\<close>\<close>

(* FIXME, transferred doesn't work here *)
lemma set_finsert:
  assumes "x |\<in>| A"
  obtains B where "A = finsert x B" and "x |\<notin>| B"
using assms by transfer (metis Set.set_insert finite_insert)

lemma mk_disjoint_finsert: "a |\<in>| A \<Longrightarrow> \<exists>B. A = finsert a B \<and> a |\<notin>| B"
  by (rule exI [where x = "A |-| {|a|}"]) blast

lemma finsert_eq_iff:
  assumes "a |\<notin>| A" and "b |\<notin>| B"
  shows "(finsert a A = finsert b B) =
    (if a = b then A = B else \<exists>C. A = finsert b C \<and> b |\<notin>| C \<and> B = finsert a C \<and> a |\<notin>| C)"
  using assms by transfer (force simp: insert_eq_iff)

subsubsection \<open>\<open>fimage\<close>\<close>

lemma subset_fimage_iff: "(B |\<subseteq>| f|`|A) = (\<exists> AA. AA |\<subseteq>| A \<and> B = f|`|AA)"
by transfer (metis mem_Collect_eq rev_finite_subset subset_image_iff)

lemma fimage_strict_mono:
  assumes "inj_on f (fset B)" and "A |\<subset>| B"
  shows "f |`| A |\<subset>| f |`| B"
  \<comment> \<open>TODO: Configure transfer framework to lift @{thm Fun.image_strict_mono}.\<close>
proof (rule pfsubsetI)
  from \<open>A |\<subset>| B\<close> have "A |\<subseteq>| B"
    by (rule pfsubset_imp_fsubset)
  thus "f |`| A |\<subseteq>| f |`| B"
    by (rule fimage_mono)
next
  from \<open>A |\<subset>| B\<close> have "A |\<subseteq>| B" and "A \<noteq> B"
    by (simp_all add: pfsubset_eq)

  have "fset A \<noteq> fset B"
    using \<open>A \<noteq> B\<close>
    by (simp add: fset_cong)
  hence "f ` fset A \<noteq> f ` fset B"
    using \<open>A |\<subseteq>| B\<close>
    by (simp add: inj_on_image_eq_iff[OF \<open>inj_on f (fset B)\<close>] less_eq_fset.rep_eq)
  hence "fset (f |`| A) \<noteq> fset (f |`| B)"
    by (simp add: fimage.rep_eq)
  thus "f |`| A \<noteq> f |`| B"
    by (simp add: fset_cong)
qed

subsubsection \<open>bounded quantification\<close>

lemma bex_simps [simp, no_atp]:
  "\<And>A P Q. fBex A (\<lambda>x. P x \<and> Q) = (fBex A P \<and> Q)"
  "\<And>A P Q. fBex A (\<lambda>x. P \<and> Q x) = (P \<and> fBex A Q)"
  "\<And>P. fBex {||} P = False"
  "\<And>a B P. fBex (finsert a B) P = (P a \<or> fBex B P)"
  "\<And>A P f. fBex (f |`| A) P = fBex A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> fBex A P) = fBall A (\<lambda>x. \<not> P x)"
by auto

lemma ball_simps [simp, no_atp]:
  "\<And>A P Q. fBall A (\<lambda>x. P x \<or> Q) = (fBall A P \<or> Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P \<or> Q x) = (P \<or> fBall A Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P \<longrightarrow> Q x) = (P \<longrightarrow> fBall A Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P x \<longrightarrow> Q) = (fBex A P \<longrightarrow> Q)"
  "\<And>P. fBall {||} P = True"
  "\<And>a B P. fBall (finsert a B) P = (P a \<and> fBall B P)"
  "\<And>A P f. fBall (f |`| A) P = fBall A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> fBall A P) = fBex A (\<lambda>x. \<not> P x)"
by auto

lemma atomize_fBall:
    "(\<And>x. x |\<in>| A ==> P x) == Trueprop (fBall A (\<lambda>x. P x))"
apply (simp only: atomize_all atomize_imp)
apply (rule equal_intr_rule)
  by (transfer, simp)+

lemma fBall_mono[mono]: "P \<le> Q \<Longrightarrow> fBall S P \<le> fBall S Q"
by auto

lemma fBex_mono[mono]: "P \<le> Q \<Longrightarrow> fBex S P \<le> fBex S Q"
by auto

end

subsubsection \<open>\<open>fcard\<close>\<close>

(* FIXME: improve transferred to handle bounded meta quantification *)

lemma fcard_fempty:
  "fcard {||} = 0"
  by transfer (rule card.empty)

lemma fcard_finsert_disjoint:
  "x |\<notin>| A \<Longrightarrow> fcard (finsert x A) = Suc (fcard A)"
  by transfer (rule card_insert_disjoint)

lemma fcard_finsert_if:
  "fcard (finsert x A) = (if x |\<in>| A then fcard A else Suc (fcard A))"
  by transfer (rule card_insert_if)

lemma fcard_0_eq [simp, no_atp]:
  "fcard A = 0 \<longleftrightarrow> A = {||}"
  by transfer (rule card_0_eq)

lemma fcard_Suc_fminus1:
  "x |\<in>| A \<Longrightarrow> Suc (fcard (A |-| {|x|})) = fcard A"
  by transfer (rule card_Suc_Diff1)

lemma fcard_fminus_fsingleton:
  "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) = fcard A - 1"
  by transfer (rule card_Diff_singleton)

lemma fcard_fminus_fsingleton_if:
  "fcard (A |-| {|x|}) = (if x |\<in>| A then fcard A - 1 else fcard A)"
  by transfer (rule card_Diff_singleton_if)

lemma fcard_fminus_finsert[simp]:
  assumes "a |\<in>| A" and "a |\<notin>| B"
  shows "fcard (A |-| finsert a B) = fcard (A |-| B) - 1"
using assms by transfer (rule card_Diff_insert)

lemma fcard_finsert: "fcard (finsert x A) = Suc (fcard (A |-| {|x|}))"
by transfer (rule card.insert_remove)

lemma fcard_finsert_le: "fcard A \<le> fcard (finsert x A)"
by transfer (rule card_insert_le)

lemma fcard_mono:
  "A |\<subseteq>| B \<Longrightarrow> fcard A \<le> fcard B"
by transfer (rule card_mono)

lemma fcard_seteq: "A |\<subseteq>| B \<Longrightarrow> fcard B \<le> fcard A \<Longrightarrow> A = B"
by transfer (rule card_seteq)

lemma pfsubset_fcard_mono: "A |\<subset>| B \<Longrightarrow> fcard A < fcard B"
by transfer (rule psubset_card_mono)

lemma fcard_funion_finter:
  "fcard A + fcard B = fcard (A |\<union>| B) + fcard (A |\<inter>| B)"
by transfer (rule card_Un_Int)

lemma fcard_funion_disjoint:
  "A |\<inter>| B = {||} \<Longrightarrow> fcard (A |\<union>| B) = fcard A + fcard B"
by transfer (rule card_Un_disjoint)

lemma fcard_funion_fsubset:
  "B |\<subseteq>| A \<Longrightarrow> fcard (A |-| B) = fcard A - fcard B"
by transfer (rule card_Diff_subset)

lemma diff_fcard_le_fcard_fminus:
  "fcard A - fcard B \<le> fcard(A |-| B)"
by transfer (rule diff_card_le_card_Diff)

lemma fcard_fminus1_less: "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) < fcard A"
by transfer (rule card_Diff1_less)

lemma fcard_fminus2_less:
  "x |\<in>| A \<Longrightarrow> y |\<in>| A \<Longrightarrow> fcard (A |-| {|x|} |-| {|y|}) < fcard A"
by transfer (rule card_Diff2_less)

lemma fcard_fminus1_le: "fcard (A |-| {|x|}) \<le> fcard A"
by transfer (rule card_Diff1_le)

lemma fcard_pfsubset: "A |\<subseteq>| B \<Longrightarrow> fcard A < fcard B \<Longrightarrow> A < B"
by transfer (rule card_psubset)

subsubsection \<open>\<open>sorted_list_of_fset\<close>\<close>

lemma sorted_list_of_fset_simps[simp]:
  "set (sorted_list_of_fset S) = fset S"
  "fset_of_list (sorted_list_of_fset S) = S"
by (transfer, simp)+

subsubsection \<open>\<open>ffold\<close>\<close>

(* FIXME: improve transferred to handle bounded meta quantification *)

context comp_fun_commute
begin
  lemmas ffold_empty[simp] = fold_empty[Transfer.transferred]

  lemma ffold_finsert [simp]:
    assumes "x |\<notin>| A"
    shows "ffold f z (finsert x A) = f x (ffold f z A)"
    using assms by (transfer fixing: f) (rule fold_insert)

  lemma ffold_fun_left_comm:
    "f x (ffold f z A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_fun_left_comm)

  lemma ffold_finsert2:
    "x |\<notin>| A \<Longrightarrow> ffold f z (finsert x A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_insert2)

  lemma ffold_rec:
    assumes "x |\<in>| A"
    shows "ffold f z A = f x (ffold f z (A |-| {|x|}))"
    using assms by (transfer fixing: f) (rule fold_rec)

  lemma ffold_finsert_fremove:
    "ffold f z (finsert x A) = f x (ffold f z (A |-| {|x|}))"
     by (transfer fixing: f) (rule fold_insert_remove)
end

lemma ffold_fimage:
  assumes "inj_on g (fset A)"
  shows "ffold f z (g |`| A) = ffold (f \<circ> g) z A"
using assms by transfer' (rule fold_image)

lemma ffold_cong:
  assumes "comp_fun_commute f" "comp_fun_commute g"
  "\<And>x. x |\<in>| A \<Longrightarrow> f x = g x"
    and "s = t" and "A = B"
  shows "ffold f s A = ffold g t B"
  using assms[unfolded comp_fun_commute_def']
  by transfer (meson Finite_Set.fold_cong subset_UNIV)

context comp_fun_idem
begin

  lemma ffold_finsert_idem:
    "ffold f z (finsert x A) = f x (ffold f z A)"
    by (transfer fixing: f) (rule fold_insert_idem)

  declare ffold_finsert [simp del] ffold_finsert_idem [simp]

  lemma ffold_finsert_idem2:
    "ffold f z (finsert x A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_insert_idem2)

end

subsubsection \<open>@{term fsubset}\<close>

lemma wfP_pfsubset: "wfP (|\<subset>|)"
proof (rule wfP_if_convertible_to_nat)
  show "\<And>x y. x |\<subset>| y \<Longrightarrow> fcard x < fcard y"
    by (rule pfsubset_fcard_mono)
qed

subsubsection \<open>Group operations\<close>

locale comm_monoid_fset = comm_monoid
begin

sublocale set: comm_monoid_set ..

lift_definition F :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b fset \<Rightarrow> 'a" is set.F .

lemmas cong[fundef_cong] = set.cong[Transfer.transferred]

lemma cong_simp[cong]:
  "\<lbrakk> A = B;  \<And>x. x |\<in>| B =simp=> g x = h x \<rbrakk> \<Longrightarrow> F g A = F h B"
unfolding simp_implies_def by (auto cong: cong)

end

context comm_monoid_add begin

sublocale fsum: comm_monoid_fset plus 0
  rewrites "comm_monoid_set.F plus 0 = sum"
  defines fsum = fsum.F
proof -
  show "comm_monoid_fset (+) 0" by standard

  show "comm_monoid_set.F (+) 0 = sum" unfolding sum_def ..
qed

end

subsubsection \<open>Semilattice operations\<close>

locale semilattice_fset = semilattice
begin

sublocale set: semilattice_set ..

lift_definition F :: "'a fset \<Rightarrow> 'a" is set.F .

lemma eq_fold: "F (finsert x A) = ffold f x A"
  by transfer (rule set.eq_fold)

lemma singleton [simp]: "F {|x|} = x"
  by transfer (rule set.singleton)

lemma insert_not_elem: "x |\<notin>| A \<Longrightarrow> A \<noteq> {||} \<Longrightarrow> F (finsert x A) = x \<^bold>* F A"
  by transfer (rule set.insert_not_elem)

lemma in_idem: "x |\<in>| A \<Longrightarrow> x \<^bold>* F A = F A"
  by transfer (rule set.in_idem)

lemma insert [simp]: "A \<noteq> {||} \<Longrightarrow> F (finsert x A) = x \<^bold>* F A"
  by transfer (rule set.insert)

end

locale semilattice_order_fset = binary?: semilattice_order + semilattice_fset
begin

end

context linorder begin

sublocale fMin: semilattice_order_fset min less_eq less
  rewrites "semilattice_set.F min = Min"
  defines fMin = fMin.F
proof -
  show "semilattice_order_fset min (\<le>) (<)" by standard

  show "semilattice_set.F min = Min" unfolding Min_def ..
qed

sublocale fMax: semilattice_order_fset max greater_eq greater
  rewrites "semilattice_set.F max = Max"
  defines fMax = fMax.F
proof -
  show "semilattice_order_fset max (\<ge>) (>)"
    by standard

  show "semilattice_set.F max = Max"
    unfolding Max_def ..
qed

end

lemma mono_fMax_commute: "mono f \<Longrightarrow> A \<noteq> {||} \<Longrightarrow> f (fMax A) = fMax (f |`| A)"
  by transfer (rule mono_Max_commute)

lemma mono_fMin_commute: "mono f \<Longrightarrow> A \<noteq> {||} \<Longrightarrow> f (fMin A) = fMin (f |`| A)"
  by transfer (rule mono_Min_commute)

lemma fMax_in[simp]: "A \<noteq> {||} \<Longrightarrow> fMax A |\<in>| A"
  by transfer (rule Max_in)

lemma fMin_in[simp]: "A \<noteq> {||} \<Longrightarrow> fMin A |\<in>| A"
  by transfer (rule Min_in)

lemma fMax_ge[simp]: "x |\<in>| A \<Longrightarrow> x \<le> fMax A"
  by transfer (rule Max_ge)

lemma fMin_le[simp]: "x |\<in>| A \<Longrightarrow> fMin A \<le> x"
  by transfer (rule Min_le)

lemma fMax_eqI: "(\<And>y. y |\<in>| A \<Longrightarrow> y \<le> x) \<Longrightarrow> x |\<in>| A \<Longrightarrow> fMax A = x"
  by transfer (rule Max_eqI)

lemma fMin_eqI: "(\<And>y. y |\<in>| A \<Longrightarrow> x \<le> y) \<Longrightarrow> x |\<in>| A \<Longrightarrow> fMin A = x"
  by transfer (rule Min_eqI)

lemma fMax_finsert[simp]: "fMax (finsert x A) = (if A = {||} then x else max x (fMax A))"
  by transfer simp

lemma fMin_finsert[simp]: "fMin (finsert x A) = (if A = {||} then x else min x (fMin A))"
  by transfer simp

context linorder begin

lemma fset_linorder_max_induct[case_names fempty finsert]:
  assumes "P {||}"
  and     "\<And>x S. \<lbrakk>\<forall>y. y |\<in>| S \<longrightarrow> y < x; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by (transfer fixing: less) (auto intro: finite_linorder_max_induct)
qed

lemma fset_linorder_min_induct[case_names fempty finsert]:
  assumes "P {||}"
  and     "\<And>x S. \<lbrakk>\<forall>y. y |\<in>| S \<longrightarrow> y > x; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by (transfer fixing: less) (auto intro: finite_linorder_min_induct)
qed

end

subsection \<open>Choice in fsets\<close>

lemma fset_choice:
  assumes "\<forall>x. x |\<in>| A \<longrightarrow> (\<exists>y. P x y)"
  shows "\<exists>f. \<forall>x. x |\<in>| A \<longrightarrow> P x (f x)"
  using assms by transfer metis

subsection \<open>Induction and Cases rules for fsets\<close>

lemma fset_exhaust [case_names empty insert, cases type: fset]:
  assumes fempty_case: "S = {||} \<Longrightarrow> P"
  and     finsert_case: "\<And>x S'. S = finsert x S' \<Longrightarrow> P"
  shows "P"
  using assms by transfer blast

lemma fset_induct [case_names empty insert]:
  assumes fempty_case: "P {||}"
  and     finsert_case: "\<And>x S. P S \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by transfer (auto intro: finite_induct)
qed

lemma fset_induct_stronger [case_names empty insert, induct type: fset]:
  assumes empty_fset_case: "P {||}"
  and     insert_fset_case: "\<And>x S. \<lbrakk>x |\<notin>| S; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by transfer (auto intro: finite_induct)
qed

lemma fset_card_induct:
  assumes empty_fset_case: "P {||}"
  and     card_fset_Suc_case: "\<And>S T. Suc (fcard S) = (fcard T) \<Longrightarrow> P S \<Longrightarrow> P T"
  shows "P S"
proof (induct S)
  case empty
  show "P {||}" by (rule empty_fset_case)
next
  case (insert x S)
  have h: "P S" by fact
  have "x |\<notin>| S" by fact
  then have "Suc (fcard S) = fcard (finsert x S)"
    by transfer auto
  then show "P (finsert x S)"
    using h card_fset_Suc_case by simp
qed

lemma fset_strong_cases:
  obtains "xs = {||}"
    | ys x where "x |\<notin>| ys" and "xs = finsert x ys"
by transfer blast

lemma fset_induct2:
  "P {||} {||} \<Longrightarrow>
  (\<And>x xs. x |\<notin>| xs \<Longrightarrow> P (finsert x xs) {||}) \<Longrightarrow>
  (\<And>y ys. y |\<notin>| ys \<Longrightarrow> P {||} (finsert y ys)) \<Longrightarrow>
  (\<And>x xs y ys. \<lbrakk>P xs ys; x |\<notin>| xs; y |\<notin>| ys\<rbrakk> \<Longrightarrow> P (finsert x xs) (finsert y ys)) \<Longrightarrow>
  P xsa ysa"
  apply (induct xsa arbitrary: ysa)
  apply (induct_tac x rule: fset_induct_stronger)
  apply simp_all
  apply (induct_tac xa rule: fset_induct_stronger)
  apply simp_all
  done

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

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

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

lemma rel_fset_alt_def: "rel_fset R = (\<lambda>A B. (\<forall>x.\<exists>y. x|\<in>|A \<longrightarrow> y|\<in>|B \<and> R x y)
  \<and> (\<forall>y. \<exists>x. y|\<in>|B \<longrightarrow> x|\<in>|A \<and> R x y))"
apply (rule ext)+
apply transfer'
apply (subst rel_set_def[unfolded fun_eq_iff])
by blast

lemma finite_rel_set:
  assumes fin: "finite X" "finite Z"
  assumes R_S: "rel_set (R OO S) X Z"
  shows "\<exists>Y. finite Y \<and> rel_set R X Y \<and> rel_set S Y Z"
proof -
  obtain f where f: "\<forall>x\<in>X. R x (f x) \<and> (\<exists>z\<in>Z. S (f x) z)"
  apply atomize_elim
  apply (subst bchoice_iff[symmetric])
  using R_S[unfolded rel_set_def OO_def] by blast

  obtain g where g: "\<forall>z\<in>Z. S (g z) z \<and> (\<exists>x\<in>X. R x (g z))"
  apply atomize_elim
  apply (subst bchoice_iff[symmetric])
  using R_S[unfolded rel_set_def OO_def] by blast

  let ?Y = "f ` X \<union> g ` Z"
  have "finite ?Y" by (simp add: fin)
  moreover have "rel_set R X ?Y"
    unfolding rel_set_def
    using f g by clarsimp blast
  moreover have "rel_set S ?Y Z"
    unfolding rel_set_def
    using f g by clarsimp blast
  ultimately show ?thesis by metis
qed

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

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

context includes lifting_syntax
begin

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

lemma finsert_transfer [transfer_rule]:
  "(A ===> rel_fset A ===> rel_fset A) finsert finsert"
  unfolding rel_fun_def rel_fset_alt_def by blast

lemma funion_transfer [transfer_rule]:
  "(rel_fset A ===> rel_fset A ===> rel_fset A) funion funion"
  unfolding rel_fun_def rel_fset_alt_def by blast

lemma ffUnion_transfer [transfer_rule]:
  "(rel_fset (rel_fset A) ===> rel_fset A) ffUnion ffUnion"
  unfolding rel_fun_def rel_fset_alt_def by transfer (simp, fast)

lemma fimage_transfer [transfer_rule]:
  "((A ===> B) ===> rel_fset A ===> rel_fset B) fimage fimage"
  unfolding rel_fun_def rel_fset_alt_def by simp blast

lemma fBall_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> (=)) ===> (=)) fBall fBall"
  unfolding rel_fset_alt_def rel_fun_def by blast

lemma fBex_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> (=)) ===> (=)) fBex fBex"
  unfolding rel_fset_alt_def rel_fun_def by blast

(* FIXME transfer doesn't work here *)
lemma fPow_transfer [transfer_rule]:
  "(rel_fset A ===> rel_fset (rel_fset A)) fPow fPow"
  unfolding rel_fun_def
  using Pow_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred]
  by blast

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

lemma bind_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> rel_fset B) ===> rel_fset B) fbind fbind"
  unfolding rel_fun_def
  using bind_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

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

lemma fmember_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(A ===> rel_fset A ===> (=)) (|\<in>|) (|\<in>|)"
  using assms unfolding rel_fun_def rel_fset_alt_def bi_unique_def by metis

lemma finter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> rel_fset A) finter finter"
  using assms unfolding rel_fun_def
  using inter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fminus_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> rel_fset A) (|-|) (|-|)"
  using assms unfolding rel_fun_def
  using Diff_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fsubset_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> (=)) (|\<subseteq>|) (|\<subseteq>|)"
  using assms unfolding rel_fun_def
  using subset_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fSup_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set (rel_fset A) ===> rel_fset A) Sup Sup"
  unfolding rel_fun_def
  apply clarify
  apply transfer'
  using Sup_fset_transfer[unfolded rel_fun_def] by blast

(* FIXME: add right_total_fInf_transfer *)

lemma fInf_transfer [transfer_rule]:
  assumes "bi_unique A" and "bi_total A"
  shows "(rel_set (rel_fset A) ===> rel_fset A) Inf Inf"
  using assms unfolding rel_fun_def
  apply clarify
  apply transfer'
  using Inf_fset_transfer[unfolded rel_fun_def] by blast

lemma ffilter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "((A ===> (=)) ===> rel_fset A ===> rel_fset A) ffilter ffilter"
  using assms unfolding rel_fun_def
  using Lifting_Set.filter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma card_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_fset A ===> (=)) fcard fcard"
  unfolding rel_fun_def
  using card_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

end

lifting_update fset.lifting
lifting_forget fset.lifting

subsection \<open>BNF setup\<close>

context
includes fset.lifting
begin

lemma rel_fset_alt:
  "rel_fset R a b \<longleftrightarrow> (\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>t \<in> fset b. \<exists>u \<in> fset a. R u t)"
by transfer (simp add: rel_set_def)

lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
apply (rule f_the_inv_into_f[unfolded inj_on_def])
apply (simp add: fset_inject)
apply (rule range_eqI Abs_fset_inverse[symmetric] CollectI)+
.

lemma rel_fset_aux:
"(\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>u \<in> fset b. \<exists>t \<in> fset a. R t u) \<longleftrightarrow>
 ((BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage fst))\<inverse>\<inverse> OO
  BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage snd)) a b" (is "?L = ?R")
proof
  assume ?L
  define R' where "R' =
    the_inv fset (Collect (case_prod R) \<inter> (fset a \<times> fset b))" (is "_ = the_inv fset ?L'")
  have "finite ?L'" by (intro finite_Int[OF disjI2] finite_cartesian_product) (transfer, simp)+
  hence *: "fset R' = ?L'" unfolding R'_def by (intro fset_to_fset)
  show ?R unfolding Grp_def relcompp.simps conversep.simps
  proof (intro CollectI case_prodI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
    from * show "a = fimage fst R'" using conjunct1[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
    from * show "b = fimage snd R'" using conjunct2[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
  qed (auto simp add: *)
next
  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
  apply (simp add: subset_eq Ball_def)
  apply (rule conjI)
  apply (transfer, clarsimp, metis snd_conv)
  by (transfer, clarsimp, metis fst_conv)
qed

bnf "'a fset"
  map: fimage
  sets: fset
  bd: natLeq
  wits: "{||}"
  rel: rel_fset
apply -
          apply transfer' apply simp
         apply transfer' apply force
        apply transfer apply force
       apply transfer' apply force
      apply (rule natLeq_card_order)
       apply (rule natLeq_cinfinite)
  apply (rule regularCard_natLeq)
    apply transfer apply (metis finite_iff_ordLess_natLeq)
   apply (fastforce simp: rel_fset_alt)
 apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff rel_fset_alt
   rel_fset_aux[unfolded OO_Grp_alt])
apply transfer apply simp
done

lemma rel_fset_fset: "rel_set \<chi> (fset A1) (fset A2) = rel_fset \<chi> A1 A2"
  by transfer (rule refl)

end

lemmas [simp] = fset.map_comp fset.map_id fset.set_map

subsection \<open>Size setup\<close>

context includes fset.lifting begin
lift_definition size_fset :: "('a \<Rightarrow> nat) \<Rightarrow> 'a fset \<Rightarrow> nat" is "\<lambda>f. sum (Suc \<circ> f)" .
end

instantiation fset :: (type) size begin
definition size_fset where
  size_fset_overloaded_def: "size_fset = FSet.size_fset (\<lambda>_. 0)"
instance ..
end

lemmas size_fset_simps[simp] =
  size_fset_def[THEN meta_eq_to_obj_eq, THEN fun_cong, THEN fun_cong,
    unfolded map_fun_def comp_def id_apply]

lemmas size_fset_overloaded_simps[simp] =
  size_fset_simps[of "\<lambda>_. 0", unfolded add_0_left add_0_right,
    folded size_fset_overloaded_def]

lemma fset_size_o_map: "inj f \<Longrightarrow> size_fset g \<circ> fimage f = size_fset (g \<circ> f)"
  apply (subst fun_eq_iff)
  including fset.lifting by transfer (auto intro: sum.reindex_cong subset_inj_on)

setup \<open>
BNF_LFP_Size.register_size_global \<^type_name>\<open>fset\<close> \<^const_name>\<open>size_fset\<close>
  @{thm size_fset_overloaded_def} @{thms size_fset_simps size_fset_overloaded_simps}
  @{thms fset_size_o_map}
\<close>

lifting_update fset.lifting
lifting_forget fset.lifting

subsection \<open>Advanced relator customization\<close>

text \<open>Set vs. sum relators:\<close>

lemma rel_set_rel_sum[simp]:
"rel_set (rel_sum \<chi> \<phi>) A1 A2 \<longleftrightarrow>
 rel_set \<chi> (Inl -` A1) (Inl -` A2) \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
(is "?L \<longleftrightarrow> ?Rl \<and> ?Rr")
proof safe
  assume L: "?L"
  show ?Rl unfolding rel_set_def Bex_def vimage_eq proof safe
    fix l1 assume "Inl l1 \<in> A1"
    then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inl l1) a2"
    using L unfolding rel_set_def by auto
    then obtain l2 where "a2 = Inl l2 \<and> \<chi> l1 l2" by (cases a2, auto)
    thus "\<exists> l2. Inl l2 \<in> A2 \<and> \<chi> l1 l2" using a2 by auto
  next
    fix l2 assume "Inl l2 \<in> A2"
    then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inl l2)"
    using L unfolding rel_set_def by auto
    then obtain l1 where "a1 = Inl l1 \<and> \<chi> l1 l2" by (cases a1, auto)
    thus "\<exists> l1. Inl l1 \<in> A1 \<and> \<chi> l1 l2" using a1 by auto
  qed
  show ?Rr unfolding rel_set_def Bex_def vimage_eq proof safe
    fix r1 assume "Inr r1 \<in> A1"
    then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inr r1) a2"
    using L unfolding rel_set_def by auto
    then obtain r2 where "a2 = Inr r2 \<and> \<phi> r1 r2" by (cases a2, auto)
    thus "\<exists> r2. Inr r2 \<in> A2 \<and> \<phi> r1 r2" using a2 by auto
  next
    fix r2 assume "Inr r2 \<in> A2"
    then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inr r2)"
    using L unfolding rel_set_def by auto
    then obtain r1 where "a1 = Inr r1 \<and> \<phi> r1 r2" by (cases a1, auto)
    thus "\<exists> r1. Inr r1 \<in> A1 \<and> \<phi> r1 r2" using a1 by auto
  qed
next
  assume Rl: "?Rl" and Rr: "?Rr"
  show ?L unfolding rel_set_def Bex_def vimage_eq proof safe
    fix a1 assume a1: "a1 \<in> A1"
    show "\<exists> a2. a2 \<in> A2 \<and> rel_sum \<chi> \<phi> a1 a2"
    proof(cases a1)
      case (Inl l1) then obtain l2 where "Inl l2 \<in> A2 \<and> \<chi> l1 l2"
      using Rl a1 unfolding rel_set_def by blast
      thus ?thesis unfolding Inl by auto
    next
      case (Inr r1) then obtain r2 where "Inr r2 \<in> A2 \<and> \<phi> r1 r2"
      using Rr a1 unfolding rel_set_def by blast
      thus ?thesis unfolding Inr by auto
    qed
  next
    fix a2 assume a2: "a2 \<in> A2"
    show "\<exists> a1. a1 \<in> A1 \<and> rel_sum \<chi> \<phi> a1 a2"
    proof(cases a2)
      case (Inl l2) then obtain l1 where "Inl l1 \<in> A1 \<and> \<chi> l1 l2"
      using Rl a2 unfolding rel_set_def by blast
      thus ?thesis unfolding Inl by auto
    next
      case (Inr r2) then obtain r1 where "Inr r1 \<in> A1 \<and> \<phi> r1 r2"
      using Rr a2 unfolding rel_set_def by blast
      thus ?thesis unfolding Inr by auto
    qed
  qed
qed

subsubsection \<open>Countability\<close>

lemma fset_of_list_surj[simp, intro]: "surj fset_of_list"
proof -
  have "x \<in> range fset_of_list" for x :: "'a fset"
    unfolding image_iff
    using exists_fset_of_list by fastforce
  thus ?thesis by auto
qed

instance fset :: (countable) countable
proof
  obtain to_nat :: "'a list \<Rightarrow> nat" where "inj to_nat"
    by (metis ex_inj)
  moreover have "inj (inv fset_of_list)"
    using fset_of_list_surj by (rule surj_imp_inj_inv)
  ultimately have "inj (to_nat \<circ> inv fset_of_list)"
    by (rule inj_compose)
  thus "\<exists>to_nat::'a fset \<Rightarrow> nat. inj to_nat"
    by auto
qed

subsection \<open>Quickcheck setup\<close>

text \<open>Setup adapted from sets.\<close>

notation Quickcheck_Exhaustive.orelse (infixr "orelse" 55)

context
  includes term_syntax
begin

definition [code_unfold]:
"valterm_femptyset = Code_Evaluation.valtermify ({||} :: ('a :: typerep) fset)"

definition [code_unfold]:
"valtermify_finsert x s = Code_Evaluation.valtermify finsert {\<cdot>} (x :: ('a :: typerep * _)) {\<cdot>} s"

end

instantiation fset :: (exhaustive) exhaustive
begin

fun exhaustive_fset where
"exhaustive_fset f i = (if i = 0 then None else (f {||} orelse exhaustive_fset (\<lambda>A. f A orelse Quickcheck_Exhaustive.exhaustive (\<lambda>x. if x |\<in>| A then None else f (finsert x A)) (i - 1)) (i - 1)))"

instance ..

end

instantiation fset :: (full_exhaustive) full_exhaustive
begin

fun full_exhaustive_fset where
"full_exhaustive_fset f i = (if i = 0 then None else (f valterm_femptyset orelse full_exhaustive_fset (\<lambda>A. f A orelse Quickcheck_Exhaustive.full_exhaustive (\<lambda>x. if fst x |\<in>| fst A then None else f (valtermify_finsert x A)) (i - 1)) (i - 1)))"

instance ..

end

no_notation Quickcheck_Exhaustive.orelse (infixr "orelse" 55)

instantiation fset :: (random) random
begin

context
  includes state_combinator_syntax
begin

fun random_aux_fset :: "natural \<Rightarrow> natural \<Rightarrow> natural \<times> natural \<Rightarrow> ('a fset \<times> (unit \<Rightarrow> term)) \<times> natural \<times> natural" where
"random_aux_fset 0 j = Quickcheck_Random.collapse (Random.select_weight [(1, Pair valterm_femptyset)])" |
"random_aux_fset (Code_Numeral.Suc i) j =
  Quickcheck_Random.collapse (Random.select_weight
    [(1, Pair valterm_femptyset),
     (Code_Numeral.Suc i,
      Quickcheck_Random.random j \<circ>\<rightarrow> (\<lambda>x. random_aux_fset i j \<circ>\<rightarrow> (\<lambda>s. Pair (valtermify_finsert x s))))])"

definition "random_fset i = random_aux_fset i i"

instance ..

end

end

end


theory Refinement
imports Setup
begin

section {* Program and datatype refinement \label{sec:refinement} *}

text {*
  Code generation by shallow embedding (cf.~\secref{sec:principle})
  allows to choose code equations and datatype constructors freely,
  given that some very basic syntactic properties are met; this
  flexibility opens up mechanisms for refinement which allow to extend
  the scope and quality of generated code dramatically.
*}

subsection {* Program refinement *}

text {*
  Program refinement works by choosing appropriate code equations
  explicitly (cf.~\secref{sec:equations}); as example, we use Fibonacci
  numbers:
*}

fun %quote fib :: "nat \<Rightarrow> nat" where
    "fib 0 = 0"
  | "fib (Suc 0) = Suc 0"
  | "fib (Suc (Suc n)) = fib n + fib (Suc n)"

text {*
  \noindent The runtime of the corresponding code grows exponential due
  to two recursive calls:
*}

text %quotetypewriter {*
  @{code_stmts fib (consts) fib (Haskell)}
*}

text {*
  \noindent A more efficient implementation would use dynamic
  programming, e.g.~sharing of common intermediate results between
  recursive calls.  This idea is expressed by an auxiliary operation
  which computes a Fibonacci number and its successor simultaneously:
*}

definition %quote fib_step :: "nat \<Rightarrow> nat \<times> nat" where
  "fib_step n = (fib (Suc n), fib n)"

text {*
  \noindent This operation can be implemented by recursion using
  dynamic programming:
*}

lemma %quote [code]:
  "fib_step 0 = (Suc 0, 0)"
  "fib_step (Suc n) = (let (m, q) = fib_step n in (m + q, m))"
  by (simp_all add: fib_step_def)

text {*
  \noindent What remains is to implement @{const fib} by @{const
  fib_step} as follows:
*}

lemma %quote [code]:
  "fib 0 = 0"
  "fib (Suc n) = fst (fib_step n)"
  by (simp_all add: fib_step_def)

text {*
  \noindent The resulting code shows only linear growth of runtime:
*}

text %quotetypewriter {*
  @{code_stmts fib (consts) fib fib_step (Haskell)}
*}

subsection {* Datatype refinement *}

text {*
  Selecting specific code equations \emph{and} datatype constructors
  leads to datatype refinement.  As an example, we will develop an
  alternative representation of the queue example given in
  \secref{sec:queue_example}.  The amortised representation is
  convenient for generating code but exposes its \qt{implementation}
  details, which may be cumbersome when proving theorems about it.
  Therefore, here is a simple, straightforward representation of
  queues:
*}

datatype %quote 'a queue = Queue "'a list"

definition %quote empty :: "'a queue" where
  "empty = Queue []"

primrec %quote enqueue :: "'a \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
  "enqueue x (Queue xs) = Queue (xs @ [x])"

fun %quote dequeue :: "'a queue \<Rightarrow> 'a option \<times> 'a queue" where
    "dequeue (Queue []) = (None, Queue [])"
  | "dequeue (Queue (x # xs)) = (Some x, Queue xs)"

text {*
  \noindent This we can use directly for proving;  for executing,
  we provide an alternative characterisation:
*}

definition %quote AQueue :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a queue" where
  "AQueue xs ys = Queue (ys @ rev xs)"

code_datatype %quote AQueue

text {*
  \noindent Here we define a \qt{constructor} @{const "AQueue"} which
  is defined in terms of @{text "Queue"} and interprets its arguments
  according to what the \emph{content} of an amortised queue is supposed
  to be.

  The prerequisite for datatype constructors is only syntactical: a
  constructor must be of type @{text "\<tau> = \<dots> \<Rightarrow> \<kappa> \<alpha>\<^sub>1 \<dots> \<alpha>\<^sub>n"} where @{text
  "{\<alpha>\<^sub>1, \<dots>, \<alpha>\<^sub>n}"} is exactly the set of \emph{all} type variables in
  @{text "\<tau>"}; then @{text "\<kappa>"} is its corresponding datatype.  The
  HOL datatype package by default registers any new datatype with its
  constructors, but this may be changed using @{command_def
  code_datatype}; the currently chosen constructors can be inspected
  using the @{command print_codesetup} command.

  Equipped with this, we are able to prove the following equations
  for our primitive queue operations which \qt{implement} the simple
  queues in an amortised fashion:
*}

lemma %quote empty_AQueue [code]:
  "empty = AQueue [] []"
  by (simp add: AQueue_def empty_def)

lemma %quote enqueue_AQueue [code]:
  "enqueue x (AQueue xs ys) = AQueue (x # xs) ys"
  by (simp add: AQueue_def)

lemma %quote dequeue_AQueue [code]:
  "dequeue (AQueue xs []) =
    (if xs = [] then (None, AQueue [] [])
    else dequeue (AQueue [] (rev xs)))"
  "dequeue (AQueue xs (y # ys)) = (Some y, AQueue xs ys)"
  by (simp_all add: AQueue_def)

text {*
  \noindent It is good style, although no absolute requirement, to
  provide code equations for the original artefacts of the implemented
  type, if possible; in our case, these are the datatype constructor
  @{const Queue} and the case combinator @{const case_queue}:
*}

lemma %quote Queue_AQueue [code]:
  "Queue = AQueue []"
  by (simp add: AQueue_def fun_eq_iff)

lemma %quote case_queue_AQueue [code]:
  "case_queue f (AQueue xs ys) = f (ys @ rev xs)"
  by (simp add: AQueue_def)

text {*
  \noindent The resulting code looks as expected:
*}

text %quotetypewriter {*
  @{code_stmts empty enqueue dequeue Queue case_queue (SML)}
*}

text {*
  The same techniques can also be applied to types which are not
  specified as datatypes, e.g.~type @{typ int} is originally specified
  as quotient type by means of @{command_def typedef}, but for code
  generation constants allowing construction of binary numeral values
  are used as constructors for @{typ int}.

  This approach however fails if the representation of a type demands
  invariants; this issue is discussed in the next section.
*}

subsection {* Datatype refinement involving invariants \label{sec:invariant} *}

text {*
  Datatype representation involving invariants require a dedicated
  setup for the type and its primitive operations.  As a running
  example, we implement a type @{text "'a dlist"} of list consisting
  of distinct elements.

  The first step is to decide on which representation the abstract
  type (in our example @{text "'a dlist"}) should be implemented.
  Here we choose @{text "'a list"}.  Then a conversion from the concrete
  type to the abstract type must be specified, here:
*}

text %quote {*
  @{term_type Dlist}
*}

text {*
  \noindent Next follows the specification of a suitable \emph{projection},
  i.e.~a conversion from abstract to concrete type:
*}

text %quote {*
  @{term_type list_of_dlist}
*}

text {*
  \noindent This projection must be specified such that the following
  \emph{abstract datatype certificate} can be proven:
*}

lemma %quote [code abstype]:
  "Dlist (list_of_dlist dxs) = dxs"
  by (fact Dlist_list_of_dlist)

text {*
  \noindent Note that so far the invariant on representations
  (@{term_type distinct}) has never been mentioned explicitly:
  the invariant is only referred to implicitly: all values in
  set @{term "{xs. list_of_dlist (Dlist xs) = xs}"} are invariant,
  and in our example this is exactly @{term "{xs. distinct xs}"}.

  The primitive operations on @{typ "'a dlist"} are specified
  indirectly using the projection @{const list_of_dlist}.  For
  the empty @{text "dlist"}, @{const Dlist.empty}, we finally want
  the code equation
*}

text %quote {*
  @{term "Dlist.empty = Dlist []"}
*}

text {*
  \noindent This we have to prove indirectly as follows:
*}

lemma %quote [code]:
  "list_of_dlist Dlist.empty = []"
  by (fact list_of_dlist_empty)

text {*
  \noindent This equation logically encodes both the desired code
  equation and that the expression @{const Dlist} is applied to obeys
  the implicit invariant.  Equations for insertion and removal are
  similar:
*}

lemma %quote [code]:
  "list_of_dlist (Dlist.insert x dxs) = List.insert x (list_of_dlist dxs)"
  by (fact list_of_dlist_insert)

lemma %quote [code]:
  "list_of_dlist (Dlist.remove x dxs) = remove1 x (list_of_dlist dxs)"
  by (fact list_of_dlist_remove)

text {*
  \noindent Then the corresponding code is as follows:
*}

text %quotetypewriter {*
  @{code_stmts Dlist.empty Dlist.insert Dlist.remove list_of_dlist (Haskell)}
*}

text {*
  See further @{cite "Haftmann-Kraus-Kuncar-Nipkow:2013:data_refinement"}
  for the meta theory of datatype refinement involving invariants.

  Typical data structures implemented by representations involving
  invariants are available in the library, theory @{theory Mapping}
  specifies key-value-mappings (type @{typ "('a, 'b) mapping"});
  these can be implemented by red-black-trees (theory @{theory RBT}).
*}

end


theory Chapter21_1_Language
imports DeBruijnEnvironment
begin

datatype kind =
  Star

datatype type =
  Tyvar var
| Nat
| Arrow type type
| All type
| Unit
| Prod type type
| Void
| Sum type type

primrec type_insert :: "var => type => type"
where "type_insert n (Tyvar v) = Tyvar (incr n v)"
    | "type_insert n Nat = Nat"
    | "type_insert n (Arrow e1 e2) = Arrow (type_insert n e1) (type_insert n e2)"
    | "type_insert n (All e) = All (type_insert (next n) e)"
    | "type_insert n Unit = Unit"
    | "type_insert n (Prod e1 e2) = Prod (type_insert n e1) (type_insert n e2)"
    | "type_insert n Void = Void"
    | "type_insert n (Sum e1 e2) = Sum (type_insert n e1) (type_insert n e2)"

primrec type_subst :: "type => var => type => type"
where "type_subst e' n (Tyvar v) = (if v = n then e' else Tyvar (subr n v))"
    | "type_subst e' n Nat = Nat"
    | "type_subst e' n (Arrow e1 e2) = Arrow (type_subst e' n e1) (type_subst e' n e2)"
    | "type_subst e' n (All e) = All (type_subst (type_insert first e') (next n) e)"
    | "type_subst e' n Unit = Unit"
    | "type_subst e' n (Prod e1 e2) = Prod (type_subst e' n e1) (type_subst e' n e2)"
    | "type_subst e' n Void = Void"
    | "type_subst e' n (Sum e1 e2) = Sum (type_subst e' n e1) (type_subst e' n e2)"

lemma [simp]: "canswap m n ==>
        type_insert m o type_insert n = type_insert (next n) o type_insert m"
by auto

lemma [simp]: "canswap m n ==> type_insert m (type_subst t' n t) =
                  type_subst (type_insert m t') (next n) (type_insert m t)"
by (induction t arbitrary: m n t', simp_all)

datatype expr =
  Var var
| Zero
| Suc expr
| Iter expr expr expr
| Lam type expr
| Appl expr expr
| TyLam expr
| TyAppl type expr
| Triv
| Pair expr expr
| ProjL expr
| ProjR expr
| Abort type expr
| Case expr expr expr
| InL type type expr
| InR type type expr

primrec insert :: "var => expr => expr"
where "insert n (Var v) = Var (incr n v)"
    | "insert n Zero = Zero"
    | "insert n (Suc e) = Suc (insert n e)"
    | "insert n (Iter et e0 es) = Iter (insert n et) (insert n e0) (insert (next n) es)"
    | "insert n (Lam t e) = Lam t (insert (next n) e)"
    | "insert n (Appl e1 e2) = Appl (insert n e1) (insert n e2)"
    | "insert n (TyLam e) = TyLam (insert n e)"
    | "insert n (TyAppl t e) = TyAppl t (insert n e)"
    | "insert n Triv = Triv"
    | "insert n (Pair e1 e2) = Pair (insert n e1) (insert n e2)"
    | "insert n (ProjL e) = ProjL (insert n e)"
    | "insert n (ProjR e) = ProjR (insert n e)"
    | "insert n (Abort t e) = Abort t (insert n e)"
    | "insert n (Case et el er) = Case (insert n et) (insert (next n) el) (insert (next n) er)"
    | "insert n (InL t1 t2 e) = InL t1 t2 (insert n e)"
    | "insert n (InR t1 t2 e) = InR t1 t2 (insert n e)"

primrec expr_insert_type :: "var => expr => expr"
where "expr_insert_type n (Var v) = Var v"
    | "expr_insert_type n Zero = Zero"
    | "expr_insert_type n (Suc e) = Suc (expr_insert_type n e)"
    | "expr_insert_type n (Iter et e0 es) =
                      Iter (expr_insert_type n et)
                           (expr_insert_type n e0)
                           (expr_insert_type n es)"
    | "expr_insert_type n (Lam t e) = Lam (type_insert n t) (expr_insert_type n e)"
    | "expr_insert_type n (Appl e1 e2) = Appl (expr_insert_type n e1) (expr_insert_type n e2)"
    | "expr_insert_type n (TyLam e) = TyLam (expr_insert_type (next n) e)"
    | "expr_insert_type n (TyAppl t e) = TyAppl (type_insert n t) (expr_insert_type n e)"
    | "expr_insert_type n Triv = Triv"
    | "expr_insert_type n (Pair e1 e2) = Pair (expr_insert_type n e1) (expr_insert_type n e2)"
    | "expr_insert_type n (ProjL e) = ProjL (expr_insert_type n e)"
    | "expr_insert_type n (ProjR e) = ProjR (expr_insert_type n e)"
    | "expr_insert_type n (Abort t e) = Abort (type_insert n t) (expr_insert_type n e)"
    | "expr_insert_type n (Case et el er) =
                      Case (expr_insert_type n et) (expr_insert_type n el) (expr_insert_type n er)"
    | "expr_insert_type n (InL t1 t2 e) =
                      InL (type_insert n t1) (type_insert n t2) (expr_insert_type n e)"
    | "expr_insert_type n (InR t1 t2 e) =
                      InR (type_insert n t1) (type_insert n t2) (expr_insert_type n e)"

primrec subst :: "expr => var => expr => expr"
where "subst e' n (Var v) = (if v = n then e' else Var (subr n v))"
    | "subst e' n Zero = Zero"
    | "subst e' n (Suc e) = Suc (subst e' n e)"
    | "subst e' n (Iter et e0 es) =
                      Iter (subst e' n et)
                           (subst e' n e0)
                           (subst (insert first e') (next n) es)"
    | "subst e' n (Lam t e) = Lam t (subst (insert first e') (next n) e)"
    | "subst e' n (Appl e1 e2) = Appl (subst e' n e1) (subst e' n e2)"
    | "subst e' n (TyLam e) = TyLam (subst (expr_insert_type first e') n e)"
    | "subst e' n (TyAppl t e) = TyAppl t (subst e' n e)"
    | "subst e' n Triv = Triv"
    | "subst e' n (Pair e1 e2) = Pair (subst e' n e1) (subst e' n e2)"
    | "subst e' n (ProjL e) = ProjL (subst e' n e)"
    | "subst e' n (ProjR e) = ProjR (subst e' n e)"
    | "subst e' n (Abort t e) = Abort t (subst e' n e)"
    | "subst e' n (Case et el er) =
                      Case (subst e' n et)
                           (subst (insert first e') (next n)el)
                           (subst (insert first e') (next n) er)"
    | "subst e' n (InL t1 t2 e) = InL t1 t2 (subst e' n e)"
    | "subst e' n (InR t1 t2 e) = InR t1 t2 (subst e' n e)"

primrec expr_subst_type :: "type => var => expr => expr"
where "expr_subst_type t' n (Var v) = Var v"
    | "expr_subst_type t' n Zero = Zero"
    | "expr_subst_type t' n (Suc e) = Suc (expr_subst_type t' n e)"
    | "expr_subst_type t' n (Iter et e0 es) =
                      Iter (expr_subst_type t' n et)
                           (expr_subst_type t' n e0)
                           (expr_subst_type t' n es)"
    | "expr_subst_type t' n (Lam t e) = Lam (type_subst t' n t) (expr_subst_type t' n e)"
    | "expr_subst_type t' n (Appl e1 e2) =
                Appl (expr_subst_type t' n e1) (expr_subst_type t' n e2)"
    | "expr_subst_type t' n (TyLam e) = TyLam (expr_subst_type (type_insert first t') (next n) e)"
    | "expr_subst_type t' n (TyAppl t e) = TyAppl (type_subst t' n t) (expr_subst_type t' n e)"
    | "expr_subst_type t' n Triv = Triv"
    | "expr_subst_type t' n (Pair e1 e2) =
            Pair (expr_subst_type t' n e1) (expr_subst_type t' n e2)"
    | "expr_subst_type t' n (ProjL e) = ProjL (expr_subst_type t' n e)"
    | "expr_subst_type t' n (ProjR e) = ProjR (expr_subst_type t' n e)"
    | "expr_subst_type t' n (Abort t e) = Abort (type_subst t' n t) (expr_subst_type t' n e)"
    | "expr_subst_type t' n (Case et el er) =
            Case (expr_subst_type t' n et) (expr_subst_type t' n el) (expr_subst_type t' n er)"
    | "expr_subst_type t' n (InL t1 t2 e) =
                      InL (type_subst t' n t1) (type_subst t' n t2) (expr_subst_type t' n e)"
    | "expr_subst_type t' n (InR t1 t2 e) =
                      InR (type_subst t' n t1) (type_subst t' n t2) (expr_subst_type t' n e)"

lemma [simp]: "canswap m n ==> insert m (insert n e) = insert (next n) (insert m e)"
by (induction e arbitrary: n m, simp_all)

lemma [simp]: "insert n (expr_insert_type m e) = expr_insert_type m (insert n e)"
by (induction e arbitrary: n m, simp_all)

lemma [simp]: "canswap n m ==> expr_insert_type n (expr_insert_type m e) =
                    expr_insert_type (next m) (expr_insert_type n e)"
by (induction e arbitrary: n m, simp_all)

lemma [simp]: "canswap m n ==>
        type_insert m (type_insert n e) = type_insert (next n) (type_insert m e)"
by (induction e arbitrary: n m, simp_all)

lemma [simp]: "canswap m n ==> type_insert m o type_insert n = type_insert (next n) o type_insert m"
by auto

lemma [simp]: "canswap m n ==> type_insert m (type_subst t' n t) =
                  type_subst (type_insert m t') (next n) (type_insert m t)"
by (induction t arbitrary: m n t', simp_all)

lemma [simp]: "canswap m n ==> type_insert m o type_subst t' n =
                                   type_subst (type_insert m t') (next n) o type_insert m"
by auto

lemma [simp]: "type_subst t' n (type_insert n t) = t"
by (induction t arbitrary: n t', simp_all)

lemma [simp]: "canswap m n ==> type_subst (type_insert n t') m (type_insert (next n) t) =
                                    type_insert n (type_subst t' m t)"
by (induction t arbitrary: n m t', simp_all)

lemma [simp]: "canswap m n ==>
                  type_subst (type_subst t' n t'') m (type_subst (type_insert m t') (next n) t) =
                      type_subst t' n (type_subst t'' m t)"
proof (induction t arbitrary: n m t' t'')
case (Tyvar v)
  thus ?case by (cases n, cases m, cases v, auto)
next case Arrow
  thus ?case by simp
next case All
  thus ?case by simp
next case Nat
  thus ?case by simp
next case Unit
  thus ?case by simp
next case Prod
  thus ?case by simp
next case Void
  thus ?case by simp
next case Sum
  thus ?case by simp
qed

end


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

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

datatype Nat = Z | S "Nat"

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

fun rotate :: "Nat => 'a list => 'a list" where
"rotate (Z) z = z"
| "rotate (S z2) (nil2) = nil2"
| "rotate (S z2) (cons2 z22 xs1) =
     rotate z2 (x xs1 (cons2 z22 (nil2)))"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
"minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
"lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

(*fun did not finish the proof*)
function mod2 :: "Nat => Nat => Nat" where
"mod2 y (Z) = Z"
| "mod2 y (S z2) =
     (if lt y (S z2) then y else mod2 (minus y (S z2)) (S z2))"
by pat_completeness auto

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun take :: "Nat => 'a list => 'a list" where
"take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
"drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

theorem property0 :
  "((rotate n xs) =
      (x (drop (mod2 n (length xs)) xs) (take (mod2 n (length xs)) xs)))"
  oops

end


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

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

datatype Nat = Z | S "Nat"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

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

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(Nat list) list => Nat list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "Nat list => Nat list" where
  "msortbu x = mergingbu (map (% (y :: Nat) => cons2 y (nil2)) x)"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msortbu xs) xs"
  oops

end


theory Submission
  imports Defs
begin

theorem good_node_def:
  "good_node i \<longleftrightarrow> E\<^sup>*\<^sup>* i 0"
  apply safe
  subgoal premises prems
    using prems by induction auto
  subgoal premises prems
    using prems by (induction rule: converse_rtranclp_induct) (auto intro: good_node.intros)
  done

lemma E_determ:
  assumes "E a b" "E a c"
  shows "b = c"
  using assms unfolding E_def by auto

lemma reaches_bound:
  assumes "E\<^sup>*\<^sup>* i j" "i < n"
  shows "j < n"
  using assms by cases (auto simp: E_def)

lemma reaches1_0:
  "E\<^sup>+\<^sup>+ 0 j \<longleftrightarrow> False"
  by (meson E_def tranclpD zero_less_iff_neq_zero)

lemma cycle_never_reaches_0:
  assumes "E\<^sup>+\<^sup>+ j 0" "E\<^sup>+\<^sup>+ j j"
  shows False
  using assms
  apply (induction j rule: converse_tranclp_induct)
   apply (metis E_def converse_tranclpE less_numeral_extra(3))
  by (metis E_determ rtranclpD tranclp.trancl_into_trancl tranclpD)

lemma reaches_determ:
  assumes "E\<^sup>*\<^sup>* a b" "E\<^sup>*\<^sup>* a c"
  obtains "E\<^sup>*\<^sup>* c b" | "E\<^sup>*\<^sup>* b c"
  apply atomize_elim
  using assms
  apply induction
   apply auto
  by (metis E_determ converse_rtranclpE r_into_rtranclp)

\<comment> \<open>This definition and the theorem are copied from the timed automata graph library
(cf.\ \<^url>\<open>https://github.com/wimmers/munta/blob/13a3a83270f9613b164af58a8ece6373c92fb7c8/library/Graphs.thy#L436\<close>)\<close>
definition sink where
  "sink a \<equiv> \<nexists>b. E a b"

lemma sink_or_cycle:
  assumes "finite {b. E\<^sup>*\<^sup>* a b}"
  obtains b where "E\<^sup>*\<^sup>* a b" "sink b" | b where "E\<^sup>*\<^sup>* a b" "E\<^sup>+\<^sup>+ b b"
proof -
  let ?S = "{b. E\<^sup>+\<^sup>+ a b}"
  have "?S \<subseteq> {b. E\<^sup>*\<^sup>* a b}"
    by auto
  then have "finite ?S"
    using assms by (rule finite_subset)
  then show ?thesis
    using that
  proof (induction ?S arbitrary: a rule: finite_psubset_induct)
    case psubset
    consider (empty) "Collect (E\<^sup>+\<^sup>+ a) = {}" | b where "E\<^sup>+\<^sup>+ a b"
      by auto
    then show ?case
    proof cases
      case empty
      then have "sink a"
        unfolding sink_def by auto
      with psubset.prems show ?thesis
        by auto
    next
      case 2
      show ?thesis
      proof (cases "E\<^sup>*\<^sup>* b a")
        case True
        with \<open>E\<^sup>+\<^sup>+ a b\<close> have "E\<^sup>+\<^sup>+ a a"
          by auto
        with psubset.prems show ?thesis
          by auto
      next
        case False
        show ?thesis
        proof (cases "E\<^sup>+\<^sup>+ b b")
          case True
          with \<open>E\<^sup>+\<^sup>+ a b\<close> psubset.prems show ?thesis
            by (auto intro: tranclp_into_rtranclp)
        next
          case False
          with \<open>\<not> E\<^sup>*\<^sup>* b a\<close> \<open>E\<^sup>+\<^sup>+ a b\<close> have "Collect (E\<^sup>+\<^sup>+ b) \<subset> Collect (E\<^sup>+\<^sup>+ a)"
            by (intro psubsetI) auto
          then show ?thesis
            using \<open>E\<^sup>+\<^sup>+ a b\<close> psubset.prems
            by - (erule psubset.hyps; meson tranclp_into_rtranclp tranclp_rtranclp_tranclp)
        qed
      qed
    qed
  qed
qed

theorem good_node_characterization_1:
  assumes "i < n" "i > 0" "good_node i"
  shows "\<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)" (* this is right *)
  using assms(3) unfolding good_node_def
proof safe
  \<comment> \<open>paths are determinstic & nothing can leave from \<open>0\<close>\<close>
  fix j :: nat
  assume prems: "E\<^sup>*\<^sup>* i 0" and "E\<^sup>*\<^sup>* i j" and "E\<^sup>+\<^sup>+ j j"
  from \<open>E\<^sup>*\<^sup>* i 0\<close> \<open>E\<^sup>*\<^sup>* i j\<close> consider "j = 0" | "E\<^sup>+\<^sup>+ 0 j" | "E\<^sup>+\<^sup>+ j 0"
    by (metis reaches_determ rtranclpD)
  then show False
  proof cases
    case 1
    with \<open>E\<^sup>+\<^sup>+ j j\<close> show ?thesis
      by (simp add: reaches1_0)
  next
    case 2
    then show ?thesis
      by (simp add: reaches1_0)
  next
    case 3
    with \<open>E\<^sup>+\<^sup>+ j j\<close> show ?thesis
      using cycle_never_reaches_0 by auto
  qed
qed

theorem good_node_characterization_2:
  assumes "i < n" "i > 0" "\<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)"
  shows "good_node i" (* this is right *)
  unfolding good_node_def
proof -
  \<comment> \<open>if a node cannot reach a cycle, then it has to reach a sink\<close>
  let ?S = "{j. E\<^sup>*\<^sup>* i j}"
  have "sink 0"
    unfolding sink_def E_def by auto
  have "?S \<subseteq> {0..<n}"
    using \<open>i < n\<close> by (auto intro: reaches_bound)
  then have "finite ?S"
    by (rule finite_subset) rule
  with assms(3) obtain j where j: "E\<^sup>*\<^sup>* i j" "sink j"
    by (auto elim: sink_or_cycle)
  with \<open>i < n\<close> have "j < n"
    by (auto intro: reaches_bound)
  with \<open>sink j\<close> have "j = 0"
    unfolding sink_def E_def n_def using wellformed by auto
  with \<open>E\<^sup>*\<^sup>* i j\<close> show "E\<^sup>*\<^sup>* i 0"
    by simp
qed

corollary good_node_characterization:
  assumes "i < n" "i > 0"
  shows "good_node i \<longleftrightarrow> \<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)" (* this is right *)
  using good_node_characterization_1 good_node_characterization_2 assms by blast

end