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

! This file was ported from Lean 3 source module model_theory.direct_limit
! leanprover-community/mathlib commit f53b23994ac4c13afa38d31195c588a1121d1860
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Order
import Mathbin.Algebra.DirectLimit
import Mathbin.ModelTheory.Quotients
import Mathbin.ModelTheory.FinitelyGenerated

/-!
# Direct Limits of First-Order Structures
This file constructs the direct limit of a directed system of first-order embeddings.

## Main Definitions
* `first_order.language.direct_limit G f`  is the direct limit of the directed system `f` of
  first-order embeddings between the structures indexed by `G`.
-/

universe v w u₁ u₂

open FirstOrder

namespace FirstOrder

namespace Language

open Structure Set

variable {L : Language} {ι : Type v} [Preorder ι]

variable {G : ι → Type w} [∀ i, L.Structure (G i)]

variable (f : ∀ i j, i ≤ j → G i ↪[L] G j)

namespace DirectedSystem

/-- A copy of `directed_system.map_self` specialized to `L`-embeddings, as otherwise the
`λ i j h, f i j h` can confuse the simplifier. -/
theorem map_self [DirectedSystem G fun i j h => f i j h] (i x h) : f i i h x = x :=
  DirectedSystem.map_self (fun i j h => f i j h) i x h
#align first_order.language.directed_system.map_self FirstOrder.Language.DirectedSystem.map_self

/-- A copy of `directed_system.map_map` specialized to `L`-embeddings, as otherwise the
`λ i j h, f i j h` can confuse the simplifier. -/
theorem map_map [DirectedSystem G fun i j h => f i j h] {i j k} (hij hjk x) :
    f j k hjk (f i j hij x) = f i k (le_trans hij hjk) x :=
  DirectedSystem.map_map (fun i j h => f i j h) hij hjk x
#align first_order.language.directed_system.map_map FirstOrder.Language.DirectedSystem.map_map

