(*  Title:      CTT/Arith.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section {* Elementary arithmetic *}

theory Arith
imports Bool
begin

subsection {* Arithmetic operators and their definitions *}

definition
  add :: "[i,i]\<Rightarrow>i"   (infixr "#+" 65) where
  "a#+b == rec(a, b, \<lambda>u v. succ(v))"

definition
  diff :: "[i,i]\<Rightarrow>i"   (infixr "-" 65) where
  "a-b == rec(b, a, \<lambda>u v. rec(v, 0, \<lambda>x y. x))"

definition
  absdiff :: "[i,i]\<Rightarrow>i"   (infixr "|-|" 65) where
  "a|-|b == (a-b) #+ (b-a)"

definition
  mult :: "[i,i]\<Rightarrow>i"   (infixr "#*" 70) where
  "a#*b == rec(a, 0, \<lambda>u v. b #+ v)"

definition
  mod :: "[i,i]\<Rightarrow>i"   (infixr "mod" 70) where
  "a mod b == rec(a, 0, %u v. rec(succ(v) |-| b, 0, %x y. succ(v)))"

definition
  div :: "[i,i]\<Rightarrow>i"   (infixr "div" 70) where
  "a div b == rec(a, 0, \<lambda>u v. rec(succ(u) mod b, succ(v), \<lambda>x y. v))"

notation (xsymbols)
  mult  (infixr "#\<times>" 70)

notation (HTML output)
  mult (infixr "#\<times>" 70)

lemmas arith_defs = add_def diff_def absdiff_def mult_def mod_def div_def

subsection {* Proofs about elementary arithmetic: addition, multiplication, etc. *}

(** Addition *)

(*typing of add: short and long versions*)

lemma add_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #+ b : N"
apply (unfold arith_defs)
apply typechk
done

lemma add_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a #+ b = c #+ d : N"
apply (unfold arith_defs)
apply equal
done

(*computation for add: 0 and successor cases*)

lemma addC0: "b:N \<Longrightarrow> 0 #+ b = b : N"
apply (unfold arith_defs)
apply rew
done

lemma addC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) #+ b = succ(a #+ b) : N"
apply (unfold arith_defs)
apply rew
done

(** Multiplication *)

(*typing of mult: short and long versions*)

lemma mult_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #* b : N"
apply (unfold arith_defs)
apply (typechk add_typing)
done

lemma mult_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a #* b = c #* d : N"
apply (unfold arith_defs)
apply (equal add_typingL)
done

(*computation for mult: 0 and successor cases*)

lemma multC0: "b:N \<Longrightarrow> 0 #* b = 0 : N"
apply (unfold arith_defs)
apply rew
done

lemma multC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) #* b = b #+ (a #* b) : N"
apply (unfold arith_defs)
apply rew
done

(** Difference *)

(*typing of difference*)

lemma diff_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a - b : N"
apply (unfold arith_defs)
apply typechk
done

lemma diff_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a - b = c - d : N"
apply (unfold arith_defs)
apply equal
done

(*computation for difference: 0 and successor cases*)

lemma diffC0: "a:N \<Longrightarrow> a - 0 = a : N"
apply (unfold arith_defs)
apply rew
done

(*Note: rec(a, 0, \<lambda>z w.z) is pred(a). *)

lemma diff_0_eq_0: "b:N \<Longrightarrow> 0 - b = 0 : N"
apply (unfold arith_defs)
apply (NE b)
apply hyp_rew
done

(*Essential to simplify FIRST!!  (Else we get a critical pair)
  succ(a) - succ(b) rewrites to   pred(succ(a) - b)  *)
lemma diff_succ_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) - succ(b) = a - b : N"
apply (unfold arith_defs)
apply hyp_rew
apply (NE b)
apply hyp_rew
done

subsection {* Simplification *}

lemmas arith_typing_rls = add_typing mult_typing diff_typing
  and arith_congr_rls = add_typingL mult_typingL diff_typingL
lemmas congr_rls = arith_congr_rls intrL2_rls elimL_rls

lemmas arithC_rls =
  addC0 addC_succ
  multC0 multC_succ
  diffC0 diff_0_eq_0 diff_succ_succ

ML {*

structure Arith_simp_data: TSIMP_DATA =
  struct
  val refl              = @{thm refl_elem}
  val sym               = @{thm sym_elem}
  val trans             = @{thm trans_elem}
  val refl_red          = @{thm refl_red}
  val trans_red         = @{thm trans_red}
  val red_if_equal      = @{thm red_if_equal}
  val default_rls       = @{thms arithC_rls} @ @{thms comp_rls}
  val routine_tac       = routine_tac (@{thms arith_typing_rls} @ @{thms routine_rls})
  end

structure Arith_simp = TSimpFun (Arith_simp_data)

local val congr_rls = @{thms congr_rls} in

fun arith_rew_tac ctxt prems = make_rew_tac ctxt
  (Arith_simp.norm_tac ctxt (congr_rls, prems))

fun hyp_arith_rew_tac ctxt prems = make_rew_tac ctxt
  (Arith_simp.cond_norm_tac ctxt (prove_cond_tac, congr_rls, prems))

end
*}

