/-
Copyright (c) 2023 Huub Vromen. All rights reserved.
Author: Huub Vromen
-/

/- This is a formalisation of Aristotle's assertoric (non-modal) syllogistic.
   We start with a syntactical account (language and proof system).
   After that, in the other files, three differrent semantics are presented,
   each with a proof of soundness of the proof system. -/

variable {term : Type}                     -- type for terms
variables {A B C P S M: term}
constants {a e i o : term → term → Prop}

infixr ` a ` : 80 := a
infixr ` e ` : 80 := e
infixr ` i ` : 80 := i
infixr ` o ` : 80 := o

-- the 'contradictories'
constant c : Prop → Prop
axiom contr_a : c (A a B) = A o B
axiom contr_e : c (A e B) = A i B
axiom contr_i : c (A i B) = A e B
axiom contr_o : c (A o B) = A a B

/-- The deductive system that follows Aristotle's text as closely as possible
    uses eight axioms / deduction rules. (Smith 1989 pp. xix-xx)  -/

-- four 'perfect' syllogisms (we use the traditional medieval names)
axiom Barbara₁ : P a M → M a S → P a S
axiom Celarent₁ : P e M → M a S → P e S
axiom Darii₁ : P a M → M i S → P i S
axiom Ferio₁ : P e M → M i S → P o S

-- three conversion rules
axiom e_conv : A e B → B e A      --   simple e_conversion
axiom i_conv : A i B → B i A      --   simple i_conversion
axiom a_conv : A a B → B i A      --   accidental a_conversion

-- reductio ad absurdum
axiom contr {p r : Prop} : (c r → c p) → p → r

/-- Aristotle does not use 'extended' deductions, i.e. he does not use already
    proved theorems but only axioms. The following proofs follow Aristotle's text as closely as
    possible. -/

-- four second-figure syllogisms
lemma Cesare₂ (h1: M e P) (h2 : M a S) : P e S :=
   Celarent₁ (e_conv h1) h2

lemma Camestres₂ (h1: M a P) (h2 : M e S) : P e S :=
   e_conv (Celarent₁ (e_conv h2) h1)

lemma Festino₂ (h1: M e P) (h2 : M i S) : P o S :=
   Ferio₁ (e_conv h1) h2

lemma Baroco₂ (h1: M a P) (h2 : M o S) : P o S :=
begin
have h3 : c (P o S) → c (M o S) :=
   begin
      intro h4,
      rw contr_o at *,
      exact Barbara₁ h1 h4,
   end,
exact contr h3 h2,
end

-- six third-figure syllogisms  -/
lemma Darapti₃ (h1 : P a M) (h2 : S a M) : P i S :=
   Darii₁ h1 (a_conv h2)

lemma Felapton₃ (h1 : P e M) (h2 : S a M) : P o S :=
   Ferio₁ h1 (a_conv h2)

lemma Disamis₃ (h1 : P i M) (h2 : S a M) : P i S :=
   i_conv (Darii₁ h2 (i_conv h1))

lemma Datisi₃ (h1 : P a M) (h2 : S i M) : P i S :=
   Darii₁ h1 (i_conv h2)

lemma Bocardo₃ (h1 : P o M) (h2 : S a M) : P o S :=
begin
have h3 : c (P o S) → c (P o M) :=
   begin
      intro h4,
      rw contr_o at *,
      exact Barbara₁ h4 h2,
   end,
exact contr h3 h1,
end

lemma Ferison₃ (h1 : P e M) (h2 : S i M) : P o S :=
   Ferio₁ h1 (i_conv h2)

/-- Up to now, we have 14 valid syllogisms. There are 10 more.
    First, we prove the four subaltern syllogisms.
    In order to prove them, we first prove a helpful lemma. -/

lemma subaltrn_e : A e B → A o B :=       --   accidental e_conversion
begin
intro h,
have h3 : c (A o B) → c (A e B) :=
   begin
      intro h4,
      rw contr_e, rw contr_o at h4,
      exact i_conv (a_conv h4),
   end,
exact contr h3 h,
end

-- the two subaltern first-figure syllogisms
lemma Barbari (h1: P a M) (h2 : M a S) : P i S :=
   i_conv (a_conv (Barbara₁ h1 h2))

lemma Celaront (h1: P e M) (h2 : M a S) : P o S :=
   subaltrn_e (Celarent₁ h1 h2)

-- the two subaltern second-figure syllogisms
lemma Cesaro₂ (h1: M e P) (h2 : M a S) : P o S :=
   subaltrn_e (Celarent₁ (e_conv h1) h2)

lemma Camestrop₂ (h1: M a P) (h2 : M e S) : P o S :=
   subaltrn_e (e_conv (Celarent₁ (e_conv h2) h1))

/-- Second, we prove the six fourth-figure syllogisms -/

lemma Bramantip₄ (h1 : M a P) (h2 : C a M) : P i C :=
   a_conv (Barbara₁ h2 h1)

lemma Camenes₄ (h1 : M a P) (h2 : C e M) : P e C :=
   e_conv(Celarent₁ h2 h1)

lemma Dimaris₄ (h1 : M i P) (h2 : C a M) : P i C :=
   i_conv(Darii₁ h2 h1)

lemma Fesapo₄ (h1 : M e P) (h2 : C a M) : P o C :=
   Ferio₁ (e_conv h1) (a_conv h2)

lemma Fresison₄ (h1 : M e P) (h2 : C i M) : P o C :=
   Festino₂ h1 (i_conv h2)

lemma Camenop₄ (h1 : M a P) (h2 : C e M) : P o C :=
   subaltrn_e (e_conv(Celarent₁ h2 h1))

/-- Metalogical observations. The proof system is redundant. Aristotle already
    mentioned that Darii₁ and Ferio₁ do not have to be assumed as axioms,
    but can be derived from Barbara₁ and Celarent₁ (An. Pr. 29b1-2]
    in Smith, 1989). This is proven below.   -/

lemma Darii (h1 : P a M) (h2 : M i S) : P i S :=
begin
have h3 : c (P i S) → c (M i S) :=
   begin
      intro h4,
      rw contr_i at *,
      exact e_conv (Celarent₁ (e_conv h4) h1),
   end,
exact contr h3 h2,
end

lemma Ferio (h1 : P e M) (h2 : M i S) : P o S :=
begin
have h3 : c (P o S) → c (M i S) :=
   begin
      intro h4,
      rw contr_i, rw contr_o at h4,
      exact Celarent₁ (e_conv h1) h4,
   end,
exact contr h3 h2,
end

/-- It is even possible to derive rule i_conv from the other rules (25a22) -/

lemma i_conv_deduction : A i B → B i A :=
begin
intro h3,
have h4 : c (B i A) → c (A i B) :=
   begin
      intro h5,
      rw contr_i at *,
      exact e_conv h5
   end,
exact contr h4 h3,
end

/- So, Barbara₁ and Celarent₁ together with e-conv and a-conv and contr
    suffice to prove all 24 valid syllogisms.
    We will refer to this system by the name `DR` in the semantics files.   -/

/- ************** ideas for further research ****************
Aristotle argued for the invalidity of all other syllogisms by semantical means,
i.e. by providing counterexamples. I would like to prove that all invalid syllogisms
cannot be derived; therefore:
a. To show that there are exactly 256 syllogisms, I will have to give an inductive
   definition of a syllogism.
b. Then select some rules that are sufficient to refute all invalid syllogisms;
   see, for instance, van Rooij (2020, p.187).
c. Finally, investigate if it is possible to prove these rules in our proof system.
-/


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

! This file was ported from Lean 3 source module topology.algebra.equicontinuity
! leanprover-community/mathlib commit 01ad394a11bf06b950232720cf7e8fc6b22f0d6a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Algebra.UniformConvergence

/-!
# Algebra-related equicontinuity criterions
-/

open Function

open UniformConvergence

