/- Formalizing Euclid's Axioms.-/
import tactic
import data.real.basic  -- imports ℝ
noncomputable theory
open_locale classical

-- # Postulated types and relations
----------------------------------
constant Point : Type
constant Line : Type
constant lies_on : Point → Line → Prop
constant between : Point → Point → Point → Prop  -- (between a b c) means "b is in between a and c"
constant congruent {A : Type} : A → A → Prop  -- variable A is implicit. Lean will figure it out.
-- Missing definition that Euclid needed but did not include:
constant distance : Point → Point → ℝ

-- Notation
-----------
local infix ` ≃ `:55 := congruent  -- typed as \ equiv

-- Missing Axiom(s)
-------------------
axiom distance_not_neg {p1 p2 : Point} : 0 ≤ distance p1 p2
axiom distance_pos {p1 p2 : Point} : p1 ≠ p2 ↔ 0 < distance p1 p2
@[instance] axiom distance_is_symm_op : is_symm_op Point ℝ distance
@[simp] axiom distance_zero_segment {p : Point} : distance p p = 0

@[symm] lemma distance_is_symm : ∀ (p1 p2 : Point),
  distance p1 p2 = distance p2 p1 := distance_is_symm_op.symm_op
axiom distance_between {a b c : Point} : between a b c ↔ distance a b + distance b c = distance a c
axiom between_refl_left (a b : Point) : between a a b
axiom between_refl_right (a b : Point) : between a b b
@[symm] axiom between_symm {x y z : Point} : between x y z → between z y x

-- Congruence is an equivalence relation.
@[instance] axiom cong_is_equiv {A : Type} : is_equiv A (≃)

-- TODO: The proof for the following lemmas follows from cong_is_equiv.
@[refl] lemma cong_refl {A : Type} : ∀ a : A, a ≃ a :=
  cong_is_equiv.to_is_preorder.to_is_refl.refl
lemma cong_symm {A : Type} : ∀ (a b : A), a ≃ b → b ≃ a :=
  cong_is_equiv.to_is_symm.symm
@[trans] lemma cong_trans {A : Type} : ∀ (a b c : A), a ≃ b → b ≃ c → a ≃ c :=
  cong_is_equiv.to_is_preorder.to_is_trans.trans
lemma cong_equiv {A : Type} : equivalence (@congruent A) :=
  -- The @ makes implicit arguments explicit.
  mk_equivalence congruent cong_refl cong_symm cong_trans

-- #Postulate I
---------------
-- Given two distinct Points, we can construct a unique Line passing
-- through them.
constant line_of_points (p₁ p₂ : Point) : p₁ ≠ p₂ → Line
axiom line_exists (p₁ p₂ : Point) (h : p₁ ≠ p₂) :
  let l : Line := line_of_points p₁ p₂ h in
  lies_on p₁ l ∧ lies_on p₂ l

structure Segment: Type :=
(p1 p2 : Point)

local infix `⬝`:56 := Segment.mk  -- typed as \ cdot

-- # Helper functions
---------------------
-- condition for 3 terms being distict.
def distinct {A : Type} (a b c : A) := a ≠ b ∧ b ≠ c ∧ c ≠ a

-- length of a segment
def length (a : Segment) := distance a.p1 a.p2
lemma distinct_swap (a b c : Point) : distinct a b c → distinct b c a :=
begin
  rintros ⟨h₁, h₂, h₃⟩,
  rw distinct,
  repeat {cc},
end

axiom distance_congruent {a b c d : Point} :
  a⬝b ≃ c⬝d ↔ distance a b = distance c d

-- Missing axiom:
-----------------
axiom segment_symm {p1 p2 : Point} : p1⬝p2 = p2⬝p1
axiom zero_segment {s : Segment} {p : Point} : s ≃ p⬝p → s.p1 = s.p2

def line_of_segment (s : Segment) : s.p1 ≠ s.p2 → Line := line_of_points s.p1 s.p2
def points_of_segment (s : Segment) : set Point := {c : Point | between s.p1 c s.p2}

-- Postulate II
---------------
-- Given two segments, we can find a Point to extend the first Segment
-- by the lenth of the Second.
constant extended_segment (ab cd : Segment) : ab.p1 ≠ ab.p2 → Point
axiom extend (ab cd : Segment) (h : ab.p1 ≠ ab.p2) :
    let p : Point := extended_segment ab cd h in
    lies_on p (line_of_segment ab h)
    ∧ between ab.p1 ab.p2 p
    ∧ cd ≃ ⟨ab.p2, p⟩

-- A Circle is constructed by specifying two Points.
-- Note: Euclid says that the two points should be distinct. But we choose not to make this
-- a strict requirement for defining a Circle.
structure Circle: Type :=
(center outer : Point)

def radius_segment (c : Circle) : Segment := {p1 := c.center, p2 := c.outer}
def radius (c : Circle) : ℝ :=
  let r := radius_segment c in distance r.1 r.2
def circumference (c : Circle) : set Point := {x : Point | radius_segment c ≃ ⟨c.center, x⟩}

-- A Ray is constructed by specifying two Points.
structure Ray: Type :=
(base ext : Point)

def line_of_ray (r : Ray) : r.base ≠ r.ext → Line := line_of_points r.base r.ext
def points_of_ray (r : Ray) (ne : r.base ≠ r.ext) : set Point :=
     points_of_segment ⟨r.base, r.ext⟩ ∪ {c | lies_on c (line_of_ray r ne) ∧ between r.base r.ext c}

-- Two Rays are opposite if they are distict, have the same base Point
-- and the same Line.
def opposite_rays (r1 r2 : Ray) (h1 : r1.base ≠ r1.ext) (h2 : r2.base ≠ r2.ext) : Prop :=
  (r1.base = r2.base) ∧ (r1 ≠ r2) ∧ (line_of_ray r1 h1 = line_of_ray r2 h2)

-- An Angle is constructed by specifying two Rays based at a common
-- Point and a proof that the Rays are not opposite.
structure Angle: Type :=
(r1 r2 : Ray)
(eq_base : r1.base = r2.base)
(not_opposite (h1 : r1.base ≠ r1.ext) (h2 : r2.base ≠ r2.ext) :
  ¬ opposite_rays r1 r2 h1 h2)

-- A Triangle is constructed by specifying three Points.
structure Triangle: Type :=
(p1 p2 p3 : Point)

def angle_of_points (a b c : Point) (different : distinct a b c) : Angle :=
  let r1 := Ray.mk b a in
  let r2 := Ray.mk b a in
  let same_base : r1.base = r2.base := rfl in
  let not_opposite : ∀ (h1 : r1.base ≠ r1.ext) (h2 : r2.base ≠ r2.ext),
    ¬opposite_rays r1 r2 h1 h2 := sorry in
  ⟨r1, r2, same_base, not_opposite⟩

-- For every triangle, we get can define three Segments (its sides).
def sides_of_triangle (t : Triangle): Segment × Segment × Segment :=
  (⟨t.p1, t.p2⟩, ⟨t.p2, t.p3⟩, ⟨t.p3, t.p1⟩)

def angles_of_triangle (t : Triangle) (different : distinct t.p1 t.p2 t.p3): vector Angle 3 :=
  let a123 := angle_of_points t.p1 t.p2 t.p3 different in
  let dif2 : distinct t.p2 t.p3 t.p1 :=
    begin apply distinct_swap, exact different, end in
  let a231 := angle_of_points t.p2 t.p3 t.p1 dif2 in
  let dif3 : distinct t.p3 t.p1 t.p2 :=
    begin apply distinct_swap, exact dif2, end in
  let a312 := angle_of_points t.p3 t.p1 t.p2 dif3 in
  ⟨[a123, a231, a312], rfl⟩

def is_equilateral (t : Triangle) : Prop :=
  let sides := sides_of_triangle t in
  sides.1 ≃ sides.2.1 ∧ sides.2.1 ≃ sides.2.2

lemma equilateral_triangle_all_sides_equal (t : Triangle) :
  let sides := sides_of_triangle t in
  is_equilateral t → sides.1 ≃ sides.2.2 :=
begin
  intros,
  cases a with h₁ h₂,
  transitivity,
    repeat {assumption},
end

def is_right_angle : Angle → Prop := sorry
def exists_intersection: Line → Line → Prop := sorry
def is_parallel : Line → Line → Prop := sorry

axiom right_angle (a1 a2 : Angle) : is_right_angle a1 ∧ is_right_angle a2 → a1 ≃ a2
axiom parallel (l1 l2 : Line) : ¬ exists_intersection l1 l2 → is_parallel l1 l2
-- does not mean equadistant
-- constant lies_on : Point → Line → Prop

-- axiom intersect (l1 l2 l3: Line) : ((make_angle l1 l3) + (make_angle l2 l3)) < (rAngle + rAngle) → on_side (Sides_of_line l3).2 (intersection l1 l2)
-- if the angle beteween two lines is less than 2 right angles, the lines meet on that side

-- # Euclid's missing axiom(s)
------------------------------

--If the sum of the radii of two circles is greater than the line joining their centers, then the two circles intersect
--https://mathcs.clarku.edu/~djoyce/java/elements/bookI/propI1.html
-- TODO: Find a reference for this. Or find a justification using Coordinate geometry.
constant circles_intersect {c₁ c₂ : Circle} :
     distance c₁.center c₂.center ≤ radius c₁ + radius c₂
  → (abs (radius c₁ - radius c₂) ≤ distance c₁.center c₂.center)
  → Point

axiom circles_intersect' {c₁ c₂ : Circle}
  (h₁ : radius c₁ + radius c₂ >= distance c₁.center c₂.center)
  (h₂ : (abs (radius c₁ - radius c₂) <= distance c₁.center c₂.center)) :
  let p : Point := circles_intersect h₁ h₂ in
  p ∈ circumference c₁ ∧ p ∈ circumference c₂

def circle_interior (p : Point) (c : Circle) : Prop :=
  distance c.center p < radius c

def circle_exterior (p : Point) (c : Circle) : Prop :=
  radius c < distance c.center p

lemma center_in_circle {a b : Point} (ne : a ≠ b) :
  let c : Circle := ⟨a, b⟩ in
  circle_interior a c :=
begin
  intros,
  rwa [circle_interior, radius, radius_segment, distance_zero_segment, ← distance_pos],
end

lemma radius_on_circumference (a b : Point) :
  let c : Circle := ⟨a, b⟩ in
  b ∈ circumference c :=
begin
  intros,
  rw [circumference, radius_segment],
  simp,
end


import .integral_domain
import .ideal

namespace hidden

namespace myring

variables {α : Type} [myring α] (I J : myset α)

def principal_ideal (r : α) : myset α := { b | ∃ a, r * a = b }

theorem principal_ideal_ideal : ∀ r : α, is_ideal (principal_ideal r) :=
begin
  intro r,
  split, {
    existsi (0: α),
    rw mul_zero,
  }, {
    intros a b ha hb,
    cases ha with s hs,
    cases hb with t ht,
    rw [←ht, ←hs, ←mul_add],
    existsi (s + t),
    refl,
  }, {
    intros s a ha,
    cases ha with t ht,
    existsi t * s,
    rw [←ht, mul_comm s, mul_assoc],
  },
end

structure is_principal_ideal {α : Type} [myring α] (I : myset α) extends is_ideal I : Prop :=
intro :: (is_principal : ∃ r, I = principal_ideal r)

class principal_ideal_domain (α : Type) extends integral_domain α :=
(all_ideals_principal : ∀ I : myset α, is_ideal I → is_principal_ideal I)

end myring

end hidden


namespace hidden

-- Commutative Unitary Ring
class myring (α : Type) extends has_add α, has_zero α, has_neg α, has_mul α, has_one α :=
(decidable_eq : ∀ a b : α, decidable (a = b))
(add_assoc (a b c : α) : a + b + c = a + (b + c))
(add_zero (a : α) : a + 0 = a)
(add_neg (a : α) : a + -a = 0)
(mul_assoc (a b c : α) : a * b * c = a * (b * c))
(mul_comm (a b : α) : a * b = b * a)
(mul_one (a : α) : a * 1 = a)
(mul_add (a b c : α) : a * (b + c) = a * b + a * c)

namespace myring

variables {α : Type} [myring α] (a b c : α)

instance (a b : α) : decidable (a = b) := decidable_eq a b

theorem one_mul : 1 * a = a :=
begin
  rw [mul_comm],
  from mul_one _,
end

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

theorem add_cancel_right : a + c = b + c → a = b :=
begin
  assume h,
  rw [←add_zero a, ←add_zero b, ←add_neg c, ←add_assoc, ←add_assoc, h],
end

theorem add_cancel_right_iff: a + c = b + c ↔ a = b :=
begin
  split, {
    from add_cancel_right _ _ _,
  }, {
    assume hbc,
    rw hbc,
  },
end

theorem zero_add : 0 + a = a :=
begin
  apply add_cancel_right _ _ (-a),
  rw [add_assoc, add_neg, add_zero],
end

theorem neg_zero : -(0 : α) = 0 :=
begin
  rw [←zero_add (-(0 : α)), add_neg],
end

private lemma important_first_lemma : a + b = 0 → b + a = 0 :=
begin
  assume h,
  apply add_cancel_right _ _ b,
  rw [add_assoc, h, zero_add, add_zero],
end

theorem neg_add : -a + a = 0 :=
begin
  apply important_first_lemma,
  rw add_neg,
end

theorem add_cancel_left : a + b = a + c → b = c :=
begin
  assume h,
  rw [←zero_add b, ←zero_add c, ←neg_add a, add_assoc, add_assoc, h],
end

theorem add_cancel_left_iff: a + b = a + c ↔ b = c :=
begin
  split, {
    from add_cancel_left _ _ _,
  }, {
    assume hbc, rw hbc,
  },
end

theorem neg_neg : -(-a) = a :=
begin
  apply add_cancel_right _ _ (-a),
  rw [add_neg, neg_add],
end

theorem neg_unique : a + b = 0 ↔ a = -b :=
begin
  split,
    assume h,
    rw [←add_zero a, ←add_neg b, ←add_assoc],
    conv {
      to_rhs,
      rw ←zero_add (-b),
    },
    congr,
    assumption,
  assume h,
  subst h,
  from neg_add b,
end

private theorem neg_distr_swap : -(a + b) = -b + -a :=
begin
  symmetry,
  rw [←neg_unique, add_assoc, ←add_assoc (-a), neg_add, zero_add, neg_add],
end

theorem mul_zero : a * 0 = 0 :=
begin
  apply add_cancel_left (a * 0),
  rw [←mul_add a, zero_add, add_zero],
end

theorem zero_mul : 0 * a = 0 :=
by rw [mul_comm, mul_zero]

theorem neg_eq_mul_neg_one : -a = -1 * a :=
begin
  symmetry,
  conv {
    to_rhs,
    rw ←mul_one a,
  },
  rw [←neg_unique, mul_comm, ←mul_add, neg_add, mul_zero],
end

theorem neg_mul : (-a) * b = -(a * b) :=
begin
  rw [←neg_unique, mul_comm (-a), mul_comm a, ←mul_add, neg_add, mul_zero],
end

theorem mul_neg : a * (-b) = -(a * b) :=
begin
  rw [mul_comm a (-b), mul_comm a b],
  apply neg_mul,
end

theorem neg_mul_neg : (-a) * (-b) = a * b :=
by rw [mul_neg, neg_mul, neg_neg]

theorem neg_distr : -(a + b) = -a + -b :=
by rw [neg_eq_mul_neg_one a, neg_eq_mul_neg_one b, ←mul_add, ←neg_eq_mul_neg_one]

