-- import SciLean.Core.Data.Curry
import SciLean.Mathlib.Convenient.Basic
-- import SciLean.Core.New.IsSmooth
import SciLean.Core.TensorProduct
import SciLean.Core.FinVec
import SciLean.Core.SmoothMap

namespace SciLean

 --TODO: Question?
 -- Should linearity include smoothness? Are there usefull linear
 -- functions that are not smooth?
 -- In finite dimension every linear function is smooth but in infitite
 -- dimensional spaces it does not have to be the case.
 /-- Function `f : X₁ → ... Xₙ → Y'` is a linear as a function `X₁ × ... × Xₙ → Y'`.

 Where `X = X₁` and `Y = X₂ → ... → Xₙ → Y'`

 Transitive closure of `IsLinNT`
 -/
 class IsLinNT {X Y : Type} {Xs Y' : Type} [Vec Xs] [Vec Y']
   (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] : Prop where
   is_lin : TensorProduct.is_linear (uncurryN n f)
   is_smooth : IsSmoothT (uncurryN n f)

  /-- Function `f : X₁ → ... Xₙ → Y'` is a linear as a function `X₁ × ... × Xₙ → Y'`.

  Where `X = X₁` and `Y = X₂ → ... → Xₙ → Y'`
  -/
  class IsLinN {X Y : Type} {Xs Y' : Type} [Vec Xs] [Vec Y']
    (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] extends IsLinNT n f : Prop

  /-- `IsLin f` says that `f : X → Y` is linear.

  Abbreviation for `IsLinN 1 f`
  -/
  abbrev IsLin {X Y} [Vec X] [Vec Y] (f : X → Y) : Prop := IsLinN 1 f

  /-- `IsLinT f` says that `f : X → Y` is linear.

  Abbreviation for `IsLinNT 1 f`.

  `IsLinT` is transitive closure of `IsLin`.
  -/
  abbrev IsLinT {X Y} [Vec X] [Vec Y] (f : X → Y) : Prop := IsLinNT 1 f

  structure LinMap (X Y : Type) [Vec X] [Vec Y] where
    val : X → Y
    [property : IsLinT val]

  /-- `X --o Y` is the space of all linear maps between `X` and `Y`.

  The notation `X ⊸ Y` is prefered, but this fixes pure ASCII equivalent. -/
  infixr:25 " --o " => LinMap

  /-- `X ⊸ Y` is the space of all linear maps between `X` and `Y` -/
  infixr:25 " ⊸ " => LinMap

  -- Lambda notation
  open Lean.TSyntax.Compat in
  macro "λ"   xs:Lean.explicitBinders " ⊸ " b:term : term =>
    Lean.expandExplicitBinders `SciLean.LinMap.mk xs b

  variable {X Y Z W: Type} [Vec X] [Vec Y] [Vec Z] [Vec W]

  instance : CoeFun (X⊸Y) (λ _ => X→Y) := ⟨λ f => f.1⟩

  instance LinMap.val.arg_x.isLin {X Y} [Vec X] [Vec Y] (f : X ⊸ Y)
    : IsLinT f.1 := f.2

  abbrev LinMap.mk' {X Y} [Vec X] [Vec Y] (f : X → Y) (_ : IsLinT f) : X⊸Y := λ x ⊸ f x

  @[ext]
  theorem LinMap.ext {X Y} [Vec X] [Vec Y] (f g : X ⊸ Y) : (∀ x, f x = g x) → f = g := by sorry

  @[simp, diff_simp]
  theorem LinMap.eta_reduction {X Y} [Vec X] [Vec Y] (f : X ⊸ Y)
      : (λ (x : X) ⊸ f x) = f := by rfl; done

  theorem show_is_lin_via {X Y} [Vec X] [Vec Y] {f : X → Y} (g : X ⊸ Y) : (f = g) → IsLinT f :=
  by
    intro p
    have q : f = g := by apply p
    rw[q]; infer_instance

  namespace Lin

  variable {Z : Type} [Vec Z] {α : Type}

  def comp' : (Y⊸Z) → (X⊸Y) → (X⊸Z) := λ f g =>
    LinMap.mk' (λ x => f (g x)) sorry

  def prodMap' : (X⊸Y) → (X⊸Z) → (X ⊸ Y×Z) := λ f g =>
    LinMap.mk' (λ x => (f x, g x)) sorry

  def zeroFun : Y⊸X :=
    LinMap.mk' (λ y => (0 : X)) sorry

  def swap : X⊗Y → Y⊗X := (λ xy => xy.map' (λ (x : X) (y : Y) => y⊗x) sorry)

  @[simp] theorem comp'_eval (f : Y ⊸ Z) (g : X⊸Y) (x : X) : comp' f g x = f (g x) := by simp[comp']
  @[simp] theorem prodMap'_eval (f : X ⊸ Y) (g : X⊸Z) (x : X) : prodMap' f g x = (f x, g x) := by simp[prodMap']
  @[simp] theorem zeroFun_eval (y : Y) : zeroFun y = (0 : X) := by simp[zeroFun]

  def neg : X ⊸ X := LinMap.mk' (λ x => -x) sorry
  def add' : X×X ⊸ X := LinMap.mk' (λ (x,y) => x+y) sorry
  def sub' : X×X ⊸ X := LinMap.mk' (λ (x,y) => x-y) sorry
  def mul' : ℝ×ℝ ⊸ ℝ := LinMap.mk' (λ (x,y) => x*y) sorry

  -- def tassocl :
  -- def tassocr :
  def unit' : ℝ → X ⊸ ℝ⊗X := λ r => LinMap.mk' (λ x => r⊗x) sorry
  def counit : ℝ⊗X ⊸ X := LinMap.mk' ((λ rx => rx.map' (λ r x => r • x) sorry)) sorry

  @[simp] theorem unit'_eval (r : ℝ) (x : X) : unit' r x = r⊗x := by simp[unit']
  @[simp] theorem counit_eval (r : ℝ) (x : X) : counit (r⊗x) = r•x := by simp[counit]

  instance : Neg (X⊸Y) := ⟨λ f => LinMap.mk' (λ x => -f x)
    (show_is_lin_via (comp' neg f) (by funext; simp[neg]))⟩

  instance : Add (X⊸Y) := ⟨λ f g => LinMap.mk' (λ x => f x + g x)
    (show_is_lin_via (comp' add' (prodMap' f g)) (by funext; simp[add']))⟩

  instance : Sub (X⊸Y) := ⟨λ f g => LinMap.mk' (λ x => f x - g x)
    (show_is_lin_via (comp' sub' (prodMap' f g)) (by funext; simp[sub']))⟩

  instance : Mul (X⊸ℝ) := ⟨λ f g => LinMap.mk' (λ x => f x * g x)
    (show_is_lin_via (comp' mul' (prodMap' f g)) (by funext; simp[mul']))⟩

  instance : SMul ℝ (X⊸Y) := ⟨λ r f => LinMap.mk' (λ x => r • f x)
    (show_is_lin_via (comp' counit (comp' (unit' r) f)) (by funext; simp))⟩

  instance : Zero (X ⊸ Y) := ⟨zeroFun⟩

  -- !!!THIS USES SORRY!!!
  instance : Vec (X ⊸ Y) := Vec.mkSorryProofs

  end Lin

  def TensorProduct.map (f : X ⊸ Y ⊸ Z) (xy : X⊗Y) : Z := xy.map' (λ x y => f x y) sorry_proof

  namespace Lin

  @[infer_tc_goals_rl]
  instance {X ι} [Enumtype ι] [FinVec X ι] [Hilbert Y] : Inner (X ⊸ Y) where
    -- This should be the correct version of the inner product
    -- It looks assymetrical but it is a consequence of `inner_proj_dualproj`
    --   ⟪x, y⟫ = ∑ i, 𝕡 i x * 𝕡' i y
    -- which also appears assymetrical
    inner f g := ∑ i, ⟪f (𝕖 i), g (𝕖' i)⟫

  @[infer_tc_goals_rl]
  instance {X ι} [Enumtype ι] [FinVec X ι] [Hilbert Y] : TestFunctions (X ⊸ Y) where
    TestFun _ := True

  @[infer_tc_goals_rl]
  instance {X ι} [Enumtype ι] [FinVec X ι] [Hilbert Y] : SemiHilbert (X ⊸ Y) := SemiHilbert.mkSorryProofs

  @[infer_tc_goals_rl]
  instance {X ι} [Enumtype ι] [FinVec X ι] [Hilbert Y] : Hilbert (X ⊸ Y) := Hilbert.mkSorryProofs

  @[infer_tc_goals_rl]
  instance {X ι κ} [Enumtype ι] [Enumtype κ] [FinVec X ι] [FinVec Y κ] : Basis (X ⊸ Y) (ι×κ) ℝ where
    basis := λ (i,j) => LinMap.mk' (λ x => 𝕡 i x • 𝕖[Y] j) sorry_proof
    proj := λ (i,j) f => 𝕡 j (f (𝕖 i))

  @[infer_tc_goals_rl]
  instance {X ι κ} [Enumtype ι] [Enumtype κ] [FinVec X ι] [FinVec Y κ] : DualBasis (X ⊸ Y) (ι×κ) ℝ where
    dualBasis := λ (i,j) => LinMap.mk' (λ x => 𝕡' i x • 𝕖'[Y] j) sorry_proof
    dualProj := λ (i,j) f => 𝕡' j (f (𝕖' i))

  open BasisDuality in
  @[infer_tc_goals_rl]
  instance {X ι κ} [Enumtype ι] [Enumtype κ] [FinVec X ι] [FinVec Y κ] : BasisDuality (X ⊸ Y) where
    toDual   := λ f => LinMap.mk' (λ x => toDual (f (fromDual x))) sorry_proof
    fromDual := λ f => LinMap.mk' (λ x => fromDual (f (toDual x))) sorry_proof

  @[infer_tc_goals_rl]
  instance {X ι κ} [Enumtype ι] [Enumtype κ] [FinVec X ι] [FinVec Y κ] : FinVec (X ⊸ Y) (ι×κ) where
    is_basis := sorry_proof
    duality :=
    by
      intro (i,j) (i',j'); simp[Basis.basis, DualBasis.dualBasis, Inner.inner];
      -- This should be:
      --  ∑ i_i, ⟪[[i=i_]] * 𝕖 j, [[i'=i_1]] 𝕖' j'⟫
      --  [[i=i']] * ⟪𝕖 j, 𝕖' j'⟫
      --  [[i=i']] * [[j=j']]
      sorry_proof
    to_dual :=
    by
      simp [BasisDuality.toDual, Basis.proj, DualBasis.dualBasis]
      intro f; ext x;
      simp[FinVec.to_dual,FinVec.from_dual]
      -- Now the goal is:
      --   ∑ j, 𝕡 j (f (∑ i, 𝕡' i x * 𝕖 i)) * 𝕖' j
      --   =
      --   ∑ (i,j), 𝕡 j (f (𝕖 i)) * 𝕡' i x * 𝕖' j
      sorry_proof
    from_dual :=
    by
      simp [BasisDuality.fromDual, DualBasis.dualProj, Basis.basis]
      intro f; ext x;
      simp[FinVec.to_dual,FinVec.from_dual]
      -- Now the goal is:
      --   ∑ j, 𝕡' j (f (∑ i, 𝕡 i x * 𝕖' i)) * 𝕖 j
      --   =
      --   ∑ (i,j), 𝕡' j (f (𝕖' i)) * 𝕡' i x * 𝕖 j
      sorry_proof

  --------------------------------------------------------------------

  def curry' (f : X ⊗ Y ⊸ Z) : (X ⊸ Y ⊸ Z) :=
    LinMap.mk' (λ x =>
      LinMap.mk' (λ y => f (x ⊗ y))
      sorry_proof)
    sorry_proof

  def uncurry' (f : X ⊸ Y ⊸ Z) : (X ⊗ Y ⊸ Z) :=
    LinMap.mk' (λ xy => xy.map' (λ x y => f x y) sorry_proof) sorry_proof

  def id : X ⊸ X := LinMap.mk' (λ x => x) sorry_proof
  def fst : X×Y ⊸ X := LinMap.mk' (λ (x,_) => x) sorry_proof
  def snd : X×Y ⊸ Y := LinMap.mk' (λ (_,y) => y) sorry_proof

  @[simp] theorem curry'_eval (f : X⊗Y ⊸ Z) (x : X) (y : Y) : curry' f x y = f (x⊗y) := by simp[curry']
  @[simp] theorem uncurry'_eval (f : X ⊸ Y ⊸ Z) (xy : X⊗Y) : uncurry' f xy = xy.map f := by simp[uncurry',TensorProduct.map]
  @[simp] theorem id_eval (x : X) : id x = x := by simp[id]
  @[simp] theorem fst_eval (xy : X×Y) : fst xy = xy.1 := by simp[fst]
  @[simp] theorem snd_eval (xy : X×Y) : snd xy = xy.2 := by simp[snd]

  def tprod : X ⊸ Y ⊸ X⊗Y :=
    LinMap.mk' (λ x =>
      LinMap.mk' (λ y => x⊗y)
      (show_is_lin_via (curry' id x) (by ext y; simp)))
    (show_is_lin_via (curry' id) (by ext x y; simp))

  -- noncomputable
  -- def tpmap : (X⊸Y) ⊸ (X⊸Z) ⊸ (X⊸Y⊗Z) := ⟨λ f => ⟨λ g => ⟨λ x => (f x ⊗ g x), sorry_proof⟩, sorry_proof⟩, sorry_proof⟩
  -- noncomputable
  -- def tfmap : (X⊸Z) ⊸ (Y⊸W) ⊸ (X⊗Y⊸Z⊗W) := ⟨λ f => ⟨λ g => ⟨λ xy =>
  --   let ⟨_,x,y⟩ := xy.repr
  --   ∑ i, f (x i) ⊗ g (y i), sorry_proof⟩, sorry_proof⟩, sorry_proof⟩

  -- def pmap : (X⊸Y) × (X⊸Z) ⊸ (X⊸Y×Z) := ⟨λ (f,g) => ⟨λ x => (f x, g x), sorry_proof⟩, sorry_proof⟩
  -- def fmap : (X⊸Z) × (Y⊸W) ⊸ (X×Y⊸Z×W) := ⟨λ (f,g) =>⟨λ (x,y) => (f x, g y), sorry_proof⟩, sorry_proof⟩
  -- def fmap' : (X→Z) × (Y→W) ⊸ (X×Y→Z×W) := ⟨λ (f,g) => λ (x,y) => (f x, g y), sorry_proof⟩
  -- def pmap' : (X→Y) × (X→Z) ⊸ (X→Y×Z) := ⟨λ (f,g) => λ x => (f x, g x), sorry_proof⟩

  -- -- I don't think this is a valid map
  -- -- noncomputable
  -- -- def tfmap' : (X→Z) ⊸ (Y→W) ⊸ (X⊗Y→Z⊗W) := ⟨λ f => ⟨ λ g => λ xy =>
  -- --   let ⟨_,x,y⟩ := xy.repr
  -- --   ∑ i, f (x i) ⊗ g (y i), sorry_proof⟩, sorry_proof⟩

  -- noncomputable
  -- def tpmap' : (X→Y) ⊸ (X→Z) ⊸ (X→Y⊗Z) := ⟨λ f => ⟨λ g => λ x => f x ⊗ g x, sorry_proof⟩, sorry_proof⟩

  -- -- Does this one work?
  -- def comp'' : (Y ⊸ Z) ⊸ (X → Y) ⊸ (X → Z) := ⟨λ f => ⟨λ g => λ x => f (g x), sorry_proof⟩, sorry_proof⟩

  -- noncomputable
  -- def teval : ((X⊸Y)⊗X) ⊸ Y := uncurry' id
  -- noncomputable
  -- def tpair : X⊸Y⊸X⊗Y := curry' id

  -- def assocl : X×(Y×Z) ⊸ (X×Y)×Z :=
  --   let F : X×(Y×Z) ⊸ (X×Y)×Z := pmap ((pmap (fst, (comp' fst snd))), (comp' snd snd))
  --   ⟨λ (x,(y,z)) => ((x,y),z),
  --    by
  --      have h : (λ (x,(y,z)) => ((x,y),z)) = F.1 := by simp[pmap, comp', fst, snd]
  --      rw[h]
  --      apply F.2⟩

  -- def assocr : (X×Y)×Z ⊸ X×(Y×Z) :=
  --   let F : (X×Y)×Z ⊸ X×(Y×Z) := pmap ((comp' fst fst), (pmap ((comp' snd fst), snd)))
  --   ⟨λ ((x,y),z) => (x,(y,z)),
  --    by
  --      have h : (λ ((x,y),z) => (x,(y,z))) = F.1 := by simp[pmap, comp', fst, snd]
  --      rw[h]
  --      apply F.2⟩

  -- @[simp]
  -- theorem assocl_eval (xyz : X×(Y×Z)) : assocl xyz = ((xyz.1,xyz.2.1),xyz.2.2) := rfl

  -- @[simp]
  -- theorem assocr_eval (xyz : (X×Y)×Z) : assocr xyz = (xyz.1.1,(xyz.1.2,xyz.2)) := rfl

  -- noncomputable
  -- def tassocl : X⊗(Y⊗Z) ⊸ (X⊗Y)⊗Z := ⟨λ xyz =>
  --   let ⟨_,x,yz⟩ := xyz.repr
  --   let y := λ i => (yz i).repr.snd.fst
  --   let z := λ i => (yz i).repr.snd.snd
  --   ∑ i j, (x i ⊗ y i j) ⊗ z i j,
  --   sorry_proof⟩

  -- noncomputable
  -- def tassocr : (X⊗Y)⊗Z ⊸ X⊗(Y⊗Z) := ⟨λ xyz =>
  --   let ⟨_,xy,z⟩ := xyz.repr
  --   let x := λ i => (xy i).repr.snd.fst
  --   let y := λ i => (xy i).repr.snd.snd
  --   ∑ i j, x i j ⊗ (y i j ⊗ z i),
  --   sorry_proof⟩

  -- def swap : (X×Y) ⊸ (Y×X) := pmap (snd, fst)

  -- @[simp]
  -- theorem swap_eval (xy : (X×Y)) : swap xy = (xy.2, xy.1) := rfl

  -- noncomputable
  -- def tswap : (X⊗Y) ⊸ (Y⊗X) := ⟨λ xy =>
  --   let ⟨_,x,y⟩ := xy.repr
  --   ∑ i, y i ⊗ x i,
  --   sorry_proof⟩

  -- def rot132 : (X×Y)×Z ⊸ (X×Z)×Y := comp' assocl (comp' (fmap (id, swap)) assocr)

  -- @[simp]
  -- theorem rot132_eval (xyz : (X×Y)×Z) : rot132 xyz = ((xyz.1.1, xyz.2), xyz.1.2) := rfl

  -- noncomputable
  -- def trot132 : (X⊗Y)⊗Z ⊸ (X⊗Z)⊗Y := comp' tassocl (comp' (tfmap id tswap) tassocr)

  -- @[simp]
  -- theorem trot132_eval (x : X) (y : Y) (z : Z) : trot132 ((x⊗y)⊗z) = (x⊗z)⊗y := sorry_proof

  -- -- TODO: This function is perfectly computable, make it so
  -- -- only the proof of linearity goes via noncomputable tensor product
  -- noncomputable
  -- def comp : (Y ⊸ Z) ⊸ (X ⊸ Y) ⊸ (X ⊸ Z) :=
  --   let F₁ : (Y⊸Z)⊗((X⊸Y)⊗X) ⊸ Z := comp' teval (tfmap id teval)
  --   curry' (curry' (comp' F₁ tassocr))

  -- @[simp]
  -- theorem comp_eval (f : Y⊸Z) (g : X ⊸ Y) (x : X) : comp f g x = f (g x) := sorry_proof

  -- -- def const : X⊸Y⊸X := curry' fst

  -- -- @[simp]
  -- -- theorem const_eval (f : Y⊸Z) (g : X ⊸ Y) (x : X) : comp f g x = f (g x) := rfl

  -- noncomputable
  -- def uncurry : (X ⊸ Y ⊸ Z) ⊸ (X⊗Y ⊸ Z) :=
  --   let F : ((X⊸Y⊸Z)⊗X)⊗Y ⊸ Z := comp teval (tfmap teval id)

  --   let G₁ : (X⊗Y ⊸ (X⊸Y⊸Z)⊗(X⊗Y)) ⊸ (X⊗Y ⊸ Z) := comp (comp' F tassocl)
  --   let G₂ : (X⊸Y⊸Z) ⊸ (X⊗Y ⊸ (X⊸Y⊸Z)⊗(X⊗Y)) := tpair
  --   comp' G₁ G₂

  -- -- @[simp]
  -- -- theorem Smooth.uncurry_eval (f : X ⊸ Y ⊸ Z) (xy : X×Y) : Smooth.uncurry f xy = f xy.1 xy.2 := by rfl

  -- noncomputable
  -- def curry : (X ⊗ Y ⊸ Z) ⊸ (X ⊸ Y ⊸ Z) :=

  --   let G : ((X⊗Y⊸Z)⊗Y)⊗X ⊸ Z := comp (comp (uncurry' id) (tfmap id tswap)) tassocr

  --   let H : (Y ⊸ (X⊗Y⊸Z)⊗Y)⊗X ⊸ (Y ⊸ ((X⊗Y⊸Z)⊗Y)⊗X) := curry' (comp (tfmap teval id) trot132)

  --   let F₁ : (X⊗Y⊸Z) ⊸ (Y ⊸ (X⊗Y⊸Z)⊗Y) := tpair
  --   let F₂ : (Y ⊸ (X⊗Y⊸Z)⊗Y) ⊸ (X ⊸ (Y ⊸ (X⊗Y⊸Z)⊗Y)⊗X) := tpair
  --   let F₃ : (X ⊸ (Y ⊸ (X⊗Y⊸Z)⊗Y)⊗X) ⊸ (X ⊸ (Y ⊸ ((X⊗Y⊸Z)⊗Y)⊗X)) := comp H

  --   comp (comp (comp G)) (comp F₃ (comp F₂ F₁))

  -- -- @[simp]
  -- -- theorem Smooth.curry_eval (f : X×Y ⊸ Z) (x : X) (y : Y) : Smooth.curry f x y = f (x,y) := by rfl

  -- -- TODO: make it computable
  -- noncomputable
  -- def prod : (X → Y ⊸ Z) ⊸ (X→Y) ⊸ (X→Z) :=
  --   let F : (X → Y ⊸ Z) ⊸ (X→Y) ⊸ (X → Y ⊸ Z)⊗(X→Y) := tpair
  --   let G₁ : (X → Y ⊸ Z)⊗(X→Y) ⊸ (X → (Y⊸Z)⊗Y) := uncurry tpmap'
  --   let G₂ : (X → (Y⊸Z)⊗Y) ⊸ (X→Z) := comp'' teval

  --   comp (comp (comp G₂ G₁)) F

  -- @[simp]
  -- theorem prod_eval (f : X → Y ⊸ Z) : prod f (λ _ => y) x = f x y := sorry_proof

  -- -- def scomb : (X⊸Y⊸Z) ⊸ (X⊸Y) ⊸ X ⊸ Z :=
  -- --   let F₁ : (X⊸Y⊸Z)⊗(X⊸Y)⊗X ⊸ (X⊗Y⊸Z)⊗(X⊗Y) := tfmap uncurry (tpmap snd teval)
  -- --   comp (curry) (curry (comp eval F₁))

  -- -- variable {ι κ : Type} {E F G : ι → Type} {E' : κ → Type} [∀ i, Vec (E i)] [∀ i, Vec (F i)] [∀ i, Vec (G i)] [∀ j, Vec (E' j)]
  -- -- instance  [∀ i, Vec (F i)] : Vec ((i : ι) → (F i)) := sorry

  -- -- def Smooth.pmapDep : ((i : ι)→(E i)) ⊸ ((i : ι)→(F i)) ⊸ ((i : ι)→(E i)×(F i)) := ⟨λ f => ⟨λ g => λ x => (f x, g x), sorry⟩, sorry⟩
  -- -- def Smooth.fmapDep : ((i : ι)→(E i)) ⊸ ((j : κ)→(E' j)) ⊸ ((ij : (ι×κ))→(E ij.1)×(E' ij.2)) := ⟨λ f => ⟨λ g => λ (i,j) => (f i, g j), sorry⟩, sorry⟩
  -- -- def Smooth.prodDep : ((i : ι) → E i ⊸ F i) ⊸ ((i : ι) → E i) ⊸ ((i : ι) → F i) := sorry

  -- end Linear


-- EXAMPLES

import syntax
import semantics

open has_sat

lemma mytaut1 (p : char) : tautology ((·p) ↣ (·p)) :=
begin
  unfold tautology evaluate,
  intros W M w,
  simp, unfold evaluate, tauto,
end

open classical

lemma mytaut2 (p : char) : tautology ((~ (~ · p)) ↣ · p) :=
begin
  unfold tautology evaluate,
  intros W M w,
  classical,
  simp, unfold evaluate, tauto,
end

def myModel : kripkeModel ℕ :=
  { val := (λ _ _ , true),
    rel := (λ _ v, v == 1 ) }

lemma mysat (p : char) : satisfiable (·p) :=
begin
  unfold satisfiable,
  existsi ℕ,
  existsi myModel,
  existsi 1,
  unfold evaluate,
end

-- Some validities of basic modal logic

lemma boxTop :
  tautology (□⊤) :=
begin
  unfold tautology evaluate,
  tauto,
end

lemma A3 (X Y : formula) :
  tautology (□(X ⋏ Y) ↣ □X ⋏ □Y) :=
begin
  unfold tautology evaluate,
  intros W M w,
  by_contradiction hyp,
  simp at hyp,
  unfold evaluate at hyp,
  simp at hyp,
  cases hyp with hl hr,
  contrapose! hr,
  split,
  { intros v1 ass, exact (hl v1 ass).1 },
  { intros v2 ass, exact (hl v2 ass).2 },
end


import data.real.basic
import data.real.sqrt
import data.set.basic
import algebra.big_operators.basic
import tactic

open real
open finset
open_locale big_operators

noncomputable theory

notation `|`x`|` := abs x

/-
 # Definitions
-/

def f_add : ℝ → ℝ → ℝ := λ x y, sqrt (|x + y|)

def f_add_move {r : ℝ} : ℝ → ℝ → ℝ := λ x y, f_add (x + r) (y + r)

def f_sub : ℝ → ℝ → ℝ := λ x y, sqrt (|x - y|)

def f_move {s : finset ℝ} : ℝ → ℝ := λ r, ∑ x y in s, f_add (x + r) (y + r)

def f_aux (x y : ℝ) : ℝ → ℝ := λ r, f_add (x + r) (y + r)

/-
# Lemmas

Here are some simple lemmas about the definitions we have just given and some auxiliary facts.
-/

lemma f_add_move_comm (r : ℝ) : ∀ x y, f_add (x + r) (y + r) = f_add (y + r) (x + r) :=
begin intros x y, unfold f_add, ring_nf end

lemma f_add_comm : ∀ x y, f_add x y = f_add y x :=
begin
  have := f_add_move_comm 0,
  simp at this,
  assumption,
end

lemma f_sub_comm : ∀ x y, f_sub x y = f_sub y x :=
begin intros x y, unfold f_sub, rw abs_sub_comm end

@[simp] lemma f_add_zero {x : ℝ} : f_add 0 x = sqrt (|x|) :=
begin unfold f_add, ring_nf end

@[simp] lemma f_sub_diag_zero {x : ℝ} : f_sub x x = 0 :=
begin unfold f_sub, simp end

@[simp] lemma f_sub_zero {x : ℝ} : f_sub 0 x = sqrt (|x|) :=
begin unfold f_sub, ring_nf, rw abs_neg end

@[simp] lemma f_sub_move {x y r : ℝ} : f_sub (x + r) (y + r) = f_sub x y :=
begin unfold f_sub, ring_nf end

lemma sum_f_sub_move {x : ℝ} {s : finset ℝ} (r : ℝ) : ∑ y in s, f_sub (x + r) (y + r) = ∑ y in s, f_sub x y :=
begin unfold f_sub, ring_nf end

lemma add_to_sub {x y : ℝ} : f_add (-x) y = f_sub x y :=
begin
  unfold f_add f_sub,
  rw add_comm,
  ring_nf,
  rw abs_sub_comm,
end

lemma left_lt_or_right_lt_of_add_lt_two_mul {a b c : ℝ} : a + b < 2*c → a < c ∨ b < c :=
begin
  intro h,
  by_contradiction h',
  push_neg at h',
  have := add_le_add h'.1 h'.2,
  linarith,
end

/-
# Sum lemmas

  Here are some lemmas about finite sums. Most of them are necessary because of the double sums.
-/

lemma sum_eq_sum {f g : ℝ → ℝ} {s : finset ℝ}: (∀ x, x ∈ s → f x = g x) → ∑ x in s, f x = ∑ x in s, g x :=
begin
  intro h,
  rw sum_eq_sum_iff_of_le,
  exact h,
  intros i hi,
  apply le_of_eq,
  exact h i hi,
end

lemma sum_add_to_sum_sub {a b r : ℝ} {s : finset ℝ}: a + b = 0 → ∑ x in s, f_add a (x + r) = ∑ x in s, f_sub b (x + r) := begin
  intro h,
  rw sum_eq_sum,
  intros x hx,
  rw add_eq_zero_iff_eq_neg at h,
  rw h,
  exact add_to_sub,
end

/- If a function is commutative, we can change the order of the indexes in a double sum -/
lemma change_index {s₁ s₂ : finset ℝ} {f : ℝ → ℝ → ℝ} : (∀ x y : ℝ, f x y = f y x) → ∑ x in s₁, ∑ y in s₂, f x y = ∑ x in s₂, ∑ y in s₁, f x y :=
begin
  intro h_comm,
  rw ← sum_product',
  rw sum_product_right,
  apply sum_eq_sum,
  intros x hx,
  apply sum_eq_sum,
  intros y hy,
  exact h_comm y x,
end

lemma le_sum_of_single {r : ℝ} {s : finset ℝ} {f : ℝ → ℝ} : (0 ≤ f ∧ ∃ x, x ∈ s ∧ r ≤ f x) → r ≤ ∑ x in s, f x :=
begin
  rintros ⟨f_nonneg, x, h_in, hx⟩,
  apply le_trans hx,
  rw sum_eq_sum_diff_singleton_add h_in,
  simp,
  apply sum_nonneg,
  intros y hy,
  specialize f_nonneg y,
  simp at f_nonneg,
  exact f_nonneg,
end

lemma sum_union' {f : ℝ → ℝ → ℝ} {s : finset ℝ} {r : ℝ} (h_in : r ∈ s) (h_comm : ∀ x y : ℝ, f x y = f y x) : ∑ x y in s, f x y = ∑ x y in s \ {r}, f x y + 2 * ∑ x in s \ {r}, f r x + f r r :=
begin
  have h₁ := sum_eq_sum_diff_singleton_add h_in (f r),
  have h₂ := sum_eq_sum_diff_singleton_add h_in (λ x, ∑ y in s, f x y),
  simp at h₂,
  rw h₁ at h₂,
  rw h₂,
  clear h₂,
  rw← add_assoc,
  simp,
  rw change_index h_comm,
  have h₃ := sum_eq_sum_diff_singleton_add h_in (λ x, ∑ y in s \ {r}, f x y),
  simp at h₃,
  rw h₃,
  ring,
end

lemma sum_union'' {f : ℝ → ℝ → ℝ} {s : finset ℝ} (r₁ r₂ : ℝ) (h_in : r₁ ∈ s ∧ r₂ ∈ s ∧ r₁ ≠ r₂) (h_comm : ∀ x y : ℝ, f x y = f y x) : ∑ x y in s, f x y = ∑ x y in s \ {r₁, r₂}, f x y + 2 * ∑ x in s \ {r₁, r₂}, f r₁ x + 2 * ∑ x in s \ {r₁, r₂}, f r₂ x + f r₁ r₁ + f r₂ r₂ + 2*f r₁ r₂ :=
begin
  have h₁ := @sum_union' f s r₁ (by tidy) h_comm,
  have h₂ := @sum_union' f (s \ {r₁}) r₂ (by tidy) h_comm,
  rw h₁,
  clear h₁,
  rw h₂,
  clear h₂,
  rcases h_in with ⟨h_r₁, h_r₂, h_ne⟩,
  have h : r₂ ∈ s \ {r₁} := by tidy,
  have h₃ := sum_eq_sum_diff_singleton_add h (f r₁),
  rw h₃,
  have : s \ {r₁} \ {r₂} = s \ {r₁, r₂} := by tidy,
  rw this,
  ring,
end

lemma sum_map' (i : ℝ ↪ ℝ) {s : finset ℝ} {f : ℝ → ℝ → ℝ} : ∑ x y in map i s, f x y = ∑ x y in s, f (i x) (i y) :=
begin rw [sum_map, sum_eq_sum], intros x hx, rw sum_map end

lemma sum_add_distrib' {s : finset ℝ} {f g : ℝ → ℝ → ℝ} : ∑ x y in s, f x y + ∑ x y in s, g x y = ∑ x y in s, (f x y + g x y) :=
begin
  rw ← sum_add_distrib,
  apply sum_eq_sum,
  intros x hx,
  rw ← sum_add_distrib,
end

/-
 # Analysis requirements

  Surprisingly we will need some facts from analysis to solve this problem. We prove that a relevant function has a global minimum and we will also use that the square root is a concave function (separately on each side of the real line) in order to apply jensen's lemma.
-/

/- This is not exactly concavity: It's concavity but only between two points with the same sign -/
def is_concave (f : ℝ → ℝ) : Prop := ∀ x y t : ℝ, t ∈ set.Ioo (0 : ℝ) (1 : ℝ) → 0 < x * y → x ≠ y → f (t * x + (1 - t) * y) > t * f x + (1 - t) * f y

def unbounded (f : ℝ → ℝ) : Prop := ∀ M > 0, ∃ K ≥ 0, ∀ y, K ≤ |y| → M ≤ f y

lemma f_is_unbounded {s : finset ℝ} (hs : s.nonempty) : unbounded (@f_move s) :=
begin
  intros M hM,
  cases hs with x hx,
  use M^2 + |x|,
  split,
  { exact add_nonneg (sq_nonneg M) (abs_nonneg x) },
  {
    intros r hr,
    unfold f_move,
    apply le_sum_of_single,
    split,
    {
      intro x,
      simp,
      apply sum_nonneg,
      intros y hy,
      apply sqrt_nonneg,
    },
    {
      use x,
      split,
      { exact hx },
      {
        apply le_sum_of_single,
        split,
        { intro y, apply sqrt_nonneg, },
        {
          use x,
          split,
          { exact hx },
          {
            unfold f_add,
            ring_nf,
            rw [← mul_add, abs_mul, @sqrt_mul (|2|) (by norm_num)],
            simp,
            have : sqrt (|x + r|) ≤ sqrt 2 * sqrt (|x + r|) :=
            begin
              by_cases sqrt (|x + r|) = 0,
              { rw h, simp },
              {
                have : sqrt (|x + r|) > 0 := begin
                apply lt_of_le_of_ne (sqrt_nonneg _),
                symmetry,
                exact h,
                end,
                rw le_mul_iff_one_le_left this,
                {
                  rw le_sqrt,
                  repeat {norm_num},
                },
              }
            end,
            apply le_trans _ this,
            clear this,
            rw le_sqrt (le_of_lt hM) (abs_nonneg (x + r)),
            have := abs_sub_abs_le_abs_sub r (-x),
            calc
            M^2 ≤ |r| - |x| : le_sub_right_of_add_le hr
            ... ≤ |x + r|   : by simp at *; rw add_comm r x at this; exact this,
          }
        }
      }
    }
  }
end

lemma has_min {f : ℝ → ℝ} {hcont : continuous f} {hubdd : unbounded f} : ∃
x, ∀ y, f x ≤ f y :=
begin
  specialize hubdd (max (f 0) 1) (by norm_num),
  rcases hubdd with ⟨K, K_nonneg, hK⟩,
  set interval := set.Icc (-K) K with h,
  have hnemp : interval.nonempty := begin use 0, rw h, tidy, end,
  have := is_compact.exists_forall_le (is_compact_Icc) hnemp (continuous.continuous_on hcont),
  rcases this with ⟨x, hx, hmin⟩,
  use x,
  intro y,
  by_cases y ∈ interval,
  { exact hmin y h },
  {
    replace h : K ≤ |y| := begin
      by_contradiction h',
      push_neg at h',
      apply h,
      simp,
      rw ← abs_le,
      apply le_of_lt h',
    end,
    specialize hK y h,
    specialize hmin 0 (by tidy),
    apply le_trans hmin (le_trans _ hK),
    exact le_max_left (f 0) 1,
  }
end

lemma sqrt_abs_is_concave : is_concave (λ x, sqrt (|x|)) :=
begin
  intros x y t ht hxy hne,
  simp at *,
  have h₁ : 0 ≤ t * sqrt (|x|) + (1 - t) * sqrt (|y|) :=
  begin
    apply add_nonneg,
    repeat {apply mul_nonneg},
    { exact le_of_lt ht.1},
    { apply sqrt_nonneg },
    { linarith },
    { apply sqrt_nonneg },
  end,
  have h₂ : sqrt (|t * x + (1 - t) * y|) ≥ 0 := by apply sqrt_nonneg,
  rw [← abs_of_nonneg h₁, ← abs_of_nonneg h₂],
  clear h₁ h₂,
  apply abs_lt_abs_of_sq_lt_sq,
  rw [add_sq, mul_pow, mul_pow, sq_sqrt, sq_sqrt, sq_sqrt],
  repeat {apply abs_nonneg},
  rw mul_pos_iff at hxy,
  have : ∀ x y, x > 0 ∧ y > 0 ∧ x ≠ y → t ^ 2 * |x| + 2 * (t * sqrt (|x|)) * ((1 - t) * sqrt (|y|)) + (1 - t) ^ 2 * |y| < |t * x + (1 - t) * y| := begin
    rintros a b ⟨ ha, hb, hne ⟩,
    have : 0 < t*a + (1-t)*b := begin
      apply add_pos,
      repeat {apply mul_pos},
      repeat {linarith},
    end,
    rw [abs_of_pos ha, abs_of_pos hb, abs_of_pos this],
    clear this,
    rw [← add_zero ((1 - t)^2 * b), ← add_assoc],
    apply add_lt_of_lt_sub_left,
    ring_nf,
    have : -a + (-b + 2 * sqrt b * sqrt a) = -(a + (b - 2 * sqrt b * sqrt a)) := by ring,
    rw this,
    apply mul_pos _ ht.1,
    rw ← mul_one (a + (b - 2 * sqrt b * sqrt a)),
    nth_rewrite 0 mul_one,
    rw add_comm _ ((a + (b - 2 * sqrt b * sqrt a)) * 1),
    ring_nf,
    rw ←mul_sub,
    apply mul_pos _,
    { simp, exact ht.2 },
    {
      rw add_sub,
      simp,
      replace this : 2 * sqrt b * sqrt a = sqrt (4*a*b) := begin
        rw [sqrt_mul, sqrt_mul],
        replace this : sqrt 4 = sqrt (2^2) := by norm_num,
        rw [this, sqrt_sq],
        ring_nf,
        norm_num,
        norm_num,
        apply mul_nonneg,
        norm_num,
        exact le_of_lt ha,
      end,
      rw this,
      replace this : a + b = sqrt ((a+b)^2) := begin
        rw sqrt_sq,
        linarith,
      end,
      rw this,
      apply sqrt_lt_sqrt,
      {
        repeat {apply mul_nonneg},
        norm_num,
        repeat {linarith},
      },
      {
        rw [add_sq, ← add_zero (4*a*b)],
        apply add_lt_of_lt_sub_left,
        replace this : a ^ 2 + 2 * a * b + b ^ 2 - 4 * a * b = (a - b)^2 := by ring,
        rw this,
        apply sq_pos_of_ne_zero,
        rw sub_ne_zero,
        exact hne,
      }
    },
  end,
  cases hxy,
  { exact this x y ⟨ hxy.1, hxy.2, hne⟩ },
  {
    set x' := -x with hx',
    set y' := -y with hy',
    have hxy' : 0 < x' ∧ 0 < y' := begin
      rw [hx', hy'],
      simp,
      exact hxy,
    end,
    have hne' : x' ≠ y' := by rw [hx', hy']; simp; exact hne,
    have h': |t * x + (1 - t) * y| = |t * x' + (1 - t) * y'| :=
    calc
      |t * x + (1 - t) * y| = | -(t * x + (1 - t) * y)| : by rw ← abs_neg
      ... = |t * (-x) + (1 - t) * (-y)| : by ring_nf
      ... = |t * x' + (1 - t) * y'|     : by rw [hx', hy'],
    rw [h', abs_of_neg hxy.1, abs_of_neg hxy.2, ← hx', ← hy'],
    nth_rewrite 0 ← abs_of_pos hxy'.1,
    nth_rewrite 1 ← abs_of_pos hxy'.1,
    nth_rewrite 0 ← abs_of_pos hxy'.2,
    nth_rewrite 1 ← abs_of_pos hxy'.2,
    exact this x' y' ⟨hxy'.1, hxy'.2, hne'⟩,
  }
end

/- Jensen's inequality for two points -/
lemma jensen {f : ℝ → ℝ} (h : is_concave f) : ∀ x y, x * y > 0 ∧ x ≠ y → f x + f y < 2 * f ((x + y)/2) :=
begin
  rintros x y ⟨hxy,hne⟩,
  specialize h x y (1/2) (by norm_num) hxy hne,
  norm_num at h,
  rw ← @mul_lt_mul_left _ _ _ _ (2 : ℝ) (by norm_num) at h,
  rw [mul_add, ← mul_assoc, ← mul_assoc, ← mul_add (1 / 2) x y] at h,
  simp at h,
  rw div_eq_mul_inv,
  nth_rewrite 1 mul_comm,
  exact h,
end

lemma epsilon_little_enough (x ε : ℝ) : x ≠ 0 → ε > 0 → ε < |x| → 0 < (x + ε)*(x - ε) :=
begin
  intros hne ε_pos hle,
  rw [add_mul,  mul_sub, mul_sub],
  ring_nf,
  simp,
  apply sq_lt_sq,
  rw ← abs_of_pos ε_pos at hle,
  exact hle,
end

/- If a collection of real numbers has no zeroes, we can choose a positive epsilon little enough so that these numbers plus or minus this epsilon, stay with the same sign -/
lemma exists_epsilon_forall (s : finset ℝ) (hnemp : s.nonempty) (r : ℝ) : (∀ x y, x ∈ s → y ∈ s → x + r + (y + r) ≠ 0) → ∃ ε : ℝ, ε > 0 ∧ ∀ x y, x ∈ s → y ∈ s → 0 < (x + (r + ε) + (y + (r + ε)))*(x + (r - ε) + (y + (r - ε))) :=
begin
  intro hs,
  set f : ℝ × ℝ → ℝ := λ x, |x.fst + r + (x.snd + r)| / 4 with hf,
  set s' : finset(ℝ) := finset.image f (finset.product s s) with hs',
  have hnemp' : s'.nonempty := begin
    cases hnemp with x hx,
    use f (x, x),
    rw mem_image,
    use (x,x),
    tidy,
  end,
  set ε := finset.min' s' hnemp' with hε,
  have ε_pos : ε > 0 := begin
    have := min'_mem s' hnemp',
    rw mem_image at this,
    rcases this with ⟨a, a_in, ha⟩,
    rw [hε, ← ha],
    simp [f],
    apply div_pos,
    {
        apply lt_of_le_of_ne,
        { apply abs_nonneg },
        {
          symmetry,
          intro h,
          rw abs_eq_zero at h,
          simp at a_in,
          exact hs a.fst a.snd a_in.1 a_in.2 h,
        }
      },
      { norm_num, }
  end,
  use ε,
  split,
  { exact ε_pos },
  {
    intros x y hx hy,
    have : ε ≤ |x + r + (y + r)| / 4 := begin
      have := min'_le s',
      have hin : |x + r + (y + r)| / 4 ∈ s' := begin
        rw mem_image,
        use (x,y),
        split,
        { tidy },
        { rw hf },
      end,
      specialize this (|x + r + (y + r)| / 4) hin,
      rw hε,
      exact this,
    end,
    specialize hs x y hx hy,
    have haux : (x + (r + ε) + (y + (r + ε))) * (x + (r - ε) + (y + (r - ε))) = (x + r + (y + r) + 2*ε) * (x + r + (y + r) - 2*ε) := by ring_nf,
    rw haux,
    apply epsilon_little_enough (x + r + (y + r)) (2*ε) hs,
    {
      apply mul_pos,
      norm_num,
      exact ε_pos,
    },
    { linarith [this] }
  }
end

/- The problem we want to solve -/

theorem problem2 (n : ℕ) : ∀ s : finset ℝ, s.card = n → ∑ x y in s, f_sub x y ≤ ∑ x y in s, f_add x y :=
begin
  induction n using nat.two_step_induction with n hn2 hn1,
  {
    intros s hs,
    rw finset.card_eq_zero at hs,
    rw hs,
    simp,
  },
  {
    intros s hs,
    rw card_eq_one at hs,
    cases hs with r h,
    rw h,
    simp,
    apply sqrt_nonneg,
  },
  {
    intros s hs,
    have hnemp : s.nonempty := begin rw [← finset.card_pos, hs], norm_num, end,
    cases @has_min (@f_move s) (by continuity) (f_is_unbounded hnemp) with r_min hrmin,
    have := hrmin 0,
    unfold f_move at this,
    simp at this,
    apply le_trans _ this,
    clear this,
    by_cases h₁ : (∃ x : ℝ, x ∈ s ∧ x + r_min = 0),
    {
      clear hn2 hrmin,
      cases h₁ with x hx,
      set f : ℝ ↪ ℝ := begin
        refine { to_fun := λ x, x + r_min, inj' := _ },
        intros a b,
        simp,
      end with hf,
      set s' := map f (s \ {x}) with hs',
      specialize hn1 s',
      have hcard : s'.card = n.succ := begin
        have h : {x} ⊆ s := by tidy,
        rw [hs', card_map, card_sdiff h, hs],
        simp,
      end,
      specialize hn1 hcard,
      rw [sum_map', sum_map'] at hn1,
      simp at hn1,
      rw sum_union' hx.1 f_sub_comm,
      have := sum_union' hx.1 (f_add_move_comm r_min),
      simp at this,
      rw this,
      clear this,
      unfold f_add,
      simp,
      rw [← sum_f_sub_move r_min, hx.2],
      simp,
      assumption,
    },
    {
      push_neg at h₁,
      by_cases h₂ : (∃ x y : ℝ, x ∈ s ∧ y ∈ s ∧ x + r_min + (y + r_min) = 0),
      {
        clear hn1,
        rcases h₂ with ⟨x, y, hx, hy, hxy⟩,
        have hne : x ≠ y := begin
          intro heq,
          rw heq at hxy,
          simp at hxy,
          exact h₁ y hy hxy,
        end,
        set f : ℝ ↪ ℝ := begin
        refine { to_fun := λ x, x + r_min, inj' := _ },
        intros a b,
        simp,
        end with hf,
        specialize hn2 (map f (s \ {x, y})),
        have : (map f (s \ {x, y})).card = n := begin
          rw card_map,
          have : {x,y} ⊆ s := by tidy,
          rw [card_sdiff this, hs, card_insert_of_not_mem],
          simp,
          tidy,
        end,
        specialize hn2 this,
        clear this,
        rw [sum_map', sum_map'] at hn2,
        simp at hn2,
        rw [sum_union'' x y ⟨hx, hy, hne⟩ (f_add_move_comm r_min)],
        dsimp,
        rw sum_add_to_sum_sub hxy,
        have dx : x + r_min = -(y + r_min) := eq_neg_of_add_eq_zero hxy,
        rw add_comm at hxy,
        have dy : y + r_min = -(x + r_min) := eq_neg_of_add_eq_zero hxy,
        rw sum_add_to_sum_sub hxy,
        nth_rewrite 0 dx,
        nth_rewrite 2 dy,
        rw [f_add_comm (y + r_min), add_to_sub, add_to_sub],
        unfold f_add,
        rw add_comm at hxy,
        rw hxy,
        simp [f_sub_comm],
        rw sum_union'' x y ⟨hx, hy, hne⟩ f_sub_comm,
        simp,
        apply add_le_of_le_sub_right,
        ring_nf,
        apply add_le_of_le_sub_right,
        simp,
        exact hn2,
      },
      {
        clear hn1 hn2 h₁,
        push_neg at h₂,
        exfalso,
        have hε := exists_epsilon_forall s hnemp r_min h₂,
        rcases hε with ⟨ ε, ε_pos, hε ⟩,
        have h₃ : @f_move s (r_min + ε) + @f_move s (r_min - ε) < 2 * @f_move s r_min := begin
          unfold f_move,
          rw [sum_add_distrib', mul_sum],
          apply sum_lt_sum_of_nonempty hnemp,
          intros x hx,
          rw mul_sum,
          apply sum_lt_sum_of_nonempty hnemp,
          intros y hy,
          have : x + (r_min + ε) + (y + (r_min + ε)) ≠ x + (r_min - ε) + (y + (r_min - ε)) := by linarith,
          replace this := jensen sqrt_abs_is_concave (x + (r_min + ε) + (y + (r_min + ε))) (x + (r_min - ε) + (y + (r_min - ε))) ⟨hε x y hx hy, this⟩,
          have haux : (x + (r_min + ε) + (y + (r_min + ε)) + (x + (r_min - ε) + (y + (r_min - ε)))) / 2 = x + r_min + (y + r_min) := by ring,
          rw haux at this,
          unfold f_add,
          exact this,
        end,
        have h₄ : @f_move s (r_min + ε) < @f_move s r_min ∨ @f_move s (r_min - ε) < @f_move s r_min := left_lt_or_right_lt_of_add_lt_two_mul h₃,
        cases h₄,
        {
          specialize hrmin (r_min + ε),
          linarith,
        },
        {
          specialize hrmin (r_min - ε),
          linarith,
        },
      }
    }
  }
end


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

! This file was ported from Lean 3 source module linear_algebra.clifford_algebra.contraction
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.ExteriorAlgebra.Basic
import Mathbin.LinearAlgebra.CliffordAlgebra.Fold
import Mathbin.LinearAlgebra.CliffordAlgebra.Conjugation

/-!
# Contraction in Clifford Algebras

This file contains some of the results from [grinberg_clifford_2016][].
The key result is `clifford_algebra.equiv_exterior`.

## Main definitions

* `clifford_algebra.contract_left`: contract a multivector by a `module.dual R M` on the left.
* `clifford_algebra.contract_right`: contract a multivector by a `module.dual R M` on the right.
* `clifford_algebra.change_form`: convert between two algebras of different quadratic form, sending
  vectors to vectors. The difference of the quadratic forms must be a bilinear form.
* `clifford_algebra.equiv_exterior`: in characteristic not-two, the `clifford_algebra Q` is
  isomorphic as a module to the exterior algebra.

## Implementation notes

This file somewhat follows [grinberg_clifford_2016][], although we are missing some of the induction
principles needed to prove many of the results. Here, we avoid the quotient-based approach described
in [grinberg_clifford_2016][], instead directly constructing our objects using the universal
property.

Note that [grinberg_clifford_2016][] concludes that its contents are not novel, and are in fact just
a rehash of parts of [bourbaki2007][]; we should at some point consider swapping our references to
refer to the latter.

Within this file, we use the local notation
* `x ⌊ d` for `contract_right x d`
* `d ⌋ x` for `contract_left d x`

-/

universe u1 u2 u3

variable {R : Type u1} [CommRing R]

variable {M : Type u2} [AddCommGroup M] [Module R M]

variable (Q : QuadraticForm R M)

namespace CliffordAlgebra

section ContractLeft

variable (d d' : Module.Dual R M)

/-- Auxiliary construction for `clifford_algebra.contract_left` -/
@[simps]
def contractLeftAux (d : Module.Dual R M) :
    M →ₗ[R] CliffordAlgebra Q × CliffordAlgebra Q →ₗ[R] CliffordAlgebra Q :=
  haveI v_mul := (LinearMap.Algebra.lmul R (CliffordAlgebra Q)).toLinearMap ∘ₗ ι Q
  d.smul_right (LinearMap.fst _ (CliffordAlgebra Q) (CliffordAlgebra Q)) -
    v_mul.compl₂ (LinearMap.snd _ (CliffordAlgebra Q) _)
#align clifford_algebra.contract_left_aux CliffordAlgebra.contractLeftAux

theorem contractLeftAux_contractLeftAux (v : M) (x : CliffordAlgebra Q) (fx : CliffordAlgebra Q) :
    contractLeftAux Q d v (ι Q v * x, contractLeftAux Q d v (x, fx)) = Q v • fx :=
  by
  simp only [contract_left_aux_apply_apply]
  rw [mul_sub, ← mul_assoc, ι_sq_scalar, ← Algebra.smul_def, ← sub_add, mul_smul_comm, sub_self,
    zero_add]
#align clifford_algebra.contract_left_aux_contract_left_aux CliffordAlgebra.contractLeftAux_contractLeftAux

variable {Q}

/-- Contract an element of the clifford algebra with an element `d : module.dual R M` from the left.

Note that $v ⌋ x$ is spelt `contract_left (Q.associated v) x`.

This includes [grinberg_clifford_2016][] Theorem 10.75 -/
def contractLeft : Module.Dual R M →ₗ[R] CliffordAlgebra Q →ₗ[R] CliffordAlgebra Q
    where
  toFun d := foldr' Q (contractLeftAux Q d) (contractLeftAux_contractLeftAux Q d) 0
  map_add' d₁ d₂ :=
    LinearMap.ext fun x => by
      rw [LinearMap.add_apply]
      induction' x using CliffordAlgebra.leftInduction with r x y hx hy m x hx
      · simp_rw [foldr'_algebra_map, smul_zero, zero_add]
      · rw [map_add, map_add, map_add, add_add_add_comm, hx, hy]
      · rw [foldr'_ι_mul, foldr'_ι_mul, foldr'_ι_mul, hx]
        dsimp only [contract_left_aux_apply_apply]
        rw [sub_add_sub_comm, mul_add, LinearMap.add_apply, add_smul]
  map_smul' c d :=
    LinearMap.ext fun x => by
      rw [LinearMap.smul_apply, RingHom.id_apply]
      induction' x using CliffordAlgebra.leftInduction with r x y hx hy m x hx
      · simp_rw [foldr'_algebra_map, smul_zero]
      · rw [map_add, map_add, smul_add, hx, hy]
      · rw [foldr'_ι_mul, foldr'_ι_mul, hx]
        dsimp only [contract_left_aux_apply_apply]
        rw [LinearMap.smul_apply, smul_assoc, mul_smul_comm, smul_sub]
#align clifford_algebra.contract_left CliffordAlgebra.contractLeft

/-- Contract an element of the clifford algebra with an element `d : module.dual R M` from the
right.

Note that $x ⌊ v$ is spelt `contract_right x (Q.associated v)`.

This includes [grinberg_clifford_2016][] Theorem 16.75 -/
def contractRight : CliffordAlgebra Q →ₗ[R] Module.Dual R M →ₗ[R] CliffordAlgebra Q :=
  LinearMap.flip (LinearMap.compl₂ (LinearMap.compr₂ contractLeft reverse) reverse)
#align clifford_algebra.contract_right CliffordAlgebra.contractRight

theorem contractRight_eq (x : CliffordAlgebra Q) :
    contractRight x d = reverse (contractLeft d <| reverse x) :=
  rfl
#align clifford_algebra.contract_right_eq CliffordAlgebra.contractRight_eq

-- mathport name: «expr ⌋ »
local infixl:70 "⌋" => contractLeft

-- mathport name: «expr ⌊ »
local infixl:70 "⌊" => contractRight

/-- This is [grinberg_clifford_2016][] Theorem 6  -/
theorem contractLeft_ι_mul (a : M) (b : CliffordAlgebra Q) :
    d⌋(ι Q a * b) = d a • b - ι Q a * (d⌋b) :=
  foldr'_ι_mul _ _ _ _ _ _
#align clifford_algebra.contract_left_ι_mul CliffordAlgebra.contractLeft_ι_mul

/-- This is [grinberg_clifford_2016][] Theorem 12  -/
theorem contractRight_mul_ι (a : M) (b : CliffordAlgebra Q) : b * ι Q a⌊d = d a • b - b⌊d * ι Q a :=
  by
  rw [contract_right_eq, reverse.map_mul, reverse_ι, contract_left_ι_mul, map_sub, map_smul,
    reverse_reverse, reverse.map_mul, reverse_ι, contract_right_eq]
#align clifford_algebra.contract_right_mul_ι CliffordAlgebra.contractRight_mul_ι

theorem contractLeft_algebraMap_mul (r : R) (b : CliffordAlgebra Q) :
    d⌋(algebraMap _ _ r * b) = algebraMap _ _ r * (d⌋b) := by
  rw [← Algebra.smul_def, map_smul, Algebra.smul_def]
#align clifford_algebra.contract_left_algebra_map_mul CliffordAlgebra.contractLeft_algebraMap_mul

theorem contractLeft_mul_algebraMap (a : CliffordAlgebra Q) (r : R) :
    d⌋(a * algebraMap _ _ r) = d⌋a * algebraMap _ _ r := by
  rw [← Algebra.commutes, contract_left_algebra_map_mul, Algebra.commutes]
#align clifford_algebra.contract_left_mul_algebra_map CliffordAlgebra.contractLeft_mul_algebraMap

theorem contractRight_algebraMap_mul (r : R) (b : CliffordAlgebra Q) :
    algebraMap _ _ r * b⌊d = algebraMap _ _ r * (b⌊d) := by
  rw [← Algebra.smul_def, LinearMap.map_smul₂, Algebra.smul_def]
#align clifford_algebra.contract_right_algebra_map_mul CliffordAlgebra.contractRight_algebraMap_mul

theorem contractRight_mul_algebraMap (a : CliffordAlgebra Q) (r : R) :
    a * algebraMap _ _ r⌊d = a⌊d * algebraMap _ _ r := by
  rw [← Algebra.commutes, contract_right_algebra_map_mul, Algebra.commutes]
#align clifford_algebra.contract_right_mul_algebra_map CliffordAlgebra.contractRight_mul_algebraMap

variable (Q)

@[simp]
theorem contractLeft_ι (x : M) : d⌋ι Q x = algebraMap R _ (d x) :=
  (foldr'_ι _ _ _ _ _).trans <| by
    simp_rw [contract_left_aux_apply_apply, MulZeroClass.mul_zero, sub_zero,
      Algebra.algebraMap_eq_smul_one]
#align clifford_algebra.contract_left_ι CliffordAlgebra.contractLeft_ι

@[simp]
theorem contractRight_ι (x : M) : ι Q x⌊d = algebraMap R _ (d x) := by
  rw [contract_right_eq, reverse_ι, contract_left_ι, reverse.commutes]
#align clifford_algebra.contract_right_ι CliffordAlgebra.contractRight_ι

@[simp]
theorem contractLeft_algebraMap (r : R) : d⌋algebraMap R (CliffordAlgebra Q) r = 0 :=
  (foldr'_algebraMap _ _ _ _ _).trans <| smul_zero _
#align clifford_algebra.contract_left_algebra_map CliffordAlgebra.contractLeft_algebraMap

@[simp]
theorem contractRight_algebraMap (r : R) : algebraMap R (CliffordAlgebra Q) r⌊d = 0 := by
  rw [contract_right_eq, reverse.commutes, contract_left_algebra_map, map_zero]
#align clifford_algebra.contract_right_algebra_map CliffordAlgebra.contractRight_algebraMap

@[simp]
theorem contractLeft_one : d⌋(1 : CliffordAlgebra Q) = 0 := by
  simpa only [map_one] using contract_left_algebra_map Q d 1
#align clifford_algebra.contract_left_one CliffordAlgebra.contractLeft_one

@[simp]
theorem contractRight_one : (1 : CliffordAlgebra Q)⌊d = 0 := by
  simpa only [map_one] using contract_right_algebra_map Q d 1
#align clifford_algebra.contract_right_one CliffordAlgebra.contractRight_one

variable {Q}

/-- This is [grinberg_clifford_2016][] Theorem 7 -/
theorem contractLeft_contractLeft (x : CliffordAlgebra Q) : d⌋(d⌋x) = 0 :=
  by
  induction' x using CliffordAlgebra.leftInduction with r x y hx hy m x hx
  · simp_rw [contract_left_algebra_map, map_zero]
  · rw [map_add, map_add, hx, hy, add_zero]
  ·
    rw [contract_left_ι_mul, map_sub, contract_left_ι_mul, hx, LinearMap.map_smul,
      MulZeroClass.mul_zero, sub_zero, sub_self]
#align clifford_algebra.contract_left_contract_left CliffordAlgebra.contractLeft_contractLeft

/-- This is [grinberg_clifford_2016][] Theorem 13 -/
theorem contractRight_contractRight (x : CliffordAlgebra Q) : x⌊d⌊d = 0 := by
  rw [contract_right_eq, contract_right_eq, reverse_reverse, contract_left_contract_left, map_zero]
#align clifford_algebra.contract_right_contract_right CliffordAlgebra.contractRight_contractRight

/-- This is [grinberg_clifford_2016][] Theorem 8 -/
theorem contractLeft_comm (x : CliffordAlgebra Q) : d⌋(d'⌋x) = -(d'⌋(d⌋x)) :=
  by
  induction' x using CliffordAlgebra.leftInduction with r x y hx hy m x hx
  · simp_rw [contract_left_algebra_map, map_zero, neg_zero]
  · rw [map_add, map_add, map_add, map_add, hx, hy, neg_add]
  · simp only [contract_left_ι_mul, map_sub, LinearMap.map_smul]
    rw [neg_sub, sub_sub_eq_add_sub, hx, mul_neg, ← sub_eq_add_neg]
#align clifford_algebra.contract_left_comm CliffordAlgebra.contractLeft_comm

/-- This is [grinberg_clifford_2016][] Theorem 14 -/
theorem contractRight_comm (x : CliffordAlgebra Q) : x⌊d⌊d' = -(x⌊d'⌊d) := by
  rw [contract_right_eq, contract_right_eq, contract_right_eq, contract_right_eq, reverse_reverse,
    reverse_reverse, contract_left_comm, map_neg]
#align clifford_algebra.contract_right_comm CliffordAlgebra.contractRight_comm

/- TODO:
lemma contract_right_contract_left (x : clifford_algebra Q) : (d ⌋ x) ⌊ d' = d ⌋ (x ⌊ d') :=
-/
end ContractLeft

-- mathport name: «expr ⌋ »
local infixl:70 "⌋" => contractLeft

-- mathport name: «expr ⌊ »
local infixl:70 "⌊" => contractRight

/-- Auxiliary construction for `clifford_algebra.change_form` -/
@[simps]
def changeFormAux (B : BilinForm R M) : M →ₗ[R] CliffordAlgebra Q →ₗ[R] CliffordAlgebra Q :=
  haveI v_mul := (LinearMap.Algebra.lmul R (CliffordAlgebra Q)).toLinearMap ∘ₗ ι Q
  v_mul - contract_left ∘ₗ B.to_lin
#align clifford_algebra.change_form_aux CliffordAlgebra.changeFormAux

theorem changeFormAux_changeFormAux (B : BilinForm R M) (v : M) (x : CliffordAlgebra Q) :
    changeFormAux Q B v (changeFormAux Q B v x) = (Q v - B v v) • x :=
  by
  simp only [change_form_aux_apply_apply]
  rw [mul_sub, ← mul_assoc, ι_sq_scalar, map_sub, contract_left_ι_mul, ← sub_add, sub_sub_sub_comm,
    ← Algebra.smul_def, BilinForm.toLin_apply, sub_self, sub_zero, contract_left_contract_left,
    add_zero, sub_smul]
#align clifford_algebra.change_form_aux_change_form_aux CliffordAlgebra.changeFormAux_changeFormAux

variable {Q}

variable {Q' Q'' : QuadraticForm R M} {B B' : BilinForm R M}

variable (h : B.toQuadraticForm = Q' - Q) (h' : B'.toQuadraticForm = Q'' - Q')

/-- Convert between two algebras of different quadratic form, sending vector to vectors, scalars to
scalars, and adjusting products by a contraction term.

This is $\lambda_B$ from [bourbaki2007][] $9 Lemma 2. -/
def changeForm (h : B.toQuadraticForm = Q' - Q) : CliffordAlgebra Q →ₗ[R] CliffordAlgebra Q' :=
  foldr Q (changeFormAux Q' B)
    (fun m x =>
      (changeFormAux_changeFormAux Q' B m x).trans <|
        by
        dsimp [← BilinForm.toQuadraticForm_apply]
        rw [h, QuadraticForm.sub_apply, sub_sub_cancel])
    1
#align clifford_algebra.change_form CliffordAlgebra.changeForm

/-- Auxiliary lemma used as an argument to `clifford_algebra.change_form` -/
theorem changeForm.zero_proof : (0 : BilinForm R M).toQuadraticForm = Q - Q :=
  (sub_self _).symm
#align clifford_algebra.change_form.zero_proof CliffordAlgebra.changeForm.zero_proof

/-- Auxiliary lemma used as an argument to `clifford_algebra.change_form` -/
theorem changeForm.add_proof : (B + B').toQuadraticForm = Q'' - Q :=
  (congr_arg₂ (· + ·) h h').trans <| sub_add_sub_cancel' _ _ _
#align clifford_algebra.change_form.add_proof CliffordAlgebra.changeForm.add_proof

/-- Auxiliary lemma used as an argument to `clifford_algebra.change_form` -/
theorem changeForm.neg_proof : (-B).toQuadraticForm = Q - Q' :=
  (congr_arg Neg.neg h).trans <| neg_sub _ _
#align clifford_algebra.change_form.neg_proof CliffordAlgebra.changeForm.neg_proof

theorem changeForm.associated_neg_proof [Invertible (2 : R)] :
    (-Q).Associated.toQuadraticForm = 0 - Q := by simp [QuadraticForm.toQuadraticForm_associated]
#align clifford_algebra.change_form.associated_neg_proof CliffordAlgebra.changeForm.associated_neg_proof

@[simp]
theorem changeForm_algebraMap (r : R) : changeForm h (algebraMap R _ r) = algebraMap R _ r :=
  (foldr_algebraMap _ _ _ _ _).trans <| Eq.symm <| Algebra.algebraMap_eq_smul_one r
#align clifford_algebra.change_form_algebra_map CliffordAlgebra.changeForm_algebraMap

@[simp]
theorem changeForm_one : changeForm h (1 : CliffordAlgebra Q) = 1 := by
  simpa using change_form_algebra_map h (1 : R)
#align clifford_algebra.change_form_one CliffordAlgebra.changeForm_one

@[simp]
theorem changeForm_ι (m : M) : changeForm h (ι _ m) = ι _ m :=
  (foldr_ι _ _ _ _ _).trans <|
    Eq.symm <| by rw [change_form_aux_apply_apply, mul_one, contract_left_one, sub_zero]
#align clifford_algebra.change_form_ι CliffordAlgebra.changeForm_ι

theorem changeForm_ι_mul (m : M) (x : CliffordAlgebra Q) :
    changeForm h (ι _ m * x) = ι _ m * changeForm h x - BilinForm.toLin B m⌋changeForm h x :=
  (foldr_mul _ _ _ _ _ _).trans <| by rw [foldr_ι]; rfl
#align clifford_algebra.change_form_ι_mul CliffordAlgebra.changeForm_ι_mul

theorem changeForm_ι_mul_ι (m₁ m₂ : M) :
    changeForm h (ι _ m₁ * ι _ m₂) = ι _ m₁ * ι _ m₂ - algebraMap _ _ (B m₁ m₂) := by
  rw [change_form_ι_mul, change_form_ι, contract_left_ι, BilinForm.toLin_apply]
#align clifford_algebra.change_form_ι_mul_ι CliffordAlgebra.changeForm_ι_mul_ι

/-- Theorem 23 of [grinberg_clifford_2016][] -/
theorem changeForm_contractLeft (d : Module.Dual R M) (x : CliffordAlgebra Q) :
    changeForm h (d⌋x) = d⌋changeForm h x :=
  by
  induction' x using CliffordAlgebra.leftInduction with r x y hx hy m x hx
  · simp only [contract_left_algebra_map, change_form_algebra_map, map_zero]
  · rw [map_add, map_add, map_add, map_add, hx, hy]
  · simp only [contract_left_ι_mul, change_form_ι_mul, map_sub, LinearMap.map_smul]
    rw [← hx, contract_left_comm, ← sub_add, sub_neg_eq_add, ← hx]
#align clifford_algebra.change_form_contract_left CliffordAlgebra.changeForm_contractLeft

theorem changeForm_self_apply (x : CliffordAlgebra Q) : changeForm changeForm.zero_proof x = x :=
  by
  induction' x using CliffordAlgebra.leftInduction with r x y hx hy m x hx
  · simp_rw [change_form_algebra_map]
  · rw [map_add, hx, hy]
  ·
    rw [change_form_ι_mul, hx, map_zero, LinearMap.zero_apply, map_zero, LinearMap.zero_apply,
      sub_zero]
#align clifford_algebra.change_form_self_apply CliffordAlgebra.changeForm_self_apply

@[simp]
theorem changeForm_self :
    changeForm changeForm.zero_proof = (LinearMap.id : CliffordAlgebra Q →ₗ[R] _) :=
  LinearMap.ext <| changeForm_self_apply
#align clifford_algebra.change_form_self CliffordAlgebra.changeForm_self

/-- This is [bourbaki2007][] $9 Lemma 3. -/
theorem changeForm_changeForm (x : CliffordAlgebra Q) :
    changeForm h' (changeForm h x) = changeForm (changeForm.add_proof h h') x :=
  by
  induction' x using CliffordAlgebra.leftInduction with r x y hx hy m x hx
  · simp_rw [change_form_algebra_map]
  · rw [map_add, map_add, map_add, hx, hy]
  ·
    rw [change_form_ι_mul, map_sub, change_form_ι_mul, change_form_ι_mul, hx, sub_sub, map_add,
      LinearMap.add_apply, map_add, LinearMap.add_apply, change_form_contract_left, hx,
      add_comm (_ : CliffordAlgebra Q'')]
#align clifford_algebra.change_form_change_form CliffordAlgebra.changeForm_changeForm

theorem changeForm_comp_changeForm :
    (changeForm h').comp (changeForm h) = changeForm (changeForm.add_proof h h') :=
  LinearMap.ext <| changeForm_changeForm _ _
#align clifford_algebra.change_form_comp_change_form CliffordAlgebra.changeForm_comp_changeForm

/-- Any two algebras whose quadratic forms differ by a bilinear form are isomorphic as modules.

This is $\bar \lambda_B$ from [bourbaki2007][] $9 Proposition 3. -/
@[simps apply]
def changeFormEquiv : CliffordAlgebra Q ≃ₗ[R] CliffordAlgebra Q' :=
  { changeForm h with
    toFun := changeForm h
    invFun := changeForm (changeForm.neg_proof h)
    left_inv := fun x =>
      (changeForm_changeForm _ _ x).trans <| by simp_rw [add_right_neg, change_form_self_apply]
    right_inv := fun x =>
      (changeForm_changeForm _ _ x).trans <| by simp_rw [add_left_neg, change_form_self_apply] }
#align clifford_algebra.change_form_equiv CliffordAlgebra.changeFormEquiv

@[simp]
theorem changeFormEquiv_symm :
    (changeFormEquiv h).symm = changeFormEquiv (changeForm.neg_proof h) :=
  LinearEquiv.ext fun x => (rfl : changeForm _ x = changeForm _ x)
#align clifford_algebra.change_form_equiv_symm CliffordAlgebra.changeFormEquiv_symm

variable (Q)

/-- The module isomorphism to the exterior algebra.

Note that this holds more generally when `Q` is divisible by two, rather than only when `1` is
divisible by two; but that would be more awkward to use. -/
@[simp]
def equivExterior [Invertible (2 : R)] : CliffordAlgebra Q ≃ₗ[R] ExteriorAlgebra R M :=
  changeFormEquiv changeForm.associated_neg_proof
#align clifford_algebra.equiv_exterior CliffordAlgebra.equivExterior

end CliffordAlgebra


/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Junyan Xu, Jack McKoen
-/
import ring_theory.valuation.valuation_ring
import ring_theory.localization.as_subring
import ring_theory.subring.pointwise
import algebraic_geometry.prime_spectrum.basic

/-!

# Valuation subrings of a field

## Projects

The order structure on `valuation_subring K`.

-/

open_locale classical
noncomputable theory

variables (K : Type*) [field K]

/-- A valuation subring of a field `K` is a subring `A` such that for every `x : K`,
either `x ∈ A` or `x⁻¹ ∈ A`. -/
structure valuation_subring extends subring K :=
(mem_or_inv_mem' : ∀ x : K, x ∈ carrier ∨ x⁻¹ ∈ carrier)

namespace valuation_subring

variables {K} (A : valuation_subring K)

instance : set_like (valuation_subring K) K :=
{ coe := λ A, A.to_subring,
  coe_injective' := by { rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ _, congr' } }

@[simp] lemma mem_carrier (x : K) : x ∈ A.carrier ↔ x ∈ A := iff.refl _
@[simp] lemma mem_to_subring (x : K) : x ∈ A.to_subring ↔ x ∈ A := iff.refl _

@[ext] lemma ext (A B : valuation_subring K)
  (h : ∀ x, x ∈ A ↔ x ∈ B) : A = B := set_like.ext h

lemma zero_mem : (0 : K) ∈ A := A.to_subring.zero_mem
lemma one_mem : (1 : K) ∈ A := A.to_subring.one_mem
lemma add_mem (x y : K) : x ∈ A → y ∈ A → x + y ∈ A := A.to_subring.add_mem
lemma mul_mem (x y : K) : x ∈ A → y ∈ A → x * y ∈ A := A.to_subring.mul_mem
lemma neg_mem (x : K) : x ∈ A → (-x) ∈ A := A.to_subring.neg_mem

lemma mem_or_inv_mem (x : K) : x ∈ A ∨ x⁻¹ ∈ A := A.mem_or_inv_mem' _

instance : subring_class (valuation_subring K) K :=
{ zero_mem := zero_mem,
  add_mem := add_mem,
  one_mem := one_mem,
  mul_mem := mul_mem,
  neg_mem := neg_mem }

lemma to_subring_injective : function.injective (to_subring : valuation_subring K → subring K) :=
λ x y h, by { cases x, cases y, congr' }

instance : comm_ring A := show comm_ring A.to_subring, by apply_instance
instance : is_domain A := show is_domain A.to_subring, by apply_instance

instance : has_top (valuation_subring K) := has_top.mk $
{ mem_or_inv_mem' := λ x, or.inl trivial,
  ..(⊤ : subring K) }

lemma mem_top (x : K) : x ∈ (⊤ : valuation_subring K) := trivial

lemma le_top : A ≤ ⊤ := λ a ha, mem_top _

instance : order_top (valuation_subring K) :=
{ top := ⊤,
  le_top := le_top }

instance : inhabited (valuation_subring K) := ⟨⊤⟩

instance : valuation_ring A :=
{ cond := λ a b,
  begin
    by_cases (b : K) = 0, { use 0, left, ext, simp [h] },
    by_cases (a : K) = 0, { use 0, right, ext, simp [h] },
    cases A.mem_or_inv_mem (a/b) with hh hh,
    { use ⟨a/b, hh⟩, right, ext, field_simp, ring },
    { rw (show (a/b : K)⁻¹ = b/a, by field_simp) at hh,
      use ⟨b/a, hh⟩, left, ext, field_simp, ring },
  end }

instance : algebra A K :=
show algebra A.to_subring K, by apply_instance

@[simp]
lemma algebra_map_apply (a : A) : algebra_map A K a = a := rfl

instance : is_fraction_ring A K :=
{ map_units := λ ⟨y, hy⟩,
    (units.mk0 (y : K) (λ c, non_zero_divisors.ne_zero hy $ subtype.ext c)).is_unit,
  surj := λ z, begin
    by_cases z = 0, { use (0, 1), simp [h] },
    cases A.mem_or_inv_mem z with hh hh,
    { use (⟨z, hh⟩, 1), simp },
    { refine ⟨⟨1, ⟨⟨_, hh⟩, _⟩⟩, mul_inv_cancel h⟩,
      exact mem_non_zero_divisors_iff_ne_zero.2 (λ c, h (inv_eq_zero.mp (congr_arg coe c))) },
  end,
  eq_iff_exists := λ a b, ⟨ λ h, ⟨1, by { ext, simpa using h }⟩, λ ⟨c, h⟩,
    congr_arg coe ((mul_eq_mul_left_iff.1 h).resolve_right (non_zero_divisors.ne_zero c.2)) ⟩ }

/-- The value group of the valuation associated to `A`. Note: it is actually a group with zero. -/
@[derive linear_ordered_comm_group_with_zero]
def value_group := valuation_ring.value_group A K

/-- Any valuation subring of `K` induces a natural valuation on `K`. -/
def valuation : valuation K A.value_group := valuation_ring.valuation A K

instance inhabited_value_group : inhabited A.value_group := ⟨A.valuation 0⟩

lemma valuation_le_one (a : A) : A.valuation a ≤ 1 :=
(valuation_ring.mem_integer_iff A K _).2 ⟨a, rfl⟩

lemma mem_of_valuation_le_one (x : K) (h : A.valuation x ≤ 1) : x ∈ A :=
let ⟨a, ha⟩ := (valuation_ring.mem_integer_iff A K x).1 h in ha ▸ a.2

lemma valuation_le_one_iff (x : K) : A.valuation x ≤ 1 ↔ x ∈ A :=
⟨mem_of_valuation_le_one _ _, λ ha, A.valuation_le_one ⟨x, ha⟩⟩

lemma valuation_eq_iff (x y : K) : A.valuation x = A.valuation y ↔
  ∃ a : Aˣ, (a : K) * y = x := quotient.eq'

lemma valuation_le_iff (x y : K) : A.valuation x ≤ A.valuation y ↔
  ∃ a : A, (a : K) * y = x := iff.rfl

lemma valuation_surjective : function.surjective A.valuation := surjective_quot_mk _

lemma valuation_unit (a : Aˣ) : A.valuation a = 1 :=
by { rw [← A.valuation.map_one, valuation_eq_iff], use a, simp }

lemma valuation_eq_one_iff (a : A) : is_unit a ↔ A.valuation a = 1 :=
⟨ λ h, A.valuation_unit h.unit,
  λ h, begin
    have ha : (a : K) ≠ 0,
    { intro c, rw [c, A.valuation.map_zero] at h, exact zero_ne_one h },
    have ha' : (a : K)⁻¹ ∈ A,
    { rw [← valuation_le_one_iff, map_inv₀, h, inv_one] },
    apply is_unit_of_mul_eq_one a ⟨a⁻¹, ha'⟩, ext, field_simp,
  end ⟩

lemma valuation_lt_one_or_eq_one (a : A) : A.valuation a < 1 ∨ A.valuation a = 1 :=
lt_or_eq_of_le (A.valuation_le_one a)

lemma valuation_lt_one_iff (a : A) : a ∈ local_ring.maximal_ideal A ↔ A.valuation a < 1 :=
begin
  rw local_ring.mem_maximal_ideal,
  dsimp [nonunits], rw valuation_eq_one_iff,
  exact (A.valuation_le_one a).lt_iff_ne.symm,
end

/-- A subring `R` of `K` such that for all `x : K` either `x ∈ R` or `x⁻¹ ∈ R` is
  a valuation subring of `K`. -/
def of_subring (R : subring K) (hR : ∀ x : K, x ∈ R ∨ x⁻¹ ∈ R) : valuation_subring K :=
{ mem_or_inv_mem' := hR, ..R }

@[simp]
lemma mem_of_subring (R : subring K) (hR : ∀ x : K, x ∈ R ∨ x⁻¹ ∈ R) (x : K) :
  x ∈ of_subring R hR ↔ x ∈ R := iff.refl _

/-- An overring of a valuation ring is a valuation ring. -/
def of_le (R : valuation_subring K) (S : subring K) (h : R.to_subring ≤ S) :
  valuation_subring K :=
{ mem_or_inv_mem' := λ x, (R.mem_or_inv_mem x).imp (@h x) (@h _), ..S}

section order

instance : semilattice_sup (valuation_subring K) :=
{ sup := λ R S, of_le R (R.to_subring ⊔ S.to_subring) $ le_sup_left,
  le_sup_left := λ R S x hx, (le_sup_left : R.to_subring ≤ R.to_subring ⊔ S.to_subring) hx,
  le_sup_right := λ R S x hx, (le_sup_right : S.to_subring ≤ R.to_subring ⊔ S.to_subring) hx,
  sup_le := λ R S T hR hT x hx, (sup_le hR hT : R.to_subring ⊔ S.to_subring ≤ T.to_subring) hx,
  ..(infer_instance : partial_order (valuation_subring K)) }

/-- The ring homomorphism induced by the partial order. -/
def inclusion (R S : valuation_subring K) (h : R ≤ S) : R →+* S :=
subring.inclusion h

/-- The canonical ring homomorphism from a valuation ring to its field of fractions. -/
def subtype (R : valuation_subring K) : R →+* K :=
subring.subtype R.to_subring

/-- The canonical map on value groups induced by a coarsening of valuation rings. -/
def map_of_le (R S : valuation_subring K) (h : R ≤ S) :
  R.value_group →*₀ S.value_group :=
{ to_fun := quotient.map' id $ λ x y ⟨u, hu⟩, ⟨units.map (R.inclusion S h).to_monoid_hom u, hu⟩,
  map_zero' := rfl,
  map_one' := rfl,
  map_mul' := by { rintro ⟨⟩ ⟨⟩, refl } }

@[mono]
lemma monotone_map_of_le (R S : valuation_subring K) (h : R ≤ S) :
  monotone (R.map_of_le S h) :=
by { rintros ⟨⟩ ⟨⟩ ⟨a, ha⟩, exact ⟨R.inclusion S h a, ha⟩ }

@[simp]
lemma map_of_le_comp_valuation (R S : valuation_subring K) (h : R ≤ S) :
  R.map_of_le S h ∘ R.valuation = S.valuation := by { ext, refl }

@[simp]
lemma map_of_le_valuation_apply (R S : valuation_subring K) (h : R ≤ S) (x : K) :
  R.map_of_le S h (R.valuation x) = S.valuation x := rfl

/-- The ideal corresponding to a coarsening of a valuation ring. -/
def ideal_of_le (R S : valuation_subring K) (h : R ≤ S) : ideal R :=
(local_ring.maximal_ideal S).comap (R.inclusion S h)

instance prime_ideal_of_le (R S : valuation_subring K) (h : R ≤ S) :
  (ideal_of_le R S h).is_prime := (local_ring.maximal_ideal S).comap_is_prime _

/-- The coarsening of a valuation ring associated to a prime ideal. -/
def of_prime (A : valuation_subring K) (P : ideal A) [P.is_prime] :
  valuation_subring K :=
of_le A (localization.subalgebra.of_field K _ P.prime_compl_le_non_zero_divisors).to_subring $
  λ a ha, subalgebra.algebra_map_mem _ (⟨a, ha⟩ : A)

instance of_prime_algebra (A : valuation_subring K) (P : ideal A) [P.is_prime] :
  algebra A (A.of_prime P) := subalgebra.algebra _

instance of_prime_scalar_tower (A : valuation_subring K) (P : ideal A) [P.is_prime] :
  is_scalar_tower A (A.of_prime P) K := is_scalar_tower.subalgebra' A K K _

instance of_prime_localization (A : valuation_subring K) (P : ideal A) [P.is_prime] :
  is_localization.at_prime (A.of_prime P) P :=
by apply localization.subalgebra.is_localization_of_field K P.prime_compl
  P.prime_compl_le_non_zero_divisors

lemma le_of_prime (A : valuation_subring K) (P : ideal A) [P.is_prime] :
  A ≤ of_prime A P :=
λ a ha, subalgebra.algebra_map_mem _ (⟨a, ha⟩ : A)

lemma of_prime_valuation_eq_one_iff_mem_prime_compl
  (A : valuation_subring K)
  (P : ideal A) [P.is_prime] (x : A) :
  (of_prime A P).valuation x = 1 ↔ x ∈ P.prime_compl :=
begin
  rw [← is_localization.at_prime.is_unit_to_map_iff (A.of_prime P) P x, valuation_eq_one_iff], refl,
end

@[simp]
lemma ideal_of_le_of_prime (A : valuation_subring K) (P : ideal A) [P.is_prime] :
  ideal_of_le A (of_prime A P) (le_of_prime A P) = P :=
by { ext, apply is_localization.at_prime.to_map_mem_maximal_iff }

@[simp]
lemma of_prime_ideal_of_le (R S : valuation_subring K) (h : R ≤ S) :
  of_prime R (ideal_of_le R S h) = S :=
begin
  ext x, split,
  { rintro ⟨a, r, hr, rfl⟩, apply mul_mem, { exact h a.2 },
    { rw [← valuation_le_one_iff, map_inv₀, ← inv_one, inv_le_inv₀],
      { exact not_lt.1 ((not_iff_not.2 $ valuation_lt_one_iff S _).1 hr) },
      { intro hh, erw [valuation.zero_iff, subring.coe_eq_zero_iff] at hh,
        apply hr, rw hh, apply ideal.zero_mem (R.ideal_of_le S h) },
      { exact one_ne_zero } } },
  { intro hx, by_cases hr : x ∈ R, { exact R.le_of_prime _ hr },
    have : x ≠ 0 := λ h, hr (by { rw h, exact R.zero_mem }),
    replace hr := (R.mem_or_inv_mem x).resolve_left hr,
    { use [1, x⁻¹, hr], split,
      { change (⟨x⁻¹, h hr⟩ : S) ∉ nonunits S,
        erw [mem_nonunits_iff, not_not],
        apply is_unit_of_mul_eq_one _ (⟨x, hx⟩ : S),
        ext, field_simp },
      { field_simp } } },
end

lemma of_prime_le_of_le (P Q : ideal A) [P.is_prime] [Q.is_prime]
  (h : P ≤ Q) : of_prime A Q ≤ of_prime A P :=
λ x ⟨a, s, hs, he⟩, ⟨a, s, λ c, hs (h c), he⟩

lemma ideal_of_le_le_of_le (R S : valuation_subring K)
  (hR : A ≤ R) (hS : A ≤ S) (h : R ≤ S) :
  ideal_of_le A S hS ≤ ideal_of_le A R hR :=
λ x hx, (valuation_lt_one_iff R _).2 begin
  by_contra c, push_neg at c, replace c := monotone_map_of_le R S h c,
  rw [(map_of_le _ _ _).map_one, map_of_le_valuation_apply] at c,
  apply not_le_of_lt ((valuation_lt_one_iff S _).1 hx) c,
end

/-- The equivalence between coarsenings of a valuation ring and its prime ideals.-/
@[simps]
def prime_spectrum_equiv :
  prime_spectrum A ≃ { S | A ≤ S } :=
{ to_fun := λ P, ⟨of_prime A P.as_ideal, le_of_prime _ _⟩,
  inv_fun := λ S, ⟨ideal_of_le _ S S.2, infer_instance⟩,
  left_inv := λ P, by { ext1, simp },
  right_inv := λ S, by { ext1, simp } }

/-- An ordered variant of `prime_spectrum_equiv`. -/
@[simps]
def prime_spectrum_order_equiv : (prime_spectrum A)ᵒᵈ ≃o {S | A ≤ S} :=
{ map_rel_iff' := λ P Q,
    ⟨ λ h, begin
        have := ideal_of_le_le_of_le A _ _ _ _ h,
        iterate 2 { erw ideal_of_le_of_prime at this },
        exact this,
      end,
      λ h, by { apply of_prime_le_of_le, exact h } ⟩,
  ..(prime_spectrum_equiv A) }

instance linear_order_overring : linear_order { S | A ≤ S } :=
{ le_total :=
  let i : is_total (prime_spectrum A) (≤) := ⟨λ ⟨x, _⟩ ⟨y, _⟩, has_le.le.is_total.total x y⟩ in
    by exactI (prime_spectrum_order_equiv A).symm.to_rel_embedding.is_total.total,
  decidable_le := infer_instance,
  ..(infer_instance : partial_order _) }

end order

end valuation_subring

namespace valuation

variables {K} {Γ Γ₁ Γ₂ : Type*}
  [linear_ordered_comm_group_with_zero Γ]
  [linear_ordered_comm_group_with_zero Γ₁]
  [linear_ordered_comm_group_with_zero Γ₂]
  (v : valuation K Γ)
  (v₁ : valuation K Γ₁)
  (v₂ : valuation K Γ₂)

/-- The valuation subring associated to a valuation. -/
def valuation_subring : valuation_subring K :=
{ mem_or_inv_mem' := begin
    intros x,
    cases le_or_lt (v x) 1,
    { left, exact h },
    { right, change v x⁻¹ ≤ 1,
      rw [map_inv₀ v, ← inv_one, inv_le_inv₀],
      { exact le_of_lt h },
      { intro c, simpa [c] using h },
      { exact one_ne_zero } }
  end,
  .. v.integer }

@[simp]
lemma mem_valuation_subring_iff (x : K) : x ∈ v.valuation_subring ↔ v x ≤ 1 := iff.refl _

lemma is_equiv_iff_valuation_subring : v₁.is_equiv v₂ ↔
  v₁.valuation_subring = v₂.valuation_subring :=
begin
  split,
  { intros h, ext x, specialize h x 1, simpa using h },
  { intros h, apply is_equiv_of_val_le_one,
    intros x,
    have : x ∈ v₁.valuation_subring ↔ x ∈ v₂.valuation_subring, by rw h,
    simpa using this }
end

lemma is_equiv_valuation_valuation_subring :
  v.is_equiv v.valuation_subring.valuation :=
begin
  rw [is_equiv_iff_val_le_one],
  intro x,
  rw valuation_subring.valuation_le_one_iff,
  refl,
end

end valuation

namespace valuation_subring

variables {K} (A : valuation_subring K)

@[simp]
lemma valuation_subring_valuation : A.valuation.valuation_subring = A :=
by { ext, rw ← A.valuation_le_one_iff, refl }

section unit_group

/-- The unit group of a valuation subring, as a subgroup of `Kˣ`. -/
def unit_group : subgroup Kˣ :=
(A.valuation.to_monoid_with_zero_hom.to_monoid_hom.comp (units.coe_hom K)).ker

@[simp] lemma mem_unit_group_iff (x : Kˣ) : x ∈ A.unit_group ↔ A.valuation x = 1 := iff.rfl

/-- For a valuation subring `A`, `A.unit_group` agrees with the units of `A`. -/
def unit_group_mul_equiv : A.unit_group ≃* Aˣ :=
{ to_fun := λ x,
  { val := ⟨x, mem_of_valuation_le_one A _ x.prop.le⟩,
    inv := ⟨↑(x⁻¹), mem_of_valuation_le_one _ _ (x⁻¹).prop.le⟩,
    val_inv := subtype.ext (units.mul_inv x),
    inv_val := subtype.ext (units.inv_mul x) },
  inv_fun := λ x, ⟨units.map A.subtype.to_monoid_hom x, A.valuation_unit x⟩,
  left_inv := λ a, by { ext, refl },
  right_inv := λ a, by { ext, refl },
  map_mul' := λ a b, by { ext, refl } }

@[simp]
lemma coe_unit_group_mul_equiv_apply (a : A.unit_group) :
  (A.unit_group_mul_equiv a : K) = a := rfl

@[simp]
lemma coe_unit_group_mul_equiv_symm_apply (a : Aˣ) :
  (A.unit_group_mul_equiv.symm a : K) = a := rfl

lemma unit_group_le_unit_group {A B : valuation_subring K} :
  A.unit_group ≤ B.unit_group ↔ A ≤ B :=
begin
  split,
  { intros h x hx,
    rw [← A.valuation_le_one_iff x, le_iff_lt_or_eq] at hx,
    by_cases h_1 : x = 0, { simp only [h_1, zero_mem] },
    by_cases h_2 : 1 + x = 0,
      { simp only [← add_eq_zero_iff_neg_eq.1 h_2, neg_mem _ _ (one_mem _)] },
    cases hx,
    { have := h (show (units.mk0 _ h_2) ∈ A.unit_group, from A.valuation.map_one_add_of_lt hx),
      simpa using B.add_mem _ _
        (show 1 + x ∈ B, from set_like.coe_mem ((B.unit_group_mul_equiv ⟨_, this⟩) : B))
        (B.neg_mem _ B.one_mem) },
    { have := h (show (units.mk0 x h_1) ∈ A.unit_group, from hx),
      refine set_like.coe_mem ((B.unit_group_mul_equiv ⟨_, this⟩) : B) } },
  { rintros h x (hx : A.valuation x = 1),
    apply_fun A.map_of_le B h at hx,
    simpa using hx }
end

lemma unit_group_injective : function.injective (unit_group : valuation_subring K → subgroup _) :=
λ A B h, by { simpa only [le_antisymm_iff, unit_group_le_unit_group] using h}

lemma eq_iff_unit_group {A B : valuation_subring K} :
  A = B ↔ A.unit_group = B.unit_group :=
unit_group_injective.eq_iff.symm

/-- The map on valuation subrings to their unit groups is an order embedding. -/
def unit_group_order_embedding : valuation_subring K ↪o subgroup Kˣ :=
{ to_fun := λ A, A.unit_group,
  inj' := unit_group_injective,
  map_rel_iff' := λ A B, unit_group_le_unit_group }

lemma unit_group_strict_mono : strict_mono (unit_group : valuation_subring K → subgroup _) :=
unit_group_order_embedding.strict_mono

end unit_group

section nonunits

/-- The nonunits of a valuation subring of `K`, as a subsemigroup of `K`-/
def nonunits : subsemigroup K :=
{ carrier := { x | A.valuation x < 1 },
  mul_mem' := λ a b ha hb, (mul_lt_mul₀ ha hb).trans_eq $ mul_one _ }

lemma mem_nonunits_iff {x : K} : x ∈ A.nonunits ↔ A.valuation x < 1 := iff.rfl

lemma nonunits_le_nonunits {A B : valuation_subring K} :
  B.nonunits ≤ A.nonunits ↔ A ≤ B :=
begin
  split,
  { intros h x hx,
    by_cases h_1 : x = 0, { simp only [h_1, zero_mem] },
    rw [← valuation_le_one_iff, ← not_lt, valuation.one_lt_val_iff _ h_1] at hx ⊢,
    by_contra h_2, from hx (h h_2) },
  { intros h x hx,
    by_contra h_1, from not_lt.2 (monotone_map_of_le _ _ h (not_lt.1 h_1)) hx }
end

lemma nonunits_injective :
  function.injective (nonunits : valuation_subring K → subsemigroup _) :=
λ A B h, by { simpa only [le_antisymm_iff, nonunits_le_nonunits] using h.symm }

lemma nonunits_inj {A B : valuation_subring K} : A.nonunits = B.nonunits ↔ A = B :=
nonunits_injective.eq_iff

/-- The map on valuation subrings to their nonunits is a dual order embedding. -/
def nonunits_order_embedding :
  valuation_subring K ↪o (subsemigroup K)ᵒᵈ :=
{ to_fun := λ A, A.nonunits,
  inj' := nonunits_injective,
  map_rel_iff' := λ A B, nonunits_le_nonunits }

variables {A}

 /-- The elements of `A.nonunits` are those of the maximal ideal of `A` after coercion to `K`.

See also `mem_nonunits_iff_exists_mem_maximal_ideal`, which gets rid of the coercion to `K`,
at the expense of a more complicated right hand side.
 -/
theorem coe_mem_nonunits_iff {a : A} : (a : K) ∈ A.nonunits ↔ a ∈ local_ring.maximal_ideal A :=
(valuation_lt_one_iff _ _).symm

lemma nonunits_le : A.nonunits ≤ A.to_subring.to_submonoid.to_subsemigroup :=
λ a ha, (A.valuation_le_one_iff _).mp (A.mem_nonunits_iff.mp ha).le

lemma nonunits_subset : (A.nonunits : set K) ⊆ A := nonunits_le

 /-- The elements of `A.nonunits` are those of the maximal ideal of `A`.

See also `coe_mem_nonunits_iff`, which has a simpler right hand side but requires the element
to be in `A` already.
 -/
theorem mem_nonunits_iff_exists_mem_maximal_ideal {a : K} :
  a ∈ A.nonunits ↔ ∃ ha, (⟨a, ha⟩ : A) ∈ local_ring.maximal_ideal A :=
⟨λ h, ⟨nonunits_subset h, coe_mem_nonunits_iff.mp h⟩,
 λ ⟨ha, h⟩, coe_mem_nonunits_iff.mpr h⟩

 /-- `A.nonunits` agrees with the maximal ideal of `A`, after taking its image in `K`. -/
theorem image_maximal_ideal : (coe : A → K) '' local_ring.maximal_ideal A = A.nonunits :=
begin
  ext a,
  simp only [set.mem_image, set_like.mem_coe, mem_nonunits_iff_exists_mem_maximal_ideal],
  erw subtype.exists,
  simp_rw [subtype.coe_mk, exists_and_distrib_right, exists_eq_right],
end

end nonunits

section principal_unit_group

/-- The principal unit group of a valuation subring, as a subgroup of `Kˣ`. -/
def principal_unit_group : subgroup Kˣ :=
{ carrier := { x | A.valuation (x - 1) < 1 },
  mul_mem' := begin
    intros a b ha hb,
    refine lt_of_le_of_lt _ (max_lt hb ha),
    rw [← one_mul (A.valuation (b - 1)), ← A.valuation.map_one_add_of_lt ha, add_sub_cancel'_right,
      ← valuation.map_mul, mul_sub_one, ← sub_add_sub_cancel],
    exact A.valuation.map_add _ _,
  end,
  one_mem' := by simp,
  inv_mem' := begin
    dsimp,
    intros a ha,
    conv {to_lhs, rw [← mul_one (A.valuation _), ← A.valuation.map_one_add_of_lt ha]},
    rwa [add_sub_cancel'_right, ← valuation.map_mul, sub_mul, units.inv_mul, ← neg_sub, one_mul,
      valuation.map_neg],
  end }

lemma principal_units_le_units : A.principal_unit_group ≤ A.unit_group :=
λ a h, by simpa only [add_sub_cancel'_right] using A.valuation.map_one_add_of_lt h

lemma mem_principal_unit_group_iff (x : Kˣ) :
  x ∈ A.principal_unit_group ↔ A.valuation ((x : K) - 1) < 1 := iff.rfl

lemma principal_unit_group_le_principal_unit_group {A B : valuation_subring K} :
  B.principal_unit_group ≤ A.principal_unit_group ↔ A ≤ B :=
begin
  split,
  { intros h x hx,
    by_cases h_1 : x = 0, { simp only [h_1, zero_mem] },
    by_cases h_2 : x⁻¹ + 1 = 0,
    { rw [add_eq_zero_iff_eq_neg, inv_eq_iff_eq_inv, inv_neg, inv_one] at h_2,
      simpa only [h_2] using B.neg_mem _ B.one_mem },
    { rw [← valuation_le_one_iff, ← not_lt, valuation.one_lt_val_iff _ h_1, ← add_sub_cancel x⁻¹,
        ← units.coe_mk0 h_2, ← mem_principal_unit_group_iff] at hx ⊢,
      simpa only [hx] using @h (units.mk0 (x⁻¹ + 1) h_2) } },
  { intros h x hx,
    by_contra h_1, from not_lt.2 (monotone_map_of_le _ _ h (not_lt.1 h_1)) hx }
end

lemma principal_unit_group_injective :
  function.injective (principal_unit_group : valuation_subring K → subgroup _) :=
λ A B h, by { simpa [le_antisymm_iff, principal_unit_group_le_principal_unit_group] using h.symm }

lemma eq_iff_principal_unit_group {A B : valuation_subring K} :
  A = B ↔ A.principal_unit_group = B.principal_unit_group :=
principal_unit_group_injective.eq_iff.symm

/-- The map on valuation subrings to their principal unit groups is an order embedding. -/
def principal_unit_group_order_embedding :
  valuation_subring K ↪o (subgroup Kˣ)ᵒᵈ :=
{ to_fun := λ A, A.principal_unit_group,
  inj' := principal_unit_group_injective,
  map_rel_iff' := λ A B, principal_unit_group_le_principal_unit_group }

lemma coe_mem_principal_unit_group_iff {x : A.unit_group} :
  (x : Kˣ) ∈ A.principal_unit_group ↔
  A.unit_group_mul_equiv x ∈ (units.map (local_ring.residue A).to_monoid_hom).ker :=
begin
  rw [monoid_hom.mem_ker, units.ext_iff],
  let π := ideal.quotient.mk (local_ring.maximal_ideal A), convert_to _ ↔ π _ = 1,
  rw [← π.map_one, ← sub_eq_zero, ← π.map_sub, ideal.quotient.eq_zero_iff_mem,
    valuation_lt_one_iff],
  simpa,
end

/-- The principal unit group agrees with the kernel of the canonical map from
the units of `A` to the units of the residue field of `A`. -/
def principal_unit_group_equiv :
  A.principal_unit_group ≃* (units.map (local_ring.residue A).to_monoid_hom).ker :=
{ to_fun := λ x, ⟨A.unit_group_mul_equiv ⟨_, A.principal_units_le_units x.2⟩,
    A.coe_mem_principal_unit_group_iff.1 x.2⟩,
  inv_fun := λ x, ⟨A.unit_group_mul_equiv.symm x,
    by { rw A.coe_mem_principal_unit_group_iff, simpa using set_like.coe_mem x }⟩,
  left_inv := λ x, by simp,
  right_inv := λ x, by simp,
  map_mul' := λ x y, by refl, }

@[simp]
lemma principal_unit_group_equiv_apply (a : A.principal_unit_group) :
  (principal_unit_group_equiv A a : K) = a := rfl

@[simp]
lemma principal_unit_group_symm_apply
  (a : (units.map (local_ring.residue A).to_monoid_hom).ker) :
  (A.principal_unit_group_equiv.symm a : K) = a := rfl

/-- The canonical map from the unit group of `A` to the units of the residue field of `A`. -/
def unit_group_to_residue_field_units :
  A.unit_group →* (local_ring.residue_field A)ˣ :=
monoid_hom.comp (units.map $ (ideal.quotient.mk _).to_monoid_hom)
  A.unit_group_mul_equiv.to_monoid_hom

@[simp]
lemma coe_unit_group_to_residue_field_units_apply (x : A.unit_group) :
  (A.unit_group_to_residue_field_units x : (local_ring.residue_field A) ) =
  (ideal.quotient.mk _ (A.unit_group_mul_equiv x : A)) := rfl

lemma ker_unit_group_to_residue_field_units :
  A.unit_group_to_residue_field_units.ker = A.principal_unit_group.comap A.unit_group.subtype :=
by { ext, simpa only [subgroup.mem_comap, subgroup.coe_subtype, coe_mem_principal_unit_group_iff] }

lemma surjective_unit_group_to_residue_field_units :
  function.surjective A.unit_group_to_residue_field_units :=
(local_ring.surjective_units_map_of_local_ring_hom _
ideal.quotient.mk_surjective local_ring.is_local_ring_hom_residue).comp (mul_equiv.surjective _)

/-- The quotient of the unit group of `A` by the principal unit group of `A` agrees with
the units of the residue field of `A`. -/
def units_mod_principal_units_equiv_residue_field_units :
  (A.unit_group ⧸ (A.principal_unit_group.comap A.unit_group.subtype)) ≃*
  (local_ring.residue_field A)ˣ :=
(quotient_group.quotient_mul_equiv_of_eq A.ker_unit_group_to_residue_field_units.symm).trans
  (quotient_group.quotient_ker_equiv_of_surjective _ A.surjective_unit_group_to_residue_field_units)

@[simp]
lemma units_mod_principal_units_equiv_residue_field_units_comp_quotient_group_mk :
  A.units_mod_principal_units_equiv_residue_field_units.to_monoid_hom.comp
  (quotient_group.mk' _) = A.unit_group_to_residue_field_units := rfl

@[simp]
lemma units_mod_principal_units_equiv_residue_field_units_comp_quotient_group_mk_apply
  (x : A.unit_group) :
  A.units_mod_principal_units_equiv_residue_field_units.to_monoid_hom
  (quotient_group.mk x) = A.unit_group_to_residue_field_units x := rfl

end principal_unit_group

/-! ### Pointwise actions

This transfers the action from `subring.pointwise_mul_action`, noting that it only applies when
the action is by a group. Notably this provides an instances when `G` is `K ≃+* K`.

These instances are in the `pointwise` locale.

The lemmas in this section are copied from `ring_theory/subring/pointwise.lean`; try to keep these
in sync.
-/
section pointwise_actions
open_locale pointwise

variables {G : Type*} [group G] [mul_semiring_action G K]

/-- The action on a valuation subring corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
def pointwise_has_smul : has_smul G (valuation_subring K) :=
{ smul := λ g S,
  -- TODO: if we add `valuation_subring.map` at a later date, we should use it here
  { mem_or_inv_mem' := λ x, (mem_or_inv_mem S (g⁻¹ • x)).imp
      (subring.mem_pointwise_smul_iff_inv_smul_mem.mpr)
      (λ h, subring.mem_pointwise_smul_iff_inv_smul_mem.mpr $ by rwa smul_inv''),
    .. g • S.to_subring } }

localized "attribute [instance] valuation_subring.pointwise_has_smul" in pointwise
open_locale pointwise

@[simp] lemma coe_pointwise_smul (g : G) (S : valuation_subring K) : ↑(g • S) = g • (S : set K) :=
rfl

@[simp] lemma pointwise_smul_to_subring (g : G) (S : valuation_subring K) :
  (g • S).to_subring = g • S.to_subring := rfl

/-- The action on a valuation subring corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale.

This is a stronger version of `valuation_subring.pointwise_has_smul`. -/
def pointwise_mul_action : mul_action G (valuation_subring K) :=
to_subring_injective.mul_action to_subring pointwise_smul_to_subring

localized "attribute [instance] valuation_subring.pointwise_mul_action" in pointwise
open_locale pointwise

lemma smul_mem_pointwise_smul (g : G) (x : K) (S : valuation_subring K) : x ∈ S → g • x ∈ g • S :=
(set.smul_mem_smul_set : _ → _ ∈ g • (S : set K))

lemma mem_smul_pointwise_iff_exists (g : G) (x : K) (S : valuation_subring K) :
  x ∈ g • S ↔ ∃ (s : K), s ∈ S ∧ g • s = x :=
(set.mem_smul_set : x ∈ g • (S : set K) ↔ _)

instance pointwise_central_scalar [mul_semiring_action Gᵐᵒᵖ K] [is_central_scalar G K] :
  is_central_scalar G (valuation_subring K) :=
⟨λ g S, to_subring_injective $ by exact op_smul_eq_smul g S.to_subring⟩

@[simp] lemma smul_mem_pointwise_smul_iff {g : G} {S : valuation_subring K} {x : K} :
  g • x ∈ g • S ↔ x ∈ S :=
set.smul_mem_smul_set_iff

lemma mem_pointwise_smul_iff_inv_smul_mem {g : G} {S : valuation_subring K} {x : K} :
  x ∈ g • S ↔ g⁻¹ • x ∈ S :=
set.mem_smul_set_iff_inv_smul_mem

lemma mem_inv_pointwise_smul_iff {g : G} {S : valuation_subring K} {x : K} :
  x ∈ g⁻¹ • S ↔ g • x ∈ S :=
set.mem_inv_smul_set_iff

@[simp] lemma pointwise_smul_le_pointwise_smul_iff {g : G} {S T : valuation_subring K} :
  g • S ≤ g • T ↔ S ≤ T :=
set.set_smul_subset_set_smul_iff

lemma pointwise_smul_subset_iff {g : G} {S T : valuation_subring K} : g • S ≤ T ↔ S ≤ g⁻¹ • T :=
set.set_smul_subset_iff

lemma subset_pointwise_smul_iff {g : G} {S T : valuation_subring K} : S ≤ g • T ↔ g⁻¹ • S ≤ T :=
set.subset_set_smul_iff

end pointwise_actions

section

variables {L J: Type*} [field L] [field J]

/-- The pullback of a valuation subring `A` along a ring homomorphism `K →+* L`. -/
def comap (A : valuation_subring L) (f : K →+* L) :
  valuation_subring K :=
{ mem_or_inv_mem' := λ k, by simp [valuation_subring.mem_or_inv_mem],
  ..(A.to_subring.comap f) }

@[simp]
lemma coe_comap (A : valuation_subring L) (f : K →+* L) : (A.comap f : set K) = f ⁻¹' A := rfl

@[simp]
lemma mem_comap {A : valuation_subring L} {f : K →+* L} {x : K} : x ∈ A.comap f ↔ f x ∈ A := iff.rfl

lemma comap_comap (A : valuation_subring J) (g : L →+* J) (f : K →+* L) :
  (A.comap g).comap f = A.comap (g.comp f) :=
rfl

end

end valuation_subring

namespace valuation

variables {Γ : Type*} [linear_ordered_comm_group_with_zero Γ] (v : valuation K Γ) (x : Kˣ)

@[simp] lemma mem_unit_group_iff : x ∈ v.valuation_subring.unit_group ↔ v x = 1 :=
(valuation.is_equiv_iff_val_eq_one _ _).mp (valuation.is_equiv_valuation_valuation_subring _).symm

end valuation


/-!
======
LAMR
======

.. default-role:: lean4

Experimenting with code from https://github.com/avigad/lamr

3. Lean as a Programming Language
=====================================

3.1. About lean
------------------

https://avigad.github.io/lamr/using_lean_as_a_programming_language.html

-/

#check 2 + 2
#check -5
#check [1, 2, 3]
#check #[1, 2, 3]
#check Array
#check (1, 2, 3)
#check "hello world"
#check true
#check fun x => x + 1
#check λ x => x + 2
#check fun x => if x = 1 then "yes" else "no"

#check ([1, 2, 3] : List Nat)
#check (#[1, 2, 3] : Array Nat)

def isOne (x : Nat) : String := if x = 1 then "yes" else "no"
#check isOne
#print isOne

#check 2 + 2 < 5 ∧ isOne 3 = "no"

def Fermat_statement : Prop :=
∀ a b c n : Nat, a * b * c ≠ 0 ∧ n > 2 → a^n + b^n ≠ c^n

#check Fermat_statement

theorem two_plus_two_is_four : 2 + 2 = 4 := rfl

theorem Fermat_last_theorem : Fermat_statement := sorry

/-!

3.2. Using Lean as a functional programming language
----------------------------------------------------------------

-/

def printExample : IO Unit:= do
  IO.println "hello"
  IO.println "world"

#eval printExample

def factorial : Nat → Nat
  | 0       => 1
  | (n + 1) => (n + 1) * factorial n

#eval factorial 10
#eval factorial 100

def hanoi (numPegs start finish aux : Nat) : IO Unit :=
  match numPegs with
  | 0     => pure ()
  | n + 1 => do
      hanoi n start aux finish
      IO.println s!"Move disk {n + 1} from peg {start} to peg {finish}"
      hanoi n aux finish start

#eval hanoi 7 1 2 3

def addNums : List Nat → Nat
  | []    => 0
  | a::as => a + addNums as

#eval addNums [0, 1, 2, 3, 4, 5, 6]

section
open List

#eval range 7
#eval addNums (range 7)
#eval addNums $ range 7
#eval map (fun x => x + 3) $ range 7
#eval map (. + 3) $ range 7
#eval foldl (. + .) 0 $ range 7
#check (. + .)

end

partial def gcd m n :=
  if n = 0 then m else gcd n (m % n)

/-!

3.3. Inductive data types in Lean
----------------------------------------------------------------

-/

section

inductive BinTree
  | empty : BinTree
  | node  : BinTree → BinTree → BinTree
  deriving Repr, DecidableEq, Inhabited

open BinTree

#eval node empty (node empty empty)

def size : BinTree → Nat
  | empty    => 0
  | node a b => 1 + size a + size b

def depth : BinTree → Nat
  | empty    => 0
  | node a b => 1 + Nat.max (depth a) (depth b)

def example_tree := node (node empty empty) (node empty (node empty empty))

#eval size example_tree
#eval depth example_tree

end

/-!

3.4. Using Lean as an imperative programming language
----------------------------------------------------------------

-/

def isPrime (n : Nat) : Bool := Id.run do
  if n < 2 then false else
    for i in [2:n] do
      if n % i = 0 then
        return false
      if i * i > n then
        return true
    true

#eval (List.range 10000).filter isPrime

def primes (n : Nat) : Array Nat := Id.run do
  let mut result := #[]
  for i in [2:n] do
    if isPrime i then
      result := result.push i
  result

#eval (primes 10000).size

/-!

5. Implementing Propositional Logic
================================================================

https://avigad.github.io/lamr/implementing_propositional_logic.html

5.1. Syntax
------------

An atomic formula is a variable or one of the constants ⊤ or ⊥. A literal is an atomic formula or a negated atomic formula.

The set of propositional formulas in negation normal form (NNF) is generated inductively as follows:

Each literal is in negation normal form.

If A and B are in negation normal form, then so are A ∧ B and A ∨ B.

Proposition

Every propositional formula is equivalent to one in negation normal form.

Proof

First use the identities A ↔ B ≡ (A → B) ∧ (B → A) and A → B ≡ ¬A ∧ B to get rid of ≡ and →. Then use De Morgan’s laws together with ¬¬A ≡ A to push negations down to the atomic formulas.

-/
section Props

inductive PropForm
  | tr     : PropForm
  | fls    : PropForm
  | var    : String → PropForm
  | conj   : PropForm → PropForm → PropForm
  | disj   : PropForm → PropForm → PropForm
  | impl   : PropForm → PropForm → PropForm
  | neg    : PropForm → PropForm
  | biImpl : PropForm → PropForm → PropForm
  deriving Repr, DecidableEq

open PropForm

#check (impl (conj (var "p") (var "q")) (var "r"))

namespace PropForm

declare_syntax_cat propform

syntax "prop!{" propform "}"  : term

syntax:max ident                        : propform
syntax "⊤"                              : propform
syntax "⊥"                              : propform
syntax:35 propform:36 " ∧ " propform:35 : propform
syntax:30 propform:31 " ∨ " propform:30 : propform
syntax:20 propform:21 " → " propform:20 : propform
syntax:20 propform:21 " ↔ " propform:20 : propform
syntax:max "¬ " propform:40             : propform
syntax:max "(" propform ")"             : propform

macro_rules
  | `(prop!{$p:ident}) => `(PropForm.var $(Lean.quote p.getId.toString))
  | `(prop!{⊤})        => `(ProfForm.tr)
  | `(prop!{⊥})        => `(ProfForm.fls)
  | `(prop!{¬ $p})     => `(PropForm.neg prop!{$p})
  | `(prop!{$p ∧ $q})  => `(PropForm.conj prop!{$p} prop!{$q})
  | `(prop!{$p ∨ $q})  => `(PropForm.disj prop!{$p} prop!{$q})
  | `(prop!{$p → $q})  => `(PropForm.impl prop!{$p} prop!{$q})
  | `(prop!{$p ↔ $q})  => `(PropForm.biImpl prop!{$p} prop!{$q})
  | `(prop!{($p:propform)}) => `(prop!{$p})

private def toString : PropForm → String
  | var s    => s
  | tr       => "⊤"
  | fls      => "⊥"
  | neg p    => s!"(¬ {toString p})"
  | conj p q => s!"({toString p} ∧ {toString q})"
  | disj p q => s!"({toString p} ∨ {toString q})"
  | impl p q => s!"({toString p} → {toString q})"
  | biImpl p q => s!"({toString p} ↔ {toString q})"

instance : ToString PropForm := ⟨PropForm.toString⟩

end PropForm

#check prop!{p ∧ q → (r ∨ ¬ p) → q}
#eval prop!{p ∧ q → (r ∨ ¬ p) → q}
#check prop!{p ∧ q ∧ r → p}

def propExample := prop!{p ∧ q → r ∧ p ∨ ¬ s1 → s2 }

/-!
Minimal enhancement for List related examples:
-/
namespace List

def insert [DecidableEq α] (a : α) (l : List α) : List α :=
  if a ∈ l then l else a :: l

protected def union [DecidableEq α] (l₁ l₂ : List α) : List α :=
  foldr insert l₂ l₁

end List

namespace PropForm

def complexity : PropForm → Nat
  | var _ => 0
  | tr => 0
  | fls => 0
  | neg A => complexity A + 1
  | conj A B => complexity A + complexity B + 1
  | disj A B => complexity A + complexity B + 1
  | impl A B => complexity A + complexity B + 1
  | biImpl A B => complexity A + complexity B + 1

def depth : PropForm → Nat
  | var _ => 0
  | tr => 0
  | fls => 0
  | neg A => depth A + 1
  | conj A B => Nat.max (depth A) (depth B) + 1
  | disj A B => Nat.max (depth A) (depth B) + 1
  | impl A B => Nat.max (depth A) (depth B) + 1
  | biImpl A B => Nat.max (depth A) (depth B) + 1

def vars : PropForm → List String
  | var s => [s]
  | tr => []
  | fls => []
  | neg A => vars A
  | conj A B => (vars A).union (vars B)
  | disj A B => (vars A).union (vars B)
  | impl A B => (vars A).union (vars B)
  | biImpl A B => (vars A).union (vars B)

end PropForm

/-!

5.2. Semantics
----------------

-/

-- Minimal implementation for PropAssignment examples
def PropAssignment := List (String × Bool)

namespace PropAssignment

def mk (vars : List (String × Bool)) : PropAssignment :=
  vars

def eval? (τ : PropAssignment) (var : String) : Option Bool := Id.run do
  let τ : List _ := τ
  for (k, v) in τ do
    if k == var then return some v
  return none

def eval (τ : PropAssignment) (var : String) : Bool :=
  τ.eval? var |>.getD false

end PropAssignment

def PropForm.eval (v : PropAssignment) : PropForm → Bool
  | var s => v.eval s
  | tr => true
  | fls => false
  | neg A => !(eval v A)
  | conj A B => (eval v A) && (eval v B)
  | disj A B => (eval v A) || (eval v B)
  | impl A B => !(eval v A) || (eval v B)
  | biImpl A B => (!(eval v A) || (eval v B)) && (!(eval v B) || (eval v A))

#eval let v := PropAssignment.mk [("p", true), ("q", true), ("r", true)]
      prop!{p ∧ q ∧ r → p}.eval v

end Props