/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Std.Lean.Parser
import Std.Lean.Meta.DiscrTree
import Mathlib.Algebra.Invertible
import Mathlib.Data.Rat.Cast
import Mathlib.Data.Nat.Basic
import Mathlib.Data.Int.Basic
import Mathlib.Tactic.Conv
import Qq.MetaM
import Qq.Delab

/-!
## `norm_num` core functionality

This file sets up the `norm_num` tactic and the `@[norm_num]` attribute,
which allow for plugging in new normalization functionality around a simp-based driver.
The actual behavior is in `@[norm_num]`-tagged definitions in `Tactic.NormNum.Basic`
and elsewhere.
-/
open Lean hiding Rat mkRat
open Lean.Meta Qq Lean.Elab Term

/-- Attribute for identifying `norm_num` extensions. -/
syntax (name := norm_num) "norm_num" term,+ : attr

namespace Mathlib
namespace Meta.NormNum

initialize registerTraceClass `Tactic.norm_num

/-- Assert that an element of a semiring is equal to the coercion of some natural number. -/
structure IsNat [AddMonoidWithOne α] (a : α) (n : ℕ) : Prop where
  /-- The element is equal to the coercion of the natural number. -/
  out : a = n

theorem IsNat.raw_refl (n : ℕ) : IsNat n n := ⟨rfl⟩

/--
A "raw nat cast" is an expression of the form `(Nat.rawCast lit : α)` where `lit` is a raw
natural number literal. These expressions are used by tactics like `ring` to decrease the number
of typeclass arguments required in each use of a number literal at type `α`.
-/
@[simp] def _root_.Nat.rawCast [AddMonoidWithOne α] (n : ℕ) : α := n

theorem IsNat.to_eq [AddMonoidWithOne α] {n} : {a a' : α} → IsNat a n → n = a' → a = a'
  | _, _, ⟨rfl⟩, rfl => rfl

theorem IsNat.to_raw_eq [AddMonoidWithOne α] : IsNat (a : α) n → a = n.rawCast
  | ⟨e⟩ => e

theorem IsNat.of_raw (α) [AddMonoidWithOne α] (n : ℕ) : IsNat (n.rawCast : α) n := ⟨rfl⟩

/-- Assert that an element of a ring is equal to the coercion of some integer. -/
structure IsInt [Ring α] (a : α) (n : ℤ) : Prop where
  /-- The element is equal to the coercion of the integer. -/
  out : a = n

/--
A "raw int cast" is an expression of the form:

* `(Nat.rawCast lit : α)` where `lit` is a raw natural number literal
* `(Int.rawCast (Int.negOfNat lit) : α)` where `lit` is a nonzero raw natural number literal

(That is, we only actually use this function for negative integers.) This representation is used by
tactics like `ring` to decrease the number of typeclass arguments required in each use of a number
literal at type `α`.
-/
@[simp] def _root_.Int.rawCast [Ring α] (n : ℤ) : α := n

theorem IsInt.to_isNat {α} [Ring α] : ∀ {a : α} {n}, IsInt a (.ofNat n) → IsNat a n
  | _, _, ⟨rfl⟩ => ⟨by simp⟩

theorem IsInt.to_raw_eq [Ring α] : IsInt (a : α) n → a = n.rawCast
  | ⟨e⟩ => e

theorem IsInt.of_raw (α) [Ring α] (n : ℤ) : IsInt (n.rawCast : α) n := ⟨rfl⟩

theorem IsInt.neg_to_eq {α} [Ring α] {n} :
    {a a' : α} → IsInt a (.negOfNat n) → n = a' → a = -a'
  | _, _, ⟨rfl⟩, rfl => by simp [Int.negOfNat_eq, Int.cast_neg]

theorem IsInt.nonneg_to_eq {α} [Ring α] {n}
    {a a' : α} (h : IsInt a (.ofNat n)) (e : n = a') : a = a' := h.to_isNat.to_eq e

/-- Represent an integer as a typed expression. -/
def mkRawIntLit (n : ℤ) : Q(ℤ) :=
  let lit : Q(ℕ) := mkRawNatLit n.natAbs
  if 0 ≤ n then q(.ofNat $lit) else q(.negOfNat $lit)

/-- A shortcut (non)instance for `AddMonoidWithOne ℕ` to shrink generated proofs. -/
def instAddMonoidWithOneNat : AddMonoidWithOne ℕ := inferInstance

/-- A shortcut (non)instance for `Ring ℤ` to shrink generated proofs. -/
def instRingInt : Ring ℤ := inferInstance

/--
Assert that an element of a ring is equal to `num / denom`
(and `denom` is invertible so that this makes sense).
We will usually also have `num` and `denom` coprime,
although this is not part of the definition.
-/
inductive IsRat [Ring α] (a : α) (num : ℤ) (denom : ℕ) : Prop
  | mk (inv : Invertible (denom : α)) (eq : a = num * ⅟(denom : α))

/--
A "raw rat cast" is an expression of the form:

* `(Nat.rawCast lit : α)` where `lit` is a raw natural number literal
* `(Int.rawCast (Int.negOfNat lit) : α)` where `lit` is a nonzero raw natural number literal
* `(Rat.rawCast n d : α)` where `n` is a raw int cast, `d` is a raw nat cast, and `d` is not 1 or 0.

This representation is used by tactics like `ring` to decrease the number of typeclass arguments
required in each use of a number literal at type `α`.
-/
@[simp]
def _root_.Rat.rawCast [DivisionRing α] (n : ℤ) (d : ℕ) : α := n / d

theorem IsRat.to_isNat {α} [Ring α] : ∀ {a : α} {n}, IsRat a (.ofNat n) (nat_lit 1) → IsNat a n
  | _, _, ⟨inv, rfl⟩ => have := @invertibleOne α _; ⟨by simp⟩

theorem IsNat.to_isRat {α} [Ring α] : ∀ {a : α} {n}, IsNat a n → IsRat a (.ofNat n) (nat_lit 1)
  | _, _, ⟨rfl⟩ => ⟨⟨1, by simp, by simp⟩, by simp⟩

theorem IsRat.to_isInt {α} [Ring α] : ∀ {a : α} {n}, IsRat a n (nat_lit 1) → IsInt a n
  | _, _, ⟨inv, rfl⟩ => have := @invertibleOne α _; ⟨by simp⟩

theorem IsInt.to_isRat {α} [Ring α] : ∀ {a : α} {n}, IsInt a n → IsRat a n (nat_lit 1)
  | _, _, ⟨rfl⟩ => ⟨⟨1, by simp, by simp⟩, by simp⟩

theorem IsRat.to_raw_eq [DivisionRing α] : ∀ {a}, IsRat (a : α) n d → a = Rat.rawCast n d
  | _, ⟨inv, rfl⟩ => by simp [div_eq_mul_inv]

theorem IsRat.neg_to_eq {α} [DivisionRing α] {n d} :
    {a n' d' : α} → IsRat a (.negOfNat n) d → n = n' → d = d' → a = -(n' / d')
  | _, _, _, ⟨_, rfl⟩, rfl, rfl => by simp [div_eq_mul_inv]

theorem IsRat.nonneg_to_eq {α} [DivisionRing α] {n d} :
    {a n' d' : α} → IsRat a (.ofNat n) d → n = n' → d = d' → a = n' / d'
  | _, _, _, ⟨_, rfl⟩, rfl, rfl => by simp [div_eq_mul_inv]

theorem IsRat.of_raw (α) [DivisionRing α] (n : ℤ) (d : ℕ)
    (h : (d : α) ≠ 0) : IsRat (Rat.rawCast n d : α) n d :=
  have := invertibleOfNonzero h
  ⟨this, by simp [div_eq_mul_inv]⟩

theorem IsRat.den_nz {α} [DivisionRing α] {a n d} : IsRat (a : α) n d → (d : α) ≠ 0
  | ⟨_, _⟩ => nonzero_of_invertible (d : α)

/-- Represent an integer as a typed expression. -/
def mkRawRatLit (q : ℚ) : Q(ℚ) :=
  let nlit : Q(ℤ) := mkRawIntLit q.num
  let dlit : Q(ℕ) := mkRawNatLit q.den
  q(mkRat $nlit $dlit)

/-- A shortcut (non)instance for `Ring ℚ` to shrink generated proofs. -/
def instRingRat : Ring ℚ := inferInstance

/-- A shortcut (non)instance for `DivisionRing ℚ` to shrink generated proofs. -/
def instDivisionRingRat : DivisionRing ℚ := inferInstance

/-- The result of `norm_num` running on an expression `x` of type `α`.
Untyped version of `Result`. -/
inductive Result' where
  /-- Untyped version of `Result.isBool`. -/
  | isBool (val : Bool) (proof : Expr)
  /-- Untyped version of `Result.isNat`. -/
  | isNat (inst lit proof : Expr)
  /-- Untyped version of `Result.isNegNat`. -/
  | isNegNat (inst lit proof : Expr)
  /-- Untyped version of `Result.isRat`. -/
  | isRat (inst : Expr) (q : Rat) (n d proof : Expr)
  deriving Inhabited

section
set_option linter.unusedVariables false

/-- The result of `norm_num` running on an expression `x` of type `α`. -/
@[nolint unusedArguments] def Result {α : Q(Type u)} (x : Q($α)) := Result'

instance : Inhabited (Result x) := inferInstanceAs (Inhabited Result')

/-- The result is `proof : x`, where `x` is a (true) proposition. -/
@[match_pattern, inline] def Result.isTrue {x : Q(Prop)} :
    ∀ (proof : Q($x)), @Result _ (q(Prop) : Q(Type)) x := Result'.isBool true

/-- The result is `proof : ¬x`, where `x` is a (false) proposition. -/
@[match_pattern, inline] def Result.isFalse {x : Q(Prop)} :
    ∀ (proof : Q(¬$x)), @Result _ (q(Prop) : Q(Type)) x := Result'.isBool false

/-- The result is `lit : ℕ` (a raw nat literal) and `proof : isNat x lit`. -/
@[match_pattern, inline] def Result.isNat {α : Q(Type u)} {x : Q($α)} :
    ∀ (inst : Q(AddMonoidWithOne $α) := by assumption) (lit : Q(ℕ)) (proof : Q(IsNat $x $lit)),
      Result x := Result'.isNat

/-- The result is `-lit` where `lit` is a raw nat literal
and `proof : isInt x (.negOfNat lit)`. -/
@[match_pattern, inline] def Result.isNegNat {α : Q(Type u)} {x : Q($α)} :
    ∀ (inst : Q(Ring $α) := by assumption) (lit : Q(ℕ)) (proof : Q(IsInt $x (.negOfNat $lit))),
      Result x := Result'.isNegNat

/-- The result is `proof : isRat x n d`, where `n` is either `.ofNat lit` or `.negOfNat lit`
with `lit` a raw nat literal and `d` is a raw nat literal (not 0 or 1),
and `q` is the value of `n / d`. -/
@[match_pattern, inline] def Result.isRat {α : Q(Type u)} {x : Q($α)} :
    ∀ (inst : Q(DivisionRing $α) := by assumption) (q : Rat) (n : Q(ℤ)) (d : Q(ℕ))
      (proof : Q(IsRat $x $n $d)), Result x := Result'.isRat

/-- A shortcut (non)instance for `AddMonoidWithOne α` from `Ring α` to shrink generated proofs. -/
def instAddMonoidWithOne [Ring α] : AddMonoidWithOne α := inferInstance

/-- The result is `z : ℤ` and `proof : isNat x z`. -/
-- Note the independent arguments `z : Q(ℤ)` and `n : ℤ`.
-- We ensure these are "the same" when calling.
def Result.isInt {α : Q(Type u)} {x : Q($α)} (inst : Q(Ring $α) := by assumption)
    (z : Q(ℤ)) (n : ℤ) (proof : Q(IsInt $x $z)) : Result x :=
  have lit : Q(ℕ) := z.appArg!
  if 0 ≤ n then
    let proof : Q(IsInt $x (.ofNat $lit)) := proof
    .isNat q(instAddMonoidWithOne) lit q(IsInt.to_isNat $proof)
  else
    .isNegNat inst lit proof

/-- Returns the rational number that is the result of `norm_num` evaluation. -/
def Result.toRat : Result e → Option Rat
  | .isBool .. => none
  | .isNat _ lit _ => some lit.natLit!
  | .isNegNat _ lit _ => some (-lit.natLit!)
  | .isRat _ q .. => some q

end

/-- Convert `undef` to `none` to make an `LOption` into an `Option`. -/
def _root_.Lean.LOption.toOption {α} : Lean.LOption α → Option α
  | .some a => some a
  | _ => none

/-- Helper function to synthesize a typed `AddMonoidWithOne α` expression. -/
def inferAddMonoidWithOne (α : Q(Type u)) : MetaM Q(AddMonoidWithOne $α) :=
  return ← synthInstanceQ (q(AddMonoidWithOne $α) : Q(Type u)) <|>
    throwError "not an AddMonoidWithOne"

/-- Helper function to synthesize a typed `Semiring α` expression. -/
def inferSemiring (α : Q(Type u)) : MetaM Q(Semiring $α) :=
  return ← synthInstanceQ (q(Semiring $α) : Q(Type u)) <|> throwError "not a semiring"

/-- Helper function to synthesize a typed `Ring α` expression. -/
def inferRing (α : Q(Type u)) : MetaM Q(Ring $α) :=
  return ← synthInstanceQ (q(Ring $α) : Q(Type u)) <|> throwError "not a ring"

/-- Helper function to synthesize a typed `DivisionRing α` expression. -/
def inferDivisionRing (α : Q(Type u)) : MetaM Q(DivisionRing $α) :=
  return ← synthInstanceQ (q(DivisionRing $α) : Q(Type u)) <|> throwError "not a division ring"

/-- Helper function to synthesize a typed `OrderedSemiring α` expression. -/
def inferOrderedSemiring (α : Q(Type u)) : MetaM Q(OrderedSemiring $α) :=
  return ← synthInstanceQ (q(OrderedSemiring $α) : Q(Type u)) <|>
    throwError "not an ordered semiring"

/-- Helper function to synthesize a typed `OrderedRing α` expression. -/
def inferOrderedRing (α : Q(Type u)) : MetaM Q(OrderedRing $α) :=
  return ← synthInstanceQ (q(OrderedRing $α) : Q(Type u)) <|> throwError "not an ordered ring"

/-- Helper function to synthesize a typed `LinearOrderedField α` expression. -/
def inferLinearOrderedField (α : Q(Type u)) : MetaM Q(LinearOrderedField $α) :=
  return ← synthInstanceQ (q(LinearOrderedField $α) : Q(Type u)) <|>
    throwError "not a linear ordered field"

/-- Helper function to synthesize a typed `CharZero α` expression given `Ring α`. -/
def inferCharZeroOfRing {α : Q(Type u)} (_i : Q(Ring $α) := by with_reducible assumption) :
    MetaM Q(CharZero $α) :=
  return ← synthInstanceQ (q(CharZero $α) : Q(Prop)) <|>
    throwError "not a characteristic zero ring"

/-- Helper function to synthesize a typed `CharZero α` expression given `Ring α`, if it exists. -/
def inferCharZeroOfRing? {α : Q(Type u)} (_i : Q(Ring $α) := by with_reducible assumption) :
    MetaM (Option Q(CharZero $α)) :=
  return (← trySynthInstanceQ (q(CharZero $α) : Q(Prop))).toOption

/-- Helper function to synthesize a typed `CharZero α` expression given `AddMonoidWithOne α`. -/
def inferCharZeroOfAddMonoidWithOne {α : Q(Type u)}
    (_i : Q(AddMonoidWithOne $α) := by with_reducible assumption) : MetaM Q(CharZero $α) :=
  return ← synthInstanceQ (q(CharZero $α) : Q(Prop)) <|>
    throwError "not a characteristic zero AddMonoidWithOne"

/-- Helper function to synthesize a typed `CharZero α` expression given `AddMonoidWithOne α`, if it
exists. -/
def inferCharZeroOfAddMonoidWithOne? {α : Q(Type u)}
    (_i : Q(AddMonoidWithOne $α) := by with_reducible assumption) :
      MetaM (Option Q(CharZero $α)) :=
  return (← trySynthInstanceQ (q(CharZero $α) : Q(Prop))).toOption

/-- Helper function to synthesize a typed `CharZero α` expression given `DivisionRing α`. -/
def inferCharZeroOfDivisionRing {α : Q(Type u)}
    (_i : Q(DivisionRing $α) := by with_reducible assumption) : MetaM Q(CharZero $α) :=
  return ← synthInstanceQ (q(CharZero $α) : Q(Prop)) <|>
    throwError "not a characterstic zero division ring"

/-- Helper function to synthesize a typed `CharZero α` expression given `DivisionRing α`, if it
exists. -/
def inferCharZeroOfDivisionRing? {α : Q(Type u)}
    (_i : Q(DivisionRing $α) := by with_reducible assumption) : MetaM (Option Q(CharZero $α)) :=
  return (← trySynthInstanceQ (q(CharZero $α) : Q(Prop))).toOption
/--
Extract from a `Result` the integer value (as both a term and an expression),
and the proof that the original expression is equal to this integer.
-/
def Result.toInt {α : Q(Type u)} {e : Q($α)} (_i : Q(Ring $α) := by with_reducible assumption) :
    Result e → Option (ℤ × (lit : Q(ℤ)) × Q(IsInt $e $lit))
  | .isNat _ lit proof => do
    have proof : Q(@IsNat _ instAddMonoidWithOne $e $lit) := proof
    pure ⟨lit.natLit!, q(.ofNat $lit), q(($proof).to_isInt)⟩
  | .isNegNat _ lit proof => pure ⟨-lit.natLit!, q(.negOfNat $lit), proof⟩
  | _ => failure

/--
Extract from a `Result` the rational value (as both a term and an expression),
and the proof that the original expression is equal to this rational number.
-/
def Result.toRat' {α : Q(Type u)} {e : Q($α)}
    (_i : Q(DivisionRing $α) := by with_reducible assumption) :
    Result e → Option (ℚ × (n : Q(ℤ)) × (d : Q(ℕ)) × Q(IsRat $e $n $d))
  | .isBool .. => none
  | .isNat _ lit proof =>
    have proof : Q(@IsNat _ instAddMonoidWithOne $e $lit) := proof
    some ⟨lit.natLit!, q(.ofNat $lit), q(nat_lit 1), q(($proof).to_isRat)⟩
  | .isNegNat _ lit proof =>
    have proof : Q(@IsInt _ DivisionRing.toRing $e (.negOfNat $lit)) := proof
    some ⟨-lit.natLit!, q(.negOfNat $lit), q(nat_lit 1),
      (q(@IsInt.to_isRat _ DivisionRing.toRing _ _ $proof) : Expr)⟩
  | .isRat _ q n d proof => some ⟨q, n, d, proof⟩

instance : ToMessageData (Result x) where
  toMessageData
  | .isBool true proof => m!"isTrue ({proof})"
  | .isBool false proof => m!"isFalse ({proof})"
  | .isNat _ lit proof => m!"isNat {lit} ({proof})"
  | .isNegNat _ lit proof => m!"isNegNat {lit} ({proof})"
  | .isRat _ q _ _ proof => m!"isRat {q} ({proof})"

/--
Given a `NormNum.Result e` (which uses `IsNat`, `IsInt`, `IsRat` to express equality to a rational
numeral), converts it to an equality `e = Nat.rawCast n`, `e = Int.rawCast n`, or
`e = Rat.rawCast n d` to a raw cast expression, so it can be used for rewriting.
-/
def Result.toRawEq {α : Q(Type u)} {e : Q($α)} : Result e → (e' : Q($α)) × Q($e = $e')
  | .isBool false p =>
    have e : Q(Prop) := e; have p : Q(¬$e) := p
    ⟨(q(False) : Expr), (q(eq_false $p) : Expr)⟩
  | .isBool true p =>
    have e : Q(Prop) := e; have p : Q($e) := p
    ⟨(q(True) : Expr), (q(eq_true $p) : Expr)⟩
  | .isNat _ lit p => ⟨q(Nat.rawCast $lit), q(IsNat.to_raw_eq $p)⟩
  | .isNegNat _ lit p => ⟨q(Int.rawCast (.negOfNat $lit)), q(IsInt.to_raw_eq $p)⟩
  | .isRat _ _ n d p => ⟨q(Rat.rawCast $n $d), q(IsRat.to_raw_eq $p)⟩

/--
`Result.toRawEq` but providing an integer. Given a `NormNum.Result e` for something known to be an
integer (which uses `IsNat` or `IsInt` to express equality to an integer numeral), converts it to
an equality `e = Nat.rawCast n` or `e = Int.rawCast n` to a raw cast expression, so it can be used
for rewriting. Gives `none` if not an integer.
-/
def Result.toRawIntEq {α : Q(Type u)} {e : Q($α)} : Result e →
    Option (ℤ × (e' : Q($α)) × Q($e = $e'))
  | .isNat _ lit p => some ⟨lit.natLit!, q(Nat.rawCast $lit), q(IsNat.to_raw_eq $p)⟩
  | .isNegNat _ lit p => some ⟨-lit.natLit!, q(Int.rawCast (.negOfNat $lit)), q(IsInt.to_raw_eq $p)⟩
  | .isRat _ .. | .isBool .. => none

/-- Constructs a `Result` out of a raw nat cast. Assumes `e` is a raw nat cast expression. -/
def Result.ofRawNat {α : Q(Type u)} (e : Q($α)) : Result e := Id.run do
  let .app (.app _ (sα : Q(AddMonoidWithOne $α))) (lit : Q(ℕ)) := e | panic! "not a raw nat cast"
  .isNat sα lit (q(IsNat.of_raw $α $lit) : Expr)

/-- Constructs a `Result` out of a raw int cast.
Assumes `e` is a raw int cast expression denoting `n`. -/
def Result.ofRawInt {α : Q(Type u)} (n : ℤ) (e : Q($α)) : Result e :=
  if 0 ≤ n then
    Result.ofRawNat e
  else Id.run do
    let .app (.app _ (rα : Q(Ring $α))) (.app _ (lit : Q(ℕ))) := e | panic! "not a raw int cast"
    .isNegNat rα lit (q(IsInt.of_raw $α (.negOfNat $lit)) : Expr)

/-- Constructs a `Result` out of a raw rat cast.
Assumes `e` is a raw rat cast expression denoting `n`. -/
def Result.ofRawRat {α : Q(Type u)} (q : ℚ) (e : Q($α)) (hyp : Option Expr := none) : Result e :=
  if q.den = 1 then
    Result.ofRawInt q.num e
  else Id.run do
    let .app (.app (.app _ (dα : Q(DivisionRing $α))) (n : Q(ℤ))) (d : Q(ℕ)) := e
      | panic! "not a raw rat cast"
    let hyp : Q(($d : $α) ≠ 0) := hyp.get!
    .isRat dα q n d (q(IsRat.of_raw $α $n $d $hyp) : Expr)

/-- The result depends on whether `q : ℚ` happens to be an integer, in which case the result is
`.isInt ..` whereas otherwise it's `.isRat ..`. -/
def Result.isRat' {α : Q(Type u)} {x : Q($α)} (inst : Q(DivisionRing $α) := by assumption)
    (q : Rat) (n : Q(ℤ)) (d : Q(ℕ)) (proof : Q(IsRat $x $n $d)) : Result x :=
  if q.den = 1 then
    have proof : Q(IsRat $x $n (nat_lit 1)) := proof
    .isInt q(DivisionRing.toRing) n q.num q(IsRat.to_isInt $proof)
  else
    .isRat inst q n d proof

/-- Returns the rational number that is the result of `norm_num` evaluation, along with a proof
that the denominator is nonzero in the `isRat` case. -/
def Result.toRatNZ : Result e → Option (Rat × Option Expr)
  | .isBool .. => none
  | .isNat _ lit _ => some (lit.natLit!, none)
  | .isNegNat _ lit _ => some (-lit.natLit!, none)
  | .isRat _ q _ _ p => some (q, q(IsRat.den_nz $p))

/--
Constructs an `ofNat` application `a'` with the canonical instance, together with a proof that
the instance is equal to the result of `Nat.cast` on the given `AddMonoidWithOne` instance.

