(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Ordinal Induction\<close>

theory OrdinalInduct
imports OrdinalDef
begin

subsection \<open>Zero and successor ordinals\<close>

definition
  oSuc :: "ordinal \<Rightarrow> ordinal" where
    "oSuc x = oStrictLimit (\<lambda>n. x)"

lemma less_oSuc[iff]: "x < oSuc x"
  by (metis oStrictLimit_ub oSuc_def)

lemma oSuc_leI: "x < y \<Longrightarrow> oSuc x \<le> y"
  by (simp add: oStrictLimit_lub oSuc_def)

instantiation ordinal :: "{zero, one}"
begin

definition
  ordinal_zero_def:       "(0::ordinal) = oZero"

definition
  ordinal_one_def [simp]: "(1::ordinal) = oSuc 0"

instance ..

end

subsubsection \<open>Derived properties of 0 and oSuc\<close>

lemma less_oSuc_eq_le: "(x < oSuc y) = (x \<le> y)"
  by (metis dual_order.strict_trans1 less_oSuc linorder_not_le oSuc_leI)

lemma ordinal_0_le [iff]: "0 \<le> (x::ordinal)"
  by (simp add: oZero_least ordinal_zero_def)

lemma ordinal_not_less_0 [iff]: "\<not> (x::ordinal) < 0"
  by (simp add: linorder_not_less)

lemma ordinal_le_0 [iff]: "(x \<le> 0) = (x = (0::ordinal))"
  by (simp add: order_le_less)

lemma ordinal_neq_0 [iff]: "(x \<noteq> 0) = (0 < (x::ordinal))"
  by (simp add: order_less_le)

lemma ordinal_not_0_less [iff]: "(\<not> 0 < x) = (x = (0::ordinal))"
  by (simp add: linorder_not_less)

lemma zero_less_oSuc [iff]: "0 < oSuc x"
  by (rule order_le_less_trans, rule ordinal_0_le, rule less_oSuc)

lemma oSuc_not_0 [iff]: "oSuc x \<noteq> 0"
  by simp

lemma less_oSuc0 [iff]: "(x < oSuc 0) = (x = 0)"
  by (simp add: less_oSuc_eq_le)

lemma oSuc_less_oSuc [iff]: "(oSuc x < oSuc y) = (x < y)"
  by (simp add: less_oSuc_eq_le oSuc_le_eq_less)

lemma oSuc_eq_oSuc [iff]: "(oSuc x = oSuc y) = (x = y)"
  by (metis less_oSuc less_oSuc_eq_le order_antisym)

lemma oSuc_le_oSuc [iff]: "(oSuc x \<le> oSuc y) = (x \<le> y)"
  by (simp add: order_le_less)

lemma le_oSucE:
  "\<lbrakk>x \<le> oSuc y; x \<le> y \<Longrightarrow> R; x = oSuc y \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp add: order_le_less less_oSuc_eq_le)

lemma less_oSucE:
  "\<lbrakk>x < oSuc y; x < y \<Longrightarrow> P; x = y \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (auto simp add: less_oSuc_eq_le order_le_less)

subsection \<open>Strict monotonicity\<close>

locale strict_mono =
  fixes f
  assumes strict_mono: "A < B \<Longrightarrow> f A < f B"

lemmas strict_monoI = strict_mono.intro
  and strict_monoD = strict_mono.strict_mono

lemma strict_mono_natI:
  fixes f :: "nat \<Rightarrow> 'a::order"
  shows "(\<And>n. f n < f (Suc n)) \<Longrightarrow> strict_mono f"
  using OrdinalInduct.strict_monoI lift_Suc_mono_less by blast

lemma mono_natI:
  fixes f :: "nat \<Rightarrow> 'a::order"
  shows "(\<And>n. f n \<le> f (Suc n)) \<Longrightarrow> mono f"
  by (simp add: mono_iff_le_Suc)

lemma strict_mono_mono:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "strict_mono f \<Longrightarrow> mono f"
  by (auto intro!: monoI simp add: order_le_less strict_monoD)

lemma strict_mono_monoD:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "\<lbrakk>strict_mono f; A \<le> B\<rbrakk> \<Longrightarrow> f A \<le> f B"
  by (rule monoD[OF strict_mono_mono])

lemma strict_mono_cancel_eq:
  fixes f :: "'a::linorder \<Rightarrow> 'b::linorder"
  shows "strict_mono f \<Longrightarrow> (f x = f y) = (x = y)"
  by (metis OrdinalInduct.strict_monoD not_less_iff_gr_or_eq)

lemma strict_mono_cancel_less:
  fixes f :: "'a::linorder \<Rightarrow> 'b::linorder"
  shows "strict_mono f \<Longrightarrow> (f x < f y) = (x < y)"
  using OrdinalInduct.strict_monoD linorder_neq_iff by fastforce

lemma strict_mono_cancel_le:
  fixes f :: "'a::linorder \<Rightarrow> 'b::linorder"
  shows "strict_mono f \<Longrightarrow> (f x \<le> f y) = (x \<le> y)"
  by (meson linorder_not_less strict_mono_cancel_less)

subsection \<open>Limit ordinals\<close>

definition
  oLimit :: "(nat \<Rightarrow> ordinal) \<Rightarrow> ordinal" where
  "oLimit f = (LEAST k. \<forall>n. f n \<le> k)"

lemma oLimit_leI: "\<forall>n. f n \<le> x \<Longrightarrow> oLimit f \<le> x"
  by (simp add: oLimit_def wellorder_Least_lemma(2))

lemma le_oLimit [iff]: "f n \<le> oLimit f"
  by (smt (verit, best) LeastI_ex leD oLimit_def oStrictLimit_ub ordinal_linear)

lemma le_oLimitI: "x \<le> f n \<Longrightarrow> x \<le> oLimit f"
  by (erule order_trans, rule le_oLimit)

lemma less_oLimitI: "x < f n \<Longrightarrow> x < oLimit f"
  by (erule order_less_le_trans, rule le_oLimit)

lemma less_oLimitD: "x < oLimit f \<Longrightarrow> \<exists>n. x < f n"
  by (meson linorder_not_le oLimit_leI)

lemma less_oLimitE: "\<lbrakk>x < oLimit f; \<And>n. x < f n \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (auto dest: less_oLimitD)

lemma le_oLimitE:
  "\<lbrakk>x \<le> oLimit f; \<And>n. x \<le> f n \<Longrightarrow> R; x = oLimit f \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp add: order_le_less dest: less_oLimitD)

lemma oLimit_const [simp]: "oLimit (\<lambda>n. x) = x"
  by (meson dual_order.refl le_oLimit oLimit_leI order_antisym)

lemma strict_mono_less_oLimit: "strict_mono f \<Longrightarrow> f n < oLimit f"
  by (meson OrdinalInduct.strict_monoD lessI less_oLimitI)

lemma oLimit_eqI:
  "\<lbrakk>\<And>n. \<exists>m. f n \<le> g m; \<And>n. \<exists>m. g n \<le> f m\<rbrakk> \<Longrightarrow> oLimit f = oLimit g"
  by (meson le_oLimitI nle_le oLimit_leI)

lemma oLimit_Suc:
  "f 0 < oLimit f \<Longrightarrow> oLimit (\<lambda>n. f (Suc n)) = oLimit f"
  by (smt (verit, ccfv_SIG) linorder_not_le nle_le oLimit_eqI oLimit_leI old.nat.exhaust)

lemma oLimit_shift:
  "\<forall>n. f n < oLimit f \<Longrightarrow> oLimit (\<lambda>n. f (n + k)) = oLimit f"
  apply (induct_tac k, simp)
  by (metis (no_types, lifting) add_Suc_shift leD le_oLimit less_oLimitD not_less_iff_gr_or_eq oLimit_Suc)

lemma oLimit_shift_mono:
  "mono f \<Longrightarrow> oLimit (\<lambda>n. f (n + k)) = oLimit f"
  by (meson le_add1 monoD oLimit_eqI)

text "limit ordinal predicate"

definition
  limit_ordinal :: "ordinal \<Rightarrow> bool" where
  "limit_ordinal x \<longleftrightarrow> (x \<noteq> 0) \<and> (\<forall>y. x \<noteq> oSuc y)"

lemma limit_ordinal_not_0 [simp]: "\<not> limit_ordinal 0"
  by (simp add: limit_ordinal_def)

lemma zero_less_limit_ordinal [simp]: "limit_ordinal x \<Longrightarrow> 0 < x"
  by (simp add: limit_ordinal_def)

lemma limit_ordinal_not_oSuc [simp]: "\<not> limit_ordinal (oSuc p)"
  by (simp add: limit_ordinal_def)

lemma oSuc_less_limit_ordinal:
  "limit_ordinal x \<Longrightarrow> (oSuc w < x) = (w < x)"
  by (metis limit_ordinal_not_oSuc oSuc_le_eq_less order_le_less)

lemma limit_ordinal_oLimitI:
  "\<forall>n. f n < oLimit f \<Longrightarrow> limit_ordinal (oLimit f)"
  by (metis less_oLimitD less_oSuc less_oSucE limit_ordinal_def order_less_imp_triv ordinal_neq_0)

lemma strict_mono_limit_ordinal:
  "strict_mono f \<Longrightarrow> limit_ordinal (oLimit f)"
  by (simp add: limit_ordinal_oLimitI strict_mono_less_oLimit)

lemma limit_ordinalI:
  "\<lbrakk>0 < z; \<forall>x<z. oSuc x < z\<rbrakk> \<Longrightarrow> limit_ordinal z"
  using limit_ordinal_def by blast

subsubsection \<open>Making strict monotonic sequences\<close>

primrec make_mono :: "(nat \<Rightarrow> ordinal) \<Rightarrow> nat \<Rightarrow> nat"
  where
    "make_mono f 0       = 0"
  | "make_mono f (Suc n) = (LEAST x. f (make_mono f n) < f x)"

lemma strict_mono_f_make_mono:
  "\<forall>n. f n < oLimit f \<Longrightarrow> strict_mono (\<lambda>n. f (make_mono f n))"
  by (rule strict_mono_natI, erule f_make_mono_less)

lemma le_f_make_mono:
  "\<lbrakk>\<forall>n. f n < oLimit f; m \<le> make_mono f n\<rbrakk> \<Longrightarrow> f m \<le> f (make_mono f n)"
  apply (auto simp add: order_le_less)
  apply (case_tac n, simp_all)
  by (metis LeastI less_oLimitD linorder_le_less_linear not_less_Least order_le_less_trans)

lemma make_mono_less:
  "\<forall>n. f n < oLimit f \<Longrightarrow> make_mono f n < make_mono f (Suc n)"
  by (meson f_make_mono_less le_f_make_mono linorder_not_less)

declare make_mono.simps [simp del]

lemma oLimit_make_mono_eq:
  assumes "\<forall>n. f n < oLimit f" shows "oLimit (\<lambda>n. f (make_mono f n)) = oLimit f"
proof -
  have "k \<le> make_mono f k" for k
    by (induction k) (auto simp: Suc_leI assms make_mono_less order_le_less_trans)
  then show ?thesis
    by (meson assms le_f_make_mono oLimit_eqI)
qed

subsection \<open>Induction principle for ordinals\<close>

lemma oLimit_le_oStrictLimit: "oLimit f \<le> oStrictLimit f"
  by (simp add: oLimit_leI oStrictLimit_ub order_less_imp_le)

lemma oLimit_induct [case_names zero suc lim]:
assumes zero: "P 0"
    and suc:  "\<And>x. P x \<Longrightarrow> P (oSuc x)"
    and lim:  "\<And>f. \<lbrakk>strict_mono f; \<forall>n. P (f n)\<rbrakk> \<Longrightarrow> P (oLimit f)"
shows "P a"
 apply (rule oStrictLimit_induct)
  apply (rule zero[unfolded ordinal_zero_def])
 apply (cut_tac f=f in oLimit_le_oStrictLimit)
 apply (simp add: order_le_less, erule disjE)
  apply (metis dual_order.order_iff_strict leD le_oLimit less_oStrictLimitD oSuc_le_eq_less suc)
  by (metis lim oLimit_make_mono_eq oStrictLimit_ub strict_mono_f_make_mono)

lemma ordinal_cases [case_names zero suc lim]:
assumes zero: "a = 0 \<Longrightarrow> P"
    and suc:  "\<And>x. a = oSuc x \<Longrightarrow> P"
    and lim:  "\<And>f. \<lbrakk>strict_mono f; a = oLimit f\<rbrakk> \<Longrightarrow> P"
  shows "P"
 apply (subgoal_tac "\<forall>x. a = x \<longrightarrow> P", force)
 apply (rule allI)
 apply (rule_tac a=x in oLimit_induct)
   apply (rule impI, erule zero)
  apply (rule impI, erule suc)
 apply (rule impI, erule lim, assumption)
done

end


section \<open>Simulation Systems\<close>

theory "Transition_Systems-Simulation_Systems"
imports
  "Transition_Systems-Foundations"
  "HOL-Eisbach.Eisbach"
begin

unbundle lattice_syntax

locale simulation_system =
  fixes original_transition :: "'a \<Rightarrow> 'p relation" (\<open>'(\<rightharpoonup>\<lparr>_\<rparr>')\<close>)
  fixes simulating_transition :: "'a \<Rightarrow> 'p relation" (\<open>'(\<rightharpoondown>\<lparr>_\<rparr>')\<close>)
begin

abbreviation original_transition_std :: "'p \<Rightarrow> 'a \<Rightarrow> 'p \<Rightarrow> bool" (\<open>(_ \<rightharpoonup>\<lparr>_\<rparr>/ _)\<close> [51, 0, 51] 50) where
  "p \<rightharpoonup>\<lparr>\<alpha>\<rparr> q \<equiv> (\<rightharpoonup>\<lparr>\<alpha>\<rparr>) p q"
abbreviation simulating_transition_std :: "'p \<Rightarrow> 'a \<Rightarrow> 'p \<Rightarrow> bool" (\<open>(_ \<rightharpoondown>\<lparr>_\<rparr> _)\<close> [51, 0, 51] 50) where
  "p \<rightharpoondown>\<lparr>\<alpha>\<rparr> q \<equiv> (\<rightharpoondown>\<lparr>\<alpha>\<rparr>) p q"

subsection \<open>Simulations and Bisimulations\<close>

definition unilateral_progression :: "'p relation \<Rightarrow> 'p relation \<Rightarrow> bool" (infix \<open>\<hookrightarrow>\<close> 50) where
  [iff]: "K \<hookrightarrow> L \<longleftrightarrow> (\<forall>\<alpha>. K\<inverse>\<inverse> OO (\<rightharpoonup>\<lparr>\<alpha>\<rparr>) \<le> (\<rightharpoondown>\<lparr>\<alpha>\<rparr>) OO L\<inverse>\<inverse>)"

definition bilateral_progression :: "'p relation \<Rightarrow> 'p relation \<Rightarrow> bool" (infix \<open>\<mapsto>\<close> 50) where
  [iff]: "K \<mapsto> L \<longleftrightarrow> K \<hookrightarrow> L \<and> K\<inverse>\<inverse> \<hookrightarrow> L\<inverse>\<inverse>"

definition simulation :: "'p relation \<Rightarrow> bool" (\<open>sim\<close>) where
  [iff]: "sim K \<longleftrightarrow> K \<hookrightarrow> K"

