(*  Title:      HOL/HOLCF/Deflation.thy
    Author:     Brian Huffman
*)

section {* Continuous deflations and ep-pairs *}

theory Deflation
imports Plain_HOLCF
begin

default_sort cpo

subsection {* Continuous deflations *}

locale deflation =
  fixes d :: "'a \<rightarrow> 'a"
  assumes idem: "\<And>x. d\<cdot>(d\<cdot>x) = d\<cdot>x"
  assumes below: "\<And>x. d\<cdot>x \<sqsubseteq> x"
begin

lemma below_ID: "d \<sqsubseteq> ID"
by (rule cfun_belowI, simp add: below)

text {* The set of fixed points is the same as the range. *}

lemma fixes_eq_range: "{x. d\<cdot>x = x} = range (\<lambda>x. d\<cdot>x)"
by (auto simp add: eq_sym_conv idem)

lemma range_eq_fixes: "range (\<lambda>x. d\<cdot>x) = {x. d\<cdot>x = x}"
by (auto simp add: eq_sym_conv idem)

text {*
  The pointwise ordering on deflation functions coincides with
  the subset ordering of their sets of fixed-points.
*}

lemma belowI:
  assumes f: "\<And>x. d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
proof (rule cfun_belowI)
  fix x
  from below have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
  also from idem have "f\<cdot>(d\<cdot>x) = d\<cdot>x" by (rule f)
  finally show "d\<cdot>x \<sqsubseteq> f\<cdot>x" .
qed

lemma belowD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
proof (rule below_antisym)
  from below show "d\<cdot>x \<sqsubseteq> x" .
next
  assume "f \<sqsubseteq> d"
  hence "f\<cdot>x \<sqsubseteq> d\<cdot>x" by (rule monofun_cfun_fun)
  also assume "f\<cdot>x = x"
  finally show "x \<sqsubseteq> d\<cdot>x" .
qed

end

lemma deflation_strict: "deflation d \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
by (rule deflation.below [THEN bottomI])

lemma adm_deflation: "adm (\<lambda>d. deflation d)"
by (simp add: deflation_def)

lemma deflation_ID: "deflation ID"
by (simp add: deflation.intro)

lemma deflation_bottom: "deflation \<bottom>"
by (simp add: deflation.intro)

lemma deflation_below_iff:
  "\<lbrakk>deflation p; deflation q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q \<longleftrightarrow> (\<forall>x. p\<cdot>x = x \<longrightarrow> q\<cdot>x = x)"
 apply safe
  apply (simp add: deflation.belowD)
 apply (simp add: deflation.belowI)
done

text {*
  The composition of two deflations is equal to
  the lesser of the two (if they are comparable).
*}

lemma deflation_below_comp1:
  assumes "deflation f"
  assumes "deflation g"
  shows "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>(g\<cdot>x) = f\<cdot>x"
proof (rule below_antisym)
  interpret g: deflation g by fact
  from g.below show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
next
  interpret f: deflation f by fact
  assume "f \<sqsubseteq> g" hence "f\<cdot>x \<sqsubseteq> g\<cdot>x" by (rule monofun_cfun_fun)
  hence "f\<cdot>(f\<cdot>x) \<sqsubseteq> f\<cdot>(g\<cdot>x)" by (rule monofun_cfun_arg)
  also have "f\<cdot>(f\<cdot>x) = f\<cdot>x" by (rule f.idem)
  finally show "f\<cdot>x \<sqsubseteq> f\<cdot>(g\<cdot>x)" .
qed

lemma deflation_below_comp2:
  "\<lbrakk>deflation f; deflation g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> g\<cdot>(f\<cdot>x) = f\<cdot>x"
by (simp only: deflation.belowD deflation.idem)

subsection {* Deflations with finite range *}

lemma finite_range_imp_finite_fixes:
  "finite (range f) \<Longrightarrow> finite {x. f x = x}"
proof -
  have "{x. f x = x} \<subseteq> range f"
    by (clarify, erule subst, rule rangeI)
  moreover assume "finite (range f)"
  ultimately show "finite {x. f x = x}"
    by (rule finite_subset)
qed

locale finite_deflation = deflation +
  assumes finite_fixes: "finite {x. d\<cdot>x = x}"
begin

lemma finite_range: "finite (range (\<lambda>x. d\<cdot>x))"
by (simp add: range_eq_fixes finite_fixes)

lemma finite_image: "finite ((\<lambda>x. d\<cdot>x) ` A)"
by (rule finite_subset [OF image_mono [OF subset_UNIV] finite_range])

lemma compact: "compact (d\<cdot>x)"
proof (rule compactI2)
  fix Y :: "nat \<Rightarrow> 'a"
  assume Y: "chain Y"
  have "finite_chain (\<lambda>i. d\<cdot>(Y i))"
  proof (rule finite_range_imp_finch)
    show "chain (\<lambda>i. d\<cdot>(Y i))"
      using Y by simp
    have "range (\<lambda>i. d\<cdot>(Y i)) \<subseteq> range (\<lambda>x. d\<cdot>x)"
      by clarsimp
    thus "finite (range (\<lambda>i. d\<cdot>(Y i)))"
      using finite_range by (rule finite_subset)
  qed
  hence "\<exists>j. (\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)"
    by (simp add: finite_chain_def maxinch_is_thelub Y)
  then obtain j where j: "(\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)" ..

  assume "d\<cdot>x \<sqsubseteq> (\<Squnion>i. Y i)"
  hence "d\<cdot>(d\<cdot>x) \<sqsubseteq> d\<cdot>(\<Squnion>i. Y i)"
    by (rule monofun_cfun_arg)
  hence "d\<cdot>x \<sqsubseteq> (\<Squnion>i. d\<cdot>(Y i))"
    by (simp add: contlub_cfun_arg Y idem)
  hence "d\<cdot>x \<sqsubseteq> d\<cdot>(Y j)"
    using j by simp
  hence "d\<cdot>x \<sqsubseteq> Y j"
    using below by (rule below_trans)
  thus "\<exists>j. d\<cdot>x \<sqsubseteq> Y j" ..
qed

end

lemma finite_deflation_intro:
  "deflation d \<Longrightarrow> finite {x. d\<cdot>x = x} \<Longrightarrow> finite_deflation d"
by (intro finite_deflation.intro finite_deflation_axioms.intro)

lemma finite_deflation_imp_deflation:
  "finite_deflation d \<Longrightarrow> deflation d"
unfolding finite_deflation_def by simp

lemma finite_deflation_bottom: "finite_deflation \<bottom>"
by default simp_all

subsection {* Continuous embedding-projection pairs *}

locale ep_pair =
  fixes e :: "'a \<rightarrow> 'b" and p :: "'b \<rightarrow> 'a"
  assumes e_inverse [simp]: "\<And>x. p\<cdot>(e\<cdot>x) = x"
  and e_p_below: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
begin

lemma e_below_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
proof
  assume "e\<cdot>x \<sqsubseteq> e\<cdot>y"
  hence "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>(e\<cdot>y)" by (rule monofun_cfun_arg)
  thus "x \<sqsubseteq> y" by simp
next
  assume "x \<sqsubseteq> y"
  thus "e\<cdot>x \<sqsubseteq> e\<cdot>y" by (rule monofun_cfun_arg)
qed

lemma e_eq_iff [simp]: "e\<cdot>x = e\<cdot>y \<longleftrightarrow> x = y"
unfolding po_eq_conv e_below_iff ..

lemma p_eq_iff:
  "\<lbrakk>e\<cdot>(p\<cdot>x) = x; e\<cdot>(p\<cdot>y) = y\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>y \<longleftrightarrow> x = y"
by (safe, erule subst, erule subst, simp)

lemma p_inverse: "(\<exists>x. y = e\<cdot>x) = (e\<cdot>(p\<cdot>y) = y)"
by (auto, rule exI, erule sym)

lemma e_below_iff_below_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
proof
  assume "e\<cdot>x \<sqsubseteq> y"
  then have "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>y" by (rule monofun_cfun_arg)
  then show "x \<sqsubseteq> p\<cdot>y" by simp
next
  assume "x \<sqsubseteq> p\<cdot>y"
  then have "e\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>y)" by (rule monofun_cfun_arg)
  then show "e\<cdot>x \<sqsubseteq> y" using e_p_below by (rule below_trans)
qed

lemma compact_e_rev: "compact (e\<cdot>x) \<Longrightarrow> compact x"
proof -
  assume "compact (e\<cdot>x)"
  hence "adm (\<lambda>y. e\<cdot>x \<notsqsubseteq> y)" by (rule compactD)
  hence "adm (\<lambda>y. e\<cdot>x \<notsqsubseteq> e\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
  hence "adm (\<lambda>y. x \<notsqsubseteq> y)" by simp
  thus "compact x" by (rule compactI)
qed

lemma compact_e: "compact x \<Longrightarrow> compact (e\<cdot>x)"
proof -
  assume "compact x"
  hence "adm (\<lambda>y. x \<notsqsubseteq> y)" by (rule compactD)
  hence "adm (\<lambda>y. x \<notsqsubseteq> p\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
  hence "adm (\<lambda>y. e\<cdot>x \<notsqsubseteq> y)" by (simp add: e_below_iff_below_p)
  thus "compact (e\<cdot>x)" by (rule compactI)
qed

lemma compact_e_iff: "compact (e\<cdot>x) \<longleftrightarrow> compact x"
by (rule iffI [OF compact_e_rev compact_e])

text {* Deflations from ep-pairs *}

lemma deflation_e_p: "deflation (e oo p)"
by (simp add: deflation.intro e_p_below)

lemma deflation_e_d_p:
  assumes "deflation d"
  shows "deflation (e oo d oo p)"
proof
  interpret deflation d by fact
  fix x :: 'b
  show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
    by (simp add: idem)
  show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
    by (simp add: e_below_iff_below_p below)
qed

lemma finite_deflation_e_d_p:
  assumes "finite_deflation d"
  shows "finite_deflation (e oo d oo p)"
proof
  interpret finite_deflation d by fact
  fix x :: 'b
  show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
    by (simp add: idem)
  show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
    by (simp add: e_below_iff_below_p below)
  have "finite ((\<lambda>x. e\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. p\<cdot>x))"
    by (simp add: finite_image)
  hence "finite (range (\<lambda>x. (e oo d oo p)\<cdot>x))"
    by (simp add: image_image)
  thus "finite {x. (e oo d oo p)\<cdot>x = x}"
    by (rule finite_range_imp_finite_fixes)
qed

lemma deflation_p_d_e:
  assumes "deflation d"
  assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
  shows "deflation (p oo d oo e)"
proof -
  interpret d: deflation d by fact
  {
    fix x
    have "d\<cdot>(e\<cdot>x) \<sqsubseteq> e\<cdot>x"
      by (rule d.below)
    hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(e\<cdot>x)"
      by (rule monofun_cfun_arg)
    hence "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
      by simp
  }
  note p_d_e_below = this
  show ?thesis
  proof
    fix x
    show "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
      by (rule p_d_e_below)
  next
    fix x
    show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) = (p oo d oo e)\<cdot>x"
    proof (rule below_antisym)
      show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) \<sqsubseteq> (p oo d oo e)\<cdot>x"
        by (rule p_d_e_below)
      have "p\<cdot>(d\<cdot>(d\<cdot>(d\<cdot>(e\<cdot>x)))) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
        by (intro monofun_cfun_arg d)
      hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
        by (simp only: d.idem)
      thus "(p oo d oo e)\<cdot>x \<sqsubseteq> (p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x)"
        by simp
    qed
  qed
qed

lemma finite_deflation_p_d_e:
  assumes "finite_deflation d"
  assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
  shows "finite_deflation (p oo d oo e)"
proof -
  interpret d: finite_deflation d by fact
  show ?thesis
  proof (rule finite_deflation_intro)
    have "deflation d" ..
    thus "deflation (p oo d oo e)"
      using d by (rule deflation_p_d_e)
  next
    have "finite ((\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
      by (rule d.finite_image)
    hence "finite ((\<lambda>x. p\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
      by (rule finite_imageI)
    hence "finite (range (\<lambda>x. (p oo d oo e)\<cdot>x))"
      by (simp add: image_image)
    thus "finite {x. (p oo d oo e)\<cdot>x = x}"
      by (rule finite_range_imp_finite_fixes)
  qed
qed

end

subsection {* Uniqueness of ep-pairs *}

lemma ep_pair_unique_e_lemma:
  assumes 1: "ep_pair e1 p" and 2: "ep_pair e2 p"
  shows "e1 \<sqsubseteq> e2"
proof (rule cfun_belowI)
  fix x
  have "e1\<cdot>(p\<cdot>(e2\<cdot>x)) \<sqsubseteq> e2\<cdot>x"
    by (rule ep_pair.e_p_below [OF 1])
  thus "e1\<cdot>x \<sqsubseteq> e2\<cdot>x"
    by (simp only: ep_pair.e_inverse [OF 2])
qed

lemma ep_pair_unique_e:
  "\<lbrakk>ep_pair e1 p; ep_pair e2 p\<rbrakk> \<Longrightarrow> e1 = e2"
by (fast intro: below_antisym elim: ep_pair_unique_e_lemma)

