section sort

theorem one_le_suc : ∀n, 1 ≤ nat.succ n :=
begin
    intros n,
    induction n,
        reflexivity,
    apply nat.less_than_or_equal.step,
    unfold has_le.le at ih_1,
    exact ih_1
end

def count_dec {α : Type} [decidable_eq α] : α → list α → ℕ
    | _ [] := 0
    | x (h :: t) := if x = h
                    then 1 + (count_dec x t)
                    else count_dec x t

def permutation_dec {α : Type} [decidable_eq α] (l₁ l₂ : list α) : Prop :=
    ∀x, count_dec x l₁ = count_dec x l₂

instance strict_order_pair_alpha_nat {α : Type} : strict_order (α × ℕ) :=
    { lt        := λl r, nat.lt l.snd r.snd,
      lt_irrefl := λpair, nat.lt_irrefl pair.snd,
      lt_trans  := λl m r, @nat.lt_trans l.snd m.snd r.snd}

def in_comp {α : Type} : α → list α → Prop
    | _ []       := false
    | x (h :: t) := x = h ∨ in_comp x t

local notation x ∈ l := in_comp x l

inductive no_dup {α : Type} : list α → Prop
    | no_dup_empty : no_dup []
    | no_dup_one   : ∀x, no_dup [x]
    | no_dup_more  : ∀x (l : list α),
                         no_dup l →
                         ¬(x ∈ l) →
                         no_dup (x :: l)

inductive sorted {α : Type} [decidable_linear_order α] : list α → Prop
    | sorted_empty : sorted []
    | sorted_one   : ∀x, sorted [x]
    | sorted_more  : ∀(x y : α) (t : list α),
                         x ≤ y → sorted (y :: t) → sorted (x :: y :: t)

inductive stable_sorted {α : Type} {β : Type}
                        [strict_order α] [decidable_linear_order β]
                        (key : α → β) :
    list α → Prop
    | stable_empty    : stable_sorted []
    | stable_one      : ∀x, stable_sorted [x]
    | stable_more_eq  : ∀(x y : α) (t : list α),
                            key x = key y →
                            x < y →
                            stable_sorted (y :: t) →
                            stable_sorted (x :: y :: t)
    | stable_more_neq : ∀(x y : α) (t : list α),
                            key x < key y →
                            stable_sorted (y :: t) →
                            stable_sorted (x :: y :: t)

open list
open sorted
open prod
open nat

lemma map_pres_nil {α β : Type} : ∀(l : list α) (f : α → β),
    map f l = [] → l = [] :=
assume l f φ,
begin
    cases l,
        refl,
    dsimp at φ,
    cases φ
end

lemma map_pres_one {α β : Type} : ∀(l : list α) (x : β) (f : α → β),
    map f l = [x] → ∃y : α, l = [y] :=
assume l x f φ,
begin
    cases l,
        dsimp at φ, cases φ,
    cases a_1,
        existsi a, refl,
    cases φ
end

lemma map_pres_more {α β : Type} : ∀(l : list α) (t : list β) (x y : β) (f : α → β),
    map f l = x :: y :: t → ∃(a b : α) (c : list α), l = a :: b :: c :=
assume l t x y f φ,
begin
    cases l,
        dsimp at φ, cases φ,
    cases a_1,
        dsimp at φ, cases φ,
    dsimp at φ,
        existsi a,
        existsi a_2,
        existsi a_3,
        refl
end

lemma no_dup_tail {α : Type} : ∀h (t : list α),
    no_dup (h :: t) → no_dup (t) :=
assume h t φ,
begin
    cases φ,
        constructor,
    assumption
end

lemma not_in_means_neq {α : Type} : ∀(a b : α) (t : list α),
    ¬a ∈ b :: t → a ≠ b :=
assume a b t dec φ,
begin
    unfold not at φ,
    unfold in_comp at φ,
    rw φ at dec,
    unfold in_comp at dec,
    apply dec, left, refl
end

lemma no_dup_are_unequal {α : Type} : ∀(a b : α) (t : list α),
    no_dup (a :: b :: t) → a ≠ b :=
assume a b t φ,
begin
    cases φ,
    apply not_in_means_neq,
    exact a_2
end

lemma lt_le_neq {α : Type} [decidable_linear_order α] :
    ∀x y : α, x ≠ y → x ≤ y → x < y :=
assume x y φ ψ,
begin
    rw le_iff_lt_or_eq at ψ,
    cases ψ,
        exact a,
    contradiction
end

lemma map_over_nil {α β : Type} :
    ∀f : α → β,
    map f [] = [] := assume f, by refl

def π₁ {α : Type} : list (α × ℕ) → list α := map fst

theorem distinct_always_stable
    {α : Type}
    [x : decidable_linear_order α]
    [y : strict_order (α × ℕ)] :
    ∀(l : list (α × ℕ)),
    no_dup (π₁ l) → (
        @stable_sorted (α × ℕ) α y x fst l ↔
        @sorted α x (π₁ l)
    ) :=
assume l ω,
begin
    unfold π₁ at *,
    split; intros φ,
    -- stable_sorted → sorted
    {
        induction φ with h h₁ h₂ t φ ψ ξ ih
                         h h₁ φ ψ ξ ih;
            -- trivial for empty list
            try {simp [map_over_nil]; constructor},
            {
                rw le_iff_lt_or_eq,
                right, assumption
            },
            -- stable_sorted under equality
            -- follows from no_dup_shoter and ih
            {
                apply ih,
                dsimp at *,
                apply no_dup_tail,
                exact ω
            },
            -- trivial for singleton list
            {
                apply le_of_lt,
                exact ψ
            },
            -- stable_sorted under inequality
            -- follows from no_dup_shorter and ih
            {
                apply ih,
                dsimp at *,
                apply no_dup_tail,
                exact ω
            }
    },
    -- sorted → stable_sorted
    {
        -- consider a sorted fixed list l₁
        generalize2 (map fst l) l₁ ψ,
        rw ψ at φ,
        revert l,
        induction φ with h
                         h₁ h₂ t₁ φ ξ ih; intros,
        -- trivial for empty list
        {
            assert l_empty : l = [],
                apply map_pres_nil, exact ψ,
            rw l_empty, constructor
        },
        -- trivial for singleton list
        {
            assert l_single : ∃x, l = [x],
                apply map_pres_one, exact ψ,
            cases l_single with l₁ eq₁,
            rw eq₁,
            constructor
        },
        -- longer lists
        {
            assert l_more : ∃x₁ x₂ x₃, l = x₁ :: x₂ :: x₃,
                apply map_pres_more, exact ψ,
            cases l_more with x₁ eq₁,
            cases eq₁ with x₂ eq₂,
            cases eq₂ with x₃ eq₃,
            subst eq₃; dsimp at *,
            injection ψ with ψ₁ eq₄,
            injection eq₄ with ψ₂ eq₅,
            -- h₁ < h₂ ∨ h₁ = h₂
            rw le_iff_lt_or_eq at φ,
            cases φ with eq eq,
            -- h₁ < h₂
            -- follows from definition of stable_sortedness
            -- ih and no_dup_shorter
            {
                apply stable_sorted.stable_more_neq,
                    cc,
                apply ih; dsimp at *,
                    apply no_dup_tail,
                    exact ω,
                exact eq₄
            },
            -- h₁ = h₂
            -- problematic for stable_sort
            -- but we know that there are no duplicates
            -- the case is therefore contradictory
            {
                assert contra : x₁.fst ≠ x₂.fst,
                    apply no_dup_are_unequal,
                    exact ω,
                cc
            }
        }
    }
end

def iota_asc_from : ℕ → ℕ → list ℕ
    | m 0        := []
    | m (succ k) := m :: iota_asc_from (succ m) k

def iota_asc (n : ℕ) : list ℕ := iota_asc_from 0 n

lemma iota_asc_from_len : ∀m n,
    length (iota_asc_from m n) = n :=
assume m n,
begin
    revert m,
    induction n with n ih; intros,
        refl,
    unfold iota_asc_from length,
    rw add_one_eq_succ,
    apply congr_arg,
    apply ih
end

theorem iota_asc_len : ∀n,
    length (iota_asc n) = n := assume n, iota_asc_from_len 0 n

theorem no_dup_split {α : Type} : ∀h (t : list α),
    no_dup (h :: t) → no_dup t :=
assume h t φ,
begin
    cases φ, constructor, exact a
end

lemma iota_in_succ_succ : ∀m n k,
    n ∈ iota_asc_from m k →
    n ∈ iota_asc_from m (succ k) :=