definition bisimulation :: "'p relation \<Rightarrow> bool" (\<open>bisim\<close>) where
  [iff]: "bisim K \<longleftrightarrow> K \<mapsto> K"

subsection \<open>Bisimilarity\<close>

coinductive bisimilarity :: "'p relation" (infix \<open>\<sim>\<close> 50) where
  bisimilarity:
    "p \<sim> q"
    if
      "\<And>\<alpha> p'. p \<rightharpoonup>\<lparr>\<alpha>\<rparr> p' \<Longrightarrow> \<exists>q'. q \<rightharpoondown>\<lparr>\<alpha>\<rparr> q' \<and> p' \<sim> q'"
    and
      "\<And>\<alpha> q'. q \<rightharpoonup>\<lparr>\<alpha>\<rparr> q' \<Longrightarrow> \<exists>p'. p \<rightharpoondown>\<lparr>\<alpha>\<rparr> p' \<and> p' \<sim> q'"

lemma bisimilarity_symmetry_rule [sym]:
  assumes "p \<sim> q"
  shows "q \<sim> p"
  using assms by (coinduction arbitrary: p q) (simp, blast elim: bisimilarity.cases)

lemma bisimilarity_symmetry: "symp (\<sim>)"
  using bisimilarity_symmetry_rule ..

text \<open>
  The following two transitivity rules are useful for calculational reasoning with both equality and
  bisimilarity.
\<close>

lemma equality_bisimilarity_transitivity_rule [trans]:
  assumes "p = q" and "q \<sim> r"
  shows "p \<sim> r"
  using assms
  by simp

lemma bisimilarity_equality_transititity_rule [trans]:
  assumes "p \<sim> q" and "q = r"
  shows "p \<sim> r"
  using assms
  by simp

lemma bisimilarity_is_bisimulation:
  shows "bisim (\<sim>)"
  by (blast elim: bisimilarity.cases)

lemma bisimilarity_is_simulation:
  shows "sim (\<sim>)"
  using bisimilarity_is_bisimulation by simp

lemma bisimulation_in_bisimilarity:
  assumes "bisim K"
  shows "K \<le> (\<sim>)"
proof
  fix p and q
  assume "K p q"
  with \<open>bisim K\<close> show "p \<sim> q"
    by (coinduction arbitrary: p q) (simp, blast)
qed

theorem bisimilarity_is_greatest_bisimulation:
  shows "(\<sim>) = (GREATEST K. bisim K)"
  using bisimilarity_is_bisimulation and bisimulation_in_bisimilarity
  by (simp add: Greatest_equality)

subsection \<open>Respectful Functions\<close>

definition shortcut_progression :: "'p relation \<Rightarrow> 'p relation \<Rightarrow> bool" (infix \<open>\<leadsto>\<close> 50) where
  [simp]: "(\<leadsto>) = (\<le>) \<sqinter> (\<mapsto>)"

text \<open>
  We chose the term ``shortcut progression'', because \<open>(\<le>)\<close> is \<open>(\<mapsto>)\<close> for
  \<open>(\<rightharpoonup>)\<lparr>\<alpha>\<rparr> = (=) \<and> (\<rightharpoondown>)\<lparr>\<alpha>\<rparr> = (=)\<close> and we have \<open>(=) = (\<rightharpoonup>)\<lparr>\<alpha>\<rparr>\<^bsup>0\<^esup> \<and> (=) = (\<rightharpoondown>)\<lparr>\<alpha>\<rparr>\<^bsup>0\<^esup>\<close>. This is made
  formal in the following note.
\<close>

notepad begin
  interpret shortcut: simulation_system \<open>\<lambda>\<alpha>. (\<rightharpoonup>\<lparr>\<alpha>\<rparr>)\<^bsup>0\<^esup>\<close> \<open>\<lambda>\<alpha>. (\<rightharpoondown>\<lparr>\<alpha>\<rparr>)\<^bsup>0\<^esup>\<close> .
  have "shortcut.unilateral_progression = (\<le>)"
    unfolding shortcut.unilateral_progression_def
    by auto
  have "shortcut.bilateral_progression = (\<le>)"
    unfolding shortcut.unilateral_progression_def and shortcut.bilateral_progression_def
    by auto
end

lemma general_union_shortcut_progression:
  assumes "\<forall>K \<in> \<K>. \<exists>L \<in> \<L>. K \<leadsto> L"
  shows "\<Squnion> \<K> \<leadsto> \<Squnion> \<L>"
  using assms by (simp, fast)

definition respectful :: "('p relation \<Rightarrow> 'p relation) \<Rightarrow> bool" where
  [iff]: "respectful \<F> \<longleftrightarrow> (\<forall>K L. K \<leadsto> L \<longrightarrow> \<F> K \<leadsto> \<F> L)"

subsubsection \<open>Automatic Proof of Respectfulness\<close>

text \<open>
  We work with a single list of respectfulness facts anyhow. It would be weird to have this single
  fact list and the same \<^theory_text>\<open>respectful\<close> method based on it in each concrete interpretation. When
  invoking the method in the theory context, we would have to pick it from an interpretation, but
  which interpretation we chose would be arbitrary. Therefore we temporarily leave the locale
  context.
\<close>

end

named_theorems respectful

text \<open>
  Note that the \<^theory_text>\<open>respectful\<close> methods works also on conclusions that contain function
  variables~\<^term>\<open>\<F>\<close> if there are premises \<^term>\<open>respectful \<F>\<close>.
\<close>

method respectful = (intro respectful ballI | elim emptyE insertE | simp only:)+

context simulation_system begin

subsubsection \<open>Common Respectful Functions and Respectful Function Combinators\<close>

(*FIXME:
  Explain that we want \<open>\<bottom>\<close> for those cases where bisimilarity holds, because no transitions are
  possible at all.
*)

lemma bottom_is_respectful [respectful]:
  shows "respectful \<bottom>"
  by auto

definition constant_bisimilarity :: "'p relation \<Rightarrow> 'p relation" (\<open>[\<sim>]\<close>) where
  [simp]: "[\<sim>] = (\<lambda>_. (\<sim>))"

lemma constant_bisimilarity_is_respectful [respectful]:
  shows "respectful [\<sim>]"
  using bisimilarity_is_bisimulation by simp

lemma identity_is_respectful [respectful]:
  shows "respectful id"
  by simp

lemma function_composition_is_respectful [respectful]:
  assumes "respectful \<F>" and "respectful \<G>"
  shows "respectful (\<F> \<circ> \<G>)"
  using assms by simp

lemma general_union_is_respectful [respectful]:
  assumes "\<forall>\<F> \<in> \<FF>. respectful \<F>"
  shows "respectful (\<Squnion> \<FF>)"
proof -
  have "(\<Squnion> \<FF>) K \<leadsto> (\<Squnion> \<FF>) L" if "K \<leadsto> L" for K and L
  proof -
    from \<open>\<forall>\<F> \<in> \<FF>. respectful \<F>\<close> and \<open>K \<leadsto> L\<close> have "\<forall>\<F> \<in> \<FF>. \<F> K \<leadsto> \<F> L"
      by simp
    then have "\<forall>K' \<in> {\<F> K | \<F>. \<F> \<in> \<FF>}. \<exists>L' \<in> {\<F> L | \<F>. \<F> \<in> \<FF>}. K' \<leadsto> L'"
      by blast
    then have "\<Squnion> {\<F> K | \<F>. \<F> \<in> \<FF>} \<leadsto> \<Squnion> {\<F> L | \<F>. \<F> \<in> \<FF>}"
      by (fact general_union_shortcut_progression)
    moreover have "\<Squnion> {\<F> M | \<F>. \<F> \<in> \<FF>} = (\<Squnion> \<FF>) M" for M
      by auto
    ultimately show ?thesis
      by simp
  qed
  then show ?thesis by simp
qed

lemma union_is_respectful [respectful]:
  assumes "respectful \<F>" and "respectful \<G>"
  shows "respectful (\<F> \<squnion> \<G>)"
proof-
  from assms have "\<forall>\<H> \<in> {\<F>, \<G>}. respectful \<H>"
    by simp
  then have "respectful (\<Squnion> {\<F>, \<G>})"
    by (fact general_union_is_respectful)
  then show ?thesis
    by simp
qed

lemma dual_is_respectful [respectful]:
  assumes "respectful \<F>"
  shows "respectful \<F>\<^sup>\<dagger>"
  using assms by simp

subsubsection \<open>Respectfully Transformed Bisimilarity\<close>

theorem respectfully_transformed_bisimilarity_in_bisimilarity:
  assumes "respectful \<F>"
  shows "\<F> (\<sim>) \<le> (\<sim>)"
proof -
  from \<open>respectful \<F>\<close> have "bisim (\<F> (\<sim>))"
    using bisimilarity_is_bisimulation
    by simp
  then show ?thesis
    using bisimulation_in_bisimilarity
    by simp
qed

subsection \<open>``Up to'' Methods\<close>

definition simulation_up_to :: "('p relation \<Rightarrow> 'p relation) \<Rightarrow> 'p relation \<Rightarrow> bool" (\<open>sim\<^bsub>_\<^esub>\<close>) where
  [iff]: "sim\<^bsub>\<F>\<^esub> K \<longleftrightarrow> K \<hookrightarrow> \<F> K"

definition bisimulation_up_to :: "('p relation \<Rightarrow> 'p relation) \<Rightarrow> 'p relation \<Rightarrow> bool" (\<open>bisim\<^bsub>_\<^esub>\<close>) where
  [iff]: "bisim\<^bsub>\<F>\<^esub> K \<longleftrightarrow> K \<mapsto> \<F> K"

lemma simulation_up_to_identity_is_simulation_and_vice_versa:
  shows "sim\<^bsub>id\<^esub> K \<longleftrightarrow> sim K"
  by simp

lemma bisimulation_up_to_identity_is_bisimulation_and_vice_versa:
  shows "bisim\<^bsub>id\<^esub> K \<longleftrightarrow> bisim K"
  by simp

subsubsection \<open>Soundness\<close>

context begin

private definition
  expansion :: "('p relation \<Rightarrow> 'p relation) \<Rightarrow> ('p relation \<Rightarrow> 'p relation)"
  (\<open>(\<langle>_\<rangle>)\<close>)
where
  [simp]: "\<langle>\<F>\<rangle> = id \<squnion> \<F>"

private lemma expansion_is_respectful:
  assumes "respectful \<F>"
  shows "respectful \<langle>\<F>\<rangle>"
  unfolding expansion_def
  using identity_is_respectful and union_is_respectful and assms
  by iprover

private lemma bisimulation_from_bisimulation_up_to:
  assumes "respectful \<F>" and "bisim\<^bsub>\<F>\<^esub> K"
  shows "bisim (\<Squnion>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K)"
proof -
  have "\<langle>\<F>\<rangle>\<^bsup>n\<^esup> K \<leadsto> \<langle>\<F>\<rangle>\<^bsup>Suc n\<^esup> K" for n
  proof (induction n)
    case 0
    from \<open>bisim\<^bsub>\<F>\<^esub> K\<close> show ?case
      by (simp, blast)
  next
    case Suc
    with \<open>respectful \<F>\<close> show ?case
      using expansion_is_respectful
      by (simp del: shortcut_progression_def expansion_def)
  qed
  then have "\<forall>K' \<in> range (\<lambda>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K). \<exists>L' \<in> range (\<lambda>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K). K' \<leadsto> L'"
    by blast
  then have "(\<Squnion>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K) \<leadsto> (\<Squnion>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K)"
    by (fact general_union_shortcut_progression)
  then show ?thesis
    by simp
qed

theorem up_to_is_sound:
  assumes "respectful \<F>" and "bisim\<^bsub>\<F>\<^esub> K"
  shows "K \<le> (\<sim>)"
proof -
  from assms have "bisim (\<Squnion>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K)"
    by (fact bisimulation_from_bisimulation_up_to)
  then have "(\<Squnion>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K) \<le> (\<sim>)"
    by (fact bisimulation_in_bisimilarity)
  moreover have "K \<le> (\<Squnion>n. \<langle>\<F>\<rangle>\<^bsup>n\<^esup> K)"
    by (subst funpow_0 [of "\<langle>\<F>\<rangle>" K, symmetric], blast)
  ultimately show ?thesis
    by simp
qed

end

context begin

private lemma bisimulation_up_to_from_simulation_up_to:
  assumes "symp K" and "sim\<^bsub>\<F>\<^esub> K"
  shows "bisim\<^bsub>\<F> \<squnion> \<F>\<^sup>\<dagger>\<^esub> K"
proof -
  from \<open>symp K\<close> have "K\<inverse>\<inverse> = K"
    by (blast elim: sympE)
  with \<open>sim\<^bsub>\<F>\<^esub> K\<close> show ?thesis
    by auto
qed

theorem symmetric_up_to_is_sound:
  assumes "respectful \<F>" and "symp K" and "sim\<^bsub>\<F>\<^esub> K"
  shows "K \<le> (\<sim>)"
proof -
  from \<open>respectful \<F>\<close> have "respectful (\<F> \<squnion> \<F>\<^sup>\<dagger>)"
    by respectful
  moreover from \<open>symp K\<close> and \<open>sim\<^bsub>\<F>\<^esub> K\<close> have "bisim\<^bsub>\<F> \<squnion> \<F>\<^sup>\<dagger>\<^esub> K"
    by (fact bisimulation_up_to_from_simulation_up_to)
  ultimately show ?thesis
    by (fact up_to_is_sound)
qed

end

subsubsection \<open>Coinduction Rules\<close>

text \<open>
  The following corollaries are coinduction rules that correspond to the above soundness lemmas. To
  use an ``up to'' method, pick the corresponding rule, instantiate the variable~\<^term>\<open>\<F>\<close>
  appropriately, and pass the resulting fact to the \<^theory_text>\<open>coinduction\<close> method via a \<^theory_text>\<open>rule\<close>
  specification, along with an appropriate \<^theory_text>\<open>arbitrary\<close> specification. The \<^theory_text>\<open>coinduction\<close> method
  automatically derives the relation~\<^term>\<open>K\<close> from the goal and proves the assumption \<^term>\<open>K s t\<close>.
\<close>

corollary up_to_rule [case_names respectful forward_simulation backward_simulation]:
  assumes
    "K s t"
  and
    "respectful \<F>"
  and
    "\<And>\<alpha> s t s'. K s t \<Longrightarrow> s \<rightharpoonup>\<lparr>\<alpha>\<rparr> s' \<Longrightarrow> \<exists>t'. t \<rightharpoondown>\<lparr>\<alpha>\<rparr> t' \<and> \<F> K s' t'"
  and
    "\<And>\<alpha> s t t'. K s t \<Longrightarrow> t \<rightharpoonup>\<lparr>\<alpha>\<rparr> t' \<Longrightarrow> \<exists>s'. s \<rightharpoondown>\<lparr>\<alpha>\<rparr> s' \<and> \<F> K s' t'"
  shows "s \<sim> t"
  using up_to_is_sound [OF \<open>respectful \<F>\<close>, of K] and assms(1,3-4)
  by blast