-- "Negate Equality"
theorem neg_eq : a = b ↔ -a = -b :=
begin
  split; assume h,
    congr, assumption,
  rw [←neg_neg a, ←neg_neg b, h],
end

theorem add_comm : a + b = b + a :=
by rw [neg_eq, neg_distr, neg_distr_swap]

theorem add_cancel_left_to_zero : a + b = b → a = 0 :=
begin
  assume h,
  apply add_cancel_right _ _ b,
  rwa zero_add,
end

theorem add_cancel_left_to_zero_iff: a + b = b ↔ a = 0 :=
begin
  split, {
    from add_cancel_left_to_zero _ _,
  }, {
    assume ha0,
    rw ha0,
    rw zero_add,
  },
end

theorem add_cancel_right_to_zero : a + b = a → b = 0 :=
λ h, add_cancel_left_to_zero b a (by rwa add_comm at h)

theorem add_cancel_right_to_zero_iff: a + b = a ↔ b = 0 :=
begin
  split, {
    from add_cancel_right_to_zero _ _,
  }, {
    assume hb0,
    rw hb0,
    rw add_zero,
  },
end

theorem add_left : a = b → c + a = c + b :=
begin
  assume h,
  congr,
  assumption,
end

theorem add_right : a = b → a + c = b + c :=
begin
  assume h,
  congr,
  assumption,
end

theorem one_eq_zero_impl_all_zero : (1 : α) = 0 → ∀ x : α, x = 0 :=
begin
  assume h10,
  intro x,
  rw [←one_mul x, h10, zero_mul],
end

def sub : α → α → α := λ a b, a + (-b)
instance: has_sub α := ⟨sub⟩

theorem sub_def : a - b = a + -b := rfl

theorem sub_self : a - a = 0 :=
begin
  change a + -a = 0,
  apply add_neg,
end

theorem sub_zero : a - 0 = a :=
by rw [sub_def, neg_zero, add_zero]

theorem zero_sub : 0 - a = -a :=
by rw [sub_def, zero_add]

theorem mul_sub : a * (b - c) = a * b - a * c :=
begin
  change a * (b + (-c)) = a * b + -(a * c),
  rw [mul_add, ←mul_neg],
end

theorem neg_sub : -(a - b) = b - a :=
by rw [sub_def, sub_def, neg_distr, neg_neg, add_comm]

theorem sub_mul : (a - b) * c = a * c - b * c:=
by rw [mul_comm, mul_sub, mul_comm a, mul_comm b]

-- This is handy imo
-- Imma have to firmly agree, bro
theorem sub_to_zero_iff_eq : a - b = 0 ↔ a = b :=
begin
  split; assume h, {
    symmetry,
    rwa [neg_eq, ←neg_unique, add_comm],
  }, {
    change a + -b = 0,
    rwa [neg_unique, neg_neg],
  },
end

instance add_is_assoc: is_associative α (+) := ⟨add_assoc⟩
instance add_is_comm: is_commutative α (+) := ⟨add_comm⟩

instance mul_is_assoc: is_associative α (*) := ⟨mul_assoc⟩
instance mul_is_comm: is_commutative α (*) := ⟨mul_comm⟩

end myring

end hidden


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

! This file was ported from Lean 3 source module combinatorics.set_family.compression.down
! leanprover-community/mathlib commit cc70d9141824ea8982d1562ce009952f2c3ece30
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Finset.Card

/-!
# Down-compressions

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

This file defines down-compression.

Down-compressing `𝒜 : finset (finset α)` along `a : α` means removing `a` from the elements of `𝒜`,
when the resulting set is not already in `𝒜`.

## Main declarations

* `finset.non_member_subfamily`: `𝒜.non_member_subfamily a` is the subfamily of sets not containing
  `a`.
* `finset.member_subfamily`: `𝒜.member_subfamily a` is the image of the subfamily of sets containing
  `a` under removing `a`.
* `down.compression`: Down-compression.

## Notation

`𝓓 a 𝒜` is notation for `down.compress a 𝒜` in locale `set_family`.

## References

* https://github.com/b-mehta/maths-notes/blob/master/iii/mich/combinatorics.pdf

## Tags

compression, down-compression
-/

variable {α : Type _} [DecidableEq α] {𝒜 ℬ : Finset (Finset α)} {s : Finset α} {a : α}

namespace Finset

#print Finset.nonMemberSubfamily /-
/-- Elements of `𝒜` that do not contain `a`. -/
def nonMemberSubfamily (a : α) (𝒜 : Finset (Finset α)) : Finset (Finset α) :=
  𝒜.filterₓ fun s => a ∉ s
#align finset.non_member_subfamily Finset.nonMemberSubfamily
-/

#print Finset.memberSubfamily /-
/-- Image of the elements of `𝒜` which contain `a` under removing `a`. Finsets that do not contain
`a` such that `insert a s ∈ 𝒜`. -/
def memberSubfamily (a : α) (𝒜 : Finset (Finset α)) : Finset (Finset α) :=
  (𝒜.filterₓ fun s => a ∈ s).image fun s => erase s a
#align finset.member_subfamily Finset.memberSubfamily
-/

#print Finset.mem_nonMemberSubfamily /-
@[simp]
theorem mem_nonMemberSubfamily : s ∈ 𝒜.nonMemberSubfamily a ↔ s ∈ 𝒜 ∧ a ∉ s :=
  mem_filter
#align finset.mem_non_member_subfamily Finset.mem_nonMemberSubfamily
-/

#print Finset.mem_memberSubfamily /-
@[simp]
theorem mem_memberSubfamily : s ∈ 𝒜.memberSubfamily a ↔ insert a s ∈ 𝒜 ∧ a ∉ s :=
  by
  simp_rw [member_subfamily, mem_image, mem_filter]
  refine' ⟨_, fun h => ⟨insert a s, ⟨h.1, mem_insert_self _ _⟩, erase_insert h.2⟩⟩
  rintro ⟨s, hs, rfl⟩
  rw [insert_erase hs.2]
  exact ⟨hs.1, not_mem_erase _ _⟩
#align finset.mem_member_subfamily Finset.mem_memberSubfamily
-/

#print Finset.nonMemberSubfamily_inter /-
theorem nonMemberSubfamily_inter (a : α) (𝒜 ℬ : Finset (Finset α)) :
    (𝒜 ∩ ℬ).nonMemberSubfamily a = 𝒜.nonMemberSubfamily a ∩ ℬ.nonMemberSubfamily a :=
  filter_inter_distrib _ _ _
#align finset.non_member_subfamily_inter Finset.nonMemberSubfamily_inter
-/

