import Mt.Reservation
import Mt.Task.Impl

namespace Mt

/-- Monad to describe single threaded algorithms. Tasks can be iterated
  step by step until they finally complete or panic.

  `TaskM` is a monad, i.e. you can use the do-notation to write code:

  ```
  import Mt.Task.Basic
  open Mt

  abbrev spec : Spec :={
    State := Nat,
    Reservation := UnitReservation,
    validate :=λ _ _ => True
  }

  def sample_task : TaskM spec Bool :=do
    if (<- TaskM.atomic_read λ n => n) > 100 then
      -- reset to 100
      TaskM.atomic_read_modify λ _ => 100
      return false

    TaskM.atomic_assert λ n => n < 500

    TaskM.atomic_read_modify λ n => n + 7
    return true
  ```

  Note: `TaskM` hat an associative bind operator, but it is not
  a lawful monad: Binding two `pure` cannot be simplified into
  a single pure, because it requires two iterations to complete.
-/
def TaskM (spec : Spec) (T : Type) : Type :=TaskM.impl.TaskM spec T

/-- The result of a single iteration of `TaskM`.

  Independent of the result, the resulting shared state after
  the iteration can be retrieved using `IterationResult.state`
-/
inductive TaskM.IterationResult (spec : Spec) (T : Type)
| Done : spec.State -> T -> IterationResult spec T
| Panic : spec.State -> String -> IterationResult spec T
| Running : spec.State -> (spec.State -> Bool) -> TaskM spec T -> IterationResult spec T

variable {spec : Spec}

def TaskM.IterationResult.state {T spec} : IterationResult spec T -> spec.State
| Done s _ => s
| Panic s _ => s
| Running s .. => s

instance TaskM.instMonad : Monad (TaskM spec) where
  pure :=impl.TaskM.pure
  bind :=impl.TaskM.bind

theorem TaskM.bind_assoc {U V W : Type}
  (mu : TaskM spec U)
  (f : U -> TaskM spec V)
  (g : V -> TaskM spec W) :
  mu >>= (fun u => (f u) >>= g) = (mu >>= f) >>= g :=by
  simp only [Bind.bind]
  exact impl.TaskM.bind_assoc ..

