/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Gabriel Ebner, Floris van Doorn
-/
import Lean
import Std.Tactic.OpenPrivate

/-!
# Helper functions for using the simplifier.

[TODO] Needs documentation, cleanup, and possibly reunification of `mkSimpContext'` with core.
-/

open Lean Elab.Tactic

def Lean.PHashSet.toList [BEq α] [Hashable α] (s : Lean.PHashSet α) : List α :=
  s.1.toList.map (·.1)

namespace Lean

namespace Meta.DiscrTree

partial def Trie.getElements : Trie α s → Array α
  | Trie.node vs children =>
    vs ++ children.concatMap fun (_, child) ↦ child.getElements

def getElements (d : DiscrTree α s) : Array α :=
  d.1.toList.toArray.concatMap fun (_, child) => child.getElements

end Meta.DiscrTree

namespace Meta.Simp
open Elab.Tactic

instance : ToFormat SimpTheorems where
  format s :=
f!"pre:
{s.pre.getElements.toList}
post:
{s.post.getElements.toList}
lemmaNames:
{s.lemmaNames.toList.map (·.key)}
toUnfold: {s.toUnfold.toList}
erased: {s.erased.toList.map (·.key)}
toUnfoldThms: {s.toUnfoldThms.toList}"

def mkEqSymm (e : Expr) (r : Simp.Result) : MetaM Simp.Result :=
  ({ expr := e, proof? := · }) <$>
  match r.proof? with
  | none => pure none
  | some p => some <$> Meta.mkEqSymm p

def mkCast (r : Simp.Result) (e : Expr) : MetaM Expr := do
  mkAppM ``cast #[← r.getProof, e]

/-- Return all propositions in the local context. -/
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

export private mkDischargeWrapper from Lean.Elab.Tactic.Simp

-- copied from core
/--
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' (simpTheorems : SimpTheorems) (stx : Syntax) (eraseLocal : Bool)
    (kind := SimpKind.simp) (ctx := false) (ignoreStarArg : Bool := false) :
    TacticM MkSimpContextResult := do
  if ctx && !stx[2].isNone then
    if kind == SimpKind.simpAll then
      throwError "'simp_all' tactic does not support 'discharger' option"
    if kind == SimpKind.dsimp then
      throwError "'dsimp' tactic does not support 'discharger' option"
  let dischargeWrapper ← mkDischargeWrapper stx[2]
  let simpOnly := !stx[3].isNone
  let simpTheorems ← if simpOnly then
    simpOnlyBuiltins.foldlM (·.addConst ·) {}
  else
    pure simpTheorems
  let congrTheorems ← Meta.getSimpCongrTheorems
  let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) {
    config       := (← elabSimpConfig stx[1] (kind := kind))
    simpTheorems := #[simpTheorems], congrTheorems
  }
  if !r.starArg || ignoreStarArg then
    return { r with dischargeWrapper }
  else
    let mut simpTheorems := r.ctx.simpTheorems
    let hs ← getPropHyps
    for h in hs do
      unless simpTheorems.isErased (.fvar h) do
        simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr
    return { ctx := { r.ctx with simpTheorems }, dischargeWrapper }

export private checkTypeIsProp shouldPreprocess preprocess mkSimpTheoremCore
  from Lean.Meta.Tactic.Simp.SimpTheorems

/-- Similar to `mkSimpTheoremsFromConst` except that it also returns the names of the generated
lemmas.
Remark: either the length of the arrays is the same,
or the length of the first one is 0 and the length of the second one is 1. -/
def mkSimpTheoremsFromConst' (declName : Name) (post : Bool) (inv : Bool) (prio : Nat) :
  MetaM (Array Name × Array SimpTheorem) := 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 := #[]
      let mut auxNames := #[]
      for (val, type) in (← preprocess val type inv (isGlobal := true)) do
        let auxName ← mkAuxLemma cinfo.levelParams type val
        auxNames := auxNames.push auxName
        r := r.push <| ← mkSimpTheoremCore (.decl declName)
          (mkConst auxName (cinfo.levelParams.map mkLevelParam)) #[] (mkConst auxName) post prio
      return (auxNames, r)
    else
      return (#[], #[← mkSimpTheoremCore (.decl declName) (mkConst declName <|
        cinfo.levelParams.map mkLevelParam) #[] (mkConst declName) post prio])

/-- Similar to `addSimpTheorem` except that it returns an array of all auto-generated
  simp-theorems. -/
def addSimpTheorem' (ext : SimpExtension) (declName : Name) (post : Bool) (inv : Bool)
  (attrKind : AttributeKind) (prio : Nat) : MetaM (Array Name) := do
  let (auxNames, simpThms) ← mkSimpTheoremsFromConst' declName post inv prio
  for simpThm in simpThms do
    ext.add (SimpEntry.thm simpThm) attrKind
  return auxNames

/-- Similar to `AttributeImpl.add` in `mkSimpAttr` except that it doesn't require syntax,
  and returns an array of all auto-generated lemmas. -/
def addSimpAttr (declName : Name) (ext : SimpExtension) (attrKind : AttributeKind)
  (post : Bool) (prio : Nat) :
    MetaM (Array Name) := do
  let info ← getConstInfo declName
  if (← isProp info.type) then
    addSimpTheorem' ext declName post (inv := false) attrKind prio
  else if info.hasValue then
    if let some eqns ← getEqnsFor? declName then
      let mut auxNames := #[]
      for eqn in eqns do
        -- Is this list is always empty?
        let newAuxNames ← addSimpTheorem' ext eqn post (inv := false) attrKind prio
        auxNames := auxNames ++ newAuxNames
      ext.add (SimpEntry.toUnfoldThms declName eqns) attrKind
      if hasSmartUnfoldingDecl (← getEnv) declName then
        ext.add (SimpEntry.toUnfold declName) attrKind
      return auxNames
    else
      ext.add (SimpEntry.toUnfold declName) attrKind
      return #[]
  else
    throwError "invalid 'simp', it is not a proposition nor a definition (to unfold)"

/-- Similar to `AttributeImpl.add` in `mkSimpAttr` except that it returns an array of all
  auto-generated lemmas. -/
def addSimpAttrFromSyntax (declName : Name) (ext : SimpExtension) (attrKind : AttributeKind)
  (stx : Syntax) : MetaM (Array Name) := do
  let post := if stx[1].isNone then true else stx[1][0].getKind == ``Lean.Parser.Tactic.simpPost
  let prio ← getAttrParamOptPrio stx[2]
  addSimpAttr declName ext attrKind post prio

end Simp

/-- Construct a `SimpTheorems` from a list of names. (i.e. as with `simp only`). -/
def simpTheoremsOfNames (lemmas : List Name) : MetaM SimpTheorems := do
  lemmas.foldlM (·.addConst ·) (← simpOnlyBuiltins.foldlM (·.addConst ·) {})

/-- Simplify an expression using only a list of lemmas specified by name. -/
-- TODO We need to write a `mkSimpContext` in `MetaM`
-- that supports all the bells and whistles in `simp`.
-- It should generalize this, and another partial implementation in `Tactic.Simps.Basic`.
def simpOnlyNames (lemmas : List Name) (e : Expr) (config : Simp.Config := {}) :
    MetaM Simp.Result := do
  (·.1) <$> simp e
    { simpTheorems := #[← simpTheoremsOfNames lemmas], congrTheorems := ← getSimpCongrTheorems,
      config := config }

/--
Given a simplifier `S : Expr → MetaM Simp.Result`,
and an expression `e : Expr`, run `S` on the type of `e`, and then
convert `e` into that simplified type, using a combination of type hints and `Eq.mp`.
-/
def simpType (S : Expr → MetaM Simp.Result) (e : Expr) : MetaM Expr := do
  match (← S (← inferType e)) with
  | ⟨ty', none, _⟩ => mkExpectedTypeHint e ty'
  -- We use `mkExpectedTypeHint` in this branch as well, in order to preserve the binder types.
  | ⟨ty', some prf, _⟩ => mkExpectedTypeHint (← mkEqMP prf e) ty'

