/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.option.defs
! leanprover-community/mathlib commit c4658a649d216f57e99621708b09dcb3dcccbd23
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Init.Algebra.Classes

/-!
# Extra definitions on `Option`

This file defines more operations involving `Option α`. Lemmas about them are located in other
files under `Mathlib.Data.Option`.
Other basic operations on `Option` are defined in the core library.
-/

namespace Option

#align option.lift_or_get Option.liftOrGet

/-- Lifts a relation `α → β → Prop` to a relation `Option α → Option β → Prop` by just adding
`none ~ none`. -/
inductive rel (r : α → β → Prop) : Option α → Option β → Prop
| /-- If `a ~ b`, then `some a ~ some b` -/
  some {a b} : r a b → rel r (some a) (some b)
| /-- `none ~ none` -/
  none : rel r none none
#align option.rel Option.rel

/-- Traverse an object of `Option α` with a function `f : α → F β` for an applicative `F`. -/
protected def traverse.{u, v} {F : Type u → Type v} [Applicative F] {α β : Type _} (f : α → F β) :
  Option α → F (Option β)
| none => pure none
| some x => some <$> f x
#align option.traverse Option.traverse

/-- If you maybe have a monadic computation in a `[Monad m]` which produces a term of type `α`,
then there is a naturally associated way to always perform a computation in `m` which maybe
produces a result. -/
def maybe.{u, v} {m : Type u → Type v} [Monad m] {α : Type u} : Option (m α) → m (Option α)
| none => pure none
| some fn => some <$> fn
#align option.maybe Option.maybe

#align option.mmap Option.mapM
#align option.melim Option.elimM

@[deprecated getDM]
protected def getDM' [Monad m] (x : m (Option α)) (y : m α) : m α := do
  (← x).getDM y
#align option.mget_or_else Option.getDM'

variable {α : Type _} {β : Type _}

-- Porting note: Would need to add the attribute directly in `Init.Prelude`.
-- attribute [inline] Option.isSome Option.isNone

/-- An elimination principle for `Option`. It is a nondependent version of `Option.rec`. -/
@[simp]
protected def elim' (b : β) (f : α → β) : Option α → β
  | some a => f a
  | none => b

#align option.elim Option.elim'

theorem mem_some_iff {α : Type _} {a b : α} : a ∈ some b ↔ b = a := by simp
#align option.mem_some_iff Option.mem_some_iff

/-- `o = none` is decidable even if the wrapped type does not have decidable equality.
This is not an instance because it is not definitionally equal to `Option.decidableEq`.
Try to use `o.isNone` or `o.isSome` instead.
-/
@[inline]
def decidableEqNone {o : Option α} : Decidable (o = none) :=
  decidable_of_decidable_of_iff isNone_iff_eq_none
#align option.decidable_eq_none Option.decidableEqNone

instance decidableForallMem {p : α → Prop} [DecidablePred p] :
    ∀ o : Option α, Decidable (∀ a ∈ o, p a)
  | none => isTrue (by simp [false_imp_iff])
  | some a =>
      if h : p a then isTrue fun o e ↦ some_inj.1 e ▸ h
      else isFalse <| mt (fun H ↦ H _ rfl) h

instance decidableExistsMem {p : α → Prop} [DecidablePred p] :
    ∀ o : Option α, Decidable (∃ a ∈ o, p a)
  | none => isFalse fun ⟨a, ⟨h, _⟩⟩ ↦ by cases h
  | some a => if h : p a then isTrue <| ⟨_, rfl, h⟩ else isFalse fun ⟨_, ⟨rfl, hn⟩⟩ ↦ h hn

/-- Inhabited `get` function. Returns `a` if the input is `some a`, otherwise returns `default`. -/
@[reducible]
def iget [Inhabited α] : Option α → α
  | some x => x
  | none => default
#align option.iget Option.iget

theorem iget_some [Inhabited α] {a : α} : (some a).iget = a :=
  rfl
#align option.iget_some Option.iget_some

@[simp]
theorem mem_toList {a : α} {o : Option α} : a ∈ toList o ↔ a ∈ o := by
  cases o <;> simp [toList, eq_comm]

#align option.mem_to_list Option.mem_toList

instance liftOrGet_isCommutative (f : α → α → α) [IsCommutative α f] :
    IsCommutative (Option α) (liftOrGet f) :=
  ⟨fun a b ↦ by cases a <;> cases b <;> simp [liftOrGet, IsCommutative.comm]⟩

instance liftOrGet_isAssociative (f : α → α → α) [IsAssociative α f] :
    IsAssociative (Option α) (liftOrGet f) :=
  ⟨fun a b c ↦ by cases a <;> cases b <;> cases c <;> simp [liftOrGet, IsAssociative.assoc]⟩

instance liftOrGet_isIdempotent (f : α → α → α) [IsIdempotent α f] :
    IsIdempotent (Option α) (liftOrGet f) :=
  ⟨fun a ↦ by cases a <;> simp [liftOrGet, IsIdempotent.idempotent]⟩

instance liftOrGet_isLeftId (f : α → α → α) : IsLeftId (Option α) (liftOrGet f) none :=
  ⟨fun a ↦ by cases a <;> simp [liftOrGet]⟩

instance liftOrGet_isRightId (f : α → α → α) : IsRightId (Option α) (liftOrGet f) none :=
  ⟨fun a ↦ by cases a <;> simp [liftOrGet]⟩

#align option.lift_or_get_comm Option.liftOrGet_isCommutative
#align option.lift_or_get_assoc Option.liftOrGet_isAssociative
#align option.lift_or_get_idem Option.liftOrGet_isIdempotent
#align option.lift_or_get_is_left_id Option.liftOrGet_isLeftId
#align option.lift_or_get_is_right_id Option.liftOrGet_isRightId


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import measure_theory.measure.measure_space_def
import tactic.auto_cases
import tactic.tidy
import tactic.with_local_reducibility
/-!
# Tactics for measure theory

Currently we have one domain-specific tactic for measure theory: `measurability`.

This tactic is to a large extent a copy of the `continuity` tactic by Reid Barton.
-/

/-!
### `measurability` tactic

Automatically solve goals of the form `measurable f`, `ae_measurable f μ` and `measurable_set s`.

Mark lemmas with `@[measurability]` to add them to the set of lemmas
used by `measurability`. Note: `to_additive` doesn't know yet how to
copy the attribute to the additive version.
-/

/-- User attribute used to mark tactics used by `measurability`. -/
@[user_attribute]
meta def measurability : user_attribute :=
{ name := `measurability,
  descr := "lemmas usable to prove (ae)-measurability" }

/- Mark some measurability lemmas already defined in `measure_theory.measurable_space_def` and
`measure_theory.measure_space_def` -/
attribute [measurability]
  measurable_id
  measurable_id'
  ae_measurable_id
  ae_measurable_id'
  measurable_const
  ae_measurable_const
  ae_measurable.measurable_mk
  measurable_set.empty
  measurable_set.univ
  measurable_set.compl
  subsingleton.measurable_set
  measurable_set.Union
  measurable_set.Inter
  measurable_set.Union_Prop
  measurable_set.Inter_Prop
  measurable_set.union
  measurable_set.inter
  measurable_set.diff
  measurable_set.symm_diff
  measurable_set.ite
  measurable_set.cond
  measurable_set.disjointed
  measurable_set.const
  measurable_set.insert
  measurable_set_eq
  set.finite.measurable_set
  finset.measurable_set
  set.countable.measurable_set
  measurable_space.measurable_set_top

namespace tactic

/--
Tactic to apply `measurable.comp` when appropriate.

Applying `measurable.comp` is not always a good idea, so we have some
extra logic here to try to avoid bad cases.

* If the function we're trying to prove measurable is actually
  constant, and that constant is a function application `f z`, then
  measurable.comp would produce new goals `measurable f`, `measurable
  (λ _, z)`, which is silly. We avoid this by failing if we could
  apply `measurable_const`.

* measurable.comp will always succeed on `measurable (λ x, f x)` and
  produce new goals `measurable (λ x, x)`, `measurable f`. We detect
  this by failing if a new goal can be closed by applying
  measurable_id.
-/
meta def apply_measurable.comp : tactic unit :=
`[fail_if_success { exact measurable_const };
  refine measurable.comp _ _;
  fail_if_success { exact measurable_id }]

/--
Tactic to apply `measurable.comp_ae_measurable` when appropriate.

Applying `measurable.comp_ae_measurable` is not always a good idea, so we have some
extra logic here to try to avoid bad cases.

* If the function we're trying to prove measurable is actually
  constant, and that constant is a function application `f z`, then
  `measurable.comp_ae_measurable` would produce new goals `measurable f`, `ae_measurable
  (λ _, z) μ`, which is silly. We avoid this by failing if we could
  apply `ae_measurable_const`.

* `measurable.comp_ae_measurable` will always succeed on `ae_measurable (λ x, f x) μ` and
  can produce new goals (`measurable (λ x, x)`, `ae_measurable f μ`) or
  (`measurable f`, `ae_measurable (λ x, x) μ`). We detect those by failing if a new goal can be
  closed by applying `measurable_id` or `ae_measurable_id`.
-/
meta def apply_measurable.comp_ae_measurable : tactic unit :=
`[fail_if_success { exact ae_measurable_const };
  refine measurable.comp_ae_measurable _ _;
  fail_if_success { exact measurable_id };
  fail_if_success { exact ae_measurable_id }]

/--
We don't want the intro1 tactic to apply to a goal of the form `measurable f`, `ae_measurable f μ`
or `measurable_set s`. This tactic tests the target to see if it matches that form.
 -/
meta def goal_is_not_measurable : tactic unit :=
do t ← tactic.target,
  match t with
  | `(measurable %%l) := failed
  | `(ae_measurable %%l %%r) := failed
  | `(measurable_set %%l) := failed
  | _ := skip
  end

/-- List of tactics used by `measurability` internally. -/
meta def measurability_tactics (md : transparency := semireducible) : list (tactic string) :=
[
  propositional_goal >> apply_assumption
                        >> pure "apply_assumption",
  goal_is_not_measurable >> intro1
                        >>= λ ns, pure ("intro " ++ ns.to_string),
  apply_rules [``(measurability)] 50 { md := md }
                        >> pure "apply_rules measurability",
  apply_measurable.comp >> pure "refine measurable.comp _ _",
  apply_measurable.comp_ae_measurable
                        >> pure "refine measurable.comp_ae_measurable _ _",
  `[ refine measurable.ae_measurable _ ]
                        >> pure "refine measurable.ae_measurable _"
]

namespace interactive
setup_tactic_parser

/--
Solve goals of the form `measurable f`, `ae_measurable f μ` or `measurable_set s`.
`measurability?` reports back the proof term it found.
-/
meta def measurability
  (bang : parse $ optional (tk "!")) (trace : parse $ optional (tk "?")) (cfg : tidy.cfg := {}) :
  tactic unit :=
let md                 := if bang.is_some then semireducible else reducible,
    measurability_core := tactic.tidy { tactics := measurability_tactics md, ..cfg },
    trace_fn           := if trace.is_some then show_term else id in
trace_fn measurability_core

/-- Version of `measurability` for use with auto_param. -/
meta def measurability' : tactic unit := measurability none none {}

/--
`measurability` solves goals of the form `measurable f`, `ae_measurable f μ` or `measurable_set s`
by applying lemmas tagged with the `measurability` user attribute.

You can also use `measurability!`, which applies lemmas with `{ md := semireducible }`.
The default behaviour is more conservative, and only unfolds `reducible` definitions
when attempting to match lemmas with the goal.

`measurability?` reports back the proof term it found.
-/
add_tactic_doc
{ name := "measurability / measurability'",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.measurability, `tactic.interactive.measurability'],
  tags := ["lemma application"] }

end interactive

end tactic


/-
Copyright (c) 2019 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Scott Morrison, Keeley Hoek, Robert Y. Lewis,
Floris van Doorn, E.W.Ayers, Arthur Paulino
-/
import Lean
import Std.Lean.Expr
import Std.Data.List.Basic

/-!
# Additional operations on Expr and related types

This file defines basic operations on the types expr, name, declaration, level, environment.

This file is mostly for non-tactics.
-/

namespace Lean

namespace BinderInfo

/-! ### Declarations about `BinderInfo` -/

/-- The brackets corresponding to a given `BinderInfo`. -/
def brackets : BinderInfo → String × String
| BinderInfo.implicit => ("{", "}")
| BinderInfo.strictImplicit => ("{{", "}}")
| BinderInfo.instImplicit => ("[", "]")
| _ => ("(", ")")

end BinderInfo

namespace Name

/-! ### Declarations about `name` -/

/-- Find the largest prefix `n` of a `Name` such that `f n != none`, then replace this prefix
with the value of `f n`. -/
def mapPrefix (f : Name → Option Name) (n : Name) : Name := Id.run do
  if let some n' := f n then return n'
  match n with
  | anonymous => anonymous
  | str n' s => mkStr (mapPrefix f n') s
  | num n' i => mkNum (mapPrefix f n') i

