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

Bases of topologies. Countability axioms.
-/

import topology.order

open set filter lattice classical

namespace topological_space
/- countability axioms

For our applications we are interested that there exists a countable basis, but we do not need the
concrete basis itself. This allows us to declare these type classes as `Prop` to use them as mixins.
-/
universe u
variables {α : Type u} [t : topological_space α]
include t

/-- A topological basis is one that satisfies the necessary conditions so that
  it suffices to take unions of the basis sets to get a topology (without taking
  finite intersections as well). -/
def is_topological_basis (s : set (set α)) : Prop :=
(∀t₁∈s, ∀t₂∈s, ∀ x ∈ t₁ ∩ t₂, ∃ t₃∈s, x ∈ t₃ ∧ t₃ ⊆ t₁ ∩ t₂) ∧
(⋃₀ s) = univ ∧
t = generate_from s

lemma is_topological_basis_of_subbasis {s : set (set α)} (hs : t = generate_from s) :
  is_topological_basis ((λf, ⋂₀ f) '' {f:set (set α) | finite f ∧ f ⊆ s ∧ ⋂₀ f ≠ ∅}) :=
let b' := (λf, ⋂₀ f) '' {f:set (set α) | finite f ∧ f ⊆ s ∧ ⋂₀ f ≠ ∅} in
⟨assume s₁ ⟨t₁, ⟨hft₁, ht₁b, ht₁⟩, eq₁⟩ s₂ ⟨t₂, ⟨hft₂, ht₂b, ht₂⟩, eq₂⟩,
    have ie : ⋂₀(t₁ ∪ t₂) = ⋂₀ t₁ ∩ ⋂₀ t₂, from Inf_union,
    eq₁ ▸ eq₂ ▸ assume x h,
      ⟨_, ⟨t₁ ∪ t₂, ⟨finite_union hft₁ hft₂, union_subset ht₁b ht₂b,
        by simpa only [ie] using ne_empty_of_mem h⟩, ie⟩, h, subset.refl _⟩,
  eq_univ_iff_forall.2 $ assume a, ⟨univ, ⟨∅, ⟨finite_empty, empty_subset _,
    by rw sInter_empty; exact nonempty_iff_univ_ne_empty.1 ⟨a⟩⟩, sInter_empty⟩, mem_univ _⟩,
 have generate_from s = generate_from b',
    from le_antisymm
      (generate_from_le $ assume s hs,
        by_cases
          (assume : s = ∅, by rw [this]; apply @is_open_empty _ _)
          (assume : s ≠ ∅, generate_open.basic _ ⟨{s}, ⟨finite_singleton s, singleton_subset_iff.2 hs,
            by rwa [sInter_singleton]⟩, sInter_singleton s⟩))
      (generate_from_le $ assume u ⟨t, ⟨hft, htb, ne⟩, eq⟩,
        eq ▸ @is_open_sInter _ (generate_from s) _ hft (assume s hs, generate_open.basic _ $ htb hs)),
  this ▸ hs⟩

lemma is_topological_basis_of_open_of_nhds {s : set (set α)}
  (h_open : ∀ u ∈ s, _root_.is_open u)
  (h_nhds : ∀(a:α) (u : set α), a ∈ u → _root_.is_open u → ∃v ∈ s, a ∈ v ∧ v ⊆ u) :
  is_topological_basis s :=
⟨assume t₁ ht₁ t₂ ht₂ x ⟨xt₁, xt₂⟩,
    h_nhds x (t₁ ∩ t₂) ⟨xt₁, xt₂⟩
      (is_open_inter _ _ _ (h_open _ ht₁) (h_open _ ht₂)),
  eq_univ_iff_forall.2 $ assume a,
    let ⟨u, h₁, h₂, _⟩ := h_nhds a univ trivial (is_open_univ _) in
    ⟨u, h₁, h₂⟩,
  le_antisymm
    (assume u hu,
      (@is_open_iff_nhds α (generate_from _) _).mpr $ assume a hau,
        let ⟨v, hvs, hav, hvu⟩ := h_nhds a u hau hu in
        by rw nhds_generate_from; exact infi_le_of_le v (infi_le_of_le ⟨hav, hvs⟩ $ le_principal_iff.2 hvu))
    (generate_from_le h_open)⟩

lemma mem_nhds_of_is_topological_basis {a : α} {s : set α} {b : set (set α)}
  (hb : is_topological_basis b) : s ∈ nhds a ↔ ∃t∈b, a ∈ t ∧ t ⊆ s :=
