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

! This file was ported from Lean 3 source module data.list.sublists
! leanprover-community/mathlib commit ccad6d5093bd2f5c6ca621fc74674cce51355af6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Nat.Choose.Basic
import Mathlib.Data.List.Perm

/-! # sublists

`List.Sublists` gives a list of all (not necessarily contiguous) sublists of a list.

This file contains basic results on this function.
-/
/-
Porting note: various auxiliary definitions such as `sublists'_aux` were left out of the port
because they were only used to prove properties of `sublists`, and these proofs have changed.
-/
universe u v w

variable {α : Type u} {β : Type v} {γ : Type w}

open Nat

namespace List

/-! ### sublists -/

@[simp]
theorem sublists'_nil : sublists' (@nil α) = [[]] :=
  rfl
#align list.sublists'_nil List.sublists'_nil

@[simp]
theorem sublists'_singleton (a : α) : sublists' [a] = [[], [a]] :=
  rfl
#align list.sublists'_singleton List.sublists'_singleton

#noalign list.map_sublists'_aux
#noalign list.sublists'_aux_append
#noalign list.sublists'_aux_eq_sublists'

--Porting note: Not the same as `sublists'_aux` from Lean3
/-- Auxilary helper definiiton for `sublists'` -/
def sublists'Aux (a : α) (r₁ r₂ : List (List α)) : List (List α) :=
  r₁.foldl (init := r₂) fun r l => r ++ [a :: l]
#align list.sublists'_aux List.sublists'Aux

theorem sublists'Aux_eq_array_foldl (a : α) : ∀ (r₁ r₂ : List (List α)),
    sublists'Aux a r₁ r₂ = ((r₁.toArray).foldl (init := r₂.toArray)
      (fun r l => r.push (a :: l))).toList := by
  intro r₁ r₂
  rw [sublists'Aux, Array.foldl_eq_foldl_data]
  have := List.foldl_hom Array.toList (fun r l => r.push (a :: l))
    (fun r l => r ++ [a :: l]) r₁ r₂.toArray (by simp)
  simpa using this

theorem sublists'_eq_sublists'Aux (l : List α) :
    sublists' l = l.foldr (fun a r => sublists'Aux a r r) [[]] := by
  simp only [sublists', sublists'Aux_eq_array_foldl]
  dsimp only
  rw [← List.foldr_hom Array.toList]
  . rfl
  . intros _ _; congr <;> simp