/-- Build a name from components. For example ``from_components [`foo, `bar]`` becomes
  ``` `foo.bar```.
  It is the inverse of `Name.components` on list of names that have single components. -/
def fromComponents : List Name → Name := go .anonymous where
  /-- Auxiliary for `Name.fromComponents` -/
  go : Name → List Name → Name
  | n, []        => n
  | n, s :: rest => go (s.updatePrefix n) rest

/-- Update the last component of a name. -/
def updateLast (f : String → String) : Name → Name
| .str n s => .str n (f s)
| n        => n

/-- Get the last field of a name as a string.
Doesn't raise an error when the last component is a numeric field. -/
def getString : Name → String
| .str _ s => s
| .num _ n => toString n
| .anonymous => ""

/-- `nm.splitAt n` splits a name `nm` in two parts, such that the *second* part has depth `n`, i.e.
  `(nm.splitAt n).2.getNumParts = n` (assuming `nm.getNumParts ≥ n`).
  Example: ``splitAt `foo.bar.baz.back.bat 1 = (`foo.bar.baz.back, `bat)``. -/
def splitAt (nm : Name) (n : Nat) : Name × Name :=
  let (nm2, nm1) := (nm.componentsRev.splitAt n)
  (.fromComponents <| nm1.reverse, .fromComponents <| nm2.reverse)

/-- `isPrefixOf? pre nm` returns `some post` if `nm = pre ++ post`.
  Note that this includes the case where `nm` has multiple more namespaces.
  If `pre` is not a prefix of `nm`, it returns `none`. -/
def isPrefixOf? (pre nm : Name) : Option Name :=
  if pre == nm then
    some anonymous
  else match nm with
  | anonymous => none
  | num p' a => (isPrefixOf? pre p').map (·.num a)
  | str p' s => (isPrefixOf? pre p').map (·.str s)

/-- Lean 4 makes declarations which are technically not internal
(that is, head string does not start with `_`) but which sometimes should
be treated as such. For example, the `to_additive` attribute needs to
transform `proof_1` constants generated by `Lean.Meta.mkAuxDefinitionFor`.
This might be better fixed in core, but until then, this method can act
as a polyfill. This method only looks at the name to decide whether it is probably internal.
Note: this declaration also occurs as `shouldIgnore` in the Lean 4 file `test/lean/run/printDecls`.
-/
def isInternal' (declName : Name) : Bool :=
  declName.isInternal ||
  match declName with
  | .str _ s => "match_".isPrefixOf s || "proof_".isPrefixOf s || "eq_".isPrefixOf s
  | _        => true

end Name

namespace ConstantInfo

/-- Checks whether this `ConstantInfo` is a definition, -/
def isDef : ConstantInfo → Bool
  | defnInfo _ => true
  | _          => false

/-- Checks whether this `ConstantInfo` is a theorem, -/
def isThm : ConstantInfo → Bool
  | thmInfo _ => true
  | _          => false

/-- Update `ConstantVal` (the data common to all constructors of `ConstantInfo`)
in a `ConstantInfo`. -/
def updateConstantVal : ConstantInfo → ConstantVal → ConstantInfo
  | defnInfo   info, v => defnInfo   {info with toConstantVal := v}
  | axiomInfo  info, v => axiomInfo  {info with toConstantVal := v}
  | thmInfo    info, v => thmInfo    {info with toConstantVal := v}
  | opaqueInfo info, v => opaqueInfo {info with toConstantVal := v}
  | quotInfo   info, v => quotInfo   {info with toConstantVal := v}
  | inductInfo info, v => inductInfo {info with toConstantVal := v}
  | ctorInfo   info, v => ctorInfo   {info with toConstantVal := v}
  | recInfo    info, v => recInfo    {info with toConstantVal := v}

/-- Update the name of a `ConstantInfo`. -/
def updateName (c : ConstantInfo) (name : Name) : ConstantInfo :=
  c.updateConstantVal {c.toConstantVal with name}

/-- Update the type of a `ConstantInfo`. -/
def updateType (c : ConstantInfo) (type : Expr) : ConstantInfo :=
  c.updateConstantVal {c.toConstantVal with type}

/-- Update the level parameters of a `ConstantInfo`. -/
def updateLevelParams (c : ConstantInfo) (levelParams : List Name) :
  ConstantInfo :=
  c.updateConstantVal {c.toConstantVal with levelParams}

/-- Update the value of a `ConstantInfo`, if it has one. -/
def updateValue : ConstantInfo → Expr → ConstantInfo
  | defnInfo   info, v => defnInfo   {info with value := v}
  | thmInfo    info, v => thmInfo    {info with value := v}
  | opaqueInfo info, v => opaqueInfo {info with value := v}
  | d, _ => d

/-- Turn a `ConstantInfo` into a declaration. -/
def toDeclaration! : ConstantInfo → Declaration
  | defnInfo   info => Declaration.defnDecl info
  | thmInfo    info => Declaration.thmDecl     info
  | axiomInfo  info => Declaration.axiomDecl   info
  | opaqueInfo info => Declaration.opaqueDecl  info
  | quotInfo   _ => panic! "toDeclaration for quotInfo not implemented"
  | inductInfo _ => panic! "toDeclaration for inductInfo not implemented"
  | ctorInfo   _ => panic! "toDeclaration for ctorInfo not implemented"
  | recInfo    _ => panic! "toDeclaration for recInfo not implemented"

end ConstantInfo

open Meta

/-- Same as `mkConst`, but with fresh level metavariables. -/
def mkConst' (constName : Name) : MetaM Expr := do
  return mkConst constName (← (← getConstInfo constName).levelParams.mapM fun _ => mkFreshLevelMVar)

namespace Expr

/-! ### Declarations about `Expr` -/

/-- If the expression is a constant, return that name. Otherwise return `Name.anonymous`. -/
def constName (e : Expr) : Name :=
  e.constName?.getD Name.anonymous

def bvarIdx? : Expr → Option Nat
  | bvar idx => some idx
  | _        => none

/-- Return the function (name) and arguments of an application. -/
def getAppFnArgs (e : Expr) : Name × Array Expr :=
  withApp e λ e a => (e.constName, a)

/-- Turn an expression that is a natural number literal into a natural number. -/
def natLit! : Expr → Nat
  | lit (Literal.natVal v) => v
  | _                      => panic! "nat literal expected"

/-- If an `Expr` has form `.fvar n`, then returns `some n`, otherwise `none`. -/
def fvarId? : Expr → Option FVarId
  | .fvar n => n
  | _ => none

/-- `isConstantApplication e` checks whether `e` is syntactically an application of the form
  `(fun x₁ ⋯ xₙ => H) y₁ ⋯ yₙ` where `H` does not contain the variable `xₙ`. In other words,
  it does a syntactic check that the expression does not depend on `yₙ`. -/
def isConstantApplication (e : Expr) :=
e.isApp && aux e.getAppNumArgs'.pred e.getAppFn' e.getAppNumArgs'
where
  /-- `aux depth e n` checks whether the body of the `n`-th lambda of `e` has loose bvar
    `depth - 1`. -/
  aux (depth : Nat) : Expr → Nat → Bool
  | .lam _ _ b _, n + 1  => aux depth b n
  | e, 0  => !e.hasLooseBVar (depth - 1)
  | _, _ => false

open Meta

/-- Check that an expression contains no metavariables (after instantiation). -/
-- There is a `TacticM` level version of this, but it's useful to have in `MetaM`.
def ensureHasNoMVars (e : Expr) : MetaM Unit := do
  let e ← instantiateMVars e
  if e.hasExprMVar then
    throwError "tactic failed, resulting expression contains metavariables{indentExpr e}"

/-- Construct the term of type `α` for a given natural number
(doing typeclass search for the `OfNat` instance required). -/
def ofNat (α : Expr) (n : Nat) : MetaM Expr := do
  mkAppOptM ``OfNat.ofNat #[α, mkRawNatLit n, none]

/-- Construct the term of type `α` for a given integer
(doing typeclass search for the `OfNat` and `Neg` instances required). -/
def ofInt (α : Expr) : Int → MetaM Expr
| Int.ofNat n => Expr.ofNat α n
| Int.negSucc n => do mkAppM ``Neg.neg #[← Expr.ofNat α (n+1)]

/--
  Return `some n` if `e` is one of the following
  - A nat literal (numeral)
  - `Nat.zero`
  - `Nat.succ x` where `isNumeral x`
  - `OfNat.ofNat _ x _` where `isNumeral x` -/
partial def numeral? (e : Expr) : Option Nat :=
  if let some n := e.natLit? then n
  else
    let f := e.getAppFn
    if !f.isConst then none
    else
      let fName := f.constName!
      if fName == ``Nat.succ && e.getAppNumArgs == 1 then (numeral? e.appArg!).map Nat.succ
      else if fName == ``OfNat.ofNat && e.getAppNumArgs == 3 then numeral? (e.getArg! 1)
      else if fName == ``Nat.zero && e.getAppNumArgs == 0 then some 0
      else none

/-- Test if an expression is either `Nat.zero`, or `OfNat.ofNat 0`. -/
def zero? (e : Expr) : Bool :=
  match e.numeral? with
  | some 0 => true
  | _ => false

def modifyAppArgM [Functor M] [Pure M] (modifier : Expr → M Expr) : Expr → M Expr
  | app f a => mkApp f <$> modifier a
  | e => pure e

def modifyAppArg (modifier : Expr → Expr) : Expr → Expr :=
  modifyAppArgM (M := Id) modifier

def modifyRevArg (modifier : Expr → Expr): Nat → Expr  → Expr
  | 0 => modifyAppArg modifier
  | (i+1) => modifyAppArg (modifyRevArg modifier i)

/-- Given `f a₀ a₁ ... aₙ₋₁`, runs `modifier` on the `i`th argument or
returns the original expression if out of bounds. -/
def modifyArg (modifier : Expr → Expr) (e : Expr) (i : Nat) (n := e.getAppNumArgs) : Expr :=
  modifyRevArg modifier (n - i - 1) e

def getRevArg? : Expr → Nat → Option Expr
  | app _ a, 0   => a
  | app f _, i+1 => getRevArg! f i
  | _,       _   => none

/-- Given `f a₀ a₁ ... aₙ₋₁`, returns the `i`th argument or none if out of bounds. -/
def getArg? (e : Expr) (i : Nat) (n := e.getAppNumArgs): Option Expr :=
  getRevArg? e (n - i - 1)

/-- Given `f a₀ a₁ ... aₙ₋₁`, runs `modifier` on the `i`th argument.
An argument `n` may be provided which says how many arguments we are expecting `e` to have. -/
def modifyArgM [Monad M] (modifier : Expr → M Expr) (e : Expr) (i : Nat) (n := e.getAppNumArgs) :
    M Expr := do
  let some a := getArg? e i | return e
  let a ← modifier a
  return modifyArg (fun _ ↦ a) e i n

/-- Traverses an expression `e` and renames bound variables named `old` to `new`. -/
def renameBVar (e : Expr) (old new : Name) : Expr :=
  match e with
  | app fn arg => app (fn.renameBVar old new) (arg.renameBVar old new)
  | lam n ty bd bi =>
    lam (if n == old then new else n) (ty.renameBVar old new) (bd.renameBVar old new) bi
  | forallE n ty bd bi =>
    forallE (if n == old then new else n) (ty.renameBVar old new) (bd.renameBVar old new) bi
  | e => e

