(*  Title:      ZF/Induct/FoldSet.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory

A "fold" functional for finite sets.  For n non-negative we have
fold f e {x1,...,xn} = f x1 (... (f xn e)) where f is at
least left-commutative.
*)

theory FoldSet imports ZF begin

consts fold_set :: "[i, i, [i,i]=>i, i] => i"

inductive
  domains "fold_set(A, B, f,e)" \<subseteq> "Fin(A)*B"
  intros
    emptyI: "e\<in>B ==> <0, e>\<in>fold_set(A, B, f,e)"
    consI:  "[| x\<in>A; x \<notin>C;  <C,y> \<in> fold_set(A, B,f,e); f(x,y):B |]
                ==>  <cons(x,C), f(x,y)>\<in>fold_set(A, B, f, e)"
  type_intros Fin.intros

definition
  fold :: "[i, [i,i]=>i, i, i] => i"  ("fold[_]'(_,_,_')")  where
   "fold[B](f,e, A) == THE x. <A, x>\<in>fold_set(A, B, f,e)"

definition
   setsum :: "[i=>i, i] => i"  where
   "setsum(g, C) == if Finite(C) then
                     fold[int](%x y. g(x) $+ y, #0, C) else #0"

(** foldSet **)

inductive_cases empty_fold_setE: "<0, x> \<in> fold_set(A, B, f,e)"
inductive_cases cons_fold_setE: "<cons(x,C), y> \<in> fold_set(A, B, f,e)"

(* add-hoc lemmas *)

lemma cons_lemma1: "[| x\<notin>C; x\<notin>B |] ==> cons(x,B)=cons(x,C) \<longleftrightarrow> B = C"
by (auto elim: equalityE)

lemma cons_lemma2: "[| cons(x, B)=cons(y, C); x\<noteq>y; x\<notin>B; y\<notin>C |]
    ==>  B - {y} = C-{x} & x\<in>C & y\<in>B"
apply (auto elim: equalityE)
done

(* fold_set monotonicity *)
lemma fold_set_mono_lemma:
     "<C, x> \<in> fold_set(A, B, f, e)
      ==> \<forall>D. A<=D \<longrightarrow> <C, x> \<in> fold_set(D, B, f, e)"
apply (erule fold_set.induct)
apply (auto intro: fold_set.intros)
done

lemma fold_set_mono: " C<=A ==> fold_set(C, B, f, e) \<subseteq> fold_set(A, B, f, e)"
apply clarify
apply (frule fold_set.dom_subset [THEN subsetD], clarify)
apply (auto dest: fold_set_mono_lemma)
done

lemma fold_set_lemma:
     "<C, x>\<in>fold_set(A, B, f, e) ==> <C, x>\<in>fold_set(C, B, f, e) & C<=A"
apply (erule fold_set.induct)
apply (auto intro!: fold_set.intros intro: fold_set_mono [THEN subsetD])
done

(* Proving that fold_set is deterministic *)
lemma Diff1_fold_set:
     "[| <C-{x},y> \<in> fold_set(A, B, f,e);  x\<in>C; x\<in>A; f(x, y):B |]
      ==> <C, f(x, y)> \<in> fold_set(A, B, f, e)"
apply (frule fold_set.dom_subset [THEN subsetD])
apply (erule cons_Diff [THEN subst], rule fold_set.intros, auto)
done

locale fold_typing =
 fixes A and B and e and f
 assumes ftype [intro,simp]:  "[|x \<in> A; y \<in> B|] ==> f(x,y) \<in> B"
     and etype [intro,simp]:  "e \<in> B"
     and fcomm:  "[|x \<in> A; y \<in> A; z \<in> B|] ==> f(x, f(y, z))=f(y, f(x, z))"

lemma (in fold_typing) Fin_imp_fold_set:
     "C\<in>Fin(A) ==> (\<exists>x. <C, x> \<in> fold_set(A, B, f,e))"
apply (erule Fin_induct)
apply (auto dest: fold_set.dom_subset [THEN subsetD]
            intro: fold_set.intros etype ftype)
done

lemma Diff_sing_imp:
     "[|C - {b} = D - {a}; a \<noteq> b; b \<in> C|] ==> C = cons(b,D) - {a}"
by (blast elim: equalityE)

lemma (in fold_typing) fold_set_determ_lemma [rule_format]:
"n\<in>nat
 ==> \<forall>C. |C|<n \<longrightarrow>
   (\<forall>x. <C, x> \<in> fold_set(A, B, f,e)\<longrightarrow>
           (\<forall>y. <C, y> \<in> fold_set(A, B, f,e) \<longrightarrow> y=x))"
apply (erule nat_induct)
 apply (auto simp add: le_iff)
apply (erule fold_set.cases)
 apply (force elim!: empty_fold_setE)
apply (erule fold_set.cases)
 apply (force elim!: empty_fold_setE, clarify)
(*force simplification of "|C| < |cons(...)|"*)
apply (frule_tac a = Ca in fold_set.dom_subset [THEN subsetD, THEN SigmaD1])
apply (frule_tac a = Cb in fold_set.dom_subset [THEN subsetD, THEN SigmaD1])
apply (simp add: Fin_into_Finite [THEN Finite_imp_cardinal_cons])
apply (case_tac "x=xb", auto)
apply (simp add: cons_lemma1, blast)
txt\<open>case @{term "x\<noteq>xb"}\<close>
apply (drule cons_lemma2, safe)
apply (frule Diff_sing_imp, assumption+)
txt\<open>* LEVEL 17\<close>
apply (subgoal_tac "|Ca| \<le> |Cb|")
 prefer 2
 apply (rule succ_le_imp_le)
 apply (simp add: Fin_into_Finite Finite_imp_succ_cardinal_Diff
                  Fin_into_Finite [THEN Finite_imp_cardinal_cons])
apply (rule_tac C1 = "Ca-{xb}" in Fin_imp_fold_set [THEN exE])
 apply (blast intro: Diff_subset [THEN Fin_subset])
txt\<open>* LEVEL 24 *\<close>
apply (frule Diff1_fold_set, blast, blast)
apply (blast dest!: ftype fold_set.dom_subset [THEN subsetD])
apply (subgoal_tac "ya = f(xb,xa) ")
 prefer 2 apply (blast del: equalityCE)
apply (subgoal_tac "<Cb-{x}, xa> \<in> fold_set(A,B,f,e)")
 prefer 2 apply simp
apply (subgoal_tac "yb = f (x, xa) ")
 apply (drule_tac [2] C = Cb in Diff1_fold_set, simp_all)
  apply (blast intro: fcomm dest!: fold_set.dom_subset [THEN subsetD])
 apply (blast intro: ftype dest!: fold_set.dom_subset [THEN subsetD], blast)
done

lemma (in fold_typing) fold_set_determ:
     "[| <C, x>\<in>fold_set(A, B, f, e);
         <C, y>\<in>fold_set(A, B, f, e)|] ==> y=x"
apply (frule fold_set.dom_subset [THEN subsetD], clarify)
apply (drule Fin_into_Finite)
apply (unfold Finite_def, clarify)
apply (rule_tac n = "succ (n)" in fold_set_determ_lemma)
apply (auto intro: eqpoll_imp_lepoll [THEN lepoll_cardinal_le])
done

(** The fold function **)

lemma (in fold_typing) fold_equality:
     "<C,y> \<in> fold_set(A,B,f,e) ==> fold[B](f,e,C) = y"
apply (unfold fold_def)
apply (frule fold_set.dom_subset [THEN subsetD], clarify)
apply (rule the_equality)
 apply (rule_tac [2] A=C in fold_typing.fold_set_determ)
apply (force dest: fold_set_lemma)
apply (auto dest: fold_set_lemma)
apply (simp add: fold_typing_def, auto)
apply (auto dest: fold_set_lemma intro: ftype etype fcomm)
done

lemma fold_0 [simp]: "e \<in> B ==> fold[B](f,e,0) = e"
apply (unfold fold_def)
apply (blast elim!: empty_fold_setE intro: fold_set.intros)
done

text\<open>This result is the right-to-left direction of the subsequent result\<close>
lemma (in fold_typing) fold_set_imp_cons:
     "[| <C, y> \<in> fold_set(C, B, f, e); C \<in> Fin(A); c \<in> A; c\<notin>C |]
      ==> <cons(c, C), f(c,y)> \<in> fold_set(cons(c, C), B, f, e)"
apply (frule FinD [THEN fold_set_mono, THEN subsetD])
 apply assumption
apply (frule fold_set.dom_subset [of A, THEN subsetD])
apply (blast intro!: fold_set.consI intro: fold_set_mono [THEN subsetD])
done

lemma (in fold_typing) fold_cons_lemma [rule_format]:
"[| C \<in> Fin(A); c \<in> A; c\<notin>C |]
     ==> <cons(c, C), v> \<in> fold_set(cons(c, C), B, f, e) \<longleftrightarrow>
         (\<exists>y. <C, y> \<in> fold_set(C, B, f, e) & v = f(c, y))"
apply auto
 prefer 2 apply (blast intro: fold_set_imp_cons)
 apply (frule_tac Fin.consI [of c, THEN FinD, THEN fold_set_mono, THEN subsetD], assumption+)
apply (frule_tac fold_set.dom_subset [of A, THEN subsetD])
apply (drule FinD)
apply (rule_tac A1 = "cons(c,C)" and f1=f and B1=B and C1=C and e1=e in fold_typing.Fin_imp_fold_set [THEN exE])
apply (blast intro: fold_typing.intro ftype etype fcomm)
apply (blast intro: Fin_subset [of _ "cons(c,C)"] Finite_into_Fin
             dest: Fin_into_Finite)
apply (rule_tac x = x in exI)
apply (auto intro: fold_set.intros)
apply (drule_tac fold_set_lemma [of C], blast)
apply (blast intro!: fold_set.consI
             intro: fold_set_determ fold_set_mono [THEN subsetD]
             dest: fold_set.dom_subset [THEN subsetD])
done

lemma (in fold_typing) fold_cons:
     "[| C\<in>Fin(A); c\<in>A; c\<notin>C|]
      ==> fold[B](f, e, cons(c, C)) = f(c, fold[B](f, e, C))"
apply (unfold fold_def)
apply (simp add: fold_cons_lemma)
apply (rule the_equality, auto)
 apply (subgoal_tac [2] "\<langle>C, y\<rangle> \<in> fold_set(A, B, f, e)")
  apply (drule Fin_imp_fold_set)
apply (auto dest: fold_set_lemma  simp add: fold_def [symmetric] fold_equality)
apply (blast intro: fold_set_mono [THEN subsetD] dest!: FinD)
done

lemma (in fold_typing) fold_type [simp,TC]:
     "C\<in>Fin(A) ==> fold[B](f,e,C):B"
apply (erule Fin_induct)
apply (simp_all add: fold_cons ftype etype)
done

lemma (in fold_typing) fold_commute [rule_format]:
     "[| C\<in>Fin(A); c\<in>A |]
      ==> (\<forall>y\<in>B. f(c, fold[B](f, y, C)) = fold[B](f, f(c, y), C))"
apply (erule Fin_induct)
apply (simp_all add: fold_typing.fold_cons [of A B _ f]
                     fold_typing.fold_type [of A B _ f]
                     fold_typing_def fcomm)
done

lemma (in fold_typing) fold_nest_Un_Int:
     "[| C\<in>Fin(A); D\<in>Fin(A) |]
      ==> fold[B](f, fold[B](f, e, D), C) =
          fold[B](f, fold[B](f, e, (C \<inter> D)), C \<union> D)"
apply (erule Fin_induct, auto)
apply (simp add: Un_cons Int_cons_left fold_type fold_commute
                 fold_typing.fold_cons [of A _ _ f]
                 fold_typing_def fcomm cons_absorb)
done

lemma (in fold_typing) fold_nest_Un_disjoint:
     "[| C\<in>Fin(A); D\<in>Fin(A); C \<inter> D = 0 |]
      ==> fold[B](f,e,C \<union> D) =  fold[B](f, fold[B](f,e,D), C)"
by (simp add: fold_nest_Un_Int)

lemma Finite_cons_lemma: "Finite(C) ==> C\<in>Fin(cons(c, C))"
apply (drule Finite_into_Fin)
apply (blast intro: Fin_mono [THEN subsetD])
done

subsection\<open>The Operator @{term setsum}\<close>

lemma setsum_0 [simp]: "setsum(g, 0) = #0"
by (simp add: setsum_def)

lemma setsum_cons [simp]:
     "Finite(C) ==>
      setsum(g, cons(c,C)) =
        (if c \<in> C then setsum(g,C) else g(c) $+ setsum(g,C))"
apply (auto simp add: setsum_def Finite_cons cons_absorb)
apply (rule_tac A = "cons (c, C)" in fold_typing.fold_cons)
apply (auto intro: fold_typing.intro Finite_cons_lemma)
done

lemma setsum_K0: "setsum((%i. #0), C) = #0"
apply (case_tac "Finite (C) ")
 prefer 2 apply (simp add: setsum_def)
apply (erule Finite_induct, auto)
done

(*The reversed orientation looks more natural, but LOOPS as a simprule!*)
lemma setsum_Un_Int:
     "[| Finite(C); Finite(D) |]
      ==> setsum(g, C \<union> D) $+ setsum(g, C \<inter> D)
        = setsum(g, C) $+ setsum(g, D)"
apply (erule Finite_induct)
apply (simp_all add: Int_cons_right cons_absorb Un_cons Int_commute Finite_Un
                     Int_lower1 [THEN subset_Finite])
done

lemma setsum_type [simp,TC]: "setsum(g, C):int"
apply (case_tac "Finite (C) ")
 prefer 2 apply (simp add: setsum_def)
apply (erule Finite_induct, auto)
done

lemma setsum_Un_disjoint:
     "[| Finite(C); Finite(D); C \<inter> D = 0 |]
      ==> setsum(g, C \<union> D) = setsum(g, C) $+ setsum(g,D)"
apply (subst setsum_Un_Int [symmetric])
apply (subgoal_tac [3] "Finite (C \<union> D) ")
apply (auto intro: Finite_Un)
done

lemma Finite_RepFun [rule_format (no_asm)]:
     "Finite(I) ==> (\<forall>i\<in>I. Finite(C(i))) \<longrightarrow> Finite(RepFun(I, C))"
apply (erule Finite_induct, auto)
done

lemma setsum_UN_disjoint [rule_format (no_asm)]:
     "Finite(I)
      ==> (\<forall>i\<in>I. Finite(C(i))) \<longrightarrow>
          (\<forall>i\<in>I. \<forall>j\<in>I. i\<noteq>j \<longrightarrow> C(i) \<inter> C(j) = 0) \<longrightarrow>
          setsum(f, \<Union>i\<in>I. C(i)) = setsum (%i. setsum(f, C(i)), I)"
apply (erule Finite_induct, auto)
apply (subgoal_tac "\<forall>i\<in>B. x \<noteq> i")
 prefer 2 apply blast