lemma ep_pair_unique_p_lemma:
  assumes 1: "ep_pair e p1" and 2: "ep_pair e p2"
  shows "p1 \<sqsubseteq> p2"
proof (rule cfun_belowI)
  fix x
  have "e\<cdot>(p1\<cdot>x) \<sqsubseteq> x"
    by (rule ep_pair.e_p_below [OF 1])
  hence "p2\<cdot>(e\<cdot>(p1\<cdot>x)) \<sqsubseteq> p2\<cdot>x"
    by (rule monofun_cfun_arg)
  thus "p1\<cdot>x \<sqsubseteq> p2\<cdot>x"
    by (simp only: ep_pair.e_inverse [OF 2])
qed

lemma ep_pair_unique_p:
  "\<lbrakk>ep_pair e p1; ep_pair e p2\<rbrakk> \<Longrightarrow> p1 = p2"
by (fast intro: below_antisym elim: ep_pair_unique_p_lemma)

subsection {* Composing ep-pairs *}

lemma ep_pair_ID_ID: "ep_pair ID ID"
by default simp_all

lemma ep_pair_comp:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (e2 oo e1) (p1 oo p2)"
proof
  interpret ep1: ep_pair e1 p1 by fact
  interpret ep2: ep_pair e2 p2 by fact
  fix x y
  show "(p1 oo p2)\<cdot>((e2 oo e1)\<cdot>x) = x"
    by simp
  have "e1\<cdot>(p1\<cdot>(p2\<cdot>y)) \<sqsubseteq> p2\<cdot>y"
    by (rule ep1.e_p_below)
  hence "e2\<cdot>(e1\<cdot>(p1\<cdot>(p2\<cdot>y))) \<sqsubseteq> e2\<cdot>(p2\<cdot>y)"
    by (rule monofun_cfun_arg)
  also have "e2\<cdot>(p2\<cdot>y) \<sqsubseteq> y"
    by (rule ep2.e_p_below)
  finally show "(e2 oo e1)\<cdot>((p1 oo p2)\<cdot>y) \<sqsubseteq> y"
    by simp
qed

locale pcpo_ep_pair = ep_pair e p
  for e :: "'a::pcpo \<rightarrow> 'b::pcpo"
  and p :: "'b::pcpo \<rightarrow> 'a::pcpo"
begin

lemma e_strict [simp]: "e\<cdot>\<bottom> = \<bottom>"
proof -
  have "\<bottom> \<sqsubseteq> p\<cdot>\<bottom>" by (rule minimal)
  hence "e\<cdot>\<bottom> \<sqsubseteq> e\<cdot>(p\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
  also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_below)
  finally show "e\<cdot>\<bottom> = \<bottom>" by simp
qed

lemma e_bottom_iff [simp]: "e\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
by (rule e_eq_iff [where y="\<bottom>", unfolded e_strict])

lemma e_defined: "x \<noteq> \<bottom> \<Longrightarrow> e\<cdot>x \<noteq> \<bottom>"
by simp

lemma p_strict [simp]: "p\<cdot>\<bottom> = \<bottom>"
by (rule e_inverse [where x="\<bottom>", unfolded e_strict])

lemmas stricts = e_strict p_strict

end

end


theory Cuadrado
imports Main
begin

text {* (cuadrado x) es el cuadrado de x. Por ejemplo,
     cuadrado 3 = 9
*}
definition cuadrado :: "int \<Rightarrow> int"
where
  "cuadrado n = n*n"

value "cuadrado 3"
lemma "cuadrado 3 = 9" by (simp add: cuadrado_def)

end


theory Ex009
imports Main
begin

lemma " \<not>C \<longrightarrow> A \<or> ((A \<or> C) \<longrightarrow> B)"
proof -
{
  assume "\<not>C"
  {
    assume "\<not>(A \<or> ((A \<or> C) \<longrightarrow> B))"
    {
      assume "A \<or> C"
      {
        assume A
        hence "A \<or> ((A \<or> C) \<longrightarrow> B)" by (rule disjI1)
        with \<open>\<not>(A \<or> ((A \<or> C) \<longrightarrow> B))\<close> have False by contradiction
        hence B by (rule FalseE)
      }
      {
        assume C
        with \<open>\<not>C\<close> have False by contradiction
        hence B by (rule FalseE)
      }
      with \<open>A \<or> C\<close>  and  \<open>A \<Longrightarrow> B\<close> have B by (rule disjE)
    }
    hence "A \<or> C \<longrightarrow> B" by (rule impI)
    hence "A \<or> (A \<or> C \<longrightarrow> B)" by (rule disjI2)
    with \<open>\<not>(A \<or> ((A \<or> C) \<longrightarrow> B))\<close> have False by contradiction
  }
  hence "\<not>\<not>(A \<or> ((A \<or> C) \<longrightarrow> B))" by (rule notI)
  hence "A \<or> ((A \<or> C) \<longrightarrow> B)" by (rule notnotD)
}
thus ?thesis by (rule impI)
qed


subsection \<open>Experimental AndNode Phase\<close>

theory NewAnd
  imports
    Common
    Graph.JavaLong
begin

lemma bin_distribute_and_over_or:
  "bin[z & (x | y)] = bin[(z & x) | (z & y)]"
  by (smt (verit, best) bit_and_iff bit_eqI bit_or_iff)

lemma intval_distribute_and_over_or:
  "val[z & (x | y)] = val[(z & x) | (z & y)]"
  apply (cases x; cases y; cases z; auto)
  using bin_distribute_and_over_or by blast+

lemma exp_distribute_and_over_or:
  "exp[z & (x | y)] \<ge> exp[(z & x) | (z & y)]"
  apply simp using intval_distribute_and_over_or
  using BinaryExpr bin_eval.simps(4,5)
  using intval_or.simps(1) unfolding new_int_bin.simps new_int.simps apply auto
  by (metis bin_eval.simps(4) bin_eval.simps(5) intval_or.simps(2) intval_or.simps(5))

lemma intval_and_commute:
  "val[x & y] = val[y & x]"
  by (cases x; cases y; auto simp: and.commute)

lemma intval_or_commute:
  "val[x | y] = val[y | x]"
  by (cases x; cases y; auto simp: or.commute)

lemma intval_xor_commute:
  "val[x \<oplus> y] = val[y \<oplus> x]"
  by (cases x; cases y; auto simp: xor.commute)

lemma exp_and_commute:
  "exp[x & z] \<ge> exp[z & x]"
  apply simp using intval_and_commute by auto

lemma exp_or_commute:
  "exp[x | y] \<ge> exp[y | x]"
  apply simp using intval_or_commute by auto

lemma exp_xor_commute:
  "exp[x \<oplus> y] \<ge> exp[y \<oplus> x]"
  apply simp using intval_xor_commute by auto

lemma bin_eliminate_y:
  assumes "bin[y & z] = 0"
  shows "bin[(x | y) & z] = bin[x & z]"
  using assms
  by (simp add: and.commute bin_distribute_and_over_or)

lemma intval_eliminate_y:
  assumes "val[y & z] = IntVal b 0"
  shows "val[(x | y) & z] = val[x & z]"
  using assms bin_eliminate_y by (cases x; cases y; cases z; auto)

lemma intval_and_associative:
  "val[(x & y) & z] = val[x & (y & z)]"
  apply (cases x; cases y; cases z; auto)
  by (simp add: and.assoc)+

lemma intval_or_associative:
  "val[(x | y) | z] = val[x | (y | z)]"
  apply (cases x; cases y; cases z; auto)
  by (simp add: or.assoc)+

lemma intval_xor_associative:
  "val[(x \<oplus> y) \<oplus> z] = val[x \<oplus> (y \<oplus> z)]"
  apply (cases x; cases y; cases z; auto)
  by (simp add: xor.assoc)+

lemma exp_and_associative:
  "exp[(x & y) & z] \<ge> exp[x & (y & z)]"
  apply simp using intval_and_associative by fastforce

lemma exp_or_associative:
  "exp[(x | y) | z] \<ge> exp[x | (y | z)]"
  apply simp using intval_or_associative by fastforce

lemma exp_xor_associative:
  "exp[(x \<oplus> y) \<oplus> z] \<ge> exp[x \<oplus> (y \<oplus> z)]"
  apply simp using intval_xor_associative by fastforce

lemma intval_and_absorb_or:
  assumes "\<exists>b v . x = new_int b v" (* TODO: required? *)
  assumes "val[x & (x | y)] \<noteq> UndefVal"
  shows "val[x & (x | y)] = val[x]"
  using assms apply (cases x; cases y; auto)
  by (metis (mono_tags, lifting) intval_and.simps(5))

lemma intval_or_absorb_and:
  assumes "\<exists>b v . x = new_int b v" (* TODO: required? *)
  assumes "val[x | (x & y)] \<noteq> UndefVal"
  shows "val[x | (x & y)] = val[x]"
  using assms apply (cases x; cases y; auto)
  by (metis (mono_tags, lifting) intval_or.simps(5))

lemma exp_and_absorb_or:
  "exp[x & (x | y)] \<ge> exp[x]"
  apply auto using intval_and_absorb_or eval_unused_bits_zero
  by (smt (verit) evalDet intval_or.elims new_int.elims)

lemma exp_or_absorb_and:
  "exp[x | (x & y)] \<ge> exp[x]"
  apply auto using intval_or_absorb_and eval_unused_bits_zero
  by (smt (verit) evalDet intval_or.elims new_int.elims)

lemma
  assumes "y = 0"
  shows "x + y = or x y"
  using assms
  by simp

(*
lemma
  fixes x y :: "64 word"
  assumes "\<exists>e. n = 2^e"
  assumes "and y n = 0"
  shows "x + y = (or (and x n) (and y n)) + ((x >> n) + (y >> n) << n)"
*)

lemma no_overlap_or:
  assumes "and x y = 0"
  shows "x + y = or x y"
  using assms
  by (metis bit_and_iff bit_xor_iff disjunctive_add xor_self_eq)

(*lemma no_carry_zero_bit:
  assumes "\<not>(bit y j)"
  assumes "\<not>(bit y (Suc j))"
  shows "bit (x + y) (Suc j) = bit x (Suc j)"
  using assms sorry*)

(*
lemma
  fixes x y :: "'a :: len word"
  assumes "(and y (mask (Suc j))) = 0"
  shows "bit (x + y) j = bit (or x y) j"
  using assms proof (induction j)
  case 0
  then show ?case
    by (metis Word.mask_Suc_0 bit_0 bit_1_iff bit_and_iff bit_mask_iff even_add even_or_iff less_numeral_extra(3) mask_0)
next
  case (Suc j)
  then show ?case sorry
qed

lemma packed_bottom_zeros_elim_add:
  fixes x y :: "'a :: len word"
  assumes "\<And>n. n \<le> j \<Longrightarrow> \<not>(bit y n)"
  shows "bit (x + y) j = bit x j"
  using assms
proof -
  have "(and y (mask j)) = 0"
    using assms
    by (metis (no_types, opaque_lifting) bit_and_iff bit_eq_iff bit_mask_iff order_le_less zero_and_eq)
  have "bit (x + y) j = bit (or x y) j"
    using assms
    proof (induction j)
      case 0
      then show ?case
        by (simp add: even_or_iff)
    next
      case (Suc j)
      then show ?case sorry
    qed
  then show ?thesis
    by (simp add: assms bit_or_iff)
qed
proof (induction j)
  case 0
  then show ?case
    by auto
next
  case (Suc j)
  have "(and y (2^(Suc j))) = 0"
    using Suc.prems and_exp_eq_0_iff_not_bit by blast

  then show ?case sorry
qed

  using assms bit_and_iff bit_xor_iff disjunctive_add xor_self_eq sorry*)
 (*
using assms proof (induction j)
  case 0
  then show ?case
    by (metis assms bit_0 bot_nat_0.extremum even_add)
next
  case (Suc j)
  have j0: "\<not>(bit y j)"
    by (simp add: Suc.prems)
  have sj0: "\<not>(bit y (Suc j))"
    by (simp add: Suc.prems)
  show ?case using j0 sj0 no_overlap_or
    by blast
qed *)

