(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_StoogeSort2Permutes
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 y =
   (case splitAt ((op div) ((2 * (length y)) + 1) 3) y of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort2 xs) xs"
  oops

end


theory SmallExamples

imports
  Main
  "Category2/Category"

begin

section "Small concrete examples"

(* Category [one_cat] with exactly one object *)
datatype one_cat_obj =
  Obj1
datatype one_cat_morph =
  Id1  (* the unique morphism is the identity by identity law *)

definition one_cat :: "(one_cat_obj, one_cat_morph) Category" where
  "one_cat = MakeCat \<lparr>
    Obj = { Obj1 },
    Mor = { Id1 },
    Dom = \<lambda>f. case f of
              Id1 \<Rightarrow> Obj1,
    Cod = \<lambda>f. case f of
              Id1 \<Rightarrow> Obj1,
    Id = \<lambda>x. case x of
              Obj1 \<Rightarrow> Id1,
    Comp = \<lambda>f1 f2. case (f1, f2) of
                (Id1, Id1) \<Rightarrow> Id1
  \<rparr>"

(* Proving the above scheme satisfies category axioms *)
lemma "Category (one_cat)"
apply (simp add: one_cat_def)
apply (rule MakeCat)
apply (unfold_locales)
apply (auto)
apply (case_tac h, auto)
apply (case_tac g, auto)
done

(* Category [two_cat] with exactly two objects *)
datatype two_cat_obj =
    ObjA
  | ObjB
datatype two_cat_morph =
    MorphF
  | IdA
  | IdB

definition two_cat :: "(two_cat_obj, two_cat_morph) Category" where
  "two_cat = MakeCat \<lparr>
    Obj = { ObjA, ObjB },
    Mor = { MorphF, IdA, IdB },
    Dom = \<lambda>f. case f of
              MorphF \<Rightarrow> ObjA
            | IdA \<Rightarrow> ObjA
            | IdB \<Rightarrow> ObjB,
    Cod = \<lambda>f. case f of
              MorphF \<Rightarrow> ObjB
            | IdA \<Rightarrow> ObjA
            | IdB \<Rightarrow> ObjB,
    Id = \<lambda>x. case x of
              ObjA \<Rightarrow> IdA
            | ObjB \<Rightarrow> IdB,
    Comp = \<lambda>f1 f2. case (f1, f2) of
                (IdA, IdA) \<Rightarrow> IdA
              | (IdB, IdB) \<Rightarrow> IdB
              | (IdA, MorphF) \<Rightarrow> MorphF
              | (MorphF, IdB) \<Rightarrow> MorphF
  \<rparr>"

(* Proving the above scheme satisfies category axioms *)
lemma "Category (two_cat)"
apply (simp add: two_cat_def)
apply (rule MakeCat)
apply (unfold_locales)
apply (auto)
apply (fastforce+)
done

(* Category [three_cat] with exactly three objects *)
datatype three_cat_obj =
    ObjA3
  | ObjB3
  | ObjC3
datatype three_cat_morph =
    MorphF3
  | MorphG3
  | MorphH3
  | IdA3
  | IdB3
  | IdC3

definition three_cat :: "(three_cat_obj, three_cat_morph) Category" where
  "three_cat = MakeCat \<lparr>
    Obj = { ObjA3, ObjB3, ObjC3 },
    Mor = { MorphF3, MorphG3, MorphH3, IdA3, IdB3, IdC3 },
    Dom = \<lambda>f. case f of
              MorphF3 \<Rightarrow> ObjA3
            | MorphG3 \<Rightarrow> ObjB3
            | MorphH3 \<Rightarrow> ObjA3
            | IdA3 \<Rightarrow> ObjA3
            | IdB3 \<Rightarrow> ObjB3
            | IdC3 \<Rightarrow> ObjC3,
    Cod = \<lambda>f. case f of
              MorphF3 \<Rightarrow> ObjB3
            | MorphG3 \<Rightarrow> ObjC3
            | MorphH3 \<Rightarrow> ObjC3
            | IdA3 \<Rightarrow> ObjA3
            | IdB3 \<Rightarrow> ObjB3
            | IdC3 \<Rightarrow> ObjC3,
    Id = \<lambda>x. case x of
              ObjA3 \<Rightarrow> IdA3
            | ObjB3 \<Rightarrow> IdB3
            | ObjC3 \<Rightarrow> IdC3,
    Comp = \<lambda>f1 f2. case (f1, f2) of
              (MorphF3, MorphG3) \<Rightarrow> MorphH3
            | (IdA3, MorphF3) \<Rightarrow> MorphF3
            | (IdA3, MorphH3) \<Rightarrow> MorphH3
            | (IdA3, IdA3) \<Rightarrow> IdA3
            | (MorphF3, IdB3) \<Rightarrow> MorphF3
            | (IdB3, MorphG3) \<Rightarrow> MorphG3
            | (IdB3, IdB3) \<Rightarrow> IdB3
            | (IdC3, IdC3) \<Rightarrow> IdC3
            | (MorphH3, IdC3) \<Rightarrow> MorphH3
            | (MorphG3, IdC3) \<Rightarrow> MorphG3
  \<rparr>"

lemma "Category (three_cat)"
apply (simp add: three_cat_def)
apply (rule MakeCat)
apply (unfold_locales)
apply (fastforce+)
done

definition undefined_cat :: "('o, 'm) Category" where
  "undefined_cat = MakeCat \<lparr>
    Obj = { undefined },
    Mor = { undefined },
    Dom = \<lambda>f. undefined,
    Cod = \<lambda>f. undefined,
    Id = \<lambda>x. undefined,
    Comp = \<lambda>f1 f2. undefined
  \<rparr>"

value "undefined = undefined"

end


(* Author: Tobias Nipkow *)

theory Def_Init_Big
imports Def_Init_Exp Def_Init
begin

subsection "Initialization-Sensitive Big Step Semantics"

inductive
  big_step :: "(com \<times> state option) \<Rightarrow> state option \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
None: "(c,None) \<Rightarrow> None" |
Skip: "(SKIP,s) \<Rightarrow> s" |
AssignNone: "aval a s = None \<Longrightarrow> (x ::= a, Some s) \<Rightarrow> None" |
Assign: "aval a s = Some i \<Longrightarrow> (x ::= a, Some s) \<Rightarrow> Some(s(x := Some i))" |
Seq:    "(c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2 \<Longrightarrow> (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s\<^sub>1) \<Rightarrow> s\<^sub>3" |

IfNone:  "bval b s = None \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> None" |
IfTrue:  "\<lbrakk> bval b s = Some True;  (c\<^sub>1,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> s'" |
IfFalse: "\<lbrakk> bval b s = Some False;  (c\<^sub>2,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> s'" |

WhileNone: "bval b s = None \<Longrightarrow> (WHILE b DO c,Some s) \<Rightarrow> None" |
WhileFalse: "bval b s = Some False \<Longrightarrow> (WHILE b DO c,Some s) \<Rightarrow> Some s" |
WhileTrue:
  "\<lbrakk> bval b s = Some True;  (c,Some s) \<Rightarrow> s';  (WHILE b DO c,s') \<Rightarrow> s'' \<rbrakk> \<Longrightarrow>
  (WHILE b DO c,Some s) \<Rightarrow> s''"

lemmas big_step_induct = big_step.induct[split_format(complete)]

subsection "Soundness wrt Big Steps"

text\<open>Note the special form of the induction because one of the arguments
of the inductive predicate is not a variable but the term \<^term>\<open>Some s\<close>:\<close>

theorem Sound:
  "\<lbrakk> (c,Some s) \<Rightarrow> s';  D A c A';  A \<subseteq> dom s \<rbrakk>
  \<Longrightarrow> \<exists> t. s' = Some t \<and> A' \<subseteq> dom t"
proof (induction c "Some s" s' arbitrary: s A A' rule:big_step_induct)
  case AssignNone thus ?case
    by auto (metis aval_Some option.simps(3) subset_trans)
next
  case Seq thus ?case by auto metis
next
  case IfTrue thus ?case by auto blast
next
  case IfFalse thus ?case by auto blast
next
  case IfNone thus ?case
    by auto (metis bval_Some option.simps(3) order_trans)
next
  case WhileNone thus ?case
    by auto (metis bval_Some option.simps(3) order_trans)
next
  case (WhileTrue b s c s' s'')
  from \<open>D A (WHILE b DO c) A'\<close> obtain A' where "D A c A'" by blast
  then obtain t' where "s' = Some t'" "A \<subseteq> dom t'"
    by (metis D_incr WhileTrue(3,7) subset_trans)
  from WhileTrue(5)[OF this(1) WhileTrue(6) this(2)] show ?case .
qed auto

corollary sound: "\<lbrakk>  D (dom s) c A';  (c,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> s' \<noteq> None"
by (metis Sound not_Some_eq subset_refl)

end


(*  Title:      HOL/Library/Stream.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012, 2013

Infinite streams.
*)

section \<open>Infinite Streams\<close>

theory Stream
  imports Nat_Bijection
begin

codatatype (sset: 'a) stream =
  SCons (shd: 'a) (stl: "'a stream") (infixr \<open>##\<close> 65)
for
  map: smap
  rel: stream_all2

context
begin

\<comment> \<open>for code generation only\<close>
qualified definition smember :: "'a \<Rightarrow> 'a stream \<Rightarrow> bool" where
  [code_abbrev]: "smember x s \<longleftrightarrow> x \<in> sset s"

lemma smember_code[code, simp]: "smember x (y ## s) = (if x = y then True else smember x s)"
  unfolding smember_def by auto

end

lemmas smap_simps[simp] = stream.map_sel
lemmas shd_sset = stream.set_sel(1)
lemmas stl_sset = stream.set_sel(2)

theorem sset_induct[consumes 1, case_names shd stl, induct set: sset]:
  assumes "y \<in> sset s" and "\<And>s. P (shd s) s" and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
  shows "P y s"
using assms by induct (metis stream.sel(1), auto)

lemma smap_ctr: "smap f s = x ## s' \<longleftrightarrow> f (shd s) = x \<and> smap f (stl s) = s'"
  by (cases s) simp

subsection \<open>prepend list to stream\<close>

primrec shift :: "'a list \<Rightarrow> 'a stream \<Rightarrow> 'a stream" (infixr \<open>@-\<close> 65) where
  "shift [] s = s"
| "shift (x # xs) s = x ## shift xs s"

lemma smap_shift[simp]: "smap f (xs @- s) = map f xs @- smap f s"
  by (induct xs) auto

lemma shift_append[simp]: "(xs @ ys) @- s = xs @- ys @- s"
  by (induct xs) auto

lemma shift_simps[simp]:
   "shd (xs @- s) = (if xs = [] then shd s else hd xs)"
   "stl (xs @- s) = (if xs = [] then stl s else tl xs @- s)"
  by (induct xs) auto

lemma sset_shift[simp]: "sset (xs @- s) = set xs \<union> sset s"
  by (induct xs) auto

lemma shift_left_inj[simp]: "xs @- s1 = xs @- s2 \<longleftrightarrow> s1 = s2"
  by (induct xs) auto

subsection \<open>set of streams with elements in some fixed set\<close>

context
  notes [[inductive_internals]]
begin

coinductive_set
  streams :: "'a set \<Rightarrow> 'a stream set"
  for A :: "'a set"
where
  Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"

end

lemma in_streams: "stl s \<in> streams S \<Longrightarrow> shd s \<in> S \<Longrightarrow> s \<in> streams S"
  by (cases s) auto

lemma streamsE: "s \<in> streams A \<Longrightarrow> (shd s \<in> A \<Longrightarrow> stl s \<in> streams A \<Longrightarrow> P) \<Longrightarrow> P"
  by (erule streams.cases) simp_all

lemma Stream_image: "x ## y \<in> ((##) x') ` Y \<longleftrightarrow> x = x' \<and> y \<in> Y"
  by auto

lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
  by (induct w) auto

lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
  by (auto elim: streams.cases)

lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
  by (cases s) (auto simp: streams_Stream)

lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
  by (cases s) (auto simp: streams_Stream)

lemma sset_streams:
  assumes "sset s \<subseteq> A"
  shows "s \<in> streams A"
using assms proof (coinduction arbitrary: s)
  case streams then show ?case by (cases s) simp
qed

lemma streams_sset:
  assumes "s \<in> streams A"
  shows "sset s \<subseteq> A"
proof
  fix x assume "x \<in> sset s" from this \<open>s \<in> streams A\<close> show "x \<in> A"
    by (induct s) (auto intro: streams_shd streams_stl)
qed

lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
  by (metis sset_streams streams_sset)

lemma streams_mono:  "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
  unfolding streams_iff_sset by auto

lemma streams_mono2: "S \<subseteq> T \<Longrightarrow> streams S \<subseteq> streams T"
  by (auto intro: streams_mono)

lemma smap_streams: "s \<in> streams A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> smap f s \<in> streams B"
  unfolding streams_iff_sset stream.set_map by auto

lemma streams_empty: "streams {} = {}"
  by (auto elim: streams.cases)

lemma streams_UNIV[simp]: "streams UNIV = UNIV"
  by (auto simp: streams_iff_sset)

subsection \<open>nth, take, drop for streams\<close>

primrec snth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a" (infixl \<open>!!\<close> 100) where
  "s !! 0 = shd s"
| "s !! Suc n = stl s !! n"

lemma snth_Stream: "(x ## s) !! Suc i = s !! i"
  by simp

lemma snth_smap[simp]: "smap f s !! n = f (s !! n)"
  by (induct n arbitrary: s) auto

lemma shift_snth_less[simp]: "p < length xs \<Longrightarrow> (xs @- s) !! p = xs ! p"
  by (induct p arbitrary: xs) (auto simp: hd_conv_nth nth_tl)

lemma shift_snth_ge[simp]: "p \<ge> length xs \<Longrightarrow> (xs @- s) !! p = s !! (p - length xs)"
  by (induct p arbitrary: xs) (auto simp: Suc_diff_eq_diff_pred)

lemma shift_snth: "(xs @- s) !! n = (if n < length xs then xs ! n else s !! (n - length xs))"
  by auto

lemma snth_sset[simp]: "s !! n \<in> sset s"
  by (induct n arbitrary: s) (auto intro: shd_sset stl_sset)

lemma sset_range: "sset s = range (snth s)"
proof (intro equalityI subsetI)
  fix x assume "x \<in> sset s"
  thus "x \<in> range (snth s)"
  proof (induct s)
    case (stl s x)
    then obtain n where "x = stl s !! n" by auto
    thus ?case by (auto intro: range_eqI[of _ _ "Suc n"])
  qed (auto intro: range_eqI[of _ _ 0])
qed auto

lemma streams_iff_snth: "s \<in> streams X \<longleftrightarrow> (\<forall>n. s !! n \<in> X)"
  by (force simp: streams_iff_sset sset_range)

lemma snth_in: "s \<in> streams X \<Longrightarrow> s !! n \<in> X"
  by (simp add: streams_iff_snth)

primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
  "stake 0 s = []"
| "stake (Suc n) s = shd s # stake n (stl s)"

lemma length_stake[simp]: "length (stake n s) = n"
  by (induct n arbitrary: s) auto

lemma stake_smap[simp]: "stake n (smap f s) = map f (stake n s)"
  by (induct n arbitrary: s) auto

lemma take_stake: "take n (stake m s) = stake (min n m) s"
proof (induct m arbitrary: s n)
  case (Suc m) thus ?case by (cases n) auto
qed simp

primrec sdrop :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
  "sdrop 0 s = s"
| "sdrop (Suc n) s = sdrop n (stl s)"

lemma sdrop_simps[simp]:
  "shd (sdrop n s) = s !! n" "stl (sdrop n s) = sdrop (Suc n) s"
  by (induct n arbitrary: s)  auto

lemma sdrop_smap[simp]: "sdrop n (smap f s) = smap f (sdrop n s)"
  by (induct n arbitrary: s) auto

lemma sdrop_stl: "sdrop n (stl s) = stl (sdrop n s)"
  by (induct n) auto

lemma drop_stake: "drop n (stake m s) = stake (m - n) (sdrop n s)"
proof (induct m arbitrary: s n)
  case (Suc m) thus ?case by (cases n) auto
qed simp

lemma stake_sdrop: "stake n s @- sdrop n s = s"
  by (induct n arbitrary: s) auto

lemma id_stake_snth_sdrop:
  "s = stake i s @- s !! i ## sdrop (Suc i) s"
  by (subst stake_sdrop[symmetric, of _ i]) (metis sdrop_simps stream.collapse)

lemma smap_alt: "smap f s = s' \<longleftrightarrow> (\<forall>n. f (s !! n) = s' !! n)" (is "?L = ?R")
proof
  assume ?R
  then have "\<And>n. smap f (sdrop n s) = sdrop n s'"
    by coinduction (auto intro: exI[of _ 0] simp del: sdrop.simps(2))
  then show ?L using sdrop.simps(1) by metis
qed auto

lemma stake_invert_Nil[iff]: "stake n s = [] \<longleftrightarrow> n = 0"
  by (induct n) auto

lemma sdrop_shift: "sdrop i (w @- s) = drop i w @- sdrop (i - length w) s"
  by (induct i arbitrary: w s) (auto simp: drop_tl drop_Suc neq_Nil_conv)

lemma stake_shift: "stake i (w @- s) = take i w @ stake (i - length w) s"
  by (induct i arbitrary: w s) (auto simp: neq_Nil_conv)

lemma stake_add[simp]: "stake m s @ stake n (sdrop m s) = stake (m + n) s"
  by (induct m arbitrary: s) auto

lemma sdrop_add[simp]: "sdrop n (sdrop m s) = sdrop (m + n) s"
  by (induct m arbitrary: s) auto

lemma sdrop_snth: "sdrop n s !! m = s !! (n + m)"
  by (induct n arbitrary: m s) auto

partial_function (tailrec) sdrop_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
  "sdrop_while P s = (if P (shd s) then sdrop_while P (stl s) else s)"

lemma sdrop_while_SCons[code]:
  "sdrop_while P (a ## s) = (if P a then sdrop_while P s else a ## s)"
  by (subst sdrop_while.simps) simp

lemma sdrop_while_sdrop_LEAST:
  assumes "\<exists>n. P (s !! n)"
  shows "sdrop_while (Not \<circ> P) s = sdrop (LEAST n. P (s !! n)) s"
proof -
  from assms obtain m where "P (s !! m)" "\<And>n. P (s !! n) \<Longrightarrow> m \<le> n"
    and *: "(LEAST n. P (s !! n)) = m" by atomize_elim (auto intro: LeastI Least_le)
  thus ?thesis unfolding *
  proof (induct m arbitrary: s)
    case (Suc m)
    hence "sdrop_while (Not \<circ> P) (stl s) = sdrop m (stl s)"
      by (metis (full_types) not_less_eq_eq snth.simps(2))
    moreover from Suc(3) have "\<not> (P (s !! 0))" by blast
    ultimately show ?case by (subst sdrop_while.simps) simp
  qed (metis comp_apply sdrop.simps(1) sdrop_while.simps snth.simps(1))
qed

primcorec sfilter where
  "shd (sfilter P s) = shd (sdrop_while (Not \<circ> P) s)"
| "stl (sfilter P s) = sfilter P (stl (sdrop_while (Not \<circ> P) s))"

lemma sfilter_Stream: "sfilter P (x ## s) = (if P x then x ## sfilter P s else sfilter P s)"
proof (cases "P x")
  case True thus ?thesis by (subst sfilter.ctr) (simp add: sdrop_while_SCons)
next
  case False thus ?thesis by (subst (1 2) sfilter.ctr) (simp add: sdrop_while_SCons)
qed

subsection \<open>unary predicates lifted to streams\<close>

definition "stream_all P s = (\<forall>p. P (s !! p))"

lemma stream_all_iff[iff]: "stream_all P s \<longleftrightarrow> Ball (sset s) P"
  unfolding stream_all_def sset_range by auto

lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
  unfolding stream_all_iff list_all_iff by auto

lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
  by simp

subsection \<open>recurring stream out of a list\<close>

primcorec cycle :: "'a list \<Rightarrow> 'a stream" where
  "shd (cycle xs) = hd xs"
| "stl (cycle xs) = cycle (tl xs @ [hd xs])"

lemma cycle_decomp: "u \<noteq> [] \<Longrightarrow> cycle u = u @- cycle u"
proof (coinduction arbitrary: u)
  case Eq_stream then show ?case using stream.collapse[of "cycle u"]
    by (auto intro!: exI[of _ "tl u @ [hd u]"])
qed

lemma cycle_Cons[code]: "cycle (x # xs) = x ## cycle (xs @ [x])"
  by (subst cycle.ctr) simp

lemma cycle_rotated: "\<lbrakk>v \<noteq> []; cycle u = v @- s\<rbrakk> \<Longrightarrow> cycle (tl u @ [hd u]) = tl v @- s"
  by (auto dest: arg_cong[of _ _ stl])

lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
proof (induct n arbitrary: u)
  case (Suc n) thus ?case by (cases u) auto
qed auto

lemma stake_cycle_le[simp]:
  assumes "u \<noteq> []" "n < length u"
  shows "stake n (cycle u) = take n u"
using min_absorb2[OF less_imp_le_nat[OF assms(2)]]
  by (subst cycle_decomp[OF assms(1)], subst stake_append) auto

lemma stake_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> stake (length u) (cycle u) = u"
  by (subst cycle_decomp) (auto simp: stake_shift)

lemma sdrop_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> sdrop (length u) (cycle u) = cycle u"
  by (subst cycle_decomp) (auto simp: sdrop_shift)

lemma stake_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
   stake n (cycle u) = concat (replicate (n div length u) u)"
  by (induct "n div length u" arbitrary: n u)
    (auto simp: stake_add [symmetric] mod_eq_0_iff_dvd elim!: dvdE)

lemma sdrop_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
   sdrop n (cycle u) = cycle u"
  by (induct "n div length u" arbitrary: n u)
    (auto simp: sdrop_add [symmetric] mod_eq_0_iff_dvd elim!: dvdE)

lemma stake_cycle: "u \<noteq> [] \<Longrightarrow>
   stake n (cycle u) = concat (replicate (n div length u) u) @ take (n mod length u) u"
  by (subst div_mult_mod_eq[of n "length u", symmetric], unfold stake_add[symmetric]) auto

lemma sdrop_cycle: "u \<noteq> [] \<Longrightarrow> sdrop n (cycle u) = cycle (rotate (n mod length u) u)"
  by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])

lemma sset_cycle[simp]:
  assumes "xs \<noteq> []"
  shows "sset (cycle xs) = set xs"
proof (intro set_eqI iffI)
  fix x
  assume "x \<in> sset (cycle xs)"
  then show "x \<in> set xs" using assms
    by (induction "cycle xs" arbitrary: xs rule: sset_induct) (fastforce simp: neq_Nil_conv)+
qed (metis assms UnI1 cycle_decomp sset_shift)

subsection \<open>iterated application of a function\<close>

primcorec siterate where
  "shd (siterate f x) = x"
| "stl (siterate f x) = siterate f (f x)"

lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
  by (induct n arbitrary: s) auto

lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
  by (induct n arbitrary: x) (auto simp: funpow_swap1)

lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
  by (induct n arbitrary: x) (auto simp: funpow_swap1)

lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
  by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)

lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
  by (auto simp: sset_range)

lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
  by (coinduction arbitrary: x) auto

subsection \<open>stream repeating a single element\<close>

abbreviation "sconst \<equiv> siterate id"

lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
  by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)

