import tactic.induction
import tactic

inductive eexpr : Type
| int : ℤ → eexpr
| str : string → eexpr
| var : ℕ → eexpr
| plus : eexpr → eexpr → eexpr
| cat : eexpr → eexpr → eexpr
| len : eexpr → eexpr
| lett : eexpr → eexpr → eexpr

inductive typ : Type
| num : typ
| str : typ

def env : Type := list typ

def lookup (n : ℕ ) (τ : typ) (Γ : env) : Prop :=
  list.nth Γ n = some τ

lemma lookup_lt (n : ℕ ) (τ : typ) (Γ : env) (h : lookup n τ Γ ) :
  n < list.length Γ :=
begin
  induction' Γ ,
  simp [lookup] at h,
  contradiction,
  cases' n,
  simp,
  simp,
  have : n < Γ.length, {
    apply ih n τ,
    simp [lookup],
    simp [lookup] at h,
    assumption,
  },
  exact nat.succ_lt_succ this,
end

-- Typing derivations
inductive has_type : env → eexpr → typ → Prop
| refl (n : ℕ ) (τ : typ) (Γ : env) :
      lookup n τ Γ →
      has_type Γ (eexpr.var n) τ
| strlit (s : string) (Γ : env) :
      has_type Γ (eexpr.str s) typ.str
| numlit (n : ℤ) (Γ : env) :
      has_type Γ (eexpr.int n) typ.num
| plus (e1 e2 : eexpr) (Γ : env) :
      has_type Γ e1 typ.num →
      has_type Γ e2 typ.num →
      has_type Γ (eexpr.plus e1 e2) typ.num
| cat (e1 e2 : eexpr) (Γ : env) :
      has_type Γ e1 typ.str →
      has_type Γ e2 typ.str →
      has_type Γ (eexpr.cat e1 e2) typ.str
| len (e1 : eexpr) (Γ : env) :
      has_type Γ e1 typ.str →
      has_type Γ (eexpr.len e1) typ.num
| lett (e1 e2 : eexpr) (τ1 τ2: typ) (Γ : env):
      has_type Γ e1 τ1 →
      has_type (τ1 :: Γ) e2 τ2 →
      has_type Γ (eexpr.lett e1 e2) τ2

-- ∅ ⊢ let 1+1 in x0 : int
-- [int] ⊢ x0 : int

-- ∅ ⊢ let 1+1 in let "foo" in len(x0) + x1 : int
-- [int] ⊢ let "foo" in len(x0) + x1 : int
-- [str, int] ⊢ len(x0) + x1 : int

-- Unicity: term can only have one type
lemma unicity (Γ : env) (e : eexpr) (τ1 : typ) (h1 : has_type Γ e τ1) :
  ∀ τ2, (has_type Γ e τ2) → τ1 = τ2 :=
begin
  induction' h1,
  all_goals {
    try {
      intros τ2 h2,
      cases h2,
      refl,
    }
  },
  case refl : v τ Γ h {
    intros τ2 hh,
    cases' hh,
    simp [lookup] at *,
    apply option.some.inj,
    rw ← h,
    rw ← h_1,
  },
  case has_type.lett {
    intros τ2 h2,
    cases' h2,
    have : τ1 = τ1_2,
    {
      apply ih_h1,
      assumption,
    },
    rw ← this at *,
    apply ih_h1_1,
    assumption,
  }
end

lemma env_append (Γ : env) (stuff : list typ) (n : ℕ ) (τ : typ) :
  lookup n τ Γ → lookup n τ (list.append Γ stuff) :=
begin
  induction' Γ ,
  simp [lookup],
  cases' n,
  simp [lookup],
  simp [lookup] at *,
  apply ih,
end

-- Weakening: you can add extra stuff in the context and typing doesn't change
lemma weakening (Γ : env) (stuff : list typ) (e : eexpr) (τ : typ) :
  has_type Γ e τ → has_type (list.append Γ stuff) e τ :=
begin
  intros ht,
  induction' ht,
  case refl {
    apply has_type.refl,
    apply env_append,
    assumption,
  },
  case strlit {
    constructor,
  },
  case numlit {
    constructor,
  },
  case lett {
    apply has_type.lett _ _ τ1 τ,
    {
      apply ih_ht,
    },
    {
      simp [list.append] at ih_ht_1,
      apply ih_ht_1,
    },
  },
  case plus {
    constructor,
    apply ih_ht,
    apply ih_ht_1,
  },
  case cat {
    constructor,
    apply ih_ht,
    apply ih_ht_1,
  },
  case len {
    constructor,
    apply ih,
  },
end

-- Example of typing inversion: plus expression and its parts can only have num type
lemma inversion_plus (Γ : env) (e1 e2 : eexpr) (τ : typ) (h : has_type Γ (eexpr.plus e1 e2) τ):
  τ = typ.num ∧ (has_type Γ e1 typ.num) ∧ (has_type Γ e2 typ.num) :=
begin
  cases' h,
  split,
  refl,
  split,
  assumption',
end

def incr : ℕ → eexpr → eexpr
| n (eexpr.var n1) := eexpr.var (if (n1 < n) then n1 else nat.succ n1)
| n (eexpr.int x) := eexpr.int x
| n (eexpr.str x) := eexpr.str x
| n (eexpr.plus e1 e2) := eexpr.plus (incr n e1) (incr n e2)
| n (eexpr.cat e1 e2) := eexpr.cat (incr n e1) (incr n e2)
| n (eexpr.len e1) := eexpr.len (incr n e1)
| n (eexpr.lett e1 e2) := eexpr.lett (incr n e1) (incr (nat.succ n) e2)

def subst : ℕ → eexpr → eexpr → eexpr
| _ _ (eexpr.int n) := eexpr.int n
| _ _ (eexpr.str n) := eexpr.str n
| n e (eexpr.plus e1 e2) := eexpr.plus (subst n e e1) (subst n e e2)
| n e (eexpr.cat e1 e2) := eexpr.cat (subst n e e1) (subst n e e2)
| n e (eexpr.len e1) := eexpr.len (subst n e e1)
| n e (eexpr.var n1) := ite (n = n1) e (eexpr.var n1)
| n e (eexpr.lett e1 e2) := (eexpr.lett (subst n e e1) (subst (nat.succ n) (incr 0 e) e2))

lemma closed_incr (e : eexpr) (τ : typ) (Γ : env) (ht : has_type Γ  e τ) (n : ℕ ) (hn : n >= list.length Γ ):
  incr n e = e :=
begin
  induction' ht,
  case refl {
    dsimp [incr],
    simp [hn],
    have : n_1 < list.length Γ, apply lookup_lt _ _ _ h,
    intro h1,
    linarith,
  },
  case lett {
    simp [incr],
    split,
    exact ih_ht n hn,
    apply ih_ht_1 n.succ,
    simp [list.length],
    apply nat.succ_le_succ,
    linarith,
  },
  all_goals { try { simp [incr]}},
  case plus {
    split,
    apply ih_ht, assumption,
    apply ih_ht_1, assumption,
  },
  case cat {
    split,
    apply ih_ht, assumption,
    apply ih_ht_1, assumption,
  },
  case len {
    apply ih, assumption,
  },
end

variable {α : Type}

@[simp] def insert_nth : ∀ (l : list α) (n : ℕ) (h : n ≤ l.length), α → list α
| xs 0 _ a := a :: xs
| (x::xs) (nat.succ i) h a := x :: insert_nth xs i (nat.le_of_succ_le_succ h) a
| []      (nat.succ i) h _ := absurd h (by {simp [list.length]})

lemma blah (l : list α) (h : 0 ≤ l.length) (x : α):
  insert_nth l 0 h x = x :: l :=
begin
  induction' l,
  simp,
  simp,
end

lemma map_insert (l : list α) (x : α) (n n1 : ℕ) (hn : n ≤ l.length) :
  (list.nth (insert_nth l n hn x) (ite (n1 < n) n1 n1.succ)) = list.nth l n1 :=
begin
  induction' l,
  simp [insert_nth],
  have hh : n = 0, {
    simp [list.length] at hn,
    assumption,
  },
  cases' n,
  simp,
  apply nat.succ_le_succ,
  exact zero_le n1,
  contradiction,

  cases' n,
  simp [insert_nth],
  simp [insert_nth],
  cases' n1,
  simp,
  simp [list.nth],
  have : n ≤ l.length, {
    simp [list.length] at hn,
    apply nat.succ_le_succ_iff.mp,
    assumption',
  },
  specialize ih x n n1 this,
  have : ite (n1.succ < n.succ) n1.succ n1.succ.succ = (ite (n1 < n) n1 n1.succ).succ, {
    by_cases (n1 < n),
    simp [h],
    intro hh,
    rw nat.succ_le_succ_iff at hh,
    exact nat.lt_le_antisymm h hh,
    simp [h],
    intro hh,
    rw nat.succ_lt_succ_iff at hh,
    contradiction,
  },
  rw this,
  simp [list.nth],
  exact ih,
end

