/-
Copyright (c) 2017 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 tactic.rcases
! leanprover-community/mathlib commit 356447fe00e75e54777321045cdff7c9ea212e60
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Leanbin.Data.Dlist
import Mathbin.Tactic.Core
import Mathbin.Tactic.Clear

/-!

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

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

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

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

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

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

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

## Tags

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

open Lean Lean.Parser

namespace Tactic

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

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

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

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

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

/-- A list, with a disjunctive meaning (like a list of inductive constructors, or subgoals) -/
@[reducible]
def ListSigma :=
  List
#align tactic.list_Sigma Tactic.ListSigma

/-- A list, with a conjunctive meaning (like a list of constructor arguments, or hypotheses) -/
@[reducible]
def ListPi :=
  List
#align tactic.list_Pi Tactic.ListPi

-- mathport name: «exprlistΣ»
local notation "listΣ" => ListSigma

-- mathport name: «exprlistΠ»
local notation "listΠ" => ListPi

/-- A metavariable representing a subgoal, together with a list of local constants to clear. -/
@[reducible]
unsafe def uncleared_goal :=
  List expr × expr
#align tactic.uncleared_goal tactic.uncleared_goal

/-- An `rcases` pattern can be one of the following, in a nested combination:

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

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

N-ary alternations are treated as a group, so `p1 | p2 | p3` is not the same as `p1 | (p2 | p3)`,
and similarly for tuples. However, note that an n-ary alternation or tuple can match an n-ary
conjunction or disjunction, because if the number of patterns exceeds the number of constructors in
the type being destructed, the extra patterns will match on the last element, meaning that
`p1 | p2 | p3` will act like `p1 | (p2 | p3)` when matching `a1 ∨ a2 ∨ a3`. If matching against a
type with 3 constructors,  `p1 | (p2 | p3)` will act like `p1 | (p2 | p3) | _` instead.
-/
unsafe inductive rcases_patt : Type
  | one : Name → rcases_patt
  | clear : rcases_patt
  | explicit : rcases_patt → rcases_patt
  | typed : rcases_patt → pexpr → rcases_patt
  | tuple : listΠ rcases_patt → rcases_patt
  | alts : listΣ rcases_patt → rcases_patt
#align tactic.rcases_patt tactic.rcases_patt

namespace RcasesPatt

unsafe instance inhabited : Inhabited rcases_patt :=
  ⟨one `_⟩
#align tactic.rcases_patt.inhabited tactic.rcases_patt.inhabited

/-- Get the name from a pattern, if provided -/
unsafe def name : rcases_patt → Option Name
  | one `_ => none
  | one `rfl => none
  | one n => some n
  | explicit p => p.Name
  | typed p _ => p.Name
  | alts [p] => p.Name
  | _ => none
#align tactic.rcases_patt.name tactic.rcases_patt.name

/-- Interpret an rcases pattern as a tuple, where `p` becomes `⟨p⟩`
if `p` is not already a tuple. -/
unsafe def as_tuple : rcases_patt → Bool × listΠ rcases_patt
  | explicit p => (true, (as_tuple p).2)
  | tuple ps => (false, ps)
  | p => (false, [p])
#align tactic.rcases_patt.as_tuple tactic.rcases_patt.as_tuple

/-- Interpret an rcases pattern as an alternation, where non-alternations are treated as one
alternative. -/
unsafe def as_alts : rcases_patt → listΣ rcases_patt
  | alts ps => ps
  | p => [p]
#align tactic.rcases_patt.as_alts tactic.rcases_patt.as_alts

/-- Convert a list of patterns to a tuple pattern, but mapping `[p]` to `p` instead of `⟨p⟩`. -/
unsafe def tuple' : listΠ rcases_patt → rcases_patt
  | [p] => p
  | ps => tuple ps
#align tactic.rcases_patt.tuple' tactic.rcases_patt.tuple'

/-- Convert a list of patterns to an alternation pattern, but mapping `[p]` to `p` instead of
a unary alternation `|p`. -/
unsafe def alts' : listΣ rcases_patt → rcases_patt
  | [p] => p
  | ps => alts ps
#align tactic.rcases_patt.alts' tactic.rcases_patt.alts'

/-- This function is used for producing rcases patterns based on a case tree. Suppose that we have
a list of patterns `ps` that will match correctly against the branches of the case tree for one
constructor. This function will merge tuples at the end of the list, so that `[a, b, ⟨c, d⟩]`
becomes `⟨a, b, c, d⟩` instead of `⟨a, b, ⟨c, d⟩⟩`.

We must be careful to turn `[a, ⟨⟩]` into `⟨a, ⟨⟩⟩` instead of `⟨a⟩` (which will not perform the
nested match). -/
unsafe def tuple₁_core : listΠ rcases_patt → listΠ rcases_patt
  | [] => []
  | [tuple []] => [tuple []]
  | [tuple ps] => ps
  | p :: ps => p :: tuple₁_core ps
#align tactic.rcases_patt.tuple₁_core tactic.rcases_patt.tuple₁_core

/-- This function is used for producing rcases patterns based on a case tree. This is like
`tuple₁_core` but it produces a pattern instead of a tuple pattern list, converting `[n]` to `n`
instead of `⟨n⟩` and `[]` to `_`, and otherwise just converting `[a, b, c]` to `⟨a, b, c⟩`. -/
unsafe def tuple₁ : listΠ rcases_patt → rcases_patt
  | [] => default
  | [one n] => one n
  | ps => tuple (tuple₁_core ps)
#align tactic.rcases_patt.tuple₁ tactic.rcases_patt.tuple₁

/-- This function is used for producing rcases patterns based on a case tree. Here we are given
the list of patterns to apply to each argument of each constructor after the main case, and must
produce a list of alternatives with the same effect. This function calls `tuple₁` to make the
individual alternatives, and handles merging `[a, b, c | d]` to `a | b | c | d` instead of
`a | b | (c | d)`. -/
unsafe def alts₁_core : listΣ (listΠ rcases_patt) → listΣ rcases_patt
  | [] => []
  | [[alts ps]] => ps
  | p :: ps => tuple₁ p :: alts₁_core ps
#align tactic.rcases_patt.alts₁_core tactic.rcases_patt.alts₁_core

/-- This function is used for producing rcases patterns based on a case tree. This is like
`alts₁_core`, but it produces a cases pattern directly instead of a list of alternatives. We
specially translate the empty alternation to `⟨⟩`, and translate `|(a | b)` to `⟨a | b⟩` (because we
don't have any syntax for unary alternation). Otherwise we can use the regular merging of
alternations at the last argument so that `a | b | (c | d)` becomes `a | b | c | d`. -/
unsafe def alts₁ : listΣ (listΠ rcases_patt) → rcases_patt
  | [[]] => tuple []
  | [[alts ps]] => tuple [alts ps]
  | ps => alts' (alts₁_core ps)
#align tactic.rcases_patt.alts₁ tactic.rcases_patt.alts₁

unsafe instance has_reflect : has_reflect rcases_patt
  | one n => q(_)
  | clear => q(_)
  | explicit l => q(explicit).subst (has_reflect l)
  | typed l e => (q(typed).subst (has_reflect l)).subst (reflect e)
  | tuple l =>
    q(fun l => tuple l).subst <|
      haveI := has_reflect
      list.reflect l
  | alts l =>
    q(fun l => alts l).subst <|
      haveI := has_reflect
      list.reflect l
#align tactic.rcases_patt.has_reflect tactic.rcases_patt.has_reflect

/-- Formats an `rcases` pattern. If the `bracket` argument is true, then it will be
printed at high precedence, i.e. it will have parentheses around it if it is not already a tuple
or atomic name. -/
protected unsafe def format : ∀ bracket : Bool, rcases_patt → tactic _root_.format
  | _, one n => pure <| to_fmt n
  | _, clear => pure "-"
  | _, explicit p => do
    let f ← format true p
    pure <| "@" ++ f
  | _, tuple [] => pure "⟨⟩"
  | _, tuple ls => do
    let fs ← ls.mapM <| format false
    pure <|
        "⟨" ++
            _root_.format.group
              (_root_.format.nest 1 <|
                _root_.format.join <| List.intersperse ("," ++ _root_.format.line) fs) ++
          "⟩"
  | br, alts ls => do
    let fs ← ls.mapM <| format true
    let fmt := _root_.format.join <| List.intersperse (↑" |" ++ _root_.format.space) fs
    pure <| if br then _root_.format.bracket "(" ")" fmt else fmt
  | br, typed p e => do
    let fp ← format false p
    let fe ← pp e
    let fmt := fp ++ " : " ++ fe
    pure <| if br then _root_.format.bracket "(" ")" fmt else fmt
#align tactic.rcases_patt.format tactic.rcases_patt.format

unsafe instance has_to_tactic_format : has_to_tactic_format rcases_patt :=
  ⟨rcases_patt.format false⟩
#align tactic.rcases_patt.has_to_tactic_format tactic.rcases_patt.has_to_tactic_format

end RcasesPatt

/-- Takes the number of fields of a single constructor and patterns to match its fields against
(not necessarily the same number). The returned lists each contain one element per field of the
constructor. The `name` is the name which will be used in the top-level `cases` tactic, and the
`rcases_patt` is the pattern which the field will be matched against by subsequent `cases`
tactics. -/
unsafe def rcases.process_constructor :
    Bool → List BinderInfo → listΠ rcases_patt → listΠ Name × listΠ rcases_patt
  | _, [], ps => ([], [])
  | explicit, bi :: l, ps =>
    if !explicit && bi ≠ BinderInfo.default then
      let (ns, tl) := rcases.process_constructor explicit l ps
      (`_ :: ns, default :: tl)
    else
      match l, ps with
      | [], [] => ([`_], [default])
      | [], [p] => ([p.Name.getD `_], [p])
      |-- The interesting case: we matched the last field against multiple
        -- patterns, so split off the remaining patterns into a subsequent
        -- match. This handles matching `α × β × γ` against `⟨a, b, c⟩`.
        [],
        ps => ([`_], [cond explicit (rcases_patt.tuple ps).explicit (rcases_patt.tuple ps)])
      | l, ps =>
        let hd := ps.headI
        let (ns, tl) := rcases.process_constructor explicit l ps.tail
        (hd.Name.getD `_ :: ns, hd :: tl)
#align tactic.rcases.process_constructor tactic.rcases.process_constructor

private unsafe def get_pi_arity_list_aux : expr → tactic (List BinderInfo)
  | expr.pi n bi d b => do
    let m ← mk_fresh_name
    let l := expr.local_const m n bi d
    let new_b ← whnf (expr.instantiate_var b l)
    let r ← get_pi_arity_list_aux new_b
    return (bi :: r)
  | e => return []
#align tactic.get_pi_arity_list_aux tactic.get_pi_arity_list_aux

/-- Compute the arity of the given (Pi-)type -/
unsafe def get_pi_arity_list (type : expr) : tactic (List BinderInfo) :=
  whnf type >>= get_pi_arity_list_aux
#align tactic.get_pi_arity_list tactic.get_pi_arity_list

/-- Compute the arity of the given function -/
unsafe def get_arity_list (fn : expr) : tactic (List BinderInfo) :=
  infer_type fn >>= get_pi_arity_list
#align tactic.get_arity_list tactic.get_arity_list

/-- Takes a list of constructor names, and an (alternation) list of patterns, and matches each
pattern against its constructor. It returns the list of names that will be passed to `cases`,
and the list of `(constructor name, patterns)` for each constructor, where `patterns` is the
(conjunctive) list of patterns to apply to each constructor argument. -/
unsafe def rcases.process_constructors (params : Nat) :
    listΣ Name → listΣ rcases_patt → tactic (Dlist Name × listΣ (Name × listΠ rcases_patt))
  | [], ps => pure (Dlist.empty, [])
  | c :: cs, ps => do
    let l ← mk_const c >>= get_arity_list
    let ((explicit, h), t) :=
      (match cs, ps.tail with
        |-- We matched the last constructor against multiple patterns,
          -- so split off the remaining constructors. This handles matching
          -- `α ⊕ β ⊕ γ` against `a|b|c`.
          [],
          _ :: _ => ((false, [rcases_patt.alts ps]), [])
        | _, _ => (ps.headI.as_tuple, ps.tail) :
        _)
    let (ns, ps) := rcases.process_constructor explicit (l.drop params) h
    let (l, r) ← rcases.process_constructors cs t
    pure (Dlist.ofList ns ++ l, (c, ps) :: r)
#align tactic.rcases.process_constructors tactic.rcases.process_constructors

/-- Like `zip`, but only elements satisfying a matching predicate `p` will go in the list,
and elements of the first list that fail to match the second list will be skipped. -/
private def align {α β} (p : α → β → Prop) [∀ a b, Decidable (p a b)] :
    List α → List β → List (α × β)
  | a :: as, b :: bs => if p a b then (a, b) :: align as bs else align as (b :: bs)
  | _, _ => []
#align tactic.align tactic.align

/-- Given a local constant `e`, get its type. *But* if `e` does not exist, go find a hypothesis
with the same pretty name as `e` and get it instead. This is needed because we can sometimes lose
track of the unique names of hypotheses when they are revert/intro'd by `change` and `cases`. (A
better solution would be for these tactics to return a map of renamed hypotheses so that we don't
lose track of them.) -/
private unsafe def get_local_and_type (e : expr) : tactic (expr × expr) :=
  (do
      let t ← infer_type e
      pure (t, e)) <|>
    do
    let e ← get_local e.local_pp_name
    let t ← infer_type e
    pure (t, e)
