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

! This file was ported from Lean 3 source module data.pfun
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Part
import Mathlib.Data.Rel

/-!
# Partial functions

This file defines partial functions. Partial functions are like functions, except they can also be
"undefined" on some inputs. We define them as functions `α → Part β`.

## Definitions

* `PFun α β`: Type of partial functions from `α` to `β`. Defined as `α → Part β` and denoted
  `α →. β`.
* `PFun.Dom`: Domain of a partial function. Set of values on which it is defined. Not to be confused
  with the domain of a function `α → β`, which is a type (`α` presently).
* `PFun.fn`: Evaluation of a partial function. Takes in an element and a proof it belongs to the
  partial function's `Dom`.
* `PFun.asSubtype`: Returns a partial function as a function from its `Dom`.
* `PFun.toSubtype`: Restricts the codomain of a function to a subtype.
* `PFun.evalOpt`: Returns a partial function with a decidable `Dom` as a function `a → Option β`.
* `PFun.lift`: Turns a function into a partial function.
* `PFun.id`: The identity as a partial function.
* `PFun.comp`: Composition of partial functions.
* `PFun.restrict`: Restriction of a partial function to a smaller `Dom`.
* `PFun.res`: Turns a function into a partial function with a prescribed domain.
* `PFun.fix` : First return map of a partial function `f : α →. β ⊕ α`.
* `PFun.fix_induction`: A recursion principle for `PFun.fix`.

### Partial functions as relations

Partial functions can be considered as relations, so we specialize some `Rel` definitions to `PFun`:
* `PFun.image`: Image of a set under a partial function.
* `PFun.ran`: Range of a partial function.
* `PFun.preimage`: Preimage of a set under a partial function.
* `PFun.core`: Core of a set under a partial function.
* `PFun.graph`: Graph of a partial function `a →. β`as a `Set (α × β)`.
* `PFun.graph'`: Graph of a partial function `a →. β`as a `Rel α β`.

### `PFun α` as a monad

Monad operations:
* `PFun.pure`: The monad `pure` function, the constant `x` function.
* `PFun.bind`: The monad `bind` function, pointwise `Part.bind`
* `PFun.map`: The monad `map` function, pointwise `Part.map`.
-/

open Function

/-- `PFun α β`, or `α →. β`, is the type of partial functions from
  `α` to `β`. It is defined as `α → part β`. -/
def PFun (α β : Type _) :=
  α → Part β
#align pfun PFun

-- mathport name: «expr →. »
/-- `α  →. β` is notation for the type `PFun α β` of partial functions from `α` to `β`.  -/
infixr:25 " →. " => PFun

namespace PFun

variable {α β γ δ ε ι : Type _}

instance : Inhabited (α →. β) :=
  ⟨fun _ => Part.none⟩

/-- The domain of a partial function -/
def Dom (f : α →. β) : Set α :=
  { a | (f a).Dom }
#align pfun.dom PFun.Dom

@[simp]
theorem mem_dom (f : α →. β) (x : α) : x ∈ Dom f ↔ ∃ y, y ∈ f x := by simp [Dom, Part.dom_iff_mem]
#align pfun.mem_dom PFun.mem_dom

@[simp]
theorem dom_mk (p : α → Prop) (f : ∀ a, p a → β) : (PFun.Dom fun x => ⟨p x, f x⟩) = { x | p x } :=
  rfl
#align pfun.dom_mk PFun.dom_mk

theorem dom_eq (f : α →. β) : Dom f = { x | ∃ y, y ∈ f x } :=
  Set.ext (mem_dom f)
#align pfun.dom_eq PFun.dom_eq

/-- Evaluate a partial function -/
def fn (f : α →. β) (a : α) : Dom f a → β :=
  (f a).get
#align pfun.fn PFun.fn

@[simp]
theorem fn_apply (f : α →. β) (a : α) : f.fn a = (f a).get :=
  rfl
#align pfun.fn_apply PFun.fn_apply

/-- Evaluate a partial function to return an `Option` -/
def evalOpt (f : α →. β) [D : DecidablePred (· ∈ Dom f)] (x : α) : Option β :=
  @Part.toOption _ _ (D x)
#align pfun.eval_opt PFun.evalOpt

/-- Partial function extensionality -/
theorem ext' {f g : α →. β} (H1 : ∀ a, a ∈ Dom f ↔ a ∈ Dom g) (H2 : ∀ a p q, f.fn a p = g.fn a q) :
    f = g :=
  funext fun a => Part.ext' (H1 a) (H2 a)
#align pfun.ext' PFun.ext'

theorem ext {f g : α →. β} (H : ∀ a b, b ∈ f a ↔ b ∈ g a) : f = g :=
  funext fun a => Part.ext (H a)
#align pfun.ext PFun.ext

/-- Turns a partial function into a function out of its domain. -/
def asSubtype (f : α →. β) (s : f.Dom) : β :=
  f.fn s s.2
#align pfun.as_subtype PFun.asSubtype

/-- The type of partial functions `α →. β` is equivalent to
the type of pairs `(p : α → Prop, f : subtype p → β)`. -/
def equivSubtype : (α →. β) ≃ Σp : α → Prop, Subtype p → β :=
  ⟨fun f => ⟨fun a => (f a).Dom, asSubtype f⟩, fun f x => ⟨f.1 x, fun h => f.2 ⟨x, h⟩⟩, fun f =>
    funext fun a => Part.eta _, fun ⟨p, f⟩ => by dsimp ; congr ⟩
#align pfun.equiv_subtype PFun.equivSubtype

theorem asSubtype_eq_of_mem {f : α →. β} {x : α} {y : β} (fxy : y ∈ f x) (domx : x ∈ f.Dom) :
    f.asSubtype ⟨x, domx⟩ = y :=
  Part.mem_unique (Part.get_mem _) fxy
#align pfun.as_subtype_eq_of_mem PFun.asSubtype_eq_of_mem

/-- Turn a total function into a partial function. -/
protected def lift (f : α → β) : α →. β := fun a => Part.some (f a)
#align pfun.lift PFun.lift

instance : Coe (α → β) (α →. β) :=
  ⟨PFun.lift⟩

@[simp]
theorem coe_val (f : α → β) (a : α) : (f : α →. β) a = Part.some (f a) :=
  rfl
#align pfun.coe_val PFun.coe_val

@[simp]
theorem dom_coe (f : α → β) : (f : α →. β).Dom = Set.univ :=
  rfl
#align pfun.dom_coe PFun.dom_coe

theorem lift_injective : Injective (PFun.lift : (α → β) → α →. β) := fun _ _ h =>
  funext fun a => Part.some_injective <| congr_fun h a
#align pfun.coe_injective PFun.lift_injective

/-- Graph of a partial function `f` as the set of pairs `(x, f x)` where `x` is in the domain of
`f`. -/
def graph (f : α →. β) : Set (α × β) :=
  { p | p.2 ∈ f p.1 }
#align pfun.graph PFun.graph

/-- Graph of a partial function as a relation. `x` and `y` are related iff `f x` is defined and
"equals" `y`. -/
def graph' (f : α →. β) : Rel α β := fun x y => y ∈ f x
#align pfun.graph' PFun.graph'

/-- The range of a partial function is the set of values
  `f x` where `x` is in the domain of `f`. -/
def ran (f : α →. β) : Set β :=
  { b | ∃ a, b ∈ f a }
#align pfun.ran PFun.ran

/-- Restrict a partial function to a smaller domain. -/
def restrict (f : α →. β) {p : Set α} (H : p ⊆ f.Dom) : α →. β := fun x =>
  (f x).restrict (x ∈ p) (@H x)
#align pfun.restrict PFun.restrict

@[simp]
theorem mem_restrict {f : α →. β} {s : Set α} (h : s ⊆ f.Dom) (a : α) (b : β) :
    b ∈ f.restrict h a ↔ a ∈ s ∧ b ∈ f a := by simp [restrict]
#align pfun.mem_restrict PFun.mem_restrict

/-- Turns a function into a partial function with a prescribed domain. -/
def res (f : α → β) (s : Set α) : α →. β :=
  (PFun.lift f).restrict s.subset_univ
#align pfun.res PFun.res

theorem mem_res (f : α → β) (s : Set α) (a : α) (b : β) : b ∈ res f s a ↔ a ∈ s ∧ f a = b := by
  simp [res, @eq_comm _ b]
#align pfun.mem_res PFun.mem_res

theorem res_univ (f : α → β) : PFun.res f Set.univ = f :=
  rfl
#align pfun.res_univ PFun.res_univ

theorem dom_iff_graph (f : α →. β) (x : α) : x ∈ f.Dom ↔ ∃ y, (x, y) ∈ f.graph :=
  Part.dom_iff_mem
#align pfun.dom_iff_graph PFun.dom_iff_graph

theorem lift_graph {f : α → β} {a b} : (a, b) ∈ (f : α →. β).graph ↔ f a = b :=
  show (∃ _ : True, f a = b) ↔ f a = b by simp
#align pfun.lift_graph PFun.lift_graph

/-- The monad `pure` function, the total constant `x` function -/
protected def pure (x : β) : α →. β := fun _ => Part.some x
#align pfun.pure PFun.pure

/-- The monad `bind` function, pointwise `part.bind` -/
def bind (f : α →. β) (g : β → α →. γ) : α →. γ := fun a => (f a).bind fun b => g b a
#align pfun.bind PFun.bind

@[simp]
theorem bind_apply (f : α →. β) (g : β → α →. γ) (a : α) : f.bind g a = (f a).bind fun b => g b a :=
  rfl
#align pfun.bind_apply PFun.bind_apply

/-- The monad `map` function, pointwise `part.map` -/
def map (f : β → γ) (g : α →. β) : α →. γ := fun a => (g a).map f
#align pfun.map PFun.map

instance : Monad (PFun α) where
  pure := @PFun.pure _
  bind := @PFun.bind _
  map := @PFun.map _

instance : LawfulMonad (PFun α) := LawfulMonad.mk'
  (bind_pure_comp := fun f x => funext fun a => Part.bind_some_eq_map _ _)
  (id_map := fun f => by funext a ; dsimp [Functor.map, PFun.map] ; cases f a; rfl)
  (pure_bind := fun x f => funext fun a => Part.bind_some _ (f x))
  (bind_assoc := fun f g k => funext fun a => (f a).bind_assoc (fun b => g b a) fun b => k b a)

theorem pure_defined (p : Set α) (x : β) : p ⊆ (@PFun.pure α _ x).Dom :=
  p.subset_univ
#align pfun.pure_defined PFun.pure_defined

theorem bind_defined {α β γ} (p : Set α) {f : α →. β} {g : β → α →. γ} (H1 : p ⊆ f.Dom)
    (H2 : ∀ x, p ⊆ (g x).Dom) : p ⊆ (f >>= g).Dom := fun a ha =>
  (⟨H1 ha, H2 _ ha⟩ : (f >>= g).Dom a)
#align pfun.bind_defined PFun.bind_defined

/-- First return map. Transforms a partial function `f : α →. β ⊕ α` into the partial function
`α →. β` which sends `a : α` to the first value in `β` it hits by iterating `f`, if such a value
exists. By abusing notation to illustrate, either `f a` is in the `β` part of `β ⊕ α` (in which
case `f.fix a` returns `f a`), or it is undefined (in which case `f.fix a` is undefined as well), or
it is in the `α` part of `β ⊕ α` (in which case we repeat the procedure, so `f.fix a` will return
`f.fix (f a)`). -/
-- Porting note: had to mark `noncomputable`
noncomputable def fix (f : α →. Sum β α) : α →. β := fun a =>
  Part.assert (Acc (fun x y => Sum.inr x ∈ f y) a) $ fun h =>
    @WellFounded.fixF _ (fun x y => Sum.inr x ∈ f y) _
      (fun a IH =>
        Part.assert (f a).Dom $ fun hf =>
          match e : (f a).get hf with
          | Sum.inl b => Part.some b
          | Sum.inr a' => IH a' ⟨hf, e⟩)
      a h