open Lean.Meta in
/-- `getBinderName e` returns `some n` if `e` is an expression of the form `∀ n, ...`
and `none` otherwise. -/
def getBinderName (e : Expr) : MetaM (Option Name) := do
  match ← withReducible (whnf e) with
  | .forallE (binderName := n) .. | .lam (binderName := n) .. => pure (some n)
  | _ => pure none

open Lean.Elab.Term
/-- Annotates a `binderIdent` with the binder information from an `fvar`. -/
def addLocalVarInfoForBinderIdent (fvar : Expr) : TSyntax ``binderIdent → TermElabM Unit
| `(binderIdent| $n:ident) => Elab.Term.addLocalVarInfo n fvar
| tk => Elab.Term.addLocalVarInfo (Unhygienic.run `(_%$tk)) fvar

/-- If `e` has a structure as type with field `fieldName`, `mkDirectProjection e fieldName` creates
the projection expression `e.fieldName` -/
def mkDirectProjection (e : Expr) (fieldName : Name) : MetaM Expr := do
  let type ← whnf (← inferType e)
  let .const structName us := type.getAppFn | throwError "{e} doesn't have a structure as type"
  let some projName := getProjFnForField? (← getEnv) structName fieldName |
    throwError "{structName} doesn't have field {fieldName}"
  return mkAppN (.const projName us) (type.getAppArgs.push e)

/-- If `e` has a structure as type with field `fieldName` (either directly or in a parent
structure), `mkProjection e fieldName` creates the projection expression `e.fieldName` -/
def mkProjection (e : Expr) (fieldName : Name) : MetaM Expr := do
  let .const structName _ := (← whnf (←inferType e)).getAppFn |
    throwError "{e} doesn't have a structure as type"
  let some baseStruct := findField? (← getEnv) structName fieldName |
    throwError "No parent of {structName} has field {fieldName}"
  let mut e := e
  for projName in (getPathToBaseStructure? (← getEnv) baseStruct structName).get! do
    let type ← whnf (← inferType e)
    let .const _structName us := type.getAppFn | throwError "{e} doesn't have a structure as type"
    e := mkAppN (.const projName us) (type.getAppArgs.push e)
  mkDirectProjection e fieldName

end Expr

/-- Get the projections that are projections to parent structures. Similar to `getParentStructures`,
  except that this returns the (last component of the) projection names instead of the parent names.
-/
def getFieldsToParents (env : Environment) (structName : Name) : Array Name :=
  getStructureFields env structName |>.filter fun fieldName =>
    isSubobjectField? env structName fieldName |>.isSome

end Lean


/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.sigma
import Mathlib.PostPort

universes u v l w

namespace Mathlib

/-!
# Association lists
-/

/-- `alist β` is a key-value map stored as a `list` (i.e. a linked list).
  It is a wrapper around certain `list` functions with the added constraint
  that the list have unique keys. -/
structure alist {α : Type u} (β : α → Type v)
where
  entries : List (sigma β)
  nodupkeys : list.nodupkeys entries

/-- Given `l : list (sigma β)`, create a term of type `alist β` by removing
entries with duplicate keys. -/
def list.to_alist {α : Type u} [DecidableEq α] {β : α → Type v} (l : List (sigma β)) : alist β :=
  alist.mk (list.erase_dupkeys l) sorry

namespace alist

theorem ext {α : Type u} {β : α → Type v} {s : alist β} {t : alist β} : entries s = entries t → s = t := sorry

theorem ext_iff {α : Type u} {β : α → Type v} {s : alist β} {t : alist β} : s = t ↔ entries s = entries t :=
  { mp := congr_arg fun {s : alist β} => entries s, mpr := ext }

protected instance decidable_eq {α : Type u} {β : α → Type v} [DecidableEq α] [(a : α) → DecidableEq (β a)] : DecidableEq (alist β) :=
  fun (xs ys : alist β) => eq.mpr sorry (list.decidable_eq (entries xs) (entries ys))

/-! ### keys -/

/-- The list of keys of an association list. -/
def keys {α : Type u} {β : α → Type v} (s : alist β) : List α :=
  list.keys (entries s)

theorem keys_nodup {α : Type u} {β : α → Type v} (s : alist β) : list.nodup (keys s) :=
  nodupkeys s

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
protected instance has_mem {α : Type u} {β : α → Type v} : has_mem α (alist β) :=
  has_mem.mk fun (a : α) (s : alist β) => a ∈ keys s

theorem mem_keys {α : Type u} {β : α → Type v} {a : α} {s : alist β} : a ∈ s ↔ a ∈ keys s :=
  iff.rfl

theorem mem_of_perm {α : Type u} {β : α → Type v} {a : α} {s₁ : alist β} {s₂ : alist β} (p : entries s₁ ~ entries s₂) : a ∈ s₁ ↔ a ∈ s₂ :=
  list.perm.mem_iff (list.perm.map sigma.fst p)

/-! ### empty -/

/-- The empty association list. -/
protected instance has_emptyc {α : Type u} {β : α → Type v} : has_emptyc (alist β) :=
  has_emptyc.mk (mk [] list.nodupkeys_nil)

protected instance inhabited {α : Type u} {β : α → Type v} : Inhabited (alist β) :=
  { default := ∅ }

theorem not_mem_empty {α : Type u} {β : α → Type v} (a : α) : ¬a ∈ ∅ :=
  list.not_mem_nil a

@[simp] theorem empty_entries {α : Type u} {β : α → Type v} : entries ∅ = [] :=
  rfl

@[simp] theorem keys_empty {α : Type u} {β : α → Type v} : keys ∅ = [] :=
  rfl

/-! ### singleton -/

/-- The singleton association list. -/
def singleton {α : Type u} {β : α → Type v} (a : α) (b : β a) : alist β :=
  mk [sigma.mk a b] sorry

@[simp] theorem singleton_entries {α : Type u} {β : α → Type v} (a : α) (b : β a) : entries (singleton a b) = [sigma.mk a b] :=
  rfl

@[simp] theorem keys_singleton {α : Type u} {β : α → Type v} (a : α) (b : β a) : keys (singleton a b) = [a] :=
  rfl

/-! ### lookup -/

/-- Look up the value associated to a key in an association list. -/
def lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : Option (β a) :=
  list.lookup a (entries s)

@[simp] theorem lookup_empty {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : lookup a ∅ = none :=
  rfl

theorem lookup_is_some {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : alist β} : ↥(option.is_some (lookup a s)) ↔ a ∈ s :=
  list.lookup_is_some

theorem lookup_eq_none {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : alist β} : lookup a s = none ↔ ¬a ∈ s :=
  list.lookup_eq_none

theorem perm_lookup {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β} {s₂ : alist β} (p : entries s₁ ~ entries s₂) : lookup a s₁ = lookup a s₂ :=
  list.perm_lookup a (nodupkeys s₁) (nodupkeys s₂) p

protected instance has_mem.mem.decidable {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : Decidable (a ∈ s) :=
  decidable_of_iff ↥(option.is_some (lookup a s)) sorry

/-! ### replace -/

/-- Replace a key with a given value in an association list.
  If the key is not present it does nothing. -/
def replace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (s : alist β) : alist β :=
  mk (list.kreplace a b (entries s)) sorry

@[simp] theorem keys_replace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (s : alist β) : keys (replace a b s) = keys s :=
  list.keys_kreplace a b (entries s)

@[simp] theorem mem_replace {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b : β a} {s : alist β} : a' ∈ replace a b s ↔ a' ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ replace a b s ↔ a' ∈ s)) (propext mem_keys)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ keys (replace a b s) ↔ a' ∈ s)) (keys_replace a b s)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ keys s ↔ a' ∈ s)) (Eq.symm (propext mem_keys)))) (iff.refl (a' ∈ s))))

theorem perm_replace {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β} {s₂ : alist β} : entries s₁ ~ entries s₂ → entries (replace a b s₁) ~ entries (replace a b s₂) :=
  list.perm.kreplace (nodupkeys s₁)

/-- Fold a function over the key-value pairs in the map. -/
def foldl {α : Type u} {β : α → Type v} {δ : Type w} (f : δ → (a : α) → β a → δ) (d : δ) (m : alist β) : δ :=
  list.foldl (fun (r : δ) (a : sigma β) => f r (sigma.fst a) (sigma.snd a)) d (entries m)

/-! ### erase -/

/-- Erase a key from the map. If the key is not present, do nothing. -/
def erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : alist β :=
  mk (list.kerase a (entries s)) sorry

@[simp] theorem keys_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : keys (erase a s) = list.erase (keys s) a := sorry

@[simp] theorem mem_erase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {s : alist β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s := sorry

theorem perm_erase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β} {s₂ : alist β} : entries s₁ ~ entries s₂ → entries (erase a s₁) ~ entries (erase a s₂) :=
  list.perm.kerase (nodupkeys s₁)

@[simp] theorem lookup_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : lookup a (erase a s) = none :=
  list.lookup_kerase a (nodupkeys s)

@[simp] theorem lookup_erase_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {s : alist β} (h : a ≠ a') : lookup a (erase a' s) = lookup a s :=
  list.lookup_kerase_ne h

theorem erase_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (a' : α) (s : alist β) : erase a' (erase a s) = erase a (erase a' s) :=
  ext list.kerase_kerase

/-! ### insert -/

/-- Insert a key-value pair into an association list and erase any existing pair
  with the same key. -/
def insert {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (s : alist β) : alist β :=
  mk (list.kinsert a b (entries s)) sorry

@[simp] theorem insert_entries {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s : alist β} : entries (insert a b s) = sigma.mk a b :: list.kerase a (entries s) :=
  rfl

theorem insert_entries_of_neg {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s : alist β} (h : ¬a ∈ s) : entries (insert a b s) = sigma.mk a b :: entries s := sorry

@[simp] theorem mem_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b' : β a'} (s : alist β) : a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
  list.mem_keys_kinsert

@[simp] theorem keys_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} (s : alist β) : keys (insert a b s) = a :: list.erase (keys s) a := sorry

theorem perm_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β} {s₂ : alist β} (p : entries s₁ ~ entries s₂) : entries (insert a b s₁) ~ entries (insert a b s₂) := sorry

@[simp] theorem lookup_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} (s : alist β) : lookup a (insert a b s) = some b := sorry