method_setup arith_rew = {*
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (arith_rew_tac ctxt ths))
*}

method_setup hyp_arith_rew = {*
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (hyp_arith_rew_tac ctxt ths))
*}

subsection {* Addition *}

(*Associative law for addition*)

(*Commutative law for addition.  Can be proved using three inductions.
  Must simplify after first induction!  Orientation of rewrites is delicate*)
lemma add_commute: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #+ b = b #+ a : N"
apply (NE a)
apply hyp_arith_rew
apply (rule sym_elem)
prefer 2
apply (NE b)
prefer 4
apply (NE b)
apply hyp_arith_rew
done

subsection {* Multiplication *}

(*right annihilation in product*)
lemma mult_0_right: "a:N \<Longrightarrow> a #* 0 = 0 : N"
apply (NE a)
apply hyp_arith_rew
done

(*right successor law for multiplication*)
lemma mult_succ_right: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #* succ(b) = a #+ (a #* b) : N"
apply (NE a)
apply (hyp_arith_rew add_assoc [THEN sym_elem])
apply (assumption | rule add_commute mult_typingL add_typingL intrL_rls refl_elem)+
done

(*Commutative law for multiplication*)
lemma mult_commute: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #* b = b #* a : N"
apply (NE a)
apply (hyp_arith_rew mult_0_right mult_succ_right)
done

(*addition distributes over multiplication*)
lemma add_mult_distrib: "\<lbrakk>a:N; b:N; c:N\<rbrakk> \<Longrightarrow> (a #+ b) #* c = (a #* c) #+ (b #* c) : N"
apply (NE a)
apply (hyp_arith_rew add_assoc [THEN sym_elem])
done

(*Associative law for multiplication*)
lemma mult_assoc: "\<lbrakk>a:N; b:N; c:N\<rbrakk> \<Longrightarrow> (a #* b) #* c = a #* (b #* c) : N"
apply (NE a)
apply (hyp_arith_rew add_mult_distrib)
done

subsection {* Difference *}

text {*
Difference on natural numbers, without negative numbers
  a - b = 0  iff  a<=b    a - b = succ(c) iff a>b   *}

lemma diff_self_eq_0: "a:N \<Longrightarrow> a - a = 0 : N"
apply (NE a)
apply hyp_arith_rew
done

lemma add_0_right: "\<lbrakk>c : N; 0 : N; c : N\<rbrakk> \<Longrightarrow> c #+ 0 = c : N"
  by (rule addC0 [THEN [3] add_commute [THEN trans_elem]])

(*Addition is the inverse of subtraction: if b<=x then b#+(x-b) = x.
  An example of induction over a quantified formula (a product).
  Uses rewriting with a quantified, implicative inductive hypothesis.*)
schematic_lemma add_diff_inverse_lemma:
  "b:N \<Longrightarrow> ?a : PROD x:N. Eq(N, b-x, 0) --> Eq(N, b #+ (x-b), x)"
