(*  Title:      HOL/Relation.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory; Stefan Berghofer, TU Muenchen
*)

section {* Relations -- as sets of pairs, and binary predicates *}

theory Relation
imports Finite_Set
begin

text {* A preliminary: classical rules for reasoning on predicates *}

declare predicate1I [Pure.intro!, intro!]
declare predicate1D [Pure.dest, dest]
declare predicate2I [Pure.intro!, intro!]
declare predicate2D [Pure.dest, dest]
declare bot1E [elim!]
declare bot2E [elim!]
declare top1I [intro!]
declare top2I [intro!]
declare inf1I [intro!]
declare inf2I [intro!]
declare inf1E [elim!]
declare inf2E [elim!]
declare sup1I1 [intro?]
declare sup2I1 [intro?]
declare sup1I2 [intro?]
declare sup2I2 [intro?]
declare sup1E [elim!]
declare sup2E [elim!]
declare sup1CI [intro!]
declare sup2CI [intro!]
declare Inf1_I [intro!]
declare INF1_I [intro!]
declare Inf2_I [intro!]
declare INF2_I [intro!]
declare Inf1_D [elim]
declare INF1_D [elim]
declare Inf2_D [elim]
declare INF2_D [elim]
declare Inf1_E [elim]
declare INF1_E [elim]
declare Inf2_E [elim]
declare INF2_E [elim]
declare Sup1_I [intro]
declare SUP1_I [intro]
declare Sup2_I [intro]
declare SUP2_I [intro]
declare Sup1_E [elim!]
declare SUP1_E [elim!]
declare Sup2_E [elim!]
declare SUP2_E [elim!]

subsection {* Fundamental *}

subsubsection {* Relations as sets of pairs *}

type_synonym 'a rel = "('a * 'a) set"

lemma subrelI: -- {* Version of @{thm [source] subsetI} for binary relations *}
  "(\<And>x y. (x, y) \<in> r \<Longrightarrow> (x, y) \<in> s) \<Longrightarrow> r \<subseteq> s"
  by auto

lemma lfp_induct2: -- {* Version of @{thm [source] lfp_induct} for binary relations *}
  "(a, b) \<in> lfp f \<Longrightarrow> mono f \<Longrightarrow>
    (\<And>a b. (a, b) \<in> f (lfp f \<inter> {(x, y). P x y}) \<Longrightarrow> P a b) \<Longrightarrow> P a b"
  using lfp_induct_set [of "(a, b)" f "case_prod P"] by auto

subsubsection {* Conversions between set and predicate relations *}

lemma pred_equals_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) = (\<lambda>x. x \<in> S) \<longleftrightarrow> R = S"
  by (simp add: set_eq_iff fun_eq_iff)

lemma pred_equals_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) = (\<lambda>x y. (x, y) \<in> S) \<longleftrightarrow> R = S"
  by (simp add: set_eq_iff fun_eq_iff)

lemma pred_subset_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) \<le> (\<lambda>x. x \<in> S) \<longleftrightarrow> R \<subseteq> S"
  by (simp add: subset_iff le_fun_def)

lemma pred_subset_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) \<le> (\<lambda>x y. (x, y) \<in> S) \<longleftrightarrow> R \<subseteq> S"
  by (simp add: subset_iff le_fun_def)

lemma bot_empty_eq [pred_set_conv]: "\<bottom> = (\<lambda>x. x \<in> {})"
  by (auto simp add: fun_eq_iff)

lemma bot_empty_eq2 [pred_set_conv]: "\<bottom> = (\<lambda>x y. (x, y) \<in> {})"
  by (auto simp add: fun_eq_iff)

lemma top_empty_eq [pred_set_conv]: "\<top> = (\<lambda>x. x \<in> UNIV)"
  by (auto simp add: fun_eq_iff)

lemma top_empty_eq2 [pred_set_conv]: "\<top> = (\<lambda>x y. (x, y) \<in> UNIV)"
  by (auto simp add: fun_eq_iff)

lemma inf_Int_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) \<sqinter> (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<inter> S)"
  by (simp add: inf_fun_def)

lemma inf_Int_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) \<sqinter> (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<inter> S)"
  by (simp add: inf_fun_def)

lemma sup_Un_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) \<squnion> (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<union> S)"
  by (simp add: sup_fun_def)

lemma sup_Un_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) \<squnion> (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<union> S)"
  by (simp add: sup_fun_def)

lemma INF_INT_eq [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (\<Inter>i\<in>S. r i))"
  by (simp add: fun_eq_iff)

lemma INF_INT_eq2 [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (\<Inter>i\<in>S. r i))"
  by (simp add: fun_eq_iff)

lemma SUP_UN_eq [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (\<Union>i\<in>S. r i))"
  by (simp add: fun_eq_iff)

lemma SUP_UN_eq2 [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (\<Union>i\<in>S. r i))"
  by (simp add: fun_eq_iff)

lemma Inf_INT_eq [pred_set_conv]: "\<Sqinter>S = (\<lambda>x. x \<in> INTER S Collect)"
  by (simp add: fun_eq_iff)

lemma INF_Int_eq [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x. x \<in> i)) = (\<lambda>x. x \<in> \<Inter>S)"
  by (simp add: fun_eq_iff)

lemma Inf_INT_eq2 [pred_set_conv]: "\<Sqinter>S = (\<lambda>x y. (x, y) \<in> INTER (case_prod ` S) Collect)"
  by (simp add: fun_eq_iff)

lemma INF_Int_eq2 [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x y. (x, y) \<in> i)) = (\<lambda>x y. (x, y) \<in> \<Inter>S)"
  by (simp add: fun_eq_iff)

lemma Sup_SUP_eq [pred_set_conv]: "\<Squnion>S = (\<lambda>x. x \<in> UNION S Collect)"
  by (simp add: fun_eq_iff)

lemma SUP_Sup_eq [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x. x \<in> i)) = (\<lambda>x. x \<in> \<Union>S)"
  by (simp add: fun_eq_iff)

lemma Sup_SUP_eq2 [pred_set_conv]: "\<Squnion>S = (\<lambda>x y. (x, y) \<in> UNION (case_prod ` S) Collect)"
  by (simp add: fun_eq_iff)

lemma SUP_Sup_eq2 [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x y. (x, y) \<in> i)) = (\<lambda>x y. (x, y) \<in> \<Union>S)"
  by (simp add: fun_eq_iff)

subsection {* Properties of relations *}

subsubsection {* Reflexivity *}

definition refl_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> bool"
where
  "refl_on A r \<longleftrightarrow> r \<subseteq> A \<times> A \<and> (\<forall>x\<in>A. (x, x) \<in> r)"

abbreviation refl :: "'a rel \<Rightarrow> bool"
where -- {* reflexivity over a type *}
  "refl \<equiv> refl_on UNIV"

definition reflp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "reflp r \<longleftrightarrow> (\<forall>x. r x x)"

lemma reflp_refl_eq [pred_set_conv]:
  "reflp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> refl r"
  by (simp add: refl_on_def reflp_def)

lemma refl_onI: "r \<subseteq> A \<times> A ==> (!!x. x : A ==> (x, x) : r) ==> refl_on A r"
  by (unfold refl_on_def) (iprover intro!: ballI)

lemma refl_onD: "refl_on A r ==> a : A ==> (a, a) : r"
  by (unfold refl_on_def) blast

lemma refl_onD1: "refl_on A r ==> (x, y) : r ==> x : A"
  by (unfold refl_on_def) blast

lemma refl_onD2: "refl_on A r ==> (x, y) : r ==> y : A"
  by (unfold refl_on_def) blast

lemma reflpI:
  "(\<And>x. r x x) \<Longrightarrow> reflp r"
  by (auto intro: refl_onI simp add: reflp_def)

lemma reflpE:
  assumes "reflp r"
  obtains "r x x"
  using assms by (auto dest: refl_onD simp add: reflp_def)

lemma reflpD:
  assumes "reflp r"
  shows "r x x"
  using assms by (auto elim: reflpE)

lemma refl_on_Int: "refl_on A r ==> refl_on B s ==> refl_on (A \<inter> B) (r \<inter> s)"
  by (unfold refl_on_def) blast

lemma reflp_inf:
  "reflp r \<Longrightarrow> reflp s \<Longrightarrow> reflp (r \<sqinter> s)"
  by (auto intro: reflpI elim: reflpE)

lemma refl_on_Un: "refl_on A r ==> refl_on B s ==> refl_on (A \<union> B) (r \<union> s)"
  by (unfold refl_on_def) blast

lemma reflp_sup:
  "reflp r \<Longrightarrow> reflp s \<Longrightarrow> reflp (r \<squnion> s)"
  by (auto intro: reflpI elim: reflpE)

lemma refl_on_INTER:
  "ALL x:S. refl_on (A x) (r x) ==> refl_on (INTER S A) (INTER S r)"
  by (unfold refl_on_def) fast

lemma refl_on_UNION:
  "ALL x:S. refl_on (A x) (r x) \<Longrightarrow> refl_on (UNION S A) (UNION S r)"
  by (unfold refl_on_def) blast

lemma refl_on_empty [simp]: "refl_on {} {}"
  by (simp add:refl_on_def)

