import for_mathlib.open_embeddings

import sheaves.sheaf_of_topological_rings
import sheaves.stalk_of_rings

universe variable u

open topological_space

variables {X : Type u} {Y : Type u} {Z : Type u}
variables [topological_space X] [topological_space Y] [topological_space Z]

namespace presheaf_of_rings
variables {F : presheaf_of_rings X} {G : presheaf_of_rings Y} {H : presheaf_of_rings Z}

structure f_map
  (F : presheaf_of_rings X) (G : presheaf_of_rings Y) :=
(f : X → Y)
(hf : continuous f)
(f_flat : ∀ V : opens Y, G V → F (hf.comap V))
(f_flat_is_ring_hom : ∀ V : opens Y, is_ring_hom (f_flat V))
(presheaf_f_flat : ∀ V W : opens Y, ∀ (hWV : W ⊆ V),
  ∀ s : G V, F.res _ _ (hf.comap_mono hWV) (f_flat V s) = f_flat W (G.res V W hWV s))

attribute [instance] f_map.f_flat_is_ring_hom

def f_map_id (F : presheaf_of_rings X) : presheaf_of_rings.f_map F F :=
{ f := λ x, x,
  hf := continuous_id,
  f_flat := λ U, F.res _ _ (λ _ hx, hx),
  f_flat_is_ring_hom := λ U, presheaf_of_rings.res_is_ring_hom _ _ _ _,
  presheaf_f_flat :=  λ U V hVU s, begin
      rw ←F.to_presheaf.Hcomp',
      rw ←F.to_presheaf.Hcomp',
    end }

def f_map.comp (a : presheaf_of_rings.f_map F G) (b : presheaf_of_rings.f_map G H) :
presheaf_of_rings.f_map F H :=
{ f := λ x, b.f (a.f x),
  hf := b.hf.comp a.hf,
  f_flat := λ V s, (a.f_flat (b.hf.comap V)) ((b.f_flat V) s),
  f_flat_is_ring_hom := λ V, show (is_ring_hom ((a.f_flat (b.hf.comap V)) ∘ (b.f_flat V))), from is_ring_hom.comp _ _,
  presheaf_f_flat := λ V W hWV s,
  begin
    rw ←b.presheaf_f_flat V W hWV s,
    rw ←a.presheaf_f_flat (b.hf.comap V) (b.hf.comap W) (b.hf.comap_mono hWV),
    refl,
  end }

@[simp] lemma f_map.id_comp (a : presheaf_of_rings.f_map F G) :
  (presheaf_of_rings.f_map_id F).comp a = a :=
begin
  cases a, delta presheaf_of_rings.f_map_id presheaf_of_rings.f_map.comp,
  congr, funext V s, dsimp,
  show _ = id _, apply congr_fun, exact F.to_presheaf.Hid _,
end

@[simp] lemma f_map.comp_id (a : presheaf_of_rings.f_map F G) :
  a.comp (presheaf_of_rings.f_map_id G) = a :=
begin
  cases a with f hf f_flat f_flat_is_ring_hom presheaf_f_flat,
  delta presheaf_of_rings.f_map_id presheaf_of_rings.f_map.comp,
  congr, funext V s, dsimp,
  rw ← presheaf_f_flat,
  show _ = id _, apply congr_fun, exact F.to_presheaf.Hid _,
end

end presheaf_of_rings

namespace presheaf_of_topological_rings
variables {F : presheaf_of_topological_rings X} {G : presheaf_of_topological_rings Y} {H : presheaf_of_topological_rings Z}

structure f_map (F : presheaf_of_topological_rings X) (G : presheaf_of_topological_rings Y) :=
(f : X → Y)
(hf : continuous f)
(f_flat : ∀ V : opens Y, G V → F (hf.comap V))
[f_flat_is_ring_hom : ∀ V : opens Y, is_ring_hom (f_flat V)]
(cont_f_flat : ∀ V : opens Y, continuous (f_flat V))
(presheaf_f_flat : ∀ V W : opens Y, ∀ (hWV : W ⊆ V),
  ∀ s : G V, F.res _ _ (hf.comap_mono hWV) (f_flat V s) = f_flat W (G.res V W hWV s))

instance f_map_flat.is_ring_hom (f : presheaf_of_topological_rings.f_map F G) (V : opens Y) :
  is_ring_hom (f.f_flat V) := f.f_flat_is_ring_hom V

attribute [instance] presheaf_of_topological_rings.f_map.f_flat_is_ring_hom

def f_map.to_presheaf_of_rings_f_map
  {X : Type u} [topological_space X] {Y : Type u} [topological_space Y]
  {F : presheaf_of_topological_rings X} {G : presheaf_of_topological_rings Y}
  (f : presheaf_of_topological_rings.f_map F G) :
  presheaf_of_rings.f_map F.to_presheaf_of_rings G.to_presheaf_of_rings :=
{ ..f}

@[ext]
lemma presheaf_of_topological_rings.f_map.ext
  {X : Type u} [topological_space X] {Y : Type u} [topological_space Y]
  {F : presheaf_of_topological_rings X} {G : presheaf_of_topological_rings Y}
  (a b : F.f_map G) (h : a.to_presheaf_of_rings_f_map = b.to_presheaf_of_rings_f_map) :
  a = b :=
begin
  cases a, cases b,
  dsimp [f_map.to_presheaf_of_rings_f_map] at h,
  injections,
  simp [*]
end

@[simp] lemma f_map.to_presheaf_of_rings_f_map_f (f : presheaf_of_topological_rings.f_map F G) :
  f.to_presheaf_of_rings_f_map.f = f.f := rfl

def f_map_id (F : presheaf_of_topological_rings X) :
  presheaf_of_topological_rings.f_map F F :=
{ cont_f_flat := λ U, begin
      show continuous (((F.to_presheaf_of_rings).to_presheaf).res U (continuous.comap continuous_id U) _),
      convert continuous_id,
      { simp [continuous.comap_id U] },
      { simp [continuous.comap_id U] },
      convert heq_of_eq (F.Hid U),
        rw continuous.comap_id U,
      exact continuous.comap_id U,
    end,
  ..presheaf_of_rings.f_map_id F.to_presheaf_of_rings }

@[simp] lemma f_map.to_presheaf_of_rings_f_map_id (F : presheaf_of_topological_rings X) :
  (presheaf_of_topological_rings.f_map_id F).to_presheaf_of_rings_f_map =
  presheaf_of_rings.f_map_id F.to_presheaf_of_rings := rfl

@[simp] lemma f_map_id_apply (F : presheaf_of_topological_rings X) (x : X) :
  (presheaf_of_topological_rings.f_map_id F).f x = x := rfl

def f_map.comp (a : presheaf_of_topological_rings.f_map F G) (b : presheaf_of_topological_rings.f_map G H) :
  presheaf_of_topological_rings.f_map F H :=
{ cont_f_flat := λ V, (a.cont_f_flat _).comp (b.cont_f_flat _),
  .. a.to_presheaf_of_rings_f_map.comp b.to_presheaf_of_rings_f_map }

@[simp] lemma f_map.comp_f (a : presheaf_of_topological_rings.f_map F G) (b : presheaf_of_topological_rings.f_map G H) :
  (a.comp b).f = b.f ∘ a.f := rfl

@[simp] lemma f_map.comp_to_presheaf_of_rings_f_map
  (a : presheaf_of_topological_rings.f_map F G) (b : presheaf_of_topological_rings.f_map G H) :
  (a.comp b).to_presheaf_of_rings_f_map =
  a.to_presheaf_of_rings_f_map.comp b.to_presheaf_of_rings_f_map := rfl

@[simp] lemma f_map.id_comp (a : presheaf_of_topological_rings.f_map F G) :
  (presheaf_of_topological_rings.f_map_id F).comp a = a :=
by ext; simp

@[simp] lemma f_map.comp_id (a : presheaf_of_topological_rings.f_map F G) :
  a.comp (presheaf_of_topological_rings.f_map_id G) = a :=
by ext; simp

end presheaf_of_topological_rings

open_locale classical

/-- The map on stalks induced from an f-map -/
noncomputable def stalk_map {F : presheaf_of_rings X} {G : presheaf_of_rings Y}
  (f : F.f_map G) (x : X) :
  stalk_of_rings G (f.f x) → stalk_of_rings F x :=
to_stalk.rec G (f.f x) (stalk_of_rings F x)
  (λ V hfx s, ⟦⟨f.hf.comap V, hfx, f.f_flat V s⟩⟧)
  (λ V W H r hfx, quotient.sound begin
    use [f.hf.comap V, hfx, set.subset.refl _, f.hf.comap_mono H],
    erw F.to_presheaf.Hid,
    symmetry,
    apply f.presheaf_f_flat
  end )

namespace stalk_map
variables {F : presheaf_of_rings X} {G : presheaf_of_rings Y} {H : presheaf_of_rings Z}
variables (f : F.f_map G) (g : G.f_map H)

instance (F : presheaf_of_rings X) (x : X) :
  comm_ring (quotient (stalk.setoid (F.to_presheaf) x)) :=
stalk_of_rings_is_comm_ring F x

instance f_flat_is_ring_hom (x : X) (V : opens Y) (hfx : f.f x ∈ V) :
  is_ring_hom (λ (s : G.F V), (⟦⟨f.hf.comap V, hfx, f.f_flat V s⟩⟧ : stalk_of_rings F x)) :=
begin
  show is_ring_hom ((to_stalk F x (f.hf.comap V) hfx) ∘ (f.f_flat V)),
  refine is_ring_hom.comp _ _,
end

instance (x : X) : is_ring_hom (stalk_map f x) := to_stalk.rec_is_ring_hom _ _ _ _ _

@[simp] lemma stalk_map_id (F : presheaf_of_rings X) (x : X) (s : stalk_of_rings F x) :
  stalk_map (presheaf_of_rings.f_map_id F) x s = s :=
begin
  induction s,
    apply quotient.sound,
    use s.U,
    use s.HxU,
    use (le_refl s.U),
    use (le_refl s.U),
    symmetry,
    convert (F.to_presheaf.Hcomp' _ _ _ _ _ s.s),
  refl,
end

@[simp] lemma stalk_map_id' (F : presheaf_of_rings X) (x : X) :
  stalk_map (presheaf_of_rings.f_map_id F) x = id := by ext; apply stalk_map_id

lemma stalk_map_comp (x : X) (s : stalk_of_rings H (g.f (f.f x))) :
  stalk_map (f.comp g) x s = stalk_map f x (stalk_map g (f.f x) s) :=
begin
  induction s,
    apply quotient.sound,
    use f.hf.comap (g.hf.comap s.U),
    use s.HxU,
    existsi _, swap, intros t ht, exact ht,
    existsi _, swap, intros t ht, exact ht,
    refl,
  refl,
end

@[simp] lemma stalk_map_comp' (x : X) :
  stalk_map (f.comp g) x = (stalk_map f x) ∘ (stalk_map g (f.f x)) :=
by ext; apply stalk_map_comp

end stalk_map

namespace presheaf_of_rings

def restrict (U : opens X) (G : presheaf_of_rings X) :
  presheaf_of_rings U :=
{ F := λ V, G.F (topological_space.opens.map U V),
  res := λ V W HWV, G.res _ _ (topological_space.opens.map_mono HWV),
  Hid := λ V, G.Hid (topological_space.opens.map U V),
  Hcomp := λ V₁ V₂ V₃ H12 H23, G.Hcomp (topological_space.opens.map U V₁)
    (topological_space.opens.map U V₂) (topological_space.opens.map U V₃)
    (topological_space.opens.map_mono H12) (topological_space.opens.map_mono H23),
  Fring := λ V, G.Fring (topological_space.opens.map U V),
  res_is_ring_hom := λ V W HWV, G.res_is_ring_hom (topological_space.opens.map U V)
    (topological_space.opens.map U W) (topological_space.opens.map_mono HWV) }

variables {U : opens X} (G : presheaf_of_rings X) (u : U)

noncomputable def restrict_stalk_map :
  stalk_of_rings (G.restrict U) u → stalk_of_rings G u :=
to_stalk.rec (G.restrict U) u (stalk_of_rings G u)
  (λ V hu, to_stalk G u (topological_space.opens.map U V) ( opens.map_mem_of_mem hu))
  (λ W V HWV s huW, quotient.sound (begin
    use [(topological_space.opens.map U W), opens.map_mem_of_mem huW],
    use [(set.subset.refl (topological_space.opens.map U W)), topological_space.opens.map_mono HWV],
    rw G.Hid (topological_space.opens.map U W),
    refl,
  end))

instance : is_ring_hom (G.restrict_stalk_map u) :=
by delta restrict_stalk_map; apply_instance

end presheaf_of_rings

def presheaf_of_topological_rings.restrict  (U : opens X) (G : presheaf_of_topological_rings X) :
  presheaf_of_topological_rings U :=
{ Ftop := λ V, G.Ftop (topological_space.opens.map U V),
  Ftop_ring := λ V, G.Ftop_ring (topological_space.opens.map U V),
  res_continuous := λ V W HWV, G.res_continuous (topological_space.opens.map U V)
    (topological_space.opens.map U W) (topological_space.opens.map_mono HWV),
..presheaf_of_rings.restrict U G.to_presheaf_of_rings }


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.ScopedEnvExtension
import Lean.Util.Recognizers
import Lean.Meta.LevelDefEq
import Lean.Meta.DiscrTree
import Lean.Meta.AppBuilder
import Lean.Meta.Tactic.AuxLemma
namespace Lean.Meta

/--
  The fields `levelParams` and `proof` are used to encode the proof of the simp lemma.
  If the `proof` is a global declaration `c`, we store `Expr.const c []` at `proof` without the universe levels, and `levelParams` is set to `#[]`
  When using the lemma, we create fresh universe metavariables.
  Motivation: most simp lemmas are global declarations, and this approach is faster and saves memory.

  The field `levelParams` is not empty only when we elaborate an expression provided by the user, and it contains universe metavariables.
  Then, we use `abstractMVars` to abstract the universe metavariables and create new fresh universe parameters that are stored at the field `levelParams`.
-/
structure SimpLemma where
  keys        : Array DiscrTree.Key := #[]
  levelParams : Array Name := #[] -- non empty for local universe polymorhic proofs.
  proof       : Expr
  priority    : Nat  := eval_prio default
  post        : Bool := true
  perm        : Bool := false -- true is lhs and rhs are identical modulo permutation of variables
  name?       : Option Name := none -- for debugging and tracing purposes
  deriving Inhabited

def SimpLemma.getName (s : SimpLemma) : Name :=
  match s.name? with
  | some n => n
  | none   => "<unknown>"

instance : ToFormat SimpLemma where
  format s :=
    let perm := if s.perm then ":perm" else ""
    let name := format s.getName
    let prio := f!":{s.priority}"
    name ++ prio ++ perm

instance : ToMessageData SimpLemma where
  toMessageData s := format s

instance : BEq SimpLemma where
  beq e₁ e₂ := e₁.proof == e₂.proof

structure SimpLemmas where
  pre         : DiscrTree SimpLemma := DiscrTree.empty
  post        : DiscrTree SimpLemma := DiscrTree.empty
  lemmaNames  : Std.PHashSet Name := {}
  toUnfold    : Std.PHashSet Name := {}
  erased      : Std.PHashSet Name := {}
  deriving Inhabited

def addSimpLemmaEntry (d : SimpLemmas) (e : SimpLemma) : SimpLemmas :=
  if e.post then
    { d with post := d.post.insertCore e.keys e, lemmaNames := updateLemmaNames d.lemmaNames }
  else
    { d with pre := d.pre.insertCore e.keys e, lemmaNames := updateLemmaNames d.lemmaNames }
where
  updateLemmaNames (s : Std.PHashSet Name) : Std.PHashSet Name :=
    match e.name? with
    | none => s
    | some name => s.insert name

def SimpLemmas.addDeclToUnfold (d : SimpLemmas) (declName : Name) : SimpLemmas :=
  { d with toUnfold := d.toUnfold.insert declName }

def SimpLemmas.isDeclToUnfold (d : SimpLemmas) (declName : Name) : Bool :=
  d.toUnfold.contains declName

def SimpLemmas.isLemma (d : SimpLemmas) (declName : Name) : Bool :=
  d.lemmaNames.contains declName

def SimpLemmas.eraseCore [Monad m] [MonadError m] (d : SimpLemmas) (declName : Name) : m SimpLemmas := do
  return { d with erased := d.erased.insert declName, lemmaNames := d.lemmaNames.erase declName, toUnfold := d.toUnfold.erase declName }

def SimpLemmas.erase [Monad m] [MonadError m] (d : SimpLemmas) (declName : Name) : m SimpLemmas := do
  unless d.isLemma declName || d.isDeclToUnfold declName do
    throwError "'{declName}' does not have [simp] attribute"
  d.eraseCore declName

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 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 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 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]

