import data.list.basic
import topology.basic
import tactic.induction
import tactic.linarith

universes u v w

--------------------------------------------------------------------------------
-- Setup: Some Inductive Types
--------------------------------------------------------------------------------

inductive le : ℕ → ℕ → Type
| zero {n} : le 0 n
| succ {n m} : le n m → le (n + 1) (m + 1)

inductive lt : ℕ → ℕ → Type
| zero {n} : lt 0 (n + 1)
| succ {n m} : lt n m → lt (n + 1) (m + 1)

inductive Fin : ℕ → Type
| zero {n} : Fin (n + 1)
| succ {n} : Fin n → Fin (n + 1)

inductive List (α : Sort*) : Sort*
| nil {} : List
| cons {} (x : α) (xs : List) : List

namespace List

def append {α} : List α → List α → List α
| nil ys := ys
| (cons x xs) ys := cons x (append xs ys)

end List

inductive Vec (α : Sort u) : ℕ → Sort (max 1 u)
| nil : Vec 0
| cons {n} : α → Vec n → Vec (n + 1)

namespace Vec

inductive eq {α} : ∀ n m, Vec α n → Vec α m → Prop
| nil : eq 0 0 nil nil
| cons {n m} {xs : Vec α n} {ys : Vec α m} {x y : α} :
  x = y →
  eq n m xs ys →
  eq (n + 1) (m + 1) (cons x xs) (cons y ys)

end Vec

inductive Two : Type | zero | one

inductive ℕ' : Type
| intro : ℕ → ℕ'

--------------------------------------------------------------------------------
-- Unit Tests
--------------------------------------------------------------------------------

example (k) : 0 + k = k :=
begin
  induction' k,
  { refl },
  { simp }
end

example {k} (fk : Fin k) : Fin (k + 1) :=
begin
  induction' fk,
  { exact Fin.zero },
  { exact Fin.succ ih }
end

example {α} (l : List α) : l.append List.nil = l :=
begin
  induction' l,
  { refl },
  { dsimp only [List.append],
    exact (congr_arg _ ih) }
end

example {k l} (h : lt k l) : le k l :=
begin
  induction' h,
  { exact le.zero },
  { exact le.succ ih }
end

