/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.fintype

universes u v
open equiv function fintype finset
variables {α : Type u} {β : Type v}

namespace equiv.perm

def subtype_perm (f : perm α) {p : α → Prop} (h : ∀ x, p x ↔ p (f x)) : perm {x // p x} :=
⟨λ x, ⟨f x, (h _).1 x.2⟩, λ x, ⟨f⁻¹ x, (h (f⁻¹ x)).2 $ by simpa using x.2⟩,
  λ _, by simp, λ _, by simp⟩

def of_subtype {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) : perm α :=
⟨λ x, if h : p x then f ⟨x, h⟩ else x, λ x, if h : p x then f⁻¹ ⟨x, h⟩ else x,
  λ x, have h : ∀ h : p x, p (f ⟨x, h⟩), from λ h, (f ⟨x, h⟩).2,
    by simp; split_ifs at *; simp * at *,
  λ x, have h : ∀ h : p x, p (f⁻¹ ⟨x, h⟩), from λ h, (f⁻¹ ⟨x, h⟩).2,
    by simp; split_ifs at *; simp * at *⟩

instance of_subtype.is_group_hom {p : α → Prop} [decidable_pred p] : is_group_hom (@of_subtype α p _) :=
⟨λ f g, equiv.ext _ _ $ λ x, begin
  rw [of_subtype, of_subtype, of_subtype],
  by_cases h : p x,
  { have h₁ : p (f (g ⟨x, h⟩)), from (f (g ⟨x, h⟩)).2,
    have h₂ : p (g ⟨x, h⟩), from (g ⟨x, h⟩).2,
    simp [h, h₁, h₂] },
  { simp [h] }
end⟩

lemma eq_inv_iff_eq {f : perm α} {x y : α} : x = f⁻¹ y ↔ f x = y :=
by conv {to_lhs, rw [← injective.eq_iff f.bijective.1, apply_inv_self]}

lemma inv_eq_iff_eq {f : perm α} {x y : α} : f⁻¹ x = y ↔ x = f y :=
by rw [eq_comm, eq_inv_iff_eq, eq_comm]

def is_cycle (f : perm α) := ∃ x, f x ≠ x ∧ ∀ y, f y ≠ y → ∃ i : ℤ, (f ^ i) x = y

lemma exists_int_pow_eq_of_is_cycle {f : perm α} (hf : is_cycle f) {x y : α}
  (hx : f x ≠ x) (hy : f y ≠ y) : ∃ i : ℤ, (f ^ i) x = y :=
let ⟨g, hg⟩ := hf in
let ⟨a, ha⟩ := hg.2 x hx in
let ⟨b, hb⟩ := hg.2 y hy in
⟨b - a, by rw [← ha, ← mul_apply, ← gpow_add, sub_add_cancel, hb]⟩

lemma of_subtype_subtype_perm {f : perm α} {p : α → Prop} [decidable_pred p] (h₁ : ∀ x, p x ↔ p (f x))
  (h₂ : ∀ x, f x ≠ x → p x) : of_subtype (subtype_perm f h₁) = f :=
equiv.ext _ _ $ λ x, begin
  rw [of_subtype, subtype_perm],
  by_cases hx : p x,
  { simp [hx] },
  { haveI := classical.prop_decidable,
    simp [hx, not_not.1 (mt (h₂ x) hx)] }
end

lemma of_subtype_apply_of_not_mem {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) {x : α} (hx : ¬ p x) :
  of_subtype f x = x := dif_neg hx

lemma mem_iff_of_subtype_apply_mem {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) (x : α) :
  p x ↔ p ((of_subtype f : α → α) x) :=
if h : p x then by dsimp [of_subtype]; simpa [h] using (f ⟨x, h⟩).2
else by simp [h, of_subtype_apply_of_not_mem f h]

@[simp] lemma subtype_perm_of_subtype {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) :
  subtype_perm (of_subtype f) (mem_iff_of_subtype_apply_mem f) = f :=
equiv.ext _ _ $ λ ⟨x, hx⟩, by dsimp [subtype_perm, of_subtype]; simp [show p x, from hx]

lemma pow_apply_eq_of_apply_apply_eq_self_nat {f : perm α} {x : α} (hffx : f (f x) = x) :
  ∀ n : ℕ, (f ^ n) x = x ∨ (f ^ n) x = f x
| 0     := or.inl rfl
| (n+1) := (pow_apply_eq_of_apply_apply_eq_self_nat n).elim
  (λ h, or.inr (by rw [pow_succ, mul_apply, h]))
  (λ h, or.inl (by rw [pow_succ, mul_apply, h, hffx]))

lemma pow_apply_eq_of_apply_apply_eq_self_int {f : perm α} {x : α} (hffx : f (f x) = x) :
  ∀ i : ℤ, (f ^ i) x = x ∨ (f ^ i) x = f x
| (n : ℕ) := pow_apply_eq_of_apply_apply_eq_self_nat hffx n
| -[1+ n] :=
  by rw [gpow_neg_succ, inv_eq_iff_eq, ← injective.eq_iff f.bijective.1, ← mul_apply, ← pow_succ,
    eq_comm, inv_eq_iff_eq, ← mul_apply, ← pow_succ', @eq_comm _ x, or.comm];
  exact pow_apply_eq_of_apply_apply_eq_self_nat hffx _

variable [decidable_eq α]

def support [fintype α] (f : perm α) := univ.filter (λ x, f x ≠ x)

@[simp] lemma mem_support [fintype α] {f : perm α} {x : α} : x ∈ f.support ↔ f x ≠ x :=
by simp [support]

def is_swap (f : perm α) := ∃ x y, x ≠ y ∧ f = swap x y

lemma swap_mul_eq_mul_swap (f : perm α) (x y : α) : swap x y * f = f * swap (f⁻¹ x) (f⁻¹ y) :=
equiv.ext _ _ $ λ z, begin
  simp [mul_apply, swap_apply_def],
  split_ifs;
  simp [*, eq_inv_iff_eq] at * <|> cc
end

lemma mul_swap_eq_swap_mul (f : perm α) (x y : α) : f * swap x y = swap (f x) (f y) * f :=
by rw [swap_mul_eq_mul_swap, inv_apply_self, inv_apply_self]

lemma is_swap_of_subtype {p : α → Prop} [decidable_pred p]
  {f : perm (subtype p)} (h : is_swap f) : is_swap (of_subtype f) :=
let ⟨⟨x, hx⟩, ⟨y, hy⟩, hxy⟩ := h in
⟨x, y, by simp at hxy; tauto,
  equiv.ext _ _ $ λ z, begin
    rw [hxy.2, of_subtype],
    simp [swap_apply_def],
    split_ifs;
    cc <|> simp * at *
  end⟩

lemma support_swap_mul {f : perm α} {x : α}
  {y : α} (hy : (swap x (f x) * f) y ≠ y) : f y ≠ y ∧ y ≠ x :=
begin
  simp only [swap_apply_def, mul_apply, injective.eq_iff f.bijective.1] at *,
  by_cases h : f y = x,
  { split; intro; simp * at * },
  { split_ifs at hy; cc }
end

def swap_factors_aux : Π (l : list α) (f : perm α), (∀ {x}, f x ≠ x → x ∈ l) →
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g}
| []       := λ f h, ⟨[], equiv.ext _ _ $ λ x, by rw [list.prod_nil];
    exact eq.symm (not_not.1 (mt h (list.not_mem_nil _))), by simp⟩
| (x :: l) := λ f h,
if hfx : x = f x
then swap_factors_aux l f
  (λ y hy, list.mem_of_ne_of_mem (λ h : y = x, by simpa [h, hfx.symm] using hy) (h hy))
else let m := swap_factors_aux l (swap x (f x) * f)
      (λ y hy, have f y ≠ y ∧ y ≠ x, from support_swap_mul hy,
        list.mem_of_ne_of_mem this.2 (h this.1)) in
  ⟨swap x (f x) :: m.1,
  by rw [list.prod_cons, m.2.1, ← mul_assoc,
    mul_def (swap x (f x)), swap_swap, ← one_def, one_mul],
  λ g hg, ((list.mem_cons_iff _ _ _).1 hg).elim (λ h, ⟨x, f x, hfx, h⟩) (m.2.2 _)⟩

/-- `swap_factors` represents a permutation as a product of a list of transpositions.
The representation is non unique and depends on the linear order structure.
For types without linear order `trunc_swap_factors` can be used -/
def swap_factors [fintype α] [decidable_linear_order α] (f : perm α) :
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
swap_factors_aux ((@univ α _).sort (≤)) f (λ _ _, (mem_sort _).2 (mem_univ _))

def trunc_swap_factors [fintype α] (f : perm α) :
  trunc {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
quotient.rec_on_subsingleton (@univ α _).1
(λ l h, trunc.mk (swap_factors_aux l f h))
(show ∀ x, f x ≠ x → x ∈ (@univ α _).1, from λ _ _, mem_univ _)

lemma swap_mul_swap_mul_swap {x y z : α} (hwz: x ≠ y) (hxz : x ≠ z) :
  swap y z * swap x y * swap y z = swap z x :=
equiv.ext _ _ $ λ n, by simp only [swap_apply_def, mul_apply]; split_ifs; cc

lemma is_conj_swap {w x y z : α} (hwx : w ≠ x) (hyz : y ≠ z) : is_conj (swap w x) (swap y z) :=
have h : ∀ {y z : α}, y ≠ z → w ≠ z →
    (swap w y * swap x z) * swap w x * (swap w y * swap x z)⁻¹ = swap y z :=
  λ y z hyz hwz, by rw [mul_inv_rev, swap_inv, swap_inv, mul_assoc (swap w y),
    mul_assoc (swap w y),  ← mul_assoc _ (swap x z), swap_mul_swap_mul_swap hwx hwz,
    ← mul_assoc, swap_mul_swap_mul_swap hwz.symm hyz.symm],
if hwz : w = z
then have hwy : w ≠ y, by cc,
  ⟨swap w z * swap x y, by rw [swap_comm y z, h hyz.symm hwy]⟩
else ⟨swap w y * swap x z, h hyz hwz⟩

/-- set of all pairs (⟨a, b⟩ : Σ a : fin n, fin n) such that b < a -/
def fin_pairs_lt (n : ℕ) : finset (Σ a : fin n, fin n) :=
(univ : finset (fin n)).sigma (λ a, (range a.1).attach_fin
  (λ m hm, lt_trans (mem_range.1 hm) a.2))

lemma mem_fin_pairs_lt {n : ℕ} {a : Σ a : fin n, fin n} :
  a ∈ fin_pairs_lt n ↔ a.2 < a.1 :=
by simp [fin_pairs_lt, fin.lt_def]

def sign_aux {n : ℕ} (a : perm (fin n)) : units ℤ :=
(fin_pairs_lt n).prod (λ x, if a x.1 ≤ a x.2 then -1 else 1)

@[simp] lemma sign_aux_one (n : ℕ) : sign_aux (1 : perm (fin n)) = 1 :=
begin
  unfold sign_aux,
  conv { to_rhs, rw ← @finset.prod_const_one _ (units ℤ)
    (fin_pairs_lt n) },
  exact finset.prod_congr rfl (λ a ha, if_neg
    (not_le_of_gt (mem_fin_pairs_lt.1 ha)))
end

def sign_bij_aux {n : ℕ} (f : perm (fin n)) (a : Σ a : fin n, fin n) :
  Σ a : fin n, fin n :=
if hxa : f a.2 < f a.1 then ⟨f a.1, f a.2⟩ else ⟨f a.2, f a.1⟩

lemma sign_bij_aux_inj {n : ℕ} {f : perm (fin n)} : ∀ a b : Σ a : fin n, fin n,
   a ∈ fin_pairs_lt n → b ∈ fin_pairs_lt n →
   sign_bij_aux f a = sign_bij_aux f b → a = b :=
λ ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ha hb h, begin
  unfold sign_bij_aux at h,
  rw mem_fin_pairs_lt at *,
  have : ¬b₁ < b₂ := not_lt_of_ge (le_of_lt hb),
  split_ifs at h;
  simp [*, injective.eq_iff f.bijective.1, sigma.mk.inj_eq] at *
end

lemma sign_bij_aux_surj {n : ℕ} {f : perm (fin n)} : ∀ a ∈ fin_pairs_lt n,
  ∃ b ∈ fin_pairs_lt n, a = sign_bij_aux f b :=
λ ⟨a₁, a₂⟩ ha,
if hxa : f⁻¹ a₂ < f⁻¹ a₁
then ⟨⟨f⁻¹ a₁, f⁻¹ a₂⟩, mem_fin_pairs_lt.2 hxa,
  by dsimp [sign_bij_aux];
    rw [apply_inv_self, apply_inv_self, dif_pos (mem_fin_pairs_lt.1 ha)]⟩
else ⟨⟨f⁻¹ a₂, f⁻¹ a₁⟩, mem_fin_pairs_lt.2 $ lt_of_le_of_ne
  (le_of_not_gt hxa) $ λ h,
    by simpa [mem_fin_pairs_lt, (f⁻¹).bijective.1 h, lt_irrefl] using ha,
  by dsimp [sign_bij_aux];
    rw [apply_inv_self, apply_inv_self,
      dif_neg (not_lt_of_ge (le_of_lt (mem_fin_pairs_lt.1 ha)))]⟩

lemma sign_bij_aux_mem {n : ℕ} {f : perm (fin n)}: ∀ a : Σ a : fin n, fin n,
  a ∈ fin_pairs_lt n → sign_bij_aux f a ∈ fin_pairs_lt n :=
λ ⟨a₁, a₂⟩ ha, begin
  unfold sign_bij_aux,
  split_ifs with h,
  { exact mem_fin_pairs_lt.2 h },
  { exact mem_fin_pairs_lt.2
    (lt_of_le_of_ne (le_of_not_gt h)
      (λ h, ne_of_lt (mem_fin_pairs_lt.1 ha) (f.bijective.1 h.symm))) }
end

@[simp] lemma sign_aux_inv {n : ℕ} (f : perm (fin n)) : sign_aux f⁻¹ = sign_aux f :=
prod_bij (λ a ha, sign_bij_aux f⁻¹ a)
sign_bij_aux_mem
(λ ⟨a, b⟩ hab, if h : f⁻¹ b < f⁻¹ a
  then by rw [sign_bij_aux, dif_pos h, if_neg (not_le_of_gt h), apply_inv_self,
    apply_inv_self, if_neg (not_le_of_gt $ mem_fin_pairs_lt.1 hab)]
  else by rw [sign_bij_aux, if_pos (le_of_not_gt h), dif_neg h, apply_inv_self,
    apply_inv_self, if_pos (le_of_lt $ mem_fin_pairs_lt.1 hab)])
sign_bij_aux_inj
sign_bij_aux_surj

lemma sign_aux_mul {n : ℕ} (f g : perm (fin n)) :
  sign_aux (f * g) = sign_aux f * sign_aux g :=
begin
  rw ← sign_aux_inv g,
  unfold sign_aux,
  rw  ← prod_mul_distrib,
  refine prod_bij (λ a ha, sign_bij_aux g a) sign_bij_aux_mem _
    sign_bij_aux_inj sign_bij_aux_surj,
  rintros ⟨a, b⟩ hab,
  rw [sign_bij_aux, mul_apply, mul_apply],
  rw mem_fin_pairs_lt at hab,
  by_cases h : g b < g a,
  { rw dif_pos h,
    simp [not_le_of_gt hab]; congr },
  { rw [dif_neg h, inv_apply_self, inv_apply_self, if_pos (le_of_lt hab)],
    by_cases h₁ : f (g b) ≤ f (g a),
    { have : f (g b) ≠ f (g a),
      { rw [ne.def, injective.eq_iff f.bijective.1,
          injective.eq_iff g.bijective.1];
        exact ne_of_lt hab },
      rw [if_pos h₁, if_neg (not_le_of_gt  (lt_of_le_of_ne h₁ this))],
      refl },
    { rw [if_neg h₁, if_pos (le_of_lt (lt_of_not_ge h₁))],
      refl } }
end

instance sign_aux.is_group_hom {n : ℕ} : is_group_hom (@sign_aux n) := ⟨sign_aux_mul⟩

private lemma sign_aux_swap_zero_one {n : ℕ} (hn : 2 ≤ n) :
  sign_aux (swap (⟨0, lt_of_lt_of_le dec_trivial hn⟩ : fin n)
  ⟨1, lt_of_lt_of_le dec_trivial hn⟩) = -1 :=
let zero : fin n := ⟨0, lt_of_lt_of_le dec_trivial hn⟩ in
let one : fin n := ⟨1, lt_of_lt_of_le dec_trivial hn⟩ in
have hzo : zero < one := dec_trivial,
show _ = (finset.singleton (⟨one, zero⟩ : Σ a : fin n, fin n)).prod
  (λ x : Σ a : fin n, fin n, if (equiv.swap zero one) x.1
  ≤ swap zero one x.2 then (-1 : units ℤ) else 1),
begin
  refine eq.symm (prod_subset (λ ⟨x₁, x₂⟩, by simp [mem_fin_pairs_lt, hzo] {contextual := tt})
    (λ a ha₁ ha₂, _)),
  rcases a with ⟨⟨a₁, ha₁⟩, ⟨a₂, ha₂⟩⟩,
  replace ha₁ : a₂ < a₁ := mem_fin_pairs_lt.1 ha₁,
  simp only [swap_apply_def],
  have : ¬ 1 ≤ a₂ → a₂ = 0, from λ h, nat.le_zero_iff.1 (nat.le_of_lt_succ (lt_of_not_ge h)),
  have : a₁ ≤ 1 → a₁ = 0 ∨ a₁ = 1, from nat.cases_on a₁ (λ _, or.inl rfl)
    (λ a₁, nat.cases_on a₁ (λ _, or.inr rfl) (λ _ h, absurd h dec_trivial)),
  split_ifs;
  simp [*, lt_irrefl, -not_lt, not_le.symm, -not_le, le_refl, fin.lt_def, fin.le_def, nat.zero_le,
    zero, one, iff.intro fin.veq_of_eq fin.eq_of_veq, nat.le_zero_iff] at *,
end

lemma sign_aux_swap : ∀ {n : ℕ} {x y : fin n} (hxy : x ≠ y),
  sign_aux (swap x y) = -1
| 0 := dec_trivial
| 1 := dec_trivial
| (n+2) := λ x y hxy,
have h2n : 2 ≤ n + 2 := dec_trivial,
by rw [← is_conj_iff_eq, ← sign_aux_swap_zero_one h2n];
  exact is_group_hom.is_conj _ (is_conj_swap hxy dec_trivial)

def sign_aux2 : list α → perm α → units ℤ
| []     f := 1
| (x::l) f := if x = f x then sign_aux2 l f else -sign_aux2 l (swap x (f x) * f)

lemma sign_aux_eq_sign_aux2 {n : ℕ} : ∀ (l : list α) (f : perm α) (e : α ≃ fin n)
  (h : ∀ x, f x ≠ x → x ∈ l), sign_aux ((e.symm.trans f).trans e) = sign_aux2 l f
| []     f e h := have f = 1, from equiv.ext _ _ $
  λ y, not_not.1 (mt (h y) (list.not_mem_nil _)),
by rw [this, one_def, equiv.trans_refl, equiv.symm_trans, ← one_def,
  sign_aux_one, sign_aux2]
| (x::l) f e h := begin
  rw sign_aux2,
  by_cases hfx : x = f x,
  { rw if_pos hfx,
    exact sign_aux_eq_sign_aux2 l f _ (λ y (hy : f y ≠ y), list.mem_of_ne_of_mem
      (λ h : y = x, by simpa [h, hfx.symm] using hy) (h y hy) ) },
  { have hy : ∀ y : α, (swap x (f x) * f) y ≠ y → y ∈ l,
      from λ y hy, have f y ≠ y ∧ y ≠ x, from support_swap_mul hy,
      list.mem_of_ne_of_mem this.2 (h _ this.1),
    have : (e.symm.trans (swap x (f x) * f)).trans e =
      (swap (e x) (e (f x))) * (e.symm.trans f).trans e,
      from equiv.ext _ _ (λ z, by rw ← equiv.symm_trans_swap_trans; simp [mul_def]),
    have hefx : e x ≠ e (f x), from mt (injective.eq_iff e.bijective.1).1 hfx,
    rw [if_neg hfx, ← sign_aux_eq_sign_aux2 _ _ e hy, this, sign_aux_mul, sign_aux_swap hefx],
    simp }
end

def sign_aux3 [fintype α] (f : perm α) {s : multiset α} : (∀ x, x ∈ s) → units ℤ :=
quotient.hrec_on s (λ l h, sign_aux2 l f)
  (trunc.induction_on (equiv_fin α)
    (λ e l₁ l₂ h, function.hfunext
      (show (∀ x, x ∈ l₁) = ∀ x, x ∈ l₂, by simp [list.mem_of_perm h])
      (λ h₁ h₂ _, by rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₁ _),
        ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₂ _)])))

