/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Chris Hughes
-/
import algebra.associated
import algebra.big_operators.basic
import ring_theory.valuation.basic

/-!
# Multiplicity of a divisor

For a commutative monoid, this file introduces the notion of multiplicity of a divisor and proves
several basic results on it.

## Main definitions

* `multiplicity a b`: for two elements `a` and `b` of a commutative monoid returns the largest
  number `n` such that `a ^ n ∣ b` or infinity, written `⊤`, if `a ^ n ∣ b` for all natural numbers
  `n`.
* `multiplicity.finite a b`: a predicate denoting that the multiplicity of `a` in `b` is finite.
-/

variables {α : Type*}

open nat part
open_locale big_operators

/-- `multiplicity a b` returns the largest natural number `n` such that
  `a ^ n ∣ b`, as an `enat` or natural with infinity. If `∀ n, a ^ n ∣ b`,
  then it returns `⊤`-/
def multiplicity [comm_monoid α] [decidable_rel ((∣) : α → α → Prop)] (a b : α) : enat :=
enat.find $ λ n, ¬a ^ (n + 1) ∣ b

namespace multiplicity

section comm_monoid
variables [comm_monoid α]

/-- `multiplicity.finite a b` indicates that the multiplicity of `a` in `b` is finite. -/
@[reducible] def finite (a b : α) : Prop := ∃ n : ℕ, ¬a ^ (n + 1) ∣ b

lemma finite_iff_dom [decidable_rel ((∣) : α → α → Prop)] {a b : α} :
  finite a b ↔ (multiplicity a b).dom := iff.rfl

lemma finite_def {a b : α} : finite a b ↔ ∃ n : ℕ, ¬a ^ (n + 1) ∣ b := iff.rfl

@[norm_cast]
theorem int.coe_nat_multiplicity (a b : ℕ) :
    multiplicity (a : ℤ) (b : ℤ) = multiplicity a b :=
begin
  apply part.ext',
  { repeat { rw [← finite_iff_dom, finite_def] },
    norm_cast },
  { intros h1 h2,
    apply _root_.le_antisymm; { apply nat.find_mono, norm_cast, simp } }
end

lemma not_finite_iff_forall {a b : α} : (¬ finite a b) ↔ ∀ n : ℕ, a ^ n ∣ b :=
⟨λ h n, nat.cases_on n (by { rw pow_zero, exact one_dvd _ }) (by simpa [finite, not_not] using h),
  by simp [finite, multiplicity, not_not]; tauto⟩

lemma not_unit_of_finite {a b : α} (h : finite a b) : ¬is_unit a :=
let ⟨n, hn⟩ := h in mt (is_unit_iff_forall_dvd.1 ∘ is_unit.pow (n + 1)) $
λ h, hn (h b)

lemma finite_of_finite_mul_left {a b c : α} : finite a (b * c) → finite a c :=
λ ⟨n, hn⟩, ⟨n, λ h, hn (h.trans (by simp [mul_pow]))⟩

lemma finite_of_finite_mul_right {a b c : α} : finite a (b * c) → finite a b :=
by rw mul_comm; exact finite_of_finite_mul_left

variable [decidable_rel ((∣) : α → α → Prop)]

lemma pow_dvd_of_le_multiplicity {a b : α} {k : ℕ} : (k : enat) ≤ multiplicity a b → a ^ k ∣ b :=
by { rw ← enat.some_eq_coe, exact
nat.cases_on k (λ _, by { rw pow_zero, exact one_dvd _ })
  (λ k ⟨h₁, h₂⟩, by_contradiction (λ hk, (nat.find_min _ (lt_of_succ_le (h₂ ⟨k, hk⟩)) hk))) }

lemma pow_multiplicity_dvd {a b : α} (h : finite a b) : a ^ get (multiplicity a b) h ∣ b :=
pow_dvd_of_le_multiplicity (by rw enat.coe_get)

lemma is_greatest  {a b : α} {m : ℕ} (hm : multiplicity a b < m) : ¬a ^ m ∣ b :=
λ h, by rw [enat.lt_coe_iff] at hm; exact nat.find_spec hm.fst ((pow_dvd_pow _ hm.snd).trans h)

lemma is_greatest' {a b : α} {m : ℕ} (h : finite a b) (hm : get (multiplicity a b) h < m) :
  ¬a ^ m ∣ b :=
is_greatest (by rwa [← enat.coe_lt_coe, enat.coe_get] at hm)

lemma unique {a b : α} {k : ℕ} (hk : a ^ k ∣ b) (hsucc : ¬a ^ (k + 1) ∣ b) :
  (k : enat) = multiplicity a b :=
