/-
Copyright (c) 2022 Wojciech Nawrocki. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Wojciech Nawrocki
-/
import Std.Data.List.Lemmas
import Std.Data.Array.Lemmas
import Std.Tactic.ShowTerm

import Mathlib.Data.List.Perm

import ProofChecker.Model.ToMathlib
import ProofChecker.Data.HashMap.Basic
import ProofChecker.Data.HashMap.WF

namespace HashMap
open Std (AssocList)
variable [BEq α] [Hashable α] [LawfulHashable α] [PartialEquivBEq α]

namespace Imp
open List

-- NOTE(WN): These would ideally be solved by a congruence-closure-for-PERs tactic
-- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Rewriting.20congruent.20relations
-- Same for proofs about List.Perm
private theorem beq_nonsense_1 {a b c : α} : a != b → a == c → b != c :=
  fun h₁ h₂ => Bool.bne_iff_not_beq.mpr fun h₃ =>
    Bool.bne_iff_not_beq.mp h₁ (PartialEquivBEq.trans h₂ (PartialEquivBEq.symm h₃))

private theorem beq_nonsense_2 {a b c : α} : a == b → b == c → ¬(c != a) :=
  fun h₁ h₂ h₃ => Bool.bne_iff_not_beq.mp (bne_symm h₃) (PartialEquivBEq.trans h₁ h₂)

private theorem beq_nonsense_3 {a b c : α} : a != b → c == b  → c != a :=
  fun h₁ h₂ => bne_symm (beq_nonsense_1 (bne_symm h₁) (PartialEquivBEq.symm h₂))

namespace Buckets

/-- The contents of any given bucket are pairwise `bne`. -/
theorem Pairwise_bne_bucket (bkts : Buckets α β) (H : bkts.WF) (h : i < bkts.val.size) :
    Pairwise (·.1 != ·.1) bkts.val[i].toList := by
  have := H.distinct bkts.val[i] (Array.getElem_mem_data _ _)
  exact Pairwise.imp Bool.bne_iff_not_beq.mpr this

/-- Reformulation of `Pairwise_bne_bucket` for use with `List.foo_of_unique`. -/
theorem Pairwise_bne_bucket' (bkts : Buckets α β) (H : bkts.WF) (h : i < bkts.val.size) (a : α) :
    Pairwise (fun p q => p.1 == a → q.1 != a) bkts.val[i].toList :=
  Pairwise.imp beq_nonsense_1 (Pairwise_bne_bucket bkts H h)

/-! ## Main abstraction using `toListModel` -/

/-- It is a bit easier to reason about `foldl (append)` than `foldl (foldl)`, so we use this
(less efficient) variant of `toList` as the mathematical model. -/
def toListModel (bkts : Buckets α β) : List (α × β) :=
  -- Note(WN): the implementation is  `bkts.foldl` rather than `bkts.data.foldl` because we need
  -- to reason about array indices in some of the theorems.
  bkts.val.foldl (init := []) (fun acc bkt => acc ++ bkt.toList)

attribute [local simp] foldl_cons_fn foldl_append_fn

theorem toListModel_eq (bkts : Buckets α β) : bkts.toListModel = bkts.val.data.bind (·.toList) := by
  simp [toListModel, Array.foldl_eq_foldl_data]