This function is performance-critical, as many higher level tactics have to construct numerals.
So rather than using typeclass search we hardcode the (relatively small) set of solutions
to the typeclass problem.
-/
def mkOfNat (α : Q(Type u)) (_sα : Q(AddMonoidWithOne $α)) (lit : Q(ℕ)) :
    MetaM ((a' : Q($α)) × Q($lit = $a')) := do
  if α.isConstOf ``Nat then
    let a' : Q(ℕ) := q(OfNat.ofNat $lit : ℕ)
    pure ⟨a', (q(Eq.refl $a') : Expr)⟩
  else if α.isConstOf ``Int then
    let a' : Q(ℤ) := q(OfNat.ofNat $lit : ℤ)
    pure ⟨a', (q(Eq.refl $a') : Expr)⟩
  else if α.isConstOf ``Rat then
    let a' : Q(ℚ) := q(OfNat.ofNat $lit : ℚ)
    pure ⟨a', (q(Eq.refl $a') : Expr)⟩
  else
    let some n := lit.natLit? | failure
    match n with
    | 0 => pure ⟨q(0 : $α), (q(Nat.cast_zero (R := $α)) : Expr)⟩
    | 1 => pure ⟨q(1 : $α), (q(Nat.cast_one (R := $α)) : Expr)⟩
    | k+2 =>
      let k : Q(ℕ) := mkRawNatLit k
      let _x : Q(Nat.AtLeastTwo $lit) :=
        (q(instAtLeastTwoHAddNatInstHAddInstAddNatOfNat (n := $k)) : Expr)
      let a' : Q($α) := q(OfNat.ofNat $lit)
      pure ⟨a', (q(Eq.refl $a') : Expr)⟩

