(*  Title:      HOL/Library/FuncSet.thy
    Author:     Florian Kammueller and Lawrence C Paulson, Lukas Bulwahn
*)

section \<open>Pi and Function Sets\<close>

theory FuncSet
imports Hilbert_Choice Main
begin

definition Pi :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b) set"
  where "Pi A B = {f. \<forall>x. x \<in> A \<longrightarrow> f x \<in> B x}"

definition extensional :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) set"
  where "extensional A = {f. \<forall>x. x \<notin> A \<longrightarrow> f x = undefined}"

definition "restrict" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b"
  where "restrict f A = (\<lambda>x. if x \<in> A then f x else undefined)"

abbreviation funcset :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  (infixr "->" 60)
  where "A -> B \<equiv> Pi A (\<lambda>_. B)"

notation (xsymbols)
  funcset  (infixr "\<rightarrow>" 60)

syntax
  "_Pi"  :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3PI _:_./ _)" 10)
  "_lam" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3%_:_./ _)" [0,0,3] 3)
syntax (xsymbols)
  "_Pi" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3\<Pi> _\<in>_./ _)"   10)
  "_lam" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3\<lambda>_\<in>_./ _)" [0,0,3] 3)
syntax (HTML output)
  "_Pi" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3\<Pi> _\<in>_./ _)"   10)
  "_lam" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3\<lambda>_\<in>_./ _)" [0,0,3] 3)
translations
  "\<Pi> x\<in>A. B" \<rightleftharpoons> "CONST Pi A (\<lambda>x. B)"
  "\<lambda>x\<in>A. f" \<rightleftharpoons> "CONST restrict (\<lambda>x. f) A"

definition "compose" :: "'a set \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c)"
  where "compose A g f = (\<lambda>x\<in>A. g (f x))"

subsection \<open>Basic Properties of @{term Pi}\<close>

lemma Pi_I[intro!]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> f \<in> Pi A B"
  by (simp add: Pi_def)

lemma Pi_I'[simp]: "(\<And>x. x \<in> A \<longrightarrow> f x \<in> B x) \<Longrightarrow> f \<in> Pi A B"
  by (simp add:Pi_def)

lemma funcsetI: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> f \<in> A \<rightarrow> B"
  by (simp add: Pi_def)

lemma Pi_mem: "f \<in> Pi A B \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<in> B x"
  by (simp add: Pi_def)

lemma Pi_iff: "f \<in> Pi I X \<longleftrightarrow> (\<forall>i\<in>I. f i \<in> X i)"
  unfolding Pi_def by auto

lemma PiE [elim]: "f \<in> Pi A B \<Longrightarrow> (f x \<in> B x \<Longrightarrow> Q) \<Longrightarrow> (x \<notin> A \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (auto simp: Pi_def)

lemma Pi_cong: "(\<And>w. w \<in> A \<Longrightarrow> f w = g w) \<Longrightarrow> f \<in> Pi A B \<longleftrightarrow> g \<in> Pi A B"
  by (auto simp: Pi_def)

lemma funcset_id [simp]: "(\<lambda>x. x) \<in> A \<rightarrow> A"
  by auto

lemma funcset_mem: "f \<in> A \<rightarrow> B \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<in> B"
  by (simp add: Pi_def)

lemma funcset_image: "f \<in> A \<rightarrow> B \<Longrightarrow> f ` A \<subseteq> B"
  by auto

lemma image_subset_iff_funcset: "F ` A \<subseteq> B \<longleftrightarrow> F \<in> A \<rightarrow> B"
  by auto

lemma Pi_eq_empty[simp]: "(\<Pi> x \<in> A. B x) = {} \<longleftrightarrow> (\<exists>x\<in>A. B x = {})"
  apply (simp add: Pi_def)
  apply auto
  txt \<open>Converse direction requires Axiom of Choice to exhibit a function
  picking an element from each non-empty @{term "B x"}\<close>
  apply (drule_tac x = "\<lambda>u. SOME y. y \<in> B u" in spec)
  apply auto
  apply (cut_tac P = "\<lambda>y. y \<in> B x" in some_eq_ex)
  apply auto
  done

lemma Pi_empty [simp]: "Pi {} B = UNIV"
  by (simp add: Pi_def)

lemma Pi_Int: "Pi I E \<inter> Pi I F = (\<Pi> i\<in>I. E i \<inter> F i)"
  by auto

lemma Pi_UN:
  fixes A :: "nat \<Rightarrow> 'i \<Rightarrow> 'a set"
  assumes "finite I"
    and mono: "\<And>i n m. i \<in> I \<Longrightarrow> n \<le> m \<Longrightarrow> A n i \<subseteq> A m i"
  shows "(\<Union>n. Pi I (A n)) = (\<Pi> i\<in>I. \<Union>n. A n i)"
proof (intro set_eqI iffI)
  fix f
  assume "f \<in> (\<Pi> i\<in>I. \<Union>n. A n i)"
  then have "\<forall>i\<in>I. \<exists>n. f i \<in> A n i"
    by auto
  from bchoice[OF this] obtain n where n: "\<And>i. i \<in> I \<Longrightarrow> f i \<in> (A (n i) i)"
    by auto
  obtain k where k: "\<And>i. i \<in> I \<Longrightarrow> n i \<le> k"
    using \<open>finite I\<close> finite_nat_set_iff_bounded_le[of "n`I"] by auto
  have "f \<in> Pi I (A k)"
  proof (intro Pi_I)
    fix i
    assume "i \<in> I"
    from mono[OF this, of "n i" k] k[OF this] n[OF this]
    show "f i \<in> A k i" by auto
  qed
  then show "f \<in> (\<Union>n. Pi I (A n))"
    by auto
qed auto

lemma Pi_UNIV [simp]: "A \<rightarrow> UNIV = UNIV"
  by (simp add: Pi_def)

text \<open>Covariance of Pi-sets in their second argument\<close>
lemma Pi_mono: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x) \<Longrightarrow> Pi A B \<subseteq> Pi A C"
  by auto

text \<open>Contravariance of Pi-sets in their first argument\<close>
lemma Pi_anti_mono: "A' \<subseteq> A \<Longrightarrow> Pi A B \<subseteq> Pi A' B"
  by auto

lemma prod_final:
  assumes 1: "fst \<circ> f \<in> Pi A B"
    and 2: "snd \<circ> f \<in> Pi A C"
  shows "f \<in> (\<Pi> z \<in> A. B z \<times> C z)"
proof (rule Pi_I)
  fix z
  assume z: "z \<in> A"
  have "f z = (fst (f z), snd (f z))"
    by simp
  also have "\<dots> \<in> B z \<times> C z"
    by (metis SigmaI PiE o_apply 1 2 z)
  finally show "f z \<in> B z \<times> C z" .
qed

lemma Pi_split_domain[simp]: "x \<in> Pi (I \<union> J) X \<longleftrightarrow> x \<in> Pi I X \<and> x \<in> Pi J X"
  by (auto simp: Pi_def)

lemma Pi_split_insert_domain[simp]: "x \<in> Pi (insert i I) X \<longleftrightarrow> x \<in> Pi I X \<and> x i \<in> X i"
  by (auto simp: Pi_def)

lemma Pi_cancel_fupd_range[simp]: "i \<notin> I \<Longrightarrow> x \<in> Pi I (B(i := b)) \<longleftrightarrow> x \<in> Pi I B"
  by (auto simp: Pi_def)

lemma Pi_cancel_fupd[simp]: "i \<notin> I \<Longrightarrow> x(i := a) \<in> Pi I B \<longleftrightarrow> x \<in> Pi I B"
  by (auto simp: Pi_def)

lemma Pi_fupd_iff: "i \<in> I \<Longrightarrow> f \<in> Pi I (B(i := A)) \<longleftrightarrow> f \<in> Pi (I - {i}) B \<and> f i \<in> A"
  apply auto
  apply (drule_tac x=x in Pi_mem)
  apply (simp_all split: split_if_asm)
  apply (drule_tac x=i in Pi_mem)
  apply (auto dest!: Pi_mem)
  done

subsection \<open>Composition With a Restricted Domain: @{term compose}\<close>

lemma funcset_compose: "f \<in> A \<rightarrow> B \<Longrightarrow> g \<in> B \<rightarrow> C \<Longrightarrow> compose A g f \<in> A \<rightarrow> C"
  by (simp add: Pi_def compose_def restrict_def)

lemma compose_assoc:
  assumes "f \<in> A \<rightarrow> B"
    and "g \<in> B \<rightarrow> C"
    and "h \<in> C \<rightarrow> D"
  shows "compose A h (compose A g f) = compose A (compose B h g) f"
  using assms by (simp add: fun_eq_iff Pi_def compose_def restrict_def)

lemma compose_eq: "x \<in> A \<Longrightarrow> compose A g f x = g (f x)"
  by (simp add: compose_def restrict_def)

lemma surj_compose: "f ` A = B \<Longrightarrow> g ` B = C \<Longrightarrow> compose A g f ` A = C"
  by (auto simp add: image_def compose_eq)

subsection \<open>Bounded Abstraction: @{term restrict}\<close>

lemma restrict_in_funcset: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> (\<lambda>x\<in>A. f x) \<in> A \<rightarrow> B"
  by (simp add: Pi_def restrict_def)

lemma restrictI[intro!]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> (\<lambda>x\<in>A. f x) \<in> Pi A B"
  by (simp add: Pi_def restrict_def)

lemma restrict_apply[simp]: "(\<lambda>y\<in>A. f y) x = (if x \<in> A then f x else undefined)"
  by (simp add: restrict_def)

lemma restrict_apply': "x \<in> A \<Longrightarrow> (\<lambda>y\<in>A. f y) x = f x"
  by simp

lemma restrict_ext: "(\<And>x. x \<in> A \<Longrightarrow> f x = g x) \<Longrightarrow> (\<lambda>x\<in>A. f x) = (\<lambda>x\<in>A. g x)"
  by (simp add: fun_eq_iff Pi_def restrict_def)

lemma restrict_UNIV: "restrict f UNIV = f"
  by (simp add: restrict_def)

lemma inj_on_restrict_eq [simp]: "inj_on (restrict f A) A = inj_on f A"
  by (simp add: inj_on_def restrict_def)

lemma Id_compose: "f \<in> A \<rightarrow> B \<Longrightarrow> f \<in> extensional A \<Longrightarrow> compose A (\<lambda>y\<in>B. y) f = f"
  by (auto simp add: fun_eq_iff compose_def extensional_def Pi_def)

lemma compose_Id: "g \<in> A \<rightarrow> B \<Longrightarrow> g \<in> extensional A \<Longrightarrow> compose A g (\<lambda>x\<in>A. x) = g"
  by (auto simp add: fun_eq_iff compose_def extensional_def Pi_def)

lemma image_restrict_eq [simp]: "(restrict f A) ` A = f ` A"
  by (auto simp add: restrict_def)

lemma restrict_restrict[simp]: "restrict (restrict f A) B = restrict f (A \<inter> B)"
  unfolding restrict_def by (simp add: fun_eq_iff)

lemma restrict_fupd[simp]: "i \<notin> I \<Longrightarrow> restrict (f (i := x)) I = restrict f I"
  by (auto simp: restrict_def)

lemma restrict_upd[simp]: "i \<notin> I \<Longrightarrow> (restrict f I)(i := y) = restrict (f(i := y)) (insert i I)"
  by (auto simp: fun_eq_iff)

lemma restrict_Pi_cancel: "restrict x I \<in> Pi I A \<longleftrightarrow> x \<in> Pi I A"
  by (auto simp: restrict_def Pi_def)

