/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

! This file was ported from Lean 3 source module control.functor
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Lint.Default
import Mathbin.Control.Basic

/-!
# Functors

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This module provides additional lemmas, definitions, and instances for `functor`s.

## Main definitions

* `const α` is the functor that sends all types to `α`.
* `add_const α` is `const α` but for when `α` has an additive structure.
* `comp F G` for functors `F` and `G` is the functor composition of `F` and `G`.
* `liftp` and `liftr` respectively lift predicates and relations on a type `α`
  to `F α`.  Terms of `F α` are considered to, in some sense, contain values of type `α`.

## Tags

functor, applicative
-/

attribute [functor_norm] seq_assoc pure_seq_eq_map map_pure seq_map_assoc map_seq

universe u v w

section Functor

variable {F : Type u → Type v}

variable {α β γ : Type u}

variable [Functor F] [LawfulFunctor F]

#print Functor.map_id /-
theorem Functor.map_id : (· <$> ·) id = (id : F α → F α) := by apply funext <;> apply id_map
#align functor.map_id Functor.map_id
-/

#print Functor.map_comp_map /-
theorem Functor.map_comp_map (f : α → β) (g : β → γ) :
    ((· <$> ·) g ∘ (· <$> ·) f : F α → F γ) = (· <$> ·) (g ∘ f) := by
  apply funext <;> intro <;> rw [comp_map]
#align functor.map_comp_map Functor.map_comp_map
-/

/- warning: functor.ext -> Functor.ext is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} {F1 : Functor.{u1, u2} F} {F2 : Functor.{u1, u2} F} [_inst_3 : LawfulFunctor.{u1, u2} F F1] [_inst_4 : LawfulFunctor.{u1, u2} F F2], (forall (α : Type.{u1}) (β : Type.{u1}) (f : α -> β) (x : F α), Eq.{succ u2} (F β) (Functor.map.{u1, u2} F F1 α β f x) (Functor.map.{u1, u2} F F2 α β f x)) -> (Eq.{succ (max (succ u1) u2)} (Functor.{u1, u2} F) F1 F2)
but is expected to have type
  forall {F : Type.{u2} -> Type.{u1}} {F1 : Functor.{u2, u1} F} {F2 : Functor.{u2, u1} F} [_inst_3 : LawfulFunctor.{u2, u1} F F1] [_inst_4 : LawfulFunctor.{u2, u1} F F2], (forall (α : Type.{u2}) (β : Type.{u2}) (f : α -> β) (x : F α), Eq.{succ u1} (F β) (Functor.map.{u2, u1} F F1 α β f x) (Functor.map.{u2, u1} F F2 α β f x)) -> (Eq.{max (succ u1) (succ (succ u2))} (Functor.{u2, u1} F) F1 F2)
Case conversion may be inaccurate. Consider using '#align functor.ext Functor.extₓ'. -/
theorem Functor.ext {F} :
    ∀ {F1 : Functor F} {F2 : Functor F} [@LawfulFunctor F F1] [@LawfulFunctor F F2]
      (H : ∀ (α β) (f : α → β) (x : F α), @Functor.map _ F1 _ _ f x = @Functor.map _ F2 _ _ f x),
      F1 = F2
  | ⟨m, mc⟩, ⟨m', mc'⟩, H1, H2, H =>
    by
    cases show @m = @m' by funext α β f x <;> apply H
    congr ; funext α β
    have E1 := @map_const_eq _ ⟨@m, @mc⟩ H1
    have E2 := @map_const_eq _ ⟨@m, @mc'⟩ H2
    exact E1.trans E2.symm
#align functor.ext Functor.ext

end Functor

#print id.mk /-
/-- Introduce the `id` functor. Incidentally, this is `pure` for
`id` as a `monad` and as an `applicative` functor. -/
def id.mk {α : Sort u} : α → id α :=
  id
#align id.mk id.mk
-/

namespace Functor

#print Functor.Const /-
/-- `const α` is the constant functor, mapping every type to `α`. When
`α` has a monoid structure, `const α` has an `applicative` instance.
(If `α` has an additive monoid structure, see `functor.add_const`.) -/
@[nolint unused_arguments]
def Const (α : Type _) (β : Type _) :=
  α
#align functor.const Functor.Const
-/

#print Functor.Const.mk /-
/-- `const.mk` is the canonical map `α → const α β` (the identity), and
it can be used as a pattern to extract this value. -/
@[match_pattern]
def Const.mk {α β} (x : α) : Const α β :=
  x
#align functor.const.mk Functor.Const.mk
-/

#print Functor.Const.mk' /-
/-- `const.mk'` is `const.mk` but specialized to map `α` to
`const α punit`, where `punit` is the terminal object in `Type*`. -/
def Const.mk' {α} (x : α) : Const α PUnit :=
  x
#align functor.const.mk' Functor.Const.mk'
-/

#print Functor.Const.run /-
/-- Extract the element of `α` from the `const` functor. -/
def Const.run {α β} (x : Const α β) : α :=
  x
#align functor.const.run Functor.Const.run
-/

namespace Const

/- warning: functor.const.ext -> Functor.Const.ext is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {x : Functor.Const.{u1, u2} α β} {y : Functor.Const.{u1, u2} α β}, (Eq.{succ u1} α (Functor.Const.run.{u1, u2} α β x) (Functor.Const.run.{u1, u2} α β y)) -> (Eq.{succ u1} (Functor.Const.{u1, u2} α β) x y)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {x : Functor.Const.{u2, u1} α β} {y : Functor.Const.{u2, u1} α β}, (Eq.{succ u2} α (Functor.Const.run.{u2, u1} α β x) (Functor.Const.run.{u2, u1} α β y)) -> (Eq.{succ u2} (Functor.Const.{u2, u1} α β) x y)
Case conversion may be inaccurate. Consider using '#align functor.const.ext Functor.Const.extₓ'. -/
protected theorem ext {α β} {x y : Const α β} (h : x.run = y.run) : x = y :=
  h
#align functor.const.ext Functor.Const.ext

#print Functor.Const.map /-
/-- The map operation of the `const γ` functor. -/
@[nolint unused_arguments]
protected def map {γ α β} (f : α → β) (x : Const γ β) : Const γ α :=
  x
#align functor.const.map Functor.Const.map
-/

instance {γ} : Functor (Const γ) where map := @Const.map γ

instance {γ} : LawfulFunctor (Const γ) := by constructor <;> intros <;> rfl

instance {α β} [Inhabited α] : Inhabited (Const α β) :=
  ⟨(default : α)⟩

end Const

#print Functor.AddConst /-
/-- `add_const α` is a synonym for constant functor `const α`, mapping
every type to `α`. When `α` has a additive monoid structure,
`add_const α` has an `applicative` instance. (If `α` has a
multiplicative monoid structure, see `functor.const`.) -/
def AddConst (α : Type _) :=
  Const α
#align functor.add_const Functor.AddConst
-/

#print Functor.AddConst.mk /-
/-- `add_const.mk` is the canonical map `α → add_const α β`, which is the identity,
where `add_const α β = const α β`. It can be used as a pattern to extract this value. -/
@[match_pattern]
def AddConst.mk {α β} (x : α) : AddConst α β :=
  x
#align functor.add_const.mk Functor.AddConst.mk
-/

#print Functor.AddConst.run /-
/-- Extract the element of `α` from the constant functor. -/
def AddConst.run {α β} : AddConst α β → α :=
  id
#align functor.add_const.run Functor.AddConst.run
-/

#print Functor.AddConst.functor /-
instance AddConst.functor {γ} : Functor (AddConst γ) :=
  @Const.functor γ
#align functor.add_const.functor Functor.AddConst.functor
-/

#print Functor.AddConst.lawfulFunctor /-
instance AddConst.lawfulFunctor {γ} : LawfulFunctor (AddConst γ) :=
  @Const.lawfulFunctor γ
#align functor.add_const.is_lawful_functor Functor.AddConst.lawfulFunctor
-/

instance {α β} [Inhabited α] : Inhabited (AddConst α β) :=
  ⟨(default : α)⟩

#print Functor.Comp /-
/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def Comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) : Type w :=
  F <| G α
#align functor.comp Functor.Comp
-/

#print Functor.Comp.mk /-
/-- Construct a term of `comp F G α` from a term of `F (G α)`, which is the same type.
Can be used as a pattern to extract a term of `F (G α)`. -/
@[match_pattern]
def Comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : F (G α)) : Comp F G α :=
  x
#align functor.comp.mk Functor.Comp.mk
-/

#print Functor.Comp.run /-
/-- Extract a term of `F (G α)` from a term of `comp F G α`, which is the same type. -/
def Comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : Comp F G α) : F (G α) :=
  x
#align functor.comp.run Functor.Comp.run
-/

namespace Comp

variable {F : Type u → Type w} {G : Type v → Type u}

#print Functor.Comp.ext /-
protected theorem ext {α} {x y : Comp F G α} : x.run = y.run → x = y :=
  id
#align functor.comp.ext Functor.Comp.ext
-/

instance {α} [Inhabited (F (G α))] : Inhabited (Comp F G α) :=
  ⟨(default : F (G α))⟩

variable [Functor F] [Functor G]

#print Functor.Comp.map /-
/-- The map operation for the composition `comp F G` of functors `F` and `G`. -/
protected def map {α β : Type v} (h : α → β) : Comp F G α → Comp F G β
  | comp.mk x => Comp.mk ((· <$> ·) h <$> x)
#align functor.comp.map Functor.Comp.map
-/

instance : Functor (Comp F G) where map := @Comp.map F G _ _

#print Functor.Comp.map_mk /-
@[functor_norm]
theorem map_mk {α β} (h : α → β) (x : F (G α)) : h <$> Comp.mk x = Comp.mk ((· <$> ·) h <$> x) :=
  rfl
#align functor.comp.map_mk Functor.Comp.map_mk
-/

#print Functor.Comp.run_map /-
@[simp]
protected theorem run_map {α β} (h : α → β) (x : Comp F G α) :
    (h <$> x).run = (· <$> ·) h <$> x.run :=
  rfl
#align functor.comp.run_map Functor.Comp.run_map
-/

variable [LawfulFunctor F] [LawfulFunctor G]

variable {α β γ : Type v}

#print Functor.Comp.id_map /-
protected theorem id_map : ∀ x : Comp F G α, Comp.map id x = x
  | comp.mk x => by simp [comp.map, Functor.map_id]
#align functor.comp.id_map Functor.Comp.id_map
-/

#print Functor.Comp.comp_map /-
protected theorem comp_map (g' : α → β) (h : β → γ) :
    ∀ x : Comp F G α, Comp.map (h ∘ g') x = Comp.map h (Comp.map g' x)
  | comp.mk x => by simp [comp.map, Functor.map_comp_map g' h, functor_norm]
#align functor.comp.comp_map Functor.Comp.comp_map
-/

instance : LawfulFunctor (Comp F G)
    where
  id_map := @Comp.id_map F G _ _ _ _
  comp_map := @Comp.comp_map F G _ _ _ _

/- warning: functor.comp.functor_comp_id -> Functor.Comp.functor_comp_id is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} [AF : Functor.{u1, u2} F] [_inst_5 : LawfulFunctor.{u1, u2} F AF], Eq.{succ (max (succ u1) u2)} (Functor.{u1, u2} (Functor.Comp.{u1, u1, u2} F (id.{succ (succ u1)} Type.{u1}))) (Functor.Comp.functor.{u1, u1, u2} F (id.{succ (succ u1)} Type.{u1}) AF (Applicative.toFunctor.{u1, u1} (id.{succ (succ u1)} Type.{u1}) (Monad.toApplicative.{u1, u1} (id.{succ (succ u1)} Type.{u1}) id.monad.{u1}))) AF
but is expected to have type
  forall {F : Type.{u2} -> Type.{u1}} [AF : Functor.{u2, u1} F] [_inst_5 : LawfulFunctor.{u2, u1} F AF], Eq.{max (succ u1) (succ (succ u2))} (Functor.{u2, u1} (Functor.Comp.{u2, u2, u1} F Id.{u2})) (Functor.Comp.functor.{u2, u2, u1} F Id.{u2} AF (Applicative.toFunctor.{u2, u2} Id.{u2} (Monad.toApplicative.{u2, u2} Id.{u2} Id.instMonadId.{u2}))) AF
Case conversion may be inaccurate. Consider using '#align functor.comp.functor_comp_id Functor.Comp.functor_comp_idₓ'. -/
theorem functor_comp_id {F} [AF : Functor F] [LawfulFunctor F] : @Comp.functor F id _ _ = AF :=
  @Functor.ext F _ AF (@Comp.lawfulFunctor F id _ _ _ _) _ fun α β f x => rfl
#align functor.comp.functor_comp_id Functor.Comp.functor_comp_id

/- warning: functor.comp.functor_id_comp -> Functor.Comp.functor_id_comp is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} [AF : Functor.{u1, u2} F] [_inst_5 : LawfulFunctor.{u1, u2} F AF], Eq.{succ (max (succ u1) u2)} (Functor.{u1, u2} (Functor.Comp.{u2, u1, u2} (id.{succ (succ u2)} Type.{u2}) F)) (Functor.Comp.functor.{u2, u1, u2} (id.{succ (succ u2)} Type.{u2}) F (Applicative.toFunctor.{u2, u2} (id.{succ (succ u2)} Type.{u2}) (Monad.toApplicative.{u2, u2} (id.{succ (succ u2)} Type.{u2}) id.monad.{u2})) AF) AF
but is expected to have type
  forall {F : Type.{u2} -> Type.{u1}} [AF : Functor.{u2, u1} F] [_inst_5 : LawfulFunctor.{u2, u1} F AF], Eq.{max (succ u1) (succ (succ u2))} (Functor.{u2, u1} (Functor.Comp.{u1, u2, u1} Id.{u1} F)) (Functor.Comp.functor.{u1, u2, u1} Id.{u1} F (Applicative.toFunctor.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) AF) AF
Case conversion may be inaccurate. Consider using '#align functor.comp.functor_id_comp Functor.Comp.functor_id_compₓ'. -/
theorem functor_id_comp {F} [AF : Functor F] [LawfulFunctor F] : @Comp.functor id F _ _ = AF :=
  @Functor.ext F _ AF (@Comp.lawfulFunctor id F _ _ _ _) _ fun α β f x => rfl
#align functor.comp.functor_id_comp Functor.Comp.functor_id_comp

end Comp

namespace Comp

open Function hiding comp

open Functor

variable {F : Type u → Type w} {G : Type v → Type u}

variable [Applicative F] [Applicative G]

/-- The `<*>` operation for the composition of applicative functors. -/
protected def seq {α β : Type v} : Comp F G (α → β) → Comp F G α → Comp F G β
  | comp.mk f, comp.mk x => Comp.mk <| (· <*> ·) <$> f <*> x