lemma sign_aux3_mul_and_swap [fintype α] (f g : perm α) (s : multiset α) (hs : ∀ x, x ∈ s) :
  sign_aux3 (f * g) hs = sign_aux3 f hs * sign_aux3 g hs ∧ ∀ x y, x ≠ y →
  sign_aux3 (swap x y) hs = -1 :=
let ⟨l, hl⟩ := quotient.exists_rep s in
let ⟨e, _⟩ := trunc.exists_rep (equiv_fin α) in
begin
  clear _let_match _let_match,
  subst hl,
  show sign_aux2 l (f * g) = sign_aux2 l f * sign_aux2 l g ∧
    ∀ x y, x ≠ y → sign_aux2 l (swap x y) = -1,
  have hfg : (e.symm.trans (f * g)).trans e = (e.symm.trans f).trans e * (e.symm.trans g).trans e,
    from equiv.ext _ _ (λ h, by simp [mul_apply]),
  split,
  { rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _),
      ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), hfg, sign_aux_mul] },
  { assume x y hxy,
    have hexy : e x ≠ e y, from mt (injective.eq_iff e.bijective.1).1 hxy,
    rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), equiv.symm_trans_swap_trans, sign_aux_swap hexy] }
end

/-- `sign` of a permutation returns the signature or parity of a permutation, `1` for even
permutations, `-1` for odd permutations. It is the unique surjective group homomorphism from
`perm α` to the group with two elements.-/
def sign [fintype α] (f : perm α) := sign_aux3 f mem_univ

instance sign.is_group_hom [fintype α] : is_group_hom (@sign α _ _) :=
⟨λ f g, (sign_aux3_mul_and_swap f g _ mem_univ).1⟩

@[simp] lemma sign_mul [fintype α] (f g : perm α) : sign (f * g) = sign f * sign g :=
is_group_hom.mul sign _ _

@[simp] lemma sign_one [fintype α] : (sign (1 : perm α)) = 1 :=
is_group_hom.one sign

@[simp] lemma sign_inv [fintype α] (f : perm α) : sign f⁻¹ = sign f :=
by rw [is_group_hom.inv sign, int.units_inv_eq_self]; apply_instance

lemma sign_swap [fintype α] {x y : α} (h : x ≠ y) : sign (swap x y) = -1 :=
(sign_aux3_mul_and_swap 1 1 _ mem_univ).2 x y h

lemma sign_eq_of_is_swap [fintype α] {f : perm α} (h : is_swap f) : sign f = -1 :=
let ⟨x, y, hxy⟩ := h in hxy.2.symm ▸ sign_swap hxy.1

lemma sign_aux3_symm_trans_trans [fintype α] [decidable_eq β] [fintype β] (f : perm α)
  (e : α ≃ β) {s : multiset α} {t : multiset β} (hs : ∀ x, x ∈ s) (ht : ∀ x, x ∈ t) :
  sign_aux3 ((e.symm.trans f).trans e) ht = sign_aux3 f hs :=
quotient.induction_on₂ t s
  (λ l₁ l₂ h₁ h₂, show sign_aux2 _ _ = sign_aux2 _ _,
    from let n := trunc.out (equiv_fin β) in
    by rw [← sign_aux_eq_sign_aux2 _ _ n (λ _ _, h₁ _),
        ← sign_aux_eq_sign_aux2 _ _ (e.trans n) (λ _ _, h₂ _)];
      exact congr_arg sign_aux (equiv.ext _ _ (λ x, by simp)))
  ht hs

lemma sign_symm_trans_trans [fintype α] [decidable_eq β] [fintype β] (f : perm α)
  (e : α ≃ β) : sign ((e.symm.trans f).trans e) = sign f :=
sign_aux3_symm_trans_trans f e mem_univ mem_univ

lemma sign_prod_list_swap [fintype α] {l : list (perm α)}
  (hl : ∀ g ∈ l, is_swap g) : sign l.prod = -1 ^ l.length :=
have h₁ : l.map sign = list.repeat (-1) l.length :=
  list.eq_repeat.2 ⟨by simp, λ u hu,
  let ⟨g, hg⟩ := list.mem_map.1 hu in
  hg.2 ▸ sign_eq_of_is_swap (hl _ hg.1)⟩,
by rw [← list.prod_repeat, ← h₁, ← is_group_hom.prod (@sign α _ _)]

lemma eq_sign_of_surjective_hom [fintype α] {s : perm α → units ℤ}
  [is_group_hom s] (hs : surjective s) : s = sign :=