corollary symmetric_up_to_rule [case_names respectful symmetry simulation]:
  assumes
    "K s t"
  and
    "respectful \<F>"
  and
    "\<And>s t. K s t \<Longrightarrow> K t s"
  and
    "\<And>\<alpha> s t s'. K s t \<Longrightarrow> s \<rightharpoonup>\<lparr>\<alpha>\<rparr> s' \<Longrightarrow> \<exists>t'. t \<rightharpoondown>\<lparr>\<alpha>\<rparr> t' \<and> \<F> K s' t'"
  shows "s \<sim> t"
  using symmetric_up_to_is_sound [OF \<open>respectful \<F>\<close>, of K] and assms (1,3-4)
  unfolding symp_def
  by blast

end

end


(* GEB MIU Puzzle *)

theory "miu"
  imports Main

begin

datatype miu = M | I | U

inductive_set MIU :: "miu list set" where
  "[M, I] : MIU" |
  "x @ [I] : MIU \<Longrightarrow> x @ [I, U] : MIU" |  (* \<Longrightarrow> abbreviation is "= = >" *)
  "[M] @ x : MIU \<Longrightarrow> [M] @ x @ x : MIU" |
  "x @ [I, I, I] @ y : MIU \<Longrightarrow> x @ [U] @ y : MIU" |
  "x @ [U, U] @ y : MIU \<Longrightarrow> x @ y : MIU"

fun ci :: "miu list \<Rightarrow> nat" where        (* \<Rightarrow> abbreviation is "= >" *)
  "ci [] = 0" |
  "ci (x # xs) = (if x = I then ci xs + 1 else ci xs)"

lemma [rule_format, simp] : "\<forall> y. ci (x @ y) = ci x + ci y"
  apply (induct_tac x)
   apply (auto)
  done
                                              (* \<noteq> abbs "~ =" *)
lemma miu_inv : "x \<in> MIU \<Longrightarrow> ci x mod 3 \<noteq> 0"  (* \<in> abbs "i n" *)
  apply (erule MIU.induct)
      apply (auto)
  apply (arith)
  done

theorem th_miu'' : "[M, U] \<notin> MIU"    (* \<notin> abbs "~ :" *)
  (* \<not> [M, U] \<notin> S \<Longrightarrow> [M, U] \<notin> S *)
  apply (rule classical)
  apply (simp)
  apply (drule miu_inv)
  apply (simp)
  done

theorem th_miu' : "[M, U] \<notin> MIU"
proof (rule classical)  (* \<not> [M, U] \<notin> S \<Longrightarrow> [M, U] \<notin> S *)
  assume "\<not> [M, U] \<notin> MIU"
  from this have 1 : "[M, U] : MIU" by simp
  from this have "ci [M, U] mod 3 \<noteq> 0" by (rule miu_inv)
  from this have  2: "\<not> [M, U] : MIU" by simp
  from 1 and 2 have "False" by simp
  from this show "[M, U] \<notin> MIU" by simp
qed

theorem th_miu : "[M, U] \<notin> MIU"
proof (rule classical)  (* \<not> [M, U] \<notin> S \<Longrightarrow> [M, U] \<notin> S *)
  assume "\<not> [M, U] \<notin> MIU"
  hence 1 : "[M, U] : MIU" by simp
  hence "ci [M, U] mod 3 \<noteq> 0" by (rule miu_inv)
  hence 2: "\<not> [M, U] : MIU" by simp
  from 1 and 2 have "False" by simp
  thus "[M, U] \<notin> MIU" by simp
qed

(* END *)


section \<open>Sphere\<close>
theory Sphere
  imports Differentiable_Manifold
begin

