/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

notation, basic datatypes and type classes
-/
prelude

universes u v w

@[inline] def id {α : Sort u} (a : α) : α := a

abbrev Function.comp {α : Sort u} {β : Sort v} {δ : Sort w} (f : β → δ) (g : α → β) : α → δ :=
  fun x => f (g x)

abbrev Function.const {α : Sort u} (β : Sort v) (a : α) : β → α :=
  fun x => a

set_option bootstrap.inductiveCheckResultingUniverse false in
inductive PUnit : Sort u
  | unit : PUnit

/-- An abbreviation for `PUnit.{0}`, its most common instantiation.
    This Type should be preferred over `PUnit` where possible to avoid
    unnecessary universe parameters. -/
abbrev Unit : Type := PUnit

@[matchPattern] abbrev Unit.unit : Unit := PUnit.unit

/-- Auxiliary unsafe constant used by the Compiler when erasing proofs from code. -/
unsafe axiom lcProof {α : Prop} : α

/-- Auxiliary unsafe constant used by the Compiler to mark unreachable code. -/
unsafe axiom lcUnreachable {α : Sort u} : α

inductive True : Prop
  | intro : True

inductive False : Prop

inductive Empty : Type

def Not (a : Prop) : Prop := a → False

@[macroInline] def False.elim {C : Sort u} (h : False) : C :=
  False.rec (fun _ => C) h

@[macroInline] def absurd {a : Prop} {b : Sort v} (h₁ : a) (h₂ : Not a) : b :=
  False.elim (h₂ h₁)

inductive Eq {α : Sort u} (a : α) : α → Prop
  | refl {} : Eq a a

abbrev Eq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : α → Sort u1} (m : motive a) {b : α} (h : Eq a b) : motive b :=
  Eq.rec (motive := fun α _ => motive α) m h

@[matchPattern] def rfl {α : Sort u} {a : α} : Eq a a := Eq.refl a

theorem Eq.subst {α : Sort u} {motive : α → Prop} {a b : α} (h₁ : Eq a b) (h₂ : motive a) : motive b :=
  Eq.ndrec h₂ h₁

theorem Eq.symm {α : Sort u} {a b : α} (h : a = b) : b = a :=
  h ▸ rfl

@[macroInline] def cast {α β : Sort u} (h : α = β) (a : α) : β :=
  Eq.rec (motive := fun α _ => α) a h

theorem congrArg {α : Sort u} {β : Sort v} {a₁ a₂ : α} (f : α → β) (h : Eq a₁ a₂) : Eq (f a₁) (f a₂) :=
  h ▸ rfl

/-
Initialize the Quotient Module, which effectively adds the following definitions:

constant Quot {α : Sort u} (r : α → α → Prop) : Sort u

constant Quot.mk {α : Sort u} (r : α → α → Prop) (a : α) : Quot r

constant Quot.lift {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) :
  (∀ a b : α, r a b → Eq (f a) (f b)) → Quot r → β

constant Quot.ind {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} :
  (∀ a : α, β (Quot.mk r a)) → ∀ q : Quot r, β q
-/
init_quot

inductive HEq {α : Sort u} (a : α) : {β : Sort u} → β → Prop
  | refl {} : HEq a a

@[matchPattern] def HEq.rfl {α : Sort u} {a : α} : a ≅ a :=
  HEq.refl a

theorem eqOfHEq {α : Sort u} {a a' : α} (h : HEq a a') : Eq a a' :=
  have (α β : Sort u) → (a : α) → (b : β) → HEq a b → (h : Eq α β) → Eq (cast h a) b from
    fun α β a b h₁ =>
      HEq.rec (motive := fun {β} (b : β) (h : HEq a b) => (h₂ : Eq α β) → Eq (cast h₂ a) b)
        (fun (h₂ : Eq α α) => rfl)
        h₁
  this α α a a' h rfl

structure Prod (α : Type u) (β : Type v) :=
  (fst : α) (snd : β)

attribute [unbox] Prod

/-- Similar to `Prod`, but `α` and `β` can be propositions.
   We use this Type internally to automatically generate the brecOn recursor. -/
structure PProd (α : Sort u) (β : Sort v) :=
  (fst : α) (snd : β)

/-- Similar to `Prod`, but `α` and `β` are in the same universe. -/
structure MProd (α β : Type u) :=
  (fst : α) (snd : β)

structure And (a b : Prop) : Prop :=
  intro :: (left : a) (right : b)

inductive Or (a b : Prop) : Prop
  | inl (h : a) : Or a b
  | inr (h : b) : Or a b

inductive Bool : Type
  | false : Bool
  | true : Bool

export Bool (false true)

/- Remark: Subtype must take a Sort instead of Type because of the axiom strongIndefiniteDescription. -/
structure Subtype {α : Sort u} (p : α → Prop) :=
  (val : α) (property : p val)

/-- Gadget for optional parameter support. -/
@[reducible] def optParam (α : Sort u) (default : α) : Sort u := α

/-- Gadget for marking output parameters in type classes. -/
@[reducible] def outParam (α : Sort u) : Sort u := α

/-- Auxiliary Declaration used to implement the notation (a : α) -/
@[reducible] def typedExpr (α : Sort u) (a : α) : α := a

/-- Auxiliary Declaration used to implement the named patterns `x@p` -/
@[reducible] def namedPattern {α : Sort u} (x a : α) : α := a

/- Auxiliary axiom used to implement `sorry`. -/
axiom sorryAx (α : Sort u) (synthetic := true) : α

theorem eqFalseOfNeTrue : {b : Bool} → Not (Eq b true) → b = false
  | true, h => False.elim (h rfl)
  | false, h => rfl

theorem eqTrueOfNeFalse : {b : Bool} → Not (Eq b false) → b = true
  | true, h => rfl
  | false, h => False.elim (h rfl)

theorem neFalseOfEqTrue : {b : Bool} → Eq b true → Not (Eq b false)
  | true, _  => fun h => Bool.noConfusion h
  | false, h => Bool.noConfusion h

theorem neTrueOfEqFalse : {b : Bool} → Eq b false → Not (Eq b true)
  | true, h  => Bool.noConfusion h
  | false, _ => fun h => Bool.noConfusion h

class Inhabited (α : Sort u) :=
  mk {} :: (default : α)

constant arbitrary (α : Sort u) [s : Inhabited α] : α :=
  @Inhabited.default α s

instance (α : Sort u) {β : Sort v} [Inhabited β] : Inhabited (α → β) := {
  default := fun _ => arbitrary β
}

instance (α : Sort u) {β : α → Sort v} [(a : α) → Inhabited (β a)] : Inhabited ((a : α) → β a) := {
  default := fun a => arbitrary (β a)
}

/-- Universe lifting operation from Sort to Type -/
structure PLift (α : Sort u) : Type u :=
  up :: (down : α)

/- Bijection between α and PLift α -/
theorem PLift.upDown {α : Sort u} : ∀ (b : PLift α), up (down b) = b
  | up a => rfl

theorem PLift.downUp {α : Sort u} (a : α) : down (up a) = a :=
  rfl

/- Pointed types -/
structure PointedType :=
  (type : Type u)
  (val : type)

instance : Inhabited PointedType.{u} := {
  default := { type := PUnit.{u+1}, val := ⟨⟩ }
}

/-- Universe lifting operation -/
structure ULift.{r, s} (α : Type s) : Type (max s r) :=
  up :: (down : α)

/- Bijection between α and ULift.{v} α -/
theorem ULift.upDown {α : Type u} : ∀ (b : ULift.{v} α), up (down b) = b
  | up a => rfl

theorem ULift.downUp {α : Type u} (a : α) : down (up.{v} a) = a :=
  rfl

class inductive Decidable (p : Prop)
  | isFalse (h : Not p) : Decidable p
  | isTrue  (h : p) : Decidable p

@[inlineIfReduce, nospecialize] def Decidable.decide (p : Prop) [h : Decidable p] : Bool :=
  Decidable.casesOn (motive := fun _ => Bool) h (fun _ => false) (fun _ => true)

export Decidable (isTrue isFalse decide)

abbrev DecidablePred {α : Sort u} (r : α → Prop) :=
  (a : α) → Decidable (r a)

abbrev DecidableRel {α : Sort u} (r : α → α → Prop) :=
  (a b : α) → Decidable (r a b)

abbrev DecidableEq (α : Sort u) :=
  (a b : α) → Decidable (Eq a b)

def decEq {α : Sort u} [s : DecidableEq α] (a b : α) : Decidable (Eq a b) :=
  s a b

theorem decideEqTrue : {p : Prop} → [s : Decidable p] → p → Eq (decide p) true
  | _, isTrue  _, _   => rfl
  | _, isFalse h₁, h₂ => absurd h₂ h₁

theorem decideEqFalse : {p : Prop} → [s : Decidable p] → Not p → Eq (decide p) false
  | _, isTrue  h₁, h₂ => absurd h₁ h₂
  | _, isFalse h, _   => rfl

theorem ofDecideEqTrue {p : Prop} [s : Decidable p] : Eq (decide p) true → p := fun h =>
  match s with
  | isTrue  h₁ => h₁
  | isFalse h₁ => absurd h (neTrueOfEqFalse (decideEqFalse h₁))

theorem ofDecideEqFalse {p : Prop} [s : Decidable p] : Eq (decide p) false → Not p := fun h =>
  match s with
  | isTrue  h₁ => absurd h (neFalseOfEqTrue (decideEqTrue h₁))
  | isFalse h₁ => h₁

@[inline] instance : DecidableEq Bool :=
  fun a b => match a, b with
   | false, false => isTrue rfl
   | false, true  => isFalse (fun h => Bool.noConfusion h)
   | true, false  => isFalse (fun h => Bool.noConfusion h)
   | true, true   => isTrue rfl

class BEq      (α : Type u) := (beq : α → α → Bool)

open BEq (beq)

instance {α : Type u} [DecidableEq α] : BEq α :=
  ⟨fun a b => decide (Eq a b)⟩

-- We use "dependent" if-then-else to be able to communicate the if-then-else condition
-- to the branches
@[macroInline] def dite {α : Sort u} (c : Prop) [h : Decidable c] (t : c → α) (e : Not c → α) : α :=
  Decidable.casesOn (motive := fun _ => α) h e t

/- if-then-else -/

@[macroInline] def ite {α : Sort u} (c : Prop) [h : Decidable c] (t e : α) : α :=
  Decidable.casesOn (motive := fun _ => α) h (fun _ => e) (fun _ => t)

@[macroInline] instance {p q} [Decidable p] [Decidable q] : Decidable (And p q) :=
  if hp : p then
    if hq : q then
      isTrue ⟨hp, hq⟩
    else
      isFalse (fun h => hq (And.right h))
  else
    isFalse (fun h => hp (And.left h))

@[macroInline] instance {p q} [Decidable p] [Decidable q] : Decidable (Or p q) :=
  if hp : p then
    isTrue (Or.inl hp)
  else if hq : q then
    isTrue (Or.inr hq)
  else
    isFalse fun h => match h with
      | Or.inl h => hp h
      | Or.inr h => hq h

instance {p} [Decidable p] : Decidable (Not p) :=
  if hp : p then isFalse (absurd hp) else isTrue hp

/- Boolean operators -/

@[macroInline] def cond {a : Type u} : Bool → a → a → a
  | true,  x, y => x
  | false, x, y => y

@[macroInline] def or : Bool → Bool → Bool
  | true,  _ => true
  | false, b => b

@[macroInline] def and : Bool → Bool → Bool
  | false, _ => false
  | true,  b => b

@[macroInline] def not : Bool → Bool
  | true  => false
  | false => true

inductive Nat
  | zero : Nat
  | succ (n : Nat) : Nat

/- For numeric literals notation -/
class OfNat (α : Type u) :=
  (ofNat : Nat → α)

export OfNat (ofNat)

instance : OfNat Nat := ⟨id⟩

instance : Inhabited Nat := {
  default := 0
}

class HasLessEq (α : Type u) := (LessEq : α → α → Prop)
class HasLess   (α : Type u) := (Less : α → α → Prop)

export HasLess (Less)
export HasLessEq (LessEq)

class Add     (α : Type u) := (add : α → α → α)
class Mul     (α : Type u) := (mul : α → α → α)
class Neg     (α : Type u) := (neg : α → α)
class Sub     (α : Type u) := (sub : α → α → α)
class Div     (α : Type u) := (div : α → α → α)
class Mod     (α : Type u) := (mod : α → α → α)
class ModN    (α : Type u) := (modn : α → Nat → α)
class Pow     (α : Type u) (β : Type v) := (pow : α → β → α)
class Append  (α : Type u) := (append : α → α → α)
class OrElse  (α : Type u) := (orElse  : α → α → α)
class AndThen (α : Type u) := (andThen : α → α → α)

open Add (add)
open Mul (mul)
open Pow (pow)
open Append (append)

@[reducible] def GreaterEq {α : Type u} [HasLessEq α] (a b : α) : Prop := LessEq b a
@[reducible] def Greater {α : Type u} [HasLess α] (a b : α) : Prop     := Less b a

set_option bootstrap.gen_matcher_code false in
@[extern "lean_nat_add"]
protected def Nat.add : (@& Nat) → (@& Nat) → Nat
  | a, Nat.zero   => a
  | a, Nat.succ b => Nat.succ (Nat.add a b)

instance : Add Nat := {
  add := Nat.add
}

set_option bootstrap.gen_matcher_code false in
@[extern "lean_nat_mul"]
protected def Nat.mul : (@& Nat) → (@& Nat) → Nat
  | a, 0          => 0
  | a, Nat.succ b => Nat.add (Nat.mul a b) a

instance : Mul Nat := {
  mul := Nat.mul
}

set_option bootstrap.gen_matcher_code false in
@[extern "lean_nat_pow"]
protected def Nat.pow (m : @& Nat) : (@& Nat) → Nat
  | 0      => 1
  | succ n => Nat.mul (Nat.pow m n) m

instance : Pow Nat Nat := {
  pow := Nat.pow
}

set_option bootstrap.gen_matcher_code false in
@[extern "lean_nat_dec_eq"]
def Nat.beq : Nat → Nat → Bool
  | zero,   zero   => true
  | zero,   succ m => false
  | succ n, zero   => false
  | succ n, succ m => beq n m

theorem Nat.eqOfBeqEqTt : {n m : Nat} → Eq (beq n m) true → Eq n m
  | zero,   zero,   h => rfl
  | zero,   succ m, h => Bool.noConfusion h
  | succ n, zero,   h => Bool.noConfusion h
  | succ n, succ m, h =>
    have Eq (beq n m) true from h
    have Eq n m from eqOfBeqEqTt this
    this ▸ rfl