@[simp] theorem lookup_insert_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b' : β a'} {s : alist β} (h : a ≠ a') : lookup a (insert a' b' s) = lookup a s :=
  list.lookup_kinsert_ne h

@[simp] theorem lookup_to_alist {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} (s : List (sigma β)) : lookup a (list.to_alist s) = list.lookup a s := sorry

@[simp] theorem insert_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {b' : β a} (s : alist β) : insert a b' (insert a b s) = insert a b' s := sorry

theorem insert_insert_of_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b : β a} {b' : β a'} (s : alist β) (h : a ≠ a') : entries (insert a' b' (insert a b s)) ~ entries (insert a b (insert a' b' s)) := sorry

@[simp] theorem insert_singleton_eq {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {b' : β a} : insert a b (singleton a b') = singleton a b := sorry

@[simp] theorem entries_to_alist {α : Type u} {β : α → Type v} [DecidableEq α] (xs : List (sigma β)) : entries (list.to_alist xs) = list.erase_dupkeys xs :=
  rfl

theorem to_alist_cons {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (xs : List (sigma β)) : list.to_alist (sigma.mk a b :: xs) = insert a b (list.to_alist xs) :=
  rfl

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : Option (β a) × alist β :=
  (fun (this : list.nodupkeys (prod.snd (list.kextract a (entries s)))) => sorry) sorry

@[simp] theorem extract_eq_lookup_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : extract a s = (lookup a s, erase a s) := sorry

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two association lists. It is
left-biased: if there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`.
-/
def union {α : Type u} {β : α → Type v} [DecidableEq α] (s₁ : alist β) (s₂ : alist β) : alist β :=
  mk (list.kunion (entries s₁) (entries s₂)) sorry

protected instance has_union {α : Type u} {β : α → Type v} [DecidableEq α] : has_union (alist β) :=
  has_union.mk union

@[simp] theorem union_entries {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β} {s₂ : alist β} : entries (s₁ ∪ s₂) = list.kunion (entries s₁) (entries s₂) :=
  rfl

@[simp] theorem empty_union {α : Type u} {β : α → Type v} [DecidableEq α] {s : alist β} : ∅ ∪ s = s :=
  ext rfl

@[simp] theorem union_empty {α : Type u} {β : α → Type v} [DecidableEq α] {s : alist β} : s ∪ ∅ = s := sorry

@[simp] theorem mem_union {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β} {s₂ : alist β} : a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
  list.mem_keys_kunion

theorem perm_union {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β} {s₂ : alist β} {s₃ : alist β} {s₄ : alist β} (p₁₂ : entries s₁ ~ entries s₂) (p₃₄ : entries s₃ ~ entries s₄) : entries (s₁ ∪ s₃) ~ entries (s₂ ∪ s₄) := sorry

theorem union_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s₁ : alist β) (s₂ : alist β) : erase a (s₁ ∪ s₂) = erase a s₁ ∪ erase a s₂ :=
  ext (Eq.symm list.kunion_kerase)

@[simp] theorem lookup_union_left {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β} {s₂ : alist β} : a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
  list.lookup_kunion_left

@[simp] theorem lookup_union_right {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β} {s₂ : alist β} : ¬a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
  list.lookup_kunion_right

@[simp] theorem mem_lookup_union {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β} {s₂ : alist β} : b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ ¬a ∈ s₁ ∧ b ∈ lookup a s₂ :=
  list.mem_lookup_kunion

theorem mem_lookup_union_middle {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β} {s₂ : alist β} {s₃ : alist β} : b ∈ lookup a (s₁ ∪ s₃) → ¬a ∈ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
  list.mem_lookup_kunion_middle

theorem insert_union {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β} {s₂ : alist β} : insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ := sorry

theorem union_assoc {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β} {s₂ : alist β} {s₃ : alist β} : entries (s₁ ∪ s₂ ∪ s₃) ~ entries (s₁ ∪ (s₂ ∪ s₃)) := sorry

/-! ### disjoint -/

/-- Two associative lists are disjoint if they have no common keys. -/
def disjoint {α : Type u} {β : α → Type v} (s₁ : alist β) (s₂ : alist β) :=
  ∀ (k : α), k ∈ keys s₁ → ¬k ∈ keys s₂

theorem union_comm_of_disjoint {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β} {s₂ : alist β} (h : disjoint s₁ s₂) : entries (s₁ ∪ s₂) ~ entries (s₂ ∪ s₁) := sorry


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

Lemmas about traversing collections.

Inspired by:

    The Essence of the Iterator Pattern
    Jeremy Gibbons and Bruno César dos Santos Oliveira
    In Journal of Functional Programming. Vol. 19. No. 3&4. Pages 377−402. 2009.
    <http://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf>
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.basic
import Mathlib.control.applicative
import Mathlib.PostPort

universes u

namespace Mathlib

namespace traversable

/-- The natural applicative transformation from the identity functor
to `F`, defined by `pure : Π {α}, α → F α`. -/
def pure_transformation (F : Type u → Type u) [Applicative F] [is_lawful_applicative F] :
    applicative_transformation id F :=
  applicative_transformation.mk pure sorry sorry

@[simp] theorem pure_transformation_apply (F : Type u → Type u) [Applicative F]
    [is_lawful_applicative F] {α : Type u} (x : id α) :
    coe_fn (pure_transformation F) α x = pure x :=
  rfl

theorem map_eq_traverse_id {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {β : Type u} {γ : Type u} (f : β → γ) : Functor.map f = traverse (id.mk ∘ f) :=
  funext fun (y : t β) => Eq.symm (is_lawful_traversable.traverse_eq_map_id f y)

theorem map_traverse {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} [Applicative F] [is_lawful_applicative F] {α : Type u} {β : Type u}
    {γ : Type u} (g : α → F β) (f : β → γ) (x : t α) :
    Functor.map f <$> traverse g x = traverse (Functor.map f ∘ g) x :=
  sorry

theorem traverse_map {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} [Applicative F] [is_lawful_applicative F] {α : Type u} {β : Type u}
    {γ : Type u} (f : β → F γ) (g : α → β) (x : t α) : traverse f (g <$> x) = traverse (f ∘ g) x :=
  sorry

theorem pure_traverse {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} [Applicative F] [is_lawful_applicative F] {α : Type u} (x : t α) :
    traverse pure x = pure x :=
  eq.mp
    (Eq._oldrec (Eq.refl (traverse pure x = pure (traverse id.mk x)))
      (is_lawful_traversable.id_traverse x))
    (Eq.symm (is_lawful_traversable.naturality (pure_transformation F) id.mk x))

theorem id_sequence {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {α : Type u}
    (x : t α) : sequence (id.mk <$> x) = id.mk x :=
  sorry

theorem comp_sequence {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F]
    [Applicative G] [is_lawful_applicative G] {α : Type u} (x : t (F (G α))) :
    sequence (functor.comp.mk <$> x) = functor.comp.mk (sequence <$> sequence x) :=
  sorry

theorem naturality' {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F]
    [Applicative G] [is_lawful_applicative G] {α : Type u} (η : applicative_transformation F G)
    (x : t (F α)) : coe_fn η (t α) (sequence x) = sequence (coe_fn η α <$> x) :=
  sorry

theorem traverse_id {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {α : Type u} :
    traverse id.mk = id.mk :=
  sorry

theorem traverse_comp {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F]
    [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u} {γ : Type u} (g : α → F β)
    (h : β → G γ) :
    traverse (functor.comp.mk ∘ Functor.map h ∘ g) =
        functor.comp.mk ∘ Functor.map (traverse h) ∘ traverse g :=
  sorry

theorem traverse_eq_map_id' {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {β : Type u} {γ : Type u} (f : β → γ) : traverse (id.mk ∘ f) = id.mk ∘ Functor.map f :=
  sorry

-- @[functor_norm]

theorem traverse_map' {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {G : Type u → Type u} [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u}
    {γ : Type u} (g : α → β) (h : β → G γ) : traverse (h ∘ g) = traverse h ∘ Functor.map g :=
  sorry

theorem map_traverse' {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {G : Type u → Type u} [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u}
    {γ : Type u} (g : α → G β) (h : β → γ) :
    traverse (Functor.map h ∘ g) = Functor.map (Functor.map h) ∘ traverse g :=
  sorry

theorem naturality_pf {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F]
    [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u}
    (η : applicative_transformation F G) (f : α → F β) :
    traverse (coe_fn η β ∘ f) = coe_fn η (t β) ∘ traverse f :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

/-!
# solve_by_elim

A depth-first search backwards reasoner.

`solve_by_elim` takes a list of lemmas, and repeating tries to `apply` these against
the goals, recursively acting on any generated subgoals.

It accepts a variety of configuration options described below, enabling
* backtracking across multiple goals,
* pruning the search tree, and
* invoking other tactics before or after trying to apply lemmas.

At present it has no "premise selection", and simply tries the supplied lemmas in order
at each step of the search.
-/

namespace tactic

namespace solve_by_elim

/--
`mk_assumption_set` builds a collection of lemmas for use in
the backtracking search in `solve_by_elim`.

* By default, it includes all local hypotheses, along with `rfl`, `trivial`, `congr_fun` and
  `congr_arg`.
* The flag `no_dflt` removes these.
* The argument `hs` is a list of `simp_arg_type`s,
  and can be used to add, or remove, lemmas or expressions from the set.
* The argument `attr : list name` adds all lemmas tagged with one of a specified list of attributes.

`mk_assumption_set` returns not a `list expr`, but a `list (tactic expr) × tactic (list expr)`.
There are two separate problems that need to be solved.

### Relevant local hypotheses

`solve_by_elim*` works with multiple goals,
and we need to use separate sets of local hypotheses for each goal.
The second component of the returned value provides these local hypotheses.
(Essentially using `local_context`, along with some filtering to remove hypotheses
that have been explicitly removed via `only` or `[-h]`.)

### Stuck metavariables

Lemmas with implicit arguments would be filled in with metavariables if we created the
`expr` objects immediately, so instead we return thunks that generate the expressions
on demand. This is the first component, with type `list (tactic expr)`.

As an example, we have `def rfl : ∀ {α : Sort u} {a : α}, a = a`, which on elaboration will become
`@rfl ?m_1 ?m_2`.

Because `solve_by_elim` works by repeated application of lemmas against subgoals,
the first time such a lemma is successfully applied,
those metavariables will be unified, and thereafter have fixed values.
This would make it impossible to apply the lemma
a second time with different values of the metavariables.

See https://github.com/leanprover-community/mathlib/issues/2269

As an optimisation, after we build the list of `tactic expr`s, we actually run them, and replace any
that do not in fact produce metavariables with a simple `return` tactic.
-/
-- We lock the tactic state so that any spurious goals generated during

-- elaboration of pre-expressions are discarded

/--
Configuration options for `solve_by_elim`.

* `accept : list expr → tactic unit` determines whether the current branch should be explored.
   At each step, before the lemmas are applied,
   `accept` is passed the proof terms for the original goals,
   as reported by `get_goals` when `solve_by_elim` started.
   These proof terms may be metavariables (if no progress has been made on that goal)
   or may contain metavariables at some leaf nodes
   (if the goal has been partially solved by previous `apply` steps).
   If the `accept` tactic fails `solve_by_elim` aborts searching this branch and backtracks.
   By default `accept := λ _, skip` always succeeds.
   (There is an example usage in `tests/solve_by_elim.lean`.)
* `pre_apply : tactic unit` specifies an additional tactic to run before each round of `apply`.
* `discharger : tactic unit` specifies an additional tactic to apply on subgoals
  for which no lemma applies.
  If that tactic succeeds, `solve_by_elim` will continue applying lemmas on resulting goals.
-/
/--
A helper function for trace messages, prepending '....' depending on the current search depth.
-/
/-- A helper function to generate trace messages on successful applications. -/
/-- A helper function to generate trace messages on unsuccessful applications. -/
/--
A helper function to generate the tactic that print trace messages.
This function exists to ensure the target is pretty printed only as necessary.
-/
/--
The internal implementation of `solve_by_elim`, with a limiting counter.
-/
/--
Arguments for `solve_by_elim`:
* By default `solve_by_elim` operates only on the first goal,
  but with `backtrack_all_goals := true`, it operates on all goals at once,
  backtracking across goals as needed,
  and only succeeds if it discharges all goals.
* `lemmas` specifies the list of lemmas to use in the backtracking search.
  If `none`, `solve_by_elim` uses the local hypotheses,
  along with `rfl`, `trivial`, `congr_arg`, and `congr_fun`.
* `lemma_thunks` provides the lemmas as a list of `tactic expr`,
  which are used to regenerate the `expr` objects to avoid binding metavariables.
  It should not usually be specified by the user.
  (If both `lemmas` and `lemma_thunks` are specified, only `lemma_thunks` is used.)
* `ctx_thunk` is for internal use only: it returns the local hypotheses which will be used.
* `max_depth` bounds the depth of the search.
-/
/--
If no lemmas have been specified, generate the default set
(local hypotheses, along with `rfl`, `trivial`, `congr_arg`, and `congr_fun`).
-/
end solve_by_elim

/--
`solve_by_elim` repeatedly tries `apply`ing a lemma
from the list of assumptions (passed via the `opt` argument),
recursively operating on any generated subgoals, backtracking as necessary.

`solve_by_elim` succeeds only if it discharges the goal.
(By default, `solve_by_elim` focuses on the first goal, and only attempts to solve that.
With the option `backtrack_all_goals := tt`,
it attempts to solve all goals, and only succeeds if it does so.
With `backtrack_all_goals := tt`, `solve_by_elim` will backtrack a solution it has found for
one goal if it then can't discharge other goals.)

If passed an empty list of assumptions, `solve_by_elim` builds a default set
as per the interactive tactic, using the `local_context` along with
`rfl`, `trivial`, `congr_arg`, and `congr_fun`.

To pass a particular list of assumptions, use the `lemmas` field
in the configuration argument. This expects an
`option (list expr)`. In certain situations it may be necessary to instead use the
`lemma_thunks` field, which expects a `option (list (tactic expr))`.
This allows for regenerating metavariables
for each application, which might otherwise get stuck.

See also the simpler tactic `apply_rules`, which does not perform backtracking.
-/
namespace interactive

/--
`apply_assumption` looks for an assumption of the form `... → ∀ _, ... → head`
where `head` matches the current goal.

If this fails, `apply_assumption` will call `symmetry` and try again.

If this also fails, `apply_assumption` will call `exfalso` and try again,
so that if there is an assumption of the form `P → ¬ Q`, the new tactic state
will have two goals, `P` and `Q`.

Optional arguments:
- `lemmas`: a list of expressions to apply, instead of the local constants
- `tac`: a tactic to run on each subgoal after applying an assumption; if
  this tactic fails, the corresponding assumption will be rejected and
  the next one will be attempted.
-/
/--
`solve_by_elim` calls `apply` on the main goal to find an assumption whose head matches
and then repeatedly calls `apply` on the generated subgoals until no subgoals remain,
performing at most `max_depth` recursive steps.

`solve_by_elim` discharges the current goal or fails.

`solve_by_elim` performs back-tracking if subgoals can not be solved.

By default, the assumptions passed to `apply` are the local context, `rfl`, `trivial`,
`congr_fun` and `congr_arg`.

The assumptions can be modified with similar syntax as for `simp`:
* `solve_by_elim [h₁, h₂, ..., hᵣ]` also applies the named lemmas.
* `solve_by_elim with attr₁ ... attrᵣ` also applies all lemmas tagged with the specified attributes.
* `solve_by_elim only [h₁, h₂, ..., hᵣ]` does not include the local context,
  `rfl`, `trivial`, `congr_fun`, or `congr_arg` unless they are explicitly included.
* `solve_by_elim [-id_1, ... -id_n]` uses the default assumptions, removing the specified ones.

`solve_by_elim*` tries to solve all goals together, using backtracking if a solution for one goal
makes other goals impossible.

optional arguments passed via a configuration argument as `solve_by_elim { ... }`
- max_depth: number of attempts at discharging generated sub-goals
- discharger: a subsidiary tactic to try at each step when no lemmas apply
  (e.g. `cc` may be helpful).
- pre_apply: a subsidiary tactic to run at each step before applying lemmas (e.g. `intros`).
- accept: a subsidiary tactic `list expr → tactic unit` that at each step,
    before any lemmas are applied, is passed the original proof terms
    as reported by `get_goals` when `solve_by_elim` started
    (but which may by now have been partially solved by previous `apply` steps).
    If the `accept` tactic fails,
    `solve_by_elim` will abort searching the current branch and backtrack.
    This may be used to filter results, either at every step of the search,
    or filtering complete results
    (by testing for the absence of metavariables, and then the filtering condition).
-/
end Mathlib


/-
Copyright (c) 2023 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import Aesop

example : 1 = 2 → False := by
  fail_if_success
    aesop (simp_options := { enabled := false })
      (options := { terminal := true })
  aesop


/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.sigma
import Mathlib.PostPort

universes u v l w

namespace Mathlib

/-!
# Association lists
-/

/-- `alist β` is a key-value map stored as a `list` (i.e. a linked list).
  It is a wrapper around certain `list` functions with the added constraint
  that the list have unique keys. -/
structure alist {α : Type u} (β : α → Type v) where
  entries : List (sigma β)
  nodupkeys : list.nodupkeys entries

/-- Given `l : list (sigma β)`, create a term of type `alist β` by removing
entries with duplicate keys. -/
def list.to_alist {α : Type u} [DecidableEq α] {β : α → Type v} (l : List (sigma β)) : alist β :=
  alist.mk (list.erase_dupkeys l) sorry

namespace alist

theorem ext {α : Type u} {β : α → Type v} {s : alist β} {t : alist β} :
    entries s = entries t → s = t :=
  sorry

theorem ext_iff {α : Type u} {β : α → Type v} {s : alist β} {t : alist β} :
    s = t ↔ entries s = entries t :=
  { mp := congr_arg fun {s : alist β} => entries s, mpr := ext }

protected instance decidable_eq {α : Type u} {β : α → Type v} [DecidableEq α]
    [(a : α) → DecidableEq (β a)] : DecidableEq (alist β) :=
  fun (xs ys : alist β) => eq.mpr sorry (list.decidable_eq (entries xs) (entries ys))

/-! ### keys -/

/-- The list of keys of an association list. -/
def keys {α : Type u} {β : α → Type v} (s : alist β) : List α := list.keys (entries s)

theorem keys_nodup {α : Type u} {β : α → Type v} (s : alist β) : list.nodup (keys s) := nodupkeys s

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
protected instance has_mem {α : Type u} {β : α → Type v} : has_mem α (alist β) :=
  has_mem.mk fun (a : α) (s : alist β) => a ∈ keys s

theorem mem_keys {α : Type u} {β : α → Type v} {a : α} {s : alist β} : a ∈ s ↔ a ∈ keys s := iff.rfl

theorem mem_of_perm {α : Type u} {β : α → Type v} {a : α} {s₁ : alist β} {s₂ : alist β}
    (p : entries s₁ ~ entries s₂) : a ∈ s₁ ↔ a ∈ s₂ :=
  list.perm.mem_iff (list.perm.map sigma.fst p)

/-! ### empty -/

/-- The empty association list. -/
protected instance has_emptyc {α : Type u} {β : α → Type v} : has_emptyc (alist β) :=
  has_emptyc.mk (mk [] list.nodupkeys_nil)

protected instance inhabited {α : Type u} {β : α → Type v} : Inhabited (alist β) := { default := ∅ }

theorem not_mem_empty {α : Type u} {β : α → Type v} (a : α) : ¬a ∈ ∅ := list.not_mem_nil a

@[simp] theorem empty_entries {α : Type u} {β : α → Type v} : entries ∅ = [] := rfl

@[simp] theorem keys_empty {α : Type u} {β : α → Type v} : keys ∅ = [] := rfl

/-! ### singleton -/

/-- The singleton association list. -/
def singleton {α : Type u} {β : α → Type v} (a : α) (b : β a) : alist β := mk [sigma.mk a b] sorry

@[simp] theorem singleton_entries {α : Type u} {β : α → Type v} (a : α) (b : β a) :
    entries (singleton a b) = [sigma.mk a b] :=
  rfl

@[simp] theorem keys_singleton {α : Type u} {β : α → Type v} (a : α) (b : β a) :
    keys (singleton a b) = [a] :=
  rfl

/-! ### lookup -/

/-- Look up the value associated to a key in an association list. -/
def lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : Option (β a) :=
  list.lookup a (entries s)

@[simp] theorem lookup_empty {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) :
    lookup a ∅ = none :=
  rfl

theorem lookup_is_some {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : alist β} :
    ↥(option.is_some (lookup a s)) ↔ a ∈ s :=
  list.lookup_is_some

theorem lookup_eq_none {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : alist β} :
    lookup a s = none ↔ ¬a ∈ s :=
  list.lookup_eq_none

theorem perm_lookup {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β}
    {s₂ : alist β} (p : entries s₁ ~ entries s₂) : lookup a s₁ = lookup a s₂ :=
  list.perm_lookup a (nodupkeys s₁) (nodupkeys s₂) p

protected instance has_mem.mem.decidable {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    (s : alist β) : Decidable (a ∈ s) :=
  decidable_of_iff ↥(option.is_some (lookup a s)) sorry

/-! ### replace -/

/-- Replace a key with a given value in an association list.
  If the key is not present it does nothing. -/
def replace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (s : alist β) :
    alist β :=
  mk (list.kreplace a b (entries s)) sorry

@[simp] theorem keys_replace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a)
    (s : alist β) : keys (replace a b s) = keys s :=
  list.keys_kreplace a b (entries s)

@[simp] theorem mem_replace {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b : β a}
    {s : alist β} : a' ∈ replace a b s ↔ a' ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ replace a b s ↔ a' ∈ s)) (propext mem_keys)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ keys (replace a b s) ↔ a' ∈ s)) (keys_replace a b s)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ keys s ↔ a' ∈ s)) (Eq.symm (propext mem_keys))))
        (iff.refl (a' ∈ s))))

theorem perm_replace {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β}
    {s₂ : alist β} :
    entries s₁ ~ entries s₂ → entries (replace a b s₁) ~ entries (replace a b s₂) :=
  list.perm.kreplace (nodupkeys s₁)

/-- Fold a function over the key-value pairs in the map. -/
def foldl {α : Type u} {β : α → Type v} {δ : Type w} (f : δ → (a : α) → β a → δ) (d : δ)
    (m : alist β) : δ :=
  list.foldl (fun (r : δ) (a : sigma β) => f r (sigma.fst a) (sigma.snd a)) d (entries m)

/-! ### erase -/

/-- Erase a key from the map. If the key is not present, do nothing. -/
def erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) : alist β :=
  mk (list.kerase a (entries s)) sorry

@[simp] theorem keys_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) :
    keys (erase a s) = list.erase (keys s) a :=
  sorry

@[simp] theorem mem_erase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α}
    {s : alist β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
  sorry

theorem perm_erase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β}
    {s₂ : alist β} : entries s₁ ~ entries s₂ → entries (erase a s₁) ~ entries (erase a s₂) :=
  list.perm.kerase (nodupkeys s₁)

@[simp] theorem lookup_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) :
    lookup a (erase a s) = none :=
  list.lookup_kerase a (nodupkeys s)

@[simp] theorem lookup_erase_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α}
    {s : alist β} (h : a ≠ a') : lookup a (erase a' s) = lookup a s :=
  list.lookup_kerase_ne h

theorem erase_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (a' : α) (s : alist β) :
    erase a' (erase a s) = erase a (erase a' s) :=
  ext list.kerase_kerase

/-! ### insert -/

/-- Insert a key-value pair into an association list and erase any existing pair
  with the same key. -/
def insert {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (s : alist β) :
    alist β :=
  mk (list.kinsert a b (entries s)) sorry

@[simp] theorem insert_entries {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {s : alist β} : entries (insert a b s) = sigma.mk a b :: list.kerase a (entries s) :=
  rfl

theorem insert_entries_of_neg {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {s : alist β} (h : ¬a ∈ s) : entries (insert a b s) = sigma.mk a b :: entries s :=
  sorry

@[simp] theorem mem_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α}
    {b' : β a'} (s : alist β) : a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
  list.mem_keys_kinsert

@[simp] theorem keys_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    (s : alist β) : keys (insert a b s) = a :: list.erase (keys s) a :=
  sorry

theorem perm_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β}
    {s₂ : alist β} (p : entries s₁ ~ entries s₂) :
    entries (insert a b s₁) ~ entries (insert a b s₂) :=
  sorry

@[simp] theorem lookup_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    (s : alist β) : lookup a (insert a b s) = some b :=
  sorry

@[simp] theorem lookup_insert_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α}
    {b' : β a'} {s : alist β} (h : a ≠ a') : lookup a (insert a' b' s) = lookup a s :=
  list.lookup_kinsert_ne h

@[simp] theorem lookup_to_alist {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    (s : List (sigma β)) : lookup a (list.to_alist s) = list.lookup a s :=
  sorry

@[simp] theorem insert_insert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {b' : β a} (s : alist β) : insert a b' (insert a b s) = insert a b' s :=
  sorry

theorem insert_insert_of_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b : β a}
    {b' : β a'} (s : alist β) (h : a ≠ a') :
    entries (insert a' b' (insert a b s)) ~ entries (insert a b (insert a' b' s)) :=
  sorry

@[simp] theorem insert_singleton_eq {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {b' : β a} : insert a b (singleton a b') = singleton a b :=
  sorry

@[simp] theorem entries_to_alist {α : Type u} {β : α → Type v} [DecidableEq α]
    (xs : List (sigma β)) : entries (list.to_alist xs) = list.erase_dupkeys xs :=
  rfl

theorem to_alist_cons {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a)
    (xs : List (sigma β)) : list.to_alist (sigma.mk a b :: xs) = insert a b (list.to_alist xs) :=
  rfl

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s : alist β) :
    Option (β a) × alist β :=
  (fun (this : list.nodupkeys (prod.snd (list.kextract a (entries s)))) => sorry) sorry

@[simp] theorem extract_eq_lookup_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    (s : alist β) : extract a s = (lookup a s, erase a s) :=
  sorry

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two association lists. It is
left-biased: if there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`.
-/
def union {α : Type u} {β : α → Type v} [DecidableEq α] (s₁ : alist β) (s₂ : alist β) : alist β :=
  mk (list.kunion (entries s₁) (entries s₂)) sorry

protected instance has_union {α : Type u} {β : α → Type v} [DecidableEq α] : has_union (alist β) :=
  has_union.mk union

@[simp] theorem union_entries {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β}
    {s₂ : alist β} : entries (s₁ ∪ s₂) = list.kunion (entries s₁) (entries s₂) :=
  rfl

@[simp] theorem empty_union {α : Type u} {β : α → Type v} [DecidableEq α] {s : alist β} :
    ∅ ∪ s = s :=
  ext rfl

@[simp] theorem union_empty {α : Type u} {β : α → Type v} [DecidableEq α] {s : alist β} :
    s ∪ ∅ = s :=
  sorry

@[simp] theorem mem_union {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s₁ : alist β}
    {s₂ : alist β} : a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
  list.mem_keys_kunion

theorem perm_union {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β} {s₂ : alist β}
    {s₃ : alist β} {s₄ : alist β} (p₁₂ : entries s₁ ~ entries s₂) (p₃₄ : entries s₃ ~ entries s₄) :
    entries (s₁ ∪ s₃) ~ entries (s₂ ∪ s₄) :=
  sorry

theorem union_erase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (s₁ : alist β)
    (s₂ : alist β) : erase a (s₁ ∪ s₂) = erase a s₁ ∪ erase a s₂ :=
  ext (Eq.symm list.kunion_kerase)

@[simp] theorem lookup_union_left {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {s₁ : alist β} {s₂ : alist β} : a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
  list.lookup_kunion_left

@[simp] theorem lookup_union_right {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {s₁ : alist β} {s₂ : alist β} : ¬a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
  list.lookup_kunion_right

@[simp] theorem mem_lookup_union {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {s₁ : alist β} {s₂ : alist β} :
    b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ ¬a ∈ s₁ ∧ b ∈ lookup a s₂ :=
  list.mem_lookup_kunion

theorem mem_lookup_union_middle {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {s₁ : alist β} {s₂ : alist β} {s₃ : alist β} :
    b ∈ lookup a (s₁ ∪ s₃) → ¬a ∈ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
  list.mem_lookup_kunion_middle

theorem insert_union {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a} {s₁ : alist β}
    {s₂ : alist β} : insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ :=
  sorry

theorem union_assoc {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β} {s₂ : alist β}
    {s₃ : alist β} : entries (s₁ ∪ s₂ ∪ s₃) ~ entries (s₁ ∪ (s₂ ∪ s₃)) :=
  sorry

/-! ### disjoint -/

/-- Two associative lists are disjoint if they have no common keys. -/
def disjoint {α : Type u} {β : α → Type v} (s₁ : alist β) (s₂ : alist β) :=
  ∀ (k : α), k ∈ keys s₁ → ¬k ∈ keys s₂

theorem union_comm_of_disjoint {α : Type u} {β : α → Type v} [DecidableEq α] {s₁ : alist β}
    {s₂ : alist β} (h : disjoint s₁ s₂) : entries (s₁ ∪ s₂) ~ entries (s₂ ∪ s₁) :=
  sorry

end Mathlib


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

! This file was ported from Lean 3 source module control.traversable.lemmas
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Control.Applicative
import Mathbin.Control.Traversable.Basic

/-!
# Traversing collections

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file proves basic properties of traversable and applicative functors and defines
`pure_transformation F`, the natural applicative transformation from the identity functor to `F`.

## References

Inspired by [The Essence of the Iterator Pattern][gibbons2009].
-/

universe u

open IsLawfulTraversable

open Function hiding comp

open Functor

attribute [functor_norm] IsLawfulTraversable.naturality

attribute [simp] IsLawfulTraversable.id_traverse

namespace Traversable

variable {t : Type u → Type u}

variable [Traversable t] [IsLawfulTraversable t]

variable (F G : Type u → Type u)

variable [Applicative F] [LawfulApplicative F]

variable [Applicative G] [LawfulApplicative G]

variable {α β γ : Type u}

variable (g : α → F β)

variable (h : β → G γ)

variable (f : β → γ)

#print Traversable.PureTransformation /-
/-- The natural applicative transformation from the identity functor
to `F`, defined by `pure : Π {α}, α → F α`. -/
def PureTransformation : ApplicativeTransformation id F
    where
  app := @pure F _
  preserves_pure' α x := rfl
  preserves_seq' α β f x := by
    simp only [map_pure, seq_pure]
    rfl
#align traversable.pure_transformation Traversable.PureTransformation
-/

#print Traversable.pureTransformation_apply /-
@[simp]
theorem pureTransformation_apply {α} (x : id α) : PureTransformation F x = pure x :=
  rfl
#align traversable.pure_transformation_apply Traversable.pureTransformation_apply
-/

variable {F G} (x : t β)

/- warning: traversable.map_eq_traverse_id -> Traversable.map_eq_traverse_id is a dubious translation:
lean 3 declaration is
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {β : Type.{u1}} {γ : Type.{u1}} (f : β -> γ), Eq.{succ u1} ((t β) -> (t γ)) (Functor.map.{u1, u1} (fun {β : Type.{u1}} => t β) (Traversable.toFunctor.{u1} (fun {β : Type.{u1}} => t β) _inst_1) β γ f) (Traversable.traverse.{u1} t _inst_1 (id.{succ (succ u1)} Type.{u1}) (Monad.toApplicative.{u1, u1} (id.{succ (succ u1)} Type.{u1}) id.monad.{u1}) β γ (Function.comp.{succ u1, succ u1, succ u1} β γ (id.{succ (succ u1)} Type.{u1} γ) (id.mk.{succ u1} γ) f))
but is expected to have type
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {β : Type.{u1}} {γ : Type.{u1}} (f : β -> γ), Eq.{succ u1} ((t β) -> (t γ)) (Functor.map.{u1, u1} t (Traversable.toFunctor.{u1} t _inst_1) β γ f) (Traversable.traverse.{u1} t _inst_1 Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1}) β γ (Function.comp.{succ u1, succ u1, succ u1} β γ (Id.{u1} γ) (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) γ) f))
Case conversion may be inaccurate. Consider using '#align traversable.map_eq_traverse_id Traversable.map_eq_traverse_idₓ'. -/
theorem map_eq_traverse_id : map f = @traverse t _ _ _ _ _ (id.mk ∘ f) :=
  funext fun y => (traverse_eq_map_id f y).symm
#align traversable.map_eq_traverse_id Traversable.map_eq_traverse_id

#print Traversable.map_traverse /-
theorem map_traverse (x : t α) : map f <$> traverse g x = traverse (map f ∘ g) x :=
  by
  rw [@map_eq_traverse_id t _ _ _ _ f]
  refine' (comp_traverse (id.mk ∘ f) g x).symm.trans _
  congr ; apply comp.applicative_comp_id
#align traversable.map_traverse Traversable.map_traverse
-/

#print Traversable.traverse_map /-
theorem traverse_map (f : β → F γ) (g : α → β) (x : t α) :
    traverse f (g <$> x) = traverse (f ∘ g) x :=
  by
  rw [@map_eq_traverse_id t _ _ _ _ g]
  refine' (comp_traverse f (id.mk ∘ g) x).symm.trans _
  congr ; apply comp.applicative_id_comp
#align traversable.traverse_map Traversable.traverse_map
-/

#print Traversable.pure_traverse /-
theorem pure_traverse (x : t α) : traverse pure x = (pure x : F (t α)) := by
  have : traverse pure x = pure (traverse id.mk x) :=
      (naturality (pure_transformation F) id.mk x).symm <;>
    rwa [id_traverse] at this
#align traversable.pure_traverse Traversable.pure_traverse
-/

/- warning: traversable.id_sequence -> Traversable.id_sequence is a dubious translation:
lean 3 declaration is
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {α : Type.{u1}} (x : t α), Eq.{succ u1} (id.{succ (succ u1)} Type.{u1} (t α)) (sequence.{u1} t α (id.{succ (succ u1)} Type.{u1}) (Monad.toApplicative.{u1, u1} (id.{succ (succ u1)} Type.{u1}) id.monad.{u1}) _inst_1 (Functor.map.{u1, u1} t (Traversable.toFunctor.{u1} t _inst_1) α (id.{succ (succ u1)} Type.{u1} α) (id.mk.{succ u1} α) x)) (id.mk.{succ u1} (t α) x)
but is expected to have type
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {α : Type.{u1}} (x : t α), Eq.{succ u1} (Id.{u1} (t α)) (sequence.{u1} t α Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1}) _inst_1 (Functor.map.{u1, u1} t (Traversable.toFunctor.{u1} t _inst_1) α (Id.{u1} α) (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) α) x)) (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) (t α) x)
Case conversion may be inaccurate. Consider using '#align traversable.id_sequence Traversable.id_sequenceₓ'. -/
theorem id_sequence (x : t α) : sequence (id.mk <$> x) = id.mk x := by
  simp [sequence, traverse_map, id_traverse] <;> rfl
#align traversable.id_sequence Traversable.id_sequence

/- warning: traversable.comp_sequence -> Traversable.comp_sequence is a dubious translation:
lean 3 declaration is
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {F : Type.{u1} -> Type.{u1}} {G : Type.{u1} -> Type.{u1}} [_inst_3 : Applicative.{u1, u1} F] [_inst_4 : LawfulApplicative.{u1, u1} F _inst_3] [_inst_5 : Applicative.{u1, u1} G] [_inst_6 : LawfulApplicative.{u1, u1} G _inst_5] {α : Type.{u1}} (x : t (F (G α))), Eq.{succ u1} (Functor.Comp.{u1, u1, u1} F G (t α)) (sequence.{u1} t α (Functor.Comp.{u1, u1, u1} F G) (Functor.Comp.applicative.{u1, u1, u1} F G _inst_3 _inst_5) _inst_1 (Functor.map.{u1, u1} t (Traversable.toFunctor.{u1} t _inst_1) (F (G α)) (Functor.Comp.{u1, u1, u1} F G α) (Functor.Comp.mk.{u1, u1, u1} F G α) x)) (Functor.Comp.mk.{u1, u1, u1} F G (t α) (Functor.map.{u1, u1} F (Applicative.toFunctor.{u1, u1} F _inst_3) (t (G α)) (G (t α)) (sequence.{u1} t α G _inst_5 _inst_1) (sequence.{u1} t (G α) F _inst_3 _inst_1 x)))
but is expected to have type
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {F : Type.{u1} -> Type.{u1}} {G : Type.{u1} -> Type.{u1}} [_inst_3 : Applicative.{u1, u1} F] [_inst_4 : LawfulApplicative.{u1, u1} F _inst_3] [_inst_5 : Applicative.{u1, u1} G] [_inst_6 : LawfulApplicative.{u1, u1} G _inst_5] {α : Type.{u1}} (x : t (F (G α))), Eq.{succ u1} (Functor.Comp.{u1, u1, u1} F G (t α)) (sequence.{u1} t α (Functor.Comp.{u1, u1, u1} F G) (Functor.Comp.instApplicativeComp.{u1, u1, u1} F G _inst_3 _inst_5) _inst_1 (Functor.map.{u1, u1} t (Traversable.toFunctor.{u1} t _inst_1) (F (G α)) (Functor.Comp.{u1, u1, u1} F G α) (Functor.Comp.mk.{u1, u1, u1} F G α) x)) (Functor.Comp.mk.{u1, u1, u1} F G (t α) (Functor.map.{u1, u1} F (Applicative.toFunctor.{u1, u1} F _inst_3) (t (G α)) (G (t α)) (sequence.{u1} t α G _inst_5 _inst_1) (sequence.{u1} t (G α) F _inst_3 _inst_1 x)))
Case conversion may be inaccurate. Consider using '#align traversable.comp_sequence Traversable.comp_sequenceₓ'. -/
theorem comp_sequence (x : t (F (G α))) :
    sequence (Comp.mk <$> x) = Comp.mk (sequence <$> sequence x) := by
  simp [sequence, traverse_map] <;> rw [← comp_traverse] <;> simp [map_id]
#align traversable.comp_sequence Traversable.comp_sequence

#print Traversable.naturality' /-
theorem naturality' (η : ApplicativeTransformation F G) (x : t (F α)) :
    η (sequence x) = sequence (@η _ <$> x) := by simp [sequence, naturality, traverse_map]
#align traversable.naturality' Traversable.naturality'
-/

/- warning: traversable.traverse_id -> Traversable.traverse_id is a dubious translation:
lean 3 declaration is
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {α : Type.{u1}}, Eq.{succ u1} ((t α) -> (id.{succ (succ u1)} Type.{u1} (t α))) (Traversable.traverse.{u1} t _inst_1 (id.{succ (succ u1)} Type.{u1}) (Monad.toApplicative.{u1, u1} (id.{succ (succ u1)} Type.{u1}) id.monad.{u1}) α α (id.mk.{succ u1} α)) (id.mk.{succ u1} (t α))
but is expected to have type
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {α : Type.{u1}}, Eq.{succ u1} ((t α) -> (Id.{u1} (t α))) (Traversable.traverse.{u1} t _inst_1 Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1}) α α (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) α)) (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) (t α))
Case conversion may be inaccurate. Consider using '#align traversable.traverse_id Traversable.traverse_idₓ'. -/
@[functor_norm]
theorem traverse_id : traverse id.mk = (id.mk : t α → id (t α)) :=
  by
  ext
  exact id_traverse _
