/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Match.Match
import Lean.Meta.Tactic.Apply
import Lean.Meta.Tactic.Delta
import Lean.Meta.Tactic.SplitIf
import Lean.Meta.Tactic.Injection
import Lean.Meta.Tactic.Contradiction

namespace Lean.Meta

/--
  Helper method for `proveCondEqThm`. Given a goal of the form `C.rec ... xMajor = rhs`,
  apply `cases xMajor`. -/
partial def casesOnStuckLHS (mvarId : MVarId) : MetaM (Array MVarId) := do
  let target ← getMVarType mvarId
  if let some (_, lhs, rhs) ← matchEq? target then
    if let some fvarId ← findFVar? lhs then
      return (← cases mvarId fvarId).map fun s => s.mvarId
  throwError "'casesOnStuckLHS' failed"
where
  findFVar? (e : Expr) : MetaM (Option FVarId) := do
    match e.getAppFn with
    | Expr.proj _ _ e _ => findFVar? e
    | f =>
      if !f.isConst then
        return none
      else
        let declName := f.constName!
        let args := e.getAppArgs
        match (← getProjectionFnInfo? declName) with
        | some projInfo =>
          if projInfo.numParams < args.size then
            findFVar? args[projInfo.numParams]
          else
            return none
        | none =>
          matchConstRec f (fun _ => return none) fun recVal _ => do
            if recVal.getMajorIdx >= args.size then
              return none
            let major := args[recVal.getMajorIdx]
            if major.isFVar then
              return some major.fvarId!
            else
              return none

def casesOnStuckLHS? (mvarId : MVarId) : MetaM (Option (Array MVarId)) := do
  try casesOnStuckLHS mvarId catch _ => return none

namespace Match

structure MatchEqns where
  eqnNames             : Array Name
  splitterName         : Name
  splitterAltNumParams : Array Nat
  deriving Inhabited, Repr

structure MatchEqnsExtState where
  map : Std.PHashMap Name MatchEqns := {}
  deriving Inhabited

/- We generate the equations and splitter on demand, and do not save them on .olean files. -/
builtin_initialize matchEqnsExt : EnvExtension MatchEqnsExtState ←
  registerEnvExtension (pure {})

private def registerMatchEqns (matchDeclName : Name) (matchEqns : MatchEqns) : CoreM Unit :=
  modifyEnv fun env => matchEqnsExt.modifyState env fun s => { s with map := s.map.insert matchDeclName matchEqns }

def unfoldNamedPattern (e : Expr) : MetaM Expr := do
  let visit (e : Expr) : MetaM TransformStep := do
    if e.isAppOfArity ``namedPattern 4 then
      if let some eNew ← unfoldDefinition? e then
        return TransformStep.visit eNew
    return TransformStep.visit e
  Meta.transform e (pre := visit)

/--
  Similar to `forallTelescopeReducing`, but eliminates arguments for named parameters and the associated
  equation proofs. The continuation `k` takes four arguments `ys args mask type`.
  - `ys` are variables for the hypotheses that have not been eliminated.
  - `args` are the arguments for the alternative `alt` that has type `altType`. `ys.size <= args.size`
  - `mask[i]` is true if the hypotheses has not been eliminated. `mask.size == args.size`.
  - `type` is the resulting type for `altType`.

  We use the `mask` to build the splitter proof. See `mkSplitterProof`.
-/
partial def forallAltTelescope (altType : Expr) (k : Array Expr → Array Expr → Array Bool → Expr → MetaM α) : MetaM α := do
  go #[] #[] #[] altType