theorem mem_toListModel_iff_mem_bucket (bkts : Buckets α β) (H : bkts.WF) (ab : α × β) :
    haveI := mkIdx (hash ab.fst) bkts.property
    ab ∈ bkts.toListModel ↔ ab ∈ (bkts.val[this.1.toNat]'this.2).toList := by
  have : ab ∈ bkts.toListModel ↔ ∃ bkt ∈ bkts.val.data, ab ∈ bkt.toList := by
    simp [toListModel_eq, mem_bind]
  rw [this]
  clear this
  apply Iff.intro
  . intro ⟨bkt, hBkt, hMem⟩
    have ⟨i, hGetI⟩ := Array.get_of_mem_data hBkt
    simp only [getElem_fin] at hGetI
    suffices (mkIdx (hash ab.fst) bkts.property).val.toNat = i by
      simp [Array.ugetElem_eq_getElem, this, hGetI, hMem]
    unfold Imp.mkIdx
    dsimp
    exact H.hash_self i.val i.isLt ab (hGetI ▸ hMem)
  . intro h
    refine ⟨_, Array.getElem_mem_data _ _, h⟩

/-- The map does not store duplicate (by `beq`) keys. -/
theorem Pairwise_bne_toListModel (bkts : Buckets α β) (H : bkts.WF) :
    bkts.toListModel.Pairwise (·.1 != ·.1) := by
  unfold toListModel
  refine Array.foldl_induction
    (motive := fun i (acc : List (α × β)) =>
      -- The acc has the desired property
      acc.Pairwise (·.1 != ·.1)
      -- All not-yet-accumulated buckets are pairwise disjoint with the acc
      ∧ ∀ j, i ≤ j → (_ : j < bkts.val.size) →
        ∀ p ∈ acc, ∀ r ∈ bkts.val[j].toList, p.1 != r.1)
    ?h0 ?hf |>.left
  case h0 => exact ⟨Pairwise.nil, fun.⟩
  case hf =>
    intro i acc h
    refine ⟨pairwise_append.mpr ⟨h.left, ?bkt, ?accbkt⟩, ?accbkts⟩
    case bkt => apply Pairwise_bne_bucket bkts H
    case accbkt =>
      intro a hA b hB
      exact h.right i.val (Nat.le_refl _) i.isLt a hA b hB
    case accbkts =>
      intro j hGe hLt p hP r hR
      cases mem_append.mp hP
      case inl hP => exact h.right j (Nat.le_of_succ_le hGe) hLt p hP r hR
      case inr hP =>
        -- Main proof 2: distinct buckets store bne keys
        refine Bool.bne_iff_not_beq.mpr fun h => ?_
        have hHashEq := LawfulHashable.hash_eq h
        have hGt := Nat.lt_of_succ_le hGe
        have hHashP := H.hash_self i (Nat.lt_trans hGt hLt) _ hP
        have hHashR := H.hash_self j hLt _ hR
        dsimp at hHashP hHashR
        have : i.val = j := by
          rw [hHashEq] at hHashP
          exact .trans hHashP.symm hHashR
        exact Nat.ne_of_lt hGt this

/-- Reformulation of `Pairwise_bne_toListModel` for use with `List.foo_of_unique`. -/
-- TODO: rm in favor of below
theorem Pairwise_bne_toListModel' (bkts : Buckets α β) (H : bkts.WF) (a : α) :
    bkts.toListModel.Pairwise (fun p q => p.1 == a → q.1 != a) :=
  Pairwise.imp beq_nonsense_1 (Pairwise_bne_toListModel bkts H)

theorem unique_toListModel (bkts : Buckets α β) (H : bkts.WF) (a : α) :
    bkts.toListModel.unique (·.1 == a) :=
  Pairwise.imp
    (fun h h₁ h₂ => Bool.bne_iff_not_beq.mp (h h₁) h₂)
    (Pairwise_bne_toListModel' bkts H a)

@[simp]
theorem toListModel_mk (size : Nat) (h : size.isPowerOfTwo) :
    (Buckets.mk (α := α) (β := β) size h).toListModel = [] := by
  simp only [Buckets.mk, toListModel_eq, mkArray_data]
  clear h
  induction size <;> simp [*]

theorem exists_of_toListModel_update (bkts : Buckets α β) (i d h) :
    ∃ l₁ l₂, bkts.toListModel = l₁ ++ bkts.1[i.toNat].toList ++ l₂
      ∧ (bkts.update i d h).toListModel = l₁ ++ d.toList ++ l₂ := by
  have ⟨bs₁, bs₂, hTgt, _, hUpd⟩ := bkts.exists_of_update i d h
  refine ⟨bs₁.bind (·.toList), bs₂.bind (·.toList), ?_, ?_⟩
  . simp [toListModel_eq, hTgt]
  . simp [toListModel_eq, hUpd]

theorem exists_of_toListModel_update_WF (bkts : Buckets α β) (H : bkts.WF) (i d h) :
    ∃ l₁ l₂, bkts.toListModel = l₁ ++ bkts.1[i.toNat].toList ++ l₂
      ∧ (bkts.update i d h).toListModel = l₁ ++ d.toList ++ l₂
      ∧ ∀ ab ∈ l₁, ((hash ab.fst).toUSize % bkts.val.size) < i := by
  have ⟨bs₁, bs₂, hTgt, hLen, hUpd⟩ := bkts.exists_of_update i d h
  refine ⟨bs₁.bind (·.toList), bs₂.bind (·.toList), ?_, ?_, ?_⟩
  . simp [toListModel_eq, hTgt]
  . simp [toListModel_eq, hUpd]
  . intro ab hMem
    have ⟨bkt, hBkt, hAb⟩ := mem_bind.mp hMem
    clear hMem
    have ⟨⟨j, hJ⟩, hEq⟩ := get_of_mem hBkt
    have hJ' : j < bkts.val.size := by
      apply Nat.lt_trans hJ
      simp [Array.size, hTgt, Nat.lt_add_of_pos_right (Nat.succ_pos _)]
    have : ab ∈ (bkts.val[j]).toList := by
      suffices bkt = bkts.val[j] by rwa [this] at hAb
      have := @List.get_append _ _ (bkts.val[i] :: bs₂) j hJ
      dsimp at this
      rw [← hEq, ← this, ← get_of_eq hTgt ⟨j, _⟩]
      rfl
    rwa [hLen, ← H.hash_self _ _ _ this] at hJ

theorem toListModel_reinsertAux (tgt : Buckets α β) (a : α) (b : β) :
    (reinsertAux tgt a b).toListModel ~ (a, b) :: tgt.toListModel := by
  unfold reinsertAux
  have ⟨l₁, l₂, hTgt, hUpd⟩ :=
    haveI := mkIdx (hash a) tgt.property
    tgt.exists_of_toListModel_update this.1 (.cons a b (tgt.1[this.1.toNat]'this.2)) this.2
  simp [hTgt, hUpd, perm_middle]

theorem toListModel_foldl_reinsertAux (bkt : List (α × β)) (tgt : Buckets α β) :
    (bkt.foldl (init := tgt) fun acc x => reinsertAux acc x.fst x.snd).toListModel
    ~ tgt.toListModel ++ bkt := by
  induction bkt generalizing tgt with
  | nil => simp [Perm.refl]
  | cons p ps ih =>
    refine Perm.trans (ih _) ?_
    refine Perm.trans (Perm.append_right ps (toListModel_reinsertAux _ _ _)) ?_
    rw [cons_append]
    refine Perm.trans (Perm.symm perm_middle) ?_
    apply Perm.append_left _ (Perm.refl _)

theorem toListModel_expand (size : Nat) (bkts : Buckets α β) :
    (expand size bkts).buckets.toListModel ~ bkts.toListModel := by
  refine (go _ _ _).trans ?_
  rw [toListModel_mk, toListModel_eq]
  simp [Perm.refl]
where
  go (i : Nat) (src : Array (AssocList α β)) (target : Buckets α β) :
      (expand.go i src target).toListModel
      ~ (src.data.drop i).foldl (init := target.toListModel) (fun a b => a ++ b.toList) := by
    unfold expand.go; split
    case inl hI =>
      refine (go (i +1) _ _).trans ?_
      have h₀ : (src.data.set i AssocList.nil).drop (i + 1) = src.data.drop (i + 1) := by
        apply drop_ext
        intro j hJ
        apply get?_set_ne _ _ (Nat.ne_of_lt <| Nat.lt_of_succ_le hJ)
      have h₁ : (drop i src.data).bind (·.toList) = src.data[i].toList
          ++ (drop (i + 1) src.data).bind (·.toList) := by
        have : i < src.data.length := by simp [hI]
        simp [drop_eq_cons_get _ _ this]
      simp [h₀, h₁]
      rw [← append_assoc]
      refine Perm.append ?_ (Perm.refl _)
      refine Perm.trans (toListModel_foldl_reinsertAux (AssocList.toList src[i]) _) ?_
      exact Perm.refl _
    case inr hI =>
      have : src.data.length ≤ i := by simp [Nat.le_of_not_lt, hI]
      simp [Perm.refl, drop_eq_nil_of_le this]
    termination_by _ i src _ => src.size - i

end Buckets

theorem findEntry?_eq (m : Imp α β) (H : m.buckets.WF) (a : α)
    : m.findEntry? a = m.buckets.toListModel.find? (·.1 == a) := by
  have hPairwiseBkt :
      haveI := mkIdx (hash a) m.buckets.property
      Pairwise (fun p q => p.1 == a → q.1 != a) (m.buckets.val[this.1]'this.2).toList :=
    by apply Buckets.Pairwise_bne_bucket' m.buckets H
  apply Option.ext
  intro (a', b)
  simp only [Option.mem_def, findEntry?, Imp.findEntry?, AssocList.findEntry?_eq,
    find?_eq_some_of_unique (Buckets.Pairwise_bne_toListModel' m.buckets H a),
    find?_eq_some_of_unique hPairwiseBkt,
    and_congr_left_iff]
  intro hBeq
  have : hash a' = hash a := LawfulHashable.hash_eq hBeq
  simp [Buckets.mem_toListModel_iff_mem_bucket m.buckets H, mkIdx, this]

theorem eraseP_toListModel_of_not_contains (m : Imp α β) (H : m.buckets.WF) (a : α) :
    haveI := mkIdx (hash a) m.buckets.property
    ¬(m.buckets.val[this.1.toNat]'this.2).contains a →
    m.buckets.toListModel.eraseP (·.1 == a) = m.buckets.toListModel := by
  intro hContains
  apply eraseP_of_forall_not
  intro ab hMem hEq
  have :
      haveI := mkIdx (hash a) m.buckets.property
      (m.buckets.val[this.1.toNat]'this.2).contains a := by
    simp only [AssocList.contains_eq, List.any_eq_true, mkIdx, ← LawfulHashable.hash_eq hEq]
    exact ⟨ab, (Buckets.mem_toListModel_iff_mem_bucket m.buckets H ab).mp hMem, hEq⟩
  contradiction

theorem toListModel_insert_perm (m : Imp α β) (H : m.buckets.WF) (a : α) (b : β) :
    (m.insert a b).buckets.toListModel ~ (a, b) :: m.buckets.toListModel.eraseP (·.1 == a) := by
  dsimp [insert, cond]; split
  next hContains =>
    have ⟨l₁, l₂, hTgt, hUpd, hProp⟩ :=
      haveI := mkIdx (hash a) m.buckets.property
      m.buckets.exists_of_toListModel_update_WF H this.1
        ((m.buckets.1[this.1.toNat]'this.2).replace a b) this.2
    rw [hUpd, hTgt]
    have hL₁ : ∀ ab ∈ l₁, ¬(ab.fst == a) := fun ab h hEq =>
      Nat.ne_of_lt (LawfulHashable.hash_eq hEq ▸ hProp ab h) rfl
    have ⟨p, hMem, hP⟩ := any_eq_true.mp (AssocList.contains_eq a _ ▸ hContains)
    simp [eraseP_append_right _ hL₁,
      eraseP_append_left (p := fun ab => ab.fst == a) hP _ hMem]
    -- begin cursed manual proofs
    refine Perm.trans ?_ perm_middle
    refine Perm.append (Perm.refl _) ?_
    rw [← cons_append]
    refine Perm.append ?_ (Perm.refl _)
    refine Perm.trans
      (replaceF_of_unique
        (b := (a, b))
        (f := fun a_1 => bif a_1.fst == a then some (a, b) else none)
        hMem
        (by simp [hP])
        (by
          refine Pairwise.imp ?_ (Buckets.Pairwise_bne_bucket' m.buckets H _ a)
          intro p q h hSome
          dsimp at *
          cases hEq: p.fst == a with
          | false => cases hEq ▸ hSome
          | true =>
            have : (q.fst == a) = false :=
              Bool.eq_false_iff.mpr (Bool.bne_iff_not_beq.mp <| h hEq)
            simp [this]))
      ?_
    apply List.Perm.of_eq
    congr
    apply funext
    intro x
    cases h : x.fst == a <;> simp [h]
    -- end cursed manual proofs

  next hContains =>
    rw [eraseP_toListModel_of_not_contains m H a (Bool.eq_false_iff.mp hContains)]
    split
    -- TODO(WN): how to merge the two branches below? They are identical except for the initial
    -- `refine`
    next =>
      have ⟨l₁, l₂, hTgt, hUpd⟩ :=
        haveI := mkIdx (hash a) m.buckets.property
        m.buckets.exists_of_toListModel_update this.1
          ((m.buckets.1[this.1.toNat]'this.2).cons a b) this.2
      simp [hTgt, hUpd, perm_middle]
    next =>
      refine Perm.trans (Buckets.toListModel_expand _ _) ?_
      have ⟨l₁, l₂, hTgt, hUpd⟩ :=
        haveI := mkIdx (hash a) m.buckets.property
        m.buckets.exists_of_toListModel_update this.1
          ((m.buckets.1[this.1.toNat]'this.2).cons a b) this.2
      simp [hTgt, hUpd, perm_middle]

theorem toListModel_erase (m : Imp α β) (H : m.buckets.WF) (a : α) :
    (m.erase a).buckets.toListModel = m.buckets.toListModel.eraseP (·.1 == a) := by
  dsimp [erase, cond]; split
  next hContains =>
    have ⟨l₁, l₂, hTgt, hUpd, hProp⟩ :=
      haveI := mkIdx (hash a) m.buckets.property
      m.buckets.exists_of_toListModel_update_WF H this.1
        ((m.buckets.1[this.1.toNat]'this.2).erase a) this.2
    rw [hTgt, hUpd]
    have hL₁ : ∀ ab ∈ l₁, ¬(ab.fst == a) := fun ab h hEq =>
      Nat.ne_of_lt (LawfulHashable.hash_eq hEq ▸ hProp ab h) rfl
    have ⟨p, hMem, hP⟩ := any_eq_true.mp (AssocList.contains_eq a _ ▸ hContains)
    simp [eraseP_append_right _ hL₁, eraseP_append_left (p := fun ab => ab.fst == a) hP _ hMem]
  next hContains =>
    rw [eraseP_toListModel_of_not_contains m H a (Bool.eq_false_iff.mp hContains)]

theorem eraseP_toListModel (m : Imp α β) (H : m.buckets.WF) (a : α) :
    m.buckets.toListModel.eraseP (·.1 == a) = m.buckets.toListModel.filter (·.1 != a) := by
  apply List.eraseP_eq_filter_of_unique
  apply List.Pairwise.imp ?_ (Buckets.Pairwise_bne_toListModel _ H)
  intro (a₁, _) (a₂, _) hA₁Bne hA₁Beq
  rw [Bool.not_eq_true_iff_ne_true, ← Bool.bne_iff_not_beq]
  exact beq_nonsense_1 hA₁Bne hA₁Beq

theorem toListModel_insert_perm' (m : Imp α β) (H : m.buckets.WF) (a : α) (b : β) :
    (m.insert a b).buckets.toListModel ~ (a, b) :: m.buckets.toListModel.filter (·.1 != a) :=
  eraseP_toListModel m H a ▸ toListModel_insert_perm m H a b

theorem toListModel_erase' (m : Imp α β) (H : m.buckets.WF) (a : α) :
    (m.erase a).buckets.toListModel = m.buckets.toListModel.filter (·.1 != a) :=
  eraseP_toListModel m H a ▸ toListModel_erase m H a

/-! ## Useful high-level theorems -/

theorem findEntry?_insert {a a' b} {m : Imp α β} (H : m.WF) :
    a == a' → (m.insert a b).findEntry? a' = some (a, b) := by
  intro hEq
  have hWF := WF_iff.mp H |>.right
  have hInsWF : (m.insert a b).buckets.WF := H.insert.out |>.right
  rw [findEntry?_eq _ hInsWF]
  have hPerm := toListModel_insert_perm m hWF a b
  have hUniq : (insert m a b).buckets.toListModel.unique (·.1 == a') :=
    Buckets.unique_toListModel _ hInsWF a'
  simp [find?_eq_of_perm_of_unique hPerm hUniq, hEq]

theorem findEntry?_insert_of_ne {a a'} {m : Imp α β} (H : m.WF) :
    a != a' → (m.insert a b).findEntry? a' = m.findEntry? a' := by
  intro hNe
  have hWF := WF_iff.mp H |>.right
  have hInsWF : (m.insert a b).buckets.WF := H.insert.out |>.right
  have hPerm := toListModel_insert_perm' m hWF a b
  have hUniq : (insert m a b).buckets.toListModel.unique (·.1 == a') :=
    Buckets.unique_toListModel _ hInsWF a'
  rw [findEntry?_eq _ hWF, findEntry?_eq _ hInsWF,
    find?_eq_of_perm_of_unique hPerm hUniq,
    find?_cons_of_neg _ ?ne]
  case ne => exact Bool.bne_iff_not_beq.mp hNe
  exact find?_filter _ _ _ fun _ => beq_nonsense_3 hNe

theorem findEntry?_erase {a a'} {m : Imp α β} (H : m.WF) :
    a == a' → (m.erase a).findEntry? a' = none := by
  intro hEq
  have hWF := WF_iff.mp H |>.right
  have hErsWF : (m.erase a).buckets.WF := H.erase.out |>.right
  rw [findEntry?_eq _ hErsWF, toListModel_erase' m hWF a,
    find?_filter' _ _ _ ?ne]
  case ne =>
    intro _ h
    simp only [Bool.bnot_eq_to_not_eq, Bool.not_eq_true, Bool.bne_eq_false]
    exact PartialEquivBEq.trans h (PartialEquivBEq.symm hEq)

end Imp

theorem toList_eq_reverse_toListModel (m : HashMap α β) :
    m.toList = m.val.buckets.toListModel.reverse := by
  simp only [toList, Imp.Buckets.toListModel, fold, Imp.fold, Array.foldl_eq_foldl_data,
    AssocList.foldl_eq, List.foldl_cons_fn]
  suffices ∀ (l₁ : List (AssocList α β)) (l₂ : List (α × β)),
      l₁.foldl (init := l₂.reverse) (fun d b => b.toList.reverse ++ d) =
      (l₁.foldl (init := l₂) fun acc bkt => acc ++ bkt.toList).reverse by
    apply this (l₂ := [])
  intro l₁
  induction l₁ with
  | nil => intro; rfl
  | cons a as ih =>
    intro l₂
    simp only [List.foldl, ← List.reverse_append, ih]

/-! `empty` -/

theorem isEmpty_empty : (HashMap.empty : HashMap α β).isEmpty :=
  sorry

/-! `findEntry?` -/

@[simp]
theorem findEntry?_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.findEntry? a = none :=
  sorry

@[simp]
theorem findEntry?_empty (a : α) : (HashMap.empty : HashMap α β).findEntry? a = none :=
  findEntry?_of_isEmpty _ a isEmpty_empty

theorem findEntry?_insert {a a'} (m : HashMap α β) (b) :
    a == a' → (m.insert a b).findEntry? a' = some (a, b) :=
  m.val.findEntry?_insert m.property

theorem findEntry?_insert_of_ne {a a'} (m : HashMap α β) (b) :
    a != a' → (m.insert a b).findEntry? a' = m.findEntry? a' :=
  m.val.findEntry?_insert_of_ne m.property

theorem findEntry?_erase {a a'} (m : HashMap α β) : a == a' → (m.erase a).findEntry? a' = none :=
  m.val.findEntry?_erase m.property

theorem ext_findEntry? (m₁ m₂ : HashMap α β) : (∀ a, m₁.findEntry? a = m₂.findEntry? a) → m₁ = m₂ :=
  sorry

/-! `find?` -/

theorem find?_eq (m : HashMap α β) (a : α) : m.find? a = (m.findEntry? a).map (·.2) :=
  AssocList.find?_eq_findEntry? _ _

theorem find?_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.find? a = none :=
  sorry

@[simp]
theorem find?_empty (a : α) : (HashMap.empty : HashMap α β).find? a = none :=
  find?_of_isEmpty _ a isEmpty_empty

theorem find?_insert {a a'} (m : HashMap α β) (b) : a == a' → (m.insert a b).find? a' = some b :=
  fun h => by simp [find?_eq, findEntry?_insert m b h]

theorem find?_insert_of_ne {a a'} (m : HashMap α β) (b) :
    a != a' → (m.insert a b).find? a' = m.find? a' :=
  fun h => by simp [find?_eq, findEntry?_insert_of_ne m b h]

theorem find?_erase {a a'} (m : HashMap α β) : a == a' → (m.erase a).find? a' = none :=
  fun h => by simp [find?_eq, findEntry?_erase m h]

/-! `insert` -/

theorem insert_comm [LawfulBEq α] (m : HashMap α β) (a₁ a₂ : α) (b : β) :
    (m.insert a₁ b).insert a₂ b = (m.insert a₂ b).insert a₁ b := by
  apply ext_findEntry?
  intro a
  cases Bool.beq_or_bne a₁ a <;> cases Bool.beq_or_bne a₂ a <;>
    simp_all [findEntry?_insert, findEntry?_insert_of_ne]

/-! `contains` -/

theorem contains_iff (m : HashMap α β) (a : α) :
    m.contains a ↔ ∃ b, m.find? a = some b :=
  sorry

theorem not_contains_iff (m : HashMap α β) (a : α) :
    m.contains a = false ↔ m.find? a = none := by
  have := contains_iff m a
  apply Iff.intro
  . intro h; cases h' : find? m a <;> simp_all
  . intro h; simp_all

theorem not_contains_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.contains a = false :=
  fun h => not_contains_iff _ _ |>.mpr (find?_of_isEmpty m a h)

@[simp]
theorem not_contains_empty (β) (a : α) : (empty : HashMap α β).contains a = false :=
  not_contains_of_isEmpty _ a isEmpty_empty

theorem contains_insert (m : HashMap α β) (a a' : α) (b : β) :
    (m.insert a b).contains a' ↔ (m.contains a' ∨ a == a') := by
  simp only [contains_iff]
  refine ⟨?mp, fun h => h.elim ?mpr₁ ?mpr₂⟩
  case mp =>
    intro ⟨b, hFind⟩
    cases Bool.beq_or_bne a a'
    case inl h =>
      exact Or.inr h
    case inr h =>
      rw [find?_insert_of_ne _ _ h] at hFind
      exact Or.inl ⟨b, hFind⟩
  case mpr₁ =>
    intro ⟨b, hFind⟩
    cases Bool.beq_or_bne a a'
    case inl h =>
      rw [find?_insert _ _ h]
      exact ⟨_, rfl⟩
    case inr h =>
      rw [find?_insert_of_ne _ _ h]
      exact ⟨_, hFind⟩
  case mpr₂ =>
    intro hEq
    rw [find?_insert _ _ hEq]
    exact ⟨_, rfl⟩

/-! `fold` -/

/-- If an entry appears in the map, it will appear "last" in a commutative `fold` over the map. -/
theorem fold_of_mapsTo_of_comm [LawfulBEq α] (m : HashMap α β) (f : δ → α → β → δ) (init : δ) :
    m.find? a = some b →
    -- NOTE: This could be strengthened by assuming m.find? a₁ = some b₁
    -- and ditto for a₂, b₂ in the ∀ hypothesis
    (∀ d a₁ b₁ a₂ b₂, f (f d a₁ b₁) a₂ b₂ = f (f d a₂ b₂) a₁ b₁) →
    -- TODO: Might also have to assume assoc
    ∃ d, m.fold f init = f d a b :=
  sorry

/-- Analogous to `List.foldlRecOn`. -/
def foldRecOn {C : δ → Sort _} (m : HashMap α β) (f : δ → α → β → δ) (init : δ) (hInit : C init)
    (hf : ∀ d a b, C d → m.find? a = some b → C (f d a b)) : C (m.fold f init) :=
  sorry

end HashMap


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.data.fin.basic

open nat
def unsigned_sz : nat := succ 4294967295

def unsigned := fin unsigned_sz

namespace unsigned
/- We cannot use tactic dec_trivial here because the tactic framework has not been defined yet. -/
private lemma zero_lt_unsigned_sz : 0 < unsigned_sz :=
zero_lt_succ _

/- Later, we define of_nat using mod, the following version is used to define the metaprogramming system. -/
protected def of_nat' (n : nat) : unsigned :=
if h : n < unsigned_sz then ⟨n, h⟩ else ⟨0, zero_lt_unsigned_sz⟩

def to_nat (c : unsigned) : nat := c.val

end unsigned

instance : decidable_eq unsigned :=
have decidable_eq (fin unsigned_sz), from fin.decidable_eq _,
this


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.natural_isomorphism
import category_theory.eq_to_hom

/-!
# Quotient category

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

Constructs the quotient of a category by an arbitrary family of relations on its hom-sets,
by introducing a type synonym for the objects, and identifying homs as necessary.

This is analogous to 'the quotient of a group by the normal closure of a subset', rather
than 'the quotient of a group by a normal subgroup'. When taking the quotient by a congruence
relation, `functor_map_eq_iff` says that no unnecessary identifications have been made.
-/

/-- A `hom_rel` on `C` consists of a relation on every hom-set. -/
@[derive inhabited]
def hom_rel (C) [quiver C] := Π ⦃X Y : C⦄, (X ⟶ Y) → (X ⟶ Y) → Prop

namespace category_theory

variables {C : Type*} [category C] (r : hom_rel C)

include r

/-- A `hom_rel` is a congruence when it's an equivalence on every hom-set, and it can be composed
from left and right. -/
class congruence : Prop :=
(is_equiv : ∀ {X Y}, is_equiv _ (@r X Y))
(comp_left : ∀ {X Y Z} (f : X ⟶ Y) {g g' : Y ⟶ Z}, r g g' → r (f ≫ g) (f ≫ g'))
(comp_right : ∀ {X Y Z} {f f' : X ⟶ Y} (g : Y ⟶ Z), r f f' → r (f ≫ g) (f' ≫ g))

attribute [instance] congruence.is_equiv

/-- A type synonym for `C`, thought of as the objects of the quotient category. -/
@[ext]
structure quotient := (as : C)

instance [inhabited C] : inhabited (quotient r) := ⟨ { as := default } ⟩

namespace quotient

/-- Generates the closure of a family of relations w.r.t. composition from left and right. -/
inductive comp_closure ⦃s t : C⦄ : (s ⟶ t) → (s ⟶ t) → Prop
| intro {a b} (f : s ⟶ a) (m₁ m₂ : a ⟶ b) (g : b ⟶ t) (h : r m₁ m₂) :
  comp_closure (f ≫ m₁ ≫ g) (f ≫ m₂ ≫ g)

lemma comp_closure.of {a b} (m₁ m₂ : a ⟶ b) (h : r m₁ m₂) : comp_closure r m₁ m₂ :=
by simpa using comp_closure.intro (𝟙 _) m₁ m₂ (𝟙 _) h

lemma comp_left {a b c : C} (f : a ⟶ b) : Π (g₁ g₂ : b ⟶ c) (h : comp_closure r g₁ g₂),
  comp_closure r (f ≫ g₁) (f ≫ g₂)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro (f ≫ x) m₁ m₂ y h

lemma comp_right {a b c : C} (g : b ⟶ c) : Π (f₁ f₂ : a ⟶ b) (h : comp_closure r f₁ f₂),
  comp_closure r (f₁ ≫ g) (f₂ ≫ g)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro x m₁ m₂ (y ≫ g) h

/-- Hom-sets of the quotient category. -/
def hom (s t : quotient r) := quot $ @comp_closure C _ r s.as t.as

instance (a : quotient r) : inhabited (hom r a a) := ⟨quot.mk _ (𝟙 a.as)⟩

/-- Composition in the quotient category. -/
def comp ⦃a b c : quotient r⦄ : hom r a b → hom r b c → hom r a c :=
λ hf hg, quot.lift_on hf ( λ f, quot.lift_on hg (λ g, quot.mk _ (f ≫ g))
  (λ g₁ g₂ h, quot.sound $ comp_left r f g₁ g₂ h) )
  (λ f₁ f₂ h, quot.induction_on hg $ λ g, quot.sound $ comp_right r g f₁ f₂ h)

@[simp]
lemma comp_mk {a b c : quotient r} (f : a.as ⟶ b.as) (g : b.as ⟶ c.as) :
  comp r (quot.mk _ f) (quot.mk _ g) = quot.mk _ (f ≫ g) := rfl

instance category : category (quotient r) :=
{ hom := hom r,
  id := λ a, quot.mk _ (𝟙 a.as),
  comp := comp r }

/-- The functor from a category to its quotient. -/
@[simps]
def functor : C ⥤ quotient r :=
{ obj := λ a, { as := a },
  map := λ _ _ f, quot.mk _ f }

noncomputable instance : full (functor r) :=
{ preimage := λ X Y f, quot.out f, }

instance : ess_surj (functor r) :=
{ mem_ess_image := λ Y, ⟨Y.as, ⟨eq_to_iso (by { ext, refl, })⟩⟩ }

protected lemma induction {P : Π {a b : quotient r}, (a ⟶ b) → Prop}
  (h : ∀ {x y : C} (f : x ⟶ y), P ((functor r).map f)) :
  ∀ {a b : quotient r} (f : a ⟶ b), P f :=
by { rintros ⟨x⟩ ⟨y⟩ ⟨f⟩, exact h f, }

protected lemma sound {a b : C} {f₁ f₂ : a ⟶ b} (h : r f₁ f₂) :
  (functor r).map f₁ = (functor r).map f₂ :=
by simpa using quot.sound (comp_closure.intro (𝟙 a) f₁ f₂ (𝟙 b) h)

variables {D : Type*} [category D]
  (F : C ⥤ D)
  (H : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂)
include H

/-- The induced functor on the quotient category. -/
@[simps]
def lift : quotient r ⥤ D :=
{ obj := λ a, F.obj a.as,
  map := λ a b hf, quot.lift_on hf (λ f, F.map f)
    (by { rintro _ _ ⟨_, _, _, _, h⟩, simp [H _ _ _ _ h], }),
  map_id' := λ a, F.map_id a.as,
  map_comp' := by { rintros a b c ⟨f⟩ ⟨g⟩, exact F.map_comp f g, } }

lemma lift_spec : (functor r) ⋙ lift r F H = F :=
begin
  apply functor.ext, rotate,
  { rintro X, refl, },
  { rintro X Y f, simp, },
end

lemma lift_unique (Φ : quotient r ⥤ D) (hΦ : (functor r) ⋙ Φ = F) : Φ = lift r F H :=
begin
  subst_vars,
  apply functor.hext,
  { rintro X, dsimp [lift, functor], congr, ext, refl, },
  { rintro X Y f,
    dsimp [lift, functor],
    apply quot.induction_on f,
    rintro ff,
    simp only [quot.lift_on_mk, functor.comp_map],
    congr; ext; refl, },
end

/-- The original functor factors through the induced functor. -/
def lift.is_lift : (functor r) ⋙ lift r F H ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma lift.is_lift_hom (X : C) : (lift.is_lift r F H).hom.app X = 𝟙 (F.obj X) :=
rfl
@[simp]
lemma lift.is_lift_inv (X : C) : (lift.is_lift r F H).inv.app X = 𝟙 (F.obj X) :=
rfl

lemma lift_map_functor_map {X Y : C} (f : X ⟶ Y) :
  (lift r F H).map ((functor r).map f) = F.map f :=
by { rw ←(nat_iso.naturality_1 (lift.is_lift r F H)), dsimp, simp, }

end quotient

end category_theory


import hott.init hott.types.sigma hott.types.nat
set_option pp.notation false
#print hott.univalence

namespace hott

local infix ` = `:50 := hott.eq

@[hott] lemma X : bool = bool := eq.refl _

@[hott] def Y (a b : unit) : ∀ (x y : a = b), x = y :=
punit.rec_on a (λ x, @eq.rec_on _ _ (λ b h, ∀ y, eq h y) _ _ $
  λ y, @eq.rec_on unit () (λ a, punit.rec_on a (eq (eq.refl ()))) () y (eq.refl _))

#print nat.no_confusion

@[hott] lemma eq.symm {α : Sort*} {x y : α} (h : x = y) : y = x := eq.rec_on h rfl

@[hott] example (a b : ℕ) : ∀ (x y : a = b), x = y :=
begin
  assume x,
  hinduction x,
  assume y,
  hinduction a,
  exact @eq.rec_on ℕ 0 begin end _ _ _ _,

end

@[hott] def bool_not : equiv bool bool :=
equiv.mk bnot $ is_equiv.mk _ bnot
  (λ b, bool.rec_on b rfl rfl) (λ b, bool.rec_on b rfl rfl)
    (λ b, bool.rec_on b rfl rfl)

axiom choice : Π {α : Sort*}, trunc 0 α → α

noncomputable example : empty :=
let b := choice (trunc.tr tt) in
let e : bool = bool := ua bool_not in
let b' : bool := eq.cast e b in
have hb' : b' = choice (trunc.tr ff), from sorry,
have h : b' = bnot b, from cast_ua bool_not b,
have h' : b' = b, from @eq.rec_on _
  (choice (trunc.tr ff)) (λ c _, b' = c) _
    (@eq.rec_on _ (choice (trunc.tr tt)) (λ c _, c = b) _
      (@eq.rec_on _ (trunc.tr ff) (λ c _, choice c = choice (trunc.tr ff)) _
        sorry
        rfl)
      rfl)
    hb',

end hott


import data.nat.basic
import smt2

lemma test : ∀ a b : ℕ, a < b → a + 1 < b + 1 :=
by { intros a b h, z3, } -- Probably only works with older Lean.


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module category_theory.grothendieck
! leanprover-community/mathlib commit 14b69e9f3c16630440a2cbd46f1ddad0d561dee7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Category.Cat
import Mathbin.CategoryTheory.Elements

/-!
# The Grothendieck construction

Given a functor `F : C ⥤ Cat`, the objects of `grothendieck F`
consist of dependent pairs `(b, f)`, where `b : C` and `f : F.obj c`,
and a morphism `(b, f) ⟶ (b', f')` is a pair `β : b ⟶ b'` in `C`, and
`φ : (F.map β).obj f ⟶ f'`

Categories such as `PresheafedSpace` are in fact examples of this construction,
and it may be interesting to try to generalize some of the development there.

## Implementation notes

Really we should treat `Cat` as a 2-category, and allow `F` to be a 2-functor.

There is also a closely related construction starting with `G : Cᵒᵖ ⥤ Cat`,
where morphisms consists again of `β : b ⟶ b'` and `φ : f ⟶ (F.map (op β)).obj f'`.

## References

See also `category_theory.functor.elements` for the category of elements of functor `F : C ⥤ Type`.

* https://stacks.math.columbia.edu/tag/02XV
* https://ncatlab.org/nlab/show/Grothendieck+construction

-/

universe u

namespace CategoryTheory

variable {C D : Type _} [Category C] [Category D]

variable (F : C ⥤ Cat)

/--
The Grothendieck construction (often written as `∫ F` in mathematics) for a functor `F : C ⥤ Cat`
gives a category whose
* objects `X` consist of `X.base : C` and `X.fiber : F.obj base`
* morphisms `f : X ⟶ Y` consist of
  `base : X.base ⟶ Y.base` and
  `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`
-/
@[nolint has_nonempty_instance]
structure Grothendieck where
  base : C
  fiber : F.obj base
#align category_theory.grothendieck CategoryTheory.Grothendieck

namespace Grothendieck

variable {F}

/-- A morphism in the Grothendieck category `F : C ⥤ Cat` consists of
`base : X.base ⟶ Y.base` and `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`.
-/
structure Hom (X Y : Grothendieck F) where
  base : X.base ⟶ Y.base
  fiber : (F.map base).obj X.fiber ⟶ Y.fiber
#align category_theory.grothendieck.hom CategoryTheory.Grothendieck.Hom

@[ext]
theorem ext {X Y : Grothendieck F} (f g : Hom X Y) (w_base : f.base = g.base)
    (w_fiber : eqToHom (by rw [w_base]) ≫ f.fiber = g.fiber) : f = g :=
  by
  cases f <;> cases g
  congr
  dsimp at w_base
  induction w_base
  rfl
  dsimp at w_base
  induction w_base
  simpa using w_fiber
#align category_theory.grothendieck.ext CategoryTheory.Grothendieck.ext

/-- The identity morphism in the Grothendieck category.
-/
@[simps]
def id (X : Grothendieck F) : Hom X X where
  base := 𝟙 X.base
  fiber := eqToHom (by erw [CategoryTheory.Functor.map_id, functor.id_obj X.fiber])
#align category_theory.grothendieck.id CategoryTheory.Grothendieck.id

instance (X : Grothendieck F) : Inhabited (Hom X X) :=
  ⟨id X⟩

/-- Composition of morphisms in the Grothendieck category.
-/
@[simps]
def comp {X Y Z : Grothendieck F} (f : Hom X Y) (g : Hom Y Z) : Hom X Z
    where
  base := f.base ≫ g.base
  fiber :=
    eqToHom (by erw [functor.map_comp, functor.comp_obj]) ≫ (F.map g.base).map f.fiber ≫ g.fiber
#align category_theory.grothendieck.comp CategoryTheory.Grothendieck.comp

attribute [local simp] eq_to_hom_map

instance : Category (Grothendieck F)
    where
  Hom X Y := Grothendieck.Hom X Y
  id X := Grothendieck.id X
  comp X Y Z f g := Grothendieck.comp f g
  comp_id' X Y f := by
    ext
    · dsimp
      -- We need to turn `F.map_id` (which is an equation between functors)
      -- into a natural isomorphism.
      rw [← nat_iso.naturality_2 (eq_to_iso (F.map_id Y.base)) f.fiber]
      simp
    · simp
  id_comp' X Y f := by ext <;> simp
  assoc' W X Y Z f g h := by
    ext; swap
    · simp
    · dsimp
      rw [← nat_iso.naturality_2 (eq_to_iso (F.map_comp _ _)) f.fiber]
      simp
      rfl

@[simp]
theorem id_fiber' (X : Grothendieck F) :
    Hom.fiber (𝟙 X) = eqToHom (by erw [CategoryTheory.Functor.map_id, functor.id_obj X.fiber]) :=
  id_fiber X
#align category_theory.grothendieck.id_fiber' CategoryTheory.Grothendieck.id_fiber'

theorem congr {X Y : Grothendieck F} {f g : X ⟶ Y} (h : f = g) :
    f.fiber = eqToHom (by subst h) ≫ g.fiber :=
  by
  subst h
  dsimp
  simp
#align category_theory.grothendieck.congr CategoryTheory.Grothendieck.congr

section

variable (F)

/-- The forgetful functor from `grothendieck F` to the source category. -/
@[simps]
def forget : Grothendieck F ⥤ C where
  obj X := X.1
  map X Y f := f.1
#align category_theory.grothendieck.forget CategoryTheory.Grothendieck.forget

end

universe w

variable (G : C ⥤ Type w)

/-- Auxiliary definition for `grothendieck_Type_to_Cat`, to speed up elaboration. -/
@[simps]
def grothendieckTypeToCatFunctor : Grothendieck (G ⋙ typeToCat) ⥤ G.Elements
    where
  obj X := ⟨X.1, X.2.as⟩
  map X Y f := ⟨f.1, f.2.1.1⟩
#align category_theory.grothendieck.grothendieck_Type_to_Cat_functor CategoryTheory.Grothendieck.grothendieckTypeToCatFunctor

/-- Auxiliary definition for `grothendieck_Type_to_Cat`, to speed up elaboration. -/
@[simps]
def grothendieckTypeToCatInverse : G.Elements ⥤ Grothendieck (G ⋙ typeToCat)
    where
  obj X := ⟨X.1, ⟨X.2⟩⟩
  map X Y f := ⟨f.1, ⟨⟨f.2⟩⟩⟩
#align category_theory.grothendieck.grothendieck_Type_to_Cat_inverse CategoryTheory.Grothendieck.grothendieckTypeToCatInverse

/-- The Grothendieck construction applied to a functor to `Type`
(thought of as a functor to `Cat` by realising a type as a discrete category)
is the same as the 'category of elements' construction.
-/
@[simps]
def grothendieckTypeToCat : Grothendieck (G ⋙ typeToCat) ≌ G.Elements
    where
  Functor := grothendieckTypeToCatFunctor G
  inverse := grothendieckTypeToCatInverse G
  unitIso :=
    NatIso.ofComponents
      (fun X => by
        rcases X with ⟨_, ⟨⟩⟩
        exact iso.refl _)
      (by
        rintro ⟨_, ⟨⟩⟩ ⟨_, ⟨⟩⟩ ⟨base, ⟨⟨f⟩⟩⟩
        dsimp at *
        subst f
        ext
        simp)
  counitIso :=
    NatIso.ofComponents
      (fun X => by
        cases X
        exact iso.refl _)
      (by
        rintro ⟨⟩ ⟨⟩ ⟨f, e⟩
        dsimp at *
        subst e
        ext
        simp)
  functor_unitIso_comp' := by
    rintro ⟨_, ⟨⟩⟩
    dsimp
    simp
    rfl
#align category_theory.grothendieck.grothendieck_Type_to_Cat CategoryTheory.Grothendieck.grothendieckTypeToCat

end Grothendieck

end CategoryTheory


/- Author: E.W.Ayers
   This should be in mathlib. Some simp and extensionality lemmas for comma and over. -/
import category_theory.comma

namespace category_theory

section

universes v₁ v₂ v₃ u₁ u₂ u₃ -- declare the `v`'s first; see `category_theory.category` for an explanation
variables {A : Type u₁} [𝒜 : category.{v₁} A]
variables {B : Type u₂} [ℬ : category.{v₂} B]
variables {T : Type u₃} [𝒯 : category.{v₃} T]
include 𝒜 ℬ 𝒯

variables {L : A ⥤ T} {R : B ⥤ T}

lemma comma.ext : Π {l₁ l₂ : comma L R} (pl : l₁.left = l₂.left) (pr : l₁.right = l₂.right) (pf : l₁.hom == l₂.hom), l₁ = l₂ :=
begin
  rintros ⟨_,_,_⟩ ⟨_,_,_⟩ pl pr pf, cases pl, cases pr, cases pf, refl,
end

end

section

open over

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

@[ext] lemma over.ext : Π {o₁ o₂ : over X} (px : o₁.left = o₂.left) (p : o₁.hom == o₂.hom), o₁ = o₂ :=
begin
  intros _ _ _ _,
  apply comma.ext,
  assumption,
  rw over.over_right, rw over.over_right,
  assumption
end

@[simp] lemma over.mk_hom_id {f : over X} : over.mk(f.hom) = f :=
begin ext, refl, refl, end

end
end category_theory


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro

! This file was ported from Lean 3 source module data.list.permutation
! leanprover-community/mathlib commit dd71334db81d0bd444af1ee339a29298bef40734
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Join

/-!
# Permutations of a list

In this file we prove properties about `List.Permutations`, a list of all permutations of a list. It
is defined in `Data.List.Defs`.

## Order of the permutations

Designed for performance, the order in which the permutations appear in `List.Permutations` is
rather intricate and not very amenable to induction. That's why we also provide `List.Permutations'`
as a less efficient but more straightforward way of listing permutations.

### `List.Permutations`

TODO. In the meantime, you can try decrypting the docstrings.

### `List.Permutations'`

The list of partitions is built by recursion. The permutations of `[]` are `[[]]`. Then, the
permutations of `a :: l` are obtained by taking all permutations of `l` in order and adding `a` in
all positions. Hence, to build `[0, 1, 2, 3].permutations'`, it does
* `[[]]`
* `[[3]]`
* `[[2, 3], [3, 2]]]`
* `[[1, 2, 3], [2, 1, 3], [2, 3, 1], [1, 3, 2], [3, 1, 2], [3, 2, 1]]`
* `[[0, 1, 2, 3], [1, 0, 2, 3], [1, 2, 0, 3], [1, 2, 3, 0],`
   `[0, 2, 1, 3], [2, 0, 1, 3], [2, 1, 0, 3], [2, 1, 3, 0],`
   `[0, 2, 3, 1], [2, 0, 3, 1], [2, 3, 0, 1], [2, 3, 1, 0],`
   `[0, 1, 3, 2], [1, 0, 3, 2], [1, 3, 0, 2], [1, 3, 2, 0],`
   `[0, 3, 1, 2], [3, 0, 1, 2], [3, 1, 0, 2], [3, 1, 2, 0],`
   `[0, 3, 2, 1], [3, 0, 2, 1], [3, 2, 0, 1], [3, 2, 1, 0]]`

## TODO

Show that `l.Nodup → l.permutations.Nodup`. See `Data.Fintype.List`.
-/

open Nat

variable {α β : Type _}

namespace List

theorem permutationsAux2_fst (t : α) (ts : List α) (r : List β) :
    ∀ (ys : List α) (f : List α → β), (permutationsAux2 t ts r ys f).1 = ys ++ ts
  | [], f => rfl
  | y :: ys, f => by simp [permutationsAux2, permutationsAux2_fst t _ _ ys]
#align list.permutations_aux2_fst List.permutationsAux2_fst

@[simp]
theorem permutationsAux2_snd_nil (t : α) (ts : List α) (r : List β) (f : List α → β) :
    (permutationsAux2 t ts r [] f).2 = r :=
  rfl
#align list.permutations_aux2_snd_nil List.permutationsAux2_snd_nil

@[simp]
theorem permutationsAux2_snd_cons (t : α) (ts : List α) (r : List β) (y : α) (ys : List α)
    (f : List α → β) :
    (permutationsAux2 t ts r (y :: ys) f).2 =
      f (t :: y :: ys ++ ts) :: (permutationsAux2 t ts r ys fun x : List α => f (y :: x)).2 :=
  by simp [permutationsAux2, permutationsAux2_fst t _ _ ys]
#align list.permutations_aux2_snd_cons List.permutationsAux2_snd_cons

/-- The `r` argument to `permutationsAux2` is the same as appending. -/
theorem permutationsAux2_append (t : α) (ts : List α) (r : List β) (ys : List α) (f : List α → β) :
    (permutationsAux2 t ts nil ys f).2 ++ r = (permutationsAux2 t ts r ys f).2 := by
  induction ys generalizing f <;> simp [*]
#align list.permutations_aux2_append List.permutationsAux2_append

/-- The `ts` argument to `permutationsAux2` can be folded into the `f` argument. -/
theorem permutationsAux2_comp_append {t : α} {ts ys : List α} {r : List β} (f : List α → β) :
    ((permutationsAux2 t [] r ys) fun x => f (x ++ ts)).2 = (permutationsAux2 t ts r ys f).2 := by
  induction' ys with ys_hd _ ys_ih generalizing f
  · simp
  · simp [ys_ih fun xs => f (ys_hd :: xs)]
#align list.permutations_aux2_comp_append List.permutationsAux2_comp_append

theorem map_permutationsAux2' {α β α' β'} (g : α → α') (g' : β → β') (t : α) (ts ys : List α)
    (r : List β) (f : List α → β) (f' : List α' → β') (H : ∀ a, g' (f a) = f' (map g a)) :
    map g' (permutationsAux2 t ts r ys f).2 =
      (permutationsAux2 (g t) (map g ts) (map g' r) (map g ys) f').2 := by
  induction' ys with ys_hd _ ys_ih generalizing f f'
  . simp
  . simp only [map, permutationsAux2_snd_cons, cons_append, cons.injEq]
    rw [ys_ih, permutationsAux2_fst]
    refine' ⟨_, rfl⟩
    . simp only [← map_cons, ← map_append]; apply H
    . intro a; apply H
#align list.map_permutations_aux2' List.map_permutationsAux2'

/-- The `f` argument to `permutationsAux2` when `r = []` can be eliminated. -/
theorem map_permutationsAux2 (t : α) (ts : List α) (ys : List α) (f : List α → β) :
    (permutationsAux2 t ts [] ys id).2.map f = (permutationsAux2 t ts [] ys f).2 := by
  rw [map_permutationsAux2' id, map_id, map_id]; rfl
  simp
#align list.map_permutations_aux2 List.map_permutationsAux2

/-- An expository lemma to show how all of `ts`, `r`, and `f` can be eliminated from
`permutationsAux2`.

`(permutationsAux2 t [] [] ys id).2`, which appears on the RHS, is a list whose elements are
produced by inserting `t` into every non-terminal position of `ys` in order. As an example:
```lean
#eval permutationsAux2 1 [] [] [2, 3, 4] id
-- [[1, 2, 3, 4], [2, 1, 3, 4], [2, 3, 1, 4]]
```
-/
theorem permutationsAux2_snd_eq (t : α) (ts : List α) (r : List β) (ys : List α) (f : List α → β) :
    (permutationsAux2 t ts r ys f).2 =
      ((permutationsAux2 t [] [] ys id).2.map fun x => f (x ++ ts)) ++ r :=
  by rw [← permutationsAux2_append, map_permutationsAux2, permutationsAux2_comp_append]
#align list.permutations_aux2_snd_eq List.permutationsAux2_snd_eq

theorem map_map_permutationsAux2 {α α'} (g : α → α') (t : α) (ts ys : List α) :
    map (map g) (permutationsAux2 t ts [] ys id).2 =
      (permutationsAux2 (g t) (map g ts) [] (map g ys) id).2 :=
  map_permutationsAux2' _ _ _ _ _ _ _ _ fun _ => rfl
#align list.map_map_permutations_aux2 List.map_map_permutationsAux2

theorem permutations'Aux_eq_permutationsAux2 (t : α) (ts : List α) :
    permutations'Aux t ts = (permutationsAux2 t [] [ts ++ [t]] ts id).2 := by
  induction' ts with a ts ih; · rfl
  simp [permutations'Aux, permutationsAux2_snd_cons, ih]
  simp (config := { singlePass := true }) only [← permutationsAux2_append]
  simp [map_permutationsAux2]
#align list.permutations'_aux_eq_permutations_aux2 List.permutations'Aux_eq_permutationsAux2

theorem mem_permutationsAux2 {t : α} {ts : List α} {ys : List α} {l l' : List α} :
    l' ∈ (permutationsAux2 t ts [] ys (l ++ .)).2 ↔
      ∃ l₁ l₂, l₂ ≠ [] ∧ ys = l₁ ++ l₂ ∧ l' = l ++ l₁ ++ t :: l₂ ++ ts := by
  induction' ys with y ys ih generalizing l
  · simp (config := { contextual := true })
  rw [permutationsAux2_snd_cons,
    show (fun x : List α => l ++ y :: x) = (l ++ [y] ++ .) by funext _; simp, mem_cons, ih]
  constructor
  · rintro (rfl | ⟨l₁, l₂, l0, rfl, rfl⟩)
    · exact ⟨[], y :: ys, by simp⟩
    · exact ⟨y :: l₁, l₂, l0, by simp⟩
  · rintro ⟨_ | ⟨y', l₁⟩, l₂, l0, ye, rfl⟩
    · simp [ye]
    · simp only [cons_append] at ye
      rcases ye with ⟨rfl, rfl⟩
      exact Or.inr ⟨l₁, l₂, l0, by simp⟩
#align list.mem_permutations_aux2 List.mem_permutationsAux2

theorem mem_permutationsAux2' {t : α} {ts : List α} {ys : List α} {l : List α} :
    l ∈ (permutationsAux2 t ts [] ys id).2 ↔
      ∃ l₁ l₂, l₂ ≠ [] ∧ ys = l₁ ++ l₂ ∧ l = l₁ ++ t :: l₂ ++ ts :=
  by rw [show @id (List α) = ([] ++ .) by funext _; rfl]; apply mem_permutationsAux2
#align list.mem_permutations_aux2' List.mem_permutationsAux2'

theorem length_permutationsAux2 (t : α) (ts : List α) (ys : List α) (f : List α → β) :
    length (permutationsAux2 t ts [] ys f).2 = length ys := by
  induction ys generalizing f <;> simp [*]
#align list.length_permutations_aux2 List.length_permutationsAux2

theorem foldr_permutationsAux2 (t : α) (ts : List α) (r L : List (List α)) :
    foldr (fun y r => (permutationsAux2 t ts r y id).2) r L =
      (L.bind fun y => (permutationsAux2 t ts [] y id).2) ++ r := by
  induction' L with l L ih
  · rfl
  · simp [ih]
    rw [← permutationsAux2_append]
#align list.foldr_permutations_aux2 List.foldr_permutationsAux2

theorem mem_foldr_permutationsAux2 {t : α} {ts : List α} {r L : List (List α)} {l' : List α} :
    l' ∈ foldr (fun y r => (permutationsAux2 t ts r y id).2) r L ↔
      l' ∈ r ∨ ∃ l₁ l₂, l₁ ++ l₂ ∈ L ∧ l₂ ≠ [] ∧ l' = l₁ ++ t :: l₂ ++ ts := by
  have :
    (∃ a : List α,
        a ∈ L ∧ ∃ l₁ l₂ : List α, ¬l₂ = nil ∧ a = l₁ ++ l₂ ∧ l' = l₁ ++ t :: (l₂ ++ ts)) ↔
      ∃ l₁ l₂ : List α, ¬l₂ = nil ∧ l₁ ++ l₂ ∈ L ∧ l' = l₁ ++ t :: (l₂ ++ ts) :=
    ⟨fun ⟨_, aL, l₁, l₂, l0, e, h⟩ => ⟨l₁, l₂, l0, e ▸ aL, h⟩, fun ⟨l₁, l₂, l0, aL, h⟩ =>
      ⟨_, aL, l₁, l₂, l0, rfl, h⟩⟩
  rw [foldr_permutationsAux2]
  simp only [mem_permutationsAux2', ← this, or_comm, and_left_comm, mem_append, mem_bind,
    append_assoc, cons_append, exists_prop]
#align list.mem_foldr_permutations_aux2 List.mem_foldr_permutationsAux2

theorem length_foldr_permutationsAux2 (t : α) (ts : List α) (r L : List (List α)) :
    length (foldr (fun y r => (permutationsAux2 t ts r y id).2) r L) =
      sum (map length L) + length r :=
  by simp [foldr_permutationsAux2, (· ∘ ·), length_permutationsAux2]
#align list.length_foldr_permutations_aux2 List.length_foldr_permutationsAux2

theorem length_foldr_permutationsAux2' (t : α) (ts : List α) (r L : List (List α)) (n)
    (H : ∀ l ∈ L, length l = n) :
    length (foldr (fun y r => (permutationsAux2 t ts r y id).2) r L) = n * length L + length r := by
  rw [length_foldr_permutationsAux2, (_ : List.sum (map length L) = n * length L)]
  induction' L with l L ih
  · simp
  have sum_map : sum (map length L) = n * length L := ih fun l m => H l (mem_cons_of_mem _ m)
  have length_l : length l = n := H _ (mem_cons_self _ _)
  simp [sum_map, length_l, mul_add, add_comm, mul_succ]
#align list.length_foldr_permutations_aux2' List.length_foldr_permutationsAux2'

@[simp]
theorem permutationsAux_nil (is : List α) : permutationsAux [] is = [] := by
  rw [permutationsAux, permutationsAux.rec]
#align list.permutations_aux_nil List.permutationsAux_nil

@[simp]
theorem permutationsAux_cons (t : α) (ts is : List α) :
    permutationsAux (t :: ts) is =
      foldr (fun y r => (permutationsAux2 t ts r y id).2) (permutationsAux ts (t :: is))
        (permutations is) :=
  by rw [permutationsAux, permutationsAux.rec]; rfl
#align list.permutations_aux_cons List.permutationsAux_cons

@[simp]
theorem permutations_nil : permutations ([] : List α) = [[]] := by
  rw [permutations, permutationsAux_nil]
#align list.permutations_nil List.permutations_nil

theorem map_permutationsAux (f : α → β) :
    ∀ ts is :
    List α, map (map f) (permutationsAux ts is) = permutationsAux (map f ts) (map f is) := by
  refine' permutationsAux.rec (by simp) _
  introv IH1 IH2; rw [map] at IH2
  simp only [foldr_permutationsAux2, map_append, map, map_map_permutationsAux2, permutations,
    bind_map, IH1, append_assoc, permutationsAux_cons, cons_bind, ← IH2, map_bind]
#align list.map_permutations_aux List.map_permutationsAux

theorem map_permutations (f : α → β) (ts : List α) :
    map (map f) (permutations ts) = permutations (map f ts) := by
  rw [permutations, permutations, map, map_permutationsAux, map]
#align list.map_permutations List.map_permutations

theorem map_permutations' (f : α → β) (ts : List α) :
    map (map f) (permutations' ts) = permutations' (map f ts) := by
  induction' ts with t ts ih <;> [rfl, simp [← ih, map_bind, ← map_map_permutations'Aux, bind_map]]
#align list.map_permutations' List.map_permutations'

theorem permutationsAux_append (is is' ts : List α) :
    permutationsAux (is ++ ts) is' =
      (permutationsAux is is').map (· ++ ts) ++ permutationsAux ts (is.reverse ++ is') := by
  induction' is with t is ih generalizing is'; · simp
  simp only [foldr_permutationsAux2, ih, bind_map, cons_append, permutationsAux_cons, map_append,
    reverse_cons, append_assoc, singleton_append]
  congr 2
  funext _
  rw [map_permutationsAux2]
  simp (config := { singlePass := true }) only [← permutationsAux2_comp_append]
  simp only [id, append_assoc]
#align list.permutations_aux_append List.permutationsAux_append

theorem permutations_append (is ts : List α) :
    permutations (is ++ ts) = (permutations is).map (· ++ ts) ++ permutationsAux ts is.reverse := by
  simp [permutations, permutationsAux_append]
#align list.permutations_append List.permutations_append

end List


import QL.FOL.fol provability consistency

universes u v

namespace fol
open_locale logic_symbol
variables (L : language.{u}) {μ : Type v} {m m₁ m₂ n : ℕ}

namespace subterm
variables {L μ n}

section encode
variables (L n)

def label := ℕ ⊕ fin n ⊕ Σ n, L.fn n

def label_type : label L n → Type
| (sum.inl n)                := empty
| (sum.inr $ sum.inl n)      := empty
| (sum.inr $ sum.inr ⟨k, f⟩) := fin k

variables {L n}

@[reducible] def W_to_subterm : W_type (label_type L n) → subterm L ℕ n
| ⟨sum.inl x, _⟩                := &x
| ⟨sum.inr $ sum.inl x, _⟩      := #x
| ⟨sum.inr $ sum.inr ⟨k, f⟩, F⟩ := function f (λ x, W_to_subterm (F x))

def subterm_to_W : subterm L ℕ n → W_type (label_type L n)
| &x             := ⟨sum.inl x, empty.rec _⟩
| #x             := ⟨sum.inr $ sum.inl x, empty.rec _⟩
| (function f v) := ⟨sum.inr $ sum.inr ⟨_, f⟩, λ i, subterm_to_W (v i)⟩

def formula_equiv_W : subterm L ℕ n ≃ W_type (label_type L n) :=
{ to_fun := subterm_to_W,
  inv_fun := W_to_subterm,
  left_inv := by intros p; induction p; simp[subterm_to_W, W_to_subterm, *],
  right_inv := by { intros w, induction w with a f IH, rcases a with (_ | _ | ⟨k, f⟩),
    { simp[subterm_to_W, W_to_subterm, *], exact funext (by rintros ⟨⟩) },
    { rcases a, simp[subterm_to_W, W_to_subterm], exact funext (by rintros ⟨⟩) },
    { simp[subterm_to_W, W_to_subterm, IH] } } }

instance : Π i, fintype (label_type L n i)
| (sum.inl a)                := show fintype empty, from fintype.of_is_empty
| (sum.inr $ sum.inl x)      := show fintype empty, from fintype.of_is_empty
| (sum.inr $ sum.inr ⟨k, f⟩) := fin.fintype k

instance : Π i, encodable (label_type L n i)
| (sum.inl a)                := show encodable empty, from is_empty.to_encodable
| (sum.inr $ sum.inl x)      := show encodable empty, from is_empty.to_encodable
| (sum.inr $ sum.inr ⟨k, f⟩) := fin.encodable k

instance [∀ k, encodable (L.fn k)] : encodable (label L n) := sum.encodable

@[irreducible]
instance [∀ k, encodable (L.fn k)] : encodable (subterm L ℕ n) := encodable.of_equiv (W_type (label_type L n)) formula_equiv_W

--variables [encodable μ]

@[simp] def arity : subterm L ℕ n → ℕ
| &x             := x + 1
| #x             := 0
| (function f v) := ⨆ᶠ i, (v i).arity

@[simp] def to_bterm {m} : Π t : subterm L ℕ n, t.arity ≤ m → bounded_subterm L m n
| &x             h := &⟨x, h⟩
| #x             h := #x
| (function f v) h := function f (λ i, (v i).to_bterm (by simp at h; refine h i))

def uniform : bounded_subterm L m n → subterm L ℕ n := map coe

def to_nat [∀ k, encodable (L.fn k)] : bounded_subterm L m n → ℕ := λ t, encodable.encode t.uniform

@[simp] lemma map_val_mlift (t : bounded_subterm L m n) : t.mlift.uniform = t.uniform :=
by simp[uniform, mlift, (∘)]

@[simp] lemma uniform_cast_le (h : m₁ ≤ m₂) (t : bounded_subterm L m₁ n) : (cast_le h t).uniform = t.uniform :=
by simp[cast_le, uniform, (∘)]

@[simp] lemma uniform_to_bform (t : bounded_subterm L m n) (h) : t.uniform.to_bterm h = t :=
by induction t; simp[uniform, *]; case function : k f v IH { funext i, simp[uniform] at h, exact IH i (h i) }

@[simp] lemma to_subterm_uniform (t : subterm L ℕ n) (h : t.arity ≤ m) : (t.to_bterm h).uniform = t :=
by induction t; simp[uniform, *]; case function : k f v IH { funext i, simp[uniform] at h, exact IH i (h i) }

@[simp] lemma subterm_arity (t : bounded_subterm L m n) : t.uniform.arity ≤ m :=
by { induction t; simp[*, uniform], case metavar : i { exact nat.succ_le_iff.mpr i.property },
     case function : k f v IH { simpa using IH } }

@[simp] lemma uniform_push (t : bounded_subterm L m (n + 1)) :
  (push t).uniform = subst &m t.uniform :=
by { induction t; simp[*, uniform],
     case var : x { refine fin.last_cases _ _ x; simp },
     case function : k f v IH { funext i, exact IH i } }

variables (L m n) [∀ k, encodable (L.fn k)]

def of_nat : ℕ → option (bounded_subterm L m n) := λ i,
  (encodable.decode (subterm L ℕ n) i).bind (λ t, if h : t.arity ≤ m then some (t.to_bterm h) else none)

variables {L m m₁ m₂ n}

@[simp] lemma to_nat_of_nat (t : bounded_subterm L m n) : of_nat L m n t.to_nat = some t :=
by simp[to_nat, of_nat]

@[simp] lemma of_nat_mlift (t : bounded_subterm L m n) : to_nat t.mlift = to_nat t :=
by simp[to_nat]

@[simp] lemma of_nat_cast_le (h : m₁ ≤ m₂) (t : bounded_subterm L m₁ n) : to_nat (cast_le h t) = to_nat t :=
by simp[to_nat]

@[simp] lemma to_nat_to_subterm (t : subterm L ℕ n) {m} (h : t.arity ≤ m) :
  (t.to_bterm h).to_nat = encodable.encode t :=
by simp[subterm.to_nat]

end encode

end subterm

end fol


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.images
import Mathlib.category_theory.filtered
import Mathlib.tactic.equiv_rw
import Mathlib.PostPort

universes u

namespace Mathlib

namespace category_theory.limits.types

/--
(internal implementation) the limit cone of a functor,
implemented as flat sections of a pi type
-/
def limit_cone {J : Type u} [small_category J] (F : J ⥤ Type u) : cone F :=
  cone.mk (↥(functor.sections F))
    (nat_trans.mk
      fun (j : J) (u : functor.obj (functor.obj (functor.const J) ↥(functor.sections F)) j) =>
        subtype.val u j)

/-- (internal implementation) the fact that the proposed limit cone is the limit -/
def limit_cone_is_limit {J : Type u} [small_category J] (F : J ⥤ Type u) :
    is_limit (limit_cone F) :=
  is_limit.mk
    fun (s : cone F) (v : cone.X s) =>
      { val := fun (j : J) => nat_trans.app (cone.π s) j v, property := sorry }

/--
The category of types has all limits.

See https://stacks.math.columbia.edu/tag/002U.
-/
protected instance sort.category_theory.limits.has_limits : has_limits (Type u) :=
  has_limits.mk
    fun (J : Type u) (𝒥 : small_category J) =>
      has_limits_of_shape.mk
        fun (F : J ⥤ Type u) => has_limit.mk (limit_cone.mk (limit_cone F) (limit_cone_is_limit F))

/--
The equivalence between a limiting cone of `F` in `Type u` and the "concrete" definition as the
sections of `F`.
-/
def is_limit_equiv_sections {J : Type u} [small_category J] {F : J ⥤ Type u} {c : cone F}
    (t : is_limit c) : cone.X c ≃ ↥(functor.sections F) :=
  iso.to_equiv (is_limit.cone_point_unique_up_to_iso t (limit_cone_is_limit F))

@[simp] theorem is_limit_equiv_sections_apply {J : Type u} [small_category J] {F : J ⥤ Type u}
    {c : cone F} (t : is_limit c) (j : J) (x : cone.X c) :
    coe (coe_fn (is_limit_equiv_sections t) x) j = nat_trans.app (cone.π c) j x :=
  rfl

@[simp] theorem is_limit_equiv_sections_symm_apply {J : Type u} [small_category J] {F : J ⥤ Type u}
    {c : cone F} (t : is_limit c) (x : ↥(functor.sections F)) (j : J) :
    nat_trans.app (cone.π c) j (coe_fn (equiv.symm (is_limit_equiv_sections t)) x) = coe x j :=
  sorry

/--
The equivalence between the abstract limit of `F` in `Type u`
and the "concrete" definition as the sections of `F`.
-/
def limit_equiv_sections {J : Type u} [small_category J] (F : J ⥤ Type u) :
    limit F ≃ ↥(functor.sections F) :=
  is_limit_equiv_sections (limit.is_limit F)

@[simp] theorem limit_equiv_sections_apply {J : Type u} [small_category J] (F : J ⥤ Type u)
    (x : limit F) (j : J) : coe (coe_fn (limit_equiv_sections F) x) j = limit.π F j x :=
  rfl

@[simp] theorem limit_equiv_sections_symm_apply {J : Type u} [small_category J] (F : J ⥤ Type u)
    (x : ↥(functor.sections F)) (j : J) :
    limit.π F j (coe_fn (equiv.symm (limit_equiv_sections F)) x) = coe x j :=
  is_limit_equiv_sections_symm_apply (limit.is_limit F) x j

/--
Construct a term of `limit F : Type u` from a family of terms `x : Π j, F.obj j`
which are "coherent": `∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j'`.
-/
def limit.mk {J : Type u} [small_category J] (F : J ⥤ Type u) (x : (j : J) → functor.obj F j)
    (h : ∀ (j j' : J) (f : j ⟶ j'), functor.map F f (x j) = x j') : limit F :=
  coe_fn (equiv.symm (limit_equiv_sections F)) { val := x, property := h }

@[simp] theorem limit.π_mk {J : Type u} [small_category J] (F : J ⥤ Type u)
    (x : (j : J) → functor.obj F j) (h : ∀ (j j' : J) (f : j ⟶ j'), functor.map F f (x j) = x j')
    (j : J) : limit.π F j (limit.mk F x h) = x j :=
  sorry

-- PROJECT: prove this for concrete categories where the forgetful functor preserves limits

theorem limit_ext {J : Type u} [small_category J] (F : J ⥤ Type u) (x : limit F) (y : limit F)
    (w : ∀ (j : J), limit.π F j x = limit.π F j y) : x = y :=
  sorry

theorem limit_ext_iff {J : Type u} [small_category J] (F : J ⥤ Type u) (x : limit F) (y : limit F) :
    x = y ↔ ∀ (j : J), limit.π F j x = limit.π F j y :=
  { mp := fun (t : x = y) (_x : J) => t ▸ rfl, mpr := limit_ext F x y }

-- TODO: are there other limits lemmas that should have `_apply` versions?

-- Can we generate these like with `@[reassoc]`?

-- PROJECT: prove these for any concrete category where the forgetful functor preserves limits?

@[simp] theorem limit.w_apply {J : Type u} [small_category J] {F : J ⥤ Type u} {j : J} {j' : J}
    {x : limit F} (f : j ⟶ j') : functor.map F f (limit.π F j x) = limit.π F j' x :=
  congr_fun (limit.w F f) x

@[simp] theorem limit.lift_π_apply {J : Type u} [small_category J] (F : J ⥤ Type u) (s : cone F)
    (j : J) (x : cone.X s) : limit.π F j (limit.lift F s x) = nat_trans.app (cone.π s) j x :=
  congr_fun (limit.lift_π s j) x

@[simp] theorem limit.map_π_apply {J : Type u} [small_category J] {F : J ⥤ Type u} {G : J ⥤ Type u}
    (α : F ⟶ G) (j : J) (x : limit F) :
    limit.π G j (lim_map α x) = nat_trans.app α j (limit.π F j x) :=
  congr_fun (lim_map_π α j) x

/--
The relation defining the quotient type which implements the colimit of a functor `F : J ⥤ Type u`.
See `category_theory.limits.types.quot`.
-/
def quot.rel {J : Type u} [small_category J] (F : J ⥤ Type u) :
    (sigma fun (j : J) => functor.obj F j) → (sigma fun (j : J) => functor.obj F j) → Prop :=
  fun (p p' : sigma fun (j : J) => functor.obj F j) =>
    ∃ (f : sigma.fst p ⟶ sigma.fst p'), sigma.snd p' = functor.map F f (sigma.snd p)

/--
A quotient type implementing the colimit of a functor `F : J ⥤ Type u`,
as pairs `⟨j, x⟩` where `x : F.obj j`, modulo the equivalence relation generated by
`⟨j, x⟩ ~ ⟨j', x'⟩` whenever there is a morphism `f : j ⟶ j'` so `F.map f x = x'`.
-/
def quot {J : Type u} [small_category J] (F : J ⥤ Type u) := Quot sorry

/--
(internal implementation) the colimit cocone of a functor,
implemented as a quotient of a sigma type
-/
def colimit_cocone {J : Type u} [small_category J] (F : J ⥤ Type u) : cocone F :=
  cocone.mk (quot F)
    (nat_trans.mk fun (j : J) (x : functor.obj F j) => Quot.mk (quot.rel F) (sigma.mk j x))

/-- (internal implementation) the fact that the proposed colimit cocone is the colimit -/
def colimit_cocone_is_colimit {J : Type u} [small_category J] (F : J ⥤ Type u) :
    is_colimit (colimit_cocone F) :=
  is_colimit.mk
    fun (s : cocone F) =>
      Quot.lift
        (fun (p : sigma fun (j : J) => functor.obj F j) =>
          nat_trans.app (cocone.ι s) (sigma.fst p) (sigma.snd p))
        sorry

/--
The category of types has all colimits.

See https://stacks.math.columbia.edu/tag/002U.
-/
protected instance sort.category_theory.limits.has_colimits : has_colimits (Type u) :=
  has_colimits.mk
    fun (J : Type u) (𝒥 : small_category J) =>
      has_colimits_of_shape.mk
        fun (F : J ⥤ Type u) =>
          has_colimit.mk (colimit_cocone.mk (colimit_cocone F) (colimit_cocone_is_colimit F))

/--
The equivalence between the abstract colimit of `F` in `Type u`
and the "concrete" definition as a quotient.
-/
def colimit_equiv_quot {J : Type u} [small_category J] (F : J ⥤ Type u) : colimit F ≃ quot F :=
  iso.to_equiv
    (is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit F) (colimit_cocone_is_colimit F))

@[simp] theorem colimit_equiv_quot_symm_apply {J : Type u} [small_category J] (F : J ⥤ Type u)
    (j : J) (x : functor.obj F j) :
    coe_fn (equiv.symm (colimit_equiv_quot F)) (Quot.mk (quot.rel F) (sigma.mk j x)) =
        colimit.ι F j x :=
  rfl

@[simp] theorem colimit_equiv_quot_apply {J : Type u} [small_category J] (F : J ⥤ Type u) (j : J)
    (x : functor.obj F j) :
    coe_fn (colimit_equiv_quot F) (colimit.ι F j x) = Quot.mk (quot.rel F) (sigma.mk j x) :=
  sorry

@[simp] theorem colimit.w_apply {J : Type u} [small_category J] {F : J ⥤ Type u} {j : J} {j' : J}
    {x : functor.obj F j} (f : j ⟶ j') : colimit.ι F j' (functor.map F f x) = colimit.ι F j x :=
  congr_fun (colimit.w F f) x

@[simp] theorem colimit.ι_desc_apply {J : Type u} [small_category J] (F : J ⥤ Type u) (s : cocone F)
    (j : J) (x : functor.obj F j) :
    colimit.desc F s (colimit.ι F j x) = nat_trans.app (cocone.ι s) j x :=
  congr_fun (colimit.ι_desc s j) x

@[simp] theorem colimit.ι_map_apply {J : Type u} [small_category J] {F : J ⥤ Type u}
    {G : J ⥤ Type u} (α : F ⟶ G) (j : J) (x : functor.obj F j) :
    functor.map colim α (colimit.ι F j x) = colimit.ι G j (nat_trans.app α j x) :=
  congr_fun (colimit.ι_map α j) x

theorem colimit_sound {J : Type u} [small_category J] {F : J ⥤ Type u} {j : J} {j' : J}
    {x : functor.obj F j} {x' : functor.obj F j'} (f : j ⟶ j') (w : functor.map F f x = x') :
    colimit.ι F j x = colimit.ι F j' x' :=
  sorry

theorem colimit_sound' {J : Type u} [small_category J] {F : J ⥤ Type u} {j : J} {j' : J}
    {x : functor.obj F j} {x' : functor.obj F j'} {j'' : J} (f : j ⟶ j'') (f' : j' ⟶ j'')
    (w : functor.map F f x = functor.map F f' x') : colimit.ι F j x = colimit.ι F j' x' :=
  sorry

theorem colimit_eq {J : Type u} [small_category J] {F : J ⥤ Type u} {j : J} {j' : J}
    {x : functor.obj F j} {x' : functor.obj F j'} (w : colimit.ι F j x = colimit.ι F j' x') :
    eqv_gen (quot.rel F) (sigma.mk j x) (sigma.mk j' x') :=
  sorry

theorem jointly_surjective {J : Type u} [small_category J] (F : J ⥤ Type u) {t : cocone F}
    (h : is_colimit t) (x : cocone.X t) :
    ∃ (j : J), ∃ (y : functor.obj F j), nat_trans.app (cocone.ι t) j y = x :=
  sorry

/-- A variant of `jointly_surjective` for `x : colimit F`. -/
theorem jointly_surjective' {J : Type u} [small_category J] {F : J ⥤ Type u} (x : colimit F) :
    ∃ (j : J), ∃ (y : functor.obj F j), colimit.ι F j y = x :=
  jointly_surjective F (colimit.is_colimit F) x

namespace filtered_colimit

/- For filtered colimits of types, we can give an explicit description
  of the equivalence relation generated by the relation used to form
  the colimit.  -/

/--
An alternative relation on `Σ j, F.obj j`,
which generates the same equivalence relation as we use to define the colimit in `Type` above,
but that is more convenient when working with filtered colimits.

Elements in `F.obj j` and `F.obj j'` are equivalent if there is some `k : J` to the right
where their images are equal.
-/
protected def r {J : Type u} [small_category J] (F : J ⥤ Type u)
    (x : sigma fun (j : J) => functor.obj F j) (y : sigma fun (j : J) => functor.obj F j) :=
  ∃ (k : J),
    ∃ (f : sigma.fst x ⟶ k),
      ∃ (g : sigma.fst y ⟶ k), functor.map F f (sigma.snd x) = functor.map F g (sigma.snd y)

protected theorem r_ge {J : Type u} [small_category J] (F : J ⥤ Type u)
    (x : sigma fun (j : J) => functor.obj F j) (y : sigma fun (j : J) => functor.obj F j) :
    (∃ (f : sigma.fst x ⟶ sigma.fst y), sigma.snd y = functor.map F f (sigma.snd x)) →
        filtered_colimit.r F x y :=
  sorry

/-- Recognizing filtered colimits of types. -/
def is_colimit_of {J : Type u} [small_category J] (F : J ⥤ Type u) (t : cocone F)
    (hsurj :
      ∀ (x : cocone.X t), ∃ (i : J), ∃ (xi : functor.obj F i), x = nat_trans.app (cocone.ι t) i xi)
    (hinj :
      ∀ (i j : J) (xi : functor.obj F i) (xj : functor.obj F j),
        nat_trans.app (cocone.ι t) i xi = nat_trans.app (cocone.ι t) j xj →
          ∃ (k : J), ∃ (f : i ⟶ k), ∃ (g : j ⟶ k), functor.map F f xi = functor.map F g xj) :
    is_colimit t :=
  is_colimit.of_iso_colimit (colimit.is_colimit F)
    (cocones.ext (equiv.to_iso (equiv.of_bijective (colimit.desc F t) sorry)) sorry)

-- Strategy: Prove that the map from "the" colimit of F (defined above) to t.X

-- is a bijection.

protected theorem r_equiv {J : Type u} [small_category J] (F : J ⥤ Type u)
    [is_filtered_or_empty J] : equivalence (filtered_colimit.r F) :=
  sorry

protected theorem r_eq {J : Type u} [small_category J] (F : J ⥤ Type u) [is_filtered_or_empty J] :
    filtered_colimit.r F =
        eqv_gen
          fun (x y : sigma fun (j : J) => functor.obj F j) =>
            ∃ (f : sigma.fst x ⟶ sigma.fst y), sigma.snd y = functor.map F f (sigma.snd x) :=
  sorry

theorem colimit_eq_iff_aux {J : Type u} [small_category J] (F : J ⥤ Type u) [is_filtered_or_empty J]
    {i : J} {j : J} {xi : functor.obj F i} {xj : functor.obj F j} :
    nat_trans.app (cocone.ι (colimit_cocone F)) i xi =
          nat_trans.app (cocone.ι (colimit_cocone F)) j xj ↔
        ∃ (k : J), ∃ (f : i ⟶ k), ∃ (g : j ⟶ k), functor.map F f xi = functor.map F g xj :=
  sorry

theorem is_colimit_eq_iff {J : Type u} [small_category J] (F : J ⥤ Type u) {t : cocone F}
    [is_filtered_or_empty J] (ht : is_colimit t) {i : J} {j : J} {xi : functor.obj F i}
    {xj : functor.obj F j} :
    nat_trans.app (cocone.ι t) i xi = nat_trans.app (cocone.ι t) j xj ↔
        ∃ (k : J), ∃ (f : i ⟶ k), ∃ (g : j ⟶ k), functor.map F f xi = functor.map F g xj :=
  sorry

theorem colimit_eq_iff {J : Type u} [small_category J] (F : J ⥤ Type u) [is_filtered_or_empty J]
    {i : J} {j : J} {xi : functor.obj F i} {xj : functor.obj F j} :
    colimit.ι F i xi = colimit.ι F j xj ↔
        ∃ (k : J), ∃ (f : i ⟶ k), ∃ (g : j ⟶ k), functor.map F f xi = functor.map F g xj :=
  is_colimit_eq_iff F (colimit.is_colimit F)

end filtered_colimit

/-- the image of a morphism in Type is just `set.range f` -/
def image {α : Type u} {β : Type u} (f : α ⟶ β) := ↥(set.range f)

protected instance image.inhabited {α : Type u} {β : Type u} (f : α ⟶ β) [Inhabited α] :
    Inhabited (image f) :=
  { default := { val := f Inhabited.default, property := sorry } }

/-- the inclusion of `image f` into the target -/
def image.ι {α : Type u} {β : Type u} (f : α ⟶ β) : image f ⟶ β := subtype.val

protected instance image.ι.category_theory.mono {α : Type u} {β : Type u} (f : α ⟶ β) :
    mono (image.ι f) :=
  iff.mpr (mono_iff_injective (image.ι f)) subtype.val_injective

/-- the universal property for the image factorisation -/
def image.lift {α : Type u} {β : Type u} {f : α ⟶ β} (F' : mono_factorisation f) :
    image f ⟶ mono_factorisation.I F' :=
  fun (x : image f) =>
    mono_factorisation.e F'
      (subtype.val
        (classical.indefinite_description (fun (x_1 : α) => f x_1 = subtype.val x) sorry))

theorem image.lift_fac {α : Type u} {β : Type u} {f : α ⟶ β} (F' : mono_factorisation f) :
    image.lift F' ≫ mono_factorisation.m F' = image.ι f :=
  sorry

/-- the factorisation of any morphism in Type through a mono. -/
def mono_factorisation {α : Type u} {β : Type u} (f : α ⟶ β) : mono_factorisation f :=
  mono_factorisation.mk (image f) (image.ι f) (set.range_factorization f)

/-- the facorisation through a mono has the universal property of the image. -/
def is_image {α : Type u} {β : Type u} (f : α ⟶ β) : is_image (mono_factorisation f) :=
  is_image.mk image.lift

protected instance category_theory.limits.has_image {α : Type u} {β : Type u} (f : α ⟶ β) :
    has_image f :=
  has_image.mk (image_factorisation.mk (mono_factorisation f) (is_image f))

protected instance sort.category_theory.limits.has_images : has_images (Type u) :=
  has_images.mk sorry

protected instance sort.category_theory.limits.has_image_maps : has_image_maps (Type u) :=
  has_image_maps.mk sorry

end Mathlib


import ring_theory.localization

universes u v

namespace localization

variables (α : Type u) [comm_ring α] (S : set α) [is_submonoid S]

theorem mul_denom (r s : α) (hs : s ∈ S) : @@has_mul.mul (localization.has_mul α S) (⟦⟨r, s, hs⟩⟧ : loc α S) (of_comm_ring α S s) = of_comm_ring α S r :=
quotient.sound $ ⟨1, is_submonoid.one_mem S, by simp [mul_comm]⟩

theorem mul_inv_denom (r s : α) (hs : s ∈ S) : @@has_mul.mul (localization.has_mul α S) (of_comm_ring α S r) (⟦⟨1, s, hs⟩⟧ : loc α S) = (⟦⟨r, s, hs⟩⟧ : loc α S) :=
quotient.sound $ ⟨1, is_submonoid.one_mem S, by simp⟩

section simp_lemmas

variables (f f₁ f₂ : α × S)

def mk : loc α S := ⟦f₁⟧
lemma mk_eq : ⟦f₁⟧ = mk α S f₁ := rfl
@[simp] lemma add_frac : mk α S f₁ + mk α S f₂ =
  mk α S ⟨f₁.2.1 * f₂.1 + f₂.2.1 * f₁.1, f₁.2.1 * f₂.2.1,
    is_submonoid.mul_mem f₁.2.2 f₂.2.2⟩ :=
by cases f₁; cases f₂; cases f₁_snd; cases f₂_snd; refl
@[simp] lemma neg_frac : -mk α S f =
  mk α S ⟨-f.1, f.2⟩ :=
by cases f; cases f_snd; refl
@[simp] lemma sub_frac : mk α S f₁ - mk α S f₂ =
  mk α S ⟨f₂.2.1 * f₁.1 - f₁.2.1 * f₂.1, f₁.2.1 * f₂.2.1,
    is_submonoid.mul_mem f₁.2.2 f₂.2.2⟩ :=
by simp; refl
@[simp] lemma mul_frac : mk α S f₁ * mk α S f₂ =
  mk α S ⟨f₁.1 * f₂.1, f₁.2.1 * f₂.2.1,
    is_submonoid.mul_mem f₁.2.2 f₂.2.2⟩ :=
by cases f₁; cases f₂; cases f₁_snd; cases f₂_snd; refl
lemma one_frac : 1 = mk α S ⟨1, 1, is_submonoid.one_mem S⟩ := rfl
lemma zero_frac : 0 = mk α S ⟨0, 1, is_submonoid.one_mem S⟩ := rfl

@[simp] lemma quotient.lift_beta {β : Sort v} (f : α × S → β) (h : ∀ a b, a ≈ b → f a = f b) (x : α × S) :
quotient.lift f h (mk α S x) = f x := rfl

@[simp] lemma quotient.lift_on_beta {β : Sort v} (f : α × S → β) (h : ∀ a b, a ≈ b → f a = f b) (x : α × S) :
quotient.lift_on (mk α S x) f h = f x := rfl

@[simp] lemma div_self {y : α} {H : y ∈ S} : mk α S (y, ⟨y, H⟩) = 1 :=
quotient.sound ⟨1, is_submonoid.one_mem S, by simp⟩

end simp_lemmas

end localization

-- Factoids (not to go to mathlib):

instance : add_comm_group int := ring.to_add_comm_group int
instance : add_group int := by apply_instance

def frac_int_to_rat : localization.quotient_ring ℤ → ℚ :=
λ f, quotient.lift_on f (λ ⟨r, s, hs⟩, rat.mk r s) $
λ ⟨r₁, s₁, hs₁⟩ ⟨r₂, s₂, hs₂⟩ ⟨t, hts, ht⟩,
have hsnz₁ : s₁ ≠ 0,
from localization.ne_zero_of_mem_non_zero_divisors hs₁,
have hsnz₂ : s₂ ≠ 0,
from localization.ne_zero_of_mem_non_zero_divisors hs₂,
have htnz : t ≠ 0,
from localization.ne_zero_of_mem_non_zero_divisors hts,
begin
  cases eq_zero_or_eq_zero_of_mul_eq_zero ht with hrs htz,
  { change rat.mk r₁ s₁ = rat.mk r₂ s₂,
    rw sub_eq_zero at hrs,
    rw rat.mk_eq hsnz₁ hsnz₂,
    simp only [mul_comm, hrs] },
  {  exfalso,
     exact htnz htz }
end

lemma coe_denom_ne_zero (r : ℚ) : (↑r.denom:ℤ) ≠ 0 :=
λ hn, ne_of_gt r.pos $ int.of_nat_inj hn

def frac_int_of_rat : ℚ → localization.quotient_ring ℤ :=
λ r, ⟦⟨r.num, r.denom, λ z hz,
or.cases_on (eq_zero_or_eq_zero_of_mul_eq_zero hz) id
  (λ hz, false.elim $ coe_denom_ne_zero r hz)⟩⟧

theorem frac_int_to_rat_to_frac_int : ∀ f, frac_int_of_rat (frac_int_to_rat f) = f :=
λ f, quotient.induction_on f $ λ ⟨r, s, hs⟩, quotient.sound
⟨1, is_submonoid.one_mem _,
   suffices r * ↑(rat.mk r s).denom = (rat.mk r s).num * s,
   from show (↑(rat.mk r s).denom * r - s * (rat.mk r s).num) * 1 = 0,
     by simp [mul_comm, this],
   have hnd : (↑(rat.mk r s).denom:ℤ) ≠ 0,
     from coe_denom_ne_zero $ rat.mk r s,
   have hns : s ≠ 0,
     from localization.ne_zero_of_mem_non_zero_divisors hs,
   have _, from rat.num_denom $ rat.mk r s,
   by rwa ← rat.mk_eq hns hnd ⟩

theorem rat_to_frac_int_to_rat : ∀ r, frac_int_to_rat (frac_int_of_rat r) = r :=
λ ⟨n, d, h, c⟩, eq.symm $ rat.num_denom _

def canonical : equiv (localization.quotient_ring ℤ) (ℚ) :=
⟨frac_int_to_rat, frac_int_of_rat,
   frac_int_to_rat_to_frac_int,
   rat_to_frac_int_to_rat⟩

def dyadic_rat := localization.away (2:ℤ)


import init.data.list.lemmas

variable {α : Type}

open list

#check subset_of_cons_subset
structure sublist  (α : Type) (ll : list α) :=
(l : list α)
(p: l ⊆ ll)

def filter (p : α → Prop) [decidable_pred p] : list α → list α
| []     := []
| (a::l) := if p a then a :: filter l else filter l

def filter_sublist (p : α → Prop) [decidable_pred p] : (Π l: list α,  sublist α l)
| l : [] := sorry

end

lemma shrink_sublist_type {l ll : list α} (s : l ⊆ ll) (f : sublist α ll -> sublist α ll) : sublist α l -> sublist α l :=
(λ x,
sorry)

private def filter_sublist_helper (p : α → Prop) [decidable_pred p] (ll : list α) : sublist α ll -> sublist α ll
| ⟨[], s⟩  := ⟨[], s⟩
| ⟨a::l, s⟩ := begin
  let smol : sublist α l := ⟨l, list.subset.refl l⟩,
  let h : l ⊆ ll := subset_of_cons_subset s,
  have r := shrink_sublist_type h filter_sublist_helper,
  have rest := (r smol),

  have f := if p a then begin
    let l := a :: rest.l,

  end
end

-- if p a then a :: (filter_sublist_helper ⟨l, list.subset_of_cons_subset s⟩) else sorry


lemma maze (P Q R S T U: Prop)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=
begin
    apply l,
    apply j,
    apply h,
    exact p,
end


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Andrew Yang
-/
import category_theory.abelian.diagram_lemmas.four

/-!
# Short exact sequences, and splittings.

`short_exact f g` is the proposition that `0 ⟶ A -f⟶ B -g⟶ C ⟶ 0` is an exact sequence.

We define when a short exact sequence is left-split, right-split, and split.

In an abelian category, a left-split short exact sequence admits a splitting.
-/

noncomputable theory

open category_theory category_theory.limits category_theory.preadditive

variables {𝒜 : Type*} [category 𝒜]

namespace category_theory

variables {A B C A' B' C' : 𝒜} (f : A ⟶ B) (g : B ⟶ C) (f' : A' ⟶ B') (g' : B' ⟶ C')

section has_zero_morphisms

variables [has_zero_morphisms 𝒜] [has_kernels 𝒜] [has_images 𝒜]

/-- If `f : A ⟶ B` and `g : B ⟶ C` then `short_exact f g` is the proposition saying
  the resulting diagram `0 ⟶ A ⟶ B ⟶ C ⟶ 0` is an exact sequence. -/
structure short_exact : Prop :=
[mono  : mono f]
[epi   : epi g]
(exact : exact f g)

open_locale zero_object

-- TODO move
instance zero_to_zero_is_iso {C : Type*} [category C] [has_zero_object C] (f : (0 : C) ⟶ 0) :
  is_iso f :=
by convert (show is_iso (𝟙 (0 : C)), by apply_instance)

/-- An exact sequence `A -f⟶ B -g⟶ C` is *left split*
if there exists a morphism `φ : B ⟶ A` such that `f ≫ φ = 𝟙 A` and `g` is epi.

Such a sequence is automatically short exact (i.e., `f` is mono). -/
structure left_split : Prop :=
(left_split : ∃ φ : B ⟶ A, f ≫ φ = 𝟙 A)
[epi   : epi g]
(exact : exact f g)

lemma left_split.short_exact {f : A ⟶ B} {g : B ⟶ C} (h : left_split f g) : short_exact f g :=
{ mono :=
  begin
    obtain ⟨φ, hφ⟩ := h.left_split,
    haveI : mono (f ≫ φ) := by { rw hφ, apply_instance },
    exact mono_of_mono f φ,
  end,
  epi := h.epi,
  exact := h.exact }

/-- An exact sequence `A -f⟶ B -g⟶ C` is *right split*
if there exists a morphism `φ : C ⟶ B` such that `f ≫ φ = 𝟙 A` and `f` is mono.

Such a sequence is automatically short exact (i.e., `g` is epi). -/
structure right_split : Prop :=
(right_split : ∃ χ : C ⟶ B, χ ≫ g = 𝟙 C)
[mono  : mono f]
(exact : exact f g)

lemma right_split.short_exact {f : A ⟶ B} {g : B ⟶ C} (h : right_split f g) : short_exact f g :=
{ epi :=
  begin
    obtain ⟨χ, hχ⟩ := h.right_split,
    haveI : epi (χ ≫ g) := by { rw hχ, apply_instance },
    exact epi_of_epi χ g,
  end,
  mono := h.mono,
  exact := h.exact }

end has_zero_morphisms

section preadditive

variables [preadditive 𝒜]

/-- An exact sequence `A -f⟶ B -g⟶ C` is *split* if there exist
`φ : B ⟶ A` and `χ : C ⟶ B` such that:
* `f ≫ φ = 𝟙 A`
* `χ ≫ g = 𝟙 C`
* `f ≫ g = 0`
* `χ ≫ φ = 0`
* `φ ≫ f + g ≫ χ = 𝟙 B`

Such a sequence is automatically short exact (i.e., `f` is mono and `g` is epi). -/
structure split : Prop :=
(split : ∃ (φ : B ⟶ A) (χ : C ⟶ B),
  f ≫ φ = 𝟙 A ∧ χ ≫ g = 𝟙 C ∧ f ≫ g = 0 ∧ χ ≫ φ = 0 ∧ φ ≫ f + g ≫ χ = 𝟙 B)

variables [has_kernels 𝒜] [has_images 𝒜]

lemma exact_of_split {A B C : 𝒜} (f : A ⟶ B) (g : B ⟶ C) (χ : C ⟶ B) (φ : B ⟶ A)
  (hfg : f ≫ g = 0) (H : φ ≫ f + g ≫ χ = 𝟙 B) : exact f g :=
{ w := hfg,
  epi :=
  begin
    let ψ : (kernel_subobject g : 𝒜) ⟶ image_subobject f :=
      subobject.arrow _ ≫ φ ≫ factor_thru_image_subobject f,
    suffices : ψ ≫ image_to_kernel f g hfg = 𝟙 _,
    { convert epi_of_epi ψ _, rw this, apply_instance },
    rw ← cancel_mono (subobject.arrow _), swap, { apply_instance },
    simp only [image_to_kernel_arrow, image_subobject_arrow_comp, category.id_comp, category.assoc],
    calc (kernel_subobject g).arrow ≫ φ ≫ f
        = (kernel_subobject g).arrow ≫ 𝟙 B : _
    ... = (kernel_subobject g).arrow        : category.comp_id _,
    rw [← H, preadditive.comp_add],
    simp only [add_zero, zero_comp, kernel_subobject_arrow_comp_assoc],
  end }

section

variables {f g}

lemma split.exact (h : split f g) : exact f g :=
by { obtain ⟨φ, χ, -, -, h1, -, h2⟩ := h, exact exact_of_split f g χ φ h1 h2 }

lemma split.left_split (h : split f g) : left_split f g :=
{ left_split := by { obtain ⟨φ, χ, h1, -⟩ := h, exact ⟨φ, h1⟩, },
  epi := begin
    obtain ⟨φ, χ, -, h2, -⟩ := h,
    have : epi (χ ≫ g), { rw h2, apply_instance },
    exactI epi_of_epi χ g,
  end,
  exact := h.exact }

lemma split.right_split (h : split f g) : right_split f g :=
{ right_split := by { obtain ⟨φ, χ, -, h1, -⟩ := h, exact ⟨χ, h1⟩, },
  mono := begin
    obtain ⟨φ, χ, h1, -⟩ := h,
    have : mono (f ≫ φ), { rw h1, apply_instance },
    exactI mono_of_mono f φ,
  end,
  exact := h.exact }

lemma split.short_exact (h : split f g) : short_exact f g :=
h.left_split.short_exact

end

lemma split.map {𝒜 ℬ : Type*} [category 𝒜] [abelian 𝒜] [category ℬ] [abelian ℬ] (F : 𝒜 ⥤ ℬ)
  [functor.additive F] {A B C : 𝒜} (f : A ⟶ B) (g : B ⟶ C) (h : split f g) :
  split (F.map f) (F.map g) :=
begin
  obtain ⟨φ, χ, h1, h2, h3, h4, h5⟩ := h,
  refine ⟨⟨F.map φ, F.map χ, _⟩⟩,
  simp only [← F.map_comp, ← F.map_id, ← F.map_add, F.map_zero, *, eq_self_iff_true, and_true],
end

/-- The sequence `A ⟶ A ⊞ B ⟶ B` is exact. -/
lemma exact_inl_snd [has_binary_biproducts 𝒜] (A B : 𝒜) :
  exact (biprod.inl : A ⟶ A ⊞ B) biprod.snd :=
exact_of_split _ _ biprod.inr biprod.fst biprod.inl_snd biprod.total

/-- The sequence `B ⟶ A ⊞ B ⟶ A` is exact. -/
lemma exact_inr_fst [has_binary_biproducts 𝒜] (A B : 𝒜) :
  exact (biprod.inr : B ⟶ A ⊞ B) biprod.fst :=
exact_of_split _ _ biprod.inl biprod.snd biprod.inr_fst ((add_comm _ _).trans biprod.total)

end preadditive

section abelian

variables [abelian 𝒜]
open_locale zero_object

lemma is_iso_of_short_exact_of_is_iso_of_is_iso (h : short_exact f g) (h' : short_exact f' g')
  (i₁ : A ⟶ A') (i₂ : B ⟶ B') (i₃ : C ⟶ C')
  (comm₁ : i₁ ≫ f' = f ≫ i₂) (comm₂ : i₂ ≫ g' = g ≫ i₃) [is_iso i₁] [is_iso i₃] :
  is_iso i₂ :=
begin
  obtain ⟨_, _, _⟩ := h,
  obtain ⟨_, _, _⟩ := h',
  resetI,
  refine @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso 𝒜 _ _ 0 _ _ _ 0 _ _ _
    0 f g 0 f' g' 0 i₁ i₂ i₃ _ comm₁ comm₂ 0 0 0 0 0 _ _ _ _ _ _ _ _ _ _ _;
  try { simp };
  try { apply exact_zero_left_of_mono };
  try { assumption };
  rwa ← epi_iff_exact_zero_right,
end

end abelian

/-- A *splitting* of a sequence `A -f⟶ B -g⟶ C` is an isomorphism
to the short exact sequence `0 ⟶ A ⟶ A ⊞ C ⟶ C ⟶ 0` such that
the vertical maps on the left and the right are the identity. -/
@[nolint has_inhabited_instance]
structure splitting [has_zero_morphisms 𝒜] [has_binary_biproducts 𝒜] :=
(iso : B ≅ A ⊞ C)
(comp_iso_eq_inl : f ≫ iso.hom = biprod.inl)
(iso_comp_snd_eq : iso.hom ≫ biprod.snd = g)

variables {f g}

namespace splitting

section has_zero_morphisms
variables [has_zero_morphisms 𝒜] [has_binary_biproducts 𝒜]

attribute [simp, reassoc] comp_iso_eq_inl iso_comp_snd_eq

variables (h : splitting f g)

@[simp, reassoc] lemma inl_comp_iso_eq : biprod.inl ≫ h.iso.inv = f :=
by rw [iso.comp_inv_eq, h.comp_iso_eq_inl]

@[simp, reassoc] lemma iso_comp_eq_snd : h.iso.inv ≫ g = biprod.snd :=
by rw [iso.inv_comp_eq, h.iso_comp_snd_eq]

/-- If `h` is a splitting of `A -f⟶ B -g⟶ C`,
then `h.section : C ⟶ B` is the morphism satisfying `h.section ≫ g = 𝟙 C`. -/
def _root_.category_theory.splitting.section : C ⟶ B := biprod.inr ≫ h.iso.inv

/-- If `h` is a splitting of `A -f⟶ B -g⟶ C`,
then `h.retraction : B ⟶ A` is the morphism satisfying `f ≫ h.retraction = 𝟙 A`. -/
def retraction : B ⟶ A := h.iso.hom ≫ biprod.fst

@[simp, reassoc] lemma section_π : h.section ≫ g = 𝟙 C := by { delta splitting.section, simp }

@[simp, reassoc] lemma ι_retraction : f ≫ h.retraction = 𝟙 A := by { delta retraction, simp }

@[simp, reassoc] lemma section_retraction : h.section ≫ h.retraction = 0 :=
by { delta splitting.section retraction, simp }

/-- The retraction in a splitting is a split mono. -/
protected def split_mono : split_mono f := ⟨h.retraction, by simp⟩

/-- The section in a splitting is a split epi. -/
protected def split_epi : split_epi g := ⟨h.section, by simp⟩

@[simp, reassoc] lemma inr_iso_inv : biprod.inr ≫ h.iso.inv = h.section := rfl

@[simp, reassoc] lemma iso_hom_fst : h.iso.hom ≫ biprod.fst = h.retraction := rfl

-- move this, add `iso_zero_biprod`
/-- If `Y` is a zero object, `X ≅ X ⊞ Y` for any `X`. -/
@[simps]
def iso_biprod_zero {C : Type*} [category C] [has_zero_morphisms C]
  [has_binary_biproducts C] {X Y : C} (hY : is_zero Y) : X ≅ X ⊞ Y :=
{ hom := biprod.inl,
  inv := biprod.fst,
  inv_hom_id' := begin
    apply category_theory.limits.biprod.hom_ext;
    simp only [category.assoc, biprod.inl_fst, category.comp_id, category.id_comp,
      biprod.inl_snd, comp_zero],
    apply hY.eq_of_tgt
  end }
.

/-- A short exact sequence of the form `X -f⟶ Y -0⟶ Z` where `f` is an iso and `Z` is zero
has a splitting. -/
def splitting_of_is_iso_zero {X Y Z : 𝒜} (f : X ⟶ Y) [is_iso f] (hZ : is_zero Z) :
  splitting f (0 : Y ⟶ Z) :=
⟨(as_iso f).symm ≪≫ iso_biprod_zero hZ, by simp [hZ.eq_of_tgt _ 0], by simp⟩

include h

protected lemma mono : mono f :=
begin
  apply mono_of_mono _ h.retraction,
  rw h.ι_retraction,
  apply_instance
end

protected lemma epi : epi g :=
begin
  apply_with (epi_of_epi h.section) { instances := ff },
  rw h.section_π,
  apply_instance
end

instance : mono h.section :=
by { delta splitting.section, apply_instance }

instance : epi h.retraction :=
by { delta retraction, apply epi_comp }

end has_zero_morphisms

section preadditive
variables [preadditive 𝒜] [has_binary_biproducts 𝒜]
variables (h : splitting f g)

lemma split_add : h.retraction ≫ f + g ≫ h.section = 𝟙 _ :=
begin
  delta splitting.section retraction,
  rw [← cancel_mono h.iso.hom, ← cancel_epi h.iso.inv],
  simp only [category.comp_id, category.id_comp, category.assoc,
    iso.inv_hom_id_assoc, iso.inv_hom_id, limits.biprod.total,
    preadditive.comp_add, preadditive.add_comp,
    splitting.comp_iso_eq_inl, splitting.iso_comp_eq_snd_assoc]
end

@[reassoc]
lemma retraction_ι_eq_id_sub :
  h.retraction ≫ f = 𝟙 _ - g ≫ h.section :=
eq_sub_iff_add_eq.mpr h.split_add

@[reassoc]
lemma π_section_eq_id_sub :
  g ≫ h.section = 𝟙 _ - h.retraction ≫ f :=
eq_sub_iff_add_eq.mpr ((add_comm _ _).trans h.split_add)

lemma splittings_comm (h h' : splitting f g) :
  h'.section ≫ h.retraction = - h.section ≫ h'.retraction :=
begin
  haveI := h.mono,
  rw ← cancel_mono f,
  simp [retraction_ι_eq_id_sub],
end

include h

lemma split : split f g :=
begin
  let φ := h.iso.hom ≫ biprod.fst,
  let χ := biprod.inr ≫ h.iso.inv,
  refine ⟨⟨h.retraction, h.section, h.ι_retraction, h.section_π, _,
    h.section_retraction, h.split_add⟩⟩,
  rw [← h.inl_comp_iso_eq, category.assoc, h.iso_comp_eq_snd, biprod.inl_snd],
end

@[reassoc] lemma comp_eq_zero : f ≫ g = 0 :=
h.split.1.some_spec.some_spec.2.2.1

variables [has_kernels 𝒜] [has_images 𝒜] [has_zero_object 𝒜] [has_cokernels 𝒜]

protected lemma exact : exact f g :=
begin
  rw exact_iff_exact_of_iso f g (biprod.inl : A ⟶ A ⊞ C) (biprod.snd : A ⊞ C ⟶ C) _ _ _,
  { exact exact_inl_snd _ _ },
  { refine arrow.iso_mk (iso.refl _) h.iso _,
    simp only [iso.refl_hom, arrow.mk_hom, category.id_comp, comp_iso_eq_inl], },
  { refine arrow.iso_mk h.iso (iso.refl _) _,
    simp only [iso.refl_hom, arrow.mk_hom, category.comp_id, iso_comp_snd_eq],
    erw category.comp_id /- why ?? -/ },
  { refl }
end

protected
lemma short_exact : short_exact f g :=
{ mono := h.mono, epi := h.epi, exact := h.exact }

end preadditive

section abelian
variables [abelian 𝒜]

-- TODO: this should be generalized to isoms of short sequences,
-- because now it forces one direction, and we want both.
/-- To construct a splitting of `A -f⟶ B -g⟶ C` it suffices to supply
a *morphism* `i : B ⟶ A ⊞ C` such that `f ≫ i` is the canonical map `biprod.inl : A ⟶ A ⊞ C` and
`i ≫ q = g`, where `q` is the canonical map `biprod.snd : A ⊞ C ⟶ C`,
together with proofs that `f` is mono and `g` is epi.

The morphism `i` is than automatically an isomorphism. -/
def mk' (h : short_exact f g) (i : B ⟶ A ⊞ C) (h1 : f ≫ i = biprod.inl) (h2 : i ≫ biprod.snd = g) :
  splitting f g :=
{ iso :=
  begin
    refine @as_iso _ _ _ _ i (id _),
    refine is_iso_of_short_exact_of_is_iso_of_is_iso f g _ _ h _ _ _ _
      (h1.trans (category.id_comp _).symm).symm (h2.trans (category.comp_id _).symm),
    split,
    apply exact_inl_snd
  end,
  comp_iso_eq_inl := by { rwa as_iso_hom, },
  iso_comp_snd_eq := h2 }

end abelian

end splitting

section
variables [abelian 𝒜]

/-- A short exact sequence that is left split admits a splitting. -/
def left_split.splitting {f : A ⟶ B} {g : B ⟶ C} (h : left_split f g) : splitting f g :=
splitting.mk' h.short_exact (biprod.lift h.left_split.some g)
(by { ext,
  { simpa only [biprod.inl_fst, biprod.lift_fst, category.assoc] using h.left_split.some_spec },
  { simp only [biprod.inl_snd, biprod.lift_snd, category.assoc, h.exact.w], } })
(by { simp only [biprod.lift_snd], })

end

end category_theory


import smt2
import .test_tactics

lemma uninterpreted_Props :
    forall (f g : int → Prop)
           (x y z : int)
           (Heq : forall x, f x = g x),
        f ((x + y) +z) = g (z + (y + x)) :=
begin
    intros, z3 "uint1.log"
end

lemma uninterpreted_Props_fail :
    forall (f g : int → Prop)
           (x y z : int)
           (Heq : forall x, f x = g x),
        f ((x + y) +z) = g (z + y) :=
begin
    intros, must_fail z3
end

lemma uninterpreted_functions :
    forall (f g : int → int)
           (x y z : int)
           (Heq : forall x, f x = g x),
        f ((x + y) +z) = g (z + (y + x)) :=
begin
    intros, z3
end

lemma uninterpreted_functions_mixed_sorts :
    forall (f g : Prop → int → int)
           (x y z : int)
           (Heq : forall x y, f x y = g x y),
        f (x < 0) ((x + y) +z) = g (x < 0) (z + (y + x)) :=
begin
    intros, z3
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.matrix_algebra
import Mathlib.data.polynomial.algebra_map
import Mathlib.PostPort

universes u_1 u_2 w

namespace Mathlib

/-!
# Algebra isomorphism between matrices of polynomials and polynomials of matrices

Given `[comm_ring R] [ring A] [algebra R A]`
we show `polynomial A ≃ₐ[R] (A ⊗[R] polynomial R)`.
Combining this with the isomorphism `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)` proved earlier
in `ring_theory.matrix_algebra`, we obtain the algebra isomorphism
```
def mat_poly_equiv :
  matrix n n (polynomial R) ≃ₐ[R] polynomial (matrix n n R)
```
which is characterized by
```
coeff (mat_poly_equiv m) k i j = coeff (m i j) k
```

We will use this algebra isomorphism to prove the Cayley-Hamilton theorem.
-/

namespace poly_equiv_tensor

/--
(Implementation detail).
The bare function underlying `A ⊗[R] polynomial R →ₐ[R] polynomial A`, on pure tensors.
-/
def to_fun (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (a : A) (p : polynomial R) : polynomial A :=
  finsupp.sum p fun (n : ℕ) (r : R) => coe_fn (polynomial.monomial n) (a * coe_fn (algebra_map R A) r)

/--
(Implementation detail).
The function underlying `A ⊗[R] polynomial R →ₐ[R] polynomial A`,
as a linear map in the second factor.
-/
def to_fun_linear_right (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (a : A) : linear_map R (polynomial R) (polynomial A) :=
  linear_map.mk (to_fun R A a) sorry sorry

/--
(Implementation detail).
The function underlying `A ⊗[R] polynomial R →ₐ[R] polynomial A`,
as a bilinear function of two arguments.
-/
def to_fun_bilinear (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] : linear_map R A (linear_map R (polynomial R) (polynomial A)) :=
  linear_map.mk (to_fun_linear_right R A) sorry sorry

/--
(Implementation detail).
The function underlying `A ⊗[R] polynomial R →ₐ[R] polynomial A`,
as a linear map.
-/
def to_fun_linear (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] : linear_map R (tensor_product R A (polynomial R)) (polynomial A) :=
  tensor_product.lift (to_fun_bilinear R A)

-- We apparently need to provide the decidable instance here

-- in order to successfully rewrite by this lemma.

theorem to_fun_linear_mul_tmul_mul_aux_1 (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (p : polynomial R) (k : ℕ) (h : Decidable (¬polynomial.coeff p k = 0)) (a : A) : ite (¬polynomial.coeff p k = 0) (a * coe_fn (algebra_map R A) (polynomial.coeff p k)) 0 =
  a * coe_fn (algebra_map R A) (polynomial.coeff p k) := sorry

theorem to_fun_linear_mul_tmul_mul_aux_2 (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (k : ℕ) (a₁ : A) (a₂ : A) (p₁ : polynomial R) (p₂ : polynomial R) : a₁ * a₂ * coe_fn (algebra_map R A) (polynomial.coeff (p₁ * p₂) k) =
  finset.sum (finset.nat.antidiagonal k)
    fun (x : ℕ × ℕ) =>
      a₁ * coe_fn (algebra_map R A) (polynomial.coeff p₁ (prod.fst x)) *
        (a₂ * coe_fn (algebra_map R A) (polynomial.coeff p₂ (prod.snd x))) := sorry

theorem to_fun_linear_mul_tmul_mul (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (a₁ : A) (a₂ : A) (p₁ : polynomial R) (p₂ : polynomial R) : coe_fn (to_fun_linear R A) (tensor_product.tmul R (a₁ * a₂) (p₁ * p₂)) =
  coe_fn (to_fun_linear R A) (tensor_product.tmul R a₁ p₁) * coe_fn (to_fun_linear R A) (tensor_product.tmul R a₂ p₂) := sorry

theorem to_fun_linear_algebra_map_tmul_one (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (r : R) : coe_fn (to_fun_linear R A) (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) =
  coe_fn (algebra_map R (polynomial A)) r := sorry

/--
(Implementation detail).
The algebra homomorphism `A ⊗[R] polynomial R →ₐ[R] polynomial A`.
-/
def to_fun_alg_hom (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] : alg_hom R (tensor_product R A (polynomial R)) (polynomial A) :=
  algebra.tensor_product.alg_hom_of_linear_map_tensor_product (to_fun_linear R A) (to_fun_linear_mul_tmul_mul R A)
    (to_fun_linear_algebra_map_tmul_one R A)

@[simp] theorem to_fun_alg_hom_apply_tmul (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (a : A) (p : polynomial R) : coe_fn (to_fun_alg_hom R A) (tensor_product.tmul R a p) =
  finsupp.sum p fun (n : ℕ) (r : R) => coe_fn (polynomial.monomial n) (a * coe_fn (algebra_map R A) r) := sorry

/--
(Implementation detail.)

The bare function `polynomial A → A ⊗[R] polynomial R`.
(We don't need to show that it's an algebra map, thankfully --- just that it's an inverse.)
-/
def inv_fun (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (p : polynomial A) : tensor_product R A (polynomial R) :=
  polynomial.eval₂ (↑algebra.tensor_product.include_left) (tensor_product.tmul R 1 polynomial.X) p

@[simp] theorem inv_fun_add (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] {p : polynomial A} {q : polynomial A} : inv_fun R A (p + q) = inv_fun R A p + inv_fun R A q := sorry

theorem inv_fun_monomial (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (n : ℕ) (a : A) : inv_fun R A (coe_fn (polynomial.monomial n) a) =
  coe_fn algebra.tensor_product.include_left a * tensor_product.tmul R 1 polynomial.X ^ n :=
  polynomial.eval₂_monomial (↑algebra.tensor_product.include_left) (tensor_product.tmul R 1 polynomial.X)

theorem left_inv (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (x : tensor_product R A (polynomial R)) : inv_fun R A (coe_fn (to_fun_alg_hom R A) x) = x := sorry

theorem right_inv (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (x : polynomial A) : coe_fn (to_fun_alg_hom R A) (inv_fun R A x) = x := sorry

/--
(Implementation detail)

The equivalence, ignoring the algebra structure, `(A ⊗[R] polynomial R) ≃ polynomial A`.
-/
def equiv (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] : tensor_product R A (polynomial R) ≃ polynomial A :=
  equiv.mk (⇑(to_fun_alg_hom R A)) (inv_fun R A) (left_inv R A) (right_inv R A)

end poly_equiv_tensor

/--
The `R`-algebra isomorphism `polynomial A ≃ₐ[R] (A ⊗[R] polynomial R)`.
-/
def poly_equiv_tensor (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] : alg_equiv R (polynomial A) (tensor_product R A (polynomial R)) :=
  alg_equiv.symm (alg_equiv.mk (alg_hom.to_fun sorry) (equiv.inv_fun sorry) sorry sorry sorry sorry sorry)

@[simp] theorem poly_equiv_tensor_apply (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (p : polynomial A) : coe_fn (poly_equiv_tensor R A) p =
  polynomial.eval₂ (↑algebra.tensor_product.include_left) (tensor_product.tmul R 1 polynomial.X) p :=
  rfl

@[simp] theorem poly_equiv_tensor_symm_apply_tmul (R : Type u_1) (A : Type u_2) [comm_semiring R] [semiring A] [algebra R A] (a : A) (p : polynomial R) : coe_fn (alg_equiv.symm (poly_equiv_tensor R A)) (tensor_product.tmul R a p) =
  finsupp.sum p fun (n : ℕ) (r : R) => coe_fn (polynomial.monomial n) (a * coe_fn (algebra_map R A) r) := sorry

/--
The algebra isomorphism stating "matrices of polynomials are the same as polynomials of matrices".

(You probably shouldn't attempt to use this underlying definition ---
it's an algebra equivalence, and characterised extensionally by the lemma
`mat_poly_equiv_coeff_apply` below.)
-/
def mat_poly_equiv {R : Type u_1} [comm_semiring R] {n : Type w} [DecidableEq n] [fintype n] : alg_equiv R (matrix n n (polynomial R)) (polynomial (matrix n n R)) :=
  alg_equiv.trans
    (alg_equiv.trans (matrix_equiv_tensor R (polynomial R) n)
      (algebra.tensor_product.comm R (polynomial R) (matrix n n R)))
    (alg_equiv.symm (poly_equiv_tensor R (matrix n n R)))

theorem mat_poly_equiv_coeff_apply_aux_1 {R : Type u_1} [comm_semiring R] {n : Type w} [DecidableEq n] [fintype n] (i : n) (j : n) (k : ℕ) (x : R) : coe_fn mat_poly_equiv (matrix.std_basis_matrix i j (coe_fn (polynomial.monomial k) x)) =
  coe_fn (polynomial.monomial k) (matrix.std_basis_matrix i j x) := sorry

theorem mat_poly_equiv_coeff_apply_aux_2 {R : Type u_1} [comm_semiring R] {n : Type w} [DecidableEq n] [fintype n] (i : n) (j : n) (p : polynomial R) (k : ℕ) : polynomial.coeff (coe_fn mat_poly_equiv (matrix.std_basis_matrix i j p)) k =
  matrix.std_basis_matrix i j (polynomial.coeff p k) := sorry

@[simp] theorem mat_poly_equiv_coeff_apply {R : Type u_1} [comm_semiring R] {n : Type w} [DecidableEq n] [fintype n] (m : matrix n n (polynomial R)) (k : ℕ) (i : n) (j : n) : polynomial.coeff (coe_fn mat_poly_equiv m) k i j = polynomial.coeff (m i j) k := sorry

@[simp] theorem mat_poly_equiv_symm_apply_coeff {R : Type u_1} [comm_semiring R] {n : Type w} [DecidableEq n] [fintype n] (p : polynomial (matrix n n R)) (i : n) (j : n) (k : ℕ) : polynomial.coeff (coe_fn (alg_equiv.symm mat_poly_equiv) p i j) k = polynomial.coeff p k i j := sorry

theorem mat_poly_equiv_smul_one {R : Type u_1} [comm_semiring R] {n : Type w} [DecidableEq n] [fintype n] (p : polynomial R) : coe_fn mat_poly_equiv (p • 1) = polynomial.map (algebra_map R (matrix n n R)) p := sorry