#align traversable.traverse_id Traversable.traverse_id

/- warning: traversable.traverse_comp -> Traversable.traverse_comp is a dubious translation:
lean 3 declaration is
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {F : Type.{u1} -> Type.{u1}} {G : Type.{u1} -> Type.{u1}} [_inst_3 : Applicative.{u1, u1} F] [_inst_4 : LawfulApplicative.{u1, u1} F _inst_3] [_inst_5 : Applicative.{u1, u1} G] [_inst_6 : LawfulApplicative.{u1, u1} G _inst_5] {α : Type.{u1}} {β : Type.{u1}} {γ : Type.{u1}} (g : α -> (F β)) (h : β -> (G γ)), Eq.{succ u1} ((t α) -> (Functor.Comp.{u1, u1, u1} (fun {β : Type.{u1}} => F β) G (t γ))) (Traversable.traverse.{u1} (fun {α : Type.{u1}} => t α) _inst_1 (Functor.Comp.{u1, u1, u1} (fun {β : Type.{u1}} => F β) G) (Functor.Comp.applicative.{u1, u1, u1} (fun {β : Type.{u1}} => F β) G _inst_3 _inst_5) α γ (Function.comp.{succ u1, succ u1, succ u1} α (F (G γ)) (Functor.Comp.{u1, u1, u1} (fun {β : Type.{u1}} => F β) G γ) (Functor.Comp.mk.{u1, u1, u1} (fun {β : Type.{u1}} => F β) G γ) (Function.comp.{succ u1, succ u1, succ u1} α (F β) (F (G γ)) (Functor.map.{u1, u1} (fun {β : Type.{u1}} => F β) (Applicative.toFunctor.{u1, u1} (fun {β : Type.{u1}} => F β) _inst_3) β (G γ) h) g))) (Function.comp.{succ u1, succ u1, succ u1} (t α) (F (G (t γ))) (Functor.Comp.{u1, u1, u1} F G (t γ)) (Functor.Comp.mk.{u1, u1, u1} F G (t γ)) (Function.comp.{succ u1, succ u1, succ u1} (t α) (F (t β)) (F (G (t γ))) (Functor.map.{u1, u1} F (Applicative.toFunctor.{u1, u1} F _inst_3) (t β) (G (t γ)) (Traversable.traverse.{u1} t _inst_1 G _inst_5 β γ h)) (Traversable.traverse.{u1} t _inst_1 F _inst_3 α β g)))
but is expected to have type
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {F : Type.{u1} -> Type.{u1}} {G : Type.{u1} -> Type.{u1}} [_inst_3 : Applicative.{u1, u1} F] [_inst_4 : LawfulApplicative.{u1, u1} F _inst_3] [_inst_5 : Applicative.{u1, u1} G] [_inst_6 : LawfulApplicative.{u1, u1} G _inst_5] {α : Type.{u1}} {β : Type.{u1}} {γ : Type.{u1}} (g : α -> (F β)) (h : β -> (G γ)), Eq.{succ u1} ((t α) -> (Functor.Comp.{u1, u1, u1} F G (t γ))) (Traversable.traverse.{u1} t _inst_1 (Functor.Comp.{u1, u1, u1} F G) (Functor.Comp.instApplicativeComp.{u1, u1, u1} F G _inst_3 _inst_5) α γ (Function.comp.{succ u1, succ u1, succ u1} α (F (G γ)) (Functor.Comp.{u1, u1, u1} F G γ) (Functor.Comp.mk.{u1, u1, u1} F G γ) (Function.comp.{succ u1, succ u1, succ u1} α (F β) (F (G γ)) (Functor.map.{u1, u1} F (Applicative.toFunctor.{u1, u1} F _inst_3) β (G γ) h) g))) (Function.comp.{succ u1, succ u1, succ u1} (t α) (F (G (t γ))) (Functor.Comp.{u1, u1, u1} F G (t γ)) (Functor.Comp.mk.{u1, u1, u1} F G (t γ)) (Function.comp.{succ u1, succ u1, succ u1} (t α) (F (t β)) (F (G (t γ))) (Functor.map.{u1, u1} F (Applicative.toFunctor.{u1, u1} F _inst_3) (t β) (G (t γ)) (Traversable.traverse.{u1} t _inst_1 G _inst_5 β γ h)) (Traversable.traverse.{u1} t _inst_1 F _inst_3 α β g)))
Case conversion may be inaccurate. Consider using '#align traversable.traverse_comp Traversable.traverse_compₓ'. -/
@[functor_norm]
theorem traverse_comp (g : α → F β) (h : β → G γ) :
    traverse (Comp.mk ∘ map h ∘ g) =
      (Comp.mk ∘ map (traverse h) ∘ traverse g : t α → Comp F G (t γ)) :=
  by
  ext
  exact comp_traverse _ _ _