theorem sublists'Aux_eq_map (a : α) (r₁ : List (List α)) : ∀ (r₂ : List (List α)),
    sublists'Aux a r₁ r₂ = r₂ ++ map (cons a) r₁ :=
  List.reverseRecOn r₁ (fun _ => by simp [sublists'Aux]) <| fun r₁ l ih r₂ => by
    rw [map_append, map_singleton, ← append_assoc, ← ih, sublists'Aux, foldl_append, foldl]
    simp [sublists'Aux]

-- Porting note: simp can prove `sublists'_singleton`
@[simp 900]
theorem sublists'_cons (a : α) (l : List α) :
    sublists' (a :: l) = sublists' l ++ map (cons a) (sublists' l) := by
  simp [sublists'_eq_sublists'Aux, foldr_cons, sublists'Aux_eq_map]
#align list.sublists'_cons List.sublists'_cons

@[simp]
theorem mem_sublists' {s t : List α} : s ∈ sublists' t ↔ s <+ t :=
  by
  induction' t with a t IH generalizing s
  · simp only [sublists'_nil, mem_singleton]
    exact ⟨fun h => by rw [h], eq_nil_of_sublist_nil⟩
  simp only [sublists'_cons, mem_append, IH, mem_map]
  constructor <;> intro h; rcases h with (h | ⟨s, h, rfl⟩)
  · exact sublist_cons_of_sublist _ h
  · exact h.cons_cons _
  · cases' h with _ _ _ h s _ _ h
    · exact Or.inl h
    · exact Or.inr ⟨s, h, rfl⟩
#align list.mem_sublists' List.mem_sublists'

@[simp]
theorem length_sublists' : ∀ l : List α, length (sublists' l) = 2 ^ length l
  | [] => rfl
  | a :: l => by
    simp_arith only [sublists'_cons, length_append, length_sublists' l,
      length_map, length, Nat.pow_succ', mul_succ, mul_zero, zero_add]
#align list.length_sublists' List.length_sublists'

@[simp]
theorem sublists_nil : sublists (@nil α) = [[]] :=
  rfl
#align list.sublists_nil List.sublists_nil

@[simp]
theorem sublists_singleton (a : α) : sublists [a] = [[], [a]] :=
  rfl
#align list.sublists_singleton List.sublists_singleton

--Porting note: Not the same as `sublists_aux` from Lean3
/-- Auxilary helper function for `sublists` -/
def sublistsAux (a : α) (r : List (List α)) : List (List α) :=
  r.foldl (init := []) fun r l => r ++ [l, a :: l]
#align list.sublists_aux List.sublistsAux

theorem sublistsAux_eq_array_foldl :
    sublistsAux = fun (a : α) (r : List (List α)) =>
      (r.toArray.foldl (init := #[])
        fun r l => (r.push l).push (a :: l)).toList := by
  funext a r
  simp only [sublistsAux, Array.foldl_eq_foldl_data, Array.mkEmpty]
  have := foldl_hom Array.toList (fun r l => (r.push l).push (a :: l))
    (fun (r : List (List α)) l => r ++ [l, a :: l]) r #[]
    (by simp)
  simpa using this

theorem sublistsAux_eq_bind :
    sublistsAux = fun (a : α) (r : List (List α)) => r.bind fun l => [l, a :: l] :=
  funext <| fun a => funext <| fun r =>
  List.reverseRecOn r
    (by simp [sublistsAux])
    (fun r l ih => by
      rw [bind_append, ← ih, bind_singleton, sublistsAux, foldl_append]
      simp [sublistsAux])

theorem sublists_eq_sublistsAux (l : List α) :
    sublists l = l.foldr sublistsAux [[]] := by
  simp only [sublists, sublistsAux_eq_array_foldl, Array.foldr_eq_foldr_data]
  rw [← foldr_hom Array.toList]
  . rfl
  . intros _ _; congr <;> simp

#noalign list.sublists_aux₁_eq_sublists_aux
#noalign list.sublists_aux_cons_eq_sublists_aux₁
#noalign list.sublists_aux_eq_foldr.aux
#noalign list.sublists_aux_eq_foldr
#noalign list.sublists_aux_cons_cons
#noalign list.sublists_aux₁_append
#noalign list.sublists_aux₁_concat
#noalign list.sublists_aux₁_bind
#noalign list.sublists_aux_cons_append

theorem sublists_append (l₁ l₂ : List α) :
    sublists (l₁ ++ l₂) = (sublists l₂) >>= (fun x => (sublists l₁).map (. ++ x)) := by
  simp only [sublists_eq_sublistsAux, foldr_append, sublistsAux_eq_bind]
  induction l₁
  . case nil => simp
  . case cons a l₁ ih =>
      rw [foldr_cons, ih]
      simp [List.bind, join_join, Function.comp]
#align list.sublists_append List.sublists_append

--Portin note: New theorem
theorem sublists_cons (a : α) (l : List α) :
    sublists (a :: l) = sublists l >>= (fun x => [x, a :: x]) :=
  show sublists ([a] ++ l) = _ by
  rw [sublists_append]
  simp only [sublists_singleton, map_cons, bind_eq_bind, nil_append, cons_append, map_nil]

@[simp]
theorem sublists_concat (l : List α) (a : α) :
    sublists (l ++ [a]) = sublists l ++ map (fun x => x ++ [a]) (sublists l) := by
  rw [sublists_append, sublists_singleton, bind_eq_bind, cons_bind, cons_bind, nil_bind,
     map_id' append_nil, append_nil]
#align list.sublists_concat List.sublists_concat

theorem sublists_reverse (l : List α) : sublists (reverse l) = map reverse (sublists' l) := by
  induction' l with hd tl ih <;> [rfl,
    simp only [reverse_cons, sublists_append, sublists'_cons, map_append, ih, sublists_singleton,
      map_eq_map, bind_eq_bind, map_map, cons_bind, append_nil, nil_bind, (· ∘ ·)]]
#align list.sublists_reverse List.sublists_reverse

theorem sublists_eq_sublists' (l : List α) : sublists l = map reverse (sublists' (reverse l)) := by
  rw [← sublists_reverse, reverse_reverse]
#align list.sublists_eq_sublists' List.sublists_eq_sublists'

theorem sublists'_reverse (l : List α) : sublists' (reverse l) = map reverse (sublists l) := by
  simp only [sublists_eq_sublists', map_map, map_id' reverse_reverse, Function.comp]
#align list.sublists'_reverse List.sublists'_reverse

theorem sublists'_eq_sublists (l : List α) : sublists' l = map reverse (sublists (reverse l)) := by
  rw [← sublists'_reverse, reverse_reverse]
#align list.sublists'_eq_sublists List.sublists'_eq_sublists

#noalign list.sublists_aux_ne_nil

@[simp]
theorem mem_sublists {s t : List α} : s ∈ sublists t ↔ s <+ t := by
  rw [← reverse_sublist, ← mem_sublists', sublists'_reverse,
    mem_map_of_injective reverse_injective]
#align list.mem_sublists List.mem_sublists

@[simp]
theorem length_sublists (l : List α) : length (sublists l) = 2 ^ length l := by
  simp only [sublists_eq_sublists', length_map, length_sublists', length_reverse]
#align list.length_sublists List.length_sublists

theorem map_ret_sublist_sublists (l : List α) : map List.ret l <+ sublists l := by
  induction' l using reverseRecOn with l a ih <;>
  simp only [map, map_append, sublists_concat]
  · simp only [sublists_nil, sublist_cons]
  exact ((append_sublist_append_left _).2 <|
              singleton_sublist.2 <| mem_map.2 ⟨[], mem_sublists.2 (nil_sublist _), by rfl⟩).trans
          ((append_sublist_append_right _).2 ih)
#align list.map_ret_sublist_sublists List.map_ret_sublist_sublists

/-! ### sublistsLen -/

/-- Auxiliary function to construct the list of all sublists of a given length. Given an
integer `n`, a list `l`, a function `f` and an auxiliary list `L`, it returns the list made of
of `f` applied to all sublists of `l` of length `n`, concatenated with `L`. -/
def sublistsLenAux {α β : Type _} : ℕ → List α → (List α → β) → List β → List β
  | 0, _, f, r => f [] :: r
  | _ + 1, [], _, r => r
  | n + 1, a :: l, f, r => sublistsLenAux (n + 1) l f (sublistsLenAux n l (f ∘ List.cons a) r)
#align list.sublists_len_aux List.sublistsLenAux

/-- The list of all sublists of a list `l` that are of length `n`. For instance, for
`l = [0, 1, 2, 3]` and `n = 2`, one gets
`[[2, 3], [1, 3], [1, 2], [0, 3], [0, 2], [0, 1]]`. -/
def sublistsLen {α : Type _} (n : ℕ) (l : List α) : List (List α) :=
  sublistsLenAux n l id []
#align list.sublists_len List.sublistsLen

theorem sublistsLenAux_append {α β γ : Type _} :
    ∀ (n : ℕ) (l : List α) (f : List α → β) (g : β → γ) (r : List β) (s : List γ),
      sublistsLenAux n l (g ∘ f) (r.map g ++ s) = (sublistsLenAux n l f r).map g ++ s
  | 0, l, f, g, r, s => by unfold sublistsLenAux; simp
  | n + 1, [], f, g, r, s => rfl
  | n + 1, a :: l, f, g, r, s => by
    unfold sublistsLenAux
    simp only [show (g ∘ f) ∘ List.cons a = g ∘ f ∘ List.cons a by rfl, sublistsLenAux_append,
      sublistsLenAux_append]
#align list.sublists_len_aux_append List.sublistsLenAux_append

theorem sublistsLenAux_eq {α β : Type _} (l : List α) (n) (f : List α → β) (r) :
    sublistsLenAux n l f r = (sublistsLen n l).map f ++ r := by
  rw [sublistsLen, ← sublistsLenAux_append]; rfl
#align list.sublists_len_aux_eq List.sublistsLenAux_eq

theorem sublistsLenAux_zero {α : Type _} (l : List α) (f : List α → β) (r) :
    sublistsLenAux 0 l f r = f [] :: r := by cases l <;> rfl
#align list.sublists_len_aux_zero List.sublistsLenAux_zero

@[simp]
theorem sublistsLen_zero {α : Type _} (l : List α) : sublistsLen 0 l = [[]] :=
  sublistsLenAux_zero _ _ _
#align list.sublists_len_zero List.sublistsLen_zero

@[simp]
theorem sublistsLen_succ_nil {α : Type _} (n) : sublistsLen (n + 1) (@nil α) = [] :=
  rfl
#align list.sublists_len_succ_nil List.sublistsLen_succ_nil

@[simp]
theorem sublistsLen_succ_cons {α : Type _} (n) (a : α) (l) :
    sublistsLen (n + 1) (a :: l) = sublistsLen (n + 1) l ++ (sublistsLen n l).map (cons a) := by
  rw [sublistsLen, sublistsLenAux, sublistsLenAux_eq, sublistsLenAux_eq, map_id,
      append_nil]; rfl
#align list.sublists_len_succ_cons List.sublistsLen_succ_cons

@[simp]

theorem sublistsLen_sublist_sublists' {α : Type _} :
    ∀ (n) (l : List α), sublistsLen n l <+ sublists' l
  | 0, l => by simp
  | _ + 1, [] => nil_sublist _
  | n + 1, a :: l => by
    rw [sublistsLen_succ_cons, sublists'_cons]
    exact (sublistsLen_sublist_sublists' _ _).append ((sublistsLen_sublist_sublists' _ _).map _)
#align list.sublists_len_sublist_sublists' List.sublistsLen_sublist_sublists'

theorem sublistsLen_sublist_of_sublist {α : Type _} (n) {l₁ l₂ : List α} (h : l₁ <+ l₂) :
    sublistsLen n l₁ <+ sublistsLen n l₂ :=
  by
  induction' n with n IHn generalizing l₁ l₂; · simp
  induction' h with l₁ l₂ a _ IH l₁ l₂ a s IH; · rfl
  · refine' IH.trans _
    rw [sublistsLen_succ_cons]
    apply sublist_append_left
  · simp [sublistsLen_succ_cons]
    exact IH.append ((IHn s).map _)
#align list.sublists_len_sublist_of_sublist List.sublistsLen_sublist_of_sublist

theorem length_of_sublistsLen {α : Type _} :
    ∀ {n} {l l' : List α}, l' ∈ sublistsLen n l → length l' = n
  | 0, l, l', h => by simp_all
  | n + 1, a :: l, l', h => by
    rw [sublistsLen_succ_cons, mem_append, mem_map] at h
    rcases h with (h | ⟨l', h, rfl⟩)
    · exact length_of_sublistsLen h
    · exact congr_arg (· + 1) (length_of_sublistsLen h)
#align list.length_of_sublists_len List.length_of_sublistsLen

theorem mem_sublistsLen_self {α : Type _} {l l' : List α} (h : l' <+ l) :
    l' ∈ sublistsLen (length l') l :=
  by
  induction' h with l₁ l₂ a s IH l₁ l₂ a s IH
  · simp
  · cases' l₁ with b l₁
    · simp
    · rw [length, sublistsLen_succ_cons]
      exact mem_append_left _ IH
  · rw [length, sublistsLen_succ_cons]
    exact mem_append_right _ (mem_map.2 ⟨_, IH, rfl⟩)
#align list.mem_sublists_len_self List.mem_sublistsLen_self

@[simp]
theorem mem_sublistsLen {α : Type _} {n} {l l' : List α} :
    l' ∈ sublistsLen n l ↔ l' <+ l ∧ length l' = n :=
  ⟨fun h =>
    ⟨mem_sublists'.1 ((sublistsLen_sublist_sublists' _ _).subset h), length_of_sublistsLen h⟩,
    fun ⟨h₁, h₂⟩ => h₂ ▸ mem_sublistsLen_self h₁⟩
#align list.mem_sublists_len List.mem_sublistsLen

theorem sublistsLen_of_length_lt {n} {l : List α} (h : l.length < n) : sublistsLen n l = [] :=
  eq_nil_iff_forall_not_mem.mpr fun _ =>
    mem_sublistsLen.not.mpr fun ⟨hs, hl⟩ => (h.trans_eq hl.symm).not_le (Sublist.length_le hs)
#align list.sublists_len_of_length_lt List.sublistsLen_of_length_lt

@[simp]
theorem sublistsLen_length : ∀ l : List α, sublistsLen l.length l = [l]
  | [] => rfl
  | a :: l => by
    simp only [length, sublistsLen_succ_cons, sublistsLen_length, map,
      sublistsLen_of_length_lt (lt_succ_self _), nil_append]
#align list.sublists_len_length List.sublistsLen_length

open Function

theorem Pairwise.sublists' {R} :
    ∀ {l : List α}, Pairwise R l → Pairwise (Lex (swap R)) (sublists' l)
  | _, Pairwise.nil => pairwise_singleton _ _
  | _, @Pairwise.cons _ _ a l H₁ H₂ => by
    simp only [sublists'_cons, pairwise_append, pairwise_map, mem_sublists', mem_map, exists_imp,
      and_imp]
    refine' ⟨H₂.sublists', H₂.sublists'.imp fun l₁ => Lex.cons l₁, _⟩
    rintro l₁ sl₁ x l₂ _ rfl
    cases' l₁ with b l₁; · constructor
    exact Lex.rel (H₁ _ <| sl₁.subset <| mem_cons_self _ _)
#align list.pairwise.sublists' List.Pairwise.sublists'

theorem pairwise_sublists {R} {l : List α} (H : Pairwise R l) :
    Pairwise (fun l₁ l₂ => Lex R (reverse l₁) (reverse l₂)) (sublists l) :=
  by
  have := (pairwise_reverse.2 H).sublists'
  rwa [sublists'_reverse, pairwise_map] at this
#align list.pairwise_sublists List.pairwise_sublists

@[simp]
theorem nodup_sublists {l : List α} : Nodup (sublists l) ↔ Nodup l :=
  ⟨fun h => (h.sublist (map_ret_sublist_sublists _)).of_map _, fun h =>
    (pairwise_sublists h).imp @fun l₁ l₂ h => by simpa using h.to_ne⟩
#align list.nodup_sublists List.nodup_sublists

@[simp]
theorem nodup_sublists' {l : List α} : Nodup (sublists' l) ↔ Nodup l := by
  rw [sublists'_eq_sublists, nodup_map_iff reverse_injective, nodup_sublists, nodup_reverse]
#align list.nodup_sublists' List.nodup_sublists'

alias nodup_sublists ↔ nodup.of_sublists nodup.sublists
#align list.nodup.of_sublists List.nodup.of_sublists
#align list.nodup.sublists List.nodup.sublists

alias nodup_sublists' ↔ nodup.of_sublists' nodup.sublists'
#align list.nodup.of_sublists' List.nodup.of_sublists'
#align list.nodup.sublists' List.nodup.sublists'

--Porting note: commented out
--attribute [protected] nodup.sublists nodup.sublists'

theorem nodup_sublistsLen (n : ℕ) {l : List α} (h : Nodup l) : (sublistsLen n l).Nodup := by
  have : Pairwise (. ≠ .) l.sublists' := Pairwise.imp
    (fun h => Lex.to_ne (by convert h using 3; simp [swap, eq_comm])) h.sublists'
  exact this.sublist (sublistsLen_sublist_sublists' _ _)

#align list.nodup_sublists_len List.nodup_sublistsLen

--Porting note: new theorem
theorem sublists_map (f : α → β) : ∀ (l : List α),
    sublists (map f l) = map (map f) (sublists l)
  | [] => by simp
  | a::l => by
    rw [map_cons, sublists_cons, bind_eq_bind, sublists_map f l, sublists_cons,
      bind_eq_bind, map_eq_bind, map_eq_bind]
    induction sublists l <;> simp [*]

--Porting note: new theorem
theorem sublists'_map (f : α → β) : ∀ (l : List α),
    sublists' (map f l) = map (map f) (sublists' l)
  | [] => by simp
  | a::l => by simp [map_cons, sublists'_cons, sublists'_map f l, Function.comp]

--Porting note: moved because it is now used to prove `sublists_cons_perm_append`
theorem sublists_perm_sublists' (l : List α) : sublists l ~ sublists' l := by
  rw [← finRange_map_get l, sublists_map, sublists'_map]
  refine' Perm.map _ _
  exact (perm_ext (nodup_sublists.2 (nodup_finRange _)) (nodup_sublists'.2 (nodup_finRange _))).2
    (by simp)
#align list.sublists_perm_sublists' List.sublists_perm_sublists'

theorem sublists_cons_perm_append (a : α) (l : List α) :
    sublists (a :: l) ~ sublists l ++ map (cons a) (sublists l) :=
  Perm.trans (sublists_perm_sublists' _) <| by
  rw [sublists'_cons];
  exact Perm.append (sublists_perm_sublists' _).symm (Perm.map _ (sublists_perm_sublists' _).symm)
#align list.sublists_cons_perm_append List.sublists_cons_perm_append

theorem revzip_sublists (l : List α) : ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists → l₁ ++ l₂ ~ l := by
  rw [revzip]
  induction' l using List.reverseRecOn with l' a ih
  . intro l₁ l₂ h
    simp at h
    simp [h]
  . intro l₁ l₂ h
    rw [sublists_concat, reverse_append, zip_append, ← map_reverse, zip_map_right, zip_map_left] at
        * <;>
      [skip, · simp]
    simp only [Prod.mk.inj_iff, mem_map, mem_append, Prod.map_mk, Prod.exists] at h
    rcases h with (⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', l₂, h, rfl, rfl⟩)
    · rw [← append_assoc]
      exact (ih _ _ h).append_right _
    · rw [append_assoc]
      apply (perm_append_comm.append_left _).trans
      rw [← append_assoc]
      exact (ih _ _ h).append_right _
#align list.revzip_sublists List.revzip_sublists

theorem revzip_sublists' (l : List α) : ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists' → l₁ ++ l₂ ~ l := by
  rw [revzip]
  induction' l with a l IH <;> intro l₁ l₂ h
  · simp at h
    simp [h]
  · rw [sublists'_cons, reverse_append, zip_append, ← map_reverse, zip_map_right, zip_map_left] at
        * <;> [simp at h, simp]
    rcases h with (⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', h, rfl⟩)
    · exact perm_middle.trans ((IH _ _ h).cons _)
    · exact (IH _ _ h).cons _
#align list.revzip_sublists' List.revzip_sublists'

theorem range_bind_sublistsLen_perm {α : Type _} (l : List α) :
    ((List.range (l.length + 1)).bind fun n => sublistsLen n l) ~ sublists' l := by
  induction' l with h tl l_ih
  · simp [range_succ]
  · simp_rw [range_succ_eq_map, length, cons_bind, map_bind, sublistsLen_succ_cons, sublists'_cons,
      List.sublistsLen_zero, List.singleton_append]
    refine' ((bind_append_perm (range (tl.length + 1)) _ _).symm.cons _).trans _
    simp_rw [← List.bind_map, ← cons_append]
    rw [← List.singleton_append, ← List.sublistsLen_zero tl]
    refine' Perm.append _ (l_ih.map _)
    rw [List.range_succ, append_bind, bind_singleton,
      sublistsLen_of_length_lt (Nat.lt_succ_self _), append_nil, ←
      List.map_bind (fun n => sublistsLen n tl) Nat.succ, ←
      cons_bind 0 _ fun n => sublistsLen n tl, ← range_succ_eq_map]
    exact l_ih
#align list.range_bind_sublists_len_perm List.range_bind_sublistsLen_perm

end List


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.discrete_category
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# The empty category

Defines a category structure on `pempty`, and the unique functor `pempty ⥤ C` for any category `C`.
-/

namespace category_theory

namespace functor

/-- The canonical functor out of the empty category. -/
def empty (C : Type u) [category C] : discrete pempty ⥤ C :=
  discrete.functor pempty.elim

/-- Any two functors out of the empty category are isomorphic. -/
def empty_ext {C : Type u} [category C] (F : discrete pempty ⥤ C) (G : discrete pempty ⥤ C) : F ≅ G :=
  discrete.nat_iso fun (x : discrete pempty) => pempty.elim x

/--
Any functor out of the empty category is isomorphic to the canonical functor from the empty
category.
-/
def unique_from_empty {C : Type u} [category C] (F : discrete pempty ⥤ C) : F ≅ empty C :=
  empty_ext F (empty C)

/--
Any two functors out of the empty category are *equal*. You probably want to use
`empty_ext` instead of this.
-/
theorem empty_ext' {C : Type u} [category C] (F : discrete pempty ⥤ C) (G : discrete pempty ⥤ C) : F = G :=
  ext (fun (x : discrete pempty) => pempty.elim x) fun (x _x : discrete pempty) (_x_1 : x ⟶ _x) => pempty.elim x


/-
Copyright (c) 2022 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller, Vincent Beffara

! This file was ported from Lean 3 source module combinatorics.simple_graph.metric
! leanprover-community/mathlib commit 352ecfe114946c903338006dd3287cb5a9955ff2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Combinatorics.SimpleGraph.Connectivity
import Mathlib.Data.Nat.Lattice

/-!
# Graph metric

This module defines the `SimpleGraph.dist` function, which takes
pairs of vertices to the length of the shortest walk between them.

## Main definitions

- `SimpleGraph.dist` is the graph metric.

## Todo

- Provide an additional computable version of `SimpleGraph.dist`
  for when `G` is connected.

- Evaluate `Nat` vs `ENat` for the codomain of `dist`, or potentially
  having an additional `edist` when the objects under consideration are
  disconnected graphs.

- When directed graphs exist, a directed notion of distance,
  likely `ENat`-valued.

## Tags

graph metric, distance

-/

namespace SimpleGraph

variable {V : Type _} (G : SimpleGraph V)

/-! ## Metric -/

/-- The distance between two vertices is the length of the shortest walk between them.
If no such walk exists, this uses the junk value of `0`. -/
noncomputable def dist (u v : V) : ℕ :=
  infₛ (Set.range (Walk.length : G.Walk u v → ℕ))
#align simple_graph.dist SimpleGraph.dist

variable {G}

protected theorem Reachable.exists_walk_of_dist {u v : V} (hr : G.Reachable u v) :
    ∃ p : G.Walk u v, p.length = G.dist u v :=
  Nat.infₛ_mem (Set.range_nonempty_iff_nonempty.mpr hr)
#align simple_graph.reachable.exists_walk_of_dist SimpleGraph.Reachable.exists_walk_of_dist

protected theorem Connected.exists_walk_of_dist (hconn : G.Connected) (u v : V) :
    ∃ p : G.Walk u v, p.length = G.dist u v :=
  (hconn u v).exists_walk_of_dist
#align simple_graph.connected.exists_walk_of_dist SimpleGraph.Connected.exists_walk_of_dist

theorem dist_le {u v : V} (p : G.Walk u v) : G.dist u v ≤ p.length :=
  Nat.infₛ_le ⟨p, rfl⟩
#align simple_graph.dist_le SimpleGraph.dist_le

@[simp]
theorem dist_eq_zero_iff_eq_or_not_reachable {u v : V} :
    G.dist u v = 0 ↔ u = v ∨ ¬G.Reachable u v := by simp [dist, Nat.infₛ_eq_zero, Reachable]
#align simple_graph.dist_eq_zero_iff_eq_or_not_reachable SimpleGraph.dist_eq_zero_iff_eq_or_not_reachable

theorem dist_self {v : V} : dist G v v = 0 := by simp
#align simple_graph.dist_self SimpleGraph.dist_self

protected theorem Reachable.dist_eq_zero_iff {u v : V} (hr : G.Reachable u v) :
    G.dist u v = 0 ↔ u = v := by simp [hr]
#align simple_graph.reachable.dist_eq_zero_iff SimpleGraph.Reachable.dist_eq_zero_iff

protected theorem Reachable.pos_dist_of_ne {u v : V} (h : G.Reachable u v) (hne : u ≠ v) :
    0 < G.dist u v :=
  Nat.pos_of_ne_zero (by simp [h, hne])
#align simple_graph.reachable.pos_dist_of_ne SimpleGraph.Reachable.pos_dist_of_ne

protected theorem Connected.dist_eq_zero_iff (hconn : G.Connected) {u v : V} :
    G.dist u v = 0 ↔ u = v := by simp [hconn u v]
#align simple_graph.connected.dist_eq_zero_iff SimpleGraph.Connected.dist_eq_zero_iff

protected theorem Connected.pos_dist_of_ne {u v : V} (hconn : G.Connected) (hne : u ≠ v) :
    0 < G.dist u v :=
  Nat.pos_of_ne_zero (by intro h; exact False.elim (hne (hconn.dist_eq_zero_iff.mp h)))
#align simple_graph.connected.pos_dist_of_ne SimpleGraph.Connected.pos_dist_of_ne

theorem dist_eq_zero_of_not_reachable {u v : V} (h : ¬G.Reachable u v) : G.dist u v = 0 := by
  simp [h]
#align simple_graph.dist_eq_zero_of_not_reachable SimpleGraph.dist_eq_zero_of_not_reachable

theorem nonempty_of_pos_dist {u v : V} (h : 0 < G.dist u v) :
    (Set.univ : Set (G.Walk u v)).Nonempty := by
  simpa [Set.range_nonempty_iff_nonempty, Set.nonempty_iff_univ_nonempty] using
    Nat.nonempty_of_pos_infₛ h
#align simple_graph.nonempty_of_pos_dist SimpleGraph.nonempty_of_pos_dist

protected theorem Connected.dist_triangle (hconn : G.Connected) {u v w : V} :
    G.dist u w ≤ G.dist u v + G.dist v w := by
  obtain ⟨p, hp⟩ := hconn.exists_walk_of_dist u v
  obtain ⟨q, hq⟩ := hconn.exists_walk_of_dist v w
  rw [← hp, ← hq, ← Walk.length_append]
  apply dist_le
#align simple_graph.connected.dist_triangle SimpleGraph.Connected.dist_triangle

private theorem dist_comm_aux {u v : V} (h : G.Reachable u v) : G.dist u v ≤ G.dist v u := by
  obtain ⟨p, hp⟩ := h.symm.exists_walk_of_dist
  rw [← hp, ← Walk.length_reverse]
  apply dist_le

theorem dist_comm {u v : V} : G.dist u v = G.dist v u := by
  by_cases h : G.Reachable u v
  · apply le_antisymm (dist_comm_aux h) (dist_comm_aux h.symm)
  · have h' : ¬G.Reachable v u := fun h' => absurd h'.symm h
    simp [h, h', dist_eq_zero_of_not_reachable]
#align simple_graph.dist_comm SimpleGraph.dist_comm

end SimpleGraph


/-
Copyright (c) 2021 Alex Kontorovich and Heather Macbeth and Marc Masdeu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex Kontorovich, Heather Macbeth, Marc Masdeu
-/
import data.fintype.parity
import linear_algebra.matrix.special_linear_group
import analysis.complex.basic
import group_theory.group_action.defs
import linear_algebra.matrix.general_linear_group
import tactic.linear_combination

/-!
# The upper half plane and its automorphisms

This file defines `upper_half_plane` to be the upper half plane in `ℂ`.

We furthermore equip it with the structure of an `GL_pos 2 ℝ` action by
fractional linear transformations.

We define the notation `ℍ` for the upper half plane available in the locale
`upper_half_plane` so as not to conflict with the quaternions.
-/

noncomputable theory

open matrix matrix.special_linear_group

open_locale classical big_operators matrix_groups

local attribute [instance] fintype.card_fin_even

/- Disable these instances as they are not the simp-normal form, and having them disabled ensures
we state lemmas in this file without spurious `coe_fn` terms. -/
local attribute [-instance] matrix.special_linear_group.has_coe_to_fun
local attribute [-instance] matrix.general_linear_group.has_coe_to_fun

local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) _) _
local notation `↑ₘ[`:1024 R `]` := @coe _ (matrix (fin 2) (fin 2) R) _

local notation `GL(` n `, ` R `)`⁺ := matrix.GL_pos (fin n) R

/-- The open upper half plane -/
@[derive [λ α, has_coe α ℂ]]
def upper_half_plane := {point : ℂ // 0 < point.im}

localized "notation (name := upper_half_plane) `ℍ` := upper_half_plane" in upper_half_plane

namespace upper_half_plane

instance : inhabited ℍ := ⟨⟨complex.I, by simp⟩⟩

instance can_lift : can_lift ℂ ℍ coe (λ z, 0 < z.im) := subtype.can_lift (λ z, 0 < z.im)

/-- Imaginary part -/
def im (z : ℍ) := (z : ℂ).im

/-- Real part -/
def re (z : ℍ) := (z : ℂ).re

/-- Constructor for `upper_half_plane`. It is useful if `⟨z, h⟩` makes Lean use a wrong
typeclass instance. -/
def mk (z : ℂ) (h : 0 < z.im) : ℍ := ⟨z, h⟩

@[simp] lemma coe_im (z : ℍ) : (z : ℂ).im = z.im := rfl

@[simp] lemma coe_re (z : ℍ) : (z : ℂ).re = z.re := rfl

@[simp] lemma mk_re (z : ℂ) (h : 0 < z.im) : (mk z h).re = z.re := rfl
@[simp] lemma mk_im (z : ℂ) (h : 0 < z.im) : (mk z h).im = z.im := rfl
@[simp] lemma coe_mk (z : ℂ) (h : 0 < z.im) : (mk z h : ℂ) = z := rfl
@[simp] lemma mk_coe (z : ℍ) (h : 0 < (z : ℂ).im := z.2) : mk z h = z := subtype.eta z h

lemma re_add_im (z : ℍ) : (z.re + z.im * complex.I : ℂ) = z :=
complex.re_add_im z

lemma im_pos (z : ℍ) : 0 < z.im := z.2

lemma im_ne_zero (z : ℍ) : z.im ≠ 0 := z.im_pos.ne'

lemma ne_zero (z : ℍ) : (z : ℂ) ≠ 0 :=
mt (congr_arg complex.im) z.im_ne_zero

lemma norm_sq_pos (z : ℍ) : 0 < complex.norm_sq (z : ℂ) :=
by { rw complex.norm_sq_pos, exact z.ne_zero }

lemma norm_sq_ne_zero (z : ℍ) : complex.norm_sq (z : ℂ) ≠ 0 := (norm_sq_pos z).ne'

lemma im_inv_neg_coe_pos (z : ℍ) : 0 < ((-z : ℂ)⁻¹).im :=
by simpa using div_pos z.property (norm_sq_pos z)

/-- Numerator of the formula for a fractional linear transformation -/
@[simp] def num (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ := (↑ₘg 0 0 : ℝ) * z + (↑ₘg 0 1 : ℝ)

/-- Denominator of the formula for a fractional linear transformation -/
@[simp] def denom (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ := (↑ₘg 1 0 : ℝ) * z + (↑ₘg 1 1 : ℝ)

lemma linear_ne_zero (cd : fin 2 → ℝ) (z : ℍ) (h : cd ≠ 0) : (cd 0 : ℂ) * z + cd 1 ≠ 0 :=
begin
  contrapose! h,
  have : cd 0 = 0, -- we will need this twice
  { apply_fun complex.im at h,
    simpa only [z.im_ne_zero, complex.add_im, add_zero, coe_im, zero_mul, or_false,
      complex.of_real_im, complex.zero_im, complex.mul_im, mul_eq_zero] using h, },
  simp only [this, zero_mul, complex.of_real_zero, zero_add, complex.of_real_eq_zero] at h,
  ext i,
  fin_cases i; assumption,
end

lemma denom_ne_zero (g : GL(2, ℝ)⁺) (z : ℍ) : denom g z ≠ 0 :=
begin
  intro H,
  have DET := (mem_GL_pos _).1 g.prop,
  have hz := z.prop,
  simp only [general_linear_group.coe_det_apply] at DET,
  have H1 : (↑ₘg 1 0 : ℝ) = 0 ∨ z.im = 0, by simpa using congr_arg complex.im H,
  cases H1,
  { simp only [H1, complex.of_real_zero, denom, coe_fn_eq_coe, zero_mul, zero_add,
    complex.of_real_eq_zero] at H,
    rw [←coe_coe, (matrix.det_fin_two (↑g : matrix (fin 2) (fin 2) ℝ))] at DET,
    simp only [coe_coe,H, H1, mul_zero, sub_zero, lt_self_iff_false] at DET,
    exact DET, },
  { change z.im > 0 at hz,
    linarith, }
end

lemma norm_sq_denom_pos (g : GL(2, ℝ)⁺) (z : ℍ) : 0 < complex.norm_sq (denom g z) :=
complex.norm_sq_pos.mpr (denom_ne_zero g z)

lemma norm_sq_denom_ne_zero (g : GL(2, ℝ)⁺) (z : ℍ) : complex.norm_sq (denom g z) ≠ 0 :=
ne_of_gt (norm_sq_denom_pos g z)

/-- Fractional linear transformation, also known as the Moebius transformation -/
def smul_aux' (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ := num g z / denom g z

lemma smul_aux'_im (g : GL(2, ℝ)⁺) (z : ℍ) :
  (smul_aux' g z).im = ((det ↑ₘg) * z.im) / (denom g z).norm_sq :=
begin
  rw [smul_aux', complex.div_im],
  set NsqBot := (denom g z).norm_sq,
  have : NsqBot ≠ 0,
  { simp only [denom_ne_zero g z, map_eq_zero, ne.def, not_false_iff], },
  field_simp [smul_aux', -coe_coe],
  rw (matrix.det_fin_two (↑ₘg)),
  ring,
end

/-- Fractional linear transformation, also known as the Moebius transformation -/
def smul_aux (g : GL(2, ℝ)⁺) (z : ℍ) : ℍ :=
 ⟨smul_aux' g z, begin
  rw smul_aux'_im,
  convert (mul_pos ((mem_GL_pos _).1 g.prop)
    (div_pos z.im_pos (complex.norm_sq_pos.mpr (denom_ne_zero g z)))),
  simp only [general_linear_group.coe_det_apply, coe_coe],
  ring
end⟩

lemma denom_cocycle (x y : GL(2, ℝ)⁺) (z : ℍ) :
  denom (x * y) z = denom x (smul_aux y z) * denom y z :=
begin
  change _ = (_ * (_ / _) + _) * _,
  field_simp [denom_ne_zero, -denom, -num],
  simp only [matrix.mul, dot_product, fin.sum_univ_succ, denom, num, coe_coe, subgroup.coe_mul,
    general_linear_group.coe_mul, fintype.univ_of_subsingleton, fin.mk_zero,
    finset.sum_singleton, fin.succ_zero_eq_one, complex.of_real_add, complex.of_real_mul],
  ring
end

lemma mul_smul' (x y : GL(2, ℝ)⁺) (z : ℍ) :
  smul_aux (x * y) z = smul_aux x (smul_aux y z) :=
begin
  ext1,
  change _ / _ = (_ * (_ / _) + _) * _,
  rw denom_cocycle,
  field_simp [denom_ne_zero, -denom, -num],
  simp only [matrix.mul, dot_product, fin.sum_univ_succ, num, denom, coe_coe, subgroup.coe_mul,
    general_linear_group.coe_mul, fintype.univ_of_subsingleton, fin.mk_zero,
    finset.sum_singleton, fin.succ_zero_eq_one, complex.of_real_add, complex.of_real_mul],
  ring
end

/-- The action of ` GL_pos 2 ℝ` on the upper half-plane by fractional linear transformations. -/
instance : mul_action (GL(2, ℝ)⁺) ℍ :=
{ smul := smul_aux,
  one_smul := λ z, by { ext1, change _ / _ = _,
   simp [coe_fn_coe_base'] },
  mul_smul := mul_smul' }

section modular_scalar_towers

variable (Γ : subgroup (special_linear_group (fin 2) ℤ))

instance SL_action {R : Type*} [comm_ring R] [algebra R ℝ] : mul_action SL(2, R) ℍ :=
mul_action.comp_hom ℍ $ (special_linear_group.to_GL_pos).comp $ map (algebra_map R ℝ)

instance : has_coe SL(2,ℤ) (GL(2, ℝ)⁺) := ⟨λ g , ((g : SL(2, ℝ)) : (GL(2, ℝ)⁺))⟩

instance SL_on_GL_pos : has_smul SL(2,ℤ) (GL(2, ℝ)⁺) := ⟨λ s g, s * g⟩

lemma SL_on_GL_pos_smul_apply (s : SL(2,ℤ)) (g : (GL(2, ℝ)⁺)) (z : ℍ) :
  (s • g) • z = ( (s : GL(2, ℝ)⁺) * g) • z := rfl

instance SL_to_GL_tower : is_scalar_tower SL(2,ℤ) (GL(2, ℝ)⁺) ℍ :=
{ smul_assoc := by {intros s g z, simp only [SL_on_GL_pos_smul_apply, coe_coe], apply mul_smul',},}

instance subgroup_GL_pos : has_smul Γ (GL(2, ℝ)⁺) := ⟨λ s g, s * g⟩

lemma subgroup_on_GL_pos_smul_apply (s : Γ) (g : (GL(2, ℝ)⁺)) (z : ℍ) :
  (s • g) • z = ( (s : GL(2, ℝ)⁺) * g) • z := rfl

instance subgroup_on_GL_pos : is_scalar_tower Γ (GL(2, ℝ)⁺) ℍ :=
{ smul_assoc :=
  by {intros s g z, simp only [subgroup_on_GL_pos_smul_apply, coe_coe], apply mul_smul',},}

instance subgroup_SL : has_smul Γ SL(2,ℤ) := ⟨λ s g, s * g⟩

lemma subgroup_on_SL_apply (s : Γ) (g : SL(2,ℤ) ) (z : ℍ) :
  (s • g) • z = ( (s : SL(2, ℤ)) * g) • z := rfl

instance subgroup_to_SL_tower : is_scalar_tower Γ SL(2,ℤ) ℍ :=
{ smul_assoc := λ s g z, by { rw subgroup_on_SL_apply, apply mul_action.mul_smul } }

end modular_scalar_towers

lemma special_linear_group_apply {R : Type*} [comm_ring R] [algebra R ℝ] (g : SL(2, R)) (z : ℍ) :
  g • z = mk ((((↑(↑ₘ[R] g 0 0) : ℝ) : ℂ) * z + ((↑(↑ₘ[R] g 0 1) : ℝ) : ℂ)) /
              (((↑(↑ₘ[R] g 1 0) : ℝ) : ℂ) * z + ((↑(↑ₘ[R] g 1 1) : ℝ) : ℂ))) (g • z).property :=
rfl

@[simp] lemma coe_smul (g : GL(2, ℝ)⁺) (z : ℍ) : ↑(g • z) = num g z / denom g z := rfl
@[simp] lemma re_smul (g : GL(2, ℝ)⁺) (z : ℍ) : (g • z).re = (num g z / denom g z).re := rfl
lemma im_smul (g : GL(2, ℝ)⁺) (z : ℍ) : (g • z).im = (num g z / denom g z).im := rfl

lemma im_smul_eq_div_norm_sq (g : GL(2, ℝ)⁺) (z : ℍ) :
  (g • z).im = (det ↑ₘg * z.im) / (complex.norm_sq (denom g z)) := smul_aux'_im g z

@[simp] lemma neg_smul (g : GL(2, ℝ)⁺) (z : ℍ) : -g • z = g • z :=
begin
  ext1,
  change _ / _ = _ / _,
  field_simp [denom_ne_zero, -denom, -num],
  simp only [num, denom, coe_coe, complex.of_real_neg, neg_mul, GL_pos.coe_neg_GL, units.coe_neg,
    pi.neg_apply],
  ring_nf,
end

section SL_modular_action

variables (g : SL(2, ℤ)) (z : ℍ) (Γ : subgroup SL(2,ℤ))

@[simp] lemma sl_moeb (A : SL(2,ℤ)) (z : ℍ) : A • z = (A : (GL(2, ℝ)⁺)) • z := rfl
lemma subgroup_moeb (A : Γ) (z : ℍ) : A • z = (A : (GL(2, ℝ)⁺)) • z := rfl
@[simp] lemma subgroup_to_sl_moeb (A : Γ) (z : ℍ) : A • z = (A : SL(2,ℤ)) • z := rfl

@[simp] lemma SL_neg_smul (g : SL(2,ℤ)) (z : ℍ) : -g • z = g • z :=
begin
simp only [coe_GL_pos_neg, sl_moeb, coe_coe, coe_int_neg, neg_smul],
end

lemma c_mul_im_sq_le_norm_sq_denom (z : ℍ) (g : SL(2, ℝ)) :
  ((↑ₘg 1 0 : ℝ) * (z.im))^2 ≤ complex.norm_sq (denom g z) :=
begin
  let c := (↑ₘg 1 0 : ℝ),
  let d := (↑ₘg 1 1 : ℝ),
  calc (c * z.im)^2 ≤ (c * z.im)^2 + (c * z.re + d)^2 : by nlinarith
                ... = complex.norm_sq (denom g z) : by simp [complex.norm_sq]; ring,
end

lemma special_linear_group.im_smul_eq_div_norm_sq :
  (g • z).im = z.im / (complex.norm_sq (denom g z)) :=
begin
  convert (im_smul_eq_div_norm_sq g z),
  simp only [coe_coe, general_linear_group.coe_det_apply,coe_GL_pos_coe_GL_coe_matrix,
    int.coe_cast_ring_hom,(g : SL(2,ℝ)).prop, one_mul],
end

lemma denom_apply (g : SL(2, ℤ)) (z : ℍ) : denom g z = (↑g : matrix (fin 2) (fin 2) ℤ) 1 0 * z +
  (↑g : matrix (fin 2) (fin 2) ℤ) 1 1 := by simp

end SL_modular_action

section pos_real_action

instance pos_real_action : mul_action {x : ℝ // 0 < x} ℍ :=
{ smul := λ x z, mk ((x : ℝ) • z) $ by simpa using mul_pos x.2 z.2,
  one_smul := λ z, subtype.ext $ one_smul _ _,
  mul_smul := λ x y z, subtype.ext $ mul_smul (x : ℝ) y (z : ℂ) }

variables (x : {x : ℝ // 0 < x}) (z : ℍ)

@[simp] lemma coe_pos_real_smul : ↑(x • z) = (x : ℝ) • (z : ℂ) := rfl
@[simp] lemma pos_real_im : (x • z).im = x * z.im := complex.smul_im _ _
@[simp] lemma pos_real_re : (x • z).re = x * z.re := complex.smul_re _ _

end pos_real_action

section real_add_action

instance : add_action ℝ ℍ :=
{ vadd := λ x z, mk (x + z) $ by simpa using z.im_pos,
  zero_vadd := λ z, subtype.ext $ by simp,
  add_vadd := λ x y z, subtype.ext $ by simp [add_assoc] }

variables (x : ℝ) (z : ℍ)

@[simp] lemma coe_vadd : ↑(x +ᵥ z) = (x + z : ℂ) := rfl
@[simp] lemma vadd_re : (x +ᵥ z).re = x + z.re := rfl
@[simp]

end real_add_action

/- these next few lemmas are *not* flagged `@simp` because of the constructors on the RHS;
instead we use the versions with coercions to `ℂ` as simp lemmas instead. -/
lemma modular_S_smul (z : ℍ) : modular_group.S • z = mk (-z : ℂ)⁻¹ z.im_inv_neg_coe_pos :=
by { rw special_linear_group_apply, simp [modular_group.S, neg_div, inv_neg], }

lemma modular_T_zpow_smul (z : ℍ) (n : ℤ) : modular_group.T ^ n • z = (n : ℝ) +ᵥ z :=
begin
  rw [←subtype.coe_inj, coe_vadd, add_comm, special_linear_group_apply, coe_mk,
    modular_group.coe_T_zpow],
  simp only [of_apply, cons_val_zero, algebra_map.coe_one, complex.of_real_one, one_mul,
    cons_val_one, head_cons, algebra_map.coe_zero, zero_mul, zero_add, div_one],
end

lemma modular_T_smul (z : ℍ) : modular_group.T • z = (1 : ℝ) +ᵥ z :=
by simpa only [algebra_map.coe_one] using modular_T_zpow_smul z 1

lemma exists_SL2_smul_eq_of_apply_zero_one_eq_zero (g : SL(2, ℝ)) (hc : ↑ₘ[ℝ] g 1 0 = 0) :
  ∃ (u : {x : ℝ // 0 < x}) (v : ℝ),
    ((•) g : ℍ → ℍ) = (λ z, v +ᵥ z) ∘ (λ z, u • z) :=
begin
  obtain ⟨a, b, ha, rfl⟩ := g.fin_two_exists_eq_mk_of_apply_zero_one_eq_zero hc,
  refine ⟨⟨_, mul_self_pos.mpr ha⟩, b * a, _⟩,
  ext1 ⟨z, hz⟩, ext1,
  suffices : ↑a * z * a + b * a = b * a + a * a * z,
  { rw special_linear_group_apply, simpa [add_mul], },
  ring,
end

lemma exists_SL2_smul_eq_of_apply_zero_one_ne_zero (g : SL(2, ℝ)) (hc : ↑ₘ[ℝ] g 1 0 ≠ 0) :
  ∃ (u : {x : ℝ // 0 < x}) (v w : ℝ),
    ((•) g : ℍ → ℍ) = ((+ᵥ) w : ℍ → ℍ) ∘ ((•) modular_group.S : ℍ → ℍ)
                     ∘ ((+ᵥ) v : ℍ → ℍ) ∘ ((•) u : ℍ → ℍ) :=
begin
  have h_denom := denom_ne_zero g,
  induction g using matrix.special_linear_group.fin_two_induction with a b c d h,
  replace hc : c ≠ 0, { simpa using hc, },
  refine ⟨⟨_, mul_self_pos.mpr hc⟩, c * d, a / c, _⟩,
  ext1 ⟨z, hz⟩, ext1,
  suffices : (↑a * z + b) / (↑c * z + d) = a / c - (c * d + ↑c * ↑c * z)⁻¹,
  { rw special_linear_group_apply,
    simpa only [inv_neg, modular_S_smul, subtype.coe_mk, coe_vadd, complex.of_real_mul,
      coe_pos_real_smul, complex.real_smul, function.comp_app, complex.of_real_div] },
  replace hc : (c : ℂ) ≠ 0, { norm_cast, assumption, },
  replace h_denom : ↑c * z + d ≠ 0, { simpa using h_denom ⟨z, hz⟩, },
  have h_aux : (c : ℂ) * d + ↑c * ↑c * z ≠ 0,
  { rw [mul_assoc, ← mul_add, add_comm], exact mul_ne_zero hc h_denom, },
  replace h : (a * d - b * c : ℂ) = (1 : ℂ), { norm_cast, assumption, },
  field_simp,
  linear_combination (-(z * ↑c ^ 2) - ↑c * ↑d) * h,
end

end upper_half_plane


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

import algebra.algebra.basic
import linear_algebra.prod

/-!
# Trivial Square-Zero Extension

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

Given a ring `R` together with an `(R, R)`-bimodule `M`, the trivial square-zero extension of `M`
over `R` is defined to be the `R`-algebra `R ⊕ M` with multiplication given by
`(r₁ + m₁) * (r₂ + m₂) = r₁ r₂ + r₁ m₂ + m₁ r₂`.

It is a square-zero extension because `M^2 = 0`.

Note that expressing this requires bimodules; we write these in general for a
not-necessarily-commutative `R` as:
```lean
variables {R M : Type*} [semiring R] [add_comm_monoid M]
variables [module R M] [module Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M]
```
If we instead work with a commutative `R'` acting symmetrically on `M`, we write
```lean
variables {R' M : Type*} [comm_semiring R'] [add_comm_monoid M]
variables [module R' M] [module R'ᵐᵒᵖ M] [is_central_scalar R' M]
```
noting that in this context `is_central_scalar R' M` implies `smul_comm_class R' R'ᵐᵒᵖ M`.

Many of the later results in this file are only stated for the commutative `R'` for simplicity.

## Main definitions

* `triv_sq_zero_ext.inl`, `triv_sq_zero_ext.inr`: the canonical inclusions into
  `triv_sq_zero_ext R M`.
* `triv_sq_zero_ext.fst`, `triv_sq_zero_ext.snd`: the canonical projections from
  `triv_sq_zero_ext R M`.
* `triv_sq_zero_ext.algebra`: the associated `R`-algebra structure.
* `triv_sq_zero_ext.lift`: the universal property of the trivial square-zero extension; algebra
  morphisms `triv_sq_zero_ext R M →ₐ[R] A` are uniquely defined by linear maps `M →ₗ[R] A` for
  which the product of any two elements in the range is zero.

-/

universes u v w

/--
"Trivial Square-Zero Extension".

Given a module `M` over a ring `R`, the trivial square-zero extension of `M` over `R` is defined
to be the `R`-algebra `R × M` with multiplication given by
`(r₁ + m₁) * (r₂ + m₂) = r₁ r₂ + r₁ m₂ + r₂ m₁`.

It is a square-zero extension because `M^2 = 0`.
-/
def triv_sq_zero_ext (R : Type u) (M : Type v) :=
R × M

local notation `tsze` := triv_sq_zero_ext

open_locale big_operators

namespace triv_sq_zero_ext

open mul_opposite (op)

section basic
variables {R : Type u} {M : Type v}

/-- The canonical inclusion `R → triv_sq_zero_ext R M`. -/
def inl [has_zero M] (r : R) : tsze R M :=
(r, 0)

/-- The canonical inclusion `M → triv_sq_zero_ext R M`. -/
def inr [has_zero R] (m : M) : tsze R M :=
(0, m)

/-- The canonical projection `triv_sq_zero_ext R M → R`. -/
def fst (x : tsze R M) : R :=
x.1

/-- The canonical projection `triv_sq_zero_ext R M → M`. -/
def snd (x : tsze R M) : M :=
x.2

@[simp] lemma fst_mk (r : R) (m : M) : fst (r, m) = r := rfl
@[simp] lemma snd_mk (r : R) (m : M) : snd (r, m) = m := rfl

@[ext] lemma ext {x y : tsze R M} (h1 : x.fst = y.fst) (h2 : x.snd = y.snd) : x = y :=
prod.ext h1 h2

section
variables (M)
@[simp] lemma fst_inl [has_zero M] (r : R) : (inl r : tsze R M).fst = r := rfl
@[simp] lemma snd_inl [has_zero M] (r : R) : (inl r : tsze R M).snd = 0 := rfl
@[simp] lemma fst_comp_inl [has_zero M] : fst ∘ (inl : R → tsze R M) = id := rfl
@[simp] lemma snd_comp_inl [has_zero M] : snd ∘ (inl : R → tsze R M) = 0 := rfl
end

section
variables (R)
@[simp] lemma fst_inr [has_zero R] (m : M) : (inr m : tsze R M).fst = 0 := rfl
@[simp]

lemma inl_injective [has_zero M] : function.injective (inl : R → tsze R M) :=
function.left_inverse.injective $ fst_inl _

lemma inr_injective [has_zero R] : function.injective (inr : M → tsze R M) :=
function.left_inverse.injective $ snd_inr _

end basic

/-! ### Structures inherited from `prod`

Additive operators and scalar multiplication operate elementwise. -/

section additive

variables {T : Type*} {S : Type*} {R : Type u} {M : Type v}

instance [inhabited R] [inhabited M] : inhabited (tsze R M) :=
prod.inhabited

instance [has_zero R] [has_zero M] : has_zero (tsze R M) :=
prod.has_zero

instance [has_add R] [has_add M] : has_add (tsze R M) :=
prod.has_add

instance [has_sub R] [has_sub M] : has_sub (tsze R M) :=
prod.has_sub

instance [has_neg R] [has_neg M] : has_neg (tsze R M) :=
prod.has_neg

instance [add_semigroup R] [add_semigroup M] : add_semigroup (tsze R M) :=
prod.add_semigroup

instance [add_zero_class R] [add_zero_class M] : add_zero_class (tsze R M) :=
prod.add_zero_class

instance [add_monoid R] [add_monoid M] : add_monoid (tsze R M) :=
prod.add_monoid

instance [add_group R] [add_group M] : add_group (tsze R M) :=
prod.add_group

instance [add_comm_semigroup R] [add_comm_semigroup M] : add_comm_semigroup (tsze R M) :=
prod.add_comm_semigroup

instance [add_comm_monoid R] [add_comm_monoid M] : add_comm_monoid (tsze R M) :=
prod.add_comm_monoid

instance [add_comm_group R] [add_comm_group M] : add_comm_group (tsze R M) :=
prod.add_comm_group

instance [has_smul S R] [has_smul S M] : has_smul S (tsze R M) :=
prod.has_smul

instance [has_smul T R] [has_smul T M] [has_smul S R] [has_smul S M] [has_smul T S]
  [is_scalar_tower T S R] [is_scalar_tower T S M] : is_scalar_tower T S (tsze R M) :=
prod.is_scalar_tower

instance [has_smul T R] [has_smul T M] [has_smul S R] [has_smul S M]
  [smul_comm_class T S R] [smul_comm_class T S M] : smul_comm_class T S (tsze R M) :=
prod.smul_comm_class

instance [has_smul S R] [has_smul S M] [has_smul Sᵐᵒᵖ R] [has_smul Sᵐᵒᵖ M]
  [is_central_scalar S R] [is_central_scalar S M] : is_central_scalar S (tsze R M) :=
prod.is_central_scalar

instance [monoid S] [mul_action S R] [mul_action S M] : mul_action S (tsze R M) :=
prod.mul_action

instance [monoid S] [add_monoid R] [add_monoid M]
  [distrib_mul_action S R] [distrib_mul_action S M] : distrib_mul_action S (tsze R M) :=
prod.distrib_mul_action

instance [semiring S] [add_comm_monoid R] [add_comm_monoid M]
  [module S R] [module S M] : module S (tsze R M) :=
prod.module

@[simp] lemma fst_zero [has_zero R] [has_zero M] : (0 : tsze R M).fst = 0 := rfl
@[simp] lemma snd_zero [has_zero R] [has_zero M] : (0 : tsze R M).snd = 0 := rfl

@[simp] lemma fst_add [has_add R] [has_add M] (x₁ x₂ : tsze R M) :
  (x₁ + x₂).fst = x₁.fst + x₂.fst := rfl
@[simp] lemma snd_add [has_add R] [has_add M] (x₁ x₂ : tsze R M) :
  (x₁ + x₂).snd = x₁.snd + x₂.snd := rfl

@[simp] lemma fst_neg [has_neg R] [has_neg M] (x : tsze R M) : (-x).fst = -x.fst := rfl
@[simp] lemma snd_neg [has_neg R] [has_neg M] (x : tsze R M) : (-x).snd = -x.snd := rfl

@[simp] lemma fst_sub [has_sub R] [has_sub M] (x₁ x₂ : tsze R M) :
  (x₁ - x₂).fst = x₁.fst - x₂.fst := rfl
@[simp] lemma snd_sub [has_sub R] [has_sub M] (x₁ x₂ : tsze R M) :
  (x₁ - x₂).snd = x₁.snd - x₂.snd := rfl

@[simp] lemma fst_smul [has_smul S R] [has_smul S M] (s : S) (x : tsze R M) :
  (s • x).fst = s • x.fst := rfl
@[simp] lemma snd_smul [has_smul S R] [has_smul S M] (s : S) (x : tsze R M) :
  (s • x).snd = s • x.snd := rfl

lemma fst_sum {ι} [add_comm_monoid R] [add_comm_monoid M] (s : finset ι) (f : ι → tsze R M) :
  (∑ i in s, f i).fst = ∑ i in s, (f i).fst := prod.fst_sum

lemma snd_sum {ι} [add_comm_monoid R] [add_comm_monoid M] (s : finset ι) (f : ι → tsze R M) :
  (∑ i in s, f i).snd = ∑ i in s, (f i).snd := prod.snd_sum

section
variables (M)

@[simp] lemma inl_zero [has_zero R] [has_zero M] : (inl 0 : tsze R M) = 0 := rfl

@[simp] lemma inl_add [has_add R] [add_zero_class M] (r₁ r₂ : R) :
  (inl (r₁ + r₂) : tsze R M) = inl r₁ + inl r₂ :=
ext rfl (add_zero 0).symm

@[simp] lemma inl_neg [has_neg R] [sub_neg_zero_monoid M] (r : R) :
  (inl (-r) : tsze R M) = -inl r :=
ext rfl neg_zero.symm

@[simp] lemma inl_sub [has_sub R] [sub_neg_zero_monoid M] (r₁ r₂ : R) :
  (inl (r₁ - r₂) : tsze R M) = inl r₁ - inl r₂ :=
ext rfl (sub_zero _).symm

@[simp] lemma inl_smul [monoid S] [add_monoid M] [has_smul S R] [distrib_mul_action S M]
  (s : S) (r : R) : (inl (s • r) : tsze R M) = s • inl r :=
ext rfl (smul_zero s).symm

lemma inl_sum {ι} [add_comm_monoid R] [add_comm_monoid M] (s : finset ι) (f : ι → R) :
  (inl (∑ i in s, f i) : tsze R M) = ∑ i in s, inl (f i) :=
(linear_map.inl ℕ _ _).map_sum

end

section
variables (R)

@[simp] lemma inr_zero [has_zero R] [has_zero M] : (inr 0 : tsze R M) = 0 := rfl

@[simp] lemma inr_add [add_zero_class R] [add_zero_class M] (m₁ m₂ : M) :
  (inr (m₁ + m₂) : tsze R M) = inr m₁ + inr m₂ :=
ext (add_zero 0).symm rfl

@[simp] lemma inr_neg [sub_neg_zero_monoid R] [has_neg M] (m : M) :
  (inr (-m) : tsze R M) = -inr m :=
ext neg_zero.symm rfl

@[simp] lemma inr_sub [sub_neg_zero_monoid R] [has_sub M] (m₁ m₂ : M) :
  (inr (m₁ - m₂) : tsze R M) = inr m₁ - inr m₂ :=
ext (sub_zero _).symm rfl

@[simp] lemma inr_smul [has_zero R] [has_zero S] [smul_with_zero S R] [has_smul S M]
  (r : S) (m : M) : (inr (r • m) : tsze R M) = r • inr m :=
ext (smul_zero _).symm rfl

lemma inr_sum {ι} [add_comm_monoid R] [add_comm_monoid M] (s : finset ι) (f : ι → M) :
  (inr (∑ i in s, f i) : tsze R M) = ∑ i in s, inr (f i) :=
(linear_map.inr ℕ _ _).map_sum

end

lemma inl_fst_add_inr_snd_eq [add_zero_class R] [add_zero_class M] (x : tsze R M) :
  inl x.fst + inr x.snd = x :=
ext (add_zero x.1) (zero_add x.2)

/-- To show a property hold on all `triv_sq_zero_ext R M` it suffices to show it holds
on terms of the form `inl r + inr m`.

This can be used as `induction x using triv_sq_zero_ext.ind`. -/
lemma ind {R M} [add_zero_class R] [add_zero_class M] {P : triv_sq_zero_ext R M → Prop}
  (h : ∀ r m, P (inl r + inr m)) (x) : P x :=
inl_fst_add_inr_snd_eq x ▸ h x.1 x.2

/-- This cannot be marked `@[ext]` as it ends up being used instead of `linear_map.prod_ext` when
working with `R × M`. -/
lemma linear_map_ext {N} [semiring S] [add_comm_monoid R] [add_comm_monoid M] [add_comm_monoid N]
  [module S R] [module S M] [module S N] ⦃f g : tsze R M →ₗ[S] N⦄
  (hl : ∀ r, f (inl r) = g (inl r)) (hr : ∀ m, f (inr m) = g (inr m)) :
  f = g :=
linear_map.prod_ext (linear_map.ext hl) (linear_map.ext hr)

variables (R M)

/-- The canonical `R`-linear inclusion `M → triv_sq_zero_ext R M`. -/
@[simps apply]
def inr_hom [semiring R] [add_comm_monoid M] [module R M] : M →ₗ[R] tsze R M :=
{ to_fun := inr, ..linear_map.inr R R M }

/-- The canonical `R`-linear projection `triv_sq_zero_ext R M → M`. -/
@[simps apply]
def snd_hom [semiring R] [add_comm_monoid M] [module R M] : tsze R M →ₗ[R] M :=
{ to_fun := snd, ..linear_map.snd _ _ _ }

end additive

/-! ### Multiplicative structure -/

section mul
variables {R : Type u} {M : Type v}

instance [has_one R] [has_zero M] : has_one (tsze R M) :=
⟨(1, 0)⟩

instance [has_mul R] [has_add M] [has_smul R M] [has_smul Rᵐᵒᵖ M] : has_mul (tsze R M) :=
⟨λ x y, (x.1 * y.1, x.1 • y.2 + op y.1 • x.2)⟩

@[simp] lemma fst_one [has_one R] [has_zero M] : (1 : tsze R M).fst = 1 := rfl
@[simp] lemma snd_one [has_one R] [has_zero M] : (1 : tsze R M).snd = 0 := rfl

@[simp] lemma fst_mul [has_mul R] [has_add M] [has_smul R M] [has_smul Rᵐᵒᵖ M] (x₁ x₂ : tsze R M) :
  (x₁ * x₂).fst = x₁.fst * x₂.fst := rfl
@[simp] lemma snd_mul [has_mul R] [has_add M] [has_smul R M] [has_smul Rᵐᵒᵖ M] (x₁ x₂ : tsze R M) :
  (x₁ * x₂).snd = x₁.fst • x₂.snd + op x₂.fst • x₁.snd := rfl

section
variables (M)

@[simp] lemma inl_one [has_one R] [has_zero M] : (inl 1 : tsze R M) = 1 := rfl

@[simp] lemma inl_mul [monoid R] [add_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] (r₁ r₂ : R) :
  (inl (r₁ * r₂) : tsze R M) = inl r₁ * inl r₂ :=
ext rfl $ show (0 : M) = r₁ • 0 + op r₂ • 0, by rw [smul_zero, zero_add, smul_zero]

lemma inl_mul_inl [monoid R] [add_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] (r₁ r₂ : R) :
  (inl r₁ * inl r₂ : tsze R M) = inl (r₁ * r₂) :=
(inl_mul M r₁ r₂).symm

end

section
variables (R)

@[simp] lemma inr_mul_inr [semiring R] [add_comm_monoid M] [module R M] [module Rᵐᵒᵖ M]
  (m₁ m₂ : M) :
  (inr m₁ * inr m₂ : tsze R M) = 0 :=
ext (mul_zero _) $ show (0 : R) • m₂ + (0 : Rᵐᵒᵖ) • m₁ = 0, by rw [zero_smul, zero_add, zero_smul]

end

lemma inl_mul_inr [semiring R] [add_comm_monoid M] [module R M] [module Rᵐᵒᵖ M] (r : R) (m : M) :
  (inl r * inr m : tsze R M) = inr (r • m) :=
ext (mul_zero r) $ show r • m + (0 : Rᵐᵒᵖ) • 0 = r • m, by rw [smul_zero, add_zero]

lemma inr_mul_inl [semiring R] [add_comm_monoid M] [module R M] [module Rᵐᵒᵖ M] (r : R) (m : M) :
  (inr m * inl r : tsze R M) = inr (op r • m) :=
ext (zero_mul r) $ show (0 : R) • 0 + op r • m = op r • m, by rw [smul_zero, zero_add]

instance [monoid R] [add_monoid M] [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] :
  mul_one_class (tsze R M) :=
{ one_mul := λ x, ext (one_mul x.1) $ show (1 : R) • x.2 + op x.1 • 0 = x.2,
    by rw [one_smul, smul_zero, add_zero],
  mul_one := λ x, ext (mul_one x.1) $ show (x.1 • 0 : M) + (1 : Rᵐᵒᵖ) • x.2 = x.2,
    by rw [smul_zero, zero_add, one_smul],
  .. triv_sq_zero_ext.has_one,
  .. triv_sq_zero_ext.has_mul }

instance [add_monoid_with_one R] [add_monoid M] : add_monoid_with_one (tsze R M) :=
{ nat_cast := λ n, inl n,
  nat_cast_zero := by simp [nat.cast],
  nat_cast_succ := λ _, by ext; simp [nat.cast],
  .. triv_sq_zero_ext.add_monoid,
  .. triv_sq_zero_ext.has_one }

@[simp] lemma fst_nat_cast [add_monoid_with_one R] [add_monoid M] (n : ℕ) :
  (n : tsze R M).fst = n := rfl
@[simp] lemma snd_nat_cast [add_monoid_with_one R] [add_monoid M] (n : ℕ) :
  (n : tsze R M).snd = 0 := rfl
@[simp] lemma inl_nat_cast [add_monoid_with_one R] [add_monoid M] (n : ℕ) :
  (inl n : tsze R M) = n := rfl

instance [add_group_with_one R] [add_group M] : add_group_with_one (tsze R M) :=
{ int_cast := λ z, inl z,
  int_cast_of_nat := λ n, ext (int.cast_coe_nat _) rfl,
  int_cast_neg_succ_of_nat := λ n, ext (int.cast_neg_succ_of_nat _) neg_zero.symm,
  .. triv_sq_zero_ext.add_group,
  .. triv_sq_zero_ext.add_monoid_with_one }

@[simp] lemma fst_int_cast [add_group_with_one R] [add_group M] (z : ℤ) :
  (z : tsze R M).fst = z := rfl
@[simp] lemma snd_int_cast [add_group_with_one R] [add_group M] (z : ℤ) :
  (z : tsze R M).snd = 0 := rfl
@[simp] lemma inl_int_cast [add_group_with_one R] [add_group M] (z : ℤ) :
  (inl z : tsze R M) = z := rfl

instance [semiring R] [add_comm_monoid M] [module R M] [module Rᵐᵒᵖ M] :
  non_assoc_semiring (tsze R M) :=
{ zero_mul := λ x, ext (zero_mul x.1) $ show (0 : R) • x.2 + op x.1 • 0 = 0,
    by rw [zero_smul, zero_add, smul_zero],
  mul_zero := λ x, ext (mul_zero x.1) $ show (x.1 • 0 : M) + (0 : Rᵐᵒᵖ) • x.2 = 0,
    by rw [smul_zero, zero_add, zero_smul],
  left_distrib := λ x₁ x₂ x₃, ext (mul_add x₁.1 x₂.1 x₃.1) $
    show x₁.1 • (x₂.2 + x₃.2) + (op x₂.1 + op x₃.1) • x₁.2 =
      x₁.1 • x₂.2 + op x₂.1 • x₁.2 + (x₁.1 • x₃.2 + op x₃.1 • x₁.2),
    by simp_rw [smul_add, add_smul, add_add_add_comm],
  right_distrib := λ x₁ x₂ x₃, ext (add_mul x₁.1 x₂.1 x₃.1) $
    show (x₁.1 + x₂.1) • x₃.2 + op x₃.1 • (x₁.2 + x₂.2) =
      x₁.1 • x₃.2 + op x₃.1 • x₁.2 + (x₂.1 • x₃.2 + op x₃.1 • x₂.2),
    by simp_rw [add_smul, smul_add, add_add_add_comm],
  .. triv_sq_zero_ext.add_monoid_with_one,
  .. triv_sq_zero_ext.mul_one_class,
  .. triv_sq_zero_ext.add_comm_monoid }

instance [ring R] [add_comm_group M] [module R M] [module Rᵐᵒᵖ M] :
  non_assoc_ring (tsze R M) :=
{ .. triv_sq_zero_ext.add_group_with_one,
  .. triv_sq_zero_ext.non_assoc_semiring }

/-- In the general non-commutative case, the power operator is

$$\begin{align}
(r + m)^n &= r^n + r^{n-1}m + r^{n-2}mr + \cdots + rmr^{n-2} + mr^{n-1} \\
          & =r^n + \sum_{i = 0}^{n - 1} r^{(n - 1) - i} m r^{i}
\end{align}$$

In the commutative case this becomes the simpler $(r + m)^n = r^n + nr^{n-1}m$.
-/
instance [monoid R] [add_monoid M] [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] :
  has_pow (tsze R M) ℕ :=
⟨λ x n, ⟨x.fst^n,
  ((list.range n).map (λ i, x.fst ^ (n.pred - i) • op (x.fst ^ i) • x.snd)).sum⟩⟩

@[simp] lemma fst_pow [monoid R] [add_monoid M] [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M]
  (x : tsze R M) (n : ℕ) :
  fst (x ^ n) = x.fst ^ n := rfl

lemma snd_pow_eq_sum [monoid R] [add_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] (x : tsze R M) (n : ℕ) :
  snd (x ^ n) = ((list.range n).map (λ i, x.fst ^ (n.pred - i) • op (x.fst ^ i) • x.snd)).sum := rfl

lemma snd_pow_of_smul_comm [monoid R] [add_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M]
  (x : tsze R M) (n : ℕ) (h : op x.fst • x.snd = x.fst • x.snd) :
  snd (x ^ n) = n • x.fst ^ n.pred • x.snd :=
begin
  have : ∀ n : ℕ, op (x.fst ^ n) • x.snd = x.fst ^ n • x.snd,
  { intro n,
    induction n with n ih,
    { simp },
    { rw [pow_succ', mul_opposite.op_mul, mul_smul, mul_smul, ←h,
        smul_comm (_ : R) (op x.fst) x.snd, ih] } },
  simp_rw [snd_pow_eq_sum, this, smul_smul, ←pow_add],
  cases n,
  { rw [nat.pred_zero, pow_zero, list.range_zero, zero_smul, list.map_nil, list.sum_nil] },
  simp_rw nat.pred_succ,
  refine (list.sum_eq_card_nsmul _ (x.fst ^ n • x.snd) _).trans _,
  { rintros m hm,
    simp_rw [list.mem_map, list.mem_range] at hm,
    obtain ⟨i, hi, rfl⟩ := hm,
    rw tsub_add_cancel_of_le (nat.lt_succ_iff.mp hi) },
  { rw [list.length_map, list.length_range] }
end

@[simp] lemma snd_pow [comm_monoid R] [add_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] [is_central_scalar R M]
  (x : tsze R M) (n : ℕ) :
  snd (x ^ n) = n • x.fst ^ n.pred • x.snd :=
snd_pow_of_smul_comm _ _ (op_smul_eq_smul _ _)

@[simp] lemma inl_pow [monoid R] [add_monoid M] [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M]
  (r : R) (n : ℕ) :
  (inl r ^ n : tsze R M) = inl (r ^ n) :=
ext rfl $ by simp [snd_pow_eq_sum]

instance [monoid R] [add_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M] :
  monoid (tsze R M) :=
{ mul_assoc := λ x y z, ext (mul_assoc x.1 y.1 z.1) $
    show (x.1 * y.1) • z.2 + op z.1 • (x.1 • y.2 + op y.1 • x.2) =
      x.1 • (y.1 • z.2 + op z.1 • y.2) + (op z.1 * op y.1) • x.2,
    by simp_rw [smul_add, ← mul_smul, add_assoc, smul_comm],
  npow := λ n x, x ^ n,
  npow_zero' := λ x, ext (pow_zero x.fst) (by simp [snd_pow_eq_sum]),
  npow_succ' := λ n x, ext (pow_succ _ _) begin
    simp_rw [snd_mul, snd_pow_eq_sum, nat.pred_succ],
    cases n,
    { simp [list.range_succ], },
    simp_rw [nat.pred_succ],
    rw [list.range_succ, list.map_append, list.sum_append, list.map_singleton, list.sum_singleton,
      nat.sub_self, pow_zero, one_smul, list.smul_sum, list.map_map, function.comp, fst_pow],
    simp_rw [smul_smul, ←pow_succ, nat.succ_eq_add_one],
    congr' 2,
    refine list.map_congr (λ i hi, _),
    rw [list.mem_range, nat.lt_succ_iff] at hi,
    rw nat.sub_add_comm hi,
  end,
  .. triv_sq_zero_ext.mul_one_class }

lemma fst_list_prod [monoid R] [add_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M]
  (l : list (tsze R M)) :
  l.prod.fst = (l.map fst).prod :=
map_list_prod (⟨fst, fst_one, fst_mul⟩ : tsze R M →* R) _

instance [semiring R] [add_comm_monoid M]
  [module R M] [module Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M] :
  semiring (tsze R M) :=
{ .. triv_sq_zero_ext.monoid,
  .. triv_sq_zero_ext.non_assoc_semiring }

/-- The second element of a product $\prod_{i=0}^n (r_i + m_i)$ is a sum of terms of the form
$r_0\cdots r_{i-1}m_ir_{i+1}\cdots r_n$. -/
lemma snd_list_prod [semiring R] [add_comm_monoid M]
  [module R M] [module Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M]
  (l : list (tsze R M)) :
  l.prod.snd =
    (l.enum.map (λ x : ℕ × tsze R M,
      ((l.map fst).take x.1).prod • op ((l.map fst).drop x.1.succ).prod • x.snd.snd)).sum :=
begin
  induction l with x xs ih,
  { simp },
  { rw [list.enum_cons, ←list.map_fst_add_enum_eq_enum_from],
    simp_rw [list.map_cons, list.map_map, function.comp, prod.map_snd, prod.map_fst, id,
      list.take_zero, list.take_cons, list.prod_nil, list.prod_cons, snd_mul, one_smul,
      list.drop, mul_smul, list.sum_cons, fst_list_prod, ih, list.smul_sum, list.map_map],
    exact add_comm _ _, }
end

instance [ring R] [add_comm_group M]
  [module R M] [module Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M] :
  ring (tsze R M) :=
{ .. triv_sq_zero_ext.semiring,
  .. triv_sq_zero_ext.non_assoc_ring }

instance [comm_monoid R] [add_comm_monoid M]
  [distrib_mul_action R M] [distrib_mul_action Rᵐᵒᵖ M] [is_central_scalar R M] :
  comm_monoid (tsze R M) :=
{ mul_comm := λ x₁ x₂, ext (mul_comm x₁.1 x₂.1) $
    show x₁.1 • x₂.2 + op x₂.1 • x₁.2 = x₂.1 • x₁.2 + op x₁.1 • x₂.2,
      by rw [op_smul_eq_smul, op_smul_eq_smul, add_comm]
  .. triv_sq_zero_ext.monoid }

instance [comm_semiring R] [add_comm_monoid M]
  [module R M] [module Rᵐᵒᵖ M] [is_central_scalar R M] :
  comm_semiring (tsze R M) :=
{ .. triv_sq_zero_ext.comm_monoid,
  .. triv_sq_zero_ext.non_assoc_semiring }

instance [comm_ring R] [add_comm_group M]
  [module R M] [module Rᵐᵒᵖ M] [is_central_scalar R M] : comm_ring (tsze R M) :=
{ .. triv_sq_zero_ext.non_assoc_ring,
  .. triv_sq_zero_ext.comm_semiring }

variables (R M)

/-- The canonical inclusion of rings `R → triv_sq_zero_ext R M`. -/
@[simps apply]
def inl_hom [semiring R] [add_comm_monoid M] [module R M] [module Rᵐᵒᵖ M] : R →+* tsze R M :=
{ to_fun := inl,
  map_one' := inl_one M,
  map_mul' := inl_mul M,
  map_zero' := inl_zero M,
  map_add' := inl_add M }

end mul

section algebra
variables (S : Type*) (R R' : Type u) (M : Type v)
variables [comm_semiring S] [semiring R] [comm_semiring R'] [add_comm_monoid M]
variables [algebra S R] [algebra S R'] [module S M]
variables [module R M] [module Rᵐᵒᵖ M] [smul_comm_class R Rᵐᵒᵖ M]
variables [is_scalar_tower S R M] [is_scalar_tower S Rᵐᵒᵖ M]
variables [module R' M] [module R'ᵐᵒᵖ M] [is_central_scalar R' M] [is_scalar_tower S R' M]

instance algebra' : algebra S (tsze R M) :=
{ smul := (•),
  commutes' := λ s x, ext (algebra.commutes _ _) $
    show algebra_map S R s • x.snd + op x.fst • 0 = x.fst • 0 + op (algebra_map S R s) • x.snd,
  begin
    rw [smul_zero, smul_zero, add_zero, zero_add],
    rw [algebra.algebra_map_eq_smul_one, mul_opposite.op_smul, mul_opposite.op_one,
      smul_assoc, one_smul, smul_assoc, one_smul],
  end,
  smul_def' := λ r x, ext (algebra.smul_def _ _) $
    show r • x.2 = algebra_map S R r • x.2 + op x.1 • 0,
      by rw [smul_zero, add_zero, algebra_map_smul],
  .. (triv_sq_zero_ext.inl_hom R M).comp (algebra_map S R) }

-- shortcut instance for the common case
instance : algebra R' (tsze R' M) := triv_sq_zero_ext.algebra' _ _ _

lemma algebra_map_eq_inl : ⇑(algebra_map R' (tsze R' M)) = inl := rfl
lemma algebra_map_eq_inl_hom : algebra_map R' (tsze R' M) = inl_hom R' M := rfl
lemma algebra_map_eq_inl' (s : S) : algebra_map S (tsze R M) s = inl (algebra_map S R s) := rfl

/-- The canonical `R`-algebra projection `triv_sq_zero_ext R M → R`. -/
@[simps]
def fst_hom : tsze R M →ₐ[S] R :=
{ to_fun := fst,
  map_one' := fst_one,
  map_mul' := fst_mul,
  map_zero' := fst_zero,
  map_add' := fst_add,
  commutes' := λ r, fst_inl M _ }

variables {R R' S M}

lemma alg_hom_ext {A} [semiring A] [algebra R' A] ⦃f g : tsze R' M →ₐ[R'] A⦄
  (h : ∀ m, f (inr m) = g (inr m)) :
  f = g :=
alg_hom.to_linear_map_injective $ linear_map_ext (λ r, (f.commutes _).trans (g.commutes _).symm) h

@[ext]
lemma alg_hom_ext' {A} [semiring A] [algebra R' A] ⦃f g : tsze R' M →ₐ[R'] A⦄
  (h : f.to_linear_map.comp (inr_hom R' M) = g.to_linear_map.comp (inr_hom R' M)) :
  f = g :=
alg_hom_ext $ linear_map.congr_fun h

variables {A : Type*} [semiring A] [algebra R' A]

/-- There is an alg_hom from the trivial square zero extension to any `R`-algebra with a submodule
whose products are all zero.

See `triv_sq_zero_ext.lift` for this as an equiv. -/
def lift_aux (f : M →ₗ[R'] A) (hf : ∀ x y, f x * f y = 0) : tsze R' M →ₐ[R'] A :=
alg_hom.of_linear_map
  ((algebra.linear_map _ _).comp (fst_hom R' R' M).to_linear_map + f.comp (snd_hom R' M))
  (show algebra_map R' _ 1 + f (0 : M) = 1, by rw [map_zero, map_one, add_zero])
  (triv_sq_zero_ext.ind $ λ r₁ m₁, triv_sq_zero_ext.ind $ λ r₂ m₂, begin
    dsimp,
    simp only [add_zero, zero_add, add_mul, mul_add, smul_mul_smul, hf, smul_zero,
      op_smul_eq_smul],
    rw [←ring_hom.map_mul, linear_map.map_add, ←algebra.commutes _ (f _), ←algebra.smul_def,
        ←algebra.smul_def, add_right_comm, add_assoc, linear_map.map_smul, linear_map.map_smul],
  end)

@[simp] lemma lift_aux_apply_inr (f : M →ₗ[R'] A) (hf : ∀ x y, f x * f y = 0) (m : M) :
  lift_aux f hf (inr m) = f m :=
show algebra_map R' A 0 + f m = f m, by rw [ring_hom.map_zero, zero_add]

@[simp] lemma lift_aux_comp_inr_hom (f : M →ₗ[R'] A) (hf : ∀ x y, f x * f y = 0) :
  (lift_aux f hf).to_linear_map.comp (inr_hom R' M) = f :=
linear_map.ext $ lift_aux_apply_inr f hf

/- When applied to `inr` itself, `lift_aux` is the identity. -/
@[simp]
lemma lift_aux_inr_hom : lift_aux (inr_hom R' M) (inr_mul_inr R') = alg_hom.id R' (tsze R' M) :=
alg_hom_ext' $ lift_aux_comp_inr_hom _ _

/-- A universal property of the trivial square-zero extension, providing a unique
`triv_sq_zero_ext R M →ₐ[R] A` for every linear map `M →ₗ[R] A` whose range has no non-zero
products.

This isomorphism is named to match the very similar `complex.lift`. -/
@[simps]
def lift : {f : M →ₗ[R'] A // ∀ x y, f x * f y = 0} ≃ (tsze R' M →ₐ[R'] A) :=
{ to_fun := λ f, lift_aux f f.prop,
  inv_fun := λ F, ⟨F.to_linear_map.comp (inr_hom R' M), λ x y,
    (F.map_mul _ _).symm.trans $ (F.congr_arg $ inr_mul_inr _ _ _).trans F.map_zero⟩,
  left_inv := λ f, subtype.ext $ lift_aux_comp_inr_hom _ _,
  right_inv := λ F, alg_hom_ext' $ lift_aux_comp_inr_hom _ _, }

/-- This lemma is obviously simp-normal, but the linter times out while processing it.-/
attribute [nolint simp_nf] lift_symm_apply_coe

end algebra

end triv_sq_zero_ext