/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Compiler.LCNF.InferType
import Lean.Compiler.LCNF.PrettyPrinter
import Lean.Compiler.LCNF.CompatibleTypes

namespace Lean.Compiler.LCNF

/-!
# Note: Type compatibility checking for LCNF

We used to have a type compatibility relation `≃` for LCNF types.
It treated erased types/values as wildcards. Examples:
- `List Nat ≃ List ◾`
- `(List ◾ → List ◾) ≃ (List Nat → List Bool)`

We used this relation to sanity check compiler passes, and detect
buggy transformations that broke type compatibility. For example,
given an application `f a`, we would check whether `a`s type as
compatible with the type expected by `f`.

However, the type compatibility relation is not transitive. Example:
- `List Nat ≃ List ◾`, `List ◾ ≃ List String`, but `List Nat` and `List String` are **not** compatible.

We tried address the issue above by adding casts, which required us
to then add `cast` elimination simplifications, and generated a significant overhead in
the code generator.

Here is an example of transformation that would require the insertion of a cast operation.
```
def foo (g : List A → List A) (a : List B) :=
  fun f (x : List ◾) :=
    let _x.1 := g x
    ...
  let _x.2 := f a
  ...
```
The code above would not trigger any type compatibility issue, but
by inlining `f` without adding cast operations, we would get the
following type incorrect code.
```
def foo (g : List A → List A) (a : List B) :=
let _x.2 := g a -- Type error
...
```

We have considered using a reflexive and transitive subtype relation `≺`.
- `A ≺ A`
- `(Nat × Nat) ≺ (Nat × ◾) ≺ (◾ × ◾) ≺ ◾`
- `List Nat ≺ List ◾ ⊀ List String`
- `(List ◾ → List Nat) ≺ (List Bool → List ◾)`
Note that `A ≺ B` implies `A ≃ B`

The subtype relation has better properties, but also has problems.
First, when converting to LCNF we would have to add more casts. Example:
the function takes a `List ◾`, but the value has type `◾`.
Moreover, recall that `(List Nat → List Nat) ⊀ (◾ → ◾)` forcing us
to add many casts operations when moving to the mono phase where
we erase type parameters.

Recall that type compatibility and subtype relationships do not help with memory layout.
We have that `(UInt32 × UInt32) ≺ (◾ × ◾) ≺ ◾` but elements of these types have
different runtime representation.

Thus, we have decided to abandon the type compatibility checks and cast operations
in LCNF. The only drawback is that we lose the capability of catching simple bugs
at compiler passes.

In the future, we can try to add a sanity check flag that instructs the compiler to use
the subtype relation in sanity checks and add the necessary casts.

-/

namespace Check
open InferType

/-
Type and structural properties checker for LCNF expressions.
-/

structure Context where
  /-- Join points that are in scope. -/
  jps : FVarIdSet := {}
  /-- Variables and local functions in scope -/
  vars : FVarIdSet := {}

structure State where
  /-- All free variables found -/
  all : FVarIdHashSet := {}

abbrev CheckM := ReaderT Context $ StateRefT State InferTypeM

def checkTypes : CheckM Bool := do
  return (← getConfig).checkTypes

def checkFVar (fvarId : FVarId) : CheckM Unit :=
  unless (← read).vars.contains fvarId do
    throwError "invalid out of scope free variable {← getBinderName fvarId}"

/-- Return true `f` is a constructor and `i` is less than its number of parameters. -/
def isCtorParam (f : Expr) (i : Nat) : CoreM Bool := do
  let .const declName _ := f | return false
  let .ctorInfo info ← getConstInfo declName | return false
  return i < info.numParams

def checkAppArgs (f : Expr) (args : Array Arg) : CheckM Unit := do
  let mut fType ← inferType f
  let mut j := 0
  for i in [:args.size] do
    let arg := args[i]!
    if fType.isErased then
      return ()
    fType := fType.headBeta
    let (d, b) ←
      match fType with
      | .forallE _ d b _ => pure (d, b)
      | _ =>
        fType := instantiateRevRangeArgs fType j i args |>.headBeta
        match fType with
        | .forallE _ d b _ => j := i; pure (d, b)
        | _ => return ()
    let expectedType := instantiateRevRangeArgs d j i args
    if (← checkTypes) then
      let argType ← arg.inferType
      unless (← InferType.compatibleTypes argType expectedType) do
        throwError "type mismatch at LCNF application{indentExpr (mkAppN f (args.map Arg.toExpr))}\nargument {arg.toExpr} has type{indentExpr argType}\nbut is expected to have type{indentExpr expectedType}"
    unless (← pure (maybeTypeFormerType expectedType) <||> isErasedCompatible expectedType) do
      match arg with
      | .fvar fvarId => checkFVar fvarId
      | .erased => pure ()
      | .type _ =>
        -- Constructor parameters that are not type formers are erased at phase .mono
        unless (← getPhase) ≥ .mono && (← isCtorParam f i) do
          throwError "invalid LCNF application{indentExpr (mkAppN f (args.map (·.toExpr)))}\nargument{indentExpr arg.toExpr}\nhas type{indentExpr expectedType}\nmust be a free variable"
    fType := b

def checkLetValue (e : LetValue) : CheckM Unit := do
  match e with
  | .value .. | .erased => pure ()
  | .const declName us args => checkAppArgs (mkConst declName us) args
  | .fvar fvarId args => checkFVar fvarId; checkAppArgs (.fvar fvarId) args
  | .proj _ _ fvarId => checkFVar fvarId

def checkJpInScope (jp : FVarId) : CheckM Unit := do
  unless (← read).jps.contains jp do
    /-
    We cannot jump to join points defined out of the scope of a local function declaration.
    For example, the following is an invalid LCNF.
    ```
    jp_1 := fun x => ... -- Some join point
    let f := fun y => -- Local function declaration.
      ...
      jp_1 _x.n -- jump to a join point that is not in the scope of `f`.
    ```
    -/
    throwError "invalid jump to out of scope join point `{mkFVar jp}`"

def checkParam (param : Param) : CheckM Unit := do
  unless param == (← getParam param.fvarId) do
    throwError "LCNF parameter mismatch at `{param.binderName}`, does not value in local context"

def checkParams (params : Array Param) : CheckM Unit :=
  params.forM checkParam

def checkLetDecl (letDecl : LetDecl) : CheckM Unit := do
  checkLetValue letDecl.value
  if (← checkTypes) then
    let valueType ← letDecl.value.inferType
    unless (← InferType.compatibleTypes letDecl.type valueType) do
      throwError "type mismatch at `{letDecl.binderName}`, value has type{indentExpr valueType}\nbut is expected to have type{indentExpr letDecl.type}"
  unless letDecl == (← getLetDecl letDecl.fvarId) do
    throwError "LCNF let declaration mismatch at `{letDecl.binderName}`, does not match value in local context"

def addFVarId (fvarId : FVarId) : CheckM Unit := do
  if (← get).all.contains fvarId then
    throwError "invalid LCNF, free variables are not unique `{fvarId.name}`"
  modify fun s => { s with all := s.all.insert fvarId }

@[inline] def withFVarId (fvarId : FVarId) (x : CheckM α) : CheckM α := do
  addFVarId fvarId
  withReader (fun ctx => { ctx with vars := ctx.vars.insert fvarId }) x

@[inline] def withJp (fvarId : FVarId) (x : CheckM α) : CheckM α := do
  addFVarId fvarId
  withReader (fun ctx => { ctx with jps := ctx.jps.insert fvarId }) x

@[inline] def withParams (params : Array Param) (x : CheckM α) : CheckM α := do
  params.forM (addFVarId ·.fvarId)
  withReader (fun ctx => { ctx with vars := params.foldl (init := ctx.vars) fun vars p => vars.insert p.fvarId })
    x

mutual

set_option linter.all false

partial def checkFunDeclCore (declName : Name) (params : Array Param) (type : Expr) (value : Code) : CheckM Unit := do
  checkParams params
  withParams params do
    discard <| check value
    if (← checkTypes) then
      let valueType ← mkForallParams params (← value.inferType)
      unless (← InferType.compatibleTypes type valueType) do
        throwError "type mismatch at `{declName}`, value has type{indentExpr valueType}\nbut is expected to have type{indentExpr type}"

partial def checkFunDecl (funDecl : FunDecl) : CheckM Unit := do
  checkFunDeclCore funDecl.binderName funDecl.params funDecl.type funDecl.value
  let decl ← getFunDecl funDecl.fvarId
  unless decl.binderName == funDecl.binderName do
    throwError "LCNF local function declaration mismatch at `{funDecl.binderName}`, binder name in local context `{decl.binderName}`"
  unless decl.type == funDecl.type do
    throwError "LCNF local function declaration mismatch at `{funDecl.binderName}`, type in local context{indentExpr decl.type}\nexpected{indentExpr funDecl.type}"
  unless (← getFunDecl funDecl.fvarId) == funDecl do
    throwError "LCNF local function declaration mismatch at `{funDecl.binderName}`, declaration in local context does match"

partial def checkCases (c : Cases) : CheckM Unit := do
  let mut ctorNames : NameSet := {}
  let mut hasDefault := false
  checkFVar c.discr
  for alt in c.alts do
    match alt with
    | .default k => hasDefault := true; check k
    | .alt ctorName params k =>
      checkParams params
      if ctorNames.contains ctorName then
        throwError "invalid LCNF `cases`, alternative `{ctorName}` occurs more than once"
      ctorNames := ctorNames.insert ctorName
      let .ctorInfo val ← getConstInfo ctorName | throwError "invalid LCNF `cases`, `{ctorName}` is not a constructor name"
      unless val.induct == c.typeName do
        throwError "invalid LCNF `cases`, `{ctorName}` is not a constructor of `{c.typeName}`"
      unless params.size == val.numFields do
        throwError "invalid LCNF `cases`, `{ctorName}` has # {val.numFields} fields, but alternative has # {params.size} alternatives"
      withParams params do check k

partial def check (code : Code) : CheckM Unit := do
  match code with
  | .let decl k => checkLetDecl decl; withFVarId decl.fvarId do check k
  | .fun decl k =>
    -- Remark: local function declarations should not jump to out of scope join points
    withReader (fun ctx => { ctx with jps := {} }) do checkFunDecl decl
    withFVarId decl.fvarId do check k
  | .jp decl k => checkFunDecl decl; withJp decl.fvarId do check k
  | .cases c => checkCases c
  | .jmp fvarId args =>
    checkJpInScope fvarId
    let decl ← getFunDecl fvarId
    unless decl.getArity == args.size do
      throwError "invalid LCNF `goto`, join point {decl.binderName} has #{decl.getArity} parameters, but #{args.size} were provided"
    checkAppArgs (.fvar fvarId) args
  | .return fvarId => checkFVar fvarId
  | .unreach .. => pure ()

end

def run (x : CheckM α) : CompilerM α :=
  x |>.run {} |>.run' {} |>.run {}

end Check

def Decl.check (decl : Decl) : CompilerM Unit := do
  Check.run do Check.checkFunDeclCore decl.name decl.params decl.type decl.value

/--
Check whether every local declaration in the local context is used in one of given `decls`.
-/
partial def checkDeadLocalDecls (decls : Array Decl) : CompilerM Unit := do
  let (_, s) := visitDecls decls |>.run {}
  let usesFVar (binderName : Name) (fvarId : FVarId) :=
    unless s.contains fvarId do
      throwError "LCNF local context contains unused local variable declaration `{binderName}`"
  let lctx := (← get).lctx
  lctx.params.forM fun fvarId decl => usesFVar decl.binderName fvarId
  lctx.letDecls.forM fun fvarId decl => usesFVar decl.binderName fvarId
  lctx.funDecls.forM fun fvarId decl => usesFVar decl.binderName fvarId
where
  visitFVar (fvarId : FVarId) : StateM FVarIdHashSet Unit :=
    modify (·.insert fvarId)

  visitParam (param : Param) : StateM FVarIdHashSet Unit := do
    visitFVar param.fvarId

  visitParams (params : Array Param) : StateM FVarIdHashSet Unit := do
    params.forM visitParam

  visitCode (code : Code) : StateM FVarIdHashSet Unit := do
    match code with
    | .jmp .. | .return .. | .unreach .. => return ()
    | .let decl k => visitFVar decl.fvarId; visitCode k
    | .fun decl k | .jp decl k =>
      visitFVar decl.fvarId; visitParams decl.params; visitCode decl.value
      visitCode k
    | .cases c => c.alts.forM fun alt => do
      match alt with
      | .default k => visitCode k
      | .alt _ ps k => visitParams ps; visitCode k

  visitDecl (decl : Decl) : StateM FVarIdHashSet Unit := do
    visitParams decl.params
    visitCode decl.value

  visitDecls (decls : Array Decl) : StateM FVarIdHashSet Unit :=
    decls.forM visitDecl

end Lean.Compiler.LCNF


/-
Copyright (c) 2019 Jesse Michael Han. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Jesse Michael Han