theorem Nat.neOfBeqEqFf : {n m : Nat} → Eq (beq n m) false → Not (Eq n m)
  | zero,   zero,   h₁, h₂ => Bool.noConfusion h₁
  | zero,   succ m, h₁, h₂ => Nat.noConfusion h₂
  | succ n, zero,   h₁, h₂ => Nat.noConfusion h₂
  | succ n, succ m, h₁, h₂ =>
    have beq n m = false from h₁
    Nat.noConfusion h₂ (fun h₂ => absurd h₂ (neOfBeqEqFf this))

@[extern "lean_nat_dec_eq"]
protected def Nat.decEq (n m : @& Nat) : Decidable (n = m) :=
  if h : beq n m = true then isTrue (eqOfBeqEqTt h)
  else isFalse (neOfBeqEqFf (eqFalseOfNeTrue h))

@[inline] instance : DecidableEq Nat := Nat.decEq

set_option bootstrap.gen_matcher_code false in
@[extern "lean_nat_dec_le"]
def Nat.ble : Nat → Nat → Bool
  | zero,   zero   => true
  | zero,   succ m => true
  | succ n, zero   => false
  | succ n, succ m => ble n m

protected def Nat.le (n m : Nat) : Prop :=
  ble n m = true

instance : HasLessEq Nat := ⟨Nat.le⟩

protected def Nat.lt (n m : Nat) : Prop :=
  Nat.le (succ n) m

instance : HasLess Nat := ⟨Nat.lt⟩

theorem Nat.notSuccLeZero : ∀ (n : Nat), LessEq (succ n) 0 → False
  | 0,      h => nomatch h
  | succ n, h => nomatch h

theorem Nat.notLtZero (n : Nat) : Not (Less n 0) :=
  notSuccLeZero n

@[extern "lean_nat_dec_le"]
instance Nat.decLe (n m : @& Nat) : Decidable (LessEq n m) :=
  decEq (Nat.ble n m) true

@[extern "lean_nat_dec_lt"]
instance Nat.decLt (n m : @& Nat) : Decidable (Less n m) :=
  decLe (succ n) m

theorem Nat.zeroLe : (n : Nat) → LessEq 0 n
  | zero   => rfl
  | succ n => rfl

theorem Nat.succLeSucc {n m : Nat} (h : LessEq n m) : LessEq (succ n) (succ m) :=
  h

theorem Nat.zeroLtSucc (n : Nat) : Less 0 (succ n) :=
  succLeSucc (zeroLe n)

theorem Nat.leStep : {n m : Nat} → LessEq n m → LessEq n (succ m)
  | zero,   zero,   h => rfl
  | zero,   succ n, h => rfl
  | succ n, zero,   h => Bool.noConfusion h
  | succ n, succ m, h =>
    have LessEq n m from h
    have LessEq n (succ m) from leStep this
    succLeSucc this

protected theorem Nat.leTrans : {n m k : Nat} → LessEq n m → LessEq m k → LessEq n k
  | zero,   m,      k,      h₁, h₂ => zeroLe _
  | succ n, zero,   k,      h₁, h₂ => Bool.noConfusion h₁
  | succ n, succ m, zero,   h₁, h₂ => Bool.noConfusion h₂
  | succ n, succ m, succ k, h₁, h₂ =>
    have h₁' : LessEq n m from h₁
    have h₂' : LessEq m k from h₂
    Nat.leTrans h₁' h₂'

protected theorem Nat.ltTrans {n m k : Nat} (h₁ : Less n m) : Less m k → Less n k :=
  Nat.leTrans (leStep h₁)

theorem Nat.leSucc : (n : Nat) → LessEq n (succ n)
  | zero   => rfl
  | succ n => leSucc n

theorem Nat.leSuccOfLe {n m : Nat} (h : LessEq n m) : LessEq n (succ m) :=
  Nat.leTrans h (leSucc m)

protected theorem Nat.eqOrLtOfLe : {n m: Nat} → LessEq n m → Or (Eq n m) (Less n m)
  | zero,   zero,   h => Or.inl rfl
  | zero,   succ n, h => Or.inr (zeroLe n)
  | succ n, zero,   h => Bool.noConfusion h
  | succ n, succ m, h =>
    have LessEq n m from h
    match Nat.eqOrLtOfLe this with
    | Or.inl h => Or.inl (h ▸ rfl)
    | Or.inr h => Or.inr (succLeSucc h)

protected def Nat.leRefl : (n : Nat) → LessEq n n
  | zero   => rfl
  | succ n => Nat.leRefl n

protected theorem Nat.ltOrGe (n m : Nat) : Or (Less n m) (GreaterEq n m) :=
  match m with
  | zero   => Or.inr (zeroLe n)
  | succ m =>
    match Nat.ltOrGe n m with
    | Or.inl h => Or.inl (leSuccOfLe h)
    | Or.inr h =>
      match Nat.eqOrLtOfLe h with
      | Or.inl h1 => Or.inl (h1 ▸ Nat.leRefl _)
      | Or.inr h1 => Or.inr h1

protected theorem Nat.leAntisymm : {n m : Nat} → LessEq n m → LessEq m n → Eq n m
  | zero,   zero,   h₁, h₂ => rfl
  | succ n, zero,   h₁, h₂ => Bool.noConfusion h₁
  | zero,   succ m, h₁, h₂ => Bool.noConfusion h₂
  | succ n, succ m, h₁, h₂ =>
    have h₁' : LessEq n m from h₁
    have h₂' : LessEq m n from h₂
    (Nat.leAntisymm h₁' h₂') ▸ rfl

protected theorem Nat.ltOfLeOfNe {n m : Nat} (h₁ : LessEq n m) (h₂ : Not (Eq n m)) : Less n m :=
  match Nat.ltOrGe n m with
  | Or.inl h₃ => h₃
  | Or.inr h₃ => absurd (Nat.leAntisymm h₁ h₃) h₂

set_option bootstrap.gen_matcher_code false in
@[extern c inline "lean_nat_sub(#1, lean_box(1))"]
def Nat.pred : Nat → Nat
  | 0      => 0
  | succ a => a

theorem Nat.predLePred : {n m : Nat} → LessEq n m → LessEq (pred n) (pred m)
  | zero,   zero,   h => rfl
  | zero,   succ n, h => zeroLe n
  | succ n, zero,   h => Bool.noConfusion h
  | succ n, succ m, h => h

theorem Nat.leOfSuccLeSucc {n m : Nat} : LessEq (succ n) (succ m) → LessEq n m :=
  predLePred

theorem Nat.leOfLtSucc {m n : Nat} : Less m (succ n) → LessEq m n :=
  leOfSuccLeSucc

@[extern "lean_system_platform_nbits"] constant System.Platform.getNumBits : Unit → { n : Nat // Or (Eq n 32) (Eq n 64) } :=
  fun _ => ⟨64, Or.inr rfl⟩ -- inhabitant

def System.Platform.numBits : Nat :=
  (getNumBits ()).val

theorem System.Platform.numBitsEq : Or (Eq numBits 32) (Eq numBits 64) :=
  (getNumBits ()).property

structure Fin (n : Nat) :=
  (val  : Nat)
  (isLt : Less val n)

theorem Fin.eqOfVeq {n} : ∀ {i j : Fin n}, Eq i.val j.val → Eq i j
  | ⟨v, h⟩, ⟨_, _⟩, rfl => rfl

theorem Fin.veqOfEq {n} {i j : Fin n} (h : Eq i j) : i.val = j.val :=
  h ▸ rfl

theorem Fin.neOfVne {n} {i j : Fin n} (h : Not (Eq i.val j.val)) : Not (Eq i j) :=
  fun h' => absurd (veqOfEq h') h

instance (n : Nat) : DecidableEq (Fin n) :=
  fun i j =>
    match decEq i.val j.val with
    | isTrue h  => isTrue (Fin.eqOfVeq h)
    | isFalse h => isFalse (Fin.neOfVne h)

def uint8Sz : Nat := 256
structure UInt8 :=
  (val : Fin uint8Sz)