#align traversable.traverse_comp Traversable.traverse_comp

/- warning: traversable.traverse_eq_map_id' -> Traversable.traverse_eq_map_id' is a dubious translation:
lean 3 declaration is
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {β : Type.{u1}} {γ : Type.{u1}} (f : β -> γ), Eq.{succ u1} ((t β) -> (id.{succ (succ u1)} Type.{u1} (t γ))) (Traversable.traverse.{u1} (fun {β : Type.{u1}} => t β) _inst_1 (id.{succ (succ u1)} Type.{u1}) (Monad.toApplicative.{u1, u1} (id.{succ (succ u1)} Type.{u1}) id.monad.{u1}) β γ (Function.comp.{succ u1, succ u1, succ u1} β γ (id.{succ (succ u1)} Type.{u1} γ) (id.mk.{succ u1} γ) f)) (Function.comp.{succ u1, succ u1, succ u1} (t β) (t γ) (id.{succ (succ u1)} Type.{u1} (t γ)) (id.mk.{succ u1} (t γ)) (Functor.map.{u1, u1} t (Traversable.toFunctor.{u1} t _inst_1) β γ f))
but is expected to have type
  forall {t : Type.{u1} -> Type.{u1}} [_inst_1 : Traversable.{u1} t] [_inst_2 : IsLawfulTraversable.{u1} t _inst_1] {β : Type.{u1}} {γ : Type.{u1}} (f : β -> γ), Eq.{succ u1} ((t β) -> (Id.{u1} (t γ))) (Traversable.traverse.{u1} t _inst_1 Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1}) β γ (Function.comp.{succ u1, succ u1, succ u1} β γ (Id.{u1} γ) (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) γ) f)) (Function.comp.{succ u1, succ u1, succ u1} (t β) (t γ) (Id.{u1} (t γ)) (Pure.pure.{u1, u1} Id.{u1} (Applicative.toPure.{u1, u1} Id.{u1} (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1})) (t γ)) (Functor.map.{u1, u1} t (Traversable.toFunctor.{u1} t _inst_1) β γ f))
