import data.set.basic
import data.set.finite
import data.set.lattice
import data.list.basic
import tactic
import languages.basic
import languages.star
import data.finset.basic
import data.finset.lattice

open languages

namespace regex

variables {S : Type} [fintype S]

inductive regex (S : Type)
| empty     : regex
| eps       : regex
| one       : S → regex
| union     : regex → regex → regex
| append    : regex → regex → regex
| star      : regex → regex

inductive regex.accepts : regex S → list S → Prop
| eps :
    regex.accepts regex.eps []
| one {ch : S} :
    regex.accepts (regex.one ch) [ch]
| append {l1 l2 r1 r2} :
    regex.accepts r1 l1 →
    regex.accepts r2 l2 →
    regex.accepts (regex.append r1 r2) (l1 ++ l2)
| union_left {l r1 r2} :
    regex.accepts r1 l →
    regex.accepts (regex.union r1 r2) l
| union_right {l r1 r2} :
    regex.accepts r2 l →
    regex.accepts (regex.union r1 r2) l
| star_eps {r} :
    regex.accepts (regex.star r) []
| star_append {r l1 l2} :
    regex.accepts r l1 →
    regex.accepts (regex.star r) l2 →
    regex.accepts (regex.star r) (l1 ++ l2)

def regex_lang (l : set (list S)) := ∃ r : regex S, r.accepts = l

lemma regex_empty_not_accepts {w : list S} : ¬ regex.empty.accepts w := λ h, by cases h

theorem regex_empty_is_empty_lang : regex.empty.accepts = (∅ : set (list S)) :=
    by {ext, split; rintro ⟨⟩}

theorem empty_is_regex : regex_lang (∅ : set (list S)) :=
    ⟨regex.empty, regex_empty_is_empty_lang⟩

theorem regex_eps_is_eps_lang : regex.eps.accepts = ({[]} : set (list S)) :=
begin
    ext x, split, {
        rintro ⟨_⟩,
        simp only [set.mem_singleton],
    }, {
        intro xnil,
        convert regex.accepts.eps,
    }
end

theorem eps_is_regex : regex_lang ({[]} : set (list S)) :=
    ⟨regex.eps, regex_eps_is_eps_lang⟩

theorem regex_one_is_one_lang {ch : S} : (regex.one ch).accepts = ({[ch]} : set (list S)) :=
begin
    ext x, split, {
        rintro ⟨_⟩,
        simp only [set.mem_singleton],
    }, {
        intro xone,
        convert regex.accepts.one,
    }
end

theorem one_is_regex {c : S} : regex_lang ({[c]} : set (list S)) :=
    ⟨regex.one c, regex_one_is_one_lang⟩

theorem regex_union_is_lang_union {rl rm : regex S}
    : (regex.union rl rm).accepts = (rl.accepts ∪ rm.accepts : set (list S)) :=
begin
    apply set.subset.antisymm,
    { rintro x (_ | _),
      left, assumption,
      right, assumption },
    { rintro x (hleft | hright),
      exact regex.accepts.union_left hleft,
      exact regex.accepts.union_right hright,
    },
end

theorem union_is_regex {L M : set (list S)}: regex_lang L → regex_lang M → regex_lang (L ∪ M) :=
begin
    rintro ⟨rl, rfl⟩ ⟨rm, rfl⟩,
    use regex.union rl rm,
    rw regex_union_is_lang_union,
end

theorem regex_append_is_lang_append {rl rm : regex S} :
    (rl.append rm).accepts = (rl.accepts * rm.accepts : set (list S)) :=
begin
    apply set.subset.antisymm, {
        rintro x h,
        rcases h with (_ | _ | ⟨left, right, _, _, hleft, hright⟩ | _ | _ | _ | _),
        use [left, right, hleft, hright, rfl],
    }, {
        rintro _ ⟨ left, right, hleft, hright, rfl ⟩,
        exact regex.accepts.append hleft hright,
    }
end

theorem append_is_regex {L M : set (list S)}: regex_lang L → regex_lang M → regex_lang (L * M) :=
begin
    rintro ⟨rl, rfl⟩ ⟨rm, rfl⟩,
    exact ⟨regex.append rl rm, regex_append_is_lang_append⟩,
end

lemma regex_star_iff_list_join {r rs : regex S}
    (hrs : rs = r.star) (w : list S)  :
    rs.accepts w ↔ ∃ l (h : ∀ x, x ∈ l → r.accepts x), w = list.join l :=
begin
    split, {
        intro rsw,
        induction rsw,
        repeat {contradiction},
        case star_eps : {
            use list.nil,
            simp,
        },
        case star_append : _ left right rleft rright ih_left ih_right {
            rcases hrs with ⟨_⟩,
            rcases ih_right hrs with ⟨l, h, rfl⟩,
            refine ⟨left :: l, _, rfl⟩,
            rw list.ball_cons,
            exact ⟨rleft, h⟩,
        },
    }, {
        subst hrs,
        rintro ⟨l, h, rfl⟩,
        induction l with head tail ih, {
            use regex.accepts.star_eps,
        }, {
            rw list.ball_cons at h,
            refine regex.accepts.star_append (h.1) (ih h.2),
        },
    },
end

theorem regex_star_is_kleene_star {rl : regex S}
    : rl.star.accepts = kleene_star (rl.accepts) :=
begin
    ext w,
    rw star_eq_list_join,
    exact regex_star_iff_list_join rfl w,
end

theorem star_is_regex {L : set (list S)}: regex_lang L → regex_lang (kleene_star L) :=
begin
    rintro ⟨rl, rfl⟩,
    use regex.star rl,
    rw regex_star_is_kleene_star,
end

theorem finset_bUnion_is_regex {α : Type*} [fintype α] {X : set α} {P : α → set (list S)} [decidable_eq α] :
    (∀ c ∈ X, regex_lang(P c)) → regex_lang(⋃ c ∈ X, P c) :=
begin
    lift X to finset α using set.finite.of_fintype X,
    rw finset.set_bUnion_coe,
    apply finset.induction_on X, {
        simp only [empty_is_regex, finset.not_mem_empty, set.Union_empty, set.Union_neg, not_false_iff, forall_true_iff],
    }, {
        rintro head tail h_head ih hX,
        rw finset.set_bUnion_insert,
        refine union_is_regex _ _,
        refine hX _ (finset.mem_insert_self _ _),
        refine ih (λ c c_tail, hX c (finset.mem_insert_of_mem c_tail)),
    },
end

end regex


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

! This file was ported from Lean 3 source module init.data.sigma.lex
! leanprover-community/mathlib commit 9af482290ef68e8aaa5ead01aa7b09b7be7019fd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Data.Sigma.Basic
import Leanbin.Init.Meta.Default

universe u v

namespace PSigma

section

variable {α : Sort u} {β : α → Sort v}

variable (r : α → α → Prop)

variable (s : ∀ a, β a → β a → Prop)

#print PSigma.Lex /-
-- Lexicographical order based on r and s
inductive Lex : PSigma β → PSigma β → Prop
  | left : ∀ {a₁ : α} (b₁ : β a₁) {a₂ : α} (b₂ : β a₂), r a₁ a₂ → Lex ⟨a₁, b₁⟩ ⟨a₂, b₂⟩
  | right : ∀ (a : α) {b₁ b₂ : β a}, s a b₁ b₂ → Lex ⟨a, b₁⟩ ⟨a, b₂⟩
#align psigma.lex PSigma.Lex
-/

end

section

open WellFounded Tactic

parameter {α : Sort u}{β : α → Sort v}

parameter {r : α → α → Prop}{s : ∀ a : α, β a → β a → Prop}

-- mathport name: «expr ≺ »
local infixl:50 "≺" => Lex r s

theorem lex_accessible {a} (aca : Acc r a) (acb : ∀ a, WellFounded (s a)) :
    ∀ b : β a, Acc (Lex r s) ⟨a, b⟩ :=
  Acc.recOn aca fun xa aca (iha : ∀ y, r y xa → ∀ b : β y, Acc (Lex r s) ⟨y, b⟩) => fun b : β xa =>
    Acc.recOn (WellFounded.apply (acb xa) b)
      fun xb acb (ihb : ∀ y : β xa, s xa y xb → Acc (Lex r s) ⟨xa, y⟩) =>
      Acc.intro ⟨xa, xb⟩ fun p (lt : p≺⟨xa, xb⟩) =>
        have aux : xa = xa → HEq xb xb → Acc (Lex r s) p :=
          @PSigma.Lex.rec_on α β r s (fun p₁ p₂ => p₂.1 = xa → HEq p₂.2 xb → Acc (Lex r s) p₁) p
            ⟨xa, xb⟩ lt
            (fun (a₁ : α) (b₁ : β a₁) (a₂ : α) (b₂ : β a₂) (h : r a₁ a₂) (eq₂ : a₂ = xa)
                (eq₃ : HEq b₂ xb) =>
              by subst eq₂; exact iha a₁ h b₁)
            fun (a : α) (b₁ b₂ : β a) (h : s a b₁ b₂) (eq₂ : a = xa) (eq₃ : HEq b₂ xb) =>
            by
            subst eq₂
            have new_eq₃ := eq_of_hEq eq₃
            subst new_eq₃
            exact ihb b₁ h
        aux rfl (HEq.refl xb)
#align psigma.lex_accessible PSigma.lex_accessible

-- The lexicographical order of well founded relations is well-founded
theorem lex_wf (ha : WellFounded r) (hb : ∀ x, WellFounded (s x)) : WellFounded (Lex r s) :=
  WellFounded.intro fun ⟨a, b⟩ => lex_accessible (WellFounded.apply ha a) hb b
#align psigma.lex_wf PSigma.lex_wf

end

section

parameter {α : Sort u}{β : Sort v}

def LexNdep (r : α → α → Prop) (s : β → β → Prop) :=
  Lex r fun a : α => s
#align psigma.lex_ndep PSigma.LexNdep

theorem lexNdep_wf {r : α → α → Prop} {s : β → β → Prop} (ha : WellFounded r) (hb : WellFounded s) :
    WellFounded (lex_ndep r s) :=
  WellFounded.intro fun ⟨a, b⟩ => lex_accessible (WellFounded.apply ha a) (fun x => hb) b
#align psigma.lex_ndep_wf PSigma.lexNdep_wf

end

section

variable {α : Sort u} {β : Sort v}

variable (r : α → α → Prop)

variable (s : β → β → Prop)

#print PSigma.RevLex /-
-- Reverse lexicographical order based on r and s
inductive RevLex : (@PSigma α fun a => β) → (@PSigma α fun a => β) → Prop
  | left : ∀ {a₁ a₂ : α} (b : β), r a₁ a₂ → rev_lex ⟨a₁, b⟩ ⟨a₂, b⟩
  | right : ∀ (a₁ : α) {b₁ : β} (a₂ : α) {b₂ : β}, s b₁ b₂ → rev_lex ⟨a₁, b₁⟩ ⟨a₂, b₂⟩
#align psigma.rev_lex PSigma.RevLex
-/

end

section

open WellFounded Tactic

parameter {α : Sort u}{β : Sort v}

parameter {r : α → α → Prop}{s : β → β → Prop}

-- mathport name: «expr ≺ »
local infixl:50 "≺" => RevLex r s

theorem revLex_accessible {b} (acb : Acc s b) (aca : ∀ a, Acc r a) : ∀ a, Acc (RevLex r s) ⟨a, b⟩ :=
  Acc.recOn acb fun xb acb (ihb : ∀ y, s y xb → ∀ a, Acc (RevLex r s) ⟨a, y⟩) => fun a =>
    Acc.recOn (aca a) fun xa aca (iha : ∀ y, r y xa → Acc (RevLex r s) (mk y xb)) =>
      Acc.intro ⟨xa, xb⟩ fun p (lt : p≺⟨xa, xb⟩) =>
        have aux : xa = xa → xb = xb → Acc (RevLex r s) p :=
          @RevLex.rec_on α β r s (fun p₁ p₂ => fst p₂ = xa → snd p₂ = xb → Acc (RevLex r s) p₁) p
            ⟨xa, xb⟩ lt
            (fun a₁ a₂ b (h : r a₁ a₂) (eq₂ : a₂ = xa) (eq₃ : b = xb) =>
              show Acc (RevLex r s) ⟨a₁, b⟩ from
                have r₁ : r a₁ xa := Eq.recOn eq₂ h
                have aux : Acc (RevLex r s) ⟨a₁, xb⟩ := iha a₁ r₁
                Eq.recOn (Eq.symm eq₃) aux)
            fun a₁ b₁ a₂ b₂ (h : s b₁ b₂) (eq₂ : a₂ = xa) (eq₃ : b₂ = xb) =>
            show Acc (RevLex r s) (mk a₁ b₁) from
              have s₁ : s b₁ xb := Eq.recOn eq₃ h
              ihb b₁ s₁ a₁
        aux rfl rfl
#align psigma.rev_lex_accessible PSigma.revLex_accessible

theorem revLex_wf (ha : WellFounded r) (hb : WellFounded s) : WellFounded (RevLex r s) :=
  WellFounded.intro fun ⟨a, b⟩ => rev_lex_accessible (apply hb b) (WellFounded.apply ha) a
#align psigma.rev_lex_wf PSigma.revLex_wf

end

section

#print PSigma.SkipLeft /-
def SkipLeft (α : Type u) {β : Type v} (s : β → β → Prop) :
    (@PSigma α fun a => β) → (@PSigma α fun a => β) → Prop :=
  RevLex EmptyRelation s
#align psigma.skip_left PSigma.SkipLeft
-/

theorem skipLeft_wf (α : Type u) {β : Type v} {s : β → β → Prop} (hb : WellFounded s) :
    WellFounded (SkipLeft α s) :=
  revLex_wf empty_wf hb
#align psigma.skip_left_wf PSigma.skipLeft_wf

theorem mk_skipLeft {α : Type u} {β : Type v} {b₁ b₂ : β} {s : β → β → Prop} (a₁ a₂ : α)
    (h : s b₁ b₂) : SkipLeft α s ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ :=
  RevLex.right _ _ h
#align psigma.mk_skip_left PSigma.mk_skipLeft

end

instance hasWellFounded {α : Type u} {β : α → Type v} [s₁ : WellFoundedRelation α]
    [s₂ : ∀ a, WellFoundedRelation (β a)] : WellFoundedRelation (PSigma β)
    where
  R := Lex s₁.R fun a => (s₂ a).R
  wf := lex_wf s₁.wf fun a => (s₂ a).wf
#align psigma.has_well_founded PSigma.hasWellFounded

end PSigma


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

import algebra.big_operators.basic

/-!
# Products (respectively, sums) over a finset or a multiset.

The regular `finset.prod` and `multiset.prod` require `[comm_monoid α]`.
Often, there are collections `s : finset α` where `[monoid α]` and we know,
in a dependent fashion, that for all the terms `∀ (x ∈ s) (y ∈ s), commute x y`.
This allows to still have a well-defined product over `s`.

## Main definitions

- `finset.noncomm_prod`, requiring a proof of commutativity of held terms
- `multiset.noncomm_prod`, requiring a proof of commutativity of held terms

## Implementation details

While `list.prod` is defined via `list.foldl`, `noncomm_prod` is defined via
`multiset.foldr` for neater proofs and definitions. By the commutativity assumption,
the two must be equal.

-/

variables {α β γ : Type*} (f : α → β → β) (op : α → α → α)

namespace multiset

/-- Fold of a `s : multiset α` with `f : α → β → β`, given a proof that `left_commutative f`
on all elements `x ∈ s`. -/
def noncomm_foldr (s : multiset α) (comm : ∀ (x ∈ s) (y ∈ s) b, f x (f y b) = f y (f x b)) (b : β) :
  β :=
s.attach.foldr (f ∘ subtype.val) (λ ⟨x, hx⟩ ⟨y, hy⟩, comm x hx y hy) b

@[simp] lemma noncomm_foldr_coe (l : list α)
  (comm : ∀ (x ∈ (l : multiset α)) (y ∈ (l : multiset α)) b, f x (f y b) = f y (f x b)) (b : β) :
  noncomm_foldr f (l : multiset α) comm b = l.foldr f b :=
begin
  simp only [noncomm_foldr, coe_foldr, coe_attach, list.attach],
  rw ←list.foldr_map,
  simp [list.map_pmap, list.pmap_eq_map]
