variable (Typ : Type)

inductive LTyp : Type
| ofTyp : Typ → LTyp
| arrow : LTyp → LTyp → LTyp

inductive Context : Nat → Type
| empty : Context (0 : Nat)
| cons : Context n → LTyp Typ → Context (n+1)

inductive Fin2 : Nat → Type
| last (n : Nat) : Fin2 (n+1)
| raise {n : Nat} : Fin2 n → Fin2 (n+1)

variable {Typ}

/-- Oth thing in the context is furthest left -/
def Context.nth : {n : Nat} → Fin2 n → Context Typ n → LTyp Typ
| _, Fin2.last _, Context.cons _ t => t
| _, Fin2.raise i, Context.cons Γ _ => Context.nth i Γ

variable (Const : LTyp Typ → Type)

inductive Term : {n : Nat} → (Γ : Context Typ n) → LTyp Typ → Type
| ofConst {t : LTyp Typ} : Const t → Term Γ t
| boundVar {n : Nat} {Γ : Context Typ n}
  (i : Fin2 n) : Term Γ (Context.nth i Γ)
| lambda {n : Nat} {Γ : Context Typ n} {t u : LTyp Typ} (e : Term (Γ.cons t) u) :
  Term Γ (t.arrow u)
| app {n : Nat} {Γ : Context Typ n} {t u : LTyp Typ}
  (e : Term Γ (t.arrow u)) (x : Term Γ t) : Term Γ u

def assign_last_var : {n : Nat} → {Γ : Context Typ n} → {t u : LTyp Typ} →
  (e : Term Const (Γ.cons t) u) → (x : Term Const Γ t) → Term Const Γ u
| _, _, _, _, Term.app e x, y =>
  Term.app (assign_last_var e y) (assign_last_var x y)
| n, Γ, t, _, @Term.lambda _ _ _ _ u v e, x =>
  have := assign_last_var e
  Term.lambda _
| _, _, _, _, _, _ => sorry

def assign_var : {n : Nat} → {Γ : Context Typ n} → {t : LTyp Typ} →
  (e : Term Const Γ t) → {i : Fin2 n} → (x : Term Const Γ (Γ.nth i)) → Term Const Γ u
| _, _, _, _, Term.app e x, y =>
  Term.app (assign_last_var e y) (assign_last_var x y)
| n, Γ, t, _, @Term.lambda _ _ _ _ u v e, x =>
  have := assign_last_var e
  Term.lambda _
| _, _, _, _, _, _ => sorry

def beta_reduce : {n : Nat} → {Γ : Context Typ n} → {t : LTyp Typ} →
  (e : Term Γ t) →

-- λ x : X. λ y : Y. y
example :
  let Typ : Type := String
  let Const : LTyp Typ → Type := λ _ => Empty
  let X : LTyp Typ := LTyp.ofTyp "X"
  let Y : LTyp Typ := LTyp.ofTyp "Y"
  Term Const Context.empty (X.arrow (Y.arrow Y)) :=
let Typ : Type := String
let Const : LTyp Typ → Type := λ _ => Empty
let X : LTyp Typ := LTyp.ofTyp "X"
let Y : LTyp Typ := LTyp.ofTyp "Y"
Term.lambda (Term.lambda (Term.boundVar (Fin2.last 1)))

example :
  let Typ : Type := String
  let Const : LTyp Typ → Type := λ _ => Unit
  let X : LTyp Typ := LTyp.ofTyp "X"
  let Y : LTyp Typ := LTyp.ofTyp "Y"
  let Z : LTyp Typ := LTyp.ofTyp "Z"
  let f : Const (X.arrow (Y.arrow Z)) := ()
  let g : Const (X.arrow Y) := ()
  let a : Const X := ()
  Term Const Context.empty
   ((X.arrow (Y.arrow Z)).arrow ((X.arrow Y).arrow (X.arrow Z))) :=
let Typ : Type := String
let Const : LTyp Typ → Type := λ _ => Unit
let X : LTyp Typ := LTyp.ofTyp "X"
let Y : LTyp Typ := LTyp.ofTyp "Y"
let Z : LTyp Typ := LTyp.ofTyp "Z"
let f : Const (X.arrow (Y.arrow Z)) := ()
let g : Const (X.arrow Y) := ()
let a : Const X := ()
Term.lambda (Term.lambda (Term.lambda
  (Term.app
    (Term.app (Term.boundVar (Fin2.raise (Fin2.raise (Fin2.last 0)))) -- f
    (Term.boundVar (Fin2.last 2))) -- a
    (Term.app (Term.boundVar (Fin2.raise (Fin2.last 1)))
      (Term.boundVar (Fin2.last 2))))))


/-
Copyright (c) 2020 Pim Spelier, Daan van Gent. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Pim Spelier, Daan van Gent
-/

import data.fintype.basic
import data.num.lemmas
import set_theory.cardinal.ordinal
import tactic.derive_fintype

/-!
# Encodings

This file contains the definition of a (finite) encoding, a map from a type to
strings in an alphabet, used in defining computability by Turing machines.
It also contains several examples:

## Examples

- `fin_encoding_nat_bool`   : a binary encoding of ℕ in a simple alphabet.
- `fin_encoding_nat_Γ'`    : a binary encoding of ℕ in the alphabet used for TM's.
- `unary_fin_encoding_nat` : a unary encoding of ℕ
- `fin_encoding_bool_bool`  : an encoding of bool.
-/

universes u v
open_locale cardinal

namespace computability

/-- An encoding of a type in a certain alphabet, together with a decoding. -/
structure encoding (α : Type u) :=
(Γ : Type v)
(encode : α → list Γ)
(decode : list Γ → option α)
(decode_encode : ∀ x, decode (encode x) = some x)

lemma encoding.encode_injective {α : Type u} (e : encoding α) :
  function.injective e.encode :=
begin
  refine λ _ _ h, option.some_injective _ _,
  rw [← e.decode_encode, ← e.decode_encode, h],
end

/-- An encoding plus a guarantee of finiteness of the alphabet. -/
structure fin_encoding (α : Type u) extends encoding.{u 0} α :=
(Γ_fin : fintype Γ)

instance {α : Type u} (e : fin_encoding α) :
  fintype e.to_encoding.Γ :=
e.Γ_fin

/-- A standard Turing machine alphabet, consisting of blank,bit0,bit1,bra,ket,comma. -/
@[derive [decidable_eq,fintype]]
inductive Γ'
| blank | bit (b : bool) | bra | ket | comma

instance inhabited_Γ' : inhabited Γ' := ⟨Γ'.blank⟩

/-- The natural inclusion of bool in Γ'. -/
def inclusion_bool_Γ' : bool → Γ' := Γ'.bit