apply (NE b)
(*strip one "universal quantifier" but not the "implication"*)
apply (rule_tac [3] intr_rls)
(*case analysis on x in
    (succ(u) <= x) --> (succ(u)#+(x-succ(u)) = x) *)
prefer 4
apply (NE x)
apply assumption
(*Prepare for simplification of types -- the antecedent succ(u)<=x *)
apply (rule_tac [2] replace_type)
apply (rule_tac [1] replace_type)
apply arith_rew
(*Solves first 0 goal, simplifies others.  Two sugbgoals remain.
  Both follow by rewriting, (2) using quantified induction hyp*)
apply intr (*strips remaining PRODs*)
apply (hyp_arith_rew add_0_right)
apply assumption
done

(*Version of above with premise   b-a=0   i.e.    a >= b.
  Using ProdE does not work -- for ?B(?a) is ambiguous.
  Instead, add_diff_inverse_lemma states the desired induction scheme
    the use of RS below instantiates Vars in ProdE automatically. *)
lemma add_diff_inverse: "\<lbrakk>a:N; b:N; b - a = 0 : N\<rbrakk> \<Longrightarrow> b #+ (a-b) = a : N"
apply (rule EqE)
apply (rule add_diff_inverse_lemma [THEN ProdE, THEN ProdE])
apply (assumption | rule EqI)+
done

subsection {* Absolute difference *}

(*typing of absolute difference: short and long versions*)

lemma absdiff_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a |-| b : N"
apply (unfold arith_defs)
apply typechk
done

lemma absdiff_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a |-| b = c |-| d : N"
apply (unfold arith_defs)
apply equal
done

lemma absdiff_self_eq_0: "a:N \<Longrightarrow> a |-| a = 0 : N"
apply (unfold absdiff_def)
apply (arith_rew diff_self_eq_0)
done

lemma absdiffC0: "a:N \<Longrightarrow> 0 |-| a = a : N"
apply (unfold absdiff_def)
apply hyp_arith_rew
done

lemma absdiff_succ_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) |-| succ(b)  =  a |-| b : N"
apply (unfold absdiff_def)
apply hyp_arith_rew
done

(*Note how easy using commutative laws can be?  ...not always... *)
lemma absdiff_commute: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a |-| b = b |-| a : N"
apply (unfold absdiff_def)
apply (rule add_commute)
apply (typechk diff_typing)
done

(*If a+b=0 then a=0.   Surprisingly tedious*)
schematic_lemma add_eq0_lemma: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> ?c : PROD u: Eq(N,a#+b,0) .  Eq(N,a,0)"
apply (NE a)
apply (rule_tac [3] replace_type)
apply arith_rew
apply intr (*strips remaining PRODs*)
apply (rule_tac [2] zero_ne_succ [THEN FE])
apply (erule_tac [3] EqE [THEN sym_elem])
apply (typechk add_typing)
done

(*Version of above with the premise  a+b=0.
  Again, resolution instantiates variables in ProdE *)
lemma add_eq0: "\<lbrakk>a:N; b:N; a #+ b = 0 : N\<rbrakk> \<Longrightarrow> a = 0 : N"
apply (rule EqE)
apply (rule add_eq0_lemma [THEN ProdE])
apply (rule_tac [3] EqI)
apply typechk
done

(*Here is a lemma to infer a-b=0 and b-a=0 from a|-|b=0, below. *)
schematic_lemma absdiff_eq0_lem:
  "\<lbrakk>a:N; b:N; a |-| b = 0 : N\<rbrakk> \<Longrightarrow> ?a : SUM v: Eq(N, a-b, 0) . Eq(N, b-a, 0)"
apply (unfold absdiff_def)
apply intr
apply eqintr
apply (rule_tac [2] add_eq0)
apply (rule add_eq0)
apply (rule_tac [6] add_commute [THEN trans_elem])
apply (typechk diff_typing)
done

(*if  a |-| b = 0  then  a = b
  proof: a-b=0 and b-a=0, so b = a+(b-a) = a+0 = a*)
lemma absdiff_eq0: "\<lbrakk>a |-| b = 0 : N; a:N; b:N\<rbrakk> \<Longrightarrow> a = b : N"
apply (rule EqE)
apply (rule absdiff_eq0_lem [THEN SumE])
apply eqintr
apply (rule add_diff_inverse [THEN sym_elem, THEN trans_elem])
apply (erule_tac [3] EqE)
apply (hyp_arith_rew add_0_right)
done

subsection {* Remainder and Quotient *}

(*typing of remainder: short and long versions*)

lemma mod_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a mod b : N"
apply (unfold mod_def)
apply (typechk absdiff_typing)
done

lemma mod_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a mod b = c mod d : N"
apply (unfold mod_def)
apply (equal absdiff_typingL)
done

(*computation for  mod : 0 and successor cases*)

lemma modC0: "b:N \<Longrightarrow> 0 mod b = 0 : N"
apply (unfold mod_def)
apply (rew absdiff_typing)
done

lemma modC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow>
  succ(a) mod b = rec(succ(a mod b) |-| b, 0, \<lambda>x y. succ(a mod b)) : N"
apply (unfold mod_def)
apply (rew absdiff_typing)
done

(*typing of quotient: short and long versions*)

lemma div_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a div b : N"
apply (unfold div_def)
apply (typechk absdiff_typing mod_typing)
done

lemma div_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a div b = c div d : N"
apply (unfold div_def)
apply (equal absdiff_typingL mod_typingL)
done

lemmas div_typing_rls = mod_typing div_typing absdiff_typing

(*computation for quotient: 0 and successor cases*)

lemma divC0: "b:N \<Longrightarrow> 0 div b = 0 : N"
apply (unfold div_def)
apply (rew mod_typing absdiff_typing)
done

lemma divC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow>
  succ(a) div b = rec(succ(a) mod b, succ(a div b), \<lambda>x y. a div b) : N"
apply (unfold div_def)
apply (rew mod_typing)
done

(*Version of above with same condition as the  mod  one*)
lemma divC_succ2: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow>
  succ(a) div b =rec(succ(a mod b) |-| b, succ(a div b), \<lambda>x y. a div b) : N"
apply (rule divC_succ [THEN trans_elem])
apply (rew div_typing_rls modC_succ)
apply (NE "succ (a mod b) |-|b")
apply (rew mod_typing div_typing absdiff_typing)
done

(*for case analysis on whether a number is 0 or a successor*)
lemma iszero_decidable: "a:N \<Longrightarrow> rec(a, inl(eq), \<lambda>ka kb. inr(<ka, eq>)) :
                      Eq(N,a,0) + (SUM x:N. Eq(N,a, succ(x)))"
apply (NE a)
apply (rule_tac [3] PlusI_inr)
apply (rule_tac [2] PlusI_inl)
apply eqintr
apply equal
done

(*Main Result.  Holds when b is 0 since   a mod 0 = a     and    a div 0 = 0  *)
lemma mod_div_equality: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a mod b #+ (a div b) #* b = a : N"
apply (NE a)
apply (arith_rew div_typing_rls modC0 modC_succ divC0 divC_succ2)
apply (rule EqE)
(*case analysis on   succ(u mod b)|-|b  *)
apply (rule_tac a1 = "succ (u mod b) |-| b" in iszero_decidable [THEN PlusE])
apply (erule_tac [3] SumE)
apply (hyp_arith_rew div_typing_rls modC0 modC_succ divC0 divC_succ2)
(*Replace one occurrence of  b  by succ(u mod b).  Clumsy!*)
apply (rule add_typingL [THEN trans_elem])
apply (erule EqE [THEN absdiff_eq0, THEN sym_elem])
apply (rule_tac [3] refl_elem)
apply (hyp_arith_rew div_typing_rls)
done

end


(*
  Copyright (c) 2014-2019 by Clemens Ballarin
  This file is licensed under the 3-clause BSD license.
*)

theory Set_Theory imports "HOL-Library.FuncSet" begin

hide_const map
hide_const partition

no_notation divide (infixl "'/" 70)
no_notation inverse_divide (infixl "'/" 70)

text \<open>
  Each statement in the formal text is annotated with the location of the originating statement
  in Jacobson's text @{cite Jacobson1985}.  Each fact that Jacobson states explicitly is marked
  as @{command theorem} unless it is translated to a @{command sublocale} declaration.
  Literal quotations from Jacobson's text are reproduced in double quotes.

  Auxiliary results needed for the formalisation that cannot be found in Jacobson's text are marked
  as @{command lemma} or are @{command interpretation}s.  Such results are annotated with the
  location of a related statement.  For example, the introduction rule of a constant is annotated
  with the location of the definition of the corresponding operation.
\<close>

section \<open>Concepts from Set Theory.  The Integers\<close>

abbreviation complement_in_of:: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" ("_\<setminus>_" [75,75]65)
  where "A \<setminus> B \<equiv> A-B"

lemma Diff_Int_nAry:"(S \<setminus> \<Inter> F) = (\<Union>x\<in>F . S \<setminus> x)"
  by auto

lemma Diff_Un_nAry:"(S \<setminus> \<Union> F) = S \<inter> ( \<Inter>x\<in>F . S \<setminus> x)"
  by auto

lemma double_diff: "U \<subseteq> S \<Longrightarrow> S\<setminus>(S\<setminus>U) = U"
  by auto

lemma diff_as_union : "(S\<setminus>A)\<setminus>B = S \<setminus> (A \<union> B)"
  by auto

lemma Diff_eq_on: "A \<subseteq> S \<Longrightarrow> A \<setminus> B = A \<inter> (S \<setminus> B)"
  by auto

lemma Diff_dist: "(A \<setminus> V) \<union> (A \<setminus> U) = A \<setminus> (U \<inter> V)"
  by auto

subsection \<open>The Cartesian Product Set.  Maps\<close>

text \<open>Maps as extensional HOL functions\<close>
text \<open>p 5, ll 21--25\<close>
locale map =
  fixes \<alpha> and S and T
  assumes graph [intro, simp]: "\<alpha> \<in> S \<rightarrow>\<^sub>E T"
begin

text \<open>p 5, ll 21--25\<close>
lemma map_closed [intro, simp]:
  "a \<in> S \<Longrightarrow> \<alpha> a \<in> T"
using graph by fast

text \<open>p 5, ll 21--25\<close>
lemma map_undefined [intro]:
  "a \<notin> S \<Longrightarrow> \<alpha> a = undefined"
using graph by fast

end (* map *)

abbreviation preimage:: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'a set" ("_ \<^sup>\<inverse> _ _" [90,90,1000]90)
  where "f\<^sup>\<inverse> X V \<equiv> (vimage f V) \<inter> X"

text \<open>p 7, ll 7--8\<close>
locale surjective_map = map + assumes surjective [intro]: "\<alpha> ` S = T"

text \<open>p 7, ll 8--9\<close>
locale injective_map = map + assumes injective [intro, simp]: "inj_on \<alpha> S"

text \<open>Enables locale reasoning about the inverse @{term "restrict (inv_into S \<alpha>) T"} of @{term \<alpha>}.\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective =
  fixes \<alpha> and S and T
  assumes bijective [intro, simp]: "bij_betw \<alpha> S T"

text \<open>
  Exploit existing knowledge about @{term bij_betw} rather than extending @{locale surjective_map}
  and @{locale injective_map}.
\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective_map = map + bijective begin

text \<open>p 7, ll 9--10\<close>
sublocale surjective_map by unfold_locales (simp add: bij_betw_imp_surj_on)

text \<open>p 7, ll 9--10\<close>
sublocale injective_map using bij_betw_def by unfold_locales fast

text \<open>p 9, ll 12--13\<close>
sublocale inverse: map "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: inv_into_into surjective)

text \<open>p 9, ll 12--13\<close>
sublocale inverse: bijective "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: bij_betw_inv_into surjective)

end (* bijective_map *)

definition inverse_map:: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('b \<Rightarrow> 'a)"
  where "inverse_map f S T \<equiv> restrict (inv_into S f) T"

text \<open>p 8, ll 14--15\<close>
abbreviation "identity S \<equiv> (\<lambda>x \<in> S. x)"

lemma preimage_of_inter:
  fixes f::"'a \<Rightarrow> 'b" and X::"'a set" and V::"'b set" and V'::"'b set"
  shows "f\<^sup>\<inverse> X (V \<inter> V') = (f\<^sup>\<inverse> X V) \<inter> (f\<^sup>\<inverse> X V')"
  by blast

lemma preimage_identity_self: "identity A \<^sup>\<inverse> A B = B \<inter> A"
  by (simp add: vimage_inter_cong)

text \<open>Simplification actually replaces the RHS by the LHS\<close>
lemma preimage_vimage_eq: "(f \<^sup>\<inverse> (f -` U') U) \<inter> X = f\<^sup>\<inverse> X (U \<inter> U')"
  by simp

lemma bijective_map_preimage:
  assumes "bijective_map f S T"
  shows "bijective_map (inverse_map f S T) T S"
proof
  show "inverse_map f S T \<in> T \<rightarrow>\<^sub>E S"
    by (simp add: assms bij_betw_imp_funcset bij_betw_inv_into bijective.bijective bijective_map.axioms(2) inverse_map_def)
  show "bij_betw (inverse_map f S T) T S"
    using assms by (simp add: bij_betw_inv_into bijective_def bijective_map_def inverse_map_def)
qed

lemma inverse_map_identity [simp]:
  "inverse_map (identity S) S S = identity S"
  by (metis Id_compose compose_id_inv_into image_ident image_restrict_eq inv_into_funcset inverse_map_def restrict_extensional)

context map begin

text \<open>p 8, ll 18--20; p 9, ll 1--8\<close>
theorem bij_betw_iff_has_inverse:
  "bij_betw \<alpha> S T \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. compose S \<beta> \<alpha> = identity S \<and> compose T \<alpha> \<beta> = identity T)"
    (is "_ \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>)")
proof
  let ?inv = "restrict (inv_into S \<alpha>) T"
  assume "bij_betw \<alpha> S T"
  then have "?INV ?inv" and "?inv \<in> T \<rightarrow>\<^sub>E S"
    by (simp_all add: compose_inv_into_id bij_betw_imp_surj_on compose_id_inv_into bij_betw_imp_funcset bij_betw_inv_into)
  then show "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>" ..
next
  assume "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>"
  then obtain \<beta> where "\<alpha> \<in> S \<rightarrow> T" "\<beta> \<in> T \<rightarrow> S" "\<And>x. x \<in> S \<Longrightarrow> \<beta> (\<alpha> x) = x" "\<And>y. y \<in> T \<Longrightarrow> \<alpha> (\<beta> y) = y"
    by (metis PiE_restrict compose_eq graph restrict_PiE restrict_apply)
  then show "bij_betw \<alpha> S T" by (rule bij_betwI)
qed

end (* map *)

abbreviation composing ("_ \<circ> _ \<down> _" [60,0,60]59)
  where "g \<circ> f \<down> D \<equiv> compose D g f"

lemma comp_maps:
  assumes "Set_Theory.map \<eta> A B" and "Set_Theory.map \<theta> B C"
  shows "Set_Theory.map (\<theta> \<circ> \<eta> \<down> A) A C"
proof-
  have "(\<theta> \<circ> \<eta> \<down> A) \<in> A \<rightarrow>\<^sub>E C"
    using assms by (metis Int_iff PiE_def compose_def funcset_compose map.graph restrict_extensional)
  thus ?thesis by (simp add: Set_Theory.map_def)
qed

lemma undefined_is_map_on_empty:
  fixes f:: "'a set \<Rightarrow> 'b set"
  assumes "f = (\<lambda>x. undefined)"
  shows "map f {} {}"
  using assms by (simp add: map.intro)

lemma restrict_on_source:
  assumes "map f S T"
  shows "restrict f S = f"
  using assms by (meson PiE_restrict map.graph)

lemma restrict_further:
  assumes "map f S T" and "U \<subseteq> S" and "V \<subseteq> U"
  shows "restrict (restrict f U) V = restrict f V"
  using assms by (simp add: inf.absorb_iff2)

lemma map_eq:
  assumes "map f S T" and "map g S T" and "\<And>x. x \<in> S \<Longrightarrow> f x = g x"
  shows "f = g"
  using assms by (metis restrict_ext restrict_on_source)

lemma image_subset_of_target:
  assumes "map f S T"
  shows "f ` S \<subseteq> T"
  using assms by (meson image_subsetI map.map_closed)

subsection \<open>Equivalence Relations.  Factoring a Map Through an Equivalence Relation\<close>

text \<open>p 11, ll 6--11\<close>
locale equivalence =
  fixes S and E
  assumes closed [intro, simp]: "E \<subseteq> S \<times> S"
    and reflexive [intro, simp]: "a \<in> S \<Longrightarrow> (a, a) \<in> E"
    and symmetric [sym]: "(a, b) \<in> E \<Longrightarrow> (b, a) \<in> E"
    and transitive [trans]: "\<lbrakk> (a, b) \<in> E; (b, c) \<in> E \<rbrakk> \<Longrightarrow> (a, c) \<in> E"
begin

text \<open>p 11, ll 6--11\<close>
lemma left_closed [intro]: (* inefficient as a simp rule *)
  "(a, b) \<in> E \<Longrightarrow> a \<in> S"
  using closed by blast

text \<open>p 11, ll 6--11\<close>

end (* equivalence *)

text \<open>p 11, ll 16--20\<close>
locale partition =
  fixes S and P
  assumes subset: "P \<subseteq> Pow S"
    and non_vacuous: "{} \<notin> P"
    and complete: "\<Union>P = S"
    and disjoint: "\<lbrakk> A \<in> P; B \<in> P; A \<noteq> B \<rbrakk> \<Longrightarrow> A \<inter> B = {}"

context equivalence begin

text \<open>p 11, ll 24--26\<close>
definition "Class = (\<lambda>a \<in> S. {b \<in> S. (b, a) \<in> E})"

text \<open>p 11, ll 24--26\<close>
lemma Class_closed [dest]:
  "\<lbrakk> a \<in> Class b; b \<in> S \<rbrakk> \<Longrightarrow> a \<in> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_closed2 [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<subseteq> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Class a = undefined"
  unfolding Class_def by simp

text \<open>p 11, ll 24--26\<close>
lemma ClassI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> a \<in> Class b"
  unfolding Class_def by (simp add: left_closed right_closed)

text \<open>p 11, ll 24--26\<close>
lemma Class_revI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> b \<in> Class a"
  by (blast intro: symmetric)

text \<open>p 11, ll 24--26\<close>
lemma ClassD [dest]:
  "\<lbrakk> b \<in> Class a; a \<in> S \<rbrakk> \<Longrightarrow> (b, a) \<in> E"
  unfolding Class_def by simp

text \<open>p 11, ll 30--31\<close>
theorem Class_self [intro, simp]:
  "a \<in> S \<Longrightarrow> a \<in> Class a"
  unfolding Class_def by simp

text \<open>p 11, l 31; p 12, l 1\<close>
theorem Class_Union [simp]:
  "(\<Union>a\<in>S. Class a) = S"
  by blast

text \<open>p 11, ll 2--3\<close>
theorem Class_subset:
  "(a, b) \<in> E \<Longrightarrow> Class a \<subseteq> Class b"
proof
  fix a and b and c
  assume "(a, b) \<in> E" and "c \<in> Class a"
  then have "(c, a) \<in> E" by auto
  also note \<open>(a, b) \<in> E\<close>
  finally have "(c, b) \<in> E" by simp
  then show "c \<in> Class b" by auto
qed

text \<open>p 11, ll 3--4\<close>
theorem Class_eq:
  "(a, b) \<in> E \<Longrightarrow> Class a = Class b"
  by (auto intro!: Class_subset intro: symmetric)

text \<open>p 12, ll 1--5\<close>
theorem Class_equivalence:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> (a, b) \<in> E"
proof
  fix a and b
  assume "a \<in> S" "b \<in> S" "Class a = Class b"
  then have "a \<in> Class a" by auto
  also note \<open>Class a = Class b\<close>
  finally show "(a, b) \<in> E" by (fast intro: \<open>b \<in> S\<close>)
qed (rule Class_eq)

text \<open>p 12, ll 5--7\<close>
theorem not_disjoint_implies_equal:
  assumes not_disjoint: "Class a \<inter> Class b \<noteq> {}"
  assumes closed: "a \<in> S" "b \<in> S"
  shows "Class a = Class b"
proof -
  from not_disjoint and closed obtain c where witness: "c \<in> Class a \<inter> Class b" by fast
  with closed have "(a, c) \<in> E" by (blast intro: symmetric)
  also from witness and closed have "(c, b) \<in> E" by fast
  finally show ?thesis by (rule Class_eq)
qed

text \<open>p 12, ll 7--8\<close>
definition "Partition = Class ` S"

text \<open>p 12, ll 7--8\<close>
lemma Class_in_Partition [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<in> Partition"
  unfolding Partition_def by fast

text \<open>p 12, ll 7--8\<close>
theorem partition:
  "partition S Partition"
proof
  fix A and B
  assume closed: "A \<in> Partition" "B \<in> Partition"
  then obtain a and b where eq: "A = Class a" "B = Class b" and ab: "a \<in> S" "b \<in> S"
  unfolding Partition_def by auto
  assume distinct: "A \<noteq> B"
  then show "A \<inter> B = {}"
  proof (rule contrapos_np)
    assume not_disjoint: "A \<inter> B \<noteq> {}"
    then show "A = B" by (simp add: eq) (metis not_disjoint_implies_equal ab)
  qed
qed (auto simp: Partition_def)

end (* equivalence *)

context partition begin

text \<open>p 12, ll 9--10\<close>
theorem block_exists:
  "a \<in> S \<Longrightarrow> \<exists>A. a \<in> A \<and> A \<in> P"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
theorem block_unique:
  "\<lbrakk> a \<in> A; A \<in> P; a \<in> B; B \<in> P \<rbrakk> \<Longrightarrow> A = B"
  using disjoint by blast

text \<open>p 12, ll 9--10\<close>
lemma block_closed [intro]: (* inefficient as a simp rule *)
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> a \<in> S"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
lemma element_exists:
  "A \<in> P \<Longrightarrow> \<exists>a \<in> S. a \<in> A"
  by (metis non_vacuous block_closed all_not_in_conv)

text \<open>p 12, ll 9--10\<close>
definition "Block = (\<lambda>a \<in> S. THE A. a \<in> A \<and> A \<in> P)"

text \<open>p 12, ll 9--10\<close>
lemma Block_closed [intro, simp]:
  assumes [intro]: "a \<in> S" shows "Block a \<in> P"
proof -
  obtain A where "a \<in> A" "A \<in> P" using block_exists by blast
  then show ?thesis
    apply (auto simp: Block_def)
    apply (rule theI2)
      apply (auto dest: block_unique)
    done
qed

text \<open>p 12, ll 9--10\<close>
lemma Block_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Block a = undefined"
  unfolding Block_def by simp

text \<open>p 12, ll 9--10\<close>
lemma Block_self:
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> Block a = A"
  apply (simp add: Block_def block_closed)
  apply (rule the_equality)
   apply (auto dest: block_unique)
  done

text \<open>p 12, ll 10--11\<close>
definition "Equivalence = {(a, b) . \<exists>A \<in> P. a \<in> A \<and> b \<in> A}"

text \<open>p 12, ll 11--12\<close>
theorem equivalence: "equivalence S Equivalence"
proof
  show "Equivalence \<subseteq> S \<times> S" unfolding Equivalence_def using subset by auto
next
  fix a
  assume "a \<in> S"
  then show "(a, a) \<in> Equivalence" unfolding Equivalence_def using complete by auto
next
  fix a and b
  assume "(a, b) \<in> Equivalence"
  then show "(b, a) \<in> Equivalence" unfolding Equivalence_def by auto
next
  fix a and b and c
  assume "(a, b) \<in> Equivalence" "(b, c) \<in> Equivalence"
  then show "(a, c) \<in> Equivalence" unfolding Equivalence_def using disjoint by auto
qed

text \<open>Temporarily introduce equivalence associated to partition.\<close>
text \<open>p 12, ll 12--14\<close>
interpretation equivalence S Equivalence by (rule equivalence)

text \<open>p 12, ll 12--14\<close>
theorem Class_is_Block:
  assumes "a \<in> S" shows "Class a = Block a"
proof -
  from \<open>a \<in> S\<close> and block_exists obtain A where block: "a \<in> A \<and> A \<in> P" by blast
  show ?thesis
    apply (simp add: Block_def Class_def)
    apply (rule theI2)
      apply (rule block)
     apply (metis block block_unique)
    apply (auto dest: block_unique simp: Equivalence_def)
    done
qed

text \<open>p 12, l 14\<close>
lemma Class_equals_Block:
  "Class = Block"
proof
  fix x show "Class x = Block x"
  by (cases "x \<in> S") (auto simp: Class_is_Block)
qed

text \<open>p 12, l 14\<close>
theorem partition_of_equivalence:
  "Partition = P"
  by (auto simp add: Partition_def Class_equals_Block image_iff) (metis Block_self element_exists)

end (* partition *)

context equivalence begin

text \<open>p 12, ll 14--17\<close>
interpretation partition S Partition by (rule partition)

text \<open>p 12, ll 14--17\<close>
theorem equivalence_of_partition:
  "Equivalence = E"
  unfolding Equivalence_def unfolding Partition_def by auto (metis ClassD Class_closed Class_eq)

end (* equivalence *)

text \<open>p 12, l 14\<close>
sublocale partition \<subseteq> equivalence S Equivalence
  rewrites "equivalence.Partition S Equivalence = P" and "equivalence.Class S Equivalence = Block"
    apply (rule equivalence)
   apply (rule partition_of_equivalence)
  apply (rule Class_equals_Block)
  done

text \<open>p 12, ll 14--17\<close>
sublocale equivalence \<subseteq> partition S Partition
  rewrites "partition.Equivalence Partition = E" and "partition.Block S Partition = Class"
    apply (rule partition)
   apply (rule equivalence_of_partition)
  apply (metis equivalence_of_partition partition partition.Class_equals_Block)
  done

text \<open>Unfortunately only effective on input\<close>
text \<open>p 12, ll 18--20\<close>
notation equivalence.Partition (infixl "'/" 75)

context equivalence begin

text \<open>p 12, ll 18--20\<close>
lemma representant_exists [dest]: "A \<in> S / E \<Longrightarrow> \<exists>a\<in>S. a \<in> A \<and> A = Class a"
  by (metis Block_self element_exists)

text \<open>p 12, ll 18--20\<close>
lemma quotient_ClassE: "A \<in> S / E \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> P (Class a)) \<Longrightarrow> P A"
  using representant_exists by blast

end (* equivalence *)

text \<open>p 12, ll 21--23\<close>
sublocale equivalence \<subseteq> natural: surjective_map Class S "S / E"
  by unfold_locales force+

text \<open>Technical device to achieve Jacobson's syntax; context where @{text \<alpha>} is not a parameter.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation_notation = fixes S :: "'a set" begin

text \<open>p 12, ll 25--26\<close>
definition Fiber_Relation ("E'(_')") where "Fiber_Relation \<alpha> = {(x, y). x \<in> S \<and> y \<in> S \<and> \<alpha> x = \<alpha> y}"

end (* fiber_relation_notation *)

text \<open>
  Context where classes and the induced map are defined through the fiber relation.
  This will be the case for monoid homomorphisms but not group homomorphisms.
\<close>
text \<open>Avoids infinite interpretation chain.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation = map begin

text \<open>Install syntax\<close>
text \<open>p 12, ll 25--26\<close>
sublocale fiber_relation_notation .

text \<open>p 12, ll 26--27\<close>
sublocale equivalence where E = "E(\<alpha>)"
  unfolding Fiber_Relation_def by unfold_locales auto

text \<open>``define $\bar{\alpha}$ by $\bar{\alpha}(\bar{a}) = \alpha(a)$''\<close>
text \<open>p 13, ll 8--9\<close>
definition "induced = (\<lambda>A \<in> S / E(\<alpha>). THE b. \<exists>a \<in> A. b = \<alpha> a)"

text \<open>p 13, l 10\<close>
theorem Fiber_equality:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> \<alpha> a = \<alpha> b"
  unfolding Class_equivalence unfolding Fiber_Relation_def by simp

text \<open>p 13, ll 8--9\<close>
theorem induced_Fiber_simp [simp]:
  assumes [intro, simp]: "a \<in> S" shows "induced (Class a) = \<alpha> a"
proof -
  have "(THE b. \<exists>a\<in>Class a. b = \<alpha> a) = \<alpha> a"
    by (rule the_equality) (auto simp: Fiber_equality [symmetric] Block_self block_closed)
  then show ?thesis unfolding induced_def by simp
qed

text \<open>p 13, ll 10--11\<close>
interpretation induced: map induced "S / E(\<alpha>)" T
proof (unfold_locales, rule)
  fix A
  assume [intro, simp]: "A \<in> S / E(\<alpha>)"
  obtain a where a: "a \<in> S" "a \<in> A" using element_exists by auto
  have "(THE b. \<exists>a\<in>A. b = \<alpha> a) \<in> T"
    apply (rule theI2)
    using a apply (auto simp: Fiber_equality [symmetric] Block_self block_closed)
    done
  then show "induced A \<in> T" unfolding induced_def by simp
qed (simp add: induced_def)

text \<open>p 13, ll 12--13\<close>
sublocale induced: injective_map induced "S / E(\<alpha>)" T
proof
  show "inj_on induced Partition"
    unfolding inj_on_def
    by (metis Fiber_equality Block_self element_exists induced_Fiber_simp)
qed

text \<open>p 13, ll 16--19\<close>
theorem factorization_lemma:
  "a \<in> S \<Longrightarrow> compose S induced Class a = \<alpha> a"
  by (simp add: compose_eq)

text \<open>p 13, ll 16--19\<close>
theorem factorization [simp]: "compose S induced Class = \<alpha>"
  by (rule ext) (simp add: compose_def map_undefined)

text \<open>p 14, ll 2--4\<close>
theorem uniqueness:
  assumes map: "\<beta> \<in> S / E(\<alpha>) \<rightarrow>\<^sub>E T"
    and factorization: "compose S \<beta> Class = \<alpha>"
  shows "\<beta> = induced"
proof
  fix A
  show "\<beta> A = induced A"
  proof (cases "A \<in> S / E(\<alpha>)")
    case True
    then obtain a where [simp]: "A = Class a" "a \<in> S" by fast
    then have "\<beta> (Class a) = \<alpha> a" by (metis compose_eq factorization)
    also have "\<dots> = induced (Class a)" by simp
    finally show ?thesis by simp
  qed (simp add: induced_def PiE_arb [OF map])
qed

end (* fiber_relation *)

end