/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import data.nat data.list data.equiv
open nat function option

definition stream (A : Type) := nat → A

namespace stream
variables {A B C : Type}

definition cons (a : A) (s : stream A) : stream A :=
λ i,
  match i with
  | 0      := a
  | succ n := s n
  end

notation h :: t := cons h t

definition head [reducible] (s : stream A) : A :=
s 0

definition tail (s : stream A) : stream A :=
λ i, s (i+1)

definition drop (n : nat) (s : stream A) : stream A :=
λ i, s (i+n)

definition nth [reducible] (n : nat) (s : stream A) : A :=
s n

protected theorem eta (s : stream A) : head s :: tail s = s :=
funext (λ i, begin cases i, repeat reflexivity end)

theorem nth_zero_cons (a : A) (s : stream A) : nth 0 (a :: s) = a :=
rfl

theorem head_cons (a : A) (s : stream A) : head (a :: s) = a :=
rfl

theorem tail_cons (a : A) (s : stream A) : tail (a :: s) = s :=
rfl

theorem tail_drop (n : nat) (s : stream A) : tail (drop n s) = drop n (tail s) :=
funext (λ i, begin esimp [tail, drop], congruence, rewrite add.right_comm end)

theorem nth_drop (n m : nat) (s : stream A) : nth n (drop m s) = nth (n+m) s :=
rfl

theorem tail_eq_drop (s : stream A) : tail s = drop 1 s :=
rfl

theorem drop_drop (n m : nat) (s : stream A) : drop n (drop m s) = drop (n+m) s :=
funext (λ i, begin esimp [drop], rewrite add.assoc end)

theorem nth_succ (n : nat) (s : stream A) : nth (succ n) s = nth n (tail s) :=
rfl

theorem drop_succ (n : nat) (s : stream A) : drop (succ n) s = drop n (tail s) :=
rfl

protected theorem ext {s₁ s₂ : stream A} : (∀ n, nth n s₁ = nth n s₂) → s₁ = s₂ :=
assume h, funext h

definition all (p : A → Prop) (s : stream A) := ∀ n, p (nth n s)

definition any (p : A → Prop) (s : stream A) := ∃ n, p (nth n s)

theorem all_def (p : A → Prop) (s : stream A) : all p s = ∀ n, p (nth n s) :=
rfl

theorem any_def (p : A → Prop) (s : stream A) : any p s = ∃ n, p (nth n s) :=
rfl

definition mem (a : A) (s : stream A) := any (λ b, a = b) s

notation e ∈ s := mem e s

theorem mem_cons (a : A) (s : stream A) : a ∈ (a::s) :=
exists.intro 0 rfl

theorem mem_cons_of_mem {a : A} {s : stream A} (b : A) : a ∈ s → a ∈ b :: s :=
assume ains, obtain n (h : a = nth n s), from ains,
exists.intro (succ n) (by rewrite [nth_succ, tail_cons, h])

theorem eq_or_mem_of_mem_cons {a b : A} {s : stream A} : a ∈ b::s → a = b ∨ a ∈ s :=
assume ainbs, obtain n (h : a = nth n (b::s)), from ainbs,
begin
  cases n with n',
   {left, exact h},
   {right, rewrite [nth_succ at h, tail_cons at h], existsi n', exact h}
end

theorem mem_of_nth_eq {n : nat} {s : stream A} {a : A} : a = nth n s → a ∈ s :=
assume h, exists.intro n h

section map
variable (f : A → B)

definition map (s : stream A) : stream B :=
λ n, f (nth n s)

theorem drop_map (n : nat) (s : stream A) : drop n (map f s) = map f (drop n s) :=
stream.ext (λ i, rfl)

theorem nth_map (n : nat) (s : stream A) : nth n (map f s) = f (nth n s) :=
rfl

theorem tail_map (s : stream A) : tail (map f s) = map f (tail s) :=
begin rewrite tail_eq_drop end

theorem head_map (s : stream A) : head (map f s) = f (head s) :=
rfl

theorem map_eq (s : stream A) : map f s = f (head s) :: map f (tail s) :=
by rewrite [-stream.eta (map f s), tail_map, head_map]

theorem map_cons (a : A) (s : stream A) : map f (a :: s) = f a :: map f s :=
by rewrite [-stream.eta (map f (a :: s)), map_eq]

theorem map_id (s : stream A) : map id s = s :=
rfl

theorem map_map (g : B → C) (f : A → B) (s : stream A) : map g (map f s) = map (g ∘ f) s :=
rfl

theorem mem_map {a : A} {s : stream A} : a ∈ s → f a ∈ map f s :=
assume ains, obtain n (h : a = nth n s), from ains,
exists.intro n (by rewrite [nth_map, h])
end map

section zip
variable (f : A → B → C)

definition zip (s₁ : stream A) (s₂ : stream B) : stream C :=
λ n, f (nth n s₁) (nth n s₂)

theorem drop_zip (n : nat) (s₁ : stream A) (s₂ : stream B) : drop n (zip f s₁ s₂) = zip f (drop n s₁) (drop n s₂) :=
stream.ext (λ i, rfl)

theorem nth_zip (n : nat) (s₁ : stream A) (s₂ : stream B) : nth n (zip f s₁ s₂) = f (nth n s₁) (nth n s₂) :=
rfl

theorem head_zip (s₁ : stream A) (s₂ : stream B) : head (zip f s₁ s₂) = f (head s₁) (head s₂) :=
rfl

theorem tail_zip (s₁ : stream A) (s₂ : stream B) : tail (zip f s₁ s₂) = zip f (tail s₁) (tail s₂) :=
rfl

theorem zip_eq (s₁ : stream A) (s₂ : stream B) : zip f s₁ s₂ = f (head s₁) (head s₂) :: zip f (tail s₁) (tail s₂) :=
by rewrite [-stream.eta (zip f s₁ s₂)]
end zip

definition const (a : A) : stream A :=
λ n, a

theorem mem_const (a : A) : a ∈ const a :=
exists.intro 0 rfl

theorem const_eq (a : A) : const a = a :: const a :=
begin
  apply stream.ext, intro n,
  cases n, repeat reflexivity
end

theorem tail_const (a : A) : tail (const a) = const a :=
by rewrite [const_eq at {1}]

theorem map_const (f : A → B) (a : A) : map f (const a) = const (f a) :=
rfl

theorem nth_const (n : nat) (a : A) : nth n (const a) = a :=
rfl

theorem drop_const (n : nat) (a : A) : drop n (const a) = const a :=
stream.ext (λ i, rfl)

definition iterate (f : A → A) (a : A) : stream A :=
λ n, nat.rec_on n a (λ n r, f r)

theorem head_iterate (f : A → A) (a : A) : head (iterate f a) = a :=
rfl

theorem tail_iterate (f : A → A) (a : A) : tail (iterate f a) = iterate f (f a) :=
begin
  apply funext, intro n,
  induction n with n' IH,
    {reflexivity},
    {esimp [tail, iterate] at *,
     rewrite add_one at *,
     esimp at *, rewrite IH}
end

theorem iterate_eq (f : A → A) (a : A) : iterate f a = a :: iterate f (f a) :=
begin
  rewrite [-stream.eta (iterate f a)], congruence, exact !tail_iterate
end

theorem nth_zero_iterate (f : A → A) (a : A) : nth 0 (iterate f a) = a :=
rfl

theorem nth_succ_iterate (n : nat) (f : A → A) (a : A) : nth (succ n) (iterate f a) = nth n (iterate f (f a)) :=
by rewrite [nth_succ, tail_iterate]

section bisim
  variable (R : stream A → stream A → Prop)
  local infix ~ := R

  definition is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → head s₁ = head s₂ ∧ tail s₁ ~ tail s₂

  lemma nth_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂} n, s₁ ~ s₂ → nth n s₁ = nth n s₂ ∧ drop (n+1) s₁ ~ drop (n+1) s₂
  | s₁ s₂ 0     h := bisim h
  | s₁ s₂ (n+1) h :=
    obtain h₁ (trel : tail s₁ ~ tail s₂), from bisim h,
    nth_of_bisim n trel

  -- If two streams are bisimilar, then they are equal
  theorem eq_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂}, s₁ ~ s₂ → s₁ = s₂ :=
  λ s₁ s₂ r, stream.ext (λ n, and.elim_left (nth_of_bisim R bisim n r))
end bisim

theorem bisim_simple (s₁ s₂ : stream A) : head s₁ = head s₂ → s₁ = tail s₁ → s₂ = tail s₂ → s₁ = s₂ :=
assume hh ht₁ ht₂, eq_of_bisim
  (λ s₁ s₂, head s₁ = head s₂ ∧ s₁ = tail s₁ ∧ s₂ = tail s₂)
  (λ s₁ s₂ h,
    obtain h₁ h₂ h₃, from h,
    begin
      constructor, exact h₁, rewrite [-h₂, -h₃], exact h
    end)
  (and.intro hh (and.intro ht₁ ht₂))

-- AKA coinduction freeze
theorem coinduction.{l} {A : Type.{l}} {s₁ s₂ : stream A} :
        head s₁ = head s₂ → (∀ (B : Type.{l}) (fr : stream A → B), fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ :=
assume hh ht,
  eq_of_bisim
    (λ s₁ s₂, head s₁ = head s₂ ∧ ∀ (B : Type) (fr : stream A → B), fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂))
    (λ s₁ s₂ h,
      have h₁ : head s₁ = head s₂,               from and.elim_left h,
      have h₂ : head (tail s₁) = head (tail s₂), from and.elim_right h A (@head A) h₁,
      have h₃ : ∀ (B : Type) (fr : stream A → B), fr (tail s₁) = fr (tail s₂) → fr (tail (tail s₁)) = fr (tail (tail s₂)), from
        λ B fr, and.elim_right h B (λ s, fr (tail s)),
      and.intro h₁ (and.intro h₂ h₃))
    (and.intro hh ht)

theorem iterate_id (a : A) : iterate id a = const a :=
coinduction
  rfl
  (λ B fr ch, by rewrite [tail_iterate, tail_const]; exact ch)

local attribute stream [reducible]
theorem map_iterate (f : A → A) (a : A) : iterate f (f a) = map f (iterate f a) :=
begin
  apply funext, intro n,
  induction n with n' IH,
    {reflexivity},
    { esimp [map, iterate, nth] at *,
      rewrite IH }
end

section corec
  definition corec (f : A → B) (g : A → A) : A → stream B :=
  λ a, map f (iterate g a)

  theorem corec_def (f : A → B) (g : A → A) (a : A) : corec f g a = map f (iterate g a) :=
  rfl

  theorem corec_eq (f : A → B) (g : A → A) (a : A) : corec f g a = f a :: corec f g (g a) :=
  by rewrite [corec_def, map_eq, head_iterate, tail_iterate]

  theorem corec_id_id_eq_const (a : A) : corec id id a = const a :=
  by rewrite [corec_def, map_id, iterate_id]

  theorem corec_id_f_eq_iterate (f : A → A) (a : A) : corec id f a = iterate f a :=
  rfl
end corec

-- corec is also known as unfold
definition unfolds (g : A → B) (f : A → A) (a : A) : stream B :=
corec g f a

theorem unfolds_eq (g : A → B) (f : A → A) (a : A) : unfolds g f a = g a :: unfolds g f (f a) :=
by esimp [ unfolds ]; rewrite [corec_eq]

theorem nth_unfolds_head_tail : ∀ (n : nat) (s : stream A), nth n (unfolds head tail s) = nth n s :=
begin
  intro n, induction n with n' ih,
   {intro s, reflexivity},
   {intro s, rewrite [*nth_succ, unfolds_eq, tail_cons, ih]}
end

theorem unfolds_head_eq : ∀ (s : stream A), unfolds head tail s = s :=
λ s, stream.ext (λ n, nth_unfolds_head_tail n s)

definition interleave (s₁ s₂ : stream A) : stream A :=
corec
  (λ p, obtain s₁ s₂, from p, head s₁)
  (λ p, obtain s₁ s₂, from p, (s₂, tail s₁))
  (s₁, s₂)

infix `⋈`:65 := interleave

theorem interleave_eq (s₁ s₂ : stream A) : s₁ ⋈ s₂ = head s₁ :: head s₂ :: (tail s₁ ⋈ tail s₂) :=
begin
  esimp [interleave], rewrite corec_eq, esimp, congruence, rewrite corec_eq
end

theorem tail_interleave (s₁ s₂ : stream A) : tail (s₁ ⋈ s₂) = s₂ ⋈ (tail s₁) :=
by esimp [interleave]; rewrite corec_eq

theorem interleave_tail_tail (s₁ s₂ : stream A) : tail s₁ ⋈ tail s₂ = tail (tail (s₁ ⋈ s₂)) :=
by rewrite [interleave_eq s₁ s₂]

theorem nth_interleave_left : ∀ (n : nat) (s₁ s₂ : stream A), nth (2*n) (s₁ ⋈ s₂) = nth n s₁
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (succ (succ (2*n))) (s₁ ⋈ s₂) = nth (succ n) s₁,
    rewrite [*nth_succ, interleave_eq, *tail_cons, nth_interleave_left]
  end

theorem nth_interleave_right : ∀ (n : nat) (s₁ s₂ : stream A), nth (2*n+1) (s₁ ⋈ s₂) = nth n s₂
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (succ (succ (2*n+1))) (s₁ ⋈ s₂) = nth (succ n) s₂,
    rewrite [*nth_succ, interleave_eq, *tail_cons, nth_interleave_right]
  end

theorem mem_interleave_left {a : A} {s₁ : stream A} (s₂ : stream A) : a ∈ s₁ → a ∈ s₁ ⋈ s₂ :=
assume ains₁, obtain n h, from ains₁,
exists.intro (2*n) (by rewrite [h, nth_interleave_left])

theorem mem_interleave_right {a : A} {s₁ : stream A} (s₂ : stream A) : a ∈ s₂ → a ∈ s₁ ⋈ s₂ :=
assume ains₂, obtain n h, from ains₂,
exists.intro (2*n+1) (by rewrite [h, nth_interleave_right])

definition even (s : stream A) : stream A :=
corec
  (λ s, head s)
  (λ s, tail (tail s))
  s

definition odd (s : stream A) : stream A :=
even (tail s)

theorem odd_eq (s : stream A) : odd s = even (tail s) :=
rfl

theorem head_even (s : stream A) : head (even s) = head s :=
rfl

theorem tail_even (s : stream A) : tail (even s) = even (tail (tail s)) :=
by esimp [even]; rewrite corec_eq

theorem even_cons_cons (a₁ a₂ : A) (s : stream A) : even (a₁ :: a₂ :: s) = a₁ :: even s :=
by esimp [even]; rewrite corec_eq

theorem even_tail (s : stream A) : even (tail s) = odd s :=
rfl

theorem even_interleave (s₁ s₂ : stream A) : even (s₁ ⋈ s₂) = s₁ :=
eq_of_bisim
  (λ s₁' s₁, ∃ s₂, s₁' = even (s₁ ⋈ s₂))
  (λ s₁' s₁ h,
    obtain s₂ (h₁ : s₁' = even (s₁ ⋈ s₂)), from h,
    begin
      rewrite h₁,
      constructor,
       {reflexivity},
       {existsi (tail s₂),
        rewrite [interleave_eq, even_cons_cons, tail_cons]}
    end)
  (exists.intro s₂ rfl)

theorem interleave_even_odd (s₁ : stream A) : even s₁ ⋈ odd s₁ = s₁ :=
eq_of_bisim
  (λ s' s, s' = even s ⋈ odd s)
  (λ s' s (h : s' = even s ⋈ odd s),
    begin
      rewrite h, constructor,
       {reflexivity},
       {esimp, rewrite [*odd_eq, tail_interleave, tail_even]}
    end)
  rfl

