-------------------------------------------------------------------
-- The PEDANTIC (Proof Engine for Deductive Automation using Non-deterministic
-- Traversal of Instruction Code) verification framework
--
-- Developed by Kenneth Roe
-- For more information, check out www.cs.jhu.edu/~roe
--
-- AbsState.lean
-- This file contains a model of the abstract state template.  The function realizeState relates
-- these abstract states to concrete states.  Key top level
-- definitions:
--    Value
--    absExp
--    absState
--    absEval
--    realizeState
--    supportsFunctionality
--
-------------------------------------------------------------------

 import .impHeap

open tactic
open monad
open expr
open smt_tactic

-------------------------------------------------------------------
--
-- absHeap, the abstract heaps
--
-------------------------------------------------------------------

 def stateProp := imp_state -> Prop

-------------------------------------------------------------------
--
-- This section builds up the definition of composing abstract states.
--
-------------------------------------------------------------------

def compose_heaps (h1 h2 : heap) : heap := λ x, h1 x <|> h2 x

def concreteCompose (s1 : imp_state) (s2 : imp_state) (s : imp_state) : Prop :=
    (s1.snd)=(s2.snd) ∧
    (s.snd)=(s1.snd) ∧
    (∀ v, (s1.fst) v=option.none ∨ (s2.fst) v=option.none) ∧
    compose_heaps (s1.fst) (s2.fst)=(s.fst)

theorem composeEnvPropagate1 :
    ∀ s1 s2 s v,
    concreteCompose s1 s2 s →
    s1.snd v = s.snd v :=
begin
    intro, intro, intro, intro, intro,
    unfold concreteCompose at *, destruct a, intros,
    destruct right,intro, intro, rw left_1
end.

theorem composeEnvPropagate2 :
    ∀ s1 s2 s v,
    concreteCompose s1 s2 s →
    s2.snd v = s.snd v :=
begin
    intro, intro, intro, intro, intro,
    unfold concreteCompose at *, destruct a, intros,
    destruct right,intro,intro,
    rewrite left_1, rewrite left
end

--
-- This is the main definition for composing abstract states
--
def composeAbsStates : stateProp → stateProp → stateProp :=
        (λ as1 as2 sr, (∃ h1 h2,
                           (as1 h1 ∧
                           as2 h2 ∧
                           (∀ v, (h1.fst v=option.none ∨
                                  h2.fst v=option.none)) ∧
                           (h1.fst)=(h2.fst) ∧
                           (sr.fst)=(h1.fst) ∧
                           (∀ x, sr.fst x = compose_heaps (h1.fst) (h2.fst) x))
              )).

-------------------------------------------------------------------
--
-- This section builds up the definition of absState and contains a few
-- functions for returning information about absState objects.
--
-------------------------------------------------------------------

def absVar := ℕ

--def absHeap := (λ h hpred (x : imp_state), (h = x.fst ∧ hpred x.fst ∧
--               (∀ v, x.snd v=0)))

--def bind {ev} := ℕ -> option ev.

-- Value is the type used for the values returned when evaluating an absExp
inductive Value : Type
| NatValue : ℕ -> Value
| ListValue : list Value -> Value
| NoValue : Value

instance : inhabited Value := ⟨Value.NoValue⟩

-- Here is the definition for expressions.
-- It takes three parameters in defining its semantics:
--     ev - the type of the OtherType case in Value
--     eq - an equality function over ev
--     f - a function defining the semantics of AbsFun--this usually includes definitions for
--         many basic operators such as addition
--
--inductive  absExp : Type
--| AbsConstVal : (@Value unit) -> absExp
--| AbsVar : ident -> absExp
--| AbsQVar : absVar -> absExp
--| AbsFun : ident -> list absExp -> absExp.

-- Special functions for managing separation logic

mutual def rangeSet, rangeSetList
with rangeSet : Value -> option (list nat)
| (Value.ListValue ((Value.NatValue loc)::r)) :=
  (loc::(rangeSetList r))
| (Value.NatValue _) := option.some list.nil
| _                  := option.none
with rangeSetList : list Value → (list nat)
| (f::r) := match rangeSet f
                     with
                     | some l := l++(rangeSetList r)
                     | _     := []
                     end
| _ := @list.nil ℕ.

def treeRecords (v:Value) : list ℕ :=
    (rangeSet v).get_or_else []

def inTree : Value → Value → Prop
| (Value.NatValue x) v := x ∈ treeRecords v
| (Value.ListValue (Value.NatValue x :: _)) v := x ∈ treeRecords v
| _ v := false

def rangeNumeric : ℕ → ℕ → list ℕ
| s (e+1) :=
    if (e+1)=s then list.nil
    else if s=e then (e::list.nil)
    else e::(rangeNumeric s e)
| s 0 := list.nil

mutual def fullRangeSet, fullRangeSetList
with fullRangeSet : Value -> option (list nat)
| (Value.ListValue ((Value.NatValue loc)::r)) :=
   match fullRangeSetList r with
   | option.some ll := option.some (append (rangeNumeric loc (loc+1+(list.sizeof r))) ll)
   | _              := option.none
   end
| (Value.NatValue _) := option.some list.nil
| _                  := option.none
with fullRangeSetList : list Value → option (list nat)
| (f::r) := match fullRangeSet f
                     with
                     | some l :=
                         match fullRangeSetList r with
                         | option.some ll := (some (append l ll))
                         | _ := option.none
                         end
                     | _     := option.none
                     end
| _ := @list.nil ℕ.

--def listmem : ℕ → list ℕ → bool
--| _ list.nil := ff
--| e (list.cons a b) := if beq_nat e a then tt else listmem e b

def Rmember : ℕ → Value → Prop
| a v := match (rangeSet v) with
         | option.some l := a ∈ l
         | option.none := ff
         end

instance : has_mem ℕ Value := ⟨Rmember⟩

def Rinclude : ℕ → Value → bool
| a v := match (fullRangeSet v) with
         | option.some l := a ∈ l
         | option.none := ff
         end

/- mutual def findRecord, findRecordHelper
with findRecord : ℕ → Value → (list Value)
| l (Value.ListValue ((Value.NatValue x)::r)) :=
                 if beq_nat x l then
                     ((Value.NatValue x)::r)
                 else findRecordHelper x r
| _ _ := list.nil
with findRecordHelper : ℕ → (list Value) → (list Value)
| _ list.nil := list.nil
| v (f::r) := match findRecord v f with
              | list.nil := findRecordHelper v r
              | x        := x
              end.   -/

-- place holder
def find (n:ℕ) (v:Value) : Value := v.

-- Some auxiliary definitions useful abstract states
inductive fold_compose : list imp_state → imp_state → Prop
| FCNil : ∀ x, fold_compose list.nil (inhabited.default heap,x)
| FCCons : ∀ f r state rstate,
             fold_compose r rstate →
             concreteCompose rstate f state →
             fold_compose (f::r) state