apply (subgoal_tac "C (x) \<inter> (\<Union>i\<in>B. C (i)) = 0")
 prefer 2 apply blast
apply (subgoal_tac "Finite (\<Union>i\<in>B. C (i)) & Finite (C (x)) & Finite (B) ")
apply (simp (no_asm_simp) add: setsum_Un_disjoint)
apply (auto intro: Finite_Union Finite_RepFun)
done

lemma setsum_addf: "setsum(%x. f(x) $+ g(x),C) = setsum(f, C) $+ setsum(g, C)"
apply (case_tac "Finite (C) ")
 prefer 2 apply (simp add: setsum_def)
apply (erule Finite_induct, auto)
done

lemma fold_set_cong:
     "[| A=A'; B=B'; e=e'; (\<forall>x\<in>A'. \<forall>y\<in>B'. f(x,y) = f'(x,y)) |]
      ==> fold_set(A,B,f,e) = fold_set(A',B',f',e')"
apply (simp add: fold_set_def)
apply (intro refl iff_refl lfp_cong Collect_cong disj_cong ex_cong, auto)
done

lemma fold_cong:
"[| B=B'; A=A'; e=e';
    !!x y. [|x\<in>A'; y\<in>B'|] ==> f(x,y) = f'(x,y) |] ==>
   fold[B](f,e,A) = fold[B'](f', e', A')"
apply (simp add: fold_def)
apply (subst fold_set_cong)
apply (rule_tac [5] refl, simp_all)
done

lemma setsum_cong:
 "[| A=B; !!x. x\<in>B ==> f(x) = g(x) |] ==>
     setsum(f, A) = setsum(g, B)"
by (simp add: setsum_def cong add: fold_cong)

lemma setsum_Un:
     "[| Finite(A); Finite(B) |]
      ==> setsum(f, A \<union> B) =
          setsum(f, A) $+ setsum(f, B) $- setsum(f, A \<inter> B)"
apply (subst setsum_Un_Int [symmetric], auto)
done

lemma setsum_zneg_or_0 [rule_format (no_asm)]:
     "Finite(A) ==> (\<forall>x\<in>A. g(x) $\<le> #0) \<longrightarrow> setsum(g, A) $\<le> #0"
apply (erule Finite_induct)
apply (auto intro: zneg_or_0_add_zneg_or_0_imp_zneg_or_0)
done

lemma setsum_succD_lemma [rule_format]:
     "Finite(A)
      ==> \<forall>n\<in>nat. setsum(f,A) = $# succ(n) \<longrightarrow> (\<exists>a\<in>A. #0 $< f(a))"
apply (erule Finite_induct)
apply (auto simp del: int_of_0 int_of_succ simp add: not_zless_iff_zle int_of_0 [symmetric])
apply (subgoal_tac "setsum (f, B) $\<le> #0")
apply simp_all
prefer 2 apply (blast intro: setsum_zneg_or_0)
apply (subgoal_tac "$# 1 $\<le> f (x) $+ setsum (f, B) ")
apply (drule zdiff_zle_iff [THEN iffD2])
apply (subgoal_tac "$# 1 $\<le> $# 1 $- setsum (f,B) ")
apply (drule_tac x = "$# 1" in zle_trans)
apply (rule_tac [2] j = "#1" in zless_zle_trans, auto)
done

lemma setsum_succD:
     "[| setsum(f, A) = $# succ(n); n\<in>nat |]==> \<exists>a\<in>A. #0 $< f(a)"
apply (case_tac "Finite (A) ")
apply (blast intro: setsum_succD_lemma)
apply (unfold setsum_def)
apply (auto simp del: int_of_0 int_of_succ simp add: int_succ_int_1 [symmetric] int_of_0 [symmetric])
done

lemma g_zpos_imp_setsum_zpos [rule_format]:
     "Finite(A) ==> (\<forall>x\<in>A. #0 $\<le> g(x)) \<longrightarrow> #0 $\<le> setsum(g, A)"
apply (erule Finite_induct)
apply (simp (no_asm))
apply (auto intro: zpos_add_zpos_imp_zpos)
done

lemma g_zpos_imp_setsum_zpos2 [rule_format]:
     "[| Finite(A); \<forall>x. #0 $\<le> g(x) |] ==> #0 $\<le> setsum(g, A)"
apply (erule Finite_induct)
apply (auto intro: zpos_add_zpos_imp_zpos)
done