/-- Atomic `TaskM` primitive with read/write-access to the shared state.

  Additional to performing a read-modify operation, it returns a value.

  Example: Compare Exchange (https://en.wikipedia.org/wiki/Compare-and-swap)
 -/
def TaskM.atomic_read_modify_read {T : Type}
  (f : spec.State -> T × spec.State)
  : TaskM spec T :=impl.TaskM.atomic_read_modify_read f

/-- Atomic `TaskM` primitive to perform read-modify operations on the
  shared state. It does not return anything. -/
def TaskM.atomic_read_modify
  (f : spec.State -> spec.State) : TaskM spec Unit :=
  atomic_read_modify_read λ s => ⟨⟨⟩, f s⟩

/-- Atomic `TaskM` primitive to perform read the shared state. It
  does not change anything -/
def TaskM.atomic_read {T : Type}
  (f : spec.State -> T)
  : TaskM spec T :=
  atomic_read_modify_read λ s => match f s with
    | t => ⟨t, s⟩

/-- Atomic `TaskM` primitive which throws an exception. The current thread
  panics and will be removed from the system -/
def TaskM.panic {T : Type} (msg : String) : TaskM spec T :=
  impl.TaskM.panic msg

/-- Atomic `TaskM` primitive to assert a given condition. The condition
  is checked atomically. If it returns `false`, the current thread panics. -/
def TaskM.atomic_assert
  (cond : spec.State -> Bool)
  : TaskM spec Unit :=impl.TaskM.atomic_assert cond

/-- `TaskM` primitive which blocks the current thread until a given
  condition holds, and executes a read-modify-read operation afterwards.

  There are neither spurious wakeups nor race conditions: The system will
  only perform the read-modify-read operation if the provided condition
  holds. If it does not, the thread will block. -/
def TaskM.atomic_blocking_rmr
  (block_until : spec.State -> Bool)
  (f : spec.State -> T × spec.State)
  : TaskM spec T :=impl.TaskM.atomic_blocking_rmr block_until f

/-- Iterate a given thread on a given state and provides an `IterationResult`.

  The task may complete or panic. If it is does not, it is still running
  and a continuation will be provided in the result -/
def TaskM.iterate {T : Type} : TaskM spec T ->
  spec.State -> IterationResult spec T :=
  λ p s => match p s with
  | impl.IterationResult.Done s' t => IterationResult.Done s' t
  | impl.IterationResult.Panic s' msg => IterationResult.Panic s' msg
  | impl.IterationResult.Running s' block_until cont =>
      IterationResult.Running s' block_until cont

/-- Iteration of `pure t` always completes with result `t` -/
theorem TaskM.iterate_pure {T : Type} :
  ∀ (s : spec.State) (t : T),
  iterate (pure t) s = IterationResult.Done s t :=by intros ; rfl

/-- Iteration of `a >>= f` iterates `a` and returns a continuation.

  * If the `a` iteration has completed with result `t`, the next
    iteration will start work on `f t`
  * If the `a` iteration has not completed yet, the next iteration
    will continue.
  * If `a` has panicked, the exception is propagated.
 -/
theorem TaskM.iterate_bind {U V : Type}
  (mu : TaskM spec U)
  (f : U -> TaskM spec V)
  : ∀ (s : spec.State),
  iterate (mu >>= f) s = match iterate mu s with
    | IterationResult.Done s' u => IterationResult.Running s' (λ _ => true) (f u)
    | IterationResult.Panic s' msg => IterationResult.Panic s' msg
    | IterationResult.Running s' block_until cont =>
        IterationResult.Running s' block_until (cont >>= f) :=by
  intro s
  simp only [Bind.bind, iterate, impl.TaskM.bind]
  cases mu s <;> rfl

/-- Iteration of a read-modify-read-operation will perform the read modify
  and complete with the computed result. -/
theorem TaskM.iterate_rmr {T : Type}
  (f : spec.State -> T × spec.State)
  : ∀ s,
  iterate (atomic_read_modify_read f) s = match f s with
    | ⟨t, s'⟩ => IterationResult.Done s' t :=by intros ; rfl

/-- Iteration of a read-modify operation will perform the read modify
  operation and complete with `Unit.unit` -/
theorem TaskM.iterate_rm
  (f : spec.State -> spec.State)
  : ∀ s,
  iterate (atomic_read_modify f) s = match f s with
    | s' => IterationResult.Done s' ⟨⟩ :=by
  apply iterate_rmr

/-- Iteration of a read operation will compute a value based on the
  current shared state and complete with the result -/
theorem TaskM.iterate_read
  (f : spec.State -> T × spec.Reservation)
  : ∀ s,
  iterate (atomic_read f) s = match f s with
    | t => IterationResult.Done s t :=by
  apply iterate_rmr

/-- Iteration of a panic will fail -/
theorem TaskM.iterate_panic {T : Type} (msg : String)
  : ∀ (s : spec.State),
    iterate (panic (T :=T) msg) s = IterationResult.Panic s msg :=by
  intros ; rfl

/-- Iteration of an assertion will atomically check the condition
  and succeed or fail depending on the result. -/
theorem TaskM.iterate_assert
  (cond : spec.State -> Bool)
  : ∀ s,
  iterate (atomic_assert cond) s = if cond s then
    IterationResult.Done s ⟨⟩
  else
    IterationResult.Panic s "Assertion failed" :=by
  intro s
  simp only [atomic_assert, impl.TaskM.atomic_assert, iterate]
  cases cond s <;> simp only [ite_false, ite_true]

/-- Iteration of a `atomic_blocking_rmr` operation will always
  return a continuation.

  The `IterationResult` contains the blocking predicate and
  the desired read-modify-read operation. The caller should ensure
  that the read-modify-operation is only iterated when the blocking
  predicate holds. -/
theorem TaskM.iterate_blocking_rmr
  (block_until : spec.State -> Bool)
  (f : spec.State -> T × spec.State)
  : ∀ s,
  iterate (atomic_blocking_rmr block_until f) s = IterationResult.Running s
    block_until (atomic_read_modify_read f) :=by intros ; rfl

/-- Well founded relation on `TaskM` fulfilled by continuations with their parents.

  It can be used to perform well founded recursion `TaskM` without using the
  implementation details of `TaskM`. Whenever `TaskM.iterate` returns a
  continuation, the continuation will be *smaller* according to this
  relation.
  -/
inductive TaskM.is_direct_cont {T : Type} : TaskM spec T -> TaskM spec T -> Prop
| running
    {p cont : TaskM spec T}
    {s s'}
    {block_until : spec.State -> Bool}
    (iteration : p.iterate s = IterationResult.Running s' block_until cont)
    : is_direct_cont cont p

/-- See `TaskM.is_direct_cont` -/
theorem TaskM.is_direct_cont_wf {T : Type} :
  WellFounded (@is_direct_cont spec T) :=by
  constructor ; intro (p : impl.TaskM spec T)

  induction p using WellFounded.induction
  . exact impl.TaskM.is_direct_cont.wf
  . clear p ; rename_i p IH
    constructor ; intro cont is_cont
    apply IH
    cases is_cont
    rename_i s s' block_until iteration
    rw [iterate] at iteration
    cases h : p s <;> rw [h] at iteration <;> try contradiction
    injection iteration
    rename_i cont'_def ; rw [cont'_def] at h
    exact ⟨h⟩

instance TaskM.instWf {T : Type} :
  WellFoundedRelation (TaskM spec T) where
  rel :=is_direct_cont
  wf  :=is_direct_cont_wf

end Mt


import Lean.Meta
import LeanCodePrompts
import LeanCodePrompts.CheckParse
import LeanCodePrompts.Makecaps
open Lean

set_option maxHeartbeats 10000000
set_option maxRecDepth 1000
set_option compiler.extract_closed false

def chkDocs : String :=
"Utility to check whether a theorem string can be parsed (and elaborated) in lean.

- Give a single argument to check parsing.
- Give two arguments to compare results (if parsing is successful).

A theorem can be given in one of two forms

- the word `theorem` followed by a name, then the arguments, a `:`, finally the statement, or
- the arguments, a `:`, and the statement.

The following examples are of these two forms:

- `theorem nonsense(n : Nat) (m : Nat) : n = m`
- `(p : Nat)(q: Nat) : p = q`

Note that the arguments can be implicit or explicit.

The underlying code also supports `open` for namespaces but this demo version does not use these.
"

def main (args: List String) : IO Unit := do
  initSearchPath (← Lean.findSysroot) ["build/lib", "lake-packages/mathlib/build/lib/",  "lake-packages/std/build/lib/", "lake-packages/Qq/build/lib/", "lake-packages/aesop/build/lib/" ]
  let env ←
    importModules [{module := `Mathlib},
    {module := `LeanCodePrompts.Basic},
    {module:= `LeanCodePrompts.CheckParse},
    {module := `Mathlib}] {}
  match args with
  | [] => IO.println chkDocs
  | s::[] => do
    let core := elabThmCore <| mkCap s
    let io? :=
    core.run' {fileName := "", fileMap := ⟨"", #[], #[]⟩, maxHeartbeats := 100000000000, maxRecDepth := 1000000} {env := env}
    match ← io?.toIO' with
    | Except.ok res =>
      match res with
      | Except.ok expr =>
        IO.println "success"
        IO.println expr
      | Except.error err =>
        IO.println "failure"
        IO.println err
    | Except.error e =>
      IO.println "error"
      let m := e.toMessageData
      IO.println <| ← m.toString
  | s₁ :: s₂ :: [] => do
    let core := compareThmsCore (mkCap s₁) (mkCap s₂)
    let io? :=
    core.run' {fileName := "", fileMap := ⟨"", #[], #[]⟩, maxHeartbeats := 100000000000, maxRecDepth := 1000000} {env := env}
    match ← io?.toIO' with
    | Except.ok res =>
      match res with
      | Except.ok expr =>
        IO.println "success"
        IO.println expr
      | Except.error err =>
        IO.println "failure"
        IO.println err
    | Except.error e =>
      IO.println "error"
      let m := e.toMessageData
      IO.println <| ← m.toString
  | _ => IO.println s!"I don't know what to do with {args.length} arguments. Run with no arguments for help."


import Std
namespace Days

structure Input :=
  text: String
  deriving Repr, DecidableEq, Ord

instance : ToString Input where
  toString := (·.text)

def Input.iter : (@& Input) → String.Iterator
  | ⟨s⟩ => s.iter

def Input.lines : (@& Input) → List Input
  | ⟨s⟩ => String.splitOn s "\n"
      |> .map Input.mk

def Input.trim : (@& Input) → Input
  | ⟨s⟩ => s.trim |> Input.mk

def Input.toInt? : (@& Input) → Option Int
  | ⟨s⟩ => s.toInt?

def Input.toNat? : (@& Input) → Option Nat
  | ⟨s⟩ => s.toNat?

def Input.intLines (i: Input) : List Int :=
  i.lines |>.map (·.toInt?.get!)

def Input.natLines (i: Input) : List Nat :=
  i.lines |>.map (·.toNat?) |>.filterMap id

def Input.splitOn : (@& Input) → String → List Input
  | ⟨s⟩, sep => String.splitOn s sep
    |> List.map .mk

instance : Inhabited Input where
  default := ⟨ "" ⟩

class ToInput (α : Type u) where
  toInput : α → Input

export ToInput (toInput)

instance : ToInput String where
  toInput := Input.mk

instance : ToInput Input where
  toInput := id

/--
A number type that models a problem number for a day.
Only the litteral 1-25 can be parsed into a number.
-/
structure ProblemNumber : Type where
  of ::
  day: Nat
  deriving Repr, Ord, DecidableEq, BEq

instance : Inhabited ProblemNumber where
  default := ProblemNumber.of 1

instance : LT ProblemNumber := ltOfOrd
instance : LE ProblemNumber := leOfOrd

example : ProblemNumber := .of 1

instance : OfNat ProblemNumber 1 where ofNat := .of 1
instance : OfNat ProblemNumber 2 where ofNat := .of 2
instance : OfNat ProblemNumber 3 where ofNat := .of 3
instance : OfNat ProblemNumber 4 where ofNat := .of 4
instance : OfNat ProblemNumber 5 where ofNat := .of 5
instance : OfNat ProblemNumber 6 where ofNat := .of 6
instance : OfNat ProblemNumber 7 where ofNat := .of 7
instance : OfNat ProblemNumber 8 where ofNat := .of 8
instance : OfNat ProblemNumber 9 where ofNat := .of 9

instance : OfNat ProblemNumber 10 where ofNat := .of 10
instance : OfNat ProblemNumber 11 where ofNat := .of 11
instance : OfNat ProblemNumber 12 where ofNat := .of 12
instance : OfNat ProblemNumber 13 where ofNat := .of 13
instance : OfNat ProblemNumber 14 where ofNat := .of 14
instance : OfNat ProblemNumber 15 where ofNat := .of 15
instance : OfNat ProblemNumber 16 where ofNat := .of 16
instance : OfNat ProblemNumber 17 where ofNat := .of 17
instance : OfNat ProblemNumber 18 where ofNat := .of 18
instance : OfNat ProblemNumber 19 where ofNat := .of 19

instance : OfNat ProblemNumber 20 where ofNat := .of 20
instance : OfNat ProblemNumber 21 where ofNat := .of 21
instance : OfNat ProblemNumber 22 where ofNat := .of 22
instance : OfNat ProblemNumber 23 where ofNat := .of 23
instance : OfNat ProblemNumber 24 where ofNat := .of 24
instance : OfNat ProblemNumber 25 where ofNat := .of 25

def ProblemNumber.ofNat? (n: Nat) :=
  match n with
  | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
  | 10 | 11 | 12 | 13 | 14 | 15
  | 16 | 17 | 18 | 19 | 20
  | 21 | 22 | 23 | 24 | 25  => some $ ProblemNumber.of n
  | _ => none

def ProblemNumber.ofNat! (n: Nat) :=
  match ProblemNumber.ofNat? n with
  | some n => n
  | none => panic! s!"Can't parse problem number from '{n}'; it should be between 1 and 25"

structure Problem (α: Type) [ToString α]:=
  define ::
  day: ProblemNumber
  part1: Input -> α
  part2: Option $ Input -> α

def Problem.wrapString {α: Type} [ToString α] (p: Problem α) : Problem String :=
  Problem.define p.day (toString ∘ p.part1) (p.part2.map (λ p₂ input => p₂ input |> toString))

def Problem.padDay (day: ProblemNumber) : String :=
  if day.day < 10 then s!"0{day.day}" else s!"{day.day}"

instance : ToString ProblemNumber where
  toString p := Problem.padDay p

def Problem.run [ToString α] (p: Problem α) (i: Input) : IO Unit := do
  let result₁ := p.part1 i

  IO.println "==========================="
  IO.println s!"DAY {p.day}"
  IO.println "==========================="
  IO.println s!"Part 1: {result₁}"
  IO.println "==========================="
  match p.part2 with
  | some f =>
    let result₂ := f i
    IO.println s!"Part 2: {result₂}"
  | none =>
    IO.println s!"Part 2: Not done yet"

  return ()

def testPart₁ [ToInput κ] [ToString α] [DecidableEq α] (expect: α) (p: Problem α) (input: κ) : IO α := do
  let result := p.part1 <| toInput input
  if result = expect then
    IO.println "Part1 ✅"
  else
    IO.println "Part1 ❌"
  return result

def testPart₂ [ToInput κ] [ToString α] [DecidableEq α] (expect: α) (p: Problem α) (input: κ) : IO α := do
  match result with
  | none =>
      IO.println "Part 2 not done yet"
      return expect
  | some result =>
    if result = expect then
      IO.println "Part2 ✅"
    else
      IO.println "Part2 ❌"
    return result
  where
    runPart2 (f: Input -> α) := f (toInput input)
    result := p.part2.map runPart2


import data.stream.defs
import data.bool.all_any
import data.lazy_list
import tactic

open expr tactic widget

meta def ft : tactic unit :=
trace "f" >> trace "t"

meta def st : tactic unit :=
fail "st"

meta def ot : tactic unit :=
st <|> ft

meta def trace_goal : tactic unit :=
target >>= trace

meta def trace_goal_is_eq : tactic unit :=
do t ← target,
  match t with
  | `(%%l = %%r) := trace $ "hmm " ++ (to_string l) ++ " ?= " ++ (to_string r)
  | _ := trace "goal is not ="
end

meta def list_types : tactic unit :=
do
  l ← local_context,
  trace l,
  l.mmap' (λ h, infer_type h >>= trace)

#eval ft
#eval st
#eval ot
#eval trace_goal
#eval trace_goal_is_eq

#eval trace $ to_raw_fmt $ (`(λ x : ℕ, x) : expr)
#eval trace $ succ_fn `(λ x : ℤ, 2 * x)

example : true :=
begin
  trace_goal,
  trace_goal_is_eq,
  have : 1 = 2,
  {
    trace_goal,
    trace_goal_is_eq,
    sorry,
  },
  let l := [1, 2, 3, 4],
  list_types,
end

/-
Below are examples that deal with *raw* expr.
These are context-unaware and is not ideal for manipulation.
-/

-- helper function instead of `expr.mk_app`
meta def mk_app (e1 e2 : expr) : expr := app e1 e2

-- function that takes a function `f` and returns essentially `f + 1`
meta def succ_fn : expr → option expr
| (lam var_name bi var_type body) :=
  let new_body := mk_app `(nat.succ) body in
  lam var_name bi var_type new_body
| _ := none

/-
Below, we use `tactic` that allows context-aware metaprogramming
Tutorial: https://www.youtube.com/watch?v=qsmnBNXgZgc
-/

meta def inspect_dump : tactic unit :=
do t ← target,
  trace t,
  a_expr ← get_local `a <|> return `(0),
  trace (to_raw_fmt a_expr),
  a_type ← infer_type a_expr,
  trace a_type,
  ctx ← local_context,
  trace ctx,
  -- new_nat ← 40 won't work since 40 is not a tactic
  -- Either use `new_nat ← return 40` or
  let new_nat := 40,
  trace new_nat

example (a b c : ℤ) : a = b := by do inspect_dump
example (b c : ℤ) : b = c := by do inspect_dump

/-
Now we implement the `assumption` tactic, which looks through local context
and look for a hypothesis that closes the current goal.
-/

meta def map_over_lc (tgt : expr) : list expr → tactic unit
| [] := fail "assump failed."
| (f :: fs) := exact f <|> map_over_lc fs

meta def assump : tactic unit :=
do tgt ← target,
   ctx ← local_context,
   map_over_lc tgt ctx

-- This pattern is common and has been implemented already
meta def assump' : tactic unit :=
local_context >>= list.mfirst (λ e, exact e)

example {A B C : Prop} (ha : A) (hb : B) (hc : C) : C := by assump
example {A B C : Prop} (ha : A) (hb : B) (hc : C) : C := by assump'
example {n : ℕ} (hn : n + 0 = 5) : n = 5 := by assump'

/-
More ad-hoc tactic practices
-/

#check interactive.dec_trivial

meta def add_refl_hyp (e : expr) : tactic unit :=
do tp ← infer_type e,
   guard (tp = `(ℕ)),
  --  pf ← mk_app `eq.refl [e],
   pf ← to_expr ``(not_lt_of_ge (ge_of_eq (eq.refl %%e))),
   nm ← get_unused_name,
   note nm none pf,
   return ()

meta def add_refl : tactic unit :=
do tgt ← target,
   ctx ← local_context,
   trace ctx,
   ctx.mmap' (λ e, try (add_refl_hyp e)),
   return ()

example {a b c : ℕ} (ha : a = b) : true := by do add_refl


import Lean
open List Lean

example (l : List α) (h : length l = length l) : length (a::l) = length (a::l) :=
  congrArg (·+1) h

elab:max "(" tm:term ":)" : term => Elab.Term.elabTerm tm none

example (l : List α) (h : length l = length l) : length (a::l) = length (a::l) :=
  (congrArg (·+1) h :)

example (l : List α) (h : length l = length l) : length (a::l) = length (a::l) :=
  have := congrArg (·+1) h; this

example (l : List α) (h : length l = length l) : length (a::l) = length (a::l) := by
  have := congrArg (·+1) h; exact this


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.meta.smt.smt_tactic
! leanprover-community/mathlib commit 4a03bdeb31b3688c31d02d7ff8e0ff2e5d6174db
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Control.Default
import Leanbin.Init.Meta.SimpTactic
import Leanbin.Init.Meta.Smt.CongruenceClosure
import Leanbin.Init.Meta.Smt.Ematch

universe u

run_cmd
  mk_simp_attr `pre_smt