le_antisymm (le_of_not_gt (λ hk', is_greatest hk' hk)) $
  have finite a b, from ⟨k, hsucc⟩,
  by { rw [enat.le_coe_iff], exact ⟨this, nat.find_min' _ hsucc⟩ }

lemma unique' {a b : α} {k : ℕ} (hk : a ^ k ∣ b) (hsucc : ¬ a ^ (k + 1) ∣ b) :
  k = get (multiplicity a b) ⟨k, hsucc⟩ :=
by rw [← enat.coe_inj, enat.coe_get, unique hk hsucc]

lemma pow_dvd_iff_le_multiplicity {a b : α}
  {k : ℕ} : a ^ k ∣ b ↔ (k : enat) ≤ multiplicity a b :=
⟨le_multiplicity_of_pow_dvd, pow_dvd_of_le_multiplicity⟩

lemma multiplicity_lt_iff_neg_dvd {a b : α} {k : ℕ} :
  multiplicity a b < (k : enat) ↔ ¬ a ^ k ∣ b :=
by { rw [pow_dvd_iff_le_multiplicity, not_le] }

lemma eq_coe_iff {a b : α} {n : ℕ} :
  multiplicity a b = (n : enat) ↔ a ^ n ∣ b ∧ ¬a ^ (n + 1) ∣ b :=
begin
  rw [← enat.some_eq_coe],
  exact ⟨λ h, let ⟨h₁, h₂⟩ := eq_some_iff.1 h in
      h₂ ▸ ⟨pow_multiplicity_dvd _, is_greatest
        (by { rw [enat.lt_coe_iff], exact ⟨h₁, lt_succ_self _⟩ })⟩,
    λ h, eq_some_iff.2 ⟨⟨n, h.2⟩, eq.symm $ unique' h.1 h.2⟩⟩
end

lemma eq_top_iff {a b : α} :
  multiplicity a b = ⊤ ↔ ∀ n : ℕ, a ^ n ∣ b :=
(enat.find_eq_top_iff _).trans $
by { simp only [not_not],
     exact ⟨λ h n, nat.cases_on n (by { rw pow_zero, exact one_dvd _}) (λ n, h _), λ h n, h _⟩ }

@[simp] lemma is_unit_left {a : α} (b : α) (ha : is_unit a) : multiplicity a b = ⊤ :=
eq_top_iff.2 (λ _, is_unit_iff_forall_dvd.1 (ha.pow _) _)

lemma is_unit_right {a b : α} (ha : ¬is_unit a) (hb : is_unit b) :
  multiplicity a b = 0 :=
eq_coe_iff.2 ⟨show a ^ 0 ∣ b, by simp only [pow_zero, one_dvd],
  by { rw pow_one, exact λ h, mt (is_unit_of_dvd_unit h) ha hb }⟩

@[simp] lemma one_left (b : α) : multiplicity 1 b = ⊤ := is_unit_left b is_unit_one

lemma one_right {a : α} (ha : ¬is_unit a) : multiplicity a 1 = 0 := is_unit_right ha is_unit_one

@[simp] lemma get_one_right {a : α} (ha : finite a 1) : get (multiplicity a 1) ha = 0 :=
begin
  rw [enat.get_eq_iff_eq_coe, eq_coe_iff, pow_zero],
  simpa [is_unit_iff_dvd_one.symm] using not_unit_of_finite ha,
end

@[simp] lemma unit_left (a : α) (u : units α) : multiplicity (u : α) a = ⊤ :=
is_unit_left a u.is_unit

lemma unit_right {a : α} (ha : ¬is_unit a) (u : units α) : multiplicity a u = 0 :=
is_unit_right ha u.is_unit

lemma multiplicity_eq_zero_of_not_dvd {a b : α} (ha : ¬a ∣ b) : multiplicity a b = 0 :=
by { rw [← nat.cast_zero, eq_coe_iff], simpa }

lemma eq_top_iff_not_finite {a b : α} : multiplicity a b = ⊤ ↔ ¬ finite a b :=
part.eq_none_iff'

lemma ne_top_iff_finite {a b : α} : multiplicity a b ≠ ⊤ ↔ finite a b :=
by rw [ne.def, eq_top_iff_not_finite, not_not]

lemma lt_top_iff_finite {a b : α} : multiplicity a b < ⊤ ↔ finite a b :=
by rw [lt_top_iff_ne_top, ne_top_iff_finite]

open_locale classical

lemma multiplicity_le_multiplicity_iff {a b c d : α} : multiplicity a b ≤ multiplicity c d ↔
  (∀ n : ℕ, a ^ n ∣ b → c ^ n ∣ d) :=
⟨λ h n hab, (pow_dvd_of_le_multiplicity (le_trans (le_multiplicity_of_pow_dvd hab) h)),
  λ h, if hab : finite a b
    then by rw [← enat.coe_get (finite_iff_dom.1 hab)];
      exact le_multiplicity_of_pow_dvd (h _ (pow_multiplicity_dvd _))
    else
    have ∀ n : ℕ, c ^ n ∣ d, from λ n, h n (not_finite_iff_forall.1 hab _),
    by rw [eq_top_iff_not_finite.2 hab, eq_top_iff_not_finite.2
      (not_finite_iff_forall.2 this)]⟩

lemma multiplicity_le_multiplicity_of_dvd_left {a b c : α} (hdvd : a ∣ b) :
  multiplicity b c ≤ multiplicity a c :=
multiplicity_le_multiplicity_iff.2 $ λ n h, (pow_dvd_pow_of_dvd hdvd n).trans h

lemma eq_of_associated_left {a b c : α} (h : associated a b) :
  multiplicity b c = multiplicity a c :=
le_antisymm (multiplicity_le_multiplicity_of_dvd_left h.dvd)
  (multiplicity_le_multiplicity_of_dvd_left h.symm.dvd)

lemma multiplicity_le_multiplicity_of_dvd_right {a b c : α} (h : b ∣ c) :
  multiplicity a b ≤ multiplicity a c :=
multiplicity_le_multiplicity_iff.2 $ λ n hb, hb.trans h

lemma eq_of_associated_right {a b c : α} (h : associated b c) :
  multiplicity a b = multiplicity a c :=
le_antisymm (multiplicity_le_multiplicity_of_dvd_right h.dvd)
  (multiplicity_le_multiplicity_of_dvd_right h.symm.dvd)

lemma dvd_of_multiplicity_pos {a b : α} (h : (0 : enat) < multiplicity a b) : a ∣ b :=
begin
  rw ← pow_one a,
  apply pow_dvd_of_le_multiplicity,
  simpa only [nat.cast_one, enat.pos_iff_one_le] using h
end

lemma dvd_iff_multiplicity_pos {a b : α} : (0 : enat) < multiplicity a b ↔ a ∣ b :=
⟨dvd_of_multiplicity_pos,
  λ hdvd, lt_of_le_of_ne (zero_le _) (λ heq, is_greatest
    (show multiplicity a b < ↑1,
      by simpa only [heq, nat.cast_zero] using enat.coe_lt_coe.mpr zero_lt_one)
    (by rwa pow_one a))⟩

lemma finite_nat_iff {a b : ℕ} : finite a b ↔ (a ≠ 1 ∧ 0 < b) :=
begin
  rw [← not_iff_not, not_finite_iff_forall, not_and_distrib, ne.def,
    not_not, not_lt, nat.le_zero_iff],
  exact ⟨λ h, or_iff_not_imp_right.2 (λ hb,
    have ha : a ≠ 0, from λ ha, by simpa [ha] using h 1,
    by_contradiction (λ ha1 : a ≠ 1,
      have ha_gt_one : 1 < a, from
        lt_of_not_ge (λ ha', by { clear h, revert ha ha1, dec_trivial! }),
      not_lt_of_ge (le_of_dvd (nat.pos_of_ne_zero hb) (h b))
          (lt_pow_self ha_gt_one b))),
    λ h, by cases h; simp *⟩
end

end comm_monoid

section comm_monoid_with_zero

variable [comm_monoid_with_zero α]

lemma ne_zero_of_finite {a b : α} (h : finite a b) : b ≠ 0 :=
let ⟨n, hn⟩ := h in λ hb, by simpa [hb] using hn

variable [decidable_rel ((∣) : α → α → Prop)]

@[simp] protected lemma zero (a : α) : multiplicity a 0 = ⊤ :=
part.eq_none_iff.2 (λ n ⟨⟨k, hk⟩, _⟩, hk (dvd_zero _))

@[simp] lemma multiplicity_zero_eq_zero_of_ne_zero (a : α) (ha : a ≠ 0) : multiplicity 0 a = 0 :=
begin
  apply multiplicity.multiplicity_eq_zero_of_not_dvd,
  rwa zero_dvd_iff,
end

end comm_monoid_with_zero

section comm_semiring

variables [comm_semiring α] [decidable_rel ((∣) : α → α → Prop)]

lemma min_le_multiplicity_add {p a b : α} :
  min (multiplicity p a) (multiplicity p b) ≤ multiplicity p (a + b) :=
(le_total (multiplicity p a) (multiplicity p b)).elim
  (λ h, by rw [min_eq_left h, multiplicity_le_multiplicity_iff];
    exact λ n hn, dvd_add hn (multiplicity_le_multiplicity_iff.1 h n hn))
  (λ h, by rw [min_eq_right h, multiplicity_le_multiplicity_iff];
    exact λ n hn, dvd_add (multiplicity_le_multiplicity_iff.1 h n hn) hn)

end comm_semiring

section comm_ring

variables [comm_ring α] [decidable_rel ((∣) : α → α → Prop)]

open_locale classical

@[simp] protected lemma neg (a b : α) : multiplicity a (-b) = multiplicity a b :=
part.ext' (by simp only [multiplicity, enat.find, dvd_neg])
  (λ h₁ h₂, enat.coe_inj.1 (by rw [enat.coe_get]; exact
    eq.symm (unique ((dvd_neg _ _).2 (pow_multiplicity_dvd _))
      (mt (dvd_neg _ _).1 (is_greatest' _ (lt_succ_self _))))))

lemma multiplicity_add_of_gt {p a b : α} (h : multiplicity p b < multiplicity p a) :
  multiplicity p (a + b) = multiplicity p b :=
begin
  apply le_antisymm,
  { apply enat.le_of_lt_add_one,
    cases enat.ne_top_iff.mp (enat.ne_top_of_lt h) with k hk,
    rw [hk], rw_mod_cast [multiplicity_lt_iff_neg_dvd], intro h_dvd,
    rw [← dvd_add_iff_right] at h_dvd,
    apply multiplicity.is_greatest _ h_dvd, rw [hk], apply_mod_cast nat.lt_succ_self,
    rw [pow_dvd_iff_le_multiplicity, nat.cast_add, ← hk, nat.cast_one],
    exact enat.add_one_le_of_lt h },
  { convert min_le_multiplicity_add, rw [min_eq_right (le_of_lt h)] }
end

lemma multiplicity_sub_of_gt {p a b : α} (h : multiplicity p b < multiplicity p a) :
  multiplicity p (a - b) = multiplicity p b :=
by { rw [sub_eq_add_neg, multiplicity_add_of_gt]; rwa [multiplicity.neg] }

lemma multiplicity_add_eq_min {p a b : α} (h : multiplicity p a ≠ multiplicity p b) :
  multiplicity p (a + b) = min (multiplicity p a) (multiplicity p b) :=
begin
  rcases lt_trichotomy (multiplicity p a) (multiplicity p b) with hab|hab|hab,
  { rw [add_comm, multiplicity_add_of_gt hab, min_eq_left], exact le_of_lt hab },
  { contradiction },
  { rw [multiplicity_add_of_gt hab, min_eq_right], exact le_of_lt hab},
end

end comm_ring

section comm_cancel_monoid_with_zero

variables [comm_cancel_monoid_with_zero α]

lemma finite_mul_aux {p : α} (hp : prime p) : ∀ {n m : ℕ} {a b : α},
  ¬p ^ (n + 1) ∣ a → ¬p ^ (m + 1) ∣ b → ¬p ^ (n + m + 1) ∣ a * b
| n m := λ a b ha hb ⟨s, hs⟩,
  have p ∣ a * b, from ⟨p ^ (n + m) * s,
    by simp [hs, pow_add, mul_comm, mul_assoc, mul_left_comm]⟩,
  (hp.2.2 a b this).elim
    (λ ⟨x, hx⟩, have hn0 : 0 < n,
        from nat.pos_of_ne_zero (λ hn0, by clear _fun_match _fun_match; simpa [hx, hn0] using ha),
      have wf : (n - 1) < n, from tsub_lt_self hn0 dec_trivial,
      have hpx : ¬ p ^ (n - 1 + 1) ∣ x,
        from λ ⟨y, hy⟩, ha (hx.symm ▸ ⟨y, mul_right_cancel₀ hp.1
          $ by rw [tsub_add_cancel_of_le (succ_le_of_lt hn0)] at hy;
            simp [hy, pow_add, mul_comm, mul_assoc, mul_left_comm]⟩),
      have 1 ≤ n + m, from le_trans hn0 (nat.le_add_right n m),
      finite_mul_aux hpx hb ⟨s, mul_right_cancel₀ hp.1 begin
          rw [tsub_add_eq_add_tsub (succ_le_of_lt hn0), tsub_add_cancel_of_le this],
          clear _fun_match _fun_match finite_mul_aux,
          simp [*, mul_comm, mul_assoc, mul_left_comm, pow_add] at *
        end⟩)
    (λ ⟨x, hx⟩, have hm0 : 0 < m,
        from nat.pos_of_ne_zero (λ hm0, by clear _fun_match _fun_match; simpa [hx, hm0] using hb),
      have wf : (m - 1) < m, from tsub_lt_self hm0 dec_trivial,
      have hpx : ¬ p ^ (m - 1 + 1) ∣ x,
        from λ ⟨y, hy⟩, hb (hx.symm ▸ ⟨y, mul_right_cancel₀ hp.1
          $ by rw [tsub_add_cancel_of_le (succ_le_of_lt hm0)] at hy;
            simp [hy, pow_add, mul_comm, mul_assoc, mul_left_comm]⟩),
      finite_mul_aux ha hpx ⟨s, mul_right_cancel₀ hp.1 begin
          rw [add_assoc, tsub_add_cancel_of_le (succ_le_of_lt hm0)],
          clear _fun_match _fun_match finite_mul_aux,
          simp [*, mul_comm, mul_assoc, mul_left_comm, pow_add] at *
        end⟩)

lemma finite_mul {p a b : α} (hp : prime p) : finite p a → finite p b → finite p (a * b) :=
λ ⟨n, hn⟩ ⟨m, hm⟩, ⟨n + m, finite_mul_aux hp hn hm⟩

lemma finite_mul_iff {p a b : α} (hp : prime p) : finite p (a * b) ↔ finite p a ∧ finite p b :=
⟨λ h, ⟨finite_of_finite_mul_right h, finite_of_finite_mul_left h⟩,
  λ h, finite_mul hp h.1 h.2⟩

lemma finite_pow {p a : α} (hp : prime p) : Π {k : ℕ} (ha : finite p a), finite p (a ^ k)
| 0     ha := ⟨0, by simp [mt is_unit_iff_dvd_one.2 hp.2.1]⟩
| (k+1) ha := by rw [pow_succ]; exact finite_mul hp ha (finite_pow ha)

variable [decidable_rel ((∣) : α → α → Prop)]

@[simp] lemma multiplicity_self {a : α} (ha : ¬is_unit a) (ha0 : a ≠ 0) :
  multiplicity a a = 1 :=
by { rw ← nat.cast_one, exact
eq_coe_iff.2 ⟨by simp, λ ⟨b, hb⟩, ha (is_unit_iff_dvd_one.2
  ⟨b, mul_left_cancel₀ ha0 $ by { clear _fun_match,
    simpa [pow_succ, mul_assoc] using hb }⟩)⟩ }

@[simp] lemma get_multiplicity_self {a : α} (ha : finite a a) :
  get (multiplicity a a) ha = 1 :=
enat.get_eq_iff_eq_coe.2 (eq_coe_iff.2
  ⟨by simp, λ ⟨b, hb⟩,
    by rw [← mul_one a, pow_add, pow_one, mul_assoc, mul_assoc,
        mul_right_inj' (ne_zero_of_finite ha)] at hb;
      exact mt is_unit_iff_dvd_one.2 (not_unit_of_finite ha)
        ⟨b, by clear _fun_match; simp * at *⟩⟩)

protected lemma mul' {p a b : α} (hp : prime p)
  (h : (multiplicity p (a * b)).dom) :
  get (multiplicity p (a * b)) h =
  get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
  get (multiplicity p b) ((finite_mul_iff hp).1 h).2 :=
have hdiva : p ^ get (multiplicity p a) ((finite_mul_iff hp).1 h).1 ∣ a,
  from pow_multiplicity_dvd _,
have hdivb : p ^ get (multiplicity p b) ((finite_mul_iff hp).1 h).2 ∣ b,
  from pow_multiplicity_dvd _,
have hpoweq : p ^ (get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
    get (multiplicity p b) ((finite_mul_iff hp).1 h).2) =
    p ^ get (multiplicity p a) ((finite_mul_iff hp).1 h).1 *
    p ^ get (multiplicity p b) ((finite_mul_iff hp).1 h).2,
  by simp [pow_add],
have hdiv : p ^ (get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
    get (multiplicity p b) ((finite_mul_iff hp).1 h).2) ∣ a * b,
  by rw [hpoweq]; apply mul_dvd_mul; assumption,
have hsucc : ¬p ^ ((get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
    get (multiplicity p b) ((finite_mul_iff hp).1 h).2) + 1) ∣ a * b,
  from λ h, by exact
    not_or (is_greatest' _ (lt_succ_self _)) (is_greatest' _ (lt_succ_self _))
      (_root_.succ_dvd_or_succ_dvd_of_succ_sum_dvd_mul hp hdiva hdivb h),
by rw [← enat.coe_inj, enat.coe_get, eq_coe_iff];
  exact ⟨hdiv, hsucc⟩

open_locale classical

protected lemma mul {p a b : α} (hp : prime p) :
  multiplicity p (a * b) = multiplicity p a + multiplicity p b :=
if h : finite p a ∧ finite p b then
by rw [← enat.coe_get (finite_iff_dom.1 h.1), ← enat.coe_get (finite_iff_dom.1 h.2),
  ← enat.coe_get (finite_iff_dom.1 (finite_mul hp h.1 h.2)),
    ← nat.cast_add, enat.coe_inj, multiplicity.mul' hp]; refl
else begin
  rw [eq_top_iff_not_finite.2 (mt (finite_mul_iff hp).1 h)],
  cases not_and_distrib.1 h with h h;
    simp [eq_top_iff_not_finite.2 h]
end

lemma finset.prod {β : Type*} {p : α} (hp : prime p) (s : finset β) (f : β → α) :
  multiplicity p (∏ x in s, f x) = ∑ x in s, multiplicity p (f x) :=
begin
  classical,
  induction s using finset.induction with a s has ih h,
  { simp only [finset.sum_empty, finset.prod_empty],
    convert one_right hp.not_unit },
  { simp [has, ← ih],
    convert multiplicity.mul hp }
end

protected lemma pow' {p a : α} (hp : prime p) (ha : finite p a) : ∀ {k : ℕ},
  get (multiplicity p (a ^ k)) (finite_pow hp ha) = k * get (multiplicity p a) ha
| 0     := by simp [one_right hp.not_unit]
| (k+1) := have multiplicity p (a ^ (k + 1)) = multiplicity p (a * a ^ k), by rw pow_succ,
    by rw [get_eq_get_of_eq _ _ this, multiplicity.mul' hp, pow', add_mul, one_mul, add_comm]

lemma pow {p a : α} (hp : prime p) : ∀ {k : ℕ},
  multiplicity p (a ^ k) = k • (multiplicity p a)
| 0        := by simp [one_right hp.not_unit]
| (succ k) := by simp [pow_succ, succ_nsmul, pow, multiplicity.mul hp]

lemma multiplicity_pow_self {p : α} (h0 : p ≠ 0) (hu : ¬ is_unit p) (n : ℕ) :
  multiplicity p (p ^ n) = n :=
by { rw [eq_coe_iff], use dvd_rfl, rw [pow_dvd_pow_iff h0 hu], apply nat.not_succ_le_self }

lemma multiplicity_pow_self_of_prime {p : α} (hp : prime p) (n : ℕ) :
  multiplicity p (p ^ n) = n :=
multiplicity_pow_self hp.ne_zero hp.not_unit n

end comm_cancel_monoid_with_zero

section valuation

variables {R : Type*} [comm_ring R] [is_domain R] {p : R}
  [decidable_rel (has_dvd.dvd : R → R → Prop)]

/-- `multiplicity` of a prime inan integral domain as an additive valuation to `enat`. -/
noncomputable def add_valuation (hp : prime p) : add_valuation R enat :=
add_valuation.of (multiplicity p) (multiplicity.zero _) (one_right hp.not_unit)
  (λ _ _, min_le_multiplicity_add) (λ a b, multiplicity.mul hp)

@[simp]
lemma add_valuation_apply {hp : prime p} {r : R} : add_valuation hp r = multiplicity p r := rfl

end valuation

end multiplicity

section nat
open multiplicity

lemma multiplicity_eq_zero_of_coprime {p a b : ℕ} (hp : p ≠ 1)
  (hle : multiplicity p a ≤ multiplicity p b)
  (hab : nat.coprime a b) : multiplicity p a = 0 :=
begin
  rw [multiplicity_le_multiplicity_iff] at hle,
  rw [← nonpos_iff_eq_zero, ← not_lt, enat.pos_iff_one_le, ← nat.cast_one,
    ← pow_dvd_iff_le_multiplicity],
  assume h,
  have := nat.dvd_gcd h (hle _ h),
  rw [coprime.gcd_eq_one hab, nat.dvd_one, pow_one] at this,
  exact hp this
end

end nat


/-
Copyright (c) 2021 Eric Rodriguez. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Rodriguez
-/
import algebra.algebra.basic
import algebra.char_p.basic

/-!
# `ne_zero` typeclass

We create a typeclass `ne_zero n` which carries around the fact that `(n : R) ≠ 0`.

## Main declarations

* `ne_zero`: `n ≠ 0` as a typeclass.

-/

/-- A type-class version of `n ≠ 0`.  -/
class ne_zero {R} [has_zero R] (n : R) : Prop := (out : n ≠ 0)

lemma ne_zero.ne {R} [has_zero R] (n : R) [h : ne_zero n] : n ≠ 0 := h.out

lemma ne_zero.ne' (n : ℕ) (R) [add_monoid_with_one R] [h : ne_zero (n : R)] :
  (n : R) ≠ 0 := h.out

lemma ne_zero_iff {R : Type*} [has_zero R] {n : R} : ne_zero n ↔ n ≠ 0 :=
⟨λ h, h.out, ne_zero.mk⟩

lemma not_ne_zero {R : Type*} [has_zero R] {n : R} : ¬ ne_zero n ↔ n = 0 :=
by simp [ne_zero_iff]

namespace ne_zero

variables {R S M F : Type*} {r : R} {x y : M} {n p : ℕ} {a : ℕ+}

instance pnat : ne_zero (a : ℕ) := ⟨a.ne_zero⟩
instance succ : ne_zero (n + 1) := ⟨n.succ_ne_zero⟩

instance char_zero [ne_zero n] [add_monoid_with_one M] [char_zero M] : ne_zero (n : M) :=
⟨nat.cast_ne_zero.mpr $ ne_zero.ne n⟩

@[priority 100] instance invertible [mul_zero_one_class M] [nontrivial M] [invertible x] :
  ne_zero x := ⟨nonzero_of_invertible x⟩

instance coe_trans [has_zero M] [has_coe R S] [has_coe_t S M] [h : ne_zero (r : M)] :
  ne_zero ((r : S) : M) := ⟨h.out⟩

lemma trans [has_zero M] [has_coe R S] [has_coe_t S M] (h : ne_zero ((r : S) : M)) :
  ne_zero (r : M) := ⟨h.out⟩

lemma of_map [has_zero R] [has_zero M] [zero_hom_class F R M] (f : F) [ne_zero (f r)] :
  ne_zero r := ⟨λ h, ne (f r) $ by convert map_zero f⟩

lemma nat_of_ne_zero [semiring R] [semiring S] [ring_hom_class F R S] (f : F)
  [hn : ne_zero (n : S)] : ne_zero (n : R) :=
begin
  apply ne_zero.of_map f,
  simp [hn]
end

lemma of_injective [has_zero R] [h : ne_zero r] [has_zero M] [zero_hom_class F R M]
  {f : F} (hf : function.injective f) : ne_zero (f r) :=
⟨by { rw ←map_zero f, exact hf.ne (ne r) }⟩

lemma nat_of_injective [non_assoc_semiring M] [non_assoc_semiring R] [h : ne_zero (n : R)]
  [ring_hom_class F R M] {f : F} (hf : function.injective f) : ne_zero (n : M) :=
 ⟨λ h, (ne_zero.ne' n R) $ hf $ by simpa⟩

lemma pos (r : R) [canonically_ordered_add_monoid R] [ne_zero r] : 0 < r :=
(zero_le r).lt_of_ne $ ne_zero.out.symm

variables (R M)

lemma of_not_dvd [add_monoid_with_one M] [char_p M p] (h : ¬ p ∣ n) : ne_zero (n : M) :=
⟨(not_iff_not.mpr $ char_p.cast_eq_zero_iff M p n).mpr h⟩

lemma of_no_zero_smul_divisors (n : ℕ) [comm_ring R] [ne_zero (n : R)] [ring M] [nontrivial M]
  [algebra R M] [no_zero_smul_divisors R M] : ne_zero (n : M) :=
nat_of_injective $ no_zero_smul_divisors.algebra_map_injective R M

lemma of_ne_zero_coe [add_monoid_with_one R] [h : ne_zero (n : R)] : ne_zero n :=
⟨by {casesI h, rintro rfl, by simpa using h}⟩

lemma not_char_dvd [add_monoid_with_one R] (p : ℕ) [char_p R p] (k : ℕ) [h : ne_zero (k : R)] :
  ¬ p ∣ k :=
by rwa [←not_iff_not.mpr $ char_p.cast_eq_zero_iff R p k, ←ne.def, ←ne_zero_iff]

lemma pos_of_ne_zero_coe [add_monoid_with_one R] [ne_zero (n : R)] : 0 < n :=
(ne_zero.of_ne_zero_coe R).out.bot_lt

end ne_zero

lemma eq_zero_or_ne_zero {α} [has_zero α] (a : α) : a = 0 ∨ ne_zero a :=
(eq_or_ne a 0).imp_right ne_zero.mk


import category_theory.category.default
import category_theory.functor
import category_theory.isomorphism

universes v₁ v₂ u₁ u₂  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

variables (C : Type u₁) [category.{v₁} C]
variables (D : Type u₂) [category.{v₂} D]

/-
# Functor world

## Level 1: Definition of functor

A functor `F : C ⥤ D` between categories `C` and `D` consists of
  * an object `F.obj X ∈ D` for all objects `X ∈ C`
  * a morphism `Ff : F.obj X ⟶ F.obj Y` for each morphism `f : X ⟶ Y`, where the domain and codomain of `Ff` are, respectively, equal to `F` applied to the domain and codomain of `f`.
The assignments are required to satisfy the following two functoriality axioms:
  * for any composable pair of morphisms `f, g` in `C`, `F.map f ≫ F.map g = F.map (f ≫ g)`.
  * for each object `X` in `C`, `F.map (𝟙 X) : 𝟙 (F.obj X)`.
In other words, a functor consists of a mapping on objects and a mapping on morphisms that preserves all of the structure of a category, namely domains and codomains, composition, and identities.
  -/

  /- Axiom :
    F.map f ≫ F.map g = F.map (f ≫ g)-/
  /- Axiom:
    F.map (𝟙 X) : 𝟙 (F.obj X)-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are monomorphisms, then $$f ≫ g : X ⟶ Z$$ is a monomorphism.
-/
lemma map_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [epi (f ≫ g)] : epi g :=
begin
    split,
    intros W h l hyp,
    rw ← cancel_epi (f ≫ g),
    rw category.assoc,
    rw hyp,
    rw ← category.assoc,
end

end category_theory


import SciLean.Core.Differential
import SciLean.Core.IsSmoothDep

namespace SciLean

variable {X Y Z W Y₁ Y₂ Y₃} [Diff X] [Diff Y] [Diff Z] [Diff W] [Diff Y₁] [Diff Y₂] [Diff Y₃]
  {α β γ : Type}

noncomputable
def differentialDep (f : X → Y) : (x : X) → 𝒯[x] X → 𝒯[f x] Y := sorry

noncomputable
def tangentMapDep (f : X → Y) : 𝒯 X → 𝒯 Y := λ ⟨x,dx⟩ => ⟨f x, differentialDep f x dx⟩

noncomputable
def tangentMapDep' (f : X → Y) (x : X) (dx : 𝒯[x] X) : (Σ' (y:Y) (_:𝒯[y] Y), (f x=y)) := ⟨f x, differentialDep f x dx, rfl⟩

instance(priority:=mid-1) (f : X → Y) : Partial f (differentialDep f) := ⟨⟩
instance(priority:=mid-1) (f : X → Y) : TangentMap f (tangentMapDep' f) := ⟨⟩

@[simp ↓, diff]
theorem differentialDep.of_id
  : ∂ (λ x : X => x) = λ x dx => dx := sorry_proof

@[simp ↓, diff]
theorem differentialDep.of_const (x : X)
  : ∂ (λ y : Y => x) = λ y dy => 0 := sorry_proof

@[simp ↓ low-3, diff low-3]
theorem differentialDep.of_swap (f : α → X → Y) [∀ i, IsSmoothDepT (f i)]
  : ∂ (λ x a => f a x) = λ x dx a => ∂ (f a) x dx := sorry_proof

@[simp ↓ low-1, diff low-1]
theorem differentialDep.of_comp
  (f : Y → Z) [IsSmoothDepT f]
  (g : X → Y) [IsSmoothDepT g]
  : ∂ (λ x => f (g x))
    =
    λ x dx =>
      -- option 1:
      let ⟨y,dy,h⟩ := 𝒯 g x dx
      h ▸ ∂ f y dy
      -- option 2:
      -- let y := g x
      -- let dy := ∂ g x dx
      -- have h : y = g x := by admit
      -- h ▸ ∂ f y dy
      -- option 3:
      -- ∂ f (g x) (∂ g x dx)
  := sorry_proof

@[simp ↓ low-2, diff low-2]
theorem differentialDep.of_diag
  (f : Y₁ → Y₂ → Z) [IsSmoothDepNT 2 f]
  (g₁ : X → Y₁) [IsSmoothDepT g₁]
  (g₂ : X → Y₂) [IsSmoothDepT g₂]
  : ∂ (λ x => f (g₁ x) (g₂ x))
    =
    λ x dx =>
      let ⟨y₁,dy₁,h₁⟩ := 𝒯 g₁ x dx
      let ⟨y₂,dy₂,h₂⟩ := 𝒯 g₂ x dx
      -- let y₁ := g₁ x
      -- let dy₁ := ∂ g₁ x dx
      -- let y₂ := g₂ x
      -- let dy₂ := ∂ g₂ x dx
      h₁ ▸ h₂ ▸ (∂ f y₁ dy₁ y₂ + ∂ (f y₁) y₂ dy₂)
  := sorry_proof

@[simp ↓ low-5, diff low-5]
theorem differentialDep.of_uncurryN (f : Y₁ → Y₂ → Z) [IsSmoothDepNT 2 f]
  : ∂ (uncurryN 2 f)
    =
    λ (y₁,y₂) (dy₁,dy₂) =>
    ∂ f y₁ dy₁ y₂ + ∂ (f y₁) y₂ dy₂
  := by admit

@[simp ↓ low, diff low]
theorem differentialDep.of_parm
  (f : X → α → Y) [IsSmoothDepT f] (a : α)
  : ∂ (λ x => f x a) = λ x dx => ∂ f x dx a :=
by
  rw[differentialDep.of_swap (λ a x => f x a)]

@[simp ↓, diff]
theorem differentialDep.of_eval
  (a : α)
  : ∂ (λ f : α → Y => f a) = λ _ df => df a := by simp

@[simp ↓, diff]
theorem Prod.fst.arg_xy.diffDep_simp
  : ∂ (Prod.fst : X×Y → X)
    =
    λ xy dxy => dxy.1
  := sorry_proof

@[simp ↓, diff]
theorem Prod.snd.arg_xy.diffDep_simp
  : ∂ (Prod.snd : X×Y → Y)
    =
    λ xy dxy => dxy.2
  := sorry_proof

--------------------------------------------------------------------------------
-- Tangent Map Rules --
--------------------------------------------------------------------------------

@[simp ↓, diff]
theorem tangentMapDep.of_id
  : 𝒯 (λ x : X => x) = λ x dx => ⟨x,dx,rfl⟩
  := by simp[tangentMapDep']; done

@[simp ↓, diff]
theorem tangentMapDep.of_const (x : X)
  : 𝒯 (λ y : Y => x) = λ y dy => ⟨x,0,rfl⟩
  := by simp[tangentMapDep']; done

@[simp ↓ low-3, diff low-3]
theorem tangentMapDep.of_swap (f : α → X → Y) [∀ i, IsSmoothDepT (f i)]
  : 𝒯 (λ x a => f a x) = λ x dx => ⟨λ a => f a x, λ a => ∂ (f a) x dx, rfl⟩
  := by simp[tangentMapDep']; done

@[simp ↓ low-1, diff low-1]
theorem tangentMapDep.of_comp
  (f : Y → Z) [IsSmoothDepT f]
  (g : X → Y) [IsSmoothDepT g]
  : 𝒯 (λ x => f (g x))
    =
    λ x dx =>
      let ⟨y,dy,h⟩ := 𝒯 g x dx
      h ▸ 𝒯 f y dy
  := by simp[tangentMapDep']; done

@[simp ↓ low-2, diff low-2]
theorem tangentMapDep.of_diag
  (f : Y₁ → Y₂ → Z) [IsSmoothDepNT 2 f]
  (g₁ : X → Y₁) [IsSmoothDepT g₁]
  (g₂ : X → Y₂) [IsSmoothDepT g₂]
  : 𝒯 (λ x => f (g₁ x) (g₂ x))
    =
    λ x dx =>
      let ⟨y₁,dy₁,h₁⟩ := 𝒯 g₁ x dx
      let ⟨y₂,dy₂,h₂⟩ := 𝒯 g₂ x dx
      -- (f y₁ y₂, ∂ f y₁ dy₁ y₂ + ∂ (f y₁) y₂ dy₂)
      h₁ ▸ h₂ ▸ 𝒯 (uncurryN 2 f) (y₁,y₂) (dy₁,dy₂)
  := by
    funext x dx
    simp[tangentMapDep']
    done

/-- Last resort theorem that changes tangent map to normal differential

Bilinear maps should usually provide a rewrite rule for `𝒯 (uncurryN 2 f)`
-/
@[simp ↓ low-5, diff low-5]
theorem tangentMapDep.of_uncurryN (f : Y₁ → Y₂ → Z) [IsSmoothDepNT 2 f]
  : 𝒯 (uncurryN 2 f)
    =
    λ  (y₁,y₂) (dy₁,dy₂) =>
    ⟨f y₁ y₂, ∂ f y₁ dy₁ y₂ + ∂ (f y₁) y₂ dy₂, rfl⟩
  := by
    simp[tangentMapDep']
    done

@[simp ↓ low, diff low]
theorem tangentMapDep.of_parm
  (f : X → α → Y) [IsSmoothDepT f] (a : α)
  : 𝒯 (λ x => f x a)
    =
    λ x dx =>
      let ⟨f',df',h⟩ := 𝒯 f x dx
      ⟨f' a, df' a, by rw[h]; done⟩
  := by simp[tangentMapDep']; done

@[simp ↓, diff]
theorem tangentMapDep.of_eval
  (a : α)
  : 𝒯 (λ f : α → Y => f a)
    =
    λ f df =>
      ⟨f a, df a, rfl⟩
  := by simp[tangentMapDep']; done

--------------------------------------------------------------------------------


import convex touching_cone linalg

open_locale pointwise

variables {V: Type} [inner_product_space ℝ V] [finite_dimensional ℝ V]

lemma polytope_pre_touching_cone_nhd {P : set V} (hP : is_polytope P) (u : V) :
∃ ε : ℝ, ε > 0 ∧
metric.ball u ε ∩ (vector_span ℝ (normal_face P u))ᗮ ⊆ pre_touching_cone P u :=
begin
  rcases polytope_facial_gap hP u with ⟨ε, εpos, εball⟩,
  refine ⟨ε, εpos, _⟩,
  rintro z ⟨hv₁, hz⟩,
  simp only [set_like.mem_coe] at hz,
  --rcases (set.eq_of_mem_singleton hu).symm with rfl,
  simp only [pre_touching_cone, outer_normal_cone, set.mem_set_of],
  intros v hv,
  rcases polytope_normal_face_nonempty hP z with ⟨w, wua⟩,
  have wu := εball _ hv₁ wua,
  simp only [mem_normal_face],
  split,
  {
    exact normal_face_subset hv,
  },
  {
    intros y yP,
    have hu := mem_vspan_normal_face P u,
    have : ⟪v, z - u⟫_ℝ = ⟪w, z - u⟫_ℝ,
    {
      rw [←sub_eq_zero, ←inner_sub_left],
      exact (submodule.sub_mem _ hz hu) (v - w) (vsub_mem_vector_span ℝ hv wu),
    },
    have zeq: z = u + (z - u) := by simp only [add_sub_cancel'_right],
    rw [zeq],
    simp only [inner_add_right, inner_eq_of_mem_normal_face hv wu],
    simp only [this, ←inner_add_right, add_sub_cancel'_right],
    exact wua.2 y yP,
  },
end

lemma polytope_vspan_pre_touching_cone {P : set V} (hP : is_polytope P) (u : V) :
submodule.span ℝ (pre_touching_cone P u) =
(vector_span ℝ (normal_face P u))ᗮ :=
begin
  apply le_antisymm,
  {
    simp only [pre_touching_cone],
    rw [le_orthogonal_symm],
    apply outer_normal_cone_orthogonal,
  },
  {
    rcases polytope_pre_touching_cone_nhd hP u
      with ⟨ε, εpos, εball⟩,
    have hu : u ∈ (vector_span ℝ (normal_face P u))ᗮ :=
      by apply mem_vspan_normal_face,
    have := ball_spans_submodule _ u hu εpos,
    rw [←this, submodule.span_le],
    refine subset_trans _ submodule.subset_span,
    convert εball,
  },
end

lemma self_mem_relint_pre_touching_cone {P : set V} (hP : is_polytope P) (u : V) :
u ∈ relint (pre_touching_cone P u) :=
begin
  simp only [mem_relint],
  split,
  {
    apply mem_span_points,
    apply self_mem_pre_touching_cone,
  },
  {
    rcases polytope_pre_touching_cone_nhd hP u
      with ⟨ε, εpos, εball⟩,
    refine ⟨ε, εpos, subset_trans _ εball⟩,
    apply set.inter_subset_inter_right,
    refine subset_trans (aspan_le_span _) _,
    rw [polytope_vspan_pre_touching_cone hP],
    refine subset_of_eq _,
    refl,
  },
end

/- lemma polytope_relint_pre_touching_cone {P : set V} (hP : is_polytope P) (u : V) :
relint (pre_touching_cone P u) = { v : V | normal_face P v = normal_face P u } :=
begin
  apply subset_antisymm,
  {
    admit,
  },
  {
    admit,
  --   simp only [is_polytope] at hP,
  --   rcases hP with ⟨S, Sfin, Sne, rfl⟩,
  --   simp only [pre_touching_cone, outer_normal_cone],
  --   simp only [normal_face_spanned_by_verts],
  --   intros v hv,
  --   simp only [set.mem_set_of] at hv,
  },
end -/

lemma polytope_touching_cone_eq_pre {P : set V} (hP : is_polytope P) (u : V) :
touching_cone P u = pre_touching_cone P u :=
begin
  symmetry,
  apply touching_cone_unique_face,
  {
    apply is_face_refl,
    apply pre_touching_cone_convex,
  },
  {
    apply self_mem_relint_pre_touching_cone hP,
  },
end

lemma TS_poly_eq_vspan_face {P : set V} (hP : is_polytope P) (u : V) :
TS P u = vector_span ℝ (normal_face P u) :=
begin
  symmetry,
  simp only [TS, eq_orthogonal_symm, polytope_touching_cone_eq_pre hP],
  rw [polytope_vspan_pre_touching_cone hP u, submodule.orthogonal_orthogonal],
end


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

Archimedean groups and fields.
-/
import algebra.group_power algebra.field_power
import data.rat tactic.linarith tactic.abel

local infix ` • ` := add_monoid.smul

variables {α : Type*}

class floor_ring (α) [linear_ordered_ring α] :=
(floor : α → ℤ)
(le_floor : ∀ (z : ℤ) (x : α), z ≤ floor x ↔ (z : α) ≤ x)

instance : floor_ring ℤ :=
{ floor := id, le_floor := λ _ _, by rw int.cast_id; refl }

instance : floor_ring ℚ :=
{ floor := rat.floor, le_floor := @rat.le_floor }

section
variables [linear_ordered_ring α] [floor_ring α]

def floor : α → ℤ := floor_ring.floor

notation `⌊` x `⌋` := floor x

theorem le_floor : ∀ {z : ℤ} {x : α}, z ≤ ⌊x⌋ ↔ (z : α) ≤ x :=
floor_ring.le_floor

theorem floor_lt {x : α} {z : ℤ} : ⌊x⌋ < z ↔ x < z :=
lt_iff_lt_of_le_iff_le le_floor

theorem floor_le (x : α) : (⌊x⌋ : α) ≤ x :=
le_floor.1 (le_refl _)

theorem floor_nonneg {x : α} : 0 ≤ ⌊x⌋ ↔ 0 ≤ x :=
by rw [le_floor]; refl

theorem lt_succ_floor (x : α) : x < ⌊x⌋.succ :=
floor_lt.1 $ int.lt_succ_self _

theorem lt_floor_add_one (x : α) : x < ⌊x⌋ + 1 :=
by simpa only [int.succ, int.cast_add, int.cast_one] using lt_succ_floor x

theorem sub_one_lt_floor (x : α) : x - 1 < ⌊x⌋ :=
sub_lt_iff_lt_add.2 (lt_floor_add_one x)

@[simp] theorem floor_coe (z : ℤ) : ⌊(z:α)⌋ = z :=
eq_of_forall_le_iff $ λ a, by rw [le_floor, int.cast_le]

@[simp] theorem floor_zero : ⌊(0:α)⌋ = 0 := floor_coe 0

@[simp] theorem floor_one : ⌊(1:α)⌋ = 1 :=
by rw [← int.cast_one, floor_coe]

theorem floor_mono {a b : α} (h : a ≤ b) : ⌊a⌋ ≤ ⌊b⌋ :=
le_floor.2 (le_trans (floor_le _) h)

@[simp] theorem floor_add_int (x : α) (z : ℤ) : ⌊x + z⌋ = ⌊x⌋ + z :=
eq_of_forall_le_iff $ λ a, by rw [le_floor,
  ← sub_le_iff_le_add, ← sub_le_iff_le_add, le_floor, int.cast_sub]

theorem floor_sub_int (x : α) (z : ℤ) : ⌊x - z⌋ = ⌊x⌋ - z :=
eq.trans (by rw [int.cast_neg]; refl) (floor_add_int _ _)

lemma abs_sub_lt_one_of_floor_eq_floor {α : Type*} [decidable_linear_ordered_comm_ring α] [floor_ring α]
  {x y : α} (h : ⌊x⌋ = ⌊y⌋) : abs (x - y) < 1 :=
begin
  have : x < ⌊x⌋ + 1         := lt_floor_add_one x,
  have : y < ⌊y⌋ + 1         :=  lt_floor_add_one y,
  have : (⌊x⌋ : α) = ⌊y⌋ := int.cast_inj.2 h,
  have : (⌊x⌋: α) ≤ x        := floor_le x,
  have : (⌊y⌋ : α) ≤ y       := floor_le y,
  exact abs_sub_lt_iff.2 ⟨by linarith, by linarith⟩
end

lemma floor_eq_iff {r : α} {z : ℤ} :
  ⌊r⌋ = z ↔ ↑z ≤ r ∧ r < (z + 1) :=
by rw [←le_floor, ←int.cast_one, ←int.cast_add, ←floor_lt,
int.lt_add_one_iff, le_antisymm_iff, and.comm]

/-- The fractional part fract r of r is just r - ⌊r⌋ -/
def fract (r : α) : α := r - ⌊r⌋

-- Mathematical notation is usually {r}. Let's not even go there.

@[simp] lemma floor_add_fract (r : α) : (⌊r⌋ : α) + fract r = r := by unfold fract; simp

@[simp] lemma fract_add_floor (r : α) : fract r + ⌊r⌋ = r := sub_add_cancel _ _

theorem fract_nonneg (r : α) : 0 ≤ fract r :=
sub_nonneg.2 $ floor_le _

theorem fract_lt_one (r : α) : fract r < 1 :=
sub_lt.1 $ sub_one_lt_floor _

@[simp] lemma fract_zero : fract (0 : α) = 0 := by unfold fract; simp

@[simp] lemma fract_coe (z : ℤ) : fract (z : α) = 0 :=
by unfold fract; rw floor_coe; exact sub_self _

@[simp] lemma fract_floor (r : α) : fract (⌊r⌋ : α) = 0 := fract_coe _

@[simp] lemma floor_fract (r : α) : ⌊fract r⌋ = 0 :=
by rw floor_eq_iff; exact ⟨fract_nonneg _,
  by rw [int.cast_zero, zero_add]; exact fract_lt_one r⟩

theorem fract_eq_iff {r s : α} : fract r = s ↔ 0 ≤ s ∧ s < 1 ∧ ∃ z : ℤ, r - s = z :=
⟨λ h, by rw ←h; exact ⟨fract_nonneg _, fract_lt_one _,
  ⟨⌊r⌋, sub_sub_cancel _ _⟩⟩, begin
    intro h,
    show r - ⌊r⌋ = s, apply eq.symm,
    rw [eq_sub_iff_add_eq, add_comm, ←eq_sub_iff_add_eq],
    rcases h with ⟨hge, hlt, ⟨z, hz⟩⟩,
    rw [hz, int.cast_inj, floor_eq_iff, ←hz],
    clear hz, split; linarith {discharger := `[simp]}
  end⟩

theorem fract_eq_fract {r s : α} : fract r = fract s ↔ ∃ z : ℤ, r - s = z :=
⟨λ h, ⟨⌊r⌋ - ⌊s⌋, begin
  unfold fract at h, rw [int.cast_sub, sub_eq_sub_iff_sub_eq_sub.1 h],
 end⟩,
λ h, begin
  rcases h with ⟨z, hz⟩,
  rw fract_eq_iff,
  split, exact fract_nonneg _,
  split, exact fract_lt_one _,
  use z + ⌊s⌋,
  rw [eq_add_of_sub_eq hz, int.cast_add],
  unfold fract, simp
end⟩

@[simp] lemma fract_fract (r : α) : fract (fract r) = fract r :=
by rw fract_eq_fract; exact ⟨-⌊r⌋, by unfold fract;simp⟩

theorem fract_add (r s : α) : ∃ z : ℤ, fract (r + s) - fract r - fract s = z :=
⟨⌊r⌋ + ⌊s⌋ - ⌊r + s⌋, by unfold fract; simp⟩

theorem fract_mul_nat (r : α) (b : ℕ) : ∃ z : ℤ, fract r * b - fract (r * b) = z :=
begin
  induction b with c hc,
    use 0, simp,
  rcases hc with ⟨z, hz⟩,
  rw [nat.succ_eq_add_one, nat.cast_add, mul_add, mul_add, nat.cast_one, mul_one, mul_one],
  rcases fract_add (r * c) r with ⟨y, hy⟩,
  use z - y,
  rw [int.cast_sub, ←hz, ←hy],
  abel
end

/-- `ceil x` is the smallest integer `z` such that `x ≤ z` -/
def ceil (x : α) : ℤ := -⌊-x⌋

notation `⌈` x `⌉` := ceil x

theorem ceil_le {z : ℤ} {x : α} : ⌈x⌉ ≤ z ↔ x ≤ z :=
by rw [ceil, neg_le, le_floor, int.cast_neg, neg_le_neg_iff]

theorem lt_ceil {x : α} {z : ℤ} : z < ⌈x⌉ ↔ (z:α) < x :=
lt_iff_lt_of_le_iff_le ceil_le

theorem le_ceil (x : α) : x ≤ ⌈x⌉ :=
ceil_le.1 (le_refl _)

@[simp] theorem ceil_coe (z : ℤ) : ⌈(z:α)⌉ = z :=
by rw [ceil, ← int.cast_neg, floor_coe, neg_neg]

theorem ceil_mono {a b : α} (h : a ≤ b) : ⌈a⌉ ≤ ⌈b⌉ :=
ceil_le.2 (le_trans h (le_ceil _))

@[simp] theorem ceil_add_int (x : α) (z : ℤ) : ⌈x + z⌉ = ⌈x⌉ + z :=
by rw [ceil, neg_add', floor_sub_int, neg_sub, sub_eq_neg_add]; refl

theorem ceil_sub_int (x : α) (z : ℤ) : ⌈x - z⌉ = ⌈x⌉ - z :=
eq.trans (by rw [int.cast_neg]; refl) (ceil_add_int _ _)

theorem ceil_lt_add_one (x : α) : (⌈x⌉ : α) < x + 1 :=
by rw [← lt_ceil, ← int.cast_one, ceil_add_int]; apply lt_add_one

lemma ceil_pos {a : α} : 0 < ⌈a⌉ ↔ 0 < a :=
⟨ λ h, have ⌊-a⌋ < 0, from neg_of_neg_pos h,
  pos_of_neg_neg $ lt_of_not_ge $ (not_iff_not_of_iff floor_nonneg).1 $ not_le_of_gt this,
 λ h, have -a < 0, from neg_neg_of_pos h,
  neg_pos_of_neg $ lt_of_not_ge $ (not_iff_not_of_iff floor_nonneg).2 $ not_le_of_gt this ⟩

@[simp] theorem ceil_zero : ⌈(0 : α)⌉ = 0 := by simp [ceil]

lemma ceil_nonneg [decidable_rel ((<) : α → α → Prop)] {q : α} (hq : q ≥ 0) : ⌈q⌉ ≥ 0 :=
if h : q > 0 then le_of_lt $ ceil_pos.2 h
else by rw [le_antisymm (le_of_not_lt h) hq, ceil_zero]; trivial

end

class archimedean (α) [ordered_comm_monoid α] : Prop :=
(arch : ∀ (x : α) {y}, 0 < y → ∃ n : ℕ, x ≤ n • y)

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

section linear_ordered_ring
variables [linear_ordered_ring α] [archimedean α]

lemma pow_unbounded_of_gt_one (x : α) {y : α}
    (hy1 : 1 < y) : ∃ n : ℕ, x < y ^ n :=
have hy0 : 0 <  y - 1 := sub_pos_of_lt hy1,
let ⟨n, h⟩ := archimedean.arch x hy0 in
⟨n, calc x ≤ n • (y - 1)     : h
       ... < 1 + n • (y - 1) : by rw add_comm; exact lt_add_one _
       ... ≤ y ^ n           : pow_ge_one_add_sub_mul (le_of_lt hy1) _⟩

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_gt_one _ 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 nat.pos_iff_ne_zero.2 (λ hn0,
    by rw [hn0, pow_zero] at hn; exact (not_lt_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

lemma exists_int_pow_near [discrete_linear_ordered_field α] [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_gt_one x⁻¹ hy in
  have he: ∃ m : ℤ, y ^ m ≤ x, from
    ⟨-N, le_of_lt (by rw [(fpow_neg y (↑N)), one_div_eq_inv];
    exact (inv_lt hx (lt_trans (inv_pos hx) hN)).1 hN)⟩,
let ⟨M, hM⟩ := pow_unbounded_of_gt_one 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 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))⟩

variables [linear_ordered_field α] [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.smul_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 [add_monoid.smul_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)⟩⟩

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, ← add_monoid.smul_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
  ⟨rat.nat_ceil q, lt_of_lt_of_le h $
    by simpa only [rat.cast_coe_nat] using (@rat.cast_le α _ _ _).2 (rat.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 := nat.cast_pos.1 (lt_trans (inv_pos (sub_pos.2 h)) nh),
  have n0' := (@nat.cast_pos α _ _).2 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_eq_inv],
  { 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 archimedean_iff_nat_lt.1 (by apply_instance) (1/ε) with n hn,
  existsi n,
  apply div_lt_of_mul_lt_of_pos,
  { simp, apply add_pos_of_pos_of_nonneg zero_lt_one, apply nat.cast_nonneg },
  { apply (div_lt_iff' hε).1,
    transitivity,
    { exact hn },
    { simp [zero_lt_one] }}
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

include α
@[simp] theorem rat.cast_floor (x : ℚ) :
  by haveI := archimedean.floor_ring α; exact ⌊(x:α)⌋ = ⌊x⌋ :=
begin
  haveI := archimedean.floor_ring α,
  apply le_antisymm,
  { rw [le_floor, ← @rat.cast_le α, rat.cast_coe_int],
    apply floor_le },
  { rw [le_floor, ← rat.cast_coe_int, rat.cast_le],
    apply floor_le }
end

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

end linear_ordered_field

section
variables [discrete_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₂⟩⟩

lemma abs_sub_round [floor_ring α] (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

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

@[simp] theorem rat.cast_round {α : Type*} [discrete_linear_ordered_field α]
  [archimedean α] (x : ℚ) : by haveI := archimedean.floor_ring α;
  exact round (x:α) = round x :=
have ((x + (1 : ℚ) / (2 : ℚ) : ℚ) : α) = x + 1 / 2, by simp,
by rw [round, round, ← this, rat.cast_floor]

end


-- La_composicion_de_funciones_biyectivas_es_biyectiva.lean
-- La composición de funciones biyectivas es biyectiva
-- José A. Alonso Jiménez
-- Sevilla, 16 de agosto de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Demostrar que la composición de dos funciones biyectivas es una
-- función biyectiva.
-- ---------------------------------------------------------------------

import tactic
open function

variables {X Y Z : Type}
variable  {f : X → Y}
variable  {g : Y → Z}

-- 1ª demostración
example
  (Hf : bijective f)
  (Hg : bijective g)
  : bijective (g ∘ f) :=
begin
  cases Hf with Hfi Hfs,
  cases Hg with Hgi Hgs,
  split,
  { apply injective.comp,
    { exact Hgi, },
    { exact Hfi, }},
  { apply surjective.comp,
    { exact Hgs, },
    { exact Hfs, }},
end

-- 2ª demostración
example
  (Hf : bijective f)
  (Hg : bijective g)
  : bijective (g ∘ f) :=
begin
  cases Hf with Hfi Hfs,
  cases Hg with Hgi Hgs,
  split,
  { exact injective.comp Hgi Hfi, },
  { exact surjective.comp Hgs Hfs, },
end

-- 3ª demostración
example
  (Hf : bijective f)
  (Hg : bijective g)
  : bijective (g ∘ f) :=
begin
  cases Hf with Hfi Hfs,
  cases Hg with Hgi Hgs,
  exact ⟨injective.comp Hgi Hfi,
         surjective.comp Hgs Hfs⟩,
end

-- 4ª demostración
example :
  bijective f → bijective g → bijective (g ∘ f) :=
begin
  rintros ⟨Hfi, Hfs⟩ ⟨Hgi, Hgs⟩,
  exact ⟨injective.comp Hgi Hfi,
         surjective.comp Hgs Hfs⟩,
end

-- 5ª demostración
example :
  bijective f → bijective g → bijective (g ∘ f) :=
λ ⟨Hfi, Hfs⟩ ⟨Hgi, Hgs⟩, ⟨injective.comp Hgi Hfi,
                          surjective.comp Hgs Hfs⟩

-- 6ª demostración
example
  (Hf : bijective f)
  (Hg : bijective g)
  : bijective (g ∘ f) :=
-- by library_search
bijective.comp Hg Hf


variables (a b c d e : ℕ)
variable h1 : a = b
variable h2 : b = c + 1
variable h3 : c = d
variable h4 : e = 1 + d

include h1 h2 h3 h4
theorem T : a = e :=
  by rw [h1, h2, h3, add_comm, h4]


/- In this file, we define the core procedure behind
   Fourier-Motzkin variable elimination over ℚ, and prove
   its correctness.
-/

import data.rat
       galois.tactic
       .dense_linear_lemmas
       galois.list
       galois.list.fpow
       galois.vector.lemmas
       galois.vector.dot_product
       galois.list.mem
       galois.fin

universes u

namespace rat

def to_string (q:ℚ) : string :=
 if q.denom = 1 then
   to_string (q.num)
 else
   to_string (q.num) ++ "/" ++ to_string q.denom

instance : has_to_string ℚ := ⟨ to_string ⟩

end rat

-- denotes the inequality coef <= bound
structure linear_expr (n:ℕ) : Type :=
(coef : vector ℚ n)
(offset : ℚ)

namespace linear_expr

def to_string_core (off : ℚ) : ℕ → list ℚ → string
| _ [] := to_string off
| i (h::r) :=
 if h = 0 then
   to_string_core (i+1) r
 else
   let ppc (c : ℚ) (i:ℕ)  : string :=
        if c = 1 then
          "x" ++ to_string i
        else
          to_string c ++ "× x" ++ to_string i in
   let f (p:string × ℕ) (c : ℚ) : string × ℕ :=
         if c = 0 then
           (p.fst, p.snd + 1)
         else
           (p.fst ++ " " ++ ppc c p.snd, p.snd + 1) in
   (r.foldl f (ppc h (i+1), i+1)).fst ++ to_string off

def to_string {n:ℕ} (l : linear_expr n) : string :=
 to_string_core l.offset 0  l.coef.to_list

def var {n:ℕ} (c : ℚ) (i : fin n) : linear_expr n :=
 { coef := vector.generate n (λj, if i.val = j then c else 0)
 , offset := 0
 }

def const (n:ℕ) (c : ℚ) : linear_expr n :=
 { coef := vector.repeat 0 n
 , offset := c
 }

/-- Return the expression with the last variable removed and the coefficient. -/
def drop_head {n:ℕ} (e:linear_expr (n+1)) : linear_expr n :=
 { coef := e.coef.tail, offset := e.offset }

def instantiate_head {n : ℕ} (e : linear_expr (n + 1)) (c : ℚ) : linear_expr n :=
 { coef := e.coef.tail, offset := c * e.coef.head + e.offset}

def extend {n : ℕ} (x : ℚ) (e : linear_expr n) : linear_expr (n + 1)
  := ⟨ x :: e.coef , e.offset ⟩

def scale_mul {n:ℕ} (c:ℚ) (e:linear_expr n) : linear_expr n :=
 { coef := e.coef.map (λ x, c * x), offset := c * e.offset }

def add_expr {n:ℕ} (e e':linear_expr n) : linear_expr n :=
 { coef := vector.map₂ (+) e.coef e'.coef , offset := e.offset + e'.offset}

lemma instantiate_head_add_expr
  {n : ℕ} (e e' : linear_expr (n + 1)) (c : ℚ)
  : instantiate_head (add_expr e e') c
  = add_expr (instantiate_head e c) (instantiate_head e' c)
:= begin
induction e with e eoff,
induction e' with e' e'off,
dsimp [instantiate_head, add_expr],
have He := e.invert_succ, induction He with ehd etl eprf,
have He' := e'.invert_succ, induction He' with e'hd e'tl e'prf,
subst e, subst e',
f_equal,
{ rw vector.map₂_cons, repeat { rw vector.tail_cons }, },
{ rw vector.map₂_cons, repeat { rw vector.head_cons },
  rw mul_add, simp }
end

/-- Given inequalities
    lb * x + lbe ≤ 0
    ub * x + ube ≤ 0
    where lb < 0 and ub > 0, we eliminate the variable x
    by creating the equisatisfiable inequality constraint
    -lb * ube + ub * lbe ≤ 0
-/
def combine {n : ℕ} (lb : ℚ) (lbe : linear_expr n) (ub : ℚ)
  (ube : linear_expr n) : linear_expr n
:= add_expr (scale_mul (-lb) ube) (scale_mul ub lbe)

/-- Evaluate an expression with a particular vector of
    variable assignments
-/
def evaluate {n : ℕ} (e:linear_expr n) (a: vector ℚ n) : ℚ :=
dot_product e.coef a + e.offset

/-- Indicates whether a list of linear inequalities
    is satisfiable, i.e., there is a variable assignment
    such that all the inequalities hold.
-/
def satisfiable {n : ℕ} (es : list (linear_expr n))
  := ∃ (a : vector ℚ n), es.Forall (λ e, evaluate e a ≤ 0)

/-- A list of linear inequalities with n + 1 variables, focused
    on the additional "1" variable, which we can call x, in the sense
    that we split up the inequalities based on how they interact with
    x. If the coefficient of x is negative, it is a lower bound (`lbs`).
    If the coefficient of x is positive, it's an upper bound (`ubs`).
    If the coefficient of x is 0, it's `uninvolved`.
-/
structure focused (n : ℕ) :=
  (lbs : list ({ q : ℚ // q < 0} × linear_expr n))
  (ubs : list ({ q : ℚ // q > 0} × linear_expr n))
  (uninvolved : list (linear_expr n))

/-- Compute the minimum of a list of values, with a default in case the
    list is empty
-/
def minimum_opt {A} [decidable_linear_order A] (default : A) : list A → A
| [] := default
| (x :: xs) := list.foldr min x xs

/-- Compute the maximum of a list of values, with a default in case the
    list is empty
-/
def maximum_opt {A} [decidable_linear_order A] (default : A) : list A → A
| [] := default
| (x :: xs) := list.foldr max x xs

/-- Any member of a list is at most the maximum in the list -/
lemma maximum_opt_in {A} [decidable_linear_order A] (default : A)
  {x : A} {xs : list A} (H : x ∈ xs)
  : x ≤ maximum_opt default xs
:= begin
cases xs; dsimp [maximum_opt],
rw list.mem_nil_iff at H, contradiction,
induction a_1; dsimp [list.foldr],
dsimp [has_mem.mem, list.mem] at H,
cases H, subst a, contradiction,
dsimp [has_mem.mem, list.mem] at H,
induction H, subst a,
apply le_trans, tactic.swap, apply le_max_right,
apply ih_1, constructor, reflexivity,
induction a_3, subst a_1, apply le_max_left,
apply le_trans, tactic.swap, apply le_max_right,
apply ih_1, dsimp [has_mem.mem, list.mem], right,
assumption
end

/-- Any member of a list is at least the minimum in the list -/
lemma minimum_opt_in {A} [decidable_linear_order A] (default : A)
  {x : A} {xs : list A} (H : x ∈ xs)
  : minimum_opt default xs ≤ x
:= begin
cases xs; dsimp [minimum_opt],
rw list.mem_nil_iff at H, contradiction,
induction a_1; dsimp [list.foldr],
dsimp [has_mem.mem, list.mem] at H,
cases H, subst a, contradiction,
dsimp [has_mem.mem, list.mem] at H,
induction H, subst a,
apply le_trans, apply min_le_right,
apply ih_1, constructor, reflexivity,
induction a_3, subst a_1, apply min_le_left,
apply le_trans, apply min_le_right,
apply ih_1, dsimp [has_mem.mem, list.mem], right,
assumption
end

/-- A helper function for `focused_soln` below -/
def focused_soln_ub_map {n : ℕ} (soln : vector ℚ n)
  : { q : ℚ // q > 0} × linear_expr n → ℚ
| (ub, ube) := -ub.val⁻¹ * (dot_product (ube.coef) soln + ube.offset)

/-- Given a problem focused on a particular variable, and a putative
    variable assignment for all the other variables, pick a variable
    assignment for the particular variable such that if the
    problem is indeed satisfiable with the given assignment for all
    the other variables, then the assignment for the particular
    variable will give a satisfying assignment for the whole problem.
-/
def focused_soln {n : ℕ} (prob : focused n)
  (soln : vector ℚ n)
  : ℚ
:= minimum_opt
   (maximum_opt 0
     (prob.lbs.map (λ p : { q : ℚ // q < 0} × linear_expr n,
     let (⟨ lb, _ ⟩, lbe) := p in
  (-lb⁻¹ * (dot_product (lbe.coef) soln + lbe.offset)))))
    $
   prob.ubs.map (focused_soln_ub_map soln)

lemma focused_soln_ubs_empty {n : ℕ} (prob : focused n)
  (soln : vector ℚ n)
  (Hubs_empty : prob.ubs = [])
  {lb : _} {lbe : _} (Hlb : (lb, lbe) ∈ prob.lbs)
  : (-lb.val⁻¹ * (dot_product (lbe.coef) soln + lbe.offset)) ≤
    focused_soln prob soln
:= begin
unfold focused_soln, rw Hubs_empty,
dsimp [maximum_opt],
apply maximum_opt_in,
apply list.mem_map', tactic.swap, assumption,
induction lb, dsimp [focused_soln], reflexivity
end

lemma focused_soln_ubs_inhabited {n : ℕ} (prob : focused n)
  (soln : vector ℚ n)
  {ub : _} {ube : _}
  (Hubs_inh : (ub, ube) ∈ prob.ubs)
  : focused_soln prob soln ≤ (-ub.val⁻¹ * (dot_product (ube.coef) soln + ube.offset))
:= begin
unfold focused_soln,
apply minimum_opt_in,
apply list.mem_map', tactic.swap, assumption,
induction ub, dsimp [focused_soln], reflexivity
end

lemma Forall_equiv_list {A : Type _}
  (P : A → Prop) (xs ys : list A)
  (H : same_elements xs ys)
  : xs.Forall P ↔ ys.Forall P
:= begin
unfold same_elements at H,
repeat { rw list.Forall_mem_equiv },
split; intros H' x, rw ← H, apply H',
rw H, apply H',
end

/-- Convert a problem "focused" on a particular variable
    into the general formulation of a problem as a list
    of linear expressions with n + 1 variables.
-/
def focused_linear_exprs {n : ℕ} (prob : focused n)
  : list (linear_expr (n + 1))
  :=    prob.lbs.map (λ p, extend p.fst.val p.snd)
     ++ prob.ubs.map (λ p, extend p.fst.val p.snd)
     ++ prob.uninvolved.map (extend 0)

/-- A focused problem is satisfiable if it is satisfiable
    when we convert a problem to a list of linear expressions.
-/
def focused_satisfiable {n : ℕ} (prob : focused n)
  := satisfiable (focused_linear_exprs prob)

/-- Given a list of linear expressions, focus it on
    the first variable, separating the inequalities based
    on the whether the coefficients of that variable are
    0, positive, or negative.
-/
def focus_problem {n : ℕ} : list (linear_expr (n + 1))
  → focused n
| [] := ⟨ [], [], [] ⟩
| (e :: es) := let prob := focus_problem es in
  let x := e.coef.head in let rest := drop_head e in
  if Heq : x = 0
    then { prob with uninvolved := rest :: prob.uninvolved }
    else if Hlt : x < 0
      then { prob with lbs := (⟨ x, Hlt⟩ , rest) :: prob.lbs }
      else  { prob with ubs := (⟨ x, gt_of_not_eq_lt Heq Hlt⟩ , rest) :: prob.ubs }

/-- If one focuses a problem on a particular variable, and then
    converts back to a list of linear inequalities with n + 1
    variables, the new list has the same elements as the
    previous one (in fact, it is a permutation of the previous one,
    but we don't need to know this).
-/
lemma focus_problem_equiv {n : ℕ}
  (xs : list (linear_expr (n + 1)))
  : same_elements xs (focused_linear_exprs (focus_problem xs))
:= begin
induction xs; dsimp [focus_problem, focused_linear_exprs],
case list.nil
{ apply same_elements_refl },
case list.cons x xs IH
{ induction x with xcoef xoffset,
  have Hx := xcoef.invert_succ, induction Hx with c cs Hcs, subst xcoef,
  dsimp [drop_head],
  simp only [vector.head_cons, vector.tail_cons],
  dsimp,
  apply (if Heq : vector.head (c :: cs) = 0 then _ else _),
  { rw (dif_pos Heq), dsimp, rw list.append_assoc,
    apply same_elements_trans, tactic.swap,
    apply same_elements_app_comm,
    apply same_elements_trans, tactic.swap,
    apply same_elements_app,
    apply same_elements_app_comm, apply same_elements_refl,
    dsimp [list.append],
    rw list.append_assoc,
    apply cons_same, dsimp [extend],
    rw vector.head_cons at Heq, subst c,
    apply same_elements_trans, apply IH,
    dsimp [focus_problem, focused_linear_exprs],
    apply same_elements_trans,
    apply same_elements_app_comm,
    apply same_elements_app, apply same_elements_refl,
    apply same_elements_app_comm,
  },
  { rw (dif_neg Heq),
    apply (if Hlt : vector.head (c :: cs) < 0 then _ else _),
    { rw (dif_pos Hlt), dsimp,
      apply cons_same, reflexivity,
      apply IH, },
    { rw (dif_neg Hlt), dsimp,
      rw list.append_assoc,
      apply same_elements_trans, tactic.swap,
      apply same_elements_app_comm,
      rw list.append_assoc,
      dsimp [list.append],
      apply cons_same, reflexivity,
      apply same_elements_trans, assumption, clear IH,
      dsimp [focus_problem, focused_linear_exprs],
      apply same_elements_trans,
      rw list.append_assoc,
      apply same_elements_app_comm,
      rw list.append_assoc,
      apply same_elements_refl,
     }
  }
}
end

/-- If two lists of linear expressions have the same
    linear expressions in them, they are equisatisfiable.
-/
lemma same_elements_satisfiable {n : ℕ}
  {xs ys : list (linear_expr n)}
  (H : same_elements xs ys)
  : satisfiable xs ↔ satisfiable ys
:= begin
split; intros H'; induction H' with a Ha;
  existsi a, rw Forall_equiv_list, assumption,
  apply same_elements_symm, assumption,
  rw Forall_equiv_list, assumption, assumption,
end

/-- A helper function for variable elimination.
    Given a focused problems, compute the list
    of inequalities
-/
def bounds_list {n : ℕ} (prob : focused n)
  : list (linear_expr n)
:= do (lb, lbe) ← prob.lbs, (ub, ube) ← prob.ubs,
       return (combine lb.val lbe ub.val ube)

/-- To eliminate a variable from a focused problem,
    we take the upper and
    lower bounds to form new inequalities with
    `bounds_list`, and we leave the inequalities that
    didn't mention that variable in place
-/
def eliminate_aux {n : ℕ} (prob : focused n)
  : list (linear_expr n)
:= bounds_list prob ++ prob.uninvolved

/-- To eliminate a variable, we "focus" on that variable
    and then use the elimination procedure.
-/
def eliminate {n : ℕ} (es : list (linear_expr (n + 1)))
  : list (linear_expr n)
:= eliminate_aux (focus_problem es)

lemma evaluate_extend {n : ℕ} (x : linear_expr n)
  (c q : ℚ) (cs : vector ℚ n)
  : evaluate (extend q x) (c :: cs) = q * c + evaluate x cs
:= begin
dsimp [evaluate, extend],
rw dot_product_cons,
rw add_assoc,
end

lemma evaluate_extend_zero {n : ℕ} (x : linear_expr n)
  (c : ℚ) (cs : vector ℚ n)
  : evaluate (extend 0 x) (c :: cs) = evaluate x cs
:= begin
rw evaluate_extend,
rw mul_comm, rw mul_zero,
rw add_zero_l,
end

/-- Any non-empty list has a minimal element when
    projected to a linearly-ordered type
-/
def minimal_list {A} {B} [decidable_linear_order B]
  (xs : list A) (f : A → B)
  (H : xs ≠ [])
  : ∃ x : A, x ∈ xs ∧ (∀ y : A, y ∈ xs → f x ≤ f y)
:= begin
cases xs, contradiction,
rename a x, rename a_1 xs, clear H,
induction xs,
{ existsi x, split, constructor, reflexivity,
  intros y Hy, dsimp [has_mem.mem, list.mem] at Hy,
  cases Hy, subst y, contradiction, },
{ induction ih_1 with x' Hx', induction Hx' with H H',
  apply (if Hxa : f x' ≤ f a then _ else _),
  { existsi x', split,
    dsimp [has_mem.mem, list.mem] at H, cases H,
    subst x, left, reflexivity, right, right, assumption,
    intros y Hy, dsimp [has_mem.mem, list.mem] at Hy,
    cases Hy, subst y,
    dsimp [has_mem.mem, list.mem] at H, cases H,
    subst x', apply H', left, reflexivity,
    cases a_2, subst a, assumption, apply H',
    right, assumption,
   },
  { existsi a, split, right, left, reflexivity,
    have Hax : f a ≤ f x',
    cases (le_total (f a) (f x')), assumption, contradiction,
    clear Hxa,
    intros y Hy, dsimp [has_mem.mem, list.mem] at Hy,
    cases Hy, subst y,  dsimp [has_mem.mem, list.mem] at H,
    cases H, subst x', assumption,
    apply le_trans, assumption, apply H', left, reflexivity,
    cases a_2, subst a, apply le_trans, assumption,
    apply H', right, assumption,
   }
 }
end

/-- For any non-empty list, we can find a value in the list
    whose value is equal to the minimum under a function `f`
    to a linearly-ordered type.
-/
def minimal_list_opt {A}  {B} [decidable_linear_order B]
   (xs : list A) (default : B) (f : A → B)
  (H : xs ≠ [])
  : ∃ x : A, x ∈ xs ∧ f x = minimum_opt default (xs.map f)
:= begin
have H' := minimal_list xs f H,
induction H' with x Hx, induction Hx with H1 H2,
existsi x, split, assumption,
cases xs, rw list.mem_nil_iff at H1, contradiction,
clear H, rename a y, rename a_1 ys,
rw le_antisymm_iff, split,
{ dsimp [minimum_opt, list.map], clear H1,
  revert x y,
  induction ys; intros,
  dsimp [list.foldr, list.map], apply H2, left, reflexivity,
  dsimp [list.foldr, list.map],
  apply le_min, apply H2, right, left, reflexivity,
  apply ih_1, intros, apply H2,
  dsimp [has_mem.mem, list.mem] at a_2,
  induction a_2 with H H, left, assumption,
  right, right, assumption,
 },
{ apply minimum_opt_in,
  apply list.mem_map, assumption,
}
end

lemma id_rhs_list {A} (x : A) :
  id_rhs (list A) (return x) = [x] := rfl

lemma add_reassoc {A} [ring A] (lb ub : A) (ube1 ube2 lbe1 lbe2 : A)
  : lb * ube1 + ub * lbe1 + (lb * ube2 + ub * lbe2)
  = lb * (ube1 + ube2) + ub * (lbe1 + lbe2)
:= begin
repeat { rw mul_add }, simp,
end

/-- A lemma that says that if we can find a satisfying assignment
   for a pair of upper and lower bounds on a particular variable,
   that assignment (discarding the assignment to the particular variable)
   also satisfies the inequality generated by the `combine` function
   that is supposed to eliminate the variable.
-/
lemma eliminate_aux_combine_sat {n : ℕ}
  (c : ℚ)
  (cs : vector ℚ n)
  (lbe ube : linear_expr n)
  (lb : ℚ)
  (lblt0 : lb < 0)
  (ub : ℚ)
  (ubgt0 : ub > 0)
  (H1 : evaluate (extend lb lbe) (c :: cs) ≤ 0)
  (H2 : evaluate (extend ub ube) (c :: cs) ≤ 0)
  : evaluate (combine lb lbe ub ube) cs ≤ 0
:= begin
  dsimp [evaluate] at *,
  dsimp [combine, add_expr, scale_mul],
  dsimp [extend] at H1 H2,
  rw dot_product_cons at H1 H2,
  rw dot_product_sum_l,
  repeat { rw dot_product_scale_l },
  rw (mul_le_zero_neg _ _ lblt0) at H2,
  rw (mul_le_zero_pos _ _ ubgt0) at H1,
  rw add_assoc at H1 H2,
  rw mul_add at H1 H2,
  rw add_reassoc,
  rw add_neg_le_r at H2,
  rw add_neg_le_l at H1,
  rw ← mul_assoc at H1 H2,
  rw mul_comm ub at H1,
  rw add_neg_le_l,
  rw ← neg_mul_eq_neg_mul,
  apply le_trans, apply H2, apply H1,
end

/-- The main theorem: If we have a focused problem and eliminate
    the focused variable, the new problem is satisfiable exactly
    when the old one was.
-/
theorem eliminate_aux_preserves_sat {n : ℕ} (prob : focused n)
  : focused_satisfiable prob
  ↔ satisfiable (eliminate_aux prob)
:= begin
split; intros H,
{ induction H with a Ha,
  unfold satisfiable,
  have Hx := a.invert_succ, induction Hx with c cs Hcs, subst a,
  existsi cs,
  unfold eliminate_aux,
  unfold focused_linear_exprs at Ha,
  rw list.Forall_app_iff at Ha,
  induction Ha with H1 H3,
  rw list.Forall_app_iff at H1,
  induction H1 with H1 H2,
  rw list.map_Forall_iff at H3 H2 H1,
  apply list.concat_Forall,
  { clear H3,
    rw list.Forall_mem_equiv at H2 H1,
    rw list.Forall_mem_equiv,
    intros x Hx,
    apply_in Hx list.mem_bind',
    induction Hx with lbp Hx,
    induction Hx with HA HB,
    specialize (H1 lbp HA),
    induction lbp with lb lbe,
    dsimp [bounds_list] at HB,
    apply_in HB list.mem_bind',
    induction HB with ubp HB,
    induction HB with HB HC,
    specialize (H2 ubp HB),
    induction ubp with ub ube,
    dsimp at HC,
    rw id_rhs_list at HC,
    induction lb with lb lblt0,
    rw list.mem_singleton_iff at HC,
    subst x,
    induction ub with ub ubgt0,
    dsimp at H2 H1,
    dsimp,
    apply eliminate_aux_combine_sat; assumption,
    },
  { apply list.impl_Forall, assumption,
    intros x He,
    rw evaluate_extend_zero at He, assumption }
},
{ unfold focused_satisfiable,
  induction H with a Ha,
  unfold satisfiable,
  existsi (focused_soln prob a :: a),
  unfold focused_linear_exprs,
  unfold eliminate_aux at Ha,
  rw list.Forall_app_iff at Ha,
  induction Ha with H1 H2,
  repeat { apply list.concat_Forall };
    apply list.map_Forall,
  { clear H2,
    rw list.Forall_mem_equiv,
    intros x xlbs, induction x with lb lbe,
    dsimp,
    rw evaluate_extend,
    destruct (prob.ubs),
    { intros Hnil,
      have H := focused_soln_ubs_empty prob a Hnil xlbs,
      apply le_trans, apply add_le_add,
      apply mul_le_mono_neg, apply lb.property,
      assumption, apply le_refl,
      rw ← mul_assoc, rw ← neg_mul_eq_mul_neg,
      rw mul_inv_cancel, rw ← neg_mul_eq_neg_mul,
      rw [mul_comm, mul_one],
      unfold evaluate,
      rw neg_add_self, apply ne_of_lt, apply lb.property,
    },
    { intros ub ubs Hubs, rw list.Forall_mem_equiv at H1,
      have Hubs' : prob.ubs ≠ [],
      rw Hubs, contradiction, clear Hubs ubs ub,
      have Hubs := minimal_list_opt _ _ (focused_soln_ub_map a) Hubs',
      induction Hubs with ub Hub, induction Hub with Hub Hub',
      induction ub with ub ube,
      specialize (H1 (combine lb.val lbe ub.val ube)),
      have H2 : combine (lb.val) lbe (ub.val) ube ∈ bounds_list prob,
      unfold bounds_list,
      rw list.mem_bind_iff',
      existsi (lb, lbe), split, assumption,
      dsimp [bounds_list], rw list.mem_bind_iff',
      existsi (ub, ube), split, assumption,
      dsimp [bounds_list], constructor, reflexivity,
      specialize (H1 H2), clear H2,
      dsimp [evaluate, combine, add_expr, scale_mul] at H1,
      rw dot_product_sum_l at H1,
      repeat { rw dot_product_scale_l at H1 },
      rw add_reassoc at H1,
      have Hubinv : ub.val⁻¹ > 0,
      apply rat.inv_pos, apply ub.property,
      rw (mul_le_zero_pos _ _ Hubinv) at H1,
      rw mul_add at H1,
      rw ← mul_assoc _ ub.val at H1,
      rw [mul_comm _ ub.val, mul_inv_cancel] at H1,
      rw mul_comm (1 : ℚ) at H1, rw mul_one at H1,
      apply le_trans, tactic.swap, apply H1,
      apply add_le_add_right,
      have Hub : (ub, ube) ∈ prob.ubs, assumption,
      unfold focused_soln, rw ← Hub',
      dsimp [focused_soln_ub_map], simp,
      apply ne_of_gt, apply ub.property,
    }
  },
  { clear H2,
    rw list.Forall_mem_equiv,
    intros x xubs, induction x with ub ube,
    dsimp,
    rw evaluate_extend,
    apply_in xubs (focused_soln_ubs_inhabited prob a),
    apply le_trans, apply add_le_add_right,
    apply mul_le_mono_pos, apply ub.property,
    assumption, rw ← mul_assoc,
    rw ← neg_mul_eq_mul_neg, rw mul_inv_cancel,
    rw ← neg_mul_eq_neg_mul, rw [mul_comm, mul_one],
    unfold evaluate,
    rw neg_add_self, apply ne_of_gt, apply ub.property,
  },
  { apply list.impl_Forall, assumption,
    intros x He,
    rw evaluate_extend_zero, assumption }
   }
end

/-- Another main theorem. The variable elimination procedure
    preserves satisfiability.
-/
theorem satsfiable_eliminate {n : ℕ}
  (xs : list (linear_expr (n + 1)))
  : satisfiable xs
  ↔ satisfiable (eliminate xs)
:= begin
unfold eliminate,
rw ← eliminate_aux_preserves_sat,
apply same_elements_satisfiable,
apply focus_problem_equiv,
end

lemma vector_nil_exists
  {A : Type _}
  (P : vector A 0 → Prop)
  : Exists P ↔ P vector.nil
:= begin
split; intros, induction a,
rw ← (vector.eq_nil a), assumption,
constructor, assumption
end

/-- Deciding satisfiability of a problem with no
    variables in it is easy, since there is one
    possible assignment (the empty vector), so we
    just need to check that.
-/
def satisfiable_constant_dec
  (xs : list (linear_expr 0))
  : decidable (satisfiable xs)
:= begin
unfold satisfiable,
rw vector_nil_exists,
apply_instance,
end

def eval_no_vars (e : linear_expr 0) : ℚ
  := e.evaluate vector.nil

/-- Eliminate all of the variables from a
    linear system of inequalities.
-/
def eliminate_all : ∀ {n : ℕ},
  list (linear_expr n) → list (linear_expr 0)
| 0 xs := xs
| (nat.succ n) xs := eliminate_all (eliminate xs)

/-- If we eliminate all variables from a system of
    inequalities, we preserve satisfiability. This
    is just the repeated application of
    `satisfiable_eliminate`, which says that eliminating
    a single variable preserves satisfiability.
-/
lemma eliminate_all_equiv {n : ℕ}
  (xs : list (linear_expr n))
  : satisfiable xs ↔ satisfiable (eliminate_all xs)
:= begin
induction n; dsimp [eliminate_all],
trivial, rw satsfiable_eliminate, apply ih_1,
end

/-- To decide satisfiability of a problem, we eliminate
    all the variables, at which point it is trivial.
-/
instance satisfiable_dec {n : ℕ}
  (xs : list (linear_expr n))
  : decidable (satisfiable xs)
:= begin
rw eliminate_all_equiv, apply satisfiable_constant_dec,
end

def satisfiable_bool {n : ℕ}
  (xs : list (linear_expr n))
  : bool
:= decidable.to_bool (satisfiable xs)

def satisfiable_bool' {n : ℕ}
  (xs : list (linear_expr n))
  : bool
:= list.band ((eliminate_all xs).map (λ e, e.evaluate vector.nil ≤ 0))

lemma band_tt_left (b : bool) : tt && b = b
:= begin
induction b; reflexivity
end

lemma to_bool_Forall {A} (xs : list A) (P : A → Prop) [decP : decidable_pred P] :
  to_bool (list.Forall P xs) = list.band (xs.map (λ x, to_bool (P x)))
:= begin
unfold to_bool,
cases (list.Forall_decidable P xs) with no yes,
{ induction xs; dsimp [list.band, list.all],
  exfalso, apply no, constructor,
  cases (decP a); dsimp, reflexivity,
  rw band_tt_left, apply ih_1, intros contra,
  apply no, constructor; assumption },
{ dsimp, induction xs; dsimp [list.band, list.all],
  reflexivity,
  apply_in yes list.Forall_invert, dsimp at yes, induction yes with yes yes',
  cases (decP a); dsimp,
  contradiction, rw band_tt_left, apply ih_1, assumption,
}
end

/-- The `decidable` instance given by `satisfiable_bool` returns
    the same value as a more concretely given Boolean function
    `satisfiable_bool'`. For some reason, I have difficulty getting
    the former to reduce, so I use the latter instead.
-/
lemma satisfiable_bool_equiv {n : ℕ} (xs : list (linear_expr n))
  : satisfiable_bool xs = satisfiable_bool' xs
:= begin
unfold satisfiable_bool satisfiable_bool',
rw (to_bool_congr (eliminate_all_equiv _)),
unfold satisfiable,
rw (to_bool_congr (vector_nil_exists _)),
apply to_bool_Forall, apply_instance,
end

lemma var_offset_0
  {n : ℕ} (c : ℚ) (i : fin n)
  : (linear_expr.var c i).offset = 0
  := rfl

lemma var_evaluate {n : ℕ} (c : ℚ) (i : fin n) (x : vector ℚ n) :
  (var c i).evaluate x = c * x.nth i
:= begin
dsimp [evaluate, var],
rw add_zero,
rw dot_product_unit,
end

end linear_expr


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .homomorphism
import .identity

namespace universal
variables {τ : Type} {σ : Type*} {sig : signature τ σ} (alg : algebra sig)

structure congruence :=
(r (t) : alg.sort t → alg.sort t → Prop)
(refl {t} (x : alg.sort t) : r t x x)
(eucl {t} {{x y z : alg.sort t}} : r t x y → r t x z → r t y z)
(func (f) {xs ys : Π (i : sig.index f), alg.sort i.val} : (∀ i, r _ (xs i) (ys i)) → r _ (alg.func f xs) (alg.func f ys))

namespace congruence
variables {alg} (con : congruence alg)

theorem rfl {t} {x : alg.sort t} : con.r t x x := con.refl x

theorem symm {t} {{x y : alg.sort t}} : con.r t x y → con.r t y x :=
λ h, con.eucl h con.rfl

theorem trans {t} {{x y z : alg.sort t}} : con.r t x y → con.r t y z → con.r t x z :=
λ hxy hyz, con.eucl (con.symm hxy) hyz

definition to_reflexive (t) : reflexive (con.r t) := λ x, con.refl x

definition to_symmetric (t) : symmetric (con.r t) := λ _ _ hxy, con.symm hxy

definition to_transitive (t) : transitive (con.r t) := λ _ _ _ hxy hyz, con.trans hxy hyz

definition to_euclidean (t) : euclidean (con.r t) := λ _ _ _ hxy hxz, con.eucl hxy hxz

definition to_equivalence (t) : equivalence (con.r t) :=
equivalence.mk _ (con.to_reflexive t) (con.to_euclidean t)

definition to_setoid (t) : setoid (alg.sort t) :=
{ r := con.r t
, iseqv := con.to_equivalence t
}

end congruence

definition quotient (con : congruence alg) : algebra sig :=
have hr : ∀ t, reflexive (con.r t), from λ t, con.to_reflexive t,
{ sort := λ t, quot (con.r t)
, func := λ f xs,
  have hr : ∀ i : sig.index  f, reflexive (con.r i.val), from λ i, con.to_reflexive i.val,
  let fn := λ (xs : Π i : sig.index f, alg.sort i.val), quot.mk (con.r (sig.cod f)) (alg.func f xs) in
  quot.lift_on (quot.index_inv hr xs) fn $
  begin
  intros xs ys h,
  apply quot.sound,
  apply con.func,
  exact h,
  end
}

variables {alg} (con : congruence alg)

abbreviation quotient.mk {{t}} : alg.sort t → (quotient alg con).sort t := quot.mk (con.r t)

theorem quotient.func_beta (f : σ) (xs : Π (i : sig.index f), alg.sort i.val) :
algebra.func (quotient alg con) f (λ i, quotient.mk con (xs i)) = quotient.mk con (alg.func f xs) :=
quot.index_lift_beta _ _

theorem quotient.mk_exact {t} {x y : alg.sort t} : quotient.mk con x = quotient.mk con y → con.r t x y :=
λ h, ec.elim_self (con.to_equivalence t) (quot.ec_exact h)

theorem quotient.mk_sound {t} {x y : alg.sort t} : con.r t x y → quotient.mk con x = quotient.mk con y := quot.sound

definition quotient_hom : homomorphism alg (quotient alg con) :=
{ map := quotient.mk con
, func := quotient.func_beta con
}

instance quotient_hom.surj : homomorphism.surjective (quotient_hom con) := ⟨λ _ x, quot.induction_on x (λ x, ⟨x, rfl⟩)⟩

theorem quotient.exact {t} {x y : alg.sort t} : (quotient_hom con).map _ x = (quotient_hom con).map _ y → con.r t x y :=
λ h, ec.elim_self (con.to_equivalence t) (quot.ec_exact h)

theorem quotient.sound {t} {x y : alg.sort t} : con.r t x y → (quotient_hom con).map _ x = (quotient_hom con).map _ y := quot.sound

definition quotient.lift {alg'} (h : homomorphism alg alg') (H : ∀ t x y, con.r t x y → h x = h y) :
homomorphism (quotient alg con) alg' :=
{ map := λ t x, quot.lift (h.map t) (H t) x
, func := λ f xs, quot.index_induction_on (λ i, con.to_reflexive i.val) xs $ λ xs,
  calc alg'.func f (λ i, quot.lift (h.map i.val) (H i.val) (quotient.mk con (xs i)))
  = h.map (sig.cod f) (alg.func f xs) : by rw h.func f xs ...
  = quot.lift (h.map (sig.cod f)) (H (sig.cod f)) ((quotient alg con).func f (λ i, quotient.mk con (xs i))) : by rw quotient.func_beta con f xs
}

theorem quotient.lift_beta {alg'} (h : homomorphism alg alg') {H : ∀ t x y, con.r t x y → h.map t x = h.map t y} {t} (x : alg.sort t) :
(quotient.lift con h H).map t (quotient.mk con x) = h.map t x := rfl

namespace homomorphism
variables {alg₁ : algebra sig} {alg₂ : algebra sig} (h : homomorphism alg₁ alg₂)

definition kernel (h : homomorphism alg₁ alg₂) : congruence alg₁ :=
{ r := λ t x y, h.map t x = h.map t y
, refl := λ _ _, rfl
, eucl := λ _ _ _ _ e₁ e₂, eq.subst e₁ e₂
, func := λ f xs ys es,
  eq.subst (h.func f xs) $
  eq.subst (h.func f ys) $
  congr_arg _ $ funext es
}

definition image : algebra sig := quotient alg₁ (kernel h)

definition image_map : homomorphism alg₁ (image h) := quotient_hom (kernel h)

definition image_inc : homomorphism (image h) alg₂ := quotient.lift (kernel h) h (λ _ _ _ a, a)

instance image_inc.inj : injective (image_inc h) :=
⟨λ t x₁ x₂, quot.induction_on x₁ $ λ x₁, quot.induction_on x₂ $ λ x₂ hx, quot.sound hx⟩

theorem image_factorization : comp (image_inc h) (image_map h) = h := homomorphism.ext $ λ _ _, rfl

end homomorphism

abbreviation congruence.satisfies (ax : identity sig) : Prop :=
∀ (val : Π (i : index ax.dom), alg.sort i.val), con.r _ (alg.eval ax.lhs val) (alg.eval ax.rhs val)

namespace quotient
variables {con}

theorem satisfies_sound (ax : identity sig) :
con.satisfies ax → (quotient alg con).satisfies ax :=
λ H val, quot.index_induction_on (λ i, con.to_reflexive i.val) val $
λ ts, calc (quotient alg con).eval (identity.lhs ax) (λ i, (quotient_hom con).map _ (ts i))
= (quotient_hom con).map _ (alg.eval (identity.lhs ax) ts) : by rw homomorphism.eval ...
= (quotient_hom con).map _ (alg.eval (identity.rhs ax) ts) : by rw quotient.sound con (H ts) ...
= (quotient alg con).eval (identity.rhs ax) (λ i, (quotient_hom con).map _ (ts i)) : by rw homomorphism.eval

theorem satisfies_exact (ax : identity sig) :
(quotient alg con).satisfies ax → con.satisfies ax :=
λ H val, quotient.exact con $
calc (quotient_hom con).map _ (alg.eval ax.lhs val)
= (quotient alg con).eval ax.lhs (λ i, (quotient_hom con).map _ (val i)) : by rw homomorphism.eval ...
= (quotient alg con).eval ax.rhs (λ i, (quotient_hom con).map _ (val i)) : by rw H ...
= (quotient_hom con).map _ (alg.eval ax.rhs val) : by rw homomorphism.eval

end quotient

theorem quotient.satisfies (ax : identity sig) :
con.satisfies ax ↔ (quotient alg con).satisfies ax :=
⟨quotient.satisfies_sound ax, quotient.satisfies_exact ax⟩

end universal


/-
Copyright (c) 2015 Joe Hendrix. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joe Hendrix, Sebastian Ullrich
-/

import data.vector2
import data.nat.basic

/-!
# Basic operations on bitvectors

This is a work-in-progress, and contains additions to other theories.

This file was moved to mathlib from core Lean in the switch to Lean 3.20.0c.
It is not fully in compliance with mathlib style standards.
-/

/-- `bitvec n` is a `vector` of `bool` with length `n`. -/
@[reducible] def bitvec (n : ℕ) := vector bool n

namespace bitvec
open nat
open vector

local infix `++ₜ`:65 := vector.append

/-- Create a zero bitvector -/
@[reducible] protected def zero (n : ℕ) : bitvec n := repeat ff n

/-- Create a bitvector of length `n` whose `n-1`st entry is 1 and other entries are 0. -/
@[reducible] protected def one : Π (n : ℕ), bitvec n
| 0        := nil
| (succ n) := repeat ff n ++ₜ tt::ᵥnil

/-- Create a bitvector from another with a provably equal length. -/
protected def cong {a b : ℕ} (h : a = b) : bitvec a → bitvec b
| ⟨x, p⟩ := ⟨x, h ▸ p⟩

/-- `bitvec` specific version of `vector.append` -/
def append {m n} : bitvec m → bitvec n → bitvec (m + n) := vector.append

/-! ### Shift operations -/
section shift
variable {n : ℕ}

/-- `shl x i` is the bitvector obtained by left-shifting `x` `i` times and padding with `ff`.
If `x.length < i` then this will return the all-`ff`s bitvector. -/
def shl (x : bitvec n) (i : ℕ) : bitvec n :=
bitvec.cong (by simp) $
  drop i x ++ₜ repeat ff (min n i)

/-- `fill_shr x i fill` is the bitvector obtained by right-shifting `x` `i` times and then
padding with `fill : bool`. If `x.length < i` then this will return the constant `fill`
bitvector. -/
def fill_shr (x : bitvec n) (i : ℕ) (fill : bool) : bitvec n :=
bitvec.cong
  begin
    by_cases (i ≤ n),
    { have h₁ := sub_le n i,
      rw [min_eq_right h],
      rw [min_eq_left h₁, ← nat.add_sub_assoc h, nat.add_comm, nat.add_sub_cancel] },
    { have h₁ := le_of_not_ge h,
      rw [min_eq_left h₁, sub_eq_zero_of_le h₁, zero_min, nat.add_zero] }
  end $
  repeat fill (min n i) ++ₜ take (n-i) x

/-- unsigned shift right -/
def ushr (x : bitvec n) (i : ℕ) : bitvec n :=
fill_shr x i ff

/-- signed shift right -/
def sshr : Π {m : ℕ}, bitvec m → ℕ → bitvec m
| 0        _ _ := nil
| (succ m) x i := head x ::ᵥ fill_shr (tail x) i (head x)

end shift

/-! ### Bitwise operations -/
section bitwise
variable {n : ℕ}

/-- bitwise not -/
def not : bitvec n → bitvec n := map bnot
/-- bitwise and -/
def and : bitvec n → bitvec n → bitvec n := map₂ band
/-- bitwise or -/
def or  : bitvec n → bitvec n → bitvec n := map₂ bor
/-- bitwise xor -/
def xor : bitvec n → bitvec n → bitvec n := map₂ bxor

end bitwise

/-! ### Arithmetic operators -/
section arith
variable {n : ℕ}

/-- `xor3 x y c` is `((x XOR y) XOR c)`. -/
protected def xor3 (x y c : bool) := bxor (bxor x y) c
/-- `carry x y c` is `x && y || x && c || y && c`. -/
protected def carry (x y c : bool) :=
x && y || x && c || y && c

/-- `neg x` is the two's complement of `x`. -/
protected def neg (x : bitvec n) : bitvec n :=
let f := λ y c, (y || c, bxor y c) in
prod.snd (map_accumr f x ff)

/-- Add with carry (no overflow) -/
def adc (x y : bitvec n) (c : bool) : bitvec (n+1) :=
let f := λ x y c, (bitvec.carry x y c, bitvec.xor3 x y c) in
let ⟨c, z⟩ := vector.map_accumr₂ f x y c in
c ::ᵥ z

/-- The sum of two bitvectors -/
protected def add (x y : bitvec n) : bitvec n := tail (adc x y ff)

/-- Subtract with borrow -/
def sbb (x y : bitvec n) (b : bool) : bool × bitvec n :=
let f := λ x y c, (bitvec.carry (bnot x) y c, bitvec.xor3 x y c) in
vector.map_accumr₂ f x y b

/-- The difference of two bitvectors -/
protected def sub (x y : bitvec n) : bitvec n := prod.snd (sbb x y ff)

instance : has_zero (bitvec n) := ⟨bitvec.zero n⟩
instance : has_one (bitvec n)  := ⟨bitvec.one n⟩
instance : has_add (bitvec n)  := ⟨bitvec.add⟩
instance : has_sub (bitvec n)  := ⟨bitvec.sub⟩
instance : has_neg (bitvec n)  := ⟨bitvec.neg⟩

/-- The product of two bitvectors -/
protected def mul (x y : bitvec n) : bitvec n :=
let f := λ r b, cond b (r + r + y) (r + r) in
(to_list x).foldl f 0

instance : has_mul (bitvec n)  := ⟨bitvec.mul⟩
end arith

/-! ### Comparison operators -/
section comparison
variable {n : ℕ}

/-- `uborrow x y` returns `tt` iff the "subtract with borrow" operation on `x`, `y` and `ff`
required a borrow. -/
def uborrow (x y : bitvec n) : bool := prod.fst (sbb x y ff)

/-- unsigned less-than proposition -/
def ult (x y : bitvec n) : Prop := uborrow x y
/-- unsigned greater-than proposition -/
def ugt (x y : bitvec n) : Prop := ult y x

/-- unsigned less-than-or-equal-to proposition -/
def ule (x y : bitvec n) : Prop := ¬ (ult y x)
/-- unsigned greater-than-or-equal-to proposition -/
def uge (x y : bitvec n) : Prop := ule y x

/-- `sborrow x y` returns `tt` iff `x < y` as two's complement integers -/
def sborrow : Π {n : ℕ}, bitvec n → bitvec n → bool
| 0        _ _ := ff
| (succ n) x y :=
  match (head x, head y) with
  | (tt, ff) := tt
  | (ff, tt) := ff
  | _        := uborrow (tail x) (tail y)
  end

/-- signed less-than proposition -/
def slt (x y : bitvec n) : Prop := sborrow x y
/-- signed greater-than proposition -/
def sgt (x y : bitvec n) : Prop := slt y x
/-- signed less-than-or-equal-to proposition -/
def sle (x y : bitvec n) : Prop := ¬ (slt y x)
/-- signed greater-than-or-equal-to proposition -/
def sge (x y : bitvec n) : Prop := sle y x

end comparison

/-! ### Conversion to `nat` and `int` -/
section conversion
variable {α : Type}

/-- Create a bitvector from a `nat` -/
protected def of_nat : Π (n : ℕ), nat → bitvec n
| 0        x := nil
| (succ n) x := of_nat n (x / 2) ++ₜ to_bool (x % 2 = 1) ::ᵥ nil

/-- Create a bitvector in the two's complement representation from an `int` -/
protected def of_int : Π (n : ℕ), int → bitvec (succ n)
| n (int.of_nat m)          := ff ::ᵥ bitvec.of_nat n m
| n (int.neg_succ_of_nat m) := tt ::ᵥ not (bitvec.of_nat n m)

/-- `add_lsb r b` is `r + r + 1` if `b` is `tt` and `r + r` otherwise. -/
def add_lsb (r : ℕ) (b : bool) := r + r + cond b 1 0

/-- Given a `list` of `bool`s, return the `nat` they represent as a list of binary digits. -/
def bits_to_nat (v : list bool) : nat :=
v.foldl add_lsb 0

/-- Return the natural number encoded by the input bitvector -/
protected def to_nat {n : nat} (v : bitvec n) : nat :=
bits_to_nat (to_list v)

theorem bits_to_nat_to_list {n : ℕ} (x : bitvec n) :
bitvec.to_nat x = bits_to_nat (vector.to_list x)  := rfl

local attribute [simp] nat.add_comm nat.add_assoc nat.add_left_comm nat.mul_comm nat.mul_assoc
local attribute [simp] nat.zero_add nat.add_zero nat.one_mul nat.mul_one nat.zero_mul nat.mul_zero
-- mul_left_comm

theorem to_nat_append {m : ℕ} (xs : bitvec m) (b : bool) :
bitvec.to_nat (xs ++ₜ b::ᵥnil) = bitvec.to_nat xs * 2 + bitvec.to_nat (b::ᵥnil) :=
begin
  cases xs with xs P,
  simp [bits_to_nat_to_list], clear P,
  unfold bits_to_nat list.foldl,
  -- generalize the accumulator of foldl
  generalize h : 0 = x, conv in (add_lsb x b) { rw ←h }, clear h,
  simp,
  induction xs with x xs generalizing x,
  { simp, unfold list.foldl add_lsb, simp [nat.mul_succ] },
  { simp, apply xs_ih }
end

theorem bits_to_nat_to_bool (n : ℕ)
: bitvec.to_nat (to_bool (n % 2 = 1) ::ᵥ nil) = n % 2 :=
begin
  simp [bits_to_nat_to_list],
  unfold bits_to_nat add_lsb list.foldl cond,
  simp [cond_to_bool_mod_two],
end

theorem of_nat_succ {k n : ℕ}
:  bitvec.of_nat (succ k) n = bitvec.of_nat k (n / 2) ++ₜ to_bool (n % 2 = 1) ::ᵥ nil :=
rfl

theorem to_nat_of_nat {k n : ℕ}
: bitvec.to_nat (bitvec.of_nat k n) = n % 2 ^ k :=
begin
  induction k with k ih generalizing n,
  { simp [nat.mod_one], refl },
  { have h : 0 < 2, { apply le_succ },
    rw [of_nat_succ, to_nat_append, ih, bits_to_nat_to_bool, mod_pow_succ h, nat.mul_comm] }
end

/-- Return the integer encoded by the input bitvector -/
protected def to_int : Π {n : nat}, bitvec n → int
| 0        _ := 0
| (succ n) v :=
  cond (head v)
    (int.neg_succ_of_nat $ bitvec.to_nat $ not $ tail v)
    (int.of_nat $ bitvec.to_nat $ tail v)

end conversion

/-! ### Miscellaneous instances -/
private def repr {n : nat} : bitvec n → string
| ⟨bs, p⟩ :=
  "0b" ++ (bs.map (λ b : bool, if b then '1' else '0')).as_string

instance (n : nat) : has_repr (bitvec n) :=
⟨repr⟩
end bitvec

instance {n} {x y : bitvec n} : decidable (bitvec.ult x y) := bool.decidable_eq _ _
instance {n} {x y : bitvec n} : decidable (bitvec.ugt x y) := bool.decidable_eq _ _