where
  go (ys : Array Expr) (args : Array Expr) (mask : Array Bool) (type : Expr) : MetaM α := do
    let type ← whnfForall type
    match type with
    | Expr.forallE n d b .. =>
      let d ← unfoldNamedPattern d
      withLocalDeclD n d fun y => do
        let typeNew := b.instantiate1 y
        if let some (_, lhs, rhs) ← matchEq? d then
          if lhs.isFVar && ys.contains lhs && args.contains lhs && isNamedPatternProof typeNew y then
             let some i  := ys.getIdx? lhs | unreachable!
             let ys      := ys.eraseIdx i
             let mask    := mask.set! i false
             let args    := args.map fun arg => if arg == lhs then rhs else arg
             let args    := args.push (← mkEqRefl rhs)
             let typeNew := typeNew.replaceFVar lhs rhs
             return (← go ys args (mask.push false) typeNew)
        go (ys.push y) (args.push y) (mask.push true) typeNew
    | _ =>
      let type ← unfoldNamedPattern type
      /- Recall that alternatives that do not have variables have a `Unit` parameter to ensure
         they are not eagerly evaluated. -/
      if ys.size == 1 then
        if (← inferType ys[0]).isConstOf ``Unit && !(← dependsOn type ys[0].fvarId!) then
          return (← k #[] #[mkConst ``Unit.unit] #[false] type)
      k ys args mask type

  isNamedPatternProof (type : Expr) (h : Expr) : Bool :=
    Option.isSome <| type.find? fun e =>
      e.isAppOfArity ``namedPattern 4 && e.appArg! == h

namespace SimpH

/--
  State for the equational theorem hypothesis simplifier.

  Recall that each equation contains additional hypotheses to ensure the associated case does not taken by previous cases.
  We have one hypothesis for each previous case.

  Each hypothesis is of the form `forall xs, eqs → False`

  We use tactics to minimize code duplication.
-/
structure State where
  mvarId : MVarId            -- Goal representing the hypothesis
  xs  : List FVarId          -- Pattern variables for a previous case
  eqs : List FVarId          -- Equations to be processed
  eqsNew : List FVarId := [] -- Simplied (already processed) equations

abbrev M := StateRefT State MetaM

/--
  Apply the given substitution to `fvarIds`.
  This is an auxiliary method for `substRHS`.
-/
private def applySubst (s : FVarSubst) (fvarIds : List FVarId) : List FVarId :=
  fvarIds.filterMap fun fvarId => match s.apply (mkFVar fvarId) with
    | Expr.fvar fvarId .. => some fvarId
    | _ => none

/--
  Given an equation of the form `lhs = rhs` where `rhs` is variable in `xs`,
  the replace it everywhere with `lhs`.
-/
private def substRHS (eq : FVarId) (rhs : FVarId) : M Unit := do
  assert! (← get).xs.contains rhs
  let (subst, mvarId) ← substCore (← get).mvarId eq (symm := true)
  modify fun s => { s with
    mvarId,
    xs  := applySubst subst (s.xs.erase rhs)
    eqs := applySubst subst s.eqs
    eqsNew := applySubst subst s.eqsNew
  }

private def isDone : M Bool :=
  return (← get).eqs.isEmpty

/--
  Auxiliary tactic that tries to replace as many variables as possible and then apply `contradiction`.
  We use it to discard redundant hypotheses.
-/
private def trySubstVarsAndContradiction (mvarId : MVarId) : MetaM Bool :=
  commitWhen do
    let mvarId ← substVars mvarId
    contradictionCore mvarId {}

private def processNextEq : M Bool := do
  let s ← get
  withMVarContext s.mvarId do
    -- If the goal is contradictory, the hypothesis is redundant.
    if (← contradictionCore s.mvarId {}) then
      return false
    if let eq :: eqs := s.eqs then
      modify fun s => { s with eqs }
      let eqType ← inferType (mkFVar eq)
      -- See `substRHS`. Recall that if `rhs` is a variable then if must be in `s.xs`
      if let some (_, lhs, rhs) ← matchEq? eqType then
        if rhs.isFVar then
          substRHS eq rhs.fvarId!
          return true
      if let some (α, lhs, β, rhs) ← matchHEq? eqType then
        -- Try to convert `HEq` into `Eq`
        if (← isDefEq α β) then
          let (eqNew, mvarId) ← heqToEq s.mvarId eq (tryToClear := true)
          modify fun s => { s with mvarId, eqs := eqNew :: s.eqs }
          return true
        -- If it is not possible, we try to show the hypothesis is redundant by substituting even variables that are not at `s.xs`, and then use contradiction.
        else if (← trySubstVarsAndContradiction s.mvarId) then
          return false
      try
        -- Try to simplify equation using `injection` tactic.
        match (← injection s.mvarId eq) with
        | InjectionResult.solved => return false
        | InjectionResult.subgoal mvarId eqNews .. =>
          modify fun s => { s with mvarId, eqs := eqNews.toList ++ s.eqs }
      catch _ =>
        modify fun s => { s with eqsNew := eq :: s.eqsNew }
    return true

partial def go : M Bool := do
  if (← isDone) then
    return true
  else if (← processNextEq) then
    go
  else
    return false

end SimpH

/--
  Auxiliary method for simplifying equational theorem hypotheses.

  Recall that each equation contains additional hypotheses to ensure the associated case does not taken by previous cases.
  We have one hypothesis for each previous case.
-/
private partial def simpH? (h : Expr) (numEqs : Nat) : MetaM (Option Expr) := withDefault do
  let numVars ← forallTelescope h fun ys _ => pure (ys.size - numEqs)
  let mvarId := (← mkFreshExprSyntheticOpaqueMVar h).mvarId!
  let (xs, mvarId) ← introN mvarId numVars
  let (eqs, mvarId) ← introN mvarId numEqs
  let (r, s) ← SimpH.go |>.run { mvarId, xs := xs.toList, eqs := eqs.toList }
  if r then
    withMVarContext s.mvarId do
      let vars := (s.xs ++ s.eqsNew.reverse).toArray.map mkFVar
      let r ← mkForallFVars vars (mkConst ``False)
      trace[Meta.Match.matchEqs] "simplified hypothesis{indentExpr r}"
      check r
      return some r
  else
    return none

private def substSomeVar (mvarId : MVarId) : MetaM (Array MVarId) := withMVarContext mvarId do
  for localDecl in (← getLCtx) do
    if let some (_, lhs, rhs) ← matchEq? localDecl.type then
      if lhs.isFVar then
        if !(← dependsOn rhs lhs.fvarId!) then
          match (← subst? mvarId lhs.fvarId!) with
          | some mvarId => return #[mvarId]
          | none => pure ()
  throwError "substSomeVar failed"

/--
  Helper method for proving a conditional equational theorem associated with an alternative of
  the `match`-eliminator `matchDeclName`. `type` contains the type of the theorem. -/
partial def proveCondEqThm (matchDeclName : Name) (type : Expr) : MetaM Expr := do
  let type ← instantiateMVars type
  withLCtx {} {} <| forallTelescope type fun ys target => do
    let mvar0  ← mkFreshExprSyntheticOpaqueMVar target
    let mvarId ← deltaTarget mvar0.mvarId! (. == matchDeclName)
    trace[Meta.Match.matchEqs] "{MessageData.ofGoal mvarId}"
    withDefault <| go mvarId 0
    mkLambdaFVars ys (← instantiateMVars mvar0)
where
  go (mvarId : MVarId) (depth : Nat) : MetaM Unit := withIncRecDepth do
    let mvarId' ← modifyTargetEqLHS mvarId whnfCore
    let mvarId := mvarId'
    let subgoals ←
      (do applyRefl mvarId; return #[])
      <|>
      (do contradiction mvarId { genDiseq := true }; return #[])
      <|>
      (casesOnStuckLHS mvarId)
      <|>
      (do let mvarId' ← simpIfTarget mvarId (useDecide := true)
          if mvarId' == mvarId then throwError "simpIf failed"
          return #[mvarId'])
      <|>
      (do if let some (s₁, s₂) ← splitIfTarget? mvarId then
            let mvarId₁ ← trySubst s₁.mvarId s₁.fvarId
            return #[mvarId₁, s₂.mvarId]
          else
            throwError "spliIf failed")
      <|>
      (substSomeVar mvarId)
      <|>
      (throwError "failed to generate equality theorems for `match` expression\n{MessageData.ofGoal mvarId}")
    subgoals.forM (go . (depth+1))

/-- Construct new local declarations `xs` with types `altTypes`, and then execute `f xs`  -/
private partial def withSplitterAlts (altTypes : Array Expr) (f : Array Expr → MetaM α) : MetaM α := do
  let rec go (i : Nat) (xs : Array Expr) : MetaM α := do
    if h : i < altTypes.size then
      let hName := (`h).appendIndexAfter (i+1)
      withLocalDeclD hName (altTypes.get ⟨i, h⟩) fun x =>
        go (i+1) (xs.push x)
    else
      f xs
  go 0 #[]

inductive InjectionAnyResult where
  | solved
  | failed
  | subgoal (mvarId : MVarId)

private def injenctionAny (mvarId : MVarId) : MetaM InjectionAnyResult :=
  withMVarContext mvarId do
    for localDecl in (← getLCtx) do
      if let some (_, lhs, rhs) ← matchEq? localDecl.type then
        unless (← isDefEq lhs rhs) do
          let lhs ← whnf lhs
          let rhs ← whnf rhs
          unless lhs.isNatLit && rhs.isNatLit do
            try
              match (← injection mvarId localDecl.fvarId) with
              | InjectionResult.solved  => return InjectionAnyResult.solved
              | InjectionResult.subgoal mvarId .. => return InjectionAnyResult.subgoal mvarId
            catch _ =>
              pure ()
    return InjectionAnyResult.failed

/--
  Construct a proof for the splitter generated by `mkEquationsfor`.
  The proof uses the definition of the `match`-declaration as a template (argument `template`).
  - `alts` are free variables corresponding to alternatives of the `match` auxiliary declaration being processed.
  - `altNews` are the new free variables which contains aditional hypotheses that ensure they are only used
     when the previous overlapping alternatives are not applicable. -/
private partial def mkSplitterProof (matchDeclName : Name) (template : Expr) (alts altsNew : Array Expr)
    (altArgMasks : Array (Array Bool)) : MetaM Expr := do
  trace[Meta.Match.matchEqs] "proof template: {template}"
  let map := mkMap
  let (proof, mvarIds) ← convertTemplate map |>.run #[]
  trace[Meta.Match.matchEqs] "splitter proof: {proof}"
  for mvarId in mvarIds do
    proveSubgoal mvarId
  instantiateMVars proof
where
  mkMap : FVarIdMap (Expr × Array Bool) := Id.run <| do
    let mut m := {}
    for alt in alts, altNew in altsNew, argMask in altArgMasks do
      m := m.insert alt.fvarId! (altNew, argMask)
    return m

  convertTemplate (m : FVarIdMap (Expr × Array Bool)) : StateRefT (Array MVarId) MetaM Expr :=
    transform template fun e => do
      match e.getAppFn with
      | Expr.fvar fvarId .. =>
        match m.find? fvarId with
        | some (altNew, argMask) =>
          trace[Meta.Match.matchEqs] ">> {e}, {altNew}"
          let mut newArgs := #[]
          for arg in e.getAppArgs, includeArg in argMask do
            if includeArg then
              newArgs := newArgs.push arg
          let eNew := mkAppN altNew newArgs
          let (mvars, _, _) ← forallMetaTelescopeReducing (← inferType eNew) (kind := MetavarKind.syntheticOpaque)
          modify fun s => s ++ (mvars.map (·.mvarId!))
          let eNew := mkAppN eNew mvars
          return TransformStep.done eNew
        | none => return TransformStep.visit e
      | _ => return TransformStep.visit e

  proveSubgoalLoop (mvarId : MVarId) : MetaM Unit := do
    if (← contradictionCore mvarId {}) then
      return ()
    match (← injenctionAny mvarId) with
    | InjectionAnyResult.solved => return ()
    | InjectionAnyResult.failed => throwError "failed to generate splitter for match auxiliary declaration '{matchDeclName}', unsolved subgoal:\n{MessageData.ofGoal mvarId}"
    | InjectionAnyResult.subgoal mvarId => proveSubgoalLoop mvarId

  proveSubgoal (mvarId : MVarId) : MetaM Unit := do
    trace[Meta.Match.matchEqs] "subgoal {mkMVar mvarId}, {repr (← getMVarDecl mvarId).kind}, {← isExprMVarAssigned mvarId}\n{MessageData.ofGoal mvarId}"
    let (_, mvarId) ← intros mvarId
    let mvarId ← tryClearMany mvarId (alts.map (·.fvarId!))
    proveSubgoalLoop mvarId

/--
  Create conditional equations and splitter for the given match auxiliary declaration. -/
private partial def mkEquationsFor (matchDeclName : Name) :  MetaM MatchEqns :=
  withConfig (fun c => { c with etaStruct := false }) do
  let baseName := mkPrivateName (← getEnv) matchDeclName
  let constInfo ← getConstInfo matchDeclName
  let us := constInfo.levelParams.map mkLevelParam
  let some matchInfo ← getMatcherInfo? matchDeclName | throwError "'{matchDeclName}' is not a matcher function"
  forallTelescopeReducing constInfo.type fun xs matchResultType => do
    let mut eqnNames := #[]
    let params := xs[:matchInfo.numParams]
    let motive := xs[matchInfo.getMotivePos]
    let alts   := xs[xs.size - matchInfo.numAlts:]
    let firstDiscrIdx := matchInfo.numParams + 1
    let discrs := xs[firstDiscrIdx : firstDiscrIdx + matchInfo.numDiscrs]
    let mut notAlts := #[]
    let mut idx := 1
    let mut splitterAltTypes := #[]
    let mut splitterAltNumParams := #[]
    let mut altArgMasks := #[] -- masks produced by `forallAltTelescope`
    for alt in alts do
      let thmName := baseName ++ ((`eq).appendIndexAfter idx)
      eqnNames := eqnNames.push thmName
      let (notAlt, splitterAltType, splitterAltNumParam, argMask) ← forallAltTelescope (← inferType alt) fun ys rhsArgs argMask altResultType => do
        let patterns := altResultType.getAppArgs
        let mut hs := #[]
        for notAlt in notAlts do
          let h ← instantiateForall notAlt patterns
          if let some h ← simpH? h patterns.size then
            hs := hs.push h
        trace[Meta.Match.matchEqs] "hs: {hs}"
        let splitterAltType ← mkForallFVars ys (← hs.foldrM (init := altResultType) mkArrow)
        let splitterAltNumParam := hs.size + ys.size
        -- Create a proposition for representing terms that do not match `patterns`
        let mut notAlt := mkConst ``False
        for discr in discrs.toArray.reverse, pattern in patterns.reverse do
          if (← isDefEq (← inferType discr) (← inferType pattern)) then
            notAlt ← mkArrow (← mkEq discr pattern) notAlt
          else
            notAlt ← mkArrow (← mkHEq discr pattern) notAlt
        notAlt ← mkForallFVars (discrs ++ ys) notAlt
        let lhs := mkAppN (mkConst constInfo.name us) (params ++ #[motive] ++ patterns ++ alts)
        let rhs := mkAppN alt rhsArgs
        let thmType ← mkEq lhs rhs
        let thmType ← hs.foldrM (init := thmType) mkArrow
        let thmType ← mkForallFVars (params ++ #[motive] ++ alts ++ ys) thmType
        let thmType ← unfoldNamedPattern thmType
        let thmVal ← proveCondEqThm matchDeclName thmType
        addDecl <| Declaration.thmDecl {
          name        := thmName
          levelParams := constInfo.levelParams
          type        := thmType
          value       := thmVal
        }
        return (notAlt, splitterAltType, splitterAltNumParam, argMask)
      notAlts := notAlts.push notAlt
      splitterAltTypes := splitterAltTypes.push splitterAltType
      splitterAltNumParams := splitterAltNumParams.push splitterAltNumParam
      altArgMasks := altArgMasks.push argMask
      trace[Meta.Match.matchEqs] "splitterAltType: {splitterAltType}"
      idx := idx + 1
    -- Define splitter with conditional/refined alternatives
    withSplitterAlts splitterAltTypes fun altsNew => do
      let splitterParams := params.toArray ++ #[motive] ++ discrs.toArray ++ altsNew
      let splitterType ← mkForallFVars splitterParams matchResultType
      trace[Meta.Match.matchEqs] "splitterType: {splitterType}"
      let template := mkAppN (mkConst constInfo.name us) (params ++ #[motive] ++ discrs ++ alts)
      let template ← deltaExpand template (. == constInfo.name)
      let splitterVal ← mkLambdaFVars splitterParams (← mkSplitterProof matchDeclName template alts altsNew altArgMasks)
      let splitterName := baseName ++ `splitter
      addDecl <| Declaration.thmDecl {
        name        := splitterName
        levelParams := constInfo.levelParams
        type        := splitterType
        value       := splitterVal
      }
      let result := { eqnNames, splitterName, splitterAltNumParams }
      registerMatchEqns matchDeclName result
      return result

def getEquationsFor (matchDeclName : Name) : MetaM MatchEqns := do
  match matchEqnsExt.getState (← getEnv) |>.map.find? matchDeclName with
  | some matchEqns => return matchEqns
  | none => mkEquationsFor matchDeclName

builtin_initialize registerTraceClass `Meta.Match.matchEqs

end Lean.Meta.Match


/-
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.algebraic_topology.homotopical_algebra.fibrant

noncomputable theory

open category_theory category_theory.limits
open category_theory.category opposite

namespace algebraic_topology

namespace model_category

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

variables (A B : C)

structure precylinder  :=
(I : C) (d₀ d₁: A ⟶ I) (σ : I ⟶ A) [weq_σ : weak_eq σ]
(σd₀' : d₀ ≫ σ = 𝟙 A . obviously) (σd₁' : d₁ ≫ σ = 𝟙 A . obviously)

namespace precylinder

variables {A} (P : precylinder A)

restate_axiom σd₀'
restate_axiom σd₁'
attribute [simp, reassoc] σd₀ σd₁

instance weq_σ' : weak_eq P.σ := P.weq_σ
instance weq_d₀ : weak_eq P.d₀ := weak_eq.of_comp_right P.d₀ P.σ infer_instance
  (by { rw σd₀, apply_instance, })
instance weq_d₁ : weak_eq P.d₁ := weak_eq.of_comp_right P.d₁ P.σ infer_instance
  (by { rw σd₁, apply_instance, })

@[simps]
def change_I {I' : C} {f : P.I ⟶ I'} {g : I' ⟶ A} (fac : f ≫ g = P.σ) [weak_eq f] :
  precylinder A :=
begin
  haveI := weak_eq.of_comp_left f g infer_instance (by {rw fac, apply_instance, }),
  exact
  { I := I',
    d₀ := P.d₀ ≫ f,
    d₁ := P.d₁ ≫ f,
    σ := g,
    σd₀' := by { simp only [assoc, fac, σd₀], },
    σd₁' := by { simp only [assoc, fac, σd₁], }, },
end

@[simp]
def ι := coprod.desc P.d₀ P.d₁

@[simps]
def symm : precylinder A :=
{ I := P.I,
  d₀ := P.d₁,
  d₁ := P.d₀,
  σ := P.σ, }

end precylinder

structure cylinder extends precylinder A :=
[cof_ι : cofibration to_precylinder.ι]

namespace cylinder

variable {A}

def mk' (P : precylinder A) (h : cofibration P.ι) : cylinder A :=
by { haveI := h, exact mk P, }

abbreviation pre (Q : cylinder A) := Q.to_precylinder

instance cof_ι' (Q : cylinder A) : cofibration Q.pre.ι := Q.cof_ι

variable (A)

def some : cylinder A :=
begin
  let φ := coprod.desc (𝟙 A) (𝟙 A),
  let P : precylinder A :=
  { I := CM5b.obj φ,
    σ := CM5b.p φ,
    d₀ := coprod.inl ≫ CM5b.i φ,
    d₁ := coprod.inr ≫ CM5b.i φ, },
  apply mk' P,
  rw [show P.ι = CM5b.i φ, by tidy],
  apply_instance,
end

instance : fibration (some A).σ := by { dsimp [some, mk'], apply_instance, }
instance [is_fibrant A] : is_fibrant (some A).I := by { dsimp [some, mk'], apply_instance, }

instance : inhabited (cylinder A) := ⟨some A⟩
instance : inhabited (precylinder A) := ⟨(some A).pre⟩

variables {A} (Q : cylinder A)

instance cof_d₀ [is_cofibrant A] : cofibration (Q.d₀) :=
begin
  rw [show Q.d₀ = coprod.inl ≫ Q.pre.ι, by simp only [precylinder.ι, coprod.inl_desc]],
  apply_instance,
end

instance cof_d₁ [is_cofibrant A] : cofibration (Q.d₁) :=
begin
  rw [show Q.d₁ = coprod.inr ≫ Q.pre.ι, by simp only [precylinder.ι, coprod.inr_desc]],
  apply_instance,
end

instance is_cofibrant_I [is_cofibrant A] : is_cofibrant Q.I :=
begin
  change cofibration _,
  rw subsingleton.elim (initial.to Q.I) (initial.to A ≫ Q.d₀),
  apply_instance,
end

@[simps]
def symm : cylinder A := mk' Q.pre.symm
begin
  have eq : Q.pre.symm.ι = (coprod.braiding A A).hom ≫ Q.pre.ι,
  { simp only [precylinder.ι, precylinder.symm_d₀, precylinder.symm_d₁, coprod.braiding_hom,
      coprod.desc_comp, coprod.inr_desc, coprod.inl_desc], },
  rw eq,
  apply_instance,
end

@[simps]
def trans [is_cofibrant A] (Q Q' : cylinder A) : cylinder A :=
begin
  let φ := pushout.desc Q.σ Q'.σ (by rw [Q.pre.σd₁, Q'.pre.σd₀]),
  haveI : weak_eq φ,
  { apply weak_eq.of_comp_left (Q.d₀ ≫ pushout.inl),
    { apply_instance, },
    { simp only [assoc, pushout.inl_desc, precylinder.σd₀],
      apply_instance, }, },
  let P : precylinder A :=
  { I := pushout Q.d₁ Q'.d₀,
    d₀ := Q.d₀ ≫ pushout.inl,
    d₁ := Q'.d₁ ≫ pushout.inr,
    σ := φ, },
  apply mk' P,
  let ψ : Q.pre.I ⨿ A ⟶ P.I := coprod.desc pushout.inl (Q'.d₁ ≫ pushout.inr),
  have eq : P.ι = (coprod.map Q.d₀ (𝟙 A)) ≫ ψ,
  { by simp only [precylinder.ι, coprod.map_desc, id_comp], },
  rw eq,
  have fac : coprod.map Q.d₁ (𝟙 A) ≫ ψ = Q'.pre.ι ≫ pushout.inr,
  { dsimp [ψ],
    ext,
    { simp only [coprod.map_desc, coprod.inl_desc, coprod.desc_comp, pushout.condition], },
    { simp only [coprod.map_desc, id_comp, coprod.inr_desc, coprod.desc_comp], }, },
  have sq : is_pushout Q.pre.d₁ (coprod.inl ≫ Q'.pre.ι)
    (coprod.inl ≫ ψ) pushout.inr := by simpa only [precylinder.ι, coprod.inl_desc]
    using is_pushout.of_has_pushout Q.pre.d₁ Q'.pre.d₀,
  haveI : cofibration ψ := cofibration.direct_image
    (is_pushout.of_bot sq fac (is_pushout.of_coprod_inl_with_id Q.d₁ A).flip),
  apply_instance,
end

end cylinder

structure pre_path_object :=
(I : C) (d₀ d₁: I ⟶ B) (σ : B ⟶ I) [weq_σ : weak_eq σ]
(d₀σ' : σ ≫ d₀ = 𝟙 B . obviously) (d₁σ' : σ ≫ d₁ = 𝟙 B . obviously)

namespace pre_path_object

restate_axiom d₀σ'
restate_axiom d₁σ'
attribute [simp, reassoc] d₀σ d₁σ

variables {B} (P : pre_path_object B)

instance : weak_eq P.σ := P.weq_σ

@[simps]
def op (P : pre_path_object B) : precylinder (op B) :=
begin
  haveI : weak_eq P.σ.op := weak_eq.op infer_instance,
  exact
  { I := op P.I,
    d₀ := P.d₀.op,
    d₁ := P.d₁.op,
    σ := P.σ.op,
    σd₀' := by simp only [← op_comp, d₀σ, op_id],
    σd₁' := by simp only [← op_comp, d₁σ, op_id], }
end

@[simps]
def unop {B : Cᵒᵖ} (P : pre_path_object B) : precylinder B.unop :=
begin
  haveI : weak_eq P.σ.unop := weak_eq.unop infer_instance,
  exact
  { I := unop P.I,
    d₀ := P.d₀.unop,
    d₁ := P.d₁.unop,
    σ := P.σ.unop,
    σd₀' := by simp only [← unop_comp, d₀σ, unop_id],
    σd₁' := by simp only [← unop_comp, d₁σ, unop_id], }
end

end pre_path_object

namespace precylinder

variable {A}

@[simps]
def op (P : precylinder A) : pre_path_object (op A) :=
begin
  haveI : weak_eq P.σ.op := weak_eq.op infer_instance,
  exact
  { I := op P.I,
    d₀ := P.d₀.op,
    d₁ := P.d₁.op,
    σ := P.σ.op,
    d₀σ' := by simp only [← op_comp, σd₀, op_id],
    d₁σ' := by simp only [← op_comp, σd₁, op_id], }
end

@[simps]
def unop {A : Cᵒᵖ} (P : precylinder A) : pre_path_object (unop A) :=
begin
  haveI : weak_eq P.σ.unop := weak_eq.unop infer_instance,
  exact
  { I := unop P.I,
    d₀ := P.d₀.unop,
    d₁ := P.d₁.unop,
    σ := P.σ.unop,
    d₀σ' := by simp only [← unop_comp, σd₀, unop_id],
    d₁σ' := by simp only [← unop_comp, σd₁, unop_id], }
end

lemma unop_op (P : precylinder A) : P.op.unop = P := by { cases P, refl, }
lemma op_unop {A : Cᵒᵖ} (P : precylinder A) : P.unop.op = P := by { cases P, refl, }

end precylinder

namespace pre_path_object

variables {B} (P : pre_path_object B)

lemma unop_op : P.op.unop = P := by { cases P, refl, }
lemma op_unop {B : Cᵒᵖ} (P : precylinder B) : P.unop.op = P := by { cases P, refl, }

instance weq_d₀ : weak_eq P.d₀ := weak_eq.unop (infer_instance : weak_eq P.op.d₀)
instance weq_d₁ : weak_eq P.d₁ := weak_eq.unop (infer_instance : weak_eq P.op.d₁)

@[simps]
def change_I {I' : C} {f : I' ⟶ P.I} {g : B ⟶ I'} (fac : g ≫ f = P.σ) [weak_eq f] :
  pre_path_object B :=
begin
  haveI : weak_eq f.op := weak_eq.op infer_instance,
  have eq : f.op ≫ g.op = P.σ.op := by rw [← op_comp, fac],
  exact (P.op.change_I eq).unop,
end

@[simp]
def π := prod.lift P.d₀ P.d₁

lemma fibration_π_iff_cofibration_op_ι (P : pre_path_object B) :
  fibration P.π ↔ cofibration P.op.ι :=
by simpa only [fibration.iff_op]
  using cofibration.respects_iso _ _ (arrow.iso_op_prod_lift P.d₀ P.d₁)

lemma fibration_π_iff_cofibration_unop_ι {B : Cᵒᵖ} (P : pre_path_object B) :
  fibration P.π ↔ cofibration P.unop.ι :=
by simpa only [fibration.iff_unop]
  using cofibration.respects_iso _ _ (arrow.iso_unop_prod_lift P.d₀ P.d₁)

@[simps]
def symm : pre_path_object B :=
{ I := P.I,
  d₀ := P.d₁,
  d₁ := P.d₀,
  σ := P.σ, }

end pre_path_object

structure path_object extends pre_path_object B :=
[fib_π : fibration to_pre_path_object.π]

namespace path_object

variable {B}

def mk' (P : pre_path_object B) (h : fibration P.π) : path_object B :=
by { haveI := h, exact mk P, }

abbreviation pre (Q : path_object B) := Q.to_pre_path_object

instance (Q : path_object B) : fibration Q.pre.π := Q.fib_π

@[simps]
def change_I {B : C} (P : path_object B) {Z : C} {f : B ⟶ Z} {g : Z ⟶ P.I}
  (fac : f ≫ g = P.σ) [fibration g] [weak_eq g] : path_object B :=
begin
  haveI : fibration (P.pre.change_I fac).π,
  { convert (infer_instance : fibration (g ≫ P.π)),
    simp only [pre_path_object.π, pre_path_object.change_I_d₀,
      pre_path_object.change_I_d₁, prod.comp_lift], },
  exact path_object.mk (P.pre.change_I fac),
end

end path_object

namespace cylinder

@[simps]
def unop {A : Cᵒᵖ} (Q : cylinder A) : path_object A.unop :=
begin
  apply path_object.mk' Q.pre.unop,
  rw [pre_path_object.fibration_π_iff_cofibration_op_ι, precylinder.op_unop],
  apply_instance,
end

variable {A}

@[simps]
def op (Q : cylinder A) : path_object (op A) :=
begin
  apply path_object.mk' Q.pre.op,
  rw [pre_path_object.fibration_π_iff_cofibration_unop_ι, precylinder.unop_op],
  apply_instance,
end

end cylinder

namespace path_object

variable {B}

@[simps]
def op (Q : path_object B) : cylinder (op B) :=
begin
  apply cylinder.mk' Q.pre.op,
  rw ← Q.pre.fibration_π_iff_cofibration_op_ι,
  apply_instance,
end

@[simps]
def unop {B : Cᵒᵖ} (Q : path_object B) : cylinder B.unop :=
begin
  apply cylinder.mk' Q.pre.unop,
  rw ← Q.pre.fibration_π_iff_cofibration_unop_ι,
  apply_instance,
end

variable (B)

def some : path_object B := (cylinder.some (opposite.op B)).unop

instance : cofibration (some B).σ := by { dsimp [some], apply fibration.unop, apply_instance, }
instance [is_cofibrant B] : is_cofibrant (some B).I :=
begin
  change cofibration _,
  rw subsingleton.elim (initial.to ((some B).I)) (initial.to _ ≫ (some B).σ),
  apply_instance,
end

instance : inhabited (path_object B) := ⟨some B⟩
instance : inhabited (pre_path_object B) := ⟨(some B).pre⟩

variable {B}

@[simp]
def symm (P : path_object B) : path_object B := P.op.symm.unop

@[simps]
def trans [hB : is_fibrant B] (P P' : path_object B) : path_object B :=
by { haveI := hB.op, exact (P.op.trans P'.op).unop, }
/- TODO : use change_I to replace the dual of the pushout by a pullback -/

end path_object

end model_category

end algebraic_topology


import LightData
import Yatima.Datatypes.Const
import Yatima.Datatypes.Env

namespace Yatima.ContAddr

open IR

scoped notation "dec" x => Encodable.decode x

def partitionName (name : Name) : List (Either String Nat) :=
  let rec aux (acc : List (Either String Nat)) : Name → List (Either String Nat)
    | .str name s => aux ((.left s) :: acc) name
    | .num name n => aux ((.right n) :: acc) name
    | .anonymous  => acc
  aux [] name

instance : Encodable Name LightData where
  encode n := partitionName n
  decode x := do
    let parts : List (Either String Nat) ← dec x
    parts.foldlM (init := .anonymous) fun acc x => match x with
      | .left  s => pure $ acc.mkStr s
      | .right n => pure $ acc.mkNum n

instance : Encodable Literal LightData where
  encode
    | .strVal s => .cell #[false, s]
    | .natVal n => .cell #[true,  n]
  decode
    | .cell #[false, s] => return .strVal (← dec s)
    | .cell #[true,  n] => return .natVal (← dec n)
    | x => throw s!"expected either but got {x}"

instance : Encodable BinderInfo LightData where
  encode | .default => 0 | .implicit => 1 | .strictImplicit => 2 | .instImplicit => 3
  decode
    | 0 => pure .default
    | 1 => pure .implicit
    | 2 => pure .strictImplicit
    | 3 => pure .instImplicit
    | x => throw s!"Invalid encoding for BinderInfo: {x}"

instance : Encodable QuotKind LightData where
  encode | .type => 0 | .ctor => 1 | .lift => 2 | .ind => 3
  decode
    | 0 => pure .type
    | 1 => pure .ctor
    | 2 => pure .lift
    | 3 => pure .ind
    | x => throw s!"Invalid encoding for QuotKind: {x}"

def univToLightData : Univ → LightData
  | .zero     => 0
  | .succ x   => .cell #[false, univToLightData x]
  | .var  x   => .cell #[true,  x]
  | .max  x y => .cell #[false, univToLightData x, univToLightData y]
  | .imax x y => .cell #[true,  univToLightData x, univToLightData y]

partial def lightDataToUniv : LightData → Except String Univ
  | 0 => pure .zero
  | .cell #[false, x] => return .succ (← lightDataToUniv x)
  | .cell #[true,  x] => return .var (← dec x)
  | .cell #[false, x, y] => return .max  (← lightDataToUniv x) (← lightDataToUniv y)
  | .cell #[true,  x, y] => return .imax (← lightDataToUniv x) (← lightDataToUniv y)
  | x => throw s!"Invalid encoding for Univ: {x}"

instance : Encodable Univ LightData where
  encode := univToLightData
  decode := lightDataToUniv

instance : Encodable Lurk.F LightData where
  encode x := x.val
  decode x := return (.ofNat $ ← dec x)

def exprToLightData : Expr → LightData
  | .sort x => .cell #[false, x]
  | .lit  x => .cell #[true,  x]
  | .var   x y => .cell #[0, x, y]
  | .const x y => .cell #[1, x, y]
  | .app   x y => .cell #[2, exprToLightData x, exprToLightData y]
  | .lam   x y => .cell #[3, exprToLightData x, exprToLightData y]
  | .pi    x y => .cell #[4, exprToLightData x, exprToLightData y]
  | .proj  x y => .cell #[5, x, exprToLightData y]
  | .letE x y z => .cell #[false, exprToLightData x, exprToLightData y, exprToLightData z]

partial def lightDataToExpr : LightData → Except String Expr
  | .cell #[false, x] => return .sort (← lightDataToUniv x)
  | .cell #[true,  x] => return .lit (← dec x)
  | .cell #[0, x, y] => return .var (← dec x) (← dec y)
  | .cell #[1, x, y] => return .const (← dec x) (← dec y)
  | .cell #[2, x, y] => return .app (← lightDataToExpr x) (← lightDataToExpr y)
  | .cell #[3, x, y] => return .lam (← lightDataToExpr x) (← lightDataToExpr y)
  | .cell #[4, x, y] => return .pi  (← lightDataToExpr x) (← lightDataToExpr y)
  | .cell #[5, x, y] => return .proj (← dec x) (← lightDataToExpr y)
  | .cell #[false, x, y, z] =>
    return .letE (← lightDataToExpr x) (← lightDataToExpr y) (← lightDataToExpr z)
  | x => throw s!"Invalid encoding for IR.Expr: {x}"

instance : Encodable Expr LightData where
  encode := exprToLightData
  decode := lightDataToExpr

instance : Encodable Constructor LightData where
  encode | ⟨a, b, c, d, e⟩ => .cell #[a, b, c, d, e]
  decode
    | .cell #[a, b, c, d, e] => return ⟨← dec a, ← dec b, ← dec c, ← dec d, ← dec e⟩
    | x => throw s!"Invalid encoding for IR.Constructor: {x}"

instance : Encodable RecursorRule LightData where
  encode | ⟨a, b⟩ => .cell #[a, b]
  decode
    | .cell #[a, b] => return ⟨← dec a, ← dec b⟩
    | x => throw s!"Invalid encoding for IR.RecursorRule: {x}"

instance : Encodable Definition LightData where
  encode | ⟨a, b, c, d⟩ => .cell #[a, b, c, d]
  decode
    | .cell #[a, b, c, d] => return ⟨← dec a, ← dec b, ← dec c, ← dec d⟩
    | x => throw s!"Invalid encoding for IR.Definition: {x}"

instance : Encodable Recursor LightData where
  encode | ⟨a, b, c, d, e, f, g, h, i⟩ => .cell #[a, b, c, d, e, f, g, h, i]
  decode
    | .cell #[a, b, c, d, e, f, g, h, i] =>
      return ⟨← dec a, ← dec b, ← dec c, ← dec d, ← dec e, ← dec f, ← dec g, ← dec h, ← dec i⟩
    | x => throw s!"Invalid encoding for IR.Recursor: {x}"

instance : Encodable Inductive LightData where
  encode | ⟨a, b, c, d, e, f, g, h, i, j⟩ => .cell #[a, b, c, d, e, f, g, h, i, j]
  decode
    | .cell #[a, b, c, d, e, f, g, h, i, j] =>
      return ⟨← dec a, ← dec b, ← dec c, ← dec d, ← dec e, ← dec f, ← dec g,
        ← dec h, ← dec i, ← dec j⟩
    | x => throw s!"Invalid encoding for IR.Inductive: {x}"

instance : Encodable Const LightData where
  encode
    | .mutIndBlock x => .cell #[false, x]
    | .mutDefBlock x => .cell #[true,  x]
    | .axiom          ⟨a, b⟩ => .cell #[0, a, b]
    | .inductiveProj  ⟨a, b⟩ => .cell #[1, a, b]
    | .definitionProj ⟨a, b⟩ => .cell #[2, a, b]
    | .theorem         ⟨a, b, c⟩ => .cell #[0, a, b, c]
    | .opaque          ⟨a, b, c⟩ => .cell #[1, a, b, c]
    | .quotient        ⟨a, b, c⟩ => .cell #[2, a, b, c]
    | .constructorProj ⟨a, b, c⟩ => .cell #[3, a, b, c]
    | .recursorProj    ⟨a, b, c⟩ => .cell #[4, a, b, c]
    | .definition ⟨a, b, c, d⟩ => .cell #[false, a, b, c, d]
  decode
    | .cell #[false, x] => return .mutIndBlock (← dec x)
    | .cell #[true,  x] => return .mutDefBlock (← dec x)
    | .cell #[0, a, b] => return .axiom          ⟨← dec a, ← dec b⟩
    | .cell #[1, a, b] => return .inductiveProj  ⟨← dec a, ← dec b⟩
    | .cell #[2, a, b] => return .definitionProj ⟨← dec a, ← dec b⟩
    | .cell #[0, a, b, c] => return .theorem         ⟨← dec a, ← dec b, ← dec c⟩
    | .cell #[1, a, b, c] => return .opaque          ⟨← dec a, ← dec b, ← dec c⟩
    | .cell #[2, a, b, c] => return .quotient        ⟨← dec a, ← dec b, ← dec c⟩
    | .cell #[3, a, b, c] => return .constructorProj ⟨← dec a, ← dec b, ← dec c⟩
    | .cell #[4, a, b, c] => return .recursorProj    ⟨← dec a, ← dec b, ← dec c⟩
    | .cell #[false, a, b, c, d] => return .definition ⟨← dec a, ← dec b, ← dec c, ← dec d⟩
    | x => throw s!"Invalid encoding for IR.Const: {x}"

instance [Encodable (Array (α × β)) LightData] [Ord α] :
    Encodable (Std.RBMap α β compare) LightData where
  encode x := (x.foldl (·.push (·, ·)) #[] : Array (α × β))
  decode x := return .ofArray (← dec x) _

instance [Encodable (Array α) LightData] [Ord α] :
    Encodable (Std.RBSet α compare) LightData where
  encode x := (x.foldl (·.push ·) #[] : Array α)
  decode x := return .ofArray (← dec x) _

instance : Encodable IR.Env LightData where
  encode | ⟨x, y⟩ => .cell #[x, y]
  decode
    | .cell #[x, y] => return ⟨← dec x, ← dec y⟩
    | x => throw s!"Invalid encoding for IR.Definition: {x}"

end Yatima.ContAddr