theorem nth_even : ∀ (n : nat) (s : stream A), nth n (even s) = nth (2*n) s
| 0        s := rfl
| (succ n) s :=
  begin
    change nth (succ n) (even s) = nth (succ (succ (2 * n))) s,
    rewrite [+nth_succ, tail_even, nth_even]
  end

theorem nth_odd : ∀ (n : nat) (s : stream A), nth n (odd s) = nth (2*n + 1) s :=
λ n s, by rewrite [odd_eq, nth_even]

theorem mem_of_mem_even (a : A) (s : stream A) : a ∈ even s → a ∈ s :=
assume aines, obtain n h, from aines,
exists.intro (2*n) (by rewrite [h, nth_even])

theorem mem_of_mem_odd (a : A) (s : stream A) : a ∈ odd s → a ∈ s :=
assume ainos, obtain n h, from ainos,
exists.intro (2*n+1) (by rewrite [h, nth_odd])

open list
definition append : list A → stream A → stream A
| []     s := s
| (a::l) s := a :: append l s

theorem nil_append (s : stream A) : append [] s = s :=
rfl

theorem cons_append (a : A) (l : list A) (s : stream A) : append (a::l) s = a :: append l s :=
rfl

infix ++ := append
-- the following local notation is used just to make the following theorem clear
local infix `++ₛ`:65 := append

theorem append_append : ∀ (l₁ l₂ : list A) (s : stream A), (l₁ ++ l₂) ++ₛ s = l₁ ++ (l₂ ++ₛ s)
| []      l₂ s := rfl
| (a::l₁) l₂ s := by rewrite [list.append_cons, *cons_append, append_append]

theorem map_append (f : A → B) : ∀ (l : list A) (s : stream A), map f (l ++ s) = list.map f l ++ map f s
| []     s := rfl
| (a::l) s := by rewrite [cons_append, list.map_cons, map_cons, cons_append, map_append]

theorem drop_append : ∀ (l : list A) (s : stream A), drop (length l) (l ++ s) = s
| []     s := by esimp
| (a::l) s := by rewrite [length_cons, add_one, drop_succ, cons_append, tail_cons, drop_append]

theorem append_head_tail (s : stream A) : [head s] ++ tail s = s :=
by rewrite [cons_append, nil_append, stream.eta]

theorem mem_append_right : ∀ {a : A} (l : list A) {s : stream A}, a ∈ s → a ∈ l ++ s
| a []     s h := h
| a (b::l) s h :=
  have ih : a ∈ l ++ s, from mem_append_right l h,
  !mem_cons_of_mem ih

theorem mem_append_left : ∀ {a : A} {l : list A} (s : stream A), a ∈ l → a ∈ l ++ s
| a []     s h := absurd h !not_mem_nil
| a (b::l) s h :=
  or.elim (list.eq_or_mem_of_mem_cons h)
    (λ (aeqb : a = b), exists.intro 0 aeqb)
    (λ (ainl : a ∈ l), mem_cons_of_mem b (mem_append_left s ainl))

definition approx : nat → stream A → list A
| 0     s := []
| (n+1) s := head s :: approx n (tail s)

theorem approx_zero (s : stream A) : approx 0 s = [] :=
rfl

theorem approx_succ (n : nat) (s : stream A) : approx (succ n) s = head s :: approx n (tail s) :=
rfl

theorem nth_approx : ∀ (n : nat) (s : stream A), list.nth (approx (succ n) s) n = some (nth n s)
| 0     s := rfl
| (n+1) s := begin rewrite [approx_succ, add_one, list.nth_succ, nth_approx] end

theorem append_approx_drop : ∀ (n : nat) (s : stream A), append (approx n s) (drop n s) = s :=
begin
  intro n,
  induction n with n' ih,
   {intro s, reflexivity},
   {intro s, rewrite [approx_succ, drop_succ, cons_append, ih (tail s), stream.eta]}
end

-- Take lemma reduces a proof of equality of infinite streams to an
-- induction over all their finite approximations.
theorem take_lemma (s₁ s₂ : stream A) : (∀ (n : nat), approx n s₁ = approx n s₂) → s₁ = s₂ :=
begin
  intro h, apply stream.ext, intro n,
    induction n with n ih,
     {injection (h 1) with aux, exact aux},
     {have h₁ : some (nth (succ n) s₁) = some (nth (succ n) s₂), by rewrite [-*nth_approx, h (succ (succ n))],
      injection h₁, assumption}
end

-- auxiliary definition for cycle corecursive definition
private definition cycle_f : A × list A × A × list A → A
| (v, _, _, _) := v

-- auxiliary definition for cycle corecursive definition
private definition cycle_g : A × list A × A × list A → A × list A × A × list A
| (v₁, [],     v₀, l₀) := (v₀, l₀, v₀, l₀)
| (v₁, v₂::l₂, v₀, l₀) := (v₂, l₂, v₀, l₀)

private lemma cycle_g_cons (a : A) (a₁ : A) (l₁ : list A) (a₀ : A) (l₀ : list A) :
              cycle_g (a, a₁::l₁, a₀, l₀) = (a₁, l₁, a₀, l₀) :=
rfl

definition cycle : Π (l : list A), l ≠ nil → stream A
| []     h := absurd rfl h
| (a::l) h := corec cycle_f cycle_g (a, l, a, l)