typedef (overloaded) ('a::real_normed_vector) sphere =
  "{a::'a\<times>real. norm a = 1}"
proof -
  have "norm (0::'a,1::real) = 1" by simp
  then show ?thesis by blast
qed

setup_lifting type_definition_sphere

(* First stereographic projection: between S^n - (0,1) and R^n. *)
lift_definition top_sphere :: "('a::real_normed_vector) sphere" is "(0, 1)" by simp

lift_definition st_proj1 :: "('a::real_normed_vector) sphere \<Rightarrow> 'a" is
  "\<lambda>(x,z). x /\<^sub>R (1 - z)" .

lift_definition st_proj1_inv :: "('a::real_normed_vector) \<Rightarrow> 'a sphere" is
  "\<lambda>x. ((2 / ((norm x) ^ 2 + 1)) *\<^sub>R x, ((norm x) ^ 2 - 1) / ((norm x) ^ 2 + 1))"
  apply (auto simp: norm_prod_def divide_simps algebra_simps)
   apply (auto simp: add_nonneg_eq_0_iff)
  by (auto simp: power2_eq_square algebra_simps)

(* Second stereographic projection: between S^n - (0,-1) and R^n. *)
lift_definition bot_sphere :: "('a::real_normed_vector) sphere" is "(0, -1)" by simp

lift_definition st_proj2 :: "('a::real_normed_vector) sphere \<Rightarrow> 'a" is
  "\<lambda>(x,z). x /\<^sub>R (1 + z)" .

lift_definition st_proj2_inv :: "('a::real_normed_vector) \<Rightarrow> 'a sphere" is
  "\<lambda>x. ((2 / ((norm x) ^ 2 + 1)) *\<^sub>R x, (1 - (norm x) ^ 2) / ((norm x) ^ 2 + 1))"
  apply (auto simp: norm_prod_def divide_simps algebra_simps)
   apply (auto simp: add_nonneg_eq_0_iff)
  by (auto simp: power2_eq_square algebra_simps)

instantiation sphere :: (real_normed_vector) topological_space
begin

lift_definition open_sphere :: "'a sphere set \<Rightarrow> bool" is
  "openin (subtopology (euclidean::('a\<times>real) topology) {a. norm a = 1})" .

instance
  apply standard
  apply (transfer; auto)
  apply (transfer; auto)
  apply (transfer; auto)
  done

end

instance sphere :: (real_normed_vector) t2_space
  apply standard
  apply transfer
  subgoal for x y
    apply (drule hausdorff[of x y])
    apply clarsimp
    subgoal for U V
      apply (rule exI[where x="U \<inter> {a. norm a = 1}"])
      apply clarsimp
      apply (rule conjI) defer
       apply (rule exI[where x="V \<inter> {a. norm a = 1}"])
      by auto
    done
  done

instance sphere :: (euclidean_space) second_countable_topology
proof standard
  obtain BB::"('a\<times>real) set set" where BB: "countable BB" "open = generate_topology BB"
    by (metis ex_countable_subbasis)
  let ?B = "(\<lambda>B. B \<inter> {x. norm x = 1}) ` BB"
  show "\<exists>B::'a sphere set set. countable B \<and> open = generate_topology B"
    apply transfer
    apply (rule bexI[where x = ?B])
    apply (rule conjI)
    subgoal using BB by force
    subgoal using BB apply clarsimp
      apply (subst openin_subtopology_eq_generate_topology[where BB=BB])
      by (auto )
    subgoal by auto
    done
qed

lemma transfer_continuous_on1[transfer_rule]:
  includes lifting_syntax
  shows "(rel_set (=) ===> ((=) ===> pcr_sphere (=)) ===> (=)) (\<lambda>X::'a::t2_space set. continuous_on X) continuous_on"
  apply (rule continuous_on_transfer_right_total2)
        apply transfer_step
       apply transfer_step
      apply transfer_step
     apply transfer_prover
    apply transfer_step
   apply transfer_step
  apply transfer_prover
  done

lemma transfer_continuous_on2[transfer_rule]:
  includes lifting_syntax
  shows "(rel_set (pcr_sphere (=)) ===> (pcr_sphere (=) ===> (=)) ===> (=)) (\<lambda>X. continuous_on (X \<inter> {x. norm x = 1})) (\<lambda>X. continuous_on X)"
  apply (rule continuous_on_transfer_right_total)
        apply transfer_step
       apply transfer_step
      apply transfer_step
     apply transfer_prover
    apply transfer_step
   apply transfer_step
  apply transfer_prover
  done

lemma st_proj1_inv_continuous:
  "continuous_on UNIV st_proj1_inv"
  by transfer (auto intro!: continuous_intros simp: add_nonneg_eq_0_iff)

lemma st_proj1_continuous:
  "continuous_on (UNIV - {top_sphere}) st_proj1"
  by transfer (auto intro!: continuous_intros simp: add_nonneg_eq_0_iff split_beta' norm_prod_def)

lemma st_proj1_inv: "st_proj1_inv (st_proj1 x) = x"
  if "x \<noteq> top_sphere"
  using that
  apply transfer
proof (clarsimp, rule conjI)
  fix a::'a and b::real
  assume *: "norm (a, b) = 1" and ab: "a = 0 \<longrightarrow> b \<noteq> 1"
  then have "b \<noteq> 1" by (auto simp: norm_prod_def)
  have na: "(norm a)\<^sup>2 = 1 - b\<^sup>2"
    using *
    unfolding norm_prod_def
    by (auto simp: algebra_simps)
  define S where "S = norm (a /\<^sub>R (1 - b))"
  have "b = (S\<^sup>2 - 1) / (S\<^sup>2 + 1)"
    by (auto simp: S_def divide_simps \<open>b \<noteq> 1\<close> na)
       (auto simp: power2_eq_square algebra_simps \<open>b \<noteq> 1\<close>)
  then show "((inverse \<bar>1 - b\<bar> * norm a)\<^sup>2 - 1) / ((inverse \<bar>1 - b\<bar> * norm a)\<^sup>2 + 1) = b"
    by (simp add: S_def)

  have "1 = (2 / (1 - b) / (S\<^sup>2 + 1))"
    by (auto simp: S_def divide_simps \<open>b \<noteq> 1\<close> na) (auto simp: power2_eq_square algebra_simps \<open>b \<noteq> 1\<close>)
  then have "a = (2 / (1 - b) / (S\<^sup>2 + 1)) *\<^sub>R a"
    by simp
  then show "(2 * inverse (1 - b) / ((inverse \<bar>1 - b\<bar> * norm a)\<^sup>2 + 1)) *\<^sub>R a = a"
    by (auto simp: S_def divide_simps)
qed

lemma st_proj1_inv_inv: "st_proj1 (st_proj1_inv x) = x"
  by transfer (auto simp: divide_simps add_nonneg_eq_0_iff)

lemma st_proj1_inv_ne_top: "st_proj1_inv xa \<noteq> top_sphere"
  by transfer (auto simp: divide_simps add_nonneg_eq_0_iff)

lemma homeomorphism_st_proj1: "homeomorphism (UNIV - {top_sphere}) UNIV st_proj1 st_proj1_inv"
  apply (auto simp: homeomorphism_def st_proj1_continuous st_proj1_inv_continuous st_proj1_inv_inv
      st_proj1_inv st_proj1_inv_ne_top)
  subgoal for x
    by (rule image_eqI[where x="st_proj1_inv x"]) (auto simp: st_proj1_inv_inv st_proj1_inv_ne_top)
  by (metis rangeI st_proj1_inv)

lemma st_proj2_inv_continuous:
  "continuous_on UNIV st_proj2_inv"
  by transfer (auto intro!: continuous_intros simp: add_nonneg_eq_0_iff)

lemma st_proj2_continuous:
  "continuous_on (UNIV - {bot_sphere}) st_proj2"
  apply (transfer; auto intro!: continuous_intros simp: add_nonneg_eq_0_iff split_beta' norm_prod_def)
proof -
  fix a b assume 1: "(norm a)^2 + b^2 = 1" and 2: "1 + b = 0"
  have "b = -1" using 2 by auto
  then show "a = 0"
    using 1 by auto
qed

lemma st_proj2_inv: "st_proj2_inv (st_proj2 x) = x"
  if "x \<noteq> bot_sphere"
  using that
  apply transfer
proof (clarsimp, rule conjI)
  fix a::'a and b::real
  assume *: "norm (a, b) = 1" and ab: "a = 0 \<longrightarrow> b \<noteq> -1"
  then have "b \<noteq> -1" by (auto simp: norm_prod_def)
  then have "1 + b \<noteq> 0" by auto
  then have "2 + b * 2 \<noteq> 0" by auto
  have na: "(norm a)\<^sup>2 = 1 - b\<^sup>2"
    using *
    unfolding norm_prod_def
    by (auto simp: algebra_simps)
  define S where "S = norm (a /\<^sub>R (1 + b))"
  have "b = (1 - S\<^sup>2) / (S\<^sup>2 + 1)"
    by (auto simp: S_def divide_simps \<open>b \<noteq> -1\<close> na)
       (auto simp: power2_eq_square algebra_simps \<open>b \<noteq> -1\<close> \<open>1 + b \<noteq> 0\<close> \<open>2 + b * 2 \<noteq> 0\<close>)
  then show "(1 - (inverse \<bar>1 + b\<bar> * norm a)\<^sup>2) / ((inverse \<bar>1 + b\<bar> * norm a)\<^sup>2 + 1) = b"
    by (simp add: S_def)
  have "1 = (2 / (1 + b) / (S\<^sup>2 + 1))"
    by (auto simp: S_def divide_simps \<open>b \<noteq> -1\<close> na)
       (auto simp: power2_eq_square algebra_simps \<open>b \<noteq> -1\<close> \<open>1 + b \<noteq> 0\<close> \<open>2 + b * 2 \<noteq> 0\<close>)
  then have "a = (2 / (1 + b) / (S\<^sup>2 + 1)) *\<^sub>R a"
    by simp
  then show "(2 * inverse (1 + b) / ((inverse \<bar>1 + b\<bar> * norm a)\<^sup>2 + 1)) *\<^sub>R a = a"
    by (auto simp: S_def divide_simps)
qed

lemma st_proj2_inv_inv: "st_proj2 (st_proj2_inv x) = x"
  by transfer (auto simp: divide_simps add_nonneg_eq_0_iff)

lemma st_proj2_inv_ne_top: "st_proj2_inv xa \<noteq> bot_sphere"
  by transfer (auto simp: divide_simps add_nonneg_eq_0_iff)

lemma homeomorphism_st_proj2: "homeomorphism (UNIV - {bot_sphere}) UNIV st_proj2 st_proj2_inv"
  apply (auto simp: homeomorphism_def st_proj2_continuous st_proj2_inv_continuous st_proj2_inv_inv
      st_proj2_inv st_proj2_inv_ne_top)
  subgoal for x
    by (rule image_eqI[where x="st_proj2_inv x"]) (auto simp: st_proj2_inv_inv st_proj2_inv_ne_top)
  by (metis rangeI st_proj2_inv)

lift_definition st_proj1_chart :: "('a sphere, 'a::euclidean_space) chart"
  is "(UNIV - {top_sphere::'a sphere}, UNIV::'a set, st_proj1, st_proj1_inv)"
  using homeomorphism_st_proj1 by blast

lift_definition st_proj2_chart :: "('a sphere, 'a::euclidean_space) chart"
  is "(UNIV - {bot_sphere::'a sphere}, UNIV::'a set, st_proj2, st_proj2_inv)"
  using homeomorphism_st_proj2 by blast

lemma st_projs_compat:
  includes lifting_syntax
  shows "\<infinity>-smooth_compat st_proj1_chart st_proj2_chart"
  unfolding smooth_compat_def
  apply (transfer; auto)
proof goal_cases
  case 1
  have *: "smooth_on ((\<lambda>(x::'a, z). x /\<^sub>R (1 - z)) ` (({a. norm a = 1} - {(0, 1)}) \<inter> ({a. norm a = 1} - {(0, - 1)})))
     ((\<lambda>(x, z). x /\<^sub>R (1 + z)) \<circ> (\<lambda>x. ((2 / ((norm x)\<^sup>2 + 1)) *\<^sub>R x, ((norm x)\<^sup>2 - 1) / ((norm x)\<^sup>2 + 1))))"
    apply (rule smooth_on_subset[where T="UNIV - {0}"])
    subgoal
      by (auto intro!: smooth_on_divide smooth_on_inverse smooth_on_scaleR smooth_on_mult smooth_on_add
          smooth_on_minus smooth_on_norm simp: o_def power2_eq_square add_nonneg_eq_0_iff divide_simps)
    apply (auto simp: norm_prod_def power2_eq_square) apply sos
    done
  show ?case
    by transfer (rule *)
next
  case 2
  have *: "smooth_on ((\<lambda>(x::'a, z). x /\<^sub>R (1 + z)) ` (({a. norm a = 1} - {(0, 1)}) \<inter> ({a. norm a = 1} - {(0, - 1)})))
     ((\<lambda>(x, z). x /\<^sub>R (1 - z)) \<circ> (\<lambda>x. ((2 / ((norm x)\<^sup>2 + 1)) *\<^sub>R x, (1 - (norm x)\<^sup>2) / ((norm x)\<^sup>2 + 1))))"
    apply (rule smooth_on_subset[where T="UNIV - {0}"])
    subgoal
      by (auto intro!: smooth_on_divide smooth_on_inverse smooth_on_scaleR smooth_on_mult smooth_on_add
          smooth_on_minus smooth_on_norm simp: o_def power2_eq_square add_nonneg_eq_0_iff divide_simps)
    apply (auto simp: norm_prod_def add_eq_0_iff) apply sos
    done
  show ?case
    by transfer (rule *)
qed

definition charts_sphere :: "('a::euclidean_space sphere, 'a) chart set" where
  "charts_sphere \<equiv> {st_proj1_chart, st_proj2_chart}"

lemma c_manifold_atlas_sphere: "c_manifold charts_sphere \<infinity>"
  apply (unfold_locales)
  unfolding charts_sphere_def
  using smooth_compat_commute smooth_compat_refl st_projs_compat by fastforce

end


header{*The Hereditarily Finite Sets*}

theory HF imports "~~/src/HOL/Library/Nat_Bijection"
begin

text{*From "Finite sets and Gödel's Incompleteness Theorems" by S. Swierczkowski.
      Thanks for Brian Huffman for this development, up to the cases and induct rules.*}

section {* Basic Definitions and Lemmas *}

typedef hf = "UNIV :: nat set" ..

definition hfset :: "hf \<Rightarrow> hf set"
  where "hfset a = Abs_hf ` set_decode (Rep_hf a)"

definition HF :: "hf set \<Rightarrow> hf"
  where "HF A = Abs_hf (set_encode (Rep_hf ` A))"

definition hinsert :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "hinsert a b = HF (insert a (hfset b))"

definition hmem :: "hf \<Rightarrow> hf \<Rightarrow> bool"     (infixl "<:" 50)
  where "hmem a b \<longleftrightarrow> a \<in> hfset b"

instantiation hf :: zero
begin

definition
  Zero_hf_def: "0 = HF {}"

instance ..

end

text {* HF Set enumerations *}

syntax
  "_HFinset" :: "args \<Rightarrow> hf"      ("{|(_)|}")

syntax (xsymbols)
  "_HFinset" :: "args \<Rightarrow> hf"      ("\<lbrace>_\<rbrace>")
  "_inserthf" :: "hf \<Rightarrow> hf \<Rightarrow> hf"  (infixl "\<triangleleft>" 60)

notation (xsymbols)
  hmem             (infixl "\<^bold>\<in>" 50)

translations
  "y \<triangleleft> x"    == "CONST hinsert x y"
  "{|x, y|}" == "\<lbrace>y\<rbrace> \<triangleleft> x"
  "{|x|}"    == "0 \<triangleleft> x"

lemma finite_hfset [simp]: "finite (hfset a)"
  unfolding hfset_def by simp

lemma HF_hfset [simp]: "HF (hfset a) = a"
  unfolding HF_def hfset_def
  by (simp add: image_image Abs_hf_inverse Rep_hf_inverse)

lemma hfset_HF [simp]: "finite A \<Longrightarrow> hfset (HF A) = A"
  unfolding HF_def hfset_def
  by (simp add: image_image Abs_hf_inverse Rep_hf_inverse)

lemma hmem_hempty [simp]: "\<not> a \<^bold>\<in> 0"
  unfolding hmem_def Zero_hf_def by simp

lemmas hemptyE [elim!] = hmem_hempty [THEN notE]

lemma hmem_hinsert [iff]:
  "hmem a (c \<triangleleft>  b) \<longleftrightarrow> a = b \<or> a \<^bold>\<in> c"
  unfolding hmem_def hinsert_def by simp

lemma hf_ext: "a = b \<longleftrightarrow> (\<forall>x. x \<^bold>\<in> a \<longleftrightarrow> x \<^bold>\<in> b)"
  unfolding hmem_def set_eq_iff [symmetric]
  by (metis HF_hfset)

lemma finite_cases [consumes 1, case_names empty insert]:
  "\<lbrakk>finite F; F = {} \<Longrightarrow> P; \<And>A x. \<lbrakk>F = insert x A; x \<notin> A; finite A\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (induct F rule: finite_induct, simp_all)

lemma hf_cases [cases type: hf, case_names 0 hinsert]:
  obtains "y = 0" | a b where "y = b \<triangleleft> a" and "\<not> a \<^bold>\<in> b"
proof -
  have "finite (hfset y)" by (rule finite_hfset)
  thus thesis
    by (metis Zero_hf_def finite_cases hf_ext hfset_HF hinsert_def hmem_def that)
qed

lemma Rep_hf_hinsert:
  "\<not> a \<^bold>\<in> b \<Longrightarrow> Rep_hf (hinsert a b) = 2 ^ (Rep_hf a) + Rep_hf b"
  unfolding hinsert_def HF_def hfset_def
  apply (simp add: image_image Abs_hf_inverse Rep_hf_inverse)
  apply (subst set_encode_insert, simp)
  apply (clarsimp simp add: hmem_def hfset_def image_def
    Rep_hf_inject [symmetric] Abs_hf_inverse, simp)
  done

lemma less_two_power: "n < 2 ^ n"
  by (induct n, auto)

section{*Verifying the Axioms of HF*}

text{*HF1*}
lemma hempty_iff: "z=0 \<longleftrightarrow> (\<forall>x. \<not> x \<^bold>\<in> z)"
  by (simp add: hf_ext)

text{*HF2*}
lemma hinsert_iff: "z = x \<triangleleft> y \<longleftrightarrow> (\<forall>u. u \<^bold>\<in> z \<longleftrightarrow> u \<^bold>\<in> x | u = y)"
  by (auto simp: hf_ext)

text{*HF induction*}
lemma hf_induct [induct type: hf, case_names 0 hinsert]:
  assumes [simp]: "P 0"
                  "\<And>x y. \<lbrakk>P x; P y; \<not> x \<^bold>\<in> y\<rbrakk> \<Longrightarrow> P (y \<triangleleft> x)"
  shows "P z"
proof (induct z rule: wf_induct [where r="measure Rep_hf", OF wf_measure])
  case (1 x) show ?case
    proof (cases x rule: hf_cases)
      case 0 thus ?thesis by simp
    next
      case (hinsert a b)
      thus ?thesis using 1
        by (simp add: Rep_hf_hinsert
                      less_le_trans [OF less_two_power le_add1])
    qed
qed

text{*HF3*}
lemma hf_induct_ax: "\<lbrakk>P 0; \<forall>x. P x \<longrightarrow> (\<forall>y. P y \<longrightarrow> P (x \<triangleleft> y))\<rbrakk> \<Longrightarrow> P x"
  by (induct x, auto)

lemma hf_equalityI [intro]: "(\<And>x. x \<^bold>\<in> a \<longleftrightarrow> x \<^bold>\<in> b) \<Longrightarrow> a = b"
  by (simp add: hf_ext)

lemma hinsert_nonempty [simp]: "A \<triangleleft> a \<noteq> 0"
  by (auto simp: hf_ext)

lemma hinsert_commute: "(z \<triangleleft> y) \<triangleleft> x = (z \<triangleleft> x) \<triangleleft> y"
  by (auto simp: hf_ext)

lemma singleton_eq_iff [iff]: "\<lbrace>a\<rbrace> = \<lbrace>b\<rbrace> \<longleftrightarrow> a=b"
  by (metis hmem_hempty hmem_hinsert)

lemma doubleton_eq_iff: "\<lbrace>a,b\<rbrace> = \<lbrace>c,d\<rbrace> \<longleftrightarrow> (a=c & b=d) | (a=d & b=c)"
  by (metis (hide_lams, no_types) hinsert_commute hmem_hempty hmem_hinsert)

section {* Ordered Pairs, from ZF/ZF.thy *}

definition hpair :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "hpair a b = \<lbrace>\<lbrace>a\<rbrace>,\<lbrace>a,b\<rbrace>\<rbrace>"

definition hfst :: "hf \<Rightarrow> hf"
  where "hfst p \<equiv> THE x. \<exists>y. p = hpair x y"

definition hsnd :: "hf \<Rightarrow> hf"
  where "hsnd p \<equiv> THE y. \<exists>x. p = hpair x y"

definition hsplit :: "[[hf, hf] \<Rightarrow> 'a, hf] \<Rightarrow> 'a::{}"  --{*for pattern-matching*}
  where "hsplit c \<equiv> %p. c (hfst p) (hsnd p)"

text {* Ordered Pairs, from ZF/ZF.thy *}

nonterminal hfs
syntax
  ""          :: "hf \<Rightarrow> hfs"                    ("_")
  "_Enum"     :: "[hf, hfs] \<Rightarrow> hfs"             ("_,/ _")
  "_Tuple"    :: "[hf, hfs] \<Rightarrow> hf"              ("<(_,/ _)>")
  "_hpattern" :: "[pttrn, patterns] \<Rightarrow> pttrn"   ("<_,/ _>")
syntax (xsymbols)
  "_Tuple"    :: "[hf, hfs] \<Rightarrow> hf"              ("\<langle>(_,/ _)\<rangle>")
  "_hpattern" :: "[pttrn, patterns] \<Rightarrow> pttrn"   ("\<langle>_,/ _\<rangle>")
syntax (HTML output)
  "_Tuple"    :: "[hf, hfs] \<Rightarrow> hf"              ("\<langle>(_,/ _)\<rangle>")
  "_hpattern" :: "[pttrn, patterns] \<Rightarrow> pttrn"   ("\<langle>_,/ _\<rangle>")

translations
  "<x, y, z>"    == "<x, <y, z>>"
  "<x, y>"       == "CONST hpair x y"
  "<x, y, z>"    == "<x, <y, z>>"
  "%<x,y,zs>. b" == "CONST hsplit(%x <y,zs>. b)"
  "%<x,y>. b"    == "CONST hsplit(%x y. b)"

lemma hpair_def': "hpair a b = \<lbrace>\<lbrace>a,a\<rbrace>,\<lbrace>a,b\<rbrace>\<rbrace>"
  by (auto simp: hf_ext hpair_def)

lemma hpair_iff [simp]: "hpair a b = hpair a' b' \<longleftrightarrow> a=a' & b=b'"
  by (auto simp: hpair_def' doubleton_eq_iff)

lemmas hpair_inject = hpair_iff [THEN iffD1, THEN conjE, elim!]

lemma hfst_conv [simp]: "hfst \<langle>a,b\<rangle> = a"
  by (simp add: hfst_def)

lemma hsnd_conv [simp]: "hsnd \<langle>a,b\<rangle> = b"
  by (simp add: hsnd_def)

lemma hsplit [simp]: "hsplit c \<langle>a,b\<rangle> = c a b"
  by (simp add: hsplit_def)

section{*Unions, Comprehensions, Intersections*}

subsection{*Unions*}

text{*Theorem 1.5 (Existence of the union of two sets).*}
lemma binary_union: "\<exists>z. \<forall>u. u \<^bold>\<in> z \<longleftrightarrow> u \<^bold>\<in> x | u \<^bold>\<in> y"
proof (induct x rule: hf_induct)
  case 0 thus ?case by auto
next
  case (hinsert a b) thus ?case by (metis hmem_hinsert)
qed

text{*Theorem 1.6 (Existence of the union of a set of sets).*}
lemma union_of_set: "\<exists>z. \<forall>u. u \<^bold>\<in> z \<longleftrightarrow> (\<exists>y. y \<^bold>\<in> x & u \<^bold>\<in> y)"
proof (induct x rule: hf_induct)
  case 0 thus ?case by (metis hmem_hempty)
next
  case (hinsert a b)
  then show ?case
    by (metis hmem_hinsert binary_union [of a])
qed

subsection {* Set comprehensions *}

text{*Theorem 1.7, comprehension scheme*}
lemma comprehension: "\<exists>z. \<forall>u. u \<^bold>\<in> z \<longleftrightarrow> u \<^bold>\<in> x & P u"
proof (induct x rule: hf_induct)
  case 0 thus ?case by (metis hmem_hempty)
next
  case (hinsert a b) thus ?case by (metis hmem_hinsert)
qed

definition HCollect :: "(hf \<Rightarrow> bool) \<Rightarrow> hf \<Rightarrow> hf" -- "comprehension"
  where "HCollect P A = (THE z. \<forall>u. u \<^bold>\<in> z = (P u & u \<^bold>\<in> A))"

syntax
  "_HCollect" :: "idt \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> hf"    ("(1\<lbrace>_ <:/ _./ _\<rbrace>)")
syntax (xsymbols)
  "_HCollect" :: "idt \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> hf"    ("(1\<lbrace>_ \<^bold>\<in>/ _./ _\<rbrace>)")
translations
  "\<lbrace>x <: A. P\<rbrace>" == "CONST HCollect (%x. P) A"

lemma HCollect_iff [iff]: "hmem x (HCollect P A) \<longleftrightarrow> P x & x \<^bold>\<in> A"
apply (insert comprehension [of A P], clarify)
apply (simp add: HCollect_def)
apply (rule theI2, blast)
apply (auto simp: hf_ext)
done

lemma HCollectI: "a \<^bold>\<in> A \<Longrightarrow> P a \<Longrightarrow> hmem a \<lbrace>x \<^bold>\<in> A. P x\<rbrace>"
  by simp

lemma HCollectE:
  assumes "a \<^bold>\<in> \<lbrace>x \<^bold>\<in> A. P x\<rbrace>" obtains "a \<^bold>\<in> A" "P a"
  using assms by auto

lemma HCollect_hempty [simp]: "HCollect P 0 = 0"
  by (simp add: hf_ext)

subsection{*Union operators*}

instantiation hf :: sup
  begin
  definition sup_hf :: "hf \<Rightarrow> hf \<Rightarrow> hf"
    where "sup_hf a b = (THE z. \<forall>u. u \<^bold>\<in> z \<longleftrightarrow> u \<^bold>\<in> a | u \<^bold>\<in> b)"
  instance ..
  end

abbreviation hunion :: "hf \<Rightarrow> hf \<Rightarrow> hf" (infixl "\<squnion>" 65) where
  "hunion \<equiv> sup"

lemma hunion_iff [iff]: "hmem x (a \<squnion> b) \<longleftrightarrow> x \<^bold>\<in> a | x \<^bold>\<in> b"
apply (insert binary_union [of a b], clarify)
apply (simp add: sup_hf_def)
apply (rule theI2)
apply (auto simp: hf_ext)
done

definition HUnion :: "hf \<Rightarrow> hf"        ("\<Squnion>_" [900] 900)
  where "HUnion A = (THE z. \<forall>u. u \<^bold>\<in> z \<longleftrightarrow> (\<exists>y. y \<^bold>\<in> A & u \<^bold>\<in> y))"

lemma HUnion_iff [iff]: "hmem x (\<Squnion> A) \<longleftrightarrow> (\<exists>y. y \<^bold>\<in> A & x \<^bold>\<in> y)"
apply (insert union_of_set [of A], clarify)
apply (simp add: HUnion_def)
apply (rule theI2)
apply (auto simp: hf_ext)
done

lemma HUnion_hempty [simp]: "\<Squnion> 0 = 0"
  by (simp add: hf_ext)

lemma HUnion_hinsert [simp]: "\<Squnion>(A \<triangleleft> a) = a \<squnion> \<Squnion>A"
  by (auto simp: hf_ext)

lemma HUnion_hunion [simp]: "\<Squnion>(A \<squnion> B) =  \<Squnion>A \<squnion> \<Squnion>B"
  by blast

subsection{*Definition 1.8, Intersections*}

instantiation hf :: inf
begin

definition inf_hf :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "inf_hf a b = \<lbrace>x \<^bold>\<in> a. x \<^bold>\<in> b\<rbrace>"

instance ..

end

abbreviation hinter :: "hf \<Rightarrow> hf \<Rightarrow> hf" (infixl "\<sqinter>" 70) where
  "hinter \<equiv> inf"

lemma hinter_iff [iff]: "hmem u (x \<sqinter> y) \<longleftrightarrow> u \<^bold>\<in> x & u \<^bold>\<in> y"
  by (metis HCollect_iff inf_hf_def)

definition HInter :: "hf \<Rightarrow> hf"           ("\<Sqinter>_" [900] 900)
  where "HInter(A) = \<lbrace>x \<^bold>\<in> HUnion(A). \<forall>y. y \<^bold>\<in> A \<longrightarrow> x \<^bold>\<in> y\<rbrace>"

lemma HInter_hempty [iff]: "\<Sqinter> 0 = 0"
  by (metis HCollect_hempty HUnion_hempty HInter_def)

lemma HInter_iff [simp]: "A\<noteq>0 \<Longrightarrow> hmem x (\<Sqinter> A) \<longleftrightarrow> (\<forall>y. y \<^bold>\<in> A \<longrightarrow> x \<^bold>\<in> y)"
  by (auto simp: HInter_def)

lemma HInter_hinsert [simp]: "A\<noteq>0 \<Longrightarrow> \<Sqinter>(A \<triangleleft> a) = a \<sqinter> \<Sqinter>A"
  by (auto simp: hf_ext HInter_iff [OF hinsert_nonempty])

subsection{*Set Difference*}

instantiation hf :: minus
  begin
  definition minus_hf where "minus A B = \<lbrace>x \<^bold>\<in> A. \<not> x \<^bold>\<in> B\<rbrace>"
  instance proof qed
  end

lemma hdiff_iff [iff]: "hmem u (x - y) \<longleftrightarrow> u \<^bold>\<in> x & \<not> u \<^bold>\<in> y"
  by (auto simp: minus_hf_def)

lemma hdiff_zero [simp]: fixes x :: hf shows "(x - 0) = x"
  by blast

lemma zero_hdiff [simp]: fixes x :: hf shows "(0 - x) = 0"
  by blast

lemma hdiff_insert: "A - (B \<triangleleft> a) = A - B - \<lbrace>a\<rbrace>"
  by blast

lemma hinsert_hdiff_if:
  "(A \<triangleleft> x) - B = (if x \<^bold>\<in> B then A - B else (A - B) \<triangleleft> x)"
  by auto

section{*Replacement*}

text{*Theorem 1.9 (Replacement Scheme).*}
lemma replacement:
  "(\<forall>u v v'. u \<^bold>\<in> x \<longrightarrow> R u v \<longrightarrow> R u v' \<longrightarrow> v'=v) \<Longrightarrow> \<exists>z. \<forall>v. v \<^bold>\<in> z \<longleftrightarrow> (\<exists>u. u \<^bold>\<in> x & R u v)"
proof (induct x rule: hf_induct)
  case 0 thus ?case
    by (metis hmem_hempty)
next
  case (hinsert a b) thus ?case
    by simp (metis hmem_hinsert)
qed

lemma replacement_fun: "\<exists>z. \<forall>v. v \<^bold>\<in> z \<longleftrightarrow> (\<exists>u. u \<^bold>\<in> x & v = f u)"
  by (rule replacement [where R = "\<lambda>u v. v = f u"]) auto

definition PrimReplace :: "hf \<Rightarrow> (hf \<Rightarrow> hf \<Rightarrow> bool) \<Rightarrow> hf"
  where "PrimReplace A R = (THE z. \<forall>v. v \<^bold>\<in> z \<longleftrightarrow> (\<exists>u. u \<^bold>\<in> A & R u v))"

definition Replace :: "hf \<Rightarrow> (hf \<Rightarrow> hf \<Rightarrow> bool) \<Rightarrow> hf"
  where "Replace A R = PrimReplace A (\<lambda>x y. (\<exists>!z. R x z) & R x y)"

definition RepFun :: "hf \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> hf"
  where "RepFun A f = Replace A (\<lambda>x y. y = f x)"

syntax
  "_HReplace"  :: "[pttrn, pttrn, hf, bool] \<Rightarrow> hf" ("(1{|_ ./ _<: _, _|})")
  "_HRepFun"   :: "[hf, pttrn, hf] \<Rightarrow> hf"          ("(1{|_ ./ _<: _|})" [51,0,51])
  "_HINTER"    :: "[pttrn, hf, hf] \<Rightarrow> hf"          ("(3INT _<:_./ _)" 10)
  "_HUNION"    :: "[pttrn, hf, hf] \<Rightarrow> hf"          ("(3UN _<:_./ _)" 10)

syntax (xsymbols)
  "_HReplace"  :: "[pttrn, pttrn, hf, bool] \<Rightarrow> hf" ("(1\<lbrace>_ ./ _ \<^bold>\<in> _, _\<rbrace>)")
  "_HRepFun"   :: "[hf, pttrn, hf] \<Rightarrow> hf"          ("(1\<lbrace>_ ./ _ \<^bold>\<in> _\<rbrace>)" [51,0,51])
  "_HUNION"    :: "[pttrn, hf, hf] \<Rightarrow> hf"          ("(3\<Squnion>_\<^bold>\<in>_./ _)" 10)
  "_HINTER"    :: "[pttrn, hf, hf] \<Rightarrow> hf"          ("(3\<Sqinter>_\<^bold>\<in>_./ _)" 10)

syntax (HTML output)
  "_HReplace"  :: "[pttrn, pttrn, hf, bool] \<Rightarrow> hf" ("(1\<lbrace>_ ./ _ \<^bold>\<in> _, _\<rbrace>)")
  "_HRepFun"   :: "[hf, pttrn, hf] \<Rightarrow> hf"          ("(1\<lbrace>_ ./ _ \<^bold>\<in> _\<rbrace>)" [51,0,51])
  "_HUNION"    :: "[pttrn, hf, hf] \<Rightarrow> hf"          ("(3\<Squnion>_\<^bold>\<in>_./ _)" 10)
  "_HINTER"    :: "[pttrn, hf, hf] \<Rightarrow> hf"          ("(3\<Sqinter>_\<^bold>\<in>_./ _)" 10)

translations
  "{|y. x<:A, Q|}" == "CONST Replace A (%x y. Q)"
  "{|b. x<:A|}"    == "CONST RepFun A (%x. b)"
  "INT x<:A. B"    == "CONST HInter(CONST RepFun A (%x. B))"
  "UN x<:A. B"     == "CONST HUnion(CONST RepFun A (%x. B))"

lemma PrimReplace_iff:
  assumes sv: "\<forall>u v v'. u \<^bold>\<in> A \<longrightarrow> R u v \<longrightarrow> R u v' \<longrightarrow> v'=v"
  shows "v \<^bold>\<in> (PrimReplace A R) \<longleftrightarrow> (\<exists>u. u \<^bold>\<in> A & R u v)"
apply (insert replacement [OF sv], clarify)
apply (simp add: PrimReplace_def)
apply (rule theI2)
apply (auto simp: hf_ext)
done

lemma Replace_iff [iff]:
  "v \<^bold>\<in> Replace A R \<longleftrightarrow> (\<exists>u. u \<^bold>\<in> A & R u v & (\<forall>y. R u y \<longrightarrow> y=v))"
apply (simp add: Replace_def)
apply (subst PrimReplace_iff, auto)
done

lemma Replace_0 [simp]: "Replace 0 R = 0"
  by blast

lemma Replace_hunion [simp]: "Replace (A \<squnion> B) R = Replace A R  \<squnion>  Replace B R"
  by blast

lemma Replace_cong [cong]:
    "\<lbrakk> A=B;  !!x y. x \<^bold>\<in> B \<Longrightarrow> P x y \<longleftrightarrow> Q x y \<rbrakk>  \<Longrightarrow> Replace A P = Replace B Q"
  by (simp add: hf_ext cong: conj_cong)

lemma RepFun_iff [iff]: "v \<^bold>\<in> (RepFun A f) \<longleftrightarrow> (\<exists>u. u \<^bold>\<in> A & v = f u)"
  by (auto simp: RepFun_def)

lemma RepFun_cong [cong]:
    "\<lbrakk> A=B;  !!x. x \<^bold>\<in> B \<Longrightarrow> f(x)=g(x) \<rbrakk>  \<Longrightarrow> RepFun A f = RepFun B g"
by (simp add: RepFun_def)

lemma triv_RepFun [simp]: "RepFun A (\<lambda>x. x) = A"
by blast

lemma RepFun_0 [simp]: "RepFun 0 f = 0"
  by blast

lemma RepFun_hinsert [simp]: "RepFun (hinsert a b) f = hinsert (f a) (RepFun b f)"
  by blast

lemma RepFun_hunion [simp]:
  "RepFun (A \<squnion> B) f = RepFun A f  \<squnion>  RepFun B f"
  by blast

section{*Subset relation and the Lattice Properties*}

text{*Definition 1.10 (Subset relation).*}
instantiation hf :: order
  begin
  definition less_eq_hf where "A \<le> B \<longleftrightarrow> (\<forall>x. x \<^bold>\<in> A \<longrightarrow> x \<^bold>\<in> B)"

  definition less_hf    where "A < B \<longleftrightarrow> A \<le> B & A \<noteq> (B::hf)"

  instance proof qed (auto simp: less_eq_hf_def less_hf_def)
  end

subsection{*Rules for subsets*}

lemma hsubsetI [intro!]:
    "(!!x. x\<^bold>\<in>A \<Longrightarrow> x\<^bold>\<in>B) \<Longrightarrow> A \<le> B"
  by (simp add: less_eq_hf_def)

text{*Classical elimination rule*}
lemma hsubsetCE [elim]: "\<lbrakk> A \<le> B;  ~(c\<^bold>\<in>A) \<Longrightarrow> P;  c\<^bold>\<in>B \<Longrightarrow> P \<rbrakk>  \<Longrightarrow> P"
  by (auto simp: less_eq_hf_def)

text{*Rule in Modus Ponens style*}
lemma hsubsetD [elim]: "\<lbrakk> A \<le> B;  c\<^bold>\<in>A \<rbrakk> \<Longrightarrow> c\<^bold>\<in>B"
  by (simp add: less_eq_hf_def)

text{*Sometimes useful with premises in this order*}
lemma rev_hsubsetD: "\<lbrakk> c\<^bold>\<in>A; A\<le>B \<rbrakk> \<Longrightarrow> c\<^bold>\<in>B"
  by blast

lemma contra_hsubsetD: "\<lbrakk> A \<le> B; c \<notin> B \<rbrakk>  \<Longrightarrow> c \<notin> A"
  by blast

lemma rev_contra_hsubsetD: "\<lbrakk> c \<notin> B;  A \<le> B \<rbrakk>  \<Longrightarrow> c \<notin> A"
  by blast

lemma hf_equalityE:
  fixes A :: hf shows "A = B \<Longrightarrow> (A \<le> B \<Longrightarrow> B \<le> A \<Longrightarrow> P) \<Longrightarrow> P"
  by (metis order_refl)

subsection{*Lattice properties*}

instantiation hf :: distrib_lattice
  begin
  instance proof qed (auto simp: less_eq_hf_def less_hf_def inf_hf_def)
  end

instantiation hf :: bounded_lattice_bot
  begin
  definition bot_hf where "bot_hf = (0::hf)"
  instance proof qed (auto simp: less_eq_hf_def bot_hf_def)
  end

lemma hinter_hempty_left [simp]: "0 \<sqinter> A = 0"
  by (metis bot_hf_def inf_bot_left)

lemma hinter_hempty_right [simp]: "A \<sqinter> 0 = 0"
  by (metis bot_hf_def inf_bot_right)

lemma hunion_hempty_left [simp]: "0 \<squnion> A = A"
  by (metis bot_hf_def sup_bot_left)

lemma hunion_hempty_right [simp]: "A \<squnion> 0 = A"
  by (metis bot_hf_def sup_bot_right)

lemma less_eq_hempty [simp]: "u \<le> 0 \<longleftrightarrow> u = (0::hf)"
  by (metis hempty_iff less_eq_hf_def)

lemma less_eq_insert1_iff [iff]: "(hinsert x y) \<le> z \<longleftrightarrow> x \<^bold>\<in> z & y \<le> z"
  by (auto simp: less_eq_hf_def)

lemma less_eq_insert2_iff:
  "z \<le> (hinsert x y) \<longleftrightarrow> z \<le> y \<or> (\<exists>u. hinsert x u = z \<and> ~ x \<^bold>\<in> u \<and> u \<le> y)"
proof (cases "x \<^bold>\<in> z")
  case True
  hence u: "hinsert x (z - \<lbrace>x\<rbrace>) = z" by auto
  show ?thesis
    proof
      assume "z \<le> (hinsert x y)"
      thus "z \<le> y \<or> (\<exists>u. hinsert x u = z \<and> \<not> x \<^bold>\<in> u \<and> u \<le> y)"
        by (simp add: less_eq_hf_def) (metis u hdiff_iff hmem_hinsert)
    next
      assume "z \<le> y \<or> (\<exists>u. hinsert x u = z \<and> \<not> x \<^bold>\<in> u \<and> u \<le> y)"
      thus "z \<le> (hinsert x y)"
        by (auto simp: less_eq_hf_def)
    qed
next
  case False thus ?thesis
    by (metis hmem_hinsert less_eq_hf_def)
qed

lemma zero_le [simp]: "0 \<le> (x::hf)"
  by blast

lemma hinsert_eq_sup: "b \<triangleleft> a = b \<squnion> \<lbrace>a\<rbrace>"
  by blast

lemma hunion_hinsert_left: "hinsert x A \<squnion> B = hinsert x (A \<squnion> B)"
  by blast

lemma hunion_hinsert_right: "B \<squnion> hinsert x A = hinsert x (B \<squnion> A)"
  by blast

lemma hinter_hinsert_left: "hinsert x A \<sqinter> B = (if x \<^bold>\<in> B then hinsert x (A \<sqinter> B) else A \<sqinter> B)"
  by auto

lemma hinter_hinsert_right: "B \<sqinter> hinsert x A = (if x \<^bold>\<in> B then hinsert x (B \<sqinter> A) else B \<sqinter> A)"
  by auto

section{*Foundation, Cardinality, Powersets*}

subsection{*Foundation*}

text{*Theorem 1.13: Foundation (Regularity) Property.*}
lemma foundation:
  assumes z: "z \<noteq> 0" shows "\<exists>w. w \<^bold>\<in> z & w \<sqinter> z = 0"
proof -
  { fix x
    assume z: "(\<forall>w. w \<^bold>\<in> z \<longrightarrow> w \<sqinter> z \<noteq> 0)"
    have "~ x \<^bold>\<in> z \<and> x \<sqinter> z = 0"
    proof (induction x rule: hf_induct)
      case 0 thus ?case
        by (metis hinter_hempty_left z)
    next
      case (hinsert x y) thus ?case
        by (metis hinter_hinsert_left z)
    qed
  }
  thus ?thesis using z
    by (metis z hempty_iff)
qed

lemma hmem_not_refl: "~ (x \<^bold>\<in> x)"
  using foundation [of "\<lbrace>x\<rbrace>"]
  by (metis hinter_iff hmem_hempty hmem_hinsert)

lemma hmem_not_sym: "~ (x \<^bold>\<in> y \<and> y \<^bold>\<in> x)"
  using foundation [of "\<lbrace>x,y\<rbrace>"]
  by (metis hinter_iff hmem_hempty hmem_hinsert)

lemma hmem_ne: "x \<^bold>\<in> y \<Longrightarrow> x \<noteq> y"
  by (metis hmem_not_refl)

lemma hmem_Sup_ne: "x <: y \<Longrightarrow> \<Squnion>x \<noteq> y"
  by (metis HUnion_iff hmem_not_sym)

lemma hpair_neq_fst: "\<langle>a,b\<rangle> \<noteq> a"
  by (metis hpair_def hinsert_iff hmem_not_sym)

lemma hpair_neq_snd: "\<langle>a,b\<rangle> \<noteq> b"
  by (metis hpair_def hinsert_iff hmem_not_sym)

lemma hpair_nonzero [simp]: "\<langle>x,y\<rangle> \<noteq> 0"
  by (auto simp: hpair_def)

lemma zero_notin_hpair: "~ 0 \<^bold>\<in> \<langle>x,y\<rangle>"
  by (auto simp: hpair_def)

subsection{*Cardinality*}

text{*First we need to hack the underlying representation*}
lemma hfset_0: "hfset 0 = {}"
  by (metis Zero_hf_def finite.emptyI hfset_HF)

lemma hfset_hinsert: "hfset (b \<triangleleft> a) = insert a (hfset b)"
  by (metis finite_insert hinsert_def HF.finite_hfset hfset_HF)

lemma hfset_hdiff: "hfset (x - y) = hfset x - hfset y"
proof (induct x arbitrary: y rule: hf_induct)
  case 0 thus ?case
    by (simp add: hfset_0)
next
  case (hinsert a b) thus ?case
    by (simp add: hfset_hinsert Set.insert_Diff_if hinsert_hdiff_if hmem_def)
qed

definition hcard :: "hf \<Rightarrow> nat"
  where "hcard x = card (hfset x)"

lemma hcard_0 [simp]: "hcard 0 = 0"
  by (simp add: hcard_def hfset_0)

lemma hcard_hinsert_if: "hcard (hinsert x y) = (if x \<^bold>\<in> y then hcard y else Suc (hcard y))"
  by (simp add: hcard_def hfset_hinsert card_insert_if hmem_def)

lemma hcard_union_inter: "hcard (x \<squnion> y) + hcard (x \<sqinter> y) = hcard x + hcard y"
  apply (induct x arbitrary: y rule: hf_induct)
  apply (auto simp: hcard_hinsert_if hunion_hinsert_left hinter_hinsert_left)
  done

lemma hcard_hdiff1_less: "x \<^bold>\<in> z \<Longrightarrow> hcard (z - \<lbrace>x\<rbrace>) < hcard z"
  by (simp add: hcard_def hfset_hdiff hfset_hinsert hfset_0)
     (metis card_Diff1_less finite_hfset hmem_def)

subsection{*Powerset Operator*}

text{*Theorem 1.11 (Existence of the power set).*}
lemma powerset: "\<exists>z. \<forall>u. u \<^bold>\<in> z \<longleftrightarrow> u \<le> x"
proof (induction x rule: hf_induct)
 case 0 thus ?case
    by (metis hmem_hempty hmem_hinsert less_eq_hempty)
next
  case (hinsert a b)
  then obtain Pb where Pb: "\<forall>u. u \<^bold>\<in> Pb \<longleftrightarrow> u \<le> b"
    by auto
  obtain RPb where RPb: "\<forall>v. v \<^bold>\<in> RPb \<longleftrightarrow> (\<exists>u. u \<^bold>\<in> Pb & v = hinsert a u)"
    using replacement_fun ..
  thus ?case using Pb binary_union [of Pb RPb]
    apply (simp add: less_eq_insert2_iff, clarify)
    apply (rule_tac x=z in exI)
    apply (metis hinsert.hyps less_eq_hf_def)
    done
qed

definition HPow :: "hf \<Rightarrow> hf"
  where "HPow x = (THE z. \<forall>u. u \<^bold>\<in> z \<longleftrightarrow> u \<le> x)"

lemma HPow_iff [iff]: "u \<^bold>\<in> HPow x \<longleftrightarrow> u \<le> x"
apply (insert powerset [of x], clarify)
apply (simp add: HPow_def)
apply (rule theI2)
apply (auto simp: hf_ext)
done

lemma HPow_mono: "x \<le> y \<Longrightarrow> HPow x \<le> HPow y"
  by (metis HPow_iff less_eq_hf_def order_trans)

lemma HPow_mono_strict: "x < y \<Longrightarrow> HPow x < HPow y"
  by (metis HPow_iff HPow_mono less_le_not_le order_eq_iff)

lemma HPow_mono_iff [simp]: "HPow x \<le> HPow y \<longleftrightarrow> x \<le> y"
  by (metis HPow_iff HPow_mono hsubsetCE order_refl)

lemma HPow_mono_strict_iff [simp]: "HPow x < HPow y \<longleftrightarrow> x < y"
  by (metis HPow_mono_iff less_le_not_le)

section{*Bounded Quantifiers*}

definition HBall :: "hf \<Rightarrow> (hf \<Rightarrow> bool) \<Rightarrow> bool" where
  "HBall A P \<longleftrightarrow> (\<forall>x. x <: A \<longrightarrow> P x)"   -- "bounded universal quantifiers"

definition HBex :: "hf \<Rightarrow> (hf \<Rightarrow> bool) \<Rightarrow> bool" where
  "HBex A P \<longleftrightarrow> (\<exists>x. x <: A \<and> P x)"   -- "bounded existential quantifiers"

syntax
  "_HBall"       :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3ALL _<:_./ _)" [0, 0, 10] 10)
  "_HBex"        :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX _<:_./ _)"  [0, 0, 10] 10)
  "_HBex1"       :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX! _<:_./ _)" [0, 0, 10] 10)

syntax (xsymbols)
  "_HBall"       :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>_\<^bold>\<in>_./ _)"  [0, 0, 10] 10)
  "_HBex"        :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>_\<^bold>\<in>_./ _)"  [0, 0, 10] 10)
  "_HBex1"       :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>!_\<^bold>\<in>_./ _)" [0, 0, 10] 10)