Case conversion may be inaccurate. Consider using '#align traversable.traverse_eq_map_id' Traversable.traverse_eq_map_id'ₓ'. -/
theorem traverse_eq_map_id' (f : β → γ) : traverse (id.mk ∘ f) = id.mk ∘ (map f : t β → t γ) :=
  by
  ext
  exact traverse_eq_map_id _ _
#align traversable.traverse_eq_map_id' Traversable.traverse_eq_map_id'

#print Traversable.traverse_map' /-
-- @[functor_norm]
theorem traverse_map' (g : α → β) (h : β → G γ) :
    traverse (h ∘ g) = (traverse h ∘ map g : t α → G (t γ)) :=
  by
  ext
  rw [comp_app, traverse_map]
#align traversable.traverse_map' Traversable.traverse_map'
-/

#print Traversable.map_traverse' /-
theorem map_traverse' (g : α → G β) (h : β → γ) :
    traverse (map h ∘ g) = (map (map h) ∘ traverse g : t α → G (t γ)) :=
  by
  ext
  rw [comp_app, map_traverse]
#align traversable.map_traverse' Traversable.map_traverse'
-/

#print Traversable.naturality_pf /-
theorem naturality_pf (η : ApplicativeTransformation F G) (f : α → F β) :
    traverse (@η _ ∘ f) = @η _ ∘ (traverse f : t α → F (t β)) :=
  by
  ext
  rw [comp_app, naturality]
#align traversable.naturality_pf Traversable.naturality_pf
-/

end Traversable


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

/-!
# Tools to reformulate category-theoretic axioms in a more associativity-friendly way

## The `reassoc` attribute

The `reassoc` attribute can be applied to a lemma

```lean
@[reassoc]
lemma some_lemma : foo ≫ bar = baz := ...
```

and produce

```lean
lemma some_lemma_assoc {Y : C} (f : X ⟶ Y) : foo ≫ bar ≫ f = baz ≫ f := ...
```

The name of the produced lemma can be specified with `@[reassoc other_lemma_name]`. If
`simp` is added first, the generated lemma will also have the `simp` attribute.

## The `reassoc_axiom` command

When declaring a class of categories, the axioms can be reformulated to be more amenable
to manipulation in right associated expressions:

```lean
class some_class (C : Type) [category C] :=
(foo : Π X : C, X ⟶ X)
(bar : ∀ {X Y : C} (f : X ⟶ Y), foo X ≫ f = f ≫ foo Y)

reassoc_axiom some_class.bar
```

Here too, the `reassoc` attribute can be used instead. It works well when combined with
`simp`:

```lean
attribute [simp, reassoc] some_class.bar
```
-/

namespace tactic

open category_theory

