import system.io
import .solvers.z3
import .syntax
import .builder
import .tactic
import .attributes
import .lol
import init.data.option.basic

declare_trace smt2

open tactic
open smt2.builder
open native

meta structure smt2_state : Type :=
(ctxt : lol.context)
(type_map : rb_map expr lol.type)

meta def smt2_state.initial : smt2_state :=
⟨ lol.context.empty, rb_map.mk _ _ ⟩

@[reducible] meta def smt2_m (α : Type) :=
state_t smt2_state tactic α

meta instance tactic_to_smt2_m (α : Type) : has_coe (tactic α) (smt2_m α) :=
⟨ fun tc, state_t.mk (fun s, do res ← tc, return (res, s)) ⟩

namespace smt2

meta def trace_smt2 (msg : string) : smt2_m unit :=
  tactic.when_tracing `smt2 (tactic.trace msg)

meta def fail {α : Type} (msg : string) : smt2_m α :=
tactic.fail $ "smt2_tactic: " ++ msg

meta def mangle_name (n : name) : string :=
"lean_" ++ n^.to_string_with_sep "-"

meta def insert_type (n : string) (ty : expr) (lty : lol.type) : smt2_m unit :=
do st ← get,
   put ⟨
     st.ctxt.declare_type n lty,
     st.type_map.insert ty lty
   ⟩

meta def fn_type : expr → (list expr × expr)
| (expr.pi _ _ ty rest) :=
    let (args, rt) := fn_type rest
    in (ty :: args, rt)
| rt := ([], rt)

-- Currently we only support first order fn types
meta def compile_arrow_type (ty : expr) (cb : expr → smt2_m lol.type) : smt2_m lol.type :=
let (args, rt) := fn_type ty
in lol.type.fn <$> monad.mapm cb args <*> cb rt

meta def compile_type : expr → smt2_m lol.type :=
fun ty,
do st ← get,
   match st.type_map.find ty with
   | some lty := return lty
   | none := do
     lty ← match ty with
     | `(int) := pure $ lol.type.int
     | `(nat) := pure $ lol.type.refinement lol.type.int (fun x, lol.term.lte (lol.term.int 0) (lol.term.var x))
     | `(Prop) := pure $ lol.type.bool
     | _ := if ty.is_arrow
            then compile_arrow_type ty compile_type
            else if ty.is_constant
            then do insert_type (mangle_name ty.const_name) ty (lol.type.fn [] (lol.type.var $ mangle_name ty.const_name)),
                 return $ (lol.type.fn [] (lol.type.var $ mangle_name ty.const_name))
            else fail $ "unsupported type: " ++ to_string ty
     end,
     -- insert_type ty lty,
     return lty
   end

meta def add_decl (n : name) (ty : expr) : smt2_m unit :=
  do st ← get,
     ct ← compile_type ty,
     let d := lol.decl.fn (mangle_name n) ct none,
     put { st with ctxt := st.ctxt.declare d }

-- meta def ensure_constant (e : expr) (n : name) : smt2_m lol.decl :=
--   do ty ← infer_type e,
--    let (arg_tys, ret_ty) := fn_type ty,
--    let mangled_name := mangle_name n,
--    arg_sorts ← monad.mapm compile_type arg_tys,
--    ret_sort ← compile_type ret_ty,
--    -- ensure_constant_core e (return $ (mangled_name, arg_sorts, ret_sort)),
--    return $ lol.decl.fn mangled_name arg_sorts ret_sort

-- meta def formula_type_from_arrow (n : name) (e : expr) : smt2_m formula_type :=
-- do (lol.decl.fn _ arg_sorts ret_sort) ← ensure_constant e n,
--    return $ formula_type.fn n arg_sorts ret_sort

-- /-- The goal of this function is to categorize the set of formulas in the hypotheses,
--     and goal. We want to narrow down from the full term language of Lean to a fragment
--     of formula's we suppose. The below code makes some assumptions:

--    A local constant of the form `(P : Prop)`, must be reflected as declaration
--    in SMT2 that is `(declare-const P Bool)`.

--    An occurence of a proof of `P`, `(p : P)`, must be transformed into
--    `(assert P)`. If P is a formula, not an atom, we must transform P into a corresponding
--    SMT2 formula and `(assert P)`.
-- -/

meta def extract_coe_args (args : list expr) : smt2_m (expr × expr × expr) :=
match args with
| (source :: target :: inst :: e :: []) := return (source, target, e)
| _ := fail "internal tactic error expected `coe` to have exactly 4 arguments"
end

meta def reflect_coercion (source target e : expr) (callback : expr → smt2_m lol.term) : smt2_m lol.term :=
if source = `(nat) ∧ target = `(int)
then callback e
else fail $ "unsupported coercion between " ++ "`" ++ to_string source ++ "` and `" ++ to_string target ++ "`"

meta def reflect_application (fn : expr) (args : list expr) (callback : expr → smt2_m lol.term) : smt2_m lol.term :=
    if fn.is_constant
    then if fn.const_name = `coe
          then do (source, target, e) ← extract_coe_args args,
                   reflect_coercion source target e callback
          else do ty ← infer_type fn,
                  let mangled := (mangle_name fn.const_name),
                  add_decl fn.const_name ty,
                  lol.term.apply mangled <$> monad.mapm callback args
    else if fn.is_local_constant
    then lol.term.apply (mangle_name fn.local_uniq_name) <$> monad.mapm callback args
    else fail $ "unsupported head symbol `" ++ to_string fn ++ "`"

-- meta def is_supported_head_symbol (e : expr) : bool := true

meta def is_supported_numeric_ty (ty : expr) : bool :=
(ty = `(int) ∨ ty = `(nat))

-- /-- This function is the meat of the tactic, it takes a propositional formula in Lean, and transforms
--    it into a corresponding term in SMT2. -/
meta def reflect_arith_formula (reflect_base : expr → smt2_m lol.term) : expr → smt2_m lol.term
| `(%%a + %%b) := lol.term.add <$> reflect_arith_formula a <*> reflect_arith_formula b
| `(%%a - %%b) := lol.term.sub <$> reflect_arith_formula a <*> reflect_arith_formula b
| `(%%a * %%b) := lol.term.mul <$> reflect_arith_formula a <*> reflect_arith_formula b
| `(%%a / %%b) := lol.term.div <$> reflect_arith_formula a <*> reflect_arith_formula b
| `(%%a % %%b) := lol.term.mod <$> reflect_arith_formula a <*> reflect_arith_formula b
| `(- %%a) := lol.term.neg <$> reflect_arith_formula a
-- /- Constants -/
| `(has_zero.zero _) := lol.term.int <$> eval_expr int `(has_zero.zero int)
| `(has_one.one _) := lol.term.int <$> eval_expr int `(has_one.one int)
| `(bit0 %%Bits) :=
  do ty ← infer_type Bits,
     if is_supported_numeric_ty ty
     then lol.term.int <$> eval_expr int `(bit0 %%Bits : int)
     else if (ty = `(nat))
     then lol.term.int <$> int.of_nat <$> eval_expr nat `(bit0 %%Bits : nat)
     else fail $ "unknown numeric literal: " ++ (to_string ```(bit0 %%Bits : int))
