/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Util.ForEachExpr
import Lean.Meta.ForEachExpr
import Lean.Meta.RecursorInfo
import Lean.Meta.Match.Match
import Lean.Meta.Transform
import Lean.Elab.PreDefinition.Basic
namespace Lean.Elab
namespace Structural
open Meta

private def getFixedPrefix (declName : Name) (xs : Array Expr) (value : Expr) : MetaM Nat := do
  let numFixedRef ← IO.mkRef xs.size
  forEachExpr' value fun e => do
    if e.isAppOf declName then
      let args := e.getAppArgs
      numFixedRef.modify fun numFixed => if args.size < numFixed then args.size else numFixed
      for arg in args, x in xs do
        /- We should not use structural equality here. For example, given the definition
           ```
           def V.map {α β} f x x_1 :=
             @V.map.match_1.{1} α (fun x x_2 => V β x) x x_1
               (fun x x_2 => @V.mk₁ β x (f Bool.true x_2))
               (fun e => @V.mk₂ β (V.map (fun b => α b) (fun b => β b) f Bool.false e))
           ```
           The first three arguments at `V.map (fun b => α b) (fun b => β b) f Bool.false e` are "fixed"
           modulo definitional equality.
        -/
        if !(← withReducible <| isDefEq arg x) then
          -- We continue searching if e's arguments are not a prefix of `xs`
          return true
      return false
    else
      return true
  numFixedRef.get

structure RecArgInfo where
  /- `fixedParams ++ ys` are the arguments of the function we are trying to justify termination using structural recursion. -/
  fixedParams : Array Expr
  ys          : Array Expr  -- recursion arguments
  pos         : Nat         -- position in `ys` of the argument we are recursing on
  indicesPos  : Array Nat   -- position in `ys` of the inductive datatype indices we are recursing on
  indName     : Name        -- inductive datatype name of the argument we are recursing on
  indLevels   : List Level  -- inductice datatype universe levels of the argument we are recursing on
  indParams   : Array Expr  -- inductive datatype parameters of the argument we are recursing on
  indIndices  : Array Expr  -- inductive datatype indices of the argument we are recursing on, it is equal to `indicesPos.map fun i => ys.get! i`
  reflexive   : Bool        -- true if we are recursing over a reflexive inductive datatype

private def getIndexMinPos (xs : Array Expr) (indices : Array Expr) : Nat := do
  let mut minPos := xs.size
  for index in indices do
    match xs.indexOf? index with
    | some pos => if pos.val < minPos then minPos := pos.val
    | _        => pure ()
  return minPos

-- Indices can only depend on other indices
private def hasBadIndexDep? (ys : Array Expr) (indices : Array Expr) : MetaM (Option (Expr × Expr)) := do
  for index in indices do
    let indexType ← inferType index
    for y in ys do
      if !indices.contains y && (← dependsOn indexType y.fvarId!) then
        return some (index, y)
  return none

-- Inductive datatype parameters cannot depend on ys
private def hasBadParamDep? (ys : Array Expr) (indParams : Array Expr) : MetaM (Option (Expr × Expr)) := do
  for p in indParams do
    let pType ← inferType p
    for y in ys do
      if ← dependsOn pType y.fvarId! then
        return some (p, y)
  return none

private def throwStructuralFailed {α} : MetaM α :=
  throwError "structural recursion cannot be used"

structure State where
  /- When compiling structural recursion we use the `brecOn` recursor automatically built by
     the `inductive` command. For an inductive datatype `C`, it has the form
     `C.brecOn As motive is c F`
     where `As` are the inductive datatype parameters, `is` are the inductive datatype indices,
     `c : C As is`, and `F : (js) → (d : C As js) → C.below d → motive d`
     The `C.below d` is used to eliminate recursive applications. We refine its type when we process
     a nested dependent pattern matcher using `MatcherApp.addArg`. See `replaceRecApps` for additional details.
     We store the names of the matcher where we used `MatcherApp.addArg` at `matcherBelowDep`.
     We use this information to generate the auxiliary `_sunfold` definition needed by the smart unfolding
     technique used at WHNF. -/
  matcherBelowDep : NameSet := {}

abbrev M := StateRefT State MetaM

instance {α} : Inhabited (M α) where
  default := throwError "failed"

private def run {α} (x : M α) (s : State := {}) : MetaM (α × State) :=
  StateRefT'.run x s

private def orelse' {α} (x y : M α) : M α := do
  let saveState ← get
  orelseMergeErrors x (do set saveState; y)

private partial def findRecArg {α} (numFixed : Nat) (xs : Array Expr) (k : RecArgInfo → M α) : M α :=
  let rec loop (i : Nat) : M α := do
    if h : i < xs.size then
      let x := xs.get ⟨i, h⟩
      let localDecl ← getFVarLocalDecl x
      if localDecl.isLet then
        throwStructuralFailed
      else
        let xType ← whnfD localDecl.type
        matchConstInduct xType.getAppFn (fun _ => loop (i+1)) fun indInfo us => do
        if !(← hasConst (mkBRecOnName indInfo.name)) then
          loop (i+1)
        else if indInfo.isReflexive && !(← hasConst (mkBInductionOnName indInfo.name)) then
          loop (i+1)
        else
          let indArgs    := xType.getAppArgs
          let indParams  := indArgs.extract 0 indInfo.numParams
          let indIndices := indArgs.extract indInfo.numParams indArgs.size
          if !indIndices.all Expr.isFVar then
            orelse'
              (throwError "argument #{i+1} was not used because its type is an inductive family and indices are not variables{indentExpr xType}")
              (loop (i+1))
          else if !indIndices.allDiff then
            orelse'
              (throwError "argument #{i+1} was not used because its type is an inductive family and indices are not pairwise distinct{indentExpr xType}")
              (loop (i+1))
          else
            let indexMinPos := getIndexMinPos xs indIndices
            let numFixed    := if indexMinPos < numFixed then indexMinPos else numFixed
            let fixedParams := xs.extract 0 numFixed
            let ys          := xs.extract numFixed xs.size
            match ← hasBadIndexDep? ys indIndices with
            | some (index, y) =>
              orelse'
                (throwError "argument #{i+1} was not used because its type is an inductive family{indentExpr xType}\nand index{indentExpr index}\ndepends on the non index{indentExpr y}")
                (loop (i+1))
            | none =>
              match ← hasBadParamDep? ys indParams with
              | some (indParam, y) =>
                orelse'
                  (throwError "argument #{i+1} was not used because its type is an inductive datatype{indentExpr xType}\nand parameter{indentExpr indParam}\ndepends on{indentExpr y}")
                  (loop (i+1))
              | none =>
                let indicesPos := indIndices.map fun index => match ys.indexOf? index with | some i => i.val | none => unreachable!
                orelse'
                  (mapError
                    (k { fixedParams := fixedParams
                         ys          := ys
                         pos         := i - fixedParams.size
                         indicesPos  := indicesPos
                         indName     := indInfo.name
                         indLevels   := us
                         indParams   := indParams
                         indIndices  := indIndices
                         reflexive := indInfo.isReflexive })
                    (fun msg => m!"argument #{i+1} was not used for structural recursion{indentD msg}"))
                  (loop (i+1))
    else
      throwStructuralFailed
  loop numFixed

private def containsRecFn (recFnName : Name) (e : Expr) : Bool :=
  (e.find? fun e => e.isConstOf recFnName).isSome

private def ensureNoRecFn (recFnName : Name) (e : Expr) : MetaM Expr := do
  if containsRecFn recFnName e then
    Meta.forEachExpr e fun e => do
      if e.isAppOf recFnName then
        throwError "unexpected occurrence of recursive application{indentExpr e}"
    pure e
  else
    pure e

private def throwToBelowFailed {α} : MetaM α :=
  throwError "toBelow failed"