example {k l} : lt k l → le k l :=
begin
  induction' k; induction' l; intro hlt,
  { cases' hlt },
  { exact le.zero },
  { cases' hlt },
  { cases' hlt,
    exact le.succ (@ih m hlt), }
end

example {α n m} {xs : Vec α n} {ys : Vec α m} (h : Vec.eq n m xs ys) : n = m :=
begin
  induction' h,
  case nil {
    refl },
  case cons {
    exact congr_arg nat.succ ih, }
end

-- A simple induction with complex index arguments.
example {k} (h : lt (k + 1) k) : false :=
begin
  induction' h,
  { exact ih }
end

-- A more complex induction with complex index arguments. Note the dependencies
-- between index arguments.
example {α : Sort u} {x y n m} {xs : Vec α n} {ys : Vec α m}
  : Vec.eq (n + 1) (m + 1) (Vec.cons x xs) (Vec.cons y ys)
  → Vec.eq n m xs ys :=
begin
  intro h,
  induction' h,
  exact h_1
end

-- It also works with cases'.
example {α : Sort u} {x y n m} {xs : Vec α n} {ys : Vec α m}
  : Vec.eq (n + 1) (m + 1) (Vec.cons x xs) (Vec.cons y ys)
  → Vec.eq n m xs ys :=
begin
  intro h,
  cases' h,
  exact h_1
end

-- This example requires elimination of cyclic generalised index equations.
example (n : ℕ) (h : n = n + 3) : false :=
begin
  success_if_fail { cases h },
  induction' h
end

-- It also works with cases'.
example (n : ℕ) (h : n = n + 3) : false :=
begin
  success_if_fail { cases h },
  cases' h
end

-- This example used to fail because it involves a nested inductive as a complex
-- index.
inductive rose₁ : Type
| tip : rose₁
| node : list rose₁ → rose₁

example (rs) (h : rose₁.tip = rose₁.node rs) : false :=
begin
  cases' h
end

-- This example checks whether we can deal with infinitely branching inductive
-- types.
inductive inf_tree (α : Type) : Type
| tip : inf_tree
| node (a : α) (f : ∀ (n : ℕ), inf_tree) : inf_tree

namespace inf_tree

inductive all {α} (P : α → Prop) : inf_tree α → Prop
| tip : all tip
| node {a} {f : ℕ → inf_tree α} : P a → (∀ n, all (f n)) → all (node a f)

example {α} (t : inf_tree α) : all (λ _, true) t :=
begin
  induction' t,
  { exact all.tip },
  { exact all.node trivial ih }
end

end inf_tree

-- This example tests type-based naming.
example (k : ℕ') (i : ℕ') : ℕ :=
begin
  induction' k,
  induction' i,
  exact (n + m)
end

-- For constructor arguments that are propositions, the default name is "h".
-- For non-propositions, it is "x".
inductive nat_or_positive
| nat : ℕ' → nat_or_positive
| positive (n : ℕ) : n > 0 → nat_or_positive

example (n : nat_or_positive) : unit :=
begin
  cases' n,
  case nat {
    guard_hyp x : ℕ',
    exact () },
  case positive {
    guard_hyp n : ℕ,
    guard_hyp h : n > 0,
    exact () }
end

-- By default, induction' generates the most general possible induction
-- hypothesis.
example {n m : ℕ} : n + m = m + n :=
begin
  induction' m,
  case zero { simp },
  case succ : k IH {
    guard_hyp k : ℕ,
    guard_hyp n : ℕ,
    guard_hyp IH : ∀ {n}, n + k = k + n,
    ac_refl }
end

-- Here's an example where this is more useful.
example {n m : ℕ} (h : n + n = m + m) : n = m :=
begin
  induction' n with n ih,
  case zero {
    cases' m,
    { refl },
    { cases' h } },
  case succ {
    cases' m,
    { cases' h },
    { rw @ih m,
      simp only [nat.succ_eq_add_one] at h,
      replace h : n + n + 2 = m + m + 2 := by linarith,
      injections } }
end

-- If we don't want a hypothesis to be generalised, we can say so with a
-- "fixing" clause.
example {n m : ℕ} : n + m = m + n :=
begin
  induction' m fixing n,
  case zero { simp },
  case succ : k IH {
    guard_hyp k : ℕ,
    guard_hyp n : ℕ,
    guard_hyp IH : n + k = k + n,
    ac_refl }
end

-- We can also fix all hypotheses. This gives us the behaviour of stock
-- `induction`. Hypotheses which depend on the major premise (or its index
-- arguments) still get generalised.
example {n m k : ℕ} (h : n + m = k) : n + m = k :=
begin
  induction' n fixing *,
  case zero { simp [*] },
  case succ : n IH {
    guard_hyp n : ℕ,
    guard_hyp m : ℕ,
    guard_hyp k : ℕ,
    guard_hyp h : n.succ + m = k,
    guard_hyp IH : n + m = k → n + m = k,
    -- Neither m nor k were generalised.
    exact h }
end

-- We can also generalise only certain hypotheses using a `generalizing`
-- clause. This gives us the behaviour of stock `induction ... generalizing`.
-- Hypotheses which depend on the major premise get generalised even if they are
-- not mentioned in the `generalizing` clause.
example {n m k : ℕ} (h : n + m = k) : n + m = k :=
begin
  induction' n generalizing k,
  case zero { simp [*] },
  case succ : n IH {
    guard_hyp n : ℕ,
    guard_hyp m : ℕ,
    guard_hyp k : ℕ,
    guard_hyp h : n.succ + m = k,
    guard_hyp IH : ∀ {k}, n + m = k → n + m = k,
    -- k was generalised, but m was not.
    exact h }
end

-- Sometimes generalising a hypothesis H does not give us a more general
-- induction hypothesis. In such cases, induction' should not generalise H. The
-- following example is not realistic, but situations like this can occur in
-- practice; see accufact_1_eq_fact below.
example (n m k : ℕ) : m + k = k + m :=
begin
  induction' m,
  case zero { simp },
  case succ {
    guard_hyp ih : ∀ k, m + k = k + m,
    -- k was generalised because this makes the IH more general.
    -- n was not generalised -- if it had been, the IH would be
    --
    --     ∀ n k, m + k = k + m
    --
    -- with one useless additional argument.
    ac_refl }
end

-- This example checks that constructor arguments don't 'steal' the names of
-- generalised hypotheses.
example (n : list ℕ) (n : ℕ) : list ℕ :=
begin
  -- this performs induction on (n : ℕ)
  induction' n,
  { exact n },
  { guard_hyp n : list ℕ,
    guard_hyp n_1 : ℕ,
    -- n is the list, which was automatically generalized and keeps its name.
    -- n_1 is the recursive argument of `nat.succ`. It would be called `n` if
    -- there wasn't already an `n` in the context.
    exact (n_1 :: n) }
end

-- This example tests whether `induction'` gets confused when there are
-- additional cases around.
example (k : ℕ) (t : Two) : 0 + k = k :=
begin
  cases t,
  induction' k,
  { refl },
  { simp },
  induction' k,
  { refl },
  { simp }
end

-- The type of the induction premise can be a complex expression so long as it
-- normalises to an inductive (possibly applied to params/indexes).
example (n) : 0 + n = n :=
begin
  let T := ℕ,
  change T at n,
  induction' n; simp
end

-- Fail if the type of the induction premise is not an inductive type
example {α} (x : α) (f : α → α) : unit :=
begin
  success_if_fail { induction' x },
  success_if_fail { induction' f },
  exact ()
end

-- The following example used to trigger a bug where eliminate would generate
-- hypotheses with duplicate names.
structure fraction : Type :=
(num           : ℤ)
(denom         : ℤ)
(denom_ne_zero : denom ≠ 0)

lemma fraction.ext (a b : fraction) (hnum : fraction.num a = fraction.num b)
    (hdenom : fraction.denom a = fraction.denom b) :
  a = b :=
begin
  cases' a,
  cases' b,
  guard_hyp num : ℤ,
  guard_hyp denom : ℤ,
  guard_hyp num_1 : ℤ,
  guard_hyp denom_1 : ℤ,
  rw fraction.mk.inj_eq,
  exact and.intro hnum hdenom
end

-- A "with" clause can be used to give the names of constructor arguments (as
-- for `cases`, `induction` etc).
example (x : ℕ × ℕ) (y : Vec ℕ 2) (z : List ℕ) : unit :=
begin
  cases' x with i j k l,
  guard_hyp i : ℕ,
  guard_hyp j : ℕ,
  clear i j,

  cases' y with i j k l,
  -- Note that i is 'skipped' because it is used to name the (n : ℕ)
  -- argument of `cons`, but that argument is cleared by index unification. I
  -- find this a little strange, but `cases` also behaves like this.
  guard_hyp j : ℕ,
  guard_hyp k : Vec ℕ 1,
  clear j k,

  cases' z with i j k l,
  case nil { exact () },
  case cons {
    guard_hyp i : ℕ,
    guard_hyp j : List ℕ,
    exact () }
end

-- "with" also works with induction'.
example (x : List ℕ) : unit :=
begin
  induction' x with i j k l,
  case nil { exact () },
  case cons {
    guard_hyp i : ℕ,
    guard_hyp j : List ℕ,
    guard_hyp k : unit,
    exact () }
end

-- An underscore in a "with" clause means "use the auto-generated name for this
-- argument".
example (x : List ℕ) : unit :=
begin
  induction' x with _ j _ l,
  case nil { exact () },
  case cons {
    guard_hyp x : ℕ,
    guard_hyp j : List ℕ,
    guard_hyp ih : unit,
    exact () }
end

namespace with_tests

inductive test
| intro (n) (f : fin n) (m) (g : fin m)

-- A hyphen in a "with" clause means "clear this hypothesis and its reverse
-- dependencies".
example (h : test) : unit :=
begin
  cases' h with - F M G,
  guard_hyp M : ℕ,
  guard_hyp G : fin M,
  success_if_fail { guard_hyp n },
  success_if_fail { guard_hyp F },
  exact ()
end

-- Names given in a "with" clause are used verbatim, even if this results in
-- shadowing.
example (x : ℕ) (h : test) : unit :=
begin
  cases' h with x y y -,
  /-
  Expected goal:

  x x : ℕ,
  y : fin x,
  y : ℕ
  ⊢ unit

  It's hard to give a good test case here because we would need a variant of
  `guard_hyp` that is sensitive to shadowing. But we can at least check that the
  hyps don't have the names they would get if we avoided shadowing.
  -/
  success_if_fail { guard_hyp x_1 },
  success_if_fail { guard_hyp y_1 },
  exact ()
end

end with_tests

-- induction' and cases' can be used to perform induction/case analysis on
-- arbitrary expressions (not just hypotheses). A very synthetic example:
example {α} : α ∨ ¬ α :=
begin
  cases' classical.em α with a nota,
  { exact (or.inl a) },
  { exact (or.inr nota) }
end

-- Cases'/induction' can add an equation witnessing the case split it
-- performed. Again, a highly synthetic example:
example {α} (xs : list α)
  : xs.reverse.length = 0 ∨ ∃ m, xs.reverse.length = m + 1 :=
begin
  cases' eq : xs.length,
  case zero {
    left,
    rw list.length_reverse,
    exact eq },
  case succ : l {
    right,
    rw list.length_reverse,
    use l,
    exact eq }
end

-- Index equation simplification can deal with equations that aren't in normal
-- form.
example {α} (x : α) (xs) : list.take 1 (x :: xs) ≠ [] :=
begin
  intro contra,
  cases' contra
end

-- Index generalisation should leave early occurrences of complex index terms
-- alone. This means that given the major premise `e : E (f y) y` where `y` is a
-- complex term, index generalisation should give us
--
--     e : E (f y) i,
--
-- *not*
--
--     e : E (f i) i.
--
-- Otherwise we get problems with examples like this:
inductive ℕ₂ : Type
| zero
| succ (n : ℕ₂) : ℕ₂

namespace ℕ₂

def plus : ℕ₂ → ℕ₂ → ℕ₂
| zero y := y
| (succ x) y := succ (plus x y)

example (x : ℕ₂) (h : plus zero x = zero) : x = zero :=
begin
  cases' h,
  guard_target zero = plus zero zero,
  refl
  -- If index generalisation blindly replaced all occurrences of zero, we would
  -- get
  --
  --     index = zero        → plus index x = index → x = index
  --
  -- and after applying the recursor
  --
  --     plus index x = zero                        → x = plus index x
  --
  -- This leaves the goal provable, but very confusing.
end

-- TODO Here's a test case (due to Floris van Doorn) where index generalisation
-- is over-eager: it replaces the complex index `zero` everywhere in the goal,
-- which makes the goal type-incorrect. `cases` does not exhibit this problem.
example (x : ℕ₂) (h : plus zero x = zero) :
  (⟨x, h⟩ : ∃ x, plus zero x = zero) = ⟨zero, rfl⟩ :=
begin
  success_if_fail { cases' h },
  cases h,
  refl
end

end ℕ₂

-- For whatever reason, the eliminator for `false` has an explicit argument
-- where all other eliminators have an implicit one. `eliminate_hyp` has to
-- work around this to ensure that we can eliminate a `false` hyp.
example {α} (h : false) : α :=
begin
  cases' h
end

-- Index equation simplification also works with nested datatypes.
inductive rose (α : Type) : Type
| leaf : rose
| node (val : α) (children : list rose) : rose

namespace rose

inductive nonempty {α} : rose α → Prop
| node (v c cs) : nonempty (node v (c :: cs))

lemma nonempty_node_elim {α} {v : α} {cs} (h : nonempty (node v cs)) : ¬ cs.empty :=
begin
  induction' h,
  finish
end

end rose

-- The following test cases, provided by Patrick Massot, test interactions with
-- several 'advanced' Lean features.
namespace topological_space_tests

class topological_space (X : Type) :=
  (is_open  : set X → Prop)
  (univ_mem : is_open set.univ)
  (union    : ∀ (B : set (set X)) (h : ∀ b ∈ B, is_open b), is_open (⋃₀ B))
  (inter    : ∀ (A B : set X) (hA : is_open A) (hB : is_open B), is_open (A ∩ B))

open topological_space (is_open)

inductive generated_open (X : Type) (g : set (set X)) : set X → Prop
| generator : ∀ A ∈ g, generated_open A
| inter     : ∀ A B, generated_open A → generated_open B → generated_open (A ∩ B)
| union     : ∀ (B : set (set X)), (∀ b ∈ B, generated_open b) → generated_open (⋃₀ B)
| univ      : generated_open set.univ

def generate_from (X : Type) (g : set (set X)) : topological_space X :=
{ is_open   := generated_open X g,
  univ_mem  := generated_open.univ,
  inter     := generated_open.inter,
  union     := generated_open.union }

inductive generated_filter {X : Type*} (g : set (set X)) : set X → Prop
| generator {A} : A ∈ g → generated_filter A
| inter   {A B} : generated_filter A → generated_filter B → generated_filter (A ∩ B)
| subset  {A B} : generated_filter A → A ⊆ B → generated_filter B
| univ          : generated_filter set.univ

def neighbourhood {X : Type} [topological_space X] (x : X) (V : set X) : Prop :=
∃ (U : set X), is_open U ∧ x ∈ U ∧ U ⊆ V

axiom nhd_inter {X : Type*} [topological_space X] {x : X} {U V : set X}
  (hU : neighbourhood x U) (hV : neighbourhood x V) : neighbourhood x (U ∩ V)

axiom nhd_superset {X : Type*} [topological_space X] {x : X} {U V : set X}
  (hU : neighbourhood x U) (hUV : U ⊆ V) : neighbourhood x V

axiom nhd_univ {X : Type*} [topological_space X] {x : X} : neighbourhood x set.univ

-- This example fails if auto-generalisation refuses to revert before
-- frozen local instances.
example {X : Type} [T : topological_space X] {s : set (set X)}
  (h : T = generate_from X s) {U x} :
  generated_filter {V | V ∈ s ∧ x ∈ V} U → neighbourhood x U :=
begin
  rw h,
  intro U_in,
  induction' U_in fixing T h with U hU U V U_gen V_gen hU hV U V U_gen hUV hU,
  { exact ⟨U, generated_open.generator U hU.1, hU.2, set.subset.refl U⟩ },
  { exact @nhd_inter _ (generate_from X s) _ _ _ hU hV },
  { exact @nhd_superset _ (generate_from X s) _  _ _ hU hUV },
  { apply nhd_univ }
end

-- This example fails if auto-generalisation tries to generalise `let`
-- hypotheses.
example {X : Type} [T : topological_space X] {s : set (set X)}
  (h : T = generate_from X s) {U x} :
  generated_filter {V | V ∈ s ∧ x ∈ V} U → neighbourhood x U :=
begin
  rw h,
  letI := generate_from X s,
  intro U_in,
  induction' U_in fixing T h with U hU U V U_gen V_gen hU hV U V U_gen hUV hU,
  { exact ⟨U, generated_open.generator U hU.1, hU.2, set.subset.refl U⟩ },
  { exact nhd_inter hU hV },
  { exact nhd_superset hU hUV },
  { apply nhd_univ }
end

-- This example fails if infinitely branching inductive types like
-- `generated_open` are not handled properly. In particular, it tests the
-- interaction of infinitely branching types with complex indices.
example {X : Type*} [T : topological_space X] {s : set (set X)}
  (h : T = generate_from X s) {U : set X} {x : X} :
  neighbourhood x U → generated_filter {V | V ∈ s ∧ x ∈ V} U :=
begin
  rw h, letI := generate_from X s,
  clear h,
  rintros ⟨V, V_op, x_in, hUV⟩,
  apply generated_filter.subset _ hUV,
  clear hUV,
  induction' V_op fixing _inst T s U,
  { apply generated_filter.generator,
    split ; assumption },
  { cases x_in,
    apply generated_filter.inter ; tauto },
  { rw set.mem_sUnion at x_in,
    rcases x_in with ⟨W, hW, hxW⟩,
    exact generated_filter.subset (ih W hW hxW) (set.subset_sUnion_of_mem hW)},
  { apply generated_filter.univ }
end

end topological_space_tests

--------------------------------------------------------------------------------
-- Logical Verification Use Cases
--------------------------------------------------------------------------------

-- The following examples were provided by Jasmin Blanchette. They are taken
-- from his course 'Logical Verification'.

/- Head induction for transitive closure -/

inductive star {α : Sort*} (r : α → α → Prop) (a : α) : α → Prop
| refl {}    : star a
| tail {b c} : star b → r b c → star c

namespace star

variables {α : Sort*} {r : α → α → Prop} {a b c d : α}

lemma head (hab : r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction' hbc fixing hab,
  case refl {
    exact refl.tail hab },
  case tail : c d hbc hcd hac {
    exact hac.tail hcd }
end

-- In this example, induction' must apply the dependent recursor for star; the
-- nondependent one doesn't apply.
lemma head_induction_on {b} {P : ∀a : α, star r a b → Prop} {a} (h : star r a b)
  (refl : P b refl)
  (head : ∀{a c} (h' : r a c) (h : star r c b), P c h → P a (h.head h')) :
  P a h :=
begin
  induction' h,
  case refl {
    exact refl },
  case tail : b c hab hbc ih {
    apply ih,
    { exact head hbc _ refl, },
    { intros _ _ hab _, exact head hab _} }
end

end star

/- Factorial -/

def accufact : ℕ → ℕ → ℕ
| a 0       := a
| a (n + 1) := accufact ((n + 1) * a) n

lemma accufact_1_eq_fact (n : ℕ) :
  accufact 1 n = nat.factorial n :=
have accufact_eq_fact_mul : ∀m a, accufact a m = nat.factorial m * a :=
  begin
    intros m a,
    induction' m,
    case zero {
      simp [nat.factorial, accufact] },
    case succ {
      simp [nat.factorial, accufact, ih, nat.succ_eq_add_one],
      cc }
  end,
by simp [accufact_eq_fact_mul n 1]

/- Substitution -/

namespace expressions

inductive exp : Type
| Var  : string → exp
| Num  : ℤ → exp
| Plus : exp → exp → exp

export exp

def subst (ρ : string → exp) : exp → exp
| (Var y)      := ρ y
| (Num i)      := Num i
| (Plus e₁ e₂) := Plus (subst e₁) (subst e₂)

lemma subst_Var (e : exp) :
  subst (λx, Var x) e = e :=
begin
  induction' e,
  case Var {
    guard_hyp s : string,
    rw [subst] },
  case Num {
    guard_hyp n : ℤ,
    rw [subst] },
  case Plus {
    guard_hyp e : exp,
    guard_hyp e_1 : exp,
    guard_hyp ih_e,
    guard_hyp ih_e_1,
    rw [subst],
    rw ih_e,
    rw ih_e_1 }
end

end expressions

/- Less-than -/

namespace less_than

inductive lt : nat → nat → Type
| zero_succ (n : nat) : lt 0 (1 + n)
| succ_succ {n m : nat} : lt n m → lt (1 + n) (1 + m)

inductive lte : nat → nat → Type
| zero (n : nat) : lte 0 n
| succ {n m : nat} : lte n m → lte (1 + n) (1 + m)

def lt_lte {n m} : lt n m → lte n m :=
begin
  intro lt_n_m,
  induction' lt_n_m,
  case zero_succ : i {
    constructor },
  case succ_succ : i j lt_i_j ih {
    constructor,
    apply ih }
end

end less_than

/- Sortedness -/

inductive sorted : list ℕ → Prop
| nil : sorted []
| single {x : ℕ} : sorted [x]
| two_or_more {x y : ℕ} {zs : list ℕ} (hle : x ≤ y)
    (hsorted : sorted (y :: zs)) :
  sorted (x :: y :: zs)

/- In this example it's important that cases' *doesn't* normalise the values of
indexes when simplifying index equations. -/
lemma not_sorted_17_13 :
  ¬ sorted [17, 13] :=
begin
  intro h,
  cases' h,
  guard_hyp hle : 17 ≤ 13,
  linarith
end

/- Palindromes -/

namespace palindrome

inductive palindrome {α : Type} : list α → Prop
| nil : palindrome []
| single (x : α) : palindrome [x]
| sandwich (x : α) (xs : list α) (hpal : palindrome xs) :
  palindrome ([x] ++ xs ++ [x])

axiom reverse_append_sandwich {α : Type} (x : α) (ys : list α) :
  list.reverse ([x] ++ ys ++ [x]) = [x] ++ list.reverse ys ++ [x]

lemma rev_palindrome {α : Type} (xs : list α) (hpal : palindrome xs) :
  palindrome (list.reverse xs) :=
begin
  induction' hpal,
  case nil {
    exact palindrome.nil },
  case single {
    exact palindrome.single _ },
  case sandwich {
    rw reverse_append_sandwich,
    apply palindrome.sandwich,
    apply ih }
end

end palindrome

/- Transitive Closure -/

namespace transitive_closure

inductive tc {α : Type} (r : α → α → Prop) : α → α → Prop
| base (x y : α) (hr : r x y) : tc x y
| step (x y z : α) (hr : r x y) (ht : tc y z) : tc x z

/- The transitive closure is a nice example with lots of variables to keep track
of. We start with a lemma where the variable names do not collide with those
appearing in the definition of the inductive predicate. -/

lemma tc_pets₁ {α : Type} (r : α → α → Prop) (c : α) :
  ∀a b, tc r a b → r b c → tc r a c :=
begin
  intros a b htab hrbc,
  induction' htab fixing c,
  case base : _ _ hrab {
    exact tc.step _ _ _ hrab (tc.base _ _ hrbc) },
  case step : _ x _ hrax {
    exact tc.step _ _ _ hrax (ih hrbc) }
end

/- The same proof, but this time the variable names clash. Also, this time we
let `induction'` generalize `z`. -/

lemma tc_pets₂ {α : Type} (r : α → α → Prop) (z : α) :
  ∀x y, tc r x y → r y z → tc r x z :=
begin
  intros x y htxy hryz,
  induction' htxy,
  case base : _ _ hrxy {
    exact tc.step _ _ _ hrxy (tc.base _ _ hryz) },
  case step : _ x' y hrxx' htx'y ih {
    exact tc.step _ _ _ hrxx' (ih _ hryz) }
end

/- Another proof along the same lines. -/

lemma tc_trans {α : Type} (r : α → α → Prop) (c : α) :
  ∀a b : α, tc r a b → tc r b c → tc r a c :=
begin
  intros a b htab htbc,
  induction' htab,
  case base {
    exact tc.step _ _ _ hr htbc },
  case step {
    exact tc.step _ _ _ hr (ih _ htbc) }
end

/- ... and with clashing variable names: -/

lemma tc_trans' {α : Type} (r : α → α → Prop) {x y z} :
  tc r x y → tc r y z → tc r x z :=
begin
  intros h₁ h₂,
  induction' h₁,
  case base {
    exact tc.step _ _ _ hr h₂ },
  case step {
    exact tc.step _ _ _ hr (ih h₂) }
end

end transitive_closure

/- Evenness -/

inductive Even : ℕ → Prop
| zero    : Even 0
| add_two : ∀k : ℕ, Even k → Even (k + 2)

lemma not_even_2_mul_add_1 (n : ℕ) :
  ¬ Even (2 * n + 1) :=
begin
  intro h,
  induction' h,
  -- No case tag since there's only one goal. I don't really like this, but
  -- this is the behaviour of induction/cases.
  {
    apply ih (n - 1),
    cases' n,
    case zero {
      linarith },
    case succ {
      simp [nat.succ_eq_add_one] at *,
      linarith } }
end

/- Big-Step Semantics -/

namespace semantics

def state :=
string → ℕ

def state.update (name : string) (val : ℕ) (s : state) : state :=
λname', if name' = name then val else s name'

notation s `{` name ` ↦ ` val `}` := state.update name val s

inductive stmt : Type
| skip   : stmt
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| ite    : (state → Prop) → stmt → stmt → stmt
| while  : (state → Prop) → stmt → stmt

export stmt

infixr ` ;; ` : 90 := stmt.seq

/- Our first version is partly uncurried, like in the Logical Verification
course, and also like in Concrete Semantics. This makes the binary infix
notation possible. -/

inductive big_step : stmt × state → state → Prop
| skip {s} :
  big_step (skip, s) s
| assign {x a s} :
  big_step (assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hS : big_step (S, s) t)
    (hT : big_step (T, t) u) :
  big_step (seq S T, s) u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : big_step (S, s) t) :
  big_step (ite b S T, s) t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : big_step (T, s) t) :
  big_step (ite b S T, s) t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : big_step (S, s) t)
    (hrest : big_step (while b S, t) u) :
  big_step (while b S, s) u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (while b S, s) s

infix ` ⟹ `:110 := big_step

open big_step

lemma not_big_step_while_true {S s t} :
  ¬ (while (λ_, true) S, s) ⟹ t :=
begin
  intro hw,
  induction' hw,
  case while_true {
    exact ih_hw_1 },
  case while_false {
    exact hcond trivial }
end

/- The same with a curried version of the predicate. It should make no
difference whether a predicate is curried or uncurried. -/

inductive curried_big_step : stmt → state → state → Prop
| skip {s} :
  curried_big_step skip s s
| assign {x a s} :
  curried_big_step (assign x a) s (s{x ↦ a s})
| seq {S T s t u} (hS : curried_big_step S s t)
    (hT : curried_big_step T t u) :
  curried_big_step (seq S T) s u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : curried_big_step S s t) :
  curried_big_step (ite b S T) s t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : curried_big_step T s t) :
  curried_big_step (ite b S T) s t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : curried_big_step S s t)
    (hrest : curried_big_step (while b S) t u) :
  curried_big_step (while b S) s u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  curried_big_step (while b S) s s

lemma not_curried_big_step_while_true {S s t} :
  ¬ curried_big_step (while (λ_, true) S) s t :=
begin
  intro hw,
  induction' hw,
  case while_true {
    exact ih_hw_1, },
  case while_false {
    exact hcond trivial }
end

end semantics

/- Small-Step Semantics -/

namespace semantics

inductive small_step : stmt × state → stmt × state → Prop
| assign {x a s} :
  small_step (assign x a, s) (skip, s{x ↦ a s})
| seq_step {S S' T s s'} (hS : small_step (S, s) (S', s')) :
  small_step (seq S T, s) (seq S' T, s')
| seq_skip {T s} :
  small_step (seq skip T, s) (T, s)
| ite_true {b : state → Prop} {S T s} (hcond : b s) :
  small_step (ite b S T, s) (S, s)
| ite_false {b : state → Prop} {S T s} (hcond : ¬ b s) :
  small_step (ite b S T, s) (T, s)
| while {b : state → Prop} {S s} :
  small_step (while b S, s) (ite b (seq S (while b S)) skip, s)

lemma small_step_if_equal_states {S T s t s' t'}
    (hstep : small_step (S, s) (T, t)) (hs : s' = s) (ht : t' = t) :
  small_step (S, s') (T, t') :=
begin
  induction' hstep,
  { rw [hs, ht],
    exact small_step.assign, },
  { apply small_step.seq_step,
    exact ih hs ht, },
  { rw [hs, ht],
    exact small_step.seq_skip, },
  { rw [hs, ht],
    exact small_step.ite_true hcond, },
  { rw [hs, ht],
    exact small_step.ite_false hcond, },
  { rw [hs, ht],
    exact small_step.while, }
end

infixr (name := small_step) ` ⇒ ` := small_step
infixr (name := small_step.star) ` ⇒* ` : 100 := star small_step

/- More lemmas about big-step and small-step semantics. These are taken from the
Logical Verification course materials. They provide lots of good test cases for
cases'/induction'. -/

namespace star

variables {α : Sort*} {r : α → α → Prop} {a b c d : α}

attribute [refl] star.refl

@[trans] lemma trans (hab : star r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction' hbc,
  case refl {
    assumption },
  case tail : c d hbc hcd hac {
    exact (star.tail (hac hab)) hcd }
end

lemma single (hab : r a b) :
  star r a b :=
star.refl.tail hab

lemma trans_induction_on {α : Sort*} {r : α → α → Prop}
    {p : ∀{a b : α}, star r a b → Prop} {a b : α} (h : star r a b)
    (ih₁ : ∀a, @p a a star.refl) (ih₂ : ∀{a b} (h : r a b), p (single h))
    (ih₃ : ∀{a b c} (h₁ : star r a b) (h₂ : star r b c), p h₁ →
       p h₂ → p (trans h₁ h₂)) :
  p h :=
begin
  induction' h,
  case refl {
    exact ih₁ a },
  case tail : b c hab hbc ih {
    exact ih₃ hab (single hbc) (ih ih₁ @ih₂ @ih₃) (ih₂ hbc) }
end

lemma lift {β : Sort*} {s : β → β → Prop} (f : α → β)
  (h : ∀a b, r a b → s (f a) (f b)) (hab : star r a b) :
  star s (f a) (f b) :=
begin
  apply trans_induction_on hab,
  exact (λ a, star.refl),
  exact (λ a b, star.single ∘ h _ _),
  exact (λ a b c _ _, star.trans)
end

end star

lemma big_step_deterministic {S s l r} (hl : (S, s) ⟹ l)
    (hr : (S, s) ⟹ r) :
  l = r :=
begin
  induction' hl,
  case skip : t {
    cases' hr,
    refl },
  case assign : x a s {
    cases' hr,
    refl },
  case seq : S T s t l hS hT ihS ihT {
    cases' hr with _ _ _ _ _ _ _ t' _ hS' hT',
    cases' ihS hS',
    cases' ihT hT',
    refl },
  case ite_true : b S T s t hb hS ih {
    cases' hr,
    { apply ih,
      assumption },
    { apply ih,
      cc } },
  case ite_false : b S T s t hb hT ih {
    cases' hr,
    { apply ih,
      cc },
    { apply ih,
      assumption } },
  case while_true : b S s t u hb hS hw ihS ihw {
    cases' hr,
    { cases' ihS hr,
      cases' ihw hr_1,
      refl },
    { cc } },
  { cases' hr,
    { cc },
    { refl } }
end

@[simp] lemma big_step_skip_iff {s t} :
  (stmt.skip, s) ⟹ t ↔ t = s :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.skip }
end

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.assign }
end

@[simp] lemma big_step_seq_iff {S T s t} :
  (S ;; T, s) ⟹ t ↔ (∃u, (S, s) ⟹ u ∧ (T, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    apply exists.intro,
    apply and.intro; assumption },
  { intro h,
    cases' h,
    cases' h,
    apply big_step.seq; assumption }
end

@[simp] lemma big_step_ite_iff {b S T s t} :
  (stmt.ite b S T, s) ⟹ t ↔
  (b s ∧ (S, s) ⟹ t) ∨ (¬ b s ∧ (T, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h; cases' h,
    { apply big_step.ite_true; assumption },
    { apply big_step.ite_false; assumption } }
end

lemma big_step_while_iff {b S s u} :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, b s ∧ (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u)
  ∨ (¬ b s ∧ u = s) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro t,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    case or.inl {
      cases' h with t h,
      cases' h with hb h,
      cases' h with hS hwhile,
      exact big_step.while_true hb hS hwhile },
    case or.inr {
      cases' h with hb hus,
      rw hus,
      exact big_step.while_false hb } }
end

lemma big_step_while_true_iff {b : state → Prop} {S s u}
    (hcond : b s) :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u) :=
by rw big_step_while_iff; simp [hcond]

@[simp] lemma big_step_while_false_iff {b : state → Prop}
    {S s t} (hcond : ¬ b s) :
  (stmt.while b S, s) ⟹ t ↔ t = s :=
by rw big_step_while_iff; simp [hcond]

lemma small_step_final (S s) :
  (¬ ∃T t, (S, s) ⇒ (T, t)) ↔ S = stmt.skip :=
begin
  induction' S,
  case skip {
    simp,
    intros T t hstep,
    cases' hstep },
  case assign : x a {
    simp,
    apply exists.intro stmt.skip,
    apply exists.intro (s{x ↦ a s}),
    exact small_step.assign },
  case seq : S T ihS ihT {
    simp,
    cases' classical.em (S = stmt.skip),
    case inl {
      rw h,
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.seq_skip },
    case inr {
      simp [h, not_forall, not_not] at ihS,
      cases' ihS s with S' hS',
      cases' hS' with s' hs',
      apply exists.intro (S' ;; T),
      apply exists.intro s',
      exact small_step.seq_step hs' } },
  case ite : b S T ihS ihT {
    simp,
    cases' classical.em (b s),
    case inl {
      apply exists.intro S,
      apply exists.intro s,
      exact small_step.ite_true h },
    case inr {
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.ite_false h } },
  case while : b S ih {
    simp,
    apply exists.intro (stmt.ite b (S ;; stmt.while b S) stmt.skip),
    apply exists.intro s,
    exact small_step.while }
end

lemma small_step_deterministic {S s Ll Rr}
    (hl : (S, s) ⇒ Ll) (hr : (S, s) ⇒ Rr) :
  Ll = Rr :=
begin
  induction' hl,
  case assign : x a s {
    cases' hr,
    refl },
  case seq_step : S S₁ T s s₁ hS₁ ih {
    cases' hr,
    case seq_step : S S₂ _ _ s₂ hS₂ {
      have hSs₁₂ := ih hS₂,
      cc },
    case seq_skip {
      cases' hS₁ } },
  case seq_skip : T s {
    cases' hr,
    { cases' hr },
    { refl } },
  case ite_true : b S T s hcond {
    cases' hr,
    case ite_true {
      refl },
    case ite_false {
      cc } },
  case ite_false : b S T s hcond {
    cases' hr,
    case ite_true {
      cc },
    case ite_false {
      refl } },
  case while : b S s {
    cases' hr,
    refl }
end

lemma small_step_skip {S s t} :
  ¬ ((stmt.skip, s) ⇒ (S, t)) :=
by intro h; cases' h

@[simp] lemma small_step_seq_iff {S T s Ut} :
  (S ;; T, s) ⇒ Ut ↔
  (∃S' t, (S, s) ⇒ (S', t) ∧ Ut = (S' ;; T, t))
  ∨ (S = stmt.skip ∧ Ut = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro S',
      apply exists.intro s',
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      cases' h,
      cases' h,
      rw right,
      apply small_step.seq_step,
      assumption },
    { cases' h,
      rw left,
      rw right,
      apply small_step.seq_skip } }
end

@[simp] lemma small_step_ite_iff {b S T s Us} :
  (stmt.ite b S T, s) ⇒ Us ↔
  (b s ∧ Us = (S, s)) ∨ (¬ b s ∧ Us = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      rw right,
      apply small_step.ite_true,
      assumption },
    { cases' h,
      rw right,
      apply small_step.ite_false,
      assumption } }
end

lemma star_small_step_seq {S T s u}
    (h : (S, s) ⇒* (stmt.skip, u)) :
  (S ;; T, s) ⇒* (stmt.skip ;; T, u) :=
begin
  apply star.lift (λSs, (prod.fst Ss ;; T, prod.snd Ss)) _ h,
  intros Ss Ss' h,
  cases' Ss,
  cases' Ss',
  apply small_step.seq_step,
  assumption
end

lemma star_small_step_of_big_step {S s t} (h : (S, s) ⟹ t) :
  (S, s) ⇒* (stmt.skip, t) :=
begin
  induction' h,
  case skip {
    refl },
  case assign {
    exact star.single small_step.assign },
  case seq : S T s t u hS hT ihS ihT {
    transitivity,
    exact star_small_step_seq ihS,
    apply star.head small_step.seq_skip ihT },
  case ite_true : b S T s t hs hst ih {
    exact star.head (small_step.ite_true hs) ih },
  case ite_false : b S T s t hs hst ih {
    exact star.head (small_step.ite_false hs) ih },
  case while_true : b S s t u hb hS hw ihS ihw {
    exact (star.head small_step.while
      (star.head (small_step.ite_true hb)
         (star.trans (star_small_step_seq ihS)
            (star.head small_step.seq_skip ihw)))) },
  case while_false : b S s hb {
    exact star.tail (star.single small_step.while)
      (small_step.ite_false hb) }
end

lemma big_step_of_small_step_of_big_step {S₀ S₁ s₀ s₁ s₂}
  (h₁ : (S₀, s₀) ⇒ (S₁, s₁)) :
  (S₁, s₁) ⟹ s₂ → (S₀, s₀) ⟹ s₂ :=
begin
  induction' h₁;
    simp [*, big_step_while_true_iff, or_imp_distrib] {contextual := tt},
  case seq_step {
    intros u hS' hT,
    apply exists.intro u,
    exact and.intro (ih hS') hT },
end

lemma big_step_of_star_small_step {S s t} :
  (S, s) ⇒* (stmt.skip, t) → (S, s) ⟹ t :=
begin
  generalize hSs : (S, s) = Ss,
  intro h,
  induction h
      using star.head_induction_on
      with _ S's' h h' ih
      generalizing S s;
    cases' hSs,
  { exact big_step.skip },
  { cases' S's' with S' s',
    apply big_step_of_small_step_of_big_step h,
    apply ih,
    refl }
end

end semantics


/-
Copyright (c) 2022 Mantas Bakšys. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mantas Bakšys
-/
import algebra.big_operators.basic
import algebra.order.module
import data.prod.lex
import group_theory.perm.support
import order.monotone.monovary
import tactic.abel

/-!
# Rearrangement inequality

This file proves the rearrangement inequality and deduces the conditions for equality and strict
inequality.

The rearrangement inequality tells you that for two functions `f g : ι → α`, the sum
`∑ i, f i * g (σ i)` is maximized over all `σ : perm ι` when `g ∘ σ` monovaries with `f` and
minimized when `g ∘ σ` antivaries with `f`.

The inequality also tells you that `∑ i, f i * g (σ i) = ∑ i, f i * g i` if and only if `g ∘ σ`
monovaries with `f` when `g` monovaries with `f`. The above equality also holds if and only if
`g ∘ σ` antivaries with `f` when `g` antivaries with `f`.

From the above two statements, we deduce that the inequality is strict if and only if `g ∘ σ` does
not monovary with `f` when `g` monovaries with `f`. Analogously, the inequality is strict if and
only if `g ∘ σ` does not antivary with `f` when `g` antivaries with `f`.

## Implementation notes

In fact, we don't need much compatibility between the addition and multiplication of `α`, so we can
actually decouple them by replacing multiplication with scalar multiplication and making `f` and `g`
land in different types.
As a bonus, this makes the dual statement trivial. The multiplication versions are provided for
convenience.

The case for `monotone`/`antitone` pairs of functions over a `linear_order` is not deduced in this
file because it is easily deducible from the `monovary` API.
-/

open equiv equiv.perm finset function order_dual
open_locale big_operators

variables {ι α β : Type*}

/-! ### Scalar multiplication versions -/

section smul
variables [linear_ordered_ring α] [linear_ordered_add_comm_group β] [module α β]
  [ordered_smul α β] {s : finset ι} {σ : perm ι} {f : ι → α} {g : ι → β}

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_smul_comp_perm_le_sum_smul (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) ≤ ∑ i in s, f i • g i :=
begin
  classical,
  revert hσ σ hfg,
  apply finset.induction_on_max_value (λ i, to_lex (g i, f i)) s,
  { simp only [le_rfl, finset.sum_empty, implies_true_iff] },
  intros a s has hamax hind σ hfg hσ,
  set τ : perm ι := σ.trans (swap a (σ a)) with hτ,
  have hτs : {x | τ x ≠ x} ⊆ s,
  { intros x hx,
    simp only [ne.def, set.mem_set_of_eq, equiv.coe_trans, equiv.swap_comp_apply] at hx,
    split_ifs at hx with h₁ h₂ h₃,
    { obtain rfl | hax := eq_or_ne x a,
      { contradiction },
      { exact mem_of_mem_insert_of_ne (hσ $ λ h, hax $ h.symm.trans h₁) hax } },
    { exact (hx $ σ.injective h₂.symm).elim },
    { exact mem_of_mem_insert_of_ne (hσ hx) (ne_of_apply_ne _ h₂) } },
  specialize hind (hfg.subset $ subset_insert _ _) hτs,
  simp_rw sum_insert has,
  refine le_trans _ (add_le_add_left hind _),
  obtain hσa | hσa := eq_or_ne a (σ a),
  { rw [hτ, ←hσa, swap_self, trans_refl] },
  have h1s : σ⁻¹ a ∈ s,
  { rw [ne.def, ←inv_eq_iff_eq] at hσa,
    refine mem_of_mem_insert_of_ne (hσ $ λ h, hσa _) hσa,
    rwa [apply_inv_self, eq_comm] at h },
  simp only [← s.sum_erase_add _ h1s, add_comm],
  rw [← add_assoc, ← add_assoc],
  simp only [hτ, swap_apply_left, function.comp_app, equiv.coe_trans, apply_inv_self],
  refine add_le_add (smul_add_smul_le_smul_add_smul' _ _) (sum_congr rfl $ λ x hx, _).le,
  { specialize hamax (σ⁻¹ a) h1s,
    rw prod.lex.le_iff at hamax,
    cases hamax,
    { exact hfg (mem_insert_of_mem h1s) (mem_insert_self _ _) hamax },
    { exact hamax.2 } },
  { specialize hamax (σ a) (mem_of_mem_insert_of_ne (hσ $ σ.injective.ne hσa.symm) hσa.symm),
    rw prod.lex.le_iff at hamax,
    cases hamax,
    { exact hamax.le },
    { exact hamax.1.le } },
  { rw [mem_erase, ne.def, eq_inv_iff_eq] at hx,
    rw swap_apply_of_ne_of_ne hx.1 (σ.injective.ne _),
    rintro rfl,
    exact has hx.2 }
end

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_smul_comp_perm_eq_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) = ∑ i in s, f i • g i ↔ monovary_on f (g ∘ σ) s :=
begin
  classical,
  refine ⟨not_imp_not.1 $ λ h, _, λ h, (hfg.sum_smul_comp_perm_le_sum_smul hσ).antisymm _⟩,
  { rw monovary_on at h,
    push_neg at h,
    obtain ⟨x, hx, y, hy, hgxy, hfxy⟩ := h,
    set τ : perm ι := (swap x y).trans σ,
    have hτs : {x | τ x ≠ x} ⊆ s,
    { refine (set_support_mul_subset σ $ swap x y).trans (set.union_subset hσ $ λ z hz, _),
      obtain ⟨_, rfl | rfl⟩ := swap_apply_ne_self_iff.1 hz; assumption },
    refine ((hfg.sum_smul_comp_perm_le_sum_smul hτs).trans_lt' _).ne,
    obtain rfl | hxy := eq_or_ne x y,
    { cases lt_irrefl _ hfxy },
    simp only [←s.sum_erase_add _ hx, ←(s.erase x).sum_erase_add _ (mem_erase.2 ⟨hxy.symm, hy⟩),
      add_assoc, equiv.coe_trans, function.comp_app, swap_apply_right, swap_apply_left],
    refine add_lt_add_of_le_of_lt (finset.sum_congr rfl $ λ z hz, _).le
      (smul_add_smul_lt_smul_add_smul hfxy hgxy),
    simp_rw mem_erase at hz,
    rw swap_apply_of_ne_of_ne hz.2.1 hz.1 },
  { convert h.sum_smul_comp_perm_le_sum_smul ((set_support_inv_eq _).subset.trans hσ) using 1,
    simp_rw [function.comp_app, apply_inv_self] }
end

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_smul_comp_perm_lt_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) < ∑ i in s, f i • g i ↔ ¬ monovary_on f (g ∘ σ) s :=
by simp [←hfg.sum_smul_comp_perm_eq_sum_smul_iff hσ,
  lt_iff_le_and_ne, hfg.sum_smul_comp_perm_le_sum_smul hσ]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_smul_le_sum_smul (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i ≤ ∑ i in s, f i • g i :=
begin
  convert hfg.sum_smul_comp_perm_le_sum_smul
    (show {x | σ⁻¹ x ≠ x} ⊆ s, by simp only [set_support_inv_eq, hσ]) using 1,
  exact σ.sum_comp' s (λ i j, f i • g j) hσ,
end

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_smul_eq_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i = ∑ i in s, f i • g i ↔ monovary_on (f ∘ σ) g s :=
begin
  have hσinv : {x | σ⁻¹ x ≠ x} ⊆ s := (set_support_inv_eq _).subset.trans hσ,
  refine (iff.trans _ $ hfg.sum_smul_comp_perm_eq_sum_smul_iff hσinv).trans ⟨λ h, _, λ h, _⟩,
  { simpa only [σ.sum_comp' s (λ i j, f i • g j) hσ] },
  { convert h.comp_right σ,
    { rw [comp.assoc, inv_def, symm_comp_self, comp.right_id] },
    { rw [σ.eq_preimage_iff_image_eq, set.image_perm hσ] } },
  { convert h.comp_right σ.symm,
    { rw [comp.assoc, self_comp_symm, comp.right_id] },
    { rw σ.symm.eq_preimage_iff_image_eq,
      exact set.image_perm hσinv } }
end

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_smul_lt_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i < ∑ i in s, f i • g i ↔ ¬ monovary_on (f ∘ σ) g s :=
by simp [←hfg.sum_comp_perm_smul_eq_sum_smul_iff hσ,
  lt_iff_le_and_ne, hfg.sum_comp_perm_smul_le_sum_smul hσ]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_smul_le_sum_smul_comp_perm (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i ≤ ∑ i in s, f i • g (σ i) :=
hfg.dual_right.sum_smul_comp_perm_le_sum_smul hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_smul_eq_sum_smul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) = ∑ i in s, f i • g i ↔ antivary_on f (g ∘ σ) s :=
(hfg.dual_right.sum_smul_comp_perm_eq_sum_smul_iff hσ).trans monovary_on_to_dual_right

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_smul_lt_sum_smul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i < ∑ i in s, f i • g (σ i) ↔ ¬ antivary_on f (g ∘ σ) s :=
by simp [←hfg.sum_smul_eq_sum_smul_comp_perm_iff hσ, lt_iff_le_and_ne, eq_comm,
  hfg.sum_smul_le_sum_smul_comp_perm hσ]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_smul_le_sum_comp_perm_smul (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i ≤ ∑ i in s, f (σ i) • g i :=
hfg.dual_right.sum_comp_perm_smul_le_sum_smul hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_smul_eq_sum_comp_perm_smul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i = ∑ i in s, f i • g i ↔ antivary_on (f ∘ σ) g s :=
(hfg.dual_right.sum_comp_perm_smul_eq_sum_smul_iff hσ).trans monovary_on_to_dual_right

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_smul_lt_sum_comp_perm_smul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i < ∑ i in s, f (σ i) • g i ↔ ¬ antivary_on (f ∘ σ) g s :=
by simp [←hfg.sum_smul_eq_sum_comp_perm_smul_iff hσ, eq_comm, lt_iff_le_and_ne,
  hfg.sum_smul_le_sum_comp_perm_smul hσ]

variables [fintype ι]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_smul_comp_perm_le_sum_smul (hfg : monovary f g) :
  ∑ i, f i • g (σ i) ≤ ∑ i, f i • g i :=
(hfg.monovary_on _).sum_smul_comp_perm_le_sum_smul $ λ i _, mem_univ _

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_smul_comp_perm_eq_sum_smul_iff (hfg : monovary f g) :
  ∑ i, f i • g (σ i) = ∑ i, f i • g i ↔ monovary f (g ∘ σ) :=
by simp [(hfg.monovary_on _).sum_smul_comp_perm_eq_sum_smul_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_smul_comp_perm_lt_sum_smul_iff (hfg : monovary f g) :
  ∑ i, f i • g (σ i) < ∑ i, f i • g i ↔ ¬ monovary f (g ∘ σ) :=
by simp [(hfg.monovary_on _).sum_smul_comp_perm_lt_sum_smul_iff (λ i _, mem_univ _)]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary.sum_comp_perm_smul_le_sum_smul (hfg : monovary f g) :
  ∑ i, f (σ i) • g i ≤ ∑ i, f i • g i :=
(hfg.monovary_on _).sum_comp_perm_smul_le_sum_smul $ λ i _, mem_univ _

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_smul_eq_sum_smul_iff (hfg : monovary f g) :
  ∑ i, f (σ i) • g i = ∑ i, f i • g i ↔ monovary (f ∘ σ) g :=
by simp [(hfg.monovary_on _).sum_comp_perm_smul_eq_sum_smul_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_smul_lt_sum_smul_iff (hfg : monovary f g) :
   ∑ i, f (σ i) • g i < ∑ i, f i • g i ↔ ¬ monovary (f ∘ σ) g :=
by simp [(hfg.monovary_on _).sum_comp_perm_smul_lt_sum_smul_iff (λ i _, mem_univ _)]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_smul_le_sum_smul_comp_perm (hfg : antivary f g) :
  ∑ i, f i • g i ≤ ∑ i, f i • g (σ i) :=
(hfg.antivary_on _).sum_smul_le_sum_smul_comp_perm $ λ i _, mem_univ _

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_smul_eq_sum_smul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i • g (σ i) = ∑ i, f i • g i ↔ antivary f (g ∘ σ) :=
by simp [(hfg.antivary_on _).sum_smul_eq_sum_smul_comp_perm_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_smul_lt_sum_smul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i • g i < ∑ i, f i • g (σ i) ↔ ¬ antivary f (g ∘ σ) :=
by simp [(hfg.antivary_on _).sum_smul_lt_sum_smul_comp_perm_iff (λ i _, mem_univ _)]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_smul_le_sum_comp_perm_smul (hfg : antivary f g) :
  ∑ i, f i • g i ≤ ∑ i, f (σ i) • g i :=
(hfg.antivary_on _).sum_smul_le_sum_comp_perm_smul $ λ i _, mem_univ _

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_smul_eq_sum_comp_perm_smul_iff (hfg : antivary f g) :
  ∑ i, f (σ i) • g i = ∑ i, f i • g i ↔ antivary (f ∘ σ) g :=
by simp [(hfg.antivary_on _).sum_smul_eq_sum_comp_perm_smul_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_smul_lt_sum_comp_perm_smul_iff (hfg : antivary f g) :
  ∑ i, f i • g i < ∑ i, f (σ i) • g i ↔ ¬ antivary (f ∘ σ) g :=
by simp [(hfg.antivary_on _).sum_smul_lt_sum_comp_perm_smul_iff (λ i _, mem_univ _)]

end smul

/-!
### Multiplication versions

Special cases of the above when scalar multiplication is actually multiplication.
-/

section mul
variables [linear_ordered_ring α] {s : finset ι} {σ : perm ι} {f g : ι → α}

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_mul_comp_perm_le_sum_mul (hfg : monovary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g (σ i) ≤ ∑ i in s, f i * g i :=
hfg.sum_smul_comp_perm_le_sum_smul hσ

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_mul_comp_perm_eq_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g (σ i) = ∑ i in s, f i * g i ↔ monovary_on f (g ∘ σ) s :=
hfg.sum_smul_comp_perm_eq_sum_smul_iff hσ

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_mul_comp_perm_lt_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) < ∑ i in s, f i • g i ↔ ¬ monovary_on f (g ∘ σ) s :=
hfg.sum_smul_comp_perm_lt_sum_smul_iff hσ

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_mul_le_sum_mul (hfg : monovary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i ≤ ∑ i in s, f i * g i :=
hfg.sum_comp_perm_smul_le_sum_smul hσ

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_mul_eq_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i = ∑ i in s, f i * g i ↔ monovary_on (f ∘ σ) g s :=
hfg.sum_comp_perm_smul_eq_sum_smul_iff hσ

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_mul_lt_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i < ∑ i in s, f i * g i ↔ ¬ monovary_on (f ∘ σ) g s :=
hfg.sum_comp_perm_smul_lt_sum_smul_iff hσ

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_mul_le_sum_mul_comp_perm (hfg : antivary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i ≤ ∑ i in s, f i * g (σ i) :=
hfg.sum_smul_le_sum_smul_comp_perm hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_mul_eq_sum_mul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g (σ i) = ∑ i in s, f i * g i ↔ antivary_on f (g ∘ σ) s :=
hfg.sum_smul_eq_sum_smul_comp_perm_iff hσ

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_mul_lt_sum_mul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i < ∑ i in s, f i * g (σ i) ↔ ¬ antivary_on f (g ∘ σ) s :=
hfg.sum_smul_lt_sum_smul_comp_perm_iff hσ

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_mul_le_sum_comp_perm_mul (hfg : antivary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i ≤ ∑ i in s, f (σ i) * g i :=
hfg.sum_smul_le_sum_comp_perm_smul hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_mul_eq_sum_comp_perm_mul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i = ∑ i in s, f i * g i ↔ antivary_on (f ∘ σ) g s :=
hfg.sum_smul_eq_sum_comp_perm_smul_iff hσ

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_mul_lt_sum_comp_perm_mul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i < ∑ i in s, f (σ i) * g i ↔ ¬ antivary_on (f ∘ σ) g s :=
hfg.sum_smul_lt_sum_comp_perm_smul_iff hσ

variables [fintype ι]

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_mul_comp_perm_le_sum_mul (hfg : monovary f g) :
  ∑ i, f i * g (σ i) ≤ ∑ i, f i * g i :=
hfg.sum_smul_comp_perm_le_sum_smul

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_mul_comp_perm_eq_sum_mul_iff (hfg : monovary f g) :
  ∑ i, f i * g (σ i) = ∑ i, f i * g i ↔ monovary f (g ∘ σ) :=
hfg.sum_smul_comp_perm_eq_sum_smul_iff

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_mul_comp_perm_lt_sum_mul_iff (hfg : monovary f g) :
  ∑ i, f i * g (σ i) < ∑ i, f i * g i ↔ ¬ monovary f (g ∘ σ) :=
hfg.sum_smul_comp_perm_lt_sum_smul_iff

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary.sum_comp_perm_mul_le_sum_mul (hfg : monovary f g) :
  ∑ i, f (σ i) * g i ≤ ∑ i, f i * g i :=
hfg.sum_comp_perm_smul_le_sum_smul

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_mul_eq_sum_mul_iff (hfg : monovary f g) :
  ∑ i, f (σ i) * g i = ∑ i, f i * g i ↔ monovary (f ∘ σ) g :=
hfg.sum_comp_perm_smul_eq_sum_smul_iff

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_mul_lt_sum_mul_iff (hfg : monovary f g) :
   ∑ i, f (σ i) * g i < ∑ i, f i * g i ↔ ¬ monovary (f ∘ σ) g :=
hfg.sum_comp_perm_smul_lt_sum_smul_iff

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_mul_le_sum_mul_comp_perm (hfg : antivary f g) :
  ∑ i, f i * g i ≤ ∑ i, f i * g (σ i) :=
hfg.sum_smul_le_sum_smul_comp_perm

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_mul_eq_sum_mul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i * g (σ i) = ∑ i, f i * g i ↔ antivary f (g ∘ σ) :=
hfg.sum_smul_eq_sum_smul_comp_perm_iff

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_mul_lt_sum_mul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i • g i < ∑ i, f i • g (σ i) ↔ ¬ antivary f (g ∘ σ) :=
hfg.sum_smul_lt_sum_smul_comp_perm_iff

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_mul_le_sum_comp_perm_mul (hfg : antivary f g) :
  ∑ i, f i * g i ≤ ∑ i, f (σ i) * g i :=
hfg.sum_smul_le_sum_comp_perm_smul

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_mul_eq_sum_comp_perm_mul_iff (hfg : antivary f g) :
  ∑ i, f (σ i) * g i = ∑ i, f i * g i ↔ antivary (f ∘ σ) g :=
hfg.sum_smul_eq_sum_comp_perm_smul_iff

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_mul_lt_sum_comp_perm_mul_iff (hfg : antivary f g) :
  ∑ i, f i * g i < ∑ i, f (σ i) * g i ↔ ¬ antivary (f ∘ σ) g :=
hfg.sum_smul_lt_sum_comp_perm_smul_iff

end mul


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

Topology of the complex numbers.
-/
import data.complex.basic topology.metric_space.basic topology.instances.real

noncomputable theory
open filter metric

namespace complex

-- TODO(Mario): these proofs are all copied from analysis/real. Generalize
-- to normed fields
instance : metric_space ℂ :=
{ dist               := λx y, (x - y).abs,
  dist_self          := by simp [abs_zero],
  eq_of_dist_eq_zero := by simp [add_neg_eq_zero],
  dist_comm          := assume x y, complex.abs_sub _ _,
  dist_triangle      := assume x y z, complex.abs_sub_le _ _ _ }

theorem dist_eq (x y : ℂ) : dist x y = (x - y).abs := rfl

theorem uniform_continuous_add : uniform_continuous (λp : ℂ × ℂ, p.1 + p.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_add_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h, let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ h₁ h₂⟩

theorem uniform_continuous_neg : uniform_continuous (@has_neg.neg ℂ _) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, ⟨_, ε0, λ a b h,
  by rw dist_comm at h; simpa [dist_eq] using h⟩

instance : uniform_add_group ℂ :=
uniform_add_group.mk' uniform_continuous_add uniform_continuous_neg

instance : topological_add_group ℂ := by apply_instance

lemma uniform_continuous_inv (s : set ℂ) {r : ℝ} (r0 : 0 < r) (H : ∀ x ∈ s, r ≤ abs x) :
  uniform_continuous (λp:s, p.1⁻¹) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_inv_continuous_lemma abs ε0 r0 in
⟨δ, δ0, λ a b h, Hδ (H _ a.2) (H _ b.2) h⟩

lemma uniform_continuous_abs : uniform_continuous (abs : ℂ → ℝ) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
  ⟨ε, ε0, λ a b, lt_of_le_of_lt (abs_abs_sub_le_abs_sub _ _)⟩

lemma continuous_abs : continuous (abs : ℂ → ℝ) :=
uniform_continuous_abs.continuous

lemma tendsto_inv {r : ℂ} (r0 : r ≠ 0) : tendsto (λq, q⁻¹) (nhds r) (nhds r⁻¹) :=
by rw ← abs_pos at r0; exact
tendsto_of_uniform_continuous_subtype
  (uniform_continuous_inv {x | abs r / 2 < abs x} (half_pos r0) (λ x h, le_of_lt h))
  (mem_nhds_sets (continuous_abs _ $ is_open_lt' (abs r / 2)) (half_lt_self r0))

lemma continuous_inv' : continuous (λa:{r:ℂ // r ≠ 0}, a.val⁻¹) :=
continuous_iff_continuous_at.mpr $ assume ⟨r, hr⟩,
  (continuous_iff_continuous_at.mp continuous_subtype_val _).comp (tendsto_inv hr)

lemma continuous_inv {α} [topological_space α] {f : α → ℂ} (h : ∀a, f a ≠ 0) (hf : continuous f) :
  continuous (λa, (f a)⁻¹) :=
show continuous ((has_inv.inv ∘ @subtype.val ℂ (λr, r ≠ 0)) ∘ λa, ⟨f a, h a⟩),
  from (continuous_subtype_mk _ hf).comp continuous_inv'

lemma uniform_continuous_mul_const {x : ℂ} : uniform_continuous ((*) x) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, begin
  cases no_top (abs x) with y xy,
  have y0 := lt_of_le_of_lt (abs_nonneg _) xy,
  refine ⟨_, div_pos ε0 y0, λ a b h, _⟩,
  rw [dist_eq, ← mul_sub, abs_mul, ← mul_div_cancel' ε (ne_of_gt y0)],
  exact mul_lt_mul' (le_of_lt xy) h (abs_nonneg _) y0
end

lemma uniform_continuous_mul (s : set (ℂ × ℂ))
  {r₁ r₂ : ℝ} (r₁0 : 0 < r₁) (r₂0 : 0 < r₂)
  (H : ∀ x ∈ s, abs (x : ℂ × ℂ).1 < r₁ ∧ abs x.2 < r₂) :
  uniform_continuous (λp:s, p.1.1 * p.1.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_mul_continuous_lemma abs ε0 r₁0 r₂0 in
⟨δ, δ0, λ a b h,
  let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ (H _ a.2).1 (H _ b.2).2 h₁ h₂⟩

protected lemma continuous_mul : continuous (λp : ℂ × ℂ, p.1 * p.2) :=
continuous_iff_continuous_at.2 $ λ ⟨a₁, a₂⟩,
tendsto_of_uniform_continuous_subtype
  (uniform_continuous_mul
    ({x | abs x < abs a₁ + 1}.prod {x | abs x < abs a₂ + 1})
    (lt_of_le_of_lt (abs_nonneg _) (lt_add_one _))
    (lt_of_le_of_lt (abs_nonneg _) (lt_add_one _))
    (λ x, id))
  (mem_nhds_sets
    (is_open_prod
      (continuous_abs _ $ is_open_gt' (abs a₁ + 1))
      (continuous_abs _ $ is_open_gt' (abs a₂ + 1)))
    ⟨lt_add_one (abs a₁), lt_add_one (abs a₂)⟩)

local attribute [semireducible] real.le

lemma uniform_continuous_re : uniform_continuous re :=
metric.uniform_continuous_iff.2 (λ ε ε0, ⟨ε, ε0, λ _ _, lt_of_le_of_lt (abs_re_le_abs _)⟩)

lemma continuous_re : continuous re := uniform_continuous_re.continuous

lemma uniform_continuous_im : uniform_continuous im :=
metric.uniform_continuous_iff.2 (λ ε ε0, ⟨ε, ε0, λ _ _, lt_of_le_of_lt (abs_im_le_abs _)⟩)

lemma continuous_im : continuous im := uniform_continuous_im.continuous

lemma uniform_continuous_of_real : uniform_continuous of_real :=
metric.uniform_continuous_iff.2 (λ ε ε0, ⟨ε, ε0, λ _ _,
  by rw [real.dist_eq, complex.dist_eq, of_real_eq_coe, of_real_eq_coe, ← of_real_sub, abs_of_real];
    exact id⟩)

lemma continuous_of_real : continuous of_real := uniform_continuous_of_real.continuous

instance : topological_ring ℂ :=
{ continuous_mul := complex.continuous_mul, ..complex.topological_add_group }

instance : topological_semiring ℂ := by apply_instance

def real_prod_homeo : homeomorph ℂ (ℝ × ℝ) :=
{ to_equiv := real_prod_equiv,
  continuous_to_fun := continuous.prod_mk continuous_re continuous_im,
  continuous_inv_fun := show continuous (λ p : ℝ × ℝ, complex.mk p.1 p.2),
    by simp only [mk_eq_add_mul_I]; exact
    continuous_add
      (continuous_fst.comp continuous_of_real)
      (continuous_mul (continuous_snd.comp continuous_of_real) continuous_const) }

instance : proper_space ℂ :=
⟨λx r, begin
  refine real_prod_homeo.symm.compact_preimage.1
    (compact_of_is_closed_subset
      (compact_prod _ _ (proper_space.compact_ball x.re r) (proper_space.compact_ball x.im r))
      (continuous_iff_is_closed.1 real_prod_homeo.symm.continuous _ is_closed_ball) _),
  exact λ p h, ⟨
    le_trans (abs_re_le_abs (⟨p.1, p.2⟩ - x)) h,
    le_trans (abs_im_le_abs (⟨p.1, p.2⟩ - x)) h⟩
end⟩

end complex


import tactic --hide
lemma not_iff_imp_false (P : Prop) : ¬ P ↔ P → false := iff.rfl -- hide
/-
In this level we will prove that `P ∧ ¬ P` is always false. This is an example of a *contradiction*.

-/

/-Lemma
If $P$ is a logical statement, then $P ∧ ¬P$ is false.
-/
lemma P_not_P_false (P : Prop) : P ∧ ¬ P → false :=
begin
  intro h,
  cases h with h1 h2,
  rw not_iff_imp_false at h2,
  apply h2,
  exact h1,

end


/-
Copyright (c) 2022 Yaël Dillies, Violeta Hernández Palacios. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Violeta Hernández Palacios, Grayson Burton, Vladimir Ivanov
-/
import data.finset.basic
import data.int.succ_pred

/-!
# Graded orders

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

This file defines graded orders, also known as ranked orders.

A `𝕆`-graded order is an order `α` equipped with a distinguished "grade" function `α → 𝕆` which
should be understood as giving the "height" of the elements. Usual graded orders are `ℕ`-graded,
cograded orders are `ℕᵒᵈ`-graded, but we can also grade by `ℤ`, and polytopes are naturally
`fin n`-graded.

Visually, `grade ℕ a` is the height of `a` in the Hasse diagram of `α`.

## Main declarations

* `grade_order`: Graded order.
* `grade_min_order`: Graded order where minimal elements have minimal grades.
* `grade_max_order`: Graded order where maximal elements have maximal grades.
* `grade_bounded_order`: Graded order where minimal elements have minimal grades and maximal
  elements have maximal grades.
* `grade`: The grade of an element. Because an order can admit several gradings, the first argument
  is the order we grade by.
* `grade_max_order`: Graded orders with maximal elements. All maximal elements have the same grade.
* `max_grade`: The maximum grade in a `grade_max_order`.
* `order_embedding.grade`: The grade of an element in a linear order as an order embedding.

## How to grade your order

Here are the translations between common references and our `grade_order`:
* [Stanley][stanley2012] defines a graded order of rank `n` as an order where all maximal chains
  have "length" `n` (so the number of elements of a chain is `n + 1`). This corresponds to
  `grade_bounded_order (fin (n + 1)) α`.
* [Engel][engel1997]'s ranked orders are somewhere between `grade_order ℕ α` and
  `grade_min_order ℕ α`, in that he requires `∃ a, is_min a ∧ grade ℕ a + 0` rather than
  `∀ a, is_min a → grade ℕ a = 0`. He defines a graded order as an order where all minimal elements
  have grade `0` and all maximal elements have the same grade. This is roughly a less bundled
  version of `grade_bounded_order (fin n) α`, assuming we discard orders with infinite chains.

## Implementation notes

One possible definition of graded orders is as the bounded orders whose flags (maximal chains)
all have the same finite length (see Stanley p. 99). However, this means that all graded orders must
have minimal and maximal elements and that the grade is not data.

Instead, we define graded orders by their grade function, without talking about flags yet.

## References

* [Konrad Engel, *Sperner Theory*][engel1997]
* [Richard Stanley, *Enumerative Combinatorics*][stanley2012]
-/

set_option old_structure_cmd true

open finset nat order_dual

variables {𝕆 ℙ α β : Type*}

/-- An `𝕆`-graded order is an order `α` equipped with a strictly monotone function `grade 𝕆 : α → 𝕆`
which preserves order covering (`covby`). -/
class grade_order (𝕆 α : Type*) [preorder 𝕆] [preorder α] :=
(grade : α → 𝕆)
(grade_strict_mono : strict_mono grade)
(covby_grade ⦃a b : α⦄ : a ⋖ b → grade a ⋖ grade b)

/-- A `𝕆`-graded order where minimal elements have minimal grades. -/
class grade_min_order (𝕆 α : Type*) [preorder 𝕆] [preorder α] extends grade_order 𝕆 α :=
(is_min_grade ⦃a : α⦄ : is_min a → is_min (grade a))

/-- A `𝕆`-graded order where maximal elements have maximal grades. -/
class grade_max_order (𝕆 α : Type*) [preorder 𝕆] [preorder α] extends grade_order 𝕆 α :=
(is_max_grade ⦃a : α⦄ : is_max a → is_max (grade a))

/-- A `𝕆`-graded order where minimal elements have minimal grades and maximal elements have maximal
grades. -/
class grade_bounded_order (𝕆 α : Type*) [preorder 𝕆] [preorder α]
  extends grade_min_order 𝕆 α, grade_max_order 𝕆 α

section preorder -- grading
variables [preorder 𝕆]

section preorder -- graded order
variables [preorder α]

section grade_order
variables (𝕆) [grade_order 𝕆 α] {a b : α}

/-- The grade of an element in a graded order. Morally, this is the number of elements you need to
go down by to get to `⊥`. -/
def grade : α → 𝕆 := grade_order.grade

protected lemma covby.grade (h : a ⋖ b) : grade 𝕆 a ⋖ grade 𝕆 b := grade_order.covby_grade h

variables {𝕆}

lemma grade_strict_mono : strict_mono (grade 𝕆 : α → 𝕆) := grade_order.grade_strict_mono

lemma covby_iff_lt_covby_grade : a ⋖ b ↔ a < b ∧ grade 𝕆 a ⋖ grade 𝕆 b :=
⟨λ h, ⟨h.1, h.grade _⟩, and.imp_right $ λ h c ha hb,
  h.2 (grade_strict_mono ha) $ grade_strict_mono hb⟩

end grade_order

section grade_min_order
variables (𝕆) [grade_min_order 𝕆 α] {a : α}

protected lemma is_min.grade (h : is_min a) : is_min (grade 𝕆 a) := grade_min_order.is_min_grade h

variables {𝕆}

@[simp] lemma is_min_grade_iff : is_min (grade 𝕆 a) ↔ is_min a :=
⟨grade_strict_mono.is_min_of_apply, is_min.grade _⟩

end grade_min_order

section grade_max_order
variables (𝕆) [grade_max_order 𝕆 α] {a : α}

protected lemma is_max.grade (h : is_max a) : is_max (grade 𝕆 a) := grade_max_order.is_max_grade h

variables {𝕆}

@[simp] lemma is_max_grade_iff : is_max (grade 𝕆 a) ↔ is_max a :=
⟨grade_strict_mono.is_max_of_apply, is_max.grade _⟩

end grade_max_order
end preorder -- graded order

lemma grade_mono [partial_order α] [grade_order 𝕆 α] : monotone (grade 𝕆 : α → 𝕆) :=
grade_strict_mono.monotone

section linear_order -- graded order
variables [linear_order α] [grade_order 𝕆 α] {a b : α}

lemma grade_injective : function.injective (grade 𝕆 : α → 𝕆) := grade_strict_mono.injective
@[simp] lemma grade_le_grade_iff : grade 𝕆 a ≤ grade 𝕆 b ↔ a ≤ b := grade_strict_mono.le_iff_le
@[simp] lemma grade_lt_grade_iff : grade 𝕆 a < grade 𝕆 b ↔ a < b := grade_strict_mono.lt_iff_lt
@[simp] lemma grade_eq_grade_iff : grade 𝕆 a = grade 𝕆 b ↔ a = b := grade_injective.eq_iff
lemma grade_ne_grade_iff : grade 𝕆 a ≠ grade 𝕆 b ↔ a ≠ b := grade_injective.ne_iff

lemma grade_covby_grade_iff : grade 𝕆 a ⋖ grade 𝕆 b ↔ a ⋖ b :=
(covby_iff_lt_covby_grade.trans $ and_iff_right_of_imp $ λ h, grade_lt_grade_iff.1 h.1).symm

end linear_order -- graded order
end preorder -- grading

section partial_order
variables [partial_order 𝕆] [preorder α]

@[simp] lemma grade_bot [order_bot 𝕆] [order_bot α] [grade_min_order 𝕆 α] : grade 𝕆 (⊥ : α) = ⊥ :=
(is_min_bot.grade _).eq_bot

@[simp] lemma grade_top [order_top 𝕆] [order_top α] [grade_max_order 𝕆 α] : grade 𝕆 (⊤ : α) = ⊤ :=
(is_max_top.grade _).eq_top

end partial_order

/-! ### Instances -/

variables [preorder 𝕆] [preorder ℙ] [preorder α] [preorder β]

instance preorder.to_grade_bounded_order : grade_bounded_order α α :=
{ grade := id,
  is_min_grade := λ _, id,
  is_max_grade := λ _, id,
  grade_strict_mono := strict_mono_id,
  covby_grade := λ a b, id }

@[simp] lemma grade_self (a : α) : grade α a = a := rfl

/-! #### Dual -/

instance [grade_order 𝕆 α] : grade_order 𝕆ᵒᵈ αᵒᵈ :=
{ grade := to_dual ∘ grade 𝕆 ∘ of_dual,
  grade_strict_mono := grade_strict_mono.dual,
  covby_grade := λ a b h, (h.of_dual.grade _).to_dual }

instance [grade_max_order 𝕆 α] : grade_min_order 𝕆ᵒᵈ αᵒᵈ :=
{ is_min_grade := λ _, is_max.grade _,
  ..order_dual.grade_order }

instance [grade_min_order 𝕆 α] : grade_max_order 𝕆ᵒᵈ αᵒᵈ :=
{ is_max_grade := λ _, is_min.grade _,
  ..order_dual.grade_order }

instance [grade_bounded_order 𝕆 α] : grade_bounded_order 𝕆ᵒᵈ αᵒᵈ :=
{ ..order_dual.grade_min_order, ..order_dual.grade_max_order }

@[simp] lemma grade_to_dual [grade_order 𝕆 α] (a : α) :
  grade 𝕆ᵒᵈ (to_dual a) = to_dual (grade 𝕆 a) := rfl
@[simp] lemma grade_of_dual [grade_order 𝕆 α] (a : αᵒᵈ) :
  grade 𝕆 (of_dual a) = of_dual (grade 𝕆ᵒᵈ a) := rfl

/-! #### Lifting a graded order -/

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_order.lift_left [grade_order 𝕆 α] (f : 𝕆 → ℙ) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) : grade_order ℙ α :=
{ grade := f ∘ grade 𝕆,
  grade_strict_mono := hf.comp grade_strict_mono,
  covby_grade := λ a b h, hcovby _ _ $ h.grade _ }

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_min_order.lift_left [grade_min_order 𝕆 α] (f : 𝕆 → ℙ) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) (hmin : ∀ a, is_min a → is_min (f a)) :
  grade_min_order ℙ α :=
{ is_min_grade := λ a ha, hmin _ $ ha.grade _,
  ..grade_order.lift_left f hf hcovby }

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_max_order.lift_left [grade_max_order 𝕆 α] (f : 𝕆 → ℙ) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) (hmax : ∀ a, is_max a → is_max (f a)) :
  grade_max_order ℙ α :=
{ is_max_grade := λ a ha, hmax _ $ ha.grade _,
  ..grade_order.lift_left f hf hcovby }

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_bounded_order.lift_left [grade_bounded_order 𝕆 α] (f : 𝕆 → ℙ) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) (hmin : ∀ a, is_min a → is_min (f a))
  (hmax : ∀ a, is_max a → is_max (f a)) :
  grade_bounded_order ℙ α :=
{ ..grade_min_order.lift_left f hf hcovby hmin, ..grade_max_order.lift_left f hf hcovby hmax }

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_order.lift_right [grade_order 𝕆 β] (f : α → β) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) : grade_order 𝕆 α :=
{ grade := grade 𝕆 ∘ f,
  grade_strict_mono := grade_strict_mono.comp hf,
  covby_grade := λ a b h, (hcovby _ _ h).grade _ }

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_min_order.lift_right [grade_min_order 𝕆 β] (f : α → β) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) (hmin : ∀ a, is_min a → is_min (f a)) :
  grade_min_order 𝕆 α :=
{ is_min_grade := λ a ha, (hmin _ ha).grade _,
  ..grade_order.lift_right f hf hcovby }

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_max_order.lift_right [grade_max_order 𝕆 β] (f : α → β) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) (hmax : ∀ a, is_max a → is_max (f a)) :
  grade_max_order 𝕆 α :=
{ is_max_grade := λ a ha, (hmax _ ha).grade _,
  ..grade_order.lift_right f hf hcovby }

/-- Lifts a graded order along a strictly monotone function. -/
@[reducible] -- See note [reducible non-instances]
def grade_bounded_order.lift_right [grade_bounded_order 𝕆 β] (f : α → β) (hf : strict_mono f)
  (hcovby : ∀ a b, a ⋖ b → f a ⋖ f b) (hmin : ∀ a, is_min a → is_min (f a))
  (hmax : ∀ a, is_max a → is_max (f a)) : grade_bounded_order 𝕆 α :=
{ ..grade_min_order.lift_right f hf hcovby hmin, ..grade_max_order.lift_right f hf hcovby hmax }

/-! #### `fin n`-graded to `ℕ`-graded to `ℤ`-graded -/

/-- A `fin n`-graded order is also `ℕ`-graded. We do not mark this an instance because `n` is not
inferrable. -/
@[reducible] -- See note [reducible non-instances]
def grade_order.fin_to_nat (n : ℕ) [grade_order (fin n) α] : grade_order ℕ α :=
grade_order.lift_left (_ : fin n → ℕ) fin.coe_strict_mono $ λ _ _, covby.coe_fin

/-- A `fin n`-graded order is also `ℕ`-graded. We do not mark this an instance because `n` is not
inferrable. -/
@[reducible] -- See note [reducible non-instances]
def grade_min_order.fin_to_nat (n : ℕ) [grade_min_order (fin n) α] : grade_min_order ℕ α :=
grade_min_order.lift_left (_ : fin n → ℕ) fin.coe_strict_mono (λ _ _, covby.coe_fin) $ λ a h, begin
    unfreezingI { cases n },
    { exact (@fin.elim0 (λ _, false) $ grade (fin 0) a).elim },
    rw [h.eq_bot, fin.bot_eq_zero],
    exact is_min_bot,
  end

instance grade_order.nat_to_int [grade_order ℕ α] : grade_order ℤ α :=
grade_order.lift_left _ int.coe_nat_strict_mono $ λ _ _, covby.cast_int


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

import algebra.field_power
import data.rat

/-!
# Archimedean groups and fields.

This file defines the archimedean property for ordered groups and proves several results connected
to this notion. Being archimedean means that for all elements `x` and `y>0` there exists a natural
number `n` such that `x ≤ n • y`.

## Main definitions

* `archimedean` is a typeclass for an ordered additive commutative monoid to have the archimedean
  property.
* `archimedean.floor_ring` defines a floor function on an archimedean linearly ordered ring making
  it into a `floor_ring`.
* `round` defines a function rounding to the nearest integer for a linearly ordered field which is
  also a floor ring.

## Main statements

* `ℕ`, `ℤ`, and `ℚ` are archimedean.
-/

variables {α : Type*}

/-- An ordered additive commutative monoid is called `archimedean` if for any two elements `x`, `y`
such that `0 < y` there exists a natural number `n` such that `x ≤ n • y`. -/
class archimedean (α) [ordered_add_comm_monoid α] : Prop :=
(arch : ∀ (x : α) {y}, 0 < y → ∃ n : ℕ, x ≤ n • y)

namespace linear_ordered_add_comm_group
variables [linear_ordered_add_comm_group α] [archimedean α]

/-- An archimedean decidable linearly ordered `add_comm_group` has a version of the floor: for
`a > 0`, any `g` in the group lies between some two consecutive multiples of `a`. -/
lemma exists_int_smul_near_of_pos {a : α} (ha : 0 < a) (g : α) :
  ∃ (k : ℤ), k • a ≤ g ∧ g < (k + 1) • a :=
begin
  let s : set ℤ := {n : ℤ | n • a ≤ g},
  obtain ⟨k, hk : -g ≤ k • a⟩ := archimedean.arch (-g) ha,
  have h_ne : s.nonempty := ⟨-k, by simpa using neg_le_neg hk⟩,
  obtain ⟨k, hk⟩ := archimedean.arch g ha,
  have h_bdd : ∀ n ∈ s, n ≤ (k : ℤ),
  { assume n hn,
    apply (gsmul_le_gsmul_iff ha).mp,
    rw ← gsmul_coe_nat at hk,
    exact le_trans hn hk },
  obtain ⟨m, hm, hm'⟩ := int.exists_greatest_of_bdd ⟨k, h_bdd⟩ h_ne,
  refine ⟨m, hm, _⟩,
  by_contra H,
  linarith [hm' _ $ not_lt.mp H]
end

lemma exists_int_smul_near_of_pos' {a : α} (ha : 0 < a) (g : α) :
  ∃ (k : ℤ), 0 ≤ g - k • a ∧ g - k • a < a :=
begin
  obtain ⟨k, h1, h2⟩ := exists_int_smul_near_of_pos ha g,
  rw add_gsmul at h2,
  refine ⟨k, sub_nonneg.mpr h1, _⟩,
  simpa [sub_lt_iff_lt_add'] using h2
end

end linear_ordered_add_comm_group

theorem exists_nat_gt [ordered_semiring α] [nontrivial α] [archimedean α]
  (x : α) : ∃ n : ℕ, x < n :=
let ⟨n, h⟩ := archimedean.arch x zero_lt_one in
⟨n+1, lt_of_le_of_lt (by rwa ← nsmul_one)
  (nat.cast_lt.2 (nat.lt_succ_self _))⟩

theorem exists_nat_ge [ordered_semiring α] [archimedean α] (x : α) :
  ∃ n : ℕ, x ≤ n :=
begin
  nontriviality α,
  exact (exists_nat_gt x).imp (λ n, le_of_lt)
end

lemma add_one_pow_unbounded_of_pos [ordered_semiring α] [nontrivial α] [archimedean α]
  (x : α) {y : α} (hy : 0 < y) :
  ∃ n : ℕ, x < (y + 1) ^ n :=
have 0 ≤ 1 + y, from add_nonneg zero_le_one hy.le,
let ⟨n, h⟩ := archimedean.arch x hy in
⟨n, calc x ≤ n • y : h
       ... = n * y : nsmul_eq_mul _ _
       ... < 1 + n * y : lt_one_add _
       ... ≤ (1 + y) ^ n : one_add_mul_le_pow' (mul_nonneg hy.le hy.le) (mul_nonneg this this)
                             (add_nonneg zero_le_two hy.le) _
       ... = (y + 1) ^ n : by rw [add_comm]⟩

section linear_ordered_ring
variables [linear_ordered_ring α] [archimedean α]

lemma pow_unbounded_of_one_lt (x : α) {y : α} (hy1 : 1 < y) :
  ∃ n : ℕ, x < y ^ n :=
sub_add_cancel y 1 ▸ add_one_pow_unbounded_of_pos _ (sub_pos.2 hy1)

/-- Every x greater than or equal to 1 is between two successive
natural-number powers of every y greater than one. -/
lemma exists_nat_pow_near {x : α} {y : α} (hx : 1 ≤ x) (hy : 1 < y) :
  ∃ n : ℕ, y ^ n ≤ x ∧ x < y ^ (n + 1) :=
have h : ∃ n : ℕ, x < y ^ n, from pow_unbounded_of_one_lt _ hy,
by classical; exact let n := nat.find h in
  have hn  : x < y ^ n, from nat.find_spec h,
  have hnp : 0 < n,     from pos_iff_ne_zero.2 (λ hn0,
    by rw [hn0, pow_zero] at hn; exact (not_le_of_gt hn hx)),
  have hnsp : nat.pred n + 1 = n,     from nat.succ_pred_eq_of_pos hnp,
  have hltn : nat.pred n < n,         from nat.pred_lt (ne_of_gt hnp),
  ⟨nat.pred n, le_of_not_lt (nat.find_min h hltn), by rwa hnsp⟩

theorem exists_int_gt (x : α) : ∃ n : ℤ, x < n :=
let ⟨n, h⟩ := exists_nat_gt x in ⟨n, by rwa ← coe_coe⟩

theorem exists_int_lt (x : α) : ∃ n : ℤ, (n : α) < x :=
let ⟨n, h⟩ := exists_int_gt (-x) in ⟨-n, by rw int.cast_neg; exact neg_lt.1 h⟩

theorem exists_floor (x : α) :
  ∃ (fl : ℤ), ∀ (z : ℤ), z ≤ fl ↔ (z : α) ≤ x :=
begin
  haveI := classical.prop_decidable,
  have : ∃ (ub : ℤ), (ub:α) ≤ x ∧ ∀ (z : ℤ), (z:α) ≤ x → z ≤ ub :=
  int.exists_greatest_of_bdd
    (let ⟨n, hn⟩ := exists_int_gt x in ⟨n, λ z h',
      int.cast_le.1 $ le_trans h' $ le_of_lt hn⟩)
    (let ⟨n, hn⟩ := exists_int_lt x in ⟨n, le_of_lt hn⟩),
  refine this.imp (λ fl h z, _),
  cases h with h₁ h₂,
  exact ⟨λ h, le_trans (int.cast_le.2 h) h₁, h₂ z⟩,
end

end linear_ordered_ring

section linear_ordered_field

variables [linear_ordered_field α]

/-- Every positive `x` is between two successive integer powers of
another `y` greater than one. This is the same as `exists_int_pow_near'`,
but with ≤ and < the other way around. -/
lemma exists_int_pow_near [archimedean α]
  {x : α} {y : α} (hx : 0 < x) (hy : 1 < y) :
  ∃ n : ℤ, y ^ n ≤ x ∧ x < y ^ (n + 1) :=
by classical; exact
let ⟨N, hN⟩ := pow_unbounded_of_one_lt x⁻¹ hy in
  have he: ∃ m : ℤ, y ^ m ≤ x, from
    ⟨-N, le_of_lt (by { rw [fpow_neg y (↑N), gpow_coe_nat],
    exact (inv_lt hx (lt_trans (inv_pos.2 hx) hN)).1 hN })⟩,
let ⟨M, hM⟩ := pow_unbounded_of_one_lt x hy in
  have hb: ∃ b : ℤ, ∀ m, y ^ m ≤ x → m ≤ b, from
    ⟨M, λ m hm, le_of_not_lt (λ hlt, not_lt_of_ge
  (fpow_le_of_le (le_of_lt hy) (le_of_lt hlt))
    (lt_of_le_of_lt hm (by rwa ← gpow_coe_nat at hM)))⟩,
let ⟨n, hn₁, hn₂⟩ := int.exists_greatest_of_bdd hb he in
  ⟨n, hn₁, lt_of_not_ge (λ hge, not_le_of_gt (int.lt_succ _) (hn₂ _ hge))⟩

/-- Every positive `x` is between two successive integer powers of
another `y` greater than one. This is the same as `exists_int_pow_near`,
but with ≤ and < the other way around. -/
lemma exists_int_pow_near' [archimedean α]
  {x : α} {y : α} (hx : 0 < x) (hy : 1 < y) :
  ∃ n : ℤ, y ^ n < x ∧ x ≤ y ^ (n + 1) :=
let ⟨m, hle, hlt⟩ := exists_int_pow_near (inv_pos.2 hx) hy in
have hyp : 0 < y, from lt_trans zero_lt_one hy,
⟨-(m+1),
by rwa [fpow_neg, inv_lt (fpow_pos_of_pos hyp _) hx],
by rwa [neg_add, neg_add_cancel_right, fpow_neg,
        le_inv hx (fpow_pos_of_pos hyp _)]⟩

/-- For any `y < 1` and any positive `x`, there exists `n : ℕ` with `y ^ n < x`. -/
lemma exists_pow_lt_of_lt_one [archimedean α] {x y : α} (hx : 0 < x) (hy : y < 1) :
  ∃ n : ℕ, y ^ n < x :=
begin
  by_cases y_pos : y ≤ 0,
  { use 1, simp only [pow_one], linarith, },
  rw [not_le] at y_pos,
  rcases pow_unbounded_of_one_lt (x⁻¹) (one_lt_inv y_pos hy) with ⟨q, hq⟩,
  exact ⟨q, by rwa [inv_pow', inv_lt_inv hx (pow_pos y_pos _)] at hq⟩
end

/-- Given `x` and `y` between `0` and `1`, `x` is between two successive powers of `y`.
This is the same as `exists_nat_pow_near`, but for elements between `0` and `1` -/
lemma exists_nat_pow_near_of_lt_one [archimedean α]
  {x : α} {y : α} (xpos : 0 < x) (hx : x ≤ 1) (ypos : 0 < y) (hy : y < 1) :
  ∃ n : ℕ, y ^ (n + 1) < x ∧ x ≤ y ^ n :=
begin
  rcases exists_nat_pow_near (one_le_inv_iff.2 ⟨xpos, hx⟩) (one_lt_inv_iff.2 ⟨ypos, hy⟩)
    with ⟨n, hn, h'n⟩,
  refine ⟨n, _, _⟩,
  { rwa [inv_pow', inv_lt_inv xpos (pow_pos ypos _)] at h'n },
  { rwa [inv_pow', inv_le_inv (pow_pos ypos _) xpos] at hn }
end

variables [floor_ring α]

lemma sub_floor_div_mul_nonneg (x : α) {y : α} (hy : 0 < y) :
  0 ≤ x - ⌊x / y⌋ * y :=
begin
  conv in x {rw ← div_mul_cancel x (ne_of_lt hy).symm},
  rw ← sub_mul,
  exact mul_nonneg (sub_nonneg.2 (floor_le _)) (le_of_lt hy)
end

lemma sub_floor_div_mul_lt (x : α) {y : α} (hy : 0 < y) :
  x - ⌊x / y⌋ * y < y :=
sub_lt_iff_lt_add.2 begin
  conv in y {rw ← one_mul y},
  conv in x {rw ← div_mul_cancel x (ne_of_lt hy).symm},
  rw ← add_mul,
  exact (mul_lt_mul_right hy).2 (by rw add_comm; exact lt_floor_add_one _),
end

end linear_ordered_field

instance : archimedean ℕ :=
⟨λ n m m0, ⟨n, by simpa only [mul_one, nat.nsmul_eq_mul] using nat.mul_le_mul_left n m0⟩⟩

instance : archimedean ℤ :=
⟨λ n m m0, ⟨n.to_nat, le_trans (int.le_to_nat _) $
by simpa only [nsmul_eq_mul, int.nat_cast_eq_coe_nat, zero_add, mul_one]
  using mul_le_mul_of_nonneg_left (int.add_one_le_iff.2 m0) (int.coe_zero_le n.to_nat)⟩⟩

/-- A linear ordered archimedean ring is a floor ring. This is not an `instance` because in some
cases we have a computable `floor` function. -/
noncomputable def archimedean.floor_ring (α)
  [linear_ordered_ring α] [archimedean α] : floor_ring α :=
{ floor := λ x, classical.some (exists_floor x),
  le_floor := λ z x, classical.some_spec (exists_floor x) z }

section linear_ordered_field
variables [linear_ordered_field α]

theorem archimedean_iff_nat_lt :
  archimedean α ↔ ∀ x : α, ∃ n : ℕ, x < n :=
⟨@exists_nat_gt α _ _, λ H, ⟨λ x y y0,
  (H (x / y)).imp $ λ n h, le_of_lt $
  by rwa [div_lt_iff y0, ← nsmul_eq_mul] at h⟩⟩

theorem archimedean_iff_nat_le :
  archimedean α ↔ ∀ x : α, ∃ n : ℕ, x ≤ n :=
archimedean_iff_nat_lt.trans
⟨λ H x, (H x).imp $ λ _, le_of_lt,
 λ H x, let ⟨n, h⟩ := H x in ⟨n+1,
   lt_of_le_of_lt h (nat.cast_lt.2 (lt_add_one _))⟩⟩

theorem exists_rat_gt [archimedean α] (x : α) : ∃ q : ℚ, x < q :=
let ⟨n, h⟩ := exists_nat_gt x in ⟨n, by rwa rat.cast_coe_nat⟩

theorem archimedean_iff_rat_lt :
  archimedean α ↔ ∀ x : α, ∃ q : ℚ, x < q :=
⟨@exists_rat_gt α _,
  λ H, archimedean_iff_nat_lt.2 $ λ x,
  let ⟨q, h⟩ := H x in
  ⟨nat_ceil q, lt_of_lt_of_le h $
    by simpa only [rat.cast_coe_nat] using (@rat.cast_le α _ _ _).2 (le_nat_ceil _)⟩⟩

theorem archimedean_iff_rat_le :
  archimedean α ↔ ∀ x : α, ∃ q : ℚ, x ≤ q :=
archimedean_iff_rat_lt.trans
⟨λ H x, (H x).imp $ λ _, le_of_lt,
 λ H x, let ⟨n, h⟩ := H x in ⟨n+1,
   lt_of_le_of_lt h (rat.cast_lt.2 (lt_add_one _))⟩⟩

variable [archimedean α]

theorem exists_rat_lt (x : α) : ∃ q : ℚ, (q : α) < x :=
let ⟨n, h⟩ := exists_int_lt x in ⟨n, by rwa rat.cast_coe_int⟩

theorem exists_rat_btwn {x y : α} (h : x < y) : ∃ q : ℚ, x < q ∧ (q:α) < y :=
begin
  cases exists_nat_gt (y - x)⁻¹ with n nh,
  cases exists_floor (x * n) with z zh,
  refine ⟨(z + 1 : ℤ) / n, _⟩,
  have n0' := (inv_pos.2 (sub_pos.2 h)).trans nh,
  have n0 := nat.cast_pos.1 n0',
  rw [rat.cast_div_of_ne_zero, rat.cast_coe_nat, rat.cast_coe_int, div_lt_iff n0'],
  refine ⟨(lt_div_iff n0').2 $
    (lt_iff_lt_of_le_iff_le (zh _)).1 (lt_add_one _), _⟩,
  rw [int.cast_add, int.cast_one],
  refine lt_of_le_of_lt (add_le_add_right ((zh _).1 (le_refl _)) _) _,
  rwa [← lt_sub_iff_add_lt', ← sub_mul,
       ← div_lt_iff' (sub_pos.2 h), one_div],
  { rw [rat.coe_int_denom, nat.cast_one], exact one_ne_zero },
  { intro H, rw [rat.coe_nat_num, ← coe_coe, nat.cast_eq_zero] at H, subst H, cases n0 },
  { rw [rat.coe_nat_denom, nat.cast_one], exact one_ne_zero }
end

theorem exists_nat_one_div_lt {ε : α} (hε : 0 < ε) : ∃ n : ℕ, 1 / (n + 1: α) < ε :=
begin
  cases exists_nat_gt (1/ε) with n hn,
  use n,
  rw [div_lt_iff, ← div_lt_iff' hε],
  { apply hn.trans,
    simp [zero_lt_one] },
  { exact n.cast_add_one_pos }
end

theorem exists_pos_rat_lt {x : α} (x0 : 0 < x) : ∃ q : ℚ, 0 < q ∧ (q : α) < x :=
by simpa only [rat.cast_pos] using exists_rat_btwn x0

end linear_ordered_field

section
variables [linear_ordered_field α] [floor_ring α]

/-- `round` rounds a number to the nearest integer. `round (1 / 2) = 1` -/
def round (x : α) : ℤ := ⌊x + 1 / 2⌋

@[simp] lemma round_zero : round (0 : α) = 0 := floor_eq_iff.2 (by norm_num)
@[simp] lemma round_one : round (1 : α) = 1 := floor_eq_iff.2 (by norm_num)

lemma abs_sub_round (x : α) : abs (x - round x) ≤ 1 / 2 :=
begin
  rw [round, abs_sub_le_iff],
  have := floor_le (x + 1 / 2),
  have := lt_floor_add_one (x + 1 / 2),
  split; linarith
end

@[simp, norm_cast] theorem rat.cast_floor (x : ℚ) : ⌊(x:α)⌋ = ⌊x⌋ :=
floor_eq_iff.2 (by exact_mod_cast floor_eq_iff.1 (eq.refl ⌊x⌋))

@[simp, norm_cast] theorem rat.cast_ceil (x : ℚ) : ⌈(x:α)⌉ = ⌈x⌉ :=
by rw [ceil, ← rat.cast_neg, rat.cast_floor, ← ceil]

@[simp, norm_cast] theorem rat.cast_round (x : ℚ) : round (x:α) = round x :=
have ((x + 1 / 2 : ℚ) : α) = x + 1 / 2, by simp,
by rw [round, round, ← this, rat.cast_floor]

end

section
variables [linear_ordered_field α] [archimedean α]

theorem exists_rat_near (x : α) {ε : α} (ε0 : 0 < ε) :
  ∃ q : ℚ, abs (x - q) < ε :=
let ⟨q, h₁, h₂⟩ := exists_rat_btwn $
  lt_trans ((sub_lt_self_iff x).2 ε0) ((lt_add_iff_pos_left x).2 ε0) in
⟨q, abs_sub_lt_iff.2 ⟨sub_lt.1 h₁, sub_lt_iff_lt_add.2 h₂⟩⟩

instance : archimedean ℚ :=
archimedean_iff_rat_le.2 $ λ q, ⟨q, by rw rat.cast_id⟩

end


/-
  A ring with the localization property at a prime ideal is a local ring.
-/

import ring_theory.ideals
import ring_theory.localization
import to_mathlib.localization.localization_alt

universes u v

lemma is_local_of_nonunits_ideal {α : Type u} [comm_ring α] (hnze : (0:α) ≠ 1)
  (h : ∀ x y ∈ nonunits α, x + y ∈ nonunits α) : is_local_ring α :=
⟨hnze,
λ x, classical.or_iff_not_imp_left.mpr $ λ hx,
begin
  classical, by_contra H,
  apply h _ _ hx H,
  simp [-sub_eq_add_neg, add_sub_cancel'_right]
end⟩

local attribute [instance] classical.prop_decidable

open localization_alt

variables {α : Type u} {β : Type v} [comm_ring α] [comm_ring β]
variables {f : α → β} [is_ring_hom f]
variables {P : ideal α} (HP : ideal.is_prime P)
variables (Hloc : is_localization_data (-P : set α) f)

include Hloc

def local_ring.of_is_localization_data_at_prime : is_local_ring β :=
begin
  apply is_local_of_nonunits_ideal,
  { -- 0 ≠ 1.
    intros HC,
    rw ←is_ring_hom.map_one f at HC,
    have Hone : (1 : α) ∈ ker f := HC.symm,
    replace Hone := Hloc.ker_le Hone,
    rcases Hone with ⟨⟨⟨u, ⟨v, HvnP⟩⟩, Huv⟩, Heq⟩,
    dsimp at Huv,
    dsimp at Heq,
    rw Heq at Huv,
    have Hzero : (0 : α) ∈ P := ideal.zero_mem P,
    rw ←Huv at Hzero,
    cases (HP.2 Hzero) with Hone Hv,
    { apply HP.1,
      rw ideal.eq_top_iff_one,
      exact Hone, },
    { change v ∉ P at HvnP,
      exact (HvnP Hv), }, },
  { -- x and y nonunits then x + y is not a unit.
    intros x y Hx Hy HC,
    change ¬is_unit x at Hx,
    change ¬is_unit y at Hy,
    rcases is_unit_iff_exists_inv.1 HC with ⟨inv, Hinv⟩,
    rcases Hloc.has_denom x with ⟨⟨⟨q₁, Hq₁⟩, p₁⟩, Hp₁q₁⟩,
    rcases Hloc.has_denom y with ⟨⟨⟨q₂, Hq₂⟩, p₂⟩, Hp₂q₂⟩,
    rcases Hloc.has_denom inv with ⟨⟨⟨q₃, Hq₃⟩, p₃⟩, Hp₃q₃⟩,
    change q₁ ∉ P at Hq₁,
    change q₂ ∉ P at Hq₂,
    change q₃ ∉ P at Hq₃,
    change f q₁ * x = f p₁ at Hp₁q₁,
    change f q₂ * y = f p₂ at Hp₂q₂,
    change f q₃ * inv = f p₃ at Hp₃q₃,
    have Hp₁P : p₁ ∈ P,
      by_contra Hp₁,
      apply Hx,
      rcases (Hloc.inverts ⟨p₁, Hp₁⟩) with ⟨w₁, Hw₁⟩,
      change f p₁ * w₁ = 1 at Hw₁,
      apply is_unit_of_mul_one x (f q₁ * w₁),
      rw [←mul_assoc, mul_comm x, Hp₁q₁],
      exact Hw₁,
    have Hp₂P : p₂ ∈ P,
      by_contra Hp₂,
      apply Hy,
      rcases (Hloc.inverts ⟨p₂, Hp₂⟩) with ⟨w₂, Hw₂⟩,
      change f p₂ * w₂ = 1 at Hw₂,
      apply is_unit_of_mul_one y (f q₂ * w₂),
      rw [←mul_assoc, mul_comm y, Hp₂q₂],
      exact Hw₂,
    have Hp₃q₂p₁P : p₃ * q₂ * p₁ ∈ P := ideal.mul_mem_left P Hp₁P,
    have Hp₃q₁p₂P : p₃ * q₁ * p₂ ∈ P := ideal.mul_mem_left P Hp₂P,
    have Hmem := (ideal.neg_mem_iff P).2 (ideal.add_mem P Hp₃q₂p₁P Hp₃q₁p₂P),
    have Hq₁q₂q₃nP : q₁ * q₂ * q₃ ∉ P,
      intros HC,
      cases (HP.2 HC) with HC₁₂ HC₃,
      { cases (HP.2 HC₁₂) with HC₁ HC₂,
        { exact (Hq₁ HC₁), },
        { exact (Hq₂ HC₂), } },
      { exact (Hq₃ HC₃), },
    have Hzero : f (q₁ * q₂ * q₃ + -(p₃ * q₂ * p₁ + p₃ * q₁ * p₂)) = 0,
      rw [←sub_eq_add_neg, is_ring_hom.map_sub f, sub_eq_zero, is_ring_hom.map_add f],
      iterate 6 { rw is_ring_hom.map_mul f, },
      iterate 2 { rw mul_assoc (f p₃), },
      rw [←mul_add (f p₃), ←Hp₃q₃, mul_comm (f q₃ * inv), mul_comm (f q₃), ←mul_assoc _ inv],
      rw [←Hp₁q₁, ←mul_assoc (f q₂), mul_comm (f q₂)],
      rw [←Hp₂q₂, ←mul_assoc (f q₁)],
      rw [←mul_add (f q₁ * f q₂), mul_assoc _ (x + y) inv, Hinv, mul_one],
    rcases (Hloc.ker_le Hzero) with ⟨⟨⟨u, ⟨v, HvnP⟩⟩, Huv⟩, Helem⟩,
    change v ∉ P at HvnP,
    dsimp only [subtype.coe_mk] at Huv,
    dsimp only [subtype.coe_mk] at Helem,
    rw Helem at Huv; clear Helem,
    cases (HP.mem_or_mem_of_mul_eq_zero Huv) with Helem HvP,
    { rw ideal.add_mem_iff_left P Hmem at Helem,
      exact (Hq₁q₂q₃nP Helem), },
    { exact (HvnP HvP), } }
end