lemma sset_sconst[simp]: "sset (sconst x) = {x}"
  by (simp add: sset_siterate)

lemma sconst_alt: "s = sconst x \<longleftrightarrow> sset s = {x}"
proof
  assume "sset s = {x}"
  then show "s = sconst x"
  proof (coinduction arbitrary: s)
    case Eq_stream
    then have "shd s = x" "sset (stl s) \<subseteq> {x}" by (cases s; auto)+
    then have "sset (stl s) = {x}" by (cases "stl s") auto
    with \<open>shd s = x\<close> show ?case by auto
  qed
qed simp

lemma sconst_cycle: "sconst x = cycle [x]"
  by coinduction auto

lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
  by coinduction auto

lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
  by (simp add: streams_iff_sset)

lemma streams_empty_iff: "streams S = {} \<longleftrightarrow> S = {}"
proof safe
  fix x assume "x \<in> S" "streams S = {}"
  then have "sconst x \<in> streams S"
    by (intro sconst_streams)
  then show "x \<in> {}"
    unfolding \<open>streams S = {}\<close> by simp
qed (auto simp: streams_empty)

subsection \<open>stream of natural numbers\<close>

abbreviation "fromN \<equiv> siterate Suc"

abbreviation "nats \<equiv> fromN 0"

lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
  by (auto simp add: sset_siterate le_iff_add)

lemma stream_smap_fromN: "s = smap (\<lambda>j. let i = j - n in s !! i) (fromN n)"
  by (coinduction arbitrary: s n)
    (force simp: neq_Nil_conv Let_def Suc_diff_Suc simp flip: snth.simps(2)
      intro: stream.map_cong split: if_splits)

lemma stream_smap_nats: "s = smap (snth s) nats"
  using stream_smap_fromN[where n = 0] by simp

subsection \<open>flatten a stream of lists\<close>

primcorec flat where
  "shd (flat ws) = hd (shd ws)"
| "stl (flat ws) = flat (if tl (shd ws) = [] then stl ws else tl (shd ws) ## stl ws)"

lemma flat_Cons[simp, code]: "flat ((x # xs) ## ws) = x ## flat (if xs = [] then ws else xs ## ws)"
  by (subst flat.ctr) simp

lemma flat_Stream[simp]: "xs \<noteq> [] \<Longrightarrow> flat (xs ## ws) = xs @- flat ws"
  by (induct xs) auto