subsection \<open>Bijections Between Sets\<close>

text \<open>The definition of @{const bij_betw} is in @{text "Fun.thy"}, but most of
the theorems belong here, or need at least @{term Hilbert_Choice}.\<close>

lemma bij_betwI:
  assumes "f \<in> A \<rightarrow> B"
    and "g \<in> B \<rightarrow> A"
    and g_f: "\<And>x. x\<in>A \<Longrightarrow> g (f x) = x"
    and f_g: "\<And>y. y\<in>B \<Longrightarrow> f (g y) = y"
  shows "bij_betw f A B"
  unfolding bij_betw_def
proof
  show "inj_on f A"
    by (metis g_f inj_on_def)
  have "f ` A \<subseteq> B"
    using \<open>f \<in> A \<rightarrow> B\<close> by auto
  moreover
  have "B \<subseteq> f ` A"
    by auto (metis Pi_mem \<open>g \<in> B \<rightarrow> A\<close> f_g image_iff)
  ultimately show "f ` A = B"
    by blast
qed

lemma bij_betw_imp_funcset: "bij_betw f A B \<Longrightarrow> f \<in> A \<rightarrow> B"
  by (auto simp add: bij_betw_def)

lemma inj_on_compose: "bij_betw f A B \<Longrightarrow> inj_on g B \<Longrightarrow> inj_on (compose A g f) A"
  by (auto simp add: bij_betw_def inj_on_def compose_eq)

lemma bij_betw_compose: "bij_betw f A B \<Longrightarrow> bij_betw g B C \<Longrightarrow> bij_betw (compose A g f) A C"
  apply (simp add: bij_betw_def compose_eq inj_on_compose)
  apply (auto simp add: compose_def image_def)
  done

lemma bij_betw_restrict_eq [simp]: "bij_betw (restrict f A) A B = bij_betw f A B"
  by (simp add: bij_betw_def)

subsection \<open>Extensionality\<close>

lemma extensional_empty[simp]: "extensional {} = {\<lambda>x. undefined}"
  unfolding extensional_def by auto

lemma extensional_arb: "f \<in> extensional A \<Longrightarrow> x \<notin> A \<Longrightarrow> f x = undefined"
  by (simp add: extensional_def)

lemma restrict_extensional [simp]: "restrict f A \<in> extensional A"
  by (simp add: restrict_def extensional_def)

lemma compose_extensional [simp]: "compose A f g \<in> extensional A"
  by (simp add: compose_def)

lemma extensionalityI:
  assumes "f \<in> extensional A"
    and "g \<in> extensional A"
    and "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
  shows "f = g"
  using assms by (force simp add: fun_eq_iff extensional_def)

lemma extensional_restrict:  "f \<in> extensional A \<Longrightarrow> restrict f A = f"
  by (rule extensionalityI[OF restrict_extensional]) auto

lemma extensional_subset: "f \<in> extensional A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f \<in> extensional B"
  unfolding extensional_def by auto

lemma inv_into_funcset: "f ` A = B \<Longrightarrow> (\<lambda>x\<in>B. inv_into A f x) \<in> B \<rightarrow> A"
  by (unfold inv_into_def) (fast intro: someI2)

lemma compose_inv_into_id: "bij_betw f A B \<Longrightarrow> compose A (\<lambda>y\<in>B. inv_into A f y) f = (\<lambda>x\<in>A. x)"
  apply (simp add: bij_betw_def compose_def)
  apply (rule restrict_ext, auto)
  done

lemma compose_id_inv_into: "f ` A = B \<Longrightarrow> compose B f (\<lambda>y\<in>B. inv_into A f y) = (\<lambda>x\<in>B. x)"
  apply (simp add: compose_def)
  apply (rule restrict_ext)
  apply (simp add: f_inv_into_f)
  done

lemma extensional_insert[intro, simp]:
  assumes "a \<in> extensional (insert i I)"
  shows "a(i := b) \<in> extensional (insert i I)"
  using assms unfolding extensional_def by auto

lemma extensional_Int[simp]: "extensional I \<inter> extensional I' = extensional (I \<inter> I')"
  unfolding extensional_def by auto

lemma extensional_UNIV[simp]: "extensional UNIV = UNIV"
  by (auto simp: extensional_def)

lemma restrict_extensional_sub[intro]: "A \<subseteq> B \<Longrightarrow> restrict f A \<in> extensional B"
  unfolding restrict_def extensional_def by auto

lemma extensional_insert_undefined[intro, simp]:
  "a \<in> extensional (insert i I) \<Longrightarrow> a(i := undefined) \<in> extensional I"
  unfolding extensional_def by auto

lemma extensional_insert_cancel[intro, simp]:
  "a \<in> extensional I \<Longrightarrow> a \<in> extensional (insert i I)"
  unfolding extensional_def by auto

subsection \<open>Cardinality\<close>

lemma card_inj: "f \<in> A \<rightarrow> B \<Longrightarrow> inj_on f A \<Longrightarrow> finite B \<Longrightarrow> card A \<le> card B"
  by (rule card_inj_on_le) auto

lemma card_bij:
  assumes "f \<in> A \<rightarrow> B" "inj_on f A"
    and "g \<in> B \<rightarrow> A" "inj_on g B"
    and "finite A" "finite B"
  shows "card A = card B"
  using assms by (blast intro: card_inj order_antisym)

subsection \<open>Extensional Function Spaces\<close>

definition PiE :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b) set"
  where "PiE S T = Pi S T \<inter> extensional S"

abbreviation "Pi\<^sub>E A B \<equiv> PiE A B"

syntax
  "_PiE" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3PIE _:_./ _)" 10)
syntax (xsymbols)
  "_PiE" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3\<Pi>\<^sub>E _\<in>_./ _)" 10)
syntax (HTML output)
  "_PiE" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3\<Pi>\<^sub>E _\<in>_./ _)" 10)
translations "\<Pi>\<^sub>E x\<in>A. B" \<rightleftharpoons> "CONST Pi\<^sub>E A (\<lambda>x. B)"

abbreviation extensional_funcset :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set" (infixr "->\<^sub>E" 60)
  where "A ->\<^sub>E B \<equiv> (\<Pi>\<^sub>E i\<in>A. B)"

notation (xsymbols)
  extensional_funcset  (infixr "\<rightarrow>\<^sub>E" 60)

lemma extensional_funcset_def: "extensional_funcset S T = (S \<rightarrow> T) \<inter> extensional S"
  by (simp add: PiE_def)

lemma PiE_empty_domain[simp]: "PiE {} T = {\<lambda>x. undefined}"
  unfolding PiE_def by simp

lemma PiE_UNIV_domain: "PiE UNIV T = Pi UNIV T"
  unfolding PiE_def by simp

lemma PiE_empty_range[simp]: "i \<in> I \<Longrightarrow> F i = {} \<Longrightarrow> (\<Pi>\<^sub>E i\<in>I. F i) = {}"
  unfolding PiE_def by auto

lemma PiE_eq_empty_iff: "Pi\<^sub>E I F = {} \<longleftrightarrow> (\<exists>i\<in>I. F i = {})"
proof
  assume "Pi\<^sub>E I F = {}"
  show "\<exists>i\<in>I. F i = {}"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "\<forall>i. \<exists>y. (i \<in> I \<longrightarrow> y \<in> F i) \<and> (i \<notin> I \<longrightarrow> y = undefined)"
      by auto
    from choice[OF this]
    obtain f where " \<forall>x. (x \<in> I \<longrightarrow> f x \<in> F x) \<and> (x \<notin> I \<longrightarrow> f x = undefined)" ..
    then have "f \<in> Pi\<^sub>E I F"
      by (auto simp: extensional_def PiE_def)
    with \<open>Pi\<^sub>E I F = {}\<close> show False
      by auto
  qed
qed (auto simp: PiE_def)

lemma PiE_arb: "f \<in> PiE S T \<Longrightarrow> x \<notin> S \<Longrightarrow> f x = undefined"
  unfolding PiE_def by auto (auto dest!: extensional_arb)

lemma PiE_mem: "f \<in> PiE S T \<Longrightarrow> x \<in> S \<Longrightarrow> f x \<in> T x"
  unfolding PiE_def by auto

lemma PiE_fun_upd: "y \<in> T x \<Longrightarrow> f \<in> PiE S T \<Longrightarrow> f(x := y) \<in> PiE (insert x S) T"
  unfolding PiE_def extensional_def by auto

lemma fun_upd_in_PiE: "x \<notin> S \<Longrightarrow> f \<in> PiE (insert x S) T \<Longrightarrow> f(x := undefined) \<in> PiE S T"
  unfolding PiE_def extensional_def by auto

lemma PiE_insert_eq:
  assumes "x \<notin> S"
  shows "PiE (insert x S) T = (\<lambda>(y, g). g(x := y)) ` (T x \<times> PiE S T)"
proof -
  {
    fix f assume "f \<in> PiE (insert x S) T"
    with assms have "f \<in> (\<lambda>(y, g). g(x := y)) ` (T x \<times> PiE S T)"
      by (auto intro!: image_eqI[where x="(f x, f(x := undefined))"] intro: fun_upd_in_PiE PiE_mem)
  }
  then show ?thesis
    using assms by (auto intro: PiE_fun_upd)
qed

lemma PiE_Int: "Pi\<^sub>E I A \<inter> Pi\<^sub>E I B = Pi\<^sub>E I (\<lambda>x. A x \<inter> B x)"
  by (auto simp: PiE_def)

lemma PiE_cong: "(\<And>i. i\<in>I \<Longrightarrow> A i = B i) \<Longrightarrow> Pi\<^sub>E I A = Pi\<^sub>E I B"
  unfolding PiE_def by (auto simp: Pi_cong)

lemma PiE_E [elim]:
  assumes "f \<in> PiE A B"
  obtains "x \<in> A" and "f x \<in> B x"
    | "x \<notin> A" and "f x = undefined"
  using assms by (auto simp: Pi_def PiE_def extensional_def)

lemma PiE_I[intro!]:
  "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> (\<And>x. x \<notin> A \<Longrightarrow> f x = undefined) \<Longrightarrow> f \<in> PiE A B"
  by (simp add: PiE_def extensional_def)

lemma PiE_mono: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x) \<Longrightarrow> PiE A B \<subseteq> PiE A C"
  by auto

lemma PiE_iff: "f \<in> PiE I X \<longleftrightarrow> (\<forall>i\<in>I. f i \<in> X i) \<and> f \<in> extensional I"
  by (simp add: PiE_def Pi_iff)

lemma PiE_restrict[simp]:  "f \<in> PiE A B \<Longrightarrow> restrict f A = f"
  by (simp add: extensional_restrict PiE_def)

lemma restrict_PiE[simp]: "restrict f I \<in> PiE I S \<longleftrightarrow> f \<in> Pi I S"
  by (auto simp: PiE_iff)

lemma PiE_eq_subset:
  assumes ne: "\<And>i. i \<in> I \<Longrightarrow> F i \<noteq> {}" "\<And>i. i \<in> I \<Longrightarrow> F' i \<noteq> {}"
    and eq: "Pi\<^sub>E I F = Pi\<^sub>E I F'"
    and "i \<in> I"
  shows "F i \<subseteq> F' i"