run_cmd
  mk_hinst_lemma_attr_set `ematch [] [`ematch_lhs]

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

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

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

  - zeta: if tt, then zeta reduction (i.e., unfolding let-expressions)
    is used during preprocessing.
-/
structure SmtPreConfig where
  simpAttr : Name := `pre_smt
  maxSteps : Nat := 1000000
  zeta : Bool := false
#align smt_pre_config SmtPreConfig

/-- Configuration for the smt_state object.

- em_attr: is the attribute name for the hinst_lemmas
  that are used for ematching -/
structure SmtConfig where
  ccCfg : CcConfig := { }
  emCfg : EmatchConfig := { }
  preCfg : SmtPreConfig := { }
  emAttr : Name := `ematch
#align smt_config SmtConfig

unsafe def smt_config.set_classical (c : SmtConfig) (b : Bool) : SmtConfig :=
  { c with ccCfg := { c.ccCfg with em := b } }
#align smt_config.set_classical smt_config.set_classical

unsafe axiom smt_goal : Type
#align smt_goal smt_goal

unsafe def smt_state :=
  List smt_goal
#align smt_state smt_state

unsafe axiom smt_state.mk : SmtConfig → tactic smt_state
#align smt_state.mk smt_state.mk

unsafe axiom smt_state.to_format : smt_state → tactic_state → format
#align smt_state.to_format smt_state.to_format

/-- Return tt iff classical excluded middle was enabled at  smt_state.mk -/
unsafe axiom smt_state.classical : smt_state → Bool
#align smt_state.classical smt_state.classical

unsafe def smt_tactic :=
  StateT smt_state tactic
#align smt_tactic smt_tactic

unsafe instance : Append smt_state :=
  List.hasAppend

section

attribute [local reducible] smt_tactic

unsafe instance : Monad smt_tactic := by infer_instance

unsafe instance : Alternative smt_tactic := by infer_instance

unsafe instance : MonadState smt_state smt_tactic := by infer_instance

end

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

unsafe instance : HasMonadLift tactic smt_tactic :=
  ⟨tactic_to_smt_tactic⟩

unsafe instance (α : Type) : Coe (tactic α) (smt_tactic α) :=
  ⟨monadLift⟩

unsafe instance : MonadFail smt_tactic :=
  { smt_tactic.monad with fail := fun α s => (tactic.fail (to_fmt s) : smt_tactic α) }

namespace SmtTactic

open Tactic (Transparency)

unsafe axiom intros : smt_tactic Unit
#align smt_tactic.intros smt_tactic.intros

unsafe axiom intron : Nat → smt_tactic Unit
#align smt_tactic.intron smt_tactic.intron

unsafe axiom intro_lst : List Name → smt_tactic Unit
#align smt_tactic.intro_lst smt_tactic.intro_lst

/-- Try to close main goal by using equalities implied by the congruence
  closure module.
-/
unsafe axiom close : smt_tactic Unit
#align smt_tactic.close smt_tactic.close

/-- Produce new facts using heuristic lemma instantiation based on E-matching.
  This tactic tries to match patterns from lemmas in the main goal with terms
  in the main goal. The set of lemmas is populated with theorems
  tagged with the attribute specified at smt_config.em_attr, and lemmas
  added using tactics such as `smt_tactic.add_lemmas`.
  The current set of lemmas can be retrieved using the tactic `smt_tactic.get_lemmas`.

  Remark: the given predicate is applied to every new instance. The instance
  is only added to the state if the predicate returns tt.
-/
unsafe axiom ematch_core : (expr → Bool) → smt_tactic Unit
#align smt_tactic.ematch_core smt_tactic.ematch_core

/-- Produce new facts using heuristic lemma instantiation based on E-matching.
  This tactic tries to match patterns from the given lemmas with terms in
  the main goal.
-/
unsafe axiom ematch_using : hinst_lemmas → smt_tactic Unit
#align smt_tactic.ematch_using smt_tactic.ematch_using

unsafe axiom mk_ematch_eqn_lemmas_for_core : Transparency → Name → smt_tactic hinst_lemmas
#align smt_tactic.mk_ematch_eqn_lemmas_for_core smt_tactic.mk_ematch_eqn_lemmas_for_core

unsafe axiom to_cc_state : smt_tactic cc_state
#align smt_tactic.to_cc_state smt_tactic.to_cc_state

unsafe axiom to_em_state : smt_tactic ematch_state
#align smt_tactic.to_em_state smt_tactic.to_em_state

unsafe axiom get_config : smt_tactic SmtConfig
#align smt_tactic.get_config smt_tactic.get_config

/-- Preprocess the given term using the same simplifications rules used when
  we introduce a new hypothesis. The result is pair containing the resulting
  term and a proof that it is equal to the given one.
-/
unsafe axiom preprocess : expr → smt_tactic (expr × expr)
#align smt_tactic.preprocess smt_tactic.preprocess

unsafe axiom get_lemmas : smt_tactic hinst_lemmas
#align smt_tactic.get_lemmas smt_tactic.get_lemmas

unsafe axiom set_lemmas : hinst_lemmas → smt_tactic Unit
#align smt_tactic.set_lemmas smt_tactic.set_lemmas

unsafe axiom add_lemmas : hinst_lemmas → smt_tactic Unit
#align smt_tactic.add_lemmas smt_tactic.add_lemmas

unsafe def add_ematch_lemma_core (md : Transparency) (as_simp : Bool) (e : expr) :
    smt_tactic Unit := do
  let h ← hinst_lemma.mk_core md e as_simp
  add_lemmas (mk_hinst_singleton h)
#align smt_tactic.add_ematch_lemma_core smt_tactic.add_ematch_lemma_core

unsafe def add_ematch_lemma_from_decl_core (md : Transparency) (as_simp : Bool) (n : Name) :
    smt_tactic Unit := do
  let h ← hinst_lemma.mk_from_decl_core md n as_simp
  add_lemmas (mk_hinst_singleton h)
#align smt_tactic.add_ematch_lemma_from_decl_core smt_tactic.add_ematch_lemma_from_decl_core

unsafe def add_ematch_eqn_lemmas_for_core (md : Transparency) (n : Name) : smt_tactic Unit := do
  let hs ← mk_ematch_eqn_lemmas_for_core md n
  add_lemmas hs
#align smt_tactic.add_ematch_eqn_lemmas_for_core smt_tactic.add_ematch_eqn_lemmas_for_core

unsafe def ematch : smt_tactic Unit :=
  ematch_core fun _ => true
#align smt_tactic.ematch smt_tactic.ematch

unsafe def failed {α} : smt_tactic α :=
  tactic.failed
#align smt_tactic.failed smt_tactic.failed

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

unsafe def try {α : Type} (t : smt_tactic α) : smt_tactic Unit :=
  ⟨fun ss ts =>
    result.cases_on (t.run ss ts) (fun ⟨a, new_ss⟩ => result.success ((), new_ss)) fun e ref s' =>
      result.success ((), ss) ts⟩
#align smt_tactic.try smt_tactic.try

/-- `iterate_at_most n t`: repeat the given tactic at most n times or until t fails -/
unsafe def iterate_at_most : Nat → smt_tactic Unit → smt_tactic Unit
  | 0, t => return ()
  | n + 1, t =>
    (do
        t
        iterate_at_most n t) <|>
      return ()
#align smt_tactic.iterate_at_most smt_tactic.iterate_at_most

/-- `iterate_exactly n t` : execute t n times -/
unsafe def iterate_exactly : Nat → smt_tactic Unit → smt_tactic Unit
  | 0, t => return ()
  | n + 1, t => do
    t
    iterate_exactly n t
#align smt_tactic.iterate_exactly smt_tactic.iterate_exactly

unsafe def iterate : smt_tactic Unit → smt_tactic Unit :=
  iterate_at_most 100000
#align smt_tactic.iterate smt_tactic.iterate

unsafe def eblast : smt_tactic Unit :=
  iterate (ematch >> try close)
#align smt_tactic.eblast smt_tactic.eblast

open Tactic

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

protected unsafe def write : smt_state × tactic_state → smt_tactic Unit := fun ⟨ss, ts⟩ =>
  ⟨fun _ _ => result.success ((), ss) ts⟩
#align smt_tactic.write smt_tactic.write

private unsafe def mk_smt_goals_for (cfg : SmtConfig) :
    List expr → List smt_goal → List expr → tactic (List smt_goal × List expr)
  | [], sr, tr => return (sr.reverse, tr.reverse)
  | tg :: tgs, sr, tr => do
    tactic.set_goals [tg]
    let [new_sg] ← smt_state.mk cfg |
      tactic.failed
    let [new_tg] ← get_goals |
      tactic.failed
    mk_smt_goals_for tgs (new_sg :: sr) (new_tg :: tr)
#align smt_tactic.mk_smt_goals_for smt_tactic.mk_smt_goals_for

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

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

unsafe def trace_state : smt_tactic Unit := do
  let (s₁, s₂) ← smt_tactic.read
  trace (smt_state.to_format s₁ s₂)
#align smt_tactic.trace_state smt_tactic.trace_state