#align functor.comp.seq Functor.Comp.seqₓ

instance : Pure (Comp F G) :=
  ⟨fun _ x => Comp.mk <| pure <| pure x⟩

instance : Seq (Comp F G) :=
  ⟨fun _ _ f x => Comp.seq f x⟩

#print Functor.Comp.run_pure /-
@[simp]
protected theorem run_pure {α : Type v} : ∀ x : α, (pure x : Comp F G α).run = pure (pure x)
  | _ => rfl
#align functor.comp.run_pure Functor.Comp.run_pure
-/

/- warning: functor.comp.run_seq -> Functor.Comp.run_seq is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] {α : Type.{u2}} {β : Type.{u2}} (f : Functor.Comp.{u1, u2, u3} F G (α -> β)) (x : Functor.Comp.{u1, u2, u3} F G α), Eq.{succ u3} (F (G β)) (Functor.Comp.run.{u1, u2, u3} F G β (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.hasSeq.{u1, u2, u3} F G _inst_1 _inst_2) α β f x)) (Seq.seq.{u1, u3} F (Applicative.toHasSeq.{u1, u3} F _inst_1) (G α) (G β) (Functor.map.{u1, u3} F (Applicative.toFunctor.{u1, u3} F _inst_1) (G (α -> β)) ((G α) -> (G β)) (Seq.seq.{u2, u1} G (Applicative.toHasSeq.{u2, u1} G _inst_2) α β) (Functor.Comp.run.{u1, u2, u3} F G (α -> β) f)) (Functor.Comp.run.{u1, u2, u3} F G α x))
but is expected to have type
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] {α : Type.{u2}} {β : Type.{u2}} (f : Functor.Comp.{u1, u2, u3} F G (α -> β)) (x : Functor.Comp.{u1, u2, u3} F G α), Eq.{succ u3} (F (G β)) (Functor.Comp.run.{u1, u2, u3} F G β (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instSeqComp.{u1, u2, u3} F G _inst_1 _inst_2) α β f (fun (x._@.Mathlib.Control.Functor._hyg.1843 : Unit) => x))) (Seq.seq.{u1, u3} F (Applicative.toSeq.{u1, u3} F _inst_1) (G α) (G β) (Functor.map.{u1, u3} F (Applicative.toFunctor.{u1, u3} F _inst_1) (G (α -> β)) ((G α) -> (G β)) (fun (x._@.Mathlib.Control.Functor._hyg.1854 : G (α -> β)) (x._@.Mathlib.Control.Functor._hyg.1856 : G α) => Seq.seq.{u2, u1} G (Applicative.toSeq.{u2, u1} G _inst_2) α β x._@.Mathlib.Control.Functor._hyg.1854 (fun (x._@.Mathlib.Control.Functor._hyg.1869 : Unit) => x._@.Mathlib.Control.Functor._hyg.1856)) (Functor.Comp.run.{u1, u2, u3} F G (α -> β) f)) (fun (x._@.Mathlib.Control.Functor._hyg.1877 : Unit) => Functor.Comp.run.{u1, u2, u3} F G α x))
Case conversion may be inaccurate. Consider using '#align functor.comp.run_seq Functor.Comp.run_seqₓ'. -/
@[simp]
protected theorem run_seq {α β : Type v} (f : Comp F G (α → β)) (x : Comp F G α) :
    (f <*> x).run = (· <*> ·) <$> f.run <*> x.run :=
  rfl
#align functor.comp.run_seq Functor.Comp.run_seq

instance : Applicative (Comp F G) :=
  { Comp.hasPure with
    map := @Comp.map F G _ _
    seq := @Comp.seq F G _ _ }

end Comp

variable {F : Type u → Type u} [Functor F]

#print Functor.Liftp /-
/-- If we consider `x : F α` to, in some sense, contain values of type `α`,
predicate `liftp p x` holds iff every value contained by `x` satisfies `p`. -/
def Liftp {α : Type u} (p : α → Prop) (x : F α) : Prop :=
  ∃ u : F (Subtype p), Subtype.val <$> u = x
#align functor.liftp Functor.Liftp
-/

#print Functor.Liftr /-
/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`liftr r x y` relates `x` and `y` iff (1) `x` and `y` have the same shape and
(2) we can pair values `a` from `x` and `b` from `y` so that `r a b` holds. -/
def Liftr {α : Type u} (r : α → α → Prop) (x y : F α) : Prop :=
  ∃ u : F { p : α × α // r p.fst p.snd },
    (fun t : { p : α × α // r p.fst p.snd } => t.val.fst) <$> u = x ∧
      (fun t : { p : α × α // r p.fst p.snd } => t.val.snd) <$> u = y
#align functor.liftr Functor.Liftr
-/

#print Functor.supp /-
/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`supp x` is the set of values of type `α` that `x` contains. -/
def supp {α : Type u} (x : F α) : Set α :=
  { y : α | ∀ ⦃p⦄, Liftp p x → p y }
#align functor.supp Functor.supp
-/

#print Functor.of_mem_supp /-
theorem of_mem_supp {α : Type u} {x : F α} {p : α → Prop} (h : Liftp p x) : ∀ y ∈ supp x, p y :=
  fun y hy => hy h
#align functor.of_mem_supp Functor.of_mem_supp
-/

end Functor


import data.real.basic
import data.real.cau_seq
import .nat_digits
import .list

lemma list.abv_sum_le_sum_abv
  {α β} [ring α] [linear_ordered_field β]
  (abv: α → β)
  [habv: is_absolute_value abv]
  (L: list α): abv (L.sum) ≤ (L.map abv).sum :=
  begin
    induction L with hd tl hl,
    { simp [list.map, is_absolute_value.abv_zero abv] },
    { simp [list.map],
      exact calc abv (hd + tl.sum) ≤ abv hd + abv tl.sum : is_absolute_value.abv_add abv hd tl.sum
      ... ≤ abv hd + (list.map abv tl).sum : add_le_add_left hl _,
    }
  end


import category_theory.limits.preserves.basic

open category_theory category_theory.limits

constant bicompletion (𝓒 : Type) [category.{0} 𝓒] : Type 1

namespace bicompletion

variables (𝓒 : Type) [category.{0} 𝓒]

@[instance] protected constant category : category.{0} (bicompletion 𝓒)

constant of_cat : 𝓒 ⥤ bicompletion 𝓒

@[instance] protected constant full : full (of_cat 𝓒)

@[instance] protected constant has_limits : has_limits_of_size.{0 0} (bicompletion 𝓒)

@[instance] protected constant has_colimits : has_colimits_of_size.{0 0} (bicompletion 𝓒)

variables {𝓒} {𝓓 : Type 1} [category.{0} 𝓓] [has_limits_of_size.{0 0} 𝓓]
  [has_colimits_of_size.{0 0} 𝓓] (F : 𝓒 ⥤ 𝓓)

constant extend (F : 𝓒 ⥤ 𝓓) : bicompletion 𝓒 ⥤ 𝓓

namespace extend

@[instance] protected constant preserves_limits :
  preserves_limits_of_size.{0 0} (extend F)

@[instance] protected constant preserves_colimits :
  preserves_colimits_of_size.{0 0} (extend F)

constant commutes : of_cat 𝓒 ⋙ extend F ≅ F

end extend

end bicompletion

@[derive decidable_eq] def free_cat : Type := ℕ

namespace free_cat

def of_nat_obj : ℕ → free_cat := id

@[derive decidable_eq] inductive hom : free_cat → free_cat → Type
| id : Π (A : free_cat), hom A A
| cons : Π (A : free_cat) {B C : free_cat}, ℕ → hom B C → hom A C

def of_nat_hom (A B : ℕ) (f : ℕ) : hom (of_nat_obj A) (of_nat_obj B) :=
hom.cons A f (hom.id B)

def comp : Π {A B C : free_cat} (f : hom A B) (g : hom B C), hom A C
| _ _ _ (hom.id _) g := g
| _ _ _ (hom.cons _ n f) g := hom.cons _ n (comp f g)

@[simp] protected lemma id_comp {A B : free_cat} (f : hom A B) : comp (hom.id A) f = f := rfl

@[simp] protected lemma comp_id {A B : free_cat} (f : hom A B) : comp f (hom.id B) = f :=
by { induction f; simp [*, comp] }

protected lemma comp_assoc {A B C D : free_cat} (f : hom A B) (g : hom B C) (h : hom C D) :
  comp (comp f g) h = comp f (comp g h) :=
by induction f; simp [comp, *]

instance : category_struct free_cat :=
{ hom := hom,
  id := hom.id,
  comp := λ _ _ _, comp }

instance : category free_cat :=
{ id_comp' := by intros; apply free_cat.id_comp,
  comp_id' := by intros; apply free_cat.comp_id,
  assoc' := by intros; apply free_cat.comp_assoc }

def extend (𝓒 : Type*) [category 𝓒] (obj : ℕ → 𝓒) (hom : Π (A B : ℕ) (f : ℕ), (obj A) ⟶ obj B) :
  free_cat ⥤ 𝓒 :=
{ obj := obj,
  map := λ A B f, @free_cat.hom.rec_on
    (λ (A B : ℕ) (f : free_cat.hom A B), obj A ⟶ obj B) A B f
    (λ A, 𝟙 (obj A)) (λ A B C f g ih, hom A B f ≫ ih),
  map_comp' := begin
    intros X Y Z f g,
    dsimp,
    induction f,
    { dsimp,
      rw [category.id_comp],
      refl },
    { dsimp,
      rw [category.assoc],
      rw [← f_ih],
      refl }
  end, }

variables (𝓒 : Type*) [category 𝓒] (obj : ℕ → 𝓒) (hom : Π (A B : ℕ) (f : ℕ), (obj A) ⟶ obj B)

lemma extend_obj (A : ℕ) : (extend 𝓒 obj hom).obj (of_nat_obj A) = obj A := rfl

lemma extend_hom (A B : ℕ) (f : ℕ) : (extend 𝓒 obj hom).map (of_nat_hom A B f) = hom A B f :=
category.comp_id _

-- lemma extend_unique (F : free_cat ⥤ 𝓒) (hobj : ∀ X, F.obj (of_nat_obj X) = obj X)
--   (hhom : ∀ (A B : ℕ) (f : ℕ), F.map (of_nat_hom A B f) = hom A B f) :

end free_cat

inductive pc


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.basic
import Mathlib.PostPort

universes v u l u'

namespace Mathlib

/-!
# Categories

Defines a category, as a type class parametrised by the type of objects.

## Notations

Introduces notations
* `X ⟶ Y` for the morphism spaces,
* `f ≫ g` for composition in the 'arrows' convention.

Users may like to add `f ⊚ g` for composition in the standard convention, using
```lean
local notation f ` ⊚ `:80 g:80 := category.comp g f    -- type as \oo
```
-/

-- The order in this declaration matters: v often needs to be explicitly specified while u often

-- can be omitted

namespace category_theory

/-- A 'notation typeclass' on the way to defining a category. -/
class has_hom (obj : Type u) where
  hom : obj → obj → Type v

infixr:10 " ⟶ " => Mathlib.category_theory.has_hom.hom

/-- A preliminary structure on the way to defining a category,
containing the data, but none of the axioms. -/
class category_struct (obj : Type u) extends has_hom obj where
  id : (X : obj) → X ⟶ X
  comp : {X Y Z : obj} → (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z)

notation:1024 "𝟙" => Mathlib.category_theory.category_struct.id

infixr:80 " ≫ " => Mathlib.category_theory.category_struct.comp

/--
The typeclass `category C` describes morphisms associated to objects of type `C`.
The universe levels of the objects and morphisms are unconstrained, and will often need to be
specified explicitly, as `category.{v} C`. (See also `large_category` and `small_category`.)

See https://stacks.math.columbia.edu/tag/0014.
-/
class category (obj : Type u) extends category_struct obj where
  id_comp' :
    autoParam (∀ {X Y : obj} (f : X ⟶ Y), 𝟙 ≫ f = f)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp_id' :
    autoParam (∀ {X Y : obj} (f : X ⟶ Y), f ≫ 𝟙 = f)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  assoc' :
    autoParam (∀ {W X Y Z : obj} (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z), (f ≫ g) ≫ h = f ≫ g ≫ h)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

-- `restate_axiom` is a command that creates a lemma from a structure field,

-- discarding any auto_param wrappers from the type.

-- (It removes a backtick from the name, if it finds one, and otherwise adds "_lemma".)

@[simp] theorem category.id_comp {obj : Type u} [c : category obj] {X : obj} {Y : obj} (f : X ⟶ Y) :
    𝟙 ≫ f = f :=
  sorry

@[simp] theorem category.comp_id {obj : Type u} [c : category obj] {X : obj} {Y : obj} (f : X ⟶ Y) :
    f ≫ 𝟙 = f :=
  sorry

@[simp] theorem category.assoc {obj : Type u} [c : category obj] {W : obj} {X : obj} {Y : obj}
    {Z : obj} (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z) : (f ≫ g) ≫ h = f ≫ g ≫ h :=
  sorry

/--
A `large_category` has objects in one universe level higher than the universe level of
the morphisms. It is useful for examples such as the category of types, or the category
of groups, etc.
-/
/--
def large_category (C : Type (u + 1)) := category C

A `small_category` has objects and morphisms in the same universe level.
-/
def small_category (C : Type u) := category C

/-- postcompose an equation between morphisms by another morphism -/
theorem eq_whisker {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Y}
    (w : f = g) (h : Y ⟶ Z) : f ≫ h = g ≫ h :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f ≫ h = g ≫ h)) w)) (Eq.refl (g ≫ h))

/-- precompose an equation between morphisms by another morphism -/
theorem whisker_eq {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) {g : Y ⟶ Z}
    {h : Y ⟶ Z} (w : g = h) : f ≫ g = f ≫ h :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f ≫ g = f ≫ h)) w)) (Eq.refl (f ≫ h))

infixr:80 " =≫ " => Mathlib.category_theory.eq_whisker

infixr:80 " ≫= " => Mathlib.category_theory.whisker_eq

theorem eq_of_comp_left_eq {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} {g : X ⟶ Y}
    (w : ∀ {Z : C} (h : Y ⟶ Z), f ≫ h = g ≫ h) : f = g :=
  sorry

theorem eq_of_comp_right_eq {C : Type u} [category C] {Y : C} {Z : C} {f : Y ⟶ Z} {g : Y ⟶ Z}
    (w : ∀ {X : C} (h : X ⟶ Y), h ≫ f = h ≫ g) : f = g :=
  sorry

theorem eq_of_comp_left_eq' {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) (g : X ⟶ Y)
    (w : (fun {Z : C} (h : Y ⟶ Z) => f ≫ h) = fun {Z : C} (h : Y ⟶ Z) => g ≫ h) : f = g :=
  sorry

