import tactic
import fol
import Rings.Notation
import Rings.ToMathlib
import data.polynomial.eval

universe u

namespace Rings

local notation h :: t  := dvector.cons h t
local notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l

/-- The constant symbols in RingSignature -/
inductive RingConsts : Type u
| zero : RingConsts
| one : RingConsts

/-- The unary function symbols in RingSignature-/
inductive RingUnaries : Type u
| minus : RingUnaries

/-- The binary function symbols in RingSignature-/
inductive RingBinaries : Type u
| plus : RingBinaries
| times : RingBinaries

/-- All function symbols in RingSignature-/
def RingFuncs : ℕ → Type u
| 0 := RingConsts
| 1 := RingUnaries
| 2 := RingBinaries
| (n + 3) := pempty

instance : inhabited RingConsts := ⟨ RingConsts.zero ⟩
instance : inhabited RingUnaries := ⟨ RingUnaries.minus ⟩
instance : inhabited RingBinaries := ⟨ RingBinaries.plus ⟩

open fol

/-- The language of rings -/
def RingSignature : Language :=
(Language.mk) (RingFuncs) (λ n, pempty)

@[reducible] private def bdt (n : ℕ) := bounded_term RingSignature n
@[reducible] private def bdt' (n : ℕ) := bounded_preterm RingSignature n 0
-- I shouldn't need to make a duplicate since they are definitionally equal

/- The following instances allow us to use symbols 0 1 - + * to write down terms in the language-/
@[simp] def zero {n} : bdt n := bd_const RingConsts.zero

@[reducible] instance RingBDTHasZero {n} : has_zero (bdt n) := ⟨ zero ⟩
@[reducible] instance RingBDTHasZero' {n} : has_zero (bdt' n) := ⟨ zero ⟩

@[simp] def one {n} : bdt n := bd_const RingConsts.one
@[reducible] instance RingBDTHasOne {n} : has_one (bdt n) := ⟨ one ⟩
@[reducible] instance RingBDTHasOne' {n} : has_one (bdt' n) := ⟨ one ⟩

@[simp] def minus {n} : bdt n → bdt n := bd_app (bd_func RingUnaries.minus)
@[reducible] instance RingBDTHasNeg {n} : has_neg (bdt n) := ⟨ minus ⟩
@[reducible] instance RingBDTHasNeg' {n} : has_neg (bdt'  n) := ⟨ minus ⟩

@[simp] def plus {n} (x : bdt n) : bdt n → bdt n :=
  bd_app (bd_app (bd_func RingBinaries.plus) x)
@[reducible] instance RingBDTHasAdd {n} : has_add (bdt n) := ⟨ plus ⟩
@[reducible] instance RingBDTHasAdd' {n} : has_add (bdt'  n) := ⟨ plus ⟩

@[simp] def times {n} (x : bdt n) : bdt n → bdt n :=
  bd_app (bd_app (bd_func RingBinaries.times) x)
@[reducible] instance RingBDTHasMul {n} : has_mul (bdt n) := ⟨ times ⟩
@[reducible] instance RingBDTHasMul' {n} : has_mul (bdt' n) := ⟨ times ⟩

-- has_pow comes for free by having instances of mul and 1 (see ToMathlib) -- input x ^ n

-- @[simp] lemma to_the_one {n} (t : bounded_term RingSignature n) : t ^ 1 = t * 1 := rfl

-- with has_one and has_add you can write any natural and lean will know what term you mean
-- with has_neg you can write any integer etc.

/-
-- variables x0 , x1 in the signature
-- (they are only variables in bounded terms that have up to n + 1, n + 2 variables)
example {n} : bounded_term RingSignature (n + 1) := x_ 0
-- for example {n} : bounded_term RingSignature n := x_ 0 doesn't work
-- since fin n doesn't have an instance of 0 in general (when n = 0)
example {n} : bounded_term RingSignature (n + 2) := x_ 1
-- actually example {n} : bounded_term RingSignature (n + 1) := x_ 1 also works because
-- fin (n + 1) is implemented mod (n + 1), in particular 1 = 0 ∈ fin 1
-- but let's avoid that

-- minus x
example {n} : bounded_term RingSignature (n + 1) := - (x_ 0)
example {n} : bounded_term RingSignature (n + 1) := (x_ 0) + 1
example {n} : bounded_term RingSignature (n + 2):= (- x_ 0) * x_ 1
example {n} : bounded_term RingSignature (n + 1) := x_ 0 + x_ 0
-/

/- Commutative group for additions axioms -/

/-- Assosiativity of addition -/
def AddAssoc : sentence RingSignature :=
  ∀' ∀' ∀' ( (x_ 0 + x_ 1) + x_ 2 ≃ x_ 0 + (x_ 1 + x_ 2) )

/-- Identity for addition -/
def AddId : sentence RingSignature := ∀' ( x_ 0 + 0 ≃ x_ 0 )
-- def AddId : sentence RingSignature := ∀' (   &'0 r+ r0 ≃ &'0   ⊓   r0 r+ &'0 ≃ &'0   )

/-- Inverse for addition -/
def AddInv : sentence RingSignature := ∀' ( - x_ 0 + x_ 0 ≃ 0 )
-- def AddInv : sentence RingSignature := ∀' (  &'0 r+ r- &'0 ≃ r0  ⊓  r- &'0 r+ &'0 ≃ r0  )

/-- Commutativity of addition-/
def AddComm : sentence RingSignature := ∀' ∀' ( x_ 0 + x_ 1 ≃ x_ 1 + x_ 0 )

/- Commutative monoid for multiplication axioms -/
/-- Associativity of multiplication -/
def MulAssoc : sentence RingSignature := ∀' ∀' ∀' ( (x_ 0 * x_ 1) * x_ 2 ≃ x_ 0 * (x_ 1 * x_ 2) )

/-- Identity of multiplication -/
def MulId : sentence RingSignature :=  ∀' ( x_ 0 * 1 ≃ x_ 0 )
-- def MulId : sentence RingSignature :=  ∀' (   &'0 r× r1 ≃ &'0   )

/-- Commutativity of multiplication -/
def MulComm : sentence RingSignature := ∀' ∀' ( x_ 0 * x_ 1 ≃ x_ 1 * x_ 0   )

/-- Distributibity -/
def AddMul : sentence RingSignature := ∀' ∀' ∀' ( (x_ 0 + x_ 1) * x_ 2 ≃ x_ 0 * x_ 2 + x_ 1 * x_ 2 )

/-- The theory of rings -/
def RingTheory : Theory RingSignature :=
{AddAssoc, AddId, AddInv, AddComm, MulAssoc, MulId, MulComm, AddMul}

lemma AddAssocInRingTheory : AddAssoc ∈ RingTheory :=
begin unfold RingTheory, left, refl end

lemma AddIdInRingTheory : AddId ∈ RingTheory :=
begin unfold RingTheory, iterate 1 {right}, left, refl end

lemma AddInvInRingTheory : AddInv ∈ RingTheory :=
begin unfold RingTheory, iterate 2 {right}, left, refl end

lemma AddCommInRingTheory : AddComm ∈ RingTheory :=
begin unfold RingTheory, iterate 3 {right}, left, refl end

lemma MulAssocInRingTheory : MulAssoc ∈ RingTheory :=
begin unfold RingTheory, iterate 4 {right}, left, refl end

lemma MulIdInRingTheory : MulId ∈ RingTheory :=
begin unfold RingTheory, iterate 5 {right}, left, refl end

lemma MulCommInRingTheory : MulComm ∈ RingTheory :=
begin unfold RingTheory, iterate 6 {right}, left, refl end

lemma AddMulInRingTheory : AddMul ∈ RingTheory :=
begin unfold RingTheory, iterate 7 {right}, exact set.mem_singleton _, end

namespace structureTo
  -- We make any (type theoretic) structure A,0,1,-,+,* into a
  -- (model theoretic) Structure in RingSignature

  variable
    {A : Type u}

  /-- Interpreting consant symbols from RingSignature -/
  @[simp] def ConstMap [has_zero A] [has_one A] : RingConsts → (dvector A 0) → A
  | RingConsts.zero _ := 0
  | RingConsts.one  _ := 1

  /-- Interpreting unary function symbols from RingSignature -/
  @[simp] def UnariesMap [has_neg A] : RingUnaries → (dvector A 1) → A
  | RingUnaries.minus a := - (dvector.last a)

  /-- Interpreting binary function symbols from RingSignature -/
  @[simp] def BinariesMap [has_add A] [has_mul A] : RingBinaries → (dvector A 2) → A
  | RingBinaries.plus   (a :: b) := a + dvector.last b
  | RingBinaries.times  (a :: b) := a * dvector.last b

  variables [has_zero A] [has_one A] [has_neg A] [has_add A] [has_mul A]

  /-- Interpreting all symbols from RingSignature-/
  @[simp] def FuncMap : Π (n : ℕ), (RingFuncs n) → (dvector A n) → A
  | 0       := ConstMap
  | 1       := UnariesMap
  | 2       := BinariesMap
  | (n + 3) := pempty.elim

  variable (A)

  /-- Interpreting the symbols -/
  @[reducible] def Structure : Structure RingSignature :=
  Structure.mk A FuncMap (λ n, pempty.elim)

  @[simp] lemma realize_zero {n} {vec : dvector A n} :
    @realize_bounded_term RingSignature (structureTo.Structure A) n vec 0
      (@bd_const RingSignature _ RingConsts.zero) dvector.nil = 0 := rfl

  @[simp] lemma realize_one {n} {vec : dvector A n} :
    @realize_bounded_term RingSignature (structureTo.Structure A) n vec 0
      (@bd_const RingSignature _ RingConsts.one) dvector.nil = 1 := rfl
end structureTo