lemma incr_type (e : eexpr) (τ τ' : typ) (Γ : env)
  (ht : has_type Γ e τ) (n : ℕ ) (hn : n ≤ list.length Γ ) :
  has_type (insert_nth Γ n hn τ') (incr n e) τ :=
begin
  induction' ht,
  all_goals { simp [incr]},
  case refl {
    constructor,
    simp [lookup],
    rw (map_insert),
    simp [lookup] at h,
    assumption,
  },
  case lett {
    apply has_type.lett _ _ τ1,
    apply ih_ht,
    specialize ih_ht_1 τ' n.succ,
    simp [insert_nth] at ih_ht_1,
    apply ih_ht_1,
    exact nat.succ_le_succ hn,
  },
  case strlit {
    constructor,
  },
  case numlit {
    constructor,
  },
  case plus {
    constructor,
    apply ih_ht,
    apply ih_ht_1,
  },
  case cat {
    constructor,
    apply ih_ht,
    apply ih_ht_1,
  },
  case len {
    constructor,
    apply ih,
  }
end

lemma type_subst
  (e e' : eexpr) (Γ : env) (τ τ' : typ)
  (n : ℕ ) (te : has_type Γ e τ)
  (hn : lookup n τ Γ )
  (te' : has_type Γ e' τ')
  : has_type Γ (subst n e e') τ'
  :=
begin
  -- induction on the derivation of te'
  induction' te',
  case refl {
    dsimp [subst],
    by_cases hh : (n=n_1),
    rw ← hh at *,
    simp,
    have : τ' = τ,
    {
      simp [lookup] at *,
      apply option.some.inj,
      rw ← hn,
      rw ← h,
    },
    rw this,
    assumption,
    simp [hh],
    constructor,
    assumption,
  },
  case lett {
    dsimp [subst],
    apply has_type.lett _ _ τ1 τ',
    {
      apply ih_te',
      exact te,
      exact hn,
    },
    {
      apply ih_te'_1 (incr 0 e) τ n.succ,
      rw ← blah _ (nat.zero_le Γ.length),
      apply incr_type,
      exact te,
      dsimp [lookup],
      dsimp [lookup] at hn,
      assumption,
    },
  },
  {
    apply has_type.strlit,
  },
  {
    apply has_type.numlit,
  },
  case plus {
    apply has_type.plus,
    exact ih_te' _ _ _ te hn,
    exact ih_te'_1 _ _ _ te hn,
  },
  case cat {
    apply has_type.cat,
    exact ih_te' _ _ _ te hn,
    exact ih_te'_1 _ _ _ te hn,
  },
  case len {
    apply has_type.len,
    exact ih _ _ _ te hn,
  },
end


import .prop

namespace fol

variable {α : Type}

class is_symb (α : Type) extends prop.is_symb α :=
(fa : α) (ex : α)

inductive symb : Type
| fn : string → symb
| prd : string → symb
| true : symb
| false : symb
| not : symb
| and : symb
| or  : symb
| imp : symb
| fa  : symb
| ex  : symb

instance : decidable_eq symb :=
by tactic.mk_dec_eq_instance

instance : is_symb symb :=
{ true  := symb.true,
  false := symb.false,
  not   := symb.not,
  and   := symb.and,
  or    := symb.or,
  imp   := symb.imp,
  fa    := symb.fa,
  ex    := symb.ex }

def fa [is_symb α] (p : exp α) := exp.app (exp.cst (is_symb.fa α)) (exp.lam p)
notation  `∀'` p := fa p

def ex [is_symb α] (p : exp α) := exp.app (exp.cst (is_symb.ex α)) (exp.lam p)
notation  `∃'` p := ex p

def pred (P : string) (args : list (exp symb)) : exp symb :=
list.foldl exp.app (exp.cst (symb.prd P)) args

def func (F : string) (args : list (exp symb)) : exp symb :=
list.foldl exp.app (exp.cst (symb.fn F)) args

inductive inf [is_symb α] : list (seq α) → seq α → Prop
| prop : ∀ S s, prop.inf S s → inf S s
| fal : ∀ t Γ Δ p, inf [(inst t p)::Γ ==> Δ] ((∀' p)::Γ ==> Δ)
| far : ∀ k Γ Δ p, k ∉ fvrs_list Γ → k ∉ fvrs_list Δ
  → inf [Γ ==> (inst (exp.fvr α k) p)::Δ] (Γ ==> (∀' p)::Δ)
| exl : ∀ k Γ Δ p, k ∉ fvrs_list Γ → k ∉ fvrs_list Δ
  → inf [(inst (exp.fvr α k) p)::Γ ==> Δ] ((∃' p)::Γ ==> Δ)
| exr : ∀ t Γ Δ p, inf [Γ ==> (inst t p)::Δ] (Γ ==> (∃' p)::Δ)

inductive thm [is_symb α] : (seq α) → Prop
| inf : ∀ {s S}, inf S s → (∀ s' ∈ S, thm s') → thm s

/- Derived rules -/

open list

lemma thm.id [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p, thm (p::Γ ==> p::Δ) :=
begin
  intros Γ Δ p, apply thm.inf, apply inf.prop,
  apply prop.inf.id, apply forall_mem_nil
end

lemma thm.truer [is_symb α] :
  ∀ (Γ Δ : list (exp α)), thm (Γ ==> ⊤'::Δ) :=
begin
  intros Γ Δ, apply thm.inf, apply inf.prop,
  apply prop.inf.truer, apply forall_mem_nil
end

lemma thm.falsel [is_symb α] :
  ∀ (Γ Δ : list (exp α)), thm (⊥'::Γ ==> Δ) :=
begin
  intros Γ Δ, apply thm.inf, apply inf.prop,
  apply prop.inf.falsel, apply forall_mem_nil
end

lemma thm.andl [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p q,
  thm ((p ∧' q)::Γ ==> Δ) → thm (p::q::Γ ==> Δ) :=
begin
  intros Γ Δ p q h, apply thm.inf, apply inf.prop, apply prop.inf.andl,
  rewrite forall_mem_singleton, apply h
end

lemma thm.andr [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p q,
  thm (Γ ==> p::Δ) → thm (Γ ==> q::Δ)
  → thm (Γ ==> (p ∧' q)::Δ) :=
begin
  intros Γ Δ p q h1 h2,
  apply thm.inf, apply inf.prop, apply prop.inf.andr, intros s hs,
  rewrite mem_cons_iff at hs, cases hs with hs hs,
  rewrite hs, apply h1, rewrite mem_singleton at hs,
  rewrite hs, apply h2
end

lemma thm.orl [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p q,
  thm (p::Γ ==> Δ) → thm (q::Γ ==> Δ)
  → thm ((p ∨' q)::Γ ==> Δ) :=
begin
  intros Γ Δ p q h1 h2,
  apply thm.inf, apply inf.prop, apply prop.inf.orl, intros s hs,
  rewrite mem_cons_iff at hs, cases hs with hs hs,
  rewrite hs, apply h1, rewrite mem_singleton at hs,
  rewrite hs, apply h2
end

lemma thm.orr [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p q,
  thm (Γ ==> p::q::Δ) → thm (Γ ==> (p ∨' q)::Δ) :=
begin
  intros Γ Δ p q h, apply thm.inf, apply inf.prop, apply prop.inf.orr,
  rewrite forall_mem_singleton, apply h
end

lemma thm.impl [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p q,
  thm (Γ ==> p::Δ) → thm (q::Γ ==> Δ)
  → thm ((p →' q)::Γ ==> Δ) :=
begin
  intros Γ Δ p q h1 h2, apply thm.inf, apply inf.prop, apply prop.inf.impl,
  intros s hs, rewrite mem_cons_iff at hs,
  cases hs with hs hs, rewrite hs, apply h1,
  rewrite mem_singleton at hs, rewrite hs, apply h2
end

lemma thm.impr [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p q,
  thm (p::Γ ==> q::Δ) → thm (Γ ==> (p →' q)::Δ) :=
begin
  intros Γ Δ p q h, apply thm.inf, apply inf.prop, apply prop.inf.impr,
  rewrite forall_mem_singleton, apply h
end

lemma thm.wl [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p,
  thm (Γ ==> Δ) → thm (p::Γ ==> Δ) :=
begin
  intros Γ Δ p h, apply thm.inf, apply inf.prop, apply prop.inf.wl,
  rewrite forall_mem_singleton, apply h
end

lemma thm.wr [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p,
  thm (Γ ==> Δ) → thm (Γ ==> p::Δ) :=
begin
  intros Γ Δ p h, apply thm.inf, apply inf.prop, apply prop.inf.wr,
  rewrite forall_mem_singleton, apply h
end

lemma thm.cl [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p,
  thm (p::p::Γ ==> Δ) → thm (p::Γ ==> Δ) :=
begin
  intros Γ Δ p h, apply thm.inf, apply inf.prop, apply prop.inf.cl,
  rewrite forall_mem_singleton, apply h
end

lemma thm.cr [is_symb α] :
  ∀ (Γ Δ : list (exp α)) p,
  thm (Γ ==> p::p::Δ) → thm (Γ ==> p::Δ) :=
begin
  intros Γ Δ p h, apply thm.inf, apply inf.prop, apply prop.inf.cr,
  rewrite forall_mem_singleton, apply h
end

lemma thm.rl [is_symb α] :
  ∀ n (Γ Δ : list (exp α)), thm (rotate n Γ ==> Δ) → thm (Γ ==> Δ) :=
begin
  intros n Γ Δ h, apply thm.inf, apply inf.prop,
  apply prop.inf.pl (rotate n Γ),
  apply perm_rotate, intros s' hs',
  rewrite list.mem_singleton at hs',
  rewrite hs', apply h
end

lemma thm.rr [is_symb α] :
  ∀ n (Γ Δ : list (exp α)), thm (Γ ==> rotate n Δ) → thm (Γ ==> Δ) :=
begin
  intros n Γ Δ h, apply thm.inf, apply inf.prop,
  apply prop.inf.pr _ (rotate n Δ),
  apply perm_rotate, intros s' hs',
  rewrite list.mem_singleton at hs',
  rewrite hs', apply h
end

lemma thm.fal [is_symb α] :
  ∀ t (Γ Δ : list (exp α)) p,
  thm ((inst t p)::Γ ==> Δ) → thm ((∀' p)::Γ ==> Δ) :=
begin
  intros t Γ Δ p h, apply thm.inf, apply inf.fal t,
  rewrite list.forall_mem_singleton, apply h
end

lemma thm.far [is_symb α] :
  ∀ k (Γ Δ : list (exp α)) p,
  k ∉ fvrs_list Γ → k ∉ fvrs_list Δ
  → thm (Γ ==> (inst (exp.fvr α k) p)::Δ) → thm (Γ ==> (∀' p)::Δ) :=
begin
  intros k Γ Δ p h1 h2 h3,
  apply thm.inf, apply inf.far k; try {assumption},
  rewrite list.forall_mem_singleton, apply h3
end

lemma thm.exl [is_symb α] :
  ∀ k (Γ Δ : list (exp α)) p,
  k ∉ fvrs_list Γ → k ∉ fvrs_list Δ
  → thm ((inst (exp.fvr α k) p)::Γ ==> Δ) → thm ((∃' p)::Γ ==> Δ) :=
begin
  intros k Γ Δ p h1 h2 h3,
  apply thm.inf, apply inf.exl k; try {assumption},
  rewrite list.forall_mem_singleton, apply h3
end

lemma thm.exr [is_symb α] :
  ∀ t (Γ Δ : list (exp α)) p,
  thm (Γ ==> (inst t p)::Δ) → thm (Γ ==> (∃' p)::Δ) :=
begin
  intros t Γ Δ p h, apply thm.inf, apply inf.exr t,
  rewrite list.forall_mem_singleton, apply h
end

open tactic

meta def apply_exl (n : nat) : tactic unit :=
do to_expr ``(thm.exl %%(`(n))) >>= apply,
   dec_triv_tac, dec_triv_tac

meta def apply_far (n : nat) : tactic unit :=
do to_expr ``(thm.far %%(`(n))) >>= apply,
   dec_triv_tac, dec_triv_tac

/- Printing -/

open expr

meta def getsqt : tactic (list (exp symb) × list (exp symb)) :=
do `(thm (%%Γe ==> %%Δe)) ← tactic.target,
    Γ ← eval_expr (list (exp symb)) Γe,
    Δ ← eval_expr (list (exp symb)) Δe,
    return (Γ,Δ)

def fml2str : exp symb → string
| (exp.app (exp.app e p) q) :=
  if e = exp.cst (prop.is_symb.and symb)
  then "(" ++ fml2str p ++ " ∧ " ++ fml2str q ++ ")" else
  if e = exp.cst (prop.is_symb.or symb)
  then "(" ++ fml2str p ++ " ∨ " ++ fml2str q ++ ")" else
  if e = exp.cst (prop.is_symb.imp symb)
  then "(" ++ fml2str p ++ " → " ++ fml2str q ++ ")" else
    fml2str (exp.app e p) ++ " " ++ fml2str q
| (exp.app e1 e2) := fml2str e1 ++ " " ++ fml2str e2
| (exp.lam e) := fml2str e
| (exp.cst s) :=
  if s = prop.is_symb.true symb
  then "⊤" else
  if s = prop.is_symb.false symb
  then "⊥" else
  match s with
  | (symb.fa) := "∀"
  | (symb.ex) := "∃"
  | (symb.not) := "¬"
  | (symb.prd str) := str
  | (symb.fn str) := str
  | _ := "ERROR 1"
  end
| (exp.bvr _ n) := "#" ++ to_string n
| (exp.fvr _ n) := "&" ++ to_string n

meta def showgoal : tactic unit :=
(do (Γ,Δ) ← getsqt, trace (sqt2str fml2str Γ Δ)) <|> trace "No Goals"

/- Examples -/

example : thm ([] ==> [∀' (pred "P" [# 0]) →' ∃' (pred "P" [# 0])]) :=
begin
  showgoal,
  apply thm.impr,
  apply thm.fal (& 0),
  apply thm.exr (& 0),
  apply thm.id,
  showgoal
end

example : thm ([∃' (pred "P" [# 0] ∨' pred "Q" [# 0])] ==> [∃' (pred "P" [# 0]) ∨' ∃' (pred "Q" [# 0])]) :=
begin
  showgoal,
  apply_exl 0, apply thm.orr, apply thm.orl,
  apply thm.exr (& 0), apply thm.id, apply thm.rr 1,
  apply thm.exr (& 0), apply thm.id,
  showgoal
end

example : thm ([∀' (pred "P" [# 0]), ∀' ((pred "P" [# 0]) →' (pred "Q" [# 0]))] ==> [∀' (pred "Q" [# 0])]) :=
begin
  showgoal,
  apply_far 0, apply thm.fal (& 0),
  apply thm.rl 1, apply thm.fal (& 0),
  apply thm.impl, apply thm.id, apply thm.id,
  showgoal
end

example : thm ([∀' (pred "P" [# 0]), (pred "P" [& 0]) →' ((pred "P" [& 1]) →' (pred "Q" []))] ==> [pred "Q" []]) :=
begin
  showgoal,
  apply thm.rl 1, apply thm.impl,
  apply thm.fal (& 0), apply thm.id,
  apply thm.impl, apply thm.fal (& 1),
  apply thm.id, apply thm.id,
  showgoal
end

end fol


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.basic
import Mathlib.ring_theory.witt_vector.is_poly
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-! ## The Verschiebung operator -/

namespace witt_vector

-- unfortunately, without this attribute, some of the code breaks for reasons I don't understand

/--
`verschiebung_fun x` shifts the coefficients of `x` up by one,
by inserting 0 as the 0th coefficient.
`x.coeff i` then becomes `(verchiebung_fun x).coeff (i + 1)`.

`verschiebung_fun` is the underlying function of the additive monoid hom `witt_vector.verschiebung`.
-/
def verschiebung_fun {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) : witt_vector p R :=
  mk p fun (n : ℕ) => ite (n = 0) 0 (coeff x (n - 1))

theorem verschiebung_fun_coeff {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) (n : ℕ) : coeff (verschiebung_fun x) n = ite (n = 0) 0 (coeff x (n - 1)) := sorry

theorem verschiebung_fun_coeff_zero {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) : coeff (verschiebung_fun x) 0 = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coeff (verschiebung_fun x) 0 = 0)) (verschiebung_fun_coeff x 0)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (ite (0 = 0) 0 (coeff x (0 - 1)) = 0)) (if_pos rfl))) (Eq.refl 0))

@[simp] theorem verschiebung_fun_coeff_succ {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) (n : ℕ) : coeff (verschiebung_fun x) (Nat.succ n) = coeff x n :=
  rfl

theorem ghost_component_zero_verschiebung_fun {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) : coe_fn (ghost_component 0) (verschiebung_fun x) = 0 := sorry

theorem ghost_component_verschiebung_fun {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) (n : ℕ) : coe_fn (ghost_component (n + 1)) (verschiebung_fun x) = ↑p * coe_fn (ghost_component n) x := sorry

/--
The 0th Verschiebung polynomial is 0. For `n > 0`, the `n`th Verschiebung polynomial is the
variable `X (n-1)`.
-/
def verschiebung_poly (n : ℕ) : mv_polynomial ℕ ℤ :=
  ite (n = 0) 0 (mv_polynomial.X (n - 1))

@[simp] theorem verschiebung_poly_zero : verschiebung_poly 0 = 0 :=
  rfl

theorem aeval_verschiebung_poly' {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) (n : ℕ) : coe_fn (mv_polynomial.aeval (coeff x)) (verschiebung_poly n) = coeff (verschiebung_fun x) n := sorry

/--
`witt_vector.verschiebung` has polynomial structure given by `witt_vector.verschiebung_poly`.
-/
theorem verschiebung_fun_is_poly (p : ℕ) : is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) => verschiebung_fun := sorry

/--
`verschiebung x` shifts the coefficients of `x` up by one, by inserting 0 as the 0th coefficient.
`x.coeff i` then becomes `(verchiebung x).coeff (i + 1)`.

This is a additive monoid hom with underlying function `verschiebung_fun`.
-/
def verschiebung {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] : witt_vector p R →+ witt_vector p R :=
  add_monoid_hom.mk verschiebung_fun sorry sorry

/-- `witt_vector.verschiebung` is a polynomial function. -/
theorem verschiebung_is_poly {p : ℕ} [hp : fact (nat.prime p)] : is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) => ⇑verschiebung :=
  verschiebung_fun_is_poly p

/-- verschiebung is a natural transformation -/
@[simp] theorem map_verschiebung {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) : coe_fn (map f) (coe_fn verschiebung x) = coe_fn verschiebung (coe_fn (map f) x) := sorry

theorem ghost_component_zero_verschiebung {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) : coe_fn (ghost_component 0) (coe_fn verschiebung x) = 0 :=
  ghost_component_zero_verschiebung_fun x

theorem ghost_component_verschiebung {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) (n : ℕ) : coe_fn (ghost_component (n + 1)) (coe_fn verschiebung x) = ↑p * coe_fn (ghost_component n) x :=
  ghost_component_verschiebung_fun x n

@[simp] theorem verschiebung_coeff_zero {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) : coeff (coe_fn verschiebung x) 0 = 0 :=
  rfl

-- simp_nf complains if this is simp

theorem verschiebung_coeff_add_one {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) (n : ℕ) : coeff (coe_fn verschiebung x) (n + 1) = coeff x n :=
  rfl

@[simp] theorem verschiebung_coeff_succ {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) (n : ℕ) : coeff (coe_fn verschiebung x) (Nat.succ n) = coeff x n :=
  rfl

theorem aeval_verschiebung_poly {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) (n : ℕ) : coe_fn (mv_polynomial.aeval (coeff x)) (verschiebung_poly n) = coeff (coe_fn verschiebung x) n :=
  aeval_verschiebung_poly' x n

@[simp] theorem bind₁_verschiebung_poly_witt_polynomial {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) : coe_fn (mv_polynomial.bind₁ verschiebung_poly) (witt_polynomial p ℤ n) =
  ite (n = 0) 0 (↑p * witt_polynomial p ℤ (n - 1)) := sorry


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.limits.comma
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Arrow
import Mathbin.CategoryTheory.Limits.Constructions.EpiMono
import Mathbin.CategoryTheory.Limits.Creates
import Mathbin.CategoryTheory.Limits.Unit
import Mathbin.CategoryTheory.StructuredArrow

/-!
# Limits and colimits in comma categories

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

We build limits in the comma category `comma L R` provided that the two source categories have
limits and `R` preserves them.
This is used to construct limits in the arrow category, structured arrow category and under
category, and show that the appropriate forgetful functors create limits.

The duals of all the above are also given.
-/

namespace CategoryTheory

open Category Limits

universe w' w v u₁ u₂ u₃

variable {J : Type w} [Category.{w'} J]

variable {A : Type u₁} [Category.{v} A]

variable {B : Type u₂} [Category.{v} B]

variable {T : Type u₃} [Category.{v} T]

namespace Comma

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

variable (F : J ⥤ Comma L R)

#print CategoryTheory.Comma.limitAuxiliaryCone /-
/-- (Implementation). An auxiliary cone which is useful in order to construct limits
in the comma category. -/
@[simps]
def limitAuxiliaryCone (c₁ : Cone (F ⋙ fst L R)) : Cone ((F ⋙ snd L R) ⋙ R) :=
  (Cones.postcompose (whiskerLeft F (Comma.natTrans L R) : _)).obj (L.mapCone c₁)
#align category_theory.comma.limit_auxiliary_cone CategoryTheory.Comma.limitAuxiliaryCone
-/

#print CategoryTheory.Comma.coneOfPreserves /-
/-- If `R` preserves the appropriate limit, then given a cone for `F ⋙ fst L R : J ⥤ L` and a
limit cone for `F ⋙ snd L R : J ⥤ R` we can build a cone for `F` which will turn out to be a limit
cone.
-/
@[simps]
def coneOfPreserves [PreservesLimit (F ⋙ snd L R) R] (c₁ : Cone (F ⋙ fst L R))
    {c₂ : Cone (F ⋙ snd L R)} (t₂ : IsLimit c₂) : Cone F
    where
  pt :=
    { left := c₁.pt
      right := c₂.pt
      Hom := (isLimitOfPreserves R t₂).lift (limitAuxiliaryCone _ c₁) }
  π :=
    { app := fun j =>
        { left := c₁.π.app j
          right := c₂.π.app j
          w' := ((isLimitOfPreserves R t₂).fac (limitAuxiliaryCone F c₁) j).symm }
      naturality' := fun j₁ j₂ t => by ext <;> dsimp <;> simp [← c₁.w t, ← c₂.w t] }
#align category_theory.comma.cone_of_preserves CategoryTheory.Comma.coneOfPreserves
-/

#print CategoryTheory.Comma.coneOfPreservesIsLimit /-
/-- Provided that `R` preserves the appropriate limit, then the cone in `cone_of_preserves` is a
limit. -/
def coneOfPreservesIsLimit [PreservesLimit (F ⋙ snd L R) R] {c₁ : Cone (F ⋙ fst L R)}
    (t₁ : IsLimit c₁) {c₂ : Cone (F ⋙ snd L R)} (t₂ : IsLimit c₂) :
    IsLimit (coneOfPreserves F c₁ t₂)
    where
  lift s :=
    { left := t₁.lift ((fst L R).mapCone s)
      right := t₂.lift ((snd L R).mapCone s)
      w' :=
        (isLimitOfPreserves R t₂).hom_ext fun j =>
          by
          rw [cone_of_preserves_X_hom, assoc, assoc, (is_limit_of_preserves R t₂).fac,
            limit_auxiliary_cone_π_app, ← L.map_comp_assoc, t₁.fac, R.map_cone_π_app, ← R.map_comp,
            t₂.fac]
          exact (s.π.app j).w }
  uniq s m w :=
    CommaMorphism.ext _ _ (t₁.uniq ((fst L R).mapCone s) _ fun j => by simp [← w])
      (t₂.uniq ((snd L R).mapCone s) _ fun j => by simp [← w])
#align category_theory.comma.cone_of_preserves_is_limit CategoryTheory.Comma.coneOfPreservesIsLimit
-/

#print CategoryTheory.Comma.colimitAuxiliaryCocone /-
/-- (Implementation). An auxiliary cocone which is useful in order to construct colimits
in the comma category. -/
@[simps]
def colimitAuxiliaryCocone (c₂ : Cocone (F ⋙ snd L R)) : Cocone ((F ⋙ fst L R) ⋙ L) :=
  (Cocones.precompose (whiskerLeft F (Comma.natTrans L R) : _)).obj (R.mapCocone c₂)
#align category_theory.comma.colimit_auxiliary_cocone CategoryTheory.Comma.colimitAuxiliaryCocone
-/

#print CategoryTheory.Comma.coconeOfPreserves /-
/--
If `L` preserves the appropriate colimit, then given a colimit cocone for `F ⋙ fst L R : J ⥤ L` and
a cocone for `F ⋙ snd L R : J ⥤ R` we can build a cocone for `F` which will turn out to be a
colimit cocone.
-/
@[simps]
def coconeOfPreserves [PreservesColimit (F ⋙ fst L R) L] {c₁ : Cocone (F ⋙ fst L R)}
    (t₁ : IsColimit c₁) (c₂ : Cocone (F ⋙ snd L R)) : Cocone F
    where
  pt :=
    { left := c₁.pt
      right := c₂.pt
      Hom := (isColimitOfPreserves L t₁).desc (colimitAuxiliaryCocone _ c₂) }
  ι :=
    { app := fun j =>
        { left := c₁.ι.app j
          right := c₂.ι.app j
          w' := (isColimitOfPreserves L t₁).fac (colimitAuxiliaryCocone _ c₂) j }
      naturality' := fun j₁ j₂ t => by ext <;> dsimp <;> simp [← c₁.w t, ← c₂.w t] }
#align category_theory.comma.cocone_of_preserves CategoryTheory.Comma.coconeOfPreserves
-/

#print CategoryTheory.Comma.coconeOfPreservesIsColimit /-
/-- Provided that `L` preserves the appropriate colimit, then the cocone in `cocone_of_preserves` is
a colimit. -/
def coconeOfPreservesIsColimit [PreservesColimit (F ⋙ fst L R) L] {c₁ : Cocone (F ⋙ fst L R)}
    (t₁ : IsColimit c₁) {c₂ : Cocone (F ⋙ snd L R)} (t₂ : IsColimit c₂) :
    IsColimit (coconeOfPreserves F t₁ c₂)
    where
  desc s :=
    { left := t₁.desc ((fst L R).mapCocone s)
      right := t₂.desc ((snd L R).mapCocone s)
      w' :=
        (isColimitOfPreserves L t₁).hom_ext fun j =>
          by
          rw [cocone_of_preserves_X_hom, (is_colimit_of_preserves L t₁).fac_assoc,
            colimit_auxiliary_cocone_ι_app, assoc, ← R.map_comp, t₂.fac, L.map_cocone_ι_app, ←
            L.map_comp_assoc, t₁.fac]
          exact (s.ι.app j).w }
  uniq s m w :=
    CommaMorphism.ext _ _ (t₁.uniq ((fst L R).mapCocone s) _ (by simp [← w]))
      (t₂.uniq ((snd L R).mapCocone s) _ (by simp [← w]))
#align category_theory.comma.cocone_of_preserves_is_colimit CategoryTheory.Comma.coconeOfPreservesIsColimit
-/

#print CategoryTheory.Comma.hasLimit /-
instance hasLimit (F : J ⥤ Comma L R) [HasLimit (F ⋙ fst L R)] [HasLimit (F ⋙ snd L R)]
    [PreservesLimit (F ⋙ snd L R) R] : HasLimit F :=
  HasLimit.mk ⟨_, coneOfPreservesIsLimit _ (limit.isLimit _) (limit.isLimit _)⟩
#align category_theory.comma.has_limit CategoryTheory.Comma.hasLimit
-/

#print CategoryTheory.Comma.hasLimitsOfShape /-
instance hasLimitsOfShape [HasLimitsOfShape J A] [HasLimitsOfShape J B]
    [PreservesLimitsOfShape J R] : HasLimitsOfShape J (Comma L R) where
#align category_theory.comma.has_limits_of_shape CategoryTheory.Comma.hasLimitsOfShape
-/

#print CategoryTheory.Comma.hasLimits /-
instance hasLimits [HasLimits A] [HasLimits B] [PreservesLimits R] : HasLimits (Comma L R) :=
  ⟨inferInstance⟩
#align category_theory.comma.has_limits CategoryTheory.Comma.hasLimits
-/

#print CategoryTheory.Comma.hasColimit /-
instance hasColimit (F : J ⥤ Comma L R) [HasColimit (F ⋙ fst L R)] [HasColimit (F ⋙ snd L R)]
    [PreservesColimit (F ⋙ fst L R) L] : HasColimit F :=
  HasColimit.mk ⟨_, coconeOfPreservesIsColimit _ (colimit.isColimit _) (colimit.isColimit _)⟩
#align category_theory.comma.has_colimit CategoryTheory.Comma.hasColimit
-/

#print CategoryTheory.Comma.hasColimitsOfShape /-
instance hasColimitsOfShape [HasColimitsOfShape J A] [HasColimitsOfShape J B]
    [PreservesColimitsOfShape J L] : HasColimitsOfShape J (Comma L R) where
#align category_theory.comma.has_colimits_of_shape CategoryTheory.Comma.hasColimitsOfShape
-/

#print CategoryTheory.Comma.hasColimits /-
instance hasColimits [HasColimits A] [HasColimits B] [PreservesColimits L] :
    HasColimits (Comma L R) :=
  ⟨inferInstance⟩
#align category_theory.comma.has_colimits CategoryTheory.Comma.hasColimits
-/

end Comma

namespace Arrow

#print CategoryTheory.Arrow.hasLimit /-
instance hasLimit (F : J ⥤ Arrow T) [i₁ : HasLimit (F ⋙ leftFunc)] [i₂ : HasLimit (F ⋙ rightFunc)] :
    HasLimit F :=
  @Comma.hasLimit _ _ _ _ _ i₁ i₂ _
#align category_theory.arrow.has_limit CategoryTheory.Arrow.hasLimit
-/

#print CategoryTheory.Arrow.hasLimitsOfShape /-
instance hasLimitsOfShape [HasLimitsOfShape J T] : HasLimitsOfShape J (Arrow T) where
#align category_theory.arrow.has_limits_of_shape CategoryTheory.Arrow.hasLimitsOfShape
-/

#print CategoryTheory.Arrow.hasLimits /-
instance hasLimits [HasLimits T] : HasLimits (Arrow T) :=
  ⟨inferInstance⟩
#align category_theory.arrow.has_limits CategoryTheory.Arrow.hasLimits
-/

#print CategoryTheory.Arrow.hasColimit /-
instance hasColimit (F : J ⥤ Arrow T) [i₁ : HasColimit (F ⋙ leftFunc)]
    [i₂ : HasColimit (F ⋙ rightFunc)] : HasColimit F :=
  @Comma.hasColimit _ _ _ _ _ i₁ i₂ _
#align category_theory.arrow.has_colimit CategoryTheory.Arrow.hasColimit
-/

#print CategoryTheory.Arrow.hasColimitsOfShape /-
instance hasColimitsOfShape [HasColimitsOfShape J T] : HasColimitsOfShape J (Arrow T) where
#align category_theory.arrow.has_colimits_of_shape CategoryTheory.Arrow.hasColimitsOfShape
-/

#print CategoryTheory.Arrow.hasColimits /-
instance hasColimits [HasColimits T] : HasColimits (Arrow T) :=
  ⟨inferInstance⟩
#align category_theory.arrow.has_colimits CategoryTheory.Arrow.hasColimits
-/

end Arrow

namespace StructuredArrow

variable {X : T} {G : A ⥤ T} (F : J ⥤ StructuredArrow X G)

#print CategoryTheory.StructuredArrow.hasLimit /-
instance hasLimit [i₁ : HasLimit (F ⋙ proj X G)] [i₂ : PreservesLimit (F ⋙ proj X G) G] :
    HasLimit F :=
  @Comma.hasLimit _ _ _ _ _ _ i₁ i₂
#align category_theory.structured_arrow.has_limit CategoryTheory.StructuredArrow.hasLimit
-/

#print CategoryTheory.StructuredArrow.hasLimitsOfShape /-
instance hasLimitsOfShape [HasLimitsOfShape J A] [PreservesLimitsOfShape J G] :
    HasLimitsOfShape J (StructuredArrow X G) where
#align category_theory.structured_arrow.has_limits_of_shape CategoryTheory.StructuredArrow.hasLimitsOfShape
-/

#print CategoryTheory.StructuredArrow.hasLimits /-
instance hasLimits [HasLimits A] [PreservesLimits G] : HasLimits (StructuredArrow X G) :=
  ⟨inferInstance⟩
#align category_theory.structured_arrow.has_limits CategoryTheory.StructuredArrow.hasLimits
-/

#print CategoryTheory.StructuredArrow.createsLimit /-
noncomputable instance createsLimit [i : PreservesLimit (F ⋙ proj X G) G] :
    CreatesLimit F (proj X G) :=
  createsLimitOfReflectsIso fun c t =>
    { liftedCone := @Comma.coneOfPreserves _ _ _ _ _ i pUnitCone t
      makesLimit := Comma.coneOfPreservesIsLimit _ pUnitConeIsLimit _
      validLift := Cones.ext (Iso.refl _) fun j => (id_comp _).symm }
#align category_theory.structured_arrow.creates_limit CategoryTheory.StructuredArrow.createsLimit
-/

#print CategoryTheory.StructuredArrow.createsLimitsOfShape /-
noncomputable instance createsLimitsOfShape [PreservesLimitsOfShape J G] :
    CreatesLimitsOfShape J (proj X G) where
#align category_theory.structured_arrow.creates_limits_of_shape CategoryTheory.StructuredArrow.createsLimitsOfShape
-/

#print CategoryTheory.StructuredArrow.createsLimits /-
noncomputable instance createsLimits [PreservesLimits G] : CreatesLimits (proj X G : _) :=
  ⟨⟩
#align category_theory.structured_arrow.creates_limits CategoryTheory.StructuredArrow.createsLimits
-/

#print CategoryTheory.StructuredArrow.mono_right_of_mono /-
instance mono_right_of_mono [HasPullbacks A] [PreservesLimitsOfShape WalkingCospan G]
    {Y Z : StructuredArrow X G} (f : Y ⟶ Z) [Mono f] : Mono f.right :=
  show Mono ((proj X G).map f) from inferInstance
#align category_theory.structured_arrow.mono_right_of_mono CategoryTheory.StructuredArrow.mono_right_of_mono
-/

#print CategoryTheory.StructuredArrow.mono_iff_mono_right /-
theorem mono_iff_mono_right [HasPullbacks A] [PreservesLimitsOfShape WalkingCospan G]
    {Y Z : StructuredArrow X G} (f : Y ⟶ Z) : Mono f ↔ Mono f.right :=
  ⟨fun h => inferInstance, fun h => mono_of_mono_right f⟩
#align category_theory.structured_arrow.mono_iff_mono_right CategoryTheory.StructuredArrow.mono_iff_mono_right
-/

end StructuredArrow

namespace CostructuredArrow

variable {G : A ⥤ T} {X : T} (F : J ⥤ CostructuredArrow G X)

#print CategoryTheory.CostructuredArrow.hasColimit /-
instance hasColimit [i₁ : HasColimit (F ⋙ proj G X)] [i₂ : PreservesColimit (F ⋙ proj G X) G] :
    HasColimit F :=
  @Comma.hasColimit _ _ _ _ _ i₁ _ i₂
#align category_theory.costructured_arrow.has_colimit CategoryTheory.CostructuredArrow.hasColimit
-/

#print CategoryTheory.CostructuredArrow.hasColimitsOfShape /-
instance hasColimitsOfShape [HasColimitsOfShape J A] [PreservesColimitsOfShape J G] :
    HasColimitsOfShape J (CostructuredArrow G X) where
#align category_theory.costructured_arrow.has_colimits_of_shape CategoryTheory.CostructuredArrow.hasColimitsOfShape
-/

#print CategoryTheory.CostructuredArrow.hasColimits /-
instance hasColimits [HasColimits A] [PreservesColimits G] : HasColimits (CostructuredArrow G X) :=
  ⟨inferInstance⟩
#align category_theory.costructured_arrow.has_colimits CategoryTheory.CostructuredArrow.hasColimits
-/

#print CategoryTheory.CostructuredArrow.createsColimit /-
noncomputable instance createsColimit [i : PreservesColimit (F ⋙ proj G X) G] :
    CreatesColimit F (proj G X) :=
  createsColimitOfReflectsIso fun c t =>
    { liftedCocone := @Comma.coconeOfPreserves _ _ _ _ _ i t pUnitCocone
      makesColimit := Comma.coconeOfPreservesIsColimit _ _ pUnitCoconeIsColimit
      validLift := Cocones.ext (Iso.refl _) fun j => comp_id _ }
#align category_theory.costructured_arrow.creates_colimit CategoryTheory.CostructuredArrow.createsColimit
-/

#print CategoryTheory.CostructuredArrow.createsColimitsOfShape /-
noncomputable instance createsColimitsOfShape [PreservesColimitsOfShape J G] :
    CreatesColimitsOfShape J (proj G X) where
#align category_theory.costructured_arrow.creates_colimits_of_shape CategoryTheory.CostructuredArrow.createsColimitsOfShape
-/

#print CategoryTheory.CostructuredArrow.createsColimits /-
noncomputable instance createsColimits [PreservesColimits G] : CreatesColimits (proj G X : _) :=
  ⟨⟩
#align category_theory.costructured_arrow.creates_colimits CategoryTheory.CostructuredArrow.createsColimits
-/

#print CategoryTheory.CostructuredArrow.epi_left_of_epi /-
instance epi_left_of_epi [HasPushouts A] [PreservesColimitsOfShape WalkingSpan G]
    {Y Z : CostructuredArrow G X} (f : Y ⟶ Z) [Epi f] : Epi f.left :=
  show Epi ((proj G X).map f) from inferInstance
#align category_theory.costructured_arrow.epi_left_of_epi CategoryTheory.CostructuredArrow.epi_left_of_epi
-/

#print CategoryTheory.CostructuredArrow.epi_iff_epi_left /-
theorem epi_iff_epi_left [HasPushouts A] [PreservesColimitsOfShape WalkingSpan G]
    {Y Z : CostructuredArrow G X} (f : Y ⟶ Z) : Epi f ↔ Epi f.left :=
  ⟨fun h => inferInstance, fun h => epi_of_epi_left f⟩
#align category_theory.costructured_arrow.epi_iff_epi_left CategoryTheory.CostructuredArrow.epi_iff_epi_left
-/

end CostructuredArrow

end CategoryTheory


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Bhavik Mehta
-/

import category_theory.adjunction.reflective
import topology.category.Top
import topology.stone_cech
import category_theory.monad.limits
import topology.urysohns_lemma

/-!
# The category of Compact Hausdorff Spaces

We construct the category of compact Hausdorff spaces.
The type of compact Hausdorff spaces is denoted `CompHaus`, and it is endowed with a category
instance making it a full subcategory of `Top`.
The fully faithful functor `CompHaus ⥤ Top` is denoted `CompHaus_to_Top`.

**Note:** The file `topology/category/Compactum.lean` provides the equivalence between `Compactum`,
which is defined as the category of algebras for the ultrafilter monad, and `CompHaus`.
`Compactum_to_CompHaus` is the functor from `Compactum` to `CompHaus` which is proven to be an
equivalence of categories in `Compactum_to_CompHaus.is_equivalence`.
See `topology/category/Compactum.lean` for a more detailed discussion where these definitions are
introduced.

-/

universe u

open category_theory

/-- The type of Compact Hausdorff topological spaces. -/
structure CompHaus :=
(to_Top : Top)
[is_compact : compact_space to_Top]
[is_hausdorff : t2_space to_Top]

namespace CompHaus

instance : inhabited CompHaus := ⟨{to_Top := { α := pempty }}⟩

instance : has_coe_to_sort CompHaus Type* := ⟨λ X, X.to_Top⟩
instance {X : CompHaus} : compact_space X := X.is_compact
instance {X : CompHaus} : t2_space X := X.is_hausdorff

instance category : category CompHaus := induced_category.category to_Top

instance concrete_category : concrete_category CompHaus :=
induced_category.concrete_category _

@[simp]
lemma coe_to_Top {X : CompHaus} : (X.to_Top : Type*) = X :=
rfl

variables (X : Type*) [topological_space X] [compact_space X] [t2_space X]

/-- A constructor for objects of the category `CompHaus`,
taking a type, and bundling the compact Hausdorff topology
found by typeclass inference. -/
def of : CompHaus :=
{ to_Top := Top.of X,
  is_compact := ‹_›,
  is_hausdorff := ‹_› }

@[simp] lemma coe_of : (CompHaus.of X : Type _) = X := rfl

/-- Any continuous function on compact Hausdorff spaces is a closed map. -/
lemma is_closed_map {X Y : CompHaus.{u}} (f : X ⟶ Y) : is_closed_map f :=
λ C hC, (hC.is_compact.image f.continuous).is_closed

/-- Any continuous bijection of compact Hausdorff spaces is an isomorphism. -/
lemma is_iso_of_bijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : function.bijective f) :
  is_iso f :=
begin
  let E := equiv.of_bijective _ bij,
  have hE : continuous E.symm,
  { rw continuous_iff_is_closed,
    intros S hS,
    rw ← E.image_eq_preimage,
    exact is_closed_map f S hS },
  refine ⟨⟨⟨E.symm, hE⟩, _, _⟩⟩,
  { ext x,
    apply E.symm_apply_apply },
  { ext x,
    apply E.apply_symm_apply }
end

/-- Any continuous bijection of compact Hausdorff spaces induces an isomorphism. -/
noncomputable
def iso_of_bijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : function.bijective f) : X ≅ Y :=
by letI := is_iso_of_bijective _ bij; exact as_iso f

end CompHaus

/-- The fully faithful embedding of `CompHaus` in `Top`. -/
@[simps {rhs_md := semireducible}, derive [full, faithful]]
def CompHaus_to_Top : CompHaus.{u} ⥤ Top.{u} := induced_functor _

instance CompHaus.forget_reflects_isomorphisms : reflects_isomorphisms (forget CompHaus.{u}) :=
⟨by introsI A B f hf; exact CompHaus.is_iso_of_bijective _ ((is_iso_iff_bijective f).mp hf)⟩

/--
(Implementation) The object part of the compactification functor from topological spaces to
compact Hausdorff spaces.
-/
@[simps]
def StoneCech_obj (X : Top) : CompHaus := CompHaus.of (stone_cech X)

/--
(Implementation) The bijection of homsets to establish the reflective adjunction of compact
Hausdorff spaces in topological spaces.
-/
noncomputable def stone_cech_equivalence (X : Top.{u}) (Y : CompHaus.{u}) :
  (StoneCech_obj X ⟶ Y) ≃ (X ⟶ CompHaus_to_Top.obj Y) :=
{ to_fun := λ f,
  { to_fun := f ∘ stone_cech_unit,
    continuous_to_fun := f.2.comp (@continuous_stone_cech_unit X _) },
  inv_fun := λ f,
  { to_fun := stone_cech_extend f.2,
    continuous_to_fun := continuous_stone_cech_extend f.2 },
  left_inv :=
  begin
    rintro ⟨f : stone_cech X ⟶ Y, hf : continuous f⟩,
    ext (x : stone_cech X),
    refine congr_fun _ x,
    apply continuous.ext_on dense_range_stone_cech_unit (continuous_stone_cech_extend _) hf,
    rintro _ ⟨y, rfl⟩,
    apply congr_fun (stone_cech_extend_extends (hf.comp _)) y,
  end,
  right_inv :=
  begin
    rintro ⟨f : (X : Type*) ⟶ Y, hf : continuous f⟩,
    ext,
    exact congr_fun (stone_cech_extend_extends hf) _,
  end }

/--
The Stone-Cech compactification functor from topological spaces to compact Hausdorff spaces,
left adjoint to the inclusion functor.
-/
noncomputable def Top_to_CompHaus : Top.{u} ⥤ CompHaus.{u} :=
adjunction.left_adjoint_of_equiv stone_cech_equivalence.{u} (λ _ _ _ _ _, rfl)

lemma Top_to_CompHaus_obj (X : Top) : ↥(Top_to_CompHaus.obj X) = stone_cech X :=
rfl

/--
The category of compact Hausdorff spaces is reflective in the category of topological spaces.
-/
noncomputable instance CompHaus_to_Top.reflective : reflective CompHaus_to_Top :=
{ to_is_right_adjoint := ⟨Top_to_CompHaus, adjunction.adjunction_of_equiv_left _ _⟩ }

noncomputable instance CompHaus_to_Top.creates_limits : creates_limits CompHaus_to_Top :=
monadic_creates_limits _

instance CompHaus.has_limits : limits.has_limits CompHaus :=
has_limits_of_has_limits_creates_limits CompHaus_to_Top

instance CompHaus.has_colimits : limits.has_colimits CompHaus :=
has_colimits_of_reflective CompHaus_to_Top

namespace CompHaus

/-- An explicit limit cone for a functor `F : J ⥤ CompHaus`, defined in terms of
`Top.limit_cone`. -/
def limit_cone {J : Type u} [small_category J] (F : J ⥤ CompHaus.{u}) :
  limits.cone F :=
{ X :=
  { to_Top := (Top.limit_cone (F ⋙ CompHaus_to_Top)).X,
    is_compact := begin
      show compact_space ↥{u : Π j, (F.obj j) | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j},
      rw ← is_compact_iff_compact_space,
      apply is_closed.is_compact,
      have : {u : Π j, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j} =
        ⋂ (i j : J) (f : i ⟶ j), {u | F.map f (u i) = u j},
      { ext1, simp only [set.mem_Inter, set.mem_set_of_eq], },
      rw this,
      apply is_closed_Inter, intros i,
      apply is_closed_Inter, intros j,
      apply is_closed_Inter, intros f,
      apply is_closed_eq,
      { exact (continuous_map.continuous (F.map f)).comp (continuous_apply i), },
      { exact continuous_apply j, }
    end,
    is_hausdorff :=
      show t2_space ↥{u : Π j, (F.obj j) | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j},
      from infer_instance },
  π :=
  { app := λ j, (Top.limit_cone (F ⋙ CompHaus_to_Top)).π.app j,
    naturality' := by { intros _ _ _, ext ⟨x, hx⟩,
      simp only [comp_apply, functor.const.obj_map, id_apply], exact (hx f).symm, } } }

/-- The limit cone `CompHaus.limit_cone F` is indeed a limit cone. -/
def limit_cone_is_limit {J : Type u} [small_category J] (F : J ⥤ CompHaus.{u}) :
  limits.is_limit (limit_cone F) :=
{ lift := λ S,
    (Top.limit_cone_is_limit (F ⋙ CompHaus_to_Top)).lift (CompHaus_to_Top.map_cone S),
  uniq' := λ S m h, (Top.limit_cone_is_limit _).uniq (CompHaus_to_Top.map_cone S) _ h }

lemma epi_iff_surjective {X Y : CompHaus.{u}} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  split,
  { contrapose!,
    rintros ⟨y, hy⟩ hf,
    let C := set.range f,
    have hC : is_closed C := (is_compact_range f.continuous).is_closed,
    let D := {y},
    have hD : is_closed D := is_closed_singleton,
    have hCD : disjoint C D,
    { rw set.disjoint_singleton_right, rintro ⟨y', hy'⟩, exact hy y' hy' },
    haveI : normal_space ↥(Y.to_Top) := normal_of_compact_t2,
    obtain ⟨φ, hφ0, hφ1, hφ01⟩ := exists_continuous_zero_one_of_closed hC hD hCD,
    haveI : compact_space (ulift.{u} $ set.Icc (0:ℝ) 1) := homeomorph.ulift.symm.compact_space,
    haveI : t2_space (ulift.{u} $ set.Icc (0:ℝ) 1) := homeomorph.ulift.symm.t2_space,
    let Z := of (ulift.{u} $ set.Icc (0:ℝ) 1),
    let g : Y ⟶ Z := ⟨λ y', ⟨⟨φ y', hφ01 y'⟩⟩,
      continuous_ulift_up.comp (continuous_subtype_mk (λ y', hφ01 y') φ.continuous)⟩,
    let h : Y ⟶ Z := ⟨λ _, ⟨⟨0, set.left_mem_Icc.mpr zero_le_one⟩⟩, continuous_const⟩,
    have H : h = g,
    { rw ← cancel_epi f,
      ext x, dsimp,
      simp only [comp_apply, continuous_map.coe_mk, subtype.coe_mk, hφ0 (set.mem_range_self x),
        pi.zero_apply], },
    apply_fun (λ e, (e y).down) at H,
    dsimp at H,
    simp only [subtype.mk_eq_mk, hφ1 (set.mem_singleton y), pi.one_apply] at H,
    exact zero_ne_one H, },
  { rw ← category_theory.epi_iff_surjective,
    apply faithful_reflects_epi (forget CompHaus) },
end

lemma mono_iff_injective {X Y : CompHaus.{u}} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  split,
  { introsI hf x₁ x₂ h,
    let g₁ : of punit ⟶ X := ⟨λ _, x₁, continuous_of_discrete_topology⟩,
    let g₂ : of punit ⟶ X := ⟨λ _, x₂, continuous_of_discrete_topology⟩,
    have : g₁ ≫ f = g₂ ≫ f, by { ext, exact h },
    rw cancel_mono at this,
    apply_fun (λ e, e punit.star) at this,
    exact this },
  { rw ← category_theory.mono_iff_injective,
    apply faithful_reflects_mono (forget CompHaus) }
end

end CompHaus


import tactic
import recording_tableau

/-

RSK (Robinson-Schensted-Knuth) Insertion

Given a biword w (list (ℕ × ℕ) sorted in lex order), we create two semistandard
Young tableaux (ssyt) of the same shape (ν : young_diagram), called the
`insertion / bumping tableau B` and `recording tableau R`.

These are defined inductively by inserting the next value ((w.nth n).2) into the
insertion tableau using [ssyt.row_bump], then placing a value ((w.nth n).1)
into the recording tableau in the outer corner that resulted [ssyt.row_bump.1].

The inductive definition is [ssyt.rsk_inductive] (you may be surprised to see
that it has two base cases. It feels like only one should be necessary!)

The actual definition is [rsk], which has the signature
*   rsk : Π (w : list (lex (ℕ × ℕ))), w.sorted (≤) →
          Σ (μ : young_diagram), ssyt μ × ssyt μ

Currently the only additional facts proven
are the size and weights of the resulting tableaux.
  [rsk_size] [rsk_wtR] [rsk_wtB]

The next goal is to show that [rsk] is a bijection.
-/

section biword

abbreviation rsk_le := (prod.lex.has_le ℕ ℕ).le

lemma rsk_mono_iff {x y : lex (ℕ × ℕ)} {w : list (lex (ℕ × ℕ))} :
  (x :: y :: w).sorted (≤) ↔
  (x.1 < y.1 ∨ x.1 = y.1 ∧ x.2 ≤ y.2) ∧ (y :: w).sorted (≤) :=
begin
  repeat {rw list.sorted_cons at *},
  split; intro h,
  { exact ⟨(prod.lex_def _ _).mp (h.1 y (or.inl rfl)), h.2⟩ },
  { split, rotate, exact h.2,
    intros b hb,
    apply @le_trans _ _ _ y _ ((prod.lex_def _ _).mpr h.1),
    cases hb, exact le_of_eq hb.symm, exact h.2.1 b hb },
end

def wtR (w : list (lex (ℕ × ℕ))) (val : ℕ) : ℕ :=
list.count val $ w.map prod.fst

def wtB (w : list (lex (ℕ × ℕ))) (val : ℕ) : ℕ :=
list.count val $ w.map prod.snd

lemma wtR_cons (x : lex (ℕ × ℕ)) (w : list (lex (ℕ × ℕ))) (val : ℕ) :
  wtR (x :: w) val = ite (val = x.1) 1 0 + wtR w val :=
begin
  unfold wtR,
  rw [list.map_cons, list.count_cons, ite_add, zero_add, add_comm],
end

lemma wtB_cons (x : lex (ℕ × ℕ)) (w : list (lex (ℕ × ℕ))) (val : ℕ) :
  wtB (x :: w) val = ite (val = x.2) 1 0 + wtB w val :=
begin
  unfold wtB,
  rw [list.map_cons, list.count_cons, ite_add, zero_add, add_comm],
end

end biword

section rsk_inductive

def ssyt.rec_cert.rsk_step
  {μ : young_diagram} {R B : ssyt μ} (rcert : ssyt.rec_cert R B) :
  Σ (ν : young_diagram), ssyt ν × ssyt ν :=
⟨_, ⟨rcert.rec_step, (B.row_bump rcert.bumpval).2⟩⟩

def ssyt.rec_cert.rsk_inductive :
  Π {μ : young_diagram} {R B : ssyt μ} (rcert : ssyt.rec_cert R B)
  (w : list (lex (ℕ × ℕ)))
  (hw : ((rcert.recval, rcert.bumpval) :: w).sorted rsk_le),
Σ {ν : young_diagram}, ssyt ν × ssyt ν
| μ R B rcert [] _ :=
  ⟨_, ⟨rcert.rsk_step.2.1, rcert.rsk_step.2.2⟩⟩
| μ R B rcert ((recval', bumpval') :: xs) hw :=
  ssyt.rec_cert.rsk_inductive
    (rcert.next_cert recval' bumpval' (rsk_mono_iff.mp hw).1)
    xs (rsk_mono_iff.mp hw).2

lemma ssyt.rec_cert.rsk_inductive_size :
  Π {μ : young_diagram} {R B : ssyt μ} (rcert : ssyt.rec_cert R B)
  (w : list (lex (ℕ × ℕ)))
  (hw : ((rcert.recval, rcert.bumpval) :: w).sorted rsk_le),
  (rcert.rsk_inductive w hw).1.size =
  μ.size + 1 + w.length
| μ R B rcert [] _ := by apply B.row_bump_size
| μ R B rcert ((recval', bumpval') :: xs) hw := begin
  rw ssyt.rec_cert.rsk_inductive,
  rw [ssyt.rec_cert.rsk_inductive_size, add_assoc, add_comm 1],
  rw [B.row_bump_size rcert.bumpval, list.length_cons],
end

lemma ssyt.rec_cert.rsk_inductive_wtR :
  Π {μ : young_diagram} {R B : ssyt μ} (rcert : ssyt.rec_cert R B)
  (w : list (lex (ℕ × ℕ)))
  (hw : ((rcert.recval, rcert.bumpval) :: w).sorted rsk_le)
  (val : ℕ),
  (rcert.rsk_inductive w hw).2.1.wt val =
  R.wt val + (ite (val = rcert.recval) 1 0) + wtR w val
| μ R B rcert [] _ val := begin
  unfold wtR, rw [list.map_nil, list.count_nil, add_zero],
  exact rcert.rec_wt val,
end
| μ R B rcert ((recval', bumpval') :: xs) hw val := begin
  rw [← rcert.rec_wt val, wtR_cons, ← add_assoc],
  rw ssyt.rec_cert.rsk_inductive,
  rw ssyt.rec_cert.rsk_inductive_wtR, refl,
end

lemma ssyt.rec_cert.rsk_inductive_wtB :
  Π {μ : young_diagram} {R B : ssyt μ} (rcert : ssyt.rec_cert R B)
  (w : list (lex (ℕ × ℕ)))
  (hw : ((rcert.recval, rcert.bumpval) :: w).sorted rsk_le)
  (val : ℕ),
  (rcert.rsk_inductive w hw).2.2.wt val =
  B.wt val + (ite (val = rcert.bumpval) 1 0) + wtB w val
| μ R B rcert [] _ val := begin
  unfold wtB, rw [list.map_nil, list.count_nil, add_zero],
  exact B.row_bump_wt _ val,
end
| μ R B rcert ((recval', bumpval') :: xs) hw val := begin
  rw [← B.row_bump_wt _ val, wtB_cons, ← add_assoc],
  rw ssyt.rec_cert.rsk_inductive,
  rw ssyt.rec_cert.rsk_inductive_wtB, refl,
end

end rsk_inductive

section rsk

def rsk_start_cert (recval bumpval : ℕ) : ssyt.rec_cert T_empty T_empty :=
{ recval := recval, bumpval := bumpval,
  rec_le := λ _ _, nat.zero_le _,
  rec_eq_left := λ _ _ cell _, false.rec _ cell }

def rsk :
  Π (w : list (lex (ℕ × ℕ))), w.sorted (≤) →
  Σ (μ : young_diagram), ssyt μ × ssyt μ
| [] _ := ⟨∅, ∅, ∅⟩
| [(recval, bumpval)] _ :=
  (rsk_start_cert recval bumpval).rsk_step
| ((recval, bumpval) :: rb' :: xs) hw :=
  (rsk_start_cert recval bumpval).rsk_inductive (rb' :: xs) hw

lemma rsk_size :
  Π (w : list (lex (ℕ × ℕ))) (hw : w.sorted (≤)),
  (rsk w hw).1.size = w.length
| [] _ := rfl
| [(recval, bumpval)] _ := by apply young_diagram.outer_corner.add_size
| ((recval, bumpval) :: rb' :: xs) hw := by {
  rw [rsk, ssyt.rec_cert.rsk_inductive_size,
      μ_empty_size, zero_add, add_comm], refl,
}

lemma rsk_wtR :
  Π (w : list (lex (ℕ × ℕ))) (hw : w.sorted (≤)) (val : ℕ),
  (rsk w hw).2.1.wt val = wtR w val
| [] _ val := rfl
| [(recval, bumpval)] _ val := begin
  rw [rsk, ssyt.rec_cert.rsk_step, ssyt.rec_cert.rec_wt, T_empty_wt, zero_add],
  refl,
end
| ((recval, bumpval) :: rb' :: xs) hw val := by {
  rw [wtR_cons, rsk, ssyt.rec_cert.rsk_inductive_wtR, T_empty_wt, zero_add],
  refl,
}

lemma rsk_wtB :
  Π (w : list (lex (ℕ × ℕ))) (hw : w.sorted (≤)) (val : ℕ),
  (rsk w hw).2.2.wt val = wtB w val
| [] _ val := rfl
| [(recval, bumpval)] _ val := begin
  rw [rsk, ssyt.rec_cert.rsk_step, ssyt.row_bump_wt, T_empty_wt, zero_add],
  refl,
end
| ((recval, bumpval) :: rb' :: xs) hw val := by {
  rw [wtB_cons, rsk, ssyt.rec_cert.rsk_inductive_wtB, T_empty_wt, zero_add],
  refl,
}

end rsk

section examples

def rsk.ex0 : list (lex (ℕ × ℕ)) :=
  [(1, 1), (1, 3), (1, 3), (2, 2), (2, 2), (3, 1), (3, 2)]

lemma rsk.ex0_sorted : rsk.ex0.sorted rsk_le :=
begin
  rw rsk.ex0, repeat {rw rsk_mono_iff}, simp,
end

def rsk.ex0_μ : young_diagram := (rsk rsk.ex0 rsk.ex0_sorted).1
def rsk.ex0_R : ssyt rsk.ex0_μ := (rsk rsk.ex0 rsk.ex0_sorted).2.1
def rsk.ex0_B : ssyt rsk.ex0_μ := (rsk rsk.ex0 rsk.ex0_sorted).2.2

#eval rsk.ex0_μ
#eval rsk.ex0_R
#eval rsk.ex0_B

end examples


import algebra.homology.single
import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.finite

noncomputable theory

open category_theory category_theory.limits
  category_theory.category

namespace category_theory.limits

lemma is_limit.of_is_zero {J C : Type*} [category J] [category C] [has_zero_object C]
  [has_zero_morphisms C]
  (F : J ⥤ C) (hF : is_zero F) (c : cone F) (hc : is_zero c.X) : is_limit c :=
{ lift := λ s, 0,
  fac' := λ s j, (F.is_zero_iff.1 hF j).eq_of_tgt _ _,
  uniq' := λ s m hm, hc.eq_of_tgt _ _, }

lemma preserves_limits_of_shape_of_is_zero {J C D : Type*}
  [category J] [category C] [category D] [has_zero_object D] [has_zero_morphisms D]
  (G : C ⥤ D) (hG : is_zero G) :
  preserves_limits_of_shape J G :=
⟨λ F, ⟨λ c hc, begin
  rw functor.is_zero_iff at hG,
  apply is_limit.of_is_zero,
  { rw functor.is_zero_iff,
    exact λ X, hG _, },
  { exact hG c.X, },
end⟩⟩

lemma is_colimit.of_is_zero {J C : Type*} [category J] [category C] [has_zero_object C]
  [has_zero_morphisms C]
  (F : J ⥤ C) (hF : is_zero F) (c : cocone F) (hc : is_zero c.X) : is_colimit c :=
{ desc := λ s, 0,
  fac' := λ s j, (F.is_zero_iff.1 hF j).eq_of_src _ _,
  uniq' := λ s m hm, hc.eq_of_src _ _, }

lemma preserves_colimits_of_shape_of_is_zero {J C D : Type*}
  [category J] [category C] [category D] [has_zero_object D] [has_zero_morphisms D]
  (G : C ⥤ D) (hG : is_zero G):
  preserves_colimits_of_shape J G :=
⟨λ F, ⟨λ c hc, begin
  rw functor.is_zero_iff at hG,
  apply is_colimit.of_is_zero,
  { rw functor.is_zero_iff,
    exact λ X, hG _, },
  { exact hG c.X, },
end⟩⟩

end category_theory.limits

open category_theory category_theory.limits
  category_theory.category

namespace homological_complex

variables (C : Type*) {ι J : Type*} [category C] [category J] [has_zero_morphisms C]
  (c : complex_shape ι) (F : J ⥤ homological_complex C c)

def single_nat_iso_self [has_zero_object C] [decidable_eq ι] (i : ι) :
  single C c i ⋙ eval C c i ≅ 𝟭 C :=
nat_iso.of_components (λ A, single_obj_X_self C c i A) (by tidy)

lemma is_zero_single_comp_eval_of_neq [has_zero_object C] [decidable_eq ι] (i j : ι) (h : i ≠ j) :
  is_zero (single C c i ⋙ eval C c j) :=
begin
  rw functor.is_zero_iff,
  intro A,
  dsimp,
  rw if_neg,
  { exact limits.is_zero_zero C, },
  { tauto, },
end

variables {C c}

namespace limits

section

variables [∀ (n : ι), has_limit (F ⋙ homological_complex.eval C c n)]

@[protected, simps]
def cone_of_limit_eval : cone F :=
{ X :=
  { X := λ n, limit (F ⋙ homological_complex.eval C c n),
    d := λ n m, lim_map { app := λ j, (F.obj j).d n m, },
    shape' := λ n m h, begin
      ext j,
      simp only [lim_map_π, zero_comp, (F.obj j).shape _ _ h, comp_zero],
    end, },
  π :=
  { app := λ j,
    { f := λ n, limit.π _ j, },
    naturality' := λ i j φ, begin
      ext n,
      dsimp,
      erw [limit.w, id_comp],
    end, }, }

lemma is_limit_cone : is_limit (cone_of_limit_eval F) :=
{ lift := λ s,
  { f := λ n, limit.lift _ ((eval C c n).map_cone s), },
  uniq' := λ s m hm, begin
    ext n j,
    simp only [limit.lift_π, functor.map_cone_π_app, eval_map,
      ← hm, comp_f, cone_of_limit_eval_π_app_f],
  end, }

instance : has_limit F := ⟨⟨⟨ _, is_limit_cone F⟩⟩⟩

instance (n : ι) : preserves_limit F (homological_complex.eval C c n) :=
preserves_limit_of_preserves_limit_cone (is_limit_cone F)
  (is_limit.of_iso_limit (limit.is_limit _)
    (cones.ext (iso.refl _) (by tidy)))

end

section

variables [∀ (n : ι), has_colimit (F ⋙ homological_complex.eval C c n)]

@[simps]
def cocone_of_colimit_eval : cocone F :=
{ X :=
  { X := λ n, colimit (F ⋙ homological_complex.eval C c n),
    d:= λ n m, colim_map { app := λ j, (F.obj j).d n m, },
    shape' := λ n m h, begin
      ext j,
      simp only [ι_colim_map, comp_zero, (F.obj j).shape _ _ h, zero_comp],
    end, },
  ι :=
  { app := λ j,
    { f := λ n, colimit.ι (F ⋙ eval C c n) j, },
    naturality' := λ i j φ, begin
      ext n,
      dsimp,
      rw [comp_id],
      exact colimit.w (F ⋙ eval C c n) φ,
    end, }, }

lemma is_colimit_cocone : is_colimit (cocone_of_colimit_eval F) :=
{ desc := λ s,
  { f := λ n, colimit.desc _ ((eval C c n).map_cocone s), },
  uniq' := λ s m hm, begin
    ext n j,
    simp only [←hm, functor.map_cocone_ι_app, eval_map, colimit.ι_desc, comp_f,
      cocone_of_colimit_eval_ι_app_f],
  end, }

instance : has_colimit F := ⟨⟨⟨ _, is_colimit_cocone F⟩⟩⟩

instance (n : ι) : preserves_colimit F (homological_complex.eval C c n) :=
preserves_colimit_of_preserves_colimit_cocone (is_colimit_cocone F)
  (is_colimit.of_iso_colimit (colimit.is_colimit _)
    (cocones.ext (iso.refl _) (by tidy)))

end

instance [has_limits_of_shape J C] :
  has_limits_of_shape J (homological_complex C c) :=
⟨λ F, infer_instance⟩

instance [has_colimits_of_shape J C] :
  has_colimits_of_shape J (homological_complex C c) :=
⟨λ F, infer_instance⟩

instance [has_limits_of_shape J C] (n : ι) :
  preserves_limits_of_shape J (homological_complex.eval C c n) :=
⟨λ F, infer_instance⟩

instance [has_colimits_of_shape J C] (n : ι) :
  preserves_colimits_of_shape J (homological_complex.eval C c n) :=
⟨λ F, infer_instance⟩

instance [has_finite_limits C] :
  has_finite_limits (homological_complex C c) :=
⟨λ J, begin
  introI,
  introI,
  apply_instance,
end⟩

instance [has_finite_colimits C] :
  has_finite_colimits (homological_complex C c) :=
⟨λ J, begin
  introI,
  introI,
  apply_instance,
end⟩

instance [has_finite_limits C] (n : ι) :
  preserves_finite_limits (homological_complex.eval C c n) :=
⟨λ J, begin
  introI,
  introI,
  apply_instance,
end⟩

instance [has_finite_colimits C] (n : ι) :
  preserves_finite_colimits (homological_complex.eval C c n) :=
⟨λ J, begin
  introI,
  introI,
  apply_instance,
end⟩

instance [has_finite_products C] :
  has_finite_products (homological_complex C c) :=
⟨λ n, infer_instance⟩

instance [has_finite_coproducts C] :
  has_finite_coproducts (homological_complex C c) :=
⟨λ n, infer_instance⟩

variable {F}

def is_limit_of_eval (s : limits.cone F) [has_limits_of_shape J C]
  (hs : ∀ (i : ι), is_limit ((eval C c i).map_cone s)) : is_limit s :=
{ lift := λ t,
  { f := λ i, (hs i).lift ((eval C c i).map_cone t),
    comm' := λ i i' hii', is_limit.hom_ext (hs i') (begin
      intro j,
      have eq := λ i, (hs i).fac ((eval C c i).map_cone t),
      simp only [functor.map_cone_π_app, eval_map] at eq,
      simp only [functor.map_cone_π_app, eval_map, assoc],
      rw [eq i', ← hom.comm, reassoc_of (eq i), hom.comm],
    end), },
  fac' := λ t j, begin
    ext i,
    simp only [comp_f],
    apply (hs i).fac,
  end,
  uniq' := λ t m hm, begin
    ext i,
    exact (hs i).uniq ((eval C c i).map_cone t) (m.f i)
      (λ j, congr_fun (congr_arg homological_complex.hom.f (hm j)) i),
  end, }

def preserves_limits_of_shape_of_eval {D : Type*} [category D]
  (G : D ⥤ homological_complex C c) [has_limits_of_shape J C]
  (hG : Π (i : ι), preserves_limits_of_shape J (G ⋙ eval C c i)) :
  preserves_limits_of_shape J G :=
⟨λ F, ⟨λ s hs, is_limit_of_eval _ (λ i, begin
  let hs' := is_limit_of_preserves (G ⋙ eval C c i) hs,
  exact hs',
end)⟩⟩

def is_colimit_of_eval (s : limits.cocone F) [has_colimits_of_shape J C]
  (hs : ∀ (i : ι), is_colimit ((eval C c i).map_cocone s)) : is_colimit s :=
{ desc := λ t,
  { f := λ i, (hs i).desc ((eval C c i).map_cocone t),
    comm' := λ i i' hii', is_colimit.hom_ext (hs i) begin
      intro j,
      have eq := λ i, (hs i).fac ((eval C c i).map_cocone t),
      simp only [functor.map_cocone_ι_app, eval_map] at eq,
      simp only [functor.map_cocone_ι_app, eval_map, hom.comm_assoc],
      rw [eq i', reassoc_of (eq i), hom.comm],
    end, },
  fac' := λ t j, begin
    ext i,
    simp only [comp_f],
    apply (hs i).fac,
  end,
  uniq' := λ t m hm, begin
    ext i,
    exact (hs i).uniq ((eval C c i).map_cocone t) (m.f i)
      (λ j, congr_fun (congr_arg homological_complex.hom.f (hm j)) i),
  end, }

def preserves_colimits_of_shape_of_eval {D : Type*} [category D]
  (G : D ⥤ homological_complex C c) [has_colimits_of_shape J C]
  (hG : Π (i : ι), preserves_colimits_of_shape J (G ⋙ eval C c i)) :
  preserves_colimits_of_shape J G :=
⟨λ F, ⟨λ s hs, is_colimit_of_eval _ (λ i, begin
  let hs' := is_colimit_of_preserves (G ⋙ eval C c i) hs,
  exact hs',
end)⟩⟩

variables [has_zero_object C] [decidable_eq ι]

instance [has_zero_object C] [has_limits_of_shape J C] (i : ι) :
  preserves_limits_of_shape J (single C c i) :=
preserves_limits_of_shape_of_eval _ (λ i', begin
  by_cases i = i',
  { subst h,
    exact preserves_limits_of_shape_of_nat_iso (single_nat_iso_self C c i).symm, },
  { apply limits.preserves_limits_of_shape_of_is_zero,
    exact is_zero_single_comp_eval_of_neq C c i i' h, },
end)

instance [has_zero_object C] [has_colimits_of_shape J C] (i : ι) :
  preserves_colimits_of_shape J (single C c i) :=
preserves_colimits_of_shape_of_eval _ (λ i', begin
  by_cases i = i',
  { subst h,
    exact preserves_colimits_of_shape_of_nat_iso (single_nat_iso_self C c i).symm, },
  { apply limits.preserves_colimits_of_shape_of_is_zero,
    exact is_zero_single_comp_eval_of_neq C c i i' h, },
end)

instance [has_finite_limits C] (i : ι) : preserves_finite_limits (single C c i) :=
⟨λ J, by { introI, introI, apply_instance, }⟩

instance [has_finite_colimits C] (i : ι) : preserves_finite_colimits (single C c i) :=
⟨λ J, by { introI, introI, apply_instance, }⟩

end limits

end homological_complex


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ring
import Mathlib.data.num.lemmas
import Mathlib.data.tree
import Mathlib.PostPort

universes u_1 l

namespace Mathlib

/-!
# ring2

An experimental variant on the `ring` tactic that uses computational
reflection instead of proof generation. Useful for kernel benchmarking.
-/

namespace tree

/-- `(reflect' t u α)` quasiquotes a tree `(t: tree expr)` of quoted
values of type `α` at level `u` into an `expr` which reifies to a `tree α`
containing the reifications of the `expr`s from the original `t`. -/
/-- Returns an element indexed by `n`, or zero if `n` isn't a valid index.
See `tree.get`. -/
protected def get_or_zero {α : Type u_1} [HasZero α] (t : tree α) (n : pos_num) : α :=
  get_or_else n t 0

end tree

namespace tactic.ring2

/-- A reflected/meta representation of an expression in a commutative
semiring. This representation is a direct translation of such
expressions - see `horner_expr` for a normal form. -/
/- (atom n) is an opaque element of the csring. For example,
inductive csring_expr
where
| atom : pos_num → csring_expr
| const : num → csring_expr
| add : csring_expr → csring_expr → csring_expr
| mul : csring_expr → csring_expr → csring_expr
| pow : csring_expr → num → csring_expr

a local variable in the context. n indexes into a storage
of such atoms - a `tree α`. -/

/- (const n) is technically the csring's one, added n times.
Or the zero if n is 0. -/

namespace csring_expr

protected instance inhabited : Inhabited csring_expr :=
  { default := const 0 }

/-- Evaluates a reflected `csring_expr` into an element of the
original `comm_semiring` type `α`, retrieving opaque elements
(atoms) from the tree `t`. -/
def eval {α : Type u_1} [comm_semiring α] (t : tree α) : csring_expr → α :=
  sorry

end csring_expr

/-- An efficient representation of expressions in a commutative
semiring using the sparse Horner normal form. This type admits
non-optimal instantiations (e.g. `P` can be represented as `P+0+0`),
so to get good performance out of it, care must be taken to maintain
an optimal, *canonical* form. -/
/- (const n) is a constant n in the csring, similarly to the same
inductive horner_expr
where
| const : znum → horner_expr
| horner : horner_expr → pos_num → num → horner_expr → horner_expr

constructor in `csring_expr`. This one, however, can be negative. -/

/- (horner a x n b) is a*xⁿ + b, where x is the x-th atom
in the atom tree. -/

namespace horner_expr

/-- True iff the `horner_expr` argument is a valid `csring_expr`.
For that to be the case, all its constants must be non-negative. -/
def is_cs : horner_expr → Prop :=
  sorry

protected instance has_zero : HasZero horner_expr :=
  { zero := const 0 }

protected instance has_one : HasOne horner_expr :=
  { one := const 1 }

protected instance inhabited : Inhabited horner_expr :=
  { default := 0 }

/-- Represent a `csring_expr.atom` in Horner form. -/
def atom (n : pos_num) : horner_expr :=
  horner 1 n 1 0

def to_string : horner_expr → string :=
  sorry

protected instance has_to_string : has_to_string horner_expr :=
  has_to_string.mk to_string

/-- Alternative constructor for (horner a x n b) which maintains canonical
form by simplifying special cases of `a`. -/
def horner' (a : horner_expr) (x : pos_num) (n : num) (b : horner_expr) : horner_expr :=
  sorry

def add_const (k : znum) (e : horner_expr) : horner_expr :=
  ite (k = 0) e
    (horner_expr.rec (fun (n : znum) => const (k + n))
      (fun (a : horner_expr) (x : pos_num) (n : num) (b A B : horner_expr) => horner a x n B) e)

def add_aux (a₁ : horner_expr) (A₁ : horner_expr → horner_expr) (x₁ : pos_num) : horner_expr → num → horner_expr → (horner_expr → horner_expr) → horner_expr :=
  sorry

def add : horner_expr → horner_expr → horner_expr :=
  sorry

/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact add_const n₁ e₂ },
  exact match e₂ with e₂ := begin
    induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁;
    let e₁ := horner a₁ x₁ n₁ b₁,
    { exact add_const n₂ e₁ },
    let e₂ := horner a₂ x₂ n₂ b₂,
    exact match pos_num.cmp x₁ x₂ with
    | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
    | ordering.gt := horner a₂ x₂ n₂ (B₂ n₁ b₁)
    | ordering.eq :=
      match num.sub' n₁ n₂ with
      | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
      | (znum.pos k) := horner (A₂ k 0) x₁ n₂ (B₁ b₂)
      | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
      end
    end
  end end
end-/

def neg (e : horner_expr) : horner_expr :=
  horner_expr.rec (fun (n : znum) => const (-n))
    (fun (a : horner_expr) (x : pos_num) (n : num) (b A B : horner_expr) => horner A x n B) e

def mul_const (k : znum) (e : horner_expr) : horner_expr :=
  ite (k = 0) 0
    (ite (k = 1) e
      (horner_expr.rec (fun (n : znum) => const (n * k))
        (fun (a : horner_expr) (x : pos_num) (n : num) (b A B : horner_expr) => horner A x n B) e))

def mul_aux (a₁ : horner_expr) (x₁ : pos_num) (n₁ : num) (b₁ : horner_expr) (A₁ : horner_expr → horner_expr) (B₁ : horner_expr → horner_expr) : horner_expr → horner_expr :=
  sorry

def mul : horner_expr → horner_expr → horner_expr :=
  sorry

/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact mul_const n₁ e₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂;
  let e₁ := horner a₁ x₁ n₁ b₁,
  { exact mul_const n₂ e₁ },
  let e₂ := horner a₂ x₂ n₂ b₂,
  cases pos_num.cmp x₁ x₂,
  { exact horner (A₁ e₂) x₁ n₁ (B₁ e₂) },
  { let haa := horner' A₂ x₁ n₂ 0,
    exact if b₂ = 0 then haa else
      haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂)) },
  { exact horner A₂ x₂ n₂ B₂ }
end-/

protected instance has_add : Add horner_expr :=
  { add := add }

protected instance has_neg : Neg horner_expr :=
  { neg := neg }

protected instance has_mul : Mul horner_expr :=
  { mul := mul }

def pow (e : horner_expr) : num → horner_expr :=
  sorry

def inv (e : horner_expr) : horner_expr :=
  0

/-- Brings expressions into Horner normal form. -/
def of_csexpr : csring_expr → horner_expr :=
  sorry

/-- Evaluates a reflected `horner_expr` - see `csring_expr.eval`. -/
def cseval {α : Type u_1} [comm_semiring α] (t : tree α) : horner_expr → α :=
  sorry

theorem cseval_atom {α : Type u_1} [comm_semiring α] (t : tree α) (n : pos_num) : is_cs (atom n) ∧ cseval t (atom n) = tree.get_or_zero t n :=
  { left := { left := Exists.intro 1 rfl, right := Exists.intro 0 rfl },
    right := Eq.symm (ring.horner_atom (tree.get_or_zero t n)) }

theorem cseval_add_const {α : Type u_1} [comm_semiring α] (t : tree α) (k : num) {e : horner_expr} (cs : is_cs e) : is_cs (add_const (num.to_znum k) e) ∧ cseval t (add_const (num.to_znum k) e) = ↑k + cseval t e := sorry

theorem cseval_horner' {α : Type u_1} [comm_semiring α] (t : tree α) (a : horner_expr) (x : pos_num) (n : num) (b : horner_expr) (h₁ : is_cs a) (h₂ : is_cs b) : is_cs (horner' a x n b) ∧ cseval t (horner' a x n b) = ring.horner (cseval t a) (tree.get_or_zero t x) (↑n) (cseval t b) := sorry

theorem cseval_add {α : Type u_1} [comm_semiring α] (t : tree α) {e₁ : horner_expr} {e₂ : horner_expr} (cs₁ : is_cs e₁) (cs₂ : is_cs e₂) : is_cs (add e₁ e₂) ∧ cseval t (add e₁ e₂) = cseval t e₁ + cseval t e₂ := sorry

theorem cseval_mul_const {α : Type u_1} [comm_semiring α] (t : tree α) (k : num) {e : horner_expr} (cs : is_cs e) : is_cs (mul_const (num.to_znum k) e) ∧ cseval t (mul_const (num.to_znum k) e) = cseval t e * ↑k := sorry

theorem cseval_mul {α : Type u_1} [comm_semiring α] (t : tree α) {e₁ : horner_expr} {e₂ : horner_expr} (cs₁ : is_cs e₁) (cs₂ : is_cs e₂) : is_cs (mul e₁ e₂) ∧ cseval t (mul e₁ e₂) = cseval t e₁ * cseval t e₂ := sorry

theorem cseval_pow {α : Type u_1} [comm_semiring α] (t : tree α) {x : horner_expr} (cs : is_cs x) (n : num) : is_cs (pow x n) ∧ cseval t (pow x n) = cseval t x ^ ↑n := sorry

/-- For any given tree `t` of atoms and any reflected expression `r`,
the Horner form of `r` is a valid csring expression, and under `t`,
the Horner form evaluates to the same thing as `r`. -/
theorem cseval_of_csexpr {α : Type u_1} [comm_semiring α] (t : tree α) (r : csring_expr) : is_cs (of_csexpr r) ∧ cseval t (of_csexpr r) = csring_expr.eval t r := sorry

end horner_expr

/-- The main proof-by-reflection theorem. Given reflected csring expressions
`r₁` and `r₂` plus a storage `t` of atoms, if both expressions go to the
same Horner normal form, then the original non-reflected expressions are
equal. `H` follows from kernel reduction and is therefore `rfl`. -/
theorem correctness {α : Type u_1} [comm_semiring α] (t : tree α) (r₁ : csring_expr) (r₂ : csring_expr) (H : horner_expr.of_csexpr r₁ = horner_expr.of_csexpr r₂) : csring_expr.eval t r₁ = csring_expr.eval t r₂ := sorry

/-- Reflects a csring expression into a `csring_expr`, together
with a dlist of atoms, i.e. opaque variables over which the
expression is a polynomial. -/
/-| `(%%e₁ - %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.add r₂.neg, l₁ ++ l₂)
| `(- %%e) := let (r, l) := reflect_expr e in (r.neg, l)-/

/-| `(has_inv.inv %%e) := let (r, l) := reflect_expr e in (r.neg, l)
| `(%%e₁ / %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.mul r₂.inv, l₁ ++ l₂)-/

/-- In the output of `reflect_expr`, `atom`s are initialized with incorrect indices.
The indices cannot be computed until the whole tree is built, so another pass over
the expressions is needed - this is what `replace` does. The computation (expressed
in the state monad) fixes up `atom`s to match their positions in the atom tree.
The initial state is a list of all atom occurrences in the goal, left-to-right. -/
--| (csring_expr.neg x)  := csring_expr.neg <$> x.replace

--| (csring_expr.inv x)  := csring_expr.inv <$> x.replace

end tactic.ring2

namespace tactic

namespace interactive

/-- `ring2` solves equations in the language of rings.

It supports only the commutative semiring operations, i.e. it does not normalize subtraction or division.

  This variant on the `ring` tactic uses kernel computation instead
  of proof generation. In general, you should use `ring` instead of `ring2`. -/


import Logic.Predicate.FirstOrder.Language
import Logic.Predicate.Coding

universe u v

namespace FirstOrder

variable {L : Language.{u}} [∀ k : ℕ, Encodable (L.func k)]
  [∀ k, Encodable (L.rel k)] {μ : Type v} [Encodable μ]

namespace SubFormula
open Encodable

def toNat : {n : ℕ} → SubFormula L μ n → ℕ
  | _, ⊤                 => 0
  | _, ⊥                 => 1
  | _, rel (k := k) r v  => (Nat.bit false $ Nat.bit false $ Nat.mkpair k  $ Nat.mkpair (encode r) (encode v)) + 2
  | _, nrel (k := k) r v => (Nat.bit false $ Nat.bit true  $ Nat.mkpair k  $ Nat.mkpair (encode r) (encode v)) + 2
  | _, p ⋏ q             => (Nat.bit true  $ Nat.bit false $ Nat.bit false $ Nat.mkpair p.toNat q.toNat) + 2
  | _, p ⋎ q             => (Nat.bit true  $ Nat.bit false $ Nat.bit true  $ Nat.mkpair p.toNat q.toNat) + 2
  | _, ∀' p              => (Nat.bit true  $ Nat.bit true  $ Nat.bit false p.toNat) + 2
  | _, ∃' p              => (Nat.bit true  $ Nat.bit true  $ Nat.bit true  p.toNat) + 2

def ofNat : (n : ℕ) → ℕ → Option (SubFormula L μ n)
  | n, 0     => some ⊤
  | n, 1     => some ⊥
  | n, (e + 2) =>
    match e.bodd with
    | false =>
      let x := e.div2.div2
      let k := x.unpair.1
      let r' := decode₂ (L.rel k) x.unpair.2.unpair.1
      let v' := decode₂ (Fin k → SubTerm L μ n) x.unpair.2.unpair.2
      match e.div2.bodd with
      | false => r'.bind fun r => v'.map fun v => rel r v
      | true  => r'.bind fun r => v'.map fun v => nrel r v
    | true  =>
      let x := e.div2.div2.div2
      have div8 : x ≤ e := by
        simp[Nat.div2_val]
        exact le_trans (Nat.div_le_self (e / 2 / 2) 2) (le_trans (Nat.div_le_self (e/2) 2) (Nat.div_le_self e 2))
      have h : x < e + 2 := Nat.lt.step $ Nat.lt_succ_iff.mpr div8
      have : x.unpair.1 < e + 2 := lt_of_le_of_lt (Nat.unpair_left_le _) h
      have : x.unpair.2 < e + 2 := lt_of_le_of_lt (Nat.unpair_right_le _) h
      match e.div2.bodd with
      | false =>
        let p' := ofNat n x.unpair.1
        let q' := ofNat n x.unpair.2
        match e.div2.div2.bodd with
        | false => p'.bind fun p => q'.map fun q => p ⋏ q
        | true  => p'.bind fun p => q'.map fun q => p ⋎ q
      | true  =>
        let p' := ofNat (n + 1) x
        match e.div2.div2.bodd with
        | false => p'.bind fun p => ∀' p
        | true  => p'.bind fun p => ∃' p
  termination_by ofNat n e => e

lemma ofNat_toNat : ∀ {n} (p : SubFormula L μ n), ofNat n p.toNat = some p
  | _, ⊤ => by simp[toNat, ofNat]
  | _, ⊥ => by simp[toNat, ofNat]
  | n, rel r v => by
      simp[toNat, ofNat]
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit, Nat.unpair_mkpair]; simp
  | n, nrel r v => by
      simp[toNat, ofNat]
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit, Nat.unpair_mkpair]; simp
  | n, p ⋏ q => by
      simp[toNat, ofNat]
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp[ofNat_toNat p, ofNat_toNat q]
  | n, p ⋎ q => by
      simp[toNat, ofNat]
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp[ofNat_toNat p, ofNat_toNat q]
  | n, ∀' p => by
      simp[toNat, ofNat]
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp[ofNat_toNat p]
  | n, ∃' p => by
      simp[toNat, ofNat]
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp
      rw[Nat.bodd_bit, Nat.div2_bit]; simp[ofNat_toNat p]

instance (n) : Encodable (SubFormula L μ n) where
  encode  := toNat
  decode  := ofNat n
  encodek := ofNat_toNat

end SubFormula

end FirstOrder


import mvpfunctor.basic
import mvqpf.basic

universes u

namespace mvqpf
variables {n m : ℕ}
  (F : typevec.{u} n → Type*) [mvfunctor F] [q : mvqpf F]
  (G : fin' n → typevec.{u} m → Type u) [∀ i, mvfunctor $ G i] [q' : ∀ i, mvqpf $ G i]

def comp (v : typevec.{u} m) : Type* :=
F $ λ i : fin' n, G i v

namespace comp
open mvfunctor mvpfunctor
variables {F G} {α β : typevec.{u} m} (f : α ⟹ β)

protected def mk (x : F $ λ i, G i α) : (comp F G) α := x

protected def get (x : (comp F G) α) : F $ λ i, G i α := x

@[simp] protected lemma mk_get (x : (comp F G) α) : comp.mk (comp.get x) = x := rfl

@[simp] protected lemma get_mk (x : F $ λ i, G i α) : comp.get (comp.mk x) = x := rfl

protected def map' : (λ (i : fin' n), G i α) ⟹ λ (i : fin' n), G i β :=
λ i, map f

protected def map : (comp F G) α → (comp F G) β :=
(map (λ i, map f) : F (λ i, G i α) → F (λ i, G i β))

instance : mvfunctor (comp F G) :=
{ map := λ α β, comp.map }

lemma map_mk (x : F $ λ i, G i α) :
  f <$$> comp.mk x = comp.mk ((λ i (x : G i α), f <$$> x) <$$> x) := rfl

lemma get_map (x : comp F G α) :
  comp.get (f <$$> x) = (λ i (x : G i α), f <$$> x) <$$> comp.get x := rfl

include q q'

instance : mvqpf (comp F G) :=
{ P         := mvpfunctor.comp (P F) (λ i, P $ G i),
  abs       := λ α, comp.mk ∘ map (λ i, abs) ∘ abs ∘ mvpfunctor.comp.get,
  repr'     := λ α,  mvpfunctor.comp.mk ∘ repr ∘
                 map (λ i, (repr : G i α → (λ (i : fin' n), apply (P (G i)) α) i)) ∘ comp.get,
  abs_repr' := by { intros, simp [(∘), mvfunctor.map_map, (⊚), abs_repr] },
  abs_map   := by { intros, simp [(∘)], rw [← abs_map],
                    simp [id_map, (⊚), map_mk, mvpfunctor.comp.get_map, abs_map,
                      mvfunctor.map_map, abs_repr] } }

end comp

end mvqpf


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.congruence
import Mathlib.linear_algebra.multilinear
import Mathlib.PostPort

universes u_1 u_2 u_4 u_3 u_6 u_5

namespace Mathlib

/-!
# Tensor product of an indexed family of semimodules over commutative semirings

We define the tensor product of an indexed family `s : ι → Type*` of semimodules over commutative
semirings. We denote this space by `⨂[R] i, s i` and define it as `free_add_monoid (R × Π i, s i)`
quotiented by the appropriate equivalence relation. The treatment follows very closely that of the
binary tensor product in `linear_algebra/tensor_product.lean`.

## Main definitions

* `pi_tensor_product R s` with `R` a commutative semiring and `s : ι → Type*` is the tensor product
  of all the `s i`'s. This is denoted by `⨂[R] i, s i`.
* `tprod R f` with `f : Π i, s i` is the tensor product of the vectors `f i` over all `i : ι`.
  This is bundled as a multilinear map from `Π i, s i` to `⨂[R] i, s i`.
* `lift_add_hom` constructs an `add_monoid_hom` from `(⨂[R] i, s i)` to some space `F` from a
  function `φ : (R × Π i, s i) → F` with the appropriate properties.
* `lift φ` with `φ : multilinear_map R s E` is the corresponding linear map
  `(⨂[R] i, s i) →ₗ[R] E`. This is bundled as a linear equivalence.

## Notations

* `⨂[R] i, s i` is defined as localized notation in locale `tensor_product`
* `⨂ₜ[R] i, f i` with `f : Π i, f i` is defined globally as the tensor product of all the `f i`'s.

## Implementation notes

* We define it via `free_add_monoid (R × Π i, s i)` with the `R` representing a "hidden" tensor
  factor, rather than `free_add_monoid (Π i, s i)` to ensure that, if `ι` is an empty type,
  the space is isomorphic to the base ring `R`.
* We have not restricted the index type `ι` to be a `fintype`, as nothing we do here strictly
  requires it. However, problems may arise in the case where `ι` is infinite; use at your own
  caution.

## TODO

* Define tensor powers, symmetric subspace, etc.
* API for the various ways `ι` can be split into subsets; connect this with the binary
  tensor product.
* Include connection with holors.
* Port more of the API from the binary tensor product over to this case.

## Tags

multilinear, tensor, tensor product
-/

namespace pi_tensor_product

/-- The relation on `free_add_monoid (R × Π i, s i)` that generates a congruence whose quotient is
the tensor product. -/
inductive eqv {ι : Type u_1} [DecidableEq ι] (R : Type u_2) [comm_semiring R] (s : ι → Type u_4)
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    free_add_monoid (R × ((i : ι) → s i)) → free_add_monoid (R × ((i : ι) → s i)) → Prop
    where
| of_zero : ∀ (r : R) (f : (i : ι) → s i) (i : ι), f i = 0 → eqv R s (free_add_monoid.of (r, f)) 0
| of_zero_scalar : ∀ (f : (i : ι) → s i), eqv R s (free_add_monoid.of (0, f)) 0
| of_add :
    ∀ (r : R) (f : (i : ι) → s i) (i : ι) (m₁ m₂ : s i),
      eqv R s
        (free_add_monoid.of (r, function.update f i m₁) +
          free_add_monoid.of (r, function.update f i m₂))
        (free_add_monoid.of (r, function.update f i (m₁ + m₂)))
| of_add_scalar :
    ∀ (r r' : R) (f : (i : ι) → s i),
      eqv R s (free_add_monoid.of (r, f) + free_add_monoid.of (r', f))
        (free_add_monoid.of (r + r', f))
| of_smul :
    ∀ (r : R) (f : (i : ι) → s i) (i : ι) (r' : R),
      eqv R s (free_add_monoid.of (r, function.update f i (r' • f i)))
        (free_add_monoid.of (r' * r, f))
| add_comm : ∀ (x y : free_add_monoid (R × ((i : ι) → s i))), eqv R s (x + y) (y + x)

end pi_tensor_product

/-- `pi_tensor_product R s` with `R` a commutative semiring and `s : ι → Type*` is the tensor
  product of all the `s i`'s. This is denoted by `⨂[R] i, s i`. -/
def pi_tensor_product {ι : Type u_1} [DecidableEq ι] (R : Type u_2) [comm_semiring R]
    (s : ι → Type u_4) [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :=
  add_con.quotient (add_con_gen sorry)

/- This enables the notation `⨂[R] i : ι, s i` for the pi tensor product, given `s : ι → Type*`. -/

namespace pi_tensor_product

protected instance add_comm_monoid {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    (s : ι → Type u_4) [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    add_comm_monoid (pi_tensor_product R fun (i : ι) => s i) :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

protected instance inhabited {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    (s : ι → Type u_4) [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    Inhabited (pi_tensor_product R fun (i : ι) => s i) :=
  { default := 0 }

/-- `tprod_coeff R r f` with `r : R` and `f : Π i, s i` is the tensor product of the vectors `f i`
over all `i : ι`, multiplied by the coefficient `r`. Note that this is meant as an auxiliary
definition for this file alone, and that one should use `tprod` defined below for most purposes. -/
def tprod_coeff {ι : Type u_1} [DecidableEq ι] (R : Type u_2) [comm_semiring R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (r : R) (f : (i : ι) → s i) :
    pi_tensor_product R fun (i : ι) => s i :=
  coe_fn (add_con.mk' (add_con_gen (eqv R fun (i : ι) => s i))) (free_add_monoid.of (r, f))

theorem zero_tprod_coeff {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    (f : (i : ι) → s i) : tprod_coeff R 0 f = 0 :=
  quotient.sound' (add_con_gen.rel.of (free_add_monoid.of (0, f)) 0 (eqv.of_zero_scalar f))

theorem zero_tprod_coeff' {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (z : R)
    (f : (i : ι) → s i) (i : ι) (hf : f i = 0) : tprod_coeff R z f = 0 :=
  quotient.sound' (add_con_gen.rel.of (free_add_monoid.of (z, f)) 0 (eqv.of_zero z f i hf))

theorem add_tprod_coeff {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (z : R)
    (f : (i : ι) → s i) (i : ι) (m₁ : s i) (m₂ : s i) :
    tprod_coeff R z (function.update f i m₁) + tprod_coeff R z (function.update f i m₂) =
        tprod_coeff R z (function.update f i (m₁ + m₂)) :=
  quotient.sound'
    (add_con_gen.rel.of
      (free_add_monoid.of (z, function.update f i m₁) +
        free_add_monoid.of (z, function.update f i m₂))
      (free_add_monoid.of (z, function.update f i (m₁ + m₂))) (eqv.of_add z f i m₁ m₂))

theorem add_tprod_coeff' {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (z₁ : R)
    (z₂ : R) (f : (i : ι) → s i) :
    tprod_coeff R z₁ f + tprod_coeff R z₂ f = tprod_coeff R (z₁ + z₂) f :=
  quotient.sound'
    (add_con_gen.rel.of (free_add_monoid.of (z₁, f) + free_add_monoid.of (z₂, f))
      (free_add_monoid.of (z₁ + z₂, f)) (eqv.of_add_scalar z₁ z₂ f))

theorem smul_tprod_coeff_aux {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (z : R)
    (f : (i : ι) → s i) (i : ι) (r : R) :
    tprod_coeff R z (function.update f i (r • f i)) = tprod_coeff R (r * z) f :=
  quotient.sound'
    (add_con_gen.rel.of (free_add_monoid.of (z, function.update f i (r • f i)))
      (free_add_monoid.of (r * z, f)) (eqv.of_smul z f i r))

theorem smul_tprod_coeff {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {R' : Type u_3} [comm_semiring R'] [algebra R' R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (z : R) (f : (i : ι) → s i)
    (i : ι) (r : R') [semimodule R' (s i)] [is_scalar_tower R' R (s i)] :
    tprod_coeff R z (function.update f i (r • f i)) = tprod_coeff R (r • z) f :=
  sorry

/-- Construct an `add_monoid_hom` from `(⨂[R] i, s i)` to some space `F` from a function
`φ : (R × Π i, s i) → F` with the appropriate properties. -/
def lift_add_hom {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] {F : Type u_6}
    [add_comm_monoid F] (φ : R × ((i : ι) → s i) → F)
    (C0 : ∀ (r : R) (f : (i : ι) → s i) (i : ι), f i = 0 → φ (r, f) = 0)
    (C0' : ∀ (f : (i : ι) → s i), φ (0, f) = 0)
    (C_add :
      ∀ (r : R) (f : (i : ι) → s i) (i : ι) (m₁ m₂ : s i),
        φ (r, function.update f i m₁) + φ (r, function.update f i m₂) =
          φ (r, function.update f i (m₁ + m₂)))
    (C_add_scalar : ∀ (r r' : R) (f : (i : ι) → s i), φ (r, f) + φ (r', f) = φ (r + r', f))
    (C_smul :
      ∀ (r : R) (f : (i : ι) → s i) (i : ι) (r' : R),
        φ (r, function.update f i (r' • f i)) = φ (r' * r, f)) :
    (pi_tensor_product R fun (i : ι) => s i) →+ F :=
  add_con.lift (add_con_gen (eqv R s)) (coe_fn free_add_monoid.lift φ) sorry

-- Most of the time we want the instance below this one, which is easier for typeclass resolution

-- to find.

protected instance has_scalar' {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {R' : Type u_3} [comm_semiring R'] [algebra R' R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    has_scalar R' (pi_tensor_product R fun (i : ι) => s i) :=
  has_scalar.mk
    fun (r : R') =>
      ⇑(lift_add_hom (fun (f : R × ((i : ι) → s i)) => tprod_coeff R (r • prod.fst f) (prod.snd f))
          sorry sorry sorry sorry sorry)

protected instance has_scalar {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    has_scalar R (pi_tensor_product R fun (i : ι) => s i) :=
  pi_tensor_product.has_scalar'

theorem smul_tprod_coeff' {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {R' : Type u_3} [comm_semiring R'] [algebra R' R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (r : R') (z : R)
    (f : (i : ι) → s i) : r • tprod_coeff R z f = tprod_coeff R (r • z) f :=
  rfl

protected theorem smul_add {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {R' : Type u_3} [comm_semiring R'] [algebra R' R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] (r : R')
    (x : pi_tensor_product R fun (i : ι) => s i) (y : pi_tensor_product R fun (i : ι) => s i) :
    r • (x + y) = r • x + r • y :=
  sorry

protected theorem induction_on' {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {C : (pi_tensor_product R fun (i : ι) => s i) → Prop}
    (z : pi_tensor_product R fun (i : ι) => s i)
    (C1 : ∀ {r : R} {f : (i : ι) → s i}, C (tprod_coeff R r f))
    (Cp : ∀ {x y : pi_tensor_product R fun (i : ι) => s i}, C x → C y → C (x + y)) : C z :=
  sorry

-- Most of the time we want the instance below this one, which is easier for typeclass resolution

-- to find.

protected instance semimodule' {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {R' : Type u_3} [comm_semiring R'] [algebra R' R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    semimodule R' (pi_tensor_product R fun (i : ι) => s i) :=
  semimodule.mk sorry sorry

protected instance semimodule {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {R' : Type u_3} [comm_semiring R'] [algebra R' R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    semimodule R' (pi_tensor_product R fun (i : ι) => s i) :=
  pi_tensor_product.semimodule'

/-- The canonical `multilinear_map R s (⨂[R] i, s i)`. -/
def tprod {ι : Type u_1} [DecidableEq ι] (R : Type u_2) [comm_semiring R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    multilinear_map R s (pi_tensor_product R fun (i : ι) => s i) :=
  multilinear_map.mk (tprod_coeff R 1) sorry sorry

@[simp] theorem tprod_coeff_eq_smul_tprod {ι : Type u_1} [DecidableEq ι] {R : Type u_2}
    [comm_semiring R] {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)]
    [(i : ι) → semimodule R (s i)] (z : R) (f : (i : ι) → s i) :
    tprod_coeff R z f = z • coe_fn (tprod R) f :=
  sorry

protected theorem induction_on {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {C : (pi_tensor_product R fun (i : ι) => s i) → Prop}
    (z : pi_tensor_product R fun (i : ι) => s i)
    (C1 : ∀ {r : R} {f : (i : ι) → s i}, C (r • coe_fn (tprod R) f))
    (Cp : ∀ {x y : pi_tensor_product R fun (i : ι) => s i}, C x → C y → C (x + y)) : C z :=
  sorry

theorem ext {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] {E : Type u_5}
    [add_comm_monoid E] [semimodule R E]
    {φ₁ : linear_map R (pi_tensor_product R fun (i : ι) => s i) E}
    {φ₂ : linear_map R (pi_tensor_product R fun (i : ι) => s i) E}
    (H :
      linear_map.comp_multilinear_map φ₁ (tprod R) = linear_map.comp_multilinear_map φ₂ (tprod R)) :
    φ₁ = φ₂ :=
  sorry

/-- Auxiliary function to constructing a linear map `(⨂[R] i, s i) → E` given a
`multilinear map R s E` with the property that its composition with the canonical
`multilinear_map R s (⨂[R] i, s i)` is the given multilinear map. -/
def lift_aux {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] {E : Type u_5}
    [add_comm_monoid E] [semimodule R E] (φ : multilinear_map R s E) :
    (pi_tensor_product R fun (i : ι) => s i) →+ E :=
  lift_add_hom (fun (p : R × ((i : ι) → s i)) => prod.fst p • coe_fn φ (prod.snd p)) sorry sorry
    sorry sorry sorry

theorem lift_aux_tprod {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {E : Type u_5} [add_comm_monoid E] [semimodule R E] (φ : multilinear_map R s E)
    (f : (i : ι) → s i) : coe_fn (lift_aux φ) (coe_fn (tprod R) f) = coe_fn φ f :=
  sorry

theorem lift_aux_tprod_coeff {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {E : Type u_5} [add_comm_monoid E] [semimodule R E] (φ : multilinear_map R s E) (z : R)
    (f : (i : ι) → s i) : coe_fn (lift_aux φ) (tprod_coeff R z f) = z • coe_fn φ f :=
  sorry

theorem lift_aux.smul {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {E : Type u_5} [add_comm_monoid E] [semimodule R E] {φ : multilinear_map R s E} (r : R)
    (x : pi_tensor_product R fun (i : ι) => s i) :
    coe_fn (lift_aux φ) (r • x) = r • coe_fn (lift_aux φ) x :=
  sorry

/-- Constructing a linear map `(⨂[R] i, s i) → E` given a `multilinear_map R s E` with the
property that its composition with the canonical `multilinear_map R s E` is
the given multilinear map `φ`. -/
def lift {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R] {s : ι → Type u_4}
    [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] {E : Type u_5}
    [add_comm_monoid E] [semimodule R E] :
    linear_equiv R (multilinear_map R s E)
        (linear_map R (pi_tensor_product R fun (i : ι) => s i) E) :=
  linear_equiv.mk
    (fun (φ : multilinear_map R s E) =>
      linear_map.mk (add_monoid_hom.to_fun (lift_aux φ)) sorry sorry)
    sorry sorry
    (fun (φ' : linear_map R (pi_tensor_product R fun (i : ι) => s i) E) =>
      linear_map.comp_multilinear_map φ' (tprod R))
    sorry sorry

@[simp] theorem lift.tprod {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {E : Type u_5} [add_comm_monoid E] [semimodule R E] {φ : multilinear_map R s E}
    (f : (i : ι) → s i) : coe_fn (coe_fn lift φ) (coe_fn (tprod R) f) = coe_fn φ f :=
  lift_aux_tprod φ f

theorem lift.unique' {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {E : Type u_5} [add_comm_monoid E] [semimodule R E] {φ : multilinear_map R s E}
    {φ' : linear_map R (pi_tensor_product R fun (i : ι) => s i) E}
    (H : linear_map.comp_multilinear_map φ' (tprod R) = φ) : φ' = coe_fn lift φ :=
  ext (Eq.symm H ▸ Eq.symm (linear_equiv.symm_apply_apply lift φ))

theorem lift.unique {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)]
    {E : Type u_5} [add_comm_monoid E] [semimodule R E] {φ : multilinear_map R s E}
    {φ' : linear_map R (pi_tensor_product R fun (i : ι) => s i) E}
    (H : ∀ (f : (i : ι) → s i), coe_fn φ' (coe_fn (tprod R) f) = coe_fn φ f) : φ' = coe_fn lift φ :=
  lift.unique' (multilinear_map.ext H)

theorem lift_tprod {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_semiring R]
    {s : ι → Type u_4} [(i : ι) → add_comm_monoid (s i)] [(i : ι) → semimodule R (s i)] :
    coe_fn lift (tprod R) = linear_map.id :=
  Eq.symm (lift.unique' rfl)

end pi_tensor_product

namespace pi_tensor_product

/- Unlike for the binary tensor product, we require `R` to be a `comm_ring` here, otherwise
this is false in the case where `ι` is empty. -/

protected instance add_comm_group {ι : Type u_1} [DecidableEq ι] {R : Type u_2} [comm_ring R]
    {s : ι → Type u_3} [(i : ι) → add_comm_group (s i)] [(i : ι) → module R (s i)] :
    add_comm_group (pi_tensor_product R fun (i : ι) => s i) :=
  semimodule.add_comm_monoid_to_add_comm_group R

end Mathlib