/-
Copyright (c) 2021 Apurva Nakade. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Apurva Nakade

! This file was ported from Lean 3 source module set_theory.surreal.dyadic
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Algebra.Basic
import Mathbin.SetTheory.Game.Birthday
import Mathbin.SetTheory.Surreal.Basic
import Mathbin.RingTheory.Localization.Basic

/-!
# Dyadic numbers
Dyadic numbers are obtained by localizing ℤ away from 2. They are the initial object in the category
of rings with no 2-torsion.

## Dyadic surreal numbers
We construct dyadic surreal numbers using the canonical map from ℤ[2 ^ {-1}] to surreals.
As we currently do not have a ring structure on `surreal` we construct this map explicitly. Once we
have the ring structure, this map can be constructed directly by sending `2 ^ {-1}` to `half`.

## Embeddings
The above construction gives us an abelian group embedding of ℤ into `surreal`. The goal is to
extend this to an embedding of dyadic rationals into `surreal` and use Cauchy sequences of dyadic
rational numbers to construct an ordered field embedding of ℝ into `surreal`.
-/

universe u

-- mathport name: pgame.equiv
local infixl:0 " ≈ " => Pgame.Equiv

namespace Pgame

/-- For a natural number `n`, the pre-game `pow_half (n + 1)` is recursively defined as
`{0 | pow_half n}`. These are the explicit expressions of powers of `1 / 2`. By definition, we have
`pow_half 0 = 1` and `pow_half 1 ≈ 1 / 2` and we prove later on that
`pow_half (n + 1) + pow_half (n + 1) ≈ pow_half n`. -/
def powHalf : ℕ → Pgame
  | 0 => 1
  | n + 1 => ⟨PUnit, PUnit, 0, fun _ => pow_half n⟩
#align pgame.pow_half Pgame.powHalf

@[simp]
theorem powHalf_zero : powHalf 0 = 1 :=
  rfl
#align pgame.pow_half_zero Pgame.powHalf_zero

theorem powHalf_leftMoves (n) : (powHalf n).LeftMoves = PUnit := by cases n <;> rfl
#align pgame.pow_half_left_moves Pgame.powHalf_leftMoves

theorem powHalf_zero_rightMoves : (powHalf 0).RightMoves = PEmpty :=
  rfl
#align pgame.pow_half_zero_right_moves Pgame.powHalf_zero_rightMoves

theorem powHalf_succ_rightMoves (n) : (powHalf (n + 1)).RightMoves = PUnit :=
  rfl
#align pgame.pow_half_succ_right_moves Pgame.powHalf_succ_rightMoves

@[simp]
theorem powHalf_moveLeft (n i) : (powHalf n).moveLeft i = 0 := by cases n <;> cases i <;> rfl
#align pgame.pow_half_move_left Pgame.powHalf_moveLeft

@[simp]
theorem powHalf_succ_moveRight (n i) : (powHalf (n + 1)).moveRight i = powHalf n :=
  rfl
#align pgame.pow_half_succ_move_right Pgame.powHalf_succ_moveRight

instance uniquePowHalfLeftMoves (n) : Unique (powHalf n).LeftMoves := by
  cases n <;> exact PUnit.unique
#align pgame.unique_pow_half_left_moves Pgame.uniquePowHalfLeftMoves

instance isEmpty_powHalf_zero_rightMoves : IsEmpty (powHalf 0).RightMoves :=
  PEmpty.isEmpty
#align pgame.is_empty_pow_half_zero_right_moves Pgame.isEmpty_powHalf_zero_rightMoves

instance uniquePowHalfSuccRightMoves (n) : Unique (powHalf (n + 1)).RightMoves :=
  PUnit.unique
#align pgame.unique_pow_half_succ_right_moves Pgame.uniquePowHalfSuccRightMoves

@[simp]
theorem birthday_half : birthday (powHalf 1) = 2 :=
  by
  rw [birthday_def]
  dsimp
  simpa using Order.le_succ (1 : Ordinal)
#align pgame.birthday_half Pgame.birthday_half

/-- For all natural numbers `n`, the pre-games `pow_half n` are numeric. -/
theorem numeric_powHalf (n) : (powHalf n).Numeric :=
  by
  induction' n with n hn
  · exact numeric_one
  · constructor
    · simpa using hn.move_left_lt default
    · exact ⟨fun _ => numeric_zero, fun _ => hn⟩
#align pgame.numeric_pow_half Pgame.numeric_powHalf

theorem powHalf_succ_lt_powHalf (n : ℕ) : powHalf (n + 1) < powHalf n :=
  (numeric_powHalf (n + 1)).lt_moveRight default
#align pgame.pow_half_succ_lt_pow_half Pgame.powHalf_succ_lt_powHalf

theorem powHalf_succ_le_powHalf (n : ℕ) : powHalf (n + 1) ≤ powHalf n :=
  (powHalf_succ_lt_powHalf n).le
#align pgame.pow_half_succ_le_pow_half Pgame.powHalf_succ_le_powHalf

theorem powHalf_le_one (n : ℕ) : powHalf n ≤ 1 :=
  by
  induction' n with n hn
  · exact le_rfl
  · exact (pow_half_succ_le_pow_half n).trans hn
#align pgame.pow_half_le_one Pgame.powHalf_le_one

theorem powHalf_succ_lt_one (n : ℕ) : powHalf (n + 1) < 1 :=
  (powHalf_succ_lt_powHalf n).trans_le <| powHalf_le_one n
#align pgame.pow_half_succ_lt_one Pgame.powHalf_succ_lt_one

theorem powHalf_pos (n : ℕ) : 0 < powHalf n :=
  by
  rw [← lf_iff_lt numeric_zero (numeric_pow_half n), zero_lf_le]
  simp
#align pgame.pow_half_pos Pgame.powHalf_pos

theorem zero_le_powHalf (n : ℕ) : 0 ≤ powHalf n :=
  (powHalf_pos n).le
#align pgame.zero_le_pow_half Pgame.zero_le_powHalf

theorem add_powHalf_succ_self_eq_powHalf (n) : powHalf (n + 1) + powHalf (n + 1) ≈ powHalf n :=
  by
  induction' n using Nat.strong_induction_on with n hn
  · constructor <;> rw [le_iff_forall_lf] <;> constructor
    · rintro (⟨⟨⟩⟩ | ⟨⟨⟩⟩) <;> apply lf_of_lt
      ·
        calc
          0 + pow_half n.succ ≈ pow_half n.succ := zero_add_equiv _
          _ < pow_half n := pow_half_succ_lt_pow_half n

      ·
        calc
          pow_half n.succ + 0 ≈ pow_half n.succ := add_zero_equiv _
          _ < pow_half n := pow_half_succ_lt_pow_half n

    · cases n
      · rintro ⟨⟩
      rintro ⟨⟩
      apply lf_of_move_right_le
      swap
      exact Sum.inl default
      calc
        pow_half n.succ + pow_half (n.succ + 1) ≤ pow_half n.succ + pow_half n.succ :=
          add_le_add_left (pow_half_succ_le_pow_half _) _
        _ ≈ pow_half n := hn _ (Nat.lt_succ_self n)

    · simp only [pow_half_move_left, forall_const]
      apply lf_of_lt
      calc
        0 ≈ 0 + 0 := (add_zero_equiv 0).symm
        _ ≤ pow_half n.succ + 0 := (add_le_add_right (zero_le_pow_half _) _)
        _ < pow_half n.succ + pow_half n.succ := add_lt_add_left (pow_half_pos _) _

    · rintro (⟨⟨⟩⟩ | ⟨⟨⟩⟩) <;> apply lf_of_lt
      ·
        calc
          pow_half n ≈ pow_half n + 0 := (add_zero_equiv _).symm
          _ < pow_half n + pow_half n.succ := add_lt_add_left (pow_half_pos _) _

      ·
        calc
          pow_half n ≈ 0 + pow_half n := (zero_add_equiv _).symm
          _ < pow_half n.succ + pow_half n := add_lt_add_right (pow_half_pos _) _

#align pgame.add_pow_half_succ_self_eq_pow_half Pgame.add_powHalf_succ_self_eq_powHalf

theorem half_add_half_equiv_one : powHalf 1 + powHalf 1 ≈ 1 :=
  add_powHalf_succ_self_eq_powHalf 0
#align pgame.half_add_half_equiv_one Pgame.half_add_half_equiv_one

end Pgame

namespace Surreal

open Pgame

/-- Powers of the surreal number `half`. -/
def powHalf (n : ℕ) : Surreal :=
  ⟦⟨Pgame.powHalf n, Pgame.numeric_powHalf n⟩⟧
#align surreal.pow_half Surreal.powHalf

@[simp]
theorem powHalf_zero : powHalf 0 = 1 :=
  rfl
#align surreal.pow_half_zero Surreal.powHalf_zero

@[simp]
theorem double_powHalf_succ_eq_powHalf (n : ℕ) : 2 • powHalf n.succ = powHalf n :=
  by
  rw [two_nsmul]
  exact Quotient.sound (Pgame.add_powHalf_succ_self_eq_powHalf n)
#align surreal.double_pow_half_succ_eq_pow_half Surreal.double_powHalf_succ_eq_powHalf

@[simp]
theorem nsmul_pow_two_powHalf (n : ℕ) : 2 ^ n • powHalf n = 1 :=
  by
  induction' n with n hn
  · simp only [nsmul_one, pow_half_zero, Nat.cast_one, pow_zero]
  ·
    rw [← hn, ← double_pow_half_succ_eq_pow_half n, smul_smul (2 ^ n) 2 (pow_half n.succ), mul_comm,
      pow_succ]
#align surreal.nsmul_pow_two_pow_half Surreal.nsmul_pow_two_powHalf