@[to_additive]
theorem equicontinuous_of_equicontinuousAt_one {ι G M hom : Type _} [TopologicalSpace G]
    [UniformSpace M] [Group G] [Group M] [TopologicalGroup G] [UniformGroup M]
    [MonoidHomClass hom G M] (F : ι → hom) (hf : EquicontinuousAt (coeFn ∘ F) (1 : G)) :
    Equicontinuous (coeFn ∘ F) :=
  by
  letI : CoeFun hom fun _ => G → M := FunLike.hasCoeToFun
  rw [equicontinuous_iff_continuous]
  rw [equicontinuousAt_iff_continuousAt] at hf
  let φ : G →* ι → M :=
    { toFun := swap (coeFn ∘ F)
      map_one' := by ext <;> exact map_one _
      map_mul' := fun a b => by ext <;> exact map_mul _ _ _ }
  exact continuous_of_continuousAt_one φ hf
#align equicontinuous_of_equicontinuous_at_one equicontinuous_of_equicontinuousAt_one
#align equicontinuous_of_equicontinuous_at_zero equicontinuous_of_equicontinuous_at_zero

@[to_additive]
theorem uniformEquicontinuous_of_equicontinuousAt_one {ι G M hom : Type _} [UniformSpace G]
    [UniformSpace M] [Group G] [Group M] [UniformGroup G] [UniformGroup M] [MonoidHomClass hom G M]
    (F : ι → hom) (hf : EquicontinuousAt (coeFn ∘ F) (1 : G)) : UniformEquicontinuous (coeFn ∘ F) :=
  by
  letI : CoeFun hom fun _ => G → M := FunLike.hasCoeToFun
  rw [uniformEquicontinuous_iff_uniformContinuous]
  rw [equicontinuousAt_iff_continuousAt] at hf
  let φ : G →* ι → M :=
    { toFun := swap (coeFn ∘ F)
      map_one' := by ext <;> exact map_one _
      map_mul' := fun a b => by ext <;> exact map_mul _ _ _ }
  exact uniformContinuous_of_continuousAt_one φ hf
#align uniform_equicontinuous_of_equicontinuous_at_one uniformEquicontinuous_of_equicontinuousAt_one
#align uniform_equicontinuous_of_equicontinuous_at_zero uniform_equicontinuous_of_equicontinuous_at_zero


import tactic.noncomm_ring

local notation `⁅`a`,` b`⁆` := a * b - b * a
local infix ` ⚬ `:70 := λ a b, a * b + b * a

variables {R : Type*} [ring R]
variables (a b c : R)

example : 0 = 0 := by noncomm_ring
example : a = a := by noncomm_ring

example : (a + b) * c = a * c + b * c := by noncomm_ring
example : a * (b + c) = a * b + a * c := by noncomm_ring
example : a - b = a + -b := by noncomm_ring
example : a * b * c = a * (b * c) := by noncomm_ring
example : a + a = a * 2 := by noncomm_ring
example : a + a = 2 * a := by noncomm_ring
example : -a = (-1) * a := by noncomm_ring
example : a + a + a = 3 * a := by noncomm_ring
example : a ^ 2 = a * a := by noncomm_ring
example : a ^ 3 = a * a * a := by noncomm_ring
example : (-a) * b = -(a * b) := by noncomm_ring
example : a * (-b) = -(a * b) := by noncomm_ring
example : a * (b + c + b + c - 2*b) = 2*a*c := by noncomm_ring
example : (a + b)^2 = a^2 + a*b + b*a + b^2 := by noncomm_ring
example : (a - b)^2 = a^2 - a*b - b*a + b^2 := by noncomm_ring
example : (a + b)^3 = a^3 + a^2*b + a*b*a + a*b^2 + b*a^2 + b*a*b + b^2*a + b^3 := by noncomm_ring
example : (a - b)^3 = a^3 - a^2*b - a*b*a + a*b^2 - b*a^2 + b*a*b + b^2*a - b^3 := by noncomm_ring

example : ⁅a, a⁆ = 0 := by noncomm_ring
example : ⁅a, b⁆ = -⁅b, a⁆ := by noncomm_ring
example : ⁅a + b, c⁆ = ⁅a, c⁆ + ⁅b, c⁆ := by noncomm_ring
example : ⁅a, b + c⁆ = ⁅a, b⁆ + ⁅a, c⁆ := by noncomm_ring
example : ⁅a, ⁅b, c⁆⁆ + ⁅b, ⁅c, a⁆⁆ + ⁅c, ⁅a, b⁆⁆ = 0 := by noncomm_ring
example : ⁅⁅a, b⁆, c⁆ + ⁅⁅b, c⁆, a⁆ + ⁅⁅c, a⁆, b⁆ = 0 := by noncomm_ring
example : ⁅a, ⁅b, c⁆⁆ = ⁅⁅a, b⁆, c⁆ + ⁅b, ⁅a, c⁆⁆ := by noncomm_ring
example : ⁅⁅a, b⁆, c⁆ = ⁅⁅a, c⁆, b⁆ + ⁅a, ⁅b, c⁆⁆ := by noncomm_ring
example : ⁅a * b, c⁆ = a * ⁅b, c⁆ + ⁅a, c⁆ * b := by noncomm_ring
example : ⁅a, b * c⁆ = ⁅a, b⁆ * c + b * ⁅a, c⁆ := by noncomm_ring
example : ⁅3 * a, a⁆ = 0 := by noncomm_ring
example : ⁅a * -5, a⁆ = 0 := by noncomm_ring
example : ⁅a^3, a⁆ = 0 := by noncomm_ring

example : a ⚬ a = 2*a^2 := by noncomm_ring
example : (2 * a) ⚬ a = 4*a^2 := by noncomm_ring
example : a ⚬ b = b ⚬ a := by noncomm_ring
example : a ⚬ (b + c) = a ⚬ b + a ⚬ c := by noncomm_ring
example : (a + b) ⚬ c = a ⚬ c + b ⚬ c := by noncomm_ring
example : (a ⚬ b) ⚬ (a ⚬ a) = a ⚬ (b ⚬ (a ⚬ a)) := by noncomm_ring

example : ⁅a, b ⚬ c⁆ = ⁅a, b⁆ ⚬ c + b ⚬ ⁅a, c⁆ := by noncomm_ring
example : ⁅a ⚬ b, c⁆ = a ⚬ ⁅b, c⁆ + ⁅a, c⁆ ⚬ b := by noncomm_ring
example : (a ⚬ b) ⚬ c - a ⚬ (b ⚬ c) = -⁅⁅a, b⁆, c⁆ + ⁅a, ⁅b, c⁆⁆ := by noncomm_ring

example : a + -b = -b + a := by noncomm_ring


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import tactic.congr
import tactic.protected
import tactic.rcases
import tactic.split_ifs
import logic.basic

/-!
# More basic logic properties

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

A few more logic lemmas. These are in their own file, rather than `logic.basic`, because it is
convenient to be able to use the `split_ifs` tactic.

## Implementation notes

We spell those lemmas out with `dite` and `ite` rather than the `if then else` notation because this
would result in less delta-reduced statements.
-/

alias heq_iff_eq ↔ heq.eq eq.heq

attribute [protected] heq.eq eq.heq

alias ne_of_eq_of_ne ← eq.trans_ne
alias ne_of_ne_of_eq ← ne.trans_eq

variables {α : Sort*} {p q r : Prop} [decidable p] [decidable q] {a b c : α}

lemma dite_dite_distrib_left {a : p → α} {b : ¬ p → q → α} {c : ¬ p → ¬ q → α} :
  dite p a (λ hp, dite q (b hp) (c hp)) =
    dite q (λ hq, dite p a $ λ hp, b hp hq) (λ hq, dite p a $ λ hp, c hp hq) :=
by split_ifs; refl

lemma dite_dite_distrib_right {a : p → q → α} {b : p → ¬ q → α} {c : ¬ p → α} :
  dite p (λ hp, dite q (a hp) (b hp)) c =
    dite q (λ hq, dite p (λ hp, a hp hq) c) (λ hq, dite p (λ hp, b hp hq) c) :=
by split_ifs; refl

lemma ite_dite_distrib_left {a : α} {b : q → α} {c : ¬ q → α} :
  ite p a (dite q b c) = dite q (λ hq, ite p a $ b hq) (λ hq, ite p a $ c hq) :=
dite_dite_distrib_left

lemma ite_dite_distrib_right {a : q → α} {b : ¬ q → α} {c : α} :
  ite p (dite q a b) c = dite q (λ hq, ite p (a hq) c) (λ hq, ite p (b hq) c) :=
dite_dite_distrib_right

lemma dite_ite_distrib_left {a : p → α} {b : ¬ p → α} {c : ¬ p → α} :
  dite p a (λ hp, ite q (b hp) (c hp)) = ite q (dite p a b) (dite p a c) :=
dite_dite_distrib_left

lemma dite_ite_distrib_right {a : p → α} {b : p → α} {c : ¬ p → α} :
  dite p (λ hp, ite q (a hp) (b hp)) c = ite q (dite p a c) (dite p b c) :=
dite_dite_distrib_right

lemma ite_ite_distrib_left : ite p a (ite q b c) = ite q (ite p a b) (ite p a c) :=
dite_dite_distrib_left

lemma ite_ite_distrib_right : ite p (ite q a b) c = ite q (ite p a c) (ite p b c) :=
dite_dite_distrib_right

lemma Prop.forall {f : Prop → Prop} : (∀ p, f p) ↔ f true ∧ f false :=
⟨λ h, ⟨h _, h _⟩, by { rintro ⟨h₁, h₀⟩ p, by_cases hp : p; simp only [hp]; assumption }⟩

lemma Prop.exists {f : Prop → Prop} : (∃ p, f p) ↔ f true ∨ f false :=
⟨λ ⟨p, h⟩, by refine (em p).imp _ _; intro H; convert h; simp [H], by rintro (h | h); exact ⟨_, h⟩⟩


import data.finset.basic
import data.finset.card

import data.list.basic

import data.multiset.basic

namespace finset

variables {α β : Type*}
variables {s t : finset α} {a b : α}

lemma card_eq_four [decidable_eq α] :
  s.card = 4 ↔ ∃ w x y z, w ≠ x ∧ w ≠ y ∧ w ≠ z ∧ x ≠ y ∧ x ≠ z ∧ y ≠ z ∧ s = {w, x, y, z} :=
begin
  split,
  { rw card_eq_succ,
    simp_rw [card_eq_three],
    rintro ⟨a, _, abcd, rfl, b, c, d, bc, bd, cd, rfl⟩,
    rw [mem_insert, not_or_distrib, mem_insert, mem_singleton, not_or_distrib] at abcd,
    exact ⟨a, b, c, d, abcd.1, abcd.2.1, abcd.2.2, bc, bd, cd, rfl⟩ },
  { rintro ⟨w, x, y, z, wx, wy, wz, xy, xz, yz, rfl⟩,
    simp only [wx, wy, wz, xy, xz, yz, mem_insert, card_insert_of_not_mem, not_false_iff, mem_singleton,
      or_self, card_singleton] }
end

end finset

namespace list

variable {α : Type*}

lemma length_eq_four {l : list α} : l.length = 4 ↔ ∃ a b c d, l = [a, b, c, d] :=
⟨match l with [a, b, c, d], _ := ⟨a, b, c, d, rfl⟩ end, λ ⟨a, b, c, d, e⟩, e.symm ▸ rfl⟩

end list

namespace multiset

variable {α : Type*}

lemma card_eq_four {s : multiset α} : s.card = 4 ↔ ∃ w x y z, s = {w, x, y, z} :=
⟨quot.induction_on s (λ l h, (list.length_eq_four.mp h).imp
  (λ a, Exists.imp (λ b, Exists.imp (λ c, Exists.imp (λ d, congr_arg coe))))), λ ⟨a, b, c, d, e⟩, e.symm ▸ rfl⟩

end multiset


import topology.tactic
import topology.instances.real

example {X : Type*} [topological_space X] : continuous (@id X) :=
by { continuity, }

example : continuous (λ (x : ℝ), -x) :=
by { exact continuous_id'.neg, }


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

! This file was ported from Lean 3 source module ring_theory.matrix_algebra
! leanprover-community/mathlib commit 6c351a8fb9b06e5a542fdf427bfb9f46724f9453
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Matrix.Basis
import Mathbin.RingTheory.TensorProduct

/-!
We show `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)`.
-/

universe u v w

open TensorProduct

open BigOperators

open TensorProduct

open Algebra.TensorProduct

open Matrix

variable {R : Type u} [CommSemiring R]

variable {A : Type v} [Semiring A] [Algebra R A]

variable {n : Type w}

variable (R A n)

namespace matrixEquivTensor

/-- (Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-bilinear map.
-/
def toFunBilinear : A →ₗ[R] Matrix n n R →ₗ[R] Matrix n n A :=
  (Algebra.lsmul R (Matrix n n A)).toLinearMap.compl₂ (Algebra.linearMap R A).mapMatrix
#align matrix_equiv_tensor.to_fun_bilinear MatrixEquivTensor.toFunBilinear

@[simp]
theorem toFunBilinear_apply (a : A) (m : Matrix n n R) :
    toFunBilinear R A n a m = a • m.map (algebraMap R A) :=
  rfl
#align matrix_equiv_tensor.to_fun_bilinear_apply MatrixEquivTensor.toFunBilinear_apply

/-- (Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-linear map.
-/
def toFunLinear : A ⊗[R] Matrix n n R →ₗ[R] Matrix n n A :=
  TensorProduct.lift (toFunBilinear R A n)
#align matrix_equiv_tensor.to_fun_linear MatrixEquivTensor.toFunLinear

variable [DecidableEq n] [Fintype n]

/-- The function `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`, as an algebra homomorphism.
-/
def toFunAlgHom : A ⊗[R] Matrix n n R →ₐ[R] Matrix n n A :=
  algHomOfLinearMapTensorProduct (toFunLinear R A n)
    (by
      intros
      simp_rw [to_fun_linear, lift.tmul, to_fun_bilinear_apply, mul_eq_mul, Matrix.map_mul]
      ext
      dsimp
      simp_rw [Matrix.mul_apply, Pi.smul_apply, Matrix.map_apply, smul_eq_mul, Finset.mul_sum,
        _root_.mul_assoc, Algebra.left_comm])
    (by
      intros
      simp_rw [to_fun_linear, lift.tmul, to_fun_bilinear_apply,
        Matrix.map_one (algebraMap R A) (map_zero _) (map_one _), algebraMap_smul,
        Algebra.algebraMap_eq_smul_one])
#align matrix_equiv_tensor.to_fun_alg_hom MatrixEquivTensor.toFunAlgHom

@[simp]
theorem toFunAlgHom_apply (a : A) (m : Matrix n n R) :
    toFunAlgHom R A n (a ⊗ₜ m) = a • m.map (algebraMap R A) := by
  simp [to_fun_alg_hom, alg_hom_of_linear_map_tensor_product, to_fun_linear]
#align matrix_equiv_tensor.to_fun_alg_hom_apply MatrixEquivTensor.toFunAlgHom_apply

/-- (Implementation detail.)

The bare function `matrix n n A → A ⊗[R] matrix n n R`.
(We don't need to show that it's an algebra map, thankfully --- just that it's an inverse.)
-/
def invFun (M : Matrix n n A) : A ⊗[R] Matrix n n R :=
  ∑ p : n × n, M p.1 p.2 ⊗ₜ stdBasisMatrix p.1 p.2 1
#align matrix_equiv_tensor.inv_fun MatrixEquivTensor.invFun

@[simp]
theorem invFun_zero : invFun R A n 0 = 0 := by simp [inv_fun]
#align matrix_equiv_tensor.inv_fun_zero MatrixEquivTensor.invFun_zero

@[simp]
theorem invFun_add (M N : Matrix n n A) : invFun R A n (M + N) = invFun R A n M + invFun R A n N :=
  by simp [inv_fun, add_tmul, Finset.sum_add_distrib]
#align matrix_equiv_tensor.inv_fun_add MatrixEquivTensor.invFun_add

@[simp]
theorem invFun_smul (a : A) (M : Matrix n n A) : invFun R A n (a • M) = a ⊗ₜ 1 * invFun R A n M :=
  by simp [inv_fun, Finset.mul_sum]
#align matrix_equiv_tensor.inv_fun_smul MatrixEquivTensor.invFun_smul

@[simp]
theorem invFun_algebraMap (M : Matrix n n R) : invFun R A n (M.map (algebraMap R A)) = 1 ⊗ₜ M :=
  by
  dsimp [inv_fun]
  simp only [Algebra.algebraMap_eq_smul_one, smul_tmul, ← tmul_sum, mul_boole]
  congr
  conv_rhs => rw [matrix_eq_sum_std_basis M]
  convert Finset.sum_product; simp
#align matrix_equiv_tensor.inv_fun_algebra_map MatrixEquivTensor.invFun_algebraMap

theorem right_inv (M : Matrix n n A) : (toFunAlgHom R A n) (invFun R A n M) = M :=
  by
  simp only [inv_fun, AlgHom.map_sum, std_basis_matrix, apply_ite ⇑(algebraMap R A), smul_eq_mul,
    mul_boole, to_fun_alg_hom_apply, RingHom.map_zero, RingHom.map_one, Matrix.map_apply,
    Pi.smul_def]
  convert Finset.sum_product; apply matrix_eq_sum_std_basis
#align matrix_equiv_tensor.right_inv MatrixEquivTensor.right_inv

theorem left_inv (M : A ⊗[R] Matrix n n R) : invFun R A n (toFunAlgHom R A n M) = M :=
  by
  induction' M using TensorProduct.induction_on with a m x y hx hy
  · simp
  · simp
  · simp [AlgHom.map_sum, hx, hy]
#align matrix_equiv_tensor.left_inv MatrixEquivTensor.left_inv

/-- (Implementation detail)

The equivalence, ignoring the algebra structure, `(A ⊗[R] matrix n n R) ≃ matrix n n A`.
-/
def equiv : A ⊗[R] Matrix n n R ≃ Matrix n n A
    where
  toFun := toFunAlgHom R A n
  invFun := invFun R A n
  left_inv := left_inv R A n
  right_inv := right_inv R A n
#align matrix_equiv_tensor.equiv MatrixEquivTensor.equiv

end matrixEquivTensor

variable [Fintype n] [DecidableEq n]

/-- The `R`-algebra isomorphism `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)`.
-/
def matrixEquivTensor : Matrix n n A ≃ₐ[R] A ⊗[R] Matrix n n R :=
  AlgEquiv.symm { MatrixEquivTensor.toFunAlgHom R A n, MatrixEquivTensor.equiv R A n with }
#align matrix_equiv_tensor matrixEquivTensor

open matrixEquivTensor

@[simp]
theorem matrixEquivTensor_apply (M : Matrix n n A) :
    matrixEquivTensor R A n M = ∑ p : n × n, M p.1 p.2 ⊗ₜ stdBasisMatrix p.1 p.2 1 :=
  rfl
#align matrix_equiv_tensor_apply matrixEquivTensor_apply

@[simp]
theorem matrixEquivTensor_apply_std_basis (i j : n) (x : A) :
    matrixEquivTensor R A n (stdBasisMatrix i j x) = x ⊗ₜ stdBasisMatrix i j 1 :=
  by
  have t : ∀ p : n × n, i = p.1 ∧ j = p.2 ↔ p = (i, j) := by tidy
  simp [ite_tmul, t, std_basis_matrix]
#align matrix_equiv_tensor_apply_std_basis matrixEquivTensor_apply_std_basis

@[simp]
theorem matrixEquivTensor_apply_symm (a : A) (M : Matrix n n R) :
    (matrixEquivTensor R A n).symm (a ⊗ₜ M) = M.map fun x => a * algebraMap R A x :=
  by
  simp [matrixEquivTensor, to_fun_alg_hom, alg_hom_of_linear_map_tensor_product, to_fun_linear]
  rfl
#align matrix_equiv_tensor_apply_symm matrixEquivTensor_apply_symm


import number_theory.legendre_symbol.add_character
import number_theory.legendre_symbol.zmod_char
import algebra.char_p.char_and_card
import field_theory.finite.trace
import number_theory.cyclotomic.basic
import data.zmod.basic
import data.complex.basic
import ring_theory.roots_of_unity
import algebra.group_power.basic
import data.complex.basic
import analysis.normed.field.basic
import data.pnat.defs
noncomputable theory
/-!
# Modified Gauss sums

We define the Gauss sum associated to a multiplicative and an additive
character of a finite field and prove some results about them.

## Main definition

Here, let 𝔽 = 𝔽_q be a finite field with q elements(q = p^f ) and let χ ζ_p be a fixed primitive root of unity and let T be the trace from 𝔽 to
ℤ/pℤ. Define
 ψ : 𝔽 → ℂ^× , ψ(x) = ζ_p^T(x)
 and now we define χ as a multiplicative character with these domains.
 𝔽^× → ℂ^×
We extend χ to all of 𝔽 by setting χ(0) = 0(even if χ is a trivial character).
-/
open add_char
open_locale big_operators
open_locale classical
open_locale complex_conjugate
universes u v w
-- variables (f : ℕ)
variables {F : Type u} [field F] [fintype F] (ζ_p : ℂˣ) [ fact (is_primitive_root ζ_p (ring_char F)) ]
/-- Definition of the Gauss sum associated to a multiplicative and an additive character. -/
-- structure add_char' extends add_char F ℂˣ:=
-- (ψ : F → ℂˣ )
-- (ζ_p: is_primitive_root )
-- (ψ_eq : ∀ x : F, ψ x = (ψ 1) ^ (trace x))

def add_char'(x : F) : ℂˣ  :=
  ζ_p^( zmod.val (algebra.trace (zmod (ring_char F)) F x))

def gauss_sum' (χ : mul_char F ℂ ) : ℂ := ∑' x : F,  -(add_char' ζ_p x)* (χ x)

instance char_p_non_zero : ne_zero (ring_char F) :=
{out :=  begin
  intro h,
  haveI : fact (ring_char F).prime := ⟨char_p.char_is_prime F _⟩,
  exact nat.prime.ne_zero (fact.out (ring_char F).prime) h,
end}

lemma ζ_p_helper_help (n : ℤ ): ζ_p^((n % (ring_char F)) ) = ζ_p^(n) := by
begin
  rw ←  mul_inv_eq_one,
  rw ← zpow_neg ζ_p n,
  rw ← zpow_add ζ_p,
  rw  is_primitive_root.zpow_eq_one_iff_dvd (fact.out (is_primitive_root ζ_p (ring_char F))) ,
  rw ← int.modeq_zero_iff_dvd,
  have h1 : 0 = n + -n := by ring,
  rw h1,
  apply int.modeq.add_right,
  apply int.mod_modeq,
end

lemma ζ_p_helper(n : ℕ ): ζ_p^((n % (ring_char F)) ) = ζ_p^(n) := by
begin
  simpa using ζ_p_helper_help ζ_p n,
end

lemma add_char'_mul_property (a : F) (x : F ): add_char' ζ_p (a + x) = add_char' ζ_p a * add_char' ζ_p x := by
begin
  unfold add_char',
  simp,
  haveI : fact (ring_char F).prime := ⟨char_p.char_is_prime F _⟩,
  rw [zmod.val_add ],
  rw[← pow_add],
  rw[← ζ_p_helper ζ_p ((algebra.trace (zmod (ring_char F)) F a).val + (algebra.trace (zmod (ring_char F)) F x).val)],
  assumption,
  assumption,
end

def conjugate (x : ℂˣ) : ℂ := conj (x.val)

lemma ζ_p_helper_add (n : ℤ )(x : F): conjugate (ζ_p^n) = (ζ_p^(-n)).val := by
begin
  unfold conjugate,
  simp[conj],
  have h1 : (ζ_p)^(ring_char F) = 1 := by
  {
    apply is_primitive_root.pow_eq_one,
    apply fact.out (is_primitive_root ζ_p (ring_char F)),
  },
  have h2 : ‖(ζ_p).val‖  = 1 := by
  {
    have h3 : ring_char F > 0 := by
    {
      haveI : fact (ring_char F).prime := ⟨char_p.char_is_prime F _⟩,
      exact nat.prime.pos (fact.out (ring_char F).prime),
    },
    set r := (ring_char F).to_pnat' with h4,
    have h5 : ((ζ_p).val)^(↑r) = 1 := by
    {
      rw  h4,
      simp,
      rw [nat.to_pnat',nat.succ_pnat],
      rw pnat.mk_coe,
      rw nat.succ_pred_eq_of_pos h3,
      rw [←units.coe_pow ζ_p (ring_char F),← units.coe_one ,units.eq_iff.mpr h1],
    },
    apply norm_one_of_pow_eq_one h5,
  },
  rw complex.inv_def,
  have h3 : ‖ ((ζ_p).val)^n ‖ = 1 := by
  {
    rw [norm_zpow , h2],
    simp,
  },
  simp at h3,
  rw ← complex.mul_self_abs,
  simp[h3],
end

lemma ζ_p_help_add' (n : ℕ  )(x : F): conjugate (ζ_p^n) = (ζ_p^(- int.of_nat (n) )).val := by
begin
  simpa using ζ_p_helper_add ζ_p n x,
end

lemma add_char'_conjugate (x : F ):  conjugate ( add_char' ζ_p x) = (add_char' ζ_p (-x)).val := by
begin
  unfold add_char',
  rw ζ_p_help_add' ζ_p (algebra.trace (zmod (ring_char F)) F x).val x,
  simp,
  sorry
end

def conj_mul_char' (χ : mul_char F ℂ ) :mul_char F ℂ :=
{ to_fun := by {classical, exact λ x, conj (χ x) },
  map_nonunit' := by { classical, exact λ x hx, by simpa using χ.map_nonunit hx },
  map_one' := by {
    classical,
    rw[map_one],
    simp,
  },
  map_mul' := by {
    classical,
    intros x y,
    rw[map_mul],
    simp,
   }
}

/-!
## Main results
-/

/-!
Some important results are as follows.

* `gauss_sum_mul_gauss_sum_eq_card`: The product of the Gauss
  sums of `χ` and `ψ` and that of `χ⁻¹` and `ψ⁻¹` is the cardinality
  of the source ring `R` (if `χ` is nontrivial, `ψ` is primitive and `R` is a field).
* `gauss_sum_sq`: The square of the Gauss sum is `χ(-1)` times
  the cardinality of `R` if in addition `χ` is a quadratic character.
* `quad_gauss_sum_frob`: For a quadratic character `χ`, raising
  the Gauss sum to the `p`th power (where `p` is the characteristic of
  the target ring `R'`) multiplies it by `χ p`.
* `char.card_pow_card`: When `F` and `F'` are finite fields and `χ : F → F'`
  is a nontrivial quadratic character, then `(χ (-1) * #F)^(#F'/2) = χ (#F')`.
* `finite_field.two_pow_card`: For every finite field `F` of odd characteristic,
  we have `2^(#F/2) = χ₈(#F)` in `F`.

This machinery can be used to derive (a generalization of) the Law of
Quadratic Reciprocity.

## Tags

additive character, multiplicative character, Gauss sum
-/


import data.nat.prime data.int.modeq data.complex.basic algebra.euclidean_domain number_theory.pell data.nat.sqrt
open nat

--1. For each of the following rings R, and elements a and b, find d = hcf(a,b), and calculate s, t ∈ R such that as + bt = d.
variables {R : Type*} [euclidean_domain R]
variables a b : ℤ

--def d : ℤ := gcd a b

structure gaussian_ints :=
(re : ℤ)
(im : ℤ)

def gaussian_val (x : gaussian_ints) : ℕ := (x.re * x.re + x.im * x.im).nat_abs

--def poly_coeff_rat := list rat -- could also use finsupp

--def ints_adj_sqrt (n : ℤ) :=
--set.range (λ x : ℤ × ℤ, x.1 + x.2 * nat.sqrt n.nat_abs)

--(a) a=4+3i,b=2−4i ∈ Z[i].
--theorem sheet10_q1_a (x y : gaussian_ints) (ha : a = ⟨4,3⟩) (ha : b = ⟨2,-4⟩)

--(b) a(x)=x^4−2x^2−x+4,b(x)=x^3+2x^2+x−1 ∈ Q[x].
--theorem sheet10_q1_b (x y : poly_coeff_rat) (ha x = [4,1,-2,0,1]) (hb y = [-1,1,2,1]) :

--(c) a(x)=x^5−x^2−x−1,b(x)=x^4+2x^2+x+1 ∈ Q[x].
--theorem sheet10_q1_c (x y : poly_coeff_rat) (ha x = [-1,-1,-1,0,0,1]) (hb y = [1,1,2,0,1]) :

--2. Find an irreducible element of ℤ[√3] that is not prime
  -- def irreducible (α : R) :
    -- e.g : 2 + √3 i think works

--3. Show that R = ℤ[√3] is a Euclidean domain with Euclidean function If a=1+3 3,b=3−4 3inZ[√3],find d=hcf(a,b), and calculate δ(a) = |N(a)|, where N is the norm map.s, t ∈ R such that as + bt = d.
--def R' := ints_adj_sqrt 3
-- def euc_func () :=
--theorem sheet10_q3

--4. Let ω=e^2πi/3 ∈ C, and let Z[ω] be the set {x + yω | x, y ∈ Z} ⊆ C.
-- cannot, as i don't have e, or pi

--(a) Show that Z[ω] is a ring under the usual operations + and · on C.

--(b) Define N:Z[ω]→Z by N(x+yω)=(x+yω)(x+yω)=x^2 +y^2 −xy. show that N(a)N(b) = N(ab) for all a,b ∈ Z[ω].

--(c) Find the units of Z[ω].

-- 5. (a) Show that the only integer solution to the equation y^3 = 4x^2 − 1 is x = 0 and y = −1.
theorem sheet10_q5_a (x y : ℤ) : y^3 = 4*x^2 - 1 → x = 0 ∧ y = -1 := sorry
--(b) Find all integer solutions to y3 = x2 + 1.
theorem sheet10_q5_b (x y : ℤ) : y^3 = x^2 + 1 → x = 0 ∧ y = 1 := sorry
-- 6. Let p be a prime number congruent to 3 mod 4. Let a,b ∈ Z. Show that if p divides a2 + b2, then p divides both a and b. [Hint: use Fermat’s Little Theorem.]
theorem sheet10_q6 (a b : ℤ) (p : ℕ) (hp : prime p) (hq: p ≡ 3 [MOD 4]) : ↑p ∣ (a^2 + b^2) → ↑p ∣ a ∧ ↑p ∣ b := sorry
--7. Show that y^3 = x^2 − 7 has no integer solutions. [Hint: Write this as y^3 +8 = x^2 + 1, show that the left-hand side must have a prime divisor congruent to 3 mod 4, and then use Qu. 6.]
theorem sheet10_q7 (x y : ℤ) : y^3 = x^2 - 7 → false := sorry -- need to add "has no solns"


/-
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 topology.sheaves.sheaf_condition.pairwise_intersections
! leanprover-community/mathlib commit 8a318021995877a44630c898d0b2bc376fceef3b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.SheafCondition.OpensLeCover
import Mathbin.CategoryTheory.Limits.Final
import Mathbin.CategoryTheory.Limits.Preserves.Basic
import Mathbin.CategoryTheory.Category.Pairwise
import Mathbin.CategoryTheory.Limits.Constructions.BinaryProducts
import Mathbin.Algebra.Category.Ring.Constructions

/-!
# Equivalent formulations of the sheaf condition

We give an equivalent formulation of the sheaf condition.

Given any indexed type `ι`, we define `overlap ι`,
a category with objects corresponding to
* individual open sets, `single i`, and
* intersections of pairs of open sets, `pair i j`,
with morphisms from `pair i j` to both `single i` and `single j`.

Any open cover `U : ι → opens X` provides a functor `diagram U : overlap ι ⥤ (opens X)ᵒᵖ`.

There is a canonical cone over this functor, `cone U`, whose cone point is `supr U`,
and in fact this is a limit cone.

A presheaf `F : presheaf C X` is a sheaf precisely if it preserves this limit.
We express this in two equivalent ways, as
* `is_limit (F.map_cone (cone U))`, or
* `preserves_limit (diagram U) F`

We show that this sheaf condition is equivalent to the `opens_le_cover` sheaf condition, and
thereby also equivalent to the default sheaf condition.
-/

noncomputable section

universe w v u

open TopologicalSpace TopCat Opposite CategoryTheory CategoryTheory.Limits

variable {C : Type u} [Category.{v} C] {X : TopCat.{w}}

namespace TopCat.Presheaf

section

/-- An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`is_sheaf_iff_is_sheaf_pairwise_intersections`).

A presheaf is a sheaf if `F` sends the cone `(pairwise.cocone U).op` to a limit cone.
(Recall `pairwise.cocone U` has cone point `supr U`, mapping down to the `U i` and the `U i ⊓ U j`.)
-/
def IsSheafPairwiseIntersections (F : Presheaf C X) : Prop :=
  ∀ ⦃ι : Type w⦄ (U : ι → Opens X), Nonempty (IsLimit (F.mapCone (Pairwise.cocone U).op))
#align Top.presheaf.is_sheaf_pairwise_intersections TopCat.Presheaf.IsSheafPairwiseIntersections

/-- An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`is_sheaf_iff_is_sheaf_preserves_limit_pairwise_intersections`).

A presheaf is a sheaf if `F` preserves the limit of `pairwise.diagram U`.
(Recall `pairwise.diagram U` is the diagram consisting of the pairwise intersections
`U i ⊓ U j` mapping into the open sets `U i`. This diagram has limit `supr U`.)
-/
def IsSheafPreservesLimitPairwiseIntersections (F : Presheaf C X) : Prop :=
  ∀ ⦃ι : Type w⦄ (U : ι → Opens X), Nonempty (PreservesLimit (Pairwise.diagram U).op F)
#align Top.presheaf.is_sheaf_preserves_limit_pairwise_intersections TopCat.Presheaf.IsSheafPreservesLimitPairwiseIntersections

end

namespace SheafCondition

variable {ι : Type w} (U : ι → Opens X)

open CategoryTheory.Pairwise

/-- Implementation detail:
the object level of `pairwise_to_opens_le_cover : pairwise ι ⥤ opens_le_cover U`
-/
@[simp]
def pairwiseToOpensLeCoverObj : Pairwise ι → OpensLeCover U
  | single i => ⟨U i, ⟨i, le_rfl⟩⟩
  | pair i j => ⟨U i ⊓ U j, ⟨i, inf_le_left⟩⟩
#align Top.presheaf.sheaf_condition.pairwise_to_opens_le_cover_obj TopCat.Presheaf.SheafCondition.pairwiseToOpensLeCoverObj

open CategoryTheory.Pairwise.Hom

/-- Implementation detail:
the morphism level of `pairwise_to_opens_le_cover : pairwise ι ⥤ opens_le_cover U`
-/
def pairwiseToOpensLeCoverMap :
    ∀ {V W : Pairwise ι}, (V ⟶ W) → (pairwiseToOpensLeCoverObj U V ⟶ pairwiseToOpensLeCoverObj U W)
  | _, _, id_single i => 𝟙 _
  | _, _, id_pair i j => 𝟙 _
  | _, _, left i j => homOfLE inf_le_left
  | _, _, right i j => homOfLE inf_le_right
#align Top.presheaf.sheaf_condition.pairwise_to_opens_le_cover_map TopCat.Presheaf.SheafCondition.pairwiseToOpensLeCoverMap

/-- The category of single and double intersections of the `U i` maps into the category
of open sets below some `U i`.
-/
@[simps]
def pairwiseToOpensLeCover : Pairwise ι ⥤ OpensLeCover U
    where
  obj := pairwiseToOpensLeCoverObj U
  map V W i := pairwiseToOpensLeCoverMap U i
#align Top.presheaf.sheaf_condition.pairwise_to_opens_le_cover TopCat.Presheaf.SheafCondition.pairwiseToOpensLeCover

instance (V : OpensLeCover U) : Nonempty (StructuredArrow V (pairwiseToOpensLeCover U)) :=
  ⟨@StructuredArrow.mk _ _ _ _ _ (single V.index) _ V.hom_to_index⟩

-- This is a case bash: for each pair of types of objects in `pairwise ι`,
-- we have to explicitly construct a zigzag.
/-- The diagram consisting of the `U i` and `U i ⊓ U j` is cofinal in the diagram
of all opens contained in some `U i`.
-/
instance : Functor.Final (pairwiseToOpensLeCover U) :=
  ⟨fun V =>
    isConnected_of_zigzag fun A B =>
      by
      rcases A with ⟨⟨⟨⟩⟩, ⟨i⟩ | ⟨i, j⟩, a⟩ <;> rcases B with ⟨⟨⟨⟩⟩, ⟨i'⟩ | ⟨i', j'⟩, b⟩ <;>
        dsimp at *
      · refine'
          ⟨[{   left := ⟨⟨⟩⟩
                right := pair i i'
                Hom := (le_inf a.le b.le).Hom }, _], _, rfl⟩
        exact
          List.Chain.cons
            (Or.inr
              ⟨{  left := 𝟙 _
                  right := left i i' }⟩)
            (List.Chain.cons
              (Or.inl
                ⟨{  left := 𝟙 _
                    right := right i i' }⟩)
              List.Chain.nil)
      · refine'
          ⟨[{   left := ⟨⟨⟩⟩
                right := pair i' i
                Hom := (le_inf (b.le.trans inf_le_left) a.le).Hom },
              { left := ⟨⟨⟩⟩
                right := single i'
                Hom := (b.le.trans inf_le_left).Hom }, _], _, rfl⟩
        exact
          List.Chain.cons
            (Or.inr
              ⟨{  left := 𝟙 _
                  right := right i' i }⟩)
            (List.Chain.cons
              (Or.inl
                ⟨{  left := 𝟙 _
                    right := left i' i }⟩)
              (List.Chain.cons
                (Or.inr
                  ⟨{  left := 𝟙 _
                      right := left i' j' }⟩)
                List.Chain.nil))
      · refine'
          ⟨[{   left := ⟨⟨⟩⟩
                right := single i
                Hom := (a.le.trans inf_le_left).Hom },
              { left := ⟨⟨⟩⟩
                right := pair i i'
                Hom := (le_inf (a.le.trans inf_le_left) b.le).Hom }, _], _, rfl⟩
        exact
          List.Chain.cons
            (Or.inl
              ⟨{  left := 𝟙 _
                  right := left i j }⟩)
            (List.Chain.cons
              (Or.inr
                ⟨{  left := 𝟙 _
                    right := left i i' }⟩)
              (List.Chain.cons
                (Or.inl
                  ⟨{  left := 𝟙 _
                      right := right i i' }⟩)
                List.Chain.nil))
      · refine'
          ⟨[{   left := ⟨⟨⟩⟩
                right := single i
                Hom := (a.le.trans inf_le_left).Hom },
              { left := ⟨⟨⟩⟩
                right := pair i i'
                Hom := (le_inf (a.le.trans inf_le_left) (b.le.trans inf_le_left)).Hom },
              { left := ⟨⟨⟩⟩
                right := single i'
                Hom := (b.le.trans inf_le_left).Hom }, _], _, rfl⟩
        exact
          List.Chain.cons
            (Or.inl
              ⟨{  left := 𝟙 _
                  right := left i j }⟩)
            (List.Chain.cons
              (Or.inr
                ⟨{  left := 𝟙 _
                    right := left i i' }⟩)
              (List.Chain.cons
                (Or.inl
                  ⟨{  left := 𝟙 _
                      right := right i i' }⟩)
                (List.Chain.cons
                  (Or.inr
                    ⟨{  left := 𝟙 _
                        right := left i' j' }⟩)
                  List.Chain.nil)))⟩

/-- The diagram in `opens X` indexed by pairwise intersections from `U` is isomorphic
(in fact, equal) to the diagram factored through `opens_le_cover U`.
-/
def pairwiseDiagramIso : Pairwise.diagram U ≅ pairwiseToOpensLeCover U ⋙ fullSubcategoryInclusion _
    where
  Hom := { app := by rintro (i | ⟨i, j⟩) <;> exact 𝟙 _ }
  inv := { app := by rintro (i | ⟨i, j⟩) <;> exact 𝟙 _ }
#align Top.presheaf.sheaf_condition.pairwise_diagram_iso TopCat.Presheaf.SheafCondition.pairwiseDiagramIso

/--
The cocone `pairwise.cocone U` with cocone point `supr U` over `pairwise.diagram U` is isomorphic
to the cocone `opens_le_cover_cocone U` (with the same cocone point)
after appropriate whiskering and postcomposition.
-/
def pairwiseCoconeIso :
    (Pairwise.cocone U).op ≅
      (Cones.postcomposeEquivalence (NatIso.op (pairwiseDiagramIso U : _) : _)).Functor.obj
        ((opensLeCoverCocone U).op.whisker (pairwiseToOpensLeCover U).op) :=
  Cones.ext (Iso.refl _) (by tidy)
#align Top.presheaf.sheaf_condition.pairwise_cocone_iso TopCat.Presheaf.SheafCondition.pairwiseCoconeIso

end SheafCondition

open SheafCondition

variable (F : Presheaf C X)

/-- The sheaf condition
in terms of a limit diagram over all `{ V : opens X // ∃ i, V ≤ U i }`
is equivalent to the reformulation
in terms of a limit diagram over `U i` and `U i ⊓ U j`.
-/
theorem isSheafOpensLeCover_iff_isSheafPairwiseIntersections :
    F.IsSheafOpensLeCover ↔ F.IsSheafPairwiseIntersections :=
  forall₂_congr fun ι U =>
    Equiv.nonempty_congr <|
      calc
        IsLimit (F.mapCone (opensLeCoverCocone U).op) ≃
            IsLimit ((F.mapCone (opensLeCoverCocone U).op).whisker (pairwiseToOpensLeCover U).op) :=
          (Functor.Initial.isLimitWhiskerEquiv (pairwiseToOpensLeCover U).op _).symm
        _ ≃ IsLimit (F.mapCone ((opensLeCoverCocone U).op.whisker (pairwiseToOpensLeCover U).op)) :=
          (IsLimit.equivIsoLimit F.mapConeWhisker.symm)
        _ ≃
            IsLimit
              ((Cones.postcomposeEquivalence _).Functor.obj
                (F.mapCone ((opensLeCoverCocone U).op.whisker (pairwiseToOpensLeCover U).op))) :=
          (IsLimit.postcomposeHomEquiv _ _).symm
        _ ≃
            IsLimit
              (F.mapCone
                ((Cones.postcomposeEquivalence _).Functor.obj
                  ((opensLeCoverCocone U).op.whisker (pairwiseToOpensLeCover U).op))) :=
          (IsLimit.equivIsoLimit (Functor.mapConePostcomposeEquivalenceFunctor _).symm)
        _ ≃ IsLimit (F.mapCone (Pairwise.cocone U).op) :=
          IsLimit.equivIsoLimit ((Cones.functoriality _ _).mapIso (pairwiseCoconeIso U : _).symm)

#align Top.presheaf.is_sheaf_opens_le_cover_iff_is_sheaf_pairwise_intersections TopCat.Presheaf.isSheafOpensLeCover_iff_isSheafPairwiseIntersections

/-- The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of a limit diagram over `U i` and `U i ⊓ U j`.
-/
theorem isSheaf_iff_isSheafPairwiseIntersections : F.IsSheaf ↔ F.IsSheafPairwiseIntersections := by
  rw [is_sheaf_iff_is_sheaf_opens_le_cover,
    is_sheaf_opens_le_cover_iff_is_sheaf_pairwise_intersections]
#align Top.presheaf.is_sheaf_iff_is_sheaf_pairwise_intersections TopCat.Presheaf.isSheaf_iff_isSheafPairwiseIntersections

/-- The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of the presheaf preserving the limit of the diagram
consisting of the `U i` and `U i ⊓ U j`.
-/
theorem isSheaf_iff_isSheafPreservesLimitPairwiseIntersections :
    F.IsSheaf ↔ F.IsSheafPreservesLimitPairwiseIntersections :=
  by
  rw [is_sheaf_iff_is_sheaf_pairwise_intersections]
  constructor
  · intro h ι U
    exact ⟨preserves_limit_of_preserves_limit_cone (pairwise.cocone_is_colimit U).op (h U).some⟩
  · intro h ι U
    haveI := (h U).some
    exact ⟨preserves_limit.preserves (pairwise.cocone_is_colimit U).op⟩
#align Top.presheaf.is_sheaf_iff_is_sheaf_preserves_limit_pairwise_intersections TopCat.Presheaf.isSheaf_iff_isSheafPreservesLimitPairwiseIntersections

end TopCat.Presheaf

namespace TopCat.Sheaf

variable (F : X.Sheaf C) (U V : Opens X)

open CategoryTheory.Limits

/-- For a sheaf `F`, `F(U ⊔ V)` is the pullback of `F(U) ⟶ F(U ⊓ V)` and `F(V) ⟶ F(U ⊓ V)`.
This is the pullback cone. -/
def interUnionPullbackCone :
    PullbackCone (F.1.map (homOfLE inf_le_left : U ⊓ V ⟶ _).op)
      (F.1.map (homOfLE inf_le_right).op) :=
  PullbackCone.mk (F.1.map (homOfLE le_sup_left).op) (F.1.map (homOfLE le_sup_right).op)
    (by
      rw [← F.1.map_comp, ← F.1.map_comp]
      congr )
#align Top.sheaf.inter_union_pullback_cone TopCat.Sheaf.interUnionPullbackCone

@[simp]
theorem interUnionPullbackCone_pt : (interUnionPullbackCone F U V).pt = F.1.obj (op <| U ⊔ V) :=
  rfl
#align Top.sheaf.inter_union_pullback_cone_X TopCat.Sheaf.interUnionPullbackCone_pt

@[simp]
theorem interUnionPullbackCone_fst :
    (interUnionPullbackCone F U V).fst = F.1.map (homOfLE le_sup_left).op :=
  rfl
#align Top.sheaf.inter_union_pullback_cone_fst TopCat.Sheaf.interUnionPullbackCone_fst

@[simp]
theorem interUnionPullbackCone_snd :
    (interUnionPullbackCone F U V).snd = F.1.map (homOfLE le_sup_right).op :=
  rfl
#align Top.sheaf.inter_union_pullback_cone_snd TopCat.Sheaf.interUnionPullbackCone_snd

variable
  (s :
    PullbackCone (F.1.map (homOfLE inf_le_left : U ⊓ V ⟶ _).op) (F.1.map (homOfLE inf_le_right).op))

/-- (Implementation).
Every cone over `F(U) ⟶ F(U ⊓ V)` and `F(V) ⟶ F(U ⊓ V)` factors through `F(U ⊔ V)`.
-/
def interUnionPullbackConeLift : s.pt ⟶ F.1.obj (op (U ⊔ V)) :=
  by
  let ι : ULift.{w} walking_pair → opens X := fun j => walking_pair.cases_on j.down U V
  have hι : U ⊔ V = supᵢ ι := by
    ext
    rw [opens.coe_supr, Set.mem_unionᵢ]
    constructor
    · rintro (h | h)
      exacts[⟨⟨walking_pair.left⟩, h⟩, ⟨⟨walking_pair.right⟩, h⟩]
    · rintro ⟨⟨_ | _⟩, h⟩
      exacts[Or.inl h, Or.inr h]
  refine'
    (F.presheaf.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 ι).some.lift
        ⟨s.X,
          { app := _
            naturality' := _ }⟩ ≫
      F.1.map (eq_to_hom hι).op
  · apply Opposite.rec
    rintro ((_ | _) | (_ | _))
    exacts[s.fst, s.snd, s.fst ≫ F.1.map (hom_of_le inf_le_left).op,
      s.snd ≫ F.1.map (hom_of_le inf_le_left).op]
  rintro i j f
  induction i using Opposite.rec
  induction j using Opposite.rec
  let g : j ⟶ i := f.unop
  have : f = g.op := rfl
  clear_value g
  subst this
  rcases i with (⟨⟨_ | _⟩⟩ | ⟨⟨_ | _⟩, ⟨_⟩⟩) <;> rcases j with (⟨⟨_ | _⟩⟩ | ⟨⟨_ | _⟩, ⟨_⟩⟩) <;>
        rcases g with ⟨⟩ <;>
      dsimp <;>
    simp only [category.id_comp, s.condition, CategoryTheory.Functor.map_id, category.comp_id]
  · rw [← cancel_mono (F.1.map (eq_to_hom <| inf_comm : U ⊓ V ⟶ _).op), category.assoc,
      category.assoc]
    erw [← F.1.map_comp, ← F.1.map_comp]
    convert s.condition.symm
#align Top.sheaf.inter_union_pullback_cone_lift TopCat.Sheaf.interUnionPullbackConeLift

theorem interUnionPullbackConeLift_left :
    interUnionPullbackConeLift F U V s ≫ F.1.map (homOfLE le_sup_left).op = s.fst :=
  by
  erw [category.assoc, ← F.1.map_comp]
  exact
    (F.presheaf.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 _).some.fac _
      (op <| pairwise.single (ULift.up walking_pair.left))
#align Top.sheaf.inter_union_pullback_cone_lift_left TopCat.Sheaf.interUnionPullbackConeLift_left

theorem interUnionPullbackConeLift_right :
    interUnionPullbackConeLift F U V s ≫ F.1.map (homOfLE le_sup_right).op = s.snd :=
  by
  erw [category.assoc, ← F.1.map_comp]
  exact
    (F.presheaf.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 _).some.fac _
      (op <| pairwise.single (ULift.up walking_pair.right))
#align Top.sheaf.inter_union_pullback_cone_lift_right TopCat.Sheaf.interUnionPullbackConeLift_right

/-- For a sheaf `F`, `F(U ⊔ V)` is the pullback of `F(U) ⟶ F(U ⊓ V)` and `F(V) ⟶ F(U ⊓ V)`. -/
def isLimitPullbackCone : IsLimit (interUnionPullbackCone F U V) :=
  by
  let ι : ULift.{w} walking_pair → opens X := fun ⟨j⟩ => walking_pair.cases_on j U V
  have hι : U ⊔ V = supᵢ ι := by
    ext
    rw [opens.coe_supr, Set.mem_unionᵢ]
    constructor
    · rintro (h | h)
      exacts[⟨⟨walking_pair.left⟩, h⟩, ⟨⟨walking_pair.right⟩, h⟩]
    · rintro ⟨⟨_ | _⟩, h⟩
      exacts[Or.inl h, Or.inr h]
  apply pullback_cone.is_limit_aux'
  intro s
  use inter_union_pullback_cone_lift F U V s
  refine' ⟨_, _, _⟩
  · apply inter_union_pullback_cone_lift_left
  · apply inter_union_pullback_cone_lift_right
  · intro m h₁ h₂
    rw [← cancel_mono (F.1.map (eq_to_hom hι.symm).op)]
    apply (F.presheaf.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 ι).some.hom_ext
    apply Opposite.rec
    rintro ((_ | _) | (_ | _)) <;> rw [category.assoc, category.assoc]
    · erw [← F.1.map_comp]
      convert h₁
      apply inter_union_pullback_cone_lift_left
    · erw [← F.1.map_comp]
      convert h₂
      apply inter_union_pullback_cone_lift_right
    all_goals
      dsimp only [functor.op, pairwise.cocone_ι_app, functor.map_cone_π_app, cocone.op,
        pairwise.cocone_ι_app_2, unop_op, op_comp, nat_trans.op]
      simp_rw [F.1.map_comp, ← category.assoc]
      congr 1
      simp_rw [category.assoc, ← F.1.map_comp]
    · convert h₁
      apply inter_union_pullback_cone_lift_left
    · convert h₂
      apply inter_union_pullback_cone_lift_right
#align Top.sheaf.is_limit_pullback_cone TopCat.Sheaf.isLimitPullbackCone

/-- If `U, V` are disjoint, then `F(U ⊔ V) = F(U) × F(V)`. -/
def isProductOfDisjoint (h : U ⊓ V = ⊥) :
    IsLimit
      (BinaryFan.mk (F.1.map (homOfLE le_sup_left : _ ⟶ U ⊔ V).op)
        (F.1.map (homOfLE le_sup_right : _ ⟶ U ⊔ V).op)) :=
  isProductOfIsTerminalIsPullback _ _ _ _ (F.isTerminalOfEqEmpty h) (isLimitPullbackCone F U V)
#align Top.sheaf.is_product_of_disjoint TopCat.Sheaf.isProductOfDisjoint

/-- `F(U ⊔ V)` is isomorphic to the `eq_locus` of the two maps `F(U) × F(V) ⟶ F(U ⊓ V)`. -/
def objSupIsoProdEqLocus {X : TopCat} (F : X.Sheaf CommRingCat) (U V : Opens X) :
    F.1.obj (op <| U ⊔ V) ≅ CommRingCat.of (RingHom.eqLocus _ _) :=
  (F.isLimitPullbackCone U V).conePointUniqueUpToIso (CommRingCat.pullbackConeIsLimit _ _)
#align Top.sheaf.obj_sup_iso_prod_eq_locus TopCat.Sheaf.objSupIsoProdEqLocus

theorem objSupIsoProdEqLocus_hom_fst {X : TopCat} (F : X.Sheaf CommRingCat) (U V : Opens X) (x) :
    ((F.objSupIsoProdEqLocus U V).Hom x).1.fst = F.1.map (homOfLE le_sup_left).op x :=
  ConcreteCategory.congr_hom
    ((F.isLimitPullbackCone U V).conePointUniqueUpToIso_hom_comp
      (CommRingCat.pullbackConeIsLimit _ _) WalkingCospan.left)
    x
#align Top.sheaf.obj_sup_iso_prod_eq_locus_hom_fst TopCat.Sheaf.objSupIsoProdEqLocus_hom_fst

theorem objSupIsoProdEqLocus_hom_snd {X : TopCat} (F : X.Sheaf CommRingCat) (U V : Opens X) (x) :
    ((F.objSupIsoProdEqLocus U V).Hom x).1.snd = F.1.map (homOfLE le_sup_right).op x :=
  ConcreteCategory.congr_hom
    ((F.isLimitPullbackCone U V).conePointUniqueUpToIso_hom_comp
      (CommRingCat.pullbackConeIsLimit _ _) WalkingCospan.right)
    x
#align Top.sheaf.obj_sup_iso_prod_eq_locus_hom_snd TopCat.Sheaf.objSupIsoProdEqLocus_hom_snd

theorem objSupIsoProdEqLocus_inv_fst {X : TopCat} (F : X.Sheaf CommRingCat) (U V : Opens X) (x) :
    F.1.map (homOfLE le_sup_left).op ((F.objSupIsoProdEqLocus U V).inv x) = x.1.1 :=
  ConcreteCategory.congr_hom
    ((F.isLimitPullbackCone U V).conePointUniqueUpToIso_inv_comp
      (CommRingCat.pullbackConeIsLimit _ _) WalkingCospan.left)
    x
#align Top.sheaf.obj_sup_iso_prod_eq_locus_inv_fst TopCat.Sheaf.objSupIsoProdEqLocus_inv_fst

theorem objSupIsoProdEqLocus_inv_snd {X : TopCat} (F : X.Sheaf CommRingCat) (U V : Opens X) (x) :
    F.1.map (homOfLE le_sup_right).op ((F.objSupIsoProdEqLocus U V).inv x) = x.1.2 :=
  ConcreteCategory.congr_hom
    ((F.isLimitPullbackCone U V).conePointUniqueUpToIso_inv_comp
      (CommRingCat.pullbackConeIsLimit _ _) WalkingCospan.right)
    x
#align Top.sheaf.obj_sup_iso_prod_eq_locus_inv_snd TopCat.Sheaf.objSupIsoProdEqLocus_inv_snd

end TopCat.Sheaf


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem amc12_2000_p5
  (x p : ℝ)
  (h₀ : x < 2)
  (h₁ : abs (x - 2) = p) :
  x - p = 2 - 2 * p :=
begin
  suffices : abs (x - 2) = -(x - 2),
  {
    rw h₁ at this,
    linarith,
  },
  apply abs_of_neg,
  linarith,
end


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.pfunctor.univariate.default
import Mathlib.PostPort

universes u l u_1

namespace Mathlib

/-!

# Quotients of Polynomial Functors

We assume the following:

`P`   : a polynomial functor
`W`   : its W-type
`M`   : its M-type
`F`   : a functor

We define:

`q`   : `qpf` data, representing `F` as a quotient of `P`

The main goal is to construct:

`fix`   : the initial algebra with structure map `F fix → fix`.
`cofix` : the final coalgebra with structure map `cofix → F cofix`

We also show that the composition of qpfs is a qpf, and that the quotient of a qpf
is a qpf.

The present theory focuses on the univariate case for qpfs

## References

* [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]

-/

/--
Quotients of polynomial functors.

Roughly speaking, saying that `F` is a quotient of a polynomial functor means that for each `α`,
elements of `F α` are represented by pairs `⟨a, f⟩`, where `a` is the shape of the object and
`f` indexes the relevant elements of `α`, in a suitably natural manner.
-/
class qpf (F : Type u → Type u) [Functor F]
where
  P : pfunctor
  abs : {α : Type u} → pfunctor.obj P α → F α
  repr : {α : Type u} → F α → pfunctor.obj P α
  abs_repr : ∀ {α : Type u} (x : F α), abs (repr x) = x
  abs_map : ∀ {α β : Type u} (f : α → β) (p : pfunctor.obj P α), abs (f <$> p) = f <$> abs p

namespace qpf

/-
Show that every qpf is a lawful functor.

Note: every functor has a field, `map_const`, and is_lawful_functor has the defining
characterization. We can only propagate the assumption.
-/

theorem id_map {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) : id <$> x = x := sorry

theorem comp_map {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} {β : Type u} {γ : Type u} (f : α → β) (g : β → γ) (x : F α) : (g ∘ f) <$> x = g <$> f <$> x := sorry

theorem is_lawful_functor {F : Type u → Type u} [Functor F] [q : qpf F] (h : ∀ (α β : Type u), Functor.mapConst = Functor.map ∘ function.const β) : is_lawful_functor F :=
  is_lawful_functor.mk id_map comp_map

/-
Lifting predicates and relations
-/

theorem liftp_iff {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (p : α → Prop) (x : F α) : functor.liftp p x ↔
  ∃ (a : pfunctor.A (P F)), ∃ (f : pfunctor.B (P F) a → α), x = abs (sigma.mk a f) ∧ ∀ (i : pfunctor.B (P F) a), p (f i) := sorry

theorem liftp_iff' {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (p : α → Prop) (x : F α) : functor.liftp p x ↔ ∃ (u : pfunctor.obj (P F) α), abs u = x ∧ ∀ (i : pfunctor.B (P F) (sigma.fst u)), p (sigma.snd u i) := sorry

theorem liftr_iff {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (r : α → α → Prop) (x : F α) (y : F α) : functor.liftr r x y ↔
  ∃ (a : pfunctor.A (P F)),
    ∃ (f₀ : pfunctor.B (P F) a → α),
      ∃ (f₁ : pfunctor.B (P F) a → α),
        x = abs (sigma.mk a f₀) ∧ y = abs (sigma.mk a f₁) ∧ ∀ (i : pfunctor.B (P F) a), r (f₀ i) (f₁ i) := sorry

/-
Think of trees in the `W` type corresponding to `P` as representatives of elements of the
least fixed point of `F`, and assign a canonical representative to each equivalence class
of trees.
-/

/-- does recursion on `q.P.W` using `g : F α → α` rather than `g : P α → α` -/
def recF {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) : pfunctor.W (P F) → α :=
  sorry

theorem recF_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) (x : pfunctor.W (P F)) : recF g x = g (abs (recF g <$> pfunctor.W.dest x)) :=
  W_type.cases_on x
    fun (x_a : pfunctor.A (P F)) (x_f : pfunctor.B (P F) x_a → W_type (pfunctor.B (P F))) =>
      Eq.refl (recF g (W_type.mk x_a x_f))

theorem recF_eq' {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → pfunctor.W (P F)) : recF g (W_type.mk a f) = g (abs (recF g <$> sigma.mk a f)) :=
  rfl

/-- two trees are equivalent if their F-abstractions are -/
inductive Wequiv {F : Type u → Type u} [Functor F] [q : qpf F] : pfunctor.W (P F) → pfunctor.W (P F) → Prop
where
| ind : ∀ (a : pfunctor.A (P F)) (f f' : pfunctor.B (P F) a → pfunctor.W (P F)),
  (∀ (x : pfunctor.B (P F) a), Wequiv (f x) (f' x)) → Wequiv (W_type.mk a f) (W_type.mk a f')
| abs : ∀ (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → pfunctor.W (P F)) (a' : pfunctor.A (P F))
  (f' : pfunctor.B (P F) a' → pfunctor.W (P F)),
  abs (sigma.mk a f) = abs (sigma.mk a' f') → Wequiv (W_type.mk a f) (W_type.mk a' f')
| trans : ∀ (u v w : pfunctor.W (P F)), Wequiv u v → Wequiv v w → Wequiv u w

/-- recF is insensitive to the representation -/
theorem recF_eq_of_Wequiv {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (u : F α → α) (x : pfunctor.W (P F)) (y : pfunctor.W (P F)) : Wequiv x y → recF u x = recF u y := sorry

theorem Wequiv.abs' {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F)) (y : pfunctor.W (P F)) (h : abs (pfunctor.W.dest x) = abs (pfunctor.W.dest y)) : Wequiv x y := sorry

theorem Wequiv.refl {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F)) : Wequiv x x :=
  W_type.cases_on x
    fun (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → W_type (pfunctor.B (P F))) => Wequiv.abs a f a f rfl

theorem Wequiv.symm {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F)) (y : pfunctor.W (P F)) : Wequiv x y → Wequiv y x := sorry

/-- maps every element of the W type to a canonical representative -/
def Wrepr {F : Type u → Type u} [Functor F] [q : qpf F] : pfunctor.W (P F) → pfunctor.W (P F) :=
  recF (pfunctor.W.mk ∘ repr)

theorem Wrepr_equiv {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F)) : Wequiv (Wrepr x) x := sorry

/--
Define the fixed point as the quotient of trees under the equivalence relation `Wequiv`.
-/
def W_setoid {F : Type u → Type u} [Functor F] [q : qpf F] : setoid (pfunctor.W (P F)) :=
  setoid.mk Wequiv sorry

/-- inductive type defined as initial algebra of a Quotient of Polynomial Functor -/
def fix (F : Type u → Type u) [Functor F] [q : qpf F] :=
  quotient W_setoid

/-- recursor of a type defined by a qpf -/
def fix.rec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) : fix F → α :=
  Quot.lift (recF g) (recF_eq_of_Wequiv g)

/-- access the underlying W-type of a fixpoint data type -/
def fix_to_W {F : Type u → Type u} [Functor F] [q : qpf F] : fix F → pfunctor.W (P F) :=
  quotient.lift Wrepr sorry

/-- constructor of a type defined by a qpf -/
def fix.mk {F : Type u → Type u} [Functor F] [q : qpf F] (x : F (fix F)) : fix F :=
  Quot.mk setoid.r (pfunctor.W.mk (fix_to_W <$> repr x))

/-- destructor of a type defined by a qpf -/
def fix.dest {F : Type u → Type u} [Functor F] [q : qpf F] : fix F → F (fix F) :=
  fix.rec (Functor.map fix.mk)

theorem fix.rec_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) (x : F (fix F)) : fix.rec g (fix.mk x) = g (fix.rec g <$> x) := sorry

theorem fix.ind_aux {F : Type u → Type u} [Functor F] [q : qpf F] (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → pfunctor.W (P F)) : fix.mk (abs (sigma.mk a fun (x : pfunctor.B (P F) a) => quotient.mk (f x))) = quotient.mk (W_type.mk a f) := sorry

theorem fix.ind_rec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g₁ : fix F → α) (g₂ : fix F → α) (h : ∀ (x : F (fix F)), g₁ <$> x = g₂ <$> x → g₁ (fix.mk x) = g₂ (fix.mk x)) (x : fix F) : g₁ x = g₂ x := sorry

theorem fix.rec_unique {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) (h : fix F → α) (hyp : ∀ (x : F (fix F)), h (fix.mk x) = g (h <$> x)) : fix.rec g = h := sorry

theorem fix.mk_dest {F : Type u → Type u} [Functor F] [q : qpf F] (x : fix F) : fix.mk (fix.dest x) = x := sorry

theorem fix.dest_mk {F : Type u → Type u} [Functor F] [q : qpf F] (x : F (fix F)) : fix.dest (fix.mk x) = x := sorry

theorem fix.ind {F : Type u → Type u} [Functor F] [q : qpf F] (p : fix F → Prop) (h : ∀ (x : F (fix F)), functor.liftp p x → p (fix.mk x)) (x : fix F) : p x := sorry

end qpf

/-
Construct the final coalgebra to a qpf.
-/

namespace qpf

/-- does recursion on `q.P.M` using `g : α → F α` rather than `g : α → P α` -/
def corecF {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α) : α → pfunctor.M (P F) :=
  pfunctor.M.corec fun (x : α) => repr (g x)

theorem corecF_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α) (x : α) : pfunctor.M.dest (corecF g x) = corecF g <$> repr (g x) := sorry

/- Equivalence -/

/-- A pre-congruence on q.P.M *viewed as an F-coalgebra*. Not necessarily symmetric. -/
def is_precongr {F : Type u → Type u} [Functor F] [q : qpf F] (r : pfunctor.M (P F) → pfunctor.M (P F) → Prop) :=
  ∀ {x y : pfunctor.M (P F)}, r x y → abs (Quot.mk r <$> pfunctor.M.dest x) = abs (Quot.mk r <$> pfunctor.M.dest y)

/-- The maximal congruence on q.P.M -/
def Mcongr {F : Type u → Type u} [Functor F] [q : qpf F] : pfunctor.M (P F) → pfunctor.M (P F) → Prop :=
  fun (x y : pfunctor.M (P F)) => ∃ (r : pfunctor.M (P F) → pfunctor.M (P F) → Prop), is_precongr r ∧ r x y

/-- coinductive type defined as the final coalgebra of a qpf -/
def cofix (F : Type u → Type u) [Functor F] [q : qpf F] :=
  Quot Mcongr

protected instance cofix.inhabited {F : Type u → Type u} [Functor F] [q : qpf F] [Inhabited (pfunctor.A (P F))] : Inhabited (cofix F) :=
  { default := Quot.mk Mcongr Inhabited.default }

/-- corecursor for type defined by `cofix` -/
def cofix.corec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α) (x : α) : cofix F :=
  Quot.mk Mcongr (corecF g x)

/-- destructor for type defined by `cofix` -/
def cofix.dest {F : Type u → Type u} [Functor F] [q : qpf F] : cofix F → F (cofix F) :=
  Quot.lift (fun (x : pfunctor.M (P F)) => Quot.mk Mcongr <$> abs (pfunctor.M.dest x)) sorry

theorem cofix.dest_corec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α) (x : α) : cofix.dest (cofix.corec g x) = cofix.corec g <$> g x := sorry

theorem cofix.bisim_rel {F : Type u → Type u} [Functor F] [q : qpf F] (r : cofix F → cofix F → Prop) (h : ∀ (x y : cofix F), r x y → Quot.mk r <$> cofix.dest x = Quot.mk r <$> cofix.dest y) (x : cofix F) (y : cofix F) : r x y → x = y := sorry

theorem cofix.bisim {F : Type u → Type u} [Functor F] [q : qpf F] (r : cofix F → cofix F → Prop) (h : ∀ (x y : cofix F), r x y → functor.liftr r (cofix.dest x) (cofix.dest y)) (x : cofix F) (y : cofix F) : r x y → x = y := sorry

theorem cofix.bisim' {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u_1} (Q : α → Prop) (u : α → cofix F) (v : α → cofix F) (h : ∀ (x : α),
  Q x →
    ∃ (a : pfunctor.A (P F)),
      ∃ (f : pfunctor.B (P F) a → cofix F),
        ∃ (f' : pfunctor.B (P F) a → cofix F),
          cofix.dest (u x) = abs (sigma.mk a f) ∧
            cofix.dest (v x) = abs (sigma.mk a f') ∧
              ∀ (i : pfunctor.B (P F) a), ∃ (x' : α), Q x' ∧ f i = u x' ∧ f' i = v x') (x : α) : Q x → u x = v x := sorry

end qpf

/-
Composition of qpfs.
-/

namespace qpf

/-- composition of qpfs gives another qpf  -/
def comp {F₂ : Type u → Type u} [Functor F₂] [q₂ : qpf F₂] {F₁ : Type u → Type u} [Functor F₁] [q₁ : qpf F₁] : qpf (functor.comp F₂ F₁) :=
  mk (pfunctor.comp (P F₂) (P F₁))
    (fun (α : Type u) =>
      id
        fun (p : pfunctor.obj (pfunctor.comp (P F₂) (P F₁)) α) =>
          abs
            (sigma.mk (sigma.fst (sigma.fst p))
              fun (x : pfunctor.B (P F₂) (sigma.fst (sigma.fst p))) =>
                abs
                  (sigma.mk (sigma.snd (sigma.fst p) x)
                    fun (y : pfunctor.B (P F₁) (sigma.snd (sigma.fst p) x)) => sigma.snd p (sigma.mk x y))))
    (fun (α : Type u) =>
      id
        fun (y : F₂ (F₁ α)) =>
          sigma.mk
            (sigma.mk (sigma.fst (repr y))
              fun (u : pfunctor.B (P F₂) (sigma.fst (repr y))) => sigma.fst (repr (sigma.snd (repr y) u)))
            (id
              fun
                (x :
                sigma
                  fun (u : pfunctor.B (P F₂) (sigma.fst (repr y))) =>
                    pfunctor.B (P F₁) (sigma.fst (repr (sigma.snd (repr y) u)))) =>
                sigma.snd (repr (sigma.snd (repr y) (sigma.fst x))) (sigma.snd x)))
    sorry sorry

end qpf

/-
Quotients.

We show that if `F` is a qpf and `G` is a suitable quotient of `F`, then `G` is a qpf.
-/

namespace qpf

/-- Given a qpf `F` and a well-behaved surjection `FG_abs` from F α to
functor G α, `G` is a qpf. We can consider `G` a quotient on `F` where
elements `x y : F α` are in the same equivalence class if
`FG_abs x = FG_abs y`  -/
def quotient_qpf {F : Type u → Type u} [Functor F] [q : qpf F] {G : Type u → Type u} [Functor G] {FG_abs : {α : Type u} → F α → G α} {FG_repr : {α : Type u} → G α → F α} (FG_abs_repr : ∀ {α : Type u} (x : G α), FG_abs (FG_repr x) = x) (FG_abs_map : ∀ {α β : Type u} (f : α → β) (x : F α), FG_abs (f <$> x) = f <$> FG_abs x) : qpf G :=
  mk (P F) (fun {α : Type u} (p : pfunctor.obj (P F) α) => FG_abs (abs p))
    (fun {α : Type u} (x : G α) => repr (FG_repr x)) sorry sorry

end qpf

/-
Support.
-/

namespace qpf

theorem mem_supp {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) (u : α) : u ∈ functor.supp x ↔ ∀ (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α), abs (sigma.mk a f) = x → u ∈ f '' set.univ := sorry

theorem supp_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) : functor.supp x =
  set_of
    fun (u : α) => ∀ (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α), abs (sigma.mk a f) = x → u ∈ f '' set.univ :=
  set.ext fun (x_1 : α) => mem_supp x x_1

theorem has_good_supp_iff {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) : (∀ (p : α → Prop), functor.liftp p x ↔ ∀ (u : α), u ∈ functor.supp x → p u) ↔
  ∃ (a : pfunctor.A (P F)),
    ∃ (f : pfunctor.B (P F) a → α),
      abs (sigma.mk a f) = x ∧
        ∀ (a' : pfunctor.A (P F)) (f' : pfunctor.B (P F) a' → α),
          abs (sigma.mk a' f') = x → f '' set.univ ⊆ f' '' set.univ := sorry

/-- A qpf is said to be uniform if every polynomial functor
representing a single value all have the same range. -/
def is_uniform {F : Type u → Type u} [Functor F] (q : qpf F) :=
  ∀ {α : Type u} (a a' : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α) (f' : pfunctor.B (P F) a' → α),
    abs (sigma.mk a f) = abs (sigma.mk a' f') → f '' set.univ = f' '' set.univ

/-- does `abs` preserve `liftp`? -/
def liftp_preservation {F : Type u → Type u} [Functor F] (q : qpf F) :=
  ∀ {α : Type u} (p : α → Prop) (x : pfunctor.obj (P F) α), functor.liftp p (abs x) ↔ functor.liftp p x

/-- does `abs` preserve `supp`? -/
def supp_preservation {F : Type u → Type u} [Functor F] (q : qpf F) :=
  ∀ {α : Type u} (x : pfunctor.obj (P F) α), functor.supp (abs x) = functor.supp x

theorem supp_eq_of_is_uniform {F : Type u → Type u} [Functor F] [q : qpf F] (h : is_uniform q) {α : Type u} (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α) : functor.supp (abs (sigma.mk a f)) = f '' set.univ := sorry

theorem liftp_iff_of_is_uniform {F : Type u → Type u} [Functor F] [q : qpf F] (h : is_uniform q) {α : Type u} (x : F α) (p : α → Prop) : functor.liftp p x ↔ ∀ (u : α), u ∈ functor.supp x → p u := sorry

theorem supp_map {F : Type u → Type u} [Functor F] [q : qpf F] (h : is_uniform q) {α : Type u} {β : Type u} (g : α → β) (x : F α) : functor.supp (g <$> x) = g '' functor.supp x := sorry

theorem supp_preservation_iff_uniform {F : Type u → Type u} [Functor F] [q : qpf F] : supp_preservation q ↔ is_uniform q := sorry

theorem supp_preservation_iff_liftp_preservation {F : Type u → Type u} [Functor F] [q : qpf F] : supp_preservation q ↔ liftp_preservation q := sorry

theorem liftp_preservation_iff_uniform {F : Type u → Type u} [Functor F] [q : qpf F] : liftp_preservation q ↔ is_uniform q := sorry


import .quantum_state
import .helper_lemmas

namespace quantum

variables {n m p q : ℕ}

/-
  The tensor product of multiple particles' states contains all the information
  about the particles. The particles are said to be be independent when
  the state is factorable into a tensor prouct of the two states and said
  to be entangled when it is not.
-/

@[reducible]
def mk_fin_div {m p : ℕ} (i : fin (m*p)) : fin m :=
  @fin.mk m ((i : ℕ)/p) (fin_div m_pos p_pos i)

@[reducible]
def mk_fin_mod {m p : ℕ} (i : fin (m*p)) : fin p :=
  @fin.mk p ((i : ℕ)%p) (fin_mod i p_pos)

def tensor_prod (A : matrix (fin m) (fin n) ℂ) (B : matrix (fin p) (fin q) ℂ) : matrix (fin (m * p)) (fin (n * q)) ℂ :=
 λi j, (A (@mk_fin_div m p i) (@mk_fin_div n q j))
  * (B (@mk_fin_mod m p i) (@mk_fin_mod n q j))

infixl ` ⊗ `: 150 := tensor_prod

-- special case of tensor product for 2D vectors (spin 1/2 particles)
lemma tensor_prod_vec (A B : QState 2 1) :
  A ⊗ B = !![(A 0 0) * (B 0 0); (A 0 0) * (B 1 0); (A 1 0) * (B 0 0); (A 1 0) * (B 1 0)] :=
begin
  rw [tensor_prod],
  funext i j,
  fin_cases *; simp [anon_0_fin4]; fin_cases *; simp [anon_0_fin1, mk_fin_div, mk_fin_mod],
  {apply or.intro_left,
   rw [anon_half_fin2]},
  {rw [fn_is_vec, matrix.cons_append, matrix.empty_append],
   simp [anon_1_fin4]},
  {simp [matrix.vec_head, matrix.cons_append],
   rw [anon_three_halves_fin2, anon_3_mod_2_fin2]}
end

def z_plus_z_plus : QState 4 1 := |z₊⟩ ⊗ |z₊⟩
def z_minus_z_plus : QState 4 1 := |z₋⟩ ⊗ |z₊⟩
def z_plus_z_minus : QState 4 1 := |z₊⟩ ⊗ |z₋⟩
def z_minus_z_minus : QState 4 1 := |z₋⟩ ⊗ |z₋⟩

notation `|z₊z₊⟩` := z_plus_z_plus
notation `|z₋z₊⟩` := z_minus_z_plus
notation `|z₊z₋⟩` := z_plus_z_minus
notation `|z₋z₋⟩` := z_minus_z_minus

end quantum


import covering_space.def

variables {X X' Y : Type _} [topological_space X] [topological_space X'] [topological_space Y]

lemma is_open_f₀_eq_f₁ {p : C(X', X)} (hp : is_covering_map p) {f : C(Y, X)} {f₀ f₁ : C(Y, X')}
  (hf₀ : p.comp f₀ = f) (hf₁ : p.comp f₁ = f) :
  is_open {y | f₀ y = f₁ y} :=
begin
  let S := {y | f₀ y = f₁ y},
  rw is_open_iff_forall_mem_open,
  rintros y (hy : f₀ y = f₁ y),
  let U := hp.U (f y),
  let Vs := hp.cover (f y),
  have : f₀ y ∈ p ⁻¹' U,
  { rw [set.mem_preimage, ←p.comp_apply, hf₀],
    exact hp.mem_U _ },
  rw [hp.preimage, set.mem_sUnion] at this,
  rcases this with ⟨W, hW₁, hW₂⟩,
  let N := f₀ ⁻¹' W ∩ f₁ ⁻¹' W,
  rcases hp.homeo (f y) W hW₁ with ⟨p', hp'₀, hp'₁, hp'₂⟩,
  refine ⟨N, _, _, _⟩,
  { intros n hn,
    show f₀ n = f₁ n,
    have h₀ : f₀ n ∈ W := hn.1,
    have h₁ : f₁ n ∈ W := hn.2,
    apply p'.inj_on _ _,
    { rw [hp'₂ (f₀ n) ‹_›, hp'₂ (f₁ n) ‹_›, ←p.comp_apply, ←p.comp_apply, hf₀, hf₁] },
    { rwa hp'₀ },
    { rwa hp'₀ } },
  have hWopen : is_open W,
  { rw ←hp'₀,
    exact p'.open_source },
  { apply is_open.inter,
    { apply continuous.is_open_preimage f₀.continuous,
      exact hWopen },
    { apply continuous.is_open_preimage f₁.continuous,
      exact hWopen } },
  { refine ⟨hW₂, _⟩,
    rwa [set.mem_preimage, ←hy] }
end

lemma is_closed_f₀_eq_f₁ {p : C(X', X)} (hp : is_covering_map p) {f : C(Y, X)} {f₀ f₁ : C(Y, X')}
  (hf₀ : p.comp f₀ = f) (hf₁ : p.comp f₁ = f) :
  is_closed {y | f₀ y = f₁ y} :=
begin
  rw is_closed_iff_nhds,
  intros y hy,
  let U := hp.U (f y),
  have h₀ : f₀ y ∈ p ⁻¹' U,
  { rw [set.mem_preimage, ←p.comp_apply, hf₀],
    exact hp.mem_U _ },
  have h₁ : f₁ y ∈ p ⁻¹' U,
  { rw [set.mem_preimage, ←p.comp_apply, hf₁],
    exact hp.mem_U _ },
  rw [hp.preimage, set.mem_sUnion] at h₀ h₁,
  rcases ⟨h₀, h₁⟩ with ⟨⟨V₀, hV₀, hV₀'⟩, V₁, hV₁, hV₁'⟩,
  rcases hp.homeo (f y) V₀ hV₀ with ⟨p', hp'₀, hp'₁, hp'₂⟩,
  rcases hp.homeo (f y) V₁ hV₁ with ⟨q', hq'₀, hq'₁, hq'₂⟩,
  let N := f₀ ⁻¹' V₀ ∩ f₁ ⁻¹' V₁,
  have hNnhds : N ∈ nhds y,
  { rw mem_nhds_iff,
    refine ⟨N, set.subset.refl _, _, _⟩,
    { apply is_open.inter,
      { apply continuous.is_open_preimage f₀.continuous,
        rw ←hp'₀,
        exact p'.open_source },
      { apply continuous.is_open_preimage f₁.continuous,
        rw ←hq'₀,
        exact q'.open_source } },
    exact ⟨hV₀', hV₁'⟩ },
  rcases hy _ hNnhds with ⟨t, ⟨ht₀ : f₀ t ∈ V₀, ht₁ : f₁ t ∈ V₁⟩, ht₂ : f₀ t = f₁ t⟩,
  have hVeq := (hp.disj (f y)).elim hV₀ hV₁ (f₀ t) ht₀ (ht₂.symm ▸ ht₁),
  apply p'.inj_on _ _,
  { rw [hp'₂ _ hV₀', hp'₂ _ (hVeq.symm ▸ hV₁' : f₁ y ∈ V₀), ←p.comp_apply, ←p.comp_apply, hf₀,
        hf₁] },
  { rwa hp'₀ },
  { rwa [hp'₀, hVeq] }
end

section

variable [connected_space Y]

lemma lift_unique (p : C(X', X)) (hp : is_covering_map p) (f : C(Y, X)) (f₀ f₁ : C(Y, X'))
  (hf₀ : p.comp f₀ = f) (hf₁ : p.comp f₁ = f) (y₀ : Y) (hy₀ : f₀ y₀ = f₁ y₀) (y : Y) :
  f₀ y = f₁ y :=
begin
  let S := {y | f₀ y = f₁ y},
  suffices : S = set.univ,
  { rw set.eq_univ_iff_forall at this,
    exact this y },
  exact eq_univ_of_nonempty_clopen ⟨y₀, hy₀⟩ ⟨is_open_f₀_eq_f₁ hp hf₀ hf₁, is_closed_f₀_eq_f₁ hp hf₀ hf₁⟩,
end

end

-- example (p : C(X', X)) (hp : is_covering_map p) (h : C(Y × ℝ, X)) (f₀ : C(Y, X')) (heq : ∀ y, h (y, 0) = p (f₀ y)) :
--   ∃ k : C(Y × ℝ, X'), (∀ y, k (y, 0) = f₀ y) ∧ (∀ z, h z = p (k z)) :=
-- begin
--   have : ∀ y, ∃ (V : set Y) (k : C(Y × ℝ, X')), is_open V ∧ y ∈ V ∧ (∀ z ∈ V, k (z, 0) = f₀ z) ∧ (∀ z, h z = p (k z)),
--   {  }
-- end

example (p : C(X', X)) (hp : is_covering_map p) (x₀' : X') (x₀ : X) (hp₀ : p x₀' = x₀) (f : C(ℝ, X))
  (hf : f 0 = x₀) : true :=
begin
  -- First, we obtain an open cover of X
  let Us := set.range hp.U,
  have hUopen : ∀ U ∈ Us, is_open U,
  { rintro U ⟨t, rfl⟩,
    exact hp.is_open_U _ },
  -- The preimage of each of the sets will be an open cover of ℝ
  let Vs := (λ t, f ⁻¹' t) '' Us,
  have hVopen : ∀ V ∈ Vs, is_open V,
  { rintro V ⟨U, hU₁, rfl⟩,
    exact f.continuous.is_open_preimage U (hUopen _ hU₁) },
  have hVcover : ⋃₀ Vs = set.univ,
  { rw set.eq_univ_iff_forall,
    intros x,
    let U := hp.U (f x),
    let V := f ⁻¹' U,
    refine ⟨V, ⟨U, ⟨f x, rfl⟩, rfl⟩, hp.mem_U _⟩ },
  -- Using the Lebesgue number lemma, we have some ε > 0 such that intervals of length < ε
  -- (contained in I) are contained in some element of `Vs`
  let I : set ℝ := set.Icc 0 1,
  have hIcompact : is_compact I := is_compact_Icc,
  rcases lebesgue_number_lemma_sUnion hIcompact hVopen (hVcover.symm ▸ set.subset_univ _) with
    ⟨ns, hnsunif, hns⟩,
  rw metric.mem_uniformity_dist at hnsunif,
  rcases hnsunif with ⟨ε, hεpos, hε⟩,
  -- Let k = 1/(N + 1) < ε.
  rcases exists_nat_one_div_lt hεpos with ⟨N, hN⟩,
  -- Then note that each [nk, (n + 1)k] is contained in some element of `Vs`
  let k : ℝ := 1 / (N + 1),
  have hk : ∀ n < N, ∃ U ∈ Us, f '' set.Icc (n * k) ((n + 1) * k) ⊆ U,
  { rintro n hnN,
    have : (n : ℝ) * k ∈ I,
    { split,
      { apply mul_nonneg (nat.cast_nonneg n),
        rw one_div_nonneg,
        linarith [@nat.cast_nonneg ℝ _ N] },
      { change k with 1 / ((N : ℝ) + 1),
        rw [mul_one_div, div_le_one],
        { norm_cast, linarith },
        { linarith [@nat.cast_nonneg ℝ _ N] } } },
    rcases hns _ this with ⟨V, ⟨U, hU, rfl⟩, hV₂⟩,
    use [U, hU],
    sorry
     }
  -- Now we define a function `f' : R → X'`, by constructing it consecutively.
end


import ..logic .qfree .wf .remove_neg

-- Requires : nqfree arg
-- Ensures : nqfree ret
def push_neg : formula → formula
| ⊤' := ⊥'
| ⊥' := ⊤'
| (A' a) := A' (remove_neg a)
| (¬' p) := ⊥'
| (p ∨' q) := push_neg p ∧' push_neg q
| (p ∧' q) := push_neg p ∨' push_neg q
| (∃' p) := ⊥'

lemma nqfree_push_neg :
  ∀ {p : formula}, nqfree p → nqfree (push_neg p)
| ⊤' h := trivial
| ⊥' h := trivial
| (A' a) h := trivial
| (¬' p) h := by cases h
| (p ∨' q) h := begin cases h, constructor; apply nqfree_push_neg; assumption end
| (p ∧' q) h := begin cases h, constructor; apply nqfree_push_neg; assumption end
| (∃' p) h := by cases h

-- Requires : qfree arg
-- Ensures : nqfree ret
def nnf : formula → formula
| (formula.true) := ⊤'
| (formula.false) := ⊥'
| (formula.atom a) := A' a
| (formula.not p) := push_neg (nnf p)
| (formula.or p q) := formula.or (nnf p) (nnf q)
| (formula.and p q) := formula.and (nnf p) (nnf q)
| (formula.ex p) := ⊥'

lemma nqfree_nnf :
  ∀ {p : formula}, qfree p → nqfree (nnf p)
| ⊤' _ := trivial
| ⊥' _ := trivial
| (A' _) _ := trivial
| (¬' p) h :=
  begin apply nqfree_push_neg (nqfree_nnf _), apply h end
| (p ∧' q) h :=
  begin
    cases h, simp [nnf], constructor;
    apply nqfree_nnf; assumption
  end
| (p ∨' q) h :=
  begin
    cases h, simp [nnf], constructor;
    apply nqfree_nnf; assumption
  end

lemma wf_push_neg : ∀ {p : formula}, nqfree p → p.wf → (push_neg p).wf
| ⊤' h1 h2 := trivial
| ⊥' h1 h2 := trivial
| (A' a) h1 h2 := begin apply wf_remove_neg, apply h2 end
| (¬' p) h1 h2 := by cases h1
| (p ∨' q) h1 h2 :=
  begin
    cases h1, cases h2, constructor;
    apply wf_push_neg; assumption
  end
| (p ∧' q) h1 h2 :=
  begin
    cases h1, cases h2, constructor;
    apply wf_push_neg; assumption
  end
| (∃' p) h1 h2 := by cases h1

lemma wf_nnf : ∀ {p : formula}, qfree p → p.wf → (nnf p).wf
| ⊤' h1 h2 := trivial
| ⊥' h1 h2 := trivial
| (A' a) h1 h2 := h2
| (¬' p) h1 h2 :=
  begin
    apply wf_push_neg (nqfree_nnf _),
    apply wf_nnf, apply h1, apply h2, apply h1
  end
| (p ∨' q) h1 h2 :=
  begin
    cases h1, cases h2, constructor;
    apply wf_nnf; assumption
  end
| (p ∧' q) h1 h2 :=
  begin
    cases h1, cases h2, constructor;
    apply wf_nnf; assumption
  end
| (∃' p) h1 h2 := by cases h1

lemma eval_push_neg  :
  ∀ {p : formula}, nqfree p →
    ∀ {xs : list znum}, (push_neg p).eval xs ↔ ¬ (p.eval xs)
| ⊤' h xs := begin simp [push_neg, formula.eval] end
| ⊥' h xs := begin simp [push_neg, formula.eval] end
| (A' a) h xs :=
  begin
    simp [push_neg, formula.eval],
    apply eval_remove_neg,
  end
| (p ∧' q) h xs :=
  begin
    cases h, simp only [push_neg, formula.eval, eval_not_and],
    rw (@not_and_distrib _ _ (classical.dec _)),
    apply or_iff_or; apply eval_push_neg; assumption
  end
| (p ∨' q) h xs :=
  begin
    cases h, simp only [push_neg, formula.eval, not_or_distrib],
    apply and_iff_and; apply eval_push_neg; assumption
  end

lemma eval_nnf  :
  ∀ {p : formula}, qfree p →
    ∀ {xs : list znum}, ((nnf p).eval xs ↔ p.eval xs)
| ⊤' hf xs := iff.refl _
| ⊥' hf xs := iff.refl _
| (A' a) h xs := iff.refl _
| (¬' p) h xs :=
  begin
    simp [nnf, formula.eval],
    rw eval_push_neg (nqfree_nnf _),
    rw eval_nnf, apply h, apply h
  end
| (p ∧' q) hf xs :=
  begin
    cases hf, simp [nnf, formula.eval],
    apply and_iff_and; apply eval_nnf; assumption
  end
| (p ∨' q) hf xs :=
  begin
    cases hf, simp [nnf, formula.eval],
    apply or_iff_or; apply eval_nnf; assumption
  end

#exit
def nnf : formula → formula
| (formula.true) := formula.true
| (formula.false) := formula.false
| (formula.atom a) := formula.atom a
| (formula.not (formula.true)) := formula.false
| (formula.not (formula.false)) := formula.true
| (formula.not (formula.atom a)) := formula.atom (remove_neg a)
| (formula.not (formula.not p)) := nnf p
| (formula.not (formula.or p q)) := formula.and (nnf p.not) (nnf q.not)
| (formula.not (formula.and p q)) := formula.or (nnf p.not) (nnf q.not)
| (formula.not (formula.ex p)) := formula.false
| (formula.or p q) := formula.or (nnf p) (nnf q)
| (formula.and p q) := formula.and (nnf p) (nnf q)
| (formula.ex p) := formula.false

| (formula.true) _ _ := and.intro trivial trivial
| (formula.false) _ _ := and.intro trivial trivial
| (formula.atom a) _ h :=
  begin
    simp [nnf, formula.wf] at *, apply and.intro h,
    apply wf_remove_neg h,
  end
| (¬' p) hf hn :=
  begin
    cases (@wf_nnf_core p hf hn),
    simp [nnf], constructor; assumption
  end
| (formula.and p q) hf hn := by wf_nnf_core_tac
| (formula.or  p q) hf hn := by wf_nnf_core_tac

#exit
-- Requires : nqfree arg
-- Ensures : nqfree ret

meta def nqfree_nnf_core_aux :=
`[ cases h with hp hq, simp [nnf, nqfree],
    cases (nqfree_nnf_core hp),
    cases (nqfree_nnf_core hq),
    constructor; constructor; assumption ]

lemma nqfree_nnf_core :
  ∀ {p : formula}, qfree p → (nqfree (nnf p) ∧ nqfree (nnf ¬' p))
| ⊤' _ := and.intro trivial trivial
| ⊥' _ := and.intro trivial trivial
| (A' _) _ := begin constructor; simp [nnf] end
| (¬' p) h :=
  begin
    cases (@nqfree_nnf_core p h),
    simp [nnf], constructor; assumption,
  end
| (p ∧' q) h := by nqfree_nnf_core_aux
| (p ∨' q) h := by nqfree_nnf_core_aux

lemma nqfree_nnf  :
  ∀ {p : formula}, qfree p → nqfree (nnf p) :=
λ p h, (nqfree_nnf_core h).left

meta def wf_nnf_core_tac :=
`[ cases hf with hfp hfq, cases hn with hnp hnq,
   simp [formula.wf, nnf],
   cases (@wf_nnf_core p hfp hnp),
   cases (@wf_nnf_core q hfq hnq),
   constructor; constructor; assumption ]

lemma wf_nnf_core  :
  ∀ {p : formula}, qfree p → p.wf
    → (nnf p).wf ∧ (nnf ¬' p).wf
| (formula.true) _ _ := and.intro trivial trivial
| (formula.false) _ _ := and.intro trivial trivial
| (formula.atom a) _ h :=
  begin
    simp [nnf, formula.wf] at *, apply and.intro h,
    apply wf_remove_neg h,
  end
| (¬' p) hf hn :=
  begin
    cases (@wf_nnf_core p hf hn),
    simp [nnf], constructor; assumption
  end
| (formula.and p q) hf hn := by wf_nnf_core_tac
| (formula.or  p q) hf hn := by wf_nnf_core_tac

lemma wf_nnf  {p : formula}
(hf : qfree p) (hn : p.wf) : (nnf p).wf :=
(wf_nnf_core hf hn)^.elim_left

open formula

lemma eval_nnf_core  :
  ∀ {p : formula}, qfree p →
    ∀ {xs : list znum},
      (eval xs (nnf p) ↔ eval xs p)
    ∧ (eval xs (nnf (¬' p)) ↔ eval xs (¬' p))
| ⊤' hf xs := and.intro (by refl) (by {simp [nnf, formula.eval]})
| ⊥' hf xs := and.intro (by refl) (by {simp [nnf, formula.eval]})
| (A' a) hf xs :=
  begin
    apply and.intro; simp [nnf, formula.eval],
    apply eval_remove_neg,
  end
| (¬' p) hf xs :=
  begin
    cases (@eval_nnf_core p hf xs),
    constructor, assumption,
    simp [nnf, eval_not, left, not_not_iff],
  end
| (p ∧' q) hf xs :=
  begin
    cases (@eval_nnf_core _ hf.left  xs),
    cases (@eval_nnf_core _ hf.right  xs),
    simp [nnf, eval_and], constructor;
    [
      {apply and_iff_and; assumption},
      {
        rw [eval_not, eval_and, @not_and_distrib _ _ (classical.dec _)],
        simp [eval_or], apply or_iff_or; assumption
      }
    ]
  end
| (p ∨' q) hf xs :=
  begin
    cases (@eval_nnf_core _ hf.left xs),
    cases (@eval_nnf_core _ hf.right xs),
    simp [nnf, eval_and], constructor;
    [
      {apply or_iff_or; assumption},
      {
        rw [eval_not, eval_or, not_or_distrib],
        apply and_iff_and; assumption
      }
    ]
  end

lemma eval_nnf {p : formula} (h : qfree p) {xs : list znum} :
  (nnf p).eval xs ↔ p.eval xs :=
(eval_nnf_core h)^.elim_left