lemma flat_unfold: "shd ws \<noteq> [] \<Longrightarrow> flat ws = shd ws @- flat (stl ws)"
  by (cases ws) auto

lemma flat_snth: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> flat s !! n = (if n < length (shd s) then
  shd s ! n else flat (stl s) !! (n - length (shd s)))"
  by (metis flat_unfold not_less shd_sset shift_snth_ge shift_snth_less)

lemma sset_flat[simp]: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow>
  sset (flat s) = (\<Union>xs \<in> sset s. set xs)" (is "?P \<Longrightarrow> ?L = ?R")
proof safe
  fix x assume ?P "x \<in> ?L"
  then obtain m where "x = flat s !! m" by (metis image_iff sset_range)
  with \<open>?P\<close> obtain n m' where "x = s !! n ! m'" "m' < length (s !! n)"
  proof (atomize_elim, induct m arbitrary: s rule: less_induct)
    case (less y)
    thus ?case
    proof (cases "y < length (shd s)")
      case True thus ?thesis by (metis flat_snth less(2,3) snth.simps(1))
    next
      case False
      hence "x = flat (stl s) !! (y - length (shd s))" by (metis less(2,3) flat_snth)
      moreover
      { from less(2) have *: "length (shd s) > 0" by (cases s) simp_all
        with False have "y > 0" by (cases y) simp_all
        with * have "y - length (shd s) < y" by simp
      }
      moreover have "\<forall>xs \<in> sset (stl s). xs \<noteq> []" using less(2) by (cases s) auto
      ultimately have "\<exists>n m'. x = stl s !! n ! m' \<and> m' < length (stl s !! n)" by (intro less(1)) auto
      thus ?thesis by (metis snth.simps(2))
    qed
  qed
  thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