lemma g_zspos_imp_setsum_zspos [rule_format]:
     "Finite(A)
      ==> (\<forall>x\<in>A. #0 $< g(x)) \<longrightarrow> A \<noteq> 0 \<longrightarrow> (#0 $< setsum(g, A))"
apply (erule Finite_induct)
apply (auto intro: zspos_add_zspos_imp_zspos)
done

lemma setsum_Diff [rule_format]:
     "Finite(A) ==> \<forall>a. M(a) = #0 \<longrightarrow> setsum(M, A) = setsum(M, A-{a})"
apply (erule Finite_induct)
apply (simp_all add: Diff_cons_eq Finite_Diff)
done

end


theory TopoS_Vertices
imports Main
"~~/src/HOL/Library/Char_ord" (*order on char*)
"~~/src/HOL/Library/List_lexord" (*order on strings*)
begin

section{*A type for vertices*}

text{*
This theory makes extensive use of graphs.
We define a typeclass @{text "vertex"} for the vertices we will use in our theory.
The vertices will correspond to network or policy entities.

Later, we will conduct some proves by providing counterexamples.
Therefore, we say that the type of a vertex has at least three pairwise distinct members.

For example, the types @{typ "string"}, @{typ nat}, @{typ "bool \<times> bool"} and many other fulfill this assumption.
The type @{typ "bool"} alone does not fulfill this assumption, because it only has two elements.

This is only a constraint over the type, of course, a policy with less than three entities can also be verified.

TL;DR: We define @{typ "'a"} @{text vertex}, which is as good as @{typ "'a"}.
*}

-- {*We need at least some vertices available for a graph ...*}
class vertex =
  fixes vertex_1 :: "'a"
  fixes vertex_2 :: "'a"
  fixes vertex_3 :: "'a"
  assumes distinct_vertices: "distinct [vertex_1, vertex_2, vertex_3]"
begin
  lemma distinct_vertices12[simp]: "vertex_1 \<noteq> vertex_2" using distinct_vertices by(simp)
  lemma distinct_vertices13[simp]: "vertex_1 \<noteq> vertex_3" using distinct_vertices by(simp)
  lemma distinct_vertices23[simp]: "vertex_2 \<noteq> vertex_3" using distinct_vertices by(simp)

  lemmas distinct_vertices_sym = distinct_vertices12[symmetric] distinct_vertices13[symmetric]
          distinct_vertices23[symmetric]
  declare distinct_vertices_sym[simp]
end

text {* Numbers, chars and strings are good candidates for vertices. *}

instantiation nat::vertex
begin
  definition "vertex_1_nat" ::nat where "vertex_1 \<equiv> (1::nat)"
  definition "vertex_2_nat" ::nat where "vertex_2 \<equiv> (2::nat)"
  definition "vertex_3_nat" ::nat where "vertex_3 \<equiv> (3::nat)"
instance proof qed(simp add: vertex_1_nat_def vertex_2_nat_def vertex_3_nat_def)
end
value "vertex_1::nat"

instantiation int::vertex
begin
  definition "vertex_1_int" ::int where "vertex_1 \<equiv> (1::int)"
  definition "vertex_2_int" ::int where "vertex_2 \<equiv> (2::int)"
  definition "vertex_3_int" ::int where "vertex_3 \<equiv> (3::int)"
instance proof qed(simp add: vertex_1_int_def vertex_2_int_def vertex_3_int_def)
end

instantiation char::vertex
begin
  definition "vertex_1_char" ::char where "vertex_1 \<equiv> CHR ''A''"
  definition "vertex_2_char" ::char where "vertex_2 \<equiv> CHR ''B''"
  definition "vertex_3_char" ::char where "vertex_3 \<equiv> CHR ''C''"
instance proof(intro_classes) qed(simp add: vertex_1_char_def  vertex_2_char_def vertex_3_char_def)
end
value "vertex_1::char"

instantiation list :: ("vertex") vertex
begin
  definition "vertex_1_list" where "vertex_1 \<equiv> []"
  definition "vertex_2_list" where "vertex_2 \<equiv> [vertex_1]"
  definition "vertex_3_list" where "vertex_3 \<equiv> [vertex_1, vertex_1]"
instance proof qed(simp add: vertex_1_list_def vertex_2_list_def vertex_3_list_def)
end

--"for the ML graphviz visualizer"
ML {*
fun tune_string_vertex_format (t: term) (s: string) : string =
    if fastype_of t = @{typ string} then
      if String.isPrefix "''" s then
        String.substring (s, (size "''"), (size s - (size "''''")))
      else let val _ = writeln ("no tune_string_vertex_format for \""^s^"\"") in s end
    else s
    handle Subscript => let val _ = writeln ("tune_string_vertex_format Subscript excpetion") in s end;
*}

end


theory Bijective_Embedding
  imports "HOL-Library.Countable_Set"
begin

text \<open>Generalization of @{thm image_vimage_eq}\<close>
lemma inj_on_vimage_image_eq: "f -` (f ` A) \<inter> S = A" if "inj_on f S" "A \<subseteq> S"
  using that unfolding inj_on_def by blast

text \<open>Generalization of @{thm card_vimage_inj}\<close>
theorem card_vimage_inj_on:
  fixes f :: "'a \<Rightarrow> 'b"
    and A :: "'b set"
  assumes "inj_on f S"
    and "A \<subseteq> f ` S"
  shows "card (f -` A \<inter> S) = card A"
  using assms
  by (auto 4 3 simp: subset_image_iff inj_on_vimage_image_eq
      intro: card_image[symmetric, OF subset_inj_on])

context
begin

private lemma finiteI: "finite {x. x \<in> A \<and> ordX x \<le> ordX a \<and> Q x}" (is "finite ?S")
    if "inj_on ordX A" for A a Q and ordX :: "_ \<Rightarrow> nat"
proof -
  have "?S \<subseteq> {x. x \<in> A \<and> ordX x \<le> ordX a}"
    by blast
  moreover have "finite \<dots>"
  proof -
    have "\<dots> = ordX -` {n. n \<le> ordX a} \<inter> A"
      by auto
    moreover from \<open>inj_on ordX A\<close> have "finite \<dots>"
      by (intro finite_vimage_IntI) auto
    ultimately show ?thesis
      by simp
  qed
  ultimately show ?thesis
    by (rule finite_subset)
qed

qualified lemma enumeration_skip_finite_set_surj:
  "\<exists>a. a \<in> A \<and> a \<notin> S \<and> card {x \<in> A. ordX x \<le> ordX a \<and> x \<notin> S} = n"
  if "n > 0" "inj_on ordX A" "ordX ` A = \<nat>" "finite S" "S \<subseteq> A" for ordX :: "_ \<Rightarrow> nat"
  using \<open>finite S\<close> \<open>n > 0\<close> \<open>S \<subseteq> A\<close>
proof (induction arbitrary: n)
  case empty
  let ?a = "the_inv_into A ordX (n - 1)"
  have "card {x \<in> A. ordX x \<le> n - 1} = n"
  proof -
    have "{x \<in> A. ordX x \<le> n - 1} = ordX -` {x. x \<le> n - 1} \<inter> A"
      by auto
    moreover have "card \<dots> = card {x. x \<le> n - 1}"
      using \<open>inj_on ordX _\<close> \<open>ordX ` A = \<nat>\<close> by (intro card_vimage_inj_on) (auto simp: Nats_def)
    moreover have "\<dots> = n"
      using \<open>n > 0\<close> by auto
    ultimately show ?thesis
      by auto
  qed
  then have "\<exists> a \<in> A. card {x \<in> A. ordX x \<le> ordX a} = n"
    using \<open>inj_on ordX A\<close> \<open>ordX ` A = \<nat>\<close>
    unfolding Nats_def
    by (intro bexI[where x = "the_inv_into A ordX (n - 1)"])
       (auto intro: the_inv_into_into simp: f_the_inv_into_f[where f = ordX])
  then show ?case
    by auto
next
  case (insert x F)
  then obtain a where a: "a \<in> A" "a \<notin> F" "card {x \<in> A. ordX x \<le> ordX a \<and> x \<notin> F} = n"
    by blast
  show ?case
  proof (cases "ordX x \<le> ordX a")
    case True
    then have *:
      "{xa \<in> A. ordX xa \<le> ordX a \<and> xa \<notin> insert x F} = {x \<in> A. ordX x \<le> ordX a \<and> x \<notin> F} - {x}"
      by auto
    let ?m = "Max (ordX ` F)"
    show ?thesis
    proof (cases "\<exists>b \<in> A. b \<notin> F \<and> ordX a < ordX b \<and> ordX b \<le> ?m")
      case False
      let ?a = "the_inv_into A ordX (max ?m (ordX a) + 1)"
      let ?S = "{xa \<in> A. ordX xa \<le> ordX ?a \<and> xa \<notin> insert x F}"
      have "?a \<in> A"
        by (simp add: Nats_def \<open>inj_on ordX A\<close> \<open>ordX ` A = \<nat>\<close> the_inv_into_into)
      have "ordX ?a = max ?m (ordX a) + 1"
        using \<open>inj_on ordX A\<close> \<open>ordX ` A = \<nat>\<close> unfolding Nats_def
        by (subst f_the_inv_into_f[where f = ordX]) auto
      then have "?S = {xa \<in> A. ordX xa \<le> max ?m (ordX a) + 1 \<and> xa \<notin> insert x F}"
        by simp
      also have "\<dots> = {xa \<in> A. ordX xa \<le> ordX a \<and> xa \<notin> insert x F} \<union> {?a}"
      proof -
        have "{xa \<in> A. ordX xa = max ?m (ordX a) + 1 \<and> xa \<notin> insert x F} = {?a}"
          unfolding \<open>ordX ?a = _\<close>
          apply (auto simp: \<open>inj_on ordX A\<close> the_inv_into_f_eq)
          using True \<open>ordX ?a = _\<close> \<open>?a \<in> A\<close>
          apply -
          apply (auto; fail)+
          by (metis Max.in_idem Suc_eq_plus1 discrete finite_imageI imageI less_not_refl insert(1)
                    max.cobounded2 max.commute max.strict_coboundedI1)
        have *: "{xa \<in> A. ordX xa \<le> ordX a \<and> xa \<notin> insert x F}
              = {xa \<in> A. ordX xa \<le> max ?m (ordX a) \<and> xa \<notin> insert x F}"
          using False by auto
        show ?thesis
          unfolding \<open>_ = {?a}\<close>[symmetric] * by auto
      qed
      finally have "?S = ({x \<in> A. ordX x \<le> ordX a \<and> x \<notin> F} - {x}) \<union> {?a}"
        by auto
      moreover have "?a \<noteq> x"
        using True \<open>ordX ?a = max (MAX x \<in> F. ordX x) (ordX a) + 1\<close> by auto
      moreover have "?a \<notin> {x \<in> A. ordX x \<le> ordX a \<and> x \<notin> F}"
        using \<open>ordX ?a = max (MAX x \<in> F. ordX x) (ordX a) + 1\<close> by auto
      moreover have "x \<in> {x \<in> A. ordX x \<le> ordX a \<and> x \<notin> F}"
        using \<open>ordX x \<le> _\<close> \<open>insert x _ \<subseteq> A\<close> \<open>x \<notin> F\<close> by auto
      ultimately have "card ?S = card {x \<in> A. ordX x \<le> ordX a \<and> x \<notin> F}"
        apply simp
        apply (subst card_insert)
        subgoal
          by (force intro: finiteI[OF \<open>inj_on ordX A\<close>, of a])
        apply simp
        apply (subst card.remove[symmetric])
        subgoal
          by (force intro: finiteI[OF \<open>inj_on ordX A\<close>, of a])
        by auto
      also have "\<dots> = n"
        using \<open>_ = n\<close> by auto
      finally show ?thesis
        using \<open>inj_on ordX A\<close> \<open>ordX ` A = \<nat>\<close> unfolding Nats_def
        apply -
        apply (rule exI[where x = ?a], rule conjI)
         apply (auto intro: the_inv_into_into)
        using \<open>ordX x \<le> _\<close>
          apply (subgoal_tac "ordX x = Suc (ordX a)"; simp add: f_the_inv_into_f[where f = ordX])
         apply (subgoal_tac "ordX ?a \<le> ?m")
        subgoal
          using False
          apply (simp add: f_the_inv_into_f[where f = ordX])
          done
         apply (rule Max_ge)
        using \<open>finite F\<close> apply (rule finite_imageI)
         apply (rule imageI)
         apply (simp add: f_the_inv_into_f[where f = ordX])
        done
    next
      case True
      let ?M = "{b \<in> A. ordX a < ordX b \<and> ordX b \<le> ?m \<and> b \<notin> F}"
      from True have "?M \<noteq> {}"
        by auto
      have "finite ?M"
      proof -
        have "?M \<subseteq> {b \<in> A. ordX b \<le> ?m}"
          by auto
        moreover have "finite \<dots>"
        proof -
          have *: "\<dots> = ordX -` {x. x \<le> ?m} \<inter> A"
            by auto
          from \<open>inj_on ordX A\<close> show ?thesis
            unfolding * by (intro finite_vimage_IntI) auto
        qed
        ultimately show ?thesis
          by (rule finite_subset)
      qed
      let ?a = "arg_min_on ordX ?M"
      from arg_min_if_finite[OF \<open>finite ?M\<close> \<open>?M \<noteq> {}\<close>, of ordX] have a:
        "?a \<in> ?M" "\<not> (\<exists> x \<in> ?M. ordX x < ordX ?a)"
        by fast+
      with \<open>ordX x \<le> ordX a\<close> have "?a \<noteq> x"
        by auto
      then have **: "{xa \<in> A. ordX xa \<le> ordX ?a \<and> xa \<noteq> x \<and> xa \<notin> F} =
            {xa \<in> A. ordX xa \<le> ordX a \<and> xa \<noteq> x \<and> xa \<notin> F} \<union> {?a}"
        using a
        by auto
           (smt \<open>inj_on ordX A\<close> inj_on_eq_iff le_eq_less_or_eq le_trans mem_Collect_eq not_le)
      have "?a \<notin> {xa \<in> A. ordX xa \<le> ordX a \<and> xa \<noteq> x \<and> xa \<notin> F}"
        using a(1) by auto
      then have "card {xa \<in> A. ordX xa \<le> ordX ?a \<and> xa \<noteq> x \<and> xa \<notin> F} = n"
        unfolding *[simplified] **
        using \<open>card _ = n\<close>
        apply simp
        apply (subst card_insert)
        subgoal
          by (auto intro: finiteI[OF \<open>inj_on ordX A\<close>])
        apply simp
        apply (subst card.remove[symmetric])
        subgoal
          by (auto intro: finiteI[OF \<open>inj_on ordX A\<close>])
        subgoal
          using \<open>insert x F \<subseteq> A\<close> \<open>ordX x \<le> _\<close> \<open>x \<notin> F\<close> by simp
        apply assumption
        done
      then show ?thesis
        using a(1) \<open>ordX x \<le> _\<close> by (intro exI[where x = ?a]) auto
    qed
  next
    case False
    then have
      "{xa \<in> A. ordX xa \<le> ordX a \<and> xa \<notin> insert x F} = {x \<in> A. ordX x \<le> ordX a \<and> x \<notin> F}"
      by auto
    with a False show ?thesis
      by (intro exI[where x = a]) auto
  qed
qed

lemma bij_betw_relI:
  assumes "\<And>x y z. x \<in> A \<Longrightarrow> y \<in> B \<Longrightarrow> z \<in> B \<Longrightarrow> R x y \<Longrightarrow> R x z \<Longrightarrow> y = z"
      and "\<And>x y z. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> z \<in> B \<Longrightarrow> R x z \<Longrightarrow> R y z \<Longrightarrow> x = y"
      and "\<And>x. x \<in> A \<Longrightarrow> \<exists>y \<in> B. R x y" "\<And>y. y \<in> B \<Longrightarrow> \<exists>x \<in> A. R x y"
  shows "bij_betw (\<lambda>a. SOME b. R a b \<and> b \<in> B) A B"
  by (rule bij_betwI'; smt assms someI)

lemma bijective_embedding:
  fixes f :: "'a \<Rightarrow> 'b"
    and A :: "'a set" and B :: "'b set"
    and S :: "'a set"
  assumes "inj_on f S" and "S \<subseteq> A" and "f ` S \<subseteq> B"
    and "finite S"
    and "countable A" and "countable B"
    and "infinite A" and "infinite B"
  shows "\<exists>h. bij_betw h A B \<and> (\<forall>x \<in> S. h x = f x)"
proof -
  obtain ordX :: "_ \<Rightarrow> nat" and ordY :: "_ \<Rightarrow> nat" where
    "inj_on ordX A" "ordX ` A = \<nat>" and "inj_on ordY B" "ordY ` B = \<nat>"
    using assms(5-) unfolding Nats_def
    by (metis bij_betw_def bij_betw_from_nat_into bij_betw_imp_inj_on bij_betw_the_inv_into
        of_nat_id surj_def)
  define P where "P a b \<equiv> a \<in> A \<and> b \<in> B \<and> a \<notin> S \<and> b \<notin> f ` S \<and>
    card {x. x \<in> A \<and> ordX x \<le> ordX a \<and> x \<notin> S} = card {x. x \<in> B \<and> ordY x \<le> ordY b \<and> x \<notin> f ` S}"
    for a b
  let ?f = "\<lambda>a. card {x. x \<in> A \<and> ordX x \<le> ordX a \<and> x \<notin> S}"
  let ?g = "\<lambda>a. card {x. x \<in> B \<and> ordY x \<le> ordY a \<and> x \<notin> f ` S}"
  have P_right: "\<exists> b. P a b" if "a \<in> A" "a \<notin> S" for a
  proof -
    have *: "\<exists>b. b \<in> B \<and> b \<notin> f ` S \<and> ?g b = n" if "n > 0" for n
      using \<open>n > 0\<close> \<open>finite S\<close> \<open>f ` S \<subseteq> B\<close> \<open>inj_on ordY B\<close> \<open>ordY ` B = \<nat>\<close>
      by (intro enumeration_skip_finite_set_surj) auto
    from that have "?f a > 0"
      unfolding card_gt_0_iff by (auto intro: finiteI[OF \<open>inj_on ordX A\<close>])
    from *[OF this] show ?thesis
      unfolding P_def using that by auto
  qed
  have P_left: "\<exists>a. P a b" if "b \<in> B" "b \<notin> f ` S" for b
    using that \<open>finite S\<close> \<open>S \<subseteq> A\<close> \<open>inj_on ordX A\<close> \<open>inj_on ordY B\<close> \<open>ordX ` A = \<nat>\<close> unfolding P_def
    by (auto 4 3 intro: enumeration_skip_finite_set_surj finiteI simp: card_gt_0_iff)
  have P_surj: "a = b" if "P a c" "P b c" for a b c
  proof -
    from that have "?f a = ?f b" (is "card ?A = card ?B")
      unfolding P_def by auto
    have fin: "finite ?A" "finite ?B"
      by (intro finiteI \<open>inj_on ordX A\<close>)+
    have *: "a \<in> A" "b \<in> A" "a \<notin> S" "b \<notin> S"
      using that unfolding P_def by auto
    consider (lt) "ordX a < ordX b" | (eq) "ordX a = ordX b" | (gt) "ordX a > ordX b"
      by force
    then show ?thesis
    proof cases
      case lt
      with * have "?f a < ?f b"
        using leD by (intro psubset_card_mono fin) auto
      with \<open>?f a = ?f b\<close> show ?thesis
        by auto
    next
      case eq
      then show ?thesis
        using \<open>inj_on ordX A\<close> \<open>a \<in> A\<close> \<open>b \<in> A\<close> by (auto dest: inj_onD)
    next
      case gt
      with * have "?f a > ?f b"
        using leD by (intro psubset_card_mono fin) auto
      with \<open>?f a = ?f b\<close> show ?thesis
        by auto
    qed
  qed
  have P_inj: "b = c" if "P a b" "P a c" for a b c
  proof -
    from that have "?g b = ?g c" (is "card ?A = card ?B")
      unfolding P_def by auto
    have fin: "finite ?A" "finite ?B"
      by (intro finiteI \<open>inj_on ordY B\<close>)+
    have *: "b \<in> B" "c \<in> B" "b \<notin> f ` S" "c \<notin> f ` S"
      using that unfolding P_def by auto
    consider (lt) "ordY b < ordY c" | (eq) "ordY b = ordY c" | (gt) "ordY b > ordY c"
      by force
    then show ?thesis
    proof cases
      case lt
      with * have "?g b < ?g c"
        using leD by (intro psubset_card_mono fin) (auto, blast)
      with \<open>?g b = ?g c\<close> show ?thesis
        by auto
    next
      case eq
      then show ?thesis
        using \<open>inj_on ordY B\<close> \<open>b \<in> B\<close> \<open>c \<in> B\<close> by (auto dest: inj_onD)
    next
      case gt
      with * have "?g b > ?g c"
        using leD by (intro psubset_card_mono fin) (auto, blast)
      with \<open>?g b = ?g c\<close> show ?thesis
        by auto
    qed
  qed

  define R where "R a b \<equiv> if a \<in> S then b = f a else P a b" for a b
  have R_A: "a \<in> A" and R_B: "b \<in> B" if "R a b" for a b
    using that \<open>f ` S \<subseteq> B\<close> \<open>S \<subseteq> A\<close> unfolding R_def by (auto split: if_split_asm simp: P_def)
  have R_inj: "b = c" if "R a b" "R a c" for a b c
    using that unfolding R_def by (auto split: if_split_asm dest: P_inj)
  moreover have R_surj: "a = b" if "R a c" "R b c" for a b c
    using that unfolding R_def
    by (auto split: if_split_asm dest: P_surj inj_onD[OF \<open>inj_on f S\<close>]) (auto simp: P_def)
  moreover have R_right: "\<exists>b. R a b" if "a \<in> A" for a
    unfolding R_def by (auto dest: P_right[OF \<open>a \<in> A\<close>])
  moreover have R_left: "\<exists>a. R a b" if "b \<in> B" for b
    unfolding R_def
    by (cases "b \<in> f ` S", (auto; fail), (frule P_left[OF \<open>b \<in> B\<close>], auto simp: P_def))
  ultimately show ?thesis
    apply (intro exI[of _ "\<lambda>a. SOME b. R a b \<and> b \<in> B"] conjI)
     apply (rule bij_betw_relI)
        apply assumption+
      apply (smt R_A R_B)+
    using assms(3) by (subst R_def) (simp, blast)
qed

end

definition extend_bij :: "('a :: countable \<Rightarrow> 'b :: countable) \<Rightarrow> 'a set \<Rightarrow> _" where
  "extend_bij f S \<equiv> SOME h. bij h \<and> (\<forall>x \<in> S. h x = f x)"

lemma
  fixes f :: "'a  :: countable \<Rightarrow> 'b :: countable" and S :: "'a set"
  assumes "infinite (UNIV :: 'a set)" and "infinite (UNIV :: 'b set)"
      and "inj_on f S" and "finite S"
    shows extend_bij_bij: "bij (extend_bij f S)"
      and extend_bij_extends: "\<forall>x \<in> S. extend_bij f S x = f x"
proof -
  from bijective_embedding[OF assms(3) _ _ assms(4) _ _ assms(1,2)] obtain h where
    "bij h \<and> (\<forall>x\<in>S. h x = f x)"
    by auto
  then show "bij (extend_bij f S)" "\<forall>x \<in> S. extend_bij f S x = f x"
    unfolding atomize_conj extend_bij_def by (rule someI[where x = h])
qed

end


(*  Title:      HOL/Quotient.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section {* Definition of Quotient Types *}

theory Quotient
imports Lifting
keywords
  "print_quotmapsQ3" "print_quotientsQ3" "print_quotconsts" :: diag and
  "quotient_type" :: thy_goal and "/" and
  "quotient_definition" :: thy_goal
begin

text {*
  Basic definition for equivalence relations
  that are represented by predicates.
*}

text {* Composition of Relations *}

abbreviation
  rel_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" (infixr "OOO" 75)
where
  "r1 OOO r2 \<equiv> r1 OO r2 OO r1"

lemma eq_comp_r:
  shows "((op =) OOO R) = R"
  by (auto simp add: fun_eq_iff)

context
begin
interpretation lifting_syntax .

subsection {* Quotient Predicate *}

definition
  "Quotient3 R Abs Rep \<longleftrightarrow>
     (\<forall>a. Abs (Rep a) = a) \<and> (\<forall>a. R (Rep a) (Rep a)) \<and>
     (\<forall>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s)"

lemma Quotient3I:
  assumes "\<And>a. Abs (Rep a) = a"
    and "\<And>a. R (Rep a) (Rep a)"
    and "\<And>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s"
  shows "Quotient3 R Abs Rep"
  using assms unfolding Quotient3_def by blast

context
  fixes R Abs Rep
  assumes a: "Quotient3 R Abs Rep"
begin

lemma Quotient3_abs_rep:
  "Abs (Rep a) = a"
  using a
  unfolding Quotient3_def
  by simp

lemma Quotient3_rep_reflp:
  "R (Rep a) (Rep a)"
  using a
  unfolding Quotient3_def
  by blast

lemma Quotient3_rel:
  "R r r \<and> R s s \<and> Abs r = Abs s \<longleftrightarrow> R r s" -- {* orientation does not loop on rewriting *}
  using a
  unfolding Quotient3_def
  by blast

lemma Quotient3_refl1:
  "R r s \<Longrightarrow> R r r"
  using a unfolding Quotient3_def
  by fast

lemma Quotient3_refl2:
  "R r s \<Longrightarrow> R s s"
  using a unfolding Quotient3_def
  by fast

lemma Quotient3_rel_rep:
  "R (Rep a) (Rep b) \<longleftrightarrow> a = b"
  using a
  unfolding Quotient3_def
  by metis

lemma Quotient3_rep_abs:
  "R r r \<Longrightarrow> R (Rep (Abs r)) r"
  using a unfolding Quotient3_def
  by blast

lemma Quotient3_rel_abs:
  "R r s \<Longrightarrow> Abs r = Abs s"
  using a unfolding Quotient3_def
  by blast

lemma Quotient3_symp:
  "symp R"
  using a unfolding Quotient3_def using sympI by metis

lemma Quotient3_transp:
  "transp R"
  using a unfolding Quotient3_def using transpI by (metis (full_types))

lemma Quotient3_part_equivp:
  "part_equivp R"
  by (metis Quotient3_rep_reflp Quotient3_symp Quotient3_transp part_equivpI)

lemma abs_o_rep:
  "Abs o Rep = id"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep)

lemma equals_rsp:
  assumes b: "R xa xb" "R ya yb"
  shows "R xa ya = R xb yb"
  using b Quotient3_symp Quotient3_transp
  by (blast elim: sympE transpE)

lemma rep_abs_rsp:
  assumes b: "R x1 x2"
  shows "R x1 (Rep (Abs x2))"
  using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
  by metis

lemma rep_abs_rsp_left:
  assumes b: "R x1 x2"
  shows "R (Rep (Abs x1)) x2"
  using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
  by metis

end

lemma identity_quotient3:
  "Quotient3 (op =) id id"
  unfolding Quotient3_def id_def
  by blast

lemma fun_quotient3:
  assumes q1: "Quotient3 R1 abs1 rep1"
  and     q2: "Quotient3 R2 abs2 rep2"
  shows "Quotient3 (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
proof -
  have "\<And>a.(rep1 ---> abs2) ((abs1 ---> rep2) a) = a"
    using q1 q2 by (simp add: Quotient3_def fun_eq_iff)
  moreover
  have "\<And>a.(R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)"
    by (rule rel_funI)
      (insert q1 q2 Quotient3_rel_abs [of R1 abs1 rep1] Quotient3_rel_rep [of R2 abs2 rep2],
        simp (no_asm) add: Quotient3_def, simp)

  moreover
  {
  fix r s
  have "(R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
        (rep1 ---> abs2) r  = (rep1 ---> abs2) s)"
  proof -

    have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) r r" unfolding rel_fun_def
      using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
      by (metis (full_types) part_equivp_def)
    moreover have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) s s" unfolding rel_fun_def
      using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
      by (metis (full_types) part_equivp_def)
    moreover have "(R1 ===> R2) r s \<Longrightarrow> (rep1 ---> abs2) r  = (rep1 ---> abs2) s"
      apply(auto simp add: rel_fun_def fun_eq_iff) using q1 q2 unfolding Quotient3_def by metis
    moreover have "((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
        (rep1 ---> abs2) r  = (rep1 ---> abs2) s) \<Longrightarrow> (R1 ===> R2) r s"
      apply(auto simp add: rel_fun_def fun_eq_iff) using q1 q2 unfolding Quotient3_def
    by (metis map_fun_apply)

    ultimately show ?thesis by blast
 qed
 }
 ultimately show ?thesis by (intro Quotient3I) (assumption+)