syntax (HTML output)
  "_HBall"       :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>_\<^bold>\<in>_./ _)"  [0, 0, 10] 10)
  "_HBex"        :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>_\<^bold>\<in>_./ _)"  [0, 0, 10] 10)
  "_HBex1"       :: "pttrn \<Rightarrow> hf \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>!_\<^bold>\<in>_./ _)" [0, 0, 10] 10)

translations
  "ALL x<:A. P" == "CONST HBall A (%x. P)"
  "EX x<:A. P" == "CONST HBex A (%x. P)"
  "EX! x<:A. P" => "EX! x. x:A & P"

lemma hball_cong [cong]:
    "\<lbrakk> A=A';  !!x. x \<^bold>\<in> A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x) \<rbrakk>  \<Longrightarrow> (\<forall>x\<^bold>\<in>A. P(x)) \<longleftrightarrow> (\<forall>x\<^bold>\<in>A'. P'(x))"
  by (simp add: HBall_def)

lemma hballI [intro!]: "(!!x. x<:A \<Longrightarrow> P x) \<Longrightarrow> ALL x<:A. P x"
  by (simp add: HBall_def)

lemma hbspec [dest?]: "ALL x<:A. P x \<Longrightarrow> x<:A \<Longrightarrow> P x"
  by (simp add: HBall_def)