(*
lemma packed_bits:
  fixes a :: "64 word"
  assumes "numberOfLeadingZeros a + bitCount a = 64"
  assumes "a \<noteq> 0"
  shows "n \<le> highestOneBit a \<longrightarrow> bit a n"
proof -
  obtain j where j: "j = highestOneBit a"
    by simp
  then have "\<forall>i. i < Nat.size a \<and> i > j \<longrightarrow> \<not>(bit a i)"
    unfolding highestOneBit_def
    by (simp add: j zerosAboveHighestOne)
  have "Nat.size a > highestOneBit a"
    unfolding highestOneBit_def MaxOrNeg_def
    by (simp add: max_bit)
  then have jcard: "numberOfLeadingZeros a = card {i. j \<le> i \<and> i \<le> Nat.size a}"
    unfolding numberOfLeadingZeros_def using j card_of_range_bound leadingZerosAddHighestOne sorry
    by presburger
  obtain k where k: "k = Nat.size a - numberOfLeadingZeros a"
    by presburger
  then have "k = bitCount a"
    using assms
    using size64 by auto
  have union: "{i. j < i \<and> i < Nat.size a} \<union> {i. i \<le> j} = {i. i < Nat.size a}"
    apply auto
    using \<open>highestOneBit (a::64 word) < int (size_class.size a)\<close> j by linarith
  have intersect: "{i. j < i \<and> i < Nat.size a} \<inter> {i. i \<le> j} = {}"
    by force
  have "card {i. j < i \<and> i < Nat.size a} + card {i. i \<le> j} = card {i. i < Nat.size a}"
    using card_add intersect union sorry
    by (metis (no_types, lifting) Int_commute bounded_nat_set_is_finite finite_Un mem_Collect_eq)
  then have "numberOfLeadingZeros a + card {i. i \<le> j} = Nat.size a + 1"
    unfolding jcard card_of_range apply auto sorry
    by (metis j jcard leadingZerosAddHighestOne)
  then have "k = card {i. i < j}"
    using assms k
    by (simp add: add.commute)
  have "{i. j < i \<and> i < Nat.size a} \<inter> {i. i \<le> j} = {}"
    using intersect by blast
  have "\<forall>i . i \<in> {i. j < i \<and> i < Nat.size a} \<longrightarrow> \<not>(bit a i)"
    using \<open>\<forall>i::nat. i < size_class.size (a::64 word) \<and> (j::nat) < i \<longrightarrow> \<not> bit a i\<close> by blast
  then have "\<forall>i . i \<in> {i. i < j} \<longrightarrow> bit a i"
    sorry
  then have less: "\<forall>i. i < j \<longrightarrow> bit a i"
    by blast
  have eq: "bit a j"
    using j unfolding highestOneBit_def MaxOrZero_def
    by (metis Max_in assms(2) disjunctive_diff eq_iff_diff_eq_0 equals0D finite_bit_word mem_Collect_eq zero_and_eq)
  then show ?thesis
    using j
    by (simp add: less order_le_less)
qed
*)

context stamp_mask
begin

lemma intval_up_and_zero_implies_zero:
  assumes "and (\<up>x) (\<up>y) = 0"
  assumes "[m, p] \<turnstile> x \<mapsto> xv"
  assumes "[m, p] \<turnstile> y \<mapsto> yv"
  assumes "val[xv & yv] \<noteq> UndefVal"
  shows "\<exists> b . val[xv & yv] = new_int b 0"
  using assms apply (cases xv; cases yv; auto)
  using up_mask_and_zero_implies_zero
  apply (smt (verit, best) take_bit_and take_bit_of_0)
  by presburger

lemma exp_eliminate_y:
  "and (\<up>y) (\<up>z) = 0 \<longrightarrow> BinaryExpr BinAnd (BinaryExpr BinOr x y) z \<ge> BinaryExpr BinAnd x z"
  apply simp apply (rule impI; rule allI; rule allI; rule allI)
  subgoal premises p for m p v apply (rule impI) subgoal premises e
  proof -
    obtain xv where xv: "[m,p] \<turnstile> x \<mapsto> xv"
      using e by auto
    obtain yv where yv: "[m,p] \<turnstile> y \<mapsto> yv"
      using e by auto
    obtain zv where zv: "[m,p] \<turnstile> z \<mapsto> zv"
      using e by auto
    have lhs: "v = val[(xv | yv) & zv]"
      using xv yv zv
      by (smt (verit, best) BinaryExprE bin_eval.simps(4) bin_eval.simps(5) e evalDet)
    then have "v = val[(xv & zv) | (yv & zv)]"
      by (simp add: intval_and_commute intval_distribute_and_over_or)
    also have "\<exists>b. val[yv & zv] = new_int b 0"
      using intval_up_and_zero_implies_zero
      by (metis calculation e intval_or.simps(5) p unfold_binary yv zv)
    ultimately have rhs: "v = val[xv & zv]"
      using intval_eliminate_y lhs by force
    from lhs rhs show ?thesis
      by (metis BinaryExpr BinaryExprE bin_eval.simps(4) e xv zv)
  qed
  done
  done

lemma leadingZeroBounds:
  fixes x :: "'a::len word"
  assumes "n = numberOfLeadingZeros x"
  shows "0 \<le> n \<and> n \<le> Nat.size x"
  using assms unfolding numberOfLeadingZeros_def
  by (simp add: MaxOrNeg_def highestOneBit_def nat_le_iff)

lemma above_nth_not_set:
  fixes x :: int64
  assumes "n = 64 - numberOfLeadingZeros x"
  shows "j > n \<longrightarrow> \<not>(bit x j)"
  using assms unfolding numberOfLeadingZeros_def
  by (smt (verit, ccfv_SIG) highestOneBit_def int_nat_eq int_ops(6) less_imp_of_nat_less max_set_bit size64 zerosAboveHighestOne)

no_notation LogicNegationNotation ("!_")

lemma zero_horner:
  "horner_sum of_bool 2 (map (\<lambda>x. False) xs) = 0"
  apply (induction xs) apply simp
  by force

lemma zero_map:
  assumes "j \<le> n"
  assumes "\<forall>i. j \<le> i \<longrightarrow> \<not>(f i)"
  shows "map f [0..<n] = map f [0..<j] @ map (\<lambda>x. False) [j..<n]"
  apply (insert assms)
  by (smt (verit, del_insts) add_diff_inverse_nat atLeastLessThan_iff bot_nat_0.extremum leD map_append map_eq_conv set_upt upt_add_eq_append)

lemma map_join_horner:
  assumes "map f [0..<n] = map f [0..<j] @ map (\<lambda>x. False) [j..<n]"
  shows "horner_sum of_bool (2::'a::len word) (map f [0..<n]) = horner_sum of_bool 2 (map f [0..<j])"
proof -
  have "horner_sum of_bool (2::'a::len word) (map f [0..<n]) = horner_sum of_bool 2 (map f [0..<j]) + 2 ^ length [0..<j] * horner_sum of_bool 2 (map f [j..<n])"
    using horner_sum_append
    by (smt (verit) assms diff_le_self diff_zero le_add_same_cancel2 length_append length_map length_upt map_append upt_add_eq_append)
  also have "... = horner_sum of_bool 2 (map f [0..<j]) + 2 ^ length [0..<j] * horner_sum of_bool 2 (map (\<lambda>x. False) [j..<n])"
    using assms
    by (metis calculation horner_sum_append length_map)
  also have "... = horner_sum of_bool 2 (map f [0..<j])"
    using zero_horner
    using mult_not_zero by auto
  finally show ?thesis by simp
qed

lemma split_horner:
  assumes "j \<le> n"
  assumes "\<forall>i. j \<le> i \<longrightarrow> \<not>(f i)"
  shows "horner_sum of_bool (2::'a::len word) (map f [0..<n]) = horner_sum of_bool 2 (map f [0..<j])"
  apply (rule map_join_horner)
  apply (rule zero_map)
  using assms by auto

lemma transfer_map:
  assumes "\<forall>i. i < n \<longrightarrow> f i = f' i"
  shows "(map f [0..<n]) = (map f' [0..<n])"
  using assms by simp

lemma transfer_horner:
  assumes "\<forall>i. i < n \<longrightarrow> f i = f' i"
  shows "horner_sum of_bool (2::'a::len word) (map f [0..<n]) = horner_sum of_bool 2 (map f' [0..<n])"
  using assms using transfer_map
  by (smt (verit, best))

lemma L1:
  assumes "n = 64 - numberOfLeadingZeros (\<up>z)"
  assumes "[m, p] \<turnstile> z \<mapsto> IntVal b zv"
  shows "and v zv = and (v mod 2^n) zv"
proof -
  have nle: "n \<le> 64"
    using assms
    using diff_le_self by blast
  also have "and v zv = horner_sum of_bool 2 (map (bit (and v zv)) [0..<64])"
    using horner_sum_bit_eq_take_bit size64
    by (metis size_word.rep_eq take_bit_length_eq)
  also have "... = horner_sum of_bool 2 (map (\<lambda>i. bit (and v zv) i) [0..<64])"
    by blast
  also have "... = horner_sum of_bool 2 (map (\<lambda>i. ((bit v i) \<and> (bit zv i))) [0..<64])"
    using bit_and_iff by metis
  also have "... = horner_sum of_bool 2 (map (\<lambda>i. ((bit v i) \<and> (bit zv i))) [0..<n])"
  proof -
    have "\<forall>i. i \<ge> n \<longrightarrow> \<not>(bit zv i)"
      using above_nth_not_set assms(1)
      using assms(2) not_may_implies_false
      by (smt (verit, ccfv_SIG) One_nat_def diff_less int_ops(6) leadingZerosAddHighestOne linorder_not_le nat_int_comparison(2) not_numeral_le_zero size64 zero_less_Suc zerosAboveHighestOne)
    then have "\<forall>i. i \<ge> n \<longrightarrow> \<not>((bit v i) \<and> (bit zv i))"
      by auto
    then show ?thesis using nle split_horner
      by (metis (no_types, lifting))
  qed
  also have "... = horner_sum of_bool 2 (map (\<lambda>i. ((bit (v mod 2^n) i) \<and> (bit zv i))) [0..<n])"
  proof -
    have "\<forall>i. i < n \<longrightarrow> bit (v mod 2^n) i = bit v i"
      by (metis bit_take_bit_iff take_bit_eq_mod)
    then have "\<forall>i. i < n \<longrightarrow> ((bit v i) \<and> (bit zv i)) = ((bit (v mod 2^n) i) \<and> (bit zv i))"
      by force
    then show ?thesis
      by (rule transfer_horner)
  qed
  also have "... = horner_sum of_bool 2 (map (\<lambda>i. ((bit (v mod 2^n) i) \<and> (bit zv i))) [0..<64])"
  proof -
    have "\<forall>i. i \<ge> n \<longrightarrow> \<not>(bit zv i)"
      using above_nth_not_set assms(1)
      using assms(2) not_may_implies_false
      by (smt (verit, ccfv_SIG) One_nat_def diff_less int_ops(6) leadingZerosAddHighestOne linorder_not_le nat_int_comparison(2) not_numeral_le_zero size64 zero_less_Suc zerosAboveHighestOne)
    then show ?thesis
      by (metis (no_types, lifting) assms(1) diff_le_self split_horner)
  qed
  also have "... = horner_sum of_bool 2 (map (bit (and (v mod 2^n) zv)) [0..<64])"
    by (meson bit_and_iff)
  also have "... = and (v mod 2^n) zv"
    using horner_sum_bit_eq_take_bit size64
    by (metis size_word.rep_eq take_bit_length_eq)
  finally show ?thesis
    using \<open>and (v::64 word) (zv::64 word) = horner_sum of_bool (2::64 word) (map (bit (and v zv)) [0::nat..<64::nat])\<close> \<open>horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit ((v::64 word) mod (2::64 word) ^ (n::nat)) i \<and> bit (zv::64 word) i) [0::nat..<64::nat]) = horner_sum of_bool (2::64 word) (map (bit (and (v mod (2::64 word) ^ n) zv)) [0::nat..<64::nat])\<close> \<open>horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit ((v::64 word) mod (2::64 word) ^ (n::nat)) i \<and> bit (zv::64 word) i) [0::nat..<n]) = horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit (v mod (2::64 word) ^ n) i \<and> bit zv i) [0::nat..<64::nat])\<close> \<open>horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit (v::64 word) i \<and> bit (zv::64 word) i) [0::nat..<64::nat]) = horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit v i \<and> bit zv i) [0::nat..<n::nat])\<close> \<open>horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit (v::64 word) i \<and> bit (zv::64 word) i) [0::nat..<n::nat]) = horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit (v mod (2::64 word) ^ n) i \<and> bit zv i) [0::nat..<n])\<close> \<open>horner_sum of_bool (2::64 word) (map (bit (and ((v::64 word) mod (2::64 word) ^ (n::nat)) (zv::64 word))) [0::nat..<64::nat]) = and (v mod (2::64 word) ^ n) zv\<close> \<open>horner_sum of_bool (2::64 word) (map (bit (and (v::64 word) (zv::64 word))) [0::nat..<64::nat]) = horner_sum of_bool (2::64 word) (map (\<lambda>i::nat. bit v i \<and> bit zv i) [0::nat..<64::nat])\<close> by presburger
qed

lemma up_mask_upper_bound:
  assumes "[m, p] \<turnstile> x \<mapsto> IntVal b xv"
  shows "xv \<le> (\<up>x)"
  using assms
  by (metis (no_types, lifting) and.idem and.right_neutral bit.conj_cancel_left bit.conj_disj_distribs(1) bit.double_compl ucast_id up_spec word_and_le1 word_not_dist(2))

lemma L2:
  assumes "numberOfLeadingZeros (\<up>z) + numberOfTrailingZeros (\<up>y) \<ge> 64"
  assumes "n = 64 - numberOfLeadingZeros (\<up>z)"
  assumes "[m, p] \<turnstile> z \<mapsto> IntVal b zv"
  assumes "[m, p] \<turnstile> y \<mapsto> IntVal b yv"
  shows "yv mod 2^n = 0"