have ∀ {f}, is_swap f → s f = -1 :=
  λ f ⟨x, y, hxy, hxy'⟩, hxy'.symm ▸ by_contradiction (λ h,
    have ∀ f, is_swap f → s f = 1 := λ f ⟨a, b, hab, hab'⟩,
      by rw [← is_conj_iff_eq, ← or.resolve_right (int.units_eq_one_or _) h, hab'];
        exact is_group_hom.is_conj _ (is_conj_swap hab hxy),
  let ⟨g, hg⟩ := hs (-1) in
  let ⟨l, hl⟩ := trunc.out (trunc_swap_factors g) in
  have ∀ a ∈ l.map s, a = (1 : units ℤ) := λ a ha,
    let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸ this _ (hl.2 _ hg.1),
  have s l.prod = 1,
    by rw [is_group_hom.prod s, list.eq_repeat'.2 this, list.prod_repeat, one_pow],
  by rw [hl.1, hg] at this;
    exact absurd this dec_trivial),
funext $ λ f,
let ⟨l, hl₁, hl₂⟩ := trunc.out (trunc_swap_factors f) in
have hsl : ∀ a ∈ l.map s, a = (-1 : units ℤ) := λ a ha,
  let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸  this (hl₂ _ hg.1),
by rw [← hl₁, is_group_hom.prod s, list.eq_repeat'.2 hsl, list.length_map,
     list.prod_repeat, sign_prod_list_swap hl₂]

lemma sign_subtype_perm [fintype α] (f : perm α) {p : α → Prop} [decidable_pred p]
  (h₁ : ∀ x, p x ↔ p (f x)) (h₂ : ∀ x, f x ≠ x → p x) : sign (subtype_perm f h₁) = sign f :=
let l := trunc.out (trunc_swap_factors (subtype_perm f h₁)) in
have hl' : ∀ g' ∈ l.1.map of_subtype, is_swap g' :=
  λ g' hg',
  let ⟨g, hg⟩ := list.mem_map.1 hg' in
  hg.2 ▸ is_swap_of_subtype (l.2.2 _ hg.1),
have hl'₂ : (l.1.map of_subtype).prod = f,
  by rw [← is_group_hom.prod of_subtype l.1, l.2.1, of_subtype_subtype_perm _ h₂],
by conv {congr, rw ← l.2.1, skip, rw ← hl'₂};
  rw [sign_prod_list_swap l.2.2, sign_prod_list_swap hl', list.length_map]

@[simp] lemma sign_of_subtype [fintype α] {p : α → Prop} [decidable_pred p]
  (f : perm (subtype p)) : sign (of_subtype f) = sign f :=
have ∀ x, of_subtype f x ≠ x → p x, from λ x, not_imp_comm.1 (of_subtype_apply_of_not_mem f),
by conv {to_rhs, rw [← subtype_perm_of_subtype f, sign_subtype_perm _ _ this]}

lemma sign_eq_sign_of_equiv [fintype α] [decidable_eq β] [fintype β] (f : perm α) (g : perm β)
  (e : α ≃ β) (h : ∀ x, e (f x) = g (e x)) : sign f = sign g :=
have hg : g = (e.symm.trans f).trans e, from equiv.ext _ _ $ by simp [h],
by rw [hg, sign_symm_trans_trans]

lemma sign_bij [fintype α] [decidable_eq β] [fintype β]
  {f : perm α} {g : perm β} (i : Π x : α, f x ≠ x → β)
  (h : ∀ x hx hx', i (f x) hx' = g (i x hx))
  (hi : ∀ x₁ x₂ hx₁ hx₂, i x₁ hx₁ = i x₂ hx₂ → x₁ = x₂)
  (hg : ∀ y, g y ≠ y → ∃ x hx, i x hx = y) :
  sign f = sign g :=
calc sign f = sign (@subtype_perm _ f (λ x, f x ≠ x) (by simp)) :
  eq.symm (sign_subtype_perm _ _ (λ _, id))
... = sign (@subtype_perm _ g (λ x, g x ≠ x) (by simp)) :
  sign_eq_sign_of_equiv _ _
    (equiv.of_bijective
      (show function.bijective (λ x : {x // f x ≠ x},
        (⟨i x.1 x.2, have f (f x) ≠ f x, from mt (λ h, f.bijective.1 h) x.2,
          by rw [← h _ x.2 this]; exact mt (hi _ _ this x.2) x.2⟩ : {y // g y ≠ y})),
        from ⟨λ ⟨x, hx⟩ ⟨y, hy⟩ h, subtype.eq (hi _ _ _ _ (subtype.mk.inj h)),
          λ ⟨y, hy⟩, let ⟨x, hfx, hx⟩ := hg y hy in ⟨⟨x, hfx⟩, subtype.eq hx⟩⟩))
      (λ ⟨x, _⟩, subtype.eq (h x _ _))
... = sign g : sign_subtype_perm _ _ (λ _, id)

lemma is_cycle_swap {x y : α} (hxy : x ≠ y) : is_cycle (swap x y) :=
⟨y, by rwa swap_apply_right,
  λ a (ha : ite (a = x) y (ite (a = y) x a) ≠ a),
    if hya : y = a then ⟨0, hya⟩
    else ⟨1, by rw [gpow_one, swap_apply_def]; split_ifs at *; cc⟩⟩

lemma is_cycle_inv {f : perm α} (hf : is_cycle f) : is_cycle (f⁻¹) :=
let ⟨x, hx⟩ := hf in
⟨x, by simp [eq_inv_iff_eq, inv_eq_iff_eq, *] at *; cc,
  λ y hy, let ⟨i, hi⟩ := hx.2 y (by simp [eq_inv_iff_eq, inv_eq_iff_eq, *] at *; cc) in
    ⟨-i, by rwa [gpow_neg, inv_gpow, inv_inv]⟩⟩

lemma is_cycle_swap_mul_aux₁ : ∀ (n : ℕ) {b x : α} {f : perm α}
  (hf : is_cycle f) (hb : (swap x (f x) * f) b ≠ b) (h : (f ^ n) (f x) = b),
  ∃ i : ℤ, ((swap x (f x) * f) ^ i) (f x) = b
| 0         := λ b x f hf hb h, ⟨0, h⟩
| (n+1 : ℕ) := λ b x f hf hb h,
  if hfbx : f x = b then ⟨0, hfbx⟩
  else
    have f b ≠ b ∧ b ≠ x, from support_swap_mul hb,
    have hb' : (swap x (f x) * f) (f⁻¹ b) ≠ f⁻¹ b,
      by rw [mul_apply, apply_inv_self, swap_apply_of_ne_of_ne this.2 (ne.symm hfbx),
          ne.def, ← injective.eq_iff f.bijective.1, apply_inv_self];
        exact this.1,
    let ⟨i, hi⟩ := is_cycle_swap_mul_aux₁ n hf hb'
      (f.bijective.1 $
        by rw [apply_inv_self];
        rwa [pow_succ, mul_apply] at h) in
    ⟨i + 1, by rw [add_comm, gpow_add, mul_apply, hi, gpow_one, mul_apply, apply_inv_self,
        swap_apply_of_ne_of_ne (support_swap_mul hb).2 (ne.symm hfbx)]⟩

lemma is_cycle_swap_mul_aux₂ : ∀ (n : ℤ) {b x : α} {f : perm α}
  (hf : is_cycle f) (hb : (swap x (f x) * f) b ≠ b) (h : (f ^ n) (f x) = b),
  ∃ i : ℤ, ((swap x (f x) * f) ^ i) (f x) = b
| (n : ℕ) := λ b x f hf, is_cycle_swap_mul_aux₁ n hf
| -[1+ n] := λ b x f hf hb h,
  if hfbx : f⁻¹ x = b then ⟨-1, by rwa [gpow_neg, gpow_one, mul_inv_rev, mul_apply, swap_inv, swap_apply_right]⟩
  else if hfbx' : f x = b then ⟨0, hfbx'⟩
  else
  have f b ≠ b ∧ b ≠ x := support_swap_mul hb,
  have hb : (swap x (f⁻¹ x) * f⁻¹) (f⁻¹ b) ≠ f⁻¹ b,
    by rw [mul_apply, swap_apply_def];
      split_ifs;
      simp [inv_eq_iff_eq, eq_inv_iff_eq] at *; cc,
  let ⟨i, hi⟩ := is_cycle_swap_mul_aux₁ n (is_cycle_inv hf) hb
    (show (f⁻¹ ^ n) (f⁻¹ x) = f⁻¹ b, by
      rw [← gpow_coe_nat, ← h, ← mul_apply, ← mul_apply, ← mul_apply, gpow_neg_succ, ← inv_pow, pow_succ', mul_assoc,
        mul_assoc, inv_mul_self, mul_one, gpow_coe_nat, ← pow_succ', ← pow_succ]) in
  have h : (swap x (f⁻¹ x) * f⁻¹) (f x) = f⁻¹ x, by rw [mul_apply, inv_apply_self, swap_apply_left],
  ⟨-i, by rw [← add_sub_cancel i 1, neg_sub, sub_eq_add_neg, gpow_add, gpow_one, gpow_neg, ← inv_gpow,
      mul_inv_rev, swap_inv, mul_swap_eq_swap_mul, inv_apply_self, swap_comm _ x, gpow_add, gpow_one,
      mul_apply, mul_apply (_ ^ i), h, hi, mul_apply, apply_inv_self, swap_apply_of_ne_of_ne this.2 (ne.symm hfbx')]⟩

lemma eq_swap_of_is_cycle_of_apply_apply_eq_self {f : perm α} (hf : is_cycle f) {x : α}
  (hfx : f x ≠ x) (hffx : f (f x) = x) : f = swap x (f x) :=
equiv.ext _ _ $ λ y,
let ⟨z, hz⟩ := hf in
let ⟨i, hi⟩ := hz.2 x hfx in
if hyx : y = x then by simp [hyx]
else if hfyx : y = f x then by simp [hfyx, hffx]
else begin
  rw [swap_apply_of_ne_of_ne hyx hfyx],
  refine by_contradiction (λ hy, _),
  cases hz.2 y hy with j hj,
  rw [← sub_add_cancel j i, gpow_add, mul_apply, hi] at hj,
  cases pow_apply_eq_of_apply_apply_eq_self_int hffx (j - i) with hji hji,
  { rw [← hj, hji] at hyx, cc },
  { rw [← hj, hji] at hfyx, cc }
end

lemma is_cycle_swap_mul {f : perm α} (hf : is_cycle f) {x : α}
  (hx : f x ≠ x) (hffx : f (f x) ≠ x) : is_cycle (swap x (f x) * f) :=
⟨f x, by simp only [swap_apply_def, mul_apply];
        split_ifs; simp [injective.eq_iff f.bijective.1] at *; cc,
  λ y hy,
  let ⟨i, hi⟩ := exists_int_pow_eq_of_is_cycle hf hx (support_swap_mul hy).1 in
  have hi : (f ^ (i - 1)) (f x) = y, from
    calc (f ^ (i - 1)) (f x) = (f ^ (i - 1) * f ^ (1 : ℤ)) x : by rw [gpow_one, mul_apply]
    ... =  y : by rwa [← gpow_add, sub_add_cancel],
  is_cycle_swap_mul_aux₂ (i - 1) hf hy hi⟩

lemma support_swap_mul_cycle [fintype α] {f : perm α} (hf : is_cycle f) {x : α}
  (hffx : f (f x) ≠ x) : (swap x (f x) * f).support = f.support.erase x :=
have hfx : f x ≠ x, from λ hfx, by simpa [hfx] using hffx,
finset.ext.2 $ λ y, begin
  have h1 : swap x (f x) * f ≠ 1,
    from λ h1, hffx $ by
      rw [mul_eq_one_iff_inv_eq, swap_inv] at h1;
      rw ← h1; simp,
  have hfyxor : f y ≠ x ∨ f x ≠ y :=
    not_and_distrib.1 (λ h, h1 $
      by have := eq_swap_of_is_cycle_of_apply_apply_eq_self hf hfx (by rw [h.2, h.1]);
      rw [← this, this, mul_def, swap_swap, one_def]),
  rw [mem_support, mem_erase, mem_support],
  split,
  { assume h,
    refine not_or_distrib.1 (λ h₁, h₁.elim
      (λ hyx, by simpa [hyx, mul_apply] using h) _),
    assume hfy,
    have hyx : x ≠ y := λ h, by rw h at hfx; tauto,
    have hfyx : f x ≠ y := by rwa [← hfy, ne.def, injective.eq_iff f.bijective.1],
    simpa [mul_apply, hfy, swap_apply_of_ne_of_ne hyx.symm hfyx.symm] using h },
  { assume h,
    simp [swap_apply_def],
    split_ifs; cc }
end

@[simp] lemma support_swap [fintype α] {x y : α} (hxy : x ≠ y) : (swap x y).support = {x, y} :=
finset.ext.2 $ λ a, by simp [swap_apply_def]; split_ifs; cc

lemma card_support_swap [fintype α] {x y : α} (hxy : x ≠ y) : (swap x y).support.card = 2 :=
show (swap x y).support.card = finset.card ⟨x::y::0, by simp [hxy]⟩,
from congr_arg card $ by rw [support_swap hxy]; simp [*, finset.ext]; cc

lemma sign_cycle [fintype α] : ∀ {f : perm α} (hf : is_cycle f),
  sign f = -(-1 ^ f.support.card)
| f := λ hf,
let ⟨x, hx⟩ := hf in
calc sign f = sign (swap x (f x) * (swap x (f x) * f)) :
  by rw [← mul_assoc, mul_def, mul_def, swap_swap, trans_refl]
... = -(-1 ^ f.support.card) :
  if h1 : f (f x) = x
  then
    have h : swap x (f x) * f = 1,
      by conv in (f) {rw eq_swap_of_is_cycle_of_apply_apply_eq_self hf hx.1 h1 };
        simp [mul_def, one_def],
    by rw [sign_mul, sign_swap hx.1.symm, h, sign_one, eq_swap_of_is_cycle_of_apply_apply_eq_self hf hx.1 h1,
        card_support_swap hx.1.symm]; refl
  else
    have h : card (support (swap x (f x) * f)) + 1 = card (support f),
      by rw [← insert_erase (mem_support.2 hx.1), support_swap_mul_cycle hf h1,
        card_insert_of_not_mem (not_mem_erase _ _)],
    have wf : card (support (swap x (f x) * f)) < card (support f),
      from h ▸ nat.lt_succ_self _,
    by rw [sign_mul, sign_swap hx.1.symm, sign_cycle (is_cycle_swap_mul hf hx.1 h1), ← h];
      simp [pow_add]
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ f, f.support.card)⟩]}

end equiv.perm


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.complete_lattice
import order.cover
import order.iterate
import tactic.monotonicity

/-!
# Successor and predecessor

This file defines successor and predecessor orders. `succ a`, the successor of an element `a : α` is
the least element greater than `a`. `pred a` is the greatest element less than `a`. Typical examples
include `ℕ`, `ℤ`, `ℕ+`, `fin n`, but also `enat`, the lexicographic order of a successor/predecessor
order...

## Typeclasses

* `succ_order`: Order equipped with a sensible successor function.
* `pred_order`: Order equipped with a sensible predecessor function.
* `is_succ_archimedean`: `succ_order` where `succ` iterated to an element gives all the greater
  ones.
* `is_pred_archimedean`: `pred_order` where `pred` iterated to an element gives all the smaller
  ones.

## Implementation notes

Maximal elements don't have a sensible successor. Thus the naïve typeclass
```lean
class naive_succ_order (α : Type*) [preorder α] :=
(succ : α → α)
(succ_le_iff : ∀ {a b}, succ a ≤ b ↔ a < b)
(lt_succ_iff : ∀ {a b}, a < succ b ↔ a ≤ b)
```
can't apply to an `order_top` because plugging in `a = b = ⊤` into either of `succ_le_iff` and
`lt_succ_iff` yields `⊤ < ⊤` (or more generally `m < m` for a maximal element `m`).
The solution taken here is to remove the implications `≤ → <` and instead require that `a < succ a`
for all non maximal elements (enforced by the combination of `le_succ` and the contrapositive of
`max_of_succ_le`).
The stricter condition of every element having a sensible successor can be obtained through the
combination of `succ_order α` and `no_max_order α`.

## TODO

Is `galois_connection pred succ` always true? If not, we should introduce
```lean
class succ_pred_order (α : Type*) [preorder α] extends succ_order α, pred_order α :=
(pred_succ_gc : galois_connection (pred : α → α) succ)
```
`covby` should help here.
-/

open function order_dual set

variables {α : Type*}

/-- Order equipped with a sensible successor function. -/
@[ext] class succ_order (α : Type*) [preorder α] :=
(succ : α → α)
(le_succ : ∀ a, a ≤ succ a)
(max_of_succ_le {a} : succ a ≤ a → is_max a)
(succ_le_of_lt {a b} : a < b → succ a ≤ b)
(le_of_lt_succ {a b} : a < succ b → a ≤ b)

/-- Order equipped with a sensible predecessor function. -/
@[ext] class pred_order (α : Type*) [preorder α] :=
(pred : α → α)
(pred_le : ∀ a, pred a ≤ a)
(min_of_le_pred {a} : a ≤ pred a → is_min a)
(le_pred_of_lt {a b} : a < b → a ≤ pred b)
(le_of_pred_lt {a b} : pred a < b → a ≤ b)

instance [preorder α] [succ_order α] : pred_order (order_dual α) :=
{ pred := to_dual ∘ succ_order.succ ∘ of_dual,
  pred_le := succ_order.le_succ,
  min_of_le_pred := λ _, succ_order.max_of_succ_le,
  le_pred_of_lt := λ a b h, succ_order.succ_le_of_lt h,
  le_of_pred_lt := λ a b, succ_order.le_of_lt_succ }

instance [preorder α] [pred_order α] : succ_order (order_dual α) :=
{ succ := to_dual ∘ pred_order.pred ∘ of_dual,
  le_succ := pred_order.pred_le,
  max_of_succ_le := λ _, pred_order.min_of_le_pred,
  succ_le_of_lt := λ a b h, pred_order.le_pred_of_lt h,
  le_of_lt_succ := λ a b, pred_order.le_of_pred_lt }

section preorder
variables [preorder α]

/-- A constructor for `succ_order α` usable when `α` has no maximal element. -/
def succ_order.of_succ_le_iff_of_le_lt_succ (succ : α → α)
  (hsucc_le_iff : ∀ {a b}, succ a ≤ b ↔ a < b) (hle_of_lt_succ : ∀ {a b}, a < succ b → a ≤ b) :
  succ_order α :=
{ succ := succ,
  le_succ := λ a, (hsucc_le_iff.1 le_rfl).le,
  max_of_succ_le := λ a ha, (lt_irrefl a $ hsucc_le_iff.1 ha).elim,
  succ_le_of_lt := λ a b, hsucc_le_iff.2,
  le_of_lt_succ := λ a b, hle_of_lt_succ }

/-- A constructor for `pred_order α` usable when `α` has no minimal element. -/
def pred_order.of_le_pred_iff_of_pred_le_pred (pred : α → α)
  (hle_pred_iff : ∀ {a b}, a ≤ pred b ↔ a < b) (hle_of_pred_lt : ∀ {a b}, pred a < b → a ≤ b) :
  pred_order α :=
{ pred := pred,
  pred_le := λ a, (hle_pred_iff.1 le_rfl).le,
  min_of_le_pred := λ a ha, (lt_irrefl a $ hle_pred_iff.1 ha).elim,
  le_pred_of_lt := λ a b, hle_pred_iff.2,
  le_of_pred_lt := λ a b, hle_of_pred_lt }

end preorder

section linear_order
variables [linear_order α]

/-- A constructor for `succ_order α` usable when `α` is a linear order with no maximal element. -/
def succ_order.of_succ_le_iff (succ : α → α) (hsucc_le_iff : ∀ {a b}, succ a ≤ b ↔ a < b) :
  succ_order α :=
{ succ := succ,
  le_succ := λ a, (hsucc_le_iff.1 le_rfl).le,
  max_of_succ_le := λ a ha, (lt_irrefl a $ hsucc_le_iff.1 ha).elim,
  succ_le_of_lt := λ a b, hsucc_le_iff.2,
  le_of_lt_succ := λ a b h, le_of_not_lt ((not_congr hsucc_le_iff).1 h.not_le) }

/-- A constructor for `pred_order α` usable when `α` is a linear order with no minimal element. -/
def pred_order.of_le_pred_iff (pred : α → α) (hle_pred_iff : ∀ {a b}, a ≤ pred b ↔ a < b) :
  pred_order α :=
{ pred := pred,
  pred_le := λ a, (hle_pred_iff.1 le_rfl).le,
  min_of_le_pred := λ a ha, (lt_irrefl a $ hle_pred_iff.1 ha).elim,
  le_pred_of_lt := λ a b, hle_pred_iff.2,
  le_of_pred_lt := λ a b h, le_of_not_lt ((not_congr hle_pred_iff).1 h.not_le) }

end linear_order

/-! ### Successor order -/

namespace order
section preorder
variables [preorder α] [succ_order α] {a b : α}

/-- The successor of an element. If `a` is not maximal, then `succ a` is the least element greater
than `a`. If `a` is maximal, then `succ a = a`. -/
def succ : α → α := succ_order.succ

lemma le_succ : ∀ a : α, a ≤ succ a := succ_order.le_succ
lemma max_of_succ_le {a : α} : succ a ≤ a → is_max a := succ_order.max_of_succ_le
lemma succ_le_of_lt {a b : α} : a < b → succ a ≤ b := succ_order.succ_le_of_lt
lemma le_of_lt_succ {a b : α} : a < succ b → a ≤ b := succ_order.le_of_lt_succ

@[simp] lemma succ_le_iff_is_max : succ a ≤ a ↔ is_max a := ⟨max_of_succ_le, λ h, h $ le_succ _⟩

@[simp] lemma lt_succ_iff_not_is_max : a < succ a ↔ ¬ is_max a :=
⟨not_is_max_of_lt, λ ha, (le_succ a).lt_of_not_le $ λ h, ha $ max_of_succ_le h⟩

alias lt_succ_iff_not_is_max ↔ _ order.lt_succ_of_not_is_max

lemma covby_succ_of_not_is_max (h : ¬ is_max a) : a ⋖ succ a :=
⟨lt_succ_of_not_is_max h, λ b hb, (succ_le_of_lt hb).not_lt⟩

lemma lt_succ_iff_of_not_is_max (ha : ¬ is_max a) : b < succ a ↔ b ≤ a :=
⟨le_of_lt_succ, λ h, h.trans_lt $ lt_succ_of_not_is_max ha⟩

lemma succ_le_iff_of_not_is_max (ha : ¬ is_max a) : succ a ≤ b ↔ a < b :=
⟨(lt_succ_of_not_is_max ha).trans_le, succ_le_of_lt⟩

@[simp, mono] lemma succ_le_succ (h : a ≤ b) : succ a ≤ succ b :=
begin
  by_cases hb : is_max b,
  { by_cases hba : b ≤ a,
    { exact (hb $ hba.trans $ le_succ _).trans (le_succ _) },
    { exact succ_le_of_lt ((h.lt_of_not_le hba).trans_le $ le_succ b) } },
  { rwa [succ_le_iff_of_not_is_max (λ ha, hb $ ha.mono h), lt_succ_iff_of_not_is_max hb] }
end

lemma succ_mono : monotone (succ : α → α) := λ a b, succ_le_succ

lemma Iio_succ_of_not_is_max (ha : ¬ is_max a) : Iio (succ a) = Iic a :=
set.ext $ λ x, lt_succ_iff_of_not_is_max ha

lemma Ici_succ_of_not_is_max (ha : ¬ is_max a) : Ici (succ a) = Ioi a :=
set.ext $ λ x, succ_le_iff_of_not_is_max ha

section no_max_order
variables [no_max_order α]

lemma lt_succ (a : α) : a < succ a := lt_succ_of_not_is_max $ not_is_max a
lemma lt_succ_iff : a < succ b ↔ a ≤ b := lt_succ_iff_of_not_is_max $ not_is_max b
lemma succ_le_iff : succ a ≤ b ↔ a < b := succ_le_iff_of_not_is_max $ not_is_max a

@[simp] lemma succ_le_succ_iff : succ a ≤ succ b ↔ a ≤ b :=
⟨λ h, le_of_lt_succ $ (lt_succ a).trans_le h, λ h, succ_le_of_lt $ h.trans_lt $ lt_succ b⟩

lemma succ_lt_succ_iff : succ a < succ b ↔ a < b :=
lt_iff_lt_of_le_iff_le' succ_le_succ_iff succ_le_succ_iff

alias succ_le_succ_iff ↔ order.le_of_succ_le_succ _
alias succ_lt_succ_iff ↔ order.lt_of_succ_lt_succ order.succ_lt_succ

lemma succ_strict_mono : strict_mono (succ : α → α) := λ a b, succ_lt_succ

lemma covby_succ (a : α) : a ⋖ succ a := covby_succ_of_not_is_max $ not_is_max a

lemma Iio_succ (a : α) : Iio (succ a) = Iic a := Iio_succ_of_not_is_max $ not_is_max a
lemma Ici_succ (a : α) : Ici (succ a) = Ioi a := Ici_succ_of_not_is_max $ not_is_max a

end no_max_order
end preorder

section partial_order
variables [partial_order α] [succ_order α] {a b : α}

@[simp] lemma succ_eq_iff_is_max : succ a = a ↔ is_max a :=
⟨λ h, max_of_succ_le h.le, λ h, h.eq_of_ge $ le_succ _⟩

alias succ_eq_iff_is_max ↔ _ is_max.succ_eq

lemma le_le_succ_iff : a ≤ b ∧ b ≤ succ a ↔ b = a ∨ b = succ a :=
begin
  refine ⟨λ h, or_iff_not_imp_left.2 $ λ hba : b ≠ a,
    h.2.antisymm (succ_le_of_lt $ h.1.lt_of_ne $ hba.symm), _⟩,
  rintro (rfl | rfl),
  { exact ⟨le_rfl, le_succ b⟩ },
  { exact ⟨le_succ a, le_rfl⟩ }
end

lemma _root_.covby.succ_eq (h : a ⋖ b) : succ a = b :=
(succ_le_of_lt h.lt).eq_of_not_lt $ λ h', h.2 (lt_succ_of_not_is_max h.lt.not_is_max) h'

section no_max_order
variables [no_max_order α]

@[simp] lemma succ_eq_succ_iff : succ a = succ b ↔ a = b :=
by simp_rw [eq_iff_le_not_lt, succ_le_succ_iff, succ_lt_succ_iff]

lemma succ_injective : injective (succ : α → α) := λ a b, succ_eq_succ_iff.1
lemma succ_ne_succ_iff : succ a ≠ succ b ↔ a ≠ b := succ_injective.ne_iff

alias succ_ne_succ_iff ↔ _ order.succ_ne_succ

lemma lt_succ_iff_lt_or_eq : a < succ b ↔ a < b ∨ a = b := lt_succ_iff.trans le_iff_lt_or_eq

lemma le_succ_iff_lt_or_eq : a ≤ succ b ↔ a ≤ b ∨ a = succ b :=
by rw [←lt_succ_iff, ←lt_succ_iff, lt_succ_iff_lt_or_eq]

lemma succ_eq_iff_covby : succ a = b ↔ a ⋖ b :=
⟨by { rintro rfl, exact covby_succ _ }, covby.succ_eq⟩

end no_max_order

section order_top
variables [order_top α]

@[simp] lemma succ_top : succ (⊤ : α) = ⊤ := is_max_top.succ_eq

@[simp] lemma succ_le_iff_eq_top : succ a ≤ a ↔ a = ⊤ := succ_le_iff_is_max.trans is_max_iff_eq_top
@[simp] lemma lt_succ_iff_ne_top : a < succ a ↔ a ≠ ⊤ :=
lt_succ_iff_not_is_max.trans not_is_max_iff_ne_top

end order_top

section order_bot
variables [order_bot α] [nontrivial α]

lemma bot_lt_succ (a : α) : ⊥ < succ a :=
(lt_succ_of_not_is_max not_is_max_bot).trans_le $ succ_mono bot_le

lemma succ_ne_bot (a : α) : succ a ≠ ⊥ := (bot_lt_succ a).ne'

end order_bot
end partial_order

/-- There is at most one way to define the successors in a `partial_order`. -/
instance [partial_order α] : subsingleton (succ_order α) :=
⟨begin
  introsI h₀ h₁,
  ext a,
  by_cases ha : is_max a,
  { exact (@is_max.succ_eq _ _ h₀ _ ha).trans ha.succ_eq.symm },
  { exact @covby.succ_eq _ _ h₀ _ _ (covby_succ_of_not_is_max ha) }
end⟩

section complete_lattice
variables [complete_lattice α] [succ_order α]

lemma succ_eq_infi (a : α) : succ a = ⨅ b (h : a < b), b :=
begin
  refine le_antisymm (le_infi (λ b, le_infi succ_le_of_lt)) _,
  obtain rfl | ha := eq_or_ne a ⊤,
  { rw succ_top,
    exact le_top },
  exact infi₂_le _ (lt_succ_iff_ne_top.2 ha),
end

end complete_lattice

/-! ### Predecessor order -/

section preorder
variables [preorder α] [pred_order α] {a b : α}

/-- The predecessor of an element. If `a` is not minimal, then `pred a` is the greatest element less
than `a`. If `a` is minimal, then `pred a = a`. -/
def pred : α → α := pred_order.pred

lemma pred_le : ∀ a : α, pred a ≤ a := pred_order.pred_le
lemma min_of_le_pred {a : α} : a ≤ pred a → is_min a := pred_order.min_of_le_pred
lemma le_pred_of_lt {a b : α} : a < b → a ≤ pred b := pred_order.le_pred_of_lt
lemma le_of_pred_lt {a b : α} : pred a < b → a ≤ b := pred_order.le_of_pred_lt

@[simp] lemma le_pred_iff_is_min : a ≤ pred a ↔ is_min a := ⟨min_of_le_pred, λ h, h $ pred_le _⟩

@[simp] lemma pred_lt_iff_not_is_min : pred a < a ↔ ¬ is_min a :=
⟨not_is_min_of_lt, λ ha, (pred_le a).lt_of_not_le $ λ h, ha $ min_of_le_pred h⟩

alias pred_lt_iff_not_is_min ↔ _ order.pred_lt_of_not_is_min

lemma pred_covby_of_not_is_min (h : ¬ is_min a) : pred a ⋖ a :=
⟨pred_lt_of_not_is_min h, λ b hb, (le_of_pred_lt hb).not_lt⟩

lemma pred_lt_iff_of_not_is_min (ha : ¬ is_min a) : pred a < b ↔ a ≤ b :=
⟨le_of_pred_lt, (pred_lt_of_not_is_min ha).trans_le⟩

lemma le_pred_iff_of_not_is_min (ha : ¬ is_min a) : b ≤ pred a ↔ b < a :=
⟨λ h, h.trans_lt $ pred_lt_of_not_is_min ha, le_pred_of_lt⟩

@[simp, mono] lemma pred_le_pred {a b : α} (h : a ≤ b) : pred a ≤ pred b := succ_le_succ h.dual

lemma pred_mono : monotone (pred : α → α) := λ a b, pred_le_pred

lemma Ioi_pred_of_not_is_min (ha : ¬ is_min a) : Ioi (pred a) = Ici a :=
set.ext $ λ x, pred_lt_iff_of_not_is_min ha

lemma Iic_pred_of_not_is_min (ha : ¬ is_min a) : Iic (pred a) = Iio a :=
set.ext $ λ x, le_pred_iff_of_not_is_min ha

section no_min_order
variables [no_min_order α]

lemma pred_lt (a : α) : pred a < a := pred_lt_of_not_is_min $ not_is_min a
lemma pred_lt_iff : pred a < b ↔ a ≤ b := pred_lt_iff_of_not_is_min $ not_is_min a
lemma le_pred_iff : a ≤ pred b ↔ a < b := le_pred_iff_of_not_is_min $ not_is_min b

@[simp] lemma pred_le_pred_iff : pred a ≤ pred b ↔ a ≤ b :=
⟨λ h, le_of_pred_lt $ h.trans_lt (pred_lt b), λ h, le_pred_of_lt $ (pred_lt a).trans_le h⟩

@[simp] lemma pred_lt_pred_iff : pred a < pred b ↔ a < b :=
by simp_rw [lt_iff_le_not_le, pred_le_pred_iff]

alias pred_le_pred_iff ↔ order.le_of_pred_le_pred _
alias pred_lt_pred_iff ↔ order.lt_of_pred_lt_pred pred_lt_pred

lemma pred_strict_mono : strict_mono (pred : α → α) := λ a b, pred_lt_pred

lemma pred_covby (a : α) : pred a ⋖ a := pred_covby_of_not_is_min $ not_is_min a

lemma Ioi_pred (a : α) : Ioi (pred a) = Ici a := Ioi_pred_of_not_is_min $ not_is_min a
lemma Iic_pred (a : α) : Iic (pred a) = Iio a := Iic_pred_of_not_is_min $ not_is_min a

end no_min_order
end preorder

section partial_order
variables [partial_order α] [pred_order α] {a b : α}

@[simp] lemma pred_eq_iff_is_min : pred a = a ↔ is_min a :=
⟨λ h, min_of_le_pred h.ge, λ h, h.eq_of_le $ pred_le _⟩

alias pred_eq_iff_is_min ↔ _ is_min.pred_eq

lemma pred_le_le_iff {a b : α} : pred a ≤ b ∧ b ≤ a ↔ b = a ∨ b = pred a :=
begin
  refine ⟨λ h, or_iff_not_imp_left.2 $ λ hba : b ≠ a,
    (le_pred_of_lt $ h.2.lt_of_ne hba).antisymm h.1, _⟩,
  rintro (rfl | rfl),
  { exact ⟨pred_le b, le_rfl⟩ },
  { exact ⟨le_rfl, pred_le a⟩ }
end

lemma _root_.covby.pred_eq {a b : α} (h : a ⋖ b) : pred b = a :=
(le_pred_of_lt h.lt).eq_of_not_gt $ λ h', h.2 h' $ pred_lt_of_not_is_min h.lt.not_is_min

section no_min_order
variables [no_min_order α]

@[simp] lemma pred_eq_pred_iff : pred a = pred b ↔ a = b :=
by simp_rw [eq_iff_le_not_lt, pred_le_pred_iff, pred_lt_pred_iff]

lemma pred_injective : injective (pred : α → α) := λ a b, pred_eq_pred_iff.1
lemma pred_ne_pred_iff : pred a ≠ pred b ↔ a ≠ b := pred_injective.ne_iff

alias pred_ne_pred_iff ↔ _ order.pred_ne_pred

lemma pred_lt_iff_lt_or_eq : pred a < b ↔ a < b ∨ a = b := pred_lt_iff.trans le_iff_lt_or_eq

lemma le_pred_iff_lt_or_eq : pred a ≤ b ↔ a ≤ b ∨ pred a = b :=
by rw [←pred_lt_iff, ←pred_lt_iff, pred_lt_iff_lt_or_eq]

lemma pred_eq_iff_covby : pred b = a ↔ a ⋖ b :=
⟨by { rintro rfl, exact pred_covby _ }, covby.pred_eq⟩

end no_min_order

section order_bot
variables [order_bot α]

@[simp] lemma pred_bot : pred (⊥ : α) = ⊥ := is_min_bot.pred_eq

@[simp] lemma le_pred_iff_eq_bot : a ≤ pred a ↔ a = ⊥ := @succ_le_iff_eq_top (order_dual α) _ _ _ _
@[simp] lemma pred_lt_iff_ne_bot : pred a < a ↔ a ≠ ⊥ := @lt_succ_iff_ne_top (order_dual α) _ _ _ _

end order_bot

section order_top
variables [order_top α] [nontrivial α]

lemma pred_lt_top (a : α) : pred a < ⊤ :=
(pred_mono le_top).trans_lt $ pred_lt_of_not_is_min not_is_min_top

lemma pred_ne_top (a : α) : pred a ≠ ⊤ := (pred_lt_top a).ne

end order_top
end partial_order

/-- There is at most one way to define the predecessors in a `partial_order`. -/
instance [partial_order α] : subsingleton (pred_order α) :=
⟨begin
  introsI h₀ h₁,
  ext a,
  by_cases ha : is_min a,
  { exact (@is_min.pred_eq _ _ h₀ _ ha).trans ha.pred_eq.symm },
  { exact @covby.pred_eq _ _ h₀ _ _ (pred_covby_of_not_is_min ha) }
end⟩

section complete_lattice
variables [complete_lattice α] [pred_order α]

lemma pred_eq_supr (a : α) : pred a = ⨆ b (h : b < a), b :=
begin
  refine le_antisymm _ (supr_le (λ b, supr_le le_pred_of_lt)),
  obtain rfl | ha := eq_or_ne a ⊥,
  { rw pred_bot,
    exact bot_le },
  { exact @le_supr₂ _ _ (λ b, b < a) _ (λ a _, a) (pred a) (pred_lt_iff_ne_bot.2 ha) }
end

end complete_lattice

/-! ### Successor-predecessor orders -/

section succ_pred_order
variables [partial_order α] [succ_order α] [pred_order α] {a b : α}

@[simp] lemma succ_pred_of_not_is_min (h : ¬ is_min a) : succ (pred a) = a :=
(pred_covby_of_not_is_min h).succ_eq
@[simp] lemma pred_succ_of_not_is_max (h : ¬ is_max a) : pred (succ a) = a :=
(covby_succ_of_not_is_max h).pred_eq

@[simp] lemma succ_pred [no_min_order α] (a : α) : succ (pred a) = a := (pred_covby _).succ_eq
@[simp] lemma pred_succ [no_max_order α] (a : α) : pred (succ a) = a := (covby_succ _).pred_eq

end succ_pred_order

/-! ### `with_bot`, `with_top`
Adding a greatest/least element to a `succ_order` or to a `pred_order`.

As far as successors and predecessors are concerned, there are four ways to add a bottom or top
element to an order:
* Adding a `⊤` to an `order_top`: Preserves `succ` and `pred`.
* Adding a `⊤` to a `no_max_order`: Preserves `succ`. Never preserves `pred`.
* Adding a `⊥` to an `order_bot`: Preserves `succ` and `pred`.
* Adding a `⊥` to a `no_min_order`: Preserves `pred`. Never preserves `succ`.
where "preserves `(succ/pred)`" means
`(succ/pred)_order α → (succ/pred)_order ((with_top/with_bot) α)`.
-/

section with_top
open with_top

/-! #### Adding a `⊤` to an `order_top` -/

instance [decidable_eq α] [partial_order α] [order_top α] [succ_order α] :
  succ_order (with_top α) :=
{ succ := λ a, match a with
    | ⊤        := ⊤
    | (some a) := ite (a = ⊤) ⊤ (some (succ a))
  end,
  le_succ := λ a, begin
    cases a,
    { exact le_top },
    change ((≤) : with_top α → with_top α → Prop) _ (ite _ _ _),
    split_ifs,
    { exact le_top },
    { exact some_le_some.2 (le_succ a) }
  end,
  max_of_succ_le := λ a ha, begin
    cases a,
    { exact is_max_top },
    change ((≤) : with_top α → with_top α → Prop) (ite _ _ _) _ at ha,
    split_ifs at ha with ha',
    { exact (not_top_le_coe _ ha).elim },
    { rw [some_le_some, succ_le_iff_eq_top] at ha,
      exact (ha' ha).elim }
  end,
  succ_le_of_lt := λ a b h, begin
    cases b,
    { exact le_top },
    cases a,
    { exact (not_top_lt h).elim },
    rw some_lt_some at h,
    change ((≤) : with_top α → with_top α → Prop) (ite _ _ _) _,
    split_ifs with ha,
    { rw ha at h,
      exact (not_top_lt h).elim },
    { exact some_le_some.2 (succ_le_of_lt h) }
  end,
  le_of_lt_succ := λ a b h, begin
    cases a,
    { exact (not_top_lt h).elim },
    cases b,
    { exact le_top },
    change ((<) : with_top α → with_top α → Prop) _ (ite _ _ _) at h,
    rw some_le_some,
    split_ifs at h with hb,
    { rw hb,
      exact le_top },
    { exact le_of_lt_succ (some_lt_some.1 h) }
  end }

instance [preorder α] [order_top α] [pred_order α] : pred_order (with_top α) :=
{ pred := λ a, match a with
    | ⊤        := some ⊤
    | (some a) := some (pred a)
  end,
  pred_le := λ a, match a with
    | ⊤        := le_top
    | (some a) := some_le_some.2 (pred_le a)
  end,
  min_of_le_pred := λ a ha, begin
    cases a,
    { exact ((coe_lt_top (⊤ : α)).not_le ha).elim },
    { exact (min_of_le_pred $ some_le_some.1 ha).with_top }
  end,
  le_pred_of_lt := λ a b h, begin
    cases a,
    { exact ((le_top).not_lt h).elim },
    cases b,
    { exact some_le_some.2 le_top },
    exact some_le_some.2 (le_pred_of_lt $ some_lt_some.1 h),
  end,
  le_of_pred_lt := λ a b h, begin
    cases b,
    { exact le_top },
    cases a,
    { exact (not_top_lt $ some_lt_some.1 h).elim },
    { exact some_le_some.2 (le_of_pred_lt $ some_lt_some.1 h) }
  end }

/-! #### Adding a `⊤` to a `no_max_order` -/

instance with_top.succ_order_of_no_max_order [preorder α] [no_max_order α] [succ_order α] :
  succ_order (with_top α) :=
{ succ := λ a, match a with
    | ⊤        := ⊤
    | (some a) := some (succ a)
  end,
  le_succ := λ a, begin
    cases a,
    { exact le_top },
    { exact some_le_some.2 (le_succ a) }
  end,
  max_of_succ_le := λ a ha, begin
    cases a,
    { exact is_max_top },
    { exact (not_is_max _ $ max_of_succ_le $ some_le_some.1 ha).elim }
  end,
  succ_le_of_lt := λ a b h, begin
    cases a,
    { exact (not_top_lt h).elim },
    cases b,
    { exact le_top},
    { exact some_le_some.2 (succ_le_of_lt $ some_lt_some.1 h) }
  end,
  le_of_lt_succ := λ a b h, begin
    cases a,
    { exact (not_top_lt h).elim },
    cases b,
    { exact le_top },
    { exact some_le_some.2 (le_of_lt_succ $ some_lt_some.1 h) }
  end }

instance [preorder α] [no_max_order α] [hα : nonempty α] : is_empty (pred_order (with_top α)) :=
⟨begin
  introI,
  set b := pred (⊤ : with_top α) with h,
  cases pred (⊤ : with_top α) with a ha; change b with pred ⊤ at h,
  { exact hα.elim (λ a, (min_of_le_pred h.ge).not_lt $ coe_lt_top a) },
  { obtain ⟨c, hc⟩ := exists_gt a,
    rw [←some_lt_some, ←h] at hc,
    exact (le_of_pred_lt hc).not_lt (some_lt_none _) }
end⟩

end with_top

section with_bot
open with_bot

/-! #### Adding a `⊥` to an `order_bot` -/

instance [preorder α] [order_bot α] [succ_order α] : succ_order (with_bot α) :=
{ succ := λ a, match a with
    | ⊥        := some ⊥
    | (some a) := some (succ a)
  end,
  le_succ := λ a, match a with
    | ⊥        := bot_le
    | (some a) := some_le_some.2 (le_succ a)
  end,
  max_of_succ_le := λ a ha, begin
    cases a,
    { exact ((none_lt_some (⊥ : α)).not_le ha).elim },
    { exact is_max.with_bot (max_of_succ_le $ some_le_some.1 ha) }
  end,
  succ_le_of_lt := λ a b h, begin
    cases b,
    { exact (not_lt_bot h).elim },
    cases a,
    { exact some_le_some.2 bot_le },
    { exact some_le_some.2 (succ_le_of_lt $ some_lt_some.1 h) }
  end,
  le_of_lt_succ := λ a b h, begin
    cases a,
    { exact bot_le },
    cases b,
    { exact (not_lt_bot $ some_lt_some.1 h).elim },
    { exact some_le_some.2 (le_of_lt_succ $ some_lt_some.1 h) }
  end }

instance [decidable_eq α] [partial_order α] [order_bot α] [pred_order α] :
  pred_order (with_bot α) :=
{ pred := λ a, match a with
    | ⊥        := ⊥
    | (some a) := ite (a = ⊥) ⊥ (some (pred a))
  end,
  pred_le := λ a, begin
    cases a,
    { exact bot_le },
    change (ite _ _ _ : with_bot α) ≤ some a,
    split_ifs,
    { exact bot_le },
    { exact some_le_some.2 (pred_le a) }
  end,
  min_of_le_pred := λ a ha, begin
    cases a,
    { exact is_min_bot },
    change ((≤) : with_bot α → with_bot α → Prop) _ (ite _ _ _) at ha,
    split_ifs at ha with ha',
    { exact (not_coe_le_bot _ ha).elim },
    { rw [some_le_some, le_pred_iff_eq_bot] at ha,
      exact (ha' ha).elim }
  end,
  le_pred_of_lt := λ a b h, begin
    cases a,
    { exact bot_le },
    cases b,
    { exact (not_lt_bot h).elim },
    rw some_lt_some at h,
    change ((≤) : with_bot α → with_bot α → Prop) _ (ite _ _ _),
    split_ifs with hb,
    { rw hb at h,
      exact (not_lt_bot h).elim },
    { exact some_le_some.2 (le_pred_of_lt h) }
  end,
  le_of_pred_lt := λ a b h, begin
    cases b,
    { exact (not_lt_bot h).elim },
    cases a,
    { exact bot_le },
    change ((<) : with_bot α → with_bot α → Prop) (ite _ _ _) _ at h,
    rw some_le_some,
    split_ifs at h with ha,
    { rw ha,
      exact bot_le },
    { exact le_of_pred_lt (some_lt_some.1 h) }
  end }

/-! #### Adding a `⊥` to a `no_min_order` -/

instance [preorder α] [no_min_order α] [hα : nonempty α] : is_empty (succ_order (with_bot α)) :=
⟨begin
  introI,
  set b : with_bot α := succ ⊥ with h,
  cases succ (⊥ : with_bot α) with a ha; change b with succ ⊥ at h,
  { exact hα.elim (λ a, (max_of_succ_le h.le).not_lt $ bot_lt_coe a) },
  { obtain ⟨c, hc⟩ := exists_lt a,
    rw [←some_lt_some, ←h] at hc,
    exact (le_of_lt_succ hc).not_lt (none_lt_some _) }
end⟩

instance with_bot.pred_order_of_no_min_order [preorder α] [no_min_order α] [pred_order α] :
  pred_order (with_bot α) :=
{ pred := λ a, match a with
    | ⊥        := ⊥
    | (some a) := some (pred a)
  end,
  pred_le := λ a, begin
    cases a,
    { exact bot_le },
    { exact some_le_some.2 (pred_le a) }
  end,
  min_of_le_pred := λ a ha, begin
    cases a,
    { exact is_min_bot },
    { exact (not_is_min _ $ min_of_le_pred $ some_le_some.1 ha).elim }
  end,
  le_pred_of_lt := λ a b h, begin
    cases b,
    { exact (not_lt_bot h).elim },
    cases a,
    { exact bot_le },
    { exact some_le_some.2 (le_pred_of_lt $ some_lt_some.1 h) }
  end,
  le_of_pred_lt := λ a b h, begin
    cases b,
    { exact (not_lt_bot h).elim },
    cases a,
    { exact bot_le },
    { exact some_le_some.2 (le_of_pred_lt $ some_lt_some.1 h) }
  end }

end with_bot
end order

open order

/-! ### Archimedeanness -/

/-- A `succ_order` is succ-archimedean if one can go from any two comparable elements by iterating
`succ` -/
class is_succ_archimedean (α : Type*) [preorder α] [succ_order α] : Prop :=
(exists_succ_iterate_of_le {a b : α} (h : a ≤ b) : ∃ n, succ^[n] a = b)

/-- A `pred_order` is pred-archimedean if one can go from any two comparable elements by iterating
`pred` -/
class is_pred_archimedean (α : Type*) [preorder α] [pred_order α] : Prop :=
(exists_pred_iterate_of_le {a b : α} (h : a ≤ b) : ∃ n, pred^[n] b = a)

export is_succ_archimedean (exists_succ_iterate_of_le)
export is_pred_archimedean (exists_pred_iterate_of_le)

section preorder
variables [preorder α]

section succ_order
variables [succ_order α] [is_succ_archimedean α] {a b : α}

instance : is_pred_archimedean (order_dual α) :=
⟨λ a b h, by convert exists_succ_iterate_of_le h.of_dual⟩

lemma has_le.le.exists_succ_iterate (h : a ≤ b) : ∃ n, succ^[n] a = b :=
exists_succ_iterate_of_le h

lemma exists_succ_iterate_iff_le : (∃ n, succ^[n] a = b) ↔ a ≤ b :=
begin
  refine ⟨_, exists_succ_iterate_of_le⟩,
  rintro ⟨n, rfl⟩,
  exact id_le_iterate_of_id_le le_succ n a,
end

/-- Induction principle on a type with a `succ_order` for all elements above a given element `m`. -/
@[elab_as_eliminator] lemma succ.rec {P : α → Prop} {m : α}
  (h0 : P m) (h1 : ∀ n, m ≤ n → P n → P (succ n)) ⦃n : α⦄ (hmn : m ≤ n) : P n :=
begin
  obtain ⟨n, rfl⟩ := hmn.exists_succ_iterate, clear hmn,
  induction n with n ih,
  { exact h0 },
  { rw [function.iterate_succ_apply'], exact h1 _ (id_le_iterate_of_id_le le_succ n m) ih }
end

lemma succ.rec_iff {p : α → Prop} (hsucc : ∀ a, p a ↔ p (succ a)) {a b : α} (h : a ≤ b) :
  p a ↔ p b :=
begin
  obtain ⟨n, rfl⟩ := h.exists_succ_iterate,
  exact iterate.rec (λ b, p a ↔ p b) (λ c hc, hc.trans (hsucc _)) iff.rfl n,
end

end succ_order

section pred_order
variables [pred_order α] [is_pred_archimedean α] {a b : α}

instance : is_succ_archimedean (order_dual α) :=
⟨λ a b h, by convert exists_pred_iterate_of_le h.of_dual⟩

lemma has_le.le.exists_pred_iterate (h : a ≤ b) : ∃ n, pred^[n] b = a :=
exists_pred_iterate_of_le h

lemma exists_pred_iterate_iff_le : (∃ n, pred^[n] b = a) ↔ a ≤ b :=
@exists_succ_iterate_iff_le (order_dual α) _ _ _ _ _

/-- Induction principle on a type with a `pred_order` for all elements below a given element `m`. -/
@[elab_as_eliminator] lemma pred.rec {P : α → Prop} {m : α}
  (h0 : P m) (h1 : ∀ n, n ≤ m → P n → P (pred n)) ⦃n : α⦄ (hmn : n ≤ m) : P n :=
@succ.rec (order_dual α) _ _ _ _ _ h0 h1 _ hmn

lemma pred.rec_iff {p : α → Prop} (hsucc : ∀ a, p a ↔ p (pred a)) {a b : α} (h : a ≤ b) :
  p a ↔ p b :=
(@succ.rec_iff (order_dual α) _ _ _ _ hsucc _ _ h).symm

end pred_order
end preorder

section linear_order
variables [linear_order α]

section succ_order
variables [succ_order α] [is_succ_archimedean α] {a b : α}

lemma exists_succ_iterate_or : (∃ n, succ^[n] a = b) ∨ ∃ n, succ^[n] b = a :=
(le_total a b).imp exists_succ_iterate_of_le exists_succ_iterate_of_le

lemma succ.rec_linear {p : α → Prop} (hsucc : ∀ a, p a ↔ p (succ a)) (a b : α) : p a ↔ p b :=
(le_total a b).elim (succ.rec_iff hsucc) (λ h, (succ.rec_iff hsucc h).symm)

end succ_order

section pred_order
variables [pred_order α] [is_pred_archimedean α] {a b : α}

lemma exists_pred_iterate_or : (∃ n, pred^[n] b = a) ∨ ∃ n, pred^[n] a = b :=
(le_total a b).imp exists_pred_iterate_of_le exists_pred_iterate_of_le

lemma pred.rec_linear {p : α → Prop} (hsucc : ∀ a, p a ↔ p (pred a)) (a b : α) : p a ↔ p b :=
(le_total a b).elim (pred.rec_iff hsucc) (λ h, (pred.rec_iff hsucc h).symm)

end pred_order
end linear_order

section order_bot
variables [preorder α] [order_bot α] [succ_order α] [is_succ_archimedean α]

lemma succ.rec_bot (p : α → Prop) (hbot : p ⊥) (hsucc : ∀ a, p a → p (succ a)) (a : α) : p a :=
succ.rec hbot (λ x _ h, hsucc x h) (bot_le : ⊥ ≤ a)

end order_bot

section order_top
variables [preorder α] [order_top α] [pred_order α] [is_pred_archimedean α]

lemma pred.rec_top (p : α → Prop) (htop : p ⊤) (hpred : ∀ a, p a → p (pred a)) (a : α) : p a :=
pred.rec htop (λ x _ h, hpred x h) (le_top : a ≤ ⊤)

end order_top


import ..dot_prod ..logic .atom

inductive formula : Type
| true  : formula
| false : formula
| atom : atom → formula
| and : formula → formula → formula
| or  : formula → formula → formula
| not : formula → formula
| ex  : formula → formula
-- | ⊤' := sorry
-- | ⊥' := sorry
-- | (A' a) := sorry
-- | (p ∧' q) := sorry
-- | (p ∨' q) := sorry
-- | (¬' p) := sorry
-- | (∃' p) := sorry

notation `⊤'`     := formula.true
notation `⊥'`     := formula.false
notation `A'` a   := formula.atom a
notation `¬'` p   := formula.not p
notation p `∧'` q := formula.and p q
notation p `∨'` q := formula.or p q
notation `∃'` p   := formula.ex p

def formula.eval : list znum → formula → Prop
| as ⊤' := _root_.true
| as ⊥' := _root_.false
| as (A' a) := a.eval as
| as (formula.not φ)   := ¬ (formula.eval as φ)
| as (formula.or φ ψ)  := (formula.eval as φ) ∨ (formula.eval as ψ)
| as (formula.and φ ψ) := (formula.eval as φ) ∧ (formula.eval as ψ)
| as (formula.ex φ) := ∃ d, formula.eval (d::as) φ

lemma eval_true  {xs : list znum} : ⊤'.eval xs ↔ _root_.true :=
by simp [formula.eval]

lemma eval_not {p : formula} (xs : list znum) :
(¬' p).eval xs ↔ ¬ (p.eval xs) := iff.refl _

lemma eval_not_false {p : formula} (xs : list znum) :
(¬' ⊥').eval xs ↔ _root_.true :=
begin simp [formula.eval] end

lemma eval_not_or {p q : formula} {xs : list znum} :
(¬' (p ∨' q)).eval xs ↔ ((¬' p).eval xs ∧ (¬' q).eval xs) :=
begin simp [formula.eval, eval_not, not_or_distrib] end

lemma eval_not_and {p q : formula} {xs : list znum} :
(¬' (p ∧' q)).eval xs ↔ ((¬' p).eval xs ∨ (¬' q).eval xs) :=
begin
  simp only [formula.eval, eval_not ],
  rw (@not_and_distrib _ _ (classical.dec _))
end

lemma eval_or {p q : formula} (xs : list znum) :
(p ∨' q).eval xs = (p.eval xs ∨ q.eval xs) := eq.refl _

lemma eval_and {p q : formula} {xs : list znum} :
(p ∧' q).eval xs ↔ (p.eval xs ∧ q.eval xs) := iff.refl _

lemma eval_le {i : znum} {ks zs : list znum} :
  (A' (i ≤' ks)).eval zs ↔ (i ≤ znum.dot_prod ks zs) := iff.refl _

lemma eval_false {xs : list znum} : ⊥'.eval xs ↔ _root_.false :=
by simp [formula.eval]

lemma eval_ex {p : formula} (xs) : (∃' p).eval xs = ∃ x, (p.eval (x::xs)) :=
begin simp [formula.eval] end

open znum

lemma eval_dvd {d i : znum} {ks zs : list znum} :
  (A' (atom.dvd d i ks)).eval zs ↔ (has_dvd.dvd d (i + dot_prod ks zs)) := iff.refl _

lemma eval_ndvd {d i ks zs} :
  (A' (atom.ndvd d i ks)).eval zs ↔ ¬ (has_dvd.dvd d (i + dot_prod ks zs)) := iff.refl _

lemma eval_ndvd' (d i : znum) (ks zs : list znum) :
  (A' (atom.ndvd d i ks)).eval zs ↔ ¬ (A' (atom.dvd d i ks)).eval zs :=
begin simp [formula.eval, atom.eval] end

def not_o : formula → formula
| ⊤' := ⊥'
| ⊥' := ⊤'
| p := ¬' p

def and_o : formula → formula → formula
| (formula.true) q' := q'
| p' (formula.true) := p'
| (formula.false) q' := formula.false
| p' (formula.false) := formula.false
| p' q' := formula.and p' q'

def or_o : formula → formula → formula
| (formula.true ) _ := ⊤'
| _ (formula.true ) := ⊤'
| (formula.false ) q := q
| p (formula.false ) := p
| p q := formula.or p q

lemma eval_not_o {p : formula} (xs : list znum) :
  (not_o p).eval xs ↔ ¬(p.eval xs) :=
begin cases p; simp [not_o, formula.eval] end

lemma eval_or_o {p q : formula} (xs : list znum) :
(or_o p q).eval xs ↔ (p.eval xs ∨ q.eval xs) :=
begin cases p; cases q; simp [or_o, formula.eval] end

lemma eval_and_o {p q : formula} (xs : list znum) :
(and_o p q).eval xs ↔ (p.eval xs ∧ q.eval xs) :=
begin cases p; cases q; simp [and_o, formula.eval] end

-- Requires : qfree arg-0
def formula.map (f : atom → atom) : formula → formula
| ⊤' := ⊤'
| ⊥' := ⊥'
| A' a := A' (f a)
| (¬' p) := ¬' p.map
| (p ∨' q) :=  p.map ∨' q.map
| (p ∧' q) :=  p.map ∧' q.map
| (∃' p) := ⊥'

def conj  : list (formula) → formula
| [] := ⊤'
| (p::ps) := and_o p $ conj ps

def conj_atom  : list (atom) → formula
| [] := ⊤'
| (a::as) := and_o (A' a) $ conj_atom as

def disj : list (formula) → formula
| [] := ⊥'
| (p::ps) := or_o p $ disj ps

lemma eval_disj {xs : list znum} :
  ∀ {ps : list (formula)}, (disj ps).eval xs ↔ (∃ p : formula, p ∈ ps ∧ p.eval xs)
| [] := begin simp [disj, formula.eval] end
| (p::ps) :=
  begin
    rw [list.forsome_mem_cons], simp [disj, eval_or_o],
    apply or_iff_or iff.rfl eval_disj
  end

def disj_map {β : Type} (bs : list β) (p : β → formula) := disj (list.map p bs)

lemma eval_disj_map {β : Type} (as : list β)
  (p : β → formula) {ds : list znum} :
  (disj_map as p).eval ds ↔ ∃ a, a ∈ as ∧ (p a).eval ds :=
begin
  simp [disj_map, eval_disj],
  constructor; intro h; cases h with x hx; cases hx with hx1 hx2,
  { cases hx1 with a ha, cases ha with ha1 ha2, subst ha2,
    existsi a, constructor; assumption },
  { existsi (p x), constructor, existsi x,
    constructor, assumption, refl, assumption }
end

lemma cases_not_o (P : formula → Prop) (p : formula)
  (HT : P ⊤') (Hp : P ⊥') (Hq : P (¬'p)) : P (not_o p) :=
begin cases p; try {simp [not_o], assumption} end

lemma cases_or_o (P : formula → Prop) (p q : formula)
  (HT : P ⊤') (Hp : P p) (Hq : P q) (Hpq : P (p ∨' q)) : P (or_o p q) :=
begin cases p; cases q; try {simp [or_o], assumption} end

lemma cases_and_o (P : formula → Prop) (p q : formula)
  (HB : P ⊥') (Hp : P p) (Hq : P q) (Hpq : P (p ∧' q)) : P (and_o p q) :=
begin cases p; cases q; try {simp [and_o], assumption} end

lemma eval_mod_dvd {m d i ks z zs} :
  d ∣ m →
  ((A' (atom.dvd d i ks)).eval (z % m :: zs)
  ↔ (A' (atom.dvd d i ks)).eval (z :: zs))  :=
begin
  intro hdvd, cases ks with k ks; simp [eval_dvd],
  simp [dot_prod], have hrw1 : z = (z % m) + (z - (z % m)),
  { rw [add_comm, sub_add_cancel] },
  have hrw2 : k * z = k * ((z % m) + (z - (z % m))) := by simp [hrw1.symm],
  rw [hrw2, mul_add],  repeat {rw [(add_assoc _ _ _).symm]},
  apply (dvd_add_iff_left _),
  rw [znum.mod_def, sub_sub_cancel, mul_comm, mul_assoc],
  apply dvd_mul_of_dvd_left hdvd,
end

lemma eval_mod_ndvd {m d i ks z zs} :
  d ∣ m →
  ((A' (atom.ndvd d i ks)).eval (z % m :: zs)
    ↔ (A' (atom.ndvd d i ks)).eval (z :: zs)) :=
begin intro hdvd, simp [eval_ndvd', eval_mod_dvd hdvd] end

meta def formula.to_format  : formula → format
| (formula.true)  := "⊤"
| (formula.false) := "⊥"
| (formula.atom a) := a.to_format
| (formula.and p q) := "(" ++ (formula.to_format p) ++ " ∧ " ++ (formula.to_format q) ++ ")"
| (formula.or p q)  := "(" ++ (formula.to_format p) ++ " ∨ " ++ (formula.to_format q) ++ ")"
| (formula.not p)  := "¬(" ++ (formula.to_format p) ++ ")"
| (formula.ex p)   := "∃(" ++ (formula.to_format p) ++ ")"

meta instance formula.has_to_format : has_to_format (formula) := ⟨formula.to_format⟩

meta instance formula.has_to_tactic_format : has_to_tactic_format (formula) :=
has_to_format_to_has_to_tactic_format _


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

! This file was ported from Lean 3 source module data.rat.nnrat
! leanprover-community/mathlib commit b3f4f007a962e3787aa0f3b5c7942a1317f7d88e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Algebra.Basic
import Mathlib.Algebra.Order.Nonneg.Field
import Mathlib.Algebra.Order.Nonneg.Floor

/-!
# Nonnegative rationals

This file defines the nonnegative rationals as a subtype of `Rat` and provides its algebraic order
structure.

We also define an instance `CanLift ℚ ℚ≥0`. This instance can be used by the `lift` tactic to
replace `x : ℚ` and `hx : 0 ≤ x` in the proof context with `x : ℚ≥0` while replacing all occurrences
of `x` with `↑x`. This tactic also works for a function `f : α → ℚ` with a hypothesis
`hf : ∀ x, 0 ≤ f x`.

## Notation

`ℚ≥0` is notation for `NNRat` in locale `NNRat`.
-/

open Function

open BigOperators

/-- Nonnegative rational numbers. -/
def NNRat := { q : ℚ // 0 ≤ q } deriving
  CanonicallyOrderedCommSemiring, CanonicallyLinearOrderedSemifield, LinearOrderedCommGroupWithZero,
  Sub, Inhabited
#align nnrat NNRat

-- Porting note: Added these instances to get `OrderedSub, DenselyOrdered, Archimedean`
-- instead of `deriving` them
instance : OrderedSub NNRat := Nonneg.orderedSub
instance : DenselyOrdered NNRat := Nonneg.densely_ordered
instance : Archimedean NNRat := Nonneg.archimedean

-- mathport name: nnrat
scoped[NNRat] notation "ℚ≥0" => NNRat

namespace NNRat

variable {α : Type _} {p q : ℚ≥0}

instance : Coe ℚ≥0 ℚ :=
  ⟨Subtype.val⟩

/-
-- Simp lemma to put back `n.val` into the normal form given by the coercion.
@[simp]
theorem val_eq_coe (q : ℚ≥0) : q.val = q :=
  rfl
-/
-- Porting note: `val_eq_coe` is no longer needed.
#noalign nnrat.val_eq_coe

instance canLift : CanLift ℚ ℚ≥0 (↑) fun q ↦ 0 ≤ q where
  prf q hq := ⟨⟨q, hq⟩, rfl⟩
#align nnrat.can_lift NNRat.canLift

@[ext]
theorem ext : (p : ℚ) = (q : ℚ) → p = q :=
  Subtype.ext
#align nnrat.ext NNRat.ext

protected theorem coe_injective : Injective ((↑) : ℚ≥0 → ℚ) :=
  Subtype.coe_injective
#align nnrat.coe_injective NNRat.coe_injective

@[simp, norm_cast]
theorem coe_inj : (p : ℚ) = q ↔ p = q :=
  Subtype.coe_inj
#align nnrat.coe_inj NNRat.coe_inj

theorem ext_iff : p = q ↔ (p : ℚ) = q :=
  Subtype.ext_iff
#align nnrat.ext_iff NNRat.ext_iff

theorem ne_iff {x y : ℚ≥0} : (x : ℚ) ≠ (y : ℚ) ↔ x ≠ y :=
  NNRat.coe_inj.not
#align nnrat.ne_iff NNRat.ne_iff

@[norm_cast]
theorem coe_mk (q : ℚ) (hq) : ((⟨q, hq⟩ : ℚ≥0) : ℚ) = q :=
  rfl
#align nnrat.coe_mk NNRat.coe_mk

/-- Reinterpret a rational number `q` as a non-negative rational number. Returns `0` if `q ≤ 0`. -/
def _root_.Rat.toNNRat (q : ℚ) : ℚ≥0 :=
  ⟨max q 0, le_max_right _ _⟩
#align rat.to_nnrat Rat.toNNRat

theorem _root_.Rat.coe_toNNRat (q : ℚ) (hq : 0 ≤ q) : (q.toNNRat : ℚ) = q :=
  max_eq_left hq
#align rat.coe_to_nnrat Rat.coe_toNNRat

theorem _root_.Rat.le_coe_toNNRat (q : ℚ) : q ≤ q.toNNRat :=
  le_max_left _ _
#align rat.le_coe_to_nnrat Rat.le_coe_toNNRat

open Rat (toNNRat)

@[simp]
theorem coe_nonneg (q : ℚ≥0) : (0 : ℚ) ≤ q :=
  q.2
#align nnrat.coe_nonneg NNRat.coe_nonneg

@[simp, norm_cast]
theorem coe_zero : ((0 : ℚ≥0) : ℚ) = 0 :=
  rfl
#align nnrat.coe_zero NNRat.coe_zero

@[simp, norm_cast]
theorem coe_one : ((1 : ℚ≥0) : ℚ) = 1 :=
  rfl
#align nnrat.coe_one NNRat.coe_one

@[simp, norm_cast]
theorem coe_add (p q : ℚ≥0) : ((p + q : ℚ≥0) : ℚ) = p + q :=
  rfl
#align nnrat.coe_add NNRat.coe_add

@[simp, norm_cast]
theorem coe_mul (p q : ℚ≥0) : ((p * q : ℚ≥0) : ℚ) = p * q :=
  rfl
#align nnrat.coe_mul NNRat.coe_mul

@[simp, norm_cast]
theorem coe_inv (q : ℚ≥0) : ((q⁻¹ : ℚ≥0) : ℚ) = (q : ℚ)⁻¹ :=
  rfl
#align nnrat.coe_inv NNRat.coe_inv

@[simp, norm_cast]
theorem coe_div (p q : ℚ≥0) : ((p / q : ℚ≥0) : ℚ) = p / q :=
  rfl
#align nnrat.coe_div NNRat.coe_div

-- Porting note: `bit0` `bit1` are deprecated, so remove these theorems.
#noalign nnrat.coe_bit0
#noalign nnrat.coe_bit1

@[simp, norm_cast]
theorem coe_sub (h : q ≤ p) : ((p - q : ℚ≥0) : ℚ) = p - q :=
  max_eq_left <| le_sub_comm.2 <| by rwa [sub_zero]
#align nnrat.coe_sub NNRat.coe_sub

@[simp]
theorem coe_eq_zero : (q : ℚ) = 0 ↔ q = 0 := by norm_cast
#align nnrat.coe_eq_zero NNRat.coe_eq_zero

theorem coe_ne_zero : (q : ℚ) ≠ 0 ↔ q ≠ 0 :=
  coe_eq_zero.not
#align nnrat.coe_ne_zero NNRat.coe_ne_zero

@[norm_cast] -- Porting note: simp can prove this
theorem coe_le_coe : (p : ℚ) ≤ q ↔ p ≤ q :=
  Iff.rfl
#align nnrat.coe_le_coe NNRat.coe_le_coe

@[norm_cast] -- Porting note: simp can prove this
theorem coe_lt_coe : (p : ℚ) < q ↔ p < q :=
  Iff.rfl
#align nnrat.coe_lt_coe NNRat.coe_lt_coe

@[simp, norm_cast]
theorem coe_pos : (0 : ℚ) < q ↔ 0 < q :=
  Iff.rfl
#align nnrat.coe_pos NNRat.coe_pos

theorem coe_mono : Monotone ((↑) : ℚ≥0 → ℚ) :=
  fun _ _ ↦ coe_le_coe.2
#align nnrat.coe_mono NNRat.coe_mono

theorem toNNRat_mono : Monotone toNNRat :=
  fun _ _ h ↦ max_le_max h le_rfl
#align nnrat.to_nnrat_mono NNRat.toNNRat_mono

@[simp]
theorem toNNRat_coe (q : ℚ≥0) : toNNRat q = q :=
  ext <| max_eq_left q.2
#align nnrat.to_nnrat_coe NNRat.toNNRat_coe

@[simp]
theorem toNNRat_coe_nat (n : ℕ) : toNNRat n = n :=
  ext <| by simp only [Nat.cast_nonneg, Rat.coe_toNNRat]; rfl
#align nnrat.to_nnrat_coe_nat NNRat.toNNRat_coe_nat

/-- `toNNRat` and `(↑) : ℚ≥0 → ℚ` form a Galois insertion. -/
protected def gi : GaloisInsertion toNNRat (↑) :=
  GaloisInsertion.monotoneIntro coe_mono toNNRat_mono Rat.le_coe_toNNRat toNNRat_coe
#align nnrat.gi NNRat.gi

/-- Coercion `ℚ≥0 → ℚ` as a `RingHom`. -/
def coeHom : ℚ≥0 →+* ℚ where
  toFun := (↑)
  map_one' := coe_one
  map_mul' := coe_mul
  map_zero' := coe_zero
  map_add' := coe_add
#align nnrat.coe_hom NNRat.coeHom

@[simp, norm_cast]
theorem coe_natCast (n : ℕ) : (↑(↑n : ℚ≥0) : ℚ) = n :=
  map_natCast coeHom n
#align nnrat.coe_nat_cast NNRat.coe_natCast

@[simp]
theorem mk_coe_nat (n : ℕ) : @Eq ℚ≥0 (⟨(n : ℚ), n.cast_nonneg⟩ : ℚ≥0) n :=
  ext (coe_natCast n).symm
#align nnrat.mk_coe_nat NNRat.mk_coe_nat

/-- The rational numbers are an algebra over the non-negative rationals. -/
instance : Algebra ℚ≥0 ℚ :=
  coeHom.toAlgebra

/-- A `MulAction` over `ℚ` restricts to a `MulAction` over `ℚ≥0`. -/
instance [MulAction ℚ α] : MulAction ℚ≥0 α :=
  MulAction.compHom α coeHom.toMonoidHom

/-- A `DistribMulAction` over `ℚ` restricts to a `DistribMulAction` over `ℚ≥0`. -/
instance [AddCommMonoid α] [DistribMulAction ℚ α] : DistribMulAction ℚ≥0 α :=
  DistribMulAction.compHom α coeHom.toMonoidHom

/-- A `Module` over `ℚ` restricts to a `Module` over `ℚ≥0`. -/
instance [AddCommMonoid α] [Module ℚ α] : Module ℚ≥0 α :=
  Module.compHom α coeHom

@[simp]
theorem coe_coeHom : ⇑coeHom = ((↑) : ℚ≥0 → ℚ) :=
  rfl
#align nnrat.coe_coe_hom NNRat.coe_coeHom

@[simp, norm_cast]
theorem coe_indicator (s : Set α) (f : α → ℚ≥0) (a : α) :
    ((s.indicator f a : ℚ≥0) : ℚ) = s.indicator (fun x ↦ ↑(f x)) a :=
  (coeHom : ℚ≥0 →+ ℚ).map_indicator _ _ _
#align nnrat.coe_indicator NNRat.coe_indicator

@[simp, norm_cast]
theorem coe_pow (q : ℚ≥0) (n : ℕ) : (↑(q ^ n) : ℚ) = (q : ℚ) ^ n :=
  coeHom.map_pow _ _
#align nnrat.coe_pow NNRat.coe_pow

@[norm_cast]
theorem coe_list_sum (l : List ℚ≥0) : (l.sum : ℚ) = (l.map (↑)).sum :=
  coeHom.map_list_sum _
#align nnrat.coe_list_sum NNRat.coe_list_sum

@[norm_cast]
theorem coe_list_prod (l : List ℚ≥0) : (l.prod : ℚ) = (l.map (↑)).prod :=
  coeHom.map_list_prod _
#align nnrat.coe_list_prod NNRat.coe_list_prod

@[norm_cast]
theorem coe_multiset_sum (s : Multiset ℚ≥0) : (s.sum : ℚ) = (s.map (↑)).sum :=
  coeHom.map_multiset_sum _
#align nnrat.coe_multiset_sum NNRat.coe_multiset_sum

@[norm_cast]
theorem coe_multiset_prod (s : Multiset ℚ≥0) : (s.prod : ℚ) = (s.map (↑)).prod :=
  coeHom.map_multiset_prod _
#align nnrat.coe_multiset_prod NNRat.coe_multiset_prod

@[norm_cast]
theorem coe_sum {s : Finset α} {f : α → ℚ≥0} : ↑(∑ a in s, f a) = ∑ a in s, (f a : ℚ) :=
  coeHom.map_sum _ _
#align nnrat.coe_sum NNRat.coe_sum

theorem toNNRat_sum_of_nonneg {s : Finset α} {f : α → ℚ} (hf : ∀ a, a ∈ s → 0 ≤ f a) :
    (∑ a in s, f a).toNNRat = ∑ a in s, (f a).toNNRat := by
  rw [← coe_inj, coe_sum, Rat.coe_toNNRat _ (Finset.sum_nonneg hf)]
  exact Finset.sum_congr rfl fun x hxs ↦ by rw [Rat.coe_toNNRat _ (hf x hxs)]
#align nnrat.to_nnrat_sum_of_nonneg NNRat.toNNRat_sum_of_nonneg

@[norm_cast]
theorem coe_prod {s : Finset α} {f : α → ℚ≥0} : ↑(∏ a in s, f a) = ∏ a in s, (f a : ℚ) :=
  coeHom.map_prod _ _
#align nnrat.coe_prod NNRat.coe_prod

theorem toNNRat_prod_of_nonneg {s : Finset α} {f : α → ℚ} (hf : ∀ a ∈ s, 0 ≤ f a) :
    (∏ a in s, f a).toNNRat = ∏ a in s, (f a).toNNRat := by
  rw [← coe_inj, coe_prod, Rat.coe_toNNRat _ (Finset.prod_nonneg hf)]
  exact Finset.prod_congr rfl fun x hxs ↦ by rw [Rat.coe_toNNRat _ (hf x hxs)]
#align nnrat.to_nnrat_prod_of_nonneg NNRat.toNNRat_prod_of_nonneg

@[norm_cast]
theorem nsmul_coe (q : ℚ≥0) (n : ℕ) : ↑(n • q) = n • (q : ℚ) :=
  coeHom.toAddMonoidHom.map_nsmul _ _
#align nnrat.nsmul_coe NNRat.nsmul_coe

theorem bddBelow_coe (s : Set ℚ≥0) : BddBelow (((↑) : ℚ≥0 → ℚ) '' s) :=
  ⟨0, fun _ ⟨q, _, h⟩ ↦ h ▸ q.2⟩
#align nnrat.bdd_below_coe NNRat.bddBelow_coe

@[simp, norm_cast]
theorem coe_max (x y : ℚ≥0) : ((max x y : ℚ≥0) : ℚ) = max (x : ℚ) (y : ℚ) :=
  coe_mono.map_max
#align nnrat.coe_max NNRat.coe_max

@[simp, norm_cast]
theorem coe_min (x y : ℚ≥0) : ((min x y : ℚ≥0) : ℚ) = min (x : ℚ) (y : ℚ) :=
  coe_mono.map_min
#align nnrat.coe_min NNRat.coe_min

theorem sub_def (p q : ℚ≥0) : p - q = toNNRat (p - q) :=
  rfl
#align nnrat.sub_def NNRat.sub_def

@[simp]
theorem abs_coe (q : ℚ≥0) : |(q : ℚ)| = q :=
  abs_of_nonneg q.2
#align nnrat.abs_coe NNRat.abs_coe

end NNRat

open NNRat

namespace Rat

variable {p q : ℚ}

@[simp]
theorem toNNRat_zero : toNNRat 0 = 0 := rfl
#align rat.to_nnrat_zero Rat.toNNRat_zero

@[simp]
theorem toNNRat_one : toNNRat 1 = 1 := rfl
#align rat.to_nnrat_one Rat.toNNRat_one

@[simp]
theorem toNNRat_pos : 0 < toNNRat q ↔ 0 < q := by simp [toNNRat, ← coe_lt_coe]
#align rat.to_nnrat_pos Rat.toNNRat_pos

@[simp]
theorem toNNRat_eq_zero : toNNRat q = 0 ↔ q ≤ 0 := by
  simpa [-toNNRat_pos] using (@toNNRat_pos q).not
#align rat.to_nnrat_eq_zero Rat.toNNRat_eq_zero

alias toNNRat_eq_zero ↔ _ toNNRat_of_nonpos
#align rat.to_nnrat_of_nonpos Rat.toNNRat_of_nonpos

@[simp]
theorem toNNRat_le_toNNRat_iff (hp : 0 ≤ p) : toNNRat q ≤ toNNRat p ↔ q ≤ p := by
  simp [← coe_le_coe, toNNRat, hp]
#align rat.to_nnrat_le_to_nnrat_iff Rat.toNNRat_le_toNNRat_iff

@[simp]
theorem toNNRat_lt_toNNRat_iff' : toNNRat q < toNNRat p ↔ q < p ∧ 0 < p := by
  simp [← coe_lt_coe, toNNRat, lt_irrefl]
#align rat.to_nnrat_lt_to_nnrat_iff' Rat.toNNRat_lt_toNNRat_iff'

theorem toNNRat_lt_toNNRat_iff (h : 0 < p) : toNNRat q < toNNRat p ↔ q < p :=
  toNNRat_lt_toNNRat_iff'.trans (and_iff_left h)
#align rat.to_nnrat_lt_to_nnrat_iff Rat.toNNRat_lt_toNNRat_iff

theorem toNNRat_lt_toNNRat_iff_of_nonneg (hq : 0 ≤ q) : toNNRat q < toNNRat p ↔ q < p :=
  toNNRat_lt_toNNRat_iff'.trans ⟨And.left, fun h ↦ ⟨h, hq.trans_lt h⟩⟩
#align rat.to_nnrat_lt_to_nnrat_iff_of_nonneg Rat.toNNRat_lt_toNNRat_iff_of_nonneg

@[simp]
theorem toNNRat_add (hq : 0 ≤ q) (hp : 0 ≤ p) : toNNRat (q + p) = toNNRat q + toNNRat p :=
  NNRat.ext <| by simp [toNNRat, hq, hp, add_nonneg]
#align rat.to_nnrat_add Rat.toNNRat_add

theorem toNNRat_add_le : toNNRat (q + p) ≤ toNNRat q + toNNRat p :=
  coe_le_coe.1 <| max_le (add_le_add (le_max_left _ _) (le_max_left _ _)) <| coe_nonneg _
#align rat.to_nnrat_add_le Rat.toNNRat_add_le

theorem toNNRat_le_iff_le_coe {p : ℚ≥0} : toNNRat q ≤ p ↔ q ≤ ↑p :=
  NNRat.gi.gc q p
#align rat.to_nnrat_le_iff_le_coe Rat.toNNRat_le_iff_le_coe

theorem le_toNNRat_iff_coe_le {q : ℚ≥0} (hp : 0 ≤ p) : q ≤ toNNRat p ↔ ↑q ≤ p := by
  rw [← coe_le_coe, Rat.coe_toNNRat p hp]
#align rat.le_to_nnrat_iff_coe_le Rat.le_toNNRat_iff_coe_le

theorem le_toNNRat_iff_coe_le' {q : ℚ≥0} (hq : 0 < q) : q ≤ toNNRat p ↔ ↑q ≤ p :=
  (le_or_lt 0 p).elim le_toNNRat_iff_coe_le fun hp ↦ by
    simp only [(hp.trans_le q.coe_nonneg).not_le, toNNRat_eq_zero.2 hp.le, hq.not_le]
#align rat.le_to_nnrat_iff_coe_le' Rat.le_toNNRat_iff_coe_le'

theorem toNNRat_lt_iff_lt_coe {p : ℚ≥0} (hq : 0 ≤ q) : toNNRat q < p ↔ q < ↑p := by
  rw [← coe_lt_coe, Rat.coe_toNNRat q hq]
#align rat.to_nnrat_lt_iff_lt_coe Rat.toNNRat_lt_iff_lt_coe

theorem lt_toNNRat_iff_coe_lt {q : ℚ≥0} : q < toNNRat p ↔ ↑q < p :=
  NNRat.gi.gc.lt_iff_lt
#align rat.lt_to_nnrat_iff_coe_lt Rat.lt_toNNRat_iff_coe_lt

-- Porting note: `bit0` `bit1` are deprecated, so remove these theorems.
#noalign rat.to_nnrat_bit0
#noalign rat.to_nnrat_bit1

theorem toNNRat_mul (hp : 0 ≤ p) : toNNRat (p * q) = toNNRat p * toNNRat q := by
  cases' le_total 0 q with hq hq
  · ext <;> simp [toNNRat, hp, hq, max_eq_left, mul_nonneg]
  · have hpq := mul_nonpos_of_nonneg_of_nonpos hp hq
    rw [toNNRat_eq_zero.2 hq, toNNRat_eq_zero.2 hpq, mul_zero]
#align rat.to_nnrat_mul Rat.toNNRat_mul

theorem toNNRat_inv (q : ℚ) : toNNRat q⁻¹ = (toNNRat q)⁻¹ := by
  obtain hq | hq := le_total q 0
  · rw [toNNRat_eq_zero.mpr hq, inv_zero, toNNRat_eq_zero.mpr (inv_nonpos.mpr hq)]
  · nth_rw 1 [← Rat.coe_toNNRat q hq]
    rw [← coe_inv, toNNRat_coe]
#align rat.to_nnrat_inv Rat.toNNRat_inv

theorem toNNRat_div (hp : 0 ≤ p) : toNNRat (p / q) = toNNRat p / toNNRat q := by
  rw [div_eq_mul_inv, div_eq_mul_inv, ← toNNRat_inv, ← toNNRat_mul hp]
#align rat.to_nnrat_div Rat.toNNRat_div

theorem toNNRat_div' (hq : 0 ≤ q) : toNNRat (p / q) = toNNRat p / toNNRat q := by
  rw [div_eq_inv_mul, div_eq_inv_mul, toNNRat_mul (inv_nonneg.2 hq), toNNRat_inv]
#align rat.to_nnrat_div' Rat.toNNRat_div'

end Rat

/-- The absolute value on `ℚ` as a map to `ℚ≥0`. -/
--@[pp_nodot]  -- Porting note: Commented out.
def Rat.nnabs (x : ℚ) : ℚ≥0 :=
  ⟨abs x, abs_nonneg x⟩
#align rat.nnabs Rat.nnabs

@[norm_cast, simp]
theorem Rat.coe_nnabs (x : ℚ) : (Rat.nnabs x : ℚ) = abs x := rfl
#align rat.coe_nnabs Rat.coe_nnabs

/-! ### Numerator and denominator -/

namespace NNRat

variable {p q : ℚ≥0}

/-- The numerator of a nonnegative rational. -/
def num (q : ℚ≥0) : ℕ :=
  (q : ℚ).num.natAbs
#align nnrat.num NNRat.num

/-- The denominator of a nonnegative rational. -/
def den (q : ℚ≥0) : ℕ :=
  (q : ℚ).den
#align nnrat.denom NNRat.den

@[simp]
theorem natAbs_num_coe : (q : ℚ).num.natAbs = q.num :=
  rfl
#align nnrat.nat_abs_num_coe NNRat.natAbs_num_coe

@[simp]
theorem den_coe : (q : ℚ).den = q.den :=
  rfl
#align nnrat.denom_coe NNRat.den_coe

theorem ext_num_den (hn : p.num = q.num) (hd : p.den = q.den) : p = q := by
  ext
  · apply (Int.natAbs_inj_of_nonneg_of_nonneg _ _).1 hn
    exact Rat.num_nonneg_iff_zero_le.2 p.2
    exact Rat.num_nonneg_iff_zero_le.2 q.2
  · exact hd
#align nnrat.ext_num_denom NNRat.ext_num_den

theorem ext_num_den_iff : p = q ↔ p.num = q.num ∧ p.den = q.den :=
  ⟨by rintro rfl; exact ⟨rfl, rfl⟩, fun h ↦ ext_num_den h.1 h.2⟩
#align nnrat.ext_num_denom_iff NNRat.ext_num_den_iff

@[simp]
theorem num_div_den (q : ℚ≥0) : (q.num : ℚ≥0) / q.den = q := by
  ext1
  rw [coe_div, coe_natCast, coe_natCast, num, ← Int.cast_ofNat,
    Int.natAbs_of_nonneg (Rat.num_nonneg_iff_zero_le.2 q.prop)]
  exact Rat.num_div_den q
#align nnrat.num_div_denom NNRat.num_div_den

/-- A recursor for nonnegative rationals in terms of numerators and denominators. -/
protected def rec {α : ℚ≥0 → Sort _} (h : ∀ m n : ℕ, α (m / n)) (q : ℚ≥0) : α q := by
  rw [← num_div_den q]
  apply h
#align nnrat.rec NNRat.rec

end NNRat


/-
Copyright (c) 2015 Haitao Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Author : Haitao Zhang
-/
import algebra.group data data.fintype.function

open nat list function

namespace group_theory
open fintype

section perm
variables {A : Type} [fintype A] [decidable_eq A]
variable  {f : A → A}

lemma perm_surj : injective f → surjective f :=
      surj_of_inj_eq_card (eq.refl (card A))

variable (perm : injective f)

definition perm_inv : A → A :=
      right_inv (perm_surj perm)

lemma perm_inv_right : f ∘ (perm_inv perm) = id :=
      right_inv_of_surj (perm_surj perm)

lemma perm_inv_left : (perm_inv perm) ∘ f = id :=
      have H : left_inverse f (perm_inv perm), from congr_fun (perm_inv_right perm),
      funext (take x, right_inverse_of_injective_of_left_inverse perm H x)

lemma perm_inv_inj : injective (perm_inv perm) :=
      injective_of_has_left_inverse (exists.intro f (congr_fun (perm_inv_right perm)))

end perm

structure perm (A : Type) [h : fintype A] : Type :=
  (f : A → A) (inj : injective f)
local attribute perm.f [coercion]

section perm
variables {A : Type} [fintype A]

lemma eq_of_feq : ∀ {p₁ p₂ : perm A}, (perm.f p₁) = p₂ → p₁ = p₂
| (perm.mk f₁ P₁) (perm.mk f₂ P₂) := assume (feq : f₁ = f₂), by congruence; assumption

lemma feq_of_eq : ∀ {p₁ p₂ : perm A}, p₁ = p₂ → (perm.f p₁) = p₂
| (perm.mk f₁ P₁) (perm.mk f₂ P₂) := assume Peq,
  have feq : f₁ = f₂, from perm.no_confusion Peq (λ Pe Pqe, Pe), feq

lemma eq_iff_feq {p₁ p₂ : perm A} : (perm.f p₁) = p₂ ↔ p₁ = p₂ :=
iff.intro eq_of_feq feq_of_eq

lemma perm.f_mk {f : A → A} {Pinj : injective f} : perm.f (perm.mk f Pinj) = f := rfl

definition move_by [reducible] (a : A) (f : perm A) : A := f a

variable [decidable_eq A]

lemma perm.has_decidable_eq [instance] : decidable_eq (perm A) :=
      take f g,
      perm.destruct f (λ ff finj, perm.destruct g (λ gf ginj,
      decidable.rec_on (decidable_eq_fun ff gf)
      (λ Peq, decidable.inl (by substvars))
      (λ Pne, decidable.inr begin intro P, injection P, contradiction end)))

lemma dinj_perm_mk : dinj (@injective A A) perm.mk :=
      take a₁ a₂ Pa₁ Pa₂ Pmkeq, perm.no_confusion Pmkeq (λ Pe Pqe, Pe)

definition all_perms : list (perm A) :=
           dmap injective perm.mk (all_injs A)

lemma nodup_all_perms : nodup (@all_perms A _ _) :=
      dmap_nodup_of_dinj dinj_perm_mk nodup_all_injs

lemma all_perms_complete : ∀ p : perm A, p ∈ all_perms :=
      take p, perm.destruct p (take f Pinj,
        have Pin : f ∈ all_injs A, from all_injs_complete Pinj,
        mem_dmap Pinj Pin)

definition perm_is_fintype [instance] : fintype (perm A) :=
           fintype.mk all_perms nodup_all_perms all_perms_complete

definition perm.mul (f g : perm A) :=
           perm.mk (f∘g) (injective_comp (perm.inj f) (perm.inj g))
definition perm.one [reducible] : perm A := perm.mk id injective_id
definition perm.inv (f : perm A) := let inj := perm.inj f in
           perm.mk (perm_inv inj) (perm_inv_inj inj)

local infix `^` := perm.mul
lemma perm.assoc (f g h : perm A) : f ^ g ^ h = f ^ (g ^ h) := rfl
lemma perm.one_mul (p : perm A) : perm.one ^ p = p :=
      perm.cases_on p (λ f inj, rfl)
lemma perm.mul_one (p : perm A) : p ^ perm.one = p :=
      perm.cases_on p (λ f inj, rfl)
lemma perm.left_inv (p : perm A) : (perm.inv p) ^ p = perm.one :=
      begin rewrite [↑perm.one], generalize @injective_id A,
      rewrite [-perm_inv_left (perm.inj p)], intros, exact rfl
      end
lemma perm.right_inv (p : perm A) : p ^ (perm.inv p) = perm.one :=
      begin rewrite [↑perm.one], generalize @injective_id A,
      rewrite [-perm_inv_right (perm.inj p)], intros, exact rfl
      end

definition perm_group [instance] : group (perm A) :=
           group.mk perm.mul perm.assoc perm.one perm.one_mul perm.mul_one perm.inv perm.left_inv

lemma perm_one : (1 : perm A) = perm.one := rfl

end perm

end group_theory