lemma refl_on_def' [nitpick_unfold, code]:
  "refl_on A r \<longleftrightarrow> (\<forall>(x, y) \<in> r. x \<in> A \<and> y \<in> A) \<and> (\<forall>x \<in> A. (x, x) \<in> r)"
  by (auto intro: refl_onI dest: refl_onD refl_onD1 refl_onD2)

subsubsection {* Irreflexivity *}

definition irrefl :: "'a rel \<Rightarrow> bool"
where
  "irrefl r \<longleftrightarrow> (\<forall>a. (a, a) \<notin> r)"

definition irreflp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "irreflp R \<longleftrightarrow> (\<forall>a. \<not> R a a)"

lemma irreflp_irrefl_eq [pred_set_conv]:
  "irreflp (\<lambda>a b. (a, b) \<in> R) \<longleftrightarrow> irrefl R"
  by (simp add: irrefl_def irreflp_def)

lemma irreflI:
  "(\<And>a. (a, a) \<notin> R) \<Longrightarrow> irrefl R"
  by (simp add: irrefl_def)

lemma irreflpI:
  "(\<And>a. \<not> R a a) \<Longrightarrow> irreflp R"
  by (fact irreflI [to_pred])

lemma irrefl_distinct [code]:
  "irrefl r \<longleftrightarrow> (\<forall>(a, b) \<in> r. a \<noteq> b)"
  by (auto simp add: irrefl_def)

subsubsection {* Asymmetry *}

inductive asym :: "'a rel \<Rightarrow> bool"
where
  asymI: "irrefl R \<Longrightarrow> (\<And>a b. (a, b) \<in> R \<Longrightarrow> (b, a) \<notin> R) \<Longrightarrow> asym R"

inductive asymp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where
  asympI: "irreflp R \<Longrightarrow> (\<And>a b. R a b \<Longrightarrow> \<not> R b a) \<Longrightarrow> asymp R"

lemma asymp_asym_eq [pred_set_conv]:
  "asymp (\<lambda>a b. (a, b) \<in> R) \<longleftrightarrow> asym R"
  by (auto intro!: asymI asympI elim: asym.cases asymp.cases simp add: irreflp_irrefl_eq)

subsubsection {* Symmetry *}

definition sym :: "'a rel \<Rightarrow> bool"
where
  "sym r \<longleftrightarrow> (\<forall>x y. (x, y) \<in> r \<longrightarrow> (y, x) \<in> r)"

definition symp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "symp r \<longleftrightarrow> (\<forall>x y. r x y \<longrightarrow> r y x)"

lemma symp_sym_eq [pred_set_conv]:
  "symp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> sym r"
  by (simp add: sym_def symp_def)

lemma symI:
  "(\<And>a b. (a, b) \<in> r \<Longrightarrow> (b, a) \<in> r) \<Longrightarrow> sym r"
  by (unfold sym_def) iprover

lemma sympI:
  "(\<And>a b. r a b \<Longrightarrow> r b a) \<Longrightarrow> symp r"
  by (fact symI [to_pred])

lemma symE:
  assumes "sym r" and "(b, a) \<in> r"
  obtains "(a, b) \<in> r"
  using assms by (simp add: sym_def)

lemma sympE:
  assumes "symp r" and "r b a"
  obtains "r a b"
  using assms by (rule symE [to_pred])

lemma symD:
  assumes "sym r" and "(b, a) \<in> r"
  shows "(a, b) \<in> r"
  using assms by (rule symE)

lemma sympD:
  assumes "symp r" and "r b a"
  shows "r a b"
  using assms by (rule symD [to_pred])

lemma sym_Int:
  "sym r \<Longrightarrow> sym s \<Longrightarrow> sym (r \<inter> s)"
  by (fast intro: symI elim: symE)

lemma symp_inf:
  "symp r \<Longrightarrow> symp s \<Longrightarrow> symp (r \<sqinter> s)"
  by (fact sym_Int [to_pred])

lemma sym_Un:
  "sym r \<Longrightarrow> sym s \<Longrightarrow> sym (r \<union> s)"
  by (fast intro: symI elim: symE)

lemma symp_sup:
  "symp r \<Longrightarrow> symp s \<Longrightarrow> symp (r \<squnion> s)"
  by (fact sym_Un [to_pred])

lemma sym_INTER:
  "\<forall>x\<in>S. sym (r x) \<Longrightarrow> sym (INTER S r)"
  by (fast intro: symI elim: symE)

lemma symp_INF:
  "\<forall>x\<in>S. symp (r x) \<Longrightarrow> symp (INFIMUM S r)"
  by (fact sym_INTER [to_pred])

lemma sym_UNION:
  "\<forall>x\<in>S. sym (r x) \<Longrightarrow> sym (UNION S r)"
  by (fast intro: symI elim: symE)

lemma symp_SUP:
  "\<forall>x\<in>S. symp (r x) \<Longrightarrow> symp (SUPREMUM S r)"
  by (fact sym_UNION [to_pred])

subsubsection {* Antisymmetry *}

definition antisym :: "'a rel \<Rightarrow> bool"
where
  "antisym r \<longleftrightarrow> (\<forall>x y. (x, y) \<in> r \<longrightarrow> (y, x) \<in> r \<longrightarrow> x = y)"

abbreviation antisymP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "antisymP r \<equiv> antisym {(x, y). r x y}"

lemma antisymI:
  "(!!x y. (x, y) : r ==> (y, x) : r ==> x=y) ==> antisym r"
  by (unfold antisym_def) iprover

lemma antisymD: "antisym r ==> (a, b) : r ==> (b, a) : r ==> a = b"
  by (unfold antisym_def) iprover

lemma antisym_subset: "r \<subseteq> s ==> antisym s ==> antisym r"
  by (unfold antisym_def) blast

lemma antisym_empty [simp]: "antisym {}"
  by (unfold antisym_def) blast

subsubsection {* Transitivity *}

definition trans :: "'a rel \<Rightarrow> bool"
where
  "trans r \<longleftrightarrow> (\<forall>x y z. (x, y) \<in> r \<longrightarrow> (y, z) \<in> r \<longrightarrow> (x, z) \<in> r)"

definition transp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "transp r \<longleftrightarrow> (\<forall>x y z. r x y \<longrightarrow> r y z \<longrightarrow> r x z)"

lemma transp_trans_eq [pred_set_conv]:
  "transp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> trans r"
  by (simp add: trans_def transp_def)

abbreviation transP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where -- {* FIXME drop *}
  "transP r \<equiv> trans {(x, y). r x y}"

lemma transI:
  "(\<And>x y z. (x, y) \<in> r \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> (x, z) \<in> r) \<Longrightarrow> trans r"
  by (unfold trans_def) iprover

lemma transpI:
  "(\<And>x y z. r x y \<Longrightarrow> r y z \<Longrightarrow> r x z) \<Longrightarrow> transp r"
  by (fact transI [to_pred])

lemma transE:
  assumes "trans r" and "(x, y) \<in> r" and "(y, z) \<in> r"
  obtains "(x, z) \<in> r"
  using assms by (unfold trans_def) iprover

lemma transpE:
  assumes "transp r" and "r x y" and "r y z"
  obtains "r x z"
  using assms by (rule transE [to_pred])

lemma transD:
  assumes "trans r" and "(x, y) \<in> r" and "(y, z) \<in> r"
  shows "(x, z) \<in> r"
  using assms by (rule transE)

lemma transpD:
  assumes "transp r" and "r x y" and "r y z"
  shows "r x z"
  using assms by (rule transD [to_pred])

lemma trans_Int:
  "trans r \<Longrightarrow> trans s \<Longrightarrow> trans (r \<inter> s)"
  by (fast intro: transI elim: transE)

lemma transp_inf:
  "transp r \<Longrightarrow> transp s \<Longrightarrow> transp (r \<sqinter> s)"
  by (fact trans_Int [to_pred])

lemma trans_INTER:
  "\<forall>x\<in>S. trans (r x) \<Longrightarrow> trans (INTER S r)"
  by (fast intro: transI elim: transD)

(* FIXME thm trans_INTER [to_pred] *)

lemma trans_join [code]:
  "trans r \<longleftrightarrow> (\<forall>(x, y1) \<in> r. \<forall>(y2, z) \<in> r. y1 = y2 \<longrightarrow> (x, z) \<in> r)"
  by (auto simp add: trans_def)

lemma transp_trans:
  "transp r \<longleftrightarrow> trans {(x, y). r x y}"
  by (simp add: trans_def transp_def)

subsubsection {* Totality *}

definition total_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> bool"
where
  "total_on A r \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x \<noteq> y \<longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r)"

abbreviation "total \<equiv> total_on UNIV"

lemma total_on_empty [simp]: "total_on {} r"
  by (simp add: total_on_def)

subsubsection {* Single valued relations *}

definition single_valued :: "('a \<times> 'b) set \<Rightarrow> bool"
where
  "single_valued r \<longleftrightarrow> (\<forall>x y. (x, y) \<in> r \<longrightarrow> (\<forall>z. (x, z) \<in> r \<longrightarrow> y = z))"

abbreviation single_valuedP :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool" where
  "single_valuedP r \<equiv> single_valued {(x, y). r x y}"