proof -
  have "yv mod 2^n = horner_sum of_bool 2 (map (bit yv) [0..<n])"
    by (simp add: horner_sum_bit_eq_take_bit take_bit_eq_mod)
  also have "... \<le> horner_sum of_bool 2 (map (bit (\<up>y)) [0..<n])"
    using up_mask_upper_bound assms(4)
    by (metis (no_types, opaque_lifting) and.right_neutral bit.conj_cancel_right bit.conj_disj_distribs(1) bit.double_compl horner_sum_bit_eq_take_bit take_bit_and ucast_id up_spec word_and_le1 word_not_dist(2))
  also have "horner_sum of_bool 2 (map (bit (\<up>y)) [0..<n]) = horner_sum of_bool 2 (map (\<lambda>x. False) [0..<n])"
  proof -
    have "\<forall>i < n. \<not>(bit (\<up>y) i)"
      using assms(1,2) zerosBelowLowestOne
      by (metis add.commute add_diff_inverse_nat add_lessD1 leD le_diff_conv numberOfTrailingZeros_def)
    then show ?thesis
      by (metis (full_types) transfer_map)
  qed
  also have "horner_sum of_bool 2 (map (\<lambda>x. False) [0..<n]) = 0"
    using zero_horner
    by blast
  finally show ?thesis
    by auto
qed

thm_oracles L1 L2

lemma unfold_binary_width_add:
  shows "([m,p] \<turnstile> BinaryExpr BinAdd xe ye \<mapsto> IntVal b val) = (\<exists> x y.
          (([m,p] \<turnstile> xe \<mapsto> IntVal b x) \<and>
           ([m,p] \<turnstile> ye \<mapsto> IntVal b y) \<and>
           (IntVal b val = bin_eval BinAdd (IntVal b x) (IntVal b y)) \<and>
           (IntVal b val \<noteq> UndefVal)
        ))" (is "?L = ?R")
proof (intro iffI)
  assume 3: ?L
  show ?R apply (rule evaltree.cases[OF 3])
    apply force+ apply auto[1]
    apply (smt (verit) intval_add.elims intval_bits.simps)
    by blast
next
  assume R: ?R
  then obtain x y where "[m,p] \<turnstile> xe \<mapsto> IntVal b x"
        and "[m,p] \<turnstile> ye \<mapsto> IntVal b y"
        and "new_int b val = bin_eval BinAdd (IntVal b x) (IntVal b y)"
        and "new_int b val \<noteq> UndefVal"
    by auto
  then show ?L
    using R by blast
 qed

lemma unfold_binary_width_and:
  shows "([m,p] \<turnstile> BinaryExpr BinAnd xe ye \<mapsto> IntVal b val) = (\<exists> x y.
          (([m,p] \<turnstile> xe \<mapsto> IntVal b x) \<and>
           ([m,p] \<turnstile> ye \<mapsto> IntVal b y) \<and>
           (IntVal b val = bin_eval BinAnd (IntVal b x) (IntVal b y)) \<and>
           (IntVal b val \<noteq> UndefVal)
        ))" (is "?L = ?R")
proof (intro iffI)
  assume 3: ?L
  show ?R apply (rule evaltree.cases[OF 3])
    apply force+ apply auto[1] using intval_and.elims intval_bits.simps
    apply (smt (verit) new_int.simps new_int_bin.simps take_bit_and)
    by blast
next
  assume R: ?R
  then obtain x y where "[m,p] \<turnstile> xe \<mapsto> IntVal b x"
        and "[m,p] \<turnstile> ye \<mapsto> IntVal b y"
        and "new_int b val = bin_eval BinAnd (IntVal b x) (IntVal b y)"
        and "new_int b val \<noteq> UndefVal"
    by auto
  then show ?L
    using R by blast
qed

lemma mod_dist_over_add_right:
  fixes a b c :: int64
  fixes n :: nat
  assumes 1: "0 < n"
  assumes 2: "n < 64"
  shows "(a + b mod 2^n) mod 2^n = (a + b) mod 2^n"
  using mod_dist_over_add
  by (simp add: "1" "2" add.commute)

lemma numberOfLeadingZeros_range:
  "0 \<le> numberOfLeadingZeros n \<and> numberOfLeadingZeros n \<le> Nat.size n"
  unfolding numberOfLeadingZeros_def highestOneBit_def using max_set_bit
  by (simp add: highestOneBit_def leadingZeroBounds numberOfLeadingZeros_def)

lemma improved_opt:
  assumes "numberOfLeadingZeros (\<up>z) + numberOfTrailingZeros (\<up>y) \<ge> 64"
  shows "exp[(x + y) & z] \<ge> exp[x & z]"
  apply simp apply ((rule allI)+; rule impI)
  subgoal premises eval for m p v