end

@[simp] lemma noncomm_foldr_empty
  (h : ∀ (x ∈ (0 : multiset α)) (y ∈ (0 : multiset α)) b, f x (f y b) = f y (f x b)) (b : β) :
  noncomm_foldr f (0 : multiset α) h b = b := rfl

lemma noncomm_foldr_cons (s : multiset α) (a : α)
  (h : ∀ (x ∈ (a ::ₘ s)) (y ∈ (a ::ₘ s)) b, f x (f y b) = f y (f x b))
  (h' : ∀ (x ∈ s) (y ∈ s) b, f x (f y b) = f y (f x b))
  (b : β) :
  noncomm_foldr f (a ::ₘ s) h b = f a (noncomm_foldr f s h' b) :=
begin
  induction s using quotient.induction_on,
  simp
end

lemma noncomm_foldr_eq_foldr (s : multiset α) (h : left_commutative f) (b : β) :
  noncomm_foldr f s (λ x _ y _, h x y) b = foldr f h b s :=
begin
  induction s using quotient.induction_on,
  simp
end

variables [assoc : is_associative α op]
include assoc

/-- Fold of a `s : multiset α` with an associative `op : α → α → α`, given a proofs that `op`
is commutative on all elements `x ∈ s`. -/
def noncomm_fold (s : multiset α)
  (comm : ∀ (x ∈ s) (y ∈ s), op x y = op y x)
  (a : α) : α :=
noncomm_foldr op s (λ x hx y hy b, by rw [←assoc.assoc, comm _ hx _ hy, assoc.assoc]) a

@[simp] lemma noncomm_fold_coe (l : list α)
  (comm : ∀ (x ∈ (l : multiset α)) (y ∈ (l : multiset α)), op x y = op y x)
  (a : α) :
  noncomm_fold op (l : multiset α) comm a = l.foldr op a :=
by simp [noncomm_fold]

@[simp] lemma noncomm_fold_empty
  (h : ∀ (x ∈ (0 : multiset α)) (y ∈ (0 : multiset α)), op x y = op y x) (a : α) :
  noncomm_fold op (0 : multiset α) h a = a := rfl

lemma noncomm_fold_cons (s : multiset α) (a : α)
  (h : ∀ (x ∈ a ::ₘ s) (y ∈ a ::ₘ s), op x y = op y x)
  (h' : ∀ (x ∈ s) (y ∈ s), op x y = op y x)
  (x : α) :
  noncomm_fold op (a ::ₘ s) h x = op a (noncomm_fold op s h' x) :=
begin
  induction s using quotient.induction_on,
  simp
end

lemma noncomm_fold_eq_fold (s : multiset α) [is_commutative α op]
  (a : α) :
  noncomm_fold op s (λ x _ y _, is_commutative.comm x y) a = fold op a s :=
begin
  induction s using quotient.induction_on,
  simp
end

omit assoc
variables [monoid α] [monoid β]

/-- Product of a `s : multiset α` with `[monoid α]`, given a proof that `*` commutes
on all elements `x ∈ s`. -/
@[to_additive "Sum of a `s : multiset α` with `[add_monoid α]`, given a proof that `+` commutes
on all elements `x ∈ s`." ]
def noncomm_prod (s : multiset α) (comm : ∀ (x ∈ s) (y ∈ s), commute x y) : α :=
s.noncomm_fold (*) comm 1

@[simp, to_additive] lemma noncomm_prod_coe (l : list α)
  (comm : ∀ (x ∈ (l : multiset α)) (y ∈ (l : multiset α)), commute x y) :
  noncomm_prod (l : multiset α) comm = l.prod :=
begin
  rw [noncomm_prod],
  simp only [noncomm_fold_coe],
  induction l with hd tl hl,
  { simp },
  { rw [list.prod_cons, list.foldr, hl],
    intros x hx y hy,
    exact comm x (list.mem_cons_of_mem _ hx) y (list.mem_cons_of_mem _ hy) }
end

@[simp, to_additive] lemma noncomm_prod_empty
  (h : ∀ (x ∈ (0 : multiset α)) (y ∈ (0 : multiset α)), commute x y) :
  noncomm_prod (0 : multiset α) h = 1 := rfl

@[simp, to_additive] lemma noncomm_prod_cons (s : multiset α) (a : α)
  (comm : ∀ (x ∈ a ::ₘ s) (y ∈ a ::ₘ s), commute x y) :
  noncomm_prod (a ::ₘ s) comm = a * noncomm_prod s
    (λ x hx y hy, comm _ (mem_cons_of_mem hx) _ (mem_cons_of_mem hy)) :=
begin
  induction s using quotient.induction_on,
  simp
end

@[to_additive] lemma noncomm_prod_cons' (s : multiset α) (a : α)
  (comm : ∀ (x ∈ a ::ₘ s) (y ∈ a ::ₘ s), commute x y) :
  noncomm_prod (a ::ₘ s) comm = noncomm_prod s
    (λ x hx y hy, comm _ (mem_cons_of_mem hx) _ (mem_cons_of_mem hy)) * a :=
begin
  induction s using quotient.induction_on with s,
  simp only [quot_mk_to_coe, cons_coe, noncomm_prod_coe, list.prod_cons],
  induction s with hd tl IH,
  { simp },
  { rw [list.prod_cons, mul_assoc, ←IH, ←mul_assoc, ←mul_assoc],
    { congr' 1,
      apply comm;
      simp },
    { intros x hx y hy,
      simp only [quot_mk_to_coe, list.mem_cons_iff, mem_coe, cons_coe] at hx hy,
      apply comm,
      { cases hx;
        simp [hx] },
      { cases hy;
        simp [hy] } } }
end

@[protected, to_additive]
lemma nocomm_prod_map_aux (s : multiset α)
  (comm : ∀ (x ∈ s) (y ∈ s), commute x y)
  {F : Type*} [monoid_hom_class F α β] (f : F) :
  ∀ (x ∈ s.map f) (y ∈ s.map f), commute x y :=
begin
  simp only [multiset.mem_map],
  rintros _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩,
  exact (comm _ hx _ hy).map f,
end

@[to_additive]
lemma noncomm_prod_map (s : multiset α) (comm : ∀ (x ∈ s) (y ∈ s), commute x y)
  {F : Type*} [monoid_hom_class F α β] (f : F) :
  f (s.noncomm_prod comm) = (s.map f).noncomm_prod (nocomm_prod_map_aux s comm f) :=
begin
  induction s using quotient.induction_on,
  simpa using map_list_prod f _,
end

@[to_additive noncomm_sum_eq_card_nsmul]
lemma noncomm_prod_eq_pow_card (s : multiset α) (comm : ∀ (x ∈ s) (y ∈ s), commute x y)
  (m : α) (h : ∀ (x ∈ s), x = m) : s.noncomm_prod comm = m ^ s.card :=
begin
  induction s using quotient.induction_on,
  simp only [quot_mk_to_coe, noncomm_prod_coe, coe_card, mem_coe] at *,
  exact list.prod_eq_pow_card _ m h,
end

@[to_additive]

@[to_additive noncomm_sum_add_commute]
lemma noncomm_prod_commute (s : multiset α)
  (comm : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → commute x y)
  (y : α) (h : ∀ (x : α), x ∈ s → commute y x) : commute y (s.noncomm_prod comm) :=
begin
  induction s using quotient.induction_on,
  simp only [quot_mk_to_coe, noncomm_prod_coe],
  exact commute.list_prod_right _ _ h,
end

end multiset

namespace finset

variables [monoid β] [monoid γ]

/-- Product of a `s : finset α` mapped with `f : α → β` with `[monoid β]`,
given a proof that `*` commutes on all elements `f x` for `x ∈ s`. -/
@[to_additive "Sum of a `s : finset α` mapped with `f : α → β` with `[add_monoid β]`,
given a proof that `+` commutes on all elements `f x` for `x ∈ s`."]
def noncomm_prod (s : finset α) (f : α → β) (comm : ∀ (x ∈ s) (y ∈ s), commute (f x) (f y)) : β :=
(s.1.map f).noncomm_prod (by simpa [multiset.mem_map, ←finset.mem_def] using comm)

@[congr, to_additive]
lemma noncomm_prod_congr
  {s₁ s₂ : finset α} {f g : α → β} (h₁ : s₁ = s₂) (h₂ : ∀ (x ∈ s₂), f x = g x)
  (comm : ∀ (x ∈ s₁) (y ∈ s₁), commute (f x) (f y)) :
  noncomm_prod s₁ f comm = noncomm_prod s₂ g
    (λ x hx y hy, h₂ x hx ▸ h₂ y hy ▸ comm x (h₁.symm ▸ hx) y (h₁.symm ▸ hy)) :=
by simp_rw [noncomm_prod, multiset.map_congr (congr_arg _ h₁) h₂]

@[simp, to_additive] lemma noncomm_prod_to_finset [decidable_eq α] (l : list α) (f : α → β)
  (comm : ∀ (x ∈ l.to_finset) (y ∈ l.to_finset), commute (f x) (f y))
  (hl : l.nodup) :
  noncomm_prod l.to_finset f comm = (l.map f).prod :=
begin
  rw ←list.dedup_eq_self at hl,
  simp [noncomm_prod, hl]
end

@[simp, to_additive] lemma noncomm_prod_empty (f : α → β)
  (h : ∀ (x ∈ (∅ : finset α)) (y ∈ (∅ : finset α)), commute (f x) (f y)) :
  noncomm_prod (∅ : finset α) f h = 1 := rfl

@[simp, to_additive] lemma noncomm_prod_insert_of_not_mem [decidable_eq α] (s : finset α) (a : α)
  (f : α → β)
  (comm : ∀ (x ∈ insert a s) (y ∈ insert a s), commute (f x) (f y))
  (ha : a ∉ s) :
  noncomm_prod (insert a s) f comm = f a * noncomm_prod s f
    (λ x hx y hy, comm _ (mem_insert_of_mem hx) _ (mem_insert_of_mem hy)) :=
by simp [insert_val_of_not_mem ha, noncomm_prod]

@[to_additive] lemma noncomm_prod_insert_of_not_mem' [decidable_eq α] (s : finset α) (a : α)
  (f : α → β)
  (comm : ∀ (x ∈ insert a s) (y ∈ insert a s), commute (f x) (f y))
  (ha : a ∉ s) :
  noncomm_prod (insert a s) f comm = noncomm_prod s f
    (λ x hx y hy, comm _ (mem_insert_of_mem hx) _ (mem_insert_of_mem hy)) * f a :=
by simp [noncomm_prod, insert_val_of_not_mem ha, multiset.noncomm_prod_cons']

@[simp, to_additive] lemma noncomm_prod_singleton (a : α) (f : α → β) :
  noncomm_prod ({a} : finset α) f
    (λ x hx y hy, by rw [mem_singleton.mp hx, mem_singleton.mp hy]) = f a :=
by simp [noncomm_prod, multiset.singleton_eq_cons]

@[to_additive]
lemma noncomm_prod_map (s : finset α) (f : α → β)
  (comm : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → commute (f x) (f y))
  {F : Type*} [monoid_hom_class F β γ] (g : F) :
  g (s.noncomm_prod f comm) = s.noncomm_prod (λ i, g (f i))
  (λ x hx y hy, (comm x hx y hy).map g)  :=
by simp [noncomm_prod, multiset.noncomm_prod_map]

@[to_additive noncomm_sum_eq_card_nsmul]
lemma noncomm_prod_eq_pow_card (s : finset α) (f : α → β)
  (comm : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → commute (f x) (f y))
  (m : β) (h : ∀ (x : α), x ∈ s → f x = m) : s.noncomm_prod f comm = m ^ s.card :=
begin
  rw [noncomm_prod, multiset.noncomm_prod_eq_pow_card _ _ m],
  simp only [finset.card_def, multiset.card_map],
  simpa using h,
end

@[to_additive noncomm_sum_add_commute]
lemma noncomm_prod_commute (s : finset α) (f : α → β)
  (comm : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → commute (f x) (f y))
  (y : β) (h : ∀ (x : α), x ∈ s → commute y (f x)) : commute y (s.noncomm_prod f comm) :=
begin
  apply multiset.noncomm_prod_commute,
  intro y,
  rw multiset.mem_map,
  rintros ⟨x, ⟨hx, rfl⟩⟩,
  exact h x hx,
end

@[to_additive] lemma noncomm_prod_eq_prod {β : Type*} [comm_monoid β] (s : finset α) (f : α → β) :
  noncomm_prod s f (λ _ _ _ _, commute.all _ _) = s.prod f :=
begin
  classical,
  induction s using finset.induction_on with a s ha IH,
  { simp },
  { simp [ha, IH] }
end

/- The non-commutative version of `finset.prod_union` -/
@[to_additive "The non-commutative version of `finset.sum_union`"]
lemma noncomm_prod_union_of_disjoint [decidable_eq α] {s t : finset α}
  (h : disjoint s t) (f : α → β)
  (comm : ∀ (x ∈ s ∪ t) (y ∈ s ∪ t), commute (f x) (f y))
  (scomm : ∀ (x ∈ s) (y ∈ s), commute (f x) (f y) :=
    λ _ hx _ hy, comm _ (mem_union_left _ hx) _ (mem_union_left _ hy))
  (tcomm : ∀ (x ∈ t) (y ∈ t), commute (f x) (f y) :=
    λ _ hx _ hy, comm _ (mem_union_right _ hx) _ (mem_union_right _ hy)) :
  noncomm_prod (s ∪ t) f comm = noncomm_prod s f scomm * noncomm_prod t f tcomm :=
begin
  obtain ⟨sl, sl', rfl⟩ := exists_list_nodup_eq s,
  obtain ⟨tl, tl', rfl⟩ := exists_list_nodup_eq t,
  rw list.disjoint_to_finset_iff_disjoint at h,
  simp [sl', tl', noncomm_prod_to_finset, ←list.prod_append, ←list.to_finset_append,
    sl'.append tl' h]
end

@[protected, to_additive]
lemma noncomm_prod_mul_distrib_aux {s : finset α} {f : α → β} {g : α → β}
  (comm_ff : ∀ (x ∈ s) (y ∈ s), commute (f x) (f y))
  (comm_gg : ∀ (x ∈ s) (y ∈ s), commute (g x) (g y))
  (comm_gf : ∀ (x ∈ s) (y ∈ s), x ≠ y → commute (g x) (f y)) :
  (∀ (x ∈ s) (y ∈ s), commute ((f * g) x) ((f * g) y)) :=
begin
  intros x hx y hy,
  by_cases h : x = y, { subst h },
  apply commute.mul_left; apply commute.mul_right,
  { exact comm_ff x hx y hy },
  { exact (comm_gf y hy x hx (ne.symm h)).symm },
  { exact comm_gf x hx y hy h },
  { exact comm_gg x hx y hy },
end

/-- The non-commutative version of `finset.prod_mul_distrib` -/
@[to_additive "The non-commutative version of `finset.sum_add_distrib`"]
lemma noncomm_prod_mul_distrib {s : finset α} (f : α → β) (g : α → β)
  (comm_ff : ∀ (x ∈ s) (y ∈ s), commute (f x) (f y))
  (comm_gg : ∀ (x ∈ s) (y ∈ s), commute (g x) (g y))
  (comm_gf : ∀ (x ∈ s) (y ∈ s), x ≠ y → commute (g x) (f y)) :
  noncomm_prod s (f * g) (noncomm_prod_mul_distrib_aux comm_ff comm_gg comm_gf)
    = noncomm_prod s f comm_ff * noncomm_prod s g comm_gg :=
begin
  classical,
  induction s using finset.induction_on with x s hnmem ih,
  { simp, },
  { simp only [finset.noncomm_prod_insert_of_not_mem _ _ _ _ hnmem],
    specialize ih
      (λ x hx y hy, comm_ff x (mem_insert_of_mem hx) y (mem_insert_of_mem hy))
      (λ x hx y hy, comm_gg x (mem_insert_of_mem hx) y (mem_insert_of_mem hy))
      (λ x hx y hy hne, comm_gf x (mem_insert_of_mem hx) y (mem_insert_of_mem hy) hne),
    rw [ih, pi.mul_apply],
    simp only [mul_assoc],
    congr' 1,
    simp only [← mul_assoc],
    congr' 1,
    apply noncomm_prod_commute,
    intros y hy,
    have : x ≠ y, by {rintro rfl, contradiction},
    exact comm_gf x (mem_insert_self x s) y (mem_insert_of_mem hy) this, }
end

section finite_pi

variables {ι : Type*} [fintype ι] [decidable_eq ι] {M : ι → Type*} [∀ i, monoid (M i)]
variables (x : Π i, M i)

@[to_additive]
lemma noncomm_prod_mul_single :
  univ.noncomm_prod (λ i, pi.mul_single i (x i)) (λ i _ j _, pi.mul_single_apply_commute x i j)
  = x :=
begin
  ext i,
  apply (univ.noncomm_prod_map (λ i, monoid_hom.single M i (x i)) _
    (pi.eval_monoid_hom M i)).trans,
  rw [ ← insert_erase (mem_univ i),
    noncomm_prod_insert_of_not_mem' _ _ _ _ (not_mem_erase _ _),
    noncomm_prod_eq_pow_card,
    one_pow],
  { simp, },
  { intros i h, simp at h, simp [h], },
end

@[to_additive]
lemma _root_.monoid_hom.pi_ext {f g : (Π i, M i) →* γ}
  (h : ∀ i x, f (pi.mul_single i x) = g (pi.mul_single i x)) :
  f = g :=
begin
  ext x,
  rw [← noncomm_prod_mul_single x, univ.noncomm_prod_map, univ.noncomm_prod_map],
  congr' 1 with i, exact h i (x i),
end

end finite_pi

end finset


namespace basics

inductive day : Type
| sunday | monday | tuesday | wednesday | thursday | friday | saturday

def next_weekday : day → day
| day.sunday := day.monday
| day.monday := day.tuesday
| day.tuesday := day.wednesday
| day.wednesday := day.thursday
| day.thursday := day.friday
| day.friday := day.monday
| day.saturday := day.monday

#reduce next_weekday day.sunday

example : next_weekday (next_weekday day.saturday) = day.tuesday := rfl

inductive bool' : Type
| tt | ff

namespace bool'

def bnot' : bool' → bool'
| tt := ff
| ff := tt

def band' : bool' → bool' → bool'
| tt tt := tt
| tt ff := ff
| ff tt := ff
| ff ff := ff

def bor' : bool' → bool' → bool'
| tt tt := tt
| tt ff := tt
| ff tt := tt
| ff ff := ff

/- bor unit tests -/
example : bor' tt ff = tt := rfl
example : bor' ff ff = ff := rfl
example : bor' ff tt = tt := rfl
example : bor' tt tt = tt := rfl

-- Exercise: 1 star (nandb)
def bnand : bool' → bool' → bool' :=
sorry -- replace `:= sorry` with your definition

lemma test_bnand1 : bnand tt ff = tt := sorry -- fill in here
lemma test_bnand2 : bnand ff ff = tt := sorry -- fill in here
lemma test_bnand3 : bnand ff tt = tt := sorry -- fill in here
lemma test_bnand4 : bnand tt tt = ff := sorry -- fill in here

-- Exercise: 1 star (band3)
def band3 (b1 : bool') (b2 : bool') (b3 : bool') : bool' :=
sorry -- replace `:= sorry` with your definition

#check bool'.tt
/- ===> tt : bool' -/
#check (bnot' tt)
/- ===> bnot' tt : bool' -/

#check bnot'
/- ===> bnot' : bool' → bool' -/

lemma test_band31: (band3 tt tt tt) = tt := sorry -- fill in here
lemma test_band32: (band3 ff tt tt) = ff := sorry -- fill in here
lemma test_band33: (band3 tt ff tt) = ff := sorry -- fill in here
lemma test_band34: (band3 tt tt ff) = ff := sorry -- fill in here

end bool'

namespace color

inductive rgb : Type
  | red : rgb
  | green : rgb
  | blue : rgb
inductive color : Type
  | black : color
  | white : color
  | primary : rgb → color

open rgb color bool'
def monochrome : color → bool'
  | black := tt
  | white := tt
  | (primary p) := ff

def isred : color → bool'
  | black := ff
  | white := ff
  | (primary red) := tt
  | (primary _)   := ff

end color

namespace nat_playground

inductive nat : Type
  | zero : nat
  | succ : nat → nat.

inductive nat' : Type
  | stop : nat'
  | tick : nat' → nat'

open nat_playground.nat
def pred : nat → nat
  | zero := zero
  | (succ n) := n

end nat_playground

/- define minustwo -/
open nat
#check succ (succ (succ (succ zero)))
/- ===> 4 : ℕ -/

def minustwo : nat → nat
  | zero := zero
  | (succ zero) := zero
  | (succ (succ n)) := n

#reduce (minustwo 4).
/- ===> 2 -/
/- end minustwo -/

def evenb : nat → bool
  | zero := true
  | (succ zero) := false
  | (succ (succ n)) := evenb n

def oddb (n:nat) : bool := bnot (evenb n)

example : oddb 1 = tt := rfl

example : oddb 4 = ff := rfl

namespace nat_playground2

def plus : nat → nat → nat
  | zero m := m
  | (succ n) m := succ (plus n m)

#reduce (plus 3 2).

/- plus eval -/
example : plus 3 2 = _ :=
calc   plus (succ (succ (succ zero))) (succ (succ zero))
     = succ (plus (succ (succ zero)) (succ (succ zero))) : rfl
                  -- by the second clause of the match
...  = succ (succ (plus (succ zero) (succ (succ zero)))) : rfl
                  -- by the second clause of the match
...  = succ (succ (succ (plus zero (succ (succ zero))))) : rfl
                  -- by the second clause of the match
...  = succ (succ (succ (succ (succ zero))))             : rfl
                  -- by the first clause of the match
/- plus eval (end) -/

def minus : nat → nat → nat
  | zero _ := zero
  | n@(succ _) zero := n
  | (succ n) (succ m) := minus n m

/- subtracted_from -/
def subtracted_from (m n : nat) : nat := minus n m

def mult (m : nat) : nat → nat
  | zero := zero
  | (succ n) := plus m (mult n)

def exp (base : nat) : nat → nat
  | zero := succ zero
  | (succ p) := mult base (exp p)

end nat_playground2

namespace nat

-- Exercise: 1 star (factorial)
def factorial : ℕ → ℕ :=
sorry -- replace `:= sorry` with your definition

lemma test_factorial1 : (factorial 3) = 6   := sorry -- fill in here
lemma test_factorial2 : (factorial 5) = 120 := sorry -- fill in here

-- | 0 := 1
-- | 1 := 1
-- | (nat.succ n) := (nat.succ n) * factorial n

section

local infixl + := nat_playground2.plus
local infixl - := nat_playground2.minus
local infixl * := nat_playground2.mult

end

def beq_nat : ℕ → ℕ → bool
| 0 0 := tt
| 0 _ := ff
| _ 0 := ff
| (nat.succ n) (nat.succ m) := beq_nat n m

def leb : ℕ → ℕ → bool
| 0 _ := tt
| (nat.succ n) 0 := ff
| (nat.succ n) (nat.succ m) := leb n m

lemma test_leb1 : leb 2 2 = tt := rfl
lemma test_leb2 : leb 2 4 = tt := rfl
lemma test_leb3 : leb 4 2 = ff := rfl

-- Exercise: 1 star (blt_nat)
def blt_nat (a b : ℕ) : bool :=
sorry -- replace `:= sorry` with your definition

lemma test_blt_nat1 : (blt_nat 2 2) = ff := sorry -- fill in here
lemma test_blt_nat2 : (blt_nat 2 4) = tt := sorry -- fill in here
lemma test_blt_nat3 : (blt_nat 4 2) = ff := sorry -- fill in here

-- Exercise: 1 star (plus_id_exercise)
theorem plus_id_exercise : ∀ n m o : ℕ, n = m → m = o → n + m = m + o :=
begin
  introv h1 h2,
  rw [h1, h2]
end

-- Exercise: 2 stars (mult_S_1)
theorem mult_S_1 : ∀ n m : ℕ, m = nat.succ n → m * (1 + n) = m * m :=
begin
  introv h1,
  rw [nat.one_add, ←h1],
end

-- Exercise: 2 stars (andb_tt_elim2)
theorem andb_tt_elim2 : ∀ b c : bool, band b c = tt → c = tt :=
begin
  introv h1,
  cases b,
    cases c,
      contradiction,
      refl,
    cases c,
      contradiction,
      refl
end

-- Exercise: 1 star (zero_nbeq_plus_1)
theorem zero_nbeq_plus_1 : ∀ n : ℕ, beq_nat 0 (n + 1) = ff :=
by intro n; refl

-- Exercise: 2 stars, optional (decreasing)
meta def fail_factorial : ℕ → ℕ
| 0 := 1
| n := n * fail_factorial (n - 1)

-- Exercise: 2 stars (boolean_functions)
theorem identity_fn_applied_twice :
  ∀ f : bool → bool, (∀ x : bool, f x = x) → ∀ b : bool, f (f b) = b :=
begin
  intros f hx x,
  rw [hx, hx]
end

end nat

theorem negation_fn_applied_twice :
  ∀ f : bool → bool, (∀ x : bool, f x = bnot x) → ∀ b : bool, f (f b) = b :=
begin
  intros f hx x,
  rw [hx, hx],
  cases x,
    refl,
    refl
end

-- Exercise: 3 stars, optional (andb_eq_orb)
theorem andb_eq_orb (b c : bool) : band b c = bor b c → b = c :=
begin
  cases b,
    cases c,
      intros; refl,
      intros; contradiction,
    cases c,
      intros; contradiction,
      intros; refl
end

-- Exercise: 3 stars (binary)
inductive bin : Type
| zero : bin
| twice : bin → bin
| omtt : bin → bin

open bin
/-
  protected def add : nat → nat → nat
  | a  zero     := a
  | a  (succ b) := succ (add a b)
-/

def incr : bin → bin
| zero := omtt zero
| (twice b) := omtt b
| (omtt b) := twice (incr b)

def bin_to_nat : bin → ℕ
| zero := 0
| (twice n) := 2 * (bin_to_nat n)
| (omtt n) := 2 * (bin_to_nat n) + 1

instance : has_coe bin ℕ := ⟨bin_to_nat⟩
instance : has_repr bin := ⟨λ b, repr $ bin_to_nat b⟩
instance : has_zero bin := ⟨zero⟩
instance : has_one bin := ⟨omtt zero⟩

lemma test_bin_incr1 : incr zero = 1 := rfl
lemma test_bin_incr2 : incr (omtt zero) = twice (omtt zero) := rfl
lemma test_bin_incr3 : incr (twice zero) = 1 := rfl
lemma test_bin_incr4 :
  incr (omtt (twice $ omtt zero)) = twice (omtt (omtt zero)) := rfl

end basics


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

import algebra.group_with_zero.power
import algebra.big_operators.order
import algebra.big_operators.ring
import algebra.big_operators.intervals
import tactic.abel
import data.nat.parity

/-!
# Partial sums of geometric series

This file determines the values of the geometric series $\sum_{i=0}^{n-1} x^i$ and
$\sum_{i=0}^{n-1} x^i y^{n-1-i}$ and variants thereof. We also provide some bounds on the
"geometric" sum of `a/b^i` where `a b : ℕ`.

## Main definitions

* `geom_sum` defines for each $x$ in a semiring and each natural number $n$ the partial sum
  $\sum_{i=0}^{n-1} x^i$ of the geometric series.
* `geom_sum₂` defines for each $x,y$ in a semiring and each natural number $n$ the partial sum
  $\sum_{i=0}^{n-1} x^i y^{n-1-i}$ of the geometric series.

## Main statements

* `geom_sum_Ico` proves that $\sum_{i=m}^{n-1} x^i=\frac{x^n-x^m}{x-1}$ in a division ring.
* `geom_sum₂_Ico` proves that $\sum_{i=m}^{n-1} x^i=\frac{x^n-y^{n-m}x^m}{x-y}$ in a field.

Several variants are recorded, generalising in particular to the case of a noncommutative ring in
which `x` and `y` commute. Even versions not using division or subtraction, valid in each semiring,
are recorded.
-/

universe u
variable {α : Type u}

open finset mul_opposite

open_locale big_operators

section semiring
variable [semiring α]

/-- Sum of the finite geometric series $\sum_{i=0}^{n-1} x^i$. -/
def geom_sum (x : α) (n : ℕ) :=
∑ i in range n, x ^ i

theorem geom_sum_def (x : α) (n : ℕ) :
  geom_sum x n = ∑ i in range n, x ^ i := rfl

lemma geom_sum_succ {x : α} {n : ℕ} : geom_sum x (n + 1) = x * geom_sum x n + 1 :=
by simp only [geom_sum_def, mul_sum, ←pow_succ, sum_range_succ', pow_zero]

lemma geom_sum_succ' {x : α} {n : ℕ} : geom_sum x (n + 1) = x ^ n + geom_sum x n :=
(sum_range_succ _ _).trans (add_comm _ _)

@[simp] theorem geom_sum_zero (x : α) :
  geom_sum x 0 = 0 := rfl

@[simp] theorem geom_sum_one (x : α) :
  geom_sum x 1 = 1 :=
by simp [geom_sum_succ']

@[simp] lemma geom_sum_two {x : α} : geom_sum x 2 = x + 1 :=
by simp [geom_sum_succ']

@[simp] lemma zero_geom_sum : ∀ {n}, geom_sum (0 : α) n = if n = 0 then 0 else 1
| 0     := by simp
| 1     := by simp
| (n+2) := by { rw geom_sum_succ', simp [zero_geom_sum] }

@[simp] lemma one_geom_sum (n : ℕ) : geom_sum (1 : α) n = n :=
by simp [geom_sum_def]

@[simp] lemma op_geom_sum (x : α) (n : ℕ) :
  op (geom_sum x n) = geom_sum (op x) n :=
by simp [geom_sum_def]

/-- Sum of the finite geometric series $\sum_{i=0}^{n-1} x^i y^{n-1-i}$. -/
def geom_sum₂ (x y : α) (n : ℕ) :=
∑ i in range n, x ^ i * (y ^ (n - 1 - i))

theorem geom_sum₂_def (x y : α) (n : ℕ) :
  geom_sum₂ x y n = ∑ i in range n, x ^ i * y ^ (n - 1 - i) := rfl

@[simp] theorem geom_sum₂_zero (x y : α) :
  geom_sum₂ x y 0 = 0 := rfl

@[simp] theorem geom_sum₂_one (x y : α) :
  geom_sum₂ x y 1 = 1 :=
by { have : 1 - 1 - 0 = 0 := rfl,
     rw [geom_sum₂_def, sum_range_one, this, pow_zero, pow_zero, mul_one] }

@[simp] lemma op_geom_sum₂ (x y : α) (n : ℕ) :
  op (geom_sum₂ x y n) = geom_sum₂ (op y) (op x) n :=
begin
  simp only [geom_sum₂_def, op_sum, op_mul, op_pow],
  rw ← sum_range_reflect,
  refine sum_congr rfl (λ j j_in, _),
  rw [mem_range, nat.lt_iff_add_one_le] at j_in,
  congr,
  apply tsub_tsub_cancel_of_le,
  exact le_tsub_of_add_le_right j_in
end

@[simp] theorem geom_sum₂_with_one (x : α) (n : ℕ) :
  geom_sum₂ x 1 n = geom_sum x n :=
sum_congr rfl (λ i _, by { rw [one_pow, mul_one] })

/-- $x^n-y^n = (x-y) \sum x^ky^{n-1-k}$ reformulated without `-` signs. -/
protected theorem commute.geom_sum₂_mul_add {x y : α} (h : commute x y) (n : ℕ) :
  (geom_sum₂ (x + y) y n) * x + y ^ n = (x + y) ^ n :=
begin
  let f := λ (m i : ℕ), (x + y) ^ i * y ^ (m - 1 - i),
  change (∑ i in range n, (f n) i) * x + y ^ n = (x + y) ^ n,
  induction n with n ih,
  { rw [range_zero, sum_empty, zero_mul, zero_add, pow_zero, pow_zero] },
  { have f_last : f (n + 1) n = (x + y) ^ n :=
     by { dsimp [f],
          rw [← tsub_add_eq_tsub_tsub, nat.add_comm, tsub_self, pow_zero, mul_one] },
    have f_succ : ∀ i, i ∈ range n → f (n + 1) i = y * f n i :=
      λ i hi, by
      { dsimp [f],
        have : commute y ((x + y) ^ i) :=
         (h.symm.add_right (commute.refl y)).pow_right i,
        rw [← mul_assoc, this.eq, mul_assoc, ← pow_succ y (n - 1 - i)],
        congr' 2,
        rw [add_tsub_cancel_right, ← tsub_add_eq_tsub_tsub, add_comm 1 i],
        have : i + 1 + (n - (i + 1)) = n := add_tsub_cancel_of_le (mem_range.mp hi),
        rw [add_comm (i + 1)] at this,
        rw [← this, add_tsub_cancel_right, add_comm i 1, ← add_assoc,
            add_tsub_cancel_right] },
    rw [pow_succ (x + y), add_mul, sum_range_succ_comm, add_mul, f_last, add_assoc],
    rw (((commute.refl x).add_right h).pow_right n).eq,
    congr' 1,
    rw [sum_congr rfl f_succ, ← mul_sum, pow_succ y, mul_assoc, ← mul_add y, ih] }
end

end semiring

@[simp] lemma neg_one_geom_sum [ring α] {n : ℕ} : geom_sum (-1 : α) n = if even n then 0 else 1 :=
begin
  induction n with k hk,
  { simp },
  { simp only [geom_sum_succ', nat.even_succ, hk],
    split_ifs,
    { rw [nat.neg_one_pow_of_even h, add_zero] },
    { rw [nat.neg_one_pow_of_odd (nat.odd_iff_not_even.mpr h), neg_add_self] } }
end

theorem geom_sum₂_self {α : Type*} [comm_ring α] (x : α) (n : ℕ) :
  geom_sum₂ x x n = n * x ^ (n-1) :=
calc  ∑ i in finset.range n, x ^ i * x ^ (n - 1 - i)
    = ∑ i in finset.range n, x ^ (i + (n - 1 - i)) : by simp_rw [← pow_add]
... = ∑ i in finset.range n, x ^ (n - 1) : finset.sum_congr rfl
  (λ i hi, congr_arg _ $ add_tsub_cancel_of_le $ nat.le_pred_of_lt $ finset.mem_range.1 hi)
... = (finset.range n).card • (x ^ (n - 1)) : finset.sum_const _
... = n * x ^ (n - 1) : by rw [finset.card_range, nsmul_eq_mul]

/-- $x^n-y^n = (x-y) \sum x^ky^{n-1-k}$ reformulated without `-` signs. -/
theorem geom_sum₂_mul_add [comm_semiring α] (x y : α) (n : ℕ) :
  (geom_sum₂ (x + y) y n) * x + y ^ n = (x + y) ^ n :=
(commute.all x y).geom_sum₂_mul_add n

theorem geom_sum_mul_add [semiring α] (x : α) (n : ℕ) :
  (geom_sum (x + 1) n) * x + 1 = (x + 1) ^ n :=
begin
  have := (commute.one_right x).geom_sum₂_mul_add n,
  rw [one_pow, geom_sum₂_with_one] at this,
  exact this
end

protected theorem commute.geom_sum₂_mul [ring α] {x y : α} (h : commute x y) (n : ℕ) :
  (geom_sum₂ x y n) * (x - y) = x ^ n - y ^ n :=
begin
  have := (h.sub_left (commute.refl y)).geom_sum₂_mul_add n,
  rw [sub_add_cancel] at this,
  rw [← this, add_sub_cancel]
end

lemma commute.mul_neg_geom_sum₂ [ring α] {x y : α} (h : commute x y) (n : ℕ) :
  (y - x) * (geom_sum₂ x y n) = y ^ n - x ^ n :=
begin
  apply op_injective,
  simp only [op_mul, op_sub, op_geom_sum₂, op_pow],
  exact (commute.op h.symm).geom_sum₂_mul n
end

lemma commute.mul_geom_sum₂ [ring α] {x y : α} (h : commute x y) (n : ℕ) :
  (x - y) * (geom_sum₂ x y n) = x ^ n - y ^ n :=
by rw [← neg_sub (y ^ n), ← h.mul_neg_geom_sum₂, ← neg_mul_eq_neg_mul_symm, neg_sub]

theorem geom_sum₂_mul [comm_ring α] (x y : α) (n : ℕ) :
  (geom_sum₂ x y n) * (x - y) = x ^ n - y ^ n :=
(commute.all x y).geom_sum₂_mul n

theorem geom_sum_mul [ring α] (x : α) (n : ℕ) :
  (geom_sum x n) * (x - 1) = x ^ n - 1 :=
begin
  have := (commute.one_right x).geom_sum₂_mul n,
  rw [one_pow, geom_sum₂_with_one] at this,
  exact this
end

lemma mul_geom_sum [ring α] (x : α) (n : ℕ) :
  (x - 1) * (geom_sum x n) = x ^ n - 1 :=
op_injective $ by simpa using geom_sum_mul (op x) n

theorem geom_sum_mul_neg [ring α] (x : α) (n : ℕ) :
  (geom_sum x n) * (1 - x) = 1 - x ^ n :=
begin
  have := congr_arg has_neg.neg (geom_sum_mul x n),
  rw [neg_sub, ← mul_neg_eq_neg_mul_symm, neg_sub] at this,
  exact this
end

lemma mul_neg_geom_sum [ring α] (x : α) (n : ℕ) :
  (1 - x) * (geom_sum x n) = 1 - x ^ n :=
op_injective $ by simpa using geom_sum_mul_neg (op x) n

protected theorem commute.geom_sum₂ [division_ring α] {x y : α} (h' : commute x y) (h : x ≠ y)
  (n : ℕ) : (geom_sum₂ x y n) = (x ^ n - y ^ n) / (x - y) :=
have x - y ≠ 0, by simp [*, -sub_eq_add_neg, sub_eq_iff_eq_add] at *,
by rw [← h'.geom_sum₂_mul, mul_div_cancel _ this]

theorem geom₂_sum [field α] {x y : α} (h : x ≠ y) (n : ℕ) :
  (geom_sum₂ x y n) = (x ^ n - y ^ n) / (x - y) :=
(commute.all x y).geom_sum₂ h n

theorem geom_sum_eq [division_ring α] {x : α} (h : x ≠ 1) (n : ℕ) :
  (geom_sum x n) = (x ^ n - 1) / (x - 1) :=
have x - 1 ≠ 0, by simp [*, -sub_eq_add_neg, sub_eq_iff_eq_add] at *,
by rw [← geom_sum_mul, mul_div_cancel _ this]

protected theorem commute.mul_geom_sum₂_Ico [ring α] {x y : α} (h : commute x y) {m n : ℕ}
  (hmn : m ≤ n) :
  (x - y) * (∑ i in finset.Ico m n, x ^ i * y ^ (n - 1 - i)) = x ^ n - x ^ m * y ^ (n - m) :=
begin
  rw [sum_Ico_eq_sub _ hmn, ← geom_sum₂_def],
  have : ∑ k in range m, x ^ k * y ^ (n - 1 - k)
    = ∑ k in range m, x ^ k * (y ^ (n - m) * y ^ (m - 1 - k)),
  { refine sum_congr rfl (λ j j_in, _),
    rw ← pow_add,
    congr,
    rw [mem_range, nat.lt_iff_add_one_le, add_comm] at j_in,
    have h' : n - m + (m - (1 + j)) = n - (1 + j) := tsub_add_tsub_cancel hmn j_in,
    rw [← tsub_add_eq_tsub_tsub m, h', ← tsub_add_eq_tsub_tsub] },
  rw this,
  simp_rw pow_mul_comm y (n-m) _,
  simp_rw ← mul_assoc,
  rw [← sum_mul, ← geom_sum₂_def, mul_sub, h.mul_geom_sum₂, ← mul_assoc,
    h.mul_geom_sum₂, sub_mul, ← pow_add, add_tsub_cancel_of_le hmn,
    sub_sub_sub_cancel_right (x ^ n) (x ^ m * y ^ (n - m)) (y ^ n)],
end

protected theorem commute.geom_sum₂_succ_eq {α : Type u} [ring α] {x y : α}
  (h : commute x y) {n : ℕ} :
  geom_sum₂ x y (n + 1) = x ^ n + y * (geom_sum₂ x y n) :=
begin
  simp_rw [geom_sum₂, mul_sum, sum_range_succ_comm, nat.add_succ_sub_one, add_zero, tsub_self,
    pow_zero, mul_one, add_right_inj, ←mul_assoc, (h.symm.pow_right _).eq, mul_assoc, ←pow_succ],
  refine sum_congr rfl (λ i hi, _),
  suffices : n - 1 - i + 1 = n - i, { rw this },
  cases n,
  { exact absurd (list.mem_range.mp hi) i.not_lt_zero },
  { rw [tsub_add_eq_add_tsub (nat.le_pred_of_lt (list.mem_range.mp hi)),
        tsub_add_cancel_of_le (nat.succ_le_iff.mpr n.succ_pos)] },
end

theorem geom_sum₂_succ_eq {α : Type u} [comm_ring α] (x y : α)  {n : ℕ} :
  geom_sum₂ x y (n + 1) = x ^ n + y * (geom_sum₂ x y n) :=
(commute.all x y).geom_sum₂_succ_eq

theorem mul_geom_sum₂_Ico [comm_ring α] (x y : α) {m n : ℕ} (hmn : m ≤ n) :
  (x - y) * (∑ i in finset.Ico m n, x ^ i * y ^ (n - 1 - i)) = x ^ n - x ^ m * y ^ (n - m) :=
(commute.all x y).mul_geom_sum₂_Ico hmn

protected theorem commute.geom_sum₂_Ico_mul [ring α] {x y : α} (h : commute x y) {m n : ℕ}
  (hmn : m ≤ n) :
  (∑ i in finset.Ico m n, x ^ i * y ^ (n - 1 - i)) * (x - y) = x ^ n -  y ^ (n - m) * x ^ m :=
begin
  apply op_injective,
  simp only [op_sub, op_mul, op_pow, op_sum],
  have : ∑ k in Ico m n, op y ^ (n - 1 - k) * op x ^ k
    = ∑ k in Ico m n, op x ^ k * op y ^ (n - 1 - k),
  { refine sum_congr rfl (λ k k_in, _),
    apply commute.pow_pow (commute.op h.symm) },
  rw this,
  exact (commute.op h).mul_geom_sum₂_Ico hmn
end

theorem geom_sum_Ico_mul [ring α] (x : α) {m n : ℕ} (hmn : m ≤ n) :
  (∑ i in finset.Ico m n, x ^ i) * (x - 1) = x^n - x^m :=
by rw [sum_Ico_eq_sub _ hmn, ← geom_sum_def, ← geom_sum_def, sub_mul,
  geom_sum_mul, geom_sum_mul, sub_sub_sub_cancel_right]

theorem geom_sum_Ico_mul_neg [ring α] (x : α) {m n : ℕ} (hmn : m ≤ n) :
  (∑ i in finset.Ico m n, x ^ i) * (1 - x) = x^m - x^n :=
by rw [sum_Ico_eq_sub _ hmn, ← geom_sum_def, ← geom_sum_def, sub_mul,
  geom_sum_mul_neg, geom_sum_mul_neg, sub_sub_sub_cancel_left]

protected theorem commute.geom_sum₂_Ico [division_ring α] {x y : α} (h : commute x y) (hxy : x ≠ y)
  {m n : ℕ} (hmn : m ≤ n) :
  ∑ i in finset.Ico m n, x ^ i * y ^ (n - 1 - i) = (x ^ n - y ^ (n - m) * x ^ m ) / (x - y) :=
have x - y ≠ 0, by simp [*, -sub_eq_add_neg, sub_eq_iff_eq_add] at *,
by rw [← h.geom_sum₂_Ico_mul hmn, mul_div_cancel _ this]

theorem geom_sum₂_Ico [field α] {x y : α} (hxy : x ≠ y) {m n : ℕ} (hmn : m ≤ n) :
  ∑ i in finset.Ico m n, x ^ i * y ^ (n - 1 - i) = (x ^ n - y ^ (n - m) * x ^ m ) / (x - y) :=
(commute.all x y).geom_sum₂_Ico hxy hmn

theorem geom_sum_Ico [division_ring α] {x : α} (hx : x ≠ 1) {m n : ℕ} (hmn : m ≤ n) :
  ∑ i in finset.Ico m n, x ^ i = (x ^ n - x ^ m) / (x - 1) :=
by simp only [sum_Ico_eq_sub _ hmn, (geom_sum_def _ _).symm, geom_sum_eq hx, div_sub_div_same,
  sub_sub_sub_cancel_right]

theorem geom_sum_Ico' [division_ring α] {x : α} (hx : x ≠ 1) {m n : ℕ} (hmn : m ≤ n) :
  ∑ i in finset.Ico m n, x ^ i = (x ^ m - x ^ n) / (1 - x) :=
by { simp only [geom_sum_Ico hx hmn], convert neg_div_neg_eq (x^m - x^n) (1-x); abel }

lemma geom_sum_inv [division_ring α] {x : α} (hx1 : x ≠ 1) (hx0 : x ≠ 0) (n : ℕ) :
  (geom_sum x⁻¹ n) = (x - 1)⁻¹ * (x - x⁻¹ ^ n * x) :=
have h₁ : x⁻¹ ≠ 1, by rwa [inv_eq_one_div, ne.def, div_eq_iff_mul_eq hx0, one_mul],
have h₂ : x⁻¹ - 1 ≠ 0, from mt sub_eq_zero.1 h₁,
have h₃ : x - 1 ≠ 0, from mt sub_eq_zero.1 hx1,
have h₄ : x * (x ^ n)⁻¹ = (x ^ n)⁻¹ * x :=
  nat.rec_on n (by simp)
  (λ n h, by rw [pow_succ, mul_inv_rev₀, ←mul_assoc, h, mul_assoc, mul_inv_cancel hx0, mul_assoc,
    inv_mul_cancel hx0]),
begin
  rw [geom_sum_eq h₁, div_eq_iff_mul_eq h₂, ← mul_right_inj' h₃,
    ← mul_assoc, ← mul_assoc, mul_inv_cancel h₃],
  simp [mul_add, add_mul, mul_inv_cancel hx0, mul_assoc, h₄, sub_eq_add_neg, add_comm,
    add_left_comm],
end

variables {β : Type*}

theorem ring_hom.map_geom_sum [semiring α] [semiring β] (x : α) (n : ℕ) (f : α →+* β) :
  f (geom_sum x n) = geom_sum (f x) n :=
by simp [geom_sum_def, f.map_sum]

theorem ring_hom.map_geom_sum₂ [semiring α] [semiring β] (x y : α) (n : ℕ) (f : α →+* β) :
  f (geom_sum₂ x y n) = geom_sum₂ (f x) (f y) n :=
by simp [geom_sum₂_def, f.map_sum]

/-! ### Geometric sum with `ℕ`-division -/

lemma nat.pred_mul_geom_sum_le (a b n : ℕ) :
  (b - 1) * ∑ i in range n.succ, a/b^i ≤ a * b - a/b^n :=
calc
  (b - 1) * (∑ i in range n.succ, a/b^i)
      = ∑ i in range n, a/b^(i + 1) * b + a * b
        - (∑ i in range n, a/b^i + a/b^n)
      : by rw [tsub_mul, mul_comm, sum_mul, one_mul, sum_range_succ',
          sum_range_succ, pow_zero, nat.div_one]
  ... ≤ ∑ i in range n, a/b^i + a * b - (∑ i in range n, a/b^i + a/b^n)
      : begin
        refine tsub_le_tsub_right (add_le_add_right (sum_le_sum $ λ i _, _) _) _,
        rw [pow_succ', ←nat.div_div_eq_div_mul],
        exact nat.div_mul_le_self _ _,
      end
  ... = a * b - a/b^n : add_tsub_add_eq_tsub_left _ _ _

lemma nat.geom_sum_le {b : ℕ} (hb : 2 ≤ b) (a n : ℕ) :
  ∑ i in range n, a/b^i ≤ a * b/(b - 1) :=
begin
  refine (nat.le_div_iff_mul_le _ _ $ tsub_pos_of_lt hb).2 _,
  cases n,
  { rw [sum_range_zero, zero_mul],
    exact nat.zero_le _ },
  rw mul_comm,
  exact (nat.pred_mul_geom_sum_le a b n).trans tsub_le_self,
end

lemma nat.geom_sum_Ico_le {b : ℕ} (hb : 2 ≤ b) (a n : ℕ) :
  ∑ i in Ico 1 n, a/b^i ≤ a/(b - 1) :=
begin
  cases n,
  { rw [Ico_eq_empty_of_le zero_le_one, sum_empty],
    exact nat.zero_le _ },
  rw ←add_le_add_iff_left a,
  calc
    a + ∑ (i : ℕ) in Ico 1 n.succ, a/b^i
        = a/b^0 + ∑ (i : ℕ) in Ico 1 n.succ, a/b^i : by rw [pow_zero, nat.div_one]
    ... = ∑ i in range n.succ, a/b^i : begin
          rw [range_eq_Ico, ←nat.Ico_insert_succ_left (nat.succ_pos _), sum_insert],
          exact λ h, zero_lt_one.not_le (mem_Ico.1 h).1,
        end
    ... ≤ a * b/(b - 1) : nat.geom_sum_le hb a _
    ... = (a * 1 + a * (b - 1))/(b - 1)
        : by rw [←mul_add, add_tsub_cancel_of_le (one_le_two.trans hb)]
    ... = a + a/(b - 1)
        : by rw [mul_one, nat.add_mul_div_right _ _ (tsub_pos_of_lt hb), add_comm]
end

section order

variables {n : ℕ} {x : α}

lemma geom_sum_pos [ordered_semiring α] (hx : 0 < x) (hn : n ≠ 0) : 0 < geom_sum x n :=
begin
  refine nat.le_induction _ _ _ (show 1 ≤ n, from hn.bot_lt),
  { simp [@@zero_lt_one _ (nontrivial_of_lt _ _ hx)] },
  intros k hk,
  rw [geom_sum_succ'],
  apply add_pos (pow_pos hx _)
end

lemma geom_sum_pos_and_lt_one [ordered_ring α] (hx : x < 0) (hx' : 0 < x + 1) (hn : 1 < n) :
  0 < geom_sum x n ∧ geom_sum x n < 1 :=
begin
  refine nat.le_induction _ _ n (show 2 ≤ n, from hn),
  { rw geom_sum_two,
    exact ⟨hx', (add_lt_iff_neg_right _).2 hx⟩ },
  clear hn n,
  intros n hn ihn,
  rw [geom_sum_succ, add_lt_iff_neg_right, ← neg_lt_iff_pos_add', neg_mul_eq_neg_mul],
  exact ⟨mul_lt_one_of_nonneg_of_lt_one_left (neg_nonneg.2 hx.le)
    (neg_lt_iff_pos_add'.2 hx') ihn.2.le, mul_neg_of_neg_of_pos hx ihn.1⟩
end

lemma geom_sum_alternating_of_lt_neg_one [ordered_ring α] (hx : x + 1 < 0) (hn : 1 < n) :
  if even n then geom_sum x n < 0 else 1 < geom_sum x n  :=
begin
  have hx0 : x < 0, from ((le_add_iff_nonneg_right _).2 (@zero_le_one α _)).trans_lt hx,
  refine nat.le_induction _ _ n (show 2 ≤ n, from hn),
  { simp only [geom_sum_two, hx, true_or, nat.even_bit0, if_true_left_eq_or] },
  clear hn n,
  intros n hn ihn,
  simp only [nat.even_succ, geom_sum_succ],
  by_cases hn' : even n,
  { rw [if_pos hn'] at ihn, rw [if_neg, lt_add_iff_pos_left],
    exact mul_pos_of_neg_of_neg hx0 ihn, exact not_not_intro hn', },
  { rw [if_neg hn'] at ihn, rw [if_pos], swap, { exact hn' },
    have := add_lt_add_right (mul_lt_mul_of_neg_left ihn hx0) 1,
    rw mul_one at this,
    exact this.trans hx }
end

lemma geom_sum_pos_of_odd [linear_ordered_ring α] (h : odd n) :
  0 < geom_sum x n :=
begin
  rcases n with (_ | _ | k),
  { exact ((show ¬ odd 0, from dec_trivial) h).elim },
  { simp only [geom_sum_one, zero_lt_one] },
  rw nat.odd_iff_not_even at h,
  rcases lt_trichotomy (x + 1) 0 with hx | hx | hx,
  { have := geom_sum_alternating_of_lt_neg_one hx k.one_lt_succ_succ,
    simp only [h, if_false] at this,
    exact zero_lt_one.trans this },
  { simp only [eq_neg_of_add_eq_zero hx, h, neg_one_geom_sum, if_false, zero_lt_one] },
  rcases lt_trichotomy x 0 with hx' | rfl | hx',
  { exact (geom_sum_pos_and_lt_one hx' hx k.one_lt_succ_succ).1 },
  { simp only [zero_geom_sum, nat.succ_ne_zero, if_false, zero_lt_one] },
  { exact geom_sum_pos hx' (by simp only [nat.succ_ne_zero, ne.def, not_false_iff]) }
end

lemma geom_sum_pos_iff [linear_ordered_ring α] (hn : 1 < n) :
  0 < geom_sum x n ↔ odd n ∨ 0 < x + 1 :=
begin
  refine ⟨λ h, _, _⟩,
  { suffices : ¬ 0 < x + 1 → odd n, by tauto,
    intro hx,
    rw not_lt at hx,
    contrapose! h,
    rw [←nat.even_iff_not_odd] at h,
    rcases hx.eq_or_lt with hx | hx,
    { rw [←neg_neg (1 : α), add_neg_eq_iff_eq_add, zero_add] at hx,
      simp only [hx, neg_one_geom_sum, h, if_true] },
    apply le_of_lt,
    simpa [h] using geom_sum_alternating_of_lt_neg_one hx hn },
  { rintro (hn | hx'),
    { exact geom_sum_pos_of_odd hn },
    rcases lt_trichotomy x 0 with hx | rfl | hx,
    { exact (geom_sum_pos_and_lt_one hx hx' hn).1 },
    { simp only [(zero_lt_one.trans hn).ne', zero_geom_sum, if_false, zero_lt_one] },
    { exact geom_sum_pos hx (zero_lt_one.trans hn).ne' } }
end

lemma geom_sum_eq_zero_iff_neg_one [linear_ordered_ring α] (hn : 1 < n) :
  geom_sum x n = 0 ↔ x = -1 ∧ even n :=
begin
  refine ⟨λ h, _, λ ⟨h, hn⟩, by simp only [h, hn, neg_one_geom_sum, if_true]⟩,
  contrapose! h,
  rcases eq_or_ne x (-1) with rfl | h,
  { simp only [h rfl, neg_one_geom_sum, if_false, ne.def, not_false_iff, one_ne_zero] },
  rw [ne.def, eq_neg_iff_add_eq_zero, ←ne.def] at h,
  rcases h.lt_or_lt with h | h,
  { have := geom_sum_alternating_of_lt_neg_one h hn,
    split_ifs at this,
    { exact this.ne },
    { exact (zero_lt_one.trans this).ne' } },
  apply ne_of_gt,
  rcases lt_trichotomy x 0 with h' | rfl | h',
  { exact (geom_sum_pos_and_lt_one h' h hn).1 },
  { simp only [(pos_of_gt hn).ne', zero_geom_sum, if_false, zero_lt_one] },
  { exact geom_sum_pos h' (pos_of_gt hn).ne' }
end

lemma geom_sum_neg_iff [linear_ordered_ring α] (hn : 1 < n) :
  geom_sum x n < 0 ↔ even n ∧ x + 1 < 0 :=
by rw [← not_iff_not, not_lt, le_iff_lt_or_eq, eq_comm,
       or_congr (geom_sum_pos_iff hn) (geom_sum_eq_zero_iff_neg_one hn), nat.odd_iff_not_even,
       ← add_eq_zero_iff_eq_neg, not_and, not_lt, le_iff_lt_or_eq, eq_comm,
       ← imp_iff_not_or, or_comm, and_comm, decidable.and_or_imp, or_comm]

end order


import tactic
import data.finset

-----------------------------------------------------------------
---------------------     helpers   -----------------------------

def subtract_emb (c:ℤ) : ℤ ↪ ℤ := ⟨λx:ℤ, x-c, begin
  intros,
  unfold function.injective,
  show ∀ x y : ℤ, x-c = y-c → x = y, by omega,
end⟩

lemma lt_of_le_ne (a b : ℤ) (h1 : a ≤ b) (h2 : a ≠ b) : (a < b)
:=
begin
  cases lt_trichotomy a b,
    show a < b, by assumption,
  cases h,
    by contradiction,
    omega,
end

---------------------     helpers   -----------------------------
-----------------------------------------------------------------
------------------   finset operations   ------------------------

lemma finset_rest {s : finset ℤ} {x : ℤ} (x_in_s : x ∈ s) :
  ∃ r : finset ℤ, s.val = x::r.val
:=
begin
  cases (@multiset.exists_cons_of_mem ℤ s.val x x_in_s) with r_ms r_h,
  have s_nodup : multiset.nodup (x::r_ms), begin
    rw ←r_h, exact s.nodup
  end,
  have : r_ms.nodup, exact (multiset.nodup_cons.elim_left s_nodup).2,
  let r : finset ℤ := ⟨r_ms, this⟩,
  show ∃ (r : finset ℤ), s.val = x :: r.val, from ⟨r, r_h⟩
end

lemma finset_cons_subset {s : finset ℤ} {s2 : finset ℤ} {x:ℤ}
  (h : s.val = x::s2.val) : s2 ⊂ s
:=
begin
  apply finset.val_lt_iff.elim_left,
  rw h,
  show s2.val < x :: s2.val, from multiset.lt_cons_self s2.val x,
end

theorem sum_filter_split {p : ℤ → Prop} [decidable_pred p] (s : finset ℤ) :
  s.card = (s.filter p).card + (s.filter (λa, ¬ p a)).card
:=
begin
  let s1 := s.filter p,
  let s2 := s.filter (λa, ¬ p a),
  have inter_empty : s1 ∩ s2 = ∅,
    by exact finset.filter_inter_filter_neg_eq s,
  have union_full : s1 ∪ s2 = s,
    by exact finset.filter_union_filter_neg_eq s,
  have : (s1 ∪ s2).card + (s1 ∩ s2).card = s1.card + s2.card,
    by apply finset.card_union_add_card_inter,
  rw [inter_empty, finset.card_empty, add_zero] at this,
  show s.card = s1.card + s2.card,
  rw ←union_full,
  show (s1 ∪ s2).card = s1.card + s2.card, from this
end

------------------   finset operations   ------------------------
-----------------------------------------------------------------
-----------------    handling prefixes   ------------------------

lemma cons_prefix (x : ℤ) (a : list ℤ) : [x] <+: x::a
:=
begin
  have : [x] = list.take 1 (x::a), by simp,
  rw this,
  show list.take 1 (x :: a) <+: x :: a, by apply list.take_prefix,
end

lemma prefix_one_eq {x : ℤ} {y : ℤ} {l : list ℤ}
  (h1 : [x] <+: l) (h2 : [y] <+: l)
  : x = y
:=
begin
  have xy : [x] <+: [y] := list.prefix_of_prefix_length_le h1 h2 (by simp),
  have : [x] = [y], from list.eq_of_prefix_of_length_eq xy (by simp),
  simp at this,
  show x = y, from this,
end

lemma prefix_eq_head {x y : ℤ} {a b : list ℤ}
  (h : list.cons x a ∈ (list.cons y b).inits)
  : x = y
:=
begin
  have pref : x::a <+: y::b, from (list.mem_inits (x::a) (y::b)).1 h,
  have xxa : [x] <+: x::a, by apply cons_prefix,
  have yyb : [y] <+: y::b, by apply cons_prefix,
  have xyb : [x] <+: y::b, from list.is_prefix.trans xxa pref,
  show x = y, from prefix_one_eq xyb yyb,
end

lemma prefix_tail_prefix {x y : ℤ} {a b : list ℤ}
  (h : list.cons x a ∈ (list.cons y b).inits)
  : a ∈ b.inits
:=
begin
  have : x = y, from prefix_eq_head h,
  rw ←this at h,
  have : x::a <+: x::b, from (list.mem_inits (x::a) (x::b)).1 h,
  have : a <+: b, from (list.prefix_cons_inj x).1 this,
  show a ∈ b.inits, from (list.mem_inits a b).2 this,
end

-----------------    handling prefixes   ------------------------
-----------------------------------------------------------------
-------------    sum of positive integers   ---------------------

lemma l_nonneg_sum {l : list ℤ} (h1 : ∀ x ∈ l, (0:ℤ) < x)
  : l.sum ≥ 0
:=
begin
  induction l,
    show [].sum ≥ (0:ℤ), by simp,
    show list.sum (l_hd :: l_tl) ≥ (0:ℤ),
    have : list.sum (l_hd :: l_tl) = l_hd + l_tl.sum, by simp,
    rw this,
    show l_hd + l_tl.sum ≥ 0,
    have : l_hd ≥ 0, begin
      apply le_of_lt,
      apply h1,
      show l_hd ∈ list.cons l_hd l_tl, by apply list.mem_cons_self,
    end,
    have : l_tl.sum ≥ 0, begin
      apply l_ih,
      assume (x:ℤ) (tl_in : x ∈ l_tl),
      show 0 < x,
      apply h1,
      apply list.mem_cons_of_mem,
      show x ∈ l_tl, by assumption,
    end,
    omega,
end

lemma pref_nonneg_sum {jumps : finset ℤ} {jumps_l : list ℤ} {jumps_pref : list ℤ}
  (h1 : ∀ jump ∈ jumps, (0:ℤ) < jump) (h2 : jumps.val = jumps_l)
  (h3 : jumps_pref ∈ jumps_l.inits)
  : jumps_pref.sum ≥ 0
:=
begin
  apply l_nonneg_sum,
  assume (jump:ℤ) (h : jump ∈ jumps_pref),
  apply h1,
  show jump ∈ jumps,
  apply finset.mem_def.2,
  rw h2,
  show jump ∈ jumps_l,
  have : jumps_pref ⊆ jumps_l, begin
    apply list.subset_of_sublist,
    apply list.sublist_of_prefix,
    apply (list.mem_inits jumps_pref jumps_l).1,
    show jumps_pref ∈ jumps_l.inits, from h3,
  end,
  apply (list.subset_def.1 this),
  show jump ∈ jumps_pref, from h,
end

-------------    sum of positive integers   ---------------------
-----------------------------------------------------------------
-----------------    the main theorem   -------------------------

theorem grasshopper :
  forall n : ℕ,
  forall jumps : finset ℤ,
  (forall jump ∈ jumps, (0:ℤ) < jump) →
  (jumps.card = n) →
  let size := jumps.1.sum in
  forall mines : finset ℤ,
  (mines.card < n) →
  (forall mine ∈ mines, (0:ℤ) < mine ∧ mine < size)
  →
  exists jumps_l : list ℤ,
  jumps.1 = jumps_l ∧
  forall jumps_pref ∈ jumps_l.inits,
  list.sum jumps_pref ∉ mines
:=
begin
  assume n,
  induction n with n n_ih, -- zero case is trivial
    intros,
    have : mines.card < 0, by assumption,
    have : ¬mines.card < 0, by apply nat.not_lt_zero,
    contradiction,
  intros, -- inductive case

  -- Take the maximal jump
  have : jumps.nonempty, by simp [a_1, finset.card_pos.elim_left],
  cases finset.max_of_nonempty this with maxjump maxjump_ex,
  have maxjump_in : maxjump ∈ jumps, by exact finset.mem_of_max maxjump_ex,
  cases finset_rest maxjump_in with jumps_res jumps_res_ex,

  -- Remove the maximal jump, partial plugging into IH
  have : jumps_res ⊆ jumps, from and.elim_left (finset_cons_subset jumps_res_ex),
  have jumps_res_pos : ∀ jump ∈ jumps_res, (0:ℤ) < jump, begin
    intro jump,
    assume h : jump ∈ jumps_res,
    have : jump ∈ jumps, from finset.mem_of_subset this h,
    show 0 < jump, from a jump this,
  end,
  have n_ih := n_ih jumps_res jumps_res_pos begin
    show jumps_res.card = n,
    apply nat.succ_inj,
    rw ←a_1,
    show jumps_res.card.succ = jumps.card,
    have : (maxjump :: jumps_res.val).card = jumps_res.val.card + 1,
      by apply multiset.card_cons,
    rw ←jumps_res_ex at this,
    exact eq.symm this,
  end,

  -- Calculate the remaining size
  let size_res := jumps_res.1.sum,
  have size_res_eq : size_res = size - maxjump, begin
    show multiset.sum jumps_res.val = multiset.sum jumps.val - maxjump,
    rw jumps_res_ex,
    rw multiset.sum_cons,
    ring,
  end,

  -- Shift the mines by maxjump to the left
  let mines_smaller := finset.filter (λ(x:ℤ), x < maxjump) mines,
  let mines_bigger := finset.filter (λ(x:ℤ), ¬x < maxjump) mines,
  have parts_size : mines.card = mines_smaller.card + mines_bigger.card,
    by apply sum_filter_split,
  let mines_sub := finset.map (subtract_emb maxjump) mines_bigger,
  have mines_sub_rev : ∀ mine ∈ mines_sub, mine + maxjump ∈ mines ∧ 0 ≤ mine, begin
    intros,
    cases finset.mem_map.elim_left H with mine_ori mine_ori_prop,
    cases mine_ori_prop with mine_ori_in_bigger mine_ori_def,
    show mine + maxjump ∈ mines ∧ 0 ≤ mine, rw [←mine_ori_def],
    show mine_ori - maxjump + maxjump ∈ mines ∧ 0 ≤ mine_ori - maxjump,
    apply and.intro, begin
      simp,
      show mine_ori ∈ mines,
      apply finset.mem_of_subset,
        show mine_ori ∈ mines_bigger, by assumption,
        show mines_bigger ⊆ mines, by simp,
    end, begin
      show 0 ≤ mine_ori - maxjump,
      have : ¬(mine_ori < maxjump), from (finset.mem_filter.1 mine_ori_in_bigger).2,
      omega,
    end
  end,
  have mines_sub_small : ∀ mine ∈ mines_sub, mine < size_res, begin
    intros,
    have : mine + maxjump ∈ mines, from (mines_sub_rev mine H).1,
    have : mine + maxjump < size, from (a_3 (mine + maxjump) this).2,
    show mine < size_res, by omega,
  end,

  ------------------------------------------
  ---------- case analysis

  cases (classical.em (maxjump ∈ mines))
    with mine_on_maxjump mine_not_on_maxjump,
  -- case A: first jump to mine
  begin
    sorry,
  end,
  -- cases C and B
    have mines_sub_positive : ∀ mine ∈ mines_sub, (0:ℤ) < mine, begin
      assume (mine : ℤ) (mine_in : mine ∈ mines_sub),
      apply lt_of_le_ne,
        show 0 ≤ mine, from (mines_sub_rev mine mine_in).2,
        show 0 ≠ mine, begin
          assume mine_zero : 0 = mine,
          have : mine + maxjump ∈ mines, from (mines_sub_rev mine mine_in).1,
          simp [←mine_zero] at this,
          contradiction,
        end
    end,
    cases (classical.em mines_smaller.nonempty)
      with mines_smaller_nonempty mines_smaller_empty,
  -- case C: we jump over a mine with the first jump
  begin

    have : mines_sub.card < n, begin
      have : mines_sub.card = mines_bigger.card,
        by apply finset.card_map,
      rw this,
      have : finset.card mines_smaller > 0,
        by exact finset.card_pos.2 mines_smaller_nonempty,
      have smaller_ge : 1 ≤ finset.card mines_smaller, exact nat.succ_le_iff.2 this,
      rw parts_size at a_2,
      have : finset.card mines_smaller + finset.card mines_bigger ≤ n,
        from nat.lt_succ_iff.1 a_2,
      show mines_bigger.card < n, from calc
        mines_bigger.card < mines_bigger.card + 1 : by apply nat.lt_succ_self
          ...             ≤ mines_bigger.card + mines_smaller.card :
                                     by apply add_le_add_left smaller_ge
          ...             = mines_smaller.card + mines_bigger.card : by apply nat.add_comm
          ...             ≤ n : this
    end,

    -- plug mines_sub to the IH, and get jumps_l_ind, jumps_l_ind_prop
    cases n_ih mines_sub this begin
      show ∀ (mine : ℤ), mine ∈ mines_sub → 0 < mine ∧ mine < size_res,
      assume (mine : ℤ) (mine_in : mine ∈ mines_sub),
      apply and.intro,
      show 0 < mine, from mines_sub_positive mine mine_in,
      show mine < size_res, from mines_sub_small mine mine_in
    end with jumps_l_ind jumps_l_ind_prop,

    let jumps_l : list ℤ := maxjump::jumps_l_ind,
    apply exists.intro jumps_l,
    apply and.intro,
      show jumps.val = ↑(maxjump :: jumps_l_ind),
        by simp [jumps_res_ex, jumps_l_ind_prop.1],
      show ∀ jumps_pref ∈ jumps_l.inits, list.sum jumps_pref ∉ mines,
        intros,
        cases jumps_pref,
          -- jumps_pref empty
          assume : (0:ℤ) ∈ mines,
          show false, from lt_irrefl (0:ℤ) (a_3 (0:ℤ) this).1,
          -- jumps_pref nonempty
          have : jumps_pref_hd = maxjump, from prefix_eq_head H,
          rw this,
          have : list.sum (maxjump :: jumps_pref_tl) = maxjump + jumps_pref_tl.sum,
            by simp,
          rw this,
          assume in_mines : maxjump + jumps_pref_tl.sum ∈ mines,
          have pref_tl_in_inits : jumps_pref_tl ∈ jumps_l_ind.inits,
            from prefix_tail_prefix H,
          have not_in_mines_sub: jumps_pref_tl.sum ∉ mines_sub,
            from jumps_l_ind_prop.2 jumps_pref_tl pref_tl_in_inits,
          have : ¬(maxjump + jumps_pref_tl.sum) < maxjump, begin
            have jumps_tl_sum_ge : jumps_pref_tl.sum ≥ (0:ℤ),
              from pref_nonneg_sum jumps_res_pos jumps_l_ind_prop.1 pref_tl_in_inits,
            have : maxjump + (0:ℤ) ≤ maxjump + jumps_pref_tl.sum,
              from add_le_add_left jumps_tl_sum_ge maxjump,
            omega,
          end,
          have in_mines_bigger : maxjump + jumps_pref_tl.sum ∈ mines_bigger,
            by simp [in_mines, this],
          have : (subtract_emb maxjump) (maxjump + jumps_pref_tl.sum) = jumps_pref_tl.sum,
            by apply add_sub_cancel',
          have : jumps_pref_tl.sum ∈ mines_sub, begin
            apply finset.mem_map.2,
            apply exists.intro (maxjump + jumps_pref_tl.sum),
            apply exists.intro in_mines_bigger,
            exact this,
          end,
          contradiction,
  end,
  -- case B: all mines are far away
  begin
    sorry,
  end
end

-----------------    the main theorem   -------------------------
-----------------------------------------------------------------


/-
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
-/
import data.set.lattice
import tactic.wlog

/-!
# Set enumeration

This file allows enumeration of sets given a choice function.

The definition does not assume `sel` actually is a choice function, i.e. `sel s ∈ s` and
`sel s = none ↔ s = ∅`. These assumptions are added to the lemmas needing them.
-/

noncomputable theory

open function

namespace set

section enumerate
parameters {α : Type*} (sel : set α → option α)

/-- Given a choice function `sel`, enumerates the elements of a set in the order
`a 0 = sel s`, `a 1 = sel (s \ {a 0})`, `a 2 = sel (s \ {a 0, a 1})`, ... and stops when
`sel (s \ {a 0, ..., a n}) = none`. Note that we don't require `sel` to be a choice function. -/
def enumerate : set α → ℕ → option α
| s 0       := sel s
| s (n + 1) := do a ← sel s, enumerate (s \ {a}) n

lemma enumerate_eq_none_of_sel {s : set α} (h : sel s = none) : ∀ {n}, enumerate s n = none
| 0       := by simp [h, enumerate]; refl
| (n + 1) := by simp [h, enumerate]; refl

lemma enumerate_eq_none : ∀ {s n₁ n₂}, enumerate s n₁ = none → n₁ ≤ n₂ → enumerate s n₂ = none
| s 0       m := λ h _, enumerate_eq_none_of_sel h
| s (n + 1) m := λ h hm,
  begin
    cases hs : sel s,
    { exact enumerate_eq_none_of_sel sel hs },
    { cases m,
      case nat.zero
      { have : n + 1 = 0, from nat.eq_zero_of_le_zero hm,
        contradiction },
      case nat.succ : m'
      { simp [hs, enumerate] at h ⊢,
        have hm : n ≤ m', from nat.le_of_succ_le_succ hm,
        exact enumerate_eq_none h hm } }
  end

lemma enumerate_mem (h_sel : ∀ s a, sel s = some a → a ∈ s) :
  ∀ {s n a}, enumerate s n = some a → a ∈ s
| s 0 a     := h_sel s a
| s (n+1) a :=
  begin
    cases h : sel s,
    case none { simp [enumerate_eq_none_of_sel, h] },
    case some : a'
    { simp [enumerate, h],
      exact λ h' : enumerate _ (s \ {a'}) n = some a,
        have a ∈ s \ {a'}, from enumerate_mem h',
        this.left }
  end

lemma enumerate_inj {n₁ n₂ : ℕ} {a : α} {s : set α} (h_sel : ∀ s a, sel s = some a → a ∈ s)
  (h₁ : enumerate s n₁ = some a) (h₂ : enumerate s n₂ = some a) : n₁ = n₂ :=
begin
  wlog hn : n₁ ≤ n₂,
  { rcases nat.le.dest hn with ⟨m, rfl⟩, clear hn,
    induction n₁ generalizing s,
    case nat.zero
    { cases m,
      case nat.zero { refl },
      case nat.succ : m
      { have : enumerate sel (s \ {a}) m = some a, { simp [enumerate, *] at * },
        have : a ∈ s \ {a}, from enumerate_mem _ h_sel this,
        by simpa } },
    case nat.succ { cases h : sel s; simp [enumerate, nat.add_succ, add_comm, *] at *; tauto } }
end

end enumerate

end set


/-
Copyright (c) 2014 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Ported from Coq HoTT
Theorems about the types equiv and is_equiv
-/

import .fiber .arrow ..arity ..prop_trunc ..cubical.square .pointed
universes u v w
hott_theory
namespace hott

open is_trunc hott.sigma hott.pi fiber hott.equiv

namespace is_equiv
  variables {A : Type _} {B : Type _} (f : A → B) [H : is_equiv f]
  include H
  /- is_equiv f is a mere proposition -/
  @[hott, instance] def is_contr_fiber_of_is_equiv (b : B) : is_contr (fiber f b) :=
  is_contr.mk
    (fiber.mk (f⁻¹ᶠ b) (right_inv f b))
    (λz, fiber.rec_on z (λa p,
      fiber_eq ((ap f⁻¹ᶠ p)⁻¹ ⬝ left_inv f a) (calc
        right_inv f b = (ap (f ∘ f⁻¹ᶠ) p)⁻¹ ⬝ ((ap (f ∘ f⁻¹ᶠ) p) ⬝ right_inv f b)
                                                            : by rwr inv_con_cancel_left
      ... = (ap (f ∘ f⁻¹ᶠ) p)⁻¹ ⬝ (right_inv f (f a) ⬝ p)   : by rwr [ap_con_eq_con (right_inv f)]
      ... = (ap (f ∘ f⁻¹ᶠ) p)⁻¹ ⬝ (ap f (left_inv f a) ⬝ p) : by rwr [adj f]
      ... = (ap (f ∘ f⁻¹ᶠ) p)⁻¹ ⬝ ap f (left_inv f a) ⬝ p   : by rwr con.assoc
      ... = (ap f (ap f⁻¹ᶠ p))⁻¹ ⬝ ap f (left_inv f a) ⬝ p  : by rwr ap_compose
      ... = ap f (ap f⁻¹ᶠ p)⁻¹ ⬝ ap f (left_inv f a) ⬝ p    : by rwr ap_inv
      ... = ap f ((ap f⁻¹ᶠ p)⁻¹ ⬝ left_inv f a) ⬝ p         : by rwr ap_con)))

  @[hott] def is_contr_right_inverse : is_contr (Σ(g : B → A), f ∘ g ~ id) :=
  begin
    fapply is_trunc_equiv_closed,
      {exact Σ(g : B → A), f ∘ g = id},
      {apply sigma_equiv_sigma_right, intro g, apply eq_equiv_homotopy},
    fapply is_trunc_equiv_closed,
      {exact fiber (λ(g : B → A), f ∘ g) id},
      {apply fiber.sigma_char},
    have : is_equiv (λ(g : B → A), f ∘ g) :=
      (to_is_equiv (arrow_equiv_arrow_right B (equiv.mk f H))),
    exactI is_contr_fiber_of_is_equiv _ _
  end

  @[hott] def is_contr_right_coherence (u : Σ(g : B → A), f ∘ g ~ id)
    : is_contr (Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a)) :=
  begin
    fapply is_trunc_equiv_closed_rev -2
      (sigma_pi_equiv_pi_sigma (λa (ηa : (u.1 ∘ f) a = a), u.2 (f a) = ap f ηa)),
    fapply is_trunc_equiv_closed -2,
      {apply pi_equiv_pi_right, intro a,
        apply (fiber_eq_equiv (fiber.mk (u.1 (f a)) (u.2 (f a))) (fiber.mk a idp))},
    apply_instance
  end

  omit H

  @[hott] protected def sigma_char : (is_equiv f) ≃
  (Σ(g : B → A) (ε : f ∘ g ~ id) (η : g ∘ f ~ id), Π(a : A), ε (f a) = ap f (η a)) :=
  equiv.MK (λH, by exactI ⟨inv f, right_inv f, left_inv f, adj f⟩)
           (λp, is_equiv.mk f p.1 p.2.1 p.2.2.1 p.2.2.2)
           (λp, begin
                  induction p with p1 p2,
                  induction p2 with p21 p22,
                  induction p22 with p221 p222,
                  reflexivity
                end)
           (λH, by induction H; reflexivity)

  @[hott] protected def sigma_char' : (is_equiv f) ≃
  (Σ(u : Σ(g : B → A), f ∘ g ~ id) (η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a)) :=
  calc
    (is_equiv f) ≃
      (Σ(g : B → A) (ε : f ∘ g ~ id) (η : g ∘ f ~ id), Π(a : A), ε (f a) = ap f (η a))
          : is_equiv.sigma_char _
    ... ≃ (Σ(u : Σ(g : B → A), f ∘ g ~ id), Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a))
          : sigma_assoc_equiv (λ(u : Σ(g : B → A), f ∘ g ~ id), Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a))

  local attribute [instance] [priority 1600] is_contr_right_inverse
  local attribute [instance] [priority 1600] is_contr_right_coherence

  @[hott, instance] theorem is_prop_is_equiv : is_prop (is_equiv f) :=
  begin
    apply is_prop_of_imp_is_contr,
    intro H, apply is_trunc_equiv_closed_rev -2 (is_equiv.sigma_char' _),
    exactI is_trunc_sigma _ _,
  end

  @[hott] def inv_eq_inv {A B : Type _} {f f' : A → B} {Hf : is_equiv f} {Hf' : is_equiv f'}
    (p : f = f') : f⁻¹ᶠ = f'⁻¹ᶠ :=
  apd011 inv p (is_prop.elimo _ _ _)

  /- contractible fibers -/
  @[hott] def is_contr_fun_of_is_equiv [H : is_equiv f] : is_contr_fun f :=
  is_contr_fiber_of_is_equiv f

  @[hott] def is_prop_is_contr_fun (f : A → B) : is_prop (is_contr_fun f) := by apply_instance

  @[hott] def is_equiv_of_is_contr_fun (f : A → B) [H : is_contr_fun f] : is_equiv f :=
  adjointify _ (λb, point (center (fiber f b)))
               (λb, point_eq (center (fiber f b)))
               (λa, ap point (center_eq (fiber.mk a idp)))

  @[hott] def is_equiv_of_imp_is_equiv (H : B → is_equiv f) : is_equiv f :=
  @is_equiv_of_is_contr_fun _ _ f (λb, @is_contr_fiber_of_is_equiv _ _ _ (H b) _)

  @[hott] def is_equiv_equiv_is_contr_fun (f : A → B) : is_equiv f ≃ is_contr_fun f :=
  begin
    apply equiv_of_is_prop,
      intro H, exactI is_contr_fun_of_is_equiv f,
      intro H, exactI is_equiv_of_is_contr_fun f,
  end

  @[hott] theorem inv_commute'_fn {A : Type _} {B C : A → Type _} (f : Π{a}, B a → C a) [H : Πa, is_equiv (@f a)]
    {g : A → A} (h : Π{a}, B a → B (g a)) (h' : Π{a}, C a → C (g a))
    (p : Π⦃a : A⦄ (b : B a), f (h b) = h' (f b)) {a : A} (b : B a) :
    inv_commute' @f @h @h' p (f b)
      = (ap f⁻¹ᶠ (p b))⁻¹ ⬝ left_inv f (h b) ⬝ (ap h (left_inv f b))⁻¹ :=
  begin
    dsimp [inv_commute',eq_of_fn_eq_fn'],
    rwr [ap_con,ap_con,←adj_inv f,con.assoc,con.assoc,con.assoc,inv_con_cancel_left,
       adj f,ap_inv,ap_inv,ap_inv,←ap_compose,←ap_compose,
       eq_bot_of_square (natural_square_tr (λb, (left_inv f (h b))⁻¹ᵖ ⬝ ap f⁻¹ᶠ (p b)) (left_inv f b))⁻¹ʰ, con_inv,eq.inv_inv,con.assoc,con.assoc,con.assoc,con.assoc,con.assoc],
    apply whisker_left, apply whisker_left, refine _ ⬝ con_idp _, apply whisker_left,
    rwr [con_inv_cancel_left,con.left_inv]
  end

end is_equiv

/- Moving equivalences around in homotopies -/
namespace is_equiv
  variables {A : Type _} {B : Type _} {C : Type _} (f : A → B) [Hf : is_equiv f]

  include Hf

  section pre_compose
  variables (α : A → C) (β : B → C)

  -- homotopy_inv_of_homotopy_pre is in init.equiv
  @[hott] protected def inv_homotopy_of_homotopy_pre.is_equiv
    : is_equiv (inv_homotopy_of_homotopy_pre f α β) :=
  adjointify _ (homotopy_of_inv_homotopy_pre f α β)
  begin abstract {
    intro q, apply eq_of_homotopy, intro b,
    dsimp [inv_homotopy_of_homotopy_pre, homotopy_of_inv_homotopy_pre],
    apply inverse, apply eq_bot_of_square,
    apply eq_hconcat (ap02 α (adj_inv f b)),
    apply eq_hconcat (ap_compose α _ (right_inv f b))⁻¹ᵖ,
    apply natural_square q (right_inv f b) } end
  begin abstract {
    intro p, apply eq_of_homotopy, intro a,
    dsimp [inv_homotopy_of_homotopy_pre, homotopy_of_inv_homotopy_pre],
    refine con.assoc' _ _ _ ⬝ _,
    apply inverse, apply eq_bot_of_square,
    refine hconcat_eq _ (ap02 β (adj f a))⁻¹,
    refine hconcat_eq _ (ap_compose β f (left_inv f a)),
    apply natural_square p (left_inv f a) } end
  end pre_compose

  section post_compose
  variables (α : C → A) (β : C → B)

  -- homotopy_inv_of_homotopy_post is in init.equiv
  @[hott] protected def inv_homotopy_of_homotopy_post.is_equiv
    : is_equiv (inv_homotopy_of_homotopy_post f α β) :=
  adjointify _ (homotopy_of_inv_homotopy_post f α β)
  begin abstract {
    intro q, apply eq_of_homotopy, intro c,
    dsimp [inv_homotopy_of_homotopy_post, homotopy_of_inv_homotopy_post],
    refine (whisker_right (left_inv f (α c)) (ap_con _ _ _ ⬝ whisker_right _ (ap_inv _ _))) ⬝ _,
    apply inverse, apply eq_bot_of_square,
    apply eq_hconcat (adj_inv f (β c))⁻¹,
    apply eq_vconcat (ap_compose' f⁻¹ᶠ _ _),
    refine vconcat_eq _ (ap_id (q c)),
    apply natural_square_tr (left_inv f) (q c)
   } end
  begin abstract {
    intro p, apply eq_of_homotopy, intro c,
    dsimp [inv_homotopy_of_homotopy_post, homotopy_of_inv_homotopy_post],
    refine (whisker_left _ (ap_con f (ap f⁻¹ᶠ (p c)) (left_inv f (α c)))) ⬝ _,
    refine con.assoc' _ _ _ ⬝ _,
    apply inverse, apply eq_bot_of_square,
    refine hconcat_eq _ (adj f (α c)),
    apply eq_vconcat (ap_compose f f⁻¹ᶠ (p c))⁻¹,
    refine vconcat_eq _ (ap_id (p c)),
    apply natural_square_tr (right_inv f) (p c)
  } end

  end post_compose

end is_equiv

namespace is_equiv

  /- @[hott] theorem 4.7.7 -/
  variables {A : Type _} {P : A → Type _} {Q : A → Type _}
  variable (f : Πa, P a → Q a)

  @[hott, reducible] def is_fiberwise_equiv := Πa, is_equiv (f a)

  @[hott] def is_equiv_total_of_is_fiberwise_equiv [H : is_fiberwise_equiv f] : is_equiv (total f) :=
  is_equiv_sigma_functor id f

  @[hott] def is_fiberwise_equiv_of_is_equiv_total [H : is_equiv (total f)]
    : is_fiberwise_equiv f :=
  begin
    intro a,
    have : is_contr_fun (f a),
    { intro q, apply is_trunc_equiv_closed, exact (fiber_total_equiv f q), apply_instance },
    exactI is_equiv_of_is_contr_fun _,
  end

end is_equiv

namespace equiv
  open hott.is_equiv
  variables {A : Type _} {B : Type _} {C : Type _}

  @[hott] def equiv_mk_eq {f f' : A → B} [H : is_equiv f] [H' : is_equiv f'] (p : f = f')
      : equiv.mk f H = equiv.mk f' H' :=
  apd011 equiv.mk p (is_prop.elimo _ _ _)

  @[hott] def equiv_eq' {f f' : A ≃ B} (p : to_fun f = to_fun f') : f = f' :=
  by induction f; induction f'; apply (equiv_mk_eq p)

  @[hott] def equiv_eq {f f' : A ≃ B} (p : to_fun f ~ to_fun f') : f = f' :=
  by apply equiv_eq'; apply eq_of_homotopy p

  @[hott] def trans_symm (f : A ≃ B) (g : B ≃ C) : (f ⬝e g)⁻¹ᵉ = g⁻¹ᵉ ⬝e f⁻¹ᵉ :> (C ≃ A) :=
  equiv_eq' idp

  @[hott] def symm_symm (f : A ≃ B) : f⁻¹ᵉ⁻¹ᵉ = f :> (A ≃ B) :=
  equiv_eq' idp

  @[hott] protected def equiv.sigma_char
    (A : Type u) (B : Type v) : (A ≃ B) ≃ Σ(f : A → B), is_equiv f :=
  begin
    fapply equiv.MK,
      {intro F, exact ⟨to_fun F, to_is_equiv F⟩},
      {intro p, cases p with f H, exact (equiv.mk f H)},
      {intro p, cases p, exact idp},
      {intro F, cases F, exact idp},
  end

  @[hott] def equiv_eq_char (f f' : A ≃ B) : (f = f') ≃ (to_fun f = to_fun f') :=
  calc
    (f = f') ≃ (to_fun (equiv.sigma_char _ _) f = to_fun (equiv.sigma_char _ _) f')
                : eq_equiv_fn_eq (to_fun (equiv.sigma_char _ _)) _ _
         ... ≃ ((to_fun (equiv.sigma_char _ _) f).1 = (to_fun (equiv.sigma_char _ _) f').1 ) : (equiv_subtype _ _)⁻¹ᵉ
         ... ≃ (to_fun f = to_fun f') : equiv.rfl

  @[hott] def is_equiv_ap_to_fun (f f' : A ≃ B)
    : is_equiv (ap to_fun : f = f' → to_fun f = to_fun f') :=
  begin
    fapply adjointify,
      { intro p, induction f with f H, induction f' with f' H', dsimp at p, induction p, apply ap (mk f), apply is_prop.elim },
      { intro p, cases f with f H, cases f' with f' H', dsimp at p, induction p,
        apply @concat _ _ (ap to_fun (ap (equiv.mk f) (is_prop.elim H H'))), refl,
        hgeneralize : is_prop.elim H H' = q, induction q, apply idp },
      { intro p, induction p, cases f with f H, dsimp,
        refine ap02 (equiv.mk f) (is_set.elim _ idp) }
  end

  @[hott] def equiv_pathover {A : Type _} {a a' : A} (p : a = a')
    {B : A → Type _} {C : A → Type _} (f : B a ≃ C a) (g : B a' ≃ C a')
    (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[p] g b') : f =[p; λa, B a ≃ C a] g :=
  begin
    refine pathover_of_fn_pathover_fn (λa, equiv.sigma_char _ _) _,
    fapply sigma_pathover, apply arrow_pathover, exact r, apply is_prop.elimo
  end

  @[hott] def is_contr_equiv (A B : Type _) [HA : is_contr A] [HB : is_contr B] : is_contr (A ≃ B) :=
  begin
    apply is_contr_of_inhabited_prop _, apply is_prop.mk,
    intros x y, cases x with fx Hx, cases y with fy Hy,
    have : fx = fy, apply eq_of_homotopy, intro a, apply is_prop.elim, induction this,
    have : Hx = Hy, apply is_prop.elim, induction this, refl,
    apply equiv_of_is_contr_of_is_contr
  end

  @[hott] def is_trunc_succ_equiv (n : ℕ₋₂) (A B : Type _)
  [HA : is_trunc n.+1 A] [HB : is_trunc n.+1 B] : is_trunc n.+1 (A ≃ B) :=
  @is_trunc_equiv_closed _ _ n.+1 (equiv.symm (equiv.sigma_char _ _))
  (@is_trunc_sigma _ _ _ _ (λ f, is_trunc_succ_of_is_prop _ _))

  @[hott] def is_trunc_equiv (n : ℕ₋₂) (A B : Type _)
  [HA : is_trunc n A] [HB : is_trunc n B] : is_trunc n (A ≃ B) :=
  begin unfreezeI, cases n, exactI is_contr_equiv _ _, apply is_trunc_succ_equiv _ _ end

  @[hott] def eq_of_fn_eq_fn'_idp {A B : Type _} (f : A → B) [is_equiv f] (x : A)
    : eq_of_fn_eq_fn' f (idpath (f x)) = idpath x :=
  con.left_inv _

  @[hott] def eq_of_fn_eq_fn'_con {A B : Type _} (f : A → B) [is_equiv f] {x y z : A}
    (p : f x = f y) (q : f y = f z)
    : eq_of_fn_eq_fn' f (p ⬝ q) = eq_of_fn_eq_fn' f p ⬝ eq_of_fn_eq_fn' f q :=
  begin
    dsimp [eq_of_fn_eq_fn'],
    refine _ ⬝ con.assoc _ _ _, apply whisker_right,
    refine _ ⬝ (con.assoc _ _ _)⁻¹, refine _ ⬝ (con.assoc _ _ _)⁻¹, apply whisker_left,
    refine ap_con _ _ _ ⬝ _, apply whisker_left,
    refine (con_inv_cancel_left _ _)⁻¹
  end

end equiv
end hott


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Alena Gusakov
-/
import data.fintype.basic
import algebra.geom_sum

/-!
# Colex

We define the colex ordering for finite sets, and give a couple of important
lemmas and properties relating to it.

The colex ordering likes to avoid large values - it can be thought of on
`finset ℕ` as the "binary" ordering. That is, order A based on
`∑_{i ∈ A} 2^i`.
It's defined here in a slightly more general way, requiring only `has_lt α` in
the definition of colex on `finset α`. In the context of the Kruskal-Katona
theorem, we are interested in particular on how colex behaves for sets of a
fixed size. If the size is 3, colex on ℕ starts
123, 124, 134, 234, 125, 135, 235, 145, 245, 345, ...

## Main statements
* `colex.hom_lt_iff`: strictly monotone functions preserve colex
* Colex order properties - linearity, decidability and so on.
* `forall_lt_of_colex_lt_of_forall_lt`: if A < B in colex, and everything
  in B is < t, then everything in A is < t. This confirms the idea that
  an enumeration under colex will exhaust all sets using elements < t before
  allowing t to be included.
* `sum_two_pow_le_iff_lt`: colex for α = ℕ is the same as binary
  (this also proves binary expansions are unique)

## Notation
We define `<` and `≤` to denote colex ordering, useful in particular when
multiple orderings are available in context.

## Tags
colex, colexicographic, binary

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

-/

variable {α : Type*}

open finset
open_locale big_operators

/--
We define this type synonym to refer to the colexicographic ordering on finsets
rather than the natural subset ordering.
-/
@[derive inhabited]
def finset.colex (α) := finset α

/--
A convenience constructor to turn a `finset α` into a `finset.colex α`, useful in order to
use the colex ordering rather than the subset ordering.
-/
def finset.to_colex {α} (s : finset α) : finset.colex α := s

@[simp]
lemma colex.eq_iff (A B : finset α) :
  A.to_colex = B.to_colex ↔ A = B := iff.rfl

/--
`A` is less than `B` in the colex ordering if the largest thing that's not in both sets is in B.
In other words, max (A Δ B) ∈ B (if the maximum exists).
-/
instance [has_lt α] : has_lt (finset.colex α) :=
⟨λ (A B : finset α), ∃ (k : α), (∀ {x}, k < x → (x ∈ A ↔ x ∈ B)) ∧ k ∉ A ∧ k ∈ B⟩

/-- We can define (≤) in the obvious way. -/
instance [has_lt α] : has_le (finset.colex α) :=
⟨λ A B, A < B ∨ A = B⟩

lemma colex.lt_def [has_lt α] (A B : finset α) :
  A.to_colex < B.to_colex ↔ ∃ k, (∀ {x}, k < x → (x ∈ A ↔ x ∈ B)) ∧ k ∉ A ∧ k ∈ B :=
iff.rfl
lemma colex.le_def [has_lt α] (A B : finset α) :
  A.to_colex ≤ B.to_colex ↔ A.to_colex < B.to_colex ∨ A = B :=
iff.rfl

/-- If everything in `A` is less than `k`, we can bound the sum of powers. -/
lemma nat.sum_two_pow_lt {k : ℕ} {A : finset ℕ} (h₁ : ∀ {x}, x ∈ A → x < k) :
  A.sum (pow 2) < 2^k :=
begin
  apply lt_of_le_of_lt (sum_le_sum_of_subset (λ t, mem_range.2 ∘ h₁)),
  have z := geom_sum_mul_add 1 k,
  rw [geom_sum, mul_one, one_add_one_eq_two] at z,
  rw ← z,
  apply nat.lt_succ_self,
end

namespace colex

/-- Strictly monotone functions preserve the colex ordering. -/
lemma hom_lt_iff {β : Type*} [linear_order α] [decidable_eq β] [preorder β]
  {f : α → β} (h₁ : strict_mono f) (A B : finset α) :
  (A.image f).to_colex < (B.image f).to_colex ↔ A.to_colex < B.to_colex :=
begin
  simp only [colex.lt_def, not_exists, mem_image, exists_prop, not_and],
  split,
  { rintro ⟨k, z, q, k', _, rfl⟩,
    exact ⟨k', λ x hx, by simpa [h₁.injective.eq_iff] using z (h₁ hx), λ t, q _ t rfl, ‹k' ∈ B›⟩ },
  rintro ⟨k, z, ka, _⟩,
  refine ⟨f k, λ x hx, _, _, k, ‹k ∈ B›, rfl⟩,
  { split,
    any_goals
    { rintro ⟨x', hx', rfl⟩,
      refine ⟨x', _, rfl⟩,
      rwa ← z _ <|> rwa z _,
      rwa strict_mono.lt_iff_lt h₁ at hx } },
  { simp only [h₁.injective, function.injective.eq_iff],
    exact λ x hx, ne_of_mem_of_not_mem hx ka }
end

/-- A special case of `colex.hom_lt_iff` which is sometimes useful. -/
@[simp] lemma hom_fin_lt_iff {n : ℕ} (A B : finset (fin n)) :
  (A.image (λ i : fin n, (i : ℕ))).to_colex < (B.image (λ i : fin n, (i : ℕ))).to_colex
   ↔ A.to_colex < B.to_colex :=
colex.hom_lt_iff (λ x y k, k) _ _

instance [has_lt α] : is_irrefl (finset.colex α) (<) :=
⟨λ A h, exists.elim h (λ _ ⟨_,a,b⟩, a b)⟩

@[trans]
lemma lt_trans [linear_order α] {a b c : finset.colex α} :
  a < b → b < c → a < c :=
begin
  rintros ⟨k₁, k₁z, notinA, inB⟩ ⟨k₂, k₂z, notinB, inC⟩,
  cases lt_or_gt_of_ne (ne_of_mem_of_not_mem inB notinB),
  { refine ⟨k₂, _, by rwa k₁z h, inC⟩,
    intros x hx,
    rw ← k₂z hx,
    apply k₁z (trans h hx) },
  { refine ⟨k₁, _, notinA, by rwa ← k₂z h⟩,
    intros x hx,
    rw k₁z hx,
    apply k₂z (trans h hx) }
end

@[trans]
lemma le_trans [linear_order α] (a b c : finset.colex α) :
  a ≤ b → b ≤ c → a ≤ c :=
λ AB BC, AB.elim (λ k, BC.elim (λ t, or.inl (lt_trans k t)) (λ t, t ▸ AB)) (λ k, k.symm ▸ BC)

instance [linear_order α] : is_trans (finset.colex α) (<) := ⟨λ _ _ _, colex.lt_trans⟩

lemma lt_trichotomy [linear_order α] (A B : finset.colex α) :
  A < B ∨ A = B ∨ B < A :=
begin
  by_cases h₁ : (A = B),
  { tauto },
  rcases (exists_max_image (A \ B ∪ B \ A) id _) with ⟨k, hk, z⟩,
  { simp only [mem_union, mem_sdiff] at hk,
    cases hk,
    { right,
      right,
      refine ⟨k, λ t th, _, hk.2, hk.1⟩,
      specialize z t,
      by_contra h₂,
      simp only [mem_union, mem_sdiff, id.def] at z,
      rw [not_iff, iff_iff_and_or_not_and_not, not_not, and_comm] at h₂,
      apply not_le_of_lt th (z h₂) },
    { left,
      refine ⟨k, λ t th, _, hk.2, hk.1⟩,
      specialize z t,
      by_contra h₃,
      simp only [mem_union, mem_sdiff, id.def] at z,
      rw [not_iff, iff_iff_and_or_not_and_not, not_not, and_comm, or_comm] at h₃,
      apply not_le_of_lt th (z h₃) }, },
  rw nonempty_iff_ne_empty,
  intro a,
  simp only [union_eq_empty_iff, sdiff_eq_empty_iff_subset] at a,
  apply h₁ (subset.antisymm a.1 a.2)
end

instance [linear_order α] : is_trichotomous (finset.colex α) (<) := ⟨lt_trichotomy⟩

instance decidable_lt [linear_order α] : ∀ {A B : finset.colex α}, decidable (A < B) :=
show ∀ A B : finset α, decidable (A.to_colex < B.to_colex),
from λ A B, decidable_of_iff'
  (∃ (k ∈ B), (∀ x ∈ A ∪ B, k < x → (x ∈ A ↔ x ∈ B)) ∧ k ∉ A)
  begin
    rw colex.lt_def,
    apply exists_congr,
    simp only [mem_union, exists_prop, or_imp_distrib, and_comm (_ ∈ B), and_assoc],
    intro k,
    refine and_congr_left' (forall_congr _),
    tauto,
  end

instance [linear_order α] : linear_order (finset.colex α) :=
{ le_refl := λ A, or.inr rfl,
  le_trans := le_trans,
  le_antisymm := λ A B AB BA, AB.elim (λ k, BA.elim (λ t, (asymm k t).elim) (λ t, t.symm)) id,
  le_total := λ A B,
          (lt_trichotomy A B).elim3 (or.inl ∘ or.inl) (or.inl ∘ or.inr) (or.inr ∘ or.inl),
  decidable_le := λ A B, by apply_instance,
  decidable_lt := λ A B, by apply_instance,
  decidable_eq := λ A B, by apply_instance,
  lt_iff_le_not_le := λ A B,
  begin
    split,
    { intro t,
      refine ⟨or.inl t, _⟩,
      rintro (i | rfl),
      { apply asymm_of _ t i },
      { apply irrefl _ t } },
    rintro ⟨h₁ | rfl, h₂⟩,
    { apply h₁ },
    apply h₂.elim (or.inr rfl),
  end,
  ..finset.colex.has_lt,
  ..finset.colex.has_le }

/-- The instances set up let us infer that `colex.lt` is a strict total order. -/
example [linear_order α] : is_strict_total_order (finset.colex α) (<) := infer_instance

/-- Strictly monotone functions preserve the colex ordering. -/
lemma hom_le_iff {β : Type*} [linear_order α] [linear_order β]
  {f : α → β} (h₁ : strict_mono f) (A B : finset α) :
  (A.image f).to_colex ≤ (B.image f).to_colex ↔ A.to_colex ≤ B.to_colex :=
by rw [le_iff_le_iff_lt_iff_lt, hom_lt_iff h₁]

/-- A special case of `colex_hom` which is sometimes useful. -/
@[simp] lemma hom_fin_le_iff {n : ℕ} (A B : finset (fin n)) :
  (A.image (λ i : fin n, (i : ℕ))).to_colex ≤ (B.image (λ i : fin n, (i : ℕ))).to_colex
   ↔ A.to_colex ≤ B.to_colex :=
colex.hom_le_iff (λ x y k, k) _ _

/--
If `A` is before `B` in colex, and everything in `B` is small, then everything in `A` is small.
-/
lemma forall_lt_of_colex_lt_of_forall_lt [linear_order α] {A B : finset α}
  (t : α) (h₁ : A.to_colex < B.to_colex) (h₂ : ∀ x ∈ B, x < t) :
  ∀ x ∈ A, x < t :=
begin
  rw colex.lt_def at h₁,
  rcases h₁ with ⟨k, z, _, _⟩,
  intros x hx,
  apply lt_of_not_ge,
  intro a,
  refine not_lt_of_ge a (h₂ x _),
  rwa ← z,
  apply lt_of_lt_of_le (h₂ k ‹_›) a,
end

/-- `s.to_colex < {r}.to_colex` iff all elements of `s` are less than `r`. -/
lemma lt_singleton_iff_mem_lt [linear_order α] {r : α} {s : finset α} :
  s.to_colex < ({r} : finset α).to_colex ↔ ∀ x ∈ s, x < r :=
begin
  simp only [lt_def, mem_singleton, ←and_assoc, exists_eq_right],
  split,
  { intros t x hx,
    rw ←not_le,
    intro h,
    rcases lt_or_eq_of_le h with h₁ | rfl,
    { exact ne_of_irrefl h₁ ((t.1 h₁).1 hx).symm },
    { exact t.2 hx } },
  { exact λ h, ⟨λ z hz, ⟨λ i, (asymm hz (h _ i)).elim, λ i, (hz.ne' i).elim⟩, by simpa using h r⟩ }
end

/-- If {r} is less than or equal to s in the colexicographical sense,
  then s contains an element greater than or equal to r. -/
lemma mem_le_of_singleton_le [linear_order α] {r : α} {s : finset α}:
  ({r} : finset α).to_colex ≤ s.to_colex ↔ ∃ x ∈ s, r ≤ x :=
by { rw ←not_lt, simp [lt_singleton_iff_mem_lt] }

/-- Colex is an extension of the base ordering on α. -/
lemma singleton_lt_iff_lt [linear_order α] {r s : α} :
  ({r} : finset α).to_colex < ({s} : finset α).to_colex ↔ r < s :=
by simp [lt_singleton_iff_mem_lt]

/-- Colex is an extension of the base ordering on α. -/
lemma singleton_le_iff_le [linear_order α] {r s : α} :
  ({r} : finset α).to_colex ≤ ({s} : finset α).to_colex ↔ r ≤ s :=
by rw [le_iff_le_iff_lt_iff_lt, singleton_lt_iff_lt]

/-- Colex doesn't care if you remove the other set -/
@[simp] lemma sdiff_lt_sdiff_iff_lt [has_lt α] [decidable_eq α] (A B : finset α) :
  (A \ B).to_colex < (B \ A).to_colex ↔ A.to_colex < B.to_colex :=
begin
  rw [colex.lt_def, colex.lt_def],
  apply exists_congr,
  intro k,
  simp only [mem_sdiff, not_and, not_not],
  split,
  { rintro ⟨z, kAB, kB, kA⟩,
    refine ⟨_, kA, kB⟩,
    { intros x hx,
      specialize z hx,
      tauto } },
  { rintro ⟨z, kA, kB⟩,
    refine ⟨_, λ _, kB, kB, kA⟩,
    intros x hx,
    rw z hx },
end

/-- Colex doesn't care if you remove the other set -/
@[simp]

lemma empty_to_colex_lt [linear_order α] {A : finset α} (hA : A.nonempty) :
  (∅ : finset α).to_colex < A.to_colex :=
begin
  rw [colex.lt_def],
  refine ⟨max' _ hA, _, by simp, max'_mem _ _⟩,
  simp only [false_iff, not_mem_empty],
  intros x hx t,
  apply not_le_of_lt hx (le_max' _ _ t),
end

/-- If `A ⊂ B`, then `A` is less than `B` in the colex order. Note the converse does not hold, as
`⊆` is not a linear order. -/
lemma colex_lt_of_ssubset [linear_order α] {A B : finset α} (h : A ⊂ B) :
  A.to_colex < B.to_colex :=
begin
  rw [←sdiff_lt_sdiff_iff_lt, sdiff_eq_empty_iff_subset.2 h.1],
  exact empty_to_colex_lt (by simpa [finset.nonempty] using exists_of_ssubset h),
end

@[simp] lemma empty_to_colex_le [linear_order α] {A : finset α} :
  (∅ : finset α).to_colex ≤ A.to_colex :=
begin
  rcases A.eq_empty_or_nonempty with rfl | hA,
  { simp },
  { apply (empty_to_colex_lt hA).le },
end

/-- If `A ⊆ B`, then `A ≤ B` in the colex order. Note the converse does not hold, as `⊆` is not a
linear order. -/
lemma colex_le_of_subset [linear_order α] {A B : finset α} (h : A ⊆ B) :
  A.to_colex ≤ B.to_colex :=
begin
  rw [←sdiff_le_sdiff_iff_le, sdiff_eq_empty_iff_subset.2 h],
  apply empty_to_colex_le
end

/-- The function from finsets to finsets with the colex order is a relation homomorphism. -/
@[simps]
def to_colex_rel_hom [linear_order α] :
  ((⊆) : finset α → finset α → Prop) →r ((≤) : finset.colex α → finset.colex α → Prop) :=
{ to_fun := finset.to_colex,
  map_rel' := λ A B, colex_le_of_subset }

instance [linear_order α] : order_bot (finset.colex α) :=
{ bot := (∅ : finset α).to_colex,
  bot_le := λ x, empty_to_colex_le }

instance [linear_order α] [fintype α] : order_top (finset.colex α) :=
{ top := finset.univ.to_colex,
  le_top := λ x, colex_le_of_subset (subset_univ _) }

instance [linear_order α] : lattice (finset.colex α) :=
{ ..(by apply_instance : semilattice_sup (finset.colex α)),
  ..(by apply_instance : semilattice_inf (finset.colex α)) }

instance [linear_order α] [fintype α] : bounded_order (finset.colex α) :=
{ ..(by apply_instance : order_top (finset.colex α)),
  ..(by apply_instance : order_bot (finset.colex α)) }

/-- For subsets of ℕ, we can show that colex is equivalent to binary. -/
lemma sum_two_pow_lt_iff_lt (A B : finset ℕ) :
  ∑ i in A, 2^i < ∑ i in B, 2^i ↔ A.to_colex < B.to_colex :=
begin
  have z : ∀ (A B : finset ℕ), A.to_colex < B.to_colex → ∑ i in A, 2^i < ∑ i in B, 2^i,
  { intros A B,
    rw [← sdiff_lt_sdiff_iff_lt, colex.lt_def],
    rintro ⟨k, z, kA, kB⟩,
    rw ← sdiff_union_inter A B,
    conv_rhs { rw ← sdiff_union_inter B A },
    rw [sum_union (disjoint_sdiff_inter _ _), sum_union (disjoint_sdiff_inter _ _),
        inter_comm, add_lt_add_iff_right],
    apply lt_of_lt_of_le (@nat.sum_two_pow_lt k (A \ B) _),
    { apply single_le_sum (λ _ _, nat.zero_le _) kB },
    intros x hx,
    apply lt_of_le_of_ne (le_of_not_lt (λ kx, _)),
    { apply (ne_of_mem_of_not_mem hx kA) },
    have := (z kx).1 hx,
    rw mem_sdiff at this hx,
    exact hx.2 this.1 },
  refine ⟨λ h, (lt_trichotomy A B).resolve_right (λ h₁, h₁.elim _ (not_lt_of_gt h ∘ z _ _)), z A B⟩,
  rintro rfl,
  apply irrefl _ h
end

/-- For subsets of ℕ, we can show that colex is equivalent to binary. -/
lemma sum_two_pow_le_iff_lt (A B : finset ℕ) :
  ∑ i in A, 2^i ≤ ∑ i in B, 2^i ↔ A.to_colex ≤ B.to_colex :=
by rw [le_iff_le_iff_lt_iff_lt, sum_two_pow_lt_iff_lt]

end colex


import LeanUtils
open Nat

theorem sum_of_squares (a b c d : Nat) : ∃ M N : Nat, (a^2+b^2) * (c^2+d^2) = M^2 + N^2 := by
  have h₁ : (a^2+b^2) * (c^2+d^2) = (a*c-b*d)^2+(a*d+b*c)^2 := by
    calc
      (a^2+b^2) * (c^2+d^2) = (a*c)^2 + (a*d)^2 + (b*c)^2 + (b*d)^2 := by
        try simp_all
        try ring
      _ = (a*c)^2 - 2*a*b*c*d + (b*d)^2 + (a*d)^2 + 2*a*b*c*d + (b*c)^2 := by
        try simp_all
        try ring
        admit -- ring does not seem to be able to solve this for now
      _ = (a*c-b*d)^2+(a*d+b*c)^2 := by
        try simp_all
        try ring
        admit -- ring does not seem to be able to solve this for now

  exact ⟨_, _, by assumption⟩


import game.order.level07
import data.real.irrational

open real

namespace xena -- hide

/-
# Chapter 2 : Order

## Level 8

Prove by example that there exist pairs of real numbers
$a$ and $b$ such that $a \in \mathbb{R} \setminus \mathbb{Q}$,
$b \in \mathbb{R} \setminus \mathbb{Q}$,
but their product $a \cdot b$ is a rational number, $(a \cdot b) \in \mathbb{Q}$.
You may use this result in the Lean mathlib library:

`irrational_sqrt_two : irrational (sqrt 2)
-/

/- Lemma
Not true that for any $a$, $b$, irrational numbers, the product is
also an irrational number.
-/
theorem not_prod_irrational :
    ¬ ( ∀ (a b : ℝ), irrational a →  irrational b → irrational (a*b) ) :=
begin
  intro h,
  have h2 := h (sqrt 2) (sqrt 2),
  have H3 := h2 irrational_sqrt_two irrational_sqrt_two,
  apply H3,
  existsi (2 : ℚ),
  simp,
  norm_num,
end

end xena -- hide


--

theorem ex : Not (1 = 2) :=
of_decide_eq_false rfl