theorem eq_of_comp_right_eq' {C : Type u} [category C] {Y : C} {Z : C} (f : Y ⟶ Z) (g : Y ⟶ Z)
    (w : (fun {X : C} (h : X ⟶ Y) => h ≫ f) = fun {X : C} (h : X ⟶ Y) => h ≫ g) : f = g :=
  sorry

theorem id_of_comp_left_id {C : Type u} [category C] {X : C} (f : X ⟶ X)
    (w : ∀ {Y : C} (g : X ⟶ Y), f ≫ g = g) : f = 𝟙 :=
  sorry

theorem id_of_comp_right_id {C : Type u} [category C] {X : C} (f : X ⟶ X)
    (w : ∀ {Y : C} (g : Y ⟶ X), g ≫ f = g) : f = 𝟙 :=
  sorry

theorem comp_dite {C : Type u} [category C] {P : Prop} [Decidable P] {X : C} {Y : C} {Z : C}
    (f : X ⟶ Y) (g : P → (Y ⟶ Z)) (g' : ¬P → (Y ⟶ Z)) :
    (f ≫ dite P (fun (h : P) => g h) fun (h : ¬P) => g' h) =
        dite P (fun (h : P) => f ≫ g h) fun (h : ¬P) => f ≫ g' h :=
  sorry

theorem dite_comp {C : Type u} [category C] {P : Prop} [Decidable P] {X : C} {Y : C} {Z : C}
    (f : P → (X ⟶ Y)) (f' : ¬P → (X ⟶ Y)) (g : Y ⟶ Z) :
    (dite P (fun (h : P) => f h) fun (h : ¬P) => f' h) ≫ g =
        dite P (fun (h : P) => f h ≫ g) fun (h : ¬P) => f' h ≫ g :=
  sorry

/--
A morphism `f` is an epimorphism if it can be "cancelled" when precomposed:
`f ≫ g = f ≫ h` implies `g = h`.

See https://stacks.math.columbia.edu/tag/003B.
-/
class epi {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  left_cancellation : ∀ {Z : C} (g h : Y ⟶ Z), f ≫ g = f ≫ h → g = h

/--
A morphism `f` is a monomorphism if it can be "cancelled" when postcomposed:
`g ≫ f = h ≫ f` implies `g = h`.

See https://stacks.math.columbia.edu/tag/003B.
-/
class mono {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  right_cancellation : ∀ {Z : C} (g h : Z ⟶ X), g ≫ f = h ≫ f → g = h

protected instance category_struct.id.epi {C : Type u} [category C] (X : C) : epi 𝟙 :=
  epi.mk
    fun (Z : C) (g h : X ⟶ Z) (w : 𝟙 ≫ g = 𝟙 ≫ h) =>
      eq.mpr (id (Eq.refl (g = h)))
        (eq.mp
          ((fun (a a_1 : X ⟶ Z) (e_1 : a = a_1) (ᾰ ᾰ_1 : X ⟶ Z) (e_2 : ᾰ = ᾰ_1) =>
              congr (congr_arg Eq e_1) e_2)
            (𝟙 ≫ g) g (category.id_comp g) (𝟙 ≫ h) h (category.id_comp h))
          w)

protected instance category_struct.id.mono {C : Type u} [category C] (X : C) : mono 𝟙 :=
  mono.mk
    fun (Z : C) (g h : Z ⟶ X) (w : g ≫ 𝟙 = h ≫ 𝟙) =>
      eq.mpr (id (Eq.refl (g = h)))
        (eq.mp
          ((fun (a a_1 : Z ⟶ X) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ X) (e_2 : ᾰ = ᾰ_1) =>
              congr (congr_arg Eq e_1) e_2)
            (g ≫ 𝟙) g (category.comp_id g) (h ≫ 𝟙) h (category.comp_id h))
          w)

theorem cancel_epi {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [epi f] {g : Y ⟶ Z}
    {h : Y ⟶ Z} : f ≫ g = f ≫ h ↔ g = h :=
  { mp := fun (p : f ≫ g = f ≫ h) => epi.left_cancellation g h p,
    mpr := fun (a : g = h) => Eq._oldrec (Eq.refl (f ≫ g)) a }

theorem cancel_mono {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [mono f]
    {g : Z ⟶ X} {h : Z ⟶ X} : g ≫ f = h ≫ f ↔ g = h :=
  { mp := fun (p : g ≫ f = h ≫ f) => mono.right_cancellation g h p,
    mpr := fun (a : g = h) => Eq._oldrec (Eq.refl (g ≫ f)) a }

theorem cancel_epi_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [epi f] {h : Y ⟶ Y} :
    f ≫ h = f ↔ h = 𝟙 :=
  sorry

theorem cancel_mono_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] {g : X ⟶ X} :
    g ≫ f = f ↔ g = 𝟙 :=
  sorry

theorem epi_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [epi f] (g : Y ⟶ Z)
    [epi g] : epi (f ≫ g) :=
  sorry

theorem mono_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [mono f] (g : Y ⟶ Z)
    [mono g] : mono (f ≫ g) :=
  sorry

theorem mono_of_mono {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)
    [mono (f ≫ g)] : mono f :=
  sorry

theorem mono_of_mono_fac {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : Y ⟶ Z}
    {h : X ⟶ Z} [mono h] (w : f ≫ g = h) : mono f :=
  Eq._oldrec (mono_of_mono f g) w _inst_2

theorem epi_of_epi {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)
    [epi (f ≫ g)] : epi g :=
  sorry

theorem epi_of_epi_fac {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : Y ⟶ Z}
    {h : X ⟶ Z} [epi h] (w : f ≫ g = h) : epi g :=
  Eq._oldrec (epi_of_epi f g) w _inst_2

protected instance ulift_category (C : Type u) [category C] : category (ulift C) := category.mk

-- We verify that this previous instance can lift small categories to large categories.

end category_theory

/-!
We now put a category instance on any preorder.

Because we do not allow the morphisms of a category to live in `Prop`,
unfortunately we need to use `plift` and `ulift` when defining the morphisms.

As convenience functions, we provide `hom_of_le` and `le_of_hom` to wrap and unwrap inequalities.
-/

namespace preorder

/--
The category structure coming from a preorder. There is a morphism `X ⟶ Y` if and only if `X ≤ Y`.

Because we don't allow morphisms to live in `Prop`,
we have to define `X ⟶ Y` as `ulift (plift (X ≤ Y))`.
See `category_theory.hom_of_le` and `category_theory.le_of_hom`.

See https://stacks.math.columbia.edu/tag/00D3.
-/
protected instance small_category (α : Type u) [preorder α] : category_theory.small_category α :=
  category_theory.category.mk

end preorder

namespace category_theory

/--
Express an inequality as a morphism in the corresponding preorder category.
-/
def hom_of_le {α : Type u} [preorder α] {U : α} {V : α} (h : U ≤ V) : U ⟶ V := ulift.up (plift.up h)

/--
Extract the underlying inequality from a morphism in a preorder category.
-/
theorem le_of_hom {α : Type u} [preorder α] {U : α} {V : α} (h : U ⟶ V) : U ≤ V :=
  plift.down (ulift.down h)

end category_theory

/--
Many proofs in the category theory library use the `dsimp, simp` pattern,
end Mathlib


import order.basic
import order.monotone

lemma aux
  {P : ℕ → ℕ → Prop}
  (h : ∀ n, ∀ N, ∃ k > N, P n k)
  : ∃ φ : ℕ → ℕ, strict_mono φ ∧ ∀ n, P n (φ n) :=
begin
  choose u hu hu' using h,
  use (λ n, nat.rec_on n (u 0 0) (λ n v, u (n+1) v) : ℕ → ℕ),
  split,
  { apply strict_mono_nat_of_lt_succ,
    intro n,
    apply hu },
  { intros n,
    cases n ; simp [hu'] },
end

lemma aux'
  {P : ℕ → ℕ → Prop}
  (h : ∀ n, ∀ N, ∃ k ≥ N, P n k)
  : ∃ φ : ℕ → ℕ, strict_mono φ ∧ ∀ n, P n (φ n) :=
begin
  apply aux,
  intros n N,
  rcases h n (N+1) with ⟨k, hk, hk'⟩,
  use k; tauto
end

lemma aux''
  {P : ℕ → ℕ → Prop}
  (h : ∀ n, ∃ N, ∀ k ≥ N, P n k)
  : ∃ φ : ℕ → ℕ, strict_mono φ ∧ ∀ n, P n (φ n) :=
begin
  apply aux',
  intros n N,
  cases h n with N₀ hN₀,
  exact ⟨max N N₀, le_max_left _ _, hN₀ _ $ le_max_right _ _⟩,
end


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import category_theory.opposites
import for_mathlib.category_theory.arrow
import for_mathlib.category_theory.comma_op
import category_theory.preadditive.projective
import for_mathlib.category_theory.morphism_property_misc

open category_theory
open category_theory.category
open opposite

variables {C D : Type*} [category C] [category D] (G : C ⥤ D)

namespace category_theory

def is_retract (X Y : C) : Prop := ∃ (s : X ⟶ Y) (r : Y ⟶ X), s ≫ r = 𝟙 X

namespace is_retract

def mk {X Y : C} (s : X ⟶ Y) (r : Y ⟶ X) (h : s ≫ r = 𝟙 X) : is_retract X Y := ⟨s, r, h⟩

lemma iff_op (X Y : C) : is_retract X Y ↔ is_retract (opposite.op X) (opposite.op Y) :=
begin
  split,
  { intro h,
    rcases h with ⟨s, r, fac⟩,
    use [r.op, s.op],
    exact congr_arg (λ (φ : _ ⟶ _), φ.op) fac, },
  { intro h,
    rcases h with ⟨s, r, fac⟩,
    use [r.unop, s.unop],
    exact congr_arg (λ (φ : _ ⟶ _), φ.unop) fac, },
end

lemma imp_of_isos {X Y X' Y' : C} (e₁ : X ≅ X') (e₂ : Y ≅ Y')
  (h : is_retract X Y) : is_retract X' Y' :=
begin
  rcases h with ⟨s, p, r⟩,
  use [e₁.inv ≫ s ≫ e₂.hom, e₂.inv ≫ p ≫ e₁.hom],
  slice_lhs 3 4 { rw iso.hom_inv_id, },
  erw id_comp,
  slice_lhs 2 3 { rw r, },
  erw [id_comp, iso.inv_hom_id],
end

lemma iff_of_isos {X Y X' Y' : C} (e₁ : X ≅ X') (e₂ : Y ≅ Y') :
  is_retract X Y ↔ is_retract X' Y' :=
begin
  split,
  { exact imp_of_isos e₁ e₂, },
  { exact imp_of_isos e₁.symm e₂.symm, },
end

lemma imp_of_functor (X Y : C) (h : is_retract X Y) : is_retract (G.obj X) (G.obj Y) :=
begin
  rcases h with ⟨s, p, r⟩,
  use [G.map s, G.map p],
  rw [← G.map_comp, r, G.map_id],
end

lemma iff_of_is_equivalence (X Y : C) [is_equivalence G] :
  is_retract X Y ↔ is_retract (G.obj X) (G.obj Y) :=
begin
  split,
  { apply imp_of_functor, },
  { intro h,
    have e : is_equivalence G := infer_instance,
    erw iff_of_isos (e.unit_iso.app X) (e.unit_iso.app Y),
    convert imp_of_functor e.inverse _ _ h, }
end

end is_retract

def is_retract_hom {X₁ X₂ Y₁ Y₂ : C} (x : X₁ ⟶ X₂) (y : Y₁ ⟶ Y₂) := is_retract (arrow.mk x) (arrow.mk y)

namespace is_retract_hom

lemma iff_op {X₁ X₂ Y₁ Y₂ : C} (x : X₁ ⟶ X₂) (y : Y₁ ⟶ Y₂) :
  is_retract_hom x y ↔ is_retract_hom x.op y.op :=
begin
  calc is_retract (arrow.mk x) (arrow.mk y) ↔ is_retract (op (arrow.mk x)) (op (arrow.mk y)) :
    is_retract.iff_op (arrow.mk x) (arrow.mk y)
  ... ↔ is_retract (arrow.mk x.op) (arrow.mk y.op) : _,
  rw is_retract.iff_of_is_equivalence (equivalence_arrow_op C).functor,
  congr',
end

lemma iff_unop {X₁ X₂ Y₁ Y₂ : Cᵒᵖ} (x : X₁ ⟶ X₂) (y : Y₁ ⟶ Y₂) :
  is_retract_hom x y ↔ is_retract_hom x.unop y.unop :=
(iff_op x.unop y.unop).symm

lemma op {X₁ X₂ Y₁ Y₂ : C} {x : X₁ ⟶ X₂} {y : Y₁ ⟶ Y₂}
  (hxy : is_retract_hom x y) : is_retract_hom x.op y.op :=
(iff_op x y).mp hxy

lemma unop {X₁ X₂ Y₁ Y₂ : Cᵒᵖ} {x : X₁ ⟶ X₂} {y : Y₁ ⟶ Y₂}
  (hxy : is_retract_hom x y) : is_retract_hom x.unop y.unop :=
(iff_op x.unop y.unop).mpr hxy

lemma imp_of_functor {X₁ X₂ Y₁ Y₂ : C} {x : X₁ ⟶ X₂} {y : Y₁ ⟶ Y₂} (h : is_retract_hom x y) :
  is_retract_hom (G.map x) (G.map y) :=
is_retract.imp_of_functor G.map_arrow _ _ h

end is_retract_hom

namespace morphism_property

variables (P : morphism_property C) {P' : morphism_property Cᵒᵖ}

def is_stable_by_retract : Prop :=
∀ ⦃X₁ X₂ Y₁ Y₂ : C⦄ (x : X₁ ⟶ X₂) (y : Y₁ ⟶ Y₂)
  (hxy : is_retract_hom x y) (hx : P y), P x

namespace is_stable_by_retract

variable {P}

lemma op (h : is_stable_by_retract P) :
  is_stable_by_retract P.op :=
λ X₁ X₂ Y₁ Y₂ x y hxy hy, h x.unop y.unop hxy.unop hy

lemma unop (h : is_stable_by_retract P') :
  is_stable_by_retract P'.unop :=
λ X₁ X₂ Y₁ Y₂ x y hxy hy, h x.op y.op hxy.op hy

variables (P P')

lemma iff_op : is_stable_by_retract P ↔ is_stable_by_retract P.op :=
begin
  split,
  { intro h,
    exact h.op, },
  { intro h,
    simpa only [P.unop_op] using h.unop, },
end

lemma iff_unop : is_stable_by_retract P' ↔ is_stable_by_retract P'.unop :=
(iff_op P'.unop).symm

lemma of_inter {P₁ P₂ : morphism_property C} (h₁ : P₁.is_stable_by_retract)
  (h₂ : P₂.is_stable_by_retract) : (P₁ ∩ P₂).is_stable_by_retract :=
λ X₁ X₂ Y₁ Y₂ x y hxy hy, ⟨h₁ x y hxy hy.1, h₂ x y hxy hy.2⟩

lemma for_isomorphisms : (isomorphisms C).is_stable_by_retract :=
λ X₁ X₂ Y₁ Y₂ x y hxy hy,
begin
  haveI : is_iso y := hy,
  rcases hxy with ⟨s, r, fac⟩,
  use s.right ≫ inv y ≫ r.left,
  have hs := s.w,
  have hr := r.w,
  have fac₁ := arrow.hom.congr_left fac,
  have fac₂ := arrow.hom.congr_right fac,
  dsimp at hs hr fac₁ fac₂ ⊢,
  split,
  { slice_lhs 1 2 { rw ← hs, },
    slice_lhs 2 3 { rw is_iso.hom_inv_id, },
    rw [id_comp, fac₁], },
  { slice_lhs 3 4 { rw hr, },
    slice_lhs 2 3 { rw is_iso.inv_hom_id, },
    rw [id_comp, fac₂], },
end

lemma for_monomorphisms : (monomorphisms C).is_stable_by_retract :=
λ X₁ X₂ Y₁ Y₂ x y hxy hy, ⟨λ Z g g' hgg', begin
  haveI : mono y := hy,
  rcases hxy with ⟨s, r, fac⟩,
  haveI : is_split_mono s.left := is_split_mono.mk' ⟨r.left, arrow.hom.congr_left fac⟩,
  have hs := s.w,
  dsimp at hs,
  rw [← cancel_mono s.left, ← cancel_mono y,
    assoc, assoc, hs, ← assoc, ← assoc, hgg'],
end⟩

lemma for_epimorphisms : (epimorphisms C).is_stable_by_retract :=
by simpa only [unop_monomorphisms] using (@for_monomorphisms Cᵒᵖ _).unop

lemma inverse_image {W : morphism_property D} (h : W.is_stable_by_retract) (F : C ⥤ D) :
  (W.inverse_image F).is_stable_by_retract := λ X₁ X₂ Y₁ Y₂ x y hxy hy,
h _ _ (is_retract_hom.imp_of_functor F hxy) hy

end is_stable_by_retract

end morphism_property

namespace projective

lemma of_retract {X Y : C} (hXY : is_retract X Y) (hY : projective Y) : projective X :=
⟨λ E Z f e, begin
  introI,
  rcases hXY with ⟨s, r, fac⟩,
  use s ≫ projective.factor_thru (r ≫ f) e,
  rw [assoc, factor_thru_comp, ← assoc, fac, id_comp],
end⟩

end projective

end category_theory


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebraic_geometry.presheafed_space
import topology.category.Top.limits
import topology.sheaves.limits
import category_theory.limits.concrete_category

/-!
# `PresheafedSpace C` has colimits.

If `C` has limits, then the category `PresheafedSpace C` has colimits,
and the forgetful functor to `Top` preserves these colimits.

When restricted to a diagram where the underlying continuous maps are open embeddings,
this says that we can glue presheaved spaces.

Given a diagram `F : J ⥤ PresheafedSpace C`,
we first build the colimit of the underlying topological spaces,
as `colimit (F ⋙ PresheafedSpace.forget C)`. Call that colimit space `X`.

Our strategy is to push each of the presheaves `F.obj j`
forward along the continuous map `colimit.ι (F ⋙ PresheafedSpace.forget C) j` to `X`.
Since pushforward is functorial, we obtain a diagram `J ⥤ (presheaf C X)ᵒᵖ`
of presheaves on a single space `X`.
(Note that the arrows now point the other direction,
because this is the way `PresheafedSpace C` is set up.)

The limit of this diagram then constitutes the colimit presheaf.
-/

noncomputable theory

universes v' u' v u

open category_theory
open Top
open Top.presheaf
open topological_space
open opposite
open category_theory.category
open category_theory.limits
open category_theory.functor

variables {J : Type u'} [category.{v'} J]
variables {C : Type u} [category.{v} C]

namespace algebraic_geometry

namespace PresheafedSpace

local attribute [simp] eq_to_hom_map

@[simp]
lemma map_id_c_app (F : J ⥤ PresheafedSpace.{v} C) (j) (U) :
  (F.map (𝟙 j)).c.app (op U) =
    (pushforward.id (F.obj j).presheaf).inv.app (op U) ≫
      (pushforward_eq (by { simp, refl }) (F.obj j).presheaf).hom.app (op U) :=
begin
  cases U,
  dsimp,
  simp [PresheafedSpace.congr_app (F.map_id j)],
  refl,
end

@[simp]
lemma map_comp_c_app (F : J ⥤ PresheafedSpace.{v} C) {j₁ j₂ j₃} (f : j₁ ⟶ j₂) (g : j₂ ⟶ j₃) (U) :
  (F.map (f ≫ g)).c.app (op U) =
    (F.map g).c.app (op U) ≫
    (pushforward_map (F.map g).base (F.map f).c).app (op U) ≫
    (pushforward.comp (F.obj j₁).presheaf (F.map f).base (F.map g).base).inv.app (op U) ≫
    (pushforward_eq (by { rw F.map_comp, refl }) _).hom.app _ :=
begin
  cases U,
  dsimp,
  simp only [PresheafedSpace.congr_app (F.map_comp f g)],
  dsimp, simp, dsimp, simp, -- See note [dsimp, simp]
end

/--
Given a diagram of `PresheafedSpace C`s, its colimit is computed by pushing the sheaves onto
the colimit of the underlying spaces, and taking componentwise limit.
This is the componentwise diagram for an open set `U` of the colimit of the underlying spaces.
-/
@[simps]
def componentwise_diagram (F : J ⥤ PresheafedSpace.{v} C)
  [has_colimit F] (U : opens (limits.colimit F).carrier) : Jᵒᵖ ⥤ C :=
{ obj := λ j, (F.obj (unop j)).presheaf.obj (op ((opens.map (colimit.ι F (unop j)).base).obj U)),
  map := λ j k f, (F.map f.unop).c.app _ ≫ (F.obj (unop k)).presheaf.map
    (eq_to_hom (by { rw [← colimit.w F f.unop, comp_base], refl })),
  map_comp' := λ i j k f g,
  begin
    cases U,
    dsimp,
    simp_rw [map_comp_c_app, category.assoc],
    congr' 1,
    rw [Top.presheaf.pushforward.comp_inv_app, Top.presheaf.pushforward_eq_hom_app,
      category_theory.nat_trans.naturality_assoc, Top.presheaf.pushforward_map_app],
    congr' 1,
    rw [category.id_comp, ← (F.obj (unop k)).presheaf.map_comp],
    erw ← (F.obj (unop k)).presheaf.map_comp,
    congr
  end }

variable [has_colimits_of_shape J Top.{v}]

/--
Given a diagram of presheafed spaces,
we can push all the presheaves forward to the colimit `X` of the underlying topological spaces,
obtaining a diagram in `(presheaf C X)ᵒᵖ`.
-/
@[simps]
def pushforward_diagram_to_colimit (F : J ⥤ PresheafedSpace.{v} C) :
  J ⥤ (presheaf C (colimit (F ⋙ PresheafedSpace.forget C)))ᵒᵖ :=
{ obj := λ j, op ((colimit.ι (F ⋙ PresheafedSpace.forget C) j) _* (F.obj j).presheaf),
  map := λ j j' f,
  (pushforward_map (colimit.ι (F ⋙ PresheafedSpace.forget C) j') (F.map f).c ≫
    (pushforward.comp (F.obj j).presheaf ((F ⋙ PresheafedSpace.forget C).map f)
      (colimit.ι (F ⋙ PresheafedSpace.forget C) j')).inv ≫
    (pushforward_eq (colimit.w (F ⋙ PresheafedSpace.forget C) f) (F.obj j).presheaf).hom).op,
  map_id' := λ j,
  begin
    apply (op_equiv _ _).injective,
    ext U,
    induction U using opposite.rec,
    cases U,
    dsimp, simp, dsimp, simp,
  end,
  map_comp' := λ j₁ j₂ j₃ f g,
  begin
    apply (op_equiv _ _).injective,
    ext U,
    dsimp,
    simp only [map_comp_c_app, id.def, eq_to_hom_op, pushforward_map_app, eq_to_hom_map, assoc,
      id_comp, pushforward.comp_inv_app, pushforward_eq_hom_app],
    dsimp,
    simp only [eq_to_hom_trans, id_comp],
    congr' 1,
    -- The key fact is `(F.map f).c.congr`,
    -- which allows us in rewrite in the argument of `(F.map f).c.app`.
    rw (F.map f).c.congr,
    -- Now we pick up the pieces. First, we say what we want to replace that open set by:
    swap 3,
    refine op ((opens.map (colimit.ι (F ⋙ PresheafedSpace.forget C) j₂)).obj (unop U)),
    -- Now we show the open sets are equal.
    swap 2,
    { apply unop_injective,
      rw ←opens.map_comp_obj,
      congr,
      exact colimit.w (F ⋙ PresheafedSpace.forget C) g, },
    -- Finally, the original goal is now easy:
    swap 2,
    { simp, refl, },
  end, }

variables [∀ X : Top.{v}, has_limits_of_shape Jᵒᵖ (X.presheaf C)]

/--
Auxiliary definition for `PresheafedSpace.has_colimits`.
-/
def colimit (F : J ⥤ PresheafedSpace.{v} C) : PresheafedSpace C :=
{ carrier := colimit (F ⋙ PresheafedSpace.forget C),
  presheaf := limit (pushforward_diagram_to_colimit F).left_op, }

@[simp] lemma colimit_carrier (F : J ⥤ PresheafedSpace.{v} C) :
  (colimit F).carrier = limits.colimit (F ⋙ PresheafedSpace.forget C) := rfl

@[simp] lemma colimit_presheaf (F : J ⥤ PresheafedSpace.{v} C) :
  (colimit F).presheaf = limit (pushforward_diagram_to_colimit F).left_op := rfl

/--
Auxiliary definition for `PresheafedSpace.has_colimits`.
-/
@[simps]
def colimit_cocone (F : J ⥤ PresheafedSpace.{v} C) : cocone F :=
{ X := colimit F,
  ι :=
  { app := λ j,
    { base := colimit.ι (F ⋙ PresheafedSpace.forget C) j,
      c := limit.π _ (op j), },
    naturality' := λ j j' f,
    begin
      fapply PresheafedSpace.ext,
      { ext x,
        exact colimit.w_apply (F ⋙ PresheafedSpace.forget C) f x, },
      { ext U,
        induction U using opposite.rec,
        cases U,
        dsimp,
        simp only [PresheafedSpace.id_c_app, eq_to_hom_op, eq_to_hom_map, assoc,
          pushforward.comp_inv_app],
        rw ← congr_arg nat_trans.app (limit.w (pushforward_diagram_to_colimit F).left_op f.op),
        dsimp,
        simp only [eq_to_hom_op, eq_to_hom_map, assoc, id_comp, pushforward.comp_inv_app],
        congr,
        dsimp,
        simp only [id_comp],
        simpa, }
    end, }, }

variables [has_limits_of_shape Jᵒᵖ C]

namespace colimit_cocone_is_colimit

/--
Auxiliary definition for `PresheafedSpace.colimit_cocone_is_colimit`.
-/
def desc_c_app (F : J ⥤ PresheafedSpace.{v} C) (s : cocone F) (U : (opens ↥(s.X.carrier))ᵒᵖ) :
  s.X.presheaf.obj U ⟶
    (colimit.desc (F ⋙ PresheafedSpace.forget C)
         ((PresheafedSpace.forget C).map_cocone s) _*
       limit (pushforward_diagram_to_colimit F).left_op).obj
      U :=
begin
  refine
    limit.lift _ { X := s.X.presheaf.obj U, π := { app := λ j, _, naturality' := λ j j' f, _, }} ≫
      (limit_obj_iso_limit_comp_evaluation _ _).inv,
  -- We still need to construct the `app` and `naturality'` fields omitted above.
  { refine (s.ι.app (unop j)).c.app U ≫ (F.obj (unop j)).presheaf.map (eq_to_hom _),
    dsimp,
    rw ←opens.map_comp_obj,
    simp, },
  { rw (PresheafedSpace.congr_app (s.w f.unop).symm U),
    dsimp,
    have w := functor.congr_obj (congr_arg opens.map
      (colimit.ι_desc ((PresheafedSpace.forget C).map_cocone s) (unop j))) (unop U),
    simp only [opens.map_comp_obj_unop] at w,
    replace w := congr_arg op w,
    have w' := nat_trans.congr (F.map f.unop).c w,
    rw w',
    dsimp, simp, dsimp, simp, },
end

lemma desc_c_naturality (F : J ⥤ PresheafedSpace.{v} C) (s : cocone F)
  {U V : (opens ↥(s.X.carrier))ᵒᵖ} (i : U ⟶ V) :
  s.X.presheaf.map i ≫ desc_c_app F s V =
  desc_c_app F s U ≫ (colimit.desc (F ⋙ forget C)
    ((forget C).map_cocone s) _* (colimit_cocone F).X.presheaf).map i :=
begin
  dsimp [desc_c_app],
  ext,
  simp only [limit.lift_π, nat_trans.naturality, limit.lift_π_assoc, eq_to_hom_map, assoc,
    pushforward_obj_map, nat_trans.naturality_assoc, op_map,
    limit_obj_iso_limit_comp_evaluation_inv_π_app_assoc,
    limit_obj_iso_limit_comp_evaluation_inv_π_app],
  dsimp,
  have w := functor.congr_hom (congr_arg opens.map
    (colimit.ι_desc ((PresheafedSpace.forget C).map_cocone s) (unop j))) (i.unop),
  simp only [opens.map_comp_map] at w,
  replace w := congr_arg quiver.hom.op w,
  rw w,
  dsimp, simp,
end

/--
Auxiliary definition for `PresheafedSpace.colimit_cocone_is_colimit`.
-/
def desc (F : J ⥤ PresheafedSpace.{v} C) (s : cocone F) : colimit F ⟶ s.X :=
{ base := colimit.desc (F ⋙ PresheafedSpace.forget C) ((PresheafedSpace.forget C).map_cocone s),
  c :=
  { app := λ U, desc_c_app F s U,
    naturality' := λ U V i, desc_c_naturality F s i } }

lemma desc_fac  (F : J ⥤ PresheafedSpace.{v} C) (s : cocone F) (j : J) :
  (colimit_cocone F).ι.app j ≫ desc F s = s.ι.app j :=
begin
  fapply PresheafedSpace.ext,
  { simp [desc] },
  { ext,
    dsimp [desc, desc_c_app],
    simpa }
end

end colimit_cocone_is_colimit

open colimit_cocone_is_colimit

/--
Auxiliary definition for `PresheafedSpace.has_colimits`.
-/
def colimit_cocone_is_colimit (F : J ⥤ PresheafedSpace.{v} C) : is_colimit (colimit_cocone F) :=
{ desc := λ s, desc F s,
  fac' := λ s, desc_fac F s,
  uniq' := λ s m w,
  begin
    -- We need to use the identity on the continuous maps twice, so we prepare that first:
    have t : m.base = colimit.desc (F ⋙ PresheafedSpace.forget C)
                        ((PresheafedSpace.forget C).map_cocone s),
    { apply category_theory.limits.colimit.hom_ext, intros j,
      apply continuous_map.ext, intros x,
      dsimp,
      simp only [colimit.ι_desc_apply, map_cocone_ι_app],
      rw ← w j,
      simp, },
    fapply PresheafedSpace.ext, -- could `ext` please not reorder goals?
    { exact t, },
    { ext U j, dsimp [desc, desc_c_app],
      simp only [limit.lift_π, eq_to_hom_op, eq_to_hom_map, assoc,
        limit_obj_iso_limit_comp_evaluation_inv_π_app],
      rw PresheafedSpace.congr_app (w (unop j)).symm U,
      dsimp,
      have w := congr_arg op (functor.congr_obj (congr_arg opens.map t) (unop U)),
      rw nat_trans.congr (limit.π (pushforward_diagram_to_colimit F).left_op j) w,
      simp }
  end, }

instance : has_colimits_of_shape J (PresheafedSpace.{v} C) :=
{ has_colimit := λ F, has_colimit.mk
  { cocone     := colimit_cocone F,
    is_colimit := colimit_cocone_is_colimit F } }

instance : preserves_colimits_of_shape J (PresheafedSpace.forget C) :=
{ preserves_colimit := λ F, preserves_colimit_of_preserves_colimit_cocone
  (colimit_cocone_is_colimit F)
  begin
    apply is_colimit.of_iso_colimit (colimit.is_colimit _),
    fapply cocones.ext,
    { refl, },
    { intro j, dsimp, simp, }
  end }

/--
When `C` has limits, the category of presheaved spaces with values in `C` itself has colimits.
-/
instance [has_limits C] : has_colimits (PresheafedSpace.{v} C) :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone     := colimit_cocone F,
      is_colimit := colimit_cocone_is_colimit F } } }

/--
The underlying topological space of a colimit of presheaved spaces is
the colimit of the underlying topological spaces.
-/
instance forget_preserves_colimits [has_limits C] : preserves_colimits (PresheafedSpace.forget C) :=
{ preserves_colimits_of_shape := λ J 𝒥, by exactI
  { preserves_colimit := λ F, preserves_colimit_of_preserves_colimit_cocone
    (colimit_cocone_is_colimit F)
    begin
      apply is_colimit.of_iso_colimit (colimit.is_colimit _),
      fapply cocones.ext,
      { refl, },
      { intro j, dsimp, simp, }
    end } }

/--
The components of the colimit of a diagram of `PresheafedSpace C` is obtained
via taking componentwise limits.
-/
def colimit_presheaf_obj_iso_componentwise_limit (F : J ⥤ PresheafedSpace.{v} C) [has_colimit F]
  (U : opens (limits.colimit F).carrier) :
  (limits.colimit F).presheaf.obj (op U) ≅ limit (componentwise_diagram F U) :=
begin
  refine ((sheaf_iso_of_iso (colimit.iso_colimit_cocone
    ⟨_, colimit_cocone_is_colimit F⟩).symm).app (op U)).trans _,
  refine (limit_obj_iso_limit_comp_evaluation _ _).trans (limits.lim.map_iso _),
  fapply nat_iso.of_components,
  { intro X,
    refine ((F.obj (unop X)).presheaf.map_iso (eq_to_iso _)),
    dsimp only [functor.op, unop_op, opens.map],
    congr' 2,
    rw set.preimage_preimage,
    simp_rw ← comp_app,
    congr' 2,
    exact ι_preserves_colimits_iso_inv (forget C) F (unop X) },
  { intros X Y f,
    change ((F.map f.unop).c.app _ ≫ _ ≫ _) ≫ (F.obj (unop Y)).presheaf.map _ = _ ≫ _,
    rw Top.presheaf.pushforward.comp_inv_app,
    erw category.id_comp,
    rw category.assoc,
    erw [← (F.obj (unop Y)).presheaf.map_comp, (F.map f.unop).c.naturality_assoc,
      ← (F.obj (unop Y)).presheaf.map_comp],
    congr }
end

@[simp]
lemma colimit_presheaf_obj_iso_componentwise_limit_inv_ι_app (F : J ⥤ PresheafedSpace.{v} C)
  (U : opens (limits.colimit F).carrier) (j : J) :
  (colimit_presheaf_obj_iso_componentwise_limit F U).inv ≫ (colimit.ι F j).c.app (op U) =
    limit.π _ (op j) :=
begin
  delta colimit_presheaf_obj_iso_componentwise_limit,
  rw [iso.trans_inv, iso.trans_inv, iso.app_inv, sheaf_iso_of_iso_inv, pushforward_to_of_iso_app,
    congr_app (iso.symm_inv _)],
  simp_rw category.assoc,
  rw [← functor.map_comp_assoc, nat_trans.naturality],
  erw ← comp_c_app_assoc,
  rw congr_app (colimit.iso_colimit_cocone_ι_hom _ _),
  simp_rw category.assoc,
  erw [limit_obj_iso_limit_comp_evaluation_inv_π_app_assoc, lim_map_π_assoc],
  convert category.comp_id _,
  erw ← (F.obj j).presheaf.map_id,
  iterate 2 { erw ← (F.obj j).presheaf.map_comp },
  congr
end

@[simp]
lemma colimit_presheaf_obj_iso_componentwise_limit_hom_π (F : J ⥤ PresheafedSpace.{v} C)
  (U : opens (limits.colimit F).carrier) (j : J) :
    (colimit_presheaf_obj_iso_componentwise_limit F U).hom ≫ limit.π _ (op j) =
      (colimit.ι F j).c.app (op U) :=
by rw [← iso.eq_inv_comp, colimit_presheaf_obj_iso_componentwise_limit_inv_ι_app]

end PresheafedSpace

end algebraic_geometry


import hilbert.wr.ki_bot
import hilbert.wr.proofs.ki

namespace clfrags
    namespace hilbert
        namespace wr
            namespace ki_bot

                theorem  kib₁_ki {a b c d e : Prop} (h₁ : ki d e (ki b a bot)) : ki d e (ki b a c) :=
                    have h₂ : ki d e (ki d a bot), from ki.ki₉ h₁,
                    have h₃ : ki d (ki e e a) bot, from ki.ki₅ h₂,
                    have h₄ : ki d (ki e e a) c, from kib₁ h₃,
                    have h₅ : ki d e (ki d a c), from ki.ki₆ h₄,
                    have h₆ : ki d e b, from ki.ki₈ h₁,
                    show ki d e (ki b a c), from ki.ki₇ h₆ h₅

                theorem  b₁ {a : Prop} (h₁ : bot) : a :=
                    have h₂ : ki bot bot bot, from ki.ki₁₀ h₁ h₁,
                    have h₃ : ki bot bot a, from kib₁ h₂,
                    show a, from ki.ki₁ h₁ h₃

            end ki_bot
        end wr
    end hilbert
end clfrags


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import category_theory.limits.shapes.zero
import category_theory.limits.shapes.kernels
import category_theory.abelian.basic

/-!
# Simple objects

We define simple objects in any category with zero morphisms.
A simple object is an object `Y` such that any monomorphism `f : X ⟶ Y`
is either an isomorphism or zero (but not both).

This is formalized as a `Prop` valued typeclass `simple X`.

If a morphism `f` out of a simple object is nonzero and has a kernel, then that kernel is zero.
(We state this as `kernel.ι f = 0`, but should add `kernel f ≅ 0`.)

When the category is abelian, being simple is the same as being cosimple (although we do not
state a separate typeclass for this).
As a consequence, any nonzero epimorphism out of a simple object is an isomorphism,
and any nonzero morphism into a simple object has trivial cokernel.
-/

noncomputable theory

open category_theory.limits

namespace category_theory

universes v u
variables {C : Type u} [category.{v} C]

section
variables [has_zero_morphisms C]

/-- An object is simple if monomorphisms into it are (exclusively) either isomorphisms or zero. -/
class simple (X : C) : Prop :=
(mono_is_iso_iff_nonzero : ∀ {Y : C} (f : Y ⟶ X) [mono f], is_iso f ↔ (f ≠ 0))

/-- A nonzero monomorphism to a simple object is an isomorphism. -/
lemma is_iso_of_mono_of_nonzero {X Y : C} [simple Y] {f : X ⟶ Y} [mono f] (w : f ≠ 0) :
  is_iso f :=
(simple.mono_is_iso_iff_nonzero f).mpr w

lemma kernel_zero_of_nonzero_from_simple
  {X Y : C} [simple X] {f : X ⟶ Y} [has_kernel f] (w : f ≠ 0) :
  kernel.ι f = 0 :=
begin
  classical,
  by_contra,
  haveI := is_iso_of_mono_of_nonzero h,
  exact w (eq_zero_of_epi_kernel f),
end

lemma mono_to_simple_zero_of_not_iso
  {X Y : C} [simple Y] {f : X ⟶ Y} [mono f] (w : is_iso f → false) : f = 0 :=
begin
  classical,
  by_contra,
  exact w (is_iso_of_mono_of_nonzero h)
end

lemma id_nonzero (X : C) [simple.{v} X] : 𝟙 X ≠ 0 :=
(simple.mono_is_iso_iff_nonzero (𝟙 X)).mp (by apply_instance)

instance (X : C) [simple.{v} X] : nontrivial (End X) :=
nontrivial_of_ne 1 0 (id_nonzero X)

section
variable [has_zero_object C]
open_locale zero_object

/-- We don't want the definition of 'simple' to include the zero object, so we check that here. -/
lemma zero_not_simple [simple (0 : C)] : false :=
(simple.mono_is_iso_iff_nonzero (0 : (0 : C) ⟶ (0 : C))).mp ⟨⟨0, by tidy⟩⟩ rfl

end
end

-- We next make the dual arguments, but for this we must be in an abelian category.
section abelian
variables [abelian C]

/-- In an abelian category, an object satisfying the dual of the definition of a simple object is
    simple. -/
lemma simple_of_cosimple (X : C) (h : ∀ {Z : C} (f : X ⟶ Z) [epi f], is_iso f ↔ (f ≠ 0)) :
  simple X :=
⟨λ Y f I,
 begin
  classical,
  fsplit,
  { introsI,
    have hx := cokernel.π_of_epi f,
    by_contra,
    substI h,
    exact (h _).mp (cokernel.π_of_zero _ _) hx },
  { intro hf,
    suffices : epi f,
    { resetI, apply abelian.is_iso_of_mono_of_epi },
    apply preadditive.epi_of_cokernel_zero,
    by_contra h',
    exact cokernel_not_iso_of_nonzero hf ((h _).mpr h') }
 end⟩

/-- A nonzero epimorphism from a simple object is an isomorphism. -/
lemma is_iso_of_epi_of_nonzero {X Y : C} [simple X] {f : X ⟶ Y} [epi f] (w : f ≠ 0) :
  is_iso f :=
begin
  -- `f ≠ 0` means that `kernel.ι f` is not an iso, and hence zero, and hence `f` is a mono.
  haveI : mono f :=
    preadditive.mono_of_kernel_zero (mono_to_simple_zero_of_not_iso (kernel_not_iso_of_nonzero w)),
  exact abelian.is_iso_of_mono_of_epi f,
end

lemma cokernel_zero_of_nonzero_to_simple
  {X Y : C} [simple Y] {f : X ⟶ Y} [has_cokernel f] (w : f ≠ 0) :
  cokernel.π f = 0 :=
begin
  classical,
  by_contradiction h,
  haveI := is_iso_of_epi_of_nonzero h,
  exact w (eq_zero_of_mono_cokernel f),
end

lemma epi_from_simple_zero_of_not_iso
  {X Y : C} [simple X] {f : X ⟶ Y} [epi f] (w : is_iso f → false) : f = 0 :=
begin
  classical,
  by_contra,
  exact w (is_iso_of_epi_of_nonzero h),
end

end abelian

end category_theory


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Instances for identity and composition functors
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.functor
import Mathlib.algebra.group.basic
import Mathlib.PostPort

universes u v u_1 w u_2

namespace Mathlib

theorem applicative.map_seq_map {F : Type u → Type v} [Applicative F] [is_lawful_applicative F] {α : Type u} {β : Type u} {γ : Type u} {σ : Type u} (f : α → β → γ) (g : σ → β) (x : F α) (y : F σ) : f <$> x <*> g <$> y = (flip function.comp g ∘ f) <$> x <*> y := sorry

theorem applicative.pure_seq_eq_map' {F : Type u → Type v} [Applicative F] [is_lawful_applicative F] {α : Type u} {β : Type u} (f : α → β) : Seq.seq (pure f) = Functor.map f := sorry

theorem applicative.ext {F : Type u → Type u_1} {A1 : Applicative F} {A2 : Applicative F} [is_lawful_applicative F] [is_lawful_applicative F] (H1 : ∀ {α : Type u} (x : α), pure x = pure x) (H2 : ∀ {α β : Type u} (f : F (α → β)) (x : F α), f <*> x = f <*> x) : A1 = A2 := sorry

protected instance id.is_comm_applicative : is_comm_applicative id :=
  is_comm_applicative.mk fun (α β : Type u_1) (a : id α) (b : id β) => Eq.refl (Prod.mk <$> a <*> b)

namespace functor

namespace comp

theorem map_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v} (f : α → β) (x : α) : f <$> pure x = pure (f x) := sorry

theorem seq_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v} (f : comp F G (α → β)) (x : α) : f <*> pure x = (fun (g : α → β) => g x) <$> f := sorry

theorem seq_assoc {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v} {γ : Type v} (x : comp F G α) (f : comp F G (α → β)) (g : comp F G (β → γ)) : g <*> (f <*> x) = function.comp <$> g <*> f <*> x := sorry

theorem pure_seq_eq_map {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v} (f : α → β) (x : comp F G α) : pure f <*> x = f <$> x := sorry

protected instance is_lawful_applicative {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] : is_lawful_applicative (comp F G) :=
  is_lawful_applicative.mk pure_seq_eq_map map_pure seq_pure seq_assoc

theorem applicative_id_comp {F : Type u_1 → Type u_2} [AF : Applicative F] [LF : is_lawful_applicative F] : comp.applicative = AF :=
  applicative.ext (fun (α : Type u_1) (x : α) => rfl) fun (α β : Type u_1) (f : F (α → β)) (x : F α) => rfl

theorem applicative_comp_id {F : Type u_1 → Type u_2} [AF : Applicative F] [LF : is_lawful_applicative F] : comp.applicative = AF := sorry

protected instance is_comm_applicative {f : Type u → Type w} {g : Type v → Type u} [Applicative f] [Applicative g] [is_comm_applicative f] [is_comm_applicative g] : is_comm_applicative (comp f g) := sorry

end comp

end functor

theorem comp.seq_mk {α : Type w} {β : Type w} {f : Type u → Type v} {g : Type w → Type u} [Applicative f] [Applicative g] (h : f (g (α → β))) (x : f (g α)) : functor.comp.mk h <*> functor.comp.mk x = functor.comp.mk (Seq.seq <$> h <*> x) :=
  rfl

protected instance functor.const.applicative {α : Type u_1} [HasOne α] [Mul α] : Applicative (functor.const α) := sorry

protected instance functor.const.is_lawful_applicative {α : Type u_1} [monoid α] : is_lawful_applicative (functor.const α) := sorry

protected instance functor.add_const.applicative {α : Type u_1} [HasZero α] [Add α] : Applicative (functor.add_const α) := sorry

protected instance functor.add_const.is_lawful_applicative {α : Type u_1} [add_monoid α] : is_lawful_applicative (functor.add_const α) := sorry


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import order.antisymmetrization
import order.category.Preord

/-!
# Category of partial orders

This defines `PartOrd`, the category of partial orders with monotone maps.
-/

open category_theory

universe u

/-- The category of partially ordered types. -/
def PartOrd := bundled partial_order

namespace PartOrd

instance : bundled_hom.parent_projection @partial_order.to_preorder := ⟨⟩

attribute [derive [large_category, concrete_category]] PartOrd

instance : has_coe_to_sort PartOrd Type* := bundled.has_coe_to_sort

/-- Construct a bundled PartOrd from the underlying type and typeclass. -/
def of (α : Type*) [partial_order α] : PartOrd := bundled.of α

@[simp] lemma coe_of (α : Type*) [partial_order α] : ↥(of α) = α := rfl

instance : inhabited PartOrd := ⟨of punit⟩

instance (α : PartOrd) : partial_order α := α.str

instance has_forget_to_Preord : has_forget₂ PartOrd Preord := bundled_hom.forget₂ _ _

/-- Constructs an equivalence between partial orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : PartOrd.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : PartOrd ⥤ PartOrd :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, order_hom.dual }

/-- The equivalence between `PartOrd` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : PartOrd ≌ PartOrd :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end PartOrd

lemma PartOrd_dual_comp_forget_to_Preord :
  PartOrd.dual ⋙ forget₂ PartOrd Preord =
    forget₂ PartOrd Preord ⋙ Preord.dual := rfl

/-- `antisymmetrization` as a functor. It is the free functor. -/
def Preord_to_PartOrd : Preord.{u} ⥤ PartOrd :=
{ obj := λ X, PartOrd.of (antisymmetrization X (≤)),
  map := λ X Y f, f.antisymmetrization,
  map_id' := λ X,
    by { ext, exact quotient.induction_on' x (λ x, quotient.map'_mk' _ (λ a b, id) _) },
  map_comp' := λ X Y Z f g,
    by { ext, exact quotient.induction_on' x (λ x, order_hom.antisymmetrization_apply_mk _ _) } }

/-- `Preord_to_PartOrd` is left adjoint to the forgetful functor, meaning it is the free
functor from `Preord` to `PartOrd`. -/
def Preord_to_PartOrd_forget_adjunction :
  Preord_to_PartOrd.{u} ⊣ forget₂ PartOrd Preord :=
adjunction.mk_of_hom_equiv
  { hom_equiv := λ X Y, { to_fun := λ f,
      ⟨f ∘ to_antisymmetrization (≤), f.mono.comp to_antisymmetrization_mono⟩,
    inv_fun := λ f, ⟨λ a, quotient.lift_on' a f $ λ a b h, (antisymm_rel.image h f.mono).eq, λ a b,
      quotient.induction_on₂' a b $ λ a b h, f.mono h⟩,
    left_inv := λ f, order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl,
    right_inv := λ f, order_hom.ext _ _ $ funext $ λ x, rfl },
  hom_equiv_naturality_left_symm' := λ X Y Z f g,
    order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl,
  hom_equiv_naturality_right' := λ X Y Z f g, order_hom.ext _ _ $ funext $ λ x, rfl }

/-- `Preord_to_PartOrd` and `order_dual` commute. -/
@[simps] def Preord_to_PartOrd_comp_to_dual_iso_to_dual_comp_Preord_to_PartOrd :
 (Preord_to_PartOrd.{u} ⋙ PartOrd.dual) ≅
    (Preord.dual ⋙ Preord_to_PartOrd) :=
nat_iso.of_components (λ X, PartOrd.iso.mk $ order_iso.dual_antisymmetrization _) $
  λ X Y f, order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import group_theory.group_action.defs

/-!
# Sum instances for additive and multiplicative actions

This file defines instances for additive and multiplicative actions on the binary `sum` type.

## See also

* `group_theory.group_action.pi`
* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
-/

variables {M N P α β γ : Type*}

namespace sum

section has_smul
variables [has_smul M α] [has_smul M β] [has_smul N α] [has_smul N β] (a : M) (b : α)
  (c : β) (x : α ⊕ β)

@[to_additive sum.has_vadd] instance : has_smul M (α ⊕ β) := ⟨λ a, sum.map ((•) a) ((•) a)⟩

@[to_additive] lemma smul_def : a • x = x.map ((•) a) ((•) a) := rfl
@[simp, to_additive] lemma smul_inl : a • (inl b : α ⊕ β) = inl (a • b) := rfl
@[simp, to_additive] lemma smul_inr : a • (inr c : α ⊕ β) = inr (a • c) := rfl
@[simp, to_additive] lemma smul_swap : (a • x).swap = a • x.swap := by cases x; refl

instance [has_smul M N] [is_scalar_tower M N α] [is_scalar_tower M N β] :
  is_scalar_tower M N (α ⊕ β) :=
⟨λ a b x,
  by { cases x, exacts [congr_arg inl (smul_assoc _ _ _), congr_arg inr (smul_assoc _ _ _)] }⟩

@[to_additive] instance [smul_comm_class M N α] [smul_comm_class M N β] :
  smul_comm_class M N (α ⊕ β) :=
⟨λ a b x,
  by { cases x, exacts [congr_arg inl (smul_comm _ _ _), congr_arg inr (smul_comm _ _ _)] }⟩

instance [has_smul Mᵐᵒᵖ α] [has_smul Mᵐᵒᵖ β] [is_central_scalar M α] [is_central_scalar M β] :
  is_central_scalar M (α ⊕ β) :=
⟨λ a x,
  by { cases x, exacts [congr_arg inl (op_smul_eq_smul _ _), congr_arg inr (op_smul_eq_smul _ _)] }⟩

@[to_additive] instance has_faithful_smul_left [has_faithful_smul M α] :
  has_faithful_smul M (α ⊕ β) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : α, by injection h (inl a)⟩

@[to_additive] instance has_faithful_smul_right [has_faithful_smul M β] :
  has_faithful_smul M (α ⊕ β) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ b : β, by injection h (inr b)⟩

end has_smul

@[to_additive] instance {m : monoid M} [mul_action M α] [mul_action M β] : mul_action M (α ⊕ β) :=
{ mul_smul := λ a b x,
    by { cases x, exacts [congr_arg inl (mul_smul _ _ _), congr_arg inr (mul_smul _ _ _)] },
  one_smul := λ x,
    by { cases x, exacts [congr_arg inl (one_smul _ _), congr_arg inr (one_smul _ _)] } }

end sum


/-
Copyright (c) 2020 Scott Morrison, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.shapes.products
import category_theory.limits.preserves.basic

/-!
# Preserving products

Constructions to relate the notions of preserving products and reflecting products
to concrete fans.

In particular, we show that `pi_comparison G f` is an isomorphism iff `G` preserves
the limit of `f`.
-/

noncomputable theory

universes w v₁ v₂ u₁ u₂

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables (G : C ⥤ D)

namespace category_theory.limits

variables {J : Type w} (f : J → C)

/--
The map of a fan is a limit iff the fan consisting of the mapped morphisms is a limit. This
essentially lets us commute `fan.mk` with `functor.map_cone`.
-/
def is_limit_map_cone_fan_mk_equiv {P : C} (g : Π j, P ⟶ f j) :
  is_limit (G.map_cone (fan.mk P g)) ≃
  is_limit (fan.mk _ (λ j, G.map (g j)) : fan (λ j, G.obj (f j))) :=
begin
  refine (is_limit.postcompose_hom_equiv _ _).symm.trans (is_limit.equiv_iso_limit _),
  refine discrete.nat_iso (λ j, iso.refl (G.obj (f j.as))),
  refine cones.ext (iso.refl _) (λ j, by { discrete_cases, dsimp, simp }),
end

/-- The property of preserving products expressed in terms of fans. -/
def is_limit_fan_mk_obj_of_is_limit [preserves_limit (discrete.functor f) G]
  {P : C} (g : Π j, P ⟶ f j) (t : is_limit (fan.mk _ g)) :
  is_limit (fan.mk (G.obj P) (λ j, G.map (g j)) : fan (λ j, G.obj (f j))) :=
is_limit_map_cone_fan_mk_equiv _ _ _ (preserves_limit.preserves t)

/-- The property of reflecting products expressed in terms of fans. -/
def is_limit_of_is_limit_fan_mk_obj [reflects_limit (discrete.functor f) G]
  {P : C} (g : Π j, P ⟶ f j) (t : is_limit (fan.mk _ (λ j, G.map (g j)) : fan (λ j, G.obj (f j)))) :
  is_limit (fan.mk P g) :=
reflects_limit.reflects ((is_limit_map_cone_fan_mk_equiv _ _ _).symm t)

section

variables [has_product f]

/--
If `G` preserves products and `C` has them, then the fan constructed of the mapped projection of a
product is a limit.
-/
def is_limit_of_has_product_of_preserves_limit [preserves_limit (discrete.functor f) G] :
  is_limit (fan.mk _ (λ (j : J), G.map (pi.π f j)) : fan (λ j, G.obj (f j))) :=
is_limit_fan_mk_obj_of_is_limit G f _ (product_is_product _)

variables [has_product (λ (j : J), G.obj (f j))]

/-- If `pi_comparison G f` is an isomorphism, then `G` preserves the limit of `f`. -/
def preserves_product.of_iso_comparison [i : is_iso (pi_comparison G f)] :
  preserves_limit (discrete.functor f) G :=
begin
  apply preserves_limit_of_preserves_limit_cone (product_is_product f),
  apply (is_limit_map_cone_fan_mk_equiv _ _ _).symm _,
  apply is_limit.of_point_iso (limit.is_limit (discrete.functor (λ (j : J), G.obj (f j)))),
  apply i,
end

variable [preserves_limit (discrete.functor f) G]

/--
If `G` preserves limits, we have an isomorphism from the image of a product to the product of the
images.
-/
def preserves_product.iso : G.obj (∏ f) ≅ ∏ (λ j, G.obj (f j)) :=
is_limit.cone_point_unique_up_to_iso
  (is_limit_of_has_product_of_preserves_limit G f)
  (limit.is_limit _)

@[simp]
lemma preserves_product.iso_hom : (preserves_product.iso G f).hom = pi_comparison G f :=
rfl

instance : is_iso (pi_comparison G f) :=
begin
  rw ← preserves_product.iso_hom,
  apply_instance,
end

end

/--
The map of a cofan is a colimit iff the cofan consisting of the mapped morphisms is a colimit.
This essentially lets us commute `cofan.mk` with `functor.map_cocone`.
-/
def is_colimit_map_cocone_cofan_mk_equiv {P : C} (g : Π j, f j ⟶ P) :
  is_colimit (G.map_cocone (cofan.mk P g)) ≃
  is_colimit (cofan.mk _ (λ j, G.map (g j)) : cofan (λ j, G.obj (f j))) :=
begin
  refine (is_colimit.precompose_hom_equiv _ _).symm.trans (is_colimit.equiv_iso_colimit _),
  refine discrete.nat_iso (λ j, iso.refl (G.obj (f j.as))),
  refine cocones.ext (iso.refl _) (λ j, by { discrete_cases, dsimp, simp }),
end

/-- The property of preserving coproducts expressed in terms of cofans. -/
def is_colimit_cofan_mk_obj_of_is_colimit [preserves_colimit (discrete.functor f) G]
  {P : C} (g : Π j, f j ⟶ P) (t : is_colimit (cofan.mk _ g)) :
  is_colimit (cofan.mk (G.obj P) (λ j, G.map (g j)) : cofan (λ j, G.obj (f j))) :=
is_colimit_map_cocone_cofan_mk_equiv _ _ _ (preserves_colimit.preserves t)

/-- The property of reflecting coproducts expressed in terms of cofans. -/
def is_colimit_of_is_colimit_cofan_mk_obj [reflects_colimit (discrete.functor f) G]
  {P : C} (g : Π j, f j ⟶ P)
  (t : is_colimit (cofan.mk _ (λ j, G.map (g j)) : cofan (λ j, G.obj (f j)))) :
  is_colimit (cofan.mk P g) :=
reflects_colimit.reflects ((is_colimit_map_cocone_cofan_mk_equiv _ _ _).symm t)

section

variables [has_coproduct f]

/--
If `G` preserves coproducts and `C` has them,
then the cofan constructed of the mapped inclusion of a coproduct is a colimit.
-/
def is_colimit_of_has_coproduct_of_preserves_colimit [preserves_colimit (discrete.functor f) G] :
  is_colimit (cofan.mk _ (λ (j : J), G.map (sigma.ι f j)) : cofan (λ j, G.obj (f j))) :=
is_colimit_cofan_mk_obj_of_is_colimit G f _ (coproduct_is_coproduct _)

variables [has_coproduct (λ (j : J), G.obj (f j))]

/-- If `sigma_comparison G f` is an isomorphism, then `G` preserves the colimit of `f`. -/
def preserves_coproduct.of_iso_comparison [i : is_iso (sigma_comparison G f)] :
  preserves_colimit (discrete.functor f) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone (coproduct_is_coproduct f),
  apply (is_colimit_map_cocone_cofan_mk_equiv _ _ _).symm _,
  apply is_colimit.of_point_iso (colimit.is_colimit (discrete.functor (λ (j : J), G.obj (f j)))),
  apply i,
end

variable [preserves_colimit (discrete.functor f) G]

/--
If `G` preserves colimits,
we have an isomorphism from the image of a coproduct to the coproduct of the images.
-/
def preserves_coproduct.iso : G.obj (∐ f) ≅ ∐ (λ j, G.obj (f j)) :=
is_colimit.cocone_point_unique_up_to_iso
  (is_colimit_of_has_coproduct_of_preserves_colimit G f)
  (colimit.is_colimit _)

@[simp]
lemma preserves_coproduct.inv_hom : (preserves_coproduct.iso G f).inv = sigma_comparison G f :=
rfl

instance : is_iso (sigma_comparison G f) :=
begin
  rw ← preserves_coproduct.inv_hom,
  apply_instance,
end

end

end category_theory.limits


import topology.basic data.set.intervals analysis.complex.exponential tactic.tidy «smt-lean»
open real set tactic

-- first part of proving that y(x)=1/(2-x) is continuous on [0,2)

def twoco_interval := (Ioo (0:ℝ) 2)

noncomputable def simple_rational := function.restrict (λ (x:ℝ), 1/(x-2)) twoco_interval

open smt.logic_fragment

lemma simple_rational_of_twoco_items_are_nonzero : ∀ (a : subtype
twoco_interval), a.val - 2 ≠ 0 :=
begin tidy,
veriT (AUFNIRA),
end


/-
This file does the following:

o defines the Cairo assembly language in terms of the raw machine language instructions
o defines Lean notation for the assembly language instructions
o proves theorems characterizing the next state for each instruction
-/
import starkware.cairo.lean.semantics.cpu

/-
Functions for clipping natural numbers and integers to the right range.
-/

section
variables {F : Type*} [field F]

def nat_clip (x : int) : nat := ((x + 2^15).to_nat % 2^16 : nat)

def int_clip (x : int) : F := nat_clip x - 2^15

lemma int_clip_eq {x : int} (h₁ : -2^15 ≤ x) (h₂ : x < 2^15) : (int_clip x : F) = x :=
begin
  have h : (x + 2^15).to_nat ≤ 2^16 - 1,
  { rw [int.to_nat_le, int.coe_nat_sub],
    apply int.le_sub_one_of_lt,
    apply lt_of_lt_of_le (add_lt_add_right h₂ _),
    norm_num, norm_num },
  rw [int_clip, nat_clip, nat.mod_eq_of_lt],
  have h' : x = ((x + 2 ^ 15).to_nat : ℤ) - 2^15,
  { apply eq_sub_of_add_eq, rw [int.to_nat_of_nonneg], linarith },
  conv { to_rhs, rw h' }, simp,
  apply nat.lt_of_succ_le,
  convert nat.succ_le_succ h
end

lemma int_clip_eq' (x : int) : int_clip x = ((nat_clip x - 2^15 : int) : F) :=
by simp [int_clip]

@[simp] theorem int.zero_clip : int_clip 0 = (0 : F) :=
by rw int_clip_eq; norm_num

def checked (x : int) {h₁ : -2^15 ≤ x} {h₂ : x < 2^15} : int := x

@[simp] lemma clip_checked (x : int) (h₁ :-2^15 ≤ x) (h₂ : x < 2^15) :
  (int_clip (@checked x h₁ h₂) : F) = ↑x := int_clip_eq h₁ h₂

notation `'[#` x `]` := @checked x (by norm_num) (by norm_num)

end

/-
A more convenient representation of instructions.
-/

structure instr :=
(off_dst   : int)
(off_op0   : int)
(off_op1   : int)
(dst_reg   : bool)
(op0_reg   : bool)
(op1_src   : bool × bool × bool)
(res_logic : bool × bool)
(pc_update : bool × bool × bool)
(ap_update : bool × bool)
(opcode    : bool × bool × bool)

namespace instr

def to_instruction (i : instr) : instruction :=
{ off_dst := bitvec.of_natr 16 (i.off_dst + 2^15).to_nat,
  off_op0 := bitvec.of_natr 16 (i.off_op0 + 2^15).to_nat,
  off_op1 := bitvec.of_natr 16 (i.off_op1 + 2^15).to_nat,
  flags   := { val := [i.dst_reg,
                       i.op0_reg,
                       i.op1_src.1, i.op1_src.2.1, i.op1_src.2.2,
                       i.res_logic.1, i.res_logic.2,
                       i.pc_update.1, i.pc_update.2.1, i.pc_update.2.2,
                       i.ap_update.1, i.ap_update.2,
                       i.opcode.1, i.opcode.2.1, i.opcode.2.2],
               property := rfl } }

def to_nat (i : instr) : nat :=
i.to_instruction.to_nat

@[simp] lemma dst_reg_to_instruction (i : instr) : i.to_instruction.dst_reg = i.dst_reg := rfl
@[simp] lemma op0_reg_to_instruction (i : instr) : i.to_instruction.op0_reg = i.op0_reg := rfl
@[simp] lemma op1_imm_to_instruction (i : instr) : i.to_instruction.op1_imm = i.op1_src.1 := rfl
@[simp] lemma op1_fp_to_instruction (i : instr) : i.to_instruction.op1_fp = i.op1_src.2.1 := rfl
@[simp] lemma op1_ap_to_instruction (i : instr) : i.to_instruction.op1_ap = i.op1_src.2.2 := rfl
@[simp] lemma res_add_to_instruction (i : instr) : i.to_instruction.res_add = i.res_logic.1 := rfl
@[simp] lemma res_mul_to_instruction (i : instr) : i.to_instruction.res_mul = i.res_logic.2 := rfl
@[simp] lemma pc_jump_abs_to_instruction (i : instr) :
                i.to_instruction.pc_jump_abs = i.pc_update.1 := rfl
@[simp] lemma pc_jump_rel_to_instruction (i : instr) :
                i.to_instruction.pc_jump_rel = i.pc_update.2.1 := rfl
@[simp] lemma pc_jnz_to_instruction (i : instr) : i.to_instruction.pc_jnz = i.pc_update.2.2 := rfl
@[simp] lemma ap_add_to_instruction (i : instr) : i.to_instruction.ap_add = i.ap_update.1 := rfl
@[simp] lemma ap_add1_to_instruction (i : instr) : i.to_instruction.ap_add1 = i.ap_update.2 := rfl
@[simp] lemma opcode_call_to_instruction (i : instr) :
                i.to_instruction.opcode_call = i.opcode.1 := rfl
@[simp] lemma opcode_ret_to_instruction (i : instr) :
                i.to_instruction.opcode_ret = i.opcode.2.1 := rfl
@[simp] lemma opcode_assert_eq_to_instruction (i : instr) :
                i.to_instruction.opcode_assert_eq = i.opcode.2.2 := rfl

@[simp] lemma off_dst_to_instruction (i : instr) :
  i.to_instruction.off_dst.to_natr = nat_clip i.off_dst :=
by simp [instr.to_instruction, bitvec.to_natr_of_natr, nat_clip]

@[simp] lemma off_op0_to_instruction (i : instr) :
  i.to_instruction.off_op0.to_natr = nat_clip i.off_op0 :=
by simp [instr.to_instruction, bitvec.to_natr_of_natr, nat_clip]

@[simp] lemma off_op1_to_instruction (i : instr) :
  i.to_instruction.off_op1.to_natr = nat_clip i.off_op1 :=
by simp [instr.to_instruction, bitvec.to_natr_of_natr, nat_clip]

def next_state {F : Type*} [field F] [decidable_eq F]
  (i : instr) (mem : F → F) (s t : register_state F) :=
i.to_instruction.next_state mem s t

end instr

/-
Model the assembly language.
-/

inductive op0_spec
| ap_plus : int → op0_spec
| fp_plus : int → op0_spec

@[simp] def op0_spec.op0_reg : op0_spec → bool
| (op0_spec.ap_plus i) := ff
| (op0_spec.fp_plus i) := tt

@[simp] def op0_spec.off_op0 : op0_spec → int
| (op0_spec.ap_plus i) := i
| (op0_spec.fp_plus i) := i

inductive op1_spec
| mem_op0_plus : int → op1_spec
| mem_pc_plus  : int → op1_spec
| mem_fp_plus  : int → op1_spec
| mem_ap_plus  : int → op1_spec

@[simp] def op1_spec.op1 : op1_spec → int
| (op1_spec.mem_op0_plus i) := i
| (op1_spec.mem_pc_plus i)  := i
| (op1_spec.mem_fp_plus i)  := i
| (op1_spec.mem_ap_plus i)  := i

@[simp] def op1_spec.op1_imm : op1_spec → bool
| (op1_spec.mem_pc_plus i)  := tt
| _                         := ff

@[simp] def op1_spec.op1_fp : op1_spec → bool
| (op1_spec.mem_fp_plus i)  := tt
| _                         := ff

@[simp] def op1_spec.op1_ap : op1_spec → bool
| (op1_spec.mem_ap_plus i)  := tt
| _                         := ff

inductive res_spec
| op1           : op1_spec → res_spec
| op0_plus_op1  : op1_spec → res_spec
| op0_times_op1 : op1_spec → res_spec

@[simp] def res_spec.res_add : res_spec → bool
| (res_spec.op0_plus_op1 i) := tt
| _                         := ff

@[simp] def res_spec.res_mul : res_spec → bool
| (res_spec.op0_times_op1 i) := tt
| _                          := ff

@[simp] def res_spec.to_op1 : res_spec → op1_spec
| (res_spec.op1 o1)           := o1
| (res_spec.op0_plus_op1 o1)  := o1
| (res_spec.op0_times_op1 o1) := o1

inductive dst_spec
| mem_ap_plus  : int → dst_spec
| mem_fp_plus  : int → dst_spec

@[simp] def dst_spec.dst_reg : dst_spec → bool
| (dst_spec.mem_ap_plus i) := ff
| (dst_spec.mem_fp_plus i) := tt

@[simp] def dst_spec.off_dst : dst_spec → int
| (dst_spec.mem_ap_plus i) := i
| (dst_spec.mem_fp_plus i) := i

def assert_eq_instr (op0 : op0_spec) (res : res_spec) (dst : dst_spec) (ap_update : bool) : instr :=
{ off_dst   := dst.off_dst,
  off_op0   := op0.off_op0,
  off_op1   := res.to_op1.op1,
  dst_reg   := dst.dst_reg,
  op0_reg   := op0.op0_reg,
  op1_src   := (res.to_op1.op1_imm, res.to_op1.op1_fp, res.to_op1.op1_ap),
  res_logic := (res.res_add, res.res_mul),
  pc_update := (ff, ff, ff),
  ap_update := (ff, ap_update),
  opcode    := (ff, ff, tt) }

def jump_instr (jump_abs : bool) (op0 : op0_spec) (res : res_spec) (ap_update : bool) : instr :=
{ off_dst   := -1,
  off_op0   := op0.off_op0,
  off_op1   := res.to_op1.op1,
  dst_reg   := tt,
  op0_reg   := op0.op0_reg,
  op1_src   := (res.to_op1.op1_imm, res.to_op1.op1_fp, res.to_op1.op1_ap),
  res_logic := (res.res_add, res.res_mul),
  pc_update := (jump_abs, bnot jump_abs, ff),
  ap_update := (ff, ap_update),
  opcode    := (ff, ff, ff) }

def jnz_instr (op0 : op0_spec) (op1 : op1_spec) (dst : dst_spec) (ap_update : bool) : instr :=
{ off_dst   := dst.off_dst,
  off_op0   := op0.off_op0,
  off_op1   := op1.op1,
  dst_reg   := dst.dst_reg,
  op0_reg   := op0.op0_reg,
  op1_src   := (op1.op1_imm, op1.op1_fp, op1.op1_ap),
  res_logic := (ff, ff),
  pc_update := (ff, ff, tt),
  ap_update := (ff, ap_update),
  opcode    := (ff, ff, ff) }

def call_instr (call_abs : bool) (res : res_spec) : instr :=
{ off_dst   := 0,
  off_op0   := 1,
  off_op1   := res.to_op1.op1,
  dst_reg   := ff,
  op0_reg   := ff,
  op1_src   := (res.to_op1.op1_imm, res.to_op1.op1_fp, res.to_op1.op1_ap),
  res_logic := (res.res_add, res.res_mul),
  pc_update := (call_abs, bnot call_abs, ff),
  ap_update := (ff, ff),
  opcode    := (tt, ff, ff) }

def ret_instr : instr :=
{ off_dst   := -2,
  off_op0   := -1,
  off_op1   := -1,
  dst_reg   := tt,
  op0_reg   := tt,
  op1_src   := (ff, tt, ff),
  res_logic := (ff, ff),
  pc_update := (tt, ff, ff),
  ap_update := (ff, ff),
  opcode    := (ff, tt, ff) }

def advance_ap_instr (op0 : op0_spec) (res : res_spec) : instr :=
{ off_dst   := -1,
  off_op0   := op0.off_op0,
  off_op1   := res.to_op1.op1,
  dst_reg   := tt,
  op0_reg   := op0.op0_reg,
  op1_src   := (res.to_op1.op1_imm, res.to_op1.op1_fp, res.to_op1.op1_ap),
  res_logic := (res.res_add, res.res_mul),
  pc_update := (ff, ff, ff),
  ap_update := (tt, ff),
  opcode    := (ff, ff, ff) }

/-
Notations for the assembly language.
-/

notation `'op0[ap]`         := op0_spec.ap_plus '[# 0]
notation `'op0[fp]`         := op0_spec.fp_plus '[# 0]
notation `'op0[ap+` i `]`   := op0_spec.ap_plus '[# i]
notation `'op0[fp+` i `]`   := op0_spec.fp_plus '[# i]

notation `'op1[op0]`        := op1_spec.mem_op0_plus '[# 0]
notation `'op1[pc]`         := op1_spec.mem_pc_plus  '[# 0]
notation `'op1[fp]`         := op1_spec.mem_fp_plus  '[# 0]
notation `'op1[ap]`         := op1_spec.mem_ap_plus  '[# 0]
notation `'op1[op0+` i `]`  := op1_spec.mem_op0_plus '[# i]
notation `'op1[pc+` i `]`   := op1_spec.mem_pc_plus  '[# i]
notation `'op1[fp+` i `]`   := op1_spec.mem_fp_plus  '[# i]
notation `'op1[ap+` i `]`   := op1_spec.mem_ap_plus  '[# i]
notation `'op1[imm]`        := op1_spec.mem_pc_plus  '[# 1]

notation `'res[` o1 `]`     := res_spec.op1 o1
notation `'res[op0+` o1 `]` := res_spec.op0_plus_op1 o1
notation `'res[op0*` o1 `]` := res_spec.op0_times_op1 o1

notation `'dst[ap]`         := dst_spec.mem_ap_plus '[# 0]
notation `'dst[fp]`         := dst_spec.mem_fp_plus '[# 0]
notation `'dst[ap+` i `]`   := dst_spec.mem_ap_plus '[# i]
notation `'dst[fp+` i `]`   := dst_spec.mem_fp_plus '[# i]

notation `'assert_eq[op0:=` op0 `,` dst `===` res `]`      := assert_eq_instr op0 res dst ff
notation `'assert_eq[op0:=` op0 `,` dst `===` res `;ap++]` := assert_eq_instr op0 res dst tt
notation `'assert_eq[` dst `===` res `]`      := assert_eq_instr (op0_spec.fp_plus (-1)) res dst ff
notation `'assert_eq[` dst `===` res `;ap++]` := assert_eq_instr (op0_spec.fp_plus (-1)) res dst tt

notation `'jmp_abs[` o1 `]`            := jump_instr tt (op0_spec.fp_plus (-1)) (res_spec.op1 o1) ff
notation `'jmp_abs[+` o0 `,` o1 `]`    := jump_instr tt o0 (res_spec.op0_plus_op1 o1) ff
notation `'jmp_abs[*` o0 `,` o1 `]`    := jump_instr tt o0 (res_spec.op0_times_op1 o1) ff
notation `'jmp_abs[` o1 `;ap++]`       := jump_instr tt (op0_spec.fp_plus (-1)) (res_spec.op1 o1) tt
notation `'jmp_abs[+` o0 `,` o1 `;ap++]` := jump_instr tt o0 (res_spec.op0_plus_op1 o1) tt
notation `'jmp_abs[*` o0 `,` o1 `;ap++]` := jump_instr tt o0 (res_spec.op0_times_op1 o1) tt

notation `'jmp_rel[` o1 `]`            := jump_instr ff (op0_spec.fp_plus (-1)) (res_spec.op1 o1) ff
notation `'jmp_rel[+` o0 `,` o1 `]`    := jump_instr ff o0 (res_spec.op0_plus_op1 o1) ff
notation `'jmp_rel[*` o0 `,` o1 `]`    := jump_instr ff o0 (res_spec.op0_times_op1 o1) ff
notation `'jmp_rel[` o1 `;ap++]`       := jump_instr ff (op0_spec.fp_plus (-1)) (res_spec.op1 o1) tt
notation `'jmp_rel[+` o0 `,` o1 `;ap++]` := jump_instr ff o0 (res_spec.op0_plus_op1 o1) tt
notation `'jmp_rel[*` o0 `,` o1 `;ap++]` := jump_instr ff o0 (res_spec.op0_times_op1 o1) tt

notation `'jnz_rel[` o1 `,` dst `]`      := jnz_instr (op0_spec.fp_plus (-1)) o1 dst ff
notation `'jnz_rel[` o1 `,` dst `;ap++]` := jnz_instr (op0_spec.fp_plus (-1)) o1 dst tt
notation `'jnz_rel[op0:=` op0 `,` o1 `,` dst `]`      := jnz_instr op0 o1 dst ff
notation `'jnz_rel[op0:=` op0 `,` o1 `,` dst `;ap++]` := jnz_instr op0 o1 dst tt

notation `'call_abs[` o1 `]` := call_instr tt (res_spec.op1 o1)
notation `'call_rel[` o1 `]` := call_instr ff (res_spec.op1 o1)

notation `'ret[]` := ret_instr

notation `'ap+=[op0:=` op0 `,` res `]` := advance_ap_instr op0 res
notation `'ap+=[` res `]`              := advance_ap_instr (op0_spec.fp_plus (-1)) res

notation `'assert_eq[op0:=` op0 `,` dst `===` res `]` := assert_eq_instr op0 res dst ff

/-
Semantics of the assembly language.
-/

section

variables {F : Type*} [field F]
variable mem : F → F
variables s t : register_state F
variables (op0 : op0_spec) (res : res_spec) (dst : dst_spec) (ap_update : bool)

lemma agrees_iff_of_eq_some {T : Type*} {a : option T} {b : T} (h : a = some b) (c : T) :
  a.agrees c ↔ c = b :=
by { rw h, simp [option.agrees], split; apply eq.symm }

lemma some_if {T : Type*} (P : Prop) [decidable P] (a b : T) :
  option.some (if P then a else b) = if P then option.some a else option.some b :=
by { by_cases h : P, { simp [if_pos h] }, simp [if_neg h] }

@[simp] def bump_ap : bool → F
| tt := s.ap + 1
| ff := s.ap

@[simp] def compute_op0 : op0_spec → F
| (op0_spec.ap_plus i) := mem (s.ap + int_clip i)
| (op0_spec.fp_plus i) := mem (s.fp + int_clip i)

@[simp] def compute_op1 : op1_spec → F
| (op1_spec.mem_op0_plus i) := mem (compute_op0 mem s op0 + int_clip i)
| (op1_spec.mem_pc_plus i)  := mem (s.pc + int_clip i)
| (op1_spec.mem_fp_plus i)  := mem (s.fp + int_clip i)
| (op1_spec.mem_ap_plus i)  := mem (s.ap + int_clip i)

@[simp] def compute_dst : dst_spec → F
| (dst_spec.mem_ap_plus i) := mem (s.ap + int_clip i)
| (dst_spec.mem_fp_plus i) := mem (s.fp + int_clip i)

@[simp] def compute_res : res_spec → F
| (res_spec.op1 o1)           := compute_op1 mem s op0 o1
| (res_spec.op0_plus_op1 o1)  := compute_op0 mem s op0 + compute_op1 mem s op0 o1
| (res_spec.op0_times_op1 o1) := compute_op0 mem s op0 * compute_op1 mem s op0 o1

@[simp] def bump_pc : bool → F
| ff := s.pc + 1
| tt := s.pc + 2

@[simp] def jump_pc : bool → F → F
| ff i := s.pc + i
| tt i := i

@[simp] lemma instruction_next_ap_aux_match_eq (i : instruction) :
  (instruction.next_ap_aux._match_1 i mem s ff ap_update) = some (bump_ap s ap_update) :=
by cases ap_update; { simp [instruction.next_ap_aux._match_1] }

lemma instruction_op1_match_eq (i : instruction) (op1 : op1_spec) (h : i.op0_reg = op0.op0_reg)
    (h' : i.off_op0.to_natr = nat_clip op0.off_op0)
    (h'' : i.off_op1.to_natr = nat_clip op1.op1) :
  (instruction.op1._match_1 i mem s op1.op1_imm op1.op1_fp op1.op1_ap) =
    some (compute_op1 mem s op0 op1) :=
begin
  cases op1 with op1 op1 op1 op1; simp [instruction.op1._match_1, instruction.op0, h];
    cases op0 with op0 op0; simp [bitvec.to_biased_16, h', h'']; refl
end

lemma instruction_res_aux_match_eq (i : instruction) (h : i.op0_reg = op0.op0_reg)
    (h' : i.off_op0.to_natr = nat_clip op0.off_op0) :
  instruction.res_aux._match_1 i mem s
      (some (compute_op1 mem s op0 res.to_op1)) res.res_add res.res_mul =
    some (compute_res mem s op0 res) :=
begin
  cases res with op1 op1 op1; simp [instruction.res_aux._match_1, instruction.op0, h, h'];
  cases op0 with op0 op0; simp [h', bitvec.to_biased_16]; try {refl}; {left, refl}
end

variable [decidable_eq F]

theorem next_state_assert_eq :
  (assert_eq_instr op0 res dst ap_update).next_state mem s t ↔
     (t.pc = bump_pc s res.to_op1.op1_imm ∧
      t.ap = bump_ap s ap_update ∧
      t.fp = s.fp ∧
      compute_dst mem s dst = compute_res mem s op0 res) :=
begin
  simp [instr.next_state, assert_eq_instr, instruction.next_state, option.agrees,
    instruction.next_pc, instruction.size, instruction.next_fp, instruction.next_ap,
    instruction.asserts, instruction.dst, instruction.next_ap_aux],
  apply and_congr, { cases res.to_op1.op1_imm; simp; split; apply eq.symm },
  repeat { apply and_congr, split; apply eq.symm },
  transitivity ((some (compute_res mem s op0 res)).agrees (compute_dst mem s dst)),
  swap, { split; apply eq.symm },
  congr',
  { simp [instruction.res, instruction.res_aux, instruction.op1],
    convert (instruction_res_aux_match_eq mem s op0 res _ _ _); try {simp},
    convert (instruction_op1_match_eq mem s op0 _ _ _ _ _); simp [nat_clip] },
  cases dst; simp [bitvec.to_biased_16]; refl
end

theorem next_state_jump (jump_abs : bool) :
  (jump_instr jump_abs op0 res ap_update).next_state mem s t ↔
    (t.pc = jump_pc s jump_abs (compute_res mem s op0 res) ∧
     t.ap = bump_ap s ap_update ∧
     t.fp = s.fp) :=
begin
  simp [instr.next_state, jump_instr, instruction.next_state, option.agrees,
    instruction.next_pc, instruction.size, instruction.next_fp, instruction.next_ap,
    instruction.asserts, instruction.dst, instruction.next_ap_aux],
  apply and_congr, swap,
  { split; rintros ⟨h1, h2⟩; rw [h1, h2]; split; trivial },
  apply agrees_iff_of_eq_some,
  cases jump_abs; simp [instruction.next_pc._match_1, instruction.res, instruction.res_aux],
  swap,
  { convert (instruction_res_aux_match_eq mem s op0 res _ _ _); try {simp},
    convert (instruction_op1_match_eq mem s op0 _ _ _ _ _); simp [nat_clip] },
  transitivity (instruction.next_pc._match_2 s (some (compute_res mem s op0 res))),
  swap, { refl }, congr',
  convert (instruction_res_aux_match_eq mem s op0 res _ _ _); try {simp},
  convert (instruction_op1_match_eq mem s op0 _ _ _ _ _); simp [nat_clip]
end

theorem next_state_jnz (op1 : op1_spec) :
  (jnz_instr op0 op1 dst ap_update).next_state mem s t ↔
    ((t.pc = if compute_dst mem s dst = 0 then
               bump_pc s op1.op1_imm
             else
               s.pc + compute_op1 mem s op0 op1) ∧
      t.ap = bump_ap s ap_update ∧
      t.fp = s.fp) :=
begin
  simp [instr.next_state, jnz_instr, instruction.next_state, option.agrees,
    instruction.next_pc, instruction.size, instruction.next_fp, instruction.next_ap,
    instruction.asserts, instruction.dst, instruction.next_ap_aux],
  apply and_congr, swap,
  { split; rintros ⟨h1, h2⟩; rw [h1, h2]; split; trivial },
  apply agrees_iff_of_eq_some, rw some_if,
  congr',
  { cases dst with dst_reg dst_off; simp [bitvec.to_biased_16]; refl },
  { cases op1.op1_imm; simp; refl },
  transitivity (instruction.next_pc._match_3 s (some (compute_op1 mem s op0 op1))),
  swap, { refl }, congr',
  convert (instruction_op1_match_eq mem s op0 _ _ _ _ _); simp [nat_clip]
end

theorem next_state_call (call_abs : bool) :
  (call_instr call_abs res).next_state mem s t ↔
    (t.pc = jump_pc s call_abs (compute_res mem s (op0_spec.ap_plus 1) res) ∧
     t.ap = s.ap + 2 ∧
     t.fp = s.ap + 2 ∧
     mem (s.ap + 1) = bump_pc s res.to_op1.op1_imm ∧
     mem s.ap = s.fp) :=
begin
  simp [instr.next_state, call_instr, instruction.next_state, option.agrees,
    instruction.next_pc, instruction.size, instruction.next_fp, instruction.next_ap,
    instruction.asserts, instruction.dst, instruction.next_ap_aux],
  apply and_congr, swap,
  { apply and_congr, { split; intro h; rw h },
    apply and_congr, { split; intro h; rw h },
    apply and_congr,
      { simp [instruction.op0, instruction.off_op0],
        rw [bitvec.to_biased_16, instr.off_op0_to_instruction], dsimp,
        rw [←int_clip_eq', @int_clip_eq]; norm_num,
        cases res.to_op1.op1_imm; simp, refl },
    rw [bitvec.to_biased_16, instr.off_dst_to_instruction], dsimp,
    rw [←int_clip_eq', @int_clip_eq]; norm_num },
  apply agrees_iff_of_eq_some,
  cases call_abs; simp [instruction.next_pc._match_1, instruction.res, instruction.res_aux],
  { transitivity (instruction.next_pc._match_2 s (some (compute_res mem s 'op0[ap+ 1] res))),
    swap, { refl }, congr',
    convert (instruction_res_aux_match_eq mem s 'op0[ap+ 1] res _ _ _); try { simp [checked] },
    convert (instruction_op1_match_eq mem s 'op0[ap+ 1] _ _ _ _ _); simp [nat_clip, checked] },
  convert (instruction_res_aux_match_eq mem s 'op0[ap+ 1] res _ _ _); try { simp [checked] },
  convert (instruction_op1_match_eq mem s 'op0[ap+ 1] _ _ _ _ _); simp [nat_clip, checked],
end

theorem next_state_ret :
  ret_instr.next_state mem s t ↔
    (t.pc = mem (s.fp + -1) ∧
     t.ap = s.ap ∧
     t.fp = mem (s.fp - 2)) :=
begin
  simp [instr.next_state, ret_instr, instruction.next_state, option.agrees,
    instruction.next_pc, instruction.size, instruction.next_fp, instruction.next_ap,
    instruction.asserts, instruction.dst, instruction.next_ap_aux, instruction.res,
    instruction.res_aux, instruction.res_aux._match_1, instruction.op1],
  rw [bitvec.to_biased_16, instr.off_op1_to_instruction], dsimp,
  rw [bitvec.to_biased_16, instr.off_dst_to_instruction], dsimp,
  rw [←int_clip_eq', ←int_clip_eq', int_clip_eq, int_clip_eq, sub_eq_add_neg]; norm_num,
  repeat { apply and_congr, split; apply eq.symm },
  split; apply eq.symm
end

theorem next_state_advance_ap :
  (advance_ap_instr op0 res).next_state mem s t ↔
     (t.pc = bump_pc s res.to_op1.op1_imm ∧
      t.ap = s.ap + compute_res mem s op0 res ∧
      t.fp = s.fp) :=
begin
  simp [instr.next_state, advance_ap_instr, instruction.next_state, option.agrees,
    instruction.next_pc, instruction.size, instruction.next_fp, instruction.next_ap,
    instruction.asserts, instruction.dst, instruction.next_ap_aux, instruction.res,
    instruction.res_aux, instruction.op1],
  apply and_congr, { cases res.to_op1.op1_imm; simp; split; apply eq.symm },
  apply and_congr, swap, { split; apply eq.symm },
  apply agrees_iff_of_eq_some,
  have : ∀ (s : register_state F) x y, x = some y →
      instruction.next_ap_aux._match_2 s x = some (s.ap + y),
  { rintros s x y rfl, simp [instruction.next_ap_aux._match_2] },
  apply this s,
  convert (instruction_res_aux_match_eq mem s op0 res _ _ _); try {simp},
  convert (instruction_op1_match_eq mem s op0 _ _ _ _ _); simp [nat_clip]
end

end