/-
Copyright (c) 2022 Dhruv Bhatia. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Dhruv Bhatia, Eric Wieser, Mario Carneiro
-/
import Mathlib.Data.Rat.Basic
import Mathlib.Tactic.LinearCombination

/-!

# polyrith Tactic

In this file, the `polyrith` tactic is created.  This tactic, which
works over `field`s, attempts to prove a multivariate polynomial target over said
field by using multivariable polynomial hypotheses/proof terms over the same field.
Used as is, the tactic makes use of those hypotheses in the local context that are
over the same field as the target. However, the user can also specifiy which hypotheses
from the local context to use, along with proof terms that might not already be in the
local context. Note: since this tactic uses SageMath via an API call done in Python,
it can only be used with a working internet connection, and with a local installation of Python.

## Implementation Notes

The tactic `linear_combination` is often used to prove such goals by allowing the user to
specify a coefficient for each hypothesis. If the target polynomial can be written as a
linear combination of the hypotheses with the chosen coefficients, then the `linear_combination`
tactic succeeds. In other words, `linear_combination` is a certificate checker, and it is left
to the user to find a collection of good coefficients. The `polyrith` tactic automates this
process using the theory of Groebner bases.

Polyrith does this by first parsing the relevant hypotheses into a form that Python can understand.
It then calls a Python file that uses the SageMath API to compute the coefficients. These
coefficients are then sent back to Lean, which parses them into pexprs. The information is then
given to the `linear_combination` tactic, which completes the process by checking the certificate.

`polyrith` calls an external python script `scripts/polyrith_sage.py`. Because this is not a Lean
file, changes to this script may not be noticed during Lean compilation if you have already
generated olean files. If you are modifying this python script, you likely know what you're doing;
remember to force recompilation of any files that call `polyrith`.

## TODO

* Give Sage more information about the specific ring being used for the coefficients. For now,
  we always use ℚ (or `QQ` in Sage).
* Handle `•` terms.
* Support local Sage installations.

## References

* See the book [*Ideals, Varieties, and Algorithms*][coxlittleOshea1997] by David Cox, John Little,
  and Donal O'Shea for the background theory on Groebner bases
* This code was heavily inspired by the code for the tactic `linarith`, which was written by
  Robert Lewis, who advised me on this project as part of a Computer Science independent study
  at Brown University.

-/

namespace Mathlib.Tactic.Polyrith
open Lean hiding Rat
open Meta Ring Qq PrettyPrinter AtomM
initialize registerTraceClass `Meta.Tactic.polyrith

/-! # Poly Datatype -/

/--
A datatype representing the semantics of multivariable polynomials.
Each `poly` can be converted into a string.
-/
inductive Poly
  | const : ℚ → Poly
  | var : ℕ → Poly
  | hyp : Term → Poly
  | add : Poly → Poly → Poly
  | sub : Poly → Poly → Poly
  | mul : Poly → Poly → Poly
  | div : Poly → Poly → Poly
  | pow : Poly → Poly → Poly
  | neg : Poly → Poly
  deriving BEq, Repr

/--
This converts a poly object into a string representing it. The string
maintains the semantic structure of the poly object.

The output of this function must be valid Python syntax, and it assumes the variables `varN` from
`scripts/polyrith.py.`
-/
def Poly.format : Poly → Lean.Format
  | .const z => toString z
  | .var n => s!"var{n}"
  | .hyp e => s!"hyp{e}" -- this one can't be used by python
  | .add p q => s!"({p.format} + {q.format})"
  | .sub p q => s!"({p.format} - {q.format})"
  | .mul p q => s!"({p.format} * {q.format})"
  | .div p q => s!"({p.format} / {q.format})" -- this one can't be used by python
  | .pow p q => s!"({p.format} ^ {q.format})"
  | .neg p => s!"-{p.format}"

instance : Lean.ToFormat Poly := ⟨Poly.format⟩
instance : ToString Poly := ⟨(toString ·.format)⟩
instance : Repr Poly := ⟨fun p _ => p.format⟩
instance : Inhabited Poly := ⟨Poly.const 0⟩

instance : Quote ℤ where quote
  | .ofNat n => quote n
  | .negSucc n => Unhygienic.run `(-$(quote n))