#align pfun.fix PFun.fix

theorem dom_of_mem_fix {f : α →. Sum β α} {a : α} {b : β} (h : b ∈ f.fix a) : (f a).Dom := by
  let ⟨h₁, h₂⟩ := Part.mem_assert_iff.1 h
  rw [WellFounded.fixFEq] at h₂ ; exact h₂.fst.fst
#align pfun.dom_of_mem_fix PFun.dom_of_mem_fix

theorem mem_fix_iff {f : α →. Sum β α} {a : α} {b : β} :
    b ∈ f.fix a ↔ Sum.inl b ∈ f a ∨ ∃ a', Sum.inr a' ∈ f a ∧ b ∈ f.fix a' :=
  ⟨fun h => by
    let ⟨h₁, h₂⟩ := Part.mem_assert_iff.1 h
    rw [WellFounded.fixFEq] at h₂
    simp at h₂
    cases' h₂ with h₂ h₃
    split at h₃ <;> simp at h₃
    next e => subst b; refine' Or.inl ⟨h₂, e⟩
    next e => exact Or.inr ⟨_, ⟨_, e⟩, Part.mem_assert _ h₃⟩,
   fun h => by
    simp [fix]
    rcases h with (⟨h₁, h₂⟩ | ⟨a', h, h₃⟩)
    · refine' ⟨⟨_, fun y h' => _⟩, _⟩
      · injection Part.mem_unique ⟨h₁, h₂⟩ h'
      · rw [WellFounded.fixFEq]
        -- Porting note: used to be simp [h₁, h₂]
        apply Part.mem_assert h₁
        split
        next e =>
          injection h₂.symm.trans e with h; simp [h]
        next e =>
          injection h₂.symm.trans e
    · simp [fix] at h₃
      cases' h₃ with h₃ h₄
      refine' ⟨⟨_, fun y h' => _⟩, _⟩
      · injection Part.mem_unique h h' with e
        exact e ▸ h₃
      · cases' h with h₁ h₂
        rw [WellFounded.fixFEq]
        -- Porting note: used to be simp [h₁, h₂, h₄]
        apply Part.mem_assert h₁
        split
        next e =>
          injection h₂.symm.trans e
        next e =>
          injection h₂.symm.trans e; subst a'; exact h₄⟩
#align pfun.mem_fix_iff PFun.mem_fix_iff

/-- If advancing one step from `a` leads to `b : β`, then `f.fix a = b` -/
theorem fix_stop {f : α →. Sum β α} {b : β} {a : α} (hb : Sum.inl b ∈ f a) : b ∈ f.fix a := by
  rw [PFun.mem_fix_iff]
  exact Or.inl hb
#align pfun.fix_stop PFun.fix_stop

/-- If advancing one step from `a` on `f` leads to `a' : α`, then `f.fix a = f.fix a'` -/
theorem fix_fwd_eq {f : α →. Sum β α} {a a' : α} (ha' : Sum.inr a' ∈ f a) : f.fix a = f.fix a' := by
  ext b; constructor
  · intro h
    obtain h' | ⟨a, h', e'⟩ := mem_fix_iff.1 h <;> cases Part.mem_unique ha' h'
    exact e'
  · intro h
    rw [PFun.mem_fix_iff]
    exact Or.inr ⟨a', ha', h⟩
#align pfun.fix_fwd_eq PFun.fix_fwd_eq

theorem fix_fwd {f : α →. Sum β α} {b : β} {a a' : α} (hb : b ∈ f.fix a) (ha' : Sum.inr a' ∈ f a) :
    b ∈ f.fix a' := by rwa [← fix_fwd_eq ha']
#align pfun.fix_fwd PFun.fix_fwd

/-- A recursion principle for `PFun.fix`. -/
-- Porting note: had to add `noncomputable`
@[elab_as_elim]
noncomputable def fixInduction {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α} (h : b ∈ f.fix a)
    (H : ∀ a', b ∈ f.fix a' → (∀ a'', Sum.inr a'' ∈ f a' → C a'') → C a') : C a := by
  have h₂ := (Part.mem_assert_iff.1 h).snd;
  -- Porting note: revert/intro trick required to address `generalize_proofs` bug
  revert h₂
  generalize_proofs h₁;
  intro h₂; clear h
  induction' h₁ with a ha IH
  have h : b ∈ f.fix a := Part.mem_assert_iff.2 ⟨⟨a, ha⟩, h₂⟩
  exact H a h fun a' fa' => IH a' fa' (Part.mem_assert_iff.1 (fix_fwd h fa')).snd
#align pfun.fix_induction PFun.fixInduction

theorem fixInduction_spec {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α} (h : b ∈ f.fix a)
    (H : ∀ a', b ∈ f.fix a' → (∀ a'', Sum.inr a'' ∈ f a' → C a'') → C a') :
    @fixInduction _ _ C _ _ _ h H = H a h fun a' h' => fixInduction (fix_fwd h h') H := by
  unfold fixInduction
  -- Porting note: `generalize` required to address `generalize_proofs` bug
  generalize (Part.mem_assert_iff.1 h).fst = ha
  induction ha
  rfl
#align pfun.fix_induction_spec PFun.fixInduction_spec

/-- Another induction lemma for `b ∈ f.fix a` which allows one to prove a predicate `P` holds for
`a` given that `f a` inherits `P` from `a` and `P` holds for preimages of `b`.
-/
@[elab_as_elim]
noncomputable def fixInduction' {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α}
    (h : b ∈ f.fix a) (hbase : ∀ a_final : α, Sum.inl b ∈ f a_final → C a_final)
    (hind : ∀ a₀ a₁ : α, b ∈ f.fix a₁ → Sum.inr a₁ ∈ f a₀ → C a₁ → C a₀) : C a := by
  refine' fixInduction h fun a' h ih => _
  rcases e : (f a').get (dom_of_mem_fix h) with b' | a'' <;> replace e : _ ∈ f a' := ⟨_, e⟩
  · apply hbase
    convert e
    exact Part.mem_unique h (fix_stop e)
  · exact hind _ _ (fix_fwd h e) e (ih _ e)
#align pfun.fix_induction' PFun.fixInduction'

theorem fixInduction'_stop {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α} (h : b ∈ f.fix a)
    (fa : Sum.inl b ∈ f a) (hbase : ∀ a_final : α, Sum.inl b ∈ f a_final → C a_final)
    (hind : ∀ a₀ a₁ : α, b ∈ f.fix a₁ → Sum.inr a₁ ∈ f a₀ → C a₁ → C a₀) :
    @fixInduction' _ _ C _ _ _ h hbase hind = hbase a fa := by
  unfold fixInduction'
  rw [fixInduction_spec]
  -- Porting note: the explicit motive required because `simp` behaves differently
  refine' Eq.rec (motive := fun x e =>
      Sum.casesOn (motive := fun y => (f a).get (dom_of_mem_fix h) = y → C a) x _ _
      (Eq.trans (Part.get_eq_of_mem fa (dom_of_mem_fix h)) e) = hbase a fa) _
    (Part.get_eq_of_mem fa (dom_of_mem_fix h)).symm
  simp
#align pfun.fix_induction'_stop PFun.fixInduction'_stop

theorem fixInduction'_fwd {C : α → Sort _} {f : α →. Sum β α} {b : β} {a a' : α} (h : b ∈ f.fix a)
    (h' : b ∈ f.fix a') (fa : Sum.inr a' ∈ f a)
    (hbase : ∀ a_final : α, Sum.inl b ∈ f a_final → C a_final)
    (hind : ∀ a₀ a₁ : α, b ∈ f.fix a₁ → Sum.inr a₁ ∈ f a₀ → C a₁ → C a₀) :
    @fixInduction' _ _ C _ _ _ h hbase hind = hind a a' h' fa (fixInduction' h' hbase hind) := by
  unfold fixInduction'
  rw [fixInduction_spec]
  -- Porting note: the explicit motive required because `simp` behaves differently
  refine' Eq.rec (motive := fun x e =>
      Sum.casesOn (motive := fun y => (f a).get (dom_of_mem_fix h) = y → C a) x _ _
      (Eq.trans (Part.get_eq_of_mem fa (dom_of_mem_fix h)) e) = _) _
    (Part.get_eq_of_mem fa (dom_of_mem_fix h)).symm
  simp
#align pfun.fix_induction'_fwd PFun.fixInduction'_fwd

variable (f : α →. β)

/-- Image of a set under a partial function. -/
def image (s : Set α) : Set β :=
  f.graph'.image s
#align pfun.image PFun.image

theorem image_def (s : Set α) : f.image s = { y | ∃ x ∈ s, y ∈ f x } :=
  rfl
#align pfun.image_def PFun.image_def

theorem mem_image (y : β) (s : Set α) : y ∈ f.image s ↔ ∃ x ∈ s, y ∈ f x :=
  Iff.rfl
#align pfun.mem_image PFun.mem_image

theorem image_inter (s t : Set α) : f.image (s ∩ t) ⊆ f.image s ∩ f.image t :=
  Rel.image_inter _ s t
#align pfun.image_inter PFun.image_inter

theorem image_union (s t : Set α) : f.image (s ∪ t) = f.image s ∪ f.image t :=
  Rel.image_union _ s t
#align pfun.image_union PFun.image_union

/-- Preimage of a set under a partial function. -/
def preimage (s : Set β) : Set α :=
  Rel.image (fun x y => x ∈ f y) s
#align pfun.preimage PFun.preimage

theorem Preimage_def (s : Set β) : f.preimage s = { x | ∃ y ∈ s, y ∈ f x } :=
  rfl
#align pfun.preimage_def PFun.Preimage_def

@[simp]
theorem mem_preimage (s : Set β) (x : α) : x ∈ f.preimage s ↔ ∃ y ∈ s, y ∈ f x :=
  Iff.rfl
#align pfun.mem_preimage PFun.mem_preimage

theorem preimage_subset_dom (s : Set β) : f.preimage s ⊆ f.Dom := fun _ ⟨y, _, fxy⟩ =>
  Part.dom_iff_mem.mpr ⟨y, fxy⟩
#align pfun.preimage_subset_dom PFun.preimage_subset_dom

theorem preimage_mono {s t : Set β} (h : s ⊆ t) : f.preimage s ⊆ f.preimage t :=
  Rel.preimage_mono _ h
#align pfun.preimage_mono PFun.preimage_mono

theorem preimage_inter (s t : Set β) : f.preimage (s ∩ t) ⊆ f.preimage s ∩ f.preimage t :=
  Rel.preimage_inter _ s t
#align pfun.preimage_inter PFun.preimage_inter

theorem preimage_union (s t : Set β) : f.preimage (s ∪ t) = f.preimage s ∪ f.preimage t :=
  Rel.preimage_union _ s t
#align pfun.preimage_union PFun.preimage_union

theorem preimage_univ : f.preimage Set.univ = f.Dom := by ext ; simp [mem_preimage, mem_dom]
#align pfun.preimage_univ PFun.preimage_univ

theorem coe_preimage (f : α → β) (s : Set β) : (f : α →. β).preimage s = f ⁻¹' s := by ext ; simp
#align pfun.coe_preimage PFun.coe_preimage

/-- Core of a set `s : set β` with respect to a partial function `f : α →. β`. Set of all `a : α`
such that `f a ∈ s`, if `f a` is defined. -/
def core (s : Set β) : Set α :=
  f.graph'.core s
#align pfun.core PFun.core

theorem core_def (s : Set β) : f.core s = { x | ∀ y, y ∈ f x → y ∈ s } :=
  rfl
#align pfun.core_def PFun.core_def

@[simp]
theorem mem_core (x : α) (s : Set β) : x ∈ f.core s ↔ ∀ y, y ∈ f x → y ∈ s :=
  Iff.rfl
#align pfun.mem_core PFun.mem_core

theorem compl_dom_subset_core (s : Set β) : f.Domᶜ ⊆ f.core s := fun x hx y fxy =>
  absurd ((mem_dom f x).mpr ⟨y, fxy⟩) hx
#align pfun.compl_dom_subset_core PFun.compl_dom_subset_core

theorem core_mono {s t : Set β} (h : s ⊆ t) : f.core s ⊆ f.core t :=
  Rel.core_mono _ h
#align pfun.core_mono PFun.core_mono

theorem core_inter (s t : Set β) : f.core (s ∩ t) = f.core s ∩ f.core t :=
  Rel.core_inter _ s t
#align pfun.core_inter PFun.core_inter

theorem mem_core_res (f : α → β) (s : Set α) (t : Set β) (x : α) :
    x ∈ (res f s).core t ↔ x ∈ s → f x ∈ t := by simp [mem_core, mem_res]
#align pfun.mem_core_res PFun.mem_core_res

section

open Classical

theorem core_res (f : α → β) (s : Set α) (t : Set β) : (res f s).core t = sᶜ ∪ f ⁻¹' t := by
  ext x
  rw [mem_core_res]
  by_cases h : x ∈ s <;> simp [h]
#align pfun.core_res PFun.core_res

end

theorem core_restrict (f : α → β) (s : Set β) : (f : α →. β).core s = s.preimage f := by
  ext x ; simp [core_def]
#align pfun.core_restrict PFun.core_restrict

theorem preimage_subset_core (f : α →. β) (s : Set β) : f.preimage s ⊆ f.core s :=
  fun _ ⟨y, ys, fxy⟩ y' fxy' =>
  have : y = y' := Part.mem_unique fxy fxy'
  this ▸ ys
#align pfun.preimage_subset_core PFun.preimage_subset_core

theorem preimage_eq (f : α →. β) (s : Set β) : f.preimage s = f.core s ∩ f.Dom :=
  Set.eq_of_subset_of_subset (Set.subset_inter (f.preimage_subset_core s) (f.preimage_subset_dom s))
    fun x ⟨xcore, xdom⟩ =>
    let y := (f x).get xdom
    have ys : y ∈ s := xcore _ (Part.get_mem _)
    show x ∈ f.preimage s from ⟨(f x).get xdom, ys, Part.get_mem _⟩
#align pfun.preimage_eq PFun.preimage_eq

theorem core_eq (f : α →. β) (s : Set β) : f.core s = f.preimage s ∪ f.Domᶜ := by
  rw [preimage_eq, Set.union_distrib_right, Set.union_comm (Dom f), Set.compl_union_self,
    Set.inter_univ, Set.union_eq_self_of_subset_right (f.compl_dom_subset_core s)]
#align pfun.core_eq PFun.core_eq

theorem preimage_as_subtype (f : α →. β) (s : Set β) :
    f.asSubtype ⁻¹' s = Subtype.val ⁻¹' f.preimage s := by
  ext x
  simp only [Set.mem_preimage, Set.mem_setOf_eq, PFun.asSubtype, PFun.mem_preimage]
  show f.fn x.val _ ∈ s ↔ ∃ y ∈ s, y ∈ f x.val
  exact
    Iff.intro (fun h => ⟨_, h, Part.get_mem _⟩) fun ⟨y, ys, fxy⟩ =>
      have : f.fn x.val x.property ∈ f x.val := Part.get_mem _
      Part.mem_unique fxy this ▸ ys
#align pfun.preimage_as_subtype PFun.preimage_as_subtype

/-- Turns a function into a partial function to a subtype. -/
def toSubtype (p : β → Prop) (f : α → β) : α →. Subtype p := fun a => ⟨p (f a), Subtype.mk _⟩
#align pfun.to_subtype PFun.toSubtype

@[simp]
theorem dom_to_subtype (p : β → Prop) (f : α → β) : (toSubtype p f).Dom = { a | p (f a) } :=
  rfl
#align pfun.dom_to_subtype PFun.dom_to_subtype

@[simp]
theorem to_subtype_apply (p : β → Prop) (f : α → β) (a : α) :
    toSubtype p f a = ⟨p (f a), Subtype.mk _⟩ :=
  rfl
#align pfun.to_subtype_apply PFun.to_subtype_apply

theorem dom_to_subtype_apply_iff {p : β → Prop} {f : α → β} {a : α} :
    (toSubtype p f a).Dom ↔ p (f a) :=
  Iff.rfl
#align pfun.dom_to_subtype_apply_iff PFun.dom_to_subtype_apply_iff

theorem mem_to_subtype_iff {p : β → Prop} {f : α → β} {a : α} {b : Subtype p} :
    b ∈ toSubtype p f a ↔ ↑b = f a := by
  rw [to_subtype_apply, Part.mem_mk_iff, exists_subtype_mk_eq_iff, eq_comm]
#align pfun.mem_to_subtype_iff PFun.mem_to_subtype_iff

/-- The identity as a partial function -/
protected def id (α : Type _) : α →. α :=
  Part.some
#align pfun.id PFun.id

@[simp]
theorem coe_id (α : Type _) : ((id : α → α) : α →. α) = PFun.id α :=
  rfl
#align pfun.coe_id PFun.coe_id

@[simp]
theorem id_apply (a : α) : PFun.id α a = Part.some a :=
  rfl
#align pfun.id_apply PFun.id_apply

/-- Composition of partial functions as a partial function. -/
def comp (f : β →. γ) (g : α →. β) : α →. γ := fun a => (g a).bind f
#align pfun.comp PFun.comp

@[simp]
theorem comp_apply (f : β →. γ) (g : α →. β) (a : α) : f.comp g a = (g a).bind f :=
  rfl
#align pfun.comp_apply PFun.comp_apply

@[simp]
theorem id_comp (f : α →. β) : (PFun.id β).comp f = f :=
  ext fun _ _ => by simp
#align pfun.id_comp PFun.id_comp

@[simp]
theorem comp_id (f : α →. β) : f.comp (PFun.id α) = f :=
  ext fun _ _ => by simp
#align pfun.comp_id PFun.comp_id

@[simp]
theorem dom_comp (f : β →. γ) (g : α →. β) : (f.comp g).Dom = g.preimage f.Dom := by
  ext
  simp_rw [mem_preimage, mem_dom, comp_apply, Part.mem_bind_iff, exists_prop, ← exists_and_right]
  rw [exists_comm]
  simp_rw [and_comm]
#align pfun.dom_comp PFun.dom_comp

@[simp]
theorem preimage_comp (f : β →. γ) (g : α →. β) (s : Set γ) :
    (f.comp g).preimage s = g.preimage (f.preimage s) := by
  ext
  simp_rw [mem_preimage, comp_apply, Part.mem_bind_iff, exists_prop, ← exists_and_right, ←
    exists_and_left]
  rw [exists_comm]
  simp_rw [and_assoc, and_comm]
#align pfun.preimage_comp PFun.preimage_comp

@[simp]
theorem Part.bind_comp (f : β →. γ) (g : α →. β) (a : Part α) :
    a.bind (f.comp g) = (a.bind g).bind f := by
  ext c
  simp_rw [Part.mem_bind_iff, comp_apply, Part.mem_bind_iff, exists_prop, ← exists_and_right, ←
    exists_and_left]
  rw [exists_comm]
  simp_rw [and_assoc]
#align part.bind_comp PFun.Part.bind_comp

@[simp]
theorem comp_assoc (f : γ →. δ) (g : β →. γ) (h : α →. β) : (f.comp g).comp h = f.comp (g.comp h) :=
  ext fun _ _ => by simp only [comp_apply, Part.bind_comp]
#align pfun.comp_assoc PFun.comp_assoc

-- This can't be `simp`
theorem coe_comp (g : β → γ) (f : α → β) : ((g ∘ f : α → γ) : α →. γ) = (g : β →. γ).comp f :=
  ext fun _ _ => by simp only [coe_val, comp_apply, Function.comp, Part.bind_some]
#align pfun.coe_comp PFun.coe_comp

/-- Product of partial functions. -/
def prodLift (f : α →. β) (g : α →. γ) : α →. β × γ := fun x =>
  ⟨(f x).Dom ∧ (g x).Dom, fun h => ((f x).get h.1, (g x).get h.2)⟩
#align pfun.prod_lift PFun.prodLift

@[simp]
theorem dom_prodLift (f : α →. β) (g : α →. γ) :
    (f.prodLift g).Dom = { x | (f x).Dom ∧ (g x).Dom } :=
  rfl
#align pfun.dom_prod_lift PFun.dom_prodLift

theorem get_prodLift (f : α →. β) (g : α →. γ) (x : α) (h) :
    (f.prodLift g x).get h = ((f x).get h.1, (g x).get h.2) :=
  rfl
#align pfun.get_prod_lift PFun.get_prodLift

@[simp]
theorem prodLift_apply (f : α →. β) (g : α →. γ) (x : α) :
    f.prodLift g x = ⟨(f x).Dom ∧ (g x).Dom, fun h => ((f x).get h.1, (g x).get h.2)⟩ :=
  rfl
#align pfun.prod_lift_apply PFun.prodLift_apply

theorem mem_prodLift {f : α →. β} {g : α →. γ} {x : α} {y : β × γ} :
    y ∈ f.prodLift g x ↔ y.1 ∈ f x ∧ y.2 ∈ g x := by
  trans ∃ hp hq, (f x).get hp = y.1 ∧ (g x).get hq = y.2
  · simp only [prodLift, Part.mem_mk_iff, And.exists, Prod.ext_iff]
  -- Porting note: was just `[exists_and_left, exists_and_right]`
  · simp only [exists_and_left, exists_and_right, (· ∈ ·), Part.Mem]
#align pfun.mem_prod_lift PFun.mem_prodLift

/-- Product of partial functions. -/
def prodMap (f : α →. γ) (g : β →. δ) : α × β →. γ × δ := fun x =>
  ⟨(f x.1).Dom ∧ (g x.2).Dom, fun h => ((f x.1).get h.1, (g x.2).get h.2)⟩
#align pfun.prod_map PFun.prodMap

@[simp]
theorem dom_prodMap (f : α →. γ) (g : β →. δ) :
    (f.prodMap g).Dom = { x | (f x.1).Dom ∧ (g x.2).Dom } :=
  rfl
#align pfun.dom_prod_map PFun.dom_prodMap

theorem get_prodMap (f : α →. γ) (g : β →. δ) (x : α × β) (h) :
    (f.prodMap g x).get h = ((f x.1).get h.1, (g x.2).get h.2) :=
  rfl
#align pfun.get_prod_map PFun.get_prodMap

@[simp]
theorem prodMap_apply (f : α →. γ) (g : β →. δ) (x : α × β) :
    f.prodMap g x = ⟨(f x.1).Dom ∧ (g x.2).Dom, fun h => ((f x.1).get h.1, (g x.2).get h.2)⟩ :=
  rfl
#align pfun.prod_map_apply PFun.prodMap_apply

theorem mem_prodMap {f : α →. γ} {g : β →. δ} {x : α × β} {y : γ × δ} :
    y ∈ f.prodMap g x ↔ y.1 ∈ f x.1 ∧ y.2 ∈ g x.2 := by
  trans ∃ hp hq, (f x.1).get hp = y.1 ∧ (g x.2).get hq = y.2
  · simp only [prodMap, Part.mem_mk_iff, And.exists, Prod.ext_iff]
  · simp only [exists_and_left, exists_and_right, (· ∈ ·), Part.Mem]
#align pfun.mem_prod_map PFun.mem_prodMap

@[simp]
theorem prodLift_fst_comp_snd_comp (f : α →. γ) (g : β →. δ) :
    prodLift (f.comp ((Prod.fst : α × β → α) : α × β →. α))
        (g.comp ((Prod.snd : α × β → β) : α × β →. β)) =
      prodMap f g :=
  ext fun a => by simp
#align pfun.prod_lift_fst_comp_snd_comp PFun.prodLift_fst_comp_snd_comp

@[simp]
theorem prodMap_id_id : (PFun.id α).prodMap (PFun.id β) = PFun.id _ :=
  ext fun _ _ => by simp [eq_comm]
#align pfun.prod_map_id_id PFun.prodMap_id_id

@[simp]
theorem prodMap_comp_comp (f₁ : α →. β) (f₂ : β →. γ) (g₁ : δ →. ε) (g₂ : ε →. ι) :
    (f₂.comp f₁).prodMap (g₂.comp g₁) = (f₂.prodMap g₂).comp (f₁.prodMap g₁) := -- by
  -- Porting note: was `by tidy`, below is a golf'd verson of the `tidy?` proof
  ext $ λ ⟨_, _⟩ ⟨_, _⟩ =>
  ⟨λ ⟨⟨⟨h1l1, h1l2⟩, ⟨h1r1, h1r2⟩⟩, h2⟩ => ⟨⟨⟨h1l1, h1r1⟩, ⟨h1l2, h1r2⟩⟩, h2⟩,
   λ ⟨⟨⟨h1l1, h1r1⟩, ⟨h1l2, h1r2⟩⟩, h2⟩ => ⟨⟨⟨h1l1, h1l2⟩, ⟨h1r1, h1r2⟩⟩, h2⟩⟩
#align pfun.prod_map_comp_comp PFun.prodMap_comp_comp

end PFun


universe u v

--
-- Model of Dijkstra monads, which combine a base monad (usually representing code) with a second
-- monad that is a predicate or prop/proof about the monad behavior.  This monad product is represented by
-- "MonadWithPredicate"
--

structure BaseMonad (α : Type) where
  (output : α)

inductive MonadResultIs {α : Type} : α → Type where
| mk : (mz : BaseMonad α) → MonadResultIs (mz.output)

def MRret {α : Type} (a : α) := MonadResultIs.mk (BaseMonad.mk a)

def MRbind {α : Type} {a b : α} {ma mb : BaseMonad α} : MonadResultIs a → (α → MonadResultIs b) → MonadResultIs b :=
  fun m1 m2 => match m1 with
               | MonadResultIs.mk mz => m2 (mz.output)

def MRrun {α : Type} {z : α} {mz : BaseMonad α} (d : MonadResultIs z) : α :=
  match d with
  | MonadResultIs.mk mz => mz.output

#check MRret 3
#reduce MRrun (MRret 3)
#reduce MRrun (MRbind (MRret 2) (fun _ => MRret 3))
-- here we try to run the monad and enforce a return value (4) that is wrong (actually returns 3).  This should produce and error
#check @MRrun Nat 4 _ (MRret 4)

def dPred (α : Type) : Type := α → Prop

def retEqPred {α : Type} (v : α) : dPred α := fun y => y = v
def retEqProof {α : Type} (v : α) : retEqPred v v := show v = v by rfl

def bindPred {α β : Type} (p : dPred α) (f : α → dPred β) : dPred β := fun b => ∃ (a:α), p a ∧ f a b

inductive MonadWithPredicate (α : Type) : dPred α → Type where
| mk : (mz : BaseMonad α) → (pf : p mz.output) → MonadWithPredicate α p

def retMW {α : Type} {p : dPred α} (v : α) (pf : p v) := MonadWithPredicate.mk (BaseMonad.mk v) pf

-- bind that just uses the predicate of the most recent monad. All monads need to use the same predicate here.
def bindMW {α : Type} {p : dPred α} {a b : α} {ma mb : BaseMonad α} : MonadWithPredicate α p → (α → MonadWithPredicate α p) → MonadWithPredicate α p :=
  fun m1 m2 => match m1 with
               | MonadWithPredicate.mk mz1 pf1 => m2 mz1.output

-- bind that combines (using AND) the predicates of both monads
def bindMWAnd {α : Type} {p₁ p₂ : dPred α} : MonadWithPredicate α p₁ → (α → MonadWithPredicate α p₂) → MonadWithPredicate α (fun b => ∃x, p₁ x ∧ (p₂ b)) :=
  fun m1 m2 => match m1 with
               | MonadWithPredicate.mk mz1 pf1 =>
                 match (m2 mz1.output) with
                 | MonadWithPredicate.mk mz2 pf2 =>
                     MonadWithPredicate.mk mz2 (show ∃ x, p₁ x ∧ p₂ mz2.output from Exists.intro mz1.output (And.intro pf1 pf2))

def runPred {α : Type} (p : dPred α) (m : MonadWithPredicate α p) : ∃ x, p x :=
  match m with
  | MonadWithPredicate.mk b pf => Exists.intro b.output pf

#check show ∃ x, x=3 from Exists.intro 3 (_ : 3=3)
#reduce (retMW 3 _ : MonadWithPredicate Nat (retEqPred 3))
#reduce (retMW 3 (retEqProof 3) : MonadWithPredicate Nat (retEqPred 3))
#reduce (runPred (retEqPred 3) (retMW 3 _))
#reduce (runPred _ (bindMW (retMW 3 (retEqProof 3)) (fun _ => retMW 3 (retEqProof 3))))
#reduce (runPred _ (bindMWAnd (retMW 3 (retEqProof 3)) (fun _ => retMW 4 (retEqProof 4))))

def runProg := runPred (retEqPred 3) (retMW 3 (retEqProof 3))
def runProg2 := (runPred _ (bindMWAnd (retMW 3 (retEqProof 3)) (fun (x : Nat) => retMW 4 (retEqProof 4))))

#check @runProg2
#check Exists.intro 3 rfl
#check (show (∃ x, x = 3) from (Exists.intro 3 rfl))
#check (show (∀ a, a = 3 → retEqPred 3 3) from (fun a (_:a=3) => _))
#check Exists.elim (show (∃ x, x = 3) from (Exists.intro 3 rfl)) (show (∀ a, a = 3 → retEqPred 3 3) from (fun a (_:a=3) => _))

example (h: ∃ x, retEqPred 3 x ∧ retEqPred 4 4) : retEqPred 3 3 := by
  let hx : ∀ a, retEqPred 3 a ∧ retEqPred 4 4 → retEqPred 3 3 := show ∀a, retEqPred 3 a ∧ retEqPred 4 4 → retEqPred 3 3 from (fun a x => show _ from rfl)
  apply Exists.elim h hx

-- forward transforming predicate

def fPred (α : Type) : Type := Prop → α → Prop

def simpleFP {α : Type} (v : α) : fPred α := fun (pre:Prop) (a : α) => pre ∧ a = v

inductive MonadFwdPredicate {α : Type} : Prop → fPred α → Type where
| mk : (mz : BaseMonad α) → (pf : ∀ (hpre : pre), p pre mz.output) → MonadFwdPredicate pre p

def retFP {α : Type} (v : α) {pre :Prop} : MonadFwdPredicate pre (@simpleFP α v) :=
  let bm := BaseMonad.mk v
  MonadFwdPredicate.mk bm (fun (hpre : pre) => show simpleFP v pre bm.output from (And.intro hpre rfl))

def bindFP {α :Type} {pre1 : Prop} {p₁ p₂ : fPred α} :
  MonadFwdPredicate pre1 p₁ → (α → MonadFwdPredicate (∃a, p₁ pre1 a) p₂) → MonadFwdPredicate pre1 (fun pre z => p₂ (∃a, p₁ pre a) z) :=
    fun m f => match m with
               | MonadFwdPredicate.mk z1 pf1 =>
                   match (f z1.output) with
                   | MonadFwdPredicate.mk z2 pf2 =>
                       MonadFwdPredicate.mk z2 (fun pre => (pf2 (Exists.intro z1.output (pf1 pre))))

def runFP {α : Type} {pre1 :Prop} {p₁ : fPred α} (m : MonadFwdPredicate pre1 p₁) : pre1 → ∃ a, p₁ pre1 a :=
  fun p1 => match m with
            | MonadFwdPredicate.mk ma pf => Exists.intro ma.output (pf p1)

def sampleProg := runFP (bindFP (retFP 3) (fun _ => bindFP (retFP 5) (fun _ => retFP 4))) (rfl : 2=2)

-- backward transforming predicate

def bPred (α : Type) : Type := (α → Prop) → Prop

-- for backward transformers we need to map pointwise under the transformer when binding monads.
-- This also restricts transformers to be monotonic
class MonoBackward (w : bPred α) where
  monoMap {p₁ p₂ : α → Prop} : (∀ a , p₁ a → p₂ a) → w p₁ → w p₂

def simpleBP {α : Type} (v : α) : bPred α := fun (post : α → Prop) => post v

instance {α : Type} {v : α}: MonoBackward (simpleBP v) where
  monoMap  {p₁ p₂ : α → Prop} :=  fun f wp1 => f v wp1

inductive MonadBwdPredicate {α : Type} : bPred α → (α → Prop) → Type where
| mk : (mz : BaseMonad α) → (pf : p post) → MonadBwdPredicate p post

def retBP {α : Type} (v : α) {post : α → Prop} {postpf: post v} : MonadBwdPredicate (@simpleBP α v) post:=
  let bm := BaseMonad.mk v
  MonadBwdPredicate.mk bm postpf

def bindBP {α : Type} {post1 post2 : α → Prop} {p₁ p₂ p₃ : bPred α} [MonoBackward p₁] :
  MonadBwdPredicate p₁ post1 → (α → MonadBwdPredicate p₂ post2) → MonadBwdPredicate (fun (p : α → Prop) => p₁ (fun a => post1 a ∧ p₂ post2)) post2 :=
    fun m f => match m with
               | MonadBwdPredicate.mk z1 pf1 =>
                 match (f z1.output) with
                 | MonadBwdPredicate.mk z2 pf2 =>
                     MonadBwdPredicate.mk z2 (let hx : ∀ a, post1 a → post1 a ∧ p₂ post2 := fun a p1 => And.intro p1 pf2
                                              MonoBackward.monoMap hx pf1)

def runBP {α : Type} {post1 : α → Prop} {p₁ : bPred α} (m : MonadBwdPredicate p₁ post1) : p₁ post1 :=
  match m with | MonadBwdPredicate.mk ma pf => pf

#check retBP 3

def sampleBack := @runBP Nat (fun x => 3 = x → Eq 3 3) (simpleBP 3) (@retBP Nat 3 _ id)
def sampleBack2 : simpleBP 3 fun x => 3 = x → 3 = 3 := runBP (@retBP Nat 3 _ id)

-- backward predicate for state monad

def Top {x : Type} : x → Prop  := fun _ => True

def bSPred (s α : Type) : Type := (α × s → Prop) → s → Prop

def StatePM (s : Type) (α : Type) : Type := s → (α × s)

inductive MonadBwdState (s : Type) (α: Type) (p : bSPred s α) : Type where
| mk : (ms : StatePM s α) → (pf : ∀ post s, p post s → post (ms s)) → MonadBwdState s α p

def retBS {s α : Type} (a : α) : MonadBwdState s α (fun post s0 => post ⟨a, s0⟩) :=
  let md : StatePM s α := fun s => ⟨a,s⟩
  MonadBwdState.mk md (fun post s_1 => by
                          intro pst
                          let (h : md s_1 = (a, s_1)) := by simp
                          rw [h]
                          assumption
                       )

-- monadic bind of backward state transformers
def bindWBS {s α β : Type} (wc : bSPred s α) (wf : α → bSPred s β) : bSPred s β :=
  fun p s0 => wc (fun ⟨a,s1⟩ => wf a p s1) s0

def bindBS {s α β : Type} {wc : bSPred s α} {wf : α → bSPred s β} :
           MonadBwdState s α wc → ((x : α) → MonadBwdState s β (wf x)) → MonadBwdState s β (bindWBS wc wf) :=
  fun m1 f =>
    match m1 with
    | MonadBwdState.mk ms1 pf1 =>
        let mm  := fun s₁ =>
                        let mo1:= ms1 s₁
                        let m2 := f mo1.1
                        match m2 with
                        | MonadBwdState.mk ms2 pf2 => ms2 mo1.2
        let pf3 := fun post s₁ bindW =>
                        let mo1 := ms1 s₁
                        let m2 := f mo1.1
                        let ms2 := m2.1
                        let pf2 := m2.2
                        let ⟨a₂,s₃⟩ := mm s₁  -- actual results from monad running
                        let postX := fun (a,s) => wf a post s
                        let postXrfl : postX = (fun (a,s) => wf a post s) := by simp
                        let postT₁ := pf1 postX s₁
                        let postT₂ := pf2 post mo1.2
                        let hh : wc postX s₁ := by unfold bindWBS at bindW; assumption
                        let pf12 := postT₁ hh
                        let hpf12 : postX (ms1 s₁) = wf mo1.1 post mo1.2 := by simp
                        let hh2 : wf mo1.1 post mo1.2 := by rw [hpf12] at pf12; assumption
                        let pf3 := postT₂ hh2
                        let hme : ms2 = (f (ms1 s₁).fst).1 := by simp
                        let hh3 : ms2 mo1.2 = mm s₁:= by simp
                        by rewrite [←hh3]; assumption
        MonadBwdState.mk mm pf3


import linear_algebra.matrix
import group_theory.free_abelian_group
import algebra.direct_sum.basic
import algebra.big_operators.finsupp
import data.matrix.dmatrix

import for_mathlib.free_abelian_group
import data.matrix.kronecker

import hacks_and_tricks.type_pow
import hacks_and_tricks.by_exactI_hack

/-!
# Breen-Deligne resolutions

Reference:
https://www.math.uni-bonn.de/people/scholze/Condensed.pdf#section*.4
("Appendix to Lecture IV", p. 28)

We formalize the notion of `breen_deligne_data`.
Roughly speaking, this is a collection of formal finite sums of matrices
that encode that data that rolls out of the Breen--Deligne resolution.

## Main definitions

- `breen_deligne.basic_universal_map` : the map corresponding to a matrix
- `breen_deligne.universal_map` : a formal linear combination of basic universal maps.

-/
noncomputable theory

-- get some notation working:
open_locale big_operators direct_sum kronecker

local attribute [instance] type_pow
local notation `ℤ[` A `]` := free_abelian_group A

namespace breen_deligne
open free_abelian_group

/-!
Suppose you have an abelian group `A`.
What data do you need to specify a "universal" map `f : ℤ[A^m] → ℤ[A^n]`?
That is, it should be functorial in `A`.

Well, such a map is specified by what it does to `(a 1, a 2, a 3, ..., a m)`.
It can send this element to an arbitrary element of `ℤ[A^n]`,
but it has to be "universal".

In the end, this means that `f` will be a `ℤ`-linear combination of
"basic universal maps", where a "basic universal map" is one that
sends `(a 1, a 2, ..., a m)` to `(b 1, ..., b n)`,
where `b i` is a `ℤ`-linear combination `c i 1 * a 1 + ... + c i m * a m`.
So a "basic universal map" is specified by the `n × m`-matrix `c`.
-/

/-- A `basic_universal_map m n` is an `n × m`-matrix.
It captures data for a homomorphism `ℤ[A^m] → ℤ[A^n]`
functorial in the abelian group `A`.

A general such homomorphism is a formal linear combination
of `basic_universal_map`s, which we aptly call `universal_map`s. -/
@[derive add_comm_group]
def basic_universal_map (m n : ℕ) := matrix (fin n) (fin m) ℤ

namespace basic_universal_map

variables (A : Type*) [add_comm_group A]
variables {k l m n : ℕ} (g : basic_universal_map m n) (f : basic_universal_map l m)

def pre_eval : basic_universal_map m n →+ A^m → A^n :=
add_monoid_hom.mk' (λ f x i, ∑ j, f i j • (x : fin _ → A) j)
begin
  intros f₁ f₂,
  ext x i,
  simp only [pi.add_apply, dmatrix.add_apply, add_smul, finset.sum_add_distrib],
end

lemma pre_eval_apply : pre_eval A g = λ x i, ∑ j, g i j • (x : fin _ → A) j := rfl

/-- `f.eval A` for a `f : basic_universal_map m n`
is the homomorphism `ℤ[A^m] →+ ℤ[A^n]` induced by matrix multiplication. -/
def eval : ℤ[A^m] →+ ℤ[A^n] :=
map $ pre_eval A g

lemma eval_of (x : A^m) :
  g.eval A (of x) = (of $ pre_eval A g x) :=
lift.of _ _

/-- The composition of basic universal maps,
defined as matrix multiplication. -/
def comp : basic_universal_map m n →+ basic_universal_map l m →+ basic_universal_map l n :=
add_monoid_hom.mk' (λ g, add_monoid_hom.mk' (λ f, matrix.mul g f) $ matrix.mul_add _) $
  λ g₁ g₂, by { ext1 f, apply matrix.add_mul }

lemma eval_comp : (comp g f).eval A = (g.eval A).comp (f.eval A) :=
begin
  ext1 x,
  simp only [add_monoid_hom.coe_comp, function.comp_app, eval_of, pre_eval, comp, finset.smul_sum,
    matrix.mul_apply, finset.sum_smul, mul_smul, add_monoid_hom.mk'_apply],
  congr' 1,
  ext1 i,
  exact finset.sum_comm
end

lemma comp_assoc
  (h : basic_universal_map m n) (g : basic_universal_map l m) (f : basic_universal_map k l) :
  comp (comp h g) f = comp h (comp g f) :=
matrix.mul_assoc h g f

/-- The identity `basic_universal_map`. -/
def id (n : ℕ) : basic_universal_map n n := (1 : matrix (fin n) (fin n) ℤ)

@[simp] lemma id_comp : comp (id _) f = f :=
matrix.one_mul f

@[simp] lemma comp_id : comp g (id _) = g :=
matrix.mul_one g

def mul (N : ℕ) : basic_universal_map m n →+ basic_universal_map (N * m) (N * n) :=
add_monoid_hom.mk'
 (λ f, matrix.reindex_linear_equiv ℕ _ fin_prod_fin_equiv fin_prod_fin_equiv (1 ⊗ₖ f))
begin
  intros f g,
  simp only [matrix.kronecker_add, matrix.reindex_linear_equiv_apply,
    matrix.reindex_apply, matrix.submatrix_add, dmatrix.add_apply],
end

lemma mul_apply (N : ℕ) (f : basic_universal_map m n) :
  mul N f = matrix.reindex_linear_equiv ℕ _ fin_prod_fin_equiv fin_prod_fin_equiv (1 ⊗ₖ f) :=
rfl

lemma mul_injective (N : ℕ) (hN : 0 < N) : function.injective (@mul m n N) :=
begin
  intros f g H,
  ext i j,
  rw function.funext_iff at H,
  specialize H (fin_prod_fin_equiv (⟨0, hN⟩, i)),
  rw function.funext_iff at H,
  specialize H (fin_prod_fin_equiv (⟨0, hN⟩, j)),
  dsimp only [basic_universal_map.mul, matrix.kronecker_map, add_monoid_hom.mk'_apply,
    matrix.reindex_linear_equiv_apply, matrix.reindex_apply, matrix.submatrix_apply] at H,
  simpa only [one_mul, equiv.symm_apply_apply, matrix.one_apply_eq] using H,
end

lemma mul_comp (N : ℕ) (g : basic_universal_map m n) (f : basic_universal_map l m) :
  mul N (comp g f) = comp (mul N g) (mul N f) :=
begin
  ext1 i j,
  dsimp only [mul, comp, add_monoid_hom.mk'_apply],
  rw [matrix.reindex_linear_equiv_mul, ← matrix.mul_kronecker_mul, matrix.one_mul],
end

def one_mul_hom (n) : basic_universal_map (1 * n) n :=
matrix.reindex_linear_equiv ℕ _
  ((fin_one_equiv.prod_congr $ equiv.refl _).trans $ equiv.punit_prod _)
  fin_prod_fin_equiv
  (1 : matrix (fin 1 × fin n) _ ℤ)

def one_mul_inv (n) : basic_universal_map n (1 * n) :=
matrix.reindex_linear_equiv ℕ _
  fin_prod_fin_equiv
  ((fin_one_equiv.prod_congr $ equiv.refl _).trans $ equiv.punit_prod _)
  (1 : matrix (fin 1 × fin n) _ ℤ)

lemma one_mul_hom_inv : comp (one_mul_hom n) (one_mul_inv n) = id n :=
begin
  dsimp only [comp, one_mul_hom, one_mul_inv, add_monoid_hom.mk'_apply, id],
  rw [matrix.reindex_linear_equiv_mul, matrix.one_mul, matrix.reindex_linear_equiv_one],
end

lemma one_mul_inv_hom : comp (one_mul_inv n) (one_mul_hom n) = id _ :=
begin
  dsimp only [comp, one_mul_hom, one_mul_inv, add_monoid_hom.mk'_apply, id],
  rw [matrix.reindex_linear_equiv_mul, matrix.one_mul, matrix.reindex_linear_equiv_one],
end

def mul_mul_hom (m n i : ℕ) : basic_universal_map (m * (n * i)) ((m * n) * i) :=
matrix.reindex_linear_equiv ℕ _
  (((equiv.refl _).prod_congr fin_prod_fin_equiv.symm).trans $
    (equiv.prod_assoc _ _ _).symm.trans $ (fin_prod_fin_equiv.prod_congr $ equiv.refl _).trans
      fin_prod_fin_equiv)
  fin_prod_fin_equiv
  (1 : matrix (fin m × fin (n * i)) (fin m × fin (n * i)) ℤ)

def mul_mul_inv (m n i : ℕ) : basic_universal_map ((m * n) * i) (m * (n * i)) :=
matrix.reindex_linear_equiv ℕ _
  fin_prod_fin_equiv
  (((equiv.refl _).prod_congr fin_prod_fin_equiv.symm).trans $
    (equiv.prod_assoc _ _ _).symm.trans $ (fin_prod_fin_equiv.prod_congr $ equiv.refl _).trans
      fin_prod_fin_equiv)
  (1 : matrix (fin m × fin (n * i)) (fin m × fin (n * i)) ℤ)

lemma mul_mul_hom_inv {m n i : ℕ} : comp (mul_mul_hom m n i) (mul_mul_inv m n i) = id _ :=
begin
  dsimp only [comp, mul_mul_hom, mul_mul_inv, add_monoid_hom.mk'_apply, id],
  rw [matrix.reindex_linear_equiv_mul, matrix.one_mul, matrix.reindex_linear_equiv_one],
end

lemma mul_mul_inv_hom {m n i : ℕ} : comp (mul_mul_inv m n i) (mul_mul_hom m n i) = id _ :=
begin
  dsimp only [comp, mul_mul_hom, mul_mul_inv, add_monoid_hom.mk'_apply, id],
  rw [matrix.reindex_linear_equiv_mul, matrix.one_mul, matrix.reindex_linear_equiv_one],
end

def proj_aux {N : ℕ} (k : fin N) : matrix punit.{1} (fin N) ℤ :=
λ i j, if j = k then 1 else 0

def proj (n : ℕ) {N : ℕ} (k : fin N) : basic_universal_map (N * n) n :=
matrix.reindex_linear_equiv ℕ _ (equiv.punit_prod _) fin_prod_fin_equiv $
(proj_aux k) ⊗ₖ 1

lemma proj_comp_mul {N : ℕ} (k : fin N) (f : basic_universal_map m n) :
  comp (proj n k) (mul N f) = comp f (proj m k) :=
begin
  dsimp only [comp, proj, mul, add_monoid_hom.mk'_apply],
  have : f = (matrix.reindex_linear_equiv
  ℕ _   (equiv.punit_prod (fin n)) (equiv.punit_prod (fin m)))
    ((1 : matrix punit.{1} punit.{1} ℤ) ⊗ₖ f),
  { ext i j,
    simp only [matrix.reindex_linear_equiv_apply, matrix.reindex_apply, matrix.submatrix_apply,
      equiv.punit_prod_symm_apply, matrix.kronecker, matrix.kronecker_apply,
      matrix.one_apply_eq, one_mul] },
  conv_rhs { rw this },
  rw [matrix.reindex_linear_equiv_mul, matrix.reindex_linear_equiv_mul],
  simp only [←matrix.mul_kronecker_mul, matrix.kronecker, matrix.mul_one, matrix.one_mul],
end

lemma one_mul_hom_eq_proj : basic_universal_map.one_mul_hom n = basic_universal_map.proj n 0 :=
begin
  dsimp only [basic_universal_map.one_mul_hom, basic_universal_map.proj],
  rw [← linear_equiv.symm_apply_eq, matrix.reindex_linear_equiv_symm,
    matrix.reindex_linear_equiv_comp_apply, equiv.self_trans_symm, equiv.trans_assoc,
    equiv.self_trans_symm, equiv.trans_refl],
  ext ⟨i, i'⟩ ⟨j, j'⟩ : 2,
  change fin 1 at j,
  dsimp only [matrix.reindex_linear_equiv_apply, matrix.kronecker],
  dsimp [fin_one_equiv, equiv.prod_congr_left, basic_universal_map.proj_aux],
  simp only [matrix.one_apply, prod.mk.inj_iff, @eq_comm _ _ j],
  simp only [true_and, mul_boole, if_true, prod.mk.inj_iff,
    eq_self_iff_true, eq_iff_true_of_subsingleton],
end
.

lemma proj_aux_kronecker_proj_aux (a : fin m) (b : fin n) :
  (proj_aux a) ⊗ₖ (proj_aux b) =
  matrix.reindex_linear_equiv ℕ _ (equiv.prod_punit _).symm fin_prod_fin_equiv.symm
    (proj_aux (fin_prod_fin_equiv (a,b))) :=
begin
  ext ⟨i, i'⟩ ⟨j, j'⟩ : 2,
  dsimp [matrix.reindex_linear_equiv_apply, matrix.kronecker, proj_aux],
  simp only [equiv.apply_eq_iff_eq, boole_mul, prod.mk.inj_iff, ← ite_and],
end

lemma proj_aux_apply (a : fin m) (b : fin m) : proj_aux a punit.star b = ite (a = b) 1 0 :=
begin
  by_cases h : a = b,
  rw if_pos,
  assumption',
  all_goals { simp only [proj_aux, zero_ne_one, ite_eq_left_iff], finish },
end

lemma comp_proj_mul_proj (n N : ℕ) (j : fin (2 * 2 ^ N)) :
  (comp (proj n ((fin_prod_fin_equiv.symm) j).fst)) (mul 2 (proj n ((fin_prod_fin_equiv.symm) j).snd)) =
  (comp (proj n j)) (mul_mul_hom 2 (2 ^ N) n) :=
begin
  dsimp only [mul_mul_hom, proj, comp, mul_apply, add_monoid_hom.mk'_apply],
  rw [matrix.reindex_linear_equiv_mul, ← matrix.mul_kronecker_mul, matrix.one_mul,
    matrix.mul_one, matrix.mul_reindex_linear_equiv_one],
  simp only [matrix.reindex_linear_equiv_apply, matrix.reindex_apply, function.comp.right_id,
    matrix.submatrix_submatrix, equiv.refl_symm, equiv.coe_refl],
  ext x y,
  dsimp [matrix.submatrix, - fin_prod_fin_equiv_symm_apply],
  rw [matrix.one_apply, matrix.one_apply],
  simp only [mul_boole, mul_ite, mul_zero, equiv.symm_apply_apply, mul_one],
  congr' 2,
  simp only [proj_aux_apply, boole_mul],
  rw [← ite_and],
  congr' 1,
  rw [← prod.mk.inj_iff, prod.mk.eta, equiv.symm_apply_eq],
end

end basic_universal_map

/-- A `universal_map m n` is a formal `ℤ`-linear combination
of `basic_universal_map`s.
It captures the data for a homomorphism `ℤ[A^m] → ℤ[A^n]`. -/
@[derive add_comm_group]
def universal_map (m n : ℕ) := ℤ[basic_universal_map m n]

namespace universal_map
universe variable u

variables {k l m n : ℕ} (g : universal_map m n) (f : universal_map l m)
variables (A : Type u) [add_comm_group A]

/-- `f.eval A` for a `f : universal_map m n`
is the homomorphism `ℤ[A^m] →+ ℤ[A^n]` induced by matrix multiplication
of the summands occurring in the formal linear combination `f`. -/
def eval : universal_map m n →+ ℤ[A^m] →+ ℤ[A^n] :=
free_abelian_group.lift $ λ (f : basic_universal_map m n), f.eval A

@[simp] lemma eval_of (f : basic_universal_map m n) :
  eval A (of f) = f.eval A :=
lift.of _ _

/-- The composition of `universal_map`s `g` and `f`,
given by the formal linear combination of all compositions
of summands occurring in `g` and `f`. -/
def comp : universal_map m n →+ universal_map l m →+ universal_map l n :=
free_abelian_group.lift $ λ (g : basic_universal_map m n), free_abelian_group.lift $ λ f,
of $ basic_universal_map.comp g f

@[simp] lemma comp_of (g : basic_universal_map m n) (f : basic_universal_map l m) :
  comp (of g) (of f) = of (basic_universal_map.comp g f) :=
by rw [comp, lift.of, lift.of]

section
open add_monoid_hom

lemma eval_comp : eval A (comp g f) = (eval A g).comp (eval A f) :=
show comp_hom (comp_hom (@eval l n A _)) (comp) g f =
  comp_hom (comp_hom (comp_hom.flip (@eval l m A _)) (comp_hom)) (@eval m n A _) g f,
begin
  congr' 2, clear f g, ext g f : 2,
  show eval A (comp (of g) (of f)) = (eval A (of g)).comp (eval A (of f)),
  simp only [basic_universal_map.eval_comp, comp_of, eval_of]
end

lemma comp_assoc (h : universal_map m n) (g : universal_map l m) (f : universal_map k l) :
  comp (comp h g) f = comp h (comp g f) :=
show comp_hom (comp_hom (@comp k l n)) (@comp l m n) h g f =
     comp_hom (comp_hom (comp_hom.flip (@comp k l m)) (comp_hom)) (@comp k m n) h g f,
begin
  congr' 3, clear h g f, ext h g f : 3,
  show comp (comp (of h) (of g)) (of f) = comp (of h) (comp (of g) (of f)),
  simp only [basic_universal_map.comp_assoc, comp_of]
end

/-- The identity `universal_map`. -/
def id (n : ℕ) : universal_map n n := of (basic_universal_map.id n)

@[simp] lemma id_comp : comp (id _) f = f :=
show comp (id _) f = add_monoid_hom.id _ f,
begin
  congr' 1, clear f, ext1 f,
  simp only [id, comp_of, id_apply, basic_universal_map.id_comp]
end

@[simp] lemma comp_id : comp g (id _) = g :=
show (@comp m m n).flip (id _) g = add_monoid_hom.id _ g,
begin
  congr' 1, clear g, ext1 g,
  show comp (of g) (id _) = (of g),
  simp only [id, comp_of, id_apply, basic_universal_map.comp_id]
end

def bound : ℕ := ∑ g in f.support, (free_abelian_group.coeff g f).nat_abs

def bound_by (N : ℕ) : Prop := f.bound ≤ N

lemma of_bound_by (f : basic_universal_map m n) : bound_by (of f) 1 :=
begin
  simp only [bound_by, bound, coeff_of_self, int.nat_abs_one, finset.sum_singleton, support_of],
end

lemma zero_bound_by (N : ℕ) : (0 : universal_map m n).bound_by N :=
by simp only [bound_by, bound, zero_le', finset.sum_const_zero,
    add_monoid_hom.map_zero, int.nat_abs_zero]

lemma zero_bound_by_zero : (0 : universal_map m n).bound_by 0 :=
zero_bound_by _

lemma bound_by.random_index {f : universal_map m n} {N : ℕ}
  (hf : f.bound_by N) (s : finset (basic_universal_map m n)) :
  ∑ g in s, (free_abelian_group.coeff g f).nat_abs ≤ N :=
begin
  calc ∑ g in s, (free_abelian_group.coeff g f).nat_abs
      = ∑ g in s ∩ f.support, (free_abelian_group.coeff g f).nat_abs +
        ∑ g in s \ f.support, (free_abelian_group.coeff g f).nat_abs : _
  ... = ∑ g in s ∩ f.support, (free_abelian_group.coeff g f).nat_abs : _
  ... ≤ ∑ g in f.support ∩ s, (free_abelian_group.coeff g f).nat_abs +
        ∑ g in f.support \ s, (free_abelian_group.coeff g f).nat_abs : _
  ... ≤ ∑ g in f.support, (free_abelian_group.coeff g f).nat_abs : _
  ... ≤ N : hf,
  { rw finset.sum_inter_add_sum_diff },
  { simp only [and_imp, add_right_eq_self, int.nat_abs_eq_zero, imp_self, imp_true_iff,
      finset.mem_sdiff, finset.sum_eq_zero_iff, free_abelian_group.not_mem_support_iff] },
  { rw finset.inter_comm, simp only [le_add_iff_nonneg_right, zero_le'], },
  { rw finset.sum_inter_add_sum_diff },
end

lemma bound_by.add {f₁ f₂ : universal_map m n} {N₁ N₂ : ℕ}
  (h₁ : f₁.bound_by N₁) (h₂ : f₂.bound_by N₂) :
  (f₁ + f₂).bound_by (N₁ + N₂) :=
begin
  calc (f₁ + f₂).bound ≤
      ∑ (g : basic_universal_map m n) in support (f₁ + f₂),
        ((coeff g f₁).nat_abs + (coeff g f₂).nat_abs) : finset.sum_le_sum _
  ... ≤ N₁ + N₂ : _,
  { intros g hg,
    rw add_monoid_hom.map_add,
    apply int.nat_abs_add_le },
  { rw finset.sum_add_distrib,
    exact add_le_add (h₁.random_index _) (h₂.random_index _) }
end

lemma bound_by_sum {ι : Type*} (s : finset ι) (f : ι → universal_map m n) (N : ι → ℕ)
  (h : ∀ i ∈ s, (f i).bound_by (N i)) :
  (∑ i in s, f i).bound_by (∑ i in s, N i) :=
begin
  classical,
  revert h,
  apply finset.induction_on s; clear s,
  { simp only [finset.not_mem_empty, is_empty.forall_iff, finset.sum_empty,
      implies_true_iff, forall_true_left],
    exact zero_bound_by_zero },
  { intros i s his IH h,
    simp only [finset.sum_insert his],
    exact (h i $ s.mem_insert_self i).add (IH $ λ j hj, h j $ finset.mem_insert_of_mem hj) }
end

end

section mul
open add_monoid_hom

/-
TODO: refactor `mul` to be a functor
TODO: put a monoidal structure on `FreeMat`, so that this is just `N ⊗ _`.
-/

def mul (N : ℕ) : universal_map m n →+ universal_map (N * m) (N * n) :=
map (basic_universal_map.mul N)

lemma mul_of (N : ℕ) (f : basic_universal_map m n) :
  mul N (of f) = of (basic_universal_map.mul N f) :=
map_of_apply _

lemma mul_comp (N : ℕ) (g : universal_map m n) (f : universal_map l m) :
  mul N (comp g f) = comp (mul N g) (mul N f) :=
begin
  simp only [← add_monoid_hom.comp_apply],
  rw [← add_monoid_hom.comp_hom_apply_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.flip_apply _ _ (mul N)],
  simp only [← add_monoid_hom.comp_apply],
  rw [← add_monoid_hom.comp_hom_apply_apply, ← add_monoid_hom.comp_hom_apply_apply],
  congr' 2, clear f g, ext g f,
  show (mul N) ((comp (of g)) (of f)) = (comp ((mul N) (of g))) ((mul N) (of f)),
  simp only [comp_of, mul_of, basic_universal_map.mul_comp],
end

lemma mem_support_mul (N : ℕ) (hN : 0 < N) (f : universal_map m n) (g) :
  g ∈ (mul N f).support ↔ ∃ g', g' ∈ f.support ∧ g = basic_universal_map.mul N g' :=
begin
  apply free_abelian_group.mem_support_map,
  exact basic_universal_map.mul_injective N hN
end

@[simp]
lemma coeff_mul (N : ℕ) (hN : 0 < N) (f : universal_map m n) (g : basic_universal_map m n) :
  coeff (basic_universal_map.mul N g) (mul N f) = coeff g f :=
begin
  simp only [← add_monoid_hom.comp_apply],
  rw [← add_monoid_hom.comp_hom_apply_apply],
  congr' 1, clear f, ext f,
  simp only [comp_hom_apply_apply, function.comp_app, coe_comp, mul, coeff, to_finsupp_of,
    map_of_apply, finsupp.apply_add_hom_apply, finsupp.single_apply,
    (basic_universal_map.mul_injective N hN).eq_iff],
end

end mul

/-
TODO: refactor `sum` and `proj` to be natural transformations from `mul n` to `𝟭 _`.
-/

def sum (n N : ℕ) : universal_map (N * n) n :=
of (∑ i, basic_universal_map.proj n i)

def proj (n N : ℕ) : universal_map (N * n) n :=
∑ i, of (basic_universal_map.proj n i)

lemma sum_comp_mul (N : ℕ) (f : universal_map m n) :
  comp (sum n N) (mul N f) = comp f (sum m N) :=
begin
  simp only [← add_monoid_hom.comp_apply],
  rw [← add_monoid_hom.comp_hom_apply_apply, ← add_monoid_hom.flip_apply _ _ (sum m N)],
  simp only [← add_monoid_hom.comp_apply],
  congr' 1, clear f, ext f,
  show (comp (sum n N)) ((mul N) (of f)) = (comp (of f)) (sum m N),
  simp only [sum, mul_of, comp_of, add_monoid_hom.map_sum,
    add_monoid_hom.finset_sum_apply, basic_universal_map.proj_comp_mul],
end

lemma proj_comp_mul (N : ℕ) (f : universal_map m n) :
  comp (proj n N) (mul N f) = comp f (proj m N) :=
begin
  simp only [← add_monoid_hom.comp_apply],
  rw [← add_monoid_hom.comp_hom_apply_apply, ← add_monoid_hom.flip_apply _ _ (proj m N)],
  simp only [← add_monoid_hom.comp_apply],
  congr' 1, clear f, ext f,
  show (comp (proj n N)) ((mul N) (of f)) = (comp (of f)) (proj m N),
  simp only [proj, mul_of, comp_of, add_monoid_hom.map_sum,
    add_monoid_hom.finset_sum_apply, basic_universal_map.proj_comp_mul],
end
.

lemma proj_bound_by (n N : ℕ) : (proj n N).bound_by N :=
le_trans (bound_by_sum _ _ _ $ λ i _, of_bound_by _) $
by simp only [finset.card_fin, mul_one, algebra.id.smul_eq_mul, finset.sum_const]

end universal_map

end breen_deligne

-- #lint- only unused_arguments def_lemma doc_blame


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Nathaniel Thomas

More examples to test automation, stolen shamelessly by Jeremy from Nathaniel's "tauto".
-/
import tactic.finish
open nat

section

variables (a b c d e f : Prop)
variable even : ℕ → Prop
variable P : ℕ → Prop

-- these next five are things that tauto doesn't get

example : (∀ x, P x) ∧ b → (∀ y, P y) ∧ P 0 ∨ b ∧ P 0 := by finish
example : (∀ A, A ∨ ¬A) → ∀ x y : ℕ, x = y ∨ x ≠ y := by finish
example : ∀ b1 b2, b1 = b2 ↔ (b1 = tt ↔ b2 = tt) := begin intro b1, cases b1; finish [iff_def] end

example : ∀ (P Q : nat → Prop), (∀ n, Q n → P n) → (∀ n, Q n) → P 2 := by finish
example (a b c : Prop) : ¬ true ∨ false ∨ b ↔ b := by finish

example : true := by finish

example : false → a := by finish
example : a → a := by finish
example : (a → b) → a → b := by finish
example : ¬ a → ¬ a := by finish
example : a → (false ∨ a) := by finish
example : (a → b → c) → (a → b) → a → c := by finish
example : a → ¬ a → (a → b) → (a ∨ b) → (a ∧ b) → a → false := by finish
example : ((a ∧ b) ∧ c) → b := by finish
example : ((a → b) → c) → b → c := by finish
example : (a ∨ b) → (b ∨ a) := by finish
example : (a → b ∧ c) → (a → b) ∨ (a → c) := by finish
example : ∀ (x0 : a ∨ b) (x1 : b ∧ c), a → b := by finish
example : a → b → (c ∨ b) := by finish
example : (a ∧ b → c) → b → a → c := by finish
example : (a ∨ b → c) → a → c := by finish
example : (a ∨ b → c) → b → c := by finish
example : (a ∧ b) → (b ∧ a) := by finish
example : (a ↔ b) → a → b := by finish
example : a → ¬¬a := by finish
example : ¬¬(a ∨ ¬a) := by finish
example : ¬¬(a ∨ b → a ∨ b) := by finish
example : ¬¬((∀ n, even n) ∨ ¬(∀ m, even m)) := by finish
example : (¬¬b → b) → (a → b) → ¬¬a → b := by finish
example : (¬¬b → b) → (¬b → ¬ a) → ¬¬a → b := by finish

example : ((a → b → false) → false) → (b → false) → false := by finish

example : ((((c → false) → a) → ((b → false) → a) → false) → false) →
            (((c → b → false) → false) → false) → ¬a → a := by finish

example (p q r : Prop) (a b : nat) : true → a = a → q → q → p → p := by finish
example : ∀ (F F' : Prop), F ∧ F' → F := by finish
example : ∀ (F1 F2 F3 : Prop), ((¬F1 ∧ F3) ∨ (F2 ∧ ¬F3)) → (F2 → F1) → (F2 → F3) →  ¬F2 := by finish
example : ∀ (f : nat → Prop), f 2 → ∃ x, f x := by finish
example : true ∧ true ∧ true ∧ true ∧ true ∧ true ∧ true := by finish
example : ∀ (P : nat → Prop), P 0 → (P 0 → P 1) → (P 1 → P 2) → (P 2) := by finish
example : ¬¬¬¬¬a → ¬¬¬¬¬¬¬¬a → false := by finish
example : ∀ n, ¬¬(even n ∨ ¬even n) := by finish
example : ∀ (p q r s : Prop) (a b : nat), r ∨ s → p ∨ q → a = b → q ∨ p := by finish
example : (∀ x, P x) → (∀ y, P y) := by finish

/- TODO(Jeremy): reinstate after simp * at * bug is fixed.
example : ((a ↔ b) → (b ↔ c)) → ((b ↔ c) → (c ↔ a)) → ((c ↔ a) → (a ↔ b)) → (a ↔ b) :=
by finish [iff_def]
-/

example : ((¬a ∨ b) ∧ (¬b ∨ b) ∧ (¬a ∨ ¬b) ∧ (¬b ∨ ¬b) → false) → ¬((a → b) → b) → false := by finish

example : ¬((a → b) → b) → ((¬b ∨ ¬b) ∧ (¬b ∨ ¬a) ∧ (b ∨ ¬b) ∧ (b ∨ ¬a) → false) → false := by finish
example : (¬a ↔ b) → (¬b ↔ a) → (¬¬a ↔ a) := by finish

example : (¬ a ↔ b) → (¬ (c ∨ e) ↔ d ∧ f) → (¬ (c ∨ a ∨ e) ↔ d ∧ b ∧ f) := by finish

example {A : Type} (p q : A → Prop) (a b : A) : q a → p b → ∃ x, (p x ∧ x = b) ∨ q x := by finish

example {A : Type} (p q : A → Prop) (a b : A) : p b → ∃ x, q x ∨ (p x ∧ x = b) := by finish

example : ¬ a → b → a → c := by finish
example : a → b → b → ¬ a → c := by finish
example (a b : nat) : a = b → b = a := by finish

-- good examples of things we don't get, even using the simplifier
example (a b c : nat) : a = b → a = c → b = c := by finish
example (p : nat → Prop) (a b c : nat) : a = b → a = c → p b → p c := by finish

example (p : Prop) (a b : nat) : a = b → p → p := by finish

-- safe should look for contradictions with constructors
example (a : nat) : (0 : ℕ) = succ a → a = a → false := by finish
example (p : Prop) (a b c : nat) : [a, b, c] = [] → p := by finish

example (a b c : nat) : succ (succ a) = succ (succ b) → c = c := by finish
example (p : Prop) (a b : nat) : a = b → b ≠ a → p := by finish
example : (a ↔ b) → ((b ↔ a) ↔ (a ↔ b)) := by finish
example (a b c : nat) : b = c → (a = b ↔ c = a) := by finish [iff_def]
example : ¬¬¬¬¬¬¬¬a → ¬¬¬¬¬a → false := by finish
example (a b c : Prop) : a ∧ b ∧ c ↔ c ∧ b ∧ a := by finish
example (a b c : Prop) : a ∧ false ∧ c ↔ false := by finish
example (a b c : Prop) : a ∨ false ∨ b ↔ b ∨ a := by finish
example : a ∧ not a ↔ false := by finish
example : a ∧ b ∧ true → b ∧ a := by finish
example (A : Type) (a₁ a₂ : A) : a₁ = a₂ →
  (λ (B : Type) (f : A → B), f a₁) = (λ (B : Type) (f : A → B), f a₂) := by finish
example (a : nat) : ¬ a = a → false := by finish
example (A : Type) (p : Prop) (a b c : A) : a = b → b ≠ a → p := by finish
example (p q r s : Prop) : r ∧ s → p ∧ q → q ∧ p := by finish
example (p q : Prop) : p ∧ p ∧ q ∧ q → q ∧ p := by finish
example (p : nat → Prop) (q : nat → nat → Prop) :
  (∃ x y, p x ∧ q x y) → q 0 0 ∧ q 1 1 → (∃ x, p x) := by finish
example (p q r s : Prop) (a b : nat) : r ∨ s → p ∨ q → a = b → q ∨ p := by finish
example (p q r : Prop) (a b : nat) : true → a = a → q → q → p → p := by finish
example (a b : Prop) : a → b → a := by finish
example (p q : nat → Prop) (a b : nat) : p a → q b → ∃ x, p x := by finish

example : ∀ b1 b2, b1 && b2 = ff ↔ (b1 = ff ∨ b2 = ff) := by finish
example : ∀ b1 b2, b1 && b2 = tt ↔ (b1 = tt ∧ b2 = tt) := by finish
example : ∀ b1 b2, b1 || b2 = ff ↔ (b1 = ff ∧ b2 = ff) := by finish
example : ∀ b1 b2, b1 || b2 = tt ↔ (b1 = tt ∨ b2 = tt) := by finish
example : ∀ b, bnot b = tt ↔ b = ff := by finish
example : ∀ b, bnot b = ff ↔ b = tt := by finish
example : ∀ b c, b = c ↔ ¬ (b = bnot c) := by intros b c; cases b; cases c; finish [iff_def]

inductive and3 (a b c : Prop) : Prop
| mk : a → b → c → and3

example (h : and3 a b c) : and3 b c a := by cases h; split; finish

inductive or3 (a b c : Prop) : Prop
| in1 : a → or3
| in2 : b → or3
| in3 : c → or3

/- TODO(Jeremy): write a tactic that tries all constructors
example (h : a) : or3 a b c := sorry
example (h : b) : or3 a b c := sorry
example (h : c) : or3 a b c := sorry
-/

variables (A₁ A₂ A₃ A₄ B₁ B₂ B₃ B₄ : Prop)
-- H first, all pos

example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) : B₄ := by finish
example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₄) : B₃ := by finish
example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n3 : ¬B₃) (n3 : ¬B₄) : B₂ := by finish
example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : B₁ := by finish

example (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : ¬A₃ := by finish
example (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : ¬A₂ := by finish
example (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : ¬A₁ := by finish

-- H last, all pos
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₄ := by finish
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₃ := by finish
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₂ := by finish
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₁ := by finish

example (a1 : A₁) (a2 : A₂) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : ¬A₃ := by finish
example (a1 : A₁) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : ¬A₂ := by finish
example (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : ¬A₁ := by finish

-- H first, all neg
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) : ¬B₄ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b4 : B₄) : ¬B₃ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b3 : B₃) (b4 : B₄) : ¬B₂ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬B₁ := by finish

example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬¬A₃ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬¬A₂ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬¬A₁ := by finish

-- H last, all neg
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₄ := by finish
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₃ := by finish
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₂ := by finish
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₁ := by finish

example (n1 : ¬A₁) (n2 : ¬A₂) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬¬A₃ := by finish
example (n1 : ¬A₁) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬¬A₂ := by finish
example (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬¬A₁ := by finish

section club
variables Scottish RedSocks WearKilt Married GoOutSunday : Prop
theorem NoMember : (¬Scottish → RedSocks) → (WearKilt ∨ ¬RedSocks) → (Married → ¬GoOutSunday) →
                 (GoOutSunday ↔ Scottish) → (WearKilt → Scottish ∧ Married) →
                 (Scottish → WearKilt) → false := by finish
end club

end


/-
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

! This file was ported from Lean 3 source module category_theory.category.Bipointed
! leanprover-community/mathlib commit c8ab806ef73c20cab1d87b5157e43a82c205f28e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Category.Pointed

/-!
# The category of bipointed types

This defines `Bipointed`, the category of bipointed types.

## TODO

Monoidal structure
-/

open CategoryTheory

universe u

variable {α β : Type _}

set_option linter.uppercaseLean3 false

/-- The category of bipointed types. -/
structure Bipointed : Type (u + 1) where
  X : Type u
  toProd : X × X
#align Bipointed Bipointed

namespace Bipointed

instance : CoeSort Bipointed (Type _) :=
  ⟨X⟩

-- porting note: protected attribute does not work
-- attribute [protected] Bipointed.X

/-- Turns a bipointing into a bipointed type. -/
def of {X : Type _} (to_prod : X × X) : Bipointed :=
  ⟨X, to_prod⟩
#align Bipointed.of Bipointed.of

@[simp]
theorem coe_of {X : Type _} (to_prod : X × X) : ↥(of to_prod) = X :=
  rfl
#align Bipointed.coe_of Bipointed.coe_of

alias of ← _root_.Prod.Bipointed
#align prod.Bipointed Prod.Bipointed

instance : Inhabited Bipointed :=
  ⟨of ((), ())⟩

/-- Morphisms in `Bipointed`. -/
@[ext]
protected structure Hom (X Y : Bipointed.{u}) : Type u where
  toFun : X → Y
  map_fst : toFun X.toProd.1 = Y.toProd.1
  map_snd : toFun X.toProd.2 = Y.toProd.2
#align Bipointed.hom Bipointed.Hom

namespace Hom

/-- The identity morphism of `X : Bipointed`. -/
@[simps]
nonrec def id (X : Bipointed) : Bipointed.Hom X X :=
  ⟨id, rfl, rfl⟩
#align Bipointed.hom.id Bipointed.Hom.id

instance (X : Bipointed) : Inhabited (Bipointed.Hom X X) :=
  ⟨id X⟩

/-- Composition of morphisms of `Bipointed`. -/
@[simps]
def comp {X Y Z : Bipointed.{u}} (f : Bipointed.Hom X Y) (g : Bipointed.Hom Y Z) :
    Bipointed.Hom X Z :=
  ⟨g.toFun ∘ f.toFun, by rw [Function.comp_apply, f.map_fst, g.map_fst], by
    rw [Function.comp_apply, f.map_snd, g.map_snd]⟩
#align Bipointed.hom.comp Bipointed.Hom.comp

end Hom

instance largeCategory : LargeCategory Bipointed where
  Hom := Bipointed.Hom
  id := Hom.id
  comp := @Hom.comp
#align Bipointed.large_category Bipointed.largeCategory

instance concreteCategory : ConcreteCategory Bipointed where
  Forget :=
    { obj := Bipointed.X
      map := @Hom.toFun }
  forget_faithful := ⟨@Hom.ext⟩
#align Bipointed.concrete_category Bipointed.concreteCategory

/-- Swaps the pointed elements of a bipointed type. `Prod.swap` as a functor. -/
@[simps]
def swap : Bipointed ⥤ Bipointed where
  obj X := ⟨X, X.toProd.swap⟩
  map f := ⟨f.toFun, f.map_snd, f.map_fst⟩
#align Bipointed.swap Bipointed.swap

/-- The equivalence between `Bipointed` and itself induced by `Prod.swap` both ways. -/
@[simps!]
def swapEquiv : Bipointed ≌ Bipointed :=
  CategoryTheory.Equivalence.mk swap swap
    (NatIso.ofComponents
      (fun X =>
        { hom := ⟨id, rfl, rfl⟩
          inv := ⟨id, rfl, rfl⟩ })
      fun f => rfl)
    (NatIso.ofComponents
      (fun X =>
        { hom := ⟨id, rfl, rfl⟩
          inv := ⟨id, rfl, rfl⟩ })
      fun f => rfl)
#align Bipointed.swap_equiv Bipointed.swapEquiv

@[simp]
theorem swapEquiv_symm : swapEquiv.symm = swapEquiv :=
  rfl
#align Bipointed.swap_equiv_symm Bipointed.swapEquiv_symm

end Bipointed

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the second point. -/
def bipointedToPointedFst : Bipointed ⥤ Pointed where
  obj X := ⟨X, X.toProd.1⟩
  map f := ⟨f.toFun, f.map_fst⟩
#align Bipointed_to_Pointed_fst bipointedToPointedFst

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the first point. -/
def bipointedToPointedSnd : Bipointed ⥤ Pointed where
  obj X := ⟨X, X.toProd.2⟩
  map f := ⟨f.toFun, f.map_snd⟩
#align Bipointed_to_Pointed_snd bipointedToPointedSnd

@[simp]
theorem bipointedToPointedFst_comp_forget :
    bipointedToPointedFst ⋙ forget Pointed = forget Bipointed :=
  rfl
#align Bipointed_to_Pointed_fst_comp_forget bipointedToPointedFst_comp_forget

@[simp]
theorem bipointedToPointedSnd_comp_forget :
    bipointedToPointedSnd ⋙ forget Pointed = forget Bipointed :=
  rfl
#align Bipointed_to_Pointed_snd_comp_forget bipointedToPointedSnd_comp_forget

@[simp]
theorem swap_comp_bipointedToPointedFst :
    Bipointed.swap ⋙ bipointedToPointedFst = bipointedToPointedSnd :=
  rfl
#align swap_comp_Bipointed_to_Pointed_fst swap_comp_bipointedToPointedFst

@[simp]
theorem swap_comp_bipointedToPointedSnd :
    Bipointed.swap ⋙ bipointedToPointedSnd = bipointedToPointedFst :=
  rfl
#align swap_comp_Bipointed_to_Pointed_snd swap_comp_bipointedToPointedSnd

/-- The functor from `Pointed` to `Bipointed` which bipoints the point. -/
def pointedToBipointed : Pointed.{u} ⥤ Bipointed where
  obj X := ⟨X, X.point, X.point⟩
  map f := ⟨f.toFun, f.map_point, f.map_point⟩
#align Pointed_to_Bipointed pointedToBipointed

/-- The functor from `Pointed` to `Bipointed` which adds a second point. -/
def pointedToBipointedFst : Pointed.{u} ⥤ Bipointed where
  obj X := ⟨Option X, X.point, none⟩
  map f := ⟨Option.map f.toFun, congr_arg _ f.map_point, rfl⟩
  map_id _ := Bipointed.Hom.ext _ _ Option.map_id
  map_comp f g := Bipointed.Hom.ext _ _ (Option.map_comp_map f.1 g.1).symm
#align Pointed_to_Bipointed_fst pointedToBipointedFst

/-- The functor from `Pointed` to `Bipointed` which adds a first point. -/
def pointedToBipointedSnd : Pointed.{u} ⥤ Bipointed where
  obj X := ⟨Option X, none, X.point⟩
  map f := ⟨Option.map f.toFun, rfl, congr_arg _ f.map_point⟩
  map_id _ := Bipointed.Hom.ext _ _ Option.map_id
  map_comp f g := Bipointed.Hom.ext _ _ (Option.map_comp_map f.1 g.1).symm
#align Pointed_to_Bipointed_snd pointedToBipointedSnd

@[simp]
theorem pointedToBipointedFst_comp_swap :
    pointedToBipointedFst ⋙ Bipointed.swap = pointedToBipointedSnd :=
  rfl
#align Pointed_to_Bipointed_fst_comp_swap pointedToBipointedFst_comp_swap

@[simp]
theorem pointedToBipointedSnd_comp_swap :
    pointedToBipointedSnd ⋙ Bipointed.swap = pointedToBipointedFst :=
  rfl
#align Pointed_to_Bipointed_snd_comp_swap pointedToBipointedSnd_comp_swap

/-- `BipointedToPointed_fst` is inverse to `PointedToBipointed`. -/
@[simps!]
def pointedToBipointedCompBipointedToPointedFst :
    pointedToBipointed ⋙ bipointedToPointedFst ≅ 𝟭 _ :=
  NatIso.ofComponents
    (fun X =>
      { hom := ⟨id, rfl⟩
        inv := ⟨id, rfl⟩ })
    fun f => rfl
#align Pointed_to_Bipointed_comp_Bipointed_to_Pointed_fst pointedToBipointedCompBipointedToPointedFst

/-- `BipointedToPointed_snd` is inverse to `PointedToBipointed`. -/
@[simps!]
def pointedToBipointedCompBipointedToPointedSnd :
    pointedToBipointed ⋙ bipointedToPointedSnd ≅ 𝟭 _ :=
  NatIso.ofComponents
    (fun X =>
      { hom := ⟨id, rfl⟩
        inv := ⟨id, rfl⟩ })
    fun f => rfl
#align Pointed_to_Bipointed_comp_Bipointed_to_Pointed_snd pointedToBipointedCompBipointedToPointedSnd

/-- The free/forgetful adjunction between `PointedToBipointed_fst` and `BipointedToPointed_fst`.
-/
def pointedToBipointedFstBipointedToPointedFstAdjunction :
    pointedToBipointedFst ⊣ bipointedToPointedFst :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X Y =>
        { toFun := fun f => ⟨f.toFun ∘ Option.some, f.map_fst⟩
          invFun := fun f => ⟨fun o => o.elim Y.toProd.2 f.toFun, f.map_point, rfl⟩
          left_inv := fun f => by
            apply Bipointed.Hom.ext
            funext x
            cases x
            · exact f.map_snd.symm
            · rfl
          right_inv := fun f => Pointed.Hom.ext _ _ rfl }
      homEquiv_naturality_left_symm := fun f g => by
        apply Bipointed.Hom.ext
        funext x
        cases x <;> rfl }
#align Pointed_to_Bipointed_fst_Bipointed_to_Pointed_fst_adjunction pointedToBipointedFstBipointedToPointedFstAdjunction

/-- The free/forgetful adjunction between `PointedToBipointed_snd` and `BipointedToPointed_snd`.
-/
def pointedToBipointedSndBipointedToPointedSndAdjunction :
    pointedToBipointedSnd ⊣ bipointedToPointedSnd :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X Y =>
        { toFun := fun f => ⟨f.toFun ∘ Option.some, f.map_snd⟩
          invFun := fun f => ⟨fun o => o.elim Y.toProd.1 f.toFun, rfl, f.map_point⟩
          left_inv := fun f => by
            apply Bipointed.Hom.ext
            funext x
            cases x
            · exact f.map_fst.symm
            · rfl
          right_inv := fun f => Pointed.Hom.ext _ _ rfl }
      homEquiv_naturality_left_symm := fun f g => by
        apply Bipointed.Hom.ext
        funext x
        cases x <;> rfl }
#align Pointed_to_Bipointed_snd_Bipointed_to_Pointed_snd_adjunction pointedToBipointedSndBipointedToPointedSndAdjunction