/-- From an expression `f ≫ g`, extract the expression representing the category instance. -/
meta def get_cat_inst : expr → tactic expr
| `(@category_struct.comp _ %%struct_inst _ _ _ _ _) := pure struct_inst
| _ := failed

/-- (internals for `@[reassoc]`)
Given a lemma of the form `∀ ..., f ≫ g = h`, proves a new lemma of the form
`h : ∀ ... {W} (k), f ≫ (g ≫ k) = h ≫ k`, and returns the type and proof of this lemma.
-/
meta def prove_reassoc (h : expr) : tactic (expr × expr) :=
do
   (vs,t) ← infer_type h >>= open_pis,
   (lhs,rhs) ← match_eq t,
   struct_inst ← get_cat_inst lhs <|> get_cat_inst rhs <|> fail "no composition found in statement",
   `(@quiver.hom _ %%hom_inst %%X %%Y) ← infer_type lhs,
   C ← infer_type X,
   X' ← mk_local' `X' binder_info.implicit C,
   ft ← to_expr ``(@quiver.hom _ %%hom_inst %%Y %%X'),
   f' ← mk_local_def `f' ft,
   t' ← to_expr ``(@category_struct.comp _ %%struct_inst _ _ _%%lhs %%f' =
                     @category_struct.comp _ %%struct_inst _ _ _ %%rhs %%f'),
   let c' := h.mk_app vs,
   (_,pr) ← solve_aux t' (rewrite_target c'; reflexivity),
   pr ← instantiate_mvars pr,
   let s := simp_lemmas.mk,
   s ← s.add_simp ``category.assoc,
   s ← s.add_simp ``category.id_comp,
   s ← s.add_simp ``category.comp_id,
   (t'', pr', _) ← simplify s [] t',
   pr' ← mk_eq_mp pr' pr,
   t'' ← pis (vs ++ [X',f']) t'',
   pr' ← lambdas (vs ++ [X',f']) pr',
   pure (t'',pr')

/-- (implementation for `@[reassoc]`)
Given a declaration named `n` of the form `∀ ..., f ≫ g = h`, proves a new lemma named `n'`
of the form `∀ ... {W} (k), f ≫ (g ≫ k) = h ≫ k`.
-/
meta def reassoc_axiom (n : name) (n' : name := n.append_suffix "_assoc") : tactic unit :=
do d ← get_decl n,
   let ls := d.univ_params.map level.param,
   let c := @expr.const tt n ls,
   (t'',pr') ← prove_reassoc c,
   add_decl $ declaration.thm n' d.univ_params t'' (pure pr'),
   copy_attribute `simp n n'

setup_tactic_parser

/--
The `reassoc` attribute can be applied to a lemma

```lean
@[reassoc]
lemma some_lemma : foo ≫ bar = baz := ...
```

to produce

```lean
lemma some_lemma_assoc {Y : C} (f : X ⟶ Y) : foo ≫ bar ≫ f = baz ≫ f := ...
```

The name of the produced lemma can be specified with `@[reassoc other_lemma_name]`. If
`simp` is added first, the generated lemma will also have the `simp` attribute.
-/
@[user_attribute]
meta def reassoc_attr : user_attribute unit (option name) :=
{ name := `reassoc,
  descr := "create a companion lemma for associativity-aware rewriting",
  parser := optional ident,
  after_set := some (λ n _ _,
    do some n' ← reassoc_attr.get_param n | reassoc_axiom n (n.append_suffix "_assoc"),
       reassoc_axiom n $ n.get_prefix ++ n' ) }

add_tactic_doc
{ name                     := "reassoc",
  category                 := doc_category.attr,
  decl_names               := [`tactic.reassoc_attr],
  tags                     := ["category theory"] }

/--
When declaring a class of categories, the axioms can be reformulated to be more amenable
to manipulation in right associated expressions:

```lean
class some_class (C : Type) [category C] :=
(foo : Π X : C, X ⟶ X)
(bar : ∀ {X Y : C} (f : X ⟶ Y), foo X ≫ f = f ≫ foo Y)

reassoc_axiom some_class.bar
```

The above will produce:

```lean
lemma some_class.bar_assoc {Z : C} (g : Y ⟶ Z) :
  foo X ≫ f ≫ g = f ≫ foo Y ≫ g := ...
```

Here too, the `reassoc` attribute can be used instead. It works well when combined with
`simp`:

```lean
attribute [simp, reassoc] some_class.bar
```
-/
@[user_command]
meta def reassoc_cmd (_ : parse $ tk "reassoc_axiom") : lean.parser unit :=
do n ← ident,
   of_tactic $
   do n ← resolve_constant n,
      reassoc_axiom n

add_tactic_doc
{ name                     := "reassoc_axiom",
  category                 := doc_category.cmd,
  decl_names               := [`tactic.reassoc_cmd],
  tags                     := ["category theory"] }

namespace interactive

/-- `reassoc h`, for assumption `h : x ≫ y = z`, creates a new assumption
`h : ∀ {W} (f : Z ⟶ W), x ≫ y ≫ f = z ≫ f`.
`reassoc! h`, does the same but deletes the initial `h` assumption.
(You can also add the attribute `@[reassoc]` to lemmas to generate new declarations generalized
in this way.)
-/
meta def reassoc (del : parse (tk "!")?) (ns : parse ident*) : tactic unit :=
do ns.mmap' (λ n,
   do h ← get_local n,
      (t,pr) ← prove_reassoc h,
      assertv n t pr,
      when del.is_some (tactic.clear h) )

end interactive

def calculated_Prop {α} (β : Prop) (hh : α) := β

meta def derive_reassoc_proof : tactic unit :=
do `(calculated_Prop %%v %%h) ← target,
   (t,pr) ← prove_reassoc h,
   unify v t,
   exact pr

end tactic

/-- With `h : x ≫ y ≫ z = x` (with universal quantifiers tolerated),
`reassoc_of h : ∀ {X'} (f : W ⟶ X'), x ≫ y ≫ z ≫ f = x ≫ f`.

The type and proof of `reassoc_of h` is generated by `tactic.derive_reassoc_proof`
which make `reassoc_of` meta-programming adjacent. It is not called as a tactic but as
an expression. The goal is to avoid creating assumptions that are dismissed after one use:

```lean
example (X Y Z W : C) (x : X ⟶ Y) (y : Y ⟶ Z) (z z' : Z ⟶ W) (w : X ⟶ Z)
  (h : x ≫ y = w)
  (h' : y ≫ z = y ≫ z') :
  x ≫ y ≫ z = w ≫ z' :=
begin
  rw [h',reassoc_of h],
end
```
-/
theorem category_theory.reassoc_of {α} (hh : α) {β}
  (x : tactic.calculated_Prop β hh . tactic.derive_reassoc_proof) : β := x

/--
`reassoc_of h` takes local assumption `h` and add a ` ≫ f` term on the right of
both sides of the equality. Instead of creating a new assumption from the result, `reassoc_of h`
stands for the proof of that reassociated statement. This keeps complicated assumptions that are
used only once or twice from polluting the local context.

In the following, assumption `h` is needed in a reassociated form. Instead of proving it as a new
goal and adding it as an assumption, we use `reassoc_of h` as a rewrite rule which works just as
well.

```lean
example (X Y Z W : C) (x : X ⟶ Y) (y : Y ⟶ Z) (z z' : Z ⟶ W) (w : X ⟶ Z)
  (h : x ≫ y = w)
  (h' : y ≫ z = y ≫ z') :
  x ≫ y ≫ z = w ≫ z' :=
begin
  -- reassoc_of h : ∀ {X' : C} (f : W ⟶ X'), x ≫ y ≫ f = w ≫ f
  rw [h',reassoc_of h],
end
```

Although `reassoc_of` is not a tactic or a meta program, its type is generated
through meta-programming to make it usable inside normal expressions.
-/
add_tactic_doc
{ name                     := "category_theory.reassoc_of",
  category                 := doc_category.tactic,
  decl_names               := [`category_theory.reassoc_of],
  tags                     := ["category theory"] }


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

/-!
# Monadic instances for `ulift` and `plift`

In this file we define `monad` and `is_lawful_monad` instances on `plift` and `ulift`. -/

universes u v

namespace plift

variables {α : Sort u} {β : Sort v}

/-- Functorial action. -/
protected def map (f : α → β) (a : plift α) : plift β :=
plift.up (f a.down)

@[simp] lemma map_up (f : α → β) (a : α) : (plift.up a).map f = plift.up (f a) := rfl

/-- Embedding of pure values. -/
@[simp] protected def pure : α → plift α := up

/-- Applicative sequencing. -/
protected def seq (f : plift (α → β)) (x : plift α) : plift β :=
plift.up (f.down x.down)

@[simp] lemma seq_up (f : α → β) (x : α) : (plift.up f).seq (plift.up x) = plift.up (f x) := rfl

/-- Monadic bind. -/
protected def bind (a : plift α) (f : α → plift β) : plift β := f a.down

@[simp] lemma bind_up (a : α) (f : α → plift β) : (plift.up a).bind f = f a := rfl

instance : monad plift :=
{ map := @plift.map,
  pure := @plift.pure,
  seq := @plift.seq,
  bind := @plift.bind }

instance : is_lawful_functor plift :=
{ id_map := λ α ⟨x⟩, rfl,
  comp_map := λ α β γ g h ⟨x⟩, rfl }

instance : is_lawful_applicative plift :=
{ pure_seq_eq_map := λ α β g ⟨x⟩, rfl,
  map_pure := λ α β g x, rfl,
  seq_pure := λ α β ⟨g⟩ x, rfl,
  seq_assoc := λ α β γ ⟨x⟩ ⟨g⟩ ⟨h⟩, rfl }

instance : is_lawful_monad plift :=
{ bind_pure_comp_eq_map := λ α β f ⟨x⟩, rfl,
  bind_map_eq_seq := λ α β ⟨a⟩ ⟨b⟩, rfl,
  pure_bind := λ α β x f, rfl,
  bind_assoc := λ α β γ ⟨x⟩ f g, rfl }

@[simp] lemma rec.constant {α : Sort u} {β : Type v} (b : β) :
  @plift.rec α (λ _, β) (λ _, b) = λ _, b :=
funext (λ x, plift.cases_on x (λ a, eq.refl (plift.rec (λ a', b) {down := a})))

end plift

namespace ulift

variables {α : Type u} {β : Type v}

/-- Functorial action. -/
protected def map (f : α → β) (a : ulift α) : ulift β :=
ulift.up (f a.down)

@[simp] lemma map_up (f : α → β) (a : α) : (ulift.up a).map f = ulift.up (f a) := rfl

/-- Embedding of pure values. -/
@[simp] protected def pure : α → ulift α := up

/-- Applicative sequencing. -/
protected def seq (f : ulift (α → β)) (x : ulift α) : ulift β :=
ulift.up (f.down x.down)

@[simp] lemma seq_up (f : α → β) (x : α) : (ulift.up f).seq (ulift.up x) = ulift.up (f x) := rfl

/-- Monadic bind. -/
protected def bind (a : ulift α) (f : α → ulift β) : ulift β := f a.down

@[simp] lemma bind_up (a : α) (f : α → ulift β) : (ulift.up a).bind f = f a := rfl

instance : monad ulift :=
{ map := @ulift.map,
  pure := @ulift.pure,
  seq := @ulift.seq,
  bind := @ulift.bind }

instance : is_lawful_functor ulift :=
{ id_map := λ α ⟨x⟩, rfl,
  comp_map := λ α β γ g h ⟨x⟩, rfl }

instance : is_lawful_applicative ulift :=
{ to_is_lawful_functor := ulift.is_lawful_functor,
  pure_seq_eq_map := λ α β g ⟨x⟩, rfl,
  map_pure := λ α β g x, rfl,
  seq_pure := λ α β ⟨g⟩ x, rfl,
  seq_assoc := λ α β γ ⟨x⟩ ⟨g⟩ ⟨h⟩, rfl }

instance : is_lawful_monad ulift :=
{ bind_pure_comp_eq_map := λ α β f ⟨x⟩, rfl,
  bind_map_eq_seq := λ α β ⟨a⟩ ⟨b⟩, rfl,
  pure_bind := λ α β x f,
    by { dsimp only [bind, pure, ulift.pure, ulift.bind], cases (f x), refl },
  bind_assoc := λ α β γ ⟨x⟩ f g,
    by { dsimp only [bind, pure, ulift.pure, ulift.bind], cases (f x), refl } }

@[simp] lemma rec.constant {α : Type u} {β : Sort v} (b : β) :
  @ulift.rec α (λ _, β) (λ _, b) = λ _, b :=
funext (λ x, ulift.cases_on x (λ a, eq.refl (ulift.rec (λ a', b) {down := a})))

end ulift