namespace comm_ring_to

  variables
    (A : Type u) [comm_ring A]

  lemma RealizeRingTheory :
    (structureTo.Structure A) ⊨ RingTheory := -- squeeze_simp, val_zero
  begin
    intros ϕ h,
    repeat {cases h},
    {intros a b c, simp, apply add_assoc},
    {intro a, simp},
    {intro a, simp},
    {intros a b, simp, apply add_comm},
    {intros a b c, simp, apply mul_assoc},
    {intro a, simp},
    {intros a b, simp, apply mul_comm},
    {intros a b c, simp, apply add_mul},
  end

  /-- -/
  def ModelOfRingTheory : Model RingTheory.{u} :=
  ⟨ structureTo.Structure A ,  RealizeRingTheory A ⟩

  open polynomial

  -- realize_bounded_term (dvector.cons x a_) (GenPoly n) dvector.nil

  -- def yuck {n} : fin (n + 2) → fin (n + 1) := _

  -- def whateever {n} (a_ : dvector A n) : (k : ℕ) → polynomial A
  -- |
  -- |

  variable {A}

  noncomputable def yuck1 {n} (a_ : dvector A n) : fin (n + 1) → polynomial A :=
  @fin.cases n (λ k, polynomial A) polynomial.X (λ k, polynomial.C (dvector.nth' a_ k))

  noncomputable def ConstPoly : RingConsts → polynomial A
  | RingConsts.zero := 0
  | RingConsts.one := 1

  noncomputable def ConstToPoly {n} (f : RingSignature.functions 0)
    (ts : dvector (bounded_term RingSignature n) 0) :
    (Π (t : bounded_term RingSignature n), dvector.pmem t ts → polynomial A) → polynomial A :=
  λ h, ConstPoly f

  noncomputable def UniPoly : RingUnaries → polynomial A → polynomial A
  | RingUnaries.minus p := - p

  noncomputable def UniToPoly {n} (f : RingSignature.functions 1) :
    Π (ts : dvector (bounded_term RingSignature n) 1),
    (Π (t : bounded_term RingSignature n), dvector.pmem t ts → polynomial A) → polynomial A
  | [t] h := UniPoly f (h t (psum.inl rfl))

  noncomputable def BinPoly : RingBinaries → polynomial A → polynomial A → polynomial A
  | RingBinaries.plus p q := p + q
  | RingBinaries.times p q := p * q

  noncomputable def BinToPoly {n} (f : RingSignature.functions 2) :
    Π (ts : dvector (bounded_term RingSignature n) 2),
    (Π (t : bounded_term RingSignature n), dvector.pmem t ts → polynomial A) → polynomial A
  | [s, t] h := BinPoly f (h s (psum.inl rfl)) (h t (psum.inr (psum.inl rfl)))

  def MoreToPoly {m} {n} (f : RingSignature.functions (m + 3))
    (ts : dvector (bounded_term RingSignature n) 3) :
    (Π (t : bounded_term RingSignature n), dvector.pmem t ts → polynomial A) → polynomial A :=
    pempty.elim f

  -- #check @bounded_term.rec
  -- #check @bd_func RingSignature _ 2 RingBinaries.plus

  -- -- def yuck4 {n} {l} : bounded_preterm RingSignature n l
  -- --   → Σ (m : ℕ), RingSignature.functions m :=
  -- -- @bounded_term.rec RingSignature _ (λ k, ⟨ 0 , RingConsts.zero ⟩) _

  -- lemma yuck2 {n} (k) : bounded_preterm RingSignature n (k + 3) → pempty
  -- | (bd_func f) := pempty.elim f
  -- | (bd_app t s) := have false,
  -- begin
  --   unfold bounded_preterm,

  -- end,
  -- _

  -- noncomputable def term_to_polynomial2 {n} : bounded_preterm RingSignature (n + 1) 2
  --   → polynomial A → polynomial A → polynomial A
  -- | (bd_func f) := BinPoly f
  -- | (bd_app t s) := _

  -- noncomputable def term_to_polynomial1 {n} : bounded_preterm RingSignature (n + 1) 1
  --   → polynomial A → polynomial A
  -- | (bd_func f) := UniPoly f
  -- | (bd_app t s) := _

  -- -- @fin.induction_on n k (λ i, polynomial A) polynomial.X (λ i hi, polynomial.C (dvector.nth' a_ i))

  noncomputable def FuncToPoly {n} :
    Π {l : ℕ} (f : RingSignature.functions l) (ts : dvector (bounded_term RingSignature n) l),
    (Π (t : bounded_term RingSignature n), dvector.pmem t ts → polynomial A) →
    (λ (_x : bounded_term RingSignature n), polynomial A) (bd_apps (bd_func f) ts)
  | 0 := ConstToPoly
  | 1 := UniToPoly
  | 2 := BinToPoly
  | (n + 3) := λ f, pempty.elim f

  -- noncomputable def term_to_polynomial {n} (a_ : dvector A n) :
  --   bounded_preterm RingSignature (n + 1) 0 → polynomial A
  -- | (bd_var k) :=
  --   @fin.cases n (λ k, polynomial A) polynomial.X (λ k, polynomial.C (dvector.nth' a_ k)) k
  -- | (bd_func f) := ConstPoly f
  -- | (bd_app t s) := _

  #check @bounded_term.rec

  noncomputable def term_to_polynomial {n} (a_ : dvector A n) :
    bounded_term RingSignature n → polynomial A :=
  @bounded_term.rec RingSignature n (λ _, polynomial A)
    (
      λ k : fin n,
      @fin.cases n (λ k, polynomial A) polynomial.X (λ k, polynomial.C (dvector.nth' a_ k)) k
    )
    (λ _, FuncToPoly)

  -- lemma polynomial_to_term {p : polynomial A} : bounded_term RingSignature 1 :=
  -- _

  -- @[simp] lemma notsure {x : structureTo.Structure A} {n m : ℕ} {a_ : dvector A n}
  --   {p : polynomial A} :
  --   realize_bounded_term (dvector.cons x a_) (polynomial_to_term p) dvector.nil = polynomial.eval x p := _

end comm_ring_to

namespace ModelTo

  variable {M : Structure RingSignature}

  def zero : ↥ M := @Structure.fun_map _ M 0 RingConsts.zero dvector.nil
  def one : ↥ M := @Structure.fun_map _ M 0 RingConsts.one dvector.nil
  def neg (a : M.carrier) : M.carrier := @Structure.fun_map _ M 1 RingUnaries.minus ([a])
  def add (a b : M.carrier) : M.carrier := @Structure.fun_map _ M 2 RingBinaries.plus ([a , b])
  def mul (a b : M.carrier) : M.carrier := @Structure.fun_map _ M 2 RingBinaries.times ([a , b])

  instance : has_zero M := ⟨ zero ⟩
  instance : has_one M := ⟨ one ⟩
  instance : has_neg M := ⟨ neg ⟩
  instance : has_add M := ⟨ add ⟩
  instance : has_mul M := ⟨ mul ⟩

  @[simp] lemma realize_zero {n} {vec : dvector M.carrier n} :
    realize_bounded_term vec (bd_const RingConsts.zero) dvector.nil = 0 := rfl

  @[simp] lemma realize_one {n} {vec : dvector M.carrier n} :
    realize_bounded_term vec (bd_const RingConsts.one) dvector.nil = 1 := rfl

  @[simp] lemma realize_neg {a : M.carrier} :
    @Structure.fun_map _ M 1 RingUnaries.minus ([a]) = - a := rfl

  @[simp] lemma realize_add {a b : M.carrier} :
    @Structure.fun_map _ M 2 RingBinaries.plus ([a , b]) = a + b := rfl

  @[simp] lemma realize_mul {a b : M.carrier} :
    @Structure.fun_map _ M 2 RingBinaries.times ([a , b]) = a * b := rfl

  variable [h : fact (M ⊨ RingTheory)]

  include h
  lemma add_assoc (a b c : M) : (a + b) + c = a + (b + c) :=
  begin
      have hAssoc := h.elim AddAssocInRingTheory, have habc := hAssoc c b a,
      simpa using habc
  end

  lemma add_comm (a b : M) : a + b = b + a :=
  begin
    have hId := h.elim AddCommInRingTheory, have hab := hId b a, simpa using hab
  end

  lemma add_zero (a : M) : a + 0 = a :=
  begin
    have hId := h.elim AddIdInRingTheory, have ha := hId a, simpa using ha
  end

  lemma zero_add (a : M) : 0 + a = a :=
  begin
    rw add_comm, apply add_zero,
  end

  lemma left_neg (a : M) : - a + a = 0 :=
  begin
    have hInv := h.elim AddInvInRingTheory, have ha := hInv a, simpa using ha
  end

  lemma mul_assoc (a b c : M) : (a * b) * c = a * (b * c) :=
  begin
    have hAssoc := h.elim MulAssocInRingTheory, have habc := hAssoc c b a,
    simpa using habc
  end

  lemma mul_comm (a b : M) : a * b = b * a :=
  begin
    have hId := h.elim MulCommInRingTheory, have hab := hId b a, simpa using hab
  end

  lemma mul_one (a : M) : a * 1 = a :=
  begin
    have hId := h.elim MulIdInRingTheory, have ha := hId a, simpa using ha
  end

  lemma one_mul (a : M) : 1 * a = a :=
  begin
    rw mul_comm, apply mul_one
  end

  lemma add_mul (a b c : M) : (a + b) * c = a * c + b * c :=
  begin
    have hAM := h.elim AddMulInRingTheory, have habc := hAM c b a, simpa using habc
  end

  lemma mul_add (c a b : M) : c * (a + b) = c * a + c * b :=
  begin
    rw (mul_comm c (a + b)), rw (mul_comm c a), rw (mul_comm c b),
    exact add_mul a b c,
  end

  instance CommRing : comm_ring M :=
  {
    add            := add,
    add_assoc      := add_assoc,
    zero           := zero,
    zero_add       := zero_add,
    add_zero       := add_zero,
    neg            := neg,
    add_left_neg   := left_neg,
    add_comm       := add_comm,
    mul            := mul,
    mul_assoc      := mul_assoc,
    one            := one,
    one_mul        := one_mul,
    mul_one        := mul_one,
    left_distrib   := mul_add,
    right_distrib  := add_mul,
    mul_comm       := mul_comm,
  }

end ModelTo

end Rings


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

Outer measures -- overapproximations of measures
-/

import order.galois_connection algebra.big_operators algebra.module
       topology.instances.ennreal analysis.specific_limits
       measure_theory.measurable_space

noncomputable theory

open set lattice finset function filter encodable
local attribute [instance] classical.prop_decidable

namespace measure_theory

structure outer_measure (α : Type*) :=
(measure_of : set α → ennreal)
(empty : measure_of ∅ = 0)
(mono : ∀{s₁ s₂}, s₁ ⊆ s₂ → measure_of s₁ ≤ measure_of s₂)
(Union_nat : ∀(s:ℕ → set α), measure_of (⋃i, s i) ≤ (∑i, measure_of (s i)))

namespace outer_measure

instance {α} : has_coe_to_fun (outer_measure α) := ⟨_, λ m, m.measure_of⟩

section basic
variables {α : Type*} {ms : set (outer_measure α)} {m : outer_measure α}

@[simp] theorem empty' (m : outer_measure α) : m ∅ = 0 := m.empty

theorem mono' (m : outer_measure α) {s₁ s₂}
  (h : s₁ ⊆ s₂) : m s₁ ≤ m s₂ := m.mono h

theorem Union_aux (m : set α → ennreal) (m0 : m ∅ = 0)
  {β} [encodable β] (s : β → set α) :
  (∑ b, m (s b)) = ∑ i, m (⋃ b ∈ decode2 β i, s b) :=
begin
  have H : ∀ n, m (⋃ b ∈ decode2 β n, s b) ≠ 0 → (decode2 β n).is_some,
  { intros n h,
    cases decode2 β n with b,
    { exact (h (by simp [m0])).elim },
    { exact rfl } },
  refine tsum_eq_tsum_of_ne_zero_bij (λ n h, option.get (H n h)) _ _ _,
  { intros m n hm hn e,
    have := mem_decode2.1 (option.get_mem (H n hn)),
    rwa [← e, mem_decode2.1 (option.get_mem (H m hm))] at this },
  { intros b h,
    refine ⟨encode b, _, _⟩,
    { convert h, simp [ext_iff, encodek2] },
    { exact option.get_of_mem _ (encodek2 _) } },
  { intros n h,
    transitivity, swap,
    rw [show decode2 β n = _, from option.get_mem (H n h)],
    congr, simp [ext_iff] }
end

protected theorem Union (m : outer_measure α)
  {β} [encodable β] (s : β → set α) :
  m (⋃i, s i) ≤ (∑i, m (s i)) :=
by rw [Union_decode2, Union_aux _ m.empty' s]; exact m.Union_nat _

lemma Union_null (m : outer_measure α)
  {β} [encodable β] {s : β → set α} (h : ∀ i, m (s i) = 0) : m (⋃i, s i) = 0 :=
by simpa [h] using m.Union s

protected lemma union (m : outer_measure α) (s₁ s₂ : set α) :
  m (s₁ ∪ s₂) ≤ m s₁ + m s₂ :=
begin
  convert m.Union (λ b, cond b s₁ s₂),
  { simp [union_eq_Union] },
  { rw tsum_fintype, change _ = _ + _, simp }
end

lemma union_null (m : outer_measure α) {s₁ s₂ : set α}
  (h₁ : m s₁ = 0) (h₂ : m s₂ = 0) : m (s₁ ∪ s₂) = 0 :=
by simpa [h₁, h₂] using m.union s₁ s₂

@[extensionality] lemma ext : ∀{μ₁ μ₂ : outer_measure α},
  (∀s, μ₁ s = μ₂ s) → μ₁ = μ₂
| ⟨m₁, e₁, _, u₁⟩ ⟨m₂, e₂, _, u₂⟩ h := by congr; exact funext h

instance : has_zero (outer_measure α) :=
⟨{ measure_of := λ_, 0,
   empty      := rfl,
   mono       := assume _ _ _, le_refl 0,
   Union_nat  := assume s, zero_le _ }⟩

@[simp] theorem zero_apply (s : set α) : (0 : outer_measure α) s = 0 := rfl

instance : inhabited (outer_measure α) := ⟨0⟩

instance : has_add (outer_measure α) :=
⟨λm₁ m₂,
  { measure_of := λs, m₁ s + m₂ s,
    empty      := show m₁ ∅ + m₂ ∅ = 0, by simp [outer_measure.empty],
    mono       := assume s₁ s₂ h, add_le_add' (m₁.mono h) (m₂.mono h),
    Union_nat  := assume s,
      calc m₁ (⋃i, s i) + m₂ (⋃i, s i) ≤
          (∑i, m₁ (s i)) + (∑i, m₂ (s i)) :
          add_le_add' (m₁.Union_nat s) (m₂.Union_nat s)
        ... = _ : ennreal.tsum_add.symm}⟩

@[simp] theorem add_apply (m₁ m₂ : outer_measure α) (s : set α) :
  (m₁ + m₂) s = m₁ s + m₂ s := rfl

instance : add_comm_monoid (outer_measure α) :=
{ zero      := 0,
  add       := (+),
  add_comm  := assume a b, ext $ assume s, add_comm _ _,
  add_assoc := assume a b c, ext $ assume s, add_assoc _ _ _,
  add_zero  := assume a, ext $ assume s, add_zero _,
  zero_add  := assume a, ext $ assume s, zero_add _ }

instance : has_bot (outer_measure α) := ⟨0⟩

instance outer_measure.order_bot : order_bot (outer_measure α) :=
{ le          := λm₁ m₂, ∀s, m₁ s ≤ m₂ s,
  bot         := 0,
  le_refl     := assume a s, le_refl _,
  le_trans    := assume a b c hab hbc s, le_trans (hab s) (hbc s),
  le_antisymm := assume a b hab hba, ext $ assume s, le_antisymm (hab s) (hba s),
  bot_le      := assume a s, zero_le _ }

section supremum

instance : has_Sup (outer_measure α) :=
⟨λms, {
  measure_of := λs, ⨆m:ms, m.val s,
  empty      := le_zero_iff_eq.1 $ supr_le $ λ ⟨m, h⟩, le_of_eq m.empty,
  mono       := assume s₁ s₂ hs, supr_le_supr $ assume ⟨m, hm⟩, m.mono hs,
  Union_nat  := assume f, supr_le $ assume m,
    calc m.val (⋃i, f i) ≤ (∑ (i : ℕ), m.val (f i)) : m.val.Union_nat _
      ... ≤ (∑i, ⨆m:ms, m.val (f i)) :
        ennreal.tsum_le_tsum $ assume i, le_supr (λm:ms, m.val (f i)) m }⟩

private lemma le_Sup (hm : m ∈ ms) : m ≤ Sup ms :=
λ s, le_supr (λm:ms, m.val s) ⟨m, hm⟩

private lemma Sup_le (hm : ∀m' ∈ ms, m' ≤ m) : Sup ms ≤ m :=
λ s, (supr_le $ assume ⟨m', h'⟩, (hm m' h') s)

instance : has_Inf (outer_measure α) := ⟨λs, Sup {m | ∀m'∈s, m ≤ m'}⟩
private lemma Inf_le (hm : m ∈ ms) : Inf ms ≤ m := Sup_le $ assume m' h', h' _ hm
private lemma le_Inf (hm : ∀m' ∈ ms, m ≤ m') : m ≤ Inf ms := le_Sup hm

instance : complete_lattice (outer_measure α) :=
{ top          := Sup univ,
  le_top       := assume a, le_Sup (mem_univ a),
  Sup          := Sup,
  Sup_le       := assume s m, Sup_le,
  le_Sup       := assume s m, le_Sup,
  Inf          := Inf,
  Inf_le       := assume s m, Inf_le,
  le_Inf       := assume s m, le_Inf,
  sup          := λa b, Sup {a, b},
  le_sup_left  := assume a b, le_Sup $ by simp,
  le_sup_right := assume a b, le_Sup $ by simp,
  sup_le       := assume a b c ha hb, Sup_le $ by simp [or_imp_distrib, ha, hb] {contextual:=tt},
  inf          := λa b, Inf {a, b},
  inf_le_left  := assume a b, Inf_le $ by simp,
  inf_le_right := assume a b, Inf_le $ by simp,
  le_inf       := assume a b c ha hb, le_Inf $ by simp [or_imp_distrib, ha, hb] {contextual:=tt},
  .. outer_measure.order_bot }

@[simp] theorem Sup_apply (ms : set (outer_measure α)) (s : set α) :
  (Sup ms) s = ⨆ m : ms, m s := rfl

@[simp] theorem supr_apply {ι} (f : ι → outer_measure α) (s : set α) :
  (⨆ i : ι, f i) s = ⨆ i, f i s :=
le_antisymm
  (supr_le $ λ ⟨_, i, rfl⟩, le_supr _ i)
  (supr_le $ λ i, le_supr
    (λ (m : {a : outer_measure α // ∃ i, f i = a}), m.1 s)
    ⟨f i, i, rfl⟩)

@[simp] theorem sup_apply (m₁ m₂ : outer_measure α) (s : set α) :
  (m₁ ⊔ m₂) s = m₁ s ⊔ m₂ s :=
by have := supr_apply (λ b, cond b m₁ m₂) s;
  rwa [supr_bool_eq, supr_bool_eq] at this

end supremum

def map {β} (f : α → β) (m : outer_measure α) : outer_measure β :=
{ measure_of := λs, m (f ⁻¹' s),
  empty := m.empty,
  mono := λ s t h, m.mono (preimage_mono h),
  Union_nat := λ s, by rw [preimage_Union]; exact
    m.Union_nat (λ i, f ⁻¹' s i) }

@[simp] theorem map_apply {β} (f : α → β)
  (m : outer_measure α) (s : set β) : map f m s = m (f ⁻¹' s) := rfl

@[simp] theorem map_id (m : outer_measure α) : map id m = m :=
ext $ λ s, rfl

@[simp] theorem map_map {β γ} (f : α → β) (g : β → γ)
  (m : outer_measure α) : map g (map f m) = map (g ∘ f) m :=
ext $ λ s, rfl

instance : functor outer_measure := {map := λ α β, map}

instance : is_lawful_functor outer_measure :=
{ id_map := λ α, map_id,
  comp_map := λ α β γ f g m, (map_map f g m).symm }

/-- The dirac outer measure. -/
def dirac (a : α) : outer_measure α :=
{ measure_of := λs, ⨆ h : a ∈ s, 1,
  empty := by simp,
  mono := λ s t h, supr_le_supr2 (λ h', ⟨h h', le_refl _⟩),
  Union_nat := λ s, supr_le $ λ h,
    let ⟨i, h⟩ := mem_Union.1 h in
    le_trans (by exact le_supr _ h) (ennreal.le_tsum i) }

@[simp] theorem dirac_apply (a : α) (s : set α) :
  dirac a s = ⨆ h : a ∈ s, 1 := rfl

def sum {ι} (f : ι → outer_measure α) : outer_measure α :=
{ measure_of := λs, ∑ i, f i s,
  empty := by simp,
  mono := λ s t h, ennreal.tsum_le_tsum (λ i, (f i).mono' h),
  Union_nat := λ s, by rw ennreal.tsum_comm; exact
    ennreal.tsum_le_tsum (λ i, (f i).Union_nat _) }

@[simp] theorem sum_apply {ι} (f : ι → outer_measure α) (s : set α) :
  sum f s = ∑ i, f i s := rfl

instance : has_scalar ennreal (outer_measure α) :=
⟨λ a m, {
  measure_of := λs, a * m s,
  empty := by simp,
  mono := λ s t h, canonically_ordered_semiring.mul_le_mul (le_refl _) (m.mono' h),
  Union_nat := λ s, by rw ennreal.mul_tsum; exact
    canonically_ordered_semiring.mul_le_mul (le_refl _) (m.Union_nat _) }⟩

@[simp] theorem smul_apply (a : ennreal) (m : outer_measure α) (s : set α) :
  (a • m) s = a * m s := rfl

instance : semimodule ennreal (outer_measure α) :=
{ smul_add := λ a m₁ m₂, ext $ λ s, mul_add _ _ _,
  add_smul := λ a b m, ext $ λ s, add_mul _ _ _,
  mul_smul := λ a b m, ext $ λ s, mul_assoc _ _ _,
  one_smul := λ m, ext $ λ s, one_mul _,
  zero_smul := λ m, ext $ λ s, zero_mul _,
  smul_zero := λ a, ext $ λ s, mul_zero _,
  ..outer_measure.has_scalar }

theorem smul_dirac_apply (a : ennreal) (b : α) (s : set α) :
  (a • dirac b) s = ⨆ h : b ∈ s, a :=
by by_cases b ∈ s; simp [h]

theorem top_apply {s : set α} (h : s ≠ ∅) : (⊤ : outer_measure α) s = ⊤ :=
let ⟨a, as⟩ := set.exists_mem_of_ne_empty h in
top_unique $ le_supr_of_le ⟨(⊤ : ennreal) • dirac a, trivial⟩ $
by simp [smul_dirac_apply, as]

end basic

section of_function
set_option eqn_compiler.zeta true

/-- Given any function `m` assigning measures to sets satisying `m ∅ = 0`, there is
  a unique maximal outer measure `μ` satisfying `μ s ≤ m s` for all `s : set α`. -/
protected def of_function {α : Type*} (m : set α → ennreal) (m_empty : m ∅ = 0) :
  outer_measure α :=
let μ := λs, ⨅{f : ℕ → set α} (h : s ⊆ ⋃i, f i), ∑i, m (f i) in
{ measure_of := μ,
  empty      := le_antisymm
    (infi_le_of_le (λ_, ∅) $ infi_le_of_le (empty_subset _) $ by simp [m_empty])
    (zero_le _),
  mono       := assume s₁ s₂ hs, infi_le_infi $ assume f,
    infi_le_infi2 $ assume hb, ⟨subset.trans hs hb, le_refl _⟩,
  Union_nat := assume s, ennreal.le_of_forall_epsilon_le $ begin
    assume ε hε (hb : (∑i, μ (s i)) < ⊤),
    rcases ennreal.exists_pos_sum_of_encodable (ennreal.coe_lt_coe.2 hε) ℕ with ⟨ε', hε', hl⟩,
    refine le_trans _ (add_le_add_left' (le_of_lt hl)),
    rw ← ennreal.tsum_add,
    choose f hf using show
      ∀i, ∃f:ℕ → set α, s i ⊆ (⋃i, f i) ∧ (∑i, m (f i)) < μ (s i) + ε' i,
    { intro,
      have : μ (s i) < μ (s i) + ε' i :=
        ennreal.lt_add_right
          (lt_of_le_of_lt (by apply ennreal.le_tsum) hb)
          (by simpa using hε' i),
      simpa [μ, infi_lt_iff] },
    refine le_trans _ (ennreal.tsum_le_tsum $ λ i, le_of_lt (hf i).2),
    rw [← ennreal.tsum_prod, ← tsum_equiv equiv.nat_prod_nat_equiv_nat.symm],
    swap, {apply_instance},
    refine infi_le_of_le _ (infi_le _ _),
    exact Union_subset (λ i, subset.trans (hf i).1 $
      Union_subset $ λ j, subset.trans (by simp) $
      subset_Union _ $ equiv.nat_prod_nat_equiv_nat (i, j)),
  end }

theorem of_function_le {α : Type*} (m : set α → ennreal) (m_empty s) :
  outer_measure.of_function m m_empty s ≤ m s :=
let f : ℕ → set α := λi, nat.rec_on i s (λn s, ∅) in
infi_le_of_le f $ infi_le_of_le (subset_Union f 0) $ le_of_eq $
calc (∑i, m (f i)) = ({0} : finset ℕ).sum (λi, m (f i)) :
    tsum_eq_sum $ by intro i; cases i; simp [m_empty]
  ... = m s : by simp; refl

theorem le_of_function {α : Type*} {m m_empty} {μ : outer_measure α} :
  μ ≤ outer_measure.of_function m m_empty ↔ ∀ s, μ s ≤ m s :=
⟨λ H s, le_trans (H _) (of_function_le _ _ _),
 λ H s, le_infi $ λ f, le_infi $ λ hs,
  le_trans (μ.mono hs) $ le_trans (μ.Union f) $
  ennreal.tsum_le_tsum $ λ i, H _⟩

end of_function

section caratheodory_measurable
universe u
parameters {α : Type u} (m : outer_measure α)
include m

local attribute [simp] set.inter_comm set.inter_left_comm set.inter_assoc

variables {s s₁ s₂ : set α}

private def C (s : set α) := ∀t, m t = m (t ∩ s) + m (t \ s)

private lemma C_iff_le {s : set α} : C s ↔ ∀t, m (t ∩ s) + m (t \ s) ≤ m t :=
forall_congr $ λ t, le_antisymm_iff.trans $ and_iff_right $
by convert m.union _ _; rw inter_union_diff t s

@[simp] private lemma C_empty : C ∅ := by simp [C, m.empty, diff_empty]

private lemma C_compl : C s₁ → C (- s₁) := by simp [C, diff_eq]

@[simp] private lemma C_compl_iff : C (- s) ↔ C s :=
⟨λ h, by simpa using C_compl m h, C_compl⟩

private lemma C_union (h₁ : C s₁) (h₂ : C s₂) : C (s₁ ∪ s₂) :=
λ t, begin
  rw [h₁ t, h₂ (t ∩ s₁), h₂ (t \ s₁), h₁ (t ∩ (s₁ ∪ s₂)),
    inter_diff_assoc _ _ s₁, set.inter_assoc _ _ s₁,
    inter_eq_self_of_subset_right (set.subset_union_left _ _),
    union_diff_left, h₂ (t ∩ s₁)],
  simp [diff_eq]
end

private lemma measure_inter_union (h : s₁ ∩ s₂ ⊆ ∅) (h₁ : C s₁) {t : set α} :
  m (t ∩ (s₁ ∪ s₂)) = m (t ∩ s₁) + m (t ∩ s₂) :=
by rw [h₁, set.inter_assoc, union_inter_cancel_left,
  inter_diff_assoc, union_diff_cancel_left h]

private lemma C_Union_lt {s : ℕ → set α} : ∀{n:ℕ}, (∀i<n, C (s i)) → C (⋃i<n, s i)
| 0       h := by simp [nat.not_lt_zero]
| (n + 1) h := by rw Union_lt_succ; exact C_union m
  (h n (le_refl (n + 1)))
      (C_Union_lt $ assume i hi, h i $ lt_of_lt_of_le hi $ nat.le_succ _)

private lemma C_inter (h₁ : C s₁) (h₂ : C s₂) : C (s₁ ∩ s₂) :=
by rw [← C_compl_iff, compl_inter]; from C_union _ (C_compl _ h₁) (C_compl _ h₂)

private lemma C_sum {s : ℕ → set α} (h : ∀i, C (s i)) (hd : pairwise (disjoint on s)) {t : set α} :
  ∀ {n}, (finset.range n).sum (λi, m (t ∩ s i)) = m (t ∩ ⋃i<n, s i)
| 0            := by simp [nat.not_lt_zero, m.empty]
| (nat.succ n) := begin
  simp [Union_lt_succ, range_succ],
  rw [measure_inter_union m _ (h n), C_sum],
  intro a, simpa [range_succ] using λ h₁ i hi h₂, hd _ _ (ne_of_gt hi) ⟨h₁, h₂⟩
end

private lemma C_Union_nat {s : ℕ → set α} (h : ∀i, C (s i))
  (hd : pairwise (disjoint on s)) : C (⋃i, s i) :=
C_iff_le.2 $ λ t, begin
  have hp : m (t ∩ ⋃i, s i) ≤ (⨆n, m (t ∩ ⋃i<n, s i)),
  { convert m.Union (λ i, t ∩ s i),
    { rw inter_Union_left },
    { simp [ennreal.tsum_eq_supr_nat, C_sum m h hd] } },
  refine le_trans (add_le_add_right' hp) _,
  rw ennreal.supr_add,
  refine supr_le (λ n, le_trans (add_le_add_left' _)
    (ge_of_eq (C_Union_lt m (λ i _, h i) _))),
  refine m.mono (diff_subset_diff_right _),
  exact bUnion_subset (λ i _, subset_Union _ i),
end

private lemma f_Union {s : ℕ → set α} (h : ∀i, C (s i))
  (hd : pairwise (disjoint on s)) : m (⋃i, s i) = ∑i, m (s i) :=
begin
  refine le_antisymm (m.Union_nat s) _,
  rw ennreal.tsum_eq_supr_nat,
  refine supr_le (λ n, _),
  have := @C_sum _ m _ h hd univ n,
  simp at this, simp [this],
  exact m.mono (bUnion_subset (λ i _, subset_Union _ i)),
end

private def caratheodory_dynkin : measurable_space.dynkin_system α :=
{ has := C,
  has_empty := C_empty,
  has_compl := assume s, C_compl,
  has_Union_nat := assume f hf hn, C_Union_nat hn hf }

/-- Given an outer measure `μ`, the Caratheodory measurable space is
  defined such that `s` is measurable if `∀t, μ t = μ (t ∩ s) + μ (t \ s)`. -/
protected def caratheodory : measurable_space α :=
caratheodory_dynkin.to_measurable_space $ assume s₁ s₂, C_inter

lemma is_caratheodory {s : set α} :
  caratheodory.is_measurable s ↔ ∀t, m t = m (t ∩ s) + m (t \ s) :=
iff.rfl

lemma is_caratheodory_le {s : set α} :
  caratheodory.is_measurable s ↔ ∀t, m (t ∩ s) + m (t \ s) ≤ m t :=
C_iff_le

protected lemma Union_eq_of_caratheodory {s : ℕ → set α}
  (h : ∀i, caratheodory.is_measurable (s i)) (hd : pairwise (disjoint on s)) :
  m (⋃i, s i) = ∑i, m (s i) :=
f_Union h hd

end caratheodory_measurable

variables {α : Type*}

lemma caratheodory_is_measurable {m : set α → ennreal} {s : set α}
  {h₀ : m ∅ = 0} (hs : ∀t, m (t ∩ s) + m (t \ s) ≤ m t) :
  (outer_measure.of_function m h₀).caratheodory.is_measurable s :=
let o := (outer_measure.of_function m h₀) in
(is_caratheodory_le o).2 $ λ t,
le_infi $ λ f, le_infi $ λ hf, begin
  refine le_trans (add_le_add'
    (infi_le_of_le (λi, f i ∩ s) $ infi_le _ _)
    (infi_le_of_le (λi, f i \ s) $ infi_le _ _)) _,
  { rw ← inter_Union_right,
    exact inter_subset_inter_left _ hf },
  { rw ← diff_Union_right,
    exact diff_subset_diff_left hf },
  { rw ← ennreal.tsum_add,
    exact ennreal.tsum_le_tsum (λ i, hs _) }
end

@[simp] theorem zero_caratheodory : (0 : outer_measure α).caratheodory = ⊤ :=
top_unique $ λ s _ t, (add_zero _).symm

theorem top_caratheodory : (⊤ : outer_measure α).caratheodory = ⊤ :=
top_unique $ assume s hs, (is_caratheodory_le _).2 $ assume t,
  by by_cases ht : t = ∅; simp [ht, top_apply]

theorem le_add_caratheodory (m₁ m₂ : outer_measure α) :
  m₁.caratheodory ⊓ m₂.caratheodory ≤ (m₁ + m₂ : outer_measure α).caratheodory :=
λ s ⟨hs₁, hs₂⟩ t, by simp [hs₁ t, hs₂ t]

theorem le_sum_caratheodory {ι} (m : ι → outer_measure α) :
  (⨅ i, (m i).caratheodory) ≤ (sum m).caratheodory :=
λ s h t, by simp [λ i,
  measurable_space.is_measurable_infi.1 h i t, ennreal.tsum_add]

theorem le_smul_caratheodory (a : ennreal) (m : outer_measure α) :
  m.caratheodory ≤ (a • m).caratheodory :=
λ s h t, by simp [h t, mul_add]

@[simp] theorem dirac_caratheodory (a : α) : (dirac a).caratheodory = ⊤ :=
top_unique $ λ s _ t, begin
  by_cases a ∈ t; simp [h],
  by_cases a ∈ s; simp [h]
end

section Inf_gen

def Inf_gen (m : set (outer_measure α)) (s : set α) : ennreal :=
⨆(h : s ≠ ∅), ⨅ (μ : outer_measure α) (h : μ ∈ m), μ s

@[simp] lemma Inf_gen_empty (m : set (outer_measure α)) : Inf_gen m ∅ = 0 :=
by simp [Inf_gen]

lemma Inf_gen_nonempty1 (m : set (outer_measure α)) (t : set α) (h : t ≠ ∅) :
  Inf_gen m t = (⨅ (μ : outer_measure α) (h : μ ∈ m), μ t) :=
by rw [Inf_gen, supr_pos h]

lemma Inf_gen_nonempty2 (m : set (outer_measure α)) (μ) (h : μ ∈ m) (t) :
  Inf_gen m t = (⨅ (μ : outer_measure α) (h : μ ∈ m), μ t) :=
begin
  by_cases ht : t = ∅,
  { simp [ht],
    refine (bot_unique $ infi_le_of_le μ $ _).symm,
    refine infi_le_of_le h (le_refl ⊥) },
  { exact Inf_gen_nonempty1 m t ht }
end

lemma Inf_eq_of_function_Inf_gen (m : set (outer_measure α)) :
  Inf m = outer_measure.of_function (Inf_gen m) (Inf_gen_empty m) :=
begin
  refine le_antisymm
    (assume t', le_of_function.2 (assume t, _) _)
    (lattice.le_Inf $ assume μ hμ t, le_trans (outer_measure.of_function_le _ _ _) _);
    by_cases ht : t = ∅; simp [ht, Inf_gen_nonempty1],
  { assume μ hμ, exact (show Inf m ≤ μ, from lattice.Inf_le hμ) t },
  { exact infi_le_of_le μ (infi_le _ hμ) }
end

end Inf_gen

end outer_measure

end measure_theory


import data.zmod.basic
import adjacency_matrix sym_matrix double_counting data.fintype.basic
import changing_scalars
import data.int.modeq
import tactic
import char_poly
import number_theory.quadratic_reciprocity

open_locale classical
noncomputable theory

lemma exists_unique_rewrite {X:Type*} {p: X → Prop} {q: X → Prop}:
  (∀ x:X, p x ↔ q x) → (∃!x : X, p x) → ∃!x:X, q x:=
begin
  intro h, rw exists_unique_congr h,
  tidy,
end

variables {V:Type} [fintype V] [inhabited V]

def is_friend (G : simple_graph V) (v w : V) (u : V) : Prop :=
G.E v u ∧ G.E w u

def friendship (G : simple_graph V) : Prop :=
∀ v w : V, v ≠ w → ∃!(u : V), is_friend G v w u

@[simp] lemma friend_symm {G : simple_graph V} {v w x:V} :
  G.E v x ∧ G.E x w ↔ G.E v x ∧ G.E w x:=
begin
  split; try { intro a, cases a, split };
  try {assumption};
  { apply G.undirected, assumption },
end

def find_friend (G:simple_graph V)(friendG: friendship G)(v w:V)(vneqw:v ≠ w):V:=
  fintype.choose (is_friend G v w) (friendG v w vneqw)

lemma find_friend_spec (G:simple_graph V)(friendG: friendship G)(v w:V)(vneqw: v ≠ w):
  is_friend G v w (find_friend G friendG v w vneqw):= by apply fintype.choose_spec

lemma find_friend_unique (G:simple_graph V)(friendG: friendship G)(v w:V)(vneqw: v ≠ w):
  ∀ y:V, is_friend G v w y → y=(find_friend G friendG v w vneqw):=
begin
  intros y hy,
  apply exists_unique.unique(friendG v w vneqw),
  apply hy,
  apply (find_friend_spec G friendG v w vneqw),
end

def exists_politician (G:simple_graph V) : Prop :=
  ∃ v:V, ∀ w:V, v=w ∨ G.E v w

def no_pol (G:simple_graph V) : Prop :=
  ∀ v:V, ∃ w:V, v ≠ w ∧ ¬ G.E v w

lemma exists_pol_of_not_no_pol {G:simple_graph V}:
  (¬ no_pol G) ↔ exists_politician G:=
begin
  unfold no_pol exists_politician, simp only [not_exists, not_and, classical.not_forall, ne.def, classical.not_not],
  apply exists_congr, intro v, apply forall_congr, intro w, tauto,
end

def path_bigraph (G : simple_graph V) (A B:finset V) : bigraph V V:=
  bigraph.mk A B G.E

lemma path_bigraph_swap {G : simple_graph V} {A B : finset V} :
  (path_bigraph G A B).swap = path_bigraph G B A:=
begin
  ext, {refl}, {refl},
  split; apply G.undirected,
end

def friends (G : simple_graph V)(v w : V) : finset V :=
  finset.filter (is_friend G v w) (finset.univ:finset V)

lemma friends_eq_inter_neighbors {G : simple_graph V} {v w : V} :
  friends G v w = neighbors G v ∩ neighbors G w:=
begin
  ext,
  rw finset.mem_inter, erw finset.mem_filter,
  unfold is_friend, simp,
end

lemma friendship' {G : simple_graph V} (friendG : friendship G) {v w : V} (hvw : v ≠ w):
exists_unique (is_friend G v w) :=
begin
  use find_friend G friendG v w hvw,
  split, exact find_friend_spec G friendG v w hvw,

  intros x hx,
  apply exists_unique.unique (friendG v w hvw) hx,
  exact find_friend_spec G friendG v w hvw,
end

lemma card_friends {G : simple_graph V} (friendG : friendship G) {v w : V} (hvw : v ≠ w) :
  (friends G v w).card = 1 :=
begin
  rw finset.card_eq_one,
  rw finset.singleton_iff_unique_mem,
  unfold friends, simp [friendship' friendG hvw],
end

lemma left_fiber_eq_nbrs_inter_A {G : simple_graph V} {A B : finset V} {v : V} :
  v ∈ B → left_fiber (path_bigraph G A B) v = A ∩ (neighbors G v):=
begin
  intro vB, ext,
  simp only [neighbor_iff_adjacent, mem_left_fiber, finset.mem_inter],
  change a ∈ A ∧ G.E a v ↔ a ∈ A ∧ G.E v a,
  have h : G.E a v ↔ G.E v a, {split; apply G.undirected},
  rw h,
end

lemma right_fiber_eq_nbrs_inter_B {G : simple_graph V} {A B : finset V} {v : V} (hv : v ∈ A):
right_fiber (path_bigraph G A B) v = B ∩ (neighbors G v):=
begin
  rw [← left_fiber_swap, path_bigraph_swap],
  exact left_fiber_eq_nbrs_inter_A hv,
end

lemma lunique_paths {G : simple_graph V} {v : V} {B : finset V} (hG : friendship G) (hv : v ∉ B):
left_unique (path_bigraph G (neighbors G v) B) :=
begin
  rw left_unique_one_reg,
  unfold left_regular,
  intros b hb,
  have hsub : left_fiber (path_bigraph G (neighbors G v) B) b = (neighbors G v) ∩ (neighbors G b),
  apply left_fiber_eq_nbrs_inter_A hb,
  rw [hsub, ← friends_eq_inter_neighbors],
  apply card_friends hG,
  intro veqb, rw veqb at hv,
  contradiction,
end

lemma runique_paths {G:simple_graph V} {v : V} {A : finset V} (hG : friendship G) (hv : v ∉ A):
right_unique (path_bigraph G A (neighbors G v)):=
begin
  rw [← path_bigraph_swap, right_unique_swap],
  exact lunique_paths hG hv,
end

lemma counter_non_adj_deg_eq
  {G : simple_graph V} (hG : friendship G)  (hG' : no_pol G)
  {v w : V} (hvw : ¬ G.E v w ):
degree G v = degree G w:=
begin
  by_cases v=w, { rw h },

  let b:= bigraph.mk (neighbors G v) (neighbors G w) (λ (x:V), λ (y:V), G.E x y),

  apply card_eq_of_lunique_runique b,
  { apply lunique_paths hG,
    rw neighbor_iff_adjacent,
    intro contra,
    apply hvw,
    apply G.undirected contra },
  apply runique_paths hG,
  rw neighbor_iff_adjacent,
  apply hvw,
end

theorem counter_reg {G:simple_graph V} (hG : friendship G) (hG' : no_pol G) :
∃ d:ℕ, regular_graph G d :=
begin
  have np:=hG',
  have h2:=counter_non_adj_deg_eq hG,
  have v := arbitrary V,
  use degree G v,
  intro x,
  by_cases hvx : G.E v x,
    swap, symmetry, apply counter_non_adj_deg_eq hG hG' hvx,

  rcases hG' v with ⟨w, hvw', hvw⟩,
  rcases hG' x with ⟨y, hxy', hxy⟩,
  have degvw:=counter_non_adj_deg_eq hG hG' hvw,
  have degxy:=counter_non_adj_deg_eq hG hG' hxy,
  by_cases hxw : G.E x w,
    swap, {rw degvw, apply counter_non_adj_deg_eq hG hG' hxw},
  rw degxy,
  by_cases hvy : G.E v y,
    swap, {symmetry, apply counter_non_adj_deg_eq hG hG' hvy},
  rw degvw,
  apply counter_non_adj_deg_eq hG hG',
  intro hcontra,
  apply hxy',
  apply exists_unique.unique (hG v w hvw'),
  exact ⟨hvx, G.undirected hxw⟩,
  exact ⟨hvy, G.undirected hcontra⟩,
end

variables {R : Type*} [ring R]

theorem friendship_adj_sq_off_diag_eq_one
  (G:simple_graph V) (hG : friendship G) {v w : V} (hvw : v ≠ w) :
((adjacency_matrix R G)^2) v w = 1 :=
begin
  rw [pow_two, adjacency_matrix_mul_apply, ← nat.cast_one, ← card_friends hG hvw, friends_eq_inter_neighbors],
  unfold neighbors, simp [finset.inter_filter],
end

def two_path_from_v (G:simple_graph V) (v:V):(V × V → Prop):=
  λ x:V × V, G.E v x.fst ∧ G.E x.fst x.snd

lemma friendship_reg_card_count_1
  {G:simple_graph V} (hG : friendship G) (v:V) :
card_edges (path_bigraph G (neighbors G v) (finset.erase finset.univ v))=(finset.erase finset.univ v).card:=
begin
  apply card_edges_of_lunique,
  apply lunique_paths hG,
  apply finset.not_mem_erase,
end

lemma friendship_reg_card_count_2
  {G:simple_graph V} {d:ℕ} (hd : regular_graph G d) (v:V) :
card_edges (path_bigraph G (neighbors G v) {v}) = d :=
begin
  unfold regular_graph at hd,
  rw ← hd v,
  apply card_edges_of_runique,
  rw right_unique_one_reg,
  unfold right_regular,
  intros a ha,
  change a ∈ neighbors G v at ha,
  rw right_fiber_eq_nbrs_inter_B ha,
  have h:neighbors G a∩ {v} = {v},
  { apply finset.inter_singleton_of_mem,
    rw neighbor_iff_adjacent,
    rw neighbor_iff_adjacent at ha,
    exact G.undirected ha },
  rw [finset.inter_comm, h], simp,
end

lemma reg_card_count_3
  {G:simple_graph V} {d:ℕ} (hd : regular_graph G d) (v:V) :
card_edges (path_bigraph G (neighbors G v) finset.univ) = d * d :=
begin
  unfold regular_graph at hd,
  unfold degree at hd,

  transitivity d * (neighbors G v).card,
  swap, { rw hd v },
  apply card_edges_of_rreg,
  intros a ha,
  rw right_fiber_eq_nbrs_inter_B,
  { rw [finset.univ_inter, hd a] },
  { exact ha },
end

lemma finset.erase_disj_sing {α:Type*}{s:finset α}{a:α}:
  disjoint (s.erase a) {a}:=
begin
  rw finset.disjoint_singleton,
  apply finset.not_mem_erase,
end

lemma finset.erase_union_sing {α:Type*}{s:finset α}{a:α}:
  a ∈ s → s.erase a ∪ {a}=s:=
begin
  intro h,
  rw finset.union_comm,
  rw ← finset.insert_eq,
  apply finset.insert_erase h,
end

theorem friendship_reg_card
  {G:simple_graph V} {d:ℕ} (hG : friendship G) (hd : regular_graph G d) :
(fintype.card V) - 1 + d = d * d :=
begin
  have v:=arbitrary V,
  have hv : v ∈ finset.univ,
    {apply finset.mem_univ}, swap, {apply_instance},

  have un:(finset.erase finset.univ v)∪ {v}=finset.univ,
  { apply finset.erase_union_sing hv},

  rw ← reg_card_count_3 hd v,
  rw ← un,

  rw ← finset.card_univ,
  rw ← nat.pred_eq_sub_one,
  rw ← finset.card_erase_of_mem hv,

  rw ← friendship_reg_card_count_1 hG v,

  rw ← friendship_reg_card_count_2 hd v,

  symmetry,
  apply card_edges_add_of_eq_disj_union_eq,
  apply finset.erase_disj_sing,
end

theorem friendship_reg_card'
  {G : simple_graph V} {d : ℕ} (hG : friendship G) (hd : regular_graph G d) :
(fintype.card V:ℤ) = d * (↑d -1) +1:=
begin
  rw mul_sub, norm_cast, rw ← friendship_reg_card hG hd,
  have : 0 ≠ fintype.card V,
  { have v := arbitrary V,
    unfold fintype.card,
    have : v ∈ @finset.univ V _, simp,
    symmetry, exact finset.card_ne_zero_of_mem this },
  push_cast, ring, norm_cast, omega,
end

lemma d_dvd_card_V
  {G : simple_graph V} {d : ℕ} (hG : friendship G) (hd : regular_graph G d)
  {p : ℕ} (hp : p ∣ d - 1) (d_pos : 0 < d) :
(p:ℤ) ∣ fintype.card V - 1 :=
begin
  rw friendship_reg_card' hG hd, ring,
  cases hp with k hk,
  use d * k, norm_cast, rw hk, ring,
end

lemma le_one_of_pred_zero {n:ℕ}:
  n-1=0 → n ≤ 1:= by omega

local attribute [simp]
lemma nat.smul_one (d : ℕ) (R : Type*) [ring R] : d • (1 : R) = (d : R) :=
begin
  induction d with k hk, simp,
  rw nat.succ_eq_add_one, push_cast,
  rw ← hk, rw add_smul, simp,
end

local attribute [simp]
lemma int.smul_one (d : ℤ) (R : Type*) [ring R] : d • (1 : R) = (d : R) :=
begin
  apply gsmul_one,
end

variable (R)
theorem friendship_reg_adj_sq
  (G:simple_graph V) (d:ℕ) (pos : 0<d) (hG : friendship G) (hd : regular_graph G d) :
(adjacency_matrix R G)^2 = matrix_J R V + (d-1:ℤ) • 1 :=
begin
  ext,
  by_cases i=j,
  { rw [← h, pow_two],
    rw adj_mat_sq_apply_eq,
    rw hd i,
    unfold matrix_J,
    simp only [matrix.one_val_eq, nat.smul_one, matrix.add_val, pi.smul_apply],
    cases d, {norm_num at pos}, {simp, rw add_comm,} },

  rw friendship_adj_sq_off_diag_eq_one G hG h,
  unfold matrix_J,
  simp [matrix.one_val_ne h],
end
variable {R}

lemma subsingleton_graph_has_pol (G : simple_graph V) :
  fintype.card V ≤ 1 → exists_politician G:=
begin
  intro subsing,
  rw fintype.card_le_one_iff at subsing,
  use arbitrary V, intro w,
  left, apply subsing,
end

lemma deg_le_one_friendship_has_pol
  {G:simple_graph V} {d:ℕ} (hG : friendship G) (hd : regular_graph G d) :
d ≤ 1 → exists_politician G :=
begin
  intro d_le_one,
  have sq : d * d = d := by {interval_cases d; norm_num},

  have hfr := friendship_reg_card hG hd,
  rw sq at hfr,
  apply subsingleton_graph_has_pol,
  apply le_one_of_pred_zero,
  linarith,
end

lemma ne_of_edge {G : simple_graph V} {a b : V} (hab : G.E a b) : a ≠ b :=
begin
  intro h, rw h at hab, apply G.loopless b, exact hab,
end

lemma deg_two_friendship_has_pol
  {G:simple_graph V} {d:ℕ}  (hG : friendship G) (hd : regular_graph G d) :
d = 2 → exists_politician G :=
begin
  intro deq2,
  rw deq2 at hd,
  have v := arbitrary V,
  have hfr:=friendship_reg_card hG hd,
  have h2 : fintype.card V - 1 = 2 := by linarith, clear hfr,
  -- now we have a degree two graph with three vertices
  -- the math thing to do would be to replace it with the triangle graph

  have herase : (finset.univ.erase v).card = fintype.card V - 1,
  { apply finset.card_erase_of_mem,
    apply finset.mem_univ },
  rw h2 at herase, clear h2,

  existsi v, intro w,
  by_cases hvw : v = w, { left, exact hvw }, right,

  have h':neighbors G v = finset.univ.erase v,
  apply finset.eq_of_subset_of_card_le,
  { rw finset.subset_iff,
    intro x,
    rw neighbor_iff_adjacent,
    rw finset.mem_erase,
    intro h,
    split, { symmetry, exact ne_of_edge h },
    apply finset.mem_univ },

  { rw herase,
    unfold regular_graph at hd, unfold degree at hd,
    rw hd },

  rw [← neighbor_iff_adjacent, h', finset.mem_erase],
  split, { symmetry, exact hvw },
  apply finset.mem_univ
end

lemma deg_le_two_friendship_has_pol
  {G:simple_graph V} {d:ℕ} (hG : friendship G) (hd : regular_graph G d) :
d ≤ 2 → exists_politician G:=
begin
  intro d_le_2,
  interval_cases d,
  iterate 2 { apply deg_le_one_friendship_has_pol hG hd, norm_num },
  { apply deg_two_friendship_has_pol hG hd, refl },
end

--def matrix_mod (V : Type* ) [fintype V] (p:ℕ) : matrix V V ℤ →+* matrix V V (zmod p) :=
--matrix.ring_hom_apply (int.cast_ring_hom (zmod p))

--def matrix_J_mod_p (V)[fintype V](p:ℕ): matrix V V (zmod p):=
--  (matrix_mod V p) (matrix_J ℤ V)

lemma matrix_J_sq :
(matrix_J R V)^2 = (fintype.card V : R) • (matrix_J R V) :=
begin
  rw pow_two,
  rw matrix.mul_eq_mul, ext, rw matrix.mul_val,
  unfold matrix_J,
  simp; refl,
end

lemma matrix_J_mod_p_idem
  {p:ℕ} [char_p R p] (hp : ↑p ∣ (fintype.card V : ℤ ) - 1) :
(matrix_J (zmod p) V) ^ 2 = matrix_J (zmod p) V :=
begin
  rw matrix_J_sq,
  have : (fintype.card V : zmod p) = 1, swap, simp [this], symmetry,
  rw [← nat.cast_one, zmod.eq_iff_modeq_nat, ← int.modeq.coe_nat_modeq_iff, int.modeq.modeq_iff_dvd], apply hp,
end

--lemma trace_mod (p:ℕ) (M: matrix V V ℤ):
--matrix.trace V (zmod p) (zmod p) (matrix_mod V p M) = (matrix.trace V ℤ ℤ M : zmod p):=
--begin
--  rw matrix_mod,
--  rw matrix.ring_hom_apply.trace (int.cast_ring_hom (zmod p)) M,
--  refl,
--end

lemma friendship_reg_adj_sq_mod_p
  {G:simple_graph V} {d:ℕ} {dpos:0<d} (hG : friendship G) (hd : regular_graph G d)
  {p:ℕ} (hp : ↑p ∣ (d: ℤ ) - 1) :
(adjacency_matrix (zmod p) G)^2 = matrix_J (zmod p) V:=
begin
  rw friendship_reg_adj_sq (zmod p) G d dpos hG hd,
  have h : (d - 1 : ℤ) • (1 : matrix V V (zmod p)) = 0, swap, rw [h, add_zero],
  rw ← char_p.int_cast_eq_zero_iff (matrix V V (zmod p)) at hp, rw ← hp,
  simp [algebra.smul_def'],
end

lemma friendship_reg_adj_mul_J
  {G:simple_graph V} {d:ℕ} {dpos:0<d} (hG : friendship G) (hd : regular_graph G d)
  :
(adjacency_matrix R G) * (matrix_J R V) = (d : ℤ) • matrix_J R V :=
by { ext, unfold matrix_J, rw ← hd i, unfold degree, simp, }

lemma friendship_reg_adj_mul_J_mod_p
  {G:simple_graph V} {d:ℕ} {dpos:0<d} (hG : friendship G) (hd : regular_graph G d)
  {p:ℕ} (hp : ↑p ∣ (d: ℤ ) - 1) :
(adjacency_matrix (zmod p) G) * (matrix_J (zmod p) V) = matrix_J (zmod p) V:=
begin
  ext, symmetry, simp only [adjacency_matrix_mul_apply, finset.sum_apply, mul_one, matrix_J_apply, finset.sum_const, nsmul_eq_mul],
  rw [← degree, hd, ← nat.cast_one, zmod.eq_iff_modeq_nat, ← int.modeq.coe_nat_modeq_iff, int.modeq.modeq_iff_dvd], apply hp,
end

lemma friendship_reg_adj_pow_mod_p
  {G:simple_graph V} {d:ℕ} {dpos:0<d} (hG : friendship G) (hd : regular_graph G d)
  {p:ℕ} (hp : ↑p ∣ (d: ℤ ) - 1) {k : ℕ} (hk : 2 ≤ k):
(adjacency_matrix (zmod p) G) ^ k = matrix_J (zmod p) V :=
begin
  iterate 2 {cases k with k, { exfalso, linarith,},},
  induction k with k hind,
  { apply friendship_reg_adj_sq_mod_p hG hd hp,
    exact dpos},
  { rw pow_succ,
    have h2 : 2 ≤ k.succ.succ := by omega,
    have hind2 := hind h2,
    rw hind2,
    apply friendship_reg_adj_mul_J_mod_p hG hd hp,
    exact dpos }
end

lemma tr_pow_p_mod_p {p:ℕ} [fact p.prime] (M : matrix V V (zmod p)) :
matrix.trace V (zmod p) (zmod p) (M ^ p) = (matrix.trace V (zmod p) (zmod p) M)^p :=
by rw [trace_from_char_poly, trace_from_char_poly, char_poly_pow_p_char_p, frobenius_fixed]

lemma three_le_deg_friendship_contra
  {G:simple_graph V} {d:ℕ} (hG : friendship G) (hd : regular_graph G d) :
3 ≤ d → false :=
begin
  intro h,
  have dpos : 0<d := by linarith,
  let p:ℕ:=(d-1).min_fac,
  have hadj:=friendship_reg_adj_sq (zmod p) G d dpos hG,
  have traceless:=adj_mat_traceless (zmod p) G,
  have cardV:=friendship_reg_card' hG hd,
  have p_dvd_d_pred:p ∣ d-1:=(d-1).min_fac_dvd,
  have d_cast : coe (d - 1) = (d : ℤ) - 1 := by norm_cast,
  have p_dvd_V_pred:↑p ∣ ((fintype.card V:ℤ)-1),
  { transitivity ↑(d-1), {rwa int.coe_nat_dvd},
    use d, rw [d_cast, cardV], ring },
  have neq1 : d-1 ≠ 1 := by linarith,
  have pprime : p.prime := nat.min_fac_prime neq1,
  haveI : fact p.prime := pprime,
  have trace_0:= tr_pow_p_mod_p (adjacency_matrix (zmod p) G),
  have eq_J : (adjacency_matrix (zmod p) G) ^ p = (matrix_J (zmod p) V),
  { apply friendship_reg_adj_pow_mod_p hG hd,
    { rw [← d_cast, int.coe_nat_dvd],
      apply p_dvd_d_pred },
    { apply nat.prime.two_le pprime },
    assumption },
  contrapose! trace_0, clear trace_0,
  rw eq_J,
  rw trace_J (zmod p) V,
  norm_num,
  have p_pos : 0 < p,
  linarith [nat.prime.two_le pprime],
  rw zero_pow p_pos,
  suffices key :  ↑(fintype.card V) = (1 : zmod p),
  { rw key, simp },
  cases p_dvd_V_pred with k hk,

  lift k to ℕ,
  { rw sub_eq_iff_eq_add at hk, norm_cast at hk, rw hk, simp },
  have p_pos' : (0 : ℤ) < p := by exact_mod_cast p_pos,
  apply nonneg_of_mul_nonneg_left _ p_pos',
  rw [← hk, cardV, add_sub_cancel], norm_cast,
  simp,
end

theorem friendship_theorem {G:simple_graph V} (hG : friendship G):
  exists_politician G:=
begin
  rw ← exists_pol_of_not_no_pol,
  intro npG,
  have regG : ∃ (d:ℕ), regular_graph G d,
  { apply counter_reg; assumption },
  cases regG with d dreg,

  have : d ≤ 2 ∨ 3 ≤ d := by omega, cases this,
  { have ex_pol : exists_politician G,
    apply deg_le_two_friendship_has_pol hG dreg,
    linarith,
    apply exists_pol_of_not_no_pol.2 ex_pol npG },

  apply three_le_deg_friendship_contra hG dreg, assumption,
end


import Lean
import Verbose.Common

open Lean Parser Meta Elab Tactic Option

def claim' (orig_goal : MVarId) (hyp_name : Name) (stmt : Expr) : MetaM (MVarId × MVarId × FVarId) := do
  withMVarContext orig_goal do
    let hole ← mkFreshExprMVar stmt MetavarKind.syntheticOpaque hyp_name
    let (fvar, mainGoal) ← intro1P (← assert orig_goal hyp_name stmt hole)
    pure (hole.mvarId!, mainGoal, fvar)

/-- Create a new subgoal `hyp_name : stmt` and return `(subGoal, fvar, mainGoal)` where
`subGoal` is the subgoal and `mainGoal` is an updated version of the main goal
having `hyp_name : stmt` in its context as `fvar`. -/
def claim (hyp_name : Name) (stmt : Term) : TacticM Unit := do
  let orig_goal ← getMainGoal
  withMVarContext orig_goal do
    let stmt_expr ← elabTerm stmt none
    let (subGoal, mainGoal, _) ← claim' orig_goal hyp_name stmt_expr
    replaceMainGoal [subGoal, mainGoal]

elab "my_have" name:ident ":" stmt:term : tactic => do
let _ ← claim name.getId stmt
pure ()

example : 1 = 1 := by
  my_have H : 1 = 1
  . rfl
  exact H

def letsInduct (hyp_name : Name) (stmt : Term) : TacticM Unit := do
  checkName hyp_name
  let orig_goal ← getMainGoal
  withMVarContext orig_goal do
    let stmt_expr ← elabTerm stmt none
    let .forallE bn bt .. := stmt_expr |
      throwError "The statement must start with a universal quantifier on a natural number."
    if not (← isDefEq bt (mkConst ``Nat)) then
      throwError "The statement must start with a universal quantifier on a natural number."
    let (subGoal, mainGoal, _) ← claim' orig_goal hyp_name stmt_expr
    withMVarContext subGoal do
      let (n_fvar, newest_goal) ← intro1P subGoal
      let goals ← Lean.Meta.induction newest_goal n_fvar ``Nat.rec #[{varNames := []}, {varNames := [bn, `hyp_rec]}]
      replaceMainGoal (((goals.map (·.mvarId))).push mainGoal).toList

elab "Let's" "prove by induction" name:ident ":" stmt:term : tactic =>
letsInduct name.getId stmt

example (P : Nat → Prop) (h₀ : P 0) (h : ∀ n, P n → P (n+1)) : P 4 := by
  Let's prove by induction H : ∀ k, P k
  . exact h₀
  . exact h k hyp_rec
  . exact H 4


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

import basicmodal.language data.set.basic basicmodal.semantics.semantics
import basicmodal.semantics.definability basicmodal.syntax.syntaxlemmas
local attribute [instance] classical.prop_decidable

---------------------- Soundness ----------------------

theorem soundness (AX : ctx) (φ : form) : prfK AX φ → global_sem_csq AX φ :=
begin
intro h,
induction h,
{intros f v h x,
exact (h h_φ x) h_h},
{intros f v x h2 h3 h4, exact h3},
{intros f v x h2 h3 h4 h5, apply h3,
exact h5, apply h4, exact h5},
{intros f x v h1 h2 h3,
by_contradiction h4,
exact (h2 h4) (h3 h4)},
{intros f v x h1 h2 h3,
exact and.intro h2 h3},
{intros f v x h1 h2, exact h2.left},
{intros f v x h1 h2, exact h2.right},
{intros f v x h1 h2 h3,
repeat {rw forces at h2},
repeat {rw imp_false at h2},
rw not_imp_not at h2,
exact h2 h3},
{intros f v x h1 h2 h3 x' h4,
exact h2 x' h4 (h3 x' h4)},
{intros f v x h,
exact (h_ih_hpq f v x h) (h_ih_hp f v x h)},
{intros f v h1 x y h2,
exact h_ih f v h1 y},
end

lemma soundnesshelper {Γ : ctx} {φ : form} {C : set (frame)} :
  prfK Γ φ → (∀ ψ ∈ Γ, F_valid ψ C) → F_valid φ C :=
begin
intros h1 h2 f h3 v, induction h1,
{intro x, exact h2 h1_φ h1_h f h3 v x},
{intros x h4 h5, exact h4},
{intros x h4 h5 h6, exact (h4 h6) (h5 h6)},
{intros x h3 h4, by_contradiction h5, specialize h3 h5,
rw ←not_forces_imp at h3, exact h3 (h4 h5)},
{intros x h4 h5, exact and.intro h4 h5},
{intros x h4, exact h4.left},
{intros x h4, exact h4.right},
{intros x h4 h5, repeat {rw forces at h4},
repeat {rw imp_false at h4},
rw not_imp_not at h4, exact h4 h5},
{intros x h3 h4, intros x' h5,
exact (h3 x' h5) (h4 x' h5)},
{intro x, exact h1_ih_hpq h2 x (h1_ih_hp h2 x)},
{intros x y h3, apply h1_ih, exact h2}
end

lemma inclusion_valid {C C' : set (frame)} : ∀ ψ, C ⊆ C' → F_valid ψ C' → F_valid ψ C :=
begin
intros φ h1 h2 f h3 v x,
exact h2 f (set.mem_of_subset_of_mem h1 h3) v x
end

def T_axioms  : ctx := {φ : form | ∃ ψ, φ = (□ ψ ⊃ ψ)}
def S4_axioms : ctx := T_axioms ∪ {φ : form | ∃ ψ, φ = (□ ψ ⊃ □ (□ ψ))}
def S5_axioms : ctx := T_axioms ∪ {φ : form | ∃ ψ, φ = (◇ ψ ⊃ □ (◇ ψ))}

lemma T_helper : ∀ φ ∈ T_axioms, F_valid φ ref_class :=
begin
intros φ h1 f h2 v x,
cases h1 with ψ h1, subst h1,
apply ref_helper, exact h2
end

theorem T_soundness (φ : form) : prfK T_axioms φ → F_valid φ ref_class :=
begin
intro h, apply soundnesshelper, apply h, apply T_helper
end

lemma S4_helper : ∀ φ ∈ S4_axioms, F_valid φ ref_trans_class :=
begin
intros φ h1 f h2 v x,
cases h2 with h2l h2r,
cases h1 with h1 h3,
{apply T_helper, exact h1, exact h2l},
{cases h3 with ψ h3, subst h3,
apply trans_helper, exact h2r}
end

theorem S4_soundness (φ : form) : prfK S4_axioms φ → F_valid φ ref_trans_class :=
begin
intro h, apply soundnesshelper, apply h, apply S4_helper
end

lemma S5_helper : ∀ φ ∈ S5_axioms, F_valid φ equiv_class :=
begin
intros φ h1 f h2 v x,
cases h2 with h2l h2r,
cases h2r with h2r h2rr,
cases h1 with h1 h3,
{apply T_helper, exact h1,
exact h2l},
{cases h3 with ψ h3, dsimp at h3,
subst h3, apply euclid_helper,
intros x y z h1 h2,
exact h2rr (h2r h1) h2}
end

theorem S5_soundness (φ : form) : prfK S5_axioms φ → F_valid φ equiv_class :=
begin
intro h, apply soundnesshelper, apply h, apply S5_helper
end


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn

Defines natural transformations between functors.

Introduces notations
  `τ.app X` for the components of natural transformations,
  `F ⟶ G` for the type of natural transformations between functors `F` and `G`,
  `σ ≫ τ` for vertical compositions, and
  `σ ◫ τ` for horizontal compositions.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.functor
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l

namespace Mathlib

namespace category_theory

/--
`nat_trans F G` represents a natural transformation between functors `F` and `G`.

The field `app` provides the components of the natural transformation.

Naturality is expressed by `α.naturality_lemma`.
-/
structure nat_trans {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) (G : C ⥤ D)
    where
  app : (X : C) → functor.obj F X ⟶ functor.obj G X
  naturality' :
    autoParam (∀ {X Y : C} (f : X ⟶ Y), functor.map F f ≫ app Y = app X ≫ functor.map G f)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

-- Rather arbitrarily, we say that the 'simpler' form is

@[simp] theorem nat_trans.naturality {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : C ⥤ D} (c : nat_trans F G) {X : C} {Y : C} (f : X ⟶ Y) :
    functor.map F f ≫ nat_trans.app c Y = nat_trans.app c X ≫ functor.map G f :=
  sorry

-- components of natural transfomations moving earlier.

@[simp] theorem nat_trans.naturality_assoc {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : C ⥤ D} (c : nat_trans F G) {X : C} {Y : C} (f : X ⟶ Y) {X' : D}
    (f' : functor.obj G Y ⟶ X') :
    functor.map F f ≫ nat_trans.app c Y ≫ f' = nat_trans.app c X ≫ functor.map G f ≫ f' :=
  sorry

theorem congr_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    {α : nat_trans F G} {β : nat_trans F G} (h : α = β) (X : C) :
    nat_trans.app α X = nat_trans.app β X :=
  congr_fun (congr_arg nat_trans.app h) X

namespace nat_trans

/-- `nat_trans.id F` is the identity natural transformation on a functor `F`. -/
protected def id {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) :
    nat_trans F F :=
  mk fun (X : C) => 𝟙

@[simp] theorem id_app' {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) (X : C) :
    app (nat_trans.id F) X = 𝟙 :=
  rfl

protected instance inhabited {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) :
    Inhabited (nat_trans F F) :=
  { default := nat_trans.id F }

/-- `vcomp α β` is the vertical compositions of natural transformations. -/
def vcomp {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} {H : C ⥤ D}
    (α : nat_trans F G) (β : nat_trans G H) : nat_trans F H :=
  mk fun (X : C) => app α X ≫ app β X

-- functor_category will rewrite (vcomp α β) to (α ≫ β), so this is not a

-- suitable simp lemma.  We will declare the variant vcomp_app' there.

theorem vcomp_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    {H : C ⥤ D} (α : nat_trans F G) (β : nat_trans G H) (X : C) :
    app (vcomp α β) X = app α X ≫ app β X :=
  rfl

end Mathlib


/-
Copyright (c) 2015 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.ordered_ring
import Mathlib.tactic.monotonicity.basic
import Mathlib.deprecated.group
import Mathlib.PostPort

universes u y v z u₁ w u₂ u_1

namespace Mathlib

/-!
# Power operations on monoids and groups

The power operation on monoids and groups.
We separate this from group, because it depends on `ℕ`,
which in turn depends on other parts of algebra.

This module contains the definitions of `monoid.pow` and `group.pow`
and their additive counterparts `nsmul` and `gsmul`, along with a few lemmas.
Further lemmas can be found in `algebra.group_power.lemmas`.

## Notation

The class `has_pow α β` provides the notation `a^b` for powers.
We define instances of `has_pow M ℕ`, for monoids `M`, and `has_pow G ℤ` for groups `G`.

We also define infix operators `•ℕ` and `•ℤ` for scalar multiplication by a natural and an integer
numbers, respectively.

## Implementation details

We adopt the convention that `0^0 = 1`.

This module provides the instance `has_pow ℕ ℕ` (via `monoid.has_pow`)
and is imported by `data.nat.basic`, so it has to live low in the import hierarchy.
Not all of its imports are needed yet; the intent is to move more lemmas here from `.lemmas`
so that they are available in `data.nat.basic`, and the imports will be required then.
-/

/-- The power operation in a monoid. `a^n = a*a*...*a` n times. -/
def monoid.pow {M : Type u} [Mul M] [HasOne M] (a : M) : ℕ → M :=
  sorry

/-- The scalar multiplication in an additive monoid.
`n •ℕ a = a+a+...+a` n times. -/
def nsmul {A : Type y} [Add A] [HasZero A] (n : ℕ) (a : A) : A :=
  monoid.pow a n

infixl:70 " •ℕ " => Mathlib.nsmul

protected instance monoid.has_pow {M : Type u} [monoid M] : has_pow M ℕ :=
  has_pow.mk monoid.pow

@[simp] theorem monoid.pow_eq_has_pow {M : Type u} [monoid M] (a : M) (n : ℕ) : monoid.pow a n = a ^ n :=
  rfl

/-!
### Commutativity

First we prove some facts about `semiconj_by` and `commute`. They do not require any theory about
`pow` and/or `nsmul` and will be useful later in this file.
-/

namespace semiconj_by

@[simp] theorem pow_right {M : Type u} [monoid M] {a : M} {x : M} {y : M} (h : semiconj_by a x y) (n : ℕ) : semiconj_by a (x ^ n) (y ^ n) :=
  nat.rec_on n (one_right a) fun (n : ℕ) (ihn : semiconj_by a (x ^ n) (y ^ n)) => mul_right h ihn

end semiconj_by

namespace commute

@[simp] theorem pow_right {M : Type u} [monoid M] {a : M} {b : M} (h : commute a b) (n : ℕ) : commute a (b ^ n) :=
  semiconj_by.pow_right h n

@[simp] theorem pow_left {M : Type u} [monoid M] {a : M} {b : M} (h : commute a b) (n : ℕ) : commute (a ^ n) b :=
  commute.symm (pow_right (commute.symm h) n)

@[simp] theorem pow_pow {M : Type u} [monoid M] {a : M} {b : M} (h : commute a b) (m : ℕ) (n : ℕ) : commute (a ^ m) (b ^ n) :=
  pow_right (pow_left h m) n

@[simp] theorem self_pow {M : Type u} [monoid M] (a : M) (n : ℕ) : commute a (a ^ n) :=
  pow_right (commute.refl a) n

@[simp] theorem pow_self {M : Type u} [monoid M] (a : M) (n : ℕ) : commute (a ^ n) a :=
  pow_left (commute.refl a) n

@[simp] theorem pow_pow_self {M : Type u} [monoid M] (a : M) (m : ℕ) (n : ℕ) : commute (a ^ m) (a ^ n) :=
  pow_pow (commute.refl a) m n

end commute

@[simp] theorem pow_zero {M : Type u} [monoid M] (a : M) : a ^ 0 = 1 :=
  rfl

@[simp] theorem zero_nsmul {A : Type y} [add_monoid A] (a : A) : 0 •ℕ a = 0 :=
  rfl

theorem pow_succ {M : Type u} [monoid M] (a : M) (n : ℕ) : a ^ (n + 1) = a * a ^ n :=
  rfl

theorem succ_nsmul {A : Type y} [add_monoid A] (a : A) (n : ℕ) : (n + 1) •ℕ a = a + n •ℕ a :=
  rfl

theorem pow_two {M : Type u} [monoid M] (a : M) : a ^ bit0 1 = a * a :=
  (fun (this : a * (a * 1) = a * a) => this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (a * (a * 1) = a * a)) (mul_one a))) (Eq.refl (a * a)))

theorem two_nsmul {A : Type y} [add_monoid A] (a : A) : bit0 1 •ℕ a = a + a :=
  pow_two a

theorem pow_mul_comm' {M : Type u} [monoid M] (a : M) (n : ℕ) : a ^ n * a = a * a ^ n :=
  commute.pow_self a n

theorem nsmul_add_comm' {A : Type y} [add_monoid A] (a : A) (n : ℕ) : n •ℕ a + a = a + n •ℕ a :=
  pow_mul_comm'

theorem pow_succ' {M : Type u} [monoid M] (a : M) (n : ℕ) : a ^ (n + 1) = a ^ n * a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (n + 1) = a ^ n * a)) (pow_succ a n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a * a ^ n = a ^ n * a)) (pow_mul_comm' a n))) (Eq.refl (a * a ^ n)))

theorem succ_nsmul' {A : Type y} [add_monoid A] (a : A) (n : ℕ) : (n + 1) •ℕ a = n •ℕ a + a :=
  pow_succ' a n

theorem pow_add {M : Type u} [monoid M] (a : M) (m : ℕ) (n : ℕ) : a ^ (m + n) = a ^ m * a ^ n := sorry

theorem add_nsmul {A : Type y} [add_monoid A] (a : A) (m : ℕ) (n : ℕ) : (m + n) •ℕ a = m •ℕ a + n •ℕ a :=
  pow_add

@[simp] theorem pow_one {M : Type u} [monoid M] (a : M) : a ^ 1 = a :=
  mul_one a

@[simp] theorem one_nsmul {A : Type y} [add_monoid A] (a : A) : 1 •ℕ a = a :=
  add_zero (coe_fn multiplicative.to_add a)

@[simp] theorem pow_ite {M : Type u} [monoid M] (P : Prop) [Decidable P] (a : M) (b : ℕ) (c : ℕ) : a ^ ite P b c = ite P (a ^ b) (a ^ c) := sorry

@[simp] theorem ite_pow {M : Type u} [monoid M] (P : Prop) [Decidable P] (a : M) (b : M) (c : ℕ) : ite P a b ^ c = ite P (a ^ c) (b ^ c) := sorry

@[simp] theorem pow_boole {M : Type u} [monoid M] (P : Prop) [Decidable P] (a : M) : a ^ ite P 1 0 = ite P a 1 := sorry

@[simp] theorem one_pow {M : Type u} [monoid M] (n : ℕ) : 1 ^ n = 1 := sorry

@[simp] theorem nsmul_zero {A : Type y} [add_monoid A] (n : ℕ) : n •ℕ 0 = 0 := sorry

theorem pow_mul {M : Type u} [monoid M] (a : M) (m : ℕ) (n : ℕ) : a ^ (m * n) = (a ^ m) ^ n := sorry

theorem mul_nsmul' {A : Type y} [add_monoid A] (a : A) (m : ℕ) (n : ℕ) : m * n •ℕ a = n •ℕ (m •ℕ a) :=
  pow_mul

theorem pow_mul' {M : Type u} [monoid M] (a : M) (m : ℕ) (n : ℕ) : a ^ (m * n) = (a ^ n) ^ m :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (m * n) = (a ^ n) ^ m)) (nat.mul_comm m n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (n * m) = (a ^ n) ^ m)) (pow_mul a n m))) (Eq.refl ((a ^ n) ^ m)))

theorem mul_nsmul {A : Type y} [add_monoid A] (a : A) (m : ℕ) (n : ℕ) : m * n •ℕ a = m •ℕ (n •ℕ a) :=
  pow_mul' a m n

theorem pow_mul_pow_sub {M : Type u} [monoid M] (a : M) {m : ℕ} {n : ℕ} (h : m ≤ n) : a ^ m * a ^ (n - m) = a ^ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ^ m * a ^ (n - m) = a ^ n)) (Eq.symm (pow_add a m (n - m)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (m + (n - m)) = a ^ n)) (nat.add_comm m (n - m))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (n - m + m) = a ^ n)) (nat.sub_add_cancel h))) (Eq.refl (a ^ n))))

theorem nsmul_add_sub_nsmul {A : Type y} [add_monoid A] (a : A) {m : ℕ} {n : ℕ} (h : m ≤ n) : m •ℕ a + (n - m) •ℕ a = n •ℕ a :=
  pow_mul_pow_sub a h

theorem pow_sub_mul_pow {M : Type u} [monoid M] (a : M) {m : ℕ} {n : ℕ} (h : m ≤ n) : a ^ (n - m) * a ^ m = a ^ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (n - m) * a ^ m = a ^ n)) (Eq.symm (pow_add a (n - m) m))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (n - m + m) = a ^ n)) (nat.sub_add_cancel h))) (Eq.refl (a ^ n)))

theorem sub_nsmul_nsmul_add {A : Type y} [add_monoid A] (a : A) {m : ℕ} {n : ℕ} (h : m ≤ n) : (n - m) •ℕ a + m •ℕ a = n •ℕ a :=
  pow_sub_mul_pow a h

theorem pow_bit0 {M : Type u} [monoid M] (a : M) (n : ℕ) : a ^ bit0 n = a ^ n * a ^ n :=
  pow_add a n n

theorem bit0_nsmul {A : Type y} [add_monoid A] (a : A) (n : ℕ) : bit0 n •ℕ a = n •ℕ a + n •ℕ a :=
  add_nsmul a n n

theorem pow_bit1 {M : Type u} [monoid M] (a : M) (n : ℕ) : a ^ bit1 n = a ^ n * a ^ n * a := sorry

theorem bit1_nsmul {A : Type y} [add_monoid A] (a : A) (n : ℕ) : bit1 n •ℕ a = n •ℕ a + n •ℕ a + a :=
  pow_bit1

theorem pow_mul_comm {M : Type u} [monoid M] (a : M) (m : ℕ) (n : ℕ) : a ^ m * a ^ n = a ^ n * a ^ m :=
  commute.pow_pow_self a m n

theorem nsmul_add_comm {A : Type y} [add_monoid A] (a : A) (m : ℕ) (n : ℕ) : m •ℕ a + n •ℕ a = n •ℕ a + m •ℕ a :=
  pow_mul_comm

@[simp] theorem monoid_hom.map_pow {M : Type u} {N : Type v} [monoid M] [monoid N] (f : M →* N) (a : M) (n : ℕ) : coe_fn f (a ^ n) = coe_fn f a ^ n := sorry

@[simp] theorem add_monoid_hom.map_nsmul {A : Type y} {B : Type z} [add_monoid A] [add_monoid B] (f : A →+ B) (a : A) (n : ℕ) : coe_fn f (n •ℕ a) = n •ℕ coe_fn f a :=
  monoid_hom.map_pow (coe_fn add_monoid_hom.to_multiplicative f) a n

theorem is_monoid_hom.map_pow {M : Type u} {N : Type v} [monoid M] [monoid N] (f : M → N) [is_monoid_hom f] (a : M) (n : ℕ) : f (a ^ n) = f a ^ n :=
  monoid_hom.map_pow (monoid_hom.of f) a

theorem is_add_monoid_hom.map_nsmul {A : Type y} {B : Type z} [add_monoid A] [add_monoid B] (f : A → B) [is_add_monoid_hom f] (a : A) (n : ℕ) : f (n •ℕ a) = n •ℕ f a :=
  add_monoid_hom.map_nsmul (add_monoid_hom.of f) a n

theorem commute.mul_pow {M : Type u} [monoid M] {a : M} {b : M} (h : commute a b) (n : ℕ) : (a * b) ^ n = a ^ n * b ^ n := sorry

theorem neg_pow {R : Type u₁} [ring R] (a : R) (n : ℕ) : (-a) ^ n = (-1) ^ n * a ^ n :=
  neg_one_mul a ▸ commute.mul_pow (commute.neg_one_left a) n

theorem pow_bit0' {M : Type u} [monoid M] (a : M) (n : ℕ) : a ^ bit0 n = (a * a) ^ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ^ bit0 n = (a * a) ^ n)) (pow_bit0 a n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ^ n * a ^ n = (a * a) ^ n)) (commute.mul_pow (commute.refl a) n)))
      (Eq.refl (a ^ n * a ^ n)))

theorem bit0_nsmul' {A : Type y} [add_monoid A] (a : A) (n : ℕ) : bit0 n •ℕ a = n •ℕ (a + a) :=
  pow_bit0' a n

theorem pow_bit1' {M : Type u} [monoid M] (a : M) (n : ℕ) : a ^ bit1 n = (a * a) ^ n * a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ^ bit1 n = (a * a) ^ n * a)) (bit1.equations._eqn_1 n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ^ (bit0 n + 1) = (a * a) ^ n * a)) (pow_succ' a (bit0 n))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (a ^ bit0 n * a = (a * a) ^ n * a)) (pow_bit0' a n))) (Eq.refl ((a * a) ^ n * a))))

theorem bit1_nsmul' {A : Type y} [add_monoid A] (a : A) (n : ℕ) : bit1 n •ℕ a = n •ℕ (a + a) + a :=
  pow_bit1'

@[simp] theorem neg_pow_bit0 {R : Type u₁} [ring R] (a : R) (n : ℕ) : (-a) ^ bit0 n = a ^ bit0 n :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((-a) ^ bit0 n = a ^ bit0 n)) (pow_bit0' (-a) n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((-a * -a) ^ n = a ^ bit0 n)) (neg_mul_neg a a)))
      (eq.mpr (id (Eq._oldrec (Eq.refl ((a * a) ^ n = a ^ bit0 n)) (pow_bit0' a n))) (Eq.refl ((a * a) ^ n))))

@[simp] theorem neg_pow_bit1 {R : Type u₁} [ring R] (a : R) (n : ℕ) : (-a) ^ bit1 n = -a ^ bit1 n := sorry

/-!
### Commutative (additive) monoid
-/

theorem mul_pow {M : Type u} [comm_monoid M] (a : M) (b : M) (n : ℕ) : (a * b) ^ n = a ^ n * b ^ n :=
  commute.mul_pow (commute.all a b) n

theorem nsmul_add {A : Type y} [add_comm_monoid A] (a : A) (b : A) (n : ℕ) : n •ℕ (a + b) = n •ℕ a + n •ℕ b :=
  mul_pow

protected instance pow.is_monoid_hom {M : Type u} [comm_monoid M] (n : ℕ) : is_monoid_hom fun (_x : M) => _x ^ n :=
  is_monoid_hom.mk (one_pow n)

protected instance nsmul.is_add_monoid_hom {A : Type y} [add_comm_monoid A] (n : ℕ) : is_add_monoid_hom (nsmul n) :=
  is_add_monoid_hom.mk (nsmul_zero n)

theorem dvd_pow {M : Type u} [comm_monoid M] {x : M} {y : M} {n : ℕ} (hxy : x ∣ y) (hn : n ≠ 0) : x ∣ y ^ n := sorry

/--
The power operation in a group. This extends `monoid.pow` to negative integers
with the definition `a^(-n) = (a^n)⁻¹`.
-/
def gpow {G : Type w} [group G] (a : G) : ℤ → G :=
  sorry

/--
The scalar multiplication by integers on an additive group.
This extends `nsmul` to negative integers
with the definition `(-n) •ℤ a = -(n •ℕ a)`.
-/
def gsmul {A : Type y} [add_group A] (n : ℤ) (a : A) : A :=
  gpow a n

protected instance group.has_pow {G : Type w} [group G] : has_pow G ℤ :=
  has_pow.mk gpow

infixl:70 " •ℤ " => Mathlib.gsmul

@[simp] theorem group.gpow_eq_has_pow {G : Type w} [group G] (a : G) (n : ℤ) : gpow a n = a ^ n :=
  rfl

@[simp] theorem inv_pow {G : Type w} [group G] (a : G) (n : ℕ) : a⁻¹ ^ n = (a ^ n⁻¹) := sorry

@[simp] theorem neg_nsmul {A : Type y} [add_group A] (a : A) (n : ℕ) : n •ℕ -a = -(n •ℕ a) :=
  inv_pow

theorem pow_sub {G : Type w} [group G] (a : G) {m : ℕ} {n : ℕ} (h : n ≤ m) : a ^ (m - n) = a ^ m * (a ^ n⁻¹) := sorry

theorem nsmul_sub {A : Type y} [add_group A] (a : A) {m : ℕ} {n : ℕ} : n ≤ m → (m - n) •ℕ a = m •ℕ a - n •ℕ a := sorry

theorem pow_inv_comm {G : Type w} [group G] (a : G) (m : ℕ) (n : ℕ) : a⁻¹ ^ m * a ^ n = a ^ n * a⁻¹ ^ m :=
  commute.pow_pow (commute.inv_left (commute.refl a)) m n

theorem nsmul_neg_comm {A : Type y} [add_group A] (a : A) (m : ℕ) (n : ℕ) : m •ℕ -a + n •ℕ a = n •ℕ a + m •ℕ -a :=
  pow_inv_comm

@[simp] theorem gpow_coe_nat {G : Type w} [group G] (a : G) (n : ℕ) : a ^ ↑n = a ^ n :=
  rfl

@[simp] theorem gsmul_coe_nat {A : Type y} [add_group A] (a : A) (n : ℕ) : ↑n •ℤ a = n •ℕ a :=
  rfl

theorem gpow_of_nat {G : Type w} [group G] (a : G) (n : ℕ) : a ^ Int.ofNat n = a ^ n :=
  rfl

theorem gsmul_of_nat {A : Type y} [add_group A] (a : A) (n : ℕ) : Int.ofNat n •ℤ a = n •ℕ a :=
  rfl

@[simp] theorem gpow_neg_succ_of_nat {G : Type w} [group G] (a : G) (n : ℕ) : a ^ Int.negSucc n = (a ^ Nat.succ n⁻¹) :=
  rfl

@[simp] theorem gsmul_neg_succ_of_nat {A : Type y} [add_group A] (a : A) (n : ℕ) : Int.negSucc n •ℤ a = -(Nat.succ n •ℕ a) :=
  rfl

@[simp] theorem gpow_zero {G : Type w} [group G] (a : G) : a ^ 0 = 1 :=
  rfl

@[simp] theorem zero_gsmul {A : Type y} [add_group A] (a : A) : 0 •ℤ a = 0 :=
  rfl

@[simp] theorem gpow_one {G : Type w} [group G] (a : G) : a ^ 1 = a :=
  pow_one a

@[simp] theorem one_gsmul {A : Type y} [add_group A] (a : A) : 1 •ℤ a = a :=
  add_zero (coe_fn multiplicative.to_add a)

@[simp] theorem one_gpow {G : Type w} [group G] (n : ℤ) : 1 ^ n = 1 := sorry

@[simp] theorem gsmul_zero {A : Type y} [add_group A] (n : ℤ) : n •ℤ 0 = 0 :=
  one_gpow

@[simp] theorem gpow_neg {G : Type w} [group G] (a : G) (n : ℤ) : a ^ (-n) = (a ^ n⁻¹) := sorry

theorem mul_gpow_neg_one {G : Type w} [group G] (a : G) (b : G) : (a * b) ^ (-1) = b ^ (-1) * a ^ (-1) := sorry

@[simp] theorem neg_gsmul {A : Type y} [add_group A] (a : A) (n : ℤ) : -n •ℤ a = -(n •ℤ a) :=
  gpow_neg

theorem gpow_neg_one {G : Type w} [group G] (x : G) : x ^ (-1) = (x⁻¹) :=
  congr_arg has_inv.inv (pow_one x)

theorem neg_one_gsmul {A : Type y} [add_group A] (x : A) : -1 •ℤ x = -x :=
  congr_arg Neg.neg (one_nsmul x)

theorem inv_gpow {G : Type w} [group G] (a : G) (n : ℤ) : a⁻¹ ^ n = (a ^ n⁻¹) :=
  int.cases_on n (fun (n : ℕ) => idRhs (a⁻¹ ^ n = (a ^ n⁻¹)) (inv_pow a n))
    fun (n : ℕ) => idRhs (a⁻¹ ^ (n + 1)⁻¹ = (a ^ (n + 1)⁻¹⁻¹)) (congr_arg has_inv.inv (inv_pow a (n + 1)))

theorem gsmul_neg {A : Type y} [add_group A] (a : A) (n : ℤ) : n •ℤ -a = -(n •ℤ a) :=
  inv_gpow a n

theorem commute.mul_gpow {G : Type w} [group G] {a : G} {b : G} (h : commute a b) (n : ℤ) : (a * b) ^ n = a ^ n * b ^ n := sorry

theorem mul_gpow {G : Type w} [comm_group G] (a : G) (b : G) (n : ℤ) : (a * b) ^ n = a ^ n * b ^ n :=
  commute.mul_gpow (commute.all a b) n

theorem gsmul_add {A : Type y} [add_comm_group A] (a : A) (b : A) (n : ℤ) : n •ℤ (a + b) = n •ℤ a + n •ℤ b :=
  mul_gpow

theorem gsmul_sub {A : Type y} [add_comm_group A] (a : A) (b : A) (n : ℤ) : n •ℤ (a - b) = n •ℤ a - n •ℤ b := sorry

protected instance gpow.is_group_hom {G : Type w} [comm_group G] (n : ℤ) : is_group_hom fun (_x : G) => _x ^ n :=
  is_group_hom.mk

protected instance gsmul.is_add_group_hom {A : Type y} [add_comm_group A] (n : ℤ) : is_add_group_hom (gsmul n) :=
  is_add_group_hom.mk

theorem zero_pow {R : Type u₁} [monoid_with_zero R] {n : ℕ} : 0 < n → 0 ^ n = 0 := sorry

namespace ring_hom

@[simp] theorem map_pow {R : Type u₁} {S : Type u₂} [semiring R] [semiring S] (f : R →+* S) (a : R) (n : ℕ) : coe_fn f (a ^ n) = coe_fn f a ^ n :=
  monoid_hom.map_pow (to_monoid_hom f) a

end ring_hom

theorem neg_one_pow_eq_or {R : Type u₁} [ring R] (n : ℕ) : (-1) ^ n = 1 ∨ (-1) ^ n = -1 := sorry

theorem pow_dvd_pow {R : Type u₁} [monoid R] (a : R) {m : ℕ} {n : ℕ} (h : m ≤ n) : a ^ m ∣ a ^ n := sorry

theorem pow_dvd_pow_of_dvd {R : Type u₁} [comm_monoid R] {a : R} {b : R} (h : a ∣ b) (n : ℕ) : a ^ n ∣ b ^ n := sorry

theorem pow_two_sub_pow_two {R : Type u_1} [comm_ring R] (a : R) (b : R) : a ^ bit0 1 - b ^ bit0 1 = (a + b) * (a - b) := sorry

theorem eq_or_eq_neg_of_pow_two_eq_pow_two {R : Type u₁} [integral_domain R] (a : R) (b : R) (h : a ^ bit0 1 = b ^ bit0 1) : a = b ∨ a = -b := sorry

theorem sq_sub_sq {R : Type u₁} [comm_ring R] (a : R) (b : R) : a ^ bit0 1 - b ^ bit0 1 = (a + b) * (a - b) := sorry

theorem pow_eq_zero {R : Type u₁} [monoid_with_zero R] [no_zero_divisors R] {x : R} {n : ℕ} (H : x ^ n = 0) : x = 0 := sorry

@[simp] theorem pow_eq_zero_iff {R : Type u₁} [monoid_with_zero R] [no_zero_divisors R] {a : R} {n : ℕ} (hn : 0 < n) : a ^ n = 0 ↔ a = 0 :=
  { mp := pow_eq_zero, mpr := fun (ᾰ : a = 0) => Eq._oldrec (zero_pow hn) (Eq.symm ᾰ) }

theorem pow_ne_zero {R : Type u₁} [monoid_with_zero R] [no_zero_divisors R] {a : R} (n : ℕ) (h : a ≠ 0) : a ^ n ≠ 0 :=
  mt pow_eq_zero h

theorem pow_abs {R : Type u₁} [linear_ordered_comm_ring R] (a : R) (n : ℕ) : abs a ^ n = abs (a ^ n) :=
  Eq.symm (monoid_hom.map_pow (monoid_with_zero_hom.to_monoid_hom abs_hom) a n)

theorem abs_neg_one_pow {R : Type u₁} [linear_ordered_comm_ring R] (n : ℕ) : abs ((-1) ^ n) = 1 := sorry

theorem nsmul_nonneg {A : Type y} [ordered_add_comm_monoid A] {a : A} (H : 0 ≤ a) (n : ℕ) : 0 ≤ n •ℕ a := sorry

theorem nsmul_pos {A : Type y} [ordered_add_comm_monoid A] {a : A} (ha : 0 < a) {k : ℕ} (hk : 0 < k) : 0 < k •ℕ a := sorry

theorem nsmul_le_nsmul {A : Type y} [ordered_add_comm_monoid A] {a : A} {n : ℕ} {m : ℕ} (ha : 0 ≤ a) (h : n ≤ m) : n •ℕ a ≤ m •ℕ a := sorry

theorem nsmul_le_nsmul_of_le_right {A : Type y} [ordered_add_comm_monoid A] {a : A} {b : A} (hab : a ≤ b) (i : ℕ) : i •ℕ a ≤ i •ℕ b := sorry

theorem gsmul_nonneg {A : Type y} [ordered_add_comm_group A] {a : A} (H : 0 ≤ a) {n : ℤ} (hn : 0 ≤ n) : 0 ≤ n •ℤ a := sorry

theorem nsmul_lt_nsmul {A : Type y} [ordered_cancel_add_comm_monoid A] {a : A} {n : ℕ} {m : ℕ} (ha : 0 < a) (h : n < m) : n •ℕ a < m •ℕ a := sorry

theorem min_pow_dvd_add {R : Type u₁} [semiring R] {n : ℕ} {m : ℕ} {a : R} {b : R} {c : R} (ha : c ^ n ∣ a) (hb : c ^ m ∣ b) : c ^ min n m ∣ a + b :=
  dvd_add (dvd.trans (pow_dvd_pow c (min_le_left n m)) ha) (dvd.trans (pow_dvd_pow c (min_le_right n m)) hb)

theorem add_pow_two {R : Type u₁} [comm_semiring R] (a : R) (b : R) : (a + b) ^ bit0 1 = a ^ bit0 1 + bit0 1 * a * b + b ^ bit0 1 := sorry

namespace canonically_ordered_semiring

theorem pow_pos {R : Type u₁} [canonically_ordered_comm_semiring R] {a : R} (H : 0 < a) (n : ℕ) : 0 < a ^ n := sorry

theorem pow_le_pow_of_le_left {R : Type u₁} [canonically_ordered_comm_semiring R] {a : R} {b : R} (hab : a ≤ b) (i : ℕ) : a ^ i ≤ b ^ i := sorry

theorem one_le_pow_of_one_le {R : Type u₁} [canonically_ordered_comm_semiring R] {a : R} (H : 1 ≤ a) (n : ℕ) : 1 ≤ a ^ n := sorry

theorem pow_le_one {R : Type u₁} [canonically_ordered_comm_semiring R] {a : R} (H : a ≤ 1) (n : ℕ) : a ^ n ≤ 1 := sorry

end canonically_ordered_semiring

@[simp] theorem pow_pos {R : Type u₁} [ordered_semiring R] {a : R} (H : 0 < a) (n : ℕ) : 0 < a ^ n := sorry

@[simp] theorem pow_nonneg {R : Type u₁} [ordered_semiring R] {a : R} (H : 0 ≤ a) (n : ℕ) : 0 ≤ a ^ n := sorry

theorem pow_lt_pow_of_lt_left {R : Type u₁} [ordered_semiring R] {x : R} {y : R} {n : ℕ} (Hxy : x < y) (Hxpos : 0 ≤ x) (Hnpos : 0 < n) : x ^ n < y ^ n := sorry

theorem strict_mono_incr_on_pow {R : Type u₁} [ordered_semiring R] {n : ℕ} (hn : 0 < n) : strict_mono_incr_on (fun (x : R) => x ^ n) (set.Ici 0) :=
  fun (x : R) (hx : x ∈ set.Ici 0) (y : R) (hy : y ∈ set.Ici 0) (h : x < y) => pow_lt_pow_of_lt_left h hx hn

theorem one_le_pow_of_one_le {R : Type u₁} [ordered_semiring R] {a : R} (H : 1 ≤ a) (n : ℕ) : 1 ≤ a ^ n := sorry

theorem pow_mono {R : Type u₁} [ordered_semiring R] {a : R} (h : 1 ≤ a) : monotone fun (n : ℕ) => a ^ n :=
  monotone_of_monotone_nat fun (n : ℕ) => le_mul_of_one_le_left (pow_nonneg (has_le.le.trans zero_le_one h) n) h

theorem pow_le_pow {R : Type u₁} [ordered_semiring R] {a : R} {n : ℕ} {m : ℕ} (ha : 1 ≤ a) (h : n ≤ m) : a ^ n ≤ a ^ m :=
  pow_mono ha h

theorem strict_mono_pow {R : Type u₁} [ordered_semiring R] {a : R} (h : 1 < a) : strict_mono fun (n : ℕ) => a ^ n := sorry

theorem pow_lt_pow {R : Type u₁} [ordered_semiring R] {a : R} {n : ℕ} {m : ℕ} (h : 1 < a) (h2 : n < m) : a ^ n < a ^ m :=
  strict_mono_pow h h2

theorem pow_lt_pow_iff {R : Type u₁} [ordered_semiring R] {a : R} {n : ℕ} {m : ℕ} (h : 1 < a) : a ^ n < a ^ m ↔ n < m :=
  strict_mono.lt_iff_lt (strict_mono_pow h)

theorem pow_le_pow_of_le_left {R : Type u₁} [ordered_semiring R] {a : R} {b : R} (ha : 0 ≤ a) (hab : a ≤ b) (i : ℕ) : a ^ i ≤ b ^ i := sorry

theorem pow_left_inj {R : Type u₁} [linear_ordered_semiring R] {x : R} {y : R} {n : ℕ} (Hxpos : 0 ≤ x) (Hypos : 0 ≤ y) (Hnpos : 0 < n) (Hxyn : x ^ n = y ^ n) : x = y :=
  strict_mono_incr_on.inj_on (strict_mono_incr_on_pow Hnpos) Hxpos Hypos Hxyn

theorem lt_of_pow_lt_pow {R : Type u₁} [linear_ordered_semiring R] {a : R} {b : R} (n : ℕ) (hb : 0 ≤ b) (h : a ^ n < b ^ n) : a < b :=
  lt_of_not_ge fun (hn : a ≥ b) => not_lt_of_ge (pow_le_pow_of_le_left hb hn n) h

theorem le_of_pow_le_pow {R : Type u₁} [linear_ordered_semiring R] {a : R} {b : R} (n : ℕ) (hb : 0 ≤ b) (hn : 0 < n) (h : a ^ n ≤ b ^ n) : a ≤ b :=
  le_of_not_lt fun (h1 : b < a) => not_le_of_lt (pow_lt_pow_of_lt_left h1 hb hn) h

theorem pow_bit0_nonneg {R : Type u₁} [linear_ordered_ring R] (a : R) (n : ℕ) : 0 ≤ a ^ bit0 n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 ≤ a ^ bit0 n)) (pow_bit0 a n))) (mul_self_nonneg (a ^ n))

theorem pow_two_nonneg {R : Type u₁} [linear_ordered_ring R] (a : R) : 0 ≤ a ^ bit0 1 :=
  pow_bit0_nonneg a 1

theorem pow_bit0_pos {R : Type u₁} [linear_ordered_ring R] {a : R} (h : a ≠ 0) (n : ℕ) : 0 < a ^ bit0 n :=
  has_le.le.lt_of_ne (pow_bit0_nonneg a n) (ne.symm (pow_ne_zero (bit0 n) h))

theorem pow_two_pos_of_ne_zero {R : Type u₁} [linear_ordered_ring R] (a : R) (h : a ≠ 0) : 0 < a ^ bit0 1 :=
  pow_bit0_pos h 1

@[simp] theorem eq_of_pow_two_eq_pow_two {R : Type u₁} [linear_ordered_comm_ring R] {a : R} {b : R} (ha : 0 ≤ a) (hb : 0 ≤ b) : a ^ bit0 1 = b ^ bit0 1 ↔ a = b := sorry

@[simp] theorem neg_square {α : Type u_1} [ring α] (z : α) : (-z) ^ bit0 1 = z ^ bit0 1 := sorry

theorem of_add_nsmul {A : Type y} [add_monoid A] (x : A) (n : ℕ) : coe_fn multiplicative.of_add (n •ℕ x) = coe_fn multiplicative.of_add x ^ n :=
  rfl

theorem of_add_gsmul {A : Type y} [add_group A] (x : A) (n : ℤ) : coe_fn multiplicative.of_add (n •ℤ x) = coe_fn multiplicative.of_add x ^ n :=
  rfl

@[simp] theorem semiconj_by.gpow_right {G : Type w} [group G] {a : G} {x : G} {y : G} (h : semiconj_by a x y) (m : ℤ) : semiconj_by a (x ^ m) (y ^ m) := sorry

namespace commute

@[simp] theorem gpow_right {G : Type w} [group G] {a : G} {b : G} (h : commute a b) (m : ℤ) : commute a (b ^ m) :=
  semiconj_by.gpow_right h m

@[simp] theorem gpow_left {G : Type w} [group G] {a : G} {b : G} (h : commute a b) (m : ℤ) : commute (a ^ m) b :=
  commute.symm (gpow_right (commute.symm h) m)

theorem gpow_gpow {G : Type w} [group G] {a : G} {b : G} (h : commute a b) (m : ℤ) (n : ℤ) : commute (a ^ m) (b ^ n) :=
  gpow_right (gpow_left h m) n

@[simp] theorem self_gpow {G : Type w} [group G] (a : G) (n : ℕ) : commute a (a ^ n) :=
  gpow_right (commute.refl a) ↑n

@[simp] theorem gpow_self {G : Type w} [group G] (a : G) (n : ℕ) : commute (a ^ n) a :=
  gpow_left (commute.refl a) ↑n

@[simp] theorem gpow_gpow_self {G : Type w} [group G] (a : G) (m : ℕ) (n : ℕ) : commute (a ^ m) (a ^ n) :=
  gpow_gpow (commute.refl a) ↑m ↑n


import pq_induction_principles

universes u v

section pq_group_central_ext_univ

variables {G : Type u} [group G]

variables {H : Type v} [group H]

-- (f : H →* G) (hf : f.ker ≤ subgroup.center H) (s : G → H) (hs : is_pq_morphism s) (hsf : ∀ x : G, f (s x) = x)

def pq_group_central_ext_univ (s : G → H) (hs : is_pq_morphism s) : pq_group G →* H := pq_morph_to_L_morph_adj s hs

theorem pq_group_central_ext_univ_comm_sec (s : G → H) (hs : is_pq_morphism s) (x : G) : (pq_group_central_ext_univ s hs) (of x) = s x := rfl

-- Isn't this obvious?

-- What else can we deduce?

-- Can we factor s through homo_locus_pres?

-- Can we find sufficient criteria for pq_group G iso H?
-- If so, find H →* pq_group G. For that, H →* homo_locus_pres_prod G
-- Based on f, with a "crossed" pq-morphism H → homo_locus_pres G
-- OR what about of ∘ f? No...
-- What conditions do we need?
-- How do we use f.ker ≤ subgroup.center H?
-- f(x) = 1 implies ∀ y, xy = yx
-- Say x = s(f(x)) * b
-- We get f(x) = f(s(f(x))) * f(b) = f(x) * f(b) => f(b) = 1
-- Implies "H ≃ f.ker × s.im" s.im is just a power quandle...

variables (f : H →* G) (hf : f.ker ≤ subgroup.center H) (s : G → H) (hs : is_pq_morphism s) (hsf : ∀ x : G, f (s x) = x)

include hf hs hsf
def pq_group_central_ext_univ_ker_range_equiv : H ≃ f.ker × (set.range s) := {
  to_fun := λ x : H, (⟨x * (s(f(x)))⁻¹, begin
    show f(x * (s(f(x)))⁻¹) = 1,
    simp only [monoid_hom.map_mul_inv],
    rw hsf,
    simp only [mul_right_inv],
  end⟩, ⟨s(f(x)), set.mem_range_self (f x)⟩),
  inv_fun := λ ⟨⟨x, _⟩, ⟨y, _⟩⟩, x * y,
  left_inv := begin
    intro x,
    simp only,
    show x * (s (f x))⁻¹ * s (f x) = x,
    simp only [inv_mul_cancel_right],
  end,
  right_inv := begin
    rintros ⟨⟨a, ha⟩, ⟨b, hb⟩⟩,
    simp only,
    unfold pq_group_central_ext_univ_ker_range_equiv._match_1, -- Find better
    ext1,
    {
      simp only [monoid_hom.map_mul, subtype.mk_eq_mk],
      have ha1 : f a = 1 := ha,
      simp_rw ha1,
      simp_rw one_mul,
      rw set.mem_range at hb,
      cases hb with c hc,
      rw ←hc,
      rw hsf,
      simp only [mul_inv_cancel_right],
    },
    {
      simp only [monoid_hom.map_mul, subtype.mk_eq_mk],
      have ha1 : f a = 1 := ha,
      simp_rw ha1,
      simp_rw one_mul,
      rw set.mem_range at hb,
      cases hb with c hc,
      rw ←hc,
      rw hsf,
    },
  end }

end pq_group_central_ext_univ