Monadic parsing in Lean, following Hutton-Meijer's 'Monadic Parsing in Haskell` (doi: 10.1017/S0956796898003050).

A related implementation for character buffers, due to Gabriel Ebner, is in data.buffer.
-/

import tactic

import init.data.string

section miscellany

lemma forall_iff_of_eq {α} {P Q : α → Prop} (h : P = Q) : (∀ x, P x ↔ Q x) :=
λ _, h ▸ iff_of_eq rfl

lemma mem_cons_iff {α} (xs : list α) (x y : α) : y ∈ (x::xs) ↔ y = x ∨ y ∈ xs :=
(set.mem_union x (eq y) (λ (x : α), list.mem y xs))

example {α β} (xs : list α) {x : α} (f : α → β) (H_mem : x ∈ xs) : f x ∈ xs.map f := list.mem_map_of_mem f H_mem

end miscellany

namespace char

notation `[]` := list.nil
notation h :: t  := list.cons h t
notation `[` l:(foldr `, ` (h t, list.cons h t) list.nil `]`) := l

instance : has_zero string := ⟨""⟩

meta def check_is_valid_char : tactic unit := `[norm_num[is_valid_char]]

/-- char.mk' will automatically attempt to use `check_is_valid_char` to produce the validity certificate -/
def mk' (n : ℕ) (H : is_valid_char n . check_is_valid_char) : char :=
char.mk n H

def lower : list char := "abcdefghijklmnopqrstuvwxyz".data

def upper : list char := "ABCDEFGHIJKLMNOPQRSTUVWXYZ".data

lemma is_upper_of_mem_upper {c} (H : c ∈ upper) : is_upper c :=
by {unfold is_upper upper, repeat{cases H, subst H, omega}, cases H }

lemma to_lower_upper_eq_lower : upper.map to_lower = lower := dec_trivial

lemma mem_lower_of_to_lower_upper {c} (H : c ∈ upper) : c.to_lower ∈ lower :=
by {rw[<-to_lower_upper_eq_lower], exact list.mem_map_of_mem _ ‹_›}