/- See toBelow -/
private partial def toBelowAux (C : Expr) : Expr → Expr → Expr → MetaM Expr
  | belowDict, arg, F => do
    let belowDict ← whnf belowDict
    trace[Elab.definition.structural] "belowDict: {belowDict}, arg: {arg}"
    match belowDict with
    | Expr.app (Expr.app (Expr.const `PProd _ _) d1 _) d2 _ =>
      (do toBelowAux C d1 arg (← mkAppM `PProd.fst #[F]))
      <|>
      (do toBelowAux C d2 arg (← mkAppM `PProd.snd #[F]))
    | Expr.app (Expr.app (Expr.const `And _ _) d1 _) d2 _ =>
      (do toBelowAux C d1 arg (← mkAppM `And.left #[F]))
      <|>
      (do toBelowAux C d2 arg (← mkAppM `And.right #[F]))
    | _ => forallTelescopeReducing belowDict fun xs belowDict => do
      let argArgs := arg.getAppArgs
      unless argArgs.size >= xs.size do throwToBelowFailed
      let n := argArgs.size
      let argTailArgs := argArgs.extract (n - xs.size) n
      let belowDict := belowDict.replaceFVars xs argTailArgs
      match belowDict with
      | Expr.app belowDictFun belowDictArg _ =>
        unless belowDictFun.getAppFn == C do throwToBelowFailed
        unless ← isDefEq belowDictArg arg do throwToBelowFailed
        pure (mkAppN F argTailArgs)
      | _ => throwToBelowFailed

/- See toBelow -/
private def withBelowDict {α} (below : Expr) (numIndParams : Nat) (k : Expr → Expr → MetaM α) : MetaM α := do
  let belowType ← inferType below
  trace[Elab.definition.structural] "belowType: {belowType}"
  belowType.withApp fun f args => do
    let motivePos := numIndParams + 1
    unless motivePos < args.size do throwError "unexpected 'below' type{indentExpr belowType}"
    let pre := mkAppN f (args.extract 0 numIndParams)
    let preType ← inferType pre
    forallBoundedTelescope preType (some 1) fun x _ => do
      let motiveType ← inferType x[0]
      let C ← mkFreshUserName `C
      withLocalDeclD C motiveType fun C =>
        let belowDict := mkApp pre C
        let belowDict := mkAppN belowDict (args.extract (numIndParams + 1) args.size)
        k C belowDict

/-
  `below` is a free variable with type of the form `I.below indParams motive indices major`,
  where `I` is the name of an inductive datatype.

  For example, when trying to show that the following function terminates using structural recursion
  ```lean
  def addAdjacent : List Nat → List Nat
  | []       => []
  | [a]      => [a]
  | a::b::as => (a+b) :: addAdjacent as
  ```
  when we are visiting `addAdjacent as` at `replaceRecApps`, `below` has type
  `@List.below Nat (fun (x : List Nat) => List Nat) (a::b::as)`
  The motive `fun (x : List Nat) => List Nat` depends on the actual function we are trying to compute.
  So, we first replace it with a fresh variable `C` at `withBelowDict`.
  Recall that `brecOn` implements course-of-values recursion, and `below` can be viewed as a dictionary
  of the "previous values".
  We search this dictionary using the auxiliary function `toBelowAux`.
  The dictionary is built using the `PProd` (`And` for inductive predicates).
  We keep searching it until we find `C recArg`, where `C` is the auxiliary fresh variable created at `withBelowDict`.  -/
private partial def toBelow (below : Expr) (numIndParams : Nat) (recArg : Expr) : MetaM Expr := do
  withBelowDict below numIndParams fun C belowDict =>
    toBelowAux C belowDict recArg below

/--
  Return true iff `e` contains an application `recFnName .. t ..` where the term `t` is
  the argument we are trying to recurse on, and it contains loose bound variables.

  We use this test to decide whether we should process a matcher-application as a regular
  applicaton or not. That is, whether we should push the `below` argument should be affected by the matcher or not.
  If `e` does not contain an application of the form `recFnName .. t ..`, then we know
  the recursion doesn't depend on any pattern variable in this matcher.
-/
private def recArgHasLooseBVarsAt (recFnName : Name) (recArgInfo : RecArgInfo) (e : Expr) : Bool :=
  let recArgPos := recArgInfo.fixedParams.size + recArgInfo.pos
  let app?   := e.find? fun e =>
     e.isAppOf recFnName && e.getAppNumArgs > recArgPos && (e.getArg! recArgPos).hasLooseBVars
  app?.isSome

private partial def replaceRecApps (recFnName : Name) (recArgInfo : RecArgInfo) (below : Expr) (e : Expr) : M Expr :=
  let rec loop (below : Expr) (e : Expr) : M Expr := do
    match e with
    | Expr.lam n d b c =>
      withLocalDecl n c.binderInfo (← loop below d) fun x => do
        mkLambdaFVars #[x] (← loop below (b.instantiate1 x))
    | Expr.forallE n d b c =>
      withLocalDecl n c.binderInfo (← loop below d) fun x => do
        mkForallFVars #[x] (← loop below (b.instantiate1 x))
    | Expr.letE n type val body _ =>
      withLetDecl n (← loop below type) (← loop below val) fun x => do
        mkLetFVars #[x] (← loop below (body.instantiate1 x))
    | Expr.mdata d e _   => return mkMData d (← loop below e)
    | Expr.proj n i e _  => return mkProj n i (← loop below e)
    | Expr.app _ _ _ =>
      let processApp (e : Expr) : M Expr :=
        e.withApp fun f args => do
          if f.isConstOf recFnName then
            let numFixed  := recArgInfo.fixedParams.size
            let recArgPos := recArgInfo.fixedParams.size + recArgInfo.pos
            if recArgPos >= args.size then
              throwError "insufficient number of parameters at recursive application {indentExpr e}"
            let recArg := args[recArgPos]
            -- For reflexive type, we may have nested recursive applications in recArg
            let recArg ← loop below recArg
            let f ← try toBelow below recArgInfo.indParams.size recArg catch  _ => throwError "failed to eliminate recursive application{indentExpr e}"
            -- Recall that the fixed parameters are not in the scope of the `brecOn`. So, we skip them.
            let argsNonFixed := args.extract numFixed args.size
            -- The function `f` does not explicitly take `recArg` and its indices as arguments. So, we skip them too.
            let mut fArgs := #[]
            for i in [:argsNonFixed.size] do
              if recArgInfo.pos != i && !recArgInfo.indicesPos.contains i then
                let arg := argsNonFixed[i]
                let arg ← replaceRecApps recFnName recArgInfo below arg
                fArgs := fArgs.push arg
            return mkAppN f fArgs
          else
            return mkAppN (← loop below f) (← args.mapM (loop below))
      let matcherApp? ← matchMatcherApp? e
      match matcherApp? with
      | some matcherApp =>
        if !recArgHasLooseBVarsAt recFnName recArgInfo e then
          processApp e
        else
          /- Here is an example we currently not handle
             ```
             def g (xs : List Nat) : Nat :=
             match xs with
             | [] => 0
             | y::ys =>
               match ys with
               | []       => 1
               | _::_::zs => g zs + 1
               | zs       => g ys + 2
             ```
             We are matching on `ys`, but still using `ys` in the third alternative.
             If we push the `below` argument over the dependent match it will be able to eliminate recursive call using `zs`.
             To make it work, users have to write the third alternative as `| zs => g zs + 2`
             If this is too annoying in practice, we may replace `ys` with the matching term, but
             this may generate weird error messages, when it doesn't work. -/
          trace[Elab.definition.structural] "below before matcherApp.addArg: {below} : {← inferType below}"
          let matcherApp ← mapError (matcherApp.addArg below) (fun msg => "failed to add `below` argument to 'matcher' application" ++ indentD msg)
          modify fun s => { s with matcherBelowDep := s.matcherBelowDep.insert matcherApp.matcherName }
          let altsNew ← (Array.zip matcherApp.alts matcherApp.altNumParams).mapM fun (alt, numParams) =>
            lambdaTelescope alt fun xs altBody => do
              trace[Elab.definition.structural] "altNumParams: {numParams}, xs: {xs}"
              unless xs.size >= numParams do
                throwError "unexpected matcher application alternative{indentExpr alt}\nat application{indentExpr e}"
              let belowForAlt := xs[numParams - 1]
              mkLambdaFVars xs (← loop belowForAlt altBody)
          pure { matcherApp with alts := altsNew }.toExpr
      | none => processApp e
    | e => ensureNoRecFn recFnName e
  loop below e

private def mkBRecOn (recFnName : Name) (recArgInfo : RecArgInfo) (value : Expr) : M Expr := do
  let type  := (← inferType value).headBeta
  let major := recArgInfo.ys[recArgInfo.pos]
  let otherArgs := recArgInfo.ys.filter fun y => y != major && !recArgInfo.indIndices.contains y
  trace[Elab.definition.structural] "fixedParams: {recArgInfo.fixedParams}, otherArgs: {otherArgs}"
  let motive ← mkForallFVars otherArgs type
  let mut brecOnUniv ← getLevel motive
  trace[Elab.definition.structural] "brecOn univ: {brecOnUniv}"
  let useBInductionOn := recArgInfo.reflexive && brecOnUniv == levelZero
  if recArgInfo.reflexive && brecOnUniv != levelZero then
    brecOnUniv ← decLevel brecOnUniv
  let motive ← mkLambdaFVars (recArgInfo.indIndices.push major) motive
  trace[Elab.definition.structural] "brecOn motive: {motive}"
  let brecOn :=
    if useBInductionOn then
      Lean.mkConst (mkBInductionOnName recArgInfo.indName) recArgInfo.indLevels
    else
      Lean.mkConst (mkBRecOnName recArgInfo.indName) (brecOnUniv :: recArgInfo.indLevels)
  let brecOn := mkAppN brecOn recArgInfo.indParams
  let brecOn := mkApp brecOn motive
  let brecOn := mkAppN brecOn recArgInfo.indIndices
  let brecOn := mkApp brecOn major
  check brecOn
  let brecOnType ← inferType brecOn
  trace[Elab.definition.structural] "brecOn     {brecOn}"
  trace[Elab.definition.structural] "brecOnType {brecOnType}"
  forallBoundedTelescope brecOnType (some 1) fun F _ => do
    let F := F[0]
    let FType ← inferType F
    trace[Elab.definition.structural] "FType: {FType}"
    let FType ← instantiateForall FType recArgInfo.indIndices
    let FType ← instantiateForall FType #[major]
    forallBoundedTelescope FType (some 1) fun below _ => do
      let below := below[0]
      let valueNew     ← replaceRecApps recFnName recArgInfo below value
      let Farg         ← mkLambdaFVars (recArgInfo.indIndices ++ #[major, below] ++ otherArgs) valueNew
      let brecOn       := mkApp brecOn Farg
      pure $ mkAppN brecOn otherArgs

private def shouldBetaReduce (e : Expr) (recFnName : Name) : Bool :=
  if e.isHeadBetaTarget then
    e.getAppFn.find? (·.isConstOf recFnName) |>.isSome
  else
    false

/--
  Beta reduce terms where the recursive function occurs in the lambda term.
  This is useful to improve the effectiveness of `elimRecursion`.
  Example:
  ```
  def f : Nat → Nat
    | 0 => 1
    | i+1 => (fun x => f x) i
  ```
-/
private def preprocess (e : Expr) (recFnName : Name) : CoreM Expr :=
  Core.transform e
   fun e => return TransformStep.visit <|
     if shouldBetaReduce e recFnName then
       e.headBeta
     else
       e

private def elimRecursion (preDef : PreDefinition) : M PreDefinition :=
  withoutModifyingEnv do lambdaTelescope preDef.value fun xs value => do
    addAsAxiom preDef
    let value ← preprocess value preDef.declName
    trace[Elab.definition.structural] "{preDef.declName} {xs} :=\n{value}"
    let numFixed ← getFixedPrefix preDef.declName xs value
    trace[Elab.definition.structural] "numFixed: {numFixed}"
    findRecArg numFixed xs fun recArgInfo => do
      -- when (recArgInfo.indName == `Nat) throwStructuralFailed -- HACK to skip Nat argument
      let valueNew ← mkBRecOn preDef.declName recArgInfo value
      let valueNew ← mkLambdaFVars xs valueNew
      trace[Elab.definition.structural] "result: {valueNew}"
      -- Recursive applications may still occur in expressions that were not visited by replaceRecApps (e.g., in types)
      let valueNew ← ensureNoRecFn preDef.declName valueNew
      pure { preDef with value := valueNew }

partial def addSmartUnfoldingDefAux (preDef : PreDefinition) (matcherBelowDep : NameSet) : MetaM PreDefinition := do
  let recFnName := preDef.declName
  let isMarkedMatcherName (n : Name) : Bool    := matcherBelowDep.contains n
  let isMarkedMatcherConst (e : Expr) : Bool   := e.isConst && isMarkedMatcherName e.constName!
  let isMarkedMatcherApp (e : Expr) : Bool     := isMarkedMatcherConst e.getAppFn
  let containsMarkedMatcher (e : Expr) : Bool := e.find? isMarkedMatcherConst |>.isSome
  let rec visit (e : Expr) : MetaM Expr := do
    match e with
    | Expr.lam ..     => lambdaTelescope e fun xs b => do mkLambdaFVars xs (← visit b)
    | Expr.forallE .. => forallTelescope e fun xs b => do mkForallFVars xs (← visit b)
    | Expr.letE n type val body _ =>
      withLetDecl n type (← visit val) fun x => do
        mkLetFVars #[x] (← visit (body.instantiate1 x))
    | Expr.mdata d b _   => return mkMData d (← visit b)
    | Expr.proj n i s _  => return mkProj n i (← visit s)
    | Expr.app .. =>
      let processApp (e : Expr) : MetaM Expr :=
        e.withApp fun f args => do
          return mkAppN (← visit f) (← args.mapM visit)
      match isMarkedMatcherApp e, (← matchMatcherApp? e) with
      | true, some matcherApp =>
        let altsNew ← (Array.zip matcherApp.alts matcherApp.altNumParams).mapM fun (alt, numParams) =>
          lambdaTelescope alt fun xs altBody => do
            unless xs.size >= numParams do
              throwError "unexpected matcher application alternative{indentExpr alt}\nat application{indentExpr e}"
            if containsMarkedMatcher altBody then
              -- continue
              mkLambdaFVars xs (← visit altBody)
            else
              -- add idRhs marker
              let altBody ← mkLambdaFVars xs[numParams:xs.size] altBody
              let altBody ← mkIdRhs altBody
              mkLambdaFVars xs[0:numParams] altBody
        pure { matcherApp with alts := altsNew }.toExpr
      | _, _ => processApp e
    | _ => pure e
  return { preDef with
    declName  := mkSmartUnfoldingNameFor preDef.declName,
    value     := (← visit preDef.value),
    modifiers := {}
  }

partial def addSmartUnfoldingDef (preDef : PreDefinition) (state : State) : TermElabM Unit := do
  if (← isProp preDef.type) then
    return ()
  else
    let preDefSUnfold ← addSmartUnfoldingDefAux preDef state.matcherBelowDep
    addNonRec preDefSUnfold

def structuralRecursion (preDefs : Array PreDefinition) : TermElabM Unit :=
  if preDefs.size != 1 then
    throwError "structural recursion does not handle mutually recursive functions"
  else do
    let (preDefNonRec, state) ← run $ elimRecursion preDefs[0]
    mapError (addNonRec preDefNonRec) (fun msg => m!"structural recursion failed, produced type incorrect term{indentD msg}")
    addAndCompilePartialRec preDefs
    addSmartUnfoldingDef preDefs[0] state

builtin_initialize
  registerTraceClass `Elab.definition.structural

end Structural

export Structural (structuralRecursion)

end Lean.Elab


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((((a2).write i3 (v2)).write i1 (v2)).read i3) ≠ (v2) → False := by
  arr


import tactic.slice
import category_theory.colimit_lemmas
import category_theory.pushout_fold
import homotopy_theory.formal.cofibrations.cofibration_category
import homotopy_theory.formal.cofibrations.cylinder
import homotopy_theory.formal.cofibrations.factorization_from_cylinder
import homotopy_theory.formal.cofibrations.homotopy
import homotopy_theory.formal.cofibrations.left_proper
import .cylinder_object
import .dold

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations
open homotopy_theory.cylinder (renaming homotopic_rel → homotopic_rel_cylinder)
open homotopy_theory.weak_equivalences
open precofibration_category

-- An I-category gives rise to a cofibration category with the same
-- cofibrations in which the weak equivalences are the homotopy
-- equivalences.

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

-- Every object is fibrant.
lemma all_objects_fibrant (x : C) : fibrant x :=
assume y j ⟨jc, jw⟩,
let ⟨⟨r, h, H⟩⟩ := (heq_iff_sdr_inclusion jc).mp jw in ⟨r, h⟩

instance I_category.cofibration_category : cofibration_category.{v} C :=
cofibration_category.mk_from_cylinder
  (assume a b a' b' f g f' g' po ⟨fc, fw⟩,
    ⟨precofibration_category.pushout_is_cof po fc, pushout_is_acof po fc fw⟩)
  (assume a, ⟨I.obj a, ii @> a, p @> a, cof_ii a, heq_p, pii⟩)
  (assume x, ⟨x, 𝟙 x, ⟨cof_id x, weq_id x⟩, all_objects_fibrant x⟩)

-- The functor I produces cylinder objects in the general sense of
-- cofibration categories.
def canonical_cylinder (b : C) :
  relative_cylinder (all_objects_cofibrant.cofibrant.{v} b) :=
⟨I.obj b,
 (pushout_by_cof (!b) (!b) _).is_pushout.induced (i 0 @> b) (i 1 @> b)
   (category_theory.initial.uniqueness _ _),
 p @> b,
 -- We proved ii : b ⊔ b → Ib is a cofibration; need to massage this
 -- into a map from the pushout over the initial object.
 let po := pushout_by_cof (!b) (!b) (all_objects_cofibrant.cofibrant.{v} b),
     -- The map we need to show is a cofibration
     ii' := po.is_pushout.induced (i 0 @> b) (i 1 @> b)
       (category_theory.initial.uniqueness _ _),
     c : Is_coproduct po.map₀ po.map₁ :=
       Is_coproduct_of_Is_pushout_of_Is_initial po.is_pushout
         has_initial_object.initial_object.is_initial_object,
     j : iso (b ⊔ b) po.ob := isomorphic_coprod_of_Is_coproduct c in
 have ii' ∘ j.hom = ii @> b, begin
   dsimp [j, isomorphic_coprod_of_Is_coproduct];
   apply coprod.uniqueness; rw ←assoc; simp [ii]
 end,
 have ii' = ii @> b ∘ j.inv, by rw ←this; simp,
 show is_cof ii',
 by rw this; exact cof_comp (cof_iso j.symm) (cof_ii b),
 heq_p,
 begin
   apply (pushout_by_cof (!b) (!b) _).is_pushout.uniqueness;
   { rw ←assoc, simp }
 end⟩

/-
         I a → a
          ↓ po ↓
 b ⊔ b → I b → c → b
   a
-/
def canonical_relative_cylinder {a b : C} {j : a ⟶ b} (hj : is_cof j) :
  relative_cylinder hj :=
let po := pushout_by_cof (I.map j) (p.app a) (I_preserves_cofibrations hj) in
⟨po.ob,
 (pushout_by_cof j j _).is_pushout.induced ((i 0).app b ≫ po.map₀) ((i 1).app b ≫ po.map₀)
   begin
     erw [←assoc, ←assoc, (i 0).naturality, (i 1).naturality],
     rw [assoc, assoc, po.is_pushout.commutes, ←assoc, ←assoc],
     simp
   end,
 po.is_pushout.induced (p.app b) j (p.naturality j),

/-
 a ⊔ a → I a →   a
   ↓  po₁ ↓ po₂  ↓
 b ⊔ b →  ⬝  → b ⊔ b
                 a
          ↓ po₃  ↓
         I b →   c → b
-/
 begin
   let po₀ := pushout_by_cof j j hj,
   let abb : a ⟶ po₀.ob := po₀.map₀ ∘ j,
   let po₁ := pushout_by_cof _ (ii.app a) (cof_coprod hj hj),
   let l := po₁.is_pushout.induced (coprod.induced po₀.map₀ po₀.map₁) (abb ∘ p.app a)
   begin
     apply coprod.uniqueness,
       { rw [←assoc, coprod_of_maps_commutes₀, assoc, coprod.induced_commutes₀],
         rw [iii₀_assoc, ←assoc, pi_components, id_comp] },
       { rw [←assoc, coprod_of_maps_commutes₁, assoc, coprod.induced_commutes₁],
         rw [iii₁_assoc, ←assoc, pi_components, id_comp, ←po₀.is_pushout.commutes] }
   end,
   have po₁₂ : Is_pushout (coprod_of_maps j j) (coprod.fold a) _ _ :=
     Is_pushout_fold po₀.is_pushout,
   have po₂ : Is_pushout po₁.map₁ (p.app a) l abb,
   { refine Is_pushout_of_Is_pushout_of_Is_pushout' po₁.is_pushout _ _,
     { convert po₁₂,
       { apply pii },
       { simp } },
     { simp } },
   have po₂₃ : Is_pushout (I.map j) (p.app a) _ _ := po.is_pushout,
   let m := _,                  -- naming part of the type of a hypothesis
   have : is_cof m := I_category.relative_cylinder j hj,
   let n := _,                  -- naming part of the type of the goal
   change is_cof n,
   have po₃ : Is_pushout m l po.map₀ n,
   { refine Is_pushout_of_Is_pushout_of_Is_pushout_vert' po₂ _ _,
     convert po₂₃,
     { simp, refl },
     { have : po.map₀ ∘ (i 0).app b ∘ j = po.map₁,
       { rw ←assoc,
         erw (i 0).naturality,
         rw [assoc, po.is_pushout.commutes, ←assoc, pi_components, id_comp] },
       simpa using this },
     { apply po₁.is_pushout.uniqueness; rw [←assoc, ←assoc],
       { simp only [Is_pushout.induced_commutes₀, Is_pushout.induced_commutes₁],
         apply coprod.uniqueness; rw [←assoc, ←assoc]; simp },
       { simp only [assoc, Is_pushout.induced_commutes₀, Is_pushout.induced_commutes₁],
         slice_rhs 2 3 { change (i 0).app b ∘ ((functor.id _).map j), rw (i 0).naturality },
         simp only [assoc],
         erw [po.is_pushout.commutes],
         slice_rhs 2 3 { rw pi_components },
         dsimp, simp } } },
   exact pushout_is_cof po₃ this
 end,
 begin
   have : is_weq po.map₀ :=
     left_proper.pushout_weq_by_cof po.is_pushout (I_preserves_cofibrations hj) heq_p,
   refine category_with_weak_equivalences.weq_of_comp_weq_left this _,
   simpa using heq_p,
 end,
 begin
   symmetry,
   apply pushout_induced_eq_iff; rw ←assoc; simp
 end⟩

section homotopy
variables {a b x : C} {j : a ⟶ b} (hj : is_cof j) (f₀ f₁ : b ⟶ x)

lemma homotopic_rel_iff_cylinder :
  homotopic_rel hj f₀ f₁ ↔ homotopic_rel_cylinder j f₀ f₁ :=
let po := pushout_by_cof (I.map j) (p.app a) (I_preserves_cofibrations hj) in
begin
  split; intro H,
  { rcases homotopic_rel' (canonical_relative_cylinder hj) (all_objects_fibrant x) f₀ f₁ H
      with ⟨H, Hi₀, Hi₁⟩,
    dsimp [canonical_relative_cylinder, relative_cylinder.i₀, relative_cylinder.i₁] at Hi₀ Hi₁,
    simp at Hi₀ Hi₁,
    refine ⟨⟨po.map₀ ≫ H, _, _⟩, _⟩,
    { rw [←Hi₀, ←assoc, ←assoc], refl },
    { rw [←Hi₁, ←assoc, ←assoc], refl },
    { dsimp [homotopy.is_rel],
      rw [←Hi₀],
      slice_rhs 2 3 { change (functor.id _).map j ≫ (i 0).app b, rw (i 0).naturality },
      slice_lhs 1 2 { rw po.is_pushout.commutes },
      slice_rhs 3 4 { change I.map j ≫ po.map₀, rw po.is_pushout.commutes },
      slice_rhs 2 3 { rw pi_components },
      simp } },
  { rcases H with ⟨⟨H, Hi₀, Hi₁⟩, r⟩,
    refine ⟨canonical_relative_cylinder hj, ⟨⟨_, _, _⟩⟩⟩,
    refine po.is_pushout.induced H (j ≫ f₀) r,
    { convert Hi₀ using 1,
      dsimp [relative_cylinder.i₀, canonical_relative_cylinder], simp },
    { convert Hi₁ using 1,
      dsimp [relative_cylinder.i₁, canonical_relative_cylinder], simp } }
end

end homotopy

end homotopy_theory.cofibrations


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((((a1).write i3 (v1)).write i2 (v1)).read i3) ≠ (v1) → False := by
  arr


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((((a1).write i2 (v1)).write i1 (v1)).read i2) ≠ (v1) → False := by
  arr


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((((a2).write i2 (v1)).write i1 (v1)).read i2) ≠ (v1) → False := by
  arr


import for_mathlib.category_theory.localization.equivalence
import category_theory.products.basic
import for_mathlib.category_theory.functor_misc
import for_mathlib.category_theory.finite_products

noncomputable theory

universes v v' u u'

namespace category_theory

open category

@[simp]
lemma prod.eq_to_hom_fst {C₁ C₂ : Type*} [category C₁] [category C₂]
  {X Y : C₁ × C₂} (eq : X = Y) : (eq_to_hom eq : X ⟶ Y).fst = eq_to_hom (by rw eq) :=
by { subst eq, refl, }

@[simp]
lemma prod.eq_to_hom_snd {C₁ C₂ : Type*} [category C₁] [category C₂]
  {X Y : C₁ × C₂} (eq : X = Y) : (eq_to_hom eq : X ⟶ Y).snd = eq_to_hom (by rw eq) :=
by { subst eq, refl, }

lemma functor.prod.ext {C₁ C₂ E : Type*} [category C₁] [category C₂] [category E]
  {F₁ F₂ : E ⥤ C₁ × C₂} (h₁ : F₁ ⋙ prod.fst _ _ = F₂ ⋙ prod.fst _ _)
  (h₂ : F₁ ⋙ prod.snd _ _ = F₂ ⋙ prod.snd _ _) : F₁ = F₂ :=
begin
  refine functor.ext (λ X, _) (λ X Y f, _),
  { ext,
    exacts [functor.congr_obj h₁ X, functor.congr_obj h₂ X], },
  { ext,
    { simpa only [prod_comp_fst, prod.eq_to_hom_fst] using functor.congr_map_conjugate h₁ f, },
    { simpa only [prod_comp_snd, prod.eq_to_hom_snd] using functor.congr_map_conjugate h₂ f, }, },
end

lemma functor.is_localization.of_is_equivalence {C D : Type*} [category C] [category D]
  (F : C ⥤ D) [is_equivalence F] (W : morphism_property C)
  (hF : W ⊆ morphism_property.isomorphisms C) : F.is_localization W :=
begin
  haveI := localization.id_is_localization W hF,
  exact functor.is_localization.of_equivalence (𝟭 C) W F F.as_equivalence F.left_unitor,
end

lemma morphism_property.of_arrow_eq {C : Type*} [category C] (W : morphism_property C)
  (f₁ f₂ : arrow C) (hf₂ : W f₂.hom) (eq : f₁ = f₂) : W f₁.hom := by { subst eq, exact hf₂, }

lemma morphism_property.of_arrow_mk_eq {C : Type*} [category C] (W : morphism_property C)
  {X₁ Y₁ X₂ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (hf₂ : W f₂) (eq : arrow.mk f₁ = arrow.mk f₂) :
  W f₁ :=
W.of_arrow_eq (arrow.mk f₁) (arrow.mk f₂) hf₂ eq

lemma functor.congr_map_arrow_obj_arrow_mk {C D : Type*} [category C] [category D]
  {F₁ F₂ : C ⥤ D} (eq : F₁ = F₂) {X Y : C} (f : X ⟶ Y) :
  F₁.map_arrow.obj (arrow.mk f) = F₂.map_arrow.obj (arrow.mk f) := by subst eq

section

variables {C₁ D₁ C₂ D₂ : Type*} [category C₁] [category C₂] [category D₁] [category D₂]
  (W₁ : morphism_property C₁) (W₂ : morphism_property C₂) {E : Type*} [category E]

@[simps]
def nat_iso.prod {F F' : C₁ ⥤ D₁} {G G' : C₂ ⥤ D₂} (α : F ≅ F') (β : G ≅ G') :
  F.prod G ≅ F'.prod G' :=
{ hom := α.hom.prod β.hom,
  inv := α.inv.prod β.inv, }

namespace equivalence

def prod (E₁ : C₁ ≌ D₁) (E₂ : C₂ ≌ D₂) : C₁ × C₂ ≌ D₁ × D₂ :=
{ functor := E₁.functor.prod E₂.functor,
  inverse := E₁.inverse.prod E₂.inverse,
  unit_iso := ((functor_prod_functor_equiv (C₁ × C₂) C₁ C₂).counit_iso.app (𝟭 _)).symm
      ≪≫ nat_iso.prod E₁.unit_iso E₂.unit_iso,
  counit_iso := nat_iso.prod E₁.counit_iso E₂.counit_iso ≪≫
      ((functor_prod_functor_equiv (D₁ × D₂) D₁ D₂).counit_iso.app (𝟭 _)), }

end equivalence

namespace functor

@[simps]
def prod_functor : (C₁ ⥤ D₁) × (C₂ ⥤ D₂) ⥤ (C₁ × C₂) ⥤ (D₁ × D₂) :=
{ obj := λ F, F.1.prod F.2,
  map := λ F G φ, φ.1.prod φ.2, }

lemma flip_flip (H : D₁ ⥤ D₂ ⥤ E) : H.flip.flip = H :=
functor.ext (λ X₁, (functor.ext (λ X₂, rfl) (by tidy))) (by tidy)

lemma comp_comp_curry_flip_flip_eq_curry (H : D₁ × D₂ ⥤ E) (F₁ : C₁ ⥤ D₁) (F₂ : C₂ ⥤ D₂) :
  F₁ ⋙ (F₂ ⋙ (curry.obj H).flip).flip = curry.obj (F₁.prod F₂ ⋙ H) :=
functor.ext (λ X₁, (functor.ext (λ Y₁, rfl) (by tidy))) (by tidy)

lemma uncurry_curry (H : D₁ × D₂ ⥤ E) : uncurry.obj (curry.obj H) = H :=
functor.ext (λ X, by { cases X, refl, }) (by tidy)

end functor

namespace morphism_property

class contains_identities {C : Type*} [category C] (W : morphism_property C) : Prop :=
(id [] : ∀ (X : C), W (𝟙 X))

namespace contains_identities

lemma op {C : Type*} [category C] {W : morphism_property C}
  (h : W.contains_identities) : W.op.contains_identities :=
⟨λ X, h.id X.unop⟩

lemma unop {C : Type*} [category C] {W : morphism_property Cᵒᵖ}
  (h : W.contains_identities) : W.unop.contains_identities :=
⟨λ X, h.id (opposite.op X)⟩

instance op' {C : Type*} [category C] {W : morphism_property C} [h : W.contains_identities] :
  W.op.contains_identities := h.op

end contains_identities

def prod : morphism_property (C₁ × C₂) := λ X Y f, W₁ f.fst ∧ W₂ f.snd

variables {W₁ W₂}

lemma is_inverted_by.prod {F₁ : C₁ ⥤ D₁} {F₂ : C₂ ⥤ D₂} (h₁ : W₁.is_inverted_by F₁)
  (h₂ : W₂.is_inverted_by F₂) : (W₁.prod W₂).is_inverted_by (F₁.prod F₂) :=
λ X Y f hf, by { rw is_iso_prod_iff, exact ⟨h₁ f.1 hf.1,h₂ f.2 hf.2⟩, }

end morphism_property

namespace localization

variables [hW₁ : W₁.contains_identities] [hW₂ : W₂.contains_identities]

namespace strict_universal_property_fixed_target

variables  (F : C₁ × C₂ ⥤ E) (hF : (W₁.prod W₂).is_inverted_by F)

@[simps]
def prod.hom_mk {X₁ Y₁ : C₁} {X₂ Y₂ : C₂} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) :
  (⟨X₁, X₂⟩ : C₁ × C₂) ⟶ ⟨Y₁, Y₂⟩ := ⟨f₁, f₂⟩

namespace prod

include hF hW₂
def lift₁ : W₁.localization ⥤ C₂ ⥤ E :=
localization.construction.lift (curry.obj F) (λ X₁ Y₁ f₁ hf₁, begin
  haveI : Π (Z₂ : C₂), is_iso (((curry.obj F).map f₁).app Z₂),
  { intro Z₂,
    apply hF,
    exact ⟨hf₁, morphism_property.contains_identities.id _ _⟩, },
    apply nat_iso.is_iso_of_is_iso_app,
end)

lemma fac₁ : W₁.Q ⋙ (lift₁ W₁ W₂ F hF) = curry.obj F := localization.construction.fac _ _

lemma lift₁_obj_map (X₁ : C₁) {X₂ Y₂ : C₂} (f₂ : X₂ ⟶ Y₂) :
  ((lift₁ W₁ W₂ F hF).obj (W₁.Q.obj X₁)).map f₂ =
    F.map (prod.hom_mk (𝟙 X₁) f₂) := rfl

lemma lift₁_map_app {X₁ Y₁ : C₁} (f₁ : X₁ ⟶ Y₁) (X₂ : C₂) :
  ((lift₁ W₁ W₂ F hF).map (W₁.Q.map f₁)).app X₂ =
    F.map (prod.hom_mk f₁ (𝟙 X₂)) :=
by simpa only [functor.comp_map, eq_to_hom_refl, category.comp_id, category.id_comp,
  curry_obj_map_app] using congr_app (functor.congr_map_conjugate (fac₁ W₁ W₂ F hF) f₁) X₂

include hW₁

def lift₂ : W₂.localization ⥤ W₁.localization ⥤ E :=
localization.construction.lift (lift₁ W₁ W₂ F hF).flip (λ X₂ Y₂ f₂ hf₂, begin
  haveI : ∀ (X₁ : W₁.localization), is_iso (((lift₁ W₁ W₂ F hF).flip.map f₂).app X₁),
  { intro X₁,
    have hF₁ : ∃ (A₁ : C₁), W₁.Q.obj A₁ = X₁ := (construction.obj_equiv W₁).surjective X₁,
    cases hF₁ with A₁ hA₁,
    subst hA₁,
    simp only [functor.flip_map_app, lift₁_obj_map],
    haveI := hF (prod.hom_mk (𝟙 A₁) f₂) ⟨morphism_property.contains_identities.id _ _, hf₂⟩,
    apply_instance, },
  apply nat_iso.is_iso_of_is_iso_app,
end)

lemma fac₂ : W₂.Q ⋙ (lift₂ W₁ W₂ F hF) = (lift₁ W₁ W₂ F hF).flip :=
localization.construction.fac _ _

lemma lift₂_obj_map {X₁ Y₁ : C₁} (f₁ : X₁ ⟶ Y₁) (X₂ : C₂) :
  ((lift₂ W₁ W₂ F hF).obj (W₂.Q.obj X₂)).map (W₁.Q.map f₁) = F.map (prod.hom_mk f₁ (𝟙 X₂)) :=
by simpa only [eq_to_hom_refl, functor.flip_obj_map, category.comp_id,
  category.id_comp, lift₁_map_app] using functor.congr_map_conjugate
    (functor.congr_obj (fac₂ W₁ W₂ F hF) X₂) (W₁.Q.map f₁)

lemma lift₂_map_app (X₁ : C₁) {X₂ Y₂ : C₂} (f₂ : X₂ ⟶ Y₂) :
  ((lift₂ W₁ W₂ F hF).map (W₂.Q.map f₂)).app (W₁.Q.obj X₁) = F.map (prod.hom_mk (𝟙 X₁) f₂) :=
by simpa only [eq_to_hom_refl, category.comp_id, category.id_comp]
  using congr_app (functor.congr_map_conjugate (fac₂ W₁ W₂ F hF) f₂) (W₁.Q.obj X₁)

def lift₃ : W₁.localization × W₂.localization ⥤ E := uncurry.obj (lift₂ W₁ W₂ F hF).flip

lemma fac : W₁.Q.prod W₂.Q ⋙ prod.lift₃ W₁ W₂ F hF = F :=
begin
  refine functor.ext (λ X, by { cases X, refl, }) (λ X Y f, _),
  { rcases X with ⟨X₁, X₂⟩,
    rcases Y with ⟨Y₁, Y₂⟩,
    have eq : f = prod.hom_mk (𝟙 X₁) f.2 ≫ prod.hom_mk f.1 (𝟙 Y₂) :=
      by simp only [prod_comp, hom_mk_fst, category.id_comp, hom_mk_snd, category.comp_id,
        prod.mk.eta],
    nth_rewrite 0 eq,
    dsimp [functor.comp, lift₃],
    simp only [category.id_comp, category.comp_id, nat_trans.naturality,
      lift₂_obj_map, lift₂_map_app, ← F.map_comp],
    congr' 1,
    ext,
    { apply category.comp_id, },
    { apply category.id_comp, }, },
end

omit hF hW₁ hW₂

lemma uniq (H H' : W₁.localization × W₂.localization ⥤ E)
  (eq : W₁.Q.prod W₂.Q ⋙ H = W₁.Q.prod W₂.Q ⋙ H') : H = H' :=
begin
  let G := (curry.obj H).flip,
  let G' := (curry.obj H').flip,
  suffices : G = G',
  { rw [← functor.uncurry_curry H, ← functor.uncurry_curry H'],
    congr' 1,
    rw [← functor.flip_flip (curry.obj H), ← functor.flip_flip (curry.obj H')],
    congr', },
  apply construction.uniq,
  suffices : (W₂.Q ⋙ G).flip = (W₂.Q ⋙ G').flip,
  { rw [← functor.flip_flip (W₂.Q ⋙ G), ← functor.flip_flip (W₂.Q ⋙ G'), this], },
  apply construction.uniq,
  convert congr_arg curry.obj eq,
  all_goals { apply functor.comp_comp_curry_flip_flip_eq_curry, },
end

end prod

include hW₁ hW₂

variable (E)

def prod : strict_universal_property_fixed_target (W₁.Q.prod W₂.Q) (W₁.prod W₂) E :=
{ inverts := (localization.inverts _ _).prod (localization.inverts _ _),
  lift := λ F hF, prod.lift₃ W₁ W₂ F hF,
  fac := λ F hF, prod.fac W₁ W₂ F hF,
  uniq := λ H H' eq, begin
    let G := (curry.obj H).flip,
    let G' := (curry.obj H').flip,
    suffices : G = G',
    { rw [← functor.uncurry_curry H, ← functor.uncurry_curry H'],
      congr' 1,
      rw [← functor.flip_flip (curry.obj H), ← functor.flip_flip (curry.obj H')],
      congr', },
    apply construction.uniq,
    suffices : (W₂.Q ⋙ G).flip = (W₂.Q ⋙ G').flip,
    { rw [← functor.flip_flip (W₂.Q ⋙ G), ← functor.flip_flip (W₂.Q ⋙ G'), this], },
    apply construction.uniq,
    convert congr_arg curry.obj eq,
    all_goals { apply functor.comp_comp_curry_flip_flip_eq_curry, },
  end, }

end strict_universal_property_fixed_target

include hW₁ hW₂

instance prod_construction_is_localization : (W₁.Q.prod W₂.Q).is_localization (W₁.prod W₂) :=
functor.is_localization.mk' _ _
  (strict_universal_property_fixed_target.prod W₁ W₂ _)
  (strict_universal_property_fixed_target.prod W₁ W₂ _)

instance prod_is_localization (L₁ : C₁ ⥤ D₁) (L₂ : C₂ ⥤ D₂)
  [L₁.is_localization W₁] [L₂.is_localization W₂] :
  (L₁.prod L₂).is_localization (W₁.prod W₂) :=
begin
  let E₁ := equivalence_from_model L₁ W₁,
  let E₂ := equivalence_from_model L₂ W₂,
  let e₁ : W₁.Q ⋙ E₁.functor ≅ L₁ := Q_comp_equivalence_from_model_functor_iso _ _,
  let e₂ : W₂.Q ⋙ E₂.functor ≅ L₂ := Q_comp_equivalence_from_model_functor_iso _ _,
  exact functor.is_localization.of_equivalence (W₁.Q.prod W₂.Q) (W₁.prod W₂) (L₁.prod L₂)
    (E₁.prod E₂) (functor.prod_functor.map_iso (e₁.prod e₂)),
end

end localization

variables {J : Type*} (C : J → Type u) [Π j, category (C j)]

def equivalence.pi' {J' : Type*} (α : J' ≃ J) :
  (Π j, C (α j)) ≌ (Π j', C j'):=
{ functor := functor.pi'_ (λ j, functor.pi_.eval _ (α.symm j) ⋙
    (pi.equivalence_of_eq C (show α (α.symm j) = j, by simp)).functor),
  inverse := functor.pi'_ (λ j', functor.pi_.eval _ (α j')),
  unit_iso := functor.pi_.mk_nat_iso (λ j', begin
    calc 𝟭 (Π (j : J'), C (α j)) ⋙ functor.pi_.eval (λ (j : J'), C (α j)) j' ≅ _ :
      functor.left_unitor _
    ... ≅ _ : (functor.pi_.eval_iso_of_eq (λ j, C (α j)) (show α.symm (α j') = j', by simp)).symm
    ... ≅ _ : _
    ... ≅ _ ⋙ functor.pi_.eval _ _ : (functor.pi'__eval_iso _ _).symm
    ... ≅ _ ⋙ _ ⋙ _ : iso_whisker_left _ ((functor.pi'__eval_iso _ _).symm)
    ... ≅ (_ ⋙ _) ⋙ _ : (functor.associator _ _ _).symm,
    { exact iso_whisker_left _ (pi.equivalence_of_eq_functor_iso C α (by simp)), },
  end),
  counit_iso := functor.pi_.mk_nat_iso
    (λ j, functor.associator _ _ _ ≪≫ iso_whisker_left _ (functor.pi'__eval_iso _ _) ≪≫
    (functor.associator _ _ _).symm ≪≫ iso_whisker_right (functor.pi'__eval_iso _ _) _ ≪≫
    functor.pi_.eval_iso_of_eq _ _ ≪≫ (functor.left_unitor _).symm),
  functor_unit_iso_comp' := λ X, begin
    ext j,
    dsimp [iso.refl],
    simp only [assoc, id_comp],
    erw nat_trans.id_app,
    dsimp,
    simp only [id_comp, comp_id, functor.map_id, eq_to_hom_app, functor.map_comp, assoc,
      pi.equivalence_of_eq_functor_iso_hom_app, eq_to_hom_map, eq_to_hom_trans, eq_to_hom_refl],
  end, }

lemma equivalence.pi'_inverse_comp_eval {J' : Type*} (α : J' ≃ J) (j' : J') :
  (equivalence.pi' C α).inverse ⋙ functor.pi_.eval _ j' = functor.pi_.eval _ (α j') := rfl

lemma equivalence.pi'_functor_comp_eval {J' : Type*} (α : J' ≃ J) (j' : J') :
  (equivalence.pi' C α).functor ⋙ functor.pi_.eval _ (α j') = functor.pi_.eval _ j' :=
begin
  dsimp only [equivalence.pi'],
  rw functor.pi'__eval,
  rw ← functor.pi_.eval_eq_of_eq (λ j', C (α j')) (show α.symm (α j') = j', by simp),
  rw pi.equivalence_of_eq_functor_eq C α,
end

variable {C}

@[simps]
def equivalence.pi'' {J' : Type*} (α : J ≃ J') {D : J' → Type*}
  [Π j', category (D j')] (e : Π j, C j ≌ D (α j)) :
  (Π j, C j) ≌ (Π j', D j') :=
(equivalence.pi e).trans (equivalence.pi' D α)

lemma equivalence.pi''_inverse_comp_eval {J' : Type*} (α : J ≃ J') {D : J' → Type*}
  [Π j', category (D j')] (e : Π j, C j ≌ D (α j)) (j : J) :
  (equivalence.pi'' α e).inverse ⋙ functor.pi_.eval _ j =
    functor.pi_.eval _ (α j) ⋙ (e j).inverse := rfl

lemma equivalence.pi''_functor_comp_eval {J' : Type*} (α : J ≃ J') {D : J' → Type*}
  [Π j', category (D j')] (e : Π j, C j ≌ D (α j)) (j : J) :
  (equivalence.pi'' α e).functor ⋙ functor.pi_.eval _ (α j) =
    functor.pi_.eval _ j ⋙ (e j).functor :=
begin
  dsimp only [equivalence.pi'', equivalence.trans],
  rw [functor.assoc, equivalence.pi'_functor_comp_eval],
  refl,
end

lemma is_iso_pi_iff {X Y : Π j, C j} (f : X ⟶ Y) :
  is_iso f ↔ ∀ j, is_iso (f j) :=
begin
  split,
  { introI,
    intro j,
    change is_iso ((functor.pi_.eval C j).map f),
    apply_instance, },
  { introI,
    exact ⟨⟨λ j, inv (f j), by tidy⟩⟩, },
end

def morphism_property.pi (W : Π j, morphism_property (C j)) :
  morphism_property (Π j, C j) := λ X Y f, ∀ j, (W j) (f j)

end

section

variables {J₁ J₂ : Type*} (C₁ : J₁ → Type u) (C₂ : J₂ → Type u)

@[simp]
def sum.desc : sum J₁ J₂ → Type u
|(sum.inl j₁) := C₁ j₁
|(sum.inr j₂) := C₂ j₂

variables [Π j₁, category.{v} (C₁ j₁)] [Π j₂, category.{v} (C₂ j₂)]

instance : Π j, category.{v} (sum.desc C₁ C₂ j) :=
λ j, by { cases j; dsimp only [sum.desc]; apply_instance, }

def equivalence_pi_prod :
  (Π j₁, C₁ j₁) × (Π j₂, C₂ j₂) ≌ (Π j, sum.desc C₁ C₂ j) :=
{ functor := functor.pi'_ (λ j, match j with
    | sum.inl j₁ := category_theory.prod.fst _ _ ⋙ functor.pi_.eval _ j₁
    | sum.inr j₂ := category_theory.prod.snd _ _ ⋙ functor.pi_.eval _ j₂
  end),
  inverse := functor.prod'
    (functor.pi'_ (λ j₁, functor.pi_.eval _ (sum.inl j₁)))
    (functor.pi'_ (λ j₂, functor.pi_.eval _ (sum.inr j₂))),
  unit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)),
  counit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)), }

end

section

variables {J : Type*} {T : Type*} (C : J → T) (C₀ : T)

@[simp]
def option.desc : option J → T
| none := C₀
| (some j) := C j

lemma option.is_desc (f : option J → T) : ∃ (C : J → T) (C₀ : T), f = option.desc C C₀ :=
⟨λ j, f (some j), f none, by { ext j, cases j; refl, }⟩

def option.desc' {C : J → Type u} {C₀ : Type u}
  (f : Π j, C j) (f₀ : C₀) : Π (j : option J), option.desc C C₀ j
| none := f₀
| (some j) := f j

lemma option.is_desc'
  {C : J → Type u} {C₀ : Type u} (g : Π (j : option J), option.desc C C₀ j) :
  ∃ (f : Π j, C j) (f₀ : C₀), g = option.desc' f f₀ :=
⟨λ j, g (some j), g none, by { ext j, cases j; refl,}⟩

end

section

variables {J : Type*} (j : J) [subsingleton J] (C : J → Type*) [Π t, category (C t)]

def equivalence_pi_single :
  (Π t, C t) ≌ C j :=
{ functor := functor.pi_.eval _ j,
  inverse := functor.pi'_ (λ t, begin
    have eq := subsingleton.elim j t,
    subst eq,
    exact 𝟭 _,
  end),
  unit_iso := eq_to_iso begin
    refine functor.ext _ _,
    { intro X,
      ext t,
      have eq := subsingleton.elim j t,
      subst eq,
      refl, },
    { intros X Y f,
      ext t,
      have eq := subsingleton.elim j t,
      subst eq,
      simp, },
  end,
  counit_iso := eq_to_iso rfl, }

end

section

variables {J : Type} (C : option J → Type u) [Π j', category.{v} (C j')]

def equivalence_pi_option : (Π j', C j') ≌ (Π j, C (some j)) × C none :=
{ functor := functor.prod' (functor.pi'_ (λ j, functor.pi_.eval _ (some j))) (functor.pi_.eval _ none),
  inverse := functor.pi'_ (λ j, match j with
    | none := prod.snd _ _
    | (some j) := prod.fst _ _ ⋙ functor.pi_.eval _ j
  end),
  unit_iso := eq_to_iso (functor.pi_.ext (λ j, by { cases j; refl, })),
  counit_iso := eq_to_iso (functor.prod.ext rfl rfl), }

end

section

variables {J : Type*} {C : J → Type*} {D : J → Type*}
  [Π j, category (C j)] [Π j, category (D j)]
  (W : Π j, morphism_property (C j))
  (L : Π j, C j ⥤ D j)

lemma morphism_property.is_inverted_by.pi (h : ∀ j, (W j).is_inverted_by (L j)):
  (morphism_property.pi W).is_inverted_by (functor.pi_ (λ j, L j)) :=
λ X Y f hf, by { rw is_iso_pi_iff, exact λ j, h _ _ (hf j), }

instance [Π j, (W j).contains_identities] :
  morphism_property.contains_identities (morphism_property.pi W) :=
⟨λ X j, morphism_property.contains_identities.id (W j) (X j)⟩

end

namespace localization

variables (J : Type) [finite J] {C : J → Type*} {D : J → Type*}
  [Π j, category (C j)] [Π j, category (D j)]
  (W : Π j, morphism_property (C j))
  [hW : ∀ j, (W j).contains_identities]
  (L : Π j, C j ⥤ D j) [Π j, (L j).is_localization (W j)]

include hW

instance pi_is_localization : ((functor.pi_ L).is_localization (morphism_property.pi W)) :=
begin
  unfreezingI { revert C D, },
  refine finite.induction_empty_option _ _ _ J,
  { intros J₁ J₂ e h₁ C₂ D₂, introI, introI, intros W₂, introI, intro L₂, introI,
    let C₁ := λ j₁, C₂ (e j₁),
    let D₁ := λ j₁, D₂ (e j₁),
    let L₁ : Π j₁, C₁ j₁ ⥤ D₁ j₁ := λ j₁, L₂ (e j₁),
    let W₁ : Π j₁, morphism_property (C₁ j₁) := λ j₁, W₂ (e j₁),
    haveI := h₁ W₁ L₁,
    let E : (Π j₁, C₁ j₁) ≌ (Π j₂, C₂ j₂) := equivalence.pi'' e (λ j₁, by refl),
    let E' : (Π j₁, D₁ j₁) ≌ (Π j₂, D₂ j₂) := equivalence.pi'' e (λ j₁, by refl),
    let Sq : Comm_sq E.symm.functor (functor.pi_ L₂) (functor.pi_ L₁) E'.symm.functor :=
      ⟨eq_to_iso (functor.pi_.ext (λ j₁, begin
        simp only [functor.assoc, functor.pi_eval],
        erw equivalence.pi''_inverse_comp_eval,
        simp only [← functor.assoc],
        erw equivalence.pi''_inverse_comp_eval,
        refl,
    end))⟩,
    have hW₁ : morphism_property.pi W₁ ⊆ (morphism_property.pi W₂).inverse_image' E.symm.inverse,
    { intros X₁ Y₁ f hf,
      refine ⟨X₁, Y₁, iso.refl _, iso.refl _, f, λ j₂, _, by tidy⟩,
      rcases e.surjective j₂ with ⟨j₁, hj₁⟩,
      subst hj₁,
      refine (W₂ (e j₁)).of_arrow_mk_eq _ _ (hf j₁) _,
      exact functor.congr_map_arrow_obj_arrow_mk (equivalence.pi''_functor_comp_eval e _ _) f, },
    exact (functor.is_localization.of_equivalence'' E.symm E'.symm Sq
      (morphism_property.pi W₂) (morphism_property.pi W₁)
      (morphism_property.is_inverted_by.pi W₂ L₂ (λ j₂, localization.inverts _ _)) hW₁), },
  { intros C D, introI, introI, intros W, introI, intro L, introI,
    haveI : is_equivalence (functor.pi_ L) :=
    { inverse :=
      { obj := λ Y j, by induction j,
        map := λ X Y f j, by induction j, },
      unit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)),
      counit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)), },
    apply functor.is_localization.of_is_equivalence (functor.pi_ L) (morphism_property.pi W),
    intros X Y f hf,
    rw morphism_property.isomorphisms.iff,
    rw is_iso_pi_iff,
    intro j,
    induction j, },
  { intro J, introI, intros hJ C' D', introI, introI, intros W' hW' L' hL',
    let W := λ j, W' (some j),
    let W₀ := W' none,
    let L := λ j, L' (some j),
    let L₀ := L' none,
    let E := equivalence_pi_option C',
    let E' := equivalence_pi_option D',
    haveI : L₀.is_localization W₀ := hL' none,
    let H : Comm_sq (equivalence_pi_option C').functor (functor.pi_ L') (functor.prod (functor.pi_ L) L₀) (equivalence_pi_option D').functor := ⟨eq_to_iso rfl⟩,
    have hW₁ := morphism_property.is_inverted_by.pi W' L' (λ j, localization.inverts _ _),
    have hW₂ : (morphism_property.pi W).prod W₀ ⊆ (morphism_property.pi W').inverse_image' E.inverse,
    { intros X Y f hf,
      refine ⟨X, Y, iso.refl X, iso.refl Y, f, _, comm_sq.mk (by simp)⟩,
      rintro (_|j),
      { exact hf.2, },
      { exact hf.1 j, }, },
    exact functor.is_localization.of_equivalence'' E E' H (morphism_property.pi W')
      (morphism_property.prod (morphism_property.pi W) W₀) hW₁ hW₂, },
end

end localization

def morphism_property.functor_category {C : Type*} [category C]
  (W : morphism_property C) (J : Type*) [category J] :
  morphism_property (J ⥤ C) := λ X Y f, ∀ j, W (f.app j)

namespace localization

variables (J : Type) [finite J] {C D : Type*} [category C] [category D]
  (W : morphism_property C)
  [morphism_property.contains_identities W]
  (L : C ⥤ D) [L.is_localization W]

instance whiskering_right_discrete_is_localization :
  ((whiskering_right (discrete J) C D).obj L).is_localization (W.functor_category _) :=
begin
  let E := pi_equivalence_functors_from_discrete C J,
  let E' := pi_equivalence_functors_from_discrete D J,
  let L₁ := (whiskering_right (discrete J) C D).obj L,
  let L₂ := functor.pi_ (λ (j : J), L),
  let H : Comm_sq E.symm.functor L₁ L₂ E'.symm.functor := ⟨iso.refl _⟩,
  refine functor.is_localization.of_equivalence'' E.symm E'.symm H (W.functor_category _)
    (morphism_property.pi (λ j, W)) _ _,
  { intros X Y f hf,
    haveI : ∀ (j : discrete J), is_iso ((((whiskering_right
      (discrete J) C D).obj L).map f).app j),
    { rintro ⟨j⟩,
      dsimp,
      exact localization.inverts L W _ (hf (discrete.mk j)), },
    apply nat_iso.is_iso_of_is_iso_app, },
  { refine has_subset.subset.trans _ (morphism_property.inverse_image_subset_inverse_image' _ _),
    rintros X Y f hf ⟨j⟩,
    exact hf j, },
end

end localization

end category_theory


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (((a2).write i2 ((a2).read i1)).read i1) ≠ ((a2).read i1) → False := by
  arr


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

import for_mathlib.algebra.homology.hom_complex
import for_mathlib.algebra.homology.bounded_above

noncomputable theory

open category_theory category_theory.category category_theory.limits category_theory.preadditive

namespace cochain_complex

namespace hom_complex

variables {C : Type*} [category C] [preadditive C]

variables {F G K : cochain_complex C ℤ} {n : ℤ} (z : cocycle F G n) {m : ℤ} [∀ p, has_binary_biproduct (F.X (p+1-n)) (G.X p)]
include z

namespace twist

@[protected, simp]
def δ (p q : ℤ) :
  biprod (F.X (p+1-n)) (G.X p) ⟶ biprod (F.X (q+1-n)) (G.X q) :=
begin
  refine biprod.desc (biprod.lift (ε (n+1) • F.d (p+1-n) (q+1-n)) _) (biprod.lift 0 (G.d p q)),
  by_cases p+1 = q,
  { exact (z : cochain F G n).v (p+1-n) q (show q=(p+1-n)+n, by linarith), },
  { exact 0, },
end

end twist

@[simps]
def twist : cochain_complex C ℤ :=
{ X := λ p, biprod (F.X (p+1-n)) (G.X p),
  d := λ p q, twist.δ z p q,
  shape' := λ p q hpq, begin
    dsimp [twist.δ],
    ext,
    { simp only [biprod.inl_desc, biprod.lift_fst, comp_zero, zero_comp],
      rw [F.shape, smul_zero],
      intro h,
      apply hpq,
      change p+1-n+1=q+1-n at h,
      change p+1=q,
      linarith, },
    { simp only [biprod.inl_desc, biprod.lift_snd, comp_zero, zero_comp],
      split_ifs,
      { exfalso, exact hpq h, },
      { refl, }, },
    { simp only [biprod.inr_desc, biprod.lift_fst, comp_zero, zero_comp], },
    { simp only [biprod.inr_desc, biprod.lift_snd, comp_zero, zero_comp, G.shape p q hpq], },
  end,
  d_comp_d' := λ i j k hij hjk, begin
    change i+1=j at hij,
    subst hij,
    change i+1+1=k at hjk,
    have hjk' : i+2 = k := by linarith,
    subst hjk',
    simp only [twist.δ, dif_pos rfl, dif_pos (show i+1+1 = i+2, by linarith)],
    ext,
    { simp only [add_zero, biprod.inl_desc_assoc, biprod.lift_desc, linear.smul_comp,
        add_comp, assoc, biprod.lift_fst,
        linear.comp_smul, homological_complex.d_comp_d, smul_zero, comp_zero, zero_comp], },
    { simp only [biprod.inl_desc_assoc, biprod.lift_desc, linear.smul_comp,
        add_comp, assoc, biprod.lift_snd, comp_zero, zero_comp],
      have hz₁ := z.2,
      rw cocycle.mem_iff n (n+1) rfl at hz₁,
      have hz₂ := cochain.congr_v hz₁ (i+1-n) (i+2) (by linarith),
      simp only [δ_v n (n+1) rfl _ (i+1-n) (i+2) (by linarith) (i+1) (i+1+1-n)
        (by linarith) (by linarith), cochain.zero_v] at hz₂,
      rw ← hz₂,
      abel, },
    { simp only [zero_add, biprod.inr_desc_assoc, biprod.lift_desc, zero_comp, assoc, biprod.lift_fst, comp_zero], },
    { simp only [zero_add, biprod.inr_desc_assoc, biprod.lift_desc, zero_comp, assoc, biprod.lift_snd, homological_complex.d_comp_d,
  comp_zero], },
  end }

namespace twist

omit z

lemma is_bounded_above (z : cocycle F G n) (hF : F.is_bounded_above) (hG : G.is_bounded_above) :
  (twist z).is_bounded_above :=
begin
  cases hF with r hr,
  cases hG with s hs,
  use max (r+n-1) s,
  intros i hi,
  dsimp only [twist],
  rw is_zero.iff_of_biprod,
  split,
  { apply hr,
    have h := lt_of_le_of_lt (le_max_left _ _) hi,
    linarith, },
  { apply hs,
    exact lt_of_le_of_lt (le_max_right _ _) hi, },
end

include z
def inl {n₀ : ℤ} (hn₀ : n₀+1=n) : cochain F (twist z) n₀ :=
cochain.mk (λ p q hpq, (cochain.of_hom (𝟙 F)).v p (q+1-n) (by linarith) ≫ biprod.inl)

def inr : G ⟶ twist z := { f := λ p, biprod.inr, }

def fst {n₁ : ℤ} (hn₁ : n+n₁=1) : cocycle (twist z) F n₁ :=
cocycle.mk (cochain.mk (λ p q hpq, biprod.fst ≫
  (cochain.of_hom (𝟙 F)).v (p+1-n) q (show q=p+1-n+0, by linarith))) (n₁+1) rfl
begin
  have hn₁' : n₁ = 1-n := by linarith,
  subst hn₁',
  ext1,
  simp only [δ_v (1-n) (1-n+1) rfl _ p q hpq (p+1-n) (p+1) (by linarith) rfl,
    cochain.mk_v, cochain.of_hom_v, homological_complex.id_f, comp_id, twist_d, twist.δ, dif_pos,
      cochain.zero_v],
  ext,
  { have hq : q = p+1+1-n := by linarith,
    subst hq,
    have eq : ε (1-n+1) * ε (n+1) = ε ((1 : ℤ) + 1 + 1) := by { rw ← ε_add, congr' 1, linarith, },
    have eq' : ε ((1 : ℤ)+1+1) = -1 := by { simp only [ε_succ, ε_1, neg_neg], },
    simp only [biprod.inl_fst_assoc, biprod.inl_desc_assoc, biprod.lift_fst, comp_add,
      cochain.of_hom_v, homological_complex.id_f, comp_zsmul, comp_id, comp_zero, smul_smul,
      eq, eq', neg_smul, one_zsmul, add_right_neg], },
  { simp only [zero_add, neg_eq_zero, comp_add, biprod.inr_fst_assoc, zero_comp,
      linear.comp_smul, biprod.inr_desc_assoc, biprod.lift_fst_assoc, smul_zero, comp_zero], },
end

def snd : cochain (twist z) G 0 :=
cochain.mk (λ p q hpq, biprod.snd ≫ (cochain.of_hom (𝟙 G)).v p q hpq)

@[simp]
lemma inl_comp_fst {n₀ n₁ : ℤ} (hn₀ : n₀+1=n) (hn₁ : n+n₁=1) :
  (inl z hn₀).comp ↑(fst z hn₁) (show 0=n₀+n₁, by linarith) = cochain.of_hom (𝟙 F) :=
begin
  ext,
  dsimp [cochain.comp, cochain.mk, cochain.v, cochain.of_hom, cochain.of_homs, inl, fst],
  simp only [id_comp, assoc, biprod.inl_fst_assoc, eq_to_hom_trans, eq_to_hom_refl],
end

@[simp]
lemma inl_comp_snd {n₀ : ℤ} (hn₀ : n₀+1=n) :
  (inl z hn₀).comp (snd z) (add_zero n₀).symm = 0 :=
begin
  ext,
  simp only [inl, snd, cochain.comp, cochain.mk, cochain.v, cochain.of_hom, cochain.of_homs,
    assoc, biprod.inl_snd_assoc, zero_comp, comp_zero, cochain.zero_v],
end

@[simp]
lemma inr_comp_fst {n₁ : ℤ} (hn₁ : n+n₁=1) :
  (cochain.of_hom (inr z)).comp (fst z hn₁ : cochain (twist z) F n₁) (zero_add n₁).symm = 0 :=
begin
  ext,
  simp only [inr, fst, cochain.zero_cochain_comp, cochain.of_hom_v, cocycle.mk_coe,
    cochain.mk_v, biprod.inr_fst_assoc, zero_comp, cochain.zero_v],
end

@[simp]
lemma inr_comp_snd :
  (cochain.of_hom (inr z)).comp (snd z) (add_zero 0).symm = cochain.of_hom (𝟙 G) :=
begin
  ext,
  simp only [inr, snd, cochain.comp_zero_cochain, cochain.mk_v, cochain.of_hom_v,
    homological_complex.id_f, comp_id, biprod.inr_snd],
end

@[simp]
lemma δ_inl {n₀ : ℤ} (hn₀ : n₀+1=n) :
  δ n₀ n (inl z hn₀) = cochain.comp ↑z (cochain.of_hom (inr z)) (add_zero n).symm :=
begin
  ext1,
  simp only [δ_v n₀ n hn₀ (inl z hn₀) p q hpq _ _ rfl rfl, twist_d, twist.δ],
  ext,
  { simp only [← hn₀, inl, cochain.mk_v, ε_succ, neg_neg, assoc, biprod.inl_desc, neg_smul,
      add_comp, biprod.lift_fst, comp_zsmul, cochain.of_hom_v_comp_d,
      homological_complex.id_f, id_comp, neg_comp, zsmul_comp, biprod.inl_fst, comp_id,
      cochain.d_comp_of_hom_v, add_right_neg, cochain.comp_zero_cochain, cochain.of_hom_v,
      inr, biprod.inr_fst, comp_zero], },
  { simp only [inl, inr, add_zero, sub_add_cancel, eq_self_iff_true, cochain.mk_v,
      dif_pos, assoc, biprod.inl_desc, add_comp, biprod.lift_snd,
      linear.smul_comp, biprod.inl_snd, comp_zero, smul_zero, cochain.comp_zero_cochain,
      cochain.of_hom_v, biprod.inr_snd, comp_id, id_comp,
      cochain.zero_cochain_comp' _ _ p (q-1+1-n) q, homological_complex.id_f], },
end

@[simp]
lemma δ_snd {n₁ : ℤ} (hn₁ : n+n₁=1) :
  δ 0 1 (snd z) = -cochain.comp (fst z hn₁ : cochain (twist z) F n₁) (↑z) (show 1 = n₁+n, by rw [← hn₁, add_comm]) :=
begin
  ext1,
  simp only [δ_v 0 1 (zero_add 1) _ p q hpq p q (by linarith) hpq, fst, snd, zero_add, ε_1,
    cochain.mk_v, cochain.of_hom_v, homological_complex.id_f, comp_id, neg_zsmul, one_zsmul,
    cochain.neg_v, cocycle.mk_coe, twist_d, twist.δ,
    cochain.comp_v _ _ (show 1=n₁+n, by linarith) p (p+1-n) q (by linarith) (by linarith)],
  ext,
  { simp only [dif_pos hpq.symm, zero_add, comp_add, biprod.inl_snd_assoc, zero_comp,
      comp_neg, biprod.inl_desc_assoc, biprod.lift_snd, biprod.inl_fst_assoc], },
  { simp only [neg_zero, comp_add, biprod.inr_snd_assoc, comp_neg, biprod.inr_desc_assoc,
      biprod.lift_snd, add_right_neg, biprod.inr_fst_assoc, zero_comp], },
end

lemma id_eq {n₀ n₁ : ℤ} (hn₀ : n₀+1=n)  (hn₁ : n+n₁=1) : cochain.of_hom (𝟙 (twist z)) =
cochain.comp ↑(fst z hn₁) (inl z hn₀) (show 0=n₁+n₀, by linarith) +
cochain.comp (snd z) (cochain.of_hom (inr z)) (zero_add 0).symm :=
begin
  ext1,
  simpa only [fst, inl, snd, inr, cochain.add_v,
    cochain.comp_v _ _ (show 0 = n₁+n₀, by linarith) p (p+1-n) p (by linarith) (by linarith),
    cochain.of_hom_v, homological_complex.id_f, cocycle.mk_coe, cochain.mk_v,
    comp_id, id_comp, cochain.comp_zero_cochain, biprod.total],
end

lemma cochain_ext (y₁ y₂ : cochain (twist z) K m) {n₀ n₁ : ℤ} (hn₀ : n₀+1=n)
  (hn₁ : n₁ = n₀+m) :
  y₁ = y₂ ↔ cochain.comp (inl z hn₀) y₁ hn₁ = cochain.comp (inl z hn₀) y₂ hn₁ ∧
    cochain.comp (cochain.of_hom (inr z)) y₁ (zero_add m).symm =
      cochain.comp (cochain.of_hom (inr z)) y₂ (zero_add m).symm :=
begin
  split,
  { intro h, rw h, tauto, },
  { rintro ⟨hl, hr⟩,
    suffices : cochain.comp (cochain.of_hom (𝟙 _)) y₁ (zero_add m).symm =
      cochain.comp (cochain.of_hom (𝟙 _)) y₂ (zero_add m).symm,
    { ext1,
      simpa only [cochain.id_comp] using cochain.congr_v this p q hpq, },
    simp only [id_eq z hn₀ (show n+(-n₀)=1, by linarith), cochain.add_comp,
      cochain.comp_assoc_of_second_is_zero_cochain,
      cochain.comp_assoc _ _ _ (show 0=-n₀+n₀, by linarith) (show n₁=n₀+m, by linarith)
      (show m=-n₀+n₀+m, by linarith), hl, hr], }
end

def desc_cochain {m m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : cochain G K m)
  (hm₁ : m₁+1=n+m) : cochain (twist z) K m :=
cochain.comp ↑(fst z (show n+(m-m₁) = 1, by linarith)) y₁ (eq_add_of_sub_eq rfl : m=(m-m₁)+m₁) +
  cochain.comp (snd z) y₂ (zero_add m).symm

lemma desc_cochain_eq {m m₁ n₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : cochain G K m)
  (hm₁ : m₁+1=n+m) (hn₁ : n+n₁=1) : desc_cochain z y₁ y₂ hm₁ =
cochain.comp ↑(fst z hn₁) y₁ (show m = n₁+m₁, begin
  suffices : m+1=n₁+m₁+1,
  { simpa only [add_left_inj] using this, },
  rw [add_assoc, hm₁, ← hn₁, add_comm n₁, add_comm n m, add_assoc],
end) + cochain.comp (snd z) y₂ (zero_add m).symm :=
begin
  have h : n₁ = m-m₁ := by linarith,
  subst h,
  refl,
end

lemma inl_comp_desc_cochain {m m₁ n₀ : ℤ} (y₁ : cochain F K m₁)
  (y₂ : cochain G K m) (hm₁ : m₁+1=n+m) (hn₀ : n₀+1=n) :
  cochain.comp (inl z hn₀) (desc_cochain z y₁ y₂ hm₁) begin
    suffices : m₁+1 = n₀+m+1,
    { simpa only [add_left_inj] using this, },
    rw [add_assoc, hm₁, ← hn₀, add_assoc, add_comm 1 m],
  end = y₁ :=
begin
  simp only [desc_cochain_eq z y₁ y₂ hm₁ (show n+(-n₀)=1, by linarith), cochain.comp_add,
    ← cochain.comp_assoc (inl z hn₀) _ y₁ (show 0=n₀+(-n₀), by linarith)
      (show m= _, by linarith) (show m₁=_, by linarith),
    ← cochain.comp_assoc_of_second_is_zero_cochain, add_zero,
    inl_comp_fst, inl_comp_snd, cochain.id_comp, cochain.zero_comp],
end

lemma inr_comp_desc_cochain {m m₁ : ℤ} (y₁ : cochain F K m₁)
  (y₂ : cochain G K m) (hm₁ : m₁+1=n+m) :
  cochain.comp (cochain.of_hom (inr z)) (desc_cochain z y₁ y₂ hm₁) (zero_add m).symm = y₂ :=
begin
  simp only [desc_cochain_eq z y₁ y₂ hm₁ (show n+(1-n)=1, by linarith), cochain.comp_add,
    ← cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_snd, cochain.id_comp,
    ← cochain.comp_assoc_of_first_is_zero_cochain, inr_comp_fst, cochain.zero_comp, zero_add],
end

lemma δ_desc_cochain {m m₁ m₂ n₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : cochain G K m)
  (hm₁ : m₁+1=n+m) (hn₁ : n+n₁=1) (hm₂ : m₁+1=m₂)
  (m' : ℤ) (hm' : m+1=m') :
  δ m m' (desc_cochain z y₁ y₂ hm₁) =
  cochain.comp (fst z hn₁ : cochain (twist z) F n₁) (δ m₁ m₂ y₁ +
    ε (m+1) • cochain.comp ↑z y₂ (show m₂ = n+m, by linarith)) (show m' = n₁+m₂, by linarith) +
  cochain.comp (snd z) (δ m m' y₂) (zero_add m').symm :=
begin
  simp only [desc_cochain_eq z y₁ y₂ hm₁ hn₁, δ_add, cochain.comp_add,
    δ_comp_of_first_is_zero_cochain _ _ _ hm', δ_snd z hn₁,
    δ_comp ↑(fst z hn₁) y₁ (show m = n₁+m₁, by linarith) _ m₂ m' hm' rfl hm₂,
    cochain.comp_zsmul, cochain.neg_comp, zsmul_neg, ε_add, ε_1, mul_neg, mul_one,
    neg_zsmul, cochain.comp_neg, cocycle.δ_eq_zero, cochain.zero_comp, zsmul_zero, add_zero,
    add_assoc],
  rw cochain.comp_assoc _ _ _ (show 1=n₁+n, by linarith) (show m₂=n+m, by linarith)
    (show m' = n₁+n+m, by linarith),
  conv_rhs { congr, skip, rw add_comm, },
end

@[simps]
def desc_cocycle {m m₁ n₂ : ℤ} (y₁ : cochain F K m₁) (y₂ : cocycle G K m)
  (hm₁ : m₁+1=n+m) (hn₂ : n₂ = n+m)
  (hy : δ m₁ n₂ y₁ = ε m • cochain.comp (z : cochain F G n) (y₂ : cochain G K m) hn₂) :
  cocycle (twist z) K m :=
cocycle.mk (desc_cochain z y₁ ↑y₂ hm₁) _ rfl
begin
  simp only [δ_desc_cochain z y₁ ↑y₂ hm₁ (show n+(1-n)=1, by linarith) (show m₁+1=n₂, by linarith) _ rfl,
    cocycle.δ_eq_zero, cochain.comp_zero, add_zero, hy, ε_add, ε_1, mul_neg, mul_one, neg_zsmul,
    add_right_neg, cochain.comp_zero],
end

lemma inr_comp_desc_cocycle {m m₁ n₂ : ℤ} (y₁ : cochain F K m₁) (y₂ : cocycle G K m)
  (hm₁ : m₁+1=n+m) (hn₂ : n₂ = n+m)
  (hy : δ m₁ n₂ y₁ = ε m • cochain.comp (z : cochain F G n) (y₂ : cochain G K m) hn₂) :
  cochain.comp (cochain.of_hom (inr z)) (desc_cocycle z y₁ y₂ hm₁ hn₂ hy : cochain (twist z) K m)
    (zero_add m).symm = y₂ :=
by simp only [desc_cocycle, cocycle.mk_coe, inr_comp_desc_cochain]

@[simps]
def desc_hom_as_cocycle {m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : G ⟶ K)(hm₁ : m₁+1=n)
  (hy : δ m₁ n y₁ = cochain.comp (z : cochain F G n) (cochain.of_hom y₂) (add_zero n).symm) :
  cocycle (twist z) K 0 :=
begin
  apply desc_cocycle z y₁ (cocycle.of_hom y₂) (by linarith) (add_zero n).symm,
  simpa only [hy, ε_0, one_zsmul],
end

@[simps]
def desc {m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : G ⟶ K)
  (hm₁ : m₁+1=n)
  (hy : δ m₁ n y₁ = cochain.comp (z : cochain F G n) (cochain.of_hom y₂) (add_zero n).symm) :
  twist z ⟶ K :=
cocycle.hom_of (desc_hom_as_cocycle z y₁ y₂ hm₁ hy)

@[simp]
lemma inr_comp_desc {m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : G ⟶ K)
  (hm₁ : m₁+1=n)
  (hy : δ m₁ n y₁ = cochain.comp (z : cochain F G n) (cochain.of_hom y₂) (add_zero n).symm) :
  inr z ≫ desc z y₁ y₂ hm₁ hy = y₂ :=
begin
  apply (cocycle.equiv_hom G K).to_equiv.injective,
  ext1,
  dsimp [cocycle.equiv_hom],
  simp only [cocycle.of_hom, cocycle.mk_coe, cochain.of_hom_comp, desc,
    cocycle.cochain_of_hom_hom_of_eq_coe, desc_hom_as_cocycle_coe, inr_comp_desc_cochain],
end

def lift_cochain {m₁ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m)
  (hm : m+1=m₁+n) : cochain K (twist z) m :=
cochain.comp y₁ (inl z (show (n-1)+1=n, by linarith)) (show m=m₁+(n-1), by linarith) +
  cochain.comp y₂ (cochain.of_hom (inr z)) (add_zero m).symm

lemma lift_cochain_eq {m₁ n₀ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₀ : n₀+1=n) : lift_cochain z y₁ y₂ hm =
cochain.comp y₁ (inl z hn₀) (begin
  suffices : m+1=m₁+n₀+1,
  { simpa only [add_left_inj] using this, },
  rw [hm, ← hn₀, add_assoc],
end) + cochain.comp y₂ (cochain.of_hom (inr z)) (add_zero m).symm :=
begin
  have eq : n₀ = n-1 := by linarith,
  subst eq,
  refl,
end

lemma lift_cochain_v {m₁ n₀ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m)
  (hm : m+1=m₁+n) (hn₀ : n₀+1 = n) (p q : ℤ) (hpq : q = p + m) (p' : ℤ) (hp' : p' = p + m₁):
  (lift_cochain z y₁ y₂ hm).v p q hpq =
    y₁.v p p' hp' ≫ (inl z hn₀).v p' q (by rw [hpq, hp', add_assoc, add_right_inj,
      ← add_left_inj (1 : ℤ), hm, ← hn₀, add_assoc]) +
    y₂.v p q hpq ≫ (inr z).f q :=
begin
  have hn₀' : n₀ = n-1 := by linarith,
  substs hn₀' hp' hpq,
  dsimp [lift_cochain, cochain.comp],
  simp only [cochain.of_hom_v],
end

@[simp]
lemma lift_cochain_comp_fst {m₁ n₁ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₁ : n+n₁=1) : cochain.comp (lift_cochain z y₁ y₂ hm) ↑(fst z hn₁)
    (show m₁=m+n₁, by { suffices : m₁+n = m+n₁+n,
    { simpa only [add_left_inj] using this,},
    rw [← hm, ← hn₁, add_comm n, add_assoc]}) = y₁ :=
begin
  simp only [lift_cochain, cochain.add_comp,
    cochain.comp_assoc _ _ _ (show m=m₁+(n-1), by linarith) (show 0=n-1+n₁, by linarith)
    (show m₁=_, by linarith), inl_comp_fst, cochain.comp_id, add_zero,
    cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_fst, cochain.comp_zero],
end

@[simp]
lemma lift_cochain_comp_snd {m₁ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n) :
  cochain.comp (lift_cochain z y₁ y₂ hm) (snd z) (add_zero m).symm = y₂ :=
by simp only [lift_cochain, cochain.add_comp, cochain.comp_assoc_of_third_is_zero_cochain,
    inl_comp_snd, cochain.comp_zero, zero_add, inr_comp_snd, cochain.comp_id]

lemma δ_lift_cochain {m₁ n₀ m₂ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₀ : n₀+1=n) (hm₂ : m₁+1=m₂) (m' : ℤ) (hm' : m+1=m') :
  δ m m' (lift_cochain z y₁ y₂ hm) =
    ε n₀ • cochain.comp (δ m₁ m₂ y₁) (inl z hn₀)
    (by rw [← hm', ← hm₂, hm, ← hn₀, add_comm n₀ 1, add_assoc]) +
  cochain.comp (δ m m' y₂ + cochain.comp y₁ ↑z (by rw [← hm', hm]))
    (cochain.of_hom (inr z)) (add_zero m').symm :=
begin
  simp only [lift_cochain_eq z y₁ y₂ hm hn₀, δ_add,
    δ_comp y₁ (inl z hn₀) (show m = m₁+n₀, by linarith) m₂ n m' hm' hm₂ hn₀,
    δ_comp_of_second_is_zero_cochain _ _ _ hm', δ_inl, cocycle.δ_cochain_of_hom,
    cochain.comp_zero, zero_add, cochain.comp_assoc_of_third_is_zero_cochain,
    cochain.add_comp],
  conv_lhs { rw [add_assoc, add_comm, add_assoc], },
end

def lift_cocycle {m₁ n₀ : ℤ} (y₁ : cocycle K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₀ : n₀+1=n) (m' : ℤ) (hm' : m+1=m')
  (hy : δ m m' y₂ + cochain.comp (y₁ : cochain K F m₁) ↑z (show m'=m₁+n, by rw [← hm', hm]) = 0) :
  cocycle K (twist z) m := cocycle.mk (lift_cochain z ↑y₁ y₂ hm) m' hm'
(by simp only [δ_lift_cochain z ↑y₁ y₂ hm hn₀ rfl m' hm', cocycle.δ_eq_zero, cochain.zero_comp,
    zsmul_zero, zero_add, hy])

@[simps]
def lift_hom_as_cocycle {m₁ n₀ : ℤ} (y₁ : cocycle K F m₁) (y₂ : cochain K G 0) (hm : m₁+n=1)
  (hn₀ : n₀+1=n)
  (hy : δ 0 1 y₂ + cochain.comp (y₁ : cochain K F m₁) ↑z hm.symm = 0) : cocycle K (twist z) 0 :=
lift_cocycle z y₁ y₂ (show 0+1 = m₁+n, by linarith) hn₀ 1 (zero_add 1) hy

@[simps]
def lift {m₁ n₀ : ℤ} (y₁ : cocycle K F m₁) (y₂ : cochain K G 0) (hm : m₁+n=1)
  (hn₀ : n₀+1=n)
  (hy : δ 0 1 y₂ + cochain.comp (y₁ : cochain K F m₁) ↑z hm.symm = 0) :
  K ⟶ twist z :=
cocycle.hom_of (lift_hom_as_cocycle z y₁ y₂ hm hn₀ hy)

lemma cochain_ext' (y₁ y₂ : cochain K (twist z) m) {n₁ m₁ : ℤ} (hn₁ : n+n₁=1) (hm₁ : m₁ = m+n₁) :
  y₁ = y₂ ↔ cochain.comp y₁ (fst z hn₁ : cochain (twist z) F n₁) hm₁
      = cochain.comp y₂ (fst z hn₁ : cochain (twist z) F n₁) hm₁ ∧
  cochain.comp y₁ (snd z) (add_zero m).symm =
  cochain.comp y₂ (snd z) (add_zero m).symm :=
begin
  split,
  { intro h, rw h, tauto, },
  { rintro ⟨hl, hr⟩,
    suffices : cochain.comp y₁ (cochain.of_hom (𝟙 _)) (add_zero m).symm =
      cochain.comp y₂ (cochain.of_hom (𝟙 _)) (add_zero m).symm,
    { ext1,
      simpa only [cochain.comp_id] using cochain.congr_v this p q hpq, },
    simp only [id_eq z (show n-1+1=n, by linarith) hn₁, cochain.add_comp,
      cochain.comp_add],
    simp only [← cochain.comp_assoc_of_second_is_zero_cochain,
      ← cochain.comp_assoc _ _ _ hm₁ (show 0=n₁+(n-1), by linarith)
      (show m=m+n₁+(n-1), by linarith), hl, hr], },
end

lemma of_d_eq (n₁ n₂ n₃ : ℤ) (hn₁ : n + n₁ = 1) (hn₂ : n₂ = n₁+1) (hn₃ : n₃+1=n) : cochain.of_d (twist z) =
  ε (n+1) • ((fst z hn₁ : cochain (twist z) F n₁).comp (cochain.of_d F) hn₂).comp (inl z hn₃)
    (by rw [← hn₁, hn₂, ← hn₃, add_comm n₃, add_assoc, add_comm n₃, ← add_assoc, add_comm n₁]) +
    ((fst z hn₁ : cochain (twist z) F n₁).comp (z : cochain F G n) (show 1 = n₁ + n, by rw [← hn₁, add_comm])).comp
      (cochain.of_hom (inr z)) (add_zero 1).symm +
    ((snd z).comp (cochain.of_d G) (zero_add 1).symm).comp (cochain.of_hom (inr z)) (add_zero 1).symm :=
begin
  rw cochain_ext z (cochain.of_d (twist z)) _ hn₃ hn₃.symm,
  split,
  { simp only [cochain.comp_add, cochain.comp_zsmul],
    simp only [← cochain.comp_assoc_of_third_is_zero_cochain,
      ← cochain.comp_assoc_of_second_is_zero_cochain, inl_comp_snd, inl_comp_fst, cochain.id_comp,
      ← cochain.comp_assoc (inl z hn₃) _ _ (show 1 = n₃+n₂, by linarith) _ (show n = n₃+n₂+n₃, by linarith),
      ← cochain.comp_assoc (inl z hn₃) _ _ (show 0 = n₃ + n₁, by linarith) _ (show 1 = n₃ + n₁ + 1, by linarith),
      ← cochain.comp_assoc (inl z hn₃) _ _ (show 0 = n₃ + n₁, by linarith) (show 1 = n₁ + n, by linarith)
      (show n = n₃+n₁+n, by linarith), cochain.zero_comp, add_zero,
      cochain_ext' z _ _ hn₁ (show 1 = n+n₁, by linarith)],
    split,
    { simp only [cochain.add_comp, cochain.zsmul_comp,
        cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_fst, cochain.comp_zero, inl_comp_fst,
        cochain.comp_assoc _ (inl z hn₃) _ (show n = 1+n₃, by linarith) (show 0 = n₃ + n₁, by linarith)
        (show 1 = 1 + n₃ + n₁, by linarith), add_zero, cochain.comp_id],
      ext p q hpq,
      dsimp [inl, fst, cochain.comp],
      simp only [twist.δ, cochain.of_d_v, twist_d, assoc, biprod.inl_desc, biprod.lift_fst_assoc,
        linear.smul_comp, cochain.d_comp_of_hom_v, homological_complex.id_f, comp_id,
        linear.comp_smul, cochain.of_hom_v_comp_d, id_comp], },
    { simp only [cochain.comp_assoc_of_third_is_zero_cochain, cochain.add_comp, cochain.zsmul_comp,
        inl_comp_snd, inr_comp_snd, cochain.comp_zero, zsmul_zero, zero_add, cochain.comp_id],
      ext p q hpq,
      have hp : ∃ (p' : ℤ), p = p' + 1 -n := ⟨p+n-1, by linarith⟩,
      obtain ⟨p', hp'⟩ := hp,
      subst hp',
      rw cochain.comp_v _ _ hn₃.symm (p'+1-n) p' q (by linarith) (by linarith),
      dsimp [inl, snd],
      simp only [cochain.of_hom_v, homological_complex.id_f, id_comp, cochain.comp_zero_cochain,
        twist.δ, cochain.of_d_v, twist_d, cochain.mk_v, comp_id, biprod.inl_desc_assoc,
        biprod.lift_snd, dif_pos (show p'+1 = q, by linarith)], }, },
  { simp only [ε_succ, neg_smul,
      cochain.comp_add, cochain.comp_neg, cochain.comp_zsmul,
      ← cochain.comp_assoc_of_first_is_zero_cochain, inr_comp_fst, cochain.zero_comp, zsmul_zero,
      zero_add, neg_zero, inr_comp_snd, cochain.id_comp,
      cochain_ext' z _ _ hn₁ (show n₂ = 1 + n₁, by linarith)],
    split,
    { rw [cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_fst, cochain.comp_zero],
      ext p q hpq,
      simp only [cochain.comp_assoc_of_first_is_zero_cochain, cochain.zero_cochain_comp,
        cochain.of_hom_v, cochain.zero_v,
        cochain.comp_v _ _ (show n₂ = 1 + n₁, by linarith) p (p+1) q rfl (by linarith)],
      dsimp [inr, fst],
      simp only [twist.δ, cochain.of_d_v, twist_d, biprod.inr_desc_assoc,
        biprod.lift_fst_assoc, zero_comp], },
    { rw [cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_snd, cochain.comp_id],
      ext p q hpq,
      dsimp [inr, snd],
      simp only [cochain.comp_assoc_of_third_is_zero_cochain, cochain.zero_cochain_comp,
        cochain.of_hom_v, cochain.comp_zero_cochain, twist.δ, cochain.of_d_v, twist_d,
        cochain.mk_v, homological_complex.id_f, comp_id, biprod.inr_desc_assoc,
        biprod.lift_snd], }, },
end

end twist

end hom_complex

end cochain_complex


import for_mathlib.derived.bounded_homotopy_category
import for_mathlib.is_quasi_iso_sigma
import for_mathlib.coprod_op
import for_mathlib.derived.example

open category_theory
open category_theory.limits

universes v u
variables {A : Type u} [category.{v} A] [abelian A] [has_coproducts.{v} A]

open_locale zero_object

namespace bounded_homotopy_category

noncomputable
def cofan {α : Type v} (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : cofan X := cofan.mk
{ val := (homotopy_category.colimit_cofan $ λ a : α, (X a).val).X,
  bdd := begin
    obtain ⟨n,hn⟩ := homotopy_category.is_uniformly_bounded_above.cond (val ∘ X),
      use n, intros i hi,
    dsimp [homotopy_category.colimit_cofan],
    let e : (∐ λ (a : α), (X a).val.as).X i ≅
      (∐ λ (a : α), (X a).val.as.X i) := homotopy_category.coproduct_iso _ _,
    refine is_zero_of_iso_of_zero _ e.symm,
    apply category_theory.is_zero_colimit,
    intros j,
    refine hn j.as _ hi,
  end }
(λ a, (homotopy_category.colimit_cofan (λ a : α, (X a).val)).ι.app ⟨a⟩)

noncomputable
def is_colimit_cofan {α : Type v} (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : is_colimit (cofan X) :=
{ desc := λ S, (homotopy_category.is_colimit_cofan
    (λ a : α, (X a).val)).desc ((forget A).map_cocone S),
  fac' := begin
    intros S j,
    erw (homotopy_category.is_colimit_cofan (λ a : α, (X a).val)).fac
      ((forget A).map_cocone S) j, refl,
  end,
  uniq' := begin
    intros S m hm,
    apply (homotopy_category.is_colimit_cofan (λ a : α, (X a).val)).hom_ext,
    intros j,
    specialize hm j,
    erw hm,
    erw (homotopy_category.is_colimit_cofan (λ a : α, (X a).val)).fac,
    refl,
  end }

instance has_coproduct_of_uniform_bound {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] :
  has_coproduct X :=
begin
  constructor, apply nonempty.intro,
  refine ⟨cofan X, is_colimit_cofan X⟩,
end

instance is_K_projective_sigma {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  [∀ a, homotopy_category.is_K_projective (X a).val] :
  homotopy_category.is_K_projective (sigma_obj X).val :=
begin
  let e : (sigma_obj X) ≅ (cofan X).X :=
    (colimit.is_colimit _).cocone_point_unique_up_to_iso (is_colimit_cofan X),
  let ee := (forget A).map_iso e,
  suffices : homotopy_category.is_K_projective ((forget A).obj (cofan X).X),
  { resetI, apply homotopy_category.is_K_projective_of_iso _ _ ee.symm },
  dsimp [forget, cofan],
  apply_instance,
end

noncomputable
instance forget_preserves_coproduct {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] :
  preserves_colimit (discrete.functor X) (forget A) :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone (is_colimit_cofan X),
  let E : (forget A).map_cocone (cofan X) ≅
    homotopy_category.colimit_cofan (val ∘ X) :=
    cocones.ext (iso.refl _) _,
  rotate,
  { intros a, dsimp [forget, cofan], simpa only [category.comp_id] },
  apply is_colimit.of_iso_colimit _ E.symm,
  apply homotopy_category.is_colimit_cofan,
end

lemma is_quasi_iso_sigma
  [AB4 A]
  {α : Type v}
  (X P : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  [uniformly_bounded P]
  (π : Π a, P a ⟶ X a)
  [∀ a, homotopy_category.is_quasi_iso (π a)] :
  homotopy_category.is_quasi_iso
    (sigma.desc $ λ a : α, π a ≫ sigma.ι X a : sigma_obj P ⟶ sigma_obj X) :=
begin
  let t := sigma.desc (λ (a : α), π a ≫ sigma.ι X a),
  change homotopy_category.is_quasi_iso ((forget A).map t),
  let eP : (forget A).obj (∐ P) ≅ ∐ (λ a, (forget A).obj (P a)) :=
    preserves_colimit_iso (forget A) _,
  let eX : (forget A).obj (∐ X) ≅ ∐ (λ a, (forget A).obj (X a)) :=
    preserves_colimit_iso (forget A) _,
  let s : ∐ (λ a, (forget A).obj (P a)) ⟶ ∐ (λ a, (forget A).obj (X a)) :=
    sigma.desc (λ (a : α), π a ≫ sigma.ι (val ∘ X) a),
  suffices : (forget A).map t = eP.hom ≫ s ≫ eX.inv,
  { rw this,
    apply homotopy_category.is_quasi_iso_comp },
  apply (is_colimit_of_preserves (forget A) (colimit.is_colimit _)).hom_ext,
  swap, apply_instance,
  intros a,
  dsimp [t, s, eP, eX, preserves_colimit_iso, is_colimit.cocone_point_unique_up_to_iso],
  rw [← (forget A).map_comp, colimit.ι_desc],
  slice_rhs 0 1
  { erw (is_colimit_of_preserves (forget A) (colimit.is_colimit (discrete.functor P))).fac },
  erw colimit.ι_desc,
  dsimp, simp only [category.assoc], erw colimit.ι_desc,
  dsimp, simp only [functor.map_comp], refl,
end

variables [enough_projectives A]

noncomputable
def uniform_π {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : sigma_obj (replace_uniformly X) ⟶ sigma_obj X :=
sigma.desc $ λ a, π_uniformly _ _ ≫ sigma.ι _ a

instance is_quasi_iso_sigma_map_π_uniformly
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] :
  homotopy_category.is_quasi_iso (uniform_π X) :=
is_quasi_iso_sigma _ _ _

open opposite

noncomputable
def Ext_coproduct_iso
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y) :
  ((Ext i).obj (op (sigma_obj X))).obj Y ≅
  pi_obj (λ a : α, ((Ext i).obj (op (X a))).obj Y) :=
Ext_iso i _ _ _ (uniform_π X) ≪≫
category_theory.preadditive_yoneda_coproduct_iso (replace_uniformly X) (Y⟦i⟧) ≪≫
category_theory.pi_iso _ _ (λ a, (Ext_iso i _ _ _ (π_uniformly X a)).symm)

lemma ι_Ext_coprodut_iso
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y) (j) :
  (Ext_coproduct_iso X i Y).inv ≫
  ((Ext i).map (sigma.ι X j : X j ⟶ ∐ X).op).app Y =
  pi.π _ _ :=
begin
  rw iso.inv_comp_eq,
  dsimp [Ext_coproduct_iso, pi_iso],
  simp only [category.assoc, limit.lift_π, fan.mk_π_app],
  simp only [← category.assoc], rw iso.eq_comp_inv,
  dsimp [Ext, Ext_iso], --ext t, simp only [comp_apply],
  dsimp [preadditive_yoneda_coproduct_iso, preadditive_yoneda_coproduct_to_product],
  simp only [category.assoc, limit.lift_π],
  ext t, simp only [comp_apply], dsimp,
  simp only [← category.assoc], congr' 1,
  apply lift_ext (∐ X).π, swap, apply_instance,
  dsimp [uniform_π],
  simp,
end

lemma ι_Ext_coproduct_iso'
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y) (j) :
  (Ext_coproduct_iso X i Y).hom ≫  pi.π _ _ =
  ((Ext i).map (sigma.ι X j : X j ⟶ ∐ X).op).app Y :=
begin
  rw [← iso.eq_inv_comp, ι_Ext_coprodut_iso],
end

lemma Ext_coproduct_iso_naturality
  [AB4 A]
  {α : Type v}
  (X₁ X₂ : α → bounded_homotopy_category A)
  [uniformly_bounded X₁]
  [uniformly_bounded X₂]
  (g : X₁ ⟶ X₂)
  (i : ℤ) (Y) :
  ((Ext i).map (sigma.desc (λ b, g b ≫ sigma.ι X₂ b) : ∐ X₁ ⟶ ∐ X₂).op).app Y ≫
  (Ext_coproduct_iso _ _ _).hom =
  (Ext_coproduct_iso _ _ _).hom ≫
  pi.lift (λ b, pi.π _ b ≫ ((Ext i).map (g b).op).app Y) :=
begin
  dsimp only [Ext_coproduct_iso, Ext, Ext0, Ext_iso, functor.comp_map, whiskering_left,
    whisker_left, iso.trans_hom, functor.map_iso, preadditive_yoneda_coproduct_iso,
    functor.flip, pi_iso, as_iso, preadditive_yoneda_coproduct_to_product],
  simp only [category.assoc],
  simp only [quiver.hom.unop_op, iso.op_hom, replacement_iso_hom, iso.op_inv,
    replacement_iso_inv, iso.symm_mk],
  apply limit.hom_ext,
  intros j,
  simp only [category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π_assoc],
  simp only [← functor.map_comp, ← op_comp],
  congr' 2,
  simp only [category.assoc],
  apply lift_ext (∐ X₂).π, swap, apply_instance,
  dsimp [quiver.hom.unop_op],
  simp only [category.assoc, lift_lifts, lift_lifts_assoc],
  dsimp [uniform_π],
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc, colimit.ι_desc,
    lift_lifts_assoc],
end

lemma Ext_coproduct_iso_naturality'
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y₁ Y₂) (f : Y₁ ⟶ Y₂) :
  ((Ext i).obj (op (sigma_obj X))).map f ≫
  (Ext_coproduct_iso _ _ _).hom =
  (Ext_coproduct_iso _ _ _).hom ≫
  pi.lift (λ a, pi.π _ a ≫ ((Ext i).obj _).map f) :=
begin
  dsimp only [Ext_coproduct_iso, Ext, Ext0, Ext_iso, functor.comp_map, whiskering_left,
    whisker_left, iso.trans_hom, functor.map_iso, preadditive_yoneda_coproduct_iso,
    functor.flip, pi_iso, as_iso, preadditive_yoneda_coproduct_to_product,
    functor.comp_map, functor.comp_obj],
  simp only [category.assoc],
  simp only [quiver.hom.unop_op, iso.op_hom, replacement_iso_hom, iso.op_inv,
    replacement_iso_inv, iso.symm_mk],
  apply limit.hom_ext,
  intros j,
  simp only [category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π_assoc],
  erw nat_trans.naturality,
  erw nat_trans.naturality_assoc,
  erw nat_trans.naturality_assoc,
  refl,
end

end bounded_homotopy_category

-- TODO: find better names... And move this stuff!

instance chain_complex_embed_cofan_uniformly_bounded
  {α : Type v}
  (X : α → chain_complex A ℕ) :
  bounded_homotopy_category.uniformly_bounded
  (λ a, chain_complex.to_bounded_homotopy_category.obj (X a)) :=
begin
  constructor, use 1, intros a i hi,
  rcases i with (_|i)|_,
  { exfalso, revert hi, dec_trivial },
  { exact is_zero_zero _, },
  { exfalso, revert hi, dec_trivial }
end

universe u'

def whisker_discrete_functor {α : Type v}
  {C : Type u} {D : Type u'} [category.{v} C] [category.{v} D] (F : C ⥤ D)
  (X : α → C) : discrete.functor X ⋙ F ≅ discrete.functor (F.obj ∘ X) :=
  discrete.nat_iso (λ i, iso.refl _)

noncomputable
lemma preserves_coproducts_aux
  {α : Type v} {C : Type u} {D : Type u'}
  [category.{v} C] [category.{v} D]
  (F : C ⥤ D)
  [has_coproducts_of_shape α C]
  [∀ (X : α → C), has_coproduct (λ a, F.obj (X a))]
  (e : Π (X : α → C), F.obj (∐ X) ≅ ∐ (λ a, F.obj (X a)))
  (he : ∀ (X : α → C) (a : α), F.map (sigma.ι X a) ≫ (e X).hom = sigma.ι _ a) :
  preserves_colimits_of_shape (discrete α) F :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor (K.obj ∘ discrete.mk) := discrete.nat_iso (λ ⟨a⟩, iso.refl _),
  apply preserves_colimit_of_iso_diagram _ E.symm,
  apply preserves_colimit_of_preserves_colimit_cocone (colimit.is_colimit _),
  swap, apply_instance,
  let P := _, change is_colimit P,
  let P' := (cocones.precompose (whisker_discrete_functor F _).inv).obj P,
  suffices : is_colimit P',
  { exact is_colimit.precompose_inv_equiv _ _ this },
  apply is_colimit.of_iso_colimit (colimit.is_colimit _), swap,
  change has_colimit (discrete.functor (λ a : α, F.obj (K.obj ⟨a⟩))),
  apply_instance,
  symmetry,
  fapply cocones.ext,
  apply e,
  rintro ⟨a⟩,
  convert (he (λ b, (K.obj ⟨b⟩))) a,
  dsimp [P', whisker_discrete_functor],
  rw category.id_comp,
end

noncomputable
instance homological_complex_embed_preserves_coproducts {α : Type v}
  {M N : Type} (c₁ : complex_shape M) (c₂ : complex_shape N) (e : c₁.embedding c₂) :
  preserves_colimits_of_shape (discrete α)
  (homological_complex.embed e : homological_complex A _ ⥤ _) :=
preserves_coproducts_aux
(homological_complex.embed e : homological_complex A _ ⥤ _)
(λ (X : α → homological_complex A c₁), homological_complex.hom.iso_of_components
(λ i,
begin
  rcases h : e.r i with _ | j,
  { refine homological_complex.embed.X_iso_of_none _ h ≪≫ _,
    refine _ ≪≫ (preserves_colimit_iso (homological_complex.eval A c₂ i) _).symm,
    refine (is_zero.iso_zero _).symm,
    apply is_zero_colimit,
    intros a,
    dsimp,
    exact homological_complex.embed.X_is_zero_of_none _ h },
  { refine homological_complex.embed.X_iso_of_some _ h ≪≫ _,
    refine (preserves_colimit_iso (homological_complex.eval _ _ _) _) ≪≫ _,
    refine _ ≪≫ (preserves_colimit_iso (homological_complex.eval _ _ _) _).symm,
    refine has_colimit.iso_of_nat_iso _,
    refine discrete.nat_iso _,
    intros b,
    dsimp,
    refine (homological_complex.embed.X_iso_of_some _ h).symm }
end) begin
  intros i j h,
  rcases h₁ : e.r i with _ | i';
  rcases h₂ : e.r j with _ | j',
  { apply is_zero.eq_of_src,
    apply homological_complex.embed.X_is_zero_of_none,
    assumption },
  { apply is_zero.eq_of_src,
    apply homological_complex.embed.X_is_zero_of_none,
    assumption },
  { apply is_zero.eq_of_tgt,
    refine is_zero.of_iso _
      (preserves_colimit_iso (homological_complex.eval _ _ _) _),
    apply is_zero_colimit, intros b,
    apply homological_complex.embed.X_is_zero_of_none,
    assumption },
  { simp_rw [h₁, h₂], dsimp,
    simp only [category.assoc],
    rw ← iso.eq_inv_comp,
    dsimp [homological_complex.embed, homological_complex.embed.obj],
    rw homological_complex.embed.d_of_some_of_some (∐ X) h₁ h₂,
    simp only [category.assoc, iso.inv_hom_id_assoc],
    apply (is_colimit_of_preserves (homological_complex.eval A c₁ i') _).hom_ext,
    rintro ⟨a⟩,
    simp only [functor.map_cocone_ι_app, colimit.cocone_ι, homological_complex.eval_map],
    slice_lhs 1 2 {
      erw (is_colimit_of_preserves (homological_complex.eval A c₁ i') _).fac },
    dsimp,
    simp only [has_colimit.iso_of_nat_iso_ι_hom, discrete.nat_iso_hom_app, iso.symm_hom,
      category.assoc, ι_preserves_colimits_iso_inv, homological_complex.eval_map,
      homological_complex.hom.comm, homological_complex.hom.comm_assoc],
    dsimp,
    rw iso.inv_comp_eq,
    slice_rhs 3 4
    { erw (is_colimit_of_preserves (homological_complex.eval A c₁ j') _).fac },
    dsimp,
    simp only [has_colimit.iso_of_nat_iso_ι_hom, discrete.nat_iso_hom_app, iso.symm_hom,
      category.assoc, ι_preserves_colimits_iso_inv, homological_complex.eval_map],
    slice_rhs 1 3
    { erw ← homological_complex.embed.d_of_some_of_some (X a) h₁ h₂ },
    apply colimit.is_colimit,
    apply_instance, }
    -- still annoying
  end)
begin
  intros X a, ext i,
  rcases h : e.r i with _ | i',
  { apply is_zero.eq_of_tgt,
    refine is_zero.of_iso _
      (preserves_colimit_iso (homological_complex.eval _ _ _) _),
    apply is_zero_colimit, intros b,
    apply homological_complex.embed.X_is_zero_of_none,
    exact h },
  dsimp [homological_complex.hom.iso_of_components],
  simp_rw [h], dsimp,
  simp only [← category.assoc, iso.comp_inv_eq],
  simp_rw [← iso.eq_comp_inv, category.assoc],
  slice_rhs 1 2
  { erw (is_colimit_of_preserves (homological_complex.eval A c₂ i) _).fac },
  dsimp,
  simp only [has_colimit.iso_of_nat_iso_ι_inv, discrete.nat_iso_inv_app, iso.symm_inv,
    category.assoc, ι_preserves_colimits_iso_inv, homological_complex.eval_map],
  apply homological_complex.embed.f_of_some,
end

noncomputable
def embed_coproduct_iso
  {α : Type v}
  (X : α → chain_complex A ℕ) :
  (homological_complex.embed complex_shape.embedding.nat_down_int_up).obj (∐ X) ≅
  (∐ λ (a : α), (homological_complex.embed complex_shape.embedding.nat_down_int_up).obj (X a)) :=
preserves_colimit_iso (homological_complex.embed complex_shape.embedding.nat_down_int_up) _ ≪≫
has_colimit.iso_of_nat_iso (whisker_discrete_functor _ _)

noncomputable
def chain_complex_embed_cofan_iso
  {α : Type v}
  (X : α → chain_complex A ℕ) :
  (bounded_homotopy_category.cofan
    (λ a, chain_complex.to_bounded_homotopy_category.obj (X a))) ≅
    ((cocones.precompose (whisker_discrete_functor _ X).inv).obj
    (chain_complex.to_bounded_homotopy_category.map_cocone
      (colimit.cocone (discrete.functor X)))) :=
cocones.ext
(bounded_homotopy_category.mk_iso $
  (homotopy_category.quotient _ _).map_iso $ (embed_coproduct_iso X).symm)
begin
  rintro ⟨a⟩,
  dsimp [bounded_homotopy_category.cofan,
    homotopy_category.colimit_cofan, whisker_discrete_functor],
  erw [category.id_comp, ← functor.map_comp],
  congr' 1,
  dsimp [embed_coproduct_iso],
  simp only [category.assoc],
  erw colimit.ι_desc_assoc,
  rw iso.comp_inv_eq,
  erw (is_colimit_of_preserves
    (homological_complex.embed complex_shape.embedding.nat_down_int_up) _).fac,
  dsimp [whisker_discrete_functor],
  rw category.id_comp,
end

noncomputable
instance chain_complex_to_bounded_homotopy_category_preserves_coproducts
  {α : Type v} :
  preserves_colimits_of_shape (discrete α)
  (chain_complex.to_bounded_homotopy_category : chain_complex A _ ⥤ _) :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor (K.obj ∘ discrete.mk) := discrete.nat_iso (λ ⟨a⟩, iso.refl _),
  apply preserves_colimit_of_iso_diagram _ E.symm,
  apply preserves_colimit_of_preserves_colimit_cocone (colimit.is_colimit _),
  let Q : α → bounded_homotopy_category A := λ a,
    chain_complex.to_bounded_homotopy_category.obj (K.obj ⟨a⟩),
  let P := _, change is_colimit P,
  let T : discrete.functor (K.obj ∘ discrete.mk) ⋙ chain_complex.to_bounded_homotopy_category ≅
    discrete.functor Q := discrete.nat_iso (λ _, iso.refl _),
  let P' := (cocones.precompose T.inv).obj P,
  suffices : is_colimit P',
  { exact is_colimit.precompose_inv_equiv _ _ this },
  apply is_colimit.of_iso_colimit (bounded_homotopy_category.is_colimit_cofan Q),
  swap, apply_instance,
  apply chain_complex_embed_cofan_iso,
end


import Logic.Predicate.FirstOrder.Semantics

universe u v

section

variable {L : Language.{u}} {μ : Type v}
 {I : Type u} (A : I → Type u) [(ι : I) → Inhabited (A ι)] [s : (ι : I) → FirstOrder.Structure L (A ι)] (𝓤 : Ultrafilter I)

namespace FirstOrder

namespace Structure

structure Uprod (𝓤 : Ultrafilter I) where
  val : (i : I) → A i

instance UprodStruc : Structure.{u,u} L (Uprod A 𝓤) where
  func := fun f v => ⟨fun ι => (s ι).func f (fun i => (v i).val ι)⟩
  rel  := fun r v => {ι | (s ι).rel r (fun i => (v i).val ι)} ∈ 𝓤

instance [Inhabited I] [(ι : I) → Inhabited (A ι)] : Inhabited (Uprod A 𝓤) := ⟨⟨default⟩⟩

@[simp] lemma func_Uprod {k} (f : L.func k) (v : Fin k → Uprod A 𝓤) :
    func f v = ⟨fun ι => (s ι).func f (fun i => (v i).val ι)⟩ := rfl

@[simp] lemma rel_Uprod {k} (r : L.rel k) (v : Fin k → Uprod A 𝓤) :
    rel r v ↔ {ι | (s ι).rel r (fun i => (v i).val ι)} ∈ 𝓤 := of_eq rfl

end Structure

end FirstOrder

namespace SubTerm

open FirstOrder Structure

variable (e : Fin n → Uprod A 𝓤) (ε : μ → Uprod A 𝓤)

lemma val_Uprod (t : SubTerm L μ n) :
    t.val! (Uprod A 𝓤) e ε = ⟨fun ι => t.val (s ι) (fun i => (e i).val ι) (fun i => (ε i).val ι)⟩ :=
  by induction t <;> simp[*, val_func]

end SubTerm

namespace FirstOrder

open Structure

variable {A} {𝓤}

namespace SubFormula
variable {e : Fin n → Uprod A 𝓤} {ε : μ → Uprod A 𝓤}

lemma val_vecCons_val_eq {z : Uprod A 𝓤} {ι : I} :
    (z.val ι :> fun i => (e i).val ι) = (fun i => ((z :> e) i).val ι) :=
  by simp[Matrix.comp_vecCons (Uprod.val · ι), Function.comp]

lemma eval_Uprod {p : SubFormula L μ n} :
    Eval! (Uprod A 𝓤) e ε p ↔ {ι | Eval (s ι) (fun i => (e i).val ι) (fun i => (ε i).val ι) p} ∈ 𝓤 := by
  induction p using rec' <;>
  simp[*, Prop.top_eq_true, Prop.bot_eq_false, eval_rel, eval_nrel, SubTerm.val_Uprod]
  case hverum => exact Filter.univ_mem
  case hnrel k r v =>
    exact Ultrafilter.compl_mem_iff_not_mem.symm
  case hand =>
    exact Filter.inter_mem_iff.symm
  case hor p q ihp ihq =>
    exact Ultrafilter.union_mem_iff.symm
  case hall p _ =>
    constructor
    · intro h
      let z : Uprod A 𝓤 := ⟨fun ι =>
        Classical.epsilon (fun z => ¬Eval (s ι) (z :> fun i => (e i).val ι) (fun i => (ε i).val ι) p)⟩
      exact Filter.mem_of_superset (h z) (by
        intro ι hι a
        have : Eval (s ι) (z.val ι :> fun i => (e i).val ι) (fun i => (ε i).val ι) p :=
          by rw [val_vecCons_val_eq]; exact hι
        by_contra hc
        have : ¬Eval! (A ι) (z.val ι :> fun i => (e i).val ι) (fun i => (ε i).val ι) p :=
          Classical.epsilon_spec (p := fun z => ¬(Eval (s ι) (z :> fun i => (e i).val ι) _ p)) ⟨a, hc⟩
        contradiction)
    · intro h x
      exact Filter.mem_of_superset h (by intro ι h; simpa [val_vecCons_val_eq] using h (x.val ι))
  case hex p _ =>
    constructor
    · rintro ⟨x, hx⟩
      exact Filter.mem_of_superset hx (by intro ι h; use x.val ι; simpa[val_vecCons_val_eq] using h)
    · intro h
      let z : Uprod A 𝓤 := ⟨fun ι =>
        Classical.epsilon (fun z => Eval (s ι) (z :> fun i => (e i).val ι) (fun i => (ε i).val ι) p)⟩
      use z
      exact Filter.mem_of_superset h (by
        intro ι; rintro ⟨x, hx⟩
        have : Eval (s ι) (z.val ι :> fun i => (e i).val ι) (fun i => (ε i).val ι) p :=
          Classical.epsilon_spec (p := fun z => Eval (s ι) (z :> fun i => (e i).val ι) _ p) ⟨x, hx⟩
        rw[val_vecCons_val_eq] at this; exact this)

lemma val_Uprod {p : Formula L μ} :
    Val! (Uprod A 𝓤) ε p ↔ {ι | Val (s ι) (fun i => (ε i).val ι) p} ∈ 𝓤 :=
  by simp[Val, eval_Uprod, Matrix.empty_eq]

end SubFormula

lemma realize_Uprod {σ : Sentence L} :
    (Uprod A 𝓤) ⊧₁ σ ↔ {ι | Semantics.realize (self := semantics) (s ι) σ} ∈ 𝓤 :=
  by simp[realize_def, SubFormula.val_Uprod, Empty.eq_elim]

variable (A)

def SubFormula.domain (σ : Sentence L) := {ι | (A ι) ⊧₁ σ}

end FirstOrder

end

section

namespace FirstOrder

variable {L : Language.{u}} {T : CTheory L}

abbrev FinSubTheory (T : CTheory L) := {t : Finset (Sentence L) // ↑t ⊆ T}

variable (A : FinSubTheory T → Type u) [s : (ι : FinSubTheory T) → Structure L (A ι)]

instance : Inhabited (FinSubTheory T) := ⟨∅, by simp⟩

attribute [instance] Classical.propDecidable in
lemma ultrafilter_exists (H : ∀ (ι : FinSubTheory T), (A ι) ⊧₁* (ι.val : CTheory L)) :
    ∃ 𝓤 : Ultrafilter (FinSubTheory T), Set.image (SubFormula.domain A) T ⊆ 𝓤.sets :=
  Ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ (by
    simp[Finset.subset_image_iff, SubFormula.domain]
    intro t ht
    use t; use ht
    intro σ hσ
    exact H ⟨t, ht⟩ hσ)

theorem compactness :
    Semantics.Satisfiableₛ T ↔ ∀ ι : FinSubTheory T, Semantics.Satisfiableₛ (ι.val : CTheory L) := by
  constructor
  · rintro h ⟨t, ht⟩; exact Semantics.satisfiableₛ_of_subset h ht
  · intro h
    have : ∀ ι : FinSubTheory T, ∃ (M : Type u) (_ : Inhabited M) (_ : Structure L M), M ⊧₁* (ι.val : CTheory L) :=
      by intro ι; exact satisfiableₛ_iff.mp (h ι)
    choose A si s hA using this
    have : ∃ 𝓤 : Ultrafilter (FinSubTheory T), Set.image (SubFormula.domain A) T ⊆ 𝓤.sets := ultrafilter_exists A hA
    rcases this with ⟨𝓤, h𝓤⟩
    have : Structure.Uprod A 𝓤 ⊧₁* T := by intro σ hσ; exact realize_Uprod.mpr (h𝓤 $ Set.mem_image_of_mem (SubFormula.domain A) hσ)
    exact satisfiableₛ_intro (Structure.Uprod A 𝓤) this

end FirstOrder

end


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (((a1).write i2 ((a1).read i1)).read i1) ≠ ((a1).read i1) → False := by
  arr


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (v2) ≠ ((((a1).write i1 (v2)).write i2 (v2)).read i1) → False := by
  arr