unsafe def trace {α : Type} [has_to_tactic_format α] (a : α) : smt_tactic Unit :=
  tactic.trace a
#align smt_tactic.trace smt_tactic.trace

unsafe def to_expr (q : pexpr) (allow_mvars := true) : smt_tactic expr :=
  tactic.to_expr q allow_mvars
#align smt_tactic.to_expr smt_tactic.to_expr

unsafe def classical : smt_tactic Bool := do
  let s ← get
  return s
#align smt_tactic.classical smt_tactic.classical

unsafe def num_goals : smt_tactic Nat :=
  List.length <$> get
#align smt_tactic.num_goals smt_tactic.num_goals

-- Low level primitives for managing set of goals
unsafe def get_goals : smt_tactic (List smt_goal × List expr) := do
  let (g₁, _) ← smt_tactic.read
  let g₂ ← tactic.get_goals
  return (g₁, g₂)
#align smt_tactic.get_goals smt_tactic.get_goals

unsafe def set_goals : List smt_goal → List expr → smt_tactic Unit := fun g₁ g₂ =>
  ⟨fun ss => tactic.set_goals g₂ >> return ((), g₁)⟩
#align smt_tactic.set_goals smt_tactic.set_goals

private unsafe def all_goals_core (tac : smt_tactic Unit) :
    List smt_goal → List expr → List smt_goal → List expr → smt_tactic Unit
  | [], ts, acs, act => set_goals acs (ts ++ act)
  | s :: ss, [], acs, act => fail "ill-formed smt_state"
  | s :: ss, t :: ts, acs, act => do
    set_goals [s] [t]
    tac
    let (new_ss, new_ts) ← get_goals
    all_goals_core ss ts (acs ++ new_ss) (act ++ new_ts)
#align smt_tactic.all_goals_core smt_tactic.all_goals_core

/-- Apply the given tactic to all goals. -/
unsafe def all_goals (tac : smt_tactic Unit) : smt_tactic Unit := do
  let (ss, ts) ← get_goals
  all_goals_core tac ss ts [] []
#align smt_tactic.all_goals smt_tactic.all_goals

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

unsafe instance : AndThen' (smt_tactic Unit) (smt_tactic Unit) (smt_tactic Unit) :=
  ⟨seq⟩

unsafe def focus1 {α} (tac : smt_tactic α) : smt_tactic α := do
  let (s :: ss, t :: ts) ← get_goals
  match ss with
    | [] => tac
    | _ => do
      set_goals [s] [t]
      let a ← tac
      let (ss', ts') ← get_goals
      set_goals (ss' ++ ss) (ts' ++ ts)
      return a
#align smt_tactic.focus1 smt_tactic.focus1

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

unsafe def swap : smt_tactic Unit := do
  let (ss, ts) ← get_goals
  match ss, ts with
    | s₁ :: s₂ :: ss, t₁ :: t₂ :: ts => set_goals (s₂ :: s₁ :: ss) (t₂ :: t₁ :: ts)
    | _, _ => failed
#align smt_tactic.swap smt_tactic.swap

/-- Add a new goal for t, and the hypothesis (h : t) in the current goal. -/
unsafe def assert (h : Name) (t : expr) : smt_tactic Unit :=
  (((tactic.assert_core h t >> swap) >> intros) >> swap) >> try close
#align smt_tactic.assert smt_tactic.assert

/-- Add the hypothesis (h : t) in the current goal if v has type t. -/
unsafe def assertv (h : Name) (t : expr) (v : expr) : smt_tactic Unit :=
  (tactic.assertv_core h t v >> intros) >> return ()
#align smt_tactic.assertv smt_tactic.assertv

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

/-- Add the hypothesis (h : t := v) in the current goal if v has type t. -/
unsafe def definev (h : Name) (t : expr) (v : expr) : smt_tactic Unit :=
  (tactic.definev_core h t v >> intros) >> return ()
#align smt_tactic.definev smt_tactic.definev

/-- Add (h : t := pr) to the current goal -/
unsafe def pose (h : Name) (t : Option expr := none) (pr : expr) : smt_tactic Unit :=
  match t with
  | none => do
    let t ← infer_type pr
    definev h t pr
  | some t => definev h t pr
#align smt_tactic.pose smt_tactic.pose

/-- Add (h : t) to the current goal, given a proof (pr : t) -/
unsafe def note (h : Name) (t : Option expr := none) (pr : expr) : smt_tactic Unit :=
  match t with
  | none => do
    let t ← infer_type pr
    assertv h t pr
  | some t => assertv h t pr
#align smt_tactic.note smt_tactic.note

unsafe def destruct (e : expr) : smt_tactic Unit :=
  smt_tactic.seq (tactic.destruct e) smt_tactic.intros
#align smt_tactic.destruct smt_tactic.destruct

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

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

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

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

unsafe def get_facts : smt_tactic (List expr) := do
  let cc ← to_cc_state
  return <| cc expr.mk_true
#align smt_tactic.get_facts smt_tactic.get_facts

unsafe def get_refuted_facts : smt_tactic (List expr) := do
  let cc ← to_cc_state
  return <| cc expr.mk_false
#align smt_tactic.get_refuted_facts smt_tactic.get_refuted_facts

unsafe def add_ematch_lemma : expr → smt_tactic Unit :=
  add_ematch_lemma_core reducible false
#align smt_tactic.add_ematch_lemma smt_tactic.add_ematch_lemma

unsafe def add_ematch_lhs_lemma : expr → smt_tactic Unit :=
  add_ematch_lemma_core reducible true
#align smt_tactic.add_ematch_lhs_lemma smt_tactic.add_ematch_lhs_lemma

unsafe def add_ematch_lemma_from_decl : Name → smt_tactic Unit :=
  add_ematch_lemma_from_decl_core reducible false
#align smt_tactic.add_ematch_lemma_from_decl smt_tactic.add_ematch_lemma_from_decl

unsafe def add_ematch_lhs_lemma_from_decl : Name → smt_tactic Unit :=
  add_ematch_lemma_from_decl_core reducible false
#align smt_tactic.add_ematch_lhs_lemma_from_decl smt_tactic.add_ematch_lhs_lemma_from_decl

unsafe def add_ematch_eqn_lemmas_for : Name → smt_tactic Unit :=
  add_ematch_eqn_lemmas_for_core reducible
#align smt_tactic.add_ematch_eqn_lemmas_for smt_tactic.add_ematch_eqn_lemmas_for

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `f -/
unsafe def add_lemmas_from_facts_core : List expr → smt_tactic Unit
  | [] => return ()
  | f :: fs => do
    try
        ((is_prop f >> guard (f && not (f f.is_arrow))) >> proof_for f >>=
          add_ematch_lemma_core reducible ff)
    add_lemmas_from_facts_core fs
#align smt_tactic.add_lemmas_from_facts_core smt_tactic.add_lemmas_from_facts_core

unsafe def add_lemmas_from_facts : smt_tactic Unit :=
  get_facts >>= add_lemmas_from_facts_core
#align smt_tactic.add_lemmas_from_facts smt_tactic.add_lemmas_from_facts

unsafe def induction (e : expr) (ids : List Name := []) (rec : Option Name := none) :
    smt_tactic Unit :=
  slift (tactic.induction e ids rec >> return ())
#align smt_tactic.induction smt_tactic.induction

-- pass on the information?
unsafe def when (c : Prop) [Decidable c] (tac : smt_tactic Unit) : smt_tactic Unit :=
  if c then tac else skip
#align smt_tactic.when smt_tactic.when

unsafe def when_tracing (n : Name) (tac : smt_tactic Unit) : smt_tactic Unit :=
  when (is_trace_enabled_for n = true) tac
#align smt_tactic.when_tracing smt_tactic.when_tracing

end SmtTactic

open SmtTactic

unsafe def using_smt {α} (t : smt_tactic α) (cfg : SmtConfig := { }) : tactic α := do
  let ss ← smt_state.mk cfg
  let (a, _) ←
    (do
            let a ← t
            iterate close
            return a).run
        ss
  return a
#align using_smt using_smt

unsafe def using_smt_with {α} (cfg : SmtConfig) (t : smt_tactic α) : tactic α :=
  using_smt t cfg
#align using_smt_with using_smt_with


import Lean

namespace SciLean.Meta.CustomSimp

open Lean Meta Elab Elab.Term

-- Maybe add option to write logical formulas in simp guard
-- something like @[simp_guard (n = 0) || (m = n)]

/-- Prevent applying the theorem if the specified argument is equation to the specified value.

Warning: It only works with custom simplifiers! Normal simplifier ignores this.

Example:
---
Adding the following simp guard to the chain rule prevents appying it if `g` is an identity function.

```
  @[simp_guard g (λ x => x)]
  theorem chain_rule {α β γ : Type}
    (f : β → γ) (g : α → β)
    : ∂ (λ x => f (g x)) = λ x dx => ∂ f (g x) (∂ g x dx) := ...