/-- Convert a `Result` to a `Simp.Result`. -/
def Result.toSimpResult {α : Q(Type u)} {e : Q($α)} : Result e → MetaM Simp.Result
  | r@(.isBool ..) => let ⟨expr, proof?⟩ := r.toRawEq; pure { expr, proof? }
  | .isNat sα lit p => do
    let ⟨a', pa'⟩ ← mkOfNat α sα lit
    return { expr := a', proof? := q(IsNat.to_eq $p $pa') }
  | .isNegNat _rα lit p => do
    let ⟨a', pa'⟩ ← mkOfNat α q(AddCommMonoidWithOne.toAddMonoidWithOne) lit
    return { expr := q(-$a'), proof? := q(IsInt.neg_to_eq $p $pa') }
  | .isRat _ q n d p => do
    have lit : Q(ℕ) := n.appArg!
    if q < 0 then
      let p : Q(IsRat $e (.negOfNat $lit) $d) := p
      let ⟨n', pn'⟩ ← mkOfNat α q(AddCommMonoidWithOne.toAddMonoidWithOne) lit
      let ⟨d', pd'⟩ ← mkOfNat α q(AddCommMonoidWithOne.toAddMonoidWithOne) d
      return { expr := q(-($n' / $d')), proof? := q(IsRat.neg_to_eq $p $pn' $pd') }
    else
      let p : Q(IsRat $e (.ofNat $lit) $d) := p
      let ⟨n', pn'⟩ ← mkOfNat α q(AddCommMonoidWithOne.toAddMonoidWithOne) lit
      let ⟨d', pd'⟩ ← mkOfNat α q(AddCommMonoidWithOne.toAddMonoidWithOne) d
      return { expr := q($n' / $d'), proof? := q(IsRat.nonneg_to_eq $p $pn' $pd') }

/--
A extension for `norm_num`.
-/
structure NormNumExt where
  /-- The extension should be run in the `pre` phase when used as simp plugin. -/
  pre := true
  /-- The extension should be run in the `post` phase when used as simp plugin. -/
  post := true
  /-- Attempts to prove an expression is equal to some explicit number of the relevant type. -/
  eval {α : Q(Type u)} (e : Q($α)) : MetaM (Result e)
  /-- The name of the `norm_num` extension. -/
  name : Name := by exact decl_name%

/-- Read a `norm_num` extension from a declaration of the right type. -/
def mkNormNumExt (n : Name) : ImportM NormNumExt := do
  let { env, opts, .. } ← read
  IO.ofExcept <| unsafe env.evalConstCheck NormNumExt opts ``NormNumExt n

/-- Each `norm_num` extension is labelled with a collection of patterns
which determine the expressions to which it should be applied. -/
abbrev Entry := Array (Array (DiscrTree.Key true)) × Name

/-- The state of the `norm_num` extension environment -/
structure NormNums where
  /-- The tree of `norm_num` extensions. -/
  tree   : DiscrTree NormNumExt true := {}
  /-- Erased `norm_num`s. -/
  erased  : PHashSet Name := {}
  deriving Inhabited

/-- Environment extensions for `norm_num` declarations -/
initialize normNumExt : ScopedEnvExtension Entry (Entry × NormNumExt) NormNums ←
  -- we only need this to deduplicate entries in the DiscrTree
  have : BEq NormNumExt := ⟨fun _ _ ↦ false⟩
  /- Insert `v : NormNumExt` into the tree `dt` on all key sequences given in `kss`. -/
  let insert kss v dt := kss.foldl (fun dt ks ↦ dt.insertCore ks v) dt
  registerScopedEnvExtension {
    mkInitial := pure {}
    ofOLeanEntry := fun _ e@(_, n) ↦ return (e, ← mkNormNumExt n)
    toOLeanEntry := (·.1)
    addEntry := fun { tree, erased } ((kss, n), ext) ↦
      { tree := insert kss ext tree, erased := erased.erase n }
  }

/-- Run each registered `norm_num` extension on an expression, returning a `NormNum.Result`. -/
def derive {α : Q(Type u)} (e : Q($α)) (post := false) : MetaM (Result e) := do
  if e.isNatLit then
    let lit : Q(ℕ) := e
    return .isNat (q(instAddMonoidWithOneNat) : Q(AddMonoidWithOne ℕ))
      lit (q(IsNat.raw_refl $lit) : Expr)
  profileitM Exception "norm_num" (← getOptions) do
    let s ← saveState
    let normNums := normNumExt.getState (← getEnv)
    let arr ← normNums.tree.getMatch e
    for ext in arr do
      if (bif post then ext.post else ext.pre) && ! normNums.erased.contains ext.name then
        try
          let new ← withReducibleAndInstances <| ext.eval e
          trace[Tactic.norm_num] "{ext.name}:\n{e} ==> {new}"
          return new
        catch err =>
          trace[Tactic.norm_num] "{e} failed: {err.toMessageData}"
          s.restore
    throwError "{e}: no norm_nums apply"

/-- Run each registered `norm_num` extension on a typed expression `e : α`,
returning a typed expression `lit : ℕ`, and a proof of `isNat e lit`. -/
def deriveNat' {α : Q(Type u)} (e : Q($α)) :
    MetaM ((_inst : Q(AddMonoidWithOne $α)) × (lit : Q(ℕ)) × Q(IsNat $e $lit)) := do
  let .isNat inst lit proof ← derive e | failure
  pure ⟨inst, lit, proof⟩

/-- Run each registered `norm_num` extension on a typed expression `e : α`,
returning a typed expression `lit : ℕ`, and a proof of `isNat e lit`. -/
def deriveNat {α : Q(Type u)} (e : Q($α))
    (_inst : Q(AddMonoidWithOne $α) := by with_reducible assumption) :
    MetaM ((lit : Q(ℕ)) × Q(IsNat $e $lit)) := do
  let .isNat _ lit proof ← derive e | failure
  pure ⟨lit, proof⟩

/-- Run each registered `norm_num` extension on a typed expression `e : α`,
returning a typed expression `lit : ℤ`, and a proof of `IsInt e lit` in expression form. -/
def deriveInt {α : Q(Type u)} (e : Q($α))
    (_inst : Q(Ring $α) := by with_reducible assumption) :
    MetaM ((lit : Q(ℤ)) × Q(IsInt $e $lit)) := do
  let some ⟨_, lit, proof⟩ := (← derive e).toInt | failure
  pure ⟨lit, proof⟩

/-- Run each registered `norm_num` extension on a typed expression `e : α`,
returning a rational number, typed expressions `n : ℚ` and `d : ℚ` for the numerator and
denominator, and a proof of `IsRat e n d` in expression form. -/
def deriveRat {α : Q(Type u)} (e : Q($α))
    (_inst : Q(DivisionRing $α) := by with_reducible assumption) :
    MetaM (ℚ × (n : Q(ℤ)) × (d : Q(ℕ)) × Q(IsRat $e $n $d)) := do
  let some res := (← derive e).toRat' | failure
  pure res

/-- Extract the natural number `n` if the expression is of the form `OfNat.ofNat n`. -/
def isNatLit (e : Expr) : Option ℕ := do
  guard <| e.isAppOfArity ``OfNat.ofNat 3
  let .lit (.natVal lit) := e.appFn!.appArg! | none
  lit

/-- Extract the integer `i` if the expression is either a natural number literal
or the negation of one. -/
def isIntLit (e : Expr) : Option ℤ :=
  if e.isAppOfArity ``Neg.neg 3 then
    (- ·) <$> isNatLit e.appArg!
  else
    isNatLit e

/-- Extract the numerator `n : ℤ` and denominator `d : ℕ` if the expression is either
an integer literal, or the division of one integer literal by another. -/
def isRatLit (e : Expr) : Option ℚ := do
  if e.isAppOfArity ``Div.div 4 then
    let d ← isNatLit e.appArg!
    guard (d ≠ 1)
    let n ← isIntLit e.appFn!.appArg!
    let q := mkRat n d
    guard (q.den = d)
    pure q
  else
    isIntLit e

/-- Test if an expression represents an explicit number written in normal form. -/
def isNormalForm : Expr → Bool
  | .lit _ => true
  | .mdata _ e => isNormalForm e
  | e => (isRatLit e).isSome

/-- Run each registered `norm_num` extension on an expression,
returning a `Simp.Result`. -/
def eval (e : Expr) (post := false) : MetaM Simp.Result := do
  if isNormalForm e then return { expr := e }
  let ⟨.succ _, _, e⟩ ← inferTypeQ e | failure
  (← derive e post).toSimpResult

/-- Erases a name marked `norm_num` by adding it to the state's `erased` field and
  removing it from the state's list of `Entry`s. -/
def NormNums.eraseCore (d : NormNums) (declName : Name) : NormNums :=
 { d with erased := d.erased.insert declName }