--inductive allFirsts {t1} {t2} : list t1 → list (t1 × t2) → Prop
--| AFNil : allFirsts list.nil list.nil
--| AFCons : ∀ fx fy r r', allFirsts r r' → allFirsts (fx::r) ((fx,fy)::r')

--def allFirsts {t1 t2} (l1 : list t1) (l2 : list (t1 × t2)) : Prop := l2.map prod.fst = l1

--inductive allSeconds {t1} {t2} : list t1 → list (t2 × t1) → Prop
--  | ASNil : allSeconds list.nil list.nil
--  | ASCons : ∀ fx fy r r', allSeconds r r' → allSeconds (fy::r) ((fx,fy)::r').

inductive anyHeap : ℕ → ℕ → heap → Prop
    | AnyHeapBase : ∀ start,
                    anyHeap start 0 (λ x, none)
    | AnyHeapNext : ∀ start next heap y,
                    anyHeap (start+1) next heap ->
                    anyHeap start (next+1)
                            (λ x, if x=start then some y else heap x).

inductive Rcell : ℕ → (list ℕ) → heap → ℕ → Prop
  | RCellBase : forall l ll h,
                Rcell l ll h l
  | RCellNext : forall l ll index (h : heap) n nn,
                index ∈ ll=tt →
                h (n+index)=some nn →
                Rcell l ll h n →
                Rcell l ll h nn.

def combine_heap (h1 : heap) (h2 : heap) (x :ℕ) :=
    match h1 x with
    | none := h2 x
    | some y := some y
    end.

inductive mergeHeaps : (list heap) → heap → Prop
  | MHBase : mergeHeaps list.nil (λ x, none)
  | MHNext : ∀ (f : heap) (r :list heap) (h1 : heap) (h2 : heap) (h : heap),
             mergeHeaps r h2 →
             (∀ (x : ℕ), h1 x=none ∨ h2 x=none) →
             h = (combine_heap h1 h2) →
             mergeHeaps (f::r) h.

inductive heapWithIndexList : (list ℕ) → (list heap) → (list Value) → (list (nat × heap × Value)) → Prop
| HWIBase : heapWithIndexList list.nil list.nil list.nil list.nil
| HWINext : ∀ ir hr ihr br i h b,
            heapWithIndexList ir hr br ihr ->
            heapWithIndexList (i::ir) (h::hr) (b::br) ((i,h,b)::ihr).

def findIndex : ℕ → heap → list (nat × heap × Value) → Value
| n h list.nil :=
             match h n with
             | some x := Value.NatValue x
             | none   := Value.NatValue 0
             end
| n h ((nn,hh,v)::r) := if n=nn then v else findIndex n h r

def buildList : ℕ → ℕ → heap → list (nat ×  heap ×  Value) → list Value
| i 0 h l := list.nil
| i (s+1) h l := (findIndex i h l)::(buildList (i+1) s h l)

--inductive ihmem : ℕ → heap → Value → list (ℕ × heap × Value) → Prop
--| IHBase : ∀ (n : ℕ) (h : heap) (v : Value) (hl : list (ℕ × heap × Value)),
--            ihmem n h v ((n,h,v)::hl)
--| IHNext : ∀ n h v f hl,
--             ihmem n h v hl →
--             ihmem n h v (f::hl).

--
-- Recursive definition for the TREE construct--used in the definition of basicState
--
-- Parameters:
--    #1 - root of tree
--    #2 - size of each node in the tree
--    #3 - list of offsets to fields for each node
--    #4 - functional representation of the tree
--    #5 - concrete heap (Must be exact heap for the tree)
--
inductive Tree : ℕ → ℕ → (list ℕ) → Value → heap → Prop
| TreeNext : ∀ root size indices heaps ihlist h0 h1 heap values vals,
            size > 0 →
            anyHeap root size h0 →
            heapWithIndexList indices heaps values ihlist →
            not(root=0) →
            (∀ i h v x, (i,h,v) ∈ ihlist → some x=h0 (root+x) → Tree x size indices v h) →
            mergeHeaps heaps h1 →
            (∀ l, (h1 l=none ∨ h0 l=none)) →
            heap = combine_heap h1 h0 ->
            vals = buildList root size heap ihlist ->
            Tree root size indices (Value.ListValue ((Value.NatValue root)::vals)) heap
  | TreeBase : forall size index (h : ℕ → option ℕ),
            size > 0 →
            (∀ (v : ℕ), h v=none) →
            Tree 0 size index (Value.ListValue ((Value.NatValue 0)::list.nil)) h

def absTree (r: env → ℕ) (s:ℕ) (f: list ℕ) (v:Value) (st: imp_state) := Tree (r st.snd) s f v st.fst.

-- Path stuff
inductive anyHeapv : ℕ → ℕ → heap → (list Value) → Prop
| AnyHeapvBase : ∀ start, anyHeapv start 0 (λ x, none) list.nil
| AnyHeapvNext : ∀ start next heap y r,
                     anyHeapv (start+1) next heap r →
                     anyHeapv start (next+1) (λ x, if x=start then some y else heap x)
                                    ((Value.NatValue y)::r).

inductive valueIndexList : (list ℕ) → (list Value) → (list (ℕ × Value)) → Prop
| VIBase : valueIndexList list.nil list.nil list.nil
| VINext : ∀ ir br i b ibr,
           valueIndexList ir br ibr →
           valueIndexList (i::ir) (b::br) ((i,b)::ibr).

inductive imem : ℕ → Value → list (ℕ × Value) → Prop
| IBase : ∀ (n : ℕ) (v : Value) hl,
          imem n v ((n,v)::hl)
| INext : ∀ (n : ℕ) (v : Value) f hl,
          imem n v hl →
          imem n v (f::hl).

inductive updateRec : list (nat × Value) → ℕ → list Value → list Value → Prop
| UBase : ∀ n vl,
          updateRec vl n list.nil list.nil
| UMem : ∀ n v vl or nr x,
         imem n v vl →
         updateRec vl (n+1) or nr →
         updateRec vl n (x::or) (v::nr)
| UDef1 : ∀ n v vl or nr x,
          not(imem n v vl) →
          updateRec vl (n+1) or nr →
          updateRec vl n ((Value.NatValue x)::or) ((Value.NatValue x)::or)
| UDef2 : ∀ n v vl or nr x rr,
          not(imem n v vl) →
          updateRec vl (n+1) or nr →
          updateRec vl n ((Value.ListValue ((Value.NatValue x)::rr))::or) ((Value.NatValue x)::or).

def nth {t} : ℕ → list t → t → t
| 0 (f::r) d := f
| (n+1) (f::r) d := nth n r d
| _ _ d := d.

def nthval: ℕ → Value → Value
| n (Value.ListValue l) := nth x l Value.NoValue
| _ _ := Value.NoValue

inductive Path : ℕ → ℕ → list ℕ → Value → Value → Prop
  | PathNext : ∀ (root : ℕ) (size : ℕ) indices (baseData : Value) rec vals ivals rec2,
            size > 0 →
            not(root=0) →
            --((Value.NatValue root)::rec) = findRecord root baseData →
            valueIndexList indices vals ivals →
            --(∀ i x v r, imem i v ivals →
            --            ((Value.ListValue ((Value.NatValue x)::r))=(nth i rec Value.NoValue) ∧
            --            Path x size indices baseData v))) →
            updateRec ivals 0 rec rec2 →
            Path root size indices baseData (Value.ListValue (Value.NatValue root::rec2))
  | PathBase : ∀ size l h,
            size > 0 →
            Path 0 size l h (Value.ListValue ((Value.NatValue 0)::list.nil)).

--
-- Rmember is a predicate used in AbsPredicate constructs to determine whether a nat
-- is in fact a pointer to the head of any of the nodes in the list or tree represented
-- by an RFun construct.
--
-- Parameters:
--    l - location to test
--    tree - a tree (which is the same form as parameter #4 to tree above
--
-- This definition is used in basicEval for the 'inTree' function
--

theorem Rmember1 { a:ℕ } { v:Value } { l:list ℕ } :
        some l = rangeSet v → (a ∈ l)=(a ∈ v):= begin
        intros, unfold has_mem.mem, unfold Rmember, rewrite ← a_1,
        simp only [Rmember._match_1], unfold has_mem.mem
end

theorem rootIsMemberAux (root:ℕ) (r:list Value) :
        root ∈ (Value.ListValue (Value.NatValue root :: r)) = to_bool true :=
begin
    rewrite ← Rmember1, swap, unfold rangeSet,refl,simp
end

theorem rootIsMember : forall root size fields heap (v : Value),
    root ≠ 0 ->
    Tree root size fields v heap ->
    root ∈ v := begin
    intros, cases a_1,
    rw rootIsMemberAux, simp, simp at a, cases a
end

inductive strip_nat_values : (list Value) -> (list ℕ) -> Prop
| SNVNil : strip_nat_values list.nil list.nil
| SNVCons : forall v a b,
            strip_nat_values a b ->
            strip_nat_values ((Value.NatValue v)::a) (v::b).

-- Separation connectives
def absCompose : (imp_state → Prop) → (imp_state → Prop) → imp_state → Prop
| s1 s2 st := ∃ st1 st2,
              (s1 st1 ∧
               s2 st2 ∧
               concreteCompose st1 st2 st).

infix `**`:5 := absCompose.

def absMagicWand : (imp_state → Prop) → (imp_state → Prop) → imp_state → Prop
| s1 s2 st := ∀ st1 st2,
              s1 st1 →
              s2 st2 →
              concreteCompose st st2 st1.

def absOrCompose : (imp_state → Prop) → (imp_state → Prop) → imp_state → Prop
| s1 s2 st := (s1 st ∨ s2 st)

-- Separation leaves
def absEmpty : imp_state → Prop
| st := ∀ (x : ℕ), st.fst x=none

def absAny : imp_state → Prop
| _ := true.

def absNone : imp_state → Prop
| _ := false.

-- Non-trivial leaves
def absPredicate : (env → Prop) → imp_state → Prop
| p s := p s.snd.

def absStateTree : (env → ℕ) → (env → ℕ)→ (env → list ℕ) → (env → Value)  → imp_state → Prop
| root size fields fvalue st := Tree (root st.snd) (size st.snd) (fields st.snd) (fvalue st.snd) st.fst.

def absStatePath : (env → ℕ) → (env → ℕ)→ (env → list ℕ) → (env → Value)  → (env → Value) → imp_state → Prop
| root size fields fvalue path st := Path (root st.snd) (size st.snd) (fields st.snd) (fvalue st.snd) (path st.snd).

def absStateArray : (env → ℕ) → (env → ℕ)→ (env → list Value) → imp_state → Prop
| root size values st := anyHeapv (root st.snd) (size st.snd) st.fst (values st.snd).

def absCell : (env → ℕ) → (env → ℕ) → imp_state → Prop
| l v h := (h.fst (l h.snd))=some (v h.snd) ∧
            (l h.snd ≠ 0 →
            (∀ (x : ℕ), x ≠ (l h.snd) → h.fst x=none)).

-- Separation updaters
def absUpdateLoc : (env → ℕ) → (env → ℕ) → (imp_state → Prop) → imp_state → Prop
| loc val s str := ∀ st, s st →
                   (st.snd = str.snd ∧
                    str.fst = (λ v, if v=(loc st.snd) then val st.snd else (st.fst) v)).

def absUpdateState : (imp_state → Prop) → (imp_state → Prop) → (imp_state → Prop) → (imp_state → Prop)
| s m p := absCompose (absMagicWand s m) p.

-- Separation quantifiers
def absAll {t : Type} : (t → imp_state → Prop) → (imp_state → Prop) :=
    (λ (st : t → imp_state → Prop) (i : imp_state), (∀ (q:t), (st q i)))

def absAllU {t : Type} : (list t) → (t → imp_state → Prop) → (imp_state → Prop)
| (f::r) st := absCompose (st f) (absAllU r st)
| list.nil st := absEmpty

def absExists {t : Type} : (t → imp_state → Prop) → (imp_state → Prop) :=
    (λ (st : t → imp_state → Prop) (i : imp_state), (∃ (q:t), (st q i)))

def absExistsU {t : Type} : list t → (t → imp_state → Prop) → (imp_state → Prop)
| (f::r) st := absOrCompose (st f) (absExistsU r st)
| list.nil st := absNone

def absEach {t : Type} : (list t) → (t → imp_state → Prop) → (imp_state → Prop)
| (f::r) st := absCompose (st f) (absEach r st)
| list.nil st := absEmpty.

def absState := imp_state → Prop

def absExp {t} := env → t

def realizeState (st : absState) (s : imp_state) : Prop := st s

def absEval {t} (e : env) (exp : env → t) := exp e


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

/-!
# Limits in the category of indexed families of objects.

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

Given a functor `F : J ⥤ Π i, C i` into a category of indexed families,
1. we can assemble a collection of cones over `F ⋙ pi.eval C i` into a cone over `F`
2. if all those cones are limit cones, the assembled cone is a limit cone, and
3. if we have limits for each of `F ⋙ pi.eval C i`, we can produce a
   `has_limit F` instance
-/

open category_theory
open category_theory.limits

namespace category_theory.pi

universes v₁ v₂ u₁ u₂

variables {I : Type v₁} {C : I → Type u₁} [Π i, category.{v₁} (C i)]
variables {J : Type v₁} [small_category J]
variables {F : J ⥤ Π i, C i}

/--
A cone over `F : J ⥤ Π i, C i` has as its components cones over each of the `F ⋙ pi.eval C i`.
-/
def cone_comp_eval (c : cone F) (i : I) : cone (F ⋙ pi.eval C i) :=
{ X := c.X i,
  π :=
  { app := λ j, c.π.app j i,
    naturality' := λ j j' f, congr_fun (c.π.naturality f) i, } }

/--
A cocone over `F : J ⥤ Π i, C i` has as its components cocones over each of the `F ⋙ pi.eval C i`.
-/
def cocone_comp_eval (c : cocone F) (i : I) : cocone (F ⋙ pi.eval C i) :=
{ X := c.X i,
  ι :=
  { app := λ j, c.ι.app j i,
    naturality' := λ j j' f, congr_fun (c.ι.naturality f) i, } }

/--
Given a family of cones over the `F ⋙ pi.eval C i`, we can assemble these together as a `cone F`.
-/
def cone_of_cone_comp_eval (c : Π i, cone (F ⋙ pi.eval C i)) : cone F :=
{ X := λ i, (c i).X,
  π :=
  { app := λ j i, (c i).π.app j,
    naturality' := λ j j' f, by { ext i, exact (c i).π.naturality f, } } }

/--
Given a family of cocones over the `F ⋙ pi.eval C i`,
we can assemble these together as a `cocone F`.
-/
def cocone_of_cocone_comp_eval (c : Π i, cocone (F ⋙ pi.eval C i)) : cocone F :=
{ X := λ i, (c i).X,
  ι :=
  { app := λ j i, (c i).ι.app j,
    naturality' := λ j j' f, by { ext i, exact (c i).ι.naturality f, } } }

/--
Given a family of limit cones over the `F ⋙ pi.eval C i`,
assembling them together as a `cone F` produces a limit cone.
-/
def cone_of_cone_eval_is_limit {c : Π i, cone (F ⋙ pi.eval C i)} (P : Π i, is_limit (c i)) :
  is_limit (cone_of_cone_comp_eval c) :=
{ lift := λ s i, (P i).lift (cone_comp_eval s i),
  fac' := λ s j,
  begin
    ext i,
    exact (P i).fac (cone_comp_eval s i) j,
  end,
  uniq' := λ s m w,
  begin
    ext i,
    exact (P i).uniq (cone_comp_eval s i) (m i) (λ j, congr_fun (w j) i)
  end }

/--
Given a family of colimit cocones over the `F ⋙ pi.eval C i`,
assembling them together as a `cocone F` produces a colimit cocone.
-/
def cocone_of_cocone_eval_is_colimit
  {c : Π i, cocone (F ⋙ pi.eval C i)} (P : Π i, is_colimit (c i)) :
  is_colimit (cocone_of_cocone_comp_eval c) :=
{ desc := λ s i, (P i).desc (cocone_comp_eval s i),
  fac' := λ s j,
  begin
    ext i,
    exact (P i).fac (cocone_comp_eval s i) j,
  end,
  uniq' := λ s m w,
  begin
    ext i,
    exact (P i).uniq (cocone_comp_eval s i) (m i) (λ j, congr_fun (w j) i)
  end }

section

variables [∀ i, has_limit (F ⋙ pi.eval C i)]

/--
If we have a functor `F : J ⥤ Π i, C i` into a category of indexed families,
and we have limits for each of the `F ⋙ pi.eval C i`,
then `F` has a limit.
-/
lemma has_limit_of_has_limit_comp_eval : has_limit F :=
has_limit.mk
{ cone := cone_of_cone_comp_eval (λ i, limit.cone _),
  is_limit := cone_of_cone_eval_is_limit (λ i, limit.is_limit _), }

end

section

variables [∀ i, has_colimit (F ⋙ pi.eval C i)]

/--
If we have a functor `F : J ⥤ Π i, C i` into a category of indexed families,
and colimits exist for each of the `F ⋙ pi.eval C i`,
there is a colimit for `F`.
-/
lemma has_colimit_of_has_colimit_comp_eval : has_colimit F :=
has_colimit.mk
{ cocone := cocone_of_cocone_comp_eval (λ i, colimit.cocone _),
  is_colimit := cocone_of_cocone_eval_is_colimit (λ i, colimit.is_colimit _), }

end

/-!
As an example, we can use this to construct particular shapes of limits
in a category of indexed families.

With the addition of
`import category_theory.limits.shapes.types`
we can use:
```
local attribute [instance] has_limit_of_has_limit_comp_eval
example : has_binary_products (I → Type v₁) := ⟨by apply_instance⟩
```
-/

end category_theory.pi


/-
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 control.equiv_functor
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Equiv.Defs

/-!
# Functions functorial with respect to equivalences

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

An `equiv_functor` is a function from `Type → Type` equipped with the additional data of
coherently mapping equivalences to equivalences.

In categorical language, it is an endofunctor of the "core" of the category `Type`.
-/

universe u₀ u₁ u₂ v₀ v₁ v₂

open Function

#print EquivFunctor /-
/-- An `equiv_functor` is only functorial with respect to equivalences.

To construct an `equiv_functor`, it suffices to supply just the function `f α → f β` from
an equivalence `α ≃ β`, and then prove the functor laws. It's then a consequence that
this function is part of an equivalence, provided by `equiv_functor.map_equiv`.
-/
class EquivFunctor (f : Type u₀ → Type u₁) where
  map : ∀ {α β}, α ≃ β → f α → f β
  map_refl' : ∀ α, map (Equiv.refl α) = @id (f α) := by obviously
  map_trans' : ∀ {α β γ} (k : α ≃ β) (h : β ≃ γ), map (k.trans h) = map h ∘ map k := by obviously
#align equiv_functor EquivFunctor
-/

restate_axiom EquivFunctor.map_refl'

restate_axiom EquivFunctor.map_trans'

attribute [simp] EquivFunctor.map_refl

namespace EquivFunctor

section

variable (f : Type u₀ → Type u₁) [EquivFunctor f] {α β : Type u₀} (e : α ≃ β)

#print EquivFunctor.mapEquiv /-
/-- An `equiv_functor` in fact takes every equiv to an equiv. -/
def mapEquiv : f α ≃ f β where
  toFun := EquivFunctor.map e
  invFun := EquivFunctor.map e.symm
  left_inv x := by
    convert(congr_fun (EquivFunctor.map_trans e e.symm) x).symm
    simp
  right_inv y := by
    convert(congr_fun (EquivFunctor.map_trans e.symm e) y).symm
    simp
#align equiv_functor.map_equiv EquivFunctor.mapEquiv
-/

#print EquivFunctor.mapEquiv_apply /-
@[simp]
theorem mapEquiv_apply (x : f α) : mapEquiv f e x = EquivFunctor.map e x :=
  rfl
#align equiv_functor.map_equiv_apply EquivFunctor.mapEquiv_apply
-/

#print EquivFunctor.mapEquiv_symm_apply /-
theorem mapEquiv_symm_apply (y : f β) : (mapEquiv f e).symm y = EquivFunctor.map e.symm y :=
  rfl
#align equiv_functor.map_equiv_symm_apply EquivFunctor.mapEquiv_symm_apply
-/

#print EquivFunctor.mapEquiv_refl /-
@[simp]
theorem mapEquiv_refl (α) : mapEquiv f (Equiv.refl α) = Equiv.refl (f α) := by
  simpa [EquivFunctor.mapEquiv]
#align equiv_functor.map_equiv_refl EquivFunctor.mapEquiv_refl
-/

#print EquivFunctor.mapEquiv_symm /-
@[simp]
theorem mapEquiv_symm : (mapEquiv f e).symm = mapEquiv f e.symm :=
  Equiv.ext <| mapEquiv_symm_apply f e
#align equiv_functor.map_equiv_symm EquivFunctor.mapEquiv_symm
-/

#print EquivFunctor.mapEquiv_trans /-
/-- The composition of `map_equiv`s is carried over the `equiv_functor`.
For plain `functor`s, this lemma is named `map_map` when applied
or `map_comp_map` when not applied.
-/
@[simp]
theorem mapEquiv_trans {γ : Type u₀} (ab : α ≃ β) (bc : β ≃ γ) :
    (mapEquiv f ab).trans (mapEquiv f bc) = mapEquiv f (ab.trans bc) :=
  Equiv.ext fun x => by simp [map_equiv, map_trans']
#align equiv_functor.map_equiv_trans EquivFunctor.mapEquiv_trans
-/

end

#print EquivFunctor.ofLawfulFunctor /-
instance (priority := 100) ofLawfulFunctor (f : Type u₀ → Type u₁) [Functor f] [LawfulFunctor f] :
    EquivFunctor f where
  map α β e := Functor.map e
  map_refl' α := by
    ext
    apply LawfulFunctor.id_map
  map_trans' α β γ k h := by
    ext x
    apply LawfulFunctor.comp_map k h x
#align equiv_functor.of_is_lawful_functor EquivFunctor.ofLawfulFunctor
-/

#print EquivFunctor.mapEquiv.injective /-
theorem mapEquiv.injective (f : Type u₀ → Type u₁) [Applicative f] [LawfulApplicative f]
    {α β : Type u₀} (h : ∀ γ, Function.Injective (pure : γ → f γ)) :
    Function.Injective (@EquivFunctor.mapEquiv f _ α β) := fun e₁ e₂ H =>
  Equiv.ext fun x => h β (by simpa [EquivFunctor.map] using Equiv.congr_fun H (pure x))
#align equiv_functor.map_equiv.injective EquivFunctor.mapEquiv.injective
-/

end EquivFunctor


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.shapes.kernels
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.shapes.zero

/-!
# Preserving (co)kernels

Constructions to relate the notions of preserving (co)kernels and reflecting (co)kernels
to concrete (co)forks.

In particular, we show that `kernel_comparison f g G` is an isomorphism iff `G` preserves
the limit of the parallel pair `f,0`, as well as the dual result.
-/

noncomputable theory

universes v u₁ u₂

open category_theory category_theory.category category_theory.limits

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

namespace category_theory.limits

section kernels
variables {X Y Z : C} {f : X ⟶ Y} {h : Z ⟶ X} (w : h ≫ f = 0)

/--
The map of a kernel fork is a limit iff
the kernel fork consisting of the mapped morphisms is a limit.
This essentially lets us commute `kernel_fork.of_ι` with `functor.map_cone`.

This is a variant of `is_limit_map_cone_fork_equiv` for equalizers,
which we can't use directly between `G.map 0 = 0` does not hold definitionally.
-/
def is_limit_map_cone_fork_equiv' :
  is_limit (G.map_cone (kernel_fork.of_ι h w)) ≃
  is_limit (kernel_fork.of_ι (G.map h) (by simp only [←G.map_comp, w, functor.map_zero])
    : fork (G.map f) 0) :=
begin
  refine (is_limit.postcompose_hom_equiv _ _).symm.trans (is_limit.equiv_iso_limit _),
  refine parallel_pair.ext (iso.refl _) (iso.refl _) _ _; simp,
  refine fork.ext (iso.refl _) _,
  simp,
end

/--
The property of preserving kernels expressed in terms of kernel forks.

This is a variant of `is_limit_fork_map_of_is_limit` for equalizers,
which we can't use directly between `G.map 0 = 0` does not hold definitionally.
-/
def is_limit_fork_map_of_is_limit' [preserves_limit (parallel_pair f 0) G]
  (l : is_limit (kernel_fork.of_ι h w)) :
  is_limit (kernel_fork.of_ι (G.map h) (by simp only [←G.map_comp, w, functor.map_zero]) :
    fork (G.map f) 0) :=
is_limit_map_cone_fork_equiv' G w (preserves_limit.preserves l)

variables (f) [has_kernel f]

/--
If `G` preserves kernels and `C` has them, then the fork constructed of the mapped morphisms of
a kernel fork is a limit.
-/
def is_limit_of_has_kernel_of_preserves_limit [preserves_limit (parallel_pair f 0) G] :
  is_limit (fork.of_ι (G.map (kernel.ι f))
    (by simp only [←G.map_comp, equalizer.condition, comp_zero, functor.map_zero])
      : fork (G.map f) 0) :=
is_limit_fork_map_of_is_limit' G (kernel.condition f) (kernel_is_kernel f)

instance [preserves_limit (parallel_pair f 0) G] : has_kernel (G.map f) :=
{ exists_limit := ⟨⟨_, is_limit_of_has_kernel_of_preserves_limit G f⟩⟩, }

variables [has_kernel (G.map f)]

/--
If the kernel comparison map for `G` at `f` is an isomorphism, then `G` preserves the
kernel of `f`.
-/
def preserves_kernel.of_iso_comparison [i : is_iso (kernel_comparison f G)] :
  preserves_limit (parallel_pair f 0) G :=
begin
  apply preserves_limit_of_preserves_limit_cone (kernel_is_kernel f),
  apply (is_limit_map_cone_fork_equiv' G (kernel.condition f)).symm _,
  apply is_limit.of_point_iso (limit.is_limit (parallel_pair (G.map f) 0)),
  apply i,
end

variables [preserves_limit (parallel_pair f 0) G]
/--
If `G` preserves the kernel of `f`, then the kernel comparison map for `G` at `f` is
an isomorphism.
-/
def preserves_kernel.iso :
  G.obj (kernel f) ≅ kernel (G.map f) :=
is_limit.cone_point_unique_up_to_iso
  (is_limit_of_has_kernel_of_preserves_limit G f)
  (limit.is_limit _)

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

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

end kernels

section cokernels

variables {X Y Z : C} {f : X ⟶ Y} {h : Y ⟶ Z} (w : f ≫ h = 0)

/--
The map of a cokernel cofork is a colimit iff
the cokernel cofork consisting of the mapped morphisms is a colimit.
This essentially lets us commute `cokernel_cofork.of_π` with `functor.map_cocone`.

This is a variant of `is_colimit_map_cocone_cofork_equiv` for equalizers,
which we can't use directly between `G.map 0 = 0` does not hold definitionally.
-/
def is_colimit_map_cocone_cofork_equiv' :
  is_colimit (G.map_cocone (cokernel_cofork.of_π h w)) ≃
  is_colimit (cokernel_cofork.of_π (G.map h) (by simp only [←G.map_comp, w, functor.map_zero])
    : cofork (G.map f) 0) :=
begin
  refine (is_colimit.precompose_hom_equiv _ _).symm.trans (is_colimit.equiv_iso_colimit _),
  refine parallel_pair.ext (iso.refl _) (iso.refl _) _ _; simp,
  refine cofork.ext (iso.refl _) _,
  simp, dsimp, simp,
end

/--
The property of preserving cokernels expressed in terms of cokernel coforks.

This is a variant of `is_colimit_cofork_map_of_is_colimit` for equalizers,
which we can't use directly between `G.map 0 = 0` does not hold definitionally.
-/
def is_colimit_cofork_map_of_is_colimit' [preserves_colimit (parallel_pair f 0) G]
  (l : is_colimit (cokernel_cofork.of_π h w)) :
  is_colimit (cokernel_cofork.of_π (G.map h) (by simp only [←G.map_comp, w, functor.map_zero]) :
    cofork (G.map f) 0) :=
is_colimit_map_cocone_cofork_equiv' G w (preserves_colimit.preserves l)

variables (f) [has_cokernel f]

/--
If `G` preserves cokernels and `C` has them, then the cofork constructed of the mapped morphisms of
a cokernel cofork is a colimit.
-/
def is_colimit_of_has_cokernel_of_preserves_colimit [preserves_colimit (parallel_pair f 0) G] :
  is_colimit (cofork.of_π (G.map (cokernel.π f))
    (by simp only [←G.map_comp, coequalizer.condition, zero_comp, functor.map_zero])
      : cofork (G.map f) 0) :=
is_colimit_cofork_map_of_is_colimit' G (cokernel.condition f) (cokernel_is_cokernel f)

instance [preserves_colimit (parallel_pair f 0) G] : has_cokernel (G.map f) :=
{ exists_colimit := ⟨⟨_, is_colimit_of_has_cokernel_of_preserves_colimit G f⟩⟩, }

variables [has_cokernel (G.map f)]

/--
If the cokernel comparison map for `G` at `f` is an isomorphism, then `G` preserves the
cokernel of `f`.
-/
def preserves_cokernel.of_iso_comparison [i : is_iso (cokernel_comparison f G)] :
  preserves_colimit (parallel_pair f 0) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone (cokernel_is_cokernel f),
  apply (is_colimit_map_cocone_cofork_equiv' G (cokernel.condition f)).symm _,
  apply is_colimit.of_point_iso (colimit.is_colimit (parallel_pair (G.map f) 0)),
  apply i,
end

variables [preserves_colimit (parallel_pair f 0) G]
/--
If `G` preserves the cokernel of `f`, then the cokernel comparison map for `G` at `f` is
an isomorphism.
-/
def preserves_cokernel.iso :
  G.obj (cokernel f) ≅ cokernel (G.map f) :=
is_colimit.cocone_point_unique_up_to_iso
  (is_colimit_of_has_cokernel_of_preserves_colimit G f)
  (colimit.is_colimit _)

@[simp]
lemma preserves_cokernel.iso_hom :
  (preserves_cokernel.iso G f).inv = cokernel_comparison f G :=
rfl

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

end cokernels

end category_theory.limits


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

import category_theory.limits.constructions.pullbacks
import category_theory.limits.shapes.biproducts
import category_theory.limits.shapes.images
import category_theory.abelian.non_preadditive

/-!
# Abelian categories

This file contains the definition and basic properties of abelian categories.

There are many definitions of abelian category. Our definition is as follows:
A category is called abelian if it is preadditive,
has a finite products, kernels and cokernels,
and if every monomorphism and epimorphism is normal.

It should be noted that if we also assume coproducts, then preadditivity is
actually a consequence of the other properties, as we show in
`non_preadditive_abelian.lean`. However, this fact is of little practical
relevance, since essentially all interesting abelian categories come with a
preadditive structure. In this way, by requiring preadditivity, we allow the
user to pass in the preadditive structure the specific category they are
working with has natively.

## Main definitions

* `abelian` is the type class indicating that a category is abelian. It extends `preadditive`.
* `abelian.image f` is `kernel (cokernel.π f)`, and
* `abelian.coimage f` is `cokernel (kernel.ι f)`.

## Main results

* In an abelian category, mono + epi = iso.
* If `f : X ⟶ Y`, then the map `factor_thru_image f : X ⟶ image f` is an epimorphism, and the map
  `factor_thru_coimage f : coimage f ⟶ Y` is a monomorphism.
* Factoring through the image and coimage is a strong epi-mono factorisation. This means that
  * every abelian category has images. We instantiated this in such a way that `abelian.image f` is
    definitionally equal to `limits.image f`, and
  * there is a canonical isomorphism `coimage_iso_image : coimage f ≅ image f` such that
    `coimage.π f ≫ (coimage_iso_image f).hom ≫ image.ι f = f`. The lemma stating this is called
    `full_image_factorisation`.
* Every epimorphism is a cokernel of its kernel. Every monomorphism is a kernel of its cokernel.
* The pullback of an epimorphism is an epimorphism. The pushout of a monomorphism is a monomorphism.
  (This is not to be confused with the fact that the pullback of a monomorphism is a monomorphism,
  which is true in any category).

## Implementation notes

The typeclass `abelian` does not extend `non_preadditive_abelian`,
to avoid having to deal with comparing the two `has_zero_morphisms` instances
(one from `preadditive` in `abelian`, and the other a field of `non_preadditive_abelian`).
As a consequence, at the beginning of this file we trivially build
a `non_preadditive_abelian` instance from an `abelian` instance,
and use this to restate a number of theorems,
in each case just reusing the proof from `non_preadditive_abelian.lean`.

We don't show this yet, but abelian categories are finitely complete and finitely cocomplete.
However, the limits we can construct at this level of generality will most likely be less nice than
the ones that can be created in specific applications. For this reason, we adopt the following
convention:

* If the statement of a theorem involves limits, the existence of these limits should be made an
  explicit typeclass parameter.
* If a limit only appears in a proof, but not in the statement of a theorem, the limit should not
  be a typeclass parameter, but instead be created using `abelian.has_pullbacks` or a similar
  definition.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
* [P. Aluffi, *Algebra: Chaper 0*][aluffi2016]

-/

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v u

namespace category_theory

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

variables (C)

/--
A (preadditive) category `C` is called abelian if it has all finite products,
all kernels and cokernels, and if every monomorphism is the kernel of some morphism
and every epimorphism is the cokernel of some morphism.

(This definition implies the existence of zero objects:
finite products give a terminal object, and in a preadditive category
any terminal object is a zero object.)
-/
class abelian extends preadditive C :=
[has_finite_products : has_finite_products C]
[has_kernels : has_kernels C]
[has_cokernels : has_cokernels C]
(normal_mono : Π {X Y : C} (f : X ⟶ Y) [mono f], normal_mono f)
(normal_epi : Π {X Y : C} (f : X ⟶ Y) [epi f], normal_epi f)

attribute [instance, priority 100] abelian.has_finite_products
attribute [instance, priority 100] abelian.has_kernels abelian.has_cokernels

end category_theory

open category_theory

namespace category_theory.abelian
variables {C : Type u} [category.{v} C] [abelian C]

/-- An abelian category has finite biproducts. -/
@[priority 100]
instance has_finite_biproducts : has_finite_biproducts C :=
limits.has_finite_biproducts.of_has_finite_products

@[priority 100]
instance has_binary_biproducts : has_binary_biproducts C :=
limits.has_binary_biproducts_of_finite_biproducts _

section to_non_preadditive_abelian

/-- Every abelian category is, in particular, `non_preadditive_abelian`. -/
def non_preadditive_abelian : non_preadditive_abelian C := { ..‹abelian C› }

end to_non_preadditive_abelian

section strong
local attribute [instance] abelian.normal_epi

/-- In an abelian category, every epimorphism is strong. -/
lemma strong_epi_of_epi {P Q : C} (f : P ⟶ Q) [epi f] : strong_epi f := by apply_instance

end strong

section mono_epi_iso
variables {X Y : C} (f : X ⟶ Y)

local attribute [instance] strong_epi_of_epi

/-- In an abelian category, a monomorphism which is also an epimorphism is an isomorphism. -/
lemma is_iso_of_mono_of_epi [mono f] [epi f] : is_iso f :=
is_iso_of_mono_of_strong_epi _

end mono_epi_iso

section factor
local attribute [instance] non_preadditive_abelian

variables {P Q : C} (f : P ⟶ Q)

section

lemma mono_of_zero_kernel (R : C)
  (l : is_limit (kernel_fork.of_ι (0 : R ⟶ P) (show 0 ≫ f = 0, by simp))) : mono f :=
non_preadditive_abelian.mono_of_zero_kernel _ _ l

lemma mono_of_kernel_ι_eq_zero (h : kernel.ι f = 0) : mono f :=
mono_of_kernel_zero h

lemma epi_of_zero_cokernel (R : C)
  (l : is_colimit (cokernel_cofork.of_π (0 : Q ⟶ R) (show f ≫ 0 = 0, by simp))) : epi f :=
non_preadditive_abelian.epi_of_zero_cokernel _ _ l

lemma epi_of_cokernel_π_eq_zero (h : cokernel.π f = 0) : epi f :=
begin
  apply epi_of_zero_cokernel _ (cokernel f),
  simp_rw ←h,
  exact is_colimit.of_iso_colimit (colimit.is_colimit (parallel_pair f 0)) (iso_of_π _)
end

end

namespace images

/-- The kernel of the cokernel of `f` is called the image of `f`. -/
protected abbreviation image : C := kernel (cokernel.π f)

/-- The inclusion of the image into the codomain. -/
protected abbreviation image.ι : images.image f ⟶ Q :=
kernel.ι (cokernel.π f)

/-- There is a canonical epimorphism `p : P ⟶ image f` for every `f`. -/
protected abbreviation factor_thru_image : P ⟶ images.image f :=
kernel.lift (cokernel.π f) f $ cokernel.condition f

/-- `f` factors through its image via the canonical morphism `p`. -/
@[simp, reassoc] protected lemma image.fac :
  images.factor_thru_image f ≫ image.ι f = f :=
kernel.lift_ι _ _ _

/-- The map `p : P ⟶ image f` is an epimorphism -/
instance : epi (images.factor_thru_image f) :=
show epi (non_preadditive_abelian.factor_thru_image f), by apply_instance

section
variables {f}

lemma image_ι_comp_eq_zero {R : C} {g : Q ⟶ R} (h : f ≫ g = 0) : images.image.ι f ≫ g = 0 :=
zero_of_epi_comp (images.factor_thru_image f) $ by simp [h]

end

instance mono_factor_thru_image [mono f] : mono (images.factor_thru_image f) :=
mono_of_mono_fac $ image.fac f

instance is_iso_factor_thru_image [mono f] : is_iso (images.factor_thru_image f) :=
is_iso_of_mono_of_epi _

/-- Factoring through the image is a strong epi-mono factorisation. -/
@[simps] def image_strong_epi_mono_factorisation : strong_epi_mono_factorisation f :=
{ I := images.image f,
  m := image.ι f,
  m_mono := by apply_instance,
  e := images.factor_thru_image f,
  e_strong_epi := strong_epi_of_epi _ }

end images

namespace coimages

/-- The cokernel of the kernel of `f` is called the coimage of `f`. -/
protected abbreviation coimage : C := cokernel (kernel.ι f)

/-- The projection onto the coimage. -/
protected abbreviation coimage.π : P ⟶ coimages.coimage f :=
cokernel.π (kernel.ι f)

/-- There is a canonical monomorphism `i : coimage f ⟶ Q`. -/
protected abbreviation factor_thru_coimage : coimages.coimage f ⟶ Q :=
cokernel.desc (kernel.ι f) f $ kernel.condition f

/-- `f` factors through its coimage via the canonical morphism `p`. -/
protected lemma coimage.fac : coimage.π f ≫ coimages.factor_thru_coimage f = f :=
cokernel.π_desc _ _ _

/-- The canonical morphism `i : coimage f ⟶ Q` is a monomorphism -/
instance : mono (coimages.factor_thru_coimage f) :=
show mono (non_preadditive_abelian.factor_thru_coimage f), by apply_instance

instance epi_factor_thru_coimage [epi f] : epi (coimages.factor_thru_coimage f) :=
epi_of_epi_fac $ coimage.fac f

instance is_iso_factor_thru_coimage [epi f] : is_iso (coimages.factor_thru_coimage f) :=
is_iso_of_mono_of_epi _

/-- Factoring through the coimage is a strong epi-mono factorisation. -/
@[simps] def coimage_strong_epi_mono_factorisation : strong_epi_mono_factorisation f :=
{ I := coimages.coimage f,
  m := coimages.factor_thru_coimage f,
  m_mono := by apply_instance,
  e := coimage.π f,
  e_strong_epi := strong_epi_of_epi _ }

end coimages

end factor

section has_strong_epi_mono_factorisations

/-- An abelian category has strong epi-mono factorisations. -/
@[priority 100] instance : has_strong_epi_mono_factorisations C :=
has_strong_epi_mono_factorisations.mk $ λ X Y f, images.image_strong_epi_mono_factorisation f

/- In particular, this means that it has well-behaved images. -/
example : has_images C := by apply_instance
example : has_image_maps C := by apply_instance

end has_strong_epi_mono_factorisations

section images
variables {X Y : C} (f : X ⟶ Y)

/-- There is a canonical isomorphism between the coimage and the image of a morphism. -/
abbreviation coimage_iso_image : coimages.coimage f ≅ images.image f :=
is_image.iso_ext (coimages.coimage_strong_epi_mono_factorisation f).to_mono_is_image
  (images.image_strong_epi_mono_factorisation f).to_mono_is_image

/-- There is a canonical isomorphism between the abelian image and the categorical image of a
    morphism. -/
abbreviation image_iso_image : images.image f ≅ image f :=
is_image.iso_ext (images.image_strong_epi_mono_factorisation f).to_mono_is_image (image.is_image f)

/-- There is a canonical isomorphism between the abelian coimage and the categorical image of a
    morphism. -/
abbreviation coimage_iso_image' : coimages.coimage f ≅ image f :=
is_image.iso_ext (coimages.coimage_strong_epi_mono_factorisation f).to_mono_is_image
  (image.is_image f)

lemma full_image_factorisation : coimages.coimage.π f ≫ (coimage_iso_image f).hom ≫
  images.image.ι f = f :=
by rw [limits.is_image.iso_ext_hom,
  ←images.image_strong_epi_mono_factorisation_to_mono_factorisation_m, is_image.lift_fac,
  coimages.coimage_strong_epi_mono_factorisation_to_mono_factorisation_m, coimages.coimage.fac]

end images

section cokernel_of_kernel
variables {X Y : C} {f : X ⟶ Y}

local attribute [instance] non_preadditive_abelian

/-- In an abelian category, an epi is the cokernel of its kernel. More precisely:
    If `f` is an epimorphism and `s` is some limit kernel cone on `f`, then `f` is a cokernel
    of `fork.ι s`. -/
def epi_is_cokernel_of_kernel [epi f] (s : fork f 0) (h : is_limit s) :
  is_colimit (cokernel_cofork.of_π f (kernel_fork.condition s)) :=
non_preadditive_abelian.epi_is_cokernel_of_kernel s h

/-- In an abelian category, a mono is the kernel of its cokernel. More precisely:
    If `f` is a monomorphism and `s` is some colimit cokernel cocone on `f`, then `f` is a kernel
    of `cofork.π s`. -/
def mono_is_kernel_of_cokernel [mono f] (s : cofork f 0) (h : is_colimit s) :
  is_limit (kernel_fork.of_ι f (cokernel_cofork.condition s)) :=
non_preadditive_abelian.mono_is_kernel_of_cokernel s h

end cokernel_of_kernel

section

@[priority 100]
instance has_equalizers : has_equalizers C :=
preadditive.has_equalizers_of_has_kernels

/-- Any abelian category has pullbacks -/
@[priority 100]
instance has_pullbacks : has_pullbacks C :=
has_pullbacks_of_has_binary_products_of_has_equalizers C

end

section

@[priority 100]
instance has_coequalizers : has_coequalizers C :=
preadditive.has_coequalizers_of_has_cokernels

/-- Any abelian category has pushouts -/
@[priority 100]
instance has_pushouts : has_pushouts C :=
has_pushouts_of_has_binary_coproducts_of_has_coequalizers C

end

namespace pullback_to_biproduct_is_kernel
variables [limits.has_pullbacks C] {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-! This section contains a slightly technical result about pullbacks and biproducts.
    We will need it in the proof that the pullback of an epimorphism is an epimorpism. -/

/-- The canonical map `pullback f g ⟶ X ⊞ Y` -/
abbreviation pullback_to_biproduct : pullback f g ⟶ X ⊞ Y :=
biprod.lift pullback.fst pullback.snd

/-- The canonical map `pullback f g ⟶ X ⊞ Y` induces a kernel cone on the map
    `biproduct X Y ⟶ Z` induced by `f` and `g`. A slightly more intuitive way to think of
    this may be that it induces an equalizer fork on the maps induced by `(f, 0)` and
    `(0, g)`. -/
abbreviation pullback_to_biproduct_fork : kernel_fork (biprod.desc f (-g)) :=
kernel_fork.of_ι (pullback_to_biproduct f g) $
by rw [biprod.lift_desc, comp_neg, pullback.condition, add_right_neg]

/-- The canonical map `pullback f g ⟶ X ⊞ Y` is a kernel of the map induced by
    `(f, -g)`. -/
def is_limit_pullback_to_biproduct : is_limit (pullback_to_biproduct_fork f g) :=
fork.is_limit.mk _
  (λ s, pullback.lift (fork.ι s ≫ biprod.fst) (fork.ι s ≫ biprod.snd) $
    sub_eq_zero.1 $ by rw [category.assoc, category.assoc, ←comp_sub, sub_eq_add_neg, ←comp_neg,
      ←biprod.desc_eq, kernel_fork.condition s])
  (λ s,
  begin
    ext; rw [fork.ι_of_ι, category.assoc],
    { rw [biprod.lift_fst, pullback.lift_fst] },
    { rw [biprod.lift_snd, pullback.lift_snd] }
  end)
  (λ s m h, by ext; simp [fork.ι_eq_app_zero, ←h walking_parallel_pair.zero])

end pullback_to_biproduct_is_kernel

namespace biproduct_to_pushout_is_cokernel
variables [limits.has_pushouts C] {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` -/
abbreviation biproduct_to_pushout : Y ⊞ Z ⟶ pushout f g :=
biprod.desc pushout.inl pushout.inr

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` induces a cokernel cofork on the map
    `X ⟶ Y ⊞ Z` induced by `f` and `-g`. -/
abbreviation biproduct_to_pushout_cofork : cokernel_cofork (biprod.lift f (-g)) :=
cokernel_cofork.of_π (biproduct_to_pushout f g) $
by rw [biprod.lift_desc, neg_comp, pushout.condition, add_right_neg]

/-- The cofork induced by the canonical map `Y ⊞ Z ⟶ pushout f g` is in fact a colimit cokernel
    cofork. -/
def is_colimit_biproduct_to_pushout : is_colimit (biproduct_to_pushout_cofork f g) :=
cofork.is_colimit.mk _
  (λ s, pushout.desc (biprod.inl ≫ cofork.π s) (biprod.inr ≫ cofork.π s) $
    sub_eq_zero.1 $ by rw [←category.assoc, ←category.assoc, ←sub_comp, sub_eq_add_neg, ←neg_comp,
      ←biprod.lift_eq, cofork.condition s, zero_comp])
  (λ s, by ext; simp)
  (λ s m h, by ext; simp [cofork.π_eq_app_one, ←h walking_parallel_pair.one] )

end biproduct_to_pushout_is_cokernel

section epi_pullback
variables [limits.has_pullbacks C] {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-- In an abelian category, the pullback of an epimorphism is an epimorphism.
    Proof from [aluffi2016, IX.2.3], cf. [borceux-vol2, 1.7.6] -/
instance epi_pullback_of_epi_f [epi f] : epi (pullback.snd : pullback f g ⟶ Y) :=
-- It will suffice to consider some morphism e : Y ⟶ R such that
-- pullback.snd ≫ e = 0 and show that e = 0.
epi_of_cancel_zero _ $ λ R e h,
begin
  -- Consider the morphism u := (0, e) : X ⊞ Y⟶ R.
  let u := biprod.desc (0 : X ⟶ R) e,
  -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
  have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa,
  -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
  -- cokernel of pullback_to_biproduct f g
  have := epi_is_cokernel_of_kernel _
    (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g),
  -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
  obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu,
  change Z ⟶ R at d,
  change biprod.desc f (-g) ≫ d = u at hd,
  -- But then f ≫ d = 0:
  have : f ≫ d = 0, calc
    f ≫ d = (biprod.inl ≫ biprod.desc f (-g)) ≫ d : by rw biprod.inl_desc
    ... = biprod.inl ≫ u : by rw [category.assoc, hd]
    ... = 0 : biprod.inl_desc _ _,
  -- But f is an epimorphism, so d = 0...
  have : d = 0 := (cancel_epi f).1 (by simpa),
  -- ...or, in other words, e = 0.
  calc
    e = biprod.inr ≫ u : by rw biprod.inr_desc
    ... = biprod.inr ≫ biprod.desc f (-g) ≫ d : by rw ←hd
    ... = biprod.inr ≫ biprod.desc f (-g) ≫ 0 : by rw this
    ... = (biprod.inr ≫ biprod.desc f (-g)) ≫ 0 : by rw ←category.assoc
    ... = 0 : has_zero_morphisms.comp_zero _ _
end

/-- In an abelian category, the pullback of an epimorphism is an epimorphism. -/
instance epi_pullback_of_epi_g [epi g] : epi (pullback.fst : pullback f g ⟶ X) :=
-- It will suffice to consider some morphism e : X ⟶ R such that
-- pullback.fst ≫ e = 0 and show that e = 0.
epi_of_cancel_zero _ $ λ R e h,
begin
  -- Consider the morphism u := (e, 0) : X ⊞ Y ⟶ R.
  let u := biprod.desc e (0 : Y ⟶ R),
  -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
  have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa,
  -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
  -- cokernel of pullback_to_biproduct f g
  have := epi_is_cokernel_of_kernel _
    (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g),
  -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
  obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu,
  change Z ⟶ R at d,
  change biprod.desc f (-g) ≫ d = u at hd,
  -- But then (-g) ≫ d = 0:
  have : (-g) ≫ d = 0, calc
    (-g) ≫ d = (biprod.inr ≫ biprod.desc f (-g)) ≫ d : by rw biprod.inr_desc
    ... = biprod.inr ≫ u : by rw [category.assoc, hd]
    ... = 0 : biprod.inr_desc _ _,
  -- But g is an epimorphism, thus so is -g, so d = 0...
  have : d = 0 := (cancel_epi (-g)).1 (by simpa),
  -- ...or, in other words, e = 0.
  calc
    e = biprod.inl ≫ u : by rw biprod.inl_desc
    ... = biprod.inl ≫ biprod.desc f (-g) ≫ d : by rw ←hd
    ... = biprod.inl ≫ biprod.desc f (-g) ≫ 0 : by rw this
    ... = (biprod.inl ≫ biprod.desc f (-g)) ≫ 0 : by rw ←category.assoc
    ... = 0 : has_zero_morphisms.comp_zero _ _
end

end epi_pullback

section mono_pushout
variables [limits.has_pushouts C] {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

instance mono_pushout_of_mono_f [mono f] : mono (pushout.inr : Z ⟶ pushout f g) :=
mono_of_cancel_zero _ $ λ R e h,
begin
  let u := biprod.lift (0 : R ⟶ Y) e,
  have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa,
  have := mono_is_kernel_of_cokernel _
    (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g),
  obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu,
  change R ⟶ X at d,
  change d ≫ biprod.lift f (-g) = u at hd,
  have : d ≫ f = 0, calc
    d ≫ f = d ≫ biprod.lift f (-g) ≫ biprod.fst : by rw biprod.lift_fst
    ... = u ≫ biprod.fst : by rw [←category.assoc, hd]
    ... = 0 : biprod.lift_fst _ _,
  have : d = 0 := (cancel_mono f).1 (by simpa),
  calc
    e = u ≫ biprod.snd : by rw biprod.lift_snd
    ... = (d ≫ biprod.lift f (-g)) ≫ biprod.snd : by rw ←hd
    ... = (0 ≫ biprod.lift f (-g)) ≫ biprod.snd : by rw this
    ... = 0 ≫ biprod.lift f (-g) ≫ biprod.snd : by rw category.assoc
    ... = 0 : zero_comp
end

instance mono_pushout_of_mono_g [mono g] : mono (pushout.inl : Y ⟶ pushout f g) :=
mono_of_cancel_zero _ $ λ R e h,
begin
  let u := biprod.lift e (0 : R ⟶ Z),
  have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa,
  have := mono_is_kernel_of_cokernel _
    (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g),
  obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu,
  change R ⟶ X at d,
  change d ≫ biprod.lift f (-g) = u at hd,
  have : d ≫ (-g) = 0, calc
    d ≫ (-g) = d ≫ biprod.lift f (-g) ≫ biprod.snd : by rw biprod.lift_snd
    ... = u ≫ biprod.snd : by rw [←category.assoc, hd]
    ... = 0 : biprod.lift_snd _ _,
  have : d = 0 := (cancel_mono (-g)).1 (by simpa),
  calc
    e = u ≫ biprod.fst : by rw biprod.lift_fst
    ... = (d ≫ biprod.lift f (-g)) ≫ biprod.fst : by rw ←hd
    ... = (0 ≫ biprod.lift f (-g)) ≫ biprod.fst : by rw this
    ... = 0 ≫ biprod.lift f (-g) ≫ biprod.fst : by rw category.assoc
    ... = 0 : zero_comp
end

end mono_pushout

end category_theory.abelian

namespace category_theory.non_preadditive_abelian

variables (C : Type u) [category.{v} C] [non_preadditive_abelian C]

/-- Every non_preadditive_abelian category can be promoted to an abelian category. -/
def abelian : abelian C :=
{ has_finite_products := by apply_instance,
/- We need the `convert`s here because the instances we have are slightly different from the
   instances we need: `has_kernels` depends on an instance of `has_zero_morphisms`. In the
   case of `non_preadditive_abelian`, this instance is an explicit argument. However, in the case
   of `abelian`, the `has_zero_morphisms` instance is derived from `preadditive`. So we need to
   transform an instance of "has kernels with non_preadditive_abelian.has_zero_morphisms" to an
   instance of "has kernels with non_preadditive_abelian.preadditive.has_zero_morphisms". Luckily,
   we have a `subsingleton` instance for `has_zero_morphisms`, so `convert` can immediately close
   the goal it creates for the two instances of `has_zero_morphisms`, and the proof is complete. -/
  has_kernels := by convert (by apply_instance : limits.has_kernels C),
  has_cokernels := by convert (by apply_instance : limits.has_cokernels C),
  normal_mono := by { introsI, convert normal_mono f },
  normal_epi := by { introsI, convert normal_epi f },
  ..non_preadditive_abelian.preadditive }

end category_theory.non_preadditive_abelian


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.nodup
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Finite products of types

This file defines the product of types over a list. For `l : list ι` and `α : ι → Type*` we define
`list.tprod α l = l.foldr (λ i β, α i × β) punit`.
This type should not be used if `Π i, α i` or `Π i ∈ l, α i` can be used instead
(in the last expression, we could also replace the list `l` by a set or a finset).
This type is used as an intermediary between binary products and finitary products.
The application of this type is finitary product measures, but it could be used in any
construction/theorem that is easier to define/prove on binary products than on finitary products.

* Once we have the construction on binary products (like binary product measures in
  `measure_theory.prod`), we can easily define a finitary version on the type `tprod l α`
  by iterating. Properties can also be easily extended from the binary case to the finitary case
  by iterating.
* Then we can use the equivalence `list.tprod.pi_equiv_tprod` below (or enhanced versions of it,
  like a `measurable_equiv` for product measures) to get the construction on `Π i : ι, α i`, at
  least when assuming `[fintype ι] [encodable ι]` (using `encodable.sorted_univ`).
  Using `local attribute [instance] fintype.encodable` we can get rid of the argument
  `[encodable ι]`.

## Main definitions

* We have the equivalence `tprod.pi_equiv_tprod : (Π i, α i) ≃ tprod α l`
  if `l` contains every element of `ι` exactly once.
* The product of sets is `set.tprod : (Π i, set (α i)) → set (tprod α l)`.
-/

namespace list

/-- The product of a family of types over a list. -/
def tprod {ι : Type u_1} (α : ι → Type u_2) (l : List ι) :=
  foldr (fun (i : ι) (β : Type (max u_2 u_3)) => α i × β) PUnit l

namespace tprod

/-- Turning a function `f : Π i, α i` into an element of the iterated product `tprod α l`. -/
protected def mk {ι : Type u_1} {α : ι → Type u_2} (l : List ι) (f : (i : ι) → α i) : tprod α l :=
  sorry

protected instance inhabited {ι : Type u_1} {α : ι → Type u_2} {l : List ι}
    [(i : ι) → Inhabited (α i)] : Inhabited (tprod α l) :=
  { default := tprod.mk l fun (i : ι) => Inhabited.default }

@[simp] theorem fst_mk {ι : Type u_1} {α : ι → Type u_2} (i : ι) (l : List ι) (f : (i : ι) → α i) :
    prod.fst (tprod.mk (i :: l) f) = f i :=
  rfl

@[simp] theorem snd_mk {ι : Type u_1} {α : ι → Type u_2} (i : ι) (l : List ι) (f : (i : ι) → α i) :
    prod.snd (tprod.mk (i :: l) f) = tprod.mk l f :=
  rfl

/-- Given an element of the iterated product `l.prod α`, take a projection into direction `i`.
  If `i` appears multiple times in `l`, this chooses the first component in direction `i`. -/
protected def elim {ι : Type u_1} {α : ι → Type u_2} [DecidableEq ι] {l : List ι} (v : tprod α l)
    {i : ι} (hi : i ∈ l) : α i :=
  sorry

@[simp] theorem elim_self {ι : Type u_1} {α : ι → Type u_2} {i : ι} {l : List ι} [DecidableEq ι]
    (v : tprod α (i :: l)) : tprod.elim v (mem_cons_self i l) = prod.fst v :=
  sorry

@[simp] theorem elim_of_ne {ι : Type u_1} {α : ι → Type u_2} {i : ι} {j : ι} {l : List ι}
    [DecidableEq ι] (hj : j ∈ i :: l) (hji : j ≠ i) (v : tprod α (i :: l)) :
    tprod.elim v hj = tprod.elim (prod.snd v) (or.resolve_left hj hji) :=
  sorry

@[simp] theorem elim_of_mem {ι : Type u_1} {α : ι → Type u_2} {i : ι} {j : ι} {l : List ι}
    [DecidableEq ι] (hl : nodup (i :: l)) (hj : j ∈ l) (v : tprod α (i :: l)) :
    tprod.elim v (mem_cons_of_mem i hj) = tprod.elim (prod.snd v) hj :=
  sorry

theorem elim_mk {ι : Type u_1} {α : ι → Type u_2} [DecidableEq ι] (l : List ι) (f : (i : ι) → α i)
    {i : ι} (hi : i ∈ l) : tprod.elim (tprod.mk l f) hi = f i :=
  sorry

theorem ext {ι : Type u_1} {α : ι → Type u_2} [DecidableEq ι] {l : List ι} (hl : nodup l)
    {v : tprod α l} {w : tprod α l}
    (hvw : ∀ (i : ι) (hi : i ∈ l), tprod.elim v hi = tprod.elim w hi) : v = w :=
  sorry

/-- A version of `tprod.elim` when `l` contains all elements. In this case we get a function into
  `Π i, α i`. -/
@[simp] protected def elim' {ι : Type u_1} {α : ι → Type u_2} {l : List ι} [DecidableEq ι]
    (h : ∀ (i : ι), i ∈ l) (v : tprod α l) (i : ι) : α i :=
  tprod.elim v (h i)

theorem mk_elim {ι : Type u_1} {α : ι → Type u_2} {l : List ι} [DecidableEq ι] (hnd : nodup l)
    (h : ∀ (i : ι), i ∈ l) (v : tprod α l) : tprod.mk l (tprod.elim' h v) = v :=
  sorry

/-- Pi-types are equivalent to iterated products. -/
def pi_equiv_tprod {ι : Type u_1} {α : ι → Type u_2} {l : List ι} [DecidableEq ι] (hnd : nodup l)
    (h : ∀ (i : ι), i ∈ l) : ((i : ι) → α i) ≃ tprod α l :=
  equiv.mk (tprod.mk l) (tprod.elim' h) sorry sorry

end tprod

end list

namespace set

/-- A product of sets in `tprod α l`. -/
@[simp] protected def tprod {ι : Type u_1} {α : ι → Type u_2} (l : List ι)
    (t : (i : ι) → set (α i)) : set (list.tprod α l) :=
  sorry

theorem mk_preimage_tprod {ι : Type u_1} {α : ι → Type u_2} (l : List ι) (t : (i : ι) → set (α i)) :
    list.tprod.mk l ⁻¹' set.tprod l t = pi (set_of fun (i : ι) => i ∈ l) t :=
  sorry

theorem elim_preimage_pi {ι : Type u_1} {α : ι → Type u_2} [DecidableEq ι] {l : List ι}
    (hnd : list.nodup l) (h : ∀ (i : ι), i ∈ l) (t : (i : ι) → set (α i)) :
    list.tprod.elim' h ⁻¹' pi univ t = set.tprod l t :=
  sorry

end Mathlib


import model_theory.substructures
import model_theory.bundled

--OUTPUT 1
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  let A : ℕ → L.formula := λ n, ∃ (x₁ : L.var) (x₂ : L.var) (x₃ : L.var) (x₄ : L.var) (x₅ : L.var) (x₆ : L.var) (x₇ : L.var) (x₈ : L.var) (x₉ : L.var) (x₁₀ : L.var) (x₁₁ : L.var) (x₁₂ : L.var) (x₁₃ : L.var) (x₁₄ : L.var) (x₁₅ : L.var) (x₁₆ : L.var) (x₁₇ : L.var) (x₁₈ : L.var) (x₁₉ : L.var) (x₂₀ : L.var) (x₂₁ : L.var) (x₂₂ : L.var) (x₂₃ : L.var) (x₂₄ : L.var) (x₂₅ : L.var) (x₂₆ : L.var) (x₂₇ : L.var) (x₂₈ : L.var) (x₂₉ : L.var) (x₃₀ : L.var) (x₃₁ : L.var) (x₃₂ : L.var) (x₃₃ : L.var) (x₃₄ : L.var) (x₃₅ : L.var) (x₃₆ : L.var) (x₃₇ : L.var) (x₃₈ : L.var) (x₃₉ : L.var) (x₄₀ : L.var) (x₄₁ : L.var) (x₄₂ : L.var) (x₄₃ : L.var) (x₄₄ : L.var) (x₄₅ : L.var) (x₄₆ : L.var) (x₄₇ : L.var) (x₄₈ : L.var) (x₄₉ : L.var) (x₅₀ : L.var) (x₅₁ : L.var) (x₅₂ : L.var) (x₅₃ : L.var) (x₅₄ : L.var) (x₅₅ : L.var) (x₅₆ : L.var) (x₅₇ : L.var) (x₅₈ : L.var) (x₅₉ : L.var) (x₆₀ : L.var) (x₆₁ : L.var) (x₆₂ : L.var) (x₆₃ : L.var) (x₆₄ : L.var) (x₆₅ : L.var) (x₆₆ : L.var) (x₆₇ : L.var) (x₆₈ : L.var) (x₆₉ : L.var) (x₇₀ : L.var) (x₇₁ : L.var) (x₇₂ : L.var) (x₇₃ : L.var) (x₇₄ : L.var) (x₇₅ : L.var) (x₇₆ : L.var) (x₇₇ : L.var) (x₇₈ : L.var) (x₇₉ : L.var) (x₈₀ : L.var) (x₈₁ : L.var) (x₈₂ : L.var) (x₈₃ : L.var) (x₈₄ : L.var) (x₈₅ : L.var) (x₈₆ : L.var) (x₈₇ : L.var) (x₈₈ : L.var) (x₈₉ : L.var) (x₉₀ : L.var) (x₉₁ : L.var) (x₉₂ : L.var) (x₉₃ : L.var) (x₉₄ : L.var) (x₉₅ : L.var) (x₉₆ : L.var) (x₉₇ : L.var) (x₉₈ : L.var) (x₉₉ : L.var) (x₁₀₀ : L.var) (x₁₀₁ : L.var) (x₁₀₂ : L.var) (x₁₀₃ : L.var) (x₁₀₄ : L.var) (x₁₀₅ : L.var) (x₁₀₆ : L.var) (x₁₀₇ : L.var) (x₁₀₈ : L.var) (x₁₀₉ : L.var) (x₁₁₀ : L.var) (x₁₁₁ : L.var) (x₁₁₂ : L.var) (x₁₁₃ : L.var) (x₁₁₄ : L.var) (x₁₁₅ : L.var) (x₁₁₆ : L.var) (x₁₁₇ : L.var) (x₁₁₈ : L.var) (x₁₁₉ : L.var) (x₁₂₀ : L.var) (x₁₂₁ : L.var) (x₁₂₂ : L.var) (x₁₂₃ : L.var) (x₁₂₄ : L.var) (x₁₂₅ : L.var) (x₁₂₆ : L.var) (x₁₂₇ : L.var) (x₁₂₈ : L.var) (x₁₂₉ : L.var) (x₁₃₀ : L.var) (x₁₃₁ : L.var) (x₁₃₂ : L.var) (x₁₃₃ : L.var) (x₁₃₄ : L.var) (x₁₃₅ : L.var) (x₁₃₆ : L.var) (x₁₃₇ : L.var) (x₁₃₈ : L.var) (x₁₃₉ : L.var) (x₁₄₀ : L.var) (x₁₄₁ : L.var) (x₁₄₂ : L.var) (x₁₄
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  let A : ℕ → L.formula,
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  have h1 : ∀ n : ℕ, A n = L.exists (L.var n) (L.and (L.ne (L.var 0) (L.var 1)) (L.and (L.ne (L.var 0) (L.var 2)) (L.and (L.ne (L.var 0) (L.var 3)) (L.and (L.ne (L.var 0) (L.var 4)) (L.and (L.ne (L.var 0) (L.var 5)) (L.and (L.ne (L.var 0) (L.var 6)) (L.and (L.ne (L.var 0) (L.var 7)) (L.and (L.ne (L.var 0) (L.var 8)) (L.and (L.ne (L.var 0) (L.var 9)) (L.and (L.ne (L.var 0) (L.var 10)) (L.and (L.ne (L.var 0) (L.var 11)) (L.and (L.ne (L.var 0) (L.var 12)) (L.and (L.ne (L.var 0) (L.var 13)) (L.and (L.ne (L.var 0) (L.var 14)) (L.and (L.ne (L.var 0) (L.var 15)) (L.and (L.ne (L.var 0) (L.var 16)) (L.and (L.ne (L.var 0) (L.var 17)) (L.and (L.ne (L.var 0) (L.var 18)) (L.and (L.ne (L.var 0) (L.var 19)) (L.and (L.ne (L.var 0) (L.var 20)) (L.and (L.ne (L.var 0) (L.var 21)) (L.and (L.ne (L.var 0) (L.var 22)) (L.and (L.ne (L.var 0) (L.var 23)) (L.and (L.ne (L.var 0) (L.var 24)) (L.and (L.ne (L.var 0) (L.var 25)) (L.and (L.ne (L.var 0) (L.var 26)) (L.and (L.ne (L.var 0) (L.var 27)) (L.and (L.ne (L.var 0) (L.var 28)) (L.and (L.ne (L.var 0) (L.var 29)) (L.and (L.ne (L.var 0) (L.var 30)) (L.and (L.ne (L.var 0) (L.var 31)) (L.and (L.ne (L.var 0) (L.var 32)) (L.and (L.ne (L.var 0) (L.var 33)) (L.and (L.ne (L.var 0) (L.var 34)) (L.and (L.ne (L.var 0) (L.var 35)) (L.and (L.ne (L.var 0) (L.var 36)) (L.and (L.ne (L.var 0) (L.var 37)) (L.and (L.ne (L.var 0) (L.var 38)) (L.and (L.ne (L.var 0) (L.var 39)) (L.and (L.ne (L.var 0) (L.var 40)) (L.and (L.ne (L.var 0) (L.var 41)) (L.and (L.ne (L.var 0) (L.var 42)) (L.and (L.ne (L.var 0) (L.var 43)) (L.and (L.ne (L.var 0) (L.var 44)) (L.and (L.ne (L.var 0) (L.var 45)) (L.and (L.ne (L.var 0) (L.var 46)) (L.and (L.ne (L.var 0) (L.var 47)) (L.and (L.ne (L.var 0) (L.var 48)) (L.and (L.ne (L.var 0) (L.var 49)) (L.and (L.ne (L.var 0) (L.var 50)) (L.and (L.ne (L.var 0) (L.var 51)) (L.and (L.ne (L.var 0) (L.var 52)) (L.and (L.ne (L.var 0) (L.var 53)) (L.and (L.ne (L.var 0) (L.var 54)) (L.and (L.ne (L.var 0) (L.var 55)) (L.and (L.ne (L.var 0) (L.var 56)) (L.and (L.ne (L.var 0) (L.var 57)) (L.and (L.ne (L.var 0) (L.var 58)) (L.and (L.ne (L.var 0) (L.var 59)) (L.and (L.ne (L.var 0) (L.var 60)) (L.and (L.ne (L.var 0) (L.var 61)) (L.and (L.ne (L.var 0) (L.var 62)) (L.and (L.ne (L.var 0) (L.var 63)) (L.and (L.ne (L.var 0) (L.var 64)) (L.and (L.ne (L.var 0) (L.var 65)) (L.and (L.ne (L.var 0) (L.var 66)) (L.and (L.ne (L.var 0) (L.var 67)) (L.and (L.ne (L.var 0) (L.var 68)) (L.and (L.ne (L.var 0) (L.var 69)) (L.and (L.ne (L.var 0) (L.var 70)) (L.and (L.ne (L.var 0) (L.var 71)) (L.and (L.ne (L.var 0) (L.var 72)) (L.and (L.ne (L.var 0) (L.var 73)) (L.and (L.ne (L.var 0) (L.var 74)) (L.and (L.ne (L.var 0) (L.var 75)) (L.and (L.ne (L.var 0) (L.var 76)) (L.and (L.ne (L.var 0) (L.var 77)) (L.and (L.ne (L.var 0) (L.var 78)) (L.and (L.ne (L.var 0) (L.var 79)) (L.and (L.ne (L.var 0) (L.var 80)) (L.and (L.ne (L.var 0) (L.var 81)) (L.and (L.ne (L.var 0) (L.var 82)) (L.and (L.ne (L.var 0) (L.var 83)) (L.and (L.ne (L.var 0) (L.var 84)) (L.and (L.ne (L.var 0) (L.var 85)) (L.and (L.ne (L.var 0) (L.var 86)) (L.and (L.ne (L.var 0) (L.var 87)) (L.and (L.ne (L.var 0) (L.var 88)) (L.and (L.ne (L.var 0) (L.var 89)) (L.and (L.ne (L.var 0) (L.var 90)) (L.and (L.ne (L.var 0) (L.var 91)) (L.and (L.ne (L.var 0) (L.var 92)) (L.and (L.ne (L.var 0) (L.var 93)) (L.and (L.ne (L.
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  let A : ℕ → L.formula,
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  have h1 : ∀ n : ℕ, A n = L.exists (L.var 1) (L.exists (L.var 2) (L.exists (L.var 3) (L.exists (L.var 4) (L.exists (L.var 5) (L.exists (L.var 6) (L.exists (L.var 7) (L.exists (L.var 8) (L.exists (L.var 9) (L.exists (L.var 10) (L.exists (L.var 11) (L.exists (L.var 12) (L.exists (L.var 13) (L.exists (L.var 14) (L.exists (L.var 15) (L.exists (L.var 16) (L.exists (L.var 17) (L.exists (L.var 18) (L.exists (L.var 19) (L.exists (L.var 20) (L.exists (L.var 21) (L.exists (L.var 22) (L.exists (L.var 23) (L.exists (L.var 24) (L.exists (L.var 25) (L.exists (L.var 26) (L.exists (L.var 27) (L.exists (L.var 28) (L.exists (L.var 29) (L.exists (L.var 30) (L.exists (L.var 31) (L.exists (L.var 32) (L.exists (L.var 33) (L.exists (L.var 34) (L.exists (L.var 35) (L.exists (L.var 36) (L.exists (L.var 37) (L.exists (L.var 38) (L.exists (L.var 39) (L.exists (L.var 40) (L.exists (L.var 41) (L.exists (L.var 42) (L.exists (L.var 43) (L.exists (L.var 44) (L.exists (L.var 45) (L.exists (L.var 46) (L.exists (L.var 47) (L.exists (L.var 48) (L.exists (L.var 49) (L.exists (L.var 50) (L.exists (L.var 51) (L.exists (L.var 52) (L.exists (L.var 53) (L.exists (L.var 54) (L.exists (L.var 55) (L.exists (L.var 56) (L.exists (L.var 57) (L.exists (L.var 58) (L.exists (L.var 59) (L.exists (L.var 60) (L.exists (L.var 61) (L.exists (L.var 62) (L.exists (L.var 63) (L.exists (L.var 64) (L.exists (L.var 65) (L.exists (L.var 66) (L.exists (L.var 67) (L.exists (L.var 68) (L.exists (L.var 69) (L.exists (L.var 70) (L.exists (L.var 71) (L.exists (L.var 72) (L.exists (L.var 73) (L.exists (L.var 74) (L.exists (L.var 75) (L.exists (L.var 76) (L.exists (L.var 77) (L.exists (L.var 78) (L.exists (L.var 79) (L.exists (L.var 80) (L.exists (L.var 81) (L.exists (L.var 82) (L.exists (L.var 83) (L.exists (L.var 84) (L.exists (L.var 85) (L.exists (L.var 86) (L.exists (L.var 87) (L.exists (L.var 88) (L.exists (L.var 89) (L.exists (L.var 90) (L.exists (L.var 91) (L.exists (L.var 92) (L.exists (L.var 93) (L.exists (L.var 94) (L.exists (L.var 95) (L.exists (L.var 96) (L.exists (L.var 97) (L.exists (L.var 98) (L.exists (L.var 99) (L.exists (L.var 100) (L.exists (L.var 101) (L.exists (L.var 102) (L.exists (L.var 103) (L.exists (L.var 104) (L.exists (L.var 105) (L.exists (L.var 106) (L.exists (L.var 107) (L.exists (L.var 108) (L.exists (L.var 109) (L.exists (L.var 110) (L.exists (L.var 111) (L.exists (L.var 112) (L.exists (L.var 113) (L.exists (L.var 114) (L.exists (L.var 115) (L.exists (L.var 116) (L.exists (L.var 117) (L.exists (L.var 118) (L.exists (L.var 119) (L.exists (L.var 120) (L.exists (L.var 121) (L.exists (L.var 122) (L.exists (L.var 123) (L.exists (L.var 124) (L.exists (L.var 125) (L.exists (L.var 126) (L.exists (L.var 127) (L.exists (L.var 128) (L.exists (L.var 129) (L.exists (L.var 130) (L.exists (L.var 131) (L.exists (L.var 132) (L.exists (L.var 133) (L.exists (L.var 134) (L.exists (L.var 135) (L.exists (L.var 136) (L.exists (L.var 137) (L.exists (L.var 138) (L.exists (L.var 139) (L.exists (L.var 140) (L.exists (L.var 141) (L.exists (L.var 142) (L.exists (L.var 143) (L.exists (L.var 144) (L.exists (L.var 145) (L.exists (L.var 146) (L.exists (L.var 147) (L.exists (L.var 148) (L.exists (L.var 149) (L.exists (L.var 150) (L.exists (L.var 151) (L.exists (L.var 152) (L.exists (L.var 153) (L.exists (L.var 154) (L.exists (L.var 155) (L.exists (L.var 156) (L.exists (L.var 157) (L.exists (L.var 158) (L.exists (L.var 159) (L.exists (L.var 160) (L.exists (L.var 161) (L.exists (L.var 162) (L.exists (L.var 163) (L.exists (L.var 164) (L.exists (L.var 165) (L.exists (L.var 166) (L.exists (L.var 167) (L.exists (L.var 168) (L.exists (L.var 169) (L.exists (L.var 170) (L.exists (L.var 171) (
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Overflow theorem
Let $F$ be a set of first-order formulas which has finite models of arbitrarily large size. Then $F$ has an infinite model.
`proof`
For each $n$, let $\mathbf A_n$ be the formula:

$\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$

Then $\mathbf A_i$ is true in a structure $\AA$ iff $\AA$ has at least $n$ elements.

Take:
$$ \Gamma := F \cup \bigcup_{i \mathop = 1}^\infty A_i $$

Since $F$ has models of arbitrarily large size, every finite subset of $\Gamma$ is satisfiable.

From the Compactness Theorem, $\Gamma$ is satisfiable in some model $\mathbf{M}$.

But since $\mathbf{M} \models A_i$ for each $i$, $\mathbf{M}$ must be infinite.

So $F$ has an infinite model.

QED
-/
theorem  overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2021 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Gabriel Ebner
-/
import Mathlib.Tactic.Cache
import Mathlib.Tactic.Core
import Mathlib.Tactic.SolveByElim
import Mathlib.Tactic.TryThis

/-!
# Library search

This file defines a tactic `librarySearch`
and a term elaborator `librarySearch%`
that tries to find a lemma
solving the current goal
(subgoals are solved using `solveByElim`).

```
example : x < x + 1 := librarySearch%
example : Nat := by librarySearch
```
-/

namespace Tactic
namespace LibrarySearch

open Lean Meta TryThis

initialize registerTraceClass `Tactic.librarySearch

-- from Lean.Server.Completion
private def isBlackListed (declName : Name) : MetaM Bool := do
  if declName == ``sorryAx then return false
  if declName matches Name.str _ "inj" _ then return false
  if declName matches Name.str _ "noConfusionType" _ then return false
  let env ← getEnv
  pure $ declName.isInternal
   || isAuxRecursor env declName
   || isNoConfusion env declName
  <||> isRec declName <||> isMatcher declName

initialize librarySearchLemmas : DeclCache (DiscrTree Name) ←
  DeclCache.mk "librarySearch: init cache" {} fun name constInfo lemmas => do
    if constInfo.isUnsafe then return lemmas
    if ← isBlackListed name then return lemmas
    withNewMCtxDepth do
      let (xs, bis, type) ← withReducible <| forallMetaTelescopeReducing constInfo.type
      let keys ← withReducible <| DiscrTree.mkPath type
      pure $ lemmas.insertCore keys name

def librarySearch (mvarId : MVarId) (lemmas : DiscrTree Name) (solveByElimDepth := 6) :
    MetaM <| Option (Array <| MetavarContext × List MVarId) := do
  profileitM Exception "librarySearch" (← getOptions) do
  let mvar := mkMVar mvarId
  let ty ← inferType mvar

  let mut suggestions := #[]

  let state0 ← get

  try
    solveByElim solveByElimDepth mvarId
    return none
  catch _ =>
    set state0

  for lem in ← lemmas.getMatch ty do
    trace[Tactic.librarySearch] "{lem}"
    match ← traceCtx `Tactic.librarySearch try
        let newMVars ← apply mvarId (← mkConstWithFreshMVarLevels lem)
        (try
          for newMVar in newMVars do
            withMVarContext newMVar do
              trace[Tactic.librarySearch] "proving {← addMessageContextFull (mkMVar newMVar)}"
              solveByElim solveByElimDepth newMVar
          pure $ some $ Sum.inr ()
        catch _ =>
          let res := some $ Sum.inl <| (← getMCtx, newMVars)
          set state0
          pure res)
      catch _ =>
        set state0
        pure none
      with
      | none => pure ()
      | some (Sum.inr ()) => return none
      | some (Sum.inl suggestion) => suggestions := suggestions.push suggestion

  pure $ some suggestions

def lines (ls : List MessageData) :=
  MessageData.joinSep ls (MessageData.ofFormat Format.line)

open Lean.Parser.Tactic

-- TODO: implement the additional options for `library_search` from Lean 3,
-- in particular including additional lemmas
-- with `library_search [X, Y, Z]` or `library_search with attr`,
-- or requiring that a particular hypothesis is used in the solution, with `library_search using h`.
syntax (name := librarySearch') "library_search" (config)? (" [" simpArg,* "]")?
  (" with " (colGt ident)+)? (" using " (colGt binderIdent)+)? : tactic
syntax (name := librarySearch!) "library_search!" (config)? (" [" simpArg,* "]")?
  (" with " (colGt ident)+)? (" using " (colGt binderIdent)+)? : tactic

-- For now we only implement the basic functionality.
-- The full syntax is recognized, but will produce a "Tactic has not been implemented" error.

open Elab.Tactic Elab Tactic in
elab_rules : tactic | `(tactic| library_search%$tk) => do
  withNestedTraces do
  trace[Tactic.librarySearch] "proving {← getMainTarget}"
  let mvar ← getMainGoal
  let (hs, introdMVar) ← intros (← getMainGoal)
  withMVarContext introdMVar do
    if let some suggestions ← librarySearch introdMVar (← librarySearchLemmas.get) then
      for suggestion in suggestions do
        addExactSuggestion tk (← instantiateMVars (mkMVar mvar))
      admitGoal introdMVar
    else
      addExactSuggestion tk (← instantiateMVars (mkMVar mvar))

open Elab Term in
elab tk:"library_search%" : term <= expectedType => do
  withNestedTraces do
  trace[Tactic.librarySearch] "proving {expectedType}"
  let mvar ← mkFreshExprMVar expectedType
  let (hs, introdMVar) ← intros mvar.mvarId!
  withMVarContext introdMVar do
    if let some suggestions ← librarySearch introdMVar (← librarySearchLemmas.get) then
      for suggestion in suggestions do
        addTermSuggestion tk (← instantiateMVars mvar)
      mkSorry expectedType (synthetic := true)
    else
      addTermSuggestion tk (← instantiateMVars mvar)
      instantiateMVars mvar


/-
Copyright 2022 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    https://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

Authors: Moritz Firsching
-/
import tactic
/-!
# The spectral theorem and Hadamard's determinant problem

## TODO
  - statement Theorem 1.
    - proof
      - Lemma
        - (A)
        - (B)
        - (C)
  - The Hadamard determinant problem
  - Hadamard matreices esixt for all $n = 2^m$
  - Theorem 2.
-/