/-- An arbitrary section of the natural inclusion of bool in Γ'. -/
def section_Γ'_bool : Γ' → bool
| (Γ'.bit b) := b
| _ := arbitrary bool

lemma left_inverse_section_inclusion : function.left_inverse section_Γ'_bool inclusion_bool_Γ' :=
λ x, bool.cases_on x rfl rfl

lemma inclusion_bool_Γ'_injective : function.injective inclusion_bool_Γ' :=
function.has_left_inverse.injective (Exists.intro section_Γ'_bool left_inverse_section_inclusion)

/-- An encoding function of the positive binary numbers in bool. -/
def encode_pos_num : pos_num → list bool
| pos_num.one := [tt]
| (pos_num.bit0 n) := ff :: encode_pos_num n
| (pos_num.bit1 n) := tt :: encode_pos_num n

/-- An encoding function of the binary numbers in bool. -/
def encode_num : num → list bool
| num.zero := []
| (num.pos n) := encode_pos_num n

/-- An encoding function of ℕ in bool. -/
def encode_nat (n : ℕ) : list bool := encode_num n

/-- A decoding function from `list bool` to the positive binary numbers. -/
def decode_pos_num : list bool → pos_num
| (ff :: l) := (pos_num.bit0 (decode_pos_num l))
| (tt :: l) := ite (l = []) pos_num.one (pos_num.bit1 (decode_pos_num l))
| _ := pos_num.one

/-- A decoding function from `list bool` to the binary numbers. -/
def decode_num : list bool → num := λ l, ite (l = []) num.zero $ decode_pos_num l

/-- A decoding function from `list bool` to ℕ. -/
def decode_nat : list bool → nat := λ l, decode_num l

lemma encode_pos_num_nonempty (n : pos_num) : (encode_pos_num n) ≠ [] :=
pos_num.cases_on n (list.cons_ne_nil _ _) (λ m, list.cons_ne_nil _ _) (λ m, list.cons_ne_nil _ _)

lemma decode_encode_pos_num : ∀ n, decode_pos_num(encode_pos_num n) = n :=
begin
  intros n,
  induction n with m hm m hm; unfold encode_pos_num decode_pos_num,
  { refl },
  { rw hm,
    exact if_neg (encode_pos_num_nonempty m) },
  { exact congr_arg pos_num.bit0 hm }
end

lemma decode_encode_num : ∀ n, decode_num(encode_num n) = n :=
begin
  intros n,
  cases n; unfold encode_num decode_num,
  { refl },
  rw decode_encode_pos_num n,
  rw pos_num.cast_to_num,
  exact if_neg (encode_pos_num_nonempty n),
end

lemma decode_encode_nat : ∀ n, decode_nat(encode_nat n) = n :=
begin
  intro n,
  conv_rhs {rw ← num.to_of_nat n},
  exact congr_arg coe (decode_encode_num ↑n),
end

/-- A binary encoding of ℕ in bool. -/
def encoding_nat_bool : encoding ℕ :=
{ Γ := bool,
  encode := encode_nat,
  decode := λ n, some (decode_nat n),
  decode_encode := λ n, congr_arg _ (decode_encode_nat n) }

/-- A binary fin_encoding of ℕ in bool. -/
def fin_encoding_nat_bool : fin_encoding ℕ := ⟨encoding_nat_bool, bool.fintype⟩

/-- A binary encoding of ℕ in Γ'. -/
def encoding_nat_Γ' : encoding ℕ :=
{ Γ := Γ',
  encode := λ x, list.map inclusion_bool_Γ' (encode_nat x),
  decode := λ x, some (decode_nat (list.map section_Γ'_bool x)),
  decode_encode := λ x, congr_arg _ $
    by rw [list.map_map, list.map_id' left_inverse_section_inclusion, decode_encode_nat] }

/-- A binary fin_encoding of ℕ in Γ'. -/
def fin_encoding_nat_Γ' : fin_encoding ℕ := ⟨encoding_nat_Γ', Γ'.fintype⟩

/-- A unary encoding function of ℕ in bool. -/
def unary_encode_nat : nat → list bool
| 0 := []
| (n+1) := tt :: (unary_encode_nat n)

/-- A unary decoding function from `list bool` to ℕ. -/
def unary_decode_nat : list bool → nat := list.length

lemma unary_decode_encode_nat : ∀ n, unary_decode_nat (unary_encode_nat n) = n :=
λ n, nat.rec rfl (λ (m : ℕ) hm, (congr_arg nat.succ hm.symm).symm) n

/-- A unary fin_encoding of ℕ. -/
def unary_fin_encoding_nat : fin_encoding ℕ :=
{ Γ := bool,
  encode := unary_encode_nat,
  decode := λ n, some (unary_decode_nat n),
  decode_encode := λ n, congr_arg _ (unary_decode_encode_nat n),
  Γ_fin := bool.fintype}

/-- An encoding function of bool in bool. -/
def encode_bool : bool → list bool := list.ret

/-- A decoding function from `list bool` to bool. -/
def decode_bool : list bool → bool
| (b :: _) := b
| _ := arbitrary bool

lemma decode_encode_bool : ∀ b, decode_bool(encode_bool b) = b := λ b, bool.cases_on b rfl rfl

/-- A fin_encoding of bool in bool. -/
def fin_encoding_bool_bool : fin_encoding bool :=
{ Γ := bool,
  encode := encode_bool,
  decode := λ x, some (decode_bool x),
  decode_encode := λ x, congr_arg _ (decode_encode_bool x),
  Γ_fin := bool.fintype }

instance inhabited_fin_encoding : inhabited (fin_encoding bool) := ⟨fin_encoding_bool_bool⟩

instance inhabited_encoding : inhabited (encoding bool) := ⟨fin_encoding_bool_bool.to_encoding⟩

lemma encoding.card_le_card_list {α : Type u} (e : encoding.{u v} α) :
  cardinal.lift.{v} (# α) ≤ cardinal.lift.{u} (# (list e.Γ)) :=
(cardinal.lift_mk_le').2 ⟨⟨e.encode, e.encode_injective⟩⟩

lemma encoding.card_le_aleph_0 {α : Type u} (e : encoding.{u v} α) [encodable e.Γ] : #α ≤ ℵ₀ :=
begin
  refine cardinal.lift_le.1 (e.card_le_card_list.trans _),
  simp only [cardinal.lift_aleph_0, cardinal.lift_le_aleph_0],
  casesI is_empty_or_nonempty e.Γ with h h,
  { simp only [cardinal.mk_le_aleph_0] },
  { rw cardinal.mk_list_eq_aleph_0 }
end

lemma fin_encoding.card_le_aleph_0 {α : Type u} (e : fin_encoding α) : #α ≤ ℵ₀ :=
begin
  haveI : encodable e.Γ := fintype.to_encodable _,
  exact e.to_encoding.card_le_aleph_0
end

end computability


import Lean

import Smt.Reconstruction.Certifying.Util

namespace Smt.Reconstruction.Certifying

open Lean Elab.Tactic Meta Expr Syntax
open Nat List Classical

abbrev Implies (p q : Prop) := p → q

theorem notImplies1 : ∀ {P Q : Prop}, ¬ (P → Q) → P := by
  intros P Q h
  cases em P with
  | inl p  => exact p
  | inr np => apply False.elim
              apply h
              intro p
              exact False.elim (np p)

theorem notImplies2 : ∀ {P Q : Prop}, ¬ (P → Q) → ¬ Q := by
  intros P Q h
  cases em Q with
  | inl q  => exact False.elim (h (λ _ => q))
  | inr nq => exact nq

theorem equivElim1 : ∀ {P Q : Prop}, Eq P Q → ¬ P ∨ Q := by
  intros P Q h
  rewrite [h]
  cases em Q with
  | inl q  => exact Or.inr q
  | inr nq => exact Or.inl nq

theorem equivElim2 : ∀ {P Q : Prop}, Eq P Q → P ∨ ¬ Q := by
  intros P Q h
  rewrite [h]
  cases em Q with
  | inl q  => exact Or.inl q
  | inr nq => exact Or.inr nq

theorem notEquivElim1 : ∀ {P Q : Prop}, ¬ (Eq P Q) → P ∨ Q := by
  intros P Q h
  exact match em P, em Q with
  | Or.inl p, _ => Or.inl p
  | _, Or.inl q => Or.inr q
  | Or.inr np, Or.inr nq =>
    absurd (propext (Iff.intro (λ p => absurd p np) (λ q => absurd q nq))) h

theorem notEquivElim2 : ∀ {P Q : Prop}, ¬ (Eq P Q) → ¬ P ∨ ¬ Q := by
  intros P Q h
  exact match em P, em Q with
  | Or.inr np, _ => Or.inl np
  | _, Or.inr nq => Or.inr nq
  | Or.inl p, Or.inl q =>
    absurd (propext (Iff.intro (λ _ => q) (λ _ => p))) h

theorem iteElim1 : ∀ {c a b : Prop}, ite c a b → ¬ c ∨ a := by
  intros c a b h
  cases em c with
  | inl hc => have r: ite c a b = a := if_pos hc
              rewrite [r] at h
              exact Or.inr h
  | inr hnc => exact Or.inl hnc

theorem iteElim2 : ∀ {c a b : Prop}, ite c a b → c ∨ b := by
  intros c a b h
  cases em c with
  | inl hc => exact Or.inl hc
  | inr hnc => have r: ite c a b = b := if_neg hnc
               rewrite [r] at h
               exact Or.inr h

theorem notIteElim1 : ∀ {c a b : Prop}, ¬ ite c a b → ¬ c ∨ ¬ a := by
  intros c a b h
  cases em c with
  | inl hc  => have r : ite c a b = a := if_pos hc
               rewrite [r] at h
               exact Or.inr h
  | inr hnc => exact Or.inl hnc

theorem notIteElim2 : ∀ {c a b : Prop}, ¬ ite c a b → c ∨ ¬ b := by
  intros c a b h
  cases em c with
  | inl hc => exact Or.inl hc
  | inr hnc => have r : ite c a b = b := if_neg hnc
               rewrite [r] at h
               exact Or.inr h

theorem contradiction : ∀ {P : Prop}, P → ¬ P → False := λ p np => np p

theorem orComm : ∀ {P Q : Prop}, P ∨ Q → Q ∨ P := by
  intros P Q h
  cases h with
  | inl hp => exact Or.inr hp
  | inr hq => exact Or.inl hq

theorem orAssocDir : ∀ {P Q R: Prop}, P ∨ Q ∨ R → (P ∨ Q) ∨ R := by
  intros P Q R h
  cases h with
  | inl h₁ => exact Or.inl (Or.inl h₁)
  | inr h₂ => cases h₂ with
              | inl h₃ => exact Or.inl (Or.inr h₃)
              | inr h₄ => exact Or.inr h₄

theorem orAssocConv : ∀ {P Q R : Prop}, (P ∨ Q) ∨ R → P ∨ Q ∨ R := by
  intros P Q R h
  cases h with
  | inl h₁ => cases h₁ with
              | inl h₃ => exact Or.inl h₃
              | inr h₄ => exact (Or.inr (Or.inl h₄))
  | inr h₂ => exact Or.inr (Or.inr h₂)

theorem congOrRight : ∀ {P Q R : Prop}, (P → Q) → P ∨ R → Q ∨ R := by
  intros P Q R h₁ h₂
  cases h₂ with
  | inl h₃ => exact Or.inl (h₁ h₃)
  | inr h₄ => exact Or.inr h₄

theorem congOrLeft : ∀ {R P Q : Prop}, (P → Q) → R ∨ P → R ∨ Q := by
  intros P Q R h₁ h₂
  apply orComm
  exact congOrRight h₁ (orComm h₂)

theorem orImplies : ∀ {p q : Prop}, (¬ p → q) → p ∨ q :=
  by intros p q h
     exact match em p with
     | Or.inl pp => Or.inl pp
     | Or.inr npp => match em q with
                     | Or.inl pq => Or.inr pq
                     | Or.inr npq => False.elim (npq (h npp))

theorem orImplies₂ : ∀ {p q : Prop}, (¬ p) ∨ q → p → q := by
  intros P Q h p
  cases h with
  | inl np => exact False.elim (np p)
  | inr q  => exact q

theorem orImplies₃ : ∀ {p q : Prop}, p ∨ q → ¬ p → q := by
  intros P Q h np
  cases h with
  | inl p => exact False.elim (np p)
  | inr q => exact q

theorem scope : ∀ {p q : Prop}, (p → q) → ¬ p ∨ q :=
  by intros p q h
     exact match em p with
     | Or.inl pp =>  Or.inr (h pp)
     | Or.inr npp => Or.inl npp

def impliesElim : ∀ {p q : Prop}, (p → q) → ¬ p ∨ q := scope

theorem deMorganSmall : ∀ {p q : Prop}, ¬ (p ∨ q) → ¬ p ∧ ¬ q :=
  by intros p q h
     exact match em p, em q with
     | Or.inl pp,  _          => False.elim (h (Or.inl pp))
     | Or.inr _,   Or.inl pq  => False.elim (h (Or.inr pq))
     | Or.inr npp, Or.inr npq => And.intro npp npq

theorem deMorganSmall₂ : ∀ {p q : Prop}, ¬ p ∧ ¬ q → ¬ (p ∨ q) :=
  by intros p q h
     have ⟨np, nq⟩ := h
     exact match em p, em q with
     | Or.inl pp,  _   => False.elim (np pp)
     | _        ,  Or.inl pq  => False.elim (nq pq)
     | Or.inr npp, Or.inr npq => λ h₂ =>
                                    match h₂ with
                                    | Or.inl pp => False.elim (npp pp)
                                    | Or.inr pq => False.elim (npq pq)

theorem deMorganSmall₃ : ∀ {p q : Prop}, ¬ (p ∧ q) → ¬ p ∨ ¬ q :=
  by intros p q h
     match em p, em q with
     | Or.inl hp, Or.inl hq  => exact False.elim (h (And.intro hp hq))
     | _,         Or.inr hnq => exact Or.inr hnq
     | Or.inr hnp, _        => exact Or.inl hnp

theorem notNotElim : ∀ {p : Prop}, ¬ ¬ p → p :=
  by intros p h
     exact match em p with
     | Or.inl pp => pp
     | Or.inr np => False.elim (h (λ p => np p))

theorem notNotIntro : ∀ {p : Prop}, p → ¬ ¬ p := λ p np => np p

theorem deMorgan : ∀ {l : List Prop}, ¬ orN (notList l) → andN l :=
  by intros l h
     exact match l with
     | []   => True.intro
     | [t]  => by simp [andN]
                  simp [notList, orN, map] at h
                  cases em t with
                  | inl tt  => exact tt
                  | inr ntt => exact False.elim (h ntt)
     | h₁::h₂::t => by simp [orN, notList, map] at h
                       have ⟨ t₁, t₂ ⟩ := deMorganSmall h
                       simp [orN] at t₂
                       have ih := @deMorgan (h₂::t) t₂
                       simp [andN]
                       have t₁' := notNotElim t₁
                       exact ⟨ t₁', ih ⟩

theorem deMorgan₂ : ∀ {l : List Prop}, andN l → ¬ orN (notList l) :=
  by intros l h
     exact match l with
     | [] => by simp [orN, notList]
     | [t] => by simp [orN, notList]; simp [andN] at h; exact notNotIntro h
     | h₁::h₂::t => by simp [orN, notList, map]
                       simp [andN] at h
                       apply deMorganSmall₂
                       have nnh₁ := notNotIntro (And.left h)
                       have ih := @deMorgan₂ (h₂::t) (And.right h)
                       exact ⟨nnh₁, ih⟩

theorem deMorgan₃ : ∀ {l : List Prop}, ¬ orN l → andN (notList l) :=
  by intros l h
     exact match l with
     | [] => True.intro
     | [t] => by simp [andN, notList, map]
                 simp [orN, Not] at h
                 exact h
     | h₁::h₂::t => by simp [orN, Not] at h
                       have ⟨t₁, t₂⟩ := deMorganSmall h
                       simp [orN, Not] at t₂
                       simp [andN, notList, map]
                       have ih := @deMorgan₃ (h₂::t) t₂
                       exact ⟨t₁, ih⟩

theorem cnfAndNeg : ∀ (l : List Prop), andN l ∨ orN (notList l) :=
  by intro l
     apply orComm
     apply orImplies
     intro h
     exact deMorgan h

syntax (name := cnfAndNegT) "cnfAndNegT" ("[" term,* "]")? : tactic

def parseCnfAndNeg : Syntax → TacticM Expr
  | `(tactic| cnfAndNegT [ $[$hs],* ]) => do
    let each ← Array.mapM (fun h => elabTerm h none) hs
    let li := listExpr each.data (Expr.sort Level.zero)
    return li
  | _ => throwError "[cnfAndNeg]: wrong usage"

@[tactic cnfAndNegT] def evalCnfAndNegT : Tactic := fun stx => do
  /- let startTime ← IO.monoMsNow -/
  withMainContext do
    let e ← parseCnfAndNeg stx
    closeMainGoal (mkApp (mkConst `cnfAndNeg) e)
  /- let endTime ← IO.monoMsNow -/
  /- logInfo m!"[cnfAndNeg] Time taken: {endTime - startTime}ms" -/

syntax (name := cnfAndPosT) "cnfAndPosT" ("[" term,* "]")? "," term : tactic

def parseCnfAndPos : Syntax → TacticM (Expr × Expr)
  | `(tactic| cnfAndPosT [ $[$hs],* ], $i) => do
    let each ← Array.mapM (fun h => elabTerm h none) hs
    let li := listExpr each.data (Expr.sort Level.zero)
    let i' ← elabTerm i none
    return (li, i')
  | _ => throwError "[cnfAndPos]: wrong usage"

theorem cnfAndPos : ∀ (l : List Prop) (i : Nat), ¬ (andN l) ∨ List.getD l i True :=
  by intros l i
     apply orImplies
     intro h
     have h' := notNotElim h
     match l with
     | [] => exact True.intro
     | [p] =>
       match i with
       | 0 => exact h'
       | _ + 1 => exact True.intro
     | p₁::p₂::ps =>
       match i with
       | 0 => exact And.left h'
       | i' + 1 =>
         have IH :=  cnfAndPos (p₂::ps) i'
         exact orImplies₂ IH (And.right h')

@[tactic cnfAndPosT] def evalCnfAndPosT : Tactic := fun stx => do
  /- let startTime ← IO.monoMsNow -/
  withMainContext do
    let (li, i) ← parseCnfAndPos stx
    closeMainGoal $ mkApp (mkApp (mkConst `cnfAndPos) li) i
  /- let endTime ← IO.monoMsNow -/
  /- logInfo m!"[cnfAndPos]: Time taken: {endTime - startTime}ms" -/

theorem cnfOrNeg : ∀ (l : List Prop) (i : Nat), orN l ∨ ¬ List.getD l i False := by
  intros l i
  apply orImplies
  intros orNl p
  have andNotl := @deMorgan₃ l orNl
  match l with
  | [] => exact False.elim p
  | [h] =>
    match i with
    | 0 => exact absurd p orNl
    | _ + 1 => exact False.elim p
  | h₁::h₂::hs =>
    match i with
    | 0 => have ⟨nh₁p, _⟩ := andNotl
           exact absurd p nh₁p
    | i' + 1 =>
      have IH := cnfOrNeg (h₂::hs) i'
      have orNTail := orImplies₂ (orComm IH) p
      have ⟨_, notOrNTail⟩ := deMorganSmall orNl
      exact absurd orNTail notOrNTail

theorem cnfOrPos : ∀ (l : List Prop), ¬ orN l ∨ orN l := λ l => orComm (em (orN l))

theorem cnfImpliesPos : ∀ (p q : Prop), ¬ (p → q) ∨ ¬ p ∨ q := by
  intros p q
  match em p, em q with
  | _,         Or.inl hq  => exact Or.inr (Or.inr hq)
  | Or.inl hp, Or.inr hnq => apply Or.inl
                             intro f
                             exact absurd (f hp) hnq
  | Or.inr hnp, _         => exact Or.inr (Or.inl hnp)

theorem cnfImpliesNeg1 : ∀ (p q : Prop), (p → q) ∨ p := by
  intros p q
  apply orComm
  apply orImplies
  exact flip absurd

theorem cnfImpliesNeg2 : ∀ (p q : Prop), (p → q) ∨ ¬ q := by
  intros p q
  apply orComm
  apply orImplies
  intros hnnq _
  exact notNotElim hnnq

theorem cnfEquivPos1 : ∀ (p q : Prop), ¬ (Eq p q) ∨ ¬ p ∨ q := by
  intros _ _
  apply orImplies
  exact equivElim1 ∘ notNotElim

theorem cnfEquivPos2 : ∀ (p q : Prop), ¬ (Eq p q) ∨ p ∨ ¬ q := by
  intros _ _
  apply orImplies
  exact equivElim2 ∘ notNotElim

theorem cnfEquivNeg1 : ∀ (p q : Prop), Eq p q ∨ p ∨ q := by
  intros _ _
  apply orImplies
  exact notEquivElim1

theorem cnfEquivNeg2 : ∀ (p q : Prop), Eq p q ∨ ¬ p ∨ ¬ q := by
  intros _ _
  apply orImplies
  exact notEquivElim2

theorem cnfItePos1 : ∀ (c a b : Prop), ¬ (ite c a b) ∨ ¬ c ∨ a := by
  intros c a b
  apply orImplies
  intro hite
  have hite' := notNotElim hite
  match em c with
  | Or.inl hc  => have r: (if c then a else b) = a := if_pos hc
                  rewrite [r] at hite'
                  exact Or.inr hite'
  | Or.inr hnc => exact Or.inl hnc

theorem cnfItePos2 : ∀ (c a b : Prop), ¬ (ite c a b) ∨ c ∨ b   := by
  intros c a b
  apply orImplies
  intro hite
  have hite' := notNotElim hite
  match em c with
  | Or.inr hnc => have r: (if c then a else b) = b := if_neg hnc
                  rewrite [r] at hite'
                  exact Or.inr hite'
  | Or.inl hc  => exact Or.inl hc

theorem cnfItePos3 : ∀ (c a b : Prop), ¬ (ite c a b) ∨ a ∨ b   := by
  intros c a b
  apply orImplies
  intro hite
  have hite' := notNotElim hite
  match em c with
  | Or.inr hnc => have r: (if c then a else b) = b := if_neg hnc
                  rewrite [r] at hite'
                  exact Or.inr hite'
  | Or.inl hc  => have r: (if c then a else b) = a := if_pos hc
                  rewrite [r] at hite'
                  exact Or.inl hite'

theorem cnfIteNeg1 : ∀ (c a b : Prop), (ite c a b) ∨ ¬ c ∨ ¬ a := by
  intros c a b
  apply orImplies
  intro hnite
  match em c with
  | Or.inl hc  => have r: (if c then a else b) = a := if_pos hc
                  rewrite [r] at hnite
                  exact Or.inr hnite
  | Or.inr hnc => exact Or.inl hnc

theorem cnfIteNeg2 : ∀ (c a b : Prop), (ite c a b) ∨ c ∨ ¬ b   := by
  intros c a b
  apply orImplies
  intro hnite
  match em c with
  | Or.inr hnc  => have r: (if c then a else b) = b := if_neg hnc
                   rewrite [r] at hnite
                   exact Or.inr hnite
  | Or.inl hc => exact Or.inl hc

theorem cnfIteNeg3 : ∀ (c a b : Prop), (ite c a b) ∨ ¬ a ∨ ¬ b := by
  intros c a b
  apply orImplies
  intro hnite
  match em c with
  | Or.inr hnc  => have r: (if c then a else b) = b := if_neg hnc
                   rewrite [r] at hnite
                   exact Or.inr hnite
  | Or.inl hc => have r: (if c then a else b) = a := if_pos hc
                 rewrite [r] at hnite
                 exact Or.inl hnite

theorem smtCong₁ : ∀ {A B : Type u} {f₁ f₂ : A → B} {t₁ t₂ : A},
  f₁ = f₂ → t₁ = t₂ → f₁ t₁ = f₂ t₂ := congr

theorem smtCong₂ : ∀ {B : Type u} {f₁ f₂ : Prop → B} {t₁ t₂ : Prop},
  f₁ = f₂ → (t₁ ↔ t₂) → f₁ t₁ = f₂ t₂ :=
  by intros B f₁ f₂ t₁ t₂ h₁ h₂
     rewrite [h₁, h₂]
     exact rfl

theorem smtCong₃ : ∀ {A : Type u} {f₁ f₂ : A → Prop} {t₁ t₂ : A},
  (f₁ = f₂) → (t₁ = t₂) → (f₁ t₁ ↔ f₂ t₂) :=
  by intros A f₁ f₂ t₁ t₂ h₁ h₂
     rewrite [h₁, h₂]
     exact Iff.rfl

theorem smtCong₄ : ∀ {f₁ f₂ : Prop → Prop} {t₁ t₂ : Prop},
  f₁ = f₂ → (t₁ ↔ t₂) → (f₁ t₁ ↔ f₂ t₂) :=
  by intros f₁ f₂ t₁ t₂ h₁ h₂
     rewrite [h₁, h₂]
     exact Iff.rfl

syntax (name := smtCong) "smtCong" term "," term : tactic
@[tactic smtCong] def evalSmtCong : Tactic := fun stx => do
  /- let startTime ← IO.monoMsNow -/
  withMainContext do
    let hyp2 ← elabTerm stx[3] none
    let hyp2Type ← inferType hyp2
    let t1: Term := ⟨stx[1]⟩
    let t3: Term := ⟨stx[3]⟩
    let e₁ ← elabTerm t1 none
    let t₁ ← instantiateMVars (← inferType e₁)
    let d ← getFunctionCounterDomain t₁
    let isProp := d == sort Level.zero
    match isProp, isIff hyp2Type with
    | false, false => evalTactic (← `(tactic| exact smtCong₁ $t1 $t3))
    | false, true  => evalTactic (← `(tactic| exact smtCong₁ $t1 $t3))
    | true,  false => evalTactic (← `(tactic| exact smtCong₁ $t1 $t3))
    | true,  true  => evalTactic (← `(tactic| exact smtCong₁ $t1 $t3))
  /- let endTime ← IO.monoMsNow -/
  /- logInfo m!"[smtCong] Time taken: {endTime - startTime}ms" -/
where
  isIff : Expr → Bool
  | app (app (const `Iff ..) _) _ => true
  | _ => false
  getFunctionCounterDomain : Expr → TacticM Expr
  | app (app _ e₁) _ => do
    let t₁ ← inferType e₁
    let d₁ := bindingBody! t₁
    return d₁
  | _ => throwError "unexpected type in smtCong"

/- theorem eqResolve {P Q : Prop} : P → (P ↔ Q) → Q := by -/
/-   intros h₁ h₂ -/
/-   rewrite [← h₂] -/
/-   exact h₁ -/

theorem eqResolve {P Q : Prop} : P → (P = Q) → Q := by
  intros h₁ h₂
  rewrite [← h₂]
  exact h₁

theorem dupOr {P Q : Prop} : P ∨ P ∨ Q → P ∨ Q := λ h =>
  match h with
  | Or.inl p          => Or.inl p
  | Or.inr (Or.inl p) => Or.inl p
  | Or.inr (Or.inr q) => Or.inr q

theorem dupOr₂ {P : Prop} : P ∨ P → P := λ h =>
  match h with
  | Or.inl p => p
  | Or.inr p => p

syntax (name := andElim) "andElim" term "," term : tactic
@[tactic andElim] def evalAndElim : Tactic := fun stx => do
  /- let startTime ← IO.monoMsNow -/
  withMainContext do
    let i ← stxToNat ⟨stx[3]⟩
    let mut proof := getProof i stx[1]
    let andProp ← inferType (← elabTerm stx[1] none)
    if i < getLengthAnd andProp - 1 then
      proof := Syntax.mkApp (mkIdent `And.left) #[⟨proof⟩]
    let proofE ← elabTerm proof none
    closeMainGoal proofE
  /- let endTime ← IO.monoMsNow -/
  /- logInfo m!"[andElim] Time taken: {endTime - startTime}ms" -/
where
  getProof (i : Nat) (hyp : Syntax) : Syntax :=
    match i with
    | 0 => hyp
    | (i + 1) =>
      Syntax.mkApp (mkIdent `And.right) #[⟨getProof i hyp⟩]

example : A ∧ B ∧ C ∧ D → D := by
  intro h
  andElim h, 3

syntax (name := notOrElim) "notOrElim" term "," term : tactic
@[tactic notOrElim] def evalNotOrElim : Tactic := fun stx => do
  /- let startTime ← IO.monoMsNow -/
  withMainContext do
    let i ← stxToNat ⟨stx[3]⟩
    let hyp ← inferType (← elabTerm stx[1] none)
    let orChain := notExpr hyp
    let proof: Syntax ←
      match getLength orChain == i + 1 with
      | true => `(x)
      | false => `(Or.inl x)
    let proof: Syntax := getProof i proof
    let proof := Syntax.mkApp ⟨stx[1]⟩ #[⟨proof⟩]
    let proof ← `(fun x => $proof)
    let proofE ← elabTerm proof none
    closeMainGoal proofE
  /- let endTime ← IO.monoMsNow -/
  /- logInfo m!"[notOrElim] Time taken: {endTime - startTime}ms" -/
where
  getProof (i : Nat) (hyp : Syntax) : Syntax :=
    match i with
    | 0 => hyp
    | i + 1 => Syntax.mkApp (mkIdent `Or.inr) #[⟨getProof i hyp⟩]

example : ¬ (A ∨ B ∨ C ∨ D) → ¬ C := by
  intro h
  notOrElim h, 2

theorem notAnd : ∀ (l : List Prop), ¬ andN l → orN (notList l) := by
  intros l h
  match l with
  | []         => exact False.elim (h True.intro)
  | [_]        => exact h
  | p₁::p₂::ps => simp [andN] at h
                  simp [orN, notList, map]
                  match deMorganSmall₃ h with
                  | Or.inl hnp₁ => exact Or.inl hnp₁
                  | Or.inr hnAndTail =>
                    have IH := notAnd (p₂::ps) hnAndTail
                    exact Or.inr IH

theorem liftOrToNeg : ∀ (l : List Prop), orN (notList l) → ¬ andN l := by
  intros l h
  match l with
  | [] => exact False.elim h
  | [_] => exact h
  | p₁::p₂::ps =>
    simp [orN, notList, map] at h
    simp [andN]
    intro ⟨hp₁, andTail⟩
    match h with
    | Or.inl hnp₁      => exact absurd hp₁ hnp₁
    | Or.inr orNotTail => have IH := liftOrToNeg (p₂::ps) orNotTail
                          exact absurd andTail IH

theorem modusPonens : ∀ {A B : Prop}, A → (A → B) → B := λ x f => f x

theorem trueIntro' : ∀ {A : Prop}, A → A = True := by
  intros A h
  exact propext (Iff.intro (λ _ => True.intro) (λ _ => h))
theorem trueIntro₂' : ∀ {A : Prop}, A → True = A := Eq.symm ∘ trueIntro'

theorem trueElim : ∀ {A : Prop}, A = True → A := by
  intros A h
  rewrite [h]
  trivial
theorem trueElim₂ : ∀ {A : Prop}, True = A → A :=
  trueElim ∘ Eq.symm

theorem falseIntro : ∀ {A : Prop}, ¬ A → A = False :=
  λ h => propext (Iff.intro (λ a => h a) (λ ff => False.elim ff))
theorem falseIntro₂ : ∀ {A : Prop}, ¬ A → False = A := Eq.symm ∘ falseIntro

theorem falseElim : ∀ {A : Prop}, A = False → ¬ A := λ h ha =>
  match h with
  | rfl => ha
theorem falseElim₂ : ∀ {A : Prop}, False = A → ¬ A := falseElim ∘ Eq.symm

theorem neg_symm {α : Type u} {a b : α} : a ≠ b → b ≠ a := λ h f => h (Eq.symm f)

syntax "flipCongrArg " term ("[" term "]")? : term
macro_rules
| `(flipCongrArg $premiss:term [$arg:term]) => `(congrArg $arg $premiss)

end Smt.Reconstruction.Certifying


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import algebra.big_operators.basic
import data.finset.basic
import data.multiset.basic
import group_theory.group_action.defs

/-!
# Lemmas about group actions on big operators

Note that analogous lemmas for `module`s like `finset.sum_smul` appear in other files.
-/

variables {α β γ : Type*}

open_locale big_operators

section
variables [monoid α] [add_monoid β] [distrib_mul_action α β]

lemma list.smul_sum {r : α} {l : list β} :
  r • l.sum = (l.map ((•) r)).sum :=
(distrib_mul_action.to_add_monoid_hom β r).map_list_sum l

end

section
variables [monoid α] [monoid β] [mul_distrib_mul_action α β]

lemma list.smul_prod {r : α} {l : list β} :
  r • l.prod = (l.map ((•) r)).prod :=
(mul_distrib_mul_action.to_monoid_hom β r).map_list_prod l

end

section
variables [monoid α] [add_comm_monoid β] [distrib_mul_action α β]

lemma multiset.smul_sum {r : α} {s : multiset β} :
  r • s.sum = (s.map ((•) r)).sum :=
(distrib_mul_action.to_add_monoid_hom β r).map_multiset_sum s

lemma finset.smul_sum {r : α} {f : γ → β} {s : finset γ} :
  r • ∑ x in s, f x = ∑ x in s, r • f x :=
(distrib_mul_action.to_add_monoid_hom β r).map_sum f s

end

section
variables [monoid α] [comm_monoid β] [mul_distrib_mul_action α β]

lemma multiset.smul_prod {r : α} {s : multiset β} :
  r • s.prod = (s.map ((•) r)).prod :=
(mul_distrib_mul_action.to_monoid_hom β r).map_multiset_prod s

lemma finset.smul_prod {r : α} {f : γ → β} {s : finset γ} :
  r • ∏ x in s, f x = ∏ x in s, r • f x :=
(mul_distrib_mul_action.to_monoid_hom β r).map_prod f s

end


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

This file demonstrates how to encode vectors using indexed inductive families.
In standard library we do not use this approach.
-/
import data.nat data.list data.fin
open nat prod fin

inductive vector (A : Type) : nat → Type :=
| nil {} : vector A zero
| cons   : Π {n}, A → vector A n → vector A (succ n)

namespace vector
  notation a :: b := cons a b
  notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l

  variables {A B C : Type}

  protected definition is_inhabited [instance] [h : inhabited A] : ∀ (n : nat), inhabited (vector A n)
  | 0     := inhabited.mk []
  | (n+1) := inhabited.mk (inhabited.value h :: inhabited.value (is_inhabited n))

  theorem vector0_eq_nil : ∀ (v : vector A 0), v = []
  | [] := rfl

  definition head : Π {n : nat}, vector A (succ n) → A
  | n (a::v) := a

  definition tail : Π {n : nat}, vector A (succ n) → vector A n
  | n (a::v) := v

  theorem head_cons {n : nat} (h : A) (t : vector A n) : head (h :: t) = h :=
  rfl

  theorem tail_cons {n : nat} (h : A) (t : vector A n) : tail (h :: t) = t :=
  rfl

  theorem eta : ∀ {n : nat} (v : vector A (succ n)), head v :: tail v = v
  | n (a::v) := rfl

  definition last : Π {n : nat}, vector A (succ n) → A
  | last [a]    := a
  | last (a::v) := last v

  theorem last_singleton (a : A) : last [a] = a :=
  rfl

  theorem last_cons {n : nat} (a : A) (v : vector A (succ n)) : last (a :: v) = last v :=
  rfl

  definition const : Π (n : nat), A → vector A n
  | 0        a := []
  | (succ n) a := a :: const n a

  theorem head_const (n : nat) (a : A) : head (const (succ n) a) = a :=
  rfl

  theorem last_const : ∀ (n : nat) (a : A), last (const (succ n) a) = a
  | 0     a := rfl
  | (n+1) a := last_const n a

  definition nth : Π {n : nat}, vector A n → fin n → A
  | ⌞0⌟   []       i               := elim0 i
  | ⌞n+1⌟ (a :: v) (mk 0 _)        := a
  | ⌞n+1⌟ (a :: v) (mk (succ i) h) := nth v (mk_pred i h)

  lemma nth_zero {n : nat} (a : A) (v : vector A n) (h : 0 < succ n) : nth (a::v) (mk 0 h) = a :=
  rfl

  lemma nth_succ {n : nat} (a : A) (v : vector A n) (i : nat) (h : succ i < succ n)
                 : nth (a::v) (mk (succ i) h) = nth v (mk_pred i h) :=
  rfl

  definition tabulate : Π {n : nat}, (fin n → A) → vector A n
  | 0      f :=  []
  | (n+1)  f :=  f (fin.zero n) :: tabulate (λ i : fin n, f (succ i))

  theorem nth_tabulate : ∀ {n : nat} (f : fin n → A) (i : fin n), nth (tabulate f) i = f i
  | 0     f i               := elim0 i
  | (n+1) f (mk 0 h)        := by reflexivity
  | (n+1) f (mk (succ i) h) :=
    begin
      change nth (f (fin.zero n) :: tabulate (λ i : fin n, f (succ i))) (mk (succ i) h) = f (mk (succ i) h),
      rewrite nth_succ,
      rewrite nth_tabulate
    end

  definition map (f : A → B) : Π {n : nat}, vector A n → vector B n
  | map []     := []
  | map (a::v) := f a :: map v

  theorem map_nil (f : A → B) : map f [] = [] :=
  rfl

  theorem map_cons {n : nat} (f : A → B) (h : A) (t : vector A n) : map f (h :: t) =  f h :: map f t :=
  rfl

  theorem nth_map (f : A → B) : ∀ {n : nat} (v : vector A n) (i : fin n), nth (map f v) i = f (nth v i)
  | 0        v        i               := elim0 i
  | (succ n) (a :: t) (mk 0 h)        := by reflexivity
  | (succ n) (a :: t) (mk (succ i) h) := by rewrite [map_cons, *nth_succ, nth_map]

  section
  open function
  theorem map_id : ∀ {n : nat} (v : vector A n), map id v = v
  | 0        []      := rfl
  | (succ n) (x::xs) := by rewrite [map_cons, map_id]

  theorem map_map (g : B → C) (f : A → B) : ∀ {n :nat} (v : vector A n), map g (map f v) = map (g ∘ f) v
  | 0        []       := rfl
  | (succ n) (a :: l) :=
    show (g ∘ f) a :: map g (map f l) = map (g ∘ f) (a :: l),
    by rewrite (map_map l)
  end

  definition map2 (f : A → B → C) : Π {n : nat}, vector A n → vector B n → vector C n
  | map2 []      []      := []
  | map2 (a::va) (b::vb) := f a b :: map2 va vb

  theorem map2_nil (f : A → B → C) : map2 f [] [] = [] :=
  rfl

  theorem map2_cons {n : nat} (f : A → B → C) (h₁ : A) (h₂ : B) (t₁ : vector A n) (t₂ : vector B n) :
                    map2 f (h₁ :: t₁) (h₂ :: t₂) = f h₁ h₂ :: map2 f t₁ t₂ :=
  rfl

  definition append : Π {n m : nat}, vector A n → vector A m → vector A (n ⊕ m)
  | 0        m []     w := w
  | (succ n) m (a::v) w := a :: (append v w)

  theorem append_nil_left {n : nat} (v : vector A n) : append [] v = v :=
  rfl

  theorem append_cons {n m : nat} (h : A) (t : vector A n) (v : vector A m) :
    append (h::t) v = h :: (append t v) :=
  rfl

  theorem map_append (f : A → B) : ∀ {n m : nat} (v : vector A n) (w : vector A m), map f (append v w) = append (map f v) (map f w)
  | 0     m   []        w   :=  rfl
  | (n+1) m   (h :: t)  w   :=
     begin
       change (f h :: map f (append t w) = f h :: append (map f t) (map f w)),
       rewrite map_append
     end

  definition unzip : Π {n : nat}, vector (A × B) n → vector A n × vector B n
  | unzip []            := ([], [])
  | unzip ((a, b) :: v) := (a :: pr₁ (unzip v), b :: pr₂ (unzip v))

  theorem unzip_nil : unzip (@nil (A × B)) = ([], []) :=
  rfl

  theorem unzip_cons {n : nat} (a : A) (b : B) (v : vector (A × B) n) :
       unzip ((a, b) :: v) = (a :: pr₁ (unzip v), b :: pr₂ (unzip v)) :=
  rfl

  definition zip : Π {n : nat}, vector A n → vector B n → vector (A × B) n
  | zip []      []      := []
  | zip (a::va) (b::vb) := ((a, b) :: zip va vb)

  theorem zip_nil_nil : zip (@nil A) (@nil B) = nil :=
  rfl

  theorem zip_cons_cons {n : nat} (a : A) (b : B) (va : vector A n) (vb : vector B n) :
      zip (a::va) (b::vb) = ((a, b) :: zip va vb) :=
  rfl

  theorem unzip_zip : ∀ {n : nat} (v₁ : vector A n) (v₂ : vector B n), unzip (zip v₁ v₂) = (v₁, v₂)
  | 0     []      []      := rfl
  | (n+1) (a::va) (b::vb) := calc
       unzip (zip (a :: va) (b :: vb))
             = (a :: pr₁ (unzip (zip va vb)), b :: pr₂ (unzip (zip va vb))) : rfl
        ...  = (a :: pr₁ (va, vb), b :: pr₂ (va, vb))                       : by rewrite unzip_zip
        ...  = (a :: va, b :: vb)                                           : rfl

  theorem zip_unzip : ∀ {n : nat} (v : vector (A × B) n), zip (pr₁ (unzip v)) (pr₂ (unzip v)) = v
  | 0     []             := rfl
  | (n+1) ((a, b) :: v)  := calc
    zip (pr₁ (unzip ((a, b) :: v))) (pr₂ (unzip ((a, b) :: v)))
         = (a, b) :: zip (pr₁ (unzip v)) (pr₂ (unzip v)) : rfl
     ... = (a, b) :: v                                   : by rewrite zip_unzip

  /- Concat -/

  definition concat : Π {n : nat}, vector A n → A → vector A (succ n)
  | concat []     a := [a]
  | concat (b::v) a := b :: concat v a

  theorem concat_nil (a : A) : concat [] a = [a] :=
  rfl

  theorem concat_cons {n : nat} (b : A) (v : vector A n) (a : A) : concat (b :: v) a = b :: concat v a :=
  rfl

  theorem last_concat : ∀ {n : nat} (v : vector A n) (a : A), last (concat v a) = a
  | 0     []     a := rfl
  | (n+1) (b::v) a := calc
    last (concat (b::v) a) = last (concat v a) : rfl
                    ...    = a                 : last_concat v a

  /- Reverse -/

  definition reverse : Π {n : nat}, vector A n → vector A n
  | 0     []        := []
  | (n+1) (x :: xs) := concat (reverse xs) x

  theorem reverse_concat : Π {n : nat} (xs : vector A n) (a : A), reverse (concat xs a) = a :: reverse xs
  | 0     []         a := rfl
  | (n+1) (x :: xs)  a :=
    begin
      change (concat (reverse (concat xs a)) x = a :: reverse (x :: xs)),
      rewrite reverse_concat
    end

  theorem reverse_reverse : Π {n : nat} (xs : vector A n), reverse (reverse xs) = xs
  | 0     []        := rfl
  | (n+1) (x :: xs) :=
    begin
      change (reverse (concat (reverse xs) x) = x :: xs),
      rewrite [reverse_concat, reverse_reverse]
    end

  /- list <-> vector -/

  definition of_list : Π (l : list A), vector A (list.length l)
  | list.nil        := []
  | (list.cons a l) := a :: (of_list l)

  definition to_list : Π {n : nat}, vector A n → list A
  | 0     []        := list.nil
  | (n+1) (a :: vs) := list.cons a (to_list vs)

  theorem to_list_of_list : ∀ (l : list A), to_list (of_list l) = l
  | list.nil         := rfl
  | (list.cons a l)  :=
    begin
      change (list.cons a (to_list (of_list l)) = list.cons a l),
      rewrite to_list_of_list
    end

  theorem to_list_nil : to_list [] = (list.nil : list A) :=
  rfl

  theorem length_to_list : ∀ {n : nat} (v : vector A n), list.length (to_list v) = n
  | 0     []        := rfl
  | (n+1) (a :: vs) :=
    begin
      change (succ (list.length (to_list vs)) = succ n),
      rewrite length_to_list
    end

  theorem heq_of_list_eq : ∀ {n m} {v₁ : vector A n} {v₂ : vector A m}, to_list v₁ = to_list v₂ → n = m → v₁ == v₂
  | 0     0     []      []      h₁ h₂ := !heq.refl
  | 0     (m+1) []      (y::ys) h₁ h₂ := by contradiction
  | (n+1) 0     (x::xs) []      h₁ h₂ := by contradiction
  | (n+1) (m+1) (x::xs) (y::ys) h₁ h₂ :=
    have e₁ : n = m, from succ.inj h₂,
    have e₂ : x = y, begin unfold to_list at h₁, injection h₁, assumption end,
    have   e₃ : to_list xs = to_list ys, begin unfold to_list at h₁, injection h₁, assumption end,
    have xs == ys, from heq_of_list_eq e₃ e₁,
    have y :: xs == y :: ys, begin clear heq_of_list_eq h₁ h₂ e₃, revert xs ys this, induction e₁, intro xs ys h, rewrite [eq_of_heq h] end,
    show x :: xs == y :: ys, by rewrite e₂; exact this

  theorem list_eq_of_heq {n m} {v₁ : vector A n} {v₂ : vector A m} : v₁ == v₂ → n = m → to_list v₁ = to_list v₂ :=
  begin
    intro h₁ h₂, revert v₁ v₂ h₁,
    subst n, intro v₁ v₂ h₁, rewrite [eq_of_heq h₁]
  end

  theorem of_list_to_list {n : nat} (v : vector A n) : of_list (to_list v) == v :=
  begin
    apply heq_of_list_eq, rewrite to_list_of_list, rewrite length_to_list
  end

  theorem to_list_append : ∀ {n m : nat} (v₁ : vector A n) (v₂ : vector A m), to_list (append v₁ v₂) = list.append (to_list v₁) (to_list v₂)
  | 0        m        []      ys      := rfl
  | (succ n) m        (x::xs) ys      := begin unfold append, unfold to_list at {1,2}, krewrite [to_list_append xs ys] end

  theorem to_list_map (f : A → B) : ∀ {n : nat} (v : vector A n), to_list (map f v) = list.map f (to_list v)
  | 0        []      := rfl
  | (succ n) (x::xs) := begin unfold [map, to_list], rewrite to_list_map end

  theorem to_list_concat : ∀ {n : nat} (v : vector A n) (a : A), to_list (concat v a) = list.concat a (to_list v)
  | 0        []      a := rfl
  | (succ n) (x::xs) a := begin unfold [concat, to_list], rewrite to_list_concat end

  theorem to_list_reverse : ∀ {n : nat} (v : vector A n), to_list (reverse v) = list.reverse (to_list v)
  | 0        []      := rfl
  | (succ n) (x::xs) := begin unfold [reverse], rewrite [to_list_concat, to_list_reverse] end

  theorem append_nil_right {n : nat} (v : vector A n) : append v [] == v :=
  begin
    apply heq_of_list_eq,
      rewrite [to_list_append, to_list_nil, list.append_nil_right],
      rewrite [-add_eq_addl]
  end

  theorem append.assoc {n₁ n₂ n₃ : nat} (v₁ : vector A n₁) (v₂ : vector A n₂) (v₃ : vector A n₃) : append v₁ (append v₂ v₃) == append (append v₁ v₂) v₃ :=
  begin
    apply heq_of_list_eq,
      rewrite [*to_list_append, list.append.assoc],
      rewrite [-*add_eq_addl, add.assoc]
  end

  theorem reverse_append {n m : nat} (v : vector A n) (w : vector A m) : reverse (append v w) == append (reverse w) (reverse v) :=
  begin
    apply heq_of_list_eq,
      rewrite [to_list_reverse, to_list_append, list.reverse_append, to_list_append, *to_list_reverse],
      rewrite [-*add_eq_addl, add.comm]
  end

  theorem concat_eq_append {n : nat} (v : vector A n) (a : A) : concat v a == append v [a] :=
  begin
    apply heq_of_list_eq,
      rewrite [to_list_concat, to_list_append, list.concat_eq_append],
      rewrite [-add_eq_addl]
  end

  /- decidable equality -/
  open decidable
  definition decidable_eq [H : decidable_eq A] : ∀ {n : nat} (v₁ v₂ : vector A n), decidable (v₁ = v₂)
  | ⌞0⌟    []      []      := by left; reflexivity
  | ⌞n+1⌟  (a::v₁) (b::v₂) :=
    match H a b with
    | inl Hab  :=
      match decidable_eq v₁ v₂ with
      | inl He := by left; congruence; repeat assumption
      | inr Hn := by right; intro h; injection h; contradiction
      end
    | inr Hnab := by right; intro h; injection h; contradiction
  end

  section
  open equiv function
  definition vector_equiv_of_equiv {A B : Type} : A ≃ B → ∀ n, vector A n ≃ vector B n
  | (mk f g l r) n :=
    mk (map f) (map g)
     begin intros, rewrite [map_map, id_of_left_inverse l, map_id], reflexivity end
     begin intros, rewrite [map_map, id_of_right_inverse r, map_id], reflexivity end
  end
end vector


import Mathlib.Algebra.Field.Basic
import Mathlib.Data.Rat.Order

-- manual port of https://github.com/alexjbest/diophantine-toolkit/blob/master/src/number_theory/QuadRing/basic.lean

/-- `QuadRing F a b` adjoins a root `α` of `x^2 - ax - b` to the ring (field) `F`.
For example, `ℤ[√5]` can be defined as `QuadRing ℤ 0 5`.
Elements of `QuadRing` are represented as a pair `⟨b1, b2⟩` standing for the element `b1 + b2 α`.
-/
@[ext]
structure QuadRing (F : Type _) (a b : F) :=
(b1 b2 : F)
deriving Repr

-- attribute [pp_using_anonymous_constructor] QuadRing

namespace QuadRing

section

variable (F : Type _) (a b : F)

@[simp] theorem eta : ∀ z : QuadRing F a b, (⟨z.b1,z.b2⟩ : QuadRing F a b) = z
| ⟨_,_⟩ => rfl

/-!
### Basic constructions of elements in `QuadRing R a b`
-/

/-- The standard inclusion `F → QuadRing F a b`. -/
instance [Zero F] : Coe F (QuadRing F a b) := ⟨λ r => ⟨r, 0⟩⟩

@[simp] lemma coe_b1 [Zero F] (r : F) : (r : QuadRing F a b).b1 = r := rfl

@[simp] lemma coe_b2 [Zero F] (r : F) : (r : QuadRing F a b).b2 = 0 := rfl

@[simp] theorem coe_inj [Zero F] {z w : F} : (z : QuadRing F a b) = w ↔ z = w :=
⟨congr_arg b1, by aesop⟩

-- lemma coe_injective [Zero F] : Function.Injective (coe : F → QuadRing F a b) :=
-- λ a b => (coe_inj F a b).mp

/-- `QuadRing.root F a b` is the adjoined root `α` of the polynomial `x^2 - ax - b`. -/
def root [Zero F] [One F] : QuadRing F a b := ⟨0, 1⟩

@[simp] lemma root_b1 [Zero F] [One F]: (root F a b).b1 = 0 := rfl
@[simp] lemma root_b2 [Zero F] [One F]: (root F a b).b2 = 1 := rfl

variables [CommRing F]
/-!
### Ring stucture on `QuadRing R a b`
-/

instance : Zero (QuadRing F a b) := ⟨(0 : F)⟩
instance : Inhabited (QuadRing F a b) := ⟨0⟩

@[simp] lemma zero_b1 : (0 : QuadRing F a b).b1 = 0 := rfl
@[simp] lemma zero_b2 : (0 : QuadRing F a b).b2 = 0 := rfl

@[simp] lemma coe_zero : ((0 : F) : QuadRing F a b) = 0 := rfl

@[simp] theorem coe_eq_zero {z : F} : (z : QuadRing F a b) = 0 ↔ z = 0 :=
coe_inj F a b

instance : One (QuadRing F a b) := ⟨(1 : F)⟩

@[simp] lemma one_b1 : (1 : QuadRing F a b).b1 = 1 := rfl
@[simp] lemma one_b2 : (1 : QuadRing F a b).b2 = 0 := rfl

@[simp] lemma coe_one : ((1 : F) : QuadRing F a b) = 1 := rfl

instance : Add (QuadRing F a b) := ⟨λ z w => ⟨z.b1 + w.b1, z.b2 + w.b2⟩⟩

@[simp] lemma add_b1 (z w : QuadRing F a b) : (z + w).b1 = z.b1 + w.b1 := rfl
@[simp] lemma add_b2 (z w : QuadRing F a b) : (z + w).b2 = z.b2 + w.b2 := rfl

@[simp] lemma coe_add (r s : F) : ((r + s : F) : QuadRing F a b) = r + s :=
(QuadRing.ext_iff _ _).2 $ by simp

instance : Neg (QuadRing F a b) := ⟨λ z => ⟨-z.b1, -z.b2⟩⟩

@[simp] lemma neg_b1 (z : QuadRing F a b) : (-z).b1 = -z.b1 := rfl
@[simp] lemma neg_b2 (z : QuadRing F a b) : (-z).b2 = -z.b2 := rfl

@[simp] lemma coe_neg (n : F) : (↑(-n) : QuadRing F a b) = - ↑n := by ext; simp; sorry

instance : Sub (QuadRing F a b) := ⟨λ z w => ⟨z.b1 - w.b1, z.b2 - w.b2⟩⟩

@[simp] lemma sub_b1 (z w : QuadRing F a b) : (z - w).b1 = z.b1 - w.b1 := rfl
@[simp] lemma sub_b2 (z w : QuadRing F a b) : (z - w).b2 = z.b2 - w.b2 := rfl

@[simp] lemma coe_sub (z w : F) : (↑(z - w) : QuadRing F a b) = ↑z - ↑w := by ext; simp; sorry

/-- This scalar multiplication is used to define `nsmul`, `zsmul` and `qsmul`. -/
instance {R F : Type _} [SMul R F] (a b : F) : SMul R (QuadRing F a b) :=
{ smul := λ c x => ⟨c • x.b1, c • x.b2⟩ }

@[simp] lemma smul_b1 {R F : Type _} [SMul R F] {a b : F} (c : R) (z : QuadRing F a b) :
  (c • z).b1 = c • z.b1 := rfl
@[simp] lemma smul_b2 {R F : Type _} [SMul R F] {a b : F} (c : R) (z : QuadRing F a b) :
  (c • z).b2 = c • z.b2 := rfl

/-! We want to define the `CommRing (QuadRing F a b)` instance in multiple steps,
so we can insert the right operations on `ℕ`, `ℤ` (and `ℚ`).
These operations have to be defined in the right way to ensure all diamond instances
involving e.g. `QuadRing ℤ a b` are indeed definitionally equal.
-/

instance : AddCommMonoidWithOne (QuadRing F a b) :=
{ add := (. + .)
  zero := (0)
  one := (1)
  add_assoc := by intros; ext <;> apply add_assoc
  add_comm := by intros; ext <;> apply add_comm
  zero_add := by intros; ext <;> apply zero_add
  add_zero := by intros; ext <;> apply add_zero
  nsmul := (.•.),
  nsmul_zero := by intros; ext <;> apply zero_nsmul
  nsmul_succ := by intros; ext <;> apply succ_nsmul
  natCast := λ n => ↑(n : F)
  natCast_zero := by simp
  natCast_succ := by intros; simp }

@[simp] lemma coe_coe_nat (n : ℕ) : ((n : F) : QuadRing F a b) = n := rfl

instance : AddCommGroup (QuadRing F a b) :=
{ instAddCommMonoidWithOneQuadRing F a b with
  add_left_neg := by intros; ext <;> apply add_left_neg,
  sub := Sub.sub
  zsmul := (.•.)
  zsmul_zero' := by intros; ext <;> apply zero_zsmul
  zsmul_succ' := sorry --by intros; ext <;> simp [add_mul, zsmul_succ', add_comm]
  zsmul_neg' := sorry --by intros; ext <;> simp [add_mul]
  sub_eq_add_neg := by intros; ext <;> apply sub_eq_add_neg }

instance : AddCommGroupWithOne (QuadRing F a b) :=
{ instAddCommMonoidWithOneQuadRing F a b,
  instAddCommGroupQuadRing F a b with
  natCast := λ n => ↑(n : F)
  intCast := λ n => ↑(n : F)
  intCast_ofNat := by intros; simp
  intCast_negSucc := by intros; simp [-neg_add_rev, neg_add, ← sub_eq_add_neg] }

@[simp] lemma coe_coe_int (n : ℤ) : ((n : F) : QuadRing F a b) = n := rfl

@[simp] lemma coe_nat_b1 (n : ℕ) : (n : QuadRing F a b).b1 = n := rfl
@[simp] lemma coe_nat_b2 (n : ℕ) : (n : QuadRing F a b).b2 = 0 := rfl

@[simp] lemma coe_nat_add (r s : ℕ) : (↑(r + s) : QuadRing F a b) = r + s :=
by ext <;> simp only [coe_nat_b1, coe_nat_b2, add_b1, add_b2, Nat.cast_add, add_zero]

@[simp] lemma coe_int_b1 (n : ℤ) : (n : QuadRing F a b).b1 = n := rfl
@[simp] lemma coe_int_b2 (n : ℤ) : (n : QuadRing F a b).b2 = 0 := rfl

-- This used to be a non-defeq diamond, we solve this by supplying a custom value for
-- `add_group_with_one.int_cast`
-- example (a b : ℤ) (n) :
--   @@coe (@@coe_to_lift (QuadRing.CoeT ℤ a b)) n = @@coe (@@coe_to_lift int.cast_coe) n :=
-- rfl

@[simp] lemma coe_int_add (r s : ℤ) : (↑(r + s) : QuadRing F a b) = r + s :=
by ext <;> simp only [coe_int_b1, coe_int_b2, add_b1, add_b2, Int.cast_add, add_zero]

instance : Mul (QuadRing F a b) :=
⟨λ z w => ⟨z.1 * w.1 + z.2 * w.2 * b ,z.2 * w.1 + z.1 * w.2 + z.2 * w.2 * a⟩⟩

@[simp] lemma mul_b1 (z w : QuadRing F a b) :
  (z * w).b1 = z.1 * w.1 + z.2 * w.2 * b := rfl
@[simp] lemma mul_b2 (z w : QuadRing F a b) :
  (z * w).b2 = z.2 * w.1 + z.1 * w.2 + z.2 * w.2 * a := rfl

@[simp] lemma coe_mul (r s : F) : ((r * s : F) : QuadRing F a b) = r * s :=
by apply (QuadRing.ext_iff _ _).2; simp [mul_comm]

instance : CommSemiring (QuadRing F a b) :=
{ instAddCommMonoidWithOneQuadRing F a b with
  zero := (0 : QuadRing F a b)
  add := (.+.)
  one := 1
  mul := (.*.)
  nsmul := (.•.)
  npow := npowRec
  mul_comm := by sorry
  mul_one := by sorry
  one_mul := by sorry
  mul_assoc:= by sorry
  mul_zero := by sorry
  zero_mul := by sorry
  right_distrib := by sorry
  left_distrib := by sorry }

instance : CommRing (QuadRing F a b) :=
{ instAddCommGroupWithOneQuadRing F a b,
  instCommSemiringQuadRing F a b with
  zero := (0 : QuadRing F a b)
  add := (.+.)
  neg := Neg.neg
  sub := Sub.sub
  one := 1,
  mul := (.*.)
  nsmul := (.•.)
  npow := npowRec
  natCast := λ n => n
  zsmul := (.•.)
  intCast := λ n => n }

instance [Nontrivial F] : Nontrivial (QuadRing F a b) :=
⟨⟨0, 1, by simp [QuadRing.ext_iff]⟩⟩

-- instance [CharZero F] : char_zero (QuadRing F a b) :=
-- ⟨(coe_injective F a b).comp nat.cast_injective⟩

-- @[simp] lemma coe_pow (x : F) : ∀ (n : ℕ), (↑(x ^ n) : QuadRing F a b) = x ^ n
-- | 0 => by simp
-- | (n + 1) = by rw [pow_succ, coe_mul, coe_pow n, pow_succ]

#eval ((⟨1,2⟩ : QuadRing ℚ 0 5) ^2 : QuadRing ℚ 0 5)


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import order.disjoint
import order.with_bot

/-!

# The order on `Prop`

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

Instances on `Prop` such as `distrib_lattice`, `bounded_order`, `linear_order`.

-/
/-- Propositions form a distributive lattice. -/
instance Prop.distrib_lattice : distrib_lattice Prop :=
{ sup          := or,
  le_sup_left  := @or.inl,
  le_sup_right := @or.inr,
  sup_le       := λ a b c, or.rec,

  inf          := and,
  inf_le_left  := @and.left,
  inf_le_right := @and.right,
  le_inf       := λ a b c Hab Hac Ha, and.intro (Hab Ha) (Hac Ha),
  le_sup_inf   := λ a b c, or_and_distrib_left.2,
  ..Prop.partial_order }

/-- Propositions form a bounded order. -/
instance Prop.bounded_order : bounded_order Prop :=
{ top          := true,
  le_top       := λ a Ha, true.intro,
  bot          := false,
  bot_le       := @false.elim }

lemma Prop.bot_eq_false : (⊥ : Prop) = false := rfl

lemma Prop.top_eq_true : (⊤ : Prop) = true := rfl

instance Prop.le_is_total : is_total Prop (≤) :=
⟨λ p q, by { change (p → q) ∨ (q → p), tauto! }⟩

noncomputable instance Prop.linear_order : linear_order Prop :=
by classical; exact lattice.to_linear_order Prop

@[simp] lemma sup_Prop_eq : (⊔) = (∨) := rfl
@[simp] lemma inf_Prop_eq : (⊓) = (∧) := rfl

namespace pi

variables {ι : Type*} {α' : ι → Type*} [Π i, partial_order (α' i)]

lemma disjoint_iff [Π i, order_bot (α' i)] {f g : Π i, α' i} :
  disjoint f g ↔ ∀ i, disjoint (f i) (g i) :=
begin
  split,
  { intros h i x hf hg,
    classical,
    refine (update_le_iff.mp $
    -- this line doesn't work
      h (update_le_iff.mpr ⟨hf, λ _ _, _⟩) (update_le_iff.mpr ⟨hg, λ _ _, _⟩)).1,
    { exact ⊥},
    { exact bot_le },
    { exact bot_le }, },
  { intros h x hf hg i,
    apply h i (hf i) (hg i) },
end

lemma codisjoint_iff [Π i, order_top (α' i)] {f g : Π i, α' i} :
  codisjoint f g ↔ ∀ i, codisjoint (f i) (g i) :=
@disjoint_iff _ (λ i, (α' i)ᵒᵈ) _ _ _ _

lemma is_compl_iff [Π i, bounded_order (α' i)] {f g : Π i, α' i} :
  is_compl f g ↔ ∀ i, is_compl (f i) (g i) :=
by simp_rw [is_compl_iff, disjoint_iff, codisjoint_iff, forall_and_distrib]

end pi

@[simp] lemma Prop.disjoint_iff {P Q : Prop} : disjoint P Q ↔ ¬(P ∧ Q) := disjoint_iff_inf_le
@[simp] lemma Prop.codisjoint_iff {P Q : Prop} : codisjoint P Q ↔ P ∨ Q :=
codisjoint_iff_le_sup.trans $ forall_const _
@[simp] lemma Prop.is_compl_iff {P Q : Prop} : is_compl P Q ↔ ¬(P ↔ Q) :=
begin
  rw [is_compl_iff, Prop.disjoint_iff, Prop.codisjoint_iff, not_iff],
  classical,
  tauto,
end


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.associated
import tactic.ring

/-- The ring of integers adjoined with a square root of `d`.
  These have the form `a + b √d` where `a b : ℤ`. The components
  are called `re` and `im` by analogy to the negative `d` case. -/
structure zsqrtd (d : ℤ) :=
(re : ℤ)
(im : ℤ)

prefix `ℤ√`:100 := zsqrtd

namespace zsqrtd
section
parameters {d : ℤ}

instance : decidable_eq ℤ√d :=
by tactic.mk_dec_eq_instance

theorem ext : ∀ {z w : ℤ√d}, z = w ↔ z.re = w.re ∧ z.im = w.im
| ⟨x, y⟩ ⟨x', y'⟩ := ⟨λ h, by injection h; split; assumption,
                      λ ⟨h₁, h₂⟩, by congr; assumption⟩

/-- Convert an integer to a `ℤ√d` -/
def of_int (n : ℤ) : ℤ√d := ⟨n, 0⟩
theorem of_int_re (n : ℤ) : (of_int n).re = n := rfl
theorem of_int_im (n : ℤ) : (of_int n).im = 0 := rfl

/-- The zero of the ring -/
def zero : ℤ√d := of_int 0
instance : has_zero ℤ√d := ⟨zsqrtd.zero⟩
@[simp] theorem zero_re : (0 : ℤ√d).re = 0 := rfl
@[simp] theorem zero_im : (0 : ℤ√d).im = 0 := rfl

instance : inhabited ℤ√d := ⟨0⟩

/-- The one of the ring -/
def one : ℤ√d := of_int 1
instance : has_one ℤ√d := ⟨zsqrtd.one⟩
@[simp] theorem one_re : (1 : ℤ√d).re = 1 := rfl
@[simp] theorem one_im : (1 : ℤ√d).im = 0 := rfl

/-- The representative of `√d` in the ring -/
def sqrtd : ℤ√d := ⟨0, 1⟩
@[simp] theorem sqrtd_re : (sqrtd : ℤ√d).re = 0 := rfl
@[simp] theorem sqrtd_im : (sqrtd : ℤ√d).im = 1 := rfl

/-- Addition of elements of `ℤ√d` -/
def add : ℤ√d → ℤ√d → ℤ√d
| ⟨x, y⟩ ⟨x', y'⟩ := ⟨x + x', y + y'⟩
instance : has_add ℤ√d := ⟨zsqrtd.add⟩
@[simp] theorem add_def (x y x' y' : ℤ) :
  (⟨x, y⟩ + ⟨x', y'⟩ : ℤ√d) = ⟨x + x', y + y'⟩ := rfl
@[simp] theorem add_re : ∀ z w : ℤ√d, (z + w).re = z.re + w.re
| ⟨x, y⟩ ⟨x', y'⟩ := rfl
@[simp] theorem add_im : ∀ z w : ℤ√d, (z + w).im = z.im + w.im
| ⟨x, y⟩ ⟨x', y'⟩ := rfl

@[simp] theorem bit0_re (z) : (bit0 z : ℤ√d).re = bit0 z.re := add_re _ _
@[simp] theorem bit0_im (z) : (bit0 z : ℤ√d).im = bit0 z.im := add_im _ _

@[simp] theorem bit1_re (z) : (bit1 z : ℤ√d).re = bit1 z.re := by simp [bit1]
@[simp] theorem bit1_im (z) : (bit1 z : ℤ√d).im = bit0 z.im := by simp [bit1]

/-- Negation in `ℤ√d` -/
def neg : ℤ√d → ℤ√d
| ⟨x, y⟩ := ⟨-x, -y⟩
instance : has_neg ℤ√d := ⟨zsqrtd.neg⟩
@[simp] theorem neg_re : ∀ z : ℤ√d, (-z).re = -z.re
| ⟨x, y⟩ := rfl
@[simp] theorem neg_im : ∀ z : ℤ√d, (-z).im = -z.im
| ⟨x, y⟩ := rfl

/-- Multiplication in `ℤ√d` -/
def mul : ℤ√d → ℤ√d → ℤ√d
| ⟨x, y⟩ ⟨x', y'⟩ := ⟨x * x' + d * y * y', x * y' + y * x'⟩
instance : has_mul ℤ√d := ⟨zsqrtd.mul⟩
@[simp] theorem mul_re : ∀ z w : ℤ√d, (z * w).re = z.re * w.re + d * z.im * w.im
| ⟨x, y⟩ ⟨x', y'⟩ := rfl
@[simp] theorem mul_im : ∀ z w : ℤ√d, (z * w).im = z.re * w.im + z.im * w.re
| ⟨x, y⟩ ⟨x', y'⟩ := rfl

instance : comm_ring ℤ√d :=
by refine_struct
{ add            := (+),
  zero           := (0 : ℤ√d),
  neg            := has_neg.neg,
  mul            := (*),
  sub            := λ a b, a + -b,
  one            := 1,
  npow           := @npow_rec _ ⟨1⟩ ⟨(*)⟩,
  nsmul          := @nsmul_rec _ ⟨0⟩ ⟨(+)⟩,
  gsmul          := @gsmul_rec _ ⟨0⟩ ⟨(+)⟩ ⟨zsqrtd.neg⟩ };
intros; try { refl }; simp [ext, add_mul, mul_add, add_comm, add_left_comm, mul_comm, mul_left_comm]

instance : add_comm_monoid ℤ√d    := by apply_instance
instance : add_monoid ℤ√d         := by apply_instance
instance : monoid ℤ√d             := by apply_instance
instance : comm_monoid ℤ√d        := by apply_instance
instance : comm_semigroup ℤ√d     := by apply_instance
instance : semigroup ℤ√d          := by apply_instance
instance : add_comm_semigroup ℤ√d := by apply_instance
instance : add_semigroup ℤ√d      := by apply_instance
instance : comm_semiring ℤ√d      := by apply_instance
instance : semiring ℤ√d           := by apply_instance
instance : ring ℤ√d               := by apply_instance
instance : distrib ℤ√d            := by apply_instance

/-- Conjugation in `ℤ√d`. The conjugate of `a + b √d` is `a - b √d`. -/
def conj : ℤ√d → ℤ√d
| ⟨x, y⟩ := ⟨x, -y⟩
@[simp] theorem conj_re : ∀ z : ℤ√d, (conj z).re = z.re
| ⟨x, y⟩ := rfl
@[simp] theorem conj_im : ∀ z : ℤ√d, (conj z).im = -z.im
| ⟨x, y⟩ := rfl

/-- `conj` as an `add_monoid_hom`. -/
def conj_hom : ℤ√d →+ ℤ√d :=
{ to_fun := conj,
  map_add' := λ ⟨a, ai⟩ ⟨b, bi⟩, ext.mpr ⟨rfl, neg_add _ _⟩,
  map_zero' := ext.mpr ⟨rfl, neg_zero⟩ }

@[simp] lemma conj_zero : conj (0 : ℤ√d) = 0 :=
conj_hom.map_zero

@[simp] lemma conj_one : conj (1 : ℤ√d) = 1 :=
by simp only [zsqrtd.ext, zsqrtd.conj_re, zsqrtd.conj_im, zsqrtd.one_im, neg_zero, eq_self_iff_true,
  and_self]

@[simp] lemma conj_neg (x : ℤ√d) : (-x).conj = -x.conj :=
conj_hom.map_neg x

@[simp] lemma conj_add (x y : ℤ√d) : (x + y).conj = x.conj + y.conj :=
conj_hom.map_add x y

@[simp] lemma conj_sub (x y : ℤ√d) : (x - y).conj = x.conj - y.conj :=
conj_hom.map_sub x y

@[simp] lemma conj_conj {d : ℤ} (x : ℤ√d) : x.conj.conj = x :=
by simp only [ext, true_and, conj_re, eq_self_iff_true, neg_neg, conj_im]

instance : nontrivial ℤ√d :=
⟨⟨0, 1, dec_trivial⟩⟩

@[simp] theorem coe_nat_re (n : ℕ) : (n : ℤ√d).re = n :=
by induction n; simp *
@[simp] theorem coe_nat_im (n : ℕ) : (n : ℤ√d).im = 0 :=
by induction n; simp *
theorem coe_nat_val (n : ℕ) : (n : ℤ√d) = ⟨n, 0⟩ :=
by simp [ext]

@[simp] theorem coe_int_re (n : ℤ) : (n : ℤ√d).re = n :=
by cases n; simp [*, int.of_nat_eq_coe, int.neg_succ_of_nat_eq]
@[simp] theorem coe_int_im (n : ℤ) : (n : ℤ√d).im = 0 :=
by cases n; simp *
theorem coe_int_val (n : ℤ) : (n : ℤ√d) = ⟨n, 0⟩ :=
by simp [ext]

instance : char_zero ℤ√d :=
{ cast_injective := λ m n, by simp [ext] }

@[simp] theorem of_int_eq_coe (n : ℤ) : (of_int n : ℤ√d) = n :=
by simp [ext, of_int_re, of_int_im]

@[simp] theorem smul_val (n x y : ℤ) : (n : ℤ√d) * ⟨x, y⟩ = ⟨n * x, n * y⟩ :=
by simp [ext]

@[simp] theorem muld_val (x y : ℤ) : sqrtd * ⟨x, y⟩ = ⟨d * y, x⟩ :=
by simp [ext]

@[simp] theorem dmuld : sqrtd * sqrtd = d :=
by simp [ext]

@[simp] theorem smuld_val (n x y : ℤ) : sqrtd * (n : ℤ√d) * ⟨x, y⟩ = ⟨d * n * y, n * x⟩ :=
by simp [ext]

theorem decompose {x y : ℤ} : (⟨x, y⟩ : ℤ√d) = x + sqrtd * y :=
by simp [ext]

theorem mul_conj {x y : ℤ} : (⟨x, y⟩ * conj ⟨x, y⟩ : ℤ√d) = x * x - d * y * y :=
by simp [ext, sub_eq_add_neg, mul_comm]

theorem conj_mul {a b : ℤ√d} : conj (a * b) = conj a * conj b :=
by { simp [ext], ring }

protected lemma coe_int_add (m n : ℤ) : (↑(m + n) : ℤ√d) = ↑m + ↑n :=
(int.cast_ring_hom _).map_add _ _
protected lemma coe_int_sub (m n : ℤ) : (↑(m - n) : ℤ√d) = ↑m - ↑n :=
(int.cast_ring_hom _).map_sub _ _
protected lemma coe_int_mul (m n : ℤ) : (↑(m * n) : ℤ√d) = ↑m * ↑n :=
(int.cast_ring_hom _).map_mul _ _
protected lemma coe_int_inj {m n : ℤ} (h : (↑m : ℤ√d) = ↑n) : m = n :=
by simpa using congr_arg re h

lemma coe_int_dvd_iff {d : ℤ} (z : ℤ) (a : ℤ√d) : ↑z ∣ a ↔ z ∣ a.re ∧ z ∣ a.im :=
begin
  split,
  { rintro ⟨x, rfl⟩,
    simp only [add_zero, coe_int_re, zero_mul, mul_im, dvd_mul_right, and_self, mul_re, mul_zero,
      coe_int_im] },
  { rintro ⟨⟨r, hr⟩, ⟨i, hi⟩⟩,
    use ⟨r, i⟩,
    rw [smul_val, ext],
    exact ⟨hr, hi⟩ },
end

/-- Read `sq_le a c b d` as `a √c ≤ b √d` -/
def sq_le (a c b d : ℕ) : Prop := c*a*a ≤ d*b*b

theorem sq_le_of_le {c d x y z w : ℕ} (xz : z ≤ x) (yw : y ≤ w) (xy : sq_le x c y d) :
  sq_le z c w d :=
le_trans (mul_le_mul (nat.mul_le_mul_left _ xz) xz (nat.zero_le _) (nat.zero_le _)) $
  le_trans xy (mul_le_mul (nat.mul_le_mul_left _ yw) yw (nat.zero_le _) (nat.zero_le _))

theorem sq_le_add_mixed {c d x y z w : ℕ} (xy : sq_le x c y d) (zw : sq_le z c w d) :
  c * (x * z) ≤ d * (y * w) :=
nat.mul_self_le_mul_self_iff.2 $
by simpa [mul_comm, mul_left_comm] using
   mul_le_mul xy zw (nat.zero_le _) (nat.zero_le _)

theorem sq_le_add {c d x y z w : ℕ} (xy : sq_le x c y d) (zw : sq_le z c w d) :
  sq_le (x + z) c (y + w) d :=
begin
  have xz := sq_le_add_mixed xy zw,
  simp [sq_le, mul_assoc] at xy zw,
  simp [sq_le, mul_add, mul_comm, mul_left_comm, add_le_add, *]
end

theorem sq_le_cancel {c d x y z w : ℕ} (zw : sq_le y d x c) (h : sq_le (x + z) c (y + w) d) :
  sq_le z c w d :=
begin
  apply le_of_not_gt,
  intro l,
  refine not_le_of_gt _ h,
  simp [sq_le, mul_add, mul_comm, mul_left_comm, add_assoc],
  have hm := sq_le_add_mixed zw (le_of_lt l),
  simp [sq_le, mul_assoc] at l zw,
  exact lt_of_le_of_lt (add_le_add_right zw _)
    (add_lt_add_left (add_lt_add_of_le_of_lt hm (add_lt_add_of_le_of_lt hm l)) _)
end

theorem sq_le_smul {c d x y : ℕ} (n : ℕ) (xy : sq_le x c y d) : sq_le (n * x) c (n * y) d :=
by simpa [sq_le, mul_left_comm, mul_assoc] using
   nat.mul_le_mul_left (n * n) xy

theorem sq_le_mul {d x y z w : ℕ} :
  (sq_le x 1 y d → sq_le z 1 w d → sq_le (x * w + y * z) d (x * z + d * y * w) 1) ∧
  (sq_le x 1 y d → sq_le w d z 1 → sq_le (x * z + d * y * w) 1 (x * w + y * z) d) ∧
  (sq_le y d x 1 → sq_le z 1 w d → sq_le (x * z + d * y * w) 1 (x * w + y * z) d) ∧
  (sq_le y d x 1 → sq_le w d z 1 → sq_le (x * w + y * z) d (x * z + d * y * w) 1) :=
by refine ⟨_, _, _, _⟩; {
  intros xy zw,
  have := int.mul_nonneg (sub_nonneg_of_le (int.coe_nat_le_coe_nat_of_le xy))
                         (sub_nonneg_of_le (int.coe_nat_le_coe_nat_of_le zw)),
  refine int.le_of_coe_nat_le_coe_nat (le_of_sub_nonneg _),
  convert this,
  simp only [one_mul, int.coe_nat_add, int.coe_nat_mul],
  ring }

/-- "Generalized" `nonneg`. `nonnegg c d x y` means `a √c + b √d ≥ 0`;
  we are interested in the case `c = 1` but this is more symmetric -/
def nonnegg (c d : ℕ) : ℤ → ℤ → Prop
| (a : ℕ) (b : ℕ) := true
| (a : ℕ) -[1+ b] := sq_le (b+1) c a d
| -[1+ a] (b : ℕ) := sq_le (a+1) d b c
| -[1+ a] -[1+ b] := false

theorem nonnegg_comm {c d : ℕ} {x y : ℤ} : nonnegg c d x y = nonnegg d c y x :=
by induction x; induction y; refl

theorem nonnegg_neg_pos {c d} : Π {a b : ℕ}, nonnegg c d (-a) b ↔ sq_le a d b c
| 0     b := ⟨by simp [sq_le, nat.zero_le], λa, trivial⟩
| (a+1) b := by rw ← int.neg_succ_of_nat_coe; refl

theorem nonnegg_pos_neg {c d} {a b : ℕ} : nonnegg c d a (-b) ↔ sq_le b c a d :=
by rw nonnegg_comm; exact nonnegg_neg_pos

theorem nonnegg_cases_right {c d} {a : ℕ} :
  Π {b : ℤ}, (Π x : ℕ, b = -x → sq_le x c a d) → nonnegg c d a b
| (b:nat) h := trivial
| -[1+ b] h := h (b+1) rfl

theorem nonnegg_cases_left {c d} {b : ℕ} {a : ℤ} (h : Π x : ℕ, a = -x → sq_le x d b c) :
  nonnegg c d a b :=
cast nonnegg_comm (nonnegg_cases_right h)

section norm

def norm (n : ℤ√d) : ℤ := n.re * n.re - d * n.im * n.im
lemma norm_def (n : ℤ√d) : n.norm = n.re * n.re - d * n.im * n.im := rfl

@[simp] lemma norm_zero : norm 0 = 0 := by simp [norm]

@[simp] lemma norm_one : norm 1 = 1 := by simp [norm]

@[simp] lemma norm_int_cast (n : ℤ) : norm n = n * n := by simp [norm]

@[simp] lemma norm_nat_cast (n : ℕ) : norm n = n * n := norm_int_cast n

@[simp] lemma norm_mul (n m : ℤ√d) : norm (n * m) = norm n * norm m :=
by { simp only [norm, mul_im, mul_re], ring }

/-- `norm` as a `monoid_hom`. -/
def norm_monoid_hom : ℤ√d →* ℤ :=
{ to_fun := norm,
  map_mul' := norm_mul,
  map_one' := norm_one }

lemma norm_eq_mul_conj (n : ℤ√d) : (norm n : ℤ√d) = n * n.conj :=
by cases n; simp [norm, conj, zsqrtd.ext, mul_comm, sub_eq_add_neg]

@[simp] lemma norm_neg (x : ℤ√d) : (-x).norm = x.norm :=
coe_int_inj $ by simp only [norm_eq_mul_conj, conj_neg, neg_mul_eq_neg_mul_symm,
  mul_neg_eq_neg_mul_symm, neg_neg]

@[simp] lemma norm_conj (x : ℤ√d) : x.conj.norm = x.norm :=
coe_int_inj $ by simp only [norm_eq_mul_conj, conj_conj, mul_comm]

instance : is_monoid_hom norm :=
{ map_one := norm_one, map_mul := norm_mul }

lemma norm_nonneg (hd : d ≤ 0) (n : ℤ√d) : 0 ≤ n.norm :=
add_nonneg (mul_self_nonneg _)
  (by rw [mul_assoc, neg_mul_eq_neg_mul];
    exact (mul_nonneg (neg_nonneg.2 hd) (mul_self_nonneg _)))

lemma norm_eq_one_iff {x : ℤ√d} : x.norm.nat_abs = 1 ↔ is_unit x :=
⟨λ h, is_unit_iff_dvd_one.2 $
  (le_total 0 (norm x)).cases_on
    (λ hx, show x ∣ 1, from ⟨x.conj,
      by rwa [← int.coe_nat_inj', int.nat_abs_of_nonneg hx,
        ← @int.cast_inj (ℤ√d) _ _, norm_eq_mul_conj, eq_comm] at h⟩)
    (λ hx, show x ∣ 1, from ⟨- x.conj,
      by rwa [← int.coe_nat_inj', int.of_nat_nat_abs_of_nonpos hx,
        ← @int.cast_inj (ℤ√d) _ _, int.cast_neg, norm_eq_mul_conj, neg_mul_eq_mul_neg,
        eq_comm] at h⟩),
λ h, let ⟨y, hy⟩ := is_unit_iff_dvd_one.1 h in begin
  have := congr_arg (int.nat_abs ∘ norm) hy,
  rw [function.comp_app, function.comp_app, norm_mul, int.nat_abs_mul,
    norm_one, int.nat_abs_one, eq_comm, nat.mul_eq_one_iff] at this,
  exact this.1
end⟩

lemma is_unit_iff_norm_is_unit {d : ℤ} (z : ℤ√d) : is_unit z ↔ is_unit z.norm :=
by rw [int.is_unit_iff_nat_abs_eq, norm_eq_one_iff]

lemma norm_eq_one_iff' {d : ℤ} (hd : d ≤ 0) (z : ℤ√d) : z.norm = 1 ↔ is_unit z :=
by rw [←norm_eq_one_iff, ←int.coe_nat_inj', int.nat_abs_of_nonneg (norm_nonneg hd z),
  int.coe_nat_one]

lemma norm_eq_zero_iff {d : ℤ} (hd : d < 0) (z : ℤ√d) : z.norm = 0 ↔ z = 0 :=
begin
  split,
  { intro h,
    rw [ext, zero_re, zero_im],
    rw [norm_def, sub_eq_add_neg, mul_assoc] at h,
    have left := mul_self_nonneg z.re,
    have right := neg_nonneg.mpr (mul_nonpos_of_nonpos_of_nonneg hd.le (mul_self_nonneg z.im)),
    obtain ⟨ha, hb⟩ := (add_eq_zero_iff_eq_zero_of_nonneg left right).mp h,
    split; apply eq_zero_of_mul_self_eq_zero,
    { exact ha },
    { rw [neg_eq_zero, mul_eq_zero] at hb,
      exact hb.resolve_left hd.ne } },
  { rintro rfl, exact norm_zero }
end

lemma norm_eq_of_associated {d : ℤ} (hd : d ≤ 0) {x y : ℤ√d} (h : associated x y) :
  x.norm = y.norm :=
begin
  obtain ⟨u, rfl⟩ := h,
  rw [norm_mul, (norm_eq_one_iff' hd _).mpr u.is_unit, mul_one],
end

end norm

end

section
parameter {d : ℕ}

/-- Nonnegativity of an element of `ℤ√d`. -/
def nonneg : ℤ√d → Prop | ⟨a, b⟩ := nonnegg d 1 a b

protected def le (a b : ℤ√d) : Prop := nonneg (b - a)

instance : has_le ℤ√d := ⟨zsqrtd.le⟩

protected def lt (a b : ℤ√d) : Prop := ¬(b ≤ a)

instance : has_lt ℤ√d := ⟨zsqrtd.lt⟩

instance decidable_nonnegg (c d a b) : decidable (nonnegg c d a b) :=
by cases a; cases b; repeat {rw int.of_nat_eq_coe}; unfold nonnegg sq_le; apply_instance

instance decidable_nonneg : Π (a : ℤ√d), decidable (nonneg a)
| ⟨a, b⟩ := zsqrtd.decidable_nonnegg _ _ _ _

instance decidable_le (a b : ℤ√d) : decidable (a ≤ b) := decidable_nonneg _

theorem nonneg_cases : Π {a : ℤ√d}, nonneg a → ∃ x y : ℕ, a = ⟨x, y⟩ ∨ a = ⟨x, -y⟩ ∨ a = ⟨-x, y⟩
| ⟨(x : ℕ), (y : ℕ)⟩ h := ⟨x, y, or.inl rfl⟩
| ⟨(x : ℕ), -[1+ y]⟩ h := ⟨x, y+1, or.inr $ or.inl rfl⟩
| ⟨-[1+ x], (y : ℕ)⟩ h := ⟨x+1, y, or.inr $ or.inr rfl⟩
| ⟨-[1+ x], -[1+ y]⟩ h := false.elim h

lemma nonneg_add_lem {x y z w : ℕ} (xy : nonneg ⟨x, -y⟩) (zw : nonneg ⟨-z, w⟩) :
  nonneg (⟨x, -y⟩ + ⟨-z, w⟩) :=
have nonneg ⟨int.sub_nat_nat x z, int.sub_nat_nat w y⟩, from int.sub_nat_nat_elim x z
  (λm n i, sq_le y d m 1 → sq_le n 1 w d → nonneg ⟨i, int.sub_nat_nat w y⟩)
  (λj k, int.sub_nat_nat_elim w y
    (λm n i, sq_le n d (k + j) 1 → sq_le k 1 m d → nonneg ⟨int.of_nat j, i⟩)
    (λm n xy zw, trivial)
    (λm n xy zw, sq_le_cancel zw xy))
  (λj k, int.sub_nat_nat_elim w y
    (λm n i, sq_le n d k 1 → sq_le (k + j + 1) 1 m d → nonneg ⟨-[1+ j], i⟩)
    (λm n xy zw, sq_le_cancel xy zw)
    (λm n xy zw, let t := nat.le_trans zw (sq_le_of_le (nat.le_add_right n (m+1)) (le_refl _) xy) in
      have k + j + 1 ≤ k, from nat.mul_self_le_mul_self_iff.2 (by repeat{rw one_mul at t}; exact t),
      absurd this (not_le_of_gt $ nat.succ_le_succ $ nat.le_add_right _ _))) (nonnegg_pos_neg.1 xy)
        (nonnegg_neg_pos.1 zw),
show nonneg ⟨_, _⟩, by rw [neg_add_eq_sub];
  rwa [int.sub_nat_nat_eq_coe,int.sub_nat_nat_eq_coe] at this

theorem nonneg_add {a b : ℤ√d} (ha : nonneg a) (hb : nonneg b) : nonneg (a + b) :=
begin
  rcases nonneg_cases ha with ⟨x, y, rfl|rfl|rfl⟩;
  rcases nonneg_cases hb with ⟨z, w, rfl|rfl|rfl⟩; dsimp [add, nonneg] at ha hb ⊢,
  { trivial },
  { refine nonnegg_cases_right (λi h, sq_le_of_le _ _ (nonnegg_pos_neg.1 hb)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (@int.le.intro _ _ y (by simp [add_comm, *]))) },
    { apply nat.le_add_left } },
  { refine nonnegg_cases_left (λi h, sq_le_of_le _ _ (nonnegg_neg_pos.1 hb)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (@int.le.intro _ _ x (by simp [add_comm, *]))) },
    { apply nat.le_add_left } },
  { refine nonnegg_cases_right (λi h, sq_le_of_le _ _ (nonnegg_pos_neg.1 ha)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (@int.le.intro _ _ w (by simp *))) },
    { apply nat.le_add_right } },
  { simpa [add_comm] using
      nonnegg_pos_neg.2 (sq_le_add (nonnegg_pos_neg.1 ha) (nonnegg_pos_neg.1 hb)) },
  { exact nonneg_add_lem ha hb },
  { refine nonnegg_cases_left (λi h, sq_le_of_le _ _ (nonnegg_neg_pos.1 ha)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (@int.le.intro _ _ z (by simp *))) },
    { apply nat.le_add_right } },
  { rw [add_comm, add_comm ↑y], exact nonneg_add_lem hb ha },
  { simpa [add_comm] using
      nonnegg_neg_pos.2 (sq_le_add (nonnegg_neg_pos.1 ha) (nonnegg_neg_pos.1 hb)) },
end

theorem le_refl (a : ℤ√d) : a ≤ a := show nonneg (a - a), by simp

protected theorem le_trans {a b c : ℤ√d} (ab : a ≤ b) (bc : b ≤ c) : a ≤ c :=
have nonneg (b - a + (c - b)), from nonneg_add ab bc,
by simpa [sub_add_sub_cancel']

theorem nonneg_iff_zero_le {a : ℤ√d} : nonneg a ↔ 0 ≤ a := show _ ↔ nonneg _, by simp

theorem le_of_le_le {x y z w : ℤ} (xz : x ≤ z) (yw : y ≤ w) : (⟨x, y⟩ : ℤ√d) ≤ ⟨z, w⟩ :=
show nonneg ⟨z - x, w - y⟩, from
match z - x, w - y, int.le.dest_sub xz, int.le.dest_sub yw with ._, ._, ⟨a, rfl⟩, ⟨b, rfl⟩ :=
  trivial end

theorem le_arch (a : ℤ√d) : ∃n : ℕ, a ≤ n :=
let ⟨x, y, (h : a ≤ ⟨x, y⟩)⟩ := show ∃x y : ℕ, nonneg (⟨x, y⟩ + -a), from match -a with
| ⟨int.of_nat x, int.of_nat y⟩ := ⟨0, 0, trivial⟩
| ⟨int.of_nat x, -[1+ y]⟩      := ⟨0, y+1, by simp [int.neg_succ_of_nat_coe, add_assoc]⟩
| ⟨-[1+ x],      int.of_nat y⟩ := ⟨x+1, 0, by simp [int.neg_succ_of_nat_coe, add_assoc]⟩
| ⟨-[1+ x],      -[1+ y]⟩      := ⟨x+1, y+1, by simp [int.neg_succ_of_nat_coe, add_assoc]⟩
end in begin
  refine ⟨x + d*y, zsqrtd.le_trans h _⟩,
  rw [← int.cast_coe_nat, ← of_int_eq_coe],
  change nonneg ⟨(↑x + d*y) - ↑x, 0-↑y⟩,
  cases y with y,
  { simp },
  have h : ∀y, sq_le y d (d * y) 1 := λ y,
    by simpa [sq_le, mul_comm, mul_left_comm] using
       nat.mul_le_mul_right (y * y) (nat.le_mul_self d),
  rw [show (x:ℤ) + d * nat.succ y - x = d * nat.succ y, by simp],
  exact h (y+1)
end

protected theorem nonneg_total : Π (a : ℤ√d), nonneg a ∨ nonneg (-a)
| ⟨(x : ℕ), (y : ℕ)⟩ := or.inl trivial
| ⟨-[1+ x], -[1+ y]⟩ := or.inr trivial
| ⟨0,       -[1+ y]⟩ := or.inr trivial
| ⟨-[1+ x], 0⟩       := or.inr trivial
| ⟨(x+1:ℕ), -[1+ y]⟩ := nat.le_total
| ⟨-[1+ x], (y+1:ℕ)⟩ := nat.le_total

protected theorem le_total (a b : ℤ√d) : a ≤ b ∨ b ≤ a :=
let t := nonneg_total (b - a) in by rw [show -(b-a) = a-b, from neg_sub b a] at t; exact t

instance : preorder ℤ√d :=
{ le               := zsqrtd.le,
  le_refl          := zsqrtd.le_refl,
  le_trans         := @zsqrtd.le_trans,
  lt               := zsqrtd.lt,
  lt_iff_le_not_le := λ a b,
    (and_iff_right_of_imp (zsqrtd.le_total _ _).resolve_left).symm }

protected theorem add_le_add_left (a b : ℤ√d) (ab : a ≤ b) (c : ℤ√d) : c + a ≤ c + b :=
show nonneg _, by rw add_sub_add_left_eq_sub; exact ab

protected theorem le_of_add_le_add_left (a b c : ℤ√d) (h : c + a ≤ c + b) : a ≤ b :=
by simpa using zsqrtd.add_le_add_left _ _ h (-c)

protected theorem add_lt_add_left (a b : ℤ√d) (h : a < b) (c) : c + a < c + b :=
λ h', h (zsqrtd.le_of_add_le_add_left _ _ _ h')

theorem nonneg_smul {a : ℤ√d} {n : ℕ} (ha : nonneg a) : nonneg (n * a) :=
by rw ← int.cast_coe_nat; exact match a, nonneg_cases ha, ha with
| ._, ⟨x, y, or.inl rfl⟩,          ha := by rw smul_val; trivial
| ._, ⟨x, y, or.inr $ or.inl rfl⟩, ha := by rw smul_val; simpa using
  nonnegg_pos_neg.2 (sq_le_smul n $ nonnegg_pos_neg.1 ha)
| ._, ⟨x, y, or.inr $ or.inr rfl⟩, ha := by rw smul_val; simpa using
  nonnegg_neg_pos.2 (sq_le_smul n $ nonnegg_neg_pos.1 ha)
end

theorem nonneg_muld {a : ℤ√d} (ha : nonneg a) : nonneg (sqrtd * a) :=
by refine match a, nonneg_cases ha, ha with
| ._, ⟨x, y, or.inl rfl⟩,          ha := trivial
| ._, ⟨x, y, or.inr $ or.inl rfl⟩, ha := by simp; apply nonnegg_neg_pos.2;
  simpa [sq_le, mul_comm, mul_left_comm] using
    nat.mul_le_mul_left d (nonnegg_pos_neg.1 ha)
| ._, ⟨x, y, or.inr $ or.inr rfl⟩, ha := by simp; apply nonnegg_pos_neg.2;
  simpa [sq_le, mul_comm, mul_left_comm] using
    nat.mul_le_mul_left d (nonnegg_neg_pos.1 ha)
end

theorem nonneg_mul_lem {x y : ℕ} {a : ℤ√d} (ha : nonneg a) : nonneg (⟨x, y⟩ * a) :=
have (⟨x, y⟩ * a : ℤ√d) = x * a + sqrtd * (y * a), by rw [decompose, right_distrib, mul_assoc];
  refl,
by rw this; exact nonneg_add (nonneg_smul ha) (nonneg_muld $ nonneg_smul ha)

theorem nonneg_mul {a b : ℤ√d} (ha : nonneg a) (hb : nonneg b) : nonneg (a * b) :=
match a, b, nonneg_cases ha, nonneg_cases hb, ha, hb with
| ._, ._, ⟨x, y, or.inl rfl⟩,          ⟨z, w, or.inl rfl⟩,          ha, hb := trivial
| ._, ._, ⟨x, y, or.inl rfl⟩,          ⟨z, w, or.inr $ or.inr rfl⟩, ha, hb := nonneg_mul_lem hb
| ._, ._, ⟨x, y, or.inl rfl⟩,          ⟨z, w, or.inr $ or.inl rfl⟩, ha, hb := nonneg_mul_lem hb
| ._, ._, ⟨x, y, or.inr $ or.inr rfl⟩, ⟨z, w, or.inl rfl⟩,          ha, hb :=
  by rw mul_comm; exact nonneg_mul_lem ha
| ._, ._, ⟨x, y, or.inr $ or.inl rfl⟩, ⟨z, w, or.inl rfl⟩,          ha, hb :=
  by rw mul_comm; exact nonneg_mul_lem ha
| ._, ._, ⟨x, y, or.inr $ or.inr rfl⟩, ⟨z, w, or.inr $ or.inr rfl⟩, ha, hb :=
  by rw [calc (⟨-x, y⟩ * ⟨-z, w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨x * z + d * y * w, -(x * w + y * z)⟩ : by simp [add_comm]]; exact
  nonnegg_pos_neg.2 (sq_le_mul.left (nonnegg_neg_pos.1 ha) (nonnegg_neg_pos.1 hb))
| ._, ._, ⟨x, y, or.inr $ or.inr rfl⟩, ⟨z, w, or.inr $ or.inl rfl⟩, ha, hb :=
  by rw [calc (⟨-x, y⟩ * ⟨z, -w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨-(x * z + d * y * w), x * w + y * z⟩ : by simp [add_comm]]; exact
  nonnegg_neg_pos.2 (sq_le_mul.right.left (nonnegg_neg_pos.1 ha) (nonnegg_pos_neg.1 hb))
| ._, ._, ⟨x, y, or.inr $ or.inl rfl⟩, ⟨z, w, or.inr $ or.inr rfl⟩, ha, hb :=
  by rw [calc (⟨x, -y⟩ * ⟨-z, w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨-(x * z + d * y * w), x * w + y * z⟩ : by simp [add_comm]]; exact
  nonnegg_neg_pos.2 (sq_le_mul.right.right.left (nonnegg_pos_neg.1 ha) (nonnegg_neg_pos.1 hb))
| ._, ._, ⟨x, y, or.inr $ or.inl rfl⟩, ⟨z, w, or.inr $ or.inl rfl⟩, ha, hb :=
  by rw [calc (⟨x, -y⟩ * ⟨z, -w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨x * z + d * y * w, -(x * w + y * z)⟩ : by simp [add_comm]]; exact
  nonnegg_pos_neg.2 (sq_le_mul.right.right.right (nonnegg_pos_neg.1 ha) (nonnegg_pos_neg.1 hb))
end

protected theorem mul_nonneg (a b : ℤ√d) : 0 ≤ a → 0 ≤ b → 0 ≤ a * b :=
by repeat {rw ← nonneg_iff_zero_le}; exact nonneg_mul

theorem not_sq_le_succ (c d y) (h : 0 < c) : ¬sq_le (y + 1) c 0 d :=
not_le_of_gt $ mul_pos (mul_pos h $ nat.succ_pos _) $ nat.succ_pos _

/-- A nonsquare is a natural number that is not equal to the square of an
  integer. This is implemented as a typeclass because it's a necessary condition
  for much of the Pell equation theory. -/
class nonsquare (x : ℕ) : Prop := (ns [] : ∀n : ℕ, x ≠ n*n)

parameter [dnsq : nonsquare d]
include dnsq

theorem d_pos : 0 < d := lt_of_le_of_ne (nat.zero_le _) $ ne.symm $ (nonsquare.ns d 0)

theorem divides_sq_eq_zero {x y} (h : x * x = d * y * y) : x = 0 ∧ y = 0 :=
let g := x.gcd y in or.elim g.eq_zero_or_pos
  (λH, ⟨nat.eq_zero_of_gcd_eq_zero_left H, nat.eq_zero_of_gcd_eq_zero_right H⟩)
  (λgpos, false.elim $
    let ⟨m, n, co, (hx : x = m * g), (hy : y = n * g)⟩ := nat.exists_coprime gpos in
    begin
      rw [hx, hy] at h,
      have : m * m = d * (n * n) := nat.eq_of_mul_eq_mul_left (mul_pos gpos gpos)
        (by simpa [mul_comm, mul_left_comm] using h),
      have co2 := let co1 := co.mul_right co in co1.mul co1,
      exact nonsquare.ns d m (nat.dvd_antisymm (by rw this; apply dvd_mul_right) $
        co2.dvd_of_dvd_mul_right $ by simp [this])
    end)

theorem divides_sq_eq_zero_z {x y : ℤ} (h : x * x = d * y * y) : x = 0 ∧ y = 0 :=
by rw [mul_assoc, ← int.nat_abs_mul_self, ← int.nat_abs_mul_self, ← int.coe_nat_mul, ← mul_assoc]
  at h;
exact let ⟨h1, h2⟩ := divides_sq_eq_zero (int.coe_nat_inj h) in
⟨int.eq_zero_of_nat_abs_eq_zero h1, int.eq_zero_of_nat_abs_eq_zero h2⟩

theorem not_divides_sq (x y) : (x + 1) * (x + 1) ≠ d * (y + 1) * (y + 1) :=
λe, by have t := (divides_sq_eq_zero e).left; contradiction

theorem nonneg_antisymm : Π {a : ℤ√d}, nonneg a → nonneg (-a) → a = 0
| ⟨0,         0⟩         xy yx := rfl
| ⟨-[1+ x],   -[1+ y]⟩   xy yx := false.elim xy
| ⟨(x+1:nat), (y+1:nat)⟩ xy yx := false.elim yx
| ⟨-[1+ x],   0⟩         xy yx := absurd xy (not_sq_le_succ _ _ _ dec_trivial)
| ⟨(x+1:nat), 0⟩         xy yx := absurd yx (not_sq_le_succ _ _ _ dec_trivial)
| ⟨0,         -[1+ y]⟩   xy yx := absurd xy (not_sq_le_succ _ _ _ d_pos)
| ⟨0,         (y+1:nat)⟩ _  yx := absurd yx (not_sq_le_succ _ _ _ d_pos)
| ⟨(x+1:nat), -[1+ y]⟩   (xy : sq_le _ _ _ _) (yx : sq_le _ _ _ _) :=
  let t := le_antisymm yx xy in by rw[one_mul] at t; exact absurd t (not_divides_sq _ _)
| ⟨-[1+ x],   (y+1:nat)⟩ (xy : sq_le _ _ _ _) (yx : sq_le _ _ _ _) :=
  let t := le_antisymm xy yx in by rw[one_mul] at t; exact absurd t (not_divides_sq _ _)

theorem le_antisymm {a b : ℤ√d} (ab : a ≤ b) (ba : b ≤ a) : a = b :=
eq_of_sub_eq_zero $ nonneg_antisymm ba (by rw neg_sub; exact ab)

instance : linear_order ℤ√d :=
{ le_antisymm     := @zsqrtd.le_antisymm,
  le_total        := zsqrtd.le_total,
  decidable_le    := zsqrtd.decidable_le,
  ..zsqrtd.preorder }

protected theorem eq_zero_or_eq_zero_of_mul_eq_zero : Π {a b : ℤ√d}, a * b = 0 → a = 0 ∨ b = 0
| ⟨x, y⟩ ⟨z, w⟩ h := by injection h with h1 h2; exact
  have h1 : x*z = -(d*y*w), from eq_neg_of_add_eq_zero h1,
  have h2 : x*w = -(y*z), from eq_neg_of_add_eq_zero h2,
  have fin : x*x = d*y*y → (⟨x, y⟩:ℤ√d) = 0, from
  λe, match x, y, divides_sq_eq_zero_z e with ._, ._, ⟨rfl, rfl⟩ := rfl end,
  if z0 : z = 0 then if w0 : w = 0 then
    or.inr (match z, w, z0, w0 with ._, ._, rfl, rfl := rfl end)
  else
     or.inl $ fin $ mul_right_cancel' w0 $ calc
       x * x * w = -y * (x * z) : by simp [h2, mul_assoc, mul_left_comm]
             ... = d * y * y * w : by simp [h1, mul_assoc, mul_left_comm]
  else
     or.inl $ fin $ mul_right_cancel' z0 $ calc
       x * x * z = d * -y * (x * w) : by simp [h1, mul_assoc, mul_left_comm]
             ... = d * y * y * z : by simp [h2, mul_assoc, mul_left_comm]

instance : integral_domain ℤ√d :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := @zsqrtd.eq_zero_or_eq_zero_of_mul_eq_zero,
  .. zsqrtd.comm_ring, .. zsqrtd.nontrivial }

protected theorem mul_pos (a b : ℤ√d) (a0 : 0 < a) (b0 : 0 < b) : 0 < a * b := λab,
or.elim (eq_zero_or_eq_zero_of_mul_eq_zero
         (le_antisymm ab (mul_nonneg _ _ (le_of_lt a0) (le_of_lt b0))))
  (λe, ne_of_gt a0 e)
  (λe, ne_of_gt b0 e)

instance : linear_ordered_comm_ring ℤ√d :=
{ add_le_add_left := @zsqrtd.add_le_add_left,
  mul_pos         := @zsqrtd.mul_pos,
  zero_le_one     := dec_trivial,
  .. zsqrtd.comm_ring, .. zsqrtd.linear_order, .. zsqrtd.nontrivial }

instance : linear_ordered_semiring ℤ√d := by apply_instance
instance : ordered_semiring ℤ√d        := by apply_instance

end

lemma norm_eq_zero {d : ℤ} (h_nonsquare : ∀ n : ℤ, d ≠ n*n) (a : ℤ√d) :
  norm a = 0 ↔ a = 0 :=
begin
  refine ⟨λ ha, ext.mpr _, λ h, by rw [h, norm_zero]⟩,
  delta norm at ha,
  rw sub_eq_zero at ha,
  by_cases h : 0 ≤ d,
  { obtain ⟨d', rfl⟩ := int.eq_coe_of_zero_le h,
    haveI : nonsquare d' := ⟨λ n h, h_nonsquare n $ by exact_mod_cast h⟩,
    exact divides_sq_eq_zero_z ha, },
  { push_neg at h,
    suffices : a.re * a.re = 0,
    { rw eq_zero_of_mul_self_eq_zero this at ha ⊢,
      simpa only [true_and, or_self_right, zero_re, zero_im, eq_self_iff_true,
        zero_eq_mul, mul_zero, mul_eq_zero, h.ne, false_or, or_self] using ha },
    apply _root_.le_antisymm _ (mul_self_nonneg _),
    rw [ha, mul_assoc],
    exact mul_nonpos_of_nonpos_of_nonneg h.le (mul_self_nonneg _) }
end

variables {R : Type} [comm_ring R]

@[ext] lemma hom_ext {d : ℤ} (f g : ℤ√d →+* R) (h : f sqrtd = g sqrtd) : f = g :=
begin
  ext ⟨x_re, x_im⟩,
  simp [decompose, h],
end

/-- The unique `ring_hom` from `ℤ√d` to a ring `R`, constructed by replacing `√d` with the provided
root. Conversely, this associates to every mapping `ℤ√d →+* R` a value of `√d` in `R`. -/
@[simps]
def lift {d : ℤ} : {r : R // r * r = ↑d} ≃ (ℤ√d →+* R) :=
{ to_fun := λ r,
  { to_fun := λ a, a.1 + a.2*(r : R),
    map_zero' := by simp,
    map_add' := λ a b, by { simp, ring, },
    map_one' := by simp,
    map_mul' := λ a b, by {
      have : (a.re + a.im * r : R) * (b.re + b.im * r) =
              a.re * b.re + (a.re * b.im + a.im * b.re) * r + a.im * b.im * (r * r) := by ring,
      simp [this, r.prop],
      ring, } },
  inv_fun := λ f, ⟨f sqrtd, by rw [←f.map_mul, dmuld, ring_hom.map_int_cast]⟩,
  left_inv := λ r, by { ext, simp },
  right_inv := λ f, by { ext, simp } }

/-- `lift r` is injective if `d` is non-square, and R has characteristic zero (that is, the map from
`ℤ` into `R` is injective). -/
lemma lift_injective [char_zero R] {d : ℤ} (r : {r : R // r * r = ↑d}) (hd : ∀ n : ℤ, d ≠ n*n) :
  function.injective (lift r) :=
(lift r).injective_iff.mpr $ λ a ha,
begin
  have h_inj : function.injective (coe : ℤ → R) := int.cast_injective,
  suffices : lift r a.norm = 0,
  { simp only [coe_int_re, add_zero, lift_apply_apply, coe_int_im, int.cast_zero, zero_mul] at this,
    rwa [← int.cast_zero, h_inj.eq_iff, norm_eq_zero hd] at this },
  rw [norm_eq_mul_conj, ring_hom.map_mul, ha, zero_mul]
end

end zsqrtd


import algebra.group.pi

/-!
# Pi instances for groups and monoids

This file defines instances for group, monoid, semigroup and related structures on Pi types.
-/

universes u v w
variables {I : Prop} {f : I → Type v}

namespace pi_Prop

/-! `1`, `0`, `+`, `*`, `-`, `⁻¹`, and `/` are defined pointwise. -/

@[to_additive] instance has_one [Π i, has_one $ f i] : has_one (Π i, f i) := ⟨λ _, 1⟩

@[to_additive] instance has_mul [Π i, has_mul $ f i] : has_mul (Π i, f i) :=
⟨λ f g i, f i * g i⟩

@[to_additive] instance has_inv [Π i, has_inv $ f i] : has_inv (Π i, f i) :=
⟨λ f i, (f i)⁻¹⟩

@[to_additive] instance has_div [Π i, has_div $ f i] : has_div (Π i, f i) :=
⟨λ f g i, f i / g i⟩

@[simp, to_additive] lemma one_apply [Π i, has_one $ f i] (i : I) : (1 : Π i, f i) i = 1 := rfl

@[to_additive]
instance semigroup [Π i, semigroup $ f i] : semigroup (Π i, f i) :=
by refine_struct { mul := (*), .. }; tactic.pi_instance_derive_field

instance semigroup_with_zero [Π i, semigroup_with_zero $ f i] :
  semigroup_with_zero (Π i, f i) :=
by refine_struct { zero := (0 : Π i, f i), mul := (*), .. }; tactic.pi_instance_derive_field

@[to_additive]
instance comm_semigroup [Π i, comm_semigroup $ f i] : comm_semigroup (Π i, f i) :=
by refine_struct { mul := (*), .. }; tactic.pi_instance_derive_field

@[to_additive]
instance mul_one_class [Π i, mul_one_class $ f i] : mul_one_class (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), .. }; tactic.pi_instance_derive_field

@[to_additive]
instance monoid [Π i, monoid $ f i] : monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), npow := λ n x i, (x i) ^ n };
tactic.pi_instance_derive_field

@[to_additive]
instance comm_monoid [Π i, comm_monoid $ f i] : comm_monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), npow := monoid.npow };
tactic.pi_instance_derive_field

@[to_additive pi_Prop.sub_neg_monoid]
instance div_inv_monoid [Π i, div_inv_monoid $ f i] : div_inv_monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), inv := has_inv.inv, div := has_div.div,
  npow := monoid.npow, zpow := λ z x i, (x i) ^ z }; tactic.pi_instance_derive_field

@[to_additive]
instance has_involutive_inv [Π i, has_involutive_inv $ f i] : has_involutive_inv (Π i, f i) :=
by refine_struct { inv := has_inv.inv }; tactic.pi_instance_derive_field

@[to_additive pi_Prop.subtraction_monoid]
instance division_monoid [Π i, division_monoid $ f i] : division_monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), inv := has_inv.inv, div := has_div.div,
  npow := monoid.npow, zpow := λ z x i, (x i) ^ z }; tactic.pi_instance_derive_field

@[to_additive pi_Prop.subtraction_comm_monoid]
instance division_comm_monoid [Π i, division_comm_monoid $ f i] :
  division_comm_monoid (Π i, f i) :=
{ ..pi_Prop.division_monoid, ..pi_Prop.comm_semigroup }

@[to_additive] instance group [Π i, group $ f i] : group (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), inv := has_inv.inv, div := has_div.div,
  npow := monoid.npow, zpow := div_inv_monoid.zpow }; tactic.pi_instance_derive_field

@[to_additive] instance comm_group [Π i, comm_group $ f i] : comm_group (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), inv := has_inv.inv, div := has_div.div,
  npow := monoid.npow, zpow := div_inv_monoid.zpow }; tactic.pi_instance_derive_field

@[to_additive add_left_cancel_semigroup]
instance left_cancel_semigroup [Π i, left_cancel_semigroup $ f i] :
  left_cancel_semigroup (Π i, f i) :=
by refine_struct { mul := (*) }; tactic.pi_instance_derive_field

@[to_additive add_right_cancel_semigroup]
instance right_cancel_semigroup [Π i, right_cancel_semigroup $ f i] :
  right_cancel_semigroup (Π i, f i) :=
by refine_struct { mul := (*) }; tactic.pi_instance_derive_field

@[to_additive add_left_cancel_monoid]
instance left_cancel_monoid [Π i, left_cancel_monoid $ f i] :
  left_cancel_monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), npow := monoid.npow };
tactic.pi_instance_derive_field

@[to_additive add_right_cancel_monoid]
instance right_cancel_monoid [Π i, right_cancel_monoid $ f i] :
  right_cancel_monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), npow := monoid.npow, .. };
tactic.pi_instance_derive_field

@[to_additive add_cancel_monoid]
instance cancel_monoid [Π i, cancel_monoid $ f i] : cancel_monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), npow := monoid.npow };
tactic.pi_instance_derive_field

@[to_additive add_cancel_comm_monoid]
instance cancel_comm_monoid [Π i, cancel_comm_monoid $ f i] : cancel_comm_monoid (Π i, f i) :=
by refine_struct { one := (1 : Π i, f i), mul := (*), npow := monoid.npow };
tactic.pi_instance_derive_field

instance mul_zero_class [Π i, mul_zero_class $ f i] : mul_zero_class (Π i, f i) :=
by refine_struct { zero := (0 : Π i, f i), mul := (*), .. }; tactic.pi_instance_derive_field

instance mul_zero_one_class [Π i, mul_zero_one_class $ f i] :
  mul_zero_one_class (Π i, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := (1 : Π i, f i), mul := (*), .. };
  tactic.pi_instance_derive_field

instance monoid_with_zero [Π i, monoid_with_zero $ f i] :
  monoid_with_zero (Π i, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := (1 : Π i, f i), mul := (*),
  npow := monoid.npow }; tactic.pi_instance_derive_field

instance comm_monoid_with_zero [Π i, comm_monoid_with_zero $ f i] :
  comm_monoid_with_zero (Π i, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := (1 : Π i, f i), mul := (*),
  npow := monoid.npow }; tactic.pi_instance_derive_field

end pi_Prop


/-
Copyright (c) 2014 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.char_zero.defs
import algebra.group_with_zero.commute
import algebra.hom.ring
import algebra.order.group.abs
import algebra.ring.commute
import data.nat.order.basic
import algebra.group.opposite

/-!
# Cast of natural numbers (additional theorems)

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

This file proves additional properties about the *canonical* homomorphism from
the natural numbers into an additive monoid with a one (`nat.cast`).

## Main declarations

* `cast_add_monoid_hom`: `cast` bundled as an `add_monoid_hom`.
* `cast_ring_hom`: `cast` bundled as a `ring_hom`.
-/

variables {α β : Type*}

namespace nat

/-- `coe : ℕ → α` as an `add_monoid_hom`. -/
def cast_add_monoid_hom (α : Type*) [add_monoid_with_one α] : ℕ →+ α :=
{ to_fun := coe,
  map_add' := cast_add,
  map_zero' := cast_zero }

@[simp] lemma coe_cast_add_monoid_hom [add_monoid_with_one α] :
  (cast_add_monoid_hom α : ℕ → α) = coe := rfl

@[simp, norm_cast] theorem cast_mul [non_assoc_semiring α] (m n : ℕ) :
  ((m * n : ℕ) : α) = m * n :=
by induction n; simp [mul_succ, mul_add, *]

/-- `coe : ℕ → α` as a `ring_hom` -/
def cast_ring_hom (α : Type*) [non_assoc_semiring α] : ℕ →+* α :=
{ to_fun := coe,
  map_one' := cast_one,
  map_mul' := cast_mul,
  .. cast_add_monoid_hom α }

@[simp] lemma coe_cast_ring_hom [non_assoc_semiring α] : (cast_ring_hom α : ℕ → α) = coe := rfl

lemma cast_commute [non_assoc_semiring α] (n : ℕ) (x : α) : commute ↑n x :=
nat.rec_on n (by rw [cast_zero]; exact commute.zero_left x) $
λ n ihn, by rw [cast_succ]; exact ihn.add_left (commute.one_left x)

lemma cast_comm [non_assoc_semiring α] (n : ℕ) (x : α) : (n : α) * x = x * n :=
(cast_commute n x).eq

lemma commute_cast [non_assoc_semiring α] (x : α) (n : ℕ) : commute x n :=
(n.cast_commute x).symm

section ordered_semiring
variables [ordered_semiring α]

@[mono] theorem mono_cast : monotone (coe : ℕ → α) :=
monotone_nat_of_le_succ $ λ n, by rw [nat.cast_succ]; exact le_add_of_nonneg_right zero_le_one

@[simp] theorem cast_nonneg (n : ℕ) : 0 ≤ (n : α) :=
@nat.cast_zero α _ ▸ mono_cast (nat.zero_le n)

section nontrivial
variable [nontrivial α]

lemma cast_add_one_pos (n : ℕ) : 0 < (n : α) + 1 :=
zero_lt_one.trans_le $ le_add_of_nonneg_left n.cast_nonneg

@[simp] lemma cast_pos {n : ℕ} : (0 : α) < n ↔ 0 < n := by cases n; simp [cast_add_one_pos]

end nontrivial

variables [char_zero α] {m n : ℕ}

lemma strict_mono_cast : strict_mono (coe : ℕ → α) :=
mono_cast.strict_mono_of_injective cast_injective

/-- `coe : ℕ → α` as an `order_embedding` -/
@[simps { fully_applied := ff }] def cast_order_embedding : ℕ ↪o α :=
order_embedding.of_strict_mono coe nat.strict_mono_cast

@[simp, norm_cast] lemma cast_le : (m : α) ≤ n ↔ m ≤ n := strict_mono_cast.le_iff_le
@[simp, norm_cast, mono] lemma cast_lt : (m : α) < n ↔ m < n := strict_mono_cast.lt_iff_lt

@[simp, norm_cast] lemma one_lt_cast : 1 < (n : α) ↔ 1 < n := by rw [←cast_one, cast_lt]
@[simp, norm_cast] lemma one_le_cast : 1 ≤ (n : α) ↔ 1 ≤ n := by rw [←cast_one, cast_le]

@[simp, norm_cast] lemma cast_lt_one : (n : α) < 1 ↔ n = 0 :=
by rw [←cast_one, cast_lt, lt_succ_iff, ←bot_eq_zero, le_bot_iff]

@[simp, norm_cast] lemma cast_le_one : (n : α) ≤ 1 ↔ n ≤ 1 := by rw [←cast_one, cast_le]

end ordered_semiring

/-- A version of `nat.cast_sub` that works for `ℝ≥0` and `ℚ≥0`. Note that this proof doesn't work
for `ℕ∞` and `ℝ≥0∞`, so we use type-specific lemmas for these types. -/
@[simp, norm_cast] lemma cast_tsub [canonically_ordered_comm_semiring α] [has_sub α]
  [has_ordered_sub α] [contravariant_class α α (+) (≤)] (m n : ℕ) :
  ↑(m - n) = (m - n : α) :=
begin
  cases le_total m n with h h,
  { rw [tsub_eq_zero_of_le h, cast_zero, tsub_eq_zero_of_le],
    exact mono_cast h },
  { rcases le_iff_exists_add'.mp h with ⟨m, rfl⟩,
    rw [add_tsub_cancel_right, cast_add, add_tsub_cancel_right] }
end

@[simp, norm_cast] theorem cast_min [linear_ordered_semiring α] {a b : ℕ} :
  (↑(min a b) : α) = min a b :=
(@mono_cast α _).map_min

@[simp, norm_cast] theorem cast_max [linear_ordered_semiring α] {a b : ℕ} :
  (↑(max a b) : α) = max a b :=
(@mono_cast α _).map_max

@[simp, norm_cast] theorem abs_cast [linear_ordered_ring α] (a : ℕ) :
  |(a : α)| = a :=
abs_of_nonneg (cast_nonneg a)

lemma coe_nat_dvd [semiring α] {m n : ℕ} (h : m ∣ n) : (m : α) ∣ (n : α) :=
map_dvd (nat.cast_ring_hom α) h

alias coe_nat_dvd ← _root_.has_dvd.dvd.nat_cast

end nat

section add_monoid_hom_class

variables {A B F : Type*} [add_monoid_with_one B]

lemma ext_nat' [add_monoid A] [add_monoid_hom_class F ℕ A] (f g : F) (h : f 1 = g 1) : f = g :=
fun_like.ext f g $ begin
  apply nat.rec,
  { simp only [nat.nat_zero_eq_zero, map_zero] },
  simp [nat.succ_eq_add_one, h] {contextual := tt}
end

@[ext] lemma add_monoid_hom.ext_nat [add_monoid A] : ∀ {f g : ℕ →+ A}, ∀ h : f 1 = g 1, f = g :=
ext_nat'

variable [add_monoid_with_one A]

-- these versions are primed so that the `ring_hom_class` versions aren't
lemma eq_nat_cast' [add_monoid_hom_class F ℕ A] (f : F) (h1 : f 1 = 1) :
  ∀ n : ℕ, f n = n
| 0     := by simp
| (n+1) := by rw [map_add, h1, eq_nat_cast' n, nat.cast_add_one]

lemma map_nat_cast' {A} [add_monoid_with_one A] [add_monoid_hom_class F A B]
                    (f : F) (h : f 1 = 1) : ∀ (n : ℕ), f n = n
| 0     := by simp
| (n+1) := by rw [nat.cast_add, map_add, nat.cast_add, map_nat_cast', nat.cast_one, h, nat.cast_one]

end add_monoid_hom_class

section monoid_with_zero_hom_class

variables {A F : Type*} [mul_zero_one_class A]

/-- If two `monoid_with_zero_hom`s agree on the positive naturals they are equal. -/
theorem ext_nat'' [monoid_with_zero_hom_class F ℕ A] (f g : F)
  (h_pos : ∀ {n : ℕ}, 0 < n → f n = g n) : f = g :=
begin
  apply fun_like.ext,
  rintro (_|n),
  { simp },
  exact h_pos n.succ_pos
end

@[ext] theorem monoid_with_zero_hom.ext_nat :
  ∀ {f g : ℕ →*₀ A}, (∀ {n : ℕ}, 0 < n → f n = g n) → f = g := ext_nat''

end monoid_with_zero_hom_class

section ring_hom_class

variables {R S F : Type*} [non_assoc_semiring R] [non_assoc_semiring S]

@[simp] lemma eq_nat_cast [ring_hom_class F ℕ R] (f : F) : ∀ n, f n = n :=
eq_nat_cast' f $ map_one f

@[simp] lemma map_nat_cast [ring_hom_class F R S] (f : F) : ∀ n : ℕ, f (n : R) = n :=
map_nat_cast' f $ map_one f

lemma ext_nat [ring_hom_class F ℕ R] (f g : F) : f = g :=
ext_nat' f g $ by simp only [map_one]

lemma ne_zero.nat_of_injective {n : ℕ} [h : ne_zero (n : R)]
  [ring_hom_class F R S] {f : F} (hf : function.injective f) : ne_zero (n : S) :=
⟨λ h, (ne_zero.nat_cast_ne n R) $ hf $ by simpa only [map_nat_cast, map_zero]⟩

lemma ne_zero.nat_of_ne_zero {R S} [semiring R] [semiring S] {F} [ring_hom_class F R S] (f : F)
  {n : ℕ} [hn : ne_zero (n : S)] : ne_zero (n : R) :=
by { apply ne_zero.of_map f, simp only [map_nat_cast, hn] }

end ring_hom_class

namespace ring_hom

/-- This is primed to match `eq_int_cast'`. -/
lemma eq_nat_cast' {R} [non_assoc_semiring R] (f : ℕ →+* R) : f = nat.cast_ring_hom R :=
ring_hom.ext $ eq_nat_cast f

end ring_hom

@[simp, norm_cast] theorem nat.cast_id (n : ℕ) : ↑n = n :=
rfl

@[simp] lemma nat.cast_ring_hom_nat : nat.cast_ring_hom ℕ = ring_hom.id ℕ := rfl

-- I don't think `ring_hom_class` is good here, because of the `subsingleton` TC slowness
instance nat.unique_ring_hom {R : Type*} [non_assoc_semiring R] : unique (ℕ →+* R) :=
{ default := nat.cast_ring_hom R, uniq := ring_hom.eq_nat_cast' }

namespace pi
variables {π : α → Type*} [Π a, has_nat_cast (π a)]

instance : has_nat_cast (Π a, π a) :=
by refine_struct { .. }; tactic.pi_instance_derive_field

lemma nat_apply (n : ℕ) (a : α) : (n : Π a, π a) a = n := rfl

@[simp] lemma coe_nat (n : ℕ) : (n : Π a, π a) = λ _, n := rfl

end pi

lemma sum.elim_nat_cast_nat_cast {α β γ : Type*} [has_nat_cast γ] (n : ℕ) :
  sum.elim (n : α → γ) (n : β → γ) = n :=
@sum.elim_lam_const_lam_const α β γ n

namespace pi
variables {π : α → Type*} [Π a, add_monoid_with_one (π a)]

instance : add_monoid_with_one (Π a, π a) :=
by refine_struct { .. }; tactic.pi_instance_derive_field

end pi

/-! ### Order dual -/

open order_dual

instance [h : has_nat_cast α] : has_nat_cast αᵒᵈ := h
instance [h : add_monoid_with_one α] : add_monoid_with_one αᵒᵈ := h
instance [h : add_comm_monoid_with_one α] : add_comm_monoid_with_one αᵒᵈ := h

@[simp] lemma to_dual_nat_cast [has_nat_cast α] (n : ℕ) : to_dual (n : α) = n := rfl
@[simp] lemma of_dual_nat_cast [has_nat_cast α] (n : ℕ) : (of_dual n : α) = n := rfl

/-! ### Lexicographic order -/

instance [h : has_nat_cast α] : has_nat_cast (lex α) := h
instance [h : add_monoid_with_one α] : add_monoid_with_one (lex α) := h
instance [h : add_comm_monoid_with_one α] : add_comm_monoid_with_one (lex α) := h

@[simp] lemma to_lex_nat_cast [has_nat_cast α] (n : ℕ) : to_lex (n : α) = n := rfl
@[simp] lemma of_lex_nat_cast [has_nat_cast α] (n : ℕ) : (of_lex n : α) = n := rfl