instance : Quote ℚ where
  quote q :=
    if q.den = 1 then quote q.num
    else Unhygienic.run `($(quote q.num) / $(quote q.den))

variable (vars : Array Syntax.Term) in
/-- Converts a `Poly` expression into a `Syntax` suitable as an input to `linear_combination`. -/
def Poly.toSyntax : Poly → Unhygienic Syntax.Term
  | .const z => pure (quote z)
  | .var n => pure vars[n]!
  | .hyp stx => pure stx
  | .add p q => do `($(← p.toSyntax) + $(← q.toSyntax))
  | .sub p q => do `($(← p.toSyntax) - $(← q.toSyntax))
  | .mul p q => do `($(← p.toSyntax) * $(← q.toSyntax))
  | .div p q => do `($(← p.toSyntax) / $(← q.toSyntax))
  | .pow p q => do `($(← p.toSyntax) ^ $(← q.toSyntax))
  | .neg p => do `(-$(← p.toSyntax))

/-- Reifies a ring expression of type `α` as a `Poly`. -/
partial def parse {u} {α : Q(Type u)} (sα : Q(CommSemiring $α))
    (c : Ring.Cache sα) (e : Q($α)) : AtomM Poly := do
  let els := do
    try pure <| Poly.const (← (← NormNum.derive e).toRat)
    catch _ => pure <| Poly.var (← addAtom e)
  let .const n _ := (← withReducible <| whnf e).getAppFn | els
  match n, c.rα with
  | ``HAdd.hAdd, _ | ``Add.add, _ => match e with
    | ~q($a + $b) => pure <| (← parse sα c a).add (← parse sα c b)
    | _ => els
  | ``HMul.hMul, _ | ``Mul.mul, _ => match e with
    | ~q($a * $b) => pure <| (← parse sα c a).mul (← parse sα c b)
    | _ => els
  | ``HSMul.hSMul, _ => match e with
    | ~q(($a : ℕ) • ($b : «$α»)) => pure <| (← parse sℕ .nat a).mul (← parse sα c b)
    | _ => els
  | ``HPow.hPow, _ | ``Pow.pow, _ => match e with
    | ~q($a ^ $b) => pure <| (← parse sα c a).pow (← parse sℕ .nat b)
    | _ => els
  | ``Neg.neg, some _ => match e with
    | ~q(-$a) => pure <| (← parse sα c a).neg
  | ``HSub.hSub, some _ | ``Sub.sub, some _ => match e with
    | ~q($a - $b) => pure <| (← parse sα c a).sub (← parse sα c b)
    | _ => els
  | _, _ => els

/-- The possible hypothesis sources for a polyrith proof. -/
inductive Source where
  /-- `input n` refers to the `n`'th input `ai` in `polyrith [a1, ..., an]`. -/
  | input : Nat → Source
  /-- `fvar h` refers to hypothesis `h` from the local context. -/
  | fvar : FVarId → Source

/-- The first half of `polyrith` produces a list of arguments to be sent to Sage. -/
def parseContext (only : Bool) (hyps : Array Expr) (tgt : Expr) :
    AtomM (Expr × Array (Source × Poly) × Poly) := do
  let fail {α} : AtomM α := throwError "polyrith failed: target is not an equality in semirings"
  let some (α, e₁, e₂) := (← whnfR <|← instantiateMVars tgt).eq? | fail
  let .sort (.succ u) ← whnf (← inferType α) | fail
  have α : Q(Type u) := α
  have e₁ : Q($α) := e₁; have e₂ : Q($α) := e₂
  let sα ← synthInstanceQ (q(CommSemiring $α) : Q(Type u))
  let c ← mkCache sα
  let tgt := (← parse sα c e₁).sub (← parse sα c e₂)
  let rec
    /-- Parses a hypothesis and adds it to the `out` list. -/
    processHyp src ty out := do
      if let some (β, e₁, e₂) := (← instantiateMVars ty).eq? then
        if ← withTransparency (← read).red <| isDefEq α β then
          return out.push (src, (← parse sα c e₁).sub (← parse sα c e₂))
      pure out
  let mut out := #[]
  if !only then
    for ldecl in ← getLCtx do
      out ← processHyp (.fvar ldecl.fvarId) ldecl.type out
  for hyp in hyps, i in [:hyps.size] do
    out ← processHyp (.input i) (← inferType hyp) out
  pure (α, out, tgt)

/-- Constructs the list of arguments to pass to the external sage script `polyrith_sage.py`. -/
def createSageArgs (trace : Bool) (α : Expr) (atoms : Nat)
    (hyps : Array (Source × Poly)) (tgt : Poly) : Array String :=
  let hyps := hyps.map (toString ·.2) |>.toList.toString
  #[toString trace, toString α, toString atoms, hyps, toString tgt]

/-- A JSON parser for `ℚ` specific to the return value of `polyrith_sage.py`. -/
local instance : FromJson ℚ where fromJson?
  | .arr #[a, b] => return (← fromJson? a : ℤ) / (← fromJson? b : ℕ)
  | _ => .error "expected array with two elements"

/-- Removes an initial `-` sign from a polynomial with negative leading coefficient. -/
def Poly.unNeg? : Poly → Option Poly
  | .mul a b => return .mul (← a.unNeg?) b
  | .const i => if i < 0 then some (.const (-i)) else none
  | .neg p => p
  | _ => none

/-- Adds two polynomials, performing some simple simplifications for presentation like
`a + -b = a - b`. -/
def Poly.add' : Poly → Poly → Poly
  | .const 0, p => match p.unNeg? with
    | some np => .neg np
    | none => p
  | p, .const 0 => p
  | a, b => match b.unNeg? with
    | some nb => a.sub nb
    | none => a.add b

/-- Multiplies two polynomials, performing some simple simplifications for presentation like
`1 * a = a`. -/
def Poly.mul' : Poly → Poly → Poly
  | .const 0, _ => .const 0
  | .const 1, p
  | p, .const 1 => p
  | a, b => a.mul b

/-- Extracts the divisor `c : ℕ` from a polynomial of the form `1/c * b`. -/
def Poly.unDiv? : Poly → Option (Poly × ℕ)
  | .mul a b => do let (a, r) ← a.unDiv?; return (.mul' a b, r)
  | .const r => if r.num = 1 ∧ r.den ≠ 1 then some (.const r.num, r.den) else none
  | .neg p => do let (p, r) ← p.unDiv?; return (.neg p, r)
  | _ => none

/-- Constructs a power expression `v_i ^ j`, performing some simplifications in trivial cases. -/
def Poly.pow' : ℕ → ℕ → Poly
  | _, 0 => .const 1
  | i, 1 => .var i
  | i, k => .pow (.var i) (.const k)

/-- Constructs a sum from a monadic function supplying the monomials. -/
def Poly.sumM [Monad m] (a : Array α) (f : α → m Poly) : m Poly :=
  a.foldlM (init := .const 0) fun p a => return p.add' (← f a)

instance : FromJson Poly where
  fromJson? j := do
    Poly.sumM (← j.getArr?) fun j => do
      let mut mon := .const (← fromJson? (← j.getArrVal? 1))
      for j in ← (← j.getArrVal? 0).getArr? do
        mon := mon.mul' (.pow' (← fromJson? (← j.getArrVal? 0)) (← fromJson? (← j.getArrVal? 1)))
      pure mon

/-- The result of a sage call in the success case. -/
structure SageSuccess where
  /-- The script returns a string containing python script to be sent to the remote server,
  when the tracing option is set. -/
  trace : Option String := none
  /-- The main result of the function call is an array of polynomials
  parallel to the input list of hypotheses. -/
  data : Option (Array Poly) := none
  deriving FromJson, Repr

/-- The result of a sage call in the failure case. -/
structure SageError where
  /-- The error kind -/
  name : String
  /-- The error message -/
  value : String
  deriving FromJson

/-- The result of a sage call. -/
def SageResult := Except SageError SageSuccess

instance : FromJson SageResult where fromJson? j := do
  if let .ok true := fromJson? <| j.getObjValD "success" then
    return .ok (← fromJson? j)
  else
    return .error (← fromJson? j)

/--
This tactic calls python from the command line with the args in `arg_list`.
The output printed to the console is parsed as a `Json`.
It assumes that `python3` is available on the path.
-/
def sageOutput (args : Array String) : IO SageResult := do
  let path := (← getMathlibDir) / "scripts" / "polyrith_sage.py"
  unless ← path.pathExists do
    throw <| IO.userError "could not find python script scripts/polyrith_sage.py"
  let s ← IO.Process.run { cmd := "python3", args := #[path.toString] ++ args }
  match Json.parse s >>= fromJson? with
  | .ok v => return v
  | .error e => throw <| .userError e

/--
This is the main body of the `polyrith` tactic. It takes in the following inputs:
* `only : Bool` - This represents whether the user used the key word "only"
* `hyps : Array Expr` - the hypotheses/proof terms selecteed by the user
* `traceOnly : Bool` - If enabled, the returned syntax will be `.missing`

First, the tactic converts the target into a `Poly`, and finds out what type it
is an equality of. (It also fills up a list of `Expr`s with its atoms). Then, it
collects all the relevant hypotheses/proof terms from the context, and from those
selected by the user, taking into account whether `only` is true. (The list of atoms is
updated accordingly as well).

This information is used to create a list of args that get used in a call to
the appropriate python file that executes a grobner basis computation. The
output of this computation is a `String` representing the certificate. This
string is parsed into a list of `Poly` objects that are then converted into
`Expr`s (using the updated list of atoms).

the names of the hypotheses, along with the corresponding coefficients are
given to `linear_combination`. If that tactic succeeds, the user is prompted
to replace the call to `polyrith` with the appropriate call to
`linear_combination`.

This returns `none` if this was a "dry run" attempt that does not actually invoke sage.
-/
def polyrith (g : MVarId) (only : Bool) (hyps : Array Expr)
    (traceOnly := false) : MetaM (Option MVarId × Syntax) := do
  IO.sleep 10 -- otherwise can lead to weird errors when actively editing code with polyrith calls
  g.withContext <| AtomM.run .reducible do
    let (α, hyps', tgt) ← parseContext only hyps (← g.getType)
    let rec
      /-- Try to prove the goal by `ring` and fail with the given message otherwise. -/
      byRing msg := do
        let stx ← `(tactic| ring)
        try
          let ([], _) ← Elab.runTactic g stx | failure
          return (none, stx.raw)
        catch _ => throwError "{msg} and the goal is not provable by ring"
    if hyps'.isEmpty then
      return ← byRing "polyrith did not find any relevant hypotheses"
    let vars := (← get).atoms.size
    if vars = 0 then
      return ← byRing "polyrith did not find find any variables"
    match ← sageOutput (createSageArgs traceOnly α vars hyps' tgt) with
    | .ok { trace, data } =>
      if let some trace := trace then logInfo trace
      if let some polys := data then
        let vars ← liftM <| (← get).atoms.mapM delab
        let p ← Poly.sumM (polys.zip hyps') fun (p, src, _) => do
          let h := .hyp (← delab (match src with | .input i => hyps[i]! | .fvar h => .fvar h))
          pure <| match p.unDiv? with
          | some (p, den) => (p.mul' h).div (.const den)
          | none => p.mul' h
        let stx := (withRef (← getRef) <| p.toSyntax vars).run
        let tac ←
          if let .const 0 := p then `(tactic| linear_combination)
          else `(tactic| linear_combination $stx:term)
        try
          guard (← Elab.runTactic g tac).1.isEmpty
        catch _ => throwError
          "polyrith found the following certificate, but it failed to close the goal:\n{stx}"
        pure (none, tac)
      else if traceOnly then
        return (g, .missing)
      else throwError "internal error: no output available"
    | .error { name, value } =>
      throwError "polyrith failed to retrieve a solution from Sage! {name}: {value}"

/--
Attempts to prove polynomial equality goals through polynomial arithmetic
on the hypotheses (and additional proof terms if the user specifies them).
It proves the goal by generating an appropriate call to the tactic
`linear_combination`. If this call succeeds, the call to `linear_combination`
is suggested to the user.

* `polyrith` will use all relevant hypotheses in the local context.
* `polyrith [t1, t2, t3]` will add proof terms t1, t2, t3 to the local context.
* `polyrith only [h1, h2, h3, t1, t2, t3]` will use only local hypotheses
  `h1`, `h2`, `h3`, and proofs `t1`, `t2`, `t3`. It will ignore the rest of the local context.

Notes:
* This tactic only works with a working internet connection, since it calls Sage
  using the SageCell web API at <https://sagecell.sagemath.org/>.
  Many thanks to the Sage team and organization for allowing this use.
* This tactic assumes that the user has `python3` installed and available on the path.
  (Test by opening a terminal and executing `python3 --version`.)
  It also assumes that the `requests` library is installed: `python3 -m pip install requests`.

Examples:

```lean
example (x y : ℚ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by polyrith
-- Try this: linear_combination h1 - 2 * h2

example (x y z w : ℚ) (hzw : z = w) : x*z + 2*y*z = x*w + 2*y*w :=
by polyrith
-- Try this: linear_combination (2 * y + x) * hzw

constant scary : ∀ a b : ℚ, a + b = 0

example (a b c d : ℚ) (h : a + b = 0) (h2: b + c = 0) : a + b + c + d = 0 :=
by polyrith only [scary c d, h]
-- Try this: linear_combination scary c d + h
```
-/
syntax "polyrith" (&" only")? (" [" term,* "]")? : tactic

open Elab Tactic
elab_rules : tactic
  | `(tactic| polyrith%$tk $[only%$onlyTk]? $[[$hyps,*]]?) => do
    let hyps ← hyps.map (·.getElems) |>.getD #[] |>.mapM (elabTerm · none)
    let traceMe ← Lean.isTracingEnabledFor `Meta.Tactic.polyrith
    let (g, stx) ← polyrith (← getMainGoal) tk.isNone hyps traceMe
    replaceMainGoal g.toList
    if !traceMe then logInfoAt tk m!"Try this: {stx}"


import Mathlib.Init.Function
import SciLean.Tactic.FunctionTransform.Core

postfix:max "⁻¹" => Function.invFun

set_option trace.Meta.Tactic.fun_trans.trans true

example {α β γ : Type} [Nonempty α] [Nonempty β]
  : ∂(λ (x : Nat) => x) = λ x dx => dx :=
by
  fun_trans
  done

example {α β γ : Type} [Nonempty α] [Nonempty β]
  : ∂(λ (x : Nat) (y : Nat) => x) = λ x dx y => dx :=
by
  fun_trans  -- (config := {singlePass := true})
  done

example {α β γ : Type} [Nonempty α] [Nonempty β]
  : ∂(λ (x : Nat) (y z : Nat) => x) = λ x dx y z => dx :=
by
  fun_trans
  done

example {α β γ : Type} (f : β → γ) (g : α → β) [Nonempty α] [Nonempty β]
  : ∂(λ x => f (g x)) = λ x dx => ∂ f (g x) (∂ g x dx) :=
by
  fun_trans
  done

example {α β γ : Type} (f : α → β → γ) (g : α → β)  [Add γ]
  : ∂(λ x => f x (g x))
    =
    λ x dx =>
      ∂ (λ x' => f x' (g x)) x dx
      +
      ∂ (f x) (g x) (∂ g x dx) :=
by
  fun_trans
  done

example {α β γ δ : Type} (f : β → δ → γ) (g : α → β) (d : δ)
  : ∂(λ x => f (g x) d) = λ x dx => ∂ (λ y => f y d) (g x) (∂ g x dx) :=
by
  fun_trans
  done

example (x : Nat)
  : ∂(λ (y : Nat) => x) = λ y dy => 0 :=
by
  fun_trans
  done

example (x : α)
  : ∂ (λ (f : α → β) => f x)
    =
    λ f df => df x :=
by
  fun_trans
  done

example
  : ∂ (λ (f : α → β) x => f x)
    =
    λ f df x => df x :=
by
  fun_trans
  done

-- set_option trace.Meta.Tactic.fun_trans.step true in
example (x : α) (y : β)
  : ∂ (λ (f : α → β → γ) => f x y)
    =
    λ f df => df x y :=
by
  fun_trans
  done

example c
  : ∂ (λ (f : α → β → γ → δ) y x => f x y c)
    =
    λ f df y x => df x y c :=
by
  fun_trans
  done

-- set_option trace.Meta.Tactic.fun_trans.step true in
example (f : α → β → γ)
  : ∂ (λ y => sum (λ x => f x y))
    =
    λ y dy => sum λ x => ∂ (f x) y dy :=
by
  fun_trans
  done

-- set_option trace.Meta.Tactic.fun_trans.step true in
example (f : α → β → γ)
  : ∂ (λ y => (sum f) y)
    =
    λ y dy => sum λ x => ∂ (f x) y dy :=
by
  fun_trans
  fun_trans
  done

example {α β₁ β₂ γ : Type} (f : β₁ → β₂ → γ) (g₁ : α → β₁) (g₂ : α → β₂) [Add γ]
  : ∂ (λ x => f (g₁ x) (g₂ x))
    =
    λ x dx =>
      ∂ (λ x' => f x' (g₂ x)) (g₁ x) (∂ g₁ x dx)
      +
      ∂ (f (g₁ x)) (g₂ x) (∂ g₂ x dx) :=
by
  fun_trans
  done

example (f : β → γ) (g : α → β)
  : (λ x => f (g x))†
    =
    λ z => g† (f† z) :=
by
  fun_trans
  done

example {α β₁ β₂ γ : Type} [Add α] (f : β₁ → β₂ → γ) (g₁ : α → β₁) (g₂ : α → β₂)
  : (λ x => f (g₁ x) (g₂ x))†
    =
    λ z =>
      let (b₁,b₂) := (uncurry f)† z
      g₁† b₁ + g₂† b₂ :=
by
  fun_trans
  done

example {α β : Type} [Add α] [Add β] (g₁ : α → β) (g₂ : α → β)
  : (λ x => (g₁ x) + (g₂ x))†
    =
    λ z => g₁† z + g₂† z :=
by
  fun_trans
  done

example {α β₁ β₂ β₃ γ : Type} [Add α] (f : β₁ → β₂ → β₃ → γ) (g₁ : α → β₁) (g₂ : α → β₂) (g₃ : α → β₃)
  : (λ x => f (g₁ x) (g₂ x) (g₃ x))†
    =
    λ z =>
      let (b₁,b₂,b₃) := (uncurry3 f)† z
      g₁† b₁ + (g₂† b₂ + g₃† b₃) :=
by
  fun_trans
  done

example {α β₁ β₂ γ : Type} [Add α] [Add (α×β₁)] [Add ((α×β₂)×β₂)] (f : β₁ → β₂ → β₃ → γ) (g₁ : α → β₁) (g₂ : α → β₂) (g₃ : α → β₃)
 : (λ x => (λ (b₁,b₂,b₃) => f b₁ b₂ b₃) (g₁ x, g₂ x, g₃ x))
   =
   λ x => f  (g₁ x) (g₂ x) (g₃ x) :=
by
  rfl

@[simp ↓ high]
theorem Prod.fst.diff
  : ∂ (λ x : α × β => x.1) = λ x dx => dx.1 := sorry

@[simp ↓ high]
theorem Prod.snd.diff
  : ∂ (λ x : α × β => x.2) = λ x dx => dx.2 := sorry

@[simp ↓ high]
theorem Prod.fst.adj [OfNat β 0]
  : (λ x : α × β => x.1)† = λ x => (x,0) := sorry

@[simp ↓ high]
theorem Prod.snd.adj [OfNat α 0]
  : (λ x : α × β => x.2)† = λ x => (0,x) := sorry

@[simp]
theorem add_diff [Add α]
  : ∂ (uncurry λ x y : α => x + y) = λ (x,y) (dx,dy) => dx + dy := sorry

example (f : α → α) [Add α] [OfNat α 0]
  : ∂ (λ x =>
         let y := f x
         let z := f y
         y + z + f z)
    =
    sorry
  :=
by
  fun_trans
  fun_trans
  simp (config := {zeta := false}) []
  done

@[simp ↓]
theorem hoho (f : β → γ) (z : γ)
  : ((fun x : β × α => f x.fst)† z).fst
    =
    f† z
  := sorry

@[simp ↓]
theorem hoho' (f : β → γ) (z : γ) [OfNat α 0]
  : ((fun x : β × α => f x.fst)† z).snd
    =
    0
  := sorry

set_option trace.Meta.Tactic.simp.discharge true in
example {α : Type} (f g h : α → α) [Add α] [Add (α×α)] [OfNat α 0] [OfNat (α×α) 0]
  : (λ x =>
         let y := f x
         let z := g y
         let z' := g z
         h z')†
    =
    sorry
  :=
by
  fun_trans
  -- fun_trans
  -- simp (config := {zeta := false}) []
  -- fun_trans
  -- simp (config := {zeta := false}) []
  -- simp
  done

set_option trace.Meta.Tactic.fun_trans.step true in
set_option trace.Meta.Tactic.simp.rewrite true in
-- set_option pp.all true in
example {α β γ : Type}
  : ∂ (λ (x : α × β × γ) =>
         x.snd.fst)
    =
    sorry
  :=
by
  fun_trans
  done

example
  : ∂ (Prod.snd : α × (β × γ) → β × γ)
  =
    fun x dx => sorry
        -- ((∂fun x => x.snd.fst) x dx, (∂fun x => x.snd.snd) x dx)
  :=
by
  simp

set_option trace.Meta.Tactic.simp.discharge true in
example (A : Fin n → Fin m → Nat)
  : (λ x : Fin m → Nat => λ i => sum λ j => A i j * x j)†
    =
    (λ y => λ i => sum λ j => A j i * y j)
  :=
by
  fun_trans
  fun_trans

  done


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import number_theory.class_number.admissible_absolute_value
import analysis.special_functions.pow
import ring_theory.ideal.local_ring
import data.polynomial.degree.card_pow_degree

/-!
# Admissible absolute values on polynomials
This file defines an admissible absolute value
`polynomial.card_pow_degree_is_admissible` which we use to show the class number
of the ring of integers of a function field is finite.

## Main results

* `polynomial.card_pow_degree_is_admissible` shows `card_pow_degree`,
  mapping `p : polynomial 𝔽_q` to `q ^ degree p`, is admissible
-/

namespace polynomial
open_locale polynomial
open absolute_value real

variables {Fq : Type*} [field Fq] [fintype Fq]

/-- If `A` is a family of enough low-degree polynomials over a finite field, there is a
pair of equal elements in `A`. -/
lemma exists_eq_polynomial {d : ℕ} {m : ℕ} (hm : fintype.card Fq ^ d ≤ m) (b : Fq[X])
  (hb : nat_degree b ≤ d) (A : fin m.succ → Fq[X]) (hA : ∀ i, degree (A i) < degree b) :
  ∃ i₀ i₁, i₀ ≠ i₁ ∧ A i₁ = A i₀ :=
begin
  -- Since there are > q^d elements of A, and only q^d choices for the highest `d` coefficients,
  -- there must be two elements of A with the same coefficients at
  -- `0`, ... `degree b - 1` ≤ `d - 1`.
  -- In other words, the following map is not injective:
  set f : fin m.succ → (fin d → Fq) := λ i j, (A i).coeff j,
  have : fintype.card (fin d → Fq) < fintype.card (fin m.succ),
  { simpa using lt_of_le_of_lt hm (nat.lt_succ_self m) },
  -- Therefore, the differences have all coefficients higher than `deg b - d` equal.
  obtain ⟨i₀, i₁, i_ne, i_eq⟩ := fintype.exists_ne_map_eq_of_card_lt f this,
  use [i₀, i₁, i_ne],
  ext j,
  -- The coefficients higher than `deg b` are the same because they are equal to 0.
  by_cases hbj : degree b ≤ j,
  { rw [coeff_eq_zero_of_degree_lt (lt_of_lt_of_le (hA _) hbj),
        coeff_eq_zero_of_degree_lt (lt_of_lt_of_le (hA _) hbj)] },
  -- So we only need to look for the coefficients between `0` and `deg b`.
  rw not_le at hbj,
  apply congr_fun i_eq.symm ⟨j, _⟩,
  exact lt_of_lt_of_le (coe_lt_degree.mp hbj) hb
end

/-- If `A` is a family of enough low-degree polynomials over a finite field,
there is a pair of elements in `A` (with different indices but not necessarily
distinct), such that their difference has small degree. -/
lemma exists_approx_polynomial_aux {d : ℕ} {m : ℕ} (hm : fintype.card Fq ^ d ≤ m)
  (b : Fq[X]) (A : fin m.succ → Fq[X]) (hA : ∀ i, degree (A i) < degree b) :
  ∃ i₀ i₁, i₀ ≠ i₁ ∧ degree (A i₁ - A i₀) < ↑(nat_degree b - d) :=
begin
  have hb : b ≠ 0,
  { rintro rfl,
    specialize hA 0,
    rw degree_zero at hA,
    exact not_lt_of_le bot_le hA },
  -- Since there are > q^d elements of A, and only q^d choices for the highest `d` coefficients,
  -- there must be two elements of A with the same coefficients at
  -- `degree b - 1`, ... `degree b - d`.
  -- In other words, the following map is not injective:
  set f : fin m.succ → (fin d → Fq) := λ i j, (A i).coeff (nat_degree b - j.succ),
  have : fintype.card (fin d → Fq) < fintype.card (fin m.succ),
  { simpa using lt_of_le_of_lt hm (nat.lt_succ_self m) },
  -- Therefore, the differences have all coefficients higher than `deg b - d` equal.
  obtain ⟨i₀, i₁, i_ne, i_eq⟩ := fintype.exists_ne_map_eq_of_card_lt f this,
  use [i₀, i₁, i_ne],
  refine (degree_lt_iff_coeff_zero _ _).mpr (λ j hj, _),
  -- The coefficients higher than `deg b` are the same because they are equal to 0.
  by_cases hbj : degree b ≤ j,
  { refine coeff_eq_zero_of_degree_lt (lt_of_lt_of_le _ hbj),
    exact lt_of_le_of_lt (degree_sub_le _ _) (max_lt (hA _) (hA _)) },
  -- So we only need to look for the coefficients between `deg b - d` and `deg b`.
  rw [coeff_sub, sub_eq_zero],
  rw [not_le, degree_eq_nat_degree hb, with_bot.coe_lt_coe] at hbj,
  have hj : nat_degree b - j.succ < d,
  { by_cases hd : nat_degree b < d,
    { exact lt_of_le_of_lt tsub_le_self hd },
    { rw not_lt at hd,
      have := lt_of_le_of_lt hj (nat.lt_succ_self j),
      rwa [tsub_lt_iff_tsub_lt hd hbj] at this } },
  have : j = b.nat_degree - (nat_degree b - j.succ).succ,
  { rw [← nat.succ_sub hbj, nat.succ_sub_succ, tsub_tsub_cancel_of_le hbj.le] },
  convert congr_fun i_eq.symm ⟨nat_degree b - j.succ, hj⟩
end

/-- If `A` is a family of enough low-degree polynomials over a finite field,
there is a pair of elements in `A` (with different indices but not necessarily
distinct), such that the difference of their remainders is close together. -/
lemma exists_approx_polynomial {b : Fq[X]} (hb : b ≠ 0)
  {ε : ℝ} (hε : 0 < ε)
  (A : fin (fintype.card Fq ^ ⌈- log ε / log (fintype.card Fq)⌉₊).succ → Fq[X]) :
  ∃ i₀ i₁, i₀ ≠ i₁ ∧ (card_pow_degree (A i₁ % b - A i₀ % b) : ℝ) < card_pow_degree b • ε :=
begin
  have hbε : 0 < card_pow_degree b • ε,
  { rw [algebra.smul_def, ring_hom.eq_int_cast],
    exact mul_pos (int.cast_pos.mpr (absolute_value.pos _ hb)) hε },
  have one_lt_q : 1 < fintype.card Fq := fintype.one_lt_card,
  have one_lt_q' : (1 : ℝ) < fintype.card Fq, { assumption_mod_cast },
  have q_pos : 0 < fintype.card Fq, { linarith },
  have q_pos' : (0 : ℝ) < fintype.card Fq, { assumption_mod_cast },
  -- If `b` is already small enough, then the remainders are equal and we are done.
  by_cases le_b : b.nat_degree ≤ ⌈- log ε / log (fintype.card Fq)⌉₊,
  { obtain ⟨i₀, i₁, i_ne, mod_eq⟩ := exists_eq_polynomial le_rfl b le_b (λ i, A i % b)
      (λ i, euclidean_domain.mod_lt (A i) hb),
    refine ⟨i₀, i₁, i_ne, _⟩,
    simp only at mod_eq,
    rwa [mod_eq, sub_self, absolute_value.map_zero, int.cast_zero] },
  -- Otherwise, it suffices to choose two elements whose difference is of small enough degree.
  rw not_le at le_b,
  obtain ⟨i₀, i₁, i_ne, deg_lt⟩ := exists_approx_polynomial_aux le_rfl b (λ i, A i % b)
    (λ i, euclidean_domain.mod_lt (A i) hb),
  simp only at deg_lt,
  use [i₀, i₁, i_ne],
  -- Again, if the remainders are equal we are done.
  by_cases h : A i₁ % b = A i₀ % b,
  { rwa [h, sub_self, absolute_value.map_zero, int.cast_zero] },
  have h' : A i₁ % b - A i₀ % b ≠ 0 := mt sub_eq_zero.mp h,
  -- If the remainders are not equal, we'll show their difference is of small degree.
  -- In particular, we'll show the degree is less than the following:
  suffices : (nat_degree (A i₁ % b - A i₀ % b) : ℝ) <
    b.nat_degree + log ε / log (fintype.card Fq),
  { rwa [← real.log_lt_log_iff (int.cast_pos.mpr (card_pow_degree.pos h')) hbε,
        card_pow_degree_nonzero _ h', card_pow_degree_nonzero _ hb,
        algebra.smul_def, ring_hom.eq_int_cast,
        int.cast_pow, int.cast_coe_nat, int.cast_pow, int.cast_coe_nat,
        log_mul (pow_ne_zero _ q_pos'.ne') hε.ne',
        ← rpow_nat_cast, ← rpow_nat_cast, log_rpow q_pos', log_rpow q_pos',
        ← lt_div_iff (log_pos one_lt_q'), add_div, mul_div_cancel _ (log_pos one_lt_q').ne'] },
  -- And that result follows from manipulating the result from `exists_approx_polynomial_aux`
  -- to turn the `-⌈-stuff⌉₊` into `+ stuff`.
  refine lt_of_lt_of_le (nat.cast_lt.mpr (with_bot.coe_lt_coe.mp _)) _,
  swap, { convert deg_lt, rw degree_eq_nat_degree h' },
  rw [← sub_neg_eq_add, neg_div],
  refine le_trans _ (sub_le_sub_left (nat.le_ceil _) (b.nat_degree : ℝ)),
  rw ← neg_div,
  exact le_of_eq (nat.cast_sub le_b.le)
end

/-- If `x` is close to `y` and `y` is close to `z`, then `x` and `z` are at least as close. -/
lemma card_pow_degree_anti_archimedean {x y z : Fq[X]} {a : ℤ}
  (hxy : card_pow_degree (x - y) < a) (hyz : card_pow_degree (y - z) < a) :
  card_pow_degree (x - z) < a :=
begin
  have ha : 0 < a := lt_of_le_of_lt (absolute_value.nonneg _ _) hxy,
  by_cases hxy' : x = y,
  { rwa hxy' },
  by_cases hyz' : y = z,
  { rwa ← hyz' },
  by_cases hxz' : x = z,
  { rwa [hxz', sub_self, absolute_value.map_zero] },
  rw [← ne.def, ← sub_ne_zero] at hxy' hyz' hxz',
  refine lt_of_le_of_lt _ (max_lt hxy hyz),
  rw [card_pow_degree_nonzero _ hxz', card_pow_degree_nonzero _ hxy',
      card_pow_degree_nonzero _ hyz'],
  have : (1 : ℤ) ≤ fintype.card Fq, { exact_mod_cast (@fintype.one_lt_card Fq _ _).le },
  simp only [int.cast_pow, int.cast_coe_nat, le_max_iff],
  refine or.imp (pow_le_pow this) (pow_le_pow this) _,
  rw [nat_degree_le_iff_degree_le, nat_degree_le_iff_degree_le, ← le_max_iff,
      ← degree_eq_nat_degree hxy', ← degree_eq_nat_degree hyz'],
  convert degree_add_le (x - y) (y - z) using 2,
  exact (sub_add_sub_cancel _ _ _).symm
end

/-- A slightly stronger version of `exists_partition` on which we perform induction on `n`:
for all `ε > 0`, we can partition the remainders of any family of polynomials `A`
into equivalence classes, where the equivalence(!) relation is "closer than `ε`". -/
lemma exists_partition_polynomial_aux (n : ℕ) {ε : ℝ} (hε : 0 < ε)
  {b : Fq[X]} (hb : b ≠ 0) (A : fin n → Fq[X]) :
  ∃ (t : fin n → fin (fintype.card Fq ^ ⌈- log ε / log (fintype.card Fq)⌉₊)),
  ∀ (i₀ i₁ : fin n),
  t i₀ = t i₁ ↔ (card_pow_degree (A i₁ % b - A i₀ % b) : ℝ) < card_pow_degree b • ε :=
begin
  have hbε : 0 < card_pow_degree b • ε,
  { rw [algebra.smul_def, ring_hom.eq_int_cast],
    exact mul_pos (int.cast_pos.mpr (absolute_value.pos _ hb)) hε },
  -- We go by induction on the size `A`.
  induction n with n ih,
  { refine ⟨fin_zero_elim, fin_zero_elim⟩ },

  -- Show `anti_archimedean` also holds for real distances.
  have anti_archim' : ∀ {i j k} {ε : ℝ}, (card_pow_degree (A i % b - A j % b) : ℝ) < ε →
    (card_pow_degree (A j % b - A k % b) : ℝ) < ε → (card_pow_degree (A i % b - A k % b) : ℝ) < ε,
  { intros i j k ε,
    simp_rw [← int.lt_ceil],
    exact card_pow_degree_anti_archimedean },

  obtain ⟨t', ht'⟩ := ih (fin.tail A),
  -- We got rid of `A 0`, so determine the index `j` of the partition we'll re-add it to.
  suffices : ∃ j,
    ∀ i, t' i = j ↔ (card_pow_degree (A 0 % b - A i.succ % b) : ℝ) < card_pow_degree b • ε,
  { obtain ⟨j, hj⟩ := this,
    refine ⟨fin.cons j t', λ i₀ i₁, _⟩,
    refine fin.cases _ (λ i₀, _) i₀; refine fin.cases _ (λ i₁, _) i₁,
    { simpa using hbε },
    { rw [fin.cons_succ, fin.cons_zero, eq_comm, absolute_value.map_sub],
      exact hj i₁ },
    { rw [fin.cons_succ, fin.cons_zero],
      exact hj i₀ },
    { rw [fin.cons_succ, fin.cons_succ],
      exact ht' i₀ i₁ } },
  -- `exists_approx_polynomial` guarantees that we can insert `A 0` into some partition `j`,
  -- but not that `j` is uniquely defined (which is needed to keep the induction going).
  obtain ⟨j, hj⟩ : ∃ j, ∀ (i : fin n), t' i = j →
    (card_pow_degree (A 0 % b - A i.succ % b) : ℝ) < card_pow_degree b • ε,
  { by_contra this, push_neg at this,
    obtain ⟨j₀, j₁, j_ne, approx⟩ := exists_approx_polynomial hb hε
      (fin.cons (A 0) (λ j, A (fin.succ (classical.some (this j))))),
    revert j_ne approx,
    refine fin.cases _ (λ j₀, _) j₀; refine fin.cases (λ j_ne approx, _) (λ j₁ j_ne approx, _) j₁,
    { exact absurd rfl j_ne },
    { rw [fin.cons_succ, fin.cons_zero, ← not_le, absolute_value.map_sub] at approx,
      have := (classical.some_spec (this j₁)).2,
      contradiction },
    { rw [fin.cons_succ, fin.cons_zero, ← not_le] at approx,
      have := (classical.some_spec (this j₀)).2,
      contradiction },
    { rw [fin.cons_succ, fin.cons_succ] at approx,
      rw [ne.def, fin.succ_inj] at j_ne,
      have : j₀ = j₁ :=
        (classical.some_spec (this j₀)).1.symm.trans
        (((ht' (classical.some (this j₀)) (classical.some (this j₁))).mpr approx).trans
        (classical.some_spec (this j₁)).1),
      contradiction } },
  -- However, if one of those partitions `j` is inhabited by some `i`, then this `j` works.
  by_cases exists_nonempty_j : ∃ j, (∃ i, t' i = j) ∧
    ∀ i, t' i = j → (card_pow_degree (A 0 % b - A i.succ % b) : ℝ) < card_pow_degree b • ε,
  { obtain ⟨j, ⟨i, hi⟩, hj⟩ := exists_nonempty_j,
    refine ⟨j, λ i', ⟨hj i', λ hi', trans ((ht' _ _).mpr _) hi⟩⟩,
    apply anti_archim' _ hi',
    rw absolute_value.map_sub,
    exact hj _ hi },
  -- And otherwise, we can just take any `j`, since those are empty.
  refine ⟨j, λ i, ⟨hj i, λ hi, _⟩⟩,
  have := exists_nonempty_j ⟨t' i, ⟨i, rfl⟩, λ i' hi', anti_archim' hi ((ht' _ _).mp hi')⟩,
  contradiction
end

/-- For all `ε > 0`, we can partition the remainders of any family of polynomials `A`
into classes, where all remainders in a class are close together. -/
lemma exists_partition_polynomial (n : ℕ) {ε : ℝ} (hε : 0 < ε)
  {b : Fq[X]} (hb : b ≠ 0) (A : fin n → Fq[X]) :
  ∃ (t : fin n → fin (fintype.card Fq ^ ⌈- log ε / log (fintype.card Fq)⌉₊)),
    ∀ (i₀ i₁ : fin n), t i₀ = t i₁ →
      (card_pow_degree (A i₁ % b - A i₀ % b) : ℝ) < card_pow_degree b • ε :=
begin
  obtain ⟨t, ht⟩ := exists_partition_polynomial_aux n hε hb A,
  exact ⟨t, λ i₀ i₁ hi, (ht i₀ i₁).mp hi⟩
end

/-- `λ p, fintype.card Fq ^ degree p` is an admissible absolute value.
We set `q ^ degree 0 = 0`. -/
noncomputable def card_pow_degree_is_admissible :
  is_admissible (card_pow_degree : absolute_value Fq[X] ℤ) :=
{ card := λ ε, fintype.card Fq ^ ⌈- log ε / log (fintype.card Fq)⌉₊,
  exists_partition' := λ n ε hε b hb, exists_partition_polynomial n hε hb,
  .. @card_pow_degree_is_euclidean Fq _ _ }

end polynomial


/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth, Frédéric Dupuis

! This file was ported from Lean 3 source module analysis.inner_product_space.rayleigh
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.Calculus
import Mathbin.Analysis.InnerProductSpace.Dual
import Mathbin.Analysis.InnerProductSpace.Adjoint
import Mathbin.Analysis.Calculus.LagrangeMultipliers
import Mathbin.LinearAlgebra.Eigenspace

/-!
# The Rayleigh quotient

The Rayleigh quotient of a self-adjoint operator `T` on an inner product space `E` is the function
`λ x, ⟪T x, x⟫ / ‖x‖ ^ 2`.

The main results of this file are `is_self_adjoint.has_eigenvector_of_is_max_on` and
`is_self_adjoint.has_eigenvector_of_is_min_on`, which state that if `E` is complete, and if the
Rayleigh quotient attains its global maximum/minimum over some sphere at the point `x₀`, then `x₀`
is an eigenvector of `T`, and the `supr`/`infi` of `λ x, ⟪T x, x⟫ / ‖x‖ ^ 2` is the corresponding
eigenvalue.

The corollaries `is_self_adjoint.has_eigenvalue_supr_of_finite_dimensional` and
`is_self_adjoint.has_eigenvalue_supr_of_finite_dimensional` state that if `E` is finite-dimensional
and nontrivial, then `T` has some (nonzero) eigenvectors with eigenvalue the `supr`/`infi` of
`λ x, ⟪T x, x⟫ / ‖x‖ ^ 2`.

## TODO

A slightly more elaborate corollary is that if `E` is complete and `T` is a compact operator, then
`T` has some (nonzero) eigenvector with eigenvalue either `⨆ x, ⟪T x, x⟫ / ‖x‖ ^ 2` or
`⨅ x, ⟪T x, x⟫ / ‖x‖ ^ 2` (not necessarily both).

-/

variable {𝕜 : Type _} [IsROrC 𝕜]

variable {E : Type _} [NormedAddCommGroup E] [InnerProductSpace 𝕜 E]

-- mathport name: «expr⟪ , ⟫»
local notation "⟪" x ", " y "⟫" => @inner 𝕜 _ _ x y

open NNReal

open Module.End Metric

namespace ContinuousLinearMap

variable (T : E →L[𝕜] E)

-- mathport name: exprrayleigh_quotient
local notation "rayleigh_quotient" => fun x : E => T.reApplyInnerSelf x / ‖(x : E)‖ ^ 2

theorem rayleigh_smul (x : E) {c : 𝕜} (hc : c ≠ 0) :
    rayleigh_quotient (c • x) = rayleigh_quotient x :=
  by
  by_cases hx : x = 0
  · simp [hx]
  have : ‖c‖ ≠ 0 := by simp [hc]
  have : ‖x‖ ≠ 0 := by simp [hx]
  field_simp [norm_smul, T.re_apply_inner_self_smul]
  ring
#align continuous_linear_map.rayleigh_smul ContinuousLinearMap.rayleigh_smul

theorem image_rayleigh_eq_image_rayleigh_sphere {r : ℝ} (hr : 0 < r) :
    rayleigh_quotient '' {0}ᶜ = rayleigh_quotient '' sphere 0 r :=
  by
  ext a
  constructor
  · rintro ⟨x, hx : x ≠ 0, hxT⟩
    have : ‖x‖ ≠ 0 := by simp [hx]
    let c : 𝕜 := ↑‖x‖⁻¹ * r
    have : c ≠ 0 := by simp [c, hx, hr.ne']
    refine' ⟨c • x, _, _⟩
    · field_simp [norm_smul, IsROrC.norm_eq_abs, abs_of_nonneg hr.le]
    · rw [T.rayleigh_smul x this]
      exact hxT
  · rintro ⟨x, hx, hxT⟩
    exact ⟨x, ne_zero_of_mem_sphere hr.ne' ⟨x, hx⟩, hxT⟩
#align continuous_linear_map.image_rayleigh_eq_image_rayleigh_sphere ContinuousLinearMap.image_rayleigh_eq_image_rayleigh_sphere

theorem supᵢ_rayleigh_eq_supᵢ_rayleigh_sphere {r : ℝ} (hr : 0 < r) :
    (⨆ x : { x : E // x ≠ 0 }, rayleigh_quotient x) = ⨆ x : sphere (0 : E) r, rayleigh_quotient x :=
  show (⨆ x : ({0} : Set E)ᶜ, rayleigh_quotient x) = _ by
    simp only [← @supₛ_image' _ _ _ _ rayleigh_quotient,
      T.image_rayleigh_eq_image_rayleigh_sphere hr]
#align continuous_linear_map.supr_rayleigh_eq_supr_rayleigh_sphere ContinuousLinearMap.supᵢ_rayleigh_eq_supᵢ_rayleigh_sphere

theorem infᵢ_rayleigh_eq_infᵢ_rayleigh_sphere {r : ℝ} (hr : 0 < r) :
    (⨅ x : { x : E // x ≠ 0 }, rayleigh_quotient x) = ⨅ x : sphere (0 : E) r, rayleigh_quotient x :=
  show (⨅ x : ({0} : Set E)ᶜ, rayleigh_quotient x) = _ by
    simp only [← @infₛ_image' _ _ _ _ rayleigh_quotient,
      T.image_rayleigh_eq_image_rayleigh_sphere hr]
#align continuous_linear_map.infi_rayleigh_eq_infi_rayleigh_sphere ContinuousLinearMap.infᵢ_rayleigh_eq_infᵢ_rayleigh_sphere

end ContinuousLinearMap

namespace IsSelfAdjoint

section Real

variable {F : Type _} [NormedAddCommGroup F] [InnerProductSpace ℝ F]

theorem LinearMap.IsSymmetric.hasStrictFderivAt_reApplyInnerSelf {T : F →L[ℝ] F}
    (hT : (T : F →ₗ[ℝ] F).IsSymmetric) (x₀ : F) :
    HasStrictFderivAt T.reApplyInnerSelf (bit0 (innerSL ℝ (T x₀))) x₀ :=
  by
  convert T.has_strict_fderiv_at.inner _ (hasStrictFderivAt_id x₀)
  ext y
  simp_rw [_root_.bit0, ContinuousLinearMap.comp_apply, ContinuousLinearMap.add_apply,
    innerSL_apply, fderivInnerClm_apply, id.def, ContinuousLinearMap.prod_apply,
    ContinuousLinearMap.id_apply, hT.apply_clm x₀ y, real_inner_comm _ x₀]
#align linear_map.is_symmetric.has_strict_fderiv_at_re_apply_inner_self LinearMap.IsSymmetric.hasStrictFderivAt_reApplyInnerSelf

variable [CompleteSpace F] {T : F →L[ℝ] F}

-- mathport name: exprrayleigh_quotient
local notation "rayleigh_quotient" => fun x : F => T.reApplyInnerSelf x / ‖(x : F)‖ ^ 2

theorem linearly_dependent_of_isLocalExtrOn (hT : IsSelfAdjoint T) {x₀ : F}
    (hextr : IsLocalExtrOn T.reApplyInnerSelf (sphere (0 : F) ‖x₀‖) x₀) :
    ∃ a b : ℝ, (a, b) ≠ 0 ∧ a • x₀ + b • T x₀ = 0 :=
  by
  have H : IsLocalExtrOn T.re_apply_inner_self { x : F | ‖x‖ ^ 2 = ‖x₀‖ ^ 2 } x₀ :=
    by
    convert hextr
    ext x
    simp [dist_eq_norm]
  -- find Lagrange multipliers for the function `T.re_apply_inner_self` and the
  -- hypersurface-defining function `λ x, ‖x‖ ^ 2`
  obtain ⟨a, b, h₁, h₂⟩ :=
    IsLocalExtrOn.exists_multipliers_of_hasStrictFderivAt_1d H (hasStrictFderivAt_norm_sq x₀)
      (hT.is_symmetric.has_strict_fderiv_at_re_apply_inner_self x₀)
  refine' ⟨a, b, h₁, _⟩
  apply (InnerProductSpace.toDualMap ℝ F).Injective
  simp only [LinearIsometry.map_add, LinearIsometry.map_smul, LinearIsometry.map_zero]
  change a • innerSL _ x₀ + b • innerSL _ (T x₀) = 0
  apply smul_right_injective (F →L[ℝ] ℝ) (two_ne_zero : (2 : ℝ) ≠ 0)
  simpa only [_root_.bit0, add_smul, smul_add, one_smul, add_zero] using h₂
#align is_self_adjoint.linearly_dependent_of_is_local_extr_on IsSelfAdjoint.linearly_dependent_of_isLocalExtrOn

theorem eq_smul_self_of_isLocalExtrOn_real (hT : IsSelfAdjoint T) {x₀ : F}
    (hextr : IsLocalExtrOn T.reApplyInnerSelf (sphere (0 : F) ‖x₀‖) x₀) :
    T x₀ = rayleigh_quotient x₀ • x₀ :=
  by
  obtain ⟨a, b, h₁, h₂⟩ := hT.linearly_dependent_of_is_local_extr_on hextr
  by_cases hx₀ : x₀ = 0
  · simp [hx₀]
  by_cases hb : b = 0
  · have : a ≠ 0 := by simpa [hb] using h₁
    refine' absurd _ hx₀
    apply smul_right_injective F this
    simpa [hb] using h₂
  let c : ℝ := -b⁻¹ * a
  have hc : T x₀ = c • x₀ :=
    by
    have : b * (b⁻¹ * a) = a := by field_simp [mul_comm]
    apply smul_right_injective F hb
    simp [c, eq_neg_of_add_eq_zero_left h₂, ← mul_smul, this]
  convert hc
  have : ‖x₀‖ ≠ 0 := by simp [hx₀]
  field_simp
  simpa [inner_smul_left, real_inner_self_eq_norm_mul_norm, sq] using
    congr_arg (fun x => ⟪x, x₀⟫_ℝ) hc
#align is_self_adjoint.eq_smul_self_of_is_local_extr_on_real IsSelfAdjoint.eq_smul_self_of_isLocalExtrOn_real

end Real

section CompleteSpace

variable [CompleteSpace E] {T : E →L[𝕜] E}

-- mathport name: exprrayleigh_quotient
local notation "rayleigh_quotient" => fun x : E => T.reApplyInnerSelf x / ‖(x : E)‖ ^ 2

theorem eq_smul_self_of_isLocalExtrOn (hT : IsSelfAdjoint T) {x₀ : E}
    (hextr : IsLocalExtrOn T.reApplyInnerSelf (sphere (0 : E) ‖x₀‖) x₀) :
    T x₀ = (↑(rayleigh_quotient x₀) : 𝕜) • x₀ :=
  by
  letI := InnerProductSpace.isROrCToReal 𝕜 E
  let hSA := hT.is_symmetric.restrict_scalars.to_self_adjoint.prop
  exact hSA.eq_smul_self_of_is_local_extr_on_real hextr
#align is_self_adjoint.eq_smul_self_of_is_local_extr_on IsSelfAdjoint.eq_smul_self_of_isLocalExtrOn

/-- For a self-adjoint operator `T`, a local extremum of the Rayleigh quotient of `T` on a sphere
centred at the origin is an eigenvector of `T`. -/
theorem hasEigenvector_of_isLocalExtrOn (hT : IsSelfAdjoint T) {x₀ : E} (hx₀ : x₀ ≠ 0)
    (hextr : IsLocalExtrOn T.reApplyInnerSelf (sphere (0 : E) ‖x₀‖) x₀) :
    HasEigenvector (T : E →ₗ[𝕜] E) (↑(rayleigh_quotient x₀)) x₀ :=
  by
  refine' ⟨_, hx₀⟩
  rw [Module.End.mem_eigenspace_iff]
  exact hT.eq_smul_self_of_is_local_extr_on hextr
#align is_self_adjoint.has_eigenvector_of_is_local_extr_on IsSelfAdjoint.hasEigenvector_of_isLocalExtrOn

/-- For a self-adjoint operator `T`, a maximum of the Rayleigh quotient of `T` on a sphere centred
at the origin is an eigenvector of `T`, with eigenvalue the global supremum of the Rayleigh
quotient. -/
theorem hasEigenvector_of_isMaxOn (hT : IsSelfAdjoint T) {x₀ : E} (hx₀ : x₀ ≠ 0)
    (hextr : IsMaxOn T.reApplyInnerSelf (sphere (0 : E) ‖x₀‖) x₀) :
    HasEigenvector (T : E →ₗ[𝕜] E) (↑(⨆ x : { x : E // x ≠ 0 }, rayleigh_quotient x)) x₀ :=
  by
  convert hT.has_eigenvector_of_is_local_extr_on hx₀ (Or.inr hextr.localize)
  have hx₀' : 0 < ‖x₀‖ := by simp [hx₀]
  have hx₀'' : x₀ ∈ sphere (0 : E) ‖x₀‖ := by simp
  rw [T.supr_rayleigh_eq_supr_rayleigh_sphere hx₀']
  refine' IsMaxOn.supᵢ_eq hx₀'' _
  intro x hx
  dsimp
  have : ‖x‖ = ‖x₀‖ := by simpa using hx
  rw [this]
  exact div_le_div_of_le (sq_nonneg ‖x₀‖) (hextr hx)
#align is_self_adjoint.has_eigenvector_of_is_max_on IsSelfAdjoint.hasEigenvector_of_isMaxOn

/-- For a self-adjoint operator `T`, a minimum of the Rayleigh quotient of `T` on a sphere centred
at the origin is an eigenvector of `T`, with eigenvalue the global infimum of the Rayleigh
quotient. -/
theorem hasEigenvector_of_isMinOn (hT : IsSelfAdjoint T) {x₀ : E} (hx₀ : x₀ ≠ 0)
    (hextr : IsMinOn T.reApplyInnerSelf (sphere (0 : E) ‖x₀‖) x₀) :
    HasEigenvector (T : E →ₗ[𝕜] E) (↑(⨅ x : { x : E // x ≠ 0 }, rayleigh_quotient x)) x₀ :=
  by
  convert hT.has_eigenvector_of_is_local_extr_on hx₀ (Or.inl hextr.localize)
  have hx₀' : 0 < ‖x₀‖ := by simp [hx₀]
  have hx₀'' : x₀ ∈ sphere (0 : E) ‖x₀‖ := by simp
  rw [T.infi_rayleigh_eq_infi_rayleigh_sphere hx₀']
  refine' IsMinOn.infᵢ_eq hx₀'' _
  intro x hx
  dsimp
  have : ‖x‖ = ‖x₀‖ := by simpa using hx
  rw [this]
  exact div_le_div_of_le (sq_nonneg ‖x₀‖) (hextr hx)
#align is_self_adjoint.has_eigenvector_of_is_min_on IsSelfAdjoint.hasEigenvector_of_isMinOn

end CompleteSpace

end IsSelfAdjoint

section FiniteDimensional

variable [FiniteDimensional 𝕜 E] [_i : Nontrivial E] {T : E →ₗ[𝕜] E}

namespace LinearMap

namespace IsSymmetric

include _i

/-- The supremum of the Rayleigh quotient of a symmetric operator `T` on a nontrivial
finite-dimensional vector space is an eigenvalue for that operator. -/
theorem hasEigenvalue_supᵢ_of_finiteDimensional (hT : T.IsSymmetric) :
    HasEigenvalue T ↑(⨆ x : { x : E // x ≠ 0 }, IsROrC.re ⟪T x, x⟫ / ‖(x : E)‖ ^ 2) :=
  by
  haveI := FiniteDimensional.proper_isROrC 𝕜 E
  let T' := hT.to_self_adjoint
  obtain ⟨x, hx⟩ : ∃ x : E, x ≠ 0 := exists_ne 0
  have H₁ : IsCompact (sphere (0 : E) ‖x‖) := isCompact_sphere _ _
  have H₂ : (sphere (0 : E) ‖x‖).Nonempty := ⟨x, by simp⟩
  -- key point: in finite dimension, a continuous function on the sphere has a max
  obtain ⟨x₀, hx₀', hTx₀⟩ :=
    H₁.exists_forall_ge H₂ T'.val.re_apply_inner_self_continuous.continuous_on
  have hx₀ : ‖x₀‖ = ‖x‖ := by simpa using hx₀'
  have : IsMaxOn T'.val.re_apply_inner_self (sphere 0 ‖x₀‖) x₀ := by simpa only [← hx₀] using hTx₀
  have hx₀_ne : x₀ ≠ 0 :=
    by
    have : ‖x₀‖ ≠ 0 := by simp only [hx₀, norm_eq_zero, hx, Ne.def, not_false_iff]
    simpa [← norm_eq_zero, Ne.def]
  exact has_eigenvalue_of_has_eigenvector (T'.prop.has_eigenvector_of_is_max_on hx₀_ne this)
#align linear_map.is_symmetric.has_eigenvalue_supr_of_finite_dimensional LinearMap.IsSymmetric.hasEigenvalue_supᵢ_of_finiteDimensional

/-- The infimum of the Rayleigh quotient of a symmetric operator `T` on a nontrivial
finite-dimensional vector space is an eigenvalue for that operator. -/
theorem hasEigenvalue_infᵢ_of_finiteDimensional (hT : T.IsSymmetric) :
    HasEigenvalue T ↑(⨅ x : { x : E // x ≠ 0 }, IsROrC.re ⟪T x, x⟫ / ‖(x : E)‖ ^ 2) :=
  by
  haveI := FiniteDimensional.proper_isROrC 𝕜 E
  let T' := hT.to_self_adjoint
  obtain ⟨x, hx⟩ : ∃ x : E, x ≠ 0 := exists_ne 0
  have H₁ : IsCompact (sphere (0 : E) ‖x‖) := isCompact_sphere _ _
  have H₂ : (sphere (0 : E) ‖x‖).Nonempty := ⟨x, by simp⟩
  -- key point: in finite dimension, a continuous function on the sphere has a min
  obtain ⟨x₀, hx₀', hTx₀⟩ :=
    H₁.exists_forall_le H₂ T'.val.re_apply_inner_self_continuous.continuous_on
  have hx₀ : ‖x₀‖ = ‖x‖ := by simpa using hx₀'
  have : IsMinOn T'.val.re_apply_inner_self (sphere 0 ‖x₀‖) x₀ := by simpa only [← hx₀] using hTx₀
  have hx₀_ne : x₀ ≠ 0 :=
    by
    have : ‖x₀‖ ≠ 0 := by simp only [hx₀, norm_eq_zero, hx, Ne.def, not_false_iff]
    simpa [← norm_eq_zero, Ne.def]
  exact has_eigenvalue_of_has_eigenvector (T'.prop.has_eigenvector_of_is_min_on hx₀_ne this)
#align linear_map.is_symmetric.has_eigenvalue_infi_of_finite_dimensional LinearMap.IsSymmetric.hasEigenvalue_infᵢ_of_finiteDimensional

omit _i

theorem subsingleton_of_no_eigenvalue_finiteDimensional (hT : T.IsSymmetric)
    (hT' : ∀ μ : 𝕜, Module.End.eigenspace (T : E →ₗ[𝕜] E) μ = ⊥) : Subsingleton E :=
  (subsingleton_or_nontrivial E).resolve_right fun h =>
    absurd (hT' _) hT.has_eigenvalue_supr_of_finite_dimensional
#align linear_map.is_symmetric.subsingleton_of_no_eigenvalue_finite_dimensional LinearMap.IsSymmetric.subsingleton_of_no_eigenvalue_finiteDimensional

end IsSymmetric

end LinearMap

end FiniteDimensional


universe u
variables a b c : Type u

open tactic
open interactive

/-

List monad:

inductive list (T : Type u)
| nil : list
| cons (hd : T) (tl : list) : list

Given a function f: a → b, the following are two ways of defining the induced function list f : list a → list b.
-/

-- def map (f : a → b) (l : list a)
-- : list b :=
-- match l with
-- | [] := []
-- | (h :: t) := ((f h) :: map t)
-- end

def map' (f : a → b) : list a
→ list b
| [] := []
| (h :: t) := ((f h) :: map' t)

def map'' (f : a → b) (α : list a)
: list b
:=
do x ← α,
  return (f x)

def map''' (f : a → b) (α : list a)
: list b
:=
α >>= (λ x, return (f x))

#check map'
#check map''
#check map'''

#check @return

#check monad

meta def list_local_ctx : tactic unit :=
do
  ctx ← tactic.local_context,
  ctx.mmap' (λ str, infer_type str >>= tactic.trace)

example (a : ℕ) : a ≥ a :=
begin
  list_local_ctx,
  sorry,
end


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import analysis.convex.extreme
import analysis.convex.function
import topology.algebra.module.basic
import topology.order.basic

/-!
# Exposed sets

This file defines exposed sets and exposed points for sets in a real vector space.

An exposed subset of `A` is a subset of `A` that is the set of all maximal points of a functional
(a continuous linear map `E → 𝕜`) over `A`. By convention, `∅` is an exposed subset of all sets.
This allows for better functoriality of the definition (the intersection of two exposed subsets is
exposed, faces of a polytope form a bounded lattice).
This is an analytic notion of "being on the side of". It is stronger than being extreme (see
`is_exposed.is_extreme`), but weaker (for exposed points) than being a vertex.

An exposed set of `A` is sometimes called a "face of `A`", but we decided to reserve this
terminology to the more specific notion of a face of a polytope (sometimes hopefully soon out
on mathlib!).

## Main declarations

* `is_exposed 𝕜 A B`: States that `B` is an exposed set of `A` (in the literature, `A` is often
  implicit).
* `is_exposed.is_extreme`: An exposed set is also extreme.

## References

See chapter 8 of [Barry Simon, *Convexity*][simon2011]

## TODO

Define intrinsic frontier/interior and prove the lemmas related to exposed sets and points.

Generalise to Locally Convex Topological Vector Spaces™

More not-yet-PRed stuff is available on the branch `sperner_again`.
-/

open_locale classical affine big_operators
open set

section preorder_semiring

variables (𝕜 : Type*) {E : Type*} [topological_space 𝕜] [semiring 𝕜] [preorder 𝕜]
  [add_comm_monoid E] [topological_space E] [module 𝕜 E] {A B : set E}

/-- A set `B` is exposed with respect to `A` iff it maximizes some functional over `A` (and contains
all points maximizing it). Written `is_exposed 𝕜 A B`. -/
def is_exposed (A B : set E) : Prop :=
B.nonempty → ∃ l : E →L[𝕜] 𝕜, B = {x ∈ A | ∀ y ∈ A, l y ≤ l x}

end preorder_semiring

section ordered_ring

variables {𝕜 : Type*} {E : Type*} [topological_space 𝕜] [ordered_ring 𝕜]
  [add_comm_monoid E] [topological_space E] [module 𝕜 E]
  {l : E →L[𝕜] 𝕜} {A B C : set E} {X : finset E} {x : E}

/-- A useful way to build exposed sets from intersecting `A` with halfspaces (modelled by an
inequality with a functional). -/
def continuous_linear_map.to_exposed (l : E →L[𝕜] 𝕜) (A : set E) : set E :=
{x ∈ A | ∀ y ∈ A, l y ≤ l x}

lemma continuous_linear_map.to_exposed.is_exposed : is_exposed 𝕜 A (l.to_exposed A) := λ h, ⟨l, rfl⟩

lemma is_exposed_empty : is_exposed 𝕜 A ∅ :=
λ ⟨x, hx⟩, by { exfalso, exact hx }

namespace is_exposed

protected lemma subset (hAB : is_exposed 𝕜 A B) : B ⊆ A :=
begin
  rintro x hx,
  obtain ⟨_, rfl⟩ := hAB ⟨x, hx⟩,
  exact hx.1,
end

@[refl] protected lemma refl (A : set E) : is_exposed 𝕜 A A :=
λ ⟨w, hw⟩, ⟨0, subset.antisymm (λ x hx, ⟨hx, λ y hy, by exact le_refl 0⟩) (λ x hx, hx.1)⟩

protected lemma antisymm (hB : is_exposed 𝕜 A B) (hA : is_exposed 𝕜 B A) :
  A = B :=
hA.subset.antisymm hB.subset

/- `is_exposed` is *not* transitive: Consider a (topologically) open cube with vertices
`A₀₀₀, ..., A₁₁₁` and add to it the triangle `A₀₀₀A₀₀₁A₀₁₀`. Then `A₀₀₁A₀₁₀` is an exposed subset
of `A₀₀₀A₀₀₁A₀₁₀` which is an exposed subset of the cube, but `A₀₀₁A₀₁₀` is not itself an exposed
subset of the cube. -/

protected lemma mono (hC : is_exposed 𝕜 A C) (hBA : B ⊆ A) (hCB : C ⊆ B) :
  is_exposed 𝕜 B C :=
begin
  rintro ⟨w, hw⟩,
  obtain ⟨l, rfl⟩ := hC ⟨w, hw⟩,
  exact ⟨l, subset.antisymm (λ x hx, ⟨hCB hx, λ y hy, hx.2 y (hBA hy)⟩)
    (λ x hx, ⟨hBA hx.1, λ y hy, (hw.2 y hy).trans (hx.2 w (hCB hw))⟩)⟩,
end

/-- If `B` is a nonempty exposed subset of `A`, then `B` is the intersection of `A` with some closed
halfspace. The converse is *not* true. It would require that the corresponding open halfspace
doesn't intersect `A`. -/

/-- For nontrivial `𝕜`, if `B` is an exposed subset of `A`, then `B` is the intersection of `A` with
some closed halfspace. The converse is *not* true. It would require that the corresponding open
halfspace doesn't intersect `A`. -/
lemma eq_inter_halfspace [nontrivial 𝕜] {A B : set E} (hAB : is_exposed 𝕜 A B) :
  ∃ l : E →L[𝕜] 𝕜, ∃ a, B = {x ∈ A | a ≤ l x} :=
begin
  obtain rfl | hB := B.eq_empty_or_nonempty,
  { refine ⟨0, 1, _⟩,
    rw [eq_comm, eq_empty_iff_forall_not_mem],
    rintro x ⟨-, h⟩,
    rw continuous_linear_map.zero_apply at h,
    have : ¬ ((1:𝕜) ≤ 0) := not_le_of_lt zero_lt_one,
    contradiction },
  exact hAB.eq_inter_halfspace' hB,
end

protected lemma inter [has_continuous_add 𝕜] {A B C : set E} (hB : is_exposed 𝕜 A B)
  (hC : is_exposed 𝕜 A C) :
  is_exposed 𝕜 A (B ∩ C) :=
begin
  rintro ⟨w, hwB, hwC⟩,
  obtain ⟨l₁, rfl⟩ := hB ⟨w, hwB⟩,
  obtain ⟨l₂, rfl⟩ := hC ⟨w, hwC⟩,
  refine ⟨l₁ + l₂, subset.antisymm _ _⟩,
  { rintro x ⟨⟨hxA, hxB⟩, ⟨-, hxC⟩⟩,
    exact ⟨hxA, λ z hz, add_le_add (hxB z hz) (hxC z hz)⟩ },
  rintro x ⟨hxA, hx⟩,
  refine ⟨⟨hxA, λ y hy, _⟩, hxA, λ y hy, _⟩,
  { exact (add_le_add_iff_right (l₂ x)).1 ((add_le_add (hwB.2 y hy) (hwC.2 x hxA)).trans
      (hx w hwB.1)) },
  { exact (add_le_add_iff_left (l₁ x)).1 (le_trans (add_le_add (hwB.2 x hxA) (hwC.2 y hy))
    (hx w hwB.1)) }
end

lemma sInter [has_continuous_add 𝕜] {F : finset (set E)} (hF : F.nonempty)
  (hAF : ∀ B ∈ F, is_exposed 𝕜 A B) :
  is_exposed 𝕜 A (⋂₀ F) :=
begin
  revert hF F,
  refine finset.induction _ _,
  { rintro h,
    exfalso,
    exact not_nonempty_empty h },
  rintro C F _ hF _ hCF,
  rw [finset.coe_insert, sInter_insert],
  obtain rfl | hFnemp := F.eq_empty_or_nonempty,
  { rw [finset.coe_empty, sInter_empty, inter_univ],
    exact hCF C (finset.mem_singleton_self C) },
  exact (hCF C (finset.mem_insert_self C F)).inter (hF hFnemp (λ B hB,
    hCF B(finset.mem_insert_of_mem hB))),
end

lemma inter_left (hC : is_exposed 𝕜 A C) (hCB : C ⊆ B) :
  is_exposed 𝕜 (A ∩ B) C :=
begin
  rintro ⟨w, hw⟩,
  obtain ⟨l, rfl⟩ := hC ⟨w, hw⟩,
  exact ⟨l, subset.antisymm (λ x hx, ⟨⟨hx.1, hCB hx⟩, λ y hy, hx.2 y hy.1⟩)
    (λ x ⟨⟨hxC, _⟩, hx⟩, ⟨hxC, λ y hy, (hw.2 y hy).trans (hx w ⟨hC.subset hw, hCB hw⟩)⟩)⟩,
end

lemma inter_right (hC : is_exposed 𝕜 B C) (hCA : C ⊆ A) :
  is_exposed 𝕜 (A ∩ B) C :=
begin
  rw inter_comm,
  exact hC.inter_left hCA,
end

protected lemma is_closed [order_closed_topology 𝕜] {A B : set E}
  (hAB : is_exposed 𝕜 A B) (hA : is_closed A) : is_closed B :=
begin
  obtain rfl | hB := B.eq_empty_or_nonempty,
  { simp },
  obtain ⟨l, a, rfl⟩ := hAB.eq_inter_halfspace' hB,
  exact hA.is_closed_le continuous_on_const l.continuous.continuous_on,
end

protected lemma is_compact [order_closed_topology 𝕜] [t2_space E] {A B : set E}
  (hAB : is_exposed 𝕜 A B) (hA : is_compact A) : is_compact B :=
is_compact_of_is_closed_subset hA (hAB.is_closed hA.is_closed) hAB.subset

end is_exposed

variables (𝕜)

/-- A point is exposed with respect to `A` iff there exists an hyperplane whose intersection with
`A` is exactly that point. -/
def set.exposed_points (A : set E) :
  set E :=
{x ∈ A | ∃ l : E →L[𝕜] 𝕜, ∀ y ∈ A, l y ≤ l x ∧ (l x ≤ l y → y = x)}

variables {𝕜}

lemma exposed_point_def :
  x ∈ A.exposed_points 𝕜 ↔ x ∈ A ∧ ∃ l : E →L[𝕜] 𝕜, ∀ y ∈ A, l y ≤ l x ∧ (l x ≤ l y → y = x) :=
iff.rfl

lemma exposed_points_subset :
  A.exposed_points 𝕜 ⊆ A :=
λ x hx, hx.1

@[simp] lemma exposed_points_empty :
  (∅ : set E).exposed_points 𝕜 = ∅ :=
subset_empty_iff.1 exposed_points_subset

/-- Exposed points exactly correspond to exposed singletons. -/
lemma mem_exposed_points_iff_exposed_singleton :
  x ∈ A.exposed_points 𝕜 ↔ is_exposed 𝕜 A {x} :=
begin
  use λ ⟨hxA, l, hl⟩ h, ⟨l, eq.symm $ eq_singleton_iff_unique_mem.2 ⟨⟨hxA, λ y hy, (hl y hy).1⟩,
    λ z hz, (hl z hz.1).2 (hz.2 x hxA)⟩⟩,
  rintro h,
  obtain ⟨l, hl⟩ := h ⟨x, mem_singleton _⟩,
  rw [eq_comm, eq_singleton_iff_unique_mem] at hl,
  exact ⟨hl.1.1, l, λ y hy, ⟨hl.1.2 y hy, λ hxy, hl.2 y ⟨hy, λ z hz, (hl.1.2 z hz).trans hxy⟩⟩⟩,
end

end ordered_ring

section linear_ordered_ring

variables {𝕜 : Type*} {E : Type*} [topological_space 𝕜] [linear_ordered_ring 𝕜]
  [add_comm_monoid E] [topological_space E] [module 𝕜 E]
  {A B C : set E}

namespace is_exposed

protected lemma convex (hAB : is_exposed 𝕜 A B) (hA : convex 𝕜 A) :
  convex 𝕜 B :=
begin
  obtain rfl | hB := B.eq_empty_or_nonempty,
  { exact convex_empty },
  obtain ⟨l, rfl⟩ := hAB hB,
  exact λ x₁ hx₁ x₂ hx₂ a b ha hb hab, ⟨hA hx₁.1 hx₂.1 ha hb hab, λ y hy,
    ((l.to_linear_map.concave_on convex_univ).convex_ge _
    ⟨mem_univ _, hx₁.2 y hy⟩ ⟨mem_univ _, hx₂.2 y hy⟩ ha hb hab).2⟩,
end

protected lemma is_extreme (hAB : is_exposed 𝕜 A B) :
  is_extreme 𝕜 A B :=
begin
  refine ⟨hAB.subset, λ x₁ hx₁A x₂ hx₂A x hxB hx, _⟩,
  obtain ⟨l, rfl⟩ := hAB ⟨x, hxB⟩,
  have hl : convex_on 𝕜 univ l := l.to_linear_map.convex_on convex_univ,
  have hlx₁ := hxB.2 x₁ hx₁A,
  have hlx₂ := hxB.2 x₂ hx₂A,
  refine ⟨⟨hx₁A, λ y hy, _⟩, ⟨hx₂A, λ y hy, _⟩⟩,
  { have := @convex_on.le_left_of_right_le 𝕜 E 𝕜 _ _ _,
    rw hlx₁.antisymm (hl.le_left_of_right_le (mem_univ _) (mem_univ _) hx hlx₂),
    exact hxB.2 y hy },
  { rw hlx₂.antisymm (hl.le_right_of_left_le (mem_univ _) (mem_univ _) hx hlx₁),
    exact hxB.2 y hy }
end

end is_exposed

lemma exposed_points_subset_extreme_points :
  A.exposed_points 𝕜 ⊆ A.extreme_points 𝕜 :=
λ x hx, mem_extreme_points_iff_extreme_singleton.2
  (mem_exposed_points_iff_exposed_singleton.1 hx).is_extreme

end linear_ordered_ring