set_option bootstrap.gen_matcher_code false in
@[extern c inline "#1 == #2"]
def UInt8.decEq (a b : UInt8) : Decidable (Eq a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt8.noConfusion h' (fun h' => absurd h' h))

instance : DecidableEq UInt8 := UInt8.decEq

instance : Inhabited UInt8 := {
  default := { val := { val := 0, isLt := decide! } }
}

def uint16Sz : Nat := 65536
structure UInt16 :=
  (val : Fin uint16Sz)

set_option bootstrap.gen_matcher_code false in
@[extern c inline "#1 == #2"]
def UInt16.decEq (a b : UInt16) : Decidable (Eq a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt16.noConfusion h' (fun h' => absurd h' h))

instance : DecidableEq UInt16 := UInt16.decEq

instance : Inhabited UInt16 := {
  default := { val := { val := 0, isLt := decide! } }
}

def uint32Sz : Nat := 4294967296
structure UInt32 :=
  (val : Fin uint32Sz)

set_option bootstrap.gen_matcher_code false in
@[extern c inline "#1 == #2"]
def UInt32.decEq (a b : UInt32) : Decidable (Eq a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt32.noConfusion h' (fun h' => absurd h' h))

instance : DecidableEq UInt32 := UInt32.decEq

instance : Inhabited UInt32 := {
  default := { val := { val := 0, isLt := decide! } }
}

def uint64Sz : Nat := 18446744073709551616
structure UInt64 :=
  (val : Fin uint64Sz)

set_option bootstrap.gen_matcher_code false in
@[extern c inline "#1 == #2"]
def UInt64.decEq (a b : UInt64) : Decidable (Eq a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt64.noConfusion h' (fun h' => absurd h' h))

instance : DecidableEq UInt64 := UInt64.decEq

instance : Inhabited UInt64 := {
  default := { val := { val := 0, isLt := decide! } }
}

def usizeSz : Nat := pow 2 System.Platform.numBits

theorem usizeSzEq : Or (Eq usizeSz 4294967296) (Eq usizeSz 18446744073709551616) :=
  show Or (Eq (pow 2 System.Platform.numBits) 4294967296) (Eq (pow 2 System.Platform.numBits) 18446744073709551616) from
  match System.Platform.numBits, System.Platform.numBitsEq with
  | _, Or.inl rfl => Or.inl (decide! : (Eq (pow 2 32) (4294967296:Nat)))
  | _, Or.inr rfl => Or.inr (decide! : (Eq (pow 2 64) (18446744073709551616:Nat)))

structure USize :=
  (val : Fin usizeSz)

set_option bootstrap.gen_matcher_code false in
@[extern c inline "#1 == #2"]
def USize.decEq (a b : USize) : Decidable (Eq a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => USize.noConfusion h' (fun h' => absurd h' h))

instance : DecidableEq USize := USize.decEq

instance : Inhabited USize := {
  default := { val := { val := 0, isLt := match usizeSz, usizeSzEq with | _, Or.inl rfl => decide! | _, Or.inr rfl => decide! } }
}

@[extern "lean_usize_of_nat"]
def USize.ofNat32 (n : @& Nat) (h : Less n 4294967296) : USize := {
  val := {
    val  := n,
    isLt := match usizeSz, usizeSzEq with
      | _, Or.inl rfl => h
      | _, Or.inr rfl => Nat.ltTrans h (decide! : Less 4294967296 18446744073709551616)
  }
}

@[extern "lean_usize_of_nat"]
def USize.ofNatCore (n : @& Nat) (h : Less n usizeSz) : USize := {
  val := { val := n, isLt := h }
}

abbrev Nat.isValidChar (n : Nat) : Prop :=
  Or (Less n 0xd800) (And (Less 0xdfff n) (Less n 0x110000))

abbrev UInt32.isValidChar (n : UInt32) : Prop :=
  n.val.val.isValidChar

/-- The `Char` Type represents an unicode scalar value.
    See http://www.unicode.org/glossary/#unicode_scalar_value). -/
structure Char :=
  (val   : UInt32)
  (valid : val.isValidChar)

private theorem validCharIsUInt32 {n : Nat} (h : n.isValidChar) : Less n uint32Sz :=
  match h with
  | Or.inl h      => Nat.ltTrans h (decide! : Less 55296 uint32Sz)
  | Or.inr ⟨_, h⟩ => Nat.ltTrans h (decide! : Less 1114112 uint32Sz)

abbrev Char.ofNat (n : Nat) : Char :=
  if h : n.isValidChar then
    { val := ⟨{ val := n, isLt := validCharIsUInt32 h }⟩, valid := h }
  else
    { val := ⟨{ val := 0, isLt := decide! }⟩, valid := Or.inl decide! }

theorem Char.eqOfVeq : ∀ {c d : Char}, Eq c.val d.val → Eq c d
  | ⟨v, h⟩, ⟨_, _⟩, rfl => rfl

theorem Char.veqOfEq : ∀ {c d : Char}, Eq c d → Eq c.val d.val
  | _, _, rfl => rfl

theorem Char.neOfVne {c d : Char} (h : Not (Eq c.val d.val)) : Not (Eq c d) :=
  fun h' => absurd (veqOfEq h') h

theorem Char.vneOfNe {c d : Char} (h : Not (Eq c d)) : Not (Eq c.val d.val) :=
  fun h' => absurd (eqOfVeq h') h

instance : DecidableEq Char :=
  fun c d =>
    match decEq c.val d.val with
    | isTrue h  => isTrue (Char.eqOfVeq h)
    | isFalse h => isFalse (Char.neOfVne h)

inductive Option (α : Type u)
  | none : Option α
  | some (val : α) : Option α

attribute [unbox] Option

export Option (none some)

instance {α} : Inhabited (Option α) := {
  default := none
}

inductive List (α : Type u)
  | nil : List α
  | cons (head : α) (tail : List α) : List α

instance {α} : Inhabited (List α) := {
  default := List.nil
}

protected def List.hasDecEq {α: Type u} [DecidableEq α] : (a b : List α) → Decidable (Eq a b)
  | nil,       nil       => isTrue rfl
  | cons a as, nil       => isFalse (fun h => List.noConfusion h)
  | nil,       cons b bs => isFalse (fun h => List.noConfusion h)
  | cons a as, cons b bs =>
    match decEq a b with
    | isTrue hab  =>
      match List.hasDecEq as bs with
      | isTrue habs  => isTrue (hab ▸ habs ▸ rfl)
      | isFalse nabs => isFalse (fun h => List.noConfusion h (fun _ habs => absurd habs nabs))
    | isFalse nab => isFalse (fun h => List.noConfusion h (fun hab _ => absurd hab nab))

instance {α : Type u} [DecidableEq α] : DecidableEq (List α) := List.hasDecEq

@[specialize]
def List.foldl {α β} (f : α → β → α) : (init : α) → List β → α
  | a, nil      => a
  | a, cons b l => foldl f (f a b) l

structure String :=
  (data : List Char)

attribute [extern "lean_string_mk"] String.mk
attribute [extern "lean_string_data"] String.data

@[extern "lean_string_dec_eq"]
def String.decEq (s₁ s₂ : @& String) : Decidable (s₁ = s₂) :=
  match s₁, s₂ with
  | ⟨s₁⟩, ⟨s₂⟩ =>
   if h : s₁ = s₂ then isTrue (congrArg _ h)
   else isFalse (fun h' => String.noConfusion h' (fun h' => absurd h' h))

instance : DecidableEq String := String.decEq

/-- A byte position in a `String`. Internally, `String`s are UTF-8 encoded.
Codepoint positions (counting the Unicode codepoints rather than bytes)
are represented by plain `Nat`s instead.
Indexing a `String` by a byte position is constant-time, while codepoint
positions need to be translated internally to byte positions in linear-time. -/
abbrev String.Pos := Nat

structure Substring :=
  (str : String)
  (startPos : String.Pos)
  (stopPos : String.Pos)

@[extern c inline "#3"]
unsafe def unsafeCast {α : Type u} {β : Type v} (a : α) : β :=
  cast lcProof (PUnit.{v})

@[neverExtract, extern "lean_panic_fn"]
constant panic {α : Type u} [Inhabited α] (msg : String) : α

/-
The Compiler has special support for arrays.
They are implemented using dynamic arrays: https://en.wikipedia.org/wiki/Dynamic_array
-/
structure Array (α : Type u) :=
  (sz   : Nat)
  (data : Fin sz → α)

attribute [extern "lean_array_mk"] Array.mk
attribute [extern "lean_array_data"] Array.data
attribute [extern "lean_array_sz"] Array.sz

/- The parameter `c` is the initial capacity -/
@[extern "lean_mk_empty_array_with_capacity"]
def Array.mkEmpty {α : Type u} (c : @& Nat) : Array α := {
  sz   := 0,
  data := fun ⟨x, h⟩ => absurd h (Nat.notLtZero x)
}

def Array.empty {α : Type u} : Array α :=
  mkEmpty 0

@[reducible, extern "lean_array_get_size"]
def Array.size {α : Type u} (a : @& Array α) : Nat :=
  a.sz

@[extern "lean_array_fget"]
def Array.get {α : Type u} (a : @& Array α) (i : @& Fin a.size) : α :=
  a.data i

/- "Comfortable" version of `fget`. It performs a bound check at runtime. -/
@[extern "lean_array_get"]
def Array.get! {α : Type u} [Inhabited α] (a : @& Array α) (i : @& Nat) : α :=
  if h : Less i a.size then a.get ⟨i, h⟩ else arbitrary α

@[extern "lean_array_push"]
def push {α : Type u} (a : Array α) (v : α) : Array α := {
  sz   := Nat.succ a.sz,
  data := fun ⟨j, h₁⟩ =>
    if h₂ : j = a.sz then
      v
    else
      a.data ⟨j, Nat.ltOfLeOfNe (Nat.leOfLtSucc h₁) h₂⟩
}

class Bind (m : Type u → Type v) :=
  (bind : {α β : Type u} → m α → (α → m β) → m β)

export Bind (bind)

class Pure (f : Type u → Type v) :=
  (pure {α : Type u} : α → f α)

export Pure (pure)

class Functor (f : Type u → Type v) : Type (max (u+1) v) :=
  (map      : {α β : Type u} → (α → β) → f α → f β)
  (mapConst : {α β : Type u} → α → f β → f α := Function.comp map (Function.const _))

class Seq (f : Type u → Type v) : Type (max (u+1) v) :=
  (seq  : {α β : Type u} → f (α → β) → f α → f β)

class SeqLeft (f : Type u → Type v) : Type (max (u+1) v) :=
  (seqLeft : {α : Type u} → f α → f PUnit → f α)

class SeqRight (f : Type u → Type v) : Type (max (u+1) v) :=
  (seqRight : {β : Type u} → f PUnit → f β → f β)

class Applicative (f : Type u → Type v) extends Functor f, Pure f, Seq f, SeqLeft f, SeqRight f :=
  (map      := fun x y => Seq.seq (pure x) y)
  (seqLeft  := fun a b => Seq.seq (Functor.map (Function.const _) a) b)
  (seqRight := fun a b => Seq.seq (Functor.map (Function.const _ id) a) b)

class Monad (m : Type u → Type v) extends Applicative m, Bind m : Type (max (u+1) v) :=
  (map      := fun f x => bind x (Function.comp pure f))
  (seq      := fun f x => bind f (fun y => Functor.map y x))
  (seqLeft  := fun x y => bind x (fun a => bind y (fun _ => pure a)))
  (seqRight := fun x y => bind x (fun _ => y))

instance {α : Type u} {m : Type u → Type v} [Monad m] : Inhabited (α → m α) := ⟨pure⟩

instance {α : Type u} {m : Type u → Type v} [Monad m] [Inhabited α] : Inhabited (m α) := ⟨pure $ arbitrary _⟩

/-- A Function for lifting a computation from an inner Monad to an outer Monad.
    Like [MonadTrans](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Class.html),
    but `n` does not have to be a monad transformer.
    Alternatively, an implementation of [MonadLayer](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLayer) without `layerInvmap` (so far). -/
class MonadLift (m : Type u → Type v) (n : Type u → Type w) :=
  (monadLift : {α : Type u} → m α → n α)

/-- The reflexive-transitive closure of `MonadLift`.
    `monadLift` is used to transitively lift monadic computations such as `StateT.get` or `StateT.put s`.
    Corresponds to [MonadLift](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLift). -/
class MonadLiftT (m : Type u → Type v) (n : Type u → Type w) :=
  (monadLift : {α : Type u} → m α → n α)

export MonadLiftT (monadLift)

abbrev liftM := @monadLift

instance (m n o) [MonadLiftT m n] [MonadLift n o] : MonadLiftT m o := {
  monadLift := fun x => MonadLift.monadLift (m := n) (monadLift x)
}

instance (m) : MonadLiftT m m := {
  monadLift := fun x => x
}

/-- A functor in the category of monads. Can be used to lift monad-transforming functions.
    Based on pipes' [MFunctor](https://hackage.haskell.org/package/pipes-2.4.0/docs/Control-MFunctor.html),
    but not restricted to monad transformers.
    Alternatively, an implementation of [MonadTransFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadTransFunctor). -/
class MonadFunctor (m : Type u → Type v) (n : Type u → Type w) :=
  (monadMap {α : Type u} : (∀ {β}, m β → m β) → n α → n α)

/-- The reflexive-transitive closure of `MonadFunctor`.
    `monadMap` is used to transitively lift Monad morphisms -/
class MonadFunctorT (m : Type u → Type v) (n : Type u → Type w) :=
  (monadMap {α : Type u} : (∀ {β}, m β → m β) → n α → n α)

export MonadFunctorT (monadMap)

instance (m n o) [MonadFunctorT m n] [MonadFunctor n o] : MonadFunctorT m o := {
  monadMap := fun f => MonadFunctor.monadMap (m := n) (monadMap (m := m) f)
}

instance monadFunctorRefl (m) : MonadFunctorT m m := {
  monadMap := fun f => f
}

inductive Except (ε : Type u) (α : Type v)
  | error : ε → Except ε α
  | ok    : α → Except ε α

attribute [unbox] Except

instance {ε : Type u} {α : Type v} [Inhabited ε] : Inhabited (Except ε α) :=
  ⟨Except.error (arbitrary ε)⟩

/-- An implementation of [MonadError](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Except.html#t:MonadError) -/
class MonadExceptOf (ε : Type u) (m : Type v → Type w) :=
  (throw {α : Type v} : ε → m α)
  (tryCatch {α : Type v} : m α → (ε → m α) → m α)

abbrev throwThe (ε : Type u) {m : Type v → Type w} [MonadExceptOf ε m] {α : Type v} (e : ε) : m α :=
  MonadExceptOf.throw e

abbrev tryCatchThe (ε : Type u) {m : Type v → Type w} [MonadExceptOf ε m] {α : Type v} (x : m α) (handle : ε → m α) : m α :=
  MonadExceptOf.tryCatch x handle

/-- Similar to `MonadExceptOf`, but `ε` is an outParam for convenience -/
class MonadExcept (ε : outParam (Type u)) (m : Type v → Type w) :=
  (throw {α : Type v} : ε → m α)
  (tryCatch {α : Type v} : m α → (ε → m α) → m α)

export MonadExcept (throw tryCatch)

instance (ε : outParam (Type u)) (m : Type v → Type w) [MonadExceptOf ε m] : MonadExcept ε m := {
  throw    := throwThe ε,
  tryCatch := tryCatchThe ε
}

namespace MonadExcept
variables {ε : Type u} {m : Type v → Type w}

@[inline] protected def orelse [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) : m α :=
  tryCatch t₁ fun _ => t₂

instance [MonadExcept ε m] {α : Type v} : OrElse (m α) := ⟨MonadExcept.orelse⟩

end MonadExcept

/-- An implementation of [ReaderT](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Reader.html#t:ReaderT) -/
def ReaderT (ρ : Type u) (m : Type u → Type v) (α : Type u) : Type (max u v) :=
  ρ → m α

instance (ρ : Type u) (m : Type u → Type v) (α : Type u) [Inhabited (m α)] : Inhabited (ReaderT ρ m α) :=
  ⟨fun _ => arbitrary _⟩

@[inline] def ReaderT.run {ρ : Type u} {m : Type u → Type v} {α : Type u} (x : ReaderT ρ m α) (r : ρ) : m α :=
  x r

@[reducible] def Reader (ρ : Type u) := ReaderT ρ id

namespace ReaderT

section
variables {ρ : Type u} {m : Type u → Type v} {α : Type u}

@[inline] protected def lift  (a : m α) : ReaderT ρ m α :=
  fun r => a

instance  : MonadLift m (ReaderT ρ m) := ⟨ReaderT.lift⟩

instance (ε) [MonadExceptOf ε m] : MonadExceptOf ε (ReaderT ρ m) := {
  throw    := Function.comp ReaderT.lift (throwThe ε),
  tryCatch := fun x c r => tryCatchThe ε (x r) (fun e => (c e) r)
}

end

section
variables {ρ : Type u} {m : Type u → Type v} [Monad m] {α β : Type u}

@[inline] protected def read : ReaderT ρ m ρ :=
  pure

@[inline] protected def pure (a : α) : ReaderT ρ m α :=
  fun r => pure a

@[inline] protected def bind (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) : ReaderT ρ m β :=
  fun r => bind (x r) fun a => f a r

@[inline] protected def map (f : α → β) (x : ReaderT ρ m α) : ReaderT ρ m β :=
  fun r => Functor.map f (x r)

instance : Monad (ReaderT ρ m) := {
  pure := ReaderT.pure,
  bind := ReaderT.bind,
  map  := ReaderT.map
}

instance (ρ m) [Monad m] : MonadFunctor m (ReaderT ρ m) := ⟨fun f x r => f (x r)⟩

@[inline] protected def adapt {ρ' : Type u} [Monad m] {α : Type u} (f : ρ' → ρ) : ReaderT ρ m α → ReaderT ρ' m α :=
  fun x r => x (f r)

end
end ReaderT

/-- An implementation of [MonadReader](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader).
    It does not contain `local` because this Function cannot be lifted using `monadLift`.
    Instead, the `MonadReaderAdapter` class provides the more general `adaptReader` Function.

    Note: This class can be seen as a simplification of the more "principled" definition
    ```
    class MonadReader (ρ : outParam (Type u)) (n : Type u → Type u) :=
    (lift {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ReaderT ρ m α) → n α)
    ```
    -/
class MonadReaderOf (ρ : Type u) (m : Type u → Type v) :=
  (read : m ρ)

@[inline] def readThe (ρ : Type u) {m : Type u → Type v} [MonadReaderOf ρ m] : m ρ :=
  MonadReaderOf.read

/-- Similar to `MonadReaderOf`, but `ρ` is an outParam for convenience -/
class MonadReader (ρ : outParam (Type u)) (m : Type u → Type v) :=
  (read : m ρ)

export MonadReader (read)

instance (ρ : Type u) (m : Type u → Type v) [MonadReaderOf ρ m] : MonadReader ρ m :=
  ⟨readThe ρ⟩

instance {ρ : Type u} {m : Type u → Type v} {n : Type u → Type w} [MonadReaderOf ρ m] [MonadLift m n] : MonadReaderOf ρ n :=
  ⟨monadLift (MonadReader.read : m ρ)⟩

instance {ρ : Type u} {m : Type u → Type v} [Monad m] : MonadReaderOf ρ (ReaderT ρ m) :=
  ⟨ReaderT.read⟩

class MonadWithReaderOf (ρ : Type u) (m : Type u → Type v) :=
  (withReader {α : Type u} : (ρ → ρ) → m α → m α)

@[inline] def withTheReader (ρ : Type u) {m : Type u → Type v} [MonadWithReaderOf ρ m] {α : Type u} (f : ρ → ρ) (x : m α) : m α :=
  MonadWithReaderOf.withReader f x

class MonadWithReader (ρ : outParam (Type u)) (m : Type u → Type v) :=
  (withReader {α : Type u} : (ρ → ρ) → m α → m α)

export MonadWithReader (withReader)

instance (ρ : Type u) (m : Type u → Type v) [MonadWithReaderOf ρ m] : MonadWithReader ρ m := ⟨withTheReader ρ⟩

instance {ρ : Type u} {m : Type u → Type v} {n : Type u → Type v} [MonadWithReaderOf ρ m] [MonadFunctor m n] : MonadWithReaderOf ρ n :=
  ⟨fun f => monadMap (m := m) (withTheReader ρ f)⟩

instance {ρ : Type u} {m : Type u → Type v} [Monad m] : MonadWithReaderOf ρ (ReaderT ρ m) :=
  ⟨fun f x ctx => x (f ctx)⟩

/-- An implementation of [MonadState](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-State-Class.html).
    In contrast to the Haskell implementation, we use overlapping instances to derive instances
    automatically from `monadLift`. -/
class MonadStateOf (σ : Type u) (m : Type u → Type v) :=
  /- Obtain the top-most State of a Monad stack. -/
  (get : m σ)
  /- Set the top-most State of a Monad stack. -/
  (set : σ → m PUnit)
  /- Map the top-most State of a Monad stack.

     Note: `modifyGet f` may be preferable to `do s <- get; let (a, s) := f s; put s; pure a`
     because the latter does not use the State linearly (without sufficient inlining). -/
  (modifyGet {α : Type u} : (σ → α × σ) → m α)

export MonadStateOf (set)

abbrev getThe (σ : Type u) {m : Type u → Type v} [MonadStateOf σ m] : m σ :=
  MonadStateOf.get

@[inline] abbrev modifyThe (σ : Type u) {m : Type u → Type v} [MonadStateOf σ m] (f : σ → σ) : m PUnit :=
  MonadStateOf.modifyGet fun s => (PUnit.unit, f s)

@[inline] abbrev modifyGetThe {α : Type u} (σ : Type u) {m : Type u → Type v} [MonadStateOf σ m] (f : σ → α × σ) : m α :=
  MonadStateOf.modifyGet f

/-- Similar to `MonadStateOf`, but `σ` is an outParam for convenience -/
class MonadState (σ : outParam (Type u)) (m : Type u → Type v) :=
  (get : m σ)
  (set : σ → m PUnit)
  (modifyGet {α : Type u} : (σ → α × σ) → m α)

export MonadState (get modifyGet)

instance (σ : Type u) (m : Type u → Type v) [MonadStateOf σ m] : MonadState σ m := {
  set       := MonadStateOf.set,
  get       := getThe σ,
  modifyGet := fun f => MonadStateOf.modifyGet f
}

@[inline] def modify {σ : Type u} {m : Type u → Type v} [MonadState σ m] (f : σ → σ) : m PUnit :=
  modifyGet fun s => (PUnit.unit, f s)

@[inline] def getModify {σ : Type u} {m : Type u → Type v} [MonadState σ m] [Monad m] (f : σ → σ) : m σ :=
  modifyGet fun s => (s, f s)

-- NOTE: The Ordering of the following two instances determines that the top-most `StateT` Monad layer
-- will be picked first
instance {σ : Type u} {m : Type u → Type v} {n : Type u → Type w} [MonadStateOf σ m] [MonadLift m n] : MonadStateOf σ n := {
  get       := liftM (m := m) MonadStateOf.get,
  set       := fun s => liftM (m := m) (MonadStateOf.set s),
  modifyGet := fun f => monadLift (m := m) (MonadState.modifyGet f)
}

namespace EStateM

inductive Result (ε σ α : Type u)
  | ok    : α → σ → Result ε σ α
  | error : ε → σ → Result ε σ α

variables {ε σ α : Type u}

instance [Inhabited ε] [Inhabited σ] : Inhabited (Result ε σ α) := ⟨Result.error (arbitrary _) (arbitrary _)⟩

end EStateM

open EStateM (Result) in
def EStateM (ε σ α : Type u) := σ → Result ε σ α

namespace EStateM

variables {ε σ α β : Type u}

instance [Inhabited ε] : Inhabited (EStateM ε σ α) := ⟨fun s =>
  Result.error (arbitrary ε) s⟩

@[inline] protected def pure (a : α) : EStateM ε σ α := fun s =>
  Result.ok a s

@[inline] protected def set (s : σ) : EStateM ε σ PUnit := fun _ =>
  Result.ok ⟨⟩ s

@[inline] protected def get : EStateM ε σ σ := fun s =>
  Result.ok s s

@[inline] protected def modifyGet (f : σ → α × σ) : EStateM ε σ α := fun s =>
  match f s with
  | (a, s) => Result.ok a s

@[inline] protected def throw (e : ε) : EStateM ε σ α := fun s =>
  Result.error e s

/-- Auxiliary instance for saving/restoring the "backtrackable" part of the state. -/
class Backtrackable (δ : outParam (Type u)) (σ : Type u) :=
  (save    : σ → δ)
  (restore : σ → δ → σ)

@[inline] protected def tryCatch {δ} [Backtrackable δ σ] {α} (x : EStateM ε σ α) (handle : ε → EStateM ε σ α) : EStateM ε σ α := fun s =>
  let d := Backtrackable.save s
  match x s with
  | Result.error e s => handle e (Backtrackable.restore s d)
  | ok               => ok

@[inline] protected def orElse {δ} [Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) : EStateM ε σ α := fun s =>
  let d := Backtrackable.save s;
  match x₁ s with
  | Result.error _ s => x₂ (Backtrackable.restore s d)
  | ok               => ok

@[inline] def adaptExcept {ε' : Type u} (f : ε → ε') (x : EStateM ε σ α) : EStateM ε' σ α := fun s =>
  match x s with
  | Result.error e s => Result.error (f e) s
  | Result.ok a s    => Result.ok a s

@[inline] protected def bind (x : EStateM ε σ α) (f : α → EStateM ε σ β) : EStateM ε σ β := fun s =>
  match x s with
  | Result.ok a s    => f a s
  | Result.error e s => Result.error e s

@[inline] protected def map (f : α → β) (x : EStateM ε σ α) : EStateM ε σ β := fun s =>
  match x s with
  | Result.ok a s    => Result.ok (f a) s
  | Result.error e s => Result.error e s

@[inline] protected def seqRight (x : EStateM ε σ PUnit) (y : EStateM ε σ β) : EStateM ε σ β := fun s =>
  match x s with
  | Result.ok _ s    => y s
  | Result.error e s => Result.error e s

instance : Monad (EStateM ε σ) := {
  bind     := EStateM.bind,
  pure     := EStateM.pure,
  map      := EStateM.map,
  seqRight := EStateM.seqRight
}

instance {δ} [Backtrackable δ σ] : OrElse (EStateM ε σ α) := {
  orElse := EStateM.orElse
}

instance : MonadStateOf σ (EStateM ε σ) := {
  set       := EStateM.set,
  get       := EStateM.get,
  modifyGet := EStateM.modifyGet
}

instance {δ} [Backtrackable δ σ] : MonadExceptOf ε (EStateM ε σ) := {
  throw    := EStateM.throw,
  tryCatch := EStateM.tryCatch
}

@[inline] def run (x : EStateM ε σ α) (s : σ) : Result ε σ α :=
  x s

@[inline] def run' (x : EStateM ε σ α) (s : σ) : Option α :=
  match run x s with
  | Result.ok v _    => some v
  | Result.error _ _ => none

@[inline] def dummySave : σ → PUnit := fun _ => ⟨⟩

@[inline] def dummyRestore : σ → PUnit → σ := fun s _ => s

/- Dummy default instance -/
instance nonBacktrackable : Backtrackable PUnit σ := {
  save    := dummySave,
  restore := dummyRestore
}

end EStateM

class Hashable (α : Type u) :=
  (hash : α → USize)

export Hashable (hash)

@[extern "lean_usize_mix_hash"]
constant mixHash (u₁ u₂ : USize) : USize

@[extern "lean_string_hash"]
protected constant String.hash (s : @& String) : USize

instance : Hashable String := ⟨String.hash⟩

namespace Lean

/- Hierarchical names -/
inductive Name
  | anonymous : Name
  | str : Name → String → USize → Name
  | num : Name → Nat → USize → Name

instance : Inhabited Name := ⟨Name.anonymous⟩

protected def Name.hash : Name → USize
  | Name.anonymous => USize.ofNat32 1723 decide!
  | Name.str p s h => h
  | Name.num p v h => h

instance : Hashable Name := ⟨Name.hash⟩

@[export lean_name_mk_string]
def mkNameStr (p : Name) (s : String) : Name :=
  Name.str p s (mixHash (hash p) (hash s))

@[export lean_name_mk_numeral]
def mkNameNum (p : Name) (v : Nat) : Name :=
  Name.num p v (mixHash (hash p) (if h : Less v usizeSz then USize.ofNatCore v h else USize.ofNat32 17 decide!))

def mkNameSimple (s : String) : Name :=
  mkNameStr Name.anonymous s

namespace Name
@[extern "lean_name_eq"]
protected def beq : (@& Name) → (@& Name) → Bool
  | anonymous,   anonymous   => true
  | str p₁ s₁ _, str p₂ s₂ _ => BEq.beq s₁ s₂ && Name.beq p₁ p₂
  | num p₁ n₁ _, num p₂ n₂ _ => BEq.beq n₁ n₂ && Name.beq p₁ p₂
  | _,           _           => false

instance : BEq Name := ⟨Name.beq⟩

protected def append : Name → Name → Name
  | n, anonymous => n
  | n, str p s _ => mkNameStr (Name.append n p) s
  | n, num p d _ => mkNameNum (Name.append n p) d

instance : Append Name := ⟨Name.append⟩

end Name

/- Syntax -/

/--
  Source information of syntax atoms. All information is generally set for unquoted syntax and unset for syntax in
  syntax quotations, but syntax transformations might want to invalidate only one side to make the pretty printer
  reformat it. In the special case of the delaborator, we also use purely synthetic position information without
  whitespace information. -/
structure SourceInfo :=
  /- Will be inferred after parsing by `Syntax.updateLeading`. During parsing,
     it is not at all clear what the preceding token was, especially with backtracking. -/
  (leading  : Option Substring  := none)
  (pos      : Option String.Pos := none)
  (trailing : Option Substring  := none)

instance : Inhabited SourceInfo := ⟨{}⟩

abbrev SyntaxNodeKind := Name

/- Syntax AST -/

inductive Syntax
  | missing : Syntax
  | node   (kind : SyntaxNodeKind) (args : Array Syntax) : Syntax
  | atom   (info : SourceInfo) (val : String) : Syntax
  | ident  (info : SourceInfo) (rawVal : Substring) (val : Name) (preresolved : List (Prod Name (List String))) : Syntax

instance : Inhabited Syntax := ⟨Syntax.missing⟩

/- Builtin kinds -/
def choiceKind : SyntaxNodeKind := `choice
def nullKind : SyntaxNodeKind := `null
def identKind : SyntaxNodeKind := `ident
def strLitKind : SyntaxNodeKind := `strLit
def charLitKind : SyntaxNodeKind := `charLit
def numLitKind : SyntaxNodeKind := `numLit
def nameLitKind : SyntaxNodeKind := `nameLit
def fieldIdxKind : SyntaxNodeKind := `fieldIdx
def interpolatedStrLitKind : SyntaxNodeKind := `interpolatedStrLitKind
def interpolatedStrKind : SyntaxNodeKind := `interpolatedStrKind

namespace Syntax

def getKind (stx : Syntax) : SyntaxNodeKind :=
  match stx with
  | Syntax.node k args   => k
  -- We use these "pseudo kinds" for antiquotation kinds.
  -- For example, an antiquotation `$id:ident` (using Lean.Parser.Term.ident)
  -- is compiled to ``if stx.isOfKind `ident ...``
  | Syntax.missing       => `missing
  | Syntax.atom _ v      => mkNameSimple v
  | Syntax.ident _ _ _ _ => identKind

def setKind (stx : Syntax) (k : SyntaxNodeKind) : Syntax :=
  match stx with
  | Syntax.node _ args => Syntax.node k args
  | _                  => stx

def isOfKind (stx : Syntax) (k : SyntaxNodeKind) : Bool :=
  beq stx.getKind k

def getArg (stx : Syntax) (i : Nat) : Syntax :=
  match stx with
  | Syntax.node _ args => args.get! i
  | _                  => Syntax.missing -- panic! "Syntax.getArg: not a node"

-- Add `stx[i]` as sugar for `stx.getArg i`
@[inline] def getOp (self : Syntax) (idx : Nat) : Syntax :=
  self.getArg idx

def getArgs (stx : Syntax) : Array Syntax :=
  match stx with
  | Syntax.node _ args => args
  | _                  => Array.empty

end Syntax

inductive ParserDescr
  | andthen           : ParserDescr → ParserDescr → ParserDescr
  | orelse            : ParserDescr → ParserDescr → ParserDescr
  | optional          : ParserDescr → ParserDescr
  | lookahead         : ParserDescr → ParserDescr
  | «try»             : ParserDescr → ParserDescr
  | many              : ParserDescr → ParserDescr
  | many1             : ParserDescr → ParserDescr
  | sepBy             : ParserDescr → ParserDescr → Bool → ParserDescr
  | sepBy1            : ParserDescr → ParserDescr → Bool → ParserDescr
  | node              : Name → Nat → ParserDescr → ParserDescr
  | trailingNode      : Name → Nat → ParserDescr → ParserDescr
  | symbol            : String → ParserDescr
  | nonReservedSymbol : String → Bool → ParserDescr
  | noWs              : ParserDescr
  | numLit            : ParserDescr
  | strLit            : ParserDescr
  | charLit           : ParserDescr
  | nameLit           : ParserDescr
  | interpolatedStr   : ParserDescr → ParserDescr -- interpolated string
  | ident             : ParserDescr
  | cat               : Name → Nat → ParserDescr
  | parser            : Name → ParserDescr
  | notFollowedBy     : ParserDescr → ParserDescr
  | withPosition      : ParserDescr → ParserDescr
  | checkCol          : Bool → ParserDescr

instance : Inhabited ParserDescr := ⟨ParserDescr.symbol ""⟩
abbrev TrailingParserDescr := ParserDescr

/-
Runtime support for making quotation terms auto-hygienic, by mangling identifiers
introduced by them with a "macro scope" supplied by the context. Details to appear in a
paper soon.
-/

abbrev MacroScope := Nat
/-- Macro scope used internally. It is not available for our frontend. -/
def reservedMacroScope := 0
/-- First macro scope available for our frontend -/
def firstFrontendMacroScope := add reservedMacroScope 1

/-- A monad that supports syntax quotations. Syntax quotations (in term
    position) are monadic values that when executed retrieve the current "macro
    scope" from the monad and apply it to every identifier they introduce
    (independent of whether this identifier turns out to be a reference to an
    existing declaration, or an actually fresh binding during further
    elaboration). -/
class MonadQuotation (m : Type → Type) :=
  -- Get the fresh scope of the current macro invocation
  (getCurrMacroScope : m MacroScope)
  (getMainModule     : m Name)
  /- Execute action in a new macro invocation context. This transformer should be
     used at all places that morally qualify as the beginning of a "macro call",
     e.g. `elabCommand` and `elabTerm` in the case of the elaborator. However, it
     can also be used internally inside a "macro" if identifiers introduced by
     e.g. different recursive calls should be independent and not collide. While
     returning an intermediate syntax tree that will recursively be expanded by
     the elaborator can be used for the same effect, doing direct recursion inside
     the macro guarded by this transformer is often easier because one is not
     restricted to passing a single syntax tree. Modelling this helper as a
     transformer and not just a monadic action ensures that the current macro
     scope before the recursive call is restored after it, as expected. -/
  (withFreshMacroScope {α : Type} : m α → m α)

export MonadQuotation (getCurrMacroScope getMainModule withFreshMacroScope)

instance {m n : Type → Type} [MonadQuotation m] [MonadLift m n] [MonadFunctorT m n] : MonadQuotation n := {
  getCurrMacroScope   := liftM (m := m) getCurrMacroScope,
  getMainModule       := liftM (m := m) getMainModule,
  withFreshMacroScope := monadMap (m := m) withFreshMacroScope
}

/-
We represent a name with macro scopes as
```
<actual name>._@.(<module_name>.<scopes>)*.<module_name>._hyg.<scopes>
```
Example: suppose the module name is `Init.Data.List.Basic`, and name is `foo.bla`, and macroscopes [2, 5]
```
foo.bla._@.Init.Data.List.Basic._hyg.2.5
```

We may have to combine scopes from different files/modules.
The main modules being processed is always the right most one.
This situation may happen when we execute a macro generated in
an imported file in the current file.
```
foo.bla._@.Init.Data.List.Basic.2.1.Init.Lean.Expr_hyg.4
```

The delimiter `_hyg` is used just to improve the `hasMacroScopes` performance.
-/

def Name.hasMacroScopes : Name → Bool
  | str _ s _   => beq s "_hyg"
  | num p _   _ => hasMacroScopes p
  | _           => false

private def eraseMacroScopesAux : Name → Name
  | Name.str p s _   => if s = "_@" then p else eraseMacroScopesAux p
  | Name.num p _ _   => eraseMacroScopesAux p
  | Name.anonymous   => Name.anonymous

@[export lean_erase_macro_scopes]
def Name.eraseMacroScopes (n : Name) : Name :=
  match n.hasMacroScopes with
  | true  => eraseMacroScopesAux n
  | false => n

private def simpMacroScopesAux : Name → Name
  | Name.num p i _ => mkNameNum (simpMacroScopesAux p) i
  | n              => eraseMacroScopesAux n

/- Helper function we use to create binder names that do not need to be unique. -/
@[export lean_simp_macro_scopes]
def Name.simpMacroScopes (n : Name) : Name :=
  match n.hasMacroScopes with
  | true  => simpMacroScopesAux n
  | false => n

structure MacroScopesView :=
  (name       : Name)
  (imported   : Name)
  (mainModule : Name)
  (scopes     : List MacroScope)

instance : Inhabited MacroScopesView := ⟨⟨arbitrary _, arbitrary _, arbitrary _, arbitrary _⟩⟩

def MacroScopesView.review (view : MacroScopesView) : Name :=
  match view.scopes with
  | List.nil      => view.name
  | List.cons _ _ =>
    let base := (mkNameStr (append (append (mkNameStr view.name "_@") view.imported) view.mainModule) "_hyg")
    view.scopes.foldl mkNameNum base

private def assembleParts : List Name → Name → Name
  | List.nil,                      acc => acc
  | List.cons (Name.str _ s _) ps, acc => assembleParts ps (mkNameStr acc s)
  | List.cons (Name.num _ n _) ps, acc => assembleParts ps (mkNameNum acc n)
  | _,                             acc => panic "unreachable @ assembleParts"

private def extractImported (scps : List MacroScope) (mainModule : Name) : Name → List Name → MacroScopesView
  | n@(Name.str p str _), parts =>
    if str = "_@" then
      { name := p, mainModule := mainModule, imported := assembleParts parts Name.anonymous, scopes := scps }
    else
      extractImported scps mainModule p (List.cons n parts)
  | n@(Name.num p str _), parts => extractImported scps mainModule p (List.cons n parts)
  | _,                    _     => panic "unreachable @ extractImported"

private def extractMainModule (scps : List MacroScope) : Name → List Name → MacroScopesView
  | n@(Name.str p str _), parts =>
    if str = "_@" then
      { name := p, mainModule := assembleParts parts Name.anonymous, imported := Name.anonymous, scopes := scps }
    else
      extractMainModule scps p (List.cons n parts)
  | n@(Name.num p num _), acc => extractImported scps (assembleParts acc Name.anonymous) n List.nil
  | _,                    _   => panic "unreachable @ extractMainModule"

private def extractMacroScopesAux : Name → List MacroScope → MacroScopesView
  | Name.num p scp _, acc => extractMacroScopesAux p (List.cons scp acc)
  | Name.str p str _, acc => extractMainModule acc p List.nil -- str must be "_hyg"
  | _,                _   => panic "unreachable @ extractMacroScopesAux"

/--
  Revert all `addMacroScope` calls. `v = extractMacroScopes n → n = v.review`.
  This operation is useful for analyzing/transforming the original identifiers, then adding back
  the scopes (via `MacroScopesView.review`). -/
def extractMacroScopes (n : Name) : MacroScopesView :=
  match n.hasMacroScopes with
  | true  => extractMacroScopesAux n List.nil
  | false => { name := n, scopes := List.nil, imported := Name.anonymous, mainModule := Name.anonymous }

def addMacroScope (mainModule : Name) (n : Name) (scp : MacroScope) : Name :=
  match n.hasMacroScopes with
  | true =>
    let view := extractMacroScopes n
    match beq view.mainModule mainModule with
    | true  => mkNameNum n scp
    | false =>
      { view with
        imported   := view.scopes.foldl mkNameNum (append view.imported view.mainModule),
        mainModule := mainModule,
        scopes     := List.cons scp List.nil
      }.review
  | false =>
    mkNameNum (mkNameStr (append (mkNameStr n "_@") mainModule) "_hyg") scp

@[inline] def MonadQuotation.addMacroScope {m : Type → Type} [MonadQuotation m] [Monad m] (n : Name) : m Name :=
  bind getMainModule     fun mainModule =>
  bind getCurrMacroScope fun scp =>
  pure (Lean.addMacroScope mainModule n scp)

def defaultMaxRecDepth := 512

def maxRecDepthErrorMessage : String :=
  "maximum recursion depth has been reached (use `set_option maxRecDepth <num>` to increase limit)"

namespace Macro

/- References -/
constant MacroEnvPointed : PointedType.{0}

def MacroEnv : Type := MacroEnvPointed.type
instance : Inhabited MacroEnv := ⟨MacroEnvPointed.val⟩

structure Context :=
  (macroEnv       : MacroEnv)
  (mainModule     : Name)
  (currMacroScope : MacroScope)
  (currRecDepth   : Nat := 0)
  (maxRecDepth    : Nat := defaultMaxRecDepth)

inductive Exception
  | error             : Syntax → String → Exception
  | unsupportedSyntax : Exception

end Macro

abbrev MacroM := ReaderT Macro.Context (EStateM Macro.Exception MacroScope)

abbrev Macro := Syntax → MacroM Syntax

namespace Macro

def addMacroScope (n : Name) : MacroM Name :=
  bind read fun ctx =>
  pure (Lean.addMacroScope ctx.mainModule n ctx.currMacroScope)

def throwUnsupported {α} : MacroM α :=
  throw Exception.unsupportedSyntax

def throwError {α} (ref : Syntax) (msg : String) : MacroM α :=
  throw (Exception.error ref msg)

@[inline] protected def withFreshMacroScope {α} (x : MacroM α) : MacroM α :=
  bind (modifyGet (fun s => (s, add s 1))) fun fresh =>
  withReader (fun ctx => { ctx with currMacroScope := fresh }) x

@[inline] def withIncRecDepth {α} (ref : Syntax) (x : MacroM α) : MacroM α :=
  bind read fun ctx =>
  if ctx.currRecDepth = ctx.maxRecDepth then
    throw (Exception.error ref maxRecDepthErrorMessage)
  else
    withReader (fun ctx => { ctx with currRecDepth := add ctx.currRecDepth 1 }) x

instance : MonadQuotation MacroM := {
  getCurrMacroScope   := fun ctx => pure ctx.currMacroScope,
  getMainModule       := fun ctx => pure ctx.mainModule,
  withFreshMacroScope := Macro.withFreshMacroScope
}

unsafe def mkMacroEnvImp (expandMacro? : Syntax → MacroM (Option Syntax)) : MacroEnv :=
  unsafeCast expandMacro?

@[implementedBy mkMacroEnvImp]
constant mkMacroEnv (expandMacro? : Syntax → MacroM (Option Syntax)) : MacroEnv

def expandMacroNotAvailable? (stx : Syntax) : MacroM (Option Syntax) :=
  throwError stx "expandMacro has not been set"

def mkMacroEnvSimple : MacroEnv :=
  mkMacroEnv expandMacroNotAvailable?

unsafe def expandMacro?Imp (stx : Syntax) : MacroM (Option Syntax) :=
  bind read fun ctx =>
  let f : Syntax → MacroM (Option Syntax) := unsafeCast (ctx.macroEnv)
  f stx

/-- `expandMacro? stx` return `some stxNew` if `stx` is a macro, and `stxNew` is its expansion. -/
@[implementedBy expandMacro?Imp] constant expandMacro? : Syntax → MacroM (Option Syntax)

end Macro

export Macro (expandMacro?)

end Lean

syntax "foo" term : term

macro_rules
  | `(foo $x) => x

#check foo 10


import Lean.Data.Json
import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Init.Data.Int.Basic
import Mathlib.Tactic.LibrarySearch
import Mathlib.Data.Equiv.Basic
import Mathlib.Init.Data.Int.Order
import Timelib.Date.Year
import Timelib.Date.Month

open Lean

structure Ymd where
  year : Year
  month : Month
  day : Nat
  dayGe : day >= 1
  dayLe : day <= month.numDays year
deriving Repr

instance : ToJson Ymd where
  toJson ymd := Json.mkObj [("year", ToJson.toJson ymd.year.val), ("month", ToJson.toJson ymd.month), ("day", ymd.day)]

instance : FromJson Ymd where
  fromJson? j := do
    let (year : Year) ← (fromJson? (← j.getObjVal? "year")).map Year.mk
    let (month : Month) ← (fromJson? (← j.getObjVal? "month"))
    let (day : Nat) ← fromJson? (← j.getObjVal? "day")
    if h : day >= 1 ∧ day <= month.numDays year
    then return Ymd.mk year month day h.left h.right
    else Except.error s!"Ymd day out of range: {day}"

theorem Ymd.eq_of_val_eq : ∀ {o₁ o₂ : Ymd} (h_year : o₁.year = o₂.year) (h_month : o₁.month = o₂.month) (h_day : o₁.day = o₂.day), o₁ = o₂
| ⟨y₁, m₁, d₁, hGt₁, hLt₁⟩, ⟨y₂, m₂, d₂, hGt₂, hLt₂⟩, hy, hm, hd => by simp [hy, hm, hd]

instance : Ord Ymd where
  compare d₁ d₂ :=
    match Ord.compare d₁.year d₂.year with
    | Ordering.eq =>
      match Ord.compare d₁.month d₂.month with
      | Ordering.eq => Ord.compare d₁.day d₂.day
      | owise => owise
    | owise => owise

instance : LE Ymd := leOfOrd
instance : LT Ymd := ltOfOrd

theorem Ymd.le_def (d₁ d₂ : Ymd) : (d₁ <= d₂) = (compare d₁ d₂).isLE := rfl
theorem Ymd.lt_def (d₁ d₂ : Ymd) : (d₁ < d₂) = (Ord.compare d₁ d₂ == Ordering.lt) := rfl

theorem Ymd.le_def' (d₁ d₂ : Ymd) :
  (d₁ <= d₂) =
  (d₁.year < d₂.year ∨ (d₁.year = d₂.year ∧ d₁.month < d₂.month) ∨ (d₁.year = d₂.year ∧ d₁.month = d₂.month ∧ d₁.day <= d₂.day)) := by
   simp [Ymd.le_def, Ordering.isLE, compare, compareOfLessAndEq]
   match lt_trichotomy d₁.year d₂.year with
   | .inl y_lt => simp [y_lt]
   | .inr (.inr y_gt) => simp [not_lt_of_gt y_gt, ne_of_gt y_gt]
   | .inr (.inl y_eq) =>
     simp [y_eq, lt_irrefl]
     match lt_trichotomy d₁.month d₂.month with
     | .inl m_lt => simp [m_lt]
     | .inr (.inr m_gt) => simp [not_lt_of_gt m_gt, ne_of_gt m_gt]
     | .inr (.inl m_eq) =>
       simp [m_eq, lt_irrefl]
       match lt_trichotomy d₁.day d₂.day with
       | .inl d_lt => simp [d_lt]; exact le_of_lt d_lt
       | .inr (.inr d_gt) => simp [not_lt_of_gt d_gt, ne_of_gt d_gt]; assumption
       | .inr (.inl d_eq) => simp [d_eq, lt_irrefl d₂.day]

theorem Ymd.lt_def' (d₁ d₂ : Ymd) :
  (d₁ < d₂) =
  (d₁.year < d₂.year
   ∨ (d₁.year = d₂.year ∧ d₁.month < d₂.month)
   ∨ (d₁.year = d₂.year ∧ d₁.month = d₂.month ∧ d₁.day < d₂.day)) := by
   simp [Ymd.lt_def, compare, compareOfLessAndEq]
   match lt_trichotomy d₁.year d₂.year with
   | .inl y_lt => simp [y_lt]
   | .inr (.inr y_gt) => simp [not_lt_of_gt y_gt, ne_of_gt y_gt]
   | .inr (.inl y_eq) =>
     simp [y_eq, lt_irrefl]
     match lt_trichotomy d₁.month d₂.month with
     | .inl m_lt => simp [m_lt]
     | .inr (.inr m_gt) => simp [not_lt_of_gt m_gt, ne_of_gt m_gt]
     | .inr (.inl m_eq) =>
       simp [m_eq, lt_irrefl]
       match lt_trichotomy d₁.day d₂.day with
       | .inl d_lt => simp [d_lt]
       | .inr (.inr d_gt) => simp [not_lt_of_gt d_gt, ne_of_gt d_gt]
       | .inr (.inl d_eq) => simp [d_eq, lt_irrefl d₂.day]

instance : LinearOrder Ymd where
  le_refl (a) := by simp [Ymd.le_def']
  le_trans (a b c) := by
    simp only [Ymd.le_def']
    rintro (ay_lt_by | ⟨ay_eq_by, am_lt_bm⟩ | ⟨ay_eq_by, am_eq_bm, ad_le_bd⟩)
    <;> rintro (by_lt_cy | ⟨by_eq_cy, bm_lt_cm⟩ | ⟨by_eq_cy, bm_eq_cm, bd_le_cd⟩)
    . exact .inl $ lt_trans ay_lt_by by_lt_cy
    . exact .inl $ by_eq_cy ▸ ay_lt_by
    . exact .inl $ by_eq_cy ▸ ay_lt_by
    . exact .inl $ ay_eq_by ▸ by_lt_cy
    . exact .inr $ .inl ⟨ay_eq_by ▸ by_eq_cy, lt_trans am_lt_bm bm_lt_cm⟩
    . exact .inr $ .inl ⟨ay_eq_by ▸ by_eq_cy, bm_eq_cm ▸ am_lt_bm⟩
    . exact .inl $ ay_eq_by ▸ by_lt_cy
    . exact .inr $ .inl ⟨ay_eq_by ▸ by_eq_cy, am_eq_bm ▸ bm_lt_cm⟩
    . exact .inr $ .inr ⟨ay_eq_by ▸ by_eq_cy, ⟨am_eq_bm ▸ bm_eq_cm, le_trans ad_le_bd bd_le_cd⟩⟩
  lt_iff_le_not_le (a b) := by
    simp only [Ymd.le_def', Ymd.lt_def']
    refine Iff.intro ?mp ?mpr
    case mp =>
      rintro (y_lt | ⟨y_eq, m_lt⟩ | ⟨y_eq, m_eq, d_le⟩)
      case inl =>
        have hr : ¬(b.year < a.year ∨ b.year = a.year ∧ b.month < a.month ∨ b.year = a.year ∧ b.month = a.month ∧ b.day ≤ a.day) := by
          rintro (y_lt' | ⟨y_eq', m_lt'⟩ | ⟨y_eq', m_lt', d_le'⟩)
          . exact (not_lt_of_gt y_lt) y_lt'
          . exact (lt_irrefl a.year (y_eq' ▸ y_lt))
          . exact (lt_irrefl a.year (y_eq' ▸ y_lt))
        exact ⟨Or.inl y_lt, hr⟩
      case inr.inl.intro =>
        have hr : ¬(b.year < a.year ∨ b.year = a.year ∧ b.month < a.month ∨ b.year = a.year ∧ b.month = a.month ∧ b.day ≤ a.day) := by
          rintro (y_lt' | ⟨y_eq', m_le⟩ | ⟨y_eq', m_eq', d_le'⟩)
          . exact (lt_irrefl a.year (y_eq ▸ y_lt'))
          . exact (not_lt_of_gt m_lt) m_le
          . exact (lt_irrefl a.month (m_eq' ▸ m_lt))
        exact ⟨.inr $ .inl ⟨y_eq, m_lt⟩, hr⟩
      case inr.inr.intro.intro =>
        have hr : ¬(b.year < a.year ∨ b.year = a.year ∧ b.month < a.month ∨ b.year = a.year ∧ b.month = a.month ∧ b.day ≤ a.day) := by
          rintro (y_lt' | ⟨y_eq', m_lt⟩ | ⟨y_eq', m_eq, d_le'⟩)
          . exact (lt_irrefl a.year (y_eq ▸ y_lt'))
          . exact (lt_irrefl a.month (m_eq ▸ m_lt))
          . exact (not_le_of_gt d_le d_le')
        exact ⟨.inr $ .inr ⟨y_eq, ⟨m_eq, le_of_lt d_le⟩⟩, hr⟩
    case mpr =>
      rintro (y_lt | ⟨y_eq, m_lt⟩ | ⟨y_eq, m_eq, d_le⟩)
      case intro.inl => exact .inl y_lt
      case intro.inr.inl.intro => exact .inr $ .inl ⟨y_eq, m_lt⟩
      case intro.inr.inr.intro.intro hnot =>
        match lt_or_eq_of_le d_le with
        | .inl d_lt => exact Or.inr $ .inr ⟨y_eq, ⟨m_eq, d_lt⟩⟩
        | .inr d_eq => exact False.elim $ hnot $ .inr $ .inr ⟨y_eq.symm, ⟨m_eq.symm, (le_of_eq d_eq.symm)⟩⟩
  le_antisymm (a b) := by
    simp [Ymd.le_def']
    rintro (ay_lt_by | ⟨ay_eq_by, am_lt_bm⟩ | ⟨ay_eq_by, am_eq_bm, ad_le_bd⟩)
    <;> rintro (by_lt_ay | ⟨by_eq_ay, bm_lt_am⟩ | ⟨by_eq_ay, bm_eq_am, bd_le_ad⟩)
    . exact absurd ay_lt_by (not_lt_of_gt by_lt_ay)
    . rw [by_eq_ay] at ay_lt_by; exact absurd (ay_lt_by) (lt_irrefl _)
    . rw [by_eq_ay] at ay_lt_by; exact absurd (ay_lt_by) (lt_irrefl _)
    . rw [ay_eq_by] at by_lt_ay; exact absurd (by_lt_ay) (lt_irrefl _)
    . exact absurd am_lt_bm (not_lt_of_gt bm_lt_am)
    . rw [bm_eq_am] at am_lt_bm; exact absurd (am_lt_bm) (lt_irrefl _)
    . rw [ay_eq_by] at by_lt_ay; exact absurd (by_lt_ay) (lt_irrefl _)
    . rw [am_eq_bm] at bm_lt_am; exact absurd (bm_lt_am) (lt_irrefl _)
    . exact Ymd.eq_of_val_eq ay_eq_by am_eq_bm (le_antisymm ad_le_bd bd_le_ad)
  le_total (a b) := by
    simp [Ymd.le_def']
    match lt_trichotomy a.year b.year with
    | .inl y_lt => simp [y_lt]
    | .inr (.inr y_gt) => simp [y_gt]
    | .inr (.inl y_eq) =>
      simp [y_eq, lt_irrefl]
      match lt_trichotomy a.month b.month with
      | .inl m_lt => simp [m_lt]
      | .inr (.inr m_gt) => simp [m_gt]
      | .inr (.inl m_eq) =>
        simp [m_eq, lt_irrefl]
        match lt_trichotomy a.day b.day with
        | .inl d_lt => simp [le_of_lt d_lt]
        | .inr (.inr d_gt) => simp [le_of_lt d_gt]
        | .inr (.inl d_eq) => simp [d_eq]
  decidable_le := inferInstance

theorem Ymd.numDays_pos (ymd : Ymd) : 0 < ymd.month.numDays ymd.year := by
  simp only [Month.numDays]
  by_cases hy : ymd.year.isLeapYear <;> (split <;> simp [hy, if_true, if_false])

theorem Ymd.numDays_lt_numDaysInGregorianYear (ymd : Ymd) : ymd.month.numDays ymd.year < ymd.year.numDaysInGregorianYear := by
  simp only [Month.numDays, Year.numDaysInGregorianYear]
  by_cases hy : ymd.year.isLeapYear <;> (split <;> simp [hy, if_true, if_false])

theorem Ymd.numDays_lt_31 (ymd : Ymd) : ymd.month.numDays ymd.year <= 31 := by
  simp only [Month.numDays, Year.numDaysInGregorianYear]
  by_cases hy : ymd.year.isLeapYear <;> (split <;> simp [hy, if_true, if_false])


import data.set.basic
import tactic.lift

/-! Some tests of the `lift` tactic. -/
example (n m k x z u : ℤ) (hn : 0 < n) (hk : 0 ≤ k + n) (hu : 0 ≤ u)
  (h : k + n = 2 + x) (f : false) :
  k + n = m + x :=
begin
  lift n to ℕ using le_of_lt hn,
    guard_target (k + ↑n = m + x), guard_hyp hn : (0 : ℤ) < ↑n,
  lift m to ℕ,
    guard_target (0 ≤ m), tactic.swap, guard_target (k + ↑n = ↑m + x),
    tactic.num_goals >>= λ n, guard (n = 2),
  lift (k + n) to ℕ using hk with l hl,
    guard_hyp l : ℕ, guard_hyp hl : ↑l = k + ↑n, guard_target (↑l = ↑m + x),
    tactic.success_if_fail (tactic.get_local `hk),
  lift x to ℕ with y hy,
    tactic.swap, guard_hyp y : ℕ, guard_hyp hy : ↑y = x, guard_target (↑l = ↑m + x), tactic.swap,
  lift z to ℕ with w,
    tactic.swap, guard_hyp w : ℕ, tactic.success_if_fail (tactic.get_local `z), tactic.swap,
  lift u to ℕ using hu with u rfl hu,
    guard_hyp hu : (0 : ℤ) ≤ ↑u,

  all_goals { exfalso, assumption },
end

-- test lift of functions
example (α : Type*) (f : α → ℤ) (hf : ∀ a, 0 ≤ f a) (hf' : ∀ a, f a < 1) (a : α) : 0 ≤ 2 * f a :=
begin
  lift f to α → ℕ using hf,
    guard_target ((0:ℤ) ≤ 2 * (λ i : α, (f i : ℤ)) a),
    guard_hyp hf' : ∀ a, ((λ i : α, (f i:ℤ)) a) < 1,
  constructor,
end

-- fail gracefully when the lifted variable is a local definition
example : let n : ℤ := 3 in n = n :=
begin
  intro n,
  success_if_fail_with_msg { lift n to ℕ }
    ("Cannot substitute variable n, it is a local definition. " ++
    "If you really want to do this, use `clear_value` first."),
  refl
end

instance can_lift_unit : can_lift unit unit id (λ _, true) := ⟨λ x _, ⟨x, rfl⟩⟩

/- test error messages -/
example (n : ℤ) (hn : 0 < n) : true :=
begin
  success_if_fail_with_msg {lift n to ℕ using hn} ("lift tactic failed.\n" ++
    "invalid type ascription, term has type\n  0 < n\nbut is expected to have type\n  0 ≤ n"),
  success_if_fail_with_msg {lift (n : option ℤ) to ℕ}
    ("Failed to find a lift from option ℤ to ℕ. " ++
    "Provide an instance of\n  can_lift (option ℤ) ℕ ?m_1 ?m_2"),
  trivial
end

example (n : ℤ) : ℕ :=
begin
  success_if_fail_with_msg {lift n to ℕ}
    "lift tactic failed. Tactic is only applicable when the target is a proposition.",
  exact 0
end

instance can_lift_set (R : Type*) (s : set R) : can_lift R s coe (λ x, x ∈ s) :=
{ prf := λ x hx, ⟨⟨x, hx⟩, rfl⟩ }

example {R : Type*} {P : R → Prop} (x : R) (hx : P x) : true :=
by { lift x to {x // P x} using hx with y, trivial }

/-! Test that `lift` elaborates `s` as a type, not as a set. -/
example {R : Type*} {s : set R} (x : R) (hx : x ∈ s) : true :=
by { lift x to s using hx with y, trivial }

example (n : ℤ) (hn : 0 ≤ n) : true :=
by { lift n to ℕ, exact hn, trivial }

example (n : ℤ) (hn : 0 ≤ n) : true :=
by { lift n to ℕ using hn, trivial }

example (n : ℤ) (hn : n ≥ 0) : true :=
by { lift n to ℕ using ge.le _, trivial, guard_target (n ≥ 0), exact hn }

example (n : ℤ) (hn : 0 ≤ 1 * n) : true :=
begin
  lift n to ℕ using by { simpa [int.one_mul] using hn } with k,
  -- the above braces are optional, but it would be bad style to remove them (see next example)
  guard_hyp hn : 0 ≤ 1 * ((k : ℕ) : ℤ),
  trivial
end

example (n : ℤ) (hn : 0 ≤ n ↔ true) : true :=
begin
  lift n to ℕ using by { simp [hn] } with k, -- the braces are not optional here
  trivial
end


/- Author: E.W.Ayers © 2019 -/
import ..equate
namespace rats
open robot

/- Example within the context of defining the rationals as ordered pairs of integers
quotiented by the relation (⟨a,b⟩ ~ ⟨c,d⟩) ↔ (a * d = c * b).
 -/

meta def blast : tactic unit :=
tactic.timetac "blast" $ (using_smt_with {cc_cfg := {ac:=ff}} $ tactic.intros >> smt_tactic.iterate (smt_tactic.ematch >> smt_tactic.try smt_tactic.close))
attribute [ematch] mul_comm mul_assoc

universes u
structure q (α : Type u) [integral_domain α] := (n : α) (d : α ) (nz : d ≠ 0)
lemma q.ext {α : Type u} [integral_domain α] : Π (q1 q2 : q α), q1.n = q2.n → q1.d = q2.d → q1 = q2
|⟨n,d,nz⟩ ⟨_,_,_⟩ rfl rfl := rfl

instance (α : Type u) [integral_domain α] : setoid (q α) :=
{ r := (λ a b, a.1 * b.2 = b.1 * a.2)
, iseqv :=
  ⟨ λ a, rfl
  , λ a b, eq.symm
  , λ ⟨a,b,_⟩ ⟨c,d,h⟩ ⟨e,f,_⟩
     (p : a * d = c * b)
     (q : c * f = e * d),
    suffices d * (a * f) = d * (e * b), from eq_of_mul_eq_mul_left h this,
    -- by blast -- takes about 2 seconds
    by equate -- also about 2 seconds, but much slower because implemented in Lean VM
  ⟩
}
def free (α : Type u) [integral_domain α] : Type* := @quotient (q α) (by apply_instance)
variables {α : Type u} [integral_domain α]

-- [TODO]
-- namespace free
-- def add : free α → free α → free α
-- := λ x y, quotient.lift_on₂ x y
--   (λ x y, ⟦(⟨x.1 * y.2 + y.1 * x.2, x.2 * y.2, mul_ne_zero x.nz y.nz⟩ : q α)⟧)
--   (λ a1 a2 b1 b2,
--       assume p : a1.n * b1.d = b1.1 * a1.2,
--       assume q : a2.1 * b2.2 = b2.1 * a2.2,
--       suffices (a1.1 * a2.2 + a2.1 * a1.2) * (b1.2 * b2.2)
--                 = (b1.1 * b2.2 + b2.1 * b1.2) * (a1.2 * a2.2),
--         from quotient.sound this,
--         calc ((a1.1 * a2.2) + (a2.1 * a1.2)) * (b1.2 * b2.2)
--               = ((b1.1 * a1.2) * (a2.2 * b2.2) + (b1.2 * a1.2) * (b2.1 * a2.2))
--                 : by equate
--          ...  = (b1.1 * b2.2 + b2.1 * b1.2) * (a1.2 * a2.2)
--                 : by symmetry; clear p q; equate
--   )
-- end free

end rats


import topology.basic
import topology.compact_open
import data.nat.prime
import data.real.basic
import data.real.irrational
import data.complex.basic
import data.fin.basic
import geometry.euclidean.basic
import analysis.inner_product_space.pi_L2
import algebra.group.defs
import algebra.field.basic
import combinatorics.configuration
import ring_theory.polynomial.basic
import group_theory.free_group
import combinatorics.simple_graph.basic
import ring_theory.integral_closure
import data.fintype.card
import category_theory.category.basic
import ring_theory.discrete_valuation_ring
import group_theory.torsion
import linear_algebra.matrix.charpoly.basic
import algebra.order.absolute_value
import analysis.convex.basic
import topology.uniform_space.uniform_convergence_topology
import topology.sequences
import analysis.normed.group.infinite_sum
import data.nat.choose.sum
import group_theory.specific_groups.cyclic
import group_theory.order_of_element
import analysis.mean_inequalities
import analysis.normed_space.banach
import topology.algebra.continuous_monoid_hom
import linear_algebra.matrix.symmetric
import analysis.inner_product_space.spectrum
import ring_theory.class_group
import ring_theory.dedekind_domain.basic
import ring_theory.principal_ideal_domain
import model_theory.satisfiability
import probability.integration
import ring_theory.simple_module
import category_theory.preadditive.schur
import representation_theory.maschke
import topology.paracompact
import combinatorics.simple_graph.coloring
--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib

--OUTPUT 1
theorem fin_ab_hom_eq_dual_hom {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H] [group_hom f : G →* H] [group_hom g : G →* H]
  (h : ∀ x, f x = g x) :
  ∀ x, (finsupp.single x : G →ₗ[ℤ] ℤ) ∘ f = (finsupp.single x : G →ₗ[ℤ] ℤ) ∘ g :=
begin
  intro x,
  have h1 : f x = g x,
    from h x,
  have h2 : (finsupp.single x : G →ₗ[ℤ] ℤ) ∘ f = (finsupp.single x : G →ₗ[ℤ] ℤ) ∘ g,
    from congr_fun h1 _,
  exact h2,

--OUTPUT 2
theorem abelian_hom_isomorphism {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp G H).to_fun ≫ (finsupp.map f).to_fun = f := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp.map f).to_fun ≫ (finsupp G H).to_fun = f := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp.map f).to_fun ≫ (finsupp.map f).to_fun = finsupp.map f := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp G H).to_fun ≫ (finsupp G H).to_fun = finsupp G H := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun = finsupp G H := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun = finsupp.map f := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun = finsupp.map f := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun = finsupp G H := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun = finsupp G H := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun = finsupp.map f := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun = finsupp.map f := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv_inv_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_fun = finsupp G H := sorry

--Prove that Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals in Lean mathlib
theorem abelian_hom_isomorphism_inv_inv_inv_inv_inv_inv_inv_inv_inv_inv_inv_inv {G H : Type*} [fintype G] [fintype H] [add_comm_group G] [add_comm_group H]
(f : G → H) [is_group_hom f] : (finsupp G H).to_fun ≫ (finsupp.map f).to_fun ≫ (finsupp G H).to_

--OUTPUT 3
theorem is_isomorphic_to_hom_of_dual (G : Type) [add_comm_group G] [module ℤ G] [fintype G] [decidable_eq G] [fintype (dual G)] [decidable_eq (dual G)] (H : Type) [add_comm_group H] [module ℤ H] [fintype H] [decidable_eq H] [fintype (dual H)] [decidable_eq (dual H)] (f : G → H) (hf : is_homomorphism f) : (dual G → dual H) ≃ (G → H) :=
begin
  haveI := classical.dec_eq G,
  haveI := classical.dec_eq H,
  haveI := classical.dec_eq (dual G),
  haveI := classical.dec_eq (dual H),
  haveI := classical.dec_eq (G → H),
  haveI := classical.dec_eq (dual G → dual H),
  let g : (dual G → dual H) → (G → H) := λ f, f ∘ dual.val,
  let h : (G → H) → (dual G → dual H) := λ f, dual.map ∘ f,
  have hg : h ∘ g = id,
  {
    ext,
    rw [h, g, dual.map_val, id_comp],
  },
  have gh : g ∘ h = id,
  {
    ext,
    rw [h, g, dual.map_val, id_comp],
  },
  exact equiv.mk g h hg gh,

github-repos/lean/ayush1801-Autoformalisation_benchmarks/Autoformalisation_benchmarks-51e1e942a0314a46684f2521b95b6b091c536051/proof/Zero-shot-theorem-names/Zero-Shot-prompts_temperature_0.4_max_tokens_2000_n_3/clean_files/Homomorphisms between two finite abelian groups are isomorphic to homomorphisms between their duals.lean


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import algebra.group.hom
import category_theory.limits.shapes.kernels
import algebra.big_operators.basic
import category_theory.endomorphism

/-!
# Preadditive categories

A preadditive category is a category in which `X ⟶ Y` is an abelian group in such a way that
composition of morphisms is linear in both variables.

This file contains a definition of preadditive category that directly encodes the definition given
above. The definition could also be phrased as follows: A preadditive category is a category
enriched over the category of Abelian groups. Once the general framework to state this in Lean is
available, the contents of this file should become obsolete.

## Main results

* Definition of preadditive categories and basic properties
* In a preadditive category, `f : Q ⟶ R` is mono if and only if `g ≫ f = 0 → g = 0` for all
  composable `g`.
* A preadditive category with kernels has equalizers.

## Implementation notes

The simp normal form for negation and composition is to push negations as far as possible to
the outside. For example, `f ≫ (-g)` and `(-f) ≫ g` both become `-(f ≫ g)`, and `(-f) ≫ (-g)`
is simplified to `f ≫ g`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

## Tags

additive, preadditive, Hom group, Ab-category, Ab-enriched
-/

universes v u

open category_theory.limits
open add_monoid_hom

namespace category_theory

variables (C : Type u) [category.{v} C]

/-- A category is called preadditive if `P ⟶ Q` is an abelian group such that composition is
    linear in both variables. -/
class preadditive :=
(hom_group : Π P Q : C, add_comm_group (P ⟶ Q) . tactic.apply_instance)
(add_comp' : ∀ (P Q R : C) (f f' : P ⟶ Q) (g : Q ⟶ R),
  (f + f') ≫ g = f ≫ g + f' ≫ g . obviously)
(comp_add' : ∀ (P Q R : C) (f : P ⟶ Q) (g g' : Q ⟶ R),
  f ≫ (g + g') = f ≫ g + f ≫ g' . obviously)

attribute [instance] preadditive.hom_group
restate_axiom preadditive.add_comp'
restate_axiom preadditive.comp_add'
attribute [simp,reassoc] preadditive.add_comp
attribute [reassoc] preadditive.comp_add -- (the linter doesn't like `simp` on this lemma)
attribute [simp] preadditive.comp_add

end category_theory

open category_theory

namespace category_theory.preadditive

section preadditive
variables {C : Type u} [category.{v} C] [preadditive C]

section induced_category
universes u'
variables {C} {D : Type u'} (F : D → C)

instance induced_category.category : preadditive.{v} (induced_category C F) :=
{ hom_group := λ P Q, @preadditive.hom_group C _ _ (F P) (F Q),
  add_comp' := λ P Q R f f' g, add_comp' _ _ _ _ _ _,
  comp_add' := λ P Q R f g g', comp_add' _ _ _ _ _ _, }

end induced_category

instance (X : C) : add_comm_group (End X) := by { dsimp [End], apply_instance, }

instance (X : C) : ring (End X) :=
{ left_distrib := λ f g h, preadditive.add_comp X X X g h f,
  right_distrib := λ f g h, preadditive.comp_add X X X h f g,
  ..(infer_instance : add_comm_group (End X)),
  ..(infer_instance : monoid (End X)) }

/-- Composition by a fixed left argument as a group homomorphism -/
def left_comp {P Q : C} (R : C) (f : P ⟶ Q) : (Q ⟶ R) →+ (P ⟶ R) :=
mk' (λ g, f ≫ g) $ λ g g', by simp

/-- Composition by a fixed right argument as a group homomorphism -/
def right_comp (P : C) {Q R : C} (g : Q ⟶ R) : (P ⟶ Q) →+ (P ⟶ R) :=
mk' (λ f, f ≫ g) $ λ f f', by simp

@[simp, reassoc] lemma sub_comp {P Q R : C} (f f' : P ⟶ Q) (g : Q ⟶ R) :
  (f - f') ≫ g = f ≫ g - f' ≫ g :=
map_sub (right_comp P g) f f'

-- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma.
@[reassoc, simp] lemma comp_sub {P Q R : C} (f : P ⟶ Q) (g g' : Q ⟶ R) :
  f ≫ (g - g') = f ≫ g - f ≫ g' :=
map_sub (left_comp R f) g g'

@[simp, reassoc] lemma neg_comp {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ g = -(f ≫ g) :=
map_neg (right_comp _ _) _

/- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma. -/
@[reassoc, simp] lemma comp_neg {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : f ≫ (-g) = -(f ≫ g) :=
map_neg (left_comp _ _) _

@[reassoc] lemma neg_comp_neg {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ (-g) = f ≫ g :=
by simp

section big_operators

open_locale big_operators

@[reassoc] lemma comp_sum {P Q R : C} {J : Type*} {s : finset J} (f : P ⟶ Q) (g : J → (Q ⟶ R)) :
  f ≫ ∑ j in s, g j = ∑ j in s, f ≫ g j :=
begin
  change left_comp R f _ = _,
  rw [add_monoid_hom.map_sum],
  refl,
end

@[reassoc] lemma sum_comp {P Q R : C} {J : Type*} {s : finset J} (f : J → (P ⟶ Q)) (g : Q ⟶ R) :
  (∑ j in s, f j) ≫ g  = ∑ j in s, f j ≫ g :=
begin
  change right_comp P g _ = _,
  rw [add_monoid_hom.map_sum],
  refl,
end

end big_operators

instance {P Q : C} {f : P ⟶ Q} [epi f] : epi (-f) :=
⟨λ R g g' H, by rwa [neg_comp, neg_comp, ←comp_neg, ←comp_neg, cancel_epi, neg_inj] at H⟩

instance {P Q : C} {f : P ⟶ Q} [mono f] : mono (-f) :=
⟨λ R g g' H, by rwa [comp_neg, comp_neg, ←neg_comp, ←neg_comp, cancel_mono, neg_inj] at H⟩

@[priority 100]
instance preadditive_has_zero_morphisms : has_zero_morphisms C :=
{ has_zero := infer_instance,
  comp_zero' := λ P Q f R, map_zero $ left_comp R f,
  zero_comp' := λ P Q R f, map_zero $ right_comp P f }

lemma mono_of_cancel_zero {Q R : C} (f : Q ⟶ R) (h : ∀ {P : C} (g : P ⟶ Q), g ≫ f = 0 → g = 0) :
  mono f :=
⟨λ P g g' hg, sub_eq_zero.1 $ h _ $ (map_sub (right_comp P f) g g').trans $ sub_eq_zero.2 hg⟩

lemma mono_iff_cancel_zero {Q R : C} (f : Q ⟶ R) :
  mono f ↔ ∀ (P : C) (g : P ⟶ Q), g ≫ f = 0 → g = 0 :=
⟨λ m P g, by exactI zero_of_comp_mono _, mono_of_cancel_zero f⟩

lemma mono_of_kernel_zero {X Y : C} {f : X ⟶ Y} [has_limit (parallel_pair f 0)]
  (w : kernel.ι f = 0) : mono f :=
mono_of_cancel_zero f (λ P g h, by rw [←kernel.lift_ι f g h, w, limits.comp_zero])

lemma epi_of_cancel_zero {P Q : C} (f : P ⟶ Q) (h : ∀ {R : C} (g : Q ⟶ R), f ≫ g = 0 → g = 0) :
  epi f :=
⟨λ R g g' hg, sub_eq_zero.1 $ h _ $ (map_sub (left_comp R f) g g').trans $ sub_eq_zero.2 hg⟩

lemma epi_iff_cancel_zero {P Q : C} (f : P ⟶ Q) :
  epi f ↔ ∀ (R : C) (g : Q ⟶ R), f ≫ g = 0 → g = 0 :=
⟨λ e R g, by exactI zero_of_epi_comp _, epi_of_cancel_zero f⟩

lemma epi_of_cokernel_zero {X Y : C} (f : X ⟶ Y) [has_colimit (parallel_pair f 0 )]
  (w : cokernel.π f = 0) : epi f :=
epi_of_cancel_zero f (λ P g h, by rw [←cokernel.π_desc f g h, w, limits.zero_comp])

end preadditive

section equalizers
variables {C : Type u} [category.{v} C] [preadditive C]

section
variables {X Y : C} (f : X ⟶ Y) (g : X ⟶ Y)

/-- A kernel of `f - g` is an equalizer of `f` and `g`. -/
lemma has_limit_parallel_pair [has_kernel (f - g)] :
  has_limit (parallel_pair f g) :=
has_limit.mk { cone := fork.of_ι (kernel.ι (f - g)) (sub_eq_zero.1 $
    by { rw ←comp_sub, exact kernel.condition _ }),
  is_limit := fork.is_limit.mk _
    (λ s, kernel.lift (f - g) (fork.ι s) $
      by { rw comp_sub, apply sub_eq_zero.2, exact fork.condition _ })
    (λ s, by simp)
    (λ s m h, by { ext, simpa using h walking_parallel_pair.zero }) }

end

section

/-- If a preadditive category has all kernels, then it also has all equalizers. -/
lemma has_equalizers_of_has_kernels [has_kernels C] : has_equalizers C :=
@has_equalizers_of_has_limit_parallel_pair _ _ (λ _ _ f g, has_limit_parallel_pair f g)

end

section
variables {X Y : C} (f : X ⟶ Y) (g : X ⟶ Y)

/-- A cokernel of `f - g` is a coequalizer of `f` and `g`. -/
lemma has_colimit_parallel_pair [has_cokernel (f - g)] :
  has_colimit (parallel_pair f g) :=
has_colimit.mk { cocone := cofork.of_π (cokernel.π (f - g)) (sub_eq_zero.1 $
    by { rw ←sub_comp, exact cokernel.condition _ }),
  is_colimit := cofork.is_colimit.mk _
    (λ s, cokernel.desc (f - g) (cofork.π s) $
      by { rw sub_comp, apply sub_eq_zero.2, exact cofork.condition _ })
    (λ s, by simp)
    (λ s m h, by { ext, simpa using h walking_parallel_pair.one }) }

end

section

/-- If a preadditive category has all cokernels, then it also has all coequalizers. -/
lemma has_coequalizers_of_has_cokernels [has_cokernels C] : has_coequalizers C :=
@has_coequalizers_of_has_colimit_parallel_pair _ _ (λ _ _ f g, has_colimit_parallel_pair f g)

end

end equalizers
end category_theory.preadditive


opaque f : Nat → Nat
opaque g : Nat → Nat

namespace Foo

@[scoped simp] axiom ax1 (x : Nat) : f (g x) = x
@[scoped simp] axiom ax2 (x : Nat) : g (g x) = g x

end Foo

theorem ex1 : f (g (g (g x))) = x := by
  simp -- does not use ax1 and ax2
  simp [Foo.ax1, Foo.ax2]

theorem ex2 : f (g (g (g x))) = x :=
  have h₁ : f (g (g (g x))) = f (g x) := by simp; /- try again with `Foo` scoped lemmas -/ open Foo in simp
  have h₂ : f (g x) = x               := by simp; open Foo in simp
  Eq.trans h₁ h₂
  -- open Foo in simp -- works

theorem ex3 : f (g (g (g x))) = x := by
  simp
  simp [Foo.ax1, Foo.ax2]

open Foo in
theorem ex4 : f (g (g (g x))) = x := by
  simp

theorem ex5 : f (g (g (g x))) = x ∧ f (g x) = x := by
  apply And.intro
  { simp; open Foo in simp }
  { simp; open Foo in simp }


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.sites.canonical
import Mathlib.category_theory.sites.sheaf_of_types
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Grothendieck Topology and Sheaves on the Category of Types

In this file we define a Grothendieck topology on the category of types,
and construct the canonical functor that sends a type to a sheaf over
the category of types, and make this an equivalence of categories.

Then we prove that the topology defined is the canonical topology.
-/

namespace category_theory

/-- A Grothendieck topology associated to the category of all types.
A sieve is a covering iff it is jointly surjective. -/
def types_grothendieck_topology : grothendieck_topology (Type u) :=
  grothendieck_topology.mk (fun (α : Type u) (S : sieve α) => ∀ (x : α), coe_fn S PUnit fun (_x : PUnit) => x) sorry sorry
    sorry

/-- The discrete sieve on a type, which only includes arrows whose image is a subsingleton. -/
@[simp] theorem discrete_sieve_apply (α : Type u) (β : Type u) (f : β ⟶ α) : coe_fn (discrete_sieve α) β f = ∃ (x : α), ∀ (y : β), f y = x :=
  Eq.refl (coe_fn (discrete_sieve α) β f)

theorem discrete_sieve_mem (α : Type u) : discrete_sieve α ∈ coe_fn types_grothendieck_topology α :=
  fun (x : α) => Exists.intro x fun (y : PUnit) => rfl

/-- The discrete presieve on a type, which only includes arrows whose domain is a singleton. -/
def discrete_presieve (α : Type u) : presieve α :=
  fun (β : Type u) (f : β ⟶ α) => ∃ (x : β), ∀ (y : β), y = x

theorem generate_discrete_presieve_mem (α : Type u) : sieve.generate (discrete_presieve α) ∈ coe_fn types_grothendieck_topology α := sorry

theorem is_sheaf_yoneda' {α : Type u} : presieve.is_sheaf types_grothendieck_topology (functor.obj yoneda α) := sorry

/-- The yoneda functor that sends a type to a sheaf over the category of types -/
@[simp] theorem yoneda'_map (α : Type u) (β : Type u) (f : α ⟶ β) : functor.map yoneda' f = functor.map yoneda f :=
  Eq.refl (functor.map yoneda' f)

@[simp] theorem yoneda'_comp : yoneda' ⋙ induced_functor subtype.val = yoneda :=
  rfl

/-- Given a presheaf `P` on the category of types, construct
a map `P(α) → (α → P(*))` for all type `α`. -/
def eval (P : Type uᵒᵖ ⥤ Type u) (α : Type u) (s : functor.obj P (opposite.op α)) (x : α) : functor.obj P (opposite.op PUnit) :=
  functor.map P (has_hom.hom.op (↾fun (_x : PUnit) => x)) s

/-- Given a sheaf `S` on the category of types, construct a map
`(α → S(*)) → S(α)` that is inverse to `eval`. -/
def types_glue (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S) (α : Type u) (f : α → functor.obj S (opposite.op PUnit)) : functor.obj S (opposite.op α) :=
  presieve.is_sheaf_for.amalgamate sorry
    (fun (β : Type u) (g : β ⟶ α) (hg : discrete_presieve α g) =>
      functor.map S (has_hom.hom.op (↾fun (x : β) => PUnit.unit)) (f (g (classical.some hg))))
    sorry

theorem eval_types_glue {S : Type uᵒᵖ ⥤ Type u} {hs : presieve.is_sheaf types_grothendieck_topology S} {α : Type u} (f : α → functor.obj S (opposite.op PUnit)) : eval S α (types_glue S hs α f) = f := sorry

theorem types_glue_eval {S : Type uᵒᵖ ⥤ Type u} {hs : presieve.is_sheaf types_grothendieck_topology S} {α : Type u} (s : functor.obj S (opposite.op α)) : types_glue S hs α (eval S α s) = s := sorry

/-- Given a sheaf `S`, construct an equivalence `S(α) ≃ (α → S(*))`. -/
def eval_equiv (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S) (α : Type u) : functor.obj S (opposite.op α) ≃ (α → functor.obj S (opposite.op PUnit)) :=
  equiv.mk (eval S α) (types_glue S hs α) types_glue_eval eval_types_glue

theorem eval_map (S : Type uᵒᵖ ⥤ Type u) (α : Type u) (β : Type u) (f : β ⟶ α) (s : functor.obj S (opposite.op α)) (x : β) : eval S β (functor.map S (has_hom.hom.op f) s) x = eval S α s (f x) := sorry

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
def equiv_yoneda (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S) : S ≅ functor.obj yoneda (functor.obj S (opposite.op PUnit)) :=
  nat_iso.of_components (fun (α : Type uᵒᵖ) => equiv.to_iso (eval_equiv S hs (opposite.unop α))) sorry

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
@[simp] theorem equiv_yoneda'_inv (S : SheafOfTypes types_grothendieck_topology) : iso.inv (equiv_yoneda' S) = iso.inv (equiv_yoneda (subtype.val S) (equiv_yoneda'._proof_1 S)) :=
  Eq.refl (iso.inv (equiv_yoneda' S))

theorem eval_app (S₁ : SheafOfTypes types_grothendieck_topology) (S₂ : SheafOfTypes types_grothendieck_topology) (f : S₁ ⟶ S₂) (α : Type u) (s : functor.obj (subtype.val S₁) (opposite.op α)) (x : α) : eval (subtype.val S₂) α (nat_trans.app f (opposite.op α) s) x =
  nat_trans.app f (opposite.op PUnit) (eval (subtype.val S₁) α s x) :=
  Eq.symm (congr_fun (nat_trans.naturality' f (has_hom.hom.op (↾fun (_x : PUnit) => x))) s)

/-- `yoneda'` induces an equivalence of category between `Type u` and
`Sheaf types_grothendieck_topology`. -/
@[simp] theorem type_equiv_inverse_obj (X : SheafOfTypes types_grothendieck_topology) : functor.obj (equivalence.inverse type_equiv) X = functor.obj (↑X) (opposite.op PUnit) :=
  Eq.refl (functor.obj (↑X) (opposite.op PUnit))

theorem subcanonical_types_grothendieck_topology : sheaf.subcanonical types_grothendieck_topology :=
  sheaf.subcanonical.of_yoneda_is_sheaf types_grothendieck_topology fun (X : Type u) => is_sheaf_yoneda'

theorem types_grothendieck_topology_eq_canonical : types_grothendieck_topology = sheaf.canonical_topology (Type u) := sorry


import ground_zero.types.heq

/-
  Integers ℤ as a quotient of ℕ × ℕ.
  * HoTT 6.10, remark 6.10.7
-/

abbreviation builtin.int := int

namespace ground_zero.HITs

def int.rel : ℕ × ℕ → ℕ × ℕ → Prop
| ⟨a, b⟩ ⟨c, d⟩ := a + d = b + c

def int := quot int.rel
local notation ℤ := int

namespace nat.product
  def add (x y : ℕ × ℕ) : ℕ × ℕ := begin
    cases x with a b, cases y with c d,
    split, apply a + c, apply b + d
  end
  instance : has_add (ℕ × ℕ) := ⟨add⟩

  def mul (x y : ℕ × ℕ) : ℕ × ℕ := begin
    cases x with a b, cases y with c d,
    split, apply a * c + b * d,
    apply a * d + b * c
  end
  instance : has_mul (ℕ × ℕ) := ⟨mul⟩

  lemma add_comm (x y : ℕ × ℕ) : x + y = y + x := begin
    cases x with a b, cases y with c d,
    simp [has_add.add], simp [add]
  end

  lemma mul_comm (x y : ℕ × ℕ) : x * y = y * x := begin
    cases x with a b, cases y with c d,
    simp [has_mul.mul], simp [mul], split,
    { rw [nat.mul_comm c a], rw [nat.mul_comm d b] },
    { rw [nat.mul_comm c b], rw [nat.mul_comm d a],
      rw [nat.add_comm (b * c) (a * d)] }
  end

  lemma rw.add (a b : ℕ × ℕ) : nat.product.add a b = a + b :=
  by trivial

  lemma rw.mul (a b : ℕ × ℕ) : nat.product.mul a b = a * b :=
  by trivial
end nat.product

namespace int
  universes u v

  def mk : ℕ × ℕ → ℤ := quot.mk rel
  def elem (a b : ℕ) : ℤ := quot.mk rel ⟨a, b⟩

  def pos (n : ℕ) := mk ⟨n, 0⟩
  instance : has_coe ℕ ℤ := ⟨pos⟩

  def neg (n : ℕ) := mk ⟨0, n⟩

  instance : has_zero int := ⟨mk ⟨0, 0⟩⟩
  instance : has_one int := ⟨mk ⟨1, 0⟩⟩

  def knife {a b c d : ℕ} (H : a + d = b + c :> ℕ) :
    mk ⟨a, b⟩ = mk ⟨c, d⟩ :> ℤ :=
  ground_zero.support.inclusion $ @quot.sound _ int.rel
    ⟨a, b⟩ ⟨c, d⟩ (ground_zero.support.truncation H)

  def ind {π : ℤ → Sort u}
    (mk₁ : Π (x : ℕ × ℕ), π (mk x))
    (knife₁ : Π {a b c d : ℕ} (H : a + d = b + c :> ℕ),
      mk₁ ⟨a, b⟩ =[knife H] mk₁ ⟨c, d⟩) (x : ℤ) : π x := begin
    refine quot.hrec_on x _ _,
    exact mk₁, intros x y p,
    cases x with a b, cases y with c d,
    refine ground_zero.types.eq.rec _
      (ground_zero.types.equiv.subst_from_pathover
        (knife₁ (ground_zero.support.inclusion p))),
    apply ground_zero.types.heq.eq_subst_heq
  end

  def injs {β : Sort u} (pos₁ : ℕ → β) (zero₁ : β) (neg₁ : ℕ → β) :
    ℕ × ℕ → β
  | ⟨0, 0⟩ := zero₁
  | ⟨n, 0⟩ := pos₁ n
  | ⟨0, n⟩ := neg₁ n
  | ⟨n + 1, m + 1⟩ := if n > m
    then injs ⟨n + 1, m⟩
    else injs ⟨n, m + 1⟩

  def simplify : ℕ × ℕ → ℕ × ℕ
  | ⟨0, 0⟩ := ⟨0, 0⟩
  | ⟨n + 1, 0⟩ := ⟨n + 1, 0⟩
  | ⟨0, n + 1⟩ := ⟨0, n + 1⟩
  | ⟨n + 1, m + 1⟩ := if n > m then ⟨n - m, 0⟩ else ⟨0, m - n⟩

  lemma ite.left {c : Prop} [decidable c] {α : Sort u} {x y : α}
    (h : not c) : ite c x y = y := begin
    unfold ite, tactic.unfreeze_local_instances,
    cases _inst_1 with u v, trivial, contradiction
  end

  lemma ite.right {c : Prop} [decidable c] {α : Sort u} {x y : α}
    (h : c) : ite c x y = x := begin
    unfold ite, tactic.unfreeze_local_instances,
    cases _inst_1 with u v, contradiction, trivial
  end

  /- theorem simplify_correct (x : ℕ × ℕ) : mk x = mk (simplify x) := begin
    apply quot.sound, cases x with u v,
    induction u with u ih₁,
    { induction v with v ih,
      repeat { simp [simplify, rel] } },
    { induction v with v ih₂,
      { simp [simplify, rel] },
      { simp [simplify],
        have H := nat.decidable_le (v + 1) u, induction H;
        unfold gt; unfold has_lt.lt; unfold nat.lt;
        unfold has_le.le at H,
        { rw [ite.left H], unfold rel,
          admit },
        { rw [ite.right H], unfold rel,
          admit } } }
  end

  def blade {π : ℤ → Sort u}
    (pos₁ : Π (n : ℕ), π (elem n 0))
    (zero₁ : π 0)
    (neg₁ : Π (n : ℕ), π (elem 0 n)) :
    Π x, π x := begin
    fapply ind,
    { intro x, cases x with u v, rw [simplify_correct],
      admit },
    admit
  end -/

  instance : has_neg int :=
  ⟨quot.lift
    (λ (x : ℕ × ℕ), mk ⟨x.pr₂, x.pr₁⟩)
    (begin
      intros x y H, simp,
      cases x with a b,
      cases y with c d,
      simp, apply quot.sound,
      simp [rel], simp [rel] at H,
      symmetry, assumption
    end)⟩

  lemma nat_rw (a b : ℕ) : nat.add a b = a + b :=
  by trivial

  def lift₂ (f : ℕ × ℕ → ℕ × ℕ → ℕ × ℕ)
    (h₁ : Π (a b x : ℕ × ℕ) (H : rel a b),
      mk (f x a) = mk (f x b))
    (h₂ : Π (a b : ℕ × ℕ),
      mk (f a b) = mk (f b a))
    (x y : int) : int :=
  quot.lift
    (λ x, quot.lift
          (λ y, mk (f x y))
          (begin intros a b H, simp, apply h₁, assumption end) y)
    (begin
      intros a b H, simp,
      induction y, simp,
      rw [h₂ a y], rw [h₂ b y], apply h₁,
      assumption, trivial
    end) x

  lemma add_saves_int {a b c d : ℕ} (H : a + d = b + c)
    (y : ℕ × ℕ) :
    mk (⟨a, b⟩ + y) = mk (⟨c, d⟩ + y) := begin
    cases y with u v,
    simp [has_add.add],
    apply quot.sound, simp [nat.product.add], simp [rel],
    rw [←nat.add_assoc], rw [H],
    rw [nat.add_assoc]
  end

  def eq_map {α : Sort u} {β : Sort v} {a b : α}
    (f : α → β) (p : a = b) : f a = f b :=
  begin induction p, reflexivity end

  def add : int → int → int := begin
    apply lift₂ nat.product.add,
    { intros x y u H,
      cases x with a b, cases y with c d,
      repeat { rw [nat.product.rw.add] },
      rw [nat.product.add_comm u ⟨a, b⟩],
      rw [nat.product.add_comm u ⟨c, d⟩],
      apply add_saves_int, assumption },
    { intros x y,
      apply eq_map mk,
      apply nat.product.add_comm }
  end

  instance : has_add int := ⟨add⟩
  instance : has_sub int := ⟨λ a b, a + (-b)⟩

  theorem inv_append (a : ℤ) : a + (-a) = 0 := begin
    induction a, cases a with u v,
    simp [has_neg.neg], apply quot.sound,
    simp [nat.product.add], simp [rel],
  end

  theorem send_to_right {a b c : ℤ} : (a + b = c) → (a = c - b) := begin
    intro h, induction a, induction b, induction c,
    cases a with x y, cases b with u v, cases c with p q,
    simp [has_sub.sub, has_neg.neg],
    rw [←h], simp [mk],
    simp [has_add.add] at *, apply quot.sound,
    simp [nat.product.add], simp [rel],
    repeat { trivial }
  end

  def mul : ℤ → ℤ → ℤ := begin
    apply lift₂ nat.product.mul,
    { intros x y z H,
      cases x with a b, cases y with c d,
      cases z with u v, simp [nat.product.mul],
      apply quot.sound, simp [rel],
      rw [←nat.add_assoc (u * a)],
      rw [←nat.add_assoc (u * b)],

      rw [←nat.left_distrib u a d],
      rw [←nat.left_distrib v b c],

      rw [←nat.left_distrib u b c],
      rw [←nat.left_distrib v a d],

      simp [rel] at H, rw [H] },
    { intros x y,
      apply eq_map mk,
      apply nat.product.mul_comm }
  end
  instance : has_mul int := ⟨mul⟩

  theorem k_equiv (a b k : ℕ) : mk ⟨a, b⟩ = mk ⟨a + k, b + k⟩ :=
  begin apply quot.sound, simp [rel] end
end int

end ground_zero.HITs