| `(bit1 %%Bits) :=
  do ty ← infer_type Bits,
     if is_supported_numeric_ty ty
     then lol.term.int <$> eval_expr int `(bit1 %%Bits : int)
     else if (ty = `(nat))
     then lol.term.int <$> (int.of_nat <$> eval_expr nat `(bit1 %%Bits : nat))
     else fail $ "unknown numeric literal: " ++ (to_string `(bit1 %%Bits : int))
| a :=
    if a.is_local_constant
    then return $ lol.term.var (mangle_name a.local_uniq_name)
    else if a.is_constant
    then return $ lol.term.var (mangle_name a.const_name)
    else if a.is_app
    then reflect_application (a.get_app_fn) (a.get_app_args) reflect_base
    else fail $ "unsupported arithmetic formula: " ++ to_string a

-- /-- Check if the type is an `int` or logically a subtype of an `int` like nat. -/
meta def is_int (e : expr) : tactic bool :=
do ty ← infer_type e,
   return $ (ty = `(int)) || (ty = `(nat))

meta def unsupported_ordering_on {α : Type} (elem : expr) : tactic α :=
do ty ← infer_type elem,
   tactic.fail $ "unable to translate orderings for values of type: " ++ to_string ty

meta def reflect_ordering (reflect_arith : expr → smt2_m lol.term) (R : lol.term → lol.term → lol.term) (P Q : expr) : smt2_m lol.term :=
do is ← is_int P, -- NB: P and Q should have the same type.
   if is
   then R <$> (reflect_arith P) <*> (reflect_arith Q)
   else unsupported_ordering_on P

meta def supported_pi_binder (ty : expr) : bool :=
match ty with
| `(int) := tt
| `(nat) := tt
| `(Prop) := tt
| _ := if ty.is_constant
       then tt
       else ff
end

meta def add_assertion (t : lol.term) : smt2_m unit :=
  do st ← get,
     put { st with ctxt := st.ctxt.assert t }

meta def compile_pi (e : expr) (cb : expr → smt2_m lol.term) : smt2_m lol.term :=
if supported_pi_binder e.binding_domain
then do loc ← tactic.mk_local' e.binding_name e.binding_info e.binding_domain,
        lol.term.forallq
          (mangle_name $ loc.local_uniq_name) <$>
          (compile_type $ e.binding_domain) <*>
          (cb (expr.instantiate_var (e.binding_body) loc))
else fail $ "arbitrary Π types are not supported, unable to translate term: `" ++ to_string e ++ "`"

meta def reflect_prop_formula' : expr → smt2_m lol.term
| `(¬ %%P) := lol.term.not <$> (reflect_prop_formula' P)
| `(%%P = %% Q) := lol.term.equals <$> (reflect_prop_formula' P) <*> (reflect_prop_formula' Q)
| `(%%P ∧ %%Q) := lol.term.and <$> (reflect_prop_formula' P) <*> (reflect_prop_formula' Q)
| `(%%P ∨ %%Q) := lol.term.or <$> (reflect_prop_formula' P) <*> (reflect_prop_formula' Q)
| `(%%P ↔ %%Q) := lol.term.iff <$> (reflect_prop_formula' P) <*> (reflect_prop_formula' Q)
| `(%%P < %%Q) := reflect_ordering (reflect_arith_formula reflect_prop_formula') lol.term.lt P Q
| `(%%P <= %%Q) := reflect_ordering (reflect_arith_formula reflect_prop_formula') lol.term.lte P Q
| `(%%P > %%Q) := reflect_ordering (reflect_arith_formula reflect_prop_formula') lol.term.gt P Q
| `(%%P >= %%Q) := reflect_ordering (reflect_arith_formula reflect_prop_formula') lol.term.gte P Q
| `(true) := return $ lol.term.true
| `(false) := return $ lol.term.false
| e := do ty ← infer_type e,
       if e.is_local_constant
       then pure $ lol.term.var (mangle_name e.local_uniq_name)
       else if e.is_arrow
       then lol.term.implies <$> (reflect_prop_formula' e.binding_domain) <*> (reflect_prop_formula' e.binding_body )
       else if e.is_pi
       then compile_pi e reflect_prop_formula'
       else if is_supported_numeric_ty ty
       then reflect_arith_formula reflect_prop_formula' e
       else if e.is_app
       then reflect_application (e.get_app_fn) (e.get_app_args) reflect_prop_formula'
       else tactic.fail $ "unsupported propositional formula : " ++ to_string e

meta def reflect_prop_formula (e : expr) : smt2_m unit :=
reflect_prop_formula' e >>= add_assertion

-- meta def warn_unable_to_trans_local (e : expr) : smt2_m (builder unit) := do
--   trace_smt2 $ "unable to translate local variable: " ++ to_string e,
--   return $ return ()

meta def is_builtin_type : expr → bool
| `(int) := tt
| `(Prop) := tt
| `(nat) := tt
| _ := ff

meta def unsupported_formula (e : expr) : smt2_m unit :=
fail $ "unsupported formula: " ++ to_string e

meta def compile_local (e : expr) : smt2_m unit :=
do ty ← infer_type e,
   prop_sorted ← is_prop ty,
   if e.is_local_constant
   then if is_builtin_type ty
        then add_decl e.local_uniq_name ty
        else if ty.is_arrow
        then add_decl e.local_uniq_name ty
        else if prop_sorted
        then reflect_prop_formula ty
        else unsupported_formula ty
   else if e.is_constant
   then if is_builtin_type ty ∨ ty.is_arrow
        then add_decl e.const_name ty
        else if prop_sorted
        then reflect_prop_formula ty
        else unsupported_formula ty
   else if (ty = `(Prop))
   then reflect_prop_formula e
   else unsupported_formula e

meta def reflect_attr_decl (n : name) : smt2_m unit :=
do exp ← mk_const n,
   compile_local exp

/- Reflect the environment consisting of declarations with the `smt2` attribute. -/
meta def reflect_environment : smt2_m unit :=
do decls ← attribute.get_instances `smt2,
   bs ← monad.mapm reflect_attr_decl decls.reverse,
   return ()

meta def reflect_context : smt2_m unit :=
 do ls ← local_context,
    bs ← monad.mapm (fun e, compile_local e) ls,
    return ()

meta def reflect_goal : smt2_m unit :=
  do tgt ← target,
     -- SMT solvers are looking for satisfiabiltiy, so we must negate to check validity.
     reflect_prop_formula `(_root_.not %%tgt),
     return ()

meta def reflect : smt2_m (builder unit) :=
do reflect_environment,
   reflect_context,
   reflect_goal,
   st ← get,
   return $ (lol.to_builder (lol.smt2_compiler_state.mk (rb_map.mk _ _) st.ctxt []) lol.compile >> check_sat)

end smt2

universe u

@[smt2] lemma int_of_nat_is_pos :
  forall (n : nat), 0 <= int.of_nat n :=
begin
  intros, trivial
end

axiom proof_by_z3 (A : Sort u) : A

meta def z3 (log_file : option string := none) : tactic unit :=
do (builder, _) ← smt2.reflect.run smt2_state.initial,
   resp ← unsafe_run_io (smt2 builder log_file),
   match resp with
   | smt2.response.sat := fail "z3 was unable to prove the goal"
   | smt2.response.unknown := fail "z3 was unable to prove the goal"
   | smt2.response.other str := fail $ "z3 communication error, unexpected response:\n\n" ++ str ++ "\n"
   | smt2.response.unsat := do
        tgt ← target,
        sry ← to_expr $ ``(proof_by_z3 %%tgt),
        exact sry
   end


import Lean.Elab.Tactic
-- import Lean.Elab.Tactic.Simp

#exit

#check Lean.Meta.getSimpLemmas
#check Lean.Elab.Tactic.mkSimpContext
#check Lean.Elab.Tactic.evalSimp

theorem pointfree_left {f : α → β} {g : β → γ} :
  g (f x) = y →
  (g ∘ f) x = y := id

theorem pointfree_right {f : α → β} {g : β → γ} :
  x = g (f y) →
  x = (g ∘ f) y := id

theorem finish_pointfree {f g : α → β} :
  (∀ x, f x = g x) → f = g := funext

namespace Lean.Meta

namespace MakeBuddies

end MakeBuddies

open Lean.Expr
open Meta
open Lean.Macro
open Lean.Meta

-- def mkLam (v : Expr) (b : Expr) : MetaM Expr := do
-- let lctx ← getLCtx
-- let decl := lctx.get! v.fvarId!
-- let n :=  decl.userName
-- let t :=  decl.type
-- let bi :=  decl.binderInfo
-- return mkLambda n bi t (b.abstract #[v])
-- open Lean.Meta (mkLambdaFVars)

partial def finishPointFree (pr : Expr) : MetaM (FVarId × Expr) := do
match (← inferType pr) with
| app (app eq (app f x@(fvar x' _) _) _) (app f' y@(fvar y' _) _) _ => do
  unless (x' == y') do
    throwError "cannot transform into point-free: {x} {y}";
  let args := #[none, none, f, f', (← mkLambdaFVars #[x] pr)]
  let l ← mkAppOptM ``finish_pointfree args
  return (x', l)
| t => do
  throwError "bad shape {(← ppExpr t)}"

-- #check @pointfree_right

partial def mkPointFreeRight (pr : Expr) : MetaM (FVarId × Expr) := do
match (← inferType pr) with
| app (app eq lhs _) (app f (app g x _) _) _ =>
      let args := #[none, none, none, none, x, g, f, pr]
      (mkAppOptM ``pointfree_right args
       >>= mkPointFreeRight)
| _ => finishPointFree pr

partial def mkPointFreeLeft (pr : Expr) : MetaM (FVarId × Expr) := do
match (← inferType pr) with
| app (app eq (app f (app g x _) _) _) _ _ =>
      let args := #[none, none, none, x, none, g, f, pr]
      (mkAppOptM ``pointfree_left args
       >>= mkPointFreeLeft)
| _ => mkPointFreeRight pr

def makeBuddies (n : Name) : MetaM (Name × Name) := do
let info ← getConstInfo n
let ls : List Name := info.levelParams
let l ← mkConst n (ls.map mkLevelParam)
let n' := Name.appendAfter info.name "_pointfree"
let t ← inferType l
forallTelescopeReducing t λ args hd => do
  for x in args do
    IO.println s!"{(← ppExpr x)} : {(← ppExpr (← inferType x))}"
  IO.println s!"{(← ppExpr hd)}"
  let l' := mkAppN l args
  IO.println s!"{(← ppExpr l')}"
  IO.println s!"{(← ppExpr (← inferType l'))}"
  let (v, e) ← mkPointFreeLeft l'
  let args := args.erase (mkFVar v)
  let e ← mkLambdaFVars args e
  let t ← inferType e
  -- let t ← mkForallFVars args (← inferType e)
  modifyEnv λ env => env.add
    <| ConstantInfo.thmInfo
    <| { name := n',
         levelParams := ls,
         type := t,
         value := e }
  IO.println s!"{(← ppExpr e)} : {(← ppExpr (← inferType e))}"
  return (n, n')

#eval makeBuddies ``LawfulFunctor.comp_map
#check @LawfulFunctor.comp_map_pointfree
#check getSimpLemmas
namespace Buddies

private partial def isPerm : Expr → Expr → MetaM Bool
  | Expr.app f₁ a₁ _, Expr.app f₂ a₂ _ => isPerm f₁ f₂ <&&> isPerm a₁ a₂
  | Expr.mdata _ s _, t => isPerm s t
  | s, Expr.mdata _ t _ => isPerm s t
  | s@(Expr.mvar ..), t@(Expr.mvar ..) => isDefEq s t
  | Expr.forallE n₁ d₁ b₁ _, Expr.forallE n₂ d₂ b₂ _ => isPerm d₁ d₂ <&&> withLocalDeclD n₁ d₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.lam n₁ d₁ b₁ _, Expr.lam n₂ d₂ b₂ _ => isPerm d₁ d₂ <&&> withLocalDeclD n₁ d₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.letE n₁ t₁ v₁ b₁ _, Expr.letE n₂ t₂ v₂ b₂ _ =>
    isPerm t₁ t₂ <&&> isPerm v₁ v₂ <&&> withLetDecl n₁ t₁ v₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.proj _ i₁ b₁ _, Expr.proj _ i₂ b₂ _ => i₁ == i₂ <&&> isPerm b₁ b₂
  | s, t => s == t

private def checkTypeIsProp (type : Expr) : MetaM Unit :=
  unless (← isProp type) do
    throwError "invalid 'simp', proposition expected{indentExpr type}"

private def mkSimpLemmaCore (e : Expr) (levelParams : Array Name) (proof : Expr) (post : Bool) (prio : Nat) (name? : Option Name) : MetaM SimpLemma := do
  let type ← instantiateMVars (← inferType e)
  withNewMCtxDepth do
    let (xs, _, type) ← withReducible <| forallMetaTelescopeReducing type
    let type ← whnfR type
    let (keys, perm) ←
      match type.eq? with
      | some (_, lhs, rhs) => pure (← DiscrTree.mkPath lhs, ← isPerm lhs rhs)
      | none => throwError "unexpected kind of 'simp' theorem{indentExpr type}"
    return { keys := keys, perm := perm, post := post, levelParams := levelParams, proof := proof, name? := name?, priority := prio }

private partial def shouldPreprocess (type : Expr) : MetaM Bool :=
  forallTelescopeReducing type fun xs result => return !result.isEq

private partial def preprocess (e type : Expr) (inv : Bool) : MetaM (List (Expr × Expr)) := do
  let type ← whnf type
  if type.isForall then
    forallTelescopeReducing type fun xs type => do
      let e := mkAppN e xs
      let ps ← preprocess e type inv
      ps.mapM fun (e, type) =>
        return (← mkLambdaFVars xs e, ← mkForallFVars xs type)
  else if let some (_, lhs, rhs) := type.eq? then
    if inv then
      let type ← mkEq rhs lhs
      let e    ← mkEqSymm e
      return [(e, type)]
    else
      return [(e, type)]
  else if let some (lhs, rhs) := type.iff? then
    if inv then
      let type ← mkEq rhs lhs
      let e    ← mkEqSymm (← mkPropExt e)
      return [(e, type)]
    else
      let type ← mkEq lhs rhs
      let e    ← mkPropExt e
      return [(e, type)]
  else if let some (_, lhs, rhs) := type.ne? then
    if inv then
      throwError "invalid '←' modifier in rewrite rule to 'False'"
    let type ← mkEq (← mkEq lhs rhs) (mkConst ``False)
    let e    ← mkEqFalse e
    return [(e, type)]
  else if let some p := type.not? then
    if inv then
      throwError "invalid '←' modifier in rewrite rule to 'False'"
    let type ← mkEq p (mkConst ``False)
    let e    ← mkEqFalse e
    return [(e, type)]
  else if let some (type₁, type₂) := type.and? then
    let e₁ := mkProj ``And 0 e
    let e₂ := mkProj ``And 1 e
    return (← preprocess e₁ type₁ inv) ++ (← preprocess e₂ type₂ inv)
  else
    if inv then
      throwError "invalid '←' modifier in rewrite rule to 'True'"
    let type ← mkEq type (mkConst ``True)
    let e    ← mkEqTrue e
    return [(e, type)]

private def mkSimpLemmasFromConst (declName : Name) (post : Bool) (inv : Bool) (prio : Nat) : MetaM (Array SimpLemma) := do
  let cinfo ← getConstInfo declName
  let val := mkConst declName (cinfo.levelParams.map mkLevelParam)
  withReducible do
    let type ← inferType val
    checkTypeIsProp type
    if inv || (← shouldPreprocess type) then
      let mut r := #[]
      for (val, type) in (← preprocess val type inv) do
        let auxName ← mkAuxLemma cinfo.levelParams type val
        r := r.push <| (← mkSimpLemmaCore (mkConst auxName (cinfo.levelParams.map mkLevelParam)) #[] (mkConst auxName) post prio declName)
      return r
    else
      #[← mkSimpLemmaCore (mkConst declName (cinfo.levelParams.map mkLevelParam)) #[] (mkConst declName) post prio declName]

abbrev SimpExtension := SimpleScopedEnvExtension SimpEntry SimpLemmas

def SimpExtension.getLemmas (ext : SimpExtension) : CoreM SimpLemmas :=
  return ext.getState (← getEnv)

def addSimpLemma (ext : SimpExtension) (declName : Name) (post : Bool) (inv : Bool) (attrKind : AttributeKind) (prio : Nat) : MetaM Unit := do
  let simpLemmas ← mkSimpLemmasFromConst declName post inv prio
  for simpLemma in simpLemmas do
    ext.add (SimpEntry.lemma simpLemma) attrKind

def mkSimpAttr (attrName : Name) (attrDescr : String) (ext : SimpExtension) : IO Unit :=
  registerBuiltinAttribute {
    name  := attrName
    descr := attrDescr
    add   := fun declName stx attrKind =>
      let go : MetaM Unit := do
        let info ← getConstInfo declName
        if (← isProp info.type) then
          let post :=
            if stx[1].isNone then true else stx[1][0].getKind == ``Lean.Parser.Tactic.simpPost
          let prio ← getAttrParamOptPrio stx[2]
          addSimpLemma ext declName post (inv := false) attrKind prio
        else if info.hasValue then
          ext.add (SimpEntry.toUnfold declName) attrKind
        else
          throwError "invalid 'simp', it is not a proposition nor a definition (to unfold)"
      discard <| go.run {} {}
    erase := fun declName => do
      let s ← ext.getState (← getEnv)
      let s ← s.erase declName
      modifyEnv fun env => ext.modifyState env fun _ => s
  }

def mkSimpExt (extName : Name) : IO SimpExtension :=
  registerSimpleScopedEnvExtension {
    name     := extName
    initial  := {}
    addEntry := fun d e =>
      match e with
      | SimpEntry.lemma e => addSimpLemmaEntry d e
      | SimpEntry.toUnfold n => d.addDeclToUnfold n
  }

def registerSimpAttr (attrName : Name) (attrDescr : String) (extName : Name := attrName.appendAfter "Ext") : IO SimpExtension := do
  let ext ← mkSimpExt extName
  mkSimpAttr attrName attrDescr ext
  return ext

builtin_initialize mySimpExtension : SimpExtension ← registerSimpAttr `my_simp "simplification theorem with buddies"

def getSimpLemmas : CoreM SimpLemmas :=
  simpExtension.getLemmas

end Buddies

end Lean.Meta

namespace Lean.Elab.Tactic
-- abbrev mkDischargeWrapper :=
-- _root_.Lean.Elab.Tactic.mkDischargeWrapper

open Lean.Meta

private def addDeclToUnfoldOrLemma (lemmas : Meta.SimpLemmas) (e : Expr) (post : Bool) (inv : Bool) : MetaM Meta.SimpLemmas := do
  if e.isConst then
    let declName := e.constName!
    let info ← getConstInfo declName
    if (← isProp info.type) then
      lemmas.addConst declName (post := post) (inv := inv)
    else
      if inv then
        throwError "invalid '←' modifier, '{declName}' is a declaration name to be unfolded"
      lemmas.addDeclToUnfold declName
  else
    lemmas.add #[] e (post := post) (inv := inv)

private def addSimpLemma (lemmas : Meta.SimpLemmas) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM Meta.SimpLemmas := do
  let (levelParams, proof) ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx <| Term.withoutErrToSorry do
    let e ← Term.elabTerm stx none
    Term.synthesizeSyntheticMVars (mayPostpone := false) (ignoreStuckTC := true)
    let e ← instantiateMVars e
    let e := e.eta
    if e.hasMVar then
      let r ← abstractMVars e
      return (r.paramNames, r.expr)
    else
      return (#[], e)
  lemmas.add levelParams proof (post := post) (inv := inv)

/--
  Elaborate extra simp lemmas provided to `simp`. `stx` is of the `simpLemma,*`
  If `eraseLocal == true`, then we consider local declarations when resolving names for erased lemmas (`- id`),
  this option only makes sense for `simp_all`.
-/
private def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (eraseLocal : Bool) : TacticM ElabSimpArgsResult := do
  if stx.isNone then
    return { ctx }
  else
    /-
    syntax simpPre := "↓"
    syntax simpPost := "↑"
    syntax simpLemma := (simpPre <|> simpPost)? term

    syntax simpErase := "-" ident
    -/
    withMainContext do
      let mut lemmas  := ctx.simpLemmas
      let mut starArg := false
      for arg in stx[1].getSepArgs do
        if arg.getKind == ``Lean.Parser.Tactic.simpErase then
          if eraseLocal && (← Term.isLocalIdent? arg[1]).isSome then
            -- We use `eraseCore` because the simp lemma for the hypothesis was not added yet
            lemmas ← lemmas.eraseCore arg[1].getId
          else
            let declName ← resolveGlobalConstNoOverloadWithInfo arg[1]
            lemmas ← lemmas.erase declName
        else if arg.getKind == ``Lean.Parser.Tactic.simpLemma then
          let post :=
            if arg[0].isNone then
              true
            else
              arg[0][0].getKind == ``Parser.Tactic.simpPost
          let inv  := !arg[1].isNone
          let term := arg[2]
          match (← resolveSimpIdLemma? term) with
          | some e => lemmas ← addDeclToUnfoldOrLemma lemmas e post inv
          | _      => lemmas ← addSimpLemma lemmas term post inv
        else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
          starArg := true
        else
          throwUnsupportedSyntax
      return { ctx := { ctx with simpLemmas := lemmas }, starArg }
where
  resolveSimpIdLemma? (simpArgTerm : Syntax) : TacticM (Option Expr) := do
    if simpArgTerm.isIdent then
      try
        Term.resolveId? simpArgTerm (withInfo := true)
      catch _ =>
        return none
    else
      Term.elabCDotFunctionAlias? simpArgTerm

private def mkDischargeWrapper (optDischargeSyntax : Syntax) : TacticM Simp.DischargeWrapper := do
  if optDischargeSyntax.isNone then
    return Simp.DischargeWrapper.default
  else
    let (ref, d) ← tacticToDischarge optDischargeSyntax[0][3]
    return Simp.DischargeWrapper.custom ref d

-- TODO: move?
private def getPropHyps : MetaM (Array FVarId) := do
  let mut result := #[]
  for localDecl in (← getLCtx) do
    unless localDecl.isAuxDecl do
      if (← isProp localDecl.type) then
        result := result.push localDecl.fvarId
  return result

/--
  If `ctx == false`, the config argument is assumed to have type `Meta.Simp.Config`, and `Meta.Simp.ConfigCtx` otherwise.
  If `ctx == false`, the `discharge` option must be none -/
def mkSimpContext' (stx : Syntax) (eraseLocal : Bool) (ctx := false) (ignoreStarArg : Bool := false) : TacticM MkSimpContextResult := do
  if ctx && !stx[2].isNone then
    throwError "'simp_all' tactic does not support 'discharger' option"
  let dischargeWrapper ← mkDischargeWrapper stx[2]
  let simpOnly := !stx[3].isNone
  let simpLemmas ←
    if simpOnly then
      ({} : SimpLemmas).addConst ``eq_self
    else
      getSimpLemmas
  let congrLemmas ← getCongrLemmas
  let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) {
    config      := (← elabSimpConfig stx[1] (ctx := ctx))
    simpLemmas, congrLemmas
  }
  if !r.starArg || ignoreStarArg then
    return { r with fvarIdToLemmaId := {}, dischargeWrapper }
  else
    let ctx := r.ctx
    let erased := ctx.simpLemmas.erased
    let hs ← getPropHyps
    let mut ctx := ctx
    let mut fvarIdToLemmaId := {}
    for h in hs do
      let localDecl ← getLocalDecl h
      unless erased.contains localDecl.userName do
        let fvarId := localDecl.fvarId
        let proof  := localDecl.toExpr
        let id     ← mkFreshUserName `h
        fvarIdToLemmaId := fvarIdToLemmaId.insert fvarId id
        let simpLemmas ← ctx.simpLemmas.add #[] proof (name? := id)
        ctx := { ctx with simpLemmas }
    return { ctx, fvarIdToLemmaId, dischargeWrapper }

@[tactic Lean.Parser.Tactic.simp] def evalSimp' : Tactic := fun stx => do
  IO.println "simp!!!"
  -- let { ctx, fvarIdToLemmaId, dischargeWrapper } ← withMainContext <| mkSimpContext stx (eraseLocal := false)
  -- -- trace[Meta.debug] "Lemmas {← toMessageData ctx.simpLemmas.post}"
  -- dischargeWrapper.with fun discharge? =>
  --   simpLocation ctx discharge? fvarIdToLemmaId (expandOptLocation stx[5])

end Lean.Elab.Tactic

example : True := by simp


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jared Roesch, Sebastian Ullrich

The Except monad transformer.
-/
prelude
import Init.Control.Basic
import Init.Control.Id
import Init.Coe

namespace Except
variable {ε : Type u}

@[inline] protected def pure (a : α) : Except ε α :=
  Except.ok a

@[inline] protected def map (f : α → β) : Except ε α → Except ε β
  | Except.error err => Except.error err
  | Except.ok v => Except.ok <| f v

@[simp] theorem map_id : Except.map (ε := ε) (α := α) (β := α) id = id := by
  apply funext
  intro e
  simp [Except.map]; cases e <;> rfl

@[inline] protected def mapError (f : ε → ε') : Except ε α → Except ε' α
  | Except.error err => Except.error <| f err
  | Except.ok v      => Except.ok v

@[inline] protected def bind (ma : Except ε α) (f : α → Except ε β) : Except ε β :=
  match ma with
  | Except.error err => Except.error err
  | Except.ok v      => f v

@[inline] protected def toBool : Except ε α → Bool
  | Except.ok _    => true
  | Except.error _ => false

@[inline] protected def toOption : Except ε α → Option α
  | Except.ok a    => some a
  | Except.error _ => none

@[inline] protected def tryCatch (ma : Except ε α) (handle : ε → Except ε α) : Except ε α :=
  match ma with
  | Except.ok a    => Except.ok a
  | Except.error e => handle e

instance : Monad (Except ε) where
  pure := Except.pure
  bind := Except.bind
  map  := Except.map

end Except

def ExceptT (ε : Type u) (m : Type u → Type v) (α : Type u) : Type v :=
  m (Except ε α)

@[inline] def ExceptT.mk {ε : Type u} {m : Type u → Type v} {α : Type u} (x : m (Except ε α)) : ExceptT ε m α := x
@[inline] def ExceptT.run {ε : Type u} {m : Type u → Type v} {α : Type u} (x : ExceptT ε m α) : m (Except ε α) := x

namespace ExceptT

variable {ε : Type u} {m : Type u → Type v} [Monad m]

@[inline] protected def pure {α : Type u} (a : α) : ExceptT ε m α :=
  ExceptT.mk <| pure (Except.ok a)

@[inline] protected def bindCont {α β : Type u} (f : α → ExceptT ε m β) : Except ε α → m (Except ε β)
  | Except.ok a    => f a
  | Except.error e => pure (Except.error e)

@[inline] protected def bind {α β : Type u} (ma : ExceptT ε m α) (f : α → ExceptT ε m β) : ExceptT ε m β :=
  ExceptT.mk <| ma >>= ExceptT.bindCont f

@[inline] protected def map {α β : Type u} (f : α → β) (x : ExceptT ε m α) : ExceptT ε m β :=
  ExceptT.mk <| x >>= fun a => match a with
    | (Except.ok a)    => pure <| Except.ok (f a)
    | (Except.error e) => pure <| Except.error e

@[inline] protected def lift {α : Type u} (t : m α) : ExceptT ε m α :=
  ExceptT.mk <| Except.ok <$> t

instance : MonadLift (Except ε) (ExceptT ε m) := ⟨fun e => ExceptT.mk <| pure e⟩
instance : MonadLift m (ExceptT ε m) := ⟨ExceptT.lift⟩

@[inline] protected def tryCatch {α : Type u} (ma : ExceptT ε m α) (handle : ε → ExceptT ε m α) : ExceptT ε m α :=
  ExceptT.mk <| ma >>= fun res => match res with
   | Except.ok a    => pure (Except.ok a)
   | Except.error e => (handle e)

instance : MonadFunctor m (ExceptT ε m) := ⟨fun f x => f x⟩

instance : Monad (ExceptT ε m) where
  pure := ExceptT.pure
  bind := ExceptT.bind
  map  := ExceptT.map

@[inline] protected def adapt {ε' α : Type u} (f : ε → ε') : ExceptT ε m α → ExceptT ε' m α := fun x =>
  ExceptT.mk <| Except.mapError f <$> x

end ExceptT

instance (m : Type u → Type v) (ε₁ : Type u) (ε₂ : Type u) [Monad m] [MonadExceptOf ε₁ m] : MonadExceptOf ε₁ (ExceptT ε₂ m) where
  throw e := ExceptT.mk <| throwThe ε₁ e
  tryCatch x handle := ExceptT.mk <| tryCatchThe ε₁ x handle

instance (m : Type u → Type v) (ε : Type u) [Monad m] : MonadExceptOf ε (ExceptT ε m) where
  throw e := ExceptT.mk <| pure (Except.error e)
  tryCatch := ExceptT.tryCatch

instance [Monad m] [Inhabited ε] : Inhabited (ExceptT ε m α) where
  default := throw arbitrary

instance (ε) : MonadExceptOf ε (Except ε) where
  throw    := Except.error
  tryCatch := Except.tryCatch

namespace MonadExcept
variable {ε : Type u} {m : Type v → Type w}

/-- Alternative orelse operator that allows to select which exception should be used.
    The default is to use the first exception since the standard `orelse` uses the second. -/
@[inline] def orelse' [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) (useFirstEx := true) : m α :=
  tryCatch t₁ fun e₁ => tryCatch t₂ fun e₂ => throw (if useFirstEx then e₁ else e₂)

end MonadExcept

@[inline] def observing {ε α : Type u} {m : Type u → Type v} [Monad m] [MonadExcept ε m] (x : m α) : m (Except ε α) :=
  tryCatch (do let a ← x; pure (Except.ok a)) (fun ex => pure (Except.error ex))

instance (ε : Type u) (m : Type u → Type v) [Monad m] : MonadControl m (ExceptT ε m) where
  stM        := Except ε
  liftWith f := liftM <| f fun x => x.run
  restoreM x := x

class MonadFinally (m : Type u → Type v) where
  tryFinally' {α β} : m α → (Option α → m β) → m (α × β)

export MonadFinally (tryFinally')

/-- Execute `x` and then execute `finalizer` even if `x` threw an exception -/
@[inline] def tryFinally {m : Type u → Type v} {α β : Type u} [MonadFinally m] [Functor m] (x : m α) (finalizer : m β) : m α :=
  let y := tryFinally' x (fun _ => finalizer)
  (·.1) <$> y

instance Id.finally : MonadFinally Id where
  tryFinally' := fun x h =>
   let a := x
   let b := h (some x)
   pure (a, b)

instance ExceptT.finally {m : Type u → Type v} {ε : Type u} [MonadFinally m] [Monad m] : MonadFinally (ExceptT ε m) where
  tryFinally' := fun x h => ExceptT.mk do
    let r ← tryFinally' x fun e? => match e? with
        | some (Except.ok a) => h (some a)
        | _                  => h none
    match r with
    | (Except.ok a,    Except.ok b)    => pure (Except.ok (a, b))
    | (_,              Except.error e) => pure (Except.error e)  -- second error has precedence
    | (Except.error e, _)              => pure (Except.error e)


import Lbar.ext_aux4
import Lbar.iota

noncomputable theory

universes v u u'

open opposite category_theory category_theory.limits category_theory.preadditive
open_locale nnreal zero_object

variables (r r' : ℝ≥0)
variables [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r < 1)] [fact (r' < 1)]

open bounded_homotopy_category

variables {r'}
variables (BD : breen_deligne.package)
variables (κ κ₂ : ℝ≥0 → ℕ → ℝ≥0)
variables [∀ (c : ℝ≥0), BD.data.suitable (κ c)] [∀ n, fact (monotone (function.swap κ n))]
variables [∀ (c : ℝ≥0), BD.data.suitable (κ₂ c)] [∀ n, fact (monotone (function.swap κ₂ n))]
variables (M : ProFiltPseuNormGrpWithTinv₁.{u} r')

namespace Lbar

open ProFiltPseuNormGrpWithTinv₁ ProFiltPseuNormGrp₁ CompHausFiltPseuNormGrp₁
open bounded_homotopy_category

variables (r r')

def Tinv_sub (S : Profinite.{u}) (V : SemiNormedGroup.{u}) [normed_with_aut r V] (i : ℤ) :
  ((Ext' i).obj (op $ (Lbar.condensed.{u} r').obj S)).obj V.to_Cond ⟶
  ((Ext' i).obj (op $ (Lbar.condensed.{u} r').obj S)).obj V.to_Cond :=
((Ext' i).map ((condensify_Tinv _).app S).op).app _ -
((Ext' i).obj _).map (Condensed.of_top_ab_map (normed_with_aut.T.inv).to_add_monoid_hom
  (normed_add_group_hom.continuous _))

-- move me
attribute [simps] Condensed.of_top_ab_map

variables (S : Profinite.{0}) (V : SemiNormedGroup.{0})
variables [complete_space V] [separated_space V]
variables (r')

-- TODO(!): TC loop? using "by apply_instance" causes a maximum TC error
instance (X : Profinite.{0}) :
  preserves_limits_of_shape.{0 0 0 0 1 1}
  (discrete_quotient.{0} ↥X) (PFPNGT₁_to_CHFPNG₁ₑₗ.{0} r') := {}

set_option pp.universes true
def condensify_iso_extend :
  condensify (Fintype_Lbar.{0 0} r' ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r') ≅
  (Profinite.extend (Fintype_Lbar.{0 0} r')) ⋙
    (PFPNGT₁_to_CHFPNG₁ₑₗ r' ⋙ CHFPNG₁_to_CHFPNGₑₗ.{0} ⋙
  CompHausFiltPseuNormGrp.to_Condensed.{0}) :=
(((whiskering_left _ _ _).map_iso $
  Profinite.extend_commutes (Fintype_Lbar.{0 0} r') (PFPNGT₁_to_CHFPNG₁ₑₗ r')).app
    (CHFPNG₁_to_CHFPNGₑₗ.{0} ⋙ CompHausFiltPseuNormGrp.to_Condensed.{0})).symm

def condensify_iso_extend' :
  (condensify (Fintype_Lbar.{0 0} r' ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r')).obj S ≅
  ((Profinite.extend (Fintype_Lbar.{0 0} r')).obj S).to_Condensed :=
(condensify_iso_extend r').app S

section move_me

--universes u'

open Profinite

variables {C : Type u} [category.{v} C] (F : Fintype.{v} ⥤ C)
variables {D : Type u'} [category.{v} D]
variable [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]

@[reassoc]
lemma extend_commutes_comp_extend_extends' (G : C ⥤ D)
  [∀ X : Profinite.{v}, preserves_limits_of_shape (discrete_quotient X) G]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ F ⋙ G)] :
  whisker_left Fintype.to_Profinite (extend_commutes F G).hom =
  (functor.associator _ _ _).inv ≫ (whisker_right (extend_extends _).hom G) ≫
    (extend_extends _).inv :=
by rw [← category.assoc, iso.eq_comp_inv, extend_commutes_comp_extend_extends]

@[reassoc]
lemma extend_commutes_comp_extend_extends'' (G : C ⥤ D)
  [∀ X : Profinite.{v}, preserves_limits_of_shape (discrete_quotient X) G]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ F ⋙ G)] :
  whisker_left Fintype.to_Profinite (extend_commutes F G).inv =
  (extend_extends _).hom ≫ (whisker_right (extend_extends _).inv G) ≫
    (functor.associator _ _ _).hom :=
begin
  rw [← iso.inv_comp_eq, ← iso_whisker_left_inv, iso.comp_inv_eq, iso_whisker_left_hom,
    extend_commutes_comp_extend_extends', category.assoc, iso.hom_inv_id_assoc,
    ← iso_whisker_right_hom, ← iso_whisker_right_inv, iso.inv_hom_id_assoc],
end

end move_me

lemma condensify_Tinv_iso :
  condensify_Tinv (Fintype_Lbar.{0 0} r') ≫ (condensify_iso_extend r').hom =
  (condensify_iso_extend r').hom ≫ (@whisker_right _ _ _ _ _ _ _ _ (Tinv_nat_trans _) _) :=
begin
  delta Tinv_cond condensify_Tinv condensify_nonstrict condensify_iso_extend' condensify_iso_extend,
  ext S : 2,
  rw [iso.symm_hom, iso.app_inv, functor.map_iso_inv, nat_trans.comp_app, nat_trans.comp_app,
    whiskering_left_map_app_app, ← iso.app_inv, ← functor.map_iso_inv, iso.comp_inv_eq,
    functor.map_iso_inv, functor.map_iso_hom, functor.comp_map, functor.comp_map,
    whisker_right_app, whisker_right_app, ← functor.map_comp, ← functor.map_comp],
  congr' 1,
  rw [iso.app_inv, iso.app_hom, ← whisker_right_app, ← whisker_right_app,
    ← nat_trans.comp_app, ← nat_trans.comp_app],
  congr' 1,
  refine nonstrict_extend_ext _ _ (r'⁻¹) (1 * (r'⁻¹ * 1)) _ _ _,
  { intro X, apply nonstrict_extend_bound_by },
  { intro X,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one },
    { apply Tinv_bound_by },
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one }, },
  { rw [whisker_left_comp, whisker_left_comp, ← whisker_right_left, ← whisker_right_left,
      extend_commutes_comp_extend_extends', extend_commutes_comp_extend_extends''],
    rw nonstrict_extend_whisker_left,

    ext X : 2,
    simp only [whisker_left_app, whisker_right_app, nat_trans.comp_app,
      functor.associator_hom_app, functor.associator_inv_app,
      category.id_comp, category.comp_id, category.assoc, functor.map_comp],
    slice_rhs 2 3 {},
    congr' 2,

    simp only [← iso.app_hom, ← iso.app_inv, ← functor.map_iso_hom, ← functor.map_iso_inv,
      category.assoc, iso.eq_inv_comp],

    ext x : 1,
    exact (comphaus_filtered_pseudo_normed_group_with_Tinv_hom.map_Tinv
      ((Profinite.extend_extends (Fintype_Lbar.{0 0} r')).app X).hom x).symm }
end

lemma condensify_Tinv_iso' :
  (condensify_Tinv (Fintype_Lbar.{0 0} r')).app S ≫ (condensify_iso_extend' r' S).hom =
  (condensify_iso_extend' r' S).hom ≫ ((Profinite.extend (Fintype_Lbar.{0 0} r')).obj S).Tinv_cond :=
begin
  have := condensify_Tinv_iso r',
  apply_fun (λ η, η.app S) at this,
  exact this,
end

def useful_commsq (i : ℤ) (ι : ulift.{1} ℕ → ℝ≥0) (hι : monotone ι) [normed_with_aut r V] :=
  shift_sub_id.commsq
    (ExtQprime.Tinv2 r r' breen_deligne.eg.data
      (λ c n, c * breen_deligne.eg.κ r r' n)
      (λ c n, r' * (c * breen_deligne.eg.κ r r' n))
      ((Lbar.functor.{0 0} r').obj S) V i) ι hι

section
open breen_deligne thm95.universal_constants

variables (i : ℕ)

lemma useful_commsq_bicartesian (ι : ulift.{1} ℕ → ℝ≥0) (hι : monotone ι) [normed_with_aut r V]
  (H1 : ∀ j, c₀ r r' eg (λ n, eg.κ r r' n) (eg.κ' r r') (i+1) ⟨ℤ⟩ ≤ ι j)
  (H2 : ∀ j, k (eg.κ' r r') i ^ 2 * ι j ≤ ι (j + 1))
  (H3 : ∀ j, k (eg.κ' r r') (i+1) ^ 2 * ι j ≤ ι (j + 1)) :
  (useful_commsq r r' S V i ι hι).bicartesian :=
begin
  apply shift_sub_id.bicartesian_iso _ _
    (ExtQprime_iso_aux_system r' _ _ _ V i).symm (ExtQprime_iso_aux_system r' _ _ _ V i).symm ι hι
    (ExtQprime_iso_aux_system_comm' _ _ _ _ _ _ _ _),
  rw [← whisker_right_twice],
  refine shift_sub_id.bicartesian (aux_system.incl'.{0 1} r r' _ _ _ (eg.κ r r')) _
    i ι hι _ _ _,
  { apply_with system_of_complexes.shift_eq_zero {instances := ff},
    swap 3, { apply thm94.explicit r r' _ _ (eg.κ' r r'), },
    any_goals { apply_instance },
    { intro j,
      refine le_trans _ ((c₀_mono _ _ _ _ _ _ (i+1)).out.trans (H1 j)),
      rw nat.add_sub_cancel, },
    { exact H2 } },
  { apply_with system_of_complexes.shift_eq_zero {instances := ff},
    swap 3, { apply thm94.explicit r r' _ _ (eg.κ' r r'), },
    any_goals { apply_instance },
    { exact H1 },
    { exact H3 } },
  { intros c n,
    let κ := eg.κ r r',
    apply aux_system.short_exact r r' _ _ _ (λ c n, r' * (c * κ n)) κ,
    intro c, dsimp, apply_instance, }
end

lemma bicartesian_of_is_zero {𝓒 : Type*} [category 𝓒] [abelian 𝓒]
  {A B C D : 𝓒} (f₁ : A ⟶ B) (g₁ : A ⟶ C) (g₂ : B ⟶ D) (f₂ : C ⟶ D) (h : commsq f₁ g₁ g₂ f₂)
  (hA : is_zero A) (hB : is_zero B) (hC : is_zero C) (hD : is_zero D) :
  h.bicartesian :=
begin
  delta commsq.bicartesian,
  apply_with short_exact.mk {instances:=ff},
  { refine ⟨λ X f g h, _⟩, apply hA.eq_of_tgt },
  { refine ⟨λ X f g h, _⟩, apply hD.eq_of_src },
  { apply exact_of_is_zero ((is_zero_biprod _ _ hB hC).of_iso (h.sum.iso (sum_str.biprod _ _))), }
end

lemma is_zero_pi {𝓒 : Type*} [category 𝓒] [abelian 𝓒] {ι : Type*} (f : ι → 𝓒) [has_product f]
  (hf : ∀ i, is_zero (f i)) :
  is_zero (∏ f) :=
begin
  rw is_zero_iff_id_eq_zero,
  ext ⟨j⟩,
  apply (hf j).eq_of_tgt,
end

lemma useful_commsq_bicartesian_neg  (ι : ulift.{1} ℕ → ℝ≥0) (hι : monotone ι) [normed_with_aut r V]
  (i : ℤ) (hi : i < 0) :
  (useful_commsq r r' S V i ι hι).bicartesian :=
begin
  have : 1 + i ≤ 0, { linarith only [hi] },
  apply bicartesian_of_is_zero;
  apply is_zero_pi; intro x;
  apply Ext_single_right_is_zero _ _ 1 _ _ (chain_complex.bounded_by_one _) this
end

lemma is_iso_sq {𝓒 : Type*} [category 𝓒] {X Y : 𝓒} (f₁ : X ⟶ X) (f₂ : Y ⟶ Y)
  (e : X ≅ Y) (h : f₁ ≫ e.hom = e.hom ≫ f₂) (h₁ : is_iso f₁) :
  is_iso f₂ :=
by { rw [← iso.inv_comp_eq] at h, rw ← h, apply_instance }

open category_theory.preadditive

lemma is_iso_sq' {𝓒 : Type*} [category 𝓒] [abelian 𝓒] [enough_projectives 𝓒]
  {X Y Z : bounded_homotopy_category 𝓒} (f₁ : X ⟶ X) (f₂ : Y ⟶ Y) (f₃ : Z ⟶ Z)
  (e : Y ≅ X) (h : e.hom ≫ f₁ = f₂ ≫ e.hom) (i : ℤ)
  (h₁ : is_iso (((Ext i).map f₁.op).app Z - ((Ext i).obj _).map f₃)) :
  is_iso (((Ext i).map f₂.op).app Z - ((Ext i).obj _).map f₃) :=
begin
  refine is_iso_sq _ _ ((functor.map_iso _ e.op).app _) _ h₁,
  rw [iso.app_hom, functor.map_iso_hom, sub_comp, comp_sub, nat_trans.naturality,
      ← nat_trans.comp_app, ← nat_trans.comp_app, ← functor.map_comp, ← functor.map_comp,
      iso.op_hom, ← op_comp, ← op_comp, h],
end

/-- Thm 9.4bis of [Analytic]. More precisely: the first observation in the proof 9.4 => 9.1. -/
theorem is_iso_Tinv_sub [normed_with_aut r V] : ∀ i, is_iso (Tinv_sub r r' S V i) :=
begin
  erw (Condensed.bd_lemma _ _ _ _),
  swap, { apply Lbar.obj.no_zero_smul_divisors },
  intro i,
  refine is_iso_sq' _ _ _ (functor.map_iso _ $ condensify_iso_extend' _ _) _ _ _,
  { refine category_theory.functor.map _ _, refine Tinv_cond _ },
  { rw [functor.map_iso_hom, ← functor.map_comp, ← functor.map_comp, condensify_Tinv_iso'], },
  revert i,
  refine Tinv2_iso_of_bicartesian' r breen_deligne.eg
      (λ c n, c * breen_deligne.eg.κ r r' n)
      (λ c n, r' * (c * breen_deligne.eg.κ r r' n))
    ((Lbar.functor.{0 0} r').obj S) V _,
  rintro (i|(_|i)),
  { refine ⟨ι r r' i, hι r r' i, _, _, _, _⟩,
    { intros s m,
      apply Lbar.sufficiently_increasing_eg },
    { intros s m,
      apply Lbar.sufficiently_increasing_eg' },
    all_goals { apply useful_commsq_bicartesian },
    { rintro ⟨j⟩, apply Hι1 },
    { rintro ⟨j⟩, apply Hι2a },
    { rintro ⟨j⟩, apply Hι2b },
    { rintro ⟨j⟩, apply Hι1' },
    { rintro ⟨j⟩, apply Hι2b },
    { rintro ⟨j⟩, apply Hι2c } },
  { refine ⟨ι r r' 0, hι r r' 0, _, _, _, _⟩,
    { intros s m, apply Lbar.sufficiently_increasing_eg, },
    { intros s m, apply Lbar.sufficiently_increasing_eg', },
    { apply useful_commsq_bicartesian_neg, dec_trivial },
    { apply useful_commsq_bicartesian,
    { rintro ⟨j⟩, apply Hι1 },
    { rintro ⟨j⟩, apply Hι2a },
    { rintro ⟨j⟩, apply Hι2b }, }, },
  { refine ⟨ι r r' 0, hι r r' 0, _, _, _, _⟩,
    { intros s m, apply Lbar.sufficiently_increasing_eg, },
    { intros s m, apply Lbar.sufficiently_increasing_eg', },
    { apply useful_commsq_bicartesian_neg, dec_trivial },
    { apply useful_commsq_bicartesian_neg,
      rw [int.neg_succ_of_nat_eq'],
      simp only [int.coe_nat_succ, neg_add_rev, sub_add_cancel, add_neg_lt_iff_le_add', add_zero],
      dec_trivial }, },
end

/-- Thm 9.4bis of [Analytic]. More precisely: the first observation in the proof 9.4 => 9.1. -/
theorem is_iso_Tinv2 [normed_with_aut r V]
  (hV : ∀ (v : V), (normed_with_aut.T.inv v) = 2 • v) :
  ∀ i, is_iso (((Ext' i).map ((condensify_Tinv2 (Fintype_Lbar.{0 0} r')).app S).op).app
    (Condensed.of_top_ab ↥V)) :=
begin
  intro i,
  rw [condensify_Tinv2_eq, ← functor.flip_obj_map, nat_trans.app_sub, category_theory.op_sub,
    nat_trans.app_nsmul,  category_theory.op_nsmul, two_nsmul, nat_trans.id_app, op_id,
    functor.map_sub, functor.map_add, category_theory.functor.map_id],
  convert is_iso_Tinv_sub r r' S V i using 2,
  suffices : Condensed.of_top_ab_map (normed_add_group_hom.to_add_monoid_hom normed_with_aut.T.inv) _ =
    2 • 𝟙 _,
  { rw [this, two_nsmul, functor.map_add, category_theory.functor.map_id], refl, },
  ext T f t,
  dsimp only [Condensed.of_top_ab_map_val, whisker_right_app, Ab.ulift_map_apply_down,
    add_monoid_hom.mk'_apply, continuous_map.coe_mk, function.comp_app],
  erw [hV, two_nsmul, two_nsmul],
  refl,
end

end

end Lbar


import Init
import Lean.Parser
import Lean.PrettyPrinter

section
open Lean.Parser
open Lean.PrettyPrinter

/-- Like `ident` but with no splitting on dots and accepts anything that's not whitespace
or parentheses. So e.g. `<=` works. -/
def generalIdent : Parser :=
  withAntiquot (mkAntiquot "generalIdent" `generalIdent) {
    fn := fun c s =>
      let startPos := s.pos
      let s := takeWhile1Fn (fun c => !("(){}[].".contains c) ∧ !c.isWhitespace) "expected generalized identifier" c s
      mkNodeToken `generalIdent startPos c s }

def Lean.TSyntax.getGeneralId : TSyntax `generalIdent → String
  | ⟨Syntax.node _ `generalIdent args⟩ => args[0]!.getAtomVal!
  | s => panic! s!"unexpected syntax '{s}'"

@[combinatorFormatter generalIdent] def generalIdent.formatter : Formatter := pure ()
@[combinatorParenthesizer generalIdent] def generalIdent.parenthesizer : Parenthesizer := pure ()
end

inductive Sexp where
  | atom : String → Sexp
  | expr : List Sexp → Sexp
  deriving Repr, BEq, Inhabited

namespace Sexp

instance : Coe String Sexp :=
  ⟨Sexp.atom⟩

declare_syntax_cat sexp

syntax generalIdent : sexp
syntax "(" sexp* ")" : sexp
syntax "(" sexp* "...{" term "}" sexp* ")" : sexp
syntax "{" term "}" : sexp

-- This coercion is justified by the macro expansions below.
instance : Coe (Lean.TSyntax `sexp) (Lean.TSyntax `term) where
  coe a := ⟨a.raw⟩

macro_rules
  | `(sexp| $a:generalIdent) => `(Sexp.atom $(Lean.quote a.getGeneralId))
  | `(sexp| ( $ss:sexp* )) => `(Sexp.expr [ $ss,* ])
  | `(sexp| ( $ss:sexp* ...{ $t:term } $ts:sexp* )) => `(Sexp.expr <| [ $ss,* ] ++ ($t : List Sexp) ++ [ $ts,* ])
  | `(sexp| { $t:term }) => `($t)

syntax "sexp!{" sexp "}" : term
macro_rules
  | `(sexp!{ $s:sexp }) => `($s)

syntax "sexps!{" sexp* "}" : term
syntax "sexps!{" sexp* "...{" term "}" sexp* "}" : term
macro_rules
  | `(sexps!{ $ss:sexp* }) => do
    let ss ← ss.mapM fun s => `(sexp!{ $s })
    `([ $[$ss],* ])
  | `(sexps!{ $ss:sexp* ...{ $t:term } $ts:sexp* }) =>
    `([ $[$ss],* ] ++ ($t : List Sexp) ++ [ $[$ts],* ])

partial def serialize : Sexp → String
  | atom s  => s
  | expr ss => s!"({" ".intercalate <| ss.map serialize})"

partial def serializeMany (ss : List Sexp) : String :=
  ss.map serialize |> "\n".intercalate

instance : ToString Sexp :=
  ⟨serialize⟩

instance : Repr Sexp where
  reprPrec s _ := s!"sexp!\{{toString s}}"

partial def parse (s : String) : Except String (List Sexp) :=
  let tks := tokenize #[] s.toSubstring
  parseMany #[] tks.toList |>.map Prod.fst |>.map Array.toList
where
  tokenize (stk : Array Substring) (s : Substring) : Array Substring :=
    if s.isEmpty then stk
    else
      let c := s.front
      if c == ')' || c == '(' then
        tokenize (stk.push <| s.take 1) (s.drop 1)
      else if c.isWhitespace then tokenize stk (s.drop 1)
      else
        let tk := s.takeWhile fun c => !c.isWhitespace && c != '(' && c != ')'
        if tk.bsize > 0 then tokenize (stk.push tk) (s.extract ⟨tk.bsize⟩ ⟨s.bsize⟩)
        else unreachable!

  parseOne : List Substring → Except String (Sexp × List Substring)
    | tk :: tks => do
      if tk.front == ')' then
        throw "mismatched parentheses"
      if tk.front == '(' then
        let (ss, tks) ← parseMany #[] tks
        return (expr ss.toList, tks)
      else
        return  (atom tk.toString, tks)
    | [] => throw "expected input, got none"

  parseMany (stk : Array Sexp) : List Substring → Except String (Array Sexp × List Substring)
    | tk :: tks => do
      if tk.front == ')' then .ok (stk, tks)
      else
        let (e, tks) ← parseOne (tk :: tks)
        parseMany (stk.push e) tks
    | [] => .ok (stk, [])

end Sexp

private def argsCvc4 : IO.Process.SpawnArgs := {
  cmd := "LAMR/bin/cvc4"
  args := #["--lang", "smt", "LAMR/bin/temp.smt"] }

private def argsCvc5 : IO.Process.SpawnArgs := {
  cmd := "LAMR/bin/cvc5"
  args := #["--lang", "smt", "LAMR/bin/temp.smt"] }

private def argsZ3 : IO.Process.SpawnArgs := {
  cmd := "LAMR/bin/z3"
  args := #["-smt2", "LAMR/bin/temp.smt"] }

private def argsBoolector : IO.Process.SpawnArgs := {
  cmd := "LAMR/bin/boolector"
  args := #["--smt2", "LAMR/bin/temp.smt"] }

-- Same as IO.Process.run, but does not require exitcode = 0
private def run' (args : IO.Process.SpawnArgs) : IO String := do
  let out ← IO.Process.output args
  pure out.stdout

/-- Executes the solver with the provided list of commands in SMT-LIB s-expression format.
Returns the solver output as s-expressions. -/
private def callSolver (args : IO.Process.SpawnArgs) (commands : List Sexp) (verbose : Bool := false)
    : IO (List Sexp) := do
  let cmdStr := Sexp.serializeMany commands
  if verbose then
    IO.println "Sending SMT-LIB problem:"
    IO.println cmdStr
  IO.FS.writeFile "LAMR/bin/temp.smt" cmdStr
  let out ← run' args
  if verbose then
    IO.println "\nSolver replied:"
    IO.println out
  let out ← IO.ofExcept (Sexp.parse out)
  return out

def callCvc4 := @callSolver argsCvc4
def callCvc5 := @callSolver argsCvc5
def callZ3 := @callSolver argsZ3
def callBoolector := @callSolver argsBoolector

private def hexdigits : Array Char :=
  #[ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f' ]

private def enhexByte (x : UInt8) : String :=
  ⟨[hexdigits.get! $ UInt8.toNat $ (x.land 0xf0).shiftRight 4,
    hexdigits.get! $ UInt8.toNat $ x.land 0xf ]⟩

/-- Convert a little-endian (LSB first) list of bytes to hexadecimal. -/
private def enhexLE : List UInt8 → String
  | [] => ""
  | b::bs => enhexLE bs ++ enhexByte b

/-- Converts a number `n` to its hexadecimal SMT-LIB representation as a `nBits`-bit vector.
For example `toBVConst 32 0xf == "#x0000000f"`. -/
def toBVConst (nBits : Nat) (n : Nat) : String :=
  assert! nBits % 8 == 0
  let nBytes := nBits/8
  let bytes := List.range nBytes |>.map fun i => UInt8.ofNat ((n >>> (i*8)) &&& 0xff)
  "#x" ++ enhexLE bytes

open Std (AssocList)

/-- Extracts constants assigned in a model returned from an SMT solver.
The model is expected to be a single s-expression representing a list,
with constant expressions represented by `(define-fun <name> () <type> <body>)`. -/
def decodeModelConsts : Sexp → AssocList String Sexp
  | Sexp.expr ss =>
    ss.foldl (init := AssocList.empty) fun
      | acc, sexp!{(define-fun {Sexp.atom x} () {_} {body})} =>
        acc.insert x body
      | acc, _ => acc
  | _ => AssocList.empty

/-- Evaluates an SMT-LIB constant numeral such as `0` or `#b01` or `#x02`. -/
def evalNumConst : Sexp → Option Nat
  | Sexp.atom s =>
    let s' :=
      if s.startsWith "#b" then "0" ++ s.drop 1
      else if s.startsWith "#x" then "0" ++ s.drop 1
      else s
    Lean.Syntax.decodeNatLitVal? s'
  | Sexp.expr _ => none


import .geom3d_series
import tactic.linarith

def ts := time_std_space

def world_fr := geom3d_std_frame
def world := geom3d_std_space

def bl_fr :=
 let origin := mk_position3d world 1.000000 2.000000 3.000000 in
 let basis0 := mk_displacement3d world 4.000000 3.000000 2.000000 in
 let basis1 := mk_displacement3d world 1.000000 2.000000 3.000000 in
 let basis2 := mk_displacement3d world 2.000000 1.000000 2.000000 in
 mk_geom3d_frame origin basis0 basis1 basis2

def fr1 :=
 let origin := mk_position3d world 2.000000 4.000000 3.000000 in
 let basis0 := mk_displacement3d world 4.000000 3.000000 2.000000 in
 let basis1 := mk_displacement3d world 1.000000 2.000000 3.000000 in
 let basis2 := mk_displacement3d world 2.000000 1.000000 2.000000 in
 mk_geom3d_frame origin basis0 basis1 basis2

def fr2 :=
 let origin := mk_position3d world 4.000000 4.000000 3.000000 in
 let basis0 := mk_displacement3d world 4.000000 3.000000 2.000000 in
 let basis1 := mk_displacement3d world 1.000000 2.000000 3.000000 in
 let basis2 := mk_displacement3d world 2.000000 1.000000 2.000000 in
 mk_geom3d_frame origin basis0 basis1 basis2

def ser : geom3d_series ts :=
  ⟨
    [
      (mk_time _ 2,world_fr)--,
    --  (mk_time _ 1,fr1),
      --(mk_time _ 0,fr2)

      --(mk_time _ 2),
      --(mk_time _ 1),
      --(mk_time _ 0)
    ]⟩
/-(⟨mk_time _ 0,sorry⟩-/

#eval ser

#check quotient.eq

def v1 := mk_displacement3d_timefixed_at_time ser (mk_time ts (2.4:ℚ)) 1 1 1

def v2 := mk_displacement3d_timefixed_at_time ser (mk_time ts (2.5:ℚ)) 1 1 1

example : v1.frame = world_fr := begin
  unfold displacement3d.frame,
  unfold geom3d_series.find,
  split,
end

example : v1.frame = v2.frame := begin
  dsimp [displacement3d.frame],
  split,
end

#check v1 +ᵥ v2

def t1 := ⟦(⟨(mk_time ts (2.4:ℚ))⟩ : series_index ts ser)⟧
def t2 := ⟦(⟨(mk_time ts (2.5:ℚ))⟩ : series_index ts ser)⟧

example : t1 = t2 := sorry

#check t1

#check quotient.lift

def v3 := mk_displacement3d_timefixed_at_time'' ser ⟦series_index.mk (mk_time ts (2.4:ℚ))⟧ 1 1 1

def v4 := mk_displacement3d_timefixed_at_time'' ser ⟦series_index.mk (mk_time ts (2.5:ℚ))⟧ 1 1 1

#check v3 +ᵥ v4


import .brown

universes v u

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

namespace homotopy_theory.cofibrations
open precofibration_category cofibration_category
open homotopy_theory.weak_equivalences

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

-- Following Rădulescu-Banu, Cofibrations in Homotopy Theory, Lemma 1.4.1

variables {a₁ a₂ a₃ a₄ b₁ b₂ b₃ b₄ : C}
  {f₁₂ : a₁ ⟶ a₂} {f₁₃ : a₁ ⟶ a₃} {f₂₄ : a₂ ⟶ a₄} {f₃₄ : a₃ ⟶ a₄}
  (po_f : Is_pushout f₁₂ f₁₃ f₂₄ f₃₄)
  {g₁₂ : b₁ ⟶ b₂} {g₁₃ : b₁ ⟶ b₃} {g₂₄ : b₂ ⟶ b₄} {g₃₄ : b₃ ⟶ b₄}
  (po_g : Is_pushout g₁₂ g₁₃ g₂₄ g₃₄)
  {u₁ : a₁ ⟶ b₁} {u₂ : a₂ ⟶ b₂} {u₃ : a₃ ⟶ b₃} -- u₄ will be the induced map of pushouts
  (ha₁ : cofibrant a₁) (ha₃ : cofibrant a₃) (hb₁ : cofibrant b₁) (hb₃ : cofibrant b₃)
  (hf₁₂ : is_cof f₁₂) (hg₁₂ : is_cof g₁₂)
  (hwu₁ : is_weq u₁) (hwu₂ : is_weq u₂) (hwu₃ : is_weq u₃)
  (s₁₂ : f₁₂ ≫ u₂ = u₁ ≫ g₁₂) (s₁₃ : f₁₃ ≫ u₃ = u₁ ≫ g₁₃)

lemma gluing_weq_aux (hcu₁ : is_cof u₁) (hcu₃ : is_cof u₃)
  (hcu₂'' : is_cof ((pushout_by_cof f₁₂ u₁ hf₁₂).is_pushout.induced u₂ g₁₂ s₁₂)) :
  is_weq (pushout_of_maps po_f po_g u₁ u₂ u₃ s₁₂ s₁₃) :=
have acof_u₁ : is_acof u₁ := ⟨hcu₁, hwu₁⟩,
have acof_u₃ : is_acof u₃ := ⟨hcu₃, hwu₃⟩,
let po₁₂ := pushout_by_cof f₁₂ u₁ hf₁₂,
    u₂' := po₁₂.map₀,
    u₂'' := po₁₂.is_pushout.induced u₂ g₁₂ s₁₂,
    u₄ := pushout_of_maps po_f po_g u₁ u₂ u₃ s₁₂ s₁₃,
    po₃₄ := pushout_by_cof f₃₄ u₃ (pushout_is_cof po_f hf₁₂),
    u₄' := po₃₄.map₀,
    u₄'' := po₃₄.is_pushout.induced u₄ g₃₄ (by simp) in
have acof_u₂' : is_acof u₂' := pushout_is_acof po₁₂.is_pushout.transpose acof_u₁,
have acof_u₄' : is_acof u₄' := pushout_is_acof po₃₄.is_pushout.transpose acof_u₃,
have acof_u₂'' : is_acof u₂'' := have _ := hwu₂, begin
  refine ⟨hcu₂'', category_with_weak_equivalences.weq_of_comp_weq_left acof_u₂'.2 _⟩,
  simpa using this
end,
let k := pushout_of_maps po₁₂.is_pushout po₃₄.is_pushout f₁₃ f₂₄ g₁₃ po_f.commutes s₁₃.symm in
suffices Is_pushout u₂'' k g₂₄ u₄'',
  by convert weq_comp acof_u₄'.2 (pushout_is_acof this acof_u₂'').2; simp,
have _ := Is_pushout_of_Is_pushout_of_Is_pushout po_f po₃₄.is_pushout,
have Is_pushout f₁₂ (u₁ ≫ g₁₃) (u₂' ≫ k) po₃₄.map₁ := begin
  convert this using 1,
  { exact s₁₃.symm },
  { simp }
end,
have Is_pushout po₁₂.map₁ g₁₃ k po₃₄.map₁ :=
  Is_pushout_of_Is_pushout_of_Is_pushout' po₁₂.is_pushout this (by simp),
have po_g' : Is_pushout (po₁₂.map₁ ≫ u₂'') g₁₃ g₂₄ (po₃₄.map₁ ≫ u₄'') := by convert po_g using 1; simp,
Is_pushout_of_Is_pushout_of_Is_pushout_vert' this po_g' $
  by apply po₁₂.is_pushout.uniqueness; rw [←category.assoc, ←category.assoc]; simp [po_g.commutes]

lemma gluing_weq : is_weq (pushout_of_maps po_f po_g u₁ u₂ u₃ s₁₂ s₁₃) :=
let ⟨c₁⟩ := exists_brown_factorization ha₁ hb₁ u₁,
    ⟨c₂, h₁₂, hv₂, hr₂, hw₂, x, y⟩ :=
      exists_relative_brown_factorization
        ha₁ hb₁ (cofibrant_of_cof ha₁ hf₁₂) (cofibrant_of_cof hb₁ hg₁₂) u₁ u₂ f₁₂ g₁₂ s₁₂.symm c₁,
    ⟨c₃, h₁₃, hv₃, hr₃, hw₃, _, _⟩ :=
      exists_relative_brown_factorization ha₁ hb₁ ha₃ hb₃ u₁ u₃ f₁₃ g₁₃ s₁₃.symm c₁,
    po := pushout_by_cof c₁.f' f₁₂ c₁.hf' in
have cof_h₁₂ : is_cof h₁₂ := begin
  convert cof_comp (pushout_is_cof po.is_pushout.transpose hf₁₂) (x hg₁₂) using 1,
  simp
end,
have wv : _ := gluing_weq_aux po_f (pushout_by_cof h₁₂ h₁₃ cof_h₁₂).is_pushout hf₁₂
  (c₁.weq_f' hwu₁) (c₂.weq_f' hwu₂) (c₃.weq_f' hwu₃) hv₂.symm hv₃.symm c₁.hf' c₃.hf'
  (by rw ←Is_pushout.transpose_induced; exact cof_comp (cof_iso _) (x hg₁₂)),
have ww : _ := gluing_weq_aux po_g (pushout_by_cof h₁₂ h₁₃ cof_h₁₂).is_pushout hg₁₂
  c₁.hs.2 c₂.hs.2 c₃.hs.2 hw₂.symm hw₃.symm c₁.hs.1 c₃.hs.1
  (by rw ←Is_pushout.transpose_induced; exact cof_comp (cof_iso _) (y hf₁₂).1),
let po_h := pushout_by_cof h₁₂ h₁₃ cof_h₁₂ in
have wr : is_weq (pushout_of_maps po_h.is_pushout po_g c₁.r c₂.r c₃.r hr₂.symm hr₃.symm), begin
  refine (weq_iff_weq_inv _).mp ww,
  rw ←pushout_of_maps_comp,
  convert pushout_of_maps_id po_g,
  { exact c₁.hsr }, { exact c₂.hsr }, { exact c₃.hsr }
end,
begin
  convert weq_comp wv wr,
  rw ←pushout_of_maps_comp,
  congr,
  { exact c₁.hf'r.symm }, { exact c₂.hf'r.symm}, { exact c₃.hf'r.symm }
end

end homotopy_theory.cofibrations


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Sebastian Ullrich
-/
import Lean.Util.CollectLevelParams
import Lean.Elab.DeclUtil
import Lean.Elab.DefView
import Lean.Elab.Inductive
import Lean.Elab.Structure
import Lean.Elab.MutualDef
import Lean.Elab.DeclarationRange
namespace Lean.Elab.Command

open Meta

/- Auxiliary function for `expandDeclNamespace?` -/
def expandDeclIdNamespace? (declId : Syntax) : Option (Name × Syntax) :=
  let (id, optUnivDeclStx) := expandDeclIdCore declId
  let scpView := extractMacroScopes id
  match scpView.name with
  | Name.str Name.anonymous s _ => none
  | Name.str pre s _            =>
    let nameNew := { scpView with name := Name.mkSimple s }.review
    if declId.isIdent then
      some (pre, mkIdentFrom declId nameNew)
    else
      some (pre, declId.setArg 0 (mkIdentFrom declId nameNew))
  | _ => none

/- given declarations such as `@[...] def Foo.Bla.f ...` return `some (Foo.Bla, @[...] def f ...)` -/
def expandDeclNamespace? (stx : Syntax) : Option (Name × Syntax) :=
  if !stx.isOfKind `Lean.Parser.Command.declaration then none
  else
    let decl := stx[1]
    let k := decl.getKind
    if k == ``Lean.Parser.Command.abbrev ||
       k == ``Lean.Parser.Command.def ||
       k == ``Lean.Parser.Command.theorem ||
       k == ``Lean.Parser.Command.constant ||
       k == ``Lean.Parser.Command.axiom ||
       k == ``Lean.Parser.Command.inductive ||
       k == ``Lean.Parser.Command.classInductive ||
       k == ``Lean.Parser.Command.structure then
      match expandDeclIdNamespace? decl[1] with
      | some (ns, declId) => some (ns, stx.setArg 1 (decl.setArg 1 declId))
      | none              => none
    else if k == ``Lean.Parser.Command.instance then
      let optDeclId := decl[3]
      if optDeclId.isNone then none
      else match expandDeclIdNamespace? optDeclId[0] with
        | some (ns, declId) => some (ns, stx.setArg 1 (decl.setArg 3 (optDeclId.setArg 0 declId)))
        | none              => none
    else
      none

def elabAxiom (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
  -- leading_parser "axiom " >> declId >> declSig
  let declId             := stx[1]
  let (binders, typeStx) := expandDeclSig stx[2]
  let scopeLevelNames ← getLevelNames
  let ⟨name, declName, allUserLevelNames⟩ ← expandDeclId declId modifiers
  addDeclarationRanges declName stx
  runTermElabM declName fun vars => Term.withLevelNames allUserLevelNames $ Term.elabBinders binders.getArgs fun xs => do
    Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.beforeElaboration
    let type ← Term.elabType typeStx
    Term.synthesizeSyntheticMVarsNoPostponing
    let type ← instantiateMVars type
    let type ← mkForallFVars xs type
    let type ← mkForallFVars vars type (usedOnly := true)
    let (type, _) ← Term.levelMVarToParam type
    let usedParams  := collectLevelParams {} type |>.params
    match sortDeclLevelParams scopeLevelNames allUserLevelNames usedParams with
    | Except.error msg      => throwErrorAt stx msg
    | Except.ok levelParams =>
      let decl := Declaration.axiomDecl {
        name        := declName,
        levelParams := levelParams,
        type        := type,
        isUnsafe    := modifiers.isUnsafe
      }
      Term.ensureNoUnassignedMVars decl
      addDecl decl
      Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.afterTypeChecking
      if isExtern (← getEnv) declName then
        compileDecl decl
      Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.afterCompilation

/-
leading_parser "inductive " >> declId >> optDeclSig >> optional ":=" >> many ctor
leading_parser atomic (group ("class " >> "inductive ")) >> declId >> optDeclSig >> optional ":=" >> many ctor >> optDeriving
-/
private def inductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : CommandElabM InductiveView := do
  checkValidInductiveModifier modifiers
  let (binders, type?) := expandOptDeclSig decl[2]
  let declId           := decl[1]
  let ⟨name, declName, levelNames⟩ ← expandDeclId declId modifiers
  addDeclarationRanges declName decl
  let ctors      ← decl[4].getArgs.mapM fun ctor => withRef ctor do
    -- def ctor := leading_parser " | " >> declModifiers >> ident >> optional inferMod >> optDeclSig
    let ctorModifiers ← elabModifiers ctor[1]
    if ctorModifiers.isPrivate && modifiers.isPrivate then
      throwError "invalid 'private' constructor in a 'private' inductive datatype"
    if ctorModifiers.isProtected && modifiers.isPrivate then
      throwError "invalid 'protected' constructor in a 'private' inductive datatype"
    checkValidCtorModifier ctorModifiers
    let ctorName := ctor.getIdAt 2
    let ctorName := declName ++ ctorName
    let ctorName ← withRef ctor[2] $ applyVisibility ctorModifiers.visibility ctorName
    let inferMod := !ctor[3].isNone
    let (binders, type?) := expandOptDeclSig ctor[4]
    addDocString' ctorName ctorModifiers.docString?
    addAuxDeclarationRanges ctorName ctor ctor[2]
    pure { ref := ctor, modifiers := ctorModifiers, declName := ctorName, inferMod := inferMod, binders := binders, type? := type? : CtorView }
  let classes ← getOptDerivingClasses decl[5]
  pure {
    ref             := decl
    modifiers       := modifiers
    shortDeclName   := name
    declName        := declName
    levelNames      := levelNames
    binders         := binders
    type?           := type?
    ctors           := ctors
    derivingClasses := classes
  }

private def classInductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : CommandElabM InductiveView :=
  inductiveSyntaxToView modifiers decl

def elabInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
  let v ← inductiveSyntaxToView modifiers stx
  elabInductiveViews #[v]

def elabClassInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
  let modifiers := modifiers.addAttribute { name := `class }
  let v ← classInductiveSyntaxToView modifiers stx
  elabInductiveViews #[v]

@[builtinCommandElab declaration]
def elabDeclaration : CommandElab := fun stx =>
  match expandDeclNamespace? stx with
  | some (ns, newStx) => do
    let ns := mkIdentFrom stx ns
    let newStx ← `(namespace $ns:ident $newStx end $ns:ident)
    withMacroExpansion stx newStx $ elabCommand newStx
  | none => do
    let modifiers ← elabModifiers stx[0]
    let decl     := stx[1]
    let declKind := decl.getKind
    if declKind == ``Lean.Parser.Command.«axiom» then
      elabAxiom modifiers decl
    else if declKind == ``Lean.Parser.Command.«inductive» then
      elabInductive modifiers decl
    else if declKind == ``Lean.Parser.Command.classInductive then
      elabClassInductive modifiers decl
    else if declKind == ``Lean.Parser.Command.«structure» then
      elabStructure modifiers decl
    else if isDefLike decl then
      elabMutualDef #[stx]
    else
      throwError "unexpected declaration"

/- Return true if all elements of the mutual-block are inductive declarations. -/
private def isMutualInductive (stx : Syntax) : Bool :=
  stx[1].getArgs.all fun elem =>
    let decl     := elem[1]
    let declKind := decl.getKind
    declKind == `Lean.Parser.Command.inductive

private def elabMutualInductive (elems : Array Syntax) : CommandElabM Unit := do
  let views ← elems.mapM fun stx => do
     let modifiers ← elabModifiers stx[0]
     inductiveSyntaxToView modifiers stx[1]
  elabInductiveViews views

/- Return true if all elements of the mutual-block are definitions/theorems/abbrevs. -/
private def isMutualDef (stx : Syntax) : Bool :=
  stx[1].getArgs.all fun elem =>
    let decl := elem[1]
    isDefLike decl

private def isMutualPreambleCommand (stx : Syntax) : Bool :=
  let k := stx.getKind
  k == ``Lean.Parser.Command.variable ||
  k == ``Lean.Parser.Command.universe ||
  k == ``Lean.Parser.Command.check ||
  k == ``Lean.Parser.Command.set_option ||
  k == ``Lean.Parser.Command.open

private partial def splitMutualPreamble (elems : Array Syntax) : Option (Array Syntax × Array Syntax) :=
  let rec loop (i : Nat) : Option (Array Syntax × Array Syntax) :=
    if h : i < elems.size then
      let elem := elems.get ⟨i, h⟩
      if isMutualPreambleCommand elem then
        loop (i+1)
      else if i == 0 then
        none -- `mutual` block does not contain any preamble commands
      else
        some (elems[0:i], elems[i:elems.size])
    else
      none -- a `mutual` block containing only preamble commands is not a valid `mutual` block
  loop 0

@[builtinMacro Lean.Parser.Command.mutual]
def expandMutualNamespace : Macro := fun stx => do
  let mut ns?      := none
  let mut elemsNew := #[]
  for elem in stx[1].getArgs do
    match ns?, expandDeclNamespace? elem with
    | _, none                         => elemsNew := elemsNew.push elem
    | none, some (ns, elem)           => ns? := some ns; elemsNew := elemsNew.push elem
    | some nsCurr, some (nsNew, elem) =>
      if nsCurr == nsNew then
        elemsNew := elemsNew.push elem
      else
        Macro.throwErrorAt elem s!"conflicting namespaces in mutual declaration, using namespace '{nsNew}', but used '{nsCurr}' in previous declaration"
  match ns? with
  | some ns =>
    let ns := mkIdentFrom stx ns
    let stxNew := stx.setArg 1 (mkNullNode elemsNew)
    `(namespace $ns:ident $stxNew end $ns:ident)
  | none => Macro.throwUnsupported

@[builtinMacro Lean.Parser.Command.mutual]
def expandMutualElement : Macro := fun stx => do
  let mut elemsNew := #[]
  let mut modified := false
  for elem in stx[1].getArgs do
    match (← expandMacro? elem) with
    | some elemNew => elemsNew := elemsNew.push elemNew; modified := true
    | none         => elemsNew := elemsNew.push elem
  if modified then
    pure $ stx.setArg 1 (mkNullNode elemsNew)
  else
    Macro.throwUnsupported

@[builtinMacro Lean.Parser.Command.mutual]
def expandMutualPreamble : Macro := fun stx =>
  match splitMutualPreamble stx[1].getArgs with
  | none => Macro.throwUnsupported
  | some (preamble, rest) => do
    let secCmd    ← `(section)
    let newMutual := stx.setArg 1 (mkNullNode rest)
    let endCmd    ← `(end)
    pure $ mkNullNode (#[secCmd] ++ preamble ++ #[newMutual] ++ #[endCmd])

@[builtinCommandElab «mutual»]
def elabMutual : CommandElab := fun stx => do
  if isMutualInductive stx then
    elabMutualInductive stx[1].getArgs
  else if isMutualDef stx then
    elabMutualDef stx[1].getArgs
  else
    throwError "invalid mutual block"

/- leading_parser "attribute " >> "[" >> sepBy1 (eraseAttr <|> Term.attrInstance) ", " >> "]" >> many1 ident -/
@[builtinCommandElab «attribute»] def elabAttr : CommandElab := fun stx => do
  let mut attrInsts := #[]
  let mut toErase := #[]
  for attrKindStx in stx[2].getSepArgs do
    if attrKindStx.getKind == ``Lean.Parser.Command.eraseAttr then
      let attrName := attrKindStx[1].getId.eraseMacroScopes
      unless isAttribute (← getEnv) attrName do
        throwError "unknown attribute [{attrName}]"
      toErase := toErase.push attrName
    else
      attrInsts := attrInsts.push attrKindStx
  let attrs ← elabAttrs attrInsts
  let idents := stx[4].getArgs
  for ident in idents do withRef ident <| liftTermElabM none do
    let declName ← resolveGlobalConstNoOverloadWithInfo ident
    Term.applyAttributes declName attrs
    for attrName in toErase do
      Attribute.erase declName attrName

def expandInitCmd (builtin : Bool) : Macro := fun stx => do
  let optVisibility := stx[0]
  let optHeader     := stx[2]
  let doSeq         := stx[3]
  let attrId        := mkIdentFrom stx $ if builtin then `builtinInit else `init
  if optHeader.isNone then
    unless optVisibility.isNone do
      Macro.throwError "invalid initialization command, 'visibility' modifer is not allowed"
    `(@[$attrId:ident]def initFn : IO Unit := do $doSeq)
  else
    let id   := optHeader[0]
    let type := optHeader[1][1]
    if optVisibility.isNone then
      `(def initFn : IO $type := do $doSeq
        @[$attrId:ident initFn] constant $id : $type)
    else if optVisibility[0].getKind == ``Parser.Command.private then
      `(def initFn : IO $type := do $doSeq
        @[$attrId:ident initFn] private constant $id : $type)
    else if optVisibility[0].getKind == ``Parser.Command.protected then
      `(def initFn : IO $type := do $doSeq
        @[$attrId:ident initFn] protected constant $id : $type)
    else
      Macro.throwError "unexpected visibility annotation"

@[builtinMacro Lean.Parser.Command.«initialize»] def expandInitialize : Macro :=
  expandInitCmd (builtin := false)

@[builtinMacro Lean.Parser.Command.«builtin_initialize»] def expandBuiltinInitialize : Macro :=
  expandInitCmd (builtin := true)

end Lean.Elab.Command