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

import algebra.quotient
import group_theory.subgroup.basic

/-!
# Cosets

This file develops the basic theory of left and right cosets.

## Main definitions

* `left_coset a s`: the left coset `a * s` for an element `a : α` and a subset `s ⊆ α`, for an
  `add_group` this is `left_add_coset a s`.
* `right_coset s a`: the right coset `s * a` for an element `a : α` and a subset `s ⊆ α`, for an
  `add_group` this is `right_add_coset s a`.
* `quotient_group.quotient s`: the quotient type representing the left cosets with respect to a
  subgroup `s`, for an `add_group` this is `quotient_add_group.quotient s`.
* `quotient_group.mk`: the canonical map from `α` to `α/s` for a subgroup `s` of `α`, for an
  `add_group` this is `quotient_add_group.mk`.
* `subgroup.left_coset_equiv_subgroup`: the natural bijection between a left coset and the subgroup,
  for an `add_group` this is `add_subgroup.left_coset_equiv_add_subgroup`.

## Notation

* `a *l s`: for `left_coset a s`.
* `a +l s`: for `left_add_coset a s`.
* `s *r a`: for `right_coset s a`.
* `s +r a`: for `right_add_coset s a`.

* `G ⧸ H` is the quotient of the (additive) group `G` by the (additive) subgroup `H`

## TODO

Add `to_additive` to `preimage_mk_equiv_subgroup_times_set`.
-/

open set function

variable {α : Type*}