begin
  change s ∈ (nhds a).sets ↔ ∃t∈b, a ∈ t ∧ t ⊆ s,
  rw [hb.2.2, nhds_generate_from, infi_sets_eq'],
  { simp only [mem_bUnion_iff, exists_prop, mem_set_of_eq, and_assoc, and.left_comm], refl },
  { exact assume s ⟨hs₁, hs₂⟩ t ⟨ht₁, ht₂⟩,
      have a ∈ s ∩ t, from ⟨hs₁, ht₁⟩,
      let ⟨u, hu₁, hu₂, hu₃⟩ := hb.1 _ hs₂ _ ht₂ _ this in
      ⟨u, ⟨hu₂, hu₁⟩, le_principal_iff.2 (subset.trans hu₃ (inter_subset_left _ _)),
        le_principal_iff.2 (subset.trans hu₃ (inter_subset_right _ _))⟩ },
  { rcases eq_univ_iff_forall.1 hb.2.1 a with ⟨i, h1, h2⟩,
    exact ⟨i, h2, h1⟩ }
end

lemma is_open_of_is_topological_basis {s : set α} {b : set (set α)}
  (hb : is_topological_basis b) (hs : s ∈ b) : _root_.is_open s :=
is_open_iff_mem_nhds.2 $ λ a as,
(mem_nhds_of_is_topological_basis hb).2 ⟨s, hs, as, subset.refl _⟩

lemma mem_basis_subset_of_mem_open {b : set (set α)}
  (hb : is_topological_basis b) {a:α} {u : set α} (au : a ∈ u)
  (ou : _root_.is_open u) : ∃v ∈ b, a ∈ v ∧ v ⊆ u :=
(mem_nhds_of_is_topological_basis hb).1 $ mem_nhds_sets ou au

lemma sUnion_basis_of_is_open {B : set (set α)}
  (hB : is_topological_basis B) {u : set α} (ou : _root_.is_open u) :
  ∃ S ⊆ B, u = ⋃₀ S :=
⟨{s ∈ B | s ⊆ u}, λ s h, h.1, set.ext $ λ a,
  ⟨λ ha, let ⟨b, hb, ab, bu⟩ := mem_basis_subset_of_mem_open hB ha ou in
         ⟨b, ⟨hb, bu⟩, ab⟩,
   λ ⟨b, ⟨hb, bu⟩, ab⟩, bu ab⟩⟩

lemma Union_basis_of_is_open {B : set (set α)}
  (hB : is_topological_basis B) {u : set α} (ou : _root_.is_open u) :
  ∃ (β : Type u) (f : β → set α), u = (⋃ i, f i) ∧ ∀ i, f i ∈ B :=
let ⟨S, sb, su⟩ := sUnion_basis_of_is_open hB ou in
⟨S, subtype.val, su.trans set.sUnion_eq_Union, λ ⟨b, h⟩, sb h⟩

variables (α)

/-- A separable space is one with a countable dense subset. -/
class separable_space : Prop :=
(exists_countable_closure_eq_univ : ∃s:set α, countable s ∧ closure s = univ)

/-- A first-countable space is one in which every point has a
  countable neighborhood basis. -/
class first_countable_topology : Prop :=
(nhds_generated_countable : ∀a:α, ∃s:set (set α), countable s ∧ nhds a = (⨅t∈s, principal t))

/-- A second-countable space is one with a countable basis. -/
class second_countable_topology : Prop :=
(is_open_generated_countable : ∃b:set (set α), countable b ∧ t = topological_space.generate_from b)

instance second_countable_topology.to_first_countable_topology
  [second_countable_topology α] : first_countable_topology α :=
let ⟨b, hb, eq⟩ := second_countable_topology.is_open_generated_countable α in
⟨assume a, ⟨{s | a ∈ s ∧ s ∈ b},
  countable_subset (assume x ⟨_, hx⟩, hx) hb, by rw [eq, nhds_generate_from]⟩⟩

lemma second_countable_topology_induced (β)
  [t : topological_space β] [second_countable_topology β] (f : α → β) :
  @second_countable_topology α (t.induced f) :=
begin
  rcases second_countable_topology.is_open_generated_countable β with ⟨b, hb, eq⟩,
  refine { is_open_generated_countable := ⟨preimage f '' b, countable_image _ hb, _⟩ },
  rw [eq, induced_generate_from_eq]
end

instance subtype.second_countable_topology
  (s : set α) [topological_space α] [second_countable_topology α] : second_countable_topology s :=
second_countable_topology_induced s α coe

lemma is_open_generated_countable_inter [second_countable_topology α] :
  ∃b:set (set α), countable b ∧ ∅ ∉ b ∧ is_topological_basis b :=
let ⟨b, hb₁, hb₂⟩ := second_countable_topology.is_open_generated_countable α in
let b' := (λs, ⋂₀ s) '' {s:set (set α) | finite s ∧ s ⊆ b ∧ ⋂₀ s ≠ ∅} in
⟨b',
  countable_image _ $ countable_subset
    (by simp only [(and_assoc _ _).symm]; exact inter_subset_left _ _)
    (countable_set_of_finite_subset hb₁),
  assume ⟨s, ⟨_, _, hn⟩, hp⟩, hn hp,
  is_topological_basis_of_subbasis hb₂⟩

instance second_countable_topology.to_separable_space
  [second_countable_topology α] : separable_space α :=
let ⟨b, hb₁, hb₂, hb₃, hb₄, eq⟩ := is_open_generated_countable_inter α in
have nhds_eq : ∀a, nhds a = (⨅ s : {s : set α // a ∈ s ∧ s ∈ b}, principal s.val),
  by intro a; rw [eq, nhds_generate_from, infi_subtype]; refl,
have ∀s∈b, ∃a, a ∈ s, from assume s hs, exists_mem_of_ne_empty $ assume eq, hb₂ $ eq ▸ hs,
have ∃f:∀s∈b, α, ∀s h, f s h ∈ s, by simp only [skolem] at this; exact this,
let ⟨f, hf⟩ := this in
⟨⟨(⋃s∈b, ⋃h:s∈b, {f s h}),
  countable_bUnion hb₁ (λ _ _, countable_Union_Prop $ λ _, countable_singleton _),
  set.ext $ assume a,
  have a ∈ (⋃₀ b), by rw [hb₄]; exact trivial,
  let ⟨t, ht₁, ht₂⟩ := this in
  have w : {s : set α // a ∈ s ∧ s ∈ b}, from ⟨t, ht₂, ht₁⟩,
  suffices (⨅ (x : {s // a ∈ s ∧ s ∈ b}), principal (x.val ∩ ⋃s (h₁ h₂ : s ∈ b), {f s h₂})) ≠ ⊥,
    by simpa only [closure_eq_nhds, nhds_eq, infi_inf w, inf_principal, mem_set_of_eq, mem_univ, iff_true],
  infi_neq_bot_of_directed ⟨a⟩
    (assume ⟨s₁, has₁, hs₁⟩ ⟨s₂, has₂, hs₂⟩,
      have a ∈ s₁ ∩ s₂, from ⟨has₁, has₂⟩,
      let ⟨s₃, hs₃, has₃, hs⟩ := hb₃ _ hs₁ _ hs₂ _ this in
      ⟨⟨s₃, has₃, hs₃⟩, begin
        simp only [le_principal_iff, mem_principal_sets, (≥)],
        simp only [subset_inter_iff] at hs, split;
          apply inter_subset_inter_left; simp only [hs]
      end⟩)
    (assume ⟨s, has, hs⟩,
      have s ∩ (⋃ (s : set α) (H h : s ∈ b), {f s h}) ≠ ∅,
        from ne_empty_of_mem ⟨hf _ hs, mem_bUnion hs $ mem_Union.mpr ⟨hs, mem_singleton _⟩⟩,
      mt principal_eq_bot_iff.1 this) ⟩⟩

variables {α}

lemma is_open_Union_countable [second_countable_topology α]
  {ι} (s : ι → set α) (H : ∀ i, _root_.is_open (s i)) :
  ∃ T : set ι, countable T ∧ (⋃ i ∈ T, s i) = ⋃ i, s i :=
let ⟨B, cB, _, bB⟩ := is_open_generated_countable_inter α in
begin
  let B' := {b ∈ B | ∃ i, b ⊆ s i},
  choose f hf using λ b:B', b.2.2,
  haveI : encodable B' := (countable_subset (sep_subset _ _) cB).to_encodable,
  refine ⟨_, countable_range f,
    subset.antisymm (bUnion_subset_Union _ _) (sUnion_subset _)⟩,
  rintro _ ⟨i, rfl⟩ x xs,
  rcases mem_basis_subset_of_mem_open bB xs (H _) with ⟨b, hb, xb, bs⟩,
  exact ⟨_, ⟨_, rfl⟩, _, ⟨⟨⟨_, hb, _, bs⟩, rfl⟩, rfl⟩, hf _ (by exact xb)⟩
end

lemma is_open_sUnion_countable [second_countable_topology α]
  (S : set (set α)) (H : ∀ s ∈ S, _root_.is_open s) :
  ∃ T : set (set α), countable T ∧ T ⊆ S ∧ ⋃₀ T = ⋃₀ S :=
let ⟨T, cT, hT⟩ := is_open_Union_countable (λ s:S, s.1) (λ s, H s.1 s.2) in
⟨subtype.val '' T, countable_image _ cT,
  image_subset_iff.2 $ λ ⟨x, xs⟩ xt, xs,
  by rwa [sUnion_image, sUnion_eq_Union]⟩

end topological_space


import tactic
import data.set.finite
import data.real.basic

import topological_spaces
import neighbourhoods
import topological_spaces2
import metric_spaces

open set

open topological_space
open metric_space

lemma Q_dense : dense {(q : ℝ) | (q : ℚ)} :=
begin
  apply subset.antisymm,
  simp,
  intros x hx,
  have clef : ∀ (n : ℕ), ∃ (q : ℚ), x < q ∧ (q : ℝ) < x + 1/(n+1),
  intro n,
  apply exists_rat_btwn,
  { have : (0 : ℝ) < 1/(n+1),
   exact nat.one_div_pos_of_nat,
   linarith },
  choose u hu using clef,
  apply seq_lim_closure (λ n, (u n : ℝ)), simp,
  sorry,
end

-- Topologie quotient :
instance quot.topological_space {X : Type} [topological_space X] (s : setoid X) : topological_space (quotient s) :=
{ is_open  := λ U, is_open ((quotient.mk') ⁻¹' U),
  univ_mem := univ_mem,
  inter    := begin intros A B hA hB, apply inter, exact hA, exact hB, end,
  union    :=
  begin
    intros B hB,
    rw preimage_sUnion,
    apply union, simp,
    intro b, apply union, simp,
    exact hB b,
  end }

-- Relation d'equivalence definissant ℝ/ℚ :
def real.rel_Q : setoid ℝ :=
{ r := λ x y, ∃ (q : ℚ), x - y = q,
  iseqv :=
  begin
    repeat {split},
    intro x,
    use 0,
    simp,
    rintros x y ⟨q, hq⟩,
    use -q,
    simp, rw ← hq,
    simp,
    rintros x y z ⟨q, hq⟩ ⟨q', hq'⟩,
    use (q + q'),
    calc x - z = (x - y) + (y - z) : by linarith
           ... = ↑(q + q') : by simp [hq, hq'],
  end}

-- La topologie quotient sur ℝ/ℚ est la topologie grossiere :
example (U : set (quotient real.rel_Q)) : is_open U ↔ U = ∅ ∨ U = univ :=
begin
  split,
  { intro hyp,
    cases em (U.nonempty) with h1 h2,
    { right,
      cases h1 with X hX,
      cases quotient.surjective_quotient_mk' X with x hx,
      rw ← hx at hX,
      rcases is_open_metric_iff.1 hyp x hX with ⟨r, hr, H⟩,
      apply subset.antisymm, simp,
      intros Y hY,
      cases quotient.surjective_quotient_mk' Y with y hy,
      let V := {z : ℝ | dist (x - y) z < r },
      have hV : V ∈ neighbourhoods (x - y),
      { apply generated_filter.generator, split,
        apply generated_open.generator,
        use [x - y, r],
        calc dist (x - y) (x - y) = 0 : (dist_eq_zero_iff _ _).2 rfl
                              ... < r : hr },
      have clef : closure {(q : ℝ) | (q : ℚ)} = univ, exact Q_dense,
      cases (point_of_closure {(q : ℝ) | (q : ℚ)} (x - y)).1 (by simp [clef]) V hV with z hz,
      rcases hz with ⟨hz, q, hq⟩,
      have hyz : quotient.mk' (y + z) = Y, rw ← hy, rw quotient.eq', use q, simp [hq],
      rw ← hyz,
      apply H,
      have : x - (y + z) = (x - y) - z, by linarith,
      calc dist x (y + z) = abs (x - (y + z))   : rfl
                      ... = abs ((x - y) - z)   : by simp [this]
                      ... = dist (x - y) z      : rfl
                      ... < r                   : hz, },
    { left,
      apply le_antisymm, intros x hx, apply h2, use [x, hx], simp, }, },
  { intro hyp,
    cases hyp with h1 h2,
    rw h1, exact empty_mem,
    rw h2, exact univ_mem, },
end

-- Relation d'equivalence definissant ℝ/ℤ :
def real.rel_Z : setoid ℝ :=
{ r := λ x y, ∃ (n : ℤ), x - y = n,
  iseqv :=
  begin
    repeat {split},
    intro x,
    use 0,
    simp,
    rintros x y ⟨n, hn⟩,
    use -n,
    simp, rw ← hn,
    simp,
    rintros x y z ⟨n, hn⟩ ⟨n', hn'⟩,
    use (n + n'),
    calc x - z = (x - y) + (y - z) : by linarith
           ... = ↑(n + n') : by simp [hn, hn'],
  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 ef7acf407d265ad4081c8998687e994fa80ba70c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Pfunctor.Multivariate.W
import Mathbin.Data.Qpf.Multivariate.Basic

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

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

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 α`.

```lean
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.W_mk a f' f₀) (q.P.W_mk 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.append_contents f'₀ f₀⟩ = abs ⟨a₁, q.P.append_contents f'₁ f₁⟩ →
        Wequiv (q.P.W_mk a₀ f'₀ f₀) (q.P.W_mk a₁ f'₁ f₁)
| trans (u v w : q.P.W α) : Wequiv u v → Wequiv v w → Wequiv u w
```

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]

include q

#print MvQPF.recF /-
/-- `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⟩)
#align mvqpf.recF MvQPF.recF
-/

#print MvQPF.recF_eq /-
theorem recF_eq {α : TypeVec n} {β : Type _} (g : F (α.append1 β) → β) (a : q.p.A)
    (f' : q.p.drop.B a ⟹ α) (f : q.p.getLast.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
#align mvqpf.recF_eq MvQPF.recF_eq
-/

#print 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.W_dest'_W_mk, MvPFunctor.map_eq, append_fun_comp_split_fun, TypeVec.id_comp]
#align mvqpf.recF_eq' MvQPF.recF_eq'
-/

#print MvQPF.WEquiv /-
/-- 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.getLast.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.getLast.B a₀ → q.p.W α) (a₁ : q.p.A)
    (f'₁ : q.p.drop.B a₁ ⟹ α) (f₁ : q.p.getLast.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
#align mvqpf.Wequiv MvQPF.WEquiv
-/

#print MvQPF.recF_eq_of_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; induction h
  case ind a f' f₀ f₁ h ih => simp only [recF_eq, Function.comp, ih]
  case abs a₀ f'₀ f₀ a₁ f'₁ f₁ h => simp only [recF_eq', abs_map, MvPFunctor.wDest'_wMk, h]
  case trans x y z e₁ e₂ ih₁ ih₂ => exact Eq.trans ih₁ ih₂
#align mvqpf.recF_eq_of_Wequiv MvQPF.recF_eq_of_wEquiv
-/

#print MvQPF.wEquiv.abs' /-
theorem wEquiv.abs' {α : TypeVec n} (x y : q.p.W α) (h : abs (q.p.wDest' x) = 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
#align mvqpf.Wequiv.abs' MvQPF.wEquiv.abs'
-/

#print MvQPF.wEquiv.refl /-
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
#align mvqpf.Wequiv.refl MvQPF.wEquiv.refl
-/

#print MvQPF.wEquiv.symm /-
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₁
#align mvqpf.Wequiv.symm MvQPF.wEquiv.symm
-/

#print MvQPF.wrepr /-
/-- 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)
#align mvqpf.Wrepr MvQPF.wrepr
-/

#print MvQPF.wrepr_wMk /-
theorem wrepr_wMk {α : TypeVec n} (a : q.p.A) (f' : q.p.drop.B a ⟹ α)
    (f : q.p.getLast.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.W_dest'_W_mk] <;> rfl
#align mvqpf.Wrepr_W_mk MvQPF.wrepr_wMk
-/

#print MvQPF.wrepr_equiv /-
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.W_mk' (append_fun id Wrepr <$$> ⟨a, q.P.append_contents f' f⟩))
  · apply Wequiv.abs'
    rw [Wrepr_W_mk, q.P.W_dest'_W_mk', q.P.W_dest'_W_mk', abs_repr]
  rw [q.P.map_eq, MvPFunctor.wMk', append_fun_comp_split_fun, id_comp]
  apply Wequiv.ind; exact ih
#align mvqpf.Wrepr_equiv MvQPF.wrepr_equiv
-/

#print MvQPF.wEquiv_map /-
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_W_mk, q.P.W_map_W_mk]; apply Wequiv.ind; apply ih
  case
    abs a₀ f'₀ f₀ a₁ f'₁ f₁ h =>
    rw [q.P.W_map_W_mk, q.P.W_map_W_mk]; apply Wequiv.abs
    show
      abs (q.P.obj_append1 a₀ (g ⊚ f'₀) fun x => q.P.W_map g (f₀ x)) =
        abs (q.P.obj_append1 a₁ (g ⊚ f'₁) fun x => q.P.W_map g (f₁ x))
    rw [← q.P.map_obj_append1, ← q.P.map_obj_append1, abs_map, abs_map, h]
  case trans x y z e₁ e₂ ih₁ ih₂ => apply MvQPF.WEquiv.trans; apply ih₁; apply ih₂
#align mvqpf.Wequiv_map MvQPF.wEquiv_map
-/

#print MvQPF.wSetoid /-
/-- 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 _ _ _ _ _⟩
#align mvqpf.W_setoid MvQPF.wSetoid
-/

attribute [local instance] W_setoid

#print MvQPF.Fix /-
/-- 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

#print MvQPF.Fix.map /-
/-- `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
-/

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

variable {α : TypeVec.{u} n}

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print MvQPF.Fix.rec /-
/-- 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
-/

#print MvQPF.fixToW /-
/-- 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))
#align mvqpf.fix_to_W MvQPF.fixToW
-/

#print MvQPF.Fix.mk /-
/-- 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
-/

#print MvQPF.Fix.dest /-
/-- 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
-/

#print MvQPF.Fix.rec_eq /-
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, ← append_fun_comp, id_comp, this]
#align mvqpf.fix.rec_eq MvQPF.Fix.rec_eq
-/

#print MvQPF.Fix.ind_aux /-
theorem Fix.ind_aux (a : q.p.A) (f' : q.p.drop.B a ⟹ α) (f : q.p.getLast.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_W_mk, q.P.W_dest'_W_mk', abs_repr, MvPFunctor.map_eq]
    congr 2; rw [MvPFunctor.appendContents, MvPFunctor.appendContents]
    rw [append_fun, append_fun, ← split_fun_comp, ← split_fun_comp]
    rfl
  rw [this]
  apply Quot.sound
  apply Wrepr_equiv
#align mvqpf.fix.ind_aux MvQPF.Fix.ind_aux
-/

#print MvQPF.Fix.ind_rec /-
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.W_mk a f' f⟧ = g₂ ⟦q.P.W_mk 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, append_fun, append_fun, ← split_fun_comp, ← split_fun_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
-/

#print MvQPF.Fix.rec_unique /-
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
-/

#print MvQPF.Fix.mk_dest /-
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, ← append_fun_comp, id_comp]
  intro h; rw [h]
  show fix.mk (append_fun id id <$$> x) = fix.mk x
  rw [append_fun_id_id, MvFunctor.id_map]
#align mvqpf.fix.mk_dest MvQPF.Fix.mk_dest
-/

#print MvQPF.Fix.dest_mk /-
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 [← append_fun_comp, id_comp]
  have : fix.mk ∘ fix.dest = id := by
    ext x
    apply fix.mk_dest
  rw [this, append_fun_id_id]
#align mvqpf.fix.dest_mk MvQPF.Fix.dest_mk
-/

#print MvQPF.Fix.ind /-
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.W_mk 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
-/

#print MvQPF.mvqpfFix /-
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]
    rw [fix.map]; apply Quot.sound
    apply Wequiv.refl
#align mvqpf.mvqpf_fix MvQPF.mvqpfFix
-/

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print MvQPF.Fix.drec /-
/-- 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 [y]
    apply fix.ind_rec _ id _ x
    intro x' ih
    rw [fix.rec_eq]
    dsimp
    simp [append_fun_id_id] at ih
    congr
    conv =>
      rhs
      rw [← ih]
    rw [MvFunctor.map_map, ← append_fun_comp, id_comp]
  cast (by rw [this]) y.2
#align mvqpf.fix.drec MvQPF.Fix.drec
-/

end MvQPF


import tactic.linear_combination
import data.real.basic

/-! ### Simple Cases with ℤ and two or less equations -/

example (x y : ℤ) (h1 : 3*x + 2*y = 10):
  3*x + 2*y = 10 :=
by linear_combination 1*h1

example (x y : ℤ) (h1 : 3*x + 2*y = 10):
  3*x + 2*y = 10 :=
by linear_combination (h1)

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  2*x + 4 = -6 :=
by linear_combination 2*h1

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination 1*h1 - 2*h2

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination -2*h2 + h1

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  2*x + 4 - y = -16 :=
by linear_combination 2*h1 + -1*h2

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  -y + 2*x + 4 = -16 :=
by linear_combination -h2 + 2*h1

example (x y : ℤ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  11*y = -11 :=
by linear_combination -2*h1 + 3*h2

example (x y : ℤ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y = 11 :=
by linear_combination 2*h1 - 3*h2

example (x y : ℤ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y = 11 + 1 - 1 :=
by linear_combination 2*h1 + -3*h2

example (x y : ℤ) (h1 : 10 = 3*x + 2*y) (h2 : 3 = 2*x + 5*y) :
  11 + 1 - 1 = -11*y :=
by linear_combination 2*h1 - 3*h2

/-! ### More complicated cases with two equations -/

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  -y + 2*x + 4 = -16 :=
by linear_combination 2*h1 - h2

example (x y : ℚ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y + 1 = 11 + 1 :=
by linear_combination 2*h1 - 3*h2

example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) :
  b = 2 / 3 :=
by linear_combination ha/6 + hab/3

/-! ### Cases with more than 2 equations -/

example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) (hignore : 3 = a + b) :
  b = 2 / 3 :=
by linear_combination 1/6 * ha + 1/3 * hab + 0 * hignore

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  -3*x - 3*y - 4*z = 2 :=
by linear_combination ha - hb - 2*hc

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  6*x = -10 :=
by linear_combination 1*ha + 4*hb - 3*hc

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  10 = 6*-x :=
by linear_combination ha + 4*hb - 3*hc

example (w x y z : ℝ) (h1 : x + 2.1*y + 2*z = 2) (h2 : x + 8*z + 5*w = -6.5)
    (h3 : x + y + 5*z + 5*w = 3) :
  x + 2.2*y + 2*z - 5*w = -8.5 :=
by linear_combination 2*h1 + 1*h2 - 2*h3

example (w x y z : ℝ) (h1 : x + 2.1*y + 2*z = 2) (h2 : x + 8*z + 5*w = -6.5)
    (h3 : x + y + 5*z + 5*w = 3) :
  x + 2.2*y + 2*z - 5*w = -8.5 :=
by linear_combination 2*h1 + h2 - 2*h3

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c*3 = d) (h4 : -d = a) :
  2*a - 3 + 9*c + 3*d = 8 - b + 3*d - 3*a :=
by linear_combination 2*h1 -1*h2 +3*h3 -3*h4

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c*3 = d) (h4 : -d = a) :
  6 - 3*c + 3*a + 3*d = 2*b - d + 12 - 3*a :=
by linear_combination 2*h2 -h3 +3*h1 -3*h4

/-! ### Cases with non-hypothesis inputs -/

constants (qc : ℚ) (hqc : qc = 2*qc)

example (a b : ℚ) (h : ∀ p q : ℚ, p = q) : 3*a + qc = 3*b + 2*qc :=
by linear_combination 3 * h a b + hqc

constant bad (q : ℚ) : q = 0

example (a b : ℚ) : a + b^3 = 0 :=
by linear_combination bad a + b * bad (b*b)

/-! ### Cases with arbitrary coefficients -/

example (a b : ℤ) (h : a = b) :
  a * a = a * b :=
by linear_combination a*h

example (a b c : ℤ) (h : a = b) :
  a * c = b * c :=
by linear_combination c*h

example (a b c : ℤ) (h1 : a = b) (h2 : b = 1) :
  c * a + b = c * b + 1 :=
by linear_combination c*h1 + h2

example (x y : ℚ) (h1 : x + y = 3) (h2 : 3*x = 7) :
  x*x*y + y*x*y + 6*x = 3*x*y + 14 :=
by linear_combination x*y*h1 + 2*h2

example {α} [h : comm_ring α] {a b c d e f : α} (h1 : a*d = b*c) (h2 : c*f = e*d) :
  c * (a*f - b*e) = 0 :=
by linear_combination e*h1 + a*h2

example (x y z w : ℚ) (hzw : z = w) : x*z + 2*y*z = x*w + 2*y*w :=
by linear_combination (x + 2*y)*hzw

/-! ### Cases that explicitly use a linear_combination_config -/

example (x y : ℚ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y + 1 = 11 + 1 :=
by linear_combination 2*h1 -3*h2 with {normalization_tactic := `[ring]}

example (x y : ℚ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y + 1 = 11 + 1 :=
by linear_combination 2*h1 + -3*h2 with {normalization_tactic := `[ring1]}

example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) :
  b = 2 / 3 :=
by linear_combination 1/6*ha + 1/3*hab with {normalization_tactic := `[ring_nf]}

example (x y : ℤ) (h1 : 3*x + 2*y = 10):
  3*x + 2*y = 10 :=
by linear_combination h1 with {normalization_tactic := `[simp]}

/-! ### Cases that have linear_combination skip normalization -/

example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) :
  b = 2 / 3 :=
begin
  linear_combination 1/6*ha + 1/3*hab with {normalize := ff},
  linarith
end

example (x y : ℤ) (h1 : x = -3) (h2 : y = 10) :
  2*x = -6 :=
begin
  linear_combination 2*h1 with {normalize := ff},
  simp,
  norm_cast
end

/-! ### Cases without any arguments provided -/

-- the corner case is "just apply the normalization procedure".
-- an empty `linear_combination` at the end of a declaration is a bad edge case for the parser.
example {x y z w : ℤ} (h₁ : 3 * x = 4 + y) (h₂ : x + 2 * y = 1) : z + w = w + z :=
by linear_combination

.

-- this interacts as expected with options
example {x y z w : ℤ} (h₁ : 3 * x = 4 + y) (h₂ : x + 2 * y = 1) : z + w = w + z :=
begin
  linear_combination with {normalize := ff},
  guard_target' z + w - (w + z) - (0 - 0) = 0,
  simp [add_comm]
end

example {x y z w : ℤ} (h₁ : 3 * x = 4 + y) (h₂ : x + 2 * y = 1) : z + w = w + z :=
by linear_combination with {normalization_tactic := `[simp [add_comm]]}

/-! ### Cases with exponent -/

example (x y z : ℚ) (h : x = y) (h2 : x * y = 0) : x + y*z = 0 :=
by linear_combination (-y * z ^ 2 + x) * h + (z ^ 2 + 2 * z + 1) * h2 with {exponent := 2}

example (x y z : ℚ) (h : x = y) (h2 : x * y = 0) : y*z = -x :=
begin
  linear_combination (-y * z ^ 2 + x) * h + (z ^ 2 + 2 * z + 1) * h2
    with {exponent := 2, normalize := ff},
  ring
end

example (K : Type)
  [field K]
  [char_zero K]
  {x y z : K}
  (h₂ : y ^ 3 + x * (3 * z ^ 2) = 0)
  (h₁ : x ^ 3 + z * (3 * y ^ 2) = 0)
  (h₀ : y * (3 * x ^ 2) + z ^ 3 = 0)
  (h : x ^ 3 * y + y ^ 3 * z + z ^ 3 * x = 0) :
  x = 0 :=
by linear_combination 2 * y * z ^ 2 * h₂ / 7 + (x ^ 3  - y ^ 2 * z / 7) * h₁ -
  x * y * z * h₀ + y * z * h / 7 with {exponent := 6}

/-! ### Cases where the goal is not closed -/

example (x y : ℚ) (h1 : x + y = 3) (h2 : 3*x = 7) :
  x*x*y + y*x*y + 6*x = 3*x*y + 14 :=
begin
  linear_combination x*y*h1 + h2,
  guard_target' (x * 3 - 7 = 0),
  linear_combination h2
end

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c*3 = d) (h4 : -d = a) :
  6 - 3*c + 3*a + 3*d = 2*b - d + 12 - 3*a :=
begin
  linear_combination 2*h2,
  linear_combination -h3,
  linear_combination 3*h1,
  linear_combination -3*h4,
end

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
begin
  linear_combination,
  linear_combination h1 - 2 * h2,
end

/-! ### Cases that should fail -/

-- This should fail because the second coefficient has a different type than
--   the equations it is being combined with.  This was a design choice for the
--   sake of simplicity, but the tactic could potentially be modified to allow
--   this behavior.
example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y + 2*x = 1 :=
begin
  success_if_fail_with_msg {linear_combination h1 + (0 : ℝ) * h2}
    "invalid type ascription, term has type
  ℝ
but is expected to have type
  ℤ",
  linear_combination h1
end

-- This fails because the linear_combination tactic requires the equations
--   and coefficients to use a type that fulfills the add_group condition,
--   and ℕ does not.
example (a b : ℕ) (h1 : a = 3) :
  a = 3 :=
begin
  success_if_fail {linear_combination h1},
  exact h1
end

example (a b : ℤ) (x y : ℝ) (hab : a = b) (hxy : x = y) : 2*x = 2*y :=
begin
  success_if_fail_with_msg {linear_combination 2*hab}
    "hab is an equality between terms of type ℤ, but is expected to be between terms of type ℝ",
  linear_combination 2*hxy
end


/-
Copyright (c) 2020 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import algebra.continued_fractions.computation.approximations
import algebra.continued_fractions.computation.correctness_terminating
import algebra.order.archimedean
import data.rat.floor
/-!
# Termination of Continued Fraction Computations (`gcf.of`)

## Summary
We show that the continued fraction for a value `v`, as defined in
`algebra.continued_fractions.computation.basic`, terminates if and only if `v` corresponds to a
rational number, that is `↑v = q` for some `q : ℚ`.

## Main Theorems

- `generalized_continued_fraction.coe_of_rat` shows that
  `generalized_continued_fraction.of v = generalized_continued_fraction.of q` for `v : α` given that
  `↑v = q` and `q : ℚ`.
- `generalized_continued_fraction.terminates_iff_rat` shows that
  `generalized_continued_fraction.of v` terminates if and only if `↑v = q` for some `q : ℚ`.

## Tags

rational, continued fraction, termination
-/

namespace generalized_continued_fraction

open generalized_continued_fraction (of)

variables {K : Type*} [linear_ordered_field K] [floor_ring K]

/-
We will have to constantly coerce along our structures in the following proofs using their provided
map functions.
-/
local attribute [simp] pair.map int_fract_pair.mapFr

section rat_of_terminates
/-!
### Terminating Continued Fractions Are Rational

We want to show that the computation of a continued fraction `generalized_continued_fraction.of v`
terminates if and only if `v ∈ ℚ`. In this section, we show the implication from left to right.

We first show that every finite convergent corresponds to a rational number `q` and then use the
finite correctness proof (`of_correctness_of_terminates`) of `generalized_continued_fraction.of` to
show that `v = ↑q`.
-/

variables (v : K) (n : ℕ)

lemma exists_gcf_pair_rat_eq_of_nth_conts_aux :
  ∃ (conts : pair ℚ),
    (of v).continuants_aux n = (conts.map coe : pair K) :=
nat.strong_induction_on n
begin
  clear n,
  let g := of v,
  assume n IH,
  rcases n with _|_|n,
  -- n = 0
  { suffices : ∃ (gp : pair ℚ), pair.mk (1 : K) 0 = gp.map coe, by simpa [continuants_aux],
    use (pair.mk 1 0),
    simp },
  -- n = 1
  { suffices : ∃ (conts : pair ℚ), pair.mk g.h 1 = conts.map coe, by
      simpa [continuants_aux],
    use (pair.mk ⌊v⌋ 1),
    simp },
  -- 2 ≤ n
  { cases (IH (n + 1) $ lt_add_one (n + 1)) with pred_conts pred_conts_eq, -- invoke the IH
    cases s_ppred_nth_eq : (g.s.nth n) with gp_n,
    -- option.none
    { use pred_conts,
      have : g.continuants_aux (n + 2) = g.continuants_aux (n + 1), from
        continuants_aux_stable_of_terminated (n + 1).le_succ s_ppred_nth_eq,
      simp only [this, pred_conts_eq] },
    -- option.some
    { -- invoke the IH a second time
      cases (IH n $ lt_of_le_of_lt (n.le_succ) $ lt_add_one $ n + 1)
        with ppred_conts ppred_conts_eq,
      obtain ⟨a_eq_one, z, b_eq_z⟩ : gp_n.a = 1 ∧ ∃ (z : ℤ), gp_n.b = (z : K), from
        of_part_num_eq_one_and_exists_int_part_denom_eq s_ppred_nth_eq,
      -- finally, unfold the recurrence to obtain the required rational value.
      simp only [a_eq_one, b_eq_z,
        (continuants_aux_recurrence s_ppred_nth_eq ppred_conts_eq pred_conts_eq)],
      use (next_continuants 1 (z : ℚ) ppred_conts pred_conts),
      cases ppred_conts, cases pred_conts,
      simp [next_continuants, next_numerator, next_denominator] } }
end

lemma exists_gcf_pair_rat_eq_nth_conts :
  ∃ (conts : pair ℚ), (of v).continuants n = (conts.map coe : pair K) :=
by { rw [nth_cont_eq_succ_nth_cont_aux], exact (exists_gcf_pair_rat_eq_of_nth_conts_aux v $ n + 1) }

lemma exists_rat_eq_nth_numerator : ∃ (q : ℚ), (of v).numerators n = (q : K) :=
begin
  rcases (exists_gcf_pair_rat_eq_nth_conts v n) with ⟨⟨a, _⟩, nth_cont_eq⟩,
  use a,
  simp [num_eq_conts_a, nth_cont_eq],
end

lemma exists_rat_eq_nth_denominator : ∃ (q : ℚ), (of v).denominators n = (q : K) :=
begin
  rcases (exists_gcf_pair_rat_eq_nth_conts v n) with ⟨⟨_, b⟩, nth_cont_eq⟩,
  use b,
  simp [denom_eq_conts_b, nth_cont_eq]
end

/-- Every finite convergent corresponds to a rational number. -/
lemma exists_rat_eq_nth_convergent : ∃ (q : ℚ), (of v).convergents n = (q : K) :=
begin
  rcases (exists_rat_eq_nth_numerator v n) with ⟨Aₙ, nth_num_eq⟩,
  rcases (exists_rat_eq_nth_denominator v n) with ⟨Bₙ, nth_denom_eq⟩,
  use (Aₙ / Bₙ),
  simp [nth_num_eq, nth_denom_eq, convergent_eq_num_div_denom]
end

variable {v}

/-- Every terminating continued fraction corresponds to a rational number. -/
theorem exists_rat_eq_of_terminates
  (terminates : (of v).terminates) :
  ∃ (q : ℚ), v = ↑q :=
begin
  obtain ⟨n, v_eq_conv⟩ : ∃ n, v = (of v).convergents n, from
    of_correctness_of_terminates terminates,
  obtain ⟨q, conv_eq_q⟩ :
    ∃ (q : ℚ), (of v).convergents n = (↑q : K), from exists_rat_eq_nth_convergent v n,
  have : v = (↑q : K), from eq.trans v_eq_conv conv_eq_q,
  use [q, this]
end

end rat_of_terminates

section rat_translation
/-!
### Technical Translation Lemmas

Before we can show that the continued fraction of a rational number terminates, we have to prove
some technical translation lemmas. More precisely, in this section, we show that, given a rational
number `q : ℚ` and value `v : K` with `v = ↑q`, the continued fraction of `q` and `v` coincide.
In particular, we show that
```lean
    (↑(generalized_continued_fraction.of q : generalized_continued_fraction ℚ)
      : generalized_continued_fraction K)
  = generalized_continued_fraction.of v`
```
in `generalized_continued_fraction.coe_of_rat`.

To do this, we proceed bottom-up, showing the correspondence between the basic functions involved in
the computation first and then lift the results step-by-step.
-/

/- The lifting works for arbitrary linear ordered fields with a floor function. -/
variables {v : K} {q : ℚ} (v_eq_q : v = (↑q : K)) (n : ℕ)
include v_eq_q

/-! First, we show the correspondence for the very basic functions in
`generalized_continued_fraction.int_fract_pair`. -/
namespace int_fract_pair

lemma coe_of_rat_eq :
  ((int_fract_pair.of q).mapFr coe : int_fract_pair K) = int_fract_pair.of v :=
by simp [int_fract_pair.of, v_eq_q]

lemma coe_stream_nth_rat_eq :
    ((int_fract_pair.stream q n).map (mapFr coe) : option $ int_fract_pair K)
  = int_fract_pair.stream v n :=
begin
  induction n with n IH,
  case nat.zero : { simp [int_fract_pair.stream, (coe_of_rat_eq v_eq_q)] },
  case nat.succ :
  { rw v_eq_q at IH,
    cases stream_q_nth_eq : (int_fract_pair.stream q n) with ifp_n,
    case option.none : { simp [int_fract_pair.stream, IH.symm, v_eq_q, stream_q_nth_eq] },
    case option.some :
    { cases ifp_n with b fr,
      cases decidable.em (fr = 0) with fr_zero fr_ne_zero,
      { simp [int_fract_pair.stream, IH.symm, v_eq_q, stream_q_nth_eq, fr_zero] },
      { replace IH : some (int_fract_pair.mk b ↑fr) = int_fract_pair.stream ↑q n, by
          rwa [stream_q_nth_eq] at IH,
        have : (fr : K)⁻¹ = ((fr⁻¹ : ℚ) : K), by norm_cast,
        have coe_of_fr := (coe_of_rat_eq this),
        simp [int_fract_pair.stream, IH.symm, v_eq_q, stream_q_nth_eq, fr_ne_zero],
        unfold_coes,
        simpa [coe_of_fr] } } }
end

lemma coe_stream_rat_eq :
  ((int_fract_pair.stream q).map (option.map (mapFr coe)) : stream $ option $ int_fract_pair K) =
    int_fract_pair.stream v :=
by { funext n, exact (int_fract_pair.coe_stream_nth_rat_eq v_eq_q n) }

end int_fract_pair

/-! Now we lift the coercion results to the continued fraction computation. -/

lemma coe_of_h_rat_eq : (↑((of q).h : ℚ) : K) = (of v).h :=
begin
  unfold of int_fract_pair.seq1,
  rw ←(int_fract_pair.coe_of_rat_eq v_eq_q),
  simp
end

lemma coe_of_s_nth_rat_eq :
  (((of q).s.nth n).map (pair.map coe) : option $ pair K) = (of v).s.nth n :=
begin
  simp only [of, int_fract_pair.seq1, seq.map_nth, seq.nth_tail],
  simp only [seq.nth],
  rw [←(int_fract_pair.coe_stream_rat_eq v_eq_q)],
  rcases succ_nth_stream_eq : (int_fract_pair.stream q (n + 1)) with _ | ⟨_, _⟩;
  simp [stream.map, stream.nth, succ_nth_stream_eq]
end

lemma coe_of_s_rat_eq : (((of q).s).map (pair.map coe) : seq $ pair K) = (of v).s :=
by { ext n, rw ←(coe_of_s_nth_rat_eq v_eq_q), refl }

/-- Given `(v : K), (q : ℚ), and v = q`, we have that `gcf.of q = gcf.of v` -/
lemma coe_of_rat_eq :
  (⟨(of q).h, (of q).s.map (pair.map coe)⟩ : generalized_continued_fraction K) = of v :=
begin
  cases gcf_v_eq : (of v) with h s, subst v,
  obtain rfl : ↑⌊↑q⌋ = h, by { injection gcf_v_eq },
  simp [coe_of_h_rat_eq rfl, coe_of_s_rat_eq rfl, gcf_v_eq]
end

lemma of_terminates_iff_of_rat_terminates {v : K} {q : ℚ} (v_eq_q : v = (q : K)) :
  (of v).terminates ↔ (of q).terminates :=
begin
  split;
  intro h;
  cases h with n h;
  use n;
  simp only [seq.terminated_at, (coe_of_s_nth_rat_eq v_eq_q n).symm] at h ⊢;
  cases ((of q).s.nth n);
  trivial
end

end rat_translation

section terminates_of_rat
/-!
### Continued Fractions of Rationals Terminate

Finally, we show that the continued fraction of a rational number terminates.

The crucial insight is that, given any `q : ℚ` with `0 < q < 1`, the numerator of `int.fract q` is
smaller than the numerator of `q`. As the continued fraction computation recursively operates on
the fractional part of a value `v` and `0 ≤ int.fract v < 1`, we infer that the numerator of the
fractional part in the computation decreases by at least one in each step. As `0 ≤ int.fract v`,
this process must stop after finite number of steps, and the computation hence terminates.
-/

namespace int_fract_pair
variables {q : ℚ} {n : ℕ}

/--
Shows that for any `q : ℚ` with `0 < q < 1`, the numerator of the fractional part of
`int_fract_pair.of q⁻¹` is smaller than the numerator of `q`.
-/

/-- Shows that the sequence of numerators of the fractional parts of the stream is strictly
antitone. -/
lemma stream_succ_nth_fr_num_lt_nth_fr_num_rat {ifp_n ifp_succ_n : int_fract_pair ℚ}
  (stream_nth_eq : int_fract_pair.stream q n = some ifp_n)
  (stream_succ_nth_eq : int_fract_pair.stream q (n + 1) = some ifp_succ_n) :
  ifp_succ_n.fr.num < ifp_n.fr.num :=
begin
  obtain ⟨ifp_n', stream_nth_eq', ifp_n_fract_ne_zero, int_fract_pair.of_eq_ifp_succ_n⟩ :
    ∃ ifp_n', int_fract_pair.stream q n = some ifp_n' ∧ ifp_n'.fr ≠ 0
    ∧ int_fract_pair.of ifp_n'.fr⁻¹ = ifp_succ_n, from
      succ_nth_stream_eq_some_iff.elim_left stream_succ_nth_eq,
  have : ifp_n = ifp_n', by injection (eq.trans stream_nth_eq.symm stream_nth_eq'),
  cases this,
  rw [←int_fract_pair.of_eq_ifp_succ_n],
  cases (nth_stream_fr_nonneg_lt_one stream_nth_eq) with zero_le_ifp_n_fract ifp_n_fract_lt_one,
  have : 0 < ifp_n.fr, from (lt_of_le_of_ne zero_le_ifp_n_fract $ ifp_n_fract_ne_zero.symm),
  exact (of_inv_fr_num_lt_num_of_pos this)
end

lemma stream_nth_fr_num_le_fr_num_sub_n_rat : ∀ {ifp_n : int_fract_pair ℚ},
  int_fract_pair.stream q n = some ifp_n → ifp_n.fr.num ≤ (int_fract_pair.of q).fr.num - n :=
begin
  induction n with n IH,
  case nat.zero
  { assume ifp_zero stream_zero_eq,
    have : int_fract_pair.of q = ifp_zero, by injection stream_zero_eq,
    simp [le_refl, this.symm] },
  case nat.succ
  { assume ifp_succ_n stream_succ_nth_eq,
    suffices : ifp_succ_n.fr.num + 1 ≤ (int_fract_pair.of q).fr.num - n, by
    { rw [int.coe_nat_succ, sub_add_eq_sub_sub],
      solve_by_elim [le_sub_right_of_add_le] },
    rcases (succ_nth_stream_eq_some_iff.elim_left stream_succ_nth_eq) with
      ⟨ifp_n, stream_nth_eq, -⟩,
    have : ifp_succ_n.fr.num < ifp_n.fr.num, from
      stream_succ_nth_fr_num_lt_nth_fr_num_rat stream_nth_eq stream_succ_nth_eq,
    have : ifp_succ_n.fr.num + 1 ≤ ifp_n.fr.num, from int.add_one_le_of_lt this,
    exact (le_trans this (IH stream_nth_eq)) }
end

lemma exists_nth_stream_eq_none_of_rat (q : ℚ) : ∃ (n : ℕ), int_fract_pair.stream q n = none :=
begin
  let fract_q_num := (int.fract q).num, let n := fract_q_num.nat_abs + 1,
  cases stream_nth_eq : (int_fract_pair.stream q n) with ifp,
  { use n, exact stream_nth_eq },
  { -- arrive at a contradiction since the numerator decreased num + 1 times but every fractional
    -- value is nonnegative.
    have ifp_fr_num_le_q_fr_num_sub_n : ifp.fr.num ≤ fract_q_num - n, from
      stream_nth_fr_num_le_fr_num_sub_n_rat stream_nth_eq,
    have : fract_q_num - n = -1, by
    { have : 0 ≤ fract_q_num, from rat.num_nonneg_iff_zero_le.elim_right (int.fract_nonneg q),
      simp [(int.nat_abs_of_nonneg this), sub_add_eq_sub_sub_swap, sub_right_comm] },
    have : ifp.fr.num ≤ -1, by rwa this at ifp_fr_num_le_q_fr_num_sub_n,
    have : 0 ≤ ifp.fr, from (nth_stream_fr_nonneg_lt_one stream_nth_eq).left,
    have : 0 ≤ ifp.fr.num, from rat.num_nonneg_iff_zero_le.elim_right this,
    linarith }
end

end int_fract_pair

/-- The continued fraction of a rational number terminates. -/
theorem terminates_of_rat (q : ℚ) : (of q).terminates :=
exists.elim (int_fract_pair.exists_nth_stream_eq_none_of_rat q)
( assume n stream_nth_eq_none,
  exists.intro n
  ( have int_fract_pair.stream q (n + 1) = none, from
      int_fract_pair.stream_is_seq q stream_nth_eq_none,
    (of_terminated_at_n_iff_succ_nth_int_fract_pair_stream_eq_none.elim_right this) ) )

end terminates_of_rat

/--
The continued fraction `generalized_continued_fraction.of v` terminates if and only if `v ∈ ℚ`.
-/
theorem terminates_iff_rat (v : K) : (of v).terminates ↔ ∃ (q : ℚ), v = (q : K) :=
iff.intro
( assume terminates_v : (of v).terminates,
  show ∃ (q : ℚ), v = (q : K), from exists_rat_eq_of_terminates terminates_v )
( assume exists_q_eq_v : ∃ (q : ℚ), v = (↑q : K),
  exists.elim exists_q_eq_v
  ( assume q,
    assume v_eq_q : v = ↑q,
    have (of q).terminates, from terminates_of_rat q,
    (of_terminates_iff_of_rat_terminates v_eq_q).elim_right this ) )

end generalized_continued_fraction


/-
Copyright (c) 2022 Anand Rao, Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anand Rao, Rémi Bottinelli
-/
import category_theory.cofiltered_system
import combinatorics.simple_graph.connectivity
import data.set_like.basic

/-!
# Ends

This file contains a definition of the ends of a simple graph, as sections of the inverse system
assigning, to each finite set of vertices, the connected components of its complement.
-/

universes u
variables {V : Type u} (G : simple_graph V) (K L L' M : set V)

namespace simple_graph

/-- The components outside a given set of vertices `K` -/
@[reducible] def component_compl := (G.induce Kᶜ).connected_component

variables {G} {K L M}

/-- The connected component of `v` in `G.induce Kᶜ`. -/
@[reducible] def component_compl_mk (G : simple_graph V) {v : V} (vK : v ∉ K) :
  G.component_compl K :=
connected_component_mk (G.induce Kᶜ) ⟨v, vK⟩

/-- The set of vertices of `G` making up the connected component `C` -/
def component_compl.supp (C : G.component_compl K) : set V :=
{v : V | ∃ h : v ∉ K, G.component_compl_mk h = C}

@[ext] lemma component_compl.supp_injective :
  function.injective (component_compl.supp : G.component_compl K → set V) :=
begin
  refine connected_component.ind₂ _,
  rintros ⟨v, hv⟩ ⟨w, hw⟩ h,
  simp only [set.ext_iff, connected_component.eq, set.mem_set_of_eq, component_compl.supp] at h ⊢,
  exact ((h v).mp ⟨hv, reachable.refl _⟩).some_spec,
end

lemma component_compl.supp_inj {C D : G.component_compl K} : C.supp = D.supp ↔ C = D :=
component_compl.supp_injective.eq_iff

instance component_compl.set_like : set_like (G.component_compl K) V :=
{ coe := component_compl.supp,
  coe_injective' := λ C D, (component_compl.supp_inj).mp, }

@[simp] lemma component_compl.mem_supp_iff {v : V} {C : component_compl G K} :
  v ∈ C ↔ ∃ (vK : v ∉ K), G.component_compl_mk vK = C := iff.rfl

lemma component_compl_mk_mem (G : simple_graph V) {v : V} (vK : v ∉ K) :
  v ∈ G.component_compl_mk vK := ⟨vK, rfl⟩

lemma component_compl_mk_eq_of_adj (G : simple_graph V) {v w : V} (vK : v ∉ K) (wK : w ∉ K)
  (a : G.adj v w) : G.component_compl_mk vK = G.component_compl_mk wK :=
by { rw [connected_component.eq], apply adj.reachable, exact a }

namespace component_compl

/--
A `component_compl` specialization of `quot.lift`, where soundness has to be proved only
for adjacent vertices.
-/
protected def lift {β : Sort*} (f : ∀ ⦃v⦄ (hv : v ∉ K), β)
  (h : ∀ ⦃v w⦄ (hv : v ∉ K) (hw : w ∉ K) (a : G.adj v w), f hv = f hw) : G.component_compl K → β :=
connected_component.lift (λ vv, f vv.prop) $ (λ v w p, by
  { induction p with _ u v w a q ih,
    { rintro _, refl, },
    { rintro h', exact (h u.prop v.prop a).trans (ih h'.of_cons), } })

protected lemma ind {β : G.component_compl K → Prop}
  (f : ∀ ⦃v⦄ (hv : v ∉ K), β (G.component_compl_mk hv)) : ∀ (C : G.component_compl K), β C := by
{ apply connected_component.ind, exact λ ⟨v, vnK⟩, f vnK, }

/-- The induced graph on the vertices `C`. -/
@[reducible]
protected def coe_graph (C : component_compl G K) : simple_graph C := G.induce (C : set V)

lemma coe_inj {C D : G.component_compl K} : (C : set V) = (D : set V) ↔ C = D := set_like.coe_set_eq

@[simp] protected lemma nonempty (C : G.component_compl K) : (C : set V).nonempty :=
C.ind (λ v vnK, ⟨v, vnK, rfl⟩)

protected lemma exists_eq_mk (C : G.component_compl K) :
  ∃ v (h : v ∉ K), G.component_compl_mk h = C :=
C.nonempty

protected lemma disjoint_right (C : G.component_compl K) : disjoint K C :=
begin
  rw set.disjoint_iff,
  exact λ v ⟨vK, vC⟩, vC.some vK,
end

lemma not_mem_of_mem {C : G.component_compl K} {c : V} (cC : c ∈ C) : c ∉ K :=
λ cK, set.disjoint_iff.mp C.disjoint_right ⟨cK, cC⟩

protected lemma pairwise_disjoint :
  pairwise $ λ C D : G.component_compl K, disjoint (C : set V) (D : set V) :=
begin
  rintro C D ne,
  rw set.disjoint_iff,
  exact λ u ⟨uC, uD⟩, ne (uC.some_spec.symm.trans uD.some_spec),
end

/--
Any vertex adjacent to a vertex of `C` and not lying in `K` must lie in `C`.
-/
lemma mem_of_adj : ∀ {C : G.component_compl K} (c d : V), c ∈ C → d ∉ K → G.adj c d → d ∈ C :=
λ C c d ⟨cnK, h⟩ dnK cd,
  ⟨ dnK, by { rw [←h, connected_component.eq], exact adj.reachable cd.symm, } ⟩

/--
Assuming `G` is preconnected and `K` not empty, given any connected component `C` outside of `K`,
there exists a vertex `k ∈ K` adjacent to a vertex `v ∈ C`.
-/
lemma exists_adj_boundary_pair (Gc : G.preconnected) (hK : K.nonempty) :
  ∀ (C : G.component_compl K), ∃ (ck : V × V), ck.1 ∈ C ∧ ck.2 ∈ K ∧ G.adj ck.1 ck.2 :=
begin
  refine component_compl.ind (λ v vnK, _),
  let C : G.component_compl K := G.component_compl_mk vnK,
  let dis := set.disjoint_iff.mp C.disjoint_right,
  by_contra' h,
  suffices : set.univ = (C : set V),
  { exact dis ⟨hK.some_spec, this ▸ (set.mem_univ hK.some)⟩, },
  symmetry,
  rw set.eq_univ_iff_forall,
  rintro u,
  by_contradiction unC,
  obtain ⟨p⟩ := Gc v u,
  obtain ⟨⟨⟨x, y⟩, xy⟩, d, xC, ynC⟩ :=
    p.exists_boundary_dart (C : set V) (G.component_compl_mk_mem vnK) unC,
  exact ynC (mem_of_adj x y xC (λ (yK : y ∈ K), h ⟨x, y⟩ xC yK xy) xy),
end

/--
If `K ⊆ L`, the components outside of `L` are all contained in a single component outside of `K`.
-/
@[reducible] def hom (h : K ⊆ L) (C : G.component_compl L) : G.component_compl K :=
C.map $ induce_hom hom.id $ set.compl_subset_compl.2 h

lemma subset_hom (C : G.component_compl L) (h : K ⊆ L) : (C : set V) ⊆ (C.hom h : set V) := by
{ rintro c ⟨cL, rfl⟩, exact ⟨λ h', cL (h h'), rfl⟩ }

lemma _root_.simple_graph.component_compl_mk_mem_hom (G : simple_graph V) {v : V} (vK : v ∉ K)
  (h : L ⊆ K) : v ∈ (G.component_compl_mk vK).hom h :=
subset_hom (G.component_compl_mk vK) h (G.component_compl_mk_mem vK)

lemma hom_eq_iff_le (C : G.component_compl L) (h : K ⊆ L) (D : G.component_compl K) :
  C.hom h = D ↔ (C : set V) ⊆ (D : set V) :=
⟨ λ h', h' ▸ (C.subset_hom h), C.ind (λ v vnL vD, (vD ⟨vnL, rfl⟩).some_spec) ⟩

lemma hom_eq_iff_not_disjoint (C : G.component_compl L) (h : K ⊆ L) (D : G.component_compl K) :
  C.hom h = D ↔ ¬ disjoint (C : set V) (D : set V) :=
begin
  rw set.not_disjoint_iff,
  split,
  { rintro rfl,
    apply C.ind (λ x xnL, _),
    exact ⟨x, ⟨xnL, rfl⟩, ⟨(λ xK, xnL (h xK)), rfl⟩⟩, },
  { apply C.ind (λ x xnL, _),
    rintro ⟨x, ⟨_, e₁⟩, _, rfl⟩,
    rw ←e₁, refl, },
end

lemma hom_refl (C : G.component_compl L) : C.hom (subset_refl L) = C :=
by { change C.map _ = C, erw [induce_hom_id G Lᶜ, connected_component.map_id], }

lemma hom_trans (C : G.component_compl L) (h : K ⊆ L) (h' : M ⊆ K) :
  C.hom (h'.trans h) = (C.hom h).hom h' :=
by { change C.map _ = (C.map _).map _, erw [connected_component.map_comp, induce_hom_comp], refl, }

lemma hom_mk {v : V} (vnL : v ∉ L) (h : K ⊆ L) :
  (G.component_compl_mk vnL).hom h = (G.component_compl_mk (set.not_mem_subset h vnL)) := rfl

lemma hom_infinite (C : G.component_compl L) (h : K ⊆ L) (Cinf : (C : set V).infinite) :
  (C.hom h : set V).infinite := set.infinite.mono (C.subset_hom h) Cinf

lemma infinite_iff_in_all_ranges {K : finset V} (C : G.component_compl K) :
  C.supp.infinite ↔ ∀ L (h : K ⊆ L), ∃ D : G.component_compl L, D.hom h = C :=
begin
  classical,
  split,
  { rintro Cinf L h,
    obtain ⟨v, ⟨vK, rfl⟩, vL⟩ := set.infinite.nonempty (set.infinite.diff Cinf L.finite_to_set),
    exact ⟨component_compl_mk _ vL, rfl⟩ },
  { rintro h Cfin,
    obtain ⟨D, e⟩ := h (K ∪ Cfin.to_finset) (finset.subset_union_left K Cfin.to_finset),
    obtain ⟨v, vD⟩ := D.nonempty,
    let Ddis := D.disjoint_right,
    simp_rw [finset.coe_union, set.finite.coe_to_finset, set.disjoint_union_left,
             set.disjoint_iff] at Ddis,
    exact Ddis.right ⟨(component_compl.hom_eq_iff_le _ _ _).mp e vD, vD⟩, },
end

end component_compl

section ends

variables (G)

open category_theory

/--
The functor assigning, to a finite set in `V`, the set of connected components in its complement.
-/
@[simps] def component_compl_functor : (finset V)ᵒᵖ ⥤ Type u :=
{ obj := λ K, G.component_compl K.unop,
  map := λ _ _ f, component_compl.hom (le_of_op_hom f),
  map_id' := λ K, funext $ λ C, C.hom_refl,
  map_comp' := λ K L M h h', funext $ λ C, C.hom_trans (le_of_op_hom h) (le_of_op_hom h') }

/-- The end of a graph, defined as the sections of the functor `component_compl_functor` . -/
@[protected]
def «end» := (component_compl_functor G).sections

lemma end_hom_mk_of_mk {s} (sec : s ∈ G.end) {K L : (finset V)ᵒᵖ} (h : L ⟶ K)
  {v : V} (vnL : v ∉ L.unop) (hs : s L = G.component_compl_mk vnL) :
  s K = G.component_compl_mk (set.not_mem_subset (le_of_op_hom h) vnL) :=
begin
  rw [←(sec h), hs],
  apply component_compl.hom_mk,
end

lemma infinite_iff_in_eventual_range {K : (finset V)ᵒᵖ} (C : G.component_compl_functor.obj K) :
  C.supp.infinite ↔ C ∈ G.component_compl_functor.eventual_range K :=
begin
  simp only [C.infinite_iff_in_all_ranges, category_theory.functor.eventual_range,
             set.mem_Inter, set.mem_range, component_compl_functor_map],
  exact ⟨λ h Lop KL, h Lop.unop (le_of_op_hom KL), λ h L KL, h (opposite.op L) (op_hom_of_le KL)⟩,
end

end ends

end simple_graph


import data.finset.basic
import order.cover
import order.category.FinPartialOrder
import tactic.linarith

noncomputable theory
local attribute [instance] classical.prop_decidable

/--
  This file provide some useful lemmas about the finiteness property of P
  In particular
  `no_infinite_increasing_seq` and `no_infinite_decreasing_seq` prove that there are
  no infinite increasing/decreasing sequences in P
  and `no_forall_exists_lt` and `no_forall_exists_gt` prove that there are no statement of
  the form ∀ x ∈ U, ∃ y ∈ U, x < (or >) y, with `U : finset P`
-/

variables (P : FinPartialOrder) -- [decidable_eq P] [@decidable_rel P (<)]

-- Some useful lemma about finiteness
namespace finite

variable {P}

abbreviation points : finset P := fintype.elems P

def greater_or_eq (x : P) : finset P := finset.filter (λ y : P, x ≤ y) points
def greater (x : P) : finset P := finset.filter (λ y : P, x < y) points

lemma greater_iff_in_greater (x y : P) : y ∈ greater x ↔ x < y :=
begin
  erw finset.mem_filter, simp [fintype.complete]
end

-- We prove that there could not be any strictly increasing sequence
lemma monotonic_of_increasing {s : ℕ → P} (hinc : ∀ n, s n < s (n + 1)) :
  ∀ i j, i < j → s i < s j :=
begin
  intros i j, revert i,
  induction j with j hj,
  simp,
  intros i hi,
  by_cases i = j,
  rw h, apply hinc,
  have i_lt_j : i < j := array.push_back_idx hi h,
  specialize hj i i_lt_j,
  apply lt_trans hj,
  apply hinc
end

lemma injective_of_increasing {s : ℕ → P} (hinc : ∀ n, s n < s (n + 1)) : function.injective s :=
begin
  intros x y h,
  wlog h : x ≤ y,
  rw le_iff_lt_or_eq at h,
  cases h,
  { exfalso,
    have lt := monotonic_of_increasing hinc x y h,
    simp at lt,
    exact ne_of_lt lt h_1 },
  { exact h }
end

lemma no_infinite_increasing_seq (s : ℕ → P) : ¬ (∀ n, s n < s (n + 1)) :=
begin
  intro hinc,
  have i : function.injective s := injective_of_increasing hinc,
  have inf_P : infinite P := infinite.of_injective s i,
  rw ←not_finite_iff_infinite at inf_P,
  exact inf_P (finite.of_fintype P)
end

lemma injective_of_neq_preds {s : ℕ → P} (hinc : ∀ n m, n < m → s n ≠ s m) : function.injective s :=
begin
  intros n m,
  wlog h : n ≤ m,
  rw le_iff_lt_or_eq at h,
  cases h,
  { intro hs, exfalso, exact hinc _ _ h hs },
  { rw h, intro, refl }
end

-- No sequence in P where s_m is different from s_n, n < m
lemma no_forall_neq_preds (s : ℕ → P) : ¬ (∀ n m, n < m → s n ≠ s m) :=
begin
  intros hneq,
  have i : function.injective s := injective_of_neq_preds hneq,
  have inf_P : infinite P := infinite.of_injective s i,
  rw ←not_finite_iff_infinite at inf_P,
  exact inf_P (finite.of_fintype P)
end

variables {U : finset P} {x0 : P} (hx0 : x0 ∈ U)

def seq_A_E' (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x < y }) : ℕ → { x : P // x ∈ U }
| 0       := ⟨x0, hx0⟩
| (n + 1) := ⟨(h (seq_A_E' n).val (seq_A_E' n).prop).val,
              (h (seq_A_E' n).val (seq_A_E' n).prop).prop.left⟩

def seq_A_E (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x < y }) : ℕ → P := λ n, (seq_A_E' hx0 h n).val
def seq_A_E_in (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x < y }) (n : ℕ)  :
  (seq_A_E hx0 h n) ∈ U := (seq_A_E' hx0 h n).prop

lemma seq_A_E_increasing (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x < y }) :
  ∀ n, seq_A_E hx0 h n < seq_A_E hx0 h n.succ :=
begin
  intro n,
  have g := (h (seq_A_E hx0 h n) (seq_A_E_in hx0 h n)).prop.right,
  convert g
end

lemma no_infinite_decreasing_seq (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x < y }) (s : ℕ → P) :
  ¬ (∀ n, s (n + 1) < s n) :=
begin
  intro h,
  apply @no_infinite_increasing_seq (FinPartialOrder.dual.obj P) s h,
end

-- Therefore, there cannot be true statement of the form (∀ x : U, { y : U // x < y })
-- which is a quite useful argument(?)
lemma no_forall_exists_lt (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x < y }) : false :=
no_infinite_increasing_seq (seq_A_E hx0 h) (seq_A_E_increasing _ _)

lemma no_forall_exists_gt (hx0 : x0 ∈ U) (h : ∀ x ∈ U, { y : P // y ∈ U ∧ y < x }) : false :=
@no_infinite_increasing_seq (FinPartialOrder.dual.obj P) _ (seq_A_E_increasing hx0 h)

-- with the axiom of choice
lemma no_forall_exists_lt' (h : ∀ x ∈ U, ∃ y ∈ U, x < y) : false :=
no_forall_exists_lt hx0
begin
  intros x hx,
  have k := classical.indefinite_description _ (h x hx),
  simp at k,
  exact k
end

lemma no_forall_exists_gt' (h : ∀ x ∈ U, ∃ y ∈ U, y < x) : false :=
no_forall_exists_gt hx0
begin
  intros x hx,
  have k := classical.indefinite_description _ (h x hx),
  simp at k,
  exact k
end

-- A variation with ≠ in place of < (should have done that first...)
def seq_A_E_neq' (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x ≠ y }) : ℕ → { x : P // x ∈ U }
| 0       := ⟨x0, hx0⟩
| (n + 1) := ⟨(h (seq_A_E_neq' n).val (seq_A_E_neq' n).prop).val,
              (h (seq_A_E_neq' n).val (seq_A_E_neq' n).prop).prop.left⟩

def seq_A_E_neq (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x ≠ y }) : ℕ → P := λ n, (seq_A_E_neq' hx0 h n).val
def seq_A_E_neq_in (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x ≠ y }) (n : ℕ)  :
  (seq_A_E_neq hx0 h n) ∈ U := (seq_A_E_neq' hx0 h n).prop

lemma seq_A_E_neq_succ (h : ∀ x ∈ U, { y : P // y ∈ U ∧ x ≠ y }) :
  ∀ n, seq_A_E_neq hx0 h n ≠ seq_A_E_neq hx0 h n.succ :=
begin
  intro n,
  have g := (h (seq_A_E_neq hx0 h n) (seq_A_E_neq_in hx0 h n)).prop.right,
  convert g
end

lemma lt_iff_le_and_neq (x y : P) : x < y ↔ x ≤ y ∧ ¬x = y :=
begin
  rw lt_iff_le_not_le,
  split; intro h; apply and.intro h.left; intro hneg,
  { have h' : y ≤ x := by rw hneg,
    exact h.right h' },
  { exact h.right (le_antisymm h.left hneg) }
end

def Ioc (x x' : P) := finset.filter (λ y, x < y ∧ y ≤ x') points
lemma right_mem_Ioc (x x' : P) : x' ∈ Ioc x x' ↔ x < x' :=
begin
  unfold Ioc,
  simp [fintype.complete]
end

lemma Ioc_lt_left {x x' y : P} (hin : y ∈ Ioc x x') : x < y :=
begin
  erw finset.mem_filter at hin,
  simp [fintype.complete] at hin,
  exact hin.left
end

lemma Ioc_le_right {x x' y : P} (hin : y ∈ Ioc x x') : y ≤ x' :=
begin
  erw finset.mem_filter at hin,
  simp [fintype.complete] at hin,
  exact hin.right
end

lemma Ioc_in_lt_lt {x x' y w : P} (hin : y ∈ Ioc x x') (hw : x < w ∧ w < y) : w ∈ Ioc x x':=
begin
  erw finset.mem_filter at *,
  simp [fintype.complete] at *,
  apply and.intro hw.left,
  exact le_of_lt (lt_of_lt_of_le hw.right hin.right)
end

-- If x < x', then the sets of greater elements has a min ≤ x'
lemma exists_min_greater {x x' : P} (hx' : x' ∈ greater x) :
  ∃ y ∈ Ioc x x', ∀ z ∈ Ioc x x', z ≤ y → z = y :=
begin
  by_contra' h,
  have h' : ∀ (y ∈ Ioc x x'), ∃ (z ∈ Ioc x x'), z < y :=
  begin
    intros y hyin,
    cases h y hyin with w h',
    use w,
    rw lt_iff_le_and_neq w y,
    exact h'
  end,
  have hIoc : x' ∈ Ioc x x' :=
  begin
    rw right_mem_Ioc,
    rw greater_iff_in_greater at hx',
    exact hx'
  end,
  apply no_forall_exists_gt' hIoc h'
end

lemma exists_cov_of_greater {x x' : P} (hx' : x' ∈ greater x) : ∃ y, x ⋖ y ∧ y ≤ x' :=
begin
  cases exists_min_greater hx',
  cases h with w_in h,
  use w,
  rw greater_iff_in_greater at *,
  split, split,
  { exact Ioc_lt_left w_in },
  { intros v hv hw,
    specialize h v,
    specialize h (Ioc_in_lt_lt w_in (and.intro hv hw)) (le_of_lt hw),
    rw h at hw,
    apply lt_irrefl w,
    exact hw },
  { exact Ioc_le_right w_in }
end

def smaller (x : P) : finset P := finset.filter (λ y : P, x > y) points

lemma smaller_iff_in_smaller (x y : P) : y ∈ smaller x ↔ y < x :=
begin
  erw finset.mem_filter, simp [fintype.complete]
end

lemma exists_cov_of_smaller {x x' : P} (hx' : x ∈ smaller x') : ∃ y, x ≤ y ∧ y ⋖ x' :=
begin
  cases @exists_cov_of_greater (FinPartialOrder.dual.obj P) x' x hx' with y hy,
  use y,
  rw ←to_dual_covby_to_dual_iff,
  apply and.intro hy.right hy.left,
end

-- useful as we will deal with dim x - 1
lemma eq_pred_eq_succ (n m : ℤ) : m = n - 1 ↔ m + 1 = n :=
begin
  split; intro h; linarith,
end

end finite


import algebra
import data.real.basic
import logic.basic
import order
import tactic.explode
import tactic.find
import tactic.linarith
import tactic.rcases
import tactic.rewrite
import tactic.ring_exp
import tactic.tidy
import tactic.where

/-! # LoVe Library

This files contains a few extensions on top of Lean's core libraries and
`mathlib`. -/

namespace LoVe

/-! ## Structured Proofs -/

notation `fix ` binders `, ` r:(scoped f, f) := r

/-! ## Logical Connectives -/

attribute [pattern] or.intro_left or.intro_right

meta def tactic.dec_trivial := `[exact dec_trivial]

lemma not_def (a : Prop) :
  ¬ a ↔ a → false :=
by refl

@[simp] lemma not_not_iff (a : Prop) [decidable a] :
  ¬¬ a ↔ a :=
by by_cases a; simp [h]

@[simp] lemma and_imp_distrib (a b c : Prop) :
  (a ∧ b → c) ↔ (a → b → c) :=
iff.intro
  (assume h ha hb, h ⟨ha, hb⟩)
  (assume h ⟨ha, hb⟩, h ha hb)

@[simp] lemma or_imp_distrib {a b c : Prop} :
  a ∨ b → c ↔ (a → c) ∧ (b → c) :=
iff.intro
  (assume h,
   ⟨assume ha, h (or.intro_left _ ha), assume hb, h (or.intro_right _ hb)⟩)
  (assume ⟨ha, hb⟩ h, match h with or.inl h := ha h | or.inr h := hb h end)

@[simp] lemma exists_imp_distrib {α : Sort*} {p : α → Prop} {a : Prop} :
  ((∃x, p x) → a) ↔ (∀x, p x → a) :=
iff.intro
  (assume h hp ha, h ⟨hp, ha⟩)
  (assume h ⟨hp, ha⟩, h hp ha)

lemma and_exists {α : Sort*} {p : α → Prop} {a : Prop} :
  (a ∧ (∃x, p x)) ↔ (∃x, a ∧ p x) :=
iff.intro
  (assume ⟨ha, x, hp⟩, ⟨x, ha, hp⟩)
  (assume ⟨x, ha, hp⟩, ⟨ha, x, hp⟩)

@[simp] lemma exists_false {α : Sort*} :
  (∃x : α, false) ↔ false :=
iff.intro (assume ⟨a, f⟩, f) (assume h, h.elim)

/-! ## Natural Numbers -/

attribute [simp] nat.add

/-! ## Integers -/

@[simp] lemma int.neg_comp_neg :
  int.neg ∘ int.neg = id :=
begin
  apply funext,
  apply neg_neg
end

/-! ## Reflexive Transitive Closure -/

namespace rtc

inductive star {α : Sort*} (r : α → α → Prop) (a : α) : α → Prop
| refl {}    : star a
| tail {b c} : star b → r b c → star c

attribute [refl] star.refl

namespace star

variables {α : Sort*} {r : α → α → Prop} {a b c d : α}

@[trans] lemma trans (hab : star r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction hbc,
  case star.refl {
    assumption },
  case star.tail : c d hbc hcd hac {
    exact hac.tail hcd }
end

lemma single (hab : r a b) :
  star r a b :=
refl.tail hab

lemma head (hab : r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction hbc,
  case star.refl {
    exact refl.tail hab },
  case star.tail : c d hbc hcd hac {
    exact hac.tail hcd }
end

lemma head_induction_on {α : Sort*} {r : α → α → Prop} {b : α}
  {P : ∀a : α, star r a b → Prop} {a : α} (h : star r a b)
  (refl : P b refl)
  (head : ∀{a c} (h' : r a c) (h : star r c b), P c h → P a (h.head h')) :
  P a h :=
begin
  induction h generalizing P,
  case star.refl {
    exact refl },
  case star.tail : b c hab hbc ih {
    apply ih,
    show P b _, from
      head hbc _ refl,
    show ∀a a', r a a' → star r a' b → P a' _ → P a _, from
      assume a a' hab hbc, head hab _ }
end

lemma trans_induction_on {α : Sort*} {r : α → α → Prop}
    {p : ∀{a b : α}, star r a b → Prop} {a b : α} (h : star r a b)
    (ih₁ : ∀a, @p a a refl) (ih₂ : ∀{a b} (h : r a b), p (single h))
    (ih₃ : ∀{a b c} (h₁ : star r a b) (h₂ : star r b c), p h₁ →
       p h₂ → p (h₁.trans h₂)) :
  p h :=
begin
  induction h,
  case star.refl {
    exact ih₁ a },
  case star.tail : b c hab hbc ih {
    exact ih₃ hab (single hbc) ih (ih₂ hbc) }
end

lemma lift {β : Sort*} {s : β → β → Prop} (f : α → β)
  (h : ∀a b, r a b → s (f a) (f b)) (hab : star r a b) :
  star s (f a) (f b) :=
hab.trans_induction_on
  (assume a, refl)
  (assume a b, single ∘ h _ _)
  (assume a b c _ _, trans)

lemma mono {p : α → α → Prop} :
  (∀a b, r a b → p a b) → star r a b → star p a b :=
lift id

lemma star_star_eq :
  star (star r) = star r :=
funext
  (assume a,
   funext
     (assume b,
      propext (iff.intro
        (assume h,
         begin
           induction h,
           { refl },
           { transitivity;
               assumption }
         end)
        (star.mono (assume a b,
           single)))))

end star

end rtc

export rtc

/-! ## States -/

def state :=
string → ℕ

def state.update (name : string) (val : ℕ) (s : state) : state :=
λname', if name' = name then val else s name'

notation s `{` name ` ↦ ` val `}` := state.update name val s

instance : has_emptyc state :=
{ emptyc := λ_, 0 }

@[simp] lemma update_apply (name : string) (val : ℕ) (s : state) :
  s{name ↦ val} name = val :=
if_pos rfl

@[simp] lemma update_apply_ne (name name' : string) (val : ℕ) (s : state)
    (h : name' ≠ name . tactic.dec_trivial) :
  s{name ↦ val} name' = s name' :=
if_neg h

@[simp] lemma update_override (name : string) (val₁ val₂ : ℕ) (s : state) :
  s{name ↦ val₂}{name ↦ val₁} = s{name ↦ val₁} :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp [h]
end

@[simp] lemma update_swap (name₁ name₂ : string) (val₁ val₂ : ℕ) (s : state)
    (h : name₁ ≠ name₂ . tactic.dec_trivial) :
  s{name₂ ↦ val₂}{name₁ ↦ val₁} = s{name₁ ↦ val₁}{name₂ ↦ val₂} :=
begin
  apply funext,
  intro name',
  by_cases name' = name₁;
    by_cases name' = name₂;
    simp * at *
end

@[simp] lemma update_id (name : string) (s : state) :
  s{name ↦ s name} = s :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp * at *
end

example (s : state) :
  s{"a" ↦ 0}{"a" ↦ 2} = s{"a" ↦ 2} :=
by simp

example (s : state) :
  s{"a" ↦ 0}{"b" ↦ 2} = s{"b" ↦ 2}{"a" ↦ 0} :=
by simp

example (s : state) :
  s{"a" ↦ s "a"}{"b" ↦ 0} = s{"b" ↦ 0} :=
by simp

/-! ## Relations -/

def Id {α : Type} : set (α × α) :=
{ab | prod.snd ab = prod.fst ab}

@[simp] lemma mem_Id {α : Type} (a b : α) :
  (a, b) ∈ @Id α ↔ b = a :=
by refl

def comp {α : Type} (r₁ r₂ : set (α × α)) : set (α × α) :=
{ac | ∃b, (prod.fst ac, b) ∈ r₁ ∧ (b, prod.snd ac) ∈ r₂}

infixl ` ◯ ` : 90 := comp

@[simp] lemma mem_comp {α : Type} (r₁ r₂ : set (α × α))
    (a b : α) :
  (a, b) ∈ r₁ ◯ r₂ ↔ (∃c, (a, c) ∈ r₁ ∧ (c, b) ∈ r₂) :=
by refl

def restrict {α : Type} (r : set (α × α)) (p : α → Prop) :
  set (α × α) :=
{ab | p (prod.fst ab) ∧ ab ∈ r}

infixl ` ⇃ ` : 90 := restrict

@[simp] lemma mem_restrict {α : Type} (r : set (α × α))
    (p : α → Prop) (a b : α) :
  (a, b) ∈ r ⇃ p ↔ p a ∧ (a, b) ∈ r :=
by refl

end LoVe


import data.int.basic
import data.int.gcd
import data.pnat.basic
import data.rat.defs

import algebra.big_operators.basic
import ring_theory.coprime.basic
import ring_theory.int.basic

import tactic.field_simp
import tactic.linarith
import tactic.ring

/-
IMO 2018 Q5

Let a₁, a₂, ..., aₙ, ... be a sequence of positive integers such that

      a₁/a₂ + a₂/a₃ + ... + aₙ₋₁/aₙ + aₙ/a₁

is an integer for all n ≥ k, where k is some positive integer.

Prove that there exists a positive integer m such that aₙ = aₙ₊₁
for all n ≥ m.

-/

open_locale big_operators

lemma gcd_dvd (a b c : ℤ)
  (hgcd : a.gcd c = 1)
  (h_cab : c ∣ a * b) :
  c ∣ b :=
begin
  have : is_coprime c a,
  {
    have h1 := int.gcd_eq_gcd_ab a c,
    rw hgcd at h1,
    simp at h1,
    rw add_comm at h1,
    use a.gcd_b c,
    use a.gcd_a c,
    linarith,
  },
  exact is_coprime.dvd_of_dvd_mul_left this h_cab,
end

/-
 Let a,b,c be positive integers such that N = b/c + (c-b)/a is an integer. Then:
  (1) if gcd(a,c) = 1, then c divides b
-/
lemma lemma_1
  (a b c : ℤ)
  (ha : 0 < a) (hb : 0 < b) (hc : 0 < c)
  (N : ℤ)
  (hN : (b:ℚ)/(c:ℚ) + ((c:ℚ) - (b:ℚ)) / (a:ℚ) = N)
  (hgcd : int.gcd a c = 1) :
  c∣b :=
begin
  /-
   Write a*b = c*(a*N + b - c). Since gcd(a,c) = 1, it follows that c divides b.
  -/
  have : (a:ℚ) * b = c * (a * N + b - c),
  {
    have ha0 : (a:ℚ) ≠ 0 := ne_of_gt (int.cast_pos.mpr ha),
    have hc0 : (c:ℚ) ≠ 0 := ne_of_gt (int.cast_pos.mpr hc),

    have h2: (a:ℚ) * (c:ℚ) * ((b:ℚ)/(c:ℚ) + ((c:ℚ) - (b:ℚ)) / (a:ℚ))
      = (a:ℚ) * (c:ℚ) * N := congr_arg (has_mul.mul (↑a * ↑c)) hN,

    have : (a:ℚ) * (c:ℚ) * ((b:ℚ)/(c:ℚ) + ((c:ℚ) - (b:ℚ)) / (a:ℚ))
     = (a:ℚ) * (b:ℚ) + (c:ℚ) * ((c:ℚ) - (b:ℚ)) := by {field_simp, ring},

    linarith,
  },

  have hz: a * b = c * (a * N + b - c),
  {
    assumption_mod_cast,
  },

  clear this,
  have h_cab : c ∣ a * b := dvd.intro (a * N + b - c) (eq.symm hz),

  clear hz hN N,

  exact gcd_dvd a b c hgcd h_cab,
end

lemma nat_of_nonneg_int (x : ℤ) (hx : 0 ≤ x) : ∃ x' : ℕ, (x': ℤ) = x :=
begin
  cases x,
  { use x, exact int.coe_nat_eq x,},
  { exfalso, exact (int.neg_succ_not_nonneg x).mp hx, }
end

/-
 Let a,b,c be positive integers such that N = b/c + (c-b)/a is an integer. Then:
  (2) if gcd(a,b,c) = 1, then gcd(a,b) = 1
-/
lemma lemma_2
  (a b c : ℤ)
  (ha : 0 < a) (hb : 0 < b) (hc : 0 < c)
  (N : ℤ)
  (hN : (b:ℚ)/(c:ℚ) + ((c:ℚ) - (b:ℚ)) / (a:ℚ) = N)
  (hgcd : int.gcd a (int.gcd b c) = 1) :
  int.gcd a b = 1 :=
begin
  have : (c:ℚ) * c - b * c = a * (c * N - b),
  {
    have ha0 : (a:ℚ) ≠ 0 := ne_of_gt (int.cast_pos.mpr ha),
    have hc0 : (c:ℚ) ≠ 0 := ne_of_gt (int.cast_pos.mpr hc),

    have h2: (a:ℚ) * (c:ℚ) * ((b:ℚ)/(c:ℚ) + ((c:ℚ) - (b:ℚ)) / (a:ℚ))
      = (a:ℚ) * (c:ℚ) * N := congr_arg (has_mul.mul (↑a * ↑c)) hN,

    have : (a:ℚ) * (c:ℚ) * ((b:ℚ)/(c:ℚ) + ((c:ℚ) - (b:ℚ)) / (a:ℚ))
     = (a:ℚ) * (b:ℚ) + (c:ℚ) * ((c:ℚ) - (b:ℚ)) := by {field_simp, ring},

    linarith,
   },

  have hz: c * c - b * c = a * (c * N - b) := by assumption_mod_cast,
  clear this,
  have h1 : a ∣ (c * c - b * c) := dvd.intro (c * N - b) (eq.symm hz),
  have h1' : ((a.gcd b):ℤ) ∣ a := int.gcd_dvd_left a b,
  have h2 : ((a.gcd b):ℤ) ∣ (c * c - b * c) := dvd_trans h1' h1,
  have h3 : ((a.gcd b):ℤ) ∣ b := int.gcd_dvd_right a b,
  have h4 : ((a.gcd b):ℤ) ∣ b * c := dvd_mul_of_dvd_left h3 c,
  have h5 : ((a.gcd b):ℤ) ∣ c * c := (dvd_iff_dvd_of_dvd_sub h2).mpr h4,

  rw[←int.gcd_assoc] at hgcd,
  have h6 := dvd_mul_gcd_of_dvd_mul h5,
  rw[←int.coe_gcd] at h6,
  rw[hgcd, nat.cast_one, mul_one] at h6,
  obtain ⟨c', hc'⟩ := nat_of_nonneg_int c (le_of_lt hc),
  rw [←hc'] at h6,
  rw [←hc', ←nat.cast_one] at hgcd,
  norm_cast at h6,
  exact nat.coprime.eq_one_of_dvd hgcd h6
end

theorem imo2018_q5
  (a : ℕ → ℕ+)
  (ha : ∃k : ℕ,
        ∀n : ℕ,
        k ≤ n →
         (∑ (i : ℕ) in finset.range n, ((a i):ℚ) / ((a ((i+1) % n)):ℚ)).denom = 1) :
  (∃m : ℕ, ∀ n : ℕ, m ≤ n → a n = a (n+1)) :=
begin
  sorry
end


import tactic data.nat.parity tactic.induction

import init.meta.well_founded_tactics

namespace exlean

namespace wf_exlean

/-
# Well-founded recursion
-/

section logarithms

/-!
## Logarithms and basic ideas

We define a function `lg` that is (roughly) the base-2 logarithm. More precisely,

  `(n + 1) < 2 ^ lg (n + 1) ≤ 2 * (n + 1)`

for every `n : ℕ`. We prove the first of these inequalities and introduce techniques for
working with well-founded recursion.
-/

/-!
### Definitions and simple proofs

Here are definitions of `lg` (and extensionally-equal variants) via `well_founded.fix` and
via the equation compiler. We prove such simple results as `lg 1 = 1`.
-/

/--
`myF x h` gives the value of `lg x` where `h y` is `lg y` for `y < x`.
-/
def myF : Π (x : ℕ) (h : Π (y : ℕ), y < x → ℕ), ℕ
| 0 _ := 0
| (x + 1) h := 1 + h ((x + 1) / 2) (nat.div_lt_self' x 0)

/-!
We prove that `myF` leads to well-founded recursive definition, which we call `lg_by_hand`.
-/

/--
`lg_by_hand x = floor (log₂ x) + 1`
-/
def lg_by_hand := well_founded.fix nat.lt_wf myF

/-!
`lg` is (extensionally) equal to `lg_by_hand`. Rather than using `well_founded.fix` and an
auxiliary function (such as `myF` above), we use the equation compiler to define the function
in one step.
-/

/--
`lg x = floor (log₂ x) + 1`
-/
def lg : ℕ → ℕ
| 0 := 0
| (x + 1) := have (x + 1) / 2 < (x + 1), from nat.div_lt_self' _ _,
    1 + lg ((x + 1)/2)

def jane : ℕ → ℕ
| 0 := 2
| (x + 1) := 3 * jane x

example : jane 3 = 54 := rfl

lemma lg_zero : lg 0 = 0 := by { rw lg }

lemma lg_zero' : lg 0 = 0 := well_founded.fix_eq _ _ _

example : lg_by_hand 0 = well_founded.fix nat.lt_wf myF 0 := rfl

lemma lg_one : lg 1 = 1 := by { erw [lg, lg_zero] }

lemma lg_by_hand_eq : ∀ x, lg_by_hand x = myF x (λ y h, lg_by_hand y) := well_founded.fix_eq _ _

lemma lg_zero_bh : lg_by_hand 0 = 0 := lg_by_hand_eq 0

lemma lg_one_bh : lg_by_hand 1 = 1 := by { erw [lg_by_hand_eq, myF, lg_zero_bh] }

section exercises

/-!
### Some basic exercises

The exercises (solutions here, questions in the blog) are to define a function described
mathematically and then prove simple equations involving the function.
-/

def ex1 : ℕ → ℕ
| 0 := 1
| (x + 1) := have (x + 1) / 3 < x + 1, from nat.div_lt_self' _ _,
    (x + 1) * ex1 ( (x + 1) / 3)

example : ex1 0 = 1 := by { rw ex1 }

example : ex1 2 = 2 := by { erw [ex1, ex1], norm_num }

example : ex1 4 = 4 := by { erw [ex1, ex1, ex1], norm_num }

def ex1_F : Π (x : ℕ) (h : Π (y : ℕ), y < x → ℕ), ℕ
| 0 _ := 1
| (x + 1) h := (x + 1) * (h ((x + 1)/3) (nat.div_lt_self' _ _))

def ex1' := well_founded.fix nat.lt_wf ex1_F

lemma ex1'_eq : ∀ x, ex1' x = ex1_F x (λ y h, ex1' y) := well_founded.fix_eq _ _

lemma ex1'_0 : ex1' 0 = 1 := ex1'_eq 0

lemma ex1'_4 : ex1' 4 = 4 := by { erw [ex1'_eq, ex1_F, ex1'_eq, ex1_F, ex1'_0], norm_num,  }

def ex2 : ℕ → ℕ
| n := if h : odd n ∨ n = 0 then 0 else
 have n / 2 < n, from
  nat.div_lt_self (nat.pos_of_ne_zero (not_or_distrib.mp h).2) (nat.le_refl 2),
  1 + ex2 (n / 2)

lemma ex2_4 : ex2 4 = 2 := by { erw [ex2, ex2, ex2], norm_num }

def ex2_F : Π (x : ℕ) (h : Π (y : ℕ), y < x → ℕ), ℕ
| n ih := if h : odd n ∨ n = 0 then 0 else
  1 + ih (n / 2) (nat.div_lt_self (nat.pos_of_ne_zero (not_or_distrib.mp h).2) (nat.le_refl 2))

def ex2' := well_founded.fix nat.lt_wf ex2_F

lemma ex2'_eq : ∀ x, ex2' x = ex2_F x (λ y h, ex2' y) := well_founded.fix_eq _ _

lemma ex2'_0 : ex2' 0 = 0 := ex2'_eq 0

lemma ex2'_1 : ex2' 1 = 0 := ex2'_eq 1

lemma ex2'_2 : ex2' 2 = 1 := by { erw [ex2'_eq, ex2_F, ex2'_1], norm_num }

lemma ex2'_4 : ex2' 4 = 2 := by { erw [ex2'_eq, ex2_F, ex2'_2], norm_num }

end exercises

section underhanded_tricks

/-!
### Underhanded tricks

Various tricks can be employed to simplify use of the equation compiler to define functions that
depend on well-founded recursion.
-/

def lg2 : ℕ → ℕ
| 0 := 0
| 1 := 0
| (n + 2) :=
  have h : (n + 2) / 2 = n / 2 + 1 :=
    nat.add_div_of_dvd_left (dvd_refl 2),
  have n / 2 + 1 < n + 2 := h ▸ nat.div_lt_self' _ _,
    1 + lg2 ((n + 2) / 2)

def lg2' : ℕ → ℕ
| n := if h : n ≤ 1 then 0 else
 have n / 2 < n, from
  nat.div_lt_self (by linarith) (nat.le_refl 2),
  1 + lg2' (n / 2)

def lg2'' : ℕ → ℕ
| n := if h : n ≤ 1 then 0 else
 have n / 2 < n, from nat.div_lt_self (by linarith) (nat.le_refl 2),
 by { exact 1 + lg2'' (n / 2) }

def lg2''' : ℕ → ℕ
| n := if h : n ≤ 1 then 0 else
begin
  exact have n / 2 < n,
    from nat.div_lt_self (by linarith) (nat.le_refl 2),
  1 + lg2''' (n / 2),
end

end underhanded_tricks

section proving_log_inequalities

/-!
### Proving log inequalities

We now show  `(n + 1) < 2 ^ lg (n + 1) ≤ 2 * (n + 1)` for each `n : ℕ`. The proof involves
well-founded recursion.
-/

lemma two_mul_succ_div_two {m : ℕ} : (2 * m + 1) / 2 = m :=
begin
  rw [nat.succ_div, if_neg], norm_num,
  rintros ⟨k, h⟩, exact nat.two_mul_ne_two_mul_add_one h.symm,
end

lemma two_mul_succ_succ {m : ℕ} : 2 * m + 1 + 1 = 2 * (m + 1) := by linarith

def lg_ineq (n : ℕ) : Prop := n + 1 < 2 ^ lg (n + 1)

/--
`lg_lemma_aux` is an auxiliary lemma used to show `lg x` satisfies the desired lower bound on
the assumpion that `lg y` also satisfies the correct bound, for every `y < x`.
-/

lemma lg_lemma_aux (x : ℕ) (h : Π (y : ℕ), y < x → lg_ineq y) : lg_ineq x :=
begin
  cases x,
  { rw [lg_ineq, lg_one], norm_num, }, -- base case
  dsimp [lg_ineq] at h ⊢,
  rcases nat.even_or_odd x with ⟨m, rfl⟩ | ⟨m, rfl⟩,
  { have h₄ : m < 2 * m + 1, by linarith,
    specialize h m h₄, rw [nat.succ_eq_add_one, lg, pow_add],
    rw two_mul_succ_succ, norm_num, exact h, },
  { have h₄ : m < 2 * m + 1 + 1, by linarith,
    specialize h m h₄, rw [lg, pow_add, nat.succ_eq_add_one],
    rw [two_mul_succ_succ, two_mul_succ_div_two], linarith, },
end

/--
`lg_lemma` is the lower bound result for `lg x`. It uses well-founded recursion and `lg_lemma_aux`.
-/
lemma lg_lemma : ∀ (x : ℕ), x + 1 < 2 ^ lg (x + 1) := well_founded.fix nat.lt_wf lg_lemma_aux

/--
`lg_lemma2` is the lower bound result for `lg x`. In contrast to `lg_lemma`, this proof uses the
equation compiler to bypass the application of `well_founded.fix`.

At two points in the proof, we supply inequalities needed to show that the recursive application
is decreasing. These must be provided in term mode.
-/
lemma lg_lemma2 : ∀ (x : ℕ), x + 1 < 2 ^ lg (x + 1)
| 0 := by { rw lg_one, norm_num, }
| (x + 1) := or.elim (nat.even_or_odd x)
( λ ⟨m, hm⟩,
  have m < x + 1, by linarith, -- needed for wf recursion
  begin
    specialize lg_lemma2 m, rw [hm, lg, pow_add],
    rw two_mul_succ_succ, norm_num, exact lg_lemma2,
  end )
( λ ⟨m, hm⟩,
  have m < x + 1, by linarith, -- needed for wf recursion
  begin
    specialize lg_lemma2 m, rw [hm, lg, pow_add],
    rw [two_mul_succ_succ, two_mul_succ_div_two], linarith,
  end )

/-
`lg_lemma2` pushes more of the proof into tactic mode, only coming out of tactic mode to
prove the recursive application is decreasing.
-/
lemma lg_lemma2' : ∀ (x : ℕ), x + 1 < 2 ^ lg (x + 1)
| 0 := by { rw lg_one, norm_num, }
| (x + 1) :=
begin
  cases (nat.even_or_odd x),
  { rcases h with ⟨m, hm⟩,
    rw [hm, lg, pow_add],
    rw two_mul_succ_succ, norm_num,
    exact have m < x + 1, by linarith,
      lg_lemma2' m, },
  { rcases h with ⟨m, hm⟩,
    rw [hm, lg, pow_add, two_mul_succ_succ, two_mul_succ_div_two],
    exact have m < x + 1, by linarith,
     show _, by { specialize lg_lemma2' m, linarith }, }
end

/--
`lg_lemma2''` is a proof of the lower bound via `using_well_founded`.
-/
lemma lg_lemma2'' : ∀ (x : ℕ), x + 1 < 2 ^ lg (x + 1)
| 0 := by { rw lg_one, norm_num, }
| (x + 1) :=
begin
  cases (nat.even_or_odd x),
  { rcases h with ⟨m, hm⟩, specialize lg_lemma2'' m, rw [hm, lg, pow_add],
    rw two_mul_succ_succ, norm_num, exact lg_lemma2'', },
  { rcases h with ⟨m, hm⟩,
    specialize lg_lemma2'' m, rw [hm, lg, pow_add],
    rw [two_mul_succ_succ, two_mul_succ_div_two], linarith }
end
using_well_founded { dec_tac := `[exact show m < x + 1, by linarith] }

end proving_log_inequalities

section exercises

/-!
### Exercises

The first exercise is a trivial modification of `lg_lemma2''`, but for the upper bound.
The second concerns the lower bound for the `lg2` function and requires more thought.
-/

lemma lg_ub : ∀ (x : ℕ), 2 ^ lg (x + 1) ≤ 2 * (x + 1)
| 0 := by { rw lg_one, norm_num, }
| (x + 1) :=
begin
  cases (nat.even_or_odd x),
  { rcases h with ⟨m, hm⟩, specialize lg_ub m, rw [hm, lg, pow_add],
    rw two_mul_succ_succ, norm_num, exact lg_ub, },
  { rcases h with ⟨m, hm⟩,
    specialize lg_ub m, rw [hm, lg, pow_add],
    rw [two_mul_succ_succ, two_mul_succ_div_two], linarith }
end
using_well_founded { dec_tac := `[exact show m < x + 1, by linarith] }

example (a b c : ℕ) : (2 * a + 2) / 2 = a + 1 := by norm_num

/-!
In the proof below, the `dec_tac` term uses a tactic combinator. Is there a better approach?
-/

 lemma lg2_lb : ∀ (x : ℕ), (x + 1) < 2 * 2 ^ lg2 (x + 1)
| 0 := by { rw lg2, norm_num }
| 1 := by { erw [lg2, lg2], norm_num }
| (x + 2) :=
begin
  cases (nat.even_or_odd x),
  { rcases h with ⟨m, hm⟩, specialize lg2_lb m, rw [hm, lg2, pow_add],
    conv_rhs { rw [add_right_comm, two_mul_succ_succ, two_mul_succ_div_two], }, linarith },
  { rcases h with ⟨m, hm⟩, rw [hm, lg2, two_mul_succ_succ, pow_add, two_mul_succ_succ],
    rw nat.mul_div_cancel_left _ zero_lt_two, specialize lg2_lb (m + 1), linarith, }
end
using_well_founded { dec_tac :=
  `[ {exact show m + 1 < x + 2, by linarith} <|> exact show m < x + 2, by linarith ] }

end exercises

end logarithms

section prime_factors

/-!
## Prime factors

The following is adapted from `data.nat.prime` in mathlib. Here the normal `<` relation isn't what
we want because we're computing `min_fac_aux k` using a value for `min_fac_aux (k + 2)`.

But clearly `k + 2 < k` is false! Instead, we use a relation generated by a 'measure', that is,
a function `f : α → ℕ`. In our case, we take `f` so that `f k = sqrt n + 2 - k`, where `n` is fixed.

Let `≺` denote the relation on `ℕ` generated by `f`. By definition, `a ≺ b` means `f a < f b`.
It's a theorem that for every measure `f`, the relation `≺` is well-founded.

We ask Lean to use this relation via the command

``using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ k, sqrt n + 2 - k)⟩]}``

What remains is to show that the recursive application in decreasing. Recall we want to define
`min_fac_aux k` in terms of `min_fac_aux (k + 2)`. We must show `f (k + 2) < f k`.

This is precisely the assertion of `min_fac_lemma`.
-/

open nat

lemma min_fac_lemma (n k : ℕ) (h : ¬ n < k * k) :
    sqrt n - k < sqrt n + 2 - k :=
begin
  rw nat.sub_lt_sub_right_iff,
  { exact lt_trans (lt_add_one _) (lt_add_one _) },
  { rw nat.le_sqrt, exact le_of_not_gt h },
end

def min_fac_aux (n : ℕ) : ℕ → ℕ | k :=
if h : n < k * k then n else
if k ∣ n then k else
have _ := min_fac_lemma n k h,
min_fac_aux (k + 2)
using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ k, sqrt n + 2 - k)⟩]}

lemma min_fac_dvd (n : ℕ) : ∀ (k : ℕ), (min_fac_aux n k) ∣ n
| k := if h : n < k * k then by { rw min_fac_aux, simp [h] } else
  if hk : k ∣ n then by { rw min_fac_aux, simp [h, hk] } else
  have _ := min_fac_lemma n k h,
  by { rw min_fac_aux, simp [h, hk], exact min_fac_dvd (k+2) }
  using_well_founded { rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ k, sqrt n + 2 - k)⟩]}

end prime_factors

section fermat_factorisation

/-
## Fermat factorisation

`fermat_fac n` returns a factor of `n` by Fermat factorisation.

It uses a function `fermat_fac_aux` such that `fermat_fac_aux n a` is the Fermat factorisation
of `n`, starting at `a`. That is, if `n < a`, we return `n`. Otherwise, we test if `bs : =a ^ 2 - n`
is a perfect square. If `bs` is a perfect square, return `a + sqrt bs`. Otherwise, increment `a`
by `1` and continue the process.
-/

open nat

def fermat_fac_aux (n : ℕ) : ℕ → ℕ | a :=
if h : n < a then n else
let bs := a * a - n  in
if (sqrt bs)^2 = bs then a + sqrt bs else
  have n - a < n + 1 - a, by
  { rw nat.sub_lt_sub_right_iff, exact lt_add_one _, exact le_of_not_gt h, },
  fermat_fac_aux (a + 1)
using_well_founded { rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ k, n + 1 - k)⟩]}

/--
`fermat_fac n` is the result of applying Fermat factorisation to `n`.
-/
def fermat_fac (n : ℕ) := let c := sqrt n in
  if c^2 = n then c else fermat_fac_aux n (c + 1)

/-!
If the code below is uncommented, it spits out `3181`, a factor of 9539819.
-/
-- #eval fermat_fac 9539819

/--
`sqrt_tac` is used to prove `sqrt n = u`.
-/
meta def sqrt_tac := `[ symmetry, rw nat.eq_sqrt, norm_num ]

example : fermat_fac 9539819 = 3181 :=
begin
  rw fermat_fac, dsimp,
  rw [show sqrt 9539819 = 3088, by sqrt_tac, fermat_fac_aux], norm_num,
  have foo : ¬ (sqrt 2102 ^ 2 = 2102) := λ h,
    by { rw show sqrt 2102 = 45, by sqrt_tac at h, norm_num at h },
  simp only [foo, if_false], clear foo, rw fermat_fac_aux, rw [if_neg], dsimp, rw [if_pos],
  any_goals { norm_num, try { rw show sqrt 8281 = 91, by sqrt_tac, norm_num }, },
end

lemma fermat_fac_aux_dvd (n : ℕ) : ∀ (a : ℕ), a * a ≥ n → fermat_fac_aux n a ∣ n
| a := if h : n < a then by { rw fermat_fac_aux, simp [h] } else
if hsq : (sqrt (a * a - n))^2 = a * a - n then
by { rw fermat_fac_aux, simp [h, hsq],
  intro hge,
  use a - sqrt (a * a - n),
  rw [←nat.sq_sub_sq, hsq, pow_two, nat.sub_sub_self hge] }
 else  have n - a < n + 1 - a, by
  { rw nat.sub_lt_sub_right_iff, exact lt_add_one _, exact le_of_not_gt h, },
 by { intro hge, rw fermat_fac_aux, simp [h, hsq], apply fermat_fac_aux_dvd, linarith }
using_well_founded { rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ k, n + 1 - k)⟩]}

/--
`fermat_fac n` divides `n`, for every `n`.
-/
lemma fermat_fac_dvd (n : ℕ) : fermat_fac n ∣ n :=
begin
  rw fermat_fac,
  by_cases h : (sqrt n) ^ 2 = n,
  { simp [h], use sqrt n, rw pow_two at h, rw h, },
  { simp [h], apply fermat_fac_aux_dvd, linarith [succ_le_succ_sqrt n], },
end

end fermat_factorisation

section using_well_founded_commmand

/-!
## The `using_well_founded` command

The argument for `using_well_founded`, a term of structure type `well_founded_tactics` is described
in `init.meta.well_founded_tactics`.

This structure has two fields: `dec_tac` and `rel_tac`. We've seen `rel_tac` already. It's purpose
is to create a well-founded relation (more precisely, to synthesize a term of type
`has_well_founded α`, where `α` is the type over which we are recursing).

The `dec_tac` field is used to synthesize a proof that the recursive application is decreasing.
-/

/--
`lg_using` is a redefinition of the function `lg` that employs `using_well_founded` to prove the
recursive application is decreasing.
-/
def lg_using : ℕ → ℕ
| 0 := 0
| (x + 1) := 1 + lg_using ((x + 1)/2)
  using_well_founded { dec_tac := `[exact nat.div_lt_self' _ _] }

def lg2_iv : ℕ → ℕ
| n := if h : n ≤ 1 then 0 else 1 + lg2_iv (n / 2)
using_well_founded
{ dec_tac := `[exact nat.div_lt_self (by linarith) (nat.le_refl 2)] }

end using_well_founded_commmand

section quick_sort

/-!
## Quick sort

We define `qsort`, the quick sort algorithm and prove that it sorts a list.

Might want to rewrite this using the definition given in core Lean `data.list.qsort`.
The definition there uses the notion of `partition`.

Note that mathlib has a defintion of `sorted` that is different from mine. It's in
`data.list.sort`.

A good discussion of quick sort proof is available at:
http://www.doc.ic.ac.uk/~scd/Dafny_Material/Lectures.pdf.
-/

open list

def at_most_list (x : ℕ) (xs : list ℕ) : list ℕ :=
  list.filter (λ y, y ≤ x) xs

def greater_list (x : ℕ) (xs : list ℕ) : list ℕ :=
  list.filter (λ y, x < y) xs

lemma filter_length_lt {p : ℕ → Prop} [decidable_pred p] :
  ∀ ys, (list.filter p ys).length < ys.length + 1
| [] := by simp
| (y :: ys) :=
begin
  simp only [list.filter, list.length],
  by_cases h : p y,
  { rw if_pos h, simp only [list.length, add_lt_add_iff_right], tauto, },
  { rw if_neg h, apply nat.lt.step, tauto, }
end

/-!
Lean can aid you in determining the correct inequality for well-founded recursion. Simply
write a proof *without* indicating the decreasing application and Lean will provide a helpful
error message, suggesting which inequality you must prove.
-/

/--
`qsort xs` returns a list `ys` such that `sorted ys` and `xs ~ ys`.
-/
def qsort : list ℕ → list ℕ
| [] := []
| (x :: xs) :=
  qsort (at_most_list x xs) ++ (x :: qsort (greater_list x xs))
  using_well_founded { rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ ys, ys.length)⟩],
    dec_tac := `[exact filter_length_lt _] }

inductive sorted : list ℕ → Prop
| nil_sort : sorted []
| singleton_sort {x : ℕ} : sorted [x]
| cons_cons_sort {x y : ℕ} {xs : list ℕ} : x ≤ y → sorted (y :: xs) → sorted (x :: y :: xs)

open sorted

lemma sorted_cons {x : ℕ} {as : list ℕ} (has : sorted as) (h : ∀ a ∈ as, x ≤ a) : sorted (x :: as) :=
begin
  cases has with a' p q qs hpq hqs,
  { exact singleton_sort, },
  { simp at h, apply cons_cons_sort; assumption, },
  { apply cons_cons_sort _ has, apply h, simp, },
end

lemma le_of_sorted_cons {x : ℕ} {as : list ℕ} (h : sorted (x :: as)) : ∀ a ∈ as, x ≤ a :=
begin
  intros a has,
  induction' h with _ _ p ps hxp hps,
  { tauto, },
  { apply le_trans hxp, rw list.mem_cons_iff at has,
    cases has,
    { subst has, },
    { exact ih _ has, }, },
end

lemma qsort_sorted_aux {x : ℕ} {as bs : list ℕ} (has : sorted as) (hbs : sorted bs)
(hale : ∀ a ∈ as, a ≤ x) (hble : ∀ b ∈ bs, x ≤ b) : sorted (as ++ (x :: bs)) :=
begin
  induction as with q qs ih,
  { rw list.nil_append, exact sorted_cons hbs hble, },
  { cases has with _ _ r rs hqr hrs,
    { simp, apply sorted_cons,
      { simp at ih, apply ih, exact nil_sort, },
      { intros a hain, simp at hain, simp at hale,
        cases hain,
        { subst hain, exact hale, },
        { specialize hble _ hain, exact le_trans hale hble, }, }, },
    { apply sorted_cons,
      { apply ih hrs, intros a ha, simp at ha,
        cases ha,
        { subst ha, apply hale, simp, },
        { apply hale, right, right, exact ha, }, },
      { simp only [forall_eq_or_imp, list.append, list.mem_cons_iff],
        rw and_iff_right hqr, clear ih,
        intros a hain,
        change (a ∈ rs ++ (x :: bs)) at hain, rw list.mem_append at hain,
        rcases hain with hain | rfl | hain,
        { apply le_trans hqr, apply le_of_sorted_cons hrs, exact hain,  },
        { apply hale, simp, },
        { specialize hble _ hain, apply le_trans _ hble, apply hale, simp, }, }, }, },
end

lemma perm_append_cons {xs as as' bs bs' : list ℕ} {y : ℕ}
(h : xs ~ y :: as ++ bs) (has : as ~ as') (hbs : bs ~ bs') : xs ~ as' ++ y :: bs' :=
calc xs ~ y :: as ++ bs : h
    ... ~ as ++ y :: bs : perm_middle.symm
    ... ~ as' ++ y :: bs : perm.append_right _ has
    ... ~ as' ++ y :: bs' : perm.append_left as' (perm.cons _ hbs)

lemma perm_at_most_append_greater {x : ℕ} : ∀ as, as ~ (at_most_list x as) ++ (greater_list x as)
| [] := by { dsimp [at_most_list, greater_list], refl, }
| (a :: as) :=
begin
  have h := perm_at_most_append_greater as, dsimp [at_most_list, greater_list],
  by_cases ha : a ≤ x,
  { rw filter_cons_of_pos, swap, exact ha,
    rw filter_cons_of_neg, swap, linarith, apply perm.cons, exact h, },
  { rw filter_cons_of_neg, swap, exact ha,
    rw filter_cons_of_pos, swap, linarith,
    exact perm.trans (perm.cons a h) perm_middle.symm, },
end

lemma qsort_sorted : ∀ xs, sorted (qsort xs) ∧ xs ~ qsort xs
| [] := by { simp [nil_sort, qsort], }
| (y :: ys) :=
begin
  rw qsort,
  have h₁ := qsort_sorted (at_most_list y ys),
  have h₂ := qsort_sorted (greater_list y ys),
  split,
  { refine qsort_sorted_aux h₁.1 h₂.1 _ _,
    { intros a ha,
      rw perm.mem_iff h₁.2.symm at ha, dsimp [at_most_list] at ha, simp at ha, exact ha.2, },
    { intros b hb,
      rw perm.mem_iff h₂.2.symm at hb, dsimp [greater_list] at hb, simp at hb, linarith, }, },
  { exact perm_append_cons (perm.cons y (perm_at_most_append_greater _)) h₁.2 h₂.2, },
end
using_well_founded { rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ ys, ys.length)⟩],
  dec_tac := `[exact filter_length_lt _] }

end quick_sort

end wf_exlean

end exlean


/- Introduces matrices and horrifying linear algebra. -/

import qtt.context

open context
open debrujin_idx

/- This matrix defines the context in which every variable (given by a debrujin idx)
   exists. In other words, it defines a substitution. Variables all exist in the same
   precontext, but the type multiplicities might differ. -/
def matrix (τ mult: Type) (γ δ: precontext τ)
  : Type := Π (T: τ), γ ∋ T → @context τ mult δ

namespace matrix

variable {τ: Type}
variables {mult: Type} [semiring mult]

def identity: Π γ, @matrix τ mult γ γ
| (T::δ) _ ZVar := ⟦1⬝T⟧::0
| (T::δ) U (SVar x) := ⟦0⬝T⟧::(identity δ U x)

@[unfold_] lemma identity_zvar {T: τ} {γ: precontext τ}
  : identity (T::γ) T ZVar = ⟦(1: mult)⬝T⟧::(0: context γ) := by refl

@[unfold_] lemma identity_svar {T U: τ} {δ: precontext τ} {x}
  : identity (T::δ) U (SVar x) = ⟦(0: mult)⬝T⟧::(identity δ U x) := by refl

def vmul: ∀ {γ δ}, @context τ mult γ → @matrix τ mult γ δ → @context τ mult δ
| _ δ context.nil _ := 0
| _ _ (⟦π⬝T⟧::Γ) Ξ := (π • Ξ T ZVar) + (vmul Γ (λ U x, Ξ U (SVar x)))

infix ` ⊛ `:70 := vmul

namespace vmul

@[simp] lemma vmul_nil {δ} {Ξ: @matrix τ mult [] δ}
  : context.nil ⊛ Ξ = 0 := by refl

@[unfold_] lemma vmul_cons {γ δ} {T: τ} {Γ: context γ} {π: mult} {Ξ: @matrix τ mult (T::γ) δ}
  : ⟦π⬝T⟧::Γ ⊛ Ξ = (π • Ξ T ZVar) + (Γ ⊛ (λ U x, Ξ U (SVar x))) :=
    by refl

@[simp] lemma zero_vmul
  : ∀ {γ δ: precontext τ} (M: @matrix τ mult γ δ),
    0 ⊛ M = 0 :=
begin
  intros,
  induction γ with T γ ih,
  { refl },
  { unfold has_zero.zero zeros,
    simp * with unfold_,
    show (0: mult) • M T ZVar + 0 ⊛ (λ (U: τ) (x: γ ∋ U), M U (SVar x)) = 0,
    simp * },
end

@[simp] lemma vmul_ext_zero
  : ∀ {γ δ} {Γ: context γ} {Ξ: @matrix τ mult γ δ} {T: τ},
    Γ ⊛ (λ U x, ⟦0⬝T⟧::(Ξ U x)) = ⟦0⬝T⟧::(Γ ⊛ Ξ) :=
begin
  intros,
  induction Γ with γ' π T' Γ ih,
  { refl },
  { simp * with unfold_ },
end

@[simp] lemma one_vmul
  : ∀ {γ δ} {Ξ: @matrix τ mult γ δ} {T: τ}
    (x: γ ∋ T),
    -------------------------------
    (identity γ T x) ⊛ Ξ = Ξ T x :=
begin
  intros,
  induction x with γ' T' δ' T'' U x' ih;
  { simp * with unfold_ },
end

@[simp] lemma vmul_one
  : ∀ {γ} (Γ: @context τ mult γ),
    Γ ⊛ (identity γ) = Γ :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { simp [*, vmul_ext_zero] with unfold_ },
end

lemma smul_vmul
  : ∀ {γ δ} {Γ: @context τ mult γ} {Ξ: @matrix τ mult γ δ} {π: mult},
    (π • Γ) ⊛ Ξ = π • (Γ ⊛ Ξ) :=
begin
  intros,
  induction Γ with γ' π' T Γ ih;
  { simp [*, context.mul_smul]
    with unfold_ sop_form },
end

@[sop_form] lemma vmul_right_distrib
  : ∀ {γ δ} {Γ₁ Γ₂: @context τ mult γ} {Ξ: @matrix τ mult γ δ},
    (Γ₁ + Γ₂) ⊛ Ξ = (Γ₁ ⊛ Ξ) + (Γ₂ ⊛ Ξ) :=
begin
  intros,
  induction Γ₁ with γ₁ π₁ T₁ Γ₁ ih₁;
  { cases Γ₂,
    simp * with unfold_ sop_form },
end

end vmul

end matrix