```
-/
syntax (name := simp_guard) "simp_guard" (ident term),+ : attr

initialize simpGuardAttr : ParametricAttribute (Array (Nat × Expr × Nat)) ←
  registerParametricAttribute {
    name := `simp_guard
    descr := "Do not apply this simp theorem if the specified argument has the specified value."
    getParam := fun name => fun
      | `(attr| simp_guard $[$ids $vals],*) =>
        MetaM.run' <| TermElabM.run' <| (ids.zip vals).mapM λ (id, val) => do
          let info ← getConstInfo name

          let nth ← forallTelescope info.type λ args _ => do
            let i? ← args.findIdxM?
              (λ arg => do
                let argDecl ← getFVarLocalDecl arg
                pure (argDecl.userName = id.getId))
            match i? with
            | some i => pure i
            | none => throwError "Theorem does not have an argument with the name `{id.getId}`"

          -- `valueFun` is a function taking all theorem arguments [0,..,nth) and returning guard value
          let (valFun, numMVars) ← forallBoundedTelescope info.type nth λ args _ => do
            let value ← elabTerm val none
            let value ← abstractMVars value

            pure (← mkLambdaFVars args value.expr, value.numMVars)

          pure (nth, valFun, numMVars)
      | _ => Elab.throwUnsupportedSyntax
  }

def hasCustomSimpGuard (env : Environment) (n : Name) : Bool :=
  match simpGuardAttr.getParam? env n with
  | some _ => true
  | none => false


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

notation, basic datatypes and type classes
-/
prelude
import Init.Prelude
import Init.SizeOf

universe u v w

def inline {α : Sort u} (a : α) : α := a

@[inline] def flip {α : Sort u} {β : Sort v} {φ : Sort w} (f : α → β → φ) : β → α → φ :=
  fun b a => f a b

@[simp] theorem Function.const_apply {y : β} {x : α} : const α y x = y := rfl

@[simp] theorem Function.comp_apply {f : β → δ} {g : α → β} {x : α} : comp f g x = f (g x) := rfl

attribute [simp] namedPattern

/--
  Thunks are "lazy" values that are evaluated when first accessed using `Thunk.get/map/bind`.
  The value is then stored and not recomputed for all further accesses. -/
-- NOTE: the runtime has special support for the `Thunk` type to implement this behavior
structure Thunk (α : Type u) : Type u where
  private fn : Unit → α

attribute [extern "lean_mk_thunk"] Thunk.mk

/-- Store a value in a thunk. Note that the value has already been computed, so there is no laziness. -/
@[extern "lean_thunk_pure"] protected def Thunk.pure (a : α) : Thunk α :=
  ⟨fun _ => a⟩
-- NOTE: we use `Thunk.get` instead of `Thunk.fn` as the accessor primitive as the latter has an additional `Unit` argument
@[extern "lean_thunk_get_own"] protected def Thunk.get (x : @& Thunk α) : α :=
  x.fn ()
@[inline] protected def Thunk.map (f : α → β) (x : Thunk α) : Thunk β :=
  ⟨fun _ => f x.get⟩
@[inline] protected def Thunk.bind (x : Thunk α) (f : α → Thunk β) : Thunk β :=
  ⟨fun _ => (f x.get).get⟩

abbrev Eq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : α → Sort u1} {b : α} (h : a = b) (m : motive a) : motive b :=
  Eq.ndrec m h

structure Iff (a b : Prop) : Prop where
  intro :: (mp : a → b) (mpr : b → a)

infix:20 " <-> " => Iff
infix:20 " ↔ "   => Iff

inductive Sum (α : Type u) (β : Type v) where
  | inl (val : α) : Sum α β
  | inr (val : β) : Sum α β

infixr:30 " ⊕ " => Sum

inductive PSum (α : Sort u) (β : Sort v) where
  | inl (val : α) : PSum α β
  | inr (val : β) : PSum α β

infixr:30 " ⊕' " => PSum

structure Sigma {α : Type u} (β : α → Type v) where
  fst : α
  snd : β fst

attribute [unbox] Sigma

structure PSigma {α : Sort u} (β : α → Sort v) where
  fst : α
  snd : β fst

inductive Exists {α : Sort u} (p : α → Prop) : Prop where
  | intro (w : α) (h : p w) : Exists p

/- Auxiliary type used to compile `for x in xs` notation. -/
inductive ForInStep (α : Type u) where
  | done  : α → ForInStep α
  | yield : α → ForInStep α

class ForIn (m : Type u₁ → Type u₂) (ρ : Type u) (α : outParam (Type v)) where
  forIn {β} [Monad m] (x : ρ) (b : β) (f : α → β → m (ForInStep β)) : m β

export ForIn (forIn)

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultPRBC (α β σ : Type u) where
  | «pure»     : α → σ → DoResultPRBC α β σ
  | «return»   : β → σ → DoResultPRBC α β σ
  | «break»    : σ → DoResultPRBC α β σ
  | «continue» : σ → DoResultPRBC α β σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultPR (α β σ : Type u) where
  | «pure»     : α → σ → DoResultPR α β σ
  | «return»   : β → σ → DoResultPR α β σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultBC (σ : Type u) where
  | «break»    : σ → DoResultBC σ
  | «continue» : σ → DoResultBC σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultSBC (α σ : Type u) where
  | «pureReturn» : α → σ → DoResultSBC α σ
  | «break»      : σ → DoResultSBC α σ
  | «continue»   : σ → DoResultSBC α σ

class HasEquiv  (α : Sort u) where
  Equiv : α → α → Sort v

infix:50 " ≈ "  => HasEquiv.Equiv

class EmptyCollection (α : Type u) where
  emptyCollection : α

notation "{" "}" => EmptyCollection.emptyCollection
notation "∅"     => EmptyCollection.emptyCollection

/- Remark: tasks have an efficient implementation in the runtime. -/
structure Task (α : Type u) : Type u where
  pure :: (get : α)
  deriving Inhabited

attribute [extern "lean_task_pure"] Task.pure
attribute [extern "lean_task_get_own"] Task.get

namespace Task
/-- Task priority. Tasks with higher priority will always be scheduled before ones with lower priority. -/
abbrev Priority := Nat
def Priority.default : Priority := 0
-- see `LEAN_MAX_PRIO`
def Priority.max : Priority := 8
/--
  Any priority higher than `Task.Priority.max` will result in the task being scheduled immediately on a dedicated thread.
  This is particularly useful for long-running and/or I/O-bound tasks since Lean will by default allocate no more
  non-dedicated workers than the number of cores to reduce context switches. -/
def Priority.dedicated : Priority := 9

@[noinline, extern "lean_task_spawn"]
protected def spawn {α : Type u} (fn : Unit → α) (prio := Priority.default) : Task α :=
  ⟨fn ()⟩

@[noinline, extern "lean_task_map"]
protected def map {α : Type u} {β : Type v} (f : α → β) (x : Task α) (prio := Priority.default) : Task β :=
  ⟨f x.get⟩

@[noinline, extern "lean_task_bind"]
protected def bind {α : Type u} {β : Type v} (x : Task α) (f : α → Task β) (prio := Priority.default) : Task β :=
  ⟨(f x.get).get⟩

end Task

/- Some type that is not a scalar value in our runtime. -/
structure NonScalar where
  val : Nat

/- Some type that is not a scalar value in our runtime and is universe polymorphic. -/
inductive PNonScalar : Type u where
  | mk (v : Nat) : PNonScalar

@[simp] theorem Nat.add_zero (n : Nat) : n + 0 = n := rfl

theorem optParam_eq (α : Sort u) (default : α) : optParam α default = α := rfl

/- Boolean operators -/

@[extern c inline "#1 || #2"] def strictOr  (b₁ b₂ : Bool) := b₁ || b₂
@[extern c inline "#1 && #2"] def strictAnd (b₁ b₂ : Bool) := b₁ && b₂

@[inline] def bne {α : Type u} [BEq α] (a b : α) : Bool :=
  !(a == b)

infix:50 " != " => bne

/- Logical connectives an equality -/

def implies (a b : Prop) := a → b

theorem implies.trans {p q r : Prop} (h₁ : implies p q) (h₂ : implies q r) : implies p r :=
  fun hp => h₂ (h₁ hp)

def trivial : True := ⟨⟩

theorem mt {a b : Prop} (h₁ : a → b) (h₂ : ¬b) : ¬a :=
  fun ha => h₂ (h₁ ha)

theorem not_false : ¬False := id

theorem not_not_intro {p : Prop} (h : p) : ¬ ¬ p :=
  fun hn : ¬ p => hn h

-- proof irrelevance is built in
theorem proofIrrel {a : Prop} (h₁ h₂ : a) : h₁ = h₂ := rfl

theorem id.def {α : Sort u} (a : α) : id a = a := rfl

@[macroInline] def Eq.mp {α β : Sort u} (h : α = β) (a : α) : β :=
  h ▸ a

@[macroInline] def Eq.mpr {α β : Sort u} (h : α = β) (b : β) : α :=
  h ▸ b

theorem Eq.substr {α : Sort u} {p : α → Prop} {a b : α} (h₁ : b = a) (h₂ : p a) : p b :=
  h₁ ▸ h₂

theorem cast_eq {α : Sort u} (h : α = α) (a : α) : cast h a = a :=
  rfl

@[reducible] def Ne {α : Sort u} (a b : α) :=
  ¬(a = b)

infix:50 " ≠ "  => Ne

section Ne
variable {α : Sort u}
variable {a b : α} {p : Prop}

theorem Ne.intro (h : a = b → False) : a ≠ b := h

theorem Ne.elim (h : a ≠ b) : a = b → False := h

theorem Ne.irrefl (h : a ≠ a) : False := h rfl

theorem Ne.symm (h : a ≠ b) : b ≠ a :=
  fun h₁ => h (h₁.symm)

theorem false_of_ne : a ≠ a → False := Ne.irrefl

theorem ne_false_of_self : p → p ≠ False :=
  fun (hp : p) (h : p = False) => h ▸ hp

theorem ne_true_of_not : ¬p → p ≠ True :=
  fun (hnp : ¬p) (h : p = True) =>
    have : ¬True := h ▸ hnp
    this trivial

theorem true_ne_false : ¬True = False :=
  ne_false_of_self trivial

end Ne

section
variable {α β φ : Sort u} {a a' : α} {b b' : β} {c : φ}

theorem HEq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} (m : motive a) {β : Sort u2} {b : β} (h : HEq a b) : motive b :=
  @HEq.rec α a (fun b _ => motive b) m β b h

theorem HEq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} {β : Sort u2} {b : β} (h : HEq a b) (m : motive a) : motive b :=
  @HEq.rec α a (fun b _ => motive b) m β b h

theorem HEq.elim {α : Sort u} {a : α} {p : α → Sort v} {b : α} (h₁ : HEq a b) (h₂ : p a) : p b :=
  eq_of_heq h₁ ▸ h₂

theorem HEq.subst {p : (T : Sort u) → T → Prop} (h₁ : HEq a b) (h₂ : p α a) : p β b :=
  HEq.ndrecOn h₁ h₂

theorem HEq.symm (h : HEq a b) : HEq b a :=
  HEq.ndrecOn (motive := fun x => HEq x a) h (HEq.refl a)

theorem heq_of_eq (h : a = a') : HEq a a' :=
  Eq.subst h (HEq.refl a)

theorem HEq.trans (h₁ : HEq a b) (h₂ : HEq b c) : HEq a c :=
  HEq.subst h₂ h₁

theorem heq_of_heq_of_eq (h₁ : HEq a b) (h₂ : b = b') : HEq a b' :=
  HEq.trans h₁ (heq_of_eq h₂)

theorem heq_of_eq_of_heq (h₁ : a = a') (h₂ : HEq a' b) : HEq a b :=
  HEq.trans (heq_of_eq h₁) h₂

def type_eq_of_heq (h : HEq a b) : α = β :=
  HEq.ndrecOn (motive := @fun (x : Sort u) _ => α = x) h (Eq.refl α)

end

theorem eqRec_heq {α : Sort u} {φ : α → Sort v} {a a' : α} : (h : a = a') → (p : φ a) → HEq (Eq.recOn (motive := fun x _ => φ x) h p) p
  | rfl, p => HEq.refl p

theorem heq_of_eqRec_eq {α β : Sort u} {a : α} {b : β} (h₁ : α = β) (h₂ : Eq.rec (motive := fun α _ => α) a h₁ = b) : HEq a b := by
  subst h₁
  apply heq_of_eq
  exact h₂

theorem cast_heq {α β : Sort u} : (h : α = β) → (a : α) → HEq (cast h a) a
  | rfl, a => HEq.refl a

variable {a b c d : Prop}

theorem iff_iff_implies_and_implies (a b : Prop) : (a ↔ b) ↔ (a → b) ∧ (b → a) :=
  Iff.intro (fun h => And.intro h.mp h.mpr) (fun h => Iff.intro h.left h.right)

theorem Iff.refl (a : Prop) : a ↔ a :=
  Iff.intro (fun h => h) (fun h => h)

protected theorem Iff.rfl {a : Prop} : a ↔ a :=
  Iff.refl a

theorem Iff.trans (h₁ : a ↔ b) (h₂ : b ↔ c) : a ↔ c :=
  Iff.intro
    (fun ha => Iff.mp h₂ (Iff.mp h₁ ha))
    (fun hc => Iff.mpr h₁ (Iff.mpr h₂ hc))

theorem Iff.symm (h : a ↔ b) : b ↔ a :=
  Iff.intro (Iff.mpr h) (Iff.mp h)

theorem Iff.comm : (a ↔ b) ↔ (b ↔ a) :=
  Iff.intro Iff.symm Iff.symm

/- Exists -/

theorem Exists.elim {α : Sort u} {p : α → Prop} {b : Prop}
   (h₁ : Exists (fun x => p x)) (h₂ : ∀ (a : α), p a → b) : b :=
  h₂ h₁.1 h₁.2

/- Decidable -/

theorem decide_true_eq_true (h : Decidable True) : @decide True h = true :=
  match h with
  | isTrue h  => rfl
  | isFalse h => False.elim <| h ⟨⟩

theorem decide_false_eq_false (h : Decidable False) : @decide False h = false :=
  match h with
  | isFalse h => rfl
  | isTrue h  => False.elim h

/-- Similar to `decide`, but uses an explicit instance -/
@[inline] def toBoolUsing {p : Prop} (d : Decidable p) : Bool :=
  decide p (h := d)

theorem toBoolUsing_eq_true {p : Prop} (d : Decidable p) (h : p) : toBoolUsing d = true :=
  decide_eq_true (s := d) h

theorem ofBoolUsing_eq_true {p : Prop} {d : Decidable p} (h : toBoolUsing d = true) : p :=
  of_decide_eq_true (s := d) h

theorem ofBoolUsing_eq_false {p : Prop} {d : Decidable p} (h : toBoolUsing d = false) : ¬ p :=
  of_decide_eq_false (s := d) h

instance : Decidable True :=
  isTrue trivial

instance : Decidable False :=
  isFalse not_false

namespace Decidable
variable {p q : Prop}

@[macroInline] def byCases {q : Sort u} [dec : Decidable p] (h1 : p → q) (h2 : ¬p → q) : q :=
  match dec with
  | isTrue h  => h1 h
  | isFalse h => h2 h

theorem em (p : Prop) [Decidable p] : p ∨ ¬p :=
  byCases Or.inl Or.inr

theorem byContradiction [dec : Decidable p] (h : ¬p → False) : p :=
  byCases id (fun np => False.elim (h np))

theorem of_not_not [Decidable p] : ¬ ¬ p → p :=
  fun hnn => byContradiction (fun hn => absurd hn hnn)

theorem not_and_iff_or_not (p q : Prop) [d₁ : Decidable p] [d₂ : Decidable q] : ¬ (p ∧ q) ↔ ¬ p ∨ ¬ q :=
  Iff.intro
    (fun h => match d₁, d₂ with
      | isTrue h₁,  isTrue h₂   => absurd (And.intro h₁ h₂) h
      | _,           isFalse h₂ => Or.inr h₂
      | isFalse h₁, _           => Or.inl h₁)
    (fun (h) ⟨hp, hq⟩ => match h with
      | Or.inl h => h hp
      | Or.inr h => h hq)

end Decidable

section
variable {p q : Prop}
@[inline] def  decidableOfDecidableOfIff (hp : Decidable p) (h : p ↔ q) : Decidable q :=
  if hp : p then
    isTrue (Iff.mp h hp)
  else
    isFalse fun hq => absurd (Iff.mpr h hq) hp

@[inline] def  decidableOfDecidableOfEq (hp : Decidable p) (h : p = q) : Decidable q :=
  h ▸ hp
end

@[macroInline] instance {p q} [Decidable p] [Decidable q] : Decidable (p → q) :=
  if hp : p then
    if hq : q then isTrue (fun h => hq)
    else isFalse (fun h => absurd (h hp) hq)
  else isTrue (fun h => absurd h hp)

instance {p q} [Decidable p] [Decidable q] : Decidable (p ↔ q) :=
  if hp : p then
    if hq : q then
      isTrue ⟨fun _ => hq, fun _ => hp⟩
    else
      isFalse fun h => hq (h.1 hp)
  else
    if hq : q then
      isFalse fun h => hp (h.2 hq)
    else
      isTrue ⟨fun h => absurd h hp, fun h => absurd h hq⟩

/- if-then-else expression theorems -/

theorem if_pos {c : Prop} [h : Decidable c] (hc : c) {α : Sort u} {t e : α} : (ite c t e) = t :=
  match h with
  | isTrue  hc  => rfl
  | isFalse hnc => absurd hc hnc

theorem if_neg {c : Prop} [h : Decidable c] (hnc : ¬c) {α : Sort u} {t e : α} : (ite c t e) = e :=
  match h with
  | isTrue hc   => absurd hc hnc
  | isFalse hnc => rfl

theorem dif_pos {c : Prop} [h : Decidable c] (hc : c) {α : Sort u} {t : c → α} {e : ¬ c → α} : (dite c t e) = t hc :=
  match h with
  | isTrue  hc  => rfl
  | isFalse hnc => absurd hc hnc

theorem dif_neg {c : Prop} [h : Decidable c] (hnc : ¬c) {α : Sort u} {t : c → α} {e : ¬ c → α} : (dite c t e) = e hnc :=
  match h with
  | isTrue hc   => absurd hc hnc
  | isFalse hnc => rfl

-- Remark: dite and ite are "defally equal" when we ignore the proofs.
theorem dif_eq_if (c : Prop) [h : Decidable c] {α : Sort u} (t : α) (e : α) : dite c (fun h => t) (fun h => e) = ite c t e :=
  match h with
  | isTrue hc   => rfl
  | isFalse hnc => rfl

instance {c t e : Prop} [dC : Decidable c] [dT : Decidable t] [dE : Decidable e] : Decidable (if c then t else e)  :=
  match dC with
  | isTrue hc  => dT
  | isFalse hc => dE

instance {c : Prop} {t : c → Prop} {e : ¬c → Prop} [dC : Decidable c] [dT : ∀ h, Decidable (t h)] [dE : ∀ h, Decidable (e h)] : Decidable (if h : c then t h else e h)  :=
  match dC with
  | isTrue hc  => dT hc
  | isFalse hc => dE hc

/- Auxiliary definitions for generating compact `noConfusion` for enumeration types -/
abbrev noConfusionTypeEnum {α : Sort u} {β : Sort v} [DecidableEq β] (f : α → β) (P : Sort w) (x y : α) : Sort w :=
  if f x = f y then P → P else P

abbrev noConfusionEnum {α : Sort u} {β : Sort v} [DecidableEq β] (f : α → β) {P : Sort w} {x y : α} (h : x = y) : noConfusionTypeEnum f P x y :=
  if h' : f x = f y then
    cast (@if_pos _ _ h' _ (P → P) (P)).symm (fun (h : P) => h)
  else
    False.elim (h' (congrArg f h))

/- Inhabited -/

instance : Inhabited Prop where
  default := True

deriving instance Inhabited for NonScalar, PNonScalar, True, ForInStep

theorem nonempty_of_exists {α : Sort u} {p : α → Prop} : Exists (fun x => p x) → Nonempty α
  | ⟨w, h⟩ => ⟨w⟩

/- Subsingleton -/

class Subsingleton (α : Sort u) : Prop where
  intro :: allEq : (a b : α) → a = b

protected def Subsingleton.elim {α : Sort u} [h : Subsingleton α] : (a b : α) → a = b :=
  h.allEq

protected def Subsingleton.helim {α β : Sort u} [h₁ : Subsingleton α] (h₂ : α = β) (a : α) (b : β) : HEq a b := by
  subst h₂
  apply heq_of_eq
  apply Subsingleton.elim

instance (p : Prop) : Subsingleton p :=
  ⟨fun a b => proofIrrel a b⟩

instance (p : Prop) : Subsingleton (Decidable p) :=
  Subsingleton.intro fun
    | isTrue t₁ => fun
      | isTrue t₂  => rfl
      | isFalse f₂ => absurd t₁ f₂
    | isFalse f₁ => fun
      | isTrue t₂  => absurd t₂ f₁
      | isFalse f₂ => rfl

theorem recSubsingleton
     {p : Prop} [h : Decidable p]
     {h₁ : p → Sort u}
     {h₂ : ¬p → Sort u}
     [h₃ : ∀ (h : p), Subsingleton (h₁ h)]
     [h₄ : ∀ (h : ¬p), Subsingleton (h₂ h)]
     : Subsingleton (Decidable.casesOn (motive := fun _ => Sort u) h h₂ h₁) :=
  match h with
  | isTrue h  => h₃ h
  | isFalse h => h₄ h

structure Equivalence {α : Sort u} (r : α → α → Prop) : Prop where
  refl  : ∀ x, r x x
  symm  : ∀ {x y}, r x y → r y x
  trans : ∀ {x y z}, r x y → r y z → r x z

def emptyRelation {α : Sort u} (a₁ a₂ : α) : Prop :=
  False

def Subrelation {α : Sort u} (q r : α → α → Prop) :=
  ∀ {x y}, q x y → r x y

def InvImage {α : Sort u} {β : Sort v} (r : β → β → Prop) (f : α → β) : α → α → Prop :=
  fun a₁ a₂ => r (f a₁) (f a₂)

inductive TC {α : Sort u} (r : α → α → Prop) : α → α → Prop where
  | base  : ∀ a b, r a b → TC r a b
  | trans : ∀ a b c, TC r a b → TC r b c → TC r a c

/- Subtype -/

namespace Subtype
def existsOfSubtype {α : Type u} {p : α → Prop} : { x // p x } → Exists (fun x => p x)
  | ⟨a, h⟩ => ⟨a, h⟩

variable {α : Type u} {p : α → Prop}

protected theorem eq : ∀ {a1 a2 : {x // p x}}, val a1 = val a2 → a1 = a2
  | ⟨x, h1⟩, ⟨_, _⟩, rfl => rfl

theorem eta (a : {x // p x}) (h : p (val a)) : mk (val a) h = a := by
  cases a
  exact rfl

instance {α : Type u} {p : α → Prop} {a : α} (h : p a) : Inhabited {x // p x} where
  default := ⟨a, h⟩

instance {α : Type u} {p : α → Prop} [DecidableEq α] : DecidableEq {x : α // p x} :=
  fun ⟨a, h₁⟩ ⟨b, h₂⟩ =>
    if h : a = b then isTrue (by subst h; exact rfl)
    else isFalse (fun h' => Subtype.noConfusion h' (fun h' => absurd h' h))

end Subtype

/- Sum -/

section
variable {α : Type u} {β : Type v}

instance Sum.inhabitedLeft [h : Inhabited α] : Inhabited (Sum α β) where
  default := Sum.inl default

instance Sum.inhabitedRight [h : Inhabited β] : Inhabited (Sum α β) where
  default := Sum.inr default

instance {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] : DecidableEq (Sum α β) := fun a b =>
  match a, b with
  | Sum.inl a, Sum.inl b =>
    if h : a = b then isTrue (h ▸ rfl)
    else isFalse fun h' => Sum.noConfusion h' fun h' => absurd h' h
  | Sum.inr a, Sum.inr b =>
    if h : a = b then isTrue (h ▸ rfl)
    else isFalse fun h' => Sum.noConfusion h' fun h' => absurd h' h
  | Sum.inr a, Sum.inl b => isFalse fun h => Sum.noConfusion h
  | Sum.inl a, Sum.inr b => isFalse fun h => Sum.noConfusion h

end

/- Product -/

instance [Inhabited α] [Inhabited β] : Inhabited (α × β) where
  default := (default, default)

instance [DecidableEq α] [DecidableEq β] : DecidableEq (α × β) :=
  fun (a, b) (a', b') =>
    match decEq a a' with
    | isTrue e₁ =>
      match decEq b b' with
      | isTrue e₂  => isTrue (e₁ ▸ e₂ ▸ rfl)
      | isFalse n₂ => isFalse fun h => Prod.noConfusion h fun e₁' e₂' => absurd e₂' n₂
    | isFalse n₁ => isFalse fun h => Prod.noConfusion h fun e₁' e₂' => absurd e₁' n₁

instance [BEq α] [BEq β] : BEq (α × β) where
  beq := fun (a₁, b₁) (a₂, b₂) => a₁ == a₂ && b₁ == b₂

instance [LT α] [LT β] : LT (α × β) where
  lt s t := s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)

instance prodHasDecidableLt
    [LT α] [LT β] [DecidableEq α] [DecidableEq β]
    [(a b : α) → Decidable (a < b)] [(a b : β) → Decidable (a < b)]
    : (s t : α × β) → Decidable (s < t) :=
  fun t s => inferInstanceAs (Decidable (_ ∨ _))

theorem Prod.lt_def [LT α] [LT β] (s t : α × β) : (s < t) = (s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)) :=
  rfl

theorem Prod.ext (p : α × β) : (p.1, p.2) = p := by
  cases p; rfl

def Prod.map {α₁ : Type u₁} {α₂ : Type u₂} {β₁ : Type v₁} {β₂ : Type v₂}
    (f : α₁ → α₂) (g : β₁ → β₂) : α₁ × β₁ → α₂ × β₂
  | (a, b) => (f a, g b)

/- Dependent products -/

theorem ex_of_PSigma {α : Type u} {p : α → Prop} : (PSigma (fun x => p x)) → Exists (fun x => p x)
  | ⟨x, hx⟩ => ⟨x, hx⟩

protected theorem PSigma.eta {α : Sort u} {β : α → Sort v} {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂}
    (h₁ : a₁ = a₂) (h₂ : Eq.ndrec b₁ h₁ = b₂) : PSigma.mk a₁ b₁ = PSigma.mk a₂ b₂ := by
  subst h₁
  subst h₂
  exact rfl

/- Universe polymorphic unit -/

theorem PUnit.subsingleton (a b : PUnit) : a = b := by
  cases a; cases b; exact rfl

theorem PUnit.eq_punit (a : PUnit) : a = ⟨⟩ :=
  PUnit.subsingleton a ⟨⟩

instance : Subsingleton PUnit :=
  Subsingleton.intro PUnit.subsingleton

instance : Inhabited PUnit where
  default := ⟨⟩

instance : DecidableEq PUnit :=
  fun a b => isTrue (PUnit.subsingleton a b)

/- Setoid -/

class Setoid (α : Sort u) where
  r : α → α → Prop
  iseqv {} : Equivalence r

instance {α : Sort u} [Setoid α] : HasEquiv α :=
  ⟨Setoid.r⟩

namespace Setoid

variable {α : Sort u} [Setoid α]

theorem refl (a : α) : a ≈ a :=
  (Setoid.iseqv α).refl a

theorem symm {a b : α} (hab : a ≈ b) : b ≈ a :=
  (Setoid.iseqv α).symm hab

theorem trans {a b c : α} (hab : a ≈ b) (hbc : b ≈ c) : a ≈ c :=
  (Setoid.iseqv α).trans hab hbc

end Setoid

/- Propositional extensionality -/

axiom propext {a b : Prop} : (a ↔ b) → a = b

theorem Eq.propIntro {a b : Prop} (h₁ : a → b) (h₂ : b → a) : a = b :=
  propext <| Iff.intro h₁ h₂

-- Eq for Prop is now decidable if the equivalent Iff is decidable
instance {p q : Prop} [d : Decidable (p ↔ q)] : Decidable (p = q) :=
  match d with
  | isTrue h => isTrue (propext h)
  | isFalse h => isFalse fun heq => h (heq ▸ Iff.rfl)

gen_injective_theorems% Prod
gen_injective_theorems% PProd
gen_injective_theorems% MProd
gen_injective_theorems% Subtype
gen_injective_theorems% Fin
gen_injective_theorems% Array
gen_injective_theorems% Sum
gen_injective_theorems% PSum
gen_injective_theorems% Nat
gen_injective_theorems% Option
gen_injective_theorems% List
gen_injective_theorems% Except
gen_injective_theorems% EStateM.Result
gen_injective_theorems% Lean.Name
gen_injective_theorems% Lean.Syntax

/- Quotients -/

-- Iff can now be used to do substitutions in a calculation
theorem Iff.subst {a b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
  Eq.subst (propext h₁) h₂

namespace Quot
axiom sound : ∀ {α : Sort u} {r : α → α → Prop} {a b : α}, r a b → Quot.mk r a = Quot.mk r b

protected theorem liftBeta {α : Sort u} {r : α → α → Prop} {β : Sort v}
    (f : α → β)
    (c : (a b : α) → r a b → f a = f b)
    (a : α)
    : lift f c (Quot.mk r a) = f a :=
  rfl

protected theorem indBeta {α : Sort u} {r : α → α → Prop} {motive : Quot r → Prop}
    (p : (a : α) → motive (Quot.mk r a))
    (a : α)
    : (ind p (Quot.mk r a) : motive (Quot.mk r a)) = p a :=
  rfl

protected abbrev liftOn {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β) (c : (a b : α) → r a b → f a = f b) : β :=
  lift f c q

protected theorem inductionOn {α : Sort u} {r : α → α → Prop} {motive : Quot r → Prop}
    (q : Quot r)
    (h : (a : α) → motive (Quot.mk r a))
    : motive q :=
  ind h q

theorem exists_rep {α : Sort u} {r : α → α → Prop} (q : Quot r) : Exists (fun a => (Quot.mk r a) = q) :=
  Quot.inductionOn (motive := fun q => Exists (fun a => (Quot.mk r a) = q)) q (fun a => ⟨a, rfl⟩)

section
variable {α : Sort u}
variable {r : α → α → Prop}
variable {motive : Quot r → Sort v}

@[reducible, macroInline]
protected def indep (f : (a : α) → motive (Quot.mk r a)) (a : α) : PSigma motive :=
  ⟨Quot.mk r a, f a⟩

protected theorem indepCoherent
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    : (a b : α) → r a b → Quot.indep f a = Quot.indep f b  :=
  fun a b e => PSigma.eta (sound e) (h a b e)

protected theorem liftIndepPr1
    (f : (a : α) → motive (Quot.mk r a))
    (h : ∀ (a b : α) (p : r a b), Eq.ndrec (f a) (sound p) = f b)
    (q : Quot r)
    : (lift (Quot.indep f) (Quot.indepCoherent f h) q).1 = q := by
 induction q using Quot.ind
 exact rfl

protected abbrev rec
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    (q : Quot r) : motive q :=
  Eq.ndrecOn (Quot.liftIndepPr1 f h q) ((lift (Quot.indep f) (Quot.indepCoherent f h) q).2)

protected abbrev recOn
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    : motive q :=
 Quot.rec f h q

protected abbrev recOnSubsingleton
    [h : (a : α) → Subsingleton (motive (Quot.mk r a))]
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    : motive q := by
  induction q using Quot.rec
  apply f
  apply Subsingleton.elim

protected abbrev hrecOn
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    (c : (a b : α) → (p : r a b) → HEq (f a) (f b))
    : motive q :=
  Quot.recOn q f fun a b p => eq_of_heq <|
    have p₁ : HEq (Eq.ndrec (f a) (sound p)) (f a) := eqRec_heq (sound p) (f a)
    HEq.trans p₁ (c a b p)

end
end Quot

def Quotient {α : Sort u} (s : Setoid α) :=
  @Quot α Setoid.r

namespace Quotient

@[inline]
protected def mk {α : Sort u} (s : Setoid α) (a : α) : Quotient s :=
  Quot.mk Setoid.r a

protected def mk' {α : Sort u} [s : Setoid α] (a : α) : Quotient s :=
  Quotient.mk s a

def sound {α : Sort u} {s : Setoid α} {a b : α} : a ≈ b → Quotient.mk s a = Quotient.mk s b :=
  Quot.sound

protected abbrev lift {α : Sort u} {β : Sort v} {s : Setoid α} (f : α → β) : ((a b : α) → a ≈ b → f a = f b) → Quotient s → β :=
  Quot.lift f

protected theorem ind {α : Sort u} {s : Setoid α} {motive : Quotient s → Prop} : ((a : α) → motive (Quotient.mk s a)) → (q : Quot Setoid.r) → motive q :=
  Quot.ind

protected abbrev liftOn {α : Sort u} {β : Sort v} {s : Setoid α} (q : Quotient s) (f : α → β) (c : (a b : α) → a ≈ b → f a = f b) : β :=
  Quot.liftOn q f c

protected theorem inductionOn {α : Sort u} {s : Setoid α} {motive : Quotient s → Prop}
    (q : Quotient s)
    (h : (a : α) → motive (Quotient.mk s a))
    : motive q :=
  Quot.inductionOn q h

theorem exists_rep {α : Sort u} {s : Setoid α} (q : Quotient s) : Exists (fun (a : α) => Quotient.mk s a = q) :=
  Quot.exists_rep q

section
variable {α : Sort u}
variable {s : Setoid α}
variable {motive : Quotient s → Sort v}

@[inline]
protected def rec
    (f : (a : α) → motive (Quotient.mk s a))
    (h : (a b : α) → (p : a ≈ b) → Eq.ndrec (f a) (Quotient.sound p) = f b)
    (q : Quotient s)
    : motive q :=
  Quot.rec f h q

protected abbrev recOn
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk s a))
    (h : (a b : α) → (p : a ≈ b) → Eq.ndrec (f a) (Quotient.sound p) = f b)
    : motive q :=
  Quot.recOn q f h

protected abbrev recOnSubsingleton
    [h : (a : α) → Subsingleton (motive (Quotient.mk s a))]
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk s a))
    : motive q :=
  Quot.recOnSubsingleton (h := h) q f

protected abbrev hrecOn
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk s a))
    (c : (a b : α) → (p : a ≈ b) → HEq (f a) (f b))
    : motive q :=
  Quot.hrecOn q f c
end

section
universe uA uB uC
variable {α : Sort uA} {β : Sort uB} {φ : Sort uC}
variable {s₁ : Setoid α} {s₂ : Setoid β}

protected abbrev lift₂
    (f : α → β → φ)
    (c : (a₁ : α) → (b₁ : β) → (a₂ : α) → (b₂ : β) → a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ = f a₂ b₂)
    (q₁ : Quotient s₁) (q₂ : Quotient s₂)
    : φ := by
  apply Quotient.lift (fun (a₁ : α) => Quotient.lift (f a₁) (fun (a b : β) => c a₁ a a₁ b (Setoid.refl a₁)) q₂) _ q₁
  intros
  induction q₂ using Quotient.ind
  apply c; assumption; apply Setoid.refl

protected abbrev liftOn₂
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (f : α → β → φ)
    (c : (a₁ : α) → (b₁ : β) → (a₂ : α) → (b₂ : β) → a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ = f a₂ b₂)
    : φ :=
  Quotient.lift₂ f c q₁ q₂

protected theorem ind₂
    {motive : Quotient s₁ → Quotient s₂ → Prop}
    (h : (a : α) → (b : β) → motive (Quotient.mk s₁ a) (Quotient.mk s₂ b))
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    : motive q₁ q₂ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  apply h

protected theorem inductionOn₂
    {motive : Quotient s₁ → Quotient s₂ → Prop}
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (h : (a : α) → (b : β) → motive (Quotient.mk s₁ a) (Quotient.mk s₂ b))
    : motive q₁ q₂ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  apply h

protected theorem inductionOn₃
    {s₃ : Setoid φ}
    {motive : Quotient s₁ → Quotient s₂ → Quotient s₃ → Prop}
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (q₃ : Quotient s₃)
    (h : (a : α) → (b : β) → (c : φ) → motive (Quotient.mk s₁ a) (Quotient.mk s₂ b) (Quotient.mk s₃ c))
    : motive q₁ q₂ q₃ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  induction q₃ using Quotient.ind
  apply h

end

section Exact

variable   {α : Sort u}

private def rel {s : Setoid α} (q₁ q₂ : Quotient s) : Prop :=
  Quotient.liftOn₂ q₁ q₂
    (fun a₁ a₂ => a₁ ≈ a₂)
    (fun a₁ a₂ b₁ b₂ a₁b₁ a₂b₂ =>
      propext (Iff.intro
        (fun a₁a₂ => Setoid.trans (Setoid.symm a₁b₁) (Setoid.trans a₁a₂ a₂b₂))
        (fun b₁b₂ => Setoid.trans a₁b₁ (Setoid.trans b₁b₂ (Setoid.symm a₂b₂)))))

private theorem rel.refl {s : Setoid α} (q : Quotient s) : rel q q :=
  Quot.inductionOn (motive := fun q => rel q q) q (fun a => Setoid.refl a)

private theorem rel_of_eq {s : Setoid α} {q₁ q₂ : Quotient s} : q₁ = q₂ → rel q₁ q₂ :=
  fun h => Eq.ndrecOn h (rel.refl q₁)

theorem exact {s : Setoid α} {a b : α} : Quotient.mk s a = Quotient.mk s b → a ≈ b :=
  fun h => rel_of_eq h

end Exact

section
universe uA uB uC
variable {α : Sort uA} {β : Sort uB}
variable {s₁ : Setoid α} {s₂ : Setoid β}

protected abbrev recOnSubsingleton₂
    {motive : Quotient s₁ → Quotient s₂ → Sort uC}
    [s : (a : α) → (b : β) → Subsingleton (motive (Quotient.mk s₁ a) (Quotient.mk s₂ b))]
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (g : (a : α) → (b : β) → motive (Quotient.mk s₁ a) (Quotient.mk s₂ b))
    : motive q₁ q₂ := by
  induction q₁ using Quot.recOnSubsingleton
  induction q₂ using Quot.recOnSubsingleton
  apply g
  intro a; apply s
  induction q₂ using Quot.recOnSubsingleton
  intro a; apply s
  infer_instance

end
end Quotient

section
variable {α : Type u}
variable (r : α → α → Prop)

instance {α : Sort u} {s : Setoid α} [d : ∀ (a b : α), Decidable (a ≈ b)] : DecidableEq (Quotient s) :=
  fun (q₁ q₂ : Quotient s) =>
    Quotient.recOnSubsingleton₂ (motive := fun a b => Decidable (a = b)) q₁ q₂
      fun a₁ a₂ =>
        match d a₁ a₂ with
        | isTrue h₁  => isTrue (Quotient.sound h₁)
        | isFalse h₂ => isFalse fun h => absurd (Quotient.exact h) h₂

/- Function extensionality -/

namespace Function
variable {α : Sort u} {β : α → Sort v}

protected def Equiv (f₁ f₂ : ∀ (x : α), β x) : Prop := ∀ x, f₁ x = f₂ x

protected theorem Equiv.refl (f : ∀ (x : α), β x) : Function.Equiv f f :=
  fun x => rfl

protected theorem Equiv.symm {f₁ f₂ : ∀ (x : α), β x} : Function.Equiv f₁ f₂ → Function.Equiv f₂ f₁ :=
  fun h x => Eq.symm (h x)

protected theorem Equiv.trans {f₁ f₂ f₃ : ∀ (x : α), β x} : Function.Equiv f₁ f₂ → Function.Equiv f₂ f₃ → Function.Equiv f₁ f₃ :=
  fun h₁ h₂ x => Eq.trans (h₁ x) (h₂ x)

protected theorem Equiv.isEquivalence (α : Sort u) (β : α → Sort v) : Equivalence (@Function.Equiv α β) := {
  refl := Equiv.refl
  symm := Equiv.symm
  trans := Equiv.trans
}

end Function

section
open Quotient
variable {α : Sort u} {β : α → Sort v}

@[instance]
private def funSetoid (α : Sort u) (β : α → Sort v) : Setoid (∀ (x : α), β x) :=
  Setoid.mk (@Function.Equiv α β) (Function.Equiv.isEquivalence α β)

private def extfunApp (f : Quotient <| funSetoid α β) (x : α) : β x :=
  Quot.liftOn f
    (fun (f : ∀ (x : α), β x) => f x)
    (fun f₁ f₂ h => h x)

theorem funext {f₁ f₂ : ∀ (x : α), β x} (h : ∀ x, f₁ x = f₂ x) : f₁ = f₂ := by
  show extfunApp (Quotient.mk' f₁) = extfunApp (Quotient.mk' f₂)
  apply congrArg
  apply Quotient.sound
  exact h

end

instance {α : Sort u} {β : α → Sort v} [∀ a, Subsingleton (β a)] : Subsingleton (∀ a, β a) where
  allEq f₁ f₂ :=
    funext (fun a => Subsingleton.elim (f₁ a) (f₂ a))

/- Squash -/

def Squash (α : Type u) := Quot (fun (a b : α) => True)

def Squash.mk {α : Type u} (x : α) : Squash α := Quot.mk _ x

theorem Squash.ind {α : Type u} {motive : Squash α → Prop} (h : ∀ (a : α), motive (Squash.mk a)) : ∀ (q : Squash α), motive q :=
  Quot.ind h

@[inline] def Squash.lift {α β} [Subsingleton β] (s : Squash α) (f : α → β) : β :=
  Quot.lift f (fun a b _ => Subsingleton.elim _ _) s

instance : Subsingleton (Squash α) where
  allEq a b := by
    induction a using Squash.ind
    induction b using Squash.ind
    apply Quot.sound
    trivial

namespace Lean
/- Kernel reduction hints -/

/--
  When the kernel tries to reduce a term `Lean.reduceBool c`, it will invoke the Lean interpreter to evaluate `c`.
  The kernel will not use the interpreter if `c` is not a constant.
  This feature is useful for performing proofs by reflection.

  Remark: the Lean frontend allows terms of the from `Lean.reduceBool t` where `t` is a term not containing
  free variables. The frontend automatically declares a fresh auxiliary constant `c` and replaces the term with
  `Lean.reduceBool c`. The main motivation is that the code for `t` will be pre-compiled.

  Warning: by using this feature, the Lean compiler and interpreter become part of your trusted code base.
  This is extra 30k lines of code. More importantly, you will probably not be able to check your developement using
  external type checkers (e.g., Trepplein) that do not implement this feature.
  Keep in mind that if you are using Lean as programming language, you are already trusting the Lean compiler and interpreter.
  So, you are mainly losing the capability of type checking your developement using external checkers.

  Recall that the compiler trusts the correctness of all `[implementedBy ...]` and `[extern ...]` annotations.
  If an extern function is executed, then the trusted code base will also include the implementation of the associated
  foreign function.
-/
constant reduceBool (b : Bool) : Bool := b

/--
  Similar to `Lean.reduceBool` for closed `Nat` terms.

  Remark: we do not have plans for supporting a generic `reduceValue {α} (a : α) : α := a`.
  The main issue is that it is non-trivial to convert an arbitrary runtime object back into a Lean expression.
  We believe `Lean.reduceBool` enables most interesting applications (e.g., proof by reflection). -/
constant reduceNat (n : Nat) : Nat := n

axiom ofReduceBool (a b : Bool) (h : reduceBool a = b) : a = b
axiom ofReduceNat (a b : Nat) (h : reduceNat a = b)    : a = b

end Lean