def lowercase : {c // c ∈ upper} → {c // c ∈ lower} :=
λ ⟨c,H⟩, ⟨char.to_lower c, mem_lower_of_to_lower_upper H⟩

def alpha : list char := lower ++ upper

def numeric : list char := "0123456789".data

def alphanumeric := alpha ++ numeric

section whitespace_chars

def cr := mk' 0x0D

def newline : char := mk' 0x0a

def space : char := ' '

def thin_space : char := ' '

def hair_space : char := ' '

def no_break_space : char := ' '

def medium_mathematical_space : char := ' '

def ideographic_space : char := '　'

def zero_width_no_break_space := ''

def zero_width_space := ''

def punctuation_space := ' '

def figure_space := ' '

def six_per_em_space := ' '

def four_per_em_space := ' '

def three_per_em_space := ' '

def em_space := ' '

def en_space := ' '

def em_quad := ' '

def en_quad := ' '

def mongolian_vowel_separator := ''

def ogham_space_mark := ' '

def tab := char.mk' 0x09

def narrow_no_break_space := ' '

def whitespace_chars : list char :=
  [cr,
   newline,
   space,
   thin_space,
   hair_space,
   tab,
   zero_width_space,
   zero_width_no_break_space,
   narrow_no_break_space,
   medium_mathematical_space,
   ideographic_space,
   punctuation_space,
   figure_space,
   six_per_em_space,
   four_per_em_space,
   three_per_em_space,
   em_quad,
   en_quad,
   en_space,
   em_space,
   mongolian_vowel_separator,
   no_break_space]

end whitespace_chars

end char

namespace string

def to_lower (arg : string) : string := ⟨arg.data.map char.to_lower⟩

def reverse (arg : string) : string :=
⟨arg.data.reverse⟩

end string

@[reducible]meta def parser' := state_t string

meta def parser_tactic := parser' tactic

namespace parser_tactic
section parser_tactic
variables {α : Type}

meta def mk (run : string → tactic (α × string)) : parser_tactic α :=
state_t.mk run

meta def lift {α} (val : tactic α) : parser_tactic α := state_t.lift val

meta def run (p : parser_tactic α) : string → tactic (α × string) :=
state_t.run p

meta def result (p : parser_tactic α) (arg : string) : tactic α :=
p.run arg >>= return ∘ prod.fst

meta def get_result [has_reflect α] (p : parser_tactic α) (arg : string) : tactic unit :=
p.result arg >>= λ x, tactic.exact (reflect x)

/--
`run parser p arg` runs `p` as if `arg` were the current state.

It returns the result of p, leaving the actual state unchanged.
-/
meta def run_parser (p : parser_tactic α) : string → parser_tactic α :=
λ arg, lift (do (a,b) <- p.run arg, return a)

meta instance monad_parser_tactic : monad parser_tactic :=
by change _root_.monad (state_t _ _); apply_instance

meta instance alternative_parser_tactic : alternative parser_tactic :=
by change _root_.alternative (state_t _ _); apply_instance

meta instance : has_append (parser_tactic string) :=
⟨λ p₁ p₂, do a <- p₁, b <- p₂, return $ a ++ b⟩

meta def fail : parser_tactic α := parser_tactic.mk $ λ _, tactic.failed

meta def trace_state : parser_tactic unit :=
parser_tactic.mk $ λ str, tactic.trace str >> return ((), str)

meta def get_state : parser_tactic string :=
state_t.get

meta def put_state : string -> parser_tactic unit :=
λ arg, state_t.put arg

meta def modify_state : (string -> string) -> parser_tactic unit :=
λ m, state_t.modify m

meta def prepend_state : string -> parser_tactic unit :=
λ arg, modify_state (λ σ, arg ++ σ)

meta def append_state : string -> parser_tactic unit :=
λ arg, modify_state (λ σ, σ ++ arg)

meta def run_parser' (p : parser_tactic α) : parser_tactic string → parser_tactic α :=
λ q, q >>= run_parser p

meta def skip : parser_tactic unit :=
parser_tactic.mk $ λ str, return ((), str)

meta def trace (msg : string) : parser_tactic unit :=
parser_tactic.mk $ λ str, tactic.trace msg >> return ((), str)

meta def try_core (p : parser_tactic α) : parser_tactic (option α) :=
mk $ (λ arg, do r <- tactic.try_core (p.run arg),
      match r with
      | none     := return (none, arg)
      | (some x) := return (some x.1, x.2)
      end)

meta def try (p : parser_tactic α) : parser_tactic unit :=
try_core p >>= λ r, match r with
                    | none := skip
                    | some x := return ()
                    end

meta def to_tactic (p : parser_tactic α) : string → tactic α :=
λ arg, (p.run arg) >>= return ∘ prod.fst

meta instance : has_coe (parser_tactic α) (string → tactic α) :=
⟨to_tactic⟩

meta def parser_tactic_format {α} [H : has_to_format α] : α × string → format :=
λ ⟨r,σ⟩,
    format.line ++ ("Result:") ++
    format.line ++ format.line ++ (format.nest 5 $ to_fmt r) ++
    format.line ++ format.line ++
    "──────────────────────────────────────" ++
    format.line ++ format.line ++ ("State:") ++
    format.line ++ format.line ++ (format.nest 5 $ to_fmt σ)

/-- For testing parsers on strings -/
meta def run' {α} [has_to_format α] (p : parser_tactic α) (arg : string) : tactic unit :=
  p.run arg >>= λ fmt, return $ _root_.trace_fmt (parser_tactic_format fmt) (λ _, ())

end parser_tactic
end parser_tactic

open parser_tactic

namespace parser_tactic

meta def item : parser_tactic char :=
parser_tactic.mk $ λ str,
  match str with
  | ⟨[]⟩      := tactic.failed
  | ⟨(x::xs)⟩ := return (x, ⟨xs⟩)
  end

meta def eof : parser_tactic unit :=
parser_tactic.mk $ λ str,
  match str with
  | ⟨[]⟩ := return ⟨(), str⟩
  | ⟨(x::xs)⟩ := tactic.failed
  end

/--
`item0` is like `item`, but does not consume anything (leaves the state unchanged).
-/
meta def item0 : parser_tactic char :=
parser_tactic.mk $ λ str,
  match str with
  | ⟨[]⟩      := tactic.failed
  | ⟨(x::xs)⟩ := return (x, ⟨x::xs⟩)
  end

meta def to_string : parser_tactic char → parser_tactic string :=
λ p, do x <- p, return x.to_string

meta def to_string' : parser_tactic (list char) → parser_tactic string :=
λ p, do x <- p, return $ string_imp.mk x

meta instance parser_to_string : has_coe (parser_tactic (char)) (parser_tactic string) :=
⟨to_string⟩

meta instance list_char_coe : has_coe (parser_tactic (list char)) (parser_tactic string) :=
⟨to_string'⟩

meta def sat (P : char → Prop) [decidable_pred P] : parser_tactic char :=
item >>= λ x, (if P x then return x else fail)

section eq_any
variables {α : Type*} [decidable_eq α]

def eq_any (cs : list α) : α → Prop :=
λ c, cs.foldr (λ x, λ b, (= c) x ⊔ b)  ⊥

@[simp]lemma eq_any_cons {c : α} {cs} : eq_any (c::cs) = λ x, c = x ∨ eq_any cs x := rfl

instance eq_any_decidable_pred : ∀ {cs : list α}, decidable_pred (eq_any cs) :=
begin
  intro cs, induction cs with c cs ih, unfold eq_any, tidy, apply_instance,
  intro x, haveI : decidable (eq_any cs x) := by apply ih,
  by_cases c = x,
    { exact decidable.is_true (by simp*) },
    { by_cases (eq_any cs x),
          { simp*, apply_instance },
          { simp*, apply_instance }}
end

/- note: we'll never need this, but it's basically free -/
def eq_all (cs : list α) : α → Prop :=
λ c, cs.foldr (λ x, λ b, (= c) x ⊓ b)  ⊤

@[simp]lemma eq_all_cons {c : α} {cs} : eq_all (c::cs) = λ x, c = x ∧ eq_all cs x := rfl

instance eq_all_decidable_pred : ∀ {cs : list α}, decidable_pred (eq_all cs) :=
begin
  intro cs, induction cs with c cs ih, unfold eq_all, tidy, apply_instance,
  intro x, haveI : decidable (eq_all cs x) := by apply ih,
  by_cases c = x,
    { by_cases (eq_all cs x),
          { simp*, apply_instance },
          { simp*, apply_instance }},
    { exact decidable.is_false (by simp*) }
end

end eq_any

meta def ch  (c : char) : parser_tactic char := sat (= c)

meta def chs (cs : list char) : parser_tactic char := sat (eq_any cs)

meta def not_chs (cs : list char) : parser_tactic char := sat (λ c, ¬ eq_any cs c)

meta def not_ch (c : char) : parser_tactic char := not_chs $ [c]

meta def str : string → parser_tactic string
| ⟨[]⟩    := pure ""
| ⟨x::xs⟩ := do y <- ch x,
               z <- str ⟨xs⟩,
               return $ y.to_string ++ z

meta def nil_if_fail {α} : parser_tactic α → parser_tactic (list α) :=
λ p, (p >>= return ∘ return) <|> return []

meta def fail_if_nil : parser_tactic string → parser_tactic string :=
λ p, do x <- p, guard (x ≠ ""), return x

meta def fail_if_nil' {α} [decidable_eq α] : parser_tactic (list α) → parser_tactic (list α) :=
λ p, do x <- p, guard (x ≠ []), return x

meta def fail_if_state_nil {α} (p : parser_tactic α) : parser_tactic α :=
(get_state >>= λ arg, guard (arg ≠ "")) >> p

meta def list.mcons {m} [monad m] {α} (x : α) (xs : list α) : m (list α) :=
return (x::xs)

meta def repeat {α} (p : parser_tactic α) : parser_tactic (list α) :=
(do a  <- p,
    as <- repeat,
    return (a::as)) <|> return []

meta def repeat1 {α : Type} : parser_tactic α → parser_tactic (list α) :=
λ p, list.cons <$> p <*> repeat p

/--
`succeeds' p` runs p, but does not change the state even if p succeeds.
-/
meta def succeeds' {α} (p : parser_tactic α) : parser_tactic bool :=
succeeds $ get_state >>= (run_parser p)

meta def fail_iff_succeeds {α} (p : parser_tactic α) : parser_tactic unit :=
succeeds' p >>= λ b, ite b fail skip

/--
`until p q` runs q until p succeeds, and returns the result of p and all the results of q
-/
meta def until {α β} (p : parser_tactic α) (q : parser_tactic β) : parser_tactic (α × list β) :=
   repeat (fail_iff_succeeds p *> q) >>= λ _, prod.mk <$> p <*> return ‹_›

/--
`until' p q` runs q until p succeeds, and returns the result of p
-/
meta def until' {α β} (p : parser_tactic α) (q : parser_tactic β) : parser_tactic α :=
prod.fst <$> until p q

/--
`until'' p q` runs q until p succeeds, and returns all results of q
-/
meta def until'' {α β} (p : parser_tactic α) (q : parser_tactic β) : parser_tactic (list β) :=
prod.snd <$> until p q

/--
`lookahead arg` succeeds if and only if `arg` is a substring of the current state
-/
meta def lookahead (arg : string) : parser_tactic bool :=
succeeds' $ until' (str arg) item

run_cmd (lookahead "foo").run' "abcfoode"
/--
`not_str arg` consumes and returns the longest prefix which does not match `arg`.
-/
meta def not_str : string → parser_tactic string := λ arg,
until'' (str arg) item

meta def not_strs : list string → parser_tactic string := λ arg,
repeat $ succeeds (list.mfirst str arg) >>= (λ b, if b then fail else item)

meta def sepby_aux {α β} : parser_tactic α → parser_tactic β → parser_tactic (list α) :=
λ p sep,
  list.cons <$> p <*> repeat (sep *> p)

meta def sepby {α β} : parser_tactic α → parser_tactic β → parser_tactic (list α) :=
λ p sep,
  (sepby_aux p sep) <|> return []

/-
The choice operator (++) from Hutton-Meijer does not have a direct analogue in this framework, since we use `tactic` as the monad instead of `list`.

However, the deterministic choice operator (+++):
1. fails iff both p and q fail
2. if p succeeds, returns the result of p
3. if p fails, runs q

and therefore (+++) is emulated by the orelse (<|>) combinator.
-/

/-
c.f. Hutton-Meijer:

chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl p op a = (p ‘chainl1‘ op) +++ return a

chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
p ‘chainl1‘ op = do {a <- p; rest a}
                 where
                   rest a = (do f <- op
                                b <- p
                                rest (f a b))
                            +++ return a
-/

meta def chainl_rest {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : α → parser_tactic α :=
λ a,
  (do f <- op,
     b <- p,
     chainl_rest (f a b)) <|> return a

meta def chainl1 {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : parser_tactic α :=
do a <- p, chainl_rest p op a

meta def chainl {α} : parser_tactic α → parser_tactic (α → α → α) → α → parser_tactic α :=
λ p op a, (chainl1 p op) <|> return a

meta def chainr_rest {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : α → parser_tactic α :=
λ a,
  (do f <- op,
     b <- p,
     chainr_rest (f b a)) <|> return a

meta def chainr1 {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : parser_tactic α :=
do a <- p, chainr_rest p op a

meta def chainr {α} : parser_tactic α → parser_tactic (α → α → α) → α → parser_tactic α :=
λ p op a, (chainr1 p op) <|> return a

/- Lexical combinators -/

meta def space : parser_tactic string := repeat (sat (= ' '))

meta def whitespace : parser_tactic string := repeat (chs char.whitespace_chars)

meta def not_whitespace : parser_tactic string := fail_if_nil $ repeat (not_chs char.whitespace_chars)

/-- `token p` runs p, then consumes as many spaces as possible before discarding them. -/
meta def token {α} (p : parser_tactic α) : parser_tactic α := p <* space

/-- `token' p runs p, then consumes as much whitespace as possible before discarding it. -/
meta def token' {α} (p : parser_tactic α) : parser_tactic α := p <* whitespace

meta def symb : string → parser_tactic string := token ∘ str

/-- An alphanumeric token is a string of alphanumeric characters which must begin with an alpha character. -/
meta def alphanumeric_token : parser_tactic string :=
(string.append <$> (sat char.is_alpha) <*> (repeat (sat char.is_alphanum))) <* whitespace

meta def digit : parser_tactic char  := chs char.numeric

def from_base_10_aux : ℕ → list ℕ → ℕ
| _      []          := 0
| 0      (x::xs)     := x
| (n+1)  (x::xs)     := (10^n) * x + from_base_10_aux n xs

def from_base_10 : list ℕ → ℕ := λ xs, from_base_10_aux xs.length xs

meta def digit' : parser_tactic ℕ :=
do x <- digit,
   if (x = '0') then return 0 else
   if (x = '1') then return 1 else
   if (x = '2') then return 2 else
   if (x = '3') then return 3 else
   if (x = '4') then return 4 else
   if (x = '5') then return 5 else
   if (x = '6') then return 6 else
   if (x = '7') then return 7 else
   if (x = '8') then return 8 else
   if (x = '9') then return 9 else
   fail

meta def number' : parser_tactic ℕ := (repeat digit') >>= return ∘ from_base_10

meta def number : parser_tactic ℕ := (fail_if_nil' (repeat digit')) >>= return ∘ from_base_10

/--
`delimiter_aux arg_left arg_right k` believes that it has passed `k` copies of `arg_left`, and is expecting `k` copies of `arg_right`.

Upon encountering a copy of `arg_right`, it calls itself, decrementing the counter by 1.

If it never encounters an opening `arg_left`, it returns the empty string.
-/

/-
running delimiter on (foo (bar )) baz produces (foo (bar )).
-/
/-
TODO(jesse) refactor this to consume extra characters to the right instead of left
-/
meta def delimiter_aux (arg_left : string) (arg_right : string) : Π k : ℕ, parser_tactic string
| 0       := (not_str arg_left ++ str arg_left ++ delimiter_aux 1)
              <|> return ""
| (k + 1) := (not_str arg_left ++ str arg_left ++ delimiter_aux (k + 2))
              <|> ((not_str arg_right) ++ str arg_right) ++ delimiter_aux k

/-- `delimiter arg_left arg_right parses the delimiters, then returns their interior as a string -/
meta def delimiter (arg_left arg_right : string) : parser_tactic string :=
delimiter_aux arg_left arg_right 0

/--
`delimiter' p arg_right arg_left` parses the delimiters, then runs p on their interior.
-/
meta def delimiter' {α} (p : parser_tactic α) (arg_right) (arg_left) : parser_tactic α :=
delimiter arg_right arg_left >>= p.run_parser

meta def delimiter'' (arg_left arg_right : string) : parser_tactic string :=
do r <- (delimiter arg_left arg_right),
   r' <- run_parser (symb arg_left >> get_state) r,
   run_parser ((symb arg_right.reverse) >> get_state >>= return ∘ string.reverse) r'.reverse

meta def between (arg_left arg_right : string) : parser_tactic string :=
  (str arg_left ++ not_strs [arg_left, arg_right] ++ (between <|> return "") ++ not_strs [arg_left, arg_right] ++ str arg_right)

meta def apply {α} (p : parser_tactic α) : string → tactic (α × string) := (space *> p).run

--TODO(jesse) fix this so it also consumes the corresponding prefix of the actual state
meta def case_insensitive (p : string → parser_tactic string) : string → parser_tactic string :=
λ arg, do s <- get_state, run_parser (p arg.to_lower) s.to_lower

-- section parse_fol
-- open fol

-- meta instance {k} : has_to_tactic_format (preformula L_empty k)  :=
-- ⟨begin intro f, have := (reflected.has_to_tactic_format f).1 ,
--        apply this, apply_instance end⟩

-- meta def parse_preformula_aux : parser_tactic (preformula L_empty 0) :=
-- token' (str "∀") >> parse_preformula_aux >>= (λ x, return (preformula.all x)) <|>
-- (repeat item) *> return (&0 ≃ &0)

-- -- as vars are encountered, they are pushed onto the stack
-- -- the de Bruijn index assigned to an encountered free variable is its position in the stack.
-- -- a named variable is captured by the nearest quantifier with the same name

-- meta structure formula_state (k : ℕ) :=
-- (bound_var : list name)
-- (free_var : list name)
-- (result : preformula L_empty k)

-- #check formula_state.mk

-- -- meta def formula_state.var {k : ℕ} (σ : formula_state k) : tactic (list name) :=
-- -- σ.bound_var >>= (λ x, (σ.free_var >>= (λ y, return (x ++ y))))

-- meta def parse_preformula {k : ℕ} (σ : formula_state k) : parser_tactic (formula_state 0) :=
-- do token' (str "∀"),
--    v <- (alphanumeric_token),
--    let foo := ℕ in
--    return (formula_state.mk (σ.bound_var ++ [v]) (σ.free_var) foo )
-- -- TODO(jesse) finish this

-- -- @formula_state.mk 0 (σ.bound_var.append ([↑v] : list _)) σ.free_var (parse_preformula >>= _

-- -- meta def parse_preformula : parser_tactic (Σk, preformula L_empty k) :=
-- -- do token' (str "∀") >> (parse_preformula >>= λ x, return ⟨x.fst, x.2⟩)

-- -- run_cmd run' parse_preformula_aux "∀ ∀ ∀ ∀ foo"

-- -- fol.preterm.var : Π {L : Language}, ℕ → preterm L 0
-- -- fol.preterm.func : Π {L : Language} {l : ℕ}, L.functions l → preterm L l
-- -- fol.preterm.app : Π {L : Language} {l : ℕ}, preterm L (l + 1) → preterm L 0 → preterm L l

-- -- fol.preformula.falsum : Π {L : Language}, preformula L 0
-- -- fol.preformula.equal : Π {L : Language}, term L → term L → preformula L 0
-- -- fol.preformula.rel : Π {L : Language} {l : ℕ}, L.relations l → preformula L l
-- -- fol.preformula.apprel : Π {L : Language} {l : ℕ}, preformula L (l + 1) → term L → preformula L l
-- -- fol.preformula.imp : Π {L : Language}, preformula L 0 → preformula L 0 → preformula L 0
-- -- fol.preformula.all : Π {L : Language}, preformula L 0 → preformula L 0

-- -- ∀ x, x = x ∧ (f x y = 3)

-- meta def parse_eq : parser_tactic $ term L_empty → term L_empty → preformula L_empty 0 :=
-- (token (ch '=' >> return preformula.equal))

-- meta def parser_var : parser_tactic $ sorry := sorry

-- meta def parse_preterm {k} : parser_tactic (preterm L_empty k) := sorry

-- meta def parse_preformula {k} : parser_tactic (preformula L_empty k) := sorry

-- end parse_fol

section tests

run_cmd (until' (str "bar") item : parser_tactic string).run' "foo bar baz"

run_cmd (str "foobar" <* eof).run' "foobar"

run_cmd (fail_if_nil $ str "h").run' "hewwo" -- succeeds as it should

-- run_cmd (fail_if_nil $ str "").run' "hewwo" -- fails as it should

-- run_cmd run' (fail_if_state_nil $ skip) "" -- fails as it should

run_cmd (sepby (str "a" <|> str "b") (str ",")).run' "a,b,c,d"

run_cmd run' (fail_if_state_nil $ skip) "foo" -- succeeds as it should

run_cmd run' (delimiter "(" ")") "(1 + 2) + 3"

run_cmd run' (delimiter "[" "]") "[a + b + [c + d] + [e + [f]]] + 3"

run_cmd run' (delimiter "[" "]") "[]] + 3"

run_cmd run' (delimiter "[" "]") "[1 + 2 + 3" -- returns nothing as it should

run_cmd run' (delimiter "[" "]") "[a + b + [c + d] + [e + [f]]] + 3"

run_cmd run' (not_str "HEWWO") "DUH HEWWO"

run_cmd run' (repeat alphanumeric_token) "a1 a3 b3 b4 x12 xasd1"

run_cmd run' (token $ (str "foo")) "foo    bar"

run_cmd run' (sepby (str "foo") (str " ")) "foo foo foo foo"

run_cmd run' (repeat (str "foo")) "barfoofoobarbarbarfoo"

-- run_cmd run' (repeat1 (str "foo")) "barfoofoobarbarbarfoo" -- fails as it should

run_cmd run' (repeat1 (str "foo")) "foofoofoobarbarbarfoo"

run_cmd run' (str "foo") "foobarbaz"  -- (foo, barbaz)

run_cmd run' (repeat1 $ fail_if_nil $ token $ not_whitespace) "foo₁ foo₂ foo₃ foo₄ foo₅"

run_cmd (repeat $ str "a" <|> str "b").run' "bbababbaabaaaa" -- if one branch fails, the state is unchanged and passed to the other branch

end tests

end parser_tactic

open parser_tactic

namespace arith_expr

section arith_expr

open arith_expr

meta def parse_number (arg : string) : tactic unit :=
do n <- number'.to_tactic arg,
   tactic.exact `(n)

mutual inductive addop,mulop,digit,factor,term,expr
with addop : Type
     | plus             : addop
     | minus            : addop
with mulop : Type
     | mult             : mulop
     | div              : mulop
with digit : Type
     | zero             : digit
     | one              : digit
     | two              : digit
     | three            : digit
     | four             : digit
     | five             : digit
     | six              : digit
     | seven            : digit
     | eight            : digit
     | nine             : digit
with factor : Type
     | of_digit         : digit → factor
     | of_expr          : expr  → factor
with term : Type
     | of_factor        : factor → term
     | of_mulop         : mulop → term → factor → term
with expr : Type
     | of_term          : term → expr
     | of_addop         : addop → expr → term → expr

def term.of_digit := term.of_factor ∘ factor.of_digit

def expr.of_digit := expr.of_term ∘ term.of_digit

meta mutual def eval_addop,eval_mulop,eval_digit,eval_factor,eval_term,eval_expr
with eval_addop                : addop → ℕ → ℕ → ℕ
     | addop.plus              := (nat.add)
     | addop.minus             := (nat.sub)
with eval_mulop                : mulop → ℕ → ℕ → ℕ
     | mulop.mult              := (nat.mul)
     | mulop.div               := (nat.div)
with eval_digit                : digit → ℕ
     | digit.zero              := 0
     | digit.one               := 1
     | digit.two               := 2
     | digit.three             := 3
     | digit.four              := 4
     | digit.five              := 5
     | digit.six               := 6
     | digit.seven             := 7
     | digit.eight             := 8
     | digit.nine              := 9
with eval_factor               : factor → ℕ
     | (factor.of_digit k)     := eval_digit k
     | (factor.of_expr e)      := eval_expr e
with eval_term                 : term → ℕ
     | (term.of_factor f)      := eval_factor f
     | (term.of_mulop op t f)  := (eval_mulop op) (eval_term t) (eval_factor f)
with eval_expr                 : expr → ℕ
     | (expr.of_term t)        := eval_term t
     | (expr.of_addop op e t)  := (eval_addop op) (eval_expr e) (eval_term t)

meta def nat.to_fmt : ℕ → format := nat.has_to_format.to_format

meta instance format_digit : has_to_format digit :=
⟨λ x, nat.to_fmt (eval_digit x)⟩

meta instance format_factor : has_to_format factor :=
⟨λ x, nat.to_fmt (eval_factor x)⟩

meta instance format_term : has_to_format term :=
⟨λ x, nat.to_fmt (eval_term x)⟩

meta instance format_expr : has_to_format expr :=
⟨λ x, nat.to_fmt (eval_expr x)⟩

meta mutual def parse_addop,parse_mulop,parse_digit,parse_factor,parse_term,parse_expr
with parse_addop                : string → tactic (addop × string)
| arg := (token (str "+" >> return addop.plus <|> str "-" >> return addop.minus)).run arg
with parse_mulop                : string → tactic (mulop × string)
| arg := (token (str "*" >> return mulop.mult <|> str "/" >> return mulop.div)).run arg
with parse_digit                : string → tactic (digit × string)
| arg := (token $ trace "HEWWO" >>    trace_state >> do  x <- parser_tactic.digit,
   trace $ x.to_string ++ " WAS THE DIGIT I PARSED",
   if (x = '0') then return digit.zero else
   if (x = '1') then return digit.one else
   if (x = '2') then return digit.two else
   if (x = '3') then return digit.three else
   if (x = '4') then return digit.four else
   if (x = '5') then return digit.five else
   if (x = '6') then return digit.six else
   if (x = '7') then return digit.seven else
   if (x = '8') then return digit.eight else
   if (x = '9') then return digit.nine else
   fail).run arg
with parse_factor               : string → tactic (factor × string)
| arg := (fail_if_state_nil $ (trace "hello" >> (token $ (mk parse_digit) >>= return ∘ factor.of_digit <|> (mk parse_expr) >>= return ∘ factor.of_expr))).run arg
with parse_term                 : string → tactic (term × string)
| arg := (token $
            (do
               trace "hola",
               b <- succeeds' (do not_str "*" >> str "*"),
               if b then (do t <- (mk parse_term),
                            op <- (mk parse_mulop),
                            f  <- (mk parse_factor),
                            return $ term.of_mulop op t f)
                     else (mk parse_factor) >>= return ∘ term.of_factor
                -- e   <- (mk parse_expr),
                -- op  <- (mk parse_addop),
                -- t   <- (mk parse_term),
                -- return $ expr.of_addop op e t
             )).run arg
with parse_expr                 : string → tactic (expr × string)
| arg := (token $
            (do
               trace "bonjour",
               b <- succeeds' (do not_str "+" >> str "+"),
               if b then -- return (expr.of_digit digit.one)
                           (do p <- not_str "+",
                             e <- (mk parse_expr).run_parser p,
                            op <- (mk parse_addop),
                            t  <- (mk parse_term),
                            return $ expr.of_addop op e t)
                     else (mk parse_term) >>= return ∘ expr.of_term
                -- e   <- (mk parse_expr),
                -- op  <- (mk parse_addop),
                -- t   <- (mk parse_term),
                -- return $ expr.of_addop op e t
             )
                ).run arg

meta def parse_arith_expr : parser_tactic expr := mk parse_expr

run_cmd (mk parse_expr).run' "9 + 1 + 1"

-- run_cmd (parse_arith_expr >> parse_arith_expr).run' "1"

-- run_cmd (
-- do b <- succeeds' (do not_str "+" >> str "+"),
--    trace_state,
--    if b then (do d₁ <- (mk parse_digit),
--                  op <- (mk parse_addop),
--                  d₂ <- (mk parse_digit),
--                  return $ expr.of_addop op (expr.of_digit d₁) (term.of_digit d₂)

--              )
--         else (mk parse_digit) >>= return ∘ expr.of_digit

--   ).run' "8 + 7"

end arith_expr

end arith_expr

namespace calculator

section calculator

open calculator

def from_base_10_aux : ℕ → list ℤ → ℤ
| _ []               := 0
| 0 (x::xs)          := x
| (n+1) (x::xs)      := (10^n) * x + from_base_10_aux n xs

def from_base_10 : list ℤ → ℤ := λ xs, from_base_10_aux xs.length xs

meta def digit' : parser_tactic ℤ :=
do x <- digit,
   if (x = '0') then return 0 else
   if (x = '1') then return 1 else
   if (x = '2') then return 2 else
   if (x = '3') then return 3 else
   if (x = '4') then return 4 else
   if (x = '5') then return 5 else
   if (x = '6') then return 6 else
   if (x = '7') then return 7 else
   if (x = '8') then return 8 else
   if (x = '9') then return 9 else
   fail

meta def number : parser_tactic ℤ := (repeat digit') >>= return ∘ from_base_10

meta def parse_number (arg : string) : tactic unit :=
do n <- number.to_tactic arg,
   tactic.exact `(n)

mutual inductive addop,mulop,digit,factor,term,expr
with addop : Type
     | plus             : addop
     | minus            : addop
with mulop : Type
     | mult             : mulop
     | div              : mulop
with digit : Type
     | zero             : digit
     | one              : digit
     | two              : digit
     | three            : digit
     | four             : digit
     | five             : digit
     | six              : digit
     | seven            : digit
     | eight            : digit
     | nine             : digit
with factor : Type
     | of_digit         : digit → factor
     | of_expr          : expr  → factor
with term : Type
     | of_factor        : factor → term
     | of_mulop         : mulop → term → factor → term
with expr : Type
     | of_term          : term → expr
     | of_addop         : addop → expr → term → expr

def term.of_digit := term.of_factor ∘ factor.of_digit

def expr.of_digit := expr.of_term ∘ term.of_digit

meta mutual def eval_addop,eval_mulop,eval_digit,eval_factor,eval_term,eval_expr
with eval_addop                : addop → ℕ → ℕ → ℕ
     | addop.plus              := (nat.add)
     | addop.minus             := (nat.sub)
with eval_mulop                : mulop → ℕ → ℕ → ℕ
     | mulop.mult              := (nat.mul)
     | mulop.div               := (nat.div)
with eval_digit                : digit → ℕ
     | digit.zero              := 0
     | digit.one               := 1
     | digit.two               := 2
     | digit.three             := 3
     | digit.four              := 4
     | digit.five              := 5
     | digit.six               := 6
     | digit.seven             := 7
     | digit.eight             := 8
     | digit.nine              := 9
with eval_factor               : factor → ℕ
     | (factor.of_digit k)     := eval_digit k
     | (factor.of_expr e)      := eval_expr e
with eval_term                 : term → ℕ
     | (term.of_factor f)      := eval_factor f
     | (term.of_mulop op t f)  := (eval_mulop op) (eval_term t) (eval_factor f)
with eval_expr                 : expr → ℕ
     | (expr.of_term t)        := eval_term t
     | (expr.of_addop op e t)  := (eval_addop op) (eval_expr e) (eval_term t)

meta def nat.to_fmt : ℕ → format := nat.has_to_format.to_format

meta instance format_digit : has_to_format digit :=
⟨λ x, nat.to_fmt (eval_digit x)⟩

meta instance format_factor : has_to_format factor :=
⟨λ x, nat.to_fmt (eval_factor x)⟩

meta instance format_term : has_to_format term :=
⟨λ x, nat.to_fmt (eval_term x)⟩

meta instance format_expr : has_to_format expr :=
⟨λ x, nat.to_fmt (eval_expr x)⟩

/-
c.f. Hutton-Meijer:

expr :: Parser Int
addop :: Parser (Int -> Int -> Int)
mulop :: Parser (Int -> Int -> Int)

expr = chainl1 term addop
term = chainl1 factor mulop
factor = digit +++ (do symb "("; n <- expr; symb ")"; return n)
digit = (do <- token (sat isDigit); return(ord x - ord '0'))
addop = (do symb "+"; return (+)) <|> (do symb "-"; return (-)))
multop = (do symb "*"; return (*)) <|> (do symb "/"; return (/)))

Since mutual recursion in Lean seems to require use of the equation compiler,
we hack around this by exposing the underlying `parser_tactic.run` function,
later recovering the parser with `parser_tactic.mk`.
-/

meta mutual def parse_addop,parse_mulop,parse_digit,parse_factor,parse_term,parse_expr
with parse_addop                : string → tactic ((ℤ → ℤ → ℤ) × string)
| arg := (symb "+" >> return (+) <|> symb "-" >> return (λ x y : ℤ, x - y)).run arg
with parse_mulop                : string → tactic ((ℤ → ℤ → ℤ) × string)
| arg := (symb "*" >> return (*) <|> symb "/" >> return (λ x y : ℤ, x / y)).run arg
with parse_digit                : string → tactic (ℤ × string)
| arg := (token $ digit').run arg
with parse_factor               : string → tactic (ℤ × string)
| arg := (mk parse_digit <|> do symb "(", e <- (mk parse_expr), symb ")", return e).run arg
with parse_term                 : string → tactic (ℤ × string)
| arg := (chainl1 (mk parse_factor) (mk parse_mulop)).run arg
with parse_expr                 : string → tactic (ℤ × string)
| arg := (chainl1 (mk parse_term) (mk parse_addop)).run arg

meta def calculator : parser_tactic ℤ := mk parse_expr

run_cmd calculator.run' "(2 * (3 + 5 + (2 * 2)))"
-- 24

run_cmd calculator.run' "9 - 9 * 0 * 3 + 4 - 7"
-- 6

end calculator

end calculator

section parse_tree_from_list

inductive my_tree
| node : option string → my_tree
| join : list my_tree → option string → my_tree

open my_tree

-- def list.reflect {α} [has_reflect α] : has_reflect $ list α :=
-- begin
--   sorry
-- end

meta instance my_tree.reflect : has_reflect my_tree
| (node arg)           := `(λ x, node x).subst `(arg)
| (join xs arg)        := (`(λ xs s, join xs s).subst (by haveI := my_tree.reflect; exact list.reflect xs)).subst `(arg)

meta def my_tree_format : my_tree → format
| (node none)           := "• "
| (node $ some st)      := sformat!"{st} "
| (join xs none)        := "{• || " ++ format.join ((xs.map my_tree_format).intersperse "  |  ") ++ "}"
| (join xs $ some st)   := "{" ++ sformat!"{st} || " ++ " || " ++ format.join ((xs.map my_tree_format).intersperse "  |  ") ++ "}"

meta instance : has_to_format my_tree := ⟨my_tree_format⟩

/-
(a, b, c, (d, e), f) should be parsed as

  none -------┐
 / | \ \      |
a  b c  none  f
        |  \
        d   e
-/

meta mutual def my_tree_parser₁,my_tree_parser₂
with my_tree_parser₁ : string → tactic (my_tree × string)
| arg := ((do int <- (fail_if_nil $ delimiter'' "(" ")"),
               ts  <- (run_parser (mk my_tree_parser₂) int),
               return (my_tree.join ts none))
            <|>
           (do x <- not_str ",",
               return $ my_tree.node x)).run arg
with my_tree_parser₂ : string → tactic (list my_tree × string)
| arg := (sepby (mk my_tree_parser₁) (symb ",")).run arg

meta def my_tree_parser : parser_tactic my_tree := mk my_tree_parser₁

def my_parse_tree : my_tree := by my_tree_parser.get_result "(a,b,c)"

#print my_parse_tree

#eval (to_fmt my_parse_tree).to_string
/- {• || a   |  b   |  c } -/
run_cmd my_tree_parser.run' "(a, b, c)"
/- {• || a   |  b   |  c } -/
run_cmd my_tree_parser.run' "(a,(b,c))"
/- {• || a   |  {• || b   |  c }} -/
run_cmd my_tree_parser.run' "((a,b),c)"
/- {• || {• || a   |  b }  |  c } -/
run_cmd my_tree_parser.run' "(a, b, c, (d, e), f)"
/- {• || a   |  b   |  c   |  {• || d   |  e }  |  f } -/

section formatting_tests

example : my_tree := node none
def example_tree : my_tree := join [node none, node none, node none] "foo"

def example_tree2 : my_tree := join [join [node "a", node "b"] none, node "foo"] "bar"

run_cmd (return example_tree  : parser_tactic my_tree).run' "ab"
run_cmd (return example_tree2 : parser_tactic my_tree).run' "ab"

end formatting_tests

end parse_tree_from_list

namespace tdop
section tdop1
/- Top-down operator-precedence parsing, but with tokens hard-coded as their own inductive types -/

structure Tokens :=
(tks   : Type)
(prec  : tks → ℕ)

@[derive has_reflect, derive decidable_eq]
inductive arith_tks : Type
| of_nat : ℕ → arith_tks
| plus : arith_tks
| mul  : arith_tks
export arith_tks

meta def arith_tks.to_format : arith_tks → format := λ x, arith_tks.cases_on x (λ n, (to_fmt n)) (to_fmt "+") (to_fmt "*")

meta instance arith_tks.has_to_format : has_to_format arith_tks :=
⟨arith_tks.to_format⟩

instance : has_coe ℕ arith_tks :=
⟨of_nat⟩

def arith_Tokens : Tokens :=
{ tks := arith_tks,
  prec := arith_tks.rec (λ _, 0) 10 15 }

instance arith_tks_Tokens_coe : has_coe arith_tks arith_Tokens.tks := ⟨id⟩

inductive tdop_parse_tree (Tks : Tokens) : Type
| node : Tks.tks → tdop_parse_tree
| join : list tdop_parse_tree → Tks.tks → tdop_parse_tree
export tdop_parse_tree

meta instance arith_tree_reflect : Π τ : tdop_parse_tree arith_Tokens, reflected τ
| (node l)                  := `(λ x, node x).subst `(l)
| (join τs l)               := (λ y, `(λ x, join x y).subst (by {haveI := arith_tree_reflect, exact (list.reflect τs)})) l

def tdop_parse_tree.make_branch {Tks : Tokens} (τ : tdop_parse_tree Tks) (τ₀ : tdop_parse_tree Tks) : tdop_parse_tree Tks :=
begin
  induction τ with n j label,
    { exact tdop_parse_tree.join ([τ₀]) n },
    { exact join (τ₀ :: j) label }
end

def tdop_parse_tree.insert {Tks : Tokens} (τ : tdop_parse_tree Tks) (tk : Tks.tks) : tdop_parse_tree Tks :=
τ.make_branch (node tk)

def my_tdop_parse_tree : tdop_parse_tree arith_Tokens :=
join [node (1 : ℕ), node (2 : ℕ)] plus

meta def of.mk {α : Type} [has_reflect α] {Tks : Tokens} (Tks_eval : (tdop_parse_tree Tks) → tactic α) (τ : tdop_parse_tree Tks) : tactic unit :=
do a <- (Tks_eval τ), tactic.exact `(a)

section arith_eval

instance : has_add $ option ℕ :=
⟨λ k₁ k₂,
option.cases_on k₁ (option.cases_on k₂ none (λ _, none)) (option.cases_on k₂ (λ _, none) (λ n₁ n₂, return $ n₁ + n₂))⟩

instance : has_mul $ option ℕ :=
⟨λ k₁ k₂,
option.cases_on k₁ (option.cases_on k₂ none (λ _, none)) (option.cases_on k₂ (λ _, none) (λ n₁ n₂, return $ n₁ * n₂))⟩

meta def arith_Tokens_eval : tdop_parse_tree arith_Tokens → option ℕ
| (node arg) := arith_tks.cases_on arg pure none none
| (join xs arg) := arith_tks.cases_on arg (λ _, none) ((xs.map arith_Tokens_eval).foldr (+) (some 0)) ((xs.map arith_Tokens_eval).foldr (*) (some 0))

meta def of_arith_Tokens : tdop_parse_tree arith_Tokens → tactic unit :=
of.mk (λ x, arith_Tokens_eval x)

meta def my_three : ℕ := by of_arith_Tokens my_tdop_parse_tree

#eval my_three -- 3

end arith_eval

meta def arith_tks.parse : parser_tactic arith_tks :=
     ((do n <- number, return n) <* whitespace)
 <|> (token (str "+") >> return plus)
 <|> (token (str "*") >> return mul)

-- run_cmd (repeat $ arith_tks.parse).run' "1 + 3 + 5 * 2"

meta def parse_nat : Π (left : tdop_parse_tree arith_Tokens), string → tactic (tdop_parse_tree arith_Tokens × string)
| left arg := (do n <- (token number), return (left.insert (of_nat n))).run arg

meta def parse_plus : Π (left : tdop_parse_tree arith_Tokens), string → tactic (tdop_parse_tree arith_Tokens × string)
| left arg := (token (str "+") >> return ((node plus : tdop_parse_tree arith_Tokens).make_branch left)).run arg

meta def parse_mul  : Π (left : tdop_parse_tree arith_Tokens), string → tactic (tdop_parse_tree arith_Tokens × string)
| left arg := (token (str "*") >> return ((node mul : tdop_parse_tree arith_Tokens).make_branch left)).run arg

meta def arith_tdop_parser' : Π (left : tdop_parse_tree arith_Tokens), parser_tactic (tdop_parse_tree arith_Tokens)
| left := (mk $ parse_nat left) <|> (mk $ parse_plus left) <|> (mk $ parse_mul left)

meta def arith_tdop_parser_aux : Π flag : bool, Π result : tdop_parse_tree arith_Tokens,  parser_tactic (tdop_parse_tree arith_Tokens)
| ff _ := arith_tdop_parser' (node $ of_nat 0) >>= arith_tdop_parser_aux tt
| tt τ := (arith_tdop_parser' τ >>= arith_tdop_parser_aux tt) <|> return τ

meta def arith_tdop_parser : parser_tactic (tdop_parse_tree arith_Tokens)
:= arith_tdop_parser_aux ff (node $ of_nat 0)

meta def tdop_arith.to_format : (tdop_parse_tree arith_Tokens) → format
| (node l) := arith_tks.to_format l
| (join τs l) := "( " ++ (tdop_arith.to_format $ node l) ++ " || " ++ (string.join (((τs.map tdop_arith.to_format).map format.to_string).intersperse " ,")) ++ ")"

meta instance tdop_parse_to_format : has_to_format (tdop_parse_tree arith_Tokens) := ⟨tdop_arith.to_format⟩

run_cmd (do arith_tdop_parser' (node $ of_nat 0) >>= arith_tdop_parser' >>= arith_tdop_parser').run' "1 + 2"

--TODO(jesse) fix this
run_cmd (arith_tdop_parser).run' "1 + 2 + 3 * 4 + 5"

end tdop1
end tdop


import Lean

set_option linter.missingDocs false
set_option linter.all true

def explicitlyUsedVariable (x : Nat) : Nat :=
  x

theorem implicitlyUsedVariable : P ∧ Q → Q := by
  intro HPQ
  have HQ : Q := by exact And.right HPQ
  assumption

axiom axiomVariable (x : Prop) : True

def unusedVariables (x : Nat) : Nat :=
  let y := 5
  3

def usedAndUnusedVariables : Nat :=
  let x : Nat :=
    let x := 5
    3
  x

def unusedWhereVariable : Nat :=
  3
where
  x := 5

def unusedWhereArgument : Nat :=
  f 2
where
  f (x : Nat) := 3

def unusedWhereFunction : Nat :=
  2
where
  f (x : Nat) := 3

def unusedFunctionArgument : Nat :=
  (fun x => 3) (x := 2)

def unusedTypedFunctionArgument : Nat :=
  (fun (x : Nat) => 3) 2

def pattern (x y : Option Nat) : Nat :=
  match x with
  | some z =>
    match y with
    | some z => 1
    | none => 0
  | none => 0

def patternLet (x : Option Nat) : Nat :=
  if let some y := x then
    0
  else
    1

def patternMatches (x : Option Nat) : Nat :=
  if x matches some y then
    0
  else
    1

def implicitVariables {α : Type} [inst : ToString α] : Nat := 4

def autoImplicitVariable [Inhabited α] := 5

def unusedArrow : (x : Nat) → Nat := fun x => x

def mutVariable (x : Nat) : Nat := Id.run <| do
  let mut y := 5
  if x == 5 then
    y := 3
  y

def mutVariableDo (list : List Nat) : Nat := Id.run <| do
  let mut sum := 0
  for elem in list do
    sum := sum + elem
  return sum

def mutVariableDo2 (list : List Nat) : Nat := Id.run <| do
  let mut sum := 0
  for _ in list do
    sum := sum.add 1
  return sum

def unusedVariablesPattern (_x : Nat) : Nat :=
  let _y := 5
  3

set_option linter.unusedVariables false in
def nolintUnusedVariables (x : Nat) : Nat :=
  let y := 5
  3

set_option linter.all false in
def nolintAll (x : Nat) : Nat :=
  let y := 5
  3

set_option linter.all false in
set_option linter.unusedVariables true in
def lintUnusedVariables (x : Nat) : Nat :=
  let y := 5
  3

set_option linter.unusedVariables.funArgs false in
def nolintFunArgs (w : Nat) : Nat :=
  let a := 5
  let f (x : Nat) := 3
  let g := fun (y : Nat) => 3
  f <| g <| h <| 2
where
  h (z : Nat) := 3

set_option linter.unusedVariables.patternVars false in
def nolintPatternVars (x : Option (Option Nat)) : Nat :=
  match x with
  | some (some y) => (fun z => 1) 2
  | _ => 0

set_option linter.unusedVariables.patternVars false in
theorem nolintPatternVarsInduction (n : Nat) : True := by
  induction n with
  | zero => exact True.intro
  | succ m =>
    have h : True := by simp
    exact True.intro

inductive Foo (α : Type)
  | foo (x : Nat) (y : Nat)

structure Bar (α : Type) where
  bar (x : Nat) : Nat
  bar' (x : Nat) : Nat := 3

class Baz (α : Type) where
  baz (x : Nat) : Nat
  baz' (x : Nat) : Nat :=
    let y := 5
    3

instance instBaz (α β : Type) : Baz α where
  baz (x : Nat) := 5

structure State where
  fieldA : Nat
  fieldB : Nat

abbrev M := StateT State Id

def modifyState : M Unit := do
  let s ← get
  modify fun s => { s with fieldA := s.fieldA + 1 }

def modifyState' : M Unit := do
  modify fun s => { s with fieldA := 1}

def modifyStateUnnecessaryWith : M Unit := do
  modify fun s => { s with fieldA := 1, fieldB := 2 }

def universeParam.{u} (T : Type u) (t : T) : T := t

open Lean in
initialize tc : Unit ← registerTraceClass `Baz

register_option opt : Nat := {
  defValue := 3
  descr := "test option"
}

opaque foo (x : Nat) : Nat
opaque foo' (x : Nat) : Nat :=
  let y := 5
  3
variable (bar)
variable (bar' : (x : Nat) → Nat)
variable {α β} [inst : ToString α]

@[specialize]
def specializeDef (x : Nat) : Nat := 3

@[implemented_by specializeDef]
def implementedByDef (x : Nat) : Nat :=
  let y := 3
  5

@[extern "test"]
def externDef (x : Nat) : Nat :=
  let y := 3
  5

@[extern "test"]
opaque externConst (x : Nat) : Nat :=
  let y := 3
  5

macro "useArg " name:declId arg:ident : command => `(def $name ($arg : α) : α := $arg)
useArg usedMacroVariable a

macro "doNotUseArg " name:declId arg:ident : command => `(def $name ($arg : α) : Nat := 3)
doNotUseArg unusedMacroVariable b

macro "ignoreArg " id:declId sig:declSig : command => `(opaque $id $sig)
ignoreArg ignoredMacroVariable (x : UInt32) : UInt32

theorem not_eq_zero_of_lt (h : b < a) : a ≠ 0 := by -- *not* unused
  cases a
  exact absurd h (Nat.not_lt_zero _)
  apply Nat.noConfusion

-- should not be reported either
example (a : Nat) : Nat := _
example (a : Nat) : Nat := sorry
example (a : sorry) : Nat := 0
example (a : Nat) : Nat := by

theorem Fin.eqq_of_val_eq {n : Nat} : ∀ {x y : Fin n}, x.val = y.val → x = y
  | ⟨_, _⟩, _, rfl => rfl

def Nat.discriminate (n : Nat) (H1 : n = 0 → α) (H2 : ∀ m, n = succ m → α) : α :=
  match n with
  | 0 => H1 rfl
  | succ m => H2 m rfl

@[unused_variables_ignore_fn]
def ignoreEverything : Lean.Linter.IgnoreFunction :=
  fun _ _ _ => true

def ignored (x : Nat) := 0


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.ScopedEnvExtension
import Lean.Util.Recognizers
import Lean.Util.CollectMVars
import Lean.Meta.Basic

namespace Lean.Meta

/--
  Data for user-defined theorems marked with the `congr` attribute.

  This type should be confused with `CongrTheorem` which reprents different kinds of automatically
  generated congruence theorems. The `simp` tactic also uses some of them.
-/
structure SimpCongrTheorem where
  theoremName   : Name
  funName       : Name
  hypothesesPos : Array Nat
  priority      : Nat
deriving Inhabited, Repr

structure SimpCongrTheorems where
  lemmas : SMap Name (List SimpCongrTheorem) := {}
  deriving Inhabited, Repr

def SimpCongrTheorems.get (d : SimpCongrTheorems) (declName : Name) : List SimpCongrTheorem :=
  match d.lemmas.find? declName with
  | none    => []
  | some cs => cs

def addSimpCongrTheoremEntry (d : SimpCongrTheorems) (e : SimpCongrTheorem) : SimpCongrTheorems :=
  { d with lemmas :=
      match d.lemmas.find? e.funName with
      | none    => d.lemmas.insert e.funName [e]
      | some es => d.lemmas.insert e.funName <| insert es }
where
  insert : List SimpCongrTheorem → List SimpCongrTheorem
    | []     => [e]
    | e'::es => if e.priority ≥ e'.priority then e::e'::es else e' :: insert es

builtin_initialize congrExtension : SimpleScopedEnvExtension SimpCongrTheorem SimpCongrTheorems ←
  registerSimpleScopedEnvExtension {
    name           := `congrExt
    initial        := {}
    addEntry       := addSimpCongrTheoremEntry
    finalizeImport := fun s => { s with lemmas := s.lemmas.switch }
  }

def mkSimpCongrTheorem (declName : Name) (prio : Nat) : MetaM SimpCongrTheorem := withReducible do
  let c ← mkConstWithLevelParams declName
  let (xs, bis, type) ← forallMetaTelescopeReducing (← inferType c)
  match type.eq? with
  | none => throwError "invalid 'congr' theorem, equality expected{indentExpr type}"
  | some (_, lhs, rhs) =>
    lhs.withApp fun lhsFn lhsArgs => rhs.withApp fun rhsFn rhsArgs => do
      unless lhsFn.isConst && rhsFn.isConst && lhsFn.constName! == rhsFn.constName! && lhsArgs.size == rhsArgs.size do
        throwError "invalid 'congr' theorem, equality left/right-hand sides must be applications of the same function{indentExpr type}"
      let mut foundMVars : MVarIdSet := {}
      for lhsArg in lhsArgs do
        for mvarId in (lhsArg.collectMVars {}).result do
          foundMVars := foundMVars.insert mvarId
      let mut i := 0
      let mut hypothesesPos := #[]
      for x in xs, bi in bis do
        if bi.isExplicit && !foundMVars.contains x.mvarId! then
          let rhsFn? ← forallTelescopeReducing (← inferType x) fun ys xType => do
            match xType.eq? with
            | none => pure none -- skip
            | some (_, xLhs, xRhs) =>
              let mut j := 0
              for y in ys do
                let yType ← inferType y
                unless onlyMVarsAt yType foundMVars do
                  throwError "invalid 'congr' theorem, argument #{j+1} of parameter #{i+1} contains unresolved parameter{indentExpr yType}"
                j := j + 1
              unless onlyMVarsAt xLhs foundMVars do
                throwError "invalid 'congr' theorem, parameter #{i+1} is not a valid hypothesis, the left-hand-side contains unresolved parameters{indentExpr xLhs}"
              let xRhsFn := xRhs.getAppFn
              unless xRhsFn.isMVar do
                throwError "invalid 'congr' theorem, parameter #{i+1} is not a valid hypothesis, the right-hand-side head is not a metavariable{indentExpr xRhs}"
              unless !foundMVars.contains xRhsFn.mvarId! do
                throwError "invalid 'congr' theorem, parameter #{i+1} is not a valid hypothesis, the right-hand-side head was already resolved{indentExpr xRhs}"
              for arg in xRhs.getAppArgs do
                unless arg.isFVar do
                  throwError "invalid 'congr' theorem, parameter #{i+1} is not a valid hypothesis, the right-hand-side argument is not local variable{indentExpr xRhs}"
              pure (some xRhsFn)
          match rhsFn? with
          | none       => pure ()
          | some rhsFn =>
            foundMVars    := foundMVars.insert x.mvarId! |>.insert rhsFn.mvarId!
            hypothesesPos := hypothesesPos.push i
        i := i + 1
      trace[Meta.debug] "c: {c} : {type}"
      return {
        theoremName   := declName
        funName       := lhsFn.constName!
        hypothesesPos := hypothesesPos
        priority      := prio
      }
where
  /-- Return `true` if `t` contains a metavariable that is not in `mvarSet` -/
  onlyMVarsAt (t : Expr) (mvarSet : MVarIdSet) : Bool :=
    Option.isNone <| t.find? fun e => e.isMVar && !mvarSet.contains e.mvarId!

def addSimpCongrTheorem (declName : Name) (attrKind : AttributeKind) (prio : Nat) : MetaM Unit := do
  let lemma ← mkSimpCongrTheorem declName prio
  congrExtension.add lemma attrKind

builtin_initialize
  registerBuiltinAttribute {
    name  := `congr
    descr := "congruence theorem"
    add   := fun declName stx attrKind => do
      let prio ← getAttrParamOptPrio stx[1]
      discard <| addSimpCongrTheorem declName attrKind prio |>.run {} {}
  }

def getSimpCongrTheorems : MetaM SimpCongrTheorems :=
  return congrExtension.getState (← getEnv)

end Lean.Meta


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

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

universes u v w l u_1 u_2 u₀ u₁ v₀ v₁

namespace Mathlib

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

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

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

class is_lawful_monad_cont (m : Type u → Type v) [Monad m] [monad_cont m]
extends is_lawful_monad m
where
  call_cc_bind_right : ∀ {α ω γ : Type u} (cmd : m α) (next : monad_cont.label ω m γ → α → m ω),
  (monad_cont.call_cc fun (f : monad_cont.label ω m γ) => cmd >>= next f) =
    do
      let x ← cmd
      monad_cont.call_cc fun (f : monad_cont.label ω m γ) => next f x
  call_cc_bind_left : ∀ {α : Type u} (β : Type u) (x : α) (dead : monad_cont.label α m β → β → m α),
  (monad_cont.call_cc fun (f : monad_cont.label α m β) => monad_cont.goto f x >>= dead f) = pure x
  call_cc_dummy : ∀ {α β : Type u} (dummy : m α), (monad_cont.call_cc fun (f : monad_cont.label α m β) => dummy) = dummy

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

def cont (r : Type u) (α : Type w) :=
  cont_t r id α

namespace cont_t

def run {r : Type u} {m : Type u → Type v} {α : Type w} : cont_t r m α → (α → m r) → m r :=
  id

def map {r : Type u} {m : Type u → Type v} {α : Type w} (f : m r → m r) (x : cont_t r m α) : cont_t r m α :=
  f ∘ x

theorem run_cont_t_map_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} (f : m r → m r) (x : cont_t r m α) : run (map f x) = f ∘ run x :=
  rfl

def with_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} {β : Type w} (f : (β → m r) → α → m r) (x : cont_t r m α) : cont_t r m β :=
  fun (g : β → m r) => x (f g)

theorem run_with_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} {β : Type w} (f : (β → m r) → α → m r) (x : cont_t r m α) : run (with_cont_t f x) = run x ∘ f :=
  rfl

protected theorem ext {r : Type u} {m : Type u → Type v} {α : Type w} {x : cont_t r m α} {y : cont_t r m α} (h : ∀ (f : α → m r), run x f = run y f) : x = y :=
  funext fun (x_1 : α → m r) => h x_1

protected instance monad {r : Type u} {m : Type u → Type v} : Monad (cont_t r m) := sorry

protected instance is_lawful_monad {r : Type u} {m : Type u → Type v} : is_lawful_monad (cont_t r m) :=
  is_lawful_monad.mk
    (fun (α β : Type u_1) (x : α) (f : α → cont_t r m β) =>
      cont_t.ext fun (f_1 : β → m r) => Eq.refl (run (pure x >>= f) f_1))
    fun (α β γ : Type u_1) (x : cont_t r m α) (f : α → cont_t r m β) (g : β → cont_t r m γ) =>
      cont_t.ext fun (f_1 : γ → m r) => Eq.refl (run (x >>= f >>= g) f_1)

def monad_lift {r : Type u} {m : Type u → Type v} [Monad m] {α : Type u} : m α → cont_t r m α :=
  fun (x : m α) (f : α → m r) => x >>= f

protected instance has_monad_lift {r : Type u} {m : Type u → Type v} [Monad m] : has_monad_lift m (cont_t r m) :=
  has_monad_lift.mk fun (α : Type u) => monad_lift

theorem monad_lift_bind {r : Type u} {m : Type u → Type v} [Monad m] [is_lawful_monad m] {α : Type u} {β : Type u} (x : m α) (f : α → m β) : monad_lift (x >>= f) = monad_lift x >>= monad_lift ∘ f := sorry

protected instance monad_cont {r : Type u} {m : Type u → Type v} : monad_cont (cont_t r m) :=
  monad_cont.mk
    fun (α β : Type u_1) (f : label α (cont_t r m) β → cont_t r m α) (g : α → m r) =>
      f (monad_cont.label.mk fun (x : α) (h : β → m r) => g x) g

protected instance is_lawful_monad_cont {r : Type u} {m : Type u → Type v} : is_lawful_monad_cont (cont_t r m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

protected instance monad_except {r : Type u} {m : Type u → Type v} (ε : outParam (Type u_1)) [monad_except ε m] : monad_except ε (cont_t r m) :=
  monad_except.mk (fun (x : Type u_2) (e : ε) (f : x → m r) => throw e)
    fun (α : Type u_2) (act : cont_t r m α) (h : ε → cont_t r m α) (f : α → m r) => catch (act f) fun (e : ε) => h e f

protected instance monad_run {r : Type u} {m : Type u → Type v} : monad_run (fun (α : Type u) => (α → m r) → ulift (m r)) (cont_t r m) :=
  monad_run.mk fun (α : Type u) (f : cont_t r m α) (x : α → m r) => ulift.up (f x)

end cont_t

def except_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {ε : Type u} : label (except ε α) m β → label α (except_t ε m) β :=
  sorry

theorem except_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {ε : Type u} (x : label (except ε α) m β) (i : α) : goto (except_t.mk_label x) i = except_t.mk (except.ok <$> goto x (except.ok i)) :=
  monad_cont.label.cases_on x fun (x : except ε α → m β) => Eq.refl (goto (except_t.mk_label (monad_cont.label.mk x)) i)

def except_t.call_cc {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] {α : Type u} {β : Type u} (f : label α (except_t ε m) β → except_t ε m α) : except_t ε m α :=
  except_t.mk (monad_cont.call_cc fun (x : label (except ε α) m β) => except_t.run (f (except_t.mk_label x)))

protected instance except_t.monad_cont {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] : monad_cont (except_t ε m) :=
  monad_cont.mk fun (α β : Type u) => except_t.call_cc

protected instance except_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (except_t ε m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def option_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} : label (Option α) m β → label α (option_t m) β :=
  sorry

theorem option_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} (x : label (Option α) m β) (i : α) : goto (option_t.mk_label x) i = option_t.mk (some <$> goto x (some i)) :=
  monad_cont.label.cases_on x fun (x : Option α → m β) => Eq.refl (goto (option_t.mk_label (monad_cont.label.mk x)) i)

def option_t.call_cc {m : Type u → Type v} [Monad m] [monad_cont m] {α : Type u} {β : Type u} (f : label α (option_t m) β → option_t m α) : option_t m α :=
  option_t.mk (monad_cont.call_cc fun (x : label (Option α) m β) => option_t.run (f (option_t.mk_label x)))

protected instance option_t.monad_cont {m : Type u → Type v} [Monad m] [monad_cont m] : monad_cont (option_t m) :=
  monad_cont.mk fun (α β : Type u) => option_t.call_cc

protected instance option_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (option_t m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def writer_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} {ω : Type u} [HasOne ω] : label (α × ω) m β → label α (writer_t ω m) β :=
  sorry

theorem writer_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} {ω : Type u} [HasOne ω] (x : label (α × ω) m β) (i : α) : goto (writer_t.mk_label x) i = monad_lift (goto x (i, 1)) :=
  monad_cont.label.cases_on x fun (x : α × ω → m β) => Eq.refl (goto (writer_t.mk_label (monad_cont.label.mk x)) i)

def writer_t.call_cc {m : Type u → Type v} [Monad m] [monad_cont m] {α : Type u} {β : Type u} {ω : Type u} [HasOne ω] (f : label α (writer_t ω m) β → writer_t ω m α) : writer_t ω m α :=
  writer_t.mk (monad_cont.call_cc (writer_t.run ∘ f ∘ writer_t.mk_label))

protected instance writer_t.monad_cont {m : Type u → Type v} [Monad m] (ω : Type u) [Monad m] [HasOne ω] [monad_cont m] : monad_cont (writer_t ω m) :=
  monad_cont.mk fun (α β : Type u) => writer_t.call_cc

def state_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {σ : Type u} : label (α × σ) m (β × σ) → label α (state_t σ m) β :=
  sorry

theorem state_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {σ : Type u} (x : label (α × σ) m (β × σ)) (i : α) : goto (state_t.mk_label x) i = state_t.mk fun (s : σ) => goto x (i, s) :=
  monad_cont.label.cases_on x fun (x : α × σ → m (β × σ)) => Eq.refl (goto (state_t.mk_label (monad_cont.label.mk x)) i)

def state_t.call_cc {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] {α : Type u} {β : Type u} (f : label α (state_t σ m) β → state_t σ m α) : state_t σ m α :=
  state_t.mk
    fun (r : σ) => monad_cont.call_cc fun (f' : label (α × σ) m (β × σ)) => state_t.run (f (state_t.mk_label f')) r

protected instance state_t.monad_cont {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] : monad_cont (state_t σ m) :=
  monad_cont.mk fun (α β : Type u) => state_t.call_cc

protected instance state_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (state_t σ m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def reader_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} (ρ : Type u) : label α m β → label α (reader_t ρ m) β :=
  sorry

theorem reader_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {ρ : Type u} {β : Type u} (x : label α m β) (i : α) : goto (reader_t.mk_label ρ x) i = monad_lift (goto x i) :=
  monad_cont.label.cases_on x fun (x : α → m β) => Eq.refl (goto (reader_t.mk_label ρ (monad_cont.label.mk x)) i)

def reader_t.call_cc {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] {α : Type u} {β : Type u} (f : label α (reader_t ε m) β → reader_t ε m α) : reader_t ε m α :=
  reader_t.mk fun (r : ε) => monad_cont.call_cc fun (f' : label α m β) => reader_t.run (f (reader_t.mk_label ε f')) r

protected instance reader_t.monad_cont {m : Type u → Type v} [Monad m] {ρ : Type u} [monad_cont m] : monad_cont (reader_t ρ m) :=
  monad_cont.mk fun (α β : Type u) => reader_t.call_cc

protected instance reader_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {ρ : Type u} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (reader_t ρ m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

/-- reduce the equivalence between two continuation passing monads to the equivalence between
their underlying monad -/
def cont_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ : Type u₀} {r₁ : Type u₀} {α₂ : Type u₁} {r₂ : Type u₁} (F : m₁ r₁ ≃ m₂ r₂) (G : α₁ ≃ α₂) : cont_t r₁ m₁ α₁ ≃ cont_t r₂ m₂ α₂ :=
  equiv.mk
    (fun (f : cont_t r₁ m₁ α₁) (r : α₂ → m₂ r₂) => coe_fn F (f fun (x : α₁) => coe_fn (equiv.symm F) (r (coe_fn G x))))
    (fun (f : cont_t r₂ m₂ α₂) (r : α₁ → m₁ r₁) =>
      coe_fn (equiv.symm F) (f fun (x : α₂) => coe_fn F (r (coe_fn (equiv.symm G) x))))
    sorry sorry


import tactic.lint
import algebra.group.basic

/-! ## Commutativity lemmas should be rejected  -/

attribute [simp] add_comm add_left_comm

open tactic
run_cmd do
decl ← get_decl ``add_comm,
res ← linter.simp_comm.test decl,
-- linter complains
guard res.is_some

open tactic
run_cmd do
decl ← get_decl ``add_left_comm,
res ← linter.simp_comm.test decl,
-- linter complains
guard res.is_some

/-! ## Floris' trick should be accepted -/

@[simp] lemma list.filter_congr_decidable {α} (s : list α) (p : α → Prop) (h : decidable_pred p)
  [decidable_pred p] : @list.filter α p h s = s.filter p :=
by congr

-- lemma is unproblematic
example : @list.filter _ (λ x, x > 0) (λ _, classical.prop_decidable _) [1,2,3] = [1,2,3] :=
begin
  -- can rewrite once
  simp only [list.filter_congr_decidable],
  -- but not twice
  success_if_fail { simp only [list.filter_congr_decidable] },
  refl
end

open tactic
set_option pp.all true
run_cmd do
decl ← get_decl ``list.filter_congr_decidable,
res ← linter.simp_comm.test decl,
-- linter does not complain
guard res.is_none


import free_pfpng.epi
import free_pfpng.mono

noncomputable theory

open_locale classical big_operators

open category_theory
open opposite
open category_theory.grothendieck_topology

universe u

lemma Condensed.is_zero_of_is_zero_obj (A : Condensed.{u} Ab.{u+1})
  (hA : ∀ S : Profinite.{u}, limits.is_zero (A.val.obj (opposite.op S))) :
  limits.is_zero A :=
{ unique_to := λ Y, nonempty.intro
  { default := 0,
    uniq := λ a, begin
      ext t : 3,
      apply (hA t.unop).eq_of_src,
    end },
  unique_from := λ Y, nonempty.intro
  { default := 0,
    uniq := λ a, begin
      ext t : 3,
      apply (hA t.unop).eq_of_tgt
    end } }

lemma Profinite.free_pfpng_eq_zero_of_empty (S : Profinite.{u}) [is_empty S]
  (a : S.free_pfpng) : a = 0 :=
begin
  let E : limits.cone ((S.fintype_diagram ⋙ free_pfpng_functor)) :=
    ProFiltPseuNormGrp₁.bounded_cone ⟨Ab.explicit_limit_cone.{u u} _,
      Ab.explicit_limit_cone_is_limit _⟩,
  let hE : limits.is_limit E :=
    ProFiltPseuNormGrp₁.bounded_cone_is_limit _,
  let ee : S.free_pfpng ≅ E.X :=
    (limits.limit.is_limit _).cone_point_unique_up_to_iso hE,
  apply_fun ee.hom, swap,
  { intros x y h, apply_fun ee.inv at h, simpa using h },
  rw ee.hom.map_zero, ext T t,
  obtain ⟨s⟩ := t,
  apply is_empty.elim _ (s : S), assumption
end

lemma Profinite.is_zero_of_empty (S : Profinite.{u}) [is_empty S] :
  limits.is_zero S.condensed_free_pfpng :=
begin
  apply Condensed.is_zero_of_is_zero_obj,
  intros T,
  dsimp [Profinite.condensed_free_pfpng],
  dsimp [CompHausFiltPseuNormGrp.presheaf],
  apply is_zero_Ab,
  rintros ⟨⟨f,hf⟩⟩, ext t, change f t = 0,
  apply Profinite.free_pfpng_eq_zero_of_empty,
end

lemma category_theory.abelian.is_iso_of_mono_of_is_zero
  {A : Type*} [category A] [abelian A] {X Y : A} (f : X ⟶ Y) [mono f]
  (hY : limits.is_zero Y) : is_iso f :=
begin
  use 0, simp, split,
  rw ← cancel_mono f,
  apply hY.eq_of_tgt,
  apply hY.eq_of_tgt,
end

instance Profinite.epi_free'_to_condensed_free_pfpng_of_empty
  (S : Profinite.{u}) [is_empty S] :
  epi S.free'_to_condensed_free_pfpng :=
begin
  suffices : is_iso S.free'_to_condensed_free_pfpng,
  { resetI, apply_instance },
  apply category_theory.abelian.is_iso_of_mono_of_is_zero,
  apply Profinite.is_zero_of_empty,
end

-- Do a case split on `[nonempty S]` here.
instance Profinite.epi_free'_to_condensed_free_pfpng (S : Profinite.{u}) :
  epi S.free'_to_condensed_free_pfpng :=
begin
  by_cases hS : nonempty S, { resetI, apply_instance },
  simp only [not_nonempty_iff] at hS,
  resetI, apply_instance
end

instance Profinite.is_iso_free'_to_condensed_free_pfpng
  (S : Profinite.{u}) : is_iso S.free'_to_condensed_free_pfpng :=
is_iso_of_mono_of_epi _

def Profinite.free_to_pfpng (S : Profinite.{u}) :
  CondensedSet_to_Condensed_Ab.obj S.to_Condensed ⟶
  S.condensed_free_pfpng :=
(Condensed_Ab_CondensedSet_adjunction.hom_equiv _ _).symm S.to_condensed_free_pfpng

attribute [simps hom_app] AddCommGroup.free_iso_free'

instance Profinite.is_iso_free_to_pfpng (S : Profinite.{u}) : is_iso S.free_to_pfpng :=
begin
  suffices : S.free_to_pfpng =
    (CondensedSet_to_Condensed_Ab_iso.app S.to_Condensed).hom ≫
    S.free'_to_condensed_free_pfpng,
  { rw this, apply_instance },
  rw [iso.app_hom],
  delta Profinite.free'_to_condensed_free_pfpng Profinite.free'_lift Profinite.free_to_pfpng
    CondensedSet_to_Condensed_Ab_iso Sheaf.adjunction
    Condensed_Ab_CondensedSet_adjunction Condensed_Ab_CondensedSet_adjunction',
  ext T : 4,
  dsimp only [adjunction.mk_of_hom_equiv_hom_equiv, functor.map_iso_hom, quiver.hom.forget_Ab,
    Sheaf.hom.comp_val, Condensed_Ab_to_CondensedSet_map, Sheaf.compose_equiv_symm_apply_val,
    presheaf_to_Sheaf_map_val, nat_trans.comp_app,
    iso_whisker_left_hom, iso_whisker_right_hom, whisker_left_app, whisker_right_app],
  rw [← nat_trans.comp_app, sheafify_map_sheafify_lift],
  congr' 4, clear T,
  ext T : 2,
  dsimp only [whiskering_right_map_app_app, whiskering_right_obj_map, nat_trans.comp_app,
    adjunction.whisker_right, adjunction.mk_of_unit_counit_hom_equiv_symm_apply,
    whisker_left_app, whisker_right_app,
    functor.associator_hom_app, functor.right_unitor_hom_app],
  erw [category.id_comp, category.id_comp, category.comp_id, category.comp_id],
  rw [← nat_trans.naturality_assoc],
  congr' 1,
  dsimp only [AddCommGroup.adj, AddCommGroup.adj', adjunction.mk_of_hom_equiv_hom_equiv,
    adjunction.of_nat_iso_left, adjunction.mk_of_hom_equiv_counit_app,
    equiv.inv_fun_as_coe, equiv.symm_trans_apply, iso.symm_hom,
    adjunction.equiv_homset_left_of_nat_iso_symm_apply],
  simp only [equiv.symm_symm],
  erw [← category.assoc, ← nat_trans.comp_app, iso.hom_inv_id, nat_trans.id_app,
    category.id_comp],
end

lemma free_pfpng_profinite_natural_map_aux (S T : Profinite.{u}) (f : S ⟶ T) :
  f ≫ T.to_free_pfpng = S.to_free_pfpng ≫
    (ProFiltPseuNormGrp₁.level.obj 1).map
    ((Profinite.extend free_pfpng_functor).map f) :=
begin
  apply (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
   (limits.limit.is_limit _)).hom_ext,
  intros W, dsimp [Profinite.to_free_pfpng,
    Profinite.free_pfpng_level_iso, limits.is_limit.cone_point_unique_up_to_iso,
    limits.is_limit.map],
  simp only [category.assoc],
  erw (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
    (limits.limit.is_limit (T.fintype_diagram ⋙ free_pfpng_functor))).fac,
  erw limits.limit.lift_π,
  swap, apply_instance,
  simp only [← functor.map_comp, limits.limit.lift_π],
  dsimp [Profinite.change_cone],
  simp only [functor.map_comp],
  erw (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
    (limits.limit.is_limit (S.fintype_diagram ⋙ free_pfpng_functor))).fac_assoc,
  erw limits.limit.lift_π_assoc,
  ext, dsimp [Profinite.as_limit_cone, Fintype.free_pfpng_unit, free_pfpng.map,
    ProFiltPseuNormGrp₁.level],
  rcases x with ⟨x⟩,
  simp only [finset.filter_congr_decidable],
  erw [finset.sum_filter, finset.sum_ite, finset.sum_ite],
  simp only [finset.filter_congr_decidable, finset.sum_const,
    nat.smul_one_eq_coe, finset.sum_const_zero, add_zero],
  rw finset.filter_filter,
  split_ifs,
  { symmetry, norm_cast, rw finset.card_eq_one,
    use (W.comap f.2).proj a,
    rw finset.eq_singleton_iff_nonempty_unique_mem,
    split,
    { rw finset.filter_nonempty_iff,
      use (W.comap f.2).proj a,
      refine ⟨finset.mem_univ _, h, rfl⟩ },
    { rintros ⟨q⟩ hq,
      simp only [finset.mem_filter, finset.mem_univ, true_and] at hq,
      erw hq.2 } },
  { symmetry, norm_cast,
    simp only [finset.card_eq_zero],
    rw finset.filter_eq_empty_iff,
    rintros ⟨q⟩ -, push_neg, intros hh,
    rw ← hh at h,
    erw discrete_quotient.map_proj_apply at h,
    contrapose! h,
    let e : (W.comap f.2) → W := discrete_quotient.map (le_refl _),
    apply_fun e at h, exact h },
end

def free_pfpng_profinite_natural_map :
  Profinite_to_Condensed ⋙ CondensedSet_to_Condensed_Ab ⟶
  Profinite.extend free_pfpng_functor ⋙
  PFPNG₁_to_CHFPNG₁ₑₗ ⋙
  CHFPNG₁_to_CHFPNGₑₗ ⋙
  CompHausFiltPseuNormGrp.to_Condensed :=
{ app := λ X, X.free_to_pfpng,
  naturality' := λ S T f, begin
    -- we should be able to precompose with the natural map `S.to_Condensed ⟶ S.free'`
    -- how do we do that?
    -- Answer: use `adjunction.hom_equiv`.
    dsimp only [functor.comp_map],
    dsimp only [Profinite.free_to_pfpng],
    apply_fun (Condensed_Ab_CondensedSet_adjunction.hom_equiv _ _),
    simp only [adjunction.hom_equiv_unit, adjunction.hom_equiv_counit, functor.map_comp],
    simp only [nat_trans.naturality, category.assoc, nat_trans.naturality_assoc],
    dsimp only [Profinite.condensed_free_pfpng],
    have := Condensed_Ab_CondensedSet_adjunction.unit.naturality
      (Profinite_to_Condensed.map f),
    dsimp only [functor.comp_map] at this,
    slice_lhs 1 2 { rw ← this }, clear this,
    dsimp only [functor.id_map], simp only [category.assoc],
    have := Condensed_Ab_CondensedSet_adjunction.unit.naturality
      S.to_condensed_free_pfpng,
    dsimp only [functor.comp_map] at this,
    slice_rhs 1 2 { erw ← this }, clear this,
    dsimp only [functor.id_map], simp only [category.assoc],
    have := Condensed_Ab_CondensedSet_adjunction.right_triangle_components,
    slice_rhs 2 3 { erw this }, clear this,
    erw category.id_comp,
    slice_lhs 2 3 { erw ← nat_trans.naturality },
    simp only [functor.id_map, category.assoc],
    have := Condensed_Ab_CondensedSet_adjunction.right_triangle_components,
    slice_lhs 3 4 { rw this }, clear this,
    erw category.comp_id,
    ext W ⟨t⟩ : 7, change W.unop ⟶ S at t,

    dsimp [Profinite.to_condensed_free_pfpng,
      CompHausFiltPseuNormGrp.level_Condensed_diagram_cocone,
      Ab.ulift, Profinite.to_free_pfpng_level],
    erw ← comp_apply,
    erw ← comp_apply,
    erw ← comp_apply,
    rw free_pfpng_profinite_natural_map_aux _ _ f, refl,
  end }

instance free_pfpng_profinite_natural_map_is_iso :
  is_iso free_pfpng_profinite_natural_map :=
begin
  apply_with nat_iso.is_iso_of_is_iso_app { instances := ff },
  intros X,
  apply X.is_iso_free_to_pfpng,
end

def free_pfpng_profinite_iso_aux :
  condensify (free_pfpng_functor ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) ≅
  ((Profinite.extend free_pfpng_functor ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) ⋙
    CHFPNG₁_to_CHFPNGₑₗ) ⋙
    CompHausFiltPseuNormGrp.to_Condensed :=
iso_whisker_right
  (iso_whisker_right
    (Profinite.extend_commutes free_pfpng_functor PFPNG₁_to_CHFPNG₁ₑₗ).symm
    CHFPNG₁_to_CHFPNGₑₗ)
  CompHausFiltPseuNormGrp.to_Condensed

/-- Prop 2.1 of Analytic.pdf -/
def free_pfpng_profinite_iso :
  condensify (free_pfpng_functor ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) ≅
  Profinite_to_Condensed ⋙ CondensedSet_to_Condensed_Ab :=
free_pfpng_profinite_iso_aux ≪≫ (as_iso free_pfpng_profinite_natural_map).symm


import tactic defs single height

lemma branch_left : ∀ t, ⟨t⟩ → ⟨⟦t∣⟧⟩ :=
begin intros, apply is_branch.left_nl, assumption end

lemma branch_left_leaf : ∀ t, ⟨t⟩ → ⟨⟦t,●⟧⟩ :=
begin intros, apply is_branch.left_l, assumption end

lemma branch_right : ∀ t, ⟨t⟩ → ⟨⟦∣t⟧⟩ :=
begin intros, apply is_branch.right_nl, assumption end

lemma branch_right_leaf : ∀ t, ⟨t⟩ → ⟨⟦●,t⟧⟩ :=
begin intros, apply is_branch.right_l, assumption end

meta def auto_branch_core : tactic unit :=
do
  h ← tactic.target,
  match h with
  | `(is_branch %%b):=
      match b with
      | `(●)      := tactic.exact `(is_branch.single)
      | `(⟦%%t∣⟧) := do tactic.applyc `branch_left, auto_branch_core
      | `(⟦∣%%t⟧) := do tactic.applyc `branch_right, auto_branch_core
      | `(⟦%%t,●⟧):= do tactic.applyc `branch_left_leaf,
                        auto_branch_core
      | `(⟦●,%%t⟧):= do tactic.applyc `branch_right_leaf,
                        auto_branch_core
      | _      := tactic.try (tactic.assumption <|> tactic.tautology)
      end
  | _ := tactic.fail "should not exists"
  end

meta def reduce_trivial_tree_core : list expr → tactic unit
| [] := tactic.skip
| (h :: hs) := do t ← tactic.infer_type h,
                  match t with
                  | `(%%b ↣ ●) := tactic.replace h.to_string ``(single_grow %%b %%h)
                  | `(height %%b ≤ 1) := tactic.replace h.to_string ``(height_le1_single %%b %%h)
                  | _ := tactic.skip
                  end,
                  reduce_trivial_tree_core hs

meta def reduce_trivial_tree : tactic unit :=
do
  h ← tactic.local_context,
  reduce_trivial_tree_core h

meta def rewrite_ci_core : list expr → tactic unit
| [] := tactic.skip
| (h :: hs) := do t ← tactic.infer_type h,
                  match t with
                  | `(%%b = ●) := tactic.try (tactic.subst h)
                  | _ := tactic.skip
                  end,
                  rewrite_ci_core hs

meta def rewrite_ci : tactic unit :=
do
  reduce_trivial_tree,
  h ← tactic.local_context,
  rewrite_ci_core h

meta def auto_grow_core : tactic unit :=
 do h ← tactic.target,
   match h with
   | `(grow %%t %%t') :=
          match t, t' with
          | `(●), _ := tactic.applyc `grow.single_grow
          | `(⟦%%u∣⟧), `(⟦%%u'∣⟧) :=
                       do tactic.applyc `grow.left_grow,
                          auto_grow_core
          | `(⟦∣%%v⟧), `(⟦∣%%v'⟧) :=
                       do tactic.applyc `grow.right_grow,
                          auto_grow_core
          | `(⟦%%u, %%v⟧), `(⟦%%u', %%v'⟧) :=
                       do tactic.applyc `grow.full_grow,
                          auto_grow_core,
                          auto_grow_core
          | _, _ := tactic.try (tactic.assumption <|> tactic.tautology)
          end
   | _ := tactic.fail "should not exists"
   end

meta def auto_grow : tactic unit :=
do
  rewrite_ci,
  auto_grow_core

meta def auto_branch : tactic unit :=
do
  rewrite_ci,
  auto_branch_core


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.rbtree.default

universes u v

namespace Mathlib

namespace rbmap

/- Auxiliary instances -/

/- Helper lemmas for reusing rbtree results. -/

theorem eq_some_of_to_value_eq_some {α : Type u} {β : Type v} {e : Option (α × β)} {v : β} : to_value e = some v → ∃ (k : α), e = some (k, v) := sorry

theorem eq_none_of_to_value_eq_none {α : Type u} {β : Type v} {e : Option (α × β)} : to_value e = none → e = none := sorry

/- Lemmas -/

theorem not_mem_mk_rbmap {α : Type u} {β : Type v} {lt : α → α → Prop} (k : α) : ¬k ∈ mk_rbmap α β := sorry

theorem not_mem_of_empty {α : Type u} {β : Type v} {lt : α → α → Prop} {m : rbmap α β} (k : α) : empty m = tt → ¬k ∈ m := sorry

theorem not_mem_of_find_entry_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {m : rbmap α β} : find_entry m k = none → ¬k ∈ m := sorry

theorem not_mem_of_find_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {m : rbmap α β} : find m k = none → ¬k ∈ m := sorry

theorem mem_of_find_entry_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {e : α × β} {m : rbmap α β} : find_entry m k₁ = some e → k₁ ∈ m := sorry

theorem mem_of_find_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β} : find m k = some v → k ∈ m := sorry

theorem find_entry_eq_find_entry_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} {k₁ : α} {k₂ : α} : strict_weak_order.equiv k₁ k₂ → find_entry m k₁ = find_entry m k₂ := sorry

theorem find_eq_find_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) : strict_weak_order.equiv k₁ k₂ → find m k₁ = find m k₂ := sorry

theorem find_entry_correct {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) : k ∈ m ↔ ∃ (e : α × β), find_entry m k = some e ∧ strict_weak_order.equiv k (prod.fst e) := sorry

theorem eqv_of_find_entry_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : find_entry m k₁ = some (k₂, v) → strict_weak_order.equiv k₁ k₂ := sorry

theorem eq_of_find_entry_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : find_entry m k₁ = some (k₂, v) → k₁ = k₂ :=
  fun (h : find_entry m k₁ = some (k₂, v)) =>
    (fun (this : strict_weak_order.equiv k₁ k₂) => eq_of_eqv_lt this) (eqv_of_find_entry_some h)

theorem find_correct {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) : k ∈ m ↔ ∃ (v : β), find m k = some v := sorry

theorem constains_correct {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) : k ∈ m ↔ contains m k = tt := sorry

theorem mem_of_mem_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} {k₁ : α} {k₂ : α} : k₁ ∈ m → strict_weak_order.equiv k₁ k₂ → k₂ ∈ m := sorry

theorem mem_insert_of_incomp {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : ¬lt k₁ k₂ ∧ ¬lt k₂ k₁ → k₁ ∈ insert m k₂ v :=
  fun (h : ¬lt k₁ k₂ ∧ ¬lt k₂ k₁) => to_rbmap_mem (rbtree.mem_insert_of_incomp m (eqv_entries_of_eqv_keys v v h))

theorem mem_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) (v : β) : k ∈ insert m k v :=
  to_rbmap_mem (rbtree.mem_insert (k, v) m)

theorem mem_insert_of_equiv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : strict_weak_order.equiv k₁ k₂ → k₁ ∈ insert m k₂ v :=
  mem_insert_of_incomp m v

theorem mem_insert_of_mem {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {m : rbmap α β} (k₂ : α) (v : β) : k₁ ∈ m → k₁ ∈ insert m k₂ v :=
  fun (h : k₁ ∈ m) => to_rbmap_mem (rbtree.mem_insert_of_mem (k₂, v) (to_rbtree_mem' v h))

theorem equiv_or_mem_of_mem_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : k₁ ∈ insert m k₂ v → strict_weak_order.equiv k₁ k₂ ∨ k₁ ∈ m := sorry

theorem incomp_or_mem_of_mem_ins {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : k₁ ∈ insert m k₂ v → ¬lt k₁ k₂ ∧ ¬lt k₂ k₁ ∨ k₁ ∈ m :=
  equiv_or_mem_of_mem_insert

theorem eq_or_mem_of_mem_ins {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : k₁ ∈ insert m k₂ v → k₁ = k₂ ∨ k₁ ∈ m := sorry

theorem find_entry_insert_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) {k₁ : α} {k₂ : α} (v : β) : strict_weak_order.equiv k₁ k₂ → find_entry (insert m k₁ v) k₂ = some (k₁, v) := sorry

theorem find_entry_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) (k : α) (v : β) : find_entry (insert m k v) k = some (k, v) :=
  find_entry_insert_of_eqv m v (refl k)

theorem find_insert_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) {k₁ : α} {k₂ : α} (v : β) : strict_weak_order.equiv k₁ k₂ → find (insert m k₁ v) k₂ = some v := sorry

theorem find_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) (k : α) (v : β) : find (insert m k v) k = some v :=
  find_insert_of_eqv m v (refl k)

theorem find_entry_insert_of_disj {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : lt k₁ k₂ ∨ lt k₂ k₁ → find_entry (insert m k₁ v) k₂ = find_entry m k₂ := sorry

theorem find_entry_insert_of_not_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : ¬strict_weak_order.equiv k₁ k₂ → find_entry (insert m k₁ v) k₂ = find_entry m k₂ := sorry

theorem find_entry_insert_of_ne {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : k₁ ≠ k₂ → find_entry (insert m k₁ v) k₂ = find_entry m k₂ :=
  fun (h : k₁ ≠ k₂) => find_entry_insert_of_not_eqv m v fun (h' : strict_weak_order.equiv k₁ k₂) => h (eq_of_eqv_lt h')

theorem find_insert_of_disj {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : lt k₁ k₂ ∨ lt k₂ k₁ → find (insert m k₁ v) k₂ = find m k₂ := sorry

theorem find_insert_of_not_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : ¬strict_weak_order.equiv k₁ k₂ → find (insert m k₁ v) k₂ = find m k₂ := sorry

theorem find_insert_of_ne {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : k₁ ≠ k₂ → find (insert m k₁ v) k₂ = find m k₂ := sorry

theorem mem_of_min_eq {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : min m = some (k, v) → k ∈ m :=
  fun (h : min m = some (k, v)) => to_rbmap_mem (rbtree.mem_of_min_eq h)

theorem mem_of_max_eq {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : max m = some (k, v) → k ∈ m :=
  fun (h : max m = some (k, v)) => to_rbmap_mem (rbtree.mem_of_max_eq h)

theorem eq_leaf_of_min_eq_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} : min m = none → m = mk_rbmap α β :=
  rbtree.eq_leaf_of_min_eq_none

theorem eq_leaf_of_max_eq_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} : max m = none → m = mk_rbmap α β :=
  rbtree.eq_leaf_of_max_eq_none

theorem min_is_minimal {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β} : min m = some (k, v) → ∀ {k' : α}, k' ∈ m → strict_weak_order.equiv k k' ∨ lt k k' := sorry

theorem max_is_maximal {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β} : max m = some (k, v) → ∀ {k' : α}, k' ∈ m → strict_weak_order.equiv k k' ∨ lt k' k := sorry

theorem min_is_minimal_of_total {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : min m = some (k, v) → ∀ {k' : α}, k' ∈ m → k = k' ∨ lt k k' := sorry

theorem max_is_maximal_of_total {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : max m = some (k, v) → ∀ {k' : α}, k' ∈ m → k = k' ∨ lt k' k := sorry