qed

lemma lambda_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>x. f x)"
  unfolding fun_eq_iff
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
  by simp

lemma lambda_prs1:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> Abs2) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>x. f x)"
  unfolding fun_eq_iff
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
  by simp

text{*
  In the following theorem R1 can be instantiated with anything,
  but we know some of the types of the Rep and Abs functions;
  so by solving Quotient assumptions we can get a unique R1 that
  will be provable; which is why we need to use @{text apply_rsp} and
  not the primed version *}

lemma apply_rspQ3:
  fixes f g::"'a \<Rightarrow> 'c"
  assumes q: "Quotient3 R1 Abs1 Rep1"
  and     a: "(R1 ===> R2) f g" "R1 x y"
  shows "R2 (f x) (g y)"
  using a by (auto elim: rel_funE)

lemma apply_rspQ3'':
  assumes "Quotient3 R Abs Rep"
  and "(R ===> S) f f"
  shows "S (f (Rep x)) (f (Rep x))"
proof -
  from assms(1) have "R (Rep x) (Rep x)" by (rule Quotient3_rep_reflp)
  then show ?thesis using assms(2) by (auto intro: apply_rsp')
qed

subsection {* lemmas for regularisation of ball and bex *}

lemma ball_reg_eqv:
  fixes P :: "'a \<Rightarrow> bool"
  assumes a: "equivp R"
  shows "Ball (Respects R) P = (All P)"
  using a
  unfolding equivp_def
  by (auto simp add: in_respects)

lemma bex_reg_eqv:
  fixes P :: "'a \<Rightarrow> bool"
  assumes a: "equivp R"
  shows "Bex (Respects R) P = (Ex P)"
  using a
  unfolding equivp_def
  by (auto simp add: in_respects)

lemma ball_reg_right:
  assumes a: "\<And>x. x \<in> R \<Longrightarrow> P x \<longrightarrow> Q x"
  shows "All P \<longrightarrow> Ball R Q"
  using a by fast

lemma bex_reg_left:
  assumes a: "\<And>x. x \<in> R \<Longrightarrow> Q x \<longrightarrow> P x"
  shows "Bex R Q \<longrightarrow> Ex P"
  using a by fast

lemma ball_reg_left:
  assumes a: "equivp R"
  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
  using a by (metis equivp_reflp in_respects)

lemma bex_reg_right:
  assumes a: "equivp R"
  shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
  using a by (metis equivp_reflp in_respects)

lemma ball_reg_eqv_range:
  fixes P::"'a \<Rightarrow> bool"
  and x::"'a"
  assumes a: "equivp R2"
  shows   "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
  apply(rule iffI)
  apply(rule allI)
  apply(drule_tac x="\<lambda>y. f x" in bspec)
  apply(simp add: in_respects rel_fun_def)
  apply(rule impI)
  using a equivp_reflp_symp_transp[of "R2"]
  apply (auto elim: equivpE reflpE)
  done

lemma bex_reg_eqv_range:
  assumes a: "equivp R2"
  shows   "(Bex (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
  apply(auto)
  apply(rule_tac x="\<lambda>y. f x" in bexI)
  apply(simp)
  apply(simp add: Respects_def in_respects rel_fun_def)
  apply(rule impI)
  using a equivp_reflp_symp_transp[of "R2"]
  apply (auto elim: equivpE reflpE)
  done

(* Next four lemmas are unused *)
lemma all_reg:
  assumes a: "!x :: 'a. (P x --> Q x)"
  and     b: "All P"
  shows "All Q"
  using a b by fast

lemma ex_reg:
  assumes a: "!x :: 'a. (P x --> Q x)"
  and     b: "Ex P"
  shows "Ex Q"
  using a b by fast

lemma ball_reg:
  assumes a: "!x :: 'a. (x \<in> R --> P x --> Q x)"
  and     b: "Ball R P"
  shows "Ball R Q"
  using a b by fast

lemma bex_reg:
  assumes a: "!x :: 'a. (x \<in> R --> P x --> Q x)"
  and     b: "Bex R P"
  shows "Bex R Q"
  using a b by fast

lemma ball_all_comm:
  assumes "\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)"
  shows "(\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y)"
  using assms by auto

lemma bex_ex_comm:
  assumes "(\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)"
  shows "(\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y)"
  using assms by auto

subsection {* Bounded abstraction *}

definition
  Babs :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
  "x \<in> p \<Longrightarrow> Babs p m x = m x"

lemma babs_rsp:
  assumes q: "Quotient3 R1 Abs1 Rep1"
  and     a: "(R1 ===> R2) f g"
  shows      "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
  apply (auto simp add: Babs_def in_respects rel_fun_def)
  apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
  using a apply (simp add: Babs_def rel_fun_def)
  apply (simp add: in_respects rel_fun_def)
  using Quotient3_rel[OF q]
  by metis

lemma babs_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "((Rep1 ---> Abs2) (Babs (Respects R1) ((Abs1 ---> Rep2) f))) = f"
  apply (rule ext)
  apply (simp add:)
  apply (subgoal_tac "Rep1 x \<in> Respects R1")
  apply (simp add: Babs_def Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
  apply (simp add: in_respects Quotient3_rel_rep[OF q1])
  done

lemma babs_simp:
  assumes q: "Quotient3 R1 Abs Rep"
  shows "((R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)) = ((R1 ===> R2) f g)"
  apply(rule iffI)
  apply(simp_all only: babs_rsp[OF q])
  apply(auto simp add: Babs_def rel_fun_def)
  apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
  apply(metis Babs_def)
  apply (simp add: in_respects)
  using Quotient3_rel[OF q]
  by metis

(* If a user proves that a particular functional relation
   is an equivalence this may be useful in regularising *)
lemma babs_reg_eqv:
  shows "equivp R \<Longrightarrow> Babs (Respects R) P = P"
  by (simp add: fun_eq_iff Babs_def in_respects equivp_reflp)

(* 3 lemmas needed for proving repabs_inj *)
lemma ball_rsp:
  assumes a: "(R ===> (op =)) f g"
  shows "Ball (Respects R) f = Ball (Respects R) g"
  using a by (auto simp add: Ball_def in_respects elim: rel_funE)

lemma bex_rsp:
  assumes a: "(R ===> (op =)) f g"
  shows "(Bex (Respects R) f = Bex (Respects R) g)"
  using a by (auto simp add: Bex_def in_respects elim: rel_funE)

lemma bex1_rsp:
  assumes a: "(R ===> (op =)) f g"
  shows "Ex1 (\<lambda>x. x \<in> Respects R \<and> f x) = Ex1 (\<lambda>x. x \<in> Respects R \<and> g x)"
  using a by (auto elim: rel_funE simp add: Ex1_def in_respects)

(* 2 lemmas needed for cleaning of quantifiers *)
lemma all_prs:
  assumes a: "Quotient3 R absf repf"
  shows "Ball (Respects R) ((absf ---> id) f) = All f"
  using a unfolding Quotient3_def Ball_def in_respects id_apply comp_def map_fun_def
  by metis

lemma ex_prs:
  assumes a: "Quotient3 R absf repf"
  shows "Bex (Respects R) ((absf ---> id) f) = Ex f"
  using a unfolding Quotient3_def Bex_def in_respects id_apply comp_def map_fun_def
  by metis

subsection {* @{text Bex1_rel} quantifier *}

definition
  Bex1_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "Bex1_rel R P \<longleftrightarrow> (\<exists>x \<in> Respects R. P x) \<and> (\<forall>x \<in> Respects R. \<forall>y \<in> Respects R. ((P x \<and> P y) \<longrightarrow> (R x y)))"

lemma bex1_rel_aux:
  "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R x\<rbrakk> \<Longrightarrow> Bex1_rel R y"
  unfolding Bex1_rel_def
  apply (erule conjE)+
  apply (erule bexE)
  apply rule
  apply (rule_tac x="xa" in bexI)
  apply metis
  apply metis
  apply rule+
  apply (erule_tac x="xaa" in ballE)
  prefer 2
  apply (metis)
  apply (erule_tac x="ya" in ballE)
  prefer 2
  apply (metis)
  apply (metis in_respects)
  done

lemma bex1_rel_aux2:
  "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R y\<rbrakk> \<Longrightarrow> Bex1_rel R x"
  unfolding Bex1_rel_def
  apply (erule conjE)+
  apply (erule bexE)
  apply rule
  apply (rule_tac x="xa" in bexI)
  apply metis
  apply metis
  apply rule+
  apply (erule_tac x="xaa" in ballE)
  prefer 2
  apply (metis)
  apply (erule_tac x="ya" in ballE)
  prefer 2
  apply (metis)
  apply (metis in_respects)
  done

lemma bex1_rel_rsp:
  assumes a: "Quotient3 R absf repf"
  shows "((R ===> op =) ===> op =) (Bex1_rel R) (Bex1_rel R)"
  apply (simp add: rel_fun_def)
  apply clarify
  apply rule
  apply (simp_all add: bex1_rel_aux bex1_rel_aux2)
  apply (erule bex1_rel_aux2)
  apply assumption
  done

lemma ex1_prs:
  assumes a: "Quotient3 R absf repf"
  shows "((absf ---> id) ---> id) (Bex1_rel R) f = Ex1 f"
apply (simp add:)
apply (subst Bex1_rel_def)
apply (subst Bex_def)
apply (subst Ex1_def)
apply simp
apply rule
 apply (erule conjE)+
 apply (erule_tac exE)
 apply (erule conjE)
 apply (subgoal_tac "\<forall>y. R y y \<longrightarrow> f (absf y) \<longrightarrow> R x y")
  apply (rule_tac x="absf x" in exI)
  apply (simp)
  apply rule+
  using a unfolding Quotient3_def
  apply metis
 apply rule+
 apply (erule_tac x="x" in ballE)
  apply (erule_tac x="y" in ballE)
   apply simp
  apply (simp add: in_respects)
 apply (simp add: in_respects)
apply (erule_tac exE)
 apply rule
 apply (rule_tac x="repf x" in exI)
 apply (simp only: in_respects)
  apply rule
 apply (metis Quotient3_rel_rep[OF a])
using a unfolding Quotient3_def apply (simp)
apply rule+
using a unfolding Quotient3_def in_respects
apply metis
done

lemma bex1_bexeq_reg:
  shows "(\<exists>!x\<in>Respects R. P x) \<longrightarrow> (Bex1_rel R (\<lambda>x. P x))"
  by (auto simp add: Ex1_def Bex1_rel_def Bex_def Ball_def in_respects)

lemma bex1_bexeq_reg_eqv:
  assumes a: "equivp R"
  shows "(\<exists>!x. P x) \<longrightarrow> Bex1_rel R P"
  using equivp_reflp[OF a]
  apply (intro impI)
  apply (elim ex1E)
  apply (rule mp[OF bex1_bexeq_reg])
  apply (rule_tac a="x" in ex1I)
  apply (subst in_respects)
  apply (rule conjI)
  apply assumption
  apply assumption
  apply clarify
  apply (erule_tac x="xa" in allE)
  apply simp
  done

subsection {* Various respects and preserve lemmas *}

lemma quot_rel_rsp:
  assumes a: "Quotient3 R Abs Rep"
  shows "(R ===> R ===> op =) R R"
  apply(rule rel_funI)+
  apply(rule equals_rsp[OF a])
  apply(assumption)+
  done

lemma o_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  and     q3: "Quotient3 R3 Abs3 Rep3"
  shows "((Abs2 ---> Rep3) ---> (Abs1 ---> Rep2) ---> (Rep1 ---> Abs3)) op \<circ> = op \<circ>"
  and   "(id ---> (Abs1 ---> id) ---> Rep1 ---> id) op \<circ> = op \<circ>"
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2] Quotient3_abs_rep[OF q3]
  by (simp_all add: fun_eq_iff)

lemma o_rsp:
  "((R2 ===> R3) ===> (R1 ===> R2) ===> (R1 ===> R3)) op \<circ> op \<circ>"
  "(op = ===> (R1 ===> op =) ===> R1 ===> op =) op \<circ> op \<circ>"
  by (force elim: rel_funE)+

lemma cond_prs:
  assumes a: "Quotient3 R absf repf"
  shows "absf (if a then repf b else repf c) = (if a then b else c)"
  using a unfolding Quotient3_def by auto

lemma if_prs:
  assumes q: "Quotient3 R Abs Rep"
  shows "(id ---> Rep ---> Rep ---> Abs) If = If"
  using Quotient3_abs_rep[OF q]
  by (auto simp add: fun_eq_iff)

lemma if_rsp:
  assumes q: "Quotient3 R Abs Rep"
  shows "(op = ===> R ===> R ===> R) If If"
  by force

lemma let_prs:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep2 ---> (Abs2 ---> Rep1) ---> Abs1) Let = Let"
  using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
  by (auto simp add: fun_eq_iff)

