/-
Copyright (c) 2020 Thomas Browning, Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz

! This file was ported from Lean 3 source module field_theory.primitive_element
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.FieldTheory.Adjoin
import Mathbin.FieldTheory.IsAlgClosed.Basic
import Mathbin.FieldTheory.Separable
import Mathbin.RingTheory.IntegralDomain

/-!
# Primitive Element Theorem

In this file we prove the primitive element theorem.

## Main results

- `exists_primitive_element`: a finite separable extension `E / F` has a primitive element, i.e.
  there is an `α : E` such that `F⟮α⟯ = (⊤ : subalgebra F E)`.

## Implementation notes

In declaration names, `primitive_element` abbreviates `adjoin_simple_eq_top`:
it stands for the statement `F⟮α⟯ = (⊤ : subalgebra F E)`. We did not add an extra
declaration `is_primitive_element F α := F⟮α⟯ = (⊤ : subalgebra F E)` because this
requires more unfolding without much obvious benefit.

## Tags

primitive element, separable field extension, separable extension, intermediate field, adjoin,
exists_adjoin_simple_eq_top

-/

noncomputable section

open Classical Polynomial

open FiniteDimensional Polynomial IntermediateField

namespace Field

section PrimitiveElementFinite

variable (F : Type _) [Field F] (E : Type _) [Field E] [Algebra F E]

/-! ### Primitive element theorem for finite fields -/

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/-- **Primitive element theorem** assuming E is finite. -/
theorem exists_primitive_element_of_finite_top [Finite E] : ∃ α : E, F⟮⟯ = ⊤ :=
  by
  obtain ⟨α, hα⟩ := IsCyclic.exists_generator (Units E)
  use α
  apply eq_top_iff.mpr
  rintro x -
  by_cases hx : x = 0
  · rw [hx]
    exact F⟮⟯.zero_mem
  · obtain ⟨n, hn⟩ := set.mem_range.mp (hα (Units.mk0 x hx))
    rw [show x = α ^ n by
        norm_cast
        rw [hn, Units.val_mk0]]
    exact zpow_mem (mem_adjoin_simple_self F ↑α) n
#align field.exists_primitive_element_of_finite_top Field.exists_primitive_element_of_finite_top

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/-- Primitive element theorem for finite dimensional extension of a finite field. -/
theorem exists_primitive_element_of_finite_bot [Finite F] [FiniteDimensional F E] :
    ∃ α : E, F⟮⟯ = ⊤ :=
  haveI : Finite E := finite_of_finite F E
  exists_primitive_element_of_finite_top F E
#align field.exists_primitive_element_of_finite_bot Field.exists_primitive_element_of_finite_bot

end PrimitiveElementFinite

/-! ### Primitive element theorem for infinite fields -/

section PrimitiveElementInf

variable {F : Type _} [Field F] [Infinite F] {E : Type _} [Field E] (ϕ : F →+* E) (α β : E)

theorem primitive_element_inf_aux_exists_c (f g : F[X]) :
    ∃ c : F, ∀ α' ∈ (f.map ϕ).roots, ∀ β' ∈ (g.map ϕ).roots, -(α' - α) / (β' - β) ≠ ϕ c :=
  by
  let sf := (f.map ϕ).roots
  let sg := (g.map ϕ).roots
  let s := (sf.bind fun α' => sg.map fun β' => -(α' - α) / (β' - β)).toFinset
  let s' := s.preimage ϕ fun x hx y hy h => ϕ.injective h
  obtain ⟨c, hc⟩ := Infinite.exists_not_mem_finset s'
  simp_rw [Finset.mem_preimage, Multiset.mem_toFinset, Multiset.mem_bind, Multiset.mem_map] at hc
  push_neg  at hc
  exact ⟨c, hc⟩
#align field.primitive_element_inf_aux_exists_c Field.primitive_element_inf_aux_exists_c