theorem cycle_eq : ∀ (l : list A) (h : l ≠ nil), cycle l h = l ++ cycle l h
| []     h := absurd rfl h
| (a::l) h :=
  have gen : ∀ l' a', corec cycle_f cycle_g (a', l', a, l) = (a' :: l') ++ₛ corec cycle_f cycle_g (a, l, a, l),
    begin
      intro l',
      induction l' with a₁ l₁ ih,
        {intro a', rewrite [corec_eq]},
        {intro a', rewrite [corec_eq, cycle_g_cons, ih a₁]}
    end,
  gen l a

theorem mem_cycle {a : A} {l : list A} : ∀ (h : l ≠ []), a ∈ l → a ∈ cycle l h :=
assume h ainl, by rewrite [cycle_eq]; exact !mem_append_left ainl

theorem cycle_singleton (a : A) (h : [a] ≠ nil) : cycle [a] h = const a :=
coinduction
  rfl
  (λ B fr ch, by rewrite [cycle_eq, const_eq]; exact ch)

definition tails (s : stream A) : stream (stream A) :=
corec id tail (tail s)

theorem tails_eq (s : stream A) : tails s = tail s :: tails (tail s) :=
by esimp [tails]; rewrite [corec_eq]

theorem nth_tails : ∀ (n : nat) (s : stream A), nth n (tails s) = drop n (tail s) :=
begin
  intro n, induction n with n' ih,
    {intros, reflexivity},
    {intro s, rewrite [nth_succ, drop_succ, tails_eq, tail_cons, ih]}
end

theorem tails_eq_iterate (s : stream A) : tails s = iterate tail (tail s) :=
rfl

definition inits_core (l : list A) (s : stream A) : stream (list A) :=
corec
  prod.pr1
  (λ p, match p with (l', s') := (l' ++ [head s'], tail s') end)
  (l, s)

definition inits (s : stream A) : stream (list A) :=
inits_core [head s] (tail s)

theorem inits_core_eq (l : list A) (s : stream A) : inits_core l s = l :: inits_core (l ++ [head s]) (tail s) :=
by esimp [inits_core]; rewrite [corec_eq]

theorem tail_inits (s : stream A) : tail (inits s) = inits_core [head s, head (tail s)] (tail (tail s)) :=
by esimp [inits]; rewrite inits_core_eq

theorem inits_tail (s : stream A) : inits (tail s) = inits_core [head (tail s)] (tail (tail s)) :=
rfl

theorem cons_nth_inits_core : ∀ (a : A) (n : nat) (l : list A) (s : stream A),
                                 a :: nth n (inits_core l s) = nth n (inits_core (a::l) s) :=
begin
  intro a n,
  induction n with n' ih,
   {intros, reflexivity},
   {intro l s, rewrite [*nth_succ, inits_core_eq, +tail_cons, ih, inits_core_eq (a::l) s] }
end

theorem nth_inits : ∀ (n : nat) (s : stream A), nth n (inits s) = approx (succ n) s  :=
begin
  intro n, induction n with n' ih,
    {intros, reflexivity},
    {intros, rewrite [nth_succ, approx_succ, -ih, tail_inits, inits_tail, cons_nth_inits_core]}
end

theorem inits_eq (s : stream A) : inits s = [head s] :: map (list.cons (head s)) (inits (tail s)) :=
begin
  apply stream.ext, intro n,
  cases n,
    {reflexivity},
    {rewrite [nth_inits, nth_succ, tail_cons, nth_map, nth_inits]}
end

theorem zip_inits_tails (s : stream A) : zip append (inits s) (tails s) = const s :=
begin
  apply stream.ext, intro n,
  rewrite [nth_zip, nth_inits, nth_tails, nth_const, approx_succ,
           cons_append, append_approx_drop, stream.eta]
end

definition pure (a : A) : stream A :=
const a

definition apply (f : stream (A → B)) (s : stream A) : stream B :=
λ n, (nth n f) (nth n s)

infix `⊛`:75 := apply  -- input as \o*

theorem identity (s : stream A) : pure id ⊛ s = s :=
rfl
theorem composition (g : stream (B → C)) (f : stream (A → B)) (s : stream A) : pure comp ⊛ g ⊛ f ⊛ s = g ⊛ (f ⊛ s) :=
rfl
theorem homomorphism (f : A → B) (a : A) : pure f ⊛ pure a = pure (f a) :=
rfl
theorem interchange (fs : stream (A → B)) (a : A) : fs ⊛ pure a = pure (λ f, f a) ⊛ fs :=
rfl
theorem map_eq_apply (f : A → B) (s : stream A) : map f s = pure f ⊛ s :=
rfl

definition nats : stream nat :=
λ n, n

theorem nth_nats (n : nat) : nth n nats = n :=
rfl

theorem nats_eq : nats = 0 :: map succ nats :=
begin
  apply stream.ext, intro n,
  cases n, reflexivity, rewrite [nth_succ]
end

section
open equiv
lemma stream_equiv_of_equiv {A B : Type} : A ≃ B → stream A ≃ stream B
| (mk f g l r) :=
  mk (map f) (map g)
   begin intros, rewrite [map_map, id_of_left_inverse l, map_id] end
   begin intros, rewrite [map_map, id_of_right_inverse r, map_id] end
end

definition lex (rel : A → A → Prop) (s₁ s₂ : stream A) : Prop :=
∃ i, rel (nth i s₁) (nth i s₂) ∧ ∀ j, j < i → nth j s₁ = nth j s₂

definition lex.trans {s₁ s₂ s₃} {rel : A → A → Prop} : transitive rel → lex rel s₁ s₂ → lex rel s₂ s₃ → lex rel s₁ s₃ :=
assume htrans h₁ h₂,
obtain (i₁ : nat) hlt₁ he₁, from h₁,
obtain (i₂ : nat) hlt₂ he₂, from h₂,
lt.by_cases
  (λ i₁lti₂ : i₁ < i₂,
    have aux : nth i₁ s₂ = nth i₁ s₃, from he₂ _ i₁lti₂,
    begin
      existsi i₁, split,
       {rewrite -aux, exact hlt₁},
       {intro j jlti₁, transitivity nth j s₂,
         exact !he₁ jlti₁,
         exact !he₂ (lt.trans jlti₁ i₁lti₂)}
    end)
  (λ i₁eqi₂ : i₁ = i₂,
    begin
      subst i₂, existsi i₁, split, exact htrans hlt₁ hlt₂, intro j jlti₁,
        transitivity nth j s₂,
          exact !he₁ jlti₁;
          exact !he₂ jlti₁
    end)
  (λ i₂lti₁ : i₂ < i₁,
    have nth i₂ s₁ = nth i₂ s₂, from he₁ _ i₂lti₁,
    begin
      existsi i₂, split,
       {rewrite this, exact hlt₂},
       {intro j jlti₂, transitivity nth j s₂,
         exact !he₁ (lt.trans jlti₂ i₂lti₁),
         exact !he₂ jlti₂}
    end)
end stream


/-
Copyright (c) 2020 Johan Commelin, Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Damiano Testa
-/
import logic.equiv.basic
import logic.nontrivial
import order.basic

/-!
# Initial lemmas to work with the `order_dual`

## Definitions
`to_dual` and `of_dual` the order reversing identity maps, bundled as equivalences.

## Basic Lemmas to convert between an order and its dual

This file is similar to algebra/group/type_tags.lean
-/

open function

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w} {r : α → α → Prop}

namespace order_dual

instance [nontrivial α] : nontrivial (order_dual α) := by delta order_dual; assumption

/-- `to_dual` is the identity function to the `order_dual` of a linear order.  -/
def to_dual : α ≃ order_dual α := ⟨id, id, λ h, rfl, λ h, rfl⟩

/-- `of_dual` is the identity function from the `order_dual` of a linear order.  -/
def of_dual : order_dual α ≃ α := to_dual.symm

@[simp] lemma to_dual_symm_eq : (@to_dual α).symm = of_dual := rfl

@[simp] lemma of_dual_symm_eq : (@of_dual α).symm = to_dual := rfl

@[simp] lemma to_dual_of_dual (a : order_dual α) : to_dual (of_dual a) = a := rfl
@[simp] lemma of_dual_to_dual (a : α) : of_dual (to_dual a) = a := rfl

@[simp] lemma to_dual_inj {a b : α} :
  to_dual a = to_dual b ↔ a = b := iff.rfl

@[simp] lemma to_dual_le_to_dual [has_le α] {a b : α} :
  to_dual a ≤ to_dual b ↔ b ≤ a := iff.rfl

@[simp] lemma to_dual_lt_to_dual [has_lt α] {a b : α} :
  to_dual a < to_dual b ↔ b < a := iff.rfl

@[simp] lemma of_dual_inj {a b : order_dual α} :
  of_dual a = of_dual b ↔ a = b := iff.rfl

@[simp] lemma of_dual_le_of_dual [has_le α] {a b : order_dual α} :
  of_dual a ≤ of_dual b ↔ b ≤ a := iff.rfl

@[simp] lemma of_dual_lt_of_dual [has_lt α] {a b : order_dual α} :
  of_dual a < of_dual b ↔ b < a := iff.rfl

lemma le_to_dual [has_le α] {a : order_dual α} {b : α} :
  a ≤ to_dual b ↔ b ≤ of_dual a := iff.rfl

lemma lt_to_dual [has_lt α] {a : order_dual α} {b : α} :
  a < to_dual b ↔ b < of_dual a := iff.rfl

lemma to_dual_le [has_le α] {a : α} {b : order_dual α} :
  to_dual a ≤ b ↔ of_dual b ≤ a := iff.rfl

lemma to_dual_lt [has_lt α] {a : α} {b : order_dual α} :
  to_dual a < b ↔ of_dual b < a := iff.rfl

/-- Recursor for `order_dual α`. -/
@[elab_as_eliminator]
protected def rec {C : order_dual α → Sort*} (h₂ : Π (a : α), C (to_dual a)) :
  Π (a : order_dual α), C a := h₂

@[simp] protected lemma «forall» {p : order_dual α → Prop} : (∀ a, p a) ↔ ∀ a, p (to_dual a) :=
iff.rfl

@[simp] protected lemma «exists» {p : order_dual α → Prop} : (∃ a, p a) ↔ ∃ a, p (to_dual a) :=
iff.rfl

end order_dual

alias order_dual.to_dual_le_to_dual ↔ _ has_le.le.dual
alias order_dual.to_dual_lt_to_dual ↔ _ has_lt.lt.dual
alias order_dual.of_dual_le_of_dual ↔ _ has_le.le.of_dual
alias order_dual.of_dual_lt_of_dual ↔ _ has_lt.lt.of_dual


import GMLAlgebra.Basic
import GMLAlgebra.Group
import GMLAlgebra.Monoid
import GMLAlgebra.Semigroup
import GMLAlgebra.UnitalSemiring

namespace Algebra
variable {α} (s : RigSig α)

local infixr:70 " ⋆ " => s.mul
local infixr:65 " ⊹ " => s.add
local notation "𝟘" => s.zero

class Rig extends Semiring (no_index s.toSemiringSig) : Prop where
  protected add_right_id (x) : x ⊹ 𝟘 = x
  protected mul_left_zero (x) : 𝟘 ⋆ x = 𝟘
  protected mul_right_zero (x) : x ⋆ 𝟘 = 𝟘

protected def Rig.infer [OpAssoc s.add] [OpComm s.add] [OpRightId s.add s.zero] [OpAssoc s.mul] [OpLeftDistrib s.mul s.add] [OpRightDistrib s.mul s.add] [OpLeftNil s.mul s.zero] [OpRightNil s.mul s.zero] : Rig s where
  add_assoc := op_assoc _
  add_comm := op_comm _
  add_right_id := op_right_id _
  mul_assoc := op_assoc _
  mul_left_distrib := op_left_distrib _
  mul_right_distrib := op_right_distrib _
  mul_left_zero := op_left_nil _
  mul_right_zero := op_right_nil _

namespace Rig
variable {s} [self : Rig s]

local instance : OpRightId (no_index s.add) (no_index s.zero) := ⟨Rig.add_right_id⟩
instance : OpLeftNil (no_index s.mul) (no_index s.zero) := ⟨Rig.mul_left_zero⟩
instance : OpRightNil (no_index s.mul) (no_index s.zero) := ⟨Rig.mul_right_zero⟩

instance toAddCommMonoid : CommMonoid (no_index s.toAddMonoidSig) := CommMonoid.infer _

end Rig

class CommRig extends CommSemiring (no_index s.toSemiringSig): Prop where
  protected add_right_id (x) : x ⊹ 𝟘 = x
  protected mul_right_zero (x) : x ⋆ 𝟘 = 𝟘

protected def CommRig.infer [OpAssoc s.add] [OpComm s.add] [OpRightId s.add s.zero] [OpAssoc s.mul] [OpComm s.mul] [OpRightDistrib s.mul s.add] [OpRightNil s.mul s.zero] : CommRig s where
  add_assoc := op_assoc _
  add_comm := op_comm _
  add_right_id := op_right_id _
  mul_assoc := op_assoc _
  mul_comm := op_comm _
  mul_right_distrib := op_right_distrib _
  mul_right_zero := op_right_nil _

namespace CommRig
variable {s} [self : CommRig s]

local instance : OpRightId (no_index s.add) (no_index s.zero) := ⟨CommRig.add_right_id⟩
local instance : OpRightNil (no_index s.mul) (no_index s.zero) := ⟨CommRig.mul_right_zero⟩

protected theorem mul_left_zero (x) : 𝟘 ⋆ x = 𝟘 := calc
  _ = x ⋆ 𝟘 := by rw [op_comm (.⋆.) x 𝟘]
  _ = 𝟘 := by rw [op_right_nil (.⋆.) x]
local instance : OpLeftNil (no_index s.mul) (no_index s.zero) := ⟨CommRig.mul_left_zero⟩

instance toRig : Rig s := Rig.infer s

end CommRig

class CancelRig extends Semiring (no_index s.toSemiringSig) : Prop where
  protected add_right_id (x) : x ⊹ 𝟘 = x
  protected add_right_cancel (x) {y z} : y ⊹ x = z ⊹ x → y = z

protected def CancelRig.infer [OpAssoc s.add] [OpComm s.add] [OpRightId s.add s.zero] [OpRightCancel s.add] [OpAssoc s.mul] [OpLeftDistrib s.mul s.add] [OpRightDistrib s.mul s.add] : CancelRig s where
  add_assoc := op_assoc _
  add_comm := op_comm _
  add_right_id := op_right_id _
  add_right_cancel := op_right_cancel _
  mul_assoc := op_assoc _
  mul_left_distrib := op_left_distrib _
  mul_right_distrib := op_right_distrib _

namespace CancelRig
variable {s} [self : CancelRig s]

local instance : OpRightId (no_index s.add) (no_index s.zero) := ⟨CancelRig.add_right_id⟩
local instance : OpRightCancel (no_index s.add) := ⟨CancelRig.add_right_cancel⟩

instance toAddCancelCommMonoid : CancelCommMonoid (no_index s.toAddMonoidSig) := CancelCommMonoid.infer _

protected theorem mul_left_zero (x) : 𝟘 ⋆ x = 𝟘 :=
  op_right_cancel (.⊹.) (𝟘 ⋆ x) $ calc
  _ = (𝟘 ⊹ 𝟘) ⋆ x := by rw [op_right_distrib (.⋆.) 𝟘 𝟘 x]
  _ = 𝟘 ⋆ x := by rw [op_right_id (.⊹.) 𝟘]
  _ = 𝟘 ⊹ 𝟘 ⋆ x := by rw [op_left_id (.⊹.)]
local instance : OpLeftNil (no_index s.mul) (no_index s.zero) := ⟨CancelRig.mul_left_zero⟩

protected theorem mul_right_zero (x) : x ⋆ 𝟘 = 𝟘 :=
  op_right_cancel (.⊹.) (x ⋆ 𝟘) $ calc
  _ = x ⋆ (𝟘 ⊹ 𝟘) := by rw [op_left_distrib (.⋆.) x 𝟘 𝟘]
  _ = x ⋆ 𝟘 := by rw [op_right_id (.⊹.) 𝟘]
  _ = 𝟘 ⊹ x ⋆ 𝟘 := by rw [op_left_id (.⊹.)]
local instance : OpRightNil (no_index s.mul) (no_index s.zero) := ⟨CancelRig.mul_right_zero⟩

instance toRig : Rig s := Rig.infer s

end CancelRig

class CancelCommRig extends CommSemiring (no_index s.toSemiringSig) : Prop where
  protected add_right_id (x) : x ⊹ 𝟘 = x
  protected add_right_cancel (x) {y z} : y ⊹ x = z ⊹ x → y = z

protected def CancelCommRig.infer [OpAssoc s.add] [OpComm s.add] [OpRightId s.add s.zero] [OpRightCancel s.add] [OpAssoc s.mul] [OpComm s.mul] [OpRightDistrib s.mul s.add] : CancelCommRig s where
  add_assoc := op_assoc _
  add_comm := op_comm _
  add_right_id := op_right_id _
  add_right_cancel := op_right_cancel _
  mul_assoc := op_assoc _
  mul_comm := op_comm _
  mul_right_distrib := op_right_distrib _

namespace CancelCommRig
variable {s} [self : CancelCommRig s]

local instance : OpRightId (no_index s.add) (no_index s.zero) := ⟨CancelCommRig.add_right_id⟩
local instance : OpRightCancel (no_index s.add) := ⟨CancelCommRig.add_right_cancel⟩

instance toCancelRig : CancelRig s := CancelRig.infer s

instance toCommRig : CommRig s := CommRig.infer s

end CancelCommRig

end Algebra


/-
1. Fill in the sorry’s in the last three proofs below.
-/
import data.set

section ex1

open function int algebra

def f (x : ℤ) : ℤ := x + 3
def g (x : ℤ) : ℤ := -x
def h (x : ℤ) : ℤ := 2 * x + 3

example : injective f :=
assume x1 x2,
assume h1 : x1 + 3 = x2 + 3,   -- Lean knows this is the same as f x1 = f x2
show x1 = x2, from eq_of_add_eq_add_right h1

example : surjective f :=
assume y,
have h1 : f (y - 3) = y, from calc
  f (y - 3) = (y - 3) + 3 : rfl
        ... = y           : by rw sub_add_cancel,
show ∃ x, f x = y, from exists.intro (y - 3) h1

example (x y : ℤ) (h : 2 * x = 2 * y) : x = y :=
have h1 : 2 ≠ (0 : ℤ), from dec_trivial,  -- this tells Lean to figure it out itself
show x = y, from eq_of_mul_eq_mul_left h1 h

example (x : ℤ) : -(-x) = x := neg_neg x

example (A B : Type) (u : A → B) (v : B → A) (h : left_inverse u v) :
  ∀ x, u (v x) = x :=
h

example (A B : Type) (u : A → B) (v : B → A) (h : left_inverse u v) :
  right_inverse v u :=
h

-- fill in the sorry's in the following proofs

example : injective h :=
assume x y : ℤ,
assume q : 2 * x + 3 = 2 * y + 3,
have h : 2 * x = 2 * y, from
  calc 2 * x = (2 * x + 3) - 3 : by simp
         ... = (2 * y + 3) - 3 : by rw q
         ... = 2 * y           : by simp,
have h1 : 2 ≠ (0 : ℤ), from dec_trivial,
show x = y, from eq_of_mul_eq_mul_left h1 h

example : surjective g :=
assume y,
have h1 : g (-y) = y, from calc
  g (-y) = -(-y) : rfl
     ... = y     : neg_neg y,
show ∃ x, g x = y, from ⟨-y, h1⟩

example (A B : Type) (u : A → B) (v1 : B → A) (v2 : B → A)
  (h1 : left_inverse v1 u) (h2 : right_inverse v2 u) : v1 = v2 :=
funext
  (assume x,
    calc
      v1 x = v1 (u (v2 x)) : by rw h2
       ... = v2 x          : by rw h1)

end ex1

/-
2. Fill in the sorry in the proof below.
-/

section ex2

open function set

variables {X Y : Type}
variable  f : X → Y
variables A B : set X

example : f '' (A ∪ B) = f '' A ∪ f '' B :=
eq_of_subset_of_subset
  (assume y,
    assume h1 : y ∈ f '' (A ∪ B),
    exists.elim h1 $
    assume x h,
    have h2 : x ∈ A ∪ B, from h.left,
    have h3 : f x = y, from h.right,
    or.elim h2
      (assume h4 : x ∈ A,
        have h5 : y ∈ f '' A, from ⟨x, h4, h3⟩,
        show y ∈ f '' A ∪ f '' B, from or.inl h5)
      (assume h4 : x ∈ B,
        have h5 : y ∈ f ''  B, from ⟨x, h4, h3⟩,
        show y ∈ f '' A ∪ f '' B, from or.inr h5))
  (assume y,
    assume h2 : y ∈ f '' A ∪ f '' B,
    or.elim h2
      (assume h3 : y ∈ f '' A,
        exists.elim h3 $
        assume x h,
        have h4 : x ∈ A, from h.left,
        have h5 : f x = y, from h.right,
        have h6 : x ∈ A ∪ B, from or.inl h4,
        show y ∈ f '' (A ∪ B), from ⟨x, h6, h5⟩)
      (assume h3 : y ∈ f '' B,
        exists.elim h3 $
        assume x h,
        have h4 : x ∈ B, from h.left,
        have h5 : f x = y, from h.right,
        have h6 : x ∈ A ∪ B, from or.inr h4,
        show y ∈ f '' (A ∪ B), from ⟨x, h6, h5⟩))

-- remember, x ∈ A ∩ B is the same as x ∈ A ∧ x ∈ B
example (x : X) (h1 : x ∈ A) (h2 : x ∈ B) : x ∈ A ∩ B :=
and.intro h1 h2

example (x : X) (h1 : x ∈ A ∩ B) : x ∈ A :=
and.left h1

-- Fill in the proof below.
-- (It should take about 8 lines.)

example : f '' (A ∩ B) ⊆ f '' A ∩ f '' B :=
assume y,
assume h1 : y ∈ f '' (A ∩ B),
show y ∈ f '' A ∩ f '' B, from (
  exists.elim h1 $
  assume (x : X) (h : x ∈ A ∩ B ∧ f x = y),
  have ha : x ∈ A, from h.left.left,
  have hb : x ∈ B, from h.left.right,
  have he : f x = y, from h.right,
  show y ∈ f '' A ∩ f '' B, from ⟨⟨x, ha, he⟩, ⟨x, hb, he⟩⟩
)

end ex2


import Lean

/- from core:
class OfNat (α : Type u) (n : Nat) where
  ofNat : α
class Mul (α : Type u) where
  mul : α → α → α
class Add (α : Type u) where
  add : α → α → α
-/

class Inv (α : Type u) where
    inv : α → α

postfix:max "⁻¹" => Inv.inv

class One (α : Type u) where
    one : α
export One (one)

instance [One α] : OfNat α (nat_lit 1) where
    ofNat := one

class Zero (α : Type u) where
    zero : α
export Zero (zero)

instance [Zero α] : OfNat α (nat_lit 0) where
    ofNat := zero

class MulComm (α : Type u) [Mul α] : Prop where
    mulComm : {a b : α} → a * b = b * a
export MulComm (mulComm)

class MulAssoc (α : Type u) [Mul α] : Prop where
    mulAssoc : {a b c : α} → a * b * c = a * (b * c)
export MulAssoc (mulAssoc)

class OneUnit (α : Type u) [Mul α] [One α] : Prop where
    oneMul : {a : α} → 1 * a = a
    mulOne : {a : α} → a * 1 = a
export OneUnit (oneMul mulOne)

class AddComm (α : Type u) [Add α] : Prop where
    addComm : {a b : α} → a + b = b + a
export AddComm (addComm)

class AddAssoc (α : Type u) [Add α] : Prop where
    addAssoc : {a b c : α} → a + b + c = a + (b + c)
export AddAssoc (addAssoc)

class ZeroUnit (α : Type u) [Add α] [Zero α] : Prop where
    zeroAdd : {a : α} → 0 + a = a
    addZero : {a : α} → a + 0 = a
export ZeroUnit (zeroAdd addZero)

class InvMul (α : Type u) [Mul α] [One α] [Inv α] : Prop where
    invMul : {a : α} → a⁻¹ * a = 1
export InvMul (invMul)

class NegAdd (α : Type u) [Add α] [Zero α] [Neg α] : Prop where
    negAdd : {a : α} → -a + a = 0
export NegAdd (negAdd)

class ZeroMul (α : Type u) [Mul α] [Zero α] : Prop where
    zeroMul : {a : α} → 0 * a = 0
export ZeroMul (zeroMul)

class Distrib (α : Type u) [Add α] [Mul α] : Prop where
    leftDistrib : {a b c : α} → a * (b + c) = a * b + a * c
    rightDistrib : {a b c : α} → (a + b) * c = a * c + b * c
export Distrib (leftDistrib rightDistrib)

class Domain (α : Type u) [Mul α] [Zero α] : Prop where
    eqZeroOrEqZeroOfMulEqZero : {a b : α} → a * b = 0 → a = 0 ∨ b = 0
export Domain (eqZeroOrEqZeroOfMulEqZero)

class Semigroup (α : Type u) extends Mul α, MulAssoc α
attribute [instance] Semigroup.mk

class AddSemigroup (α : Type u) extends Add α, AddAssoc α
attribute [instance] AddSemigroup.mk

class Monoid (α : Type u) extends Semigroup α, One α, OneUnit α
attribute [instance] Monoid.mk

class AddMonoid (α : Type u) extends AddSemigroup α, Zero α, ZeroUnit α
attribute [instance] AddMonoid.mk

class CommSemigroup (α : Type u) extends Semigroup α, MulComm α
attribute [instance] CommSemigroup.mk

class CommMonoid (α : Type u) extends Monoid α, MulComm α
attribute [instance] CommMonoid.mk

class Group (α : Type u) extends Monoid α, Inv α, InvMul α
attribute [instance] Group.mk

class AddGroup (α : Type u) extends AddMonoid α, Neg α, NegAdd α
attribute [instance] AddGroup.mk

class Semiring (α : Type u) extends AddMonoid α, Monoid α, AddComm α, ZeroMul α, Distrib α
attribute [instance] Semiring.mk

class Ring (α : Type u) extends AddGroup α, Monoid α, AddComm α, Distrib α
attribute [instance] Ring.mk

class CommRing (α : Type u) extends Ring α, MulComm α
attribute [instance] CommRing.mk

class IntegralDomain (α : Type u) extends CommRing α, Domain α
attribute [instance] IntegralDomain.mk

section test1
variable (α : Type u) [h : CommMonoid α]
example : Semigroup α := inferInstance
example : Monoid α := inferInstance
example : CommSemigroup α := inferInstance
end test1

section test2
variable (β : Type u) [CommSemigroup β] [One β] [OneUnit β]
example : Monoid β := inferInstance
example : CommMonoid β := inferInstance
example : Semigroup β := inferInstance
end test2

section test3
variable (β : Type u) [Mul β] [One β] [MulAssoc β] [OneUnit β]
example : Monoid β := inferInstance
example : Semigroup β := inferInstance
end test3

theorem negZero [AddGroup α] : -(0 : α) = 0 := by
    rw [←addZero (a := -(0 : α)), negAdd]

theorem subZero [AddGroup α] {a : α} : a + -(0 : α) = a := by
    rw [←addZero (a := a), addAssoc, negZero, addZero]

theorem negNeg [AddGroup α] {a : α} : -(-a) = a := by {
    rw [←addZero (a := - -a)];
    rw [←negAdd (a := a)];
    rw [←addAssoc];
    rw [negAdd];
    rw [zeroAdd];
}

theorem addNeg [AddGroup α] {a : α} : a + -a = 0 := by {
    have h : - -a + -a = 0 := by { rw [negAdd] };
    rw [negNeg] at h;
    exact h
}

theorem addIdemIffZero [AddGroup α] {a : α} : a + a = a ↔ a = 0 := by
    apply Iff.intro
    focus
        intro h
        have h' := congrArg (λ x => x + -a) h
        simp at h'
        rw [addAssoc, addNeg, addZero] at h'
        exact h'
    focus
        intro h
        subst a
        rw [addZero]

instance [Ring α] : ZeroMul α := by {
    apply ZeroMul.mk;
    intro a;
    have h : 0 * a + 0 * a = 0 * a := by { rw [←rightDistrib, addZero] };
    rw [addIdemIffZero (a := 0 * a)] at h;
    rw [h];
}

example [Ring α] : Semiring α := inferInstance

section prod

instance [Mul α] [Mul β] : Mul (α × β) where
    mul p p' := (p.1 * p'.1, p.2 * p'.2)

instance [Inv α] [Inv β] : Inv (α × β) where
    inv p := (p.1⁻¹, p.2⁻¹)

instance [One α] [One β] : One (α × β) where
    one := (1, 1)

theorem Product.ext : {p q : α × β} → p.1 = q.1 → p.2 = q.2 → p = q
    | (a, b), (c, d) => by simp_all

instance [Semigroup α] [Semigroup β] : Semigroup (α × β) where
    mulAssoc := by
        intros
        apply Product.ext
        apply mulAssoc
        apply mulAssoc

instance [Monoid α] [Monoid β] : Monoid (α × β) where
    oneMul := by
        intros
        apply Product.ext
        apply oneMul
        apply oneMul
    mulOne := by
        intros
        apply Product.ext
        apply mulOne
        apply mulOne

instance [Group α] [Group β] : Group (α × β) where
    invMul := by
        intros
        apply Product.ext
        apply invMul
        apply invMul

end prod

def test1 {G : Type _} [Group G]: Group (G) := inferInstance
def test2 {G : Type _} [Group G]: Group (G × G) := inferInstance
def test3 {G : Type _} [Group G]: Group (G × G × G) := inferInstance
def test4 {G : Type _} [Group G]: Group (G × G × G × G) := inferInstance
def test5 {G : Type _} [Group G]: Group (G × G × G × G × G) := inferInstance
def test6 {G : Type _} [Group G]: Group (G × G × G × G × G × G) := inferInstance
def test7 {G : Type _} [Group G]: Group (G × G × G × G × G × G × G) := inferInstance
def test8 {G : Type _} [Group G]: Group (G × G × G × G × G × G × G × G) := inferInstance

namespace Lean

unsafe def Expr.dagSizeUnsafe (e : Expr) : IO Nat := do
  let (_, s) ← visit e |>.run ({}, 0)
  return s.2
where
  visit (e : Expr) : StateRefT (HashSet USize × Nat) IO Unit := do
    let addr := ptrAddrUnsafe e
    unless (← get).1.contains addr do
      modify fun (s, c) => (s.insert addr, c+1)
      match e with
      | Expr.proj _ _ s      => visit s
      | Expr.forallE _ d b _ => visit d; visit b
      | Expr.lam _ d b _     => visit d; visit b
      | Expr.letE _ t v b _  => visit t; visit v; visit b
      | Expr.app f a         => visit f; visit a
      | Expr.mdata _ b       => visit b
      | _ => return ()

@[implemented_by Expr.dagSizeUnsafe]
opaque Expr.dagSize (e : Expr) : IO Nat

def getDeclTypeValueDagSize (declName : Name) : CoreM Nat := do
  let info ← getConstInfo declName
  let n ← info.type.dagSize
  match info.value? with
  | none   => return n
  | some v => return n + (← v.dagSize)

#eval getDeclTypeValueDagSize `test2
#eval getDeclTypeValueDagSize `test3
#eval getDeclTypeValueDagSize `test4
#eval getDeclTypeValueDagSize `test5
#eval getDeclTypeValueDagSize `test6
#eval getDeclTypeValueDagSize `test7
#eval getDeclTypeValueDagSize `test8

def reduceAndGetDagSize (declName : Name) : MetaM Nat := do
  let c := mkConst declName [levelOne]
  let e ← Meta.reduce c
  trace[Meta.debug] "{e}"
  e.dagSize

#eval reduceAndGetDagSize `test1
#eval reduceAndGetDagSize `test2
#eval reduceAndGetDagSize `test3
#eval reduceAndGetDagSize `test4
#eval reduceAndGetDagSize `test5
#eval reduceAndGetDagSize `test6
#eval reduceAndGetDagSize `test7
-- Use `set_option` to trace the reduced term
set_option pp.all true in
set_option trace.Meta.debug true in
#eval reduceAndGetDagSize `test8


import Mathlib.Data.Finset.Card
import Mathlib.Data.Finset.Lattice
import Mathlib.Data.Fintype.Basic

class Matroid (E : Type _) [DecidableEq E] extends Fintype E :=
  ( bases' : Finset (Finset E) )
  ( independents' : Finset (Finset E) )
  ( circuits' : Finset (Finset E))
  ( mem_independents_iff' : ∀ i, i ∈ independents' ↔ ∃ b ∈ bases', i ⊆ b )
  ( bases_nonempty' : bases'.Nonempty )
  ( circuits_eq' : ∀ c, c ∈ circuits' ↔ (c ∉ independents' ∧
    ∀ c', c' ∉ independents' → c' ⊆ c → c' = c))
  ( steinitz_exchange' : ∀ {B₁ B₂},
      B₁ ∈ bases' → B₂ ∈ bases' → ∀ {e : E},
      e ∈ B₁ \ B₂ → ∃ f ∈ B₂ \ B₁,
        (B₁ ∪ {f}) \ {e} ∈ bases' )

namespace Matroid

variable {E : Type _} [DecidableEq E] [Matroid E]

/-- `bases` are maximal independent Finsets -/
def bases (E : Type _) [DecidableEq E] [Matroid E] : Finset (Finset E) :=
  Matroid.bases'

theorem bases_nonempty (E : Type _) [DecidableEq E] [Matroid E] : (bases E).Nonempty :=
  Matroid.bases_nonempty'

/-- `circuits` are minimal dependent Finsets -/
def circuits (E : Type _) [DecidableEq E] [Matroid E] : Finset (Finset E) :=
  Matroid.circuits'

/-- `independents` are subFinsets of bases -/
def independents (E : Type _) [DecidableEq E] [Matroid E] : Finset (Finset E) :=
  Matroid.independents'

theorem mem_circuits_iff_independents {c : Finset E} : c ∈ circuits E ↔
    (c ∉ independents E ∧ ∀ c', c' ∉ independents E → c' ⊆ c → c' = c) :=
  Matroid.circuits_eq' c

theorem mem_independents_iff_bases {i : Finset E} : i ∈ independents E ↔
    ∃ b ∈ bases E, i ⊆ b :=
  Matroid.mem_independents_iff' i

theorem steinitz_exchange : ∀ {B₁ B₂},
    B₁ ∈ bases E → B₂ ∈ bases E → ∀ {e : E},
    e ∈ (B₁ \ B₂) → ∃ f ∈ B₂ \ B₁, (B₁ ∪ {f}) \ {e} ∈ bases E :=
  Matroid.steinitz_exchange'

theorem mem_bases_iff_independents {b : Finset E} : b ∈ bases E ↔
    (b ∈ independents E ∧ ∀ i ∈ independents E, b ⊆ i → b = i) := by
  simp only [mem_independents_iff_bases]
  constructor
  . refine' fun hb => ⟨⟨b, hb, Finset.Subset.refl _⟩,
      fun b' ⟨b₂, hb₂⟩ hb' => _⟩
    by_contra heq
    have hbb₂ : b ≠ b₂ := by
      rintro rfl
      exact heq (Finset.Subset.antisymm hb' hb₂.2)
    have hbb₂ : b ⊂ b₂ := Finset.ssubset_iff_subset_ne.2 ⟨hb'.trans hb₂.2, hbb₂⟩
    rcases Finset.exists_of_ssubset hbb₂ with ⟨e, he⟩
    rcases steinitz_exchange hb₂.1 hb (by simpa using he) with ⟨f, hf, _⟩
    rw [Finset.mem_sdiff] at hf
    exact hf.2 (hbb₂.subset hf.1)
  . rintro ⟨⟨b', hb'⟩, h⟩
    rw [h b' ⟨b', hb'.1, refl _⟩ hb'.2]
    exact hb'.1

theorem mem_circuits_iff_independents' {c : Finset E} : c ∈ circuits E ↔
    (c ∉ independents E ∧ ∀ (i), i ⊂ c → i ∈ independents E) := by
  simp only [mem_circuits_iff_independents, @not_imp_comm (_ ∈ independents E), not_forall, exists_prop,
    and_imp, ssubset_iff_subset_ne, ne_eq]

theorem empty_mem_independents : ∅ ∈ independents E := by
  rcases bases_nonempty E with ⟨b, hb⟩
  exact mem_independents_iff_bases.2 ⟨b, hb, Finset.empty_subset _⟩

theorem mem_independents_of_subset {i₁ i₂} (h : i₁ ⊆ i₂) (hi : i₂ ∈ independents E) :
    (i₁ ∈ independents E) :=
  let ⟨b, hb⟩ := mem_independents_iff_bases.1 hi
  mem_independents_iff_bases.2 ⟨b, hb.1, h.trans hb.2⟩

open Finset

-- theorem augmentation_aux {i₁ i₂ : Finset E} (h₁ : i₁ ∈ independents E)
--     (h₂ : i₂ ∈ independents E) (hc : card i₁ < card i₂) :
--     ∃ e ∈ i₂ \ i₁, i₁ ∪ {e} ∈ independents E := by
--   let ⟨b₁, hb₁⟩ := mem_independents_iff_bases.1 h₁
--   let ⟨b₂, hb₂⟩ := mem_independents_iff_bases.1 h₂
--   have : (i₂ \ i₁).Nonempty := by
--     by_contra h
--     have h : i₂ ⊆ i₁ := by simpa only [not_nonempty_iff_eq_empty, sdiff_eq_empty_iff_subset] using h
--     exact not_le_of_lt hc (card_le_of_subset h)
--   rcases this with ⟨e, he⟩
--   rw [mem_sdiff] at he
--   by_cases hi₁ : i₁ ∪ {e} ∈ independents E
--   . exact ⟨e, mem_sdiff.2 he, hi₁⟩
--   . rcases steinitz_exchange hb₂.1 hb₁.1 (show e ∈ b₂ \ b₁ from mem_sdiff.2 ⟨hb₂.2 he.1,
--       fun h => hi₁ (mem_independents_iff_bases.2 ⟨b₁, hb₁.1, union_subset hb₁.2 (by simpa using h)⟩)⟩) with ⟨f, hf, hb⟩

private theorem basis_card_aux (b₁ b₂ : Finset E) (h₁ : b₁ ∈ bases E)
    (h₂ : b₂ ∈ bases E) (hlt : Finset.card b₂ < Finset.card b₁) : False := by
  have : (b₁ \ b₂).Nonempty := by
    by_contra h
    have h : b₁ ⊆ b₂ := by simpa only [not_nonempty_iff_eq_empty, sdiff_eq_empty_iff_subset] using h
    exact not_le_of_lt hlt (card_le_of_subset h)
  rcases this with ⟨e, he⟩
  rcases steinitz_exchange h₁ h₂ he with ⟨f, hf, hb⟩
  simp only [mem_sdiff] at he hf
  have : Finset.card b₂ < Finset.card ((b₁ ∪ {f}) \ {e}) := by
    rw [card_sdiff, card_disjoint_union] <;> simp [hlt, hf.2, he.1]
  have _wf : card (((b₁ ∪ {f}) \ {e}) \ b₂) < card (b₁ \ b₂) := by
    apply card_lt_card
    simp only [mem_union, mem_singleton, ssubset_def, subset_iff, mem_sdiff, and_imp, not_forall, not_and,
      not_not, exists_prop, exists_and_left]
    aesop
  exact basis_card_aux _ _ hb h₂ this
termination_by basis_card_aux b₁ b₂ _ _ _ => Finset.card (b₁ \ b₂)

theorem basis_card {b₁ b₂ : Finset E}  (h₁ : b₁ ∈ bases E)
    (h₂ : b₂ ∈ bases E) : Finset.card b₁ = Finset.card b₂ :=
  match lt_trichotomy (Finset.card b₁) (Finset.card b₂) with
  | Or.inl hlt => (basis_card_aux b₂ b₁ h₂ h₁ hlt).elim
  | Or.inr (Or.inl heq) => heq
  | Or.inr (Or.inr hlt) => (basis_card_aux b₁ b₂ h₁ h₂ hlt).elim

private theorem augmentation_aux (i₁ i₂ : Finset E) (b₁ b₂ : Finset E) (hb₁ : b₁ ∈ bases E)
    (hb₂ : b₂ ∈ bases E) (hib₁ : i₁ ⊆ b₁) (hib₂ : i₂ ⊆ b₂) (hc : card i₁ < card i₂) :
    ∃ e ∈ i₂ \ i₁, i₁ ∪ {e} ∈ independents E := by
  by_cases ht : ((b₁ \ i₁) \ b₂).Nonempty
  . rcases ht with ⟨t, ht⟩
    simp only [mem_sdiff] at ht
    rcases steinitz_exchange hb₁ hb₂ (mem_sdiff.2 ⟨ht.1.1, ht.2⟩) with ⟨f, hf⟩
    have _wf : card (b₂ \ ((b₁ ∪ {f}) \ {t})) < card (b₂ \ b₁) := by
      apply card_lt_card
      simp only [mem_union, mem_singleton, ssubset_def, subset_iff, mem_sdiff, and_imp, not_forall, not_and,
        not_not, exists_prop, exists_and_left]
      aesop
    exact @augmentation_aux i₁ i₂ _ b₂ hf.2 hb₂ (subset_sdiff.2 ⟨hib₁.trans (subset_union_left _ _),
      (by simpa using ht.1.2)⟩) hib₂ hc
  . replace ht : b₁ \ i₁ ⊆ b₂ := by simpa using ht
    have : ¬ Disjoint (b₁ \ i₁) i₂ := by
      intro h
      apply not_le.2 hc
      apply le_of_add_le_add_left (a := card (b₁ \ i₁))
      rw [← card_disjoint_union h]
      apply le_trans (card_le_of_subset (show b₁ \ i₁ ∪ i₂ ⊆ b₂ from union_subset ht hib₂))
      rw [← basis_card hb₁ hb₂, ← card_disjoint_union, sdiff_union_self_eq_union]
      exact card_le_of_subset (subset_union_left _ _)
      exact disjoint_iff_inter_eq_empty.2 (by simp)
    rw [disjoint_iff_inter_eq_empty, ← Ne.def, ← nonempty_iff_ne_empty] at this
    rcases this with ⟨e, he⟩
    simp only [mem_inter, mem_sdiff] at he
    exact ⟨e, mem_sdiff.2 ⟨he.2, he.1.2⟩, mem_independents_iff_bases.2 ⟨b₁, hb₁,
      union_subset hib₁ (by simpa using he.1.1)⟩⟩
termination_by augmentation_aux i₁ i₂ b₁ b₂ _ _ _ _ _ => Finset.card (b₂ \ b₁)

theorem augmentation {i₁ i₂ : Finset E} (hi₁ : i₁ ∈ independents E) (hi₂ : i₂ ∈ independents E)
    (hc : card i₁ < card i₂) : ∃ e ∈ i₂ \ i₁, i₁ ∪ {e} ∈ independents E :=
  let ⟨b₁, hb₁⟩ := mem_independents_iff_bases.1 hi₁
  let ⟨b₂, hb₂⟩ := mem_independents_iff_bases.1 hi₂
  augmentation_aux i₁ i₂ b₁ b₂ hb₁.1 hb₂.1 hb₁.2 hb₂.2 hc

end Matroid


import graphs.definitions

/-
Now that we know the compatability condition holds, we can go ahead and
define composition of morphisms.
-/

def compose {G H K : graph} (β : H ↦ K) (α : G ↦ H) : G ↦ K :=
  morphism.mk (β.vertex_map ∘ α.vertex_map) (β.edge_map ∘ α.edge_map) (by exact compatability α β)

/-
We want a convenient infix operator for composition of morphisms.
-/

infix `⊚`:80 := compose

/-
Proving associativity of composition is now trivial ...
-/

/- Lemma :
For all morphisms $α : G → H$, $β : H → K$ and $γ : K → L$, we have
$γ ∘ (β ∘ α) = (γ ∘ β) ∘ α$.
-/
lemma mor_assoc {G H K L : graph} (α : G ↦ H) (β : H ↦ K) (γ : K ↦ L) : γ ⊚ (β ⊚ α) = (γ ⊚ β) ⊚ α :=
begin
  sorry,

end


/-
Copyright (c) 2020 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.specific_limits
import Mathlib.analysis.asymptotics
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# The group of units of a complete normed ring

This file contains the basic theory for the group of units (invertible elements) of a complete
normed ring (Banach algebras being a notable special case).

## Main results

The constructions `one_sub`, `add` and `unit_of_nearby` state, in varying forms, that perturbations
of a unit are units.  The latter two are not stated in their optimal form; more precise versions
would use the spectral radius.

The first main result is `is_open`:  the group of units of a complete normed ring is an open subset
of the ring.

The function `inverse` (defined in `algebra.ring`), for a ring `R`, sends `a : R` to `a⁻¹` if `a` is
a unit and 0 if not.  The other major results of this file (notably `inverse_add`,
`inverse_add_norm` and `inverse_add_norm_diff_nth_order`) cover the asymptotic properties of
`inverse (x + t)` as `t → 0`.

-/

namespace units

/-- In a complete normed ring, a perturbation of `1` by an element `t` of distance less than `1`
from `1` is a unit.  Here we construct its `units` structure.  -/
def one_sub {R : Type u_1} [normed_ring R] [complete_space R] (t : R) (h : norm t < 1) : units R :=
  mk (1 - t) (tsum fun (n : ℕ) => t ^ n) (mul_neg_geom_series t h) (geom_series_mul_neg t h)

@[simp] theorem one_sub_coe {R : Type u_1} [normed_ring R] [complete_space R] (t : R) (h : norm t < 1) : ↑(one_sub t h) = 1 - t :=
  rfl

/-- In a complete normed ring, a perturbation of a unit `x` by an element `t` of distance less than
`∥x⁻¹∥⁻¹` from `x` is a unit.  Here we construct its `units` structure. -/
def add {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) (t : R) (h : norm t < (norm ↑(x⁻¹)⁻¹)) : units R :=
  x * one_sub (-(↑(x⁻¹) * t)) sorry

@[simp] theorem add_coe {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) (t : R) (h : norm t < (norm ↑(x⁻¹)⁻¹)) : ↑(add x t h) = ↑x + t := sorry

/-- In a complete normed ring, an element `y` of distance less than `∥x⁻¹∥⁻¹` from `x` is a unit.
Here we construct its `units` structure. -/
def unit_of_nearby {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) (y : R) (h : norm (y - ↑x) < (norm ↑(x⁻¹)⁻¹)) : units R :=
  add x (y - ↑x) h

@[simp] theorem unit_of_nearby_coe {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) (y : R) (h : norm (y - ↑x) < (norm ↑(x⁻¹)⁻¹)) : ↑(unit_of_nearby x y h) = y := sorry

/-- The group of units of a complete normed ring is an open subset of the ring. -/
theorem is_open {R : Type u_1} [normed_ring R] [complete_space R] : is_open (set_of fun (x : R) => is_unit x) := sorry

theorem nhds {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) : (set_of fun (x : R) => is_unit x) ∈ nhds ↑x :=
  mem_nhds_sets is_open
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑x ∈ set_of fun (x : R) => is_unit x)) set.mem_set_of_eq)) (is_unit_unit x))

end units

namespace normed_ring

theorem inverse_one_sub {R : Type u_1} [normed_ring R] [complete_space R] (t : R) (h : norm t < 1) : ring.inverse (1 - t) = ↑(units.one_sub t h⁻¹) := sorry

/-- The formula `inverse (x + t) = inverse (1 + x⁻¹ * t) * x⁻¹` holds for `t` sufficiently small. -/
theorem inverse_add {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) : filter.eventually (fun (t : R) => ring.inverse (↑x + t) = ring.inverse (1 + ↑(x⁻¹) * t) * ↑(x⁻¹)) (nhds 0) := sorry

theorem inverse_one_sub_nth_order {R : Type u_1} [normed_ring R] [complete_space R] (n : ℕ) : filter.eventually
  (fun (t : R) =>
    ring.inverse (1 - t) = (finset.sum (finset.range n) fun (i : ℕ) => t ^ i) + t ^ n * ring.inverse (1 - t))
  (nhds 0) := sorry

/-- The formula
`inverse (x + t) = (∑ i in range n, (- x⁻¹ * t) ^ i) * x⁻¹ + (- x⁻¹ * t) ^ n * inverse (x + t)`
holds for `t` sufficiently small. -/
theorem inverse_add_nth_order {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) (n : ℕ) : filter.eventually
  (fun (t : R) =>
    ring.inverse (↑x + t) =
      (finset.sum (finset.range n) fun (i : ℕ) => (-↑(x⁻¹) * t) ^ i) * ↑(x⁻¹) +
        (-↑(x⁻¹) * t) ^ n * ring.inverse (↑x + t))
  (nhds 0) := sorry

theorem inverse_one_sub_norm {R : Type u_1} [normed_ring R] [complete_space R] : asymptotics.is_O (fun (t : R) => ring.inverse (1 - t)) (fun (t : R) => 1) (nhds 0) := sorry

/-- The function `λ t, inverse (x + t)` is O(1) as `t → 0`. -/
theorem inverse_add_norm {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) : asymptotics.is_O (fun (t : R) => ring.inverse (↑x + t)) (fun (t : R) => 1) (nhds 0) := sorry

/-- The function
`λ t, inverse (x + t) - (∑ i in range n, (- x⁻¹ * t) ^ i) * x⁻¹`
is `O(t ^ n)` as `t → 0`. -/
theorem inverse_add_norm_diff_nth_order {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) (n : ℕ) : asymptotics.is_O
  (fun (t : R) => ring.inverse (↑x + t) - (finset.sum (finset.range n) fun (i : ℕ) => (-↑(x⁻¹) * t) ^ i) * ↑(x⁻¹))
  (fun (t : R) => norm t ^ n) (nhds 0) := sorry

/-- The function `λ t, inverse (x + t) - x⁻¹` is `O(t)` as `t → 0`. -/
theorem inverse_add_norm_diff_first_order {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) : asymptotics.is_O (fun (t : R) => ring.inverse (↑x + t) - ↑(x⁻¹)) (fun (t : R) => norm t) (nhds 0) := sorry

/-- The function
`λ t, inverse (x + t) - x⁻¹ + x⁻¹ * t * x⁻¹`
is `O(t ^ 2)` as `t → 0`. -/
theorem inverse_add_norm_diff_second_order {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) : asymptotics.is_O (fun (t : R) => ring.inverse (↑x + t) - ↑(x⁻¹) + ↑(x⁻¹) * t * ↑(x⁻¹)) (fun (t : R) => norm t ^ bit0 1)
  (nhds 0) := sorry

/-- The function `inverse` is continuous at each unit of `R`. -/
theorem inverse_continuous_at {R : Type u_1} [normed_ring R] [complete_space R] (x : units R) : continuous_at ring.inverse ↑x := sorry


import .group

universe u

-- A ring is a standard construction in algebra, almost as fundemental as a group
--
-- Of course the lean standard library includes Rings, but I choose to create my own
-- probably because I'm bloody minded like that

def LeftDistrib {α: Type} (add: α → α → α) (mul: α → α → α) := ∀ a b c : α, mul c (add a b) = add (mul c a) (mul c b)
def RightDistrib {α: Type} (add: α → α → α) (mul: α → α → α) := ∀ a b c : α, mul (add a b) c = add (mul a c) (mul b c)
def NoZeroDivisors (α: Type) [has_add α] [has_mul α] [has_zero α] := ∀ a b : α, a * b = 0 → a ≠ 0 → b = 0
def NonZero (α: Type) [has_zero α]: Type := {a: α // a ≠ 0}
def ExcludedMiddle (α: Type) := ∀ a b : α, a = b ∨ a ≠ b

postfix `ˣ`:1025 := NonZero

def NZLeftInverse {α: Type} (zero: α) (one: α) (mul: α → α → α) (inv : α → α) := ∀ a : α, (a ≠ zero → mul (inv a) a = one)

class Ring (α: Type) extends has_zero α, has_add α, has_neg α, has_mul α:=
(is_set: ExcludedMiddle α)
(add_assoc: Associative add)
(add_comm: Commutative add)
(left_zero: LeftIdentity add 0)
(left_neg: LeftInverse add 0 neg)
(mul_assoc: Associative mul)
(left_distrib: LeftDistrib add mul)
(right_distrib: RightDistrib add mul)

instance RingHasSub {α: Type} [r: Ring α]: has_sub α := ⟨λ a b : α, a + -b⟩

-- Given a Ring we can also construct subrings

structure SubRing { α : Type} (r: Ring α) (p : α → Prop) :=
(pd: ∀ a : α, decidable (p a))
(inc_zero: p 0)
(cu_add: ∀ a b : α, p a → p b → p (a + b))
(cu_mul: ∀ a b : α, p a → p b → p (a*b))
(cu_neg: ∀ a : α, p a → p (-a))

-- This lets us construct a Commutative Ring

class CommRing (α: Type) extends has_zero α, has_add α, has_neg α, has_mul α :=
(is_set: ExcludedMiddle α)
(add_assoc: Associative add)
(add_comm: Commutative add)
(left_zero: LeftIdentity add 0)
(left_neg: LeftInverse add 0 neg)
(mul_assoc: Associative mul)
(mul_comm: Commutative mul)
(left_distrib: LeftDistrib add mul)
def CommRing.to_Ring {α: Type} (cr: CommRing α): Ring α :=
{
    is_set        := cr.is_set,
    add_assoc     := cr.add_assoc,
    add_comm      := cr.add_comm,
    left_zero     := cr.left_zero,
    left_neg      := cr.left_neg,
    mul_assoc     := cr.mul_assoc,
    left_distrib  := cr.left_distrib,
    right_distrib := assume a b c: α, by rw [cr.mul_comm, cr.left_distrib, CommRing.mul_comm α c, CommRing.mul_comm α c]
}
instance CommRingIsRing {α: Type} [cr: CommRing α]: Ring α := cr.to_Ring

-- And a Unit Ring
class UnitRing (α: Type) extends Ring α, has_one α := (left_one: LeftIdentity mul one) (right_one: RightIdentity mul one)

-- An NZDRing is a Ring without zero divisors
class NZDRing (α: Type) extends Ring α := (nzd: NoZeroDivisors α)

-- A Commutative Unit Ring
class CommUnitRing (α: Type) extends CommRing α, has_one α := (left_one: LeftIdentity mul one)
def CommUnitRing.to_UnitRing {α: Type} (cur: CommUnitRing α): UnitRing α :=
{
    is_set        := cur.is_set,
    add_assoc     := cur.add_assoc,
    add_comm      := cur.add_comm,
    left_zero     := cur.left_zero,
    left_neg      := cur.left_neg,
    mul_assoc     := cur.mul_assoc,
    left_distrib  := cur.left_distrib,
    right_distrib := cur.to_CommRing.to_Ring.right_distrib,
    left_one      := cur.left_one,
    right_one     := assume a : α, by rw [cur.mul_comm, CommUnitRing.left_one α a]
}
instance CommUnitRingIsUnitRing {α: Type} [cur: CommUnitRing α]: UnitRing α := cur.to_UnitRing

-- A Commutative NZDRing
class CommNZDRing (α: Type) extends CommRing α := (nzd: NoZeroDivisors α)
def CommNZDRing.to_Ring {α : Type} (cnzdr: CommNZDRing α): Ring α := cnzdr.to_CommRing.to_Ring
def CommNZDRing.to_NZDRing {α: Type} (cnzdr: CommNZDRing α): NZDRing α :=
{
    is_set        := cnzdr.is_set,
    add_assoc     := cnzdr.add_assoc,
    add_comm      := cnzdr.add_comm,
    left_zero     := cnzdr.left_zero,
    left_neg      := cnzdr.left_neg,
    mul_assoc     := cnzdr.mul_assoc,
    left_distrib  := cnzdr.left_distrib,
    right_distrib := cnzdr.to_Ring.right_distrib,
    nzd           := cnzdr.nzd
}
instance CommNZDRingIsNZDRing {α: Type} [cnzdr: CommNZDRing α]: NZDRing α := cnzdr.to_NZDRing

-- NZDUnitRing
class NZDUnitRing (α : Type) extends UnitRing α := (zero_ne_one: zero ≠ one) (nzd: NoZeroDivisors α)
def NZDUnitRing.to_NZDRing {α: Type} (nzdur: NZDUnitRing α): NZDRing α :=
{
    is_set        := nzdur.is_set,
    add_assoc     := nzdur.add_assoc,
    add_comm      := nzdur.add_comm,
    left_zero     := nzdur.left_zero,
    left_neg      := nzdur.left_neg,
    mul_assoc     := nzdur.mul_assoc,
    left_distrib  := nzdur.left_distrib,
    right_distrib := nzdur.right_distrib,
    nzd           := nzdur.nzd
}
instance NZDUnitRingIsNZDRing {α: Type} [nzdur: NZDUnitRing α]: NZDRing α := nzdur.to_NZDRing

-- An Integral Domain
class IntegralDomain (α: Type) extends CommUnitRing α := (nzd: NoZeroDivisors α)
def IntegralDomain.to_UnitRing {α: Type} (intd: IntegralDomain α): UnitRing α := intd.to_CommUnitRing.to_UnitRing
def IntegralDomain.to_CommNZDRing {α: Type} (intd: IntegralDomain α): CommNZDRing α :=
{
    is_set        := intd.is_set,
    add_assoc     := intd.add_assoc,
    add_comm      := intd.add_comm,
    left_zero     := intd.left_zero,
    left_neg      := intd.left_neg,
    mul_assoc     := intd.mul_assoc,
    left_distrib  := intd.left_distrib,
    mul_comm      := intd.mul_comm,
    nzd           := intd.nzd
}
instance IntegralDomainIsCommNZDRing {α: Type} [intd: IntegralDomain α]: CommNZDRing α := intd.to_CommNZDRing
def IntegralDomain.to_NZDRing {α: Type } (intd: IntegralDomain α): NZDRing α := intd.to_CommNZDRing.to_NZDRing
def IntegralDomain.to_Ring {α: Type } (intd: IntegralDomain α): Ring α := intd.to_UnitRing.to_Ring

-- Division Ring
-- For convenience we will define inv: α → α even though this is strictly speaking wrong.
-- We thus require that inv : α → α can be projected onto αˣ
class DivisionRing (α: Type) extends UnitRing α, has_inv α :=
(inv_nz_is_nz: ∀ a : α, a ≠ 0 → a⁻¹ ≠ 0)
(left_inv: NZLeftInverse zero one mul inv)
(zero_ne_one: zero ≠ one)

-- Field
class Field (α: Type) extends IntegralDomain α, has_inv α :=
(inv_nz_is_nz: ∀ a : α, a ≠ 0 → a⁻¹ ≠ 0)
(left_inv: NZLeftInverse zero one mul inv)
(zero_ne_one: zero ≠ one)
def Field.to_UnitRing {α: Type} (f: Field α): UnitRing α := f.to_IntegralDomain.to_UnitRing
def Field.to_Ring {α: Type} (f: Field α): Ring α := f.to_UnitRing.to_Ring
def Field.to_DivisionRing {α: Type} (f: Field α): DivisionRing α :=
{
    is_set        := f.is_set,
    add_assoc     := f.add_assoc,
    add_comm      := f.add_comm,
    left_zero     := f.left_zero,
    left_neg      := f.left_neg,
    mul_assoc     := f.mul_assoc,
    left_distrib  := f.left_distrib,
    right_distrib := f.to_Ring.right_distrib,
    left_one      := f.left_one,
    right_one     := f.to_UnitRing.right_one,
    inv_nz_is_nz  := f.inv_nz_is_nz,
    left_inv      := f.left_inv,
    zero_ne_one   := f.zero_ne_one
}
instance FieldIsDivisionRing {α: Type} [f: Field α]: DivisionRing α := f.to_DivisionRing

-- And subfields

class SubField {α: Type} (f: Field α) (p: α → Prop) :=
(pd: ∀ a : α, decidable (p a))
(inc_zero: p 0)
(inc_one: p 1)
(cu_add: ∀ a b : α, p a → p b → p (a + b))
(cu_mul: ∀ a b : α, p a → p b → p (a*b))
(cu_neg: ∀ a : α, p a → p (-a))
(cu_inv: ∀ a : α, p a → p (a⁻¹))

-- And now some results on these various ringoids!

namespace Ring
variable {α: Type}
variable (r: Ring α)
include r

lemma zero_add (a : α): 0 + a = a := Ring.left_zero α a
lemma add_zero (a : α): a + 0 = a := by rw [r.add_comm, r.zero_add]

lemma neg_add (a : α): -a + a = 0 := Ring.left_neg α a
lemma add_neg (a : α): a  + -a = 0 := by rw [r.add_comm, r.neg_add]

lemma add_mul (a b c: α): (a + b)*c = a*c + b*c := Ring.right_distrib α a b c
lemma mul_add (a b c: α): c*(a + b) = c*a + c*b := Ring.left_distrib α a b c

def to_AdditiveAbelianGroup {α: Type} (r: Ring α): AdditiveAbelianGroup α :=
{
    assoc := r.add_assoc,
    left_id := r.left_zero,
    right_id := r.add_zero,
    left_inv := r.left_neg,
    right_inv := r.add_neg,
    comm := r.add_comm
}

instance RingIsAdditiveAbelianGroup {α: Type} [r: Ring α]: AdditiveAbelianGroup α := r.to_AdditiveAbelianGroup

lemma zero_unique (z: α): LeftIdentity r.add z → z = 0 := r.to_AdditiveAbelianGroup.to_Group.id_unique
lemma neg_unique {a b : α}: a + b = 0 → a = -b := r.to_AdditiveAbelianGroup.to_Group.inv_unique

lemma zero_mul (a : α): 0 * a = 0 :=
    suffices 0*a + 0*a = 0 + 0*a, from iff.elim_left r.to_AdditiveAbelianGroup.to_Group.cancel_right this,
    calc
        0*a + 0*a = 0 + (0*a + 0*a)  : by rw r.zero_add
        ...       = 0 + (0 + 0)*a    : by rw r.right_distrib
        ...       = 0 + 0*a          : by rw r.zero_add 0
lemma mul_zero (a : α): a * 0 = 0 :=
    suffices a*0 + a*0 = 0 + a*0, from iff.elim_left r.to_AdditiveAbelianGroup.to_Group.cancel_right this,
    calc
        a*0 + a*0 = 0 + (a*0 + a*0)  : by rw r.zero_add
        ...       = 0 + a*(0 + 0)    : by rw r.left_distrib
        ...       = 0 + a*0          : by rw r.zero_add 0

lemma neg_neg (a: α): -(-a) = a := r.to_AdditiveAbelianGroup.to_Group.inv_inv a

lemma neg_mul (a b : α): (-a) * b = -(a * b) :=
    suffices ((-a) * b) + (a * b) = 0, from r.neg_unique this,
    calc
        ((-a) * b) + (a * b) = (-a + a) * b  : by rw r.right_distrib
        ...                  = 0 * b         : by rw r.neg_add
        ...                  = 0             : by rw r.zero_mul

lemma mul_neg (a b : α): a * (-b) = -(a * b) :=
    suffices (a * -b) + (a * b) = 0, from r.neg_unique this,
    calc
        (a * -b) + (a * b) = a * (-b + b)  : by rw r.left_distrib
        ...                = a * 0         : by rw r.neg_add
        ...                = 0             : by rw r.mul_zero

lemma neg_mul_neg (a b : α): -a * -b = a * b :=
calc
    -a * -b = -(a * -b)   : by rw r.neg_mul
    ...     = -(-(a * b)) : by rw r.mul_neg
    ...     = a * b       : by rw r.neg_neg

lemma add_cancel_left {a b c : α}: a + b = a + c ↔ b = c := r.to_AdditiveAbelianGroup.to_Group.cancel_left
lemma add_cancel_right {a b c : α}: a + b = c + b ↔ a = c := r.to_AdditiveAbelianGroup.to_Group.cancel_right

lemma left_transfer_to_rhs {a b c : α}: a + b = c ↔ b = -a + c :=
calc
    a + b = c ↔ -a + (a + b) = -a + c : by rw r.add_cancel_left
    ...       ↔ (-a + a) + b = -a + c : by rw r.add_assoc
    ...       ↔ 0 + b = -a + c        : by rw r.neg_add
    ...       ↔ b = -a + c            : by rw r.zero_add

lemma right_transfer_to_rhs {a b c : α}: a + b = c ↔ a = c + -b :=
calc
    a + b = c ↔ (a + b) + -b = c + -b : by rw r.add_cancel_right
    ...       ↔ a + (b + -b) = c + -b : by rw r.add_assoc
    ...       ↔ a + 0 = c + -b        : by rw r.add_neg
    ...       ↔ a = c + -b            : by rw r.add_zero

lemma neg_zero: -(0 : α) = 0 :=
suffices (0: α) + 0 = 0, from eq.symm (r.neg_unique this),
r.add_zero 0

lemma left_distrib_neg (a b c : α): c*(a - b) = c*a - c*b :=
calc
    c*(a - b) = c*(a + -b)    : by refl
    ...       = c*a + c*-b    : by rw r.left_distrib
    ...       = c*a + -(c*b)  : by rw r.mul_neg
    ...       = c*a - c*b     : by refl

lemma diff_zero {a b : α}: a = b ↔ a - b = 0 :=
iff.intro (
    assume h: a = b,
    calc
        a - b = a - a  : by rw h
        ...   = a + -a : by refl
        ...   = 0      : by rw r.add_neg
) (
    assume h: a - b = 0,
    calc
        a   = a + 0         : by rw r.add_zero
        ... = a + (-b + b)  : by rw r.neg_add
        ... = (a + -b) + b  : by rw r.add_assoc
        ... = (a - b) + b   : by refl
        ... = 0 + b         : by rw h
        ... = b             : by rw r.zero_add
)

end Ring

namespace SubRing
variable {α : Type}
variable [r: Ring α]
variable {p: α → Prop}
variable (sr: SubRing r p)

include α
include r
include p
include sr

def add (a b : {x: α // p x}): {x: α // p x} := ⟨a.val + b.val,(sr.cu_add) a.val b.val a.property b.property⟩
def mul (a b : {x: α // p x}): {x: α // p x} := ⟨a.val * b.val, (sr.cu_mul) a.val b.val a.property b.property⟩
def neg (a : {x: α // p x}): {x: α // p x} := ⟨-a.val, (sr.cu_neg) a.val a.property⟩
def zero : {x: α // p x} := ⟨(0 : α), sr.inc_zero⟩
def is_set: ExcludedMiddle {x: α // p x} :=
    assume ⟨a, ha⟩ ⟨b, hb⟩,
    or.elim (Ring.is_set α a b) (
        assume h: a = b,
        or.intro_left _ (subtype.eq h)
    ) (
        assume h: a ≠ b,
        or.intro_right _ (assume hc: (⟨a, ha⟩: {x:α // p x}) = ⟨b, hb⟩, absurd (by injection hc) h)
    )

lemma add_sr (a b : {x: α // p x}): (sr.add a b).val = a.val + b.val := let ⟨a, ha⟩ := a in (let ⟨b, hb⟩ := b in (rfl))
lemma mul_sr (a b : {x: α // p x}): (sr.mul a b).val = a.val * b.val := let ⟨a, ha⟩ := a in (let ⟨b, hb⟩ := b in (rfl))

instance SubRingHasAdd {α: Type} [r: Ring α] {p : α → Prop} [sr: SubRing r p]: has_add {x: α // p x} := ⟨sr.add⟩
instance SubRingHasMul {α: Type} [r: Ring α] {p : α → Prop} [sr: SubRing r p]: has_mul {x: α // p x} := ⟨sr.mul⟩
instance SubRingHasZero {α: Type} [r: Ring α] {p : α → Prop} [sr: SubRing r p]: has_zero {x: α // p x} := ⟨sr.zero⟩
instance SubRingHasNeg {α: Type} [r: Ring α] {p : α → Prop} [sr: SubRing r p]: has_neg {x: α // p x} := ⟨sr.neg⟩

lemma add_assoc: Associative sr.add := assume a b c : {x: α // p x}, suffices (sr.add (sr.add a b) c).val = (sr.add a (sr.add b c)).val, from subtype.eq this, by rw [sr.add_sr, sr.add_sr, r.add_assoc, ←sr.add_sr, ←sr.add_sr]
lemma add_comm: Commutative sr.add := assume a b : {x: α // p x}, suffices (sr.add a b).val = (sr.add b a).val, from subtype.eq this, by rw [sr.add_sr, r.add_comm, ←sr.add_sr]
lemma left_zero: LeftIdentity sr.add sr.zero := assume a: {x: α // p x}, suffices (sr.add sr.zero a).val = a.val, from subtype.eq this, calc
    (sr.add sr.zero a).val = sr.zero.val + a.val  : by rw sr.add_sr
    ...                    = 0 + a.val            : by refl
    ...                    = a.val                : by rw r.zero_add
lemma left_neg: LeftInverse sr.add sr.zero sr.neg := assume a : {x: α // p x}, suffices (sr.add (sr.neg a) a).val = 0, from subtype.eq this, calc
    (sr.add (sr.neg a) a).val = (sr.neg a).val + a.val  : by rw sr.add_sr
    ...                       = -(a.val) + a.val        : by refl
    ...                       = 0                       : by rw r.neg_add
lemma mul_assoc: Associative sr.mul := assume a b c : {x:α // p x}, suffices (sr.mul (sr.mul a b) c).val = (sr.mul a (sr.mul b c)).val, from subtype.eq this, by rw [sr.mul_sr, sr.mul_sr, r.mul_assoc, sr.mul_sr, sr.mul_sr]
lemma left_distrib: LeftDistrib sr.add sr.mul := assume a b c : {x:α // p x}, suffices (sr.mul c (sr.add a b)).val = (sr.add (sr.mul c a) (sr.mul c b)).val, from subtype.eq this, calc
    (sr.mul c (sr.add a b)).val = c.val * (a.val + b.val)                 : by rw [sr.mul_sr, sr.add_sr]
    ...                         = c.val * a.val + c.val * b.val           : by rw r.left_distrib
    ...                         = (sr.add (sr.mul c a) (sr.mul c b)).val  : by rw [←sr.mul_sr, ←sr.mul_sr, ←sr.add_sr]
lemma right_distrib: RightDistrib sr.add sr.mul := assume a b c : {x:α // p x}, suffices (sr.mul (sr.add a b) c).val = (sr.add (sr.mul a c) (sr.mul b c)).val, from subtype.eq this, calc
    (sr.mul (sr.add a b) c).val = (a.val + b.val) * c.val                 : by rw [sr.mul_sr, sr.add_sr]
    ...                         = a.val * c.val + b.val * c.val           : by rw r.right_distrib
    ...                         = (sr.add (sr.mul a c) (sr.mul b c)).val  : by rw [←sr.mul_sr, ←sr.mul_sr, ←sr.add_sr]

def to_Ring: Ring {x: α // p x} :=
{
    add := sr.add,
    mul := sr.mul,
    neg := sr.neg,
    zero := sr.zero,
    is_set := sr.is_set,
    add_assoc := sr.add_assoc,
    add_comm := sr.add_comm,
    left_zero := sr.left_zero,
    left_neg := sr.left_neg,
    mul_assoc := sr.mul_assoc,
    left_distrib := sr.left_distrib,
    right_distrib := sr.right_distrib
}
instance {α: Type} [r: Ring α] {p : α → Prop} [sr: SubRing r p]: Ring {x:α // p x} := sr.to_Ring

end SubRing

namespace SubRing
private def decidable_and {α : Type} {p q : α → Prop} (pd: ∀ a : α, decidable (p a)) (qd: ∀ a : α, decidable (q a)): ∀ a : α, decidable (p a ∧ q a) :=
    assume a: α,
    match (pd a), (qd a) with
    | is_true hp,  is_true hq  := is_true (and.intro (hp) (hq))
    | is_false hp, _           := is_false (assume hc, absurd hc.left hp)
    | is_true hp,  is_false hq := is_false (assume hc, absurd hc.right hq)
    end

def intersection {α: Type} [r: Ring α] {p q: α → Prop} (srp: SubRing r p) (srq: SubRing r q): SubRing r (λ a, p a ∧ q a) :=
{
    pd:=decidable_and srp.pd srq.pd,
    inc_zero:=and.intro (srp.inc_zero) (srq.inc_zero),
    cu_add:=assume a b, assume ha hb, and.intro (srp.cu_add a b ha.left hb.left) (srq.cu_add a b ha.right hb.right),
    cu_mul:=assume a b, assume ha hb, and.intro (srp.cu_mul a b ha.left hb.left) (srq.cu_mul a b ha.right hb.right),
    cu_neg:=assume a, assume ha, and.intro (srp.cu_neg a ha.left) (srq.cu_neg a ha.right)
}

end SubRing

namespace UnitRing
variable {α: Type}
variable (ur: UnitRing α)
include ur

lemma one_mul (a: α): 1*a = a := UnitRing.left_one α a
lemma mul_one (a: α): a*1 = a := UnitRing.right_one α a

lemma neg_one_mul (a : α): -1 * a = -a :=
calc
    -1 * a = -(1*a)  : by rw ur.to_Ring.neg_mul
    ...    = -a      : by rw ur.one_mul
lemma mul_neg_one (a : α): a*(-1) = -a :=
calc
    a * -1 = -(a*1)  : by rw ur.to_Ring.mul_neg
    ...    = -a      : by rw ur.mul_one

lemma neg_one_mul_neg_one: (-1: α) * -1 = 1 :=
calc
    (-1: α) * -1 = -(-1)  : by rw ur.neg_one_mul
    ...          = 1      : by rw ur.to_Ring.neg_neg

end UnitRing

namespace NZDRing
variable {α : Type}
variable (nzdr: NZDRing α)
include nzdr

lemma no_zero_divisors {a b: α}: a * b = 0 → a ≠ 0 → b = 0 := NZDRing.nzd α a b

lemma mul_preserves_nz {a b : α}: a ≠ 0 → b ≠ 0 → a*b ≠ 0 :=
assume ha: a ≠ 0,
assume hb: b ≠ 0,
assume hc: a *b = 0,
absurd (nzdr.no_zero_divisors hc ha) hb

def mul_of_nz: αˣ → αˣ → αˣ := assume ⟨a, ha⟩, assume ⟨b, hb⟩, ⟨a*b, mul_preserves_nz nzdr ha hb⟩
instance NZHasMul [nzdr: NZDRing α]: has_mul αˣ := ⟨mul_of_nz nzdr⟩
lemma nz_mul (a b: αˣ): (a * b).val = a.val * b.val := let ⟨x, hx⟩ := a in (let ⟨y, hy⟩ := b in (rfl))

lemma mul_of_nz_assoc: Associative (mul_of_nz nzdr) :=
assume a b c,
suffices ((a * b) * c).val = (a * (b * c)).val, from subtype.eq this,
calc
    ((a * b) * c).val = (a * b).val * c.val  : by rw nz_mul nzdr
    ...               = (a.val * b.val) * c.val : by rw nz_mul nzdr
    ...               = a.val * (b.val * c.val) : by rw Ring.mul_assoc α a.val b.val c.val
    ...               = a.val * (b * c).val     : by rw nz_mul nzdr
    ...               = (a * (b * c)).val       : by rw nz_mul nzdr a

def multiplicative_semigroup_structure: MultiplicativeSemigroup αˣ := { mul_assoc_ := mul_of_nz_assoc nzdr }

instance {α : Type} [nzdr: NZDRing α]: MultiplicativeSemigroup αˣ := multiplicative_semigroup_structure nzdr

end NZDRing

namespace NZDUnitRing
variable {α : Type}
variable (nzdur: NZDUnitRing α)
include nzdur

lemma one_ne_zero: (1 : α) ≠ 0 := ne.symm (nzdur.zero_ne_one)

instance NZHasOne {α: Type} [nzdur: NZDUnitRing α]: has_one αˣ := ⟨⟨1, nzdur.one_ne_zero⟩⟩

lemma nonzero_one_mul (a : αˣ): 1 * a = a :=
suffices (1 * a).val = a.val, from subtype.eq this,
calc
    (1 * a).val = (1: αˣ).val * a.val  : by rw nzdur.to_NZDRing.nz_mul
    ...         = 1 * a.val            : by refl
    ...         = a.val                : by rw nzdur.to_UnitRing.one_mul

lemma nonzero_mul_one (a : αˣ): a * 1 = a :=
suffices (a * 1).val = a.val, from subtype.eq this,
calc
    (a * 1).val = a.val * (1: αˣ).val  : by rw nzdur.to_NZDRing.nz_mul
    ...         = a.val * 1            : by refl
    ...         = a.val                : by rw nzdur.to_UnitRing.mul_one

def multiplicative_monoid_structure: MultiplicativeMonoid αˣ :=
{
    assoc := nzdur.to_NZDRing.mul_of_nz_assoc,
    left_id := nzdur.nonzero_one_mul,
    right_id := nzdur.nonzero_mul_one
}
instance {α : Type} [nzdur: NZDUnitRing α]: MultiplicativeMonoid αˣ := nzdur.multiplicative_monoid_structure

lemma mul_cancel_left {a b c: α}: c ≠ 0 → c * a = c * b → a = b :=
assume hc: c ≠ 0,
assume h: c * a = c * b,
suffices a - b = 0, from iff.elim_right nzdur.to_Ring.diff_zero this,
suffices c*(a - b) = 0, from nzdur.to_NZDRing.no_zero_divisors this hc,
calc
    c*(a - b) = c*a - c*b  : by rw [nzdur.to_Ring.left_distrib_neg a b c, h]
    ...       = 0          : by rw iff.elim_left nzdur.to_Ring.diff_zero h

end NZDUnitRing

namespace IntegralDomain
variable {α : Type}
variable (intd: IntegralDomain α)
include intd

end IntegralDomain

namespace DivisionRing
variable {α : Type}
variable (dr: DivisionRing α)
include dr

lemma inv_mul {a : α}: a ≠ 0 → a⁻¹ * a = 1 := DivisionRing.left_inv α a
lemma inv_nz {a : α}: a ≠ 0 → a⁻¹ ≠ 0 := DivisionRing.inv_nz_is_nz a

lemma inv_inv {a : α}: a ≠ 0 → (a⁻¹)⁻¹ = a :=
assume hnz: a ≠ 0,
calc
    a⁻¹⁻¹ = a⁻¹⁻¹ * 1          : by rw dr.to_UnitRing.mul_one
    ...   = a⁻¹⁻¹ * (a⁻¹ * a)  : by rw dr.inv_mul hnz
    ...   = (a⁻¹⁻¹ * a⁻¹) * a  : by rw dr.to_Ring.mul_assoc
    ...   = 1 * a              : by rw dr.inv_mul (dr.inv_nz hnz)
    ...   = a                  : by rw dr.to_UnitRing.one_mul

lemma mul_inv {a : α}: a ≠ 0 → a * a⁻¹ = 1 :=
assume hnz: a ≠ 0,
calc
    a * a⁻¹ = a⁻¹⁻¹ * a⁻¹  : by rw dr.inv_inv hnz
    ...     = 1            : by rw dr.inv_mul (dr.inv_nz hnz)

def inv_of_nz: αˣ → αˣ := λ a : αˣ, ⟨a.val⁻¹, dr.inv_nz a.property⟩
instance {α : Type} [dr: DivisionRing α]: has_inv αˣ := ⟨dr.inv_of_nz⟩

lemma no_zero_divisors: NoZeroDivisors α :=
    assume a b : α,
    assume h: a * b = 0,
    assume ha: a ≠ 0,
    calc
        b   = 1*b          : by rw dr.to_UnitRing.one_mul
        ... = (a⁻¹ * a)*b  : by rw dr.inv_mul ha
        ... = a⁻¹ * (a*b)  : by rw dr.to_Ring.mul_assoc
        ... = a⁻¹ * 0      : by rw h
        ... = 0            : by rw dr.to_Ring.mul_zero

def to_NZDUnitRing {α: Type} (dr: DivisionRing α): NZDUnitRing α :=
{
    zero_ne_one := dr.zero_ne_one,
    nzd := dr.no_zero_divisors
}
instance {α: Type} [dr: DivisionRing α]: NZDUnitRing α := dr.to_NZDUnitRing
def to_NZDRing {α: Type} (dr: DivisionRing α): NZDRing α := dr.to_NZDUnitRing.to_NZDRing

lemma nz_inv_mul (a : αˣ): a⁻¹ * a = 1 :=
    suffices (a⁻¹ * a).val = 1, from subtype.eq this,
    calc
        (a⁻¹ * a).val = (a⁻¹).val * a.val  : by rw dr.to_NZDRing.nz_mul
        ...           = (a.val)⁻¹ * a.val  : by refl
        ...           = 1                  : by rw dr.inv_mul a.property
lemma nz_mul_inv (a : αˣ): a * a⁻¹ = 1 :=
    suffices (a * a⁻¹).val = 1, from subtype.eq this,
    calc
        (a * a⁻¹).val = a.val * (a⁻¹).val  : by rw dr.to_NZDRing.nz_mul
        ...           = a.val * (a.val)⁻¹  : by refl
        ...           = 1                  : by rw dr.mul_inv a.property

def multiplicative_group_structure: MultiplicativeGroup αˣ :=
{
    left_inv  := dr.nz_inv_mul,
    right_inv := dr.nz_mul_inv
}
instance {α : Type} [dr: DivisionRing α]: MultiplicativeGroup αˣ := dr.multiplicative_group_structure

end DivisionRing

namespace Field
variable {α : Type}
variable (f: Field α)
include f

def to_NZDUnitRing {α: Type} (f: Field α): NZDUnitRing α := f.to_DivisionRing.to_NZDUnitRing
def to_NZDRing: NZDRing α := f.to_DivisionRing.to_NZDRing

lemma nz_mul_comm (a b : αˣ): a * b = b * a :=
suffices (a * b).val = (b * a).val, from subtype.eq this,
calc
    (a * b).val = a.val * b.val   : by rw f.to_NZDRing.nz_mul
    ...         = b.val * a.val   : by rw f.mul_comm
    ...         = (b * a).val     : by rw f.to_NZDRing.nz_mul

def multiplicative_abelian_group_structure: MultiplicativeAbelianGroup αˣ :=
{
    comm := f.nz_mul_comm
}
instance {α: Type} [f: Field α]: MultiplicativeAbelianGroup αˣ := f.multiplicative_abelian_group_structure

end Field

namespace SubField

variable {α: Type}
variable [f: Field α]
variable {p : α → Prop}
variable (sf: SubField f p)

include α
include f
include p
include sf

def to_SubRing: SubRing f.to_Ring p :=
{
    pd:=sf.pd,
    inc_zero:=sf.inc_zero,
    cu_add:=sf.cu_add,
    cu_mul:=sf.cu_mul,
    cu_neg:=sf.cu_neg
}

instance: has_zero {x: α // p x} := ⟨sf.to_SubRing.zero⟩

def add: {x:α//p x} → {x:α//p x} → {x:α//p x} := sf.to_SubRing.add
def mul: {x:α//p x} → {x:α//p x} → {x:α//p x} := sf.to_SubRing.mul
def zero: {x:α//p x} := sf.to_SubRing.zero
def one: {x:α//p x} := ⟨1, sf.inc_one⟩
def neg: {x:α//p x} → {x:α//p x} := sf.to_SubRing.neg
def inv: {x:α//p x} → {x:α//p x} := λ ⟨a, ha⟩, ⟨a⁻¹, SubField.cu_inv f a ha⟩
lemma mul_comm: Commutative sf.mul := assume a b, suffices (sf.to_SubRing.mul a b).val = (sf.to_SubRing.mul b a).val, from subtype.eq this, by rw [sf.to_SubRing.mul_sr, f.mul_comm, ←sf.to_SubRing.mul_sr]
lemma left_one: LeftIdentity sf.to_SubRing.mul sf.one := assume a, suffices (SubRing.mul (to_SubRing sf) (one sf) a).val = a.val, from subtype.eq this, calc
    (SubRing.mul (to_SubRing sf) (one sf) a).val = sf.one.val * a.val   : by rw sf.to_SubRing.mul_sr
    ...                                          = 1 * a.val            : by refl
    ...                                          = a.val                : by rw f.to_UnitRing.one_mul
lemma nzd: ∀ a b : {x:α//p x}, sf.mul a b = sf.zero → a ≠ sf.zero → b = sf.zero :=
    assume a b,
    assume h: sf.to_SubRing.mul a b = sf.to_SubRing.zero,
    have h: (sf.to_SubRing.mul a b).val = sf.to_SubRing.zero.val, by injection h,
    have h: a.val * b.val = 0, from h,
    assume ha: a ≠ sf.to_SubRing.zero,
    have ha: a.val ≠ 0, from assume hc: a.val = sf.to_SubRing.zero.val, absurd (subtype.eq hc) ha,
    suffices b.val = 0, from subtype.eq this,
    f.to_NZDRing.no_zero_divisors h ha
lemma inv_nz_is_nz: ∀ a : {x:α//p x}, a ≠ sf.zero → sf.inv a ≠ sf.zero :=
    assume ⟨a, hp⟩,
    assume ha: (⟨a, hp⟩ : {x:α//p x}) ≠ sf.to_SubRing.zero,
    have ha: a ≠ 0, from assume hc: (⟨a,hp⟩ : {x:α//p x}).val = sf.to_SubRing.zero.val, absurd (subtype.eq hc) ha,
    assume hc: sf.inv ⟨a, hp⟩ = sf.to_SubRing.zero,
    have hc: (⟨a⁻¹, SubField.cu_inv f a hp⟩ : {x:α//p x}) = sf.to_SubRing.zero, from hc,
    have hc: a⁻¹ = 0, by injection hc,
    absurd hc (Field.inv_nz_is_nz a ha)

lemma left_inv: ∀ a : {x:α//p x}, a ≠ sf.zero → sf.mul (sf.inv a) a = sf.one :=
    assume ⟨a, hp⟩,
    assume h: (⟨a, hp⟩ : {x:α//p x}) ≠ sf.to_SubRing.zero,
    have h: a ≠ 0, from assume hc: (⟨a, hp⟩ : {x:α//p x}).val = sf.to_SubRing.zero.val, absurd (subtype.eq hc) h,
    suffices (sf.mul (sf.inv ⟨a, hp⟩) ⟨a, hp⟩).val = 1, from subtype.eq this,
    calc
        (sf.mul (sf.inv ⟨a, hp⟩) ⟨a, hp⟩).val = (sf.to_SubRing.mul ⟨a⁻¹, SubField.cu_inv f a hp⟩ ⟨a, hp⟩).val  : by refl
        ...                                   = a⁻¹ * a                                                        : by rw sf.to_SubRing.mul_sr
        ...                                   = 1                                                              : by rw f.to_DivisionRing.inv_mul h
lemma zero_ne_one: sf.zero ≠ sf.one := assume hc: sf.zero = sf.one, have hc: (0: α) = 1, by injection hc, absurd hc f.zero_ne_one

def to_Field: Field {x: α // p x} :=
{
    add := sf.add,
    mul := sf.mul,
    neg := sf.to_SubRing.neg,
    zero := sf.zero,
    one := sf.one,
    inv := sf.inv,
    is_set := sf.to_SubRing.is_set,
    add_assoc := sf.to_SubRing.add_assoc,
    add_comm := sf.to_SubRing.add_comm,
    left_zero := sf.to_SubRing.left_zero,
    left_neg := sf.to_SubRing.left_neg,
    mul_assoc := sf.to_SubRing.mul_assoc,
    left_distrib := sf.to_SubRing.left_distrib,
    mul_comm := sf.mul_comm,
    left_one := sf.left_one,
    nzd := sf.nzd,
    inv_nz_is_nz := sf.inv_nz_is_nz,
    left_inv := sf.left_inv,
    zero_ne_one := sf.zero_ne_one
}

end SubField


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

! This file was ported from Lean 3 source module ring_theory.coprime.lemmas
! leanprover-community/mathlib commit 509de852e1de55e1efa8eacfa11df0823f26f226
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.Ring
import Mathlib.Data.Fintype.Basic
import Mathlib.Data.Int.GCD
import Mathlib.RingTheory.Coprime.Basic

/-!
# Additional lemmas about elements of a ring satisfying `IsCoprime`

These lemmas are in a separate file to the definition of `IsCoprime` as they require more imports.

Notably, this includes lemmas about `Finset.prod` as this requires importing big_operators, and
lemmas about `HasPow` since these are easiest to prove via `Finset.prod`.

-/

universe u v

variable {R : Type u} {I : Type v} [CommSemiring R] {x y z : R} {s : I → R} {t : Finset I}

open BigOperators

section

open Classical

theorem Nat.isCoprime_iff_coprime {m n : ℕ} : IsCoprime (m : ℤ) n ↔ Nat.coprime m n :=
  ⟨fun ⟨a, b, H⟩ ↦
    Nat.eq_one_of_dvd_one <|
      Int.coe_nat_dvd.1 <| by
        rw [Int.ofNat_one, ← H]
        exact
          dvd_add (dvd_mul_of_dvd_right (Int.coe_nat_dvd.2 <| Nat.gcd_dvd_left m n) _)
            (dvd_mul_of_dvd_right (Int.coe_nat_dvd.2 <| Nat.gcd_dvd_right m n) _),
    fun H ↦
    ⟨Nat.gcdA m n, Nat.gcdB m n, by
      rw [mul_comm _ (m : ℤ), mul_comm _ (n : ℤ), ← Nat.gcd_eq_gcd_ab, show _ = _ from H,
        Int.ofNat_one]⟩⟩
#align nat.is_coprime_iff_coprime Nat.isCoprime_iff_coprime

alias Nat.isCoprime_iff_coprime ↔ IsCoprime.nat_coprime Nat.coprime.isCoprime
#align is_coprime.nat_coprime IsCoprime.nat_coprime
#align nat.coprime.is_coprime Nat.coprime.isCoprime

theorem IsCoprime.prod_left : (∀ i ∈ t, IsCoprime (s i) x) → IsCoprime (∏ i in t, s i) x :=
  Finset.induction_on t (fun _ ↦ isCoprime_one_left) fun b t hbt ih H ↦
    by
    rw [Finset.prod_insert hbt]
    rw [Finset.forall_mem_insert] at H
    exact H.1.mul_left (ih H.2)
#align is_coprime.prod_left IsCoprime.prod_left

theorem IsCoprime.prod_right : (∀ i ∈ t, IsCoprime x (s i)) → IsCoprime x (∏ i in t, s i) := by
  simpa only [isCoprime_comm] using IsCoprime.prod_left (R := R)
#align is_coprime.prod_right IsCoprime.prod_right

theorem IsCoprime.prod_left_iff : IsCoprime (∏ i in t, s i) x ↔ ∀ i ∈ t, IsCoprime (s i) x :=
  Finset.induction_on t (iff_of_true isCoprime_one_left fun _ ↦ by simp) fun b t hbt ih ↦ by
    rw [Finset.prod_insert hbt, IsCoprime.mul_left_iff, ih, Finset.forall_mem_insert]
#align is_coprime.prod_left_iff IsCoprime.prod_left_iff

theorem IsCoprime.prod_right_iff : IsCoprime x (∏ i in t, s i) ↔ ∀ i ∈ t, IsCoprime x (s i) := by
  simpa only [isCoprime_comm] using IsCoprime.prod_left_iff (R := R)
#align is_coprime.prod_right_iff IsCoprime.prod_right_iff

theorem IsCoprime.of_prod_left (H1 : IsCoprime (∏ i in t, s i) x) (i : I) (hit : i ∈ t) :
    IsCoprime (s i) x :=
  IsCoprime.prod_left_iff.1 H1 i hit
#align is_coprime.of_prod_left IsCoprime.of_prod_left

theorem IsCoprime.of_prod_right (H1 : IsCoprime x (∏ i in t, s i)) (i : I) (hit : i ∈ t) :
    IsCoprime x (s i) :=
  IsCoprime.prod_right_iff.1 H1 i hit
#align is_coprime.of_prod_right IsCoprime.of_prod_right

-- porting note: removed names of things due to linter, but they seem helpful
theorem Finset.prod_dvd_of_coprime :
    ∀ (_ : (t : Set I).Pairwise (IsCoprime on s)) (_ : ∀ i ∈ t, s i ∣ z), (∏ x in t, s x) ∣ z :=
  Finset.induction_on t (fun _ _ ↦ one_dvd z)
    (by
      intro a r har ih Hs Hs1
      rw [Finset.prod_insert har]
      have aux1 : a ∈ (↑(insert a r) : Set I) := Finset.mem_insert_self a r
      refine'
        (IsCoprime.prod_right fun i hir ↦
              Hs aux1 (Finset.mem_insert_of_mem hir) <|
                by
                rintro rfl
                exact har hir).mul_dvd
          (Hs1 a aux1) (ih (Hs.mono _) fun i hi ↦ Hs1 i <| Finset.mem_insert_of_mem hi)
      simp only [Finset.coe_insert, Set.subset_insert])
#align finset.prod_dvd_of_coprime Finset.prod_dvd_of_coprime

theorem Fintype.prod_dvd_of_coprime [Fintype I] (Hs : Pairwise (IsCoprime on s))
    (Hs1 : ∀ i, s i ∣ z) : (∏ x, s x) ∣ z :=
  Finset.prod_dvd_of_coprime (Hs.set_pairwise _) fun i _ ↦ Hs1 i
#align fintype.prod_dvd_of_coprime Fintype.prod_dvd_of_coprime

end

open Finset

theorem exists_sum_eq_one_iff_pairwise_coprime [DecidableEq I] (h : t.Nonempty) :
    (∃ μ : I → R, (∑ i in t, μ i * ∏ j in t \ {i}, s j) = 1) ↔
      Pairwise (IsCoprime on fun i : t ↦ s i) := by
  refine' h.cons_induction _ _
  · simp only [sum_singleton, Finset.sdiff_self, prod_empty, mul_one, exists_apply_eq,
               Pairwise, Ne.def, true_iff_iff]
    rintro a ⟨i, hi⟩ ⟨j, hj⟩ h
    rw [Finset.mem_singleton] at hi hj
    simp [hi, hj] at h
  intro a t hat h ih
  rw [pairwise_cons']
  have mem : ∀ x ∈ t, a ∈ insert a t \ {x} := fun x hx ↦
    by
    rw [mem_sdiff, mem_singleton]
    refine ⟨mem_insert_self _ _, fun ha ↦ hat (ha ▸ hx)⟩
  constructor
  · rintro ⟨μ, hμ⟩
    rw [sum_cons, cons_eq_insert, sdiff_singleton_eq_erase, erase_insert hat] at hμ
    refine' ⟨ih.mp ⟨Pi.single h.choose (μ a * s h.choose) + μ * fun _ ↦ s a, ?_⟩, fun b hb ↦ ?_⟩
    · rw [prod_eq_mul_prod_diff_singleton h.choose_spec, ← mul_assoc, ←
        @if_pos _ _ h.choose_spec R (_ * _) 0, ← sum_pi_single', ← sum_add_distrib] at hμ
      rw [← hμ, sum_congr rfl]
      intro x hx
      dsimp -- porting note: terms were showing as sort of `HAdd.hadd` instead of `+`
      -- this whole proof pretty much breaks and has to be rewritten from scratch
      rw [add_mul]
      congr 1
      · by_cases hx : x = h.choose
        · rw [hx, Pi.single_eq_same, Pi.single_eq_same]
        · rw [Pi.single_eq_of_ne hx, Pi.single_eq_of_ne hx, zero_mul]
      · rw [mul_assoc]
        congr
        rw [prod_eq_prod_diff_singleton_mul (mem x hx) _, mul_comm]
        congr 2
        rw [sdiff_sdiff_comm, sdiff_singleton_eq_erase a, erase_insert hat]
    · have : IsCoprime (s b) (s a) :=
        ⟨μ a * ∏ i in t \ {b}, s i, ∑ i in t, μ i * ∏ j in t \ {i}, s j, ?_⟩
      · exact ⟨this.symm, this⟩
      rw [mul_assoc, ← prod_eq_prod_diff_singleton_mul hb, sum_mul, ← hμ, sum_congr rfl]
      intro x hx
      rw [mul_assoc]
      congr
      rw [prod_eq_prod_diff_singleton_mul (mem x hx) _]
      congr 2
      rw [sdiff_sdiff_comm, sdiff_singleton_eq_erase a, erase_insert hat]
  · rintro ⟨hs, Hb⟩
    obtain ⟨μ, hμ⟩ := ih.mpr hs
    obtain ⟨u, v, huv⟩ := IsCoprime.prod_left fun b hb ↦ (Hb b hb).right
    use fun i ↦ if i = a then u else v * μ i
    have hμ' : (∑ i in t, v * ((μ i * ∏ j in t \ {i}, s j) * s a)) = v * s a := by
      rw [← mul_sum, ← sum_mul, hμ, one_mul]
    rw [sum_cons, cons_eq_insert, sdiff_singleton_eq_erase, erase_insert hat]
    dsimp
    rw [if_pos rfl, ← huv, ← hμ', sum_congr rfl]
    intro x hx
    rw [mul_assoc, if_neg fun ha : x = a ↦ hat (ha.casesOn hx)]
    rw [mul_assoc]
    congr
    rw [prod_eq_prod_diff_singleton_mul (mem x hx) _]
    congr 2
    rw [sdiff_sdiff_comm, sdiff_singleton_eq_erase a, erase_insert hat]
#align exists_sum_eq_one_iff_pairwise_coprime exists_sum_eq_one_iff_pairwise_coprime

theorem exists_sum_eq_one_iff_pairwise_coprime' [Fintype I] [Nonempty I] [DecidableEq I] :
    (∃ μ : I → R, (∑ i : I, μ i * ∏ j in {i}ᶜ, s j) = 1) ↔ Pairwise (IsCoprime on s) := by
  convert exists_sum_eq_one_iff_pairwise_coprime Finset.univ_nonempty (s := s) using 1
  simp only [Function.onFun, pairwise_subtype_iff_pairwise_finset', coe_univ, Set.pairwise_univ]
#align exists_sum_eq_one_iff_pairwise_coprime' exists_sum_eq_one_iff_pairwise_coprime'

-- porting note: a lot of the capitalization wasn't working
theorem pairwise_coprime_iff_coprime_prod [DecidableEq I] :
    Pairwise (IsCoprime on fun i : t ↦ s i) ↔ ∀ i ∈ t, IsCoprime (s i) (∏ j in t \ {i}, s j) := by
  refine' ⟨fun hp i hi ↦ IsCoprime.prod_right_iff.mpr fun j hj ↦ ?_, fun hp ↦ ?_⟩
  · rw [Finset.mem_sdiff, Finset.mem_singleton] at hj
    obtain ⟨hj, ji⟩ := hj
    refine @hp ⟨i, hi⟩ ⟨j, hj⟩ fun h ↦ ji (congrArg Subtype.val h).symm
    -- porting note: is there a better way compared to the old `congr_arg coe h`?
  · rintro ⟨i, hi⟩ ⟨j, hj⟩ h
    apply IsCoprime.prod_right_iff.mp (hp i hi)
    exact Finset.mem_sdiff.mpr ⟨hj, fun f ↦ h <| Subtype.ext (Finset.mem_singleton.mp f).symm⟩
#align pairwise_coprime_iff_coprime_prod pairwise_coprime_iff_coprime_prod

variable {m n : ℕ}

theorem IsCoprime.pow_left (H : IsCoprime x y) : IsCoprime (x ^ m) y := by
  rw [← Finset.card_range m, ← Finset.prod_const]
  exact IsCoprime.prod_left fun _ _ ↦ H
#align is_coprime.pow_left IsCoprime.pow_left

theorem IsCoprime.pow_right (H : IsCoprime x y) : IsCoprime x (y ^ n) := by
  rw [← Finset.card_range n, ← Finset.prod_const]
  exact IsCoprime.prod_right fun _ _ ↦ H
#align is_coprime.pow_right IsCoprime.pow_right

theorem IsCoprime.pow (H : IsCoprime x y) : IsCoprime (x ^ m) (y ^ n) :=
  H.pow_left.pow_right
#align is_coprime.pow IsCoprime.pow

theorem IsCoprime.pow_left_iff (hm : 0 < m) : IsCoprime (x ^ m) y ↔ IsCoprime x y := by
  refine' ⟨fun h ↦ _, IsCoprime.pow_left⟩
  rw [← Finset.card_range m, ← Finset.prod_const] at h
  exact h.of_prod_left 0 (Finset.mem_range.mpr hm)
  -- porting note: I'm not sure why `finset` didn't get corrected automatically to `Finset`
  -- by Mathport, nor whether this is an issue
#align is_coprime.pow_left_iff IsCoprime.pow_left_iff

theorem IsCoprime.pow_right_iff (hm : 0 < m) : IsCoprime x (y ^ m) ↔ IsCoprime x y :=
  isCoprime_comm.trans <| (IsCoprime.pow_left_iff hm).trans <| isCoprime_comm
#align is_coprime.pow_right_iff IsCoprime.pow_right_iff

theorem IsCoprime.pow_iff (hm : 0 < m) (hn : 0 < n) : IsCoprime (x ^ m) (y ^ n) ↔ IsCoprime x y :=
  (IsCoprime.pow_left_iff hm).trans <| IsCoprime.pow_right_iff hn
#align is_coprime.pow_iff IsCoprime.pow_iff


import GMLAlgebra.Basic
import GMLAlgebra.Monoid
import GMLAlgebra.Semigroup
import GMLAlgebra.Semiring

namespace Algebra
variable {α} (s : UnitalSemiringSig α)

local infixr:70 " ⋆ " => s.mul
local infixr:65 " ⊹ " => s.add
local notation "e" => s.one

class UnitalSemiring extends Semiring (no_index s.toSemiringSig) : Prop where
  protected mul_left_id (x) : e ⋆ x = x
  protected mul_right_id (x) : x ⋆ e = x

protected def UnitalSemiring.infer [OpAssoc s.add] [OpComm s.add] [OpAssoc s.mul] [OpLeftDistrib s.mul s.add] [OpRightDistrib s.mul s.add] [OpLeftId s.mul s.one] [OpRightId s.mul s.one] : UnitalSemiring s where
  add_assoc := op_assoc _
  add_comm := op_comm _
  mul_assoc := op_assoc _
  mul_left_distrib := op_left_distrib _
  mul_right_distrib := op_right_distrib _
  mul_left_id := op_left_id _
  mul_right_id := op_right_id _

namespace UnitalSemiring
variable {s} [self : UnitalSemiring s]

local instance : OpLeftId (no_index s.mul) (no_index s.one) := ⟨UnitalSemiring.mul_left_id⟩
local instance : OpRightId (no_index s.mul) (no_index s.one) := ⟨UnitalSemiring.mul_right_id⟩

instance toMulMonoid : Monoid (no_index s.toMulMonoidSig) := Monoid.infer _

end UnitalSemiring

class UnitalCommSemiring extends CommSemiring (no_index s.toSemiringSig) : Prop where
  protected mul_right_id (x) : x ⋆ e = x

protected def UnitalCommSemiring.infer [OpAssoc s.add] [OpComm s.add] [OpAssoc s.mul] [OpComm s.mul] [OpRightDistrib s.mul s.add] [OpRightId s.mul s.one] : UnitalCommSemiring s where
  add_assoc := op_assoc _
  add_comm := op_comm _
  mul_assoc := op_assoc _
  mul_comm := op_comm _
  mul_right_distrib := op_right_distrib _
  mul_right_id := op_right_id _

namespace UnitalCommSemiring
variable {s} [self : UnitalCommSemiring s]

local instance : OpRightId (no_index s.mul) (no_index s.one) := ⟨UnitalCommSemiring.mul_right_id⟩

protected theorem mul_left_id (x : α) : e ⋆ x = x := calc
  _ = x ⋆ e := by rw [op_comm (.⋆.) e x]
  _ = x := by rw [op_right_id (.⋆.) x]
local instance : OpLeftId (no_index s.mul) (no_index s.one) := ⟨UnitalCommSemiring.mul_left_id⟩

instance toUnitalSemiring : UnitalSemiring s := UnitalSemiring.infer _

instance toMulCommMonoid : CommMonoid (no_index s.toMulMonoidSig) := CommMonoid.infer _

end UnitalCommSemiring