inductive SimpEntry where
  | lemma    : SimpLemma → SimpEntry
  | toUnfold : Name → SimpEntry
  deriving Inhabited

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 simpExtension : SimpExtension ← registerSimpAttr `simp "simplification theorem"

def getSimpLemmas : CoreM SimpLemmas :=
  simpExtension.getLemmas

/- Auxiliary method for adding a global declaration to a `SimpLemmas` datastructure. -/
def SimpLemmas.addConst (s : SimpLemmas) (declName : Name) (post : Bool := true) (inv : Bool := false) (prio : Nat := eval_prio default) : MetaM SimpLemmas := do
  let simpLemmas ← mkSimpLemmasFromConst declName post inv prio
  return simpLemmas.foldl addSimpLemmaEntry s

def SimpLemma.getValue (simpLemma : SimpLemma) : MetaM Expr := do
  if simpLemma.proof.isConst && simpLemma.levelParams.isEmpty then
    let info ← getConstInfo simpLemma.proof.constName!
    if info.levelParams.isEmpty then
      return simpLemma.proof
    else
      return simpLemma.proof.updateConst! (← info.levelParams.mapM (fun _ => mkFreshLevelMVar))
  else
    let us ← simpLemma.levelParams.mapM fun _ => mkFreshLevelMVar
    simpLemma.proof.instantiateLevelParamsArray simpLemma.levelParams us

private def preprocessProof (val : Expr) (inv : Bool) : MetaM (Array Expr) := do
  let type ← inferType val
  checkTypeIsProp type
  let ps ← preprocess val type inv
  return ps.toArray.map fun (val, _) => val

/- Auxiliary method for creating simp lemmas from a proof term `val`. -/
def mkSimpLemmas (levelParams : Array Name) (proof : Expr) (post : Bool := true) (inv : Bool := false) (prio : Nat := eval_prio default) (name? : Option Name := none): MetaM (Array SimpLemma) :=
  withReducible do
    (← preprocessProof proof inv).mapM fun val => mkSimpLemmaCore val levelParams val post prio name?

/- Auxiliary method for adding a local simp lemma to a `SimpLemmas` datastructure. -/
def SimpLemmas.add (s : SimpLemmas) (levelParams : Array Name) (proof : Expr) (inv : Bool := false) (post : Bool := true) (prio : Nat := eval_prio default) (name? : Option Name := none): MetaM SimpLemmas := do
  if proof.isConst then
    s.addConst proof.constName! post inv prio
  else
    let simpLemmas ← mkSimpLemmas levelParams proof post inv prio (← getName? proof)
    return simpLemmas.foldl addSimpLemmaEntry s
where
  getName? (e : Expr) : MetaM (Option Name) := do
    match name? with
    | some _ => return name?
    | none   =>
      let f := e.getAppFn
      if f.isConst then
        return f.constName!
      else if f.isFVar then
        let localDecl ← getFVarLocalDecl f
        return localDecl.userName
      else
        return none

end Lean.Meta


import .expr_zipper
open tactic
universe u
/-- ltb is the same as lt but it goes to a bool rather than a prop to make deriving decidability easier. -/
class has_ltb (α : Type u) := (ltb : α → α → bool)
instance lt_of_ltb (α : Type u) [has_ltb α] : has_lt α := ⟨λ x y, has_ltb.ltb x y⟩
instance dec_lt_of_ltb (α : Type u) [has_ltb α] : decidable_rel ((<) : α → α → Prop) := by apply_instance
instance le_of_ltb (α : Type u) [has_ltb α] : has_le α := ⟨λ x y, x < y ∨ x = y⟩
instance dec_le_of_ltb (α : Type u) [has_ltb α] [decidable_eq α] : decidable_rel ((≤) : α → α → Prop)  := by apply_instance

namespace derivations
/-- An 'inductive argument' is either just a normal argument or a recursive argument.
So for example `@list.cons {α}` is a constructor with two arguments,
one being a normal with type α and the second being recursive.
-/
meta inductive ind_arg
| normal : expr → ind_arg
| recursive (arg : expr) (rr : expr) : ind_arg

meta def map_ind_arg (f : pexpr → pexpr): ind_arg → pexpr
| (ind_arg.normal e) := f $ to_pexpr e
| (ind_arg.recursive _ rr) := to_pexpr rr

meta def ind_arg.pp : ind_arg → tactic format
| (ind_arg.normal a) := pp a >>= pure ∘ (++ "normal ")
| (ind_arg.recursive a b) := pure (λ a b, "rec " ++ a ++ " " ++ b) <*> pp a <*> pp b

meta instance : has_to_tactic_format ind_arg := ⟨ind_arg.pp⟩

/-- Induction but the induction hypotheses are bundled with their respective arguments.
Contrast this with the result of `induction` where all of the arguments are given, followed by the induction hyps
and you don't know immediately whether you are looking at an ind hyp, a normal arg or a recursive arg.
 -/
meta def induction_but_the_recursors_are_kept_with_the_arguments (x : expr)
    : tactic $ list (name × list ind_arg × list (name × expr) ) := do
    xT ← infer_type x,
    cs ← induction x,
    gs ← get_goals,
    es ← (list.zip cs gs).mmap (λ c, do
        ⟨⟨n,ls, ss⟩, g⟩ ← pure c,
        set_goals [g],
        e ← resolve_name n >>= pure ∘ pexpr.mk_explicit >>= to_expr,
        T ← infer_type e,
        (ctx,b) ← pure $ telescope.of_pis T,
        args ← pure $ ls.take $ ctx.length,
        indos ← pure $ ls.drop $ ctx.length,
        ⟨[], acc⟩ ← args.mfoldl (λ p a, do
            ⟨indos, acc⟩ ← pure (p : (list expr) × (list ind_arg)),
            T ← infer_type a,
            if expr.get_app_fn xT = expr.get_app_fn T then do
                h::indos ← pure indos,
                pure (indos, ind_arg.recursive a h :: acc) else
            pure (indos, ind_arg.normal a :: acc)
        ) (indos, []),
        acc ← pure $ acc.reverse,
        pure (n, acc, ss)
    ),
    set_goals gs,
    pure es

/-- Automatically derive `has_to_string` for an inductive datatype. -/
@[derive_handler] meta def to_string_handler :=
instance_derive_handler ``has_to_string $
    do
        e ← get_env,
        split,
        x ← intro `x,
        cs ← induction_but_the_recursors_are_kept_with_the_arguments x,
        cs.mmap (λ c, do
            ⟨n,ls,ss⟩ ← pure c,
            constructor_name ← pure $ reflect $ n.components.ilast,
            if ls.empty then refine $ ```(to_string %%constructor_name) else do
            str ← pure $ list.foldl (λ x y, ```(%%x ++ %%y)) ```("") $ list.intersperse ```( " " ) $ list.map (λ x, ```( "(" ++ %%x ++ ")" )) $ ls.map (map_ind_arg (λ x, ```( to_string %%x))),
            refine $ ```(to_string %%constructor_name ++ " " ++ %%str)
        ),
        pure ()

/-- Helper method for has_to_tactic_format_handler -/
private meta def pp_cases : ind_arg → tactic unit
|(ind_arg.normal x) :=
    refine ```(tactic.pp %%x)
    <|> refine ```(pure $ to_fmt %%x)
    <|> refine ```(pure $ format.of_string $ to_string %%x)
    <|> (do
        ppx ← tactic.pp x,
        T ← tactic.infer_type x,
        ppT ← tactic.pp T,
        msg : format ← pure $ to_fmt "Couldn't find a way of showing " ++ ppx ++ " : " ++ ppT,
        tactic.fail $ msg)
|(ind_arg.recursive x r) := refine ```(%%r)

@[derive_handler] meta def has_to_tactic_format_handler :=
instance_derive_handler ``has_to_tactic_format $ do
    split,
    x ← intro `x,
    cs ← induction_but_the_recursors_are_kept_with_the_arguments x,
    cs.mmap (λ x, do
        ⟨n,ls,ss⟩ ← pure x,
        constructor_name ← pure $ reflect $ n.components.ilast,
        cnp ← pure $ ```(tactic.pp %%constructor_name), -- : tactic format
        if ls.empty then refine cnp else do
        pps ← ls.mmap (λ x, do
            g ← mk_meta_var `(tactic format),
            gs ← get_goals,
            set_goals [g],
            pp_cases x,
            set_goals gs,
            instantiate_mvars g),
        ppl ← pure $ pps.foldr (λ x acc, ```(%%x :: %%acc)) ```([]),
        ppl ← pure $ ```(list.mmap id %%ppl), -- : tactic (list format)
        refine ```(pure (λ cnp ppl, cnp ++ (to_fmt "{")++ (format.group $ format.nest 1 $ format.join $ list.intersperse ("," ++ format.line) ppl) ++ "}") <*> %%cnp <*> %%ppl)
    ),
    pure ()

private meta def lt_cases : (ind_arg × ind_arg) → pexpr → pexpr
| (ind_arg.normal a_h, ind_arg.normal b_h) acc :=
    ```((%%a_h < %%b_h) ∨ ((%%a_h = %%b_h) ∧ %%acc))
| (ind_arg.recursive a_h ai, ind_arg.recursive b_h bi) acc :=
    ```((%%ai %%b_h) ∨ ((%%a_h = %%b_h) ∧ %%acc))
| _ acc := acc