lemma let_rsp:
  shows "(R1 ===> (R1 ===> R2) ===> R2) Let Let"
  by (force elim: rel_funE)

lemma id_rsp:
  shows "(R ===> R) id id"
  by auto

lemma id_prs:
  assumes a: "Quotient3 R Abs Rep"
  shows "(Rep ---> Abs) id = id"
  by (simp add: fun_eq_iff Quotient3_abs_rep [OF a])

end

locale quot_type =
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and   Abs :: "'a set \<Rightarrow> 'b"
  and   Rep :: "'b \<Rightarrow> 'a set"
  assumes equivp: "part_equivp R"
  and     rep_prop: "\<And>y. \<exists>x. R x x \<and> Rep y = Collect (R x)"
  and     rep_inverse: "\<And>x. Abs (Rep x) = x"
  and     abs_inverse: "\<And>c. (\<exists>x. ((R x x) \<and> (c = Collect (R x)))) \<Longrightarrow> (Rep (Abs c)) = c"
  and     rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
begin

definition
  abs :: "'a \<Rightarrow> 'b"
where
  "abs x = Abs (Collect (R x))"

definition
  rep :: "'b \<Rightarrow> 'a"
where
  "rep a = (SOME x. x \<in> Rep a)"

lemma some_collect:
  assumes "R r r"
  shows "R (SOME x. x \<in> Collect (R r)) = R r"
  apply simp
  by (metis assms exE_some equivp[simplified part_equivp_def])

lemma Quotient:
  shows "Quotient3 R abs rep"
  unfolding Quotient3_def abs_def rep_def
  proof (intro conjI allI)
    fix a r s
    show x: "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)" proof -
      obtain x where r: "R x x" and rep: "Rep a = Collect (R x)" using rep_prop[of a] by auto
      have "R (SOME x. x \<in> Rep a) x"  using r rep some_collect by metis
      then have "R x (SOME x. x \<in> Rep a)" using part_equivp_symp[OF equivp] by fast
      then show "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)"
        using part_equivp_transp[OF equivp] by (metis `R (SOME x. x \<in> Rep a) x`)
    qed
    have "Collect (R (SOME x. x \<in> Rep a)) = (Rep a)" by (metis some_collect rep_prop)
    then show "Abs (Collect (R (SOME x. x \<in> Rep a))) = a" using rep_inverse by auto
    have "R r r \<Longrightarrow> R s s \<Longrightarrow> Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s"
    proof -
      assume "R r r" and "R s s"
      then have "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> Collect (R r) = Collect (R s)"
        by (metis abs_inverse)
      also have "Collect (R r) = Collect (R s) \<longleftrightarrow> (\<lambda>A x. x \<in> A) (Collect (R r)) = (\<lambda>A x. x \<in> A) (Collect (R s))"
        by rule simp_all
      finally show "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s" by simp
    qed
    then show "R r s \<longleftrightarrow> R r r \<and> R s s \<and> (Abs (Collect (R r)) = Abs (Collect (R s)))"
      using equivp[simplified part_equivp_def] by metis
    qed

end

subsection {* Quotient composition *}

lemma OOO_quotient3:
  fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
  fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
  fixes R2' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes R2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  assumes R1: "Quotient3 R1 Abs1 Rep1"
  assumes R2: "Quotient3 R2 Abs2 Rep2"
  assumes Abs1: "\<And>x y. R2' x y \<Longrightarrow> R1 x x \<Longrightarrow> R1 y y \<Longrightarrow> R2 (Abs1 x) (Abs1 y)"
  assumes Rep1: "\<And>x y. R2 x y \<Longrightarrow> R2' (Rep1 x) (Rep1 y)"
  shows "Quotient3 (R1 OO R2' OO R1) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
apply (rule Quotient3I)
   apply (simp add: o_def Quotient3_abs_rep [OF R2] Quotient3_abs_rep [OF R1])
  apply simp
  apply (rule_tac b="Rep1 (Rep2 a)" in relcomppI)
   apply (rule Quotient3_rep_reflp [OF R1])
  apply (rule_tac b="Rep1 (Rep2 a)" in relcomppI [rotated])
   apply (rule Quotient3_rep_reflp [OF R1])
  apply (rule Rep1)
  apply (rule Quotient3_rep_reflp [OF R2])
 apply safe
    apply (rename_tac x y)
    apply (drule Abs1)
      apply (erule Quotient3_refl2 [OF R1])
     apply (erule Quotient3_refl1 [OF R1])
    apply (drule Quotient3_refl1 [OF R2], drule Rep1)
    apply (subgoal_tac "R1 r (Rep1 (Abs1 x))")
     apply (rule_tac b="Rep1 (Abs1 x)" in relcomppI, assumption)
     apply (erule relcomppI)
     apply (erule Quotient3_symp [OF R1, THEN sympD])
    apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
    apply (rule conjI, erule Quotient3_refl1 [OF R1])
    apply (rule conjI, rule Quotient3_rep_reflp [OF R1])
    apply (subst Quotient3_abs_rep [OF R1])
    apply (erule Quotient3_rel_abs [OF R1])
   apply (rename_tac x y)
   apply (drule Abs1)
     apply (erule Quotient3_refl2 [OF R1])
    apply (erule Quotient3_refl1 [OF R1])
   apply (drule Quotient3_refl2 [OF R2], drule Rep1)
   apply (subgoal_tac "R1 s (Rep1 (Abs1 y))")
    apply (rule_tac b="Rep1 (Abs1 y)" in relcomppI, assumption)
    apply (erule relcomppI)
    apply (erule Quotient3_symp [OF R1, THEN sympD])
   apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
   apply (rule conjI, erule Quotient3_refl2 [OF R1])
   apply (rule conjI, rule Quotient3_rep_reflp [OF R1])
   apply (subst Quotient3_abs_rep [OF R1])
   apply (erule Quotient3_rel_abs [OF R1, THEN sym])
  apply simp
  apply (rule Quotient3_rel_abs [OF R2])
  apply (rule Quotient3_rel_abs [OF R1, THEN ssubst], assumption)
  apply (rule Quotient3_rel_abs [OF R1, THEN subst], assumption)
  apply (erule Abs1)
   apply (erule Quotient3_refl2 [OF R1])
  apply (erule Quotient3_refl1 [OF R1])
 apply (rename_tac a b c d)
 apply simp
 apply (rule_tac b="Rep1 (Abs1 r)" in relcomppI)
  apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
  apply (rule conjI, erule Quotient3_refl1 [OF R1])
  apply (simp add: Quotient3_abs_rep [OF R1] Quotient3_rep_reflp [OF R1])
 apply (rule_tac b="Rep1 (Abs1 s)" in relcomppI [rotated])
  apply (rule Quotient3_rel[symmetric, OF R1, THEN iffD2])
  apply (simp add: Quotient3_abs_rep [OF R1] Quotient3_rep_reflp [OF R1])
  apply (erule Quotient3_refl2 [OF R1])
 apply (rule Rep1)
 apply (drule Abs1)
   apply (erule Quotient3_refl2 [OF R1])
  apply (erule Quotient3_refl1 [OF R1])
 apply (drule Abs1)
  apply (erule Quotient3_refl2 [OF R1])
 apply (erule Quotient3_refl1 [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply (drule Quotient3_rel_abs [OF R1])
 apply simp
 apply (rule Quotient3_rel[symmetric, OF R2, THEN iffD2])
 apply simp
done

lemma OOO_eq_quotient3:
  fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
  fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
  assumes R1: "Quotient3 R1 Abs1 Rep1"
  assumes R2: "Quotient3 op= Abs2 Rep2"
  shows "Quotient3 (R1 OOO op=) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
using assms
by (rule OOO_quotient3) auto

subsection {* Quotient3 to Quotient *}

lemma Quotient3_to_Quotient:
assumes "Quotient3 R Abs Rep"
and "T \<equiv> \<lambda>x y. R x x \<and> Abs x = y"
shows "Quotient R Abs Rep T"
using assms unfolding Quotient3_def by (intro QuotientI) blast+

lemma Quotient3_to_Quotient_equivp:
assumes q: "Quotient3 R Abs Rep"
and T_def: "T \<equiv> \<lambda>x y. Abs x = y"
and eR: "equivp R"
shows "Quotient R Abs Rep T"
proof (intro QuotientI)
  fix a
  show "Abs (Rep a) = a" using q by(rule Quotient3_abs_rep)
next
  fix a
  show "R (Rep a) (Rep a)" using q by(rule Quotient3_rep_reflp)
next
  fix r s
  show "R r s = (R r r \<and> R s s \<and> Abs r = Abs s)" using q by(rule Quotient3_rel[symmetric])
next
  show "T = (\<lambda>x y. R x x \<and> Abs x = y)" using T_def equivp_reflp[OF eR] by simp
qed

subsection {* ML setup *}

text {* Auxiliary data for the quotient package *}

named_theorems quot_equiv "equivalence relation theorems"
  and quot_respect "respectfulness theorems"
  and quot_preserve "preservation theorems"
  and id_simps "identity simp rules for maps"
  and quot_thm "quotient theorems"
ML_file "Tools/Quotient/quotient_info.ML"

declare [[mapQ3 "fun" = (rel_fun, fun_quotient3)]]

lemmas [quot_thm] = fun_quotient3
lemmas [quot_respect] = quot_rel_rsp if_rsp o_rsp let_rsp id_rsp
lemmas [quot_preserve] = if_prs o_prs let_prs id_prs
lemmas [quot_equiv] = identity_equivp

text {* Lemmas about simplifying id's. *}
lemmas [id_simps] =
  id_def[symmetric]
  map_fun_id
  id_apply
  id_o
  o_id
  eq_comp_r
  vimage_id

text {* Translation functions for the lifting process. *}
ML_file "Tools/Quotient/quotient_term.ML"

text {* Definitions of the quotient types. *}
ML_file "Tools/Quotient/quotient_type.ML"

text {* Definitions for quotient constants. *}
ML_file "Tools/Quotient/quotient_def.ML"

text {*
  An auxiliary constant for recording some information
  about the lifted theorem in a tactic.
*}
definition
  Quot_True :: "'a \<Rightarrow> bool"
where
  "Quot_True x \<longleftrightarrow> True"

lemma
  shows QT_all: "Quot_True (All P) \<Longrightarrow> Quot_True P"
  and   QT_ex:  "Quot_True (Ex P) \<Longrightarrow> Quot_True P"
  and   QT_ex1: "Quot_True (Ex1 P) \<Longrightarrow> Quot_True P"
  and   QT_lam: "Quot_True (\<lambda>x. P x) \<Longrightarrow> (\<And>x. Quot_True (P x))"
  and   QT_ext: "(\<And>x. Quot_True (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (Quot_True a \<Longrightarrow> f = g)"
  by (simp_all add: Quot_True_def ext)

lemma QT_imp: "Quot_True a \<equiv> Quot_True b"
  by (simp add: Quot_True_def)

context
begin
interpretation lifting_syntax .

text {* Tactics for proving the lifted theorems *}
ML_file "Tools/Quotient/quotient_tacs.ML"

end

subsection {* Methods / Interface *}

method_setup lifting =
  {* Attrib.thms >> (fn thms => fn ctxt =>
       SIMPLE_METHOD' (Quotient_Tacs.lift_tac ctxt [] thms)) *}
  {* lift theorems to quotient types *}

method_setup lifting_setup =
  {* Attrib.thm >> (fn thm => fn ctxt =>
       SIMPLE_METHOD' (Quotient_Tacs.lift_procedure_tac ctxt [] thm)) *}
  {* set up the three goals for the quotient lifting procedure *}

method_setup descending =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_tac ctxt [])) *}
  {* decend theorems to the raw level *}

method_setup descending_setup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_procedure_tac ctxt [])) *}
  {* set up the three goals for the decending theorems *}

method_setup partiality_descending =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_tac ctxt [])) *}
  {* decend theorems to the raw level *}

method_setup partiality_descending_setup =
  {* Scan.succeed (fn ctxt =>
       SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_procedure_tac ctxt [])) *}
  {* set up the three goals for the decending theorems *}

method_setup regularize =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.regularize_tac ctxt)) *}
  {* prove the regularization goals from the quotient lifting procedure *}

method_setup injection =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.all_injection_tac ctxt)) *}
  {* prove the rep/abs injection goals from the quotient lifting procedure *}

method_setup cleaning =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.clean_tac ctxt)) *}
  {* prove the cleaning goals from the quotient lifting procedure *}

attribute_setup quot_lifted =
  {* Scan.succeed Quotient_Tacs.lifted_attrib *}
  {* lift theorems to quotient types *}

no_notation
  rel_conj (infixr "OOO" 75)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Port of Anthony Fox's HOL4 realisation of John Harrison's paper
   in TPHOLs 2005 on finite cartesian products *)

theory Arrays
imports
  "~~/src/HOL/Library/Numeral_Type"
begin

definition
  has_size :: "'a set \<Rightarrow> nat \<Rightarrow> bool" where
   "has_size s n = (finite s \<and> card s = n)"

