/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Leonardo de Moura
-/
prelude
import Init.SimpLemmas
universe u

-- this is a copy of leanprover/lean4/src/Init/Data/Nat/Basic.lean
namespace Nat

@[specialize] def foldAux {α : Type u} (f : Nat → α → α) (s : Nat) : Nat → α → α
  | 0,      a => a
  | succ n, a => foldAux f s n (f (s - (succ n)) a)

@[inline] def fold {α : Type u} (f : Nat → α → α) (n : Nat) (init : α) : α :=
  foldAux f n n init

@[inline] def foldRev {α : Type u} (f : Nat → α → α) (n : Nat) (init : α) : α :=
  let rec @[specialize] loop
    | 0,      a => a
    | succ n, a => loop n (f n a)
  loop n init

@[specialize] def anyAux (f : Nat → Bool) (s : Nat) : Nat → Bool
  | 0      => false
  | succ n => f (s - (succ n)) || anyAux f s n

/-- `any f n = true` iff there is `i in [0, n-1]` s.t. `f i = true` -/
@[inline] def any (f : Nat → Bool) (n : Nat) : Bool :=
  anyAux f n n

@[inline] def all (f : Nat → Bool) (n : Nat) : Bool :=
  !any (fun i => !f i) n

@[inline] def repeat {α : Type u} (f : α → α) (n : Nat) (a : α) : α :=
  let rec @[specialize] loop
    | 0,      a => a
    | succ n, a => loop n (f a)
  loop n a

def blt (a b : Nat) : Bool :=
  ble a.succ b

attribute [simp] Nat.zero_le

/-! # Helper "packing" theorems -/

@[simp] theorem zero_eq : Nat.zero = 0 := rfl
@[simp] theorem add_eq : Nat.add x y = x + y := rfl
@[simp] theorem mul_eq : Nat.mul x y = x * y := rfl
@[simp] theorem sub_eq : Nat.sub x y = x - y := rfl
@[simp] theorem lt_eq : Nat.lt x y = (x < y) := rfl
@[simp] theorem le_eq : Nat.le x y = (x ≤ y) := rfl

/-! # Helper Bool relation theorems -/

@[simp] theorem beq_refl (a : Nat) : Nat.beq a a = true := by
  induction a with simp [Nat.beq]
  | succ a ih => simp [ih]

@[simp] theorem beq_eq : (Nat.beq x y = true) = (x = y) := propext <| Iff.intro Nat.eq_of_beq_eq_true (fun h => h ▸ (Nat.beq_refl x))
@[simp] theorem ble_eq : (Nat.ble x y = true) = (x ≤ y) := propext <| Iff.intro Nat.le_of_ble_eq_true Nat.ble_eq_true_of_le
@[simp] theorem blt_eq : (Nat.blt x y = true) = (x < y) := propext <| Iff.intro Nat.le_of_ble_eq_true Nat.ble_eq_true_of_le

instance : LawfulBEq Nat where
  eq_of_beq h := Nat.eq_of_beq_eq_true h
  rfl := by simp [BEq.beq]

@[simp] theorem beq_eq_true_eq (a b : Nat) : ((a == b) = true) = (a = b) := propext <| Iff.intro eq_of_beq (fun h => by subst h; apply LawfulBEq.rfl)
@[simp] theorem not_beq_eq_true_eq (a b : Nat) : ((!(a == b)) = true) = ¬(a = b) :=
  propext <| Iff.intro
    (fun h₁ h₂ => by subst h₂; rw [LawfulBEq.rfl] at h₁; contradiction)
    (fun h =>
      have : ¬ ((a == b) = true) := fun h' => absurd (eq_of_beq h') h
      by simp [this])

/-! # Nat.add theorems -/

@[simp] protected theorem zero_add : ∀ (n : Nat), 0 + n = n
  | 0   => rfl
  | n+1 => congrArg succ (Nat.zero_add n)

theorem succ_add : ∀ (n m : Nat), (succ n) + m = succ (n + m)
  | _, 0   => rfl
  | n, m+1 => congrArg succ (succ_add n m)

theorem add_succ (n m : Nat) : n + succ m = succ (n + m) :=
  rfl

theorem add_one (n : Nat) : n + 1 = succ n :=
  rfl

theorem succ_eq_add_one (n : Nat) : succ n = n + 1 :=
  rfl

protected theorem add_comm : ∀ (n m : Nat), n + m = m + n
  | n, 0   => Eq.symm (Nat.zero_add n)
  | n, m+1 => by
    have : succ (n + m) = succ (m + n) := by apply congrArg; apply Nat.add_comm
    rw [succ_add m n]
    apply this

protected theorem add_assoc : ∀ (n m k : Nat), (n + m) + k = n + (m + k)
  | _, _, 0      => rfl
  | n, m, succ k => congrArg succ (Nat.add_assoc n m k)

protected theorem add_left_comm (n m k : Nat) : n + (m + k) = m + (n + k) := by
  rw [← Nat.add_assoc, Nat.add_comm n m, Nat.add_assoc]

protected theorem add_right_comm (n m k : Nat) : (n + m) + k = (n + k) + m := by
  rw [Nat.add_assoc, Nat.add_comm m k, ← Nat.add_assoc]

protected theorem add_left_cancel {n m k : Nat} : n + m = n + k → m = k := by
  induction n with
  | zero => simp; intros; assumption
  | succ n ih => simp [succ_add]; intro h; apply ih h

protected theorem add_right_cancel {n m k : Nat} (h : n + m = k + m) : n = k := by
  rw [Nat.add_comm n m, Nat.add_comm k m] at h
  apply Nat.add_left_cancel h

/-! # Nat.mul theorems -/

@[simp] protected theorem mul_zero (n : Nat) : n * 0 = 0 :=
  rfl

theorem mul_succ (n m : Nat) : n * succ m = n * m + n :=
  rfl

@[simp] protected theorem zero_mul : ∀ (n : Nat), 0 * n = 0
  | 0      => rfl
  | succ n => mul_succ 0 n ▸ (Nat.zero_mul n).symm ▸ rfl

theorem succ_mul (n m : Nat) : (succ n) * m = (n * m) + m := by
  induction m with
  | zero => rfl
  | succ m ih => rw [mul_succ, add_succ, ih, mul_succ, add_succ, Nat.add_right_comm]

protected theorem mul_comm : ∀ (n m : Nat), n * m = m * n
  | n, 0      => (Nat.zero_mul n).symm ▸ (Nat.mul_zero n).symm ▸ rfl
  | n, succ m => (mul_succ n m).symm ▸ (succ_mul m n).symm ▸ (Nat.mul_comm n m).symm ▸ rfl

@[simp] protected theorem mul_one : ∀ (n : Nat), n * 1 = n :=
  Nat.zero_add

@[simp] protected theorem one_mul (n : Nat) : 1 * n = n :=
  Nat.mul_comm n 1 ▸ Nat.mul_one n

protected theorem left_distrib (n m k : Nat) : n * (m + k) = n * m + n * k := by
  induction n generalizing m k with
  | zero      => repeat rw [Nat.zero_mul]
  | succ n ih => simp [succ_mul, ih]; rw [Nat.add_assoc, Nat.add_assoc (n*m)]; apply congrArg; apply Nat.add_left_comm

protected theorem right_distrib (n m k : Nat) : (n + m) * k = n * k + m * k := by
  rw [Nat.mul_comm, Nat.left_distrib]; simp [Nat.mul_comm]

protected theorem mul_add (n m k : Nat) : n * (m + k) = n * m + n * k :=
  Nat.left_distrib n m k

protected theorem add_mul (n m k : Nat) : (n + m) * k = n * k + m * k :=
  Nat.right_distrib n m k

protected theorem mul_assoc : ∀ (n m k : Nat), (n * m) * k = n * (m * k)
  | n, m, 0      => rfl
  | n, m, succ k => by simp [mul_succ, Nat.mul_assoc n m k, Nat.left_distrib]

protected theorem mul_left_comm (n m k : Nat) : n * (m * k) = m * (n * k) := by
  rw [← Nat.mul_assoc, Nat.mul_comm n m, Nat.mul_assoc]

/-! # Inequalities -/

attribute [simp] Nat.le_refl

theorem succ_lt_succ {n m : Nat} : n < m → succ n < succ m :=
  succ_le_succ

theorem lt_succ_of_le {n m : Nat} : n ≤ m → n < succ m :=
  succ_le_succ

@[simp] protected theorem sub_zero (n : Nat) : n - 0 = n :=
  rfl

theorem succ_sub_succ_eq_sub (n m : Nat) : succ n - succ m = n - m := by
  induction m with
  | zero      => exact rfl
  | succ m ih => apply congrArg pred ih

theorem pred_le : ∀ (n : Nat), pred n ≤ n
  | zero   => Nat.le.refl
  | succ _ => le_succ _

theorem pred_lt : ∀ {n : Nat}, n ≠ 0 → pred n < n
  | zero,   h => absurd rfl h
  | succ _, _ => lt_succ_of_le (Nat.le_refl _)

theorem sub_le (n m : Nat) : n - m ≤ n := by
  induction m with
  | zero      => exact Nat.le_refl (n - 0)
  | succ m ih => apply Nat.le_trans (pred_le (n - m)) ih

theorem sub_lt : ∀ {n m : Nat}, 0 < n → 0 < m → n - m < n
  | 0,   _,   h1, _  => absurd h1 (Nat.lt_irrefl 0)
  | _+1, 0,   _, h2  => absurd h2 (Nat.lt_irrefl 0)
  | n+1, m+1, _,  _  =>
    Eq.symm (succ_sub_succ_eq_sub n m) ▸
      show n - m < succ n from
      lt_succ_of_le (sub_le n m)

theorem sub_succ (n m : Nat) : n - succ m = pred (n - m) :=
  rfl

theorem succ_sub_succ (n m : Nat) : succ n - succ m = n - m :=
  succ_sub_succ_eq_sub n m

@[simp] protected theorem sub_self : ∀ (n : Nat), n - n = 0
  | 0        => by rw [Nat.sub_zero]
  | (succ n) => by rw [succ_sub_succ, Nat.sub_self n]

protected theorem lt_of_lt_of_le {n m k : Nat} : n < m → m ≤ k → n < k :=
  Nat.le_trans

protected theorem lt_of_lt_of_eq {n m k : Nat} : n < m → m = k → n < k :=
  fun h₁ h₂ => h₂ ▸ h₁

instance : Trans (. < . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) where
  trans := Nat.lt_trans

instance : Trans (. ≤ . : Nat → Nat → Prop) (. ≤ . : Nat → Nat → Prop) (. ≤ . : Nat → Nat → Prop) where
  trans := Nat.le_trans

instance : Trans (. < . : Nat → Nat → Prop) (. ≤ . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) where
  trans := Nat.lt_of_lt_of_le

instance : Trans (. ≤ . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) where
  trans := Nat.lt_of_le_of_lt

protected theorem le_of_eq {n m : Nat} (p : n = m) : n ≤ m :=
  p ▸ Nat.le_refl n

theorem le_of_succ_le {n m : Nat} (h : succ n ≤ m) : n ≤ m :=
  Nat.le_trans (le_succ n) h

protected theorem le_of_lt {n m : Nat} (h : n < m) : n ≤ m :=
  le_of_succ_le h

def lt.step {n m : Nat} : n < m → n < succ m := le_step

theorem eq_zero_or_pos : ∀ (n : Nat), n = 0 ∨ n > 0
  | 0   => Or.inl rfl
  | _+1 => Or.inr (succ_pos _)

def lt.base (n : Nat) : n < succ n := Nat.le_refl (succ n)

theorem lt_succ_self (n : Nat) : n < succ n := lt.base n

protected theorem le_total (m n : Nat) : m ≤ n ∨ n ≤ m :=
  match Nat.lt_or_ge m n with
  | Or.inl h => Or.inl (Nat.le_of_lt h)
  | Or.inr h => Or.inr h

theorem eq_zero_of_le_zero {n : Nat} (h : n ≤ 0) : n = 0 :=
  Nat.le_antisymm h (zero_le _)

theorem lt_of_succ_lt {n m : Nat} : succ n < m → n < m :=
  le_of_succ_le

theorem lt_of_succ_lt_succ {n m : Nat} : succ n < succ m → n < m :=
  le_of_succ_le_succ

theorem lt_of_succ_le {n m : Nat} (h : succ n ≤ m) : n < m :=
  h

theorem succ_le_of_lt {n m : Nat} (h : n < m) : succ n ≤ m :=
  h

theorem zero_lt_of_lt : {a b : Nat} → a < b → 0 < b
  | 0,   _, h => h
  | a+1, b, h =>
    have : a < b := Nat.lt_trans (Nat.lt_succ_self _) h
    zero_lt_of_lt this

theorem zero_lt_of_ne_zero {a : Nat} (h : a ≠ 0) : 0 < a := by
  match a with
  | 0 => contradiction
  | a+1 => apply Nat.zero_lt_succ

attribute [simp] Nat.lt_irrefl

theorem ne_of_lt {a b : Nat} (h : a < b) : a ≠ b :=
  fun he => absurd (he ▸ h) (Nat.lt_irrefl a)