proof
  fix x
  assume "x \<in> F i"
  with ne have "\<forall>j. \<exists>y. (j \<in> I \<longrightarrow> y \<in> F j \<and> (i = j \<longrightarrow> x = y)) \<and> (j \<notin> I \<longrightarrow> y = undefined)"
    by auto
  from choice[OF this] obtain f
    where f: " \<forall>j. (j \<in> I \<longrightarrow> f j \<in> F j \<and> (i = j \<longrightarrow> x = f j)) \<and> (j \<notin> I \<longrightarrow> f j = undefined)" ..
  then have "f \<in> Pi\<^sub>E I F"
    by (auto simp: extensional_def PiE_def)
  then have "f \<in> Pi\<^sub>E I F'"
    using assms by simp
  then show "x \<in> F' i"
    using f \<open>i \<in> I\<close> by (auto simp: PiE_def)
qed

lemma PiE_eq_iff_not_empty:
  assumes ne: "\<And>i. i \<in> I \<Longrightarrow> F i \<noteq> {}" "\<And>i. i \<in> I \<Longrightarrow> F' i \<noteq> {}"
  shows "Pi\<^sub>E I F = Pi\<^sub>E I F' \<longleftrightarrow> (\<forall>i\<in>I. F i = F' i)"
proof (intro iffI ballI)
  fix i
  assume eq: "Pi\<^sub>E I F = Pi\<^sub>E I F'"
  assume i: "i \<in> I"
  show "F i = F' i"
    using PiE_eq_subset[of I F F', OF ne eq i]
    using PiE_eq_subset[of I F' F, OF ne(2,1) eq[symmetric] i]
    by auto
qed (auto simp: PiE_def)

lemma PiE_eq_iff:
  "Pi\<^sub>E I F = Pi\<^sub>E I F' \<longleftrightarrow> (\<forall>i\<in>I. F i = F' i) \<or> ((\<exists>i\<in>I. F i = {}) \<and> (\<exists>i\<in>I. F' i = {}))"
proof (intro iffI disjCI)
  assume eq[simp]: "Pi\<^sub>E I F = Pi\<^sub>E I F'"
  assume "\<not> ((\<exists>i\<in>I. F i = {}) \<and> (\<exists>i\<in>I. F' i = {}))"
  then have "(\<forall>i\<in>I. F i \<noteq> {}) \<and> (\<forall>i\<in>I. F' i \<noteq> {})"
    using PiE_eq_empty_iff[of I F] PiE_eq_empty_iff[of I F'] by auto
  with PiE_eq_iff_not_empty[of I F F'] show "\<forall>i\<in>I. F i = F' i"
    by auto
next
  assume "(\<forall>i\<in>I. F i = F' i) \<or> (\<exists>i\<in>I. F i = {}) \<and> (\<exists>i\<in>I. F' i = {})"
  then show "Pi\<^sub>E I F = Pi\<^sub>E I F'"
    using PiE_eq_empty_iff[of I F] PiE_eq_empty_iff[of I F'] by (auto simp: PiE_def)
qed

lemma extensional_funcset_fun_upd_restricts_rangeI:
  "\<forall>y \<in> S. f x \<noteq> f y \<Longrightarrow> f \<in> (insert x S) \<rightarrow>\<^sub>E T \<Longrightarrow> f(x := undefined) \<in> S \<rightarrow>\<^sub>E (T - {f x})"
  unfolding extensional_funcset_def extensional_def
  apply auto
  apply (case_tac "x = xa")
  apply auto
  done

lemma extensional_funcset_fun_upd_extends_rangeI:
  assumes "a \<in> T" "f \<in> S \<rightarrow>\<^sub>E (T - {a})"
  shows "f(x := a) \<in> insert x S \<rightarrow>\<^sub>E  T"
  using assms unfolding extensional_funcset_def extensional_def by auto

subsubsection \<open>Injective Extensional Function Spaces\<close>

lemma extensional_funcset_fun_upd_inj_onI:
  assumes "f \<in> S \<rightarrow>\<^sub>E (T - {a})"
    and "inj_on f S"
  shows "inj_on (f(x := a)) S"
  using assms
  unfolding extensional_funcset_def by (auto intro!: inj_on_fun_updI)

lemma extensional_funcset_extend_domain_inj_on_eq:
  assumes "x \<notin> S"
  shows "{f. f \<in> (insert x S) \<rightarrow>\<^sub>E T \<and> inj_on f (insert x S)} =
    (\<lambda>(y, g). g(x:=y)) ` {(y, g). y \<in> T \<and> g \<in> S \<rightarrow>\<^sub>E (T - {y}) \<and> inj_on g S}"
  using assms
  apply (auto del: PiE_I PiE_E)
  apply (auto intro: extensional_funcset_fun_upd_inj_onI
    extensional_funcset_fun_upd_extends_rangeI del: PiE_I PiE_E)
  apply (auto simp add: image_iff inj_on_def)
  apply (rule_tac x="xa x" in exI)
  apply (auto intro: PiE_mem del: PiE_I PiE_E)
  apply (rule_tac x="xa(x := undefined)" in exI)
  apply (auto intro!: extensional_funcset_fun_upd_restricts_rangeI)
  apply (auto dest!: PiE_mem split: split_if_asm)
  done

lemma extensional_funcset_extend_domain_inj_onI:
  assumes "x \<notin> S"
  shows "inj_on (\<lambda>(y, g). g(x := y)) {(y, g). y \<in> T \<and> g \<in> S \<rightarrow>\<^sub>E (T - {y}) \<and> inj_on g S}"
  using assms
  apply (auto intro!: inj_onI)
  apply (metis fun_upd_same)
  apply (metis assms PiE_arb fun_upd_triv fun_upd_upd)
  done

subsubsection \<open>Cardinality\<close>

lemma finite_PiE: "finite S \<Longrightarrow> (\<And>i. i \<in> S \<Longrightarrow> finite (T i)) \<Longrightarrow> finite (\<Pi>\<^sub>E i \<in> S. T i)"
  by (induct S arbitrary: T rule: finite_induct) (simp_all add: PiE_insert_eq)

lemma inj_combinator: "x \<notin> S \<Longrightarrow> inj_on (\<lambda>(y, g). g(x := y)) (T x \<times> Pi\<^sub>E S T)"
proof (safe intro!: inj_onI ext)
  fix f y g z
  assume "x \<notin> S"
  assume fg: "f \<in> Pi\<^sub>E S T" "g \<in> Pi\<^sub>E S T"
  assume "f(x := y) = g(x := z)"
  then have *: "\<And>i. (f(x := y)) i = (g(x := z)) i"
    unfolding fun_eq_iff by auto
  from this[of x] show "y = z" by simp
  fix i from *[of i] \<open>x \<notin> S\<close> fg show "f i = g i"
    by (auto split: split_if_asm simp: PiE_def extensional_def)
qed

lemma card_PiE: "finite S \<Longrightarrow> card (\<Pi>\<^sub>E i \<in> S. T i) = (\<Prod> i\<in>S. card (T i))"
proof (induct rule: finite_induct)
  case empty
  then show ?case by auto
next
  case (insert x S)
  then show ?case
    by (simp add: PiE_insert_eq inj_combinator card_image card_cartesian_product)
qed

end


(*  Title:      HOL/ex/PER.thy
    Author:     Oscar Slotosch and Markus Wenzel, TU Muenchen
*)

section \<open>Partial equivalence relations\<close>

theory PER
imports MainRLT
begin

text \<open>
  Higher-order quotients are defined over partial equivalence
  relations (PERs) instead of total ones.  We provide axiomatic type
  classes \<open>equiv < partial_equiv\<close> and a type constructor
  \<open>'a quot\<close> with basic operations.  This development is based
  on:

  Oscar Slotosch: \emph{Higher Order Quotients and their
  Implementation in Isabelle HOL.}  Elsa L. Gunter and Amy Felty,
  editors, Theorem Proving in Higher Order Logics: TPHOLs '97,
  Springer LNCS 1275, 1997.
\<close>

subsection \<open>Partial equivalence\<close>

text \<open>
  Type class \<open>partial_equiv\<close> models partial equivalence
  relations (PERs) using the polymorphic \<open>\<sim> :: 'a \<Rightarrow> 'a \<Rightarrow>
  bool\<close> relation, which is required to be symmetric and transitive,
  but not necessarily reflexive.
\<close>

class partial_equiv =
  fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"    (infixl "\<sim>" 50)
  assumes partial_equiv_sym [elim?]: "x \<sim> y \<Longrightarrow> y \<sim> x"
  assumes partial_equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"

text \<open>
  \medskip The domain of a partial equivalence relation is the set of
  reflexive elements.  Due to symmetry and transitivity this
  characterizes exactly those elements that are connected with
  \emph{any} other one.
\<close>

definition
  "domain" :: "'a::partial_equiv set" where
  "domain = {x. x \<sim> x}"

lemma domainI [intro]: "x \<sim> x \<Longrightarrow> x \<in> domain"
  unfolding domain_def by blast

lemma domainD [dest]: "x \<in> domain \<Longrightarrow> x \<sim> x"
  unfolding domain_def by blast

theorem domainI' [elim?]: "x \<sim> y \<Longrightarrow> x \<in> domain"
proof
  assume xy: "x \<sim> y"
  also from xy have "y \<sim> x" ..
  finally show "x \<sim> x" .
qed

subsection \<open>Equivalence on function spaces\<close>

text \<open>
  The \<open>\<sim>\<close> relation is lifted to function spaces.  It is
  important to note that this is \emph{not} the direct product, but a
  structural one corresponding to the congruence property.
\<close>

instantiation "fun" :: (partial_equiv, partial_equiv) partial_equiv
begin

definition "f \<sim> g \<longleftrightarrow> (\<forall>x \<in> domain. \<forall>y \<in> domain. x \<sim> y \<longrightarrow> f x \<sim> g y)"

lemma partial_equiv_funI [intro?]:
    "(\<And>x y. x \<in> domain \<Longrightarrow> y \<in> domain \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g y) \<Longrightarrow> f \<sim> g"
  unfolding eqv_fun_def by blast

lemma partial_equiv_funD [dest?]:
    "f \<sim> g \<Longrightarrow> x \<in> domain \<Longrightarrow> y \<in> domain \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g y"
  unfolding eqv_fun_def by blast

text \<open>
  The class of partial equivalence relations is closed under function
  spaces (in \emph{both} argument positions).
\<close>

instance proof
  fix f g h :: "'a::partial_equiv \<Rightarrow> 'b::partial_equiv"
  assume fg: "f \<sim> g"
  show "g \<sim> f"
  proof
    fix x y :: 'a
    assume x: "x \<in> domain" and y: "y \<in> domain"
    assume "x \<sim> y" then have "y \<sim> x" ..
    with fg y x have "f y \<sim> g x" ..
    then show "g x \<sim> f y" ..
  qed
  assume gh: "g \<sim> h"
  show "f \<sim> h"
  proof
    fix x y :: 'a
    assume x: "x \<in> domain" and y: "y \<in> domain" and "x \<sim> y"
    with fg have "f x \<sim> g y" ..
    also from y have "y \<sim> y" ..
    with gh y y have "g y \<sim> h y" ..
    finally show "f x \<sim> h y" .
  qed
qed

end

subsection \<open>Total equivalence\<close>

text \<open>
  The class of total equivalence relations on top of PERs.  It
  coincides with the standard notion of equivalence, i.e.\ \<open>\<sim>
  :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close> is required to be reflexive, transitive and
  symmetric.
\<close>

class equiv =
  assumes eqv_refl [intro]: "x \<sim> x"

text \<open>
  On total equivalences all elements are reflexive, and congruence
  holds unconditionally.
\<close>

theorem equiv_domain [intro]: "(x::'a::equiv) \<in> domain"
proof
  show "x \<sim> x" ..
qed

theorem equiv_cong [dest?]: "f \<sim> g \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g (y::'a::equiv)"
proof -
  assume "f \<sim> g"
  moreover have "x \<in> domain" ..
  moreover have "y \<in> domain" ..
  moreover assume "x \<sim> y"
  ultimately show ?thesis ..
qed

subsection \<open>Quotient types\<close>

text \<open>
  The quotient type \<open>'a quot\<close> consists of all
  \emph{equivalence classes} over elements of the base type \<^typ>\<open>'a\<close>.
\<close>

definition "quot = {{x. a \<sim> x}| a::'a::partial_equiv. True}"

typedef (overloaded) 'a quot = "quot :: 'a::partial_equiv set set"
  unfolding quot_def by blast

lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
  unfolding quot_def by blast

lemma quotE [elim]: "R \<in> quot \<Longrightarrow> (\<And>a. R = {x. a \<sim> x} \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding quot_def by blast

text \<open>
  \medskip Abstracted equivalence classes are the canonical
  representation of elements of a quotient type.
\<close>

definition eqv_class :: "('a::partial_equiv) \<Rightarrow> 'a quot"  ("\<lfloor>_\<rfloor>")
  where "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"

theorem quot_rep: "\<exists>a. A = \<lfloor>a\<rfloor>"
proof (cases A)
  fix R assume R: "A = Abs_quot R"
  assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
  with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
  then show ?thesis by (unfold eqv_class_def)
qed

lemma quot_cases [cases type: quot]:
  obtains (rep) a where "A = \<lfloor>a\<rfloor>"
  using quot_rep by blast

subsection \<open>Equality on quotients\<close>

text \<open>
  Equality of canonical quotient elements corresponds to the original
  relation as follows.
\<close>

theorem eqv_class_eqI [intro]: "a \<sim> b \<Longrightarrow> \<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
proof -
  assume ab: "a \<sim> b"
  have "{x. a \<sim> x} = {x. b \<sim> x}"
  proof (rule Collect_cong)
    fix x show "a \<sim> x \<longleftrightarrow> b \<sim> x"
    proof
      from ab have "b \<sim> a" ..
      also assume "a \<sim> x"
      finally show "b \<sim> x" .
    next
      note ab
      also assume "b \<sim> x"
      finally show "a \<sim> x" .
    qed
  qed
  then show ?thesis by (simp only: eqv_class_def)
qed

theorem eqv_class_eqD' [dest?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<Longrightarrow> a \<in> domain \<Longrightarrow> a \<sim> b"
proof (unfold eqv_class_def)
  assume "Abs_quot {x. a \<sim> x} = Abs_quot {x. b \<sim> x}"
  then have "{x. a \<sim> x} = {x. b \<sim> x}" by (simp only: Abs_quot_inject quotI)
  moreover assume "a \<in> domain" then have "a \<sim> a" ..
  ultimately have "a \<in> {x. b \<sim> x}" by blast
  then have "b \<sim> a" by blast
  then show "a \<sim> b" ..
qed

theorem eqv_class_eqD [dest?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<Longrightarrow> a \<sim> (b::'a::equiv)"
proof (rule eqv_class_eqD')
  show "a \<in> domain" ..
qed

lemma eqv_class_eq' [simp]: "a \<in> domain \<Longrightarrow> \<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> b"
  using eqv_class_eqI eqv_class_eqD' by (blast del: eqv_refl)

lemma eqv_class_eq [simp]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> (b::'a::equiv)"
  using eqv_class_eqI eqv_class_eqD by blast

subsection \<open>Picking representing elements\<close>

definition pick :: "'a::partial_equiv quot \<Rightarrow> 'a"
  where "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"

theorem pick_eqv' [intro?, simp]: "a \<in> domain \<Longrightarrow> pick \<lfloor>a\<rfloor> \<sim> a"
proof (unfold pick_def)
  assume a: "a \<in> domain"
  show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
  proof (rule someI2)
    show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
    fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
    from this and a have "a \<sim> x" ..
    then show "x \<sim> a" ..
  qed
qed

theorem pick_eqv [intro, simp]: "pick \<lfloor>a\<rfloor> \<sim> (a::'a::equiv)"
proof (rule pick_eqv')
  show "a \<in> domain" ..
qed

theorem pick_inverse: "\<lfloor>pick A\<rfloor> = (A::'a::equiv quot)"
proof (cases A)
  fix a assume a: "A = \<lfloor>a\<rfloor>"
  then have "pick A \<sim> a" by simp
  then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" by simp
  with a show ?thesis by simp
qed

end


(*  Title:       Countable Ordinals

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

header {* Ordinal Induction *}

theory OrdinalInduct
imports OrdinalDef
begin

subsection {* Zero and successor ordinals *}

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

lemma less_oSuc[iff]: "x < oSuc x"
by (unfold oSuc_def, rule oStrictLimit_ub)

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

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

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

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

instance ..

end

subsubsection {* Derived properties of 0 and oSuc *}

lemma less_oSuc_eq_le: "(x < oSuc y) = (x \<le> y)"
 apply (rule iffI)
  apply (erule contrapos_pp, simp add: linorder_not_less linorder_not_le)
  apply (erule oSuc_leI)
 apply (erule order_le_less_trans[OF _ less_oSuc])
done

lemma ordinal_0_le [iff]: "0 \<le> (x::ordinal)"
by (unfold ordinal_zero_def, rule oZero_least)

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)"
 apply (rule iffI)
  apply (simp add: less_oSuc_eq_le order_less_le_trans[OF less_oSuc])
 apply (erule order_le_less_trans[OF oSuc_leI less_oSuc])
done

lemma oSuc_eq_oSuc [iff]: "(oSuc x = oSuc y) = (x = y)"
by (safe, erule contrapos_pp, simp add: linorder_neq_iff)

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 {* Strict monotonicity *}

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"
 apply (rule strict_monoI)
 apply (drule Suc_leI)
 apply (drule le_add_diff_inverse)
 apply (subgoal_tac "\<forall>k. f A < f (Suc A + k)")
  apply (erule subst, erule spec)
 apply (rule allI, induct_tac k, simp)
 apply (erule order_less_trans, simp)
done

lemma mono_natI:
fixes f :: "nat \<Rightarrow> 'a::order"
shows "(\<And>n. f n \<le> f (Suc n)) \<Longrightarrow> mono f"
 apply (rule monoI)
 apply (drule le_add_diff_inverse)
 apply (subgoal_tac "\<forall>k. f x \<le> f (x + k)")
  apply (erule subst, erule spec)
 apply (rule allI, induct_tac k, simp)
 apply (erule order_trans, simp)
done

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)"
 apply safe
 apply (rule_tac x=x and y=y in linorder_cases)
   apply (drule strict_monoD, assumption, simp)
  apply assumption
 apply (drule strict_monoD, assumption, simp)
done

lemma strict_mono_cancel_less:
fixes f :: "'a::linorder \<Rightarrow> 'b::linorder"
shows "strict_mono f \<Longrightarrow> (f x < f y) = (x < y)"
 apply safe
  apply (rule_tac x=x and y=y in linorder_cases)
    apply assumption
   apply simp
  apply (drule strict_monoD, assumption, simp)
 apply (simp add: strict_monoD)
done

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)"
 apply (auto simp add: order_le_less)
   apply (simp add: strict_mono_cancel_less)
  apply (simp add: strict_mono_cancel_eq)
 apply (simp add: strict_monoD)
done

subsection {* Limit ordinals *}

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"
 apply (unfold oLimit_def)
 apply (erule Least_le)
done

lemma le_oLimit [iff]: "f n \<le> oLimit f"
 apply (unfold oLimit_def)
 apply (rule_tac x=n in spec)
 apply (rule_tac k="oStrictLimit f" in LeastI)
 apply (clarify, rule order_less_imp_le)
 apply (rule oStrictLimit_ub)
done

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"
 apply (unfold oLimit_def)
 apply (drule not_less_Least)
 apply (simp add: linorder_not_le)
done

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"
 apply (rule order_antisym[OF _ le_oLimit])
 apply (rule oLimit_leI, simp)
done

lemma strict_mono_less_oLimit:
"strict_mono f \<Longrightarrow> f n < oLimit f"
 apply (rule order_less_le_trans)
  apply (erule strict_monoD, rule lessI)
 apply (rule le_oLimit)
done

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"
 apply atomize
 apply (rule order_antisym)
  apply (rule oLimit_leI, clarify)
  apply (drule spec, erule exE, erule le_oLimitI)
 apply (rule oLimit_leI, clarify)
 apply (drule spec, erule exE, erule le_oLimitI)
done

lemma oLimit_Suc:
"f 0 < oLimit f \<Longrightarrow> oLimit (\<lambda>n. f (Suc n)) = oLimit f"
 apply (rule oLimit_eqI)
  apply (rule exI, rule order_refl)
 apply (case_tac n)
  apply (drule less_oLimitD, clarify, rename_tac m)
  apply (case_tac m, simp)
  apply (rule_tac x=nat in exI)
  apply (simp add: order_less_imp_le)
 apply (rule_tac x=nat in exI, simp)
done

lemma oLimit_shift:
"\<forall>n. f n < oLimit f \<Longrightarrow> oLimit (\<lambda>n. f (n + k)) = oLimit f"
 apply (induct_tac k, simp, rename_tac k)
 apply (simp only: add_Suc_right add_Suc[symmetric])
 apply (rule trans[OF oLimit_Suc], simp_all)
done

lemma oLimit_shift_mono:
"mono f \<Longrightarrow> oLimit (\<lambda>n. f (n + k)) = oLimit f"
 apply (rule oLimit_eqI)
  apply (rule exI, rule order_refl)
 apply (rule_tac x=n in exI)
 apply (erule monoD, simp)
done

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)"
 apply (rule iffI)
  apply (erule order_less_trans[OF less_oSuc])
 apply (simp add: linorder_not_le[symmetric])
 apply (erule contrapos_nn)
 apply (auto simp add: order_le_less less_oSuc_eq_le)
done

lemma limit_ordinal_oLimitI:
"\<forall>n. f n < oLimit f \<Longrightarrow> limit_ordinal (oLimit f)"
 apply (unfold limit_ordinal_def, simp)
 apply (rule conjI)
  apply (rule order_le_less_trans[OF ordinal_0_le])
  apply (erule spec)
 apply (clarsimp simp add: less_oSuc_eq_le)
 apply (drule oLimit_leI)
 apply (simp add: linorder_not_less[symmetric])
done

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

lemma limit_ordinalI:
"\<lbrakk>0 < z; \<forall>x<z. oSuc x < z\<rbrakk> \<Longrightarrow> limit_ordinal z"
 apply (erule contrapos_pp)
 apply (unfold limit_ordinal_def, clarsimp)
 apply (drule_tac x=y in spec, clarsimp)
done

subsubsection {* Making strict monotonic sequences *}

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)
 apply (drule not_less_Least)
 apply (simp add: linorder_not_less)
 apply (erule order_le_less_trans)
 apply (rule LeastI)
 apply (erule f_make_mono_less)
done

lemma make_mono_less:
"\<forall>n. f n < oLimit f \<Longrightarrow> make_mono f n < make_mono f (Suc n)"
 apply (frule_tac n=n in f_make_mono_less)
 apply (rule ccontr, simp only: linorder_not_less)
 apply (drule le_f_make_mono, assumption)
 apply (simp add: linorder_not_less[symmetric])
done

declare make_mono.simps [simp del]

lemma oLimit_make_mono_eq:
"\<forall>n. f n < oLimit f \<Longrightarrow> oLimit (\<lambda>n. f (make_mono f n)) = oLimit f"
 apply (rule oLimit_eqI, force)
 apply (rule_tac x=n in exI)
 apply (rule le_f_make_mono, assumption)
 apply (induct_tac n, simp)
 apply (rule Suc_leI)
 apply (erule order_le_less_trans)
 apply (erule make_mono_less)
done

subsection {* Induction principle for ordinals *}

lemma oLimit_le_oStrictLimit: "oLimit f \<le> oStrictLimit f"
 apply (rule oLimit_leI, clarify)
 apply (rule order_less_imp_le)
 apply (rule oStrictLimit_ub)
done

lemma oLimit_induct:
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 (drule less_oStrictLimitD, clarify)
  apply (subgoal_tac "oStrictLimit f = oSuc (f n)", simp add: suc)
  apply (rule order_antisym)
   apply (rule oStrictLimit_lub, clarify)
   apply (simp add: less_oSuc_eq_le)
   apply (erule order_trans[OF le_oLimit])
  apply (rule oSuc_leI, rule oStrictLimit_ub)
 apply (subgoal_tac "\<forall>n. f n < oLimit f")
  apply (subgoal_tac "P (oLimit (\<lambda>n. f (make_mono f n)))")
   apply (simp add: oLimit_make_mono_eq)
  apply (rule lim)
   apply (erule strict_mono_f_make_mono)
  apply simp
 apply (simp add: oStrictLimit_ub)
done

lemma ordinal_cases:
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


theory Mult
  imports Main Add
begin

thm nat.induct
print_statement nat.induct

(*  mult: \<nat> \<times> \<nat> \<rightarrow> \<nat>  *)
(*  requer \<top>  *)
(*  garante mult(x, y) = x \<^emph> y  *)
(*  mult (x, y) = 0, se y = 0  *)
(*  mult (x, y) = x + mult (x, y − 1), se y > 0  *)

primrec mult::"nat \<Rightarrow> nat \<Rightarrow> nat"
where
  mult01: "mult x 0 = 0"|
  mult02: "mult x (Suc y) = add x (mult x y)"

value "mult 2 2"
value "mult 1 2"
value "mult 2 0"
value "mult 0 1"

(*  \<forall>x \<in> \<nat>. \<forall>y \<in> \<nat>: mult(x, y) = x \<^emph> y  *)
theorem multT1:"\<forall>x. mult x y = x * y"
proof(induct y)
  show "\<forall>x. mult x 0 = x * 0"
  proof (rule allI)
    fix x0::nat
    have "mult x0 0 = 0" by (simp only:mult01)
    also have "... = x0 * 0" by (simp only:algebra)
    finally show "mult x0 0 = x0 * 0" by simp
  qed
next
  fix y0::nat
  assume HIP:"\<forall>x. mult x y0 = x * y0"
  show "\<forall>x. mult x (Suc y0) = x * (Suc y0)"
  proof (rule allI)
    fix x0::nat
    have "mult x0 (Suc y0) = add x0 (mult x0 y0)" by (simp only:mult02)
    also have "... = x0 + (mult x0 y0)" by (simp only:addT1)
    also have "... = x0 + x0 * y0" by (simp only:HIP)
    also have "... = x0 * (y0 + 1)" by algebra
    also have "... = x0 * (Suc y0)" by simp
    finally show "mult x0 (Suc y0) = x0 * (Suc y0)" by simp
  qed
qed

(*  \<forall>x \<in> \<nat>. \<forall>y \<in> \<nat>: mult(x, y) = mult(y, x)  *)
theorem multT2:"\<forall>x. mult x y = mult y x"
proof(induct y)
  show "\<forall>x. mult x 0 = mult 0 x"
  proof (rule allI)
    fix x0::nat
    have "mult x0 0 = 0" by (simp only:mult01)
    also have "... = 0 * x0" by (simp only:algebra)
    also have "... = mult 0 x0" by (simp only:multT1)
    finally show "mult x0 0 = mult 0 x0" by simp
  qed
next
  fix y0::nat
  assume HIP:"\<forall>x. mult x y0 = mult y0 x"
  show "\<forall>x. mult x (Suc y0) = mult (Suc y0) x"
  proof (rule allI)
    fix x0::nat
    have "mult x0 (Suc y0) = add x0 (mult x0 y0)" by (simp only:mult02)
    also have "... = x0 + (mult x0 y0)" by (simp only:addT1)
    also have "... = x0 + x0 * y0" by (simp only:multT1)
    also have "... = x0 * (y0 + 1)" by algebra
    also have "... = x0 * (Suc y0)" by simp
    also have "... = (Suc y0) * x0" by simp
    also have "... = mult (Suc y0) x0" by (simp only:multT1)
    finally show "mult x0 (Suc y0) = mult (Suc y0) x0" by simp
  qed
qed

(*  \<forall>x \<in> \<nat>: mult(1, x) = x  *)
theorem multT4:"mult 1 x = x"
proof(induct x)
  show "mult 1 0 = 0"
  proof -
    show "mult 1 0 = 0" by (simp only:mult01)
  qed
next
  fix x0::nat
  assume HIP:"mult 1 x0 = x0"
  show "mult 1 (Suc x0) = Suc x0"
  proof -
    have "mult 1 (Suc x0) = add 1 (mult 1  x0)" by (simp only:mult02)
    also have "... = add 1 x0" by (simp only:HIP)
    also have "... = Suc x0" by (simp only:addT0)
    finally show "mult 1 (Suc x0) = Suc x0" by simp
  qed
qed

(*  \<forall>x \<in> \<nat>: mult(x, 1) = x  *)
theorem multT3:"mult x 1 = x"
proof(induct x)
  show "mult 0 1 = 0"
  proof -
    have "mult 0 1 = 0 * 1" by (simp only:multT1)
    also have "... = 0" by arith
    finally show "mult 0 1 = 0" by simp
  qed
next
  fix x0::nat
  assume HIP:"mult x0 1 = x0"
  show "mult (Suc x0) 1 = Suc x0"
  proof -
    have "mult (Suc x0) 1 = mult 1 (Suc x0)" by (simp only:multT2)
    also have "... = Suc x0" by (simp only:multT4)
    finally show "mult (Suc x0) 1 = Suc x0" by simp
  qed
qed

(*  \<forall>x \<in> \<nat>. \<forall>y \<in> \<nat>. \<forall>z \<in> \<nat>: mult(x, mult(y, z)) = mult(mult(x, y), z)  *)
theorem multT5:"\<forall>x. \<forall>y. mult x (mult y z) = mult (mult x y) z"
proof(induction z)
  show "\<forall>x. \<forall>y. mult x (mult y 0) = mult (mult x y) 0"
  proof(rule allI, rule allI)
    fix x0::nat and y0::nat
    have "mult x0 (mult y0 0) = mult x0 0" by (simp only:mult01)
    also have "... = mult (mult x0 y0) 0" by (simp only:mult01)
    finally show "mult x0 (mult y0 0) = mult (mult x0 y0) 0" by simp
  qed
next
  fix z0::nat
  assume HI:"\<forall>x y. mult x (mult y z0) = mult (mult x y) z0"
  show "\<forall>x y. mult x (mult y (Suc z0)) = mult (mult x y) (Suc z0)"
  proof(rule allI, rule allI)
    fix x0::nat and y0::nat
    have "mult x0 (mult y0 (Suc z0)) = x0 * (mult y0 (Suc z0))" by (simp only:multT1)
    also have "... = x0 * y0 * (Suc z0)" by (simp only:multT1)
    also have "... = mult x0 y0 * (Suc z0)" by (simp only:multT1)
    also have "... = mult (mult x0 y0) (Suc z0)" by (simp only:multT1)
    finally show "mult x0 (mult y0 (Suc z0)) = mult (mult x0 y0) (Suc z0)" by simp
  qed
qed


theory BExp imports AExp begin

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)"|
"less n\<^sub>1 n\<^sub>2 = Less n\<^sub>1 n\<^sub>2"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and n\<^sub>1 n\<^sub>2 = And n\<^sub>1 n\<^sub>2"

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply auto
done

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc v) = Bc(\<not> v)" |
"not b = Not b"

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction )
apply auto
done

text \<open>Now the overall optimizer:\<close>

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"

theorem "bval (bsimp b) s = bval b s"
apply(induction b)
apply auto
  done

end


theory Baby
imports Main

begin

 (* fun conj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"conj True True = True" |
"conj _ _ = False"

 fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

lemma add_02: "add m 0 = m"
apply(induction m)
apply(auto)
done

lemma add_03 [simp]: "add 0 m = m"
(* apply(induction m) *)
apply(auto)
done

(* double function *)
(* fun double :: "nat => nat" where
"double 0 = 0" |
"double (Suc m) = Suc(m) + Suc(m)"

lemma double_2 [simp]: "double m = add m m"
apply(induction m)
apply (auto)
done *)

(* we can now compute it *)
value "add 5 0"

thm add_02

(* datatype 'a list = Nil | Cons 'a " 'a list" *)

fun app :: "'a list => 'a list => 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list => 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

lemma app_Nil2: "app xs Nil = xs"
apply(induction xs)
apply(auto)
done

lemma app_assoc [simp]: "app (app xs ys) zs = app xs (app ys zs)"
apply(induction xs)
apply(auto)
done

fun map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
"map f Nil = Nil" |
"map f (Cons x xs) = Cons (f x ) (map f xs)"

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count [] _ = 0" |
  "count (x#xs) x' = (if x = x' then Suc (count xs x') else count xs x')"

value "count [(1::nat), 1, 1] 1"

theorem "count xs x \<le> length xs"
  apply(induct xs)
   apply auto
  done

fun sum_upto :: "nat \<Rightarrow> nat " where
"sum_upto 0 = 0" |
"sum_upto n = n + sum_upto (n - 1)"

value "sum_upto 4"

lemma sum_up_to: "sum_upto n = (n * (n+1)) div 2 "
apply(induction n)
apply(auto)
done

thm sum_up_to

(*  tree/mirror *)
datatype 'a tree = Tip | Node "'a tree" 'a " 'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
    "mirror Tip = Tip" |
    "mirror (Node l a r ) = Node (mirror r ) a (mirror l)"

lemma "mirror (mirror t) = t"
apply(induction t)
apply(auto)
done

datatype 'a option = None | Some 'a *)

fun lookup :: "('a * 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup [] x = None" |
"lookup ((a,b) # ps) x = (if a = x then Some b else lookup ps x )"

fun div2 :: "nat \<Rightarrow> nat" where
"div2 0 = 0" |
"div2 (Suc 0) = 0" |
"div2 (Suc(Suc n)) = Suc(div2 n)"

value "div2 2"

lemma "div2 n = n div 2"
apply(induction n rule: div2.induct)
apply(auto)
done

fun intersperse:: "'a => 'a list => 'a list" where
    "intersperse a [] = []" |
    "intersperse _ [x] = [x]" |
    "intersperse a (x#xs) = x#a#(intersperse a xs)"
(* it works too: `"intersperse a (Cons x xs) = [x,a]@(intersperse a xs)"` *)

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
apply(induction xs rule: intersperse.induct)
apply(auto)
done

value "intersperse 9 [1::nat,2,3,4,5]"

end


theory Projection
imports Main
begin

(* Projection of an event list onto a subset of the events *)
definition projection:: "'e list \<Rightarrow> 'e set \<Rightarrow> 'e list" (infixl "\<upharpoonleft>" 100)
where
"l \<upharpoonleft> E \<equiv> filter (\<lambda>x . x \<in> E) l"

(* If projecting on Y yields the empty sequence, then projecting
  on X \<union> Y yields the projection on X. *)
lemma projection_on_union:
  "l \<upharpoonleft> Y = [] \<Longrightarrow> l \<upharpoonleft> (X \<union> Y) = l \<upharpoonleft> X"
proof (induct l)
  case Nil show ?case by (simp add: projection_def)
next
  case (Cons a b) show ?case
  proof (cases "a \<in> Y")
    case True from Cons show "a \<in> Y \<Longrightarrow> (a # b) \<upharpoonleft> (X \<union> Y) = (a # b) \<upharpoonleft> X"
      by (simp add: projection_def)
  next
    case False from Cons show "a \<notin> Y \<Longrightarrow> (a # b) \<upharpoonleft> (X \<union> Y) = (a # b) \<upharpoonleft> X"
      by (simp add: projection_def)
  qed
qed

(*projection on the empty trace yields the empty trace*)
lemma projection_on_empty_trace: "[] \<upharpoonleft> X =[]" by (simp add: projection_def)

(*projection to the empty set yields the empty trace*)
lemma projection_to_emptyset_is_empty_trace: "l \<upharpoonleft>{} = []" by (simp add: projection_def)

(*projection is idempotent*)
lemma projection_idempotent: "l \<upharpoonleft> X= (l \<upharpoonleft>X) \<upharpoonleft>X" by (simp add: projection_def)

(*empty projection implies that the trace contains no events of the set the trace is projected to*)
lemma projection_empty_implies_absence_of_events: "l \<upharpoonleft> X = [] \<Longrightarrow>  X \<inter> (set l) = {}"
 by (metis empty_set inter_set_filter projection_def)

(*subsequently projecting to two disjoint sets yields the empty trace*)
lemma disjoint_projection: "X \<inter> Y = {} \<Longrightarrow> (l \<upharpoonleft> X) \<upharpoonleft> Y = []"
proof -
  assume X_Y_disjoint: "X \<inter> Y = {}"
  show "(l \<upharpoonleft> X) \<upharpoonleft> Y = []" unfolding projection_def
  proof (induct l)
    case Nil show ?case by simp
  next
    case (Cons x xs) show ?case
    proof (cases "x \<in> X")
      case True
      with X_Y_disjoint have "x \<notin> Y" by auto
      thus "[x\<leftarrow>[x\<leftarrow>x # xs . x \<in> X] . x \<in> Y] = []" using Cons.hyps by auto
    next
      case False show "[x\<leftarrow>[x\<leftarrow>x # xs . x \<in> X] . x \<in> Y] = []" using Cons.hyps False by auto
    qed
  qed
qed

(* auxiliary lemmas for projection *)
lemma projection_concatenation_commute:
  "(l1 @ l2) \<upharpoonleft> X = (l1 \<upharpoonleft> X) @ (l2 \<upharpoonleft> X)"
  by (unfold projection_def, auto)

(* Lists that are equal under projection on a set will remain
equal under projection on a subset. *)
lemma projection_subset_eq_from_superset_eq:
"((xs \<upharpoonleft> (X \<union> Y)) = (ys \<upharpoonleft> (X \<union> Y))) \<Longrightarrow> ((xs \<upharpoonleft> X) = (ys \<upharpoonleft> X))"
(is "(?L1 = ?L2) \<Longrightarrow> (?L3 = ?L4)")
proof -
  assume prem: "?L1 = ?L2"
  have "?L1 \<upharpoonleft> X = ?L3 \<and> ?L2 \<upharpoonleft> X = ?L4"
  proof -
    have "\<And> a. ((a \<in> X \<or> a \<in> Y) \<and> a \<in> X) = (a \<in> X)"
      by auto
    thus ?thesis
      by (simp add: projection_def)
  qed
  with prem show ?thesis
    by auto
qed

(* All elements of a list l are in a set X if and only if
 the projection of l onto X yields l. *)
lemma list_subset_iff_projection_neutral: "(set l \<subseteq> X) = ((l \<upharpoonleft> X) = l)"
(is "?A = ?B")
proof -
  have "?A \<Longrightarrow> ?B"
    proof -
      assume "?A"
      hence "\<And>x. x \<in> (set l) \<Longrightarrow> x \<in> X"
        by auto
      thus ?thesis
        by (simp add: projection_def)
    qed
  moreover
  have "?B \<Longrightarrow> ?A"
    proof -
      assume "?B"
      hence "(set (l \<upharpoonleft> X)) = set l"
        by (simp add: projection_def)
      thus ?thesis
        by (simp add: projection_def, auto)
    qed
  ultimately show ?thesis ..
qed

(* If the projection of \<tau> onto a set X is not the empty trace, then
there is x \<in> X that is the last occurrence of all elements of X in \<tau>.
\<tau> can then be split around x.

Expressing non-emptiness in terms of list length is quite useful
for inductive proofs. *)
lemma projection_split_last: "Suc n = length (\<tau> \<upharpoonleft> X) \<Longrightarrow>
\<exists> \<beta> x \<alpha>. (x \<in> X \<and> \<tau> = \<beta> @ [x] @ \<alpha> \<and> \<alpha> \<upharpoonleft> X = [] \<and> n = length ((\<beta> @ \<alpha>) \<upharpoonleft> X))"
proof -
  assume Suc_n_is_len_\<tau>X: "Suc n = length (\<tau> \<upharpoonleft> X)"

  let ?L = "\<tau> \<upharpoonleft> X"
  let ?RL = "filter (\<lambda>x . x \<in> X) (rev \<tau>)"

  have "Suc n = length ?RL"
  proof -
    have "rev ?L = ?RL"
      by (simp add: projection_def, rule rev_filter)
    hence "rev (rev ?L) = rev ?RL" ..
    hence "?L = rev ?RL"
      by auto
    with Suc_n_is_len_\<tau>X show ?thesis
      by auto
  qed
  with Suc_length_conv[of n ?RL] obtain x xs
    where "?RL = x # xs"
    by auto
  hence "x # xs = ?RL"
    by auto

  from Cons_eq_filterD[OF this] obtain rev\<alpha> rev\<beta>
    where "(rev \<tau>) = rev\<alpha> @ x # rev\<beta>"
    and rev\<alpha>_no_x: "\<forall>a \<in> set rev\<alpha>. a \<notin> X"
    and x_in_X: "x \<in> X"
    by auto
  hence "rev (rev \<tau>) = rev (rev\<alpha> @ x # rev\<beta>)"
    by auto
  hence "\<tau> = (rev rev\<beta>) @ [x] @ (rev rev\<alpha>)"
    by auto
  then obtain \<beta> \<alpha>
    where \<tau>_is_\<beta>x\<alpha>: "\<tau> = \<beta> @ [x] @ \<alpha>"
    and \<alpha>_is_revrev\<alpha>: "\<alpha> = (rev rev\<alpha>)"
    and \<beta>_is_revrev\<beta>: "\<beta> = (rev rev\<beta>)"
    by auto
  hence \<alpha>_no_x: "\<alpha> \<upharpoonleft> X = []"
  proof -
    from \<alpha>_is_revrev\<alpha> rev\<alpha>_no_x have "\<forall>a \<in> set \<alpha>. a \<notin> X"
      by auto
    thus ?thesis
      by (simp add: projection_def)
  qed

  have "n = length ((\<beta> @ \<alpha>) \<upharpoonleft> X)"
  proof -
    from \<alpha>_no_x have \<alpha>X_zero_len: "length (\<alpha> \<upharpoonleft> X) = 0"
      by auto

    from x_in_X have xX_one_len: "length ([x] \<upharpoonleft> X) = 1"
      by (simp add: projection_def)

    from \<tau>_is_\<beta>x\<alpha> have "length ?L = length (\<beta> \<upharpoonleft> X) + length ([x] \<upharpoonleft> X) + length (\<alpha> \<upharpoonleft> X)"
      by (simp add: projection_def)
    with \<alpha>X_zero_len have "length ?L = length (\<beta> \<upharpoonleft> X) + length ([x] \<upharpoonleft> X)"
      by auto
    with xX_one_len Suc_n_is_len_\<tau>X have "n = length (\<beta> \<upharpoonleft> X)"
      by auto
    with \<alpha>X_zero_len show ?thesis
      by (simp add: projection_def)
  qed
  with x_in_X \<tau>_is_\<beta>x\<alpha> \<alpha>_no_x show ?thesis
    by auto
qed

lemma projection_rev_commute:
  "rev (l \<upharpoonleft> X) = (rev l) \<upharpoonleft> X"
  by (induct l, simp add: projection_def, simp add: projection_def)

(* Same as the previous lemma except that we split around the FIRST
    occurrence.

    Note that we do not express non-emptiness via the length function
    simply because there is no need for it in the theories relying on
    this lemma. *)

  from rev\<tau>_is_\<beta>'x'\<alpha>' have "rev (rev \<tau>) = rev (\<beta>' @ [x'] @ \<alpha>')" ..
  hence \<tau>_is_rev\<alpha>'_x'_rev\<beta>':"\<tau> = rev \<alpha>' @ [x'] @ rev \<beta>'"
    by auto
  moreover
  from \<alpha>'X_empty have rev\<alpha>'X_empty: "rev \<alpha>' \<upharpoonleft> X = []"
    by (metis projection_rev_commute rev_is_Nil_conv)
  moreover
  note x'_in_X
  ultimately have "(\<tau> \<upharpoonleft> X) = x' # ((rev \<beta>') \<upharpoonleft> X)"
    by (simp only: projection_concatenation_commute projection_def, auto)
  with \<tau>X_is_x_xs have "x = x'"
    by auto
  with \<tau>_is_rev\<alpha>'_x'_rev\<beta>' have \<tau>_is_rev\<alpha>'_x_rev\<beta>': "\<tau> = rev \<alpha>' @ [x] @ rev \<beta>'"
    by auto
  with rev\<alpha>'X_empty show ?thesis
    by auto
qed

(* this lemma extends the previous lemma by also concluding that the suffix of the splitted trace
   projected is equal to the projection of the initial trace without the first element *)
lemma projection_split_first_with_suffix:
  "\<lbrakk> (\<tau> \<upharpoonleft> X) = x # xs \<rbrakk> \<Longrightarrow> \<exists> \<alpha> \<beta>. (\<tau> = \<alpha> @ [x] @ \<beta> \<and> \<alpha> \<upharpoonleft> X = [] \<and> \<beta> \<upharpoonleft> X = xs)"
proof -
  assume tau_proj_X: "(\<tau> \<upharpoonleft> X) = x # xs"
  show ?thesis
  proof -
    from   tau_proj_X have x_in_X: "x \<in> X"
      by (metis IntE inter_set_filter list.set_intros(1) projection_def)
    from  tau_proj_X have  "\<exists> \<alpha> \<beta>. \<tau> = \<alpha> @ [x] @ \<beta> \<and> \<alpha> \<upharpoonleft> X = []"
      using projection_split_first by auto
    then obtain \<alpha> \<beta> where tau_split: "\<tau> = \<alpha> @ [x] @ \<beta>"
                      and X_empty_prefix:"\<alpha> \<upharpoonleft> X = []"
      by auto
    from tau_split tau_proj_X  have  "(\<alpha> @ [x] @ \<beta>) \<upharpoonleft> X =x # xs"
      by auto
    with  X_empty_prefix have  "([x] @ \<beta>) \<upharpoonleft> X =x # xs"
      by (simp add: projection_concatenation_commute)
    hence "(x # \<beta>) \<upharpoonleft> X =x # xs"
      by auto
    with  x_in_X have "\<beta> \<upharpoonleft> X = xs"
      unfolding projection_def by simp
    with  tau_split X_empty_prefix show ?thesis
      by auto
  qed
qed

lemma projection_split_arbitrary_element:
  "\<lbrakk>\<tau> \<upharpoonleft> X = (\<alpha> @ [x] @ \<beta>) \<upharpoonleft> X; x \<in> X \<rbrakk>
      \<Longrightarrow> \<exists> \<alpha>' \<beta>'. (\<tau> = \<alpha>' @ [x] @ \<beta>' \<and> \<alpha>' \<upharpoonleft> X = \<alpha> \<upharpoonleft> X \<and> \<beta>' \<upharpoonleft> X = \<beta> \<upharpoonleft> X)"
proof -
  assume "\<tau> \<upharpoonleft> X = (\<alpha> @ [x] @ \<beta>) \<upharpoonleft> X"
  and  " x \<in> X"
  {
    fix n
    have "\<lbrakk>\<tau> \<upharpoonleft> X = (\<alpha> @ [x] @ \<beta>) \<upharpoonleft> X; x \<in> X; n = length(\<alpha>\<upharpoonleft>X) \<rbrakk>
          \<Longrightarrow> \<exists> \<alpha>' \<beta>'. (\<tau> = \<alpha>' @ [x] @ \<beta>' \<and> \<alpha>' \<upharpoonleft> X = \<alpha> \<upharpoonleft> X \<and> \<beta>' \<upharpoonleft> X = \<beta> \<upharpoonleft> X)"
    proof (induct n arbitrary: \<tau> \<alpha> )
      case 0
      hence "\<alpha>\<upharpoonleft>X = []"
        unfolding projection_def by simp
      with "0.prems"(1) "0.prems"(2) have "\<tau>\<upharpoonleft>X = x # \<beta>\<upharpoonleft>X"
        unfolding projection_def by simp
      with \<open>\<alpha>\<upharpoonleft>X = []\<close> show ?case
        using projection_split_first_with_suffix by fastforce
    next
      case (Suc n)
      from "Suc.prems"(1) have "\<tau>\<upharpoonleft>X=\<alpha>\<upharpoonleft>X @ ([x] @ \<beta>) \<upharpoonleft>X"
        using projection_concatenation_commute by auto
      from "Suc.prems"(3) obtain x' xs' where "\<alpha> \<upharpoonleft>X= x' #xs'"
                                            and "x' \<in> X"
        by (metis filter_eq_ConsD length_Suc_conv projection_def)
      then obtain a\<^sub>1 a\<^sub>2 where "\<alpha> = a\<^sub>1 @ [x'] @ a\<^sub>2"
                         and "a\<^sub>1\<upharpoonleft>X = []"
                         and "a\<^sub>2\<upharpoonleft>X = xs'"
        using projection_split_first_with_suffix by metis
      with \<open>x' \<in> X\<close> "Suc.prems"(1) have "\<tau>\<upharpoonleft>X= x' #  (a\<^sub>2 @ [x] @ \<beta>) \<upharpoonleft>X"
        unfolding projection_def by simp
      then obtain t\<^sub>1 t\<^sub>2 where "\<tau>= t\<^sub>1 @ [x'] @ t\<^sub>2"
                         and "t\<^sub>1\<upharpoonleft>X = []"
                         and "t\<^sub>2\<upharpoonleft>X = (a\<^sub>2 @ [x] @ \<beta>) \<upharpoonleft>X"
        using projection_split_first_with_suffix by metis
      from Suc.prems(3) \<open>\<alpha> \<upharpoonleft>X= x' # xs'\<close> \<open>\<alpha> = a\<^sub>1 @ [x'] @ a\<^sub>2\<close> \<open>a\<^sub>1\<upharpoonleft>X = []\<close> \<open>a\<^sub>2\<upharpoonleft>X = xs'\<close>
      have "n=length(a\<^sub>2\<upharpoonleft>X)"
        by auto
      with "Suc.hyps"(1) "Suc.prems"(2) \<open>t\<^sub>2\<upharpoonleft>X = (a\<^sub>2 @ [x] @ \<beta>) \<upharpoonleft>X\<close>
        obtain t\<^sub>2' t\<^sub>3' where "t\<^sub>2=t\<^sub>2' @ [x] @ t\<^sub>3'"
                         and "t\<^sub>2'\<upharpoonleft>X = a\<^sub>2\<upharpoonleft>X"
                         and "t\<^sub>3'\<upharpoonleft>X = \<beta>\<upharpoonleft>X"
          using projection_concatenation_commute by blast

      let ?\<alpha>'="t\<^sub>1 @ [x'] @ t\<^sub>2'" and ?\<beta>'="t\<^sub>3'"
      from \<open>\<tau>= t\<^sub>1 @ [x'] @ t\<^sub>2\<close> \<open>t\<^sub>2=t\<^sub>2' @ [x] @ t\<^sub>3'\<close> have "\<tau>=?\<alpha>'@[x]@?\<beta>'"
        by auto
      moreover
      from  \<open>\<alpha> \<upharpoonleft>X= x' # xs'\<close>  \<open>t\<^sub>1\<upharpoonleft>X = []\<close> \<open>x' \<in> X\<close> \<open>t\<^sub>2'\<upharpoonleft>X = a\<^sub>2\<upharpoonleft>X\<close> \<open>a\<^sub>2\<upharpoonleft>X = xs'\<close>
      have "?\<alpha>'\<upharpoonleft>X = \<alpha>\<upharpoonleft>X"
        using projection_concatenation_commute unfolding projection_def by simp
      ultimately
      show ?case using \<open>t\<^sub>3'\<upharpoonleft>X = \<beta>\<upharpoonleft>X\<close>
        by blast
    qed
  }
  with \<open>\<tau> \<upharpoonleft> X = (\<alpha> @ [x] @ \<beta>) \<upharpoonleft> X\<close> \<open> x \<in> X\<close> show ?thesis
    by simp
qed

(* If the projection of a list l onto a set X is empty, it
    will remain empty when projecting further. *)
lemma projection_on_intersection: "l \<upharpoonleft> X = [] \<Longrightarrow> l \<upharpoonleft> (X \<inter> Y) = []"
(is "?L1 = [] \<Longrightarrow> ?L2 = []")
proof -
  assume "?L1 = []"
  hence "set ?L1 = {}"
    by simp
  moreover
  have "set ?L2 \<subseteq> set ?L1"
    by (simp add: projection_def, auto)
  ultimately have "set ?L2 = {}"
    by auto
  thus ?thesis
    by auto
qed

(* The previous lemma expressed with subsets. *)
lemma projection_on_subset: "\<lbrakk> Y \<subseteq> X; l \<upharpoonleft> X = [] \<rbrakk> \<Longrightarrow> l \<upharpoonleft> Y = []"
proof -
  assume subset: "Y \<subseteq> X"
  assume proj_empty: "l \<upharpoonleft> X = []"
  hence "l \<upharpoonleft> (X \<inter> Y) = []"
    by (rule projection_on_intersection)
  moreover
  from subset have "X \<inter> Y = Y"
    by auto
  ultimately show ?thesis
    by auto
qed

(* Another variant that is used in proofs of BSP compositionality theorems. *)
lemma projection_on_subset2: "\<lbrakk> set l \<subseteq> L; l \<upharpoonleft> X' = []; X \<inter> L \<subseteq> X' \<rbrakk> \<Longrightarrow> l \<upharpoonleft> X = []"
proof -
  assume setl_subset_L: "set l \<subseteq> L"
  assume l_no_X': "l \<upharpoonleft> X' = []"
  assume X_inter_L_subset_X': "X \<inter> L \<subseteq> X'"

  from X_inter_L_subset_X' l_no_X' have "l \<upharpoonleft> (X \<inter> L) = []"
    by (rule projection_on_subset)
  moreover
  have "l \<upharpoonleft> (X \<inter> L) = (l \<upharpoonleft> L) \<upharpoonleft> X"
    by (simp add: Int_commute projection_def)
  moreover
  note setl_subset_L
  ultimately show ?thesis
    by (simp add: list_subset_iff_projection_neutral)
qed

(*If the projection of two lists l1 and l2  onto a set Y is equal then its also equal for all X \<subseteq> Y*)
lemma non_empty_projection_on_subset: "X \<subseteq> Y \<and> l\<^sub>1 \<upharpoonleft> Y = l\<^sub>2 \<upharpoonleft> Y \<Longrightarrow>  l\<^sub>1 \<upharpoonleft> X = l\<^sub>2 \<upharpoonleft> X"
  by (metis projection_subset_eq_from_superset_eq subset_Un_eq)

(* Intersecting a projection set with a list's elements does not change the result
    of the projection. *)
lemma projection_intersection_neutral: "(set l \<subseteq> X) \<Longrightarrow> (l \<upharpoonleft> (X \<inter> Y) = l \<upharpoonleft> Y)"
proof -
  assume "set l \<subseteq> X"
  hence "(l \<upharpoonleft> X) = l"
    by (simp add: list_subset_iff_projection_neutral)
  hence "(l \<upharpoonleft> X) \<upharpoonleft> Y = l \<upharpoonleft> Y"
    by simp
  moreover
  have "(l \<upharpoonleft> X) \<upharpoonleft> Y = l \<upharpoonleft> (X \<inter> Y)"
    by (simp add: projection_def)
  ultimately show ?thesis
    by simp
qed

lemma projection_commute:
  "(l \<upharpoonleft> X) \<upharpoonleft> Y = (l \<upharpoonleft> Y) \<upharpoonleft> X"
  by (simp add: projection_def conj_commute)

lemma projection_subset_elim: "Y \<subseteq> X \<Longrightarrow> (l \<upharpoonleft> X) \<upharpoonleft> Y = l \<upharpoonleft> Y"
by (simp only: projection_def, metis Diff_subset list_subset_iff_projection_neutral
    minus_coset_filter order_trans projection_commute projection_def)

lemma projection_sequence: "(xs \<upharpoonleft> X) \<upharpoonleft> Y = (xs \<upharpoonleft> (X \<inter> Y))"
by (metis Int_absorb inf_sup_ord(1) list_subset_iff_projection_neutral
    projection_intersection_neutral projection_subset_elim)

(* This function yields a possible interleaving for given
  traces t1 and t2.
  The set A (B) shall denote the the set of events for t1 (t2).
  Non-synchronization events in trace t1 are prioritized. *)
fun merge :: "'e set \<Rightarrow> 'e set \<Rightarrow> 'e list \<Rightarrow> 'e list \<Rightarrow> 'e list"
where
"merge A B [] t2 = t2" |
"merge A B t1 [] = t1" |
"merge A B (e1 # t1') (e2 # t2') = (if e1 = e2 then
                                          e1 # (merge A B t1' t2')
                                        else (if e1 \<in> (A \<inter> B) then
                                               e2 # (merge A B (e1 # t1') t2')
                                             else e1 # (merge A B t1' (e2 # t2'))))"

(* If two traces can be interleaved, then merge yields such an interleaving  *)
lemma merge_property: "\<lbrakk>set t1 \<subseteq> A; set t2 \<subseteq> B; t1 \<upharpoonleft> B = t2 \<upharpoonleft> A \<rbrakk>
  \<Longrightarrow> let t = (merge A B t1 t2) in (t \<upharpoonleft> A = t1 \<and> t \<upharpoonleft> B = t2 \<and> set t \<subseteq> ((set t1) \<union> (set t2)))"
unfolding Let_def
proof (induct A B t1 t2 rule: merge.induct)
  case (1 A B t2) thus ?case
    by (metis Un_empty_left empty_subsetI list_subset_iff_projection_neutral
      merge.simps(1) set_empty subset_iff_psubset_eq)
next
  case (2 A B t1) thus ?case
    by (metis Un_empty_right empty_subsetI list_subset_iff_projection_neutral
      merge.simps(2) set_empty subset_refl)
next
  case (3 A B e1 t1' e2 t2') thus ?case
  proof (cases)
    assume e1_is_e2: "e1 = e2"

    note e1_is_e2
    moreover
    from 3(4) have "set t1' \<subseteq> A"
      by auto
    moreover
    from 3(5) have "set t2' \<subseteq> B"
      by auto
    moreover
    from e1_is_e2 3(4-6) have "t1' \<upharpoonleft> B = t2' \<upharpoonleft> A"
      by (simp add: projection_def)
    moreover
    note 3(1)
    ultimately have ind1: "merge A B t1' t2' \<upharpoonleft> A = t1'"
      and ind2: "merge A B t1' t2' \<upharpoonleft> B = t2'"
      and ind3: "set (merge A B t1' t2') \<subseteq> (set t1') \<union> (set t2')"
      by auto

    from e1_is_e2 have merge_eq:
      "merge A B (e1 # t1') (e2 # t2') = e1 # (merge A B t1' t2')"
      by auto

    from 3(4) ind1 have goal1:
      "merge A B (e1 # t1') (e2 # t2') \<upharpoonleft> A = e1 # t1'"
      by (simp only: merge_eq projection_def, auto)
    moreover
    from e1_is_e2 3(5) ind2 have goal2:
      "merge A B (e1 # t1') (e2 # t2') \<upharpoonleft> B = e2 # t2'"
      by (simp only: merge_eq projection_def, auto)
    moreover
    from ind3 have goal3:
      "set (merge A B (e1 # t1') (e2 # t2')) \<subseteq> set (e1 # t1') \<union> set (e2 # t2')"
      by (simp only: merge_eq, auto)
    ultimately show ?thesis
      by auto (* case (3 e1 t1' e2 t2') for e1 = e2 *)
  next
    assume e1_isnot_e2: "e1 \<noteq> e2"
    show ?thesis
    proof (cases)
      assume e1_in_A_inter_B: "e1 \<in> A \<inter> B"

      from 3(6) e1_isnot_e2 e1_in_A_inter_B have e2_notin_A: "e2 \<notin> A"
        by (simp add: projection_def, auto)

      note e1_isnot_e2 e1_in_A_inter_B 3(4)
      moreover
      from 3(5) have "set t2' \<subseteq> B"
        by auto
      moreover
      from 3(6) e1_isnot_e2 e1_in_A_inter_B have "(e1 # t1') \<upharpoonleft> B = t2' \<upharpoonleft> A"
        by (simp add: projection_def, auto)
      moreover
      note 3(2)
      ultimately have ind1: "merge A B (e1 # t1') t2' \<upharpoonleft> A = (e1 # t1')"
        and ind2: "merge A B (e1 # t1') t2' \<upharpoonleft> B = t2'"
        and ind3: "set (merge A B (e1 # t1') t2') \<subseteq> set (e1 # t1') \<union> set t2'"
        by auto

      from e1_isnot_e2 e1_in_A_inter_B
      have merge_eq:
        "merge A B (e1 # t1') (e2 # t2') = e2 # (merge A B (e1 # t1') t2')"
        by auto

      from e1_isnot_e2 ind1 e2_notin_A have goal1:
        "merge A B (e1 # t1') (e2 # t2') \<upharpoonleft> A = e1 # t1'"
        by (simp only: merge_eq projection_def, auto)
      moreover
      from 3(5) ind2 have goal2: "merge A B (e1 # t1') (e2 # t2') \<upharpoonleft> B = e2 # t2'"
        by (simp only: merge_eq projection_def, auto)
      moreover
      from 3(5) ind3 have goal3:
        "set (merge A B (e1 # t1') (e2 # t2')) \<subseteq> set (e1 # t1') \<union> set (e2 # t2')"
        by (simp only: merge_eq, auto)
      ultimately show ?thesis
        by auto (* case (3 e1 t1' e2 t2') for e1 \<noteq> e2 e1 \<in> A \<inter> B *)
    next
      assume e1_notin_A_inter_B: "e1 \<notin> A \<inter> B"

      from 3(4) e1_notin_A_inter_B have e1_notin_B: "e1 \<notin> B"
        by auto

      note e1_isnot_e2 e1_notin_A_inter_B
      moreover
      from 3(4) have "set t1' \<subseteq> A"
        by auto
      moreover
      note 3(5)
      moreover
      from 3(6) e1_notin_B have "t1' \<upharpoonleft> B = (e2 # t2') \<upharpoonleft> A"
        by (simp add: projection_def)
      moreover
      note 3(3)
      ultimately have ind1: "merge A B t1' (e2 # t2') \<upharpoonleft> A = t1'"
        and ind2: "merge A B t1' (e2 # t2') \<upharpoonleft> B = (e2 # t2')"
        and ind3: "set (merge A B t1' (e2 # t2')) \<subseteq> set t1' \<union> set (e2 # t2')"
        by auto

      from e1_isnot_e2 e1_notin_A_inter_B
      have merge_eq: "merge A B (e1 # t1') (e2 # t2') = e1 # (merge A B t1' (e2 # t2'))"
        by auto

      from 3(4) ind1 have goal1: "merge A B (e1 # t1') (e2 # t2') \<upharpoonleft> A = e1 # t1'"
        by (simp only: merge_eq projection_def, auto)
      moreover
      from ind2 e1_notin_B have goal2:
        "merge A B (e1 # t1') (e2 # t2') \<upharpoonleft> B = e2 # t2'"
        by (simp only: merge_eq projection_def, auto)
      moreover
      from 3(4) ind3 have goal3:
        "set (merge A B (e1 # t1') (e2 # t2')) \<subseteq> set (e1 # t1') \<union> set (e2 # t2')"
        by (simp only: merge_eq, auto)
      ultimately show ?thesis
        by auto (* case (3 e1 t1' e2 t2') for e1 \<noteq> e2 e1 \<notin> A \<inter> B *)
    qed
  qed
qed

end


theory de_morgan imports Main begin

text {*
  Proving De Morgan's Laws in zeroth and first order logic
*}

lemma "(\<not>(P\<or>Q)) = (\<not>P\<and>\<not>Q)"
  apply (rule iffI)
   apply(rule conjI)
    apply(rule classical)
    apply(erule notE)
    apply(rule disjI1)
    apply(rule classical)
    apply(erule notE)
    apply assumption
   apply(rule classical)
   apply(erule notE)
   apply(rule disjI2)
   apply(rule classical)
   apply(erule notE)
   apply assumption
  apply(erule conjE)
  apply (rule notI)
  apply(erule notE)
  apply(rule classical)
  apply(erule notE)
  apply(erule disjE)
   apply(erule notE)
   apply assumption
  apply assumption
  done

lemma "(\<not>(P\<and>Q)) = (\<not>P\<or>\<not>Q)"
    apply (rule iffI)
   apply (rule classical)
   apply (erule notE)
   apply (rule conjI)
    apply (rule classical)
    apply (erule notE)
    apply (rule disjI1)
    apply assumption
   apply (rule classical)
   apply (erule notE)
  apply (rule disjI2)
  apply assumption

  apply (rule notI)
  apply (erule conjE)
  apply (erule disjE)
  apply (erule notE,  assumption)+
  done
lemma "(\<not> (\<forall> x. P x)) = (\<exists> x. \<not> P x)"
  apply(rule iffI)
   apply(rule classical)
   apply(erule notE)
   apply(rule allI)
   apply(rule classical)
   apply(erule notE)
  apply(rule exI)
   apply assumption

  apply(erule exE)
  apply(rule notI)
  apply(erule allE)
  apply(erule notE)
  apply assumption
  done
lemma "(\<not> (\<exists> x. P x)) = (\<forall> x. \<not> P x)"
  apply(rule iffI)
   apply(rule allI)
   apply(rule classical)
   apply (erule notE)
   apply(rule exI)
   apply(rule classical)
   apply(erule notE)
   apply assumption
  apply (rule notI)
  apply (erule exE)
  apply (erule allE)
  apply (erule notE)
  apply assumption
  done


(*  Title:      HOL/Examples/Ackermann.thy
    Author:     Larry Paulson
*)

section \<open>A Tail-Recursive, Stack-Based Ackermann's Function\<close>

theory Ackermann imports MainRLT

begin

text\<open>This theory investigates a stack-based implementation of Ackermann's function.
Let's recall the traditional definition,
as modified by R{\'o}zsa P\'eter and Raphael Robinson.\<close>

fun ack :: "[nat,nat] \<Rightarrow> nat" where
  "ack 0 n             = Suc n"
| "ack (Suc m) 0       = ack m 1"
| "ack (Suc m) (Suc n) = ack m (ack (Suc m) n)"

text\<open>Here is the stack-based version, which uses lists.\<close>

function (domintros) ackloop :: "nat list \<Rightarrow> nat" where
  "ackloop (n # 0 # l)         = ackloop (Suc n # l)"
| "ackloop (0 # Suc m # l)     = ackloop (1 # m # l)"
| "ackloop (Suc n # Suc m # l) = ackloop (n # Suc m # m # l)"
| "ackloop [m] = m"
| "ackloop [] =  0"
  by pat_completeness auto

text\<open>
The key task is to prove termination. In the first recursive call, the head of the list gets bigger
while the list gets shorter, suggesting that the length of the list should be the primary
termination criterion. But in the third recursive call, the list gets longer. The idea of trying
a multiset-based termination argument is frustrated by the second recursive call when m = 0:
the list elements are simply permuted.

Fortunately, the function definition package allows us to define a function and only later identify its domain of termination.
Instead, it makes all the recursion equations conditional on satisfying
the function's domain predicate. Here we shall eventually be able
to show that the predicate is always satisfied.\<close>

text\<open>@{thm [display] ackloop.domintros[no_vars]}\<close>
declare ackloop.domintros [simp]

text \<open>Termination is trivial if the length of the list is less then two.
The following lemma is the key to proving termination for longer lists.\<close>
lemma "ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
proof (induction m arbitrary: n l)
  case 0
  then show ?case
    by auto
next
  case (Suc m)
  show ?case
    using Suc.prems
    by (induction n arbitrary: l) (simp_all add: Suc)
qed

text \<open>The proof above (which actually is unused) can be expressed concisely as follows.\<close>
lemma ackloop_dom_longer:
  "ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
  by (induction m n arbitrary: l rule: ack.induct) auto

lemma "ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
  by (induction m n arbitrary: l rule: ack.induct) auto

text\<open>This function codifies what @{term ackloop} is designed to do.
Proving the two functions equivalent also shows that @{term ackloop} can be used
to compute Ackermann's function.\<close>
fun acklist :: "nat list \<Rightarrow> nat" where
  "acklist (n#m#l) = acklist (ack m n # l)"
| "acklist [m] = m"
| "acklist [] =  0"

text\<open>The induction rule for @{term acklist} is @{thm [display] acklist.induct[no_vars]}.\<close>

lemma ackloop_dom: "ackloop_dom l"
  by (induction l rule: acklist.induct) (auto simp: ackloop_dom_longer)

termination ackloop
  by (simp add: ackloop_dom)

text\<open>This result is trivial even by inspection of the function definitions
(which faithfully follow the definition of Ackermann's function).
All that we needed was termination.\<close>
lemma ackloop_acklist: "ackloop l = acklist l"
  by (induction l rule: ackloop.induct) auto

theorem ack: "ack m n = ackloop [n,m]"
  by (simp add: ackloop_acklist)

end