/-- Independently simplify both the left-hand side and the right-hand side
of an equality. The equality is allowed to be under binders.
Returns the simplified equality and a proof of it. -/
def simpEq (S : Expr → MetaM Simp.Result) (type pf : Expr) : MetaM (Expr × Expr) := do
  forallTelescope type fun fvars type => do
    let .app (.app (.app (.const `Eq [u]) α) lhs) rhs := type | throwError "simpEq expecting Eq"
    let ⟨lhs', lhspf?, _⟩ ← S lhs
    let ⟨rhs', rhspf?, _⟩ ← S rhs
    let mut pf' := mkAppN pf fvars
    if let some lhspf := lhspf? then
      pf' ← mkEqTrans (← mkEqSymm lhspf) pf'
    if let some rhspf := rhspf? then
      pf' ← mkEqTrans pf' rhspf
    let type' := mkApp3 (mkConst ``Eq [u]) α lhs' rhs'
    return (← mkForallFVars fvars type', ← mkLambdaFVars fvars pf')

/-- Checks whether `declName` is in `SimpTheorems` as either a lemma or definition to unfold. -/
def SimpTheorems.contains (d : SimpTheorems) (declName : Name) :=
  d.isLemma (.decl declName) || d.isDeclToUnfold declName

/-- Tests whether `decl` has `simp`-attribute `simpAttr`. Returns `false` is `simpAttr` is not a
valid simp-attribute. -/
def isInSimpSet (simpAttr decl : Name) : CoreM Bool := do
  let .some simpDecl ← getSimpExtension? simpAttr | return false
  return (← simpDecl.getTheorems).contains decl

/-- Returns all declarations with the `simp`-attribute `simpAttr`.
  Note: this also returns many auxiliary declarations. -/
def getAllSimpDecls (simpAttr : Name) : CoreM (List Name) := do
  let .some simpDecl ← getSimpExtension? simpAttr | return []
  let thms ← simpDecl.getTheorems
  return thms.toUnfold.toList ++ thms.lemmaNames.toList.filterMap fun
    | .decl decl => some decl
    | _ => none

/-- Gets all simp-attributes given to declaration `decl`. -/
def getAllSimpAttrs (decl : Name) : CoreM (Array Name) := do
  let mut simpAttrs := #[]
  for (simpAttr, simpDecl) in (← simpExtensionMapRef.get).toList do
    if (← simpDecl.getTheorems).contains decl then
      simpAttrs := simpAttrs.push simpAttr
  return simpAttrs

end Lean.Meta


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.lint.default
import Mathlib.tactic.ext
import Mathlib.tactic.simps
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

namespace subtype

/-- See Note [custom simps projection] -/
def simps.val {α : Sort u_1} {p : α → Prop} (x : Subtype p) : α := ↑x

/-- A version of `x.property` or `x.2` where `p` is syntactically applied to the coercion of `x`
  instead of `x.1`. A similar result is `subtype.mem` in `data.set.basic`. -/
theorem prop {α : Sort u_1} {p : α → Prop} (x : Subtype p) : p ↑x := property x

@[simp] theorem val_eq_coe {α : Sort u_1} {p : α → Prop} {x : Subtype p} : val x = ↑x := rfl

@[simp] protected theorem forall {α : Sort u_1} {p : α → Prop}
    {q : (Subtype fun (a : α) => p a) → Prop} :
    (∀ (x : Subtype fun (a : α) => p a), q x) ↔
        ∀ (a : α) (b : p a), q { val := a, property := b } :=
  sorry

/-- An alternative version of `subtype.forall`. This one is useful if Lean cannot figure out `q`
  when using `subtype.forall` from right to left. -/
protected theorem forall' {α : Sort u_1} {p : α → Prop} {q : (x : α) → p x → Prop} :
    (∀ (x : α) (h : p x), q x h) ↔ ∀ (x : Subtype fun (a : α) => p a), q (↑x) (property x) :=
  iff.symm subtype.forall

@[simp] protected theorem exists {α : Sort u_1} {p : α → Prop}
    {q : (Subtype fun (a : α) => p a) → Prop} :
    (∃ (x : Subtype fun (a : α) => p a), q x) ↔
        ∃ (a : α), ∃ (b : p a), q { val := a, property := b } :=
  sorry

protected theorem ext {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x}
    {a2 : Subtype fun (x : α) => p x} : ↑a1 = ↑a2 → a1 = a2 :=
  sorry

theorem ext_iff {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x}
    {a2 : Subtype fun (x : α) => p x} : a1 = a2 ↔ ↑a1 = ↑a2 :=
  { mp := congr_arg fun {a1 : Subtype fun (x : α) => p x} => ↑a1, mpr := subtype.ext }

theorem heq_iff_coe_eq {α : Sort u_1} {p : α → Prop} {q : α → Prop} (h : ∀ (x : α), p x ↔ q x)
    {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => q x} : a1 == a2 ↔ ↑a1 = ↑a2 :=
  Eq._oldrec (fun (a2' : Subtype fun (x : α) => p x) => iff.trans heq_iff_eq ext_iff)
    (funext fun (x : α) => propext (h x)) a2

theorem ext_val {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x}
    {a2 : Subtype fun (x : α) => p x} : val a1 = val a2 → a1 = a2 :=
  subtype.ext

theorem ext_iff_val {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x}
    {a2 : Subtype fun (x : α) => p x} : a1 = a2 ↔ val a1 = val a2 :=
  ext_iff

@[simp] theorem coe_eta {α : Sort u_1} {p : α → Prop} (a : Subtype fun (a : α) => p a) (h : p ↑a) :
    { val := ↑a, property := h } = a :=
  subtype.ext rfl

@[simp] theorem coe_mk {α : Sort u_1} {p : α → Prop} (a : α) (h : p a) :
    ↑{ val := a, property := h } = a :=
  rfl

@[simp] theorem mk_eq_mk {α : Sort u_1} {p : α → Prop} {a : α} {h : p a} {a' : α} {h' : p a'} :
    { val := a, property := h } = { val := a', property := h' } ↔ a = a' :=
  ext_iff

theorem coe_eq_iff {α : Sort u_1} {p : α → Prop} {a : Subtype fun (a : α) => p a} {b : α} :
    ↑a = b ↔ ∃ (h : p b), a = { val := b, property := h } :=
  sorry

theorem coe_injective {α : Sort u_1} {p : α → Prop} : function.injective coe :=
  fun (a b : Subtype p) => subtype.ext

theorem val_injective {α : Sort u_1} {p : α → Prop} : function.injective val := coe_injective

/-- Restrict a (dependent) function to a subtype -/
def restrict {α : Sort u_1} {β : α → Type u_2} (f : (x : α) → β x) (p : α → Prop) (x : Subtype p) :
    β (val x) :=
  f ↑x

theorem restrict_apply {α : Sort u_1} {β : α → Type u_2} (f : (x : α) → β x) (p : α → Prop)
    (x : Subtype p) : restrict f p x = f (val x) :=
  Eq.refl (restrict f p x)

theorem restrict_def {α : Sort u_1} {β : Type u_2} (f : α → β) (p : α → Prop) :
    restrict f p = f ∘ coe :=
  Eq.refl (restrict f p)

theorem restrict_injective {α : Sort u_1} {β : Type u_2} {f : α → β} (p : α → Prop)
    (h : function.injective f) : function.injective (restrict f p) :=
  function.injective.comp h coe_injective

/-- Defining a map into a subtype, this can be seen as an "coinduction principle" of `subtype`-/
def coind {α : Sort u_1} {β : Sort u_2} (f : α → β) {p : β → Prop} (h : ∀ (a : α), p (f a)) :
    α → Subtype p :=
  fun (a : α) => { val := f a, property := h a }

theorem coind_injective {α : Sort u_1} {β : Sort u_2} {f : α → β} {p : β → Prop}
    (h : ∀ (a : α), p (f a)) (hf : function.injective f) : function.injective (coind f h) :=
  fun (x y : α) (hxy : coind f h x = coind f h y) => hf (congr_arg val hxy)

theorem coind_surjective {α : Sort u_1} {β : Sort u_2} {f : α → β} {p : β → Prop}
    (h : ∀ (a : α), p (f a)) (hf : function.surjective f) : function.surjective (coind f h) :=
  sorry

theorem coind_bijective {α : Sort u_1} {β : Sort u_2} {f : α → β} {p : β → Prop}
    (h : ∀ (a : α), p (f a)) (hf : function.bijective f) : function.bijective (coind f h) :=
  { left := coind_injective h (and.left hf), right := coind_surjective h (and.right hf) }

/-- Restriction of a function to a function on subtypes. -/
@[simp] theorem map_coe {α : Sort u_1} {β : Sort u_2} {p : α → Prop} {q : β → Prop} (f : α → β)
    (h : ∀ (a : α), p a → q (f a)) : ∀ (ᾰ : Subtype p), ↑(map f h ᾰ) = f ↑ᾰ :=
  fun (ᾰ : Subtype p) => Eq.refl ↑(map f h ᾰ)

theorem map_comp {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {p : α → Prop} {q : β → Prop}
    {r : γ → Prop} {x : Subtype p} (f : α → β) (h : ∀ (a : α), p a → q (f a)) (g : β → γ)
    (l : ∀ (a : β), q a → r (g a)) :
    map g l (map f h x) = map (g ∘ f) (fun (a : α) (ha : p a) => l (f a) (h a ha)) x :=
  rfl

theorem map_id {α : Sort u_1} {p : α → Prop} {h : ∀ (a : α), p a → p (id a)} : map id h = id :=
  sorry

theorem map_injective {α : Sort u_1} {β : Sort u_2} {p : α → Prop} {q : β → Prop} {f : α → β}
    (h : ∀ (a : α), p a → q (f a)) (hf : function.injective f) : function.injective (map f h) :=
  coind_injective (fun (x : Subtype fun (a : α) => p a) => map._proof_1 f h x)
    (function.injective.comp hf coe_injective)

theorem map_involutive {α : Sort u_1} {p : α → Prop} {f : α → α} (h : ∀ (a : α), p a → p (f a))
    (hf : function.involutive f) : function.involutive (map f h) :=
  fun (x : Subtype fun (a : α) => p a) => subtype.ext (hf ↑x)

protected instance has_equiv {α : Sort u_1} [has_equiv α] (p : α → Prop) : has_equiv (Subtype p) :=
  has_equiv.mk fun (s t : Subtype p) => ↑s ≈ ↑t

theorem equiv_iff {α : Sort u_1} [has_equiv α] {p : α → Prop} {s : Subtype p} {t : Subtype p} :
    s ≈ t ↔ ↑s ≈ ↑t :=
  iff.rfl

protected theorem refl {α : Sort u_1} {p : α → Prop} [setoid α] (s : Subtype p) : s ≈ s :=
  setoid.refl ↑s

protected theorem symm {α : Sort u_1} {p : α → Prop} [setoid α] {s : Subtype p} {t : Subtype p}
    (h : s ≈ t) : t ≈ s :=
  setoid.symm h

protected theorem trans {α : Sort u_1} {p : α → Prop} [setoid α] {s : Subtype p} {t : Subtype p}
    {u : Subtype p} (h₁ : s ≈ t) (h₂ : t ≈ u) : s ≈ u :=
  setoid.trans h₁ h₂

theorem equivalence {α : Sort u_1} [setoid α] (p : α → Prop) : equivalence has_equiv.equiv :=
  mk_equivalence has_equiv.equiv subtype.refl subtype.symm subtype.trans

protected instance setoid {α : Sort u_1} [setoid α] (p : α → Prop) : setoid (Subtype p) :=
  setoid.mk has_equiv.equiv (equivalence p)

end subtype

namespace subtype

/-! Some facts about sets, which require that `α` is a type. -/

@[simp] theorem coe_prop {α : Type u_1} {S : set α} (a : Subtype fun (a : α) => a ∈ S) : ↑a ∈ S :=
  prop a

theorem val_prop {α : Type u_1} {S : set α} (a : Subtype fun (a : α) => a ∈ S) : val a ∈ S :=
  property a

end Mathlib


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Monad encapsulating continuation passing programming style, similar to
Haskell's `Cont`, `ContT` and `MonadCont`:
<http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Cont.html>
-/
import control.monad.writer

universes u v w u₀ u₁ v₀ v₁

structure monad_cont.label (α : Type w) (m : Type u → Type v) (β : Type u) :=
(apply : α → m β)

def monad_cont.goto {α β} {m : Type u → Type v} (f : monad_cont.label α m β) (x : α) := f.apply x

class monad_cont (m : Type u → Type v) :=
(call_cc : Π {α β}, ((monad_cont.label α m β) → m α) → m α)

open monad_cont

class is_lawful_monad_cont (m : Type u → Type v) [monad m] [monad_cont m]
extends is_lawful_monad m :=
(call_cc_bind_right {α ω γ} (cmd : m α) (next : (label ω m γ) → α → m ω) :
  call_cc (λ f, cmd >>= next f) = cmd >>= λ x, call_cc (λ f, next f x))
(call_cc_bind_left {α} (β) (x : α) (dead : label α m β → β → m α) :
  call_cc (λ f : label α m β, goto f x >>= dead f) = pure x)
(call_cc_dummy {α β} (dummy : m α) :
  call_cc (λ f : label α m β, dummy) = dummy)

export is_lawful_monad_cont

def cont_t (r : Type u) (m : Type u → Type v) (α : Type w) := (α → m r) → m r

@[reducible] def cont (r : Type u) (α : Type w) := cont_t r id α

namespace cont_t

export monad_cont (label goto)

variables {r : Type u} {m : Type u → Type v} {α β γ ω : Type w}

def run : cont_t r m α → (α → m r) → m r := id

def map (f : m r → m r) (x : cont_t r m α) : cont_t r m α := f ∘ x

lemma run_cont_t_map_cont_t (f : m r → m r) (x : cont_t r m α) :
  run (map f x) = f ∘ run x := rfl

def with_cont_t (f : (β → m r) → α → m r) (x : cont_t r m α) : cont_t r m β :=
λ g, x $ f g

lemma run_with_cont_t (f : (β → m r) → α → m r) (x : cont_t r m α) :
  run (with_cont_t f x) = run x ∘ f := rfl

@[ext]
protected lemma ext {x y : cont_t r m α}
  (h : ∀ f, x.run f = y.run f) :
  x = y := by { ext; apply h }

instance : monad (cont_t r m) :=
{ pure := λ α x f, f x,
  bind := λ α β x f g, x $ λ i, f i g }

instance : is_lawful_monad (cont_t r m) :=
{ id_map := by { intros, refl },
  pure_bind := by { intros, ext, refl },
  bind_assoc := by { intros, ext, refl } }

def monad_lift [monad m] {α} : m α → cont_t r m α :=
λ x f, x >>= f

instance [monad m] : has_monad_lift m (cont_t r m) :=
{ monad_lift := λ α, cont_t.monad_lift }

lemma monad_lift_bind [monad m] [is_lawful_monad m] {α β} (x : m α) (f : α → m β) :
  (monad_lift (x >>= f) : cont_t r m β) = monad_lift x >>= monad_lift ∘ f :=
begin
  ext,
  simp only [monad_lift,has_monad_lift.monad_lift,(∘),(>>=),bind_assoc,id.def,run,cont_t.monad_lift]
end

instance : monad_cont (cont_t r m) :=
{ call_cc := λ α β f g, f ⟨λ x h, g x⟩ g }

instance : is_lawful_monad_cont (cont_t r m) :=
{ call_cc_bind_right := by intros; ext; refl,
  call_cc_bind_left := by intros; ext; refl,
  call_cc_dummy := by intros; ext; refl }

instance (ε) [monad_except ε m] : monad_except ε (cont_t r m) :=
{ throw := λ x e f, throw e,
  catch := λ α act h f, catch (act f) (λ e, h e f) }

instance : monad_run (λ α, (α → m r) → ulift.{u v} (m r)) (cont_t.{u v u} r m) :=
{ run := λ α f x, ⟨ f x ⟩ }

end cont_t

variables {m : Type u → Type v} [monad m]

def except_t.mk_label {α β ε} : label (except.{u u} ε α) m β → label α (except_t ε m) β
| ⟨ f ⟩ := ⟨ λ a, monad_lift $ f (except.ok a) ⟩

lemma except_t.goto_mk_label {α β ε : Type*} (x : label (except.{u u} ε α) m β) (i : α) :
  goto (except_t.mk_label x) i = ⟨ except.ok <$> goto x (except.ok i) ⟩ := by cases x; refl

def except_t.call_cc
  {ε} [monad_cont m] {α β : Type*} (f : label α (except_t ε m) β → except_t ε m α) :
  except_t ε m α :=
except_t.mk (call_cc $ λ x : label _ m β, except_t.run $ f (except_t.mk_label x) : m (except ε α))

instance {ε} [monad_cont m] : monad_cont (except_t ε m) :=
{ call_cc := λ α β, except_t.call_cc }

instance {ε} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (except_t ε m) :=
{ call_cc_bind_right := by { intros, simp [call_cc,except_t.call_cc,call_cc_bind_right], ext, dsimp,
    congr' with ⟨ ⟩; simp [except_t.bind_cont,@call_cc_dummy m _], },
  call_cc_bind_left  := by { intros,
    simp [call_cc,except_t.call_cc,call_cc_bind_right,except_t.goto_mk_label,map_eq_bind_pure_comp,
      bind_assoc,@call_cc_bind_left m _], ext, refl },
  call_cc_dummy := by { intros, simp [call_cc,except_t.call_cc,@call_cc_dummy m _], ext, refl }, }

def option_t.mk_label {α β} : label (option.{u} α) m β → label α (option_t m) β
| ⟨ f ⟩ := ⟨ λ a, monad_lift $ f (some a) ⟩

lemma option_t.goto_mk_label {α β : Type*} (x : label (option.{u} α) m β) (i : α) :
  goto (option_t.mk_label x) i = ⟨ some <$> goto x (some i) ⟩ := by cases x; refl

def option_t.call_cc [monad_cont m] {α β : Type*} (f : label α (option_t m) β → option_t m α) :
  option_t m α :=
option_t.mk (call_cc $ λ x : label _ m β, option_t.run $ f (option_t.mk_label x) : m (option α))

instance [monad_cont m] : monad_cont (option_t m) :=
{ call_cc := λ α β, option_t.call_cc }

instance [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (option_t m) :=
{ call_cc_bind_right := by { intros, simp [call_cc,option_t.call_cc,call_cc_bind_right], ext, dsimp,
    congr' with ⟨ ⟩; simp [option_t.bind_cont,@call_cc_dummy m _], },
  call_cc_bind_left  := by { intros, simp [call_cc,option_t.call_cc,call_cc_bind_right,
    option_t.goto_mk_label,map_eq_bind_pure_comp,bind_assoc,@call_cc_bind_left m _], ext, refl },
  call_cc_dummy := by { intros, simp [call_cc,option_t.call_cc,@call_cc_dummy m _], ext, refl }, }

def writer_t.mk_label {α β ω} [has_one ω] : label (α × ω) m β → label α (writer_t ω m) β
| ⟨ f ⟩ := ⟨ λ a, monad_lift $ f (a,1) ⟩

lemma writer_t.goto_mk_label {α β ω : Type*} [has_one ω] (x : label (α × ω) m β) (i : α) :
  goto (writer_t.mk_label x) i = monad_lift (goto x (i,1)) := by cases x; refl

def writer_t.call_cc [monad_cont m] {α β ω : Type*} [has_one ω]
  (f : label α (writer_t ω m) β → writer_t ω m α) : writer_t ω m α :=
⟨ call_cc (writer_t.run ∘ f ∘ writer_t.mk_label : label (α × ω) m β → m (α × ω)) ⟩

instance (ω) [monad m] [has_one ω] [monad_cont m] : monad_cont (writer_t ω m) :=
{ call_cc := λ α β, writer_t.call_cc }

def state_t.mk_label {α β σ : Type u} : label (α × σ) m (β × σ) → label α (state_t σ m) β
| ⟨ f ⟩ := ⟨ λ a, ⟨ λ s, f (a,s) ⟩ ⟩

lemma state_t.goto_mk_label {α β σ : Type u} (x : label (α × σ) m (β × σ)) (i : α) :
  goto (state_t.mk_label x) i = ⟨ λ s, (goto x (i,s)) ⟩ := by cases x; refl

def state_t.call_cc {σ}  [monad_cont m] {α β : Type*}
  (f : label α (state_t σ m) β → state_t σ m α) : state_t σ m α :=
⟨ λ r, call_cc (λ f', (f $ state_t.mk_label f').run r) ⟩

instance {σ} [monad_cont m] : monad_cont (state_t σ m) :=
{ call_cc := λ α β, state_t.call_cc }

instance {σ} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (state_t σ m) :=
{ call_cc_bind_right := by { intros,
    simp [call_cc,state_t.call_cc,call_cc_bind_right,(>>=),state_t.bind], ext, dsimp,
    congr' with ⟨x₀,x₁⟩, refl },
  call_cc_bind_left  := by { intros, simp [call_cc,state_t.call_cc,call_cc_bind_left,(>>=),
    state_t.bind,state_t.goto_mk_label], ext, refl },
  call_cc_dummy := by { intros, simp [call_cc,state_t.call_cc,call_cc_bind_right,(>>=),
    state_t.bind,@call_cc_dummy m _], ext, refl }, }

def reader_t.mk_label {α β} (ρ) : label α m β → label α (reader_t ρ m) β
| ⟨ f ⟩ := ⟨ monad_lift ∘ f ⟩

lemma reader_t.goto_mk_label {α ρ β} (x : label α m β) (i : α) :
  goto (reader_t.mk_label ρ x) i = monad_lift (goto x i) := by cases x; refl

def reader_t.call_cc {ε}  [monad_cont m] {α β : Type*}
  (f : label α (reader_t ε m) β → reader_t ε m α) : reader_t ε m α :=
⟨ λ r, call_cc (λ f', (f $ reader_t.mk_label _ f').run r) ⟩

instance {ρ} [monad_cont m] : monad_cont (reader_t ρ m) :=
{ call_cc := λ α β, reader_t.call_cc }

instance {ρ} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (reader_t ρ m) :=
{ call_cc_bind_right :=
    by { intros, simp [call_cc,reader_t.call_cc,call_cc_bind_right], ext, refl },
  call_cc_bind_left  := by { intros, simp [call_cc,reader_t.call_cc,call_cc_bind_left,
    reader_t.goto_mk_label], ext, refl },
  call_cc_dummy := by { intros, simp [call_cc,reader_t.call_cc,@call_cc_dummy m _], ext, refl } }

/-- reduce the equivalence between two continuation passing monads to the equivalence between
their underlying monad -/
def cont_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁}
  {α₁ r₁ : Type u₀} {α₂ r₂ : Type u₁} (F : m₁ r₁ ≃ m₂ r₂) (G : α₁ ≃ α₂) :
  cont_t r₁ m₁ α₁ ≃ cont_t r₂ m₂ α₂ :=
{ to_fun := λ f r, F $ f $ λ x, F.symm $ r $ G x,
  inv_fun := λ f r, F.symm $ f $ λ x, F $ r $ G.symm x,
  left_inv := λ f, by funext r; simp,
  right_inv := λ f, by funext r; simp }


import ReactorModel.Determinism.State

open Classical ReactorType Indexable

namespace Execution
namespace Instantaneous
namespace Step

variable [Indexable α] {s₁ s₂ : State α}

theorem rcn_not_mem_progress (e : s₁ ⇓ᵢ s₂) : e.rcn ∉ s₁.progress :=
  sorry -- e.allows.unprocessed

theorem preserves_tag (e : s₁ ⇓ᵢ s₂) : s₁.tag = s₂.tag :=
  sorry -- e.exec.preserves_tag

theorem mem_progress_iff :
  (e : s₁ ⇓ᵢ s₂) → (rcn' ∈ s₂.progress ↔ rcn' = e.rcn ∨ rcn' ∈ s₁.progress) := by
  intro h
  constructor
  case mp =>
    intro ho
    by_cases hc : rcn' = h.rcn
    case pos => exact .inl hc
    case neg => sorry
      -- rw [State.progress, h.exec.ctx_adds_rcn, ←rcn] at ho
      -- simp [Context.mem_record_progress_iff _ _ _ |>.mp ho]
  case mpr =>
    intro ho
    by_cases hc : rcn' = h.rcn
    case pos =>
      simp [hc]
      sorry
      -- exact Context.mem_record_progress_iff _ _ _ |>.mpr (.inl rfl)
    case neg =>
      sorry
      -- simp [State.progress, h.exec.ctx_adds_rcn, Context.mem_record_progress_iff _ _ _ |>.mpr (.inr $ ho.resolve_left hc)]

-- Corollary of `InstStep.mem_progress_iff`.
theorem not_mem_progress :
  (e : s₁ ⇓ᵢ s₂) → (rcn' ≠ e.rcn) → rcn' ∉ s₁.progress → rcn' ∉ s₂.progress :=
  sorry -- λ h hn hm => (mt h.mem_progress.mp) $ not_or.mpr ⟨hn, hm⟩

-- Corollary of `InstStep.mem_progress`.
theorem monotonic_progress : (s₁ ⇓ᵢ s₂) → rcn' ∈ s₁.progress → rcn' ∈ s₂.progress :=
  sorry -- (·.mem_progress_iff.mpr $ .inr ·)

-- Corollary of `InstStep.mem_progress`.
theorem rcn_mem_progress : (e : s₁ ⇓ᵢ s₂) → e.rcn ∈ s₂.progress :=
  (·.mem_progress_iff.mpr $ .inl rfl)

theorem Skip.equiv : (s₁ ⇓ₛ s₂) → s₁.rtr ≈ s₂.rtr
  | mk .. => .refl

theorem Skip.progress_eq : (e : s₁ ⇓ₛ s₂) → s₂.progress = s₁.progress.insert e.rcn
  | mk .. => rfl

theorem Skip.progress_mono (e : s₁ ⇓ₛ s₂) : s₁.progress ⊆ s₂.progress := by
  simp [e.progress_eq]
  apply Set.subset_insert

theorem Skip.triggers_iff (e : s₁ ⇓ₛ s₂) : (s₁.Triggers i) ↔ (s₂.Triggers i) := by
  cases e
  case mk rcn _ _ =>
    constructor
    all_goals
      intro h
      sorry -- exact h.progress_agnostic (s₁.record_preserves_rtr rcn) (s₁.record_preserves_tag rcn) |>.choose_spec

theorem Skip.mem_progress_iff (e : s₁ ⇓ₛ s₂) :
    (rcn' ∈ s₂.progress) ↔ (rcn' = e.rcn ∨ rcn' ∈ s₁.progress) := by
  sorry

theorem Skip.preserves_allows_indep (e₁ : s₁ ⇓ₛ s₂) (e₂ : s₂ ⇓ₛ s₃) (h : e₁.rcn ≮[s₁.rtr] e₂.rcn) :
    s₁.Allows e₂.rcn where
  mem := sorry
  unprocessed := Set.not_mem_subset e₁.progress_mono $ e₂.allows_rcn.unprocessed
  deps := by
    intro i hi
    have h' := equiv_eq_dependencies e₁.equiv |>.symm ▸ e₂.allows_rcn.deps
    refine e₁.mem_progress_iff.mp (h' hi) |>.resolve_left ?_
    intro hc; subst hc; contradiction

set_option pp.proofs.withType false
theorem Skip.swap_indep_skip (e₁ : s₁ ⇓ₛ s₂) (e₂ : s₂ ⇓ₛ s₃) (h : e₁.rcn ≮[s₁.rtr] e₂.rcn) :
    ∃ (s₂' : _) (f₁ : s₁ ⇓ₛ s₂') (f₂ : s₂' ⇓ₛ s₃), (f₁.rcn = e₂.rcn) ∧ (f₂.rcn = e₁.rcn) := by
  have ha := e₁.preserves_allows_indep e₂ h
  have ht := e₁.triggers_iff.not.mpr e₂.not_triggers
  have e₁' := Skip.mk ha ht
  simp at e₁'
  exists _, e₁'
  sorry -- TODO: This is super annoying. Is there a better way to approach this?
        --       Do we need more preservation theorems for `Allows` and `Triggers` first?

theorem Skip.swap_indep_exec (e₁ : s₁ ⇓ₛ s₂) (e₂ : s₂ ⇓ₑ s₃) (h : e₁.rcn ≮[s₁.rtr] e₂.rcn) :
    ∃ (s₂' : _) (f₁ : s₁ ⇓ₑ s₂') (f₂ : s₂' ⇓ₛ s₃), (f₁.rcn = e₂.rcn) ∧ (f₂.rcn = e₁.rcn) := by
  sorry

theorem Skip.swap_indep (e₁ : s₁ ⇓ₛ s₂) (e₂ : s₂ ⇓ᵢ s₃) (h : e₁.rcn ≮[s₁.rtr] e₂.rcn) :
    ∃ (s₂' : _) (f₁ : s₁ ⇓ᵢ s₂') (f₂ : s₂' ⇓ₛ s₃), (f₁.rcn = e₂.rcn) ∧ (f₂.rcn = e₁.rcn) := by
  cases e₂
  case skip e₂ =>
    have ⟨_, e₁', e₂', _⟩ := e₁.swap_indep_skip e₂ h
    exists _, skip e₁', e₂'
  case exec e₂ =>
    have ⟨_, e₁', e₂', _⟩ := e₁.swap_indep_exec e₂ h
    exists _, exec e₁', e₂'

theorem Exec.equiv : (s₁ ⇓ₑ s₂) → s₁.rtr ≈ s₂.rtr
  | mk .. => by simp [State.record_preserves_rtr, s₁.exec_equiv]

theorem Exec.progress_eq : (e : s₁ ⇓ₑ s₂) → s₂.progress = s₁.progress.insert e.rcn
  | mk .. => rfl

theorem not_Closed (e : s₁ ⇓ᵢ s₂) : ¬s₁.Closed := by
  intro c
  have h := c ▸ e.allows_rcn.unprocessed
  simp [Partial.mem_iff] at h
  sorry -- have := h e.allows.mem.choose
  -- contradiction

theorem equiv : (s₁ ⇓ᵢ s₂) → s₁.rtr ≈ s₂.rtr
  | skip e | exec e => e.equiv

theorem deterministic (e₁ : s ⇓ᵢ s₁) (e₂ : s ⇓ᵢ s₂) (h : e₁.rcn = e₂.rcn) : s₁ = s₂ := by
  cases e₁ <;> cases e₂
  all_goals
    case _ e₁ e₂ =>
      cases e₁; cases e₂
      simp [rcn] at h
      subst h
      first | rfl | contradiction

theorem acyclic (e : s₁ ⇓ᵢ s₂) : e.rcn ≮[s₁.rtr] e.rcn :=
  e.allows_rcn.acyclic

theorem progress_eq : (e : s₁ ⇓ᵢ s₂) → s₂.progress = s₁.progress.insert e.rcn
  | skip e | exec e => e.progress_eq

/-
By cases on e₁ and e₂:
(1) skip.skip:
    then both didn't trigger and nothing about the reactors changed, so it is easy to show that
    switching the order preserves non-triggering.

(2)&(3) exec.skip and skip.exec:
        using `preserves_triggers` it should be easy

(4) exec.exec:
    reduces to a theorem on State.exec?
-/
theorem prepend_indep (e₁ : s₁ ⇓ᵢ s₂) (e₂ : s₂ ⇓ᵢ s₃) (h : e₁.rcn ≮[s₁.rtr] e₂.rcn) :
    ∃ (s₂' : _) (e₁' : s₁ ⇓ᵢ s₂') (e₂' : s₂' ⇓ᵢ s₃), e₁'.rcn = e₂.rcn ∧ e₂'.rcn = e₁.rcn := by
  cases e₁
  case skip e₁ =>
    have ⟨_, e₁', e₂', _⟩ := e₁.swap_indep e₂ h
    exists _, e₁', skip e₂'
  case exec e₁ =>
    sorry

end Step
end Instantaneous
end Execution


import polytime.lemmas
import complexity_class.dependent

namespace polytime

open_locale complexity_class
open tencodable function polysize

variables {α β γ δ ε η : Type} [tencodable α] [tencodable β] [tencodable γ]
 [tencodable δ] [tencodable ε] [tencodable η]

@[complexity] lemma list_len : (@list.length α) ∈ₑ PTIME :=
begin
  complexity using λ x, (encode x).stack_rec (λ _ : unit, 0) (λ _ _ _, ()) (λ _ _ _, ())
    (λ _ ih _ _ _, ih + 1) (),
  induction x with hd tl ih, { refl, },
  simpa [encode_cons],
end

@[simp] def scanl_step {α β : Type*} (f : β → α → β) : list α × list β → list α × list β
| ((x :: xs), (y :: ys)) := (xs, f y x :: y :: ys)
| x := x

@[complexity] theorem scanl_step_polytime {f : γ → β → α → β} {st : γ → list α × list β} (hf : f ∈ₑ PTIME) (hst : st ∈ₑ PTIME) :
  (λ x, scanl_step (f x) (st x)) ∈ₑ PTIME :=
by { delta scanl_step, clean_target, complexity, }

theorem scanl_step_iterate' {α : Type*} (f : β → α → β) (l : list α) (x : β) (n : ℕ) :
  (scanl_step f)^[n] (l, [x]) = (l.drop n, ((l.scanl f x).take (n + 1)).reverse) :=
begin
  suffices : ∀ xs, (scanl_step f)^[n] (l, x :: xs) = (l.drop n, ((l.scanl f x).take (n + 1)).reverse ++ xs),
  { simpa using this [], },
  intro xs,
  induction l with hd tl ih generalizing x xs n, { rw iterate_fixed; simp, },
  cases n, { simp, }, { simp [ih], },
end

theorem scanl_step_iterate {α : Type*} (f : β → α → β) (l : list α) (x : β) :
  (scanl_step f)^[l.length] (l, [x]) = ([], (l.scanl f x).reverse) :=
by { rw [scanl_step_iterate', ← @list.length_scanl _ _ f x l], simp, }

lemma list_scanl_rev' [polysize α] [polysize β] [polysize γ] {lst : γ → list α} {acc : γ → β} {f : γ → β → α → β}
  (hlst : lst ∈ₑ PTIME) (hacc : acc ∈ₑ PTIME) (hf : f ∈ₑ PTIME)
  (hf' : polysize_fun (λ (ls : list α) (x), ls.foldl (f x) (acc x))) :
  polytime.mem (λ x : γ, ((lst x).scanl (f x) (acc x)).reverse) :=
begin
  convert_to polytime.mem (λ x, ((scanl_step (f x))^[(lst x).length] (lst x, [acc x])).2),
  { simp [scanl_step_iterate], },
  refine complexity_class.mem.snd.comp _,
  apply iterate, complexity,
  cases hf' with pf hpf, cases polytime.size_le hlst with pl hpl,
  use pl + (pl + 1) * (pf.comp (pl + polynomial.X) + 1),
  intros x m _,
  simp [scanl_step_iterate'], apply add_le_add,
  { exact (list.size_le_of_sublist ((lst x).drop_sublist _)).trans (hpl _), },
  refine (list.size_le_of_sublist (list.take_sublist _ _)).trans _,
  apply list.size_le_mul_of_le,
  { rw [list.length_scanl, add_le_add_iff_right], exact (lst x).length_le_size.trans (hpl _), },
  simp_rw list.mem_iff_nth_le,
  rintros e ⟨n, hn, rfl⟩,
  rw list.scanl_nth_le_eq_foldl,
  exact (hpf ((lst x).take n, x)).trans (pf.eval_mono $ add_le_add_right ((list.size_le_of_sublist (list.take_sublist _ _)).trans (hpl _)) _),
end

lemma list_scanl_rev [polysize α] [polysize β] [polysize γ] {lst : γ → list α} {acc : γ → β} {f : γ → β → α → β}
  (hlst : lst ∈ₑ PTIME) (hacc : acc ∈ₑ PTIME) (hf : f ∈ₑ PTIME)
  (hf' : polysize_safe (λ (usf : γ × α) (sf : β), f usf.1 sf usf.2)) :
  polytime.mem (λ x : γ, ((lst x).scanl (f x) (acc x)).reverse) :=
list_scanl_rev' hlst hacc hf
  (polysize_safe.foldl polysize_fun.fst ((polytime.size_le hacc).comp polysize_fun.snd)
    (by { apply hf'.comp₃_1, complexity, }))

lemma list_foldl' [polysize α] [polysize β] [polysize γ] {lst : γ → list α} {acc : γ → β} {f : γ → β → α → β}
  (hlst : lst ∈ₑ PTIME) (hacc : acc ∈ₑ PTIME) (hf : f ∈ₑ PTIME)
  (hf' : polysize_fun (λ (ls : list α) (x), ls.foldl (f x) (acc x))) :
  polytime.mem (λ x : γ, (lst x).foldl (f x) (acc x)) :=
begin
  rw complexity_class.of_some,
  convert complexity_class.head'.comp (list_scanl_rev' hlst hacc hf hf'),
  ext x : 1, simp [list.scanl_last_eq_foldl],
end

@[complexity] lemma list_foldl [polysize α] [polysize β] [polysize γ] {lst : γ → list α} {acc : γ → β} {f : γ → β → α → β}
  (hlst : lst ∈ₑ PTIME) (hacc : acc ∈ₑ PTIME) (hf : f ∈ₑ PTIME)
  (hf' : polysize_safe (λ (usf : γ × α) (sf : β), f usf.1 sf usf.2)) :
  polytime.mem (λ x : γ, (lst x).foldl (f x) (acc x)) :=
begin
  rw complexity_class.of_some,
  convert complexity_class.head'.comp (list_scanl_rev hlst hacc hf hf'),
  ext x : 1, simp [list.scanl_last_eq_foldl],
end

@[complexity] theorem list_reverse : (@list.reverse α) ∈ₑ PTIME :=
begin
  complexity using (λ l : list α, l.foldl (λ (acc : list α) (hd : α), hd :: acc) []),
  rw [← list.foldr_reverse, list.foldr_eta],
end

@[complexity] lemma list_scanl [polysize α] [polysize β] [polysize γ] {lst : γ → list α} {acc : γ → β} {f : γ → β → α → β}
  (hlst : lst ∈ₑ PTIME) (hacc : acc ∈ₑ PTIME) (hf : f ∈ₑ PTIME)
  (hf' : polysize_safe (λ (usf : γ × α) (sf : β), f usf.1 sf usf.2)) :
  polytime.mem (λ x : γ, ((lst x).scanl (f x) (acc x))) :=
by simpa using list_reverse.comp (list_scanl_rev hlst hacc hf hf')

@[complexity] theorem list_foldr [polysize α] [polysize β] [polysize γ] {lst : γ → list α} {acc : γ → β} {f : γ → α → β → β}
  (hlst : lst ∈ₑ PTIME) (hacc : acc ∈ₑ PTIME) (hf : f ∈ₑ PTIME)
  (hf' : polysize_safe (λ (usf : γ × α) (sf : β), f usf.1 usf.2 sf)) :
  polytime.mem (λ x : γ, (lst x).foldr (f x) (acc x)) :=
by { simp_rw ← list.foldl_reverse, complexity, }

@[complexity] theorem list_map {lst : γ → list α} {f : γ → α → β} (hlst : lst ∈ₑ PTIME) (hf : f ∈ₑ PTIME) :
 (λ x, (lst x).map (f x)) ∈ₑ PTIME :=
by { complexity using (λ x, (lst x).foldr (λ hd acc, (f x hd) :: acc) []), induction lst x; simp [*], }

@[complexity] theorem list_all_some : (@list.all_some α) ∈ₑ PTIME :=
begin
  complexity using λ l, l.foldr (λ hd' acc', hd'.bind (λ hd, acc'.map (λ acc, hd :: acc))) (some []),
  induction l with hd, { simp, }, cases hd; simp [*],
end

instance {α : Type*} [polycodable α] : polycodable (list α) :=
{ poly := by { dunfold decode, complexity, } }

@[complexity] theorem list_tails : (@list.tails α) ∈ₑ PTIME :=
by { complexity using λ ls, ls.scanl (λ l _, l.tail) ls, induction ls; simp [*], }

@[complexity] theorem list_init : (@list.init α) ∈ₑ PTIME :=
by { complexity using λ ls, ls.reverse.tail.reverse, induction ls using list.reverse_rec_on; simp [list.init], }

theorem stack_rec_eq [inhabited β] [inhabited γ] (ls : list γ) (base : α → β) (pre : γ → list γ → α → α)
  (post : β → γ → list γ → α → β) (arg : α) : ls.stack_rec base pre post arg =
  (ls.tails.init.scanl (λ (acc : list γ × α) (x : list γ), (x.tail, pre x.head x.tail acc.2)) (ls, arg))
    .foldr (λ ls_arg ih, if ls_arg.1.empty then base ls_arg.2 else post ih ls_arg.1.head ls_arg.1.tail ls_arg.2) (arbitrary _) :=
begin
  induction ls with hd tl ih generalizing arg, { simp [list.init], },
  simp [list.init_cons_of_ne_nil (list.ne_nil_of_length_eq_succ $ list.length_tails _), ih],
end

@[complexity] theorem list_stack_rec [polysize α] [polysize β] [polysize γ] [polysize δ] {ls : δ → list γ} {base : δ → α → β} {pre : δ → γ → list γ → α → α}
  {post : δ → β → γ → list γ → α → β} {arg : δ → α} (hls : ls ∈ₑ PTIME) (hb : base ∈ₑ PTIME)
  (hpre : pre ∈ₑ PTIME) (hpost : post ∈ₑ PTIME) (harg : arg ∈ₑ PTIME)
  (hpre' : polysize_safe (λ (usf : δ × γ × list γ) (sf : α), pre usf.1 usf.2.1 usf.2.2 sf))
  (hpost' : polysize_safe (λ (usf : δ × γ × list γ × α) (sf : β), post usf.1 sf usf.2.1 usf.2.2.1 usf.2.2.2)) :
  (λ x, (ls x).stack_rec (base x) (pre x) (post x) (arg x)) ∈ₑ PTIME :=
begin
  casesI is_empty_or_nonempty δ, { exact complexity_class.of_from_fintype' _, },
  casesI is_empty_or_nonempty γ, { complexity using (λ x, base x (arg x)), cases ls x with hd, { refl, }, exact is_empty.elim' infer_instance hd, },
  inhabit δ, inhabit γ, haveI : inhabited α := ⟨arg default⟩, haveI : inhabited β := ⟨base default default⟩,
  simp_rw stack_rec_eq,
  complexity, { apply polysize_safe.comp₄_3, complexity, },
  { apply polysize_safe.comp₅_1, complexity, },
end

@[complexity] lemma repeat : (@list.repeat α) ∈ₑ PTIME :=
by { complexity using λ x n, (list.cons x)^[n] [], induction n; simp [iterate_succ', *], }

@[complexity] lemma nat_stack_rec {n : γ → ℕ} {base : γ → α → β} {pre : γ → ℕ → α → α} {post : γ → β → ℕ → α → β}
  {arg : γ → α}  (hn : n ∈ₑ PTIME) (hb : base ∈ₑ PTIME) (hpr : pre ∈ₑ PTIME) (hpo : post ∈ₑ PTIME)
  (harg : arg ∈ₑ PTIME) (hpr : polysize_safe (λ (usf : γ × ℕ) (sf : α), pre usf.1 usf.2 sf))
  (hpo' : polysize_safe (λ (usf : γ × ℕ × α) (sf : β), post usf.1 sf usf.2.1 usf.2.2)) : (λ x, (n x).stack_rec (base x) (pre x) (post x) (arg x)) ∈ₑ PTIME :=
begin
  complexity using λ x, (list.repeat () $ n x).stack_rec (base x) (λ _ tl y, pre x tl.length y)
    (λ ih _ tl y, post x ih tl.length y) (arg x),
  { apply polysize_safe.comp₃_2, complexity, },
  { apply polysize_safe.comp₄_1, complexity, },
  generalize : arg x = y, induction n x with n ih generalizing y,
  { simp, }, { simp [ih], },
end

@[complexity] lemma unary_nat_sum : (@list.sum ℕ _ _) ∈ₑ PTIME :=
by { delta list.sum, complexity, }

@[complexity] lemma list_ordered_insert {r : γ → α → α → Prop} [∀ x, decidable_rel (r x)] {a : γ → α} {ls : γ → list α} (hr : r ∈ₚ PTIME)
  (he : a ∈ₑ PTIME) (hls : ls ∈ₑ PTIME) : (λ x, (ls x).ordered_insert (r x) (a x)) ∈ₑ PTIME :=
begin
  complexity using λ x, (ls x).stack_rec (λ _ : unit, [a x]) (λ _ _ _, ())
    (λ ih b l _, if r x (a x) b then a x :: b :: l else b :: ih) (),
  induction ls x; simp [*],
end

@[complexity] lemma list_insertion_sort {r : γ → α → α → Prop} [∀ x, decidable_rel (r x)] {ls : γ → list α} (hr : r ∈ₚ PTIME)
  (hls : ls ∈ₑ PTIME) : (λ x, (ls x).insertion_sort (r x)) ∈ₑ PTIME :=
by { complexity using λ x, (ls x).foldr (λ b ih, list.ordered_insert (r x) b ih) [], induction ls x; simp [*], }

@[complexity] lemma list_append : ((++) : list α → list α → list α) ∈ₑ PTIME :=
by { complexity using λ l₁ l₂, l₁.foldr (λ hd acc, hd :: acc) l₂, induction l₁; simp [*], }

@[complexity] lemma list_drop : @list.drop α ∈ₑ PTIME :=
by { complexity using λ n l, list.tail^[n] l, simp, }

@[complexity] lemma list_any {l : α → list β} {p : α → β → bool} (hl : l ∈ₑ PTIME) (hp : p ∈ₑ PTIME) :
  (λ x, (l x).any (p x)) ∈ₑ PTIME :=
by { delta list.any, complexity, use 0, simp, }

@[complexity] lemma list_all {l : α → list β} {p : α → β → bool} (hl : l ∈ₑ PTIME) (hp : p ∈ₑ PTIME) :
  (λ x, (l x).all (p x)) ∈ₑ PTIME :=
by { delta list.all, complexity, use 0, simp, }

@[complexity] lemma list_bex {l : α → list β} {p : α → β → Prop} [∀ x y, decidable (p x y)] (hl : l ∈ₑ PTIME) (hp : p ∈ₚ PTIME) :
  (λ x, ∃ e ∈ l x, p x e) ∈ₚ PTIME :=
by { simp_rw [← list.any_iff_exists_prop], complexity, }

@[complexity] lemma list_ball {l : α → list β} {p : α → β → Prop} [∀ x y, decidable (p x y)] (hl : l ∈ₑ PTIME) (hp : p ∈ₚ PTIME) :
  (λ x, ∀ e ∈ l x, p x e) ∈ₚ PTIME :=
by { simp_rw ← list.all_iff_forall_prop, complexity, }

@[complexity] lemma list_mem : ((∈) : α → list α → Prop) ∈ₚ PTIME :=
by { haveI : decidable_eq α := decidable_eq_of_encodable _, complexity using λ x l, ∃ z ∈ l, z = x, simp, }

@[complexity] lemma pairwise {l : α → list β} {r : α → β → β → Prop} (hl : l ∈ₑ PTIME)
  (hr : r ∈ₚ PTIME) : (λ x, (l x).pairwise (r x)) ∈ₚ PTIME :=
begin
  classical, rw ← complexity_class.mem_iff_mem_pred,
  complexity using λ x, (l x).stack_rec (λ _ : unit, tt) (λ _ _ _, ())
    (λ ih hd tl _, (∀ a' ∈ tl, r x hd a') && ih) (), { use 0, simp, },
  induction l x; simp [*],
end

@[complexity] lemma list_nodup : (@list.nodup α) ∈ₚ PTIME :=
by { dunfold list.nodup, complexity, }

@[complexity] lemma list_nth {α : Type} [tencodable α] : @list.nth α ∈ₑ PTIME :=
by { complexity using λ l n, (l.drop n).head', rw [← list.nth_zero, list.nth_drop], refl, }

section dep
open_locale tree
variables {σ τ : α → Type} [∀ i, tencodable (σ i)] [∀ i, tencodable (τ i)]

lemma list_map_dep {f : ∀ x, list (σ x)} {g : ∀ x, σ x → τ x} (hf : f ∈ₐ PTIME) (hg : g ∈ₐ PTIME) :
  (λ x, @list.map _ (τ x) (g x) (f x)) ∈ₐ PTIME :=
polytime.functor_map_dep list hf hg (@list_map _ _ _ _ _ _)

end dep

end polytime


import defs.dynamics
import defs.fv
import defs.statics
import lemmas.cx
import lemmas.fv

theorem if_subst (ex: exp) (x: var) (fv_ex: fv ex = []) (e1 e2 e3: exp):
  subst ex x fv_ex (exp.if_ e1 e2 e3) =
    exp.if_
    (subst ex x fv_ex e1)
    (subst ex x fv_ex e2)
    (subst ex x fv_ex e3)
  := by simp [subst]

theorem app_subst (ex: exp) (x: var) (fv_ex: fv ex = []) (e1 e2: exp):
  subst ex x fv_ex (exp.app e1 e2) =
    exp.app
    (subst ex x fv_ex e1)
    (subst ex x fv_ex e2)
  := by simp [subst]

theorem fn_subst (ex: exp) (x: var) (fv_ex: fv ex = [])
  (y: var) (τ: typ) (e: exp):
  subst ex x fv_ex (exp.fn y τ e) =
  exp.fn y τ (if x = y then e else subst ex x fv_ex e) :=
begin
  simp [subst],
  -- super weird... at this point the lhs and rhs are equal so we should be
  -- done by refl but it doesn't work. but this does...?
  by_cases x = y,
  simp [h],
  simp [h],
end

theorem pair_subst (ex: exp) (x: var) (fv_ex: fv ex = []) (e1 e2: exp):
  subst ex x fv_ex (exp.pair e1 e2) =
    exp.pair
    (subst ex x fv_ex e1)
    (subst ex x fv_ex e2)
  := by simp [subst]

theorem pair_left_subst (ex: exp) (x: var) (fv_ex: fv ex = []) (e: exp):
  subst ex x fv_ex (exp.pair_left e) = exp.pair_left (subst ex x fv_ex e)
  := by simp [subst]

theorem pair_right_subst (ex: exp) (x: var) (fv_ex: fv ex = []) (e: exp):
  subst ex x fv_ex (exp.pair_right e) = exp.pair_right (subst ex x fv_ex e)
  := by simp [subst]

theorem either_left_subst {τ: typ} (ex: exp) (x: var) (fv_ex: fv ex = []) (e: exp):
  subst ex x fv_ex (exp.either_left τ e) = exp.either_left τ (subst ex x fv_ex e)
  := by simp [subst]

theorem either_right_subst {τ: typ} (ex: exp) (x: var) (fv_ex: fv ex = []) (e: exp):
  subst ex x fv_ex (exp.either_right τ e) = exp.either_right τ (subst ex x fv_ex e)
  := by simp [subst]

theorem case_never_subst {τ: typ} (ex: exp) (x: var) (fv_ex: fv ex = []) (e: exp):
  subst ex x fv_ex (exp.case_never τ e) = exp.case_never τ (subst ex x fv_ex e)
  := by simp [subst]

theorem case_subst (ex: exp) (x: var) (fv_ex: fv ex = [])
  (eh e1 e2: exp) (x1 x2: var):
  subst ex x fv_ex (exp.case eh x1 e1 x2 e2) =
  exp.case
    (subst ex x fv_ex eh)
    x1 (if x = x1 then e1 else subst ex x fv_ex e1)
    x2 (if x = x2 then e2 else subst ex x fv_ex e2)
   :=
begin
  simp [subst],
  -- same as in fn_subst...?
  by_cases h1: x = x1,
  simp [h1],
  by_cases h2: x1 = x2,
  simp [h2],
  simp [h2],
  simp [h1],
  by_cases h2: x = x2,
  simp [h2],
  simp [h2],
end

theorem weakening_var_helper {Γ: env} {x x': var} {τ1 τ2 τ: typ} {e: exp}:
  has_typ (env.insert_exp Γ x' τ1) e τ2 ->
  (x ∉ fv e -> has_typ (env.insert_exp (env.insert_exp Γ x' τ1) x τ) e τ2) ->
  x ∉ list.filter (ne x') (fv e) ->
  has_typ (env.insert_exp (env.insert_exp Γ x τ) x' τ1) e τ2 :=
begin
  intros et ih fv_e,
  by_cases x = x',
  let a := useless_insert_twice Γ.exps x τ1 τ,
  rw symm h at et ⊢,
  simp [env.insert_exp] at et,
  rw symm a at et,
  exact et,
  let b := ih (not_filter fv_e (fun a, h (symm a))),
  simp [env.insert_exp] at b,
  rw insert_comm Γ.exps x x' τ τ1 h at b,
  exact b,
end

theorem weakening {Γ: env} {e: exp} {τ: typ} (x: var) (τx: typ):
  x ∉ fv e ->
  has_typ Γ e τ ->
  has_typ (env.insert_exp Γ x τx) e τ :=
begin
  intros fv_e et,
  induction et,
  exact has_typ.int,
  exact has_typ.true,
  exact has_typ.false,
  rw if_fv at fv_e,
  simp [list.append] at fv_e,
  let t_e1 := et_ih_a (fun a, fv_e (or.inl a)),
  let t_e2 := et_ih_a_1 (fun a, fv_e (or.inr (or.inl a))),
  let t_e3 := et_ih_a_2 (fun a, fv_e (or.inr (or.inr a))),
  exact has_typ.if_ t_e1 t_e2 t_e3,
  simp [fv] at fv_e,
  let var_ne := fun a, fv_e (symm a),
  exact has_typ.var (iff.elim_right (useless_insert_ne var_ne) et_a),
  rw fn_fv at fv_e,
  exact has_typ.fn (weakening_var_helper et_a et_ih fv_e),
  rw app_fv at fv_e,
  simp [list.append] at fv_e,
  let t_e1 := et_ih_a (fun a, fv_e (or.inl a)),
  let t_e2 := et_ih_a_1 (fun a, fv_e (or.inr a)),
  exact has_typ.app t_e1 t_e2,
  exact has_typ.unit,
  rw pair_fv at fv_e,
  simp [list.append] at fv_e,
  let t_e1 := et_ih_a (fun a, fv_e (or.inl a)),
  let t_e2 := et_ih_a_1 (fun a, fv_e (or.inr a)),
  exact has_typ.pair t_e1 t_e2,
  rw pair_left_fv at fv_e,
  exact has_typ.pair_left (et_ih fv_e),
  rw pair_right_fv at fv_e,
  exact has_typ.pair_right (et_ih fv_e),
  rw either_left_fv at fv_e,
  exact has_typ.either_left (et_ih fv_e),
  rw either_right_fv at fv_e,
  exact has_typ.either_right (et_ih fv_e),
  rw case_never_fv at fv_e,
  exact has_typ.case_never (et_ih fv_e),
  rw case_fv at fv_e,
  simp [list.append] at fv_e,
  let t_eh := et_ih_a (fun a, fv_e (or.inl a)),
  let fv_et_e1 := fun a, fv_e (or.inr (or.inl a)),
  let t_e1 := weakening_var_helper et_a_1 et_ih_a_1 fv_et_e1,
  let fv_et_e2 := fun a, fv_e (or.inr (or.inr a)),
  let t_e2 := weakening_var_helper et_a_2 et_ih_a_2 fv_et_e2,
  exact has_typ.case t_eh t_e1 t_e2,
end

theorem subst_preservation_var_helper
  {Γ Γ': env} {x x': var} {τ1 τ2 τx: typ}
  {ex e: exp} (fv_ex: fv ex = []):
  Γ' = env.insert_exp Γ x τx ->
  has_typ (env.insert_exp Γ' x' τ1) e τ2 ->
  has_typ Γ ex τx ->
  (∀ {Γ : env},
    env.insert_exp Γ' x' τ1 = env.insert_exp Γ x τx →
    has_typ Γ ex τx → has_typ Γ (subst ex x fv_ex e) τ2) ->
  has_typ (env.insert_exp Γ x' τ1) (ite (x = x') e (subst ex x fv_ex e)) τ2 :=
begin
  intros Γ'_is et ext ih,
  by_cases x = x',
  simp [h],
  rw Γ'_is at et,
  rw h at et,
  simp [env.insert_exp] at et,
  rw useless_insert_twice Γ.exps x' τ1 τx at et,
  exact et,
  simp [h],
  rw Γ'_is at ih,
  let notin_fv_ex := list.not_mem_nil x',
  rw symm fv_ex at notin_fv_ex,
  let ext' := weakening x' τ1 notin_fv_ex ext,
  simp [env.insert_exp] at ih,
  let a := insert_comm Γ.exps x' x τ1 τx (fun a, h (symm a)),
  exact @ih (env.insert_exp Γ x' τ1) a ext',
end

theorem subst_preservation
  {Γ Γ': env}
  {e ex: exp}
  {x: var}
  {τ τx: typ}
  (Γ'_is: Γ' = env.insert_exp Γ x τx)
  (fv_ex: fv ex = [])
  (et: has_typ Γ' e τ)
  (ext: has_typ Γ ex τx)
  : has_typ Γ (subst ex x fv_ex e) τ :=
begin
  induction et generalizing Γ,
  exact has_typ.int,
  exact has_typ.true,
  exact has_typ.false,
  let a := et_ih_a Γ'_is ext,
  let b := et_ih_a_1 Γ'_is ext,
  let c := et_ih_a_2 Γ'_is ext,
  exact has_typ.if_ a b c,
  rw Γ'_is at et_a,
  by_cases x = et_x,
  rw h at et_a ⊢,
  rw lookup_uniq (lookup_insert Γ.exps et_x τx) et_a at ext,
  simp [subst],
  exact ext,
  simp [subst, h],
  let h' := fun a, h (symm a),
  let hm := iff.elim_left (useless_insert_ne h') et_a,
  exact has_typ.var hm,
  rw fn_subst,
  let a := subst_preservation_var_helper fv_ex Γ'_is et_a ext @et_ih,
  exact has_typ.fn a,
  let a := et_ih_a Γ'_is ext,
  let b := et_ih_a_1 Γ'_is ext,
  exact has_typ.app a b,
  exact has_typ.unit,
  let a := et_ih_a Γ'_is ext,
  let b := et_ih_a_1 Γ'_is ext,
  exact has_typ.pair a b,
  exact has_typ.pair_left (et_ih Γ'_is ext),
  exact has_typ.pair_right (et_ih Γ'_is ext),
  exact has_typ.either_left (et_ih Γ'_is ext),
  exact has_typ.either_right (et_ih Γ'_is ext),
  exact has_typ.case_never (et_ih Γ'_is ext),
  rw case_subst,
  let t_e1 := subst_preservation_var_helper fv_ex Γ'_is et_a_1 ext @et_ih_a_1,
  let t_e2 := subst_preservation_var_helper fv_ex Γ'_is et_a_2 ext @et_ih_a_2,
  exact has_typ.case (et_ih_a Γ'_is ext) t_e1 t_e2,
end

theorem subst_fv_var_helper {x x': var} {ex e: exp} (fv_ex: fv ex = []):
  fv (subst ex x fv_ex e) = list.filter (ne x) (fv e) ->
  list.filter (ne x') (fv (ite (x = x') e (subst ex x fv_ex e))) =
  list.filter (ne x) (list.filter (ne x') (fv e)) :=
begin
  intro ih,
  by_cases x = x',
  -- can't just `simp [h]` or else weird stuff happens with mismatched types
  rw h,
  simp,
  exact symm (filter_idempotent (ne x') (fv e)),
  simp [h],
  simp [ih],
  exact filter_comm (ne x') (ne x) (fv e),
end

theorem subst_fv (ex: exp) (x: var) (fv_ex: fv ex = []) (e: exp):
  fv (subst ex x fv_ex e) = list.filter (ne x) (fv e) :=
begin
  let s := subst ex x fv_ex,
  induction e,
  simp [subst, fv],
  simp [subst, fv],
  simp [subst, fv],
  rw if_subst ex x fv_ex e_a e_a_1 e_a_2,
  rw if_fv (s e_a) (s e_a_1) (s e_a_2),
  rw e_ih_a,
  rw e_ih_a_1,
  rw e_ih_a_2,
  rw symm (list.filter_append (fv e_a_1) (fv e_a_2)),
  rw symm (list.filter_append (fv e_a) (fv e_a_1 ++ fv e_a_2)),
  simp [subst, fv],
  by_cases x = e,
  rw h,
  simp [subst, var_fv],
  exact fv_ex,
  simp [fv, subst, h],
  simp [fn_subst, fn_fv],
  exact subst_fv_var_helper fv_ex e_ih,
  rw app_subst ex x fv_ex e_a e_a_1,
  rw app_fv (s e_a) (s e_a_1),
  rw e_ih_a,
  rw e_ih_a_1,
  rw symm (list.filter_append (fv e_a) (fv e_a_1)),
  rw symm (app_fv e_a e_a_1),
  simp [subst, fv],
  simp [pair_subst],
  simp [pair_fv],
  rw e_ih_a,
  rw e_ih_a_1,
  simp [pair_left_subst, pair_left_fv],
  rw e_ih,
  simp [pair_right_subst, pair_right_fv],
  rw e_ih,
  simp [either_left_subst, either_left_fv],
  rw e_ih,
  simp [either_right_subst, either_right_fv],
  rw e_ih,
  simp [case_never_subst, case_never_fv],
  rw e_ih,
  simp [case_subst, case_fv],
  rw e_ih_a,
  rw subst_fv_var_helper fv_ex e_ih_a_1,
  rw subst_fv_var_helper fv_ex e_ih_a_2,
end


import Lean

macro "foo!" x:term:max : term => `($x + 1)

#check foo! 0

theorem ex1 : foo! 2 = 3 :=
  rfl

macro "foo!" x:term:max : term => `($x * 2)

#check foo! 1 -- ambiguous

-- macro with higher priority
macro (priority := high) "foo!" x:term:max : term => `($x - 2)

#check foo! 2

theorem ex2 : foo! 2 = 0 :=
  rfl

-- Define elaborator with even higher priority
elab (priority := high+1) "foo!" x:term:max : term <= expectedType =>
  Lean.Elab.Term.elabTerm x expectedType

theorem ex3 : foo! 3 = 3 :=
  rfl


import breen_deligne.constants
import breen_deligne.suitable
import pseudo_normed_group.FP
import system_of_complexes.rescale

noncomputable theory

open_locale classical nnreal big_operators
local attribute [instance] type_pow

universe variable u

namespace category_theory
namespace FreeAb

def of_functor (C : Type*) [category C] : C ⥤ FreeAb C :=
{ obj := of,
  map := λ X Y f, free_abelian_group.of f,
  map_id' := λ X, rfl,
  map_comp' := λ X Y Z f g, rfl }

end FreeAb
end category_theory

open category_theory breen_deligne

namespace breen_deligne

variables (r' : ℝ≥0)
variables (BD : breen_deligne.data)
variables (M : ProFiltPseuNormGrpWithTinv r')
variables (c c₁ c₂ c₃ c₄ : ℝ≥0) (l m n : ℕ)

open category_theory breen_deligne
open Profinite pseudo_normed_group profinitely_filtered_pseudo_normed_group

/-- The "functor" that sends `M` and `c` to `(filtration M c)^n` -/
def FP2 (r' : ℝ≥0) (c : ℝ≥0) (n : ℕ) :
  ProFiltPseuNormGrpWithTinv r' ⥤ FreeAb Profinite :=
FiltrationPow r' c n ⋙ FreeAb.of_functor _

theorem FP2_def (r' : ℝ≥0) (c : ℝ≥0) (n : ℕ) :
  FP2 r' c n = FiltrationPow r' c n ⋙ FreeAb.of_functor _ := rfl

namespace FP2

@[simps {fully_applied := ff}]
def res (r' : ℝ≥0) (c₁ c₂ : ℝ≥0) [fact (c₁ ≤ c₂)] (n : ℕ) : FP2 r' c₁ n ⟶ FP2 r' c₂ n :=
whisker_right (FiltrationPow.cast_le r' c₁ c₂ n) _

@[simp] lemma res_refl : res r' c c n = 𝟙 _ :=
by { simp [res, FiltrationPow.cast_le_refl], refl }

lemma res_comp_res [h₁ : fact (c₁ ≤ c₂)] [h₂ : fact (c₂ ≤ c₃)] :
  res r' c₁ c₂ n ≫ res r' c₂ c₃ n = @res r' c₁ c₃ ⟨le_trans h₁.1 h₂.1⟩ n :=
by simp only [res, ← whisker_right_comp, FiltrationPow.cast_le_comp]

section Tinv
open profinitely_filtered_pseudo_normed_group_with_Tinv
variables [fact (0 < r')]

@[simps {fully_applied := ff}]
def Tinv [fact (c₁ ≤ r' * c₂)] : FP2 r' c₁ n ⟶ FP2 r' c₂ n :=
whisker_right (FiltrationPow.Tinv r' c₁ c₂ n) _

lemma Tinv_def [fact (c₁ ≤ r' * c₂)] :
  Tinv r' c₁ c₂ n = whisker_right (FiltrationPow.Tinv r' c₁ c₂ n) _ := rfl

lemma res_comp_Tinv
  [fact (c₁ ≤ c₂)] [fact (c₂ ≤ c₃)] [fact (c₁ ≤ r' * c₂)] [fact (c₂ ≤ r' * c₃)] :
  res r' c₁ c₂ n ≫ Tinv r' c₂ c₃ n = Tinv r' c₁ c₂ n ≫ res r' c₂ c₃ n :=
by { simp only [Tinv, res, ← whisker_right_comp], refl }

end Tinv

end FP2

open FP2

variables {l m n}

namespace basic_universal_map

open basic_universal_map

variables (ϕ : basic_universal_map m n)

def eval_FP2 (c₁ c₂ : ℝ≥0) [ϕ.suitable c₁ c₂] : FP2 r' c₁ m ⟶ FP2 r' c₂ n :=
whisker_right (ϕ.eval_FP r' c₁ c₂) _

def eval_FP2' (c₁ c₂ : ℝ≥0) : FP2 r' c₁ m ⟶ FP2 r' c₂ n :=
if H : ϕ.suitable c₁ c₂
then by exactI whisker_right (ϕ.eval_FP r' c₁ c₂) _
else 0

lemma eval_FP2_eq_eval_FP2' (h : ϕ.suitable c₁ c₂) :
  eval_FP2 r' ϕ c₁ c₂ = eval_FP2' r' ϕ c₁ c₂ :=
by { delta eval_FP2 eval_FP2', rw dif_pos h }

lemma eval_FP2'_def [h : ϕ.suitable c₁ c₂] :
  eval_FP2' r' ϕ c₁ c₂ = whisker_right (ϕ.eval_FP r' c₁ c₂) _ :=
dif_pos h

lemma eval_FP2'_not_suitable (h : ¬ ϕ.suitable c₁ c₂) :
  eval_FP2' r' ϕ c₁ c₂ = 0 :=
dif_neg h

lemma eval_FP2'_comp (f : basic_universal_map l m) (g : basic_universal_map m n)
  [hf : f.suitable c₁ c₂] [hg : g.suitable c₂ c₃] :
  eval_FP2' r' (comp g f) c₁ c₃ = eval_FP2' r' f c₁ c₂ ≫ eval_FP2' r' g c₂ c₃ :=
begin
  haveI : (comp g f).suitable c₁ c₃ := suitable_comp c₂,
  simp only [eval_FP2'_def, eval_FP_comp r' _ c₂, whisker_right_comp]
end

lemma eval_FP2_comp (f : basic_universal_map l m) (g : basic_universal_map m n)
  [hf : f.suitable c₁ c₂] [hg : g.suitable c₂ c₃] :
  @eval_FP2 r' _ _ (comp g f) c₁ c₃ (suitable_comp c₂) =
    eval_FP2 r' f c₁ c₂ ≫ eval_FP2 r' g c₂ c₃ :=
by { simp only [eval_FP2_eq_eval_FP2'], apply eval_FP2'_comp }

lemma res_comp_eval_FP2
  [fact (c₁ ≤ c₂)] [fact (c₃ ≤ c₄)] [ϕ.suitable c₂ c₄] [ϕ.suitable c₁ c₃] :
  res r' c₁ c₂ m ≫ eval_FP2 r' ϕ c₂ c₄ = eval_FP2 r' ϕ c₁ c₃ ≫ res r' c₃ c₄ n :=
by simp only [res, eval_FP2, ← whisker_right_comp,
  cast_le_comp_eval_FP _ c₁ c₂ c₃ c₄]

lemma Tinv_comp_eval_FP2 [fact (0 < r')] [fact (c₁ ≤ r' * c₂)] [fact (c₃ ≤ r' * c₄)]
  [ϕ.suitable c₁ c₃] [ϕ.suitable c₂ c₄] :
  Tinv r' c₁ c₂ m ≫ eval_FP2 r' ϕ c₂ c₄ = eval_FP2 r' ϕ c₁ c₃ ≫ Tinv r' c₃ c₄ n :=
by simp only [Tinv, eval_FP2, ← whisker_right_comp,
  Tinv_comp_eval_FP _ _ c₁ c₂ c₃ c₄]

end basic_universal_map

namespace universal_map

open free_abelian_group

variables (ϕ : universal_map m n)

def eval_FP2 [ϕ.suitable c₁ c₂] : FP2 r' c₁ m ⟶ FP2 r' c₂ n :=
∑ g : {g : basic_universal_map m n // g ∈ ϕ.support},
  begin
    haveI := suitable_of_mem_support ϕ c₁ c₂ g g.2,
    exact coeff (g : basic_universal_map m n) ϕ • (basic_universal_map.eval_FP2 r' g c₁ c₂)
  end

def eval_FP2' : FP2 r' c₁ m ⟶ FP2 r' c₂ n :=
∑ g in ϕ.support, coeff g ϕ • (g.eval_FP2' r' c₁ c₂)

lemma eval_FP2_eq_eval_FP2' (h : ϕ.suitable c₁ c₂) :
  eval_FP2 r' c₁ c₂ ϕ = eval_FP2' r' c₁ c₂ ϕ :=
begin
  simp only [eval_FP2, eval_FP2', basic_universal_map.eval_FP2_eq_eval_FP2',
    subtype.val_eq_coe],
  symmetry,
  apply finset.sum_subtype ϕ.support (λ _, iff.rfl),
end

@[simp] lemma eval_FP2'_of (f : basic_universal_map m n) :
  eval_FP2' r' c₁ c₂ (of f) = f.eval_FP2' r' c₁ c₂ :=
by simp only [eval_FP2', support_of, coeff_of_self, one_smul, finset.sum_singleton]

@[simp] lemma eval_FP2_of (f : basic_universal_map m n) [f.suitable c₁ c₂] :
  eval_FP2 r' c₁ c₂ (of f) = f.eval_FP2 r' c₁ c₂ :=
by rw [eval_FP2_eq_eval_FP2', eval_FP2'_of, basic_universal_map.eval_FP2_eq_eval_FP2']

@[simp] lemma eval_FP2'_zero :
  eval_FP2' r' c₁ c₂ (0 : universal_map m n) = 0 :=
by rw [eval_FP2', support_zero, finset.sum_empty]

@[simp] lemma eval_FP2_zero :
  eval_FP2 r' c₁ c₂ (0 : universal_map m n) = 0 :=
by rw [eval_FP2_eq_eval_FP2', eval_FP2'_zero]

@[simp] lemma eval_FP2'_neg (f : universal_map m n) :
  eval_FP2' r' c₁ c₂ (-f) = -eval_FP2' r' c₁ c₂ f :=
by simp only [eval_FP2', add_monoid_hom.map_neg, finset.sum_neg_distrib, neg_smul, support_neg]

@[simp] lemma eval_FP2_neg (f : universal_map m n) [f.suitable c₁ c₂] :
  eval_FP2 r' c₁ c₂ (-f) = -eval_FP2 r' c₁ c₂ f :=
by simp only [eval_FP2_eq_eval_FP2', eval_FP2'_neg]

lemma eval_FP2'_add (f g : universal_map m n) :
  eval_FP2' r' c₁ c₂ (f + g) = eval_FP2' r' c₁ c₂ f + eval_FP2' r' c₁ c₂ g :=
begin
  simp only [eval_FP2'],
  rw finset.sum_subset (support_add f g), -- two goals
  simp only [add_monoid_hom.map_add _ f g, add_smul],
  convert finset.sum_add_distrib using 2, -- three goals
  apply finset.sum_subset (finset.subset_union_left _ _), swap,
  apply finset.sum_subset (finset.subset_union_right _ _),
  all_goals { rintros x - h, rw not_mem_support_iff at h, simp [h] },
end

lemma eval_FP2_add (f g : universal_map m n) [f.suitable c₁ c₂] [g.suitable c₁ c₂] :
  eval_FP2 r' c₁ c₂ (f + g) = eval_FP2 r' c₁ c₂ f + eval_FP2 r' c₁ c₂ g :=
by simp only [eval_FP2_eq_eval_FP2', eval_FP2'_add]

lemma eval_FP2_sub (f g : universal_map m n) [f.suitable c₁ c₂] [g.suitable c₁ c₂] :
  eval_FP2 r' c₁ c₂ (f - g) = eval_FP2 r' c₁ c₂ f - eval_FP2 r' c₁ c₂ g :=
by simp only [sub_eq_add_neg, eval_FP2_add, eval_FP2_neg]

lemma eval_FP2'_comp_of (g : basic_universal_map m n) (f : basic_universal_map l m)
  [hf : f.suitable c₁ c₂] [hg : g.suitable c₂ c₃] :
  eval_FP2' r' c₁ c₃ ((universal_map.comp (of g)) (of f)) =
    eval_FP2' r' c₁ c₂ (of f) ≫ eval_FP2' r' c₂ c₃ (of g) :=
begin
  simp only [universal_map.comp_of, eval_FP2'_of],
  haveI hfg : (basic_universal_map.comp g f).suitable c₁ c₃ := basic_universal_map.suitable_comp c₂,
  rw ← basic_universal_map.eval_FP2'_comp,
end

open category_theory category_theory.limits category_theory.preadditive

lemma eval_FP2'_comp (g : universal_map m n) (f : universal_map l m)
  [hf : f.suitable c₁ c₂] [hg : g.suitable c₂ c₃] :
  eval_FP2' r' c₁ c₃ (universal_map.comp g f) = eval_FP2' r' c₁ c₂ f ≫ eval_FP2' r' c₂ c₃ g :=
begin
  unfreezingI { revert hg },
  apply free_abelian_group.induction_on_free_predicate
    (universal_map.suitable c₁ c₂) (universal_map.suitable_free_predicate c₁ c₂) f hf;
      unfreezingI { clear_dependent f },
  { intros h₂,
    simp only [eval_FP2'_zero, zero_comp, pi.zero_apply,
      add_monoid_hom.zero_apply, add_monoid_hom.map_zero] },
  { intros f hf hg,
    -- now do another nested induction on `f`
    apply free_abelian_group.induction_on_free_predicate
      (universal_map.suitable c₂ c₃) (universal_map.suitable_free_predicate c₂ c₃) g hg;
        unfreezingI { clear_dependent g },
    { simp only [universal_map.eval_FP2'_zero, comp_zero, add_monoid_hom.map_zero,
        add_monoid_hom.zero_apply] },
    { intros g hg,
      rw suitable_of_iff at hf hg,
      resetI,
      apply eval_FP2'_comp_of },
    { intros g hg IH,
      simp only [IH, eval_FP2'_neg, add_monoid_hom.map_neg, comp_neg,
        add_monoid_hom.neg_apply] },
    { rintros (g₁ : universal_map m n) (g₂ : universal_map m n) hg₁ hg₂ IH₁ IH₂, resetI,
      haveI Hg₁f : (universal_map.comp g₁ (of f)).suitable c₁ c₃ := suitable.comp c₂,
      haveI Hg₂f : (universal_map.comp g₂ (of f)).suitable c₁ c₃ := suitable.comp c₂,
      simp only [add_monoid_hom.map_add, eval_FP2'_add, IH₁, IH₂, comp_add,
        add_monoid_hom.add_apply] } },
  { intros f hf IH hg, resetI, specialize IH,
    simp only [IH, add_monoid_hom.map_neg, eval_FP2'_neg,
      add_monoid_hom.neg_apply, neg_inj, neg_comp] },
  { rintros (f₁ : universal_map l m) (f₂ : universal_map l m) hf₁ hf₂ IH₁ IH₂ hf, resetI,
    haveI Hgf₁ : (universal_map.comp g f₁).suitable c₁ c₃ := suitable.comp c₂,
    haveI Hgf₂ : (universal_map.comp g f₂).suitable c₁ c₃ := suitable.comp c₂,
    simp only [add_monoid_hom.map_add, add_monoid_hom.add_apply, eval_FP2'_add, IH₁, IH₂, add_comp] }
end

lemma eval_FP2_comp (g : universal_map m n) (f : universal_map l m)
  [hf : f.suitable c₁ c₂] [hg : g.suitable c₂ c₃] :
  @eval_FP2 r' c₁ c₃ _ _ (universal_map.comp g f) (universal_map.suitable.comp c₂) =
    eval_FP2 r' c₁ c₂ f ≫ eval_FP2 r' c₂ c₃ g :=
by { simp only [eval_FP2_eq_eval_FP2'], apply eval_FP2'_comp }

lemma res_comp_eval_FP2 [fact (c₁ ≤ c₂)] [fact (c₃ ≤ c₄)] [ϕ.suitable c₁ c₃] [ϕ.suitable c₂ c₄] :
  res r' c₁ c₂ m ≫ eval_FP2 r' c₂ c₄ ϕ = eval_FP2 r' c₁ c₃ ϕ ≫ res r' c₃ c₄ n :=
begin
  simp only [eval_FP2, comp_sum, sum_comp, comp_zsmul, zsmul_comp],
  apply finset.sum_congr rfl,
  rintros ⟨g, hg⟩ -,
  haveI : g.suitable c₁ c₃ := suitable_of_mem_support ϕ _ _ g hg,
  haveI : g.suitable c₂ c₄ := suitable_of_mem_support ϕ _ _ g hg,
  simp only [subtype.coe_mk, g.res_comp_eval_FP2 r' c₁ c₂ c₃ c₄],
end

lemma Tinv_comp_eval_FP2 [fact (0 < r')] [fact (c₁ ≤ r' * c₂)] [fact (c₃ ≤ r' * c₄)]
  [ϕ.suitable c₁ c₃] [ϕ.suitable c₂ c₄] :
  Tinv r' c₁ c₂ m ≫ eval_FP2 r' c₂ c₄ ϕ = eval_FP2 r' c₁ c₃ ϕ ≫ Tinv r' c₃ c₄ n :=
begin
  simp only [eval_FP2, comp_sum, sum_comp, comp_zsmul, zsmul_comp],
  apply finset.sum_congr rfl,
  rintros ⟨g, hg⟩ -,
  haveI : g.suitable c₁ c₃ := suitable_of_mem_support ϕ _ _ g hg,
  haveI : g.suitable c₂ c₄ := suitable_of_mem_support ϕ _ _ g hg,
  congr' 1, apply basic_universal_map.Tinv_comp_eval_FP2 r',
end

end universal_map

variables (κ : ℝ≥0 → ℕ → ℝ≥0) [∀ c, BD.suitable (κ c)]

def FPsystem.X (c : ℝ≥0) (n : ℕ) : FreeAb Profinite :=
FreeAb.of $ (FiltrationPow r' (κ c n) $ BD.X n).obj M

def FPsystem.d (c : ℝ≥0) (n : ℕ) :
  FPsystem.X r' BD M κ c (n + 1) ⟶ FPsystem.X r' BD M κ c n :=
(universal_map.eval_FP2 r' (κ c (n+1)) (κ c n) (BD.d (n+1) n)).app M

lemma FPsystem.d_comp_d (c : ℝ≥0) (n : ℕ) :
  FPsystem.d r' BD M κ c (n + 1) ≫ FPsystem.d r' BD M κ c n = 0 :=
begin
  delta FPsystem.d,
  rw [← nat_trans.comp_app, ← universal_map.eval_FP2_comp],
  convert nat_trans.app_zero _, refl, refl,
  convert universal_map.eval_FP2_zero _ _ _,
  show BD.d _ _ ≫ BD.d _ _ = 0,
  rw homological_complex.d_comp_d,
end

open opposite

def FPsystem [hκ : ∀ n, fact (monotone (function.swap κ n))] :
  ℝ≥0 ⥤ chain_complex (FreeAb Profinite) ℕ :=
{ obj := λ c, chain_complex.of (FPsystem.X r' BD M κ c) (FPsystem.d r' BD M κ _) (FPsystem.d_comp_d _ _ _ _ _),
  map := λ c₁ c₂ h,
  { f := λ n, by { refine (@FP2.res r' _ _ (id _) (BD.X n)).app M,
      have := (hκ n).out, refine ⟨this h.le⟩, },
    comm' := begin
      rintro i j (rfl : j + 1 = i),
      rw [chain_complex.of_d, chain_complex.of_d],
      delta FPsystem.d, rw [← nat_trans.comp_app, ← nat_trans.comp_app],
      congr' 1,
      apply universal_map.res_comp_eval_FP2,
    end },
  map_id' := λ c, begin
    ext n, dsimp, rw [Filtration.cast_le_refl, (FreeAb.of_functor _).map_id], refl,
  end,
  map_comp' := λ c₁ c₂ c₃ h₁₂ h₂₃, begin
    ext n, dsimp, rw [← (FreeAb.of_functor _).map_comp, Filtration.cast_le_comp],
  end }
.

def FPsystem.Tinv [fact (0 < r')]
  (κ₁ κ₂ : ℝ≥0 → ℕ → ℝ≥0)
  [∀ c, BD.suitable (κ₁ c)] [∀ c, BD.suitable (κ₂ c)]
  [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))]
  [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ r' * κ₂ c n)] :
  FPsystem r' BD M κ₁ ⟶ FPsystem r' BD M κ₂ :=
{ app := λ c,
  { f := λ n, (FP2.Tinv r' _ _ _).app M,
    comm' := begin
      rintro i j (rfl : j + 1 = i),
      dsimp only [functor.comp_obj, FPsystem],
      rw [chain_complex.of_d, chain_complex.of_d],
      delta FPsystem.d,
      rw [← nat_trans.comp_app, ← nat_trans.comp_app],
      congr' 1,
      apply universal_map.Tinv_comp_eval_FP2
    end },
  naturality' := begin
    intros c₁ c₂ h,
    ext n,
    dsimp only [FPsystem, Tinv_app, homological_complex.comp_f, functor.comp_map, res_app],
    rw [← functor.map_comp, ← functor.map_comp],
    refl,
  end }

def FPsystem.res [fact (r' ≤ 1)]
  (κ₁ κ₂ : ℝ≥0 → ℕ → ℝ≥0)
  [∀ c, BD.suitable (κ₁ c)] [∀ c, BD.suitable (κ₂ c)]
  [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))]
  [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ κ₂ c n)] :
  FPsystem r' BD M κ₁ ⟶ FPsystem r' BD M κ₂ :=
{ app := λ c,
  { f := λ n, (FP2.res r' _ _ _).app M,
    comm' := begin
      rintro i j (rfl : j + 1 = i),
      dsimp only [functor.comp_obj, FPsystem],
      rw [chain_complex.of_d, chain_complex.of_d],
      delta FPsystem.d,
      rw [← nat_trans.comp_app, ← nat_trans.comp_app],
      congr' 1,
      apply universal_map.res_comp_eval_FP2
    end },
  naturality' := begin
    intros c₁ c₂ h,
    ext n,
    dsimp only [FPsystem, res_app, homological_complex.comp_f, functor.comp_map],
    rw [← functor.map_comp, ← functor.map_comp],
    refl,
  end }

end breen_deligne


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.dlist
import Mathlib.tactic.core
import Mathlib.tactic.clear
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!

# Recursive cases (`rcases`) tactic and related tactics

`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c ∨ d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.

Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:

* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
  hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
  hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
  against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
  of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
  then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
  and so on.
* An alteration pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
  or a nested disjunction like `a ∨ b ∨ c`.

The patterns are fairly liberal about the exact shape of the constructors, and will insert
additional alternation branches and tuple arguments if there are not enough arguments provided, and
reuse the tail for further matches if there are too many arguments provided to alternation and
tuple patterns.

This file also contains the `obtain` and `rintro` tactics, which use the same syntax of `rcases`
patterns but with a slightly different use case:

* `rintro` (or `rintros`) is used like `rintro x ⟨y, z⟩` and is the same as `intros` followed by
  `rcases` on the newly introduced arguments.
* `obtain` is the same as `rcases` but with a syntax styled after `have` rather than `cases`.
  `obtain ⟨hx, hy⟩ | hz := foo` is equivalent to `rcases foo with ⟨hx, hy⟩ | hz`. Unlike `rcases`,
  `obtain` also allows one to omit `:= foo`, although a type must be provided in this case,
  as in `obtain ⟨hx, hy⟩ | hz : a ∧ b ∨ c`, in which case it produces a subgoal for proving
  `a ∧ b ∨ c` in addition to the subgoals `hx : a, hy : b |- goal` and `hz : c |- goal`.

## Tags

rcases, rintro, obtain, destructuring, cases, pattern matching, match
-/

namespace tactic

/-!
These synonyms for `list` are used to clarify the meanings of the many
usages of lists in this module.

- `listΣ` is used where a list represents a disjunction, such as the
  list of possible constructors of an inductive type.

- `listΠ` is used where a list represents a conjunction, such as the
  list of arguments of an individual constructor.

These are merely type synonyms, and so are not checked for consistency
by the compiler.

The `def`/`local notation` combination makes Lean retain these
annotations in reported types.
-/

/-- A list, with a disjunctive meaning (like a list of inductive constructors, or subgoals) -/
def list_Sigma (T : Type u_1) := List

/-- A list, with a conjunctive meaning (like a list of constructor arguments, or hypotheses) -/
def list_Pi (T : Type u_1) := List

/-- A metavariable representing a subgoal, together with a list of local constants to clear. -/
/--
An `rcases` pattern can be one of the following, in a nested combination:

* A name like `foo`
* The special keyword `rfl` (for pattern matching on equality using `subst`)
* A hyphen `-`, which clears the active hypothesis and any dependents.
* A type ascription like `pat : ty` (parentheses are optional)
* A tuple constructor like `⟨p1, p2, p3⟩`
* An alternation / variant pattern `p1 | p2 | p3`

Parentheses can be used for grouping; alternation is higher precedence than type ascription, so
`p1 | p2 | p3 : ty` means `(p1 | p2 | p3) : ty`.

N-ary alternations are treated as a group, so `p1 | p2 | p3` is not the same as `p1 | (p2 | p3)`,
and similarly for tuples. However, note that an n-ary alternation or tuple can match an n-ary
conjunction or disjunction, because if the number of patterns exceeds the number of constructors in
the type being destructed, the extra patterns will match on the last element, meaning that
`p1 | p2 | p3` will act like `p1 | (p2 | p3)` when matching `a1 ∨ a2 ∨ a3`. If matching against a
type with 3 constructors,  `p1 | (p2 | p3)` will act like `p1 | (p2 | p3) | _` instead.
-/
namespace rcases_patt

/-- Get the name from a pattern, if provided -/
/-- Interpret an rcases pattern as a tuple, where `p` becomes `⟨p⟩`
if `p` is not already a tuple. -/
/-- Interpret an rcases pattern as an alternation, where non-alternations are treated as one
alternative. -/
/-- Convert a list of patterns to a tuple pattern, but mapping `[p]` to `p` instead of `⟨p⟩`. -/
/-- Convert a list of patterns to an alternation pattern, but mapping `[p]` to `p` instead of
a unary alternation `|p`. -/
/-- This function is used for producing rcases patterns based on a case tree. Suppose that we have
a list of patterns `ps` that will match correctly against the branches of the case tree for one
constructor. This function will merge tuples at the end of the list, so that `[a, b, ⟨c, d⟩]`
becomes `⟨a, b, c, d⟩` instead of `⟨a, b, ⟨c, d⟩⟩`.

We must be careful to turn `[a, ⟨⟩]` into `⟨a, ⟨⟩⟩` instead of `⟨a⟩` (which will not perform the
nested match). -/
/-- This function is used for producing rcases patterns based on a case tree. This is like
`tuple₁_core` but it produces a pattern instead of a tuple pattern list, converting `[n]` to `n`
instead of `⟨n⟩` and `[]` to `_`, and otherwise just converting `[a, b, c]` to `⟨a, b, c⟩`. -/
/-- This function is used for producing rcases patterns based on a case tree. Here we are given
the list of patterns to apply to each argument of each constructor after the main case, and must
produce a list of alternatives with the same effect. This function calls `tuple₁` to make the
individual alternatives, and handles merging `[a, b, c | d]` to `a | b | c | d` instead of
`a | b | (c | d)`. -/
/-- This function is used for producing rcases patterns based on a case tree. This is like
`alts₁_core`, but it produces a cases pattern directly instead of a list of alternatives. We
specially translate the empty alternation to `⟨⟩`, and translate `|(a | b)` to `⟨a | b⟩` (because we
don't have any syntax for unary alternation). Otherwise we can use the regular merging of
alternations at the last argument so that `a | b | (c | d)` becomes `a | b | c | d`. -/
/-- Formats an `rcases` pattern. If the `bracket` argument is true, then it will be
printed at high precedence, i.e. it will have parentheses around it if it is not already a tuple
or atomic name. -/
end rcases_patt

/-- Takes the number of fields of a single constructor and patterns to match its fields against
(not necessarily the same number). The returned lists each contain one element per field of the
constructor. The `name` is the name which will be used in the top-level `cases` tactic, and the
`rcases_patt` is the pattern which the field will be matched against by subsequent `cases`
tactics. -/
-- The interesting case: we matched the last field against multiple

-- patterns, so split off the remaining patterns into a subsequent

-- match. This handles matching `α × β × γ` against `⟨a, b, c⟩`.

/-- Takes a list of constructor names, and an (alternation) list of patterns, and matches each
pattern against its constructor. It returns the list of names that will be passed to `cases`,
and the list of `(constructor name, patterns)` for each constructor, where `patterns` is the
(conjunctive) list of patterns to apply to each constructor argument. -/
/-- Like `zip`, but only elements satisfying a matching predicate `p` will go in the list,
and elements of the first list that fail to match the second list will be skipped. -/
/-- Given a local constant `e`, get its type. *But* if `e` does not exist, go find a hypothesis
with the same pretty name as `e` and get it instead. This is needed because we can sometimes lose
track of the unique names of hypotheses when they are revert/intro'd by `change` and `cases`. (A
better solution would be for these tactics to return a map of renamed hypotheses so that we don't
lose track of them.) -/
/--
* `rcases_core p e` will match a pattern `p` against a local hypothesis `e`.
  It returns the list of subgoals that were produced.
* `rcases.continue pes` will match a (conjunctive) list of `(p, e)` pairs which refer to
  patterns and local hypotheses to match against, and applies all of them. Note that this can
  involve matching later arguments multiple times given earlier arguments, for example
  `⟨a | b, ⟨c, d⟩⟩` performs the `⟨c, d⟩` match twice, once on the `a` branch and once on `b`.
-/
-- If the pattern is any other name, we already bound the name in the

-- top-level `cases` tactic, so there is no more work to do for it.

/-- Given a list of `uncleared_goal`s, each of which is a goal metavariable and
a list of variables to clear, actually perform the clear and set the goals with the result. -/
/-- `rcases h e pat` performs case distinction on `e` using `pat` to
name the arising new variables and assumptions. If `h` is `some` name,
a new assumption `h : e = pat` will relate the expression `e` with the
current pattern. See the module comment for the syntax of `pat`. -/
/-- `rcases_many es pats` performs case distinction on the `es` using `pat` to
name the arising new variables and assumptions.
See the module comment for the syntax of `pat`. -/
/-- `rintro pat₁ pat₂ ... patₙ` introduces `n` arguments, then pattern matches on the `patᵢ` using
the same syntax as `rcases`. -/
/-- Like `zip_with`, but if the lists don't match in length, the excess elements will be put at the
end of the result. -/
def merge_list {α : Type u_1} (m : α → α → α) : List α → List α → List α := sorry

/-- Merge two `rcases` patterns. This is used to underapproximate a case tree by an `rcases`
pattern. The two patterns come from cases in two branches, that due to the syntax of `rcases`
patterns are forced to overlap. The rule here is that we take only the case splits that are in
common between both branches. For example if one branch does `⟨a, b⟩` and the other does `c`,
then we return `c` because we don't know that a case on `c` would be safe to do. -/
/--
* `rcases_hint_core depth e` does the same as `rcases p e`, except the pattern `p` is an output
  instead of an input, controlled only by the case depth argument `depth`. We use `cases` to depth
  `depth` and then reconstruct an `rcases` pattern `p` that would, if passed to `rcases`, perform
  the same thing as the case tree we just constructed (or at least, the nearest expressible
  approximation to this.)
* `rcases_hint.process_constructors depth cs l` takes a list of constructor names `cs` and a
  matching list `l` of elements `(g, c', hs, _)` where  `c'` is a constructor name (used for
  alignment with `cs`), `g` is the subgoal, and `hs` is the list of local hypotheses created by
  `cases` in that subgoal. It matches on all of them, and then produces a `ΣΠ`-list of `rcases`
  patterns describing the result, and the list of generated subgoals.
* `rcases_hint.continue depth es` does the same as `rcases.continue (ps.zip es)`, except the
  patterns `ps` are an output instead of an input, created by matching on everything to depth
  `depth` and recording the successful cases. It returns `ps`, and the list of generated subgoals.
-/
/--
* `rcases? e` is like `rcases e with ...`, except it generates `...` by matching on everything it
can, and it outputs an `rcases` invocation that should have the same effect.
* `rcases? e : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
/--
* `rcases? ⟨e1, e2, e3⟩` is like `rcases ⟨e1, e2, e3⟩ with ...`, except it
  generates `...` by matching on everything it can, and it outputs an `rcases`
  invocation that should have the same effect.
* `rcases? ⟨e1, e2, e3⟩ : n` can be used to control the depth of case splits
  (especially important for recursive types like `nat`, which can be cased as many
  times as you like). -/
/--
* `rintro?` is like `rintro ...`, except it generates `...` by introducing and matching on
everything it can, and it outputs an `rintro` invocation that should have the same effect.
* `rintro? : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
/--
* `rcases_patt_parse tt` will parse a high precedence `rcases` pattern, `patt_hi`.
  This means only tuples and identifiers are allowed; alternations and type ascriptions
  require `(...)` instead, which switches to `patt`.
* `rcases_patt_parse ff` will parse a low precedence `rcases` pattern, `patt`. This consists of a
  `patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
  expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
  example in `rcases e with x : ty <|> skip`.
* `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
  patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
  `(a | b) : ty` where `a | b` is the `patt_med` part.
* `rcases_patt_parse_list_rest a` parses an alternation list after the initial pattern, `| b | c`.

```lean
patt ::= patt_med (":" expr)?
patt_med ::= (patt_hi "|")* patt_hi
patt_hi ::= id | "rfl" | "_" | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
```
-/
/-- Parse the optional depth argument `(: n)?` of `rcases?` and `rintro?`, with default depth 5. -/
/-- The arguments to `rcases`, which in fact dispatch to several other tactics.
* `rcases? expr (: n)?` or `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint`
* `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint_many`
* `rcases (h :)? expr (with patt)?` calls `rcases`
* `rcases ⟨expr, ...⟩ (with patt)?` calls `rcases_many`
-/
/-- Syntax for a `rcases` pattern:
* `rcases? expr (: n)?`
* `rcases (h :)? expr (with patt_list (: expr)?)?`. -/
/--
`rintro_patt_parse_hi` and `rintro_patt_parse` are like `rcases_patt_parse`, but is used for
parsing top level `rintro` patterns, which allow sequences like `(x y : t)` in addition to simple
`rcases` patterns.

* `rintro_patt_parse_hi` will parse a high precedence `rcases` pattern, `rintro_patt_hi` below.
  This means only tuples and identifiers are allowed; alternations and type ascriptions
  require `(...)` instead, which switches to `patt`.
* `rintro_patt_parse tt` will parse a low precedence `rcases` pattern, `rintro_patt` below.
  This consists of either a sequence of patterns `p1 p2 p3` or an alternation list `p1 | p2 | p3`
  treated as a single pattern, optionally followed by a `: ty` type ascription, which applies to
  every pattern in the list.
* `rintro_patt_parse ff` parses `rintro_patt_low`, which is the same as `rintro_patt_parse tt` but
  it does not permit an unparenthesized alternation list, it must have the form `p1 p2 p3 (: ty)?`.

```lean
rintro_patt ::= (rintro_patt_hi+ | patt_med) (":" expr)?
rintro_patt_low ::= rintro_patt_hi* (":" expr)?
rintro_patt_hi ::= patt_hi | "(" rintro_patt ")"
```
-/
/-- Syntax for a `rintro` pattern: `('?' (: n)?) | rintro_patt`. -/
namespace interactive

/--
`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c ∨ d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.

Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:

* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
  hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
  hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
  against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
  of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
  then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
  and so on.
* An alteration pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
  or a nested disjunction like `a ∨ b ∨ c`.

A pattern like `⟨a, b, c⟩ | ⟨d, e⟩` will do a split over the inductive datatype,
naming the first three parameters of the first constructor as `a,b,c` and the
first two of the second constructor `d,e`. If the list is not as long as the
number of arguments to the constructor or the number of constructors, the
remaining variables will be automatically named. If there are nested brackets
such as `⟨⟨a⟩, b | c⟩ | d` then these will cause more case splits as necessary.
If there are too many arguments, such as `⟨a, b, c⟩` for splitting on
`∃ x, ∃ y, p x`, then it will be treated as `⟨a, ⟨b, c⟩⟩`, splitting the last
parameter as necessary.

`rcases` also has special support for quotient types: quotient induction into Prop works like
matching on the constructor `quot.mk`.

`rcases h : e with PAT` will do the same as `rcases e with PAT` with the exception that an
assumption `h : e = PAT` will be added to the context.

`rcases? e` will perform case splits on `e` in the same way as `rcases e`,
but rather than accepting a pattern, it does a maximal cases and prints the
pattern that would produce this case splitting. The default maximum depth is 5,
but this can be modified with `rcases? e : n`.
-/
/--
The `rintro` tactic is a combination of the `intros` tactic with `rcases` to
allow for destructuring patterns while introducing variables. See `rcases` for
a description of supported patterns. For example, `rintro (a | ⟨b, c⟩) ⟨d, e⟩`
will introduce two variables, and then do case splits on both of them producing
two subgoals, one with variables `a d e` and the other with `b c d e`.

`rintro`, unlike `rcases`, also supports the form `(x y : ty)` for introducing
and type-ascripting multiple variables at once, similar to binders.

`rintro?` will introduce and case split on variables in the same way as
`rintro`, but will also print the `rintro` invocation that would have the same
result. Like `rcases?`, `rintro? : n` allows for modifying the
depth of splitting; the default is 5.

`rintros` is an alias for `rintro`.
-/
/-- Alias for `rintro`. -/
/-- Parses `patt? (: expr)? (:= expr)?`, the arguments for `obtain`.
 (This is almost the same as `rcases_patt_parse ff`,
but it allows the pattern part to be empty.) -/
/--
The `obtain` tactic is a combination of `have` and `rcases`. See `rcases` for
a description of supported patterns.

```lean
obtain ⟨patt⟩ : type,
{ ... }
```
is equivalent to
```lean
have h : type,
{ ... },
rcases h with ⟨patt⟩
```

The syntax `obtain ⟨patt⟩ : type := proof` is also supported.

If `⟨patt⟩` is omitted, `rcases` will try to infer the pattern.

If `type` is omitted, `:= proof` is required.
-/
end Mathlib