#align tactic.get_local_and_type tactic.get_local_and_type

mutual
  /-- * `rcases_core p e` will match a pattern `p` against a local hypothesis `e`.
    It returns the list of subgoals that were produced.
  * `rcases.continue pes` will match a (conjunctive) list of `(p, e)` pairs which refer to
    patterns and local hypotheses to match against, and applies all of them. Note that this can
    involve matching later arguments multiple times given earlier arguments, for example
    `⟨a | b, ⟨c, d⟩⟩` performs the `⟨c, d⟩` match twice, once on the `a` branch and once on `b`.
  -/
  unsafe def rcases_core : rcases_patt → expr → tactic (List uncleared_goal)
    | rcases_patt.one `rfl, e => do
      let (t, e) ← get_local_and_type e
      subst' e
      List.map (Prod.mk []) <$> get_goals
    |-- If the pattern is any other name, we already bound the name in the
        -- top-level `cases` tactic, so there is no more work to do for it.
        rcases_patt.one
        _,
      _ => List.map (Prod.mk []) <$> get_goals
    | rcases_patt.clear, e => do
      let m ← try_core (get_local_and_type e)
      List.map (Prod.mk <| m [] fun ⟨_, e⟩ => [e]) <$> get_goals
    | rcases_patt.typed p ty, e => do
      let (t, e) ← get_local_and_type e
      let ty ← i_to_expr_no_subgoals ``(($(ty) : Sort _))
      unify t ty
      let t ← instantiate_mvars t
      let ty ← instantiate_mvars ty
      let e ← if t == ty then pure e else change_core ty (some e) >> get_local e.local_pp_name
      rcases_core p e
    | rcases_patt.alts [p], e => rcases_core p e
    | pat, e => do
      let (t, e) ← get_local_and_type e
      let t ← whnf t
      let env ← get_env
      let I := t.get_app_fn.const_name
      let pat := pat.as_alts
      let (ids, r, l) ←
        if I ≠ `quot then do
            when ¬env I <| fail f! "rcases tactic failed: {e } : {I} is not an inductive datatype"
            let params := env.inductive_num_params I
            let c := env.constructors_of I
            let (ids, r) ← rcases.process_constructors params c pat
            let l ← cases_core e ids.toList
            pure (ids, r, l)
          else do
            let (ids, r) ← rcases.process_constructors 2 [`quot.mk] pat
            let [(_, d)] ← induction e ids.toList `quot.induction_on |
              fail f! "quotient induction on {e} failed. Maybe goal is not in Prop?"
            -- the result from `induction` is missing the information that the original constructor was
                -- `quot.mk` so we fix this up:
                pure
                (ids, r, [(`quot.mk, d)])
      let gs ← get_goals
      let-- `cases_core` may not generate a new goal for every constructor,
      -- as some constructors may be impossible for type reasons. (See its
      -- documentation.) Match up the new goals with our remaining work
      -- by constructor name.
      ls := align (fun (a : Name × _) (b : _ × Name × _) => a.1 = b.2.1) r (gs.zip l)
      List.join <$> ls fun ⟨⟨_, ps⟩, g, _, hs, _⟩ => set_goals [g] >> rcases.continue (ps hs)
  /-- * `rcases_core p e` will match a pattern `p` against a local hypothesis `e`.
    It returns the list of subgoals that were produced.
  * `rcases.continue pes` will match a (conjunctive) list of `(p, e)` pairs which refer to
    patterns and local hypotheses to match against, and applies all of them. Note that this can
    involve matching later arguments multiple times given earlier arguments, for example
    `⟨a | b, ⟨c, d⟩⟩` performs the `⟨c, d⟩` match twice, once on the `a` branch and once on `b`.
  -/
  unsafe def rcases.continue : listΠ (rcases_patt × expr) → tactic (List uncleared_goal)
    | [] => List.map (Prod.mk []) <$> get_goals
    | (pat, e) :: pes => do
      let gs ← rcases_core pat e
      List.join <$>
          gs fun ⟨cs, g⟩ => do
            set_goals [g]
            let ugs ← rcases.continue pes
            pure <| ugs fun ⟨cs', gs⟩ => (cs ++ cs', gs)
end
#align tactic.rcases_core tactic.rcases_core
#align tactic.rcases.continue tactic.rcases.continue

/-- Given a list of `uncleared_goal`s, each of which is a goal metavariable and
a list of variables to clear, actually perform the clear and set the goals with the result. -/
unsafe def clear_goals (ugs : List uncleared_goal) : tactic Unit := do
  let gs ←
    ugs.mapM fun ⟨cs, g⟩ => do
        set_goals [g]
        let cs ←
          cs.foldrM
              (fun c cs =>
                (do
                    let (_, c) ← get_local_and_type c
                    pure (c :: cs)) <|>
                  pure cs)
              []
        clear' tt cs
        let [g] ← get_goals
        pure g
  set_goals gs
#align tactic.clear_goals tactic.clear_goals

/-- `rcases h e pat` performs case distinction on `e` using `pat` to
name the arising new variables and assumptions. If `h` is `some` name,
a new assumption `h : e = pat` will relate the expression `e` with the
current pattern. See the module comment for the syntax of `pat`. -/
unsafe def rcases (h : Option Name) (p : pexpr) (pat : rcases_patt) : tactic Unit := do
  let p :=
    match pat with
    | rcases_patt.typed _ ty => ``(($(p) : $(ty)))
    | _ => p
  let e ←
    match h with
      | some h => do
        let x ← get_unused_name <| pat.Name.getD `this
        interactive.generalize h () (p, x)
        get_local x
      | none => i_to_expr p
  if e then
      match pat with
      | some x => do
        let n ← revert e
        let e ← intro x
        intron (n - 1)
        focus1 (rcases_core pat e >>= clear_goals)
      | none => focus1 (rcases_core pat e >>= clear_goals)
    else do
      let x ← pat mk_fresh_name pure
      let n ← revert_kdependencies e semireducible
      tactic.generalize e x <|> do
          let t ← infer_type e
          tactic.assertv x t e
          get_local x >>= tactic.revert
          pure ()
      let h ← tactic.intro1
      focus1 (rcases_core pat h >>= clear_goals)
#align tactic.rcases tactic.rcases

/-- `rcases_many es pats` performs case distinction on the `es` using `pat` to
name the arising new variables and assumptions.
See the module comment for the syntax of `pat`. -/
unsafe def rcases_many (ps : listΠ pexpr) (pat : rcases_patt) : tactic Unit := do
  let (_, pats) := rcases.process_constructor false (ps.map fun _ => default) pat.as_tuple.2
  let pes ←
    (ps.zip pats).mapM fun ⟨p, pat⟩ => do
        let p :=
          match pat with
          | rcases_patt.typed _ ty => ``(($(p) : $(ty)))
          | _ => p
        let e ← i_to_expr p
        if e then
            match pat with
            | some x => do
              let n ← revert e
              let e ← intro x
              intron (n - 1)
              pure (pat, e)
            | none => pure (pat, e)
          else do
            let x ← pat mk_fresh_name pure
            let n ← revert_kdependencies e semireducible
            tactic.generalize e x <|> do
                let t ← infer_type e
                tactic.assertv x t e
                get_local x >>= tactic.revert
                pure ()
            Prod.mk pat <$> tactic.intro1
  focus1 (rcases.continue pes >>= clear_goals)
#align tactic.rcases_many tactic.rcases_many

/-- `rintro pat₁ pat₂ ... patₙ` introduces `n` arguments, then pattern matches on the `patᵢ` using
the same syntax as `rcases`. -/
unsafe def rintro (ids : listΠ rcases_patt) : tactic Unit := do
  let l ←
    ids.mapM fun id => do
        let e ← intro <| id.Name.getD `_
        pure (id, e)
  focus1 (rcases.continue l >>= clear_goals)
#align tactic.rintro tactic.rintro

/-- Like `zip_with`, but if the lists don't match in length, the excess elements will be put at the
end of the result. -/
def mergeList {α} (m : α → α → α) : List α → List α → List α
  | [], l₂ => l₂
  | l₁, [] => l₁
  | a :: l₁, b :: l₂ => m a b :: merge_list l₁ l₂
#align tactic.merge_list Tactic.mergeList

/-- Merge two `rcases` patterns. This is used to underapproximate a case tree by an `rcases`
pattern. The two patterns come from cases in two branches, that due to the syntax of `rcases`
patterns are forced to overlap. The rule here is that we take only the case splits that are in
common between both branches. For example if one branch does `⟨a, b⟩` and the other does `c`,
then we return `c` because we don't know that a case on `c` would be safe to do. -/
unsafe def rcases_patt.merge : rcases_patt → rcases_patt → rcases_patt
  | rcases_patt.alts p₁, p₂ => rcases_patt.alts (mergeList rcases_patt.merge p₁ p₂.as_alts)
  | p₁, rcases_patt.alts p₂ => rcases_patt.alts (mergeList rcases_patt.merge p₁.as_alts p₂)
  | rcases_patt.explicit p₁, p₂ => rcases_patt.explicit (p₁.merge p₂)
  | p₁, rcases_patt.explicit p₂ => rcases_patt.explicit (p₁.merge p₂)
  | rcases_patt.tuple p₁, p₂ => rcases_patt.tuple (mergeList rcases_patt.merge p₁ p₂.as_tuple.2)
  | p₁, rcases_patt.tuple p₂ => rcases_patt.tuple (mergeList rcases_patt.merge p₁.as_tuple.2 p₂)
  | rcases_patt.typed p₁ e, p₂ => rcases_patt.typed (p₁.merge p₂) e
  | p₁, rcases_patt.typed p₂ e => rcases_patt.typed (p₁.merge p₂) e
  | rcases_patt.one `rfl, rcases_patt.one `rfl => rcases_patt.one `rfl
  | rcases_patt.one `_, p => p
  | p, rcases_patt.one `_ => p
  | rcases_patt.clear, p => p
  | p, rcases_patt.clear => p
  | rcases_patt.one n, _ => rcases_patt.one n
#align tactic.rcases_patt.merge tactic.rcases_patt.merge

mutual
  /--
  * `rcases_hint_core depth e` does the same as `rcases p e`, except the pattern `p` is an output
    instead of an input, controlled only by the case depth argument `depth`. We use `cases` to depth
    `depth` and then reconstruct an `rcases` pattern `p` that would, if passed to `rcases`, perform
    the same thing as the case tree we just constructed (or at least, the nearest expressible
    approximation to this.)
  * `rcases_hint.process_constructors depth cs l` takes a list of constructor names `cs` and a
    matching list `l` of elements `(g, c', hs, _)` where  `c'` is a constructor name (used for
    alignment with `cs`), `g` is the subgoal, and `hs` is the list of local hypotheses created by
    `cases` in that subgoal. It matches on all of them, and then produces a `ΣΠ`-list of `rcases`
    patterns describing the result, and the list of generated subgoals.
  * `rcases_hint.continue depth es` does the same as `rcases.continue (ps.zip es)`, except the
    patterns `ps` are an output instead of an input, created by matching on everything to depth
    `depth` and recording the successful cases. It returns `ps`, and the list of generated subgoals.
  -/
  unsafe def rcases_hint_core (explicit : Bool) :
      Bool → ℕ → expr → tactic (Option rcases_patt × List expr)
    | force, depth, e => do
      let (t, e) ← get_local_and_type e
      let tt ← pure (explicit || force || e.local_binding_info = BinderInfo.default) |
        Prod.mk none <$> get_goals
      let t ← whnf t
      let env ← get_env
      let I := t.get_app_fn.const_name
      (do
            guard (I = `` Eq)
            subst' e
            Prod.mk (some (rcases_patt.one `rfl)) <$> get_goals) <|>
          do
          let c := env I
          let some l ← try_core (guard (depth ≠ 0) >> cases_core e) |
            let n :=
                match e with
                | Name.anonymous => `_
                | n => n
              Prod.mk (some (rcases_patt.one n)) <$> get_goals
          let gs ← get_goals
          if gs then pure (some (rcases_patt.tuple []), [])
            else do
              let (ps, gs') ← rcases_hint.process_constructors (depth - 1) c (gs l)
              pure (some (rcases_patt.alts₁ ps), gs')
  /--
  * `rcases_hint_core depth e` does the same as `rcases p e`, except the pattern `p` is an output
    instead of an input, controlled only by the case depth argument `depth`. We use `cases` to depth
    `depth` and then reconstruct an `rcases` pattern `p` that would, if passed to `rcases`, perform
    the same thing as the case tree we just constructed (or at least, the nearest expressible
    approximation to this.)
  * `rcases_hint.process_constructors depth cs l` takes a list of constructor names `cs` and a
    matching list `l` of elements `(g, c', hs, _)` where  `c'` is a constructor name (used for
    alignment with `cs`), `g` is the subgoal, and `hs` is the list of local hypotheses created by
    `cases` in that subgoal. It matches on all of them, and then produces a `ΣΠ`-list of `rcases`
    patterns describing the result, and the list of generated subgoals.
  * `rcases_hint.continue depth es` does the same as `rcases.continue (ps.zip es)`, except the
    patterns `ps` are an output instead of an input, created by matching on everything to depth
    `depth` and recording the successful cases. It returns `ps`, and the list of generated subgoals.
  -/
  unsafe def rcases_hint.process_constructors (explicit : Bool) :
      ℕ →
        listΣ Name →
          List (expr × Name × listΠ expr × List (Name × expr)) →
            tactic (listΣ (listΠ rcases_patt) × List expr)
    | depth, [], _ => pure ([], [])
    | depth, cs, [] => pure (cs.map fun _ => [], [])
    | depth, c :: cs, ls@((g, c', hs, _) :: l) =>
      if c ≠ c' then do
        let (ps, gs) ← rcases_hint.process_constructors depth cs ls
        pure ([] :: ps, gs)
      else do
        let (p, gs) ← set_goals [g] >> rcases_hint.continue depth hs
        let (ps, gs') ← rcases_hint.process_constructors depth cs l
        pure (p :: ps, gs ++ gs')
  /--
  * `rcases_hint_core depth e` does the same as `rcases p e`, except the pattern `p` is an output
    instead of an input, controlled only by the case depth argument `depth`. We use `cases` to depth
    `depth` and then reconstruct an `rcases` pattern `p` that would, if passed to `rcases`, perform
    the same thing as the case tree we just constructed (or at least, the nearest expressible
    approximation to this.)
  * `rcases_hint.process_constructors depth cs l` takes a list of constructor names `cs` and a
    matching list `l` of elements `(g, c', hs, _)` where  `c'` is a constructor name (used for
    alignment with `cs`), `g` is the subgoal, and `hs` is the list of local hypotheses created by
    `cases` in that subgoal. It matches on all of them, and then produces a `ΣΠ`-list of `rcases`
    patterns describing the result, and the list of generated subgoals.
  * `rcases_hint.continue depth es` does the same as `rcases.continue (ps.zip es)`, except the
    patterns `ps` are an output instead of an input, created by matching on everything to depth
    `depth` and recording the successful cases. It returns `ps`, and the list of generated subgoals.
  -/
  unsafe def rcases_hint.continue (explicit : Bool) :
      ℕ → listΠ expr → tactic (listΠ rcases_patt × List expr)
    | depth, [] => Prod.mk [] <$> get_goals
    | depth, e :: es => do
      let (p, gs) ← rcases_hint_core false depth e
      let (ps, gs') ←
        gs.foldlM
            (fun (r : listΠ rcases_patt × List expr) g => do
              let (ps, gs') ← set_goals [g] >> rcases_hint.continue depth es
              pure (merge_list rcases_patt.merge r.1 ps, r.2 ++ gs'))
            ([], [])
      pure
          (match p with
            | none => ps
            | some p => p :: ps,
            gs')
end
#align tactic.rcases_hint_core tactic.rcases_hint_core
#align tactic.rcases_hint.process_constructors tactic.rcases_hint.process_constructors
#align tactic.rcases_hint.continue tactic.rcases_hint.continue

/--
* `rcases? e` is like `rcases e with ...`, except it generates `...` by matching on everything it
can, and it outputs an `rcases` invocation that should have the same effect.
* `rcases? e : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
unsafe def rcases_hint (p : pexpr) (depth : Nat) : tactic rcases_patt := do
  let e ← i_to_expr p
  if e then
      focus1 do
        let (p, gs) ← rcases_hint_core ff tt depth e
        set_goals gs
        pure (p default)
    else do
      let x ← mk_fresh_name
      let n ← revert_kdependencies e semireducible
      tactic.generalize e x <|> do
          let t ← infer_type e
          tactic.assertv x t e
          get_local x >>= tactic.revert
          pure ()
      let h ← tactic.intro1
      focus1 do
          let (p, gs) ← rcases_hint_core ff tt depth h
          set_goals gs
          pure (p default)
#align tactic.rcases_hint tactic.rcases_hint

/-- * `rcases? ⟨e1, e2, e3⟩` is like `rcases ⟨e1, e2, e3⟩ with ...`, except it
  generates `...` by matching on everything it can, and it outputs an `rcases`
  invocation that should have the same effect.
* `rcases? ⟨e1, e2, e3⟩ : n` can be used to control the depth of case splits
  (especially important for recursive types like `nat`, which can be cased as many
  times as you like). -/
unsafe def rcases_hint_many (ps : List pexpr) (depth : Nat) : tactic (listΠ rcases_patt) := do
  let es ←
    ps.mapM fun p => do
        let e ← i_to_expr p
        if e then pure e
          else do
            let x ← mk_fresh_name
            let n ← revert_kdependencies e semireducible
            tactic.generalize e x <|> do
                let t ← infer_type e
                tactic.assertv x t e
                get_local x >>= tactic.revert
                pure ()
            tactic.intro1
  focus1 do
      let (ps, gs) ← rcases_hint.continue ff depth es
      set_goals gs
      pure ps
#align tactic.rcases_hint_many tactic.rcases_hint_many

/-- * `rintro?` is like `rintro ...`, except it generates `...` by introducing and matching on
everything it can, and it outputs an `rintro` invocation that should have the same effect.
* `rintro? : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
unsafe def rintro_hint (depth : Nat) : tactic (listΠ rcases_patt) := do
  let l ← intros
  focus1 do
      let (p, gs) ← rcases_hint.continue ff depth l
      set_goals gs
      pure p
#align tactic.rintro_hint tactic.rintro_hint

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
mutual
  /-- * `rcases_patt_parse_hi` will parse a high precedence `rcases` pattern, `patt_hi`.
    This means only tuples and identifiers are allowed; alternations and type ascriptions
    require `(...)` instead, which switches to `patt`.
  * `rcases_patt_parse` will parse a low precedence `rcases` pattern, `patt`. This consists of a
    `patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
    expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
    example in `rcases e with x : ty <|> skip`.
  * `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
    patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
    `(a | b) : ty` where `a | b` is the `patt_med` part.
  * `rcases_patt_parse_list_rest a` parses an alternation list after the initial pattern, `| b | c`.

  ```lean
  patt ::= patt_med (":" expr)?
  patt_med ::= (patt_hi "|")* patt_hi
  patt_hi ::= id | "rfl" | "_" | "@" patt_hi | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
  ```
  -/
  unsafe def rcases_patt_parse_hi' : parser rcases_patt
    | x =>
      (brackets "(" ")" rcases_patt_parse' <|>
          rcases_patt.tuple <$> brackets "⟨" "⟩" (sep_by (tk ",") rcases_patt_parse') <|>
            tk "-" $> rcases_patt.clear <|>
              tk "@" *> rcases_patt.explicit <$> rcases_patt_parse_hi' <|>
                rcases_patt.one <$> ident_)
        x
  /-- * `rcases_patt_parse_hi` will parse a high precedence `rcases` pattern, `patt_hi`.
    This means only tuples and identifiers are allowed; alternations and type ascriptions
    require `(...)` instead, which switches to `patt`.
  * `rcases_patt_parse` will parse a low precedence `rcases` pattern, `patt`. This consists of a
    `patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
    expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
    example in `rcases e with x : ty <|> skip`.
  * `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
    patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
    `(a | b) : ty` where `a | b` is the `patt_med` part.
  * `rcases_patt_parse_list_rest a` parses an alternation list after the initial pattern, `| b | c`.

  ```lean
  patt ::= patt_med (":" expr)?
  patt_med ::= (patt_hi "|")* patt_hi
  patt_hi ::= id | "rfl" | "_" | "@" patt_hi | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
  ```
  -/
  unsafe def rcases_patt_parse' : parser rcases_patt
    | x =>
      (do
          let pat ← rcases_patt.alts' <$> rcases_patt_parse_list'
          tk ":" *> pat <$> texpr <|> pure pat)
        x
  /-- * `rcases_patt_parse_hi` will parse a high precedence `rcases` pattern, `patt_hi`.
    This means only tuples and identifiers are allowed; alternations and type ascriptions
    require `(...)` instead, which switches to `patt`.
  * `rcases_patt_parse` will parse a low precedence `rcases` pattern, `patt`. This consists of a
    `patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
    expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
    example in `rcases e with x : ty <|> skip`.
  * `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
    patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
    `(a | b) : ty` where `a | b` is the `patt_med` part.
  * `rcases_patt_parse_list_rest a` parses an alternation list after the initial pattern, `| b | c`.

  ```lean
  patt ::= patt_med (":" expr)?
  patt_med ::= (patt_hi "|")* patt_hi
  patt_hi ::= id | "rfl" | "_" | "@" patt_hi | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
  ```
  -/
  unsafe def rcases_patt_parse_list' : parser (listΣ rcases_patt)
    | x => (rcases_patt_parse_hi' >>= rcases_patt_parse_list_rest) x
  /-- * `rcases_patt_parse_hi` will parse a high precedence `rcases` pattern, `patt_hi`.
    This means only tuples and identifiers are allowed; alternations and type ascriptions
    require `(...)` instead, which switches to `patt`.
  * `rcases_patt_parse` will parse a low precedence `rcases` pattern, `patt`. This consists of a
    `patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
    expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
    example in `rcases e with x : ty <|> skip`.
  * `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
    patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
    `(a | b) : ty` where `a | b` is the `patt_med` part.
  * `rcases_patt_parse_list_rest a` parses an alternation list after the initial pattern, `| b | c`.

  ```lean
  patt ::= patt_med (":" expr)?
  patt_med ::= (patt_hi "|")* patt_hi
  patt_hi ::= id | "rfl" | "_" | "@" patt_hi | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
  ```
  -/
  unsafe def rcases_patt_parse_list_rest : rcases_patt → parser (listΣ rcases_patt)
    | pat =>
      tk "|" *>
          List.cons pat <$>
            rcases_patt_parse_list' <|>-- hack to support `-|-` patterns, because `|-` is a token
              tk
              "|-" *>
            List.cons pat <$> rcases_patt_parse_list_rest rcases_patt.clear <|>
          pure [pat]
end
#align tactic.rcases_patt_parse_hi' tactic.rcases_patt_parse_hi'
#align tactic.rcases_patt_parse' tactic.rcases_patt_parse'
#align tactic.rcases_patt_parse_list' tactic.rcases_patt_parse_list'
#align tactic.rcases_patt_parse_list_rest tactic.rcases_patt_parse_list_rest

/-- `rcases_patt_parse_hi` will parse a high precedence `rcases` pattern, `patt_hi`.
This means only tuples and identifiers are allowed; alternations and type ascriptions
require `(...)` instead, which switches to `patt`.
```lean
patt_hi ::= id | "rfl" | "_" | "@" patt_hi | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
```
-/
unsafe def rcases_patt_parse_hi :=
  with_desc "patt_hi" rcases_patt_parse_hi'
#align tactic.rcases_patt_parse_hi tactic.rcases_patt_parse_hi

/-- `rcases_patt_parse` will parse a low precedence `rcases` pattern, `patt`. This consists of a
`patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
example in `rcases e with x : ty <|> skip`.
```lean
patt ::= patt_med (":" expr)?
```
-/
unsafe def rcases_patt_parse :=
  with_desc "patt" rcases_patt_parse'
#align tactic.rcases_patt_parse tactic.rcases_patt_parse

/-- `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
`(a | b) : ty` where `a | b` is the `patt_med` part.
```lean
patt_med ::= (patt_hi "|")* patt_hi
```
-/
unsafe def rcases_patt_parse_list :=
  with_desc "patt_med" rcases_patt_parse_list'
#align tactic.rcases_patt_parse_list tactic.rcases_patt_parse_list

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- Parse the optional depth argument `(: n)?` of `rcases?` and `rintro?`, with default depth 5. -/
unsafe def rcases_parse_depth : parser Nat := do
  let o ← parser.optional (tk ":" *> small_nat)
  pure <| o 5
#align tactic.rcases_parse_depth tactic.rcases_parse_depth

/-- The arguments to `rcases`, which in fact dispatch to several other tactics.
* `rcases? expr (: n)?` or `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint`
* `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint_many`
* `rcases (h :)? expr (with patt)?` calls `rcases`
* `rcases ⟨expr, ...⟩ (with patt)?` calls `rcases_many`
-/
unsafe inductive rcases_args
  | hint (tgt : Sum pexpr (List pexpr)) (depth : Nat)
  | rcases (name : Option Name) (tgt : pexpr) (pat : rcases_patt)
  | rcases_many (tgt : listΠ pexpr) (pat : rcases_patt)
  deriving has_reflect
#align tactic.rcases_args tactic.rcases_args

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- Syntax for a `rcases` pattern:
* `rcases? expr (: n)?`
* `rcases (h :)? expr (with patt_list (: expr)?)?`. -/
unsafe def rcases_parse : parser rcases_args :=
  with_desc "('?' expr (: n)?) | ((h :)? expr (with patt)?)" do
    let hint ← parser.optional (tk "?")
    let p ← Sum.inr <$> brackets "⟨" "⟩" (sep_by (tk ",") (parser.pexpr 0)) <|> Sum.inl <$> texpr
    match hint with
      | none => do
        let p ←
          (do
                let Sum.inl (expr.local_const h _ _ _) ← pure p
                tk ":" *> (@Sum.inl _ (Sum pexpr (List pexpr)) ∘ Prod.mk h) <$> texpr) <|>
              pure (Sum.inr p)
        let ids ← parser.optional (tk "with" *> rcases_patt_parse)
        let ids := ids (rcases_patt.tuple [])
        pure <|
            match p with
            | Sum.inl (Name, tgt) => rcases_args.rcases (some Name) tgt ids
            | Sum.inr (Sum.inl tgt) => rcases_args.rcases none tgt ids
            | Sum.inr (Sum.inr tgts) => rcases_args.rcases_many tgts ids
      | some _ => do
        let depth ← rcases_parse_depth
        pure <| rcases_args.hint p depth
#align tactic.rcases_parse tactic.rcases_parse

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.many -/
mutual
  /-- `rintro_patt_parse_hi` and `rintro_patt_parse` are like `rcases_patt_parse`, but is used for
  parsing top level `rintro` patterns, which allow sequences like `(x y : t)` in addition to simple
  `rcases` patterns.

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

  ```lean
  rintro_patt ::= (rintro_patt_hi+ | patt_med) (":" expr)?
  rintro_patt_low ::= rintro_patt_hi* (":" expr)?
  rintro_patt_hi ::= patt_hi | "(" rintro_patt ")"
  ```
  -/
  unsafe def rintro_patt_parse_hi' : parser (listΠ rcases_patt)
    | x =>
      (brackets "(" ")" (rintro_patt_parse' true) <|> do
          let p ← rcases_patt_parse_hi
          pure [p])
        x
  /-- `rintro_patt_parse_hi` and `rintro_patt_parse` are like `rcases_patt_parse`, but is used for
  parsing top level `rintro` patterns, which allow sequences like `(x y : t)` in addition to simple
  `rcases` patterns.

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

  ```lean
  rintro_patt ::= (rintro_patt_hi+ | patt_med) (":" expr)?
  rintro_patt_low ::= rintro_patt_hi* (":" expr)?
  rintro_patt_hi ::= patt_hi | "(" rintro_patt ")"
  ```
  -/
  unsafe def rintro_patt_parse' : Bool → parser (listΠ rcases_patt)
    | med => do
      let ll ← parser.many rintro_patt_parse_hi'
      let pats ←
        match med, ll.join with
          | tt, [] => failure
          | tt, [pat] => do
            let l ← rcases_patt_parse_list_rest pat
            pure [rcases_patt.alts' l]
          | _, pats => pure pats
      (do
            tk ":"
            let e ← texpr
            pure (pats fun p => rcases_patt.typed p e)) <|>
          pure pats
end
#align tactic.rintro_patt_parse_hi' tactic.rintro_patt_parse_hi'
#align tactic.rintro_patt_parse' tactic.rintro_patt_parse'

/-- `rintro_patt_parse_hi` will parse a high precedence `rcases` pattern, `rintro_patt_hi` below.
This means only tuples and identifiers are allowed; alternations and type ascriptions
require `(...)` instead, which switches to `patt`.
```lean
rintro_patt_hi ::= patt_hi | "(" rintro_patt ")"
```
-/
unsafe def rintro_patt_parse_hi :=
  with_desc "rintro_patt_hi" rintro_patt_parse_hi'
#align tactic.rintro_patt_parse_hi tactic.rintro_patt_parse_hi

/-- `rintro_patt_parse` will parse a low precedence `rcases` pattern, `rintro_patt` below.
This consists of either a sequence of patterns `p1 p2 p3` or an alternation list `p1 | p2 | p3`
treated as a single pattern, optionally followed by a `: ty` type ascription, which applies to
every pattern in the list.
```lean
rintro_patt ::= (rintro_patt_hi+ | patt_med) (":" expr)?
```
-/
unsafe def rintro_patt_parse :=
  with_desc "rintro_patt" <| rintro_patt_parse' true
#align tactic.rintro_patt_parse tactic.rintro_patt_parse

/--
`rintro_patt_parse_low` parses `rintro_patt_low`, which is the same as `rintro_patt_parse tt` but
it does not permit an unparenthesized alternation list, it must have the form `p1 p2 p3 (: ty)?`.
```lean
rintro_patt_low ::= rintro_patt_hi* (":" expr)?
```
-/
unsafe def rintro_patt_parse_low :=
  with_desc "rintro_patt_low" <| rintro_patt_parse' false
#align tactic.rintro_patt_parse_low tactic.rintro_patt_parse_low

/-- Syntax for a `rintro` pattern: `('?' (: n)?) | rintro_patt`. -/
unsafe def rintro_parse : parser (Sum (listΠ rcases_patt) Nat) :=
  with_desc "('?' (: n)?) | patt*" <|
    tk "?" >> Sum.inr <$> rcases_parse_depth <|> Sum.inl <$> rintro_patt_parse_low
#align tactic.rintro_parse tactic.rintro_parse

namespace Interactive

open Interactive Interactive.Types Expr

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

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

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

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

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

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

`rcases? e` will perform case splits on `e` in the same way as `rcases e`,
but rather than accepting a pattern, it does a maximal cases and prints the
pattern that would produce this case splitting. The default maximum depth is 5,
but this can be modified with `rcases? e : n`.
-/
unsafe def rcases : parse rcases_parse → tactic Unit
  | rcases_args.rcases h p ids => tactic.rcases h p ids
  | rcases_args.rcases_many ps ids => tactic.rcases_many ps ids
  | rcases_args.hint p depth => do
    let (pe, patt) ←
      match p with
        | Sum.inl p => Prod.mk <$> pp p <*> rcases_hint p depth
        | Sum.inr ps => do
          let patts ← rcases_hint_many ps depth
          let pes ← ps.mapM pp
          pure (format.bracket "⟨" "⟩" (format.comma_separated pes), rcases_patt.tuple patts)
    let ppat ← pp patt
    trace <| ↑"Try this: rcases " ++ pe ++ " with " ++ ppat
#align tactic.interactive.rcases tactic.interactive.rcases

add_tactic_doc
  { Name := "rcases"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.rcases]
    tags := ["induction"] }

/-- The `rintro` tactic is a combination of the `intros` tactic with `rcases` to
allow for destructuring patterns while introducing variables. See `rcases` for
a description of supported patterns. For example, `rintro (a | ⟨b, c⟩) ⟨d, e⟩`
will introduce two variables, and then do case splits on both of them producing
two subgoals, one with variables `a d e` and the other with `b c d e`.

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

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

`rintros` is an alias for `rintro`.
-/
unsafe def rintro : parse rintro_parse → tactic Unit
  | Sum.inl [] => intros []
  | Sum.inl l => tactic.rintro l
  | Sum.inr depth => do
    let ps ← tactic.rintro_hint depth
    let fs ←
      ps.mapM fun p => do
          let f ← pp <| p.format true
          pure <| format.space ++ format.group f
    trace <| ↑"Try this: rintro" ++ format.join fs
#align tactic.interactive.rintro tactic.interactive.rintro

/-- Alias for `rintro`. -/
unsafe def rintros :=
  rintro
#align tactic.interactive.rintros tactic.interactive.rintros

add_tactic_doc
  { Name := "rintro"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.rintro, `tactic.interactive.rintros]
    tags := ["induction"]
    inheritDescriptionFrom := `tactic.interactive.rintro }

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- Parses `patt? (: expr)? (:= expr)?`, the arguments for `obtain`.
 (This is almost the same as `rcases_patt_parse`,
but it allows the pattern part to be empty.) -/
unsafe def obtain_parse :
    parser ((Option rcases_patt × Option pexpr) × Option (Sum pexpr (List pexpr))) :=
  with_desc "patt? (: expr)? (:= expr)?" do
    let (pat, tp) ←
      (do
            let pat ← rcases_patt_parse
            pure <|
                match pat with
                | rcases_patt.typed pat tp => (some pat, some tp)
                | _ => (some pat, none)) <|>
          Prod.mk none <$> parser.optional (tk ":" >> texpr)
    Prod.mk (pat, tp) <$>
        parser.optional do
          tk ":="
          guard tp >> Sum.inr <$> brackets "⟨" "⟩" (sep_by (tk ",") (parser.pexpr 0)) <|>
              Sum.inl <$> texpr
#align tactic.interactive.obtain_parse tactic.interactive.obtain_parse

/-- The `obtain` tactic is a combination of `have` and `rcases`. See `rcases` for
a description of supported patterns.

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

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

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

If `type` is omitted, `:= proof` is required.
-/
unsafe def obtain : parse obtain_parse → tactic Unit
  | ((pat, _), some (Sum.inr val)) => tactic.rcases_many val (pat.getD default)
  | ((pat, none), some (Sum.inl val)) => tactic.rcases none val (pat.getD default)
  | ((pat, some tp), some (Sum.inl val)) => tactic.rcases none val <| (pat.getD default).typed tp
  | ((pat, some tp), none) => do
    let nm ← mk_fresh_name
    let e ← to_expr tp >>= assert nm
    let g :: gs ← get_goals
    set_goals gs
    tactic.rcases none ``($(e)) (pat (rcases_patt.one `this))
    let gs ← get_goals
    set_goals (g :: gs)
  | ((pat, none), none) =>
    fail <|
      "`obtain` requires either an expected type or a value.\n" ++
        "usage: `obtain ⟨patt⟩? : type (:= val)?` or `obtain ⟨patt⟩? (: type)? := val`"
#align tactic.interactive.obtain tactic.interactive.obtain

add_tactic_doc
  { Name := "obtain"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.obtain]
    tags := ["induction"] }

/-- The `rsuffices` tactic is an alternative version of `suffices`, that allows the usage
of any syntax that would be valid in an `obtain` block. This tactic just calls `obtain`
on the expression, and then `rotate 1`.
-/
unsafe def rsuffices (h : parse obtain_parse) : tactic Unit :=
  focus1 <| obtain h >> tactic.rotate 1
#align tactic.interactive.rsuffices tactic.interactive.rsuffices

add_tactic_doc
  { Name := "rsuffices"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.rsuffices]
    tags := ["induction"] }

/--
The `rsufficesI` tactic is an instance-cache aware version of `rsuffices`; it resets the instance
cache on the resulting goals.
-/
unsafe def rsufficesI (h : parse obtain_parse) : tactic Unit :=
  andthen (rsuffices h) resetI
#align tactic.interactive.rsufficesI tactic.interactive.rsufficesI

add_tactic_doc
  { Name := "rsufficesI"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.rsufficesI]
    tags := ["induction", "type class"] }

end Interactive

end Tactic


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.group.defs
import data.equiv.set
import logic.embedding
import order.rel_classes

/-!
# Relation homomorphisms, embeddings, isomorphisms

This file defines relation homomorphisms, embeddings, isomorphisms and order embeddings and
isomorphisms.

## Main declarations

* `rel_hom`: Relation homomorphism. A `rel_hom r s` is a function `f : α → β` such that
  `r a b → s (f a) (f b)`.
* `rel_embedding`: Relation embedding. A `rel_embedding r s` is an embedding `f : α ↪ β` such that
  `r a b ↔ s (f a) (f b)`.
* `rel_iso`: Relation isomorphism. A `rel_iso r s` is an equivalence `f : α ≃ β` such that
  `r a b ↔ s (f a) (f b)`.
* `order_embedding`: Relation embedding. An `order_embedding α β` is an embedding `f : α ↪ β` such
  that `a ≤ b ↔ f a ≤ f b`. Defined as an abbreviation of `@rel_embedding α β (≤) (≤)`.
* `order_iso`: Relation isomorphism. An `order_iso α β` is an equivalence `f : α ≃ β` such that
  `a ≤ b ↔ f a ≤ f b`. Defined as an abbreviation of `@rel_iso α β (≤) (≤)`.
* `sum_lex_congr`, `prod_lex_congr`: Creates a relation homomorphism between two `sum_lex` or two
  `prod_lex` from relation homomorphisms between their arguments.

## Notation

* `→r`: `rel_hom`
* `↪r`: `rel_embedding`
* `≃r`: `rel_iso`
* `↪o`: `order_embedding`
* `≃o`: `order_iso`
-/

open function

universes u v w
variables {α β γ : Type*} {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop}

/-- A relation homomorphism with respect to a given pair of relations `r` and `s`
is a function `f : α → β` such that `r a b → s (f a) (f b)`. -/
@[nolint has_inhabited_instance]
structure rel_hom {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) :=
(to_fun : α → β)
(map_rel' : ∀ {a b}, r a b → s (to_fun a) (to_fun b))

infix ` →r `:25 := rel_hom

namespace rel_hom

instance : has_coe_to_fun (r →r s) (λ _, α → β) := ⟨λ o, o.to_fun⟩

initialize_simps_projections rel_hom (to_fun → apply)

theorem map_rel (f : r →r s) : ∀ {a b}, r a b → s (f a) (f b) := f.map_rel'

@[simp] theorem coe_fn_mk (f : α → β) (o) :
  (@rel_hom.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_fun (f : r →r s) : (f.to_fun : α → β) = f := rfl

/-- The map `coe_fn : (r →r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r →r s) (α → β) coe_fn
| ⟨f₁, o₁⟩ ⟨f₂, o₂⟩ h := by { congr, exact h }

@[ext] theorem ext ⦃f g : r →r s⦄ (h : ∀ x, f x = g x) : f = g :=
coe_fn_injective (funext h)

theorem ext_iff {f g : r →r s} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

/-- Identity map is a relation homomorphism. -/
@[refl, simps] protected def id (r : α → α → Prop) : r →r r :=
⟨λ x, x, λ a b x, x⟩

/-- Composition of two relation homomorphisms is a relation homomorphism. -/
@[trans, simps] protected def comp (g : s →r t) (f : r →r s) : r →r t :=
⟨λ x, g (f x), λ a b h, g.2 (f.2 h)⟩

/-- A relation homomorphism is also a relation homomorphism between dual relations. -/
protected def swap (f : r →r s) : swap r →r swap s :=
⟨f, λ a b, f.map_rel⟩

/-- A function is a relation homomorphism from the preimage relation of `s` to `s`. -/
def preimage (f : α → β) (s : β → β → Prop) : f ⁻¹'o s →r s := ⟨f, λ a b, id⟩

protected theorem is_irrefl : ∀ (f : r →r s) [is_irrefl β s], is_irrefl α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a h, H _ (o h)⟩

protected theorem is_asymm : ∀ (f : r →r s) [is_asymm β s], is_asymm α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b h₁ h₂, H _ _ (o h₁) (o h₂)⟩

protected theorem acc (f : r →r s) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (f.map_rel h) _ rfl⟩
end

protected theorem well_founded : ∀ (f : r →r s) (h : well_founded s), well_founded r
| f ⟨H⟩ := ⟨λ a, f.acc _ (H _)⟩

lemma map_inf {α β : Type*} [semilattice_inf α] [linear_order β]
  (a : ((<) : β → β → Prop) →r ((<) : α → α → Prop)) (m n : β) : a (m ⊓ n) = a m ⊓ a n :=
(strict_mono.monotone $ λ x y, a.map_rel).map_inf m n

lemma map_sup {α β : Type*} [semilattice_sup α] [linear_order β]
  (a : ((>) : β → β → Prop) →r ((>) : α → α → Prop)) (m n : β) : a (m ⊔ n) = a m ⊔ a n :=
@rel_hom.map_inf (order_dual α) (order_dual β) _ _ _ _ _

end rel_hom

/-- An increasing function is injective -/
lemma injective_of_increasing (r : α → α → Prop) (s : β → β → Prop) [is_trichotomous α r]
  [is_irrefl β s] (f : α → β) (hf : ∀ {x y}, r x y → s (f x) (f y)) : injective f :=
begin
  intros x y hxy,
  rcases trichotomous_of r x y with h | h | h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this,
  exact h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this
end

/-- An increasing function is injective -/
lemma rel_hom.injective_of_increasing [is_trichotomous α r]
  [is_irrefl β s] (f : r →r s) : injective f :=
injective_of_increasing r s f (λ x y, f.map_rel)

theorem surjective.well_founded_iff {f : α → β} (hf : surjective f)
  (o : ∀ {a b}, r a b ↔ s (f a) (f b)) : well_founded r ↔ well_founded s :=
iff.intro (begin
  apply rel_hom.well_founded,
  refine rel_hom.mk _ _,
  {exact classical.some hf.has_right_inverse},
  intros a b h, apply o.2, convert h,
  iterate 2 { apply classical.some_spec hf.has_right_inverse },
end) (rel_hom.well_founded ⟨f, λ _ _, o.1⟩)

/-- A relation embedding with respect to a given pair of relations `r` and `s`
is an embedding `f : α ↪ β` such that `r a b ↔ s (f a) (f b)`. -/
structure rel_embedding {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ↪ β :=
(map_rel_iff' : ∀ {a b}, s (to_embedding a) (to_embedding b) ↔ r a b)

infix ` ↪r `:25 := rel_embedding

/-- An order embedding is an embedding `f : α ↪ β` such that `a ≤ b ↔ (f a) ≤ (f b)`.
This definition is an abbreviation of `rel_embedding (≤) (≤)`. -/
abbreviation order_embedding (α β : Type*) [has_le α] [has_le β] :=
@rel_embedding α β (≤) (≤)

infix ` ↪o `:25 := order_embedding

/-- The induced relation on a subtype is an embedding under the natural inclusion. -/
definition subtype.rel_embedding {X : Type*} (r : X → X → Prop) (p : X → Prop) :
  ((subtype.val : subtype p → X) ⁻¹'o r) ↪r r :=
⟨embedding.subtype p, λ x y, iff.rfl⟩

theorem preimage_equivalence {α β} (f : α → β) {s : β → β → Prop}
  (hs : equivalence s) : equivalence (f ⁻¹'o s) :=
⟨λ a, hs.1 _, λ a b h, hs.2.1 h, λ a b c h₁ h₂, hs.2.2 h₁ h₂⟩

namespace rel_embedding

/-- A relation embedding is also a relation homomorphism -/
def to_rel_hom (f : r ↪r s) : (r →r s) :=
{ to_fun := f.to_embedding.to_fun,
  map_rel' := λ x y, (map_rel_iff' f).mpr }

instance : has_coe (r ↪r s) (r →r s) := ⟨to_rel_hom⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ↪r s) (λ _, α → β) := ⟨λ o, o.to_embedding⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (h : r ↪r s) : α → β := h

initialize_simps_projections rel_embedding (to_embedding_to_fun → apply, -to_embedding)

@[simp] lemma to_rel_hom_eq_coe (f : r ↪r s) : f.to_rel_hom = f := rfl

@[simp] lemma coe_coe_fn (f : r ↪r s) : ((f : r →r s) : α → β) = f := rfl

theorem injective (f : r ↪r s) : injective f := f.inj'

theorem map_rel_iff (f : r ↪r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ↪ β) (o) :
  (@rel_embedding.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_embedding (f : r ↪r s) : (f.to_embedding : α → β) = f := rfl

/-- The map `coe_fn : (r ↪r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r ↪r s) (α → β) coe_fn
| ⟨⟨f₁, h₁⟩, o₁⟩ ⟨⟨f₂, h₂⟩, o₂⟩ h := by { congr, exact h }

@[ext] theorem ext ⦃f g : r ↪r s⦄ (h : ∀ x, f x = g x) : f = g :=
coe_fn_injective (funext h)

theorem ext_iff {f g : r ↪r s} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

/-- Identity map is a relation embedding. -/
@[refl, simps] protected def refl (r : α → α → Prop) : r ↪r r :=
⟨embedding.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation embeddings is a relation embedding. -/
@[trans] protected def trans (f : r ↪r s) (g : s ↪r t) : r ↪r t :=
⟨f.1.trans g.1, λ a b, by simp [f.map_rel_iff, g.map_rel_iff]⟩

instance (r : α → α → Prop) : inhabited (r ↪r r) := ⟨rel_embedding.refl _⟩

theorem trans_apply (f : r ↪r s) (g : s ↪r t) (a : α) : (f.trans g) a = g (f a) := rfl

@[simp] theorem coe_trans (f : r ↪r s) (g : s ↪r t) : ⇑(f.trans g) = g ∘ f := rfl

/-- A relation embedding is also a relation embedding between dual relations. -/
protected def swap (f : r ↪r s) : swap r ↪r swap s :=
⟨f.to_embedding, λ a b, f.map_rel_iff⟩

/-- If `f` is injective, then it is a relation embedding from the
  preimage relation of `s` to `s`. -/
def preimage (f : α ↪ β) (s : β → β → Prop) : f ⁻¹'o s ↪r s := ⟨f, λ a b, iff.rfl⟩

theorem eq_preimage (f : r ↪r s) : r = f ⁻¹'o s :=
by { ext a b, exact f.map_rel_iff.symm }

protected theorem is_irrefl (f : r ↪r s) [is_irrefl β s] : is_irrefl α r :=
⟨λ a, mt f.map_rel_iff.2 (irrefl (f a))⟩

protected theorem is_refl (f : r ↪r s) [is_refl β s] : is_refl α r :=
⟨λ a, f.map_rel_iff.1 $ refl _⟩

protected theorem is_symm (f : r ↪r s) [is_symm β s] : is_symm α r :=
⟨λ a b, imp_imp_imp f.map_rel_iff.2 f.map_rel_iff.1 symm⟩

protected theorem is_asymm (f : r ↪r s) [is_asymm β s] : is_asymm α r :=
⟨λ a b h₁ h₂, asymm (f.map_rel_iff.2 h₁) (f.map_rel_iff.2 h₂)⟩

protected theorem is_antisymm : ∀ (f : r ↪r s) [is_antisymm β s], is_antisymm α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b h₁ h₂, f.inj' (H _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_trans : ∀ (f : r ↪r s) [is_trans β s], is_trans α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b c h₁ h₂, o.1 (H _ _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_total : ∀ (f : r ↪r s) [is_total β s], is_total α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o o).1 (H _ _)⟩

protected theorem is_preorder : ∀ (f : r ↪r s) [is_preorder β s], is_preorder α r
| f H := by exactI {..f.is_refl, ..f.is_trans}

protected theorem is_partial_order : ∀ (f : r ↪r s) [is_partial_order β s], is_partial_order α r
| f H := by exactI {..f.is_preorder, ..f.is_antisymm}

protected theorem is_linear_order : ∀ (f : r ↪r s) [is_linear_order β s], is_linear_order α r
| f H := by exactI {..f.is_partial_order, ..f.is_total}

protected theorem is_strict_order : ∀ (f : r ↪r s) [is_strict_order β s], is_strict_order α r
| f H := by exactI {..f.is_irrefl, ..f.is_trans}

protected theorem is_trichotomous : ∀ (f : r ↪r s) [is_trichotomous β s], is_trichotomous α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o (or_congr f.inj'.eq_iff o)).1 (H _ _)⟩

protected theorem is_strict_total_order' :
  ∀ (f : r ↪r s) [is_strict_total_order' β s], is_strict_total_order' α r
| f H := by exactI {..f.is_trichotomous, ..f.is_strict_order}

protected theorem acc (f : r ↪r s) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (f.map_rel_iff.2 h) _ rfl⟩
end

protected theorem well_founded : ∀ (f : r ↪r s) (h : well_founded s), well_founded r
| f ⟨H⟩ := ⟨λ a, f.acc _ (H _)⟩

protected theorem is_well_order : ∀ (f : r ↪r s) [is_well_order β s], is_well_order α r
| f H := by exactI {wf := f.well_founded H.wf, ..f.is_strict_total_order'}

/--
To define an relation embedding from an antisymmetric relation `r` to a reflexive relation `s` it
suffices to give a function together with a proof that it satisfies `s (f a) (f b) ↔ r a b`.
-/
def of_map_rel_iff (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) : r ↪r s :=
{ to_fun := f,
  inj' := λ x y h, antisymm ((hf _ _).1 (h ▸ refl _)) ((hf _ _).1 (h ▸ refl _)),
  map_rel_iff' := hf }

@[simp]
lemma of_map_rel_iff_coe (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) :
  ⇑(of_map_rel_iff f hf : r ↪r s) = f :=
rfl

/-- It suffices to prove `f` is monotone between strict relations
  to show it is a relation embedding. -/
def of_monotone [is_trichotomous α r] [is_asymm β s] (f : α → β)
  (H : ∀ a b, r a b → s (f a) (f b)) : r ↪r s :=
begin
  haveI := @is_asymm.is_irrefl β s _,
  refine ⟨⟨f, λ a b e, _⟩, λ a b, ⟨λ h, _, H _ _⟩⟩,
  { refine ((@trichotomous _ r _ a b).resolve_left _).resolve_right _;
    exact λ h, @irrefl _ s _ _ (by simpa [e] using H _ _ h) },
  { refine (@trichotomous _ r _ a b).resolve_right (or.rec (λ e, _) (λ h', _)),
    { subst e, exact irrefl _ h },
    { exact asymm (H _ _ h') h } }
end

@[simp] theorem of_monotone_coe [is_trichotomous α r] [is_asymm β s] (f : α → β) (H) :
  (@of_monotone _ _ r s _ _ f H : α → β) = f := rfl

/-- Embeddings of partial orders that preserve `<` also preserve `≤`. -/
def order_embedding_of_lt_embedding [partial_order α] [partial_order β]
  (f : ((<) : α → α → Prop) ↪r ((<) : β → β → Prop)) :
  α ↪o β :=
{ map_rel_iff' := by { intros, simp [le_iff_lt_or_eq,f.map_rel_iff, f.injective.eq_iff] }, .. f }

@[simp]
lemma order_embedding_of_lt_embedding_apply [partial_order α] [partial_order β]
  {f : ((<) : α → α → Prop) ↪r ((<) : β → β → Prop)} {x : α} :
  order_embedding_of_lt_embedding f x = f x := rfl

end rel_embedding

namespace order_embedding

variables [preorder α] [preorder β] (f : α ↪o β)

/-- `<` is preserved by order embeddings of preorders. -/
def lt_embedding : ((<) : α → α → Prop) ↪r ((<) : β → β → Prop) :=
{ map_rel_iff' := by intros; simp [lt_iff_le_not_le, f.map_rel_iff], .. f }

@[simp] lemma lt_embedding_apply (x : α) : f.lt_embedding x = f x := rfl

@[simp] theorem le_iff_le {a b} : (f a) ≤ (f b) ↔ a ≤ b := f.map_rel_iff

@[simp] theorem lt_iff_lt {a b} : f a < f b ↔ a < b :=
f.lt_embedding.map_rel_iff

@[simp] lemma eq_iff_eq {a b} : f a = f b ↔ a = b := f.injective.eq_iff

protected theorem monotone : monotone f := λ x y, f.le_iff_le.2

protected theorem strict_mono : strict_mono f := λ x y, f.lt_iff_lt.2

protected theorem acc (a : α) : acc (<) (f a) → acc (<) a :=
f.lt_embedding.acc a

protected theorem well_founded :
  well_founded ((<) : β → β → Prop) → well_founded ((<) : α → α → Prop) :=
f.lt_embedding.well_founded

protected theorem is_well_order [is_well_order β (<)] : is_well_order α (<) :=
f.lt_embedding.is_well_order

/-- An order embedding is also an order embedding between dual orders. -/
protected def dual : order_dual α ↪o order_dual β :=
⟨f.to_embedding, λ a b, f.map_rel_iff⟩

/--
To define an order embedding from a partial order to a preorder it suffices to give a function
together with a proof that it satisfies `f a ≤ f b ↔ a ≤ b`.
-/
def of_map_le_iff {α β} [partial_order α] [preorder β] (f : α → β)
  (hf : ∀ a b, f a ≤ f b ↔ a ≤ b) : α ↪o β :=
rel_embedding.of_map_rel_iff f hf

@[simp] lemma coe_of_map_le_iff {α β} [partial_order α] [preorder β] {f : α → β} (h) :
  ⇑(of_map_le_iff f h) = f := rfl

/-- A strictly monotone map from a linear order is an order embedding. --/
def of_strict_mono {α β} [linear_order α] [preorder β] (f : α → β)
  (h : strict_mono f) : α ↪o β :=
of_map_le_iff f (λ _ _, h.le_iff_le)

@[simp] lemma coe_of_strict_mono {α β} [linear_order α] [preorder β] {f : α → β}
  (h : strict_mono f) : ⇑(of_strict_mono f h) = f := rfl

/-- Embedding of a subtype into the ambient type as an `order_embedding`. -/
@[simps {fully_applied := ff}] def subtype (p : α → Prop) : subtype p ↪o α :=
⟨embedding.subtype p, λ x y, iff.rfl⟩

end order_embedding

/-- A relation isomorphism is an equivalence that is also a relation embedding. -/
structure rel_iso {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ≃ β :=
(map_rel_iff' : ∀ {a b}, s (to_equiv a) (to_equiv b) ↔ r a b)

infix ` ≃r `:25 := rel_iso

/-- An order isomorphism is an equivalence such that `a ≤ b ↔ (f a) ≤ (f b)`.
This definition is an abbreviation of `rel_iso (≤) (≤)`. -/
abbreviation order_iso (α β : Type*) [has_le α] [has_le β] := @rel_iso α β (≤) (≤)

infix ` ≃o `:25 := order_iso

namespace rel_iso

/-- Convert an `rel_iso` to an `rel_embedding`. This function is also available as a coercion
but often it is easier to write `f.to_rel_embedding` than to write explicitly `r` and `s`
in the target type. -/
def to_rel_embedding (f : r ≃r s) : r ↪r s :=
⟨f.to_equiv.to_embedding, f.map_rel_iff'⟩

instance : has_coe (r ≃r s) (r ↪r s) := ⟨to_rel_embedding⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ≃r s) (λ _, α → β) := ⟨λ f, f⟩

@[simp] lemma to_rel_embedding_eq_coe (f : r ≃r s) : f.to_rel_embedding = f := rfl

@[simp] lemma coe_coe_fn (f : r ≃r s) : ((f : r ↪r s) : α → β) = f := rfl

theorem map_rel_iff (f : r ≃r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ≃ β) (o : ∀ ⦃a b⦄, s (f a) (f b) ↔ r a b) :
  (rel_iso.mk f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_equiv (f : r ≃r s) : (f.to_equiv : α → β) = f := rfl

theorem to_equiv_injective : injective (to_equiv : (r ≃r s) → α ≃ β)
| ⟨e₁, o₁⟩ ⟨e₂, o₂⟩ h := by { congr, exact h }

/-- The map `coe_fn : (r ≃r s) → (α → β)` is injective. Lean fails to parse
`function.injective (λ e : r ≃r s, (e : α → β))`, so we use a trick to say the same. -/
theorem coe_fn_injective : @function.injective (r ≃r s) (α → β) coe_fn :=
equiv.coe_fn_injective.comp to_equiv_injective

@[ext] theorem ext ⦃f g : r ≃r s⦄ (h : ∀ x, f x = g x) : f = g :=
coe_fn_injective (funext h)

theorem ext_iff {f g : r ≃r s} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

/-- Inverse map of a relation isomorphism is a relation isomorphism. -/
@[symm] protected def symm (f : r ≃r s) : s ≃r r :=
⟨f.to_equiv.symm, λ a b, by erw [← f.map_rel_iff, f.1.apply_symm_apply, f.1.apply_symm_apply]⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : r ≃r s) : α → β := h
/-- See Note [custom simps projection]. -/
def simps.symm_apply (h : r ≃r s) : β → α := h.symm

initialize_simps_projections rel_iso
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

/-- Identity map is a relation isomorphism. -/
@[refl, simps apply] protected def refl (r : α → α → Prop) : r ≃r r :=
⟨equiv.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation isomorphisms is a relation isomorphism. -/
@[trans, simps apply] protected def trans (f₁ : r ≃r s) (f₂ : s ≃r t) : r ≃r t :=
⟨f₁.to_equiv.trans f₂.to_equiv, λ a b, f₂.map_rel_iff.trans f₁.map_rel_iff⟩

instance (r : α → α → Prop) : inhabited (r ≃r r) := ⟨rel_iso.refl _⟩

@[simp] lemma default_def (r : α → α → Prop) : default (r ≃r r) = rel_iso.refl r := rfl

/-- a relation isomorphism is also a relation isomorphism between dual relations. -/
protected def swap (f : r ≃r s) : (swap r) ≃r (swap s) :=
⟨f.to_equiv, λ _ _, f.map_rel_iff⟩

@[simp] theorem coe_fn_symm_mk (f o) : ((@rel_iso.mk _ _ r s f o).symm : β → α) = f.symm :=
rfl

@[simp] theorem apply_symm_apply (e : r ≃r s) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_symm_apply x

@[simp] theorem symm_apply_apply (e : r ≃r s) (x : α) : e.symm (e x) = x :=
e.to_equiv.symm_apply_apply x

theorem rel_symm_apply (e : r ≃r s) {x y} : r x (e.symm y) ↔ s (e x) y :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

theorem symm_apply_rel (e : r ≃r s) {x y} : r (e.symm x) y ↔ s x (e y) :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

protected lemma bijective (e : r ≃r s) : bijective e := e.to_equiv.bijective
protected lemma injective (e : r ≃r s) : injective e := e.to_equiv.injective
protected lemma surjective (e : r ≃r s) : surjective e := e.to_equiv.surjective

@[simp] lemma range_eq (e : r ≃r s) : set.range e = set.univ := e.surjective.range_eq

@[simp] lemma eq_iff_eq (f : r ≃r s) {a b} : f a = f b ↔ a = b :=
f.injective.eq_iff

/-- Any equivalence lifts to a relation isomorphism between `s` and its preimage. -/
protected def preimage (f : α ≃ β) (s : β → β → Prop) : f ⁻¹'o s ≃r s := ⟨f, λ a b, iff.rfl⟩

/-- A surjective relation embedding is a relation isomorphism. -/
@[simps apply]
noncomputable def of_surjective (f : r ↪r s) (H : surjective f) : r ≃r s :=
⟨equiv.of_bijective f ⟨f.injective, H⟩, λ a b, f.map_rel_iff⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the sum.
-/
def sum_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  sum.lex r₁ r₂ ≃r sum.lex s₁ s₂ :=
⟨equiv.sum_congr e₁.to_equiv e₂.to_equiv, λ a b,
 by cases e₁ with f hf; cases e₂ with g hg;
    cases a; cases b; simp [hf, hg]⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the product.
-/
def prod_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  prod.lex r₁ r₂ ≃r prod.lex s₁ s₂ :=
⟨equiv.prod_congr e₁.to_equiv e₂.to_equiv,
  λ a b, by simp [prod.lex_def, e₁.map_rel_iff, e₂.map_rel_iff]⟩

instance : group (r ≃r r) :=
{ one := rel_iso.refl r,
  mul := λ f₁ f₂, f₂.trans f₁,
  inv := rel_iso.symm,
  mul_assoc := λ f₁ f₂ f₃, rfl,
  one_mul := λ f, ext $ λ _, rfl,
  mul_one := λ f, ext $ λ _, rfl,
  mul_left_inv := λ f, ext f.symm_apply_apply }

@[simp] lemma coe_one : ⇑(1 : r ≃r r) = id := rfl

@[simp] lemma coe_mul (e₁ e₂ : r ≃r r) : ⇑(e₁ * e₂) = e₁ ∘ e₂ := rfl

lemma mul_apply (e₁ e₂ : r ≃r r) (x : α) : (e₁ * e₂) x = e₁ (e₂ x) := rfl

@[simp] lemma inv_apply_self (e : r ≃r r) (x) : e⁻¹ (e x) = x := e.symm_apply_apply x

@[simp] lemma apply_inv_self (e : r ≃r r) (x) : e (e⁻¹ x) = x := e.apply_symm_apply x

end rel_iso

namespace order_iso

section has_le

variables [has_le α] [has_le β] [has_le γ]

/-- Reinterpret an order isomorphism as an order embedding. -/
def to_order_embedding (e : α ≃o β) : α ↪o β :=
e.to_rel_embedding

@[simp] lemma coe_to_order_embedding (e : α ≃o β) :
  ⇑(e.to_order_embedding) = e := rfl

protected lemma bijective (e : α ≃o β) : bijective e := e.to_equiv.bijective
protected lemma injective (e : α ≃o β) : injective e := e.to_equiv.injective
protected lemma surjective (e : α ≃o β) : surjective e := e.to_equiv.surjective

@[simp] lemma range_eq (e : α ≃o β) : set.range e = set.univ := e.surjective.range_eq

@[simp] lemma apply_eq_iff_eq (e : α ≃o β) {x y : α} : e x = e y ↔ x = y :=
e.to_equiv.apply_eq_iff_eq

/-- Identity order isomorphism. -/
def refl (α : Type*) [has_le α] : α ≃o α := rel_iso.refl (≤)

@[simp] lemma coe_refl : ⇑(refl α) = id := rfl

lemma refl_apply (x : α) : refl α x = x := rfl

@[simp] lemma refl_to_equiv : (refl α).to_equiv = equiv.refl α := rfl

/-- Inverse of an order isomorphism. -/
def symm (e : α ≃o β) : β ≃o α := e.symm

@[simp] lemma apply_symm_apply (e : α ≃o β) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (e : α ≃o β) (x : α) : e.symm (e x) = x :=
e.to_equiv.symm_apply_apply x

@[simp] lemma symm_refl (α : Type*) [has_le α] : (refl α).symm = refl α := rfl

lemma apply_eq_iff_eq_symm_apply (e : α ≃o β) (x : α) (y : β) : e x = y ↔ x = e.symm y :=
e.to_equiv.apply_eq_iff_eq_symm_apply

theorem symm_apply_eq (e : α ≃o β) {x : α} {y : β} : e.symm y = x ↔ y = e x :=
e.to_equiv.symm_apply_eq

@[simp] lemma symm_symm (e : α ≃o β) : e.symm.symm = e := by { ext, refl }

lemma symm_injective : injective (symm : (α ≃o β) → (β ≃o α)) :=
λ e e' h, by rw [← e.symm_symm, h, e'.symm_symm]

@[simp] lemma to_equiv_symm (e : α ≃o β) : e.to_equiv.symm = e.symm.to_equiv := rfl

@[simp] lemma symm_image_image (e : α ≃o β) (s : set α) : e.symm '' (e '' s) = s :=
e.to_equiv.symm_image_image s

@[simp] lemma image_symm_image (e : α ≃o β) (s : set β) : e '' (e.symm '' s) = s :=
e.to_equiv.image_symm_image s

lemma image_eq_preimage (e : α ≃o β) (s : set α) : e '' s = e.symm ⁻¹' s :=
e.to_equiv.image_eq_preimage s

@[simp] lemma preimage_symm_preimage (e : α ≃o β) (s : set α) : e ⁻¹' (e.symm ⁻¹' s) = s :=
e.to_equiv.preimage_symm_preimage s

@[simp] lemma symm_preimage_preimage (e : α ≃o β) (s : set β) : e.symm ⁻¹' (e ⁻¹' s) = s :=
e.to_equiv.symm_preimage_preimage s

@[simp] lemma image_preimage (e : α ≃o β) (s : set β) : e '' (e ⁻¹' s) = s :=
e.to_equiv.image_preimage s

@[simp] lemma preimage_image (e : α ≃o β) (s : set α) : e ⁻¹' (e '' s) = s :=
e.to_equiv.preimage_image s

/-- Composition of two order isomorphisms is an order isomorphism. -/
@[trans] def trans (e : α ≃o β) (e' : β ≃o γ) : α ≃o γ := e.trans e'

@[simp] lemma coe_trans (e : α ≃o β) (e' : β ≃o γ) : ⇑(e.trans e') = e' ∘ e := rfl

lemma trans_apply (e : α ≃o β) (e' : β ≃o γ) (x : α) : e.trans e' x = e' (e x) := rfl

@[simp] lemma refl_trans (e : α ≃o β) : (refl α).trans e = e := by { ext x, refl }

@[simp] lemma trans_refl (e : α ≃o β) : e.trans (refl β) = e := by { ext x, refl }

end has_le

open set

section le

variables [has_le α] [has_le β] [has_le γ]

@[simp] lemma le_iff_le (e : α ≃o β) {x y : α} : e x ≤ e y ↔ x ≤ y := e.map_rel_iff

lemma le_symm_apply (e : α ≃o β) {x : α} {y : β} : x ≤ e.symm y ↔ e x ≤ y :=
e.rel_symm_apply

lemma symm_apply_le (e : α ≃o β) {x : α} {y : β} : e.symm y ≤ x ↔ y ≤ e x :=
e.symm_apply_rel

end le

variables [preorder α] [preorder β] [preorder γ]

protected lemma monotone (e : α ≃o β) : monotone e := e.to_order_embedding.monotone

protected lemma strict_mono (e : α ≃o β) : strict_mono e := e.to_order_embedding.strict_mono

@[simp] lemma lt_iff_lt (e : α ≃o β) {x y : α} : e x < e y ↔ x < y :=
e.to_order_embedding.lt_iff_lt

/-- To show that `f : α → β`, `g : β → α` make up an order isomorphism of linear orders,
    it suffices to prove `cmp a (g b) = cmp (f a) b`. --/
def of_cmp_eq_cmp {α β} [linear_order α] [linear_order β] (f : α → β) (g : β → α)
  (h : ∀ (a : α) (b : β), cmp a (g b) = cmp (f a) b) : α ≃o β :=
have gf : ∀ (a : α), a = g (f a) := by { intro, rw [←cmp_eq_eq_iff, h, cmp_self_eq_eq] },
{ to_fun := f,
  inv_fun := g,
  left_inv := λ a, (gf a).symm,
  right_inv := by { intro, rw [←cmp_eq_eq_iff, ←h, cmp_self_eq_eq] },
  map_rel_iff' := by { intros, apply le_iff_le_of_cmp_eq_cmp, convert (h _ _).symm, apply gf } }

/-- Order isomorphism between two equal sets. -/
def set_congr (s t : set α) (h : s = t) : s ≃o t :=
{ to_equiv := equiv.set_congr h,
  map_rel_iff' := λ x y, iff.rfl }

/-- Order isomorphism between `univ : set α` and `α`. -/
def set.univ : (set.univ : set α) ≃o α :=
{ to_equiv := equiv.set.univ α,
  map_rel_iff' := λ x y, iff.rfl }

/-- Order isomorphism between `α → β` and `β`, where `α` has a unique element. -/
@[simps to_equiv apply] def fun_unique (α β : Type*) [unique α] [preorder β] :
  (α → β) ≃o β :=
{ to_equiv := equiv.fun_unique α β,
  map_rel_iff' := λ f g, by simp [pi.le_def, unique.forall_iff] }

@[simp] lemma fun_unique_symm_apply {α β : Type*} [unique α] [preorder β] :
  ((fun_unique α β).symm : β → α → β) = function.const α := rfl

end order_iso

namespace equiv

variables [preorder α] [preorder β]

/-- If `e` is an equivalence with monotone forward and inverse maps, then `e` is an
order isomorphism. -/
def to_order_iso (e : α ≃ β) (h₁ : monotone e) (h₂ : monotone e.symm) :
  α ≃o β :=
⟨e, λ x y, ⟨λ h, by simpa only [e.symm_apply_apply] using h₂ h, λ h, h₁ h⟩⟩

@[simp] lemma coe_to_order_iso (e : α ≃ β) (h₁ : monotone e) (h₂ : monotone e.symm) :
  ⇑(e.to_order_iso h₁ h₂) = e := rfl

@[simp] lemma to_order_iso_to_equiv (e : α ≃ β) (h₁ : monotone e) (h₂ : monotone e.symm) :
  (e.to_order_iso h₁ h₂).to_equiv = e := rfl

end equiv

/-- If a function `f` is strictly monotone on a set `s`, then it defines an order isomorphism
between `s` and its image. -/
protected noncomputable def strict_mono_on.order_iso {α β} [linear_order α] [preorder β]
  (f : α → β) (s : set α) (hf : strict_mono_on f s) :
  s ≃o f '' s :=
{ to_equiv := hf.inj_on.bij_on_image.equiv _,
  map_rel_iff' := λ x y, hf.le_iff_le x.2 y.2 }

/-- A strictly monotone function from a linear order is an order isomorphism between its domain and
its range. -/
protected noncomputable def strict_mono.order_iso {α β} [linear_order α] [preorder β] (f : α → β)
  (h_mono : strict_mono f) : α ≃o set.range f :=
{ to_equiv := equiv.of_injective f h_mono.injective,
  map_rel_iff' := λ a b, h_mono.le_iff_le }

/-- A strictly monotone surjective function from a linear order is an order isomorphism. -/
noncomputable def strict_mono.order_iso_of_surjective {α β} [linear_order α] [preorder β]
  (f : α → β) (h_mono : strict_mono f) (h_surj : surjective f) : α ≃o β :=
(h_mono.order_iso f).trans $ (order_iso.set_congr _ _ h_surj.range_eq).trans order_iso.set.univ

/-- `subrel r p` is the inherited relation on a subset. -/
def subrel (r : α → α → Prop) (p : set α) : p → p → Prop :=
(coe : p → α) ⁻¹'o r

@[simp] theorem subrel_val (r : α → α → Prop) (p : set α)
  {a b} : subrel r p a b ↔ r a.1 b.1 := iff.rfl

namespace subrel

/-- The relation embedding from the inherited relation on a subset. -/
protected def rel_embedding (r : α → α → Prop) (p : set α) :
  subrel r p ↪r r := ⟨embedding.subtype _, λ a b, iff.rfl⟩

@[simp] theorem rel_embedding_apply (r : α → α → Prop) (p a) :
  subrel.rel_embedding r p a = a.1 := rfl

instance (r : α → α → Prop) [is_well_order α r]
  (p : set α) : is_well_order p (subrel r p) :=
rel_embedding.is_well_order (subrel.rel_embedding r p)

end subrel

/-- Restrict the codomain of a relation embedding. -/
def rel_embedding.cod_restrict (p : set β) (f : r ↪r s) (H : ∀ a, f a ∈ p) : r ↪r subrel s p :=
⟨f.to_embedding.cod_restrict p H, f.map_rel_iff'⟩

@[simp] theorem rel_embedding.cod_restrict_apply (p) (f : r ↪r s) (H a) :
  rel_embedding.cod_restrict p f H a = ⟨f a, H a⟩ := rfl

/-- An order isomorphism is also an order isomorphism between dual orders. -/
protected def order_iso.dual [has_le α] [has_le β] (f : α ≃o β) :
  order_dual α ≃o order_dual β := ⟨f.to_equiv, λ _ _, f.map_rel_iff⟩

section lattice_isos

lemma order_iso.map_bot' [has_le α] [partial_order β] (f : α ≃o β) {x : α} {y : β}
  (hx : ∀ x', x ≤ x') (hy : ∀ y', y ≤ y') : f x = y :=
by { refine le_antisymm _ (hy _), rw [← f.apply_symm_apply y, f.map_rel_iff], apply hx }

lemma order_iso.map_bot [has_le α] [partial_order β] [order_bot α] [order_bot β] (f : α ≃o β) :
  f ⊥ = ⊥ :=
f.map_bot' (λ _, bot_le) (λ _, bot_le)

lemma order_iso.map_top' [has_le α] [partial_order β] (f : α ≃o β) {x : α} {y : β}
  (hx : ∀ x', x' ≤ x) (hy : ∀ y', y' ≤ y) : f x = y :=
f.dual.map_bot' hx hy

lemma order_iso.map_top [has_le α] [partial_order β] [order_top α] [order_top β] (f : α ≃o β) :
  f ⊤ = ⊤ :=
f.dual.map_bot

lemma order_embedding.map_inf_le [semilattice_inf α] [semilattice_inf β]
  (f : α ↪o β) (x y : α) :
  f (x ⊓ y) ≤ f x ⊓ f y :=
f.monotone.map_inf_le x y

lemma order_iso.map_inf [semilattice_inf α] [semilattice_inf β]
  (f : α ≃o β) (x y : α) :
  f (x ⊓ y) = f x ⊓ f y :=
begin
  refine (f.to_order_embedding.map_inf_le x y).antisymm _,
  simpa [← f.symm.le_iff_le] using f.symm.to_order_embedding.map_inf_le (f x) (f y)
end

/-- Note that this goal could also be stated `(disjoint on f) a b` -/
lemma disjoint.map_order_iso [semilattice_inf α] [order_bot α] [semilattice_inf β] [order_bot β]
  {a b : α} (f : α ≃o β) (ha : disjoint a b) : disjoint (f a) (f b) :=
begin
  rw [disjoint, ←f.map_inf, ←f.map_bot],
  exact f.monotone ha,
end

@[simp] lemma disjoint_map_order_iso_iff [semilattice_inf α] [order_bot α] [semilattice_inf β]
  [order_bot β] {a b : α} (f : α ≃o β) : disjoint (f a) (f b) ↔ disjoint a b :=
⟨λ h, f.symm_apply_apply a ▸ f.symm_apply_apply b ▸ h.map_order_iso f.symm, λ h, h.map_order_iso f⟩

lemma order_embedding.le_map_sup [semilattice_sup α] [semilattice_sup β]
  (f : α ↪o β) (x y : α) :
  f x ⊔ f y ≤ f (x ⊔ y) :=
f.monotone.le_map_sup x y

lemma order_iso.map_sup [semilattice_sup α] [semilattice_sup β]
  (f : α ≃o β) (x y : α) :
  f (x ⊔ y) = f x ⊔ f y :=
f.dual.map_inf x y

section bounded_order

variables [lattice α] [lattice β] [bounded_order α] [bounded_order β] (f : α ≃o β)
include f

lemma order_iso.is_compl {x y : α} (h : is_compl x y) : is_compl (f x) (f y) :=
⟨by { rw [← f.map_bot, ← f.map_inf, f.map_rel_iff], exact h.1 },
  by { rw [← f.map_top, ← f.map_sup, f.map_rel_iff], exact h.2 }⟩

theorem order_iso.is_compl_iff {x y : α} :
  is_compl x y ↔ is_compl (f x) (f y) :=
⟨f.is_compl, λ h, begin
  rw [← f.symm_apply_apply x, ← f.symm_apply_apply y],
  exact f.symm.is_compl h,
end⟩

lemma order_iso.is_complemented
  [is_complemented α] : is_complemented β :=
⟨λ x, begin
  obtain ⟨y, hy⟩ := exists_is_compl (f.symm x),
  rw ← f.symm_apply_apply y at hy,
  refine ⟨f y, f.symm.is_compl_iff.2 hy⟩,
end⟩

theorem order_iso.is_complemented_iff :
  is_complemented α ↔ is_complemented β :=
⟨by { introI, exact f.is_complemented }, by { introI, exact f.symm.is_complemented }⟩

end bounded_order
end lattice_isos


import data.finsupp.basic

section

/-- An inductive type from which to index the variables of the mv_polynomials the proof manages -/
@[derive decidable_eq]
inductive vars : Type
| α : vars
| β : vars
| γ : vars
| δ : vars
-- | x : vars

-- lemma finsupp_vars_eq_ext (f g : vars →₀ ℕ) : f = g ↔
--   f vars.α = g vars.α ∧ f vars.β = g vars.β ∧ f vars.γ = g vars.γ ∧ f vars.δ = g vars.δ ∧ f vars.x = g vars.x :=
-- begin
--   rw finsupp.ext_iff,
--   split,
--     {
--       intro h,
--       split, exact h vars.α,
--       split, exact h vars.β,
--       split, exact h vars.γ,
--       split, exact h vars.δ,
--       exact h vars.x,
--     },
--     {
--       intro h,
--       intro a,
--       induction a,
--       finish,
--       finish,
--       finish,
--       finish,
--       finish,
--     },
-- end

lemma finsupp_vars_eq_ext (f g : vars →₀ ℕ) : f = g ↔
  f vars.α = g vars.α ∧ f vars.β = g vars.β ∧ f vars.γ = g vars.γ ∧ f vars.δ = g vars.δ :=
begin
  rw finsupp.ext_iff,
  split,
    {
      intro h,
      split, exact h vars.α,
      split, exact h vars.β,
      split, exact h vars.γ,
      exact h vars.δ,
    },
    {
      intro h,
      intro a,
      induction a,
      finish,
      finish,
      finish,
      finish,
    },
  -- induction,
end

end


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.BoundedDistribLattice

/-!
# The category of boolean algebras

This defines `BoolAlg`, the category of boolean algebras.
-/

open order_dual opposite set

universes u

open category_theory

/-- The category of boolean algebras. -/
def BoolAlg := bundled boolean_algebra

namespace BoolAlg

instance : has_coe_to_sort BoolAlg Type* := bundled.has_coe_to_sort
instance (X : BoolAlg) : boolean_algebra X := X.str

/-- Construct a bundled `BoolAlg` from a `boolean_algebra`. -/
def of (α : Type*) [boolean_algebra α] : BoolAlg := bundled.of α

@[simp] lemma coe_of (α : Type*) [boolean_algebra α] : ↥(of α) = α := rfl

instance : inhabited BoolAlg := ⟨of punit⟩

/-- Turn a `BoolAlg` into a `BoundedDistribLattice` by forgetting its complement operation. -/
def to_BoundedDistribLattice (X : BoolAlg) : BoundedDistribLattice := BoundedDistribLattice.of X

@[simp] lemma coe_to_BoundedDistribLattice (X : BoolAlg) : ↥X.to_BoundedDistribLattice = ↥X := rfl

instance : large_category.{u} BoolAlg := induced_category.category to_BoundedDistribLattice
instance : concrete_category BoolAlg := induced_category.concrete_category to_BoundedDistribLattice

instance has_forget_to_BoundedDistribLattice : has_forget₂ BoolAlg BoundedDistribLattice :=
induced_category.has_forget₂ to_BoundedDistribLattice

/-- Constructs an equivalence between boolean algebras from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : BoolAlg.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := (e : bounded_lattice_hom α β),
  inv := (e.symm : bounded_lattice_hom β α),
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : BoolAlg ⥤ BoolAlg :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, bounded_lattice_hom.dual }

/-- The equivalence between `BoolAlg` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : BoolAlg ≌ BoolAlg :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end BoolAlg

lemma BoolAlg_dual_comp_forget_to_BoundedDistribLattice :
  BoolAlg.dual ⋙ forget₂ BoolAlg BoundedDistribLattice =
    forget₂ BoolAlg BoundedDistribLattice ⋙ BoundedDistribLattice.dual := rfl


import constructive.pigeon
import classical.tools

namespace classical.pigeon

open constructive.pigeon
open set

def cofinite (A : set ℕ) := ∃ x : ℕ, ∀ y : ℕ, y ≥ x → A y
def infinite (A : set ℕ) := ∀ x : ℕ, ∃ y : ℕ, y ≥ x ∧ A y

lemma x_le_fx_incr (f : ℕ → ℕ) (x : ℕ): increasing f → x ≤ f (x) :=
λ (incr : increasing f),
  nat.rec_on x (nat.zero_le (f 0))
    (λ (n : ℕ) (ih : n ≤ f n),
      nat.le_trans (nat.succ_le_succ ih) (incr n (nat.succ n) (nat.lt_succ_self n)))

lemma cofinite_implies_almost_full (A : set ℕ) : cofinite A → almost_full A :=
λ (h : cofinite A),
  exists.elim h
    (λ (x : ℕ) (HAx : (λ (x : ℕ), ∀ (y : ℕ), y ≥ x → A y) x),
       exists.intro (λ (f : ℕ → ℕ), f x)
         (λ (f : ℕ → ℕ) (incrf : increasing f),
            HAx (f ((λ (f : ℕ → ℕ), f x) f))
              (nat.le_trans (x_le_fx_incr f x incrf) (x_le_fx_incr f (f x) incrf))))

def failure_past (A : set ℕ) (x y : ℕ) := y ≥ x ∧ ¬ A y

def iter (f : ℕ → ℕ) : ℕ → ℕ
  | 0 := f 1
  | (n+1) := f ((iter n)+1)

lemma iter_incr (A : set ℕ) (f : ℕ → ℕ) :
  (∀ x : ℕ, f x ≥ x) → increasing (iter f) :=
  λ (h : ∀ (x : ℕ), f x ≥ x),
    increasing_by_step (iter f) (λ (n : ℕ), h (nat.succ (iter f n)))

open classical
open classical.tools

lemma not_cofinite (A : set ℕ) :
  ¬ cofinite A → (∀ x : ℕ, ∃ y : ℕ, failure_past A x y) :=
  λ (cofA : ¬cofinite A) (x : ℕ),
    exists.elim
      (neg_universal_as_ex ℕ (λ (z : ℕ), ¬(z ≥ x → A z))
        (λ (c : ∀ (m : ℕ), ¬¬(m ≥ x → A m)),
           absurd (dne_under_univ ℕ (λ (w : ℕ), w ≥ x → A w) c) (forall_not_of_not_exists cofA x)))
      (λ (w : ℕ) (eh : ¬(w ≥ x → A w)), exists.intro w (neg_imp_as_conj (w ≥ x) (A w) eh))

lemma increasing_failures (A : set ℕ) (f : ℕ → ℕ) :
  (∀ x : ℕ, failure_past A x (f x)) → increasing (iter f):=
  λ (h : ∀ (x : ℕ), failure_past A x (f x)), iter_incr A f (λ (x : ℕ), (h x).left)

lemma wit_not_A (A : set ℕ) (f : ℕ → ℕ) :
  (∀ x : ℕ, failure_past A x (f x)) → ∀ x : ℕ, ¬ A ((iter f) x) :=
  λ (h : ∀ (x : ℕ), pigeon.failure_past A x (f x)) (x : ℕ),
    nat.cases_on x ((h 1).right) (λ (x : ℕ), (h (pigeon.iter f x + 1)).right)

lemma not_cof_has_incr_wit (A : set ℕ) : ¬ cofinite A →
  ∃ f : ℕ → ℕ, (increasing (iter f)) ∧ (∀ x : ℕ, ¬ A ((iter f) x)) :=
  λ (nCofA : ¬pigeon.cofinite A),
    exists.elim (axiom_of_choice (not_cofinite A nCofA))
      (λ (f : Π (x : ℕ), (λ (x : ℕ), ℕ) x)
       (hf : ∀ (x : ℕ), (λ (x y : ℕ), pigeon.failure_past A x y) x (f x)),
         exists.intro f ⟨increasing_failures A f hf, wit_not_A A f hf⟩)

lemma almost_full_implies_cofinite (A : set ℕ) : ¬ cofinite A → ¬ almost_full A :=
λ (nCofA : ¬pigeon.cofinite A),
  exists.elim (not_cof_has_incr_wit A nCofA)
    (λ (f : ℕ → ℕ) (hf : increasing (pigeon.iter f) ∧ ∀ (x : ℕ), ¬A (pigeon.iter f x)),
       (λ (c : almost_full A),
          Exists.dcases_on c
            (λ (Y : (ℕ → ℕ) → ℕ) (hY : full A Y),
               absurd (hY (pigeon.iter f) (hf.left)) (hf.right (Y (pigeon.iter f))))))

theorem cofinite_is_almost_full (A : set ℕ) : cofinite A ↔ almost_full A :=
  {
     mp := pigeon.cofinite_implies_almost_full A,
     mpr := contra_pos (almost_full A) (pigeon.cofinite A) (almost_full_implies_cofinite A)
  }

def comp (A : set ℕ) := λ n : ℕ, ¬ A n

lemma not_infinite_has_wit (A : set ℕ) :
  ¬ infinite A → ∃ x : ℕ, ¬ (∃ y : ℕ, y ≥ x ∧ A y) :=
  λ (h : ¬pigeon.infinite A),
    neg_universal_as_ex ℕ (λ (x : ℕ), ¬∃ (y : ℕ), y ≥ x ∧ A y)
      (λ (c : ∀ (x : ℕ), ¬¬∃ (y : ℕ), y ≥ x ∧ A y),
         absurd (dne_under_univ ℕ (λ (x : ℕ), ∃ (y : ℕ), y ≥ x ∧ A y) c) h)

lemma not_infinite_co_cofinite (A : set ℕ) :
  ¬ infinite A → cofinite (comp A) :=
λ (h : ¬pigeon.infinite A),
  exists.elim (not_infinite_has_wit A h)
    (λ (w : ℕ) (wMax : ¬∃ (y : ℕ), y ≥ w ∧ A y),
       exists.intro w
         (λ (y : ℕ) (hyw : y ≥ w),
           (λ (c : A y),
             absurd
               (and.intro hyw c)
               (( @forall_not_of_not_exists ℕ (λ n : ℕ, n ≥ w ∧ A n) wMax) y))))

theorem pigeon (A : set ℕ) : infinite A ∨ infinite (comp A) :=
  by_contradiction
    (λ (c : ¬(pigeon.infinite A ∨ pigeon.infinite (comp A))),
       exists.elim
         (constr_pigeon (comp A) (comp (comp A))
            (pigeon.cofinite_implies_almost_full (comp A)
               (not_infinite_co_cofinite A
                 ((demorgan_or (pigeon.infinite A) (pigeon.infinite (comp A)) c).left)))
            (pigeon.cofinite_implies_almost_full (comp (comp A))
               (not_infinite_co_cofinite (comp A)
                  ((demorgan_or (pigeon.infinite A) (pigeon.infinite (comp A)) c).right))))
         (λ (Y : (ℕ → ℕ) → ℕ) (hY : full (comp A ∩ comp (comp A)) Y),
            absurd
              ((hY id (λ (x y : ℕ) (h : x < y), h)).left)
              ((hY id (λ (x y : ℕ) (h : x < y), h)).right)))

end classical.pigeon