/-- Derive a total ordering for a given inductive datatype. This just puts an ordering on the constructor names and then
compares two terms with the same ctor lexically on their arguments. Useful for enabling the datatype to be
stored in rtrees and other structures which require some total ordering on data.
You should only use this if you don't care about the semantics of `<`.
-/
@[derive_handler] meta def lt_derive_handler :=
instance_derive_handler ``has_lt $ do
    split,
    a ← intro `a,
    a_cs ← induction_but_the_recursors_are_kept_with_the_arguments a,
    a_goals ← get_goals,
    (list.zip a_cs a_goals).mmap (λ c, do
        ⟨⟨a_cn,a_hs,a_subs⟩,g⟩ ← pure c,
        b ← intro `b,
        b_cs ← induction_but_the_recursors_are_kept_with_the_arguments b,
        b_goals ← get_goals,
        bz ← pure $ list.zip b_cs b_goals,
        bz.mmap(λ c, do
            ⟨⟨b_cn,b_hs,b_subs⟩,g⟩ ← pure c,
            if a_cn < b_cn then exact `(true) else
            if a_cn > b_cn then exact `(false) else do
            r ← pure $ list.foldr lt_cases ```(false) $ list.zip a_hs b_hs,
            r ← to_expr r,
            exact r
        )
    ),
    set_goals a_goals,
    pure ()

private meta def ltb_cases : (ind_arg × ind_arg) → pexpr → pexpr
| (ind_arg.normal a_h, ind_arg.normal b_h) acc :=
    ```(bor (%%a_h < %%b_h) (band (to_bool $ %%a_h = %%b_h) %%acc))
| (ind_arg.recursive a_h ai, ind_arg.recursive b_h bi) acc :=
    ```(bor (%%ai %%b_h) (band (to_bool $ %%a_h = %%b_h) %%acc))
| _ acc := acc

@[derive_handler] meta def mk_ltb_instance := instance_derive_handler ``has_ltb $ do
    split,
    a ← intro `a,
    (expr.const typename _) ← infer_type a >>= pure ∘ expr.get_app_fn,
    e ← get_env,
    all_cases ← pure $ environment.constructors_of e typename,
    a_cs ← induction_but_the_recursors_are_kept_with_the_arguments a,
    a_goals ← get_goals,
    (list.zip a_cs a_goals).mmap (λ c, do
        ⟨⟨a_cn,a_hs,a_subs⟩,g⟩ ← pure c,
        a_idx ← pure $ list.find_index (= a_cn) all_cases,
        b ← intro `b,
        b_cs ← induction_but_the_recursors_are_kept_with_the_arguments b,
        b_goals ← get_goals,
        bz ← pure $ list.zip b_cs b_goals,
        bz.mmap(λ c, do
            ⟨⟨b_cn,b_hs,b_subs⟩,g⟩ ← pure c,
            b_idx ← pure $ list.find_index (= b_cn) all_cases,
            if a_idx < b_idx then exact `(tt) else
            if a_idx > b_idx then exact `(ff) else do
            r ← pure $ list.foldr ltb_cases ```(ff) $ list.zip a_hs b_hs,
            r ← to_expr r,
            exact r
        )
    ),
    set_goals a_goals,
    pure ()

/-!
# An example:

```
@[derive decidable_eq, derive has_ltb, derive has_to_tactic_format]
inductive qwerty
| nil : qwerty
| asdf (n : nat) : qwerty
| br (x: qwerty) (n : nat) (y : qwerty) : qwerty
| s : qwerty → qwerty

open qwerty
#eval to_bool $  nil < (asdf 3)
#eval to_bool $ s (asdf 3) < s (asdf 4)
#eval to_bool (br (asdf 3) 2 nil < br (asdf 3) 2 nil)
#eval to_bool $ ((asdf 3) < (asdf 4))
run_cmd (trace $ br (asdf 3) 2 nil)
```
-/
end derivations


/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis

Normalizing casts inside expressions.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.converter.interactive
import Mathlib.tactic.hint
import Mathlib.PostPort

universes l u_1 u_2

namespace Mathlib

/-!
# A tactic for normalizing casts inside expressions

This tactic normalizes casts inside expressions.
It can be thought of as a call to the simplifier with a specific set of lemmas to
move casts upwards in the expression.
It has special handling of numerals and a simple heuristic to help moving
casts "past" binary operators.
Contrary to simp, it should be safe to use as a non-terminating tactic.

The algorithm implemented here is described in the paper
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.

## Important definitions
* `tactic.interactive.norm_cast`
* `tactic.interactive.push_cast`
* `tactic.interactive.exact_mod_cast`
* `tactic.interactive.apply_mod_cast`
* `tactic.interactive.rw_mod_cast`
* `tactic.interactive.assumption_mod_cast`
-/

namespace tactic

/--
Runs `mk_instance` with a time limit.

This is a work around to the fact that in some cases
mk_instance times out instead of failing,
for example: `has_lift_t ℤ ℕ`

`mk_instance_fast` is used when we assume the type class search
should end instantly.
-/
end tactic

namespace norm_cast

/--
Output a trace message if `trace.norm_cast` is enabled.
-/
/--
`label` is a type used to classify `norm_cast` lemmas.
* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
inductive label
where
| elim : label
| move : label
| squash : label

namespace label

/-- Convert `label` into `string`. -/
protected def to_string : label → string :=
  sorry

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

protected instance has_repr : has_repr label :=
  has_repr.mk label.to_string

/-- Convert `string` into `label`. -/
def of_string : string → Option label :=
  sorry

end label

/-- Count how many coercions are at the top of the expression. -/
/-- Count how many coercions are inside the expression, including the top ones. -/
/-- Count how many coercions are inside the expression, excluding the top ones. -/
/--
Classifies a declaration of type `ty` as a `norm_cast` rule.
-/
/-- The cache for `norm_cast` attribute stores three `simp_lemma` objects. -/
/-- Empty `norm_cast_cache`. -/
/-- `add_elim cache e` adds `e` as an `elim` lemma to `cache`. -/
/-- `add_move cache e` adds `e` as a `move` lemma to `cache`. -/
/-- `add_squash cache e` adds `e` as an `squash` lemma to `cache`. -/
/--
The type of the `norm_cast` attribute.
The optional label is used to overwrite the classifier.
-/
/--
Efficient getter for the `@[norm_cast]` attribute parameter that does not call `eval_expr`.

See Note [user attribute parameters].
-/
/--
`add_lemma cache decl` infers the proper `norm_cast` attribute for `decl` and adds it to `cache`.
-/
-- special lemmas to handle the ≥, > and ≠ operators

/--
`mk_cache names` creates a `norm_cast_cache`. It infers the proper `norm_cast` attributes
for names in `names`, and collects the lemmas attributed with specific `norm_cast` attributes.
-/
-- names has the declarations in reverse order

--some special lemmas to handle binary relations

/--
The `norm_cast` attribute.
-/
/-- Classify a declaration as a `norm_cast` rule. -/
/--
Gets the `norm_cast` classification label for a declaration. Applies the
override specified on the attribute, if necessary.
-/
end norm_cast

namespace tactic.interactive

/--
`push_cast` rewrites the expression to move casts toward the leaf nodes.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
Equivalent to `simp only with push_cast`.
Can also be used at hypotheses.

`push_cast` can also be used at hypotheses and with extra simp rules.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```
-/
end tactic.interactive

namespace norm_cast

/-- Prove `a = b` using the given simp set. -/
/-- Prove `a = b` by simplifying using move and squash lemmas. -/
/--
This is the main heuristic used alongside the elim and move lemmas.
The goal is to help casts move past operators by adding intermediate casts.
An expression of the shape: op (↑(x : α) : γ) (↑(y : β) : γ)
is rewritten to:            op (↑(↑(x : α) : β) : γ) (↑(y : β) : γ)
when (↑(↑(x : α) : β) : γ) = (↑(x : α) : γ) can be proven with a squash lemma
-/
/--
Discharging function used during simplification in the "squash" step.

TODO: norm_cast takes a list of expressions to use as lemmas for the discharger
TODO: a tactic to print the results the discharger fails to proove
-/
/--
Core rewriting function used in the "squash" step, which moves casts upwards
and eliminates them.

It tries to rewrite an expression using the elim and move lemmas.
On failure, it calls the splitting procedure heuristic.
-/
/-!
The following auxiliary functions are used to handle numerals.
-/

/--
If possible, rewrite `(n : α)` to `((n : ℕ) : α)` where `n` is a numeral and `α ≠ ℕ`.
Returns a pair of the new expression and proof that they are equal.
-/
/--
If possible, rewrite `((n : ℕ) : α)` to `(n : α)` where `n` is a numeral.
Returns a pair of the new expression and proof that they are equal.
-/
/-- A local variant on `simplify_top_down`. -/
/--
The core simplification routine of `norm_cast`.
-/
/--
A small variant of `push_cast` suited for non-interactive use.

`derive_push_cast extra_lems e` returns an expression `e'` and a proof that `e = e'`.
-/
end norm_cast

namespace tactic

/-- `aux_mod_cast e` runs `norm_cast` on `e` and returns the result. If `include_goal` is true, it
also normalizes the goal. -/
/-- `exact_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to use `e` to close the goal. -/
/-- `apply_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to apply `e`. -/
/-- `assumption_mod_cast` runs `norm_cast` on the goal. For each local hypothesis `h`, it also
normalizes `h` and tries to use that to close the goal. -/
end tactic

namespace tactic.interactive

/--
Normalize casts at the given locations by moving them "upwards".
As opposed to simp, norm_cast can be used without necessarily closing the goal.
-/
/--
Rewrite with the given rules and normalize casts between steps.
-/
/--
Normalize the goal and the given expression, then close the goal with exact.
-/
/--
Normalize the goal and the given expression, then apply the expression to the goal.
-/
/--
Normalize the goal and every expression in the local context, then close the goal with assumption.
-/
end tactic.interactive

namespace conv.interactive

/-- the converter version of `norm_cast' -/
end conv.interactive

-- TODO: move this elsewhere?

theorem ite_cast {α : Sort u_1} {β : Sort u_2} [has_lift_t α β] {c : Prop} [Decidable c] {a : α} {b : α} : ↑(ite c a b) = ite c ↑a ↑b := sorry

/--
The `norm_cast` family of tactics is used to normalize casts inside expressions.
It is basically a simp tactic with a specific set of lemmas to move casts
upwards in the expression.
Therefore it can be used more safely as a non-terminating tactic.
It also has special handling of numerals.

For instance, given an assumption
```lean
a b : ℤ
h : ↑a + ↑b < (10 : ℚ)
```

writing `norm_cast at h` will turn `h` into
```lean
h : a + b < 10
```

You can also use `exact_mod_cast`, `apply_mod_cast`, `rw_mod_cast`
or `assumption_mod_cast`.
Writing `exact_mod_cast h` and `apply_mod_cast h` will normalize the goal and
`h` before using `exact h` or `apply h`.
Writing `assumption_mod_cast` will normalize the goal and for every
expression `h` in the context it will try to normalize `h` and use
`exact h`.
`rw_mod_cast` acts like the `rw` tactic but it applies `norm_cast` between steps.

`push_cast` rewrites the expression to move casts toward the leaf nodes.
This uses `norm_cast` lemmas in the forward direction.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
It is equivalent to `simp only with push_cast`.
It can also be used at hypotheses with `push_cast at h`
and with extra simp lemmas with `push_cast [int.add_zero]`.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```

The implementation and behavior of the `norm_cast` family is described in detail at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
/--
The `norm_cast` attribute should be given to lemmas that describe the


import Structure.Generic.Axioms.Universes

import mathlib4_experiments.Data.Equiv.Basic

set_option autoBoundImplicitLocal false
--set_option pp.universes true

universes u v w

-- We additionally want "sort-like" types to have some concept of "functors" that map instances. Here, we
-- need to reconcile two conflicting requirements:
--
-- * We want a functor `F : α ⟶ β` with `α β : V` to be an instance of `V`, so that we can chain functors
--   as in `α ⟶ β ⟶ γ`.
--
-- * We axiomatically assert the existence of certain functors such as identity and composition, which we
--   assume to map instances in a specific way. We want this mapping to be a definitional equality so that
--   e.g. applying the identity functor is a trivial operation.
--   This implies that "functoriality" should be extra structure on functions, so that we can say that a
--   given function "is functorial".
--
-- In order to meet both requirements, we define both kinds of functors, and write `α ⟶ β` for the first
-- kind and `α ⟶' β` for a bundled version of the second kind, i.e. a function that is functorial. We
-- assert the equivalence of these two kinds of functors as an axiom.
--
-- In the case of `Bundled C`, we can make sure that `α ⟶' β` is actually an instance of the type class
-- `C`, so we can define `α ⟶ β` to be the same as `α ⟶' β`. However, in the case of `Sort u`, `α ⟶' β`
-- is not an instance of `Sort u` if `u = 0` (i.e. `Sort u` is actually `Prop`).
--
-- Moreover, `α ⟶' β` is defined so that `α` and `β` can live in different universes.

class HasExternalFunctors (U : Universe.{u}) (V : Universe.{v}) : Type (max u v) where
(IsFun {α : U} {β : V} : (α → β) → Sort (max u v))

structure BundledFunctor {U : Universe.{u}} {V : Universe.{v}} [h : HasExternalFunctors U V]
                         (α : U) (β : V) : Sort (max 1 u v) where
(f     : α → β)
(isFun : h.IsFun f)