variable {G' : ℕ → Type w} [∀ i, L.Structure (G' i)] (f' : ∀ n : ℕ, G' n ↪[L] G' (n + 1))

/-- Given a chain of embeddings of structures indexed by `ℕ`, defines a `directed_system` by
composing them. -/
def natLeRec (m n : ℕ) (h : m ≤ n) : G' m ↪[L] G' n :=
  Nat.leRecOn h (fun k g => (f' k).comp g) (Embedding.refl L _)
#align first_order.language.directed_system.nat_le_rec FirstOrder.Language.DirectedSystem.natLeRec

@[simp]
theorem coe_natLeRec (m n : ℕ) (h : m ≤ n) :
    (natLeRec f' m n h : G' m → G' n) = Nat.leRecOn h fun n => f' n :=
  by
  obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le h
  ext x
  induction' k with k ih
  · rw [nat_le_rec, Nat.leRecOn_self, embedding.refl_apply, Nat.leRecOn_self]
  ·
    rw [Nat.leRecOn_succ le_self_add, nat_le_rec, Nat.leRecOn_succ le_self_add, ← nat_le_rec,
      embedding.comp_apply, ih]
#align first_order.language.directed_system.coe_nat_le_rec FirstOrder.Language.DirectedSystem.coe_natLeRec

instance natLeRec.directedSystem : DirectedSystem G' fun i j h => natLeRec f' i j h :=
  ⟨fun i x h => congr (congr rfl (Nat.leRecOn_self _)) rfl, fun i j k ij jk => by
    simp [Nat.leRecOn_trans ij jk]⟩
#align first_order.language.directed_system.nat_le_rec.directed_system FirstOrder.Language.DirectedSystem.natLeRec.directedSystem

end DirectedSystem

namespace DirectLimit

/-- Raises a family of elements in the `Σ`-type to the same level along the embeddings. -/
def unify {α : Type _} (x : α → Σi, G i) (i : ι) (h : i ∈ upperBounds (range (Sigma.fst ∘ x)))
    (a : α) : G i :=
  f (x a).1 i (h (mem_range_self a)) (x a).2
#align first_order.language.direct_limit.unify FirstOrder.Language.DirectLimit.unify

variable [DirectedSystem G fun i j h => f i j h]

@[simp]
theorem unify_sigma_mk_self {α : Type _} {i : ι} {x : α → G i} :
    (unify f (Sigma.mk i ∘ x) i fun j ⟨a, hj⟩ => trans (le_of_eq hj.symm) (refl _)) = x :=
  by
  ext a
  simp only [unify, DirectedSystem.map_self]
#align first_order.language.direct_limit.unify_sigma_mk_self FirstOrder.Language.DirectLimit.unify_sigma_mk_self

theorem comp_unify {α : Type _} {x : α → Σi, G i} {i j : ι} (ij : i ≤ j)
    (h : i ∈ upperBounds (range (Sigma.fst ∘ x))) :
    f i j ij ∘ unify f x i h = unify f x j fun k hk => trans (mem_upperBounds.1 h k hk) ij :=
  by
  ext a
  simp [unify, DirectedSystem.map_map]
#align first_order.language.direct_limit.comp_unify FirstOrder.Language.DirectLimit.comp_unify

end DirectLimit

variable (G)

namespace DirectLimit

/-- The directed limit glues together the structures along the embeddings. -/
def setoid [DirectedSystem G fun i j h => f i j h] [IsDirected ι (· ≤ ·)] : Setoid (Σi, G i)
    where
  R := fun ⟨i, x⟩ ⟨j, y⟩ => ∃ (k : ι)(ik : i ≤ k)(jk : j ≤ k), f i k ik x = f j k jk y
  iseqv :=
    ⟨fun ⟨i, x⟩ => ⟨i, refl i, refl i, rfl⟩, fun ⟨i, x⟩ ⟨j, y⟩ ⟨k, ik, jk, h⟩ =>
      ⟨k, jk, ik, h.symm⟩, fun ⟨i, x⟩ ⟨j, y⟩ ⟨k, z⟩ ⟨ij, hiij, hjij, hij⟩ ⟨jk, hjjk, hkjk, hjk⟩ =>
      by
      obtain ⟨ijk, hijijk, hjkijk⟩ := directed_of (· ≤ ·) ij jk
      refine' ⟨ijk, le_trans hiij hijijk, le_trans hkjk hjkijk, _⟩
      rw [← DirectedSystem.map_map, hij, DirectedSystem.map_map]
      symm
      rw [← DirectedSystem.map_map, ← hjk, DirectedSystem.map_map]⟩
#align first_order.language.direct_limit.setoid FirstOrder.Language.DirectLimit.setoid

/-- The structure on the `Σ`-type which becomes the structure on the direct limit after quotienting.
 -/
noncomputable def sigmaStructure [IsDirected ι (· ≤ ·)] [Nonempty ι] : L.Structure (Σi, G i)
    where
  funMap n F x :=
    ⟨_,
      funMap F
        (unify f x (Classical.choose (Fintype.bddAbove_range fun a => (x a).1))
          (Classical.choose_spec (Fintype.bddAbove_range fun a => (x a).1)))⟩
  rel_map n R x :=
    RelMap R
      (unify f x (Classical.choose (Fintype.bddAbove_range fun a => (x a).1))
        (Classical.choose_spec (Fintype.bddAbove_range fun a => (x a).1)))
#align first_order.language.direct_limit.sigma_structure FirstOrder.Language.DirectLimit.sigmaStructure

end DirectLimit

/-- The direct limit of a directed system is the structures glued together along the embeddings. -/
def DirectLimit [DirectedSystem G fun i j h => f i j h] [IsDirected ι (· ≤ ·)] :=
  Quotient (DirectLimit.setoid G f)
#align first_order.language.direct_limit FirstOrder.Language.DirectLimit

attribute [local instance] direct_limit.setoid

instance [DirectedSystem G fun i j h => f i j h] [IsDirected ι (· ≤ ·)] [Inhabited ι]
    [Inhabited (G default)] : Inhabited (DirectLimit G f) :=
  ⟨⟦⟨default, default⟩⟧⟩

namespace DirectLimit

variable [IsDirected ι (· ≤ ·)] [DirectedSystem G fun i j h => f i j h]

theorem equiv_iff {x y : Σi, G i} {i : ι} (hx : x.1 ≤ i) (hy : y.1 ≤ i) :
    x ≈ y ↔ (f x.1 i hx) x.2 = (f y.1 i hy) y.2 :=
  by
  cases x
  cases y
  refine' ⟨fun xy => _, fun xy => ⟨i, hx, hy, xy⟩⟩
  obtain ⟨j, _, _, h⟩ := xy
  obtain ⟨k, ik, jk⟩ := directed_of (· ≤ ·) i j
  have h := congr_arg (f j k jk) h
  apply (f i k ik).Injective
  rw [DirectedSystem.map_map, DirectedSystem.map_map] at *
  exact h
#align first_order.language.direct_limit.equiv_iff FirstOrder.Language.DirectLimit.equiv_iff

theorem funMap_unify_equiv {n : ℕ} (F : L.Functions n) (x : Fin n → Σi, G i) (i j : ι)
    (hi : i ∈ upperBounds (range (Sigma.fst ∘ x))) (hj : j ∈ upperBounds (range (Sigma.fst ∘ x))) :
    (⟨i, funMap F (unify f x i hi)⟩ : Σi, G i) ≈ ⟨j, funMap F (unify f x j hj)⟩ :=
  by
  obtain ⟨k, ik, jk⟩ := directed_of (· ≤ ·) i j
  refine' ⟨k, ik, jk, _⟩
  rw [(f i k ik).map_fun, (f j k jk).map_fun, comp_unify, comp_unify]
#align first_order.language.direct_limit.fun_map_unify_equiv FirstOrder.Language.DirectLimit.funMap_unify_equiv

theorem relMap_unify_equiv {n : ℕ} (R : L.Relations n) (x : Fin n → Σi, G i) (i j : ι)
    (hi : i ∈ upperBounds (range (Sigma.fst ∘ x))) (hj : j ∈ upperBounds (range (Sigma.fst ∘ x))) :
    RelMap R (unify f x i hi) = RelMap R (unify f x j hj) :=
  by
  obtain ⟨k, ik, jk⟩ := directed_of (· ≤ ·) i j
  rw [← (f i k ik).map_rel, comp_unify, ← (f j k jk).map_rel, comp_unify]
#align first_order.language.direct_limit.rel_map_unify_equiv FirstOrder.Language.DirectLimit.relMap_unify_equiv

variable [Nonempty ι]

theorem exists_unify_eq {α : Type _} [Fintype α] {x y : α → Σi, G i} (xy : x ≈ y) :
    ∃ (i : ι)(hx : i ∈ upperBounds (range (Sigma.fst ∘ x)))(hy :
      i ∈ upperBounds (range (Sigma.fst ∘ y))), unify f x i hx = unify f y i hy :=
  by
  obtain ⟨i, hi⟩ := Fintype.bddAbove_range (Sum.elim (fun a => (x a).1) fun a => (y a).1)
  rw [sum.elim_range, upperBounds_union] at hi
  simp_rw [← Function.comp_apply Sigma.fst _] at hi
  exact ⟨i, hi.1, hi.2, funext fun a => (equiv_iff G f _ _).1 (xy a)⟩
#align first_order.language.direct_limit.exists_unify_eq FirstOrder.Language.DirectLimit.exists_unify_eq

theorem funMap_equiv_unify {n : ℕ} (F : L.Functions n) (x : Fin n → Σi, G i) (i : ι)
    (hi : i ∈ upperBounds (range (Sigma.fst ∘ x))) :
    @funMap _ _ (sigmaStructure G f) _ F x ≈ ⟨_, funMap F (unify f x i hi)⟩ :=
  funMap_unify_equiv G f F x (Classical.choose (Fintype.bddAbove_range fun a => (x a).1)) i _ hi
#align first_order.language.direct_limit.fun_map_equiv_unify FirstOrder.Language.DirectLimit.funMap_equiv_unify

theorem relMap_equiv_unify {n : ℕ} (R : L.Relations n) (x : Fin n → Σi, G i) (i : ι)
    (hi : i ∈ upperBounds (range (Sigma.fst ∘ x))) :
    @RelMap _ _ (sigmaStructure G f) _ R x = RelMap R (unify f x i hi) :=
  relMap_unify_equiv G f R x (Classical.choose (Fintype.bddAbove_range fun a => (x a).1)) i _ hi
#align first_order.language.direct_limit.rel_map_equiv_unify FirstOrder.Language.DirectLimit.relMap_equiv_unify

/-- The direct limit `setoid` respects the structure `sigma_structure`, so quotienting by it
  gives rise to a valid structure. -/
noncomputable instance prestructure : L.Prestructure (DirectLimit.setoid G f)
    where
  toStructure := sigmaStructure G f
  fun_equiv n F x y xy := by
    obtain ⟨i, hx, hy, h⟩ := exists_unify_eq G f xy
    refine'
      Setoid.trans (fun_map_equiv_unify G f F x i hx)
        (Setoid.trans _ (Setoid.symm (fun_map_equiv_unify G f F y i hy)))
    rw [h]
  rel_equiv n R x y xy := by
    obtain ⟨i, hx, hy, h⟩ := exists_unify_eq G f xy
    refine'
      trans (rel_map_equiv_unify G f R x i hx) (trans _ (symm (rel_map_equiv_unify G f R y i hy)))
    rw [h]
#align first_order.language.direct_limit.prestructure FirstOrder.Language.DirectLimit.prestructure

/-- The `L.Structure` on a direct limit of `L.Structure`s. -/
noncomputable instance structure : L.Structure (DirectLimit G f) :=
  Language.quotientStructure
#align first_order.language.direct_limit.Structure FirstOrder.Language.DirectLimit.structure

@[simp]
theorem funMap_quotient_mk'_sigma_mk' {n : ℕ} {F : L.Functions n} {i : ι} {x : Fin n → G i} :
    (funMap F fun a => (⟦⟨i, x a⟩⟧ : DirectLimit G f)) = ⟦⟨i, funMap F x⟩⟧ :=
  by
  simp only [Function.comp_apply, fun_map_quotient_mk, Quotient.eq']
  obtain ⟨k, ik, jk⟩ :=
    directed_of (· ≤ ·) i (Classical.choose (Fintype.bddAbove_range fun a : Fin n => i))
  refine' ⟨k, jk, ik, _⟩
  simp only [embedding.map_fun, comp_unify]
  rfl
#align first_order.language.direct_limit.fun_map_quotient_mk_sigma_mk FirstOrder.Language.DirectLimit.funMap_quotient_mk'_sigma_mk'

@[simp]
theorem relMap_quotient_mk'_sigma_mk' {n : ℕ} {R : L.Relations n} {i : ι} {x : Fin n → G i} :
    (RelMap R fun a => (⟦⟨i, x a⟩⟧ : DirectLimit G f)) = RelMap R x :=
  by
  rw [rel_map_quotient_mk]
  obtain ⟨k, ik, jk⟩ :=
    directed_of (· ≤ ·) i (Classical.choose (Fintype.bddAbove_range fun a : Fin n => i))
  rw [rel_map_equiv_unify G f R (fun a => ⟨i, x a⟩) i, unify_sigma_mk_self]
#align first_order.language.direct_limit.rel_map_quotient_mk_sigma_mk FirstOrder.Language.DirectLimit.relMap_quotient_mk'_sigma_mk'

theorem exists_quotient_mk'_sigma_mk'_eq {α : Type _} [Fintype α] (x : α → DirectLimit G f) :
    ∃ (i : ι)(y : α → G i), x = Quotient.mk' ∘ Sigma.mk i ∘ y :=
  by
  obtain ⟨i, hi⟩ := Fintype.bddAbove_range fun a => (x a).out.1
  refine' ⟨i, unify f (Quotient.out ∘ x) i hi, _⟩
  ext a
  rw [Quotient.eq_mk_iff_out, Function.comp_apply, unify, equiv_iff G f _]
  · simp only [DirectedSystem.map_self]
  · rfl
#align first_order.language.direct_limit.exists_quotient_mk_sigma_mk_eq FirstOrder.Language.DirectLimit.exists_quotient_mk'_sigma_mk'_eq

variable (L ι)

/-- The canonical map from a component to the direct limit. -/
def of (i : ι) : G i ↪[L] DirectLimit G f
    where
  toFun := Quotient.mk' ∘ Sigma.mk i
  inj' x y h := by
    simp only [Quotient.eq'] at h
    obtain ⟨j, h1, h2, h3⟩ := h
    exact (f i j h1).Injective h3
#align first_order.language.direct_limit.of FirstOrder.Language.DirectLimit.of

variable {L ι G f}

@[simp]
theorem of_apply {i : ι} {x : G i} : of L ι G f i x = ⟦⟨i, x⟩⟧ :=
  rfl
#align first_order.language.direct_limit.of_apply FirstOrder.Language.DirectLimit.of_apply

@[simp]
theorem of_f {i j : ι} {hij : i ≤ j} {x : G i} : of L ι G f j (f i j hij x) = of L ι G f i x :=
  by
  simp only [of_apply, Quotient.eq']
  refine' Setoid.symm ⟨j, hij, refl j, _⟩
  simp only [DirectedSystem.map_self]
#align first_order.language.direct_limit.of_f FirstOrder.Language.DirectLimit.of_f

/-- Every element of the direct limit corresponds to some element in
some component of the directed system. -/
theorem exists_of (z : DirectLimit G f) : ∃ i x, of L ι G f i x = z :=
  ⟨z.out.1, z.out.2, by simp⟩
#align first_order.language.direct_limit.exists_of FirstOrder.Language.DirectLimit.exists_of

@[elab_as_elim]
protected theorem induction_on {C : DirectLimit G f → Prop} (z : DirectLimit G f)
    (ih : ∀ i x, C (of L ι G f i x)) : C z :=
  let ⟨i, x, h⟩ := exists_of z
  h ▸ ih i x
#align first_order.language.direct_limit.induction_on FirstOrder.Language.DirectLimit.induction_on

variable {P : Type u₁} [L.Structure P] (g : ∀ i, G i ↪[L] P)

variable (Hg : ∀ i j hij x, g j (f i j hij x) = g i x)

include Hg

variable (L ι G f)

/-- The universal property of the direct limit: maps from the components to another module
that respect the directed system structure (i.e. make some diagram commute) give rise
to a unique map out of the direct limit. -/
def lift : DirectLimit G f ↪[L] P
    where
  toFun :=
    Quotient.lift (fun x : Σi, G i => (g x.1) x.2) fun x y xy =>
      by
      simp only
      obtain ⟨i, hx, hy⟩ := directed_of (· ≤ ·) x.1 y.1
      rw [← Hg x.1 i hx, ← Hg y.1 i hy]
      exact congr_arg _ ((equiv_iff _ _ _ _).1 xy)
  inj' x y xy :=
    by
    rw [← Quotient.out_eq x, ← Quotient.out_eq y, Quotient.lift_mk, Quotient.lift_mk] at xy
    obtain ⟨i, hx, hy⟩ := directed_of (· ≤ ·) x.out.1 y.out.1
    rw [← Hg x.out.1 i hx, ← Hg y.out.1 i hy] at xy
    rw [← Quotient.out_eq x, ← Quotient.out_eq y, Quotient.eq', equiv_iff G f hx hy]
    exact (g i).Injective xy
  map_fun' n F x := by
    obtain ⟨i, y, rfl⟩ := exists_quotient_mk_sigma_mk_eq G f x
    rw [fun_map_quotient_mk_sigma_mk, ← Function.comp.assoc, Quotient.lift_comp_mk]
    simp only [Quotient.lift_mk, embedding.map_fun]
  map_rel' n R x := by
    obtain ⟨i, y, rfl⟩ := exists_quotient_mk_sigma_mk_eq G f x
    rw [rel_map_quotient_mk_sigma_mk G f, ← (g i).map_rel R y, ← Function.comp.assoc,
      Quotient.lift_comp_mk]
#align first_order.language.direct_limit.lift FirstOrder.Language.DirectLimit.lift

variable {L ι G f}

omit Hg

@[simp]
theorem lift_quotient_mk'_sigma_mk' {i} (x : G i) : lift L ι G f g Hg ⟦⟨i, x⟩⟧ = (g i) x :=
  by
  change (lift L ι G f g Hg).toFun ⟦⟨i, x⟩⟧ = _
  simp only [lift, Quotient.lift_mk]
#align first_order.language.direct_limit.lift_quotient_mk_sigma_mk FirstOrder.Language.DirectLimit.lift_quotient_mk'_sigma_mk'

theorem lift_of {i} (x : G i) : lift L ι G f g Hg (of L ι G f i x) = g i x := by simp
#align first_order.language.direct_limit.lift_of FirstOrder.Language.DirectLimit.lift_of

theorem lift_unique (F : DirectLimit G f ↪[L] P) (x) :
    F x =
      lift L ι G f (fun i => F.comp <| of L ι G f i)
        (fun i j hij x => by rw [F.comp_apply, F.comp_apply, of_f]) x :=
  DirectLimit.induction_on x fun i x => by rw [lift_of] <;> rfl
#align first_order.language.direct_limit.lift_unique FirstOrder.Language.DirectLimit.lift_unique

/-- The direct limit of countably many countably generated structures is countably generated. -/
theorem cg {ι : Type _} [Encodable ι] [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι]
    {G : ι → Type w} [∀ i, L.Structure (G i)] (f : ∀ i j, i ≤ j → G i ↪[L] G j)
    (h : ∀ i, Structure.Cg L (G i)) [DirectedSystem G fun i j h => f i j h] :
    Structure.Cg L (DirectLimit G f) :=
  by
  refine' ⟨⟨⋃ i, direct_limit.of L ι G f i '' Classical.choose (h i).out, _, _⟩⟩
  · exact Set.countable_unionᵢ fun i => Set.Countable.image (Classical.choose_spec (h i).out).1 _
  · rw [eq_top_iff, substructure.closure_Union]
    simp_rw [← embedding.coe_to_hom, substructure.closure_image]
    rw [le_supᵢ_iff]
    intro S hS x hx
    let out := @Quotient.out _ (direct_limit.setoid G f)
    refine' hS (out x).1 ⟨(out x).2, _, _⟩
    · rw [(Classical.choose_spec (h (out x).1).out).2]
      simp only [substructure.coe_top]
    · simp only [embedding.coe_to_hom, direct_limit.of_apply, Sigma.eta, Quotient.out_eq]
#align first_order.language.direct_limit.cg FirstOrder.Language.DirectLimit.cg

instance cg' {ι : Type _} [Encodable ι] [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι]
    {G : ι → Type w} [∀ i, L.Structure (G i)] (f : ∀ i j, i ≤ j → G i ↪[L] G j)
    [h : ∀ i, Structure.Cg L (G i)] [DirectedSystem G fun i j h => f i j h] :
    Structure.Cg L (DirectLimit G f) :=
  cg f h
#align first_order.language.direct_limit.cg' FirstOrder.Language.DirectLimit.cg'

end DirectLimit

end Language

end FirstOrder


/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Ulrik Buchholtz

Declaration of suspension
-/

import ..hit.pushout ..types.pointed2 ..cubical.square .connectedness
universes u v w

namespace hott
hott_theory

open hott.pushout hott.equiv unit pointed hott.is_equiv

@[hott] def susp' (A : Type _) : Type _ := pushout (λ(a : A), star) (λ(a : A), star)

namespace susp

  @[hott] def north' {A : Type _} : susp' A :=
  inl star

  @[hott, instance] def pointed_susp (X : Type _) : pointed (susp' X) :=
  pointed.mk north'

end susp open susp

@[hott] def susp (X : Type _) : Type* :=
pointed.MK (susp' X) north'

@[hott, hsimp] def carrier_susp (X : Type _) : ↥(susp X) = susp' X := by refl

notation `⅀` := susp

namespace susp
section
  variable {A : Type _}

  @[hott] def north {A : Type _} : susp A :=
  north'

  @[hott] def south {A : Type _} : susp A :=
  inr star

  @[hott] def merid (a : A) : @north A = @south A :=
  glue a

  @[hott, induction, elab_as_eliminator] protected def rec {P : susp A → Type _}
    (PN : P north) (PS : P south) (Pm : Π(a : A), PN =[merid a] PS) (x : susp' A) : P x :=
  begin
    hinduction x using pushout.rec with u u,
    { cases u, exact PN },
    { cases u, exact PS },
    { apply Pm },
  end

  @[hott] theorem rec_merid {P : susp A → Type _} (PN : P north) (PS : P south)
    (Pm : Π(a : A), PN =[merid a] PS) (a : A)
      : apd (susp.rec PN PS Pm) (merid a) = Pm a :=
  begin delta susp.rec, dsimp, exact rec_glue _ _ _ a end

  @[hott, induction] protected def elim {P : Type _} (PN : P) (PS : P) (Pm : A → PN = PS)
    (x : susp' A) : P :=
  susp.rec PN PS (λa, pathover_of_eq _ (Pm a)) x

  @[hott] theorem elim_merid {P : Type _} {PN PS : P} (Pm : A → PN = PS) (a : A)
    : ap (susp.elim PN PS Pm) (merid a) = Pm a :=
  begin
    apply eq_of_fn_eq_fn_inv ((pathover_constant (merid a)) _ _),
    dsimp [susp.elim, susp.rec], refine (apd_eq_pathover_of_eq_ap _ _)⁻¹ ⬝ rec_glue _ _ _ _
  end

  @[hott] protected def elim_type (PN : Type _) (PS : Type _) (Pm : A → PN ≃ PS)
    (x : susp' A) : Type _ :=
  pushout.elim_type (λx, PN) (λx, PS) Pm x

  @[hott] theorem elim_type_merid (PN : Type _) (PS : Type _) (Pm : A → PN ≃ PS)
    (a : A) : transport (susp.elim_type PN PS Pm) (merid a) = Pm a :=
  elim_type_glue _ _ _ _

  @[hott] theorem elim_type_merid_inv {A : Type _} (PN : Type _) (PS : Type _) (Pm : A → PN ≃ PS)
    (a : A) : transport (susp.elim_type PN PS Pm) (merid a)⁻¹ = to_inv (Pm a) :=
  elim_type_glue_inv _ _ _ _

  @[hott] protected def merid_square {a a' : A} (p : a = a')
    : square (merid a) (merid a') idp idp :=
  by induction p; apply vrefl

  open is_trunc is_conn trunc
  -- theorem 8.2.1
  @[hott, instance] def is_conn_susp (n : trunc_index) (A : Type _)
    [H : is_conn n A] : is_conn (n .+1) (susp A) :=
  is_contr.mk (tr north)
  begin
    intro x, hinduction x with x, dsimp at x, hinduction x,
    { refl },
    { hinduction center (trunc n A) with p a, exact ap tr (merid a) },
    { hinduction center (trunc n A) with p a', dsimp,
      apply pathover_of_tr_eq,
      rwr [eq_transport_Fr, idp_con],
      unfreezeI,
      induction n with n IH generalizing H,
      { apply is_prop.elim },
      { change ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid a'),
        hgeneralize : a' = x,
        apply is_conn_fun.elim n
              (is_conn_fun_from_unit n A a)
              (λx : A, trunctype.mk' n (ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid x))),
        intros,
        change ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid a),
        refl }
    }
  end
end
  /- Flattening @[hott] lemma -/

  open prod
  section
    parameters (A : Type _) (PN PS : Type u) (Pm : A → PN ≃ PS)
    include Pm

    private abbreviation P := susp.elim_type PN PS Pm

    private abbreviation F : A × PN → PN := λz, z.2

    private abbreviation G : A × PN → PS := λz, Pm z.1 z.2

    @[hott] protected def flattening : sigma P ≃ pushout F G :=
    begin
      refine pushout.flattening _ _ _ _ _ ⬝e _,
      fapply pushout.equiv,
      { exact sigma.equiv_prod A PN },
      { apply sigma.sigma_unit_left },
      { apply sigma.sigma_unit_left },
      { refl },
      { refl }
    end
  end

end susp

/- Functoriality and equivalence -/
namespace susp
  variables {A : Type _} {B : Type _} (f : A → B)
  include f

  @[hott] def susp_functor' : susp A → susp B :=
  begin
    intro x, dsimp at x, hinduction x with a,
    { exact north },
    { exact south },
    { exact merid (f a) }
  end

  variable [Hf : is_equiv f]
  include Hf

  open is_equiv
  @[hott, instance] protected def is_equiv_functor : is_equiv (susp_functor' f) :=
  adjointify (susp_functor' f) (susp_functor' f⁻¹ᶠ)
  begin abstract {
    intro sb, dsimp at sb, hinduction sb with b, refl, refl,
    apply eq_pathover,
    rwr [ap_id, ap_compose (susp_functor' f) (susp_functor' f⁻¹ᶠ)],
    dsimp [susp_functor'], rwr [susp.elim_merid, susp.elim_merid], apply transpose,
    apply susp.merid_square (right_inv f b)
   } end
  begin abstract {
    intro sa, dsimp at sa, hinduction sa with a, refl, refl,
    apply eq_pathover,
    rwr [ap_id, ap_compose (susp_functor' f⁻¹ᶠ) (susp_functor' f)],
    dsimp [susp_functor'],
    rwr [susp.elim_merid, susp.elim_merid], apply transpose,
    apply susp.merid_square (left_inv f a)
  } end

end susp

namespace susp
  variables {A : Type _} {B : Type _} (f : A ≃ B)

  @[hott] protected def equiv : susp A ≃ susp B :=
  equiv.mk (susp_functor' f) (susp.is_equiv_functor f)
end susp

namespace susp
  open pointed is_trunc
  variables {X : Type*} {X' : Type*} {Y : Type*} {Y' : Type*} {Z : Type*}

  @[hott] def susp_functor (f : X →* Y) : susp X →* susp Y :=
  begin
    fconstructor,
    { exact susp_functor' f },
    { refl }
  end

  @[hott, hsimp] def functor_merid (f : X →* Y) (x : X) :
    @ap (susp X) (susp Y) (susp_functor f).to_fun _ _ (merid x) = merid (f.to_fun x) :=
  elim_merid _ x

  @[hott] def is_equiv_susp_functor (f : X →* Y) [Hf : is_equiv f]
    : is_equiv (susp_functor f) :=
  susp.is_equiv_functor f

  @[hott] def susp_pequiv (f : X ≃* Y) : susp X ≃* susp Y :=
  pequiv_of_equiv (susp.equiv f.to_equiv) idp

set_option pp.coercions true
  @[hott] def susp_functor_pcompose (g : Y →* Z) (f : X →* Y) :
    susp_functor (g ∘* f) ~* susp_functor g ∘* susp_functor f :=
  begin
    fapply phomotopy.mk,
    { intro x, dsimp at *, hinduction x,
      { refl },
      { refl },
      { apply eq_pathover, apply hdeg_square,
        refine functor_merid _ _ ⬝ _ ⬝ (ap_compose (susp_functor g) _ _)⁻¹ᵖ,
        hsimp, refl }},
    { refl },
  end

  @[hott] def susp_functor_phomotopy {f g : X →* Y} (p : f ~* g) :
    susp_functor f ~* susp_functor g :=
  begin
    fapply phomotopy.mk,
    { intro x, dsimp at *, hinduction x,
      { refl },
      { refl },
      { apply eq_pathover, apply hdeg_square, refine (elim_merid _ _) ⬝ _ ⬝ (elim_merid _ _)⁻¹ᵖ,
        exact ap merid (p a), }},
    { refl },
  end

  @[hott] def susp_functor_pid (A : Type*) : susp_functor (pid A) ~* pid (susp A) :=
  begin
    fapply phomotopy.mk,
    { intro x, dsimp at x, hinduction x,
      { refl },
      { refl },
      { apply eq_pathover_id_right, apply hdeg_square, apply elim_merid }},
    { refl },
  end

  /- adjunction originally  ported from Coq-HoTT,
     but we proved some additional naturality conditions -/

  @[hott] def loop_susp_unit (X : Type*) : X →* Ω(susp X) :=
  begin
    fconstructor,
    { intro x, exact merid x ⬝ (merid pt)⁻¹ },
    { apply con.right_inv },
  end
/-
 (eq.rec (refl (refl (susp_functor' f ((⅀ X).Point))))
               (ap (susp_functor' f) ((loop_susp_unit {carrier := X, Point := x}).to_fun x)) ⬝
             (ap_con (susp_functor' f) (merid x) (merid x)⁻¹ ⬝
                whisker_left (ap (susp_functor' f) (merid x)) (ap_inv (susp_functor' f) (merid x))) ⬝
           elim_merid (λ (a : X), merid (f a)) x ◾ (elim_merid (λ (a : X), merid (f a)) x)⁻²)⁻¹ ⬝
      (ap ((Ω→ (susp_functor {to_fun := f, resp_pt := refl (f x)})).to_fun)
           ((loop_susp_unit {carrier := X, Point := x}).resp_pt) ⬝
         (Ω→ (susp_functor {to_fun := f, resp_pt := refl (f x)})).resp_pt) =
    refl ((loop_susp_unit {carrier := Y, Point := f x}).to_fun (f x)) ⬝
      (loop_susp_unit {carrier := Y, Point := f x}).resp_pt
-/
  @[hott] def loop_susp_unit_natural (f : X →* Y)
    : loop_susp_unit Y ∘* f ~* Ω→ (susp_functor f) ∘* loop_susp_unit X :=
  begin
    induction X with X x, induction Y with Y y, induction f with f pf, dsimp at *, induction pf,
    fapply phomotopy.mk,
    { intro x', symmetry,
      exact
        ap1_gen_idp_left _ _ ⬝
        (ap_con _ _ _ ⬝ whisker_left _ (ap_inv _ _)) ⬝
        elim_merid _ _ ◾ (elim_merid _ _)⁻² },
    { dsimp [loop_susp_unit, -con.right_inv, -ap1_gen_idp_left], refine _ ⬝ (idp_con _)⁻¹ᵖ,
      apply inv_con_eq_of_eq_con,
      refine _ ⬝ con.assoc' _ _ _, rwr inverse2_right_inv,
      refine _ ⬝ con.assoc' _ _ _,
      rwr [ap_con_right_inv],
      rwr [ap1_gen_idp_left_con],
      rwr [←ap_compose (concat idp)] },
  end

  @[hott] def loop_susp_counit (X : Type*) : susp (Ω X) →* X :=
  begin
    fapply pmap.mk,
    { intro x, dsimp at x, hinduction x, exact pt, exact pt, exact a },
    { refl },
  end

  @[hott] def loop_susp_counit_natural (f : X →* Y)
    : f ∘* loop_susp_counit X ~* loop_susp_counit Y ∘* (susp_functor (ap1 f)) :=
  begin
    induction X with X x, induction Y with Y y, induction f with f pf, dsimp at *, induction pf,
    fconstructor,
    { intro x', dsimp at *, hinduction x' with p,
      { refl },
      { refl },
      { apply eq_pathover, apply hdeg_square, dsimp [pcompose, loop_susp_counit],
        rwr [ap_compose f, ap_compose (susp.elim (f x) (f x) (λ (a : f x = f x), a))],
        dsimp [susp_functor, susp_functor'], rwr [elim_merid, elim_merid, elim_merid],
        dsimp [ap1], rwr [ap1_gen_idp_left] }},
    { refl }
  end

  @[hott] def loop_susp_counit_unit (X : Type*)
    : ap1 (loop_susp_counit X) ∘* loop_susp_unit (Ω X) ~* pid (Ω X) :=
  begin
    induction X with X x, fconstructor,
    { intro p,
      refine (ap1_gen_idp_left _ _) ⬝
             (ap_con _ _ _ ⬝
             whisker_left _ (ap_inv _ _)) ⬝ _,
      refine (elim_merid _ _ ◾ (elim_merid _ _)⁻²) ⬝ _, refl },
    { dsimp [loop_susp_unit, -ap1_gen_idp_left, -con.right_inv],
      refine idp ◾ ((con_idp _)⁻¹ᵖ ⬝ inverse2_right_inv _) ⬝ _,
      refine con.assoc _ _ _ ⬝ _,
      refine whisker_left _ (ap_con_right_inv (susp.elim x x (λa, a)) (merid (refl x))) ⬝ _,
      rwr [ap1_gen_idp_left_con, ←ap_compose] }
  end

  @[hott] def loop_susp_unit_counit (X : Type*)
    : loop_susp_counit (susp X) ∘* susp_functor (loop_susp_unit X) ~* pid (susp X) :=
  begin
    induction X with X x, fconstructor,
    { intro x', dsimp at *, hinduction x',
      { refl },
      { exact merid x },
      { apply eq_pathover, dsimp [pid, pcompose, loop_susp_counit],
        refine ap_compose (susp.elim north north (λa, a)) _ _ ⬝ph _ ⬝hp (ap_id _)⁻¹ᵖ,
        refine ap02 _ (functor_merid _ _) ⬝ elim_merid _ _ ⬝ph _,
        apply square_of_eq, exact idp_con _ ⬝ (inv_con_cancel_right _ _)⁻¹ }},
    { refl }
  end

  @[hott] def susp_elim {X Y : Type*} (f : X →* Ω Y) : susp X →* Y :=
  loop_susp_counit Y ∘* susp_functor f

  @[hott] def loop_susp_intro {X Y : Type*} (f : susp X →* Y) : X →* Ω Y :=
  ap1 f ∘* loop_susp_unit X

  @[hott] def susp_elim_susp_functor {A B C : Type*} (g : B →* Ω C) (f : A →* B) :
    susp_elim g ∘* susp_functor f ~* susp_elim (g ∘* f) :=
  begin
    refine passoc _ _ _ ⬝* _, exact pwhisker_left _ (susp_functor_pcompose _ _)⁻¹*
  end

  @[hott] def susp_elim_phomotopy {A B : Type*} {f g : A →* Ω B} (p : f ~* g) : susp_elim f ~* susp_elim g :=
  pwhisker_left _ (susp_functor_phomotopy p)

  @[hott] def susp_elim_natural {X Y Z : Type*} (g : Y →* Z) (f : X →* Ω Y)
    : g ∘* susp_elim f ~* susp_elim (Ω→ g ∘* f) :=
  begin
    refine _ ⬝* pwhisker_left _ (susp_functor_pcompose _ _)⁻¹*,
    refine (passoc _ _ _)⁻¹* ⬝* _ ⬝* passoc _ _ _,
    exact pwhisker_right _ (loop_susp_counit_natural _)
  end

  @[hott] def loop_susp_intro_natural {X Y Z : Type*} (g : susp Y →* Z) (f : X →* Y) :
    loop_susp_intro (g ∘* susp_functor f) ~* loop_susp_intro g ∘* f :=
  pwhisker_right _ (ap1_pcompose _ _) ⬝* passoc _ _ _ ⬝*
  pwhisker_left _ (loop_susp_unit_natural _)⁻¹* ⬝* (passoc _ _ _)⁻¹*

  @[hott] def susp_adjoint_loop_right_inv {X Y : Type*} (g : X →* Ω Y) :
    loop_susp_intro (susp_elim g) ~* g :=
  begin
    refine pwhisker_right _ (ap1_pcompose _ _) ⬝* _,
    refine passoc _ _ _ ⬝* _,
    refine pwhisker_left _ (loop_susp_unit_natural _)⁻¹* ⬝* _,
    refine (passoc _ _ _)⁻¹* ⬝* _,
    refine pwhisker_right _ (loop_susp_counit_unit _) ⬝* _,
    apply pid_pcompose
  end

  @[hott] def susp_adjoint_loop_left_inv {X Y : Type*} (f : susp X →* Y) :
    susp_elim (loop_susp_intro f) ~* f :=
  begin
    refine pwhisker_left _ (susp_functor_pcompose _ _) ⬝* _,
    refine (passoc _ _ _)⁻¹* ⬝* _,
    refine pwhisker_right _ (loop_susp_counit_natural _)⁻¹* ⬝* _,
    refine passoc _ _ _ ⬝* _,
    refine pwhisker_left _ (loop_susp_unit_counit _) ⬝* _,
    apply pcompose_pid
  end

  @[hott] def susp_adjoint_loop_unpointed (X Y : Type*) : susp X →* Y ≃ X →* Ω Y :=
  begin
    fapply equiv.MK,
    { exact loop_susp_intro },
    { exact susp_elim },
    { intro g, apply eq_of_phomotopy, exact susp_adjoint_loop_right_inv g },
    { intro f, apply eq_of_phomotopy, exact susp_adjoint_loop_left_inv f }
  end

  @[hott] def susp_functor_pconst_homotopy {X Y : Type*} (x : susp X) :
    susp_functor (pconst X Y) x = pt :=
  begin
    dsimp at x, hinduction x,
    { refl },
    { exact (merid pt)⁻¹ },
    { apply eq_pathover, refine (elim_merid _ _) ⬝ph _ ⬝hp (ap_constant _ _)⁻¹, exact square_of_eq (con.right_inv _)⁻¹ }
  end

  @[hott] def susp_functor_pconst (X Y : Type*) : susp_functor (pconst X Y) ~* pconst (susp X) (susp Y) :=
  begin
    fapply phomotopy.mk,
    { exact susp_functor_pconst_homotopy },
    { refl }
  end

  @[hott] def susp_pfunctor (X Y : Type*) : ppmap X Y →* ppmap (susp X) (susp Y) :=
  pmap.mk susp_functor (eq_of_phomotopy (susp_functor_pconst _ _))

  @[hott] def susp_pelim (X Y : Type*) : ppmap X (Ω Y) →* ppmap (susp X) Y :=
  ppcompose_left (loop_susp_counit Y) ∘* susp_pfunctor X (Ω Y)

  @[hott] def loop_susp_pintro (X Y : Type*) : ppmap (susp X) Y →* ppmap X (Ω Y) :=
  ppcompose_right (loop_susp_unit X) ∘* pap1 (susp X) Y

  @[hott] def loop_susp_pintro_natural_left (f : X' →* X) :
    psquare (loop_susp_pintro X Y) (loop_susp_pintro X' Y)
            (ppcompose_right (susp_functor f)) (ppcompose_right f) :=
  pap1_natural_left _ ⬝h* ppcompose_right_psquare (loop_susp_unit_natural f)⁻¹*

  @[hott] def loop_susp_pintro_natural_right (f : Y →* Y') :
    psquare (loop_susp_pintro X Y) (loop_susp_pintro X Y')
            (ppcompose_left f) (ppcompose_left (Ω→ f)) :=
  pap1_natural_right _ ⬝h* (ppcompose_left_ppcompose_right _ _)⁻¹*

  @[hott] def is_equiv_loop_susp_pintro (X Y : Type*) :
    is_equiv (loop_susp_pintro X Y) :=
  begin
    fapply adjointify,
    { exact susp_pelim X Y },
    { intro g, apply eq_of_phomotopy, exact susp_adjoint_loop_right_inv g },
    { intro f, apply eq_of_phomotopy, exact susp_adjoint_loop_left_inv f }
  end

  -- @[hott] def susp_adjoint_loop (X Y : Type*) : ppmap (susp X) Y ≃* ppmap X (Ω Y) :=
  -- pequiv_of_pmap (loop_susp_pintro X Y) (is_equiv_loop_susp_pintro X Y)

  -- @[hott] def susp_adjoint_loop_natural_right (f : Y →* Y') :
  --   psquare (susp_adjoint_loop X Y).to_pmap (susp_adjoint_loop X Y').to_pmap
  --           (ppcompose_left f) (ppcompose_left (Ω→ f)) :=
  -- loop_susp_pintro_natural_right f

  -- @[hott] def susp_adjoint_loop_natural_left (f : X' →* X) :
  --   psquare (susp_adjoint_loop X Y).to_pmap (susp_adjoint_loop X' Y).to_pmap
  --           (ppcompose_right (susp_functor f)) (ppcompose_right f) :=
  -- loop_susp_pintro_natural_left f

  -- @[hott] def ap1_susp_elim {A : Type*} {X : Type*} (p : A →* Ω X) :
  --   Ω→(susp_elim p) ∘* loop_susp_unit A ~* p :=
  -- susp_adjoint_loop_right_inv p

  -- /- the underlying homotopies of susp_adjoint_loop_natural_* -/
  -- @[hott] def susp_adjoint_loop_nat_right (f : susp X →* Y) (g : Y →* Z)
  --   : (susp_adjoint_loop X Z).to_pmap (g ∘* f) ~* ap1 g ∘* (susp_adjoint_loop X Y).to_pmap f :=
  -- begin
  --   dsimp [susp_adjoint_loop],
  --   refine _ ⬝* passoc _ _ _,
  --   apply pwhisker_right,
  --   apply ap1_pcompose
  -- end

  -- @[hott] def susp_adjoint_loop_nat_left (f : Y →* Ω Z) (g : X →* Y)
  --   : (susp_adjoint_loop X Z)⁻¹ᵉ (f ∘* g) ~* (susp_adjoint_loop Y Z)⁻¹ᵉ f ∘* susp_functor g :=
  -- begin
  --   esimp [susp_adjoint_loop],
  --   refine _ ⬝* (passoc _ _ _)⁻¹*,
  --   apply pwhisker_left,
  --   apply susp_functor_pcompose
  -- end

  -- /- iterated suspension -/
  -- @[hott] def iterate_susp (n : ℕ) (A : Type*) : Type* := iterate (λX, susp X) n A

  -- open is_conn trunc_index nat
  -- @[hott] def iterate_susp_succ (n : ℕ) (A : Type*) :
  --   iterate_susp (succ n) A = susp (iterate_susp n A) :=
  -- idp

  -- @[hott] def is_conn_iterate_susp [instance] (n : ℕ₋₂) (m : ℕ) (A : Type*)
  --   [H : is_conn n A] : is_conn (n + m) (iterate_susp m A) :=
  -- begin induction m with m IH, exact H, exact @is_conn_susp _ _ IH end

  -- -- Separate cases for n = 0, which comes up often
  -- @[hott] def is_conn_iterate_susp_zero [instance] (m : ℕ) (A : Type*)
  --   [H : is_conn 0 A] : is_conn m (iterate_susp m A) :=
  -- begin induction m with m IH, exact H, exact @is_conn_susp _ _ IH end

  -- @[hott] def iterate_susp_functor (n : ℕ) {A B : Type*} (f : A →* B) :
  --   iterate_susp n A →* iterate_susp n B :=
  -- begin
  --   induction n with n g,
  --   { exact f },
  --   { exact susp_functor g }
  -- end

  -- @[hott] def iterate_susp_succ_in (n : ℕ) (A : Type*) :
  --   iterate_susp (succ n) A ≃* iterate_susp n (susp A) :=
  -- begin
  --   induction n with n IH,
  --   { refl},
  --   { exact susp_pequiv IH}
  -- end

  -- @[hott] def iterate_susp_adjoint_loopn (X Y : Type*) (n : ℕ) :
  --   ppmap (iterate_susp n X) Y ≃* ppmap X (Ω[n] Y) :=
  -- begin
  --   induction n with n IH generalizing X Y,
  --   { refl },
  --   { refine susp_adjoint_loop _ _ ⬝e* IH _ _ ⬝e* _, apply pequiv_ppcompose_left,
  --     symmetry, apply loopn_succ_in }
  -- end

end susp
end hott


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro, Johannes Hölzl, Sander Dahmen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.basis
import Mathlib.set_theory.cardinal_ordinal
import Mathlib.PostPort

universes u v w w' m v' u_1 u₁ u₁' v''

namespace Mathlib

/-!
# Dimension of modules and vector spaces

## Main definitions

* The dimension of a vector space is defined as `vector_space.dim : cardinal`.

## Main statements

* `mk_eq_mk_of_basis`: the dimension theorem, any two bases of the same vector space have the same
  cardinality.
* `dim_quotient_add_dim`: if V₁ is a submodule of V, then dim (V/V₁) + dim V₁ = dim V.
* `dim_range_add_dim_ker`: the rank-nullity theorem.

## Implementation notes

Many theorems in this file are not universe-generic when they relate dimensions
in different universes. They should be as general as they can be without
inserting `lift`s. The types `V`, `V'`, ... all live in different universes,
and `V₁`, `V₂`, ... all live in the same universe.
-/

/-- the dimension of a vector space, defined as a term of type `cardinal` -/
def vector_space.dim (K : Type u) (V : Type v) [field K] [add_comm_group V] [vector_space K V] : cardinal :=
  cardinal.min sorry fun (b : Subtype fun (b : set V) => is_basis K fun (i : ↥b) => ↑i) => cardinal.mk ↥(subtype.val b)

theorem is_basis.le_span {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} {J : set V} (hv : is_basis K v) (hJ : submodule.span K J = ⊤) : cardinal.mk ↥(set.range v) ≤ cardinal.mk ↥J := sorry

/-- dimension theorem -/
theorem mk_eq_mk_of_basis {K : Type u} {V : Type v} {ι : Type w} {ι' : Type w'} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} {v' : ι' → V} (hv : is_basis K v) (hv' : is_basis K v') : cardinal.lift (cardinal.mk ι) = cardinal.lift (cardinal.mk ι') := sorry

theorem mk_eq_mk_of_basis' {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {ι' : Type w} {v : ι → V} {v' : ι' → V} (hv : is_basis K v) (hv' : is_basis K v') : cardinal.mk ι = cardinal.mk ι' :=
  iff.mp cardinal.lift_inj (mk_eq_mk_of_basis hv hv')

theorem is_basis.mk_eq_dim'' {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {ι : Type v} {v : ι → V} (h : is_basis K v) : cardinal.mk ι = vector_space.dim K V := sorry

theorem is_basis.mk_range_eq_dim {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} (h : is_basis K v) : cardinal.mk ↥(set.range v) = vector_space.dim K V :=
  is_basis.mk_eq_dim'' (is_basis.range h)

theorem is_basis.mk_eq_dim {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} (h : is_basis K v) : cardinal.lift (cardinal.mk ι) = cardinal.lift (vector_space.dim K V) := sorry

theorem is_basis.mk_eq_dim' {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} (h : is_basis K v) : cardinal.lift (cardinal.mk ι) = cardinal.lift (vector_space.dim K V) :=
  eq.mpr (id (propext cardinal.lift_max))
    (eq.mp (Eq.refl (cardinal.lift (cardinal.mk ι) = cardinal.lift (vector_space.dim K V))) (is_basis.mk_eq_dim h))

theorem dim_le {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {n : ℕ} (H : ∀ (s : finset V), (linear_independent K fun (i : ↥↑s) => ↑i) → finset.card s ≤ n) : vector_space.dim K V ≤ ↑n := sorry

/-- Two linearly equivalent vector spaces have the same dimension, a version with different
universes. -/
theorem linear_equiv.lift_dim_eq {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] (f : linear_equiv K V V') : cardinal.lift (vector_space.dim K V) = cardinal.lift (vector_space.dim K V') := sorry

/-- Two linearly equivalent vector spaces have the same dimension. -/
theorem linear_equiv.dim_eq {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_equiv K V V₁) : vector_space.dim K V = vector_space.dim K V₁ :=
  iff.mp cardinal.lift_inj (linear_equiv.lift_dim_eq f)

/-- Two vector spaces are isomorphic if they have the same dimension. -/
theorem nonempty_linear_equiv_of_lift_dim_eq {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] (cond : cardinal.lift (vector_space.dim K V) = cardinal.lift (vector_space.dim K V')) : Nonempty (linear_equiv K V V') := sorry

/-- Two vector spaces are isomorphic if they have the same dimension. -/
theorem nonempty_linear_equiv_of_dim_eq {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (cond : vector_space.dim K V = vector_space.dim K V₁) : Nonempty (linear_equiv K V V₁) :=
  nonempty_linear_equiv_of_lift_dim_eq (congr_arg cardinal.lift cond)

/-- Two vector spaces are isomorphic if they have the same dimension. -/
def linear_equiv.of_lift_dim_eq {K : Type u} (V : Type v) (V' : Type v') [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] (cond : cardinal.lift (vector_space.dim K V) = cardinal.lift (vector_space.dim K V')) : linear_equiv K V V' :=
  Classical.choice (nonempty_linear_equiv_of_lift_dim_eq cond)

/-- Two vector spaces are isomorphic if they have the same dimension. -/
def linear_equiv.of_dim_eq {K : Type u} (V : Type v) (V₁ : Type v) [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (cond : vector_space.dim K V = vector_space.dim K V₁) : linear_equiv K V V₁ :=
  Classical.choice (nonempty_linear_equiv_of_dim_eq cond)

/-- Two vector spaces are isomorphic if and only if they have the same dimension. -/
theorem linear_equiv.nonempty_equiv_iff_lift_dim_eq {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] : Nonempty (linear_equiv K V V') ↔ cardinal.lift (vector_space.dim K V) = cardinal.lift (vector_space.dim K V') := sorry

/-- Two vector spaces are isomorphic if and only if they have the same dimension. -/
theorem linear_equiv.nonempty_equiv_iff_dim_eq {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] : Nonempty (linear_equiv K V V₁) ↔ vector_space.dim K V = vector_space.dim K V₁ := sorry

@[simp] theorem dim_bot {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] : vector_space.dim K ↥⊥ = 0 := sorry

@[simp] theorem dim_top {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] : vector_space.dim K ↥⊤ = vector_space.dim K V :=
  linear_equiv.dim_eq (linear_equiv.of_top ⊤ rfl)

theorem dim_of_field (K : Type u_1) [field K] : vector_space.dim K K = 1 := sorry

theorem dim_span {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} (hv : linear_independent K v) : vector_space.dim K ↥(submodule.span K (set.range v)) = cardinal.mk ↥(set.range v) := sorry

theorem dim_span_set {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {s : set V} (hs : linear_independent K fun (x : ↥s) => ↑x) : vector_space.dim K ↥(submodule.span K s) = cardinal.mk ↥s := sorry

theorem cardinal_lift_le_dim_of_linear_independent {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {ι : Type w} {v : ι → V} (hv : linear_independent K v) : cardinal.lift (cardinal.mk ι) ≤ cardinal.lift (vector_space.dim K V) := sorry

theorem cardinal_le_dim_of_linear_independent {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {ι : Type v} {v : ι → V} (hv : linear_independent K v) : cardinal.mk ι ≤ vector_space.dim K V :=
  eq.mpr (id (Eq.refl (cardinal.mk ι ≤ vector_space.dim K V)))
    (eq.mp (propext cardinal.lift_le) (cardinal_lift_le_dim_of_linear_independent hv))

theorem cardinal_le_dim_of_linear_independent' {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {s : set V} (hs : linear_independent K fun (x : ↥s) => ↑x) : cardinal.mk ↥s ≤ vector_space.dim K V := sorry

theorem dim_span_le {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : set V) : vector_space.dim K ↥(submodule.span K s) ≤ cardinal.mk ↥s := sorry

theorem dim_span_of_finset {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : finset V) : vector_space.dim K ↥(submodule.span K ↑s) < cardinal.omega := sorry

theorem dim_prod {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] : vector_space.dim K (V × V₁) = vector_space.dim K V + vector_space.dim K V₁ := sorry

theorem dim_quotient_add_dim {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (p : submodule K V) : vector_space.dim K (submodule.quotient p) + vector_space.dim K ↥p = vector_space.dim K V := sorry

theorem dim_quotient_le {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (p : submodule K V) : vector_space.dim K (submodule.quotient p) ≤ vector_space.dim K V := sorry

/-- rank-nullity theorem -/
theorem dim_range_add_dim_ker {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) : vector_space.dim K ↥(linear_map.range f) + vector_space.dim K ↥(linear_map.ker f) = vector_space.dim K V := sorry

theorem dim_range_le {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) : vector_space.dim K ↥(linear_map.range f) ≤ vector_space.dim K V := sorry

theorem dim_map_le {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) (p : submodule K V) : vector_space.dim K ↥(submodule.map f p) ≤ vector_space.dim K ↥p := sorry

theorem dim_range_of_surjective {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] (f : linear_map K V V') (h : function.surjective ⇑f) : vector_space.dim K ↥(linear_map.range f) = vector_space.dim K V' := sorry

theorem dim_eq_of_surjective {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) (h : function.surjective ⇑f) : vector_space.dim K V = vector_space.dim K V₁ + vector_space.dim K ↥(linear_map.ker f) := sorry

theorem dim_le_of_surjective {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) (h : function.surjective ⇑f) : vector_space.dim K V₁ ≤ vector_space.dim K V :=
  eq.mpr (id (Eq._oldrec (Eq.refl (vector_space.dim K V₁ ≤ vector_space.dim K V)) (dim_eq_of_surjective f h)))
    (self_le_add_right (vector_space.dim K V₁) (vector_space.dim K ↥(linear_map.ker f)))

theorem dim_eq_of_injective {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) (h : function.injective ⇑f) : vector_space.dim K V = vector_space.dim K ↥(linear_map.range f) := sorry

theorem dim_submodule_le {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : submodule K V) : vector_space.dim K ↥s ≤ vector_space.dim K V :=
  eq.mpr (id (Eq._oldrec (Eq.refl (vector_space.dim K ↥s ≤ vector_space.dim K V)) (Eq.symm (dim_quotient_add_dim s))))
    (self_le_add_left (vector_space.dim K ↥s) (vector_space.dim K (submodule.quotient s)))

theorem dim_le_of_injective {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) (h : function.injective ⇑f) : vector_space.dim K V ≤ vector_space.dim K V₁ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (vector_space.dim K V ≤ vector_space.dim K V₁)) (dim_eq_of_injective f h)))
    (dim_submodule_le (linear_map.range f))

theorem dim_le_of_submodule {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : submodule K V) (t : submodule K V) (h : s ≤ t) : vector_space.dim K ↥s ≤ vector_space.dim K ↥t := sorry

theorem linear_independent_le_dim {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} (hv : linear_independent K v) : cardinal.lift (cardinal.mk ι) ≤ cardinal.lift (vector_space.dim K V) := sorry

theorem linear_independent_le_dim' {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {v : ι → V} (hs : linear_independent K v) : cardinal.lift (cardinal.mk ι) ≤ cardinal.lift (vector_space.dim K V) :=
  cardinal.mk_range_eq_lift (linear_independent.injective hs) ▸
    dim_span hs ▸ iff.mpr cardinal.lift_le (dim_submodule_le (submodule.span K (set.range v)))

/-- This is mostly an auxiliary lemma for `dim_sup_add_dim_inf_eq`. -/
theorem dim_add_dim_split {K : Type u} {V : Type v} {V₁ : Type v} {V₂ : Type v} {V₃ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] [add_comm_group V₂] [vector_space K V₂] [add_comm_group V₃] [vector_space K V₃] (db : linear_map K V₂ V) (eb : linear_map K V₃ V) (cd : linear_map K V₁ V₂) (ce : linear_map K V₁ V₃) (hde : ⊤ ≤ linear_map.range db ⊔ linear_map.range eb) (hgd : linear_map.ker cd = ⊥) (eq : linear_map.comp db cd = linear_map.comp eb ce) (eq₂ : ∀ (d : V₂) (e : V₃), coe_fn db d = coe_fn eb e → ∃ (c : V₁), coe_fn cd c = d ∧ coe_fn ce c = e) : vector_space.dim K V + vector_space.dim K V₁ = vector_space.dim K V₂ + vector_space.dim K V₃ := sorry

theorem dim_sup_add_dim_inf_eq {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : submodule K V) (t : submodule K V) : vector_space.dim K ↥(s ⊔ t) + vector_space.dim K ↥(s ⊓ t) = vector_space.dim K ↥s + vector_space.dim K ↥t := sorry

theorem dim_add_le_dim_add_dim {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : submodule K V) (t : submodule K V) : vector_space.dim K ↥(s ⊔ t) ≤ vector_space.dim K ↥s + vector_space.dim K ↥t := sorry

theorem dim_pi {K : Type u} {η : Type u₁'} {φ : η → Type u_1} [field K] [fintype η] [(i : η) → add_comm_group (φ i)] [(i : η) → vector_space K (φ i)] : vector_space.dim K ((i : η) → φ i) = cardinal.sum fun (i : η) => vector_space.dim K (φ i) := sorry

theorem dim_fun {K : Type u} [field K] {V : Type u} {η : Type u} [fintype η] [add_comm_group V] [vector_space K V] : vector_space.dim K (η → V) = ↑(fintype.card η) * vector_space.dim K V := sorry

theorem dim_fun_eq_lift_mul {K : Type u} {V : Type v} {η : Type u₁'} [field K] [add_comm_group V] [vector_space K V] [fintype η] : vector_space.dim K (η → V) = ↑(fintype.card η) * cardinal.lift (vector_space.dim K V) := sorry

theorem dim_fun' {K : Type u} {η : Type u₁'} [field K] [fintype η] : vector_space.dim K (η → K) = ↑(fintype.card η) := sorry

theorem dim_fin_fun {K : Type u} [field K] (n : ℕ) : vector_space.dim K (fin n → K) = ↑n := sorry

theorem exists_mem_ne_zero_of_ne_bot {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {s : submodule K V} (h : s ≠ ⊥) : ∃ (b : V), b ∈ s ∧ b ≠ 0 := sorry

theorem exists_mem_ne_zero_of_dim_pos {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] {s : submodule K V} (h : 0 < vector_space.dim K ↥s) : ∃ (b : V), b ∈ s ∧ b ≠ 0 := sorry

theorem exists_is_basis_fintype {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (h : vector_space.dim K V < cardinal.omega) : ∃ (s : set V), is_basis K subtype.val ∧ Nonempty (fintype ↥s) := sorry

/-- `rank f` is the rank of a `linear_map f`, defined as the dimension of `f.range`. -/
def rank {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] (f : linear_map K V V') : cardinal :=
  vector_space.dim K ↥(linear_map.range f)

theorem rank_le_domain {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) : rank f ≤ vector_space.dim K V :=
  eq.mpr (id (Eq._oldrec (Eq.refl (rank f ≤ vector_space.dim K V)) (Eq.symm (dim_range_add_dim_ker f))))
    (self_le_add_right (rank f) (vector_space.dim K ↥(linear_map.ker f)))

theorem rank_le_range {K : Type u} {V : Type v} {V₁ : Type v} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V₁] [vector_space K V₁] (f : linear_map K V V₁) : rank f ≤ vector_space.dim K V₁ :=
  dim_submodule_le (linear_map.range f)

theorem rank_add_le {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] (f : linear_map K V V') (g : linear_map K V V') : rank (f + g) ≤ rank f + rank g := sorry

@[simp] theorem rank_zero {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] : rank 0 = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (rank 0 = 0)) (rank.equations._eqn_1 0)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (vector_space.dim K ↥(linear_map.range 0) = 0)) linear_map.range_zero))
      (eq.mpr (id (Eq._oldrec (Eq.refl (vector_space.dim K ↥⊥ = 0)) dim_bot)) (Eq.refl 0)))

theorem rank_finset_sum_le {K : Type u} {V : Type v} {V' : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] {η : Type u_1} (s : finset η) (f : η → linear_map K V V') : rank (finset.sum s fun (d : η) => f d) ≤ finset.sum s fun (d : η) => rank (f d) :=
  finset.sum_hom_rel (le_of_eq rank_zero)
    fun (i : η) (g : linear_map K V V') (c : cardinal) (h : rank g ≤ c) =>
      le_trans (rank_add_le (f i) g) (add_le_add_left h (rank (f i)))

theorem rank_comp_le1 {K : Type u} {V : Type v} {V' : Type v'} {V'' : Type v''} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] [add_comm_group V''] [vector_space K V''] (g : linear_map K V V') (f : linear_map K V' V'') : rank (linear_map.comp f g) ≤ rank f := sorry

theorem rank_comp_le2 {K : Type u} {V : Type v} {V' : Type v'} {V'₁ : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V'] [add_comm_group V'₁] [vector_space K V'₁] (g : linear_map K V V') (f : linear_map K V' V'₁) : rank (linear_map.comp f g) ≤ rank g := sorry

theorem dim_zero_iff_forall_zero {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] : vector_space.dim K V = 0 ↔ ∀ (x : V), x = 0 := sorry

theorem dim_pos_iff_exists_ne_zero {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] : 0 < vector_space.dim K V ↔ ∃ (x : V), x ≠ 0 := sorry

theorem dim_pos_iff_nontrivial {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] : 0 < vector_space.dim K V ↔ nontrivial V := sorry

theorem dim_pos {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] [h : nontrivial V] : 0 < vector_space.dim K V :=
  iff.mpr dim_pos_iff_nontrivial h

/-- A vector space has dimension at most `1` if and only if there is a
single vector of which all vectors are multiples. -/
theorem dim_le_one_iff {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] : vector_space.dim K V ≤ 1 ↔ ∃ (v₀ : V), ∀ (v : V), ∃ (r : K), r • v₀ = v := sorry

/-- A submodule has dimension at most `1` if and only if there is a
single vector in the submodule such that the submodule is contained in
its span. -/
theorem dim_submodule_le_one_iff {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : submodule K V) : vector_space.dim K ↥s ≤ 1 ↔ ∃ (v₀ : V), ∃ (H : v₀ ∈ s), s ≤ submodule.span K (singleton v₀) := sorry

/-- A submodule has dimension at most `1` if and only if there is a
single vector, not necessarily in the submodule, such that the
submodule is contained in its span. -/
theorem dim_submodule_le_one_iff' {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] (s : submodule K V) : vector_space.dim K ↥s ≤ 1 ↔ ∃ (v₀ : V), s ≤ submodule.span K (singleton v₀) := sorry

/-- Version of linear_equiv.dim_eq without universe constraints. -/
theorem linear_equiv.dim_eq_lift {K : Type u} {V : Type v} {E : Type v'} [field K] [add_comm_group V] [vector_space K V] [add_comm_group E] [vector_space K E] (f : linear_equiv K V E) : cardinal.lift (vector_space.dim K V) = cardinal.lift (vector_space.dim K E) := sorry


import rowround

import category_theory.category.basic

open rowround
open utils

open category_theory

namespace rowround_examples

variable [category (bitvec params.word_len)]

/-
  # Examples from the spec.

  https://cr.yp.to/snuffle/spec.pdf
-/

/-!
## Example 1 :

> rowround(0x00000001, 0x00000000, 0x00000000, 0x00000000,
> 0x00000001, 0x00000000, 0x00000000, 0x00000000,
> 0x00000001, 0x00000000, 0x00000000, 0x00000000,
> 0x00000001, 0x00000000, 0x00000000, 0x00000000)
> = (0x08008145, 0x00000080, 0x00010200, 0x20500000,
> 0x20100001, 0x00048044, 0x00000080, 0x00010000,
> 0x00000001, 0x00002000, 0x80040000, 0x00000000,
> 0x00000001, 0x00000200, 0x00402000, 0x88000100)
-/

def example1_input : matrixType :=
  (
    (0x00000001, 0x00000000, 0x00000000, 0x00000000),
    (0x00000001, 0x00000000, 0x00000000, 0x00000000),
    (0x00000001, 0x00000000, 0x00000000, 0x00000000),
    (0x00000001, 0x00000000, 0x00000000, 0x00000000)
  )

def example1_output : matrixType :=
  (
    (0x08008145, 0x00000080, 0x00010200, 0x20500000),
    (0x20100001, 0x00048044, 0x00000080, 0x00010000),
    (0x00000001, 0x00002000, 0x80040000, 0x00000000),
    (0x00000001, 0x00000200, 0x00402000, 0x88000100)
  )

/-- `rowround_single (1, 0, 0, 0) = 134250821` -/
lemma example1_rowround_single_0 : (rowround_single example1_input.fst).fst = example1_output.fst.fst  :=
begin
  rw example1_input,
  rw example1_output,

  rw rowround_single,
  rw quarterround.quarterround,

  rw quarterround.qr0,
  rw quarterround.qr1,
  rw quarterround.qr2,
  rw quarterround.qr3,

  rw quarterround.qr2,
  rw quarterround.qr1,

  repeat { rw operations.operation },
  repeat { rw operations.operation_rhs },
  repeat { rw operations.xor },
  repeat { rw operations.mod },
  repeat { rw operations.rotl },
  repeat { rw params.max_bitvec },
  repeat { rw params.mod },
  repeat { rw params.word_len },
  repeat { rw bitvec.of_nat },
  repeat { rw bitvec.shl },
  repeat { rw bitvec.ushr },
  repeat { rw bitvec.fill_shr },
  repeat { rw bitvec.of_nat },

  norm_num,

  refl,
end

/-- `rowround_single (1, 0, 0, 0) = 128` -/
lemma example1_rowround_single_1 : (rowround_single example1_input.fst).snd.fst = example1_output.fst.snd.fst  :=
begin
  rw example1_input,
  rw example1_output,

  rw rowround_single,
  rw quarterround.quarterround,

  rw quarterround.qr0,
  rw quarterround.qr1,
  rw quarterround.qr2,
  rw quarterround.qr3,

  rw quarterround.qr2,
  rw quarterround.qr1,

  repeat { rw operations.operation },
  repeat { rw operations.operation_rhs },
  repeat { rw operations.xor },
  repeat { rw operations.mod },
  repeat { rw operations.rotl },
  repeat { rw params.max_bitvec },
  repeat { rw params.mod },
  repeat { rw params.word_len },
  repeat { rw bitvec.of_nat },
  repeat { rw bitvec.shl },
  repeat { rw bitvec.ushr },
  repeat { rw bitvec.fill_shr },
  repeat { rw bitvec.of_nat },

  norm_num,

  refl,
end

-- #eval if rowround_output (rowround (rowround_input input)) = output then "pass" else "fail"

-- example 2

def input' : matrixType :=
  (
    (0x08521bd6, 0x1fe88837, 0xbb2aa576, 0x3aa26365),
    (0xc54c6a5b, 0x2fc74c2f, 0x6dd39cc3, 0xda0a64f6),
    (0x90a2f23d, 0x067f95a6, 0x06b35f61, 0x41e4732e),
    (0xe859c100, 0xea4d84b7, 0x0f619bff, 0xbc6e965a)
  )

def output' : matrixType :=
  (
    (0xa890d39d, 0x65d71596, 0xe9487daa, 0xc8ca6a86),
    (0x949d2192, 0x764b7754, 0xe408d9b9, 0x7a41b4d1),
    (0x3402e183, 0x3c3af432, 0x50669f96, 0xd89ef0a8),
    (0x0040ede5, 0xb545fbce, 0xd257ed4f, 0x1818882d)
  )

-- #eval if rowround_output (rowround (rowround_input input')) = output' then "pass" else "fail"

/-
  Inverse examples, using the same test vectors as the spec but going backwards.
-/

-- example1
-- #eval if rowround_output (rowround_inv (rowround_input output)) = input then "pass" else "fail"

-- example2
-- #eval if rowround_output (rowround_inv (rowround_input output')) = input' then "pass" else "fail"

end rowround_examples


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Sean Leather
-/
import algebra.group.opposite
import algebra.free_monoid.basic
import control.traversable.instances
import control.traversable.lemmas
import category_theory.endomorphism
import category_theory.types
import category_theory.category.Kleisli
/-!

# List folds generalized to `traversable`

Informally, we can think of `foldl` as a special case of `traverse` where we do not care about the
reconstructed data structure and, in a state monad, we care about the final state.

The obvious way to define `foldl` would be to use the state monad but it
is nicer to reason about a more abstract interface with `fold_map` as a
primitive and `fold_map_hom` as a defining property.

```
def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω := ...

lemma fold_map_hom (α β)
  [monoid α] [monoid β] (f : α →* β)
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
...
```

`fold_map` uses a monoid ω to accumulate a value for every element of
a data structure and `fold_map_hom` uses a monoid homomorphism to
substitute the monoid used by `fold_map`. The two are sufficient to
define `foldl`, `foldr` and `to_list`. `to_list` permits the
formulation of specifications in terms of operations on lists.

Each fold function can be defined using a specialized
monoid. `to_list` uses a free monoid represented as a list with
concatenation while `foldl` uses endofunctions together with function
composition.

The definition through monoids uses `traverse` together with the
applicative functor `const m` (where `m` is the monoid). As an
implementation, `const` guarantees that no resource is spent on
reconstructing the structure during traversal.

A special class could be defined for `foldable`, similarly to Haskell,
but the author cannot think of instances of `foldable` that are not also
`traversable`.
-/

universes u v

open ulift category_theory mul_opposite

namespace monoid
variables {m : Type u → Type u} [monad m]
variables {α β : Type u}
/--
For a list, foldl f x [y₀,y₁] reduces as follows:

```
calc  foldl f x [y₀,y₁]
    = foldl f (f x y₀) [y₁]      : rfl
... = foldl f (f (f x y₀) y₁) [] : rfl
... = f (f x y₀) y₁              : rfl
```
with
```
f : α → β → α
x : α
[y₀,y₁] : list β
```

We can view the above as a composition of functions:
```
... = f (f x y₀) y₁              : rfl
... = flip f y₁ (flip f y₀ x)    : rfl
... = (flip f y₁ ∘ flip f y₀) x  : rfl
```

We can use traverse and const to construct this composition:
```
calc   const.run (traverse (λ y, const.mk' (flip f y)) [y₀,y₁]) x
     = const.run ((::) <$> const.mk' (flip f y₀) <*> traverse (λ y, const.mk' (flip f y)) [y₁]) x
...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
         ( (::) <$> const.mk' (flip f y₁) <*> traverse (λ y, const.mk' (flip f y)) [] )) x
...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
         ( (::) <$> const.mk' (flip f y₁) <*> pure [] )) x
...  = const.run ( ((::) <$> const.mk' (flip f y₁) <*> pure []) ∘
         ((::) <$> const.mk' (flip f y₀)) ) x
...  = const.run ( const.mk' (flip f y₁) ∘ const.mk' (flip f y₀) ) x
...  = const.run ( flip f y₁ ∘ flip f y₀ ) x
...  = f (f x y₀) y₁
```

And this is how `const` turns a monoid into an applicative functor and
how the monoid of endofunctions define `foldl`.
-/
@[reducible] def foldl (α : Type u) : Type u := (End α)ᵐᵒᵖ
def foldl.mk (f : α → α) : foldl α := op f
def foldl.get (x : foldl α) : α → α := unop x
@[simps] def foldl.of_free_monoid (f : β → α → β) : free_monoid α →* monoid.foldl β :=
{ to_fun := λ xs, op $ flip (list.foldl f) xs.to_list,
  map_one' := rfl,
  map_mul' := by intros; simp only [free_monoid.to_list_mul, flip, unop_op,
    list.foldl_append, op_inj]; refl }

@[reducible] def foldr (α : Type u) : Type u := End α
def foldr.mk (f : α → α) : foldr α := f
def foldr.get (x : foldr α) : α → α := x
@[simps] def foldr.of_free_monoid (f : α → β → β) : free_monoid α →* monoid.foldr β :=
{ to_fun := λ xs, flip (list.foldr f) xs.to_list,
  map_one' := rfl,
  map_mul' := λ xs ys, funext $ λ z, list.foldr_append _ _ _ _ }

@[reducible] def mfoldl (m : Type u → Type u) [monad m] (α : Type u) : Type u :=
mul_opposite $ End $ Kleisli.mk m α
def mfoldl.mk (f : α → m α) : mfoldl m α := op f
def mfoldl.get (x : mfoldl m α) : α → m α := unop x
@[simps] def mfoldl.of_free_monoid [is_lawful_monad m] (f : β → α → m β) :
  free_monoid α →* monoid.mfoldl m β :=
{ to_fun := λ xs, op $ flip (list.mfoldl f) xs.to_list,
  map_one' := rfl,
  map_mul' := by intros; apply unop_injective; ext; apply list.mfoldl_append }

@[reducible] def mfoldr (m : Type u → Type u) [monad m] (α : Type u) : Type u :=
End $ Kleisli.mk m α
def mfoldr.mk (f : α → m α) : mfoldr m α := f
def mfoldr.get (x : mfoldr m α) : α → m α := x
@[simps] def mfoldr.of_free_monoid [is_lawful_monad m] (f : α → β → m β) :
  free_monoid α →* monoid.mfoldr m β :=
{ to_fun := λ xs, flip (list.mfoldr f) xs.to_list,
  map_one' := rfl,
  map_mul' := by intros; ext; apply list.mfoldr_append }

end monoid

namespace traversable
open monoid functor

section defs
variables {α β : Type u} {t : Type u → Type u} [traversable t]

def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω :=
traverse (const.mk' ∘ f)

def foldl (f : α → β → α) (x : α) (xs : t β) : α :=
(fold_map (foldl.mk ∘ flip f) xs).get x

def foldr (f : α → β → β) (x : β) (xs : t α) : β :=
(fold_map (foldr.mk ∘ f) xs).get x

/--
Conceptually, `to_list` collects all the elements of a collection
in a list. This idea is formalized by

  `lemma to_list_spec (x : t α) : to_list x = fold_map free_monoid.mk x`.

The definition of `to_list` is based on `foldl` and `list.cons` for
speed. It is faster than using `fold_map free_monoid.mk` because, by
using `foldl` and `list.cons`, each insertion is done in constant
time. As a consequence, `to_list` performs in linear.

On the other hand, `fold_map free_monoid.mk` creates a singleton list
around each element and concatenates all the resulting lists. In
`xs ++ ys`, concatenation takes a time proportional to `length xs`. Since
the order in which concatenation is evaluated is unspecified, nothing
prevents each element of the traversable to be appended at the end
`xs ++ [x]` which would yield a `O(n²)` run time. -/
def to_list : t α → list α :=
list.reverse ∘ foldl (flip list.cons) []

def length (xs : t α) : ℕ :=
down $ foldl (λ l _, up $ l.down + 1) (up 0) xs

variables {m : Type u → Type u} [monad m]

def mfoldl (f : α → β → m α) (x : α) (xs : t β) : m α :=
(fold_map (mfoldl.mk ∘ flip f) xs).get x

def mfoldr (f : α → β → m β) (x : β) (xs : t α) : m β :=
(fold_map (mfoldr.mk ∘ f) xs).get x

end defs

section applicative_transformation
variables {α β γ : Type u}

open function (hiding const)

def map_fold [monoid α] [monoid β] (f : α →* β) :
  applicative_transformation (const α) (const β) :=
{ app := λ x, f,
  preserves_seq'  := by { intros, simp only [f.map_mul, (<*>)], },
  preserves_pure' := by { intros, simp only [f.map_one, pure] } }

lemma free.map_eq_map (f : α → β) (xs : list α) :
  f <$> xs = (free_monoid.map f (free_monoid.of_list xs)).to_list := rfl

lemma foldl.unop_of_free_monoid  (f : β → α → β) (xs : free_monoid α) (a : β) :
  unop (foldl.of_free_monoid f xs) a = list.foldl f a xs.to_list := rfl

variables (m : Type u → Type u) [monad m] [is_lawful_monad m]

variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
open is_lawful_traversable

lemma fold_map_hom [monoid α] [monoid β] (f : α →* β)
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
calc  f (fold_map g x)
    = f (traverse (const.mk' ∘ g) x)                                     : rfl
... = (map_fold f).app _ (traverse (const.mk' ∘ g) x)   : rfl
... = traverse ((map_fold f).app _ ∘ (const.mk' ∘ g)) x :
        naturality (map_fold f) _ _
... = fold_map (f ∘ g) x : rfl

lemma fold_map_hom_free
  [monoid β] (f : free_monoid α →* β) (x : t α) :
  f (fold_map free_monoid.of x) = fold_map (f ∘ free_monoid.of) x :=
fold_map_hom f _ x

end applicative_transformation

section equalities
open is_lawful_traversable list (cons)
variables {α β γ : Type u}
variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]

@[simp]
lemma foldl.of_free_monoid_comp_of (f : α → β → α) :
  foldl.of_free_monoid f ∘ free_monoid.of = foldl.mk ∘ flip f := rfl

@[simp]
lemma foldr.of_free_monoid_comp_of (f : β → α → α) :
  foldr.of_free_monoid f ∘ free_monoid.of = foldr.mk ∘ f := rfl

@[simp]
lemma mfoldl.of_free_monoid_comp_of {m} [monad m] [is_lawful_monad m] (f : α → β → m α) :
  mfoldl.of_free_monoid f ∘ free_monoid.of = mfoldl.mk ∘ flip f :=
by { ext1 x, simp [(∘), mfoldl.of_free_monoid, mfoldl.mk, flip], refl }

@[simp]
lemma mfoldr.of_free_monoid_comp_of {m} [monad m] [is_lawful_monad m] (f : β → α → m α) :
  mfoldr.of_free_monoid f ∘ free_monoid.of = mfoldr.mk ∘ f :=
by { ext, simp [(∘), mfoldr.of_free_monoid, mfoldr.mk, flip] }

lemma to_list_spec (xs : t α) :
  to_list xs = free_monoid.to_list (fold_map free_monoid.of xs) :=
eq.symm $
calc  free_monoid.to_list (fold_map free_monoid.of xs)
    = free_monoid.to_list (fold_map free_monoid.of xs).reverse.reverse
                 : by simp only [list.reverse_reverse]
... = free_monoid.to_list (list.foldr cons [] (fold_map free_monoid.of xs).reverse).reverse
                 : by simp only [list.foldr_eta]
... = (unop (foldl.of_free_monoid (flip cons) (fold_map free_monoid.of xs)) []).reverse
                 : by simp [flip, list.foldr_reverse, foldl.of_free_monoid, unop_op]
... = to_list xs : begin
                     rw fold_map_hom_free (foldl.of_free_monoid (flip $ @cons α)),
                     { simp only [to_list, foldl, list.reverse_inj, foldl.get,
                         foldl.of_free_monoid_comp_of] },
                     { apply_instance }
                   end

lemma fold_map_map [monoid γ]  (f : α → β) (g : β → γ) (xs : t α) :
  fold_map g (f <$> xs) = fold_map (g ∘ f) xs :=
by simp only [fold_map,traverse_map]

lemma foldl_to_list (f : α → β → α) (xs : t β) (x : α) :
  foldl f x xs = list.foldl f x (to_list xs) :=
begin
  rw [← free_monoid.to_list_of_list (to_list xs), ← foldl.unop_of_free_monoid],
  simp only [foldl, to_list_spec, fold_map_hom_free,
    foldl.of_free_monoid_comp_of, foldl.get, free_monoid.of_list_to_list]
end

lemma foldr_to_list (f : α → β → β) (xs : t α) (x : β) :
  foldr f x xs = list.foldr f x (to_list xs) :=
begin
  change _ = foldr.of_free_monoid _ (free_monoid.of_list $ to_list xs) _,
  rw [to_list_spec, foldr, foldr.get, free_monoid.of_list_to_list, fold_map_hom_free,
    foldr.of_free_monoid_comp_of]
end

/-

-/

lemma to_list_map (f : α → β) (xs : t α) :
  to_list (f <$> xs) = f <$> to_list xs :=
by simp only [to_list_spec, free.map_eq_map, fold_map_hom, fold_map_map,
  free_monoid.of_list_to_list, free_monoid.map_of, (∘)]

@[simp] theorem foldl_map (g : β → γ) (f : α → γ → α) (a : α) (l : t β) :
  foldl f a (g <$> l) = foldl (λ x y, f x (g y)) a l :=
by simp only [foldl, fold_map_map, (∘), flip]

@[simp] theorem foldr_map (g : β → γ) (f : γ → α → α) (a : α) (l : t β) :
  foldr f a (g <$> l) = foldr (f ∘ g) a l :=
by simp only [foldr, fold_map_map, (∘), flip]

@[simp] theorem to_list_eq_self {xs : list α} : to_list xs = xs :=
begin
  simp only [to_list_spec, fold_map, traverse],
  induction xs,
  case list.nil { refl },
  case list.cons : _ _ ih { conv_rhs { rw [← ih] }, refl }
end

theorem length_to_list {xs : t α} : length xs = list.length (to_list xs) :=
begin
  unfold length,
  rw foldl_to_list,
  generalize : to_list xs = ys,
  let f := λ (n : ℕ) (a : α), n + 1,
  transitivity list.foldl f 0 ys,
  { generalize : 0 = n,
    induction ys with _ _ ih generalizing n,
    { simp only [list.foldl_nil] },
    { simp only [list.foldl, ih (n+1)] } },
  { induction ys with _ tl ih,
    { simp only [list.length, list.foldl_nil] },
    { simp only [list.foldl, list.length],
      rw [← ih],
      exact tl.foldl_hom (λx, x+1) f f 0 (λ n x, rfl) } }
end

variables {m : Type u → Type u} [monad m] [is_lawful_monad m]

lemma mfoldl_to_list {f : α → β → m α} {x : α} {xs : t β} :
  mfoldl f x xs = list.mfoldl f x (to_list xs) :=
calc mfoldl f x xs = unop (mfoldl.of_free_monoid f (free_monoid.of_list $ to_list xs)) x :
  by simp only [mfoldl, to_list_spec, fold_map_hom_free (mfoldl.of_free_monoid f),
    mfoldl.of_free_monoid_comp_of, mfoldl.get, free_monoid.of_list_to_list]
... = list.mfoldl f x (to_list xs) : by simp [mfoldl.of_free_monoid, unop_op, flip]

lemma mfoldr_to_list (f : α → β → m β) (x : β) (xs : t α) :
  mfoldr f x xs = list.mfoldr f x (to_list xs) :=
begin
  change _ = mfoldr.of_free_monoid f (free_monoid.of_list $ to_list xs) x,
  simp only [mfoldr, to_list_spec, fold_map_hom_free (mfoldr.of_free_monoid f),
    mfoldr.of_free_monoid_comp_of, mfoldr.get, free_monoid.of_list_to_list]
end

@[simp] theorem mfoldl_map (g : β → γ) (f : α → γ → m α) (a : α) (l : t β) :
  mfoldl f a (g <$> l) = mfoldl (λ x y, f x (g y)) a l :=
by simp only [mfoldl, fold_map_map, (∘), flip]

@[simp] theorem mfoldr_map (g : β → γ) (f : γ → α → m α) (a : α) (l : t β) :
  mfoldr f a (g <$> l) = mfoldr (f ∘ g) a l :=
by simp only [mfoldr, fold_map_map, (∘), flip]

end equalities

end traversable


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta
-/
import category_theory.limits.creates
import category_theory.over
import category_theory.is_connected

/-!
# Connected limits in the over category

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

Shows that the forgetful functor `over B ⥤ C` creates connected limits, in particular `over B` has
any connected limit which `C` has.
-/

universes v u -- morphism levels before object levels. See note [category_theory universes].

noncomputable theory

open category_theory category_theory.limits

variables {J : Type v} [small_category J]
variables {C : Type u} [category.{v} C]
variable {X : C}

namespace category_theory.over

namespace creates_connected

/--
(Impl) Given a diagram in the over category, produce a natural transformation from the
diagram legs to the specific object.
-/
def nat_trans_in_over {B : C} (F : J ⥤ over B) :
  F ⋙ forget B ⟶ (category_theory.functor.const J).obj B :=
{ app := λ j, (F.obj j).hom }

local attribute [tidy] tactic.case_bash

/--
(Impl) Given a cone in the base category, raise it to a cone in the over category. Note this is
where the connected assumption is used.
-/
@[simps]
def raise_cone [is_connected J] {B : C} {F : J ⥤ over B} (c : cone (F ⋙ forget B)) :
  cone F :=
{ X := over.mk (c.π.app (classical.arbitrary J) ≫ (F.obj (classical.arbitrary J)).hom),
  π :=
  { app := λ j,
      over.hom_mk (c.π.app j) (nat_trans_from_is_connected (c.π ≫ nat_trans_in_over F) j _) } }

lemma raised_cone_lowers_to_original [is_connected J] {B : C} {F : J ⥤ over B}
  (c : cone (F ⋙ forget B)) (t : is_limit c) :
  (forget B).map_cone (raise_cone c) = c :=
by tidy

/-- (Impl) Show that the raised cone is a limit. -/
def raised_cone_is_limit [is_connected J] {B : C} {F : J ⥤ over B}
  {c : cone (F ⋙ forget B)} (t : is_limit c) :
  is_limit (raise_cone c) :=
{ lift := λ s, over.hom_mk (t.lift ((forget B).map_cone s)) (by { dsimp, simp }),
  uniq' := λ s m K, by { ext1, apply t.hom_ext, intro j, simp [← K j] } }

end creates_connected

/-- The forgetful functor from the over category creates any connected limit. -/
instance forget_creates_connected_limits
  [is_connected J] {B : C} : creates_limits_of_shape J (forget B) :=
{ creates_limit := λ K,
    creates_limit_of_reflects_iso (λ c t,
      { lifted_cone := creates_connected.raise_cone c,
        valid_lift := eq_to_iso (creates_connected.raised_cone_lowers_to_original c t),
        makes_limit := creates_connected.raised_cone_is_limit t } ) }

/-- The over category has any connected limit which the original category has. -/
instance has_connected_limits
  {B : C} [is_connected J] [has_limits_of_shape J C] : has_limits_of_shape J (over B) :=
{ has_limit := λ F, has_limit_of_created F (forget B) }

end category_theory.over


import constructions
import endofunctor.algebra

universes u₀ u₁

namespace category_theory

namespace W_type
open endofunctor

/-
We fix a W-type consisting of an index α of constructors and
their dependently indexed arities β.
-/
variables {α : Type u₀} (β : α → Type u₁)

/-- The polynomial endofunctor associated to a `W_type` -/
@[simps] def polynomial_endofunctor : Type (max u₀ u₁) ⥤ Type (max u₀ u₁) :=
{ obj := λ X, Σ (a : α), β a → X,
  map := λ X Y f p, ⟨ p.1 , f ∘ p.2 ⟩ }

/-- The category of W_types -/
@[nolint check_univs]
structure cat :=
{α : Type*}
(β : α → Type*)

/-- Polynomial endofunctors form a full subcategory of `C ⥤ C` -/
instance : category cat :=
{ hom := λ W₀ W₁, nat_trans (polynomial_endofunctor W₀.β) (polynomial_endofunctor W₁.β),
  id := λ _, nat_trans.id _,
  comp := λ _ _ _, nat_trans.vcomp }

namespace cat

/-- Two W_types are isomorphic if their endofunctors are isomorphic -/
def iso_of_iso {W₀ W₁ : cat} (endo_iso : polynomial_endofunctor W₀.β ≅ polynomial_endofunctor W₁.β) :
  W₀ ≅ W₁ :=
{ hom := endo_iso.hom,
  inv := endo_iso.inv,
  hom_inv_id' := endo_iso.hom_inv_id,
  inv_hom_id' := endo_iso.inv_hom_id }.

/-- Two W_types are isomorphic if their defining types are equivalent -/
def iso_of_equiv {W₀ W₁ : cat} (hα : W₀.α ≃ W₁.α) (hβ : ∀ a : W₀.α, W₀.β a ≃ W₁.β (hα.to_fun a)) :
  W₀ ≅ W₁ :=
iso_of_iso $ nat_iso.of_components
  (λ X, equiv.to_iso $ equiv.sigma_congr hα (λ a, equiv.Pi_congr' (hβ _) (by { intro, refl })))
  (by { intros, funext,
    simp only [types_comp_apply, equiv.to_iso, equiv.sigma_congr, equiv.to_fun_as_coe,
      equiv.coe_trans, function.comp_app, equiv.sigma_congr_right_apply, equiv.coe_Pi_congr',
      polynomial_endofunctor_map_snd, equiv.coe_refl, id.def, equiv.sigma_congr_left_apply],
    dsimp only [polynomial_endofunctor],
    simp [equiv.Pi_congr'_apply] })

open endofunctor.algebra

/-- If the `W_types` are isomorphic then their algebra categories are equivalent -/
def iso_to_equivalence {W₀ W₁ : cat} (hiso : W₀ ≅ W₁) :
algebra (polynomial_endofunctor W₀.β) ≌ algebra (polynomial_endofunctor W₁.β) :=
{ functor := functor_of_nat_trans hiso.inv,
  inverse := functor_of_nat_trans hiso.hom,
  unit_iso := functor_of_nat_trans_id.symm ≪≫
    functor_of_nat_trans_eq hiso.3.symm ≪≫ (functor_of_nat_trans_comp _ _),
  counit_iso := (functor_of_nat_trans_comp _ _).symm ≪≫
    functor_of_nat_trans_eq hiso.4 ≪≫ functor_of_nat_trans_id }

/--
The endofunctor `Σ (x : γ), X ^ (fin n) ≃ γ X ^ n `
-/
@[simp] def monomial (γ : Type u₀) (n : ℕ) : cat := ⟨ λ x : γ, ulift (fin n) ⟩

/--
The identity endofunctor as a W_type,
`X ≃ punit X ^ 1`
-/
@[simp] def X : cat := monomial punit 1

/--
The polynomial endofunctor taking anything to `⊥_ = pempty`,
since `pempty ≃ pempty X ^ 0` -/
@[simps] instance : has_zero cat := { zero := monomial pempty 0 }

instance : inhabited cat := ⟨ 0 ⟩

/--
The polynomial endofunctor taking anything to `⊤_ = punit`,
since `punit ≃ punit X ^ 0`
-/
@[simps] instance : has_one cat := { one := monomial punit 0 }

/--
The constant functor going to a type `γ` is a polynomial
`γ = Σ (a : γ) 1 = Σ (a : γ) X ^ pempty `
-/
instance : has_coe (Type u₀) cat.{u₀ u₀} := { coe := λ γ, monomial γ 0 }

@[simp] lemma coe_β_eq (γ : Type u₀) :
  (γ : cat.{u₀ u₀}).β = λ (_ : γ), ulift (fin 0) := rfl

/--
The sum of two polynomial endofunctors
`Σ (a : α₀) X^(β a) + Σ (a : α₁) X^(β₁ a) ≃ Σ (a : α₀ ⊕ α₁) X^((β₀ ⊕ β₁) a)`
-/
@[simps] def addition : cat.{u₁ u₀} → cat.{u₁ u₀} → cat.{u₁ u₀} :=
λ W₀ W₁, ⟨ sum.elim W₀.β W₁.β ⟩

@[simps] instance : has_add cat := { add := addition }

end cat

/-- `W_type` β as an algebra of its associated polynomial endofunctor -/
def as_algebra : algebra (polynomial_endofunctor β) :=
{ A   := W_type β,
  str := W_type.of_sigma }

variables {β} (A : algebra (polynomial_endofunctor β))

/-- The map in `Type` from the initial algebra `W_type` to any other algebra -/
def lift_f : W_type β → A.A
| (W_type.mk a b) := A.str ⟨ a , λ x, lift_f (b x) ⟩

/-- The map in `endofunctor.algebra` from the initial algebra `W_type` to any other algebra -/
def lift : as_algebra β ⟶ A := { f := lift_f A }

lemma lift_uniq (f : as_algebra β ⟶ A) : f = lift A :=
begin
  ext w,
  induction w with a b hw,
  simp only [lift, lift_f],
  convert (congr_fun f.2 ⟨ a , b ⟩).symm,
  funext x,
  exact (hw x).symm,
end

instance (A : algebra (polynomial_endofunctor β)) : unique (as_algebra β ⟶ A) :=
{ default := lift A,
  uniq := lift_uniq A }.

/-- A `W_Type` is the initial algebra of its associated polynomial endofunctor -/
def is_initial : limits.is_initial (as_algebra β) :=
limits.is_initial.of_unique _

section instances

open _root_.W_type cat

/-- The polynomial endofunctor of the `W_type` for `ℕ` is `1 + X` (a.k.a the maybe monad) -/
def cat_nat_β_eq_one_add_X : cat.mk nat_β ≅ 1 + X :=
iso_of_equiv (nat_α_equiv_bool.trans equiv.bool_equiv_punit_sum_punit)
  (λ c, match c with
    | nat_α.zero := by {dsimp [nat_β, equiv.bool_equiv_punit_sum_punit, nat_α_equiv_bool],
      exact (equiv.equiv_empty _).symm }
    | nat_α.succ := by {dsimp [nat_β, equiv.bool_equiv_punit_sum_punit, nat_α_equiv_bool],
      exact equiv_of_unique_of_unique }
    end)

/-- The polynomial endofunctor for the `W_type` for `list γ` is `1 + γ X` -/
def cat_list_β_eq_one_add_type (γ : Type u₁) : cat.mk (list_β γ) ≅ 1 + monomial γ 1 :=
iso_of_equiv (list_α_equiv_punit_sum γ)
  (λ c, match c with
    | list_α.nil := by { dsimp [list_β, list_α_equiv_punit_sum],
      exact (equiv.equiv_pempty _).symm }
    | list_α.cons x := by { dsimp [list_β, list_α_equiv_punit_sum],
      exact equiv_of_unique_of_unique }
    end)

end instances

end W_type

end category_theory


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.nat.basic
import algebra.ordered_group
/-!
# `with_bot ℕ`

Lemmas about the type of natural numbers with a bottom element adjoined.
-/
namespace nat

lemma with_bot.add_eq_zero_iff : ∀ {n m : with_bot ℕ}, n + m = 0 ↔ n = 0 ∧ m = 0
| none     m        := iff_of_false dec_trivial (λ h, absurd h.1 dec_trivial)
| n        none     := iff_of_false (by cases n; exact dec_trivial)
  (λ h, absurd h.2 dec_trivial)
| (some n) (some m) := show (n + m : with_bot ℕ) = (0 : ℕ) ↔ (n : with_bot ℕ) = (0 : ℕ) ∧
    (m : with_bot ℕ) = (0 : ℕ),
  by rw [← with_bot.coe_add, with_bot.coe_eq_coe, with_bot.coe_eq_coe,
    with_bot.coe_eq_coe, add_eq_zero_iff' (nat.zero_le _) (nat.zero_le _)]

lemma with_bot.add_eq_one_iff : ∀ {n m : with_bot ℕ}, n + m = 1 ↔ (n = 0 ∧ m = 1) ∨ (n = 1 ∧ m = 0)
| none     none     := dec_trivial
| none     (some m) := dec_trivial
| (some n) none     := iff_of_false dec_trivial (λ h, h.elim (λ h, absurd h.2 dec_trivial)
  (λ h, absurd h.2 dec_trivial))
| (some n) (some 0) := by erw [with_bot.coe_eq_coe, with_bot.coe_eq_coe, with_bot.coe_eq_coe,
    with_bot.coe_eq_coe]; simp
| (some n) (some (m + 1)) := by erw [with_bot.coe_eq_coe, with_bot.coe_eq_coe, with_bot.coe_eq_coe,
    with_bot.coe_eq_coe, with_bot.coe_eq_coe]; simp [nat.add_succ, nat.succ_inj', nat.succ_ne_zero]

@[simp] lemma with_bot.coe_nonneg {n : ℕ} : 0 ≤ (n : with_bot ℕ) :=
by rw [← with_bot.coe_zero, with_bot.coe_le_coe]; exact nat.zero_le _

@[simp] lemma with_bot.lt_zero_iff (n : with_bot ℕ) : n < 0 ↔ n = ⊥ :=
option.cases_on n dec_trivial (λ n, iff_of_false
  (by simp [with_bot.some_eq_coe]) (λ h, option.no_confusion h))

end nat