@[simp]
theorem nsmul_pow_two_pow_half' (n k : ℕ) : 2 ^ n • powHalf (n + k) = powHalf k :=
  by
  induction' k with k hk
  ·
    simp only [add_zero, Surreal.nsmul_pow_two_powHalf, Nat.zero_eq, eq_self_iff_true,
      Surreal.powHalf_zero]
  · rw [← double_pow_half_succ_eq_pow_half (n + k), ← double_pow_half_succ_eq_pow_half k,
      smul_algebra_smul_comm] at hk
    rwa [← zsmul_eq_zsmul_iff' two_ne_zero]
#align surreal.nsmul_pow_two_pow_half' Surreal.nsmul_pow_two_pow_half'

theorem zsmul_pow_two_powHalf (m : ℤ) (n k : ℕ) : (m * 2 ^ n) • powHalf (n + k) = m • powHalf k :=
  by
  rw [mul_zsmul]
  congr
  norm_cast
  exact nsmul_pow_two_pow_half' n k
#align surreal.zsmul_pow_two_pow_half Surreal.zsmul_pow_two_powHalf

theorem dyadic_aux {m₁ m₂ : ℤ} {y₁ y₂ : ℕ} (h₂ : m₁ * 2 ^ y₁ = m₂ * 2 ^ y₂) :
    m₁ • powHalf y₂ = m₂ • powHalf y₁ := by
  revert m₁ m₂
  wlog h : y₁ ≤ y₂
  · intro m₁ m₂ aux
    exact (this (le_of_not_le h) aux.symm).symm
  intro m₁ m₂ h₂
  obtain ⟨c, rfl⟩ := le_iff_exists_add.mp h
  rw [add_comm, pow_add, ← mul_assoc, mul_eq_mul_right_iff] at h₂
  cases h₂
  · rw [h₂, add_comm, zsmul_pow_two_pow_half m₂ c y₁]
  · have := Nat.one_le_pow y₁ 2 Nat.succ_pos'
    norm_cast  at h₂
    linarith
#align surreal.dyadic_aux Surreal.dyadic_aux

/-- The additive monoid morphism `dyadic_map` sends ⟦⟨m, 2^n⟩⟧ to m • half ^ n. -/
def dyadicMap : Localization.Away (2 : ℤ) →+ Surreal
    where
  toFun x :=
    (Localization.liftOn x fun x y => x • powHalf (Submonoid.log y)) <|
      by
      intro m₁ m₂ n₁ n₂ h₁
      obtain ⟨⟨n₃, y₃, hn₃⟩, h₂⟩ := localization.r_iff_exists.mp h₁
      simp only [Subtype.coe_mk, mul_eq_mul_left_iff] at h₂
      cases h₂
      · simp only
        obtain ⟨a₁, ha₁⟩ := n₁.prop
        obtain ⟨a₂, ha₂⟩ := n₂.prop
        have hn₁ : n₁ = Submonoid.pow 2 a₁ := Subtype.ext ha₁.symm
        have hn₂ : n₂ = Submonoid.pow 2 a₂ := Subtype.ext ha₂.symm
        have h₂ : 1 < (2 : ℤ).natAbs := one_lt_two
        rw [hn₁, hn₂, Submonoid.log_pow_int_eq_self h₂, Submonoid.log_pow_int_eq_self h₂]
        apply dyadic_aux
        rwa [ha₁, ha₂, mul_comm, mul_comm m₂]
      · have : (1 : ℤ) ≤ 2 ^ y₃ := by exact_mod_cast Nat.one_le_pow y₃ 2 Nat.succ_pos'
        linarith
  map_zero' := Localization.liftOn_zero _ _
  map_add' x y :=
    Localization.induction_on₂ x y <|
      by
      rintro ⟨a, ⟨b, ⟨b', rfl⟩⟩⟩ ⟨c, ⟨d, ⟨d', rfl⟩⟩⟩
      have h₂ : 1 < (2 : ℤ).natAbs := one_lt_two
      have hpow₂ := Submonoid.log_pow_int_eq_self h₂
      simp_rw [Submonoid.pow_apply] at hpow₂
      simp_rw [Localization.add_mk, Localization.liftOn_mk, Subtype.coe_mk,
        Submonoid.log_mul (Int.pow_right_injective h₂), hpow₂]
      calc
        (2 ^ b' * c + 2 ^ d' * a) • pow_half (b' + d') =
            (c * 2 ^ b') • pow_half (b' + d') + (a * 2 ^ d') • pow_half (d' + b') :=
          by simp only [add_smul, mul_comm, add_comm]
        _ = c • pow_half d' + a • pow_half b' := by simp only [zsmul_pow_two_pow_half]
        _ = a • pow_half b' + c • pow_half d' := add_comm _ _

#align surreal.dyadic_map Surreal.dyadicMap

@[simp]
theorem dyadicMap_apply (m : ℤ) (p : Submonoid.powers (2 : ℤ)) :
    dyadicMap (IsLocalization.mk' (Localization (Submonoid.powers 2)) m p) =
      m • powHalf (Submonoid.log p) :=
  by
  rw [← Localization.mk_eq_mk']
  rfl
#align surreal.dyadic_map_apply Surreal.dyadicMap_apply

@[simp]
theorem dyadicMap_apply_pow (m : ℤ) (n : ℕ) :
    dyadicMap (IsLocalization.mk' (Localization (Submonoid.powers 2)) m (Submonoid.pow 2 n)) =
      m • powHalf n :=
  by rw [dyadic_map_apply, @Submonoid.log_pow_int_eq_self 2 one_lt_two]
#align surreal.dyadic_map_apply_pow Surreal.dyadicMap_apply_pow

/-- We define dyadic surreals as the range of the map `dyadic_map`. -/
def dyadic : Set Surreal :=
  Set.range dyadicMap
#align surreal.dyadic Surreal.dyadic

-- We conclude with some ideas for further work on surreals; these would make fun projects.
-- TODO show that the map from dyadic rationals to surreals is injective
-- TODO map the reals into the surreals, using dyadic Dedekind cuts
-- TODO show this is a group homomorphism, and injective
-- TODO show the maps from the dyadic rationals and from the reals
-- into the surreals are multiplicative
end Surreal


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kevin Kappelmann
-/
import tactic.linarith
import tactic.abel
import algebra.ordered_group
import data.set.intervals.basic

/-!
# Floor and Ceil

## Summary

We define `floor`, `ceil`, and `nat_ceil` functions on linear ordered rings.

## Main Definitions

- `floor_ring` is a linear ordered ring with floor function.
- `floor x` is the greatest integer `z` such that `z ≤ x`.
- `fract x` is the fractional part of x, that is `x - floor x`.
- `ceil x` is the smallest integer `z` such that `x ≤ z`.
- `nat_ceil x` is the smallest nonnegative integer `n` with `x ≤ n`.

## Notations

- `⌊x⌋` is `floor x`.
- `⌈x⌉` is `ceil x`.

## Tags

rounding
-/

variables {α : Type*}

open_locale classical

/--
A `floor_ring` is a linear ordered ring over `α` with a function
`floor : α → ℤ` satisfying `∀ (z : ℤ) (x : α), z ≤ floor x ↔ (z : α) ≤ x)`.
-/
class floor_ring (α) [linear_ordered_ring α] :=
(floor : α → ℤ)
(le_floor : ∀ (z : ℤ) (x : α), z ≤ floor x ↔ (z : α) ≤ x)

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

variables [linear_ordered_ring α] [floor_ring α]

/-- `floor x` is the greatest integer `z` such that `z ≤ x` -/
def floor : α → ℤ := floor_ring.floor

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

lemma floor_ring_unique {α} [linear_ordered_ring α] (inst1 inst2 : floor_ring α) :
  @floor _ _ inst1 = @floor _ _ inst2 :=
begin
  ext v,
  suffices : (⌊v⌋ : α) ≤ v ∧ v < ⌊v⌋ + 1, by rwa [floor_eq_iff],
  exact ⟨floor_le v, lt_floor_add_one v⟩
end

lemma floor_eq_on_Ico (n : ℤ) : ∀ x ∈ (set.Ico n (n+1) : set α), floor x = n :=
λ x ⟨h₀, h₁⟩, floor_eq_iff.mpr ⟨h₀, h₁⟩

lemma floor_eq_on_Ico' (n : ℤ) : ∀ x ∈ (set.Ico n (n+1) : set α), (floor x : α) = n :=
λ x hx, by exact_mod_cast floor_eq_on_Ico n x hx

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

theorem ceil_le_floor_add_one (x : α) : ⌈x⌉ ≤ ⌊x⌋ + 1 :=
by rw [ceil_le, int.cast_add, int.cast_one]; exact le_of_lt (lt_floor_add_one x)

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

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

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

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

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

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

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

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

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

lemma ceil_eq_iff {r : α} {z : ℤ} :
  ⌈r⌉ = z ↔ ↑z-1 < r ∧ r ≤ z :=
by rw [←ceil_le, ←int.cast_one, ←int.cast_sub, ←lt_ceil,
int.sub_one_lt_iff, le_antisymm_iff, and.comm]

lemma ceil_eq_on_Ioc (n : ℤ) : ∀ x ∈ (set.Ioc (n-1) n : set α), ceil x = n :=
λ x ⟨h₀, h₁⟩, ceil_eq_iff.mpr ⟨h₀, h₁⟩

lemma ceil_eq_on_Ioc' (n : ℤ) : ∀ x ∈ (set.Ioc (n-1) n : set α), (ceil x : α) = n :=
λ x hx, by exact_mod_cast ceil_eq_on_Ioc n x hx

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

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

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

theorem le_nat_ceil (a : α) : a ≤ nat_ceil a := nat_ceil_le.1 (le_refl _)

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

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

@[simp] theorem nat_ceil_zero : nat_ceil (0 : α) = 0 := nat_ceil_coe 0

theorem nat_ceil_add_nat {a : α} (a_nonneg : 0 ≤ a) (n : ℕ) : nat_ceil (a + n) = nat_ceil a + n :=
begin
  change int.to_nat (⌈a + (n:ℤ)⌉) = int.to_nat ⌈a⌉ + n,
  rw [ceil_add_int],
  have : 0 ≤ ⌈a⌉, by simpa using (ceil_mono a_nonneg),
  obtain ⟨_, ceil_a_eq⟩ : ∃ (n : ℕ), ⌈a⌉ = n, from int.eq_coe_of_zero_le this,
  rw ceil_a_eq,
  refl
end

theorem nat_ceil_lt_add_one {a : α} (a_nonneg : 0 ≤ a) :
  (nat_ceil a : α) < a + 1 :=
lt_nat_ceil.1 $ by rw (
  show nat_ceil (a + 1) = nat_ceil a + 1, by exact_mod_cast (nat_ceil_add_nat a_nonneg 1));
  apply nat.lt_succ_self

lemma lt_of_nat_ceil_lt {x : α} {n : ℕ} (h : nat_ceil x < n) : x < n :=
lt_of_le_of_lt (le_nat_ceil x) (by exact_mod_cast h)

lemma le_of_nat_ceil_le {x : α} {n : ℕ} (h : nat_ceil x ≤ n) : x ≤ n :=
le_trans (le_nat_ceil x) (by exact_mod_cast h)

namespace int

@[simp] lemma preimage_Ioo {x y : α} :
  ((coe : ℤ → α) ⁻¹' (set.Ioo x y)) = set.Ioo (floor x) (ceil y) :=
by { ext, simp [floor_lt, lt_ceil] }

@[simp] lemma preimage_Ico {x y : α} :
  ((coe : ℤ → α) ⁻¹' (set.Ico x y)) = set.Ico (ceil x) (ceil y) :=
by { ext, simp [ceil_le, lt_ceil] }

@[simp] lemma preimage_Ioc {x y : α} :
  ((coe : ℤ → α) ⁻¹' (set.Ioc x y)) = set.Ioc (floor x) (floor y) :=
by { ext, simp [floor_lt, le_floor] }

@[simp] lemma preimage_Icc {x y : α} :
  ((coe : ℤ → α) ⁻¹' (set.Icc x y)) = set.Icc (ceil x) (floor y) :=
by { ext, simp [ceil_le, le_floor] }

@[simp] lemma preimage_Ioi {x : α} : ((coe : ℤ → α) ⁻¹' (set.Ioi x)) = set.Ioi (floor x) :=
by { ext, simp [floor_lt] }

@[simp] lemma preimage_Ici {x : α} : ((coe : ℤ → α) ⁻¹' (set.Ici x)) = set.Ici (ceil x) :=
by { ext, simp [ceil_le] }

@[simp] lemma preimage_Iio {x : α} : ((coe : ℤ → α) ⁻¹' (set.Iio x)) = set.Iio (ceil x) :=
by { ext, simp [lt_ceil] }

@[simp] lemma preimage_Iic {x : α} : ((coe : ℤ → α) ⁻¹' (set.Iic x)) = set.Iic (floor x) :=
by { ext, simp [le_floor] }

end int


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

! This file was ported from Lean 3 source module data.int.succ_pred
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Int.Order.Basic
import Mathlib.Data.Nat.SuccPred

/-!
# Successors and predecessors of integers

In this file, we show that `ℤ` is both an archimedean `SuccOrder` and an archimedean `PredOrder`.
-/

open Function Order

namespace Int

-- so that Lean reads `Int.succ` through `SuccOrder.succ`
@[reducible]
instance : SuccOrder ℤ :=
  { SuccOrder.ofSuccLeIff succ fun {_ _} => Iff.rfl with succ := succ }

-- so that Lean reads `Int.pred` through `PredOrder.pred`
@[reducible]
instance : PredOrder ℤ where
  pred := pred
  pred_le _ := (sub_one_lt_of_le le_rfl).le
  min_of_le_pred ha := ((sub_one_lt_of_le le_rfl).not_le ha).elim
  le_pred_of_lt {_ _} := le_sub_one_of_lt
  le_of_pred_lt {_ _} := le_of_sub_one_lt

@[simp]
theorem succ_eq_succ : Order.succ = succ :=
  rfl
#align int.succ_eq_succ Int.succ_eq_succ

@[simp]
theorem pred_eq_pred : Order.pred = pred :=
  rfl
#align int.pred_eq_pred Int.pred_eq_pred

theorem pos_iff_one_le {a : ℤ} : 0 < a ↔ 1 ≤ a :=
  Order.succ_le_iff.symm
#align int.pos_iff_one_le Int.pos_iff_one_le

theorem succ_iterate (a : ℤ) : ∀ n, (succ^[n]) a = a + n
  | 0 => (add_zero a).symm
  | n + 1 => by
    rw [Function.iterate_succ', Int.ofNat_succ, ← add_assoc]
    exact congr_arg _ (succ_iterate a n)
#align int.succ_iterate Int.succ_iterate

theorem pred_iterate (a : ℤ) : ∀ n, (pred^[n]) a = a - n
  | 0 => (sub_zero a).symm
  | n + 1 => by
    rw [Function.iterate_succ', Int.ofNat_succ, ← sub_sub]
    exact congr_arg _ (pred_iterate a n)
#align int.pred_iterate Int.pred_iterate

instance : IsSuccArchimedean ℤ :=
  ⟨fun {a b} h =>
    ⟨(b - a).toNat, by
      rw [succ_eq_succ, succ_iterate, toNat_sub_of_le h, ← add_sub_assoc, add_sub_cancel']⟩⟩

instance : IsPredArchimedean ℤ :=
  ⟨fun {a b} h =>
    ⟨(b - a).toNat, by rw [pred_eq_pred, pred_iterate, toNat_sub_of_le h, sub_sub_cancel]⟩⟩

/-! ### Covering relation -/

protected theorem covby_iff_succ_eq {m n : ℤ} : m ⋖ n ↔ m + 1 = n :=
  succ_eq_iff_covby.symm
#align int.covby_iff_succ_eq Int.covby_iff_succ_eq

@[simp]
theorem sub_one_covby (z : ℤ) : z - 1 ⋖ z := by rw [Int.covby_iff_succ_eq, sub_add_cancel]
#align int.sub_one_covby Int.sub_one_covby

@[simp]
theorem covby_add_one (z : ℤ) : z ⋖ z + 1 :=
  Int.covby_iff_succ_eq.mpr rfl
#align int.covby_add_one Int.covby_add_one

end Int

@[simp, norm_cast]
theorem Nat.cast_int_covby_iff {a b : ℕ} : (a : ℤ) ⋖ b ↔ a ⋖ b :=
  by
  rw [Nat.covby_iff_succ_eq, Int.covby_iff_succ_eq]
  exact Int.coe_nat_inj'
#align nat.cast_int_covby_iff Nat.cast_int_covby_iff

alias Nat.cast_int_covby_iff ↔ _ Covby.cast_int
#align covby.cast_int Covby.cast_int


import BrownCs22.Library.Tactics
import BrownCs22.Library.Defs
import Mathlib.Data.Real.Basic
import Mathlib.Tactic.Polyrith

-- don't change these lines
namespace HW4
open Dvd Function
set_option linter.unusedVariables false

/-

# Welcome to the Lean section of HW4!

Today we'll explore a little bit about functions and relations in Lean.

In particular, we'll think about the *logical form*
of some of the function and relation properties we saw,
like injectivity and surjectivity.

## Defining functions in Lean

Lean, believe it or not, is a programming language like Python, Pyret,
ReasonML, or whatever language you're familiar with.
(Of the Brown intro course languages, it's probably closest to ReasonML.)

This means we can define functions and evaluate them.
The below defines a function named `my_quadratic` that takes as input
an integer `x` and produces another integer.
-/

def my_quadratic (x : ℤ) : ℤ :=
  4*x^2 + 55*x - 10

#check my_quadratic

/-
We can evaluate it by using `#eval`.

Unlike many languages like Python, we don't need parentheses
if the argument is a single integer --
we *can* write `my_quadratic(12)`, but we don't need to.
If we want to evaluate it on a more complicated expression,
we do need parentheses around the argument.
-/

#eval my_quadratic 12
#eval my_quadratic (10 + 2)

/-

What makes Lean more exciting than these other languages?
Not only can we define functions, but we can state *properties*
of these functions, and *prove* that these properties hold.

How convenient: we just learned about a lot of function
and relation properties in class :)

A side note: in class, we said that functions and relations were
sets of ordered pairs, defined by their *graph*:
`f(x) = y` if and only if `(x, y) ∈ G(f)`.
But we also (in lecture 9) mentioned that it was a *choice* of ours
to take sets as the "primary" concept and to define functions and relations
in terms of sets. Lean, like most programming languages,
takes the opposite approach: functions are a "primary" concept, and
sets are defined in terms of functions.

Confusing? Don't worry about it too much: if we're interested in properties
of functions and relations, and in using these ideas, it doesn't really
matter how they're defined. It matters what they can do. And Lean functions
can do exactly the same things as our "sets of pairs" functions from class.

## Problems 1 and 2

We'll work with some pretty simple functions today.
Here's one, a *linear* function on the rational numbers, called `f`.

(We call `f` linear because its graph is a straight line, or equivalently,
because it doesn't multiply variables together.
`g x = x^2` would not be linear.)

-/

def f (x : ℚ) : ℚ := 2*x + 6

#eval f 5
#eval f (1/3)

/-

Let's prove that `f` is injective and surjective.

Some tactics to remember:

* `dsimp` unfolds definitions. You can `dsimp [Injective]`
  to expand what it means for `f` to be injective.
  (This is probably a good place to start!)
  You can `dsimp [f]` to change `f x` into `2*x + 6`.

* `linarith` will do basic arithmetic for you, using facts
  that appear in your hypotheses.
  In particular, `linarith` will reason about linear functions.
  It will often get confused, or fail to prove things,
  if it sees variables multiplied together.

-/

/- 2 points -/
theorem problem_1 : Injective f := by
  -- A good first step is always to unfold definitions! After these lines, the tactic state shows
  -- the internal definition of `Injective` and `f`, which will help with the proof.
  dsimp [Injective]
  dsimp [f] -- Make sure you can read, understand, and explain the rewritten goal before continuing
  -- We now have a goal with 2 universal quantifiers and an implication. This will require 3 intro statements:
  -- make sure to check that everything is named what you want it to be!
  intro a1
  intro a2
  intro heq
  -- Now, our goal is a mathematical statement that can be algebraically proved from our hypotheses.
  linarith

/- 2 points -/
theorem problem_2 : Surjective f := by
  -- As before, let's start by unfolding `Surjective` and `f`.
  dsimp [Surjective]
  dsimp [f] -- Make sure you can read, understand, and explain the rewritten goal before continuing
  -- We have a universal quantifier and an existential quantifier. Let's start by introducing the universal:
  intro b
  -- We now have an ∃ statement. Because we are working in the rational numbers, we can directly calculate
  -- a value for a that makes the statement true, and "plug" that value into `existsi`:
  existsi (b - 6) / 2        -- b / 2 - 3 also works, if you come up with that instead
  -- From here, just algebra!
  linarith

/-

## Notes for 1 and 2

Think about the *logical forms* of injectivity and surjectivity.

Injectivity says: if two things `a, b` in the domain map to the same value in the codomain,
then `a` and `b` must be the same.
This is a ∀, ∀, → structure.

Surjectivity says: everything in the codomain gets mapped to by something in the domain.
This is a ∀, ∃ structure.

If you `dsimp [f]` before `dsimp [Surjective]`, you might see some funny
syntax. This syntax is for an "anonymous function" (if you're familiar with that concept).
Try starting by unfolding surjectivity.

-/

/-

## Problem 3

We can talk about relations in Lean as well.
Again, the relations we see will be mostly mathematical,
but there are lots of interesting relations on programming data types:
for instance, the relation `is_prefix_of` on strings or lists.

Here's a mathematical relation on `ℤ`: `R a b` holds when `a` divides `b`.
-/

def R (a b : ℤ) : Prop :=
  a ∣ b

/-

When we talked about relation properties in class, we described them
in terms of "arrows" going out of and into the domain and codomain.
But we also saw the logical form of these properties. Lean, unsurprisingly,
knows about these logical forms. To show that `R` is reflexive,
we'll need to prove `∀ x : ℤ, R x x`:
"every integer is related to itself by `R`."

Let's show that this relation is reflexive. Like before,
`dsimp [Reflexive]` and `dsimp [R]` might be useful!

-/

/- 2 points -/
theorem problem_3 : Reflexive R := by
  -- As mentioned above, dsimp is almost always useful, and is a good first step!
  dsimp [Reflexive]
  dsimp [R]
  dsimp [dvd] -- You should probably also dsimp `dvd` as they did on previous homework
  -- Now, we have a ∀ statement and an ∃ statement, so we know `intro` and `existsi` will have to show up somewhere.
  -- But what witness should we introduce? Note that after simplifying, the math part of our goal is `x = x * c`.
  -- c = 1 satisfies this statement.
  intro x
  exists 1
  linarith

/-

## Notes for problem 3

Again, unfolding `R` before `Reflexive` might expose some confusing syntax.

-/

/-

## Problem 4

Finally, let's also show that `R` is transitive.
(Why did we skip "symmetric"? Think about that one for a sec!)

At some point in your proof, you might end up with a statement that
looks like it could be solved by `linarith`, but can't.
First, check that the statement should really be provable.
If you're convinced it is -- are there variables multiplied together?

There's another tactic (actually, two tactics) that can help out.

`polyrith` is a very expensive version of `linarith` that only works
on equalities, but handles nonlinear expressions.
Because it can sometimes be slow, when it succeeds,
it prints a message in the tactic state to the right.
The message suggests to try using a tactic called `linear_combination`.
Copy and paste this message, replacing your call to `polyrith`,
and it should magically work.

(We'll talk more in class about linear combinations very soon --
this is the same concept showing up in a different context.)

-/

/- 3 points -/
theorem problem_4 : Transitive R := by
  -- No surprises here - time to `dsimp`:
  dsimp [Transitive]
  dsimp [R]
  -- This is a good time to look at the Infoview to get the feel for what you are being asked to do: unfolding
  -- `dvd` can make things a bit cluttered.

  -- There's quite a bit going on here. Looking at the goal, we can see that there are 3 universal quantifiers,
  -- and 2 implications. Hovering over the arrows in the Infoview shows that the left arrow (the one with only x | y on the side)
  -- is the outermost of the implications, so that will be the first one introduced after the quantifiers.
  dsimp [dvd] -- Be careful - the term `c` shows up in 3 separate lines in the Infoview, but they are not all the same `c`!
  intro x
  intro y
  intro z
  intro hxy
  intro hyz
  -- Here, you should check to make sure that everything is named how you expect it to be. If they accidentally
  -- named a hypothesis with the wrong letters, it will cause extra confusion later.

  -- Looking at the Infoview, it looks like `x * something₁ = y` and `y * something₂ = z`. Therefore, the main goal of
  -- our proof is to conclude that `x * (something₁ * something₂) = z`. In order to do that, we will need to use
  -- `eliminate` on `hxy` and `hyz` to extract the `something`s, and then use `existsi` to introduce
  -- `(something₁ * something₂)` as our witness:
  eliminate hxy with c₁ hc₁
  eliminate hyz with c₂ hc₂
  existsi c₁ * c₂
  -- Now, looking at the statements in the Infoview, this looks like a purely algebraic proof! However, `linarith` will not
  -- work here, since we are multiplying variables together. Therefore, we can use `polyrith` to make sure that the goal
  -- is provable:

  -- polyrith

  -- `polyrith` will complete the proof, but will also generate the following message in the Infoview:
  -- `Try this: linear_combination c₂ * hc₁ + hc₂`
  -- Using this in place of polyrith will also complete the proof, and it is preferred that you do such
  -- (for a variety of reasons: if you are interested, you can hover over an uncommented call to polyrith to
  --  see its documentation - do you notice anything going on that might not be good to keep in a final product?)
  linear_combination c₂ * hc₁ + hc₂

/-

## Notes for problem 4

The `polyrith` step is kind of funny: a tactic is suggesting another tactic!
If you see an error about python when trying to use `polyrith`,
you did not follow the directions to create a new Gitpod instance.

Fun fact: `linear_combination` and `polyrith` were both written by Brown undergrads,
Abby Goldberg and Dhruv Bhatia, who took cs1951x "Formal Proof and Verification"!

-/

end HW4


-- Homework 5 due 9.26

theorem problem1 (A B : Prop) : (A → B) → (¬ B → ¬ A) := sorry

theorem problem2 (A B : Prop) : ¬ (A ∨ B) ↔ ¬ A ∧ ¬ B := sorry

theorem problem3 (A B C : Prop) (h : B ↔ C) : (A ∨ B) ↔ A ∨ C := sorry

theorem problem4 (A B : Prop) : (A → B) ↔ ¬ A ∨ B := sorry

theorem problem5 (A B : Prop) : ¬ A → A → B := sorry


import syntax.syntax
import logic.basic data.set.basic
local attribute [instance] classical.prop_decidable

open form

/- SEMANTICS -/

/-

We now want to define a *semantics* for our language.#check

-/

---------------------- Semantics ----------------------

/-

In classical modal logic, a frame is a pair F = ⟨W, R⟩
where W is a *non-empty* set of worlds and R is a
binary relation on W (indicating which worlds are related to
which others).

-/
structure frame :=
(W : Type)
(W_inhabited : inhabited W)
(R : W → W → Prop)

/-

Truth at a world

In modal logic, a formula A is true at a world if.

-/
def true_at_world (f : frame) (v : nat → f.W → Prop) : f.W → form → Prop
  | w (bot)    := false
  | w (var n)  := v n w
  | w (A & B)  := (true_at_world w A) ∧ (true_at_world w B)
  | w (A ⊃ B) := (true_at_world w A) → (true_at_world w B)
  | w (box A)  := ∀ y, f.R w y → true_at_world y A

/-

Now we define semantic entailment. Say we have a set of formulas Γ
a formula A. We say that Γ *entails* A iff:

For each model M = ⟨W, R, V⟩ and w ∈ W,
*if*   M, w ⊩ B for every B ∈ Γ,
*then* M, w ⊩ A

We'll encode the *if* in its own definition 'ctx_true_in_frame'

-/

/- Given a model (specified by f and v),
all formulas in the context are true at all worlds in the model -/

-- A context is true at a world in a model if each
-- formula of the context is true at that world in that model
def ctx_true_in_model (f : frame) (v : nat → f.W → Prop)
  (Γ : ctx) := ∀ A, ∀ w, A ∈ Γ → true_at_world f v w A

-- Global semantic consequence
def entails (Γ : ctx) (A : form) :=
  ∀ f v, ctx_true_in_model f v Γ → ∀ x, true_at_world f v x A

/-----------------/

/- A formula A is valid in a specific model if true at each world -/
def valid_in_model (A : form) (f : frame)
  (v : nat → f.W → Prop) :=
  ∀ w, true_at_world f v w A

/- A formula A is valid in a specific frame if true at each model in the frame -/
def valid_in_frame (A : form) (f : frame) :=
  ∀ v w, true_at_world f v w A

/- A formula A is valid in a *class* of frames if true at each frame in the class -/
def valid_in_frame_class (A : form) (F : set (frame)) :=
  ∀ f ∈ F, ∀ v w, true_at_world f v w A

/- Finally, there are certain formulas that are universally valid -/
def valid_universally (A : form) :=
  ∀ f v w, true_at_world f v w A

/- Finally, a helpful lemma regarding the moving of negation in/out -/
lemma not_forces_imp :  ∀ f v x A,
  (¬(true_at_world f v x A)) ↔ (true_at_world f v x (¬A)) :=
begin
intros f v x A, split,
repeat {intros h1 h2, exact h1 h2},
end


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import field_theory.finite.basic

/-!
# The Chevalley–Warning theorem

This file contains a proof of the Chevalley–Warning theorem.
Throughout most of this file, `K` denotes a finite field
and `q` is notation for the cardinality of `K`.

## Main results

1. Let `f` be a multivariate polynomial in finitely many variables (`X s`, `s : σ`)
   such that the total degree of `f` is less than `(q-1)` times the cardinality of `σ`.
   Then the evaluation of `f` on all points of `σ → K` (aka `K^σ`) sums to `0`.
   (`sum_eval_eq_zero`)
2. The Chevalley–Warning theorem (`char_dvd_card_solutions_of_sum_lt`).
   Let `f i` be a finite family of multivariate polynomials
   in finitely many variables (`X s`, `s : σ`) such that
   the sum of the total degrees of the `f i` is less than the cardinality of `σ`.
   Then the number of common solutions of the `f i`
   is divisible by the characteristic of `K`.

## Notation

- `K` is a finite field
- `q` is notation for the cardinality of `K`
- `σ` is the indexing type for the variables of a multivariate polynomial ring over `K`

-/

universes u v

open_locale big_operators

section finite_field
open mv_polynomial function (hiding eval) finset finite_field

variables {K σ ι : Type*} [fintype K] [field K] [fintype σ] [decidable_eq σ]
local notation `q` := fintype.card K

lemma mv_polynomial.sum_eval_eq_zero (f : mv_polynomial σ K)
  (h : f.total_degree < (q - 1) * fintype.card σ) :
  ∑ x, eval x f = 0 :=
begin
  haveI : decidable_eq K := classical.dec_eq K,
  calc (∑ x, eval x f)
        = ∑ x : σ → K, ∑ d in f.support, f.coeff d * ∏ i, x i ^ d i : by simp only [eval_eq']
    ... = ∑ d in f.support, ∑ x : σ → K, f.coeff d * ∏ i, x i ^ d i : sum_comm
    ... = 0 : sum_eq_zero _,
  intros d hd,
  obtain ⟨i, hi⟩ : ∃ i, d i < q - 1, from f.exists_degree_lt (q - 1) h hd,
  calc (∑ x : σ → K, f.coeff d * ∏ i, x i ^ d i)
        = f.coeff d * (∑ x : σ → K, ∏ i, x i ^ d i) : mul_sum.symm
    ... = 0                                         : (mul_eq_zero.mpr ∘ or.inr) _,
  calc (∑ x : σ → K, ∏ i, x i ^ d i)
        = ∑ (x₀ : {j // j ≠ i} → K) (x : {x : σ → K // x ∘ coe = x₀}), ∏ j, (x : σ → K) j ^ d j :
              (fintype.sum_fiberwise _ _).symm
    ... = 0 : fintype.sum_eq_zero _ _,
  intros x₀,
  let e : K ≃ {x // x ∘ coe = x₀} := (equiv.subtype_equiv_codomain _).symm,
  calc (∑ x : {x : σ → K // x ∘ coe = x₀}, ∏ j, (x : σ → K) j ^ d j)
        = ∑ a : K, ∏ j : σ, (e a : σ → K) j ^ d j : (e.sum_comp _).symm
    ... = ∑ a : K, (∏ j, x₀ j ^ d j) * a ^ d i    : fintype.sum_congr _ _ _
    ... = (∏ j, x₀ j ^ d j) * ∑ a : K, a ^ d i    : by rw mul_sum
    ... = 0                                       : by rw [sum_pow_lt_card_sub_one _ hi, mul_zero],
  intros a,
  let e' : {j // j = i} ⊕ {j // j ≠ i} ≃ σ := equiv.sum_compl _,
  letI : unique {j // j = i} :=
  { default := ⟨i, rfl⟩, uniq := λ ⟨j, h⟩, subtype.val_injective h },
  calc (∏ j : σ, (e a : σ → K) j ^ d j)
        = (e a : σ → K) i ^ d i * (∏ (j : {j // j ≠ i}), (e a : σ → K) j ^ d j) :
        by { rw [← e'.prod_comp, fintype.prod_sum_type, univ_unique, prod_singleton], refl }
    ... = a ^ d i * (∏ (j : {j // j ≠ i}), (e a : σ → K) j ^ d j) :
        by rw equiv.subtype_equiv_codomain_symm_apply_eq
    ... = a ^ d i * (∏ j, x₀ j ^ d j) : congr_arg _ (fintype.prod_congr _ _ _) -- see below
    ... = (∏ j, x₀ j ^ d j) * a ^ d i : mul_comm _ _,
  { -- the remaining step of the calculation above
    rintros ⟨j, hj⟩,
    show (e a : σ → K) j ^ d j = x₀ ⟨j, hj⟩ ^ d j,
    rw equiv.subtype_equiv_codomain_symm_apply_ne, }
end

variables [decidable_eq K] (p : ℕ) [char_p K p]

/-- The **Chevalley–Warning theorem**, finitary version.
Let `(f i)` be a finite family of multivariate polynomials
in finitely many variables (`X s`, `s : σ`) over a finite field of characteristic `p`.
Assume that the sum of the total degrees of the `f i` is less than the cardinality of `σ`.
Then the number of common solutions of the `f i` is divisible by `p`. -/
theorem char_dvd_card_solutions_of_sum_lt {s : finset ι} {f : ι → mv_polynomial σ K}
  (h : (∑ i in s, (f i).total_degree) < fintype.card σ) :
  p ∣ fintype.card {x : σ → K // ∀ i ∈ s, eval x (f i) = 0} :=
begin
  have hq : 0 < q - 1, { rw [← fintype.card_units, fintype.card_pos_iff], exact ⟨1⟩ },
  let S : finset (σ → K) := { x ∈ univ | ∀ i ∈ s, eval x (f i) = 0 },
  have hS : ∀ (x : σ → K), x ∈ S ↔ ∀ (i : ι), i ∈ s → eval x (f i) = 0,
  { intros x, simp only [S, true_and, sep_def, mem_filter, mem_univ], },
  /- The polynomial `F = ∏ i in s, (1 - (f i)^(q - 1))` has the nice property
  that it takes the value `1` on elements of `{x : σ → K // ∀ i ∈ s, (f i).eval x = 0}`
  while it is `0` outside that locus.
  Hence the sum of its values is equal to the cardinality of
  `{x : σ → K // ∀ i ∈ s, (f i).eval x = 0}` modulo `p`. -/
  let F : mv_polynomial σ K := ∏ i in s, (1 - (f i)^(q - 1)),
  have hF : ∀ x, eval x F = if x ∈ S then 1 else 0,
  { intro x,
    calc eval x F = ∏ i in s, eval x (1 - f i ^ (q - 1)) : eval_prod s _ x
              ... = if x ∈ S then 1 else 0 : _,
    simp only [(eval x).map_sub, (eval x).map_pow, (eval x).map_one],
    split_ifs with hx hx,
    { apply finset.prod_eq_one,
      intros i hi,
      rw hS at hx,
      rw [hx i hi, zero_pow hq, sub_zero], },
    { obtain ⟨i, hi, hx⟩ : ∃ (i : ι), i ∈ s ∧ eval x (f i) ≠ 0,
      { simpa only [hS, not_forall, not_imp] using hx },
      apply finset.prod_eq_zero hi,
      rw [pow_card_sub_one_eq_one (eval x (f i)) hx, sub_self], } },
  -- In particular, we can now show:
  have key : ∑ x, eval x F = fintype.card {x : σ → K // ∀ i ∈ s, eval x (f i) = 0},
  rw [fintype.card_of_subtype S hS, card_eq_sum_ones, nat.cast_sum, nat.cast_one,
      ← fintype.sum_extend_by_zero S, sum_congr rfl (λ x hx, hF x)],
  -- With these preparations under our belt, we will approach the main goal.
  show p ∣ fintype.card {x // ∀ (i : ι), i ∈ s → eval x (f i) = 0},
  rw [← char_p.cast_eq_zero_iff K, ← key],
  show ∑ x, eval x F = 0,
  -- We are now ready to apply the main machine, proven before.
  apply F.sum_eval_eq_zero,
  -- It remains to verify the crucial assumption of this machine
  show F.total_degree < (q - 1) * fintype.card σ,
  calc F.total_degree ≤ ∑ i in s, (1 - (f i)^(q - 1)).total_degree : total_degree_finset_prod s _
                  ... ≤ ∑ i in s, (q - 1) * (f i).total_degree     : sum_le_sum $ λ i hi, _ -- see ↓
                  ... = (q - 1) * (∑ i in s, (f i).total_degree)   : mul_sum.symm
                  ... < (q - 1) * (fintype.card σ)                 : by rwa mul_lt_mul_left hq,
  -- Now we prove the remaining step from the preceding calculation
  show (1 - f i ^ (q - 1)).total_degree ≤ (q - 1) * (f i).total_degree,
  calc (1 - f i ^ (q - 1)).total_degree
        ≤ max (1 : mv_polynomial σ K).total_degree (f i ^ (q - 1)).total_degree :
        total_degree_sub _ _
    ... ≤ (f i ^ (q - 1)).total_degree : by simp only [max_eq_right, nat.zero_le, total_degree_one]
    ... ≤ (q - 1) * (f i).total_degree : total_degree_pow _ _
end

/-- The **Chevalley–Warning theorem**, fintype version.
Let `(f i)` be a finite family of multivariate polynomials
in finitely many variables (`X s`, `s : σ`) over a finite field of characteristic `p`.
Assume that the sum of the total degrees of the `f i` is less than the cardinality of `σ`.
Then the number of common solutions of the `f i` is divisible by `p`. -/
theorem char_dvd_card_solutions_of_fintype_sum_lt [fintype ι] {f : ι → mv_polynomial σ K}
  (h : (∑ i, (f i).total_degree) < fintype.card σ) :
  p ∣ fintype.card {x : σ → K // ∀ i, eval x (f i) = 0} :=
by simpa using char_dvd_card_solutions_of_sum_lt p h

/-- The **Chevalley–Warning theorem**, unary version.
Let `f` be a multivariate polynomial in finitely many variables (`X s`, `s : σ`)
over a finite field of characteristic `p`.
Assume that the total degree of `f` is less than the cardinality of `σ`.
Then the number of solutions of `f` is divisible by `p`.
See `char_dvd_card_solutions_of_sum_lt` for a version that takes a family of polynomials `f i`. -/
theorem char_dvd_card_solutions {f : mv_polynomial σ K} (h : f.total_degree < fintype.card σ) :
  p ∣ fintype.card {x : σ → K // eval x f = 0} :=
begin
  let F : unit → mv_polynomial σ K := λ _, f,
  have : ∑ i : unit, (F i).total_degree < fintype.card σ := h,
  simpa only [F, fintype.univ_punit, forall_eq, mem_singleton] using
    char_dvd_card_solutions_of_sum_lt p this,
end

/-- The **Chevalley–Warning theorem**, binary version.
Let `f₁`, `f₂` be two multivariate polynomials in finitely many variables (`X s`, `s : σ`) over a
finite field of characteristic `p`.
Assume that the sum of the total degrees of `f₁` and `f₂` is less than the cardinality of `σ`.
Then the number of common solutions of the `f₁` and `f₂` is divisible by `p`. -/
theorem char_dvd_card_solutions_of_add_lt {f₁ f₂ : mv_polynomial σ K}
  (h : f₁.total_degree + f₂.total_degree < fintype.card σ) :
  p ∣ fintype.card {x : σ → K // eval x f₁ = 0 ∧ eval x f₂ = 0} :=
begin
  let F : bool → mv_polynomial σ K := λ b, cond b f₂ f₁,
  have : ∑ b : bool, (F b).total_degree < fintype.card σ := (add_comm _ _).trans_lt h,
  simpa only [F, bool.forall_bool] using char_dvd_card_solutions_of_fintype_sum_lt p this,
end

end finite_field


/-
Copyright (c) 2023 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.quadratic_form.basic
import algebra.char_p.two
import data.zmod.basic

/-!
# `quadratic_form R M` and `subtype bilin_form.is_symm` are distinct notions in characteristic 2

The main result of this file is `bilin_form.not_inj_on_to_quadratic_form_is_symm`.

The counterexample we use is $B (x, y) (x', y') ↦ xy' + x'y$ where `x y x' y' : zmod 2`.
-/

variables (F : Type*) [nontrivial F] [comm_ring F] [char_p F 2]

open bilin_form

/-- The bilinear form we will use as a counterexample, over some field `F` of characteristic two. -/
def B : bilin_form F (F × F) :=
bilin_form.lin_mul_lin (linear_map.fst _ _ _) (linear_map.snd _ _ _)
 + bilin_form.lin_mul_lin (linear_map.snd _ _ _) (linear_map.fst _ _ _)

@[simp]
lemma B_apply (x y : F × F) : B F x y = x.1 * y.2 + x.2 * y.1 := rfl

lemma is_symm_B : (B F).is_symm := λ x y, by simp [mul_comm, add_comm]

lemma is_alt_B : (B F).is_alt := λ x, by simp [mul_comm, char_two.add_self_eq_zero (x.1 * x.2)]

lemma B_ne_zero : B F ≠ 0 := λ h, by simpa using bilin_form.congr_fun h (1, 0) (1, 1)

/-- `bilin_form.to_quadratic_form` is not injective on symmetric bilinear forms.

This disproves a weaker version of `quadratic_form.associated_left_inverse`.
-/
lemma {u} bilin_form.not_inj_on_to_quadratic_form_is_symm :
  ¬∀ {R M : Type u} [semiring R] [add_comm_monoid M],
    by exactI ∀ [module R M],
    by exactI set.inj_on
      (to_quadratic_form : bilin_form R M → quadratic_form R M)
      { B | B.is_symm }:=
begin
  intro h,
  let F := ulift.{u} (zmod 2),
  apply B_ne_zero F,
  apply h (is_symm_B F) (is_symm_zero),
  rw [bilin_form.to_quadratic_form_zero, bilin_form.to_quadratic_form_eq_zero],
  exact is_alt_B F,
end


-- 11/21/2019 - natural deduction

variables P Q R : Prop

-- two different ways to solve proofs including "forall"

-- forall introduction: given a proof of Q for an arbitrary value of type P, we can conclude that Q holds "for all" P
    -- i.e. ∀ (p : P), Q

example : ∀ (p : P), Q :=
    λ (hp : P),
        sorry

example : ∀ (p : P), Q :=
begin
    assume hp,
    sorry
end

example : (∀ (p : P), Q) → P → Q :=
begin
    assume pq,
    exact pq
end

example : (∀ (p : P), Q) → P → Q :=
    λ (pq : ∀ (p : P), Q), -- forall "introduction" - we assume an arbitrary value using a lambda expression
        λ (hp : P),        -- assume P
            (pq hp)        -- forall "elimination" - apply our "for all" proof to our hypothesis of p

example : (∀ (p : P), Q) → P → Q := id

-- What's the f word? Just kidding. Function!

-- Proof that X → Y is really just a function that takes an argument that is a proof of X, and spits out a proof of Y

example : (P ∧ Q) → P := and.elim_left
example : (P ∧ Q) → Q := and.elim_right

-- = introduction
-- for any value of type α a, a=a
-- (eq.refl)

variable L : P → Prop

-- = elimination rule : eq.subst
-- given a proof that a = b, we derive a proof that P a implies P b

example : ∀ (a b : P), (a = b) → (L a → L b) :=
begin
    assume a b, -- assume a and b of typ eP
    assume heq, -- assume a = b
    apply eq.subst, -- apply equals substitution; new goal: show that a = b
    exact heq, -- assumption.
end

example : ∀ (a b : P), (a = b) → (L a → L b) := λ (a b : P), eq.subst

-- the equals relation has two fundamental properties: reflexivity and substitutability.

-- negation! meet "false."
-- false is a proposition that is never true. it has no proofs.

def f : false → 0 = 1 :=
begin
    assume f,
    apply false.elim,
    exact f,
end

def f' : false → 0 = 1
| x := false.elim x

-- false elimination: we can derive a proof of anything from false

example : ¬(0=1):=
begin
    contradiction,
end


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson

! This file was ported from Lean 3 source module order.atoms.finite
! leanprover-community/mathlib commit d6fad0e5bf2d6f48da9175d25c3dc5706b3834ce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Finite
import Mathlib.Order.Atoms

/-!
# Atoms, Coatoms, Simple Lattices, and Finiteness

This module contains some results on atoms and simple lattices in the finite context.

## Main results
  * `Finite.to_isAtomic`, `Finite.to_isCoatomic`: Finite partial orders with bottom resp. top
    are atomic resp. coatomic.

-/

variable {α β : Type _}

namespace IsSimpleOrder

section DecidableEq

/- It is important that `IsSimpleOrder` is the last type-class argument of this instance,
so that type-class inference fails quickly if it doesn't apply. -/
instance (priority := 200) {α} [DecidableEq α] [LE α] [BoundedOrder α] [IsSimpleOrder α] :
    Fintype α :=
  Fintype.ofEquiv Bool equivBool.symm

end DecidableEq

end IsSimpleOrder

namespace Fintype

namespace IsSimpleOrder

variable [PartialOrder α] [BoundedOrder α] [IsSimpleOrder α] [DecidableEq α]

theorem univ : (Finset.univ : Finset α) = {⊤, ⊥} := by
  change Finset.map _ (Finset.univ : Finset Bool) = _
  rw [Fintype.univ_bool]
  simp only [Finset.map_insert, Function.Embedding.coeFn_mk, Finset.map_singleton]
  rfl
#align fintype.is_simple_order.univ Fintype.IsSimpleOrder.univ

theorem card : Fintype.card α = 2 :=
  (Fintype.ofEquiv_card _).trans Fintype.card_bool
#align fintype.is_simple_order.card Fintype.IsSimpleOrder.card

end IsSimpleOrder

end Fintype

namespace Bool

instance : IsSimpleOrder Bool :=
  ⟨fun a =>
    by
    rw [← Finset.mem_singleton, Or.comm, ← Finset.mem_insert, top_eq_true, bot_eq_false, ←
      Fintype.univ_bool]
    apply Finset.mem_univ⟩

end Bool

section Fintype

open Finset

-- see Note [lower instance priority]
instance (priority := 100) Finite.to_isCoatomic [PartialOrder α] [OrderTop α] [Finite α] :
    IsCoatomic α := by
  refine' IsCoatomic.mk fun b => or_iff_not_imp_left.2 fun ht => _
  obtain ⟨c, hc, hmax⟩ :=
    Set.Finite.exists_maximal_wrt id { x : α | b ≤ x ∧ x ≠ ⊤ } (Set.toFinite _) ⟨b, le_rfl, ht⟩
  refine' ⟨c, ⟨hc.2, fun y hcy => _⟩, hc.1⟩
  by_contra hyt
  obtain rfl : c = y := hmax y ⟨hc.1.trans hcy.le, hyt⟩ hcy.le
  exact (lt_self_iff_false _).mp hcy
#align finite.to_is_coatomic Finite.to_isCoatomic

-- see Note [lower instance priority]
instance (priority := 100) Finite.to_isAtomic [PartialOrder α] [OrderBot α] [Finite α] :
    IsAtomic α :=
  isCoatomic_dual_iff_isAtomic.mp Finite.to_isCoatomic
#align finite.to_is_atomic Finite.to_isAtomic

end Fintype


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module data.vector.zip
! leanprover-community/mathlib commit 1126441d6bccf98c81214a0780c73d499f6721fe
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Vector.Basic
import Mathlib.Data.List.Zip

/-!
# The `zipWith` operation on vectors.
-/

namespace Vector

section ZipWith

variable {α β γ : Type _} {n : ℕ} (f : α → β → γ)

/-- Apply the function `f : α → β → γ` to each corresponding pair of elements from two vectors. -/
def zipWith : Vector α n → Vector β n → Vector γ n := fun x y => ⟨List.zipWith f x.1 y.1, by simp⟩
#align vector.zip_with Vector.zipWith

@[simp]
theorem zipWith_toList (x : Vector α n) (y : Vector β n) :
    (Vector.zipWith f x y).toList = List.zipWith f x.toList y.toList :=
  rfl
#align vector.zip_with_to_list Vector.zipWith_toList

@[simp]
theorem zipWith_get (x : Vector α n) (y : Vector β n) (i) :
    (Vector.zipWith f x y).get i = f (x.get i) (y.get i) := by
  dsimp only [Vector.zipWith, Vector.get]
  cases x; cases y
  simp only [List.nthLe_zipWith]
#align vector.zip_with_nth Vector.zipWith_get

@[simp]
theorem zipWith_tail (x : Vector α n) (y : Vector β n) :
    (Vector.zipWith f x y).tail = Vector.zipWith f x.tail y.tail := by
  ext
  simp [get_tail]
#align vector.zip_with_tail Vector.zipWith_tail

@[to_additive]
theorem prod_mul_prod_eq_prod_zipWith [CommMonoid α] (x y : Vector α n) :
    x.toList.prod * y.toList.prod = (Vector.zipWith (· * ·) x y).toList.prod :=
  List.prod_mul_prod_eq_prod_zipWith_of_length_eq x.toList y.toList
    ((toList_length x).trans (toList_length y).symm)
#align vector.prod_mul_prod_eq_prod_zip_with Vector.prod_mul_prod_eq_prod_zipWith
#align vector.sum_add_sum_eq_sum_zip_with Vector.sum_add_sum_eq_sum_zipWith

end ZipWith

end Vector


/-
Copyright (c) 2018 Ellen Arlt. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ellen Arlt, Blair Shi, Sean Leather, Mario Carneiro, Johan Commelin
-/
import data.matrix.basic

/-!
# Block Matrices

## Main definitions

* `matrix.from_blocks`: build a block matrix out of 4 blocks
* `matrix.to_blocks₁₁`, `matrix.to_blocks₁₂`, `matrix.to_blocks₂₁`, `matrix.to_blocks₂₂`:
  extract each of the four blocks from `matrix.from_blocks`.
* `matrix.block_diagonal`: block diagonal of equally sized blocks. On square blocks, this is a
  ring homomorphisms, `matrix.block_diagonal_ring_hom`.
* `matrix.block_diag`: extract the blocks from the diagonal of a block diagonal matrix.
* `matrix.block_diagonal'`: block diagonal of unequally sized blocks. On square blocks, this is a
  ring homomorphisms, `matrix.block_diagonal'_ring_hom`.
* `matrix.block_diag'`: extract the blocks from the diagonal of a block diagonal matrix.
-/

variables {l m n o p q : Type*} {m' n' p' : o → Type*}
variables {R : Type*} {S : Type*} {α : Type*} {β : Type*}

open_locale matrix

namespace matrix

section block_matrices

/-- We can form a single large matrix by flattening smaller 'block' matrices of compatible
dimensions. -/
@[pp_nodot]
def from_blocks (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  matrix (n ⊕ o) (l ⊕ m) α :=
sum.elim (λ i, sum.elim (A i) (B i))
         (λ i, sum.elim (C i) (D i))

@[simp] lemma from_blocks_apply₁₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : n) (j : l) :
  from_blocks A B C D (sum.inl i) (sum.inl j) = A i j :=
rfl

@[simp] lemma from_blocks_apply₁₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : n) (j : m) :
  from_blocks A B C D (sum.inl i) (sum.inr j) = B i j :=
rfl

@[simp] lemma from_blocks_apply₂₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : o) (j : l) :
  from_blocks A B C D (sum.inr i) (sum.inl j) = C i j :=
rfl

@[simp] lemma from_blocks_apply₂₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : o) (j : m) :
  from_blocks A B C D (sum.inr i) (sum.inr j) = D i j :=
rfl

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"top left" submatrix. -/
def to_blocks₁₁ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix n l α :=
λ i j, M (sum.inl i) (sum.inl j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"top right" submatrix. -/
def to_blocks₁₂ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix n m α :=
λ i j, M (sum.inl i) (sum.inr j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"bottom left" submatrix. -/
def to_blocks₂₁ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix o l α :=
λ i j, M (sum.inr i) (sum.inl j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"bottom right" submatrix. -/
def to_blocks₂₂ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix o m α :=
λ i j, M (sum.inr i) (sum.inr j)

lemma from_blocks_to_blocks (M : matrix (n ⊕ o) (l ⊕ m) α) :
  from_blocks M.to_blocks₁₁ M.to_blocks₁₂ M.to_blocks₂₁ M.to_blocks₂₂ = M :=
begin
  ext i j, rcases i; rcases j; refl,
end

@[simp] lemma to_blocks_from_blocks₁₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₁₁ = A :=
rfl

@[simp] lemma to_blocks_from_blocks₁₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₁₂ = B :=
rfl

@[simp] lemma to_blocks_from_blocks₂₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₂₁ = C :=
rfl

@[simp] lemma to_blocks_from_blocks₂₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₂₂ = D :=
rfl

lemma from_blocks_map
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (f : α → β) :
  (from_blocks A B C D).map f = from_blocks (A.map f) (B.map f) (C.map f) (D.map f) :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_transpose
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D)ᵀ = from_blocks Aᵀ Cᵀ Bᵀ Dᵀ :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_conj_transpose [has_star α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D)ᴴ = from_blocks Aᴴ Cᴴ Bᴴ Dᴴ :=
begin
  simp only [conj_transpose, from_blocks_transpose, from_blocks_map]
end

/-- A 2x2 block matrix is block diagonal if the blocks outside of the diagonal vanish -/
def is_two_block_diagonal [has_zero α] (A : matrix (n ⊕ o) (l ⊕ m) α) : Prop :=
to_blocks₁₂ A = 0 ∧ to_blocks₂₁ A = 0

/-- Let `p` pick out certain rows and `q` pick out certain columns of a matrix `M`. Then
  `to_block M p q` is the corresponding block matrix. -/
def to_block (M : matrix m n α) (p : m → Prop) (q : n → Prop) :
  matrix {a // p a} {a // q a} α := M.minor coe coe

@[simp] lemma to_block_apply (M : matrix m n α) (p : m → Prop) (q : n → Prop)
  (i : {a // p a}) (j : {a // q a}) : to_block M p q i j = M ↑i ↑j := rfl

/-- Let `b` map rows and columns of a square matrix `M` to blocks. Then
  `to_square_block M b k` is the block `k` matrix. -/
def to_square_block (M : matrix m m α) {n : nat} (b : m → fin n) (k : fin n) :
  matrix {a // b a = k} {a // b a = k} α := M.minor coe coe

@[simp] lemma to_square_block_def (M : matrix m m α) {n : nat} (b : m → fin n) (k : fin n) :
  to_square_block M b k = λ i j, M ↑i ↑j := rfl

/-- Alternate version with `b : m → nat`. Let `b` map rows and columns of a square matrix `M` to
  blocks. Then `to_square_block' M b k` is the block `k` matrix. -/
def to_square_block' (M : matrix m m α) (b : m → nat) (k : nat) :
  matrix {a // b a = k} {a // b a = k} α := M.minor coe coe

@[simp] lemma to_square_block_def' (M : matrix m m α) (b : m → nat) (k : nat) :
  to_square_block' M b k = λ i j, M ↑i ↑j := rfl

/-- Let `p` pick out certain rows and columns of a square matrix `M`. Then
  `to_square_block_prop M p` is the corresponding block matrix. -/
def to_square_block_prop (M : matrix m m α) (p : m → Prop) :
  matrix {a // p a} {a // p a} α := M.minor coe coe

@[simp] lemma to_square_block_prop_def (M : matrix m m α) (p : m → Prop) :
  to_square_block_prop M p = λ i j, M ↑i ↑j := rfl

lemma from_blocks_smul [has_scalar R α]
  (x : R) (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  x • (from_blocks A B C D) = from_blocks (x • A) (x • B) (x • C) (x • D) :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_add [has_add α]
  (A  : matrix n l α) (B  : matrix n m α) (C  : matrix o l α) (D  : matrix o m α)
  (A' : matrix n l α) (B' : matrix n m α) (C' : matrix o l α) (D' : matrix o m α) :
  (from_blocks A B C D) + (from_blocks A' B' C' D') =
  from_blocks (A + A') (B + B')
              (C + C') (D + D') :=
begin
  ext i j, rcases i; rcases j; refl,
end

lemma from_blocks_multiply [fintype l] [fintype m] [non_unital_non_assoc_semiring α]
  (A  : matrix n l α) (B  : matrix n m α) (C  : matrix o l α) (D  : matrix o m α)
  (A' : matrix l p α) (B' : matrix l q α) (C' : matrix m p α) (D' : matrix m q α) :
  (from_blocks A B C D) ⬝ (from_blocks A' B' C' D') =
  from_blocks (A ⬝ A' + B ⬝ C') (A ⬝ B' + B ⬝ D')
              (C ⬝ A' + D ⬝ C') (C ⬝ B' + D ⬝ D') :=
begin
  ext i j, rcases i; rcases j;
  simp only [from_blocks, mul_apply, fintype.sum_sum_type, sum.elim_inl, sum.elim_inr,
    pi.add_apply],
end

lemma from_blocks_mul_vec [fintype l] [fintype m] [non_unital_non_assoc_semiring α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (x : l ⊕ m → α) :
  mul_vec (from_blocks A B C D) x =
  sum.elim (mul_vec A (x ∘ sum.inl) + mul_vec B (x ∘ sum.inr))
           (mul_vec C (x ∘ sum.inl) + mul_vec D (x ∘ sum.inr)) :=
by { ext i, cases i; simp [mul_vec, dot_product] }

lemma vec_mul_from_blocks [fintype n] [fintype o] [non_unital_non_assoc_semiring α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (x : n ⊕ o → α) :
  vec_mul x (from_blocks A B C D) =
  sum.elim (vec_mul (x ∘ sum.inl) A + vec_mul (x ∘ sum.inr) C)
           (vec_mul (x ∘ sum.inl) B + vec_mul (x ∘ sum.inr) D) :=
by { ext i, cases i; simp [vec_mul, dot_product] }

variables [decidable_eq l] [decidable_eq m]

@[simp] lemma from_blocks_diagonal [has_zero α] (d₁ : l → α) (d₂ : m → α) :
  from_blocks (diagonal d₁) 0 0 (diagonal d₂) = diagonal (sum.elim d₁ d₂) :=
begin
  ext i j, rcases i; rcases j; simp [diagonal],
end

@[simp] lemma from_blocks_one [has_zero α] [has_one α] :
  from_blocks (1 : matrix l l α) 0 0 (1 : matrix m m α) = 1 :=
by { ext i j, rcases i; rcases j; simp [one_apply] }

end block_matrices

section block_diagonal
variables [decidable_eq o]

section has_zero
variables [has_zero α] [has_zero β]

/-- `matrix.block_diagonal M` turns a homogenously-indexed collection of matrices
`M : o → matrix m n α'` into a `m × o`-by-`n × o` block matrix which has the entries of `M` along
the diagonal and zero elsewhere.

See also `matrix.block_diagonal'` if the matrices may not have the same size everywhere.
-/
def block_diagonal (M : o → matrix m n α) : matrix (m × o) (n × o) α
| ⟨i, k⟩ ⟨j, k'⟩ := if k = k' then M k i j else 0

lemma block_diagonal_apply (M : o → matrix m n α) (ik jk) :
  block_diagonal M ik jk = if ik.2 = jk.2 then M ik.2 ik.1 jk.1 else 0 :=
by { cases ik, cases jk, refl }

@[simp]
lemma block_diagonal_apply_eq (M : o → matrix m n α) (i j k) :
  block_diagonal M (i, k) (j, k) = M k i j :=
if_pos rfl

lemma block_diagonal_apply_ne (M : o → matrix m n α) (i j) {k k'} (h : k ≠ k') :
  block_diagonal M (i, k) (j, k') = 0 :=
if_neg h

lemma block_diagonal_map (M : o → matrix m n α) (f : α → β) (hf : f 0 = 0) :
  (block_diagonal M).map f = block_diagonal (λ k, (M k).map f) :=
begin
  ext,
  simp only [map_apply, block_diagonal_apply, eq_comm],
  rw [apply_ite f, hf],
end

@[simp] lemma block_diagonal_transpose (M : o → matrix m n α) :
  (block_diagonal M)ᵀ = block_diagonal (λ k, (M k)ᵀ) :=
begin
  ext,
  simp only [transpose_apply, block_diagonal_apply, eq_comm],
  split_ifs with h,
  { rw h },
  { refl }
end

@[simp] lemma block_diagonal_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : o → matrix m n α) :
  (block_diagonal M)ᴴ = block_diagonal (λ k, (M k)ᴴ) :=
begin
  simp only [conj_transpose, block_diagonal_transpose],
  rw block_diagonal_map _ star (star_zero α),
end

@[simp] lemma block_diagonal_zero :
  block_diagonal (0 : o → matrix m n α) = 0 :=
by { ext, simp [block_diagonal_apply] }

@[simp] lemma block_diagonal_diagonal [decidable_eq m] (d : o → m → α) :
  block_diagonal (λ k, diagonal (d k)) = diagonal (λ ik, d ik.2 ik.1) :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal_apply, diagonal, prod.mk.inj_iff, ← ite_and],
  congr' 1,
  rw and_comm,
end

@[simp] lemma block_diagonal_one [decidable_eq m] [has_one α] :
  block_diagonal (1 : o → matrix m m α) = 1 :=
show block_diagonal (λ (_ : o), diagonal (λ (_ : m), (1 : α))) = diagonal (λ _, 1),
by rw [block_diagonal_diagonal]

end has_zero

@[simp] lemma block_diagonal_add [add_zero_class α] (M N : o → matrix m n α) :
  block_diagonal (M + N) = block_diagonal M + block_diagonal N :=
begin
  ext,
  simp only [block_diagonal_apply, pi.add_apply],
  split_ifs; simp
end

section
variables (o m n α)
/-- `matrix.block_diagonal` as an `add_monoid_hom`. -/
@[simps] def block_diagonal_add_monoid_hom [add_zero_class α] :
  (o → matrix m n α) →+ matrix (m × o) (n × o) α :=
{ to_fun := block_diagonal,
  map_zero' := block_diagonal_zero,
  map_add' := block_diagonal_add }
end

@[simp] lemma block_diagonal_neg [add_group α] (M : o → matrix m n α) :
  block_diagonal (-M) = - block_diagonal M :=
map_neg (block_diagonal_add_monoid_hom m n o α) M

@[simp] lemma block_diagonal_sub [add_group α] (M N : o → matrix m n α) :
  block_diagonal (M - N) = block_diagonal M - block_diagonal N :=
map_sub (block_diagonal_add_monoid_hom m n o α) M N

@[simp] lemma block_diagonal_mul [fintype n] [fintype o] [non_unital_non_assoc_semiring α]
  (M : o → matrix m n α) (N : o → matrix n p α) :
  block_diagonal (λ k, M k ⬝ N k) = block_diagonal M ⬝ block_diagonal N :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal_apply, mul_apply, ← finset.univ_product_univ, finset.sum_product],
  split_ifs with h; simp [h]
end

section
variables (α m o)
/-- `matrix.block_diagonal` as a `ring_hom`. -/
@[simps]
def block_diagonal_ring_hom [decidable_eq m] [fintype o] [fintype m] [non_assoc_semiring α] :
  (o → matrix m m α) →+* matrix (m × o) (m × o) α :=
{ to_fun := block_diagonal,
  map_one' := block_diagonal_one,
  map_mul' := block_diagonal_mul,
  ..block_diagonal_add_monoid_hom m m o α }
end

@[simp] lemma block_diagonal_pow [decidable_eq m] [fintype o] [fintype m] [semiring α]
  (M : o → matrix m m α) (n : ℕ)  :
  block_diagonal (M ^ n) = block_diagonal M ^ n :=
map_pow (block_diagonal_ring_hom m o α) M n

@[simp] lemma block_diagonal_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : o → matrix m n α) : block_diagonal (x • M) = x • block_diagonal M :=
by { ext, simp only [block_diagonal_apply, pi.smul_apply], split_ifs; simp }

end block_diagonal

section block_diag

/-- Extract a block from the diagonal of a block diagonal matrix.

This is the block form of `matrix.diag`, and the left-inverse of `matrix.block_diagonal`. -/
def block_diag (M : matrix (m × o) (n × o) α) (k : o) : matrix m n α
| i j := M (i, k) (j, k)

lemma block_diag_map (M : matrix (m × o) (n × o) α) (f : α → β) :
  block_diag (M.map f) = λ k, (block_diag M k).map f :=
rfl

@[simp] lemma block_diag_transpose (M : matrix (m × o) (n × o) α) (k : o) :
  block_diag Mᵀ k = (block_diag M k)ᵀ :=
ext $ λ i j, rfl

@[simp] lemma block_diag_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : matrix (m × o) (n × o) α) (k : o) :
  block_diag Mᴴ k = (block_diag M k)ᴴ :=
ext $ λ i j, rfl

section has_zero
variables [has_zero α] [has_zero β]

@[simp] lemma block_diag_zero :
  block_diag (0 : matrix (m × o) (n × o) α) = 0 :=
rfl

@[simp] lemma block_diag_diagonal [decidable_eq o] [decidable_eq m] (d : (m × o) → α) (k : o) :
  block_diag (diagonal d) k = diagonal (λ i, d (i, k)) :=
ext $ λ i j, begin
  obtain rfl | hij := decidable.eq_or_ne i j,
  { rw [block_diag, diagonal_apply_eq, diagonal_apply_eq] },
  { rw [block_diag, diagonal_apply_ne _ hij, diagonal_apply_ne _ (mt _ hij)],
    exact prod.fst_eq_iff.mpr },
end

@[simp] lemma block_diag_block_diagonal [decidable_eq o] (M : o → matrix m n α) :
  block_diag (block_diagonal M) = M :=
funext $ λ k, ext $ λ i j, block_diagonal_apply_eq _ _ _ _

@[simp] lemma block_diag_one [decidable_eq o] [decidable_eq m] [has_one α] :
  block_diag (1 : matrix (m × o) (m × o) α) = 1 :=
funext $ block_diag_diagonal _

end has_zero

@[simp] lemma block_diag_add [add_zero_class α] (M N : matrix (m × o) (n × o) α) :
  block_diag (M + N) = block_diag M + block_diag N :=
rfl

section
variables (o m n α)
/-- `matrix.block_diag` as an `add_monoid_hom`. -/
@[simps] def block_diag_add_monoid_hom [add_zero_class α] :
  matrix (m × o) (n × o) α →+ (o → matrix m n α) :=
{ to_fun := block_diag,
  map_zero' := block_diag_zero,
  map_add' := block_diag_add }
end

@[simp] lemma block_diag_neg [add_group α] (M : matrix (m × o) (n × o) α) :
  block_diag (-M) = - block_diag M :=
map_neg (block_diag_add_monoid_hom m n o α) M

@[simp] lemma block_diag_sub [add_group α] (M N : matrix (m × o) (n × o) α) :
  block_diag (M - N) = block_diag M - block_diag N :=
map_sub (block_diag_add_monoid_hom m n o α) M N

@[simp] lemma block_diag_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : matrix (m × o) (n × o) α) : block_diag (x • M) = x • block_diag M :=
rfl

end block_diag

section block_diagonal'

variables [decidable_eq o]

section has_zero
variables [has_zero α] [has_zero β]

/-- `matrix.block_diagonal' M` turns `M : Π i, matrix (m i) (n i) α` into a
`Σ i, m i`-by-`Σ i, n i` block matrix which has the entries of `M` along the diagonal
and zero elsewhere.

This is the dependently-typed version of `matrix.block_diagonal`. -/
def block_diagonal' (M : Π i, matrix (m' i) (n' i) α) : matrix (Σ i, m' i) (Σ i, n' i) α
| ⟨k, i⟩ ⟨k', j⟩ := if h : k = k' then M k i (cast (congr_arg n' h.symm) j) else 0

lemma block_diagonal'_eq_block_diagonal (M : o → matrix m n α) {k k'} (i j) :
  block_diagonal M (i, k) (j, k') = block_diagonal' M ⟨k, i⟩ ⟨k', j⟩ :=
rfl

lemma block_diagonal'_minor_eq_block_diagonal (M : o → matrix m n α) :
  (block_diagonal' M).minor (prod.to_sigma ∘ prod.swap) (prod.to_sigma ∘ prod.swap) =
    block_diagonal M :=
matrix.ext $ λ ⟨k, i⟩ ⟨k', j⟩, rfl

lemma block_diagonal'_apply (M : Π i, matrix (m' i) (n' i) α) (ik jk) :
  block_diagonal' M ik jk = if h : ik.1 = jk.1 then
    M ik.1 ik.2 (cast (congr_arg n' h.symm) jk.2) else 0 :=
by { cases ik, cases jk, refl }

@[simp]
lemma block_diagonal'_apply_eq (M : Π i, matrix (m' i) (n' i) α) (k i j) :
  block_diagonal' M ⟨k, i⟩ ⟨k, j⟩ = M k i j :=
dif_pos rfl

lemma block_diagonal'_apply_ne (M : Π i, matrix (m' i) (n' i) α) {k k'} (i j) (h : k ≠ k') :
  block_diagonal' M ⟨k, i⟩ ⟨k', j⟩ = 0 :=
dif_neg h

lemma block_diagonal'_map (M : Π i, matrix (m' i) (n' i) α) (f : α → β) (hf : f 0 = 0) :
  (block_diagonal' M).map f = block_diagonal' (λ k, (M k).map f) :=
begin
  ext,
  simp only [map_apply, block_diagonal'_apply, eq_comm],
  rw [apply_dite f, hf],
end

@[simp] lemma block_diagonal'_transpose (M : Π i, matrix (m' i) (n' i) α) :
  (block_diagonal' M)ᵀ = block_diagonal' (λ k, (M k)ᵀ) :=
begin
  ext ⟨ii, ix⟩ ⟨ji, jx⟩,
  simp only [transpose_apply, block_diagonal'_apply],
  split_ifs; cc
end

@[simp] lemma block_diagonal'_conj_transpose {α} [add_monoid α] [star_add_monoid α]
  (M : Π i, matrix (m' i) (n' i) α) :
  (block_diagonal' M)ᴴ = block_diagonal' (λ k, (M k)ᴴ) :=
begin
  simp only [conj_transpose, block_diagonal'_transpose],
  exact block_diagonal'_map _ star (star_zero α),
end

@[simp] lemma block_diagonal'_zero :
  block_diagonal' (0 : Π i, matrix (m' i) (n' i) α) = 0 :=
by { ext, simp [block_diagonal'_apply] }

@[simp] lemma block_diagonal'_diagonal [Π i, decidable_eq (m' i)] (d : Π i, m' i → α) :
  block_diagonal' (λ k, diagonal (d k)) = diagonal (λ ik, d ik.1 ik.2) :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal'_apply, diagonal],
  obtain rfl | hij := decidable.eq_or_ne i j,
  { simp, },
  { simp [hij] },
end

@[simp] lemma block_diagonal'_one [∀ i, decidable_eq (m' i)] [has_one α] :
  block_diagonal' (1 : Π i, matrix (m' i) (m' i) α) = 1 :=
show block_diagonal' (λ (i : o), diagonal (λ (_ : m' i), (1 : α))) = diagonal (λ _, 1),
by rw [block_diagonal'_diagonal]

end has_zero

@[simp] lemma block_diagonal'_add [add_zero_class α] (M N : Π i, matrix (m' i) (n' i) α) :
  block_diagonal' (M + N) = block_diagonal' M + block_diagonal' N :=
begin
  ext,
  simp only [block_diagonal'_apply, pi.add_apply],
  split_ifs; simp
end

section
variables (m' n' α)
/-- `matrix.block_diagonal'` as an `add_monoid_hom`. -/
@[simps] def block_diagonal'_add_monoid_hom [add_zero_class α] :
  (Π i, matrix (m' i) (n' i) α) →+ matrix (Σ i, m' i) (Σ i, n' i) α :=
{ to_fun := block_diagonal',
  map_zero' := block_diagonal'_zero,
  map_add' := block_diagonal'_add }
end

@[simp]

@[simp] lemma block_diagonal'_sub [add_group α] (M N : Π i, matrix (m' i) (n' i) α) :
  block_diagonal' (M - N) = block_diagonal' M - block_diagonal' N :=
map_sub (block_diagonal'_add_monoid_hom m' n' α) M N

@[simp] lemma block_diagonal'_mul [non_unital_non_assoc_semiring α]
  [Π i, fintype (n' i)] [fintype o]
  (M : Π i, matrix (m' i) (n' i) α) (N : Π i, matrix (n' i) (p' i) α) :
  block_diagonal' (λ k, M k ⬝ N k) = block_diagonal' M ⬝ block_diagonal' N :=
begin
  ext ⟨k, i⟩ ⟨k', j⟩,
  simp only [block_diagonal'_apply, mul_apply, ← finset.univ_sigma_univ, finset.sum_sigma],
  rw fintype.sum_eq_single k,
  { split_ifs; simp },
  { intros j' hj', exact finset.sum_eq_zero (λ _ _, by rw [dif_neg hj'.symm, zero_mul]) },
end

section
variables (α m')
/-- `matrix.block_diagonal'` as a `ring_hom`. -/
@[simps]
def block_diagonal'_ring_hom [Π i, decidable_eq (m' i)] [fintype o] [Π i, fintype (m' i)]
  [non_assoc_semiring α] :
  (Π i, matrix (m' i) (m' i) α) →+* matrix (Σ i, m' i) (Σ i, m' i) α :=
{ to_fun := block_diagonal',
  map_one' := block_diagonal'_one,
  map_mul' := block_diagonal'_mul,
  ..block_diagonal'_add_monoid_hom m' m' α }
end

@[simp] lemma block_diagonal'_pow [Π i, decidable_eq (m' i)] [fintype o] [Π i, fintype (m' i)]
  [semiring α] (M : Π i, matrix (m' i) (m' i) α) (n : ℕ)  :
  block_diagonal' (M ^ n) = block_diagonal' M ^ n :=
map_pow (block_diagonal'_ring_hom m' α) M n

@[simp] lemma block_diagonal'_smul {R : Type*} [semiring R] [add_comm_monoid α] [module R α]
  (x : R) (M : Π i, matrix (m' i) (n' i) α) : block_diagonal' (x • M) = x • block_diagonal' M :=
by { ext, simp only [block_diagonal'_apply, pi.smul_apply], split_ifs; simp }

end block_diagonal'

section block_diag'

/-- Extract a block from the diagonal of a block diagonal matrix.

This is the block form of `matrix.diag`, and the left-inverse of `matrix.block_diagonal'`. -/
def block_diag' (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) : matrix (m' k) (n' k) α
| i j := M ⟨k, i⟩ ⟨k, j⟩

lemma block_diag'_map (M : matrix (Σ i, m' i) (Σ i, n' i) α) (f : α → β) :
  block_diag' (M.map f) = λ k, (block_diag' M k).map f :=
rfl

@[simp] lemma block_diag'_transpose (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) :
  block_diag' Mᵀ k = (block_diag' M k)ᵀ :=
ext $ λ i j, rfl

@[simp] lemma block_diag'_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) :
  block_diag' Mᴴ k = (block_diag' M k)ᴴ :=
ext $ λ i j, rfl

section has_zero
variables [has_zero α] [has_zero β]

@[simp] lemma block_diag'_zero :
  block_diag' (0 : matrix (Σ i, m' i) (Σ i, n' i) α) = 0 :=
rfl

@[simp] lemma block_diag'_diagonal [decidable_eq o] [Π i, decidable_eq (m' i)]
  (d : (Σ i, m' i) → α) (k : o) :
  block_diag' (diagonal d) k = diagonal (λ i, d ⟨k, i⟩) :=
ext $ λ i j, begin
  obtain rfl | hij := decidable.eq_or_ne i j,
  { rw [block_diag', diagonal_apply_eq, diagonal_apply_eq] },
  { rw [block_diag', diagonal_apply_ne _ hij, diagonal_apply_ne _ (mt (λ h, _) hij)],
    cases h, refl },
end

@[simp] lemma block_diag'_block_diagonal' [decidable_eq o] (M : Π i, matrix (m' i) (n' i) α) :
  block_diag' (block_diagonal' M) = M :=
funext $ λ k, ext $ λ i j, block_diagonal'_apply_eq _ _ _ _

@[simp] lemma block_diag'_one [decidable_eq o] [Π i, decidable_eq (m' i)] [has_one α] :
  block_diag' (1 : matrix (Σ i, m' i) (Σ i, m' i) α) = 1 :=
funext $ block_diag'_diagonal _

end has_zero

@[simp] lemma block_diag'_add [add_zero_class α] (M N : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (M + N) = block_diag' M + block_diag' N :=
rfl

section
variables (m' n' α)
/-- `matrix.block_diag'` as an `add_monoid_hom`. -/
@[simps] def block_diag'_add_monoid_hom [add_zero_class α] :
  matrix (Σ i, m' i) (Σ i, n' i) α →+ Π i, matrix (m' i) (n' i) α :=
{ to_fun := block_diag',
  map_zero' := block_diag'_zero,
  map_add' := block_diag'_add }
end

@[simp] lemma block_diag'_neg [add_group α] (M : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (-M) = - block_diag' M :=
map_neg (block_diag'_add_monoid_hom m' n' α) M

@[simp] lemma block_diag'_sub [add_group α] (M N : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (M - N) = block_diag' M - block_diag' N :=
map_sub (block_diag'_add_monoid_hom m' n' α) M N

@[simp] lemma block_diag'_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : matrix (Σ i, m' i) (Σ i, n' i) α) : block_diag' (x • M) = x • block_diag' M :=
rfl

end block_diag'

end matrix


import data.real.basic

/-
Iranian Mathematical Olympiad 1998, problem 11

Let f₁, f₂, f₃ : ℝ → ℝ be functions such that

  a₁f₁ + a₂f₂ + a₃f₃

is monotonic for all a₁,a₂,a₃ ∈ ℝ. Prove that there exist c₁,c₂,c₃ ∈ ℝ, not all zero,
such that

  c₁f₁(x) + c₂f₂(x) + c₃f₃(x) = 0

for all x ∈ ℝ.
-/

theorem iran1998_q11
  (f₁ f₂ f₃ : ℝ -> ℝ)
  (hf : (∀a₁ a₂ a₃ : ℝ, monotone (λ x, a₁ * f₁ x + a₂ * f₂ x + a₃ * f₃ x))) :
  ∃c₁ c₂ c₃ : ℝ, (¬ (c₁ = 0 ∧ c₂ = 0 ∧ c₃ = 0) ∧
                  ∀ x, c₁ * f₁ x + c₂ * f₂ x + c₃ * f₃ x = 0) :=
begin
  sorry
end


import set_theory.cardinal.basic

open cardinal
open_locale cardinal

lemma set.countable_infinite_iff_nonempty_denumerable {α : Type*} {s : set α} :
  s.countable ∧ s.infinite ↔ nonempty (denumerable s) :=
begin
  rw [denumerable_iff, ← set.infinite_coe_iff, infinite_iff, ← le_aleph_0_iff_set_countable],
  exact ⟨λ h, le_antisymm h.1 h.2, λ h, ⟨by rw h, by rw h⟩⟩,
end


import category_theory.types
import help_functions
import set_category.colimits.Sum
import set_category.colimits.Coequalizer

import tactic.tidy

universes u v

namespace Pushout
open category_theory
     set
     classical
     help_functions
     sum
     Sum
     Coequalizer

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

def is_pushout  {X : Type v} [category X]
    {A B₁ B₂: X} (f : A ⟶ B₁) (g : A ⟶ B₂)
    (P : X) (p₁ : B₁ ⟶ P) (p₂ : B₂ ⟶ P)
    : Prop
    :=  p₁ ⊚ f = p₂ ⊚ g ∧
        Π (Q : X)
          (q₁ : B₁ ⟶ Q)
          (q₂ : B₂ ⟶ Q),
          q₁ ⊚ f = q₂ ⊚ g →
                (∃! h : P ⟶ Q,
                q₁ = h ⊚ p₁ ∧ q₂ = h ⊚ p₂)

lemma coequalizer_sum_is_pushout_cat
    {X : Type v} [category X]
    {A B₁ B₂: X} (f : A ⟶ B₁) (g : A ⟶ B₂)
    (S P : X) (s₁ : B₁ ⟶ S) (s₂ : B₂ ⟶ S)
    (p : S ⟶ P)
    (is_sm : is_sum S s₁ s₂)
    (is_coeq: is_coequalizer (s₁ ⊚ f) (s₂ ⊚ g) p):
    is_pushout f g P (p ⊚ s₁) (p ⊚ s₂)
    :=
    begin
        have comm : (p ⊚ s₁) ⊚ f = (p ⊚ s₂) ⊚ g :=
            by tidy,
        split,
        exact comm,
        intros Q q₁ q₂ qfg,
        have sm : _ := is_sm Q q₁ q₂,
        let s := some sm,
        have spec : q₁ = s ⊚ s₁ ∧ q₂ = s ⊚ s₂
            := (some_spec sm).1,
        have sf_sg : s ⊚ s₁ ⊚ f = s ⊚ s₂ ⊚ g :=
            calc (s ⊚ s₁) ⊚ f
                    = q₁ ⊚ f      : by rw ← spec.1
                ... = q₂ ⊚ g      : qfg
                ... = s ⊚ s₂ ⊚ g : by rw spec.2,
        have coeq : ∃! (h : P ⟶ Q), h ⊚ p = s
         := is_coeq.2 Q s (by tidy),

        let h := some coeq,
        have h_spec : s = h ⊚ p := eq.symm (some_spec coeq).1,

        use h,
        split,
        split,
        by simp [h_spec , spec.1],
        by simp [h_spec , spec.2],
        intros q spec_q,
        have h01 : q₁ = q ⊚ p ⊚ s₁ := by tidy,
        have h02 : q₂ = q ⊚ p ⊚ s₂ := by tidy,

        have q_s : q ⊚ p = s :=
                jointly_epi_cat s₁ s₂ is_sm (q ⊚ p) s
                    (spec.1 ▸ (eq.symm h01))
                    (spec.2 ▸ (eq.symm h02)),

        exact (some_spec coeq).2 q q_s
    end

variables   {A B₁ B₂: Type u}
            (f : A ⟶ B₁)
            (g : A ⟶ B₂)

lemma coequalizer_sum_is_pushout :
    let S := B₁ ⊕ B₂ in
    let B_Θ := @theta A S (inl ∘ f) (inr ∘ g) in
    let π_Θ := @coequalizer A S (inl ∘ f) (inr ∘ g) in
    is_pushout f g B_Θ (π_Θ ∘ inl) (π_Θ ∘ inr)
    :=
    begin
        intros S B_Θ π_Θ,
        have is_sm : _ := @disjoint_union_is_sum B₁ B₂,
        have is_coeq: _ := @quot_is_coequalizer A S (inl ∘ f) (inr ∘ g),
        have comm : (π_Θ ∘ inl) ∘ f = (π_Θ ∘ inr) ∘ g :=
            by tidy,
        split,
        exact comm,
        intros Q q₁ q₂ qfg,
        have sm : _ := is_sm Q q₁ q₂,
        let s := some sm,
        have spec : q₁ = s ∘ inl ∧ q₂ = s ∘ inr
            := (some_spec sm).1,
        have sf_sg : s ∘ inl ∘ f = s ∘ inr ∘ g :=
            calc (s ∘ inl) ∘ f
                    = q₁ ∘ f      : by rw ← spec.1
                ... = q₂ ∘ g      : qfg
                ... = s ∘ inr ∘ g : by rw spec.2,
        have coeq : ∃! (h : B_Θ → Q), h ∘ π_Θ = s
         := is_coeq.2 Q s sf_sg,

        let h := some coeq,
        have h_spec : s = h ∘ π_Θ := eq.symm (some_spec coeq).1,

        use h,
        split,
        split,
        by simp [h_spec , spec.1],
        by simp [h_spec , spec.2],
        intros q spec_q,
        have q_s : q ∘ π_Θ = s :=
                jointly_epi s (q ∘ π_Θ)
                    (spec.1 ▸ (eq.symm spec_q.1))
                    (spec.2 ▸ (eq.symm spec_q.2)),

        exact (some_spec coeq).2 q q_s
    end

end Pushout


/-
Copyright (c) 2021 Roberto Alvarez. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Roberto Alvarez

! This file was ported from Lean 3 source module topology.homotopy.homotopy_group
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicTopology.FundamentalGroupoid.FundamentalGroup

/-!
# `n`th homotopy group

We define the `n`th homotopy group at `x`, `π n x`, as the equivalence classes
of functions from the nth dimensional cube to the topological space `X`
that send the boundary to the base point `x`, up to homotopic equivalence.
Note that such functions are generalized loops `gen_loop n x`, in particular
`gen_loop 1 x ≃ path x x`

We show that `π 0 x` is equivalent to the path-conected components, and
that `π 1 x` is equivalent to the fundamental group at `x`.

## definitions

* `gen_loop n x` is the type of continous fuctions `I^n → X` that send the boundary to `x`
* `homotopy_group n x` denoted `π n x` is the quotient of `gen_loop n x` by homotopy relative
  to the boundary

TODO: show that `π n x` is a group when `n > 0` and abelian when `n > 1`. Show that
`pi1_equiv_fundamental_group` is an isomorphism of groups.

-/

open unitInterval Topology

noncomputable section

universe u

variable {X : Type u} [TopologicalSpace X]

variable {n : ℕ} {x : X}

/-- The `n`-dimensional cube.
-/
def Cube (n : ℕ) : Type :=
  Fin n → I deriving Zero, One, TopologicalSpace
#align cube Cube

-- mathport name: «exprI^»
local notation "I^" => Cube

namespace Cube

@[continuity]
theorem proj_continuous (i : Fin n) : Continuous fun f : I^ n => f i :=
  continuous_apply i
#align cube.proj_continuous Cube.proj_continuous

/-- The points of the `n`-dimensional cube with at least one projection equal to 0 or 1.
-/
def boundary (n : ℕ) : Set (I^ n) :=
  { y | ∃ i, y i = 0 ∨ y i = 1 }
#align cube.boundary Cube.boundary

/-- The first projection of a positive-dimensional cube.
-/
@[simp]
def head {n} : I^ (n + 1) → I := fun c => c 0
#align cube.head Cube.head

@[continuity]
theorem head.continuous {n} : Continuous (@head n) :=
  proj_continuous 0
#align cube.head.continuous Cube.head.continuous

/-- The projection to the last `n` coordinates from an `n+1` dimensional cube.
-/
@[simp]
def tail {n} : I^ (n + 1) → I^ n := fun c => Fin.tail c
#align cube.tail Cube.tail

instance uniqueCube0 : Unique (I^ 0) :=
  Pi.uniqueOfIsEmpty _
#align cube.unique_cube0 Cube.uniqueCube0

theorem one_char (f : I^ 1) : f = fun _ => f 0 := by convert eq_const_of_unique f
#align cube.one_char Cube.one_char

end Cube

/--
The `n`-dimensional generalized loops; functions `I^n → X` that send the boundary to the base point.
-/
structure GenLoop (n : ℕ) (x : X) extends C(I^ n, X) where
  boundary : ∀ y ∈ Cube.boundary n, to_fun y = x
#align gen_loop GenLoop

namespace GenLoop

instance funLike : FunLike (GenLoop n x) (I^ n) fun _ => X
    where
  coe f := f.1
  coe_injective' := fun ⟨⟨f, _⟩, _⟩ ⟨⟨g, _⟩, _⟩ h =>
    by
    congr
    exact h
#align gen_loop.fun_like GenLoop.funLike

@[ext]
theorem ext (f g : GenLoop n x) (H : ∀ y, f y = g y) : f = g :=
  FunLike.ext f g H
#align gen_loop.ext GenLoop.ext

@[simp]
theorem mk_apply (f : C(I^ n, X)) (H y) : (⟨f, H⟩ : GenLoop n x) y = f y :=
  rfl
#align gen_loop.mk_apply GenLoop.mk_apply

/-- The constant `gen_loop` at `x`.
-/
def const : GenLoop n x :=
  ⟨ContinuousMap.const _ x, fun _ _ => rfl⟩
#align gen_loop.const GenLoop.const

instance inhabited : Inhabited (GenLoop n x) where default := const
#align gen_loop.inhabited GenLoop.inhabited

/-- The "homotopy relative to boundary" relation between `gen_loop`s.
-/
def Homotopic (f g : GenLoop n x) : Prop :=
  f.toContinuousMap.HomotopicRel g.toContinuousMap (Cube.boundary n)
#align gen_loop.homotopic GenLoop.Homotopic

namespace Homotopic

section

variable {f g h : GenLoop n x}

@[refl]
theorem refl (f : GenLoop n x) : Homotopic f f :=
  ContinuousMap.HomotopicRel.refl _
#align gen_loop.homotopic.refl GenLoop.Homotopic.refl

@[symm]
theorem symm (H : f.Homotopic g) : g.Homotopic f :=
  H.symm
#align gen_loop.homotopic.symm GenLoop.Homotopic.symm

@[trans]
theorem trans (H0 : f.Homotopic g) (H1 : g.Homotopic h) : f.Homotopic h :=
  H0.trans H1
#align gen_loop.homotopic.trans GenLoop.Homotopic.trans

theorem equiv : Equivalence (@Homotopic X _ n x) :=
  ⟨Homotopic.refl, fun _ _ => Homotopic.symm, fun _ _ _ => Homotopic.trans⟩
#align gen_loop.homotopic.equiv GenLoop.Homotopic.equiv

instance setoid (n : ℕ) (x : X) : Setoid (GenLoop n x) :=
  ⟨Homotopic, equiv⟩
#align gen_loop.homotopic.setoid GenLoop.Homotopic.setoid

end

end Homotopic

end GenLoop

/-- The `n`th homotopy group at `x` defined as the quotient of `gen_loop n x` by the
`homotopic` relation.
-/
def HomotopyGroup (n : ℕ) (x : X) : Type _ :=
  Quotient (GenLoop.Homotopic.setoid n x)deriving Inhabited
#align homotopy_group HomotopyGroup

-- mathport name: exprπ
local notation "π" => HomotopyGroup

/-- The 0-dimensional generalized loops based at `x` are in 1-1 correspondence with `X`. -/
def genLoopZeroEquiv : GenLoop 0 x ≃ X where
  toFun f := f 0
  invFun x := ⟨ContinuousMap.const _ x, fun _ ⟨f0, _⟩ => f0.elim0ₓ⟩
  left_inv f := by
    ext1
    exact congr_arg f (Subsingleton.elim _ _)
  right_inv _ := rfl
#align gen_loop_zero_equiv genLoopZeroEquiv

/-- The 0th homotopy "group" is equivalent to the path components of `X`, aka the `zeroth_homotopy`.
-/
def pi0EquivPathComponents : π 0 x ≃ ZerothHomotopy X :=
  Quotient.congr genLoopZeroEquiv
    (by
      -- joined iff homotopic
      intros ;
      constructor <;> rintro ⟨H⟩
      exacts[⟨{
            toFun := fun t => H ⟨t, Fin.elim0⟩
            source' := (H.apply_zero _).trans (congr_arg a₁ matrix.zero_empty.symm)
            target' := (H.apply_one _).trans (congr_arg a₂ matrix.zero_empty.symm) }⟩,
        ⟨{  toFun := fun t0 => H t0.fst
            map_zero_left' := fun _ => by convert H.source
            map_one_left' := fun _ => by convert H.target
            prop' := fun _ _ ⟨i, _⟩ => i.elim0ₓ }⟩])
#align pi0_equiv_path_components pi0EquivPathComponents

/-- The 1-dimensional generalized loops based at `x` are in 1-1 correspondence with
  paths from `x` to itself. -/
@[simps]
def genLoopOneEquivPathSelf : GenLoop 1 x ≃ Path x x
    where
  toFun p :=
    Path.mk
      ⟨fun t => p fun _ => t, by
        continuity
        exact p.1.2⟩
      (p.boundary (fun _ => 0) ⟨0, Or.inl rfl⟩) (p.boundary (fun _ => 1) ⟨1, Or.inr rfl⟩)
  invFun p :=
    { toFun := fun c => p c.headI
      boundary :=
        by
        rintro y ⟨i, iH | iH⟩ <;> cases Unique.eq_default i <;> apply (congr_arg p iH).trans
        exacts[p.source, p.target] }
  left_inv p := by
    ext1
    exact congr_arg p y.one_char.symm
  right_inv p := by
    ext
    rfl
#align gen_loop_one_equiv_path_self genLoopOneEquivPathSelf

/-- The first homotopy group at `x` is equivalent to the fundamental group,
i.e. the loops based at `x` up to homotopy.
-/
def pi1EquivFundamentalGroup : π 1 x ≃ FundamentalGroup X x :=
  by
  refine' Equiv.trans _ (CategoryTheory.Groupoid.isoEquivHom _ _).symm
  refine' Quotient.congr genLoopOneEquivPathSelf _
  -- homotopic iff homotopic
  intros ;
  constructor <;> rintro ⟨H⟩
  exacts[⟨{
        toFun := fun tx => H (tx.fst, fun _ => tx.snd)
        map_zero_left' := fun _ => by convert H.apply_zero _
        map_one_left' := fun _ => by convert H.apply_one _
        prop' := fun t y iH => H.prop' _ _ ⟨0, iH⟩ }⟩,
    ⟨{  toFun := fun tx => H (tx.fst, tx.snd.head)
        map_zero_left' := fun y => by
          convert H.apply_zero _
          exact y.one_char
        map_one_left' := fun y => by
          convert H.apply_one _
          exact y.one_char
        prop' := fun t y ⟨i, iH⟩ => by
          cases Unique.eq_default i; constructor
          · convert H.eq_fst _ _
            exacts[y.one_char, iH]
          · convert H.eq_snd _ _
            exacts[y.one_char, iH] }⟩]
#align pi1_equiv_fundamental_group pi1EquivFundamentalGroup


/-
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
-/
import analysis.convex.strict_convex_space

/-!
# Uniformly convex spaces

This file defines uniformly convex spaces, which are real normed vector spaces in which for all
strictly positive `ε`, there exists some strictly positive `δ` such that `ε ≤ ∥x - y∥` implies
`∥x + y∥ ≤ 2 - δ` for all `x` and `y` of norm at most than `1`. This means that the triangle
inequality is strict with a uniform bound, as opposed to strictly convex spaces where the triangle
inequality is strict but not necessarily uniformly (`∥x + y∥ < ∥x∥ + ∥y∥` for all `x` and `y` not in
the same ray).

## Main declarations

`uniform_convex_space E` means that `E` is a uniformly convex space.

## TODO

* Milman-Pettis
* Hanner's inequalities

## Tags

convex, uniformly convex
-/

open set metric
open_locale convex pointwise

/-- A *uniformly convex space* is a real normed space where the triangle inequality is strict with a
uniform bound. Namely, over the `x` and `y` of norm `1`, `∥x + y∥` is uniformly bounded above
by a constant `< 2` when `∥x - y∥` is uniformly bounded below by a positive constant.

See also `uniform_convex_space.of_uniform_convex_closed_unit_ball`. -/
class uniform_convex_space (E : Type*) [semi_normed_group E] : Prop :=
(uniform_convex : ∀ ⦃ε : ℝ⦄, 0 < ε → ∃ δ, 0 < δ ∧
  ∀ ⦃x : E⦄, ∥x∥ = 1 → ∀ ⦃y⦄, ∥y∥ = 1 → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 - δ)

variables {E : Type*}

section semi_normed_group
variables (E) [semi_normed_group E] [uniform_convex_space E] {ε : ℝ}

lemma exists_forall_sphere_dist_add_le_two_sub (hε : 0 < ε) :
  ∃ δ, 0 < δ ∧ ∀ ⦃x : E⦄, ∥x∥ = 1 → ∀ ⦃y⦄, ∥y∥ = 1 → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 - δ :=
uniform_convex_space.uniform_convex hε

variables [normed_space ℝ E]

lemma exists_forall_closed_ball_dist_add_le_two_sub (hε : 0 < ε) :
  ∃ δ, 0 < δ ∧ ∀ ⦃x : E⦄, ∥x∥ ≤ 1 → ∀ ⦃y⦄, ∥y∥ ≤ 1 → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 - δ :=
begin
  have hε' : 0 < ε / 3 := div_pos hε zero_lt_three,
  obtain ⟨δ, hδ, h⟩ := exists_forall_sphere_dist_add_le_two_sub E hε',
  set δ' := min (1/2) (min (ε/3) $ δ/3),
  refine ⟨δ', lt_min one_half_pos $ lt_min hε' (div_pos hδ zero_lt_three), λ x hx y hy hxy, _⟩,
  obtain hx' | hx' := le_or_lt (∥x∥) (1 - δ'),
  { exact (norm_add_le_of_le hx' hy).trans (sub_add_eq_add_sub _ _ _).le },
  obtain hy' | hy' := le_or_lt (∥y∥) (1 - δ'),
  { exact (norm_add_le_of_le hx hy').trans (add_sub_assoc _ _ _).ge },
  have hδ' : 0 < 1 - δ' := sub_pos_of_lt  (min_lt_of_left_lt one_half_lt_one),
  have h₁ : ∀ z : E, 1 - δ' < ∥z∥ → ∥∥z∥⁻¹ • z∥ = 1,
  { rintro z hz,
    rw [norm_smul_of_nonneg (inv_nonneg.2 $ norm_nonneg _), inv_mul_cancel (hδ'.trans hz).ne'] },
  have h₂ : ∀ z : E, ∥z∥ ≤ 1 → 1 - δ' ≤ ∥z∥ → ∥∥z∥⁻¹ • z - z∥ ≤ δ',
  { rintro z hz hδz,
    nth_rewrite 2 ←one_smul ℝ z,
    rwa [←sub_smul, norm_smul_of_nonneg (sub_nonneg_of_le $ one_le_inv (hδ'.trans_le hδz) hz),
      sub_mul, inv_mul_cancel (hδ'.trans_le hδz).ne', one_mul, sub_le] },
  set x' := ∥x∥⁻¹ • x,
  set y' := ∥y∥⁻¹ • y,
  have hxy' : ε/3 ≤ ∥x' - y'∥ :=
  calc ε/3 = ε - (ε/3 + ε/3) : by ring
    ... ≤ ∥x - y∥ - (∥x' - x∥ + ∥y' - y∥) : sub_le_sub hxy (add_le_add
          ((h₂ _ hx hx'.le).trans $ min_le_of_right_le $ min_le_left _ _) $
          (h₂ _ hy hy'.le).trans $ min_le_of_right_le $ min_le_left _ _)
    ... ≤ _ : begin
        have : ∀ x' y', x - y = x' - y' + (x - x') + (y' - y) := λ _ _, by abel,
        rw [sub_le_iff_le_add, norm_sub_rev _ x, ←add_assoc, this],
        exact norm_add₃_le _ _ _,
      end,
  calc ∥x + y∥ ≤ ∥x' + y'∥ + ∥x' - x∥ + ∥y' - y∥ : begin
        have : ∀ x' y', x + y = x' + y' + (x - x') + (y - y') := λ _ _, by abel,
        rw [norm_sub_rev, norm_sub_rev y', this],
        exact norm_add₃_le _ _ _,
      end
    ... ≤ 2 - δ + δ' + δ'
        : add_le_add_three (h (h₁ _ hx') (h₁ _ hy') hxy') (h₂ _ hx hx'.le) (h₂ _ hy hy'.le)
    ... ≤ 2 - δ' : begin
        rw [←le_sub_iff_add_le, ←le_sub_iff_add_le, sub_sub, sub_sub],
        refine sub_le_sub_left _ _,
        ring_nf,
        rw ←mul_div_cancel' δ three_ne_zero,
        exact mul_le_mul_of_nonneg_left (min_le_of_right_le $ min_le_right _ _) three_pos.le,
      end,
end

lemma exists_forall_closed_ball_dist_add_le_two_mul_sub (hε : 0 < ε) (r : ℝ) :
  ∃ δ, 0 < δ ∧ ∀ ⦃x : E⦄, ∥x∥ ≤ r → ∀ ⦃y⦄, ∥y∥ ≤ r → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 * r - δ :=
begin
  obtain hr | hr := le_or_lt r 0,
  { exact ⟨1, one_pos, λ x hx y hy h, (hε.not_le $ h.trans $ (norm_sub_le _ _).trans $
     add_nonpos (hx.trans hr) (hy.trans hr)).elim⟩ },
  obtain ⟨δ, hδ, h⟩ := exists_forall_closed_ball_dist_add_le_two_sub E (div_pos hε hr),
  refine ⟨δ * r, mul_pos hδ hr, λ x hx y hy hxy, _⟩,
  rw [←div_le_one hr, div_eq_inv_mul, ←norm_smul_of_nonneg (inv_nonneg.2 hr.le)] at hx hy;
    try { apply_instance },
  have := h hx hy,
  simp_rw [←smul_add, ←smul_sub, norm_smul_of_nonneg (inv_nonneg.2 hr.le), ←div_eq_inv_mul,
    div_le_div_right hr, div_le_iff hr, sub_mul] at this,
  exact this hxy,
end

end semi_normed_group

variables [normed_group E] [normed_space ℝ E] [uniform_convex_space E]

@[priority 100] -- See note [lower instance priority]
instance uniform_convex_space.to_strict_convex_space : strict_convex_space ℝ E :=
strict_convex_space.of_norm_add_lt one_half_pos one_half_pos (add_halves _) $ λ x y hx hy hxy, begin
  obtain ⟨δ, hδ, h⟩ := exists_forall_closed_ball_dist_add_le_two_sub E (norm_sub_pos_iff.2 hxy),
  rw [←smul_add, norm_smul_of_nonneg one_half_pos.le, ←lt_div_iff' one_half_pos, one_div_one_div],
  exact (h hx hy le_rfl).trans_lt (sub_lt_self _ hδ),
end