lemma hbex_cong [cong]:
    "\<lbrakk> A=A';  !!x. x \<^bold>\<in> A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x) \<rbrakk>  \<Longrightarrow> (\<exists>x\<^bold>\<in>A. P(x)) \<longleftrightarrow> (\<exists>x\<^bold>\<in>A'. P'(x))"
  by (simp add: HBex_def cong: conj_cong)

lemma hbexI [intro]: "P x \<Longrightarrow> x<:A \<Longrightarrow> EX x<:A. P x"
  by (unfold HBex_def) blast

lemma rev_hbexI [intro?]: "x<:A \<Longrightarrow> P x \<Longrightarrow> EX x<:A. P x"
  by (unfold HBex_def) blast

lemma bexCI: "(ALL x<:A. ~P x \<Longrightarrow> P a) \<Longrightarrow> a<:A \<Longrightarrow> EX x<:A. P x"
  by (unfold HBex_def) blast

lemma hbexE [elim!]: "EX x<:A. P x \<Longrightarrow> (!!x. x<:A \<Longrightarrow> P x \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (unfold HBex_def) blast

lemma hball_triv [simp]: "(ALL x<:A. P) = ((EX x. x<:A) --> P)"
  -- {* Trival rewrite rule. *}
  by (simp add: HBall_def)

lemma hbex_triv [simp]: "(EX x<:A. P) = ((EX x. x<:A) & P)"
  -- {* Dual form for existentials. *}
  by (simp add: HBex_def)

lemma hbex_triv_one_point1 [simp]: "(EX x<:A. x = a) = (a<:A)"
  by blast

lemma hbex_triv_one_point2 [simp]: "(EX x<:A. a = x) = (a<:A)"
  by blast

lemma hbex_one_point1 [simp]: "(EX x<:A. x = a & P x) = (a<:A & P a)"
  by blast

lemma hbex_one_point2 [simp]: "(EX x<:A. a = x & P x) = (a<:A & P a)"
  by blast

lemma hball_one_point1 [simp]: "(ALL x<:A. x = a --> P x) = (a<:A --> P a)"
  by blast

lemma hball_one_point2 [simp]: "(ALL x<:A. a = x --> P x) = (a<:A --> P a)"
  by blast

lemma hball_conj_distrib:
  "(\<forall>x\<^bold>\<in>A. P x \<and> Q x) \<longleftrightarrow> ((\<forall>x\<^bold>\<in>A. P x) \<and> (\<forall>x\<^bold>\<in>A. Q x))"
  by blast

lemma hbex_disj_distrib:
  "(\<exists>x\<^bold>\<in>A. P x \<or> Q x) \<longleftrightarrow> ((\<exists>x\<^bold>\<in>A. P x) \<or> (\<exists>x\<^bold>\<in>A. Q x))"
  by blast

lemma hb_all_simps [simp, no_atp]:
  "\<And>A P Q. (\<forall>x \<^bold>\<in> A. P x \<or> Q) \<longleftrightarrow> ((\<forall>x \<^bold>\<in> A. P x) \<or> Q)"
  "\<And>A P Q. (\<forall>x \<^bold>\<in> A. P \<or> Q x) \<longleftrightarrow> (P \<or> (\<forall>x \<^bold>\<in> A. Q x))"
  "\<And>A P Q. (\<forall>x \<^bold>\<in> A. P \<longrightarrow> Q x) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x \<^bold>\<in> A. Q x))"
  "\<And>A P Q. (\<forall>x \<^bold>\<in> A. P x \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x \<^bold>\<in> A. P x) \<longrightarrow> Q)"
  "\<And>P. (\<forall>x \<^bold>\<in> 0. P x) \<longleftrightarrow> True"
  "\<And>a B P. (\<forall>x \<^bold>\<in> B \<triangleleft> a. P x) \<longleftrightarrow> (P a \<and> (\<forall>x \<^bold>\<in> B. P x))"
  "\<And>P Q. (\<forall>x \<^bold>\<in> HCollect Q A. P x) \<longleftrightarrow> (\<forall>x \<^bold>\<in> A. Q x \<longrightarrow> P x)"
  "\<And>A P. (\<not> (\<forall>x \<^bold>\<in> A. P x)) \<longleftrightarrow> (\<exists>x \<^bold>\<in> A. \<not> P x)"
  by auto

lemma hb_ex_simps [simp, no_atp]:
  "\<And>A P Q. (\<exists>x \<^bold>\<in> A. P x \<and> Q) \<longleftrightarrow> ((\<exists>x \<^bold>\<in> A. P x) \<and> Q)"
  "\<And>A P Q. (\<exists>x \<^bold>\<in> A. P \<and> Q x) \<longleftrightarrow> (P \<and> (\<exists>x \<^bold>\<in> A. Q x))"
  "\<And>P. (\<exists>x \<^bold>\<in> 0. P x) \<longleftrightarrow> False"
  "\<And>a B P. (\<exists>x \<^bold>\<in> B \<triangleleft> a. P x) \<longleftrightarrow> (P a | (\<exists>x \<^bold>\<in> B. P x))"
  "\<And>P Q. (\<exists>x \<^bold>\<in> HCollect Q A. P x) \<longleftrightarrow> (\<exists>x \<^bold>\<in> A. Q x \<and> P x)"
  "\<And>A P. (\<not>(\<exists>x \<^bold>\<in> A. P x)) \<longleftrightarrow> (\<forall>x \<^bold>\<in> A. \<not> P x)"
  by auto

lemma le_HCollect_iff: "A \<le> \<lbrace>x \<^bold>\<in> B. P x\<rbrace> \<longleftrightarrow> A \<le> B \<and> (\<forall>x \<^bold>\<in> A. P x)"
  by blast

end


(*  Gauss-Jordan elimination for matrices represented as functions
    Author: Tobias Nipkow
*)
section \<open>Gauss-Jordan elimination algorithm\<close>
theory Gauss_Jordan_Elim_Fun
  imports
    "HOL-Combinatorics.Transposition"
begin

text\<open>Matrices are functions:\<close>

type_synonym 'a matrix = "nat \<Rightarrow> nat \<Rightarrow> 'a"

text\<open>In order to restrict to finite matrices, a matrix is usually combined
with one or two natural numbers indicating the maximal row and column of the
matrix.