variable (F) [Algebra F E]

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
-- This is the heart of the proof of the primitive element theorem. It shows that if `F` is
-- infinite and `α` and `β` are separable over `F` then `F⟮α, β⟯` is generated by a single element.
theorem primitive_element_inf_aux [IsSeparable F E] : ∃ γ : E, F⟮⟯ = F⟮⟯ :=
  by
  have hα := IsSeparable.isIntegral F α
  have hβ := IsSeparable.isIntegral F β
  let f := minpoly F α
  let g := minpoly F β
  let ιFE := algebraMap F E
  let ιEE' := algebraMap E (splitting_field (g.map ιFE))
  obtain ⟨c, hc⟩ := primitive_element_inf_aux_exists_c (ιEE'.comp ιFE) (ιEE' α) (ιEE' β) f g
  let γ := α + c • β
  suffices β_in_Fγ : β ∈ F⟮⟯
  · use γ
    apply le_antisymm
    · rw [adjoin_le_iff]
      have α_in_Fγ : α ∈ F⟮⟯ := by
        rw [← add_sub_cancel α (c • β)]
        exact F⟮⟯.sub_mem (mem_adjoin_simple_self F γ) (F⟮⟯.toSubalgebra.smul_mem β_in_Fγ c)
      exact fun x hx => by cases hx <;> cases hx <;> cases hx <;> assumption
    · rw [adjoin_simple_le_iff]
      have α_in_Fαβ : α ∈ F⟮⟯ := subset_adjoin F {α, β} (Set.mem_insert α {β})
      have β_in_Fαβ : β ∈ F⟮⟯ := subset_adjoin F {α, β} (Set.mem_insert_of_mem α rfl)
      exact F⟮⟯.add_mem α_in_Fαβ (F⟮⟯.smul_mem β_in_Fαβ)
  let p :=
    EuclideanDomain.gcd ((f.map (algebraMap F F⟮⟯)).comp (C (adjoin_simple.gen F γ) - C ↑c * X))
      (g.map (algebraMap F F⟮⟯))
  let h := EuclideanDomain.gcd ((f.map ιFE).comp (C γ - C (ιFE c) * X)) (g.map ιFE)
  have map_g_ne_zero : g.map ιFE ≠ 0 := map_ne_zero (minpoly.ne_zero hβ)
  have h_ne_zero : h ≠ 0 :=
    mt euclidean_domain.gcd_eq_zero_iff.mp (not_and.mpr fun _ => map_g_ne_zero)
  suffices p_linear : p.map (algebraMap F⟮⟯ E) = C h.leading_coeff * (X - C β)
  · have finale : β = algebraMap F⟮⟯ E (-p.coeff 0 / p.coeff 1) :=
      by
      rw [map_div₀, RingHom.map_neg, ← coeff_map, ← coeff_map, p_linear]
      simp [mul_sub, coeff_C, mul_div_cancel_left β (mt leading_coeff_eq_zero.mp h_ne_zero)]
    rw [finale]
    exact Subtype.mem (-p.coeff 0 / p.coeff 1)
  have h_sep : h.separable := separable_gcd_right _ (IsSeparable.separable F β).map
  have h_root : h.eval β = 0 := by
    apply eval_gcd_eq_zero
    ·
      rw [eval_comp, eval_sub, eval_mul, eval_C, eval_C, eval_X, eval_map, ← aeval_def, ←
        Algebra.smul_def, add_sub_cancel, minpoly.aeval]
    · rw [eval_map, ← aeval_def, minpoly.aeval]
  have h_splits : splits ιEE' h :=
    splits_of_splits_gcd_right ιEE' map_g_ne_zero (splitting_field.splits _)
  have h_roots : ∀ x ∈ (h.map ιEE').roots, x = ιEE' β :=
    by
    intro x hx
    rw [mem_roots_map h_ne_zero] at hx
    specialize
      hc (ιEE' γ - ιEE' (ιFE c) * x)
        (by
          have f_root := root_left_of_root_gcd hx
          rw [eval₂_comp, eval₂_sub, eval₂_mul, eval₂_C, eval₂_C, eval₂_X, eval₂_map] at f_root
          exact (mem_roots_map (minpoly.ne_zero hα)).mpr f_root)
    specialize
      hc x
        (by
          rw [mem_roots_map (minpoly.ne_zero hβ), ← eval₂_map]
          exact root_right_of_root_gcd hx)
    by_contra a
    apply hc
    apply (div_eq_iff (sub_ne_zero.mpr a)).mpr
    simp only [Algebra.smul_def, RingHom.map_add, RingHom.map_mul, RingHom.comp_apply]
    ring
  rw [← eq_X_sub_C_of_separable_of_root_eq h_sep h_root h_splits h_roots]
  trans EuclideanDomain.gcd (_ : E[X]) (_ : E[X])
  · dsimp only [p]
    convert(gcd_map (algebraMap F⟮⟯ E)).symm
  · simpa [map_comp, Polynomial.map_map, ← IsScalarTower.algebraMap_eq, h]
#align field.primitive_element_inf_aux Field.primitive_element_inf_aux

end PrimitiveElementInf

variable (F E : Type _) [Field F] [Field E]

variable [Algebra F E] [FiniteDimensional F E]

section SeparableAssumption

variable [IsSeparable F E]

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/-- Primitive element theorem: a finite separable field extension `E` of `F` has a
  primitive element, i.e. there is an `α ∈ E` such that `F⟮α⟯ = (⊤ : subalgebra F E)`.-/
theorem exists_primitive_element : ∃ α : E, F⟮⟯ = ⊤ :=
  by
  rcases isEmpty_or_nonempty (Fintype F) with (F_inf | ⟨⟨F_finite⟩⟩)
  · let P : IntermediateField F E → Prop := fun K => ∃ α : E, F⟮⟯ = K
    have base : P ⊥ := ⟨0, adjoin_zero⟩
    have ih : ∀ (K : IntermediateField F E) (x : E), P K → P (K⟮⟯.restrictScalars F) :=
      by
      intro K β hK
      cases' hK with α hK
      rw [← hK, adjoin_simple_adjoin_simple]
      haveI : Infinite F := is_empty_fintype.mp F_inf
      cases' primitive_element_inf_aux F α β with γ hγ
      exact ⟨γ, hγ.symm⟩
    exact induction_on_adjoin P base ih ⊤
  · exact exists_primitive_element_of_finite_bot F E
#align field.exists_primitive_element Field.exists_primitive_element

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/-- Alternative phrasing of primitive element theorem:
a finite separable field extension has a basis `1, α, α^2, ..., α^n`.

See also `exists_primitive_element`. -/
noncomputable def powerBasisOfFiniteOfSeparable : PowerBasis F E :=
  let α := (exists_primitive_element F E).some
  let pb := adjoin.powerBasis (IsSeparable.isIntegral F α)
  have e : F⟮⟯ = ⊤ := (exists_primitive_element F E).choose_spec
  pb.map ((IntermediateField.equivOfEq e).trans IntermediateField.topEquiv)
#align field.power_basis_of_finite_of_separable Field.powerBasisOfFiniteOfSeparable

end SeparableAssumption

end Field

@[simp]
theorem AlgHom.card (F E K : Type _) [Field F] [Field E] [Field K] [IsAlgClosed K] [Algebra F E]
    [FiniteDimensional F E] [IsSeparable F E] [Algebra F K] :
    Fintype.card (E →ₐ[F] K) = finrank F E :=
  by
  convert(AlgHom.card_of_powerBasis (Field.powerBasisOfFiniteOfSeparable F E)
          (IsSeparable.separable _ _) (IsAlgClosed.splits_codomain _)).trans
      (PowerBasis.finrank _).symm
  infer_instance
#align alg_hom.card AlgHom.card


import data.int.basic
import data.int.modeq
import data.int.order
import algebra.group_power
import tactic.ring
import chris_hughes_various.zmod
open nat

--#check int.le
--theorem l_to_le {a b : ℤ} (hab : a < b) : a ≤ b := begin
--unfold has_le.le,
--unfold int.le,
--have h1 : b < b+1, by lt_succ_self b,
--end

definition prime_int (p : ℤ) := nat.prime(int.nat_abs p)
theorem prime_int_to_nat {p : ℤ} (h : prime_int p) : prime (int.nat_abs p) := sorry

definition quadratic_res (a n : ℤ) := ∃ x : ℤ, a ≡ x^2 [ZMOD (int.nat_abs n)]
--definition quadratic_res' (p : ℤ) (hp : prime_int_int p ∧ p ≠ 2) (a n : zmod p) := ∃ x : ℕ, a ≡ x^2 [ZMOD n]

attribute [instance, priority 0] classical.prop_decidable
noncomputable definition legendre_sym {p : ℤ} (a : ℤ) (H1 : prime_int p ∧ p ≠ 2) : ℤ :=
if quadratic_res a p ∧ ¬ ((p : ℤ) ∣ a) then 1 else
if ¬ quadratic_res a p then -1
else 0

-- lemmas

lemma legendre_strong_mul {p : ℤ} (a b : ℤ) (H1 : prime_int p ∧ p ≠ 2) : legendre_sym (a*b) H1 = (legendre_sym a H1) * (legendre_sym b H1)  := sorry

lemma if_cong_legendre_eq {p : ℤ} (a b : ℤ) (H1 : prime_int p ∧ p ≠ 2) : a % p = b → legendre_sym a H1 = legendre_sym b H1 := sorry

lemma euler_criterion {p : ℤ} (a : ℤ) (H1 : prime_int p ∧ p ≠ 2) : legendre_sym a H1 = a^(int.nat_abs p-1) % p := sorry

theorem legendre_sym_one_implies_quadratic_res {p : ℤ} (a : ℤ)(H1 : prime_int p ∧ p ≠ 2): legendre_sym a H1 = 1 → quadratic_res a p :=
begin
intro h,
unfold legendre_sym at h,
split_ifs at h,
exact h_1.1,
exfalso,
revert h, norm_num,
revert h, norm_num,
end

theorem minus_one_quad_res_of_p {p : ℤ} (hp : prime_int p ∧ p ≠ 2) : (p ≡ 1 [ZMOD 4] ↔ (legendre_sym (-1: ℤ) hp) = 1) ∧ (p ≡ 3 [ZMOD 4] ↔ legendre_sym (-1 : ℤ) hp = (-1 : ℤ)) := sorry

definition is_sum_of_two_squares (n : ℕ) := ∃ x y : ℤ, (n : ℤ) =  x ^ 2 + y ^ 2

theorem is_sum_of_two_squares_mul (m n : ℕ) : is_sum_of_two_squares m ∧ is_sum_of_two_squares n → is_sum_of_two_squares (m * n) :=
begin
intro h,
unfold is_sum_of_two_squares,
unfold is_sum_of_two_squares at h,
rcases h with ⟨⟨a, b, hab⟩, ⟨c, d, hcd⟩⟩,
existsi [a * c - b * d, a * d + b * c],
rw int.coe_nat_mul, rw hab, rw hcd,
ring,
end

theorem one_mod_four_prime (p : ℤ)(h : prime_int p ∧ p ≠ 2) : p ^ 2 ≡  1 [ZMOD 4] := sorry

theorem fermat_descent (p : ℤ)(h : prime_int p ∧ p ≠ 2) : ∃ a b r : ℤ, (a ^ 2 + b ^ 2 = p * r) ∧ (1 < r) ∧ (r < p) → ∃ x y r' : ℤ, (1 ≤ r') ∧ (r'< r) ∧ (x ^ 2 + y ^ 2 = p * r') :=
begin
sorry
end

theorem fermat_two_square (p : ℤ)(h : prime_int p ∧ p ≠ 2)(H: p ≥ 0) : p ≡ 1 [ZMOD 4] → is_sum_of_two_squares (int.nat_abs p) :=
begin
intro hpp,
have b1 := (minus_one_quad_res_of_p h).1.1,
have b2 := b1 hpp,
have b3 := legendre_sym_one_implies_quadratic_res (-1) h b2,
unfold quadratic_res at b3,
rcases b3 with x,
let y := x % ↑(int.nat_abs p),
have b3_hh : -1 ≡ y ^ 2 [ZMOD ↑(int.nat_abs p)],
begin
haveI : pos_nat p.nat_abs := sorry,
rw ← zmod.eq_iff_modeq_int,
rw ← zmod.eq_iff_modeq_int at b3_h,
have : x ≡ y [ZMOD ↑(p.nat_abs)],
exact (int.mod_mod x p.nat_abs).symm,
rw ← zmod.eq_iff_modeq_int at this,
rw int.cast_pow at b3_h,
rw int.cast_pow,
exact eq.subst this b3_h,
end,
have b4 : 1 ≡ 1 [ZMOD ↑(int.nat_abs p)], by refl,
have b5 := int.modeq.modeq_add b3_hh b4,
have b6 : (-1 :ℤ) + 1 = 0, by simp,
rw b6 at b5,
have b7 := int.modeq.symm b5,
rw int.nat_abs_of_nonneg at b7,
have b8:= int.modeq.modeq_zero_iff.1 b7,
have b9 := exists_eq_mul_right_of_dvd b8,
rcases b9 with r,

have c5 : (int.nat_abs p : ℤ) ≠ 0, begin
by_contradiction,
simp at a,
have c6 := int.eq_zero_of_nat_abs_eq_zero a,
have c7 : 0 ≡ 1 [ZMOD 4], from eq.subst c6 hpp,
rw int.modeq.modeq_iff_dvd at c7,
revert c7,
simp,
norm_num,
end,

have c : (1 ≤ r) ∧ (r < p),
begin
split,
have c1 : 0 < y ^ 2 + 1,
{
    rw int.lt_add_one_iff,
    exact pow_two_nonneg y,
},
have c2 : p * r > 0, from eq.subst b9_h c1,
have c3 := pos_of_mul_pos_left c2 H, exact c3,
have c4 : y ≥ 0 ∧ y ≤ p - 1,
split,

have c8 : x % ↑(int.nat_abs p) ≥ 0, from int.mod_nonneg x c5,
exact c8,
rw ← int.lt_add_one_iff,
simp,
have d1 := int.mod_lt x c5,
conv at d1 {to_rhs, rw int.nat_abs_of_nonneg H},
rw abs_of_nonneg H at d1,
exact d1,
have d2 : y ^ 2  ≤ (p-1) ^ 2 , sorry,
have d3 : y ^ 2 + 1 ≤ (p-1) ^ 2 + 1, sorry,
have d4 : p * r ≤ (p-1) ^ 2 + 1, from eq.subst b9_h d3,
rw mul_comm at d4,
have d5 : p > 0, sorry,
have d6 := le_div_of_mul_le d5 d4,
sorry,
end,

sorry,
exact H,
end

#check abs
#check int.nat_abs_of_nonneg

--inductive less_than_or_equal (a : ℤ) : ℤ → Prop
--| refl : less_than_or_equal a
--| step : Π {b}, less_than_or_equal b → less_than_or_equal (succ b)

--def le_refl : ∀ a : ℤ, a ≤ a :=
--less_than_or_equal.refl

--lemma le_succ (n:ℤ) : n ≤ succ n :=
--less_than_or_equal.step (int.le_refl n)

--theorem le_of_succ_le {n m : ℤ} (h : succ n ≤ m) : n ≤ m :=
--int.le_trans (le_succ n) h


-- Boilerplate
import algebra.group.units
import logic.basic
namespace examples

/-
For example, `subsingleton : Π (α : Type*), Prop` asserts the type `α` has at most one element:
-/
-- Adapted from `library/init/logic.lean:808`
class subsingleton (α : Type*) : Prop := (h : ∀ (a b : α), a = b)
/-
The subclass `unique α` of `subsingleton α` (constructively) asserts that `α` has exactly one element.
-/
class unique (α : Type*) extends subsingleton α :=
(default : α)
/-
This means `unique α` is also a subclass of `inhabited α`, which (constructively) specifies an element of `α` while also allowing for more.
-/
-- Adapted from `library/init/logic.lean:775`
class inhabited (α : Type*) := (default : α)

instance unique.to_inhabited (α : Type*) [h : unique α] := { ..h }

/-
A theorem about trivial monoids will take these assumptions as separate parameters `[monoid M] [subsingleton M]`:
-/
instance units.unique {M : Type*} [monoid M] [subsingleton M] : unique (units M) :=
{ default := 1,
  h := λ x y, by { cases x, cases y, congr; apply subsingleton.h } }

/-
In fact, `unique α` is equivalent to the conjunction of `subsingleton α` and `inhabited α`.
However, the implication `∀ {α}, subsingleton α → inhabited α → unique α` cannot be added while keeping `subsingleton` and `inhabited` superclasses of `unique`,
since that would result in an infinite loop `unique → subsingleton → unique → subsingleton → ⋯` during instance synthesis.
-/
instance unique.of_subsingleton_of_inhabited (α : Type*) [hs : subsingleton α] [hi : inhabited α] : unique α :=
⟨hi.default⟩

example (α : Type*) : unique α :=
begin
  success_if_fail { apply_instance }, -- maximum class-instance resolution depth has been reached
  sorry
end

end examples


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

import algebra.module.basic

/-!
# Instances on punit

This file collects facts about algebraic structures on the one-element type, e.g. that it is a
commutative ring.
-/

universes u

namespace punit
variables (x y : punit.{u+1}) (s : set punit.{u+1})

@[to_additive]
instance : comm_group punit :=
by refine_struct
{ mul := λ _ _, star,
  one := star,
  inv := λ _, star,
  div := λ _ _, star,
  npow := λ _ _, star,
  zpow := λ _ _, star,
  .. };
intros; exact subsingleton.elim _ _

instance : comm_ring punit :=
by refine
{ .. punit.comm_group,
  .. punit.add_comm_group,
  .. };
intros; exact subsingleton.elim _ _

instance : complete_boolean_algebra punit :=
by refine
{ le := λ _ _, true,
  le_antisymm := λ _ _ _ _, subsingleton.elim _ _,
  lt := λ _ _, false,
  lt_iff_le_not_le := λ _ _, iff_of_false not_false (λ H, H.2 trivial),
  top := star,
  bot := star,
  sup := λ _ _, star,
  inf := λ _ _, star,
  Sup := λ _, star,
  Inf := λ _, star,
  compl := λ _, star,
  sdiff := λ _ _, star,
  .. };
intros; trivial <|> simp only [eq_iff_true_of_subsingleton]

instance : canonically_ordered_add_monoid punit :=
by refine
{ le_iff_exists_add := λ _ _, iff_of_true _ ⟨star, subsingleton.elim _ _⟩,
  .. punit.comm_ring, .. punit.complete_boolean_algebra, .. };
intros; trivial

instance : linear_ordered_cancel_add_comm_monoid punit :=
{ add_left_cancel := λ _ _ _ _, subsingleton.elim _ _,
  le_of_add_le_add_left := λ _ _ _ _, trivial,
  le_total := λ _ _, or.inl trivial,
  decidable_le := λ _ _, decidable.true,
  decidable_eq := punit.decidable_eq,
  decidable_lt := λ _ _, decidable.false,
  .. punit.canonically_ordered_add_monoid }

instance (R : Type u) [semiring R] : module R punit := module.of_core $
by refine
{ smul := λ _ _, star,
  .. punit.comm_ring, .. };
intros; exact subsingleton.elim _ _

@[simp] lemma zero_eq : (0 : punit) = star := rfl
@[simp, to_additive] lemma one_eq : (1 : punit) = star := rfl
@[simp] lemma add_eq : x + y = star := rfl
@[simp, to_additive] lemma mul_eq : x * y = star := rfl
@[simp, to_additive] lemma div_eq : x / y = star := rfl
@[simp] lemma neg_eq : -x = star := rfl
@[simp, to_additive] lemma inv_eq : x⁻¹ = star := rfl
lemma smul_eq : x • y = star := rfl
@[simp] lemma top_eq : (⊤ : punit) = star := rfl
@[simp] lemma bot_eq : (⊥ : punit) = star := rfl
@[simp] lemma sup_eq : x ⊔ y = star := rfl
@[simp] lemma inf_eq : x ⊓ y = star := rfl
@[simp] lemma Sup_eq : Sup s = star := rfl
@[simp] lemma Inf_eq : Inf s = star := rfl
@[simp] protected lemma le : x ≤ y := trivial
@[simp] lemma not_lt : ¬(x < y) := not_false

end punit


-- Unión de unitarios
-- ==================

import tactic
import data.set.basic

-- 1ª demostración
example
  {R : Type*}
  (s : set R)
  : s = ⋃ (i : s), {i} :=
by ext; simp

-- 2ª demostración
lemma setext
  {R : Type*}
  (s : set R)
  : s = ⋃ (i : s), {i} :=
by tidy


/-
Copyright © 2019, Oracle and/or its affiliates. All rights reserved.
-/

import data.set
import analysis.complex.exponential
import .attributed.dvector
import lib.basic
import topology.constructions

local attribute [instance] classical.prop_decidable

open nnreal real ennreal set lattice
open topological_space
open measure_theory

lemma lc_nnreal:
    ∀ a: nnreal, ∀ b: nnreal, a + b = 1 → a = (1:nnreal) - b :=
assume a b h, h ▸ (nnreal.add_sub_cancel).symm

lemma super_dumb:
    ∀ δ: nnreal, δ > (0:nnreal) → (1:nnreal) - δ ≤ (1: nnreal) :=
assume h, by simp

lemma coe_pmeas:
    ∀ a: ennreal, ∀ b: ennreal, a ≤ (1:ennreal) → b ≤ (1: ennreal) → a ≤ b → ennreal.to_nnreal a ≤ ennreal.to_nnreal b :=
begin
    intros a b h₁ h₂ h₃,
    rw [← coe_le_coe, coe_to_nnreal,coe_to_nnreal],
    assumption,
    rw ←ennreal.lt_top_iff_ne_top,
    exact lt_of_le_of_lt h₂ (ennreal.lt_top_iff_ne_top.2 one_ne_top),
    rw ←ennreal.lt_top_iff_ne_top,
    exact lt_of_le_of_lt h₁ (ennreal.lt_top_iff_ne_top.2 one_ne_top),
end

lemma pow_preserves_order:
    ∀ n: ℕ, ∀ a: nnreal, ∀ b: nnreal, a ≤ b → a^n ≤ b^n :=
begin
    intros n a b h,
    induction n with k ih,
    {by simp},
    {simp [pow_succ], exact mul_le_mul h ih (zero_le _) (zero_le _)},
end

lemma not_eq_prop:
    ∀ A: Prop, ∀ B: Prop, (¬ (A ↔ B)) ↔ ((¬ (A → B)) ∨ (¬ (B → A))) :=
begin
    intros,
    split; intros,
    finish,
    finish,
end

lemma nnreal_sub_trans:
    ∀ a: nnreal, ∀ b: nnreal,
    a ≥ b → 1 - a ≤ 1 - b :=
begin
    intros,
    rw nnreal.sub_le_iff_le_add,
    simp,
    by_cases (b ≤ 1),
    {
        have h: 1 + (a - b) = a + (1 - b),
        {
            calc 1 + (a - b) = 1 + a - b : by rw [←nnreal.eq_iff,nnreal.coe_add, (nnreal.coe_sub _ _ a_1), ←add_sub_assoc, nnreal.coe_sub _, nnreal.coe_add];                        exact le_add_of_le_of_nonneg h (zero_le _)
                 ...         = a + 1 - b : by rw add_comm
                 ...         = a + (1 - b) : by rw [←nnreal.eq_iff,nnreal.coe_add, (nnreal.coe_sub _ _ h), ←add_sub_assoc,nnreal.coe_sub _, nnreal.coe_add];exact le_add_of_le_of_nonneg a_1 (zero_le _),

        },
        rw h.symm,
        cases b, cases a, dsimp at *, simp at *,
    },
    {
        simp at h,
        rw nnreal.sub_eq_zero, swap,
        exact le_of_lt h,
        simp,
        transitivity b,
        exact le_of_lt h,
        assumption,
    }
end

lemma prod_rw {α: Type} {β: Type}:
    ∀ P₁: α → Prop,
    ∀ P₂: β → Prop,
    { v : α × β | P₁ v.fst ∧ P₂ v.snd} = set.prod {x: α | P₁ x} {x: β | P₂ x} :=
begin
    intros,
    unfold set.prod,
    rw ext_iff, intro,
    repeat {rw mem_set_of_eq},
end

lemma dfin_1_projn {α: Type}:
    ∀ P: α → Prop,
    ∀ x: vec α 0,
    (∀ (i: dfin 1), P (kth_projn x i)) ↔ P x :=
begin
    intros,
    split; intros,
    {
        simp at *,
        apply a,
        exact dfin.fz,
    },
    {
        simp at *, assumption,
    },
end

lemma dfin_1_projn' {α: Type}:
    ∀ P: α → Prop,
    { x: vec α 0 | ∀ (i: dfin 1), P (kth_projn x i)} = {x: α | P x} :=
begin
    intros,
    rw ext_iff, intro,
    repeat {rw mem_set_of_eq},
    rw dfin_1_projn,
    trivial,
end

lemma is_measurable_simple_vec {α: Type} [measurable_space α]:
    ∀ P: α → Prop,
    is_measurable {x: α | P x} →
    ∀ n,
    is_measurable {v: vec α n | ∀ (i: dfin (nat.succ n)), P(kth_projn v i)} :=
begin
    intros,
    induction n; intros,
    {
        rw dfin_1_projn', assumption,
    },
    {
        dunfold vec,
        conv {
            congr, congr, funext, rw dfin_succ_prop_iff_fst_and_rst, skip,
        },
        have PROD := prod_rw (λ x, P x) (λ x, ∀ (i: dfin (nat.succ n_n)), P(kth_projn x i)),
        simp at PROD,
        rw PROD, clear PROD,
        apply is_measurable_set_prod; try {assumption},
    },
end

/- Move these results back to where vec was defined (../to_mathlib.lean)-/
noncomputable
instance vec_topo: ∀ n: ℕ, topological_space (vec nnreal n) :=
begin
    intro,
    induction n,
    {
        dunfold vec,
        apply_instance,
    },
    {
        unfold vec,
        have PROD := @prod.topological_space nnreal (vec nnreal n_n) _ n_ih,
        assumption,
    },
end

instance vec_second_countable : ∀ n:ℕ, second_countable_topology (vec nnreal n) :=
begin
    intros n,
    induction n with k ih,
    dsimp [vec], apply_instance,
    dsimp [vec],
    haveI := second_countable_topology nnreal,
    apply_instance,
end

lemma vec.measurable_space_eq_borel (n : ℕ) : vec.measurable_space n = measure_theory.borel (vec nnreal n) :=
begin
    induction n with k ih,
    refl,
    dsimp [vec], rw ←measure_theory.borel_prod,
    rw prod.measurable_space, rw ←ih, refl,
end

lemma test''' :
    ∀ n: ℕ,
    ∀ f: nnreal × vec nnreal n → nnreal,
    ∀ g: nnreal × vec nnreal n → nnreal,
    continuous f →
    continuous g →
    is_measurable {p: nnreal × (vec nnreal n) | f p < g p} :=
begin
    intros n f g hf hg,
    convert measure_theory.is_measurable_of_is_open _,
    haveI := vec_second_countable n,
    swap,
    change topological_space (vec nnreal (nat.succ n)), apply_instance,
    swap,
    exact is_open_lt hf hg, rw prod.measurable_space,
    rw ←measure_theory.borel_prod, rw vec.measurable_space_eq_borel n, refl,
end

lemma to_nnreal_sub {r₁ r₂ : ennreal} (h₁ : r₁ < ⊤) (h₂ : r₂ < ⊤) :
  (r₁ - r₂).to_nnreal = r₁.to_nnreal - r₂.to_nnreal :=
by rw [← ennreal.coe_eq_coe, ennreal.coe_sub, ennreal.coe_to_nnreal (ne_top_of_lt h₂), ennreal.coe_to_nnreal (ne_top_of_lt h₁),
    ennreal.coe_to_nnreal ((lt_top_iff_ne_top.1 (lt_of_le_of_lt (sub_le_self _ _) h₁)))]

section to_borel_space

/- Move these back to borel_space.lean -/

variables {α : Type*} [linear_order α] [topological_space α] [ordered_topology α] {a b c : α}

lemma is_measurable_Ioc : is_measurable (Ioc a b) :=  (is_measurable_of_is_open (is_open_lt continuous_const continuous_id)).inter (is_measurable_of_is_closed (is_closed_le continuous_id continuous_const))

lemma is_measurable_Icc : is_measurable (Icc a b) := is_measurable_of_is_closed $ is_closed_Icc

lemma is_measurable_Ioi : is_measurable (Ioi a) :=
is_measurable_of_is_open $ is_open_lt continuous_const continuous_id

end to_borel_space

lemma Ioi_complement:
    ∀ x: nnreal, Ioi x = - (Iio x ∪ {x}) :=
begin
    intros,
    rw ext_iff, intro,
    unfold Ioi, unfold Iio,
    simp,
    repeat {rw mem_set_of_eq},
    split; intro,
    {
        push_neg, split,
        {
            by_contradiction, simp at *,
            rw a_1 at a,
            have FOO: ¬ (x < x), simp,
            contradiction,
        },
        {
            exact le_of_lt a,
        },
    },
    {
        push_neg at a,
        cases a,
        by_contradiction,
        have FOO: ¬ (x ≤ x_1),
        {
            simp, simp at a,
            exact lt_of_le_of_ne a a_left,
        },
        contradiction,
    },
end

lemma Icc_diff_Ioc:
    ∀ a: nnreal, ∀ b: nnreal, ∀ c: nnreal,
    a ≤ b → b ≤ c → (Icc a c \ Icc a b) = Ioc b c :=
begin
    unfold Icc, unfold Ioc,
    introv H1 H2,
    rw ext_iff, intro,
    rw mem_diff,
    repeat {rw mem_set_of_eq at *,},
    split; intros,
    {
        cases a_1, cases a_1_left,
        finish,
    },
    {
        cases a_1,
        split,
        {
            split,
            {
                transitivity b,
                assumption,
                exact le_of_lt a_1_left,
            },
            {
                assumption,
            },
        },
        {
            simp, intro, assumption,
        },
    },
end

lemma mono_simple {μ: probability_measure nnreal}:
    ∀ a: nnreal, ∀ b: nnreal, a ≤ b → μ (Icc 0 a) ≤ μ (Icc 0 b) :=
begin
    intros,
    apply probability_measure.prob_mono,
    unfold Icc,
    rw subset_def, intros,
    rw mem_set_of_eq at *,
    cases a_2,
    split,
    assumption,
    transitivity a; assumption,
end

lemma log_le_log_nnreal:
    ∀ x: nnreal, ∀ y: nnreal, x > 0 → y > 0 → (x ≤ y ↔ log x ≤ log y) :=
begin
    intros,
    rw log_le_log,
    refl, assumption, assumption,
end

lemma log_pow_nnreal:
    ∀ x: nnreal, x > 0 → ∀ n: ℕ, log(x^n) = n * log(x) :=
begin
    intros,
    apply exp_injective,
    rw exp_nat_mul,
    rw exp_log,
    rw exp_log,
    assumption,
    exact pow_pos a n,
end

lemma pow_coe:
    ∀ a: nnreal, ∀ n: ℕ, a.val ^ n = (a ^ n).val :=
begin
    intros,
    induction n,
    simp, refl,
    have pow_nnreal: ∀ a: nnreal, ∀ n: ℕ, a ^ (nat.succ n) = a * a ^ n, intros, exact rfl,
    rw pow_nnreal,
    have mul_coe: ∀ a: nnreal, ∀ b: nnreal, (a * b).val = a.val * b.val, intros, refl,
    rw mul_coe,
    rw ← n_ih,
    refl,
end

lemma sub_nnreal:
    ∀ a: nnreal, ∀ b: nnreal, a ≥ b → (a - b).val = a.val - b.val :=
begin
    intros a b h,
    change (↑(a-b) = ↑a - ↑b),
    rw nnreal.coe_sub _ _ h,
end

lemma ite_equals_union_interval:
    ∀ θ > 0, ∀ y: nnreal, {x: nnreal | ite (to_bool(x ≤ y)) x 0 < θ} = Ico 0 θ ∪ Ioi y :=
begin
    intros,
    unfold Ico, unfold Ioi,
    rw ext_iff, intro,
    rw mem_union,
    repeat {rw mem_set_of_eq},
    split; intro,
    {
        split_ifs at a,
        {
            left,
            split, tidy,
        },
        {
            right, tidy,
        },
    },
    {
        cases a,
        {
            cases a,
            split_ifs; assumption,
        },
        {
            split_ifs,
            {
                by_contradiction,
                have GEQ: ¬ (y < x),
                {
                    simp, simp at h, assumption,
                },
                contradiction,
            },
            {
                assumption,
            },
        },
    },
end


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

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

/-!
# The initial algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `Fix F (α₀,..,αₙ₋₁)`.
Making `Fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `Fix.mk`     - constructor
 * `Fix.dest`    - destructor
 * `Fix.rec`    - recursor: basis for defining functions by structural recursion on `Fix F α`
 * `Fix.drec`   - dependent recursor: generalization of `Fix.rec` where
                  the result type of the function is allowed to depend on the `Fix F α` value
 * `Fix.rec_eq` - defining equation for `recursor`
 * `Fix.ind`    - induction principle for `Fix F α`

## Implementation notes

For `F` a `QPF`, we define `Fix F α` in terms of the W-type of the polynomial functor `P` of `F`.
We define the relation `WEquiv` and take its quotient as the definition of `Fix F α`.

See [avigad-carneiro-hudon2019] for more details.

## Reference

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

universe u v

namespace MvQPF

open TypeVec

open MvFunctor (LiftP LiftR)

open MvFunctor

variable {n : ℕ} {F : TypeVec.{u} (n + 1) → Type u} [MvFunctor F] [q : MvQPF F]

/-- `recF` is used as a basis for defining the recursor on `Fix F α`. `recF`
traverses recursively the W-type generated by `q.P` using a function on `F`
as a recursive step -/
def recF {α : TypeVec n} {β : Type _} (g : F (α.append1 β) → β) : q.P.W α → β :=
  q.P.wRec fun a f' _f rec => g (abs ⟨a, splitFun f' rec⟩)
set_option linter.uppercaseLean3 false in
#align mvqpf.recF MvQPF.recF

theorem recF_eq {α : TypeVec n} {β : Type _} (g : F (α.append1 β) → β) (a : q.P.A)
    (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
    recF g (q.P.wMk a f' f) = g (abs ⟨a, splitFun f' (recF g ∘ f)⟩) := by
  rw [recF, MvPFunctor.wRec_eq]; rfl
set_option linter.uppercaseLean3 false in
#align mvqpf.recF_eq MvQPF.recF_eq

theorem recF_eq' {α : TypeVec n} {β : Type _} (g : F (α.append1 β) → β) (x : q.P.W α) :
    recF g x = g (abs (appendFun id (recF g) <$$> q.P.wDest' x)) := by
  apply q.P.w_cases _ x
  intro a f' f
  rw [recF_eq, q.P.wDest'_wMk, MvPFunctor.map_eq, appendFun_comp_splitFun, TypeVec.id_comp]
set_option linter.uppercaseLean3 false in
#align mvqpf.recF_eq' MvQPF.recF_eq'

/-- Equivalence relation on W-types that represent the same `Fix F`
value -/
inductive WEquiv {α : TypeVec n} : q.P.W α → q.P.W α → Prop
  | ind (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f₀ f₁ : q.P.last.B a → q.P.W α) :
    (∀ x, WEquiv (f₀ x) (f₁ x)) → WEquiv (q.P.wMk a f' f₀) (q.P.wMk a f' f₁)
  | abs (a₀ : q.P.A) (f'₀ : q.P.drop.B a₀ ⟹ α) (f₀ : q.P.last.B a₀ → q.P.W α) (a₁ : q.P.A)
    (f'₁ : q.P.drop.B a₁ ⟹ α) (f₁ : q.P.last.B a₁ → q.P.W α) :
    abs ⟨a₀, q.P.appendContents f'₀ f₀⟩ = abs ⟨a₁, q.P.appendContents f'₁ f₁⟩ →
      WEquiv (q.P.wMk a₀ f'₀ f₀) (q.P.wMk a₁ f'₁ f₁)
  | trans (u v w : q.P.W α) : WEquiv u v → WEquiv v w → WEquiv u w
set_option linter.uppercaseLean3 false in
#align mvqpf.Wequiv MvQPF.WEquiv

theorem recF_eq_of_wEquiv (α : TypeVec n) {β : Type _} (u : F (α.append1 β) → β) (x y : q.P.W α) :
    WEquiv x y → recF u x = recF u y := by
  apply q.P.w_cases _ x
  intro a₀ f'₀ f₀
  apply q.P.w_cases _ y
  intro a₁ f'₁ f₁
  intro h
  -- porting note: induction on h doesn't work.
  refine' @WEquiv.recOn _ _ _ _ _ (λ a a' _ => recF u a = recF u a') _ _ h _ _ _
  · intros a f' f₀ f₁ _h ih; simp only [recF_eq, Function.comp]
    congr; funext; congr; funext; apply ih
  · intros a₀ f'₀ f₀ a₁ f'₁ f₁ h; simp only [recF_eq', abs_map, MvPFunctor.wDest'_wMk, h]
  · intros x y z _e₁ _e₂ ih₁ ih₂; exact Eq.trans ih₁ ih₂
set_option linter.uppercaseLean3 false in
#align mvqpf.recF_eq_of_Wequiv MvQPF.recF_eq_of_wEquiv

theorem wEquiv.abs' {α : TypeVec n} (x y : q.P.W α)
                    (h : MvQPF.abs (q.P.wDest' x ) = MvQPF.abs (q.P.wDest' y)) :
    WEquiv x y := by
  revert h
  apply q.P.w_cases _ x
  intro a₀ f'₀ f₀
  apply q.P.w_cases _ y
  intro a₁ f'₁ f₁
  apply WEquiv.abs
set_option linter.uppercaseLean3 false in
#align mvqpf.Wequiv.abs' MvQPF.wEquiv.abs'

theorem wEquiv.refl {α : TypeVec n} (x : q.P.W α) : WEquiv x x := by
  apply q.P.w_cases _ x; intro a f' f; exact WEquiv.abs a f' f a f' f rfl
set_option linter.uppercaseLean3 false in
#align mvqpf.Wequiv.refl MvQPF.wEquiv.refl

theorem wEquiv.symm {α : TypeVec n} (x y : q.P.W α) : WEquiv x y → WEquiv y x := by
  intro h; induction h
  case ind a f' f₀ f₁ _h ih => exact WEquiv.ind _ _ _ _ ih
  case abs a₀ f'₀ f₀ a₁ f'₁ f₁ h => exact WEquiv.abs _ _ _ _ _ _ h.symm
  case trans x y z _e₁ _e₂ ih₁ ih₂ => exact MvQPF.WEquiv.trans _ _ _ ih₂ ih₁
set_option linter.uppercaseLean3 false in
#align mvqpf.Wequiv.symm MvQPF.wEquiv.symm

/-- maps every element of the W type to a canonical representative -/
def wrepr {α : TypeVec n} : q.P.W α → q.P.W α :=
  recF (q.P.wMk' ∘ repr)
set_option linter.uppercaseLean3 false in
#align mvqpf.Wrepr MvQPF.wrepr

theorem wrepr_wMk {α : TypeVec n} (a : q.P.A) (f' : q.P.drop.B a ⟹ α)
    (f : q.P.last.B a → q.P.W α) :
    wrepr (q.P.wMk a f' f) =
      q.P.wMk' (repr (abs (appendFun id wrepr <$$> ⟨a, q.P.appendContents f' f⟩))) :=
  by rw [wrepr, recF_eq', q.P.wDest'_wMk]; rfl
set_option linter.uppercaseLean3 false in
#align mvqpf.Wrepr_W_mk MvQPF.wrepr_wMk

theorem wrepr_equiv {α : TypeVec n} (x : q.P.W α) : WEquiv (wrepr x) x := by
  apply q.P.w_ind _ x; intro a f' f ih
  apply WEquiv.trans _ (q.P.wMk' (appendFun id wrepr <$$> ⟨a, q.P.appendContents f' f⟩))
  · apply wEquiv.abs'
    rw [wrepr_wMk, q.P.wDest'_wMk', q.P.wDest'_wMk', abs_repr]
  rw [q.P.map_eq, MvPFunctor.wMk', appendFun_comp_splitFun, id_comp]
  apply WEquiv.ind; exact ih
set_option linter.uppercaseLean3 false in
#align mvqpf.Wrepr_equiv MvQPF.wrepr_equiv

theorem wEquiv_map {α β : TypeVec n} (g : α ⟹ β) (x y : q.P.W α) :
    WEquiv x y → WEquiv (g <$$> x) (g <$$> y) := by
  intro h; induction h
  case ind a f' f₀ f₁ h ih => rw [q.P.w_map_wMk, q.P.w_map_wMk]; apply WEquiv.ind; exact ih
  case
    abs a₀ f'₀ f₀ a₁ f'₁ f₁ h =>
    rw [q.P.w_map_wMk, q.P.w_map_wMk]; apply WEquiv.abs
    show
      abs (q.P.objAppend1 a₀ (g ⊚ f'₀) fun x => q.P.wMap g (f₀ x)) =
        abs (q.P.objAppend1 a₁ (g ⊚ f'₁) fun x => q.P.wMap g (f₁ x))
    rw [← q.P.map_objAppend1, ← q.P.map_objAppend1, abs_map, abs_map, h]
  case trans x y z _ _ ih₁ ih₂ => apply MvQPF.WEquiv.trans; apply ih₁; apply ih₂
set_option linter.uppercaseLean3 false in
#align mvqpf.Wequiv_map MvQPF.wEquiv_map

/-- Define the fixed point as the quotient of trees under the equivalence relation.
-/
def wSetoid (α : TypeVec n) : Setoid (q.P.W α) :=
  ⟨WEquiv, @wEquiv.refl _ _ _ _ _, @wEquiv.symm _ _ _ _ _, @WEquiv.trans _ _ _ _ _⟩
set_option linter.uppercaseLean3 false in
#align mvqpf.W_setoid MvQPF.wSetoid

attribute [local instance] wSetoid

/-- Least fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, `Fix F` is a binary functor such that

```lean
Fix F a b = F a b (Fix F a b)
```
-/
def Fix {n : ℕ} (F : TypeVec (n + 1) → Type _) [MvFunctor F] [q : MvQPF F] (α : TypeVec n) :=
  Quotient (wSetoid α : Setoid (q.P.W α))
#align mvqpf.fix MvQPF.Fix

--attribute [nolint has_nonempty_instance] Fix

/-- `Fix F` is a functor -/
def Fix.map {α β : TypeVec n} (g : α ⟹ β) : Fix F α → Fix F β :=
  Quotient.lift (fun x : q.P.W α => ⟦q.P.wMap g x⟧) fun _a _b h => Quot.sound (wEquiv_map _ _ _ h)
#align mvqpf.fix.map MvQPF.Fix.map

instance Fix.mvfunctor : MvFunctor (Fix F) where map := @Fix.map _ _ _ _
#align mvqpf.fix.mvfunctor MvQPF.Fix.mvfunctor

variable {α : TypeVec.{u} n}

/-- Recursor for `Fix F` -/
def Fix.rec {β : Type u} (g : F (α ::: β) → β) : Fix F α → β :=
  Quot.lift (recF g) (recF_eq_of_wEquiv α g)
#align mvqpf.fix.rec MvQPF.Fix.rec

/-- Access W-type underlying `Fix F`  -/
def fixToW : Fix F α → q.P.W α :=
  Quotient.lift wrepr (recF_eq_of_wEquiv α fun x => q.P.wMk' (repr x))
set_option linter.uppercaseLean3 false in
#align mvqpf.fix_to_W MvQPF.fixToW

/-- Constructor for `Fix F` -/
def Fix.mk (x : F (append1 α (Fix F α))) : Fix F α :=
  Quot.mk _ (q.P.wMk' (appendFun id fixToW <$$> repr x))
#align mvqpf.fix.mk MvQPF.Fix.mk

/-- Destructor for `Fix F` -/
def Fix.dest : Fix F α → F (append1 α (Fix F α)) :=
  Fix.rec (MvFunctor.map (appendFun id Fix.mk))
#align mvqpf.fix.dest MvQPF.Fix.dest

theorem Fix.rec_eq {β : Type u} (g : F (append1 α β) → β) (x : F (append1 α (Fix F α))) :
    Fix.rec g (Fix.mk x) = g (appendFun id (Fix.rec g) <$$> x) := by
  have : recF g ∘ fixToW = Fix.rec g := by
    apply funext
    apply Quotient.ind
    intro x
    apply recF_eq_of_wEquiv
    apply wrepr_equiv
  conv =>
    lhs
    rw [Fix.rec, Fix.mk]
    dsimp
  cases' h : repr x with a f
  rw [MvPFunctor.map_eq, recF_eq', ← MvPFunctor.map_eq, MvPFunctor.wDest'_wMk']
  rw [← MvPFunctor.comp_map, abs_map, ← h, abs_repr, ← appendFun_comp, id_comp, this]
#align mvqpf.fix.rec_eq MvQPF.Fix.rec_eq

theorem Fix.ind_aux (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
    Fix.mk (abs ⟨a, q.P.appendContents f' fun x => ⟦f x⟧⟩) = ⟦q.P.wMk a f' f⟧ := by
  have : Fix.mk (abs ⟨a, q.P.appendContents f' fun x => ⟦f x⟧⟩) = ⟦wrepr (q.P.wMk a f' f)⟧ :=
    by
    apply Quot.sound; apply wEquiv.abs'
    rw [MvPFunctor.wDest'_wMk', abs_map, abs_repr, ← abs_map, MvPFunctor.map_eq]
    conv =>
      rhs
      rw [wrepr_wMk, q.P.wDest'_wMk', abs_repr, MvPFunctor.map_eq]
    congr 2; rw [MvPFunctor.appendContents, MvPFunctor.appendContents]
    rw [appendFun, appendFun, ← splitFun_comp, ← splitFun_comp]
    rfl
  rw [this]
  apply Quot.sound
  apply wrepr_equiv
#align mvqpf.fix.ind_aux MvQPF.Fix.ind_aux

theorem Fix.ind_rec {β : Type _} (g₁ g₂ : Fix F α → β)
    (h :
      ∀ x : F (append1 α (Fix F α)),
        appendFun id g₁ <$$> x = appendFun id g₂ <$$> x → g₁ (Fix.mk x) = g₂ (Fix.mk x)) :
    ∀ x, g₁ x = g₂ x := by
  apply Quot.ind
  intro x
  apply q.P.w_ind _ x
  intro a f' f ih
  show g₁ ⟦q.P.wMk a f' f⟧ = g₂ ⟦q.P.wMk a f' f⟧
  rw [← Fix.ind_aux a f' f]
  apply h
  rw [← abs_map, ← abs_map, MvPFunctor.map_eq, MvPFunctor.map_eq]
  congr 2
  rw [MvPFunctor.appendContents, appendFun, appendFun, ← splitFun_comp, ← splitFun_comp]
  have : (g₁ ∘ fun x => ⟦f x⟧) = g₂ ∘ fun x => ⟦f x⟧ :=
    by
    ext x
    exact ih x
  rw [this]
#align mvqpf.fix.ind_rec MvQPF.Fix.ind_rec

theorem Fix.rec_unique {β : Type _} (g : F (append1 α β) → β) (h : Fix F α → β)
    (hyp : ∀ x, h (Fix.mk x) = g (appendFun id h <$$> x)) : Fix.rec g = h := by
  ext x
  apply Fix.ind_rec
  intro x hyp'
  rw [hyp, ← hyp', Fix.rec_eq]
#align mvqpf.fix.rec_unique MvQPF.Fix.rec_unique

theorem Fix.mk_dest (x : Fix F α) : Fix.mk (Fix.dest x) = x := by
  change (Fix.mk ∘ Fix.dest) x = x
  apply Fix.ind_rec
  intro x; dsimp
  rw [Fix.dest, Fix.rec_eq, ← comp_map, ← appendFun_comp, id_comp]
  intro h; rw [h]
  show Fix.mk (appendFun id id <$$> x) = Fix.mk x
  rw [appendFun_id_id, MvFunctor.id_map]
#align mvqpf.fix.mk_dest MvQPF.Fix.mk_dest

theorem Fix.dest_mk (x : F (append1 α (Fix F α))) : Fix.dest (Fix.mk x) = x := by
  unfold Fix.dest
  rw [Fix.rec_eq, ← Fix.dest, ← comp_map]
  conv =>
    rhs
    rw [← MvFunctor.id_map x]
  rw [← appendFun_comp, id_comp]
  have : Fix.mk ∘ Fix.dest = _root_.id := by
    ext (x: Fix F α)
    apply Fix.mk_dest
  rw [this, appendFun_id_id]
#align mvqpf.fix.dest_mk MvQPF.Fix.dest_mk

theorem Fix.ind {α : TypeVec n} (p : Fix F α → Prop)
    (h : ∀ x : F (α.append1 (Fix F α)), LiftP (PredLast α p) x → p (Fix.mk x)) : ∀ x, p x := by
  apply Quot.ind
  intro x
  apply q.P.w_ind _ x; intro a f' f ih
  change p ⟦q.P.wMk a f' f⟧
  rw [← Fix.ind_aux a f' f]
  apply h
  rw [MvQPF.liftP_iff]
  refine' ⟨_, _, rfl, _⟩
  intro i j
  cases i
  · apply ih
  · trivial
#align mvqpf.fix.ind MvQPF.Fix.ind

instance mvqpfFix : MvQPF (Fix F) where
  P := q.P.wp
  abs α := Quot.mk WEquiv α
  repr α := fixToW α
  abs_repr := by
    intro α
    apply Quot.ind
    intro a
    apply Quot.sound
    apply wrepr_equiv
  abs_map := by
    intro α β g x;
    conv =>
      rhs
      dsimp [MvFunctor.map]
#align mvqpf.mvqpf_fix MvQPF.mvqpfFix

/-- Dependent recursor for `fix F` -/
def Fix.drec {β : Fix F α → Type u}
    (g : ∀ x : F (α ::: Sigma β), β (Fix.mk <| (id ::: Sigma.fst) <$$> x)) (x : Fix F α) : β x :=
  let y := @Fix.rec _ F _ _ α (Sigma β) (fun i => ⟨_, g i⟩) x
  have : x = y.1 := by
    symm
    dsimp
    apply Fix.ind_rec _ id _ x
    intro x' ih
    rw [Fix.rec_eq]
    dsimp
    simp [appendFun_id_id] at ih
    congr
    conv =>
      rhs
      rw [← ih]
    rw [MvFunctor.map_map, ← appendFun_comp, id_comp]
    simp only [Function.comp]
  cast (by rw [this]) y.2

#align mvqpf.fix.drec MvQPF.Fix.drec

end MvQPF


-- Print a nat using well-founded recursion
def natPrintAux (n : Nat) (sink : List Char) : List Char :=
  if h0 : n < 10
  then (n.digitChar :: sink)
  else natPrintAux (n / 10) (Nat.digitChar (n % 10) :: sink)
termination_by' measure (fun ⟨n, _⟩ => n)
decreasing_by sorry

-- I meant to write `simp only [natPrintAux]`, but accidentally referenced the current theorem
theorem natPrintAux_eq (n : Nat) (sink : List Char) :
        natPrintAux n sink = if n < 10 then (n.digitChar :: sink) else natPrintAux (n / 10) (Nat.digitChar (n % 10) :: sink) := by
  simp only [natPrintAux_eq]


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.fderiv_analytic
import analysis.asymptotics.specific_asymptotics
import analysis.complex.cauchy_integral

/-!
# Removable singularity theorem

In this file we prove Riemann's removable singularity theorem: if `f : ℂ → E` is complex
differentiable in a punctured neighborhood of a point `c` and is bounded in a punctured neighborhood
of `c` (or, more generally, $f(z) - f(c)=o((z-c)^{-1})$), then it has a limit at `c` and the
function `function.update f c (lim (𝓝[≠] c) f)` is complex differentiable in a neighborhood of `c`.
-/

open topological_space metric set filter asymptotics function
open_locale topological_space filter nnreal

universe u
variables {E : Type u} [normed_group E] [normed_space ℂ E] [complete_space E]

namespace complex

/-- **Removable singularity** theorem, weak version. If `f : ℂ → E` is differentiable in a punctured
neighborhood of a point and is continuous at this point, then it is analytic at this point. -/
lemma analytic_at_of_differentiable_on_punctured_nhds_of_continuous_at {f : ℂ → E} {c : ℂ}
  (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z) (hc : continuous_at f c) :
  analytic_at ℂ f c :=
begin
  rcases (nhds_within_has_basis nhds_basis_closed_ball _).mem_iff.1 hd with ⟨R, hR0, hRs⟩,
  lift R to ℝ≥0 using hR0.le,
  replace hc : continuous_on f (closed_ball c R),
  { refine λ z hz, continuous_at.continuous_within_at _,
    rcases eq_or_ne z c with rfl | hne,
    exacts [hc, (hRs ⟨hz, hne⟩).continuous_at] },
  exact (has_fpower_series_on_ball_of_differentiable_off_countable (countable_singleton c) hc
    (λ z hz, hRs (diff_subset_diff_left ball_subset_closed_ball hz)) hR0).analytic_at
end

lemma differentiable_on_compl_singleton_and_continuous_at_iff {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hs : s ∈ 𝓝 c) : differentiable_on ℂ f (s \ {c}) ∧ continuous_at f c ↔ differentiable_on ℂ f s :=
begin
  refine ⟨_, λ hd, ⟨hd.mono (diff_subset _ _), (hd.differentiable_at hs).continuous_at⟩⟩,
  rintro ⟨hd, hc⟩ x hx,
  rcases eq_or_ne x c with rfl | hne,
  { refine (analytic_at_of_differentiable_on_punctured_nhds_of_continuous_at _ hc)
      .differentiable_at.differentiable_within_at,
    refine eventually_nhds_within_iff.2 ((eventually_mem_nhds.2 hs).mono $ λ z hz hzx, _),
    exact hd.differentiable_at (inter_mem hz (is_open_ne.mem_nhds hzx)) },
  { simpa only [differentiable_within_at, has_fderiv_within_at, hne.nhds_within_diff_singleton]
      using hd x ⟨hx, hne⟩ }
end

lemma differentiable_on_dslope {f : ℂ → E} {s : set ℂ} {c : ℂ} (hc : s ∈ 𝓝 c) :
  differentiable_on ℂ (dslope f c) s ↔ differentiable_on ℂ f s :=
⟨λ h, h.of_dslope, λ h, (differentiable_on_compl_singleton_and_continuous_at_iff hc).mp $
  ⟨iff.mpr (differentiable_on_dslope_of_nmem $ λ h, h.2 rfl) (h.mono $ diff_subset _ _),
    continuous_at_dslope_same.2 $ h.differentiable_at hc⟩⟩

/-- **Removable singularity** theorem: if `s` is a neighborhood of `c : ℂ`, a function `f : ℂ → E`
is complex differentiable on `s \ {c}`, and $f(z) - f(c)=o((z-c)^{-1})$, then `f` redefined to be
equal to `lim (𝓝[≠] c) f` at `c` is complex differentiable on `s`. -/
lemma differentiable_on_update_lim_of_is_o {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝 c) (hd : differentiable_on ℂ f (s \ {c}))
  (ho : is_o (λ z, f z - f c) (λ z, (z - c)⁻¹) (𝓝[≠] c)) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) s :=
begin
  set F : ℂ → E := λ z, (z - c) • f z with hF,
  suffices : differentiable_on ℂ F (s \ {c}) ∧ continuous_at F c,
  { rw [differentiable_on_compl_singleton_and_continuous_at_iff hc, ← differentiable_on_dslope hc,
      dslope_sub_smul] at this; try { apply_instance },
    have hc : tendsto f (𝓝[≠] c) (𝓝 (deriv F c)),
      from continuous_at_update_same.mp (this.continuous_on.continuous_at hc),
    rwa hc.lim_eq },
  refine ⟨(differentiable_on_id.sub_const _).smul hd, _⟩,
  rw ← continuous_within_at_compl_self,
  have H := ho.tendsto_inv_smul_nhds_zero,
  have H' : tendsto (λ z, (z - c) • f c) (𝓝[≠] c) (𝓝 (F c)),
    from (continuous_within_at_id.tendsto.sub tendsto_const_nhds).smul tendsto_const_nhds,
  simpa [← smul_add, continuous_within_at] using H.add H'
end

/-- **Removable singularity** theorem: if `s` is a punctured neighborhood of `c : ℂ`, a function
`f : ℂ → E` is complex differentiable on `s`, and $f(z) - f(c)=o((z-c)^{-1})$, then `f` redefined to
be equal to `lim (𝓝[≠] c) f` at `c` is complex differentiable on `{c} ∪ s`. -/
lemma differentiable_on_update_lim_insert_of_is_o {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝[≠] c) (hd : differentiable_on ℂ f s)
  (ho : is_o (λ z, f z - f c) (λ z, (z - c)⁻¹) (𝓝[≠] c)) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) (insert c s) :=
differentiable_on_update_lim_of_is_o (insert_mem_nhds_iff.2 hc)
  (hd.mono $ λ z hz, hz.1.resolve_left hz.2) ho

/-- **Removable singularity** theorem: if `s` is a neighborhood of `c : ℂ`, a function `f : ℂ → E`
is complex differentiable and is bounded on `s \ {c}`, then `f` redefined to be equal to
`lim (𝓝[≠] c) f` at `c` is complex differentiable on `s`. -/
lemma differentiable_on_update_lim_of_bdd_above {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝 c) (hd : differentiable_on ℂ f (s \ {c}))
  (hb : bdd_above (norm ∘ f '' (s \ {c}))) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) s :=
differentiable_on_update_lim_of_is_o hc hd $ is_bounded_under.is_o_sub_self_inv $
  let ⟨C, hC⟩ := hb in ⟨C + ∥f c∥, eventually_map.2 $ mem_nhds_within_iff_exists_mem_nhds_inter.2
    ⟨s, hc, λ z hz, norm_sub_le_of_le (hC $ mem_image_of_mem _ hz) le_rfl⟩⟩

/-- **Removable singularity** theorem: if a function `f : ℂ → E` is complex differentiable on a
punctured neighborhood of `c` and $f(z) - f(c)=o((z-c)^{-1})$, then `f` has a limit at `c`. -/
lemma tendsto_lim_of_differentiable_on_punctured_nhds_of_is_o {f : ℂ → E} {c : ℂ}
  (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z)
  (ho : is_o (λ z, f z - f c) (λ z, (z - c)⁻¹) (𝓝[≠] c)) :
  tendsto f (𝓝[≠] c) (𝓝 $ lim (𝓝[≠] c) f) :=
begin
  rw eventually_nhds_within_iff at hd,
  have : differentiable_on ℂ f ({z | z ≠ c → differentiable_at ℂ f z} \ {c}),
    from λ z hz, (hz.1 hz.2).differentiable_within_at,
  have H := differentiable_on_update_lim_of_is_o hd this ho,
  exact continuous_at_update_same.1 (H.differentiable_at hd).continuous_at
end

/-- **Removable singularity** theorem: if a function `f : ℂ → E` is complex differentiable and
bounded on a punctured neighborhood of `c`, then `f` has a limit at `c`. -/
lemma tendsto_lim_of_differentiable_on_punctured_nhds_of_bounded_under {f : ℂ → E}
  {c : ℂ} (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z)
  (hb : is_bounded_under (≤) (𝓝[≠] c) (λ z, ∥f z - f c∥)) :
  tendsto f (𝓝[≠] c) (𝓝 $ lim (𝓝[≠] c) f) :=
tendsto_lim_of_differentiable_on_punctured_nhds_of_is_o hd hb.is_o_sub_self_inv

end complex


/-
Copyright (c) 2022 Christopher Hoskin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Christopher Hoskin
-/
import analysis.normed_space.basic
import algebra.ring.idempotents
import tactic.noncomm_ring

/-!
# M-structure

A projection P on a normed space X is said to be an L-projection (`is_Lprojection`) if, for all `x`
in `X`,
$\|x\| = \|P x\| + \|(1 - P) x\|$.

A projection P on a normed space X is said to be an M-projection if, for all `x` in `X`,
$\|x\| = max(\|P x\|,\|(1 - P) x\|)$.

The L-projections on `X` form a Boolean algebra (`is_Lprojection.subtype.boolean_algebra`).

## TODO (Motivational background)

The M-projections on a normed space form a Boolean algebra.

The range of an L-projection on a normed space `X` is said to be an L-summand of `X`. The range of
an M-projection is said to be an M-summand of `X`.

When `X` is a Banach space, the Boolean algebra of L-projections is complete. Let `X` be a normed
space with dual `X^*`. A closed subspace `M` of `X` is said to be an M-ideal if the topological
annihilator `M^∘` is an L-summand of `X^*`.

M-ideal, M-summands and L-summands were introduced by Alfsen and Effros in [alfseneffros1972] to
study the structure of general Banach spaces. When `A` is a JB*-triple, the M-ideals of `A` are
exactly the norm-closed ideals of `A`. When `A` is a JBW*-triple with predual `X`, the M-summands of
`A` are exactly the weak*-closed ideals, and their pre-duals can be identified with the L-summands
of `X`. In the special case when `A` is a C*-algebra, the M-ideals are exactly the norm-closed
two-sided ideals of `A`, when `A` is also a W*-algebra the M-summands are exactly the weak*-closed
two-sided ideals of `A`.

## Implementation notes

The approach to showing that the L-projections form a Boolean algebra is inspired by
`measure_theory.measurable_space`.

Instead of using `P : X →L[𝕜] X` to represent projections, we use an arbitrary ring `M` with a
faithful action on `X`. `continuous_linear_map.apply_module` can be used to recover the `X →L[𝕜] X`
special case.

## References

* [Behrends, M-structure and the Banach-Stone Theorem][behrends1979]
* [Harmand, Werner, Werner, M-ideals in Banach spaces and Banach algebras][harmandwernerwerner1993]

## Tags

M-summand, M-projection, L-summand, L-projection, M-ideal, M-structure

-/

variables (X : Type*) [normed_group X]
variables {M : Type} [ring M] [module M X]
/--
A projection on a normed space `X` is said to be an L-projection if, for all `x` in `X`,
$\|x\| = \|P x\| + \|(1 - P) x\|$.

Note that we write `P • x` instead of `P x` for reasons described in the module docstring.
-/
structure is_Lprojection (P : M) : Prop :=
(proj : is_idempotent_elem P)
(Lnorm : ∀ (x : X), ∥x∥ = ∥P • x∥ + ∥(1 - P) • x∥)

/--
A projection on a normed space `X` is said to be an M-projection if, for all `x` in `X`,
$\|x\| = max(\|P x\|,\|(1 - P) x\|)$.

Note that we write `P • x` instead of `P x` for reasons described in the module docstring.
-/
structure is_Mprojection (P : M) : Prop :=
(proj : is_idempotent_elem P)
(Mnorm : ∀ (x : X), ∥x∥ = (max ∥P • x∥ ∥(1 - P) • x∥))

variables {X}

namespace is_Lprojection

lemma Lcomplement {P : M} (h: is_Lprojection X P) : is_Lprojection X (1 - P) :=
⟨h.proj.one_sub, λ x, by { rw [add_comm, sub_sub_cancel], exact h.Lnorm x }⟩

lemma Lcomplement_iff (P : M) : is_Lprojection X P ↔ is_Lprojection X (1 - P) :=
⟨Lcomplement, λ h, sub_sub_cancel 1 P ▸ h.Lcomplement⟩

lemma commute [has_faithful_smul M X] {P Q : M} (h₁ : is_Lprojection X P)
  (h₂ : is_Lprojection X Q) : commute P Q :=
begin
  have PR_eq_RPR : ∀ R : M, is_Lprojection X R → P * R = R * P * R := λ R h₃,
  begin
    refine @eq_of_smul_eq_smul _ X _ _ _ _ (λ x, _),
    rw ← norm_sub_eq_zero_iff,
    have e1 : ∥R • x∥ ≥ ∥R • x∥ + 2 • ∥ (P * R) • x - (R * P * R) • x∥ :=
    calc ∥R • x∥ = ∥R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥ +
                   (∥(R * R) • x - R • (P • (R • x))∥ + ∥(1 - R) • ((1 - P) • (R • x))∥) :
      by rw [h₁.Lnorm, h₃.Lnorm, h₃.Lnorm ((1 - P) • (R • x)), sub_smul 1 P,
        one_smul, smul_sub, mul_smul]
    ... = ∥R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥ + (∥R • x - R • (P • (R • x))∥
      + ∥((1 - R) * R) • x - (1 - R) • (P • (R • x))∥) : by rw [h₃.proj.eq,
        sub_smul 1 P, one_smul, smul_sub, mul_smul]
    ... = ∥R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥ +
          (∥R • x - R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥) :
      by rw [sub_mul, h₃.proj.eq, one_mul, sub_self, zero_smul, zero_sub,
        norm_neg]
    ... = ∥R • (P • (R • x))∥ + ∥R • x - R • (P • (R • x))∥ + 2•∥(1 - R) • (P • (R • x))∥ : by abel
    ... ≥ ∥R • x∥ + 2 • ∥ (P * R) • x - (R * P * R) • x∥ : by
      { rw ge,
        have := add_le_add_right
          (norm_le_insert' (R • x) (R • (P • (R • x)))) (2•∥(1 - R) • (P • (R • x))∥),
        simpa only [mul_smul, sub_smul, one_smul] using this },
    rw ge at e1,
    nth_rewrite_rhs 0 ← add_zero (∥R • x∥) at e1,
    rw [add_le_add_iff_left, two_smul, ← two_mul] at e1,
    rw le_antisymm_iff,
    refine ⟨_, norm_nonneg _⟩,
    rwa [←mul_zero (2 : ℝ), mul_le_mul_left (show (0 : ℝ) < 2, by norm_num)] at e1
  end,
  have QP_eq_QPQ : Q * P = Q * P * Q,
  { have e1 : P * (1 - Q) = P * (1 - Q) - (Q * P - Q * P * Q) :=
    calc P * (1 - Q) = (1 - Q) * P * (1 - Q) : by rw PR_eq_RPR (1 - Q) h₂.Lcomplement
    ... = P * (1 - Q) - (Q * P - Q * P * Q) : by noncomm_ring,
    rwa [eq_sub_iff_add_eq, add_right_eq_self, sub_eq_zero] at e1 },
  show P * Q = Q * P, by rw [QP_eq_QPQ, PR_eq_RPR Q h₂]
end

lemma mul [has_faithful_smul M X] {P Q : M} (h₁ : is_Lprojection X P) (h₂ : is_Lprojection X Q) :
  is_Lprojection X (P * Q) :=
begin
  refine ⟨is_idempotent_elem.mul_of_commute (h₁.commute h₂) h₁.proj h₂.proj, _⟩,
  intro x,
  refine le_antisymm _ _,
  { calc ∥ x ∥ = ∥(P * Q) • x + (x - (P * Q) • x)∥ : by rw add_sub_cancel'_right ((P * Q) • x) x
    ... ≤ ∥(P * Q) • x∥ + ∥ x - (P * Q) • x ∥ : by apply norm_add_le
    ... = ∥(P * Q) • x∥ + ∥(1 - P * Q) • x∥ : by rw [sub_smul,
      one_smul] },
  { calc ∥x∥ = ∥P • (Q • x)∥ + (∥Q • x - P • (Q • x)∥ + ∥x - Q • x∥) : by
      rw [h₂.Lnorm x, h₁.Lnorm (Q • x),
          sub_smul, one_smul,
          sub_smul, one_smul, add_assoc]
    ... ≥ ∥P • (Q • x)∥ + ∥(Q • x - P • (Q • x)) + (x - Q • x)∥ :
      (add_le_add_iff_left (∥P • (Q • x)∥)).mpr (norm_add_le (Q • x - P • (Q • x)) (x - Q • x))
    ... = ∥(P * Q) • x∥ + ∥(1 - P * Q) • x∥ : by rw [sub_add_sub_cancel',
      sub_smul, one_smul,
      mul_smul] }
end

lemma join [has_faithful_smul M X] {P Q : M} (h₁ : is_Lprojection X P) (h₂ : is_Lprojection X Q) :
  is_Lprojection X (P + Q - P * Q) :=
begin
  convert (Lcomplement_iff _).mp (h₁.Lcomplement.mul h₂.Lcomplement) using 1,
  noncomm_ring,
end

instance : has_compl { f : M // is_Lprojection X f } :=
⟨λ P, ⟨1 - P, P.prop.Lcomplement⟩⟩

@[simp] lemma coe_compl (P : {P : M // is_Lprojection X P}) :
  ↑(Pᶜ) = (1 : M) - ↑P := rfl

instance [has_faithful_smul M X] : has_inf {P : M // is_Lprojection X P} :=
⟨λ P Q, ⟨P * Q, P.prop.mul Q.prop⟩ ⟩

@[simp] lemma coe_inf [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  ↑(P ⊓ Q) = ((↑P : (M)) * ↑Q) := rfl

instance [has_faithful_smul M X] : has_sup {P : M // is_Lprojection X P} :=
⟨λ P Q, ⟨P + Q - P * Q, P.prop.join Q.prop⟩ ⟩

@[simp] lemma coe_sup [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  ↑(P ⊔ Q) = ((↑P : M) + ↑Q - ↑P * ↑Q) := rfl

instance [has_faithful_smul M X] : has_sdiff {P : M // is_Lprojection X P} :=
⟨λ P Q, ⟨P * (1 - Q), by exact P.prop.mul Q.prop.Lcomplement ⟩⟩

@[simp] lemma coe_sdiff [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  ↑(P \ Q) = (↑P : M) * (1 - ↑Q) := rfl

instance [has_faithful_smul M X] : partial_order {P : M // is_Lprojection X P} :=
{ le := λ P Q, (↑P : M) = ↑(P ⊓ Q),
  le_refl := λ P, by simpa only [coe_inf, ←sq] using (P.prop.proj.eq).symm,
  le_trans := λ P Q R h₁ h₂, by { simp only [coe_inf] at ⊢ h₁ h₂, rw [h₁, mul_assoc, ←h₂] },
  le_antisymm := λ P Q h₁ h₂, subtype.eq (by convert (P.prop.commute Q.prop).eq) }

lemma le_def [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  P ≤ Q ↔ (P : M) = ↑(P ⊓ Q) :=
iff.rfl

instance : has_zero {P : M // is_Lprojection X P} :=
⟨⟨0, ⟨by rw [is_idempotent_elem, zero_mul],
     λ x, by simp only [zero_smul, norm_zero, sub_zero,
                        one_smul, zero_add]⟩⟩⟩

@[simp] lemma coe_zero : ↑(0 : {P : M // is_Lprojection X P}) = (0 : M) :=
rfl

instance : has_one {P : M // is_Lprojection X P} :=
⟨⟨1, sub_zero (1 : M) ▸ (0 : {P : M // is_Lprojection X P}).prop.Lcomplement⟩⟩

@[simp] lemma coe_one : ↑(1 : {P : M // is_Lprojection X P}) = (1 : M) :=
rfl

instance [has_faithful_smul M X] : bounded_order {P : M // is_Lprojection X P} :=
{ top := 1,
  le_top := λ P, (mul_one (P : M)).symm,
  bot := 0,
  bot_le := λ P, (zero_mul (P : M)).symm, }

@[simp] lemma coe_bot [has_faithful_smul M X] :
  ↑(bounded_order.bot : {P : M // is_Lprojection X P}) = (0 : M) := rfl

@[simp]

lemma compl_mul {P : {P : M // is_Lprojection X P}} {Q : M} :
  ↑Pᶜ * Q = Q - ↑P * Q := by rw [coe_compl, sub_mul, one_mul]

lemma mul_compl_self {P : {P : M // is_Lprojection X P}} :
  (↑P : M) * (↑Pᶜ) = 0 :=
by rw [coe_compl, mul_sub, mul_one, P.prop.proj.eq, sub_self]

lemma distrib_lattice_lemma [has_faithful_smul M X] {P Q R : {P : M // is_Lprojection X P}} :
  ((↑P : M) + ↑Pᶜ * R) * (↑P + ↑Q * ↑R * ↑Pᶜ) = (↑P + ↑Q * ↑R * ↑Pᶜ) :=
by rw [add_mul, mul_add, mul_add, mul_assoc ↑Pᶜ ↑R (↑Q * ↑R * ↑Pᶜ), ← mul_assoc ↑R (↑Q * ↑R) ↑Pᶜ,
    ← coe_inf Q, (Pᶜ.prop.commute R.prop).eq, ((Q ⊓ R).prop.commute Pᶜ.prop).eq,
    (R.prop.commute (Q ⊓ R).prop).eq, coe_inf Q, mul_assoc ↑Q, ← mul_assoc, mul_assoc ↑R,
    (Pᶜ.prop.commute P.prop).eq, mul_compl_self, zero_mul, mul_zero, zero_add, add_zero,
    ← mul_assoc,
    P.prop.proj.eq, R.prop.proj.eq, ← coe_inf Q, mul_assoc, ((Q ⊓ R).prop.commute Pᶜ.prop).eq,
    ← mul_assoc, Pᶜ.prop.proj.eq]

instance [has_faithful_smul M X] : distrib_lattice {P : M // is_Lprojection X P} :=
{ le_sup_left := λ P Q, by rw [le_def, coe_inf, coe_sup, ← add_sub, mul_add, mul_sub, ← mul_assoc,
    P.prop.proj.eq, sub_self, add_zero],
  le_sup_right := λ P Q,
  begin
    rw [le_def, coe_inf, coe_sup, ← add_sub, mul_add, mul_sub, commute.eq (commute P.prop Q.prop),
      ← mul_assoc, Q.prop.proj.eq, add_sub_cancel'_right],
  end,
  sup_le := λ P Q R,
  begin
    rw [le_def, le_def, le_def, coe_inf, coe_inf, coe_sup, coe_inf, coe_sup, ← add_sub, add_mul,
      sub_mul, mul_assoc],
    intros h₁ h₂,
    rw [← h₂, ← h₁],
  end,
  inf_le_left := λ P Q, by rw [le_def, coe_inf, coe_inf, coe_inf, mul_assoc,
    (Q.prop.commute P.prop).eq, ← mul_assoc, P.prop.proj.eq],
  inf_le_right := λ P Q, by rw [le_def, coe_inf, coe_inf, coe_inf, mul_assoc, Q.prop.proj.eq],
  le_inf := λ P Q R,
  begin
    rw [le_def, le_def, le_def, coe_inf, coe_inf, coe_inf, coe_inf, ← mul_assoc],
    intros h₁ h₂,
    rw [← h₁, ← h₂],
  end,
  le_sup_inf := λ P Q R,
  begin
    have e₁: ↑((P ⊔ Q) ⊓ (P ⊔ R)) = ↑P + ↑Q * ↑R * ↑Pᶜ :=
    by rw [coe_inf, coe_sup, coe_sup,
      ← add_sub, ← add_sub, ←compl_mul, ←compl_mul, add_mul, mul_add,
      (Pᶜ.prop.commute Q.prop).eq, mul_add, ← mul_assoc, mul_assoc ↑Q, (Pᶜ.prop.commute P.prop).eq,
      mul_compl_self, zero_mul, mul_zero, zero_add, add_zero, ← mul_assoc, mul_assoc ↑Q,
      P.prop.proj.eq, Pᶜ.prop.proj.eq, mul_assoc, (Pᶜ.prop.commute R.prop).eq, ← mul_assoc],
    have e₂ : ↑((P ⊔ Q) ⊓ (P ⊔ R)) * ↑(P ⊔ Q ⊓ R) = ↑P + ↑Q * ↑R * ↑Pᶜ := by rw [coe_inf, coe_sup,
      coe_sup, coe_sup, ← add_sub, ← add_sub, ← add_sub, ←compl_mul, ←compl_mul,
      ←compl_mul, (Pᶜ.prop.commute (Q⊓R).prop).eq, coe_inf, mul_assoc, distrib_lattice_lemma,
      (Q.prop.commute R.prop).eq, distrib_lattice_lemma],
    rw [le_def, e₁, coe_inf, e₂],
  end,
  .. is_Lprojection.subtype.has_inf,
  .. is_Lprojection.subtype.has_sup,
  .. is_Lprojection.subtype.partial_order }

instance [has_faithful_smul M X] : boolean_algebra {P : M // is_Lprojection X P} :=
{ sup_inf_sdiff := λ P Q, subtype.ext $
    by rw [coe_sup, coe_inf, coe_sdiff, mul_assoc, ← mul_assoc ↑Q,
    (Q.prop.commute P.prop).eq, mul_assoc ↑P ↑Q, ← coe_compl, mul_compl_self, mul_zero, mul_zero,
    sub_zero, ← mul_add, coe_compl, add_sub_cancel'_right, mul_one],
  inf_inf_sdiff := λ P Q, subtype.ext $
    by rw [coe_inf, coe_inf, coe_sdiff, coe_bot, mul_assoc, ← mul_assoc ↑Q,
      (Q.prop.commute P.prop).eq, ← coe_compl, mul_assoc, mul_compl_self, mul_zero, mul_zero],
  inf_compl_le_bot := λ P,
    (subtype.ext (by rw [coe_inf, coe_compl, coe_bot, ← coe_compl, mul_compl_self])).le,
  top_le_sup_compl := λ P, (subtype.ext(by rw [coe_top, coe_sup, coe_compl,
    add_sub_cancel'_right, ← coe_compl, mul_compl_self, sub_zero])).le,
  sdiff_eq := λ P Q, subtype.ext $ by rw [coe_sdiff, ← coe_compl, coe_inf],
  .. is_Lprojection.subtype.has_compl,
  .. is_Lprojection.subtype.has_sdiff,
  .. is_Lprojection.subtype.bounded_order,
  .. is_Lprojection.subtype.distrib_lattice }

end is_Lprojection


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison
-/
import category_theory.limits.preserves.shapes.biproducts
import category_theory.preadditive.functor_category

/-!
# Additive Functors

A functor between two preadditive categories is called *additive*
provided that the induced map on hom types is a morphism of abelian
groups.

An additive functor between preadditive categories creates and preserves biproducts.
Conversely, if `F : C ⥤ D` is a functor between preadditive categories, where `C` has binary
biproducts, and if `F` preserves binary biproducts, then `F` is additive.

We also define the category of bundled additive functors.

# Implementation details

`functor.additive` is a `Prop`-valued class, defined by saying that for every two objects `X` and
`Y`, the map `F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of abelian groups.

-/

namespace category_theory

/-- A functor `F` is additive provided `F.map` is an additive homomorphism. -/
class functor.additive {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] (F : C ⥤ D) : Prop :=
(map_add' : Π {X Y : C} {f g : X ⟶ Y}, F.map (f + g) = F.map f + F.map g . obviously)

section preadditive

namespace functor

section
variables {C D : Type*} [category C] [category D] [preadditive C]
  [preadditive D] (F : C ⥤ D) [functor.additive F]

@[simp]

/-- `F.map_add_hom` is an additive homomorphism whose underlying function is `F.map`. -/
@[simps {fully_applied := ff}]
def map_add_hom {X Y : C} : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y) :=
add_monoid_hom.mk' (λ f, F.map f) (λ f g, F.map_add)

lemma coe_map_add_hom {X Y : C} : ⇑(F.map_add_hom : (X ⟶ Y) →+ _) = @map C _ D _ F X Y := rfl

@[priority 100]
instance preserves_zero_morphisms_of_additive : preserves_zero_morphisms F :=
{ map_zero' := λ X Y, F.map_add_hom.map_zero }

instance : additive (𝟭 C) :=
{}

instance {E : Type*} [category E] [preadditive E] (G : D ⥤ E) [functor.additive G] :
  additive (F ⋙ G) :=
{}

@[simp]
lemma map_neg {X Y : C} {f : X ⟶ Y} : F.map (-f) = - F.map f :=
F.map_add_hom.map_neg _

@[simp]
lemma map_sub {X Y : C} {f g : X ⟶ Y} : F.map (f - g) = F.map f - F.map g :=
F.map_add_hom.map_sub _ _

-- You can alternatively just use `functor.map_smul` here, with an explicit `(r : ℤ)` argument.
lemma map_zsmul {X Y : C} {f : X ⟶ Y} {r : ℤ} : F.map (r • f) = r • F.map f :=
F.map_add_hom.map_zsmul _ _

open_locale big_operators

@[simp]
lemma map_sum {X Y : C} {α : Type*} (f : α → (X ⟶ Y)) (s : finset α) :
  F.map (∑ a in s, f a) = ∑ a in s, F.map (f a) :=
(F.map_add_hom : (X ⟶ Y) →+ _).map_sum f s

end

section induced_category
variables {C : Type*} {D : Type*} [category D] [preadditive D] (F : C → D)

instance induced_functor_additive : functor.additive (induced_functor F) := {}

end induced_category

section
-- To talk about preservation of biproducts we need to specify universes explicitly.

noncomputable theory
universes v u₁ u₂

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

open category_theory.limits
open category_theory.preadditive

@[priority 100]
instance preserves_finite_biproducts_of_additive [additive F] : preserves_finite_biproducts F :=
{ preserves := λ J _ _,
  { preserves := λ f,
    { preserves := λ b hb, by exactI is_bilimit_of_total _
      begin
        simp_rw [F.map_bicone_π, F.map_bicone_ι, ← F.map_comp, ← F.map_sum],
        dsimp only [map_bicone_X],
        simp_rw [← F.map_id],
        refine congr_arg _ (hb.is_limit.hom_ext (λ j, hb.is_colimit.hom_ext (λ j', _))),
        simp [sum_comp, comp_sum, bicone.ι_π, comp_dite, dite_comp]
      end } } }

lemma additive_of_preserves_binary_biproducts [has_binary_biproducts C] [preserves_zero_morphisms F]
  [preserves_binary_biproducts F] : additive F :=
{ map_add' := λ X Y f g, by rw [biprod.add_eq_lift_id_desc, F.map_comp, ← biprod.lift_map_biprod,
    ← biprod.map_biprod_hom_desc, category.assoc, iso.inv_hom_id_assoc, F.map_id,
    biprod.add_eq_lift_id_desc] }

end

end functor

namespace equivalence

variables {C D : Type*} [category C] [category D] [preadditive C] [preadditive D]

instance inverse_additive (e : C ≌ D) [e.functor.additive] : e.inverse.additive :=
{ map_add' := λ X Y f g, by { apply e.functor.map_injective, simp, }, }

end equivalence

section
variables (C D : Type*) [category C] [category D] [preadditive C] [preadditive D]

/-- Bundled additive functors. -/
@[derive category, nolint has_inhabited_instance]
def AdditiveFunctor :=
{ F : C ⥤ D // functor.additive F }

infixr ` ⥤+ `:26 := AdditiveFunctor

instance : preadditive (C ⥤+ D) :=
preadditive.induced_category.category _

/-- An additive functor is in particular a functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.forget : (C ⥤+ D) ⥤ (C ⥤ D) :=
full_subcategory_inclusion _

variables {C D}

/-- Turn an additive functor into an object of the category `AdditiveFunctor C D`. -/
def AdditiveFunctor.of (F : C ⥤ D) [F.additive] : C ⥤+ D :=
⟨F, infer_instance⟩

@[simp]
lemma AdditiveFunctor.of_fst (F : C ⥤ D) [F.additive] : (AdditiveFunctor.of F).1 = F :=
rfl

@[simp]
lemma AdditiveFunctor.forget_obj (F : C ⥤+ D) : (AdditiveFunctor.forget C D).obj F = F.1 :=
rfl

lemma AdditiveFunctor.forget_obj_of (F : C ⥤ D) [F.additive] :
  (AdditiveFunctor.forget C D).obj (AdditiveFunctor.of F) = F :=
rfl

@[simp]
lemma AdditiveFunctor.forget_map (F G : C ⥤+ D) (α : F ⟶ G) :
  (AdditiveFunctor.forget C D).map α = α :=
rfl

instance : functor.additive (AdditiveFunctor.forget C D) :=
{ map_add' := λ F G α β, rfl }

instance (F : C ⥤+ D) : functor.additive F.1 :=
F.2

end

end preadditive

end category_theory


/-
Copyright (c) 2022 Youjack. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Youjack
-/
import logic.equiv.transfer_instance
import math_lemma
import zeroth_law

/-!
# Thermodynamic Cycles and the FIRST Law

This file defines
* the notion of abstract thermodynamic `cycle`, which satisfies the first law
* some specific types of `cycle`s, including
  `one_rsv_cycle`, `abs_rel_cycle`, `engine_cycle` class,
  `usual_engine_cycle`, `usual_pump_cycle`
* the connection (`add`), scaling (`smul`), and reversion of `cycle`s
and proves
* some basic properties of the various types of `cycle`s
-/

noncomputable theory

namespace thermodynamics

/-!
## General abstract `cycle`

In the spirit of the first law, a thermodynamic `cycle` is a heat-work conversion.
* The abstract `cycle` defined here can be viewd of as the equivalence class of concrete cycles
  that have the same result of heat-work conversion.
* `cycle`s need not to satisfy the second law.
---------------------------------------------------------------------------------------------------/

/-- Abstrct `cycle` (denoted by `H`) :
    finitely many `𝓣`s PROVIDE heat `𝓠 𝓣`, and `H` DOES work `𝓦`, satisfying the first law -/
structure cycle :=
  (𝓠 : reservoir →₀ ℝ)
  (𝓦 : ℝ)
  (energy_conserv : 𝓠.sum_image - 𝓦 = 0)
--

namespace cycle
variables (H : cycle)

lemma 𝓦_from_𝓠 : H.𝓦 = H.𝓠.sum_image :=
  (sub_eq_zero.elim_left H.energy_conserv).symm
/-! Lemmas concerning `Qabs` and `Qrel` should use them as `ℝ`s. -/
/-- `abs`orbed heat `Qabs = ∑(+𝓠 > 0)` -/
def Qabs : nnreal :=
  { val := H.𝓠.support.sum (λ 𝓣, max (H.𝓠 𝓣) 0),
    property := by simp only [finset.sum_nonneg, le_max_iff, le_refl, or_true, implies_true_iff] }
/-- `rel`eased heat `Qrel = ∑(-𝓠 > 0)` -/
def Qrel : nnreal :=
  { val := H.𝓠.support.sum (λ 𝓣, max (- H.𝓠 𝓣) 0),
    property := by simp only [finset.sum_nonneg, le_max_iff, le_refl, or_true, implies_true_iff] }
lemma 𝓠_from_Qabs_Qrel : H.𝓠.sum_image = H.Qabs - H.Qrel := by {
  simp only [Qabs, Qrel, subtype.coe_mk],
  simp only [←finset.sum_sub_distrib, max_zero_sub_max_neg_zero_eq_self], }
lemma 𝓦_from_Qabs_Qrel : H.𝓦 = H.Qabs - H.Qrel :=
  eq.trans H.𝓦_from_𝓠 H.𝓠_from_Qabs_Qrel
lemma Qabs_from_𝓦_Qrel : ↑H.Qabs = H.𝓦 + H.Qrel :=
  calc H.Qabs.val
       = H.Qabs - H.Qrel + H.Qrel : by ring
    ...= H.𝓦 + H.Qrel            : by rw 𝓦_from_Qabs_Qrel
lemma Qrel_from_Qabs_𝓦 : ↑H.Qrel = ↑H.Qabs - H.𝓦 := by {
  apply eq.symm,
  rw 𝓦_from_Qabs_Qrel,
  ring, }
--

@[reducible] def equiv_𝓠 : (reservoir →₀ ℝ) ≃ cycle :=
  { to_fun  := λ 𝓠,
      { 𝓠 := 𝓠,
        𝓦 := 𝓠.sum_image,
        energy_conserv := sub_self _ },
    inv_fun := λ H, H.𝓠,
    left_inv  := λ _, rfl,
    right_inv := λ H, let ⟨_,_,energy_conserv⟩ := H in
      by simp [sub_eq_zero.elim_left energy_conserv] }
/-- `cycle` forms a `add_comm_group`.
* adding two `cycle`s means connecting them
* negating a `cycle` means reversing it
-/
instance : add_comm_group cycle := equiv.add_comm_group equiv_𝓠.symm
/-- `cycle` forms a real vector space.
* multiplying a `cycle` with `c ∈ ℝ` means scaling it `c` times
-/
instance : module ℝ       cycle := equiv.module ℝ      equiv_𝓠.symm

variables {H} {H₁ H₂ : cycle} {c : ℝ}
@[simp] lemma 𝓦_add : (H₁ + H₂).𝓦 = H₁.𝓦 + H₂.𝓦 :=
  calc (H₁ + H₂).𝓦
       = (H₁.𝓠 + H₂.𝓠).sum_image         : 𝓦_from_𝓠 _
    ...= H₁.𝓠.sum_image + H₂.𝓠.sum_image : finsupp.sum_image_add
    ...= H₁.𝓦 + H₂.𝓦                    : by rw [𝓦_from_𝓠, 𝓦_from_𝓠]
@[simp] lemma 𝓦_smul : (c • H).𝓦 = c * H.𝓦 :=
  calc (c • H).𝓦
       = (c • H.𝓠).sum_image : 𝓦_from_𝓠 _
    ...= c * H.𝓠.sum_image   : finsupp.sum_image_smul
    ...= c * H.𝓦            : by rw 𝓦_from_𝓠
@[simp] lemma Qabs_smul_pos (hc : 0 < c) : ↑(c • H).Qabs = c * H.Qabs :=
  have hsupp : (c • H.𝓠).support = H.𝓠.support, from
    finsupp.support_smul_eq (ne_of_gt hc),
  have hmax : ∀ 𝓣, max (c • H.𝓠 𝓣) 0 = c • max (H.𝓠 𝓣) 0, from
    λ _, real.max_mul_nonneg_zero _ _ (le_of_lt hc),
  calc ↑(c • H).Qabs
       = (c • H.𝓠).support.sum (λ 𝓣, max (c • H.𝓠 𝓣) 0) : rfl
    ...= H.𝓠.support.sum (λ 𝓣, max (c • H.𝓠 𝓣) 0) : by rw hsupp
    ...= H.𝓠.support.sum (λ 𝓣, c • max (H.𝓠 𝓣) 0) : by rw (funext hmax)
    ...= c • H.𝓠.support.sum (λ 𝓣, max (H.𝓠 𝓣) 0) : by rw finset.smul_sum
    ...= c * H.Qabs : rfl
@[simp] lemma Qrel_smul_pos (hc : 0 < c) : ↑(c • H).Qrel = c * H.Qrel :=
  have hsupp : (c • H.𝓠).support = H.𝓠.support, from
    finsupp.support_smul_eq (ne_of_gt hc),
  have hmax : ∀ 𝓣, max (-(c • H.𝓠 𝓣)) 0 = c • max (- H.𝓠 𝓣) 0, by {
    assume 𝓣,
    have : -(c • H.𝓠 𝓣) = c * (- H.𝓠 𝓣), rw [smul_eq_mul, mul_neg], rw this,
    exact real.max_mul_nonneg_zero _ _ (le_of_lt hc), },
  calc ↑(c • H).Qrel
       = (c • H.𝓠).support.sum (λ 𝓣, max (-(c • H.𝓠 𝓣)) 0) : rfl
    ...= H.𝓠.support.sum (λ 𝓣, max (-(c • H.𝓠 𝓣)) 0) : by rw hsupp
    ...= H.𝓠.support.sum (λ 𝓣, c • max (- H.𝓠 𝓣 ) 0) : by rw (funext hmax)
    ...= c • H.𝓠.support.sum (λ 𝓣, max (- H.𝓠 𝓣 ) 0) : by rw finset.smul_sum
    ...= c * H.Qrel : rfl
lemma rev_Qabs : ((-H).Qabs:ℝ) = H.Qrel :=
  calc (-H).Qabs.val
       = (-H.𝓠).support.sum (λ 𝓣, max (- H.𝓠 𝓣) 0) : rfl
    ...=   H.𝓠 .support.sum (λ 𝓣, max (- H.𝓠 𝓣) 0) : by rw finsupp.support_neg
    ...= H.Qrel.val : rfl
lemma rev_Qrel : ((-H).Qrel:ℝ) = H.Qabs :=
  have hmax : ∀ 𝓣, max (- (-H.𝓠 𝓣)) 0 = max (H.𝓠 𝓣) 0, {
    assume _, rw neg_neg, },
  calc (-H).Qrel.val
       = (-H.𝓠).support.sum (λ 𝓣, max (- (-H.𝓠 𝓣)) 0) : rfl
    ...=   H.𝓠 .support.sum (λ 𝓣, max (- (-H.𝓠 𝓣)) 0) : by rw finsupp.support_neg
    ...=   H.𝓠 .support.sum (λ 𝓣, max (    H.𝓠 𝓣 ) 0) : by rw (funext hmax)
    ...= H.Qabs.val : rfl
--

end cycle

/-!
## Some types of abstract `cycle`s
---------------------------------------------------------------------------------------------------/

/-!
### `one_rsv_cycle`
-/

/-- `cycle` that exchanges heat with only one `reservoir` -/
structure one_rsv_cycle (𝓣 : reservoir) extends cycle :=
  (one_rsv : 𝓠.support = {𝓣})
--

namespace one_rsv_cycle
variables {𝓣 : reservoir} (H : one_rsv_cycle 𝓣)

lemma Qabs_one_rsv : ↑H.Qabs = max (H.𝓠 𝓣) 0 := by {
  simp only [cycle.Qabs, subtype.coe_mk],
  simp only [H.one_rsv, finset.sum_singleton], }
lemma Qrel_one_rsv : ↑H.Qrel = max (- H.𝓠 𝓣) 0 := by {
  simp only [cycle.Qrel, subtype.coe_mk],
  simp only [H.one_rsv, finset.sum_singleton], }
/-- `𝓦` is `conv`erted from/to one rsv. -/
lemma 𝓦_conv_one_rsv : H.𝓦 = H.𝓠 𝓣 := by {
  rw [H.𝓦_from_𝓠, finsupp.sum_image],
  simp only [H.one_rsv, finset.sum_singleton], }
--

lemma to_cycle_inj : function.injective (λ H : one_rsv_cycle 𝓣, H.to_cycle) :=
  λ ⟨_,_⟩ ⟨_,_⟩, by simp only [imp_self]
instance : has_smul ℝ₊ (one_rsv_cycle 𝓣) := ⟨λ c H,
  let H' := c.val • H.to_cycle in
  { one_rsv := by {
      have : H'.𝓠 = c.val • H.𝓠, from rfl, rw this,
      exact finsupp.support_smul_exact H.one_rsv c.ne_zero, },
    ..H' } ⟩
--

end one_rsv_cycle

/-!
### `abs_rel_cycle`
-/

/-- `cycle` that absorbs heat `Qabs > 0` from rsv `𝓐` and releases heat `Qrel > 0` to rsv `𝓡` -/
structure abs_rel_cycle (𝓐 𝓡 : reservoir) extends cycle :=
  (two_rsv : 𝓠.support = {𝓐, 𝓡} ∧ 𝓐 ≠ 𝓡)
  (do_abs_rsv : 0 < 𝓠 𝓐) -- does absorb  heat from `𝓐`
  (do_rel_rsv : 𝓠 𝓡 < 0) -- does release heat to   `𝓡`
--

namespace abs_rel_cycle
variables {𝓐 𝓡 : reservoir} (H : abs_rel_cycle 𝓐 𝓡)

lemma Qabs_one_rsv : ↑H.Qabs = H.𝓠 𝓐 := by {
  simp only [cycle.Qabs, subtype.coe_mk],
  simp only [H.two_rsv.elim_left, (finset.sum_pair H.two_rsv.elim_right)],
  simp [le_of_lt H.do_abs_rsv, le_of_lt H.do_rel_rsv], }
lemma Qrel_one_rsv : ↑H.Qrel = - H.𝓠 𝓡 := by {
  simp only [cycle.Qrel, subtype.coe_mk],
  simp only [H.two_rsv.elim_left, (finset.sum_pair H.two_rsv.elim_right)],
  simp [le_of_lt H.do_abs_rsv, le_of_lt H.do_rel_rsv], }
lemma do_abs : (0:ℝ) < H.Qabs :=
  calc H.Qabs.val
       = H.𝓠 𝓐 : H.Qabs_one_rsv
    ...> 0      : H.do_abs_rsv
lemma do_rel : (0:ℝ) < H.Qrel :=
  calc H.Qrel.val
       = - H.𝓠 𝓡 : H.Qrel_one_rsv
    ...> 0       : by simp [H.do_rel_rsv]
lemma 𝓦_from_two_rsv : H.𝓦 = (H.𝓠 𝓐) + (H.𝓠 𝓡) := by {
  rw [H.𝓦_from_Qabs_Qrel],
  rw [H.Qabs_one_rsv, H.Qrel_one_rsv],
  rw [sub_neg_eq_add], }
--

variables {H₁ H₂ : abs_rel_cycle 𝓐 𝓡}
lemma to_cycle_inj : function.injective (λ H : abs_rel_cycle 𝓐 𝓡, H.to_cycle) :=
  λ ⟨_,_,_,_⟩ ⟨_,_,_,_⟩, by simp only [imp_self]
lemma eq_of_Q_eq (habs : (H₁.Qabs:ℝ) = H₂.Qabs) (hrel : (H₁.Qrel:ℝ) = H₂.Qrel) : H₁ = H₂ := by {
  apply to_cycle_inj, apply cycle.equiv_𝓠.symm.injective,
  simp only [equiv.coe_fn_symm_mk],
  apply finsupp.ext_iff'.elim_right, split,
  { rw [H₁.two_rsv.elim_left, H₂.two_rsv.elim_left], },
  { rw H₁.two_rsv.elim_left,
    simp only [finset.mem_insert, finset.mem_singleton, forall_eq_or_imp, forall_eq],
    split,
    { rw [H₁.Qabs_one_rsv, H₂.Qabs_one_rsv] at habs,
      exact habs, },
    { rw [H₁.Qrel_one_rsv, H₂.Qrel_one_rsv] at hrel,
      exact neg_inj.elim_left hrel, } } }
lemma eq_of_Qabs_𝓦_eq (hQabs : (H₁.Qabs:ℝ) = H₂.Qabs) (h𝓦 : H₁.𝓦 = H₂.𝓦) : H₁ = H₂ := by {
  refine eq_of_Q_eq hQabs _,
  rw [H₁.𝓦_from_Qabs_Qrel, H₂.𝓦_from_Qabs_Qrel] at h𝓦,
  simp only [hQabs, sub_right_inj] at h𝓦,
  exact h𝓦, }
--

instance : has_add (abs_rel_cycle 𝓐 𝓡) := ⟨λ H₁ H₂, by {
  let H' := H₁.to_cycle + H₂.to_cycle,
  have do_abs_rsv := add_pos H₁.do_abs_rsv H₂.do_abs_rsv,
  have do_rel_rsv := add_neg H₁.do_rel_rsv H₂.do_rel_rsv,
  exact
  { two_rsv := by {
      refine ⟨_, H₁.two_rsv.elim_right⟩,
      have : H'.𝓠 = H₁.𝓠 + H₂.𝓠, from rfl, rw this,
      apply finsupp.support_add_exact,
      { simp only [finset.mem_insert, finset.mem_singleton, ne.def, forall_eq_or_imp, forall_eq],
        split,
          exact ne_of_gt do_abs_rsv,
          exact ne_of_lt do_rel_rsv, },
      { have : (H₁.𝓠.support ∪ H₂.𝓠.support) \ {𝓐, 𝓡} = ∅, {
          rw [H₁.two_rsv.elim_left, H₂.two_rsv.elim_left],
          ext, simp, tauto, },
        simp only [this, finset.not_mem_empty, is_empty.forall_iff, implies_true_iff], } },
    do_abs_rsv :=
      calc H'.𝓠 𝓐
           = H₁.𝓠 𝓐 + H₂.𝓠 𝓐 : rfl
        ...> 0                 : do_abs_rsv,
    do_rel_rsv :=
      calc H'.𝓠 𝓡
           = H₁.𝓠 𝓡 + H₂.𝓠 𝓡 : rfl
        ...< 0                : do_rel_rsv,
    ..H' } } ⟩
instance : add_comm_semigroup (abs_rel_cycle 𝓐 𝓡) :=
  function.injective.add_comm_semigroup
    (λ H, H.to_cycle)
    to_cycle_inj
    (λ _ _, rfl)
instance : has_smul ℝ₊ (abs_rel_cycle 𝓐 𝓡) := ⟨λ c H,
  let H' := c.val • H.to_cycle in
  { two_rsv := by {
      refine ⟨_, H.two_rsv.elim_right⟩,
      have : H'.𝓠 = c.val • H.𝓠, from rfl, rw this,
      exact finsupp.support_smul_exact H.two_rsv.elim_left c.ne_zero, },
    do_abs_rsv :=
      calc H'.𝓠 𝓐
           = c * (H.𝓠 𝓐) : rfl
        ...> 0            : mul_pos c.property H.do_abs_rsv,
    do_rel_rsv :=
      calc H'.𝓠 𝓡
           = c * (H.𝓠 𝓡) : rfl
        ...< 0            : mul_neg_of_pos_of_neg c.property H.do_rel_rsv,
    ..H' } ⟩
--

/-- The reverse of an `abs_rel_cycle 𝓐 𝓡` is an `abs_rel_cycle 𝓡 𝓐`. -/
def rev : abs_rel_cycle 𝓡 𝓐 :=
  { two_rsv :=
      ⟨ calc (-H.to_cycle).𝓠.support
             = (-H.𝓠).support : rfl
          ...= {𝓐, 𝓡} : by rw [H.𝓠.support_neg, H.two_rsv.elim_left]
          ...= {𝓡, 𝓐} : by{ext, simp only [finset.mem_insert, finset.mem_singleton], tauto},
        H.two_rsv.elim_right.symm ⟩,
    do_abs_rsv :=
      calc (-H.to_cycle).𝓠 𝓡
           = - H.𝓠 𝓡 : rfl
        ...= H.Qrel  : by rw H.Qrel_one_rsv
        ...> 0       : H.do_rel,
    do_rel_rsv :=
      calc (-H.to_cycle).𝓠 𝓐
           = - H.𝓠 𝓐 : rfl
        ...= - H.Qabs : by rw H.Qabs_one_rsv
        ...< 0        : neg_neg_of_pos H.do_abs,
    ..(-H.to_cycle) }
--

end abs_rel_cycle

/-!
### `engine_cycle` class
-/

/-- `cycle` that does positive work -/
class engine_cycle (H : cycle) :=
  (do_work : 0 < H.𝓦)
--

namespace cycle

variables (H : cycle) [engine_cycle H]

lemma engine_do_work : 0 < H.𝓦 := (infer_instance : engine_cycle H).do_work
/-- absorb heat `Qabs > 0` -/
lemma engine_do_abs : (0:ℝ) < H.Qabs := by {
  suffices : 0 ≠ H.Qabs.val, from lt_of_le_of_ne H.Qabs.property this,
  have :=
    calc H.Qabs.val
         = H.𝓦 + H.Qrel : by simp [H.𝓦_from_Qabs_Qrel]
      ...>        H.Qrel : by simp [H.engine_do_work]
      ...≥ 0             : H.Qrel.property,
  exact ne_of_lt this, }
--

/-- `eff`iciency of `engine_cycle` -/
def eff : ℝ := H.𝓦 / H.Qabs
lemma eff_pos    : 0 < H.eff := div_pos H.engine_do_work H.engine_do_abs
lemma eff_le_one : H.eff ≤ 1 := by {
  refine (@div_le_one ℝ _ _ _ H.engine_do_abs).elim_right _,
  calc H.𝓦
       = H.Qabs - H.Qrel : H.𝓦_from_Qabs_Qrel
    ...≤ H.Qabs          : by simp only [sub_le_self_iff, nnreal.zero_le_coe], }
lemma eff_from_Qabs_Qrel : H.eff = 1 - H.Qrel / H.Qabs :=
  calc H.eff
       =  H.𝓦            / H.Qabs         : rfl
    ...= (H.Qabs - H.Qrel)/ H.Qabs         : by rw H.𝓦_from_Qabs_Qrel
    ...= H.Qabs / H.Qabs - H.Qrel / H.Qabs : sub_div _ _ _
    ...= 1 - H.Qrel / H.Qabs               : by rw [div_self (ne_of_gt H.engine_do_abs)]
lemma 𝓦_from_eff_Qabs : H.𝓦 = H.eff * H.Qabs :=
  calc H.𝓦
       = H.𝓦 / H.Qabs * H.Qabs : eq.symm $ div_mul_cancel _ (ne_of_gt H.engine_do_abs)
    ...= H.eff * H.Qabs         : by rw eff
lemma Qabs_from_𝓦_eff : ↑H.Qabs = H.𝓦 / H.eff := by {
  have :=
    calc H.𝓦 / H.eff
         = H.𝓦 / H.𝓦 * H.Qabs : by { rw div_mul, refl }
      ...= H.Qabs               : by rw [div_self (ne_of_gt H.engine_do_work), one_mul],
  exact this.symm, }
--

variables (H₁ H₂ : cycle) [engine_cycle H₁] [engine_cycle H₂]
instance engine_add : engine_cycle (H₁ + H₂) :=
  ⟨ calc (H₁ + H₂).𝓦
         = H₁.𝓦 + H₂.𝓦 : cycle.𝓦_add
      ...> 0             : add_pos H₁.engine_do_work H₂.engine_do_work ⟩
variables (c : ℝ) [fact (0 < c)]
instance engine_smul_pos : engine_cycle (c • H) :=
  let hc := (infer_instance : fact (0 < c)).out in
  ⟨ calc (c • H).𝓦
         = c * H.𝓦 : cycle.𝓦_smul
      ...> 0        : mul_pos hc H.engine_do_work ⟩
lemma eff_smul_pos {c : ℝ} [fact (0 < c)] : (c • H).eff = H.eff :=
  let hc := (infer_instance : fact (0 < c)).out in
  calc (c • H).eff
       = (c • H).𝓦 / (c • H).Qabs : rfl
    ...= (c * H.𝓦) / (c * H.Qabs) : by rw [cycle.𝓦_smul, cycle.Qabs_smul_pos hc]
    ...= (c / c) * (H.𝓦 / H.Qabs) : mul_div_mul_comm _ _ _ _
    ...=            H.eff          : by rw [div_self (ne_of_gt hc), one_mul, eff]
--

end cycle

/-!
### `usual_engine_cycle`
-/

/-- `abs_rel_cycle` that abs from hotter `𝓗`, rel to colder `𝓒`, and does positive work -/
structure usual_engine_cycle {𝓗 𝓒} (_: 𝓒 < 𝓗) extends (abs_rel_cycle 𝓗 𝓒) :=
  (do_work : 0 < 𝓦)
--

namespace usual_engine_cycle
variables {𝓗 𝓒 : reservoir} {𝓒_lt_𝓗 : 𝓒 < 𝓗} (H : usual_engine_cycle 𝓒_lt_𝓗)

instance : engine_cycle H.to_cycle := ⟨H.do_work⟩
lemma eff_lt_one : H.eff < 1 := by {
  rw H.eff_from_Qabs_Qrel,
  simp only [sub_lt_self_iff],
  exact div_pos H.do_rel H.do_abs, }
lemma eff_from_𝓦_𝓠 : H.eff = H.𝓦 / (H.𝓠 𝓗) :=
  by rw [cycle.eff, H.Qabs_one_rsv]
lemma eff_from_𝓠 : H.eff = 1 - (- H.𝓠 𝓒)/(H.𝓠 𝓗) := by {
  have := H.eff_from_Qabs_Qrel,
  rw [H.Qabs_one_rsv, H.Qrel_one_rsv] at this,
  exact this, }
--

lemma to_abs_rel_cycle_inj :
  function.injective (λ H : usual_engine_cycle 𝓒_lt_𝓗, H.to_abs_rel_cycle) :=
  λ ⟨_,_⟩ ⟨_,_⟩, by simp only [imp_self]
/- lemma to_cycle_inj :
  function.injective (λ H : usual_engine_cycle 𝓒_lt_𝓗, H.to_cycle) :=
  λ ⟨⟨_,_,_,_⟩,_⟩ ⟨⟨_,_,_,_⟩,_⟩, by simp only [imp_self] -/
instance : has_add (usual_engine_cycle 𝓒_lt_𝓗) := ⟨λ H₁ H₂,
  { ..(H₁.to_abs_rel_cycle + H₂.to_abs_rel_cycle),
    ..(cycle.engine_add H₁.to_cycle H₂.to_cycle) } ⟩
instance : add_comm_semigroup (usual_engine_cycle 𝓒_lt_𝓗) :=
  function.injective.add_comm_semigroup
    (λ H, H.to_abs_rel_cycle)
    to_abs_rel_cycle_inj
    (λ _ _, rfl)
instance : has_smul ℝ₊ (usual_engine_cycle 𝓒_lt_𝓗) := ⟨λ c H,
  { ..(c • H.to_abs_rel_cycle),
    ..(@cycle.engine_smul_pos H.to_cycle _ _ ⟨c.property⟩) } ⟩
--

variables {H₁ H₂ : usual_engine_cycle 𝓒_lt_𝓗}
lemma eq_smul_pos_of_eff_eq : H₁.eff = H₂.eff → ∃ c : ℝ₊, H₁ = c • H₂ := by {
  let c : ℝ₊ :=
    { val := H₁.𝓦 / H₂.𝓦,
      property := div_pos H₁.do_work H₂.do_work },
  assume heff, refine ⟨c, _⟩,
  apply to_abs_rel_cycle_inj, apply abs_rel_cycle.eq_of_Qabs_𝓦_eq,
  calc (H₁.Qabs:ℝ)
       = H₁.𝓦 / H₁.𝓦 * H₁.Qabs : by rw [div_self (ne_of_gt H₁.engine_do_work), one_mul]
    ...= H₁.𝓦 / H₁.eff          : by { rw div_mul, refl }
    ...= H₁.𝓦 / H₂.𝓦 * H₂.Qabs : by { rw [heff, div_mul], refl }
    ...= c             * H₂.Qabs : rfl
    ...= (c • H₂).Qabs           : eq.symm $ cycle.Qabs_smul_pos c.property,
  calc H₁.𝓦
       = H₁.𝓦 / H₂.𝓦 * H₂.𝓦 : eq.symm $ div_mul_cancel _ (ne_of_gt H₂.engine_do_work)
    ...= c             * H₂.𝓦 : rfl
    ...= (c • H₂).𝓦           : eq.symm $ cycle.𝓦_smul, }
--

end usual_engine_cycle

/-!
### `usual_pump_cycle`
-/

/-- `abs_rel_cycle` that consumes work, abs from colder `𝓒`, and rel to hotter `𝓗` -/
structure usual_pump_cycle {𝓒 𝓗} (_: 𝓒 < 𝓗) extends (abs_rel_cycle 𝓒 𝓗) :=
  (consume_work : 𝓦 < 0)
--

namespace usual_pump_cycle
variables {𝓒 𝓗 : reservoir} {𝓒_lt_𝓗 : 𝓒 < 𝓗} (H : usual_pump_cycle 𝓒_lt_𝓗)

lemma to_abs_rel_cycle_inj :
  function.injective (λ H : usual_pump_cycle 𝓒_lt_𝓗, H.to_abs_rel_cycle) :=
  λ ⟨_,_⟩ ⟨_,_⟩, by simp only [imp_self]
/- lemma to_cycle_inj :
  function.injective (λ H : usual_pump_cycle 𝓒_lt_𝓗, H.to_cycle) :=
  λ ⟨⟨_,_,_,_⟩,_⟩ ⟨⟨_,_,_,_⟩,_⟩, by simp only [imp_self] -/
instance : has_add (usual_pump_cycle 𝓒_lt_𝓗) := ⟨λ H₁ H₂,
  let H' := H₁.to_abs_rel_cycle + H₂.to_abs_rel_cycle in
  { consume_work :=
      calc H'.𝓦
           = (H₁.to_cycle + H₂.to_cycle).𝓦 : rfl
        ...= H₁.𝓦 + H₂.𝓦                  : cycle.𝓦_add
        ...< 0                              : add_neg H₁.consume_work H₂.consume_work,
    ..H' } ⟩
instance : add_comm_semigroup (usual_pump_cycle 𝓒_lt_𝓗) :=
  function.injective.add_comm_semigroup
    (λ H, H.to_abs_rel_cycle)
    to_abs_rel_cycle_inj
    (λ _ _, rfl)
instance : has_smul ℝ₊ (usual_pump_cycle 𝓒_lt_𝓗) := ⟨λ c H,
  let H' := c • H.to_abs_rel_cycle in
  { consume_work :=
      calc H'.𝓦
           = (c.val • H.to_cycle).𝓦 : rfl
        ...= c * H.𝓦                : cycle.𝓦_smul
        ...< 0                       : mul_neg_of_pos_of_neg c.property H.consume_work,
    ..H' } ⟩
--

end usual_pump_cycle

/-!
### Reverse of `usual_engine_cycle` and `usual_pump_cycle`
-/

section rev_usual_engine_pump_cycle
variables {𝓒 𝓗 : reservoir} {𝓒_lt_𝓗 : 𝓒 < 𝓗}

/-- The reverse of an `usual_engine_cycle` is an `usual_pump_cycle`. -/
def usual_engine_cycle.rev (H : usual_engine_cycle 𝓒_lt_𝓗) : usual_pump_cycle 𝓒_lt_𝓗 :=
  { consume_work :=
      calc H.rev.𝓦
           =         (-H.to_cycle).𝓦 : rfl
        ...= ((-1:ℝ) • H.to_cycle).𝓦 : by rw [neg_one_smul]
        ...=                   - H.𝓦 : by rw [cycle.𝓦_smul, neg_one_mul]
        ...< 0                        : neg_neg_of_pos H.do_work,
    ..H.rev }
/-- The reverse of an `usual_pump_cycle` is an `usual_engine_cycle`. -/
def usual_pump_cycle.rev (H : usual_pump_cycle 𝓒_lt_𝓗) : usual_engine_cycle 𝓒_lt_𝓗 :=
  { do_work :=
      calc H.rev.𝓦
           =         (-H.to_cycle).𝓦 : rfl
        ...= ((-1:ℝ) • H.to_cycle).𝓦 : by rw [neg_one_smul]
        ...=                   - H.𝓦 : by rw [cycle.𝓦_smul, neg_one_mul]
        ...> 0                        : neg_pos_of_neg H.consume_work,
    ..H.rev }
--

end rev_usual_engine_pump_cycle

end thermodynamics


/-
Range check constraints.
-/
import starkware.cairo.lean.semantics.air_encoding.memory

noncomputable theory
open_locale big_operators

/- trace data -/

variables {F : Type*} [field F]

variables {n : ℕ} {a a' p : fin (n + 1) → F}

variables {z : F}

variables {rc_min rc_max : ℕ}

variable  {T : ℕ}

variables {off_op0_tilde
           off_op1_tilde
           off_dst_tilde
           rc16_vals       : fin T → F}

variables {embed_off_op0
           embed_off_op1
           embed_off_dst
           embed_rc16_vals : fin T → fin (n + 1)}

/- constraints -/

variable h_continuity :
  ∀ i : fin n, (a' i.succ - a' i.cast_succ) * (a' i.succ - a' i.cast_succ - 1) = 0

variable h_initial : (z - a' 0) * p 0 = z - a 0

variable h_cumulative : ∀ i : fin n, (z - a' i.succ) * p i.succ = (z - a i.succ) * p i.cast_succ

variable h_final : p (fin.last n) = 1

variable h_rc_min : a' 0 = rc_min

variable h_rc_max : a' (fin.last n) = rc_max

variable h_embed_op0 : ∀ i, a (embed_off_op0 i) = off_op0_tilde i

variable h_embed_op1 : ∀ i, a (embed_off_op1 i) = off_op1_tilde i

variable h_embed_dst : ∀ i, a (embed_off_dst i) = off_dst_tilde i

variable h_embed_rc : ∀ i, a (embed_rc16_vals i) = rc16_vals i

variable h_n_lt : n < ring_char F

variable h_rc_lt : rc_max < 2^16

variable h_rc_le : rc_min ≤ rc_max

variable h_ring_char_gt : 2^16 < ring_char F

section
include h_continuity h_rc_min

lemma rc_a'_eq (j : fin (n + 1)) : a' j = ↑(rc_min + a'_nat_offset a' j) :=
by rw [a'_nat_offset_spec h_continuity j, h_rc_min, nat.cast_add]

include h_rc_max h_rc_le h_rc_lt h_n_lt h_ring_char_gt

lemma rc_nat_offset_eq : rc_min + a'_nat_offset a' (fin.last n) = rc_max :=
begin
  have h₀ : (↑rc_min : F) + ↑(a'_nat_offset a' (fin.last n)) = ↑rc_min + ↑(rc_max - rc_min),
  { rw [←nat.cast_add, ←nat.cast_add, ←rc_a'_eq h_continuity h_rc_min, h_rc_max,
         nat.add_sub_of_le h_rc_le] },
  have h₁ : a'_nat_offset a' (fin.last n) < ring_char F :=
    lt_of_le_of_lt (a'_nat_offset_le _) h_n_lt,
  have h₂ : rc_max - rc_min < ring_char F :=
    lt_of_le_of_lt tsub_le_self (lt_trans h_rc_lt h_ring_char_gt),
  have := add_left_cancel h₀,
  rw nat.cast_inj_of_lt_char h₁ h₂ this,
  apply nat.add_sub_of_le h_rc_le
end

lemma rc_nat_offset_le (j : fin (n + 1)): rc_min + a'_nat_offset a' j ≤ rc_max :=
begin
  rw ←rc_nat_offset_eq h_continuity h_rc_min h_rc_max h_n_lt h_rc_lt h_rc_le h_ring_char_gt,
  apply add_le_add_left,
  apply monotone_a'_nat_offset,
  apply fin.le_last
end

end

section

variable [fintype F]

def bad_set_3 (a a' : fin (n + 1) → F) : finset F :=
polynomial_aux.exceptional_set a a'

theorem card_bad_set_3_le : (bad_set_3 a a').card ≤ n + 1 :=
by { transitivity, apply polynomial_aux.card_exceptional_set_le, simp }

theorem bad_set_3_spec {z : F}
    (h₁ : z ∉ bad_set_3 a a')
    (h₂ : ∏ i : fin (n + 1), (z - a i) = ∏ i, (z - a' i)) :
  ∀ i, ∃ j, a i = a' j :=
exceptional_set_spec _ _ h₁ h₂

theorem bad_set_3_spec' {z : F}
    (h₁ : z ∉ bad_set_3 a a')
    (h₂ : ∏ i : fin (n + 1), (z - a i) = ∏ i, (z - a' i)) :
  ∀ i, ∃ j, a' i = a j:=
exceptional_set_spec' _ _ h₁ h₂

end

section permutation

include h_initial h_cumulative

lemma rc_permutation_aux (j : fin (n + 1)) :
  ∏ i in fin.range j.succ, (z - a i) = (∏ i in fin.range j.succ, (z - a' i)) * p j :=
begin
  apply fin.induction_on j,
  { rw [←fin.one_eq_succ_zero, fin.prod_range_one, fin.prod_range_one, h_initial] },
  intros j ih,
  rw [fin.prod_range_succ, fin.prod_range_succ, ←fin.succ_cast_succ, ih, ←mul_assoc],
  conv { to_rhs, rw [mul_right_comm, h_cumulative, mul_right_comm] }
end

include h_final

lemma rc_permutation_prod_eq : ∏ i, (z - a i) = ∏ i, (z - a' i) :=
by rw [←fin.range_last, ←fin.succ_last, rc_permutation_aux h_initial h_cumulative, h_final, mul_one]

end permutation

variable [fintype F]

variable hprob₃ : z ∉ bad_set_3 a a'

lemma rc_permutation : ∀ i, ∃ j, a i = a' j :=
λ i, bad_set_3_spec hprob₃ (rc_permutation_prod_eq h_initial h_cumulative h_final) i

include h_continuity h_initial h_cumulative h_final hprob₃
include h_rc_min h_rc_max h_rc_le h_rc_lt h_n_lt h_ring_char_gt

section
include h_embed_op0

theorem off_op0_in_range (i : fin T) : ∃ k : ℕ, k < 2^16 ∧ off_op0_tilde i = ↑k :=
begin
  rcases (rc_permutation h_initial h_cumulative h_final hprob₃ (embed_off_op0 i)) with ⟨j, hj⟩,
  have : a' j = a' 0 + a'_nat_offset a' j := a'_nat_offset_spec h_continuity _,
  rw [this, h_embed_op0, h_rc_min, ←nat.cast_add] at hj,
  use [rc_min + a'_nat_offset a' j],
  split,
  { apply lt_of_le_of_lt _ h_rc_lt,
    apply rc_nat_offset_le h_continuity h_rc_min h_rc_max h_n_lt h_rc_lt h_rc_le h_ring_char_gt },
  exact hj
end
end

theorem off_op1_in_range (i : fin T) : ∃ k : ℕ, k < 2^16 ∧ off_op1_tilde i = ↑k :=
off_op0_in_range h_continuity h_initial h_cumulative h_final h_rc_min
  h_rc_max h_embed_op1 h_n_lt h_rc_lt h_rc_le h_ring_char_gt hprob₃ i

theorem off_dst_in_range (i : fin T) : ∃ k : ℕ, k < 2^16 ∧ off_dst_tilde i = ↑k :=
off_op0_in_range h_continuity h_initial h_cumulative h_final h_rc_min
  h_rc_max h_embed_dst h_n_lt h_rc_lt h_rc_le h_ring_char_gt hprob₃ i

theorem rc16_vals_in_range (i : fin T) : ∃ k : ℕ, k < 2^16 ∧ rc16_vals i = ↑k :=
off_op0_in_range h_continuity h_initial h_cumulative h_final h_rc_min
  h_rc_max h_embed_rc h_n_lt h_rc_lt h_rc_le h_ring_char_gt hprob₃ i


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.sheaves.local_predicate
import Mathlib.topology.sheaves.stalks
import Mathlib.PostPort

universes v

namespace Mathlib

/-!
# Sheafification of `Type` valued presheaves

We construct the sheafification of a `Type` valued presheaf,
as the subsheaf of dependent functions into the stalks
consisting of functions which are locally germs.

We show that the stalks of the sheafification are isomorphic to the original stalks,
via `stalk_to_fiber` which evaluates a germ of a dependent function at a point.

We construct a morphism `to_sheafify` from a presheaf to (the underlying presheaf of)
its sheafification, given by sending a section to its collection of germs.

## Future work
Show that the map induced on stalks by `to_sheafify` is the inverse of `stalk_to_fiber`.

Show sheafification is a functor from presheaves to sheaves,
and that it is the left adjoint of the forgetful functor,
following https://stacks.math.columbia.edu/tag/007X.
-/

namespace Top.presheaf

namespace sheafify

/--
The prelocal predicate on functions into the stalks, asserting that the function is equal to a germ.
-/
def is_germ {X : Top} (F : presheaf (Type v) X) : prelocal_predicate fun (x : ↥X) => stalk F x :=
  prelocal_predicate.mk
    (fun (U : topological_space.opens ↥X) (f : (x : ↥U) → stalk F ↑x) =>
      ∃ (g : category_theory.functor.obj F (opposite.op U)), ∀ (x : ↥U), f x = germ F x g)
    sorry

/--
The local predicate on functions into the stalks,
asserting that the function is locally equal to a germ.
-/
def is_locally_germ {X : Top} (F : presheaf (Type v) X) : local_predicate fun (x : ↥X) => stalk F x :=
  prelocal_predicate.sheafify (is_germ F)

end sheafify

/--
The sheafification of a `Type` valued presheaf, defined as the functions into the stalks which
are locally equal to germs.
-/
def sheafify {X : Top} (F : presheaf (Type v) X) : sheaf (Type v) X :=
  subsheaf_to_Types sorry

/--
The morphism from a presheaf to its sheafification,
sending each section to its germs.
(This forms the unit of the adjunction.)
-/
def to_sheafify {X : Top} (F : presheaf (Type v) X) : F ⟶ sheaf.presheaf (sheafify F) :=
  category_theory.nat_trans.mk
    fun (U : topological_space.opens ↥Xᵒᵖ) (f : category_theory.functor.obj F U) =>
      { val := fun (x : ↥(opposite.unop U)) => germ F x f, property := sorry }

/--
The natural morphism from the stalk of the sheafification to the original stalk.
In `sheafify_stalk_iso` we show this is an isomorphism.
-/
def stalk_to_fiber {X : Top} (F : presheaf (Type v) X) (x : ↥X) : stalk (sheaf.presheaf (sheafify F)) x ⟶ stalk F x :=
  stalk_to_fiber (sheafify.is_locally_germ F) x

theorem stalk_to_fiber_surjective {X : Top} (F : presheaf (Type v) X) (x : ↥X) : function.surjective (stalk_to_fiber F x) := sorry

theorem stalk_to_fiber_injective {X : Top} (F : presheaf (Type v) X) (x : ↥X) : function.injective (stalk_to_fiber F x) := sorry

/--
The isomorphism betweeen a stalk of the sheafification and the original stalk.
-/
def sheafify_stalk_iso {X : Top} (F : presheaf (Type v) X) (x : ↥X) : stalk (sheaf.presheaf (sheafify F)) x ≅ stalk F x :=
  equiv.to_iso (equiv.of_bijective (stalk_to_fiber F x) sorry)