/--
  Erase a name marked as a `norm_num` attribute.

  Check that it does in fact have the `norm_num` attribute by making sure it names a `NormNumExt`
  found somewhere in the state's tree, and is not erased.
-/
def NormNums.erase [Monad m] [MonadError m] (d : NormNums) (declName : Name) : m NormNums := do
  unless d.tree.values.any (·.name == declName) && ! d.erased.contains declName
  do
    throwError "'{declName}' does not have [norm_num] attribute"
  return d.eraseCore declName

initialize registerBuiltinAttribute {
  name := `norm_num
  descr := "adds a norm_num extension"
  applicationTime := .afterCompilation
  add := fun declName stx kind ↦ match stx with
    | `(attr| norm_num $es,*) => do
      let env ← getEnv
      unless (env.getModuleIdxFor? declName).isNone do
        throwError "invalid attribute 'norm_num', declaration is in an imported module"
      if (IR.getSorryDep env declName).isSome then return -- ignore in progress definitions
      let ext ← mkNormNumExt declName
      let keys ← MetaM.run' <| es.getElems.mapM fun stx ↦ do
        let e ← TermElabM.run' <| withSaveInfoContext <| withAutoBoundImplicit <|
          withReader ({ · with ignoreTCFailures := true }) do
            let e ← elabTerm stx none
            let (_, _, e) ← lambdaMetaTelescope (← mkLambdaFVars (← getLCtx).getFVars e)
            return e
        DiscrTree.mkPath e
      normNumExt.add ((keys, declName), ext) kind
    | _ => throwUnsupportedSyntax
  erase := fun declName => do
    let s := normNumExt.getState (← getEnv)
    let s ← s.erase declName
    modifyEnv fun env => normNumExt.modifyState env fun _ => s
}

/-- A simp plugin which calls `NormNum.eval`. -/
def tryNormNum? (post := false) (e : Expr) : SimpM (Option Simp.Step) := do
  try return some (.done (← eval e post))
  catch _ => return none

/--
Constructs a proof that the original expression is true
given a simp result which simplifies the target to `True`.
-/
def _root_.Lean.Meta.Simp.Result.ofTrue (r : Simp.Result) : MetaM (Option Expr) :=
  if r.expr.isConstOf ``True then
    some <$> match r.proof? with
    | some proof => mkOfEqTrue proof
    | none => pure (mkConst ``True.intro)
  else
    pure none

variable (ctx : Simp.Context) (useSimp := true) in
mutual
  /-- A discharger which calls `norm_num`. -/
  partial def discharge (e : Expr) : SimpM (Option Expr) := do (← deriveSimp e).ofTrue

  /-- A `Methods` implementation which calls `norm_num`. -/
  partial def methods : Simp.Methods :=
    if useSimp then {
      pre := fun e ↦ do
        Simp.andThen (← Simp.preDefault e discharge) tryNormNum?
      post := fun e ↦ do
        Simp.andThen (← Simp.postDefault e discharge) (tryNormNum? (post := true))
      discharge? := discharge
    } else {
      pre := fun e ↦ Simp.andThen (.visit { expr := e }) tryNormNum?
      post := fun e ↦ Simp.andThen (.visit { expr := e }) (tryNormNum? (post := true))
      discharge? := discharge
    }

  /-- Traverses the given expression using simp and normalises any numbers it finds. -/
  partial def deriveSimp (e : Expr) : MetaM Simp.Result :=
    (·.1) <$> Simp.main e ctx (methods := methods)
end

-- FIXME: had to inline a bunch of stuff from `simpGoal` here
/--
The core of `norm_num` as a tactic in `MetaM`.

* `g`: The goal to simplify
* `ctx`: The simp context, constructed by `mkSimpContext` and
  containing any additional simp rules we want to use
* `fvarIdsToSimp`: The selected set of hypotheses used in the location argument
* `simplifyTarget`: true if the target is selected in the location argument
* `useSimp`: true if we used `norm_num` instead of `norm_num1`
-/
def normNumAt (g : MVarId) (ctx : Simp.Context) (fvarIdsToSimp : Array FVarId)
    (simplifyTarget := true) (useSimp := true) :
    MetaM (Option (Array FVarId × MVarId)) := g.withContext do
  g.checkNotAssigned `norm_num
  let mut g := g
  let mut toAssert := #[]
  let mut replaced := #[]
  for fvarId in fvarIdsToSimp do
    let localDecl ← fvarId.getDecl
    let type ← instantiateMVars localDecl.type
    let ctx := { ctx with simpTheorems := ctx.simpTheorems.eraseTheorem (.fvar localDecl.fvarId) }
    let r ← deriveSimp ctx useSimp type
    match r.proof? with
    | some _ =>
      let some (value, type) ← applySimpResultToProp g (mkFVar fvarId) type r
        | return none
      toAssert := toAssert.push { userName := localDecl.userName, type, value }
    | none =>
      if r.expr.isConstOf ``False then
        g.assign (← mkFalseElim (← g.getType) (mkFVar fvarId))
        return none
      g ← g.replaceLocalDeclDefEq fvarId r.expr
      replaced := replaced.push fvarId
  if simplifyTarget then
    let res ← g.withContext do
      let target ← instantiateMVars (← g.getType)
      let r ← deriveSimp ctx useSimp target
      let some proof ← r.ofTrue
        | some <$> applySimpResultToTarget g target r
      g.assign proof
      pure none
    let some gNew := res | return none
    g := gNew
  let (fvarIdsNew, gNew) ← g.assertHypotheses toAssert
  let toClear := fvarIdsToSimp.filter fun fvarId ↦ !replaced.contains fvarId
  let gNew ← gNew.tryClearMany toClear
  return some (fvarIdsNew, gNew)

open Qq Lean Meta Elab Tactic Term

/-- Constructs a simp context from the simp argument syntax. -/
def getSimpContext (args : Syntax) (simpOnly := false) :
    TacticM Simp.Context := do
  let simpTheorems ←
    if simpOnly then simpOnlyBuiltins.foldlM (·.addConst ·) {} else getSimpTheorems
  let mut { ctx, starArg } ← elabSimpArgs args (eraseLocal := false) (kind := .simp)
    { simpTheorems := #[simpTheorems], congrTheorems := ← getSimpCongrTheorems }
  unless starArg do return ctx
  let mut simpTheorems := ctx.simpTheorems
  for h in ← getPropHyps do
    unless simpTheorems.isErased (.fvar h) do
      simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr
  pure { ctx with simpTheorems }

open Elab.Tactic in
/--
Elaborates a call to `norm_num only? [args]` or `norm_num1`.
* `args`: the `(simpArgs)?` syntax for simp arguments
* `loc`: the `(location)?` syntax for the optional location argument
* `simpOnly`: true if `only` was used in `norm_num`
* `useSimp`: false if `norm_num1` was used, in which case only the structural parts
  of `simp` will be used, not any of the post-processing that `simp only` does without lemmas
-/
-- FIXME: had to inline a bunch of stuff from `mkSimpContext` and `simpLocation` here
def elabNormNum (args : Syntax) (loc : Syntax)
    (simpOnly := false) (useSimp := true) : TacticM Unit := do
  let ctx ← getSimpContext args (!useSimp || simpOnly)
  let g ← getMainGoal
  let res ← match expandOptLocation loc with
  | .targets hyps simplifyTarget => normNumAt g ctx (← getFVarIds hyps) simplifyTarget useSimp
  | .wildcard => normNumAt g ctx (← g.getNondepPropHyps) (simplifyTarget := true) useSimp
  match res with
  | none => replaceMainGoal []
  | some (_, g) => replaceMainGoal [g]

end Meta.NormNum

namespace Tactic
open Lean.Parser.Tactic Meta.NormNum

/--
Normalize numerical expressions. Supports the operations `+` `-` `*` `/` `⁻¹` `^` and `%`
over numerical types such as `ℕ`, `ℤ`, `ℚ`, `ℝ`, `ℂ` and some general algebraic types,
and can prove goals of the form `A = B`, `A ≠ B`, `A < B` and `A ≤ B`, where `A` and `B` are
numerical expressions. It also has a relatively simple primality prover.
-/
elab (name := normNum) "norm_num" only:&" only"? args:(simpArgs ?) loc:(location ?) : tactic =>
  elabNormNum args loc (simpOnly := only.isSome) (useSimp := true)

/-- Basic version of `norm_num` that does not call `simp`. -/
elab (name := normNum1) "norm_num1" loc:(location ?) : tactic =>
  elabNormNum mkNullNode loc (simpOnly := true) (useSimp := false)

open Lean Elab Tactic

@[inherit_doc normNum1] syntax (name := normNum1Conv) "norm_num1" : conv

/-- Elaborator for `norm_num1` conv tactic. -/
@[tactic normNum1Conv] def elabNormNum1Conv : Tactic := fun _ ↦ withMainContext do
  let ctx ← getSimpContext mkNullNode true
  Conv.applySimpResult (← deriveSimp ctx (← instantiateMVars (← Conv.getLhs)) (useSimp := false))

@[inherit_doc normNum] syntax (name := normNumConv) "norm_num" &" only"? (simpArgs)? : conv

/-- Elaborator for `norm_num` conv tactic. -/
@[tactic normNumConv] def elabNormNumConv : Tactic := fun stx ↦ withMainContext do
  let ctx ← getSimpContext stx[2] !stx[1].isNone
  Conv.applySimpResult (← deriveSimp ctx (← instantiateMVars (← Conv.getLhs)) (useSimp := true))

/--
The basic usage is `#norm_num e`, where `e` is an expression,
which will print the `norm_num` form of `e`.

Syntax: `#norm_num` (`only`)? (`[` simp lemma list `]`)? `:`? expression

This accepts the same options as the `#simp` command.
You can specify additional simp lemmas as usual, for example using `#norm_num [f, g] : e`.
(The colon is optional but helpful for the parser.)
The `only` restricts `norm_num` to using only the provided lemmas, and so
`#norm_num only : e` behaves similarly to `norm_num1`.

Unlike `norm_num`, this command does not fail when no simplifications are made.