/-- The left coset `a * s` for an element `a : α` and a subset `s : set α` -/
@[to_additive left_add_coset "The left coset `a+s` for an element `a : α`
and a subset `s : set α`"]
def left_coset [has_mul α] (a : α) (s : set α) : set α := (λ x, a * x) '' s

/-- The right coset `s * a` for an element `a : α` and a subset `s : set α` -/
@[to_additive right_add_coset "The right coset `s+a` for an element `a : α`
and a subset `s : set α`"]
def right_coset [has_mul α] (s : set α) (a : α) : set α := (λ x, x * a) '' s

localized "infix ` *l `:70 := left_coset" in coset
localized "infix ` +l `:70 := left_add_coset" in coset
localized "infix ` *r `:70 := right_coset" in coset
localized "infix ` +r `:70 := right_add_coset" in coset

section coset_mul
variable [has_mul α]

@[to_additive mem_left_add_coset]
lemma mem_left_coset {s : set α} {x : α} (a : α) (hxS : x ∈ s) : a * x ∈ a *l s :=
mem_image_of_mem (λ b : α, a * b) hxS

@[to_additive mem_right_add_coset]
lemma mem_right_coset {s : set α} {x : α} (a : α) (hxS : x ∈ s) : x * a ∈ s *r a :=
mem_image_of_mem (λ b : α, b * a) hxS

/-- Equality of two left cosets `a * s` and `b * s`. -/
@[to_additive left_add_coset_equivalence "Equality of two left cosets `a + s` and `b + s`."]
def left_coset_equivalence (s : set α) (a b : α) := a *l s = b *l s

@[to_additive left_add_coset_equivalence_rel]
lemma left_coset_equivalence_rel (s : set α) : equivalence (left_coset_equivalence s) :=
mk_equivalence (left_coset_equivalence s) (λ a, rfl) (λ a b, eq.symm) (λ a b c, eq.trans)

/-- Equality of two right cosets `s * a` and `s * b`. -/
@[to_additive right_add_coset_equivalence "Equality of two right cosets `s + a` and `s + b`."]
def right_coset_equivalence (s : set α) (a b : α) := s *r a = s *r b

@[to_additive right_add_coset_equivalence_rel]
lemma right_coset_equivalence_rel (s : set α) : equivalence (right_coset_equivalence s) :=
mk_equivalence (right_coset_equivalence s) (λ a, rfl) (λ a b, eq.symm) (λ a b c, eq.trans)

end coset_mul

section coset_semigroup
variable [semigroup α]

@[simp, to_additive left_add_coset_assoc] lemma left_coset_assoc (s : set α) (a b : α) :
  a *l (b *l s) = (a * b) *l s :=
by simp [left_coset, right_coset, (image_comp _ _ _).symm, function.comp, mul_assoc]

@[simp, to_additive right_add_coset_assoc] lemma right_coset_assoc (s : set α) (a b : α) :
  s *r a *r b = s *r (a * b) :=
by simp [left_coset, right_coset, (image_comp _ _ _).symm, function.comp, mul_assoc]

@[to_additive left_add_coset_right_add_coset]
lemma left_coset_right_coset (s : set α) (a b : α) : a *l s *r b = a *l (s *r b) :=
by simp [left_coset, right_coset, (image_comp _ _ _).symm, function.comp, mul_assoc]

end coset_semigroup

section coset_monoid
variables [monoid α] (s : set α)

@[simp, to_additive zero_left_add_coset] lemma one_left_coset : 1 *l s = s :=
set.ext $ by simp [left_coset]

@[simp, to_additive right_add_coset_zero] lemma right_coset_one : s *r 1 = s :=
set.ext $ by simp [right_coset]

end coset_monoid

section coset_submonoid
open submonoid
variables [monoid α] (s : submonoid α)

@[to_additive mem_own_left_add_coset]
lemma mem_own_left_coset (a : α) : a ∈ a *l s :=
suffices a * 1 ∈ a *l s, by simpa,
mem_left_coset a (one_mem s)

@[to_additive mem_own_right_add_coset]
lemma mem_own_right_coset (a : α) : a ∈ (s : set α) *r a :=
suffices 1 * a ∈ (s : set α) *r a, by simpa,
mem_right_coset a (one_mem s)

@[to_additive mem_left_add_coset_left_add_coset]
lemma mem_left_coset_left_coset {a : α} (ha : a *l s = s) : a ∈ s :=
by rw [←set_like.mem_coe, ←ha]; exact mem_own_left_coset s a

@[to_additive mem_right_add_coset_right_add_coset]
lemma mem_right_coset_right_coset {a : α} (ha : (s : set α) *r a = s) : a ∈ s :=
by rw [←set_like.mem_coe, ←ha]; exact mem_own_right_coset s a

end coset_submonoid

section coset_group
variables [group α] {s : set α} {x : α}

@[to_additive mem_left_add_coset_iff]
lemma mem_left_coset_iff (a : α) : x ∈ a *l s ↔ a⁻¹ * x ∈ s :=
iff.intro
  (assume ⟨b, hb, eq⟩, by simp [eq.symm, hb])
  (assume h, ⟨a⁻¹ * x, h, by simp⟩)

@[to_additive mem_right_add_coset_iff]
lemma mem_right_coset_iff (a : α) : x ∈ s *r a ↔ x * a⁻¹ ∈ s :=
iff.intro
  (assume ⟨b, hb, eq⟩, by simp [eq.symm, hb])
  (assume h, ⟨x * a⁻¹, h, by simp⟩)

end coset_group

section coset_subgroup
open subgroup

variables [group α] (s : subgroup α)

@[to_additive left_add_coset_mem_left_add_coset]
lemma left_coset_mem_left_coset {a : α} (ha : a ∈ s) : a *l s = s :=
set.ext $ by simp [mem_left_coset_iff, mul_mem_cancel_left s (s.inv_mem ha)]

@[to_additive right_add_coset_mem_right_add_coset]
lemma right_coset_mem_right_coset {a : α} (ha : a ∈ s) : (s : set α) *r a = s :=
set.ext $ assume b, by simp [mem_right_coset_iff, mul_mem_cancel_right s (s.inv_mem ha)]

@[to_additive eq_add_cosets_of_normal]
theorem eq_cosets_of_normal (N : s.normal) (g : α) : g *l s = s *r g :=
set.ext $ assume a, by simp [mem_left_coset_iff, mem_right_coset_iff]; rw [N.mem_comm_iff]

@[to_additive normal_of_eq_add_cosets]
theorem normal_of_eq_cosets (h : ∀ g : α, g *l s = s *r g) : s.normal :=
⟨assume a ha g, show g * a * g⁻¹ ∈ (s : set α),
  by rw [← mem_right_coset_iff, ← h]; exact mem_left_coset g ha⟩

@[to_additive normal_iff_eq_add_cosets]
theorem normal_iff_eq_cosets : s.normal ↔ ∀ g : α, g *l s = s *r g :=
⟨@eq_cosets_of_normal _ _ s, normal_of_eq_cosets s⟩

@[to_additive left_add_coset_eq_iff]
lemma left_coset_eq_iff {x y : α} : left_coset x s = left_coset y s ↔ x⁻¹ * y ∈ s :=
begin
  rw set.ext_iff,
  simp_rw [mem_left_coset_iff, set_like.mem_coe],
  split,
  { intro h, apply (h y).mpr, rw mul_left_inv, exact s.one_mem },
  { intros h z, rw ←mul_inv_cancel_right x⁻¹ y, rw mul_assoc, exact s.mul_mem_cancel_left h },
end

@[to_additive right_add_coset_eq_iff]
lemma right_coset_eq_iff {x y : α} : right_coset ↑s x = right_coset s y ↔ y * x⁻¹ ∈ s :=
begin
  rw set.ext_iff,
  simp_rw [mem_right_coset_iff, set_like.mem_coe],
  split,
  { intro h, apply (h y).mpr, rw mul_right_inv, exact s.one_mem },
  { intros h z, rw ←inv_mul_cancel_left y x⁻¹, rw ←mul_assoc, exact s.mul_mem_cancel_right h },
end

end coset_subgroup

run_cmd to_additive.map_namespace `quotient_group `quotient_add_group

namespace quotient_group

variables [group α] (s : subgroup α)

/-- The equivalence relation corresponding to the partition of a group by left cosets
of a subgroup.-/
@[to_additive "The equivalence relation corresponding to the partition of a group by left cosets
of a subgroup."]
def left_rel : setoid α :=
⟨λ x y, x⁻¹ * y ∈ s, by { simp_rw ←left_coset_eq_iff, exact left_coset_equivalence_rel s }⟩

lemma left_rel_r_eq_left_coset_equivalence :
  @setoid.r _ (quotient_group.left_rel s) = left_coset_equivalence s :=
by { ext, exact (left_coset_eq_iff s).symm }

@[to_additive]
instance left_rel_decidable [decidable_pred (∈ s)] :
  decidable_rel (left_rel s).r := λ x y, ‹decidable_pred (∈ s)› _

/-- `α ⧸ s` is the quotient type representing the left cosets of `s`.
  If `s` is a normal subgroup, `α ⧸ s` is a group -/
@[to_additive "`α ⧸ s` is the quotient type representing the left cosets of `s`.  If `s` is a
normal subgroup, `α ⧸ s` is a group"]
instance : has_quotient α (subgroup α) := ⟨λ s, quotient (left_rel s)⟩

/-- The equivalence relation corresponding to the partition of a group by right cosets of a
subgroup. -/
@[to_additive "The equivalence relation corresponding to the partition of a group by right cosets of
a subgroup."]
def right_rel : setoid α :=
⟨λ x y, y * x⁻¹ ∈ s, by { simp_rw ←right_coset_eq_iff, exact right_coset_equivalence_rel s }⟩

lemma right_rel_r_eq_right_coset_equivalence :
  @setoid.r _ (quotient_group.right_rel s) = right_coset_equivalence s :=
by { ext, exact (right_coset_eq_iff s).symm }

@[to_additive]
instance right_rel_decidable [decidable_pred (∈ s)] :
  decidable_rel (right_rel s).r := λ x y, ‹decidable_pred (∈ s)› _

end quotient_group

namespace quotient_group

variables [group α] {s : subgroup α}

@[to_additive]
instance fintype [fintype α] (s : subgroup α) [decidable_rel (left_rel s).r] :
  fintype (α ⧸ s) :=
quotient.fintype (left_rel s)

/-- The canonical map from a group `α` to the quotient `α ⧸ s`. -/
@[to_additive "The canonical map from an `add_group` `α` to the quotient `α ⧸ s`."]
abbreviation mk (a : α) : α ⧸ s :=
quotient.mk' a

@[elab_as_eliminator, to_additive]
lemma induction_on {C : α ⧸ s → Prop} (x : α ⧸ s)
  (H : ∀ z, C (quotient_group.mk z)) : C x :=
quotient.induction_on' x H

@[to_additive]
instance : has_coe_t α (α ⧸ s) := ⟨mk⟩ -- note [use has_coe_t]

@[elab_as_eliminator, to_additive]
lemma induction_on' {C : α ⧸ s → Prop} (x : α ⧸ s)
  (H : ∀ z : α, C z) : C x :=
quotient.induction_on' x H

@[to_additive]
lemma forall_coe {C : α ⧸ s → Prop} :
  (∀ x : α ⧸ s, C x) ↔ ∀ x : α, C x :=
⟨λ hx x, hx _, quot.ind⟩

@[to_additive]
instance (s : subgroup α) : inhabited (α ⧸ s) :=
⟨((1 : α) : α ⧸ s)⟩

@[to_additive quotient_add_group.eq]
protected lemma eq {a b : α} : (a : α ⧸ s) = b ↔ a⁻¹ * b ∈ s :=
quotient.eq'

@[to_additive quotient_add_group.eq']
lemma eq' {a b : α} : (mk a : α ⧸ s) = mk b ↔ a⁻¹ * b ∈ s :=
quotient_group.eq

@[to_additive quotient_add_group.out_eq']
lemma out_eq' (a : α ⧸ s) : mk a.out' = a :=
quotient.out_eq' a

variables (s)

/- It can be useful to write `obtain ⟨h, H⟩ := mk_out'_eq_mul ...`, and then `rw [H]` or
  `simp_rw [H]` or `simp only [H]`. In order for `simp_rw` and `simp only` to work, this lemma is
  stated in terms of an arbitrary `h : s`, rathern that the specific `h = g⁻¹ * (mk g).out'`. -/
@[to_additive quotient_add_group.mk_out'_eq_mul]
lemma mk_out'_eq_mul (g : α) : ∃ h : s, (mk g : α ⧸ s).out' = g * h :=
⟨⟨g⁻¹ * (mk g).out', eq'.mp (mk g).out_eq'.symm⟩, by rw [s.coe_mk, mul_inv_cancel_left]⟩

variables {s}

@[to_additive quotient_add_group.mk_mul_of_mem]
lemma mk_mul_of_mem (g₁ g₂ : α) (hg₂ : g₂ ∈ s) : (mk (g₁ * g₂) : α ⧸ s) = mk g₁ :=
by rwa [eq', mul_inv_rev, inv_mul_cancel_right, s.inv_mem_iff]

@[to_additive]
lemma eq_class_eq_left_coset (s : subgroup α) (g : α) :
  {x : α | (x : α ⧸ s) = g} = left_coset g s :=
set.ext $ λ z,
  by rw [mem_left_coset_iff, set.mem_set_of_eq, eq_comm, quotient_group.eq, set_like.mem_coe]

@[to_additive]
lemma preimage_image_coe (N : subgroup α) (s : set α) :
  coe ⁻¹' ((coe : α → α ⧸ N) '' s) = ⋃ x : N, (λ y : α, y * x) ⁻¹' s :=
begin
  ext x,
  simp only [quotient_group.eq, set_like.exists, exists_prop, set.mem_preimage, set.mem_Union,
    set.mem_image, subgroup.coe_mk, ← eq_inv_mul_iff_mul_eq],
  exact ⟨λ ⟨y, hs, hN⟩, ⟨_, N.inv_mem hN, by simpa using hs⟩,
         λ ⟨z, hz, hxz⟩, ⟨x*z, hxz, by simpa using hz⟩⟩,
end

end quotient_group

namespace subgroup
open quotient_group
variables [group α] {s : subgroup α}

/-- The natural bijection between a left coset `g * s` and `s`. -/
@[to_additive "The natural bijection between the cosets `g + s` and `s`."]
def left_coset_equiv_subgroup (g : α) : left_coset g s ≃ s :=
⟨λ x, ⟨g⁻¹ * x.1, (mem_left_coset_iff _).1 x.2⟩,
 λ x, ⟨g * x.1, x.1, x.2, rfl⟩,
 λ ⟨x, hx⟩, subtype.eq $ by simp,
 λ ⟨g, hg⟩, subtype.eq $ by simp⟩

/-- The natural bijection between a right coset `s * g` and `s`. -/
@[to_additive "The natural bijection between the cosets `s + g` and `s`."]
def right_coset_equiv_subgroup (g : α) : right_coset ↑s g ≃ s :=
⟨λ x, ⟨x.1 * g⁻¹, (mem_right_coset_iff _).1 x.2⟩,
 λ x, ⟨x.1 * g, x.1, x.2, rfl⟩,
 λ ⟨x, hx⟩, subtype.eq $ by simp,
 λ ⟨g, hg⟩, subtype.eq $ by simp⟩

/-- A (non-canonical) bijection between a group `α` and the product `(α/s) × s` -/
@[to_additive "A (non-canonical) bijection between an add_group `α` and the product `(α/s) × s`"]
noncomputable def group_equiv_quotient_times_subgroup :
  α ≃ (α ⧸ s) × s :=
calc α ≃ Σ L : α ⧸ s, {x : α // (x : α ⧸ s) = L} :
  (equiv.sigma_preimage_equiv quotient_group.mk).symm
    ... ≃ Σ L : α ⧸ s, left_coset (quotient.out' L) s :
  equiv.sigma_congr_right (λ L,
    begin
      rw ← eq_class_eq_left_coset,
      show _root_.subtype (λ x : α, quotient.mk' x = L) ≃
        _root_.subtype (λ x : α, quotient.mk' x = quotient.mk' _),
      simp [-quotient.eq'],
    end)
    ... ≃ Σ L : α ⧸ s, s :
  equiv.sigma_congr_right (λ L, left_coset_equiv_subgroup _)
    ... ≃ (α ⧸ s) × s :
  equiv.sigma_equiv_prod _ _

variables {t : subgroup α}

/-- If `H ≤ K`, then `G/H ≃ G/K × K/H` constructively, using the provided right inverse
of the quotient map `G → G/K`. The classical version is `quotient_equiv_prod_of_le`. -/
@[to_additive "If `H ≤ K`, then `G/H ≃ G/K × K/H` constructively, using the provided right inverse
of the quotient map `G → G/K`. The classical version is `quotient_equiv_prod_of_le`.", simps]
def quotient_equiv_prod_of_le' (h_le : s ≤ t)
  (f : α ⧸ t → α) (hf : function.right_inverse f quotient_group.mk) :
  α ⧸ s ≃ (α ⧸ t) × (t ⧸ s.subgroup_of t) :=
{ to_fun := λ a, ⟨a.map' id (λ b c h, h_le h),
    a.map' (λ g : α, ⟨(f (quotient.mk' g))⁻¹ * g, quotient.exact' (hf g)⟩) (λ b c h, by
    { change ((f b)⁻¹ * b)⁻¹ * ((f c)⁻¹ * c) ∈ s,
      have key : f b = f c := congr_arg f (quotient.sound' (h_le h)),
      rwa [key, mul_inv_rev, inv_inv, mul_assoc, mul_inv_cancel_left] })⟩,
  inv_fun := λ a, a.2.map' (λ b, f a.1 * b) (λ b c h, by
  { change (f a.1 * b)⁻¹ * (f a.1 * c) ∈ s,
    rwa [mul_inv_rev, mul_assoc, inv_mul_cancel_left] }),
  left_inv := by
  { refine quotient.ind' (λ a, _),
    simp_rw [quotient.map'_mk', id.def, t.coe_mk, mul_inv_cancel_left] },
  right_inv := by
  { refine prod.rec _,
    refine quotient.ind' (λ a, _),
    refine quotient.ind' (λ b, _),
    have key : quotient.mk' (f (quotient.mk' a) * b) = quotient.mk' a :=
      (quotient_group.mk_mul_of_mem (f a) ↑b b.2).trans (hf a),
    simp_rw [quotient.map'_mk', id.def, key, inv_mul_cancel_left, subtype.coe_eta] } }

/-- If `H ≤ K`, then `G/H ≃ G/K × K/H` nonconstructively.
The constructive version is `quotient_equiv_prod_of_le'`. -/
@[to_additive "If `H ≤ K`, then `G/H ≃ G/K × K/H` nonconstructively.
The constructive version is `quotient_equiv_prod_of_le'`.", simps]
noncomputable def quotient_equiv_prod_of_le (h_le : s ≤ t) :
  α ⧸ s ≃ (α ⧸ t) × (t ⧸ s.subgroup_of t) :=
quotient_equiv_prod_of_le' h_le quotient.out' quotient.out_eq'

@[to_additive] lemma card_eq_card_quotient_mul_card_subgroup
  [fintype α] (s : subgroup α) [fintype s] [decidable_pred (λ a, a ∈ s)] :
  fintype.card α = fintype.card (α ⧸ s) * fintype.card s :=
by rw ← fintype.card_prod;
  exact fintype.card_congr (subgroup.group_equiv_quotient_times_subgroup)

/-- **Order of a Subgroup** -/
@[to_additive] lemma card_subgroup_dvd_card [fintype α] (s : subgroup α) [fintype s] :
  fintype.card s ∣ fintype.card α :=
by classical; simp [card_eq_card_quotient_mul_card_subgroup s, @dvd_mul_left ℕ]

@[to_additive] lemma card_quotient_dvd_card [fintype α] (s : subgroup α)
  [decidable_pred (λ a, a ∈ s)] [fintype s] : fintype.card (α ⧸ s) ∣ fintype.card α :=
by simp [card_eq_card_quotient_mul_card_subgroup s, @dvd_mul_right ℕ]

open fintype

variables {H : Type*} [group H]

@[to_additive] lemma card_dvd_of_injective [fintype α] [fintype H] (f : α →* H)
  (hf : function.injective f) : card α ∣ card H :=
by classical;
calc card α = card (f.range : subgroup H) : card_congr (equiv.of_injective f hf)
...∣ card H : card_subgroup_dvd_card _

@[to_additive] lemma card_dvd_of_le {H K : subgroup α} [fintype H] [fintype K] (hHK : H ≤ K) :
  card H ∣ card K :=
card_dvd_of_injective (inclusion hHK) (inclusion_injective hHK)

@[to_additive] lemma card_comap_dvd_of_injective (K : subgroup H) [fintype K]
  (f : α →* H) [fintype (K.comap f)] (hf : function.injective f) :
  fintype.card (K.comap f) ∣ fintype.card K :=
by haveI : fintype ((K.comap f).map f) :=
  fintype.of_equiv _ (equiv_map_of_injective _ _ hf).to_equiv;
calc fintype.card (K.comap f) = fintype.card ((K.comap f).map f) :
       fintype.card_congr (equiv_map_of_injective _ _ hf).to_equiv
... ∣ fintype.card K : card_dvd_of_le (map_comap_le _ _)

end subgroup

namespace quotient_group

variables [group α]

-- FIXME -- why is there no `to_additive`?

/-- If `s` is a subgroup of the group `α`, and `t` is a subset of `α/s`, then
there is a (typically non-canonical) bijection between the preimage of `t` in
`α` and the product `s × t`. -/
noncomputable def preimage_mk_equiv_subgroup_times_set
  (s : subgroup α) (t : set (α ⧸ s)) : quotient_group.mk ⁻¹' t ≃ s × t :=
have h : ∀ {x : α ⧸ s} {a : α}, x ∈ t → a ∈ s →
  (quotient.mk' (quotient.out' x * a) : α ⧸ s) = quotient.mk' (quotient.out' x) :=
    λ x a hx ha, quotient.sound' (show (quotient.out' x * a)⁻¹ * quotient.out' x ∈ s,
      from (s.inv_mem_iff).1 $
        by rwa [mul_inv_rev, inv_inv, ← mul_assoc, inv_mul_self, one_mul]),
{ to_fun := λ ⟨a, ha⟩, ⟨⟨(quotient.out' (quotient.mk' a))⁻¹ * a,
    @quotient.exact' _ (left_rel s) _ _ $ (quotient.out_eq' _)⟩,
      ⟨quotient.mk' a, ha⟩⟩,
  inv_fun := λ ⟨⟨a, ha⟩, ⟨x, hx⟩⟩, ⟨quotient.out' x * a, show quotient.mk' _ ∈ t,
    by simp [h hx ha, hx]⟩,
  left_inv := λ ⟨a, ha⟩, subtype.eq $ show _ * _ = a, by simp,
  right_inv := λ ⟨⟨a, ha⟩, ⟨x, hx⟩⟩, show (_, _) = _, by simp [h hx ha] }

end quotient_group

/--
We use the class `has_coe_t` instead of `has_coe` if the first argument is a variable,
or if the second argument is a variable not occurring in the first.
Using `has_coe` would cause looping of type-class inference. See
<https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/remove.20all.20instances.20with.20variable.20domain>
-/
library_note "use has_coe_t"


set_option trace.simplify.rewrite true
open nat
open classical

lemma fst_of_two_props :
∀a b : Prop, a → b → a :=
assume a b : Prop,
assume ha : a,
assume hb : b,
show a, from
ha

lemma prop_comp (a b c : Prop) (hab : a → b) (hbc : b → c) :
a → c :=
begin
  assume ha : a,
  have hb : b :=
  hab ha,
  have hc : c :=
  hbc hb,
  show c, from
  hc
end

--------

--Prueba mixta
lemma forall.one_point {α : Type} (t : α) (p : α → Prop) :
(∀x, x = t → p x) ↔ p t :=
iff.intro
  (assume hall : ∀x, x = t → p x,
  show p t, from
    begin
    apply hall t,
    refl
    end)
  (assume hp : p t,
  assume x,
  assume heq : x = t,
  show p x, from
    begin
    rw heq,
    exact hp
    end
)

--Prueba by tactics
lemma forall.one_point2 {α : Type} (t : α) (p : α → Prop) :
(∀x, x = t → p x) ↔ p t :=
begin
  split,
  {assume h1,
  apply h1 t,
  refl},
  {assume h1,
  assume x,
  assume h2: x=t,
  rw h2,
  exact h1
  }
end

-- Prueba sin tactics
lemma forall.one_point3 {α : Type} (t : α) (p : α → Prop) :
(∀x, x = t → p x) ↔ p t :=
iff.intro
(assume h1: ∀x, x = t → p x,
have h2 : t=t → p t, from
  h1 t,
show p t, from
 h2 (eq.refl t)
)
(assume h1 : p t,
assume x : α,
assume h2 : x=t,
show p x, from
  eq.subst (eq.symm h2) h1
)

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

lemma beast_666 (beast : ℕ) :
(∀n, n = 666 → beast ≥ n) ↔ beast ≥ 666 :=
forall.one_point 666 (λ n:ℕ, beast ≥ n)

lemma beast_666_2 (beast : ℕ) :
(∀n, n = 666 → beast ≥ n) ↔ beast ≥ 666 :=
forall.one_point 666 (λ n:ℕ, beast ≥ n)

lemma exists.one_point {α : Type} (t : α) (p : α → Prop) :
(∃x : α, x = t ∧ p x) ↔ p t :=
iff.intro
(assume hex : ∃x, x = t ∧ p x,
show p t, from
  exists.elim hex
  (assume x,
  assume hand : x = t ∧ p x,
  show p t, from
    by cc))
(assume hp : p t,
show ∃x : α, x = t ∧ p x, from
  exists.intro t
  (show t = t ∧ p t, from
    by cc))

lemma prop_comp₃ (a b c : Prop) (hab : a → b) (hbc : b → c) :
  a → c :=
begin
  intro ha,
  have hb : b :=
    hab ha,
  let c' := c,
  have hc : c' :=
    hbc hb,
  exact hc
end


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

import tactic -- imports all the Lean tactics

/-!

# Sets in Lean, example sheet 2 : "the" empty set and the "universal set".

Lean notation for the empty subset of `X` is `∅`. Unlike in
set theory, there is more than one empty set in Lean! Every
type has an empty subset, and it *doesn't make sense*
to ask if `∅ : set ℕ` and `∅ : set ℤ` are equal, because
they have different types.

At the other extreme, the subset of `X` containing all the terms of type `X`
is...well...mathematicians would just call it `X`, but `X` is a type not a subset.
The subset of `X` consisting of every element of `X` is called `set.univ : set X`,
or just `univ : set X` if we have opened the `set` namespace. Let's do that now.

-/

open set

/-

## Definition of ∅ and univ

`x ∈ ∅` is *by definition* equal to `false` and `x ∈ univ` is *by definition*
equal to `true`. You can use the `change` tactic to make these changes
if you like. But you don't have to. Remember that `triv` proves `true`
and `cases h` will solve a goal if `h : false`.

-/

-- set up variables
variables
  (X : Type) -- Everything will be a subset of `X`
  (A B C D E : set X) -- A,B,C,D,E are subsets of `X`
  (x y z : X) -- x,y,z are elements of `X` or, more precisely, terms of type `X`

open set

example : x ∈ (univ : set X) :=
begin
  triv,
end

example : x ∈ (∅ : set X) → false :=
begin
  exact id,
end

example : A ⊆ univ :=
begin
  intros x hxA,
  triv,
end

example : ∅ ⊆ A :=
begin
  -- rintros x ⟨⟩, -- solves goal in one line
  intros x hx,
  change false at hx, -- unnecessary line
  exfalso,
  exact hx,
end


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

! This file was ported from Lean 3 source module data.int.associated
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Associated
import Mathbin.Data.Int.Units

/-!
# Associated elements and the integers

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

This file contains some results on equality up to units in the integers.

## Main results

 * `int.nat_abs_eq_iff_associated`: the absolute value is equal iff integers are associated
-/

/- warning: int.nat_abs_eq_iff_associated -> Int.natAbs_eq_iff_associated is a dubious translation:
lean 3 declaration is
  forall {a : Int} {b : Int}, Iff (Eq.{1} Nat (Int.natAbs a) (Int.natAbs b)) (Associated.{0} Int Int.monoid a b)
but is expected to have type
  forall {a : Int} {b : Int}, Iff (Eq.{1} Nat (Int.natAbs a) (Int.natAbs b)) (Associated.{0} Int Int.instMonoidInt a b)
Case conversion may be inaccurate. Consider using '#align int.nat_abs_eq_iff_associated Int.natAbs_eq_iff_associatedₓ'. -/
theorem Int.natAbs_eq_iff_associated {a b : ℤ} : a.natAbs = b.natAbs ↔ Associated a b :=
  by
  refine' int.nat_abs_eq_nat_abs_iff.trans _
  constructor
  · rintro (rfl | rfl)
    · rfl
    · exact ⟨-1, by simp⟩
  · rintro ⟨u, rfl⟩
    obtain rfl | rfl := Int.units_eq_one_or u
    · exact Or.inl (by simp)
    · exact Or.inr (by simp)
#align int.nat_abs_eq_iff_associated Int.natAbs_eq_iff_associated


import tactic
import .size .num_lemmas

open_locale classical
open_locale big_operators
noncomputable theory

universes u v w

open set

variables {α : Type*} [fintype α]

def list_union : list (set α) → set α :=
  λ Xs, (⋃ (X ∈ Xs), X)

def list_inter : list (set α) → set α :=
  λ Xs, (⋂ (X ∈ Xs), X)

@[simp] lemma list_empty_union_eq_empty (Xs : list (set α)) :
  Xs = list.nil → list_union Xs = ∅ :=
λ h, by {unfold list_union, rw h, simp,}

@[simp] lemma list_empty_inter_eq_univ (Xs : list (set α)) :
  Xs = list.nil → list_inter Xs = univ :=
λ h, by {unfold list_inter, rw h, simp,}

@[simp] lemma list_single_union (Xs : list (set α)) :
  Xs.length = 1 → list_union Xs = Xs.head :=
begin
  intro h, unfold list_union, rw list.eq_cons_of_length_one h,
  ext, simp,
end

@[simp] lemma list_single_inter (Xs : list (set α)) :
  Xs.length = 1 → list_inter Xs = Xs.head :=
begin
  intro h, unfold list_inter, rw list.eq_cons_of_length_one h,
  ext, simp,
end

@[simp] lemma list_union_cons (Xs: list (set α)) (Y : set α) :
  list_union (Y :: Xs) = Y ∪ list_union Xs :=
begin
  unfold list_union, ext,
  simp_rw[set.mem_union, set.mem_Union],
  simp only [exists_prop, list.mem_cons_iff],
  refine ⟨λ h, _, λ h, _⟩; finish,
end

@[simp] lemma list_inter_cons (Xs: list (set α)) (Y : set α) :
  list_inter (Y :: Xs) = Y ∩ list_inter Xs :=
begin
  unfold list_inter, ext,
  simp_rw [set.mem_inter_iff, set.mem_Inter],
  simp only [exists_prop, list.mem_cons_iff],
  refine ⟨λ h, _, λ h, _⟩; finish,
end

namespace seq

@[simp] lemma fin_zero_Union (Xs : fin 0 → set α) :
set.Union Xs = ∅  :=
by {rw [set.Union_eq_empty], exact λ i, fin_zero_elim i}

@[simp] lemma fin_zero_Inter (Xs : fin 0 → set α) :
set.Inter Xs = univ  :=
by {rw [set.Inter_eq_univ], exact λ i, fin_zero_elim i}

lemma Union_cons {n : ℕ} (Xs : fin n → set α) (Y : set α) :
set.Union (fin.cons Y Xs) = set.Union Xs ∪ Y  :=
begin
  ext, rw [iff.comm, set.mem_union, set.mem_Union, set.mem_Union],
  refine ⟨λ h, _, λ h, _⟩,
  rcases h with (⟨i, hi⟩ | h),
    {use fin.succ i, simp [hi]},
    {use 0, convert h,},
  cases h with i hi,
  revert i, refine λ i, fin.cases (λ h, _) (λ i₀ h, _) i,
    {right, convert h,},
  left, use i₀,
  convert h, simp,
end

lemma Inter_cons {n : ℕ} (Xs : fin n → set α) (Y : set α) :
set.Inter (fin.cons Y Xs) = set.Inter Xs ∩ Y  :=
begin
  ext, rw [iff.comm, set.mem_inter_iff, set.mem_Inter, set.mem_Inter],
  refine ⟨λ h, λ i, _, λ h, ⟨λ i, _, _⟩⟩,
    {revert i, refine λ i, fin.cases (by convert h.2) (λ i₀, _) i, convert h.1 i₀, simp,  },
    {convert h (i.succ), simp,},
  convert h 0,
end

end seq

namespace list

lemma nil_of_unzip_nil_left {α β : Type*} (L : list (α × β)) :
  L.unzip.1 = list.nil → L = list.nil :=
λ h, by {rw [←L.zip_unzip, h], simp only [zip_nil_left]}

lemma nil_of_unzip_nil_right {α β : Type*} (L : list (α × β)) :
  L.unzip.2 = list.nil → L = list.nil :=
λ h, by {rw [←L.zip_unzip, h], simp only [zip_nil_right]}

end list


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import topology.stone_cech
import topology.algebra.semigroup
import data.stream.init

/-!
# Hindman's theorem on finite sums

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

We prove Hindman's theorem on finite sums, using idempotent ultrafilters.

Given an infinite sequence `a₀, a₁, a₂, …` of positive integers, the set `FS(a₀, …)` is the set
of positive integers that can be expressed as a finite sum of `aᵢ`'s, without repetition. Hindman's
theorem asserts that whenever the positive integers are finitely colored, there exists a sequence
`a₀, a₁, a₂, …` such that `FS(a₀, …)` is monochromatic. There is also a stronger version, saying
that whenever a set of the form `FS(a₀, …)` is finitely colored, there exists a sequence
`b₀, b₁, b₂, …` such that `FS(b₀, …)` is monochromatic and contained in `FS(a₀, …)`. We prove both
these versions for a general semigroup `M` instead of `ℕ+` since it is no harder, although this
special case implies the general case.

The idea of the proof is to extend the addition `(+) : M → M → M` to addition `(+) : βM → βM → βM`
on the space `βM` of ultrafilters on `M`. One can prove that if `U` is an _idempotent_ ultrafilter,
i.e. `U + U = U`, then any `U`-large subset of `M` contains some set `FS(a₀, …)` (see
`exists_FS_of_large`). And with the help of a general topological argument one can show that any set
of the form `FS(a₀, …)` is `U`-large according to some idempotent ultrafilter `U` (see
`exists_idempotent_ultrafilter_le_FS`). This is enough to prove the theorem since in any finite
partition of a `U`-large set, one of the parts is `U`-large.

## Main results

- `FS_partition_regular`: the strong form of Hindman's theorem
- `exists_FS_of_finite_cover`: the weak form of Hindman's theorem

## Tags

Ramsey theory, ultrafilter

-/

open filter

/-- Multiplication of ultrafilters given by `∀ᶠ m in U*V, p m ↔ ∀ᶠ m in U, ∀ᶠ m' in V, p (m*m')`. -/
@[to_additive "Addition of ultrafilters given by
`∀ᶠ m in U+V, p m ↔ ∀ᶠ m in U, ∀ᶠ m' in V, p (m+m')`." ]
def ultrafilter.has_mul {M} [has_mul M] : has_mul (ultrafilter M) :=
{ mul := λ U V, (*) <$> U <*> V }

local attribute [instance] ultrafilter.has_mul ultrafilter.has_add

/- We could have taken this as the definition of `U * V`, but then we would have to prove that it
defines an ultrafilter. -/
@[to_additive]
lemma ultrafilter.eventually_mul {M} [has_mul M] (U V : ultrafilter M) (p : M → Prop) :
  (∀ᶠ m in ↑(U * V), p m) ↔ ∀ᶠ m in U, ∀ᶠ m' in V, p (m * m') := iff.rfl

/-- Semigroup structure on `ultrafilter M` induced by a semigroup structure on `M`. -/
@[to_additive "Additive semigroup structure on `ultrafilter M` induced by an additive semigroup
structure on `M`."]
def ultrafilter.semigroup {M} [semigroup M] : semigroup (ultrafilter M) :=
{ mul_assoc := λ U V W, ultrafilter.coe_inj.mp $ filter.ext' $ λ p,
    by simp only [ultrafilter.eventually_mul, mul_assoc]
  ..ultrafilter.has_mul }

local attribute [instance] ultrafilter.semigroup ultrafilter.add_semigroup

/- We don't prove `continuous_mul_right`, because in general it is false! -/
@[to_additive]
lemma ultrafilter.continuous_mul_left {M} [semigroup M] (V : ultrafilter M) : continuous (* V) :=
topological_space.is_topological_basis.continuous ultrafilter_basis_is_basis _ $
set.forall_range_iff.mpr $ λ s, ultrafilter_is_open_basic { m : M | ∀ᶠ m' in V, m * m' ∈ s }

namespace hindman

/-- `FS a` is the set of finite sums in `a`, i.e. `m ∈ FS a` if `m` is the sum of a nonempty
subsequence of `a`. We give a direct inductive definition instead of talking about subsequences. -/
inductive FS {M} [add_semigroup M] : stream M → set M
| head (a : stream M) : FS a a.head
| tail (a : stream M) (m : M) (h : FS a.tail m) : FS a m
| cons (a : stream M) (m : M) (h : FS a.tail m) : FS a (a.head + m)

/-- `FP a` is the set of finite products in `a`, i.e. `m ∈ FP a` if `m` is the product of a nonempty
subsequence of `a`. We give a direct inductive definition instead of talking about subsequences. -/
@[to_additive FS]
inductive FP {M} [semigroup M] : stream M → set M
| head (a : stream M) : FP a a.head
| tail (a : stream M) (m : M) (h : FP a.tail m) : FP a m
| cons (a : stream M) (m : M) (h : FP a.tail m) : FP a (a.head * m)

/-- If `m` and `m'` are finite products in `M`, then so is `m * m'`, provided that `m'` is obtained
from a subsequence of `M` starting sufficiently late. -/
@[to_additive "If `m` and `m'` are finite sums in `M`, then so is `m + m'`, provided that `m'`
is obtained from a subsequence of `M` starting sufficiently late."]
lemma FP.mul {M} [semigroup M] {a : stream M} {m : M} (hm : m ∈ FP a) :
  ∃ n, ∀ m' ∈ FP (a.drop n), m * m' ∈ FP a :=
begin
  induction hm with a a m hm ih a m hm ih,
  { exact ⟨1, λ m hm, FP.cons a m hm⟩, },
  { cases ih with n hn, use n+1, intros m' hm', exact FP.tail _ _ (hn _ hm'), },
  { cases ih with n hn, use n+1, intros m' hm', rw mul_assoc, exact FP.cons _ _ (hn _ hm'), },
end

@[to_additive exists_idempotent_ultrafilter_le_FS]
lemma exists_idempotent_ultrafilter_le_FP {M} [semigroup M] (a : stream M) :
  ∃ U : ultrafilter M, U * U = U ∧ ∀ᶠ m in U, m ∈ FP a :=
begin
  let S : set (ultrafilter M) := ⋂ n, { U | ∀ᶠ m in U, m ∈ FP (a.drop n) },
  obtain ⟨U, hU, U_idem⟩ := exists_idempotent_in_compact_subsemigroup _ S _ _ _,
  { refine ⟨U, U_idem, _⟩, convert set.mem_Inter.mp hU 0, },
  { exact ultrafilter.continuous_mul_left },
  { apply is_compact.nonempty_Inter_of_sequence_nonempty_compact_closed,
    { intros n U hU,
      apply eventually.mono hU,
      rw [add_comm, ←stream.drop_drop, ←stream.tail_eq_drop],
      exact FP.tail _ },
    { intro n, exact ⟨pure _, mem_pure.mpr $ FP.head _⟩, },
    { exact (ultrafilter_is_closed_basic _).is_compact, },
    { intro n, apply ultrafilter_is_closed_basic, }, },
  { exact is_closed.is_compact (is_closed_Inter $ λ i, ultrafilter_is_closed_basic _) },
  { intros U hU V hV,
    rw set.mem_Inter at *,
    intro n,
    rw [set.mem_set_of_eq, ultrafilter.eventually_mul],
    apply eventually.mono (hU n),
    intros m hm,
    obtain ⟨n', hn⟩ := FP.mul hm,
    apply eventually.mono (hV (n' + n)),
    intros m' hm',
    apply hn,
    simpa only [stream.drop_drop] using hm', }
end

@[to_additive exists_FS_of_large]
lemma exists_FP_of_large {M} [semigroup M] (U : ultrafilter M) (U_idem : U * U = U)
  (s₀ : set M) (sU : s₀ ∈ U) : ∃ a, FP a ⊆ s₀ :=
begin
/- Informally: given a `U`-large set `s₀`, the set `s₀ ∩ { m | ∀ᶠ m' in U, m * m' ∈ s₀ }` is also
`U`-large (since `U` is idempotent). Thus in particular there is an `a₀` in this intersection. Now
let `s₁` be the intersection `s₀ ∩ { m | a₀ * m ∈ s₀ }`. By choice of `a₀`, this is again `U`-large,
so we can repeat the argument starting from `s₁`, obtaining `a₁`, `s₂`, etc. This gives the desired
infinite sequence. -/
  have exists_elem : ∀ {s : set M} (hs : s ∈ U), (s ∩ { m | ∀ᶠ m' in U, m * m' ∈ s }).nonempty :=
    λ s hs, ultrafilter.nonempty_of_mem (inter_mem hs $ by { rw ←U_idem at hs, exact hs }),
  let elem : { s // s ∈ U } → M := λ p, (exists_elem p.property).some,
  let succ : { s // s ∈ U } → { s // s ∈ U } := λ p, ⟨p.val ∩ { m | elem p * m ∈ p.val },
    inter_mem p.2 $ show _, from set.inter_subset_right _ _ (exists_elem p.2).some_mem⟩,
  use stream.corec elem succ (subtype.mk s₀ sU),
  suffices : ∀ (a : stream M) (m ∈ FP a), ∀ p, a = stream.corec elem succ p → m ∈ p.val,
  { intros m hm, exact this _ m hm ⟨s₀, sU⟩ rfl, },
  clear sU s₀,
  intros a m h,
  induction h with b b n h ih b n h ih,
  { rintros p rfl,
    rw [stream.corec_eq, stream.head_cons],
    exact set.inter_subset_left _ _ (set.nonempty.some_mem _), },
  { rintros p rfl,
    refine set.inter_subset_left _ _ (ih (succ p) _),
    rw [stream.corec_eq, stream.tail_cons], },
  { rintros p rfl,
    have := set.inter_subset_right _ _ (ih (succ p) _),
    { simpa only using this },
    rw [stream.corec_eq, stream.tail_cons], },
end

/-- The strong form of **Hindman's theorem**: in any finite cover of an FP-set, one the parts
contains an FP-set. -/
@[to_additive FS_partition_regular "The strong form of **Hindman's theorem**: in any finite cover of
an FS-set, one the parts contains an FS-set."]
lemma FP_partition_regular {M} [semigroup M] (a : stream M) (s : set (set M)) (sfin : s.finite)
  (scov : FP a ⊆ ⋃₀ s) : ∃ (c ∈ s) (b : stream M), FP b ⊆ c :=
let ⟨U, idem, aU⟩ := exists_idempotent_ultrafilter_le_FP a in
let ⟨c, cs, hc⟩ := (ultrafilter.finite_sUnion_mem_iff sfin).mp (mem_of_superset aU scov) in
⟨c, cs, exists_FP_of_large U idem c hc⟩

/-- The weak form of **Hindman's theorem**: in any finite cover of a nonempty semigroup, one of the
parts contains an FP-set. -/
@[to_additive exists_FS_of_finite_cover "The weak form of **Hindman's theorem**: in any finite cover
of a nonempty additive semigroup, one of the parts contains an FS-set."]

@[to_additive FS_iter_tail_sub_FS]
lemma FP_drop_subset_FP {M} [semigroup M] (a : stream M) (n : ℕ) :
  FP (a.drop n) ⊆ FP a :=
begin
  induction n with n ih, { refl },
  rw [nat.succ_eq_one_add, ←stream.drop_drop],
  exact trans (FP.tail _) ih,
end

@[to_additive]
lemma FP.singleton {M} [semigroup M] (a : stream M) (i : ℕ) : a.nth i ∈ FP a :=
by { induction i with i ih generalizing a, { apply FP.head }, { apply FP.tail, apply ih } }

@[to_additive]
lemma FP.mul_two {M} [semigroup M] (a : stream M) (i j : ℕ) (ij : i < j) :
  a.nth i * a.nth j ∈ FP a :=
begin
  refine FP_drop_subset_FP _ i _,
  rw ←stream.head_drop,
  apply FP.cons,
  rcases le_iff_exists_add.mp (nat.succ_le_of_lt ij) with ⟨d, hd⟩,
  have := FP.singleton (a.drop i).tail d,
  rw [stream.tail_eq_drop, stream.nth_drop, stream.nth_drop] at this,
  convert this,
  rw [hd, add_comm, nat.succ_add, nat.add_succ],
end

@[to_additive]
lemma FP.finset_prod {M} [comm_monoid M] (a : stream M) (s : finset ℕ) (hs : s.nonempty) :
  s.prod (λ i, a.nth i) ∈ FP a :=
begin
  refine FP_drop_subset_FP _ (s.min' hs) _,
  induction s using finset.strong_induction with s ih,
  rw [←finset.mul_prod_erase _ _ (s.min'_mem hs), ←stream.head_drop],
  cases (s.erase (s.min' hs)).eq_empty_or_nonempty with h h,
  { rw [h, finset.prod_empty, mul_one], exact FP.head _ },
  { apply FP.cons, rw [stream.tail_eq_drop, stream.drop_drop, add_comm],
    refine set.mem_of_subset_of_mem _ (ih _ (finset.erase_ssubset $ s.min'_mem hs) h),
    have : s.min' hs + 1 ≤ (s.erase (s.min' hs)).min' h :=
      nat.succ_le_of_lt (finset.min'_lt_of_mem_erase_min' _ _ $ finset.min'_mem _ _),
    cases le_iff_exists_add.mp this with d hd,
    rw [hd, add_comm, ←stream.drop_drop],
    apply FP_drop_subset_FP }
end

end hindman


-- 1
section
  variable A : Type
  variable f : A → A
  variable P : A → Prop
  variable h : ∀x, P x → P (f x)

  example : ∀y, P y → P (f (f y)) :=

  assume y : A,
  assume h0: P y,
  have h1: (P y → P (f y)), from h y,
  have h2: P (f y), from h1 h0,
  have h3: P (f y) → P (f (f y)), from h (f y),
  show P (f (f y)), from h3 h2
end

-- 2
section
  variable U : Type
  variables A B : U → Prop

  example : (∀x, A x ∧ B x) → ∀x, A x :=
  assume h : (∀x, A x ∧ B x),
  assume y,
  have h1: A y ∧ B y, from h y,
  show A y, from and.left h1
end

-- 3
section
  variable U : Type
  variables A B C : U → Prop

  variable h1 : ∀x, A x ∨ B x
  variable h2 : ∀x, A x → C x
  variable h3 : ∀x, B x → C x

  example : ∀x, C x :=
  assume y : U,

  have h0: A y ∨ B y, from h1 y,

  or.elim h0
  (
    assume Ay,
    have ha: A y → C y, from h2 y,
    have hb: C y, from ha Ay,
    show C y, from hb
  )
  (
    assume By,
    have ha: B y → C y, from h3 y,
    have hb: C y, from ha By,
    show C y, from hb
  )
end

-- 4
open classical

axiom not_iff_not_self (P : Prop) : ¬(P ↔ ¬P)

example (Q : Prop) : ¬(Q ↔ ¬Q) :=
not_iff_not_self Q

section
  variable Person : Type
  variable shaves : Person → Person → Prop
  variable barber : Person
  variable h : ∀x, shaves barber x ↔ ¬shaves x x

  example : false :=
    not_iff_not_self
    (shaves barber barber)
    (h barber)
end

-- 5
section
  variable U : Type
  variables A B : U → Prop

  example : (∃x, A x) → ∃x, A x ∨ B x :=

  assume h1 : ∃x, A x,

  exists.elim h1
  (
    assume a (h0: A a),
    have h2: A a ∨ B a, from or.inl h0,
    show ∃x, A x ∨ B x, from exists.intro a h2
  )
end

-- 6
section
  variable U : Type
  variables A B : U → Prop

  variable h1 : ∀x, A x → B x
  variable h2 : ∃x, A x

  example : ∃x, B x :=

  exists.elim h2
  (
    assume y (h3: A y),
    have h0: A y → B y, from h1 y,
    have h4: B y, from h0 h3,
    show ∃x, B x, from exists.intro y h4
  )
end

-- 7
section
  variable  U : Type
  variables A B C : U → Prop

  example (h1 : ∃x, A x ∧ B x) (h2 : ∀x, B x → C x) :
      ∃x, A x ∧ C x :=

  exists.elim h1
  (
  assume a (h0 : A a ∧ B a),
  have ha : B a, from h0.right,
  have hb : B a → C a, from h2 a,
  have hc : C a, from hb ha,
  have hd : A a, from and.left h0,
  have he : A a ∧ C a, from and.intro hd hc,
  show ∃x, A x ∧ C x, from exists.intro a he
  )
end

-- 8
section
  variable  U : Type
  variables A B C : U → Prop

  example : (¬∃x, A x) → ∀x, ¬A x :=

  assume h1 : ¬ ∃ x, A x,

  assume y : U,
  assume h2 : A y,

  have h2 : ∃ x, A x, from exists.intro y h2,

  show false, from h1 h2
end

-- 9
section
  variable  U : Type
  variables A B C : U → Prop

  example : (∀x, ¬A x) → ¬∃x, A x :=

  assume h01: ∀x, ¬A x,

  show ¬∃x, A x, from not.intro
  (
    assume h1: ∃x, A x,

    exists.elim h1
    (
      assume y (h2: A y),
      have h3: ¬A y, from h01 y,
      show false, from h3 h2
    )
  )
end

-- 10
section
  variable  U : Type
  variables R : U → U → Prop

  example : (∃x, ∀y, R x y) → ∀y, ∃x, R x y :=

  assume h1: ∃x, ∀y, R x y,

  show ∀y, ∃x, R x y, from
    exists.elim h1
    (
      assume x (h2:(∀y, R x y)),
      assume y : U,

      have h3: (R x y), from h2 y,

      exists.intro x h3
    )
end


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

Given a poset `P`, we define `subdiv P` to be the poset of
finite nonempty chains `s ⊆ P`.  Any such `s` has a largest
element, and the map `max : (subdiv P) → P` is a morphism
of posets.  There is an approach to the homotopy theory of
finite complexes based on finite posets, and the above map
`max` plays a key role in this.
-/

import data.list.sort
import basic sort_rank

universes uP uQ uR uS

variables (P : Type uP) [partial_order P] [decidable_eq P]
variables (Q : Type uQ) [partial_order Q] [decidable_eq Q]
variables (R : Type uR) [partial_order R] [decidable_eq R]
variables (S : Type uS) [partial_order S] [decidable_eq S]

variable [decidable_rel (has_le.le : P → P → Prop)]
variable [decidable_rel (has_le.le : Q → Q → Prop)]
variable [decidable_rel (has_le.le : R → R → Prop)]
variable [decidable_rel (has_le.le : S → S → Prop)]

namespace poset
open poset

variable {P}

/-- Definition of chains
  LaTeX: defn-subdiv
-/
def is_chain (s : finset P) : Prop :=
 ∀ (p ∈ s) (q ∈ s), (p ≤ q ∨ q ≤ p)

instance decidable_is_chain (s : finset P) : decidable (is_chain s) :=
by { unfold is_chain, apply_instance }

/-- Definition of simplices as nonempty chains
  LaTeX: defn-subdiv
-/
def is_simplex (s : finset P) : Prop := s ≠ ∅ ∧ (is_chain s)

instance decidable_is_simplex (s : finset P) : decidable (is_simplex s) :=
by { unfold is_simplex, apply_instance }

variable (P)

/-- Definition of subdiv P as a type
  LaTeX: defn-subdiv
-/
def subdiv := {s : finset P // is_simplex s}

/-- Vertices as 0-simplices -/
variable {P}
def vertex (p : P) : subdiv P := ⟨
finset.singleton p,
begin
  split,
  {exact finset.ne_empty_of_mem (finset.mem_singleton_self p)},
  {intros x hx y hy,
   rw [finset.mem_singleton.mp hx, finset.mem_singleton.mp hy],
   left, exact le_refl p }
end⟩
variable (P)

namespace subdiv

instance : decidable_eq (subdiv P) :=
  by { unfold subdiv, apply_instance }

/-- Definition of the partial order on subdiv P
  LaTeX: defn-subdiv
-/
instance : partial_order (subdiv P) :=
{ le := λ s t, s.val ⊆ t.val,
  le_refl := λ s, (le_refl s.val),
  le_antisymm := λ s t hst hts, subtype.eq (le_antisymm hst hts),
  le_trans := λ s t u (hst : s.val ⊆ t.val) (htu : t.val ⊆ u.val) p hs,
                (htu (hst hs)) }

instance decidable_le : decidable_rel
 (has_le.le : (subdiv P) → (subdiv P) → Prop) :=
  λ s t, by { apply_instance }

variable {P}

/-- Definition of the dimension of a simplex, as one less than
  the cardinality.  We use the predecessor operation on
  natural numbers, which sends zero to zero.  Because of this,
  we need a small argument to show that the cardinality is
  strictly positive and thus equal to one more than the dimension.

  LaTeX: defn-subdiv
-/
def dim (s : subdiv P) : ℕ := s.val.card.pred

lemma card_eq (s : subdiv P) : s.val.card = s.dim.succ :=
begin
  by_cases h : s.val.card = 0,
  { exact (s.property.left (finset.card_eq_zero.mp h)).elim },
  { replace h := nat.pos_of_ne_zero h,
    exact (nat.succ_pred_eq_of_pos h).symm }
end

/-- The dimension function dim : subdiv P → ℕ is monotone. -/
lemma dim_mono : monotone (dim : (subdiv P) → ℕ) :=
begin
  intros s t hst,
  let h := finset.card_le_of_subset hst,
  rw[card_eq,card_eq] at h,
  exact nat.le_of_succ_le_succ h
end

/-- If we have simplices s ≤ t with dim s ≥ dim t then s = t. -/
lemma eq_of_le_of_dim_ge (s t : subdiv P)
 (hst : s ≤ t) (hd : s.dim ≥ t.dim) : s = t :=
begin
  let hc := nat.succ_le_succ hd,
  rw [← card_eq, ← card_eq] at hc,
  exact subtype.eq (finset.eq_of_subset_of_card_le hst hc)
end

/-- This allows us to treat a simplex as a type in its own right. -/
instance : has_coe_to_sort (subdiv P) :=
  ⟨_,λ s, {p : P // p ∈ s.val}⟩

section els

variable (s : subdiv P)

instance els_decidable_eq : decidable_eq s := by { apply_instance }
instance els_fintype : fintype s           := by { apply_instance }

lemma card_eq' : fintype.card s = s.dim.succ :=
 (fintype.card_coe s.val).trans s.card_eq

/-- If s is a simplex, we can treat it as a linearly ordered set. -/
instance els_order : decidable_linear_order s :=
{ le := λ p q,p.val ≤ q.val,
  le_refl := λ p, ((le_refl (p.val : P)) : p.val ≤ p.val),
  le_antisymm := λ p q (hpq : p.val ≤ q.val) (hqp : q.val ≤ p.val),
                 subtype.eq (le_antisymm hpq hqp),
  le_trans := λ p q r (hpq : p.val ≤ q.val) (hqr : q.val ≤ r.val),
                 le_trans hpq hqr,
  le_total := λ p q,s.property.right p.val p.property q.val q.property,
  lt := λ p q,p.val < q.val,
  lt_iff_le_not_le := λ p q,
  begin
    change p.val < q.val ↔ p.val ≤ q.val ∧ ¬ q.val ≤ p.val,
    apply lt_iff_le_not_le,
  end,
  decidable_le := λ p q, by { apply_instance } }

variable {s}

/-- The inclusion of a simplex in the full poset P. -/
def inc : s → P := λ p, p.val

/-- The inclusion map is injective. -/
lemma inc_inj (p₀ p₁ : s) : (inc p₀) = (inc p₁) → p₀ = p₁ := subtype.eq

/-- The inclusion map is monotone. -/
lemma inc_mono : monotone (inc : s → P) := λ p₀ p₁ hp, hp

variable (s)
variables {d : ℕ} (e : s.dim = d)

/-- If dim s = d, then we have a canonical bijection from s
  to the set  fin d.succ = { 0,1,...,d }.  We define
  rank_equiv s to be a package consisting of this bijection
  and its inverse.  We define seq s and rank s to be
  auxiliary functions defined in terms of rank_equiv s,
  and we prove some lemmas about the behaviour of these.
-/

def rank_equiv : s ≃ fin d.succ :=
 fintype.rank_equiv (s.card_eq'.trans (congr_arg nat.succ e))

def seq : (fin d.succ) → P := λ i, inc ((rank_equiv s e).inv_fun i)

def rank (p : P) (hp : p ∈ s.val) : fin d.succ :=
 (rank_equiv s e).to_fun ⟨p,hp⟩

lemma seq_mem (i : fin d.succ) : seq s e i ∈ s.val :=
  ((rank_equiv s e).inv_fun i).property

lemma seq_rank (p : P) (hp : p ∈ s.val) :
 seq s e (rank s e p hp) = p :=
  congr_arg inc ((rank_equiv s e).left_inv ⟨p,hp⟩)

lemma seq_eq (i : fin d.succ) :
 ((rank_equiv s e).inv_fun i) = ⟨seq s e i,seq_mem s e i⟩ :=
  by { apply subtype.eq, refl }

lemma rank_seq (i : fin d.succ) :
 rank s e (seq s e i) (seq_mem s e i) = i :=
begin
  dsimp [rank],
  rw [← seq_eq, (rank_equiv s e).right_inv]
end

lemma seq_le (i₀ i₁ : fin d.succ) :
 i₀ ≤ i₁ ↔ seq s e i₀ ≤ seq s e i₁ :=
  fintype.seq_le (s.card_eq'.trans (congr_arg nat.succ e)) i₀ i₁

lemma seq_lt (i₀ i₁ : fin d.succ) :
 i₀ < i₁ ↔ seq s e i₀ < seq s e i₁ :=
  fintype.seq_lt (s.card_eq'.trans (congr_arg nat.succ e)) i₀ i₁

variables {P Q}

def map (f : poset.hom P Q) : (poset.hom (subdiv P) (subdiv Q)) :=
begin
  let sf : subdiv P → subdiv Q := λ s,
  begin
    let t0 : finset Q := s.val.image f.val,
    have : is_simplex t0 :=
    begin
      split,
      { rcases finset.exists_mem_of_ne_empty s.property.1
          with ⟨p,p_in_s⟩,
        exact finset.ne_empty_of_mem
         (finset.mem_image_of_mem f.val p_in_s) },
      { intros q₀ hq₀ q₁ hq₁,
        rcases finset.mem_image.mp hq₀ with ⟨p₀,hp₀,hfp₀⟩,
        rcases finset.mem_image.mp hq₁ with ⟨p₁,hp₁,hfp₁⟩,
        rw [← hfp₀, ← hfp₁],
        rcases s.property.2 p₀ hp₀ p₁ hp₁ with h₀₁ | h₁₀,
        { left,  exact f.property h₀₁ },
        { right, exact f.property h₁₀ } }
    end,
    exact ⟨t0,this⟩
  end,
  have : monotone sf := λ s₀ s₁ hs,
  begin
    change s₀.val.image f.val ⊆ s₁.val.image f.val,
    intros q hq,
    rcases finset.mem_image.mp hq with ⟨p,hp,hfp⟩,
    exact finset.mem_image.mpr ⟨p,hs hp,hfp⟩
  end,
  exact ⟨sf, this⟩
end

lemma map_val (f : poset.hom P Q) (s : subdiv P) :
 ((subdiv.map f).val s).val = s.val.image f.val := rfl

section interleave

variables [fintype P] {f g : poset.hom P Q} (hfg : f ≤ g)
include hfg

def interleave :
 ∀ (r : fin_ranking P) (m : ℕ), hom (subdiv P) (subdiv Q)
| ⟨n,r,r_mono⟩ m :=
  ⟨ λ (σ : subdiv P),
    ⟨ ((σ.val.filter (λ p, 2 * (r p).val < m)).image f) ∪
      ((σ.val.filter (λ p, 2 * (r p).val + 1 ≥ m)).image g),
      begin
        split,
        { rcases finset.exists_mem_of_ne_empty σ.property.1
            with ⟨p, p_in_σ⟩,
          by_cases h : 2 * (r p).val < m,
          { apply @finset.ne_empty_of_mem Q (f p),
            apply finset.mem_union_left,
            apply finset.mem_image_of_mem,
            rw [finset.mem_filter],
            exact ⟨p_in_σ, h⟩ },
          { replace h := le_trans (le_of_not_gt h) (nat.le_succ _),
            apply @finset.ne_empty_of_mem Q (g p),
            apply finset.mem_union_right,
            apply finset.mem_image_of_mem,
            rw [finset.mem_filter],
            exact ⟨p_in_σ, h⟩ } },
        { intros q₀ h₀ q₁ h₁,
          rcases finset.mem_union.mp h₀ with h₀ | h₀;
          rcases finset.mem_union.mp h₁ with h₁ | h₁;
          rcases finset.mem_image.mp h₀ with ⟨p₀,hf₀,he₀⟩;
          rcases finset.mem_image.mp h₁ with ⟨p₁,hf₁,he₁⟩;
          rw [finset.mem_filter] at hf₀ hf₁;
          rw [← he₀, ← he₁];
          let r₀ := (r p₀).val ; let r₁ := (r p₁).val ;
          rcases σ.property.right p₀ hf₀.1 p₁ hf₁.1 with hpp | hpp;
          let hfpp := f.property hpp;
          let hgpp := g.property hpp,
          { left , exact hfpp },
          { right, exact hfpp },
          { left , exact le_trans hfpp (hfg p₁) },
          { by_cases hrr : r₀ = r₁,
            { rw [r.injective (fin.eq_of_veq hrr)],
              left, exact hfg p₁ },
            { exfalso,
              change r₀ ≠ r₁ at hrr,
              replace hrr : r₁ < r₀ := lt_of_le_of_ne (r_mono hpp) hrr.symm,
              change r₁ + 1 ≤ r₀ at hrr,
              have := calc
                2 * r₁ + 2 = 2 * (r₁ + 1) : by rw [mul_add, mul_one]
                ... ≤ 2 * r₀ : nat.mul_le_mul_left 2 hrr
                ... < m : hf₀.2
                ... ≤ 2 * r₁ + 1 : hf₁.2
                ... < 2 * r₁ + 2 : nat.lt_succ_self _,
              exact lt_irrefl _ this } },
          { by_cases hrr : r₀ = r₁,
            { rw [r.injective (fin.eq_of_veq hrr)],
              right, exact hfg p₁ },
            { exfalso,
              change r₀ ≠ r₁ at hrr,
              replace hrr : r₀ < r₁ := lt_of_le_of_ne (r_mono hpp) hrr,
              change r₀ + 1 ≤ r₁ at hrr,
              have := calc
                2 * r₁ < m : hf₁.2
                ... ≤ 2 * r₀ + 1 : hf₀.2
                ... < 2 * r₀ + 2 : nat.lt_succ_self _
                ... = 2 * (r₀ + 1) : by rw [mul_add, mul_one]
                ... ≤ 2 * r₁ : nat.mul_le_mul_left 2 hrr,
              exact lt_irrefl _ this } },
          { right, exact le_trans hfpp (hfg p₀) },
          { left , exact hgpp },
          { right, exact hgpp } }
      end ⟩,
      begin
        intros σ₀ σ₁ h_le q hq,
        rw [finset.mem_union] at hq ⊢,
        rcases hq with hq | hq;
        rcases finset.mem_image.mp hq with ⟨p,hm,he⟩;
        rw [← he];
        rw [finset.mem_filter] at hm;
        replace hm := and.intro (h_le hm.1) hm.2,
        { left , apply finset.mem_image_of_mem,
          rw [finset.mem_filter], exact hm },
        { right, apply finset.mem_image_of_mem,
          rw [finset.mem_filter], exact hm }
      end ⟩

lemma interleave_start :
 ∀ (r : fin_ranking P), interleave hfg r 0 = subdiv.map g
| ⟨n,r,r_mono⟩ :=
begin
  ext σ,
  apply subtype.eq,
  change _ ∪ _ = σ.val.image g.val,
  ext q,
  have : σ.val.filter (λ (p : P), 2 * (r p).val < 0) = ∅ :=
  begin
    ext p, rw [finset.mem_filter],
    simp [nat.not_lt_zero, finset.not_mem_empty]
  end,
  rw [this, finset.image_empty],
  have : σ.val.filter (λ (p : P), 2 * (r p).val + 1 ≥ 0) = σ.val :=
  begin
    ext p, rw [finset.mem_filter],
    have : _ ≥ 0 := nat.zero_le (2 * (r p).val + 1),
    simp only [this, and_true]
  end,
  rw [this, finset.mem_union],
  have : (g : P → Q) = g.val := rfl, rw [this],
  simp [finset.not_mem_empty],
end

lemma interleave_end :
 ∀ (r : fin_ranking P) (m : ℕ) (hm : m ≥ 2 * r.card),
  interleave hfg r m = subdiv.map f
| ⟨n,r,r_mono⟩ m hm :=
begin
  change m ≥ 2 * n at hm,
  ext σ,
  apply subtype.eq,
  change _ ∪ _ = σ.val.image f.val,
  ext q,
  have : σ.val.filter (λ (p : P), 2 * (r p).val < m) = σ.val :=
  begin
    ext p, rw [finset.mem_filter],
    have := calc
      2 * (r p).val < 2 * n :
        nat.mul_lt_mul_of_pos_left (r p).is_lt (dec_trivial : 2 > 0)
      ... ≤ m : hm,
    simp [this]
  end,
  rw [this],
  have : σ.val.filter (λ (p : P), 2 * (r p).val + 1 ≥ m) = ∅ :=
  begin
    ext p, rw [finset.mem_filter],
    have := calc
      2 * (r p).val + 1 < 2 * (r p).val + 2 : nat.lt_succ_self _
      ... = 2 * ((r p).val + 1) : by rw [mul_add, mul_one]
      ... ≤ 2 * n : nat.mul_le_mul_left 2 (r p).is_lt
      ... ≤ m : hm,
    have : ¬ (_ ≥ m) := not_le_of_gt this,
    simp only [this, finset.not_mem_empty, and_false]
  end,
  rw [this, finset.image_empty, finset.union_empty],
  have : (f : P → Q) = f.val := rfl, rw [this]
end

lemma interleave_even_step :
 ∀ (r : fin_ranking P) (k : ℕ),
  interleave hfg r (2 * k) ≤ interleave hfg r (2 * k + 1)
| ⟨n,r,r_mono⟩ k :=
begin
  intros σ q h,
  change q ∈ _ ∪ _ at h,
  change q ∈ _ ∪ _,
  rw [finset.mem_union] at h ⊢,
  rcases h with h | h;
  rcases finset.mem_image.mp h with ⟨p,hf,he⟩;
  rw [finset.mem_filter] at hf;
  rw [← he],
  { left,
    apply finset.mem_image_of_mem,
    rw [finset.mem_filter],
    exact ⟨hf.1, lt_trans hf.2 (nat.lt_succ_self _)⟩ },
  { right,
    apply finset.mem_image_of_mem,
    rw [finset.mem_filter],
    rcases le_or_gt k (r p).val with hk | hk,
    { exact ⟨hf.1, nat.succ_le_succ (nat.mul_le_mul_left 2 hk)⟩ },
    { exfalso,
      have := calc
        2 * (r p).val + 2 = 2 * ((r p).val + 1) : by rw [mul_add, mul_one]
        ... ≤ 2 * k : nat.mul_le_mul_left 2 hk
        ... ≤ 2 * (r p).val + 1 : hf.2
        ... < 2 * (r p).val + 2 : nat.lt_succ_self _,
      exact lt_irrefl _ this } }
end

lemma interleave_odd_step :
 ∀ (r : fin_ranking P) (k : ℕ),
  interleave hfg r (2 * k + 2) ≤ interleave hfg r (2 * k + 1)
| ⟨n,r,r_mono⟩ k :=
begin
  intros σ q h,
  change q ∈ _ ∪ _ at h,
  change q ∈ _ ∪ _,
  rw [finset.mem_union] at h ⊢,
  rcases h with h | h;
  rcases finset.mem_image.mp h with ⟨p,hf,he⟩;
  rw [finset.mem_filter] at hf;
  rw [← he],
  { left,
    apply finset.mem_image_of_mem,
    rw [finset.mem_filter],
    rcases le_or_gt (r p).val k with hk | hk,
    { have := calc
       2 * (r p).val ≤ 2 * k : nat.mul_le_mul_left 2 hk
       ... < 2 * k + 1 : nat.lt_succ_self _,
      exact ⟨hf.1, this⟩ },
    { exfalso,
      have := calc
        2 * k + 2 = 2 * (k + 1) : by rw [mul_add, mul_one]
        ... ≤ 2 * (r p).val : nat.mul_le_mul_left 2 hk
        ... < 2 * k + 2 : hf.2,
      exact lt_irrefl _ this } },
  { right,
    apply finset.mem_image_of_mem,
    rw [finset.mem_filter],
    exact ⟨hf.1, le_trans (le_of_lt (nat.lt_succ_self (2 * k + 1))) hf.2⟩ }
end

lemma interleave_component (r : fin_ranking P) (m : ℕ) :
  component (interleave hfg r m) = component (interleave hfg r 0) :=
zigzag (interleave hfg r)
  (interleave_even_step hfg r)
  (interleave_odd_step hfg r) m

end interleave

def subdiv.mapₕ [fintype P] :
  π₀ (hom P Q) → π₀ (hom (subdiv P) (subdiv Q)) :=
π₀.lift (λ f, component (subdiv.map f))
begin
  intros f g hfg,
  rcases exists_fin_ranking P with ⟨r⟩,
  let n := r.card,
  let c := interleave hfg r,
  have : c 0 = subdiv.map g := interleave_start hfg r,
  rw [← this],
  have : c (2 * n) = subdiv.map f := interleave_end hfg r (2 * n) (le_refl _),
  rw [← this],
  apply interleave_component
end

/-- For a simplex s, we define max s to be the largest element. -/

def max₀ : P := seq s rfl (fin.last s.dim)

lemma max₀_mem : s.max₀ ∈ s.val := seq_mem s rfl (fin.last s.dim)

lemma le_max₀ (p : P) (hp : p ∈ s.val) : p ≤ s.max₀ :=
begin
  rw [← seq_rank s rfl p hp],
  apply (seq_le s rfl (rank s rfl p hp) (fin.last s.dim)).mp,
  apply fin.le_last
end

end els

/-- The function max : subdiv P → P is monotone. -/
lemma max₀_mono : monotone (max₀ : subdiv P → P) :=
  λ s t hst, t.le_max₀ s.max₀ (hst s.max₀_mem)

variable (P)

def max : hom (subdiv P) P := ⟨max₀,max₀_mono⟩

lemma max_mem (s : subdiv P) : max P s ∈ s.val := max₀_mem s

lemma le_max (s : subdiv P) (p : P) (hp : p ∈ s.val) : p ≤ max P s :=
le_max₀ s p hp

lemma max_cofinal : cofinalₕ (max P) :=
begin
  intro p,
  let C := comma (max P) p,
  let c : C := ⟨vertex p,le_refl _⟩,
  let T := punit.{uP + 1},
  let f : hom C T := const C punit.star,
  let g : hom T C := const T c,
  have hfg : comp f g = id T :=
  by { ext t, rcases t, refl },
  let m₀ : C → C := λ x,
  begin
    let τ₀ := x.val.val ∪ finset.singleton p,
    have h₀ : τ₀ ≠ ∅ :=
      finset.ne_empty_of_mem
       (finset.mem_union_right _ (finset.mem_singleton_self p)),
    have h₁ : is_chain τ₀ := λ a ha b hb,
    begin
      rcases finset.mem_union.mp ha with hax | hap;
      rcases finset.mem_union.mp hb with hbx | hbp,
      { exact x.val.property.2 a hax b hbx },
      { left,
        rw [finset.mem_singleton.mp hbp],
        exact le_trans (le_max P x.val a hax) x.property },
      { right,
        rw [finset.mem_singleton.mp hap],
        exact le_trans (le_max P x.val b hbx) x.property },
      { left,
        rw [finset.mem_singleton.mp hbp],
        rw [finset.mem_singleton.mp hap] }
    end,
    let τ : subdiv P := ⟨τ₀,⟨h₀,h₁⟩⟩,
    have h₂ : max P τ ≤ p :=
    begin
      rcases finset.mem_union.mp (max_mem P τ) with h | h,
      { exact le_trans (le_max P x.val _ h) x.property },
      { rw [finset.mem_singleton.mp h] }
    end,
    exact ⟨τ,h₂⟩
  end,
  have m₀_mono : monotone m₀ := λ x₀ x₁ h,
  begin
    change x₀.val.val ⊆ x₁.val.val at h,
    change x₀.val.val ∪ finset.singleton p ⊆ x₁.val.val ∪ finset.singleton p,
    intros a ha,
    rcases finset.mem_union.mp ha with hax | hap,
    { exact finset.mem_union_left _ (h hax) },
    { exact finset.mem_union_right _ hap }
  end,
  let m : hom C C := ⟨m₀,m₀_mono⟩,
  have hm₀ : comp g f ≤ m := λ x a ha,
  begin
    change a ∈ finset.singleton p at ha,
    change a ∈ x.val.val ∪ finset.singleton p,
    exact finset.mem_union_right _ ha
  end,
  have hm₁ : id C ≤ m := λ x a ha,
  begin
    change a ∈ x.val.val at ha,
    change a ∈ x.val.val ∪ finset.singleton p,
    exact finset.mem_union_left _ ha
  end,
  let hgf := (π₀.sound hm₀).trans (π₀.sound hm₁).symm,
  have e : equivₕ C T :=
  { to_fun := component f,
    inv_fun := component g,
    left_inv := hgf,
    right_inv := congr_arg component hfg },
  exact ⟨e⟩
end

end subdiv

end poset


/-
# Formalising IUM 2021 in Lean (unofficial version)

Things about the logical foundations of Lean are skipped here...
(I just assumed the basic knowledge of "universes", "Π types", "inductive types" and their "recursors",
 also you need to know about how the logical connectives, the naturals and equality are defined in Lean...)
(For them you may want to read *Theorem Proving in Lean*:
 https://leanprover.github.io/theorem_proving_in_lean/
 I also made some notes about that...)
-/

import tactic

universe u

--------------------------------------------------------------------------------
-- ## Using sets in Lean

namespace using_sets_in_lean

#print set
/-
In Lean, the `set` is a "type constructor":
  `def set : Type u → Type u :=`
  `  λ (α : Type u), α → Prop`
"A set on a type α" (`set α`) is just the type `α → Prop`!

Note that:
1. This is a function type, which contains all "predicates on `α`"
    (i.e. function that receives an element of `α` and returns a `Prop`).
2. This function type lives in the same universe as `α`.
-/

#check set ℕ
#reduce set ℕ -- `set ℕ` and `ℕ → Prop` are the same (definitionally equal)!

-- This is the set {0, 1, 12}.
def some_subset : set ℕ := λ n, n = 0 ∨ n = 1 ∨ n = 12
-- You can also define it as:
-- `def some_subset : ℕ → Prop := λ n, n = 0 ∨ n = 1 ∨ n = 12`

#print notation ∈
#print set.mem
/-
The `mem` is defined as:
  `def set.mem : Π {α : Type u} (a : α) (s : set α), Prop :=`
    `λ α a s, s a`
which is just a function that "takes an implicit `α : Type`,
  an element of `a`, and a "set" `s` on `α` (i.e. `s : α → Prop`),
  and returns the proposition obtained by putting `a` into the predicate `s`."
  (i.e. it is just an application of the predicate `s` on `a`!)
-/

#check (set.mem 4 some_subset) -- `Prop`
#check (4 ∈ some_subset) -- An alternative notation for the above line
#check (some_subset 4) -- An alternative notation for the above line!

#reduce (4 ∈ some_subset) -- `4 = 0 ∨ 4 = 1 ∨ 4 = 12`

-- Let's prove that 1 ∈ {0, 1, 12}...
lemma l1 : (1 ∈ some_subset) :=
begin
  unfold some_subset,
  right, left, refl,
end
-- (Term mode version)
example : (1 ∈ some_subset) := or.inr (or.inl rfl)

-- Now prove that 4 ∉ {0, 1, 12}...
example : (4 ∉ some_subset) :=
begin
  intros h,
  unfold some_subset at h,
  cases h with h₁ h₂,
  { injection h₁ },
  { cases h₂ with h₂ h₃,
    { injections },
    { injections }}
end
-- (Term mode version)
example : (4 ∉ some_subset) :=
  (λ h : (some_subset 4), h.elim
    (λ h, nat.no_confusion h)
    (λ h, h.elim
      (λ h, nat.no_confusion (nat.succ.inj h))
      (λ h, nat.no_confusion ((nat.succ.inj ∘ nat.succ.inj ∘ nat.succ.inj ∘ nat.succ.inj) h))))

#print notation ⊆
#print set.subset
/-
In Lean, the `subset` takes two `set`s and emits a `Prop`:
  `def set.subset : Π {α : Type u}, set α → set α → Prop :=`
  `  λ α s₁ s₂, (∀ (a : α), a ∈ s₁ → a ∈ s₂)`
-/

#print set.univ
#print notation ∅
#print set.has_emptyc
/-
In Lean, the `univ` emits a `set` (α is implicit):
  `def set.univ : Π {α : Type u}, set α :=`
  `  λ α, (λ a, true)`
-/

#reduce (some_subset ⊆ (set.univ : set ℕ))
-- `∀ (a : ℕ), (a = 0 ∨ a = 1 ∨ a = 12) → true`
example : some_subset ⊆ (set.univ : set ℕ) :=
  λ x (hx : some_subset x), trivial

-- TODO: intersection, union, complement
-- TODO: indexed intersection / union
-- TODO: extensionality of sets
-- https://leanprover.github.io/logic_and_proof/sets_in_lean.html

end using_sets_in_lean

--------------------------------------------------------------------------------
-- ## Using functions in Lean

-- TODO: complete


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

/-!
# Logic

A Lean companion to the "Logic" part of the intro module.

We develop the basic theory of the five symbols
→, ¬, ∧, ↔, ∨

# Background

It is hard to ask you difficult questions
about the basic theory of these logical operators,
because every question can be proved by "check all the cases".

However, there is this cool theorem, that says that if
a theorem in the basic theory of logical propositions can be proved
by "check all the cases", then it can be proved in the Lean theorem
prover using only the eight constructive tactics `intro`, `apply`,
`assumption`, `exfalso`, `split`, `cases`, `have`, `left` and `right`,
as well as one extra rule called the Law of the Excluded Middle,
which in Lean is the tactic `by_cases`. Note that the tactic `finish`
is a general "check all the cases" tactic, and it uses `by_cases`.

## Reference

* The first half of section 1 of the M40001/40009 course notes.

-/

namespace xena

variables (P Q R : Prop)

/-

## Level 1 : implies

In Lean, `P → Q` is the notation for `P ⇒ Q` .

Let's start by learning how to control implications. We will
learn the three tactics `intro`, `apply` and `exact`.

-/

/-- Every proposition implies itself. -/
def id : P → P :=
begin
  /-
  Click here!

  See that

  `⊢ P → P`

  on the top right? That funny symbol `⊢ X` means "you have to prove `X`".

  So we have to prove that `P` implies `P`.

  How do we prove that `X` implies `Y`? We assume `X`, and try and deduce `Y`.
  -/
  -- assume P is true. Call this hypothesis hP.
  intro hP,
  -- goal now `⊢ P` and we also have hypothesis `hP: P`
  -- So we know that P is true, by hypothesis hP.
  exact hP,
end

-- implication isn't associative!
-- Try it when P, Q, R are all false.
-- `false → (false → false)` is `true`,
-- and
-- `(false → false) → false` is `false`.

-- in Lean, `P → Q → R` is _defined_ to be `P → (Q → R)`
-- Here's a proof of what I just said.
example : (P → Q → R) ↔ (P → (Q → R)) :=
begin
  -- ⊢ P → Q → R ↔ P → Q → R
  refl -- that closes goals of the form X = X and X ↔ X.
end

-- Another way to see it is just to uncomment out the line below:
-- #check P → (Q → R) -- output is `P → Q → R : Prop`

example : P → Q → P :=
begin
  -- remember that by definition the goal is P → (Q → P),
  -- so it's P implies something, so let's assume
  -- that P is true and call this hypothesis hP.
  intro hP,
  -- Now we have to prove that Q implies P, so let's
  -- assume that Q is true, and let's call this hypothesis hQ
  intro hQ,
  -- We now have to prove that P is true.
  -- But this is exactly our hypothesis hP.
  exact hP,
end

/-- If we know `P`, and we also know `P → Q`, we can deduce `Q`. -/
lemma modus_ponens : P → (P → Q) → Q :=
begin
  -- remember this means "P implies that ((P implies Q) implies Q)"
  -- so let's assume P is true
  intro hP,
  -- and let's assume hypothesis hPQ, that P implies Q
  intro hPQ,
  -- now `hPQ` says `P → Q` and we're trying to prove `Q`!
  -- So by applying the hypothesis `hPQ`, we can reduce
  -- this puzzle to proving `P`.
  apply hPQ,
  -- Now we have to prove `P`. But this is just an assumption
  exact hP, -- or `assumption`
end

-- See if you can do this one yourself. Replace the `sorry` with a proof.
lemma transitivity : (P → Q) → (Q → R) → (P → R) :=
begin
  sorry,
end

-- Of course you can always cheat with the `finish` tactic
example : (P → Q) → (Q → R) → (P → R) :=
begin
  finish,
end

-- finish just checks all the cases. It's slower than a constructive proof.
-- constructivists regard it as cheating.

-- This one is a "relative modus ponens" -- in the
-- presence of P, if Q -> R and Q then R.
-- Something fun happens in this one. I'll start you off.
example : (P → Q → R) → (P → Q) → (P → R) :=
begin
  -- Let `hPQR` be the hypothesis that `P → Q → R`.
  intro hPQR,
  -- We now need to prove that `(P → Q)` implies something.
  -- So let `hPQ` be hypothesis that `P → Q`
  intro hPQ,
  -- We now need to prove that `P` implies something, so
  -- let `hP` be the hypothesis that `P` is true.
  intro hP,
  -- We now have to prove `R`.
  -- We know the hypothesis `hPQR : P → (Q → R)`.
  -- Can we apply it?
  apply hPQR,
  -- exercise: what just happened?
  sorry, sorry
end

/-

### Level 2 : not

`not P`, with notation `¬ P`, is defined to mean `P → false` in Lean,
i.e., the proposition that P implies false. Note that `true → false` is `false`,
and `false → false` is `true`, so `P → false` is indeed equivalent
to `¬ P`. But we need to remember the fact that in Lean, `¬ P` was
*defined* to mean `P → false` and not in any other way.

We develop a basic interface for `¬`.
-/

theorem not_not_intro : P → ¬ (¬ P) :=
begin
  -- we have to prove that P implies (not (not P)),
  -- so let's assume P is true, and let's call this assumption hP
  intro hP,
  -- now we have to prove `not (not P)`, a.k.a. `¬ (¬ P)`, and
  -- by definition this means we have to prove `(¬ P) → false`
  -- In fact we can `change` our goal to this
  change ¬ P → false,
  -- The `change` tactic will make changes to the goal, as long
  -- as they are true *by definition*.

  -- So let's let hnP be the hypothesis that `¬ P` is true.
  intro hnP,
  -- and now we have to prove `false`!
  -- Sometimes this can be difficult, but it's OK if you have
  -- *contradictory hypotheses*, because with contradictory
  -- assumptions you can prove false conclusions, and once you've
  -- proved one false thing you've proved all false things because
  -- you've made mathematics collapse.

  -- How are we going to use hypothesis `hnP : ¬ P`?

  -- Well, what does it _mean_? It means `P → false`,
  -- We could `change` `hnP` to remind us of this:
  change P → false at hnP,

  -- Now our _goal_ is false, so why don't we apply
  -- hypothesis hnP, which will reduce our problem
  -- to proving `P`.

  apply hnP,

  -- now our goal is `P`, and this is an assumption!
  exact hP
end

-- What do you think of this proof?
theorem not_not_intro'' : P → ¬ (¬ P) :=
begin
  apply modus_ponens,
  -- Go back and look at modus ponens. Can you see how this proof worked?
end

-- If you're into lambda calculus or functional programming,
-- here's a functional proof
theorem not_not_intro' : P → ¬ (¬ P) :=
λ hP hnP, hnP hP

-- This one is straightforward -- give it a go:
theorem contra1 : (P → Q) → (¬ Q → ¬ P) :=
begin
  sorry
end

-- This way is impossible using constructive logic -- you have to use
-- a classical tactic like `finish` or check manually on cases.
theorem contra2 : (¬ Q → ¬ P) → (P → Q) :=
begin
  intro h,
  intro hP,
  -- stuck
  finish,
end

/-!

### Level 3 : and

The hypothesis `hPaQ : P ∧ Q` in Lean, is equivalent to
hypotheses `hP : P` and `hQ : Q`.

If you have `hPaQ` as a hypothesis, and you want to get to
`hP` and `hQ`, you can use the `cases` tactic.

If you have `⊢ P ∧ Q` as a goal, and want to turn the goal
into two goals `⊢ P` and `⊢ Q`, then use the `split` tactic.

Note that after `split` it's good etiquette to use indentation
or brackets, because you have two goals.

Example:

example (hP : P) (hQ : Q) : P ∧ Q :=
begin
  split,
    exact hP, -- we had two goals here
  exact hQ  -- we are back to one goal
end

or

example (hP : P) (hQ : Q) : P ∧ Q :=
begin
  split,
  { exact hP },
  { exact hQ }
end

-/

theorem and.elim_left : P ∧ Q → P :=
begin
  intro hPaQ,
  -- You can use the `cases` tactic on an `and` hypothesis
  cases hPaQ with hP hQ,
  exact hP,
end

-- try this one
theorem and.elim_right : P ∧ Q → Q :=
begin
  sorry
end

-- functional proof
theorem and.elim_right' : P ∧ Q → Q := λ hPaQ, hPaQ.2

-- Can you construct the full eliminator for `and`?
theorem and.elim : P ∧ Q → (P → Q → R) → R :=
begin
  sorry
end

-- Here's how to solve `and` goals.
theorem and.intro : P → Q → P ∧ Q :=
begin
  intro hP,
  intro hQ,
  -- use `split` on an and goal; you'll get two goals.
  split,
    assumption, -- just means "the goal is one of the hypotheses"
  assumption,
end

-- there's a two-line proof of this which starts
-- `apply function.swap`, but you don't need to do this
theorem and.rec : (P → Q → R) → P ∧ Q → R :=
begin
  sorry
end

theorem and.symm : P ∧ Q → Q ∧ P :=
begin
  sorry
end

theorem and.trans : (P ∧ Q) → (Q ∧ R) → (P ∧ R) :=
begin
  sorry,
end

/-
Extra credit

Recall that the convention for the implies sign →
is that it is _right associative_, by which
I mean that `P → Q → R` means `P → (Q → R)` by definition.
This does actually simplify! If `P` implies `Q → R`
then this means that `P` and `Q` together, imply `R`,
so `P → Q → R` is logically equivalent to `(P ∧ Q) → R`.

We proved that `P → Q → R` implied `(P ∧ Q) → R`; this was `and.rec`.
Let's go the other way.
-/

example : ((P ∧ Q) → R) → (P → Q → R) :=
begin
  sorry
end

/-!

### Level 4 : iff

The basic theory of `iff`.

In Lean, `P ↔ Q` is *defined to mean* `(P → Q) ∧ (Q → P)`.

It is _not_ defined by a truth table. You can attack a `P ↔ Q` goal
with the `split` tactic, because it is really an `∧` statement.
-/

/-- `P ↔ P` is true for all propositions `P`. -/
def iff.refl : P ↔ P :=
begin
  -- By Lean's definition I need to prove (P → P) ∧ (P → P)
  split,
    -- need to prove P → P
    -- We proved that a long time ago and called it `id`.
    apply id,
  -- need to prove P → P
  apply id
end

-- If you get stuck, there is always the "truth table" tactic `finish`
def iff.refl' : P ↔ P :=
begin
  finish,
end

-- The refl tactic also works
def iff.refl'' : P ↔ P :=
begin
  refl
end

def iff.symm : (P ↔ Q) → (Q ↔ P) :=
begin
  -- Try this one using `cases` and `split`.
  sorry
end

-- I'll now show you a better way: the `rewrite` tactic.
def iff.symm' : (P ↔ Q) → (Q ↔ P) :=
begin
  intro h,
  -- `h : P ↔ Q`
  -- The `rw h` tactic will change all P's in the goal to Q's.
  -- And then it will try `refl`, just for luck
  rw h,
  -- finished! Goal becamse `Q ↔ Q` and then `refl` finished it.
end

def iff.comm : (P ↔ Q) ↔ (Q ↔ P) :=
begin
  sorry,
end

-- without rw or cc this is ugly
def iff.trans :  (P ↔ Q) → (Q ↔ R) → (P ↔ R) :=
begin
  sorry
end

-- This is a cute question. Can you prove it constructively,
-- using only `intro`, `cases`, `have`, `apply`, and `assumption`?
def iff.boss : ¬ (P ↔ ¬ P) :=
begin
  sorry
end

-- Now we have iff we can go back to and.

/-! ### iff epilogue: ↔ and ∧ -/

theorem and.comm : P ∧ Q ↔ Q ∧ P :=
begin
  sorry
end

-- ∧ is "right associative" in Lean, which means
-- that `P ∧ Q ∧ R` is _defined to mean_ `P ∧ (Q ∧ R)`.
-- Associativity can hence be written like this:
theorem and_assoc : ((P ∧ Q) ∧ R) ↔ (P ∧ Q ∧ R) :=
begin
  sorry,
end

/-!

## Level 5 (final level) : Or

`P ∨ Q` is true when at least one of `P` and `Q` are true.
Here is how to work with `∨` in Lean.

If you have a _hypothesis_ `hPoQ : P ∨ Q` then you
can break into the two cases `hP : P` and `hQ : Q` using
`cases hPoQ with hP hQ`

If you have a _goal_ of the form `⊢ P ∨ Q` then you
need to decide whether you're going to prove `P` or `Q`.
If you want to prove `P` then use the `left` tactic,
and if you want to prove `Q` then use the `right` tactic.
Don't get lost! You can't go back.
-/

-- recall that P, Q, R are Propositions. We'll need S for this one.
variable (S : Prop)

-- use the `left` tactic to reduce from `⊢ P ∨ Q` to `⊢ P`
theorem or.intro_left : P → P ∨ Q :=
begin
  intro hP,
  -- ⊢ P ∨ Q
  left,
  -- ⊢ P
  exact hP
end

-- use the `right` tactic to reduce from `⊢ P ∨ Q`
theorem or.intro_right : Q → P ∨ Q :=
begin
  sorry,
end

theorem or.elim : P ∨ Q → (P → R) → (Q → R) → R :=
begin
  intro hPoQ,
  intros hpq hqr,
  -- use the `cases h` tactic if `h : X ∨ Y`
  cases hPoQ with hP hQ,
    sorry,
  sorry
end

theorem or.symm : P ∨ Q → Q ∨ P :=
begin
  sorry
end

theorem or.comm : P ∨ Q ↔ Q ∨ P :=
begin
  sorry
end

theorem or.assoc : (P ∨ Q) ∨ R ↔ P ∨ Q ∨ R :=
begin
  sorry,
end

theorem or.cases_on : P ∨ Q → (P → R) → (Q → R) → R :=
begin
  sorry,
end

theorem or.imp : (P → R) → (Q → S) → P ∨ Q → R ∨ S :=
begin
  sorry,
end

theorem or.imp_left : (P → Q) → P ∨ R → Q ∨ R :=
begin
  sorry,
end

theorem or.imp_right : (P → Q) → R ∨ P → R ∨ Q :=
begin
  sorry,
end

theorem or.left_comm : P ∨ Q ∨ R ↔ Q ∨ P ∨ R :=
begin
  sorry,
end

theorem or.rec : (P → R) → (Q → R) → P ∨ Q → R :=
begin
  sorry
end

theorem or.resolve_left : P ∨ Q → ¬P → Q :=
begin
  sorry,
end

theorem or_congr : (P ↔ R) → (Q ↔ S) → (P ∨ Q ↔ R ∨ S) :=
begin
  sorry,
end

/-!

# Appendix: `exfalso` and classical logic

-/

-- useful lemma about false
theorem false.elim' : false → P :=
begin
  -- Let's assume that a false proposition is true. Let's
  -- call this assumption h.
  intro h,
  -- We now have to prove P.
  -- The `exfalso` tactic changes any goal to `false`.
  exfalso,
  -- Now our goal is an assumption! It's exactly `h`.
  exact h,
end

-- Is that confusing? What about this proof?
theorem false.elim'' : false → P :=
begin
  -- Let's assume that a false proposition is true. Let's
  -- call this assumption h.
  intro h,
  -- Now let's deal with all the cases.
  cases h,
  -- There are no cases.
end

-- This next one cannot be proved using the tactics we know
-- which are constructive. This one needs the assumption
-- that every statement is true or false.
-- We give a "by cases" proof explicitly -- `finish` just does the
-- job immediately.
theorem double_negation_elimination : ¬ (¬ P) → P :=
begin
  -- `finish` works
  classical,
  intro hnnP,
  by_cases hP : P,
    -- hypothesis hP : P
    assumption,
  -- hypothesis hP : ¬ P
  -- `contradiction` works from here
  exfalso,
  apply hnnP,
  exact hP,
end

end xena


/-
Copyright (c) 2021 Tian Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tian Chen
-/
import data.pnat.basic

/-!
# IMO 1977 Q6

Suppose `f : ℕ+ → ℕ+` satisfies `f(f(n)) < f(n + 1)` for all `n`.
Prove that `f(n) = n` for all `n`.

We first prove the problem statement for `f : ℕ → ℕ`
then we use it to prove the statement for positive naturals.
-/

theorem imo1977_q6_nat (f : ℕ → ℕ) (h : ∀ n, f (f n) < f (n + 1)) :
  ∀ n, f n = n :=
begin
  have h' : ∀ (k n : ℕ), k ≤ n → k ≤ f n,
  { intro k,
    induction k with k h_ind,
    { intros, exact nat.zero_le _ },
    { intros n hk,
      apply nat.succ_le_of_lt,
      calc k ≤ f (f (n - 1)) : h_ind _ (h_ind (n - 1) (le_tsub_of_add_le_right hk))
         ... < f n           : tsub_add_cancel_of_le
        (le_trans (nat.succ_le_succ (nat.zero_le _)) hk) ▸ h _ } },
  have hf : ∀ n, n ≤ f n := λ n, h' n n rfl.le,
  have hf_mono : strict_mono f := strict_mono_nat_of_lt_succ (λ _, lt_of_le_of_lt (hf _) (h _)),
  intro,
  exact nat.eq_of_le_of_lt_succ (hf _) (hf_mono.lt_iff_lt.mp (h _))
end

theorem imo1977_q6 (f : ℕ+ → ℕ+) (h : ∀ n, f (f n) < f (n + 1)) :
  ∀ n, f n = n :=
begin
  intro n,
  simpa using imo1977_q6_nat (λ m, if 0 < m then f m.to_pnat' else 0) _ n,
  { intro x, cases x,
    { simp },
    { simpa using h _ } }
end