assume m n k φ,
begin
    revert φ n m,
    induction k; intros m n φ,
    unfold iota_asc_from at *, cases φ, rename a a',
    unfold iota_asc_from,
    assert step : n ∈ m :: iota_asc_from (succ m) (succ a') →
                  n ∈ m :: succ m :: iota_asc_from (succ (succ m)) a',
        intros, unfold iota_asc_from at *, assumption,
    apply step, clear step,
    unfold in_comp, by_cases (m = n), left, rw h,
    right, apply ih_1,
    unfold iota_asc_from in_comp at φ,
    cases φ,
    rw eq_comm at a, contradiction,
    exact a
end

def add_key_from {α : Type} (l : list α) (n : ℕ) : list (α × ℕ) :=
    zip l (iota_asc_from n (length l))

def add_key {α : Type} (l : list α) : list (α × ℕ) :=
    add_key_from l 0

lemma pair_equal {α β : Type} : ∀p p' : α × β,
    p = p' ↔ p.fst = p'.fst ∧ p.snd = p'.snd :=
assume p p',
begin
    split; intros,
    split; cases a; refl,
    cases a, cases p, cases p',
    dsimp at *,
    cc
end

lemma add_key_from_immediate {α : Type} : ∀n h (t : list α),
    add_key_from (h :: t) n = (h, n) :: add_key_from t (succ n) :=
assume n h t, by refl

lemma add_key_from_nil {α : Type} :
    ∀n, add_key_from (@nil α) n = [] :=
assume n, by refl

lemma singleton_list_equal {α : Type} : ∀(x y : α),
    [x] = [y] ↔ x = y :=
assume x y,
begin
    split; intros,
    cases a, refl,
    cc
end

def insert_le {α : Type} [x : linear_weak_order α] [decidable_rel x.le]
    : α → list α → list α
    | a []       := [a]
    | a (h :: t) := if a ≤ h
                    then a :: h :: t
                    else h :: insert_le a t

def insert_le_key {α : Type} [decidable_linear_order α]
    : (α × ℕ) → list (α × ℕ) → list (α × ℕ)
    | a []       := [a]
    | a (h :: t) := if a.fst ≤ h.fst
                    then a :: h :: t
                    else h :: insert_le_key a t

def insert_sort {α : Type} [x : decidable_linear_order α]
    (l : list α) : list (α × ℕ) :=
    foldr insert_le_key [] (add_key l)

def insert_sort_keyless {α : Type} [x : linear_weak_order α] [decidable_rel x.le] (l : list α) : (list α) :=
    foldr insert_le [] l

def π₁immediate {α : Type} : ∀(h₁ : α) h₂ (t : list (α × ℕ)),
    π₁ ((h₁, h₂) :: t) = h₁ :: π₁ t := assume h₁ h₂ t, by refl

lemma zip_l_nil {α β : Type} : ∀l : list α, zip l (@nil β) = (@nil (α × β)) :=
assume l,
begin
    cases l, refl, unfold zip zip_with, refl
end

lemma zip_nil_l {α β : Type} : ∀l : list α, zip (@nil β) l = (@nil (β × α)) :=
    assume l, by refl

lemma zip_immediate {α β : Type} : ∀h₁ h₂ (t₁ : list α) (t₂ : list β),
    zip (h₁ :: t₁) (h₂ :: t₂) = (h₁, h₂) :: zip t₁ t₂ :=
    assume h₁ h₂ t₁ t₂, by refl

lemma insert_into_nil {α : Type} [x : linear_weak_order α] [decidable_rel x.le] :
    ∀a, insert_le a (@nil α) = [a] := assume a, by refl

lemma insert_key_into_nil {α : Type} [x : decidable_linear_order α] :
    ∀a, insert_le_key a (@nil (α × ℕ)) = [a] := assume a, by refl

lemma sort_empty {α : Type} [x : decidable_linear_order α] :
    insert_sort (@nil α) = [] := by refl

lemma insert_into_empty {α : Type} [x : decidable_linear_order α] : ∀(h : α × ℕ),
    insert_le_key h nil = [h] := assume h, by refl

lemma one_add_eq_succ : ∀n : ℕ, 1 + n = succ n :=
    assume n, by rw add_comm

lemma zip_second_empty {α β : Type} : ∀(l : list α),
    zip_with mk l (@nil β) = nil := assume l, by cases l; refl

lemma add_key_cons {α : Type} : ∀h (t : list α),
    add_key (h :: t) = (h, 0) :: add_key_from t 1 := assume h t, rfl

lemma permutation_refl {α : Type} [decidable_eq α] : ∀(l : list α),
    permutation_dec l l := by simp [permutation_dec]

lemma count_dec_immediate {α : Type} [decidable_eq α] : ∀x (l : list α),
    count_dec x (x :: l) = succ (count_dec x l) :=
assume x l,
begin
    unfold count_dec,
    rw one_add_eq_succ,
    cc
end

lemma count_dec_not_immediate {α : Type} [decidable_eq α] : ∀x₁ x₂ (l : list α),
    x₁ ≠ x₂ →
    count_dec x₁ (x₂ :: l) = count_dec x₁ l :=
assume x₁ x₂ l,
begin
    unfold count_dec,
    cc
end

lemma count_dec_eq_head {α : Type} [decidable_eq α] : ∀x h (t t' : list α),
    count_dec x (h :: t) = count_dec x (h :: t') ↔
    count_dec x t = count_dec x t' :=
assume x h t t',
begin
    split;
      unfold count_dec;
      by_cases (x = h) with ψ; simp [ψ]; intros φ,
        {repeat {rw one_add_eq_succ at φ},
         injection φ},
        {exact φ},
      {repeat {rw one_add_eq_succ}, apply congr_arg, exact φ},
      {exact φ}
end

lemma count_empty {α : Type} [decidable_eq α] : ∀x : α,
    count_dec x [] = 0 := assume x, by simp [count_dec]

lemma count_dec_app {α : Type} [decidable_eq α] : ∀x (l₁ l₂ : list α),
    count_dec x (l₁ ++ l₂) = count_dec x l₁ + count_dec x l₂ :=
assume x l l',
begin
    induction l with h t ih,
    {simp [nil_append, count_empty]},
    {unfold count_dec,
     by_cases (x = h) with φ; simp [φ],
       rw count_dec_immediate,
       rw one_add_eq_succ,
       apply congr_arg,
       rw -φ,
       rw add_comm,
       exact ih,
     rw add_comm,
     rw -ih,
     unfold count_dec,
     cc
    }
end

lemma permutation_dec_eq_head {α : Type} [decidable_eq α] : ∀h (t t' : list α),
    permutation_dec t t' →
    permutation_dec (h :: t) (h :: t') :=
assume h t t' φ,
begin
    unfold permutation_dec,
    intros x,
    rw count_dec_eq_head,
    unfold permutation_dec at φ,
    apply φ
end

lemma list_len_mismatch {α : Type} : ∀h (t : list α),
    length (@nil α) ≠ length (h :: t) :=
assume h t, by contradiction

lemma permute_cons_diff {α : Type} [decidable_eq α] : ∀x y (t t' : list α),
    permutation_dec t (y :: t') →
    permutation_dec (x :: t) (y :: x :: t') :=
assume x y t t' φ,
begin
    unfold permutation_dec count_dec, intros h,
    by_cases (h = x) with ψ; simp [ψ],
        by_cases (x = y) with ξ; simp [ξ],
            repeat {rw one_add_eq_succ},
            apply congr_arg,
            unfold permutation_dec at φ,
            assert ih_fix :
                count_dec y t = count_dec y (y :: t'),
                begin apply φ end,
            rw ih_fix,
            simp [count_dec_immediate],
        repeat {rw one_add_eq_succ},
        apply congr_arg,
        unfold permutation_dec at φ,
        assert ih_fix :
            count_dec x t = count_dec x (y :: t'),
        begin apply φ end,
        rw ih_fix,
        rw count_dec_not_immediate, cc,
        by_cases (h = y) with ψ; simp [ψ],
            unfold permutation_dec at φ,
            assert ih_fix :
                count_dec y t = count_dec y (y :: t'),
                begin apply φ end,
            rw ih_fix,
            rw count_dec_immediate,
            rw one_add_eq_succ,
        unfold permutation_dec at φ,
        assert ih_fix :
            count_dec h t = count_dec h (y :: t'),
            begin apply φ end,
        rw ih_fix,
        rw count_dec_not_immediate,
        cc
end

lemma insert_permutes {α : Type} [x : decidable_linear_order α] : ∀h (t : list (α × ℕ)),
    permutation_dec (insert_le_key h t) (h :: t) :=
assume h t,
begin
    induction t with h' t' ih,
    {simp [insert_into_empty, permutation_refl]},
    {unfold insert_le_key,
     by_cases (h.fst ≤ h'.fst) with h;
     unfold strong_order_pair.le linear_strong_order_pair.le decidable_linear_order.le;
     simp [h],
         apply permutation_refl,
         apply permute_cons_diff,
         exact ih
    }
end

lemma count_over_projection {α : Type} [x : decidable_linear_order α] :
    ∀x xₖ (l : list (α × ℕ)),
    count_dec x (π₁ (insert_le_key (x, xₖ) l)) = succ (count_dec x (π₁ l)) :=
assume x xₖ l,
begin
    induction l,
    {rw insert_into_empty,
     unfold π₁,
     dsimp,
     rw count_dec_immediate
    },
    {unfold insert_le_key,
     dsimp,
     by_cases (x ≤ a.fst) with φ;
     unfold strong_order_pair.le linear_strong_order_pair.le decidable_linear_order.le; simp [φ],
       unfold π₁, dsimp,
       rw count_dec_immediate,
     unfold π₁ at *, dsimp at *,
     rename x_1 x₁,
     assert neq_if_nleq : x₁ ≠ a.fst,
       dsimp, unfold not, intros contra,
       assert if_nleq : x₁ ≤ a.fst,
         apply le_of_eq, exact contra,
       contradiction,
     repeat {rw count_dec_not_immediate},
     exact ih_1, cc, cc
    }
end

lemma count_over_projection_neq
    {α : Type}
    [x : decidable_linear_order α] :
    ∀x y xₖ (l : list (α × ℕ)),
        x ≠ y →
        count_dec x (π₁ (insert_le_key (y, xₖ) l)) = count_dec x (π₁ l) :=
assume x y xₖ l,
begin
    induction l; intros φ,
    {
        rw insert_into_empty,
        unfold π₁,
        dsimp,
        rw count_dec_not_immediate,
        exact φ
    },
    {
        unfold insert_le_key,
        dsimp,
        by_cases (y ≤ a.fst) with ψ;
            unfold strong_order_pair.le linear_strong_order_pair.le decidable_linear_order.le; simp [ψ],
            rw π₁immediate,
            rw count_dec_not_immediate, exact φ,
        unfold π₁ at *, dsimp at *,
        rename x_1 x₁,
        note ihₕ := ih_1 φ,
        unfold count_dec,
        by_cases (x₁ = a.fst) with ξ;
        unfold has_le.le weak_order.le; simp [ξ],
        repeat {rw one_add_eq_succ},
            apply congr_arg,
            cc,
        cc
    }
end

lemma projection_over_pairs
    {α : Type} :
    ∀(l₁ : list α)(l₂ : list ℕ),
        length l₁ = length l₂ →
        ∀l, (length l₁ = length l) →
            π₁ (zip l₁ l₂) = π₁ (zip l₁ l) :=
assume l₁,
begin
    induction l₁ with h t ih; intros l₂ φ l,
        repeat {rw zip_nil_l}, intros, refl,
    intros ψ,
    cases l₂ with a₁; dsimp at φ,
        cases φ,
    dsimp at φ, repeat {rw add_one_eq_succ at φ},
    injection φ with eq_len,
    cases l with h₁ t₁,
        cases ψ,
    dsimp at ψ, repeat {rw add_one_eq_succ at ψ},
    injection ψ with eq_lenψ,
    note ih_fix := ih a eq_len t₁ eq_lenψ,
    repeat {rw zip_immediate},
    repeat {rw π₁immediate},
    apply congr_arg,
    exact ih_fix
end

lemma insert_second_irrelevant
    {α : Type}
    [x : decidable_linear_order α] :
    ∀a b c (l : list (α × ℕ)),
        π₁ (insert_le_key (a, b) l) = π₁ (insert_le_key (a, c) l) :=
assume a b c l,
begin
    induction l with h t ih,
        repeat {rw insert_key_into_nil}, refl,
    unfold insert_le_key, dsimp,
    by_cases (a ≤ h.fst) with ψ;
    unfold strong_order_pair.le linear_strong_order_pair.le decidable_linear_order.le;
    simp [ψ],
        repeat {rw π₁immediate},
    cases h,
    repeat {rw π₁immediate},
    apply congr_arg,
    exact ih
end

lemma insert_le_x_right_neutral
    {α : Type}
    [decidable_linear_order α] :
    ∀x (l₁ l₂ : list (α × ℕ)),
        π₁ l₁ = π₁ l₂ →
        π₁ (insert_le_key x l₁) = π₁ (insert_le_key x l₂) :=
assume x l₁,
begin
    induction l₁ with h t ih; intros l₂ φ; cases l₂ with h₂ t₂,
    -- trivial for empty lists
    {
        refl
    },
    -- contradictory for lists of unequal lengths
    {
        contradiction
    },
    {
        contradiction
    },
    {
        unfold insert_le_key at *,
        by_cases (x.fst ≤ h.fst) with ψ;
            by_cases (x.fst ≤ h₂.fst) with ξ;
                simp [ψ, ξ]; unfold π₁ at *; dsimp at *;
                    injection φ with eq₁ eq₂;
                try {try {apply congr_arg}; cc},
        rw eq₁, apply congr_arg, apply ih, exact eq₂
    }
end

lemma projection_over_foldr
    {α : Type}
    [x : decidable_linear_order α] :
    ∀(l : list α) (l₁ l₂ : list ℕ),
        length l₁ = length l₂ →
        π₁ (foldr insert_le_key nil (zip l l₁)) =
        π₁ (foldr insert_le_key nil (zip l l₂)) :=
assume l,
begin
    induction l with h t ih; intros l₁ l₂ φ,
        repeat {rw zip_nil_l},
    cases l₁ with h₁ t₁; cases l₂ with h₂ t₂,
        rw zip_l_nil,
        contradiction,
        contradiction,
    repeat {rw zip_immediate},
    dsimp,
    dsimp at φ, repeat {rw add_one_eq_succ at φ}, injection φ with H,
    note ih₁ := ih t₁ t₂ H,
    rw (@insert_second_irrelevant _ _ h h₂ h₁ _),
    apply insert_le_x_right_neutral,
    exact ih₁
end

lemma sort_permutes
    {α : Type}
    [decidable_linear_order α] :
    ∀l₁ (l₂ : list (α × ℕ)),
        l₂ = insert_sort l₁ → permutation_dec (π₁ l₂) l₁ :=
assume l₁ l₂ φ,
begin
    revert l₂ φ,
    induction l₁ with h t ih; intros,
    -- l₁ = ε
    {
        assert l₂_nil : l₂ = [],
            rw φ, apply sort_empty,
            rw l₂_nil,
        unfold π₁ permutation_dec,
        intros, refl
    },
    -- l₁ = h :: t
    {
        subst φ,
        unfold insert_sort,
        rw add_key_cons,
        unfold foldr,
        assert ih₁ : permutation_dec (π₁ (insert_sort t)) t,
            apply ih, refl,
        unfold permutation_dec at *,
        intros hₑ,
        unfold count_dec,
        -- assuming hₑ = h
        -- follows from ih count_over_projection
        -- projection_over_foldr iota_asc_from_len
        by_cases (hₑ = h) with ψ; simp [ψ],
        {
            rw count_over_projection,
            rw one_add_eq_succ,
            apply congr_arg,
            note ihₕ := ih₁ h,
            unfold insert_sort at ihₕ,
            unfold add_key_from add_key at *,
            rw (@projection_over_foldr _ _ t _ (iota_asc_from 0 (length t))),
                exact ihₕ,
            simp [iota_asc_from_len]
        },
        -- assuming hₑ ≠ h
        -- follows from ih count_over_projection_neq
        -- projection_over_foldr iota_asc_from_len
        {
            note ihₑ := ih₁ hₑ,
            rw -ihₑ,
            unfold insert_sort add_key,
            rw count_over_projection_neq,
            unfold insert_sort add_key add_key_from at *,
            rw (@projection_over_foldr _ _ t _ (iota_asc_from 0 (length t))),
            simp [iota_asc_from_len],
            cc
        }
    }

end

inductive strictly_increasing : list ℕ → Prop
    | si_empty : strictly_increasing []
    | si_one   : ∀x, strictly_increasing [x]
    | si_more  : ∀h₁ h₂ (t : list ℕ),
                 h₁ < h₂ →
                 strictly_increasing (h₂ :: t) →
                 strictly_increasing (h₁ :: h₂ :: t)

lemma iota_excl : ∀m n l,
    iota_asc_from m n = l →
    ∀x, x ∈ l → m ≤ x:=
assume m n,
begin
    revert m,
    induction n with k ih; intros m l φ x ψ,
        unfold iota_asc_from at φ, subst φ, cases ψ,
    cases l with h t,
        cases ψ,
    by_cases (x = h) with H,
        unfold iota_asc_from at φ,
        injection φ with ξ ρ,
        subst H, subst ξ,
    unfold iota_asc_from at φ,
    injection φ with h₁ h₂,
    unfold in_comp at ψ,
    cases ψ with head tail,
        contradiction,
    note ih₁ := ih (succ m) t h₂ x tail,
    apply le_of_succ_le,
    exact ih₁
end

theorem iota_from_strictly : ∀m n l,
    l = iota_asc_from m n →
    strictly_increasing l :=
assume m n l φ,
begin
    subst φ,
    revert m,
    induction n with k ih; intros m,
        constructor,
    unfold iota_asc_from,
    generalize2 (iota_asc_from (succ m) k) G H,
    cases G,
        constructor,
    constructor,
    apply lt_of_succ_le,
        apply iota_excl,
        exact H,
        unfold in_comp,
        left,
        refl,
    rw -H,
    apply ih
end

lemma le_succ_succ_of : ∀m n, succ m ≤ succ n → m ≤ n :=
assume m n φ, @pred_le_pred (succ m) (succ n) φ

lemma stable_sorted_over_zip {α : Type} [x : decidable_linear_order α] [decidable_rel x.le] [decidable_eq α] :
    ∀h₁ h₂ (t₁ : list α) (t₂ : list ℕ),
    t₁ = [] →
    length t₁ = length t₂ →
    stable_sorted fst (foldr insert_le_key nil (zip t₁ t₂)) →
    stable_sorted fst (foldr insert_le_key nil (zip (h₁ :: t₁) (h₂ :: t₂))) :=
assume h₁ h₂ t₁ t₂ φ ψ ξ,
begin
    subst φ, cases t₂, rw zip_immediate, rw zip_nil_l,
    unfold foldr insert_le_key, constructor,
    contradiction
end

lemma strictly_increasing_over_head : ∀h t,
    strictly_increasing (h :: t) →
    strictly_increasing t :=
assume h t φ,
begin
    cases φ,
        constructor,
    exact a_1
end

lemma insert_inc_len {α : Type} [x : decidable_linear_order α] :
    ∀a (l : list (α × ℕ)),
    length (insert_le_key a l) = succ (length l) :=
assume a l,
begin
    induction l, dsimp, rw insert_key_into_nil,
    refl,
    unfold insert_le_key,
    by_cases (a.fst ≤ a_1.fst) with H;
    unfold strong_order_pair.le linear_strong_order_pair.le decidable_linear_order.le;
    simp [H],
    rw one_add_eq_succ,
    rw one_add_eq_succ,
    apply congr_arg, rw ih_1,
    rw one_add_eq_succ
end

lemma insert_twice_len {α : Type} [x : decidable_linear_order α] :
    ∀a b (l : list (α × ℕ)),
        length (insert_le_key a (insert_le_key b l)) ≥ 2 :=
assume a b l,
begin
    rw insert_inc_len, rw insert_inc_len,
    dsimp, induction l, refl,
    unfold length, rw add_one_eq_succ, apply le_succ_of_le,
    exact ih_1
end

lemma len_congr {α : Type} :
    ∀l₁ l₂ : list α,
    l₁ = l₂ → length l₁ = length l₂ :=
assume l₁ l₂ φ,
begin
    induction l₁, subst φ,
    rw φ
end

lemma fold_zip_singular {α : Type} [x : decidable_linear_order α] :
    ∀(l₁ : list α) l₂ x,
    length l₁ = length l₂ →
    foldr insert_le_key nil (zip l₁ l₂) = [x] →
    l₁ = [x.fst] ∧ l₂ = [x.snd] :=
assume l₁ l₂ x ψ φ,
begin
    split,
        cases l₁; cases l₂, rw zip_nil_l at φ, unfold foldr at φ, contradiction,
            rw zip_nil_l at φ, unfold foldr at φ, contradiction,
        rw zip_l_nil at φ, unfold foldr at φ, contradiction,
        rw zip_immediate at φ, cases a_1, rw zip_nil_l at φ,
        unfold foldr at φ, rw insert_key_into_nil at φ,
        injection φ with G H, subst G,
        cases a_3, rw zip_l_nil at φ,
        unfold length at ψ, rw zero_add at ψ,
        repeat {rw add_one_eq_succ at ψ},
        cases ψ,
        rw zip_immediate at φ,
        unfold foldr at φ,
        unfold insert_le_key at φ,
        note len := len_congr _ _ φ,
        dsimp at len,
        rw zero_add at len,
        rw insert_inc_len at len,
        rw insert_inc_len at len,
        cases len,
        cases l₂,
            rw zip_l_nil at φ, dsimp at φ, contradiction,
        cases l₁,
            dsimp at ψ, rw add_one_eq_succ at ψ, contradiction,
        cases a_1; cases a_3,
            rw zip_immediate at φ, rw zip_nil_l at φ,
            dsimp at φ, rw insert_key_into_nil at φ,
            injection φ with A B,
            subst A,
        dsimp at ψ, rw add_one_eq_succ at ψ,
        rw zero_add at ψ, cases ψ,
        dsimp at ψ, rw add_one_eq_succ at ψ,
        rw add_one_eq_succ at ψ,
        rw add_one_eq_succ at ψ,
        cases ψ,
        repeat {rw zip_immediate at φ},
        dsimp at φ,
        note len := len_congr _ _ φ,
        repeat {rw insert_inc_len at len},
        dsimp at len,
        rw zero_add at len,
        cases len
end

lemma zero_le_true_iff : ∀n, nat.less_than_or_equal 0 n ↔ true :=
assume n,
begin
    split; intros,
        cc,
    induction n,
    unfold linear_weak_order.le,
        unfold nat.le,
        constructor,
    unfold linear_weak_order.le nat.le,
    constructor,
    exact ih_1
end

lemma strictly_into_head : ∀h h₁ t,
    h < h₁ →
    strictly_increasing (h₁ :: t) →
    strictly_increasing (h :: h₁ :: t) :=
assume h h₁ t φ ψ,
begin
    generalize2 (h₁ :: t) l ρ,
        rw ρ at ψ,
    revert h h₁ t φ,
    induction ψ; intros,
        constructor,
        cases ρ, constructor, exact φ,
        constructor,
    constructor,
    cases ρ, exact φ,
    note ih₁ := ih_1 h₁ h₂ t a,
    apply ih₁, refl
end

lemma   strictly_over_skip : ∀h h₁ t,
    strictly_increasing (h :: h₁ :: t) →
    strictly_increasing (h :: t) :=
assume h h₁ t φ,
begin
    cases φ,
    cases a_1,
        constructor,
    apply strictly_into_head,
    apply (@lt_trans _ _ _ h₁); try {assumption},
    exact a_3
end

lemma strictly_split : ∀h t,
    strictly_increasing (h :: t) →
    (∀x, x ∈ t → h < x) :=
assume h t φ,
begin
    induction t with h₁ t₁ ih; intros,
        cases a,
    unfold in_comp at a,
        cases a,
        rw -a_1 at φ,
        cases φ, exact a,
    apply ih,
    note ρ := strictly_increasing (h :: t₁),
         apply strictly_over_skip, exact φ,
    exact a_1
end

lemma project_second {α : Type} :
    ∀x y (l : list α) (l₁ : list ℕ),
    length l = length l₁ →
    (x, y) ∈ zip l l₁ →
    y ∈ l₁ :=
assume x y l l₁ φ ψ,
begin
    revert ψ,
    generalize2 (zip l l₁) l' ρ,
    intros,
    revert x y l l₁ φ,
    induction l'; intros,
        cases ψ,
    unfold in_comp at ψ,
    cases ψ,
        cases a,
        cases a_2,
        cases l; cases l₁,
            rw zip_nil_l at ρ,
            cases ρ,
            rw zip_nil_l at ρ,
            cases ρ,
            unfold length at φ,
            rw add_one_eq_succ at φ,
            cases φ,
            rw zip_immediate at ρ,
            injection ρ with A B,
            cases A,
            unfold in_comp, left, refl,
        cases l; cases l₁,
            rw zip_nil_l at ρ,
            cases ρ,
            rw zip_nil_l at ρ,
            cases ρ,
            rw zip_l_nil at ρ,
            cases ρ,
            rw zip_immediate at ρ,
            injection ρ,
        unfold length at φ,
        repeat {rw add_one_eq_succ at φ},
        injection φ with ω,
        note ih := ih_1 x y a_4 a_6 ω h a_2,
        unfold in_comp,
        right,
        exact ih
end

lemma insert_always_in {α : Type} [decidable_linear_order α] :
    ∀x (l : list (α × ℕ)),
    x ∈ insert_le_key x l :=
assume x l,
begin
    induction l,
    rw insert_key_into_nil,
    unfold in_comp, left, refl,
    unfold insert_le_key,
    by_cases (x.fst ≤ a.fst) with h; simp [h],
    unfold in_comp, left, refl,
    unfold in_comp, right, exact ih_1
end

lemma insert_pres_in {α : Type} [decidable_linear_order α] :
    ∀x y (l : list (α × ℕ)),
    y ∈ l →
    y ∈ insert_le_key x l :=
assume x y l φ,
begin
    induction l,
        cases φ,
    unfold in_comp at φ; cases φ,
    rw a_2,
        unfold insert_le_key,
        by_cases (x.fst ≤ a.fst) with h; simp [h],
            unfold in_comp,
                right, left, refl,
            unfold in_comp,
                left, refl,
            unfold insert_le_key,
            by_cases (x.fst ≤ a.fst) with g; simp [g],
                unfold in_comp,
                    right, right, exact a_2,
                unfold in_comp,
                    right, apply ih_1, exact a_2
end

lemma list_len_shorter {α β : Type} :
    ∀h h₁ (t : list α) (t₁ : list β),
    length (h :: t) = length (h₁ :: t₁) →
    length t = length t₁ :=
assume h h₁ t t₁ φ,
begin
    unfold length at φ,
    repeat {rw add_one_eq_succ at φ},
    injection φ
end

lemma in_immediate {α : Type} : ∀h (t : list α), h ∈ h :: t :=
assume h t, by unfold in_comp; left; refl

lemma leq_to_orq {α : Type} [decidable_linear_order α] :
    ∀a b : α, a ≠ b → ¬(a ≤ b) → b < a :=
assume a b ψ φ,
begin
    cases (lt_trichotomy a b),
        rw le_iff_lt_or_eq at φ,
    by_cases (a < b) with h,
        cc, cc,
    cases a_1,
        cc, assumption
end

def π₂ {α : Type} (l : list (α × ℕ)) : list ℕ := map snd l

lemma iota_split :
    ∀h t m n,
    1 ≤ n →
    h :: t = iota_asc_from m n →
    h = m ∧ t = iota_asc_from (succ m) (pred n) :=
assume h t m n φ ψ,
begin
    split,
    -- h = m
    {cases n, cases φ, unfold iota_asc_from at ψ, injection ψ},
    -- t = iota_sac_from (succ m) (pred n)
    {
        cases n, cases φ,
        unfold iota_asc_from at ψ,
        injection ψ
    }
end

lemma in_π₂_immediate {α : Type} :
    ∀(h : α × ℕ) (t : list (α × ℕ)),
    h.snd ∈ π₂ (h :: t) :=
assume h t,
begin
    unfold π₂, dsimp, apply in_immediate
end

lemma in_extended {α : Type} :
    ∀x y (l : list (α × ℕ)),
    x ∈ π₂ l →
    x ∈ π₂ (y :: l) :=
assume x y l φ,
begin
    unfold π₂, dsimp, unfold in_comp, right, assumption
end

lemma le_contra {α : Type} [decidable_linear_order α] :
    ∀x y : α,
        x = y →
        ¬x ≤ y →
        false :=
assume x y φ ψ,
begin
    rw φ at ψ,
    assert contra : y ≤ y, apply le_refl,
    contradiction
end

lemma insert_pres_sorted {α : Type} [decidable_linear_order α] :
    ∀l (e : α × ℕ) elem key,
    e = (elem, key) →
    (∀x, x ∈ π₂ l → key < x) →
    stable_sorted fst l →
    stable_sorted fst (insert_le_key e l) :=
assume l e elem key φ ψ ξ,
begin
    subst φ,
    induction l with h t ih,
    {
        rw insert_key_into_nil,
        constructor
    },
    {
        dsimp,
        unfold insert_le_key, dsimp,
        by_cases (elem = h.fst) with H;
            by_cases (elem ≤ h.fst) with H₁;
                simp [H₁],
        {
            apply stable_sorted.stable_more_eq;
                try{assumption},
            apply ψ,
            apply in_π₂_immediate
        },
        {
            note contra := le_contra elem h.fst, cc
        },
        {
            apply stable_sorted.stable_more_neq; dsimp,
            apply lt_le_neq; assumption,
            assumption
        },
        {
            cases ξ; by_cases (h.fst = elem) with G; try{cc},
            {
                apply stable_sorted.stable_more_neq; dsimp;
                    try{cc},
                apply leq_to_orq; assumption,
                constructor
            },
            {
                unfold insert_le_key; dsimp,
                by_cases (elem ≤ y.fst) with J,
                {
                    cc
                },
                {
                    simp [J],
                    apply stable_sorted.stable_more_eq,
                        try{cc},
                    assumption,
                    assert folded : y :: insert_le_key (elem, key) t_2 =
                                    insert_le_key (elem, key) (y :: t_2),
                        unfold insert_le_key, dsimp, simp [J],
                    rw folded,
                    apply ih,
                        intros x eqₓ,
                        apply ψ,
                    apply in_extended, assumption,
                    assumption,
                }
            },
            {
                unfold insert_le_key; dsimp,
                by_cases (elem ≤ y.fst) with J; simp [J],
                {
                    apply stable_sorted.stable_more_neq; dsimp;
                        try{cc},
                    apply leq_to_orq; cc,
                    by_cases (elem = y.fst) with K,
                    {
                        apply stable_sorted.stable_more_eq; dsimp;
                            try{cc},
                        apply ψ,
                        apply in_extended,
                        apply in_π₂_immediate
                    },
                    {
                        apply stable_sorted.stable_more_neq; dsimp;
                            try{cc},
                        apply lt_le_neq; cc
                    }
                },
                {
                    apply stable_sorted.stable_more_neq; dsimp;
                        try{cc},
                    assert folded : y :: insert_le_key (elem, key) t_2 =
                                    insert_le_key (elem, key) (y :: t_2),
                        unfold insert_le_key, dsimp, simp [J],
                    rw folded,
                    apply ih,
                        intros x eqₓ,
                        apply ψ,
                        apply in_extended, assumption,
                    assumption
                }
            }
        }
    }
end

lemma over_second_split {α : Type} [decidable_linear_order α] :
    ∀x elem idx (l : list (α × ℕ)),
    x ∈ π₂ (insert_le_key (elem, idx) l) →
    x = idx ∨ x ∈ π₂ l :=
assume x elem key l φ,
begin
    induction l with h t ih,
        {rw insert_key_into_nil at φ,
         unfold π₂ at φ, dsimp at φ, unfold in_comp at φ,
         cases φ, left, assumption, contradiction},
        {
            unfold insert_le_key at φ, dsimp at φ,
            by_cases (elem ≤ h.fst) with H; simp [H] at φ,
                unfold π₂ at φ, dsimp at φ,
                unfold in_comp at φ, cases φ, left, assumption,
                cases a, right, unfold π₂, dsimp,
                unfold in_comp, left, assumption, right,
                unfold in_comp, unfold π₂, dsimp,
                unfold in_comp, right, assumption,
            unfold π₂, dsimp, unfold in_comp,
            unfold π₂ at φ, dsimp at φ,
            unfold in_comp at φ, cases φ,
            right, left, exact a,
            assert or_split : ∀x y z, x ∨ z → x ∨ y ∨ z,
                intros, cases a_1, left, assumption,
                right, right, assumption,
            apply or_split, apply ih, assumption
        }
end

lemma over_second_projection {α : Type} [decidable_linear_order α] :
    ∀x (l₁ : list α) (l₂ : list ℕ),
    length l₁ = length l₂ →
    x ∈ π₂ (foldr insert_le_key nil (zip l₁ l₂)) →
    x ∈ l₂ :=
assume x l₁ l₂ ψ φ,
begin
    revert l₂,
    induction l₁ with h t ih; intros,
        rw zip_nil_l at φ,
        unfold foldr π₂ at φ,
        dsimp at φ,
        unfold in_comp at φ,
        contradiction,
    cases l₂ with h₂ t₂,
        unfold length at ψ,
        rw add_one_eq_succ at ψ,
        cases ψ,
    rw zip_immediate at φ,
    unfold foldr at φ,
    assert split : x = h₂ ∨
                   x ∈ π₂ (foldr insert_le_key nil (zip t t₂)),
        apply over_second_split, assumption,
    cases split,
        unfold in_comp, left, assumption,
    unfold in_comp, right, apply ih, apply list_len_shorter, assumption,
    assumption
end

lemma sort_sorts_stabily_aux {α : Type} [decidable_linear_order α] :
    ∀(l : list (α × ℕ)) (l₁ : list α) (l₂ : list ℕ) m n,
        length l₁ = length l₂ →
        l₂ = iota_asc_from m n →
        l = foldr insert_le_key [] (zip l₁ l₂) →
        stable_sorted fst l :=
assume l l₁ l₂ m n φ ψ ξ,
begin
    revert l l₂ m n,
    induction l₁ with h t ih; intros; cases l₂ with h₂ t₂,
        -- l₁ = ε
        {rw zip_l_nil at ξ, unfold foldr at ξ, rw ξ, constructor},
        -- contradiction by list length mismatch
        {note contra := list_len_mismatch h₂ t₂, contradiction},
        {note contra := list_len_mismatch h t, contradiction},
        -- l₁ l₂ of h :: t
        {
            rw ξ,
            rw zip_immediate,
            unfold foldr,
            assert split_iota_asc :
                    h₂ = m ∧ t₂ = iota_asc_from (succ m) (pred n),
                    apply iota_split,
                    -- in h :: t, there is at least one
                    cases n, unfold iota_asc_from at ψ, cases ψ,
                    apply one_le_suc,
                    exact ψ,
            cases split_iota_asc with eq₁ eq₂,
            assert iota_always_strictly : strictly_increasing (h₂ :: t₂),
                apply iota_from_strictly, exact ψ,
            assert tails_strictly_inc : strictly_increasing t₂,
                apply strictly_increasing_over_head,
                exact iota_always_strictly,
            note tails_eq_len := list_len_shorter _ _ _ _ φ,
            apply insert_pres_sorted,
                -- insert (h₁, h₂)
                refl,
                -- stability preserving condition
                intros x eqₓ,
                assert eq₁ : x ∈ t₂,
                    apply over_second_projection,
                    apply list_len_shorter,
                    assumption,
                    assumption,
                apply strictly_split, assumption,
                assumption,
            -- follows from ih for a strictly shorter list
            apply ih,
                exact tails_eq_len,
                exact eq₂,
                refl
        }
end

lemma sort_sorts_stabily {α : Type} [x : decidable_linear_order α] :
    ∀(l₁ : list α)(l₂ : list (α × ℕ)),
        l₂ = insert_sort l₁ → stable_sorted fst l₂ :=
assume l₁ l₂ φ,
begin
    unfold insert_sort add_key add_key_from at φ,
    apply (@sort_sorts_stabily_aux _ _ _ l₁ (iota_asc_from 0 (length l₁))),
        -- length of zipped lists coincide
        {
            assert lens_eq : length (iota_asc_from 0 (length l₁)) = length l₁,
                apply iota_asc_len,
                symmetry,
                exact lens_eq
        },
        -- iota asc from is irrelevant as long as it is strictly increasing
        {
            refl
        },
        -- list fits into the auxiliary lemma
        {
            exact φ
        }
end

theorem sort_correct_and_stable {α : Type} [decidable_linear_order α] :
    ∀(l₁ : list α) (l₂ : list (α × ℕ)),
        l₂ = insert_sort l₁ →
        stable_sorted fst l₂ ∧
        permutation_dec (π₁ l₂) l₁ :=
assume l₁ l₂ φ,
begin
    split,
    {apply sort_sorts_stabily, exact φ},
    {apply sort_permutes, exact φ}
end

def sort {α : Type} [decidable_linear_order α] :
    list α → list α := π₁ ∘ insert_sort

theorem insert_sort_well_behaved {α : Type} [decidable_linear_order α] :
    ∀l : list α, π₁ (insert_sort l) = sort l :=
assume l, by refl

end sort


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Algdata.Init.Order
import Algdata.Init.LawfulLT
import Algdata.Data.List.Basic
import Algdata.Data.KVChain.Basic
import Algdata.Data.KVChain.MergeWith
import Algdata.Algebra.Monoid.FreeCMonoid

/-!

# Monomial order

Given a (decidable) linearly ordered type `α`, a relation `r : FreeCMonoid α → FreeCMonoid α → Prop` is called a monomial order if it satisfies the following:

  - it is a strict linear order
  - `1` is minimum; i.e. `¬ r 1 x` implies `x=1`
  - it is stable under the right translation; i.e. `r x y` implies `r (x*z) (y*z)`

@remark We always assume decidability.
-/

universe u

structure MonomialOrder (α : Type u) [LinearLT α] [DecidableRel (α:=α) LT.lt] where
  lt : FreeCMonoid α → FreeCMonoid α → Prop
  linear : StrictLinearOrder lt
  decidable : DecidableRel lt
  unit_antisymm : ∀ x, ¬ lt 1 x → x = 1
  mul_lt_mul_right : ∀ (x y z : FreeCMonoid α), lt x y → lt (x*z) (y*z)

attribute [instance] MonomialOrder.linear
attribute [instance] MonomialOrder.decidable

namespace MonomialOrder

variable {α : Type u} [DecidableEq α] [LinearLT α] [DecidableRel (α:=α) LT.lt]

protected
def gt (o : MonomialOrder α) : FreeCMonoid α → FreeCMonoid α → Prop :=
  flip o.lt

instance (o : MonomialOrder α) : StrictLinearOrder o.gt :=
  inferInstanceAs (StrictLinearOrder (flip o.lt))

instance (o : MonomialOrder α) : DecidableRel o.gt :=
  inferInstanceAs (DecidableRel (flip o.lt))

theorem mul_lt_mul_left (o : MonomialOrder α) : ∀ (x y z : FreeCMonoid α), o.lt x y → o.lt (z*x) (z*y) :=
    λ x y z =>
      FreeCMonoid.mul_comm x z ▸ FreeCMonoid.mul_comm y z ▸ o.mul_lt_mul_right x y z

--- Purely lexicographical order
@[inline]
def plex : MonomialOrder α where
  lt := InvImage (KVChain.rklex (λ _=>LT.lt)) FreeCMonoid.vars
  linear := {
    toTrans := inferInstance
    toIrreflective := inferInstance
    toTrichotomous := mkInstTrichotomousInvImage _ FreeCMonoid.vars $ @FreeCMonoid.eq _ _
  }
  decidable := inferInstance
  unit_antisymm x h := by
    cases x with | mk xv =>
    cases xv with | mk toList chain =>
    dsimp [OfNat.ofNat] at *
    cases toList
    case nil => rfl
    case cons x xs =>
      exact absurd (List.lex.nil x xs) h
  mul_lt_mul_right
  | FreeCMonoid.mk xvars, FreeCMonoid.mk yvars, FreeCMonoid.mk zvars => by
    unfold InvImage
    dsimp [HMul.hMul, Mul.mul]
    apply KVChain.rklex_mergeWith_right
    case hsf_right =>
      intro _ b₁ b
      cases b₁ with | mk m m_gt_zero =>
      cases b with | mk n n_gt_zero =>
      dsimp [LT.lt, FreeCMonoid.valAdd]
      unfold InvImage; dsimp
      calc
        m = 0 + m := (Nat.zero_add m).symm
        _ < n + m := Nat.add_lt_add_right n_gt_zero _
    case hsf_stab =>
      intro _ b₁ b₂ b hb₁b₂
      cases b₁ with | mk m₁ m₁_gt_zero =>
      cases b₂ with | mk m₂ m₂_gt_zero =>
      cases b with | mk n n_gt_zero =>
      dsimp [LT.lt, FreeCMonoid.valAdd]
      unfold InvImage; dsimp
      exact Nat.add_lt_add_right hb₁b₂ n

--- Degree-wise lexicographical order
@[inline]
def deglex : MonomialOrder α where
  lt := Lexcomb (InvImage Nat.lt FreeCMonoid.degree) plex.lt
  linear := inferInstance
  decidable := inferInstance
  unit_antisymm x h := by
    cases Nat.eq_zero_or_pos x.degree
    case inl hx => exact FreeCMonoid.eq_one_of_degree_zero hx
    case inr hx => exact absurd (Or.inl hx) h
  mul_lt_mul_right x y z hxy := by
    unfold InvImage at *
    cases hxy
    case inl hdeg =>
      apply Or.inl; dsimp at *
      rw [FreeCMonoid.degree_mul, FreeCMonoid.degree_mul]
      exact Nat.add_lt_add_right hdeg _
    case inr hxy =>
      apply Or.inr
      constructor
      case left =>
        unfold Incomp at *; dsimp at *
        have : x.degree = y.degree := Trichotomous.eq_of_incomp hxy.left
        rw [FreeCMonoid.degree_mul, FreeCMonoid.degree_mul, this]
        exact ⟨Nat.lt_irrefl _, Nat.lt_irrefl _⟩
      case right =>
        exact plex.mul_lt_mul_right x y z hxy.right

--- @todo Complete the proof that `devrevlex` is a monomial order.
@[inline]
def degrevlex : MonomialOrder α where
  lt := Lexcomb (InvImage Nat.lt FreeCMonoid.degree) (InvImage (KVChain.rklex (λ _=>LT.lt)) (KVChain.reverse ∘ FreeCMonoid.vars))
  linear := {
    toTrans := inferInstance
    toIrreflective := inferInstance
    toTrichotomous := sorry
  }
  decidable := inferInstance
  unit_antisymm := sorry
  mul_lt_mul_right := sorry

end MonomialOrder


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

Theory of topological rings.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.algebra.group
import Mathlib.ring_theory.ideal.basic
import Mathlib.PostPort

universes u l u_1

namespace Mathlib

/-- A topological semiring is a semiring where addition and multiplication are continuous. -/
class topological_semiring (α : Type u) [topological_space α] [semiring α]
    extends has_continuous_mul α, has_continuous_add α where

/-- A topological ring is a ring where the ring operations are continuous. -/
class topological_ring (α : Type u) [topological_space α] [ring α]
    extends has_continuous_mul α, has_continuous_add α where
  continuous_neg : continuous fun (a : α) => -a

protected instance topological_ring.to_topological_semiring (α : Type u) [topological_space α]
    [ring α] [t : topological_ring α] : topological_semiring α :=
  topological_semiring.mk

protected instance topological_ring.to_topological_add_group (α : Type u) [topological_space α]
    [ring α] [t : topological_ring α] : topological_add_group α :=
  topological_add_group.mk topological_ring.continuous_neg

/-- In a topological ring, the left-multiplication `add_monoid_hom` is continuous. -/
theorem mul_left_continuous {α : Type u} [topological_space α] [ring α] [topological_ring α]
    (x : α) : continuous ⇑(add_monoid_hom.mul_left x) :=
  continuous.mul continuous_const continuous_id

/-- In a topological ring, the right-multiplication `add_monoid_hom` is continuous. -/
theorem mul_right_continuous {α : Type u} [topological_space α] [ring α] [topological_ring α]
    (x : α) : continuous ⇑(add_monoid_hom.mul_right x) :=
  continuous.mul continuous_id continuous_const

/-- The closure of an ideal in a topological ring as an ideal. -/
def ideal.closure {α : Type u_1} [topological_space α] [comm_ring α] [topological_ring α]
    (S : ideal α) : ideal α :=
  submodule.mk (closure ↑S) sorry sorry sorry

@[simp] theorem ideal.coe_closure {α : Type u_1} [topological_space α] [comm_ring α]
    [topological_ring α] (S : ideal α) : ↑(ideal.closure S) = closure ↑S :=
  rfl

protected instance topological_ring_quotient_topology {α : Type u_1} [topological_space α]
    [comm_ring α] (N : ideal α) : topological_space (ideal.quotient N) :=
  id quotient.topological_space

theorem quotient_ring_saturate {α : Type u_1} [comm_ring α] (N : ideal α) (s : set α) :
    ⇑(ideal.quotient.mk N) ⁻¹' (⇑(ideal.quotient.mk N) '' s) =
        set.Union fun (x : ↥N) => (fun (y : α) => subtype.val x + y) '' s :=
  sorry

theorem quotient_ring.is_open_map_coe {α : Type u_1} [topological_space α] [comm_ring α]
    (N : ideal α) [topological_ring α] : is_open_map ⇑(ideal.quotient.mk N) :=
  sorry

theorem quotient_ring.quotient_map_coe_coe {α : Type u_1} [topological_space α] [comm_ring α]
    (N : ideal α) [topological_ring α] :
    quotient_map
        fun (p : α × α) =>
          (coe_fn (ideal.quotient.mk N) (prod.fst p), coe_fn (ideal.quotient.mk N) (prod.snd p)) :=
  sorry

protected instance topological_ring_quotient {α : Type u_1} [topological_space α] [comm_ring α]
    (N : ideal α) [topological_ring α] : topological_ring (ideal.quotient N) :=
  topological_ring.mk
    (eq.mpr
      ((fun (f f_1 : ideal.quotient N → ideal.quotient N) (e_3 : f = f_1) =>
          congr_arg continuous e_3)
        (fun (a : ideal.quotient N) => -a)
        (quotient.lift (Quot.mk setoid.r ∘ fun (a : α) => -a)
          (submodule.quotient.has_neg._proof_1 N))
        (Eq.refl fun (a : ideal.quotient N) => -a))
      (continuous_quotient_lift (submodule.quotient.has_neg._proof_1 N)
        (continuous.comp continuous_quot_mk continuous_neg)))

end Mathlib


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

import linear_algebra.basic
import order.atoms

/-!
# Simple Modules

## Main Definitions
  * `is_simple_module` indicates that a module has no proper submodules
  (the only submodules are `⊥` and `⊤`).
  * `is_semisimple_module` indicates that every submodule has a complement, or equivalently,
    the module is a direct sum of simple modules.
  * A `division_ring` structure on the endomorphism ring of a simple module.

## Main Results
  * Schur's Lemma: `bijective_or_eq_zero` shows that a linear map between simple modules
  is either bijective or 0, leading to a `division_ring` structure on the endomorphism ring.

## TODO
  * Artin-Wedderburn Theory
  * Unify with the work on Schur's Lemma in a category theory context

-/

variables (R : Type*) [ring R] (M : Type*) [add_comm_group M] [module R M]

/-- A module is simple when it has only two submodules, `⊥` and `⊤`. -/
abbreviation is_simple_module := (is_simple_order (submodule R M))

/-- A module is semisimple when every submodule has a complement, or equivalently, the module
  is a direct sum of simple modules. -/
abbreviation is_semisimple_module := (is_complemented (submodule R M))

-- Making this an instance causes the linter to complain of "dangerous instances"
theorem is_simple_module.nontrivial [is_simple_module R M] : nontrivial M :=
⟨⟨0, begin
  have h : (⊥ : submodule R M) ≠ ⊤ := bot_ne_top,
  contrapose! h,
  ext,
  simp [submodule.mem_bot,submodule.mem_top, h x],
end⟩⟩

variables {R} {M} {m : submodule R M} {N : Type*} [add_comm_group N] [module R N]

theorem is_simple_module_iff_is_atom :
  is_simple_module R m ↔ is_atom m :=
begin
  rw ← set.is_simple_order_Iic_iff_is_atom,
  apply order_iso.is_simple_order_iff,
  exact submodule.map_subtype.rel_iso m,
end

namespace is_simple_module

variable [hm : is_simple_module R m]

@[simp]
lemma is_atom : is_atom m := is_simple_module_iff_is_atom.1 hm

end is_simple_module

theorem is_semisimple_of_Sup_simples_eq_top
  (h : Sup {m : submodule R M | is_simple_module R m} = ⊤) :
  is_semisimple_module R M :=
is_complemented_of_Sup_atoms_eq_top (by simp_rw [← h, is_simple_module_iff_is_atom])

namespace is_semisimple_module

variable [is_semisimple_module R M]

theorem Sup_simples_eq_top : Sup {m : submodule R M | is_simple_module R m} = ⊤ :=
begin
  simp_rw is_simple_module_iff_is_atom,
  exact Sup_atoms_eq_top,
end

instance is_semisimple_submodule {m : submodule R M} : is_semisimple_module R m :=
begin
  have f : submodule R m ≃o set.Iic m := submodule.map_subtype.rel_iso m,
  exact f.is_complemented_iff.2 is_modular_lattice.is_complemented_Iic,
end

end is_semisimple_module

theorem is_semisimple_iff_top_eq_Sup_simples :
  Sup {m : submodule R M | is_simple_module R m} = ⊤ ↔ is_semisimple_module R M :=
⟨is_semisimple_of_Sup_simples_eq_top, by { introI, exact is_semisimple_module.Sup_simples_eq_top }⟩

namespace linear_map

theorem injective_or_eq_zero [is_simple_module R M] (f : M →ₗ[R] N) :
  function.injective f ∨ f = 0 :=
begin
  rw [← ker_eq_bot, ← ker_eq_top],
  apply eq_bot_or_eq_top,
end

theorem injective_of_ne_zero [is_simple_module R M] {f : M →ₗ[R] N} (h : f ≠ 0) :
  function.injective f :=
f.injective_or_eq_zero.resolve_right h

theorem surjective_or_eq_zero [is_simple_module R N] (f : M →ₗ[R] N) :
  function.surjective f ∨ f = 0 :=
begin
  rw [← range_eq_top, ← range_eq_bot, or_comm],
  apply eq_bot_or_eq_top,
end

theorem surjective_of_ne_zero [is_simple_module R N] {f : M →ₗ[R] N} (h : f ≠ 0) :
  function.surjective f :=
f.surjective_or_eq_zero.resolve_right h

/-- **Schur's Lemma** for linear maps between (possibly distinct) simple modules -/
theorem bijective_or_eq_zero [is_simple_module R M] [is_simple_module R N]
  (f : M →ₗ[R] N) :
  function.bijective f ∨ f = 0 :=
begin
  by_cases h : f = 0,
  { right,
    exact h },
  exact or.intro_left _ ⟨injective_of_ne_zero h, surjective_of_ne_zero h⟩,
end

theorem bijective_of_ne_zero [is_simple_module R M] [is_simple_module R N]
  {f : M →ₗ[R] N} (h : f ≠ 0):
  function.bijective f :=
f.bijective_or_eq_zero.resolve_right h

/-- Schur's Lemma makes the endomorphism ring of a simple module a division ring. -/
noncomputable instance _root_.module.End.division_ring
  [decidable_eq (module.End R M)] [is_simple_module R M] :
  division_ring (module.End R M) :=
{ inv := λ f, if h : f = 0 then 0 else (linear_map.inverse f
    (equiv.of_bijective _ (bijective_of_ne_zero h)).inv_fun
    (equiv.of_bijective _ (bijective_of_ne_zero h)).left_inv
    (equiv.of_bijective _ (bijective_of_ne_zero h)).right_inv),
  exists_pair_ne := ⟨0, 1, begin
    haveI := is_simple_module.nontrivial R M,
    have h := exists_pair_ne M,
    contrapose! h,
    intros x y,
    simp_rw [ext_iff, one_apply, zero_apply] at h,
    rw [← h x, h y],
  end⟩,
  mul_inv_cancel := begin
    intros a a0,
    change (a * (dite _ _ _)) = 1,
    ext,
    rw [dif_neg a0, mul_eq_comp, one_apply, comp_apply],
    exact (equiv.of_bijective _ (bijective_of_ne_zero a0)).right_inv x,
  end,
  inv_zero := dif_pos rfl,
.. (module.End.ring : ring (module.End R M))}

end linear_map


/-
Copyright (c) 2022 Yuyang Zhao. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuyang Zhao
-/
import data.complex.exponential
import data.polynomial.basic
import data.polynomial.taylor
import data.polynomial.iterated_deriv
import ring_theory.algebraic
import measure_theory.integral.set_integral

noncomputable theory

open_locale big_operators polynomial
open finset

namespace nat

lemma desc_factorial_eq_prod_range (n : ℕ) :
  ∀ k, n.desc_factorial k = ∏ i in range k, (n - i)
| 0       := rfl
| (k + 1) := by rw [desc_factorial, prod_range_succ, mul_comm, desc_factorial_eq_prod_range k]

end nat

namespace polynomial

variables {R : Type*} [comm_semiring R] -- [semiring R]

lemma sum_ideriv_apply_of_lt' {p : R[X]} {n : ℕ} (hn : p.nat_degree < n) :
  ∑ i in range (p.nat_degree + 1), p.iterated_deriv i =
  ∑ i in range n, p.iterated_deriv i := by
{ obtain ⟨m, hm⟩ := nat.exists_eq_add_of_lt hn, rw [hm, add_right_comm],
  rw [sum_range_add _ _ m], convert (add_zero _).symm, apply sum_eq_zero,
  intros x hx, rw [add_comm, iterated_deriv, function.iterate_add_apply],
  convert iterate_derivative_zero, rw [iterate_derivative_eq_zero], exact lt_add_one _, }

lemma sum_ideriv_apply_of_le' {p : R[X]} {n : ℕ} (hn : p.nat_degree ≤ n) :
  ∑ i in range (p.nat_degree + 1), p.iterated_deriv i =
  ∑ i in range (n + 1), p.iterated_deriv i :=
sum_ideriv_apply_of_lt' (nat.lt_add_one_iff.mpr hn)

def sum_ideriv : R[X] →ₗ[R] R[X] :=
{ to_fun := λ p, ∑ i in range (p.nat_degree + 1), p.iterated_deriv i,
  map_add' := λ p q, by
  { let x := max ((p + q).nat_degree + 1) (max (p.nat_degree + 1) (q.nat_degree + 1)),
    have hpq : ((p + q).nat_degree + 1) ≤ x := le_max_left _ _,
    have hp : (p.nat_degree + 1) ≤ x := (le_max_left _ _).trans (le_max_right _ _),
    have hq : (q.nat_degree + 1) ≤ x := (le_max_right _ _).trans (le_max_right _ _),
    simp_rw [sum_ideriv_apply_of_lt' hpq, sum_ideriv_apply_of_lt' hp,
      sum_ideriv_apply_of_lt' hq, ← sum_add_distrib, iterated_deriv_add], },
  map_smul' := λ a p, by dsimp;
    simp_rw [sum_ideriv_apply_of_le' (nat_degree_smul_le _ _), iterated_deriv_smul, smul_sum] }

lemma sum_ideriv_apply (p : R[X]) :
  p.sum_ideriv = ∑ i in range (p.nat_degree + 1), p.iterated_deriv i := rfl

lemma sum_ideriv_apply_of_lt {p : R[X]} {n : ℕ} (hn : p.nat_degree < n) :
  p.sum_ideriv = ∑ i in range n, p.iterated_deriv i :=
sum_ideriv_apply_of_lt' hn

lemma sum_ideriv_apply_of_le {p : R[X]} {n : ℕ} (hn : p.nat_degree ≤ n) :
  p.sum_ideriv = ∑ i in range (n + 1), p.iterated_deriv i :=
sum_ideriv_apply_of_le' hn

lemma sum_ideriv_zero : (0 : R[X]).sum_ideriv = 0 :=
by rw [sum_ideriv_apply, nat_degree_zero, zero_add, sum_range_one, iterated_deriv_zero_right]

lemma sum_ideriv_C (a : R) : (C a).sum_ideriv = C a :=
by rw [sum_ideriv_apply, nat_degree_C, zero_add, sum_range_one, iterated_deriv_zero_right]

lemma sum_ideriv_eq_self_add (p : R[X]) :
  p.sum_ideriv = p + p.sum_ideriv.derivative := by
{ rw [sum_ideriv_apply, derivative_sum, sum_range_succ', sum_range_succ, add_comm,
    ← add_zero (finset.sum _ _)], simp_rw [← iterated_deriv_succ], congr',
  rw [iterated_deriv_eq_zero_of_nat_degree_lt _ _ (nat.lt_succ_self _)], }

lemma sum_ideriv_derivative (p : R[X]) :
  p.derivative.sum_ideriv = p.sum_ideriv.derivative := by
{ rw [sum_ideriv_apply_of_le ((nat_degree_derivative_le p).trans tsub_le_self),
    sum_ideriv_apply, derivative_sum],
  simp_rw [iterated_deriv, ← function.iterate_succ_apply, function.iterate_succ_apply'], }

def iterated_deriv_linear_map (n : ℕ) : R[X] →ₗ[R] R[X] :=
{ to_fun := λ p, p.iterated_deriv n,
  map_add' := λ p q, iterated_deriv_add p q n,
  map_smul' := λ a p, iterated_deriv_smul p n a }

lemma iterated_deriv_linear_map_apply (p : R[X]) (n : ℕ) :
  iterated_deriv_linear_map n p = p.iterated_deriv n := rfl

variables (f p q : R[X]) (n k : ℕ)

lemma coeff_iterated_deriv_as_prod_range' :
  ∀ m : ℕ, (iterated_deriv f k).coeff m = (∏ i in range k, (m + k - i)) • f.coeff (m + k) :=
begin
  induction k with k ih,
  { simp },
  intro m,
  calc (f.iterated_deriv k.succ).coeff m
      = (∏ i in range k, (m + k.succ - i)) • f.coeff (m + k.succ) * (m + 1) :
    by rw [iterated_deriv_succ, coeff_derivative, ih m.succ, nat.succ_add, nat.add_succ]
  ... = ((∏ i in range k, (m + k.succ - i)) * (m + 1)) • f.coeff (m + k.succ) :
    by rw [← nat.cast_add_one, ← nsmul_eq_mul', smul_smul, mul_comm]
  ... = (∏ i in range k.succ, (m + k.succ - i)) • f.coeff (m + k.succ) :
    by rw [prod_range_succ, add_tsub_assoc_of_le k.le_succ, nat.succ_sub le_rfl, tsub_self]
end

lemma coeff_iterated_deriv_as_desc_factorial (m : ℕ) :
  (iterated_deriv f k).coeff m = (m + k).desc_factorial k • f.coeff (m + k) :=
by rw [coeff_iterated_deriv_as_prod_range', ← nat.desc_factorial_eq_prod_range]

lemma iterated_deriv_X_pow :
  ∀ n : ℕ, iterated_deriv (X ^ k : R[X]) n = k.desc_factorial n • X ^ (k - n)
| 0       := by rw [iterated_deriv_zero_right, nat.desc_factorial, one_smul, tsub_zero]
| (n + 1) := by rw [iterated_deriv_succ, iterated_deriv_X_pow n, derivative_smul, derivative_X_pow,
  nat.desc_factorial, ← nsmul_eq_mul, smul_smul, mul_comm, tsub_tsub]

lemma iterated_deriv_taylor (p : R[X]) (r : R) :
  ∀ n : ℕ, (taylor r p).iterated_deriv n = taylor r (p.iterated_deriv n)
| 0       := by simp_rw [iterated_deriv_zero_right]
| (n + 1) := by simp_rw [iterated_deriv_succ, iterated_deriv_taylor n, taylor_apply,
  derivative_comp, derivative_add, derivative_X, derivative_C, add_zero, one_mul]

end polynomial

open polynomial
open_locale nat

namespace e_transcendental
open real

lemma lemma₁ (p : ℤ[X]) {x : ℝ} (hx : 0 < x) : ∃ (c ∈ set.Ioo 0 x),
  aeval x p.sum_ideriv - exp x * aeval 0 p.sum_ideriv = -(x * exp (x - c) * aeval c p) := by
{ obtain ⟨c, hc, h⟩ := exists_deriv_eq_slope (λ x, exp (-x) * aeval x p.sum_ideriv) hx _ _,
  { use [c, hc], dsimp only at h,
    rw [sub_zero, eq_div_iff hx.ne.symm, exp_neg 0, exp_zero, inv_one, one_mul] at h,
    replace h := (@mul_eq_mul_left_iff _ _ (exp x) _ _).mpr (or.inl h),
    rw [mul_sub, ← mul_assoc, ← mul_assoc, ← exp_add, add_neg_self, exp_zero, one_mul] at h,
    rw [← h, mul_comm, mul_assoc, ← mul_neg, mul_eq_mul_left_iff, neg_mul_eq_mul_neg], left,
    rw [exp_sub, div_mul_eq_mul_div, mul_div_assoc, mul_eq_mul_left_iff], left,
    rw [deriv_mul, _root_.deriv_exp, deriv_neg, div_eq_mul_inv, ← exp_neg, mul_comm _ (exp _),
      mul_assoc, ← mul_add, mul_eq_mul_left_iff], left,
    simp_rw [aeval_def, ← eval_map, polynomial.deriv, neg_one_mul, ← eval_neg, ← eval_add,
      derivative_map, ← polynomial.map_neg, ← polynomial.map_add],
    refine congr_arg _ (congr_arg _ _),
    rw [neg_add_eq_iff_eq_add, eq_add_neg_iff_add_eq, add_comm, ← sum_ideriv_eq_self_add],
    { exact differentiable_at.neg differentiable_at_id, },
    { exact differentiable_at.exp (differentiable_at.neg differentiable_at_id), },
    { simp_rw [aeval_def, ← eval_map], exact polynomial.differentiable_at _, }, },
  { exact continuous_on.mul (continuous_on.exp (continuous_on.neg continuous_on_id))
      (polynomial.continuous_on_aeval _), },
  { simp_rw [aeval_def, ← eval_map], exact differentiable_on.mul
      (differentiable_on.exp (differentiable_on.neg differentiable_on_id))
      (polynomial.differentiable_on _), }, }

lemma lemma₂ (ann : ℤ[X]) (hann : aeval (exp 1) ann = 0) (p : ℤ[X]) :
  ∃ (b : ℕ → ℝ) (hb : ∀ i < ann.nat_degree, b i ∈ set.Ioo 0 (i + 1 : ℝ)),
    ∑ i in range (ann.nat_degree + 1), ann.coeff i • aeval (i : ℝ) p.sum_ideriv =
    ∑ i in range ann.nat_degree, ann.coeff (i + 1) •
      -((i + 1) • (exp ((i + 1 : ℕ) - b i) * aeval (b i) p)) := by
{ have lt_succ : ∀ (i : ℕ), (0 : ℝ) < i + 1,
  { intros i, convert_to ((0 : ℕ) : ℝ) < (i + 1 : ℕ),
    { rw [nat.cast_zero] },
    { rw [nat.cast_add, nat.cast_one] },
    rw [nat.cast_lt], exact nat.zero_lt_succ _ },
  have lem := λ i, lemma₁ p (lt_succ i),
  let b := λ i, (lem i).some, use b,
  have hb : ∀ i, b i ∈ set.Ioo 0 (i + 1 : ℝ) := λ i, (lem i).some_spec.some,
  have hb' : ∀ (i : ℕ), aeval (i + 1 : ℝ) (sum_ideriv p) - exp (i + 1) * aeval 0 (sum_ideriv p) =
                        -((i + 1) * exp ((i + 1 : ℕ) - b i) * aeval (b i) p),
  { intros i, convert (lem i).some_spec.some_spec, rw [nat.cast_add, nat.cast_one], },
  use λ i _, hb i,
  have hc0 : (ann.coeff 0 : ℝ) = -∑ i in range ann.nat_degree, ann.coeff (i + 1) • exp 1 ^ (i + 1),
  { rw [eq_neg_iff_add_eq_zero, add_comm], convert hann,
    rw [aeval_eq_sum_range, sum_range_succ', pow_zero, int.smul_one_eq_coe], },
  simp_rw [← rpow_nat_cast, ← exp_mul, one_mul] at hc0,
  rw [sum_range_succ', zsmul_eq_mul, hc0, neg_mul, ← sub_eq_add_neg, sum_mul, ← sum_sub_distrib],
  congr, funext i, rw [smul_mul_assoc, ← smul_sub], apply congr_arg,
  specialize hb' i, rw [nat.cast_zero, nat.cast_add, nat.cast_one, hb',
                        nsmul_eq_mul, nat.cast_add, nat.cast_one, mul_assoc], }

lemma lemma₃ (p : ℤ[X]) (k : ℕ) : ∃ p', p.iterated_deriv k = k! * p' :=
by use ∑ (x : ℕ) in (p.iterated_deriv k).support, (x + k).choose k • C (p.coeff (x + k)) * X ^ x;
  conv_lhs { rw [(p.iterated_deriv k).as_sum_support_C_mul_X_pow], };
  rw [← nsmul_eq_mul, smul_sum]; congr'; funext i;
calc C ((p.iterated_deriv k).coeff i) * X ^ i
    = C ((i + k).desc_factorial k • p.coeff (i + k)) * X ^ i :
      by rw [coeff_iterated_deriv_as_desc_factorial]
... = C ((k! * (i + k).choose k) • p.coeff (i + k)) * X ^ i :
      by rw [nat.desc_factorial_eq_factorial_mul_choose]
... = (k! * (i + k).choose k) • C (p.coeff (i + k)) * X ^ i :
      by rw [smul_C]
... = k! • (i + k).choose k • C (p.coeff (i + k)) * X ^ i :
      by rw [mul_smul]
... = k! • ((i + k).choose k • C (p.coeff (i + k)) * X ^ i) :
      by rw [smul_mul_assoc]

lemma lemma₄ (p : ℤ[X]) (q : ℕ) {p' : ℤ[X]} (hp : p = X ^ q * p') {k : ℕ} (hk : k < q) :
  (p.iterated_deriv k).eval 0 = 0 := by
{ have h : ∀ x, (X : ℤ[X]) ^ (q - (k - x)) = X ^ 1 * X ^ (q - (k - x) - 1),
  { intros x, rw [← pow_add, add_tsub_cancel_of_le], rw [nat.lt_iff_add_one_le] at hk,
    exact (le_tsub_of_add_le_left hk).trans (tsub_le_tsub_left (tsub_le_self : _ ≤ k) _), },
  simp_rw [hp, iterated_deriv_mul, iterated_deriv_X_pow, ← smul_mul_assoc, smul_smul, h,
    ← mul_smul_comm, mul_assoc, ← mul_sum, eval_mul, pow_one, eval_X, zero_mul], }

lemma lemma₄' (p : ℤ[X]) (q : ℕ) {k : ℕ} (hk : q ≤ k) :
  ∃ n', (p.iterated_deriv k).eval 0 = q! * n' := by
{ obtain ⟨p', hp'⟩ := lemma₃ p k,
  use ↑(k.desc_factorial (k - q)) * eval 0 p',
  rw [hp', eval_mul, ← C_eq_nat_cast, eval_C,
    ← nat.factorial_mul_desc_factorial (tsub_le_self : k - q ≤ k), tsub_tsub_cancel_of_le hk,
    nat.cast_mul, mul_assoc], }

lemma lemma₅ (p : ℤ[X]) (q : ℕ) {p' : ℤ[X]} (hp : p = X ^ q * p') (k : ℕ) :
  ∃ n', (p.iterated_deriv k).eval 0 = q! * n' := by
{ by_cases hk : k < q,
  { use 0, rw [mul_zero, lemma₄ p q hp hk], },
  { rw [not_lt] at hk, exact lemma₄' p q hk, }, }

def F (n : ℕ) (q : ℕ) : ℤ[X] :=
X ^ q * ∏ i in range n, (X - C (i + 1 : ℤ)) ^ (q + 1)

lemma lemma₆_zero₁ (n : ℕ) (q : ℕ) {k : ℕ} (hk : k < q) :
  ((F n q).iterated_deriv k).eval 0 = 0 :=
lemma₄ (F n q) q rfl hk

lemma lemma₆_zero₂ (n : ℕ) (q : ℕ) {k : ℕ} (hk : q + 1 ≤ k) :
  ∃ n', ((F n q).iterated_deriv k).eval 0 = (q + 1)! * n' :=
lemma₄' (F n q) (q + 1) hk

lemma lemma₆_succ (n : ℕ) (q : ℕ) (k : ℕ) (x : ℕ) (hx : x < n) :
  ∃ n', ((F n q).iterated_deriv k).eval (x + 1) = (q + 1)! * n' := by
{ obtain h := lemma₅ (taylor (x + 1 : ℤ) (F n q)) (q + 1) _ k,
  rwa [iterated_deriv_taylor, taylor_eval, zero_add] at h, swap,
  rw [F, ← mul_prod_erase _ _ (mem_range.mpr hx), ← taylor_alg_hom_apply],
  simp_rw [_root_.map_mul, map_pow, _root_.map_sub, taylor_alg_hom_apply, taylor_X, taylor_C],
  rw [add_sub_cancel, ← mul_assoc, mul_comm (_ ^ q), mul_assoc], }

lemma lemma₇_zero (n : ℕ) (q : ℕ) :
  ∃ n', (F n q).sum_ideriv.eval 0 = q! * ∏ i in range n, (-(i + 1)) ^ (q + 1) + (q + 1)! * n' := by
{ let ub := max (q + 1) ((F n q).nat_degree + 1),
  let u := λ i, if h : q + 1 ≤ i then classical.some (lemma₆_zero₂ n q h) else 0,
  have hu : ∀ (i : ℕ) (h : q + 1 ≤ i), eval 0 ((F n q).iterated_deriv i) = (q + 1)! * u i :=
    λ i h, by simp only [u, dif_pos h]; exact classical.some_spec (lemma₆_zero₂ n q h),
  have := calc (F n q).sum_ideriv.eval 0
      = (∑ (i : ℕ) in range ub, (F n q).iterated_deriv i).eval 0 : _
  ... = ( ∑ (i : ℕ) in range q, (F n q).iterated_deriv i +
          (F n q).iterated_deriv q +
          ∑ (i : ℕ) in Ico (q + 1) ub, (F n q).iterated_deriv i ).eval 0 : _
  ... = (∑ (i : ℕ) in range q, (F n q).iterated_deriv i).eval 0 +
        ((F n q).iterated_deriv q).eval 0 +
        (∑ (i : ℕ) in Ico (q + 1) ub, (F n q).iterated_deriv i).eval 0 : by rw [eval_add, eval_add]
  ... = ∑ (i : ℕ) in range q, ((F n q).iterated_deriv i).eval 0 +
        q! * ∏ i in range n, (-(i + 1)) ^ (q + 1) +
        ∑ (i : ℕ) in Ico (q + 1) ub, ((F n q).iterated_deriv i).eval 0 : _
  ... = ∑ (i : ℕ) in range q, 0 +
        q! * ∏ i in range n, (-(i + 1)) ^ (q + 1) +
        ∑ (i : ℕ) in Ico (q + 1) ub, (q + 1)! * u i : _
  ... = q! * ∏ i in range n, (-(i + 1)) ^ (q + 1) +
        (q + 1)! * ∑ (i : ℕ) in Ico (q + 1) ub, u i : _,
  rw [this], use ∑ (i : ℕ) in Ico (q + 1) ub, u i,
  { rw [sum_ideriv_apply_of_lt],
    exact (nat.lt_add_one_iff.2 le_rfl).trans_le (le_max_right _ _), },
  { apply congr_arg,
    have h₁ : range ub = range (q + 1) ∪ Ico (q + 1) ub,
    { rw [range_eq_Ico, finset.Ico_union_Ico_eq_Ico (nat.zero_le _) (le_max_left _ _)], },
    rw [h₁, sum_union, sum_range_succ],
    rintros i h, rw [inf_eq_inter, mem_inter, mem_range, mem_Ico, nat.lt_add_one_iff] at h,
    exact h.1.not_lt h.2.1, },
  { congr' 2, { rw [← coe_eval_ring_hom, map_sum], },
    { rw [F, iterated_deriv_mul, sum_range_succ', eval_add],
      convert_to 0 + (q! : ℤ) * ∏ (i : ℕ) in range n, (-(i + 1 : ℤ)) ^ (q + 1) =
                 q! * ∏ (i : ℕ) in range n, (-(i + 1)) ^ (q + 1),
      { congr' 1,
        { rw [← coe_eval_ring_hom, map_sum], apply sum_eq_zero, intros x hx, rw [mem_range] at hx,
          rw [coe_eval_ring_hom, eval_smul, iterated_deriv_X_pow, tsub_tsub_cancel_of_le, pow_add,
              pow_one, eval_mul, eval_smul, eval_mul, eval_X,
              mul_zero, smul_zero, zero_mul, smul_zero],
          rwa [nat.add_one_le_iff], },
        { simp_rw [nat.choose_zero_right, one_smul, tsub_zero, iterated_deriv_X_pow, tsub_self,
            pow_zero, smul_one_mul, nat.desc_factorial_self, eval_smul,
            iterated_deriv_zero_right, eval_prod, eval_pow, eval_sub, eval_X, eval_C, zero_sub],
          simp only [nsmul_eq_mul, mul_eq_mul_left_iff, prod_congr, eq_self_iff_true], }, },
        rw [zero_add], },
    { rw [← coe_eval_ring_hom, map_sum], }, },
  { congr' 1, congr' 1,
    { rw [sum_congr], refl, intros x hx, rw [mem_range] at hx, rwa [lemma₆_zero₁], },
    { rw [sum_congr], refl, intros x hx, rw [mem_Ico] at hx, exact hu x hx.1, }, },
  { rw [sum_eq_zero (λ _ _, rfl)], congr' 1, rw [zero_add], rw [mul_sum], }, }

lemma lemma₇_succ (n : ℕ) (q : ℕ) (x : ℕ) (hx : x < n) :
  ∃ n', (F n q).sum_ideriv.eval (x + 1) = (q + 1)! * n' := by
{ let c := λ k, classical.some (lemma₆_succ n q k x hx),
  have hc : ∀ (k : ℕ), eval (↑x + 1) ((F n q).iterated_deriv k) = (q + 1)! * c k :=
    λ k, classical.some_spec (lemma₆_succ n q k x hx),
  simp_rw [sum_ideriv_apply, ← coe_eval_ring_hom, map_sum, coe_eval_ring_hom, hc, ← mul_sum],
  use (range ((F n q).nat_degree + 1)).sum c, }

lemma hF (q : ℕ) (ann : ℤ[X]) (hann : aeval (exp 1) ann = 0) :
  ∃ (b : ℕ → ℝ) (hb : ∀ i < ann.nat_degree, b i ∈ set.Ioo 0 (i + 1 : ℝ)),
    ∑ i in range (ann.nat_degree + 1),
      ann.coeff i • aeval (i : ℝ) (F ann.nat_degree q).sum_ideriv =
    ∑ i in range ann.nat_degree, ann.coeff (i + 1) •
      -((i + 1) • (exp ((i + 1 : ℕ) - b i) * aeval (b i) (F ann.nat_degree q))) :=
lemma₂ ann hann (F ann.nat_degree q)

lemma hF_lhs' (q : ℕ) (ann : ℤ[X]) (hann : aeval (exp 1) ann = 0) :
  ∃ n',
    ∑ i in range (ann.nat_degree + 1),
      ann.coeff i • aeval (i : ℝ) (F ann.nat_degree q).sum_ideriv =
    (q! * (ann.coeff 0 * ∏ i in range ann.nat_degree, (-(i + 1 : ℕ)) ^ (q + 1)) +
      (q + 1)! * n' : ℤ) := by
{ obtain ⟨uz, huz⟩ := lemma₇_zero ann.nat_degree q,
  let us := λ x, if hx : x < ann.nat_degree then
    classical.some (lemma₇_succ ann.nat_degree q x hx) else 0,
  have hus : ∀ (x : ℕ) (hx : x < ann.nat_degree),
    eval (x + 1 : ℤ) (sum_ideriv (F ann.nat_degree q)) = (q + 1)! * us x :=
  λ x (hx : x < ann.nat_degree), by simp only [us, dif_pos hx]; exact
    classical.some_spec (lemma₇_succ ann.nat_degree q x hx),
  use ann.coeff 0 * uz + ∑ i in range ann.nat_degree, ann.coeff (i + 1) * us i,
  convert_to ↑∑ i in range (ann.nat_degree + 1),
    ann.coeff i * (F ann.nat_degree q).sum_ideriv.eval i = _,
  { rw [int.cast_sum, sum_congr], refl, intros x hx,
    rw [int.cast_mul, zsmul_eq_mul, mul_eq_mul_left_iff], left,
    rw [aeval_def, eval₂_eq_eval_map],
    simp only [ring_hom.eq_int_cast, eval_nat_cast_map], },
  { rw [int.cast_inj, sum_range_succ', int.coe_nat_zero, huz, add_comm, mul_add,
      add_assoc, mul_add], simp_rw [← mul_assoc, mul_comm (ann.coeff 0)], congr' 2,
    convert_to _ = ↑(q + 1)! * ∑ i in range ann.nat_degree, ann.coeff (i + 1) * us i,
    rw [mul_sum, sum_congr], refl, intros x hx, rw [mem_range] at hx,
    rw [int.coe_nat_succ, hus x hx, ← mul_assoc, ← mul_assoc, mul_comm (ann.coeff (x + 1))], }, }

lemma hF_lhs (q : ℕ) (prime_q : q.prime) (ann : ℤ[X]) (hann : aeval (exp 1) ann = 0)
  (coeff0 : ann.coeff 0 ≠ 0) (hcq : (ann.coeff 0).nat_abs + 1 ≤ q) (hnq : ann.nat_degree + 1 ≤ q) :
  ∃ (n' r : ℤ) (hr : 0 < r ∧ r < q),
    ∑ i in range (ann.nat_degree + 1),
      ann.coeff i • aeval (i : ℝ) (F ann.nat_degree (q - 1)).sum_ideriv =
    ((q - 1)! * r + q! * n' : ℤ) := by
{ obtain ⟨n'', h''⟩ := hF_lhs' (q - 1) ann hann,
  have q_0 : q ≠ 0 := prime_q.ne_zero,
  have q_pos : 0 < q := nat.pos_of_ne_zero q_0,
  have int_q_0 : (q : ℤ) ≠ 0 := int.coe_nat_ne_zero.mpr q_0,
  have int_q_pos : 0 < (q : ℤ) := int.coe_nat_pos.mpr q_pos,
  have prime_int_q := nat.prime_iff_prime_int.mp prime_q,
  rw [tsub_add_cancel_of_le (nat.one_le_of_lt q_pos)] at h'',
  let n : ℤ := ann.coeff 0 * ∏ (i : ℕ) in range ann.nat_degree, (-(i + 1 : ℕ)) ^ q,
  let n' := n / q + n'', let r := n % q, have h' := n.div_add_mod (q + 1),
  use [n', r], refine ⟨⟨_, int.mod_lt_of_pos _ int_q_pos⟩, _⟩,
  { simp only [r, n], apply lt_of_le_of_ne (int.mod_nonneg _ int_q_0),
    symmetry, rw [ne.def, euclidean_domain.mod_eq_zero], intros q_dvd,
    replace q_dvd := (int.prime.dvd_mul' prime_q q_dvd).resolve_left _, swap,
    { rw [int.coe_nat_dvd_left], apply nat.not_dvd_of_pos_of_lt,
      exacts [int.nat_abs_pos_of_ne_zero coeff0, nat.add_one_le_iff.mp hcq], },
    rw [prime.dvd_finset_prod_iff prime_int_q] at q_dvd,
    obtain ⟨a, ha, q_dvd⟩ := q_dvd, replace q_dvd := prime_int_q.dvd_of_dvd_pow q_dvd,
    rw [int.coe_nat_dvd_left, int.nat_abs_neg, int.nat_abs_of_nat] at q_dvd,
    revert q_dvd, apply nat.not_dvd_of_pos_of_lt (nat.zero_lt_succ _),
    rw [mem_range, ← add_lt_add_iff_right 1] at ha, exact ha.trans_le hnq, },
  simp_rw [h'', int.cast_inj, n', r, mul_add, ← add_assoc, add_left_inj,
    ← nat.mul_factorial_pred q_pos, int.coe_nat_mul, mul_comm (q : ℤ), mul_assoc, ← mul_add],
  refine (mul_right_inj' _).mpr _, rw [int.coe_nat_ne_zero], exact nat.factorial_ne_zero _,
  rw [int.mod_add_div], }

lemma abs_aeval_le (n : ℕ) (q : ℕ) (x : ℝ) (hx : 0 ≤ x ∧ x ≤ n) :
  |(aeval x (F n q))| ≤ (n ^ q * (n ^ (q + 1)) ^ n : ℕ) := by
{ simp_rw [F, map_mul, map_pow, map_prod, map_pow, map_sub, aeval_X, aeval_C],
  simp only [algebra_map_int_eq, int.cast_coe_nat, int.cast_add, ring_hom.eq_int_cast,
    int.cast_one, prod_congr],
  simp_rw [abs_mul, nat.cast_mul, nat.cast_pow], apply mul_le_mul,
  { rw [abs_pow], apply pow_le_pow_of_le_left (abs_nonneg x), rw [abs_le],
    refine ⟨(right.neg_nonpos_iff.mpr _).trans hx.1, hx.2⟩, exact nat.cast_nonneg n, },
  { rw [abs_prod, pow_eq_prod_const], apply prod_le_prod, { exact λ _ _, abs_nonneg _, },
    intros i hi, rw [abs_pow], apply pow_le_pow_of_le_left (abs_nonneg (x - (i + 1))), rw [abs_le],
    rw [mem_range, nat.lt_iff_add_one_le] at hi, split,
    simp only [neg_le_sub_iff_le_add], apply le_add_of_nonneg_of_le hx.1,
    rwa [← nat.cast_add_one, nat.cast_le], refine (sub_le_self _ _).trans hx.2,
    rw [← nat.cast_add_one], exact nat.cast_nonneg _, },
  exacts [abs_nonneg _, pow_nonneg (nat.cast_nonneg _) _], }

lemma pow_le_sq_pow (n k : ℕ) (h : 0 < n) : n ^ k ≤ (n ^ 2) ^ (k / 2 + 1) := by
{ rw [← pow_mul], apply nat.pow_le_pow_of_le_right h,
  refine (nat.lt_mul_div_succ _ zero_lt_two).le, }

lemma hF_rhs (ann : ℤ[X]) (hann : aeval (exp 1) ann = 0) (ann0 : ann ≠ 0) :
  ∃ Q, ∀ q ≥ Q,
    ∀ (b : ℕ → ℝ) (hb : ∀ i < ann.nat_degree, b i ∈ set.Ioo 0 ((i + 1 : ℕ) : ℝ)),
      |∑ i in range ann.nat_degree, ann.coeff (i + 1) •
        -((i + 1) • (exp ((i + 1 : ℕ) - b i) * aeval (b i) (F ann.nat_degree q) : ℝ))| < q! := by
{ by_cases n0 : ann.nat_degree = 0,
  { have h := eq_C_of_nat_degree_eq_zero n0,
    rw [h, aeval_C, algebra_map_int_eq, ring_hom.eq_int_cast, int.cast_eq_zero] at hann,
    rw [hann, C_0] at h, exact absurd h ann0, },
  let coeff_max := ((range ann.nat_degree).image (λ i, |(ann.coeff (i + 1) : ℝ)|)).max'
    (nonempty.image (nonempty_range_iff.mpr n0) _),
  let Q := (((ann.nat_degree ^ ann.nat_degree) ^ 2) ^ 2 +
    ⌈ann.nat_degree • coeff_max * ann.nat_degree • exp (ann.nat_degree)⌉₊ + 1) * 2 + 1,
  use Q, intros q hq b hb',
  have n_pos := nat.pos_of_ne_zero n0,
  have coeff_max_nonneg : 0 ≤ coeff_max := by {
    refine (abs_nonneg (ann.coeff (0 + 1) : ℝ)).trans (le_max' _ _ (mem_image.mpr ⟨0, _, rfl⟩)),
    rwa [mem_range], },
  refine (calc |∑ i in range ann.nat_degree, ann.coeff (i + 1) •
          -((i + 1) • (exp ((i + 1 : ℕ) - b i) * aeval (b i) (F ann.nat_degree q)))|
      ≤ ∑ i in range ann.nat_degree, |ann.coeff (i + 1) •
          -((i + 1) • (exp ((i + 1 : ℕ) - b i) * aeval (b i) (F ann.nat_degree q)))|
      : abv_sum_le_sum_abv _ _
  ... ≤ ∑ i in range ann.nat_degree, coeff_max *
          (ann.nat_degree • (exp ann.nat_degree *
           (ann.nat_degree ^ q * (ann.nat_degree ^ (q + 1)) ^ ann.nat_degree : ℕ))) : by
      { apply sum_le_sum, intros i hi, rw [zsmul_eq_mul, abs_mul, abs_neg],
        have hi' := mem_range.mp hi, have hi'' := nat.add_one_le_iff.mpr hi',
        refine mul_le_mul _ _ (abs_nonneg _) coeff_max_nonneg,
        { apply le_max', rw [mem_image], exact ⟨i, hi, rfl⟩, },
        rw [abs_nsmul, nsmul_eq_mul, nsmul_eq_mul],
        refine mul_le_mul (by rwa [nat.cast_le]) _ (abs_nonneg _) (nat.cast_nonneg _),
        rw [abs_mul], refine mul_le_mul _ _ (abs_nonneg _) ((exp_pos _).le),
        { rw [abs_exp, exp_le_exp],
          refine (sub_le_self _ (hb' i hi').1.le).trans (nat.cast_le.mpr hi''), },
        refine abs_aeval_le ann.nat_degree q (b i) ⟨(hb' i hi').1.le, _⟩,
        exact (hb' i hi').2.le.trans (nat.cast_le.mpr hi''), }
  ... ≤ ann.nat_degree • (coeff_max *
          (ann.nat_degree • (exp ann.nat_degree *
           (ann.nat_degree ^ q * (ann.nat_degree ^ (q + 1)) ^ ann.nat_degree : ℕ))))
      : by rw [sum_const, card_range]).trans_lt _,
  have le_pow_self : ann.nat_degree ≤ ann.nat_degree ^ ann.nat_degree,
  { cases ann.nat_degree, { exact nat.zero_le _, },
    rw [pow_succ], apply le_mul_of_one_le_right (nat.zero_le _),
    rw [← one_pow n], exact pow_le_pow_of_le (le_add_of_nonneg_left (nat.zero_le _)), },
  have one_le_np := (nat.one_le_iff_ne_zero.mpr n0).trans le_pow_self,
  simp_rw [← smul_mul_assoc, ← mul_assoc, ← pow_mul, mul_comm, pow_mul],
  refine (_ : _ ≤ ((⌈(ann.nat_degree • coeff_max) * (ann.nat_degree • exp (ann.nat_degree))⌉₊ *
    (((ann.nat_degree ^ ann.nat_degree) ^ 2) ^ 2) ^ ((q + 1) / 2 + 1) : ℕ) : ℝ)).trans_lt _,
  { rw [nat.cast_mul (nat.ceil _)],
    refine mul_le_mul (nat.le_ceil _) _ (nat.cast_nonneg _) (le_trans _ (nat.le_ceil _)),
    rw [nat.cast_le],
    refine le_trans _ (pow_le_sq_pow _ (q + 1) ((one_le_sq_iff (nat.zero_le _)).mpr one_le_np)),
    rw [pow_two, mul_pow], refine mul_le_mul_of_nonneg_right _ (nat.zero_le _),
    exact calc ann.nat_degree ^ q
        = ann.nat_degree ^ q * 1
        : (mul_one _).symm
    ... ≤ (ann.nat_degree ^ ann.nat_degree) ^ q * (ann.nat_degree ^ ann.nat_degree)
        : mul_le_mul (pow_le_pow_of_le le_pow_self) one_le_np (zero_le _) (zero_le _)
    ... = (ann.nat_degree ^ ann.nat_degree) ^ (q + 1)
        : by rw [pow_add, pow_one],
    exact mul_nonneg (nsmul_nonneg coeff_max_nonneg _) (nsmul_nonneg (exp_pos _).le _), },
  have hq' := le_of_mul_le_mul_right
    (calc ((((ann.nat_degree ^ ann.nat_degree) ^ 2) ^ 2 +
        ⌈ann.nat_degree • coeff_max * ann.nat_degree • exp (ann.nat_degree)⌉₊ + 1 + 1) * 2)
      = Q + 1                         : by rw [add_mul, mul_two 1, ← add_assoc]
  ... ≤ q + 1                         : add_le_add_right hq 1
  ... = (q + 1) * 2 - (q + 1)         : by rw [mul_two, add_tsub_cancel_left]
  ... ≤ (q + 1) * 2 - (q + 1) / 2 * 2 : tsub_le_tsub_left (nat.div_mul_le_self _ _) _
  ... = ((q + 1) - (q + 1) / 2) * 2   : by rw [tsub_mul]) zero_lt_two,
  simp_rw [le_tsub_iff_left (nat.div_le_self _ _), ← add_assoc, add_le_add_iff_right] at hq',
  obtain ⟨c, hc⟩ := nat.exists_eq_add_of_le hq', rw [nat.cast_lt], conv_rhs { rw [hc], },
  refine lt_of_lt_of_le _ (nat.factorial_le (nat.le_add_right _ c)), rw [nat.factorial],
  have nppp_pos := pow_pos (pow_pos (pow_pos n_pos ann.nat_degree) 2) 2,
  have one_le_nppp := nat.one_le_of_lt nppp_pos,
  refine mul_lt_mul _ _ (pow_pos nppp_pos _) (nat.zero_le _),
  { rw [nat.lt_succ_iff], exact nat.le_add_left _ _, },
  refine le_trans _ (nat.factorial_le (nat.le_add_right _ _)),
  conv_rhs { rw [add_comm, ← (@tsub_add_cancel_iff_le _ _ _ _ 1 _).mpr one_le_nppp, add_assoc], },
  refine le_trans _ nat.factorial_mul_pow_le_factorial,
  rw [nat.succ_eq_add_one, tsub_add_cancel_of_le one_le_nppp, add_comm 1],
  exact le_mul_of_one_le_left (nat.zero_le _) (nat.one_le_of_lt (nat.factorial_pos _)), }

end e_transcendental

lemma remove_X_factor {x : ℝ} (hx : x ≠ 0) (p' : ℤ[X]) (p0' : p' ≠ 0) (p_ann' : aeval x p' = 0) :
  ∃ (p : ℤ[X]) (p0 : p ≠ 0) (hp : ¬ X ∣ p), aeval x p = 0 := by
{ revert p0' p_ann', refine unique_factorization_monoid.induction_on_prime p' (absurd rfl) _ _,
  { intros p p_unit p0 p_ann, obtain ⟨r, unit_r, hr⟩ := polynomial.is_unit_iff.mp p_unit,
    rw [← hr, aeval_C, algebra_map_int_eq, ring_hom.eq_int_cast, int.cast_eq_zero] at p_ann,
    rw [int.is_unit_iff, p_ann, zero_eq_neg] at unit_r,
    exact (unit_r.elim zero_ne_one one_ne_zero).elim, },
  { intros a p a0 prime_p h pa0 pa_ann, obtain ⟨p0, a0⟩ := mul_ne_zero_iff.mp pa0,
    rw [aeval_mul, mul_eq_zero] at pa_ann,
    refine pa_ann.elim (λ p_ann, _) (λ a_ann, h a0 a_ann),
    refine ⟨p, p0, λ hX, _, p_ann⟩,
    obtain ⟨u, hu⟩ := (@prime_X ℤ _ _).associated_of_dvd prime_p hX,
    obtain ⟨r, unit_r, hr⟩ := polynomial.is_unit_iff.mp u.is_unit, rw [int.is_unit_iff] at unit_r,
    rw [← hu, ← hr, aeval_mul, aeval_X, aeval_C,
        algebra_map_int_eq, ring_hom.eq_int_cast] at p_ann,
    exact unit_r.elim (λ h', hx (by rwa [h', int.cast_one, mul_one] at p_ann))
      (λ h', hx
        (by rwa [h', int.cast_neg, mul_neg, int.cast_one, mul_one, neg_eq_zero] at p_ann)), }, }

section
open real e_transcendental

theorem e_transcendental : transcendental ℤ (exp 1) := by
{ rintro ⟨p', ⟨p0', p_ann'⟩⟩,
  obtain ⟨p, p0, hp, p_ann⟩ := remove_X_factor (exp_ne_zero 1) p' p0' p_ann',
  have coeff0 : p.coeff 0 ≠ 0 := (not_iff_not_of_iff polynomial.X_dvd_iff).mp hp,
  obtain ⟨Q, hQ⟩ := hF_rhs p p_ann p0,
  obtain ⟨q, hq, prime_q⟩ :=
    nat.exists_infinite_primes (max (Q + 1) (max ((p.coeff 0).nat_abs + 1) (p.nat_degree + 1))),
  have hQq : Q + 1 ≤ q                   := le_of_max_le_left hq,
  have hcq : (p.coeff 0).nat_abs + 1 ≤ q := le_of_max_le_left (le_of_max_le_right hq),
  have hnq : p.nat_degree + 1 ≤ q        := le_of_max_le_right (le_of_max_le_right hq),
  have q_0 : q ≠ 0 := prime_q.ne_zero,
  have q_pos : 0 < q := nat.pos_of_ne_zero q_0,
  obtain ⟨nl, r, hr, hl⟩ := hF_lhs q prime_q p p_ann coeff0 hcq hnq,
  obtain ⟨b, hb, h⟩ := hF (q - 1) p p_ann,
  replace hb : ∀ (i : ℕ), i < p.nat_degree → b i ∈ set.Ioo 0 ((i + 1 : ℕ) : ℝ),
  { intros i hi, convert hb i hi, rw [nat.cast_add, nat.cast_one], },
  --, rw [← nat.cast_one, ← nat.cast_add]
  specialize hQ (q - 1) (le_tsub_of_add_le_right hQq) b hb,
  rw [hl] at h, rw [← h] at hQ,
  replace hQ : ((|(q - 1)! * r + q! * nl| : ℤ) : ℝ) < (((q - 1)! : ℤ) : ℝ),
  { norm_cast at ⊢ hQ, exact hQ, },
  rw [int.cast_lt] at hQ,
  simp_rw [← nat.mul_factorial_pred q_pos, mul_comm q, int.coe_nat_mul, mul_assoc, ← mul_add,
    abs_mul, int.coe_nat_abs] at hQ,
  conv_rhs at hQ { rw [← mul_one ((q - 1)! : ℤ)], },
  replace hQ := lt_of_mul_lt_mul_left hQ (int.coe_nat_nonneg _),
  rw [← int.zero_add 1, int.lt_add_one_iff] at hQ,
  replace hQ := le_antisymm hQ (abs_nonneg _),
  rw [abs_eq_zero] at hQ,
  have hQ_mod : (r + ↑q * nl) % q = r :=
    by rw [int.add_mod, int.mul_mod, int.mod_self, zero_mul, int.zero_mod, add_zero, int.mod_mod,
      int.mod_eq_of_lt hr.1.le hr.2],
  have hQ_mod_pos : 0 < (r + ↑q * nl) % ↑q := hQ_mod.symm ▸ hr.1,
  exact (ne_of_lt hQ_mod_pos).symm (hQ.symm ▸ int.zero_mod _), }

end


import .love02_backward_proofs_exercise_sheet

/-! # LoVe Homework 3: Forward Proofs

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1 (6 points): Connectives and Quantifiers

1.1 (2 points). We have proved or stated three of the six possible implications
between `excluded_middle`, `peirce`, and `double_negation`. Prove the three
missing implications using structured proofs, exploiting the three theorems we
already have. -/

namespace backward_proofs

#check peirce_of_em
#check dn_of_peirce
#check sorry_lemmas.em_of_dn

lemma peirce_of_dn :
  double_negation → peirce :=
sorry

lemma em_of_peirce :
  peirce → excluded_middle :=
sorry

lemma dn_of_em :
  excluded_middle → double_negation :=
sorry

end backward_proofs

/-! 1.2 (4 points). Supply a structured proof of the commutativity of `∧` under
an `∃` quantifier, using no other lemmas than the introduction and elimination
rules for `∃`, `∧`, and `↔`. -/

lemma exists_and_commute {α : Type} (p q : α → Prop) :
  (∃x, p x ∧ q x) ↔ (∃x, q x ∧ p x) :=
sorry

/-! ## Question 2 (3 points): Fokkink Logic Puzzles

If you have studied Logic and Sets with Prof. Fokkink, you will know he is fond
of logic puzzles. This question is a tribute.

Recall the following tactical proof: -/

lemma weak_peirce :
  ∀a b : Prop, ((((a → b) → a) → a) → b) → b :=
begin
  intros a b habaab,
  apply habaab,
  intro habaa,
  apply habaa,
  intro ha,
  apply habaab,
  intro haba,
  apply ha
end

/-! 2.1 (1 point). Prove the same lemma again, this time by providing a proof
term.

Hint: There is an easy way. -/

lemma weak_peirce₂ :
  ∀a b : Prop, ((((a → b) → a) → a) → b) → b :=
sorry

/-! 2.2 (2 points). Prove the same Fokkink lemma again, this time by providing a
structured proof, with `assume`s and `show`s. -/

lemma weak_peirce₃ :
  ∀a b : Prop, ((((a → b) → a) → a) → b) → b :=
sorry

end LoVe


import Mathlib.Tactic.Basic
import BackwardProofs.BasicTactics
/-!
## Reasoning about Connectives and Quantifiers

Before we learn to reason about natural numbers, lists, or other data types, we
must first learn to reason about the logical connectives and quantifiers of Lean’s
logic. Let us start with a simple example: commutativity of conjunction (`∧`).
-/
lemma and_swap (a b : Prop) :
a ∧ b → b ∧ a := by
  intro hab
  apply And.intro
  apply And.right
  exact hab
  apply And.left
  exact hab
/-!
At this point, we recommend that you move the cursor over each line in the above example to see the
sequence of proof states. By putting the cursor over each bubble at the end of the line, you can see
the effect of the command on that line. At the end of the last line Lean simply reports “goals
accomplished 🎉” meaning that no subgoals remain to be proved.

The proof is a typical `intro–apply–exact` mixture. It uses the lemmas

```
And.intro : ?a → ?b → ?a ∧ ?b
And.left : ?a ∧ ?b → ?a
And.right : ?a ∧ ?b → ?b
```
where the question marks (?) indicate variables that can be instantiated—for example, by matching
the goal’s target against the conclusion of a lemma.

The three lemmas above are the introduction rule and the two elimination
rules associated with conjunction. An introduction rule for a symbol (e.g., `∧`) is
a lemma whose conclusion contains that symbol. Dually, an elimination rule has
the symbol in an assumption. In the above proof, we apply the introduction rule
associated with `∧` to prove the goal `⊢ b ∧ a`, and we apply the two elimination
rules to extract `b` and `a` from the hypothesis `a ∧ b`.

Question marks can also arise in goals. They indicate variables that can be
instantiated arbitrarily. In the middle of the proof above, right after the tactic
apply `And.right`, we have the goal

```lean
a b : Prop, hab : a ∧ b ⊢ ?left.a ∧ b
```
The tactic exact `hab` matches `?left.a` (in the target) with `a` (in `hab`). Because variables can
occur both in the hypothesis or lemma that is `apply`d and in the target, in general the procedure
used to instantiate variables to make two terms syntactically equal is called _unification_. Matching
is a special case of unification where one of the two terms contains no variables. In practice,
goals with variables are rare, so Lean’s unification usually amounts to matching.

    -- BUGBUG: no idea what most of that paragraph means.

In Lean, unification is performed up to computation. For example, the terms
`(λ x => ?left.a) a` and `b` can be unified by taking `?left.a := b`,
because `(λ x => b) a` and `b` are syntactically equal up to β-conversion.

The following is an alternative proof of the lemma `and_swap`:
-/
lemma and_swap2 :
∀ a b : Prop, a ∧ b → b ∧ a := by
  intros a b hab
  apply And.intro
  { exact And.right hab }
  { exact And.left hab }
/-!
The lemma is stated differently, with `a` and `b` as ∀-quantified variables instead of
parameters of the lemma. Logically, this is equivalent, but in the proof we must
then introduce `a` and `b` in addition to `hab`.

Another difference is the use of curly braces `{ }`. When we face two or more goals to prove, it is
generally good style to put each proof in its own block enclosed in curly braces. The `{ }` tactic
combinator focuses on the first subgoal; the tactic inside must prove it. In our example, the
`apply And.intro` tactic creates two subgoals, `⊢ b` and `⊢ a`.

A third difference is that we now apply, by juxtaposition, `And.right` and
`And.left` directly to the hypothesis `a ∧ b` to obtain `b` and `a`, respectively,
instead of waiting for the lemmas’ assumptions to emerge as new subgoals. This
is a small forward step in an otherwise backward proof. The same syntax is used
both to discharge (i.e., prove) a hypothesis and to instantiate a ∀-quantifier. One
benefit of this approach is that we avoid the potentially confusing `?left.a` variable.

The introduction and elimination rules for disjunction (∨) are as follows:
```lean
Or.intro_left : ∀ b : Prop, ?a → ?a ∨ b
Or.intro_right : ∀ b : Prop, ?a → b ∨ ?a
Or.elim : ?a ∨ ?b → (?a → ?c) → (?b → ?c) → ?c
```

--BUGBUG: what are all these question marks? Are they supposed to look like
unresolved metavariables?  I find it ugly and distracting, can we just write `a`
instead?

The ∀-quantifiers in `Or.intro_left` and `Or.intro_right` can be instantiated
directly by applying the lemma name to the value we want to instantiate with,
via simple juxtaposition. Thus, `Or.intro_left false` corresponds to the lemma
`?a → ?a ∨ false`. This is the forward style.

Alternatively, we can invoke apply `Or.intro_left` on a goal of the form
`. . . ⊢ c ∨ d`. This instantiates the lemma with `?a := c` and `b := d`.
The new subgoal is `. . . ⊢ c`. This is the backward style.

Both `Or.intro_left` and `Or.intro_right` are unsafe: If you apply the wrong
one of the two, or either of them too early in a proof, you might end up with an
unprovable subgoal. This is easy to see if you consider the provable goal
`⊢ true ∨ false`: applying `Or.intro_right` yields the unprovable subgoal
`⊢ false`.

The `Or.elim` rule may seem counterintuitive at a first glance. In essence, it
states that if we have `a ∨ b`, then to prove an arbitrary `c`, it suffices to prove `c`
when `a` holds and when `b` holds. You can think of `(?a → ?c) → (?b → ?c) → ?c`
as a clever trick to express the concept of disjunction using only implication.

The introduction and elimination rules for equivalence (`↔`) are as follows:

```lean
Iff.intro : (?a → ?b) → (?b → ?a) → (?a ↔ ?b)
Iff.mp : (?a ↔ ?b) → ?a → ?b
Iff.mpr : (?a ↔ ?b) → ?b → ?a
```
The introduction and elimination rules for existential quantification (`∃`) are

```lean
Exists.intro : ∀ w, (?p w → (∃x, ?p x))
Exists.elim : (∃ x, ?p x) → (∀a, ?p a → ?c) → ?c
```
The introduction rule for `∃` can be used to instantiate an existential quantifier
with a witness. For example:
-/
lemma nat_exists_double_iden :
  ∃ n : ℕ, double n = n := by
  apply Exists.intro 0
  rfl
/-!
Again, we instantiate a ∀-quantifier in a forward fashion: `Exists.intro 0` is the
lemma `?p 0 → (∃x, ?p x)`. The rule is unsafe: Choosing the wrong witness for `x`
will result in an unprovable goal. For example, if the goal is `⊢ ∃ n, n > 5` and we
take 3 as the witness, we end up with the unprovable subgoal `⊢ 3 > 5`.

The elimination rule for `∃` is reminiscent of `∨`. Indeed, a fruitful way to think
of a quantification `∃ n, ?p n` is as a possibly infinitary disjunction `?p 0 ∨ ?p 1 ∨ · · · `.
Similarly, `∀ n, ?p n` can be thought of as `?p 0 ∧ ?p 1 ∧ · · · `.
For truth (`true`), there is only an introduction rule:

```lean
True.intro : true
```
Truth holds no information whatsoever. If it appears as a hypothesis, it is completely useless, and
there is no elimination rule that will succeed at extracting any information from it. The `clear`
tactic, described in Section 2.8 below, can be used to remove such useless hypotheses.

Dually, for falsehood (`false`), there is only an elimination rule

```lean
False.elim : false → ?a
```
There is no way to prove falsehood, but if we somehow have it from somewhere
(e.g., from a hypothesis), then we can derive `?a`nything.

Negation (`not`) is defined in terms of implication and falsehood:
`¬ a` abbreviates `a → false`. Lean’s logic is classical, with support for the law of excluded
middle and proof by contradiction:

-- BUGBUG is this still true statement or is classical lean just one option now as per:
  https://leanprover.github.io/theorem_proving_in_lean4/propositions_and_proofs.html?highlight=classical#classical-logic

```lean
Classical.em : ∀ a : Prop, a ∨ ¬ a
Classical.byContradiction : (¬ ?a → false) → ?a
```

Finally, implication (`→`) and universal quantification (`∀`) are the proverbial dogs
that did not bark. For both of them, the `intro` tactic is the introduction principle,
and application is the elimination principle. For example, given the lemmas
`hab : a → b` and `ha : a`, the juxtaposition `hab ha` is a lemma stating `b`.

For proving logic puzzles involving connectives and quantifiers, we advocate
a “mindless,” “video game” style of reasoning that relies mostly on basic tactics
such as `intro`(s) and `apply`. Here are some strategies that often work:

- If the goal’s target is an implication `P → Q`, invoke `intro hP` to move `P` into your
  hypotheses: `. . ., hP : P ⊢ Q`.

- If the goal’s target is a universal quantification `∀ x : σ, Q`, invoke `intro x` to move `x` into
  the local context: `. . ., x : σ ⊢ Q`.

- Look for a lemma or hypothesis whose conclusion has the same shape as the goal’s target (possibly
  containing variables that can be matched), and apply it. For example, if the goal’s target is `Q`
  and you have a lemma or hypothesis of the form `hPQ : P → Q`, try `apply hPQ`.

- A negated goal `⊢ ¬ P` is syntactically equal to `⊢ P → false` up to computation, so you can
  invoke `intro hP` to produce the subgoal `hP : P ⊢ false`. Expanding negation’s definition by
  invoking `rw not_def` (described in Section 2.5) is often a good strategy.

- Sometimes you can make progress by replacing the goal by `false`, by entering apply `False.elim`. As
  next step, you would typically apply a lemma or hypothesis of the form `P → false` or `¬ P`.

- When you face several choices (e.g., between `Or.intro_left` and `Or.intro_right`), remember which
  choices you have made, and backtrack when you reach a dead end or have the impression you are not
  making any progress.

- If you suspect that you might have reached a dead end, check whether the goal actually is provable
  under the given assumptions. Even if you started with a provable lemma statement, the current goal
  might be unprovable (e.g., if you used unsafe rules such as `Or.intro_left`)

-/