-- {* If @{typ 'a} is not finite, there is no @{term "n < CARD('a)"} *}
definition
  finite_index :: "nat \<Rightarrow> 'a::finite" where
  "finite_index = (SOME f. \<forall>x. \<exists>!n. n < CARD('a) \<and> f n = x)"

lemma card_image_inj[rule_format]:
  "finite S \<Longrightarrow>  (\<forall>x y. x \<in> S \<and> y \<in> S \<and> f x = f y \<longrightarrow> x = y) \<longrightarrow>
                 card (f ` S) = card S"
  by (erule finite_induct) (auto simp add: card_insert_if)

lemma has_size_image_inj:
  "\<lbrakk> has_size S n; (\<And>x y. x \<in> S \<and> y \<in> S \<and> f x = f y \<Longrightarrow> x = y) \<rbrakk>
  \<Longrightarrow> has_size (f ` S) n"
  by (simp add: has_size_def card_image_inj)

lemma has_size_0[simp]:
  "has_size S 0 = (S = {})"
  by (auto simp: has_size_def)

lemma has_size_suc:
  "has_size S (Suc n) =
     (S \<noteq> {} \<and> (\<forall>a. a \<in> S \<longrightarrow> has_size (S - {a}) n))"
  unfolding has_size_def
  by (metis Diff_empty Suc_not_Zero bot_least card_Suc_Diff1 card_gt_0_iff finite_Diff_insert
            nat.inject neq0_conv subsetI subset_antisym)

lemma has_index:
  "\<lbrakk> finite S; card S = n \<rbrakk> \<Longrightarrow>
  (\<exists>f. (\<forall>m. m < n \<longrightarrow> f m \<in> S) \<and> (\<forall>x. x\<in>S \<longrightarrow> (\<exists>!m. m < n \<and> f m = x)))"
proof (induct n arbitrary: S)
  case 0 thus ?case by (auto simp: card_eq_0_iff)
next
  case (Suc n)
  then obtain b B where
    S: "S = insert b B \<and> b \<notin> B \<and> card B = n \<and> (n = 0 \<longrightarrow> B = {})"
    by (auto simp: card_Suc_eq)
  with `finite S` Suc.hyps [of B]
  obtain f where IH: "(\<forall>m<n. f m \<in> B) \<and> (\<forall>x. x \<in> B \<longrightarrow> (\<exists>!m. m < n \<and> f m = x))" by auto
  def f' \<equiv> "\<lambda>m. if m = card B then b else f m"
  from Suc.prems S IH
  have "(\<forall>m<Suc n. f' m \<in> S) \<and> (\<forall>x. x \<in> S \<longrightarrow> (\<exists>!m. m < Suc n \<and> f' m = x))"
    unfolding f'_def
    apply (clarsimp)
    apply (rule conjI, metis less_SucE)
    apply (metis less_SucE less_SucI nat_neq_iff)
    done
  thus ?case by blast
qed

lemma finite_index_works[rule_format]:
  "\<forall>i::'n. \<exists>!n. n < CARD('n::finite) \<and> finite_index n = i"
proof -
  have "\<exists>f::nat \<Rightarrow> 'n. \<forall>i. \<exists>!n. n < CARD('n) \<and> f n = i"
    using has_index[where S = "UNIV :: 'n set"] by simp
  thus ?thesis unfolding finite_index_def by (rule someI_ex)
qed

lemma finite_index_inj:
  "\<lbrakk> i < CARD('a::finite); j < CARD('a) \<rbrakk> \<Longrightarrow>
   ((finite_index i :: 'a) = finite_index j) = (i = j)"
  using finite_index_works[where i = "finite_index j"] by blast

lemma forall_finite_index:
  "(\<forall>k::('a::finite). P k) = (\<forall>i. i < CARD('a) \<longrightarrow> P (finite_index i))"
  by (metis (mono_tags, hide_lams) finite_index_works)

section {* Finite Cartesian Products *}

typedef ('a,'n::finite) array ("_[_]" [30,0] 31) = "UNIV :: ('n => 'a) set"
  by simp

definition
  index :: "('a,'n::finite) array \<Rightarrow> nat \<Rightarrow> 'a" ("_.[_]" [900,0] 901)
where
  "index x i \<equiv> Rep_array x (finite_index i)"

theorem array_index_eq:
  "((x::'a['n::finite]) = y) = (\<forall>i. i < CARD('n) \<longrightarrow> x.[i] = y.[i])"
  by (auto dest!: forall_finite_index [THEN iffD2]
           simp: index_def Rep_array_inject [symmetric])

(* FIXME: legacy name *)
lemmas cart_eq = array_index_eq

lemma array_ext:
  fixes x :: "'a['n::finite]"
  shows "(\<And>i. i < CARD('n) \<Longrightarrow> x.[i] = y.[i]) \<Longrightarrow> x = y"
  by (simp add: array_index_eq)

definition FCP :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a['b::finite]" where
  "FCP \<equiv> \<lambda>g. SOME a. \<forall>i. i < CARD('b) \<longrightarrow> a.[i] = g i"

notation FCP (binder "ARRAY " 10)

definition
  update :: "'a['n::finite] \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a['n]"
where
  "update f i x \<equiv> FCP ((index f)(i := x))"

definition
  fupdate :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a['b::finite] \<Rightarrow> 'a['b]"
where
  "fupdate i f x \<equiv> update x i (f (index x i))"

lemma fcp_beta[rule_format, simp]:
  "\<forall>i < CARD('n::finite). (FCP g :: 'a['n]).[i] = g i"
unfolding FCP_def
proof (rule someI_ex)
  let ?g' = "\<lambda>k::'n. g (SOME i. i < CARD('n) \<and> finite_index i = k)"
  have "\<forall>i<CARD('n). (Abs_array ?g').[i] = g i"
    by (clarsimp simp: index_def Abs_array_inverse)
       (metis (mono_tags, lifting) finite_index_inj someI_ex)
  thus "\<exists>x::'a['n]. \<forall>i<CARD('n). x.[i] = g i" ..
qed

lemma fcp_unique:
  "(ALL i. i < CARD('b::finite) --> (index f i = g i)) =
   (FCP g = (f :: ('a,'b) array))"
  by (fastforce simp: cart_eq)

lemma fcp_eta [simp]:
  "(ARRAY i. g.[i]) = g"
  by (simp add: cart_eq)

lemma index_update [simp]:
  "n < CARD('b::finite) \<Longrightarrow> index (update (f::'a['b]) n x) n = x"
  by (simp add: update_def)

lemma index_update2 [simp]:
  "\<lbrakk> k < CARD('b::finite); n \<noteq> k \<rbrakk> \<Longrightarrow> index (update (f::'a['b]) n x) k = index f k"
  by (simp add: update_def)

lemma update_update [simp]:
  "update (update f n x) n y = update f n y"
  by (simp add: cart_eq update_def)

lemma update_comm [simp]:
  "n \<noteq> m \<Longrightarrow> update (update f m v) n v' = update (update f n v') m v"
  by (simp add: cart_eq update_def)

lemma update_index_same [simp]:
  "update v n (index v n) = v"
  by (simp add: cart_eq update_def)

function
  foldli0 :: "(nat \<Rightarrow> 'acc \<Rightarrow> 'a \<Rightarrow> 'acc) \<Rightarrow> 'acc \<Rightarrow> nat \<Rightarrow> 'a['index::finite] \<Rightarrow> 'acc"
where
  "foldli0 f a i arr = (if CARD('index) \<le> i then a else foldli0 f (f i a (index arr i)) (i+1) arr)"
  by pat_completeness auto

termination
  by (relation "measure (\<lambda>(f,a,i,(arr::'b['c::finite])). CARD('c) - i)") auto

definition
  foldli :: "(nat => 'acc => 'a => 'acc) => 'acc => ('a,'i::finite) array => 'acc"
where
   "foldli f a arr == foldli0 f a 0 arr"

(* for a traditional word presentation, with MSB on the left, you'd
   want a fold that numbered in the reverse direction (with element 0
   on the right rather than the left) *)

definition
  map_array :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a['n::finite] \<Rightarrow> 'b['n]"
where
  "map_array f a \<equiv> ARRAY i. f (a.[i])"

definition
  map_array2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a['n::finite] \<Rightarrow> 'b['n] \<Rightarrow> 'c['n]"
where
  "map_array2 f a b \<equiv> ARRAY i. f (a.[i]) (b.[i])"

definition
  "zip_array \<equiv> map_array2 Pair"

definition
  list_array :: "('a,'n::finite) array \<Rightarrow> 'a list"
where
  "list_array a = map (index a) [0..<CARD('n)]"

setup_lifting type_definition_array
lift_definition set_array :: "'a['n::finite] \<Rightarrow> 'a set" is range .

lemma set_array_list:
  "set_array a = set (list_array a)"
  by (simp add: list_array_def index_def set_array.rep_eq image_def)
     (metis atLeast0LessThan finite_index_works lessThan_iff)

definition
  rel_array :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a['n::finite] \<Rightarrow> 'b['n] \<Rightarrow> bool"
where
  "rel_array f a b \<equiv> \<forall>i < CARD('n). f (a.[i]) (b.[i])"

lemma map_array_index:
  fixes a :: "'a['n::finite]"
  shows "n < CARD('n) \<Longrightarrow> (map_array f a).[n] = f (a.[n])"
  by (metis fcp_beta map_array_def)

lemma map_array2_index:
  fixes a :: "'a['n::finite]"
  shows "n < CARD('n) \<Longrightarrow> (map_array2 f a b).[n] = f (a.[n]) (b.[n])"
  by (metis fcp_beta map_array2_def)

lemma zip_array_index:
  fixes a :: "'a['n::finite]"
  shows "n < CARD('n) \<Longrightarrow> (zip_array a b).[n] = (a.[n],b.[n])"
  by (simp add: zip_array_def map_array2_index)

lemma map_array_id [simp]:
  "map_array id = id"
  by (auto simp: map_array_index array_ext)

lemma map_array_comp:
  "map_array (g \<circ> f) = map_array g \<circ> map_array f"
  by (auto simp: map_array_def intro!: array_ext)

lemma list_array_nth:
  fixes a :: "'a['n::finite]"
  shows "n < CARD('n) \<Longrightarrow> list_array a ! n = index a n"
  by (simp add: list_array_def)

lemma list_array_length [simp]:
  "length (list_array (a :: 'a['n::finite])) = CARD('n)"
  by (simp add: list_array_def)

lemma in_set_array_index_conv:
  "(z \<in> set_array (a :: 'a['n::finite])) = (\<exists>n < CARD('n). z = a.[n])"
  by (metis in_set_conv_nth list_array_length list_array_nth nth_mem set_array_list)

lemma in_set_arrayE [elim!]:
  "\<lbrakk> z \<in> set_array (a :: 'a['n::finite]); (\<And>n . \<lbrakk>n < CARD('n); z = a.[n]\<rbrakk> \<Longrightarrow> P) \<rbrakk> \<Longrightarrow> P"
  by (metis in_set_array_index_conv)

lemma map_array_setI:
  "(\<And>z. z \<in> set_array x \<Longrightarrow> f z = g z) \<Longrightarrow> map_array f x = map_array g x"
  by (rule array_ext) (auto simp: map_array_index in_set_array_index_conv)

lemma list_array_map_array:
  "list_array (map_array f a) = map f (list_array a)"
  by (simp add: list_array_def map_array_index)

lemma list_array_FCP [simp]:
  "list_array (FCP f :: 'a['n]) = map f [0..<CARD('n::finite)]"
  by (simp add: list_array_def)

lemma set_array_FCP [simp]:
  "set_array (FCP f :: 'a['n]) = f ` {0..< CARD('n::finite)}"
  by (auto simp: set_array_list)

lemma map_array_set_img:
  "set_array \<circ> map_array f = op ` f \<circ> set_array"
  by (rule ext) (auto simp: map_array_def in_set_array_index_conv intro!: imageI)

lemma fcp_cong [cong]:
  "(\<And>i. i < CARD('n::finite) \<Longrightarrow> f i = g i) \<Longrightarrow> FCP f = (FCP g :: 'a['n])"
  by (rule array_ext) simp

bnf "('a,'n::finite) array"
  map: map_array
  sets: set_array
  bd: "BNF_Cardinal_Arithmetic.csum natLeq (card_of (UNIV :: 'n set))"
  rel: rel_array
proof -
  show "map_array id = id" by simp
next
  fix f :: "'a \<Rightarrow> 'b" and g :: "'b \<Rightarrow> 'c"
  show "map_array (g \<circ> f) = map_array g \<circ> map_array f"
    by (rule map_array_comp)
next
  fix x :: "'a['n::finite]" and f :: "'a \<Rightarrow> 'b" and g
  assume "\<And>z. z \<in> set_array x \<Longrightarrow> f z = g z"
  thus "map_array f x = map_array g x"
    by (rule map_array_setI)
next
  fix f :: "'a \<Rightarrow> 'b"
  show "set_array \<circ> map_array f = op ` f \<circ> set_array"
    by (rule map_array_set_img)
next
  show "card_order (BNF_Cardinal_Arithmetic.csum natLeq (card_of UNIV))"
    by (simp add: card_of_card_order_on card_order_csum natLeq_card_order)
next
  show " BNF_Cardinal_Arithmetic.cinfinite (BNF_Cardinal_Arithmetic.csum natLeq (card_of UNIV))"
    by (simp add: cinfinite_csum natLeq_cinfinite)
next
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and S :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
  show "rel_array R OO rel_array S \<le> rel_array (R OO S)"
    by (force simp: rel_array_def)
next
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  { fix a :: "('a \<times> 'b)['n::finite]" and i
    have "\<lbrakk>set_array a \<subseteq> {(x, y). R x y}; i < CARD('n)\<rbrakk> \<Longrightarrow> R (fst (a.[i])) (snd (a.[i]))"
      by (meson Collect_splitD in_set_array_index_conv subset_iff)
  } note conv1 = this
  { fix a :: "'a['n::finite]" and b :: "'b['n]"
    let ?z = "zip_array a b"
    let ?A = "ARRAY i. fst (?z.[i])"
    let ?B = "ARRAY i. snd (?z.[i])"
    assume "\<forall>i<CARD('n). R (a.[i]) (b.[i])"
    hence "a = ?A \<and> b = ?B \<and> set_array ?z \<subseteq> {(x, y). R x y}"
      by (clarsimp simp: zip_array_index)
  } note conv2 = this
  show "rel_array R =
         (BNF_Def.Grp {x. set_array x \<subseteq> {(x, y). R x y}} (map_array fst))\<inverse>\<inverse> OO
          BNF_Def.Grp {x. set_array x \<subseteq> {(x, y). R x y}} (map_array snd)"
    unfolding Grp_def fun_eq_iff relcompp.simps conversep.simps
    by (auto simp: rel_array_def map_array_def BNF_Def.Grp_def conv1 dest: conv2)
next
  fix x :: "'a['n::finite]"
  let ?U = "UNIV :: 'n set"
  have "ordLeq3 (card_of (set_array x)) (card_of ?U)" by transfer (rule card_of_image)
  also
  have "ordLeq3 (card_of ?U) (BNF_Cardinal_Arithmetic.csum natLeq (card_of ?U))"
   by (rule ordLeq_csum2) (rule card_of_Card_order)
  finally
  show "ordLeq3 (card_of (set_array x)) (BNF_Cardinal_Arithmetic.csum natLeq (card_of ?U))" .
qed

end


theory IsarTutorial
imports Main
begin

lemma "apply": "(\<not>P \<and> \<not>Q) \<longrightarrow> \<not>(P \<or> Q)"
  apply (rule impI)
  apply (erule conjE)
  apply (rule notI)
  apply (erule disjE)
   apply (erule notE)
   apply assumption
  apply (erule_tac P="Q" in notE)
  apply assumption
  done

lemma "Isar": "(\<not>P \<and> \<not>Q) \<longrightarrow> \<not>(P \<or> Q)"
proof
  assume "\<not> P \<and> \<not> Q"
  then show "\<not> (P \<or> Q)"
  proof (rule conjE)
    assume np: "\<not>P" and nq: "\<not>Q"
    show "\<not> (P \<or> Q)"
    proof (rule notI)
      assume "P \<or> Q"
      then show "False"
      proof (rule disjE)
        assume "P"
        with np show "False" by (rule notE)
      next
        assume "Q"
        with nq show "False" by (rule notE)
      qed
    qed
  qed
qed

lemma "com_backward": "A \<and> B \<longrightarrow> B \<and> A"
proof (rule impI)
  assume ab: "A \<and> B"
  from this  show "B \<and> A"
  proof (rule conjE)
    assume a: "A" and b: "B"
    from b a show "B \<and> A" by (rule conjI)
  qed
qed

thm conjI       (* ?P \<Longrightarrow> ?Q \<Longrightarrow> ?P \<and> ?Q *)
thm conjE       (* ?P \<and> ?Q \<Longrightarrow> (?P \<Longrightarrow> ?Q \<Longrightarrow> ?R) \<Longrightarrow> ?R *)
thm conjunct1   (* ?P \<and> ?Q \<Longrightarrow> ?P *)
thm conjunct2   (* ?P \<and> ?Q \<Longrightarrow> ?Q *)
thm disjI1      (* ?P \<Longrightarrow> ?P \<or> ?Q *)
thm disjI2      (* ?Q \<Longrightarrow> ?P \<or> ?Q *)
thm disjE       (* ?P \<or> ?Q \<Longrightarrow> (?P \<Longrightarrow> ?R) \<Longrightarrow> (?Q \<Longrightarrow> ?R) \<Longrightarrow> ?R *)
thm impI        (* (?P \<Longrightarrow> ?Q) \<Longrightarrow> ?P \<longrightarrow> ?Q *)
thm mp          (* ?P \<longrightarrow> ?Q \<Longrightarrow> ?P \<Longrightarrow> ?Q *)
thm rev_mp      (* ?P \<Longrightarrow> ?P \<longrightarrow> ?Q \<Longrightarrow> ?Q *)
thm iffI        (* (?P \<Longrightarrow> ?Q) \<Longrightarrow> (?Q \<Longrightarrow> ?P) \<Longrightarrow> ?P = ?Q *)
thm notI        (* (?P \<Longrightarrow> False) \<Longrightarrow> \<not> ?P *)
thm ccontr      (* (\<not> ?P \<Longrightarrow> False) \<Longrightarrow> ?P *)
thm notE        (* \<not> ?P \<Longrightarrow> ?P \<Longrightarrow> ?R *)
thm classical   (* (\<not> ?P \<Longrightarrow> ?P) \<Longrightarrow> ?P *)
thm subst       (* ?s = ?t \<Longrightarrow> ?P ?s \<Longrightarrow> ?P ?t *)
thm ssubst      (* ?t = ?s \<Longrightarrow> ?P ?s \<Longrightarrow> ?P ?t *)
thm refl        (* ?t = ?t *)
thm allI        (* (\<And>x. ?P x) \<Longrightarrow> \<forall>x. ?P x *)
thm spec        (* \<forall>x. ?P x \<Longrightarrow> ?P ?x *)
thm exI         (* ?P ?x \<Longrightarrow> \<exists>x. ?P x *)
thm exE         (* \<exists>x. ?P x \<Longrightarrow> (\<And>x. ?P x \<Longrightarrow> ?Q) \<Longrightarrow> ?Q *)

lemma
  "com_backward_show_fail_ex1":
  "A \<and> B \<longrightarrow> B \<and> A"
proof (rule impI)
  assume ab: "A \<and> B"
  from this show "P \<longrightarrow> Q"
    oops

lemma
  "com_backward_show_fail_ex2":
  "A \<and> B \<longrightarrow> B \<and> A"
proof (rule impI)
  assume "A \<and> B" "A"
  show "B \<and> A"
    oops

lemma "rule_elim_fail_1_ex": "A \<and> B \<Longrightarrow> C \<longrightarrow> A \<and> C"
proof (rule impI)
  assume ab: "A \<and> B" and c: "C"
  from ab show "A \<and> C"
  proof (rule conjE)
    oops

lemma "rule_elim_fail_2_ex": "A \<Longrightarrow> B \<longrightarrow> B \<and> A"
proof (rule impI)
  assume a: "A" and b: "B"
  from b a show "B \<and> A"
  proof (rule conjI) qed
qed

lemma "com_backward_assume_B_A":
  shows "A \<and> B \<longrightarrow> B \<and> A"
proof (rule impI)
  assume ab: "A \<and> B"
  from this show "B \<and> A"
  proof (rule conjE)
    assume "B" "A"
    from this show "B \<and> A" by (rule conjI)
  qed
qed

lemma "com_backward_backquote": "A \<and> B \<longrightarrow> B \<and> A"
proof (rule impI)
  assume "A \<and> B"
  from `A \<and> B` show "B \<and> A"
  proof (rule conjE)
    assume "A" "B"
    from `B` `A` show "B \<and> A" by (rule conjI)
  qed
qed

lemma "Exer1-2_hint": "P \<and> Q \<longrightarrow> R \<Longrightarrow> P \<longrightarrow> (Q \<longrightarrow> R)"
proof (rule impI)
  assume pqr: "P \<and> Q \<longrightarrow> R"
  assume p: "P"
  show "Q \<longrightarrow> R"
  proof (rule impI)
    assume q: "Q"
    from pqr show "R"
    proof (rule mp)
      from p q show "P \<and> Q" by (rule conjI)
    qed
  qed
qed

lemma "Exer1-1": "Q \<Longrightarrow> (P \<longrightarrow> Q)"
  oops

lemma "Exer1-2": "(P \<and> Q) \<and> R \<longrightarrow> Q"
  oops

lemma "com_forward": "A \<and> B \<longrightarrow> B \<and> A"
proof (rule impI)
  assume ab: "A \<and> B"
  from ab have a: "A" by (rule conjunct1)
  from ab have b: "B" by (rule conjunct2)
  from b a show "B \<and> A" by (rule conjI)
qed

lemma "assumes_shows":
  assumes "A \<and> B" "C"
  shows "B \<and> C"
  using assms(1)
proof (rule conjE)
  assume "B"
  from this assms(2) show "B \<and> C" by (rule conjI)
qed

lemma "not_use_assumes_shows": "A \<and> B \<Longrightarrow> C \<Longrightarrow> B \<and> C"
proof -
  assume "C"
  assume "A \<and> B"
  from this show "B \<and> C"
  proof (rule conjE)
    assume "B"
    from this `C` show "B \<and> C" by (rule conjI)
  qed
qed

lemma "next":
  assumes "\<not>P \<or> Q" "P"
  shows "P \<and> Q"
  using assms(1)
proof (rule disjE)
  assume "\<not>P"
  from this assms(2) show "P \<and> Q" by (rule notE)
next
  assume "Q"
  from assms(2) this show "P \<and> Q" by (rule conjI)
qed

lemma "next_share_fact": "\<not>P \<or> Q \<Longrightarrow> P \<Longrightarrow> P \<and> Q"
proof (rule conjI)
  assume "P"
  show "P" by (rule `P`)
next
  assume 1: "\<not>P \<or> Q" and 2: "P"
  from 1 show "Q"
  proof (rule disjE)
    assume "\<not>P"
    from this 2 show "Q" by (rule notE)
  qed
qed

lemma "block":
  assumes "\<not>P \<or> Q" "P"
  shows "P \<and> Q"
  using assms(1)
proof (rule disjE)
  {
    assume "\<not>P"
    from this assms(2) show "P \<and> Q" by (rule notE)
  }
  {
    assume "Q"
    from assms(2) this show "P \<and> Q" by (rule conjI)
  }
qed

notepad begin
  have a: "A" sorry
  have b: "B" sorry
  thm conjI                    (* ?P \<Longrightarrow> ?Q \<Longrightarrow> ?P \<and> ?Q *)

  thm conjI[of A B]            (* A \<Longrightarrow> B \<Longrightarrow> A \<and> B *)
  thm conjI[where P=A and Q=B] (* A \<Longrightarrow> B \<Longrightarrow> A \<and> B *)

  thm conjI[OF a b]            (* A \<and> B *)
end

lemma "tips_standard_then_thesis_dot": "P \<and> Q \<Longrightarrow> P \<longrightarrow> Q"
proof (* = "proof standard" *)
  assume a: "P \<and> Q"
  from a show "Q"
  proof (rule conjE)
    assume c: "Q"
    then (* = from this *) show ?thesis (* = Q *) . (* = "by this" *)
  qed
qed

lemma "tips_standard_with_doubledots": "P \<and> Q \<longrightarrow> R \<Longrightarrow> P \<longrightarrow> (Q \<longrightarrow> R)"
proof (* = proof standard *)
  assume a: "P \<and> Q \<longrightarrow> R" and b: "P"
  show "Q \<longrightarrow> R"
  proof
    assume c: "Q"
    from b c have "P \<and> Q" .. (* = "by standard" *)
    with a show "R" ..
  qed
qed

lemma tips_of_where: "P \<and> Q \<longrightarrow> R \<Longrightarrow> P \<longrightarrow> (Q \<longrightarrow> R)"
proof (rule impI)
  assume pqr: "P \<and> Q \<longrightarrow> R"
  assume p: "P"
  show "Q \<longrightarrow> R"
  proof (rule impI)
    assume q: "Q"
    from pqr show "R"
    thm mp[of "P \<and> Q"] (* P \<and> Q \<longrightarrow> ?Q \<Longrightarrow> P \<and> Q \<Longrightarrow> ?Q *)
    thm mp[where P="P \<and> Q"] (* P \<and> Q \<longrightarrow> ?Q \<Longrightarrow> P \<and> Q \<Longrightarrow> ?Q *)
    proof (rule mp[of "P \<and> Q"]) (* = "proof (rule_tac P="P \<and> Q" in mp)" *)
      from p q show "P \<and> Q" by (rule conjI)
    qed
  qed
qed

lemma "comma": "P \<longleftrightarrow> P"
proof (rule iffI)
  (* goal (2 subgoals):
     1. P \<Longrightarrow> P
     2. P \<Longrightarrow> P
  *)
  oops

lemma "comma": "P \<longleftrightarrow> P"
proof (rule iffI, assumption, assumption) qed

lemma "semicolon": "P \<longleftrightarrow> P"
proof (rule iffI; assumption) qed

lemma "Exer2-1": "P \<longrightarrow> (P \<longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q"
  oops

lemma "Exer2-2": "P \<or> Q \<longrightarrow> R \<Longrightarrow> P \<Longrightarrow> R"
  oops

lemma "Exer2-3": "(P \<longrightarrow> Q) \<longrightarrow> (\<not>Q \<longrightarrow> \<not>P)"
  oops

lemma "Exer2-4":
  assumes "P \<or> Q" "\<not>P"
  shows "Q"
  oops

lemma "Exer2-5":
  assumes "(P \<or> Q) \<longrightarrow> R"
  shows "(P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)"
  oops

lemma "fix": "\<forall>x::nat. P x \<Longrightarrow> \<forall>y. P y"
proof (rule allI)
  fix a::nat
  assume "\<forall>x. P x"
  thm spec
  then show "P a" by (rule spec)
qed

lemma "obtain": "\<exists>x. P x \<Longrightarrow> \<exists>x. P x \<or> Q x"
proof -
  assume "\<exists>x. P x"
  then obtain x where "P x"  by (rule exE)
  then have "P x \<or> Q x" by (rule disjI1)
  then show ?thesis by (rule exI)
qed

lemma "Exer3-1":
  assumes "\<forall>x. P x" and "\<forall>x. P x \<longrightarrow> Q x"
  shows "\<forall>x. Q x"
  oops

lemma "Exer3-2":
  assumes "\<forall>x. (P x \<longrightarrow> (\<exists>y. Q y))"
  shows "(\<exists>x. P x) \<longrightarrow> (\<exists>x. Q x)"
  oops

lemma "Exer3-3(don't use obtain)":
  assumes "\<exists>x. P x"
  shows "\<exists>x. (P x \<or> Q x)"
  oops

lemma "Exer3-4": "x \<in> \<Union>C \<Longrightarrow> \<exists>A\<in>C. x \<in> A"
(* hint *)
thm UnionE (* ?A \<in> \<Union> ?C \<Longrightarrow> (\<And>X. ?A \<in> X \<Longrightarrow> X \<in> ?C \<Longrightarrow> ?R) \<Longrightarrow> ?R *)
thm bexI   (* ?P ?x \<Longrightarrow> ?x \<in> ?A \<Longrightarrow> \<exists>x\<in>?A. ?P x *)
  oops

lemma "moreover": "(P \<longrightarrow> Q) \<Longrightarrow> (P \<longrightarrow> R) \<Longrightarrow> (P \<longrightarrow> S) \<Longrightarrow> P \<Longrightarrow> Q \<and> R \<and> S"
proof -
  assume p: "P"
  assume "P \<longrightarrow> Q"
  with p have "Q" by (rule rev_mp)
  moreover
  assume "P \<longrightarrow> R"
  with p have "R" by (rule rev_mp)
  moreover
  assume "P \<longrightarrow> S"
  with p have "S" by (rule rev_mp)
  ultimately
  show ?thesis by (intro conjI)  (* TODO: intro ?thesis *)
qed

lemma "without-moreover": "(P \<longrightarrow> Q) \<Longrightarrow> (P \<longrightarrow> R) \<Longrightarrow> (P \<longrightarrow> S) \<Longrightarrow> P \<Longrightarrow> Q \<and> R \<and> S"
proof -
  assume p: "P"
  assume "P \<longrightarrow> Q"
  with p have a: "Q" by (rule rev_mp)
  assume "P \<longrightarrow> R"
  with p have b: "R" by (rule rev_mp)
  assume "P \<longrightarrow> S"
  with p have "S" by (rule rev_mp)
  with a b show ?thesis by (intro conjI)
qed

lemma "case": "P \<or> \<not>P"
proof (cases "P")
  case True
  then show ?thesis by (rule disjI1)
next
  case False
  then show ?thesis by (rule disjI2)
qed

notepad begin
  fix a b c::nat
  assume "a = b"
  have "a = c" unfolding `a = b`
    (* new goal: b = c *)
    sorry
end

notepad begin
  fix a b c::nat
  assume "b = a"
  have "a = c" unfolding `b = a` [symmetric]
    (* new goal: b = c *)
    sorry
end

notepad begin
  fix a b c::nat
  assume "a = b"
  have "a = c"
  proof (subst `a = b`)
    (* new goal *) show "b = c" sorry
  qed
end

notepad begin
  fix a b c d::nat
  assume "a = b"
  have "a = c \<and> d = a"
  proof (subst (2) `a = b`)
    (* new goal *) show "a = c \<and> d = b" sorry
  qed
end

notepad begin
  fix a b c d::nat
  assume 1: "a = b" and 2: "a = c"
  from 1 have "b = c"
  proof (subst (asm) `a = c`)
    (* new goal *) show "c = b \<Longrightarrow> b = c" sorry
  qed
end

notepad begin
  fix a b c d::nat
  assume 1: "a = b" and 2: "a = c" and 3: "a = d"
  from 1 2 have "b = c"
  proof (subst (asm) (2) `a = d`)
    (* new goal *) show "a = b \<Longrightarrow> d = c \<Longrightarrow> b = c" sorry
  qed
end

lemma "Exer4-1(use moreover, ultimately)": "A \<and> B \<Longrightarrow> B \<and> A"
  oops

lemma "Exer4-2(use moreover, ultimately)":
  assumes "(P \<longrightarrow> Q) \<and> (\<not>P \<longrightarrow> Q)"
  shows "Q"
  using assms
proof(rule conjE)
  assume 1: "P \<longrightarrow> Q" and 2: "\<not>P \<longrightarrow> Q"
  {
    assume "P"
    (* write proof *)
  }
  moreover
  {
    assume "\<not>P"
    (* write proof *)
  }
  ultimately show "Q" by ( (* write proof *) )
  oops

lemma "Exer4-3": "(P \<longrightarrow> Q) \<and> (\<not>P \<longrightarrow> Q) \<Longrightarrow> Q"
  oops

lemma "Exer4-4": "\<forall>x. P \<or> Q x \<Longrightarrow> P \<or> (\<forall>x. Q x)"
  oops

lemma "Exer4-5": "if y \<le> x then z = x else z = y \<Longrightarrow> z = x \<or> z = y"
(* hint *)
thm if_P      (* ?P \<Longrightarrow> (if ?P then ?x else ?y) = ?x *)
thm if_not_P  (* \<not> ?P \<Longrightarrow> (if ?P then ?x else ?y) = ?y *)
  oops

lemma "induction":
  assumes "a 0 = 1" "\<forall>n::nat. a (Suc n) = a n + 2"
  shows "a n = 2 * n + 1"
proof (induction n)
  case 0
  from assms(1) show ?case by simp
next
  case (Suc n)
  with assms show ?case by auto
qed

lemma "induction_also":
  assumes "a 0 = 1" "\<forall>n::nat. a (Suc n) = a n + 2"
  shows "a n = 2 * n + 1"
proof (induction n)
  case 0
  from assms(1) show ?case by simp
next
  case (Suc n)
  then show ?case
  proof -
    from assms(2) have "a (Suc n) = a n + 2" by (rule spec)
    also have "... = 2 * n + 1 + 2"
      by (subst Suc) (rule refl)
    also have "... = 2 * n + 2 + 1"
      by (subst semiring_normalization_rules(23)) (rule refl)
    also have "... = n * 2 + 2 + 1"
      by (subst semiring_normalization_rules(7)) (rule refl)
    also have "... = (n + 1) * 2 + 1"
      by (subst semiring_normalization_rules(2)) (rule refl)
    also have "... = 2 * (n + 1) + 1"
      by (subst semiring_normalization_rules(7)) (rule refl)
    also have "... = 2 * (Suc n) + 1"
      by (subst Nat.Suc_eq_plus1[symmetric]) (rule refl)
    finally show ?thesis .
  qed
qed

notepad begin
  have "a = b" sorry
  also have "... = c" sorry
  also have "... = d" sorry
  also have "... = e" sorry
  finally have "a = e" .
end

thm trans (* ?r = ?s \<Longrightarrow> ?s = ?t \<Longrightarrow> ?r = ?t *)
print_trans_rules

notepad begin
  have "a = b" sorry
  note cal = this have "... = c" sorry
  thm trans[OF cal this] (* a = c *)
  note cal = trans[OF cal this] have c: "... = d" sorry
  thm trans[OF cal this] (* a = d *)
  note cal = trans[OF cal this] have d: "... = e" sorry
  thm trans[OF cal this] (* a = e *)
  note cal = trans[OF cal this]
  from cal have "a = e" .
end

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

lemma "Exer8-1": "\<forall>m. add m n = m + n"
(* hint *)
thm add.simps(1) (* add ?m 0 = ?m *)
thm add.simps(2) (* add ?m (Suc ?n) = add (Suc ?m) ?n *)
thm add_0_right  (* ?a + 0 = ?a *)
thm add_Suc_shift (* Suc ?m + ?n = ?m + Suc ?n *)
  oops


theory sledgeCategory imports FreeLogic

abbrevs "modphism" = ":\<rightarrow>" and
        "wedge" = "\<leftarrow>-()-\<rightarrow>"

begin

 (*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 180]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 spass e vampire remote_leo3]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

section \<open>The basis of category theory\<close>

class category =
  fixes domain:: "'a \<Rightarrow> 'a" ("dom _" [108] 109) and
        codomain:: "'a\<Rightarrow> 'a" ("cod _" [110] 111) and
        composition:: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infix "\<cdot>" 110)

  assumes
        S1: "E(dom x) \<^bold>\<rightarrow> E x" and
        S2: "E(cod y) \<^bold>\<rightarrow> E y" and
        S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
        S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
        S5: "x\<cdot>(dom x) \<cong> x" and
        S6: "(cod y)\<cdot>y \<cong> y"

class categoryOp =
  fixes domainOp:: "'a \<Rightarrow> 'a" ("domOp _" [108] 109) and
        codomainOp:: "'a\<Rightarrow> 'a" ("codOp _" [110] 111) and
        compositionOp:: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infix "\<cdot>\<^sub>o\<^sub>p" 110)

  assumes
        opS1: "E(domOp x) \<^bold>\<rightarrow> E x" and
        opS2: "E(codOp y) \<^bold>\<rightarrow> E y" and
        opS3: "E(x\<cdot>\<^sub>o\<^sub>py) \<^bold>\<leftrightarrow> domOp x \<simeq> codOp y" and
        opS4: "x\<cdot>\<^sub>o\<^sub>p(y\<cdot>\<^sub>o\<^sub>pz) \<cong> (x\<cdot>\<^sub>o\<^sub>py)\<cdot>\<^sub>o\<^sub>pz" and
        opS5: "x\<cdot>\<^sub>o\<^sub>p(domOp x) \<cong> x" and
        opS6: "(codOp y)\<cdot>\<^sub>o\<^sub>py \<cong> y"

sublocale category \<subseteq> categoryOp codomain domain "\<lambda>x y. y \<cdot> x"
proof
  show "\<And>x::'a. E x \<^bold>\<leftarrow> E (cod x)"
    using S2 by blast

  show "\<And>y::'a. E y \<^bold>\<leftarrow> E (dom y)"
    using S1 by blast

  show "\<And>(x::'a) y::'a. E(y\<cdot>x) \<^bold>\<leftrightarrow> cod x \<simeq> dom y"
    by (metis S3)

  show "\<And>(x::'a) (y::'a) z::'a. (z \<cdot> y) \<cdot> x \<cong> z \<cdot> (y \<cdot> x)"
    using S4 by fastforce

  show "\<And>x::'a. (cod x) \<cdot> x \<cong> x"
    using S6 by blast

  show "\<And>y::'a. y \<cdot> (dom y) \<cong> y"
    using S5 by blast
qed

sublocale categoryOp \<subseteq> category codomainOp domainOp "\<lambda>x y. y \<cdot>\<^sub>o\<^sub>p x"
proof
  show "\<And>x::'a. E x \<^bold>\<leftarrow> E (codOp x)"
    using opS2 by blast

  show "\<And>y::'a. E y \<^bold>\<leftarrow> E (domOp y)"
    using opS1 by blast

  show "\<And>(x::'a) y::'a. E(y\<cdot>\<^sub>o\<^sub>px) \<^bold>\<leftrightarrow> codOp x \<simeq> domOp y"
    by (metis opS3)

  show "\<And>(x::'a) (y::'a) z::'a. (z \<cdot>\<^sub>o\<^sub>p y) \<cdot>\<^sub>o\<^sub>p x \<cong> z \<cdot>\<^sub>o\<^sub>p (y \<cdot>\<^sub>o\<^sub>p x)"
    using opS4 by fastforce

  show "\<And>x::'a. (codOp x) \<cdot>\<^sub>o\<^sub>p x \<cong> x"
    using opS6 by blast

  show "\<And>y::'a. y \<cdot>\<^sub>o\<^sub>p (domOp y) \<cong> y"
    using opS5 by blast
qed

context category begin

abbreviation type ("type") where "type x \<equiv> x \<cong> dom x"

abbreviation arrow ("(_):(_)\<rightarrow>(_)" [120,120,120] 119) where
  "x:a\<rightarrow>b \<equiv> dom x \<simeq> a \<and> cod x \<simeq> b"

abbreviation wedge ("_\<leftarrow>_- (_) -_\<rightarrow>_" [120,0,0,0,120] 119) where
  "a \<leftarrow>f- (x) -g\<rightarrow> b \<equiv> dom f \<simeq> x \<and> cod f \<simeq> a \<and> dom g \<simeq> x \<and> cod g \<simeq> b"

abbreviation monic::"'a \<Rightarrow> bool" ("monic") where
  "(monic m) \<equiv> \<forall>f g. m\<cdot>f \<simeq> m\<cdot>g \<longrightarrow> f \<simeq> g"

abbreviation epi::"'a \<Rightarrow> bool" ("epi") where
  "(epi m) \<equiv> \<forall>f g. f\<cdot>m \<simeq> g\<cdot>m \<longrightarrow> f \<simeq> g"

abbreviation isomorphism::"'a \<Rightarrow> bool" ("isomorphism") where
  "(isomorphism f) \<equiv> \<exists>g. f\<cdot>g \<cong> (dom g) \<and> g\<cdot>f \<cong> (dom f)"

abbreviation isomorphic::"'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<cong>" 120) where
  "isomorphic z y \<equiv> \<exists>f. dom f \<cong> z \<and> cod f \<cong> y \<and> isomorphism f"

abbreviation initial::"'a \<Rightarrow> bool" ("initial") where
  "(initial z) \<equiv> \<^bold>\<forall>t. (type t) \<longrightarrow> (\<exists>!f. ((dom f) \<simeq> z \<and> (cod f) \<simeq> t))"

abbreviation final::"'a \<Rightarrow> bool" ("final") where
  "(final z) \<equiv> \<^bold>\<forall>t. (type t) \<longrightarrow> (\<exists>!f. ((dom f) \<simeq> t \<and> (cod f) \<simeq> z))"

\<comment>\<open>Checking equivalences of abbreviations\<close>
lemma StrongerInitial1: "(initial z) \<longrightarrow>  (\<^bold>\<forall>t.(type t)\<longrightarrow> (\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t))" (* sledgehammer sledgehammer [remote_leo3] *)
  by (metis S1)

lemma StrongerInitial2: "(\<^bold>\<forall>t. (type t)\<longrightarrow>(\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t)) \<longrightarrow> initial z"  (*sledgehammer sledgehammer [remote_leo3]*)
  by (metis local.S1)

lemma WeakerInitial1: "(\<^bold>\<forall>t. (type t) \<longrightarrow> (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t)) \<longrightarrow> initial z" (* sledgehammer sledgehammer [remote_leo3] *)
  by (smt S5 S2 S3 category_axioms)

lemma WeakerInitial2: "(initial z) \<longrightarrow> (\<^bold>\<forall>t. (type t) \<longrightarrow> (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t))" (* sledgehammer sledgehammer [remote_leo3] *)
  by smt
(*The same as above would do for final*)

end

lemma (in category) InitialsAreIsomorphic: "initial z \<and> initial y \<longrightarrow> z \<^bold>\<cong> y"  (*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)*)
  by (smt S1 S2 S3 S4 S5 S6)

lemma (in category) InitialIsUnique: "\<forall>z. \<forall>f. initial z \<and> (dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f" (*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)*)
  by (smt S3 S5 S6)

lemma (in category) FinalsAreIsomorphic: "final z \<and> final y \<longrightarrow> z \<^bold>\<cong> y" (*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)*)
  by (smt S1 S2 S3 S4 S5 S6)

lemma (in category) FinalIsUnique: "\<forall>z. \<forall>f. final z \<and> ( dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f" (* sledgehammer sledgehammer [remote_leo3] *)
  by (metis S2 S3 S5 S6)

lemma (in category) TwoMonicsBetweenTypes: "(\<^bold>\<forall>(m::'a) (n::'a). monic m \<and> monic n \<and> dom m \<simeq> dom n \<and> cod m \<simeq> cod n \<longrightarrow> (m\<simeq>n))" nitpick oops

(*Relationship between isomorphisms and epic and monic maps*)
proposition (in category) "isomorphism m \<longrightarrow> monic m \<and> epi m"  \<comment>\<open>cvc4 and Leo-III proves this\<close>
  (* sledgehammer sledgehammer [remote_leo3] *)
  by (smt S1 S3 S4 S5 S6)

proposition (in category) "monic m \<and> epi m \<longrightarrow> isomorphism m" nitpick oops

section \<open>Product\<close>

abbreviation (in category) product::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("product") where
"product a b c p1 p2 \<equiv> dom p1 \<simeq> c \<and> cod p1 \<simeq> a \<and> dom p2 \<simeq> c \<and> cod p2 \<simeq> b \<and>
                  (\<^bold>\<forall>x f g. dom f \<simeq> x \<and> cod f \<simeq> a \<and> dom g \<simeq> x \<and> cod g \<simeq> b \<longrightarrow> (\<^bold>\<exists>!h. dom h \<simeq> x \<and> cod h \<simeq> c \<and> f \<simeq> p1\<cdot>h \<and> g \<simeq> p2\<cdot>h))"

lemma (in category) productIso: "((product a b c p1 p2) \<and> (product a b d q1 q2)) \<longrightarrow> c \<^bold>\<cong> d"
   by (smt S1 S2 S4 S3 S5 S6)

lemma (in category) productAssoc: "((product b a c p1 p2) \<longrightarrow>  (product a b c p2 p1))"
   (*sledgehammer  sledgehammer [remote_leo3]()*)
  by smt

context categoryOp begin

abbreviation coproduct::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "coproduct \<equiv> categoryOp.type"

end

lemma (in category) coproductIso: "((coproduct a b c p1 p2) \<and> (coproduct a b d q1 q2)) \<longrightarrow> c \<^bold>\<cong> d" sledgehammer(S1 S2 S4 S3 S5 S6)  sledgehammer [remote_leo3](S1 S2 S4 S3 S5 S6)

end