#print Finset.memberSubfamily_inter /-
theorem memberSubfamily_inter (a : α) (𝒜 ℬ : Finset (Finset α)) :
    (𝒜 ∩ ℬ).memberSubfamily a = 𝒜.memberSubfamily a ∩ ℬ.memberSubfamily a :=
  by
  unfold member_subfamily
  rw [filter_inter_distrib, image_inter_of_inj_on _ _ ((erase_inj_on' _).mono _)]
  rw [← coe_union, ← filter_union, coe_filter]
  exact Set.inter_subset_right _ _
#align finset.member_subfamily_inter Finset.memberSubfamily_inter
-/

#print Finset.nonMemberSubfamily_union /-
theorem nonMemberSubfamily_union (a : α) (𝒜 ℬ : Finset (Finset α)) :
    (𝒜 ∪ ℬ).nonMemberSubfamily a = 𝒜.nonMemberSubfamily a ∪ ℬ.nonMemberSubfamily a :=
  filter_union _ _ _
#align finset.non_member_subfamily_union Finset.nonMemberSubfamily_union
-/

#print Finset.memberSubfamily_union /-
theorem memberSubfamily_union (a : α) (𝒜 ℬ : Finset (Finset α)) :
    (𝒜 ∪ ℬ).memberSubfamily a = 𝒜.memberSubfamily a ∪ ℬ.memberSubfamily a := by
  simp_rw [member_subfamily, filter_union, image_union]
#align finset.member_subfamily_union Finset.memberSubfamily_union
-/

#print Finset.card_memberSubfamily_add_card_nonMemberSubfamily /-
theorem card_memberSubfamily_add_card_nonMemberSubfamily (a : α) (𝒜 : Finset (Finset α)) :
    (𝒜.memberSubfamily a).card + (𝒜.nonMemberSubfamily a).card = 𝒜.card :=
  by
  rw [member_subfamily, non_member_subfamily, card_image_of_inj_on,
    filter_card_add_filter_neg_card_eq_card]
  exact (erase_inj_on' _).mono fun s hs => (mem_filter.1 hs).2
#align finset.card_member_subfamily_add_card_non_member_subfamily Finset.card_memberSubfamily_add_card_nonMemberSubfamily
-/

#print Finset.memberSubfamily_union_nonMemberSubfamily /-
theorem memberSubfamily_union_nonMemberSubfamily (a : α) (𝒜 : Finset (Finset α)) :
    𝒜.memberSubfamily a ∪ 𝒜.nonMemberSubfamily a = 𝒜.image fun s => s.eraseₓ a :=
  by
  ext s
  simp only [mem_union, mem_member_subfamily, mem_non_member_subfamily, mem_image, exists_prop]
  constructor
  · rintro (h | h)
    · exact ⟨_, h.1, erase_insert h.2⟩
    · exact ⟨_, h.1, erase_eq_of_not_mem h.2⟩
  · rintro ⟨s, hs, rfl⟩
    by_cases ha : a ∈ s
    · exact Or.inl ⟨by rwa [insert_erase ha], not_mem_erase _ _⟩
    · exact Or.inr ⟨by rwa [erase_eq_of_not_mem ha], not_mem_erase _ _⟩
#align finset.member_subfamily_union_non_member_subfamily Finset.memberSubfamily_union_nonMemberSubfamily
-/

#print Finset.memberSubfamily_memberSubfamily /-
@[simp]
theorem memberSubfamily_memberSubfamily : (𝒜.memberSubfamily a).memberSubfamily a = ∅ :=
  by
  ext
  simp
#align finset.member_subfamily_member_subfamily Finset.memberSubfamily_memberSubfamily
-/

#print Finset.memberSubfamily_nonMemberSubfamily /-
@[simp]
theorem memberSubfamily_nonMemberSubfamily : (𝒜.nonMemberSubfamily a).memberSubfamily a = ∅ :=
  by
  ext
  simp
#align finset.member_subfamily_non_member_subfamily Finset.memberSubfamily_nonMemberSubfamily
-/

#print Finset.nonMemberSubfamily_memberSubfamily /-
@[simp]
theorem nonMemberSubfamily_memberSubfamily :
    (𝒜.memberSubfamily a).nonMemberSubfamily a = 𝒜.memberSubfamily a :=
  by
  ext
  simp
#align finset.non_member_subfamily_member_subfamily Finset.nonMemberSubfamily_memberSubfamily
-/

#print Finset.nonMemberSubfamily_nonMemberSubfamily /-
@[simp]
theorem nonMemberSubfamily_nonMemberSubfamily :
    (𝒜.nonMemberSubfamily a).nonMemberSubfamily a = 𝒜.nonMemberSubfamily a :=
  by
  ext
  simp
#align finset.non_member_subfamily_non_member_subfamily Finset.nonMemberSubfamily_nonMemberSubfamily
-/

end Finset

open Finset

-- The namespace is here to distinguish from other compressions.
namespace Down

#print Down.compression /-
/-- `a`-down-compressing `𝒜` means removing `a` from the elements of `𝒜` that contain it, when the
resulting finset is not already in `𝒜`. -/
def compression (a : α) (𝒜 : Finset (Finset α)) : Finset (Finset α) :=
  (𝒜.filterₓ fun s => erase s a ∈ 𝒜).disjUnion
      ((𝒜.image fun s => erase s a).filterₓ fun s => s ∉ 𝒜) <|
    disjoint_left.2 fun s h₁ h₂ => (mem_filter.1 h₂).2 (mem_filter.1 h₁).1
#align down.compression Down.compression
-/

-- mathport name: down.compression
scoped[FinsetFamily] notation "𝓓 " => Down.compression

#print Down.mem_compression /-
/-- `a` is in the down-compressed family iff it's in the original and its compression is in the
original, or it's not in the original but it's the compression of something in the original. -/
theorem mem_compression : s ∈ 𝓓 a 𝒜 ↔ s ∈ 𝒜 ∧ s.eraseₓ a ∈ 𝒜 ∨ s ∉ 𝒜 ∧ insert a s ∈ 𝒜 :=
  by
  simp_rw [compression, mem_disj_union, mem_filter, mem_image, and_comm' (s ∉ 𝒜)]
  refine'
    or_congr_right
      (and_congr_left fun hs =>
        ⟨_, fun h => ⟨_, h, erase_insert <| insert_ne_self.1 <| ne_of_mem_of_not_mem h hs⟩⟩)
  rintro ⟨t, ht, rfl⟩
  rwa [insert_erase (erase_ne_self.1 (ne_of_mem_of_not_mem ht hs).symm)]
#align down.mem_compression Down.mem_compression
-/

#print Down.erase_mem_compression /-
theorem erase_mem_compression (hs : s ∈ 𝒜) : s.eraseₓ a ∈ 𝓓 a 𝒜 :=
  by
  simp_rw [mem_compression, erase_idem, and_self_iff]
  refine' (em _).imp_right fun h => ⟨h, _⟩
  rwa [insert_erase (erase_ne_self.1 (ne_of_mem_of_not_mem hs h).symm)]
#align down.erase_mem_compression Down.erase_mem_compression
-/

#print Down.erase_mem_compression_of_mem_compression /-
-- This is a special case of `erase_mem_compression` once we have `compression_idem`.
theorem erase_mem_compression_of_mem_compression : s ∈ 𝓓 a 𝒜 → s.eraseₓ a ∈ 𝓓 a 𝒜 :=
  by
  simp_rw [mem_compression, erase_idem]
  refine' Or.imp (fun h => ⟨h.2, h.2⟩) fun h => _
  rwa [erase_eq_of_not_mem (insert_ne_self.1 <| ne_of_mem_of_not_mem h.2 h.1)]
#align down.erase_mem_compression_of_mem_compression Down.erase_mem_compression_of_mem_compression
-/

#print Down.mem_compression_of_insert_mem_compression /-
theorem mem_compression_of_insert_mem_compression (h : insert a s ∈ 𝓓 a 𝒜) : s ∈ 𝓓 a 𝒜 :=
  by
  by_cases ha : a ∈ s
  · rwa [insert_eq_of_mem ha] at h
  · rw [← erase_insert ha]
    exact erase_mem_compression_of_mem_compression h
#align down.mem_compression_of_insert_mem_compression Down.mem_compression_of_insert_mem_compression
-/

#print Down.compression_idem /-
/-- Down-compressing a family is idempotent. -/
@[simp]
theorem compression_idem (a : α) (𝒜 : Finset (Finset α)) : 𝓓 a (𝓓 a 𝒜) = 𝓓 a 𝒜 :=
  by
  ext s
  refine' mem_compression.trans ⟨_, fun h => Or.inl ⟨h, erase_mem_compression_of_mem_compression h⟩⟩
  rintro (h | h)
  · exact h.1
  · cases h.1 (mem_compression_of_insert_mem_compression h.2)
#align down.compression_idem Down.compression_idem
-/

#print Down.card_compression /-
/-- Down-compressing a family doesn't change its size. -/
@[simp]
theorem card_compression (a : α) (𝒜 : Finset (Finset α)) : (𝓓 a 𝒜).card = 𝒜.card :=
  by
  rw [compression, card_disj_union, image_filter,
    card_image_of_inj_on ((erase_inj_on' _).mono fun s hs => _), ← card_disjoint_union,
    filter_union_filter_neg_eq]
  · exact disjoint_filter_filter_neg _ _ _
  rw [mem_coe, mem_filter] at hs
  exact not_imp_comm.1 erase_eq_of_not_mem (ne_of_mem_of_not_mem hs.1 hs.2).symm
#align down.card_compression Down.card_compression
-/

end Down


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau
-/
import data.list.range
import data.int.order.basic

/-!
# Intervals in ℤ

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

This file defines integer ranges. `range m n` is the set of integers greater than `m` and strictly
less than `n`.

## Note

This could be unified with `data.list.intervals`. See the TODOs there.
-/

namespace int

/-- List enumerating `[m, n)`. This is the ℤ variant of `list.Ico`. -/
def range (m n : ℤ) : list ℤ :=
(list.range (to_nat (n-m))).map $ λ r, m+r

theorem mem_range_iff {m n r : ℤ} : r ∈ range m n ↔ m ≤ r ∧ r < n :=
⟨λ H, let ⟨s, h1, h2⟩ := list.mem_map.1 H in h2 ▸
  ⟨le_add_of_nonneg_right (coe_zero_le s),
  add_lt_of_lt_sub_left $ match n-m, h1 with
    | (k:ℕ), h1 := by rwa [list.mem_range, to_nat_coe_nat, ← coe_nat_lt] at h1
    end⟩,
λ ⟨h1, h2⟩, list.mem_map.2 ⟨to_nat (r-m),
  list.mem_range.2 $ by rw [← coe_nat_lt, to_nat_of_nonneg (sub_nonneg_of_le h1),
      to_nat_of_nonneg (sub_nonneg_of_le (le_of_lt (lt_of_le_of_lt h1 h2)))];
    exact sub_lt_sub_right h2 _,
  show m + _ = _, by rw [to_nat_of_nonneg (sub_nonneg_of_le h1), add_sub_cancel'_right]⟩⟩

instance decidable_le_lt (P : int → Prop) [decidable_pred P] (m n : ℤ) :
  decidable (∀ r, m ≤ r → r < n → P r) :=
decidable_of_iff (∀ r ∈ range m n, P r) $ by simp only [mem_range_iff, and_imp]

instance decidable_le_le (P : int → Prop) [decidable_pred P] (m n : ℤ) :
  decidable (∀ r, m ≤ r → r ≤ n → P r) :=
decidable_of_iff (∀ r ∈ range m (n+1), P r) $ by simp only [mem_range_iff, and_imp, lt_add_one_iff]

instance decidable_lt_lt (P : int → Prop) [decidable_pred P] (m n : ℤ) :
  decidable (∀ r, m < r → r < n → P r) :=
int.decidable_le_lt P _ _

instance decidable_lt_le (P : int → Prop) [decidable_pred P] (m n : ℤ) :
  decidable (∀ r, m < r → r ≤ n → P r) :=
int.decidable_le_le P _ _

end int


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.char_p.basic
import algebra.hom.iterate
import algebra.ring.equiv

/-!
# The perfect closure of a field

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

universes u v

open function

section defs

variables (R : Type u) [comm_semiring R] (p : ℕ) [fact p.prime] [char_p R p]

/-- A perfect ring is a ring of characteristic p that has p-th root. -/
class perfect_ring : Type u :=
(pth_root' : R → R)
(frobenius_pth_root' : ∀ x, frobenius R p (pth_root' x) = x)
(pth_root_frobenius' : ∀ x, pth_root' (frobenius R p x) = x)

/-- Frobenius automorphism of a perfect ring. -/
def frobenius_equiv [perfect_ring R p] : R ≃+* R :=
{ inv_fun := perfect_ring.pth_root' p,
  left_inv := perfect_ring.pth_root_frobenius',
  right_inv := perfect_ring.frobenius_pth_root',
  .. frobenius R p }

/-- `p`-th root of an element in a `perfect_ring` as a `ring_hom`. -/
def pth_root [perfect_ring R p] : R →+* R :=
(frobenius_equiv R p).symm

end defs

section

variables {R : Type u} [comm_semiring R] {S : Type v} [comm_semiring S] (f : R →* S) (g : R →+* S)
  {p : ℕ} [fact p.prime] [char_p R p] [perfect_ring R p] [char_p S p] [perfect_ring S p]

@[simp] lemma coe_frobenius_equiv : ⇑(frobenius_equiv R p) = frobenius R p := rfl

@[simp] lemma coe_frobenius_equiv_symm : ⇑(frobenius_equiv R p).symm = pth_root R p := rfl

@[simp] theorem frobenius_pth_root (x : R) : frobenius R p (pth_root R p x) = x :=
(frobenius_equiv R p).apply_symm_apply x

@[simp] theorem pth_root_pow_p (x : R) : pth_root R p x ^ p = x :=
frobenius_pth_root x

@[simp] theorem pth_root_frobenius (x : R) : pth_root R p (frobenius R p x) = x :=
(frobenius_equiv R p).symm_apply_apply x

@[simp] theorem pth_root_pow_p' (x : R) : pth_root R p (x ^ p) = x :=
pth_root_frobenius x

theorem left_inverse_pth_root_frobenius : left_inverse (pth_root R p) (frobenius R p) :=
pth_root_frobenius

theorem right_inverse_pth_root_frobenius : function.right_inverse (pth_root R p) (frobenius R p) :=
frobenius_pth_root

theorem commute_frobenius_pth_root : function.commute (frobenius R p) (pth_root R p) :=
λ x, (frobenius_pth_root x).trans (pth_root_frobenius x).symm

theorem eq_pth_root_iff {x y : R} : x = pth_root R p y ↔ frobenius R p x = y :=
(frobenius_equiv R p).to_equiv.eq_symm_apply

theorem pth_root_eq_iff {x y : R} : pth_root R p x = y ↔ x = frobenius R p y :=
(frobenius_equiv R p).to_equiv.symm_apply_eq

theorem monoid_hom.map_pth_root (x : R) : f (pth_root R p x) = pth_root S p (f x) :=
eq_pth_root_iff.2 $ by rw [← f.map_frobenius, frobenius_pth_root]

theorem monoid_hom.map_iterate_pth_root (x : R) (n : ℕ) :
  f (pth_root R p^[n] x) = (pth_root S p^[n] (f x)) :=
semiconj.iterate_right f.map_pth_root n x

theorem ring_hom.map_pth_root (x : R) :
  g (pth_root R p x) = pth_root S p (g x) :=
g.to_monoid_hom.map_pth_root x

theorem ring_hom.map_iterate_pth_root (x : R) (n : ℕ) :
  g (pth_root R p^[n] x) = (pth_root S p^[n] (g x)) :=
g.to_monoid_hom.map_iterate_pth_root x n

variables (p)
lemma injective_pow_p {x y : R} (hxy : x ^ p = y ^ p) : x = y :=
left_inverse_pth_root_frobenius.injective hxy

end

section

variables (K : Type u) [comm_ring K] (p : ℕ) [fact p.prime] [char_p K p]

/-- `perfect_closure K p` is the quotient by this relation. -/
@[mk_iff] inductive perfect_closure.r : (ℕ × K) → (ℕ × K) → Prop
| intro : ∀ n x, perfect_closure.r (n, x) (n+1, frobenius K p x)

/-- The perfect closure is the smallest extension that makes frobenius surjective. -/
def perfect_closure : Type u := quot (perfect_closure.r K p)

end

namespace perfect_closure

variables (K : Type u)

section ring

variables [comm_ring K] (p : ℕ) [fact p.prime] [char_p K p]

/-- Constructor for `perfect_closure`. -/
def mk (x : ℕ × K) : perfect_closure K p := quot.mk (r K p) x

@[simp] lemma quot_mk_eq_mk (x : ℕ × K) :
  (quot.mk (r K p) x : perfect_closure K p) = mk K p x := rfl

variables {K p}

/-- Lift a function `ℕ × K → L` to a function on `perfect_closure K p`. -/
@[elab_as_eliminator]
def lift_on {L : Type*} (x : perfect_closure K p) (f : ℕ × K → L)
  (hf : ∀ x y, r K p x y → f x = f y) : L :=
quot.lift_on x f hf

@[simp] lemma lift_on_mk {L : Sort*} (f : ℕ × K → L)
  (hf : ∀ x y, r K p x y → f x = f y) (x : ℕ × K) :
  (mk K p x).lift_on f hf = f x :=
rfl

@[elab_as_eliminator]
lemma induction_on (x : perfect_closure K p) {q : perfect_closure K p → Prop}
  (h : ∀ x, q (mk K p x)) : q x :=
quot.induction_on x h

variables (K p)

private lemma mul_aux_left (x1 x2 y : ℕ × K) (H : r K p x1 x2) :
  mk K p (x1.1 + y.1, ((frobenius K p)^[y.1] x1.2) * ((frobenius K p)^[x1.1] y.2)) =
  mk K p (x2.1 + y.1, ((frobenius K p)^[y.1] x2.2) * ((frobenius K p)^[x2.1] y.2)) :=
match x1, x2, H with
| _, _, r.intro n x := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_mul, nat.succ_add]; apply r.intro
end

private lemma mul_aux_right (x y1 y2 : ℕ × K) (H : r K p y1 y2) :
  mk K p (x.1 + y1.1, ((frobenius K p)^[y1.1] x.2) * ((frobenius K p)^[x.1] y1.2)) =
  mk K p (x.1 + y2.1, ((frobenius K p)^[y2.1] x.2) * ((frobenius K p)^[x.1] y2.2)) :=
match y1, y2, H with
| _, _, r.intro n y := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_mul]; apply r.intro
end

instance : has_mul (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, quot.lift (λ y:ℕ×K, mk K p
    (x.1 + y.1, ((frobenius K p)^[y.1] x.2) * ((frobenius K p)^[x.1] y.2))) (mul_aux_right K p x))
  (λ x1 x2 (H : r K p x1 x2), funext $ λ e, quot.induction_on e $ λ y,
mul_aux_left K p x1 x2 y H)⟩

@[simp] lemma mk_mul_mk (x y : ℕ × K) :
  mk K p x * mk K p y = mk K p
    (x.1 + y.1, ((frobenius K p)^[y.1] x.2) * ((frobenius K p)^[x.1] y.2)) :=
rfl

instance : comm_monoid (perfect_closure K p) :=
{ mul_assoc := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, congr_arg (quot.mk _) $
    by simp only [add_assoc, mul_assoc, ring_hom.iterate_map_mul,
      ← iterate_add_apply, add_comm, add_left_comm],
  one := mk K p (0, 1),
  one_mul := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_one, iterate_zero_apply, one_mul, zero_add]),
  mul_one := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_one, iterate_zero_apply, mul_one, add_zero]),
  mul_comm := λ e f, quot.induction_on e (λ ⟨m, x⟩, quot.induction_on f (λ ⟨n, y⟩,
    congr_arg (quot.mk _) $ by simp only [add_comm, mul_comm])),
  .. (infer_instance : has_mul (perfect_closure K p)) }

lemma one_def : (1 : perfect_closure K p) = mk K p (0, 1) := rfl

instance : inhabited (perfect_closure K p) := ⟨1⟩

private lemma add_aux_left (x1 x2 y : ℕ × K) (H : r K p x1 x2) :
  mk K p (x1.1 + y.1, ((frobenius K p)^[y.1] x1.2) + ((frobenius K p)^[x1.1] y.2)) =
  mk K p (x2.1 + y.1, ((frobenius K p)^[y.1] x2.2) + ((frobenius K p)^[x2.1] y.2)) :=
match x1, x2, H with
| _, _, r.intro n x := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_add, nat.succ_add]; apply r.intro
end

private lemma add_aux_right (x y1 y2 : ℕ × K) (H : r K p y1 y2) :
  mk K p (x.1 + y1.1, ((frobenius K p)^[y1.1] x.2) + ((frobenius K p)^[x.1] y1.2)) =
  mk K p (x.1 + y2.1, ((frobenius K p)^[y2.1] x.2) + ((frobenius K p)^[x.1] y2.2)) :=
match y1, y2, H with
| _, _, r.intro n y := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_add]; apply r.intro
end

instance : has_add (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, quot.lift (λ y:ℕ×K, mk K p
    (x.1 + y.1, ((frobenius K p)^[y.1] x.2) + ((frobenius K p)^[x.1] y.2))) (add_aux_right K p x))
  (λ x1 x2 (H : r K p x1 x2), funext $ λ e, quot.induction_on e $ λ y,
add_aux_left K p x1 x2 y H)⟩

@[simp] lemma mk_add_mk (x y : ℕ × K) :
  mk K p x + mk K p y =
    mk K p (x.1 + y.1, ((frobenius K p)^[y.1] x.2) + ((frobenius K p)^[x.1] y.2)) := rfl

instance : has_neg (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, mk K p (x.1, -x.2)) (λ x y (H : r K p x y), match x, y, H with
| _, _, r.intro n x := quot.sound $ by rw ← frobenius_neg; apply r.intro
end)⟩

@[simp] lemma neg_mk (x : ℕ × K) : - mk K p x = mk K p (x.1, -x.2) := rfl

instance : has_zero (perfect_closure K p) := ⟨mk K p (0, 0)⟩

lemma zero_def : (0 : perfect_closure K p) = mk K p (0, 0) := rfl
@[simp] lemma mk_zero_zero : mk K p (0, 0) = 0 := rfl

theorem mk_zero (n : ℕ) : mk K p (n, 0) = 0 :=
by induction n with n ih; [refl, rw ← ih]; symmetry; apply quot.sound;
have := r.intro n (0:K); rwa [frobenius_zero K p] at this

theorem r.sound (m n : ℕ) (x y : K) (H : frobenius K p^[m] x = y) :
  mk K p (n, x) = mk K p (m + n, y) :=
by subst H; induction m with m ih; [simp only [zero_add, iterate_zero_apply],
  rw [ih, nat.succ_add, iterate_succ']]; apply quot.sound; apply r.intro

instance : add_comm_group (perfect_closure K p) :=
{ add_assoc := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_add, ← iterate_add_apply, add_assoc, add_comm s _],
  zero := 0,
  zero_add := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_zero, iterate_zero_apply, zero_add]),
  add_zero := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_zero, iterate_zero_apply, add_zero]),
  sub_eq_add_neg := λ a b, rfl,
  add_left_neg := λ e, by exact quot.induction_on e (λ ⟨n, x⟩,
    by simp only [quot_mk_eq_mk, neg_mk, mk_add_mk,
      ring_hom.iterate_map_neg, add_left_neg, mk_zero]),
  add_comm := λ e f, quot.induction_on e (λ ⟨m, x⟩, quot.induction_on f (λ ⟨n, y⟩,
    congr_arg (quot.mk _) $ by simp only [add_comm])),
  .. (infer_instance : has_add (perfect_closure K p)),
  .. (infer_instance : has_neg (perfect_closure K p)) }

instance : comm_ring (perfect_closure K p) :=
{ left_distrib := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, show quot.mk _ _ = quot.mk _ _,
    by simp only [add_assoc, add_comm, add_left_comm]; apply r.sound;
    simp only [ring_hom.iterate_map_mul, ring_hom.iterate_map_add,
      ← iterate_add_apply, mul_add, add_comm, add_left_comm],
  right_distrib := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, show quot.mk _ _ = quot.mk _ _,
    by simp only [add_assoc, add_comm _ s, add_left_comm _ s]; apply r.sound;
    simp only [ring_hom.iterate_map_mul, ring_hom.iterate_map_add,
      ← iterate_add_apply, add_mul, add_comm, add_left_comm],
  .. perfect_closure.add_comm_group K p,
  .. add_monoid_with_one.unary,
  .. (infer_instance : comm_monoid (perfect_closure K p)) }