proof -
  obtain n where n: "n = 64 - numberOfLeadingZeros (\<up>z)"
    by simp
  obtain b val where val: "[m, p] \<turnstile> exp[(x + y) & z] \<mapsto> IntVal b val"
    by (metis BinaryExprE bin_eval_new_int eval new_int.simps)
  then obtain xv yv where addv: "[m, p] \<turnstile> exp[x + y] \<mapsto> IntVal b (xv + yv)"
    apply (subst (asm) unfold_binary_width_and) by (metis add.right_neutral)
  then obtain yv where yv: "[m, p] \<turnstile> y \<mapsto> IntVal b yv"
    apply (subst (asm) unfold_binary_width_add) by blast
  from addv obtain xv where xv: "[m, p] \<turnstile> x \<mapsto> IntVal b xv"
    apply (subst (asm) unfold_binary_width_add) by blast
  from val obtain zv where zv: "[m, p] \<turnstile> z \<mapsto> IntVal b zv"
    apply (subst (asm) unfold_binary_width_and) by blast
  have addv: "[m, p] \<turnstile> exp[x + y] \<mapsto> new_int b (xv + yv)"
    apply (rule evaltree.BinaryExpr)
    using xv apply simp
    using yv apply simp
    by simp+
  have lhs: "[m, p] \<turnstile> exp[(x + y) & z] \<mapsto> new_int b (and (xv + yv) zv)"
    apply (rule evaltree.BinaryExpr)
    using addv apply simp
    using zv apply simp
    using addv apply auto[1]
    by simp
  have rhs: "[m, p] \<turnstile> exp[x & z] \<mapsto> new_int b (and xv zv)"
    apply (rule evaltree.BinaryExpr)
    using xv apply simp
    using zv apply simp
     apply force
    by simp
  then show ?thesis
  proof (cases "numberOfLeadingZeros (\<up>z) > 0")
    case True
    have n_bounds: "0 \<le> n \<and> n < 64"
      using diff_le_self n numberOfLeadingZeros_range
      by (simp add: True)
    have "and (xv + yv) zv = and ((xv + yv) mod 2^n) zv"
      using L1 n zv by blast
    also have "... = and ((xv + (yv mod 2^n)) mod 2^n) zv"
      using mod_dist_over_add_right n_bounds
      by (metis take_bit_0 take_bit_eq_mod zero_less_iff_neq_zero)
    also have "... = and (((xv mod 2^n) + (yv mod 2^n)) mod 2^n) zv"
      by (metis bits_mod_by_1 mod_dist_over_add n_bounds order_le_imp_less_or_eq power_0)
    also have "... = and ((xv mod 2^n) mod 2^n) zv"
      using L2 n zv yv
      using assms by auto
    also have "... = and (xv mod 2^n) zv"
      using mod_mod_trivial
      by (smt (verit, best) and.idem take_bit_eq_mask take_bit_eq_mod word_bw_assocs(1))
    also have "... = and xv zv"
      using L1 n zv by metis
    finally show ?thesis
      using eval lhs rhs
      by (metis evalDet)
  next
    case False
    then have "numberOfLeadingZeros (\<up>z) = 0"
      by simp
    then have "numberOfTrailingZeros (\<up>y) \<ge> 64"
      using assms(1)
      by fastforce
    then have "yv = 0"
      using yv
      by (metis (no_types, lifting) L1 L2 add_diff_cancel_left' and.comm_neutral and.idem bit.compl_zero bit.conj_cancel_right bit.conj_disj_distribs(1) bit.double_compl less_imp_diff_less linorder_not_le word_not_dist(2))
    then show ?thesis
      by (metis add.right_neutral eval evalDet lhs rhs)
  qed
qed
done

thm_oracles improved_opt

(*
lemma falseBelowN_nBelowLowest:
  assumes "n \<le> Nat.size a"
  assumes "\<forall> i < n. \<not>(bit a i)"
  shows "lowestOneBit a \<ge> n"
proof (cases "{i. bit a i} = {}")
  case True
  then show ?thesis unfolding lowestOneBit_def MinOrHighest_def
    using assms(1) trans_le_add1 by presburger
next
  case False
  have "n \<le> Min (Collect (bit a))"
    by (metis False Min_ge_iff assms(2) finite_bit_word linorder_le_less_linear mem_Collect_eq)
  then show ?thesis unfolding lowestOneBit_def MinOrHighest_def
    using False by presburger
qed

lemma noZeros_Count:
  fixes a :: "64 word"
  assumes "zeroCount a = 0"
  shows "i < Nat.size a \<longrightarrow> bit a i"
  using assms unfolding zeroCount_def size64
  using zeroCount_finite by auto

lemma allZeros_Count:
  fixes a :: "64 word"
  assumes "zeroCount a = 64"
  shows "\<not>(bit a i)"
  using assms unfolding zeroCount_def size64
  using zeroCount_finite apply auto sorry

lemma zeroBits:
  fixes a :: "'a::len word"
  shows "(\<forall>i. \<not>(bit a i)) \<longleftrightarrow> a = 0"
  apply auto
  by (simp add: bit_word_eqI)

lemma mask_bit_iff:
  fixes a :: "'a::len word"
  assumes "n \<le> Nat.size a"
  shows "a = mask n \<Longrightarrow> bit a i \<longleftrightarrow> i < n"
  apply auto
  using Word.bit_mask_iff
   apply auto[1] using assms
  by (simp add: Word.bit_mask_iff wsst_TYs(3))

lemma maskBitCount:
  fixes a :: "'a::len word"
  assumes "n \<le> Nat.size a"
  shows "a = mask n \<Longrightarrow> card {i. bit a i} = n"
  using mask_bit_iff assms
  by fastforce

lemma packedMask:
  fixes a :: "64 word"
  assumes "numberOfLeadingZeros a = zeroCount a"
  shows "a = mask (64 - numberOfLeadingZeros a)"
  using assms
proof (induction "64 - numberOfLeadingZeros a")
  case 0
  have "numberOfLeadingZeros a = 64"
    by (metis "0.hyps" local.numberOfLeadingZeros_range nat_less_le size64 zero_less_diff)
  then have "zeroCount a = 64"
    using assms by fastforce
  then have "a = 0"
    using allZeros_Count zeroBits by blast
  then show ?case
    by (simp add: "0.hyps")
next
  case (Suc x)
  then have "numberOfLeadingZeros a = 64 - Suc x"
    by (metis add_diff_cancel_right' add_diff_inverse_nat less_numeral_extra(3) nat_diff_split zero_less_Suc)
  then have "zeroCount a = 64 - Suc x"
    using assms by presburger
  from Suc show ?case sorry
qed
(*
proof (induction a)
  case zero
  then show ?case
    by (simp add: MaxOrNeg_neg highestOneBit_def numberOfLeadingZeros_def size64)
next
  case (suc a)
  then show ?case unfolding MaxOrNeg_neg highestOneBit_def numberOfLeadingZeros_def zeroCount_def
    using size64 apply auto sorry
qed
*)

lemma zerosAboveOnly:
  fixes a :: "64 word"
  assumes "numberOfLeadingZeros a = zeroCount a"
  shows "\<not>(bit a i) \<longrightarrow> i \<ge> (64 - numberOfLeadingZeros a)"
proof -
  obtain n where n: "n = 64 - numberOfLeadingZeros a"
    by simp
  then have n_range: "n \<le> Nat.size a"
    using size64
    by presburger
  then have "a = (mask n)"
    using packedMask
    using assms n by blast
  then have "\<not> bit a i \<longrightarrow> i \<ge> n"
    using Word.bit_mask_iff
    by (metis (mono_tags) le_antisym linorder_le_less_linear min_def n_range word_size)
  then show ?thesis using n
    by blast
qed
*)

(*
lemma consumes:
  assumes "numberOfLeadingZeros (\<up>z) + bitCount (\<up>z) = 64"
  and "\<up>z \<noteq> 0"
  and "and (\<up>y) (\<up>z) = 0"
  shows "numberOfLeadingZeros (\<up>z) + numberOfTrailingZeros (\<up>y) \<ge> 64"
proof -
  obtain n where "n = 64 - numberOfLeadingZeros (\<up>z)"
    by simp
  then have "n = bitCount (\<up>z)"
    by (metis add_diff_cancel_left' assms(1))
  have "numberOfLeadingZeros (\<up>z) = zeroCount (\<up>z)"
    using assms(1) size64 ones_zero_sum_to_width
    by (metis add.commute add_left_imp_eq)
  then have "\<forall>i. \<not>(bit (\<up>z) i) \<longrightarrow> i \<ge> n"
    using assms(1) zerosAboveOnly
    using \<open>(n::nat) = (64::nat) - numberOfLeadingZeros (\<up> (z::IRExpr))\<close> by blast
  then have "\<forall> i < n. bit (\<up>z) i"
    using leD by blast
  then have "\<forall> i < n. \<not>(bit (\<up>y) i)"
    using assms(3)
    by (metis bit.conj_cancel_right bit_and_iff bit_not_iff)
  then have "lowestOneBit (\<up>y) \<ge> n"
    by (simp add: \<open>(n::nat) = (64::nat) - numberOfLeadingZeros (\<up> (z::IRExpr))\<close> falseBelowN_nBelowLowest size64)
  then have "n \<le> numberOfTrailingZeros (\<up>y)"
    unfolding numberOfTrailingZeros_def
    by simp
  have "card {i. i < n} = bitCount (\<up>z)"
    by (simp add: \<open>(n::nat) = bitCount (\<up> (z::IRExpr))\<close>)
  then have "bitCount (\<up>z) \<le> numberOfTrailingZeros (\<up>y)"
    using \<open>(n::nat) \<sqsubseteq> numberOfTrailingZeros (\<up> (y::IRExpr))\<close> by auto
  then show ?thesis using assms(1) by auto
qed

thm_oracles consumes

(*
lemma wrong:
  assumes "numberOfLeadingZeros (\<down>z) + highestOneBit (\<down>z) = 64"
  assumes "\<down>z \<noteq> 0"
  assumes "and (\<up>y) (\<down>z) = 0"
  shows "exp[(x + y) & z] \<ge> x"
  using assms apply auto sorry

lemma wrong2:
  (* assumes "numberOfLeadingZeros (\<up>z) + highestOneBit (\<up>z) = 64" see: leadingZerosAddHighestOne *)
  assumes "\<up>z \<noteq> 0"
  assumes "and (\<up>y) (\<up>z) = 0"
  shows "exp[(x + y) & z] \<ge> x"
  using assms apply simp apply (rule allI)+
  subgoal premises p for m p v apply (rule impI) subgoal premises e
    print_facts
  proof -
    obtain xv where xv: "[m,p] \<turnstile> x \<mapsto> xv"
      using e by auto
    obtain yv where yv: "[m,p] \<turnstile> y \<mapsto> yv"
      using e by auto
    obtain zv where zv: "[m,p] \<turnstile> z \<mapsto> zv"
      using e by auto
    have lhs: "v = val[(xv + yv) & zv]"
      using xv yv zv
      by (smt (verit, best) BinaryExprE bin_eval.simps(1) bin_eval.simps(4) e evalDet)
    have "val[yv & zv] \<noteq> UndefVal"
      sorry
    also have "\<exists>b. val[yv & zv] = new_int b 0"
      using intval_up_and_zero_implies_zero yv zv p(2)
      using calculation by presburger
    ultimately have rhs: "v = val[xv & zv]"
      using intval_eliminate_y lhs sorry
    from lhs rhs show ?thesis sorry
  qed
  done
  done*)

lemma right:
  assumes "numberOfLeadingZeros (\<up>z) + bitCount (\<up>z) = 64"
  assumes "\<up>z \<noteq> 0"
  assumes "and (\<up>y) (\<up>z) = 0"
  shows "exp[(x + y) & z] \<ge> exp[x & z]"
apply simp apply (rule allI)+
  subgoal premises p for m p v apply (rule impI) subgoal premises e
proof -
  obtain j where j: "j = highestOneBit (\<up>z)"
    by simp
  obtain xv b where xv: "[m,p] \<turnstile> x \<mapsto> IntVal b xv"
    using e
    by (metis EvalTreeE(5) bin_eval_inputs_are_ints bin_eval_new_int new_int.simps)
  obtain yv where yv: "[m,p] \<turnstile> y \<mapsto> IntVal b yv"
    using e EvalTreeE(5) bin_eval_inputs_are_ints bin_eval_new_int new_int.simps
    by (smt (verit) Value.sel(1) bin_eval.simps(1) evalDet intval_add.elims xv)
  obtain xyv where xyv: "[m, p] \<turnstile> exp[x + y] \<mapsto> IntVal b xyv"
    using e EvalTreeE(5) bin_eval_inputs_are_ints bin_eval_new_int new_int.simps
    xv yv
    by (metis BinaryExpr Value.distinct(1) bin_eval.simps(1) intval_add.simps(1))
  then obtain zv where zv: "[m,p] \<turnstile> z \<mapsto> IntVal b zv"
    using e EvalTreeE(5) bin_eval_inputs_are_ints bin_eval_new_int new_int.simps
    Value.sel(1) bin_eval.simps(4) evalDet intval_and.elims
    by (smt (verit) new_int_bin.simps)
  have "xyv = take_bit b (xv + yv)"
    using xv yv xyv
    by (metis BinaryExprE Value.sel(2) bin_eval.simps(1) evalDet intval_add.simps(1))
  then have "v = IntVal b (take_bit b (and (take_bit b (xv + yv)) zv))"
    using zv
    by (smt (verit) EvalTreeE(5) Value.sel(1) Value.sel(2) bin_eval.simps(4) e evalDet intval_and.elims new_int.simps new_int_bin.simps xyv)
  then have veval: "v = IntVal b (and (xv + yv) zv)"
    by (metis (no_types, lifting) eval_unused_bits_zero take_bit_eq_mask word_bw_comms(1) word_bw_lcs(1) zv)
  have obligation: "(and (xv + yv) zv) = (and xv zv) \<Longrightarrow> [m,p] \<turnstile> BinaryExpr BinAnd x z \<mapsto> v"
    by (smt (verit) EvalTreeE(5) Value.inject(1) \<open>(v::Value) = IntVal (b::nat) (take_bit b (and (take_bit b ((xv::64 word) + (yv::64 word))) (zv::64 word)))\<close> \<open>(xyv::64 word) = take_bit (b::nat) ((xv::64 word) + (yv::64 word))\<close> bin_eval.simps(4) e evalDet eval_unused_bits_zero evaltree.simps intval_and.simps(1) take_bit_and xv xyv zv)
  have per_bit: "\<forall>n . bit (and (xv + yv) zv) n = bit (and xv zv) n \<Longrightarrow> (and (xv + yv) zv) = (and xv zv)"
    by (simp add: bit_eq_iff)
  show ?thesis
    apply (rule obligation)
    apply (rule per_bit)
    apply (rule allI)
    subgoal for n
  proof (cases "n \<le> j")
    case True
    (*
    then have "\<not>(bit yv n)"
      by (metis (no_types, opaque_lifting) assms(1) assms(2) assms(3) bit_and_iff bit_not_iff impossible_bit j packed_bits ucast_id up_spec yv)
    have "\<forall>n' . n' \<le> n \<longrightarrow> \<not>(bit yv n')"
      by (metis (no_types, lifting) True assms(1) assms(2) assms(3) bit_and_iff bit_not_iff down_spec dual_order.trans j not_may_implies_false packed_bits yv)
    then have "bit (xv + yv) n = bit xv n"
      sorry using packed_bottom_zeros_elim_add
      by blast*)
    then show ?thesis sorry
      (*by (simp add: bit_and_iff)*)
  next
    case False
    then have "\<not>(bit zv n)"
      by (metis j linorder_not_less not_may_implies_false zerosAboveHighestOne zv)
    then have v: "\<not>(bit (and (xv + yv) zv) n)"
      by (simp add: bit_and_iff)
    then have v': "\<not>(bit (and xv zv) n)"
      by (simp add: \<open>\<not> bit (zv::64 word) (n::nat)\<close> bit_and_iff)
    from v v' show ?thesis
      by simp
  qed
  done
qed
  done
  done
*)

end

phase NewAnd
  terminating size
begin

optimization redundant_lhs_y_or: "((x | y) & z) \<longmapsto> x & z
                                when (((and (IRExpr_up y) (IRExpr_up z)) = 0))"
  apply (simp add: IRExpr_up_def)
  using simple_mask.exp_eliminate_y by blast

optimization redundant_lhs_x_or: "((x | y) & z) \<longmapsto> y & z
                                when (((and (IRExpr_up x) (IRExpr_up z)) = 0))"
  apply (simp add: IRExpr_up_def)
  using simple_mask.exp_eliminate_y
  by (meson exp_or_commute mono_binary order_refl order_trans)

optimization redundant_rhs_y_or: "(z & (x | y)) \<longmapsto> z & x
                                when (((and (IRExpr_up y) (IRExpr_up z)) = 0))"
  apply (simp add: IRExpr_up_def)
  using simple_mask.exp_eliminate_y
  by (meson exp_and_commute order.trans)

optimization redundant_rhs_x_or: "(z & (x | y)) \<longmapsto> z & y
                                when (((and (IRExpr_up x) (IRExpr_up z)) = 0))"
  apply (simp add: IRExpr_up_def)
  using simple_mask.exp_eliminate_y
  by (meson dual_order.trans exp_and_commute exp_or_commute mono_binary order_refl)

(*
optimization redundant_lhs_add: "((x + y) & z) \<longmapsto> x & z
                               when ((and (IRExpr_up y) (IRExpr_down z)) = 0)"
*)

end

end


theory ValuesFSetProps
  imports ValuesFSet
begin

inductive_cases
  vfun_le_inv[elim!]: "VFun t1 \<sqsubseteq> VFun t2" and
  le_fun_nat_inv[elim!]: "VFun t2 \<sqsubseteq> VNat x1" and
  le_any_nat_inv[elim!]: "v \<sqsubseteq> VNat n" and
  le_nat_any_inv[elim!]: "VNat n \<sqsubseteq> v" and
  le_fun_any_inv[elim!]: "VFun t \<sqsubseteq> v" and
  le_any_fun_inv[elim!]: "v \<sqsubseteq> VFun t"

proposition val_le_refl[simp]: fixes v::val shows "v \<sqsubseteq> v" by (induction v) auto

proposition val_le_trans[trans]: fixes v2::val shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v3 \<rbrakk> \<Longrightarrow> v1 \<sqsubseteq> v3"
  by (induction v2 arbitrary: v1 v3) blast+

lemma fsubset[intro!]: "fset A \<subseteq> fset B \<Longrightarrow> A |\<subseteq>| B"
proof (rule fsubsetI)
  fix x assume ab: "fset A \<subseteq> fset B" and xa: "x |\<in>| A"
  from xa have "x \<in> fset A" using fmember_iff_member_fset[of x A] by simp
  from this ab have "x \<in> fset B" by blast
  from this show "x |\<in>| B" using fmember_iff_member_fset[of x B] by simp
qed

proposition val_le_antisymm: fixes v1::val shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v1 \<rbrakk> \<Longrightarrow> v1 = v2"
  by (induction v1 arbitrary: v2) auto

lemma le_nat_any[simp]: "VNat n \<sqsubseteq> v \<Longrightarrow> v = VNat n"
  by (cases v) auto

lemma le_nat_nat[simp]: "VNat n \<sqsubseteq> VNat n' \<Longrightarrow> n = n'"
  by auto

end


(*  Title:      HOL/ex/Sqrt_Script.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>Square roots of primes are irrational (script version)\<close>

text \<open>
  Contrast this linear Isabelle/Isar script with the more mathematical version
  in \<^file>\<open>~~/src/HOL/Examples/Sqrt.thy\<close> by Makarius Wenzel.
\<close>

theory Sqrt_Script
  imports Complex_Main "HOL-Computational_Algebra.Primes"
begin

subsection \<open>Preliminaries\<close>

lemma prime_nonzero:  "prime (p::nat) \<Longrightarrow> p \<noteq> 0"
  by (force simp add: prime_nat_iff)

lemma prime_dvd_other_side:
    "(n::nat) * n = p * (k * k) \<Longrightarrow> prime p \<Longrightarrow> p dvd n"
  apply (subgoal_tac "p dvd n * n", blast dest: prime_dvd_mult_nat)
  apply auto
  done

lemma reduction: "prime (p::nat) \<Longrightarrow>
    0 < k \<Longrightarrow> k * k = p * (j * j) \<Longrightarrow> k < p * j \<and> 0 < j"
  apply (rule ccontr)
  apply (simp add: linorder_not_less)
  apply (erule disjE)
   apply (frule mult_le_mono, assumption)
   apply auto
  apply (force simp add: prime_nat_iff)
  done

lemma rearrange: "(j::nat) * (p * j) = k * k \<Longrightarrow> k * k = p * (j * j)"
  by (simp add: ac_simps)

lemma prime_not_square:
    "prime (p::nat) \<Longrightarrow> (\<And>k. 0 < k \<Longrightarrow> m * m \<noteq> p * (k * k))"
  apply (induct m rule: nat_less_induct)
  apply clarify
  apply (frule prime_dvd_other_side, assumption)
  apply (erule dvdE)
  apply (simp add: nat_mult_eq_cancel_disj prime_nonzero)
  apply (blast dest: rearrange reduction)
  done

subsection \<open>Main theorem\<close>

text \<open>
  The square root of any prime number (including \<open>2\<close>) is
  irrational.
\<close>

theorem prime_sqrt_irrational:
    "prime (p::nat) \<Longrightarrow> x * x = real p \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<notin> \<rat>"
  apply (rule notI)
  apply (erule Rats_abs_nat_div_natE)
  apply (simp del: of_nat_mult
              add: abs_if divide_eq_eq prime_not_square of_nat_mult [symmetric])
  done

lemmas two_sqrt_irrational =
  prime_sqrt_irrational [OF two_is_prime_nat]

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Definition of Equivalence Classes\<close>

theory Equiv_Relations_on_Functions
imports
  Preliminaries
  Twelvefold_Way_Core
begin

subsection \<open>Permutation on the Domain\<close>

definition domain_permutation
where
  "domain_permutation A B = {(f, f') \<in> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B). \<exists>p. p permutes A \<and> (\<forall>x \<in> A. f x = f' (p x))}"

lemma equiv_domain_permutation:
  "equiv (A \<rightarrow>\<^sub>E B) (domain_permutation A B)"
proof (rule equivI)
  show "refl_on (A \<rightarrow>\<^sub>E B) (domain_permutation A B)"
  proof (rule refl_onI)
    show "domain_permutation A B \<subseteq> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B)"
      unfolding domain_permutation_def by auto
  next
    fix f
    assume "f \<in> A \<rightarrow>\<^sub>E B"
    from this show "(f, f) \<in> domain_permutation A B"
      using permutes_id unfolding domain_permutation_def by fastforce
  qed
next
  show "sym (domain_permutation A B)"
  proof (rule symI)
    fix f f'
    assume "(f, f') \<in> domain_permutation A B"
    from this obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
      unfolding domain_permutation_def by auto
    from \<open>(f, f') \<in> domain_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_permutation_def by auto
    moreover from \<open>p permutes A\<close> have "inv p permutes A"
      by (simp add: permutes_inv)
    moreover from \<open>p permutes A\<close> \<open>\<forall>x\<in>A. f x = f' (p x)\<close> have "\<forall>x\<in>A. f' x = f (inv p x)"
      using permutes_in_image permutes_inverses(1) by (metis (mono_tags, opaque_lifting))
    ultimately show "(f', f) \<in> domain_permutation A B"
      unfolding domain_permutation_def by auto
  qed
next
  show "trans (domain_permutation A B)"
  proof (rule transI)
    fix f f' f''
    assume "(f, f') \<in> domain_permutation A B" "(f', f'') \<in> domain_permutation A B"
    from \<open>(f, f') \<in> _\<close> obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
      unfolding domain_permutation_def by auto
    from \<open>(f', f'') \<in> _\<close> obtain p' where "p' permutes A" and "\<forall>x\<in>A. f' x = f'' (p' x)"
      unfolding domain_permutation_def by auto
    from \<open>(f, f') \<in> domain_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_permutation_def by auto
    moreover from \<open>(f', f'') \<in> domain_permutation A B\<close> have "f'' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_permutation_def by auto
    moreover from \<open>p permutes A\<close> \<open>p' permutes A\<close> have "(p' \<circ> p) permutes A"
      by (simp add: permutes_compose)
    moreover have "\<forall>x\<in>A. f x = f'' ((p' \<circ> p) x)"
      using \<open>\<forall>x\<in>A. f x = f' (p x)\<close> \<open>\<forall>x\<in>A. f' x = f'' (p' x)\<close> \<open>p permutes A\<close>
      by (simp add: permutes_in_image)
    ultimately show "(f, f'') \<in> domain_permutation A B"
      unfolding domain_permutation_def by auto
  qed
qed

subsubsection \<open>Respecting Functions\<close>

lemma inj_on_respects_domain_permutation:
  "(\<lambda>f. inj_on f A) respects domain_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where p: "p permutes A" "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  have inv_p: "\<forall>x\<in>A. f' x = f (inv p x)"
    using p by (metis permutes_inverses(1) permutes_not_in)
  show "inj_on f A \<longleftrightarrow> inj_on f' A"
  proof
    assume "inj_on f A"
    show "inj_on f' A"
    proof (rule inj_onI)
      fix a a'
      assume "a \<in> A" "a' \<in> A" "f' a = f' a'"
      from this \<open>p permutes A\<close> have "inv p a \<in> A" "inv p a' \<in> A"
        by (simp add:  permutes_in_image permutes_inv)+
      have "f (inv p a) = f (inv p a')"
        using \<open>f' a = f' a'\<close> \<open>a \<in> A\<close> \<open>a' \<in> A\<close> inv_p by auto
      from \<open>inj_on f A\<close> this \<open>inv p a \<in> A\<close> \<open>inv p a' \<in> A\<close> have "inv p a = inv p a'"
        using inj_on_contraD by fastforce
      from this show "a = a'"
        by (metis \<open>p permutes A\<close> permutes_inverses(1))
    qed
  next
    assume "inj_on f' A"
    from this p show "inj_on f A"
      unfolding inj_on_def
      by (metis inj_on_contraD permutes_in_image permutes_inj_on)
  qed
qed

lemma image_respects_domain_permutation:
  "(\<lambda>f. f ` A) respects (domain_permutation A B)"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where p: "p permutes A" and f_eq: "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  show "f ` A = f' ` A"
  proof
    from p f_eq show "f ` A \<subseteq> f' ` A"
      by (auto simp add: permutes_in_image)
  next
    from \<open>p permutes A\<close> \<open>\<forall>x\<in>A. f x = f' (p x)\<close> have "\<forall>x\<in>A. f' x = f (inv p x)"
      using permutes_in_image permutes_inverses(1) by (metis (mono_tags, opaque_lifting))
    from this show "f' ` A \<subseteq> f ` A"
      using \<open>p permutes A\<close> by (auto simp add: permutes_inv permutes_in_image)
  qed
qed

lemma surjective_respects_domain_permutation:
  "(\<lambda>f. f ` A = B) respects domain_permutation A B"
by (metis image_respects_domain_permutation congruentD congruentI)

lemma bij_betw_respects_domain_permutation:
  "(\<lambda>f. bij_betw f A B) respects domain_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  have "bij_betw f A B \<longleftrightarrow> bij_betw (f' o p) A B"
    using \<open>\<forall>x\<in>A. f x = f' (p x)\<close>
    by (metis (mono_tags, opaque_lifting) bij_betw_cong comp_apply)
  also have "... \<longleftrightarrow> bij_betw f' A B"
    using \<open>p permutes A\<close>
    by (auto intro!: bij_betw_comp_iff[symmetric] permutes_imp_bij)
  finally show "bij_betw f A B \<longleftrightarrow> bij_betw f' A B" .
qed

lemma image_mset_respects_domain_permutation:
  shows "(\<lambda>f. image_mset f (mset_set A)) respects (domain_permutation A B)"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_permutation A B"
  from this obtain p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
    unfolding domain_permutation_def by auto
  from this show "image_mset f (mset_set A) = image_mset f' (mset_set A)"
    using permutes_implies_image_mset_eq by fastforce
qed

subsection \<open>Permutation on the Range\<close>

definition range_permutation
where
  "range_permutation A B = {(f, f') \<in> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B). \<exists>p. p permutes B \<and> (\<forall>x \<in> A. f x = p (f' x))}"

lemma equiv_range_permutation:
  "equiv (A \<rightarrow>\<^sub>E B) (range_permutation A B)"
proof (rule equivI)
  show "refl_on (A \<rightarrow>\<^sub>E B) (range_permutation A B)"
  proof (rule refl_onI)
    show "range_permutation A B \<subseteq> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B)"
      unfolding range_permutation_def by auto
  next
    fix f
    assume "f \<in> A \<rightarrow>\<^sub>E B"
    from this show "(f, f) \<in> range_permutation A B"
      using permutes_id unfolding range_permutation_def by fastforce
  qed
next
  show "sym (range_permutation A B)"
  proof (rule symI)
    fix f f'
    assume "(f, f') \<in> range_permutation A B"
    from this obtain p where "p permutes B" and "\<forall>x\<in>A. f x = p (f' x)"
      unfolding range_permutation_def by auto
    from \<open>(f, f') \<in> range_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
      unfolding range_permutation_def by auto
    moreover from \<open>p permutes B\<close> have "inv p permutes B"
      by (simp add: permutes_inv)
    moreover from \<open>p permutes B\<close> \<open>\<forall>x\<in>A. f x = p (f' x)\<close> have "\<forall>x\<in>A. f' x = inv p (f x)"
      by (simp add: permutes_inverses(2))
    ultimately show "(f', f) \<in> range_permutation A B"
      unfolding range_permutation_def by auto
  qed
next
  show "trans (range_permutation A B)"
  proof (rule transI)
    fix f f' f''
    assume "(f, f') \<in> range_permutation A B" "(f', f'') \<in> range_permutation A B"
    from \<open>(f, f') \<in> _\<close> obtain p where "p permutes B" and "\<forall>x\<in>A. f x = p (f' x)"
      unfolding range_permutation_def by auto
    from \<open>(f', f'') \<in> _\<close> obtain p' where "p' permutes B" and "\<forall>x\<in>A. f' x = p' (f'' x)"
      unfolding range_permutation_def by auto
    from \<open>(f, f') \<in> range_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
      unfolding range_permutation_def by auto
    moreover from \<open>(f', f'') \<in> range_permutation A B\<close> have "f'' \<in> A \<rightarrow>\<^sub>E B"
      unfolding range_permutation_def by auto
    moreover from \<open>p permutes B\<close> \<open>p' permutes B\<close> have "(p \<circ> p') permutes B"
      by (simp add: permutes_compose)
    moreover have "\<forall>x\<in>A. f x = (p \<circ> p') (f'' x)"
      using \<open>\<forall>x\<in>A. f x = p (f' x)\<close> \<open>\<forall>x\<in>A. f' x = p' (f'' x)\<close> by auto
    ultimately show "(f, f'') \<in> range_permutation A B"
      unfolding range_permutation_def by auto
  qed
qed

subsubsection \<open>Respecting Functions\<close>

lemma inj_on_respects_range_permutation:
  "(\<lambda>f. inj_on f A) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> range_permutation A B"
  from this obtain p where p: "p permutes B" "\<forall>x\<in>A. f x = p (f' x)"
    unfolding range_permutation_def by auto
  have inv_p: "\<forall>x\<in>A. f' x = inv p (f x)"
    using p by (simp add: permutes_inverses(2))
  show "inj_on f A \<longleftrightarrow> inj_on f' A"
  proof
    assume "inj_on f A"
    from this p show "inj_on f' A"
      unfolding inj_on_def by auto
  next
    assume "inj_on f' A"
    from this inv_p show "inj_on f A"
      unfolding inj_on_def by auto
  qed
qed

lemma surj_on_respects_range_permutation:
  "(\<lambda>f. f ` A = B) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume a: "(f, f') \<in> range_permutation A B"
  from this have "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
    unfolding range_permutation_def by auto
  from a obtain p where p: "p permutes B" "\<forall>x\<in>A. f x = p (f' x)"
    unfolding range_permutation_def by auto
  have 1: "f ` A = (\<lambda>x. p (f' x)) ` A"
    using p by (meson image_cong)
  have 2: "inv p ` ((\<lambda>x. p (f' x)) ` A) = f' ` A"
    using p by (simp add: image_image image_inv_f_f permutes_inj)
  show "(f ` A = B) = (f' ` A = B)"
  proof
    assume "f ` A = B"
    from this 1 2 show "f' ` A = B"
      using p by (simp add: permutes_image permutes_inv)
  next
    assume "f' ` A = B"
    from this 1 2 show "f ` A = B"
      using p by (metis image_image permutes_image)
  qed
qed

lemma bij_betw_respects_range_permutation:
  "(\<lambda>f. bij_betw f A B) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> range_permutation A B"
  from this obtain p where "p permutes B" and "\<forall>x\<in>A. f x = p (f' x)"
    and "f' \<in> A \<rightarrow>\<^sub>E B"
    unfolding range_permutation_def by auto
  have "bij_betw f A B \<longleftrightarrow> bij_betw (p o f') A B"
    using \<open>\<forall>x\<in>A. f x = p (f' x)\<close>
    by (metis (mono_tags, opaque_lifting) bij_betw_cong comp_apply)
  also have "... \<longleftrightarrow> bij_betw f' A B"
    using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>p permutes B\<close>
    by (auto intro!: bij_betw_comp_iff2[symmetric] permutes_imp_bij)
  finally show "bij_betw f A B \<longleftrightarrow> bij_betw f' A B" .
qed

lemma domain_partitions_respects_range_permutation:
  "(\<lambda>f. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) respects range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> range_permutation A B"
  from this obtain p where p: "p permutes B" "\<forall>x \<in> A. f x = p (f' x)"
    unfolding range_permutation_def by blast
  have "{} \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B \<longleftrightarrow> \<not> (\<forall>b \<in> B. \<exists>x \<in> A. f' x = b)" by auto
  also have "(\<forall>b \<in> B. \<exists>x \<in> A. f' x = b) \<longleftrightarrow> (\<forall>b \<in> B. \<exists>x \<in> A. p (f' x) = b)"
  proof
    assume "\<forall>b\<in>B. \<exists>x\<in>A. f' x = b"
    from this show "\<forall>b\<in>B. \<exists>x\<in>A. p (f' x) = b"
      using \<open>p permutes B\<close> unfolding permutes_def by metis
  next
    assume "\<forall>b\<in>B. \<exists>x\<in>A. p (f' x) = b"
    from this show "\<forall>b\<in>B. \<exists>x\<in>A. f' x = b"
      using \<open>p permutes B\<close> by (metis bij_betwE permutes_imp_bij permutes_inverses(2))
  qed
  also have "\<not> (\<forall>b\<in>B. \<exists>x\<in>A. p (f' x) = b) \<longleftrightarrow> {} \<in> (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B" by auto
  finally have "{} \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B \<longleftrightarrow> {} \<in> (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B" .
  moreover have "(\<lambda>b. {x \<in> A. f' x = b}) ` B = (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B"
    using \<open>p permutes B\<close> permutes_implies_inv_image_on_eq by blast
  ultimately have "(\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B - {{}}" by auto
  also have "\<dots> = (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
    using \<open>\<forall>x \<in> A. f x = p (f' x)\<close> Collect_cong image_cong by auto
  finally show "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}" ..
qed

subsection \<open>Permutation on the Domain and the Range\<close>

definition domain_and_range_permutation
where
  "domain_and_range_permutation A B = {(f, f') \<in> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B).
    \<exists>p\<^sub>A p\<^sub>B. p\<^sub>A permutes A \<and> p\<^sub>B permutes B \<and> (\<forall>x \<in> A. f x = p\<^sub>B (f' (p\<^sub>A x)))}"

lemma equiv_domain_and_range_permutation:
  "equiv (A \<rightarrow>\<^sub>E B) (domain_and_range_permutation A B)"
proof (rule equivI)
  show "refl_on (A \<rightarrow>\<^sub>E B) (domain_and_range_permutation A B)"
  proof (rule refl_onI)
    show "domain_and_range_permutation A B \<subseteq> (A \<rightarrow>\<^sub>E B) \<times> (A \<rightarrow>\<^sub>E B)"
      unfolding domain_and_range_permutation_def by auto
  next
    fix f
    assume "f \<in> A \<rightarrow>\<^sub>E B"
    from this show "(f, f) \<in> domain_and_range_permutation A B"
      using permutes_id[of A] permutes_id[of B]
      unfolding domain_and_range_permutation_def by fastforce
  qed
next
  show "sym (domain_and_range_permutation A B)"
  proof (rule symI)
    fix f f'
    assume "(f, f') \<in> domain_and_range_permutation A B"
    from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
      unfolding domain_and_range_permutation_def by auto
    from \<open>(f, f') \<in> domain_and_range_permutation A B\<close> have f: "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_and_range_permutation_def by auto
    moreover from \<open>p\<^sub>A permutes A\<close> \<open>p\<^sub>B permutes B\<close> have "inv p\<^sub>A permutes A" "inv p\<^sub>B permutes B"
      by (auto simp add: permutes_inv)
    moreover from \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> have "\<forall>x\<in>A. f' x = inv p\<^sub>B (f (inv p\<^sub>A x))"
      using \<open>p\<^sub>A permutes A\<close> \<open>p\<^sub>B permutes B\<close> \<open>inv p\<^sub>A permutes A\<close> \<open>inv p\<^sub>B permutes B\<close>
      by (metis (no_types, lifting) bij_betwE bij_inv_eq_iff permutes_bij permutes_imp_bij)
    ultimately show "(f', f) \<in> domain_and_range_permutation A B"
      unfolding domain_and_range_permutation_def by auto
  qed
next
  show "trans (domain_and_range_permutation A B)"
  proof (rule transI)
    fix f f' f''
    assume "(f, f') \<in> domain_and_range_permutation A B"
    assume "(f', f'') \<in> domain_and_range_permutation A B"
    from \<open>(f, f') \<in> _\<close> obtain p\<^sub>A p\<^sub>B where
      "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
      unfolding domain_and_range_permutation_def by auto
    from \<open>(f', f'') \<in> _\<close> obtain p'\<^sub>A p'\<^sub>B where
      "p'\<^sub>A permutes A" "p'\<^sub>B permutes B" and "\<forall>x\<in>A. f' x = p'\<^sub>B (f'' (p'\<^sub>A x))"
      unfolding domain_and_range_permutation_def by auto
    from \<open>(f, f') \<in> domain_and_range_permutation A B\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_and_range_permutation_def by auto
    moreover from \<open>(f', f'') \<in> domain_and_range_permutation A B\<close> have "f'' \<in> A \<rightarrow>\<^sub>E B"
      unfolding domain_and_range_permutation_def by auto
    moreover from \<open>p\<^sub>A permutes A\<close> \<open>p'\<^sub>A permutes A\<close> have "(p'\<^sub>A \<circ> p\<^sub>A) permutes A"
      by (simp add: permutes_compose)
    moreover from \<open>p\<^sub>B permutes B\<close> \<open>p'\<^sub>B permutes B\<close> have "(p\<^sub>B \<circ> p'\<^sub>B) permutes B"
      by (simp add: permutes_compose)
    moreover have "\<forall>x\<in>A. f x = (p\<^sub>B \<circ> p'\<^sub>B) (f'' ((p'\<^sub>A \<circ> p\<^sub>A) x))"
      using \<open>\<forall>x\<in>A. f' x = p'\<^sub>B (f'' (p'\<^sub>A x))\<close> \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> \<open>p\<^sub>A permutes A\<close>
      by (simp add: permutes_in_image)
    ultimately show "(f, f'') \<in> domain_and_range_permutation A B"
      unfolding domain_and_range_permutation_def by fastforce
  qed
qed

subsubsection \<open>Respecting Functions\<close>

lemma inj_on_respects_domain_and_range_permutation:
  "(\<lambda>f. inj_on f A) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
    unfolding domain_and_range_permutation_def by auto
  from \<open>(f, f') \<in> domain_and_range_permutation A B\<close> have "f' ` A \<subseteq> B"
    unfolding domain_and_range_permutation_def by auto
  from \<open>p\<^sub>A permutes A\<close> have "p\<^sub>A ` A = A" by (auto simp add: permutes_image)
  from \<open>p\<^sub>A permutes A\<close> have "inj_on p\<^sub>A A"
    using bij_betw_imp_inj_on permutes_imp_bij by blast
  from \<open>p\<^sub>B permutes B\<close> have "inj_on p\<^sub>B B"
    using bij_betw_imp_inj_on permutes_imp_bij by blast
  show "inj_on f A \<longleftrightarrow> inj_on f' A"
  proof -
    have "inj_on f A \<longleftrightarrow> inj_on (\<lambda>x. p\<^sub>B (f' (p\<^sub>A x))) A"
      using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> inj_on_cong comp_apply by fastforce
    have "inj_on f A \<longleftrightarrow> inj_on (p\<^sub>B o f' o p\<^sub>A) A"
      by (simp add: \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> inj_on_def)
    also have "inj_on (p\<^sub>B o f' o p\<^sub>A) A \<longleftrightarrow> inj_on (p\<^sub>B o f') A"
      using \<open>inj_on p\<^sub>A A\<close> \<open>p\<^sub>A ` A = A\<close>
      by (auto dest: inj_on_imageI intro: comp_inj_on)
    also have "inj_on (p\<^sub>B o f') A \<longleftrightarrow> inj_on f' A"
      using \<open>inj_on p\<^sub>B B\<close> \<open>f' ` A \<subseteq> B\<close>
      by (auto dest: inj_on_imageI2 intro: comp_inj_on subset_inj_on)
    finally show ?thesis .
  qed
qed

lemma surjective_respects_domain_and_range_permutation:
  "(\<lambda>f. f ` A = B) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain p\<^sub>A p\<^sub>B where
    permutes: "p\<^sub>A permutes A" "p\<^sub>B permutes B" and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
    unfolding domain_and_range_permutation_def by auto
  from permutes have "p\<^sub>A ` A = A" "p\<^sub>B ` B = B" by (auto simp add: permutes_image)
  from \<open>p\<^sub>B permutes B\<close> have "inj p\<^sub>B" by (simp add: permutes_inj)
  show "(f ` A = B) \<longleftrightarrow> (f' ` A = B)"
  proof -
    have "f ` A = B \<longleftrightarrow> (\<lambda>x. p\<^sub>B (f' (p\<^sub>A x))) ` A = B"
      using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> by (metis (mono_tags, lifting) image_cong)
    also have "(\<lambda>x. p\<^sub>B (f' (p\<^sub>A x))) ` A = B \<longleftrightarrow> (\<lambda>x. p\<^sub>B (f' x)) ` A = B"
      using \<open>p\<^sub>A ` A = A\<close> by (metis image_image)
    also have "(\<lambda>x. p\<^sub>B (f' x)) ` A = B \<longleftrightarrow> (f' ` A = B)"
      using \<open>p\<^sub>B ` B = B\<close> \<open>inj p\<^sub>B\<close> by (metis image_image image_inv_f_f)
    finally show ?thesis .
  qed
qed

lemma bij_betw_respects_domain_and_range_permutation:
  "(\<lambda>f. bij_betw f A B) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B"
    and "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))" and "f' \<in> A \<rightarrow>\<^sub>E B"
    unfolding domain_and_range_permutation_def by auto
  have "bij_betw f A B \<longleftrightarrow> bij_betw (p\<^sub>B o f' o p\<^sub>A) A B"
    using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> bij_betw_congI by fastforce
  also have "... \<longleftrightarrow> bij_betw (p\<^sub>B o f')  A B"
    using \<open>p\<^sub>A permutes A\<close>
    by (auto intro!: bij_betw_comp_iff[symmetric] permutes_imp_bij)
  also have "... \<longleftrightarrow> bij_betw f' A B"
    using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>p\<^sub>B permutes B\<close>
    by (auto intro!: bij_betw_comp_iff2[symmetric] permutes_imp_bij)
  finally show "bij_betw f A B \<longleftrightarrow> bij_betw f' A B" .
qed

lemma count_image_mset':
  "count (image_mset f A) x = sum (count A) {x' \<in> set_mset A. f x' = x}"
proof -
  have "count (image_mset f A) x = sum (count A) (f -` {x} \<inter> set_mset A)"
    unfolding count_image_mset ..
  also have "\<dots> = sum (count A) {x' \<in> set_mset A. f x' = x}"
  proof -
    have "(f -` {x} \<inter> set_mset A) = {x' \<in> set_mset A. f x' = x}" by blast
    from this show ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma multiset_of_partition_cards_respects_domain_and_range_permutation:
  assumes "finite B"
  shows "(\<lambda>f. image_mset (\<lambda>X. card X) (mset_set (((\<lambda>b. {x \<in> A. f x = b})) ` B - {{}}))) respects domain_and_range_permutation A B"
proof (rule congruentI)
  fix f f'
  assume "(f, f') \<in> domain_and_range_permutation A B"
  from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B" "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
    unfolding domain_and_range_permutation_def by auto
  have "(\<lambda>b. {x \<in> A. f x = b}) ` B = (\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B"
    using \<open>\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))\<close> by auto
  from this have "image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})) =
    image_mset card (mset_set ((\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}}))" by simp
  also have "image_mset card (mset_set ((\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}})) =
    image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}))"
    using permutes_implies_inv_image_on_eq[OF \<open>p\<^sub>B permutes B\<close>, of A] by metis
  also have "image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}})) =
    image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
  proof (rule multiset_eqI)
    fix n
    have "bij_betw (\<lambda>X. p\<^sub>A ` X) {X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n} {X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n}"
    proof (rule bij_betw_byWitness)
      show "\<forall>X\<in>{X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n}. inv p\<^sub>A ` p\<^sub>A ` X = X"
        by (meson \<open>p\<^sub>A permutes A\<close> image_inv_f_f permutes_inj)
      show "\<forall>X\<in>{X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n}. p\<^sub>A ` inv p\<^sub>A ` X = X"
        by (meson \<open>p\<^sub>A permutes A\<close> image_f_inv_f permutes_surj)
      show "(\<lambda>X. p\<^sub>A ` X) ` {X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n} \<subseteq> {X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n}"
      proof -
        have "card (p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b}) = card {x \<in> A. f' (p\<^sub>A x) = b}" for b
        proof -
          have "inj_on p\<^sub>A {x \<in> A. f' (p\<^sub>A x) = b}"
            by (metis (no_types, lifting) \<open>p\<^sub>A permutes A\<close> injD inj_onI permutes_inj)
          from this show ?thesis by (simp add: card_image)
        qed
        moreover have "p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b} = {x \<in> A. f' x = b}" for b
        proof
          show "p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b} \<subseteq> {x \<in> A. f' x = b}"
            by (auto simp add: \<open>p\<^sub>A permutes A\<close> permutes_in_image)
          show "{x \<in> A. f' x = b} \<subseteq> p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b}"
          proof
            fix x
            assume "x \<in> {x \<in> A. f' x = b}"
            moreover have "p\<^sub>A (inv p\<^sub>A x) = x"
              using \<open>p\<^sub>A permutes A\<close> permutes_inverses(1) by fastforce
            moreover from \<open>x \<in> {x \<in> A. f' x = b}\<close> have "inv p\<^sub>A x \<in> A"
              by (simp add: \<open>p\<^sub>A permutes A\<close> permutes_in_image permutes_inv)
            ultimately show "x \<in> p\<^sub>A ` {x \<in> A. f' (p\<^sub>A x) = b}"
              by (auto intro: image_eqI[where x="inv p\<^sub>A x"])
          qed
        qed
        ultimately show ?thesis by auto
      qed
      show "(\<lambda>X. inv p\<^sub>A ` X) ` {X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card X = n} \<subseteq> {X \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card X = n}"
      proof -
        have "card (inv p\<^sub>A ` {x \<in> A. f' x = b}) = card {x \<in> A. f' x = b}" for b
        proof -
          have "inj_on (inv p\<^sub>A) {x \<in> A. f' x = b}"
            by (metis (no_types, lifting) \<open>p\<^sub>A permutes A\<close> injD inj_onI permutes_surj surj_imp_inj_inv)
          from this show ?thesis by (simp add: card_image)
        qed
        moreover have "inv p\<^sub>A ` {x \<in> A. f' x = b} = {x \<in> A. f' (p\<^sub>A x) = b}" for b
        proof
          show "inv p\<^sub>A ` {x \<in> A. f' x = b} \<subseteq> {x \<in> A. f' (p\<^sub>A x) = b}"
            using \<open>p\<^sub>A permutes A\<close>
            by (auto simp add: permutes_in_image permutes_inv permutes_inverses(1))
          show "{x \<in> A. f' (p\<^sub>A x) = b} \<subseteq> inv p\<^sub>A ` {x \<in> A. f' x = b}"
          proof
            fix x
            assume "x \<in> {x \<in> A. f' (p\<^sub>A x) = b}"
            moreover have "inv p\<^sub>A (p\<^sub>A x) = x"
              by (meson \<open>p\<^sub>A permutes A\<close> permutes_inverses(2))
            moreover from \<open>x \<in> {x \<in> A. f' (p\<^sub>A x) = b}\<close> have "p\<^sub>A x \<in> A"
              by (simp add: \<open>p\<^sub>A permutes A\<close> permutes_in_image)
            ultimately show "x \<in> inv p\<^sub>A ` {x \<in> A. f' x = b}"
              by (auto intro: image_eqI[where x="p\<^sub>A x"])
          qed
        qed
        ultimately show ?thesis by auto
      qed
    qed
    from this have "card {x' \<in> (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}. card x' = n} = card {x' \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}. card x' = n}"
      by (rule bij_betw_same_card)
    from this show "count (image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}))) n =
      count (image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))) n"
      using \<open>finite B\<close> by (simp add: count_image_mset')
  qed
  finally show "image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})) =
    image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))" .
qed

end


theory Ex045
  imports Main
begin

theorem "C \<longrightarrow> \<not>A \<or> ((B \<or> C) \<longrightarrow> A)"
proof -
  {
    assume C
    {
      assume "\<not>(\<not>A \<or> ((B \<or> C) \<longrightarrow> A))"
      {
        assume A
        {
          assume "B \<or> C"
          from \<open>A\<close> have A by assumption
        }
        hence "(B \<or> C) \<longrightarrow> A" by (rule impI)
        hence "\<not>A \<or> ((B \<or> C) \<longrightarrow> A)" by (rule disjI2)
        with \<open>\<not>(\<not>A \<or> ((B \<or> C) \<longrightarrow> A))\<close> have False by (rule notE)
      }
      hence "\<not>A" by (rule notI)
      hence "\<not>A \<or> ((B \<or> C) \<longrightarrow> A)" by (rule disjI1)
      with \<open>\<not>(\<not>A \<or> ((B \<or> C) \<longrightarrow> A))\<close> have False by contradiction
    }
    hence "\<not>\<not>(\<not>A \<or> ((B \<or> C) \<longrightarrow> A))" by (rule notI)
    hence "\<not>A \<or> ((B \<or> C) \<longrightarrow> A)" by (rule notnotD)
  }
  thus ?thesis by (rule impI)
qed


theory Ex012
imports Main
begin

lemma "A \<longrightarrow> (A \<or> B)"
proof -
{
  assume A
  hence "A \<or> B" by (rule disjI1)
}
thus ?thesis by (rule impI)
qed


theory ListExt
imports ZF.List
begin

definition front :: "i \<Rightarrow> i" where
  "front(l) == rev( tl( rev(l) ) )"

declare leI [simp]
declare length_type [simp]
declare rev_type [simp]
declare tl_type [simp]

theorem rev_app_disturb: "\<lbrakk> xs: list(A); ys: list(B) \<rbrakk> \<Longrightarrow> rev(xs@ys) = rev(ys)@rev(xs)"
by(induct_tac xs, auto simp add: app_assoc)

lemma all_drop_length_Cons_t: "xs: list(A) \<Longrightarrow> ALL x. EX z. EX zs:list(A). drop( length(xs), Cons(x, xs) ) = Cons(z, zs)"
by(induct_tac xs, auto)

theorem drop_length_Cons_t: "xs: list(A) \<Longrightarrow> EX z. EX zs:list(A). drop( length(xs), Cons(x, xs) ) = Cons(z, zs)"
by(simp add: all_drop_length_Cons_t)

lemma in_length_in_nat[simp]: "\<lbrakk> l:list(A); i:length(l) \<rbrakk> \<Longrightarrow> (i:nat)"
proof -
  assume a: "l:list(A)" "i:length(l)"
  then have b: "length(l):nat" using length_type by simp
  then have "i < length(l)" using a lt_def by simp
  then show ?thesis using b lt_nat_in_nat by simp
qed

theorem drop_length_t: "\<lbrakk> l:list(A); i:length(l) \<rbrakk> \<Longrightarrow> EX z. EX zs:list(A). drop(i, l) = Cons(z, zs)"
proof -
  assume a: "l:list(A)" "i:length(l)"
  then have "EX z. EX zs. drop(i, l) = Cons(z, zs)" using drop_length by(auto)
  then obtain z where "EX zs. drop(i, l) = Cons(z, zs)" ..
  then obtain zs where b: "drop(i, l) = Cons(z, zs)" ..
  have "i:nat" using a in_length_in_nat by simp
  then have "drop(i, l):list(A)" using a drop_type by(auto)
  then have "Cons(z, zs):list(A)" using b by(auto)
  then have "zs:list(A)" by(auto)
  then have "EX zs:list(A). drop(i, l) = Cons(z, zs)" using b by(auto)
  then show ?thesis ..
qed

theorem drop_length_app: "\<lbrakk> l:list(A); l':list(B) \<rbrakk> \<Longrightarrow> drop(length(l), l @ l') = drop(length(l), l) @ l'"
apply(subst drop_append, auto)
done

theorem drop_length_in_succ: "\<lbrakk> l:list(A); ll:list(B); j:succ(length(l)) \<rbrakk> \<Longrightarrow> drop(j, l @ ll) = drop (j, l) @ ll"
apply(subst drop_append, auto)
proof -
  assume a: "l:list(A)" "ll:list(B)" "j:length(l)"
  then have b: "j < length(l)" using lt_def by simp
  then have "j #- length(l) = 0" using diff_is_0_lemma[of j "length(l)"] a b by simp
  then show "drop(j, l) @ drop(j #- length(l), ll) = drop(j, l) @ ll" by simp
qed

theorem hd_type: "\<lbrakk> l:list(A); 0 < length(l) \<rbrakk> \<Longrightarrow> hd(l):A"
apply(frule length_greater_0_iff, auto)
apply(case_tac l, auto)
done

theorem length_tl: "\<lbrakk> l:list(A) \<rbrakk> \<Longrightarrow> length(tl(l)) = length(l) #- 1"
apply(auto)
done

theorem length_0_nil: "\<lbrakk> l:list(A); length(l) = 0 \<rbrakk> \<Longrightarrow> l = []"
apply(auto)
done

declare front_def [simp]

theorem front_Nil: "front([]) = []"
apply(simp)
done

theorem front_Cons1: "front([a]) = []"
apply(simp)
done

theorem front_Cons2: "front([a, b]) = [a]"
apply(simp)
done

theorem front_app_end: "\<lbrakk> l:list(A); a:A; b:A \<rbrakk> \<Longrightarrow> front( Cons(a, l) @ [b]) = Cons(a, l)"
apply(simp)
apply((subst rev_app_distrib, simp+)+)
done

theorem front_Cons3: "\<lbrakk> l:list(A); a:A; b:A \<rbrakk> \<Longrightarrow> front( Cons(a, Cons(b, l))) = Cons(a, front(Cons(b, l)))"
apply(simp)
apply(subst rev_app_distrib, auto)
done

theorem front_type: "\<lbrakk> l:list(A) \<rbrakk> \<Longrightarrow> front(l):list(A)"
apply(simp)
done

lemma length_front_induct_lemma:
  " \<lbrakk>a \<in> A; l \<in> list(A); length(rev(tl(rev(l)))) = length(l) #- 1\<rbrakk>
    \<Longrightarrow> length(rev(tl(rev(l) @ [a]))) = length(l)"
proof -
  assume a:"a:A" "l:list(A)" "length(rev(tl(rev(l)))) = length(l) #- 1"
  then have b: "rev(l) @ [a]:list(A)" by simp
  then have "tl(rev(l) @ [a]):list(A)" by simp
  then have "length(rev(tl(rev(l) @ [a]))) = length(tl(rev(l) @ [a]))" using length_rev by simp
  then have "length(rev(tl(rev(l) @ [a]))) = length(rev(l) @ [a]) #- 1" using length_tl b by simp
  then have "length(rev(tl(rev(l) @ [a]))) = length(rev(l)) #+ length([a]) #- 1"
    using length_app a by simp
  then have "length(rev(tl(rev(l) @ [a]))) = length(l) #+ length([a]) #- 1"
    using length_rev a by simp
  then have "length(rev(tl(rev(l) @ [a]))) = length(l) #+ 1 #- 1" by simp
  then show ?thesis using a by simp
qed

theorem length_front: "\<lbrakk> l:list(A) \<rbrakk> \<Longrightarrow> length(front(l)) = length(l) #- 1"
apply(induct_tac l, auto)
apply(rule length_front_induct_lemma, simp+)
done

theorem rev_inject: "\<lbrakk> l:list(A); l':list(B) \<rbrakk> \<Longrightarrow> rev(l) = rev(l') <-> (l = l')"
apply(auto)
proof -
  assume a: "l:list(A)" "l':list(B)" and aa: "rev(l) = rev(l')"
  then have b: "rev(rev(l)) = rev(rev(l'))" by simp
  then have c: "rev(rev(l)) = l" using rev_rev_ident[of l A] a by simp
  then have "rev(rev(l')) = l'" using rev_rev_ident[of l' B] a by(simp only: mp)
  then show "l = l'" using b c by simp
qed

theorem rev_app_end: "\<lbrakk> l:list(A); l':list(B); a:C; a':E \<rbrakk> \<Longrightarrow> (rev(l @ [a]) = rev(l' @ [a'])) <-> (l = l' & a = a')"
proof(auto)
  assume a: "l \<in> list(A)" "l' \<in> list(B)" and aa: "a \<in> C" "a' \<in> E"
    and ab: "rev(l @ [a]) = rev(l' @ [a'])"
  have b: "rev(l @ [a]) = rev([a]) @ rev(l)" using rev_app_disturb a aa by simp
  have c: "rev(l' @ [a']) = rev([a']) @ rev(l')" using rev_app_disturb a aa by simp
  have "rev([a]) @ rev(l) = rev([a']) @ rev(l')" using ab b c by simp
  then have d: "[a] @ rev(l) = [a'] @ rev(l')" by simp
  then have "hd([a] @ rev(l)) = hd([a'] @ rev(l'))" by simp
  then have "a = a'" by simp
  then show "a = a'" by simp
  have "tl([a] @ rev(l)) = tl([a'] @ rev(l'))" using d by simp
  then have "rev(l) = rev(l')" by simp
  then have "l = l'" using rev_inject a by simp
  then show "l = l'" by simp
qed

theorem snoc_iff: "\<lbrakk> l:list(A); l':list(B); a:C; a':E \<rbrakk> \<Longrightarrow> (l @ [a] = l' @ [a']) <-> (l = l' & a = a')"
apply(auto)
proof -
  assume a: "l:list(A)" "l':list(B)" and aa: "a:C" "a':E" and ab: "l @ [a] = l' @ [a']"
  have "rev(l @ [a]) = rev(l' @ [a'])" using ab by simp
  then have b: "l = l' & a = a'" using rev_app_end a aa by simp
  then show "l = l'" by simp
  show "a = a'" using b by simp
qed

declare leI [simp del]
declare length_type [simp del]
declare rev_type [simp del]
declare tl_type [simp del]
declare front_def [simp del]

lemmas list_typechecks =
  hd_type tl_type front_type list_rec_type
  map_type map_type2 app_type length_type rev_type flat_type
  list_add_type drop_type Cons Nil

lemmas list_simps =
  app_Nil app_Cons drop_0 drop_Nil drop_succ_Cons
  front_Cons1 front_Nil front_Cons2 front_Cons3

lemmas list_ss = list_typechecks list_simps
declare list_ss [simp]

end