namespace BundledFunctor

  infixr:20 " ⟶' " => BundledFunctor

  variable {U V : Universe} [h : HasExternalFunctors U V]

  instance coeFun (α : U) (β : V) : CoeFun (α ⟶' β) (λ _ => α → β) := ⟨BundledFunctor.f⟩

  def mkFun {α : U} {β : V} {f : α → β} (hf : h.IsFun f) : α ⟶' β := ⟨f, hf⟩

end BundledFunctor

class HasInternalFunctors (U : Universe.{u}) extends HasExternalFunctors U U : Type u where
(Fun                : U → U → U)
(funEquiv (α β : U) : ⌈Fun α β⌉ ≃ (α ⟶' β))

namespace HasInternalFunctors

  infixr:20 " ⟶ " => HasInternalFunctors.Fun

  variable {U : Universe} [h : HasInternalFunctors U]

  def toBundled   {α β : U} (F : α ⟶  β) : α ⟶' β := (h.funEquiv α β).toFun  F
  def fromBundled {α β : U} (F : α ⟶' β) : α ⟶  β := (h.funEquiv α β).invFun F

  @[simp] theorem fromToBundled {α β : U} (F : α ⟶  β) : fromBundled (toBundled F) = F := (h.funEquiv α β).leftInv  F
  @[simp] theorem toFromBundled {α β : U} (F : α ⟶' β) : toBundled (fromBundled F) = F := (h.funEquiv α β).rightInv F

  def funCoe {α β : U} (F : α ⟶ β) : α → β := (toBundled F).f
  instance (α β : U) : CoeFun ⌈α ⟶ β⌉ (λ _ => α → β) := ⟨funCoe⟩

  -- Workaround for cases where `coeFun` doesn't work.
  notation:max F:max "⟮" x:0 "⟯" => HasInternalFunctors.funCoe F x

  def isFun {α β : U} (F : α ⟶ β) : h.IsFun (funCoe F) := (toBundled F).isFun

  theorem toBundled.eff {α β : U} (F : α ⟶ β) (a : α) : (toBundled F) a = F a := rfl

  @[simp] theorem fromBundled.coe {α β : U} (F : α ⟶' β) : funCoe (fromBundled F) = F.f :=
  congrArg BundledFunctor.f (toFromBundled F)
  @[simp] theorem fromBundled.eff {α β : U} (F : α ⟶' β) (a : α) : (fromBundled F) a = F a :=
  congrFun (fromBundled.coe F) a

  def mkFun {α β : U} {f : α → β} (hf : h.IsFun f) : α ⟶ β := fromBundled (BundledFunctor.mkFun hf)

  @[simp] theorem mkFun.eff {α β : U} {f : α → β} (hf : h.IsFun f) (a : α) :
    (mkFun hf) a = f a :=
  fromBundled.eff (BundledFunctor.mkFun hf) a

end HasInternalFunctors

@[simp] theorem elimRec {α : Sort u} {a a' : α} {ha : a = a'}
                        {T : α → Sort v} {x : T a}
                        {β : Sort w} {f : {a : α} → T a → β} :
  @f a' (ha ▸ x) = f x :=
by subst ha; rfl

-- The following axioms are equivalent to asserting the existence of five functors with specified behavior:
-- id    : `α ⟶ α,                           a ↦ a`
-- const : `β ⟶ (α ⟶ β),                     c ↦ (a ↦ c)`
-- app   : `α ⟶ (α ⟶ β) ⟶ β,                 a ↦ (F ↦ F a)`
-- dup   : `(α ⟶ α ⟶ β) ⟶ (α ⟶ β),           F ↦ (a ↦ F a a)`
-- comp  : `(α ⟶ β) ⟶ (β ⟶ γ) ⟶ (α ⟶ γ),     F ↦ (G ↦ (a ↦ G (F a)))`
--
-- In `DerivedFunctors.lean`, we construct several other functors such as
-- swap  : `(α ⟶ β ⟶ γ) ⟶ (β ⟶ α ⟶ γ),       F ↦ (b ↦ (a ↦ F a b))`
-- subst : `(α ⟶ β ⟶ γ) ⟶ (α ⟶ β) ⟶ (α ⟶ γ), F ↦ (G ↦ (a ↦ F a (G a)))`
-- Using these, we can give a general algorithm for proving that a function is functorial.

class HasIdFun (U : Universe) [h : HasExternalFunctors U U] where
(idIsFun (α : U) : h.IsFun (λ a : α => a))

namespace HasIdFun

  variable {U : Universe} [HasExternalFunctors U U] [h : HasIdFun U]

  def idFun' (α : U) : α ⟶' α := BundledFunctor.mkFun (h.idIsFun α)

end HasIdFun

class HasConstFun (U V : Universe) [h : HasExternalFunctors U V] where
(constIsFun (α : U) {β : V} (c : β) : h.IsFun (λ a : α => c))

namespace HasConstFun

  variable {U V : Universe} [HasExternalFunctors U V] [h : HasConstFun U V]

  def constFun' (α : U) {β : V} (c : β) : α ⟶' β := BundledFunctor.mkFun (h.constIsFun α c)

end HasConstFun

class HasCompFun (U V W : Universe) [HasExternalFunctors U V] [HasExternalFunctors V W] [h : HasExternalFunctors U W] where
(compIsFun {α : U} {β : V} {γ : W} (F : α ⟶' β) (G : β ⟶' γ) : h.IsFun (λ a : α => G (F a)))

namespace HasCompFun

  variable {U V W : Universe} [HasExternalFunctors U V] [HasExternalFunctors V W] [HasExternalFunctors U W] [h : HasCompFun U V W]

  def compFun' {α : U} {β : V} {γ : W} (F : α ⟶' β) (G : β ⟶' γ) : α ⟶' γ := BundledFunctor.mkFun (h.compIsFun F G)

  def revCompFun' {α : U} {β : V} {γ : W} (G : β ⟶' γ) (F : α ⟶' β) : α ⟶' γ := compFun' F G
  infixr:90 " ⊙' " => HasCompFun.revCompFun'

end HasCompFun

class HasLinearFunOp (U : Universe) [h : HasInternalFunctors U] extends HasIdFun U, HasCompFun U U U where
(appIsFun        {α : U} (a : α) (β : U)        : h.IsFun (λ F : α ⟶ β     => F a))
(appFunIsFun     (α β : U)                      : h.IsFun (λ a : α         => HasInternalFunctors.mkFun (appIsFun a β)))
(compFunIsFun    {α β : U} (F : α ⟶' β) (γ : U) : h.IsFun (λ G : β ⟶ γ     => HasInternalFunctors.mkFun (compIsFun F (HasInternalFunctors.toBundled G))))
(compFunFunIsFun (α β γ : U)                    : h.IsFun (λ F : α ⟶ β     => HasInternalFunctors.mkFun (compFunIsFun (HasInternalFunctors.toBundled F) γ)))

namespace HasLinearFunOp

  variable {U : Universe} [HasInternalFunctors U] [h : HasLinearFunOp U]

  def idFun' (α : U) : α ⟶' α := HasIdFun.idFun' α
  def idFun  (α : U) : α ⟶  α := HasInternalFunctors.fromBundled (idFun' α)

  @[simp] theorem idFun.eff (α : U) (a : α) : (idFun α) a = a :=
  by apply HasInternalFunctors.fromBundled.eff

  def appFun' {α : U} (a : α) (β : U) : (α ⟶ β) ⟶' β := BundledFunctor.mkFun (h.appIsFun a β)
  def appFun  {α : U} (a : α) (β : U) : (α ⟶ β) ⟶  β := HasInternalFunctors.fromBundled (appFun' a β)

  @[simp] theorem appFun.eff {α : U} (a : α) (β : U) (F : α ⟶ β) : (appFun a β) F = F a :=
  by apply HasInternalFunctors.fromBundled.eff

  def appFunFun' (α β : U) : α ⟶' (α ⟶ β) ⟶ β := BundledFunctor.mkFun (h.appFunIsFun α β)
  def appFunFun  (α β : U) : α ⟶  (α ⟶ β) ⟶ β := HasInternalFunctors.fromBundled (appFunFun' α β)

  @[simp] theorem appFunFun.eff (α β : U) (a : α) : (appFunFun α β) a = appFun a β :=
  by apply HasInternalFunctors.fromBundled.eff
  @[simp] theorem appFunFun.effEff (α β : U) (a : α) (F : α ⟶ β) : ((appFunFun α β) a) F = F a :=
  by simp

  def compFun' {α β γ : U} (F : α ⟶' β) (G : β ⟶' γ) : α ⟶' γ := HasCompFun.compFun' F G
  def compFun  {α β γ : U} (F : α ⟶  β) (G : β ⟶  γ) : α ⟶  γ :=
  HasInternalFunctors.fromBundled (compFun' (HasInternalFunctors.toBundled F) (HasInternalFunctors.toBundled G))

  @[simp] theorem compFun.eff {α β γ : U} (F : α ⟶ β) (G : β ⟶ γ) (a : α) : (compFun F G) a = G (F a) :=
  by apply HasInternalFunctors.fromBundled.eff

  def compFunFun' {α β : U} (F : α ⟶' β) (γ : U) : (β ⟶ γ) ⟶' (α ⟶ γ) := BundledFunctor.mkFun (h.compFunIsFun F γ)
  def compFunFun  {α β : U} (F : α ⟶  β) (γ : U) : (β ⟶ γ) ⟶  (α ⟶ γ) :=
  HasInternalFunctors.fromBundled (compFunFun' (HasInternalFunctors.toBundled F) γ)

  @[simp] theorem compFunFun.eff {α β : U} (F : α ⟶ β) (γ : U) (G : β ⟶ γ) : (compFunFun F γ) G = compFun F G :=
  by apply HasInternalFunctors.fromBundled.eff
  @[simp] theorem compFunFun.effEff {α β : U} (F : α ⟶ β) (γ : U) (G : β ⟶ γ) (a : α) : ((compFunFun F γ) G) a = G (F a) :=
  by simp

  def compFunFunFun' (α β γ : U) : (α ⟶ β) ⟶' (β ⟶ γ) ⟶ (α ⟶ γ) := BundledFunctor.mkFun (h.compFunFunIsFun α β γ)
  def compFunFunFun  (α β γ : U) : (α ⟶ β) ⟶  (β ⟶ γ) ⟶ (α ⟶ γ) := HasInternalFunctors.fromBundled (compFunFunFun' α β γ)

  @[simp] theorem compFunFunFun.eff (α β γ : U) (F : α ⟶ β) : (compFunFunFun α β γ) F = compFunFun F γ :=
  by apply HasInternalFunctors.fromBundled.eff
  @[simp] theorem compFunFunFun.effEff (α β γ : U) (F : α ⟶ β) (G : β ⟶ γ) : ((compFunFunFun α β γ) F) G = compFun F G :=
  by simp
  @[simp] theorem compFunFunFun.effEffEff (α β γ : U) (F : α ⟶ β) (G : β ⟶ γ) (a : α) : (((compFunFunFun α β γ) F) G) a = G (F a) :=
  by simp

end HasLinearFunOp

class HasSubLinearFunOp (U : Universe) [h : HasInternalFunctors U] extends HasConstFun U U where
(constFunIsFun (α β : U) : h.IsFun (λ c : β => HasInternalFunctors.mkFun (constIsFun α c)))

namespace HasSubLinearFunOp

  variable {U : Universe} [HasInternalFunctors U] [h : HasSubLinearFunOp U]

  def constFun' (α : U) {β : U} (c : β) : α ⟶' β := HasConstFun.constFun' α c
  def constFun  (α : U) {β : U} (c : β) : α ⟶  β := HasInternalFunctors.fromBundled (constFun' α c)

  @[simp] theorem constFun.eff (α : U) {β : U} (c : β) (a : α) : (constFun α c) a = c :=
  by apply HasInternalFunctors.fromBundled.eff

  def constFunFun' (α β : U) : β ⟶' (α ⟶ β) := BundledFunctor.mkFun (h.constFunIsFun α β)
  def constFunFun  (α β : U) : β ⟶  (α ⟶ β) := HasInternalFunctors.fromBundled (constFunFun' α β)

  @[simp] theorem constFunFun.eff (α β : U) (c : β) : (constFunFun α β) c = constFun α c :=
  by apply HasInternalFunctors.fromBundled.eff
  @[simp] theorem constFunFun.effEff (α β : U) (c : β) (a : α) : ((constFunFun α β) c) a = c :=
  by simp

end HasSubLinearFunOp

class HasAffineFunOp (U : Universe) [h : HasInternalFunctors U] extends HasLinearFunOp U, HasSubLinearFunOp U

class HasNonLinearFunOp (U : Universe) [h : HasInternalFunctors U] where
(dupIsFun    {α β : U} (F : α ⟶' α ⟶ β) : h.IsFun (λ a : α         => F a a))
(dupFunIsFun (α β : U)                  : h.IsFun (λ F : α ⟶ α ⟶ β => HasInternalFunctors.mkFun (dupIsFun (HasInternalFunctors.toBundled F))))

namespace HasNonLinearFunOp

  variable {U : Universe} [HasInternalFunctors U] [h : HasNonLinearFunOp U]

  def dupFun' {α β : U} (F : α ⟶' α ⟶ β) : α ⟶' β := BundledFunctor.mkFun (h.dupIsFun F)
  def dupFun  {α β : U} (F : α ⟶  α ⟶ β) : α ⟶  β :=
  HasInternalFunctors.fromBundled (dupFun' (HasInternalFunctors.toBundled F))

  @[simp] theorem dupFun.eff {α β : U} (F : α ⟶ α ⟶ β) (a : α) : (dupFun F) a = F a a :=
  by apply HasInternalFunctors.fromBundled.eff

  def dupFunFun' (α β : U) : (α ⟶ α ⟶ β) ⟶' (α ⟶ β) := BundledFunctor.mkFun (h.dupFunIsFun α β)
  def dupFunFun  (α β : U) : (α ⟶ α ⟶ β) ⟶  (α ⟶ β) := HasInternalFunctors.fromBundled (dupFunFun' α β)

  @[simp] theorem dupFunFun.eff (α β : U) (F : α ⟶ α ⟶ β) : (dupFunFun α β) F = dupFun F :=
  by apply HasInternalFunctors.fromBundled.eff
  @[simp] theorem dupFunFun.effEff (α β : U) (F : α ⟶ α ⟶ β) (a : α) : ((dupFunFun α β) F) a = F a a :=
  by simp

end HasNonLinearFunOp

class HasFullFunOp (U : Universe) [h : HasInternalFunctors U] extends HasAffineFunOp U, HasNonLinearFunOp U

class HasFunOp (U : Universe.{u}) extends HasInternalFunctors U, HasFullFunOp U : Type u


/-
Copyright (c) 2018 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.data.finset.basic
import Mathlib.data.multiset.pi
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The cartesian product of finsets
-/

namespace finset

/-! ### pi -/

/-- The empty dependent product function, defined on the empty set. The assumption `a ∈ ∅` is never
satisfied. -/
def pi.empty {α : Type u_1} (β : α → Type u_2) (a : α) (h : a ∈ ∅) : β a := multiset.pi.empty β a h

/-- Given a finset `s` of `α` and for all `a : α` a finset `t a` of `δ a`, then one can define the
finset `s.pi t` of all functions defined on elements of `s` taking values in `t a` for `a ∈ s`.
Note that the elements of `s.pi t` are only partially defined, on `s`. -/
def pi {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α)
    (t : (a : α) → finset (δ a)) : finset ((a : α) → a ∈ s → δ a) :=
  mk (multiset.pi (val s) fun (a : α) => val (t a)) sorry

@[simp] theorem pi_val {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α)
    (t : (a : α) → finset (δ a)) : val (pi s t) = multiset.pi (val s) fun (a : α) => val (t a) :=
  rfl

@[simp] theorem mem_pi {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {s : finset α}
    {t : (a : α) → finset (δ a)} {f : (a : α) → a ∈ s → δ a} :
    f ∈ pi s t ↔ ∀ (a : α) (h : a ∈ s), f a h ∈ t a :=
  multiset.mem_pi (val s) (fun (a : α) => (fun (a : α) => val (t a)) a) f

/-- Given a function `f` defined on a finset `s`, define a new function on the finset `s ∪ {a}`,
equal to `f` on `s` and sending `a` to a given value `b`. This function is denoted
`s.pi.cons a b f`. If `a` already belongs to `s`, the new function takes the value `b` at `a`
anyway. -/
def pi.cons {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α) (a : α) (b : δ a)
    (f : (a : α) → a ∈ s → δ a) (a' : α) (h : a' ∈ insert a s) : δ a' :=
  multiset.pi.cons (val s) a b f a' sorry

@[simp] theorem pi.cons_same {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α)
    (a : α) (b : δ a) (f : (a : α) → a ∈ s → δ a) (h : a ∈ insert a s) : pi.cons s a b f a h = b :=
  multiset.pi.cons_same (pi.cons._proof_1 s a a h)

theorem pi.cons_ne {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {s : finset α} {a : α} {a' : α}
    {b : δ a} {f : (a : α) → a ∈ s → δ a} {h : a' ∈ insert a s} (ha : a ≠ a') :
    pi.cons s a b f a' h = f a' (or.resolve_left (iff.mp mem_insert h) (ne.symm ha)) :=
  multiset.pi.cons_ne (pi.cons._proof_1 s a a' h) (ne.symm ha)

theorem pi_cons_injective {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {a : α} {b : δ a}
    {s : finset α} (hs : ¬a ∈ s) : function.injective (pi.cons s a b) :=
  sorry

@[simp] theorem pi_empty {α : Type u_1} {δ : α → Type u_2} [DecidableEq α]
    {t : (a : α) → finset (δ a)} : pi ∅ t = singleton (pi.empty δ) :=
  rfl

@[simp] theorem pi_insert {α : Type u_1} {δ : α → Type u_2} [DecidableEq α]
    [(a : α) → DecidableEq (δ a)] {s : finset α} {t : (a : α) → finset (δ a)} {a : α}
    (ha : ¬a ∈ s) :
    pi (insert a s) t = finset.bUnion (t a) fun (b : δ a) => image (pi.cons s a b) (pi s t) :=
  sorry

theorem pi_singletons {α : Type u_1} [DecidableEq α] {β : Type u_2} (s : finset α) (f : α → β) :
    (pi s fun (a : α) => singleton (f a)) = singleton fun (a : α) (_x : a ∈ s) => f a :=
  sorry

theorem pi_const_singleton {α : Type u_1} [DecidableEq α] {β : Type u_2} (s : finset α) (i : β) :
    (pi s fun (_x : α) => singleton i) = singleton fun (_x : α) (_x : _x ∈ s) => i :=
  pi_singletons s fun (_x : α) => i

theorem pi_subset {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {s : finset α}
    (t₁ : (a : α) → finset (δ a)) (t₂ : (a : α) → finset (δ a))
    (h : ∀ (a : α), a ∈ s → t₁ a ⊆ t₂ a) : pi s t₁ ⊆ pi s t₂ :=
  fun (g : (a : α) → a ∈ s → δ a) (hg : g ∈ pi s t₁) =>
    iff.mpr mem_pi fun (a : α) (ha : a ∈ s) => h a ha (iff.mp mem_pi hg a ha)

theorem pi_disjoint_of_disjoint {α : Type u_1} [DecidableEq α] {δ : α → Type u_2}
    [(a : α) → DecidableEq (δ a)] {s : finset α} [DecidableEq ((a : α) → a ∈ s → δ a)]
    (t₁ : (a : α) → finset (δ a)) (t₂ : (a : α) → finset (δ a)) {a : α} (ha : a ∈ s)
    (h : disjoint (t₁ a) (t₂ a)) : disjoint (pi s t₁) (pi s t₂) :=
  sorry

end Mathlib


import classes.unrestricted.basics.toolbox
import utilities.list_utils

section functions_lift_sink

variables {T N₀ N : Type}

def lift_symbol_ (lift_N : N₀ → N) : symbol T N₀ → symbol T N
| (symbol.terminal t)    := symbol.terminal t
| (symbol.nonterminal n) := symbol.nonterminal (lift_N n)

def sink_symbol_ (sink_N : N → option N₀) : symbol T N → option (symbol T N₀)
| (symbol.terminal t)    := some (symbol.terminal t)
| (symbol.nonterminal n) := option.map symbol.nonterminal (sink_N n)

def lift_string_ (lift_N : N₀ → N) : list (symbol T N₀) → list (symbol T N) :=
list.map (lift_symbol_ lift_N)

def sink_string_ (sink_N : N → option N₀) : list (symbol T N) → list (symbol T N₀) :=
list.filter_map (sink_symbol_ sink_N)

def lift_rule_ (lift_N : N₀ → N) : grule T N₀ → grule T N :=
λ r : grule T N₀, grule.mk
  (lift_string_ lift_N r.input_L)
  (lift_N r.input_N)
  (lift_string_ lift_N r.input_R)
  (lift_string_ lift_N r.output_string)

end functions_lift_sink

section lifting_conditions

structure lifted_grammar_ (T : Type) :=
(g₀ g : grammar T)
(lift_nt : g₀.nt → g.nt)
(sink_nt : g.nt → option g₀.nt)
(lift_inj : function.injective lift_nt)
(sink_inj : ∀ x y, sink_nt x = sink_nt y →
  x = y  ∨  sink_nt x = none
)
(lift_nt_sink : ∀ n₀ : g₀.nt, sink_nt (lift_nt n₀) = some n₀)
(corresponding_rules : ∀ r : grule T g₀.nt,
  r ∈ g₀.rules →
    lift_rule_ lift_nt r ∈ g.rules
)
(preimage_of_rules : ∀ r : grule T g.nt,
  (r ∈ g.rules ∧ ∃ n₀ : g₀.nt, lift_nt n₀ = r.input_N) →
    (∃ r₀ ∈ g₀.rules, lift_rule_ lift_nt r₀ = r)
)

private lemma lifted_grammar_inverse {T : Type} (lg : lifted_grammar_ T) :
  ∀ x : lg.g.nt,
    (∃ val, lg.sink_nt x = some val) →
      option.map lg.lift_nt (lg.sink_nt x) = x :=
begin
  intros x h,
  cases h with valu ass,
  rw ass,
  rw option.map_some',
  apply congr_arg,
  symmetry,
  by_contradiction,
  have inje := lg.sink_inj x (lg.lift_nt valu),
  rw lg.lift_nt_sink at inje,
  cases inje ass with case_valu case_none,
  {
    exact h case_valu,
  },
  rw ass at case_none,
  exact option.no_confusion case_none,
end

end lifting_conditions

section translating_derivations

variables {T : Type}

private lemma lift_tran_ {lg : lifted_grammar_ T} {w₁ w₂ : list (symbol T lg.g₀.nt)}
    (hyp : grammar_transforms lg.g₀ w₁ w₂) :
  grammar_transforms lg.g (lift_string_ lg.lift_nt w₁) (lift_string_ lg.lift_nt w₂) :=
begin
  rcases hyp with ⟨r, rin, u, v, bef, aft⟩,
  use lift_rule_ lg.lift_nt r,
  split,
  {
    exact lg.corresponding_rules r rin,
  },
  use lift_string_ lg.lift_nt u,
  use lift_string_ lg.lift_nt v,
  split,
  {
    have lift_bef := congr_arg (lift_string_ lg.lift_nt) bef,
    unfold lift_string_ at *,
    rw list.map_append_append at lift_bef,
    rw list.map_append_append at lift_bef,
    exact lift_bef,
  },
  {
    have lift_aft := congr_arg (lift_string_ lg.lift_nt) aft,
    unfold lift_string_ at *,
    rw list.map_append_append at lift_aft,
    exact lift_aft,
  },
end

lemma lift_deri_ (lg : lifted_grammar_ T) {w₁ w₂ : list (symbol T lg.g₀.nt)}
    (hyp : grammar_derives lg.g₀ w₁ w₂) :
  grammar_derives lg.g (lift_string_ lg.lift_nt w₁) (lift_string_ lg.lift_nt w₂) :=
begin
  induction hyp with u v trash orig ih,
  {
    apply grammar_deri_self,
  },
  apply grammar_deri_of_deri_tran,
  {
    exact ih,
  },
  exact lift_tran_ orig,
end

def good_letter_ {lg : lifted_grammar_ T} : symbol T lg.g.nt → Prop
| (symbol.terminal t)    := true
| (symbol.nonterminal n) := (∃ n₀ : lg.g₀.nt, lg.sink_nt n = n₀)

def good_string_ {lg : lifted_grammar_ T} (s : list (symbol T lg.g.nt)) :=
∀ a ∈ s, good_letter_ a

private lemma sink_tran_ {lg : lifted_grammar_ T} {w₁ w₂ : list (symbol T lg.g.nt)}
    (hyp : grammar_transforms lg.g w₁ w₂)
    (ok_input : good_string_ w₁) :
  grammar_transforms lg.g₀ (sink_string_ lg.sink_nt w₁) (sink_string_ lg.sink_nt w₂)
  ∧ good_string_ w₂ :=
begin
  rcases hyp with ⟨r, rin, u, v, bef, aft⟩,

  rcases lg.preimage_of_rules r (by {
    split,
    {
      exact rin,
    },
    rw bef at ok_input,
    have good_matched_nonterminal : good_letter_ (symbol.nonterminal r.input_N),
    {
      apply ok_input (symbol.nonterminal r.input_N),
      apply list.mem_append_left,
      apply list.mem_append_left,
      apply list.mem_append_right,
      rw list.mem_singleton,
    },
    change ∃ n₀ : lg.g₀.nt, lg.sink_nt r.input_N = some n₀ at good_matched_nonterminal,
    cases good_matched_nonterminal with n₀ hn₀,
    use n₀,
    have almost := congr_arg (option.map lg.lift_nt) hn₀,
    rw lifted_grammar_inverse lg r.input_N ⟨n₀, hn₀⟩ at almost,
    rw option.map_some' at almost,
    apply option.some_injective,
    exact almost.symm,
  }) with ⟨r₀, pre_in, preimage⟩,

  split, swap,
  {
    rw bef at ok_input,
    rw aft,
    unfold good_string_ at ok_input ⊢,
    rw ←preimage,
    clear_except ok_input,
    rw list.forall_mem_append_append at ok_input ⊢,
    rw list.forall_mem_append_append at ok_input,
    split,
    {
      exact ok_input.1.1,
    },
    split, swap,
    {
      exact ok_input.2.2,
    },
    intros a a_in_ros,
    cases a,
    {
      clear_except,
      unfold good_letter_,
    },
    unfold lift_rule_ at a_in_ros,
    dsimp only at a_in_ros,
    unfold lift_string_ at a_in_ros,
    rw list.mem_map at a_in_ros,
    rcases a_in_ros with ⟨s, trash, a_from_s⟩,
    rw ←a_from_s,
    cases s,
    {
      exfalso,
      clear_except a_from_s,
      unfold lift_symbol_ at a_from_s,
      exact symbol.no_confusion a_from_s,
    },
    unfold lift_symbol_,
    unfold good_letter_,
    use s,
    exact lg.lift_nt_sink s,
  },
  use r₀,
  split,
  {
    exact pre_in,
  },
  use sink_string_ lg.sink_nt u,
  use sink_string_ lg.sink_nt v,
  have correct_inverse : sink_symbol_ lg.sink_nt ∘ lift_symbol_ lg.lift_nt = option.some,
  {
    ext1,
    cases x,
    {
      refl,
    },
    rw function.comp_app,
    unfold lift_symbol_,
    unfold sink_symbol_,
    rw lg.lift_nt_sink,
    apply option.map_some',
  },
  split,
  {
    have sink_bef := congr_arg (sink_string_ lg.sink_nt) bef,
    unfold sink_string_ at *,
    rw list.filter_map_append_append at sink_bef,
    rw list.filter_map_append_append at sink_bef,
    convert sink_bef;
    rw ←preimage;
    unfold lift_rule_;
    dsimp only;
    clear_except correct_inverse,
    {
      unfold lift_string_,
      rw list.filter_map_map,
      rw correct_inverse,
      rw list.filter_map_some,
    },
    {
      change
        [symbol.nonterminal r₀.input_N] =
        list.filter_map (sink_symbol_ lg.sink_nt)
          (list.map (lift_symbol_ lg.lift_nt) [symbol.nonterminal r₀.input_N]),
      rw list.filter_map_map,
      rw correct_inverse,
      rw list.filter_map_some,
    },
    {
      unfold lift_string_,
      rw list.filter_map_map,
      rw correct_inverse,
      rw list.filter_map_some,
    },
  },
  {
    have sink_aft := congr_arg (sink_string_ lg.sink_nt) aft,
    unfold sink_string_ at *,
    rw list.filter_map_append_append at sink_aft,
    convert sink_aft,
    rw ←preimage,
    clear_except correct_inverse,
    unfold lift_rule_,
    dsimp only,
    unfold lift_string_,
    rw list.filter_map_map,
    rw correct_inverse,
    rw list.filter_map_some,
  },
end

private lemma sink_deri_aux {lg : lifted_grammar_ T} {w₁ w₂ : list (symbol T lg.g.nt)}
    (hyp : grammar_derives lg.g w₁ w₂)
    (ok_input : good_string_ w₁) :
  grammar_derives lg.g₀ (sink_string_ lg.sink_nt w₁) (sink_string_ lg.sink_nt w₂)
  ∧ good_string_ w₂ :=
begin
  induction hyp with u v trash orig ih,
  {
    split,
    {
      apply grammar_deri_self,
    },
    {
      exact ok_input,
    },
  },
  have both := sink_tran_ orig ih.2,

  split, swap,
  {
    exact both.2,
  },
  apply grammar_deri_of_deri_tran,
  {
    exact ih.1,
  },
  {
    exact both.1,
  },
end

lemma sink_deri_ (lg : lifted_grammar_ T) {w₁ w₂ : list (symbol T lg.g.nt)}
    (hyp : grammar_derives lg.g w₁ w₂)
    (ok_input : good_string_ w₁) :
  grammar_derives lg.g₀ (sink_string_ lg.sink_nt w₁) (sink_string_ lg.sink_nt w₂) :=
begin
  exact (sink_deri_aux hyp ok_input).1
end

end translating_derivations


import data.cpi.name
import data.list.witness

namespace cpi

/-- A telescope may extend a context by 0 or 1 levels. This is effectively a
    function on contexts, but having it be inductive allows us to case split on
    it, simplifying some proofs. -/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive telescope : Type
| extend : ℕ → telescope
| preserve : telescope

/-- Apply a telescope to a context. -/
def telescope.apply : telescope → context → context
| (telescope.extend n) Γ := context.extend n Γ
| telescope.preserve Γ := Γ

/-- A prefix expression. This can either be one of:

  - A communication prefix (send a series of variables on a channel, and then
    recieve, binding $n$ variables).

  - A spontaneous or silent prefix: a spontaneous reaction with some rate $k$.
    Used to model when a molecule may decompose into a simpler one.

  The prefix is parameterised by two types: the context it exists in, a function
  which augments an arbitrary context with variables bound by this prefix.

  While it is possible to do without the second parameter, this introduces many
  complexities to the proof when renaming, as you need to
  `augment (rename π) = augment π', while preserving type safety.
-/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive prefix_expr (ℍ : Type) : context → telescope → Type
| communicate {} {Γ} (a :  name Γ) (b : list (name Γ)) (y : ℕ) : prefix_expr Γ (telescope.extend y)
| spontaneous {} {Γ} (k : ℍ) : prefix_expr Γ telescope.preserve

variables {ℍ : Type}

-- Define some additional notation, and sugar
notation a `#(` b ` ; ` y `)` := prefix_expr.communicate a b y
notation a `#(` y `)` := prefix_expr.communicate a [] y
notation a `#⟨` b `⟩` := prefix_expr.communicate a b 0
notation a `#` := prefix_expr.communicate a [] 0

notation `τ@`:max k:max := prefix_expr.spontaneous k

namespace prefix_expr
  /-- Convert a prefix expression to a string. Can use `repr` normally. -/
  protected def to_string [has_repr ℍ] {Γ} : ∀ {f}, prefix_expr ℍ Γ f → string
  | ._ (a #( []; 0)) := repr a ++ "#"
  | ._ (a #( b; 0)) := repr a ++ "#<  " ++ repr b ++ "⟩"
  | ._ (a #( []; y)) := repr a ++ "#(" ++ repr y ++ ")"
  | ._ (a #( b; y)) := repr a ++ "#(" ++ repr b ++ ";" ++ repr y ++ ")"
  | ._ (τ@ k) := "τ@" ++ repr k

  instance [has_repr ℍ] {Γ f} : has_repr (prefix_expr ℍ Γ f) := ⟨ prefix_expr.to_string ⟩

  /-- A wrapper for prefixed expressions, which hides the extension function.

      This is suitable for comparing prefixes. -/
  @[nolint has_inhabited_instance]
  inductive wrap (ℍ : Type) : context → Type
  | intro {} {Γ} {f} (π : prefix_expr ℍ Γ f) : wrap Γ

  section free
    /-- Determine if any variable with a given level occurs within this prefix.
    -/
    def free_in : ∀ {Γ} {f}, level Γ → prefix_expr ℍ Γ f → Prop
    | ._ ._ l (a#(b; y)) := l ∈ a ∨ ∃ x ∈ b, l ∈ x
    | ._ ._ l τ@_ := false

    instance {Γ} {f} : has_mem (level Γ) (prefix_expr ℍ Γ f) := ⟨ free_in ⟩

    private def free_in_decide : ∀ {Γ} {f}
      (l : level Γ) (π : prefix_expr ℍ Γ f), decidable (free_in l π)
    | Γ ._ l (a#(b; y)) := if h : l ∈ a ∨ ∃ x ∈ b, l ∈ x then is_true h else is_false h
    | ._ ._ l τ@_ := decidable.false

    instance free_in.decidable {Γ} {f} {l} {π : prefix_expr ℍ Γ f}
      : decidable (free_in l π)
      := free_in_decide l π
  end free

  /- Renaming and extension.

      The extension sections are largely similar to that in data.cpi.name - see
      there for an explanation of some of the decisions made. -/
  section rename
    /-- Raise a level according to this prefix's context extension function. -/
    def raise :
      ∀ {Γ η} {f} (π : prefix_expr ℍ η f)
      , level Γ → level (f.apply Γ)
    | Γ ._ ._ (a#(b; y)) l := level.extend l
    | Γ ._ ._ τ@_ l := l

    /-- Rename all names within a prefix expression, providing some witness that
        this variable is free within it. -/
    def rename_with {Γ Δ} :
      Π {f} (π : prefix_expr ℍ Γ f)
      , (Π (a : name Γ), name.to_level a ∈ π → name Δ) → prefix_expr ℍ Δ f
    | f (a#(b; y)) ρ :=
      let a' := ρ a (or.inl (name.to_level_at a)) in
      let b' := list.map_witness b
        (λ x mem, ρ x (or.inr ⟨ x, mem, name.to_level_at x ⟩))
      in
      a'#( b' ; y)
    | f τ@k ρ := τ@k

    /-- Simple renaming function, not taking any witness. -/
    @[reducible]
    def rename {Γ Δ} {f} (ρ : name Γ → name Δ) (π : prefix_expr ℍ Γ f)
      : prefix_expr ℍ Δ f
      := rename_with π (λ a _, ρ a)

    /-- Renaming with the identity function does nothing. -/
    lemma rename_with_id {Γ} : ∀ {f} (π : prefix_expr ℍ Γ f)
      , rename_with π (λ a _, a) = π
    | ._ (a#(b; y)) := by simp [rename_with]
    | ._ τ@k := rfl

    /-- Renaming with the identity function is the identity. -/
    lemma rename_id {Γ} {f} (π : prefix_expr ℍ Γ f) : rename id π = π
      := rename_with_id π

    /-- Renaming twice is the same as renaming with a composed function. -/
    lemma rename_with_compose {Γ Δ η} :
      ∀ {f} (π : prefix_expr ℍ Γ f)
        (ρ : Π (a : name Γ), name.to_level a ∈ π → name Δ)
        (σ : name Δ → name η)
      , rename σ (rename_with π ρ) = rename_with π (λ a free, σ (ρ a free))
    | f (a#(b; y)) ρ σ := by simp [rename_with, rename, list.map_witness_to_map]
    | f (τ@_) ρ σ := rfl

    /-- Renaming twice is the same as renaming with a composed function. -/
    lemma rename_compose {Γ Δ η} {f}
        (π : prefix_expr ℍ Γ f) (ρ : name Γ → name Δ) (σ : name Δ → name η)
      : rename σ (rename ρ π) = rename (σ ∘ ρ) π
    := rename_with_compose π _ _

    /-- Wrap a renaming function, making it suitable for a nested context. -/
    def ext_with {Γ Δ η} :
      ∀ {f} (π : prefix_expr ℍ η f)
        (P : level (f.apply Γ) → Prop)
        (ρ : Π (x : name Γ), P (prefix_expr.raise π (name.to_level x)) → name Δ)
      , Π (x : name (f.apply Γ)), P (name.to_level x) → name (f.apply Δ)
    | f (_#(_; y)) P ρ a p := name.ext_with P ρ a p
    | f τ@_ P ρ a p := ρ a p

    /-- Extending with the identity does nothing. -/
    lemma ext_with_identity :
      ∀ {Γ η} {f} (π : prefix_expr ℍ η f)
        (P : level (f.apply Γ) → Prop)
        (a : name (f.apply Γ)) (p : P (name.to_level a))
      , ext_with π P (λ x _, x) a p = a
    | Γ η ._ (_#(_; _)) P a p := name.ext_with_identity P a p
    | Γ η ._ τ@k P a p := rfl

    /-- Extending with the identity does nothing. -/
    lemma ext_with_id {Γ η} {f}
        (π : prefix_expr ℍ η f) (P : level (f.apply Γ) → Prop)
      : ext_with π P (λ x _, x) = λ x _, x
      := funext $ λ a, funext (ext_with_identity π P a)

    /-- Wrap a simple renaming function, making it suitable for a nested context. -/
    def ext {Γ Δ η} {f} (π : prefix_expr ℍ η f) (ρ : name Γ → name Δ)
          : name (f.apply Γ) → name (f.apply Δ)
    | a := ext_with π (λ _, true) (λ x _, ρ x) a true.intro

    /-- Extending with the identity does nothing. -/
    lemma ext_identity {Γ η} {f} (π : prefix_expr ℍ η f) (a : name (f.apply Γ))
      : ext π id a = a := ext_with_identity π _ a _

    /-- Extending with the identity yields the identity function. -/
    lemma ext_id : ∀ {Γ η} {f} (π : prefix_expr ℍ η f), @ext ℍ Γ Γ η f π id = id
    | Γ η f π := funext (ext_identity π)

    /-- Composing extensions is equivalent extending a composition. -/
    lemma ext_with_compose :
      ∀ {Γ Δ η φ} {f} (π : prefix_expr ℍ φ f)
        (P : level (f.apply Γ) → Prop)
        (ρ : Π (x : name Γ), P (raise π (name.to_level x)) → name Δ)
        (σ : name Δ → name η)
        (a : name (f.apply Γ)) (p : P (name.to_level a))
      , ext π σ (ext_with π P ρ a p) = ext_with π P (λ a p, σ (ρ a p)) a p
    | Γ Δ η φ f (_#(_;_)) P ρ σ a p := name.ext_with_compose P ρ σ a p
    | Γ Δ η φ f τ@_ P ρ σ _ _ := rfl

    /-- Composing extensions is equivalent extending a composition. -/
    lemma ext_with_comp {Γ Δ η φ} {f} (π : prefix_expr ℍ φ f)
        (P : level (f.apply Γ) → Prop)
        (ρ : Π (x : name Γ), P (raise π (name.to_level x)) → name Δ)
        (σ : name Δ → name η)
      : (λ a p, ext π σ (ext_with π P ρ a p)) = ext_with π P (λ a p, σ (ρ a p))
      := funext $ λ a, funext (ext_with_compose π P ρ σ a)

    /-- Composing extensions is equivalent extending a composition. -/
    lemma ext_compose :
      ∀ {Γ Δ η φ} {f} (ρ : name Γ → name Δ) (σ : name Δ → name η)
        (π : prefix_expr ℍ φ f) (α : name (f.apply Γ))
      , ext π σ (ext π ρ α) = ext π (σ ∘ ρ) α
    | Γ Δ η φ f ρ σ (a#(b; y)) α := name.ext_compose ρ σ α
    | Γ Δ η φ f ρ σ τ@k α := rfl

    /-- Composing extensions is equivalent extending a composition. -/
    lemma ext_comp :
      ∀ {Γ Δ η φ} {f} (ρ : name Γ → name Δ) (σ : name Δ → name η)
        (π : prefix_expr ℍ φ f)
      , (ext π σ ∘ ext π ρ) = ext π (σ ∘ ρ)
    | Γ Δ η φ f ρ σ π := funext (ext_compose ρ σ π)

    /-- Rewrite one ext_with to another -/
    lemma ext_with_discard :
      ∀ {Γ Δ η} {f} (π : prefix_expr ℍ η f)
        (P : level (f.apply Γ) → Prop)
        (ρ : name Γ → name Δ)
      , (ext_with π P (λ a _, ρ a))
      = (λ a _, ext_with π (λ _x, true) (λ x _, ρ x) a true.intro)
    | Γ Δ η f (a'#(b; y)) P ρ := funext $ λ a, funext $ λ free, begin
        have : (λ (a : name Γ) (_x : P (@raise ℍ _ _ _ (a'#(b ; y)) (name.to_level a))), ρ a)
             = (λ (a : name Γ) (_x : P (level.extend (name.to_level a))), ρ a)
             := rfl,
        unfold ext_with,
        rw [this, name.ext_with_discard P],
        from rfl,
      end
    | Γ Δ η f τ@_ P ρ := funext $ λ a, funext $ λ free, rfl

    /-- Raising with a renamed prefix has the same effect as the original one. -/
    lemma rename_with_raise
        {Γ Δ η} {f} (π : prefix_expr ℍ Γ f)
        (ρ : Π (x : name Γ), name.to_level x ∈ π → name Δ)
        (l : level η)
      : raise π l = raise (rename_with π ρ) l
      := by { cases π; from rfl }

    /-- Extending with a renamed prefix has the same effect as the original one. -/
    lemma rename_with_ext_with
        {Γ Δ η φ} {f} (π : prefix_expr ℍ η f)
        (P : level (f.apply Γ) → Prop)
        (ρ : name Γ → name Δ)
        (σ : Π (x : name η), name.to_level x ∈ π → name φ)
      : ext_with (rename_with π σ) P (λ a _, ρ a) = ext_with π P (λ a _, ρ a)
      := funext $ λ a, funext $ λ free, by { cases π; from rfl }

    /-- Extending with a renamed prefix has the same effect as the original one. -/
    lemma rename_ext
        {Γ Δ η φ} {f} (ρ : name Γ → name Δ) (σ : name η → name φ)
        (π : prefix_expr ℍ Γ f)
      : @ext ℍ η φ Γ f π σ = (ext (rename ρ π) σ)
      := funext $ λ a, by { cases π; from rfl }
  end rename

  section rename_equations
    variables {Γ Δ : context} {ρ : name Γ → name Δ}

    @[simp]
    lemma rename_communicate (a :  name Γ) (b : list (name Γ)) (y : ℕ)
      : rename ρ (a#(b; y) : prefix_expr ℍ _ _) = ((ρ a)#(list.map ρ b; y))
      := by simp [rename, rename_with, list.map_witness_to_map]

    @[simp]
    lemma rename_spontaneous (k : ℍ)
      : rename ρ τ@k = τ@k
      := by simp only [rename, rename_with]

    @[simp]
    lemma ext_communicate {η} (a :  name η) (b : list (name η)) (y : ℕ)
      : ext (a#(b; y) : prefix_expr ℍ _ _) ρ = name.ext ρ
      := funext $ λ x, by { unfold ext ext_with, from rfl }

    @[simp]
    lemma ext_spontaneous {η} (k : ℍ)
      : ext (@spontaneous ℍ η k) ρ = ρ
      := funext $ λ x, by unfold ext ext_with

    private lemma rename_inj {Γ Δ} {ρ : name Γ → name Δ} (inj : function.injective ρ)
      : ∀ {f₁ f₂} {π₁ : prefix_expr ℍ Γ f₁} {π₂ : prefix_expr ℍ Γ f₂}
      , wrap.intro (rename ρ π₁) = wrap.intro (rename ρ π₂)
      → π₁ == π₂
    | _ _ (a#(b; y)) (a'#(b'; y')) eq := begin
        simp only [rename_communicate] at eq,
        rcases eq with ⟨ ⟨ _ ⟩, eqπ ⟩,
        simp only [heq_iff_eq] at eqπ ⊢,
        from ⟨ inj eqπ.left, list.injective_map_iff.mpr inj eqπ.right ⟩,
      end
    | _ _ (a#(b; y)) τ@k eq := begin
      simp only [rename_communicate, rename_spontaneous] at eq,
      exfalso, from eq.1,
    end
    | _ _ τ@k (a#(b; y)) eq := begin
        simp only [rename_communicate, rename_spontaneous] at eq,
        exfalso, from eq.1,
      end
    | _ _ τ@k τ@k' eq := begin
        simp only [rename_spontaneous] at eq,
        rcases eq with ⟨ eqC, eqπ ⟩,
        cases eqπ, from heq.refl _,
      end

    lemma rename.inj {Γ Δ} {ρ : name Γ → name Δ} (inj : function.injective ρ)
      : ∀ {f}, function.injective (@rename ℍ Γ Δ f ρ)
    | f π₁ π₂ eq := eq_of_heq (rename_inj inj (congr_arg wrap.intro eq))

    lemma ext.inj {Γ Δ η} {ρ : name Γ → name Δ}
      : ∀ {f} (π : prefix_expr ℍ η f), function.injective ρ → function.injective (ext π ρ)
    | ._ (_#(_; y)) inj a b eq := begin
        simp only [ext_communicate] at eq,
        from name.ext.inj inj eq,
      end
    | ._ (τ@_) inj a b eq := by { simp only [ext_spontaneous] at eq, from inj eq, }
  end rename_equations
end prefix_expr

end cpi

#lint-


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.control
import init.meta.simp_tactic
import init.meta.smt.congruence_closure
import init.meta.smt.ematch

universe u

run_cmd mk_simp_attr `pre_smt
run_cmd mk_hinst_lemma_attr_set `ematch [] [`ematch_lhs]

/--
  Configuration for the smt tactic preprocessor. The preprocessor
  is applied whenever a new hypothesis is introduced.

  - simp_attr: is the attribute name for the simplification lemmas
    that are used during the preprocessing step.

  - max_steps: it is the maximum number of steps performed by the simplifier.

  - zeta: if tt, then zeta reduction (i.e., unfolding let-expressions)
    is used during preprocessing.
-/
structure smt_pre_config :=
(simp_attr : name := `pre_smt)
(max_steps : nat  := 1000000)
(zeta      : bool := ff)

/--
Configuration for the smt_state object.

- em_attr: is the attribute name for the hinst_lemmas
  that are used for ematching -/
structure smt_config :=
(cc_cfg        : cc_config      := {})
(em_cfg        : ematch_config  := {})
(pre_cfg       : smt_pre_config := {})
(em_attr       : name           := `ematch)

meta def smt_config.set_classical (c : smt_config) (b : bool) : smt_config :=
{ cc_cfg := { em := b, ..c.cc_cfg }, ..c }

meta constant smt_goal                  : Type
meta def smt_state :=
list smt_goal
meta constant smt_state.mk              : smt_config → tactic smt_state
meta constant smt_state.to_format       : smt_state → tactic_state → format
/-- Return tt iff classical excluded middle was enabled at  smt_state.mk -/
meta constant smt_state.classical       : smt_state → bool

meta def smt_tactic :=
state_t smt_state tactic

meta instance : has_append smt_state :=
list.has_append

section
local attribute [reducible] smt_tactic
meta instance : monad smt_tactic := by apply_instance
meta instance : alternative smt_tactic := by apply_instance
meta instance : monad_state smt_state smt_tactic := by apply_instance
end

/- We don't use the default state_t lift operation because only
   tactics that do not change hypotheses can be automatically lifted to smt_tactic. -/
meta constant tactic_to_smt_tactic (α : Type) : tactic α → smt_tactic α

meta instance : has_monad_lift tactic smt_tactic :=
⟨tactic_to_smt_tactic⟩

meta instance (α : Type) : has_coe (tactic α) (smt_tactic α) :=
⟨monad_lift⟩

meta instance : monad_fail smt_tactic :=
{ fail := λ α s, (tactic.fail (to_fmt s) : smt_tactic α), ..smt_tactic.monad }

namespace smt_tactic
open tactic (transparency)
meta constant intros                     : smt_tactic unit
meta constant intron                     : nat  → smt_tactic unit
meta constant intro_lst                  : list name → smt_tactic unit
/--
  Try to close main goal by using equalities implied by the congruence
  closure module.
-/
meta constant close                           : smt_tactic unit
/--
  Produce new facts using heuristic lemma instantiation based on E-matching.
  This tactic tries to match patterns from lemmas in the main goal with terms
  in the main goal. The set of lemmas is populated with theorems
  tagged with the attribute specified at smt_config.em_attr, and lemmas
  added using tactics such as `smt_tactic.add_lemmas`.
  The current set of lemmas can be retrieved using the tactic `smt_tactic.get_lemmas`.

  Remark: the given predicate is applied to every new instance. The instance
  is only added to the state if the predicate returns tt.
-/
meta constant ematch_core                     : (expr → bool) → smt_tactic unit
/--
  Produce new facts using heuristic lemma instantiation based on E-matching.
  This tactic tries to match patterns from the given lemmas with terms in
  the main goal.
-/
meta constant ematch_using                    : hinst_lemmas → smt_tactic unit
meta constant mk_ematch_eqn_lemmas_for_core   : transparency → name → smt_tactic hinst_lemmas
meta constant to_cc_state                     : smt_tactic cc_state
meta constant to_em_state                     : smt_tactic ematch_state
meta constant get_config                      : smt_tactic smt_config
/--
  Preprocess the given term using the same simplifications rules used when
  we introduce a new hypothesis. The result is pair containing the resulting
  term and a proof that it is equal to the given one.
-/
meta constant preprocess                      : expr → smt_tactic (expr × expr)
meta constant get_lemmas                      : smt_tactic hinst_lemmas
meta constant set_lemmas                      : hinst_lemmas → smt_tactic unit
meta constant add_lemmas                      : hinst_lemmas → smt_tactic unit

meta def add_ematch_lemma_core (md : transparency) (as_simp : bool) (e : expr) : smt_tactic unit :=
do h  ← hinst_lemma.mk_core md e as_simp,
   add_lemmas (mk_hinst_singleton h)

meta def add_ematch_lemma_from_decl_core (md : transparency) (as_simp : bool) (n : name) : smt_tactic unit :=
do h  ← hinst_lemma.mk_from_decl_core md n as_simp,
   add_lemmas (mk_hinst_singleton h)

meta def add_ematch_eqn_lemmas_for_core  (md : transparency) (n : name) : smt_tactic unit :=
do hs ← mk_ematch_eqn_lemmas_for_core md n,
   add_lemmas hs

meta def ematch : smt_tactic unit :=
ematch_core (λ _, tt)

meta def failed {α} : smt_tactic α :=
tactic.failed

meta def fail {α : Type} {β : Type u} [has_to_format β] (msg : β) : smt_tactic α :=
tactic.fail msg

meta def try {α : Type} (t : smt_tactic α) : smt_tactic unit :=
⟨λ ss ts, result.cases_on (t.run ss ts)
 (λ ⟨a, new_ss⟩, result.success ((), new_ss))
 (λ e ref s', result.success ((), ss) ts)⟩

/-- `iterate_at_most n t`: repeat the given tactic at most n times or until t fails -/
meta def iterate_at_most : nat → smt_tactic unit → smt_tactic unit
| 0     t := return ()
| (n+1) t := (do t, iterate_at_most n t) <|> return ()

/-- `iterate_exactly n t` : execute t n times -/
meta def iterate_exactly : nat → smt_tactic unit → smt_tactic unit
| 0     t := return ()
| (n+1) t := do t, iterate_exactly n t

meta def iterate : smt_tactic unit → smt_tactic unit :=
iterate_at_most 100000

meta def eblast : smt_tactic unit :=
iterate (ematch >> try close)

open tactic

protected meta def read : smt_tactic (smt_state × tactic_state) :=
do s₁ ← get,
   s₂ ← tactic.read,
   return (s₁, s₂)

protected meta def write : smt_state × tactic_state → smt_tactic unit :=
λ ⟨ss, ts⟩, ⟨λ _ _, result.success ((), ss) ts⟩

private meta def mk_smt_goals_for (cfg : smt_config) : list expr → list smt_goal → list expr
                                  → tactic (list smt_goal × list expr)
| []        sr tr := return (sr.reverse, tr.reverse)
| (tg::tgs) sr tr := do
  tactic.set_goals [tg],
  [new_sg] ← smt_state.mk cfg | tactic.failed,
  [new_tg] ← get_goals | tactic.failed,
  mk_smt_goals_for tgs (new_sg::sr) (new_tg::tr)

/- See slift -/
meta def slift_aux {α : Type} (t : tactic α) (cfg : smt_config) : smt_tactic α :=
⟨λ ss, do
   _::sgs  ← return ss | tactic.fail "slift tactic failed, there no smt goals to be solved",
   tg::tgs ← tactic.get_goals | tactic.failed,
   tactic.set_goals [tg], a ← t,
   new_tgs ← tactic.get_goals,
   (new_sgs, new_tgs) ← mk_smt_goals_for cfg new_tgs [] [],
   tactic.set_goals (new_tgs ++ tgs),
   return (a, new_sgs ++ sgs)⟩

/--
  This lift operation will restart the SMT state.
  It is useful for using tactics that change the set of hypotheses. -/
meta def slift {α : Type} (t : tactic α) : smt_tactic α :=
get_config >>= slift_aux t

meta def trace_state : smt_tactic unit :=
do (s₁, s₂) ← smt_tactic.read,
   trace (smt_state.to_format s₁ s₂)

meta def trace {α : Type} [has_to_tactic_format α] (a : α) : smt_tactic unit :=
tactic.trace a

meta def to_expr (q : pexpr) (allow_mvars := tt) : smt_tactic expr :=
tactic.to_expr q allow_mvars

meta def classical : smt_tactic bool :=
do s ← get,
   return s.classical

meta def num_goals : smt_tactic nat :=
list.length <$> get

/- Low level primitives for managing set of goals -/
meta def get_goals : smt_tactic (list smt_goal × list expr) :=
do (g₁, _) ← smt_tactic.read,
   g₂ ← tactic.get_goals,
   return (g₁, g₂)

meta def set_goals : list smt_goal → list expr → smt_tactic unit :=
λ g₁ g₂, ⟨λ ss, tactic.set_goals g₂ >> return ((), g₁)⟩

private meta def all_goals_core (tac : smt_tactic unit) : list smt_goal → list expr → list smt_goal → list expr → smt_tactic unit
| []        ts        acs act := set_goals acs (ts ++ act)
| (s :: ss) []        acs act := fail "ill-formed smt_state"
| (s :: ss) (t :: ts) acs act :=
  do set_goals [s] [t],
     tac,
     (new_ss, new_ts) ← get_goals,
     all_goals_core ss ts (acs ++ new_ss) (act ++ new_ts)

/-- Apply the given tactic to all goals. -/
meta def all_goals (tac : smt_tactic unit) : smt_tactic unit :=
do (ss, ts) ← get_goals,
   all_goals_core tac ss ts [] []

/-- LCF-style AND_THEN tactic. It applies tac1, and if succeed applies tac2 to each subgoal produced by tac1 -/
meta def seq (tac1 : smt_tactic unit) (tac2 : smt_tactic unit) : smt_tactic unit :=
do (s::ss, t::ts) ← get_goals,
   set_goals [s] [t],
   tac1, all_goals tac2,
   (new_ss, new_ts) ← get_goals,
   set_goals (new_ss ++ ss) (new_ts ++ ts)

meta instance : has_andthen (smt_tactic unit) (smt_tactic unit) (smt_tactic unit) :=
⟨seq⟩

meta def focus1 {α} (tac : smt_tactic α) : smt_tactic α :=
do (s::ss, t::ts) ← get_goals,
   match ss with
   | []  := tac
   | _   := do
     set_goals [s] [t],
     a ← tac,
     (ss', ts') ← get_goals,
     set_goals (ss' ++ ss) (ts' ++ ts),
     return a
   end

meta def solve1 (tac : smt_tactic unit) : smt_tactic unit :=
do (ss, gs) ← get_goals,
   match ss, gs with
   | [],     _    := fail "solve1 tactic failed, there isn't any goal left to focus"
   | _,     []    := fail "solve1 tactic failed, there isn't any smt goal left to focus"
   | s::ss, g::gs :=
     do set_goals [s] [g],
        tac,
        (ss', gs') ← get_goals,
        match ss', gs' with
        | [], [] := set_goals ss gs
        | _,  _  := fail "solve1 tactic failed, focused goal has not been solved"
        end
   end

meta def swap : smt_tactic unit :=
do (ss, ts) ← get_goals,
   match ss, ts with
   | (s₁ :: s₂ :: ss), (t₁ :: t₂ :: ts) := set_goals (s₂ :: s₁ :: ss) (t₂ :: t₁ :: ts)
   | _,                _                := failed
   end

/-- Add a new goal for t, and the hypothesis (h : t) in the current goal. -/
meta def assert (h : name) (t : expr) : smt_tactic unit :=
tactic.assert_core h t >> swap >> intros >> swap >> try close

/-- Add the hypothesis (h : t) in the current goal if v has type t. -/
meta def assertv (h : name) (t : expr) (v : expr) : smt_tactic unit :=
tactic.assertv_core h t v >> intros >> return ()

/-- Add a new goal for t, and the hypothesis (h : t := ?M) in the current goal. -/
meta def define  (h : name) (t : expr) : smt_tactic unit :=
tactic.define_core h t >> swap >> intros >> swap >> try close

/-- Add the hypothesis (h : t := v) in the current goal if v has type t. -/
meta def definev (h : name) (t : expr) (v : expr) : smt_tactic unit :=
tactic.definev_core h t v >> intros >> return ()

/-- Add (h : t := pr) to the current goal -/
meta def pose (h : name) (t : option expr := none) (pr : expr) : smt_tactic unit :=
match t with
| none   := do t ← infer_type pr, definev h t pr
| some t := definev h t pr
end

/-- Add (h : t) to the current goal, given a proof (pr : t) -/
meta def note (h : name) (t : option expr := none) (pr : expr) : smt_tactic unit :=
match t with
| none   := do t ← infer_type pr, assertv h t pr
| some t := assertv h t pr
end

meta def destruct (e : expr) : smt_tactic unit :=
smt_tactic.seq (tactic.destruct e) smt_tactic.intros

meta def by_cases (e : expr) : smt_tactic unit :=
do c ← classical,
   if c then
     destruct (expr.app (expr.const `classical.em []) e)
   else do
     dec_e ← (mk_app `decidable [e] <|> fail "by_cases smt_tactic failed, type is not a proposition"),
     inst  ← (mk_instance dec_e <|> fail "by_cases smt_tactic failed, type of given expression is not decidable"),
     em    ← mk_app `decidable.em [e, inst],
     destruct em

meta def by_contradiction : smt_tactic unit :=
do t ← target,
   c ← classical,
   if t.is_false then skip
   else if c then do
      apply (expr.app (expr.const `classical.by_contradiction []) t),
      intros
   else do
     dec_t ← (mk_app `decidable [t] <|> fail "by_contradiction smt_tactic failed, target is not a proposition"),
     inst  ← (mk_instance dec_t <|> fail "by_contradiction smt_tactic failed, target is not decidable"),
     a     ← mk_mapp `decidable.by_contradiction [some t, some inst],
     apply a,
     intros

/-- Return a proof for e, if 'e' is a known fact in the main goal. -/
meta def proof_for (e : expr) : smt_tactic expr :=
do cc ← to_cc_state, cc.proof_for e

/-- Return a refutation for e (i.e., a proof for (not e)), if 'e' has been refuted in the main goal. -/
meta def refutation_for (e : expr) : smt_tactic expr :=
do cc ← to_cc_state, cc.refutation_for e

meta def get_facts : smt_tactic (list expr) :=
do cc ← to_cc_state,
   return $ cc.eqc_of expr.mk_true

meta def get_refuted_facts : smt_tactic (list expr) :=
do cc ← to_cc_state,
   return $ cc.eqc_of expr.mk_false

meta def add_ematch_lemma : expr → smt_tactic unit :=
add_ematch_lemma_core reducible ff

meta def add_ematch_lhs_lemma : expr → smt_tactic unit :=
add_ematch_lemma_core reducible tt

meta def add_ematch_lemma_from_decl : name → smt_tactic unit :=
add_ematch_lemma_from_decl_core reducible ff

meta def add_ematch_lhs_lemma_from_decl : name → smt_tactic unit :=
add_ematch_lemma_from_decl_core reducible ff

meta def add_ematch_eqn_lemmas_for : name → smt_tactic unit :=
add_ematch_eqn_lemmas_for_core reducible

meta def add_lemmas_from_facts_core : list expr → smt_tactic unit
| []      := return ()
| (f::fs) := do
  try (is_prop f >> guard (f.is_pi && bnot (f.is_arrow)) >> proof_for f >>= add_ematch_lemma_core reducible ff),
  add_lemmas_from_facts_core fs

meta def add_lemmas_from_facts : smt_tactic unit :=
get_facts >>= add_lemmas_from_facts_core

meta def induction (e : expr) (ids : list name := []) (rec : option name := none) : smt_tactic unit :=
slift (tactic.induction e ids rec >> return ()) -- pass on the information?

meta def when (c : Prop) [decidable c] (tac : smt_tactic unit) : smt_tactic unit :=
if c then tac else skip

meta def when_tracing (n : name) (tac : smt_tactic unit) : smt_tactic unit :=
when (is_trace_enabled_for n = tt) tac

end smt_tactic

open smt_tactic

meta def using_smt {α} (t : smt_tactic α) (cfg : smt_config := {}) : tactic α :=
do ss ← smt_state.mk cfg,
   (a, _) ← (do a ← t, iterate close, return a).run ss,
   return a

meta def using_smt_with {α} (cfg : smt_config) (t : smt_tactic α) : tactic α :=
using_smt t cfg


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Scott Morrison

/- The Yoneda embedding, as a functor `yoneda : C ⥤ ((Cᵒᵖ) ⥤ (Type v₁))`,
   along with instances that it is `full` and `faithful`.

   Also the Yoneda lemma, `yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C)`. -/

import category_theory.natural_transformation
import category_theory.opposites
import category_theory.types
import category_theory.embedding
import category_theory.natural_isomorphism

namespace category_theory

universes u₁ v₁ u₂

variables (C : Type u₁) [𝒞 : category.{u₁ v₁} C]
include 𝒞

def yoneda : C ⥤ ((Cᵒᵖ) ⥤ (Type v₁)) :=
{ obj := λ X,
  { obj := λ Y : C, Y ⟶ X,
    map' := λ Y Y' f g, f ≫ g,
    map_comp' := begin intros X_1 Y Z f g, ext1, dsimp at *, erw [category.assoc] end,
    map_id' := begin intros X_1, ext1, dsimp at *, erw [category.id_comp] end },
  map' := λ X X' f, { app := λ Y g, g ≫ f } }

namespace yoneda
@[simp] lemma obj_obj (X Y : C) : ((yoneda C) X) Y = (Y ⟶ X) := rfl
@[simp] lemma obj_map (X : C) {Y Y' : C} (f : Y ⟶ Y') : ((yoneda C) X).map f = λ g, f ≫ g := rfl
@[simp] lemma map_app {X X' : C} (f : X ⟶ X') (Y : C) : ((yoneda C).map f) Y = λ g, g ≫ f := rfl

lemma obj_map_id {X Y : Cᵒᵖ} (f : X ⟶ Y) : ((yoneda C) X).map f (𝟙 X) = ((yoneda C).map f) Y (𝟙 Y) :=
by obviously

@[simp] lemma naturality {X Y : C} (α : (yoneda C) X ⟶ (yoneda C) Y)
  {Z Z' : C} (f : Z ⟶ Z') (h : Z' ⟶ X) : f ≫ α Z' h = α Z (f ≫ h) :=
begin erw [functor_to_types.naturality], refl end

instance full : full (yoneda C) :=
{ preimage := λ X Y f, (f X) (𝟙 X) }.

instance faithful : faithful (yoneda C) :=
begin
  fsplit,
  intros X Y f g p,
  injection p with h,
  convert (congr_fun (congr_fun h X) (𝟙 X)) ; simp
end

/-- Extensionality via Yoneda. The typical usage would be
```
-- Goal is `X ≅ Y`
apply yoneda.ext,
-- Goals are now functions `(Z ⟶ X) → (Z ⟶ Y)`, `(Z ⟶ Y) → (Z ⟶ X)`, and the fact that these
functions are inverses and natural in `Z`.
```
-/
def ext (X Y : C)
  (p : Π {Z : C}, (Z ⟶ X) → (Z ⟶ Y)) (q : Π {Z : C}, (Z ⟶ Y) → (Z ⟶ X))
  (h₁ : Π {Z : C} (f : Z ⟶ X), q (p f) = f) (h₂ : Π {Z : C} (f : Z ⟶ Y), p (q f) = f)
  (n : Π {Z Z' : C} (f : Z' ⟶ Z) (g : Z ⟶ X), p (f ≫ g) = f ≫ p g) : X ≅ Y :=
@preimage_iso _ _ _ _ (yoneda C) _ _ _ _
  (nat_iso.of_components (λ Z, { hom := p, inv := q, }) (by tidy))

-- We need to help typeclass inference with some awkward universe levels here.
instance prod_category_instance_1 : category (((Cᵒᵖ) ⥤ Type v₁) × (Cᵒᵖ)) :=
category_theory.prod.{(max u₁ (v₁+1)) (max u₁ v₁) u₁ v₁} (Cᵒᵖ ⥤ Type v₁) (Cᵒᵖ)

instance prod_category_instance_2 : category ((Cᵒᵖ) × ((Cᵒᵖ) ⥤ Type v₁)) :=
category_theory.prod.{u₁ v₁ (max u₁ (v₁+1)) (max u₁ v₁)} (Cᵒᵖ) (Cᵒᵖ ⥤ Type v₁)

end yoneda

open yoneda

def yoneda_evaluation : (((Cᵒᵖ) ⥤ (Type v₁)) × (Cᵒᵖ)) ⥤ (Type (max u₁ v₁)) :=
(evaluation (Cᵒᵖ) (Type v₁)) ⋙ ulift_functor.{v₁ u₁}

@[simp] lemma yoneda_evaluation_map_down
  (P Q : (Cᵒᵖ ⥤ Type v₁) ×  (Cᵒᵖ)) (α : P ⟶ Q) (x : (yoneda_evaluation C) P) :
  ((yoneda_evaluation C).map α x).down = (α.1) (Q.2) ((P.1).map (α.2) (x.down)) := rfl

def yoneda_pairing : (((Cᵒᵖ) ⥤ (Type v₁)) × (Cᵒᵖ)) ⥤ (Type (max u₁ v₁)) :=
let F := (category_theory.prod.swap ((Cᵒᵖ) ⥤ (Type v₁)) (Cᵒᵖ)) in
let G := (functor.prod ((yoneda C).op) (functor.id ((Cᵒᵖ) ⥤ (Type v₁)))) in
let H := (functor.hom ((Cᵒᵖ) ⥤ (Type v₁))) in
  (F ⋙ G ⋙ H)

@[simp] lemma yoneda_pairing_map
  (P Q : (Cᵒᵖ ⥤ Type v₁) ×  (Cᵒᵖ)) (α : P ⟶ Q) (β : (yoneda_pairing C) (P.1, P.2)) :
  (yoneda_pairing C).map α β = (yoneda C).map (α.snd) ≫ β ≫ α.fst := rfl

def yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C) :=
{ hom :=
  { app := λ F x, ulift.up ((x.app F.2) (𝟙 F.2)),
    naturality' := begin intros X Y f, ext1, ext1, cases f, cases Y, cases X, dsimp at *, simp at *,
      erw [←functor_to_types.naturality, obj_map_id, functor_to_types.naturality, functor_to_types.map_id] end },
  inv :=
  { app := λ F x,
    { app := λ X a, (F.1.map a) x.down,
      naturality' := begin intros X Y f, ext1, cases x, cases F, dsimp at *, erw [functor_to_types.map_comp], refl end },
    naturality' := begin intros X Y f, ext1, ext1, ext1, cases x, cases f, cases Y, cases X,
      dsimp at *, simp at *, erw [←functor_to_types.naturality, functor_to_types.map_comp] end },
  hom_inv_id' := begin ext1, ext1, ext1, ext1, cases X, dsimp at *, simp at *,
    erw [←functor_to_types.naturality, obj_map_id, functor_to_types.naturality, functor_to_types.map_id] end,
  inv_hom_id' := begin ext1, ext1, ext1, cases x, cases X, dsimp at *, erw [functor_to_types.map_id] end }.

end category_theory