theorem eq_iff' (x y : ℕ × K) : mk K p x = mk K p y ↔
    ∃ z, (frobenius K p^[y.1 + z] x.2) = (frobenius K p^[x.1 + z] y.2) :=
begin
  split,
  { intro H,
    replace H := quot.exact _ H,
    induction H,
    case eqv_gen.rel : x y H
    { cases H with n x, exact ⟨0, rfl⟩ },
    case eqv_gen.refl : H
    { exact ⟨0, rfl⟩ },
    case eqv_gen.symm : x y H ih
    { cases ih with w ih, exact ⟨w, ih.symm⟩ },
    case eqv_gen.trans : x y z H1 H2 ih1 ih2
    { cases ih1 with z1 ih1,
      cases ih2 with z2 ih2,
      existsi z2+(y.1+z1),
      rw [← add_assoc, iterate_add_apply, ih1],
      rw [← iterate_add_apply, add_comm, iterate_add_apply, ih2],
      rw [← iterate_add_apply],
      simp only [add_comm, add_left_comm] } },
  intro H,
  cases x with m x,
  cases y with n y,
  cases H with z H, dsimp only at H,
  rw [r.sound K p (n+z) m x _ rfl, r.sound K p (m+z) n y _ rfl, H],
  rw [add_assoc, add_comm, add_comm z]
end

theorem nat_cast (n x : ℕ) : (x : perfect_closure K p) = mk K p (n, x) :=
begin
  induction n with n ih,
  { induction x with x ih, {simp},
    rw [nat.cast_succ, nat.cast_succ, ih], refl },
  rw ih, apply quot.sound,
  conv {congr, skip, skip, rw ← frobenius_nat_cast K p x},
  apply r.intro
end

theorem int_cast (x : ℤ) : (x : perfect_closure K p) = mk K p (0, x) :=
by induction x; simp only [int.cast_of_nat, int.cast_neg_succ_of_nat, nat_cast K p 0]; refl

instance : char_p (perfect_closure K p) p :=
begin
  constructor, intro x, rw ← char_p.cast_eq_zero_iff K,
  rw [← nat.cast_zero, nat_cast_eq_iff, nat.cast_zero]
end

theorem frobenius_mk (x : ℕ × K) :
  (frobenius (perfect_closure K p) p : perfect_closure K p → perfect_closure K p)
    (mk K p x) = mk _ _ (x.1, x.2^p) :=
begin
  simp only [frobenius_def], cases x with n x, dsimp only,
  suffices : ∀ p':ℕ, mk K p (n, x) ^ p' = mk K p (n, x ^ p'),
  { apply this },
  intro p, induction p with p ih,
  case nat.zero { apply r.sound, rw [(frobenius _ _).iterate_map_one, pow_zero] },
  case nat.succ
  { rw [pow_succ, ih],
    symmetry,
    apply r.sound,
    simp only [pow_succ, (frobenius _ _).iterate_map_mul] }
end

/-- Embedding of `K` into `perfect_closure K p` -/
def of : K →+* perfect_closure K p :=
{ to_fun := λ x, mk _ _ (0, x),
  map_one' := rfl,
  map_mul' := λ x y, rfl,
  map_zero' := rfl,
  map_add' := λ x y, rfl }

lemma of_apply (x : K) : of K p x = mk _ _ (0, x) := rfl

end ring

theorem eq_iff [comm_ring K] [is_domain K] (p : ℕ) [fact p.prime] [char_p K p]
  (x y : ℕ × K) : quot.mk (r K p) x = quot.mk (r K p) y ↔
    (frobenius K p^[y.1] x.2) = (frobenius K p^[x.1] y.2) :=
(eq_iff' K p x y).trans ⟨λ ⟨z, H⟩, (frobenius_inj K p).iterate z $
  by simpa only [add_comm, iterate_add] using H,
λ H, ⟨0, H⟩⟩

section field

variables [field K] (p : ℕ) [fact p.prime] [char_p K p]

instance : has_inv (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, quot.mk (r K p) (x.1, x.2⁻¹)) (λ x y (H : r K p x y), match x, y, H with
| _, _, r.intro n x := quot.sound $ by { simp only [frobenius_def], rw ← inv_pow, apply r.intro }
end)⟩

instance : field (perfect_closure K p) :=
{ exists_pair_ne := ⟨0, 1, λ H, zero_ne_one ((eq_iff _ _ _ _).1 H)⟩,
  mul_inv_cancel := λ e, induction_on e $ λ ⟨m, x⟩ H,
    have _ := mt (eq_iff _ _ _ _).2 H, (eq_iff _ _ _ _).2
      (by simp only [(frobenius _ _).iterate_map_one, (frobenius K p).iterate_map_zero,
        iterate_zero_apply, ← (frobenius _ p).iterate_map_mul] at this ⊢;
        rw [mul_inv_cancel this, (frobenius _ _).iterate_map_one]),
  inv_zero := congr_arg (quot.mk (r K p)) (by rw [inv_zero]),
  .. (infer_instance : has_inv (perfect_closure K p)),
  .. (infer_instance : comm_ring (perfect_closure K p)) }

instance : perfect_ring (perfect_closure K p) p :=
{ pth_root' := λ e, lift_on e (λ x, mk K p (x.1 + 1, x.2)) (λ x y H,
    match x, y, H with
    | _, _, r.intro n x := quot.sound (r.intro _ _)
    end),
  frobenius_pth_root' := λ e, induction_on e (λ ⟨n, x⟩,
    by { simp only [lift_on_mk, frobenius_mk], exact (quot.sound $ r.intro _ _).symm }),
  pth_root_frobenius' := λ e, induction_on e (λ ⟨n, x⟩,
    by { simp only [lift_on_mk, frobenius_mk], exact (quot.sound $ r.intro _ _).symm }) }

theorem eq_pth_root (x : ℕ × K) :
  mk K p x = (pth_root (perfect_closure K p) p^[x.1] (of K p x.2)) :=
begin
  rcases x with ⟨m, x⟩,
  induction m with m ih, {refl},
  rw [iterate_succ_apply', ← ih]; refl
end

/-- Given a field `K` of characteristic `p` and a perfect ring `L` of the same characteristic,
any homomorphism `K →+* L` can be lifted to `perfect_closure K p`. -/
def lift (L : Type v) [comm_semiring L] [char_p L p] [perfect_ring L p] :
  (K →+* L) ≃ (perfect_closure K p →+* L) :=
begin
  have := left_inverse_pth_root_frobenius.iterate,
  refine_struct { .. },
  field to_fun { intro f,
    refine_struct { .. },
    field to_fun { refine λ e, lift_on e (λ x, pth_root L p^[x.1] (f x.2)) _,
      rintro a b ⟨n⟩,
      simp only [f.map_frobenius, iterate_succ_apply, pth_root_frobenius] },
    field map_one' { exact f.map_one },
    field map_zero' { exact f.map_zero },
    field map_mul' { rintro ⟨x⟩ ⟨y⟩,
      simp only [quot_mk_eq_mk, lift_on_mk, mk_mul_mk, ring_hom.map_iterate_frobenius,
        ring_hom.iterate_map_mul, ring_hom.map_mul],
      rw [iterate_add_apply, this _ _, add_comm, iterate_add_apply, this _ _] },
    field map_add' { rintro ⟨x⟩ ⟨y⟩,
      simp only [quot_mk_eq_mk, lift_on_mk, mk_add_mk, ring_hom.map_iterate_frobenius,
        ring_hom.iterate_map_add, ring_hom.map_add],
      rw [iterate_add_apply, this _ _, add_comm x.1, iterate_add_apply, this _ _] } },
  field inv_fun { exact λ f, f.comp (of K p) },
  field left_inv { intro f, ext x, refl },
  field right_inv { intro f, ext ⟨x⟩,
    simp only [ring_hom.coe_mk, quot_mk_eq_mk, ring_hom.comp_apply, lift_on_mk],
    rw [eq_pth_root, ring_hom.map_iterate_pth_root] }
end

end field

end perfect_closure