next
  fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
    by (induct rule: sset_induct)
      (metis UnI1 flat_unfold shift.simps(1) sset_shift,
       metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
qed

subsection \<open>merge a stream of streams\<close>

definition smerge :: "'a stream stream \<Rightarrow> 'a stream" where
  "smerge ss = flat (smap (\<lambda>n. map (\<lambda>s. s !! n) (stake (Suc n) ss) @ stake n (ss !! n)) nats)"

lemma stake_nth[simp]: "m < n \<Longrightarrow> stake n s ! m = s !! m"
  by (induct n arbitrary: s m) (auto simp: nth_Cons', metis Suc_pred snth.simps(2))

lemma snth_sset_smerge: "ss !! n !! m \<in> sset (smerge ss)"
proof (cases "n \<le> m")
  case False thus ?thesis unfolding smerge_def
    by (subst sset_flat)
      (auto simp: stream.set_map in_set_conv_nth simp del: stake.simps
        intro!: exI[of _ n, OF disjI2] exI[of _ m, OF mp])
next
  case True thus ?thesis unfolding smerge_def
    by (subst sset_flat)
      (auto simp: stream.set_map in_set_conv_nth image_iff simp del: stake.simps snth.simps
        intro!: exI[of _ m, OF disjI1] bexI[of _ "ss !! n"] exI[of _ n, OF mp])
qed

lemma sset_smerge: "sset (smerge ss) = \<Union>(sset ` (sset ss))"
proof safe
  fix x assume "x \<in> sset (smerge ss)"
  thus "x \<in> \<Union>(sset ` (sset ss))"
    unfolding smerge_def by (subst (asm) sset_flat)
      (auto simp: stream.set_map in_set_conv_nth sset_range simp del: stake.simps, fast+)
next
  fix s x assume "s \<in> sset ss" "x \<in> sset s"
  thus "x \<in> sset (smerge ss)" using snth_sset_smerge by (auto simp: sset_range)
qed

subsection \<open>product of two streams\<close>

definition sproduct :: "'a stream \<Rightarrow> 'b stream \<Rightarrow> ('a \<times> 'b) stream" where
  "sproduct s1 s2 = smerge (smap (\<lambda>x. smap (Pair x) s2) s1)"

lemma sset_sproduct: "sset (sproduct s1 s2) = sset s1 \<times> sset s2"
  unfolding sproduct_def sset_smerge by (auto simp: stream.set_map)

subsection \<open>interleave two streams\<close>

primcorec sinterleave where
  "shd (sinterleave s1 s2) = shd s1"
| "stl (sinterleave s1 s2) = sinterleave s2 (stl s1)"

lemma sinterleave_code[code]:
  "sinterleave (x ## s1) s2 = x ## sinterleave s2 s1"
  by (subst sinterleave.ctr) simp

lemma sinterleave_snth[simp]:
  "even n \<Longrightarrow> sinterleave s1 s2 !! n = s1 !! (n div 2)"
  "odd n \<Longrightarrow> sinterleave s1 s2 !! n = s2 !! (n div 2)"
  by (induct n arbitrary: s1 s2) simp_all

lemma sset_sinterleave: "sset (sinterleave s1 s2) = sset s1 \<union> sset s2"
proof (intro equalityI subsetI)
  fix x assume "x \<in> sset (sinterleave s1 s2)"
  then obtain n where "x = sinterleave s1 s2 !! n" unfolding sset_range by blast
  thus "x \<in> sset s1 \<union> sset s2" by (cases "even n") auto
next
  fix x assume "x \<in> sset s1 \<union> sset s2"
  thus "x \<in> sset (sinterleave s1 s2)"
  proof
    assume "x \<in> sset s1"
    then obtain n where "x = s1 !! n" unfolding sset_range by blast
    hence "sinterleave s1 s2 !! (2 * n) = x" by simp
    thus ?thesis unfolding sset_range by blast
  next
    assume "x \<in> sset s2"
    then obtain n where "x = s2 !! n" unfolding sset_range by blast
    hence "sinterleave s1 s2 !! (2 * n + 1) = x" by simp
    thus ?thesis unfolding sset_range by blast
  qed
qed

subsection \<open>zip\<close>

primcorec szip where
  "shd (szip s1 s2) = (shd s1, shd s2)"
| "stl (szip s1 s2) = szip (stl s1) (stl s2)"

lemma szip_unfold[code]: "szip (a ## s1) (b ## s2) = (a, b) ## (szip s1 s2)"
  by (subst szip.ctr) simp

lemma snth_szip[simp]: "szip s1 s2 !! n = (s1 !! n, s2 !! n)"
  by (induct n arbitrary: s1 s2) auto

lemma stake_szip[simp]:
  "stake n (szip s1 s2) = zip (stake n s1) (stake n s2)"
  by (induct n arbitrary: s1 s2) auto

lemma sdrop_szip[simp]: "sdrop n (szip s1 s2) = szip (sdrop n s1) (sdrop n s2)"
  by (induct n arbitrary: s1 s2) auto

lemma smap_szip_fst:
  "smap (\<lambda>x. f (fst x)) (szip s1 s2) = smap f s1"
  by (coinduction arbitrary: s1 s2) auto

lemma smap_szip_snd:
  "smap (\<lambda>x. g (snd x)) (szip s1 s2) = smap g s2"
  by (coinduction arbitrary: s1 s2) auto

subsection \<open>zip via function\<close>

primcorec smap2 where
  "shd (smap2 f s1 s2) = f (shd s1) (shd s2)"
| "stl (smap2 f s1 s2) = smap2 f (stl s1) (stl s2)"

lemma smap2_unfold[code]:
  "smap2 f (a ## s1) (b ## s2) = f a b ## (smap2 f s1 s2)"
  by (subst smap2.ctr) simp

lemma smap2_szip:
  "smap2 f s1 s2 = smap (case_prod f) (szip s1 s2)"
  by (coinduction arbitrary: s1 s2) auto

lemma smap_smap2[simp]:
  "smap f (smap2 g s1 s2) = smap2 (\<lambda>x y. f (g x y)) s1 s2"
  unfolding smap2_szip stream.map_comp o_def split_def ..

lemma smap2_alt:
  "(smap2 f s1 s2 = s) = (\<forall>n. f (s1 !! n) (s2 !! n) = s !! n)"
  unfolding smap2_szip smap_alt by auto

lemma snth_smap2[simp]:
  "smap2 f s1 s2 !! n = f (s1 !! n) (s2 !! n)"
  by (induct n arbitrary: s1 s2) auto

lemma stake_smap2[simp]:
  "stake n (smap2 f s1 s2) = map (case_prod f) (zip (stake n s1) (stake n s2))"
  by (induct n arbitrary: s1 s2) auto

lemma sdrop_smap2[simp]:
  "sdrop n (smap2 f s1 s2) = smap2 f (sdrop n s1) (sdrop n s2)"
  by (induct n arbitrary: s1 s2) auto

end


section \<open>Normalization of DBMs\<close>

theory DBM_Normalization
imports DBM_Basics
begin

text \<open>This is the implementation of the common approximation operation.\<close>

fun norm_upper :: "('t::time) DBMEntry \<Rightarrow> 't \<Rightarrow> ('t::time) DBMEntry"
where
  "norm_upper e t = (if Le t \<prec> e then \<infinity> else e)"

fun norm_lower :: "('t::time) DBMEntry \<Rightarrow> 't \<Rightarrow> ('t::time) DBMEntry"
where
  "norm_lower e t = (if e \<prec> Lt t then Lt t else e)"

text \<open>
  Note that literature pretends that \<open>\<zero>\<close> would have some (presumably infinite bound) in \<open>k\<close>
  and thus defines normalization uniformly. The easiest way to get around this seems to explicate
  this in the definition as below.
\<close>
definition norm :: "('t::time) DBM \<Rightarrow> (nat \<Rightarrow> 't) \<Rightarrow> nat \<Rightarrow> 't DBM"
where
  "norm M k n \<equiv> \<lambda> i j.
    let ub = if i > 0 then (k i) else 0 in
    let lb = if j > 0 then (- k j) else 0 in
    if i \<le> n \<and> j \<le> n then norm_lower (norm_upper (M i j) ub) lb else M i j
  "

section \<open>Normalization is a Widening Operator\<close>

lemma norm_mono:
  assumes "\<forall>c. v c > 0" "u \<in> [M]\<^bsub>v,n\<^esub>"
  shows "u \<in> [norm M k n]\<^bsub>v,n\<^esub>" (is "u \<in> [?M2]\<^bsub>v,n\<^esub>")
proof -
  note A = assms
  note M1 = A(2)[unfolded DBM_zone_repr_def DBM_val_bounded_def]
  show ?thesis
  proof (unfold DBM_zone_repr_def DBM_val_bounded_def, auto)
    show "Le 0 \<preceq> ?M2 0 0"
    using A unfolding norm_def DBM_zone_repr_def DBM_val_bounded_def dbm_le_def by auto
  next
    fix c assume "v c \<le> n"
    with M1 have M1: "dbm_entry_val u None (Some c) (M 0 (v c))" by auto
    from \<open>v c \<le> n\<close> A have *:
      "?M2 0 (v c) = norm_lower (norm_upper (M 0 (v c)) 0) (- k (v c))"
    unfolding norm_def by auto
    show "dbm_entry_val u None (Some c) (?M2 0 (v c))"
    proof (cases "M 0 (v c) \<prec> Lt (- k (v c))")
      case True
      show ?thesis
      proof (cases "Le 0 \<prec> M 0 (v c)")
        case True with * show ?thesis by auto
      next
        case False
        with * True have "?M2 0 (v c) = Lt (- k (v c))" by auto
        moreover from True dbm_entry_val_mono_2[OF M1] have
          "dbm_entry_val u None (Some c) (Lt (- k (v c)))"
        by auto
        ultimately show ?thesis by auto
      qed
    next
      case False
      show ?thesis
      proof (cases "Le 0 \<prec> M 0 (v c)")
        case True with * show ?thesis by auto
      next
        case F: False
        with M1 * False show ?thesis by auto
      qed
    qed
  next
    fix c assume "v c \<le> n"
    with M1 have M1: "dbm_entry_val u (Some c) None (M (v c) 0)" by auto
    from \<open>v c \<le> n\<close> A have *:
      "?M2 (v c) 0 = norm_lower (norm_upper (M (v c) 0) (k (v c))) 0"
    unfolding norm_def by auto
    show "dbm_entry_val u (Some c) None (?M2 (v c) 0)"
    proof (cases "Le (k (v c)) \<prec> M (v c) 0")
      case True
      with A(1,2) \<open>v c \<le> n\<close> have "?M2 (v c) 0 = \<infinity>" unfolding norm_def by auto
      then show ?thesis by auto
    next
      case False
      show ?thesis
      proof (cases "M (v c) 0 \<prec> Lt 0")
        case True with False * dbm_entry_val_mono_3[OF M1] show ?thesis by auto
      next
        case F: False
        with M1 * False show ?thesis by auto
      qed
    qed
  next
    fix c1 c2 assume "v c1 \<le> n" "v c2 \<le> n"
    with M1 have M1: "dbm_entry_val u (Some c1) (Some c2) (M (v c1) (v c2))" by auto
    then show "dbm_entry_val u (Some c1) (Some c2) (?M2 (v c1) (v c2))"
    proof (cases "Le (k (v c1)) \<prec> M (v c1) (v c2)")
      case True
      with A(1,2) \<open>v c1 \<le> n\<close> \<open>v c2 \<le> n\<close> have "?M2 (v c1) (v c2) = \<infinity>" unfolding norm_def by auto
      then show ?thesis by auto
    next
      case False
      with A(1,2) \<open>v c1 \<le> n\<close> \<open>v c2 \<le> n\<close> have
        *: "?M2 (v c1) (v c2) = norm_lower (M (v c1) (v c2)) (- k (v c2))"
      unfolding norm_def by auto
      show ?thesis
      proof (cases "M (v c1) (v c2) \<prec> Lt (- k (v c2))")
        case True
        with dbm_entry_val_mono_1[OF M1] have
          "dbm_entry_val u (Some c1) (Some c2) (Lt (- k (v c2)))"
        by auto
        then have "u c1 - u c2 < - k (v c2)" by auto
        with * True show ?thesis by auto
      next
        case False with M1 * show ?thesis by auto
      qed
    qed
  qed
qed

end


(*  Title:       EquivalenceOfCategories
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Equivalence of Categories"

text \<open>
  In this chapter we define the notions of equivalence and adjoint equivalence of categories
  and establish some properties of functors that are part of an equivalence.
\<close>

theory EquivalenceOfCategories
imports Adjunction
begin
  locale equivalence_of_categories =
    C: category C +
    D: category D +
    F: "functor" D C F +
    G: "functor" C D G +
    \<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
    \<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
  for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
  and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
  and F :: "'d \<Rightarrow> 'c"
  and G :: "'c \<Rightarrow> 'd"
  and \<eta> :: "'d \<Rightarrow> 'd"
  and \<epsilon> :: "'c \<Rightarrow> 'c"
  begin

    notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
    notation D.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")

    lemma C_arr_expansion:
    assumes "C.arr f"
    shows "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f"
    and "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
    proof -
      have \<epsilon>_dom: "C.inverse_arrows (\<epsilon> (C.dom f)) (C.inv (\<epsilon> (C.dom f)))"
        using assms C.inv_is_inverse by auto
      have \<epsilon>_cod: "C.inverse_arrows (\<epsilon> (C.cod f)) (C.inv (\<epsilon> (C.cod f)))"
        using assms C.inv_is_inverse by auto
      have "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) =
            (\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
        using C.comp_assoc by force
      also have 1: "... = (f \<cdot>\<^sub>C \<epsilon> (C.dom f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
        using assms \<epsilon>.naturality by simp
      also have 2: "... = f"
        using assms \<epsilon>_dom C.comp_arr_inv C.comp_arr_dom C.comp_assoc by force
      finally show "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f" by blast
      show "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
        using assms 1 2 \<epsilon>_dom \<epsilon>_cod C.invert_side_of_triangle C.isoI C.iso_inv_iso
        by metis
    qed

    lemma G_is_essentially_surjective:
    shows "essentially_surjective_functor C D G"
    proof
      fix b
      assume b: "D.ide b"
      have "C.ide (F b) \<and> D.isomorphic (G (F b)) b"
      proof
        show "C.ide (F b)" using b by simp
        show "D.isomorphic (G (F b)) b"
        proof (unfold D.isomorphic_def)
          have "\<guillemotleft>D.inv (\<eta> b) : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso (D.inv (\<eta> b))"
            using b D.iso_inv_iso by auto
          thus "\<exists>f. \<guillemotleft>f : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso f" by blast
        qed
      qed
      thus "\<exists>a. C.ide a \<and> D.isomorphic (G a) b"
        by blast
    qed

    interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
    interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
    interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..

    lemma F_is_faithful:
    shows "faithful_functor D C F"
      using GF.G_is_faithful by simp

    lemma F_is_essentially_surjective:
    shows "essentially_surjective_functor D C F"
      using GF.G_is_essentially_surjective by simp

    lemma G_is_full:
    shows "full_functor C D G"
    proof
      fix a a' g
      assume a: "C.ide a" and a': "C.ide a'"
      assume g: "\<guillemotleft>g : G a \<rightarrow>\<^sub>D G a'\<guillemotright>"
      show "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G f = g"
      proof
        have \<epsilon>a: "C.inverse_arrows (\<epsilon> a) (C.inv (\<epsilon> a))"
          using a C.inv_is_inverse by auto
        have \<epsilon>a': "C.inverse_arrows (\<epsilon> a') (C.inv (\<epsilon> a'))"
          using a' C.inv_is_inverse by auto
        let ?f = "\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a)"
        have f: "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright>"
          using a a' g \<epsilon>a \<epsilon>a' \<epsilon>.preserves_hom [of a' a' a'] \<epsilon>_inv.preserves_hom [of a a a]
          by fastforce
        moreover have "G ?f = g"
        proof -
          interpret F: faithful_functor D C F
            using F_is_faithful by auto
          have "F (G ?f) = F g"
          proof -
            have "F (G ?f) = C.inv (\<epsilon> a') \<cdot>\<^sub>C ?f \<cdot>\<^sub>C \<epsilon> a"
              using f C_arr_expansion(2) [of "?f"] by auto
            also have "... = (C.inv (\<epsilon> a') \<cdot>\<^sub>C \<epsilon> a') \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a) \<cdot>\<^sub>C \<epsilon> a"
              using a a' f g C.comp_assoc by fastforce
            also have "... = F g"
              using a a' g \<epsilon>a \<epsilon>a' C.comp_inv_arr C.comp_arr_dom C.comp_cod_arr by auto
            finally show ?thesis by blast
          qed
          moreover have "D.par (G (\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a))) g"
            using f g by fastforce
          ultimately show ?thesis using f g F.is_faithful by blast
        qed
        ultimately show "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G ?f = g" by blast
      qed
    qed

  end

  (* I'm not sure why I had to close and re-open the context here in order to
   * get the G_is_full fact in the interpretation GF. *)

  context equivalence_of_categories
  begin

    interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
    interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
    interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..

    lemma F_is_full:
    shows "full_functor D C F"
      using GF.G_is_full by simp

  end

  text \<open>
    Traditionally the term "equivalence of categories" is also used for a functor
    that is part of an equivalence of categories.  However, it seems best to use
    that term for a situation in which all of the structure of an equivalence is
    explicitly given, and to have a different term for one of the functors involved.
\<close>

  locale equivalence_functor =
    C: category C +
    D: category D +
    "functor" C D G
  for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
  and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
  and G :: "'c \<Rightarrow> 'd" +
  assumes induces_equivalence: "\<exists>F \<eta> \<epsilon>. equivalence_of_categories C D F G \<eta> \<epsilon>"
  begin

    notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
    notation D.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")

  end

  sublocale equivalence_of_categories \<subseteq> equivalence_functor C D G
    using equivalence_of_categories_axioms by (unfold_locales, blast)

  text \<open>
    An equivalence functor is fully faithful and essentially surjective.
\<close>

  sublocale equivalence_functor \<subseteq> fully_faithful_functor C D G
  proof -
    obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
      using induces_equivalence by blast
    interpret equivalence_of_categories C D F G \<eta> \<epsilon>
      using 1 by auto
    show "fully_faithful_functor C D G"
      using G_is_full G_is_faithful fully_faithful_functor.intro by auto
  qed

  sublocale equivalence_functor \<subseteq> essentially_surjective_functor C D G
  proof -
    obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
      using induces_equivalence by blast
    interpret equivalence_of_categories C D F G \<eta> \<epsilon>
      using 1 by auto
    show "essentially_surjective_functor C D G"
      using G_is_essentially_surjective by auto
  qed

  text \<open>
    A special case of an equivalence functor is an endofunctor \<open>F\<close> equipped with
    a natural isomorphism from \<open>F\<close> to the identity functor.
\<close>

  context endofunctor
  begin

    lemma isomorphic_to_identity_is_equivalence:
    assumes "natural_isomorphism A A F A.map \<phi>"
    shows "equivalence_functor A A F"
    proof -
      interpret \<phi>: natural_isomorphism A A F A.map \<phi>
         using assms by auto
      interpret \<phi>': inverse_transformation A A F A.map \<phi> ..
      interpret F\<phi>': natural_isomorphism A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
      proof -
        interpret F\<phi>': natural_transformation A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
          using \<phi>'.natural_transformation_axioms functor_axioms
                horizontal_composite [of A A A.map F \<phi>'.map A F F F]
          by simp
        show "natural_isomorphism A A F (F o F) (F o \<phi>'.map)"
          apply unfold_locales
          using \<phi>'.components_are_iso by fastforce
      qed
      interpret F\<phi>'o\<phi>': vertical_composite A A A.map F \<open>F o F\<close> \<phi>'.map \<open>F o \<phi>'.map\<close> ..
      interpret F\<phi>'o\<phi>': natural_isomorphism A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map
        using \<phi>'.natural_isomorphism_axioms F\<phi>'.natural_isomorphism_axioms
              natural_isomorphisms_compose
        by fast
      interpret inv_F\<phi>'o\<phi>': inverse_transformation A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map ..
      interpret F: equivalence_of_categories A A F F F\<phi>'o\<phi>'.map inv_F\<phi>'o\<phi>'.map ..
      show ?thesis ..
    qed

  end

  text \<open>
    An adjoint equivalence is an equivalence of categories that is also an adjunction.
\<close>

  locale adjoint_equivalence =
    unit_counit_adjunction C D F G \<eta> \<epsilon> +
    \<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
    \<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
  for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
  and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
  and F :: "'d \<Rightarrow> 'c"
  and G :: "'c \<Rightarrow> 'd"
  and \<eta> :: "'d \<Rightarrow> 'd"
  and \<epsilon> :: "'c \<Rightarrow> 'c"

  text \<open>
    An adjoint equivalence is clearly an equivalence of categories.
\<close>

  sublocale adjoint_equivalence \<subseteq> equivalence_of_categories ..

  context adjoint_equivalence
  begin

    text \<open>
      The triangle identities for an adjunction reduce to inverse relations when
      \<open>\<eta>\<close> and \<open>\<epsilon>\<close> are natural isomorphisms.
\<close>

    lemma triangle_G':
    assumes "C.ide a"
    shows "D.inverse_arrows (\<eta> (G a)) (G (\<epsilon> a))"
    proof
      show "D.ide (G (\<epsilon> a) \<cdot>\<^sub>D \<eta> (G a))"
        using assms triangle_G G\<epsilon>o\<eta>G.map_simp_ide by fastforce
      thus "D.ide (\<eta> (G a) \<cdot>\<^sub>D G (\<epsilon> a))"
        using assms D.section_retraction_of_iso [of "G (\<epsilon> a)" "\<eta> (G a)"] by auto
    qed

    lemma triangle_F':
    assumes "D.ide b"
    shows "C.inverse_arrows (F (\<eta> b)) (\<epsilon> (F b))"
    proof
     show "C.ide (\<epsilon> (F b) \<cdot>\<^sub>C F (\<eta> b))"
        using assms triangle_F \<epsilon>FoF\<eta>.map_simp_ide by auto
      thus "C.ide (F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b))"
        using assms C.section_retraction_of_iso [of "\<epsilon> (F b)" "F (\<eta> b)"] by auto
    qed

    text \<open>
      An adjoint equivalence can be dualized by interchanging the two functors and inverting
      the natural isomorphisms.  This is somewhat awkward to prove, but probably useful to have
      done it once and for all.
\<close>

    lemma dual_equivalence:
    assumes "adjoint_equivalence C D F G \<eta> \<epsilon>"
    shows "adjoint_equivalence D C G F (inverse_transformation.map C C (C.map) \<epsilon>)
                                       (inverse_transformation.map D D (G o F) \<eta>)"
    proof -
      interpret adjoint_equivalence C D F G \<eta> \<epsilon> using assms by auto
      interpret \<epsilon>': inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
      interpret \<eta>': inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
      interpret G\<epsilon>': natural_transformation C D G \<open>G o F o G\<close> \<open>G o \<epsilon>'.map\<close>
      proof -
        have "natural_transformation C D G (G o (F o G)) (G o \<epsilon>'.map)"
          using G.natural_transformation_axioms \<epsilon>'.natural_transformation_axioms
                horizontal_composite
          by fastforce
        thus "natural_transformation C D G (G o F o G) (G o \<epsilon>'.map)"
          using o_assoc by metis
      qed
      interpret \<eta>'G: natural_transformation C D \<open>G o F o G\<close> G \<open>\<eta>'.map o G\<close>
        using \<eta>'.natural_transformation_axioms G.natural_transformation_axioms
              horizontal_composite
        by fastforce
      interpret \<epsilon>'F: natural_transformation D C F \<open>F o G o F\<close> \<open>\<epsilon>'.map o F\<close>
        using \<epsilon>'.natural_transformation_axioms F.natural_transformation_axioms
              horizontal_composite
        by fastforce
      interpret F\<eta>': natural_transformation D C \<open>F o G o F\<close> F \<open>F o \<eta>'.map\<close>
      proof -
        have "natural_transformation D C (F o (G o F)) F (F o \<eta>'.map)"
          using \<eta>'.natural_transformation_axioms F.natural_transformation_axioms
                horizontal_composite
          by fastforce
        thus "natural_transformation D C (F o G o F) F (F o \<eta>'.map)"
          using o_assoc by metis
      qed
      interpret F\<eta>'o\<epsilon>'F: vertical_composite D C F \<open>(F o G) o F\<close> F \<open>\<epsilon>'.map o F\<close> \<open>F o \<eta>'.map\<close> ..
      interpret \<eta>'GoG\<epsilon>': vertical_composite C D G \<open>G o F o G\<close> G \<open>G o \<epsilon>'.map\<close> \<open>\<eta>'.map o G\<close> ..
      show ?thesis
      proof
        show "\<eta>'GoG\<epsilon>'.map = G"
        proof (intro NaturalTransformation.eqI)
          show "natural_transformation C D G G G"
            using G.natural_transformation_axioms by auto
          show "natural_transformation C D G G \<eta>'GoG\<epsilon>'.map"
            using \<eta>'GoG\<epsilon>'.natural_transformation_axioms by auto
          show "\<And>a. C.ide a \<Longrightarrow> \<eta>'GoG\<epsilon>'.map a = G a"
          proof -
            fix a
            assume a: "C.ide a"
            show "\<eta>'GoG\<epsilon>'.map a = G a"
              using a \<eta>'GoG\<epsilon>'.map_simp_ide triangle_G'
                    \<eta>.components_are_iso \<epsilon>.components_are_iso G.preserves_ide
                    \<eta>'.inverts_components \<epsilon>'.inverts_components
                    D.inverse_unique G.preserves_inverse_arrows G\<epsilon>o\<eta>G.map_simp_ide
                    D.inverse_arrows_sym triangle_G
              by (metis o_apply)
          qed
        qed
        show "F\<eta>'o\<epsilon>'F.map = F"
        proof (intro NaturalTransformation.eqI)
          show "natural_transformation D C F F F"
            using F.natural_transformation_axioms by auto
          show "natural_transformation D C F F F\<eta>'o\<epsilon>'F.map"
            using F\<eta>'o\<epsilon>'F.natural_transformation_axioms by auto
          show "\<And>b. D.ide b \<Longrightarrow> F\<eta>'o\<epsilon>'F.map b = F b"
          proof -
            fix b
            assume b: "D.ide b"
            show "F\<eta>'o\<epsilon>'F.map b = F b"
              using b F\<eta>'o\<epsilon>'F.map_simp_ide \<epsilon>FoF\<eta>.map_simp_ide triangle_F triangle_F'
                    \<eta>.components_are_iso \<epsilon>.components_are_iso G.preserves_ide
                    \<eta>'.inverts_components \<epsilon>'.inverts_components F.preserves_ide
                    C.inverse_unique F.preserves_inverse_arrows C.inverse_arrows_sym
              by (metis o_apply)
          qed
        qed
      qed
    qed

  end

  text \<open>
    Every fully faithful and essentially surjective functor underlies an adjoint equivalence.
    To prove this without repeating things that were already proved in @{theory Category3.Adjunction},
    we first show that a fully faithful and essentially surjective functor is a left adjoint
    functor, and then we show that if the left adjoint in a unit-counit adjunction is
    fully faithful and essentially surjective, then the unit and counit are natural isomorphisms;
    hence the adjunction is in fact an adjoint equivalence.
\<close>

  locale fully_faithful_and_essentially_surjective_functor =
    C: category C +
    D: category D +
    fully_faithful_functor D C F +
    essentially_surjective_functor D C F
    for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
    and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
    and F :: "'d \<Rightarrow> 'c"
  begin

    notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
    notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")

    lemma is_left_adjoint_functor:
    shows "left_adjoint_functor D C F"
    proof
      fix y
      assume y: "C.ide y"
      let ?x = "SOME x. D.ide x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>)"
      let ?e = "SOME e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>"
      have "\<exists>x e. C.iso e \<and> terminal_arrow_from_functor D C F x y e"
      proof -
        have "\<exists>x. C.iso ?e \<and> terminal_arrow_from_functor D C F x y ?e"
        proof -
          have x: "D.ide ?x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>)"
          proof -
            obtain x where x: "D.ide x \<and> C.isomorphic (F x) y"
              using y essentially_surjective D.isomorphic_def by blast
            obtain e where e: "C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>"
              using y x by auto
            hence "\<exists>x. D.ide x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>)"
              using x by auto
            thus "D.ide ?x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>)"
              using someI_ex [of "\<lambda>x. D.ide x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>)"] by blast
          qed
          hence e: "C.iso ?e \<and> \<guillemotleft>?e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>"
            using someI_ex [of "\<lambda>e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>"] by blast
          interpret arrow_from_functor D C F ?x y ?e
            using x e by (unfold_locales, simp)
          interpret terminal_arrow_from_functor D C F ?x y ?e
          proof
            fix x' f
            assume 1: "arrow_from_functor D C F x' y f"
            interpret f: arrow_from_functor D C F x' y f
              using 1 by simp
            have f: "\<guillemotleft>f: F x' \<rightarrow>\<^sub>C y\<guillemotright>"
              by (meson f.arrow)
            show "\<exists>!g. is_coext x' f g"
            proof
              let ?g = "SOME g. \<guillemotleft>g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F g = C.inv ?e \<cdot>\<^sub>C f"
              have g: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F ?g = C.inv ?e \<cdot>\<^sub>C f"
              proof -
                have "\<exists>g. \<guillemotleft>g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F g = C.inv ?e \<cdot>\<^sub>C f"
                  using f e x f.arrow
                  by (meson C.comp_in_homI C.inv_in_hom is_full)
                thus ?thesis
                  using someI_ex [of "\<lambda>g. \<guillemotleft>g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F g = C.inv ?e \<cdot>\<^sub>C f"] by blast
              qed
              show 1: "is_coext x' f ?g"
              proof -
                have "\<guillemotleft>?g : x' \<rightarrow>\<^sub>D ?x\<guillemotright>"
                  using g by simp
                moreover have "?e \<cdot>\<^sub>C F ?g = f"
                proof -
                  have "?e \<cdot>\<^sub>C F ?g = ?e \<cdot>\<^sub>C C.inv ?e \<cdot>\<^sub>C f"
                    using g by simp
                  also have "... = (?e \<cdot>\<^sub>C C.inv ?e) \<cdot>\<^sub>C f"
                    using e f C.inv_in_hom by (metis C.comp_assoc)
                  also have "... = f"
                  proof -
                    have "?e \<cdot>\<^sub>C C.inv ?e = y"
                      using e C.comp_arr_inv [of ?e] C.inv_is_inverse by auto
                    thus ?thesis
                      using f C.comp_cod_arr by auto
                  qed
                  finally show ?thesis by blast
                qed
                ultimately show ?thesis
                  unfolding is_coext_def by simp
              qed
              show "\<And>g'. is_coext x' f g' \<Longrightarrow> g' = ?g"
              proof -
                fix g'
                assume g': "is_coext x' f g'"
                have 2: "\<guillemotleft>g' : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>C F g' = f" using g' is_coext_def by simp
                have 3: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>C F ?g = f" using 1 is_coext_def by simp
                have "F g' = F ?g"
                  using e 2 3 C.iso_is_section C.section_is_mono C.monoE by blast
                moreover have "D.par g' ?g"
                  using 2 3 by fastforce
                ultimately show "g' = ?g"
                  using is_faithful [of g' ?g] by simp
              qed
            qed
          qed
          show ?thesis
            using e terminal_arrow_from_functor_axioms by auto
        qed
        thus ?thesis by auto
      qed
      thus "\<exists>x e. terminal_arrow_from_functor D C F x y e" by blast
    qed

    lemma is_equivalence_functor:
    shows "equivalence_functor D C F"
    proof
      interpret left_adjoint_functor D C F
        using is_left_adjoint_functor by blast
      interpret equivalence_of_categories C D F G \<eta> \<epsilon>
      proof
        show 1: "\<And>a. C.ide a \<Longrightarrow> C.iso (\<epsilon> a)"
        proof -
          fix a
          assume a: "C.ide a"
          interpret \<epsilon>a: terminal_arrow_from_functor D C F \<open>G a\<close> a \<open>\<epsilon> a\<close>
            using a \<phi>\<psi>.has_terminal_arrows_from_functor [of a] by blast
          have "C.retraction (\<epsilon> a)"
          proof -
            obtain b \<phi> where \<phi>: "D.ide b \<and> C.iso \<phi> \<and> \<guillemotleft>\<phi>: F b \<rightarrow>\<^sub>C a\<guillemotright>"
              using a essentially_surjective by blast
            interpret \<phi>: arrow_from_functor D C F b a \<phi>
              using \<phi> by (unfold_locales, simp)
            let ?g = "\<epsilon>a.the_coext b \<phi>"
            have 1: "\<guillemotleft>?g : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> \<epsilon> a \<cdot>\<^sub>C F ?g = \<phi>"
              using \<phi>.arrow_from_functor_axioms \<epsilon>a.the_coext_prop [of b \<phi>] by simp
            have "a = (\<epsilon> a \<cdot>\<^sub>C F ?g) \<cdot>\<^sub>C C.inv \<phi>"
              using a 1 \<phi> C.comp_cod_arr \<epsilon>.preserves_hom [of a a a]
                    C.invert_side_of_triangle(2) [of "\<epsilon> a \<cdot>\<^sub>C F ?g" a \<phi>]
               by auto
            also have "... = \<epsilon> a \<cdot>\<^sub>C F ?g \<cdot>\<^sub>C C.inv \<phi>"
            proof -
              have "C.seq (\<epsilon> a) (F ?g)"
                using a 1 \<epsilon>.preserves_hom [of a a a] by fastforce
              moreover have "C.seq (F ?g) (C.inv \<phi>)"
                using a 1 \<phi> C.inv_in_hom [of \<phi> "F b" a] by blast
              ultimately show ?thesis using C.comp_assoc by auto
            qed
            finally have "\<exists>f. C.ide (\<epsilon> a \<cdot>\<^sub>C f)"
              using a by metis
            thus ?thesis
              unfolding C.retraction_def by blast
          qed
          moreover have "C.mono (\<epsilon> a)"
          proof
            show "C.arr (\<epsilon> a)"
              using a by simp
            show "\<And>f f'. C.seq (\<epsilon> a) f \<and> C.seq (\<epsilon> a) f' \<and> \<epsilon> a \<cdot>\<^sub>C f = \<epsilon> a \<cdot>\<^sub>C f' \<Longrightarrow> f = f'"
            proof -
              fix f f'
              assume ff': "C.seq (\<epsilon> a) f \<and> C.seq (\<epsilon> a) f' \<and> \<epsilon> a \<cdot>\<^sub>C f = \<epsilon> a \<cdot>\<^sub>C f'"
              have f: "\<guillemotleft>f : C.dom f \<rightarrow>\<^sub>C F (G a)\<guillemotright>"
                using a ff' \<epsilon>.preserves_hom [of a a a] by fastforce
              have f': "\<guillemotleft>f' : C.dom f' \<rightarrow>\<^sub>C F (G a)\<guillemotright>"
                using a ff' \<epsilon>.preserves_hom [of a a a] by fastforce
              have par: "C.par f f'"
                using f f' ff' C.dom_comp [of "\<epsilon> a" f] by force
              obtain b' \<phi> where \<phi>: "D.ide b' \<and> C.iso \<phi> \<and> \<guillemotleft>\<phi>: F b' \<rightarrow>\<^sub>C C.dom f\<guillemotright>"
                using par essentially_surjective C.ide_dom [of f] by blast
              have 1: "\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi> = \<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>"
              proof -
                have "\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi> = (\<epsilon> a \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<phi>"
                proof -
                  have "C.seq f \<phi>" using par \<phi> by auto
                  moreover have "C.seq (\<epsilon> a) f" using ff' by blast
                  ultimately show ?thesis using C.comp_assoc by auto
                qed
                also have "... = (\<epsilon> a \<cdot>\<^sub>C f') \<cdot>\<^sub>C \<phi>"
                  using ff' by argo
                also have "... = \<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>"
                proof -
                  have "C.seq f' \<phi>" using par \<phi> by auto
                  moreover have "C.seq (\<epsilon> a) f'" using ff' by blast
                  ultimately show ?thesis using C.comp_assoc by auto
                qed
                finally show ?thesis by blast
              qed
              obtain g where g: "\<guillemotleft>g : b' \<rightarrow>\<^sub>D G a\<guillemotright> \<and> F g = f \<cdot>\<^sub>C \<phi>"
                using a f \<phi> is_full [of "G a" b' "f \<cdot>\<^sub>C \<phi>"] by auto
              obtain g' where g': "\<guillemotleft>g' : b' \<rightarrow>\<^sub>D G a\<guillemotright> \<and> F g' = f' \<cdot>\<^sub>C \<phi>"
                using a f' par \<phi> is_full [of "G a" b' "f' \<cdot>\<^sub>C \<phi>"] by auto
              interpret f\<phi>: arrow_from_functor D C F b' a \<open>\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi>\<close>
                using a \<phi> f \<epsilon>.preserves_hom [of a a a]
                by (unfold_locales, fastforce)
              interpret f'\<phi>: arrow_from_functor D C F b' a \<open>\<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>\<close>
                using a \<phi> f' par \<epsilon>.preserves_hom [of a a a]
                by (unfold_locales, fastforce)
              have "\<epsilon>a.is_coext b' (\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi>) g"
                unfolding \<epsilon>a.is_coext_def using g 1 by auto
              moreover have "\<epsilon>a.is_coext b' (\<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>) g'"
                unfolding \<epsilon>a.is_coext_def using g' 1 by auto
              ultimately have "g = g'"
                using 1 f\<phi>.arrow_from_functor_axioms f'\<phi>.arrow_from_functor_axioms
                      \<epsilon>a.the_coext_unique [of b' "\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi>" g]
                      \<epsilon>a.the_coext_unique [of b' "\<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>" g']
                by auto
              hence "f \<cdot>\<^sub>C \<phi> = f' \<cdot>\<^sub>C \<phi>"
                using g g' is_faithful by argo
              thus "f = f'"
                using \<phi> f f' par C.iso_is_retraction C.retraction_is_epi
                      C.epiE [of \<phi> f f']
                by auto
            qed
          qed
          ultimately show "C.iso (\<epsilon> a)"
            using C.iso_iff_mono_and_retraction by simp
        qed
        interpret \<epsilon>: natural_isomorphism C C \<open>F o G\<close> C.map \<epsilon>
          using 1 by (unfold_locales, auto)
        interpret \<epsilon>F: natural_isomorphism D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close>
          using \<epsilon>.components_are_iso by (unfold_locales, simp)
        show "\<And>a. D.ide a \<Longrightarrow> D.iso (\<eta> a)"
        proof -
          fix a
          assume a: "D.ide a"
          have 1: "C.iso ((\<epsilon> o F) a)"
            using a \<epsilon>.components_are_iso by simp
          moreover have "(\<epsilon> o F) a \<cdot>\<^sub>C (F o \<eta>) a = F a"
            using a \<eta>\<epsilon>.triangle_F \<epsilon>FoF\<eta>.map_simp_ide by simp
          ultimately have "C.inverse_arrows ((\<epsilon> o F) a) ((F o \<eta>) a)"
            using a C.section_retraction_of_iso by simp
          hence "C.iso ((F o \<eta>) a)"
            using C.iso_inv_iso by blast
          thus "D.iso (\<eta> a)"
            using a reflects_iso [of "\<eta> a"] by fastforce
        qed
      qed
      (*
       * Uggh, I should have started with "right_adjoint_functor C D G" so that the
       * following would come out right.  Instead, another step is needed to dualize.
       * TODO: Maybe re-work this later.
       *)
      interpret adjoint_equivalence C D F G \<eta> \<epsilon> ..
      interpret \<epsilon>': inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
      interpret \<eta>': inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
      interpret E: adjoint_equivalence D C G F \<epsilon>'.map \<eta>'.map
        using adjoint_equivalence_axioms dual_equivalence by blast
      have "equivalence_of_categories D C G F \<epsilon>'.map \<eta>'.map" ..
      thus "\<exists>G \<eta> \<epsilon>. equivalence_of_categories D C G F \<eta> \<epsilon>" by blast
    qed

  end

  sublocale fully_faithful_and_essentially_surjective_functor \<subseteq> equivalence_functor D C F
    using is_equivalence_functor by blast

end


(*
  File:     More_Polynomial_HLW.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Auxiliary facts about univariate polynomials\<close>
theory More_Polynomial_HLW
imports
  "HOL-Computational_Algebra.Computational_Algebra"
  "Polynomial_Factorization.Gauss_Lemma"
  "Power_Sum_Polynomials.Power_Sum_Polynomials_Library"
  "Algebraic_Numbers.Algebraic_Numbers"
begin

instance poly :: ("{idom_divide,normalization_semidom_multiplicative,factorial_ring_gcd,
                    semiring_gcd_mult_normalize}") factorial_semiring_multiplicative ..

lemma lead_coeff_prod_mset:
  fixes A :: "'a::{comm_semiring_1, semiring_no_zero_divisors} poly multiset"
  shows "Polynomial.lead_coeff (prod_mset A) = prod_mset (image_mset Polynomial.lead_coeff A)"
  by (induction A) (auto simp: Polynomial.lead_coeff_mult)

lemma content_normalize [simp]:
  fixes p :: "'a :: {factorial_semiring, idom_divide, semiring_gcd, normalization_semidom_multiplicative} poly"
  shows "content (normalize p) = content p"
proof (cases "p = 0")
  case [simp]: False
  have "content p = content (unit_factor p * normalize p)"
    by simp
  also have "\<dots> = content (unit_factor p) * content (normalize p)"
    by (rule content_mult)
  also have "content (unit_factor p) = 1"
    by (auto simp: unit_factor_poly_def)
  finally show ?thesis by simp
qed auto

lemma rat_to_normalized_int_poly_exists:
  fixes p :: "rat poly"
  assumes "p \<noteq> 0"
  obtains q lc where "p = Polynomial.smult lc (of_int_poly q)" "lc > 0" "content q = 1"
proof -
  define lc where "lc = fst (rat_to_normalized_int_poly p)"
  define q where "q = snd (rat_to_normalized_int_poly p)"
  have eq: "rat_to_normalized_int_poly p = (lc, q)"
    by (simp add: lc_def q_def)
  show ?thesis
    using rat_to_normalized_int_poly[OF eq] assms
    by (intro that[of lc q]) auto
qed

lemma irreducible_imp_squarefree:
  assumes "irreducible p"
  shows   "squarefree p"
proof (rule squarefreeI)
  fix q assume "q ^ 2 dvd p"
  then obtain r where qr: "p = q ^ 2 * r"
    by (elim dvdE)
  have "q dvd 1 \<or> q * r dvd 1"
    by (intro irreducibleD[OF assms]) (use qr in \<open>simp_all add: power2_eq_square mult_ac\<close>)
  thus "q dvd 1"
    by (meson dvd_mult_left)
qed

lemma squarefree_imp_rsquarefree:
  fixes p :: "'a :: idom poly"
  assumes "squarefree p"
  shows   "rsquarefree p"
  unfolding rsquarefree_def
proof (intro conjI allI)
  fix x :: 'a
  have "Polynomial.order x p < 2"
  proof (rule ccontr)
    assume "\<not>(Polynomial.order x p < 2)"
    hence "[:-x, 1:] ^ 2 dvd p"
      by (subst order_divides) auto
    from assms and this have "[:-x, 1:] dvd 1"
      by (rule squarefreeD)
    hence "Polynomial.degree [:-x, 1:] \<le> Polynomial.degree (1 :: 'a poly)"
      by (rule dvd_imp_degree_le) auto
    thus False by simp
  qed
  thus "Polynomial.order x p = 0 \<or> Polynomial.order x p = 1"
    by linarith
qed (use assms in auto)

lemma squarefree_imp_coprime_pderiv:
  fixes p :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize,semiring_char_0} poly"
  assumes "squarefree p" and "content p = 1"
  shows   "Rings.coprime p (pderiv p)"
proof (rule coprimeI_primes)
  fix d assume d: "prime d" "d dvd p" "d dvd pderiv p"
  show False
  proof (cases "Polynomial.degree d = 0")
    case deg: False
    obtain q where dq: "p = d * q"
      using d by (elim dvdE)
    have \<open>d dvd q * pderiv d\<close>
      using d by (simp add: dq pderiv_mult dvd_add_right_iff)
    moreover have "\<not>d dvd pderiv d"
    proof
      assume "d dvd pderiv d"
      hence "Polynomial.degree d \<le> Polynomial.degree (pderiv d)"
        using d deg by (intro dvd_imp_degree_le) (auto simp: pderiv_eq_0_iff)
      hence "Polynomial.degree d = 0"
        by (subst (asm) degree_pderiv) auto
      thus False using deg by contradiction
    qed
    ultimately have "d dvd q"
      using d(1) by (simp add: prime_dvd_mult_iff)
    hence "d ^ 2 dvd p"
      by (auto simp: dq power2_eq_square)
    from assms(1) and this have "is_unit d"
      by (rule squarefreeD)
    thus False using \<open>prime d\<close> by auto
  next
    case True
    then obtain d' where [simp]: "d = [:d':]"
      by (elim degree_eq_zeroE)
    from d have "d' dvd content p"
      by (simp add: const_poly_dvd_iff_dvd_content)
    with assms and prime_imp_prime_elem[OF \<open>prime d\<close>] show False
      by (auto simp: prime_elem_const_poly_iff)
  qed
qed (use assms in auto)

lemma irreducible_imp_coprime_pderiv:
  fixes p :: "'a :: {idom_divide,semiring_char_0} poly"
  assumes "irreducible p" "Polynomial.degree p \<noteq> 0"
  shows   "Rings.coprime p (pderiv p)"
proof (rule Rings.coprimeI)
  fix d assume d: "d dvd p" "d dvd pderiv p"
  obtain q where dq: "p = d * q"
    using d by (elim dvdE)
  have "is_unit d \<or> is_unit q"
    using assms dq by (auto simp: irreducible_def)
  thus "is_unit d"
  proof
    assume unit: "is_unit q"
    with d have "p dvd pderiv p"
      using algebraic_semidom_class.mult_unit_dvd_iff dq by blast
    hence "Polynomial.degree p = 0"
      by (meson not_dvd_pderiv)
    with assms(2) show ?thesis by contradiction
  qed
qed

lemma poly_gcd_eq_0I:
  assumes "poly p x = 0" "poly q x = 0"
  shows   "poly (gcd p q) x = 0"
  using assms by (simp add: poly_eq_0_iff_dvd)

lemma poly_eq_0_coprime:
  assumes "Rings.coprime p q" "p \<noteq> 0" "q \<noteq> 0"
  shows   "poly p x \<noteq> 0 \<or> poly q x \<noteq> 0"
proof -
  have False if "poly p x = 0" "poly q x = 0"
  proof -
    have "[:-x, 1:] dvd p" "[:-x, 1:] dvd q"
      using that by (simp_all add: poly_eq_0_iff_dvd)
    hence "[:-x, 1:] dvd 1"
      using \<open>Rings.coprime p q\<close> by (meson not_coprimeI)
    thus False
      by (simp add: is_unit_poly_iff)
  qed
  thus ?thesis
    by blast
qed

lemma coprime_of_int_polyI:
  assumes "Rings.coprime p q"
  shows   "Rings.coprime (of_int_poly p) (of_int_poly q :: 'a :: {field_char_0,field_gcd} poly)"
  using assms gcd_of_int_poly[of p q, where ?'a = 'a] unfolding coprime_iff_gcd_eq_1 by simp

lemma irreducible_imp_rsquarefree_of_int_poly:
  fixes p :: "int poly"
  assumes "irreducible p" and "Polynomial.degree p > 0"
  shows   "rsquarefree (of_int_poly p :: 'a :: {field_gcd, field_char_0} poly)"
proof -
  {
    fix x :: 'a
    assume x: "poly (of_int_poly p) x = 0" "poly (pderiv (of_int_poly p)) x = 0"
    define d where "d = gcd (of_int_poly p) (pderiv (of_int_poly p) :: 'a poly)"
    have "poly d x = 0"
      using x unfolding d_def by (intro poly_gcd_eq_0I) auto
    moreover have "d \<noteq> 0"
      using assms by (auto simp: d_def)
    ultimately have "0 < Polynomial.degree d"
      by (intro Nat.gr0I) (auto elim!: degree_eq_zeroE)
    also have "Polynomial.degree d = Polynomial.degree (gcd p (pderiv p))"
      unfolding d_def of_int_hom.map_poly_pderiv[symmetric] gcd_of_int_poly by simp
    finally have deg: "\<dots> > 0" .

    have "gcd p (pderiv p) dvd p"
      by auto
    from irreducibleD'[OF assms(1) this] and deg have "p dvd gcd p (pderiv p)"
      by auto
    also have "\<dots> dvd pderiv p"
      by auto
    finally have "Polynomial.degree p = 0"
      by auto
    with assms have False by simp
  }
  thus ?thesis by (auto simp: rsquarefree_roots)
qed

lemma squarefree_of_int_polyI:
  assumes "squarefree p" "content p = 1"
  shows   "squarefree (of_int_poly p :: 'a :: {field_char_0,field_gcd} poly)"
proof -
  have "Rings.coprime p (pderiv p)"
    by (rule squarefree_imp_coprime_pderiv) fact+
  hence "Rings.coprime (of_int_poly p :: 'a poly) (of_int_poly (pderiv p))"
    by (rule coprime_of_int_polyI)
  also have "of_int_poly (pderiv p) = pderiv (of_int_poly p :: 'a poly)"
    by (simp add: of_int_hom.map_poly_pderiv)
  finally show ?thesis
    using coprime_pderiv_imp_squarefree by blast
qed

lemma higher_pderiv_pcompose_linear:
   "(pderiv ^^ n) (pcompose p [:0, c:]) =
    Polynomial.smult (c ^ n) (pcompose ((pderiv ^^ n) p) [:0, c:])"
  by (induction n)  (simp_all add: pderiv_pcompose pderiv_smult pderiv_pCons pcompose_smult mult_ac)

lemma poly_poly_eq:
  "poly (poly p [:x:]) y = poly (eval_poly (\<lambda>p. [:poly p y:]) p [:0, 1:]) x"
  by (induction p) (auto simp: eval_poly_def)

lemma poly_poly_poly_y_x [simp]:
  fixes p :: "'a :: idom poly poly"
  shows "poly (poly (poly_y_x p) [:y:]) x = poly (poly p [:x:]) y"
proof (induction p)
  case (pCons a p)
  have "poly (poly (poly_y_x (pCons a p)) [:y:]) x =
          poly a y + poly (poly (map_poly (pCons 0) (poly_y_x p)) [:y:]) x"
    by (simp add: poly_y_x_pCons eval_poly_def)
  also have "pCons 0 = (\<lambda>p::'a poly. Polynomial.monom 1 1 * p)"
    by (simp add: Polynomial.monom_altdef)
  also have "map_poly \<dots> (poly_y_x p) = Polynomial.smult (Polynomial.monom 1 1) (poly_y_x p)"
    by (simp add: smult_conv_map_poly)
  also have "poly \<dots> [:y:] = Polynomial.monom 1 1 * poly (poly_y_x p) [:y:]"
    by simp
  also have "poly a y + poly \<dots> x = poly (poly (pCons a p) [:x:]) y"
    by (simp add: pCons poly_monom)
  finally show ?case .
qed auto

lemma (in idom_hom) map_poly_higher_pderiv [hom_distribs]:
  "map_poly hom ((pderiv ^^ n) p) = (pderiv ^^ n) (map_poly hom p)"
  by (induction n) (simp_all add: map_poly_pderiv)

lemma coeff_prod_linear_factors:
  fixes f :: "'a \<Rightarrow> 'b :: comm_ring_1"
  assumes [intro]: "finite A"
  shows "Polynomial.coeff (\<Prod>x\<in>A. [:-f x, 1:] ^ e x) i =
           (\<Sum>X | X \<in> Pow (SIGMA x:A. {..<e x}) \<and> i = sum e A - card X.
             (-1) ^ card X * (\<Prod>x\<in>X. f (fst x)))"
proof -
  define poly_X where "poly_X = (Polynomial.monom 1 1 :: 'b poly)"
  have [simp]: "(- 1) ^ n = [:(- 1) ^ n :: 'b:]" for n :: nat
    by (simp flip: pCons_one add: poly_const_pow)
  have "(\<Prod>x\<in>A. [:-f x, 1:] ^ e x) = (\<Prod>(x,_)\<in>Sigma A (\<lambda>x. {..<e x}). [:-f x, 1:])"
    by (subst prod.Sigma [symmetric]) auto
  also have "\<dots> = (\<Prod>(x,_)\<in>Sigma A (\<lambda>x. {..<e x}). poly_X - [:f x:])"
    by (intro prod.cong) (auto simp: poly_X_def monom_altdef)
  also have "\<dots> = (\<Sum>X\<in>Pow (SIGMA x:A. {..<e x}).
                    Polynomial.smult ((-1) ^ card X * (\<Prod>x\<in>X. f (fst x)))
                    (poly_X ^ card ((SIGMA x:A. {..<e x}) - X)))"
    unfolding case_prod_unfold
    by (subst prod_diff1) (auto simp: mult_ac simp flip: coeff_lift_hom.hom_prod)
  also have "\<dots> = (\<Sum>X\<in>Pow (SIGMA x:A. {..<e x}).
       Polynomial.monom ((- 1) ^ card X * (\<Prod>x\<in>X. f (fst x))) (card ((SIGMA x:A. {..<e x}) - X)))"
    unfolding poly_X_def monom_power Polynomial.smult_monom by simp
  also have "Polynomial.coeff \<dots> i = (\<Sum>X\<in>{X\<in>Pow (SIGMA x:A. {..<e x}). i =
               sum e A - card X}. (- 1) ^ card X * (\<Prod>x\<in>X. f (fst x)))"
    unfolding Polynomial.coeff_sum
  proof (intro sum.mono_neutral_cong_right ballI, goal_cases)
    case (3 X)
    hence X: "X \<subseteq> (SIGMA x:A. {..<e x})"
      by auto
    have card_le: "card X \<le> card (SIGMA x:A. {..<e x})"
      using X by (intro card_mono) auto
    have "finite X"
      by (rule finite_subset[OF X]) auto
    hence "card ((SIGMA x:A. {..<e x}) - X) = card (SIGMA x:A. {..<e x}) - card X"
      using 3 by (intro card_Diff_subset) auto
    also have card_eq: "card (SIGMA x:A. {..<e x}) = sum e A"
      by (subst card_SigmaI) auto
    finally show ?case
      using 3 card_le card_eq by (auto simp: algebra_simps)
  next
    case (4 X)
    hence X: "X \<subseteq> (SIGMA x:A. {..<e x})"
      by auto
    have "finite X"
      by (rule finite_subset[OF X]) auto
    hence "card ((SIGMA x:A. {..<e x}) - X) = card (SIGMA x:A. {..<e x}) - card X"
      using 4 by (intro card_Diff_subset) auto
    also have card_eq: "card (SIGMA x:A. {..<e x}) = sum e A"
      by (subst card_SigmaI) auto
    finally show ?case
      using 4 card_eq by (auto simp: algebra_simps)
  qed auto
  finally show ?thesis .
qed

lemma (in comm_ring_hom) synthetic_div_hom:
  "synthetic_div (map_poly hom p) (hom x) = map_poly hom (synthetic_div p x)"
  by (induction p) (auto simp: map_poly_pCons_hom)

lemma synthetic_div_altdef:
  fixes p :: "'a :: field poly"
  shows "synthetic_div p c = p div [:-c, 1:]"
proof -
  define q where "q = p div [:- c, 1:]"
  have "Polynomial.degree (p mod [:-c, 1:]) = 0"
  proof (cases "p mod [:-c, 1:] = 0")
    case False
    hence "Polynomial.degree (p mod [:-c, 1:]) < Polynomial.degree [:-c, 1:]"
      by (intro degree_mod_less') auto
    thus ?thesis by simp
  qed auto
  then obtain d where d: "p mod [:-c, 1:] = [:d:]"
    by (elim degree_eq_zeroE)

  have p_eq: "p = q * [:-c, 1:] + [:d:]"
    unfolding q_def d [symmetric] by presburger
  have [simp]: "poly p c = d"
    by (simp add: p_eq)
  have "p + Polynomial.smult c q = pCons (poly p c) q"
    by (subst p_eq) auto
  from synthetic_div_unique[OF this] show ?thesis
    by (auto simp: q_def)
qed

lemma (in ring_closed) poly_closed [intro]:
  assumes "\<And>i. poly.coeff p i \<in> A" "x \<in> A"
  shows   "poly p x \<in> A"
  unfolding poly_altdef by (intro sum_closed mult_closed power_closed assms)

lemma (in ring_closed) coeff_pCons_closed [intro]:
  assumes "\<And>i. poly.coeff p i \<in> A" "x \<in> A"
  shows   "poly.coeff (pCons x p) i \<in> A"
  unfolding poly_altdef using assms by (auto simp: coeff_pCons split: nat.splits)

lemma (in ring_closed) coeff_poly_mult_closed [intro]:
  assumes "\<And>i. poly.coeff p i \<in> A" "\<And>i. poly.coeff q i \<in> A"
  shows   "poly.coeff (p * q) i \<in> A"
  unfolding coeff_mult using assms by auto

lemma (in ring_closed) coeff_poly_prod_closed [intro]:
  assumes "\<And>x i. x \<in> X \<Longrightarrow> poly.coeff (f x) i \<in> A"
  shows   "poly.coeff (prod f X) i \<in> A"
  using assms by (induction X arbitrary: i rule: infinite_finite_induct) auto

lemma (in ring_closed) coeff_poly_power_closed [intro]:
  assumes "\<And>i. poly.coeff p i \<in> A"
  shows   "poly.coeff (p ^ n) i \<in> A"
  using coeff_poly_prod_closed[of "{..<n}" "\<lambda>_. p" i] assms by simp

lemma (in ring_closed) synthetic_div_closed:
  assumes "\<And>i. poly.coeff p i \<in> A" "x \<in> A"
  shows   "poly.coeff (synthetic_div p x) i \<in> A"
proof -
  from assms(1) have "\<forall>i. poly.coeff p i \<in> A"
    by blast
  from this and assms(2) show ?thesis
    by (induction p arbitrary: i) (auto simp: coeff_pCons split: nat.splits)
qed

lemma pcompose_monom: "pcompose (Polynomial.monom c n) p = Polynomial.smult c (p ^ n)"
  by (simp add: monom_altdef pcompose_hom.hom_power pcompose_smult)

lemma poly_roots_uminus [simp]: "poly_roots (-p) = poly_roots p"
  using poly_roots_smult[of "-1" p] by (simp del: poly_roots_smult)

lemma poly_roots_normalize [simp]:
  fixes p :: "'a :: {normalization_semidom, idom_divide} poly"
  shows "poly_roots (normalize p) = poly_roots p"
proof (cases "p = 0")
  case [simp]: False
  have "poly_roots p = poly_roots (unit_factor p * normalize p)"
    by simp
  also have "\<dots> = poly_roots (normalize p)"
    unfolding unit_factor_poly_def by simp
  finally show ?thesis ..
qed auto

lemma poly_roots_of_int_normalize [simp]:
  "poly_roots (of_int_poly (normalize p) :: 'a :: {idom, ring_char_0} poly) =
   poly_roots (of_int_poly p)"
proof (cases "p = 0")
  case [simp]: False
  have "poly_roots (of_int_poly p :: 'a poly) = poly_roots (of_int_poly (unit_factor p * normalize p))"
    by simp
  also have "\<dots> = poly_roots (Polynomial.smult (of_int (sgn (Polynomial.lead_coeff p)))
                    (of_int_poly (normalize p)))"
    by (simp add: unit_factor_poly_def of_int_hom.map_poly_hom_smult)
  also have "\<dots> = poly_roots (Ring_Hom_Poly.of_int_poly (normalize p) :: 'a poly)"
    by (intro poly_roots_smult) (auto simp: sgn_if)
  finally show ?thesis ..
qed auto

lemma poly_roots_power [simp]: "poly_roots (p ^ n) = repeat_mset n (poly_roots p)"
proof (cases "p = 0")
  case True
  thus ?thesis by (cases n) auto
next
  case False
  thus ?thesis by (induction n) (auto simp: poly_roots_mult)
qed

lemma poly_roots_conv_sum_prime_factors:
  "poly_roots q = (\<Sum>p\<in>#prime_factorization q. poly_roots p)"
proof (cases "q = 0")
  case [simp]: False

  have "(\<Sum>p\<in>#prime_factorization q. poly_roots p) =
        poly_roots (prod_mset (prime_factorization q))"
    by (rule poly_roots_prod_mset [symmetric]) auto
  also have "\<dots> = poly_roots (normalize (prod_mset (prime_factorization q)))"
    by simp
  also have "normalize (prod_mset (prime_factorization q)) = normalize q"
    by (rule prod_mset_prime_factorization_weak) auto
  also have "poly_roots \<dots> = poly_roots q"
    by simp
  finally show ?thesis ..
qed auto

lemma poly_roots_of_int_conv_sum_prime_factors:
  "poly_roots (of_int_poly q :: 'a :: {idom, ring_char_0} poly) =
   (\<Sum>p\<in>#prime_factorization q. poly_roots (of_int_poly p))"
proof (cases "q = 0")
  case [simp]: False

  have "(\<Sum>p\<in>#prime_factorization q. poly_roots (of_int_poly p :: 'a poly)) =
        poly_roots (\<Prod>p\<in>#prime_factorization q. of_int_poly p)"
    by (subst poly_roots_prod_mset) (auto simp: multiset.map_comp o_def)
  also have "(\<Prod>p\<in>#prime_factorization q. of_int_poly p :: 'a poly) =
               of_int_poly (prod_mset (prime_factorization q))"
    by simp
  also have "poly_roots \<dots> = poly_roots (of_int_poly (normalize (prod_mset (prime_factorization q))))"
    by (rule poly_roots_of_int_normalize [symmetric])
  also have "normalize (prod_mset (prime_factorization q)) = normalize q"
    by (rule prod_mset_prime_factorization_weak) auto
  also have "poly_roots (of_int_poly \<dots> :: 'a poly) = poly_roots (of_int_poly q)"
    by simp
  finally show ?thesis ..
qed auto

lemma dvd_imp_poly_roots_subset:
  assumes "q \<noteq> 0" "p dvd q"
  shows   "poly_roots p \<subseteq># poly_roots q"
proof -
  from assms have "p \<noteq> 0"
    by auto
  thus ?thesis
    using assms by (intro mset_subset_eqI) (auto intro: dvd_imp_order_le)
qed

lemma abs_prod_mset: "\<bar>prod_mset (A :: 'a :: idom_abs_sgn multiset)\<bar> = prod_mset (image_mset abs A)"
  by (induction A) (auto simp: abs_mult)

lemma content_1_imp_nonconstant_prime_factors:
  assumes "content (p :: int poly) = 1" and "q \<in> prime_factors p"
  shows   "Polynomial.degree q > 0"
proof -
  let ?d = "Polynomial.degree :: int poly \<Rightarrow> nat"
  let ?lc = "Polynomial.lead_coeff :: int poly \<Rightarrow> int"
  define P where "P = prime_factorization p"
  define P1 where "P1 = filter_mset (\<lambda>p. ?d p = 0) P"
  define P2 where "P2 = filter_mset (\<lambda>p. ?d p > 0) P"
  have [simp]: "p \<noteq> 0"
    using assms by auto
  have "1 = content (normalize p)"
    using assms by simp
  also have "normalize p = prod_mset P"
    unfolding P_def by (rule prod_mset_prime_factorization [symmetric]) auto
  also have "P = filter_mset (\<lambda>p. ?d p = 0) P + filter_mset (\<lambda>p. ?d p > 0) P"
    by (induction P) auto
  also have "prod_mset \<dots> = prod_mset P1 * prod_mset P2"
    unfolding P1_def P2_def by (subst prod_mset.union) auto
  also have "content \<dots> = content (prod_mset P1) * content (prod_mset P2)"
    unfolding content_mult ..
  also have "image_mset id P1 = image_mset (\<lambda>q. [:?lc q:]) P1"
    by (intro image_mset_cong) (auto simp: P1_def elim!: degree_eq_zeroE)
  hence "P1 = image_mset (\<lambda>q. [:?lc q:]) P1"
    by simp
  also have "content (prod_mset \<dots>) = \<bar>(\<Prod>q\<in>#P1. ?lc q)\<bar>"
    by (simp add: content_prod_mset multiset.map_comp o_def abs_prod_mset)
  finally have "\<bar>(\<Prod>q\<in>#P1. ?lc q)\<bar> * content (prod_mset P2) = 1" ..
  hence "\<bar>(\<Prod>q\<in>#P1. ?lc q)\<bar> dvd 1"
    unfolding dvd_def by metis

  have "set_mset P1 = {}"
  proof (rule ccontr)
    assume "set_mset P1 \<noteq> {}"
    then obtain q where q: "q \<in># P1"
      by blast
    have "\<bar>?lc q\<bar> dvd (\<Prod>q\<in>#P1. \<bar>?lc q\<bar>)"
      by (rule dvd_prod_mset) (use q in auto)
    also have "\<dots> = \<bar>(\<Prod>q\<in>#P1. ?lc q)\<bar>"
      by (simp add: abs_prod_mset multiset.map_comp o_def)
    also have "\<dots> dvd 1"
      by fact
    finally have "is_unit (?lc q)"
      by simp
    hence "is_unit q"
      using q unfolding P1_def by (auto elim!: degree_eq_zeroE)
    moreover have "prime q"
      using q unfolding P1_def P_def by auto
    ultimately show False by auto
  qed
  with assms show ?thesis
    by (auto simp: P1_def P_def)
qed

end


theory NatExt
imports ZF.Arith ZF.ArithSimp
begin

ML_file \<open>InitRuby.ML\<close>

definition nats :: "i \<Rightarrow> i" where
  "nats(n) == {m:nat. m < n}"

theorem le_in_succ: "[| i \<le> n; n: nat; i:nat|] ==> i:succ(n)"
apply(auto simp: ltD ltE)
done

theorem succ_add_1: "n:nat ==> succ(n) = n #+ 1"
apply(auto)
done

lemma neq_0_lt_0: "[| m #- n ~= 0; m:nat; n:nat |] ==> 0 < m #- n"
apply(rule Ord_0_lt)
apply(auto)
done

theorem diff_le_0: "[| m \<le> n; n:nat; m:nat |] ==> m #- n = 0"
apply(rule ccontr)
apply(drule le_imp_not_lt)
apply(drule neq_0_lt_0, assumption+)
apply(simp add: less_diff_conv)
done

theorem add_lt_n: "[| x #+ n < y #+ n; n:nat; x:nat; y:nat |] ==> x < y"
apply(rule_tac k = "n" in add_lt_elim1)
apply(simp add: add_commute)
apply(assumption+)
done

lemma lt_imp_neq: "x < y \<Longrightarrow> x \<noteq> y"
apply(auto)
done

theorem add_lt_reverse: "\<lbrakk> m < n; x #+ n = m #+ y; x:nat; y:nat; n:nat; m:mat \<rbrakk> \<Longrightarrow> x < y"
apply(rule ccontr)
apply(simp add: not_lt_iff_le)
apply(drule add_lt_le_mono, auto)
apply((drule lt_imp_neq)+)
apply(simp add: add_commute)
done

theorem diff_lt_0: "[| m < n; n:nat; m:nat |] ==> 0 < n #- m"
apply(simp add: less_diff_conv)
done

lemma add_lt_larger_side_help: "\<lbrakk> n:nat; m:nat; x:nat; m < n \<rbrakk> \<Longrightarrow> m #+ 0 < n #+ x"
by(rule add_lt_le_mono[of m n 0 x], auto)

lemma add_lt_larger_side: "\<lbrakk> n:nat; m:nat; x:nat; m < n \<rbrakk> \<Longrightarrow> m < x #+ n"
apply(frule add_lt_larger_side_help[of n m x], auto)
apply(simp add: add_commute)
done

lemma diff_add_comm_help: "⟦n ∈ nat; m ∈ nat; m < n; x ∈ nat; x #+ n #- m = x #+ (n #- m)⟧ ⟹ succ(x #+ n) #- m = succ(x #+ (n #- m))"
proof -
  assume a: "n ∈ nat" "m ∈ nat" "m < n" "x:nat" "x #+ n #- m = x #+ (n #- m)"
  then have "m < x #+ n" using add_lt_larger_side by simp
  then have "m \<le> x #+ n" using leI by simp
  then have b: "succ(x #+ n #- m) = succ(x #+ n) #- m" using diff_succ by simp
  have "succ(x #+ n #- m) = succ(x #+ (n #- m))" using succ_inject_iff a by simp
  then show ?thesis using b by simp
qed

theorem diff_add_assoc: "[| m < n; n:nat; m:nat; k:nat|] ==> k #+ n #- m = k #+ (n #- m)"
apply(drule diff_lt_0, assumption+)
apply(induct_tac k, auto)
by(rule diff_add_comm_help, auto)

theorem diff_add_comm: "[| m < n; n:nat; m:nat; k:nat|] ==> n #+ k #- m = k #+ (n #- m)"
apply(simp add: add_commute)
by(rule diff_add_assoc)

theorem n_gt_0_succ: "[| 0 < n; n: nat; !!x. [| n = succ(x); x:nat |] ==> P |] ==> P"
by(erule zero_lt_natE)

lemma refl_add_help: "[| n:nat; m:nat |] ==> 0 #+ n \<le> m #+ n"
by(rule add_le_mono1, simp)

theorem mult_le_self: "[| 0 < m; n:nat; m:nat |] ==> n \<le> n #* m"
apply (case_tac m, simp)
apply (frule_tac ?m="n #* x" in refl_add_help)
by (auto simp add: add_commute)

theorem gt_not0: "[| 0 < n; n:nat |] ==> n~= 0"
apply(auto)
done

theorem diff_succ: "[| m \<le> n; n:nat; m:nat |] ==> succ(n) #- m = succ(n #- m)"
by(rule diff_succ)

lemma add_same_cancel: "\<lbrakk> m:nat; n:nat; k:nat; m #+ k = n #+ k \<rbrakk> \<Longrightarrow> m = n"
by(auto)

theorem diff_diff_inverse: "[| m < n; n:nat; m:nat |] ==> n #- (n #- m) = m"
proof -
  assume a: "m < n" "n:nat" "m:nat"
  then have "n #- m \<le> n" using diff_le_self by(auto)
  then have b: "n #- (n #- m) #+ (n #- m) = n" using add_diff_inverse2[of "n #- m" n] a by(auto)
  then have "m \<le> n" using a leI by(auto)
  then have "m #+ (n #- m) = n" using a add_diff_inverse by(auto)
  then have c: "n #- (n #- m) #+ (n #- m) = m #+ (n #- m)" using b by(auto)
  have d: "n #- m : nat" using a by(auto)
  then have "n #- (n #- m) : nat" using a by(auto)
  then show ?thesis using add_same_cancel[of "n #- (n #- m)" "m" "n #- m"] a c d by(auto)
qed

theorem add_0_eq_0: "[| n #+ m = 0; m:nat; n:nat |] ==> n = 0"
by(case_tac m, auto)

theorem mult_cancel: "[| n #* m = n #* p; 0 < n; n:nat; m:nat; p:nat |] ==> m = p"
by(auto)

declare nats_def [simp]

theorem mod_dep_type: "[| 0 < n; m:nat; n:nat |] ==> m mod n :nats(n)"
apply(auto)
by(rule mod_less_divisor)

theorem mod_lt: "[| 0 < n; m:nat; n:nat |] ==> m mod n < n"
by(rule mod_less_divisor)

theorem natsI: "[| m:nat; n:nat; m:n |] ==> m :nats(n)"
apply(auto)
by(rule ltI, simp_all)

theorem natsI2: "q:{ m:nat. m < n } ==> q: nats(n)"
by(simp)

theorem natsE: "[| m:nats(n); n:nat; [| m:nat; m < n |] ==> P |] ==> P"
by(auto)

lemma ball_le_nat: "n:nat \<Longrightarrow> ALL j:nat. j \<le> n \<longrightarrow> p(j) \<Longrightarrow>
ALL j:nat. j < n \<longrightarrow> p(j)"
apply(auto)
by(drule leI, auto)

theorem ball_lt_nats: "[| ALL j:nats(succ(n)). p(j); ALL j:nats(n). p(j) ==> P; n:nat |] ==> P"
apply(auto)
by(drule ball_le_nat)

theorem mod_mult_self: "[| t:nat; n:nat; 0 < n; j:nats(n) |] ==> (n #* t #+ j) mod n = j"
apply(auto)
proof -
  assume a: "t ∈ nat" "n ∈ nat" "0 < n" "j ∈ nat" "j < n"
  then have b: "(n #* t #+ j) mod n = j mod n" using mod_mult_self1_raw [of t j n] by(simp add: add_commute)
  have "j = j mod n" using a by(auto)
  then show ?thesis using b by(auto)
qed

lemma "\<lbrakk> m:nat; n:nat; a:nat; k:nat; (m mod n) = (a mod n) \<rbrakk> \<Longrightarrow> (m #+ k) mod n = (a #+ k) mod n"
apply(induct_tac k, auto)
by(simp add: mod_succ)

lemma mod_diff_induct_lemma:
  "⟦n ∈ nat; 0 < n; j ∈ nat; j < n; t = succ(ja); x ∈ nat; (n #+ n #* x #- j) mod n = (n #- j) mod n⟧
    \<Longrightarrow> (n #+ (n #+ n #* x) #- j) mod n = (n #- j) mod n"
proof -
  assume a: "n ∈ nat" "0 < n" "j ∈ nat" "j < n" "t = succ(ja)"
            "x ∈ nat" "(n #+ n #* x #- j) mod n = (n #- j) mod n"
  then have "j < n #+ n #* x" using add_lt_larger_side by(simp add: add_commute)
  then have "n #+ (n #+ n #* x) #- j = n #+ ((n #+ n #* x) #- j)"
    using diff_add_assoc[of j "n #+ n #* x" n ] a by simp
  then have "(n #+ (n #+ n #* x) #- j) mod n = (n #+ n #* x #- j) mod n"
    using mod_add_self1 by simp
  then show ?thesis using a by simp
qed

theorem mod_diff: "[| t:nat; 0 < t; n:nat; 0 < n; j:nats(n) |] ==>
                    (n #* t #- j) mod n = (n #- j) mod n"
apply(auto)
apply(drule zero_lt_lemma, auto)
apply(induct_tac ja, auto)
by(rule mod_diff_induct_lemma)

lemmas arith_typechecks =
  mod_type div_type nat_typechecks

lemmas arith_simps =
  add_0_right add_succ_right mult_0_right
  mult_succ_right diff_self_eq_0 add_diff_inverse
  diff_add_inverse diff_add_0

lemmas arith_ss = arith_typechecks arith_simps

declare arith_ss [simp]

end