lemma single_valuedI:
  "ALL x y. (x,y):r --> (ALL z. (x,z):r --> y=z) ==> single_valued r"
  by (unfold single_valued_def)

lemma single_valuedD:
  "single_valued r ==> (x, y) : r ==> (x, z) : r ==> y = z"
  by (simp add: single_valued_def)

lemma single_valued_empty[simp]: "single_valued {}"
by(simp add: single_valued_def)

lemma single_valued_subset:
  "r \<subseteq> s ==> single_valued s ==> single_valued r"
  by (unfold single_valued_def) blast

subsection {* Relation operations *}

subsubsection {* The identity relation *}

definition Id :: "'a rel"
where
  [code del]: "Id = {p. \<exists>x. p = (x, x)}"

lemma IdI [intro]: "(a, a) : Id"
  by (simp add: Id_def)

lemma IdE [elim!]: "p : Id ==> (!!x. p = (x, x) ==> P) ==> P"
  by (unfold Id_def) (iprover elim: CollectE)

lemma pair_in_Id_conv [iff]: "((a, b) : Id) = (a = b)"
  by (unfold Id_def) blast

lemma refl_Id: "refl Id"
  by (simp add: refl_on_def)

lemma antisym_Id: "antisym Id"
  -- {* A strange result, since @{text Id} is also symmetric. *}
  by (simp add: antisym_def)

lemma sym_Id: "sym Id"
  by (simp add: sym_def)

lemma trans_Id: "trans Id"
  by (simp add: trans_def)

lemma single_valued_Id [simp]: "single_valued Id"
  by (unfold single_valued_def) blast

lemma irrefl_diff_Id [simp]: "irrefl (r - Id)"
  by (simp add:irrefl_def)

lemma trans_diff_Id: "trans r \<Longrightarrow> antisym r \<Longrightarrow> trans (r - Id)"
  unfolding antisym_def trans_def by blast

lemma total_on_diff_Id [simp]: "total_on A (r - Id) = total_on A r"
  by (simp add: total_on_def)

subsubsection {* Diagonal: identity over a set *}

definition Id_on  :: "'a set \<Rightarrow> 'a rel"
where
  "Id_on A = (\<Union>x\<in>A. {(x, x)})"

lemma Id_on_empty [simp]: "Id_on {} = {}"
  by (simp add: Id_on_def)

lemma Id_on_eqI: "a = b ==> a : A ==> (a, b) : Id_on A"
  by (simp add: Id_on_def)

lemma Id_onI [intro!]: "a : A ==> (a, a) : Id_on A"
  by (rule Id_on_eqI) (rule refl)

lemma Id_onE [elim!]:
  "c : Id_on A ==> (!!x. x : A ==> c = (x, x) ==> P) ==> P"
  -- {* The general elimination rule. *}
  by (unfold Id_on_def) (iprover elim!: UN_E singletonE)

lemma Id_on_iff: "((x, y) : Id_on A) = (x = y & x : A)"
  by blast

lemma Id_on_def' [nitpick_unfold]:
  "Id_on {x. A x} = Collect (\<lambda>(x, y). x = y \<and> A x)"
  by auto

lemma Id_on_subset_Times: "Id_on A \<subseteq> A \<times> A"
  by blast

lemma refl_on_Id_on: "refl_on A (Id_on A)"
  by (rule refl_onI [OF Id_on_subset_Times Id_onI])

lemma antisym_Id_on [simp]: "antisym (Id_on A)"
  by (unfold antisym_def) blast

lemma sym_Id_on [simp]: "sym (Id_on A)"
  by (rule symI) clarify

lemma trans_Id_on [simp]: "trans (Id_on A)"
  by (fast intro: transI elim: transD)

lemma single_valued_Id_on [simp]: "single_valued (Id_on A)"
  by (unfold single_valued_def) blast

subsubsection {* Composition *}

inductive_set relcomp  :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set" (infixr "O" 75)
  for r :: "('a \<times> 'b) set" and s :: "('b \<times> 'c) set"
where
  relcompI [intro]: "(a, b) \<in> r \<Longrightarrow> (b, c) \<in> s \<Longrightarrow> (a, c) \<in> r O s"

notation relcompp (infixr "OO" 75)

lemmas relcomppI = relcompp.intros

text {*
  For historic reasons, the elimination rules are not wholly corresponding.
  Feel free to consolidate this.
*}

inductive_cases relcompEpair: "(a, c) \<in> r O s"
inductive_cases relcomppE [elim!]: "(r OO s) a c"

lemma relcompE [elim!]: "xz \<in> r O s \<Longrightarrow>
  (\<And>x y z. xz = (x, z) \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> (y, z) \<in> s  \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases xz) (simp, erule relcompEpair, iprover)

lemma R_O_Id [simp]:
  "R O Id = R"
  by fast

lemma Id_O_R [simp]:
  "Id O R = R"
  by fast

lemma relcomp_empty1 [simp]:
  "{} O R = {}"
  by blast

lemma relcompp_bot1 [simp]:
  "\<bottom> OO R = \<bottom>"
  by (fact relcomp_empty1 [to_pred])

lemma relcomp_empty2 [simp]:
  "R O {} = {}"
  by blast

lemma relcompp_bot2 [simp]:
  "R OO \<bottom> = \<bottom>"
  by (fact relcomp_empty2 [to_pred])

lemma O_assoc:
  "(R O S) O T = R O (S O T)"
  by blast

lemma relcompp_assoc:
  "(r OO s) OO t = r OO (s OO t)"
  by (fact O_assoc [to_pred])

lemma trans_O_subset:
  "trans r \<Longrightarrow> r O r \<subseteq> r"
  by (unfold trans_def) blast

lemma transp_relcompp_less_eq:
  "transp r \<Longrightarrow> r OO r \<le> r "
  by (fact trans_O_subset [to_pred])

lemma relcomp_mono:
  "r' \<subseteq> r \<Longrightarrow> s' \<subseteq> s \<Longrightarrow> r' O s' \<subseteq> r O s"
  by blast

lemma relcompp_mono:
  "r' \<le> r \<Longrightarrow> s' \<le> s \<Longrightarrow> r' OO s' \<le> r OO s "
  by (fact relcomp_mono [to_pred])

lemma relcomp_subset_Sigma:
  "r \<subseteq> A \<times> B \<Longrightarrow> s \<subseteq> B \<times> C \<Longrightarrow> r O s \<subseteq> A \<times> C"
  by blast

lemma relcomp_distrib [simp]:
  "R O (S \<union> T) = (R O S) \<union> (R O T)"
  by auto

lemma relcompp_distrib [simp]:
  "R OO (S \<squnion> T) = R OO S \<squnion> R OO T"
  by (fact relcomp_distrib [to_pred])

lemma relcomp_distrib2 [simp]:
  "(S \<union> T) O R = (S O R) \<union> (T O R)"
  by auto

lemma relcompp_distrib2 [simp]:
  "(S \<squnion> T) OO R = S OO R \<squnion> T OO R"
  by (fact relcomp_distrib2 [to_pred])

lemma relcomp_UNION_distrib:
  "s O UNION I r = (\<Union>i\<in>I. s O r i) "
  by auto

(* FIXME thm relcomp_UNION_distrib [to_pred] *)

lemma relcomp_UNION_distrib2:
  "UNION I r O s = (\<Union>i\<in>I. r i O s) "
  by auto

(* FIXME thm relcomp_UNION_distrib2 [to_pred] *)

lemma single_valued_relcomp:
  "single_valued r \<Longrightarrow> single_valued s \<Longrightarrow> single_valued (r O s)"
  by (unfold single_valued_def) blast

lemma relcomp_unfold:
  "r O s = {(x, z). \<exists>y. (x, y) \<in> r \<and> (y, z) \<in> s}"
  by (auto simp add: set_eq_iff)

lemma relcompp_apply: "(R OO S) a c \<longleftrightarrow> (\<exists>b. R a b \<and> S b c)"
  unfolding relcomp_unfold [to_pred] ..

lemma eq_OO: "op= OO R = R"
by blast

subsubsection {* Converse *}

inductive_set converse :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'a) set" ("(_^-1)" [1000] 999)
  for r :: "('a \<times> 'b) set"
where
  "(a, b) \<in> r \<Longrightarrow> (b, a) \<in> r^-1"

notation (xsymbols)
  converse  ("(_\<inverse>)" [1000] 999)

notation
  conversep ("(_^--1)" [1000] 1000)

notation (xsymbols)
  conversep  ("(_\<inverse>\<inverse>)" [1000] 1000)

lemma converseI [sym]:
  "(a, b) \<in> r \<Longrightarrow> (b, a) \<in> r\<inverse>"
  by (fact converse.intros)

lemma conversepI (* CANDIDATE [sym] *):
  "r a b \<Longrightarrow> r\<inverse>\<inverse> b a"
  by (fact conversep.intros)

lemma converseD [sym]:
  "(a, b) \<in> r\<inverse> \<Longrightarrow> (b, a) \<in> r"
  by (erule converse.cases) iprover

lemma conversepD (* CANDIDATE [sym] *):
  "r\<inverse>\<inverse> b a \<Longrightarrow> r a b"
  by (fact converseD [to_pred])