/-- A reduced ring with prime characteristic and surjective frobenius map is perfect. -/
noncomputable def perfect_ring.of_surjective (k : Type*) [comm_ring k] [is_reduced k] (p : ℕ)
  [fact p.prime] [char_p k p] (h : function.surjective $ frobenius k p) :
  perfect_ring k p :=
{ pth_root' := function.surj_inv h,
  frobenius_pth_root' := function.surj_inv_eq h,
  pth_root_frobenius' := λ x, frobenius_inj _ _ $ function.surj_inv_eq h _ }


/-
Copyright (c) 2014 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad, Mario Carneiro

Basic operations on the natural numbers.
-/
import logic.basic algebra.order data.option

universe u

namespace nat
variables {m n k : ℕ}

theorem pred_sub (n m : ℕ) : pred n - m = pred (n - m) :=
by rw [← sub_one, nat.sub_sub, one_add]; refl

theorem pos_iff_ne_zero : n > 0 ↔ n ≠ 0 :=
⟨ne_of_gt, nat.pos_of_ne_zero⟩

theorem pos_iff_ne_zero' : 0 < n ↔ n ≠ 0 := pos_iff_ne_zero

protected theorem le_sub_add (n m : ℕ) : n ≤ n - m + m :=
or.elim (le_total n m)
  (assume : n ≤ m, begin rw [sub_eq_zero_of_le this, zero_add], exact this end)
  (assume : m ≤ n, begin rw (nat.sub_add_cancel this) end)

theorem sub_add_eq_max (n m : ℕ) : n - m + m = max n m :=
eq_max (nat.le_sub_add _ _) (le_add_left _ _) $ λ k h₁ h₂,
by rw ← nat.sub_add_cancel h₂; exact
add_le_add_right (nat.sub_le_sub_right h₁ _) _

theorem sub_add_min (n m : ℕ) : n - m + min n m = n :=
(le_total n m).elim
  (λ h, by rw [min_eq_left h, sub_eq_zero_of_le h, zero_add])
  (λ h, by rw [min_eq_right h, nat.sub_add_cancel h])

protected theorem add_sub_cancel' {n m : ℕ} (h : n ≥ m) : m + (n - m) = n :=
by rw [add_comm, nat.sub_add_cancel h]

protected theorem sub_eq_of_eq_add (h : k = m + n) : k - m = n :=
begin rw [h, nat.add_sub_cancel_left] end

theorem sub_min (n m : ℕ) : n - min n m = n - m :=
nat.sub_eq_of_eq_add $ by rw [add_comm, sub_add_min]

protected theorem lt_of_sub_pos (h : n - m > 0) : m < n :=
lt_of_not_ge
  (assume : m ≥ n,
    have n - m = 0, from sub_eq_zero_of_le this,
    begin rw this at h, exact lt_irrefl _ h end)

protected theorem lt_of_sub_lt_sub_right : m - k < n - k → m < n :=
le_imp_le_iff_lt_imp_lt.1 (λ h, nat.sub_le_sub_right h _)

protected theorem lt_of_sub_lt_sub_left : m - n < m - k → k < n :=
le_imp_le_iff_lt_imp_lt.1 (nat.sub_le_sub_left _)

protected theorem sub_lt_self (h₁ : m > 0) (h₂ : n > 0) : m - n < m :=
calc
  m - n = succ (pred m) - succ (pred n) : by rw [succ_pred_eq_of_pos h₁, succ_pred_eq_of_pos h₂]
    ... = pred m - pred n               : by rw succ_sub_succ
    ... ≤ pred m                        : sub_le _ _
    ... < succ (pred m)                 : lt_succ_self _
    ... = m                             : succ_pred_eq_of_pos h₁

protected theorem le_sub_right_of_add_le (h : m + k ≤ n) : m ≤ n - k :=
by rw ← nat.add_sub_cancel m k; exact nat.sub_le_sub_right h k

protected theorem le_sub_left_of_add_le (h : k + m ≤ n) : m ≤ n - k :=
nat.le_sub_right_of_add_le (by rwa add_comm at h)

protected theorem lt_sub_right_of_add_lt (h : m + k < n) : m < n - k :=
lt_of_succ_le $ nat.le_sub_right_of_add_le $
by rw succ_add; exact succ_le_of_lt h

protected theorem lt_sub_left_of_add_lt (h : k + m < n) : m < n - k :=
nat.lt_sub_right_of_add_lt (by rwa add_comm at h)

protected theorem add_lt_of_lt_sub_right (h : m < n - k) : m + k < n :=
@nat.lt_of_sub_lt_sub_right _ _ k (by rwa nat.add_sub_cancel)

protected theorem add_lt_of_lt_sub_left (h : m < n - k) : k + m < n :=
by rw add_comm; exact nat.add_lt_of_lt_sub_right h

protected theorem le_add_of_sub_le_right : n - k ≤ m → n ≤ m + k :=
le_imp_le_iff_lt_imp_lt.2 nat.lt_sub_right_of_add_lt

protected theorem le_add_of_sub_le_left : n - k ≤ m → n ≤ k + m :=
le_imp_le_iff_lt_imp_lt.2 nat.lt_sub_left_of_add_lt

protected theorem lt_add_of_sub_lt_right : n - k < m → n < m + k :=
le_imp_le_iff_lt_imp_lt.1 nat.le_sub_right_of_add_le

protected theorem lt_add_of_sub_lt_left : n - k < m → n < k + m :=
le_imp_le_iff_lt_imp_lt.1 nat.le_sub_left_of_add_le

protected theorem sub_le_left_of_le_add : n ≤ k + m → n - k ≤ m :=
le_imp_le_iff_lt_imp_lt.2 nat.add_lt_of_lt_sub_left

protected theorem sub_le_right_of_le_add : n ≤ m + k → n - k ≤ m :=
le_imp_le_iff_lt_imp_lt.2 nat.add_lt_of_lt_sub_right

protected theorem sub_lt_left_iff_lt_add (H : n ≤ k) : k - n < m ↔ k < n + m :=
⟨nat.lt_add_of_sub_lt_left,
 λ h₁,
  have succ k ≤ n + m,   from succ_le_of_lt h₁,
  have succ (k - n) ≤ m, from
    calc succ (k - n) = succ k - n : by rw (succ_sub H)
          ...     ≤ n + m - n      : nat.sub_le_sub_right this n
          ...     = m              : by rw nat.add_sub_cancel_left,
  lt_of_succ_le this⟩

protected theorem le_sub_left_iff_add_le (H : m ≤ k) : n ≤ k - m ↔ m + n ≤ k :=
le_iff_le_iff_lt_iff_lt.2 (nat.sub_lt_left_iff_lt_add H)

protected theorem le_sub_right_iff_add_le (H : n ≤ k) : m ≤ k - n ↔ m + n ≤ k :=
by rw [nat.le_sub_left_iff_add_le H, add_comm]

protected theorem lt_sub_left_iff_add_lt (H : m ≤ k) : n < k - m ↔ m + n < k :=
⟨λ h, by have := nat.add_le_add_left h m;
         rwa [nat.add_sub_cancel' H] at this,
 nat.lt_sub_left_of_add_lt⟩

protected theorem lt_sub_right_iff_add_lt (H : n ≤ k) : m < k - n ↔ m + n < k :=
by rw [nat.lt_sub_left_iff_add_lt H, add_comm]

theorem sub_le_left_iff_le_add (H : n ≤ m) : m - n ≤ k ↔ m ≤ n + k :=
le_iff_le_iff_lt_iff_lt.2 (nat.lt_sub_left_iff_add_lt H)

theorem sub_le_right_iff_le_add (H : k ≤ m) : m - k ≤ n ↔ m ≤ n + k :=
by rw [nat.sub_le_left_iff_le_add H, add_comm]

protected theorem sub_lt_right_iff_lt_add (H : k ≤ m) : m - k < n ↔ m < n + k :=
by rw [nat.sub_lt_left_iff_lt_add H, add_comm]

protected theorem sub_le_sub_left_iff (H : k ≤ m) : m - n ≤ m - k ↔ k ≤ n :=
⟨λ h,
  have k + (m - k) - n ≤ m - k, by rwa nat.add_sub_cancel' H,
  nat.le_of_add_le_add_right (nat.le_add_of_sub_le_left this),
nat.sub_le_sub_left _⟩

protected theorem sub_lt_sub_right_iff (H : k ≤ m) : m - k < n - k ↔ m < n :=
le_iff_le_iff_lt_iff_lt.1 (nat.sub_le_sub_right_iff _ _ _ H)

protected theorem sub_lt_sub_left_iff (H : n ≤ m) : m - n < m - k ↔ k < n :=
le_iff_le_iff_lt_iff_lt.1 (nat.sub_le_sub_left_iff H)

protected theorem sub_le_iff (h₁ : n ≤ m) (h₂ : k ≤ m) : m - n ≤ k ↔ m - k ≤ n :=
(nat.sub_le_left_iff_le_add h₁).trans (nat.sub_le_right_iff_le_add h₂).symm

protected theorem sub_lt_iff (h₁ : n ≤ m) (h₂ : k ≤ m) : m - n < k ↔ m - k < n :=
(nat.sub_lt_left_iff_lt_add h₁).trans (nat.sub_lt_right_iff_lt_add h₂).symm

lemma lt_pred_of_succ_lt {n m : ℕ} : succ n < m → n < pred m :=
@nat.lt_sub_right_of_add_lt n m 1

protected theorem mul_ne_zero {n m : ℕ} (n0 : n ≠ 0) (m0 : m ≠ 0) : n * m ≠ 0
| nm := (eq_zero_of_mul_eq_zero nm).elim n0 m0

@[simp] protected theorem mul_eq_zero {a b : ℕ} : a * b = 0 ↔ a = 0 ∨ b = 0 :=
iff.intro eq_zero_of_mul_eq_zero (by simp [or_imp_distrib] {contextual := tt})

@[simp] protected theorem zero_eq_mul {a b : ℕ} : 0 = a * b ↔ a = 0 ∨ b = 0 :=
by rw [eq_comm, nat.mul_eq_zero]

attribute [simp] nat.div_self

protected theorem div_le_div_right {n m : ℕ} (h : n ≤ m) {k : ℕ} : n / k ≤ m / k :=
(nat.eq_zero_or_pos k).elim (λ k0, by simp [k0]) $ λ hk,
(nat.le_div_iff_mul_le _ _ hk).2 $ le_trans (nat.div_mul_le_self _ _) h

protected theorem eq_mul_of_div_eq_right {a b c : ℕ} (H1 : b ∣ a) (H2 : a / b = c) :
  a = b * c :=
by rw [← H2, nat.mul_div_cancel' H1]

protected theorem div_eq_iff_eq_mul_right {a b c : ℕ} (H : b > 0) (H' : b ∣ a) :
  a / b = c ↔ a = b * c :=
⟨nat.eq_mul_of_div_eq_right H', nat.div_eq_of_eq_mul_right H⟩

protected theorem div_eq_iff_eq_mul_left {a b c : ℕ} (H : b > 0) (H' : b ∣ a) :
  a / b = c ↔ a = c * b :=
by rw mul_comm; exact nat.div_eq_iff_eq_mul_right H H'

protected theorem eq_mul_of_div_eq_left {a b c : ℕ} (H1 : b ∣ a) (H2 : a / b = c) :
  a = c * b :=
by rw [mul_comm, nat.eq_mul_of_div_eq_right H1 H2]

protected theorem mul_div_cancel_left' {a b : ℕ} (Hd :  a ∣ b) : a * (b / a) = b :=
by rw [mul_comm,nat.div_mul_cancel Hd]

protected theorem div_mod_unique {n k m d : ℕ} (h : 0 < k) :
  n / k = d ∧ n % k = m ↔ m + k * d = n ∧ m < k :=
⟨λ ⟨e₁, e₂⟩, e₁ ▸ e₂ ▸ ⟨mod_add_div _ _, mod_lt _ h⟩,
 λ ⟨h₁, h₂⟩, h₁ ▸ by rw [add_mul_div_left _ _ h, add_mul_mod_self_left];
   simp [div_eq_of_lt, mod_eq_of_lt, h₂]⟩

protected theorem mul_right_inj {a b c : ℕ} (ha : a > 0) : b * a = c * a ↔ b = c :=
⟨nat.eq_of_mul_eq_mul_right ha, λ e, e ▸ rfl⟩

protected theorem mul_left_inj {a b c : ℕ} (ha : a > 0) : a * b = a * c ↔ b = c :=
⟨nat.eq_of_mul_eq_mul_left ha, λ e, e ▸ rfl⟩

@[simp] protected theorem dvd_one {n : ℕ} : n ∣ 1 ↔ n = 1 :=
⟨eq_one_of_dvd_one, λ e, e.symm ▸ dvd_refl _⟩

protected theorem mul_dvd_mul_iff_left {a b c : ℕ} (ha : a > 0) : a * b ∣ a * c ↔ b ∣ c :=
exists_congr $ λ d, by rw [mul_assoc, nat.mul_left_inj ha]

protected theorem mul_dvd_mul_iff_right {a b c : ℕ} (hc : c > 0) : a * c ∣ b * c ↔ a ∣ b :=
exists_congr $ λ d, by rw [mul_right_comm, nat.mul_right_inj hc]

@[simp] theorem mod_mod (a n : ℕ) : (a % n) % n = a % n :=
(eq_zero_or_pos n).elim
  (λ n0, by simp [n0])
  (λ npos, mod_eq_of_lt (mod_lt _ npos))

theorem add_pos_left {m : ℕ} (h : m > 0) (n : ℕ) : m + n > 0 :=
calc
  m + n > 0 + n : nat.add_lt_add_right h n
    ... = n     : nat.zero_add n
    ... ≥ 0     : zero_le n

theorem add_pos_right (m : ℕ) {n : ℕ} (h : n > 0) : m + n > 0 :=
begin rw add_comm, exact add_pos_left h m end

theorem add_pos_iff_pos_or_pos (m n : ℕ) : m + n > 0 ↔ m > 0 ∨ n > 0 :=
iff.intro
  begin
    intro h,
    cases m with m,
    {simp [zero_add] at h, exact or.inr h},
    exact or.inl (succ_pos _)
  end
  begin
    intro h, cases h with mpos npos,
    { apply add_pos_left mpos },
    apply add_pos_right _ npos
  end

theorem succ_le_succ_iff {m n : ℕ} : succ m ≤ succ n ↔ m ≤ n :=
⟨le_of_succ_le_succ, succ_le_succ⟩

theorem lt_succ_iff {m n : ℕ} : m < succ n ↔ m ≤ n :=
succ_le_succ_iff

lemma lt_succ_iff_lt_or_eq {n i : ℕ} : n < i.succ ↔ (n < i ∨ n = i) :=
lt_succ_iff.trans le_iff_lt_or_eq

theorem le_zero_iff {i : ℕ} : i ≤ 0 ↔ i = 0 :=
⟨nat.eq_zero_of_le_zero, assume h, h ▸ le_refl i⟩

theorem le_add_one_iff {i j : ℕ} : i ≤ j + 1 ↔ (i ≤ j ∨ i = j + 1) :=
⟨assume h,
  match nat.eq_or_lt_of_le h with
  | or.inl h := or.inr h
  | or.inr h := or.inl $ nat.le_of_succ_le_succ h
  end,
  or.rec (assume h, le_trans h $ nat.le_add_right _ _) le_of_eq⟩

theorem mul_self_inj {n m : ℕ} : n * n = m * m ↔ n = m :=
le_antisymm_iff.trans (le_antisymm_iff.trans
  (and_congr mul_self_le_mul_self_iff mul_self_le_mul_self_iff)).symm

instance decidable_ball_lt (n : nat) (P : Π k < n, Prop) :
  ∀ [H : ∀ n h, decidable (P n h)], decidable (∀ n h, P n h) :=
begin
  induction n with n IH; intro; resetI,
  { exact is_true (λ n, dec_trivial) },
  cases IH (λ k h, P k (lt_succ_of_lt h)) with h,
  { refine is_false (mt _ h), intros hn k h, apply hn },
  by_cases p : P n (lt_succ_self n),
  { exact is_true (λ k h',
     (lt_or_eq_of_le $ le_of_lt_succ h').elim (h _)
       (λ e, match k, e, h' with _, rfl, h := p end)) },
  { exact is_false (mt (λ hn, hn _ _) p) }
end

instance decidable_forall_fin {n : ℕ} (P : fin n → Prop)
  [H : decidable_pred P] : decidable (∀ i, P i) :=
decidable_of_iff (∀ k h, P ⟨k, h⟩) ⟨λ a ⟨k, h⟩, a k h, λ a k h, a ⟨k, h⟩⟩

instance decidable_ball_le (n : ℕ) (P : Π k ≤ n, Prop)
  [H : ∀ n h, decidable (P n h)] : decidable (∀ n h, P n h) :=
decidable_of_iff (∀ k (h : k < succ n), P k (le_of_lt_succ h))
⟨λ a k h, a k (lt_succ_of_le h), λ a k h, a k _⟩

instance decidable_lo_hi (lo hi : ℕ) (P : ℕ → Prop) [H : decidable_pred P] : decidable (∀x, lo ≤ x → x < hi → P x) :=
decidable_of_iff (∀ x < hi - lo, P (lo + x))
⟨λal x hl hh, by have := al (x - lo) (lt_of_not_ge $
  (not_congr (nat.sub_le_sub_right_iff _ _ _ hl)).2 $ not_le_of_gt hh);
  rwa [nat.add_sub_of_le hl] at this,
λal x h, al _ (nat.le_add_right _ _) (nat.add_lt_of_lt_sub_left h)⟩

instance decidable_lo_hi_le (lo hi : ℕ) (P : ℕ → Prop) [H : decidable_pred P] : decidable (∀x, lo ≤ x → x ≤ hi → P x) :=
decidable_of_iff (∀x, lo ≤ x → x < hi + 1 → P x) $
ball_congr $ λ x hl, imp_congr lt_succ_iff iff.rfl

protected theorem bit0_le {n m : ℕ} (h : n ≤ m) : bit0 n ≤ bit0 m :=
add_le_add h h

protected theorem bit1_le {n m : ℕ} (h : n ≤ m) : bit1 n ≤ bit1 m :=
succ_le_succ (add_le_add h h)

theorem bit_le : ∀ (b : bool) {n m : ℕ}, n ≤ m → bit b n ≤ bit b m
| tt n m h := nat.bit1_le h
| ff n m h := nat.bit0_le h

theorem bit_ne_zero (b) {n} (h : n ≠ 0) : bit b n ≠ 0 :=
by cases b; [exact nat.bit0_ne_zero h, exact nat.bit1_ne_zero _]

theorem bit0_le_bit : ∀ (b) {m n : ℕ}, m ≤ n → bit0 m ≤ bit b n
| tt m n h := le_of_lt $ nat.bit0_lt_bit1 h
| ff m n h := nat.bit0_le h

theorem bit_le_bit1 : ∀ (b) {m n : ℕ}, m ≤ n → bit b m ≤ bit1 n
| ff m n h := le_of_lt $ nat.bit0_lt_bit1 h
| tt m n h := nat.bit1_le h

theorem bit_lt_bit0 : ∀ (b) {n m : ℕ}, n < m → bit b n < bit0 m
| tt n m h := nat.bit1_lt_bit0 h
| ff n m h := nat.bit0_lt h

theorem bit_lt_bit (a b) {n m : ℕ} (h : n < m) : bit a n < bit b m :=
lt_of_lt_of_le (bit_lt_bit0 _ h) (bit0_le_bit _ (le_refl _))

/- partial subtraction -/

/-- Partial predecessor operation. Returns `ppred n = some m`
  if `n = m + 1`, otherwise `none`. -/
@[simp] def ppred : ℕ → option ℕ
| 0     := none
| (n+1) := some n

/-- Partial subtraction operation. Returns `psub m n = some k`
  if `m = n + k`, otherwise `none`. -/
@[simp] def psub (m : ℕ) : ℕ → option ℕ
| 0     := some m
| (n+1) := psub n >>= ppred

theorem pred_eq_ppred (n : ℕ) : pred n = (ppred n).get_or_else 0 :=
by cases n; refl

theorem sub_eq_psub (m : ℕ) : ∀ n, m - n = (psub m n).get_or_else 0
| 0     := rfl
| (n+1) := (pred_eq_ppred (m-n)).trans $
  by rw [sub_eq_psub, psub]; cases psub m n; refl

@[simp] theorem ppred_eq_some {m : ℕ} : ∀ {n}, ppred n = some m ↔ succ m = n
| 0     := by split; intro h; contradiction
| (n+1) := by dsimp; split; intro h; injection h; subst n

@[simp] theorem ppred_eq_none : ∀ {n : ℕ}, ppred n = none ↔ n = 0
| 0     := by simp
| (n+1) := by dsimp; split; contradiction

theorem psub_eq_some {m : ℕ} : ∀ {n k}, psub m n = some k ↔ k + n = m
| 0     k := by simp [eq_comm]
| (n+1) k := by dsimp; apply option.bind_eq_some.trans; simp [psub_eq_some]

theorem psub_eq_none (m n : ℕ) : psub m n = none ↔ m < n :=
begin
  cases s : psub m n; simp [eq_comm],
  { show m < n, refine lt_of_not_ge (λ h, _),
    cases le.dest h with k e,
    injection s.symm.trans (psub_eq_some.2 $ (add_comm _ _).trans e) },
  { show n ≤ m, rw ← psub_eq_some.1 s, apply le_add_left }
end

theorem ppred_eq_pred {n} (h : 0 < n) : ppred n = some (pred n) :=
ppred_eq_some.2 $ succ_pred_eq_of_pos h

theorem psub_eq_sub {m n} (h : n ≤ m) : psub m n = some (m - n) :=
psub_eq_some.2 $ nat.sub_add_cancel h

theorem psub_add (m n k) : psub m (n + k) = do x ← psub m n, psub x k :=
by induction k; simp [*, add_succ, bind_assoc]

/- pow -/

@[simp] lemma one_pow : ∀ n : ℕ, 1 ^ n = 1
| 0 := rfl
| (k+1) := show 1^k * 1 = 1, by rw [mul_one, one_pow]

theorem pow_add (a m n : ℕ) : a^(m + n) = a^m * a^n :=
by induction n; simp [*, pow_succ, mul_assoc]

theorem pow_two (a : ℕ) : a ^ 2 = a * a := show (1 * a) * a = _, by rw one_mul

theorem pow_dvd_pow (a : ℕ) {m n : ℕ} (h : m ≤ n) : a^m ∣ a^n :=
by rw [← nat.add_sub_cancel' h, pow_add]; apply dvd_mul_right

theorem pow_dvd_pow_of_dvd {a b : ℕ} (h : a ∣ b) : ∀ n:ℕ, a^n ∣ b^n
| 0     := dvd_refl _
| (n+1) := mul_dvd_mul (pow_dvd_pow_of_dvd n) h

theorem mul_pow (a b n : ℕ) : (a * b) ^ n = a ^ n * b ^ n :=
by induction n; simp [*, nat.pow_succ, mul_comm, mul_assoc, mul_left_comm]

protected theorem pow_mul (a b n : ℕ) : n ^ (a * b) = (n ^ a) ^ b :=
by induction b; simp [*, nat.succ_eq_add_one, nat.pow_add, mul_add, mul_comm]

theorem pow_pos {p : ℕ} (hp : p > 0) : ∀ n : ℕ, p ^ n > 0
| 0 := by simpa using zero_lt_one
| (k+1) := mul_pos (pow_pos _) hp

lemma pow_eq_mul_pow_sub (p : ℕ) {m n : ℕ} (h : m ≤ n) : p ^ m * p ^ (n - m)  = p ^ n :=
by rw [←nat.pow_add, nat.add_sub_cancel' h]

lemma pow_lt_pow_succ {p : ℕ} (h : p > 1) (n : ℕ) : p^n < p^(n+1) :=
suffices p^n*1 < p^n*p, by simpa,
nat.mul_lt_mul_of_pos_left h (nat.pow_pos (lt_of_succ_lt h) n)

lemma lt_pow_self {p : ℕ} (h : p > 1) : ∀ n : ℕ, n < p ^ n
| 0 := by simp [zero_lt_one]
| (n+1) := calc
  n + 1 < p^n + 1 : nat.add_lt_add_right (lt_pow_self _) _
    ... ≤ p ^ (n+1) : pow_lt_pow_succ h _

lemma not_pos_pow_dvd : ∀ {p k : ℕ} (hp : p > 1) (hk : k > 1), ¬ p^k ∣ p
| (succ p) (succ k) hp hk h :=
  have (succ p)^k * succ p ∣ 1 * succ p, by simpa,
  have (succ p) ^ k ∣ 1, from dvd_of_mul_dvd_mul_right (succ_pos _) this,
  have he : (succ p) ^ k = 1, from eq_one_of_dvd_one this,
  have k < (succ p) ^ k, from lt_pow_self hp k,
  have k < 1, by rwa [he] at this,
  have k = 0, from eq_zero_of_le_zero $ le_of_lt_succ this,
  have 1 > 1, by rwa [this] at hk,
  absurd this dec_trivial

@[simp] theorem bodd_div2_eq (n : ℕ) : bodd_div2 n = (bodd n, div2 n) :=
by unfold bodd div2; cases bodd_div2 n; refl

@[simp] lemma bodd_bit0 (n) : bodd (bit0 n) = ff := bodd_bit ff n
@[simp] lemma bodd_bit1 (n) : bodd (bit1 n) = tt := bodd_bit tt n

@[simp] lemma div2_bit0 (n) : div2 (bit0 n) = n := div2_bit ff n
@[simp] lemma div2_bit1 (n) : div2 (bit1 n) = n := div2_bit tt n

/- iterate -/

section
variables {α : Sort*} (op : α → α)

@[simp] theorem iterate_zero (a : α) : op^[0] a = a := rfl

@[simp] theorem iterate_succ (n : ℕ) (a : α) : op^[succ n] a = (op^[n]) (op a) := rfl

theorem iterate_add : ∀ (m n : ℕ) (a : α), op^[m + n] a = (op^[m]) (op^[n] a)
| m 0 a := rfl
| m (succ n) a := iterate_add m n _

theorem iterate_succ' (n : ℕ) (a : α) : op^[succ n] a = op (op^[n] a) :=
by rw [← one_add, iterate_add]; refl

end

/- size and shift -/

theorem shiftl'_ne_zero_left (b) {m} (h : m ≠ 0) (n) : shiftl' b m n ≠ 0 :=
by induction n; simp [shiftl', bit_ne_zero, *]

theorem shiftl'_tt_ne_zero (m) : ∀ {n} (h : n ≠ 0), shiftl' tt m n ≠ 0
| 0        h := absurd rfl h
| (succ n) _ := nat.bit1_ne_zero _

@[simp] theorem size_zero : size 0 = 0 := rfl

@[simp] theorem size_bit {b n} (h : bit b n ≠ 0) : size (bit b n) = succ (size n) :=
begin
  rw size,
  conv { to_lhs, rw [binary_rec], simp [h] },
  rw div2_bit, refl
end

@[simp] theorem size_bit0 {n} (h : n ≠ 0) : size (bit0 n) = succ (size n) :=
@size_bit ff n (nat.bit0_ne_zero h)

@[simp] theorem size_bit1 (n) : size (bit1 n) = succ (size n) :=
@size_bit tt n (nat.bit1_ne_zero n)

@[simp] theorem size_one : size 1 = 1 := by apply size_bit1 0

@[simp] theorem size_shiftl' {b m n} (h : shiftl' b m n ≠ 0) :
  size (shiftl' b m n) = size m + n :=
begin
  induction n with n IH; simp [shiftl'] at h ⊢,
  rw [size_bit h, nat.add_succ],
  by_cases s0 : shiftl' b m n = 0; [skip, rw [IH s0]],
  rw s0 at h ⊢,
  cases b, {exact absurd rfl h},
  have : shiftl' tt m n + 1 = 1 := congr_arg (+1) s0,
  rw [shiftl'_tt_eq_mul_pow] at this,
  have m0 := succ_inj (eq_one_of_dvd_one ⟨_, this.symm⟩),
  subst m0,
  simp at this,
  have : n = 0 := eq_zero_of_le_zero (le_of_not_gt $ λ hn,
    ne_of_gt (pow_lt_pow_of_lt_right dec_trivial hn) this),
  subst n, refl
end

@[simp] theorem size_shiftl {m} (h : m ≠ 0) (n) :
  size (shiftl m n) = size m + n :=
size_shiftl' (shiftl'_ne_zero_left _ h _)

theorem lt_size_self (n : ℕ) : n < 2^size n :=
begin
  rw [← one_shiftl],
  have : ∀ {n}, n = 0 → n < shiftl 1 (size n) :=
    λ n e, by subst e; exact dec_trivial,
  apply binary_rec _ _ n, {apply this rfl},
  intros b n IH,
  by_cases bit b n = 0, {apply this h},
  rw [size_bit h, shiftl_succ],
  exact bit_lt_bit0 _ IH
end

theorem size_le {m n : ℕ} : size m ≤ n ↔ m < 2^n :=
⟨λ h, lt_of_lt_of_le (lt_size_self _) (pow_le_pow_of_le_right dec_trivial h),
begin
  rw [← one_shiftl], revert n,
  apply binary_rec _ _ m,
  { intros n h, apply zero_le },
  { intros b m IH n h,
    by_cases e : bit b m = 0, { rw e, apply zero_le },
    rw [size_bit e],
    cases n with n,
    { exact e.elim (eq_zero_of_le_zero (le_of_lt_succ h)) },
    { apply succ_le_succ (IH _),
      apply le_imp_le_iff_lt_imp_lt.1 (λ h', bit0_le_bit _ h') h } }
end⟩

theorem lt_size {m n : ℕ} : m < size n ↔ 2^m ≤ n :=
by rw [← not_lt, iff_not_comm, not_lt, size_le]

theorem size_pos {n : ℕ} : 0 < size n ↔ 0 < n :=
by rw lt_size; refl

theorem size_eq_zero {n : ℕ} : size n = 0 ↔ n = 0 :=
by have := @size_pos n; simp [pos_iff_ne_zero'] at this;
   exact not_iff_not.1 this

theorem size_pow {n : ℕ} : size (2^n) = n+1 :=
le_antisymm
  (size_le.2 $ pow_lt_pow_of_lt_right dec_trivial (lt_succ_self _))
  (lt_size.2 $ le_refl _)

theorem size_le_size {m n : ℕ} (h : m ≤ n) : size m ≤ size n :=
size_le.2 $ lt_of_le_of_lt h (lt_size_self _)

/- factorial -/

/-- `fact n` is the factorial of `n`. -/
@[simp] def fact : nat → nat
| 0        := 1
| (succ n) := succ n * fact n

@[simp] theorem fact_zero : fact 0 = 1 := rfl

@[simp] theorem fact_one : fact 1 = 1 := rfl

@[simp] theorem fact_succ (n) : fact (succ n) = succ n * fact n := rfl

theorem fact_pos : ∀ n, fact n > 0
| 0        := zero_lt_one
| (succ n) := mul_pos (succ_pos _) (fact_pos n)

theorem fact_ne_zero (n : ℕ) : fact n ≠ 0 := ne_of_gt (fact_pos _)

theorem fact_dvd_fact {m n} (h : m ≤ n) : fact m ∣ fact n :=
begin
  induction n with n IH; simp,
  { have := eq_zero_of_le_zero h, subst m, simp },
  { cases eq_or_lt_of_le h with he hl,
    { subst m, simp },
    { apply dvd_mul_of_dvd_right (IH (le_of_lt_succ hl)) } }
end

theorem dvd_fact : ∀ {m n}, m > 0 → m ≤ n → m ∣ fact n
| (succ m) n _ h := dvd_of_mul_right_dvd (fact_dvd_fact h)

theorem fact_le {m n} (h : m ≤ n) : fact m ≤ fact n :=
le_of_dvd (fact_pos _) (fact_dvd_fact h)

section find_greatest

/-- `find_greatest P b` is the largest `i ≤ bound` such that `P i` holds, or `0` if no such `i`
exists -/
protected def find_greatest (P : ℕ → Prop) [decidable_pred P] : ℕ → ℕ
| 0       := 0
| (n + 1) := if P (n + 1) then n + 1 else find_greatest n

variables {P : ℕ → Prop} [decidable_pred P]

@[simp] lemma find_greatest_zero : nat.find_greatest P 0 = 0 := rfl

@[simp] lemma find_greatest_eq : ∀{b}, P b → nat.find_greatest P b = b
| 0       h := rfl
| (n + 1) h := by simp [nat.find_greatest, h]

@[simp] lemma find_greatest_of_not {b} (h : ¬ P (b + 1)) :
  nat.find_greatest P (b + 1) = nat.find_greatest P b :=
by simp [nat.find_greatest, h]

lemma find_greatest_spec_and_le :
  ∀{b m}, m ≤ b → P m → P (nat.find_greatest P b) ∧ m ≤ nat.find_greatest P b
| 0       m hm hP :=
  have m = 0, from le_antisymm hm (nat.zero_le _),
  show P 0 ∧ m ≤ 0, from this ▸ ⟨hP, le_refl _⟩
| (b + 1) m hm hP :=
  begin
    by_cases h : P (b + 1),
    { simp [h, hm] },
    { have : m ≠ b + 1 := assume this, h $ this ▸ hP,
      have : m ≤ b := (le_of_not_gt $ assume h : b + 1 ≤ m, this $ le_antisymm hm h),
      have : P (nat.find_greatest P b) ∧ m ≤ nat.find_greatest P b :=
        find_greatest_spec_and_le this hP,
      simp [h, this] }
  end

lemma find_greatest_spec {b} : (∃m, m ≤ b ∧ P m) → P (nat.find_greatest P b)
| ⟨m, hmb, hm⟩ := (find_greatest_spec_and_le hmb hm).1

lemma find_greatest_le : ∀ {b}, nat.find_greatest P b ≤ b
| 0       := le_refl _
| (b + 1) :=
  have nat.find_greatest P b ≤ b + 1, from le_trans find_greatest_le (nat.le_succ b),
  by by_cases P (b + 1); simp [h, this]

lemma le_find_greatest {b m} (hmb : m ≤ b) (hm : P m) : m ≤ nat.find_greatest P b :=
(find_greatest_spec_and_le hmb hm).2

lemma find_greatest_is_greatest {P : ℕ → Prop} [decidable_pred P] {b} :
  (∃ m, m ≤ b ∧ P m) → ∀ k, nat.find_greatest P b < k ∧ k ≤ b → ¬ P k
| ⟨m, hmb, hP⟩ k ⟨hk, hkb⟩ hPk := lt_irrefl k $ lt_of_le_of_lt (le_find_greatest hkb hPk) hk

end find_greatest

section div
lemma dvd_div_of_mul_dvd {a b c : ℕ} (h : a * b ∣ c) : b ∣ c / a :=
if ha : a = 0 then
  by simp [ha]
else
  have ha : a > 0, from nat.pos_of_ne_zero ha,
  have h1 : ∃ d, c = a * b * d, from h,
  let ⟨d, hd⟩ := h1 in
  have hac : a ∣ c, from dvd_of_mul_right_dvd h,
  have h2 : c / a = b * d, from nat.div_eq_of_eq_mul_right ha (by simpa [mul_assoc] using hd),
  show ∃ d, c / a = b * d, from ⟨d, h2⟩

lemma mul_dvd_of_dvd_div {a b c : ℕ} (hab : c ∣ b) (h : a ∣ b / c) : c * a ∣ b :=
have h1 : ∃ d, b / c = a * d, from h,
have h2 : ∃ e, b = c * e, from hab,
let ⟨d, hd⟩ := h1, ⟨e, he⟩ := h2 in
have h3 : b = a * d * c, from
  nat.eq_mul_of_div_eq_left hab hd,
show ∃ d, b = c * a * d, from ⟨d, by cc⟩

lemma nat.div_mul_div {a b c d : ℕ} (hab : b ∣ a) (hcd : d ∣ c) :
      (a / b) * (c / d) = (a * c) / (b * d) :=
have exi1 : ∃ x, a = b * x, from hab,
have exi2 : ∃ y, c = d * y, from hcd,
if hb : b = 0 then by simp [hb]
else have b > 0, from nat.pos_of_ne_zero hb,
if hd : d = 0 then by simp [hd]
else have d > 0, from nat.pos_of_ne_zero hd,
begin
  cases exi1 with x hx, cases exi2 with y hy,
  rw [hx, hy, nat.mul_div_cancel_left, nat.mul_div_cancel_left],
  symmetry,
  apply nat.div_eq_of_eq_mul_left,
  apply mul_pos,
  repeat {assumption},
  cc
end

lemma pow_div_of_le_of_pow_div {p m n k : ℕ} (hmn : m ≤ n) (hdiv : p ^ n ∣ k) : p ^ m ∣ k :=
have p ^ m ∣ p ^ n, from pow_dvd_pow _ hmn,
dvd_trans this hdiv

end div

end nat


/-
Copyright (c) 2023 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/
import data.real.basic

import number_theory.number_field.class_number
import tactic
/-

# More on rings of integers.

Lean has a lot of commutative algebra machinery in its maths library. For example it knows
that the set of elements of a number field which are integral over ℤ form a ring; the fact
that the sum of two integral elements is integral is not obvious. Here is a high-powered
conceptual proof formalised in Lean. Note that the version in Lean's maths library of this
proof was written by an Imperial undergrad!

-/

variables (K : Type) [comm_ring K] -- [number_field K] -- not actually necessary for this sheet

-- The key lemma (proved in mathlib already):
-- An element of K is integral over a subring R iff the subring ℤ[a] of K is finitely-generated
-- as a ℤ-module (i.e. as an abelian group)
lemma lemma1 (R : Type) [comm_ring R] [algebra R K] (a : K) :
  is_integral R a ↔ (algebra.adjoin R ({a} : set K)).to_submodule.fg :=
begin
  split,
  -- Both directions are delicate to do in Lean, but there already
  { exact fg_adjoin_singleton_of_integral a, },
  { intro h,
    exact is_integral_of_mem_of_fg _ h _ (algebra.self_mem_adjoin_singleton R a),
  },
end

-- One can use this lemma to prove that if `a` and `b` are integral then `R[a]` is finitely-generated
-- as an R-module, and `R[a][b]` is finitely-generated as an R[a]-module, so finitely-generated
-- as an `R`-module. If furthermore `R` is Noetherian (for example `R=ℤ` then the subalgebras `R[a+b]` and `R[ab]`
-- are finitely-generated as `R`-modules, so by the lemma applied the other way we deduce
-- that these elements are integral. This is still a hard exercise (despite the lemma)
-- because you have to move between `R` and `R[a]`.

example (a b : K) (ha : is_integral ℤ a) (hb : is_integral ℤ b) : is_integral ℤ (a + b) :=
begin
  rw lemma1 at ha ⊢,
  have hb' : is_integral (algebra.adjoin ℤ ({a} : set K)) b,
  { apply is_integral_of_is_scalar_tower hb,
    { exact algebra_int ↥(algebra.adjoin ℤ {a}), },
    { exact is_scalar_tower.subalgebra' ℤ K K (algebra.adjoin ℤ {a}), }, },
  rw lemma1 at hb',
  have foo : ((algebra.adjoin ℤ ({a, b} : set K))) =
    (algebra.adjoin ↥(algebra.adjoin ℤ ({a} : set K)) ({b} : set K)).restrict_scalars ℤ,
  { apply le_antisymm,
    { rw [algebra.adjoin_le_iff, subalgebra.coe_restrict_scalars],
      rintro x (rfl | hxb),
      { simp only [set_like.mem_coe],
        -- `mem_adjoin_of_mem` is missing??
        sorry },
      { cases hxb,
        simp,
        -- `mem_adjoin_of_mem_base` or whatever?
        sorry }, },
    { sorry, -- API is missing?
    }, },
  -- this is pretty messy actually :-/
  sorry,
end


variable (α : Type) (p q : α → Prop)

example : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) := by
  constructor
  . intro h
    constructor
    . intro y
      match h y with
      | ⟨hp, _⟩ => assumption
    . intro y
      match h y with
      | ⟨_, hq⟩ => assumption
  . intro h
    intro y
    match h with
    | ⟨hp, hq⟩ => exact ⟨hp y, hq y⟩

example : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) := by
  intro hapq
  intro hap
  intro z
  have hpq := hapq z
  have hp := hap z
  exact hpq hp

example : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x := by
  intro h
  intro y
  match h with
  | Or.inl hl => apply Or.inl; exact hl y
  | Or.inr hr => apply Or.inr; exact hr y


/- Exercise 2.4: Functional Programming — Metaprogramming -/

open expr
open tactic

/- Question 1: A term exploder -/

/- In this exercise, we develop a string format for the `expr` metatype. By default, there is no
`has_repr` instance to print a nice string. For example: -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)  -- result: `[external]`
#eval (`(λx : ℕ, x + x) : expr)  -- result: `[external]`

/- 1.1. Define a metafunction `expr.repr` that converts an `expr` into a `string`. It is acceptable
to leave out some fields from the `expr` constructors, such as the level `l` of a sort, the binder
information `bi` of a λ- or Π- binder, and the arguments of the `macro` constructor.

Hint: Use `name.to_string` to convert a name to a string, and `repr` for other types that belong to
the `has_repr` type class. -/

-- enter your definition here

/- 1.2. Register `expr.repr` in the `has_repr` type class, so that we can use `repr` without
qualification in the future, and so that it is available to `#eval`.

Hint: You will need the `meta` keyword in front of the command you enter. -/

-- enter your command here

/- 1.3. Test your setup. -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)
#eval (`(λx : ℕ, x + x) : expr)

/- 1.4. Compare your answer with `expr.to_raw_fmt`. -/

/- Question 2: `destruct_and` on steroids -/

/- Recall from the lecture that `destruct_and` fails on the following easy goal: -/

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ d := sorry

/- We will now address this by developing a new tactic called `destro_and`, which applies both
*des*truction and in*tro*duction rules for conjunction. It will also go automatically through the
hypotheses instead of taking an argument. We will develop it in three steps. -/

/- 2.1. Develop a tactic `intro_ands` that replaces all goals of the form `a ∧ b` with two new goals
`a` and `b` systematically, until all top-level conjunctions are gone.

For this, we can use tactics such as `repeat` (which repeatedly applies a tactic on all goals until
the tactic fails on each of the goal) and `applyc` (which can be used to apply a rule, in connection
with backtick quoting). -/

meta def intro_ands : tactic unit :=
sorry

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ d :=
begin
  intro_ands,
  /- The proof state should be as follows:

  2 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ d -/
  repeat { sorry }
end

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ (a ∧ (c ∧ b)) :=
begin
  intro_ands,
  /- The proof state should be as follows:

  4 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ a

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ c

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b -/
  repeat { sorry }
end

/- 2.2. Develop a tactic `destruct_ands` that replaces hypotheses of the form `h : a ∧ b` by two new
hypotheses `h_left : a` and `h_right : b` systematically, until all top-level conjunctions are gone.

Here is imperative-style pseudocode that you can follow:

1. Retrieve the list of hypotheses from the context. This is provided by the metaconstant
`local_context`.

2. Find the first hypothesis (= term) with a type (= proposition) of the form `_ ∧ _`. Here, you can
use the `list.mfirst` function, in conjunction with pattern matching. You can use `infer_type` to
query the type of a term.

3. Perform a case split on the first found hypothesis. This can be achieved using the `cases`
metafunction.

4. Go to step 1.

The above procedure might fail if there exists no hypotheses of the required form. Make sure to
handle this failure gracefully using `<|>`. -/

meta def destruct_ands : tactic unit :=
sorry

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ d :=
begin
  destruct_ands,
  /- The proof state should be as follows:

  a b c d : Prop,
  h_left : a,
  h_right_right : d,
  h_right_left_left : b,
  h_right_left_right : c
  ⊢ b ∧ d -/
  sorry
end

/- 2.3. Finally, combine the two tactics developed above and the `assumption` tactic to implement
the desired `destro_and` tactic. -/

meta def destro_and : tactic unit :=
sorry

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ d := by destro_and
example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ (a ∧ (c ∧ b)) := by destro_and

/- Question 3: A theorem finder -/

/- We will implement a function that allows us to find theorems by constants appearing in their
statements. So given a list of constant names, the function will list all theorems in which all
these constants appear.

You can use the following metaconstants:

* `declaration`: contains all data (name, type, value) associated with a declaration,
  i.e. axiom, theorem, constant, etc.
* `tactic.get_env`: gives us access to the `environment`, a metatype thats lists all `declaration`s
  (especially all theorems)
* `environment.fold` allows us to walk through the environment and collect data
* `expr.fold` allows us to walk through an expression and collect data. -/

/- 3.1. Write a metafunction that checks whether an expression contains a specific constant.

You can use `expr.fold` to walk through the expression, `||` and `ff` for Booleans, and
`expr.is_constant_of` to check if an expression is a constant. -/

meta def term_contains (e : expr) (n : name) : bool :=
sorry

/- 3.2. Write a metafunction that checks whether an expression contains _all_ constants in a list.

You can use `list.band` (Boolean and). -/

meta def term_contains_all (ns : list name) (e : expr) : bool :=
sorry

/- 3.3. Produce the list of all theorems that contain all constants `ns` in their statement.

`environment.fold` allows you to walk over the list of declarations. With `declaration.type`, you
get the type of a theorem, and with `declaration.to_name` you get the name. -/

meta def list_constants (ns : list name) (e : environment) : list name :=
sorry

/- 3.4. Finally, develop a tactic that uses the above metafunctions to log all found theorems.

You can use `trace` to log the results. -/

meta def find_constants (ns : list name) : tactic unit :=
sorry

/- 3.5. Test your solution. -/

run_cmd find_constants []  -- lists all theorems
run_cmd find_constants [`list.map, `function.comp]


import .X
import .Idem
import group_theory.group_action
open X
namespace idem_action_X
def mul_action' (R : Type)[comm_ring R] : Idem(R) → X(R) → X(R) := λ g η,
begin
    exact {
        x := g.e * (η.x-η.y)  +  η .y,
        y := η.x + g.e * (η .y -η.x) ,
        inv := η.inv,
        certif :=
            begin
                have h : g.e * (η.x - η.y) + η.y - (η.x + g.e * (η.y - η.x)) = g.e * (η.x - η.y) - (1-g.e) * (η.x - η.y),
                  ring,
                rw h,
                rw ← Idem.Idem.calculus.square_idem,
                exact η.certif,
            end
    }
end
instance (R : Type)[comm_ring R] : has_scalar (Idem(R)) (X(R)) := ⟨mul_action' R⟩
variables (R :Type)[comm_ring R]
lemma mul_action_comp_x  (g : Idem R)  (η : X R): (g • η).x = g.e * (η.x-η.y)  +  η.y  :=  rfl
lemma mul_action_comp_y  (g : Idem R)  (η : X R): (g • η).y = η.x + g.e * (η .y -η.x)  :=  rfl
lemma mul_action_comp_inv  (g : Idem R)  (η : X R): (g • η).inv = η.inv   :=  rfl
--- Ecrire un revriter !
open Idem
open X
meta def idem_ring : tactic unit :=
`[simp only [one_e, mul_action_comp_x,mul_action_comp_y, e_comp], ring]

run_cmd add_interactive [`idem_ring]
def one_smul' (η : X R) : (1 : Idem R) •  η = η  := begin
    ext ; idem_ring,
end
def mul_smul' (g1 g2 : Idem R) (η : X(R)) : (g1 * g2) • η  = g1 • g2 • η :=
begin
    ext ; idem_ring,
end
instance (R : Type)[comm_ring R]: mul_action (Idem R) (X(R)) := ⟨ one_smul' R, mul_smul' R⟩
open mul_action
def A := orbit_rel (Idem (R)) (X(R))
#check (A(R)).r

end idem_action_X


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon

! This file was ported from Lean 3 source module data.qpf.multivariate.basic
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.PFunctor.Multivariate.Basic

/-!
# Multivariate quotients of polynomial functors.

Basic definition of multivariate QPF. QPFs form a compositional framework
for defining inductive and coinductive types, their quotients and nesting.

The idea is based on building ever larger functors. For instance, we can define
a list using a shape functor:

```lean
inductive ListShape (a b : Type)
| nil : ListShape
| cons : a -> b -> ListShape
```

This shape can itself be decomposed as a sum of product which are themselves
QPFs. It follows that the shape is a QPF and we can take its fixed point
and create the list itself:

```lean
def List (a : Type) := fix ListShape a -- not the actual notation
```

We can continue and define the quotient on permutation of lists and create
the multiset type:

```lean
def Multiset (a : Type) := QPF.quot List.perm List a -- not the actual notion
```

And `Multiset` is also a QPF. We can then create a novel data type (for Lean):

```lean
inductive Tree (a : Type)
| node : a -> Multiset Tree -> Tree
```

An unordered tree. This is currently not supported by Lean because it nests
an inductive type inside of a quotient. We can go further and define
unordered, possibly infinite trees:

```lean
coinductive Tree' (a : Type)
| node : a -> Multiset Tree' -> Tree'
```

by using the `cofix` construct. Those options can all be mixed and
matched because they preserve the properties of QPF. The latter example,
`Tree'`, combines fixed point, co-fixed point and quotients.

## Related modules

 * constructions
   * Fix
   * Cofix
   * Quot
   * Comp
   * Sigma / Pi
   * Prj
   * Const

each proves that some operations on functors preserves the QPF structure

## Reference

! * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u

open MvFunctor

/-- Multivariate quotients of polynomial functors.
-/
class MvQPF {n : ℕ} (F : TypeVec.{u} n → Type _) [MvFunctor F] where
  P : MvPFunctor.{u} n
  abs : ∀ {α}, P.Obj α → F α
  repr : ∀ {α}, F α → P.Obj α
  abs_repr : ∀ {α} (x : F α), abs (repr x) = x
  abs_map : ∀ {α β} (f : α ⟹ β) (p : P.Obj α), abs (f <$$> p) = f <$$> abs p
#align mvqpf MvQPF

namespace MvQPF

variable {n : ℕ} {F : TypeVec.{u} n → Type _} [MvFunctor F] [q : MvQPF F]

open MvFunctor (LiftP LiftR)

/-!
### Show that every MvQPF is a lawful MvFunctor.
-/

protected theorem id_map {α : TypeVec n} (x : F α) : TypeVec.id <$$> x = x := by
  rw [← abs_repr x]
  cases' repr x with a f
  rw [← abs_map]
  rfl
#align mvqpf.id_map MvQPF.id_map

@[simp]
theorem comp_map {α β γ : TypeVec n} (f : α ⟹ β) (g : β ⟹ γ) (x : F α) :
    (g ⊚ f) <$$> x = g <$$> f <$$> x := by
  rw [← abs_repr x]
  cases' repr x with a f
  rw [← abs_map, ← abs_map, ← abs_map]
  rfl
#align mvqpf.comp_map MvQPF.comp_map

instance (priority := 100) lawfulMvFunctor : LawfulMvFunctor F where
  id_map := @MvQPF.id_map n F _ _
  comp_map := @comp_map n F _ _
#align mvqpf.is_lawful_mvfunctor MvQPF.lawfulMvFunctor

-- Lifting predicates and relations
theorem liftP_iff {α : TypeVec n} (p : ∀ ⦃i⦄, α i → Prop) (x : F α) :
    LiftP p x ↔ ∃ a f, x = abs ⟨a, f⟩ ∧ ∀ i j, p (f i j) := by
  constructor
  · rintro ⟨y, hy⟩
    cases' h : repr y with a f
    use a, fun i j => (f i j).val
    constructor
    · rw [← hy, ← abs_repr y, h, ← abs_map]; rfl
    intro i j
    apply (f i j).property
  rintro ⟨a, f, h₀, h₁⟩; dsimp at *
  use abs ⟨a, fun i j => ⟨f i j, h₁ i j⟩⟩
  rw [← abs_map, h₀]; rfl
#align mvqpf.liftp_iff MvQPF.liftP_iff

theorem liftR_iff {α : TypeVec n} (r : ∀ /- ⦃i⦄ -/ {i}, α i → α i → Prop) (x y : F α) :
    LiftR r x y ↔ ∃ a f₀ f₁, x = abs ⟨a, f₀⟩ ∧ y = abs ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) := by
  constructor
  · rintro ⟨u, xeq, yeq⟩
    cases' h : repr u with a f
    use a, fun i j => (f i j).val.fst, fun i j => (f i j).val.snd
    constructor
    · rw [← xeq, ← abs_repr u, h, ← abs_map]; rfl
    constructor
    · rw [← yeq, ← abs_repr u, h, ← abs_map]; rfl
    intro i j
    exact (f i j).property
  rintro ⟨a, f₀, f₁, xeq, yeq, h⟩
  use abs ⟨a, fun i j => ⟨(f₀ i j, f₁ i j), h i j⟩⟩
  dsimp; constructor
  · rw [xeq, ← abs_map]; rfl
  rw [yeq, ← abs_map]; rfl
#align mvqpf.liftr_iff MvQPF.liftR_iff

open Set

open MvFunctor (LiftP LiftR)

theorem mem_supp {α : TypeVec n} (x : F α) (i) (u : α i) :
    u ∈ supp x i ↔ ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ := by
  rw [supp]; dsimp; constructor
  · intro h a f haf
    have : LiftP (fun i u => u ∈ f i '' univ) x := by
      rw [liftP_iff]
      refine' ⟨a, f, haf.symm, _⟩
      intro i u
      exact mem_image_of_mem _ (mem_univ _)
    exact h this
  intro h p; rw [liftP_iff]
  rintro ⟨a, f, xeq, h'⟩
  rcases h a f xeq.symm with ⟨i, _, hi⟩
  rw [← hi]; apply h'
#align mvqpf.mem_supp MvQPF.mem_supp

theorem supp_eq {α : TypeVec n} {i} (x : F α) :
    supp x i = { u | ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ } := by ext ; apply mem_supp
#align mvqpf.supp_eq MvQPF.supp_eq

theorem has_good_supp_iff {α : TypeVec n} (x : F α) :
    (∀ p, LiftP p x ↔ ∀ (i), ∀ u ∈ supp x i, p i u) ↔
      ∃ a f, abs ⟨a, f⟩ = x ∧ ∀ i a' f', abs ⟨a', f'⟩ = x → f i '' univ ⊆ f' i '' univ := by
  constructor
  · intro h
    have : LiftP (supp x) x := by rw [h]; introv; exact id
    rw [liftP_iff] at this
    rcases this with ⟨a, f, xeq, h'⟩
    refine' ⟨a, f, xeq.symm, _⟩
    intro a' f' h''
    rintro hu u ⟨j, _h₂, hfi⟩
    have hh : u ∈ supp x a' := by rw [← hfi] ; apply h'
    refine' (mem_supp x _ u).mp hh _ _ hu
  rintro ⟨a, f, xeq, h⟩ p; rw [liftP_iff]; constructor
  · rintro ⟨a', f', xeq', h'⟩ i u usuppx
    rcases(mem_supp x _ u).mp (@usuppx) a' f' xeq'.symm with ⟨i, _, f'ieq⟩
    rw [← f'ieq]
    apply h'
  intro h'
  refine' ⟨a, f, xeq.symm, _⟩; intro j y
  apply h'; rw [mem_supp]
  intro a' f' xeq'
  apply h _ a' f' xeq'
  apply mem_image_of_mem _ (mem_univ _)
#align mvqpf.has_good_supp_iff MvQPF.has_good_supp_iff

/-- A qpf is said to be uniform if every polynomial functor
representing a single value all have the same range. -/
def IsUniform : Prop :=
  ∀ ⦃α : TypeVec n⦄ (a a' : q.P.A) (f : q.P.B a ⟹ α) (f' : q.P.B a' ⟹ α),
    abs ⟨a, f⟩ = abs ⟨a', f'⟩ → ∀ i, f i '' univ = f' i '' univ
#align mvqpf.is_uniform MvQPF.IsUniform

/-- does `abs` preserve `liftp`? -/
def LiftPPreservation : Prop :=
  ∀ ⦃α : TypeVec n⦄ (p : ∀ ⦃i⦄, α i → Prop) (x : q.P.Obj α), LiftP p (abs x) ↔ LiftP p x
#align mvqpf.liftp_preservation MvQPF.LiftPPreservation

/-- does `abs` preserve `supp`? -/
def SuppPreservation : Prop :=
  ∀ ⦃α⦄ (x : q.P.Obj α), supp (abs x) = supp x
#align mvqpf.supp_preservation MvQPF.SuppPreservation

theorem supp_eq_of_isUniform (h : q.IsUniform) {α : TypeVec n} (a : q.P.A) (f : q.P.B a ⟹ α) :
    ∀ i, supp (abs ⟨a, f⟩) i = f i '' univ := by
  intro ; ext u; rw [mem_supp]; constructor
  · intro h'
    apply h' _ _ rfl
  intro h' a' f' e
  rw [← h _ _ _ _ e.symm]; apply h'
#align mvqpf.supp_eq_of_is_uniform MvQPF.supp_eq_of_isUniform

theorem liftP_iff_of_isUniform (h : q.IsUniform) {α : TypeVec n} (x : F α) (p : ∀ i, α i → Prop) :
    LiftP p x ↔ ∀ (i), ∀ u ∈ supp x i, p i u := by
  rw [liftP_iff, ← abs_repr x]
  cases' repr x with a f; constructor
  · rintro ⟨a', f', abseq, hf⟩ u
    rw [supp_eq_of_isUniform h, h _ _ _ _ abseq]
    rintro b ⟨i, _, hi⟩
    rw [← hi]
    apply hf
  intro h'
  refine' ⟨a, f, rfl, fun _ i => h' _ _ _⟩
  rw [supp_eq_of_isUniform h]
  exact ⟨i, mem_univ i, rfl⟩
#align mvqpf.liftp_iff_of_is_uniform MvQPF.liftP_iff_of_isUniform

theorem suppPreservation_iff_isUniform : q.SuppPreservation ↔ q.IsUniform := by
  constructor
  · intro h α a a' f f' h' i
    rw [← MvPFunctor.supp_eq, ← MvPFunctor.supp_eq, ← h, h', h]
  · rintro h α ⟨a, f⟩
    ext
    rwa [supp_eq_of_isUniform, MvPFunctor.supp_eq]
#align mvqpf.supp_preservation_iff_uniform MvQPF.suppPreservation_iff_isUniform

theorem suppPreservation_iff_liftpPreservation : q.SuppPreservation ↔ q.LiftPPreservation := by
  constructor <;> intro h
  · rintro α p ⟨a, f⟩
    have h' := h
    rw [suppPreservation_iff_isUniform] at h'
    dsimp only [SuppPreservation, supp] at h
    simp only [liftP_iff_of_isUniform, supp_eq_of_isUniform, MvPFunctor.liftP_iff', h',
      image_univ, mem_range, exists_imp]
    constructor <;> intros <;> subst_vars <;> solve_by_elim
  · rintro α ⟨a, f⟩
    simp only [LiftPPreservation] at h
    ext
    simp only [supp, h, mem_setOf_eq]
#align mvqpf.supp_preservation_iff_liftp_preservation MvQPF.suppPreservation_iff_liftpPreservation

theorem liftpPreservation_iff_uniform : q.LiftPPreservation ↔ q.IsUniform := by
  rw [← suppPreservation_iff_liftpPreservation, suppPreservation_iff_isUniform]
#align mvqpf.liftp_preservation_iff_uniform MvQPF.liftpPreservation_iff_uniform

end MvQPF


lemma and_or_distrib_left (P Q R : Prop) : P ∧ (Q ∨ R) ↔ (P ∧ Q) ∨ (P ∧ R) :=
begin
split,
intro h1,
cases h1,
cases h1_right,
left,
split,
exact h1_left,
exact h1_right,
right,
split,
exact h1_left,
exact h1_right,
intro h,
split,
repeat {cases h, repeat {cc}},
end


import algebra.order.field.canonical.defs algebra.big_operators.intervals algebra.periodic

/-! # IMO 2010 A3 -/

namespace IMOSL
namespace IMO2010A3

open finset function

variables {F : Type*} [canonically_linear_ordered_semifield F]

section extra_lemmas

private lemma AM_GM (a b : F) : 2 * a * b ≤ a ^ 2 + b ^ 2 :=
begin
  rw le_iff_exists_add,
  cases le_total a b with h h; rw le_iff_exists_add at h;
    rcases h with ⟨c, rfl⟩; use c ^ 2,
  rw [add_sq, ← add_assoc, ← add_assoc, ← two_mul, sq, ← mul_assoc, ← mul_add],
  rw [add_sq, add_right_comm, add_right_comm _ _ (b ^ 2),
      ← two_mul, sq, ← mul_assoc, ← mul_add, mul_right_comm]
end

private lemma special_ineq {w x y z c : F} (h : w + x + y ≤ c) (h0 : x + y + z ≤ c) :
  w * y + x * z ≤ (c / 2) ^ 2 :=
begin
  rw [← add_le_add_iff_right (x * (x + y)), add_assoc, ← mul_add, add_comm z],
  refine le_trans (add_le_add_left (mul_le_mul_left' h0 _) _) _; clear h0 z,
  rw [add_comm, ← add_le_add_iff_right ((x + y) * y), add_assoc, ← add_mul, ← add_assoc],
  refine le_trans (add_le_add_left (mul_le_mul_right' h _) _) _; clear h w,
  rw [mul_comm, ← mul_add, add_assoc, mul_comm x, ← mul_add, ← sq],
  nth_rewrite 0 ← mul_div_cancel' c two_ne_zero,
  exact AM_GM (c / 2) (x + y)
end

end extra_lemmas

/-- Final solution -/
theorem final_solution (n : ℕ) (c : F) :
  is_greatest ((λ x : ℕ → F, (range (2 * n)).sum (λ i, x i * x (i + 2))) ''
    {x | (∀ j : ℕ, x j + x (j + 1) + x (j + 2) ≤ c) ∧ periodic x (2 * n)})
      (n • (c / 2) ^ 2) :=
begin
  refine ⟨⟨λ i, ite (even i) (c / 2) 0, ⟨λ i, _, λ i, if_congr _ rfl rfl⟩, _⟩, _⟩,

  ---- The choice of `x` is good
  { dsimp only []; by_cases h : even i,
    rw [if_pos h, if_neg, add_zero, if_pos, add_halves],
    rwa [nat.even_add_one, nat.even_add_one, not_not],
    rwa [nat.even_add_one, not_not],
    rw [if_neg h, zero_add, if_pos, if_neg, add_zero],
    exact half_le_self (zero_le c),
    rwa [nat.even_add_one, nat.even_add_one, not_not],
    rwa nat.even_add_one },

  ---- The choice of `x` is `2n`-periodic
  rw [nat.even_add, iff_true_intro (even.mul_right even_two n), iff_true],

  ---- The choice of `x` gives the lower bound `n (c/2)^2`
  { dsimp only []; induction n with n h,
    rw [zero_smul, mul_zero, sum_range_zero],
    rw [nat.mul_succ, sum_range_succ, sum_range_succ, h, succ_nsmul', add_assoc, add_right_inj],
    replace h : even (2 * n) := even_two.mul_right n,
    rw [if_pos h, if_pos, if_neg, zero_mul, add_zero, ← sq],
    rwa [nat.even_add_one, not_not],
    rwa [nat.even_add_one, nat.even_add_one, not_not] },

  ---- The upper bound is indeed `n (c/2)^2`
  { rw mem_upper_bounds; intros s h,
    rw set.mem_image at h; rcases h with ⟨x, ⟨h, -⟩, rfl⟩,
    induction n with n h0,
    rw [zero_smul, mul_zero, sum_range_zero],
    rw [nat.mul_succ, sum_range_succ, sum_range_succ, add_assoc, succ_nsmul'],
    exact add_le_add h0 (special_ineq (h $ 2 * n) (h $ 2 * n + 1)) }
end

end IMO2010A3
end IMOSL


-- import data.real.basic
-- import data.real.sqrt

-- open real
-- lemma limit :
-- ∀ (ε : ℝ) (hε : 0 < ε), ∃ (δ : ℝ) (hδ : 0 < δ), ∀ x : ℝ, 0 < |x - 5| ∧ |x - 5| < δ → |(3 * x ^ 2 - 1) - 74| < ε :=
-- begin
--   intros,
--   let ε' := min ε 72,
--   use min (5 - sqrt (25 - ε' / 3)) (-5 + sqrt (25 + ε' / 3)),
--   simp only [ε'],
--   split,
--   sorry,
--   -- simp only [ε'],
--   -- simp,
--   -- split,
--   -- rw sqrt_lt_of
--   intros x hx,
--   rw sub_sub,
--   norm_num,
--   rw abs_lt at *,
--   rcases hx with ⟨hx₁, hx₃, hx₄⟩,
--   simp [-neg_lt_sub_iff_lt_add, neg_lt, abs_pos, add_sub_cancel'_right, lt_min_iff, ne.def, lt_neg_add_iff_add_lt] at *,
--   cases hx₃,
--   cases hx₄,
--   simp at *,
--   split,
--   sorry,
--   nlinarith,
--   sorry,
--   sorry,
-- end


/-
Copyright (c) 2020 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Heather Macbeth
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.intervals.basic
import Mathlib.data.set.function
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Monotone surjective functions are surjective on intervals

A monotone surjective function sends any interval in the domain onto the interval with corresponding
endpoints in the range.  This is expressed in this file using `set.surj_on`, and provided for all
permutations of interval endpoints.
-/

theorem surj_on_Ioo_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) (a : α) (b : α) : set.surj_on f (set.Ioo a b) (set.Ioo (f a) (f b)) := sorry

theorem surj_on_Ico_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) (a : α) (b : α) : set.surj_on f (set.Ico a b) (set.Ico (f a) (f b)) := sorry

theorem surj_on_Ioc_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) (a : α) (b : α) : set.surj_on f (set.Ioc a b) (set.Ioc (f a) (f b)) := sorry

-- to see that the hypothesis `a ≤ b` is necessary, consider a constant function

theorem surj_on_Icc_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) {a : α} {b : α} (hab : a ≤ b) : set.surj_on f (set.Icc a b) (set.Icc (f a) (f b)) := sorry

theorem surj_on_Ioi_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) (a : α) : set.surj_on f (set.Ioi a) (set.Ioi (f a)) := sorry

theorem surj_on_Iio_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) (a : α) : set.surj_on f (set.Iio a) (set.Iio (f a)) :=
  surj_on_Ioi_of_monotone_surjective (monotone.order_dual h_mono) h_surj a

theorem surj_on_Ici_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) (a : α) : set.surj_on f (set.Ici a) (set.Ici (f a)) := sorry

theorem surj_on_Iic_of_monotone_surjective {α : Type u_1} {β : Type u_2} [linear_order α] [partial_order β] {f : α → β} (h_mono : monotone f) (h_surj : function.surjective f) (a : α) : set.surj_on f (set.Iic a) (set.Iic (f a)) :=
  surj_on_Ici_of_monotone_surjective (monotone.order_dual h_mono) h_surj a


import data.polynomial
import data.real.basic

noncomputable theory
open_locale big_operators

def binom_l (a : ℝ) : polynomial ℝ := polynomial.X - polynomial.C a

def lagrange_interpolant_v2 (n : ℕ) (i : ℕ) (xData : ℕ → ℝ): polynomial ℝ :=
    ∏ j in ( finset.range (n+1) \ {i} ),
    ((1 : ℝ)/(xData i - xData j)) • (binom_l (xData j))

def myX : ℕ → ℝ
| 0 := (1 : ℝ)
| 1 := (2 : ℝ)
| (n+2) := 5

@[simp] lemma myX_0 : myX 0 = (1:ℝ) := rfl
@[simp] lemma myX_1 : myX 1 = (2:ℝ) := rfl
@[simp] lemma myX_all (n : ℕ): myX (nat.succ (nat.succ n)) = (5:ℝ) := rfl
@[simp] lemma myX_n (n : ℕ) (hn : 1 < n) : myX n = (5:ℝ) :=
begin
    -- should I use rec_on or something else instead of induction?
    induction n with d hd,
    { -- base case
        exfalso, linarith,
    },
    { -- induction step, how to best prove this?
        have h1 : 0 < d,
            rw nat.succ_eq_add_one at hn,
            linarith,
        have h2 : ∃ m : ℕ, d = m.succ,
        use d - 1, rw nat.succ_eq_add_one, omega, -- a little ℕ subtraction problem, thx `omega`!
        cases h2 with m hm,
        rw hm,
        exact myX_all m,
    },
    done
end
example (n : ℕ) : n - n = 0 := nat.sub_self n

-- The first interpolant (i=0) evaluated at the first point (x 0 = 1.0):
example : polynomial.eval (1 : ℝ) (lagrange_interpolant_v2 1 0 myX) = (1 : ℝ) :=
begin
    unfold lagrange_interpolant_v2,
    unfold finset.prod,
    simp * at *,
    --rw polynomial.eval_smul (binom_l _) (1:ℝ),
    sorry,
end

#check polynomial.eval_smul (binom_l (1:ℝ)) (1:ℝ)