`#norm_num` understands local variables, so you can use them to introduce parameters.
-/
macro (name := normNumCmd) "#norm_num" o:(&" only")?
    args:(Parser.Tactic.simpArgs)? " :"? ppSpace e:term : command =>
  `(command| #conv norm_num $[only%$o]? $(args)? => $e)


/-
Copyright (c) 2021 Paula Neeley. All rights reserved.
Author: Paula Neeley
-/

import basicmodal.semantics.consistency basicmodal.syntax.soundness
local attribute [instance] classical.prop_decidable

open prfK

---------------------- Canonical Model Construction ----------------------

namespace canonical

def canonical (AX : ctx) [hax : sem_cons AX] : frame :=
{
  states := {xΓ : ctx // max_ax_consist AX xΓ},
  h :=
  begin
    have h1 := max_ax_exists AX hax,
    choose Γ h1 using h1,
    exact ⟨⟨Γ, h1⟩⟩
  end,
  rel := λ xΓ yΔ, ∀ φ : form, □φ ∈ xΓ.val → φ ∈ yΔ.val
}

def T_canonical  : frame := @canonical T_axioms sem_consT
def S4_canonical : frame := @canonical S4_axioms sem_consS4
def S5_canonical : frame := @canonical S5_axioms sem_consS5

def val_canonical (AX : ctx) [hax : sem_cons AX] : nat → (canonical AX).states → Prop :=
  λ n, λ xΓ : (canonical AX).states, (p n) ∈ xΓ.val

lemma existence (AX : ctx) (hax : sem_cons AX) (xΓ : (canonical AX).states) :
  ∀ φ, ◇φ ∈ xΓ.val ↔ ∃ yΔ : (canonical AX).states, φ ∈ yΔ.val ∧ (canonical AX).rel xΓ yΔ :=
begin
intro φ, split,
intro h1,
let Γbox : ctx := {ψ : form | □ψ ∈ xΓ.val},
have h1 : ax_consist AX (Γbox ∪ {φ}),
{by_contradiction h2, simp at h2,
have h3 := five AX Γbox φ h2,
cases h3 with L h3, cases h3 with h3 h4,
have h5 := cut fin_conj_boxn (mp kdist (nec h4)),
have h6 := exercise1,
have h7 : ∀ ψ ∈ (list.map □ L), ψ ∈ xΓ.1,
intros ψ h8, simp at *, cases h8 with a h8,
cases h8 with h8l h8r,
subst h8r, exact h3 a h8l,
specialize h6 xΓ.2 h7 h5,
have h8 := (six AX xΓ.1 (max_imp_ax xΓ.2)).mp xΓ.2 (¬φ).box,
cases h8 with h8l h8r, simp at *,
exact absurd h1 (h8r h6)
},
have h2 := lindenbaum AX (Γbox ∪ {φ}) h1,
cases h2 with Δ h2, cases h2 with h2 h3,
let xΔ : (canonical AX).states := ⟨Δ, h2⟩,
existsi (xΔ : (canonical AX).states),
have h5 := set.union_subset_iff.mp h3,
cases h5, split, simp at h5_right, exact h5_right,
have h3 : ∀ φ : form, □φ ∈ xΓ.val → φ ∈ xΔ.val,
intros ψ h4, apply h5_left, exact h4,
exact h3,
simp at *,
intros yΔ h1 h2,
by_contradiction h3,
have h4 := (max_notiff AX xΓ.1 xΓ.2 (◇φ)).mp h3,
have h5 := (max_dn AX xΓ.1 xΓ.2 (□¬φ)).mpr h4,
have h6 := (max_notiff AX yΔ.1 yΔ.2 φ).mpr (h2 (¬φ) h5),
exact absurd h1 h6
end

lemma truth (AX : ctx) (hax : sem_cons AX) (xΓ : (canonical AX).states) :
  ∀ φ, forces (canonical AX) (val_canonical AX) xΓ φ ↔ (φ ∈ xΓ.val) :=
begin
intro φ, induction φ with n φ ψ ih_φ ih_ψ
φ ψ ih_φ ih_ψ φ ih_φ generalizing xΓ,
split, intro h1, exact false.elim h1,
intro h1,
have h2 := xΓ.2,
cases h2,
specialize h2_left [⊥],
simp at *,
exact absurd not_contra (h2_left h1),
repeat {rw forces, rw val_canonical},
split, intro h1, cases h1 with h1 h2,
exact max_conj_1 xΓ.2 (and.intro ((ih_φ xΓ).mp h1) ((ih_ψ xΓ).mp h2)),
intro h1, split,
apply (ih_φ xΓ).mpr, exact max_conj_2 xΓ.2 h1,
apply (ih_ψ xΓ).mpr, exact max_conj_3 xΓ.2 h1,
split,
intro h1,
apply max_imp_1 xΓ.2,
intro h2,
exact (ih_ψ xΓ).mp (h1 ((ih_φ xΓ).mpr h2)),
intros h1 h2,
apply (ih_ψ xΓ).mpr,
exact max_imp_2 xΓ.2 h1 ((ih_φ xΓ).mp h2),
split, intros h1,
by_contradiction h2,
have h4 := (existence AX hax xΓ (¬φ)).mp,
have h5 := max_boxdn AX xΓ.1 xΓ.2 φ ((max_notiff AX xΓ.1 xΓ.2 φ.box).mp h2),
cases h4 h5 with xΔ h4, cases h4 with h4 h6,
have h7 := max_notiff AX xΔ.1 xΔ.2 φ,
cases h7 with h7l h7r,
exact absurd ((ih_φ xΔ).mp (h1 xΔ h6)) (h7r h4),
intros h1 xΔ h2,
apply (ih_φ xΔ).mpr, exact h2 φ h1,
end

lemma comphelper (AX : ctx) (φ : form) (hax : sem_cons AX) :
  ¬ prfK AX φ → ax_consist AX {¬φ} :=
begin
intro h1, intros L h2,
rw fin_ax_consist, induction L,
by_contradiction h3,
exact absurd (mp dne h3) (nprfalse AX hax),
have h4 : (∀ ψ ∈ L_hd::L_tl, ψ = ¬φ) → prfK AX (¬fin_conj (L_hd::L_tl)) → prfK AX φ,
from fin_conj_repeat hax,
simp at *,
cases h2 with h2 h3,
intro h6, apply h1, apply h4 h2,
exact h3,
exact h6
end

theorem forcesAX (AX : ctx) (hax : sem_cons AX) :
  forces_ctx (canonical AX) (val_canonical AX) AX :=
begin
intros φ xΓ h1,
have h2 : ∀ ψ ∈ list.nil, ψ ∈ xΓ.val,
{intros ψ h3, have h4 := list.ne_nil_of_length_pos (list.length_pos_of_mem h3),
simp at *, exact false.elim h4},
exact (truth AX hax xΓ φ).mpr (exercise1 xΓ.2 h2 (mp pl1 (ax h1)))
end

theorem completeness (AX : ctx) (hax : sem_cons AX) (φ : form) :
  global_sem_csq AX φ → prfK AX φ :=
begin
rw ←not_imp_not, intro h1,
have h2 := comphelper AX φ hax h1,
have h3 := lindenbaum AX {¬φ} h2,
simp at *,
cases h3 with Γ' h3, cases h3 with h3 h4,
rw global_sem_csq,
push_neg,
let f := canonical, use f AX,
let v := val_canonical, use v AX,
let xΓ' : (f AX).states := ⟨Γ', h3⟩,
split,
exact forcesAX AX hax,
use xΓ',
have h5 := truth AX hax xΓ' ¬φ,
cases h5 with h5 h6,
have h7 := not_forces_imp (f AX) (v AX) xΓ' φ,
cases h7 with h7 h8, apply h8, apply h6, exact h4
end

lemma T_reflexive : T_canonical ∈ ref_class :=
begin
intros x φ h1,
have h2 : (∀ ψ ∈ [□φ], ψ ∈ x.1) → prfK T_axioms (fin_conj [□φ] ⊃ φ) → φ ∈ x.1,
  from exercise1 x.2, simp at *,
have h3 : prfK T_axioms (fin_conj [φ.box] ⊃ φ),
{repeat {rw fin_conj},
have h4 : prfK T_axioms (φ.box ⊃ φ),
{refine ax _, rw T_axioms, simp},
exact cut (mp pl5 phi_and_true) h4},
exact h2 h1 h3
end

theorem T_completeness (φ : form) : F_valid φ ref_class → prfK T_axioms φ :=
begin
rw ←not_imp_not,
intro h1,
have h2 := completeness T_axioms sem_consT φ,
rw ←not_imp_not at h2,
specialize h2 h1,
rw F_valid,
push_neg,
let f := T_canonical, use f,
split,
exact T_reflexive,
let v := val_canonical, use (@v T_axioms sem_consT),
have h4 := lindenbaum T_axioms {¬φ} (comphelper T_axioms φ sem_consT h1),
simp at *,
cases h4 with Γ' h4, cases h4 with h4 h5,
let xΓ : f.states := ⟨Γ', h4⟩,
use xΓ,
have h6 := truth T_axioms sem_consT xΓ ¬φ,
cases h6 with h6 h7,
have h8 := not_forces_imp f (@v T_axioms sem_consT) xΓ φ,
cases h8 with h8 h9, apply h9, apply h7, exact h5
end

lemma S4_reftrans : S4_canonical ∈ ref_trans_class :=
begin
split,
intros x φ h1,
have h2 : (∀ ψ ∈ [□φ], ψ ∈ x.1) → prfK S4_axioms (fin_conj [□φ] ⊃ φ) → φ ∈ x.1,
  from exercise1 x.2, simp at *,
have h3 : prfK S4_axioms (fin_conj [φ.box] ⊃ φ),
{repeat {rw fin_conj},
have h4 : prfK S4_axioms (φ.box ⊃ φ),
{refine ax _, rw S4_axioms, simp, rw T_axioms, simp},
exact cut (mp pl5 phi_and_true) h4},
exact h2 h1 h3,
intros x y z h1 h2 φ h3, apply h2 φ,
apply h1 (□φ),
have h4 : prfK S4_axioms (fin_conj [φ.box] ⊃ φ.box.box),
{repeat {rw fin_conj},
have h5 : prfK S4_axioms (φ.box ⊃ φ.box.box),
{refine ax _, rw S4_axioms, simp},
exact cut (mp pl5 phi_and_true) h5},
have h6 : (∀ ψ ∈ [□φ], ψ ∈ x.1) → prfK S4_axioms (fin_conj [□φ] ⊃ φ.box.box) → φ.box.box ∈ x.1,
  from exercise1 x.2, simp at *,
exact h6 h3 h4
end

theorem S4_completeness (φ : form) : F_valid φ ref_trans_class → prfK S4_axioms φ :=
begin
rw ←not_imp_not,
intro h1,
have h2 := completeness S4_axioms sem_consS4 φ,
rw ←not_imp_not at h2,
specialize h2 h1,
rw F_valid,
push_neg,
let f := S4_canonical, use f,
split,
exact S4_reftrans,
let v := val_canonical, use (@v S4_axioms sem_consS4),
have h4 := lindenbaum S4_axioms {¬φ} (comphelper S4_axioms φ sem_consS4 h1),
simp at *,
cases h4 with Γ' h4, cases h4 with h4 h5,
let xΓ : f.states := ⟨Γ', h4⟩,
use xΓ,
have h6 := truth S4_axioms sem_consS4 xΓ ¬φ,
cases h6 with h6 h7,
have h8 := not_forces_imp f (@v S4_axioms sem_consS4) xΓ φ,
cases h8 with h8 h9, apply h9, apply h7, exact h5
end

lemma euclid_dual {φ : form} : prfK S5_axioms ((◇(¬φ) ⊃ □(◇(¬φ))) ⊃ (◇(□φ) ⊃ □φ)) :=
begin
simp,
have h1 : prfK S5_axioms (◇(¬φ) ⊃ □(◇¬φ)),
refine ax _, rw S5_axioms, simp, simp at *,
have h2 := contrapos.mpr h1,
have h3 := cut h2 (mp pl6 dual_equiv1),
have h4 : prfK S5_axioms ((¬□(◇¬φ)) ↔ (¬¬◇(¬(◇¬φ)))),
  from (mp (mp pl4 (contrapos.mpr (mp pl6 dual_equiv1))) (contrapos.mpr (mp pl5 dual_equiv1))),
have h5 := cut dni (cut (mp pl6 h4) h3),
have h6 := (contrapos.mpr (mp kdist (nec (contrapos.mpr (mp pl5 dual_equiv1))))),
exact (mp pl1 (cut h6 h5))
end

lemma S5_equiv : S5_canonical ∈ equiv_class :=
begin
rw equiv_ref_euclid,
split,
intros x φ h1,
have h2 : (∀ ψ ∈ [□φ], ψ ∈ x.1) → prfK S5_axioms (fin_conj [□φ] ⊃ φ) → φ ∈ x.1,
  from exercise1 x.2, simp at *,
have h3 : prfK S5_axioms (fin_conj [φ.box] ⊃ φ),
{repeat {rw fin_conj},
have h4 : prfK S5_axioms (φ.box ⊃ φ),
{refine ax _, rw S5_axioms, simp, rw T_axioms, simp},
exact cut (mp pl5 phi_and_true) h4},
exact h2 h1 h3,
intros x y z h1 h2 φ h3,
apply h2 φ, clear h2,
have h2 : prfK S5_axioms (◇(¬φ) ⊃ □(◇¬φ)),
{refine ax _, rw S5_axioms, simp},
have h4 : prfK S5_axioms (◇(□φ) ⊃ □φ),
  from mp euclid_dual h2,
have h5 : (∀ ψ ∈ [◇(□φ)], ψ ∈ x.1) →
  prfK S5_axioms (fin_conj [◇(□φ)] ⊃ □φ) → □φ ∈ x.1,
  from exercise1 x.2, simp at *,
apply h5,
by_contradiction h6,
have h7 := (max_notiff S5_axioms x.1 x.2 (¬(¬φ.box).box)).mp h6,
have h8 := (max_dn S5_axioms x.1 x.2 ((¬φ.box).box)).mpr h7,
have h9 := (max_notiff S5_axioms y.1 y.2 (φ.box)).mpr (h1 (¬φ.box) h8),
exact absurd h3 h9,
exact (cut (mp pl5 phi_and_true) h4)
end

theorem S5_completeness (φ : form) : F_valid φ equiv_class → prfK S5_axioms φ :=
begin
rw ←not_imp_not,
intro h1,
have h2 := completeness S5_axioms sem_consS5 φ,
rw ←not_imp_not at h2,
specialize h2 h1,
rw F_valid,
push_neg,
let f := S5_canonical, use f,
split,
exact S5_equiv,
let v := val_canonical, use (@v S5_axioms sem_consS5),
have h4 := lindenbaum S5_axioms {¬φ} (comphelper S5_axioms φ sem_consS5 h1),
simp at *,
cases h4 with Γ' h4, cases h4 with h4 h5,
let xΓ : f.states := ⟨Γ', h4⟩,
use xΓ,
have h6 := truth S5_axioms sem_consS5 xΓ ¬φ,
cases h6 with h6 h7,
have h8 := not_forces_imp f (@v S5_axioms sem_consS5) xΓ φ,
cases h8 with h8 h9, apply h9, apply h7, exact h5
end

end canonical


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.rel_iso
import Mathlib.order.lattice_intervals
import Mathlib.order.order_dual
import Mathlib.PostPort

universes u_2 l u_1

namespace Mathlib

/-!
# Modular Lattices
This file defines Modular Lattices, a kind of lattice useful in algebra.
For examples, look to the subobject lattices of abelian groups, submodules, and ideals, or consider
any distributive lattice.

## Main Definitions
- `is_modular_lattice` defines a modular lattice to be one such that
  `x ≤ z → (x ⊔ y) ⊓ z ≤ x ⊔ (y ⊓ z)`
- `inf_Icc_order_iso_Icc_sup` gives an order isomorphism between the intervals
  `[a ⊓ b, a]` and `[b, a ⊔ b]`.
  This corresponds to the diamond (or second) isomorphism theorems of algebra.

## Main Results
- `is_modular_lattice_iff_sup_inf_sup_assoc`:
  Modularity is equivalent to the `sup_inf_sup_assoc`: `(x ⊓ z) ⊔ (y ⊓ z) = ((x ⊓ z) ⊔ y) ⊓ z`
- `distrib_lattice.is_modular_lattice`: Distributive lattices are modular.

## To do
- Relate atoms and coatoms in modular lattices

-/

/-- A modular lattice is one with a limited associativity between `⊓` and `⊔`. -/
class is_modular_lattice (α : Type u_2) [lattice α] where
  sup_inf_le_assoc_of_le : ∀ {x : α} (y : α) {z : α}, x ≤ z → (x ⊔ y) ⊓ z ≤ x ⊔ y ⊓ z

theorem sup_inf_assoc_of_le {α : Type u_1} [lattice α] [is_modular_lattice α] {x : α} (y : α)
    {z : α} (h : x ≤ z) : (x ⊔ y) ⊓ z = x ⊔ y ⊓ z :=
  le_antisymm (is_modular_lattice.sup_inf_le_assoc_of_le y h)
    (le_inf (sup_le_sup_left inf_le_left x) (sup_le h inf_le_right))

theorem is_modular_lattice.sup_inf_sup_assoc {α : Type u_1} [lattice α] [is_modular_lattice α]
    {x : α} {y : α} {z : α} : x ⊓ z ⊔ y ⊓ z = (x ⊓ z ⊔ y) ⊓ z :=
  Eq.symm (sup_inf_assoc_of_le y inf_le_right)

theorem inf_sup_assoc_of_le {α : Type u_1} [lattice α] [is_modular_lattice α] {x : α} (y : α)
    {z : α} (h : z ≤ x) : x ⊓ y ⊔ z = x ⊓ (y ⊔ z) :=
  sorry

protected instance order_dual.is_modular_lattice {α : Type u_1} [lattice α] [is_modular_lattice α] :
    is_modular_lattice (order_dual α) :=
  is_modular_lattice.mk
    fun (x y z : order_dual α) (xz : x ≤ z) =>
      le_of_eq
        (eq.mpr (id (Eq._oldrec (Eq.refl ((x ⊔ y) ⊓ z = x ⊔ y ⊓ z)) inf_comm))
          (eq.mpr (id (Eq._oldrec (Eq.refl (z ⊓ (x ⊔ y) = x ⊔ y ⊓ z)) sup_comm))
            (eq.mpr (id (Eq._oldrec (Eq.refl (z ⊓ (y ⊔ x) = x ⊔ y ⊓ z)) (propext eq_comm)))
              (eq.mpr (id (Eq._oldrec (Eq.refl (x ⊔ y ⊓ z = z ⊓ (y ⊔ x))) inf_comm))
                (eq.mpr (id (Eq._oldrec (Eq.refl (x ⊔ z ⊓ y = z ⊓ (y ⊔ x))) sup_comm))
                  (eq.mpr
                    ((fun (a a_1 : order_dual α) (e_1 : a = a_1) (ᾰ ᾰ_1 : order_dual α)
                        (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
                      (z ⊓ y ⊔ x) ((z ⊔ coe_fn order_dual.of_dual y) ⊓ x) (Eq.refl (z ⊓ y ⊔ x))
                      (z ⊓ (y ⊔ x)) (z ⊔ coe_fn order_dual.of_dual y ⊓ x) (Eq.refl (z ⊓ (y ⊔ x))))
                    (sup_inf_assoc_of_le (coe_fn order_dual.of_dual y)
                      (iff.mpr order_dual.dual_le xz))))))))

/-- The diamond isomorphism between the intervals `[a ⊓ b, a]` and `[b, a ⊔ b]` -/
def inf_Icc_order_iso_Icc_sup {α : Type u_1} [lattice α] [is_modular_lattice α] (a : α) (b : α) :
    ↥(set.Icc (a ⊓ b) a) ≃o ↥(set.Icc b (a ⊔ b)) :=
  rel_iso.mk
    (equiv.mk (fun (x : ↥(set.Icc (a ⊓ b) a)) => { val := ↑x ⊔ b, property := sorry })
      (fun (x : ↥(set.Icc b (a ⊔ b))) => { val := a ⊓ ↑x, property := sorry }) sorry sorry)
    sorry

namespace is_compl

/-- The diamond isomorphism between the intervals `set.Iic a` and `set.Ici b`. -/
def Iic_order_iso_Ici {α : Type u_1} [bounded_lattice α] [is_modular_lattice α] {a : α} {b : α}
    (h : is_compl a b) : ↥(set.Iic a) ≃o ↥(set.Ici b) :=
  order_iso.trans (order_iso.set_congr (set.Iic a) (set.Icc (a ⊓ b) a) sorry)
    (order_iso.trans (inf_Icc_order_iso_Icc_sup a b)
      (order_iso.set_congr (set.Icc b (a ⊔ b)) (set.Ici b) sorry))

end is_compl

theorem is_modular_lattice_iff_sup_inf_sup_assoc {α : Type u_1} [lattice α] :
    is_modular_lattice α ↔ ∀ (x y z : α), x ⊓ z ⊔ y ⊓ z = (x ⊓ z ⊔ y) ⊓ z :=
  sorry

namespace distrib_lattice

protected instance is_modular_lattice {α : Type u_1} [distrib_lattice α] : is_modular_lattice α :=
  is_modular_lattice.mk
    fun (x y z : α) (xz : x ≤ z) =>
      eq.mpr (id (Eq._oldrec (Eq.refl ((x ⊔ y) ⊓ z ≤ x ⊔ y ⊓ z)) inf_sup_right))
        (eq.mpr (id (Eq._oldrec (Eq.refl (x ⊓ z ⊔ y ⊓ z ≤ x ⊔ y ⊓ z)) (iff.mpr inf_eq_left xz)))
          (le_refl (x ⊔ y ⊓ z)))

end distrib_lattice

namespace is_modular_lattice

protected instance is_modular_lattice_Iic {α : Type u_1} [bounded_lattice α] [is_modular_lattice α]
    {a : α} : is_modular_lattice ↥(set.Iic a) :=
  mk fun (x y z : ↥(set.Iic a)) (xz : x ≤ z) => sup_inf_le_assoc_of_le (↑y) xz

protected instance is_modular_lattice_Ici {α : Type u_1} [bounded_lattice α] [is_modular_lattice α]
    {a : α} : is_modular_lattice ↥(set.Ici a) :=
  mk fun (x y z : ↥(set.Ici a)) (xz : x ≤ z) => sup_inf_le_assoc_of_le (↑y) xz

end Mathlib


import lambda_calculus.utlc.beta.distance
import lambda_calculus.utlc.beta.encoding.basic
import complexity.basic
import complexity.core

namespace lambda_calculus
namespace utlc
namespace β
namespace complexity

open lambda_calculus.utlc.β.encoding

local attribute [simp] β.normal_iteration β.strategic_reduction_step head_reduced

variables {et: encoding_type}

theorem of_distance_le
  {a: complexity.encodable_function (distance_model et)} {f f': a.unwrap} (g : encoded_program) {g': encoded_program} (fc fc': complexity.cost_function a) (n: ℕ):
  distance_le n g'.value g.value → complexity.witness a g f fc → f = f' → (fc + ↑n) ≤ fc' →
  complexity.witness a g' f' fc' :=
begin
  induction a with _ _ _ en _ generalizing f f' g g' fc fc',
  { intros hg hw hf hfc,
    rw [← hf],
    apply distance_le_mono,
    apply distance_le_trans',
    apply hg,
    apply hw,
    refl,
    rw  [nat.cast_id, nat.add_comm] at hfc,
    assumption },
  { intros hg hw hf hfc a,
    apply a_ih (en.application g a),
    simp [distance_model],
    apply utlc.β.dot_distance_le_dot_left,
    apply hg,
    apply hw,
    rw [hf],
    apply hfc,
  }
end

instance value_complexity (α: Type) (et: encoding_type) [en: complexity.has_encoding (distance_model et) α] (a: α):
  complexity.has_complexity (distance_model et) a :=
  ⟨ ⟨ (0:ℕ),
    ⟨ ⟨ (en.value.encode a).value, (en.value.encode a).proof.left ⟩,
      @distance_le_refl _ has_β_reduction.step _ ⟩ ⟩ ⟩

def id_prog: encoded_program := ⟨ Λ ↓0, by simp ⟩

instance id_complexity (α: Type) (et: encoding_type) [en: complexity.has_encoding (distance_model et) α] (a: α):
  complexity.has_complexity (distance_model et) (@id α) :=
  ⟨ ⟨ λ _, (1:ℕ), ⟨ id_prog,
begin
  intro a,
  apply distance_le_of_normal_iteration,
  simp [id_prog, complexity.cast_unwrap, distance_model],
end ⟩ ⟩ ⟩

def const_prog: encoded_program := ⟨ Λ Λ ↓1, by simp ⟩

instance const_complexity (α β: Type) (et: encoding_type)
  [en: complexity.has_encoding (distance_model et) α] [en: complexity.has_encoding (distance_model et) β]:
  complexity.has_complexity (distance_model et) (@const α β) :=
  ⟨ ⟨ λ _ _, (2:ℕ), ⟨ const_prog,
begin
  intros a b,
  apply distance_le_of_normal_iteration,
  simp [const_prog, const, complexity.cast_unwrap, distance_model],
end ⟩ ⟩ ⟩

instance partial_complexity
  (α β: Type) (et: encoding_type)
  [en: complexity.has_encoding (distance_model et) α]
  [complexity.has_encodable_function (distance_model et) β]
  (a: α) {f: α → β} [h: complexity.has_complexity (distance_model et) f] :
  complexity.has_complexity (distance_model et) (f a) :=
  ⟨ ⟨ (complexity (distance_model et) f) a,
  by {
  cases h.value.proof with prog h,
  exact ⟨ ⟨ prog.value·(en.value.encode a).value, by {
    simp only [ bool.to_bool_coe, and_true,
      data_is_closed_below', closed_below, closed], apply prog.proof } ⟩,
  by { rw [complexity.cast_unwrap, fcast], exact h a } ⟩ } ⟩ ⟩

def compose_prog: encoded_program := ⟨ Λ Λ Λ ↓2·(↓1·↓0), by simp ⟩

instance compose_complexity
  (α β γ: Type) (et: encoding_type)
  [α_en: complexity.has_encoding (distance_model et) α] [β_en: complexity.has_encoding (distance_model et) β] [γ_en: complexity.has_encodable_function (distance_model et) γ]
  (f: α → β) (g: β → γ) [cf: complexity.has_complexity (distance_model et) f] [cg: complexity.has_complexity (distance_model et) g]:
  complexity.has_complexity (distance_model et) (compose g f) :=
⟨ ⟨ λ a, cg.value.cost (f a) + ↑(3 + (cf.value.cost a):ℕ),
begin
  rcases cf.value with ⟨cfc, fp, cfp⟩,
  rcases cg.value with ⟨cgc, gp, cgp⟩,
  fconstructor,
  { exact ⟨ compose_prog.value·gp.value·fp.value,
    by simp; exact ⟨compose_prog.proof, gp.proof, fp.proof⟩ ⟩ },
  intro a,
  apply of_distance_le begin
    fconstructor,
    { exact gp.value·((β_en.value.encode (f a)).value) },
    simp,
  end,
  { simp [distance_model, compose_prog],
    apply distance_le_trans,
    { apply distance_le_of_normal_iteration 3,
      simp [normal_iteration, distance_model, compose_prog] },
    apply utlc.β.dot_distance_le_dot_right,
    apply cfp a },
  apply cgp (f a),
  unfold complexity.cast_unwrap,
  rw [← fcast', ← fcast'],
  all_goals { simp [compose] },
end ⟩ ⟩

def flip_prog: encoded_program := ⟨ Λ Λ Λ ↓2·↓0·↓1, by simp ⟩

instance flip_complexity
  (α β γ: Type) (et: encoding_type)
  [α_en: complexity.has_encoding (distance_model et) α] [β_en: complexity.has_encoding (distance_model et) β] [γ_en: complexity.has_encoding (distance_model et) γ]
  (f: α → β → γ) [cf: complexity.has_complexity (distance_model et) f]:
  complexity.has_complexity (distance_model et) (flip f) :=
⟨ ⟨ λ b a, (cf.value.cost a b) + ↑3,
begin
  rcases cf.value with ⟨cfc, fp, cfp⟩,
  fconstructor,
  { exact ⟨ flip_prog.value·fp.value,
    by simp; exact ⟨ flip_prog.proof, fp.proof ⟩ ⟩ },
  intros a b,
  apply distance_le_trans',
  { apply distance_le_of_normal_iteration 3,
    refl },
  simp [distance_model, flip_prog],
  apply cfp,
  simp [add_comm 3],
end ⟩ ⟩

def ycomb: utlc := Λ (Λ ↓1·(↓0·↓0))·(Λ ↓1·(↓0·↓0))
def yrec (f: utlc): utlc := ycomb·f

theorem yrec_apply {f: utlc}: distance_le 3 (yrec f) (f·yrec f) :=
begin
  rw [yrec, ycomb],
  apply distance_le_trans',
  apply distance_le_of_normal_iteration 2,
  simp,
  apply dot_distance_le_dot_right,
  apply distance_le_symm,
  apply distance_le_of_normal_iteration 1,
  simp,
end

end complexity
end β
end utlc
end lambda_calculus


import meta_data

namespace Wiles_A_and_Taylor_R_FermatLast

-- the statement of Fermat's Last Theorem
axiom fermat_last_theorem :
∀ (x y z n : nat), x > 0 → y > 0 → n > 2 → x ^ n + y ^ n ≠ z ^ n

def paper : document :=
{   authors := [
    {name := "Andrew Wiles"},
    {name := "Richard Tylor"}
  ],
  title := "Modular elliptic curves and Fermat's last theorem",
  doi := "10.2307/2118559"}

definition fabstract : fabstract :=
{ description := "A result in number theory conjectured by Pierre de Fermat and proved by Andrew Wiles and Richard Taylor. Colloquially referred to as Fermat's Last Theorem.",
  contributors := [{name := "Adam Kurkiewicz"}],
  sources := [cite.Document paper],
  results := [result.Proof fermat_last_theorem] }

end Wiles_A_and_Taylor_R_FermatLast


open int
example : 2 + 3 = 5:=begin generalize h:3=x,generalize g:2=y,rw ← h,rw ← g,← end


example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
  by { repeat { any_goals { split } }; repeat { { left, assumption } <|> right <|> assumption } }


import analysis.normed_space.bounded_linear_maps
import seminormed_rings
import smoothing_procedure

noncomputable theory

open_locale big_operators nnreal

--TODO: check normed_group is normed_add_comm_group, nondiscrete_normed_field is nontrivilly_normed_field
structure is_continuous_linear_map (𝕜 : Type*) [normed_field 𝕜]
  {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
  {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F] (f : E → F)
  extends is_linear_map 𝕜 f : Prop :=
(cont : continuous f . tactic.interactive.continuity')

lemma is_continuous_linear_map_iff_is_bounded_linear_map {K : Type*} [nontrivially_normed_field K]
  {M : Type*} [normed_add_comm_group M] [normed_space K M] {N : Type*} [normed_add_comm_group N]
  [normed_space K N] (f : M → N) : is_continuous_linear_map K f ↔ is_bounded_linear_map K f :=
begin
  refine ⟨λ h_cont, _, λ h_bdd, ⟨h_bdd.to_is_linear_map, h_bdd.continuous⟩⟩,
  { set F : M →L[K] N :=
    by use [f, is_linear_map.map_add h_cont.1, is_linear_map.map_smul h_cont.1, h_cont.2],
    exact continuous_linear_map.is_bounded_linear_map F, },
end

-- Lemma 3.2.1./3

/- section

variables {K : Type*} [field K] {L : Type*} [field L] [algebra K L] {g : K → ℝ≥0} (hg : is_norm g)

lemma finite_extension_pow_mul_seminorm' (hfd : finite_dimensional K L)
  (hna : ∀ (a b : K), g(a - b) ≤ max (g a) (g b)) :
  ∃ f : L → nnreal, is_algebra_norm hg f ∧ is_pow_mult f ∧ function_extends g f :=
sorry
end -/

variables {K : Type*} [normed_field K] {L : Type*} [field L] [algebra K L]

variables {ι : Type*} [fintype ι] {R : Type*} [ring R] {M : Type*} [add_comm_group M]
  [module R M]

lemma linear_independent.eq_coords_of_eq {v : ι → M} (hv : linear_independent R v) {f : ι → R}
  {g : ι → R} (heq : ∑ i, f i • v i = ∑ i, g i • v i) (i : ι) : f i = g i :=
begin
  rw [← sub_eq_zero, ← finset.sum_sub_distrib] at heq,
  simp_rw ← sub_smul at heq,
  rw linear_independent_iff' at hv,
  exact sub_eq_zero.mp (hv finset.univ (λ i, (f i - g i)) heq i (finset.mem_univ i)),
end

lemma basis_one {ι : Type*} [fintype ι] [decidable_eq ι] {B : basis ι K L} {i : ι}
  (hBi : B i = (1 : L)) (k : K) :
  (B.equiv_fun) ((algebra_map K L) k) = λ (j : ι), if (j = i) then k else 0 :=
begin
  ext j,
  apply linear_independent.eq_coords_of_eq B.linear_independent,
  rw basis.sum_equiv_fun B (algebra_map K L k),
  have h_sum : ∑ (j : ι), ite (j = i) k 0 • B j = ∑ (j : ι), ite (j = i) (k • B j) 0,
  { apply finset.sum_congr (eq.refl _),
    { rintros h -,
      split_ifs,
      exacts [rfl, zero_smul _ _] }},
  rw [h_sum, algebra.algebra_map_eq_smul_one,
    finset.sum_ite_eq' finset.univ (i : ι) (λ j : ι, k • B j)],
  simp only [finset.mem_univ, if_true, hBi],
end

def basis.norm {ι : Type*} [fintype ι] [nonempty ι] (B : basis ι K L) : L → ℝ≥0 :=
λ x, ∥B.equiv_fun x (classical.some (finite.exists_max (λ i : ι, ∥B.equiv_fun x i∥ )))∥₊

lemma basis.norm_zero {ι : Type*} [fintype ι] [nonempty ι] (B : basis ι K L) :  B.norm 0 = 0 :=
by simp only [basis.norm, nnnorm_eq_zero, map_zero, pi.zero_apply, norm_zero]

lemma basis.norm_extends {ι : Type*} [fintype ι] [nonempty ι] [decidable_eq ι] {B : basis ι K L}
  {i : ι} (hBi : B i = (1 : L)) :
  function_extends (λ x : K, ∥x∥₊) B.norm :=
begin
  intro k,
  { by_cases hk : k = 0,
  { simp only [hk, map_zero, B.norm_zero, nnnorm_zero] },
  { simp only [basis.norm,  basis_one hBi],
    have h_max : (classical.some (finite.exists_max (λ j : ι,
      ∥(λ (n : ι), if (n = i) then k else 0) j ∥))) = i,
    { by_contradiction h,
      have h_max := classical.some_spec (finite.exists_max (λ j : ι,
        ∥(λ (n : ι), if (n = i) then k else 0) j ∥)),
      simp only [if_neg h] at h_max,
      specialize h_max i,
      rw [if_pos rfl, norm_zero, norm_le_zero_iff] at h_max,
      exact hk h_max },
    rw if_pos h_max, }}
end

lemma basis.norm_is_nonarchimedean {ι : Type*} [fintype ι] [nonempty ι] [decidable_eq ι]
  {B : basis ι K L} {i : ι} (hBi : B i = (1 : L))
  (hna : ∀ (a b : K), ∥a - b∥₊ ≤ max (∥a∥₊) (∥b∥₊)) : is_nonarchimedean B.norm  :=
begin
  intros x y,
  simp only [basis.norm],
  set ixy := classical.some (finite.exists_max (λ i : ι, ∥B.equiv_fun (x - y) i∥)) with hixy_def,
  have hxy : ∥B.equiv_fun (x - y) ixy∥₊ ≤ max (∥B.equiv_fun x ixy∥₊) (∥B.equiv_fun y ixy∥₊),
  { rw [linear_equiv.map_sub, pi.sub_apply], exact hna _ _ , },
  have hix := classical.some_spec (finite.exists_max (λ i : ι, ∥B.equiv_fun x i∥)),
  have hiy := classical.some_spec (finite.exists_max (λ i : ι, ∥B.equiv_fun y i∥)),
  cases le_max_iff.mp hxy with hx hy,
  { apply le_max_of_le_left,
    exact le_trans hx (hix ixy), },
  { apply le_max_of_le_right,
    exact le_trans hy (hiy ixy), },
end

lemma basis.norm_is_bdd {ι : Type*} [fintype ι] [nonempty ι] [decidable_eq ι] {B : basis ι K L}
  {i : ι} (hBi : B i = (1 : L)) :
  ∃ (c : nnreal) (hc : 0 < c), ∀ (x y : L), B.norm (x * y) ≤ c * B.norm x * B.norm y :=
begin
  set M := classical.some (finite.exists_max (λ (i : ι × ι), B.norm (B i.1 * B i.2))) with hM_def,
  have hM := classical.some_spec (finite.exists_max (λ (i : ι × ι), B.norm (B i.1 * B i.2))),
  use B.norm (B M.1 * B M.2),
  split,
  { have h_pos : (0 : nnreal) < B.norm (B i * B i),
    { have h1 : (1 : L) = (algebra_map K L) 1 := by rw map_one,
      rw [hBi, mul_one, h1, basis.norm_extends hBi],
      simp only [nnnorm_one, zero_lt_one] },
    exact lt_of_lt_of_le h_pos (hM (i, i)) },
  { intros x y,
    set ixy := classical.some (finite.exists_max (λ i : ι, ∥B.equiv_fun (x*y) i∥))
      with hixy_def,
    conv_lhs{simp only [basis.norm],
    rw [← hixy_def, ← basis.sum_equiv_fun B x, ← basis.sum_equiv_fun B y] },
    rw finset.sum_mul,
    --rw basis.equiv_fun_apply,

    have h_sum : B.equiv_fun (∑ (x_1 : ι), B.equiv_fun x x_1 • B x_1 *
    ∑ (i : ι), B.equiv_fun y i •  B i) ixy =
    ∑ (x_1 : ι), B.equiv_fun (B.equiv_fun x x_1 • B x_1 *
    ∑ (i : ι), B.equiv_fun y i •  B i) ixy,
    {
      sorry },
/-     have h_sum : B.repr (∑ (x_1 : ι), B.repr x x_1 • B x_1 *
    ∑ (i : ι), B.equiv_fun y i •  B i) ixy =
    ∑ (x_1 : ι), B.repr (B.equiv_fun x x_1 • B x_1 *
    ∑ (i : ι), B.equiv_fun y i •  B i) ixy,
    {
      sorry }, -/
    simp_rw h_sum,
 --apply @is_nonarchimedean_finset_image_add _ _ (λ (x : K), ∥x∥₊) (nnnorm_zero) _ B.equiv_fun,
   -- },
    /- have hj : ∃ (j : ι) (hj : finset.univ.nonempty → j ∈ finset.univ), ∥∑ (x_1 : ι),
      B.equiv_fun (B.equiv_fun x x_1 • B x_1 *
      ∑ (i : ι), B.equiv_fun y i • B i) ixy∥₊ ≤
    ∥B.equiv_fun (B.equiv_fun x j • B j * ∑ (i : ι), B.equiv_fun y i • B i) ixy∥₊,
    { have hna : is_nonarchimedean (nnnorm : K → ℝ≥0) := sorry,
      sorry,
      /- have := @is_nonarchimedean_finset_image_add K _ nnnorm (nnnorm_zero) hna B.equiv_fun
        finset.univ,  -/
    },
    obtain ⟨j, hjuniv, hj⟩ := hj,
    apply le_trans hj,
    simp, -/

    /- lemma is_nonarchimedean_finset_image_add {α : Type*} [ring α] {f : α → nnreal} (hf0 : f 0 = 0)
  (hna : is_nonarchimedean f) {β : Type*} [hβ : nonempty β] (g : β → α) (s : finset β) :
  ∃ (b : β) (hb : s.nonempty → b ∈ s), f (s.sum g) ≤ f (g b) := -/

    sorry },
end

lemma basis.repr_smul {ι : Type*} [fintype ι] [nonempty ι] [decidable_eq ι] (B : basis ι K L)
  (i : ι) (k : K) (y : L) : B.equiv_fun ((algebra_map K L k) * y) i = k * (B.equiv_fun y i) :=
by rw [← smul_eq_mul, algebra_map_smul, linear_equiv.map_smul]; refl

lemma basis.norm_smul {ι : Type*} [fintype ι] [nonempty ι] [decidable_eq ι] {B : basis ι K L}
  {i : ι} (hBi : B i = (1 : L)) (k : K) (y : L) :
  B.norm ((algebra_map K L) k * y) = B.norm ((algebra_map K L) k) * B.norm y :=
begin
  by_cases hk : k = 0,
  { rw [hk, map_zero, zero_mul, B.norm_zero, zero_mul],},
  { rw basis.norm_extends hBi,
    simp only [basis.norm],
    set i := classical.some (finite.exists_max (λ i : ι, ∥B.equiv_fun y i∥)) with hi_def,
    have hi := classical.some_spec (finite.exists_max (λ i : ι, ∥B.equiv_fun y i∥)),
    set j := classical.some (finite.exists_max (λ i : ι, ∥B.equiv_fun ((algebra_map K L) k * y) i∥))
      with hj_def,
    have hj := classical.some_spec
      (finite.exists_max (λ i : ι, ∥B.equiv_fun ((algebra_map K L) k * y) i∥)),
    have hij : ∥B.equiv_fun y i∥₊ = ∥B.equiv_fun y j∥₊,
    { refine le_antisymm _ (hi j),
      { specialize hj i,
        rw ← hj_def at hj,
        simp only [basis.repr_smul, norm_mul] at hj,
        exact (mul_le_mul_left (lt_of_le_of_ne (norm_nonneg _)
          (ne.symm (norm_ne_zero_iff.mpr hk)))).mp hj }},
    rw [basis.repr_smul, nnnorm_mul, ← hi_def, ← hj_def, hij] },
end

/- lemma basis.norm_is_module_norm {ι : Type*} [fintype ι] (B : basis ι K L)
  (hB1 : ∃ i : ι, B i = (1 : L)) : Prop := false -/

lemma finite_extension_pow_mul_seminorm (hfd : finite_dimensional K L)
  (hna : ∀ (a b : K), ∥a - b∥₊ ≤ max (∥a∥₊) (∥b∥₊)) :
  ∃ f : L → nnreal, is_algebra_norm (normed_ring.to_is_norm K) f ∧ is_pow_mult f ∧
    function_extends (λ (k : K), ∥ k ∥₊) f ∧ is_nonarchimedean f :=
begin
  -- Choose a basis B = {1, e2,..., en} of the K-vector space L
  classical,
  set h1 : linear_independent K (λ (x : ({1} : set L)), (x : L)) :=
  linear_independent_singleton one_ne_zero,
  set ι := {x // x ∈ (h1.extend (set.subset_univ ({1} : set L)))} with hι,
  set B : basis ι K L  := basis.extend h1 with hB,
  letI hfin : fintype ι := finite_dimensional.fintype_basis_index B,
  haveI hem : nonempty ι := B.index_nonempty,
  have h1L : (1 : L) ∈ h1.extend _,
  { apply basis.subset_extend,
    exact set.mem_singleton 1 },
  have hB1 : B ⟨1, h1L⟩ = (1 : L),
  { rw [basis.coe_extend, subtype.coe_mk] },
  -- For every k ∈ K, k = k • 1 + 0 • e2 + ... + 0 • en
  have h_k : ∀ (k : K), (B.equiv_fun) ((algebra_map K L) k) = λ (i : ι),
    if (i = ⟨(1 : L), h1L⟩) then k else 0 := basis_one hB1,
  -- Define a function g : L → ℝ≥0 by setting g (∑ki • ei) = maxᵢ ∥ ki ∥
  set g : L → nnreal := B.norm with hg,
  -- g 0 = 0
  have hg0 : g 0 = 0 := B.norm_zero,
  -- g extends the norm on K
  have hg_ext : function_extends (λ x : K, ∥x∥₊) g := basis.norm_extends hB1,
  -- g is nonarchimedean
  have hg_na : is_nonarchimedean g := basis.norm_is_nonarchimedean hB1 hna,
  -- g is multiplicatively bounded
  have hg_bdd : ∃ (c : nnreal) (hc : 0 < c), ∀ (x y : L), g (x * y) ≤ c * g x * g y,
  { exact basis.norm_is_bdd hB1 },
  -- g is a K-module norm
  have hg_mul : ∀ (k : K) (y : L), g ((algebra_map K L) k * y) = g ((algebra_map K L) k) * g y :=
  λ k y, basis.norm_smul hB1 k y,
  -- Using BGR Prop. 1.2.1/2, we can smooth g to a ring norm f on L that extends the norm on K.
  set f := seminorm_from_bounded g with hf,
  have hf_sn : is_seminorm f := seminorm_from_bounded_is_seminorm hg0 hg_bdd
    (add_le_of_is_nonarchimedean hg0 hg_na),
  have hf_na : is_nonarchimedean f := seminorm_from_bounded_is_nonarchimedean hg_bdd hg_na,
  have hf_1 : is_norm_le_one_class f := seminorm_from_bounded_is_norm_le_one_class hg_bdd,
  have hf_ext : function_extends (λ x : K, ∥x∥₊) f,
  { intro k,
    rw ← hg_ext,
    exact seminorm_from_bounded_of_mul_apply hg_bdd (hg_mul k) },
  -- Using BGR Prop. 1.3.2/1, we obtain from f  a power multiplicative K-algebra norm on L
  -- extending the norm on K.
  set F := smoothing_seminorm hf_1 with hF,
  have hF_ext : ∀ k : K,  F ((algebra_map K L) k) = (λ (k : K), ∥k∥₊) k,
  { intro k,
    rw ← hf_ext _,
    exact smoothing_seminorm_apply_of_is_mult hf_sn hf_1
      (seminorm_from_bounded_of_mul_is_mul hg_bdd (hg_mul k)) },
  have hF_1 : F 1 = 1,
  { have h1 : (1 : L) = (algebra_map K L) 1 := by rw map_one,
    simp only [h1, hF_ext (1 : K), nnnorm_one], },
  use F,
  refine ⟨⟨field.is_norm_of_is_seminorm (smoothing_seminorm_is_seminorm hf_sn hf_1 hf_na)
      ⟨(1 : L), hF_1.symm ▸ zero_ne_one⟩, _⟩, smoothing_seminorm_is_pow_mult hf_sn hf_1, hF_ext,
      smoothing_seminorm_is_nonarchimedean hf_sn hf_1 hf_na⟩,
  { intros k y,
    have hk : ∀ y : L, f ((algebra_map K L k) * y) = f (algebra_map K L k) * f y,
    { exact seminorm_from_bounded_of_mul_is_mul hg_bdd (hg_mul k), },
    have hfk : f ((algebra_map K L) k) = ∥k∥₊ := hf_ext k,
    rw [hF, ← hfk, ← smoothing_seminorm_apply_of_is_mult hf_sn hf_1 hk, algebra.smul_def],
    exact smoothing_seminorm_of_mult hf_sn hf_1 hk y, },
end