Gauss-Jordan elimination is parameterized with a natural number \<open>n\<close>. It indicates that the matrix \<open>A\<close> has \<open>n\<close> rows and columns.
In fact, \<open>A\<close> is the augmented matrix with \<open>n+1\<close> columns. Column
\<open>n\<close> is the ``right-hand side'', i.e.\ the constant vector \<open>b\<close>. The result is the unit matrix augmented with the solution in column
\<open>n\<close>; see the correctness theorem below.\<close>

fun gauss_jordan :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> ('a)matrix option" where
"gauss_jordan A 0 = Some(A)" |
"gauss_jordan A (Suc m) =
 (case dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] of
   [] \<Rightarrow> None |
   p # _ \<Rightarrow>
    (let Ap' = (\<lambda>j. A p j / A p m);
         A' = (\<lambda>i. if i=p then Ap' else (\<lambda>j. A i j - A i m * Ap' j))
     in gauss_jordan (Fun.swap p m A') m))"

text\<open>Some auxiliary functions:\<close>

definition solution :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
"solution A n x = (\<forall>i<n. (\<Sum> j=0..<n. A i j * x j) = A i n)"

definition unit :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"unit A m n =
 (\<forall>i j::nat. m\<le>j \<longrightarrow> j<n \<longrightarrow> A i j = (if i=j then 1 else 0))"

lemma solution_swap:
assumes "p1 < n" "p2 < n"
shows "solution (Fun.swap p1 p2 A) n x = solution A n x" (is "?L = ?R")
proof(cases "p1=p2")
  case True thus ?thesis by simp
next
  case False
  show ?thesis
  proof
    assume ?R thus ?L using assms False by(simp add: solution_def Fun.swap_def)
  next
   assume ?L
   show ?R
   proof(auto simp: solution_def)
     fix i assume "i<n"
     show "(\<Sum>j = 0..<n. A i j * x j) = A i n"
     proof cases
       assume "i=p1"
       with \<open>?L\<close> assms False show ?thesis
         by(fastforce simp add: solution_def Fun.swap_def)
     next
       assume "i\<noteq>p1"
       show ?thesis
       proof cases
         assume "i=p2"
         with \<open>?L\<close> assms False show ?thesis
           by(fastforce simp add: solution_def Fun.swap_def)
       next
         assume "i\<noteq>p2"
         with \<open>i\<noteq>p1\<close> \<open>?L\<close> \<open>i<n\<close> assms False show ?thesis
           by(fastforce simp add: solution_def Fun.swap_def)
       qed
     qed
   qed
 qed
qed

(* Converting these apply scripts makes them blow up - see above *)

lemma solution_upd1:
  "c \<noteq> 0 \<Longrightarrow> solution (A(p:=(\<lambda>j. A p j / c))) n x = solution A n x"
apply(cases "p<n")
 prefer 2
 apply(simp add: solution_def)
apply(clarsimp simp add: solution_def)
apply rule
 apply clarsimp
 apply(case_tac "i=p")
  apply (simp add: sum_divide_distrib[symmetric] eq_divide_eq field_simps)
 apply simp
apply (simp add: sum_divide_distrib[symmetric] eq_divide_eq field_simps)
done

lemma solution_upd_but1: "\<lbrakk> ap = A p; \<forall>i j. i\<noteq>p \<longrightarrow> a i j = A i j; p<n \<rbrakk> \<Longrightarrow>
 solution (\<lambda>i. if i=p then ap else (\<lambda>j. a i j - c i * ap j)) n x =
 solution A n x"
apply(clarsimp simp add: solution_def)
apply rule
 prefer 2
 apply (simp add: field_simps sum_subtractf sum_distrib_left[symmetric])
apply(clarsimp)
apply(case_tac "i=p")
 apply simp
apply (auto simp add: field_simps sum_subtractf sum_distrib_left[symmetric] all_conj_distrib)
done

subsection\<open>Correctness\<close>

text\<open>The correctness proof:\<close>

lemma gauss_jordan_lemma: "m\<le>n \<Longrightarrow> unit A m n \<Longrightarrow> gauss_jordan A m = Some B \<Longrightarrow>
  unit B 0 n \<and> solution A n (\<lambda>j. B j n)"
proof(induct m arbitrary: A B)
  case 0
  { fix a and b c d :: "'a"
    have "(if a then b else c) * d = (if a then b*d else c*d)" by simp
  } with 0 show ?case by(simp add: unit_def solution_def sum.If_cases)
next
  case (Suc m)
  let "?Ap' p" = "(\<lambda>j. A p j / A p m)"
  let "?A' p" = "(\<lambda>i. if i=p then ?Ap' p else (\<lambda>j. A i j - A i m * ?Ap' p j))"
  from \<open>gauss_jordan A (Suc m) = Some B\<close>
  obtain p ks where "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] = p#ks" and
    rec: "gauss_jordan (Fun.swap p m (?A' p)) m = Some B"
    by (auto split: list.splits)
  from this have p: "p\<le>m" "A p m \<noteq> 0"
    apply(simp_all add: dropWhile_eq_Cons_conv del:upt_Suc)
    by (metis set_upt atLeast0AtMost atLeastLessThanSuc_atLeastAtMost atMost_iff in_set_conv_decomp)
  have "m\<le>n" "m<n" using \<open>Suc m \<le> n\<close> by arith+
  have "unit (Fun.swap p m (?A' p)) m n" using Suc.prems(2) p
    unfolding unit_def Fun.swap_def Suc_le_eq by (auto simp: le_less)
  from Suc.hyps[OF \<open>m\<le>n\<close> this rec] \<open>m<n\<close> p
  show ?case
    by (simp only: solution_swap) (simp_all add: solution_swap solution_upd_but1 [where A = "A(p := ?Ap' p)"] solution_upd1)
qed

theorem gauss_jordan_correct:
  "gauss_jordan A n = Some B \<Longrightarrow> solution A n (\<lambda>j. B j n)"
by(simp add:gauss_jordan_lemma[of n n] unit_def  field_simps)

definition solution2 :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where "solution2 A m n x = (\<forall>i<m. (\<Sum> j=0..<m. A i j * x j) = A i n)"

definition "usolution A m n x \<longleftrightarrow>
  solution2 A m n x \<and> (\<forall>y. solution2 A m n y \<longrightarrow> (\<forall>j<m. y j = x j))"

lemma non_null_if_pivot:
  assumes "usolution A m n x" and "q < m" shows "\<exists>p<m. A p q \<noteq> 0"
proof(rule ccontr)
  assume "\<not>(\<exists>p<m. A p q \<noteq> 0)"
  hence 1: "\<And>p. p<m \<Longrightarrow> A p q = 0" by simp
  { fix y assume 2: "\<forall>j. j\<noteq>q \<longrightarrow> y j = x j"
    { fix i assume "i<m"
      with assms(1) have "A i n = (\<Sum>j = 0..<m. A i j * x j)"
        by (auto simp: solution2_def usolution_def)
      with 1[OF \<open>i<m\<close>] 2
      have "(\<Sum>j = 0..<m. A i j * y j) = A i n"
        by (auto intro!: sum.cong)
    }
    hence "solution2 A m n y" by(simp add: solution2_def)
  }
  hence "solution2 A m n (x(q:=0))" and "solution2 A m n (x(q:=1))" by auto
  with assms(1) zero_neq_one \<open>q < m\<close>
  show False
    by (simp add: usolution_def)
       (metis fun_upd_same zero_neq_one)
qed

lemma lem1:
  fixes f :: "'a \<Rightarrow> 'b::field"
  shows "(\<Sum>x\<in>A. f x * (a * g x)) = a * (\<Sum>x\<in>A. f x * g x)"
  by (simp add: sum_distrib_left field_simps)

subsection\<open>Complete\<close>

lemma gauss_jordan_complete:
  "m \<le> n \<Longrightarrow> usolution A m n x \<Longrightarrow> \<exists>B. gauss_jordan A m = Some B"
proof(induction m arbitrary: A)
  case 0 show ?case by simp
next
  case (Suc m A)
  from \<open>Suc m \<le> n\<close> have "m\<le>n" and "m<Suc m" by arith+
  from non_null_if_pivot[OF Suc.prems(2) \<open>m<Suc m\<close>]
  obtain p' where "p'<Suc m" and "A p' m \<noteq> 0" by blast
  hence "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] \<noteq> []"
    by (simp add: atLeast0LessThan) (metis lessThan_iff linorder_neqE_nat not_less_eq)
  then obtain p xs where 1: "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] = p#xs"
    by (metis list.exhaust)
  from this have "p\<le>m" "A p m \<noteq> 0"
    by (simp_all add: dropWhile_eq_Cons_conv del: upt_Suc)
       (metis set_upt atLeast0AtMost atLeastLessThanSuc_atLeastAtMost atMost_iff in_set_conv_decomp)
  then have p: "p < Suc m" "A p m \<noteq> 0"
    by auto
  let ?Ap' = "(\<lambda>j. A p j / A p m)"
  let ?A' = "(\<lambda>i. if i=p then ?Ap' else (\<lambda>j. A i j - A i m * ?Ap' j))"
  let ?A = "Fun.swap p m ?A'"
  have A: "solution2 A (Suc m) n x" using Suc.prems(2) by(simp add: usolution_def)
  { fix i assume le_m: "p < Suc m" "i < Suc m" "A p m \<noteq> 0"
    have "(\<Sum>j = 0..<m. (A i j - A i m * A p j / A p m) * x j) =
      ((\<Sum>j = 0..<Suc m. A i j * x j) - A i m * x m) -
      ((\<Sum>j = 0..<Suc m. A p j * x j) - A p m * x m) * A i m / A p m"
      by (simp add: field_simps sum_subtractf sum_divide_distrib
                    sum_distrib_left)
    also have "\<dots> = A i n - A p n * A i m / A p m"
      using A le_m
      by (simp add: solution2_def field_simps del: sum.op_ivl_Suc)
    finally have "(\<Sum>j = 0..<m. (A i j - A i m * A p j / A p m) * x j) =
      A i n - A p n * A i m / A p m" . }
  then have "solution2 ?A m n x" using p
    by (auto simp add: solution2_def Fun.swap_def field_simps)
  moreover
  { fix y assume a: "solution2 ?A m n y"
    let ?y = "y(m := A p n / A p m - (\<Sum>j = 0..<m. A p j * y j) / A p m)"
    have "solution2 A (Suc m) n ?y" unfolding solution2_def
    proof safe
      fix i assume "i < Suc m"
      show "(\<Sum>j=0..<Suc m. A i j * ?y j) = A i n"
      proof (cases "i = p")
        assume "i = p" with p show ?thesis by (simp add: field_simps)
      next
        assume "i \<noteq> p"
        show ?thesis
        proof (cases "i = m")
          assume "i = m"
          with p \<open>i \<noteq> p\<close> have "p < m" by simp
          with a[unfolded solution2_def, THEN spec, of p] p(2)
          have "A p m * (A m m * A p n + A p m * (\<Sum>j = 0..<m. y j * A m j)) = A p m * (A m n * A p m + A m m * (\<Sum>j = 0..<m. y j * A p j))"
            by (simp add: Fun.swap_def field_simps sum_subtractf lem1 lem2 sum_divide_distrib[symmetric]
                     split: if_splits)
          with \<open>A p m \<noteq> 0\<close> show ?thesis unfolding \<open>i = m\<close>
            by simp (simp add: field_simps)
        next
          assume "i \<noteq> m"
          then have "i < m" using \<open>i < Suc m\<close> by simp
          with a[unfolded solution2_def, THEN spec, of i] p(2)
          have "A p m * (A i m * A p n + A p m * (\<Sum>j = 0..<m. y j * A i j)) = A p m * (A i n * A p m + A i m * (\<Sum>j = 0..<m. y j * A p j))"
            by (simp add: Fun.swap_def split: if_splits)
              (simp add: field_simps sum_subtractf lem1 lem2 sum_divide_distrib [symmetric])
          with \<open>A p m \<noteq> 0\<close> show ?thesis
            by simp (simp add: field_simps)
        qed
      qed
    qed
    with \<open>usolution A (Suc m) n x\<close>
    have "\<forall>j<Suc m. ?y j = x j" by (simp add: usolution_def)
    hence "\<forall>j<m. y j = x j"
      by simp (metis less_SucI nat_neq_iff)
  } ultimately have "usolution ?A m n x"
    by (simp add: usolution_def)
  note * = Suc.IH [OF \<open>m \<le> n\<close> this]
  from 1 show ?case
    by auto (use * in blast)
qed

text\<open>Future work: extend the proof to matrix inversion.\<close>

hide_const (open) unit

end


theory LeftistHeap
  imports Main "HOL-Library.Multiset"
begin

datatype 'a LHeap = Null | Node "'a LHeap" 'a nat  "'a LHeap"

(* Racunamo rastojanje do null-a koristeci sledece svojstvo leftist hipa:
    dist(right(i)) <= dist(left(i))
*)
fun dist :: "'a LHeap \<Rightarrow> nat" where
  "dist Null = 0"
| "dist (Node _ _ _ r) = dist r + 1"

(* Citamo rastojanje prosledjenog cvora *)
fun readDist :: "'a LHeap \<Rightarrow> nat" where
  "readDist Null = 0"
| "readDist (Node _ _ n _) = n"

(* Ukoliko uslov dist(right(i)) <= dist(left(i) nije ispunjen rotiramo levo i desno
    podstablo i racunamo razdaljinu za koreni cvor
*)
definition node :: "'a LHeap \<Rightarrow> 'a \<Rightarrow> 'a LHeap \<Rightarrow> 'a LHeap" where
  "node l v r =
    (let dl = readDist l; dr = readDist r
     in if dl \<ge> dr then Node l v (dr+1) r else Node r v (dl+1) l)"

fun merge :: "'a::ord LHeap \<Rightarrow> 'a LHeap \<Rightarrow> 'a LHeap" where
  "merge Null t2 = t2"
| "merge t1 Null = t1"
| "merge (Node l1 v1 n1 r1) (Node l2 v2 n2 r2) =
    (if v1 \<le> v2 then node l1 v1 (merge r1 (Node l2 v2 n2 r2))
     else node l2 v2 (merge (Node l1 v1 n1 r1) r2))"

value "merge Null (Node Null 4 1 Null)::nat LHeap"

definition insert :: "'a::ord \<Rightarrow> 'a LHeap \<Rightarrow> 'a LHeap" where
  "insert v t = merge (Node Null v 1 Null) t"

(* testiranje insert-a *)
definition test_tree_1 :: "nat LHeap" where
  "test_tree_1 = (insert 7 (insert 6 (insert 8 (insert 14 Null))))"

definition test_tree_2 :: "nat LHeap" where
    "test_tree_2 = insert 8 (insert 25 (insert 12 (insert 15 (insert 4 (insert 20 (insert 19 (insert 27 (insert 43 Null))))))))"

(* testiranje merge-a*)
value "merge test_tree_1 test_tree_2"

(* brisemo najmanji element (koren) stabla *)
fun delMin :: "'a::ord LHeap \<Rightarrow> 'a LHeap" where
"delMin Null = Null" |
"delMin (Node l v n r) = merge l r"

value "delMin test_tree_1"

(* Uzimamo najmanji element iz stabla *)
fun getMin :: "'a LHeap \<Rightarrow> 'a" where
  "getMin (Node l v n r) = v"

value "getMin test_tree_1"

datatype ('a, 'b) Tree = TNull | TNode "('a, 'b) Tree" 'a 'b "('a, 'b) Tree"

(* Pravimo multiset elemenata iz drveta *)
fun treeToMSet :: "'a LHeap \<Rightarrow> 'a multiset" where
  "treeToMSet Null = {#}"
| "treeToMSet (Node l v _ r) = treeToMSet l + {#v#} + treeToMSet r"

(* Proverava "Normal Min Heap Property" svojstvo:
    key(i) >= key(parent(i))
*)
fun isHeap :: "'a::ord LHeap \<Rightarrow> bool" where
  "isHeap Null = True"
| "isHeap (Node l v _ r) = ((\<forall>x \<in> set_mset(treeToMSet l + treeToMSet r).v \<le> x)
                            \<and> isHeap l \<and> isHeap r)"

definition heap :: "nat LHeap" where
  "heap = (Node (Node (Node Null 4 20 Null) 2 5 (Node Null 5 25 Null)) 1 11 (Node Null 3 7 Null))"
definition not_heap :: "nat LHeap" where
  "not_heap = (Node (Node (Node Null 14 20 Null) 21 5 (Node Null 5 25 Null)) 19 11 (Node Null 6 7 Null))"

value "isHeap heap"
value "isHeap not_heap"

(* Proverava "Heavier on left side" svojstvo:
     dist(right(i)) <= dist(left(i))
*)
fun isLHeap :: "'a LHeap \<Rightarrow> bool" where
  "isLHeap Null = True"
| "isLHeap (Node l v n r) = (n = dist r + 1 \<and> dist l \<ge> dist r
                             \<and> (isLHeap l \<and> isLHeap r))"

(* Prosledjeno leftist drvo*)
value "isLHeap test_tree_1"

(* Prosledjeno drvo koje nije leftist *)
definition not_ltree :: "nat LHeap" where
  "not_ltree = (Node (Node Null 6 1 Null) 4 3 (Node (Node Null 6 1 Null) 8 2 (Node Null 10 1 Null)))"
value "isLHeap not_ltree"

(* Prazan multiset nekog drveta znaci da je drvo null *)
lemma emptyMSetEQNullTree[simp]: "treeToMSet tree = {#} \<longleftrightarrow> tree = Null"
  by (induction tree) auto

lemma getDistEQDist[simp]: "isLHeap tree \<Longrightarrow> readDist tree = dist tree"
  by (induction tree) auto

(* Ako primenimo node funkciju na dva leftist stabla, dobijeno stablo
    ostaje leftist
 *)
lemma isLHeapNode[simp]: "isLHeap l \<and> isLHeap r \<longleftrightarrow> isLHeap (node l v r)"
  using node_def
  by (smt getDistEQDist isLHeap.simps(2) linear)

(* Izvrsavanjem node funkcije drvo ne gubi "Normal Min Heap Property" svojstvo:
    key(i) >= key(parent(i))
*)
lemma heapNode[simp]: "isHeap (node l v r) \<longleftrightarrow>
  isHeap l \<and> isHeap r \<and> (\<forall>x \<in> set_mset(treeToMSet l + treeToMSet r). v \<le> x)"
  using node_def
  by (smt add.commute isHeap.simps(2))

(* Multiskup dva spojena drveta je jednak uniji multiskupova pojedinacnih dveta *)
lemma mergeMSet[simp]: "treeToMSet (merge tree1 tree2) = treeToMSet tree1 + treeToMSet tree2"
proof (induction tree1 tree2 rule: merge.induct)
case (1 t2)
then show ?case
  by simp
next
  case (2 v va vb vc)
  then show ?case
    by simp
next
  case (3 l1 v1 n1 r1 l2 v2 n2 r2)
  then show ?case
  proof cases
    assume "v1 \<le> v2"
    hence "treeToMSet (merge r1 (Node l2 v2 n2 r2)) = treeToMSet r1 + treeToMSet (Node l2 v2 n2 r2)"
      by (simp add: "3.IH"(1))
    thus "treeToMSet (merge (Node l1 v1 n1 r1) (Node l2 v2 n2 r2)) = treeToMSet (Node l1 v1 n1 r1) + treeToMSet (Node l2 v2 n2 r2)"
      using  LHeap.simps(1)  LHeap.simps(3)  merge.simps(3) node_def treeToMSet.simps(2)
    by (smt \<open>v1 \<le> v2\<close> add.commute add.left_commute )
  next
    assume "\<not> v1 \<le> v2"
    hence "treeToMSet (merge (Node l1 v1 n1 r1) r2) = treeToMSet (Node l1 v1 n1 r1) + treeToMSet r2"
      by (simp add: "3.IH"(2))
    thus "treeToMSet (merge (Node l1 v1 n1 r1) (Node l2 v2 n2 r2)) = treeToMSet (Node l1 v1 n1 r1) + treeToMSet (Node l2 v2 n2 r2)"
      using  merge.simps(3) node_def treeToMSet.simps(2)
  by (smt \<open>\<not> v1 \<le> v2\<close> add.assoc add.commute)
  qed
qed

(* Multiskup drveta nakon ubacivanja elemenata je jednak multiskupu kojem smo dodali novi element*)
lemma insertMSet[simp]: "treeToMSet (insert v tree) = treeToMSet tree + {#v#}"
  using insert_def
  by (metis add.commute add_mset_add_single mergeMSet treeToMSet.simps(1) treeToMSet.simps(2))

(* Ukoliko je drvo hip i nije Null tada je njegov najmanji element jednak najmanjem
  elementu multiskupa tog drveta*)
lemma minHeapEQminMSet[simp]:
  assumes "isHeap tree" and "tree \<noteq> Null"
  shows "getMin tree = Min_mset (treeToMSet tree)"
  by (smt Min_insert2 add_mset_add_single assms(1) assms(2) finite_set_mset
      getMin.simps isHeap.simps(2) set_mset_add_mset_insert treeToMSet.elims
      union_mset_add_mset_left)

(* Multiskup drveta sa izbrisanim najmanjim elementom jednak je razlici  multiskupu
 celog drveta i najmanjeg elementa. *)
lemma delMinMSet[simp]: "treeToMSet (delMin tree) = treeToMSet tree - {#getMin tree#}"
  by (smt add_mset_add_single add_mset_not_empty add_mset_remove_trivial
      add_mset_remove_trivial_If delMin.simps(1) delMin.simps(2) diff_single_trivial
      getMin.simps mergeMSet treeToMSet.elims union_mset_add_mset_left)

(* Ako pretpostavimo da je levo podstablo leftist i desno podstablo leftist kad ih
  spojimo novo stablo je takodje leftist. *)
lemma LHeapMerge[simp]:
  assumes "isLHeap l" and "isLHeap r"
  shows "isLHeap (merge l r)"
  using assms
proof (induction l r rule: merge.induct)
case (1 t2)
  then show ?case
    by simp
next
  case (2 v va vb vc)
  then show ?case
    by simp
next
  case (3 l1 v1 n1 r1 l2 v2 n2 r2)
  then show ?case
    by (metis isLHeap.simps(2) isLHeapNode merge.simps(3))
qed

lemma heapMerge:
  assumes "isHeap l" and "isHeap r"
  shows "isHeap (merge l r)"
  using assms
  proof (induction l r rule: merge.induct)
case (1 t2)
then show ?case
  by simp
next
  case (2 v va vb vc)
  then show ?case by simp
next
  case (3 l1 v1 n1 r1 l2 v2 n2 r2)
  then show ?case
  proof(cases)
    assume "v1 \<le> v2"
    hence "isHeap r1"
      using "3.prems"(1) by auto
    hence "isHeap (Node l2 v2 n2 r2)"
  using "3.prems"(2) by auto
  hence *:"isHeap (merge r1 (Node l2 v2 n2 r2))"
    by (simp add: "3.IH"(1) \<open>isHeap r1\<close> \<open>v1 \<le> v2\<close>)
  have **: "isHeap (Node l1 v1 n1 r1)"
    using "3.prems"(1) by blast
  have "isHeap (Node l2 v2 n2 r2)"
    using "3.prems"(2) by auto
  thus "isHeap (merge (Node l1 v1 n1 r1) (Node l2 v2 n2 r2))"
    using * **
    sorry

next
  assume "\<not> v1 \<le> v2"
  hence "isHeap (Node l1 v1 n1 r1)"
    using "3.prems"(1) by blast
  hence "isHeap r2"
    using "3.prems"(2) isHeap.simps(2) by blast
  hence "isHeap (merge (Node l1 v1 n1 r1) r2)"
    using "3.IH"(2) "3.prems"(1) \<open>\<not> v1 \<le> v2\<close> by blast
  thus "isHeap (merge (Node l1 v1 n1 r1) (Node l2 v2 n2 r2))"
    sorry
  qed
qed

(* U narednim lemama se proverava da li drvo posle ubacivanja elementa ili
    brisanja najmanjeg elementa zadrzava sledeca svojstva:
    -"Normal Min Heap Property": value(i) >= value(parent(i))
    -"Heavier on left side": dist(right(i)) <= dist(left(i))
*)
lemma insertIsLHeap: "isLHeap tree \<Longrightarrow> isLHeap (insert v tree)"
  by (simp add: LeftistHeap.insert_def)

lemma isertIsHeap: "isHeap tree \<Longrightarrow> isHeap (insert v tree)"
  by (simp add: LeftistHeap.insert_def heapMerge)

lemma delMinIsLHeap: "isLHeap tree \<Longrightarrow> isLHeap (delMin tree)"
  by (metis LHeapMerge delMin.simps(1) delMin.simps(2) isLHeap.elims(2))

lemma delMinIsHeap: "isHeap tree \<Longrightarrow> isHeap (delMin tree)"
  by (metis (full_types) delMin.elims heapMerge isHeap.simps(2))

(*
Implementiramo red sa prioritetom zasnovan na leftist drvetu sa sledecim operacijama:
  push: Ubacujemo element sa njegovim prioritetom.
  top: Ocitavamo element sa najmanjim prioritetom.
  pop: Brisemo element sa najmanjim prioritetom.
  empty: Proveravamo da li je red prazan.
 *)

type_synonym PriorityQueue = "nat LHeap"

fun push :: "nat \<Rightarrow> PriorityQueue \<Rightarrow> PriorityQueue" where
  "push pr PQ  = insert pr PQ"

fun top :: "PriorityQueue \<Rightarrow> nat" where
  "top PQ = getMin PQ"

fun pop :: "PriorityQueue \<Rightarrow> PriorityQueue" where
  "pop PQ = delMin PQ"

fun empty :: "PriorityQueue \<Rightarrow> bool" where
  "empty PQ \<longleftrightarrow> PQ = Null"

definition bank :: "PriorityQueue" where
  "bank = push 5 (push 150 (push 112 Null))"

value "top bank"
value "top (pop bank)"
value "empty bank"

(* Hipsort zasnovan na leftist drvetu *)

fun listToLHeap :: "'a::ord list \<Rightarrow> 'a LHeap" where
  "listToLHeap [] = Null"
| "listToLHeap (x # xs) = insert x (listToLHeap xs)"

value "listToLHeap [2::nat,7,1,9,6]"

fun size :: "'a::ord LHeap \<Rightarrow> nat" where
  "size Null = 0"
| "size (Node Null _ _ Null) = 1"
| "size (Node l _ _ Null) = 1 + size l"
| "size (Node Null _ _ r) = 1 + size r"
| "size (Node l _ _ r) = 1 + size l + size r"

lemma sizeMerge[simp]: "size t1 + size t2 = size (merge t1 t2)"
proof (induction t1 t2 rule: merge.induct)
  case (1 t2)
then show ?case by simp
next
  case (2 v va vb vc)
  then show ?case by simp
next
  case (3 l1 v1 n1 r1 l2 v2 n2 r2)
  then show ?case
  proof (cases)
    assume "v1 \<le> v2"
    hence "LeftistHeap.size r1 + LeftistHeap.size (Node l2 v2 n2 r2) = LeftistHeap.size (merge r1 (Node l2 v2 n2 r2))"
      by (simp add: "3.IH"(1))
    thus "LeftistHeap.size (Node l1 v1 n1 r1) + LeftistHeap.size (Node l2 v2 n2 r2) = LeftistHeap.size (merge (Node l1 v1 n1 r1) (Node l2 v2 n2 r2))"
      using node_def
      sorry
next
  assume "\<not>v1 \<le> v2"
  hence " LeftistHeap.size (Node l1 v1 n1 r1) + LeftistHeap.size r2 = LeftistHeap.size (merge (Node l1 v1 n1 r1) r2)"
    by (simp add: "3.IH"(2))
  thus "LeftistHeap.size (Node l1 v1 n1 r1) + LeftistHeap.size (Node l2 v2 n2 r2) = LeftistHeap.size (merge (Node l1 v1 n1 r1) (Node l2 v2 n2 r2))"
    sorry
qed
qed

function heapsort' :: "nat LHeap \<Rightarrow> nat list" where
  "heapsort' Null = []"
| "heapsort' (Node Null v _ Null) = [v]"
| "heapsort' (Node l v _ r) = v # heapsort' (merge l r)"
  apply pat_completeness
apply   auto

end


theory Tutorial2_2
imports Main
begin

  section \<open>Arithmetic Expressions with Exceptions\<close>

  text \<open>Model arithmetic expressions that have constants, variables, plus, and div.\<close>

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

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

  text \<open>Model the evaluation to return \<open>None\<close> if a division by zero occurs, and \<open>Some v\<close> otherwise.
    Use case distinctions to distinguish between None and Some results.
  \<close>

  fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val option" where
    "aval (N i) s = Some i"
  | "aval (V x) s = Some (s x)"
  | "aval (Plus a1 a2) s = (case aval a1 s of
      None \<Rightarrow> None
    | Some v1 \<Rightarrow> (case aval a2 s of
        None \<Rightarrow> None
      | Some v2 \<Rightarrow> Some (v1+v2)
      )
    )"
  | "aval (Div a1 a2) s = (case aval a1 s of
      None \<Rightarrow> None
    | Some v1 \<Rightarrow> (case aval a2 s of
        None \<Rightarrow> None
      | Some v2 \<Rightarrow> (if v2=0 then None else Some (v1 div v2))
      )
    )"

text {* A little syntax magic to write larger states compactly: *}

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

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

text \<open>Add constant folding to divisions. Consider division of two constants and division by one.
  Be careful not to accidentally "define" division by zero to be \<open>x div 0\<close>.
\<close>

fun division :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "division (N i1) (N i2) = (if i2\<noteq>0 then N (i1 div i2) else Div (N i1) (N i2))"
| "division a (N i) = (if i=1 then a else Div a (N i))"
| "division a b = Div a b"

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval (Plus a1 a2) s"
apply(induction a1 a2 rule: plus.induct)
apply (auto split: option.splits)
done

lemma aval_div[simp]:
  "aval (division a1 a2) s = aval (Div a1 a2) s"
  apply (induction a1 a2 rule: division.induct)
  apply (auto split: option.splits)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)" |
"asimp (Div a\<^sub>1 a\<^sub>2) = division (asimp a\<^sub>1) (asimp a\<^sub>2)"
(* Add an equation for division *)

(* Show correctness of constant folding. *)
theorem aval_asimp[simp]: "aval (asimp a) s = aval a s"
  apply (induction a)
  apply (auto split: option.splits)
  done

end