/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.group_action.defs
import Mathlib.algebra.group.units
import Mathlib.algebra.group_with_zero.default
import Mathlib.data.equiv.mul_add
import Mathlib.group_theory.perm.basic
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Group actions applied to various types of group

This file contains lemmas about `smul` on `units`, `group_with_zero`, and `group`.
-/

@[simp] theorem units.inv_smul_smul {α : Type u} {β : Type v} [monoid α] [mul_action α β] (u : units α) (x : β) : ↑(u⁻¹) • ↑u • x = x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(u⁻¹) • ↑u • x = x)) (smul_smul (↑(u⁻¹)) (↑u) x)))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((↑(u⁻¹) * ↑u) • x = x)) (units.inv_mul u)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (1 • x = x)) (one_smul α x))) (Eq.refl x)))

@[simp] theorem units.smul_inv_smul {α : Type u} {β : Type v} [monoid α] [mul_action α β] (u : units α) (x : β) : ↑u • ↑(u⁻¹) • x = x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑u • ↑(u⁻¹) • x = x)) (smul_smul (↑u) (↑(u⁻¹)) x)))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((↑u * ↑(u⁻¹)) • x = x)) (units.mul_inv u)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (1 • x = x)) (one_smul α x))) (Eq.refl x)))

/-- If a monoid `α` acts on `β`, then each `u : units α` defines a permutation of `β`. -/
def units.smul_perm_hom {α : Type u} {β : Type v} [monoid α] [mul_action α β] : units α →* equiv.perm β :=
  monoid_hom.mk
    (fun (u : units α) =>
      equiv.mk (fun (x : β) => ↑u • x) (fun (x : β) => ↑(u⁻¹) • x) (units.inv_smul_smul u) (units.smul_inv_smul u))
    sorry sorry

@[simp] theorem units.smul_left_cancel {α : Type u} {β : Type v} [monoid α] [mul_action α β] (u : units α) {x : β} {y : β} : ↑u • x = ↑u • y ↔ x = y :=
  equiv.apply_eq_iff_eq (coe_fn units.smul_perm_hom u)

theorem units.smul_eq_iff_eq_inv_smul {α : Type u} {β : Type v} [monoid α] [mul_action α β] (u : units α) {x : β} {y : β} : ↑u • x = y ↔ x = ↑(u⁻¹) • y :=
  equiv.apply_eq_iff_eq_symm_apply (coe_fn units.smul_perm_hom u)

theorem is_unit.smul_left_cancel {α : Type u} {β : Type v} [monoid α] [mul_action α β] {a : α} (ha : is_unit a) {x : β} {y : β} : a • x = a • y ↔ x = y := sorry

@[simp] theorem inv_smul_smul' {α : Type u} {β : Type v} [group_with_zero α] [mul_action α β] {c : α} (hc : c ≠ 0) (x : β) : c⁻¹ • c • x = x :=
  units.inv_smul_smul (units.mk0 c hc) x

@[simp] theorem smul_inv_smul' {α : Type u} {β : Type v} [group_with_zero α] [mul_action α β] {c : α} (hc : c ≠ 0) (x : β) : c • c⁻¹ • x = x :=
  units.smul_inv_smul (units.mk0 c hc) x

theorem inv_smul_eq_iff' {α : Type u} {β : Type v} [group_with_zero α] [mul_action α β] {a : α} (ha : a ≠ 0) {x : β} {y : β} : a⁻¹ • x = y ↔ x = a • y := sorry

theorem eq_inv_smul_iff' {α : Type u} {β : Type v} [group_with_zero α] [mul_action α β] {a : α} (ha : a ≠ 0) {x : β} {y : β} : x = a⁻¹ • y ↔ a • x = y := sorry

@[simp] theorem inv_smul_smul {α : Type u} {β : Type v} [group α] [mul_action α β] (c : α) (x : β) : c⁻¹ • c • x = x :=
  units.inv_smul_smul (coe_fn to_units c) x

@[simp] theorem smul_inv_smul {α : Type u} {β : Type v} [group α] [mul_action α β] (c : α) (x : β) : c • c⁻¹ • x = x :=
  units.smul_inv_smul (coe_fn to_units c) x

theorem inv_smul_eq_iff {α : Type u} {β : Type v} [group α] [mul_action α β] {a : α} {x : β} {y : β} : a⁻¹ • x = y ↔ x = a • y := sorry

theorem eq_inv_smul_iff {α : Type u} {β : Type v} [group α] [mul_action α β] {a : α} {x : β} {y : β} : x = a⁻¹ • y ↔ a • x = y := sorry

/-- Given an action of a group `α` on a set `β`, each `g : α` defines a permutation of `β`. -/
def mul_action.to_perm (α : Type u) (β : Type v) [group α] [mul_action α β] : α →* equiv.perm β :=
  monoid_hom.comp units.smul_perm_hom (mul_equiv.to_monoid_hom to_units)

protected theorem mul_action.bijective {α : Type u} {β : Type v} [group α] [mul_action α β] (g : α) : function.bijective fun (b : β) => g • b :=
  equiv.bijective (coe_fn (mul_action.to_perm α β) g)

theorem units.smul_eq_zero {α : Type u} {β : Type v} [monoid α] [add_monoid β] [distrib_mul_action α β] (u : units α) {x : β} : ↑u • x = 0 ↔ x = 0 := sorry

theorem units.smul_ne_zero {α : Type u} {β : Type v} [monoid α] [add_monoid β] [distrib_mul_action α β] (u : units α) {x : β} : ↑u • x ≠ 0 ↔ x ≠ 0 :=
  not_congr (units.smul_eq_zero u)

@[simp] theorem is_unit.smul_eq_zero {α : Type u} {β : Type v} [monoid α] [add_monoid β] [distrib_mul_action α β] {u : α} (hu : is_unit u) {x : β} : u • x = 0 ↔ x = 0 :=
  exists.elim hu fun (u_1 : units α) (hu : ↑u_1 = u) => hu ▸ units.smul_eq_zero u_1


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.sheaves.sheaf
import category_theory.limits.preserves.shapes.products
import category_theory.limits.types

/-!
# Checking the sheaf condition on the underlying presheaf of types.

If `G : C ⥤ D` is a functor which reflects isomorphisms and preserves limits
(we assume all limits exist in both `C` and `D`),
then checking the sheaf condition for a presheaf `F : presheaf C X`
is equivalent to checking the sheaf condition for `F ⋙ G`.

The important special case is when
`C` is a concrete category with a forgetful functor
that preserves limits and reflects isomorphisms.
Then to check the sheaf condition it suffices
to check it on the underlying sheaf of types.

## References
* https://stacks.math.columbia.edu/tag/0073
-/

noncomputable theory

open category_theory
open category_theory.limits
open topological_space
open opposite

namespace Top

namespace presheaf

namespace sheaf_condition

open sheaf_condition_equalizer_products

universes v u₁ u₂

variables {C : Type u₁} [category.{v} C] [has_limits C]
variables {D : Type u₂} [category.{v} D] [has_limits D]
variables (G : C ⥤ D) [preserves_limits G]
variables {X : Top.{v}} (F : presheaf C X)
variables {ι : Type v} (U : ι → opens X)

local attribute [reducible] diagram left_res right_res

/--
When `G` preserves limits, the sheaf condition diagram for `F` composed with `G` is
naturally isomorphic to the sheaf condition diagram for `F ⋙ G`.
-/
def diagram_comp_preserves_limits :
  diagram F U ⋙ G ≅ diagram (F ⋙ G) U :=
begin
  fapply nat_iso.of_components,
  rintro ⟨j⟩,
  exact (preserves_product.iso _ _),
  exact (preserves_product.iso _ _),
  rintros ⟨⟩ ⟨⟩ ⟨⟩,
  { ext, simp, dsimp, simp, }, -- non-terminal `simp`, but `squeeze_simp` fails
  { ext,
    simp only [limit.lift_π, functor.comp_map, map_lift_pi_comparison, fan.mk_π_app,
               preserves_product.iso_hom, parallel_pair_map_left, functor.map_comp,
               category.assoc],
    dsimp, simp, },
  { ext,
    simp only [limit.lift_π, functor.comp_map, parallel_pair_map_right, fan.mk_π_app,
               preserves_product.iso_hom, map_lift_pi_comparison, functor.map_comp,
               category.assoc],
    dsimp, simp, },
 { ext, simp, dsimp, simp, },
end

local attribute [reducible] res

/--
When `G` preserves limits, the image under `G` of the sheaf condition fork for `F`
is the sheaf condition fork for `F ⋙ G`,
postcomposed with the inverse of the natural isomorphism `diagram_comp_preserves_limits`.
-/
def map_cone_fork : G.map_cone (fork F U) ≅
  (cones.postcompose (diagram_comp_preserves_limits G F U).inv).obj (fork (F ⋙ G) U) :=
cones.ext (iso.refl _) (λ j,
begin
  dsimp, simp [diagram_comp_preserves_limits], cases j; dsimp,
  { rw iso.eq_comp_inv,
    ext,
    simp, dsimp, simp, },
  { rw iso.eq_comp_inv,
    ext,
    simp, -- non-terminal `simp`, but `squeeze_simp` fails
    dsimp,
    simp only [limit.lift_π, fan.mk_π_app, ←G.map_comp, limit.lift_π_assoc, fan.mk_π_app] }
end)

end sheaf_condition

universes v u₁ u₂

open sheaf_condition sheaf_condition_equalizer_products

variables {C : Type u₁} [category.{v} C] {D : Type u₂} [category.{v} D]
variables (G : C ⥤ D)
variables [reflects_isomorphisms G]
variables [has_limits C] [has_limits D] [preserves_limits G]

variables {X : Top.{v}} (F : presheaf C X)

/--
If `G : C ⥤ D` is a functor which reflects isomorphisms and preserves limits
(we assume all limits exist in both `C` and `D`),
then checking the sheaf condition for a presheaf `F : presheaf C X`
is equivalent to checking the sheaf condition for `F ⋙ G`.

The important special case is when
`C` is a concrete category with a forgetful functor
that preserves limits and reflects isomorphisms.
Then to check the sheaf condition it suffices to check it on the underlying sheaf of types.

Another useful example is the forgetful functor `TopCommRing ⥤ Top`.

See https://stacks.math.columbia.edu/tag/0073.
In fact we prove a stronger version with arbitrary complete target category.
-/
def sheaf_condition_equiv_sheaf_condition_comp :
  sheaf_condition F ≃ sheaf_condition (F ⋙ G) :=