theorem le_or_eq_of_le_succ {m n : Nat} (h : m ≤ succ n) : m ≤ n ∨ m = succ n :=
  Decidable.byCases
    (fun (h' : m = succ n) => Or.inr h')
    (fun (h' : m ≠ succ n) =>
       have : m < succ n := Nat.lt_of_le_of_ne h h'
       have : succ m ≤ succ n := succ_le_of_lt this
       Or.inl (le_of_succ_le_succ this))

theorem le_add_right : ∀ (n k : Nat), n ≤ n + k
  | n, 0   => Nat.le_refl n
  | n, k+1 => le_succ_of_le (le_add_right n k)

theorem le_add_left (n m : Nat): n ≤ m + n :=
  Nat.add_comm n m ▸ le_add_right n m

theorem le.dest : ∀ {n m : Nat}, n ≤ m → Exists (fun k => n + k = m)
  | zero,   zero,   _ => ⟨0, rfl⟩
  | zero,   succ n, _ => ⟨succ n, Nat.add_comm 0 (succ n) ▸ rfl⟩
  | succ _, zero,   h => absurd h (not_succ_le_zero _)
  | succ n, succ m, h =>
    have : n ≤ m := Nat.le_of_succ_le_succ h
    have : Exists (fun k => n + k = m) := dest this
    match this with
    | ⟨k, h⟩ => ⟨k, show succ n + k = succ m from ((succ_add n k).symm ▸ h ▸ rfl)⟩

theorem le.intro {n m k : Nat} (h : n + k = m) : n ≤ m :=
  h ▸ le_add_right n k

protected theorem not_le_of_gt {n m : Nat} (h : n > m) : ¬ n ≤ m := fun h₁ =>
  match Nat.lt_or_ge n m with
  | Or.inl h₂ => absurd (Nat.lt_trans h h₂) (Nat.lt_irrefl _)
  | Or.inr h₂ =>
    have Heq : n = m := Nat.le_antisymm h₁ h₂
    absurd (@Eq.subst _ _ _ _ Heq h) (Nat.lt_irrefl m)

theorem gt_of_not_le {n m : Nat} (h : ¬ n ≤ m) : n > m :=
  match Nat.lt_or_ge m n with
  | Or.inl h₁ => h₁
  | Or.inr h₁ => absurd h₁ h

theorem ge_of_not_lt {n m : Nat} (h : ¬ n < m) : n ≥ m :=
  match Nat.lt_or_ge n m with
  | Or.inl h₁ => absurd h₁ h
  | Or.inr h₁ => h₁

instance : Antisymm ( . ≤ . : Nat → Nat → Prop) where
  antisymm h₁ h₂ := Nat.le_antisymm h₁ h₂

instance : Antisymm (¬ . < . : Nat → Nat → Prop) where
  antisymm h₁ h₂ := Nat.le_antisymm (Nat.ge_of_not_lt h₂) (Nat.ge_of_not_lt h₁)

protected theorem add_le_add_left {n m : Nat} (h : n ≤ m) (k : Nat) : k + n ≤ k + m :=
  match le.dest h with
  | ⟨w, hw⟩ =>
    have h₁ : k + n + w = k + (n + w) := Nat.add_assoc ..
    have h₂ : k + (n + w) = k + m     := congrArg _ hw
    le.intro <| h₁.trans h₂

protected theorem add_le_add_right {n m : Nat} (h : n ≤ m) (k : Nat) : n + k ≤ m + k := by
  rw [Nat.add_comm n k, Nat.add_comm m k]
  apply Nat.add_le_add_left
  assumption

protected theorem add_lt_add_left {n m : Nat} (h : n < m) (k : Nat) : k + n < k + m :=
  lt_of_succ_le (add_succ k n ▸ Nat.add_le_add_left (succ_le_of_lt h) k)

protected theorem add_lt_add_right {n m : Nat} (h : n < m) (k : Nat) : n + k < m + k :=
  Nat.add_comm k m ▸ Nat.add_comm k n ▸ Nat.add_lt_add_left h k

protected theorem zero_lt_one : 0 < (1:Nat) :=
  zero_lt_succ 0

theorem add_le_add {a b c d : Nat} (h₁ : a ≤ b) (h₂ : c ≤ d) : a + c ≤ b + d :=
  Nat.le_trans (Nat.add_le_add_right h₁ c) (Nat.add_le_add_left h₂ b)

theorem add_lt_add {a b c d : Nat} (h₁ : a < b) (h₂ : c < d) : a + c < b + d :=
  Nat.lt_trans (Nat.add_lt_add_right h₁ c) (Nat.add_lt_add_left h₂ b)

protected theorem le_of_add_le_add_left {a b c : Nat} (h : a + b ≤ a + c) : b ≤ c := by
  match le.dest h with
  | ⟨d, hd⟩ =>
    apply @le.intro _ _ d
    rw [Nat.add_assoc] at hd
    apply Nat.add_left_cancel hd

protected theorem le_of_add_le_add_right {a b c : Nat} : a + b ≤ c + b → a ≤ c := by
  rw [Nat.add_comm _ b, Nat.add_comm _ b]
  apply Nat.le_of_add_le_add_left

/-! # Basic theorems for comparing numerals -/

theorem ctor_eq_zero : Nat.zero = 0 :=
  rfl

protected theorem one_ne_zero : 1 ≠ (0 : Nat) :=
  fun h => Nat.noConfusion h

protected theorem zero_ne_one : 0 ≠ (1 : Nat) :=
  fun h => Nat.noConfusion h

theorem succ_ne_zero (n : Nat) : succ n ≠ 0 :=
  fun h => Nat.noConfusion h

/-! # mul + order -/

theorem mul_le_mul_left {n m : Nat} (k : Nat) (h : n ≤ m) : k * n ≤ k * m :=
  match le.dest h with
  | ⟨l, hl⟩ =>
    have : k * n + k * l = k * m := Nat.left_distrib k n l ▸ hl.symm ▸ rfl
    le.intro this

theorem mul_le_mul_right {n m : Nat} (k : Nat) (h : n ≤ m) : n * k ≤ m * k :=
  Nat.mul_comm k m ▸ Nat.mul_comm k n ▸ mul_le_mul_left k h

protected theorem mul_le_mul {n₁ m₁ n₂ m₂ : Nat} (h₁ : n₁ ≤ n₂) (h₂ : m₁ ≤ m₂) : n₁ * m₁ ≤ n₂ * m₂ :=
  Nat.le_trans (mul_le_mul_right _ h₁) (mul_le_mul_left _ h₂)

protected theorem mul_lt_mul_of_pos_left {n m k : Nat} (h : n < m) (hk : k > 0) : k * n < k * m :=
  Nat.lt_of_lt_of_le (Nat.add_lt_add_left hk _) (Nat.mul_succ k n ▸ Nat.mul_le_mul_left k (succ_le_of_lt h))

protected theorem mul_lt_mul_of_pos_right {n m k : Nat} (h : n < m) (hk : k > 0) : n * k < m * k :=
  Nat.mul_comm k m ▸ Nat.mul_comm k n ▸ Nat.mul_lt_mul_of_pos_left h hk

protected theorem mul_pos {n m : Nat} (ha : n > 0) (hb : m > 0) : n * m > 0 :=
  have h : 0 * m < n * m := Nat.mul_lt_mul_of_pos_right ha hb
  Nat.zero_mul m ▸ h

protected theorem le_of_mul_le_mul_left {a b c : Nat} (h : c * a ≤ c * b) (hc : 0 < c) : a ≤ b :=
  Nat.ge_of_not_lt fun hlt : b < a =>
    have h' : c * b < c * a := Nat.mul_lt_mul_of_pos_left hlt hc
    absurd h (Nat.not_le_of_gt h')

protected theorem eq_of_mul_eq_mul_left {m k n : Nat} (hn : 0 < n) (h : n * m = n * k) : m = k :=
  Nat.le_antisymm (Nat.le_of_mul_le_mul_left (Nat.le_of_eq h) hn)
                  (Nat.le_of_mul_le_mul_left (Nat.le_of_eq h.symm) hn)

theorem eq_of_mul_eq_mul_right {n m k : Nat} (hm : 0 < m) (h : n * m = k * m) : n = k := by
  rw [Nat.mul_comm n m, Nat.mul_comm k m] at h; exact Nat.eq_of_mul_eq_mul_left hm h

/-! # power -/

theorem pow_succ (n m : Nat) : n^(succ m) = n^m * n :=
  rfl

theorem pow_zero (n : Nat) : n^0 = 1 := rfl

theorem pow_le_pow_of_le_left {n m : Nat} (h : n ≤ m) : ∀ (i : Nat), n^i ≤ m^i
  | 0      => Nat.le_refl _
  | succ i => Nat.mul_le_mul (pow_le_pow_of_le_left h i) h

theorem pow_le_pow_of_le_right {n : Nat} (hx : n > 0) {i : Nat} : ∀ {j}, i ≤ j → n^i ≤ n^j
  | 0,      h =>
    have : i = 0 := eq_zero_of_le_zero h
    this.symm ▸ Nat.le_refl _
  | succ j, h =>
    match le_or_eq_of_le_succ h with
    | Or.inl h => show n^i ≤ n^j * n from
      have : n^i * 1 ≤ n^j * n := Nat.mul_le_mul (pow_le_pow_of_le_right hx h) hx
      Nat.mul_one (n^i) ▸ this
    | Or.inr h =>
      h.symm ▸ Nat.le_refl _

theorem pos_pow_of_pos {n : Nat} (m : Nat) (h : 0 < n) : 0 < n^m :=
  pow_le_pow_of_le_right h (Nat.zero_le _)

/-! # min/max -/

protected def min (n m : Nat) : Nat :=
  if n ≤ m then n else m

protected def max (n m : Nat) : Nat :=
  if n ≤ m then m else n

/-! # Auxiliary theorems for well-founded recursion -/

theorem not_eq_zero_of_lt (h : b < a) : a ≠ 0 := by
  cases a
  exact absurd h (Nat.not_lt_zero _)
  apply Nat.noConfusion

theorem pred_lt' {n m : Nat} (h : m < n) : pred n < n :=
  pred_lt (not_eq_zero_of_lt h)

/-! # sub/pred theorems -/

theorem add_sub_self_left (a b : Nat) : (a + b) - a = b := by
  induction a with
  | zero => simp
  | succ a ih =>
    rw [Nat.succ_add, Nat.succ_sub_succ]
    apply ih

theorem add_sub_self_right (a b : Nat) : (a + b) - b = a := by
  rw [Nat.add_comm]; apply add_sub_self_left

theorem sub_le_succ_sub (a i : Nat) : a - i ≤ a.succ - i := by
  cases i with
  | zero => apply Nat.le_of_lt; apply Nat.lt_succ_self
  | succ i => rw [Nat.sub_succ, Nat.succ_sub_succ]; apply Nat.pred_le

theorem zero_lt_sub_of_lt (h : i < a) : 0 < a - i := by
  induction a with
  | zero => contradiction
  | succ a ih =>
    match Nat.eq_or_lt_of_le h with
    | Or.inl h => injection h with h; subst h; rw [←Nat.add_one, Nat.add_sub_self_left]; decide
    | Or.inr h =>
      have : 0 < a - i := ih (Nat.lt_of_succ_lt_succ h)
      exact Nat.lt_of_lt_of_le this (Nat.sub_le_succ_sub _ _)

theorem sub_succ_lt_self (a i : Nat) (h : i < a) : a - (i + 1) < a - i := by
  rw [Nat.add_succ, Nat.sub_succ]
  apply Nat.pred_lt
  apply Nat.not_eq_zero_of_lt
  apply Nat.zero_lt_sub_of_lt
  assumption

theorem succ_pred {a : Nat} (h : a ≠ 0) : a.pred.succ = a := by
  induction a with
  | zero => contradiction
  | succ => rfl

theorem sub_ne_zero_of_lt : {a b : Nat} → a < b → b - a ≠ 0
  | 0, 0, h      => absurd h (Nat.lt_irrefl 0)
  | 0, succ b, _ => by simp
  | succ a, 0, h => absurd h (Nat.not_lt_zero a.succ)
  | succ a, succ b, h => by rw [Nat.succ_sub_succ]; exact sub_ne_zero_of_lt (Nat.lt_of_succ_lt_succ h)

theorem add_sub_of_le {a b : Nat} (h : a ≤ b) : a + (b - a) = b := by
  induction a with
  | zero => simp
  | succ a ih =>
    have hne : b - a ≠ 0 := Nat.sub_ne_zero_of_lt h
    have : a ≤ b := Nat.le_of_succ_le h
    rw [sub_succ, Nat.succ_add, ← Nat.add_succ, Nat.succ_pred hne, ih this]

protected theorem sub_add_cancel {n m : Nat} (h : m ≤ n) : n - m + m = n := by
  rw [Nat.add_comm, Nat.add_sub_of_le h]

protected theorem add_sub_add_right (n k m : Nat) : (n + k) - (m + k) = n - m := by
  induction k with
  | zero => simp
  | succ k ih => simp [add_succ, add_succ, succ_sub_succ, ih]

protected theorem add_sub_add_left (k n m : Nat) : (k + n) - (k + m) = n - m := by
  rw [Nat.add_comm k n, Nat.add_comm k m, Nat.add_sub_add_right]

protected theorem add_sub_cancel (n m : Nat) : n + m - m = n :=
  suffices n + m - (0 + m) = n by rw [Nat.zero_add] at this; assumption
  by rw [Nat.add_sub_add_right, Nat.sub_zero]

protected theorem add_sub_cancel_left (n m : Nat) : n + m - n = m :=
  show n + m - (n + 0) = m from
  by rw [Nat.add_sub_add_left, Nat.sub_zero]

protected theorem add_sub_assoc {m k : Nat} (h : k ≤ m) (n : Nat) : n + m - k = n + (m - k) := by
 cases Nat.le.dest h
 rename_i l hl
 rw [← hl, Nat.add_sub_cancel_left, Nat.add_comm k, ← Nat.add_assoc, Nat.add_sub_cancel]

protected theorem eq_add_of_sub_eq {a b c : Nat} (hle : b ≤ a) (h : a - b = c) : a = c + b := by
  rw [h.symm, Nat.sub_add_cancel hle]

protected theorem sub_eq_of_eq_add {a b c : Nat} (h : a = c + b) : a - b = c := by
  rw [h, Nat.add_sub_cancel]

theorem le_add_of_sub_le {a b c : Nat} (h : a - b ≤ c) : a ≤ c + b := by
  match le.dest h, Nat.le_total a b with
  | _, Or.inl hle =>
    exact Nat.le_trans hle (Nat.le_add_left ..)
  | ⟨d, hd⟩, Or.inr hge =>
    apply @le.intro _ _ d
    rw [Nat.add_comm, ← Nat.add_sub_assoc hge] at hd
    have hd := Nat.eq_add_of_sub_eq (Nat.le_trans hge (Nat.le_add_left ..)) hd
    rw [Nat.add_comm, hd]

@[simp] protected theorem zero_sub (n : Nat) : 0 - n = 0 := by
  induction n with
  | zero => rfl
  | succ n ih => simp [ih, Nat.sub_succ]

protected theorem sub_self_add (n m : Nat) : n - (n + m) = 0 := by
  show (n + 0) - (n + m) = 0
  rw [Nat.add_sub_add_left, Nat.zero_sub]

protected theorem sub_eq_zero_of_le {n m : Nat} (h : n ≤ m) : n - m = 0 := by
  match le.dest h with
  | ⟨k, hk⟩ => rw [← hk, Nat.sub_self_add]

theorem sub_le_of_le_add {a b c : Nat} (h : a ≤ c + b) : a - b ≤ c := by
  match le.dest h, Nat.le_total a b with
  | _, Or.inl hle =>
    rw [Nat.sub_eq_zero_of_le hle]
    apply Nat.zero_le
  | ⟨d, hd⟩, Or.inr hge =>
    apply @le.intro _ _ d
    have hd := Nat.sub_eq_of_eq_add hd
    rw [Nat.add_comm, ← Nat.add_sub_assoc hge, Nat.add_comm]
    exact hd

theorem add_le_of_le_sub {a b c : Nat} (hle : b ≤ c) (h : a ≤ c - b) : a + b ≤ c := by
  match le.dest h with
  | ⟨d, hd⟩ =>
    apply @le.intro _ _ d
    rw [Nat.eq_add_of_sub_eq hle hd.symm]
    simp [Nat.add_comm, Nat.add_assoc, Nat.add_left_comm]

theorem le_sub_of_add_le {a b c : Nat} (h : a + b ≤ c) : a ≤ c - b := by
  match le.dest h with
  | ⟨d, hd⟩ =>
    apply @le.intro _ _ d
    have hd : a + d + b = c := by simp [← hd, Nat.add_comm, Nat.add_assoc, Nat.add_left_comm]
    have hd := Nat.sub_eq_of_eq_add hd.symm
    exact hd.symm

theorem add_lt_of_lt_sub {a b c : Nat} (h : a < c - b) : a + b < c := by
  have hle : b ≤ c := by
    apply Nat.ge_of_not_lt
    intro hgt
    apply Nat.not_lt_zero a
    rw [Nat.sub_eq_zero_of_le (Nat.le_of_lt hgt)] at h
    exact h
  have : a.succ + b ≤ c := add_le_of_le_sub hle h
  simp [Nat.succ_add] at this
  exact this

theorem lt_sub_of_add_lt {a b c : Nat} (h : a + b < c) : a < c - b :=
  have : a.succ + b ≤ c := by simp [Nat.succ_add]; exact h
  le_sub_of_add_le this

@[simp] protected theorem pred_zero : pred 0 = 0 :=
  rfl

@[simp] protected theorem pred_succ (n : Nat) : pred n.succ = n :=
  rfl

theorem sub.elim {motive : Nat → Prop}
    (x y : Nat)
    (h₁ : y ≤ x → (k : Nat) → x = y + k → motive k)
    (h₂ : x < y → motive 0)
    : motive (x - y) := by
  cases Nat.lt_or_ge x y with
  | inl hlt => rw [Nat.sub_eq_zero_of_le (Nat.le_of_lt hlt)]; exact h₂ hlt
  | inr hle => exact h₁ hle (x - y) (Nat.add_sub_of_le hle).symm

theorem mul_pred_left (n m : Nat) : pred n * m = n * m - m := by
  cases n with
  | zero   => simp
  | succ n => rw [Nat.pred_succ, succ_mul, Nat.add_sub_cancel]

theorem mul_pred_right (n m : Nat) : n * pred m = n * m - n := by
  rw [Nat.mul_comm, mul_pred_left, Nat.mul_comm]

protected theorem sub_sub (n m k : Nat) : n - m - k = n - (m + k) := by
  induction k with
  | zero => simp
  | succ k ih => rw [Nat.add_succ, Nat.sub_succ, Nat.sub_succ, ih]

protected theorem mul_sub_right_distrib (n m k : Nat) : (n - m) * k = n * k - m * k := by
  induction m with
  | zero => simp
  | succ m ih => rw [Nat.sub_succ, Nat.mul_pred_left, ih, succ_mul, Nat.sub_sub]; done

protected theorem mul_sub_left_distrib (n m k : Nat) : n * (m - k) = n * m - n * k := by
  rw [Nat.mul_comm, Nat.mul_sub_right_distrib, Nat.mul_comm m n, Nat.mul_comm n k]

/-! # Helper normalization theorems -/

theorem not_le_eq (a b : Nat) : (¬ (a ≤ b)) = (b + 1 ≤ a) :=
  propext <| Iff.intro (fun h => Nat.gt_of_not_le h) (fun h => Nat.not_le_of_gt h)

theorem not_ge_eq (a b : Nat) : (¬ (a ≥ b)) = (a + 1 ≤ b) :=
  not_le_eq b a

theorem not_lt_eq (a b : Nat) : (¬ (a < b)) = (b ≤ a) :=
  propext <| Iff.intro (fun h => have h := Nat.succ_le_of_lt (Nat.gt_of_not_le h); Nat.le_of_succ_le_succ h) (fun h => Nat.not_le_of_gt (Nat.succ_le_succ h))

theorem not_gt_eq (a b : Nat) : (¬ (a > b)) = (a ≤ b) :=
  not_lt_eq b a

end Nat

namespace Prod

@[inline] def foldI {α : Type u} (f : Nat → α → α) (i : Nat × Nat) (a : α) : α :=
  Nat.foldAux f i.2 (i.2 - i.1) a

@[inline] def anyI (f : Nat → Bool) (i : Nat × Nat) : Bool :=
  Nat.anyAux f i.2 (i.2 - i.1)

@[inline] def allI (f : Nat → Bool) (i : Nat × Nat) : Bool :=
  Nat.anyAux (fun a => !f a) i.2 (i.2 - i.1)

end Prod


import basic
import data.set

namespace subuniverse

section
parameters {α : Type*} {S : signature} (A : algebra_on S α) {I ζ : Type} {R : I → set α}
open set

def Sub (β : set α) : Prop :=
∀ f (a : S.ρ f → α), (∀ x, a x ∈ β) → A f a ∈ β

-- N.B. A f a ∈ β   is notation for   β (A f a)

def Sg (X : set α) : set α :=
⋂₀ {U | Sub U ∧ X ⊆ U}

def index_of_sub_above_X (X : set α) (C : I → set α) : I → Prop := λ i, Sub (C i) ∧ X ⊆ (C i)

theorem mem_Inter_of_mem  {s : I → set α} : ∀ x, (∀ i, x ∈ s i) → (x ∈ ⋂ i, s i) :=
assume x h t ⟨a, (eq : t = s a)⟩, eq.symm ▸ h a

theorem Inter.intro {x : α} (C : I → set α) (h : ∀ i, x ∈ C i) : x ∈ ⋂ i, C i :=
by simp; assumption

theorem Inter.elim {x : α} (C : I → set α) (h : x ∈ ⋂ i, C i) (i : I) : x ∈ C i :=
by simp at h; apply h

lemma sub_of_sub_inter_sub (C : I → set α) :
(∀ i, Sub (C i)) → Sub ⋂i, C i :=
  assume h : ∀ i, Sub (C i), show  Sub (⋂i, C i), from
    assume f a (h1 : (∀ x, a x ∈ ⋂i, C i)), show A f a ∈ (⋂i, C i), from
      have h4 : ∀ j, A f a ∈ C j, from
        assume j : I, show A f a ∈ C j, from
          have h3 : ∀ x, a x ∈ (C j), from assume x, Inter.elim C (h1 x) j,
      (h j) f a h3,
    (mem_Inter_of_mem (A f a)) h4 --Inter.intro C h4

lemma subset_X_of_SgX (X : set α) : X ⊆ Sg X :=
assume x (h1 : x ∈ X), show x ∈ ⋂₀ {U | Sub U ∧ X ⊆ U}, from
  assume V (h2 : V ∈ {U | Sub U ∧ X ⊆ U}),  show x ∈ V, from
    have h3: Sub V ∧ X ⊆ V, from h2,
    h3.right h1

lemma sInter_mem {X : set α} (x : α) :
x ∈ Sg X  →  ∀ {R : set α }, Sub R → X ⊆ R → x ∈ R :=
  (assume (h1 : x ∈ Sg X) (R : set α)  (h2 : Sub R) (h3 : X ⊆ R),
    show x ∈ R, from h1 R (and.intro h2 h3))

-- Sg X is a Sub
lemma sub_SgX (X : set α) : Sub (Sg X) :=
assume f a (h : ∀ i, a i ∈ Sg X), show A f a ∈ Sg X, from
  assume U (h1 : Sub U ∧ X ⊆ U), show A f a ∈ U, from
    have h3 : Sg X ⊆ U, from
      assume r (h4 : r ∈ Sg X), show r ∈ U, from sInter_mem r h4 h1.left h1.right,
    have h5 : ∀ i, a i ∈ U, from assume i, h3 (h i),
    (h1.left f a h5)

lemma sInter_mem_of_mem {X : set α} (x : α) :
x ∈ Sg X  ↔  ∀ {R : set α }, Sub R → X ⊆ R → x ∈ R :=
iff.intro
  (assume (h1 : x ∈ Sg X) (R : set α)  (h2 : Sub R) (h3 : X ⊆ R),
    show x ∈ R, from h1 R (and.intro h2 h3))
  (assume (h1 : ∀ {R : set α}, Sub R → X ⊆ R → x ∈ R),
    show x∈ Sg X, from h1 (sub_SgX X) (subset_X_of_SgX X))

parameter (X : set α)

-- One way to make this SEGFAULT lol    -- Siva, do you get a segv here?
--                                         I don't...
inductive Y : set α
| var (x : α) : x ∈ X → Y x
| app (f : S.F) (a : S.ρ f → α) : (∀ i, Y (a i)) → Y (A f a)

-- Y is a Sub
lemma sub_Y : (Sub Y) :=
assume f a (h: ∀ i, Y (a i)), show Y (A f a), from
Y.app f a h

-- Y is the smallest Sub containing X
lemma sub_min_Y (U : set α) : Sub U → X ⊆ U → Y ⊆ U :=
assume (h₁ : Sub U) (h₂ : X ⊆ U),
assume (y : α)  (p : Y y), show U y, from
  have q : Y y → Y y → U y, from
    Y.rec
      --base: y = x ∈ X
      ( assume y (h : X y) (h' : Y y), h₂ h )

      --inductive: y = A f a for some a with ∀ i, a i ∈ Y
      ( assume f a (h : ∀ i, Y (a i)) (h' : ∀ i, Y (a i) → U (a i)) (h'' : Y (A f a)),
        have h₄ : ∀ i, a i ∈ U, from
          assume i, h' i (h i), show U (A f a), from h₁ f a h₄ ),
  q p p

-- Y is the Sub generated by X
theorem sg_inductive : Sg X = Y :=
  have h' : X ⊆ Y, from
    assume x (h3 : x ∈ X), show x  ∈ Y, from Y.var x h3,

  have h : Sub Y, from
    assume f a (h1 : ∀ x, Y (a x)), show Y (A f a), from Y.app f a h1,

  have l : Sg X ⊆ Y, from
    assume u (h3 : u ∈ Sg X), show u ∈ Y, from (sInter_mem u) h3 h h',

  have r : Y ⊆ Sg X, from
    assume a (p: a ∈ Y), show a ∈ Sg X, from
      have q : a ∈ Y → a ∈ Sg X, from
        Y.rec

        --base: a = x ∈ X
        ( assume x (h1 : x ∈ X), show x ∈ Sg X, from subset_X_of_SgX X h1 )

        --inductive: a = A f b for some b with ∀ i, b i ∈ Sg X
        ( assume f b (h2 : ∀ i, b i ∈ Y) (h3 : ∀ i, b i ∈ Sg X),
          show A f b ∈ Sg X, from sub_SgX X f b h3 ),

      q p,

  subset.antisymm l r
end

end subuniverse

-- Miscellaneous Notes

-- ⋂₀ is notation for sInter (S : set (set α)) : set α := Inf S,
-- and Inf S is defined as follows:
-- Inf          := λs, {a | ∀ t ∈ s, a ∈ t },
-- So, if S : set (set α) (i.e., a collection of sets of type α),
-- then Inf S is the intersection of the sets in S.


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.creates

/-!
# Limits in full subcategories

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

We introduce the notion of a property closed under taking limits and show that if `P` is closed
under taking limits, then limits in `full_subcategory P` can be constructed from limits in `C`.
More precisely, the inclusion creates such limits.

-/

noncomputable theory

universes w' w v u

open category_theory

namespace category_theory.limits

/-- We say that a property is closed under limits of shape `J` if whenever all objects in a
    `J`-shaped diagram have the property, any limit of this diagram also has the property. -/
def closed_under_limits_of_shape {C : Type u} [category.{v} C] (J : Type w) [category.{w'} J]
  (P : C → Prop) : Prop :=
∀ ⦃F : J ⥤ C⦄ ⦃c : cone F⦄ (hc : is_limit c), (∀ j, P (F.obj j)) → P c.X

/-- We say that a property is closed under colimits of shape `J` if whenever all objects in a
    `J`-shaped diagram have the property, any colimit of this diagram also has the property. -/
def closed_under_colimits_of_shape {C : Type u} [category.{v} C] (J : Type w) [category.{w'} J]
  (P : C → Prop) : Prop :=
∀ ⦃F : J ⥤ C⦄ ⦃c : cocone F⦄ (hc : is_colimit c), (∀ j, P (F.obj j)) → P c.X

section
variables {C : Type u} [category.{v} C] {J : Type w} [category.{w'} J] {P : C → Prop}

lemma closed_under_limits_of_shape.limit (h : closed_under_limits_of_shape J P) {F : J ⥤ C}
  [has_limit F] : (∀ j, P (F.obj j)) → P (limit F) :=
h (limit.is_limit _)

lemma closed_under_colimits_of_shape.colimit (h : closed_under_colimits_of_shape J P) {F : J ⥤ C}
  [has_colimit F] : (∀ j, P (F.obj j)) → P (colimit F) :=
h (colimit.is_colimit _)

end

section
variables {J : Type w} [category.{w'} J] {C : Type u} [category.{v} C] {P : C → Prop}

/-- If a `J`-shaped diagram in `full_subcategory P` has a limit cone in `C` whose cone point lives
    in the full subcategory, then this defines a limit in the full subcategory. -/
def creates_limit_full_subcategory_inclusion' (F : J ⥤ full_subcategory P)
  {c : cone (F ⋙ full_subcategory_inclusion P)} (hc : is_limit c) (h : P c.X) :
  creates_limit F (full_subcategory_inclusion P) :=
creates_limit_of_fully_faithful_of_iso' hc ⟨_, h⟩ (iso.refl _)

/-- If a `J`-shaped diagram in `full_subcategory P` has a limit in `C` whose cone point lives in the
    full subcategory, then this defines a limit in the full subcategory. -/
def creates_limit_full_subcategory_inclusion (F : J ⥤ full_subcategory P)
  [has_limit (F ⋙ full_subcategory_inclusion P)]
  (h : P (limit (F ⋙ full_subcategory_inclusion P))) :
  creates_limit F (full_subcategory_inclusion P) :=
creates_limit_full_subcategory_inclusion' F (limit.is_limit _) h

/-- If a `J`-shaped diagram in `full_subcategory P` has a colimit cocone in `C` whose cocone point
    lives in the full subcategory, then this defines a colimit in the full subcategory. -/
def creates_colimit_full_subcategory_inclusion' (F : J ⥤ full_subcategory P)
  {c : cocone (F ⋙ full_subcategory_inclusion P)} (hc : is_colimit c) (h : P c.X) :
  creates_colimit F (full_subcategory_inclusion P) :=
creates_colimit_of_fully_faithful_of_iso' hc ⟨_, h⟩ (iso.refl _)

/-- If a `J`-shaped diagram in `full_subcategory P` has a colimit in `C` whose cocone point lives in
    the full subcategory, then this defines a colimit in the full subcategory. -/
def creates_colimit_full_subcategory_inclusion (F : J ⥤ full_subcategory P)
  [has_colimit (F ⋙ full_subcategory_inclusion P)]
  (h : P (colimit (F ⋙ full_subcategory_inclusion P))) :
  creates_colimit F (full_subcategory_inclusion P) :=
creates_colimit_full_subcategory_inclusion' F (colimit.is_colimit _) h

/-- If `P` is closed under limits of shape `J`, then the inclusion creates such limits. -/
def creates_limit_full_subcategory_inclusion_of_closed (h : closed_under_limits_of_shape J P)
  (F : J ⥤ full_subcategory P) [has_limit (F ⋙ full_subcategory_inclusion P)] :
  creates_limit F (full_subcategory_inclusion P) :=
creates_limit_full_subcategory_inclusion F (h.limit (λ j, (F.obj j).property))

/-- If `P` is closed under limits of shape `J`, then the inclusion creates such limits. -/
def creates_limits_of_shape_full_subcategory_inclusion (h : closed_under_limits_of_shape J P)
  [has_limits_of_shape J C] : creates_limits_of_shape J (full_subcategory_inclusion P) :=
{ creates_limit := λ F, creates_limit_full_subcategory_inclusion_of_closed h F }

lemma has_limit_of_closed_under_limits (h : closed_under_limits_of_shape J P)
  (F : J ⥤ full_subcategory P) [has_limit (F ⋙ full_subcategory_inclusion P)] : has_limit F :=
have creates_limit F (full_subcategory_inclusion P),
  from creates_limit_full_subcategory_inclusion_of_closed h F,
by exactI has_limit_of_created F (full_subcategory_inclusion P)

lemma has_limits_of_shape_of_closed_under_limits (h : closed_under_limits_of_shape J P)
  [has_limits_of_shape J C] : has_limits_of_shape J (full_subcategory P) :=
{ has_limit := λ F, has_limit_of_closed_under_limits h F }

/-- If `P` is closed under colimits of shape `J`, then the inclusion creates such colimits. -/
def creates_colimit_full_subcategory_inclusion_of_closed (h : closed_under_colimits_of_shape J P)
  (F : J ⥤ full_subcategory P) [has_colimit (F ⋙ full_subcategory_inclusion P)] :
  creates_colimit F (full_subcategory_inclusion P) :=
creates_colimit_full_subcategory_inclusion F (h.colimit (λ j, (F.obj j).property))

/-- If `P` is closed under colimits of shape `J`, then the inclusion creates such colimits. -/
def creates_colimits_of_shape_full_subcategory_inclusion
  (h : closed_under_colimits_of_shape J P) [has_colimits_of_shape J C] :
  creates_colimits_of_shape J (full_subcategory_inclusion P) :=
{ creates_colimit := λ F, creates_colimit_full_subcategory_inclusion_of_closed h F }

lemma has_colimit_of_closed_under_colimits (h : closed_under_colimits_of_shape J P)
  (F : J ⥤ full_subcategory P) [has_colimit (F ⋙ full_subcategory_inclusion P)] : has_colimit F :=
have creates_colimit F (full_subcategory_inclusion P),
  from creates_colimit_full_subcategory_inclusion_of_closed h F,
by exactI has_colimit_of_created F (full_subcategory_inclusion P)

end

end category_theory.limits


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

Coinductive formalization of unbounded computations.
-/
import data.stream data.nat.basic
universes u v w

/-
coinductive computation (α : Type u) : Type u
| return : α → computation α
| think : computation α → computation α
-/

/-- `computation α` is the type of unbounded computations returning `α`.
  An element of `computation α` is an infinite sequence of `option α` such
  that if `f n = some a` for some `n` then it is constantly `some a` after that. -/
def computation (α : Type u) : Type u :=
{ f : stream (option α) // ∀ {n a}, f n = some a → f (n+1) = some a }

namespace computation
variables {α : Type u} {β : Type v} {γ : Type w}

-- constructors
/-- `return a` is the computation that immediately terminates with result `a`. -/
def return (a : α) : computation α := ⟨stream.const (some a), λn a', id⟩

instance : has_coe α (computation α) := ⟨return⟩

/-- `think c` is the computation that delays for one "tick" and then performs
  computation `c`. -/
def think (c : computation α) : computation α :=
⟨none :: c.1, λn a h, by {cases n with n, contradiction, exact c.2 h}⟩

/-- `thinkN c n` is the computation that delays for `n` ticks and then performs
  computation `c`. -/
def thinkN (c : computation α) : ℕ → computation α
| 0 := c
| (n+1) := think (thinkN n)

-- check for immediate result
/-- `head c` is the first step of computation, either `some a` if `c = return a`
  or `none` if `c = think c'`. -/
def head (c : computation α) : option α := c.1.head

-- one step of computation
/-- `tail c` is the remainder of computation, either `c` if `c = return a`
  or `c'` if `c = think c'`. -/
def tail (c : computation α) : computation α :=
⟨c.1.tail, λ n a, let t := c.2 in t⟩

/-- `empty α` is the computation that never returns, an infinite sequence of
  `think`s. -/
def empty (α) : computation α := ⟨stream.const none, λn a', id⟩

/-- `run_for c n` evaluates `c` for `n` steps and returns the result, or `none`
  if it did not terminate after `n` steps. -/
def run_for : computation α → ℕ → option α := subtype.val

/-- `destruct c` is the destructor for `computation α` as a coinductive type.
  It returns `inl a` if `c = return a` and `inr c'` if `c = think c'`. -/
def destruct (c : computation α) : α ⊕ computation α :=
match c.1 0 with
| none := sum.inr (tail c)
| some a := sum.inl a
end

/-- `run c` is an unsound meta function that runs `c` to completion, possibly
  resulting in an infinite loop in the VM. -/
meta def run : computation α → α | c :=
match destruct c with
| sum.inl a := a
| sum.inr ca := run ca
end

theorem destruct_eq_ret {s : computation α} {a : α} :
  destruct s = sum.inl a → s = return a :=
begin
  dsimp [destruct],
  induction f0 : s.1 0; intro h,
  { contradiction },
  { apply subtype.eq, funext n,
    induction n with n IH,
    { injection h with h', rwa h' at f0 },
    { exact s.2 IH } }
end

theorem destruct_eq_think {s : computation α} {s'} :
  destruct s = sum.inr s' → s = think s' :=
begin
  dsimp [destruct],
  induction f0 : s.1 0 with a'; intro h,
  { injection h with h', rw ←h',
    cases s with f al,
    apply subtype.eq, dsimp [think, tail],
    rw ←f0, exact (stream.eta f).symm },
  { contradiction }
end

@[simp] theorem destruct_ret (a : α) : destruct (return a) = sum.inl a := rfl

@[simp] theorem destruct_think : ∀ s : computation α, destruct (think s) = sum.inr s
| ⟨f, al⟩ := rfl

@[simp] theorem destruct_empty : destruct (empty α) = sum.inr (empty α) := rfl

@[simp] theorem head_ret (a : α) : head (return a) = some a := rfl

@[simp] theorem head_think (s : computation α) : head (think s) = none := rfl

@[simp] theorem head_empty : head (empty α) = none := rfl

@[simp] theorem tail_ret (a : α) : tail (return a) = return a := rfl

@[simp] theorem tail_think (s : computation α) : tail (think s) = s :=
by cases s with f al; apply subtype.eq; dsimp [tail, think]; rw [stream.tail_cons]

@[simp] theorem tail_empty : tail (empty α) = empty α := rfl

theorem think_empty : empty α = think (empty α) :=
destruct_eq_think destruct_empty

def cases_on {C : computation α → Sort v} (s : computation α)
  (h1 : ∀ a, C (return a)) (h2 : ∀ s, C (think s)) : C s := begin
  induction H : destruct s with v v,
  { rw destruct_eq_ret H, apply h1 },
  { cases v with a s', rw destruct_eq_think H, apply h2 }
end

def corec.F (f : β → α ⊕ β) : α ⊕ β → option α × (α ⊕ β)
| (sum.inl a) := (some a, sum.inl a)
| (sum.inr b) := (match f b with
  | sum.inl a := some a
  | sum.inr b' := none
  end, f b)

/-- `corec f b` is the corecursor for `computation α` as a coinductive type.
  If `f b = inl a` then `corec f b = return a`, and if `f b = inl b'` then
  `corec f b = think (corec f b')`. -/
def corec (f : β → α ⊕ β) (b : β) : computation α :=
begin
  refine ⟨stream.corec' (corec.F f) (sum.inr b), λn a' h, _⟩,
  rw stream.corec'_eq,
  change stream.corec' (corec.F f) (corec.F f (sum.inr b)).2 n = some a',
  revert h, generalize : sum.inr b = o, revert o,
  induction n with n IH; intro o,
  { change (corec.F f o).1 = some a' → (corec.F f (corec.F f o).2).1 = some a',
    cases o with a b; intro h, { exact h },
    dsimp [corec.F] at h, dsimp [corec.F],
    cases f b with a b', { exact h },
    { contradiction } },
  { rw [stream.corec'_eq (corec.F f) (corec.F f o).2,
        stream.corec'_eq (corec.F f) o],
    exact IH (corec.F f o).2 }
end

/-- left map of `⊕` -/
def lmap (f : α → β) : α ⊕ γ → β ⊕ γ
| (sum.inl a) := sum.inl (f a)
| (sum.inr b) := sum.inr b

/-- right map of `⊕` -/
def rmap (f : β → γ) : α ⊕ β → α ⊕ γ
| (sum.inl a) := sum.inl a
| (sum.inr b) := sum.inr (f b)
attribute [simp] lmap rmap

@[simp] def corec_eq (f : β → α ⊕ β) (b : β) :
  destruct (corec f b) = rmap (corec f) (f b) :=
begin
  dsimp [corec, destruct],
  change stream.corec' (corec.F f) (sum.inr b) 0 with corec.F._match_1 (f b),
  induction h : f b with a b', { refl },
  dsimp [corec.F, destruct],
  apply congr_arg, apply subtype.eq,
  dsimp [corec, tail],
  rw [stream.corec'_eq, stream.tail_cons],
  dsimp [corec.F], rw h
end

section bisim
  variable (R : computation α → computation α → Prop)

  local infix ~ := R

  def bisim_o : α ⊕ computation α → α ⊕ computation α → Prop
  | (sum.inl a) (sum.inl a') := a = a'
  | (sum.inr s) (sum.inr s') := R s s'
  | _           _            := false
  attribute [simp] bisim_o

  def is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → bisim_o R (destruct s₁) (destruct s₂)

  -- If two computations are bisimilar, then they are equal
  theorem eq_of_bisim (bisim : is_bisimulation R) {s₁ s₂} (r : s₁ ~ s₂) : s₁ = s₂ :=
  begin
    apply subtype.eq,
    apply stream.eq_of_bisim (λx y, ∃ s s' : computation α, s.1 = x ∧ s'.1 = y ∧ R s s'),
    dsimp [stream.is_bisimulation],
    intros t₁ t₂ e,
    exact match t₁, t₂, e with ._, ._, ⟨s, s', rfl, rfl, r⟩ :=
      suffices head s = head s' ∧ R (tail s) (tail s'), from
      and.imp id (λr, ⟨tail s, tail s',
        by cases s; refl, by cases s'; refl, r⟩) this,
      begin
        have := bisim r, revert r this,
        apply cases_on s _ _; intros; apply cases_on s' _ _; intros; intros r this,
        { constructor, dsimp at this, rw this, assumption },
        { rw [destruct_ret, destruct_think] at this,
          exact false.elim this },
        { rw [destruct_ret, destruct_think] at this,
          exact false.elim this },
        { simp at this, simp [*] }
      end
    end,
    exact ⟨s₁, s₂, rfl, rfl, r⟩
  end
end bisim

-- It's more of a stretch to use ∈ for this relation, but it
-- asserts that the computation limits to the given value.
protected def mem (a : α) (s : computation α) := some a ∈ s.1

instance : has_mem α (computation α) := ⟨computation.mem⟩

theorem le_stable (s : computation α) {a m n} (h : m ≤ n) :
  s.1 m = some a → s.1 n = some a :=
by {cases s with f al, induction h with n h IH, exacts [id, λ h2, al (IH h2)]}

theorem mem_unique :
   relator.left_unique ((∈) : α → computation α → Prop) :=
λa s b ⟨m, ha⟩ ⟨n, hb⟩, by injection
  (le_stable s (le_max_left m n) ha.symm).symm.trans
  (le_stable s (le_max_right m n) hb.symm)

/-- `terminates s` asserts that the computation `s` eventually terminates with some value. -/
@[class] def terminates (s : computation α) : Prop := ∃ a, a ∈ s

theorem terminates_of_mem {s : computation α} {a : α} : a ∈ s → terminates s :=
exists.intro a

theorem terminates_def (s : computation α) : terminates s ↔ ∃ n, (s.1 n).is_some :=
⟨λ⟨a, n, h⟩, ⟨n, by {dsimp [stream.nth] at h, rw ←h, exact rfl}⟩,
λ⟨n, h⟩, ⟨option.get h, n, (option.eq_some_of_is_some h).symm⟩⟩

theorem ret_mem (a : α) : a ∈ return a :=
exists.intro 0 rfl

theorem eq_of_ret_mem {a a' : α} (h : a' ∈ return a) : a' = a :=
mem_unique h (ret_mem _)

instance ret_terminates (a : α) : terminates (return a) :=
terminates_of_mem (ret_mem _)

theorem think_mem {s : computation α} {a} : a ∈ s → a ∈ think s
| ⟨n, h⟩ := ⟨n+1, h⟩

instance think_terminates (s : computation α) :
  ∀ [terminates s], terminates (think s)
| ⟨a, n, h⟩ := ⟨a, n+1, h⟩

theorem of_think_mem {s : computation α} {a} : a ∈ think s → a ∈ s
| ⟨n, h⟩ := by {cases n with n', contradiction, exact ⟨n', h⟩}

theorem of_think_terminates {s : computation α} :
  terminates (think s) → terminates s
| ⟨a, h⟩ := ⟨a, of_think_mem h⟩

theorem not_mem_empty (a : α) : a ∉ empty α :=
λ ⟨n, h⟩, by clear _fun_match; contradiction

theorem not_terminates_empty : ¬ terminates (empty α) :=
λ ⟨a, h⟩, not_mem_empty a h

theorem eq_empty_of_not_terminates {s} (H : ¬ terminates s) : s = empty α :=
begin
  apply subtype.eq, funext n,
  induction h : s.val n, {refl},
  refine absurd _ H, exact ⟨_, _, h.symm⟩
end

theorem thinkN_mem {s : computation α} {a} : ∀ n, a ∈ thinkN s n ↔ a ∈ s
| 0 := iff.rfl
| (n+1) := iff.trans ⟨of_think_mem, think_mem⟩ (thinkN_mem n)

instance thinkN_terminates (s : computation α) :
  ∀ [terminates s] n, terminates (thinkN s n)
| ⟨a, h⟩ n := ⟨a, (thinkN_mem n).2 h⟩

theorem of_thinkN_terminates (s : computation α) (n) :
  terminates (thinkN s n) → terminates s
| ⟨a, h⟩ := ⟨a, (thinkN_mem _).1 h⟩

/-- `promises s a`, or `s ~> a`, asserts that although the computation `s`
  may not terminate, if it does, then the result is `a`. -/
def promises (s : computation α) (a : α) : Prop := ∀ ⦃a'⦄, a' ∈ s → a = a'

infix ` ~> `:50 := promises

theorem mem_promises {s : computation α} {a : α} : a ∈ s → s ~> a :=
λ h a', mem_unique h

theorem empty_promises (a : α) : empty α ~> a :=
λ a' h, absurd h (not_mem_empty _)

section get
variables (s : computation α) [h : terminates s]
include s h

/-- `length s` gets the number of steps of a terminating computation -/
def length : ℕ := nat.find ((terminates_def _).1 h)

/-- `get s` returns the result of a terminating computation -/
def get : α := option.get (nat.find_spec $ (terminates_def _).1 h)

theorem get_mem : get s ∈ s :=
exists.intro (length s) (option.eq_some_of_is_some _).symm

theorem get_eq_of_mem {a} : a ∈ s → get s = a :=
mem_unique (get_mem _)

theorem mem_of_get_eq {a} : get s = a → a ∈ s :=
by intro h; rw ←h; apply get_mem

@[simp] theorem get_think : get (think s) = get s :=
get_eq_of_mem _ $ let ⟨n, h⟩ := get_mem s in ⟨n+1, h⟩

@[simp] theorem get_thinkN (n) : get (thinkN s n) = get s :=
get_eq_of_mem _ $ (thinkN_mem _).2 (get_mem _)

theorem get_promises : s ~> get s := λ a, get_eq_of_mem _

theorem mem_of_promises {a} (p : s ~> a) : a ∈ s :=
by unfreezeI; cases h with a' h; rw p h; exact h

theorem get_eq_of_promises {a} : s ~> a → get s = a :=
get_eq_of_mem _ ∘ mem_of_promises _

end get

/-- `results s a n` completely characterizes a terminating computation:
  it asserts that `s` terminates after exactly `n` steps, with result `a`. -/
def results (s : computation α) (a : α) (n : ℕ) :=
∃ (h : a ∈ s), @length _ s (terminates_of_mem h) = n

theorem results_of_terminates (s : computation α) [T : terminates s] :
  results s (get s) (length s) :=
⟨get_mem _, rfl⟩

theorem results_of_terminates' (s : computation α) [T : terminates s] {a} (h : a ∈ s) :
  results s a (length s) :=
by rw ←get_eq_of_mem _ h; apply results_of_terminates

theorem results.mem {s : computation α} {a n} : results s a n → a ∈ s
| ⟨m, _⟩ := m

theorem results.terminates {s : computation α} {a n} (h : results s a n) : terminates s :=
terminates_of_mem h.mem

theorem results.length {s : computation α} {a n} [T : terminates s] :
  results s a n → length s = n
| ⟨_, h⟩ := h

theorem results.val_unique {s : computation α} {a b m n}
  (h1 : results s a m) (h2 : results s b n) : a = b :=
mem_unique h1.mem h2.mem

theorem results.len_unique {s : computation α} {a b m n}
  (h1 : results s a m) (h2 : results s b n) : m = n :=
by haveI := h1.terminates; haveI := h2.terminates; rw [←h1.length, h2.length]

theorem exists_results_of_mem {s : computation α} {a} (h : a ∈ s) : ∃ n, results s a n :=
by haveI := terminates_of_mem h; exact ⟨_, results_of_terminates' s h⟩

@[simp] theorem get_ret (a : α) : get (return a) = a :=
get_eq_of_mem _ ⟨0, rfl⟩

@[simp] theorem length_ret (a : α) : length (return a) = 0 :=
let h := computation.ret_terminates a in
nat.eq_zero_of_le_zero $ nat.find_min' ((terminates_def (return a)).1 h) rfl

theorem results_ret (a : α) : results (return a) a 0 :=
⟨_, length_ret _⟩

@[simp] theorem length_think (s : computation α) [h : terminates s] :
  length (think s) = length s + 1 :=
begin
  apply le_antisymm,
  { exact nat.find_min' _ (nat.find_spec ((terminates_def _).1 h)) },
  { have : (option.is_some ((think s).val (length (think s))) : Prop) :=
      nat.find_spec ((terminates_def _).1 s.think_terminates),
    cases length (think s) with n,
    { contradiction },
    { apply nat.succ_le_succ, apply nat.find_min', apply this } }
end

theorem results_think {s : computation α} {a n}
  (h : results s a n) : results (think s) a (n + 1) :=
by haveI := h.terminates; exact ⟨think_mem h.mem, by rw [length_think, h.length]⟩

theorem of_results_think {s : computation α} {a n}
  (h : results (think s) a n) : ∃ m, results s a m ∧ n = m + 1 :=
begin
  haveI := of_think_terminates h.terminates,
  have := results_of_terminates' _ (of_think_mem h.mem),
  exact ⟨_, this, results.len_unique h (results_think this)⟩,
end

@[simp] theorem results_think_iff {s : computation α} {a n} :
  results (think s) a (n + 1) ↔ results s a n :=
⟨λ h, let ⟨n', r, e⟩ := of_results_think h in by injection e with h'; rwa h',
results_think⟩

theorem results_thinkN {s : computation α} {a m} :
  ∀ n, results s a m → results (thinkN s n) a (m + n)
| 0     h := h
| (n+1) h := results_think (results_thinkN n h)

theorem results_thinkN_ret (a : α) (n) : results (thinkN (return a) n) a n :=
by have := results_thinkN n (results_ret a); rwa zero_add at this

@[simp] theorem length_thinkN (s : computation α) [h : terminates s] (n) :
  length (thinkN s n) = length s + n :=
(results_thinkN n (results_of_terminates _)).length

theorem eq_thinkN {s : computation α} {a n} (h : results s a n) :
  s = thinkN (return a) n :=
begin
  revert s,
  induction n with n IH; intro s;
  apply cases_on s (λ a', _) (λ s, _); intro h,
  { rw ←eq_of_ret_mem h.mem, refl },
  { cases of_results_think h with n h, cases h, contradiction },
  { have := h.len_unique (results_ret _), contradiction },
  { rw IH (results_think_iff.1 h), refl }
end

theorem eq_thinkN' (s : computation α) [h : terminates s] :
  s = thinkN (return (get s)) (length s) :=
eq_thinkN (results_of_terminates _)

def mem_rec_on {C : computation α → Sort v} {a s} (M : a ∈ s)
  (h1 : C (return a)) (h2 : ∀ s, C s → C (think s)) : C s :=
begin
  haveI T := terminates_of_mem M,
  rw [eq_thinkN' s, get_eq_of_mem s M],
  generalize : length s = n,
  induction n with n IH, exacts [h1, h2 _ IH]
end

def terminates_rec_on {C : computation α → Sort v} (s) [terminates s]
  (h1 : ∀ a, C (return a)) (h2 : ∀ s, C s → C (think s)) : C s :=
mem_rec_on (get_mem s) (h1 _) h2

/-- Map a function on the result of a computation. -/
def map (f : α → β) : computation α → computation β
| ⟨s, al⟩ := ⟨s.map (λo, option.cases_on o none (some ∘ f)),
λn b, begin
  dsimp [stream.map, stream.nth],
  induction e : s n with a; intro h,
  { contradiction }, { rw [al e, ←h] }
end⟩

def bind.G : β ⊕ computation β → β ⊕ computation α ⊕ computation β
| (sum.inl b)   := sum.inl b
| (sum.inr cb') := sum.inr $ sum.inr cb'

def bind.F (f : α → computation β) :
  computation α ⊕ computation β → β ⊕ computation α ⊕ computation β
| (sum.inl ca) :=
  match destruct ca with
  | sum.inl a := bind.G $ destruct (f a)
  | sum.inr ca' := sum.inr $ sum.inl ca'
  end
| (sum.inr cb) := bind.G $ destruct cb

/-- Compose two computations into a monadic `bind` operation. -/
def bind (c : computation α) (f : α → computation β) : computation β :=
corec (bind.F f) (sum.inl c)

instance : has_bind computation := ⟨@bind⟩

theorem has_bind_eq_bind {β} (c : computation α) (f : α → computation β) :
  c >>= f = bind c f := rfl

/-- Flatten a computation of computations into a single computation. -/
def join (c : computation (computation α)) : computation α := c >>= id

@[simp] theorem map_ret (f : α → β) (a) : map f (return a) = return (f a) := rfl

@[simp] theorem map_think (f : α → β) : ∀ s, map f (think s) = think (map f s)
| ⟨s, al⟩ := by apply subtype.eq; dsimp [think, map]; rw stream.map_cons

@[simp] theorem destruct_map (f : α → β) (s) : destruct (map f s) = lmap f (rmap (map f) (destruct s)) :=
by apply s.cases_on; intro; simp

@[simp] theorem map_id : ∀ (s : computation α), map id s = s
| ⟨f, al⟩ := begin
  apply subtype.eq; simp [map, function.comp],
  have e : (@option.rec α (λ_, option α) none some) = id,
  { funext x, cases x; refl },
  simp [e, stream.map_id]
end

theorem map_comp (f : α → β) (g : β → γ) :
  ∀ (s : computation α), map (g ∘ f) s = map g (map f s)
| ⟨s, al⟩ := begin
  apply subtype.eq; dsimp [map],
  rw stream.map_map,
  apply congr_arg (λ f : _ → option γ, stream.map f s),
  funext x, cases x with x; refl
end

@[simp] theorem ret_bind (a) (f : α → computation β) :
  bind (return a) f = f a :=
begin
  apply eq_of_bisim (λc₁ c₂,
         c₁ = bind (return a) f ∧ c₂ = f a ∨
         c₁ = corec (bind.F f) (sum.inr c₂)),
  { intros c₁ c₂ h,
    exact match c₁, c₂, h with
    | ._, ._, or.inl ⟨rfl, rfl⟩ := begin
      simp [bind, bind.F],
      cases destruct (f a) with b cb; simp [bind.G]
    end
    | ._, c, or.inr rfl := begin
      simp [bind.F],
      cases destruct c with b cb; simp [bind.G]
    end end },
  { simp }
end

@[simp] theorem think_bind (c) (f : α → computation β) :
  bind (think c) f = think (bind c f) :=
destruct_eq_think $ by simp [bind, bind.F]

@[simp] theorem bind_ret (f : α → β) (s) : bind s (return ∘ f) = map f s :=
begin
  apply eq_of_bisim (λc₁ c₂, c₁ = c₂ ∨
         ∃ s, c₁ = bind s (return ∘ f) ∧ c₂ = map f s),
  { intros c₁ c₂ h,
    exact match c₁, c₂, h with
    | _, _, or.inl (eq.refl c) := begin cases destruct c with b cb; simp end
    | _, _, or.inr ⟨s, rfl, rfl⟩ := begin
      apply cases_on s; intros s; simp,
      exact or.inr ⟨s, rfl, rfl⟩
    end end },
  { exact or.inr ⟨s, rfl, rfl⟩ }
end

@[simp] theorem bind_ret' (s : computation α) : bind s return = s :=
by rw bind_ret; change (λ x : α, x) with @id α; rw map_id

@[simp] theorem bind_assoc (s : computation α) (f : α → computation β) (g : β → computation γ) :
  bind (bind s f) g = bind s (λ (x : α), bind (f x) g) :=
begin
  apply eq_of_bisim (λc₁ c₂, c₁ = c₂ ∨
         ∃ s, c₁ = bind (bind s f) g ∧ c₂ = bind s (λ (x : α), bind (f x) g)),
  { intros c₁ c₂ h,
    exact match c₁, c₂, h with
    | _, _, or.inl (eq.refl c) := by cases destruct c with b cb; simp
    | ._, ._, or.inr ⟨s, rfl, rfl⟩ := begin
      apply cases_on s; intros s; simp,
      { generalize : f s = fs,
        apply cases_on fs; intros t; simp,
        { cases destruct (g t) with b cb; simp } },
      { exact or.inr ⟨s, rfl, rfl⟩ }
    end end },
  { exact or.inr ⟨s, rfl, rfl⟩ }
end

theorem results_bind {s : computation α} {f : α → computation β} {a b m n}
  (h1 : results s a m) (h2 : results (f a) b n) : results (bind s f) b (n + m) :=
begin
  have := h1.mem, revert m,
  apply mem_rec_on this _ (λ s IH, _); intros m h1,
  { rw [ret_bind], rw h1.len_unique (results_ret _), exact h2 },
  { rw [think_bind], cases of_results_think h1 with m' h, cases h with h1 e,
    rw e, exact results_think (IH h1) }
end

theorem mem_bind {s : computation α} {f : α → computation β} {a b}
  (h1 : a ∈ s) (h2 : b ∈ f a) : b ∈ bind s f :=
let ⟨m, h1⟩ := exists_results_of_mem h1,
    ⟨n, h2⟩ := exists_results_of_mem h2 in (results_bind h1 h2).mem

instance terminates_bind (s : computation α) (f : α → computation β)
  [terminates s] [terminates (f (get s))] :
  terminates (bind s f) :=
terminates_of_mem (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem get_bind (s : computation α) (f : α → computation β)
  [terminates s] [terminates (f (get s))] :
  get (bind s f) = get (f (get s)) :=
get_eq_of_mem _ (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem length_bind (s : computation α) (f : α → computation β)
  [T1 : terminates s] [T2 : terminates (f (get s))] :
  length (bind s f) = length (f (get s)) + length s :=
(results_of_terminates _).len_unique $
results_bind (results_of_terminates _) (results_of_terminates _)

theorem of_results_bind {s : computation α} {f : α → computation β} {b k} :
  results (bind s f) b k →
  ∃ a m n, results s a m ∧ results (f a) b n ∧ k = n + m :=
begin
  induction k with n IH generalizing s;
  apply cases_on s (λ a, _) (λ s', _); intro e,
  { simp [thinkN] at e, refine ⟨a, _, _, results_ret _, e, rfl⟩ },
  { have := congr_arg head (eq_thinkN e), contradiction },
  { simp at e, refine ⟨a, _, n+1, results_ret _, e, rfl⟩ },
  { simp at e, exact let ⟨a, m, n', h1, h2, e'⟩ := IH e in
    by rw e'; exact ⟨a, m.succ, n', results_think h1, h2, rfl⟩ }
end

theorem exists_of_mem_bind {s : computation α} {f : α → computation β} {b}
  (h : b ∈ bind s f) : ∃ a ∈ s, b ∈ f a :=
let ⟨k, h⟩ := exists_results_of_mem h,
    ⟨a, m, n, h1, h2, e⟩ := of_results_bind h in ⟨a, h1.mem, h2.mem⟩

theorem bind_promises {s : computation α} {f : α → computation β} {a b}
  (h1 : s ~> a) (h2 : f a ~> b) : bind s f ~> b :=
λ b' bB, begin
  rcases exists_of_mem_bind bB with ⟨a', a's, ba'⟩,
  rw ←h1 a's at ba', exact h2 ba'
end

instance : monad computation :=
{ map  := @map,
  pure := @return,
  bind := @bind }

instance : is_lawful_monad computation :=
{ id_map := @map_id,
  bind_pure_comp_eq_map := @bind_ret,
  pure_bind := @ret_bind,
  bind_assoc := @bind_assoc }

theorem has_map_eq_map {β} (f : α → β) (c : computation α) : f <$> c = map f c := rfl

@[simp] theorem return_def (a) : (_root_.return a : computation α) = return a := rfl

@[simp] theorem map_ret' {α β} : ∀ (f : α → β) (a), f <$> return a = return (f a) := map_ret
@[simp] theorem map_think' {α β} : ∀ (f : α → β) s, f <$> think s = think (f <$> s) := map_think

theorem mem_map (f : α → β) {a} {s : computation α} (m : a ∈ s) : f a ∈ map f s :=
by rw ←bind_ret; apply mem_bind m; apply ret_mem

theorem exists_of_mem_map {f : α → β} {b : β} {s : computation α} (h : b ∈ map f s) :
   ∃ a, a ∈ s ∧ f a = b :=
by rw ←bind_ret at h; exact
let ⟨a, as, fb⟩ := exists_of_mem_bind h in ⟨a, as, mem_unique (ret_mem _) fb⟩

instance terminates_map (f : α → β) (s : computation α) [terminates s] : terminates (map f s) :=
by rw ←bind_ret; apply_instance

theorem terminates_map_iff (f : α → β) (s : computation α) :
  terminates (map f s) ↔ terminates s :=
⟨λ⟨a, h⟩, let ⟨b, h1, _⟩ := exists_of_mem_map h in ⟨_, h1⟩, @computation.terminates_map _ _ _ _⟩

-- Parallel computation
/-- `c₁ <|> c₂` calculates `c₁` and `c₂` simultaneously, returning
  the first one that gives a result. -/
def orelse (c₁ c₂ : computation α) : computation α :=
@computation.corec α (computation α × computation α)
  (λ⟨c₁, c₂⟩, match destruct c₁ with
  | sum.inl a := sum.inl a
  | sum.inr c₁' := match destruct c₂ with
    | sum.inl a := sum.inl a
    | sum.inr c₂' := sum.inr (c₁', c₂')
    end
  end) (c₁, c₂)

instance : alternative computation :=
{ orelse := @orelse, failure := @empty, ..computation.monad }

@[simp] theorem ret_orelse (a : α) (c₂ : computation α) :
  (return a <|> c₂) = return a :=
destruct_eq_ret $ by unfold has_orelse.orelse; simp [orelse]

@[simp] theorem orelse_ret (c₁ : computation α) (a : α) :
  (think c₁ <|> return a) = return a :=
destruct_eq_ret $ by unfold has_orelse.orelse; simp [orelse]

@[simp] theorem orelse_think (c₁ c₂ : computation α) :
  (think c₁ <|> think c₂) = think (c₁ <|> c₂) :=
destruct_eq_think $ by unfold has_orelse.orelse; simp [orelse]

@[simp] theorem empty_orelse (c) : (empty α <|> c) = c :=
begin
  apply eq_of_bisim (λc₁ c₂, (empty α <|> c₂) = c₁) _ rfl,
  intros s' s h, rw ←h,
  apply cases_on s; intros s; rw think_empty; simp,
  rw ←think_empty,
end

@[simp] theorem orelse_empty (c : computation α) : (c <|> empty α) = c :=
begin
  apply eq_of_bisim (λc₁ c₂, (c₂ <|> empty α) = c₁) _ rfl,
  intros s' s h, rw ←h,
  apply cases_on s; intros s; rw think_empty; simp,
  rw←think_empty,
end

/-- `c₁ ~ c₂` asserts that `c₁` and `c₂` either both terminate with the same result,
  or both loop forever. -/
def equiv (c₁ c₂ : computation α) : Prop := ∀ a, a ∈ c₁ ↔ a ∈ c₂

infix ~ := equiv

@[refl] theorem equiv.refl (s : computation α) : s ~ s := λ_, iff.rfl

@[symm] theorem equiv.symm {s t : computation α} : s ~ t → t ~ s :=
λh a, (h a).symm

@[trans] theorem equiv.trans {s t u : computation α} : s ~ t → t ~ u → s ~ u :=
λh1 h2 a, (h1 a).trans (h2 a)

theorem equiv.equivalence : equivalence (@equiv α) :=
⟨@equiv.refl _, @equiv.symm _, @equiv.trans _⟩

theorem equiv_of_mem {s t : computation α} {a} (h1 : a ∈ s) (h2 : a ∈ t) : s ~ t :=
λa', ⟨λma, by rw mem_unique ma h1; exact h2,
      λma, by rw mem_unique ma h2; exact h1⟩

theorem terminates_congr {c₁ c₂ : computation α}
  (h : c₁ ~ c₂) : terminates c₁ ↔ terminates c₂ :=
exists_congr h

theorem promises_congr {c₁ c₂ : computation α}
  (h : c₁ ~ c₂) (a) : c₁ ~> a ↔ c₂ ~> a :=
forall_congr (λa', imp_congr (h a') iff.rfl)

theorem get_equiv {c₁ c₂ : computation α} (h : c₁ ~ c₂)
  [terminates c₁] [terminates c₂] : get c₁ = get c₂ :=
get_eq_of_mem _ $ (h _).2 $ get_mem _

theorem think_equiv (s : computation α) : think s ~ s :=
λ a, ⟨of_think_mem, think_mem⟩

theorem thinkN_equiv (s : computation α) (n) : thinkN s n ~ s :=
λ a, thinkN_mem n

theorem bind_congr {s1 s2 : computation α} {f1 f2 : α → computation β}
  (h1 : s1 ~ s2) (h2 : ∀ a, f1 a ~ f2 a) : bind s1 f1 ~ bind s2 f2 :=
λ b, ⟨λh, let ⟨a, ha, hb⟩ := exists_of_mem_bind h in
        mem_bind ((h1 a).1 ha) ((h2 a b).1 hb),
      λh, let ⟨a, ha, hb⟩ := exists_of_mem_bind h in
        mem_bind ((h1 a).2 ha) ((h2 a b).2 hb)⟩

theorem equiv_ret_of_mem {s : computation α} {a} (h : a ∈ s) : s ~ return a :=
equiv_of_mem h (ret_mem _)

/-- `lift_rel R ca cb` is a generalization of `equiv` to relations other than
  equality. It asserts that if `ca` terminates with `a`, then `cb` terminates with
  some `b` such that `R a b`, and if `cb` terminates with `b` then `ca` terminates
  with some `a` such that `R a b`. -/
def lift_rel (R : α → β → Prop) (ca : computation α) (cb : computation β) : Prop :=
(∀ {a}, a ∈ ca → ∃ {b}, b ∈ cb ∧ R a b) ∧
 ∀ {b}, b ∈ cb → ∃ {a}, a ∈ ca ∧ R a b

theorem lift_rel.swap (R : α → β → Prop) (ca : computation α) (cb : computation β) :
  lift_rel (function.swap R) cb ca ↔ lift_rel R ca cb :=
and_comm _ _

theorem lift_eq_iff_equiv (c₁ c₂ : computation α) : lift_rel (=) c₁ c₂ ↔ c₁ ~ c₂ :=
⟨λ⟨h1, h2⟩ a,
  ⟨λ a1, let ⟨b, b2, ab⟩ := h1 a1 in by rwa ab,
   λ a2, let ⟨b, b1, ab⟩ := h2 a2 in by rwa ←ab⟩,
λe, ⟨λ a a1, ⟨a, (e _).1 a1, rfl⟩, λ a a2, ⟨a, (e _).2 a2, rfl⟩⟩⟩

theorem lift_rel.refl (R : α → α → Prop) (H : reflexive R) : reflexive (lift_rel R) :=
λ s, ⟨λ a as, ⟨a, as, H a⟩, λ b bs, ⟨b, bs, H b⟩⟩

theorem lift_rel.symm (R : α → α → Prop) (H : symmetric R) : symmetric (lift_rel R) :=
λ s1 s2 ⟨l, r⟩,
 ⟨λ a a2, let ⟨b, b1, ab⟩ := r a2 in ⟨b, b1, H ab⟩,
  λ a a1, let ⟨b, b2, ab⟩ := l a1 in ⟨b, b2, H ab⟩⟩

theorem lift_rel.trans (R : α → α → Prop) (H : transitive R) : transitive (lift_rel R) :=
λ s1 s2 s3 ⟨l1, r1⟩ ⟨l2, r2⟩,
 ⟨λ a a1, let ⟨b, b2, ab⟩ := l1 a1, ⟨c, c3, bc⟩ := l2 b2 in ⟨c, c3, H ab bc⟩,
  λ c c3, let ⟨b, b2, bc⟩ := r2 c3, ⟨a, a1, ab⟩ := r1 b2 in ⟨a, a1, H ab bc⟩⟩

theorem lift_rel.equiv (R : α → α → Prop) : equivalence R → equivalence (lift_rel R)
| ⟨refl, symm, trans⟩ :=
  ⟨lift_rel.refl R refl, lift_rel.symm R symm, lift_rel.trans R trans⟩

theorem lift_rel.imp {R S : α → β → Prop} (H : ∀ {a b}, R a b → S a b) (s t) :
  lift_rel R s t → lift_rel S s t | ⟨l, r⟩ :=
⟨λ a as, let ⟨b, bt, ab⟩ := l as in ⟨b, bt, H ab⟩,
 λ b bt, let ⟨a, as, ab⟩ := r bt in ⟨a, as, H ab⟩⟩

theorem terminates_of_lift_rel {R : α → β → Prop} {s t} :
 lift_rel R s t → (terminates s ↔ terminates t) | ⟨l, r⟩ :=
⟨λ ⟨a, as⟩, let ⟨b, bt, ab⟩ := l as in ⟨b, bt⟩,
 λ ⟨b, bt⟩, let ⟨a, as, ab⟩ := r bt in ⟨a, as⟩⟩

theorem rel_of_lift_rel {R : α → β → Prop} {ca cb} :
 lift_rel R ca cb → ∀ {a b}, a ∈ ca → b ∈ cb → R a b
| ⟨l, r⟩ a b ma mb :=
  let ⟨b', mb', ab'⟩ := l ma in by rw mem_unique mb mb'; exact ab'

theorem lift_rel_of_mem {R : α → β → Prop} {a b ca cb}
  (ma : a ∈ ca) (mb : b ∈ cb) (ab : R a b) : lift_rel R ca cb :=
⟨λ a' ma', by rw mem_unique ma' ma; exact ⟨b, mb, ab⟩,
 λ b' mb', by rw mem_unique mb' mb; exact ⟨a, ma, ab⟩⟩

theorem exists_of_lift_rel_left {R : α → β → Prop} {ca cb}
  (H : lift_rel R ca cb) {a} (h : a ∈ ca) : ∃ {b}, b ∈ cb ∧ R a b :=
H.left h

theorem exists_of_lift_rel_right {R : α → β → Prop} {ca cb}
  (H : lift_rel R ca cb) {b} (h : b ∈ cb) : ∃ {a}, a ∈ ca ∧ R a b :=
H.right h

theorem lift_rel_def {R : α → β → Prop} {ca cb} : lift_rel R ca cb ↔
  (terminates ca ↔ terminates cb) ∧ ∀ {a b}, a ∈ ca → b ∈ cb → R a b :=
⟨λh, ⟨terminates_of_lift_rel h, λ a b ma mb,
  let ⟨b', mb', ab⟩ := h.left ma in by rwa mem_unique mb mb'⟩,
λ⟨l, r⟩,
 ⟨λ a ma, let ⟨b, mb⟩ := l.1 ⟨_, ma⟩ in ⟨b, mb, r ma mb⟩,
  λ b mb, let ⟨a, ma⟩ := l.2 ⟨_, mb⟩ in ⟨a, ma, r ma mb⟩⟩⟩

theorem lift_rel_bind {δ} (R : α → β → Prop) (S : γ → δ → Prop)
  {s1 : computation α} {s2 : computation β}
  {f1 : α → computation γ} {f2 : β → computation δ}
  (h1 : lift_rel R s1 s2) (h2 : ∀ {a b}, R a b → lift_rel S (f1 a) (f2 b))
  : lift_rel S (bind s1 f1) (bind s2 f2) :=
let ⟨l1, r1⟩ := h1 in
⟨λ c cB,
  let ⟨a, a1, c₁⟩ := exists_of_mem_bind cB,
      ⟨b, b2, ab⟩ := l1 a1,
      ⟨l2, r2⟩ := h2 ab,
      ⟨d, d2, cd⟩ := l2 c₁ in
  ⟨_, mem_bind b2 d2, cd⟩,
λ d dB,
  let ⟨b, b1, d1⟩ := exists_of_mem_bind dB,
      ⟨a, a2, ab⟩ := r1 b1,
      ⟨l2, r2⟩ := h2 ab,
      ⟨c, c₂, cd⟩ := r2 d1 in
  ⟨_, mem_bind a2 c₂, cd⟩⟩

@[simp] theorem lift_rel_return_left (R : α → β → Prop) (a : α) (cb : computation β) :
  lift_rel R (return a) cb ↔ ∃ {b}, b ∈ cb ∧ R a b :=
⟨λ⟨l, r⟩, l (ret_mem _),
 λ⟨b, mb, ab⟩,
  ⟨λ a' ma', by rw eq_of_ret_mem ma'; exact ⟨b, mb, ab⟩,
   λ b' mb', ⟨_, ret_mem _, by rw mem_unique mb' mb; exact ab⟩⟩⟩

@[simp] theorem lift_rel_return_right (R : α → β → Prop) (ca : computation α) (b : β) :
  lift_rel R ca (return b) ↔ ∃ {a}, a ∈ ca ∧ R a b :=
by rw [lift_rel.swap, lift_rel_return_left]

@[simp] theorem lift_rel_return (R : α → β → Prop) (a : α) (b : β) :
  lift_rel R (return a) (return b) ↔ R a b :=
by rw [lift_rel_return_left]; exact
⟨λ⟨b', mb', ab'⟩, by rwa eq_of_ret_mem mb' at ab',
 λab, ⟨_, ret_mem _, ab⟩⟩

@[simp] theorem lift_rel_think_left (R : α → β → Prop) (ca : computation α) (cb : computation β) :
  lift_rel R (think ca) cb ↔ lift_rel R ca cb :=
and_congr (forall_congr $ λb, imp_congr ⟨of_think_mem, think_mem⟩ iff.rfl)
 (forall_congr $ λb, imp_congr iff.rfl $
    exists_congr $ λ b, and_congr ⟨of_think_mem, think_mem⟩ iff.rfl)

@[simp] theorem lift_rel_think_right (R : α → β → Prop) (ca : computation α) (cb : computation β) :
  lift_rel R ca (think cb) ↔ lift_rel R ca cb :=
by rw [←lift_rel.swap R, ←lift_rel.swap R]; apply lift_rel_think_left

theorem lift_rel_mem_cases {R : α → β → Prop} {ca cb}
  (Ha : ∀ a ∈ ca, lift_rel R ca cb)
  (Hb : ∀ b ∈ cb, lift_rel R ca cb) : lift_rel R ca cb :=
⟨λ a ma, (Ha _ ma).left ma, λ b mb, (Hb _ mb).right mb⟩

theorem lift_rel_congr {R : α → β → Prop} {ca ca' : computation α} {cb cb' : computation β}
  (ha : ca ~ ca') (hb : cb ~ cb') : lift_rel R ca cb ↔ lift_rel R ca' cb' :=
and_congr
  (forall_congr $ λ a, imp_congr (ha _) $ exists_congr $ λ b, and_congr (hb _) iff.rfl)
  (forall_congr $ λ b, imp_congr (hb _) $ exists_congr $ λ a, and_congr (ha _) iff.rfl)

theorem lift_rel_map {δ} (R : α → β → Prop) (S : γ → δ → Prop)
  {s1 : computation α} {s2 : computation β}
  {f1 : α → γ} {f2 : β → δ}
  (h1 : lift_rel R s1 s2) (h2 : ∀ {a b}, R a b → S (f1 a) (f2 b))
  : lift_rel S (map f1 s1) (map f2 s2) :=
by rw [←bind_ret, ←bind_ret]; apply lift_rel_bind _ _ h1; simp; exact @h2

theorem map_congr (R : α → α → Prop) (S : β → β → Prop)
  {s1 s2 : computation α} {f : α → β}
  (h1 : s1 ~ s2) : map f s1 ~ map f s2 :=
by rw [←lift_eq_iff_equiv];
   exact lift_rel_map eq _ ((lift_eq_iff_equiv _ _).2 h1) (λ a b, congr_arg _)

def lift_rel_aux (R : α → β → Prop)
  (C : computation α → computation β → Prop) :
  α ⊕ computation α → β ⊕ computation β → Prop
| (sum.inl a)  (sum.inl b)  := R a b
| (sum.inl a)  (sum.inr cb) := ∃ {b}, b ∈ cb ∧ R a b
| (sum.inr ca) (sum.inl b)  := ∃ {a}, a ∈ ca ∧ R a b
| (sum.inr ca) (sum.inr cb) := C ca cb
attribute [simp] lift_rel_aux

@[simp] def lift_rel_aux.ret_left (R : α → β → Prop)
  (C : computation α → computation β → Prop) (a cb) :
  lift_rel_aux R C (sum.inl a) (destruct cb) ↔ ∃ {b}, b ∈ cb ∧ R a b :=
begin
  apply cb.cases_on (λ b, _) (λ cb, _),
  { exact ⟨λ h, ⟨_, ret_mem _, h⟩, λ ⟨b', mb, h⟩,
    by rw [mem_unique (ret_mem _) mb]; exact h⟩ },
  { rw [destruct_think],
    exact ⟨λ ⟨b, h, r⟩, ⟨b, think_mem h, r⟩,
           λ ⟨b, h, r⟩, ⟨b, of_think_mem h, r⟩⟩ }
end

theorem lift_rel_aux.swap (R : α → β → Prop) (C) (a b) :
  lift_rel_aux (function.swap R) (function.swap C) b a = lift_rel_aux R C a b :=
by cases a with a ca; cases b with b cb; simp only [lift_rel_aux]

@[simp] def lift_rel_aux.ret_right (R : α → β → Prop)
  (C : computation α → computation β → Prop) (b ca) :
  lift_rel_aux R C (destruct ca) (sum.inl b) ↔ ∃ {a}, a ∈ ca ∧ R a b :=
by rw [←lift_rel_aux.swap, lift_rel_aux.ret_left]

theorem lift_rel_rec.lem {R : α → β → Prop} (C : computation α → computation β → Prop)
  (H : ∀ {ca cb}, C ca cb → lift_rel_aux R C (destruct ca) (destruct cb))
  (ca cb) (Hc : C ca cb) (a) (ha : a ∈ ca) : lift_rel R ca cb :=
begin
  revert cb, refine mem_rec_on ha _ (λ ca' IH, _);
  intros cb Hc; have h := H Hc,
  { simp at h, simp [h] },
  { have h := H Hc, simp, revert h, apply cb.cases_on (λ b, _) (λ cb', _);
    intro h; simp at h; simp [h], exact IH _ h }
end

theorem lift_rel_rec {R : α → β → Prop} (C : computation α → computation β → Prop)
  (H : ∀ {ca cb}, C ca cb → lift_rel_aux R C (destruct ca) (destruct cb))
  (ca cb) (Hc : C ca cb) : lift_rel R ca cb :=
lift_rel_mem_cases (lift_rel_rec.lem C @H ca cb Hc) (λ b hb,
 (lift_rel.swap _ _ _).2 $
 lift_rel_rec.lem (function.swap C)
   (λ cb ca h, cast (lift_rel_aux.swap _ _ _ _).symm $ H h)
   cb ca Hc b hb)

end computation


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Yury Kudryashov, Neil Strickland
Ported by: Moritz Doll

! This file was ported from Lean 3 source module algebra.ring.basic
! leanprover-community/mathlib commit 2ed7e4aec72395b6a7c3ac4ac7873a7a43ead17c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Ring.Defs
import Mathlib.Algebra.Hom.Group
import Mathlib.Algebra.Opposites

/-!
# Semirings and rings

This file gives lemmas about semirings, rings and domains.
This is analogous to `Algebra.Group.Basic`,
the difference being that the former is about `+` and `*` separately, while
the present file is about their interaction.

For the definitions of semirings and rings see `Algebra.Ring.Defs`.
-/

open Function

namespace AddHom

/-- Left multiplication by an element of a type with distributive multiplication is an `AddHom`. -/
@[simps (config := { fullyApplied := false })]
def mulLeft [Distrib R] (r : R) : AddHom R R :=
  ⟨(· * ·) r, mul_add r⟩
#align add_hom.mul_left AddHom.mulLeft
#align add_hom.mul_left_apply AddHom.mulLeft_apply

/-- Left multiplication by an element of a type with distributive multiplication is an `AddHom`. -/
@[simps (config := { fullyApplied := false })]
def mulRight [Distrib R] (r : R) : AddHom R R :=
  ⟨fun a => a * r, fun _ _ => add_mul _ _ r⟩
#align add_hom.mul_right AddHom.mulRight
#align add_hom.mul_right_apply AddHom.mulRight_apply

end AddHom

section AddHomClass

variable {F : Type _} [NonAssocSemiring α] [NonAssocSemiring β] [AddHomClass F α β]

set_option linter.deprecated false in
/-- Additive homomorphisms preserve `bit0`. -/
@[deprecated, simp]
theorem map_bit0 (f : F) (a : α) : (f (bit0 a) : β) = bit0 (f a) :=
  map_add _ _ _
#align map_bit0 map_bit0

end AddHomClass

namespace AddMonoidHom

/-- Left multiplication by an element of a (semi)ring is an `AddMonoidHom` -/
def mulLeft [NonUnitalNonAssocSemiring R] (r : R) :
    R →+ R where
  toFun := (· * ·) r
  map_zero' := mul_zero r
  map_add' := mul_add r
#align add_monoid_hom.mul_left AddMonoidHom.mulLeft

@[simp]
theorem coe_mul_left [NonUnitalNonAssocSemiring R] (r : R) :
    (mulLeft r : R → R) = HMul.hMul r :=
  rfl
#align add_monoid_hom.coe_mul_left AddMonoidHom.coe_mul_left

/-- Right multiplication by an element of a (semi)ring is an `AddMonoidHom` -/
def mulRight [NonUnitalNonAssocSemiring R] (r : R) :
    R →+ R where
  toFun a := a * r
  map_zero' := zero_mul r
  map_add' _ _ := add_mul _ _ r
#align add_monoid_hom.mul_right AddMonoidHom.mulRight

@[simp]
theorem coe_mul_right [NonUnitalNonAssocSemiring R] (r : R) :
    (mulRight r) = (· * r) :=
  rfl
#align add_monoid_hom.coe_mul_right AddMonoidHom.coe_mul_right

theorem mul_right_apply [NonUnitalNonAssocSemiring R] (a r : R) :
    mulRight r a = a * r :=
  rfl
#align add_monoid_hom.mul_right_apply AddMonoidHom.mul_right_apply

end AddMonoidHom

section HasDistribNeg

section Mul

variable [Mul α] [HasDistribNeg α]

open MulOpposite

instance hasDistribNeg : HasDistribNeg αᵐᵒᵖ :=
  { MulOpposite.involutiveNeg _ with
    neg_mul := fun _ _ => unop_injective <| mul_neg _ _,
    mul_neg := fun _ _ => unop_injective <| neg_mul _ _ }

end Mul

section Group

variable [Group α] [HasDistribNeg α]

@[simp]
theorem inv_neg' (a : α) : (-a)⁻¹ = -a⁻¹ := by
  rw [eq_comm, eq_inv_iff_mul_eq_one, neg_mul, mul_neg, neg_neg, mul_left_inv]
#align inv_neg' inv_neg'

end Group

end HasDistribNeg

section NonUnitalCommRing

variable [NonUnitalCommRing α] {a b c : α}

attribute [local simp] add_assoc add_comm add_left_comm mul_comm

/-- Vieta's formula for a quadratic equation, relating the coefficients of the polynomial with
  its roots. This particular version states that if we have a root `x` of a monic quadratic
  polynomial, then there is another root `y` such that `x + y` is negative the `a_1` coefficient
  and `x * y` is the `a_0` coefficient. -/
theorem vieta_formula_quadratic {b c x : α} (h : x * x - b * x + c = 0) :
    ∃ y : α, y * y - b * y + c = 0 ∧ x + y = b ∧ x * y = c := by
  have : c = x * (b - x) := (eq_neg_of_add_eq_zero_right h).trans (by simp [mul_sub, mul_comm])
  refine' ⟨b - x, _, by simp, by rw [this]⟩
  rw [this, sub_add, ← sub_mul, sub_self]
set_option linter.uppercaseLean3 false in
#align Vieta_formula_quadratic vieta_formula_quadratic

end NonUnitalCommRing

theorem succ_ne_self [NonAssocRing α] [Nontrivial α] (a : α) : a + 1 ≠ a := fun h =>
  one_ne_zero ((add_right_inj a).mp (by simp [h]))
#align succ_ne_self succ_ne_self

theorem pred_ne_self [NonAssocRing α] [Nontrivial α] (a : α) : a - 1 ≠ a := fun h ↦
  one_ne_zero (neg_injective ((add_right_inj a).mp (by simp [←sub_eq_add_neg, h])))
#align pred_ne_self pred_ne_self

section NoZeroDivisors

variable (α)

lemma IsLeftCancelMulZero.to_noZeroDivisors [Ring α] [IsLeftCancelMulZero α] :
    NoZeroDivisors α :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := @fun x y h ↦ by
    by_cases hx : x = 0
    { left
      exact hx }
    { right
      rw [← sub_zero (x * y), ← mul_zero x, ← mul_sub] at h
      have := (IsLeftCancelMulZero.mul_left_cancel_of_ne_zero) hx h
      rwa [sub_zero] at this } }
#align is_left_cancel_mul_zero.to_no_zero_divisors IsLeftCancelMulZero.to_noZeroDivisors

lemma IsRightCancelMulZero.to_noZeroDivisors [Ring α] [IsRightCancelMulZero α] :
    NoZeroDivisors α :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := @fun x y h ↦ by
    by_cases hy : y = 0
    { right
      exact hy }
    { left
      rw [← sub_zero (x * y), ← zero_mul y, ← sub_mul] at h
      have := (IsRightCancelMulZero.mul_right_cancel_of_ne_zero) hy h
      rwa [sub_zero] at this } }
#align is_right_cancel_mul_zero.to_no_zero_divisors IsRightCancelMulZero.to_noZeroDivisors

instance (priority := 100) NoZeroDivisors.to_isCancelMulZero [Ring α] [NoZeroDivisors α] :
    IsCancelMulZero α :=
{ mul_left_cancel_of_ne_zero := fun ha h ↦ by
    rw [← sub_eq_zero, ← mul_sub] at h
    exact sub_eq_zero.1 ((eq_zero_or_eq_zero_of_mul_eq_zero h).resolve_left ha)
  mul_right_cancel_of_ne_zero := fun hb h ↦ by
    rw [← sub_eq_zero, ← sub_mul] at h
    exact sub_eq_zero.1 ((eq_zero_or_eq_zero_of_mul_eq_zero h).resolve_right hb) }
#align no_zero_divisors.to_is_cancel_mul_zero NoZeroDivisors.to_isCancelMulZero

lemma NoZeroDivisors.to_isDomain [Ring α] [h : Nontrivial α] [NoZeroDivisors α] :
  IsDomain α :=
{ NoZeroDivisors.to_isCancelMulZero α, h with .. }
#align no_zero_divisors.to_is_domain NoZeroDivisors.to_isDomain

instance (priority := 100) IsDomain.to_noZeroDivisors [Ring α] [IsDomain α] :
    NoZeroDivisors α :=
IsRightCancelMulZero.to_noZeroDivisors α
#align is_domain.to_no_zero_divisors IsDomain.to_noZeroDivisors

end NoZeroDivisors


/-
Copyright (c) 2022 Alex J. Best, Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex J. Best, Yaël Dillies

! This file was ported from Lean 3 source module algebra.order.hom.ring
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Archimedean
import Mathlib.Algebra.Order.Hom.Monoid
import Mathlib.Algebra.Order.Ring.Defs
import Mathlib.Algebra.Ring.Equiv
import Mathlib.Tactic.ByContra
import Mathlib.Tactic.SwapVar
import Mathlib.Tactic.WLOG

/-!
# Ordered ring homomorphisms

Homomorphisms between ordered (semi)rings that respect the ordering.

## Main definitions

* `OrderRingHom` : Monotone semiring homomorphisms.
* `OrderRingIso` : Monotone semiring isomorphisms.

## Notation

* `→+*o`: Ordered ring homomorphisms.
* `≃+*o`: Ordered ring isomorphisms.

## Tags

ordered ring homomorphism, order homomorphism
-/

open Function

variable {F α β γ δ : Type _}

/-- `OrderRingHom α β` is the type of monotone semiring homomorphisms from `α` to `β`.

When possible, instead of parametrizing results over `(f : OrderRingHom α β)`,
you should parametrize over `(F : Type*) [OrderRingHomClass F α β] (f : F)`.

When you extend this structure, make sure to extend `OrderRingHomClass`. -/
structure OrderRingHom (α β : Type _) [NonAssocSemiring α] [Preorder α] [NonAssocSemiring β]
  [Preorder β] extends α →+* β where
  /-- The proposition that the function preserves the order. -/
  monotone' : Monotone toFun
#align order_ring_hom OrderRingHom

/-- Reinterpret an ordered ring homomorphism as a ring homomorphism. -/
add_decl_doc OrderRingHom.toRingHom

@[inherit_doc]
infixl:25 " →+*o " => OrderRingHom

/- Porting note: Needed to reorder instance arguments below:
`[Mul α] [Add α] [LE α] [Mul β] [Add β] [LE β]`
to
`[Mul α] [Mul β] [Add α] [Add β] [LE α] [LE β]`
otherwise the [refl] attribute on `OrderRingIso.refl` complains.
TODO: change back when `refl` attribute is fixed, github issue #2505 -/

/-- `OrderRingHom α β` is the type of order-preserving semiring isomorphisms between `α` and `β`.

When possible, instead of parametrizing results over `(f : OrderRingIso α β)`,
you should parametrize over `(F : Type*) [OrderRingIsoClass F α β] (f : F)`.

When you extend this structure, make sure to extend `OrderRingIsoClass`. -/
structure OrderRingIso (α β : Type _) [Mul α] [Mul β] [Add α] [Add β] [LE α] [LE β] extends
  α ≃+* β where
  /-- The proposition that the function preserves the order bijectively. -/
  map_le_map_iff' {a b : α} : toFun a ≤ toFun b ↔ a ≤ b
#align order_ring_iso OrderRingIso

@[inherit_doc]
infixl:25 " ≃+*o " => OrderRingIso

/-- `OrderRingHomClass F α β` states that `F` is a type of ordered semiring homomorphisms.
You should extend this typeclass when you extend `OrderRingHom`. -/
class OrderRingHomClass (F : Type _) (α β : outParam <| Type _) [NonAssocSemiring α] [Preorder α]
  [NonAssocSemiring β] [Preorder β] extends RingHomClass F α β where
  /-- The proposition that the function preserves the order. -/
  monotone (f : F) : Monotone f
#align order_ring_hom_class OrderRingHomClass

/-- `OrderRingIsoClass F α β` states that `F` is a type of ordered semiring isomorphisms.
You should extend this class when you extend `OrderRingIso`. -/
class OrderRingIsoClass (F : Type _) (α β : outParam (Type _)) [Mul α] [Add α] [LE α] [Mul β]
  [Add β] [LE β] extends RingEquivClass F α β where
  /-- The proposition that the function preserves the order bijectively. -/
  map_le_map_iff (f : F) {a b : α} : f a ≤ f b ↔ a ≤ b
#align order_ring_iso_class OrderRingIsoClass

-- See note [lower priority instance]
instance (priority := 100) OrderRingHomClass.toOrderAddMonoidHomClass {_ :NonAssocSemiring α}
    {_ : Preorder α} {_ :NonAssocSemiring β} {_ : Preorder β} [OrderRingHomClass F α β] :
    OrderAddMonoidHomClass F α β :=
  { ‹OrderRingHomClass F α β› with }
#align
  order_ring_hom_class.to_order_add_monoid_hom_class
  OrderRingHomClass.toOrderAddMonoidHomClass

-- See note [lower priority instance]
instance (priority := 100) OrderRingHomClass.toOrderMonoidWithZeroHomClass {_ : NonAssocSemiring α}
    {_ : Preorder α} {_ : NonAssocSemiring β} {_ : Preorder β} [OrderRingHomClass F α β] :
    OrderMonoidWithZeroHomClass F α β :=
  { ‹OrderRingHomClass F α β› with }
#align
  order_ring_hom_class.to_order_monoid_with_zero_hom_class
  OrderRingHomClass.toOrderMonoidWithZeroHomClass

-- See note [lower instance priority]
-- porting note: replaced []'s with {_ : }'s to prevent dangerous instances
instance (priority := 100) OrderRingIsoClass.toOrderIsoClass {_ : Mul α}  {_ : Add α}  {_ :LE α}
  {_ :Mul β} {_ :Add β}  {_ : LE β} [OrderRingIsoClass F α β] : OrderIsoClass F α β :=
  { ‹OrderRingIsoClass F α β› with }
#align order_ring_iso_class.to_order_iso_class OrderRingIsoClass.toOrderIsoClass

-- See note [lower instance priority]
instance (priority := 100) OrderRingIsoClass.toOrderRingHomClass {_ :NonAssocSemiring α}
  {_ : Preorder α} {_ :NonAssocSemiring β} {_ : Preorder β} [OrderRingIsoClass F α β] :
    OrderRingHomClass F α β :=
  { monotone := fun f _ _ => (map_le_map_iff f).2
    -- porting note: used to be the following which times out
    --‹OrderRingIsoClass F α β› with monotone := fun f => OrderHomClass.mono f
    }
#align order_ring_iso_class.to_order_ring_hom_class OrderRingIsoClass.toOrderRingHomClass

-- porting note: OrderRingHomClass.toOrderRingHom is new
/-- Turn an element of a type `F` satisfying `OrderRingHomClass F α β` into an actual
`OrderRingHom`. This is declared as the default coercion from `F` to `α →+*o β`. -/
@[coe]
def OrderRingHomClass.toOrderRingHom [NonAssocSemiring α] [Preorder α] [NonAssocSemiring β]
    [Preorder β] [OrderRingHomClass F α β]  (f : F) : α →+*o β :=
{ (f : α →+* β) with monotone' := monotone f}

/-- Any type satisfying `OrderRingHomClass` can be cast into `OrderRingHom` via
  `OrderRingHomClass.toOrderRingHom`. -/
instance [NonAssocSemiring α] [Preorder α] [NonAssocSemiring β] [Preorder β]
    [OrderRingHomClass F α β] : CoeTC F (α →+*o β) :=
  ⟨OrderRingHomClass.toOrderRingHom⟩

-- porting note: OrderRingIsoClass.toOrderRingIso is new
/-- Turn an element of a type `F` satisfying `OrderRingIsoClass F α β` into an actual
`OrderRingIso`. This is declared as the default coercion from `F` to `α ≃+*o β`. -/
@[coe]
def OrderRingIsoClass.toOrderRingIso [Mul α] [Add α] [LE α] [Mul β] [Add β] [LE β]
    [OrderRingIsoClass F α β] (f : F) : α ≃+*o β :=
{ (f : α ≃+* β) with map_le_map_iff' := map_le_map_iff f}

/-- Any type satisfying `OrderRingIsoClass` can be cast into `OrderRingIso` via
  `OrderRingIsoClass.toOrderRingIso`. -/
instance [Mul α] [Add α] [LE α] [Mul β] [Add β] [LE β] [OrderRingIsoClass F α β] :
    CoeTC F (α ≃+*o β) :=
  ⟨OrderRingIsoClass.toOrderRingIso⟩

/-! ### Ordered ring homomorphisms -/

namespace OrderRingHom

variable [NonAssocSemiring α] [Preorder α]

section Preorder

variable [NonAssocSemiring β] [Preorder β] [NonAssocSemiring γ] [Preorder γ] [NonAssocSemiring δ]
  [Preorder δ]

/-- Reinterpret an ordered ring homomorphism as an ordered additive monoid homomorphism. -/
def toOrderAddMonoidHom (f : α →+*o β) : α →+o β :=
  { f with }
#align order_ring_hom.to_order_add_monoid_hom OrderRingHom.toOrderAddMonoidHom

/-- Reinterpret an ordered ring homomorphism as an order homomorphism. -/
def toOrderMonoidWithZeroHom (f : α →+*o β) : α →*₀o β :=
  { f with }
#align order_ring_hom.to_order_monoid_with_zero_hom OrderRingHom.toOrderMonoidWithZeroHom

instance : OrderRingHomClass (α →+*o β) α β
    where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨_, _⟩, _⟩ := f; obtain ⟨⟨_, _⟩, _⟩ := g; congr
    -- porting note: needed to add the following line
    exact MonoidHom.monoidHomClass.coe_injective' h
  map_mul f := f.map_mul'
  map_one f := f.map_one'
  map_add f := f.map_add'
  map_zero f := f.map_zero'
  monotone f := f.monotone'

-- porting note: These helper instances are unhelpful in Lean 4, so omitting:
-- /-- Helper instance for when there's too many metavariables to apply `FunLike.has_coe_to_fun`
-- directly. -/
-- instance : CoeFun (α →+*o β) fun _ => α → β :=
--   ⟨fun f => f.toFun⟩

theorem toFun_eq_coe (f : α →+*o β) : f.toFun = f :=
  rfl
#align order_ring_hom.to_fun_eq_coe OrderRingHom.toFun_eq_coe

@[ext]
theorem ext {f g : α →+*o β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align order_ring_hom.ext OrderRingHom.ext

@[simp]
theorem toRingHom_eq_coe (f : α →+*o β) : f.toRingHom = f :=
  RingHom.ext fun _ => rfl
#align order_ring_hom.to_ring_hom_eq_coe OrderRingHom.toRingHom_eq_coe

@[simp]
theorem toOrderAddMonoidHom_eq_coe (f : α →+*o β) : f.toOrderAddMonoidHom = f :=
  rfl
#align order_ring_hom.to_order_add_monoid_hom_eq_coe OrderRingHom.toOrderAddMonoidHom_eq_coe

@[simp]
theorem toOrderMonoidWithZeroHom_eq_coe (f : α →+*o β) : f.toOrderMonoidWithZeroHom = f :=
  rfl
#align order_ring_hom.to_order_monoid_with_zero_hom_eq_coe OrderRingHom.toOrderMonoidWithZeroHom

@[simp]
theorem coe_coe_ringHom (f : α →+*o β) : ⇑(f : α →+* β) = f :=
  rfl
#align order_ring_hom.coe_coe_ring_hom OrderRingHom.coe_coe_ringHom

@[simp]
theorem coe_coe_orderAddMonoidHom (f : α →+*o β) : ⇑(f : α →+o β) = f :=
  rfl
#align order_ring_hom.coe_coe_order_add_monoid_hom OrderRingHom.coe_coe_orderAddMonoidHom

@[simp]
theorem coe_coe_orderMonoidWithZeroHom (f : α →+*o β) : ⇑(f : α →*₀o β) = f :=
  rfl
#align
  order_ring_hom.coe_coe_order_monoid_with_zero_hom OrderRingHom.coe_coe_orderMonoidWithZeroHom

@[norm_cast]
theorem coe_ringHom_apply (f : α →+*o β) (a : α) : (f : α →+* β) a = f a :=
  rfl
#align order_ring_hom.coe_ring_hom_apply OrderRingHom.coe_ringHom_apply

@[norm_cast]
theorem coe_orderAddMonoidHom_apply (f : α →+*o β) (a : α) : (f : α →+o β) a = f a :=
  rfl
#align order_ring_hom.coe_order_add_monoid_hom_apply OrderRingHom.coe_orderAddMonoidHom_apply

@[norm_cast]
theorem coe_orderMonoidWithZeroHom_apply (f : α →+*o β) (a : α) : (f : α →*₀o β) a = f a :=
  rfl
#align
  order_ring_hom.coe_order_monoid_with_zero_hom_apply
  OrderRingHom.coe_orderMonoidWithZeroHom_apply

/-- Copy of a `OrderRingHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : α →+*o β) (f' : α → β) (h : f' = f) : α →+*o β :=
  { f.toRingHom.copy f' h, f.toOrderAddMonoidHom.copy f' h with }
#align order_ring_hom.copy OrderRingHom.copy

@[simp]

theorem copy_eq (f : α →+*o β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align order_ring_hom.copy_eq OrderRingHom.copy_eq

variable (α)

/-- The identity as an ordered ring homomorphism. -/
protected def id : α →+*o α :=
  { RingHom.id _, OrderHom.id with }
#align order_ring_hom.id OrderRingHom.id

instance : Inhabited (α →+*o α) :=
  ⟨OrderRingHom.id α⟩

@[simp]
theorem coe_id : ⇑(OrderRingHom.id α) = id :=
  rfl
#align order_ring_hom.coe_id OrderRingHom.coe_id

variable {α}

@[simp]
theorem id_apply (a : α) : OrderRingHom.id α a = a :=
  rfl
#align order_ring_hom.id_apply OrderRingHom.id_apply

@[simp]
theorem coe_RingHom_id : (OrderRingHom.id α : α →+* α) = RingHom.id α :=
  rfl
#align order_ring_hom.coe_ring_hom_id OrderRingHom.coe_RingHom_id

@[simp]
theorem coe_OrderAddMonoidHom_id : (OrderRingHom.id α : α →+o α) = OrderAddMonoidHom.id α :=
  rfl
#align order_ring_hom.coe_order_add_monoid_hom_id OrderRingHom.coe_OrderAddMonoidHom_id

@[simp]
theorem coe_OrderMonoidWithZeroHom_id :
    (OrderRingHom.id α : α →*₀o α) = OrderMonoidWithZeroHom.id α :=
  rfl
#align
  order_ring_hom.coe_order_monoid_with_zero_hom_id OrderRingHom.coe_OrderMonoidWithZeroHom_id

/-- Composition of two `OrderRingHom`s as an `OrderRingHom`. -/
protected def comp (f : β →+*o γ) (g : α →+*o β) : α →+*o γ :=
  { f.toRingHom.comp g.toRingHom, f.toOrderAddMonoidHom.comp g.toOrderAddMonoidHom with }
#align order_ring_hom.comp OrderRingHom.comp

@[simp]
theorem coe_comp (f : β →+*o γ) (g : α →+*o β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align order_ring_hom.coe_comp OrderRingHom.coe_comp

@[simp]
theorem comp_apply (f : β →+*o γ) (g : α →+*o β) (a : α) : f.comp g a = f (g a) :=
  rfl
#align order_ring_hom.comp_apply OrderRingHom.comp_apply

theorem comp_assoc (f : γ →+*o δ) (g : β →+*o γ) (h : α →+*o β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align order_ring_hom.comp_assoc OrderRingHom.comp_assoc

@[simp]
theorem comp_id (f : α →+*o β) : f.comp (OrderRingHom.id α) = f :=
  rfl
#align order_ring_hom.comp_id OrderRingHom.comp_id

@[simp]
theorem id_comp (f : α →+*o β) : (OrderRingHom.id β).comp f = f :=
  rfl
#align order_ring_hom.id_comp OrderRingHom.id_comp

theorem cancel_right {f₁ f₂ : β →+*o γ} {g : α →+*o β} (hg : Surjective g) :
    f₁.comp g = f₂.comp g ↔ f₁ = f₂ :=
  ⟨fun h => ext <| hg.forall.2 <| FunLike.ext_iff.1 h, fun h => by rw [h]⟩
#align order_ring_hom.cancel_right OrderRingHom.cancel_right
theorem cancel_left {f : β →+*o γ} {g₁ g₂ : α →+*o β} (hf : Injective f) :
    f.comp g₁ = f.comp g₂ ↔ g₁ = g₂ :=
  ⟨fun h => ext fun a => hf <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align order_ring_hom.cancel_left OrderRingHom.cancel_left

end Preorder

variable [NonAssocSemiring β]

instance [Preorder β] : Preorder (OrderRingHom α β) :=
  Preorder.lift ((⇑) : _ → α → β)

instance [PartialOrder β] : PartialOrder (OrderRingHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

end OrderRingHom

/-! ### Ordered ring isomorphisms -/

namespace OrderRingIso

section LE

variable [Mul α] [Add α] [LE α] [Mul β] [Add β] [LE β] [Mul γ] [Add γ] [LE γ] [Mul δ] [Add δ] [LE δ]

/-- Reinterpret an ordered ring isomorphism as an order isomorphism. -/
-- Porting note: Added @[coe] attribute
@[coe]
def toOrderIso (f : α ≃+*o β) : α ≃o β :=
  ⟨f.toRingEquiv.toEquiv, f.map_le_map_iff'⟩
#align order_ring_iso.to_order_iso OrderRingIso.toOrderIso

instance : OrderRingIsoClass (α ≃+*o β) α β
    where
  coe f := f.toFun
  inv f := f.invFun
  coe_injective' f g h₁ h₂ := by
    obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f
    obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g
    congr
  map_add f := f.map_add'
  map_mul f := f.map_mul'
  map_le_map_iff f _ _ := f.map_le_map_iff'
  left_inv f := f.left_inv
  right_inv f := f.right_inv

-- porting note: These helper instances are unhelpful in Lean 4, so omitting:
/-- Helper instance for when there's too many metavariables to apply `FunLike.has_coe_to_fun`
directly. -/
-- instance : CoeFun (α ≃+*o β) fun _ => α → β :=
--   FunLike.has_coe_to_fun

theorem toFun_eq_coe (f : α ≃+*o β) : f.toFun = f :=
  rfl
#align order_ring_iso.to_fun_eq_coe OrderRingIso.toFun_eq_coe

@[ext]
theorem ext {f g : α ≃+*o β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align order_ring_iso.ext OrderRingIso.ext

@[simp]
theorem coe_mk (e : α ≃+* β) (h) : ⇑(⟨e, h⟩ : α ≃+*o β) = e :=
  rfl
#align order_ring_iso.coe_mk OrderRingIso.coe_mk

@[simp]
theorem mk_coe (e : α ≃+*o β) (h) : (⟨e, h⟩ : α ≃+*o β) = e :=
  ext fun _ => rfl
#align order_ring_iso.mk_coe OrderRingIso.mk_coe

@[simp]
theorem toRingEquiv_eq_coe (f : α ≃+*o β) : f.toRingEquiv = f :=
  RingEquiv.ext fun _ => rfl
#align order_ring_iso.to_ring_equiv_eq_coe OrderRingIso.toRingEquiv_eq_coe

@[simp]
theorem toOrderIso_eq_coe (f : α ≃+*o β) : f.toOrderIso = f :=
  OrderIso.ext rfl
#align order_ring_iso.to_order_iso_eq_coe OrderRingIso.toOrderIso_eq_coe

@[simp, norm_cast]
theorem coe_toRingEquiv (f : α ≃+*o β) : ⇑(f : α ≃+* β) = f :=
  rfl
#align order_ring_iso.coe_to_ring_equiv OrderRingIso.coe_toRingEquiv

-- Porting note: needed to add FunLike.coe on the lhs, bad Equiv coercion otherwise
@[simp, norm_cast]
theorem coe_toOrderIso (f : α ≃+*o β) : FunLike.coe (f : α ≃o β) = f :=
  rfl
#align order_ring_iso.coe_to_order_iso OrderRingIso.coe_toOrderIso

variable (α)

/-- The identity map as an ordered ring isomorphism. -/
@[refl]
protected def refl : α ≃+*o α :=
  ⟨RingEquiv.refl α, Iff.rfl⟩
#align order_ring_iso.refl OrderRingIso.refl

instance : Inhabited (α ≃+*o α) :=
  ⟨OrderRingIso.refl α⟩

@[simp]
theorem refl_apply (x : α) : OrderRingIso.refl α x = x := by
  rfl
#align order_ring_iso.refl_apply OrderRingIso.refl_apply

@[simp]
theorem coe_ringEquiv_refl : (OrderRingIso.refl α : α ≃+* α) = RingEquiv.refl α :=
  rfl
#align order_ring_iso.coe_ring_equiv_refl OrderRingIso.coe_ringEquiv_refl

@[simp]
theorem coe_orderIso_refl : (OrderRingIso.refl α : α ≃o α) = OrderIso.refl α :=
  rfl
#align order_ring_iso.coe_order_iso_refl OrderRingIso.coe_orderIso_refl

variable {α}

/-- The inverse of an ordered ring isomorphism as an ordered ring isomorphism. -/
@[symm]
protected def symm (e : α ≃+*o β) : β ≃+*o α :=
  ⟨e.toRingEquiv.symm, by
    intro a b
    erw [← map_le_map_iff e, e.1.apply_symm_apply, e.1.apply_symm_apply]⟩
#align order_ring_iso.symm OrderRingIso.symm

/-- See Note [custom simps projection] -/
def Simps.symm_apply (e : α ≃+*o β) : β → α :=
  e.symm
#align order_ring_iso.simps.symm_apply OrderRingIso.Simps.symm_apply

@[simp]
theorem symm_symm (e : α ≃+*o β) : e.symm.symm = e :=
  ext fun _ => rfl
#align order_ring_iso.symm_symm OrderRingIso.symm_symm

/-- Composition of `OrderRingIso`s as an `OrderRingIso`. -/
@[trans]
protected def trans (f : α ≃+*o β) (g : β ≃+*o γ) : α ≃+*o γ :=
  ⟨f.toRingEquiv.trans g.toRingEquiv, (map_le_map_iff g).trans (map_le_map_iff f)⟩
#align order_ring_iso.trans OrderRingIso.trans

/- Porting note: Used to be generated by [simps] on `trans`, but the lhs of this simplifies under
simp, so problem with the simpNF linter. Removed [simps] attribute and added aux version below. -/
theorem trans_toRingEquiv (f : α ≃+*o β) (g : β ≃+*o γ):
    (OrderRingIso.trans f g).toRingEquiv = RingEquiv.trans f.toRingEquiv g.toRingEquiv :=
  rfl

@[simp]
theorem trans_toRingEquiv_aux (f : α ≃+*o β) (g : β ≃+*o γ):
    RingEquivClass.toRingEquiv (OrderRingIso.trans f g)
      = RingEquiv.trans f.toRingEquiv g.toRingEquiv :=
  rfl

@[simp]
theorem trans_apply (f : α ≃+*o β) (g : β ≃+*o γ) (a : α) : f.trans g a = g (f a) :=
  rfl
#align order_ring_iso.trans_apply OrderRingIso.trans_apply

@[simp]
theorem self_trans_symm (e : α ≃+*o β) : e.trans e.symm = OrderRingIso.refl α :=
  ext e.left_inv
#align order_ring_iso.self_trans_symm OrderRingIso.self_trans_symm

@[simp]
theorem symm_trans_self (e : α ≃+*o β) : e.symm.trans e = OrderRingIso.refl β :=
  ext e.right_inv
#align order_ring_iso.symm_trans_self OrderRingIso.symm_trans_self

theorem symm_bijective : Bijective (OrderRingIso.symm : α ≃+*o β → β ≃+*o α) :=
  ⟨fun f g h => f.symm_symm.symm.trans <| (congr_arg OrderRingIso.symm h).trans g.symm_symm,
    fun f => ⟨f.symm, f.symm_symm⟩⟩
#align order_ring_iso.symm_bijective OrderRingIso.symm_bijective

end LE

section NonAssocSemiring

variable [NonAssocSemiring α] [Preorder α] [NonAssocSemiring β] [Preorder β] [NonAssocSemiring γ]
  [Preorder γ]

/-- Reinterpret an ordered ring isomorphism as an ordered ring homomorphism. -/
def toOrderRingHom (f : α ≃+*o β) : α →+*o β :=
  ⟨f.toRingEquiv.toRingHom, fun _ _ => (map_le_map_iff f).2⟩
#align order_ring_iso.to_order_ring_hom OrderRingIso.toOrderRingHom

@[simp]
theorem toOrderRingHom_eq_coe (f : α ≃+*o β) : f.toOrderRingHom = f :=
  rfl
#align order_ring_iso.to_order_ring_hom_eq_coe OrderRingIso.toOrderRingHom_eq_coe

@[simp, norm_cast]
theorem coe_toOrderRingHom (f : α ≃+*o β) : ⇑(f : α →+*o β) = f :=
  rfl
#align order_ring_iso.coe_to_order_ring_hom OrderRingIso.coe_toOrderRingHom

@[simp]
theorem coe_toOrderRingHom_refl : (OrderRingIso.refl α : α →+*o α) = OrderRingHom.id α :=
  rfl
#align order_ring_iso.coe_to_order_ring_hom_refl OrderRingIso.coe_toOrderRingHom_refl

theorem toOrderRingHom_injective : Injective (toOrderRingHom : α ≃+*o β → α →+*o β) :=
  fun f g h => FunLike.coe_injective <| by convert FunLike.ext'_iff.1 h using 0
#align order_ring_iso.to_order_ring_hom_injective OrderRingIso.toOrderRingHom_injective

end NonAssocSemiring

end OrderRingIso

/-!
### Uniqueness

There is at most one ordered ring homomorphism from a linear ordered field to an archimedean linear
ordered field. Reciprocally, such an ordered ring homomorphism exists when the codomain is further
conditionally complete.
-/

/-- There is at most one ordered ring homomorphism from a linear ordered field to an archimedean
linear ordered field. -/
instance OrderRingHom.subsingleton [LinearOrderedField α] [LinearOrderedField β] [Archimedean β] :
    Subsingleton (α →+*o β) :=
  ⟨fun f g => by
    ext x
    by_contra' h' : f x ≠ g x
    wlog h : f x < g x generalizing α β with h₂
    -- porting note: had to add the `generalizing` as there are random variables
    -- `F γ δ` flying around in context.
    · exact h₂ g f x (Ne.symm h') (h'.lt_or_lt.resolve_left h)
    obtain ⟨q, hf, hg⟩ := exists_rat_btwn h
    rw [← map_ratCast f] at hf
    rw [← map_ratCast g] at hg
    exact
      (lt_asymm ((OrderHomClass.mono g).reflect_lt hg) <|
          (OrderHomClass.mono f).reflect_lt hf).elim⟩
#align order_ring_hom.subsingleton OrderRingHom.subsingleton

/-- There is at most one ordered ring isomorphism between a linear ordered field and an archimedean
linear ordered field. -/
instance OrderRingIso.subsingleton_right [LinearOrderedField α] [LinearOrderedField β]
    [Archimedean β] : Subsingleton (α ≃+*o β) :=
  OrderRingIso.toOrderRingHom_injective.subsingleton
#align order_ring_iso.subsingleton_right OrderRingIso.subsingleton_right

/-- There is at most one ordered ring isomorphism between an archimedean linear ordered field and a
linear ordered field. -/
instance OrderRingIso.subsingleton_left [LinearOrderedField α] [Archimedean α]
    [LinearOrderedField β] : Subsingleton (α ≃+*o β) :=
  OrderRingIso.symm_bijective.injective.subsingleton
#align order_ring_iso.subsingleton_left OrderRingIso.subsingleton_left