lemma converseE [elim!]:
  -- {* More general than @{text converseD}, as it ``splits'' the member of the relation. *}
  "yx \<in> r\<inverse> \<Longrightarrow> (\<And>x y. yx = (y, x) \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases yx) (simp, erule converse.cases, iprover)

lemmas conversepE [elim!] = conversep.cases

lemma converse_iff [iff]:
  "(a, b) \<in> r\<inverse> \<longleftrightarrow> (b, a) \<in> r"
  by (auto intro: converseI)

lemma conversep_iff [iff]:
  "r\<inverse>\<inverse> a b = r b a"
  by (fact converse_iff [to_pred])

lemma converse_converse [simp]:
  "(r\<inverse>)\<inverse> = r"
  by (simp add: set_eq_iff)

lemma conversep_conversep [simp]:
  "(r\<inverse>\<inverse>)\<inverse>\<inverse> = r"
  by (fact converse_converse [to_pred])

lemma converse_empty[simp]: "{}\<inverse> = {}"
by auto

lemma converse_UNIV[simp]: "UNIV\<inverse> = UNIV"
by auto

lemma converse_relcomp: "(r O s)^-1 = s^-1 O r^-1"
  by blast

lemma converse_relcompp: "(r OO s)^--1 = s^--1 OO r^--1"
  by (iprover intro: order_antisym conversepI relcomppI
    elim: relcomppE dest: conversepD)

lemma converse_Int: "(r \<inter> s)^-1 = r^-1 \<inter> s^-1"
  by blast

lemma converse_meet: "(r \<sqinter> s)^--1 = r^--1 \<sqinter> s^--1"
  by (simp add: inf_fun_def) (iprover intro: conversepI ext dest: conversepD)

lemma converse_Un: "(r \<union> s)^-1 = r^-1 \<union> s^-1"
  by blast

lemma converse_join: "(r \<squnion> s)^--1 = r^--1 \<squnion> s^--1"
  by (simp add: sup_fun_def) (iprover intro: conversepI ext dest: conversepD)

lemma converse_INTER: "(INTER S r)^-1 = (INT x:S. (r x)^-1)"
  by fast

lemma converse_UNION: "(UNION S r)^-1 = (UN x:S. (r x)^-1)"
  by blast

lemma converse_mono[simp]: "r^-1 \<subseteq> s ^-1 \<longleftrightarrow> r \<subseteq> s"
  by auto

lemma conversep_mono[simp]: "r^--1 \<le> s ^--1 \<longleftrightarrow> r \<le> s"
  by (fact converse_mono[to_pred])

lemma converse_inject[simp]: "r^-1 = s ^-1 \<longleftrightarrow> r = s"
  by auto

lemma conversep_inject[simp]: "r^--1 = s ^--1 \<longleftrightarrow> r = s"
  by (fact converse_inject[to_pred])

lemma converse_subset_swap: "r \<subseteq> s ^-1 = (r ^-1 \<subseteq> s)"
  by auto

lemma conversep_le_swap: "r \<le> s ^--1 = (r ^--1 \<le> s)"
  by (fact converse_subset_swap[to_pred])

lemma converse_Id [simp]: "Id^-1 = Id"
  by blast

lemma converse_Id_on [simp]: "(Id_on A)^-1 = Id_on A"
  by blast

lemma refl_on_converse [simp]: "refl_on A (converse r) = refl_on A r"
  by (unfold refl_on_def) auto

lemma sym_converse [simp]: "sym (converse r) = sym r"
  by (unfold sym_def) blast

lemma antisym_converse [simp]: "antisym (converse r) = antisym r"
  by (unfold antisym_def) blast

lemma trans_converse [simp]: "trans (converse r) = trans r"
  by (unfold trans_def) blast

lemma sym_conv_converse_eq: "sym r = (r^-1 = r)"
  by (unfold sym_def) fast

lemma sym_Un_converse: "sym (r \<union> r^-1)"
  by (unfold sym_def) blast

lemma sym_Int_converse: "sym (r \<inter> r^-1)"
  by (unfold sym_def) blast

lemma total_on_converse [simp]: "total_on A (r^-1) = total_on A r"
  by (auto simp: total_on_def)

lemma finite_converse [iff]: "finite (r^-1) = finite r"
  unfolding converse_def conversep_iff using [[simproc add: finite_Collect]]
  by (auto elim: finite_imageD simp: inj_on_def)

lemma conversep_noteq [simp]: "(op \<noteq>)^--1 = op \<noteq>"
  by (auto simp add: fun_eq_iff)

lemma conversep_eq [simp]: "(op =)^--1 = op ="
  by (auto simp add: fun_eq_iff)

lemma converse_unfold [code]:
  "r\<inverse> = {(y, x). (x, y) \<in> r}"
  by (simp add: set_eq_iff)

subsubsection {* Domain, range and field *}

inductive_set Domain :: "('a \<times> 'b) set \<Rightarrow> 'a set"
  for r :: "('a \<times> 'b) set"
where
  DomainI [intro]: "(a, b) \<in> r \<Longrightarrow> a \<in> Domain r"

abbreviation (input) "DomainP \<equiv> Domainp"

lemmas DomainPI = Domainp.DomainI

inductive_cases DomainE [elim!]: "a \<in> Domain r"
inductive_cases DomainpE [elim!]: "Domainp r a"

inductive_set Range :: "('a \<times> 'b) set \<Rightarrow> 'b set"
  for r :: "('a \<times> 'b) set"
where
  RangeI [intro]: "(a, b) \<in> r \<Longrightarrow> b \<in> Range r"

abbreviation (input) "RangeP \<equiv> Rangep"

lemmas RangePI = Rangep.RangeI

inductive_cases RangeE [elim!]: "b \<in> Range r"
inductive_cases RangepE [elim!]: "Rangep r b"

definition Field :: "'a rel \<Rightarrow> 'a set"
where
  "Field r = Domain r \<union> Range r"

lemma Domain_fst [code]:
  "Domain r = fst ` r"
  by force

lemma Range_snd [code]:
  "Range r = snd ` r"
  by force

lemma fst_eq_Domain: "fst ` R = Domain R"
  by force

lemma snd_eq_Range: "snd ` R = Range R"
  by force

lemma Domain_empty [simp]: "Domain {} = {}"
  by auto

lemma Range_empty [simp]: "Range {} = {}"
  by auto

lemma Field_empty [simp]: "Field {} = {}"
  by (simp add: Field_def)

lemma Domain_empty_iff: "Domain r = {} \<longleftrightarrow> r = {}"
  by auto

lemma Range_empty_iff: "Range r = {} \<longleftrightarrow> r = {}"
  by auto

lemma Domain_insert [simp]: "Domain (insert (a, b) r) = insert a (Domain r)"
  by blast

lemma Range_insert [simp]: "Range (insert (a, b) r) = insert b (Range r)"
  by blast

lemma Field_insert [simp]: "Field (insert (a, b) r) = {a, b} \<union> Field r"
  by (auto simp add: Field_def)

lemma Domain_iff: "a \<in> Domain r \<longleftrightarrow> (\<exists>y. (a, y) \<in> r)"
  by blast

lemma Range_iff: "a \<in> Range r \<longleftrightarrow> (\<exists>y. (y, a) \<in> r)"
  by blast

lemma Domain_Id [simp]: "Domain Id = UNIV"
  by blast

lemma Range_Id [simp]: "Range Id = UNIV"
  by blast

lemma Domain_Id_on [simp]: "Domain (Id_on A) = A"
  by blast

lemma Range_Id_on [simp]: "Range (Id_on A) = A"
  by blast

lemma Domain_Un_eq: "Domain (A \<union> B) = Domain A \<union> Domain B"
  by blast

lemma Range_Un_eq: "Range (A \<union> B) = Range A \<union> Range B"
  by blast

lemma Field_Un [simp]: "Field (r \<union> s) = Field r \<union> Field s"
  by (auto simp: Field_def)

lemma Domain_Int_subset: "Domain (A \<inter> B) \<subseteq> Domain A \<inter> Domain B"
  by blast

lemma Range_Int_subset: "Range (A \<inter> B) \<subseteq> Range A \<inter> Range B"
  by blast

lemma Domain_Diff_subset: "Domain A - Domain B \<subseteq> Domain (A - B)"
  by blast

lemma Range_Diff_subset: "Range A - Range B \<subseteq> Range (A - B)"
  by blast

lemma Domain_Union: "Domain (\<Union>S) = (\<Union>A\<in>S. Domain A)"
  by blast

lemma Range_Union: "Range (\<Union>S) = (\<Union>A\<in>S. Range A)"
  by blast

lemma Field_Union [simp]: "Field (\<Union>R) = \<Union>(Field ` R)"
  by (auto simp: Field_def)

lemma Domain_converse [simp]: "Domain (r\<inverse>) = Range r"
  by auto

lemma Range_converse [simp]: "Range (r\<inverse>) = Domain r"
  by blast

lemma Field_converse [simp]: "Field (r\<inverse>) = Field r"
  by (auto simp: Field_def)

lemma Domain_Collect_split [simp]: "Domain {(x, y). P x y} = {x. EX y. P x y}"
  by auto

lemma Range_Collect_split [simp]: "Range {(x, y). P x y} = {y. EX x. P x y}"
  by auto