begin
  apply equiv_of_subsingleton_of_subsingleton,
  { intros S ι U,
    -- We have that the sheaf condition fork for `F` is a limit fork,
    have t₁ := S U,
    -- and since `G` preserves limits, the image under `G` of this fork is a limit fork too.
    have t₂ := @preserves_limit.preserves _ _ _ _ _ _ _ G _ _ t₁,
    -- As we established above, that image is just the sheaf condition fork
    -- for `F ⋙ G` postcomposed with some natural isomorphism,
    have t₃ := is_limit.of_iso_limit t₂ (map_cone_fork G F U),
    -- and as postcomposing by a natural isomorphism preserves limit cones,
    have t₄ := is_limit.postcompose_inv_equiv _ _ t₃,
    -- we have our desired conclusion.
    exact t₄, },
  { intros S ι U,
    -- Let `f` be the universal morphism from `F.obj U` to the equalizer
    -- of the sheaf condition fork, whatever it is.
    -- Our goal is to show that this is an isomorphism.
    let f := equalizer.lift _ (w F U),
    -- If we can do that,
    suffices : is_iso (G.map f),
    { resetI,
      -- we have that `f` itself is an isomorphism, since `G` reflects isomorphisms
      haveI : is_iso f := is_iso_of_reflects_iso f G,
      -- TODO package this up as a result elsewhere:
      apply is_limit.of_iso_limit (limit.is_limit _),
      apply iso.symm,
      fapply cones.ext,
      exact (as_iso f),
      rintro ⟨_|_⟩; { dsimp [f], simp, }, },
    { -- Returning to the task of shwoing that `G.map f` is an isomorphism,
      -- we note that `G.map f` is almost but not quite (see below) a morphism
      -- from the sheaf condition cone for `F ⋙ G` to the
      -- image under `G` of the equalizer cone for the sheaf condition diagram.
      let c := fork (F ⋙ G) U,
      have hc : is_limit c := S U,
      let d := G.map_cone (equalizer.fork (left_res F U) (right_res F U)),
      have hd : is_limit d := preserves_limit.preserves (limit.is_limit _),
      -- Since both of these are limit cones
      -- (`c` by our hypothesis `S`, and `d` because `G` preserves limits),
      -- we hope to be able to conclude that `f` is an isomorphism.
      -- We say "not quite" above because `c` and `d` don't quite have the same shape:
      -- we need to postcompose by the natural isomorphism `diagram_comp_preserves_limits`
      -- introduced above.
      let d' := (cones.postcompose (diagram_comp_preserves_limits G F U).hom).obj d,
      have hd' : is_limit d' :=
        (is_limit.postcompose_hom_equiv (diagram_comp_preserves_limits G F U) d).symm hd,
      -- Now everything works: we verify that `f` really is a morphism between these cones:
      let f' : c ⟶ d' :=
      fork.mk_hom (G.map f)
      begin
        dsimp only [c, d, d', f, diagram_comp_preserves_limits, res],
        dunfold fork.ι,
        ext1 j,
        dsimp,
        simp only [category.assoc, ←functor.map_comp_assoc, equalizer.lift_ι,
          map_lift_pi_comparison_assoc],
        dsimp [res], simp,
      end,
      -- conclude that it is an isomorphism,
      -- just because it's a morphism between two limit cones.
      haveI : is_iso f' := is_limit.hom_is_iso hc hd' f',
      -- A cone morphism is an isomorphism exactly if the morphism between the cone points is,
      -- so we're done!
      exact is_iso.of_iso ((cones.forget _).map_iso (as_iso f')) }, },
end

/-!
As an example, we now have everything we need to check the sheaf condition
for a presheaf of commutative rings, merely by checking the sheaf condition
for the underlying sheaf of types.
```
example (X : Top) (F : presheaf CommRing X) (h : sheaf_condition (F ⋙ (forget CommRing))) :
  sheaf_condition F :=
(sheaf_condition_equiv_sheaf_condition_forget F).symm h
```
-/

end presheaf

end Top


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro

Introduces the rational numbers as discrete, linear ordered field.
-/

import
  data.nat.gcd data.pnat data.int.basic data.equiv.encodable order.basic
  algebra.ordered_field data.real.cau_seq

/- rational numbers -/

/-- `rat`, or `ℚ`, is the type of rational numbers. It is defined
  as the set of pairs ⟨n, d⟩ of integers such that `d` is positive and `n` and
  `d` are coprime. This representation is preferred to the quotient
  because without periodic reduction, the numerator and denominator can grow
  exponentially (for example, adding 1/2 to itself repeatedly). -/
structure rat := mk' ::
(num : ℤ)
(denom : ℕ)
(pos : denom > 0)
(cop : num.nat_abs.coprime denom)
notation `ℚ` := rat

namespace rat

protected def repr : ℚ → string
| ⟨n, d, _, _⟩ := if d = 1 then _root_.repr n else
  _root_.repr n ++ "/" ++ _root_.repr d

instance : has_repr ℚ := ⟨rat.repr⟩
instance : has_to_string ℚ := ⟨rat.repr⟩
meta instance : has_to_format ℚ := ⟨coe ∘ rat.repr⟩

instance : encodable ℚ := encodable.of_equiv (Σ n : ℤ, {d : ℕ // d > 0 ∧ n.nat_abs.coprime d})
  ⟨λ ⟨a, b, c, d⟩, ⟨a, b, c, d⟩, λ⟨a, b, c, d⟩, ⟨a, b, c, d⟩,
   λ ⟨a, b, c, d⟩, rfl, λ⟨a, b, c, d⟩, rfl⟩

/-- Embed an integer as a rational number -/
def of_int (n : ℤ) : ℚ :=
⟨n, 1, nat.one_pos, nat.coprime_one_right _⟩

instance : has_zero ℚ := ⟨of_int 0⟩
instance : has_one ℚ := ⟨of_int 1⟩
instance : inhabited ℚ := ⟨0⟩

/-- Form the quotient `n / d` where `n:ℤ` and `d:ℕ+` (not necessarily coprime) -/
def mk_pnat (n : ℤ) : ℕ+ → ℚ | ⟨d, dpos⟩ :=
let n' := n.nat_abs, g := n'.gcd d in
⟨n / g, d / g, begin
  apply (nat.le_div_iff_mul_le _ _ (nat.gcd_pos_of_pos_right _ dpos)).2,
  simp, exact nat.le_of_dvd dpos (nat.gcd_dvd_right _ _)
end, begin
  have : int.nat_abs (n / ↑g) = n' / g,
  { cases int.nat_abs_eq n with e e; rw e, { refl },
    rw [int.neg_div_of_dvd, int.nat_abs_neg], { refl },
    exact int.coe_nat_dvd.2 (nat.gcd_dvd_left _ _) },
  rw this,
  exact nat.coprime_div_gcd_div_gcd (nat.gcd_pos_of_pos_right _ dpos)
end⟩

/-- Form the quotient `n / d` where `n:ℤ` and `d:ℕ`. In the case `d = 0`, we
  define `n / 0 = 0` by convention. -/
def mk_nat (n : ℤ) (d : ℕ) : ℚ :=
if d0 : d = 0 then 0 else mk_pnat n ⟨d, nat.pos_of_ne_zero d0⟩

/-- Form the quotient `n / d` where `n d : ℤ`. -/
def mk : ℤ → ℤ → ℚ
| n (int.of_nat d) := mk_nat n d
| n -[1+ d]        := mk_pnat (-n) d.succ_pnat

local infix ` /. `:70 := mk

theorem mk_pnat_eq (n d h) : mk_pnat n ⟨d, h⟩ = n /. d :=
by change n /. d with dite _ _ _; simp [ne_of_gt h]

theorem mk_nat_eq (n d) : mk_nat n d = n /. d := rfl

@[simp] theorem mk_zero (n) : n /. 0 = 0 := rfl

@[simp] theorem zero_mk_pnat (n) : mk_pnat 0 n = 0 :=
by cases n; simp [mk_pnat]; change int.nat_abs 0 with 0; simp *; refl

@[simp] theorem zero_mk_nat (n) : mk_nat 0 n = 0 :=
by by_cases n = 0; simp [*, mk_nat]

@[simp] theorem zero_mk (n) : 0 /. n = 0 :=
by cases n; simp [mk]

private lemma gcd_abs_dvd_left {a b} : (nat.gcd (int.nat_abs a) b : ℤ) ∣ a :=
int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $ nat.gcd_dvd_left (int.nat_abs a) b

@[simp] theorem mk_eq_zero {a b : ℤ} (b0 : b ≠ 0) : a /. b = 0 ↔ a = 0 :=
begin
  constructor; intro h; [skip, {subst a, simp}],
  have : ∀ {a b}, mk_pnat a b = 0 → a = 0,
  { intros a b e, cases b with b h,
    injection e with e,
    apply int.eq_mul_of_div_eq_right gcd_abs_dvd_left e },
  cases b with b; simp [mk, mk_nat] at h,
  { simp [mt (congr_arg int.of_nat) b0] at h,
    exact this h },
  { apply neg_inj, simp [this h] }
end

theorem mk_eq : ∀ {a b c d : ℤ} (hb : b ≠ 0) (hd : d ≠ 0),
  a /. b = c /. d ↔ a * d = c * b :=
suffices ∀ a b c d hb hd, mk_pnat a ⟨b, hb⟩ = mk_pnat c ⟨d, hd⟩ ↔ a * d = c * b,
begin
  intros, cases b with b b; simp [mk, mk_nat, nat.succ_pnat],
  simp [mt (congr_arg int.of_nat) hb],
  all_goals {
    cases d with d d; simp [mk, mk_nat, nat.succ_pnat],
    simp [mt (congr_arg int.of_nat) hd],
    all_goals { rw this, try {refl} } },
  { change a * ↑(d.succ) = -c * ↑b ↔ a * -(d.succ) = c * b,
    constructor; intro h; apply neg_inj; simpa [left_distrib, neg_add_eq_iff_eq_add,
      eq_neg_iff_add_eq_zero, neg_eq_iff_add_eq_zero] using h },
  { change -a * ↑d = c * b.succ ↔ a * d = c * -b.succ,
    constructor; intro h; apply neg_inj; simpa [left_distrib, eq_comm] using h },
  { change -a * d.succ = -c * b.succ ↔ a * -d.succ = c * -b.succ,
    simp [left_distrib] }
end,
begin
  intros, simp [mk_pnat], constructor; intro h,
  { cases h with ha hb,
    have ha, {
      have dv := @gcd_abs_dvd_left,
      have := int.eq_mul_of_div_eq_right dv ha,
      rw ← int.mul_div_assoc _ dv at this,
      exact int.eq_mul_of_div_eq_left (dvd_mul_of_dvd_right dv _) this.symm },
    have hb, {
      have dv := λ {a b}, nat.gcd_dvd_right (int.nat_abs a) b,
      have := nat.eq_mul_of_div_eq_right dv hb,
      rw ← nat.mul_div_assoc _ dv at this,
      exact nat.eq_mul_of_div_eq_left (dvd_mul_of_dvd_right dv _) this.symm },
    have m0 : (a.nat_abs.gcd b * c.nat_abs.gcd d : ℤ) ≠ 0, {
      refine int.coe_nat_ne_zero.2 (ne_of_gt _),
      apply mul_pos; apply nat.gcd_pos_of_pos_right; assumption },
    apply eq_of_mul_eq_mul_right m0,
    simpa [mul_comm, mul_left_comm] using
      congr (congr_arg (*) ha.symm) (congr_arg coe hb) },
  { suffices : ∀ a c, a * d = c * b →
      a / a.gcd b = c / c.gcd d ∧ b / a.gcd b = d / c.gcd d,
    { cases this a.nat_abs c.nat_abs
        (by simpa [int.nat_abs_mul] using congr_arg int.nat_abs h) with h₁ h₂,
      have hs := congr_arg int.sign h,
      simp [int.sign_eq_one_of_pos (int.coe_nat_lt.2 hb),
            int.sign_eq_one_of_pos (int.coe_nat_lt.2 hd)] at hs,
      conv in a { rw ← int.sign_mul_nat_abs a },
      conv in c { rw ← int.sign_mul_nat_abs c },
      rw [int.mul_div_assoc, int.mul_div_assoc],
      exact ⟨congr (congr_arg (*) hs) (congr_arg coe h₁), h₂⟩,
      all_goals { exact int.coe_nat_dvd.2 (nat.gcd_dvd_left _ _) } },
    intros a c h,
    suffices bd : b / a.gcd b = d / c.gcd d,
    { refine ⟨_, bd⟩,
      apply nat.eq_of_mul_eq_mul_left hb,
      rw [← nat.mul_div_assoc _ (nat.gcd_dvd_left _ _), mul_comm,
          nat.mul_div_assoc _ (nat.gcd_dvd_right _ _), bd,
          ← nat.mul_div_assoc _ (nat.gcd_dvd_right _ _), h, mul_comm,
          nat.mul_div_assoc _ (nat.gcd_dvd_left _ _)] },
    suffices : ∀ {a c : ℕ} (b>0) (d>0),
      a * d = c * b → b / a.gcd b ≤ d / c.gcd d,
    { exact le_antisymm (this _ hb _ hd h) (this _ hd _ hb h.symm) },
    intros a c b hb d hd h,
    have gb0 := nat.gcd_pos_of_pos_right a hb,
    have gd0 := nat.gcd_pos_of_pos_right c hd,
    apply nat.le_of_dvd,
    apply (nat.le_div_iff_mul_le _ _ gd0).2,
    simp, apply nat.le_of_dvd hd (nat.gcd_dvd_right _ _),
    apply (nat.coprime_div_gcd_div_gcd gb0).symm.dvd_of_dvd_mul_left,
    refine ⟨c / c.gcd d, _⟩,
    rw [← nat.mul_div_assoc _ (nat.gcd_dvd_left _ _),
        ← nat.mul_div_assoc _ (nat.gcd_dvd_right _ _)],
    apply congr_arg (/ c.gcd d),
    rw [mul_comm, ← nat.mul_div_assoc _ (nat.gcd_dvd_left _ _),
        mul_comm, h, nat.mul_div_assoc _ (nat.gcd_dvd_right _ _), mul_comm] }
end

@[simp] theorem div_mk_div_cancel_left {a b c : ℤ} (c0 : c ≠ 0) :
  (a * c) /. (b * c) = a /. b :=
begin
  by_cases b0 : b = 0, { subst b0, simp },
  apply (mk_eq (mul_ne_zero b0 c0) b0).2, simp [mul_comm, mul_assoc]
end

theorem num_denom : ∀ a : ℚ, a = a.num /. a.denom
| ⟨n, d, h, (c:_=1)⟩ := show _ = mk_nat n d,
  by simp [mk_nat, ne_of_gt h, mk_pnat, c]

theorem num_denom' (n d h c) : (⟨n, d, h, c⟩ : ℚ) = n /. d := num_denom _

@[elab_as_eliminator] theorem {u} num_denom_cases_on {C : ℚ → Sort u}
   : ∀ (a : ℚ) (H : ∀ n d, d > 0 → (int.nat_abs n).coprime d → C (n /. d)), C a
| ⟨n, d, h, c⟩ H := by rw num_denom'; exact H n d h c

@[elab_as_eliminator] theorem {u} num_denom_cases_on' {C : ℚ → Sort u}
   (a : ℚ) (H : ∀ (n:ℤ) (d:ℕ), d ≠ 0 → C (n /. d)) : C a :=
num_denom_cases_on a $ λ n d h c,
H n d $ ne_of_gt h

theorem num_dvd (a) {b : ℤ} (b0 : b ≠ 0) : (a /. b).num ∣ a :=
begin
  cases e : a /. b with n d h c,
  rw [rat.num_denom', rat.mk_eq b0
    (ne_of_gt (int.coe_nat_pos.2 h))] at e,
  refine (int.nat_abs_dvd.1 $ int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $
    c.dvd_of_dvd_mul_right _),
  have := congr_arg int.nat_abs e,
  simp [int.nat_abs_mul, int.nat_abs_of_nat] at this, simp [this]
end

theorem denom_dvd (a b : ℤ) : ((a /. b).denom : ℤ) ∣ b :=
begin
  by_cases b0 : b = 0, {simp [b0]},
  cases e : a /. b with n d h c,
  rw [num_denom', mk_eq b0 (ne_of_gt (int.coe_nat_pos.2 h))] at e,
  refine (int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $ c.symm.dvd_of_dvd_mul_left _),
  rw [← int.nat_abs_mul, ← int.coe_nat_dvd, int.dvd_nat_abs, ← e], simp
end

protected def add : ℚ → ℚ → ℚ
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := mk_pnat (n₁ * d₂ + n₂ * d₁) ⟨d₁ * d₂, mul_pos h₁ h₂⟩

instance : has_add ℚ := ⟨rat.add⟩

theorem lift_binop_eq (f : ℚ → ℚ → ℚ) (f₁ : ℤ → ℤ → ℤ → ℤ → ℤ) (f₂ : ℤ → ℤ → ℤ → ℤ → ℤ)
  (fv : ∀ {n₁ d₁ h₁ c₁ n₂ d₂ h₂ c₂},
    f ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ = f₁ n₁ d₁ n₂ d₂ /. f₂ n₁ d₁ n₂ d₂)
  (f0 : ∀ {n₁ d₁ n₂ d₂} (d₁0 : d₁ ≠ 0) (d₂0 : d₂ ≠ 0), f₂ n₁ d₁ n₂ d₂ ≠ 0)
  (a b c d : ℤ) (b0 : b ≠ 0) (d0 : d ≠ 0)
  (H : ∀ {n₁ d₁ n₂ d₂} (h₁ : a * d₁ = n₁ * b) (h₂ : c * d₂ = n₂ * d),
       f₁ n₁ d₁ n₂ d₂ * f₂ a b c d = f₁ a b c d * f₂ n₁ d₁ n₂ d₂) :
  f (a /. b) (c /. d) = f₁ a b c d /. f₂ a b c d :=
begin
  generalize ha : a /. b = x, cases x with n₁ d₁ h₁ c₁, rw num_denom' at ha,
  generalize hc : c /. d = x, cases x with n₂ d₂ h₂ c₂, rw num_denom' at hc,
  rw fv,
  have d₁0 := ne_of_gt (int.coe_nat_lt.2 h₁),
  have d₂0 := ne_of_gt (int.coe_nat_lt.2 h₂),
  exact (mk_eq (f0 d₁0 d₂0) (f0 b0 d0)).2 (H ((mk_eq b0 d₁0).1 ha) ((mk_eq d0 d₂0).1 hc))
end

@[simp] theorem add_def {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
  a /. b + c /. d = (a * d + c * b) /. (b * d) :=
begin
  apply lift_binop_eq rat.add; intros; try {assumption},
  { apply mk_pnat_eq },
  { apply mul_ne_zero d₁0 d₂0 },
  calc (n₁ * d₂ + n₂ * d₁) * (b * d) =
          (n₁ * b) * d₂ * d + (n₂ * d) * (d₁ * b) : by simp [mul_add, mul_comm, mul_left_comm]
    ... = (a * d₁) * d₂ * d + (c * d₂) * (d₁ * b) : by rw [h₁, h₂]
    ... = (a * d + c * b) * (d₁ * d₂)             : by simp [mul_add, mul_comm, mul_left_comm]
end

protected def neg : ℚ → ℚ
| ⟨n, d, h, c⟩ := ⟨-n, d, h, by simp [c]⟩

instance : has_neg ℚ := ⟨rat.neg⟩

@[simp] theorem neg_def {a b : ℤ} : -(a /. b) = -a /. b :=
begin
  by_cases b0 :  b = 0, { subst b0, simp, refl },
  generalize ha : a /. b = x, cases x with n₁ d₁ h₁ c₁, rw num_denom' at ha,
  show rat.mk' _ _ _ _ = _, rw num_denom',
  have d0 := ne_of_gt (int.coe_nat_lt.2 h₁),
  apply (mk_eq d0 b0).2, have h₁ := (mk_eq b0 d0).1 ha,
  simp only [neg_mul_eq_neg_mul_symm, congr_arg has_neg.neg h₁]
end

protected def mul : ℚ → ℚ → ℚ
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := mk_pnat (n₁ * n₂) ⟨d₁ * d₂, mul_pos h₁ h₂⟩

instance : has_mul ℚ := ⟨rat.mul⟩

@[simp] theorem mul_def {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
  (a /. b) * (c /. d) = (a * c) /. (b * d) :=
begin
  apply lift_binop_eq rat.mul; intros; try {assumption},
  { apply mk_pnat_eq },
  { apply mul_ne_zero d₁0 d₂0 },
  cc
end

protected def inv : ℚ → ℚ
| ⟨(n+1:ℕ), d, h, c⟩ := ⟨d, n+1, n.succ_pos, c.symm⟩
| ⟨0, d, h, c⟩ := 0
| ⟨-[1+ n], d, h, c⟩ := ⟨-d, n+1, n.succ_pos, nat.coprime.symm $ by simp; exact c⟩

instance : has_inv ℚ := ⟨rat.inv⟩

@[simp] theorem inv_def {a b : ℤ} : (a /. b)⁻¹ = b /. a :=
begin
  by_cases a0 : a = 0, { subst a0, simp, refl },
  by_cases b0 : b = 0, { subst b0, simp, refl },
  generalize ha : a /. b = x, cases x with n d h c, rw num_denom' at ha,
  refine eq.trans (_ : rat.inv ⟨n, d, h, c⟩ = d /. n) _,
  { cases n with n; [cases n with n, skip],
    { refl },
    { change int.of_nat n.succ with (n+1:ℕ),
      unfold rat.inv, rw num_denom' },
    { unfold rat.inv, rw num_denom', refl } },
  have n0 : n ≠ 0,
  { refine mt (λ (n0 : n = 0), _) a0,
    subst n0, simp at ha,
    exact (mk_eq_zero b0).1 ha },
  have d0 := ne_of_gt (int.coe_nat_lt.2 h),
  have ha := (mk_eq b0 d0).1 ha,
  apply (mk_eq n0 a0).2,
  cc
end

variables (a b c : ℚ)

protected theorem add_zero : a + 0 = a :=
num_denom_cases_on' a $ λ n d h,
by rw [← zero_mk d]; simp [h, -zero_mk]

protected theorem zero_add : 0 + a = a :=
num_denom_cases_on' a $ λ n d h,
by rw [← zero_mk d]; simp [h, -zero_mk]

protected theorem add_comm : a + b = b + a :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
by simp [h₁, h₂, mul_comm]

protected theorem add_assoc : a + b + c = a + (b + c) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
num_denom_cases_on' c $ λ n₃ d₃ h₃,
by simp [h₁, h₂, h₃, mul_ne_zero, mul_add, mul_comm, mul_left_comm, add_left_comm]

protected theorem add_left_neg : -a + a = 0 :=
num_denom_cases_on' a $ λ n d h,
by simp [h]

protected theorem mul_one : a * 1 = a :=
num_denom_cases_on' a $ λ n d h,
by change (1:ℚ) with 1 /. 1; simp [h]

protected theorem one_mul : 1 * a = a :=
num_denom_cases_on' a $ λ n d h,
by change (1:ℚ) with 1 /. 1; simp [h]

protected theorem mul_comm : a * b = b * a :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
by simp [h₁, h₂, mul_comm]

protected theorem mul_assoc : a * b * c = a * (b * c) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
num_denom_cases_on' c $ λ n₃ d₃ h₃,
by simp [h₁, h₂, h₃, mul_ne_zero, mul_comm, mul_left_comm]

protected theorem add_mul : (a + b) * c = a * c + b * c :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
num_denom_cases_on' c $ λ n₃ d₃ h₃,
by simp [h₁, h₂, h₃, mul_ne_zero];
   refine (div_mk_div_cancel_left (int.coe_nat_ne_zero.2 h₃)).symm.trans _;
   simp [mul_add, mul_comm, mul_assoc, mul_left_comm]

protected theorem mul_add : a * (b + c) = a * b + a * c :=
by rw [rat.mul_comm, rat.add_mul, rat.mul_comm, rat.mul_comm c a]

protected theorem zero_ne_one : 0 ≠ (1:ℚ) :=
mt (λ (h : 0 = 1 /. 1), (mk_eq_zero one_ne_zero).1 h.symm) one_ne_zero

protected theorem mul_inv_cancel : a ≠ 0 → a * a⁻¹ = 1 :=
num_denom_cases_on' a $ λ n d h a0,
have n0 : n ≠ 0, from mt (by intro e; subst e; simp) a0,
by simp [h, n0, mul_comm]; exact
eq.trans (by simp) (@div_mk_div_cancel_left 1 1 _ n0)

protected theorem inv_mul_cancel (h : a ≠ 0) : a⁻¹ * a = 1 :=
eq.trans (rat.mul_comm _ _) (rat.mul_inv_cancel _ h)

instance : decidable_eq ℚ := by tactic.mk_dec_eq_instance

instance : discrete_field ℚ :=
{ zero             := 0,
  add              := rat.add,
  neg              := rat.neg,
  one              := 1,
  mul              := rat.mul,
  inv              := rat.inv,
  zero_add         := rat.zero_add,
  add_zero         := rat.add_zero,
  add_comm         := rat.add_comm,
  add_assoc        := rat.add_assoc,
  add_left_neg     := rat.add_left_neg,
  mul_one          := rat.mul_one,
  one_mul          := rat.one_mul,
  mul_comm         := rat.mul_comm,
  mul_assoc        := rat.mul_assoc,
  left_distrib     := rat.mul_add,
  right_distrib    := rat.add_mul,
  zero_ne_one      := rat.zero_ne_one,
  mul_inv_cancel   := rat.mul_inv_cancel,
  inv_mul_cancel   := rat.inv_mul_cancel,
  has_decidable_eq := rat.decidable_eq,
  inv_zero         := rfl }

/- Extra instances to short-circuit type class resolution -/
instance : field ℚ              := by apply_instance
instance : division_ring ℚ      := by apply_instance
instance : integral_domain ℚ    := by apply_instance
-- TODO(Mario): this instance slows down data.real.basic
--instance : domain ℚ           := by apply_instance
instance : nonzero_comm_ring ℚ  := by apply_instance
instance : comm_ring ℚ          := by apply_instance
--instance : ring ℚ             := by apply_instance
instance : comm_semiring ℚ      := by apply_instance
instance : semiring ℚ           := by apply_instance
instance : add_comm_group ℚ     := by apply_instance
instance : add_group ℚ          := by apply_instance
instance : add_comm_monoid ℚ    := by apply_instance
instance : add_monoid ℚ         := by apply_instance
instance : add_left_cancel_semigroup ℚ := by apply_instance
instance : add_right_cancel_semigroup ℚ := by apply_instance
instance : add_comm_semigroup ℚ := by apply_instance
instance : add_semigroup ℚ      := by apply_instance
instance : comm_monoid ℚ        := by apply_instance
instance : monoid ℚ             := by apply_instance
instance : comm_semigroup ℚ     := by apply_instance
instance : semigroup ℚ          := by apply_instance

theorem sub_def {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
  a /. b - c /. d = (a * d - c * b) /. (b * d) :=
by simp [b0, d0]

protected def nonneg : ℚ → Prop
| ⟨n, d, h, c⟩ := n ≥ 0

@[simp] theorem mk_nonneg (a : ℤ) {b : ℤ} (h : b > 0) : (a /. b).nonneg ↔ a ≥ 0 :=
begin
  generalize ha : a /. b = x, cases x with n₁ d₁ h₁ c₁, rw num_denom' at ha,
  simp [rat.nonneg],
  have d0 := int.coe_nat_lt.2 h₁,
  have := (mk_eq (ne_of_gt h) (ne_of_gt d0)).1 ha,
  constructor; intro h₂,
  { apply nonneg_of_mul_nonneg_right _ d0,
    rw this, exact mul_nonneg h₂ (le_of_lt h) },
  { apply nonneg_of_mul_nonneg_right _ h,
    rw ← this, exact mul_nonneg h₂ (int.coe_zero_le _) },
end

protected def nonneg_add {a b} : rat.nonneg a → rat.nonneg b → rat.nonneg (a + b) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
begin
  have d₁0 : (d₁:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₁),
  have d₂0 : (d₂:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₂),
  simp [d₁0, d₂0, h₁, h₂, mul_pos d₁0 d₂0],
  intros n₁0 n₂0,
  apply add_nonneg; apply mul_nonneg; {assumption <|> apply int.coe_zero_le}
end

protected def nonneg_mul {a b} : rat.nonneg a → rat.nonneg b → rat.nonneg (a * b) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
begin
  have d₁0 : (d₁:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₁),
  have d₂0 : (d₂:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₂),
  simp [d₁0, d₂0, h₁, h₂, mul_pos d₁0 d₂0],
  exact mul_nonneg
end

protected def nonneg_antisymm {a} : rat.nonneg a → rat.nonneg (-a) → a = 0 :=
num_denom_cases_on' a $ λ n d h,
begin
  have d0 : (d:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h),
  simp [d0, h],
  exact λ h₁ h₂, le_antisymm (nonpos_of_neg_nonneg h₂) h₁
end

protected def nonneg_total : rat.nonneg a ∨ rat.nonneg (-a) :=
by cases a with n; exact
or.imp_right neg_nonneg_of_nonpos (le_total 0 n)

instance decidable_nonneg : decidable (rat.nonneg a) :=
by cases a; unfold rat.nonneg; apply_instance

protected def le (a b : ℚ) := rat.nonneg (b - a)

instance : has_le ℚ := ⟨rat.le⟩

instance decidable_le : decidable_rel ((≤) : ℚ → ℚ → Prop)
| a b := show decidable (rat.nonneg (b - a)), by apply_instance

protected theorem le_def {a b c d : ℤ} (b0 : b > 0) (d0 : d > 0) :
  a /. b ≤ c /. d ↔ a * d ≤ c * b :=
show rat.nonneg _ ↔ _,
by simpa [ne_of_gt b0, ne_of_gt d0, mul_pos b0 d0, mul_comm]
   using @sub_nonneg _ _ (b * c) (a * d)

protected theorem le_refl : a ≤ a :=
show rat.nonneg (a - a), by rw sub_self; exact le_refl (0 : ℤ)

protected theorem le_total : a ≤ b ∨ b ≤ a :=
by have := rat.nonneg_total (b - a); rwa neg_sub at this

protected theorem le_antisymm {a b : ℚ} (hab : a ≤ b) (hba : b ≤ a) : a = b :=
by have := eq_neg_of_add_eq_zero (rat.nonneg_antisymm hba $ by simpa);
   rwa neg_neg at this

protected theorem le_trans {a b c : ℚ} (hab : a ≤ b) (hbc : b ≤ c) : a ≤ c :=
have rat.nonneg (b - a + (c - b)), from rat.nonneg_add hab hbc,
have rat.nonneg (c - a + (b - b)), by simpa [-add_right_neg, add_left_comm],
by simpa

instance : decidable_linear_order ℚ :=
{ le              := rat.le,
  le_refl         := rat.le_refl,
  le_trans        := @rat.le_trans,
  le_antisymm     := @rat.le_antisymm,
  le_total        := rat.le_total,
  decidable_eq    := by apply_instance,
  decidable_le    := assume a b, rat.decidable_nonneg (b - a) }

/- Extra instances to short-circuit type class resolution -/
instance : has_lt ℚ                  := by apply_instance
instance : lattice.distrib_lattice ℚ := by apply_instance
instance : lattice.lattice ℚ         := by apply_instance
instance : lattice.semilattice_inf ℚ := by apply_instance
instance : lattice.semilattice_sup ℚ := by apply_instance
instance : lattice.has_inf ℚ         := by apply_instance
instance : lattice.has_sup ℚ         := by apply_instance
instance : linear_order ℚ            := by apply_instance
instance : partial_order ℚ           := by apply_instance
instance : preorder ℚ                := by apply_instance

theorem nonneg_iff_zero_le {a} : rat.nonneg a ↔ 0 ≤ a :=
show rat.nonneg a ↔ rat.nonneg (a - 0), by simp

theorem num_nonneg_iff_zero_le : ∀ {a : ℚ}, 0 ≤ a.num ↔ 0 ≤ a
| ⟨n, d, h, c⟩ := @nonneg_iff_zero_le ⟨n, d, h, c⟩

theorem mk_le {a b c d : ℤ} (h₁ : b > 0) (h₂ : d > 0) :
  a /. b ≤ c /. d ↔ a * d ≤ c * b :=
by conv in (_ ≤ _) {
  simp only [(≤), rat.le],
  rw [sub_def (ne_of_gt h₂) (ne_of_gt h₁),
      mk_nonneg _ (mul_pos h₂ h₁), ge, sub_nonneg] }

protected theorem add_le_add_left {a b c : ℚ} : c + a ≤ c + b ↔ a ≤ b :=
by unfold has_le.le rat.le; rw add_sub_add_left_eq_sub

protected theorem mul_nonneg {a b : ℚ} (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a * b :=
by rw ← nonneg_iff_zero_le at ha hb ⊢; exact rat.nonneg_mul ha hb

instance : discrete_linear_ordered_field ℚ :=
{ zero_lt_one     := dec_trivial,
  add_le_add_left := assume a b ab c, rat.add_le_add_left.2 ab,
  add_lt_add_left := assume a b ab c, lt_of_not_ge $ λ ba,
    not_le_of_lt ab $ rat.add_le_add_left.1 ba,
  mul_nonneg      := @rat.mul_nonneg,
  mul_pos         := assume a b ha hb, lt_of_le_of_ne
    (rat.mul_nonneg (le_of_lt ha) (le_of_lt hb))
    (mul_ne_zero (ne_of_lt ha).symm (ne_of_lt hb).symm).symm,
  ..rat.discrete_field, ..rat.decidable_linear_order }

/- Extra instances to short-circuit type class resolution -/
instance : linear_ordered_field ℚ                := by apply_instance
instance : decidable_linear_ordered_comm_ring ℚ  := by apply_instance
instance : linear_ordered_comm_ring ℚ            := by apply_instance
instance : linear_ordered_ring ℚ                 := by apply_instance
instance : ordered_ring ℚ                        := by apply_instance
instance : decidable_linear_ordered_semiring ℚ   := by apply_instance
instance : linear_ordered_semiring ℚ             := by apply_instance
instance : ordered_semiring ℚ                    := by apply_instance
instance : decidable_linear_ordered_comm_group ℚ := by apply_instance
instance : ordered_comm_group ℚ                  := by apply_instance
instance : ordered_cancel_comm_monoid ℚ          := by apply_instance
instance : ordered_comm_monoid ℚ                 := by apply_instance

theorem num_pos_iff_pos {a : ℚ} : 0 < a.num ↔ 0 < a :=
le_iff_le_iff_lt_iff_lt.1 $
by simpa [(by cases a; refl : (-a).num = -a.num)]
   using @num_nonneg_iff_zero_le (-a)

theorem of_int_eq_mk (z : ℤ) : of_int z = z /. 1 := num_denom' _ _ _ _

theorem coe_int_eq_mk : ∀ z : ℤ, ↑z = z /. 1
| (n : ℕ) := show (n:ℚ) = n /. 1,
  by induction n with n IH n; simp [*, show (1:ℚ) = 1 /. 1, from rfl]
| -[1+ n] := show (-(n + 1) : ℚ) = -[1+ n] /. 1, begin
  induction n with n IH, {refl},
  show -(n + 1 + 1 : ℚ) = -[1+ n.succ] /. 1,
  rw [neg_add, IH],
  simpa [show -1 = (-1) /. 1, from rfl]
end

theorem coe_int_eq_of_int (z : ℤ) : ↑z = of_int z :=
(coe_int_eq_mk z).trans (of_int_eq_mk z).symm

theorem mk_eq_div (n d : ℤ) : n /. d = (n / d : ℚ) :=
begin
  by_cases d0 : d = 0, {simp [d0, div_zero]},
  rw [division_def, coe_int_eq_mk, coe_int_eq_mk, inv_def,
      mul_def one_ne_zero d0, one_mul, mul_one]
end

/-- `floor q` is the largest integer `z` such that `z ≤ q` -/
def floor : ℚ → ℤ
| ⟨n, d, h, c⟩ := n / d

theorem le_floor {z : ℤ} : ∀ {r : ℚ}, z ≤ floor r ↔ (z : ℚ) ≤ r
| ⟨n, d, h, c⟩ := begin
  simp [floor],
  rw [num_denom'],
  have h' := int.coe_nat_lt.2 h,
  conv { to_rhs,
    rw [coe_int_eq_mk, mk_le zero_lt_one h', mul_one] },
  exact int.le_div_iff_mul_le h'
end

theorem floor_lt {r : ℚ} {z : ℤ} : floor r < z ↔ r < z :=
le_iff_le_iff_lt_iff_lt.1 le_floor

theorem floor_le (r : ℚ) : (floor r : ℚ) ≤ r :=
le_floor.1 (le_refl _)

theorem lt_succ_floor (r : ℚ) : r < (floor r).succ :=
floor_lt.1 $ int.lt_succ_self _

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

theorem floor_mono {a b : ℚ} (h : a ≤ b) : floor a ≤ floor b :=
le_floor.2 (le_trans (floor_le _) h)

@[simp] theorem floor_add_int (r : ℚ) (z : ℤ) : floor (r + z) = floor r + 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 (r : ℚ) (z : ℤ) : floor (r - z) = floor r - z :=
eq.trans (by rw [int.cast_neg]; refl) (floor_add_int _ _)

/-- `ceil q` is the smallest integer `z` such that `q ≤ z` -/
def ceil (r : ℚ) : ℤ :=
-(floor (-r))

theorem ceil_le {z : ℤ} {r : ℚ} : ceil r ≤ z ↔ r ≤ z :=
by rw [ceil, neg_le, le_floor, int.cast_neg, neg_le_neg_iff]

theorem le_ceil (r : ℚ) : r ≤ ceil r :=
ceil_le.1 (le_refl _)

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

theorem ceil_mono {a b : ℚ} (h : a ≤ b) : ceil a ≤ ceil b :=
ceil_le.2 (le_trans h (le_ceil _))

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

theorem ceil_sub_int (r : ℚ) (z : ℤ) : ceil (r - z) = ceil r - z :=
eq.trans (by rw [int.cast_neg]; refl) (ceil_add_int _ _)

/- cast (injection into fields) -/

section cast
variables {α : Type*}

section
variables [division_ring α]

/-- Construct the canonical injection from `ℚ` into an arbitrary
  division ring. If the field has positive characteristic `p`,
  we define `1 / p = 1 / 0 = 0` for consistency with our
  division by zero convention. -/
protected def cast : ℚ → α
| ⟨n, d, h, c⟩ := n / d

@[priority 0] instance cast_coe : has_coe ℚ α := ⟨rat.cast⟩

@[simp] theorem cast_of_int (n : ℤ) : (of_int n : α) = n :=
show (n / (1:ℕ) : α) = n, by rw [nat.cast_one, div_one]

@[simp] theorem cast_coe_int (n : ℤ) : ((n : ℚ) : α) = n :=
by rw [coe_int_eq_of_int, cast_of_int]

@[simp] theorem coe_int_num (n : ℤ) : (n : ℚ).num = n :=
by rw coe_int_eq_of_int; refl

@[simp] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1 :=
by rw coe_int_eq_of_int; refl

@[simp] theorem coe_nat_num (n : ℕ) : (n : ℚ).num = n :=
by rw [← int.cast_coe_nat, coe_int_num]

@[simp] theorem coe_nat_denom (n : ℕ) : (n : ℚ).denom = 1 :=
by rw [← int.cast_coe_nat, coe_int_denom]

@[simp] theorem cast_coe_nat (n : ℕ) : ((n : ℚ) : α) = n := cast_coe_int n

@[simp] theorem cast_zero : ((0 : ℚ) : α) = 0 :=
(cast_of_int _).trans int.cast_zero

@[simp] theorem cast_one : ((1 : ℚ) : α) = 1 :=
(cast_of_int _).trans int.cast_one

theorem mul_cast_comm (a : α) :
  ∀ (n : ℚ), (n.denom : α) ≠ 0 → a * n = n * a
| ⟨n, d, h, c⟩ h₂ := show a * (n * d⁻¹) = n * d⁻¹ * a,
  by rw [← mul_assoc, int.mul_cast_comm, mul_assoc, mul_assoc,
         ← show (d:α)⁻¹ * a = a * d⁻¹, from
           division_ring.inv_comm_of_comm h₂ (int.mul_cast_comm a d).symm]

theorem cast_mk_of_ne_zero (a b : ℤ)
  (b0 : (b:α) ≠ 0) : (a /. b : α) = a / b :=
begin
  have b0' : b ≠ 0, { refine mt _ b0, simp {contextual := tt} },
  cases e : a /. b with n d h c,
  have d0 : (d:α) ≠ 0,
  { intro d0,
    have dd := denom_dvd a b,
    cases (show (d:ℤ) ∣ b, by rwa e at dd) with k ke,
    have : (b:α) = (d:α) * (k:α), {rw [ke, int.cast_mul], refl},
    rw [d0, zero_mul] at this, contradiction },
  rw [num_denom'] at e,
  have := congr_arg (coe : ℤ → α) ((mk_eq b0' $ ne_of_gt $ int.coe_nat_pos.2 h).1 e),
  rw [int.cast_mul, int.cast_mul, int.cast_coe_nat] at this,
  symmetry, change (a * b⁻¹ : α) = n / d,
  rw [eq_div_iff_mul_eq _ _ d0, mul_assoc, nat.mul_cast_comm,
      ← mul_assoc, this, mul_assoc, mul_inv_cancel b0, mul_one]
end

theorem cast_add_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m + n : ℚ) : α) = m + n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 rfl),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 rfl),
  rw [num_denom', num_denom', add_def d₁0' d₂0'],
  suffices : (n₁ * (d₂ * (d₂⁻¹ * d₁⁻¹)) +
    n₂ * (d₁ * d₂⁻¹) * d₁⁻¹ : α) = n₁ * d₁⁻¹ + n₂ * d₂⁻¹,
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, left_distrib, right_distrib, mul_inv_eq,
             d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0]} },
  rw [← mul_assoc (d₂:α), mul_inv_cancel d₂0, one_mul,
      ← nat.mul_cast_comm], simp [d₁0, mul_assoc]
end

@[simp] theorem cast_neg : ∀ n, ((-n : ℚ) : α) = -n
| ⟨n, d, h, c⟩ := show (↑-n * d⁻¹ : α) = -(n * d⁻¹),
  by rw [int.cast_neg, neg_mul_eq_neg_mul]

theorem cast_sub_of_ne_zero {m n : ℚ}
  (m0 : (m.denom : α) ≠ 0) (n0 : (n.denom : α) ≠ 0) : ((m - n : ℚ) : α) = m - n :=
have ((-n).denom : α) ≠ 0, by cases n; exact n0,
by simp [m0, this, cast_add_of_ne_zero]

theorem cast_mul_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m * n : ℚ) : α) = m * n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 rfl),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 rfl),
  rw [num_denom', num_denom', mul_def d₁0' d₂0'],
  suffices : (n₁ * ((n₂ * d₂⁻¹) * d₁⁻¹) : α) = n₁ * (d₁⁻¹ * (n₂ * d₂⁻¹)),
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, mul_inv_eq, d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0]} },
  rw [division_ring.inv_comm_of_comm d₁0 (nat.mul_cast_comm _ _).symm]
end

theorem cast_inv_of_ne_zero : ∀ {n : ℚ},
  (n.num : α) ≠ 0 → (n.denom : α) ≠ 0 → ((n⁻¹ : ℚ) : α) = n⁻¹
| ⟨n, d, h, c⟩ := λ (n0 : (n:α) ≠ 0) (d0 : (d:α) ≠ 0), begin
  have n0' : (n:ℤ) ≠ 0 := λ e, by rw e at n0; exact n0 rfl,
  have d0' : (d:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d0; exact d0 rfl),
  rw [num_denom', inv_def],
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, inv_div];
  simp [n0, d0]
end

theorem cast_div_of_ne_zero {m n : ℚ} (md : (m.denom : α) ≠ 0)
  (nn : (n.num : α) ≠ 0) (nd : (n.denom : α) ≠ 0) : ((m / n : ℚ) : α) = m / n :=
have (n⁻¹.denom : ℤ) ∣ n.num,
by conv in n⁻¹.denom { rw [num_denom n, inv_def] };
   apply denom_dvd,
have (n⁻¹.denom : α) = 0 → (n.num : α) = 0, from
λ h, let ⟨k, e⟩ := this in
  by have := congr_arg (coe : ℤ → α) e;
     rwa [int.cast_mul, int.cast_coe_nat, h, zero_mul] at this,
by rw [division_def, cast_mul_of_ne_zero md (mt this nn), cast_inv_of_ne_zero nn nd, division_def]

@[simp] theorem cast_inj [char_zero α] : ∀ {m n : ℚ}, (m : α) = n ↔ m = n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := begin
  refine ⟨λ h, _, congr_arg _⟩,
  have d₁0 : d₁ ≠ 0 := ne_of_gt h₁,
  have d₂0 : d₂ ≠ 0 := ne_of_gt h₂,
  have d₁a : (d₁:α) ≠ 0 := nat.cast_ne_zero.2 d₁0,
  have d₂a : (d₂:α) ≠ 0 := nat.cast_ne_zero.2 d₂0,
  rw [num_denom', num_denom'] at h ⊢,
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero] at h; simp [d₁0, d₂0] at h ⊢,
  rwa [eq_div_iff_mul_eq _ _ d₂a, division_def, mul_assoc,
    division_ring.inv_comm_of_comm d₁a (nat.mul_cast_comm _ _),
    ← mul_assoc, ← division_def, eq_comm, eq_div_iff_mul_eq _ _ d₁a, eq_comm,
    ← int.cast_coe_nat, ← int.cast_mul, ← int.cast_coe_nat, ← int.cast_mul,
    int.cast_inj, ← mk_eq (int.coe_nat_ne_zero.2 d₁0) (int.coe_nat_ne_zero.2 d₂0)] at h
end

theorem cast_injective [char_zero α] : function.injective (coe : ℚ → α)
| m n := cast_inj.1

@[simp] theorem cast_eq_zero [char_zero α] {n : ℚ} : (n : α) = 0 ↔ n = 0 :=
by rw [← cast_zero, cast_inj]

@[simp] theorem cast_ne_zero [char_zero α] {n : ℚ} : (n : α) ≠ 0 ↔ n ≠ 0 :=
not_congr cast_eq_zero

theorem eq_cast_of_ne_zero (f : ℚ → α) (H1 : f 1 = 1)
  (Hadd : ∀ x y, f (x + y) = f x + f y)
  (Hmul : ∀ x y, f (x * y) = f x * f y) :
  ∀ n : ℚ, (n.denom : α) ≠ 0 → f n = n
| ⟨n, d, h, c⟩ := λ (h₂ : ((d:ℤ):α) ≠ 0), show _ = (n / (d:ℤ) : α), begin
  rw [num_denom', mk_eq_div, eq_div_iff_mul_eq _ _ h₂],
  have : ∀ n : ℤ, f n = n, { apply int.eq_cast; simp [H1, Hadd] },
  rw [← this, ← this, ← Hmul, div_mul_cancel],
  exact int.cast_ne_zero.2 (int.coe_nat_ne_zero.2 $ ne_of_gt h),
end

theorem eq_cast [char_zero α] (f : ℚ → α) (H1 : f 1 = 1)
  (Hadd : ∀ x y, f (x + y) = f x + f y)
  (Hmul : ∀ x y, f (x * y) = f x * f y) (n : ℚ) : f n = n :=
eq_cast_of_ne_zero _ H1 Hadd Hmul _ $
  nat.cast_ne_zero.2 $ ne_of_gt n.pos

end

theorem cast_mk [discrete_field α] [char_zero α] (a b : ℤ) : ((a /. b) : α) = a / b :=
if b0 : b = 0 then by simp [b0, div_zero]
else cast_mk_of_ne_zero a b (int.cast_ne_zero.2 b0)

@[simp] theorem cast_add [division_ring α] [char_zero α] (m n) : ((m + n : ℚ) : α) = m + n :=
cast_add_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_sub [division_ring α] [char_zero α] (m n) : ((m - n : ℚ) : α) = m - n :=
cast_sub_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_mul [division_ring α] [char_zero α] (m n) : ((m * n : ℚ) : α) = m * n :=
cast_mul_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_inv [discrete_field α] [char_zero α] (n) : ((n⁻¹ : ℚ) : α) = n⁻¹ :=
if n0 : n.num = 0 then
  by simp [show n = 0, by rw [num_denom n, n0]; simp, inv_zero] else
cast_inv_of_ne_zero (int.cast_ne_zero.2 n0) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_div [discrete_field α] [char_zero α] (m n) : ((m / n : ℚ) : α) = m / n :=
by rw [division_def, cast_mul, cast_inv, division_def]

@[simp] theorem cast_bit0 [division_ring α] [char_zero α] (n : ℚ) : ((bit0 n : ℚ) : α) = bit0 n := cast_add _ _

@[simp] theorem cast_bit1 [division_ring α] [char_zero α] (n : ℚ) : ((bit1 n : ℚ) : α) = bit1 n :=
by rw [bit1, cast_add, cast_one, cast_bit0]; refl

@[simp] theorem cast_nonneg [linear_ordered_field α] : ∀ {n : ℚ}, 0 ≤ (n : α) ↔ 0 ≤ n
| ⟨n, d, h, c⟩ := show 0 ≤ (n * d⁻¹ : α) ↔ 0 ≤ (⟨n, d, h, c⟩ : ℚ),
  by rw [num_denom', ← nonneg_iff_zero_le, mk_nonneg _ (int.coe_nat_pos.2 h),
    mul_nonneg_iff_right_nonneg_of_pos (@inv_pos α _ _ (nat.cast_pos.2 h)),
    int.cast_nonneg]

@[simp] theorem cast_le [linear_ordered_field α] {m n : ℚ} : (m : α) ≤ n ↔ m ≤ n :=
by rw [← sub_nonneg, ← cast_sub, cast_nonneg, sub_nonneg]

@[simp] theorem cast_lt [linear_ordered_field α] {m n : ℚ} : (m : α) < n ↔ m < n :=
by simpa [-cast_le] using not_congr (@cast_le α _ n m)

@[simp] theorem cast_nonpos [linear_ordered_field α] {n : ℚ} : (n : α) ≤ 0 ↔ n ≤ 0 :=
by rw [← cast_zero, cast_le]

@[simp] theorem cast_pos [linear_ordered_field α] {n : ℚ} : (0 : α) < n ↔ 0 < n :=
by rw [← cast_zero, cast_lt]

@[simp] theorem cast_lt_zero [linear_ordered_field α] {n : ℚ} : (n : α) < 0 ↔ n < 0 :=
by rw [← cast_zero, cast_lt]

@[simp] theorem cast_id : ∀ n : ℚ, ↑n = n
| ⟨n, d, h, c⟩ := show (n / (d : ℤ) : ℚ) = _, by rw [num_denom', mk_eq_div]

@[simp] theorem cast_min [discrete_linear_ordered_field α] {a b : ℚ} : (↑(min a b) : α) = min a b :=
by by_cases a ≤ b; simp [h, min]

@[simp] theorem cast_max [discrete_linear_ordered_field α] {a b : ℚ} : (↑(max a b) : α) = max a b :=
by by_cases a ≤ b; simp [h, max]

@[simp] theorem cast_abs [discrete_linear_ordered_field α] {q : ℚ} : ((abs q : ℚ) : α) = abs q :=
by simp [abs]

end cast

/- nat ceiling -/

/-- `nat_ceil q` is the smallest nonnegative integer `n` with `q ≤ n`.
  It is the same as `ceil q` when `q ≥ 0`, otherwise it is `0`. -/
def nat_ceil (q : ℚ) : ℕ := int.to_nat (ceil q)

theorem nat_ceil_le {q : ℚ} {n : ℕ} : nat_ceil q ≤ n ↔ q ≤ n :=
by rw [nat_ceil, int.to_nat_le, ceil_le]; refl

theorem lt_nat_ceil {q : ℚ} {n : ℕ} : n < nat_ceil q ↔ (n : ℚ) < q :=
not_iff_not.1 $ by rw [not_lt, not_lt, nat_ceil_le]

theorem le_nat_ceil (q : ℚ) : q ≤ nat_ceil q :=
nat_ceil_le.1 (le_refl _)

theorem nat_ceil_mono {q₁ q₂ : ℚ} (h : q₁ ≤ q₂) : nat_ceil q₁ ≤ nat_ceil q₂ :=
nat_ceil_le.2 (le_trans h (le_nat_ceil _))

@[simp] theorem nat_ceil_coe (n : ℕ) : nat_ceil n = n :=
show (ceil (n:ℤ)).to_nat = n, by rw [ceil_coe]; refl

@[simp] theorem nat_ceil_zero : nat_ceil 0 = 0 := nat_ceil_coe 0

theorem nat_ceil_add_nat {q : ℚ} (hq : 0 ≤ q) (n : ℕ) : nat_ceil (q + n) = nat_ceil q + n :=
show int.to_nat (ceil (q + (n:ℤ))) = int.to_nat (ceil q) + n,
by rw [ceil_add_int]; exact
match ceil q, int.eq_coe_of_zero_le (ceil_mono hq) with
| _, ⟨m, rfl⟩ := rfl
end

theorem nat_ceil_lt_add_one {q : ℚ} (hq : q ≥ 0) : ↑(nat_ceil q) < q + 1 :=
lt_nat_ceil.1 $ by rw [
  show nat_ceil (q+1) = nat_ceil q+1, from nat_ceil_add_nat hq 1]; apply nat.lt_succ_self

@[simp] lemma denom_neg_eq_denom : ∀ q : ℚ, (-q).denom = q.denom
| ⟨_, d, _, _⟩ := rfl

@[simp] lemma num_neg_eq_neg_num : ∀ q : ℚ, (-q).num = -(q.num)
| ⟨n, _, _, _⟩ := rfl

@[simp] lemma num_zero : rat.num 0 = 0 := rfl

lemma zero_of_num_zero {q : ℚ} (hq : q.num = 0) : q = 0 :=
have q = q.num /. q.denom, from num_denom _,
by simpa [hq]

lemma num_ne_zero_of_ne_zero {q : ℚ} (h : q ≠ 0) : q.num ≠ 0 :=
assume : q.num = 0,
h $ zero_of_num_zero this

lemma denom_ne_zero (q : ℚ) : q.denom ≠ 0 :=
ne_of_gt q.pos

lemma mk_num_ne_zero_of_ne_zero {q : ℚ} {n d : ℤ} (hq : q ≠ 0) (hqnd : q = n /. d) : n ≠ 0 :=
assume : n = 0,
hq $ by simpa [this] using hqnd

lemma mk_denom_ne_zero_of_ne_zero {q : ℚ} {n d : ℤ} (hq : q ≠ 0) (hqnd : q = n /. d) : d ≠ 0 :=
assume : d = 0,
hq $ by simpa [this] using hqnd

lemma mk_ne_zero_of_ne_zero {n d : ℤ} (h : n ≠ 0) (hd : d ≠ 0) : n /. d ≠ 0 :=
assume : n /. d = 0,
h $ (mk_eq_zero hd).1 this

lemma mul_num_denom (q r : ℚ) : q * r = (q.num * r.num) /. ↑(q.denom * r.denom) :=
have hq' : (↑q.denom : ℤ) ≠ 0, by have := denom_ne_zero q; simpa,
have hr' : (↑r.denom : ℤ) ≠ 0, by have := denom_ne_zero r; simpa,
suffices (q.num /. ↑q.denom) * (r.num /. ↑r.denom) = (q.num * r.num) /. ↑(q.denom * r.denom),
  by rwa [←num_denom q, ←num_denom r] at this,
by simp [mul_def hq' hr']

lemma num_denom_mk {q : ℚ} {n d : ℤ} (hn : n ≠ 0) (hd : d ≠ 0) (qdf : q = n /. d) :
      ∃ c : ℤ, n = c * q.num ∧ d = c * q.denom :=
have hq : q ≠ 0, from
  assume : q = 0,
  hn $ (rat.mk_eq_zero hd).1 (by cc),
have q.num /. q.denom = n /. d, by rwa [←rat.num_denom q],
have q.num * d = n * ↑(q.denom), from (rat.mk_eq (by simp [rat.denom_ne_zero]) hd).1 this,
begin
  existsi n / q.num,
  have hqdn : q.num ∣ n, begin rw qdf, apply rat.num_dvd, assumption end,
  split,
    { rw int.div_mul_cancel hqdn },
    { apply int.eq_mul_div_of_mul_eq_mul_of_dvd_left,
      {apply rat.num_ne_zero_of_ne_zero hq},
      {simp [rat.denom_ne_zero]},
      repeat {assumption} }
end
end rat


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

/-! # Semiquotients

A data type for semiquotients, which are classically equivalent to
nonempty sets, but are useful for programming; the idea is that
a semiquotient set `S` represents some (particular but unknown)
element of `S`. This can be used to model nondeterministic functions,
which return something in a range of values (represented by the
predicate `S`) but are not completely determined.
-/

/-- A member of `semiquot α` is classically a nonempty `set α`,
  and in the VM is represented by an element of `α`; the relation
  between these is that the VM element is required to be a member
  of the set `s`. The specific element of `s` that the VM computes
  is hidden by a quotient construction, allowing for the representation
  of nondeterministic functions. -/
structure {u} semiquot (α : Type*) := mk' ::
(s : set α)
(val : trunc ↥s)

namespace semiquot
variables {α : Type*} {β : Type*}

instance : has_mem α (semiquot α) := ⟨λ a q, a ∈ q.s⟩

/-- Construct a `semiquot α` from `h : a ∈ s` where `s : set α`. -/
def mk {a : α} {s : set α} (h : a ∈ s) : semiquot α :=
⟨s, trunc.mk ⟨a, h⟩⟩

theorem ext_s {q₁ q₂ : semiquot α} : q₁ = q₂ ↔ q₁.s = q₂.s :=
begin
  refine ⟨congr_arg _, λ h, _⟩,
  cases q₁,
  cases q₂,
  cc,
end

theorem ext {q₁ q₂ : semiquot α} : q₁ = q₂ ↔ ∀ a, a ∈ q₁ ↔ a ∈ q₂ :=
ext_s.trans set.ext_iff

theorem exists_mem (q : semiquot α) : ∃ a, a ∈ q :=
let ⟨⟨a, h⟩, h₂⟩ := q.2.exists_rep in ⟨a, h⟩

theorem eq_mk_of_mem {q : semiquot α} {a : α} (h : a ∈ q) :
  q = @mk _ a q.1 h := ext_s.2 rfl

theorem nonempty (q : semiquot α) : q.s.nonempty := q.exists_mem

/-- `pure a` is `a` reinterpreted as an unspecified element of `{a}`. -/
protected def pure (a : α) : semiquot α := mk (set.mem_singleton a)

@[simp] theorem mem_pure' {a b : α} : a ∈ semiquot.pure b ↔ a = b :=
set.mem_singleton_iff

/-- Replace `s` in a `semiquot` with a superset. -/
def blur' (q : semiquot α) {s : set α} (h : q.s ⊆ s) : semiquot α :=
⟨s, trunc.lift (λ a : q.s, trunc.mk ⟨a.1, h a.2⟩)
  (λ _ _, trunc.eq _ _) q.2⟩

/-- Replace `s` in a `q : semiquot α` with a union `s ∪ q.s` -/
def blur (s : set α) (q : semiquot α) : semiquot α :=
blur' q (set.subset_union_right s q.s)

theorem blur_eq_blur' (q : semiquot α) (s : set α) (h : q.s ⊆ s) :
  blur s q = blur' q h :=
by unfold blur; congr; exact set.union_eq_self_of_subset_right h

@[simp] theorem mem_blur' (q : semiquot α) {s : set α} (h : q.s ⊆ s)
  {a : α} : a ∈ blur' q h ↔ a ∈ s := iff.rfl

/-- Convert a `trunc α` to a `semiquot α`. -/
def of_trunc (q : trunc α) : semiquot α :=
⟨set.univ, q.map (λ a, ⟨a, trivial⟩)⟩

/-- Convert a `semiquot α` to a `trunc α`. -/
def to_trunc (q : semiquot α) : trunc α :=
q.2.map subtype.val

/-- If `f` is a constant on `q.s`, then `q.lift_on f` is the value of `f`
at any point of `q`. -/
def lift_on (q : semiquot α) (f : α → β) (h : ∀ a b ∈ q, f a = f b) : β :=
trunc.lift_on q.2 (λ x, f x.1) (λ x y, h _ x.2 _ y.2)

theorem lift_on_of_mem (q : semiquot α)
  (f : α → β) (h : ∀ a b ∈ q, f a = f b)
  (a : α) (aq : a ∈ q) : lift_on q f h = f a :=
by revert h; rw eq_mk_of_mem aq; intro; refl

/-- Apply a function to the unknown value stored in a `semiquot α`. -/
def map (f : α → β) (q : semiquot α) : semiquot β :=
⟨f '' q.1, q.2.map (λ x, ⟨f x.1, set.mem_image_of_mem _ x.2⟩)⟩

@[simp] theorem mem_map (f : α → β) (q : semiquot α) (b : β) :
  b ∈ map f q ↔ ∃ a, a ∈ q ∧ f a = b := set.mem_image _ _ _

/-- Apply a function returning a `semiquot` to a `semiquot`. -/
def bind (q : semiquot α) (f : α → semiquot β) : semiquot β :=
⟨⋃ a ∈ q.1, (f a).1,
 q.2.bind (λ a, (f a.1).2.map (λ b, ⟨b.1, set.mem_bUnion a.2 b.2⟩))⟩

@[simp] theorem mem_bind (q : semiquot α) (f : α → semiquot β) (b : β) :
  b ∈ bind q f ↔ ∃ a ∈ q, b ∈ f a := set.mem_Union₂

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

@[simp] lemma map_def {β} : ((<$>) : (α → β) → semiquot α → semiquot β) = map := rfl
@[simp] lemma bind_def {β} : ((>>=) : semiquot α → (α → semiquot β) → semiquot β) = bind := rfl

@[simp]

theorem mem_pure_self (a : α) : a ∈ (pure a : semiquot α) :=
set.mem_singleton a

@[simp] theorem pure_inj {a b : α} : (pure a : semiquot α) = pure b ↔ a = b :=
ext_s.trans set.singleton_eq_singleton_iff

instance : is_lawful_monad semiquot :=
{ pure_bind  := λ α β x f, ext.2 $ by simp,
  bind_assoc := λ α β γ s f g, ext.2 $ by simp; exact
    λ c, ⟨λ ⟨b, ⟨a, as, bf⟩, cg⟩, ⟨a, as, b, bf, cg⟩,
          λ ⟨a, as, b, bf, cg⟩, ⟨b, ⟨a, as, bf⟩, cg⟩⟩,
  id_map     := λ α q, ext.2 $ by simp,
  bind_pure_comp_eq_map := λ α β f s, ext.2 $ by simp [eq_comm] }

instance : has_le (semiquot α) := ⟨λ s t, s.s ⊆ t.s⟩

instance : partial_order (semiquot α) :=
{ le := λ s t, ∀ ⦃x⦄, x ∈ s → x ∈ t,
  le_refl := λ s, set.subset.refl _,
  le_trans := λ s t u, set.subset.trans,
  le_antisymm := λ s t h₁ h₂, ext_s.2 (set.subset.antisymm h₁ h₂) }

instance : semilattice_sup (semiquot α) :=
{ sup := λ s, blur s.s,
  le_sup_left := λ s t, set.subset_union_left _ _,
  le_sup_right := λ s t, set.subset_union_right _ _,
  sup_le := λ s t u, set.union_subset,
  ..semiquot.partial_order }

@[simp] theorem pure_le {a : α} {s : semiquot α} : pure a ≤ s ↔ a ∈ s :=
set.singleton_subset_iff

/-- Assert that a `semiquot` contains only one possible value. -/
def is_pure (q : semiquot α) : Prop := ∀ a b ∈ q, a = b

/-- Extract the value from a `is_pure` semiquotient. -/
def get (q : semiquot α) (h : q.is_pure) : α := lift_on q id h

theorem get_mem {q : semiquot α} (p) : get q p ∈ q :=
let ⟨a, h⟩ := exists_mem q in
by unfold get; rw lift_on_of_mem q _ _ a h; exact h

theorem eq_pure {q : semiquot α} (p) : q = pure (get q p) :=
ext.2 $ λ a, by simp; exact
⟨λ h, p _ h _ (get_mem _), λ e, e.symm ▸ get_mem _⟩

@[simp] theorem pure_is_pure (a : α) : is_pure (pure a)
| b ab c ac := by { rw [mem_pure] at ab ac, cc }

theorem is_pure_iff {s : semiquot α} : is_pure s ↔ ∃ a, s = pure a :=
⟨λ h, ⟨_, eq_pure h⟩, λ ⟨a, e⟩, e.symm ▸ pure_is_pure _⟩

theorem is_pure.mono {s t : semiquot α}
  (st : s ≤ t) (h : is_pure t) : is_pure s
| a as b bs := h _ (st as) _ (st bs)

theorem is_pure.min {s t : semiquot α} (h : is_pure t) : s ≤ t ↔ s = t :=
⟨λ st, le_antisymm st $ by rw [eq_pure h, eq_pure (h.mono st)]; simp;
   exact h _ (get_mem _) _ (st $ get_mem _),
 le_of_eq⟩

theorem is_pure_of_subsingleton [subsingleton α] (q : semiquot α) : is_pure q
| a b aq bq := subsingleton.elim _ _

/-- `univ : semiquot α` represents an unspecified element of `univ : set α`. -/
def univ [inhabited α] : semiquot α :=
mk $ set.mem_univ default

instance [inhabited α] : inhabited (semiquot α) := ⟨univ⟩

@[simp] theorem mem_univ [inhabited α] : ∀ a, a ∈ @univ α _ :=
@set.mem_univ α

@[congr] theorem univ_unique (I J : inhabited α) : @univ _ I = @univ _ J :=
ext.2 $ by simp

@[simp] theorem is_pure_univ [inhabited α] : @is_pure α univ ↔ subsingleton α :=
⟨λ h, ⟨λ a b, h a trivial b trivial⟩, λ ⟨h⟩ a _ b _, h a b⟩

instance [inhabited α] : order_top (semiquot α) :=
{ top := univ,
  le_top := λ s, set.subset_univ _ }

end semiquot


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Jujian Zhang

! This file was ported from Lean 3 source module algebra.direct_sum.decomposition
! leanprover-community/mathlib commit 4e861f25ba5ceef42ba0712d8ffeb32f38ad6441
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.DirectSum.Module
import Mathbin.Algebra.Module.Submodule.Basic

/-!
# Decompositions of additive monoids, groups, and modules into direct sums

## Main definitions

* `direct_sum.decomposition ℳ`: A typeclass to provide a constructive decomposition from
  an additive monoid `M` into a family of additive submonoids `ℳ`
* `direct_sum.decompose ℳ`: The canonical equivalence provided by the above typeclass

## Main statements

* `direct_sum.decomposition.is_internal`: The link to `direct_sum.is_internal`.

## Implementation details

As we want to talk about different types of decomposition (additive monoids, modules, rings, ...),
we choose to avoid heavily bundling `direct_sum.decompose`, instead making copies for the
`add_equiv`, `linear_equiv`, etc. This means we have to repeat statements that follow from these
bundled homs, but means we don't have to repeat statements for different types of decomposition.
-/

variable {ι R M σ : Type _}

open DirectSum BigOperators

namespace DirectSum

section AddCommMonoid

variable [DecidableEq ι] [AddCommMonoid M]

variable [SetLike σ M] [AddSubmonoidClass σ M] (ℳ : ι → σ)

/-- A decomposition is an equivalence between an additive monoid `M` and a direct sum of additive
submonoids `ℳ i` of that `M`, such that the "recomposition" is canonical. This definition also
works for additive groups and modules.

This is a version of `direct_sum.is_internal` which comes with a constructive inverse to the
canonical "recomposition" rather than just a proof that the "recomposition" is bijective. -/
class Decomposition where
  decompose' : M → ⨁ i, ℳ i
  left_inv : Function.LeftInverse (DirectSum.coeAddMonoidHom ℳ) decompose'
  right_inv : Function.RightInverse (DirectSum.coeAddMonoidHom ℳ) decompose'
#align direct_sum.decomposition DirectSum.Decomposition

include M

/-- `direct_sum.decomposition` instances, while carrying data, are always equal. -/
instance : Subsingleton (Decomposition ℳ) :=
  ⟨fun x y => by
    cases' x with x xl xr
    cases' y with y yl yr
    congr
    exact Function.LeftInverse.eq_rightInverse xr yl⟩

variable [Decomposition ℳ]

protected theorem Decomposition.isInternal : DirectSum.IsInternal ℳ :=
  ⟨Decomposition.right_inv.Injective, Decomposition.left_inv.Surjective⟩
#align direct_sum.decomposition.is_internal DirectSum.Decomposition.isInternal

/-- If `M` is graded by `ι` with degree `i` component `ℳ i`, then it is isomorphic as
to a direct sum of components. This is the canonical spelling of the `decompose'` field. -/
def decompose : M ≃ ⨁ i, ℳ i where
  toFun := Decomposition.decompose'
  invFun := DirectSum.coeAddMonoidHom ℳ
  left_inv := Decomposition.left_inv
  right_inv := Decomposition.right_inv
#align direct_sum.decompose DirectSum.decompose

protected theorem Decomposition.inductionOn {p : M → Prop} (h_zero : p 0)
    (h_homogeneous : ∀ {i} (m : ℳ i), p (m : M)) (h_add : ∀ m m' : M, p m → p m' → p (m + m')) :
    ∀ m, p m :=
  by
  let ℳ' : ι → AddSubmonoid M := fun i =>
    (⟨ℳ i, fun _ _ => AddMemClass.add_mem, ZeroMemClass.zero_mem _⟩ : AddSubmonoid M)
  haveI t : DirectSum.Decomposition ℳ' :=
    { decompose' := DirectSum.decompose ℳ
      left_inv := fun _ => (decompose ℳ).left_inv _
      right_inv := fun _ => (decompose ℳ).right_inv _ }
  have mem : ∀ m, m ∈ supᵢ ℳ' := fun m =>
    (DirectSum.IsInternal.addSubmonoid_supᵢ_eq_top ℳ' (decomposition.is_internal ℳ')).symm ▸ trivial
  exact fun m =>
    AddSubmonoid.supᵢ_induction ℳ' (mem m) (fun i m h => h_homogeneous ⟨m, h⟩) h_zero h_add
#align direct_sum.decomposition.induction_on DirectSum.Decomposition.inductionOn

@[simp]
theorem Decomposition.decompose'_eq : Decomposition.decompose' = decompose ℳ :=
  rfl
#align direct_sum.decomposition.decompose'_eq DirectSum.Decomposition.decompose'_eq

@[simp]
theorem decompose_symm_of {i : ι} (x : ℳ i) : (decompose ℳ).symm (DirectSum.of _ i x) = x :=
  DirectSum.coeAddMonoidHom_of ℳ _ _
#align direct_sum.decompose_symm_of DirectSum.decompose_symm_of

@[simp]
theorem decompose_coe {i : ι} (x : ℳ i) : decompose ℳ (x : M) = DirectSum.of _ i x := by
  rw [← decompose_symm_of, Equiv.apply_symm_apply]
#align direct_sum.decompose_coe DirectSum.decompose_coe

theorem decompose_of_mem {x : M} {i : ι} (hx : x ∈ ℳ i) :
    decompose ℳ x = DirectSum.of (fun i => ℳ i) i ⟨x, hx⟩ :=
  decompose_coe _ ⟨x, hx⟩
#align direct_sum.decompose_of_mem DirectSum.decompose_of_mem

theorem decompose_of_mem_same {x : M} {i : ι} (hx : x ∈ ℳ i) : (decompose ℳ x i : M) = x := by
  rw [decompose_of_mem _ hx, DirectSum.of_eq_same, Subtype.coe_mk]
#align direct_sum.decompose_of_mem_same DirectSum.decompose_of_mem_same

theorem decompose_of_mem_ne {x : M} {i j : ι} (hx : x ∈ ℳ i) (hij : i ≠ j) :
    (decompose ℳ x j : M) = 0 := by
  rw [decompose_of_mem _ hx, DirectSum.of_eq_of_ne _ _ _ _ hij, ZeroMemClass.coe_zero]
#align direct_sum.decompose_of_mem_ne DirectSum.decompose_of_mem_ne

/-- If `M` is graded by `ι` with degree `i` component `ℳ i`, then it is isomorphic as
an additive monoid to a direct sum of components. -/
@[simps (config := { fullyApplied := false })]
def decomposeAddEquiv : M ≃+ ⨁ i, ℳ i :=
  AddEquiv.symm { (decompose ℳ).symm with map_add' := map_add (DirectSum.coeAddMonoidHom ℳ) }
#align direct_sum.decompose_add_equiv DirectSum.decomposeAddEquiv

@[simp]
theorem decompose_zero : decompose ℳ (0 : M) = 0 :=
  map_zero (decomposeAddEquiv ℳ)
#align direct_sum.decompose_zero DirectSum.decompose_zero

@[simp]
theorem decompose_symm_zero : (decompose ℳ).symm 0 = (0 : M) :=
  map_zero (decomposeAddEquiv ℳ).symm
#align direct_sum.decompose_symm_zero DirectSum.decompose_symm_zero

@[simp]
theorem decompose_add (x y : M) : decompose ℳ (x + y) = decompose ℳ x + decompose ℳ y :=
  map_add (decomposeAddEquiv ℳ) x y
#align direct_sum.decompose_add DirectSum.decompose_add

@[simp]
theorem decompose_symm_add (x y : ⨁ i, ℳ i) :
    (decompose ℳ).symm (x + y) = (decompose ℳ).symm x + (decompose ℳ).symm y :=
  map_add (decomposeAddEquiv ℳ).symm x y
#align direct_sum.decompose_symm_add DirectSum.decompose_symm_add

@[simp]
theorem decompose_sum {ι'} (s : Finset ι') (f : ι' → M) :
    decompose ℳ (∑ i in s, f i) = ∑ i in s, decompose ℳ (f i) :=
  map_sum (decomposeAddEquiv ℳ) f s
#align direct_sum.decompose_sum DirectSum.decompose_sum

@[simp]
theorem decompose_symm_sum {ι'} (s : Finset ι') (f : ι' → ⨁ i, ℳ i) :
    (decompose ℳ).symm (∑ i in s, f i) = ∑ i in s, (decompose ℳ).symm (f i) :=
  map_sum (decomposeAddEquiv ℳ).symm f s
#align direct_sum.decompose_symm_sum DirectSum.decompose_symm_sum

theorem sum_support_decompose [∀ (i) (x : ℳ i), Decidable (x ≠ 0)] (r : M) :
    (∑ i in (decompose ℳ r).support, (decompose ℳ r i : M)) = r :=
  by
  conv_rhs =>
    rw [← (decompose ℳ).symm_apply_apply r, ← sum_support_of (fun i => ℳ i) (decompose ℳ r)]
  rw [decompose_symm_sum]
  simp_rw [decompose_symm_of]
#align direct_sum.sum_support_decompose DirectSum.sum_support_decompose

end AddCommMonoid

/-- The `-` in the statements below doesn't resolve without this line.

This seems to a be a problem of synthesized vs inferred typeclasses disagreeing. If we replace
the statement of `decompose_neg` with `@eq (⨁ i, ℳ i) (decompose ℳ (-x)) (-decompose ℳ x)`
instead of `decompose ℳ (-x) = -decompose ℳ x`, which forces the typeclasses needed by `⨁ i, ℳ i` to
be found by unification rather than synthesis, then everything works fine without this instance. -/
instance addCommGroupSetLike [AddCommGroup M] [SetLike σ M] [AddSubgroupClass σ M] (ℳ : ι → σ) :
    AddCommGroup (⨁ i, ℳ i) := by infer_instance
#align direct_sum.add_comm_group_set_like DirectSum.addCommGroupSetLike

section AddCommGroup

variable [DecidableEq ι] [AddCommGroup M]

variable [SetLike σ M] [AddSubgroupClass σ M] (ℳ : ι → σ)

variable [Decomposition ℳ]

include M

@[simp]
theorem decompose_neg (x : M) : decompose ℳ (-x) = -decompose ℳ x :=
  map_neg (decomposeAddEquiv ℳ) x
#align direct_sum.decompose_neg DirectSum.decompose_neg

@[simp]
theorem decompose_symm_neg (x : ⨁ i, ℳ i) : (decompose ℳ).symm (-x) = -(decompose ℳ).symm x :=
  map_neg (decomposeAddEquiv ℳ).symm x
#align direct_sum.decompose_symm_neg DirectSum.decompose_symm_neg

@[simp]
theorem decompose_sub (x y : M) : decompose ℳ (x - y) = decompose ℳ x - decompose ℳ y :=
  map_sub (decomposeAddEquiv ℳ) x y
#align direct_sum.decompose_sub DirectSum.decompose_sub

@[simp]
theorem decompose_symm_sub (x y : ⨁ i, ℳ i) :
    (decompose ℳ).symm (x - y) = (decompose ℳ).symm x - (decompose ℳ).symm y :=
  map_sub (decomposeAddEquiv ℳ).symm x y
#align direct_sum.decompose_symm_sub DirectSum.decompose_symm_sub

end AddCommGroup

section Module

variable [DecidableEq ι] [Semiring R] [AddCommMonoid M] [Module R M]

variable (ℳ : ι → Submodule R M)

variable [Decomposition ℳ]

include M

/-- If `M` is graded by `ι` with degree `i` component `ℳ i`, then it is isomorphic as
a module to a direct sum of components. -/
@[simps (config := { fullyApplied := false })]
def decomposeLinearEquiv : M ≃ₗ[R] ⨁ i, ℳ i :=
  LinearEquiv.symm
    { (decomposeAddEquiv ℳ).symm with map_smul' := map_smul (DirectSum.coeLinearMap ℳ) }
#align direct_sum.decompose_linear_equiv DirectSum.decomposeLinearEquiv

@[simp]
theorem decompose_smul (r : R) (x : M) : decompose ℳ (r • x) = r • decompose ℳ x :=
  map_smul (decomposeLinearEquiv ℳ) r x
#align direct_sum.decompose_smul DirectSum.decompose_smul

end Module

end DirectSum


import galois.data.bounded_list
import galois.list.take_drop_lemmas
import galois.list.member

universes u v

namespace merkle

structure combine_result (Link Data : Type) :=
(root : Data)
(left : Link)
(right : Link)

/-- Operations needed to build a Merkle tree.-/
structure ops (Leaf Link Data : Type) :=
(empty_root : Data)
(leaf_data : Leaf → Data)
(combine_data : Data -> Data → combine_result Link Data)
/-- This stores information about a path from a leaf to a root.

 max_req_level bounds the length of the links.
-/
structure path (Leaf Link : Type) (max_req_level : ℕ) :=
(leaf  : Leaf)
(links : bounded_list Link max_req_level)

/-- This represents a result of computing a merkle tree-/
structure result (Leaf Link Data : Type) (max_req_level : ℕ) :=
-- what we are aggregating
(root : Data)
-- the paths through the tree to get to this point
(paths : list (path Leaf Link max_req_level))
-- what we have not yet aggregated
(remaining : list Leaf)

section path

parameters {Leaf Link : Type}

def path.extend_none {n:ℕ} (p : path Leaf Link n)
: path Leaf Link n.succ :=
  { links := p.links.extend 1
  , leaf  := p.leaf
  }

theorem path.leaf_extend_none (n : ℕ)
: path.leaf ∘ @path.extend_none n = path.leaf :=
begin
  apply funext,
  intro p,
  cases p,
  simp [function.comp, path.extend_none],
end

def path.extend_sibling {n : ℕ}
    (l : Link)
    (p : path Leaf Link n)
: path Leaf Link n.succ :=
{ links := p.links.cons l
, leaf  := p.leaf
}

theorem path.leaf_extend_sibling (n : ℕ) (l : Link)
: path.leaf ∘ @path.extend_sibling n l = path.leaf :=
begin
  apply funext,
  intro p,
  cases p,
  simp [function.comp, path.extend_sibling],
end

end path

section merkle

-- This contains the types for the leaves of the tree and link elements
parameters {Leaf Link Data : Type}
parameter (ops : ops Leaf Link Data)

def merkle_core
     : Π (n : ℕ) (e : Leaf) (rest : list Leaf), result Leaf Link Data n
| 0 e rest :=
{ root := ops.leaf_data e
, paths := [{ leaf := e
            , links := bounded_list.nil
            }]
, remaining := rest
}
| (nat.succ n) e rest := do
  let left_result := merkle_core n e rest in
  match left_result.remaining with
  | [] :=
      { root := left_result.root
      , paths := left_result.paths.map path.extend_none
      , remaining := []
      }
  | (e' :: rest') :=
      let right_result := merkle_core n e' rest' in
      let z := ops.combine_data left_result.root right_result.root in
      { root := z.root
      , paths := left_result.paths.map  (path.extend_sibling z.left)
              ++ right_result.paths.map (path.extend_sibling z.right)
      , remaining := right_result.remaining
      }
  end

section proofs

theorem merkle_core_ind
  {P : ℕ → Leaf → list Leaf → Prop}
  (n : ℕ) (e : Leaf) (l : list Leaf)
  (base : ∀ (e:Leaf) (l:list Leaf), P 0 e l)
  (ind1 : ∀ (n:ℕ) (e:Leaf) (l:list Leaf)
      (pr : (merkle_core n e l).remaining = list.nil)
      (ind : P n e l), P n.succ e l)
  (ind2 : ∀ (n:ℕ) (e:Leaf) (l:list Leaf) (v : Leaf) (r : list Leaf)
      (pr : (merkle_core n e l).remaining = v :: r)
      (ind : P n e l), P n.succ e l)

: P n e l :=
begin
  induction n,
  case nat.zero { apply base },
  case nat.succ m ind {
    destruct (merkle_core ops m e l).remaining,
    { intro rl,
      exact ind1 m e l rl ind,
    },
    {
      intros v r rl,
      exact ind2 m e l v r rl ind,
    }
  }

end

parameters (n :ℕ) (e : Leaf) (l : list Leaf)

theorem merkle_core_paths_ne : (merkle_core n e l).paths ≠ [] :=
begin
  induction n,
  { simp [merkle_core], },
  case nat.succ n ind {
    simp [merkle_core],
    cases (merkle_core ops n e l).remaining,
    all_goals {
      simp [merkle_core],
      cases (merkle_core ops n e l).paths,
      { contradiction, },
      { simp, },
    },
  }
end

theorem merkle_core_remaining (n:ℕ) (e : Leaf) (l : list Leaf)
: (merkle_core n e l).remaining = l.drop (2^n-1) :=
begin
  revert e l,
  induction n,
  case nat.zero {
    intros e l,
    simp [merkle_core],
  },
  case nat.succ n ind {
    intros e l,
    simp only [merkle_core, ind],
    have h : (2^nat.succ n - 1) = (2^n-1) + 2^n,
    {
      simp [nat.pow, nat.succ_mul],
      simp [nat.add_sub_assoc, nat.one_le_pow, nat.succ_le_succ_iff
           , nat.zero_le],
    },
    rw [h, list.drop_add],
    cases (l.drop (2^n - 1)) with r rest,
    { simp [merkle_core], },
    { simp [merkle_core, ind, nat.pow_is_zero_iff], },
  },
end

theorem merkle_core_list_lengths (n:ℕ) (e : Leaf) (l : list Leaf)
: (merkle_core n e l).paths.length + (merkle_core n e l).remaining.length
   = l.length + 1 :=
begin
  revert e l,
  induction n,
  case nat.zero {
    intros e l,
    simp [merkle_core],
  },
  case nat.succ n ind {
    intros e l,
    simp only [merkle_core],
    destruct (merkle_core ops n e l).remaining,
    case list.nil {
      intro eq,
      rw [eq],
      simp only [merkle_core, list.length_map],
      have pr := ind e l, rw [eq] at pr,
      apply pr,
    },
    case list.cons {
      intros r rest eq, rw [eq],
      simp only [merkle_core, list.length_append, list.length_map],
      rw [ add_assoc, ind],
      have final := ind e l,
      rw [eq] at final,
      exact final,
    }
  },
end

end proofs

def merkle
     : Π (n : ℕ) (l : list Leaf), result Leaf Link Data n
| n [] :=
{ root := ops.empty_root
, paths := []
, remaining := []
}
| n (e::r) := merkle_core n e r

section merkel_proofs

parameters (n : ℕ) (l : list Leaf)

theorem merkle_paths_ne (pr : l ≠ []) : (merkle n l).paths ≠ [] :=
begin
  cases l,
  { contradiction, },
  case list.cons e r {
    simp [merkle],
    apply merkle_core_paths_ne,
  }
end

theorem merkle_paths_length (n:ℕ) (l : list Leaf)
: (merkle n l).paths.length = min (2^n) l.length :=
begin
  cases l,
  case list.nil { simp [merkle], },
  case list.cons e l {
    simp [merkle],
    have pr := merkle_core_list_lengths ops n e l,
    simp [merkle_core_remaining] at pr,
    admit,
  },
end

theorem merkel_paths_nth_leaf  {n:ℕ} {l : list Leaf}
   {idx : ℕ}
   {r : Leaf}
   (r_at_idx : l.nth idx = some r)
   {p : path Leaf Link n}
   (pr : (merkle n l).paths.nth idx = some p)
: p.leaf = r :=
begin
  admit
end

end merkel_proofs

end merkle

end merkle


import lovelib

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

structure sig := (name : string)

structure relation := (name : string) (sigs : list sig)

structure atom := (name : string) (sig : sig)

def sig_bound := sig → set atom

structure sig_bounds :=
(lower : sig_bound)
(upper : sig_bound)

def rel_bound := relation → set (list atom)

structure rel_bounds :=
(lower : rel_bound)
(upper : rel_bound)

structure all_bounds :=
(sigs : sig_bounds)
(rels : rel_bounds)

--For now, ignore `join`
--For now, each bind must include a list of atoms
--For now, ignore `not in`
inductive inst : Type
| and : inst → inst → inst
| sig_in_atoms : sig → set atom → inst
| atoms_in_sig : set atom → sig → inst
| rel_in_atoms : relation → set (list atom) → inst
| atoms_in_rel : set (list atom) → relation → inst

def refine_bounds [decidable_eq sig] [decidable_eq relation] : inst → all_bounds → all_bounds
| (inst.and i1 i2) (bounds : all_bounds) := refine_bounds i2 (refine_bounds i1 bounds)
| (inst.sig_in_atoms s1 atoms) (bounds : all_bounds) :=
  all_bounds.mk (
    sig_bounds.mk bounds.sigs.lower (
      λ(s : sig),
        if s = s1 then
          atoms ∩ (bounds.sigs.upper s)
        else
          bounds.sigs.upper s
    )
  ) bounds.rels
| (inst.atoms_in_sig atoms s1) (bounds : all_bounds) :=
  all_bounds.mk (
    sig_bounds.mk (
      λ(s : sig),
        if s = s1 then
          atoms ∪ (bounds.sigs.lower s)
        else
          bounds.sigs.lower s
    ) bounds.sigs.upper
  ) bounds.rels
| (inst.rel_in_atoms r1 atoms) (bounds : all_bounds) :=
  all_bounds.mk bounds.sigs (
    rel_bounds.mk bounds.rels.lower (
      λ(r : relation),
        if r = r1 then
          atoms ∩ (bounds.rels.upper r)
        else
          bounds.rels.upper r
    )
  )
| (inst.atoms_in_rel atoms r1) (bounds : all_bounds) :=
  all_bounds.mk bounds.sigs (
    rel_bounds.mk (
      λ(r : relation),
        if r = r1 then
          atoms ∪ (bounds.rels.lower r)
        else
          bounds.rels.lower r
    ) bounds.rels.upper
  )

lemma bounds_conflict_carries_for_sig [decidable_eq sig] [decidable_eq atom] [decidable_eq relation] (s1 : sig) (lower upper : set atom) :
  (lower ⊆ upper) ↔
    ((refine_bounds (inst.and (inst.sig_in_atoms s1 upper) (inst.atoms_in_sig lower s1))
                       (all_bounds.mk (sig_bounds.mk (λx, ∅) (λx, set.univ))
                                      (rel_bounds.mk (λx, ∅) (λx, set.univ)))).sigs.lower s1)
        ⊆
       ((refine_bounds (inst.and (inst.sig_in_atoms s1 upper) (inst.atoms_in_sig lower s1))
                       (all_bounds.mk (sig_bounds.mk (λx, ∅) (λx, set.univ))
                                      (rel_bounds.mk (λx, ∅) (λx, set.univ)))).sigs.upper s1) :=
begin
  have hlower : lower = (refine_bounds (inst.and (inst.sig_in_atoms s1 upper) (inst.atoms_in_sig lower s1))
                       (all_bounds.mk (sig_bounds.mk (λx, ∅) (λx, set.univ))
                                      (rel_bounds.mk (λx, ∅) (λx, set.univ)))).sigs.lower s1 :=
      begin
         calc lower
             = (λ(s : sig), if s = s1 then (lower ∪ ∅) else ∅) s1 :
          by simp
        ... = (sig_bounds.mk (λ(s : sig), if s = s1 then (lower ∪ ∅) else ∅)
                             (λ(s : sig), if s = s1 then (upper ∩ set.univ) else set.univ)).lower s1 :
          by simp
         ... = (all_bounds.mk (sig_bounds.mk (λ(s : sig), if s = s1 then (lower ∪ ∅) else ∅)
                                             (λ(s : sig), if s = s1 then (upper ∩ set.univ) else set.univ))
                              (rel_bounds.mk (λx, ∅) (λx, set.univ))).sigs.lower s1 :
          by simp
        ... = (refine_bounds (inst.and (inst.sig_in_atoms s1 upper) (inst.atoms_in_sig lower s1))
                       (all_bounds.mk (sig_bounds.mk (λx, ∅) (λx, set.univ))
                                      (rel_bounds.mk (λx, ∅) (λx, set.univ)))).sigs.lower s1 :
          by refl
      end,
  have hupper : upper = (refine_bounds (inst.and (inst.sig_in_atoms s1 upper) (inst.atoms_in_sig lower s1))
                       (all_bounds.mk (sig_bounds.mk (λx, ∅) (λx, set.univ))
                                      (rel_bounds.mk (λx, ∅) (λx, set.univ)))).sigs.upper s1 :=
      begin
         calc upper
             = (λ(s : sig), if s = s1 then (upper ∩ set.univ) else set.univ) s1 :
          by simp
        ... = (sig_bounds.mk (λ(s : sig), if s = s1 then (lower ∪ ∅) else ∅)
                             (λ(s : sig), if s = s1 then (upper ∩ set.univ) else set.univ)).upper s1 :
          by simp
         ... = (all_bounds.mk (sig_bounds.mk (λ(s : sig), if s = s1 then (lower ∪ ∅) else ∅)
                                             (λ(s : sig), if s = s1 then (upper ∩ set.univ) else set.univ))
                              (rel_bounds.mk (λx, ∅) (λx, set.univ))).sigs.upper s1 :
          by simp
        ... = (refine_bounds (inst.and (inst.sig_in_atoms s1 upper) (inst.atoms_in_sig lower s1))
                       (all_bounds.mk (sig_bounds.mk (λx, ∅) (λx, set.univ))
                                      (rel_bounds.mk (λx, ∅) (λx, set.univ)))).sigs.upper s1 :
          by refl
      end,
  apply iff.intro,
  { intro hlsubu,
    intro bound,
    intro hboundlower,
    simp [refine_bounds],
    simp,
    have hboundeltlower : bound ∈ lower :=
      by cc,
    apply hlsubu,
    exact hboundeltlower, },
  { rw ←hupper,
    rw ←hlower,
    intro hlu,
    exact hlu, },
end

def new_bounds : all_bounds :=
(all_bounds.mk (sig_bounds.mk (λx, ∅) (λx, set.univ))
               (rel_bounds.mk (λx, ∅) (λx, set.univ)))

lemma and_assoc [decidable_eq sig] [decidable_eq atom] [decidable_eq relation] (i1 i2 i3 : inst) :
  refine_bounds (inst.and i1 (inst.and i2 i3)) new_bounds = refine_bounds (inst.and (inst.and i1 i2) i3) new_bounds :=
by refl

lemma add_comm [decidable_eq sig] [decidable_eq atom] [decidable_eq relation] (i1 i2 : inst) :
  refine_bounds (inst.and i1 i2) new_bounds = refine_bounds (inst.and i2 i1) new_bounds :=
sorry
/-!
begin
  cases' i1,
  case and {
    sorry
  },
  case sig_in_atoms {
    calc refine_bounds (inst.and (inst.sig_in_atoms x x_1) i2) new_bounds
        = refine_bounds i2 (refine_bounds (inst.sig_in_atoms x x_1) new_bounds) : sorry
    ... = refine_bounds i2 (all_bounds.mk (sig_bounds.mk (λx, ∅) (λ(s : sig), if s = x then set.univ ∩ x_1 else set.univ))
                                          (rel_bounds.mk (λx, ∅) (λx, set.univ))) : sorry
    ... = sorry
    sorry
  },
end
-/

lemma and_reverse [decidable_eq sig] [decidable_eq atom] [decidable_eq relation] (i1 i2 i3 : inst) :
  refine_bounds (inst.and i1 (inst.and i2 i3)) new_bounds = refine_bounds (inst.and i3 (inst.and i2 i1)) new_bounds :=
calc refine_bounds (inst.and i1 (inst.and i2 i3)) new_bounds
    = refine_bounds (inst.and i2 i3) (refine_bounds i1 new_bounds) :
  by refl
... = refine_bounds i3 (refine_bounds i2 (refine_bounds i1 new_bounds)) :
  by refl
... = refine_bounds i3 (refine_bounds i1 (refine_bounds i2 new_bounds)) :
  begin
    have hi1i2eq : (refine_bounds i2 (refine_bounds i1 new_bounds)) = (refine_bounds i1 (refine_bounds i2 new_bounds)) :=
      by apply add_comm,
    rw hi1i2eq,
  end
... = refine_bounds i3 (refine_bounds (inst.and i2 i1) new_bounds) :
  by refl
... = refine_bounds (inst.and (inst.and i2 i1) i3) new_bounds :
  by refl
... = refine_bounds (inst.and i3 (inst.and i2 i1)) new_bounds :
  by apply add_comm

end LoVe


import Mathlib.Data.Nat.Basic
import Mathlib.Data.Fin.Basic
import Mathlib.Algebra.Group.Defs
import Mathlib.Algebra.GroupWithZero.Defs
import Mathlib.Algebra.Ring.Basic

lemma UInt8.size_positive : 0 < UInt8.size := by decide

lemma UInt16.size_positive : 0 < UInt16.size := by decide

lemma UInt32.size_positive : 0 < UInt32.size := by decide

lemma UInt64.size_positive : 0 < UInt64.size := by decide

lemma USize.size_positive : 0 < USize.size := usize_size_gt_zero

lemma UInt8.val_eq_of_lt {a : Nat} : a < UInt8.size -> (ofNat a).val = a := Fin.val_eq_of_lt

lemma UInt16.val_eq_of_lt {a : Nat} : a < UInt16.size -> (ofNat a).val = a := Fin.val_eq_of_lt

lemma UInt32.val_eq_of_lt {a : Nat} : a < UInt32.size -> (ofNat a).val = a := Fin.val_eq_of_lt

lemma UInt64.val_eq_of_lt {a : Nat} : a < UInt64.size -> (ofNat a).val = a := Fin.val_eq_of_lt

lemma USize.val_eq_of_lt {a : Nat} : a < USize.size -> (ofNat a).val = a := Fin.val_eq_of_lt

set_option hygiene false
local macro "genIntDeclars" typeName:ident : command => do
  `(
    namespace $typeName
      instance : Inhabited (Fin size) where
        default := Fin.ofNat' 0 size_positive

      instance : AddSemigroup $typeName where
        add_assoc := fun _ _ _ => congrArg mk (AddSemigroup.add_assoc _ _ _)

      instance : AddCommSemigroup $typeName where
        add_comm := fun _ _ => congrArg mk (AddCommSemigroup.add_comm _ _)

      instance : Semigroup $typeName where
        mul_assoc := fun _ _ _ => congrArg mk (Semigroup.mul_assoc _ _ _)

      instance : Neg $typeName where
        neg a := mk (-a.val)

      lemma sub_def (a b : $typeName) : a - b = ⟨a.val - b.val⟩ := rfl

      lemma mul_def (a b : $typeName) : a * b = ⟨a.val * b.val⟩ := rfl

      lemma mod_def (a b : $typeName) : a % b = ⟨a.val % b.val⟩ := rfl

      lemma add_def (a b : $typeName) : a + b = ⟨a.val + b.val⟩ := rfl

      lemma eq_of_val_eq : ∀ {a b : $typeName}, a.val = b.val -> a = b
      | ⟨f1⟩, ⟨f2⟩, h => congrArg mk h

      lemma val_eq_of_eq : ∀ {a b : $typeName}, a = b -> a.val = b.val
      | ⟨f1⟩, ⟨f2⟩, h => congrArg val h

      @[simp] lemma mk_val_eq : ∀ (a : $typeName), mk a.val = a
      | ⟨a, _⟩ => rfl

      lemma zero_def : (0 : $typeName) = ⟨0⟩ := rfl

      lemma neg_def (a : $typeName) : -a = ⟨-a.val⟩ := rfl

      lemma one_def : (1 : $typeName) = ⟨1⟩ := rfl

      instance : Semiring $typeName where
        add_zero := by simp [add_def, zero_def]
        zero_add := by simp [add_def, zero_def]
        add_comm := by simp [add_def, add_comm]
        mul_one  := by simp [mul_def, one_def]
        one_mul  := by simp [mul_def, one_def]
        nsmul n a := ⟨AddMonoid.nsmul n a.val⟩
        nsmul_zero' x := congrArg mk (AddMonoid.nsmul_zero' x.val)
        nsmul_succ' n a := congrArg mk (AddMonoid.nsmul_succ' n a.val)
        zero_mul := by simp [mul_def, zero_def]
        mul_zero := by simp [mul_def, zero_def]
        npow_zero' := fun _ => rfl
        npow_succ' := fun _ _ => rfl
        right_distrib a b c := by
          simp only [mul_def, add_def]
          apply eq_of_val_eq
          exact right_distrib a.val b.val c.val
        left_distrib a b c := by
          simp only [mul_def, add_def]
          apply eq_of_val_eq
          exact left_distrib a.val b.val c.val
        natCast n := ⟨n⟩
        natCast_zero := rfl
        natCast_succ _ := congrArg mk (Fin.ofNat'_succ)
        __ := inferInstanceAs (AddCommSemigroup $typeName)
        __ := inferInstanceAs (Semigroup $typeName)

      instance : Ring $typeName where
        sub_eq_add_neg := fun _ _ => congrArg mk (sub_eq_add_neg _ _)
        gsmul := fun x a => mk (Ring.gsmul x a.val)
        gsmul_zero' := fun a => congrArg mk (SubNegMonoid.gsmul_zero' a.val)
        gsmul_succ' := fun x a => congrArg mk (SubNegMonoid.gsmul_succ' x a.val)
        gsmul_neg' := fun x a => congrArg mk (SubNegMonoid.gsmul_neg' x a.val)
        add_left_neg := fun a => by apply eq_of_val_eq; simp [neg_def, add_def, zero_def]
        intCast n := ⟨n⟩
        intCast_ofNat _ := rfl
        intCast_negSucc _ := rfl

      instance : CommRing $typeName where
        mul_comm := fun _ _ => by
          apply eq_of_val_eq
          simp [mul_def, zero_def]
          exact mul_comm _ _

    end $typeName
  )

genIntDeclars UInt8
genIntDeclars UInt16
genIntDeclars UInt32
genIntDeclars UInt64
genIntDeclars USize

namespace UInt8

/-- Is this an uppercase ASCII letter? -/
def isUpper (c : UInt8) : Bool :=
  c ≥ 65 && c ≤ 90

/-- Is this a lowercase ASCII letter? -/
def isLower (c : UInt8) : Bool :=
  c ≥ 97 && c ≤ 122

/-- Is this an alphabetic ASCII character? -/
def isAlpha (c : UInt8) : Bool :=
  c.isUpper || c.isLower

/-- Is this an ASCII digit character? -/
def isDigit (c : UInt8) : Bool :=
  c ≥ 48 && c ≤ 57

/-- Is this an alphanumeric ASCII character? -/
def isAlphanum (c : UInt8) : Bool :=
  c.isAlpha || c.isDigit

theorem toChar_aux (n : Nat) (h : n < size) : Nat.isValidChar (UInt32.ofNat n).1 := by
  rw [UInt32.val_eq_of_lt]
  exact Or.inl $ Nat.lt_trans h $ by decide
  exact Nat.lt_trans h $ by decide

/-- The numbers from 0 to 256 are all valid UTF-8 characters, so we can embed one in the other. -/
def toChar (n : UInt8) : Char := ⟨n.toUInt32, toChar_aux n.1 n.1.2⟩

end UInt8


import data.real.basic
import data.bool

import trace

namespace Compose1Ge2

inductive WstState
  | Tracking
  | NoWst

-- Helper function. If (τₛ.w (t+1)) = this value, then τₛ.upper = τ₁.upper
def track (τ₁ τ₂ : Trace) (wst_cur : ℚ) (t : ℕ) : ℚ :=
  let wst := τ₁.wst (t+1) - (τ₁.C - τ₂.C) * ↑t in
    if wst_cur > wst then wst_cur else wst

-- Make all propositions decidable
-- open classical
-- local attribute [instance] prop_decidable

-- This is how we derive τₛ.w
def wst_compose (τ₁ τ₂ : Trace) : ℕ → (ℚ × WstState)
  | 0 := (0, WstState.Tracking)
  | (nat.succ t) :=
    let ⟨wst, s⟩ := (wst_compose t) in
    match s with
    | WstState.Tracking :=
      if τ₁.lower (1 + t) ≥ τ₂.upper 1 + t
      then (wst, WstState.NoWst)
      else (track τ₁ τ₂ wst t, WstState.Tracking)
    | WstState.NoWst :=
      if τ₂.C * ↑t - wst + τ₂.C ≥ τ₁.upper (1 + t)
      then (track τ₁ τ₂ wst t, WstState.Tracking)
      else (wst, WstState.NoWst)
    end

set_option trace.check true
theorem trace_composes_τ₁_ge_τ₂ :
    ∀(τ₁ τ₂ : Trace),
        τ₁.C ≥ τ₂.C ∧
        τ₁.out = τ₂.inp ∧
        (∀t, τ₁.los t = 0 ∧ τ₂.los t = 0)
    → ∃(τₛ : Trace),
        τₛ.C = τ₁.C ∧
        τₛ.D = τ₁.D + τ₂.D ∧
        τₛ.inp = τ₁.inp ∧
        τₛ.out = τ₂.out ∧
        ∀ t, τₛ.los t = τ₁.los t + τ₂.los t :=
begin
  intros τ₁ τ₂ h, cases h with hc h, cases h with h₁₂ h_los,

  -- We will set τₛ.wst to wst_compose
  -- generalize h : w = λ t, (waste_compose τ₁ τ₂ t),
  -- have h : ℕ → (ℚ × WstState) := (λ t, (wst_compose τ₁ τ₂ t)),
  generalize h_wstₛ : (wst_compose τ₁ τ₂) = wstₛ,

  -- Whenever waste happens, it is allowed
  have h_cond_waste : ∀t, (wstₛ (1 + t)).1 > (wstₛ t).1 →
    τ₁.inp (1 + t) ≤ τ₂.C * (1 + t) - (wstₛ (1 + t)).1 :=
  begin
    intros t h_inc,
    induction t,
    {
      simp, rw <- h_wstₛ, unfold wst_compose,
      by_cases h_cond : ((Trace.lower τ₁ (1 + 0) ≥ Trace.upper τ₂ 1 + ↑0)) = tt,
      rw h_cond,

      sorry
    },
    -- Go through wst_compose and get the cases where waste can increase
    -- rw wstₛ at h_wst,
    sorry,
  end,

  sorry,
end

end Compose1Ge2


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Miscellaneous lemmas that depend on compute_grad_slow_correct.
-/
import .predicates .tcont .expected_value .lemmas .compute_grad_slow_correct

namespace certigrad
open list

lemma is_nabla_gintegrable_of_gintegrable {costs : list ID} :
  Π (m : env) (nodes : list node) (tgt : reference),
  well_formed_at costs nodes m tgt →
  grads_exist_at nodes m tgt →
  pdfs_exist_at nodes m →
  is_gdifferentiable (λ m, ⟦sum_costs m costs⟧) tgt m nodes dvec.head →
  can_differentiate_under_integrals costs nodes m tgt →

  is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) m nodes dvec.head → is_nabla_gintegrable (λ m, ⟦sum_costs m costs⟧) tgt m nodes dvec.head
| m [] tgt H_wf H_gs_exist H_pdfs_exist H_gdiff H_diff_under_int H_gint := trivial

| m (⟨ref, parents, operator.det op⟩ :: nodes) tgt H_wf H_gs_exist H_pdfs_exist H_gdiff H_diff_under_int H_gint :=
let x : T ref.2 := op^.f (env.get_ks parents m),
    next_inputs : env := env.insert ref x m in
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,
have H_get_ks_next_inputs : env.get_ks parents next_inputs = env.get_ks parents m,
  begin dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents) end,
have H_wfs : well_formed_at costs nodes next_inputs tgt ∧ well_formed_at costs nodes next_inputs ref, from wf_at_next H_wf,

begin
dsimp [is_gintegrable, compute_grad_slow] at H_gint,
dsimp [is_nabla_gintegrable],
split,
-- tgt
begin
apply is_nabla_gintegrable_of_gintegrable,
exact H_wfs^.left,
exact H_gs_exist^.left,
exact H_pdfs_exist,
exact H_gdiff^.right^.right^.left,
exact H_diff_under_int^.left,
exact (iff.mpr (is_gintegrable_k_add _ _ _ _) H_gint)^.left
end,

-- ref
begin
intros idx H_idx_in_riota H_tgt_eq_dnth_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_eq_dnth_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,
assertv H_f_pre : op^.pre (env.get_ks parents next_inputs) := eq.rec_on (eq.symm H_get_ks_next_inputs) (H_gs_exist^.right H_tgt_in_parents)^.left,

-- TODO(dhs): copy-pasted from compute_grad_slow_correct.lean:223
assert H_grad_gint_ref : is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m ref⟧) next_inputs nodes dvec.head,
begin
assertv H_op_called : is_gintegrable (λ m, ⟦det.op.pb op (env.get_ks parents m) (env.get ref m) (compute_grad_slow costs nodes m ref) idx (tgt.snd)⟧)
                                    next_inputs nodes dvec.head :=
  is_gintegrable_of_sumr_map (λ m idx, det.op.pb op (env.get_ks parents m) (env.get ref m) (compute_grad_slow costs nodes m ref) idx (tgt.snd))
                                    next_inputs nodes _ (iff.mpr (is_gintegrable_k_add _ _ _ _) H_gint)^.right idx (in_filter _ _ _ H_idx_in_riota H_tgt_eq_dnth_idx),

assert H_op_called_swap : is_gintegrable (λ m, ⟦det.op.pb op (env.get_ks parents next_inputs) x (compute_grad_slow costs nodes m ref) idx (tgt.snd)⟧)
                                         next_inputs nodes dvec.head,
begin
apply is_gintegrable_k_congr _ _ _ _ _ H_wfs^.right^.uids _ H_op_called,
intros m H_envs_match,
-- TODO(dhs): this is copy-pasted from above (nested comment!)
assert H_parents_match : env.get_ks parents m = env.get_ks parents next_inputs,
begin
  apply env.get_ks_env_eq,
  intros parent H_parent_in_parents,
  apply H_envs_match,
  apply env.has_key_insert,
  exact (H_wf^.ps_in_env^.left parent H_parent_in_parents)
end,
assert H_ref_matches : env.get ref m = x,
begin
  assertv H_env_has_key_ref : env.has_key ref next_inputs := env.has_key_insert_same _ _,
  rw [H_envs_match ref H_env_has_key_ref, env.get_insert_same]
end,
simp only [H_parents_match, H_ref_matches],
end,

simp only [λ (m : env), op^.pb_correct (env.get_ks parents next_inputs) x (by rw H_get_ks_next_inputs) (compute_grad_slow costs nodes m ref) H_tshape_at_idx H_f_pre] at H_op_called_swap,
exact iff.mpr (is_gintegrable_tmulT _ _ _ _) H_op_called_swap
end,
apply is_nabla_gintegrable_of_gintegrable,
exact H_wfs^.right,
exact (H_gs_exist^.right H_tgt_in_parents)^.right,
exact H_pdfs_exist,
exact H_gdiff^.right^.right^.right H_idx_in_riota H_tgt_eq_dnth_idx,
exact H_diff_under_int^.right H_tgt_in_parents,
exact H_grad_gint_ref
end
end

| inputs (⟨ref, parents, operator.rand op⟩ :: nodes) tgt H_wf H_gs_exist H_pdfs_exist H_gdiff H_diff_under_int H_gint :=
let θ := env.get tgt inputs in
let next_inputs := λ (y : T ref.2), env.insert ref y inputs in
have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,
have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,

have H_wfs : ∀ y, well_formed_at costs nodes (next_inputs y) tgt ∧ well_formed_at costs nodes (next_inputs y) ref,
  from assume y, wf_at_next H_wf,

begin
dsimp [is_gintegrable, compute_grad_slow] at H_gint,
dsimp [is_nabla_gintegrable],

assert H_cgsc : ∀ x,
E (graph.to_dist (λ (m : env), ⟦compute_grad_slow costs nodes m tgt⟧)
                 (env.insert ref x inputs) nodes)
  dvec.head
=
∇ (λ (θ₀ : T (tgt.snd)),
     E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                      (env.insert ref x (env.insert tgt θ₀ inputs)) nodes)
        dvec.head)
  (env.get tgt inputs),
begin -- start H_cgsc
intro x,
rw -theorems.compute_grad_slow_correct (H_wfs x)^.left (H_gs_exist^.right _) (H_pdfs_exist^.right _) (H_gdiff^.right^.right _)
                                       _
                                       (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_gint^.right x))^.left
                                       (H_diff_under_int^.right _),

simp only [(λ (θ₀ : T tgt.2), env.insert_insert_flip θ₀ x inputs H_tgt_neq_ref), @env.get_insert_diff tgt ref x inputs H_tgt_neq_ref],
exact is_nabla_gintegrable_of_gintegrable _ _ _ (H_wfs x)^.left (H_gs_exist^.right _) (H_pdfs_exist^.right _) (H_gdiff^.right^.right _)
                                          (H_diff_under_int^.right _)
                                          (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_gint^.right x))^.left,
end, -- end H_cgsc

simp only [λ x, E.E_k_add _ _ _ _ (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_gint^.right x))^.left
                              (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_gint^.right x))^.right] at H_gint,
simp only [H_cgsc] at H_gint,

-- TODO(dhs): apply and.intro _ (and.intro _ _) does not instantiate the second metavariable, change back once fixed
split, tactic.swap, split, tactic.rotate 2,

begin -- start PD
apply (iff.mpr (T.is_integrable_add_middle _ _ _) H_gint^.left)^.left
end, -- end PD

dunfold sum_downstream_costs at H_gint,

-- Scores
assert H_score_rw : ∀ y,
map
            (λ (idx : ℕ),
               E
                 (graph.to_dist
                    (λ (m : env), ⟦sum_costs m costs⟧)
                    (env.insert ref y inputs)
                    nodes)
                 dvec.head ⬝ ∇
                 (λ (θ₀ : T (tgt.snd)), T.log (rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents inputs) idx) y))
                 (env.get tgt inputs))
            (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents)))
=
map
    (λ (idx : ℕ),
       E
         (graph.to_dist
            (λ (m : env),
               ⟦sum_downstream_costs nodes costs ref m ⬝ rand.op.glogpdf op (env.get_ks parents m) (env.get ref m)
                    idx
                    (tgt.snd)⟧)
            (env.insert ref y inputs)
            nodes)
         dvec.head)
    (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))),
begin -- start H_score_rw
exact map_filter_expand_helper _ _ _ _ _ _ H_wf H_gs_exist
end, -- end H_score_rw

assert H_pull_E : ∀ y,
sumr
         (map
            (λ (idx : ℕ),
               E
                 (graph.to_dist
                    (λ (m : env),
                       ⟦sum_downstream_costs nodes costs ref m ⬝ rand.op.glogpdf op (env.get_ks parents m) (env.get ref m) idx (tgt.snd)⟧)
                    (env.insert ref y inputs)
                    nodes)
                 dvec.head)
            (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))
=
E (graph.to_dist (λ (m : env),
                    ⟦sumr (map (λ (idx : ℕ), sum_downstream_costs nodes costs ref m ⬝ rand.op.glogpdf op (env.get_ks parents m) (env.get ref m) idx (tgt.snd))
                               (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))⟧)
                    (env.insert ref y inputs)
                    nodes)
                 dvec.head,
begin -- start H_pull_E
intro y,
rw -E.E_g_pull_out_of_sum _ _ _ _ (H_pdfs_exist^.right y),
exact (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_gint^.right y))^.right
end, -- end H_pull_E

begin -- start score
simp only [H_score_rw], clear H_score_rw,
simp only [H_pull_E], clear H_pull_E,
apply (iff.mpr (T.is_integrable_add_middle _ _ _) H_gint^.left)^.right
end, -- end score

-- Recursive
begin
intro y,
apply is_nabla_gintegrable_of_gintegrable,
exact (H_wfs y)^.left,
exact H_gs_exist^.right _,
exact H_pdfs_exist^.right _,
exact H_gdiff^.right^.right _,
exact H_diff_under_int^.right _,
apply (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_gint^.right y))^.left,
end

end

end certigrad