/-
Copyright (c) 2018 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import Std.Data.AssocList
import Std.Data.Nat.Basic
import Std.Classes.BEq

namespace HashMap
open Std

/-- A hash is lawful if elements which compare equal under `==` have equal hash. -/
class LawfulHashable (α : Type _) [BEq α] [Hashable α] : Prop where
  /-- Two elements which compare equal under the `BEq` instance have equal hash. -/
  hash_eq {a b : α} : a == b → hash a = hash b

instance [BEq α] [LawfulBEq α] [Hashable α] : LawfulHashable α where
  hash_eq h := by rw [LawfulBEq.eq_of_beq h]

namespace Imp

/--
The bucket array of a `HashMap` is a nonempty array of `AssocList`s.
(This type is an internal implementation detail of `HashMap`.)
-/
def Buckets (α : Type u) (β : Type v) := {b : Array (AssocList α β) // b.size.isPowerOfTwo}

namespace Buckets

/-- Construct a new empty bucket array with the specified number of buckets. -/
def mk (nBuckets : Nat) (h : nBuckets.isPowerOfTwo) : Buckets α β :=
  ⟨mkArray nBuckets .nil, by simp [h]⟩

/-- Update one bucket in the bucket array with a new value. -/
def update (data : Buckets α β) (i : USize)
    (d : AssocList α β) (h : i.toNat < data.1.size) : Buckets α β :=
  ⟨data.1.uset i d h, (Array.size_uset ..).symm ▸ data.2⟩

/--
The number of elements in the bucket array.
Note: this is marked `noncomputable` because it is only intended for specification.
-/
noncomputable def size (data : Buckets α β) : Nat := .sum (data.1.data.map (·.toList.length))

/-- Map a function over the values in the map. -/
@[specialize] def mapVal (f : α → β → γ) (self : Buckets α β) : Buckets α γ :=
  ⟨self.1.map (.mapVal f), by simp [self.2]⟩

/--
The well-formedness invariant for the bucket array says that every element hashes to its index
(assuming the hash is lawful - otherwise there are no promises about where elements are located).
-/
structure WF [BEq α] [Hashable α] (buckets : Buckets α β) : Prop where
  /-- The elements of a bucket are all distinct according to the `BEq` relation. -/
  distinct [LawfulHashable α] [PartialEquivBEq α] : ∀ bucket ∈ buckets.1.data,
    bucket.toList.Pairwise fun a b => ¬(a.1 == b.1)
  /-- Every element in a bucket should hash to its location. -/
  hash_self (i : Nat) (h : i < buckets.1.size) :
    buckets.1[i].All fun k _ => ((hash k).toUSize % buckets.1.size).toNat = i

end Buckets
end Imp

/-- `HashMap.Imp α β` is the internal implementation type of `HashMap α β`. -/
structure Imp (α : Type u) (β : Type v) where
  /-- The number of elements stored in the `HashMap`.
  We cache this both so that we can implement `.size` in `O(1)`, and also because we
  use the size to determine when to resize the map. -/
  size    : Nat
  /-- The bucket array of the `HashMap`. -/
  buckets : Imp.Buckets α β

namespace Imp

/--
Given a desired capacity, this returns the number of buckets we should reserve.
A "load factor" of 0.75 is the usual standard for hash maps, so we return `capacity * 4 / 3`.
-/
@[inline] def numBucketsForCapacity (capacity : Nat) : Nat :=
  capacity * 4 / 3

/-- Constructs an empty hash map with the specified nonzero number of buckets. -/
@[inline] def empty' (nBuckets : Nat) (h : nBuckets.isPowerOfTwo) : Imp α β :=
  ⟨0, .mk nBuckets h⟩

/-- Constructs an empty hash map with the specified target capacity. -/
def empty (capacity := 8) : Imp α β :=
  let nBuckets := numBucketsForCapacity capacity |>.nextPowerOfTwo
  empty' nBuckets (Nat.isPowerOfTwo_nextPowerOfTwo _)

/-- Calculates the bucket index from a `hash` value. -/
def mkIdx {sz : Nat} (hash : UInt64) (h : sz.isPowerOfTwo) : {u : USize // u.toNat < sz} :=
  ⟨hash.toUSize % sz, USize.modn_lt _ (Nat.pos_of_isPowerOfTwo h)⟩

/--
Inserts a key-value pair into the bucket array. This function assumes that the data is not
already in the array, which is appropriate when reinserting elements into the array after a resize.
-/
@[inline] def reinsertAux [Hashable α] (data : Buckets α β) (a : α) (b : β) : Buckets α β :=
  let ⟨i, h⟩ := mkIdx (hash a) data.property
  data.update i (.cons a b data.1[i]) h

/-- Folds a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def foldM [Monad m] (f : δ → α → β → m δ) (d : δ) (map : Imp α β) : m δ :=
  map.buckets.1.foldlM (init := d) fun d b => b.foldlM f d

/-- Folds a function over the elements in the map (in arbitrary order). -/
@[inline] def fold (f : δ → α → β → δ) (d : δ) (map : Imp α β) : δ :=
  map.buckets.1.foldl (init := d) fun d b => b.foldl f d

/-- Runs a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def forM [Monad m] (f : α → β → m PUnit) (h : Imp α β) : m PUnit :=
  h.buckets.1.forM fun b => b.forM f

/-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. -/
def findEntry? [BEq α] [Hashable α] (m : Imp α β) (a : α) : Option (α × β) :=
  let ⟨_, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx (hash a) buckets.property
  buckets.1[i].findEntry? a

/-- Looks up an element in the map with key `a`. -/
def find? [BEq α] [Hashable α] (m : Imp α β) (a : α) : Option β :=
  let ⟨_, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx (hash a) buckets.property
  buckets.1[i].find? a

/-- Returns true if the element `a` is in the map. -/
def contains [BEq α] [Hashable α] (m : Imp α β) (a : α) : Bool :=
  let ⟨_, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx (hash a) buckets.property
  buckets.1[i].contains a

/-- Copies all the entries from `buckets` into a new hash map with a larger capacity. -/
def expand [Hashable α] (size : Nat) (buckets : Buckets α β) : Imp α β :=
  let nbuckets := buckets.1.size * 2
  have h : nbuckets.isPowerOfTwo := Nat.mul2_isPowerOfTwo_of_isPowerOfTwo buckets.property
  { size, buckets := go 0 buckets.1 (.mk nbuckets h) }
where
  /-- Inner loop of `expand`. Copies elements `source[i:]` into `target`,
  destroying `source` in the process. -/
  go (i : Nat) (source : Array (AssocList α β)) (target : Buckets α β) : Buckets α β :=
    if h : i < source.size then
      let idx : Fin source.size := ⟨i, h⟩
      let es := source.get idx
      -- We remove `es` from `source` to make sure we can reuse its memory cells
      -- when performing es.foldl
      let source := source.set idx .nil
      let target := es.foldl reinsertAux target
      go (i+1) source target
    else target
termination_by go i source _ => source.size - i

/--
Inserts key-value pair `a, b` into the map.
If an element equal to `a` is already in the map, it is replaced by `b`.
-/
@[inline] def insert [BEq α] [Hashable α] (m : Imp α β) (a : α) (b : β) : Imp α β :=
  let ⟨size, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx (hash a) buckets.property
  let bkt := buckets.1[i]
  bif bkt.contains a then
    ⟨size, buckets.update i (bkt.replace a b) h⟩
  else
    let size' := size + 1
    let buckets' := buckets.update i (.cons a b bkt) h
    if numBucketsForCapacity size' ≤ buckets.1.size then
      { size := size', buckets := buckets' }
    else
      expand size' buckets'

/--
Removes key `a` from the map. If it does not exist in the map, the map is returned unchanged.
-/
def erase [BEq α] [Hashable α] (m : Imp α β) (a : α) : Imp α β :=
  let ⟨size, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx (hash a) buckets.property
  let bkt := buckets.1[i]
  bif bkt.contains a then ⟨size - 1, buckets.update i (bkt.erase a) h⟩ else m

/-- Map a function over the values in the map. -/
@[inline] def mapVal (f : α → β → γ) (self : Imp α β) : Imp α γ :=
  { size := self.size, buckets := self.buckets.mapVal f }

/--
Applies `f` to each key-value pair `a, b` in the map. If it returns `some c` then
`a, c` is pushed into the new map; else the key is removed from the map.
-/
@[specialize] def filterMap {α : Type u} {β : Type v} {γ : Type w}
    (f : α → β → Option γ) (m : Imp α β) : Imp α γ :=
  let m' := m.buckets.1.mapM (m := StateT (ULift Nat) Id) (go .nil) |>.run ⟨0⟩ |>.run
  have : m'.1.size.isPowerOfTwo := by
    have := Array.size_mapM (m := StateT (ULift Nat) Id) (go .nil) m.buckets.1
    simp [SatisfiesM_StateT_eq, SatisfiesM_Id_eq] at this
    simp [this, Id.run, StateT.run, m.2.2]
  ⟨m'.2.1, m'.1, this⟩
where
  /-- Inner loop of `filterMap`. Note that this reverses the bucket lists,
  but this is fine since bucket lists are unordered. -/
  @[specialize] go (acc : AssocList α γ) : AssocList α β → ULift Nat → AssocList α γ × ULift Nat
  | .nil, n => (acc, n)
  | .cons a b l, n => match f a b with
    | none => go acc l n
    | some c => go (.cons a c acc) l ⟨n.1 + 1⟩

/-- Constructs a map with the set of all pairs `a, b` such that `f` returns true. -/
@[inline] def filter (f : α → β → Bool) (m : Imp α β) : Imp α β :=
  m.filterMap fun a b => bif f a b then some b else none

/--
The well-formedness invariant for a hash map. The first constructor is the real invariant,
and the others allow us to "cheat" in this file and define `insert` and `erase`,
which have more complex proofs that are delayed to `Std.Data.HashMap.Lemmas`.
-/
inductive WF [BEq α] [Hashable α] : Imp α β → Prop where
  /-- The real well-formedness invariant:
  * The `size` field should match the actual number of elements in the map
  * The bucket array should be well-formed, meaning that if the hashable instance
    is lawful then every element hashes to its index. -/
  | mk : m.size = m.buckets.size → m.buckets.WF → WF m
  /-- The empty hash map is well formed. -/
  | empty' : WF (empty' n h)
  /-- Inserting into a well formed hash map yields a well formed hash map. -/
  | insert : WF m → WF (insert m a b)
  /-- Removing an element from a well formed hash map yields a well formed hash map. -/
  | erase : WF m → WF (erase m a)

theorem WF.empty [BEq α] [Hashable α] : WF (empty n : Imp α β) := by unfold empty; apply empty'

end Imp

/--
`HashMap α β` is a key-value map which stores elements in an array using a hash function
to find the values. This allows it to have very good performance for lookups
(average `O(1)` for a perfectly random hash function), but it is not a persistent data structure,
meaning that one should take care to use the map linearly when performing updates.
Copies are `O(n)`.
-/
def _root_.HashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] := {m : Imp α β // m.WF}

open HashMap.Imp

/-- Make a new hash map with the specified capacity. -/
@[inline] def _root_.mkHashMap [BEq α] [Hashable α] (capacity := 8) : HashMap α β :=
  ⟨.empty capacity, .empty⟩

instance [BEq α] [Hashable α] : Inhabited (HashMap α β) where
  default := mkHashMap

instance [BEq α] [Hashable α] : EmptyCollection (HashMap α β) := ⟨mkHashMap⟩

/-- Make a new empty hash map. -/
@[inline] def empty [BEq α] [Hashable α] : HashMap α β := mkHashMap

variable {_ : BEq α} {_ : Hashable α}

/-- The number of elements in the hash map. -/
@[inline] def size (self : HashMap α β) : Nat := self.1.size

/-- Is the map empty? -/
@[inline] def isEmpty (self : HashMap α β) : Bool := self.size = 0

/--
Inserts key-value pair `a, b` into the map.
If an element equal to `a` is already in the map, it is replaced by `b`.
-/
def insert (self : HashMap α β) (a : α) (b : β) : HashMap α β := ⟨self.1.insert a b, self.2.insert⟩

/--
Similar to `insert`, but also returns a boolean flag indicating whether an existing entry has been
replaced with `a ↦ b`.
-/
@[inline] def insert' (m : HashMap α β) (a : α) (b : β) : HashMap α β × Bool :=
  let old := m.size
  let m' := m.insert a b
  let replaced := old == m'.size
  (m', replaced)

/--
Removes key `a` from the map. If it does not exist in the map, the map is returned unchanged.
-/
@[inline] def erase (self : HashMap α β) (a : α) : HashMap α β := ⟨self.1.erase a, self.2.erase⟩

/-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. -/
@[inline] def findEntry? (self : HashMap α β) (a : α) : Option (α × β) := self.1.findEntry? a

/-- Looks up an element in the map with key `a`. -/
@[inline] def find? (self : HashMap α β) (a : α) : Option β := self.1.find? a

/-- Looks up an element in the map with key `a`. Returns `b₀` if the element is not found. -/
@[inline] def findD (self : HashMap α β) (a : α) (b₀ : β) : β := (self.find? a).getD b₀

/-- Looks up an element in the map with key `a`. Panics if the element is not found. -/
@[inline] def find! [Inhabited β] (self : HashMap α β) (a : α) : β :=
  (self.find? a).getD (panic! "key is not in the map")

instance : GetElem (HashMap α β) α (Option β) fun _ _ => True where
  getElem m k _ := m.find? k

/-- Returns true if the element `a` is in the map. -/
@[inline] def contains (self : HashMap α β) (a : α) : Bool := self.1.contains a

/-- Folds a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def foldM [Monad m] (f : δ → α → β → m δ) (init : δ) (self : HashMap α β) : m δ :=
  self.1.foldM f init

/-- Folds a function over the elements in the map (in arbitrary order). -/
@[inline] def fold (f : δ → α → β → δ) (init : δ) (self : HashMap α β) : δ := self.1.fold f init

/-- Combines two hashmaps using a monadic function `f` to combine two values at a key. -/
@[specialize] def mergeWithM [Monad m] (f : α → β → β → m β)
    (self other : HashMap α β) : m (HashMap α β) :=
  other.foldM (init := self) fun m k v₂ =>
    match m.find? k with
    | none => return m.insert k v₂
    | some v₁ => return m.insert k (← f k v₁ v₂)

/-- Combines two hashmaps using function `f` to combine two values at a key. -/
@[inline] def mergeWith (f : α → β → β → β) (self other : HashMap α β) : HashMap α β :=
  -- Implementing this function directly, rather than via `mergeWithM`, gives
  -- us less constrained universes.
  other.fold (init := self) λ map k v₂ =>
    match map.find? k with
    | none => map.insert k v₂
    | some v₁ => map.insert k $ f k v₁ v₂

/-- Runs a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def forM [Monad m] (f : α → β → m PUnit) (self : HashMap α β) : m PUnit := self.1.forM f

/-- Converts the map into a list of key-value pairs. -/
def toList (self : HashMap α β) : List (α × β) := self.fold (init := []) fun r k v => (k, v)::r

/-- Converts the map into an array of key-value pairs. -/
def toArray (self : HashMap α β) : Array (α × β) :=
  self.fold (init := #[]) fun r k v => r.push (k, v)

/-- The number of buckets in the hash map. -/
def numBuckets (self : HashMap α β) : Nat := self.1.buckets.1.size

/--
Builds a `HashMap` from a list of key-value pairs.
Values of duplicated keys are replaced by their respective last occurrences.
-/
def ofList (l : List (α × β)) : HashMap α β :=
  l.foldl (init := HashMap.empty) fun m (k, v) => m.insert k v

/-- Variant of `ofList` which accepts a function that combines values of duplicated keys. -/
def ofListWith (l : List (α × β)) (f : β → β → β) : HashMap α β :=
  l.foldl (init := HashMap.empty) fun m p =>
    match m.find? p.1 with
    | none   => m.insert p.1 p.2
    | some v => m.insert p.1 <| f v p.2


import quantifier_elimination
import data.nat.basic

namespace number_theory

open first_order

variable {L : language}

section NT_succ

/- The functions of number theory with successor -/
inductive NT_succ_func : ℕ → Type
| zero : NT_succ_func 0
| succ : NT_succ_func 1

/- The relations of number theory with successor -/
inductive NT_succ_rel : ℕ → Type

/- The language of number theory with successor -/
def NT_succ : language :=
  ⟨NT_succ_func, NT_succ_rel⟩

notation ` zero `  := @term.func NT_succ _ NT_succ_func.zero ![]
notation ` zero' `x := @term.func NT_succ _ NT_succ_func.zero x
notation ` succ `x := @term.func NT_succ _ NT_succ_func.succ ![x]
notation ` succ' `x := @term.func NT_succ _ NT_succ_func.succ x

@[simp]
def nth_succ (t : term NT_succ) : ℕ → term NT_succ
| 0            := t
| (nat.succ n) := succ' (λ _, nth_succ n)

/- The axioms of number theory with successor -/
inductive NT_succ_Γ
| eq1 : NT_succ_Γ
| eq2 : NT_succ_Γ
| ax1 : NT_succ_Γ
| ax2 : NT_succ_Γ
| ax3 : ℕ → NT_succ_Γ

open NT_succ_Γ

def NT_succ_Γ_to_formula : NT_succ_Γ → formula (NT_succ)
-- Equality is reflexive
| eq1     := formula.all 0 (v₀ ≃ v₀)
-- Functional extensionality
| eq2     := formula.all 0 (formula.all 1 (v₀ ≃ v₁ ⇒ (succ v₀) ≃ (succ v₁)))
-- Zero does not have a predecessor
| ax1     := formula.all 0 ∼((succ v₀) ≃ zero)
-- Successor is injective
| ax2     := formula.all 0 (formula.all 1 ((((succ v₀) ≃ (succ v₁)) ⇒ (v₀ ≃ v₁))))
-- There are no loops
| (ax3 n) := formula.all 0 ∼(nth_succ v₀ n ≃ v₀)

instance NT_succ_Γ_to_formula_NT_succ : has_coe NT_succ_Γ (formula NT_succ) := ⟨NT_succ_Γ_to_formula⟩

variables (φ : formula NT_succ) (t : term NT_succ)

lemma var_not_free_in_NT_succ_Γ : ∀ x : ℕ, @var_not_free_in_axioms NT_succ x NT_succ_Γ _ := sorry

-- Helpful lemmas
lemma rw_ite_P {α : Type*} (a b : α) (P : Prop) [decidable P] : P → ite P a b = a := sorry

lemma rw_ite_nP {α : Type*} (a b : α) (P : Prop) [decidable P]: ¬P → ite P a b = b := sorry

lemma fin_0_eq {α : Type*} (f g : fin 0 → α) : f = g := begin
  apply funext, intro x, rcases x with ⟨y, hy⟩, apply absurd hy (nat.not_lt_zero y),
end

lemma reflexive (Γ : list (formula NT_succ)) : ∀ t : term NT_succ, NT_succ_Γ ∣ Γ ⊢ t ≃ t := sorry

lemma symmetric (Γ : list (formula NT_succ)) : ∀ t₁ t₂ : term NT_succ,
  (NT_succ_Γ ∣ Γ ⊢ (t₁ ≃ t₂)) → (NT_succ_Γ ∣ Γ ⊢ (t₂ ≃ t₁)) := sorry

lemma ax1 (Γ : list (formula NT_succ)) (arg1 : fin 1 → term NT_succ) (arg2 : fin 0 → term NT_succ) :
  NT_succ_Γ ∣ Γ ⊢ ∼((succ' arg1) ≃ (zero' arg2)) := sorry

lemma ax2 (Γ : list (formula NT_succ)) (t₁ t₂ : term NT_succ) :
  NT_succ_Γ ∣ Γ ⊢ ((succ t₁) ≃ (succ t₂)) ⇒ (t₁ ≃ t₂) := sorry

lemma ax3 (Γ : list (formula NT_succ)) (t : term NT_succ) (n : ℕ) :
  NT_succ_Γ ∣ Γ ⊢ ∼(nth_succ t n ≃ t) := sorry

/- A function that converts a formula of the form t₁ ≃ t₂ to an equivalent quantifier free formula -/
@[simp]
def ex_t₁_eq_t₂_to_qf (n : ℕ) : term NT_succ → term NT_succ → qf NT_succ
-- vᵢ ≃ vⱼ
| (v m₁) (v m₂) := if n = m₁ then qf.n qf.f else (if n = m₂ then qf.n qf.f else qf.e (v m₁) (v m₂))
-- vᵢ ≃ 0
| (v m₁) (term.func NT_succ_func.zero arg) := if n = m₁ then qf.n qf.f else qf.e (v m₁) (zero' arg)
-- 0 ≃ vᵢ
| (term.func NT_succ_func.zero arg) (v m₂) := if n = m₂ then qf.n qf.f else qf.e (zero' arg) (v m₂)
/- ... -/
-- vᵢ ≃ succ y
| (v m₁) (term.func NT_succ_func.succ t₂) :=
  if n = m₁ then
    (if occurs_in_term n (@term.func NT_succ _ NT_succ_func.succ t₂) then qf.f else qf.n qf.f) else
    (if occurs_in_term n (@term.func NT_succ _ NT_succ_func.succ t₂) then qf.f else qf.e (v m₁) (@term.func NT_succ _ NT_succ_func.succ t₂))
-- succ x ≃ vⱼ
| (term.func NT_succ_func.succ t₁) (v m₂) := qf.f
-- 0 ≃ 0
| (term.func NT_succ_func.zero _) (term.func NT_succ_func.zero _) := qf.n qf.f
-- succ x ≃ 0
| (term.func NT_succ_func.succ t₁) (term.func NT_succ_func.zero _) := qf.f
-- 0 ≃ succ y
| (term.func NT_succ_func.zero _) (term.func NT_succ_func.succ t₂) := qf.f
-- succ x ≃ succ y
| (term.func NT_succ_func.succ t₁) (term.func NT_succ_func.succ t₂) := ex_t₁_eq_t₂_to_qf (t₁ 0) (t₂ 0)

def not_occurs_in_zero (n : ℕ) (args : fin 0 → term NT_succ) : ¬(@occurs_in_term NT_succ n (term.func NT_succ_func.zero args)) := begin
  simp, intro x, rcases x with ⟨n, hn⟩,
  apply false.elim (nat.not_lt_zero n hn)
end

lemma qe_ex_n_n_eq_t₂ (n : ℕ) (t₂ : term NT_succ) : ¬(occurs_in_term n t₂) →
  ((NT_succ_Γ ∣ [] ⊢ (exi n ((v n) ≃ t₂))) ↔ (@Prf NT_succ NT_succ_Γ _ list.nil T)) := begin
  intro h1, split,
  { intro h2, apply Top_intro },
  { simp, intro h2,
    apply Ex_intro n t₂ _,
    simp,
    rw replace_term_with_does_not_occur _ _ _ _ h1,
    apply reflexive,
  }
end

lemma qe_ex_n_t₁_eq_n (n : ℕ) (t₁ : term NT_succ) : ¬(occurs_in_term n t₁) →
  ((NT_succ_Γ ∣ [] ⊢ (exi n (t₁ ≃ (v n)))) ↔ (@Prf NT_succ NT_succ_Γ _ list.nil T)) := begin
  intro h1, split,
  { intro h2, apply Top_intro },
  { simp, intro h2,
    apply Ex_intro n t₁ _,
    simp,
    rw replace_term_with_does_not_occur _ _ _ _ h1,
    apply reflexive,
  }
end

lemma qe_ex_n_t₁_eq_t₂ (n : ℕ) (t₁ t₂ : term NT_succ) : ¬(occurs_in_term n t₁) → ¬(occurs_in_term n t₂) →
  (@Prf NT_succ NT_succ_Γ _ list.nil (exi n (t₁ ≃ t₂)) ↔ @Prf NT_succ NT_succ_Γ _ list.nil (t₁ ≃ t₂)) := begin
  intros ht₁ ht₂,
  split,
  { intro h1,
    apply Ex_elim n v₀ _ (t₁ ≃ t₂),
    have h2 : substitutable_for v₀ n (t₁ ≃ t₂) := sorry,
    apply h2,
    apply h1,
    unfold replace_formula_with,
    rw replace_term_with_does_not_occur _ n _ t₂ ht₂,
    apply Prf.Assumption 0, simp,
    apply replace_term_with_does_not_occur,
    apply ht₁,
  },
  { intro h1,
    apply Ex_intro n v₀,
    unfold replace_formula_with,
    rw replace_term_with_does_not_occur _ n _ t₁ ht₁,
    rw replace_term_with_does_not_occur _ n _ t₂ ht₂,
    assumption,
  }
end

lemma qe_ex_n_vi_eq_succ (n m : ℕ) (x : fin 1 → term NT_succ) :
  (NT_succ_Γ ∣ [] ⊢ exi n ((v m) ≃ succ' x)) ↔
  (@Prf NT_succ NT_succ_Γ _ list.nil ↑(ex_t₁_eq_t₂_to_qf n (v m) (succ' x))) := begin
  have x' := x 0,
  have h : (succ' x) = (succ x') := sorry,
  unfold ex_t₁_eq_t₂_to_qf,
  have h_occurs : (occurs_in_term n (succ' x)) ∨ ¬(occurs_in_term n (succ' x)) := by apply em,
  have m_eq : (m = n) ∨ (m ≠ n) := by apply em,
  apply or.elim h_occurs,
  all_goals { apply or.elim m_eq },
  all_goals { intro t₁eq', intro h_occurs' },
  { rw rw_ite_P _ _ _ (h_occurs'),
    rw t₁eq', simp,
    rw h,
    cases x',
    have x'eq : (x' = n) ∨ (x' ≠ n) := by apply em,
    apply or.elim x'eq,
    intro x'eq', rw x'eq',
    split,
    { intro h1,
      apply Ex_elim n (v n) _ F,
      have h2 : substitutable_for (v n) n (v n ≃ @term.func NT_succ _ NT_succ_func.succ ![v n]) := sorry,
      apply h2, apply h1,
      simp,
      apply Absurd,
      apply Prf.Assumption 0, refl,
      apply R_Not_ (symmetric _ _ _),
      apply ax3 _ (v n) 1,
    },
    { apply Prf.Bot_elim, },
    intro x'eq,
    have : ¬(occurs_in_term n (@term.func NT_succ _ NT_succ_func.succ x)) := sorry,
    contradiction,
    cases x'_ᾰ,
    {
      sorry
    },
    {
      sorry
    }
  },
  { rw rw_ite_P _ _ _ (h_occurs'),
    rw rw_ite_nP _ _ _ (ne.symm t₁eq'),
    sorry,
  },
  { rw rw_ite_nP _ _ _ (h_occurs'),
    rw t₁eq', simp,
    apply qe_ex_n_n_eq_t₂,
    assumption,
  },
  { rw rw_ite_nP _ _ _ (ne.symm t₁eq'),
    rw rw_ite_nP _ _ _ (h_occurs'),
    apply qe_ex_n_t₁_eq_t₂,
    simp, exact ne.symm t₁eq',
    assumption,
  }
end

lemma qe_ex_n_succ_eq_vj (n m : ℕ) (x : fin 1 → term NT_succ) :
  (NT_succ_Γ ∣ [] ⊢ exi n ((succ' x) ≃ (v m))) ↔
  (@Prf NT_succ NT_succ_Γ _ list.nil ↑(ex_t₁_eq_t₂_to_qf n (succ' x) (v m))) := sorry

lemma qe_ex_t₁_eq_t₂ (n : ℕ) (t₁ t₂ : term NT_succ) : equiv_qf NT_succ_Γ (exi n (t₁ ≃ t₂)) := begin
  existsi (ex_t₁_eq_t₂_to_qf n t₁ t₂),
  induction t₁, cases t₂,
  -- Case: vᵢ ≃ vⱼ
  { have t₁eq : (n = t₁) ∨ (n ≠ t₁) := by apply em,
    have t₂eq : (n = t₂) ∨ (n ≠ t₂) := by apply em,
    cases t₁eq,
    all_goals { cases t₂eq },
    -- n = t₁, n = t₂
    { rw ← t₁eq, rw ← t₂eq,
      split,
      intro h1, simp, apply Top_intro,
      intro h1, simp, apply Ex_intro n (v 0) _, simp, apply reflexive,
    },
    -- n = t₁, n ≠ t₂
    { rw ← t₁eq, simp,
      apply qe_ex_n_n_eq_t₂,
      simp, assumption,
    },
    -- n ≠ t₁, n = t₂
    { rw ← t₂eq, simp,
      apply qe_ex_n_t₁_eq_n,
      simp, assumption,
    },
    -- n ≠ t₁, n ≠ t₂
    { have h : (v t₁ ≃ v t₂) = ((ex_t₁_eq_t₂_to_qf n (v t₁) (v t₂)) : formula NT_succ) := begin
        simp, repeat { rw rw_ite_nP _ _ _ }, refl, repeat { assumption },
      end, rw ← h,
      apply qe_ex_n_t₁_eq_t₂,
      repeat { simp, assumption },
    },
  },
  { cases t₂_n, cases t₂_ᾰ,
    -- Case: vᵢ ≃ zero
    { simp,
      have t₁eq : (t₁ = n) ∨ (t₁ ≠ n) := by apply em,
      apply or.elim t₁eq,
      intro t₁eq', rw t₁eq', simp,
      apply qe_ex_n_n_eq_t₂,
      apply not_occurs_in_zero,
      intro t₁eq', rw rw_ite_nP _ _ _ (ne.symm t₁eq'),
      apply qe_ex_n_t₁_eq_t₂,
      simp, apply (ne.symm t₁eq'),
      apply not_occurs_in_zero,
    },
    cases t₂_ᾰ,
    -- Case: vᵢ ≃ succ x
    { apply qe_ex_n_vi_eq_succ }
  },
  cases t₁_ᾰ,
  all_goals { cases t₂ },
  any_goals { cases t₂_ᾰ },
  -- Case: zero ≃ vⱼ
  { simp,
    have t₂eq : (t₂ = n) ∨ (t₂ ≠ n) := by apply em,
    apply or.elim t₂eq,
    intro t₂eq', rw t₂eq', simp,
    apply qe_ex_n_t₁_eq_n,
    apply not_occurs_in_zero,
    intro t₂eq', rw rw_ite_nP _ _ _ (ne.symm t₂eq'),
    apply qe_ex_n_t₁_eq_t₂,
    apply not_occurs_in_zero,
    simp, apply (ne.symm t₂eq'),
  },
  -- Case: zero ≃ zero
  { simp, split,
    { intro h1, apply Top_intro },
    { intro h1, apply Ex_intro _ v₀,
      unfold replace_formula_with,
      repeat { rw replace_term_with_does_not_occur },
      rw fin_0_eq t₁_ᾰ_1 t₂_ᾰ_1,
      apply reflexive,
      repeat { apply not_occurs_in_zero _ _ },
    }
  },
  -- Case: zero ≃ succ y
  { simp, split,
    { intro h1,
      have h2 : ∃ m : ℕ, ¬(free m ((zero' t₁_ᾰ_1) ≃ (succ' t₂_ᾰ_1))) := by apply for_all_formula_ex_var_not_free,
      rcases h2 with ⟨m, hm⟩,
      unfold free at hm,
      have hm' : ¬(occurs_in_term m (zero' t₁_ᾰ_1)) ∧ ¬(occurs_in_term m (succ' t₂_ᾰ_1)) := not_or_distrib.mp hm,
      apply Ex_elim m (v 0) ((zero' t₁_ᾰ_1) ≃ (succ' t₂_ᾰ_1)),
      simp, apply (Ex_rename n m _ h1),
      apply Absurd,
      apply Prf.Assumption 0, refl,
      unfold replace_formula_with,
      repeat { rw replace_term_with_does_not_occur },
      apply R_Not_ (symmetric _ _ _),
      apply ax1,
      apply hm'.right, apply hm'.left,
    },
    { apply Prf.Bot_elim, }
  },
  -- Case: succ x ≃ vⱼ
  { apply qe_ex_n_succ_eq_vj },
  -- Case: succ x ≃ zero
  { simp, split,
    { intro h1,
      have h2 : ∃ m : ℕ, ¬(free m ((succ' t₁_ᾰ_1) ≃ (zero' t₂_ᾰ_1))) := by apply for_all_formula_ex_var_not_free,
      rcases h2 with ⟨m, hm⟩,
      unfold free at hm,
      have hm' : ¬(occurs_in_term m (succ' t₁_ᾰ_1)) ∧ ¬(occurs_in_term m (zero' t₂_ᾰ_1)) := not_or_distrib.mp hm,
      apply Ex_elim m (v 0) ((succ' t₁_ᾰ_1) ≃ (zero' t₂_ᾰ_1)),
      simp, apply (Ex_rename n m _ h1),
      apply Absurd,
      apply Prf.Assumption 0, refl,
      unfold replace_formula_with,
      repeat { rw replace_term_with_does_not_occur },
      apply ax1,
      apply hm'.right, apply hm'.left,
    },
    { apply Prf.Bot_elim, }
  },
  -- Case succ x ≃ succ y
  { sorry, },
end

lemma NT_succ_qe_ecl1 : @qe_ecl1 NT_succ NT_succ_Γ _ := begin
  intro φ,
  induction φ,
  { existsi (φ : qf NT_succ), refl, },
  { cases φ_ᾰ_1, cases φ_ᾰ_1, cases φ_ᾰ_1,
    { have h_free : ¬(@free NT_succ φ_ᾰ F) := by { intro, assumption, },
      apply Eq_equiv_qf ⟨AddEx, RemoveEx h_free⟩,
      existsi qf.f, refl,
    },
    { apply qe_ex_t₁_eq_t₂, },
    { cases φ_ᾰ_1_ᾰ, },
    cases φ_ᾰ_1,
    { have h_free : ¬(@free NT_succ φ_ᾰ ∼F) := by { intro c, apply c, },
      apply Eq_equiv_qf ⟨AddEx, RemoveEx h_free⟩,
      existsi qf.n qf.f, refl,
    },
    { have h_free₁ :
      (occurs_in_term φ_ᾰ φ_ᾰ_1_ᾰ) ∨ ¬(occurs_in_term φ_ᾰ φ_ᾰ_1_ᾰ) :=
        by apply em,
      have h_free₂ : (occurs_in_term φ_ᾰ φ_ᾰ_1_ᾰ_1) ∨ ¬(occurs_in_term φ_ᾰ φ_ᾰ_1_ᾰ_1) :=
        by apply em,
      apply or.elim h_free₁,
      all_goals { apply or.elim h_free₂ },
      repeat { sorry },
    },
    { cases φ_ᾰ_1_ᾰ, },
    { sorry },
  }
end

/- NT_succ has quantifier elimination -/
theorem NT_succ_qe : @qe NT_succ NT_succ_Γ _ := sorry

end NT_succ

end number_theory


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau, Yury Kudryashov
-/
import data.list.pairwise
import logic.relation

/-!
# Relation chain

This file provides basic results about `list.chain` (definition in `data.list.defs`).
A list `[a₂, ..., aₙ]` is a `chain` starting at `a₁` with respect to the relation `r` if `r a₁ a₂`
and `r a₂ a₃` and ... and `r aₙ₋₁ aₙ`. We write it `chain r a₁ [a₂, ..., aₙ]`.
A graph-specialized version is in development and will hopefully be added under `combinatorics.`
sometime soon.
-/

universes u v

open nat

namespace list

variables {α : Type u} {β : Type v} {R r : α → α → Prop} {l l₁ l₂ : list α} {a b : α}

mk_iff_of_inductive_prop list.chain list.chain_iff

theorem rel_of_chain_cons {a b : α} {l : list α}
  (p : chain R a (b :: l)) : R a b :=
(chain_cons.1 p).1

theorem chain_of_chain_cons {a b : α} {l : list α}
  (p : chain R a (b :: l)) : chain R b l :=
(chain_cons.1 p).2

theorem chain.imp' {S : α → α → Prop}
  (HRS : ∀ ⦃a b⦄, R a b → S a b) {a b : α} (Hab : ∀ ⦃c⦄, R a c → S b c)
  {l : list α} (p : chain R a l) : chain S b l :=
by induction p with _ a c l r p IH generalizing b; constructor;
   [exact Hab r, exact IH (@HRS _)]

theorem chain.imp {S : α → α → Prop}
  (H : ∀ a b, R a b → S a b) {a : α} {l : list α} (p : chain R a l) : chain S a l :=
p.imp' H (H a)

theorem chain.iff {S : α → α → Prop}
  (H : ∀ a b, R a b ↔ S a b) {a : α} {l : list α} : chain R a l ↔ chain S a l :=
⟨chain.imp (λ a b, (H a b).1), chain.imp (λ a b, (H a b).2)⟩

theorem chain.iff_mem {a : α} {l : list α} :
  chain R a l ↔ chain (λ x y, x ∈ a :: l ∧ y ∈ l ∧ R x y) a l :=
⟨λ p, by induction p with _ a b l r p IH; constructor;
  [exact ⟨mem_cons_self _ _, mem_cons_self _ _, r⟩,
   exact IH.imp (λ a b ⟨am, bm, h⟩,
    ⟨mem_cons_of_mem _ am, mem_cons_of_mem _ bm, h⟩)],
 chain.imp (λ a b h, h.2.2)⟩

theorem chain_singleton {a b : α} : chain R a [b] ↔ R a b :=
by simp only [chain_cons, chain.nil, and_true]

theorem chain_split {a b : α} {l₁ l₂ : list α} : chain R a (l₁ ++ b :: l₂) ↔
  chain R a (l₁ ++ [b]) ∧ chain R b l₂ :=
by induction l₁ with x l₁ IH generalizing a;
simp only [*, nil_append, cons_append, chain.nil, chain_cons, and_true, and_assoc]

@[simp] theorem chain_append_cons_cons {a b c : α} {l₁ l₂ : list α} :
  chain R a (l₁ ++ b :: c :: l₂) ↔ chain R a (l₁ ++ [b]) ∧ R b c ∧ chain R c l₂ :=
by rw [chain_split, chain_cons]

theorem chain_iff_forall₂ :
  ∀ {a : α} {l : list α}, chain R a l ↔ l = [] ∨ forall₂ R (a :: init l) l
| a [] := by simp
| a [b] := by simp [init]
| a (b :: c :: l) := by simp [@chain_iff_forall₂ b]

theorem chain_append_singleton_iff_forall₂ :
  chain R a (l ++ [b]) ↔ forall₂ R (a :: l) (l ++ [b]) :=
by simp [chain_iff_forall₂, init]

theorem chain_map (f : β → α) {b : β} {l : list β} :
  chain R (f b) (map f l) ↔ chain (λ a b : β, R (f a) (f b)) b l :=
by induction l generalizing b; simp only [map, chain.nil, chain_cons, *]

theorem chain_of_chain_map {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, S (f a) (f b) → R a b) {a : α} {l : list α}
  (p : chain S (f a) (map f l)) : chain R a l :=
((chain_map f).1 p).imp H

theorem chain_map_of_chain {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, R a b → S (f a) (f b)) {a : α} {l : list α}
  (p : chain R a l) : chain S (f a) (map f l) :=
(chain_map f).2 $ p.imp H

theorem chain_pmap_of_chain {S : β → β → Prop} {p : α → Prop}
  {f : Π a, p a → β}
  (H : ∀ a b ha hb, R a b → S (f a ha) (f b hb))
  {a : α} {l : list α}
  (hl₁ : chain R a l) (ha : p a) (hl₂ : ∀ a ∈ l, p a) :
  chain S (f a ha) (list.pmap f l hl₂) :=
begin
  induction l with lh lt l_ih generalizing a,
  { simp },
  { simp [H _ _ _ _ (rel_of_chain_cons hl₁), l_ih _ (chain_of_chain_cons hl₁)] }
end

theorem chain_of_chain_pmap {S : β → β → Prop} {p : α → Prop}
  (f : Π a, p a → β) {l : list α} (hl₁ : ∀ a ∈ l, p a)
  {a : α} (ha : p a) (hl₂ : chain S (f a ha) (list.pmap f l hl₁))
  (H : ∀ a b ha hb, S (f a ha) (f b hb) → R a b) :
  chain R a l :=
begin
  induction l with lh lt l_ih generalizing a,
  { simp },
  { simp [H _ _ _ _ (rel_of_chain_cons hl₂), l_ih _ _ (chain_of_chain_cons hl₂)] }
end

protected lemma pairwise.chain (p : pairwise R (a :: l)) : chain R a l :=
begin
  cases pairwise_cons.1 p with r p', clear p,
  induction p' with b l r' p IH generalizing a, {exact chain.nil},
  simp only [chain_cons, forall_mem_cons] at r,
  exact chain_cons.2 ⟨r.1, IH r'⟩
end

protected lemma chain.pairwise (tr : transitive R) :
  ∀ {a : α} {l : list α}, chain R a l → pairwise R (a :: l)
| a [] chain.nil := pairwise_singleton _ _
| a _ (@chain.cons _ _ _ b l h hb) := hb.pairwise.cons begin
    simp only [mem_cons_iff, forall_eq_or_imp, h, true_and],
    exact λ c hc, tr h (rel_of_pairwise_cons hb.pairwise hc),
  end

theorem chain_iff_pairwise (tr : transitive R) {a : α} {l : list α} :
  chain R a l ↔ pairwise R (a :: l) :=
⟨chain.pairwise tr, pairwise.chain⟩

protected lemma chain.sublist [is_trans α R] (hl : l₂.chain R a) (h : l₁ <+ l₂) : l₁.chain R a :=
by { rw chain_iff_pairwise (transitive_of_trans R) at ⊢ hl, exact hl.sublist (h.cons_cons a) }

protected lemma chain.rel [is_trans α R] (hl : l.chain R a) (hb : b ∈ l) : R a b :=
by { rw chain_iff_pairwise (transitive_of_trans R) at hl, exact rel_of_pairwise_cons hl hb }

theorem chain_iff_nth_le {R} : ∀ {a : α} {l : list α},
  chain R a l ↔ (∀ h : 0 < length l, R a (nth_le l 0 h)) ∧ (∀ i (h : i < length l - 1),
    R (nth_le l i (lt_of_lt_pred h)) (nth_le l (i+1) (lt_pred_iff.mp h)))
| a []       := by simp
| a (b :: t) :=
begin
  rw [chain_cons, chain_iff_nth_le],
  split,
  { rintro ⟨R, ⟨h0, h⟩⟩,
    split,
    { intro w, exact R },
    intros i w,
    cases i,
    { apply h0 },
    convert h i _ using 1,
    simp only [succ_eq_add_one, add_succ_sub_one, add_zero, length, add_lt_add_iff_right] at w,
    exact lt_pred_iff.mpr w, },
  rintro ⟨h0, h⟩, split,
  { apply h0, simp, },
  split,
  { apply h 0, },
  intros i w, convert h (i+1) _ using 1,
  exact lt_pred_iff.mp w,
end

theorem chain'.imp {S : α → α → Prop}
  (H : ∀ a b, R a b → S a b) {l : list α} (p : chain' R l) : chain' S l :=
by cases l; [trivial, exact p.imp H]

theorem chain'.iff {S : α → α → Prop}
  (H : ∀ a b, R a b ↔ S a b) {l : list α} : chain' R l ↔ chain' S l :=
⟨chain'.imp (λ a b, (H a b).1), chain'.imp (λ a b, (H a b).2)⟩

theorem chain'.iff_mem : ∀ {l : list α}, chain' R l ↔ chain' (λ x y, x ∈ l ∧ y ∈ l ∧ R x y) l
| []       := iff.rfl
| (x :: l) :=
  ⟨λ h, (chain.iff_mem.1 h).imp $ λ a b ⟨h₁, h₂, h₃⟩, ⟨h₁, or.inr h₂, h₃⟩,
   chain'.imp $ λ a b h, h.2.2⟩

@[simp] theorem chain'_nil : chain' R [] := trivial

@[simp] theorem chain'_singleton (a : α) : chain' R [a] := chain.nil

@[simp] theorem chain'_cons {x y l} : chain' R (x :: y :: l) ↔ R x y ∧ chain' R (y :: l) :=
chain_cons

theorem chain'_split {a : α} : ∀ {l₁ l₂ : list α}, chain' R (l₁ ++ a :: l₂) ↔
  chain' R (l₁ ++ [a]) ∧ chain' R (a :: l₂)
| []        l₂ := (and_iff_right (chain'_singleton a)).symm
| (b :: l₁) l₂ := chain_split

@[simp] theorem chain'_append_cons_cons {b c : α} {l₁ l₂ : list α} :
  chain' R (l₁ ++ b :: c :: l₂) ↔ chain' R (l₁ ++ [b]) ∧ R b c ∧ chain' R (c :: l₂) :=
by rw [chain'_split, chain'_cons]

theorem chain'_map (f : β → α) {l : list β} :
  chain' R (map f l) ↔ chain' (λ a b : β, R (f a) (f b)) l :=
by cases l; [refl, exact chain_map _]

theorem chain'_of_chain'_map {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, S (f a) (f b) → R a b) {l : list α}
  (p : chain' S (map f l)) : chain' R l :=
((chain'_map f).1 p).imp H

theorem chain'_map_of_chain' {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, R a b → S (f a) (f b)) {l : list α}
  (p : chain' R l) : chain' S (map f l) :=
(chain'_map f).2 $ p.imp H

theorem pairwise.chain' : ∀ {l : list α}, pairwise R l → chain' R l
| []       _ := trivial
| (a :: l) h := pairwise.chain h

theorem chain'_iff_pairwise (tr : transitive R) : ∀ {l : list α},
  chain' R l ↔ pairwise R l
| []       := (iff_true_intro pairwise.nil).symm
| (a :: l) := chain_iff_pairwise tr

protected lemma chain'.sublist [is_trans α R] (hl : l₂.chain' R) (h : l₁ <+ l₂) : l₁.chain' R :=
by { rw chain'_iff_pairwise (transitive_of_trans R) at ⊢ hl, exact hl.sublist h }

theorem chain'.cons {x y l} (h₁ : R x y) (h₂ : chain' R (y :: l)) :
  chain' R (x :: y :: l) :=
chain'_cons.2 ⟨h₁, h₂⟩

theorem chain'.tail : ∀ {l} (h : chain' R l), chain' R l.tail
| []            _ := trivial
| [x]           _ := trivial
| (x :: y :: l) h := (chain'_cons.mp h).right

theorem chain'.rel_head {x y l} (h : chain' R (x :: y :: l)) : R x y :=
rel_of_chain_cons h

theorem chain'.rel_head' {x l} (h : chain' R (x :: l)) ⦃y⦄ (hy : y ∈ head' l) : R x y :=
by { rw ← cons_head'_tail hy at h, exact h.rel_head }

theorem chain'.cons' {x} :
  ∀ {l : list α},  chain' R l → (∀ y ∈ l.head', R x y) → chain' R (x :: l)
| []       _  _ := chain'_singleton x
| (a :: l) hl H := hl.cons $ H _ rfl

theorem chain'_cons' {x l} : chain' R (x :: l) ↔ (∀ y ∈ head' l, R x y) ∧ chain' R l :=
⟨λ h, ⟨h.rel_head', h.tail⟩, λ ⟨h₁, h₂⟩, h₂.cons' h₁⟩

theorem chain'.drop : ∀ (n) {l} (h : chain' R l), chain' R (drop n l)
| 0       _             h := h
| _       []            _ := by {rw drop_nil, exact chain'_nil}
| (n + 1) [a]           _ := by {unfold drop, rw drop_nil, exact chain'_nil}
| (n + 1) (a :: b :: l) h := chain'.drop n (chain'_cons'.mp h).right

theorem chain'.append : ∀ {l₁ l₂ : list α} (h₁ : chain' R l₁) (h₂ : chain' R l₂)
  (h : ∀ (x ∈ l₁.last') (y ∈ l₂.head'), R x y),
  chain' R (l₁ ++ l₂)
| []            l₂ h₁ h₂ h := h₂
| [a]           l₂ h₁ h₂ h := h₂.cons' $ h _ rfl
| (a :: b :: l) l₂ h₁ h₂ h :=
  begin
    simp only [last'] at h,
    have : chain' R (b :: l) := h₁.tail,
    exact (this.append h₂ h).cons h₁.rel_head
  end

theorem chain'_pair {x y} : chain' R [x, y] ↔ R x y :=
by simp only [chain'_singleton, chain'_cons, and_true]

theorem chain'.imp_head {x y} (h : ∀ {z}, R x z → R y z) {l} (hl : chain' R (x :: l)) :
  chain' R (y :: l) :=
hl.tail.cons' $ λ z hz, h $ hl.rel_head' hz

theorem chain'_reverse : ∀ {l}, chain' R (reverse l) ↔ chain' (flip R) l
| []            := iff.rfl
| [a]           := by simp only [chain'_singleton, reverse_singleton]
| (a :: b :: l) := by rw [chain'_cons, reverse_cons, reverse_cons, append_assoc, cons_append,
    nil_append, chain'_split, ← reverse_cons, @chain'_reverse (b :: l), and_comm, chain'_pair, flip]

theorem chain'_iff_nth_le {R} : ∀ {l : list α},
  chain' R l ↔ ∀ i (h : i < length l - 1),
    R (nth_le l i (lt_of_lt_pred h)) (nth_le l (i+1) (lt_pred_iff.mp h))
| []            := by simp
| [a]           := by simp
| (a :: b :: t) :=
begin
  rw [chain'_cons, chain'_iff_nth_le],
  split,
  { rintro ⟨R, h⟩ i w,
    cases i,
    { exact R, },
    { convert h i _ using 1,
      simp only [succ_eq_add_one, add_succ_sub_one, add_zero, length, add_lt_add_iff_right] at w,
      simpa using w, } },
  { rintro h, split,
    { apply h 0, simp, },
    { intros i w, convert h (i+1) _ using 1,
      simp only [add_zero, length, add_succ_sub_one] at w,
      simpa using w, } },
end

/-- If `l₁ l₂` and `l₃` are lists and `l₁ ++ l₂` and `l₂ ++ l₃` both satisfy
  `chain' R`, then so does `l₁ ++ l₂ ++ l₃` provided `l₂ ≠ []` -/
lemma chain'.append_overlap : ∀ {l₁ l₂ l₃ : list α}
  (h₁ : chain' R (l₁ ++ l₂)) (h₂ : chain' R (l₂ ++ l₃)) (hn : l₂ ≠ []),
  chain' R (l₁ ++ l₂ ++ l₃)
| []             l₂        l₃ h₁ h₂ hn := h₂
| l₁             []        l₃ h₁ h₂ hn := (hn rfl).elim
| [a]            (b :: l₂) l₃ h₁ h₂ hn := by { simp at *, tauto }
| (a :: b :: l₁) (c :: l₂) l₃ h₁ h₂ hn := begin
  simp only [cons_append, chain'_cons] at h₁ h₂ ⊢,
  simp only [← cons_append] at h₁ h₂ ⊢,
  exact ⟨h₁.1, chain'.append_overlap h₁.2 h₂ (cons_ne_nil _ _)⟩
end

/--
If `a` and `b` are related by the reflexive transitive closure of `r`, then there is a `r`-chain
starting from `a` and ending on `b`.
The converse of `relation_refl_trans_gen_of_exists_chain`.
-/
lemma exists_chain_of_relation_refl_trans_gen (h : relation.refl_trans_gen r a b) :
  ∃ l, chain r a l ∧ last (a :: l) (cons_ne_nil _ _) = b :=
begin
  apply relation.refl_trans_gen.head_induction_on h,
  { exact ⟨[], chain.nil, rfl⟩ },
  { intros c d e t ih,
    obtain ⟨l, hl₁, hl₂⟩ := ih,
    refine ⟨d :: l, chain.cons e hl₁, _⟩,
    rwa last_cons_cons }
end

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true everywhere in the chain and at `a`.
That is, we can propagate the predicate up the chain.
-/
lemma chain.induction (p : α → Prop)
  (l : list α) (h : chain r a l)
  (hb : last (a :: l) (cons_ne_nil _ _) = b)
  (carries : ∀ ⦃x y : α⦄, r x y → p y → p x) (final : p b) : ∀ i ∈ a :: l, p i :=
begin
  induction l generalizing a,
  { cases hb,
    simp [final] },
  { rw chain_cons at h,
    rintro _ (rfl | _),
    apply carries h.1 (l_ih h.2 hb _ (or.inl rfl)),
    apply l_ih h.2 hb _ H }
end

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true at `a`.
That is, we can propagate the predicate all the way up the chain.
-/
@[elab_as_eliminator]
lemma chain.induction_head (p : α → Prop)
  (l : list α) (h : chain r a l)
  (hb : last (a :: l) (cons_ne_nil _ _) = b)
  (carries : ∀ ⦃x y : α⦄, r x y → p y → p x) (final : p b) : p a :=
(chain.induction p l h hb carries final) _ (mem_cons_self _ _)

/--
If there is an `r`-chain starting from `a` and ending at `b`, then `a` and `b` are related by the
reflexive transitive closure of `r`. The converse of `exists_chain_of_relation_refl_trans_gen`.
-/
lemma relation_refl_trans_gen_of_exists_chain (l) (hl₁ : chain r a l)
  (hl₂ : last (a :: l) (cons_ne_nil _ _) = b) :
  relation.refl_trans_gen r a b :=
chain.induction_head _ l hl₁ hl₂ (λ x y, relation.refl_trans_gen.head) relation.refl_trans_gen.refl

end list


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import topology.subset_properties
import topology.separation
import topology.noetherian_space

/-!
# Quasi-separated spaces

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

A topological space is quasi-separated if the intersections of any pairs of compact open subsets
are still compact.
Notable examples include spectral spaces, Noetherian spaces, and Hausdorff spaces.

A non-example is the interval `[0, 1]` with doubled origin: the two copies of `[0, 1]` are compact
open subsets, but their intersection `(0, 1]` is not.

## Main results

- `is_quasi_separated`: A subset `s` of a topological space is quasi-separated if the intersections
of any pairs of compact open subsets of `s` are still compact.
- `quasi_separated_space`: A topological space is quasi-separated if the intersections of any pairs
of compact open subsets are still compact.
- `quasi_separated_space.of_open_embedding`: If `f : α → β` is an open embedding, and `β` is
  a quasi-separated space, then so is `α`.
-/

open topological_space

variables {α β : Type*} [topological_space α] [topological_space β] {f : α → β}

/-- A subset `s` of a topological space is quasi-separated if the intersections of any pairs of
compact open subsets of `s` are still compact.

Note that this is equivalent to `s` being a `quasi_separated_space` only when `s` is open. -/
def is_quasi_separated (s : set α) : Prop :=
∀ (U V : set α), U ⊆ s → is_open U → is_compact U → V ⊆ s →
  is_open V → is_compact V → is_compact (U ∩ V)

/-- A topological space is quasi-separated if the intersections of any pairs of compact open
subsets are still compact. -/
@[mk_iff]
class quasi_separated_space (α : Type*) [topological_space α] : Prop :=
(inter_is_compact : ∀ (U V : set α),
  is_open U → is_compact U → is_open V → is_compact V → is_compact (U ∩ V))

lemma is_quasi_separated_univ_iff {α : Type*} [topological_space α] :
  is_quasi_separated (set.univ : set α) ↔ quasi_separated_space α :=
begin
  rw quasi_separated_space_iff,
  simp [is_quasi_separated],
end

lemma is_quasi_separated_univ {α : Type*} [topological_space α] [quasi_separated_space α] :
  is_quasi_separated (set.univ : set α) :=
is_quasi_separated_univ_iff.mpr infer_instance

lemma is_quasi_separated.image_of_embedding {s : set α}
  (H : is_quasi_separated s) (h : embedding f) : is_quasi_separated (f '' s) :=
begin
  intros U V hU hU' hU'' hV hV' hV'',
  convert (H (f ⁻¹' U) (f ⁻¹' V) _ (h.continuous.1 _ hU') _ _ (h.continuous.1 _ hV') _).image
    h.continuous,
  { symmetry,
    rw [← set.preimage_inter, set.image_preimage_eq_inter_range, set.inter_eq_left_iff_subset],
    exact (set.inter_subset_left _ _).trans (hU.trans (set.image_subset_range _ _)) },
  { intros x hx, rw ← (h.inj.inj_on _).mem_image_iff (set.subset_univ _) trivial, exact hU hx },
  { rw h.is_compact_iff_is_compact_image,
    convert hU'',
    rw [set.image_preimage_eq_inter_range, set.inter_eq_left_iff_subset],
    exact hU.trans (set.image_subset_range _ _) },
  { intros x hx, rw ← (h.inj.inj_on _).mem_image_iff (set.subset_univ _) trivial, exact hV hx },
  { rw h.is_compact_iff_is_compact_image,
    convert hV'',
    rw [set.image_preimage_eq_inter_range, set.inter_eq_left_iff_subset],
    exact hV.trans (set.image_subset_range _ _) }
end

lemma open_embedding.is_quasi_separated_iff (h : open_embedding f) {s : set α} :
  is_quasi_separated s ↔ is_quasi_separated (f '' s) :=
begin
  refine ⟨λ hs, hs.image_of_embedding h.to_embedding, _⟩,
  intros H U V hU hU' hU'' hV hV' hV'',
  rw [h.to_embedding.is_compact_iff_is_compact_image, set.image_inter h.inj],
  exact H (f '' U) (f '' V)
    (set.image_subset _ hU) (h.is_open_map _ hU') (hU''.image h.continuous)
    (set.image_subset _ hV) (h.is_open_map _ hV') (hV''.image h.continuous)
end

lemma is_quasi_separated_iff_quasi_separated_space (s : set α) (hs : is_open s) :
  is_quasi_separated s ↔ quasi_separated_space s :=
begin
  rw ← is_quasi_separated_univ_iff,
  convert hs.open_embedding_subtype_coe.is_quasi_separated_iff.symm; simp
end

lemma is_quasi_separated.of_subset {s t : set α} (ht : is_quasi_separated t) (h : s ⊆ t) :
  is_quasi_separated s :=
begin
  intros U V hU hU' hU'' hV hV' hV'',
  exact ht U V (hU.trans h) hU' hU'' (hV.trans h) hV' hV'',
end

@[priority 100]
instance t2_space.to_quasi_separated_space [t2_space α] : quasi_separated_space α :=
⟨λ U V hU hU' hV hV', hU'.inter hV'⟩

@[priority 100]
instance noetherian_space.to_quasi_separated_space [noetherian_space α] :
  quasi_separated_space α :=
⟨λ _ _ _ _ _ _, noetherian_space.is_compact _⟩

lemma is_quasi_separated.of_quasi_separated_space (s : set α) [quasi_separated_space α] :
  is_quasi_separated s :=
is_quasi_separated_univ.of_subset (set.subset_univ _)

lemma quasi_separated_space.of_open_embedding (h : open_embedding f) [quasi_separated_space β] :
  quasi_separated_space α :=
is_quasi_separated_univ_iff.mp
  (h.is_quasi_separated_iff.mpr $ is_quasi_separated.of_quasi_separated_space _)


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.CommMon_
import Mathlib.category_theory.monoidal.functor_category
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂

namespace Mathlib

/-!
# `Mon_ (C ⥤ D) ≌ C ⥤ Mon_ D`

When `D` is a monoidal category,
monoid objects in `C ⥤ D` are the same thing as functors from `C` into the monoid objects of `D`.

This is formalised as:
* `Mon_functor_category_equivalence : Mon_ (C ⥤ D) ≌ C ⥤ Mon_ D`

The intended application is that as `Ring ≌ Mon_ Ab` (not yet constructed!),
we have `presheaf Ring X ≌ presheaf (Mon_ Ab) X ≌ Mon_ (presheaf Ab X)`,
and we can model a module over a presheaf of rings as a module object in `presheaf Ab X`.

## Future work
Presumably this statement is not specific to monoids,
and could be generalised to any internal algebraic objects,
if the appropriate framework was available.
-/

namespace category_theory.monoidal

namespace Mon_functor_category_equivalence

/--
Functor translating a monoid object in a functor category
to a functor into the category of monoid objects.
-/
@[simp] theorem functor_map_app_hom {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] (A : Mon_ (C ⥤ D)) (B : Mon_ (C ⥤ D)) (f : A ⟶ B) (X : C) : Mon_.hom.hom (nat_trans.app (functor.map functor f) X) = nat_trans.app (Mon_.hom.hom f) X :=
  Eq.refl (Mon_.hom.hom (nat_trans.app (functor.map functor f) X))

/--
Functor translating a functor into the category of monoid objects
to a monoid object in the functor category
-/
@[simp] theorem inverse_map_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] (F : C ⥤ Mon_ D) (G : C ⥤ Mon_ D) (α : F ⟶ G) (X : C) : nat_trans.app (Mon_.hom.hom (functor.map inverse α)) X = Mon_.hom.hom (nat_trans.app α X) :=
  Eq.refl (nat_trans.app (Mon_.hom.hom (functor.map inverse α)) X)

/--
The unit for the equivalence `Mon_ (C ⥤ D) ≌ C ⥤ Mon_ D`.
-/
@[simp] theorem unit_iso_inv_app_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] (X : Mon_ (C ⥤ D)) (_x : C) : nat_trans.app (Mon_.hom.hom (nat_trans.app (iso.inv unit_iso) X)) _x = 𝟙 :=
  Eq.refl 𝟙

/--
The counit for the equivalence `Mon_ (C ⥤ D) ≌ C ⥤ Mon_ D`.
-/
@[simp] theorem counit_iso_inv_app_app_hom {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] (X : C ⥤ Mon_ D) : ∀ (X_1 : C), Mon_.hom.hom (nat_trans.app (nat_trans.app (iso.inv counit_iso) X) X_1) = 𝟙 :=
  fun (X_1 : C) => Eq.refl 𝟙

end Mon_functor_category_equivalence

/--
When `D` is a monoidal category,
monoid objects in `C ⥤ D` are the same thing
as functors from `C` into the monoid objects of `D`.
-/
@[simp] theorem Mon_functor_category_equivalence_counit_iso (C : Type u₁) [category C] (D : Type u₂) [category D] [monoidal_category D] : equivalence.counit_iso (Mon_functor_category_equivalence C D) = Mon_functor_category_equivalence.counit_iso :=
  Eq.refl (equivalence.counit_iso (Mon_functor_category_equivalence C D))

namespace CommMon_functor_category_equivalence

/--
Functor translating a commutative monoid object in a functor category
to a functor into the category of commutative monoid objects.
-/
@[simp] theorem functor_obj_map {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] [braided_category D] (A : CommMon_ (C ⥤ D)) {X : C} {Y : C} : ∀ (ᾰ : X ⟶ Y),
  functor.map (functor.obj functor A) ᾰ =
    functor.map (functor.obj (equivalence.functor (Mon_functor_category_equivalence C D)) (CommMon_.to_Mon_ A)) ᾰ :=
  fun (ᾰ : X ⟶ Y) => Eq.refl (functor.map (functor.obj functor A) ᾰ)

/--
Functor translating a functor into the category of commutative monoid objects
to a commutative monoid object in the functor category
-/
def inverse {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] [braided_category D] : (C ⥤ CommMon_ D) ⥤ CommMon_ (C ⥤ D) :=
  functor.mk
    (fun (F : C ⥤ CommMon_ D) =>
      CommMon_.mk
        (Mon_.mk
          (Mon_.X
            (functor.obj (equivalence.inverse (Mon_functor_category_equivalence C D)) (F ⋙ CommMon_.forget₂_Mon_ D)))
          (Mon_.one
            (functor.obj (equivalence.inverse (Mon_functor_category_equivalence C D)) (F ⋙ CommMon_.forget₂_Mon_ D)))
          (Mon_.mul
            (functor.obj (equivalence.inverse (Mon_functor_category_equivalence C D)) (F ⋙ CommMon_.forget₂_Mon_ D)))))
    fun (F G : C ⥤ CommMon_ D) (α : F ⟶ G) =>
      functor.map (equivalence.inverse (Mon_functor_category_equivalence C D)) (whisker_right α (CommMon_.forget₂_Mon_ D))

/--
The unit for the equivalence `CommMon_ (C ⥤ D) ≌ C ⥤ CommMon_ D`.
-/
@[simp] theorem unit_iso_inv_app_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] [braided_category D] (X : CommMon_ (C ⥤ D)) (_x : C) : nat_trans.app (Mon_.hom.hom (nat_trans.app (iso.inv unit_iso) X)) _x = 𝟙 :=
  Eq.refl 𝟙

/--
The counit for the equivalence `CommMon_ (C ⥤ D) ≌ C ⥤ CommMon_ D`.
-/
def counit_iso {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D] [braided_category D] : inverse ⋙ functor ≅ 𝟭 :=
  nat_iso.of_components
    (fun (A : C ⥤ CommMon_ D) => nat_iso.of_components (fun (X : C) => iso.mk (Mon_.hom.mk 𝟙) (Mon_.hom.mk 𝟙)) sorry)
    sorry

end CommMon_functor_category_equivalence

/--
When `D` is a braided monoidal category,
commutative monoid objects in `C ⥤ D` are the same thing
as functors from `C` into the commutative monoid objects of `D`.
-/
@[simp] theorem CommMon_functor_category_equivalence_inverse (C : Type u₁) [category C] (D : Type u₂) [category D] [monoidal_category D] [braided_category D] : equivalence.inverse (CommMon_functor_category_equivalence C D) = CommMon_functor_category_equivalence.inverse :=
  Eq.refl (equivalence.inverse (CommMon_functor_category_equivalence C D))


variables p q : Prop
variable hp : p

theorem t1 : q → p := λ (hq : q), hp


import Reynold_operator.reynold
import basic_definitions.kernel_range
import Tools.tools
open Reynold stability morphism_module linear_map
open_locale big_operators
universes  u v w w'
variables   {G : Type u} [group G][fintype G]
            {R : Type v}[comm_ring R]
            {M : Type w}[add_comm_group M] [module R M]
            (ρ : group_representation G R M)
            (W : submodule  R M)

theorem pre_mask (Hyp : has_projector W)  [stable_submodule ρ  W] (a : R )  (inv : a * (fintype.card G) = 1 ) :
∃ F : ρ ⟶ᵣ ρ,is_projector F.ℓ ∧  linear_map.range (F.ℓ) = W   :=
begin
    rcases Hyp with ⟨p,hyp_p⟩,
    use a • (ℛ ρ ρ  p),
    rw coe_smul,
    erw reynold_ext,
    apply   sum_proj, assumption,
    apply conjugate_projector, exact  hyp_p.1,
    rw ←hyp_p.2 at *,
    apply @conj_mixte_range G _ _ R _ M _ _ ρ p _inst_6,
end
namespace field
variables
            {k : Type v}[comm_ring k]
            {V : Type w}[add_comm_group V] [module R V]
            (π  : group_representation G R V)
            (F : submodule  R V)
            -- ici juste virer l'hypothèse has_projector !

end field


import Playground.Category.Functor.Universal
import Playground.Category.WithZeroMorphisms

namespace Category.Construction
section
  open Functor
  variable {C} [Category C] {X Y : C} (f g : X ⟶ Y)
  namespace CoEqualizer
  structure Data where
    object : C
    morphism : Y ⟶ object
    comm : f ≫ morphism = g ≫ morphism
  instance : CoUniversal.CanFactorThrough (Data f g) where
    object := Data.object
    FactorsThroughVia ψ φ α := φ.morphism ≫ α = ψ.morphism
    FactorsThroughVia_comp {f d f' α α'} (hα : _ = _) (hα' : _ = _) := show _ = _ from
      assoc _ α _ ▸ hα ▸ hα'
    FactorsThroughVia_id := by simp
  end CoEqualizer
  structure CoEqualizer extends CoEqualizer.Data f g, CoUniversal.Property toData
end

section
  open Functor
  variable {C} [Category C] [WithZeroMorphisms C] {X Y : C} (f : X ⟶ Y)
  namespace CoKernel
  structure Data where
    object : C
    morphism : Y ⟶ object
    comm : f ≫ morphism = 𝟬 _ _
  instance : CoUniversal.CanFactorThrough (Data f) where
    object := Data.object
    FactorsThroughVia ψ φ α := φ.morphism ≫ α = ψ.morphism
    FactorsThroughVia_comp {f d f' α α'} (hα : _ = _) (hα' : _ = _) := show _ = _ from
      assoc _ α _ ▸ hα ▸ hα'
    FactorsThroughVia_id := by simp
  end CoKernel
  structure CoKernel extends CoKernel.Data f, CoUniversal.Property toData
end

section
  open Functor
  universe u
  variable {X : Type u} (s : Setoid X)
  namespace Quotient
  structure Data.{v} where
    object : Type v
    morphism : X → object
    sound : ∀ x y : X, x ≈ y → morphism x = morphism y
  instance : CoUniversal.CanFactorThrough (Data s) where
    object := Data.object
    FactorsThroughVia f π f' := π.morphism ≫ f' = f.morphism
    FactorsThroughVia_comp {f d f' α α'} (hα : _ = _) (hα' : _ = _) := show _ = _ from
      assoc _ α _ ▸ hα ▸ hα'
    FactorsThroughVia_id g := by simp
  end Quotient
  structure Quotient extends Quotient.Data s, CoUniversal.Property toData

  noncomputable def isomorphismOfSolutions (h : Quotient s) (h' : Quotient s) : h.object ≅ h'.object :=
    let this : (d : Quotient s) → CoUniversal.Property d.toData := Quotient.toProperty
    CoUniversal.isomorphismOfSolutions h.toData h'.toData
end
end Category.Construction
namespace Category
example {X} (s : Setoid X) : Construction.Quotient s where
  object := Quotient s
  morphism := Quotient.mk s
  sound _ _ := Quotient.sound
  existence
  | { object := Y
      morphism := f
      sound := h } =>
    ⟨show Quotient s → Y from Quotient.lift f h,
    show (Quotient.lift f h) ∘ (Quotient.mk s) = f from funext λ _ => rfl⟩
  uniqueness
  | { object := Y,
      morphism := f,
      sound := h },
    (α : Quotient s → Y), (β : Quotient s → Y),
    (hα : α ∘ (Quotient.mk s) = f), (hβ : β ∘ (Quotient.mk s) = f) =>
      have : α ∘ (Quotient.mk s) = β ∘ (Quotient.mk s) := hα ▸ hβ ▸ rfl
      funext <| Quotient.ind <| congrFun <| this
end Category


/- Author: E.W.Ayers.
   This section roughly follows Chapter 3, §1, §2 of Sheaves in Geology and Logic by Saunders Maclane and Ieke M.
 -/

import category_theory.whiskering
import .sieve
import .pullbacks

universes u v w
namespace category_theory

open order lattice

def sieve_set (C : Type u) [𝒞 : category.{v} C] :=  Π (X : C), set (sieve X)

def arrow_set (C : Type u) [𝒞 : category.{v} C] :=  Π (X : C), set (set (over X))

def sieve_set.trivial (C : Type u) [𝒞 : category.{v} C] : sieve_set C := λ X, {⊤}

def sieve_set.dense (C : Type u) [𝒞 : category.{v} C] : sieve_set C :=
λ X, {S| ∀ {Y : C} (f : Y ⟶ X), ∃ (Z) (g : Z ⟶ Y), (over.mk (g ≫ f)) ∈ S }

/-- The atomic sieve_set just contains all of the non-empty sieves. -/
def sieve_set.atomic (C : Type u) [𝒞 : category.{v} C] : sieve_set C :=
λ X, {S | ∃ x, x ∈ S}

def sieve_set.generate {C : Type u} [𝒞 : category.{v} C] (K : arrow_set C) : sieve_set C :=
λ X, {S | ∃ R ∈ K(X), R ⊆ S.arrows}

open sieve category

/-- Definition of a Grothendiek Topology. -/
class grothendieck {C : Type u} [𝒞 : category.{v} C] (J : sieve_set C) :=
(max : ∀ X, ⊤ ∈ J(X))
(stab : ∀ (X Y : C) (S ∈ J(X)) (h : Y ⟶ X), sieve.pullback S h ∈ J(Y))
(trans :
  ∀ ⦃X : C⦄,
  ∀ (S ∈ J(X)),
  ∀ (R : sieve X),
  ∀ (_ : ∀ (f : over X),
         ∀ (_ : f ∈ S),
           sieve.pullback R f.hom ∈ J(f.left)),
    R ∈ J(X)
)

structure Site :=
(C : Type u)
[𝒞 : category.{v} C]
(J : sieve_set C)
[g : @grothendieck C 𝒞 J]

namespace grothendieck

variables {C : Type u} [𝒞 : category.{v} C]
variables {X Y : C} {S R : sieve X}
variables {J : sieve_set C} [grothendieck J]
include 𝒞

class basis [@category_theory.limits.has_pullbacks C 𝒞] (K : arrow_set C) :=
(has_isos      : ∀ {X Y : C} (e : X ≅ Y), {over.mk e.hom} ∈ K(Y))
(has_pullbacks : ∀ {X Y : C} {ℱ : set (over X)} (h₁ : ℱ ∈ K(X)) (g : Y ⟶ X), set.image (over.pullback g) ℱ ∈ K(Y))
(trans : ∀ {X} {ℱ : set (over X)},
         ∀ (h₁ : ℱ ∈ K(X)),
         ∀ (𝒢 : ∀ {f : over X} (hf :f ∈ ℱ), set (over f.left)),
         ∀ (h₃ : ∀ {f : over X} (hf : f ∈ ℱ), 𝒢 hf ∈ K(f.left)),
           {h : over X | ∃ (f : over X) (hf : f ∈ ℱ) (g : over f.left) (hg : g ∈ 𝒢 hf), h = over.mk (g.hom ≫ f.hom)} ∈ K(X))

instance of_basis [@category_theory.limits.has_pullbacks C 𝒞] {K : arrow_set C} [basis K] : grothendieck (sieve_set.generate K) :=
{ max := λ X, ⟨{over.mk (𝟙 X)}, basis.has_isos K (iso.refl X), λ f h, ⟨⟩⟩,
  stab := begin
    rintros X Y S ⟨ℱ,h₁,h₂⟩ f,
    refine ⟨_,basis.has_pullbacks h₁ f,_⟩,
    rintros g ⟨h,h₃,rfl⟩,
    show over.mk (_ ≫ f) ∈ S,
    simp,
    rw limits.pullback.condition,
    apply sieve.subs,
    apply h₂,
    apply h₃
  end,
  trans := begin
    rintros X S ⟨ℱ,h₁,h₂⟩ R h₃,
    have h₄ :  ∀ (f : over X), f ∈ S → ∃ T, T ∈ K f.left ∧ T ⊆ {sl : over f.left | (over.mk $ sl.hom ≫ f.hom) ∈ R },
      rw [sieve_set.generate] at h₃, simp at h₃,
      exact h₃,
    rw [sieve_set.generate],
    show ∃ (T : set (over X)) (H : T ∈ K X), T ⊆ R.arrows,
    refine ⟨_,basis.trans h₁ _ _,_⟩,
    { intros f hf, apply (classical.some (h₄ f (h₂ hf)))},
    { intros f hf, rcases classical.some_spec (h₄ f (h₂ hf)) with ⟨h10,h11⟩, apply h10 },
    {
      rintros f ⟨g,h₅,h,h₆,rfl⟩,
      rcases classical.some_spec (h₄ g (h₂ h₅)) with ⟨h11,h12⟩,
      apply h12,
      assumption
    }
  end,
}

def superset_covers (Hss : S ⊆ R) (sjx : S ∈ J(X)) : (R ∈ J(X)) :=
begin
  apply grothendieck.trans,
    apply sjx,
  rintros h H2,
  have : over.mk (𝟙 h.left) ∈ (sieve.pullback R h.hom),
    apply Hss,
    simp, rw [@category.id_comp _ _ h.left _ h.hom], simp,
    apply H2,
  have : sieve.pullback R h.hom = ⊤,
    apply top_of_has_id this,
  rw this,
  apply grothendieck.max
end

def trans2
  (sjx : S ∈ J(X))
  (R : Π (f : over X), sieve f.left)
  (hR : Π f (H:f ∈ S), (R f) ∈ J(f.left))
  : comps R S ∈ J(X) :=
  begin
    apply grothendieck.trans,
      apply sjx,
    rintros f Hf,
    apply superset_covers,
      apply sieve.pullback_le_map,
      apply comp_le_comps,
      apply Hf,
    apply superset_covers,
      apply le_pullback_comp,
    apply hR,
    apply Hf,
  end

def covers (J : sieve_set C) (S : sieve X) (f : Y ⟶ X) :=
sieve.pullback S f ∈ J(Y)

lemma intersection_covers (rj : R ∈ J(X)) (sj : S ∈ J(X)) : R ⊓ S ∈ J(X) :=
begin
  apply grothendieck.trans R, assumption,
  intros f Hf,
  apply superset_covers,
  show sieve.pullback S (f.hom) ⊆ sieve.pullback (R ⊓ S) (f.hom),
    intros g gys, refine ⟨_,gys⟩,
    apply sieve.subs,
    assumption,
  apply grothendieck.stab, assumption, apply_instance
end

open sieve_set

instance trivial.grothendieck : grothendieck (sieve_set.trivial C) :=
{ max := λ X, set.mem_singleton _,
  stab := λ X Y S HS h , begin
    have : S = ⊤,
      apply set.eq_of_mem_singleton, assumption,
    rw [this, sieve.pullback_top],
    apply set.mem_singleton
  end,
  trans := λ X S HS R HR, begin
    have : S = ⊤, apply set.eq_of_mem_singleton, assumption, subst this,
    apply set.mem_singleton_of_eq,
    apply lattice.top_unique,
    rintros g Hg,
    have : sieve.pullback R (g.hom) ≥ ⊤, refine (ge_of_eq (set.eq_of_mem_singleton (HR g Hg))),
    have : over.mk (𝟙 g.left) ∈ sieve.pullback R (g.hom), refine this _, trivial,
    have : over.mk (𝟙 (g.left) ≫ g.hom) ∈ R, apply this,
    simpa,
  end
}

instance dense.grothendieck : grothendieck (dense C) :=
{ max := λ X Y f, ⟨Y,𝟙 Y, ⟨⟩⟩
, stab :=
    begin
      intros X Y S H h Z f,
      rcases H (f ≫ h) with ⟨W,g,H⟩,
      refine ⟨W,g,_⟩,
      simp, apply H
    end
, trans :=
    begin intros X S H₁ R H₂ Y f,
      rcases H₁ f with ⟨Z,g,H₃⟩,
      rcases H₂ _ H₃ (𝟙 Z) with ⟨W,h,H₄⟩,
      refine ⟨W,(h ≫ (𝟙 Z) ≫ g), _⟩,
      simp [sieve_set.dense] at *,
      apply H₄
    end
}

/-- The atomic sieveset is a grothendieck topology when it
    satisfies the 'square' property. Which says that every span `Y ⟶ X ⟵ Z` forms a commuting
    diagram. -/
instance atomic.grothendieck
  (square :
    ∀ {X Y Z : C} (yx : Y ⟶ X) (zx : Z ⟶ X),
    ∃ (W : C)     (wy : W ⟶ Y) (wz : W ⟶ Z),
      wy ≫ yx = wz ≫ zx)
  : grothendieck (atomic C) :=
{ max := λ X, ⟨over.mk (𝟙 _),⟨⟩⟩,
  stab := begin
    rintros X Y S HS h,
    cases HS with f HS,
    rcases square h f.hom with ⟨a,b,c,d⟩,
    refine ⟨over.mk b,_⟩,
    simp, rw d,
    apply sieve.subs, assumption
   end,
   trans := begin
     rintros _ _ ⟨f,fS⟩ _ Ra,
     rcases Ra f fS with ⟨g,h₁⟩,
     refine ⟨_,h₁⟩
   end
}

open opposite

def matching_family (P : Cᵒᵖ ⥤ Type v) (S : sieve X) :=
S.as_functor ⟶ P

def amalgamation {P : Cᵒᵖ ⥤ Type v} {S : sieve X} (γ : matching_family P S) :=
{α : yoneda.obj X ⟶ P // sieve.functor_inclusion S ≫ α = γ}

def sheaf (J : sieve_set C) [grothendieck J] (P : Cᵒᵖ ⥤ Type v) :=
∀ (X : C) (S : sieve X) (γ : matching_family P S), S ∈ J(X) → unique (amalgamation γ)

end grothendieck

end category_theory


variables {p q : Prop} (hp : p) (hq : q)

example : p ∧ q ∧ p :=
let hp := hp, hq := hq in
begin
  apply and.intro hp,
  exact and.intro hq hp
end


import formula
import logic.nonempty

/-- A frame is a binary *accesibility* relation R on a nonempty set of *worlds*
W. -/
structure frame : Type 1 :=
  (W : Type) [hnonempty : nonempty W]
  (R : W → W → Prop)
notation `‹` W `, ` R `›` := frame.mk W R

instance frame_nonempty := frame.hnonempty

/-- A model for the language of modal formulas defined above is ⟨W, R, V⟩
where
1. W is a nonempty set of *worlds*,
2. R is a binary *accessibility* relation on W,
3. V is a truth assignment of each variable x to the set worlds in which it
   is true.
(W, R) alone without the truth assignment constitutes a `frame`. This separation
will become important when we talk about frame definability.

The nonemptiness of W will be assumed in the theorems, not the definition.

Note: W is given as an argument to deal with type universe issues. -/
structure model (vars : Type) : Type 1 :=
  (F : frame)
  (V : vars → set F.W)
notation `⟪` W `, ` R `, ` V `⟫` := model.mk (frame.mk W R) V
notation `⟪` F `, ` V `⟫` := model.mk F V

@[ext]
lemma model_ext {vars : Type} (M : model vars)
: M = model.mk (frame.mk M.F.W M.F.R) M.V :=
begin
  rcases M with ⟨⟨W, _, R⟩, V⟩,
  simp
end

variables {vars : Type} [denumerable vars] {W : Type} [nonempty W]
variables {A B C : form vars}

/-- Truth at a world -/
@[simp]
def eval (M : model vars) : M.F.W → form vars → Prop
| w (form.Bottom) := false
| w ⦃x⦄ := w ∈ M.V x
| w (~ P) := ¬ eval w P
| w (P ⋀ Q) := eval w P ∧ eval w Q
| w (P ⋁ Q) := eval w P ∨ eval w Q
| w (P ⟹ Q) := eval w P → eval w Q
| w (□ P) := ∀ w', M.F.R w w' → eval w' P

notation M `@@` w ` ⊩ ` P := eval M w P
notation M `@@` w ` ⊮ ` P := ¬ eval M w P

theorem box_diamond_dual {M : model vars} {w : M.F.W}
  : (M @@ w ⊩ □ A) ↔ (M @@ w ⊩ ~ ◇ ~ A) :=
begin
  simp [eval],
end

theorem diamond_box_dual {M : model vars} {w : M.F.W}
  : (M @@ w ⊩ ◇ A) ↔ (M @@ w ⊩ ~ □ ~ A) :=
begin
  simp,
end

notation M ` ⊩ ` P := ∀w, M @@ w ⊩ P
notation M ` ⊮ ` P := ¬ (M ⊩ P)

example {M : model vars} : (M ⊩ A) → (M ⊮ ~ A) :=
begin
simp only [eval, not_forall, not_not],
intro hA,
use classical.choice M.F.hnonempty,
apply hA,
end

example {M : model vars} : (M ⊩ A ⟹ B) → (M ⊩ A) → (M ⊩ B) :=
begin
simp only [eval],
intros hAB hA w,
specialize hAB w,
specialize hA w,
exact hAB hA
end

def valid (A : form vars) := ∀ M : model vars, M ⊩ A

/- The following development of tautological instances is subsumed by a more
general proof when I talk about schemas, so I don't talk about it in the report.
I still learned something out of it though, so I'll leave it in. -/

/-- A formula is modal-free if it contains no modal operator, i.e. □ -/
def modal_free : form vars → Prop
| form.Bottom := true
| ⦃_⦄ := true
| ~ A := modal_free A
| (A ⋀ B) := modal_free A ∧ modal_free B
| (A ⋁ B) := modal_free A ∧ modal_free B
| (A ⟹ B) := modal_free A ∧ modal_free B
| □ A := false

/-- Modal-free formulas can be evaluated as they would in propositional logic,
by truth-value assignments.

Learning point: recursing over two arguments to ensure that we can rule out
the modality. -/
def eval_modal_free (v : vars → Prop) : ∀(A : form vars), modal_free A → Prop
| form.Bottom _ := false
| ⦃x⦄ _ := v x
| (~ A) hA := ¬ eval_modal_free A hA
| (A ⋀ B) ⟨hA, hB⟩ := eval_modal_free A hA ∧ eval_modal_free B hB
| (A ⋁ B) ⟨hA, hB⟩ := eval_modal_free A hA ∨ eval_modal_free B hB
| (A ⟹ B) ⟨hA, hB⟩ := eval_modal_free A hA → eval_modal_free B hB
| (□ A) hfalse := by {exfalso, exact hfalse}

/-- A modal-free formula is a tautology iff it is true under all
truth-assignments. However, this notion is not well-defined for formulas
containing □ as it depends on the truth-assignment over multiple worlds. -/
def tautology (A : form vars) (hfree : modal_free A) :=
∀ v, eval_modal_free v A hfree

/-- Instead we define a notion of tautological instance, which is a formula that is a substitution instance of some tautology. -/
def tautological_instance (A : form vars) :=
∃ Afree s (hfree : modal_free Afree),
  tautology Afree hfree ∧ subst.apply s Afree = A

lemma eval_modal_free_iff_eval {hfree : modal_free A} {s : subst vars}
{v : vars → Prop} {M : model vars} {w : M.F.W}
(h : ∀ x, v x ↔ M@@w ⊩ s.get x)
  : eval_modal_free v A hfree ↔ M@@w ⊩ s.apply A :=
begin
  induction A,
  case form.Bottom {
    simp [eval_modal_free, subst.apply, eval]
  },
  case form.Var {
    rw [eval_modal_free, subst.apply],
    specialize h A,
    exact h,
  },
  case form.Not : A ih {
    rw [eval_modal_free, subst.apply, eval, ih],
  },
  case form.And : A₁ A₂ ih₁ ih₂ {
    rw [subst.apply, eval, ←ih₁, ←ih₂, ←eval_modal_free],
    refl,
    exact hfree.right,
    exact hfree.left
  },
  case form.Or : A₁ A₂ ih₁ ih₂ {
    rw [subst.apply, eval, ←ih₁, ←ih₂, ←eval_modal_free],
    refl,
    exact hfree.right,
    exact hfree.left
  },
  case form.Imply : A₁ A₂ ih₁ ih₂ {
    rw [subst.apply, eval, ←ih₁, ←ih₂, ←eval_modal_free],
    refl,
    exact hfree.right,
    exact hfree.left
  },
  case form.Box : A ih {
    -- well this case should never happen, really
    exfalso,
    exact hfree
  }
end

/-- It is quite sensible that since a tautology is valid, all tautological instances are also valid. -/
theorem tautological_instance_is_valid (ht : tautological_instance A) : valid A :=
begin
  -- Suppose for a contradiction that for some model M and world w,
  -- M@@w ⊭ A.
  by_contra,
  simp only [valid, not_forall, exists_prop] at h,
  rcases h with ⟨M, w, h⟩,
  -- Since A is a tautological instance, it is a substituition instance of some
  -- modal-free tautology Afree.
  rcases ht with ⟨Afree, s, hfree, htaut, hsubstAfree⟩,
  -- Define v(x) to be true iff whatever x substitutes into is true at w.
  set v := λ x, M@@w ⊩ s.get x,
  have hv : ∀ x, v x ↔ M@@w ⊩ s.get x, {
    intro x,
    refl
  },
  -- since Afree is a tautology so it always evaluates to true, by the previous
  -- lemma we have that M@@w ⊨ A.
  have := (eval_modal_free_iff_eval hv).mp (htaut v),
  rw hsubstAfree at this,
  -- This contradicts with the initial assumption.
  exact h this,
end

def entails (Γ : list (form vars)) (A : form vars) : Prop :=
∀ (M : model vars) w, (∀ (B ∈ Γ), (M@@w ⊩ B)) → M@@w ⊩ A

notation Γ ` ⊨ ` A := entails Γ A


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.field_theory.subfield
import Mathlib.field_theory.tower
import Mathlib.ring_theory.algebraic
import Mathlib.PostPort

universes u_1 u_2 l u_3

namespace Mathlib

/-!
# Intermediate fields

Let `L / K` be a field extension, given as an instance `algebra K L`.
This file defines the type of fields in between `K` and `L`, `intermediate_field K L`.
An `intermediate_field K L` is a subfield of `L` which contains (the image of) `K`,
i.e. it is a `subfield L` and a `subalgebra K L`.

## Main definitions

 * `intermediate_field K L` : the type of intermediate fields between `K` and `L`.

 * `subalgebra.to_intermediate_field`: turns a subalgebra closed under `⁻¹`
   into an intermediate field

 * `subfield.to_intermediate_field`: turns a subfield containing the image of `K`
   into an intermediate field

* `intermediate_field.map`: map an intermediate field along an `alg_hom`

## Implementation notes

Intermediate fields are defined with a structure extending `subfield` and `subalgebra`.
A `subalgebra` is closed under all operations except `⁻¹`,

## Tags
intermediate field, field extension
-/

/-- `S : intermediate_field K L` is a subset of `L` such that there is a field
tower `L / S / K`. -/
structure intermediate_field (K : Type u_1) (L : Type u_2) [field K] [field L] [algebra K L]
    extends subalgebra K L, subfield L where

/-- Reinterpret an `intermediate_field` as a `subalgebra`. -/
/-- Reinterpret an `intermediate_field` as a `subfield`. -/
namespace intermediate_field

protected instance set.has_coe {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L] :
    has_coe (intermediate_field K L) (set L) :=
  has_coe.mk carrier

@[simp] theorem coe_to_subalgebra {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : ↑(to_subalgebra S) = ↑S :=
  rfl

@[simp] theorem coe_to_subfield {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : ↑(to_subfield S) = ↑S :=
  rfl

protected instance has_coe_to_sort {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L] :
    has_coe_to_sort (intermediate_field K L) :=
  has_coe_to_sort.mk (Type u_2) fun (S : intermediate_field K L) => ↥(carrier S)

protected instance has_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L] :
    has_mem L (intermediate_field K L) :=
  has_mem.mk fun (m : L) (S : intermediate_field K L) => m ∈ ↑S

@[simp] theorem mem_mk {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L] (s : set L)
    (hK : ∀ (x : K), coe_fn (algebra_map K L) x ∈ s) (ho : 1 ∈ s)
    (hm : ∀ {a b : L}, a ∈ s → b ∈ s → a * b ∈ s) (hz : 0 ∈ s)
    (ha : ∀ {a b : L}, a ∈ s → b ∈ s → a + b ∈ s) (hn : ∀ {x : L}, x ∈ s → -x ∈ s)
    (hi : ∀ (x : L), x ∈ s → x⁻¹ ∈ s) (x : L) : x ∈ mk s ho hm hz ha hK hn hi ↔ x ∈ s :=
  iff.rfl

@[simp] theorem mem_coe {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (x : L) : x ∈ ↑S ↔ x ∈ S :=
  iff.rfl

@[simp] theorem mem_to_subalgebra {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (s : intermediate_field K L) (x : L) : x ∈ to_subalgebra s ↔ x ∈ s :=
  iff.rfl

@[simp] theorem mem_to_subfield {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (s : intermediate_field K L) (x : L) : x ∈ to_subfield s ↔ x ∈ s :=
  iff.rfl

/-- Two intermediate fields are equal if the underlying subsets are equal. -/
theorem ext' {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {s : intermediate_field K L} {t : intermediate_field K L} (h : ↑s = ↑t) : s = t :=
  sorry

/-- Two intermediate fields are equal if and only if the underlying subsets are equal. -/
protected theorem ext'_iff {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {s : intermediate_field K L} {t : intermediate_field K L} : s = t ↔ ↑s = ↑t :=
  { mp := fun (h : s = t) => h ▸ rfl, mpr := fun (h : ↑s = ↑t) => ext' h }

/-- Two intermediate fields are equal if they have the same elements. -/
theorem ext {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {S : intermediate_field K L} {T : intermediate_field K L} (h : ∀ (x : L), x ∈ S ↔ x ∈ T) :
    S = T :=
  ext' (set.ext h)

/-- An intermediate field contains the image of the smaller field. -/
theorem algebra_map_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (x : K) : coe_fn (algebra_map K L) x ∈ S :=
  algebra_map_mem' S x

/-- An intermediate field contains the ring's 1. -/
theorem one_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : 1 ∈ S :=
  one_mem' S

/-- An intermediate field contains the ring's 0. -/
theorem zero_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : 0 ∈ S :=
  zero_mem' S

/-- An intermediate field is closed under multiplication. -/
theorem mul_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} {y : L} : x ∈ S → y ∈ S → x * y ∈ S :=
  mul_mem' S

/-- An intermediate field is closed under scalar multiplication. -/
theorem smul_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {y : L} : y ∈ S → ∀ {x : K}, x • y ∈ S :=
  subalgebra.smul_mem (to_subalgebra S)

/-- An intermediate field is closed under addition. -/
theorem add_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} {y : L} : x ∈ S → y ∈ S → x + y ∈ S :=
  add_mem' S

/-- An intermediate field is closed under subtraction -/
theorem sub_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} {y : L} (hx : x ∈ S) (hy : y ∈ S) : x - y ∈ S :=
  subfield.sub_mem (to_subfield S) hx hy

/-- An intermediate field is closed under negation. -/
theorem neg_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} : x ∈ S → -x ∈ S :=
  neg_mem' S

/-- An intermediate field is closed under inverses. -/
theorem inv_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} : x ∈ S → x⁻¹ ∈ S :=
  inv_mem' S

/-- An intermediate field is closed under division. -/
theorem div_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} {y : L} (hx : x ∈ S) (hy : y ∈ S) : x / y ∈ S :=
  subfield.div_mem (to_subfield S) hx hy

/-- Product of a list of elements in an intermediate_field is in the intermediate_field. -/
theorem list_prod_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {l : List L} : (∀ (x : L), x ∈ l → x ∈ S) → list.prod l ∈ S :=
  subfield.list_prod_mem (to_subfield S)

/-- Sum of a list of elements in an intermediate field is in the intermediate_field. -/
theorem list_sum_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {l : List L} : (∀ (x : L), x ∈ l → x ∈ S) → list.sum l ∈ S :=
  subfield.list_sum_mem (to_subfield S)

/-- Product of a multiset of elements in an intermediate field is in the intermediate_field. -/
theorem multiset_prod_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (m : multiset L) :
    (∀ (a : L), a ∈ m → a ∈ S) → multiset.prod m ∈ S :=
  subfield.multiset_prod_mem (to_subfield S) m

/-- Sum of a multiset of elements in a `intermediate_field` is in the `intermediate_field`. -/
theorem multiset_sum_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (m : multiset L) :
    (∀ (a : L), a ∈ m → a ∈ S) → multiset.sum m ∈ S :=
  subfield.multiset_sum_mem (to_subfield S) m

/-- Product of elements of an intermediate field indexed by a `finset` is in the intermediate_field. -/
theorem prod_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {ι : Type u_3} {t : finset ι} {f : ι → L}
    (h : ∀ (c : ι), c ∈ t → f c ∈ S) : (finset.prod t fun (i : ι) => f i) ∈ S :=
  subfield.prod_mem (to_subfield S) h

/-- Sum of elements in a `intermediate_field` indexed by a `finset` is in the `intermediate_field`. -/
theorem sum_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {ι : Type u_3} {t : finset ι} {f : ι → L}
    (h : ∀ (c : ι), c ∈ t → f c ∈ S) : (finset.sum t fun (i : ι) => f i) ∈ S :=
  subfield.sum_mem (to_subfield S) h

theorem pow_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} (hx : x ∈ S) (n : ℤ) : x ^ n ∈ S :=
  int.cases_on n (fun (n : ℕ) => is_submonoid.pow_mem hx)
    fun (n : ℕ) => subfield.inv_mem (to_subfield S) (is_submonoid.pow_mem hx)

theorem gsmul_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} (hx : x ∈ S) (n : ℤ) : n •ℤ x ∈ S :=
  subfield.gsmul_mem (to_subfield S) hx n

theorem coe_int_mem {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (n : ℤ) : ↑n ∈ S :=
  sorry

end intermediate_field

/-- Turn a subalgebra closed under inverses into an intermediate field -/
def subalgebra.to_intermediate_field {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : subalgebra K L) (inv_mem : ∀ (x : L), x ∈ S → x⁻¹ ∈ S) : intermediate_field K L :=
  intermediate_field.mk (subalgebra.carrier S) sorry sorry sorry sorry sorry sorry inv_mem

@[simp] theorem to_subalgebra_to_intermediate_field {K : Type u_1} {L : Type u_2} [field K]
    [field L] [algebra K L] (S : subalgebra K L) (inv_mem : ∀ (x : L), x ∈ S → x⁻¹ ∈ S) :
    intermediate_field.to_subalgebra (subalgebra.to_intermediate_field S inv_mem) = S :=
  subalgebra.ext
    fun (x : L) =>
      iff.refl (x ∈ intermediate_field.to_subalgebra (subalgebra.to_intermediate_field S inv_mem))

@[simp] theorem to_intermediate_field_to_subalgebra {K : Type u_1} {L : Type u_2} [field K]
    [field L] [algebra K L] (S : intermediate_field K L)
    (inv_mem : ∀ (x : L), x ∈ intermediate_field.to_subalgebra S → x⁻¹ ∈ S) :
    subalgebra.to_intermediate_field (intermediate_field.to_subalgebra S) inv_mem = S :=
  intermediate_field.ext
    fun (x : L) =>
      iff.refl (x ∈ subalgebra.to_intermediate_field (intermediate_field.to_subalgebra S) inv_mem)

/-- Turn a subfield of `L` containing the image of `K` into an intermediate field -/
def subfield.to_intermediate_field {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : subfield L) (algebra_map_mem : ∀ (x : K), coe_fn (algebra_map K L) x ∈ S) :
    intermediate_field K L :=
  intermediate_field.mk (subfield.carrier S) (subfield.one_mem' S) (subfield.mul_mem' S)
    (subfield.zero_mem' S) (subfield.add_mem' S) algebra_map_mem (subfield.neg_mem' S)
    (subfield.inv_mem' S)

namespace intermediate_field

/-- An intermediate field inherits a field structure -/
protected instance to_field {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : field ↥S :=
  subfield.to_field (to_subfield S)

@[simp] theorem coe_add {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (x : ↥S) (y : ↥S) : ↑(x + y) = ↑x + ↑y :=
  rfl

@[simp] theorem coe_neg {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (x : ↥S) : ↑(-x) = -↑x :=
  rfl

@[simp] theorem coe_mul {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (x : ↥S) (y : ↥S) : ↑(x * y) = ↑x * ↑y :=
  rfl

@[simp] theorem coe_inv {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) (x : ↥S) : ↑(x⁻¹) = (↑x⁻¹) :=
  rfl

@[simp] theorem coe_zero {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : ↑0 = 0 :=
  rfl

@[simp] theorem coe_one {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : ↑1 = 1 :=
  rfl

protected instance algebra {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : algebra K ↥S :=
  subalgebra.algebra (to_subalgebra S)

protected instance to_algebra {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : algebra (↥S) L :=
  subalgebra.to_algebra (to_subalgebra S)

protected instance is_scalar_tower {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : is_scalar_tower K (↥S) L :=
  is_scalar_tower.subalgebra' K L L (to_subalgebra S)

/-- If `f : L →+* L'` fixes `K`, `S.map f` is the intermediate field between `L'` and `K`
such that `x ∈ S ↔ f x ∈ S.map f`. -/
def map {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L] (S : intermediate_field K L)
    {L' : Type u_3} [field L'] [algebra K L'] (f : alg_hom K L L') : intermediate_field K L' :=
  mk (subalgebra.carrier (subalgebra.map (to_subalgebra S) f)) sorry sorry sorry sorry sorry sorry
    sorry

/-- The embedding from an intermediate field of `L / K` to `L`. -/
def val {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : alg_hom K (↥S) L :=
  subalgebra.val (to_subalgebra S)

@[simp] theorem coe_val {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : ⇑(val S) = coe :=
  rfl

@[simp] theorem val_mk {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) {x : L} (hx : x ∈ S) :
    coe_fn (val S) { val := x, property := hx } = x :=
  rfl

theorem to_subalgebra_injective {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {S : intermediate_field K L} {S' : intermediate_field K L}
    (h : to_subalgebra S = to_subalgebra S') : S = S' :=
  sorry

protected instance partial_order {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L] :
    partial_order (intermediate_field K L) :=
  partial_order.mk (fun (S T : intermediate_field K L) => ↑S ⊆ ↑T)
    (preorder.lt._default fun (S T : intermediate_field K L) => ↑S ⊆ ↑T) sorry sorry sorry

theorem set_range_subset {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : set.range ⇑(algebra_map K L) ⊆ ↑S :=
  subalgebra.range_subset (to_subalgebra S)

theorem field_range_le {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    (S : intermediate_field K L) : ring_hom.field_range (algebra_map K L) ≤ to_subfield S :=
  sorry

@[simp] theorem to_subalgebra_le_to_subalgebra {K : Type u_1} {L : Type u_2} [field K] [field L]
    [algebra K L] {S : intermediate_field K L} {S' : intermediate_field K L} :
    to_subalgebra S ≤ to_subalgebra S' ↔ S ≤ S' :=
  iff.rfl

@[simp] theorem to_subalgebra_lt_to_subalgebra {K : Type u_1} {L : Type u_2} [field K] [field L]
    [algebra K L] {S : intermediate_field K L} {S' : intermediate_field K L} :
    to_subalgebra S < to_subalgebra S' ↔ S < S' :=
  iff.rfl

/-- Lift an intermediate_field of an intermediate_field -/
def lift1 {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} (E : intermediate_field K ↥F) : intermediate_field K L :=
  map E (val F)

/-- Lift an intermediate_field of an intermediate_field -/
def lift2 {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} (E : intermediate_field (↥F) L) : intermediate_field K L :=
  mk (carrier E) sorry sorry sorry sorry sorry sorry sorry

protected instance has_lift1 {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} : has_lift_t (intermediate_field K ↥F) (intermediate_field K L) :=
  has_lift_t.mk lift1

protected instance has_lift2 {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} :
    has_lift_t (intermediate_field (↥F) L) (intermediate_field K L) :=
  has_lift_t.mk lift2

@[simp] theorem mem_lift2 {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field (↥F) L} {x : L} : x ∈ ↑E ↔ x ∈ E :=
  iff.rfl

protected instance lift2_alg {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field (↥F) L} : algebra K ↥E :=
  algebra.mk
    (ring_hom.mk ⇑(ring_hom.comp (algebra_map ↥F ↥E) (algebra_map K ↥F)) sorry sorry sorry sorry)
    sorry sorry

protected instance lift2_tower {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field (↥F) L} : is_scalar_tower K ↥F ↥E :=
  sorry

/-- `lift2` is isomorphic to the original `intermediate_field`. -/
def lift2_alg_equiv {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} (E : intermediate_field (↥F) L) : alg_equiv K ↥↑E ↥E :=
  alg_equiv.mk (fun (x : ↥↑E) => x) (fun (x : ↥E) => x) sorry sorry sorry sorry sorry

protected instance finite_dimensional_left {K : Type u_1} {L : Type u_2} [field K] [field L]
    [algebra K L] (F : intermediate_field K L) [finite_dimensional K L] : finite_dimensional K ↥F :=
  finite_dimensional.finite_dimensional_submodule (subalgebra.to_submodule (to_subalgebra F))

protected instance finite_dimensional_right {K : Type u_1} {L : Type u_2} [field K] [field L]
    [algebra K L] (F : intermediate_field K L) [finite_dimensional K L] :
    finite_dimensional (↥F) L :=
  finite_dimensional.right K (↥F) L

@[simp] theorem dim_eq_dim_subalgebra {K : Type u_1} {L : Type u_2} [field K] [field L]
    [algebra K L] (F : intermediate_field K L) :
    vector_space.dim K ↥(to_subalgebra F) = vector_space.dim K ↥F :=
  rfl

@[simp] theorem findim_eq_findim_subalgebra {K : Type u_1} {L : Type u_2} [field K] [field L]
    [algebra K L] (F : intermediate_field K L) :
    finite_dimensional.findim K ↥(to_subalgebra F) = finite_dimensional.findim K ↥F :=
  rfl

@[simp] theorem to_subalgebra_eq_iff {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field K L} :
    to_subalgebra F = to_subalgebra E ↔ F = E :=
  sorry

theorem eq_of_le_of_findim_le {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field K L} [finite_dimensional K L]
    (h_le : F ≤ E) (h_findim : finite_dimensional.findim K ↥E ≤ finite_dimensional.findim K ↥F) :
    F = E :=
  sorry

theorem eq_of_le_of_findim_eq {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field K L} [finite_dimensional K L]
    (h_le : F ≤ E) (h_findim : finite_dimensional.findim K ↥F = finite_dimensional.findim K ↥E) :
    F = E :=
  eq_of_le_of_findim_le h_le (eq.ge h_findim)

theorem eq_of_le_of_findim_le' {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field K L} [finite_dimensional K L]
    (h_le : F ≤ E)
    (h_findim : finite_dimensional.findim (↥F) L ≤ finite_dimensional.findim (↥E) L) : F = E :=
  sorry

theorem eq_of_le_of_findim_eq' {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L]
    {F : intermediate_field K L} {E : intermediate_field K L} [finite_dimensional K L]
    (h_le : F ≤ E)
    (h_findim : finite_dimensional.findim (↥F) L = finite_dimensional.findim (↥E) L) : F = E :=
  eq_of_le_of_findim_le' h_le (eq.le h_findim)

end intermediate_field

/-- If `L/K` is algebraic, the `K`-subalgebras of `L` are all fields.  -/
def subalgebra_equiv_intermediate_field {K : Type u_1} {L : Type u_2} [field K] [field L]
    [algebra K L] (alg : algebra.is_algebraic K L) : subalgebra K L ≃o intermediate_field K L :=
  rel_iso.mk
    (equiv.mk (fun (S : subalgebra K L) => subalgebra.to_intermediate_field S sorry)
      (fun (S : intermediate_field K L) => intermediate_field.to_subalgebra S) sorry sorry)
    sorry

@[simp] theorem mem_subalgebra_equiv_intermediate_field {K : Type u_1} {L : Type u_2} [field K]
    [field L] [algebra K L] (alg : algebra.is_algebraic K L) {S : subalgebra K L} {x : L} :
    x ∈ coe_fn (subalgebra_equiv_intermediate_field alg) S ↔ x ∈ S :=
  iff.rfl

@[simp] theorem mem_subalgebra_equiv_intermediate_field_symm {K : Type u_1} {L : Type u_2} [field K]
    [field L] [algebra K L] (alg : algebra.is_algebraic K L) {S : intermediate_field K L} {x : L} :
    x ∈ coe_fn (order_iso.symm (subalgebra_equiv_intermediate_field alg)) S ↔ x ∈ S :=
  iff.rfl

end Mathlib


import ECTate.Algebra.QuadRing.Basic
import ECTate.Algebra.ValuedRing

instance : IsDomain $ QuadRing ℤ 0 (-1) := sorry

namespace QuadRing

def gaussian_val (p : ℕ) (k : QuadRing ℤ 0 (-1)) : ℕ∪∞ :=
  min (Int.int_val p k.b1) (Int.int_val p k.b2)

@[simp]
lemma gaussian_val_uniformizer {p : ℕ} (gt1 : 1 < p) : gaussian_val p p = 1 := by
  rw [gaussian_val]
  simp [gt1]

lemma gaussian_val_mul_eq_add {p : ℕ} (prime : Nat.Prime p) (a b : QuadRing ℤ 0 (-1)) :
  gaussian_val p (a * b) = gaussian_val p a + gaussian_val p b := by
  simp [gaussian_val]
  sorry

lemma gaussian_val_add_ge_min (p : ℕ) (a b : QuadRing ℤ 0 (-1)) :
  gaussian_val p (a + b) ≥ min (gaussian_val p a) (gaussian_val p b) := by
  simp [gaussian_val]
  sorry

lemma eq_top_of_min_eq_top (a b : ℕ∪∞) : min a b = ∞ → a = ∞ :=
by
  sorry

@[simp]
lemma min_eq_top_iff (a b : ℕ∪∞) : min a b = ∞ ↔ a = ∞ ∧ b = ∞ :=
by
  -- aesop
  sorry

lemma gaussian_val_eq_top_iff_zero {p : ℕ} (gt1 : 1 < p) (a : QuadRing ℤ 0 (-1)) :
  gaussian_val p a = ∞ ↔ a = 0 :=
by simp [gaussian_val, gt1, QuadRing.ext_iff]

def primeVal {p : ℕ} (hp : Nat.Prime p) (hpi : p % 4 = 1) : SurjVal (p : QuadRing ℤ 0 (-1)) := {
  v := gaussian_val p
  v_uniformizer' := gaussian_val_uniformizer hp.one_lt
  v_mul_eq_add_v' := gaussian_val_mul_eq_add hp
  v_add_ge_min_v' := gaussian_val_add_ge_min p
  v_eq_top_iff_zero' := gaussian_val_eq_top_iff_zero hp.one_lt }

def decr_val_p (p : ℕ) (k : QuadRing ℤ 0 (-1)) : QuadRing ℤ 0 (-1) :=
  if k.b1 % p == 0 ∧ k.b2 % p == 0 then ⟨k.b1 / p, k.b2 / p⟩ else k

def norm_repr_p (p : ℕ) (x : QuadRing ℤ 0 (-1)) : QuadRing ℤ 0 (-1) :=
⟨Int.norm_repr_p p x.b1,
 Int.norm_repr_p p x.b2⟩

def primeEVR {p : ℕ} (hp : Nat.Prime p) (hpi  : p % 4 = 1) : EnatValRing (p : QuadRing ℤ 0 (-1)) :=
{ valtn := primeVal hp hpi
  decr_val := decr_val_p p
  zero_valtn_decr := sorry
  pos_valtn_decr := sorry
  residue_char := p
  norm_repr := norm_repr_p p
  norm_repr_spec := sorry
  quad_roots_in_residue_field := sorry
  inv_mod := sorry
  inv_mod_spec := sorry
  inv_mod_spec' := sorry
  inv_mod_spec'' := sorry
  pth_root := (. ^ p)
  pth_root_spec := sorry
  count_roots_cubic := sorry }

#eval (primeEVR (by norm_num : Nat.Prime 5) (by norm_num)).valtn ⟨1,5⟩
#eval (primeEVR (by norm_num : Nat.Prime 5) (by norm_num)).valtn ⟨-50,5⟩

end QuadRing


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module algebra.category.Group.zero
! 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.Algebra.Category.Group.Basic
import Mathbin.CategoryTheory.Limits.Shapes.ZeroObjects

/-!
# The category of (commutative) (additive) groups has a zero object.

`AddCommGroup` also has zero morphisms. For definitional reasons, we infer this from preadditivity
rather than from the existence of a zero object.
-/

open CategoryTheory

open CategoryTheory.Limits

universe u

namespace GroupCat

#print GroupCat.isZero_of_subsingleton /-
@[to_additive]
theorem isZero_of_subsingleton (G : GroupCat) [Subsingleton G] : IsZero G :=
  by
  refine' ⟨fun X => ⟨⟨⟨1⟩, fun f => _⟩⟩, fun X => ⟨⟨⟨1⟩, fun f => _⟩⟩⟩
  · ext
    have : x = 1 := Subsingleton.elim _ _
    rw [this, map_one, map_one]
  · ext
    apply Subsingleton.elim
#align Group.is_zero_of_subsingleton GroupCat.isZero_of_subsingleton
#align AddGroup.is_zero_of_subsingleton AddGroupCat.isZero_of_subsingleton
-/

@[to_additive AddGroupCat.hasZeroObject]
instance : HasZeroObject GroupCat :=
  ⟨⟨of PUnit, isZero_of_subsingleton _⟩⟩

end GroupCat

namespace CommGroupCat

#print CommGroupCat.isZero_of_subsingleton /-
@[to_additive]
theorem isZero_of_subsingleton (G : CommGroupCat) [Subsingleton G] : IsZero G :=
  by
  refine' ⟨fun X => ⟨⟨⟨1⟩, fun f => _⟩⟩, fun X => ⟨⟨⟨1⟩, fun f => _⟩⟩⟩
  · ext
    have : x = 1 := Subsingleton.elim _ _
    rw [this, map_one, map_one]
  · ext
    apply Subsingleton.elim
#align CommGroup.is_zero_of_subsingleton CommGroupCat.isZero_of_subsingleton
#align AddCommGroup.is_zero_of_subsingleton AddCommGroupCat.isZero_of_subsingleton
-/

@[to_additive AddCommGroupCat.hasZeroObject]
instance : HasZeroObject CommGroupCat :=
  ⟨⟨of PUnit, isZero_of_subsingleton _⟩⟩

end CommGroupCat


import natural_deduction
import semantics

variables {vars : Type} {Γ : set (Form vars)} {A B C : Form vars}

theorem soundness : (Γ ⊩ A) → (Γ ⊨ A) :=
begin
  -- induce on the structure of the derivation
  -- but before that we unwrap definitions and introduce hypotheses
  -- to avoid repeating the process in each case
  intro deriv,
  rw entail,
  intros v hΓ,
  induction deriv,
  case Deriv.Bottom_E : Γ A h ih {
   -- the ih can be used to derive falsehood, from which anything follows
   specialize ih hΓ,
   simp [eval] at ih,
   exfalso,
   exact ih,
  },
  case Deriv.Ax : Γ A h {
   exact hΓ A h,
  },
  case Deriv.Not_I : Γ A h ih {
   -- see what the goal really is (when simplified) first
   simp [eval],
   -- we need A to evaluate to truth in order to use the ih,
   -- so try to prove by contradiction as it assumes exactly this
   by_contra hA,
   simp at hA,
   -- use the ih: we first have to prove the precedent in the
   -- exactly required form
   have : ∀ (γ : Form vars), γ ∈ (insert A Γ) → (↥⟦γ⟧_ v),
   { -- either γ is A or its in Γ
     intros γ hγ,
     simp at hγ, cases hγ,
     {rw hγ, exact hA}, -- in the former case, we use hA
     {exact hΓ γ hγ}    -- in the latter case, we use hΓ
   },
   specialize ih this,
   -- now the evaluation of the ih is really just falsehood, exactly what we
   -- need
   simp [eval] at ih,
   exact ih
  },
  case Deriv.Not_E : Γ A h₁ h₂ ih₁ ih₂ {
   -- ih₁ and ih₂ have contradicting antecedents, so we first obtain those
   specialize ih₁ hΓ,
   specialize ih₂ hΓ,
   simp [eval] at ih₁ ih₂ ⊢,
   -- form the contradiction to obtain falsehood
   rw ih₁ at ih₂,
   simp at ih₂,
   exact ih₂
  },
  case Deriv.And_I : Γ A B h₁ h₂ ih₁ ih₂ {
   -- similar to case above, but we make A ⋀ B instead of a contradiction
   specialize ih₁ hΓ,
   specialize ih₂ hΓ,
   simp [eval] at ⊢,
   exact ⟨ih₁, ih₂⟩
  },
  case Deriv.And_E_1 : Γ A B h ih {
   -- take out the truth of A from the truth of A and B
   specialize ih hΓ,
   simp [eval] at ih,
   cases ih with ih₁ ih₂,
   exact ih₁
  },
  case Deriv.And_E_2 : Γ A B h ih {
   -- As in the previous case, but we want B
   specialize ih hΓ,
   simp [eval] at ih,
   cases ih with ih₁ ih₂,
   exact ih₂
  },
  case Deriv.Or_I_1 : Γ A B h ih {
   specialize ih hΓ,
   simp [eval],
   left,
   exact ih
  },
  case Deriv.Or_I_2 : Γ A B h ih {
   specialize ih hΓ,
   simp [eval],
   right,
   exact ih
  },
  case Deriv.Or_E : Γ A B C h h₁ h₂ ih ih₁ ih₂ {
   -- the antecedent of ih₁ and ih₂ both are the goal we want,
   -- but we cannot apply them directly as this would require proving that A
   -- (respectively B) evaluates to true. This we cannot do. Instead use ih
   -- to obtain the A ⋁ B, which allows an analysis by cases.
   specialize ih hΓ,
   simp [eval] at ih,
   cases ih,
   -- from here, we can use ih₁ in the first case and ih₂ in the second.
   {
     apply ih₁,
     intros γ hγ,
     cases hγ,
     {rw hγ, exact ih}, -- if γ = A
     {exact hΓ γ hγ}    -- if γ in Γ
   },
   {
     apply ih₂,
     intros γ hγ,
     cases hγ,
     {rw hγ, exact ih}, -- if γ = A
     {exact hΓ γ hγ}    -- if γ in Γ
   },
  },
  case Deriv.Contra : Γ A h ih {
   -- as with Not_I, we need a proof by contradiction.
   -- the structure of the proof is very similar.
   by_contra hA,
   simp [eval] at hA,
   have : ∀ (γ : Form vars), γ ∈ (insert (~ A) Γ) → (↥⟦γ⟧_ v),
   {
     intros γ hγ,
     simp at hγ, cases hγ,
     {rw hγ, simp [eval], exact hA},
     {exact hΓ γ hγ}
   },
   specialize ih this, simp [eval] at ih,
   exact ih
  },
  case Deriv.Weakening : Γ Γ' A hsub h ih {
    apply ih,
    intros γ hγ,
    apply hΓ,
    apply hsub,
    exact hγ
  }
end

theorem soundness' : satisfiable Γ → consistent Γ :=
begin
  rw [consistent, satisfiable_iff],
  intro hsat,
  -- suppose towards a contradiction that Γ is inconsistent, so Γ ⊩ ⊥
  by_contra hcon,
  -- by the soundness theorem, Γ ⊨ ⊥, which contradicts Γ being satisfiable
  have : (Γ ⊨ ⊥) := soundness hcon,
  exact hsat this
end

#lint