lemma finite_Domain: "finite r \<Longrightarrow> finite (Domain r)"
  by (induct set: finite) auto

lemma finite_Range: "finite r \<Longrightarrow> finite (Range r)"
  by (induct set: finite) auto

lemma finite_Field: "finite r \<Longrightarrow> finite (Field r)"
  by (simp add: Field_def finite_Domain finite_Range)

lemma Domain_mono: "r \<subseteq> s \<Longrightarrow> Domain r \<subseteq> Domain s"
  by blast

lemma Range_mono: "r \<subseteq> s \<Longrightarrow> Range r \<subseteq> Range s"
  by blast

lemma mono_Field: "r \<subseteq> s \<Longrightarrow> Field r \<subseteq> Field s"
  by (auto simp: Field_def Domain_def Range_def)

lemma Domain_unfold:
  "Domain r = {x. \<exists>y. (x, y) \<in> r}"
  by blast

subsubsection {* Image of a set under a relation *}

definition Image :: "('a \<times> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" (infixr "``" 90)
where
  "r `` s = {y. \<exists>x\<in>s. (x, y) \<in> r}"

lemma Image_iff: "(b : r``A) = (EX x:A. (x, b) : r)"
  by (simp add: Image_def)

lemma Image_singleton: "r``{a} = {b. (a, b) : r}"
  by (simp add: Image_def)

lemma Image_singleton_iff [iff]: "(b : r``{a}) = ((a, b) : r)"
  by (rule Image_iff [THEN trans]) simp

lemma ImageI [intro]: "(a, b) : r ==> a : A ==> b : r``A"
  by (unfold Image_def) blast

lemma ImageE [elim!]:
  "b : r `` A ==> (!!x. (x, b) : r ==> x : A ==> P) ==> P"
  by (unfold Image_def) (iprover elim!: CollectE bexE)

lemma rev_ImageI: "a : A ==> (a, b) : r ==> b : r `` A"
  -- {* This version's more effective when we already have the required @{text a} *}
  by blast

lemma Image_empty [simp]: "R``{} = {}"
  by blast

lemma Image_Id [simp]: "Id `` A = A"
  by blast

lemma Image_Id_on [simp]: "Id_on A `` B = A \<inter> B"
  by blast

lemma Image_Int_subset: "R `` (A \<inter> B) \<subseteq> R `` A \<inter> R `` B"
  by blast

lemma Image_Int_eq:
  "single_valued (converse R) ==> R `` (A \<inter> B) = R `` A \<inter> R `` B"
  by (simp add: single_valued_def, blast)

lemma Image_Un: "R `` (A \<union> B) = R `` A \<union> R `` B"
  by blast

lemma Un_Image: "(R \<union> S) `` A = R `` A \<union> S `` A"
  by blast

lemma Image_subset: "r \<subseteq> A \<times> B ==> r``C \<subseteq> B"
  by (iprover intro!: subsetI elim!: ImageE dest!: subsetD SigmaD2)

lemma Image_eq_UN: "r``B = (\<Union>y\<in> B. r``{y})"
  -- {* NOT suitable for rewriting *}
  by blast

lemma Image_mono: "r' \<subseteq> r ==> A' \<subseteq> A ==> (r' `` A') \<subseteq> (r `` A)"
  by blast

lemma Image_UN: "(r `` (UNION A B)) = (\<Union>x\<in>A. r `` (B x))"
  by blast

lemma UN_Image: "(\<Union>i\<in>I. X i) `` S = (\<Union>i\<in>I. X i `` S)"
  by auto

lemma Image_INT_subset: "(r `` INTER A B) \<subseteq> (\<Inter>x\<in>A. r `` (B x))"
  by blast

text{*Converse inclusion requires some assumptions*}
lemma Image_INT_eq:
     "[|single_valued (r\<inverse>); A\<noteq>{}|] ==> r `` INTER A B = (\<Inter>x\<in>A. r `` B x)"
apply (rule equalityI)
 apply (rule Image_INT_subset)
apply  (simp add: single_valued_def, blast)
done

lemma Image_subset_eq: "(r``A \<subseteq> B) = (A \<subseteq> - ((r^-1) `` (-B)))"
  by blast

lemma Image_Collect_split [simp]: "{(x, y). P x y} `` A = {y. EX x:A. P x y}"
  by auto

lemma Sigma_Image: "(SIGMA x:A. B x) `` X = (\<Union>x\<in>X \<inter> A. B x)"
  by auto

lemma relcomp_Image: "(X O Y) `` Z = Y `` (X `` Z)"
  by auto

subsubsection {* Inverse image *}

definition inv_image :: "'b rel \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a rel"
where
  "inv_image r f = {(x, y). (f x, f y) \<in> r}"

definition inv_imagep :: "('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "inv_imagep r f = (\<lambda>x y. r (f x) (f y))"

lemma [pred_set_conv]: "inv_imagep (\<lambda>x y. (x, y) \<in> r) f = (\<lambda>x y. (x, y) \<in> inv_image r f)"
  by (simp add: inv_image_def inv_imagep_def)

lemma sym_inv_image: "sym r ==> sym (inv_image r f)"
  by (unfold sym_def inv_image_def) blast

lemma trans_inv_image: "trans r ==> trans (inv_image r f)"
  apply (unfold trans_def inv_image_def)
  apply (simp (no_asm))
  apply blast
  done

lemma in_inv_image[simp]: "((x,y) : inv_image r f) = ((f x, f y) : r)"
  by (auto simp:inv_image_def)

lemma converse_inv_image[simp]: "(inv_image R f)^-1 = inv_image (R^-1) f"
  unfolding inv_image_def converse_unfold by auto

lemma in_inv_imagep [simp]: "inv_imagep r f x y = r (f x) (f y)"
  by (simp add: inv_imagep_def)

subsubsection {* Powerset *}

definition Powp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
where
  "Powp A = (\<lambda>B. \<forall>x \<in> B. A x)"

lemma Powp_Pow_eq [pred_set_conv]: "Powp (\<lambda>x. x \<in> A) = (\<lambda>x. x \<in> Pow A)"
  by (auto simp add: Powp_def fun_eq_iff)

lemmas Powp_mono [mono] = Pow_mono [to_pred]

subsubsection {* Expressing relation operations via @{const Finite_Set.fold} *}

lemma Id_on_fold:
  assumes "finite A"
  shows "Id_on A = Finite_Set.fold (\<lambda>x. Set.insert (Pair x x)) {} A"
proof -
  interpret comp_fun_commute "\<lambda>x. Set.insert (Pair x x)" by default auto
  show ?thesis using assms unfolding Id_on_def by (induct A) simp_all
qed

lemma comp_fun_commute_Image_fold:
  "comp_fun_commute (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A)"
proof -
  interpret comp_fun_idem Set.insert
      by (fact comp_fun_idem_insert)
  show ?thesis
  by default (auto simp add: fun_eq_iff comp_fun_commute split:prod.split)
qed

lemma Image_fold:
  assumes "finite R"
  shows "R `` S = Finite_Set.fold (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A) {} R"
proof -
  interpret comp_fun_commute "(\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A)"
    by (rule comp_fun_commute_Image_fold)
  have *: "\<And>x F. Set.insert x F `` S = (if fst x \<in> S then Set.insert (snd x) (F `` S) else (F `` S))"
    by (force intro: rev_ImageI)
  show ?thesis using assms by (induct R) (auto simp: *)
qed

lemma insert_relcomp_union_fold:
  assumes "finite S"
  shows "{x} O S \<union> X = Finite_Set.fold (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A') X S"
proof -
  interpret comp_fun_commute "\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A'"
  proof -
    interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert)
    show "comp_fun_commute (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A')"
    by default (auto simp add: fun_eq_iff split:prod.split)
  qed
  have *: "{x} O S = {(x', z). x' = fst x \<and> (snd x,z) \<in> S}" by (auto simp: relcomp_unfold intro!: exI)
  show ?thesis unfolding *
  using `finite S` by (induct S) (auto split: prod.split)
qed

lemma insert_relcomp_fold:
  assumes "finite S"
  shows "Set.insert x R O S =
    Finite_Set.fold (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A') (R O S) S"
proof -
  have "Set.insert x R O S = ({x} O S) \<union> (R O S)" by auto
  then show ?thesis by (auto simp: insert_relcomp_union_fold[OF assms])
qed

lemma comp_fun_commute_relcomp_fold:
  assumes "finite S"
  shows "comp_fun_commute (\<lambda>(x,y) A.
    Finite_Set.fold (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') A S)"
proof -
  have *: "\<And>a b A.
    Finite_Set.fold (\<lambda>(w, z) A'. if b = w then Set.insert (a, z) A' else A') A S = {(a,b)} O S \<union> A"
    by (auto simp: insert_relcomp_union_fold[OF assms] cong: if_cong)
  show ?thesis by default (auto simp: *)
qed

lemma relcomp_fold:
  assumes "finite R"
  assumes "finite S"
  shows "R O S = Finite_Set.fold
    (\<lambda>(x,y) A. Finite_Set.fold (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') A S) {} R"
  using assms by (induct R)
    (auto simp: comp_fun_commute.fold_insert comp_fun_commute_relcomp_fold insert_relcomp_fold
      cong: if_cong)

end


(*  Title:      ListPre.thy
    Author:     Ludovic Henrio and Florian Kammuller, 2006

List lemmata and other general stuff as preparation for ASP.
*)

section \<open>List features\<close>

theory ListPre
imports Main
begin

lemma drop_lem[rule_format]:
  fixes n :: nat and l :: "'a list" and g :: "'a list"
  assumes "drop n l = drop n g" and "length l = length g" and "n < length g"
  shows "l!n = g!n"
proof -
  from assms(2-3) have "n < length l" by simp
  from Cons_nth_drop_Suc[OF this] Cons_nth_drop_Suc[OF assms(3)] assms(1)
  have "l!n # drop (Suc n) l = g!n # drop (Suc n) g" by simp
  thus ?thesis by simp
qed

lemma mem_append_lem': "x \<in> set (l @ [y]) \<Longrightarrow> x \<in> set l \<or> x = y"
  by auto

lemma nth_last: "length l = n \<Longrightarrow> (l @ [x])!n = x"
  by auto

lemma take_n:
  fixes n :: nat and l :: "'a list" and g :: "'a list"
  assumes "take n l = take n g" and "Suc n \<le> length g" and "length l = length g"
  shows "take (Suc n) (l[n := g!n]) = take (Suc n) g"
proof -
  from assms(2) have ng: "n < length g" by simp
  with assms(3) have nlupd: "n < length (l[n := g!n])" by simp
  hence nl: "n < length l" by simp
  from
    sym[OF assms(1)] id_take_nth_drop[OF ng] take_Suc_conv_app_nth[OF nlupd]
    nth_list_update_eq[OF nl] take_Suc_conv_app_nth[OF ng]
    upd_conv_take_nth_drop[OF nl] assms(2-3)
  show ?thesis by simp
qed

lemma drop_n_lem:
  fixes n :: nat and l :: "'a list"
  assumes "Suc n \<le> length l"
  shows "drop (Suc n) (l[n := x]) = drop (Suc n) l"
  using assms by simp

lemma drop_n:
  fixes n :: nat and l :: "'a list" and g :: "'a list"
  assumes "drop n l = drop n g" and "Suc n \<le> length g" and "length l = length g"
  shows "drop (Suc n) (l[n := g!n]) = drop (Suc n) g"
proof -
  from assms(2-3) have "Suc n \<le> length l" by simp
  from drop_n_lem[OF this] assms(1) show ?thesis
    by (simp, (subst drop_Suc)+, (subst drop_tl)+, simp)
qed

lemma nth_fst[rule_format]: "length l = n + 1 \<longrightarrow> (l @ [x])!0 = l!0"
  by (induct l, simp_all)

lemma nth_zero_app:
  fixes l :: "'a list" and x :: 'a and y :: 'a
  assumes "l \<noteq> []" and "l!0 = x"
  shows"(l @ [y])!0 = x"
proof -
  have "l \<noteq> [] \<and> l!0 = x \<longrightarrow> (l @ [y])!0 = x"
    by (induct l, simp_all)
  with assms show ?thesis by simp
qed

lemma rev_induct2[consumes 1]:
  fixes xs :: "'a list" and ys :: "'a list" and P :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  assumes
  "length xs = length ys" and "P [] []" and
  "\<And>x xs y ys. \<lbrakk> length xs = length ys; P xs ys \<rbrakk> \<Longrightarrow> P (xs @ [x]) (ys @ [y])"
  shows "P xs ys"
proof (simplesubst rev_rev_ident[symmetric])
  from assms(1) have lrev: "length (rev xs) = length (rev ys)" by simp
  from assms have "P (rev (rev xs))(rev (rev ys))"
    by (induct rule: list_induct2[OF lrev], simp_all)
  thus "P xs (rev (rev ys))" by simp
qed

lemma list_induct3: (* Similar to induction for 2: see ML "thm \"list_induct2\""; *)
  "\<And>ys zs. \<lbrakk> length xs = length ys; length zs = length xs; P [] [] [];
              \<And>x xs y ys z zs. \<lbrakk> length xs = length ys;
                                    length zs = length xs; P xs ys zs \<rbrakk>
                                 \<Longrightarrow> P (x # xs)(y # ys)(z # zs)
  \<rbrakk> \<Longrightarrow> P xs ys zs"
proof (induct xs, simp)
  case (Cons a xs ys zs)
  from \<open>length (a#xs) = length ys\<close> \<open>length zs = length (a#xs)\<close>
  have "ys \<noteq> [] \<and> zs \<noteq> []" by auto
  then obtain b ly c lz where "ys = b#ly" and "zs = c#lz"
    by (auto simp: neq_Nil_conv)
  with \<open>length (a#xs) = length ys\<close> \<open>length zs = length (a#xs)\<close>
  obtain "length xs = length ly" and "length lz = length xs"
    by auto
  from
    Cons(5)[OF this Cons(1)[OF this \<open>P [] [] []\<close>]]
    Cons(5) \<open>ys = b#ly\<close> \<open>zs = c#lz\<close>
  show ?case by simp
qed

primrec list_insert :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_insert (ah#as) i a =
  (case i of
        0      \<Rightarrow> a#ah#as
       |Suc j  \<Rightarrow> ah#(list_insert as j a))" |

  "list_insert [] i a = [a]"

lemma insert_eq[simp]: "\<forall>i\<le>length l. (list_insert l i a)!i = a"
  by (induct l, simp, intro strip, simp split: nat.split)

lemma insert_gt[simp]: "\<forall>i\<le>length l. \<forall>j<i. (list_insert  l i a)!j = l!j"
proof (induct l, simp)
  case (Cons x l) thus ?case
  proof (auto split: nat.split)
    fix n j assume "n \<le> length l" and "j < Suc n"
    with Cons(1) show "(x#(list_insert l n a))!j = (x#l)!j"
      by (cases j) simp_all
  qed
qed

lemma insert_lt[simp]: "\<forall>j\<le>length l. \<forall>i\<le>j. (list_insert l i a)!Suc j = l!j"
proof (induct l, simp)
  case (Cons x l) thus ?case
  proof (auto split: nat.split)
    fix n j assume "j \<le> Suc (length l)" and "Suc n \<le> j"
    with Cons(1) show "(list_insert l n a)!j = l!(j - Suc 0)"
      by (cases j) simp_all
  qed
qed

lemma insert_first[simp]: "list_insert l 0 b = b#l"
  by (induct l, simp_all)

lemma insert_prepend[simp]:
  "i = Suc j \<Longrightarrow> list_insert (a#l) i b = a # list_insert l j b"
  by auto

lemma insert_lt2[simp]: "\<forall>j. \<forall>i\<le>j. (list_insert  l i a)!Suc j = l!j"
proof (induct l, simp)
  case (Cons x l) thus ?case
  proof (auto split: nat.split)
    fix n j assume "Suc n \<le> j"
    with Cons(1) show "(list_insert l n a)!j = l!(j - Suc 0)"
      by (cases j) simp_all
  qed
qed

lemma insert_commute[simp]:
  "\<forall>i\<le>length l. (list_insert (list_insert l i b) 0 a) =
                 (list_insert (list_insert l 0 a ) (Suc i) b)"
  by (induct l, auto split: nat.split)

lemma insert_length': "\<And>i x. length (list_insert l i x) = length (x#l)"
  by (induct l, auto split: nat.split)

lemma insert_length[simp]: "length (list_insert l i b) = length (list_insert l j c)"
  by (simp add: insert_length')

lemma insert_select[simp]: "the ((f(l \<mapsto> t)) l) = t"
  by auto

lemma dom_insert[simp]: "l \<in> dom f \<Longrightarrow> dom (f(l \<mapsto> t)) = dom f"
  by auto

lemma insert_select2[simp]: "l1 \<noteq> l2 \<Longrightarrow> ((f(l1 \<mapsto> t)) l2) = (f l2)"
  by auto

lemma the_insert_select[simp]:
  "\<lbrakk> l2 \<in> dom f; l1 \<noteq> l2 \<rbrakk> \<Longrightarrow>  the ((f(l1 \<mapsto> t)) l2) =  the (f l2)"
  by auto

lemma insert_dom_eq: "dom f = dom f' \<Longrightarrow> dom (f(l \<mapsto> x)) = dom (f'(l \<mapsto> x'))"
  by auto

lemma insert_dom_less_eq:
  "\<lbrakk> x \<notin> dom f; x \<notin> dom f'; dom (f(x \<mapsto> y)) = dom (f'(x \<mapsto> y')) \<rbrakk>
  \<Longrightarrow> dom f = dom f'"
  by auto

lemma one_more_dom[rule_format]:
  "\<forall>l\<in>dom f . \<exists>f'. f = f'(l \<mapsto> the(f l)) \<and> l \<notin> dom f'"
proof
  fix l assume "l \<in> dom f"
  hence "\<And>la. f la = ((\<lambda>la. if la = l then None else f la)(l \<mapsto> the (f l))) la"
    by auto
  hence "f = (\<lambda>la. if la = l then None else f la)(l \<mapsto> the (f l))"
    by (rule ext)
  thus "\<exists>f'. f = f'(l \<mapsto> the(f l) ) \<and> l \<notin> dom f'" by auto
qed

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header "Language Primitives"

theory Primitives imports "../pGCL" begin

text {* Programs in pGCL are probabilistic automata.  They can do anything a traditional program
can, plus, they may make truly probabilistic choices. *}

subsection {* The Basics *}

text {* Imagine flipping a pair of fair coins: @{term a} and @{term b}. Using a record type for the
state allows a number of syntactic niceties, which we describe shortly: *}

datatype coin = Heads | Tails

record coins =
  a :: coin
  b :: coin

text {* The primitive state operation is @{term Apply}, which takes a state transformer as an
argument, constructs the pGCL equivalent. Thus @{term "Apply (\<lambda>s. s\<lparr> a := Heads \<rparr>)"} sets the value
of coin @{term a} to @{term Heads}. As records are so common as state types, we introduce syntax to
make these update neater: The same program may be defined more simply as @{term "a := (\<lambda>s. Heads)"}
(note that the syntax translation involved does not apply to Latex output, and thus this lemma
appears trivial):
*}

lemma
  "Apply (\<lambda>s. s \<lparr> a := Heads \<rparr>) = (a := (\<lambda>s. Heads))"
  by(simp)

text {* We can treat the record's fields as the names of \emph{variables}. Note that the right-hand
side of an assignment is always a function of the current state. Thus we may use a record accessor
directly, for example @{term "a := b"}, which updates @{term a} with the current value of @{term b}.
If we wish to formally establish that the previous statement is correct i.e. that in the final
state, @{term a} really will have whatever value @{term b} had in the initial state, we must first
introduce the assertion language. *}

subsection {* Assertion and Annotation *}

text {* Assertions in pGCL are real-valued functions of the state, which are often interpreted as a
probability distribution over possible outcomes. These functions are termed \emph{expectations}, for
reasons which shortly be clear. Initially, however, we need only consider \emph{standard}
expectations: those derived from a binary predicate. A predicate @{term_type "P::'s \<Rightarrow> bool"} is
embedded as @{term_type "\<guillemotleft>P::'s \<Rightarrow> bool\<guillemotright>"}, such that @{term "P s \<longrightarrow> \<guillemotleft>P\<guillemotright> s = 1 \<and> \<not> P s \<longrightarrow> \<guillemotleft>P\<guillemotright> s = 0"}.

  An annotation consists of an assertion on the initial state and one on the final state, which for
  standard expectations may be interpreted as `if @{term P} holds in the initial state, then @{term
  Q} will hold in the final state'. These are in weakest-precondition form: we assert that the
  precondition implies the \emph{weakest precondition}: the weakest assertion on the initial state,
  which implies that the postcondition must hold on the final state. So far, this is identical to
  the standard approach. Remember, however, that we are working with \emph{real-valued} assertions.
  For standard expectations, the logic is nevertheless identical, if the implication @{term "\<forall>s. P s
  \<longrightarrow> Q s"} is substituted with the equivalent expectation entailment @{term "\<guillemotleft>P\<guillemotright> \<tturnstile> \<guillemotleft>Q\<guillemotright>"}, @{thm
  entails_implies}. Thus a valid specification of @{term "a := b"} is: *}

lemma
  "\<And>x. \<guillemotleft>\<lambda>s. b s = x\<guillemotright> \<tturnstile> wp (a := b) \<guillemotleft>\<lambda>s. a s = x\<guillemotright>"
  by(pvcg, simp add:o_def)

text {* Any ordinary computation and its associated annotation can be expressed in this form. *}

subsection {* Probability *}

text {* Next, we introduce the syntax @{term "x ;; y"} for the sequential composition of @{term x}
and @{term y}, and also demonstrate that one can operate directly on a real-valued (and thus
infinite) state space: *}

lemma
  "\<guillemotleft>\<lambda>s::real. s \<noteq> 0\<guillemotright> \<tturnstile> wp (Apply (op * 2) ;; Apply (\<lambda>s. s / s)) \<guillemotleft>\<lambda>s. s = 1\<guillemotright>"
  by(pvcg, simp add:o_def)

text {* So far, we haven't done anything that required probabilities, or expectations other than 0
and 1. As an example of both, we show that a single coin toss is fair. We introduce the syntax
@{term "x \<^bsub>p\<^esub>\<oplus> y"} for a probabilistic choice between @{term x} and @{term y}. This program behaves
as @{term x} with probability @{term p}, and as @{term y} with probability @{term "1-p"}. The
probability may depend on the state, and is therefore of type @{typ "'s \<Rightarrow> real"}. The following
annotation states that the probability of heads is exactly 1/2: *}

definition
  flip_a :: "real \<Rightarrow> coins prog"
where
  "flip_a p = a := (\<lambda>_. Heads) \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> a := (\<lambda>_. Tails)"

lemma
  "(\<lambda>s. 1/2) = wp (flip_a (1/2)) \<guillemotleft>\<lambda>s. a s = Heads\<guillemotright>"
  unfolding flip_a_def
  txt {* Sufficiently small problems can be handled by the simplifier, by symbolic evaluation. *}
  by(simp add:wp_eval o_def)

subsection {* Nondeterminism *}

text {* We can also under-specify a program, using the \emph{nondeterministic choice} operator,
@{term "x \<Sqinter> y"}. This is interpreted demonically, giving the pointwise \emph{minimum} of the
pre-expectations for @{term x} and @{term y}: the chance of seeing heads, if your opponent is
allowed choose between a pair of coins, one biased 2/3 heads and one 2/3 tails, and then flips it,
is \emph{at least} 1/3, but we can make no stronger statement: *}

lemma
  "\<lambda>s. 1/3 \<tturnstile> wp (flip_a (2/3) \<Sqinter> flip_a (1/3)) \<guillemotleft>\<lambda>s. a s = Heads\<guillemotright>"
  unfolding flip_a_def
  by(pvcg, simp add:o_def le_funI)

subsection {* Properties of Expectations *}

text {* The probabilities of independent events combine as usual, by multiplying: The chance
of getting heads on two separate coins is @{term "1/4"}. *}

definition
  flip_b :: "real \<Rightarrow> coins prog"
where
  "flip_b p = b := (\<lambda>_. Heads) \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b := (\<lambda>_. Tails)"

lemma
  "(\<lambda>s. 1/4) = wp (flip_a (1/2) ;; flip_b (1/2))
                  \<guillemotleft>\<lambda>s. a s = Heads \<and> b s = Heads\<guillemotright>"
  unfolding flip_a_def flip_b_def
  by(simp add:wp_eval o_def)

text {* If, rather than two coins, we use two dice, we can make some slightly more involved
calculations.  We see that the weakest pre-expectation of the value on the face of the die after
rolling is its \emph{expected value} in the initial state, which justifies the use of the term
expectation.
*}

record dice =
  red  :: nat
  blue :: nat

definition Puniform :: "'a set \<Rightarrow> ('a \<Rightarrow> real)"
where "Puniform S = (\<lambda>x. if x \<in> S then 1 / card S else 0)"

lemma Puniform_out:
  "x \<notin> S \<Longrightarrow> Puniform S x = 0"
  by(simp add:Puniform_def)

lemma supp_Puniform:
  "finite S \<Longrightarrow> supp (Puniform S) = S"
  by(auto simp:Puniform_def supp_def)

text {* The expected value of a roll of a six-sided die is @{term "7/2"}: *}

lemma
  "(\<lambda>s. 7/2) = wp (bind v at (\<lambda>s. Puniform {1..6} v) in red := (\<lambda>_. v)) red"
  by(simp add:wp_eval supp_Puniform setsum_head_Suc Puniform_in real_eq_of_nat)

text {* The expectations of independent variables add: *}

lemma
  "(\<lambda>s. 7) = wp ((bind v at (\<lambda>s. Puniform {1..6} v) in red := (\<lambda>s. v)) ;;
                 (bind v at (\<lambda>s. Puniform {1..6} v) in blue := (\<lambda>s. v)))
                (\<lambda>s. red s + blue s)"
  by(simp add:wp_eval supp_Puniform setsum_head_Suc Puniform_in real_eq_of_nat)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Set Equality\<close>
theory Equality
  imports Subset
begin

lemma eqI [intro]: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B) \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> x \<in> A) \<Longrightarrow> A = B"
  by auto

lemma eqI': "(\<And>x. x \<in> A \<longleftrightarrow> x \<in> B) \<Longrightarrow> A = B" by auto

lemma eqE: "\<lbrakk>A = B; \<lbrakk>A \<subseteq> B ; B \<subseteq> A\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" by blast

lemma eqD [dest]: "A = B \<Longrightarrow> (\<And>x. x \<in> A \<longleftrightarrow> x \<in> B)" by auto

lemma ne_if_ex_mem_not_mem: "\<exists>x. x \<in> A \<and> x \<notin> B \<Longrightarrow> A \<noteq> B" by auto

lemma neD: "A \<noteq> B \<Longrightarrow> \<exists>x. (x \<in> A \<and> x \<notin> B) \<or> (x \<notin> A \<and> x \<in> B)" by auto

end


(*  Title:      HOL/Examples/Adhoc_Overloading_Examples.thy
    Author:     Christian Sternagel
*)

section \<open>Ad Hoc Overloading\<close>

theory Adhoc_Overloading_Examples
imports
  Main
  "HOL-Library.Infinite_Set"
  "HOL-Library.Adhoc_Overloading"
begin

text \<open>Adhoc overloading allows to overload a constant depending on
its type. Typically this involves to introduce an uninterpreted
constant (used for input and output) and then add some variants (used
internally).\<close>

subsection \<open>Plain Ad Hoc Overloading\<close>

text \<open>Consider the type of first-order terms.\<close>
datatype ('a, 'b) "term" =
  Var 'b |
  Fun 'a "('a, 'b) term list"

text \<open>The set of variables of a term might be computed as follows.\<close>
fun term_vars :: "('a, 'b) term \<Rightarrow> 'b set" where
  "term_vars (Var x) = {x}" |
  "term_vars (Fun f ts) = \<Union>(set (map term_vars ts))"

text \<open>However, also for \emph{rules} (i.e., pairs of terms) and term
rewrite systems (i.e., sets of rules), the set of variables makes
sense. Thus we introduce an unspecified constant \<open>vars\<close>.\<close>

consts vars :: "'a \<Rightarrow> 'b set"

text \<open>Which is then overloaded with variants for terms, rules, and TRSs.\<close>
adhoc_overloading
  vars term_vars

value [nbe] "vars (Fun ''f'' [Var 0, Var 1])"

fun rule_vars :: "('a, 'b) term \<times> ('a, 'b) term \<Rightarrow> 'b set" where
  "rule_vars (l, r) = vars l \<union> vars r"

adhoc_overloading
  vars rule_vars

value [nbe] "vars (Var 1, Var 0)"

definition trs_vars :: "(('a, 'b) term \<times> ('a, 'b) term) set \<Rightarrow> 'b set" where
  "trs_vars R = \<Union>(rule_vars ` R)"

adhoc_overloading
  vars trs_vars

value [nbe] "vars {(Var 1, Var 0)}"

text \<open>Sometimes it is necessary to add explicit type constraints
before a variant can be determined.\<close>
(*value "vars R" (*has multiple instances*)*)
value "vars (R :: (('a, 'b) term \<times> ('a, 'b) term) set)"

text \<open>It is also possible to remove variants.\<close>
no_adhoc_overloading
  vars term_vars rule_vars

(*value "vars (Var 1)" (*does not have an instance*)*)

text \<open>As stated earlier, the overloaded constant is only used for
input and output. Internally, always a variant is used, as can be
observed by the configuration option \<open>show_variants\<close>.\<close>

adhoc_overloading
  vars term_vars

declare [[show_variants]]

term "vars (Var 1)" (*which yields: "term_vars (Var 1)"*)

subsection \<open>Adhoc Overloading inside Locales\<close>

text \<open>As example we use permutations that are parametrized over an
atom type \<^typ>\<open>'a\<close>.\<close>

definition perms :: "('a \<Rightarrow> 'a) set" where
  "perms = {f. bij f \<and> finite {x. f x \<noteq> x}}"

typedef 'a perm = "perms :: ('a \<Rightarrow> 'a) set"
  by standard (auto simp: perms_def)

text \<open>First we need some auxiliary lemmas.\<close>
lemma permsI [Pure.intro]:
  assumes "bij f" and "MOST x. f x = x"
  shows "f \<in> perms"
  using assms by (auto simp: perms_def) (metis MOST_iff_finiteNeg)

lemma perms_imp_bij:
  "f \<in> perms \<Longrightarrow> bij f"
  by (simp add: perms_def)

lemma perms_imp_MOST_eq:
  "f \<in> perms \<Longrightarrow> MOST x. f x = x"
  by (simp add: perms_def) (metis MOST_iff_finiteNeg)

lemma id_perms [simp]:
  "id \<in> perms"
  "(\<lambda>x. x) \<in> perms"
  by (auto simp: perms_def bij_def)

lemma perms_comp [simp]:
  assumes f: "f \<in> perms" and g: "g \<in> perms"
  shows "(f \<circ> g) \<in> perms"
  apply (intro permsI bij_comp)
  apply (rule perms_imp_bij [OF g])
  apply (rule perms_imp_bij [OF f])
  apply (rule MOST_rev_mp [OF perms_imp_MOST_eq [OF g]])
  apply (rule MOST_rev_mp [OF perms_imp_MOST_eq [OF f]])
  by simp

lemma perms_inv:
  assumes f: "f \<in> perms"
  shows "inv f \<in> perms"
  apply (rule permsI)
  apply (rule bij_imp_bij_inv)
  apply (rule perms_imp_bij [OF f])
  apply (rule MOST_mono [OF perms_imp_MOST_eq [OF f]])
  apply (erule subst, rule inv_f_f)
  apply (rule bij_is_inj [OF perms_imp_bij [OF f]])
  done

lemma bij_Rep_perm: "bij (Rep_perm p)"
  using Rep_perm [of p] unfolding perms_def by simp

instantiation perm :: (type) group_add
begin

definition "0 = Abs_perm id"
definition "- p = Abs_perm (inv (Rep_perm p))"
definition "p + q = Abs_perm (Rep_perm p \<circ> Rep_perm q)"
definition "(p1::'a perm) - p2 = p1 + - p2"

lemma Rep_perm_0: "Rep_perm 0 = id"
  unfolding zero_perm_def by (simp add: Abs_perm_inverse)

lemma Rep_perm_add:
  "Rep_perm (p1 + p2) = Rep_perm p1 \<circ> Rep_perm p2"
  unfolding plus_perm_def by (simp add: Abs_perm_inverse Rep_perm)

lemma Rep_perm_uminus:
  "Rep_perm (- p) = inv (Rep_perm p)"
  unfolding uminus_perm_def by (simp add: Abs_perm_inverse perms_inv Rep_perm)

instance
  apply standard
  unfolding Rep_perm_inject [symmetric]
  unfolding minus_perm_def
  unfolding Rep_perm_add
  unfolding Rep_perm_uminus
  unfolding Rep_perm_0
  apply (simp_all add: o_assoc inv_o_cancel [OF bij_is_inj [OF bij_Rep_perm]])
  done

end

lemmas Rep_perm_simps =
  Rep_perm_0
  Rep_perm_add
  Rep_perm_uminus

section \<open>Permutation Types\<close>

text \<open>We want to be able to apply permutations to arbitrary types. To
this end we introduce a constant \<open>PERMUTE\<close> together with
convenient infix syntax.\<close>

consts PERMUTE :: "'a perm \<Rightarrow> 'b \<Rightarrow> 'b" (infixr "\<bullet>" 75)

text \<open>Then we add a locale for types \<^typ>\<open>'b\<close> that support
appliciation of permutations.\<close>
locale permute =
  fixes permute :: "'a perm \<Rightarrow> 'b \<Rightarrow> 'b"
  assumes permute_zero [simp]: "permute 0 x = x"
    and permute_plus [simp]: "permute (p + q) x = permute p (permute q x)"
begin

adhoc_overloading
  PERMUTE permute

end

text \<open>Permuting atoms.\<close>
definition permute_atom :: "'a perm \<Rightarrow> 'a \<Rightarrow> 'a" where
  "permute_atom p a = (Rep_perm p) a"

adhoc_overloading
  PERMUTE permute_atom

interpretation atom_permute: permute permute_atom
  by standard (simp_all add: permute_atom_def Rep_perm_simps)

text \<open>Permuting permutations.\<close>
definition permute_perm :: "'a perm \<Rightarrow> 'a perm \<Rightarrow> 'a perm" where
  "permute_perm p q = p + q - p"

adhoc_overloading
  PERMUTE permute_perm

interpretation perm_permute: permute permute_perm
  apply standard
  unfolding permute_perm_def
  apply simp
  apply (simp only: diff_conv_add_uminus minus_add add.assoc)
  done

text \<open>Permuting functions.\<close>
locale fun_permute =
  dom: permute perm1 + ran: permute perm2
  for perm1 :: "'a perm \<Rightarrow> 'b \<Rightarrow> 'b"
  and perm2 :: "'a perm \<Rightarrow> 'c \<Rightarrow> 'c"
begin

adhoc_overloading
  PERMUTE perm1 perm2

definition permute_fun :: "'a perm \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'c)" where
  "permute_fun p f = (\<lambda>x. p \<bullet> (f (-p \<bullet> x)))"

adhoc_overloading
  PERMUTE permute_fun

end

sublocale fun_permute \<subseteq> permute permute_fun
  by (unfold_locales, auto simp: permute_fun_def)
     (metis dom.permute_plus minus_add)

lemma "(Abs_perm id :: nat perm) \<bullet> Suc 0 = Suc 0"
  unfolding permute_atom_def
  by (metis Rep_perm_0 id_apply zero_perm_def)

interpretation atom_fun_permute: fun_permute permute_atom permute_atom
  by (unfold_locales)

adhoc_overloading
  PERMUTE atom_fun_permute.permute_fun

lemma "(Abs_perm id :: 'a perm) \<bullet> id = id"
  unfolding atom_fun_permute.permute_fun_def
  unfolding permute_atom_def
  by (metis Rep_perm_0 id_def inj_imp_inv_eq inj_on_id uminus_perm_def zero_perm_def)

end