/-
Copyright (c) 2020 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa, Jujian Zhang

! This file was ported from Lean 3 source module number_theory.liouville.basic
! leanprover-community/mathlib commit 62c0a4ef1441edb463095ea02a06e87f3dfe135c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Calculus.MeanValue
import Mathbin.Data.Polynomial.DenomsClearable
import Mathbin.Data.Real.Irrational

/-!

# Liouville's theorem

This file contains a proof of Liouville's theorem stating that all Liouville numbers are
transcendental.

To obtain this result, there is first a proof that Liouville numbers are irrational and two
technical lemmas.  These lemmas exploit the fact that a polynomial with integer coefficients
takes integer values at integers.  When evaluating at a rational number, we can clear denominators
and obtain precise inequalities that ultimately allow us to prove transcendence of
Liouville numbers.
-/

/-- A Liouville number is a real number `x` such that for every natural number `n`, there exist
`a, b ∈ ℤ` with `1 < b` such that `0 < |x - a/b| < 1/bⁿ`.
In the implementation, the condition `x ≠ a/b` replaces the traditional equivalent `0 < |x - a/b|`.
-/
def Liouville (x : ℝ) :=
  ∀ n : ℕ, ∃ a b : ℤ, 1 < b ∧ x ≠ a / b ∧ |x - a / b| < 1 / b ^ n
#align liouville Liouville

namespace Liouville

@[protected]
theorem irrational {x : ℝ} (h : Liouville x) : Irrational x :=
  by
  -- By contradiction, `x = a / b`, with `a ∈ ℤ`, `0 < b ∈ ℕ` is a Liouville number,
  rintro ⟨⟨a, b, bN0, cop⟩, rfl⟩
  -- clear up the mess of constructions of rationals
  rw [Rat.cast_mk', ← div_eq_mul_inv] at h
  -- Since `a / b` is a Liouville number, there are `p, q ∈ ℤ`, with `q1 : 1 < q`,
  -- `a0 : a / b ≠ p / q` and `a1 : |a / b - p / q| < 1 / q ^ (b + 1)`
  rcases h (b + 1) with ⟨p, q, q1, a0, a1⟩
  -- A few useful inequalities
  have qR0 : (0 : ℝ) < q := int.cast_pos.mpr (zero_lt_one.trans q1)
  have b0 : (b : ℝ) ≠ 0 := ne_of_gt (nat.cast_pos.mpr bN0)
  have bq0 : (0 : ℝ) < b * q := mul_pos (nat.cast_pos.mpr bN0) qR0
  -- At a1, clear denominators...
  replace a1 : |a * q - b * p| * q ^ (b + 1) < b * q;
  ·
    rwa [div_sub_div _ _ b0 (ne_of_gt qR0), abs_div,
      div_lt_div_iff (abs_pos.mpr (ne_of_gt bq0)) (pow_pos qR0 _), abs_of_pos bq0, one_mul,
      ←-- ... and revert to integers
      Int.cast_pow,
      ← Int.cast_mul, ← Int.cast_ofNat, ← Int.cast_mul, ← Int.cast_mul, ← Int.cast_sub, ←
      Int.cast_abs, ← Int.cast_mul, Int.cast_lt] at a1
  -- At a0, clear denominators...
  replace a0 : ¬a * q - ↑b * p = 0;
  ·
    rwa [Ne.def, div_eq_div_iff b0 (ne_of_gt qR0), mul_comm ↑p, ← sub_eq_zero,
      ←-- ... and revert to integers
      Int.cast_ofNat,
      ← Int.cast_mul, ← Int.cast_mul, ← Int.cast_sub, Int.cast_eq_zero] at a0
  -- Actually, `q` is a natural number
  lift q to ℕ using (zero_lt_one.trans q1).le
  -- Looks innocuous, but we now have an integer with non-zero absolute value: this is at
  -- least one away from zero.  The gain here is what gets the proof going.
  have ap : 0 < |a * ↑q - ↑b * p| := abs_pos.mpr a0
  -- Actually, the absolute value of an integer is a natural number
  lift |a * ↑q - ↑b * p| to ℕ using abs_nonneg (a * ↑q - ↑b * p)
  -- At a1, revert to natural numbers
  rw [← Int.ofNat_mul, ← Int.coe_nat_pow, ← Int.ofNat_mul, Int.ofNat_lt] at a1
  -- Recall this is by contradiction: we obtained the inequality `b * q ≤ x * q ^ (b + 1)`, so
  -- we are done.
  exact not_le.mpr a1 (Nat.mul_lt_mul_pow_succ (int.coe_nat_pos.mp ap) (int.coe_nat_lt.mp q1)).le
#align liouville.irrational Liouville.irrational

open Polynomial Metric Set Real RingHom

open Polynomial

/-- Let `Z, N` be types, let `R` be a metric space, let `α : R` be a point and let
`j : Z → N → R` be a function.  We aim to estimate how close we can get to `α`, while staying
in the image of `j`.  The points `j z a` of `R` in the image of `j` come with a "cost" equal to
`d a`.  As we get closer to `α` while staying in the image of `j`, we are interested in bounding
the quantity `d a * dist α (j z a)` from below by a strictly positive amount `1 / A`: the intuition
is that approximating well `α` with the points in the image of `j` should come at a high cost.  The
hypotheses on the function `f : R → R` provide us with sufficient conditions to ensure our goal.
The first hypothesis is that `f` is Lipschitz at `α`: this yields a bound on the distance.
The second hypothesis is specific to the Liouville argument and provides the missing bound
involving the cost function `d`.

This lemma collects the properties used in the proof of `exists_pos_real_of_irrational_root`.
It is stated in more general form than needed: in the intended application, `Z = ℤ`, `N = ℕ`,
`R = ℝ`, `d a = (a + 1) ^ f.nat_degree`, `j z a  = z / (a + 1)`, `f ∈ ℤ[x]`, `α` is an irrational
root of `f`, `ε` is small, `M` is a bound on the Lipschitz constant of `f` near `α`, `n` is
the degree of the polynomial `f`.
-/
theorem exists_one_le_pow_mul_dist {Z N R : Type _} [PseudoMetricSpace R] {d : N → ℝ}
    {j : Z → N → R} {f : R → R} {α : R} {ε M : ℝ}
    -- denominators are positive
    (d0 : ∀ a : N, 1 ≤ d a)
    (e0 : 0 < ε)
    -- function is Lipschitz at α
    (B : ∀ ⦃y : R⦄, y ∈ closedBall α ε → dist (f α) (f y) ≤ dist α y * M)
    -- clear denominators
    (L : ∀ ⦃z : Z⦄, ∀ ⦃a : N⦄, j z a ∈ closedBall α ε → 1 ≤ d a * dist (f α) (f (j z a))) :
    ∃ A : ℝ, 0 < A ∧ ∀ z : Z, ∀ a : N, 1 ≤ d a * (dist α (j z a) * A) :=
  by
  -- A useful inequality to keep at hand
  have me0 : 0 < max (1 / ε) M := lt_max_iff.mpr (Or.inl (one_div_pos.mpr e0))
  -- The maximum between `1 / ε` and `M` works
  refine' ⟨max (1 / ε) M, me0, fun z a => _⟩
  -- First, let's deal with the easy case in which we are far away from `α`
  by_cases dm1 : 1 ≤ dist α (j z a) * max (1 / ε) M
  · exact one_le_mul_of_one_le_of_one_le (d0 a) dm1
  · -- `j z a = z / (a + 1)`: we prove that this ratio is close to `α`
    have : j z a ∈ closed_ball α ε :=
      by
      refine' mem_closed_ball'.mp (le_trans _ ((one_div_le me0 e0).mpr (le_max_left _ _)))
      exact (le_div_iff me0).mpr (not_le.mp dm1).le
    -- use the "separation from `1`" (assumption `L`) for numerators,
    refine' (L this).trans _
    -- remove a common factor and use the Lipschitz assumption `B`
    refine' mul_le_mul_of_nonneg_left ((B this).trans _) (zero_le_one.trans (d0 a))
    exact mul_le_mul_of_nonneg_left (le_max_right _ M) dist_nonneg
#align liouville.exists_one_le_pow_mul_dist Liouville.exists_one_le_pow_mul_dist

theorem exists_pos_real_of_irrational_root {α : ℝ} (ha : Irrational α) {f : ℤ[X]} (f0 : f ≠ 0)
    (fa : eval α (map (algebraMap ℤ ℝ) f) = 0) :
    ∃ A : ℝ, 0 < A ∧ ∀ a : ℤ, ∀ b : ℕ, (1 : ℝ) ≤ (b + 1) ^ f.natDegree * (|α - a / (b + 1)| * A) :=
  by
  -- `fR` is `f` viewed as a polynomial with `ℝ` coefficients.
  set fR : ℝ[X] := map (algebraMap ℤ ℝ) f
  -- `fR` is non-zero, since `f` is non-zero.
  obtain fR0 : fR ≠ 0 := fun fR0 =>
    (map_injective (algebraMap ℤ ℝ) fun _ _ A => int.cast_inj.mp A).Ne f0
      (fR0.trans (Polynomial.map_zero _).symm)
  -- reformulating assumption `fa`: `α` is a root of `fR`.
  have ar : α ∈ (fR.roots.to_finset : Set ℝ) :=
    finset.mem_coe.mpr (multiset.mem_to_finset.mpr ((mem_roots fR0).mpr (is_root.def.mpr fa)))
  -- Since the polynomial `fR` has finitely many roots, there is a closed interval centered at `α`
  -- such that `α` is the only root of `fR` in the interval.
  obtain ⟨ζ, z0, U⟩ : ∃ ζ > 0, closed_ball α ζ ∩ fR.roots.to_finset = {α} :=
    @exists_closed_ball_inter_eq_singleton_of_discrete _ _ _ discrete_of_t1_of_finite _ ar
  -- Since `fR` is continuous, it is bounded on the interval above.
  obtain ⟨xm, -, hM⟩ :
    ∃ (xm : ℝ)(H : xm ∈ Icc (α - ζ) (α + ζ)),
      ∀ y : ℝ, y ∈ Icc (α - ζ) (α + ζ) → |fR.derivative.eval y| ≤ |fR.derivative.eval xm| :=
    IsCompact.exists_forall_ge is_compact_Icc
      ⟨α, (sub_lt_self α z0).le, (lt_add_of_pos_right α z0).le⟩
      (continuous_abs.comp fR.derivative.continuous_aeval).ContinuousOn
  -- Use the key lemma `exists_one_le_pow_mul_dist`: we are left to show that ...
  refine'
    @exists_one_le_pow_mul_dist ℤ ℕ ℝ _ _ _ (fun y => fR.eval y) α ζ (|fR.derivative.eval xm|) _ z0
      (fun y hy => _) fun z a hq => _
  -- 1: the denominators are positive -- essentially by definition;
  · exact fun a => one_le_pow_of_one_le ((le_add_iff_nonneg_left 1).mpr a.cast_nonneg) _
  -- 2: the polynomial `fR` is Lipschitz at `α` -- as its derivative continuous;
  · rw [mul_comm]
    rw [Real.closedBall_eq_Icc] at hy
    -- apply the Mean Value Theorem: the bound on the derivative comes from differentiability.
    refine'
      Convex.norm_image_sub_le_of_norm_deriv_le (fun _ _ => fR.differentiable_at)
        (fun y h => by
          rw [fR.deriv]
          exact hM _ h)
        (convex_Icc _ _) hy (mem_Icc_iff_abs_le.mp _)
    exact @mem_closed_ball_self ℝ _ α ζ (le_of_lt z0)
  -- 3: the weird inequality of Liouville type with powers of the denominators.
  · show 1 ≤ (a + 1 : ℝ) ^ f.nat_degree * |eval α fR - eval (z / (a + 1)) fR|
    rw [fa, zero_sub, abs_neg]
    rw [show (a + 1 : ℝ) = ((a + 1 : ℕ) : ℤ) by norm_cast] at hq⊢
    -- key observation: the right-hand side of the inequality is an *integer*.  Therefore,
    -- if its absolute value is not at least one, then it vanishes.  Proceed by contradiction
    refine' one_le_pow_mul_abs_eval_div (Int.coe_nat_succ_pos a) fun hy => _
    -- As the evaluation of the polynomial vanishes, we found a root of `fR` that is rational.
    -- We know that `α` is the only root of `fR` in our interval, and `α` is irrational:
    -- follow your nose.
    refine' (irrational_iff_ne_rational α).mp ha z (a + 1) (mem_singleton_iff.mp _).symm
    refine' U.subset _
    refine' ⟨hq, finset.mem_coe.mp (multiset.mem_to_finset.mpr _)⟩
    exact (mem_roots fR0).mpr (is_root.def.mpr hy)
#align liouville.exists_pos_real_of_irrational_root Liouville.exists_pos_real_of_irrational_root

/-- **Liouville's Theorem** -/
theorem transcendental {x : ℝ} (lx : Liouville x) : Transcendental ℤ x :=
  by
  -- Proceed by contradiction: if `x` is algebraic, then `x` is the root (`ef0`) of a
  -- non-zero (`f0`) polynomial `f`
  rintro ⟨f : ℤ[X], f0, ef0⟩
  -- Change `aeval x f = 0` to `eval (map _ f) = 0`, who knew.
  replace ef0 : (f.map (algebraMap ℤ ℝ)).eval x = 0;
  · rwa [aeval_def, ← eval_map] at ef0
  -- There is a "large" real number `A` such that `(b + 1) ^ (deg f) * |f (x - a / (b + 1))| * A`
  -- is at least one.  This is obtained from lemma `exists_pos_real_of_irrational_root`.
  obtain ⟨A, hA, h⟩ :
    ∃ A : ℝ,
      0 < A ∧ ∀ (a : ℤ) (b : ℕ), (1 : ℝ) ≤ (b + 1) ^ f.nat_degree * (|x - a / (b + 1)| * A) :=
    exists_pos_real_of_irrational_root lx.irrational f0 ef0
  -- Since the real numbers are Archimedean, a power of `2` exceeds `A`: `hn : A < 2 ^ r`.
  rcases pow_unbounded_of_one_lt A (lt_add_one 1) with ⟨r, hn⟩
  -- Use the Liouville property, with exponent `r +  deg f`.
  obtain ⟨a, b, b1, -, a1⟩ :
    ∃ a b : ℤ, 1 < b ∧ x ≠ a / b ∧ |x - a / b| < 1 / b ^ (r + f.nat_degree) := lx (r + f.nat_degree)
  have b0 : (0 : ℝ) < b :=
    zero_lt_one.trans
      (by
        rw [← Int.cast_one]
        exact int.cast_lt.mpr b1)
  -- Prove that `b ^ f.nat_degree * abs (x - a / b)` is strictly smaller than itself
  -- recall, this is a proof by contradiction!
  refine' lt_irrefl ((b : ℝ) ^ f.nat_degree * |x - ↑a / ↑b|) _
  -- clear denominators at `a1`
  rw [lt_div_iff' (pow_pos b0 _), pow_add, mul_assoc] at a1
  -- split the inequality via `1 / A`.
  refine' (_ : (b : ℝ) ^ f.nat_degree * |x - a / b| < 1 / A).trans_le _
  -- This branch of the proof uses the Liouville condition and the Archimedean property
  · refine' (lt_div_iff' hA).mpr _
    refine' lt_of_le_of_lt _ a1
    refine' mul_le_mul_of_nonneg_right _ (mul_nonneg (pow_nonneg b0.le _) (abs_nonneg _))
    refine' hn.le.trans _
    refine' pow_le_pow_of_le_left zero_le_two _ _
    exact int.cast_two.symm.le.trans (int.cast_le.mpr (int.add_one_le_iff.mpr b1))
  -- this branch of the proof exploits the "integrality" of evaluations of polynomials
  -- at ratios of integers.
  · lift b to ℕ using zero_le_one.trans b1.le
    specialize h a b.pred
    rwa [← Nat.cast_succ, Nat.succ_pred_eq_of_pos (zero_lt_one.trans _), ← mul_assoc, ←
      div_le_iff hA] at h
    exact int.coe_nat_lt.mp b1
#align liouville.transcendental Liouville.transcendental

end Liouville


import boolalg.basic boolalg.examples
import .basic .dual

namespace boolalg

def is_minor {U: boolalg} {E : U} : rankfun (subalg E) → rankfun U → Prop :=
  λ N M, ∃ C, E ∩ C = ⊥ ∧ ∀ X : subalg E, N.r X = M.r (X ∪ C) - M.r C

structure minor_on' (U: boolalg) (M: rankfun U) (E : U) :=
(mat : rankfun (subalg E))
(is_minor : is_minor mat M)

@[simp] instance coe_to_matroid {U : boolalg} {M :rankfun U} {E : U} : has_coe (minor_on' U M E) (rankfun (subalg E)) := {coe := minor_on'.mat}

def corestrict' (U : boolalg) (M : rankfun U) (E : U) : minor_on' U M E :=
let r := M.r, C := Eᶜ in
{
  mat :=
  ⟨
  λ X, M.r (X ∪ C) - M.r C,
  λ X, by {rw sub_nonneg, exact M.R2 C (X ∪ C) (subset_union_right X C)},
  λ X, by linarith [subalg_coe_size X, M.R0 (X ∩ C), M.R3 X C, M.R1 X],
  λ X Y hXY, by linarith [M.R2 (X ∪ C) (Y ∪ C) (subset_union_subset_left X Y C (subalg_coe_subset hXY))] ,
  λ X Y, by
  {
    suffices : M.r (coe (X ∪ Y) ∪ C) + M.r (coe (X ∩ Y) ∪ C) ≤ M.r (X ∪ C) + M.r (Y ∪ C), by linarith,
    have h := M.R3 (X ∪ C) (Y ∪ C),
    rw [←union_distrib_right, ←union_distrib_union_left] at h, refine h,
  },⟩,
  is_minor := ⟨C, ⟨inter_compl_self E, λ X, rfl⟩⟩,
}

def restrict' (U : boolalg) (M : rankfun U) (E : U) : minor_on' U M E :=
let r := M.r in
{
  mat := ⟨λ X, M.r X, λ X, M.R0 X , λ X, M.R1 X, λ X Y, M.R2 X Y, λ X Y, M.R3 X Y⟩,
  is_minor := ⟨⊥, ⟨ inter_bot E, λ X, by {simp only [union_bot], linarith [rank_bot M]}⟩⟩,
}

lemma corestrict_corestrict' (U : boolalg) (M : rankfun U) (E F : U) (h : E ⊆ F) :
  corestrict' (subalg F) (corestrict' U M F).mat E = corestrict' U M E

end boolalg


import group_theory.subgroup.basic

variables {G H : Type*} [group G] [group H]

theorem hom_is_trivial_if_kernel_eq_group
(φ : G →* G) (h : φ.ker = ⊤) : φ = 1 :=
begin
  apply fun_like.ext,
  intro g,
  rw [monoid_hom.one_apply, ← monoid_hom.mem_ker, h],
  trivial,
end


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group_ring_action
import algebra.hom.group_action
import data.polynomial.algebra_map
import data.polynomial.monic

/-!
# Group action on rings applied to polynomials

This file contains instances and definitions relating `mul_semiring_action` to `polynomial`.
-/

variables (M : Type*) [monoid M]

open_locale polynomial
namespace polynomial

variables (R : Type*) [semiring R]

variables {M}

lemma smul_eq_map [mul_semiring_action M R] (m : M) :
  ((•) m) = map (mul_semiring_action.to_ring_hom M R m) :=
begin
  suffices :
    distrib_mul_action.to_add_monoid_hom R[X] m =
      (map_ring_hom (mul_semiring_action.to_ring_hom M R m)).to_add_monoid_hom,
  { ext1 r, exact add_monoid_hom.congr_fun this r, },
  ext n r : 2,
  change m • monomial n r = map (mul_semiring_action.to_ring_hom M R m) (monomial n r),
  simpa only [polynomial.map_monomial, polynomial.smul_monomial],
end

variables (M)

noncomputable instance [mul_semiring_action M R] : mul_semiring_action M R[X] :=
{ smul := (•),
  smul_one := λ m,
    (smul_eq_map R m).symm ▸ polynomial.map_one (mul_semiring_action.to_ring_hom M R m),
  smul_mul := λ m p q,
    (smul_eq_map R m).symm ▸ polynomial.map_mul (mul_semiring_action.to_ring_hom M R m),
  ..polynomial.distrib_mul_action }

variables {M R}

variables [mul_semiring_action M R]

@[simp] lemma smul_X (m : M) : (m • X : R[X]) = X :=
(smul_eq_map R m).symm ▸ map_X _

variables (S : Type*) [comm_semiring S] [mul_semiring_action M S]

theorem smul_eval_smul (m : M) (f : S[X]) (x : S) :
  (m • f).eval (m • x) = m • f.eval x :=
polynomial.induction_on f
  (λ r, by rw [smul_C, eval_C, eval_C])
  (λ f g ihf ihg, by rw [smul_add, eval_add, ihf, ihg, eval_add, smul_add])
  (λ n r ih, by rw [smul_mul', smul_pow', smul_C, smul_X, eval_mul, eval_C, eval_pow, eval_X,
      eval_mul, eval_C, eval_pow, eval_X, smul_mul', smul_pow'])

variables (G : Type*) [group G]

theorem eval_smul' [mul_semiring_action G S] (g : G) (f : S[X]) (x : S) :
  f.eval (g • x) = g • (g⁻¹ • f).eval x :=
by rw [← smul_eval_smul, smul_inv_smul]

theorem smul_eval [mul_semiring_action G S] (g : G) (f : S[X]) (x : S) :
  (g • f).eval x = g • f.eval (g⁻¹ • x) :=
by rw [← smul_eval_smul, smul_inv_smul]

end polynomial

section comm_ring

variables (G : Type*) [group G] [fintype G]
variables (R : Type*) [comm_ring R] [mul_semiring_action G R]
open mul_action
open_locale classical

/-- the product of `(X - g • x)` over distinct `g • x`. -/
noncomputable def prod_X_sub_smul (x : R) : R[X] :=
(finset.univ : finset (G ⧸ mul_action.stabilizer G x)).prod $
λ g, polynomial.X - polynomial.C (of_quotient_stabilizer G x g)

theorem prod_X_sub_smul.monic (x : R) : (prod_X_sub_smul G R x).monic :=
polynomial.monic_prod_of_monic _ _ $ λ g _, polynomial.monic_X_sub_C _

theorem prod_X_sub_smul.eval (x : R) : (prod_X_sub_smul G R x).eval x = 0 :=
(monoid_hom.map_prod
  ((polynomial.aeval x).to_ring_hom.to_monoid_hom : R[X] →* R) _ _).trans $
  finset.prod_eq_zero (finset.mem_univ $ quotient_group.mk 1) $
  by simp

theorem prod_X_sub_smul.smul (x : R) (g : G) :
  g • prod_X_sub_smul G R x = prod_X_sub_smul G R x :=
finset.smul_prod.trans $ fintype.prod_bijective _ (mul_action.bijective g) _ _
  (λ g', by rw [of_quotient_stabilizer_smul, smul_sub, polynomial.smul_X, polynomial.smul_C])

theorem prod_X_sub_smul.coeff (x : R) (g : G) (n : ℕ) :
  g • (prod_X_sub_smul G R x).coeff n =
  (prod_X_sub_smul G R x).coeff n :=
by rw [← polynomial.coeff_smul, prod_X_sub_smul.smul]

end comm_ring

namespace mul_semiring_action_hom
variables {M}
variables {P : Type*} [comm_semiring P] [mul_semiring_action M P]
variables {Q : Type*} [comm_semiring Q] [mul_semiring_action M Q]
open polynomial

/-- An equivariant map induces an equivariant map on polynomials. -/
protected noncomputable def polynomial (g : P →+*[M] Q) : P[X] →+*[M] Q[X] :=
{ to_fun := map g,
  map_smul' := λ m p, polynomial.induction_on p
    (λ b, by rw [smul_C, map_C, coe_fn_coe, g.map_smul, map_C, coe_fn_coe, smul_C])
    (λ p q ihp ihq, by rw [smul_add, polynomial.map_add, ihp, ihq, polynomial.map_add, smul_add])
    (λ n b ih, by rw [smul_mul', smul_C, smul_pow', smul_X, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, coe_fn_coe, g.map_smul, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, smul_mul', smul_C, smul_pow', smul_X, coe_fn_coe]),
  map_zero' := polynomial.map_zero g,
  map_add' := λ p q, polynomial.map_add g,
  map_one' := polynomial.map_one g,
  map_mul' := λ p q, polynomial.map_mul g }

@[simp] theorem coe_polynomial (g : P →+*[M] Q) :
  (g.polynomial : P[X] → Q[X]) = map g :=
rfl

end mul_semiring_action_hom


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.modeq
import Mathlib.data.zsqrtd.basic
import Mathlib.tactic.omega.default
import Mathlib.PostPort

namespace Mathlib

namespace pell

@[simp] theorem d_pos {a : ℕ} (a1 : 1 < a) : 0 < d a1 :=
  nat.sub_pos_of_lt (mul_lt_mul a1 (le_of_lt a1) (of_as_true trivial) (of_as_true trivial))

def pell {a : ℕ} (a1 : 1 < a) : ℕ → ℕ × ℕ :=
  fun (n : ℕ) =>
    nat.rec_on n (1, 0) fun (n : ℕ) (xy : ℕ × ℕ) => (prod.fst xy * a + d a1 * prod.snd xy, prod.fst xy + prod.snd xy * a)

def xn {a : ℕ} (a1 : 1 < a) (n : ℕ) : ℕ :=
  prod.fst (pell a1 n)

def yn {a : ℕ} (a1 : 1 < a) (n : ℕ) : ℕ :=
  prod.snd (pell a1 n)

@[simp] theorem pell_val {a : ℕ} (a1 : 1 < a) (n : ℕ) : pell a1 n = (xn a1 n, yn a1 n) :=
  (fun (this : pell a1 n = (prod.fst (pell a1 n), prod.snd (pell a1 n))) => this)
    ((fun (_a : ℕ × ℕ) => prod.cases_on _a fun (fst snd : ℕ) => idRhs ((fst, snd) = (fst, snd)) rfl) (pell a1 n))

@[simp] theorem xn_zero {a : ℕ} (a1 : 1 < a) : xn a1 0 = 1 :=
  rfl

@[simp] theorem yn_zero {a : ℕ} (a1 : 1 < a) : yn a1 0 = 0 :=
  rfl

@[simp] theorem xn_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : xn a1 (n + 1) = xn a1 n * a + d a1 * yn a1 n :=
  rfl

@[simp] theorem yn_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : yn a1 (n + 1) = xn a1 n + yn a1 n * a :=
  rfl

@[simp] theorem xn_one {a : ℕ} (a1 : 1 < a) : xn a1 1 = a := sorry

@[simp] theorem yn_one {a : ℕ} (a1 : 1 < a) : yn a1 1 = 1 := sorry

def xz {a : ℕ} (a1 : 1 < a) (n : ℕ) : ℤ :=
  ↑(xn a1 n)

def yz {a : ℕ} (a1 : 1 < a) (n : ℕ) : ℤ :=
  ↑(yn a1 n)

def az {a : ℕ} (a1 : 1 < a) : ℤ :=
  ↑a

theorem asq_pos {a : ℕ} (a1 : 1 < a) : 0 < a * a :=
  le_trans (le_of_lt a1) (eq.mp (Eq._oldrec (Eq.refl (a * 1 ≤ a * a)) (mul_one a)) (nat.mul_le_mul_left a (le_of_lt a1)))

theorem dz_val {a : ℕ} (a1 : 1 < a) : ↑(d a1) = az a1 * az a1 - 1 := sorry

@[simp] theorem xz_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : xz a1 (n + 1) = xz a1 n * az a1 + ↑(d a1) * yz a1 n :=
  rfl

@[simp] theorem yz_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : yz a1 (n + 1) = xz a1 n + yz a1 n * az a1 :=
  rfl

def pell_zd {a : ℕ} (a1 : 1 < a) (n : ℕ) : ℤ√↑(d a1) :=
  zsqrtd.mk ↑(xn a1 n) ↑(yn a1 n)

@[simp] theorem pell_zd_re {a : ℕ} (a1 : 1 < a) (n : ℕ) : zsqrtd.re (pell_zd a1 n) = ↑(xn a1 n) :=
  rfl

@[simp] theorem pell_zd_im {a : ℕ} (a1 : 1 < a) (n : ℕ) : zsqrtd.im (pell_zd a1 n) = ↑(yn a1 n) :=
  rfl

def is_pell {a : ℕ} (a1 : 1 < a) : ℤ√↑(d a1) → Prop :=
  sorry

theorem is_pell_nat {a : ℕ} (a1 : 1 < a) {x : ℕ} {y : ℕ} : is_pell a1 (zsqrtd.mk ↑x ↑y) ↔ x * x - d a1 * y * y = 1 := sorry

theorem is_pell_norm {a : ℕ} (a1 : 1 < a) {b : ℤ√↑(d a1)} : is_pell a1 b ↔ b * zsqrtd.conj b = 1 := sorry

theorem is_pell_mul {a : ℕ} (a1 : 1 < a) {b : ℤ√↑(d a1)} {c : ℤ√↑(d a1)} (hb : is_pell a1 b) (hc : is_pell a1 c) : is_pell a1 (b * c) := sorry

theorem is_pell_conj {a : ℕ} (a1 : 1 < a) {b : ℤ√↑(d a1)} : is_pell a1 b ↔ is_pell a1 (zsqrtd.conj b) := sorry

@[simp] theorem pell_zd_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : pell_zd a1 (n + 1) = pell_zd a1 n * zsqrtd.mk (↑a) 1 := sorry

theorem is_pell_one {a : ℕ} (a1 : 1 < a) : is_pell a1 (zsqrtd.mk (↑a) 1) := sorry

theorem is_pell_pell_zd {a : ℕ} (a1 : 1 < a) (n : ℕ) : is_pell a1 (pell_zd a1 n) := sorry

@[simp] theorem pell_eqz {a : ℕ} (a1 : 1 < a) (n : ℕ) : xz a1 n * xz a1 n - ↑(d a1) * yz a1 n * yz a1 n = 1 :=
  is_pell_pell_zd a1 n

@[simp] theorem pell_eq {a : ℕ} (a1 : 1 < a) (n : ℕ) : xn a1 n * xn a1 n - d a1 * yn a1 n * yn a1 n = 1 := sorry

protected instance dnsq {a : ℕ} (a1 : 1 < a) : zsqrtd.nonsquare (d a1) := sorry

theorem xn_ge_a_pow {a : ℕ} (a1 : 1 < a) (n : ℕ) : a ^ n ≤ xn a1 n := sorry

theorem n_lt_a_pow {a : ℕ} (a1 : 1 < a) (n : ℕ) : n < a ^ n := sorry

theorem n_lt_xn {a : ℕ} (a1 : 1 < a) (n : ℕ) : n < xn a1 n :=
  lt_of_lt_of_le (n_lt_a_pow a1 n) (xn_ge_a_pow a1 n)

theorem x_pos {a : ℕ} (a1 : 1 < a) (n : ℕ) : 0 < xn a1 n :=
  lt_of_le_of_lt (nat.zero_le n) (n_lt_xn a1 n)

theorem eq_pell_lem {a : ℕ} (a1 : 1 < a) (n : ℕ) (b : ℤ√↑(d a1)) : 1 ≤ b → is_pell a1 b → b ≤ pell_zd a1 n → ∃ (n : ℕ), b = pell_zd a1 n := sorry

theorem eq_pell_zd {a : ℕ} (a1 : 1 < a) (b : ℤ√↑(d a1)) (b1 : 1 ≤ b) (hp : is_pell a1 b) : ∃ (n : ℕ), b = pell_zd a1 n := sorry

theorem eq_pell {a : ℕ} (a1 : 1 < a) {x : ℕ} {y : ℕ} (hp : x * x - d a1 * y * y = 1) : ∃ (n : ℕ), x = xn a1 n ∧ y = yn a1 n := sorry

theorem pell_zd_add {a : ℕ} (a1 : 1 < a) (m : ℕ) (n : ℕ) : pell_zd a1 (m + n) = pell_zd a1 m * pell_zd a1 n := sorry

theorem xn_add {a : ℕ} (a1 : 1 < a) (m : ℕ) (n : ℕ) : xn a1 (m + n) = xn a1 m * xn a1 n + d a1 * yn a1 m * yn a1 n := sorry

theorem yn_add {a : ℕ} (a1 : 1 < a) (m : ℕ) (n : ℕ) : yn a1 (m + n) = xn a1 m * yn a1 n + yn a1 m * xn a1 n := sorry

theorem pell_zd_sub {a : ℕ} (a1 : 1 < a) {m : ℕ} {n : ℕ} (h : n ≤ m) : pell_zd a1 (m - n) = pell_zd a1 m * zsqrtd.conj (pell_zd a1 n) := sorry

theorem xz_sub {a : ℕ} (a1 : 1 < a) {m : ℕ} {n : ℕ} (h : n ≤ m) : xz a1 (m - n) = xz a1 m * xz a1 n - ↑(d a1) * yz a1 m * yz a1 n := sorry

theorem yz_sub {a : ℕ} (a1 : 1 < a) {m : ℕ} {n : ℕ} (h : n ≤ m) : yz a1 (m - n) = xz a1 n * yz a1 m - xz a1 m * yz a1 n := sorry

theorem xy_coprime {a : ℕ} (a1 : 1 < a) (n : ℕ) : nat.coprime (xn a1 n) (yn a1 n) := sorry

theorem y_increasing {a : ℕ} (a1 : 1 < a) {m : ℕ} {n : ℕ} : m < n → yn a1 m < yn a1 n := sorry

theorem x_increasing {a : ℕ} (a1 : 1 < a) {m : ℕ} {n : ℕ} : m < n → xn a1 m < xn a1 n := sorry

theorem yn_ge_n {a : ℕ} (a1 : 1 < a) (n : ℕ) : n ≤ yn a1 n := sorry

theorem y_mul_dvd {a : ℕ} (a1 : 1 < a) (n : ℕ) (k : ℕ) : yn a1 n ∣ yn a1 (n * k) := sorry

theorem y_dvd_iff {a : ℕ} (a1 : 1 < a) (m : ℕ) (n : ℕ) : yn a1 m ∣ yn a1 n ↔ m ∣ n := sorry

theorem xy_modeq_yn {a : ℕ} (a1 : 1 < a) (n : ℕ) (k : ℕ) : nat.modeq (yn a1 n ^ bit0 1) (xn a1 (n * k)) (xn a1 n ^ k) ∧
  nat.modeq (yn a1 n ^ bit1 1) (yn a1 (n * k)) (k * xn a1 n ^ (k - 1) * yn a1 n) := sorry

theorem ysq_dvd_yy {a : ℕ} (a1 : 1 < a) (n : ℕ) : yn a1 n * yn a1 n ∣ yn a1 (n * yn a1 n) := sorry

theorem dvd_of_ysq_dvd {a : ℕ} (a1 : 1 < a) {n : ℕ} {t : ℕ} (h : yn a1 n * yn a1 n ∣ yn a1 t) : yn a1 n ∣ t := sorry

theorem pell_zd_succ_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : pell_zd a1 (n + bit0 1) + pell_zd a1 n = ↑(bit0 1 * a) * pell_zd a1 (n + 1) := sorry

theorem xy_succ_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : xn a1 (n + bit0 1) + xn a1 n = bit0 1 * a * xn a1 (n + 1) ∧ yn a1 (n + bit0 1) + yn a1 n = bit0 1 * a * yn a1 (n + 1) := sorry

theorem xn_succ_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : xn a1 (n + bit0 1) + xn a1 n = bit0 1 * a * xn a1 (n + 1) :=
  and.left (xy_succ_succ a1 n)

theorem yn_succ_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : yn a1 (n + bit0 1) + yn a1 n = bit0 1 * a * yn a1 (n + 1) :=
  and.right (xy_succ_succ a1 n)

theorem xz_succ_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : xz a1 (n + bit0 1) = ↑(bit0 1 * a) * xz a1 (n + 1) - xz a1 n := sorry

theorem yz_succ_succ {a : ℕ} (a1 : 1 < a) (n : ℕ) : yz a1 (n + bit0 1) = ↑(bit0 1 * a) * yz a1 (n + 1) - yz a1 n := sorry

theorem yn_modeq_a_sub_one {a : ℕ} (a1 : 1 < a) (n : ℕ) : nat.modeq (a - 1) (yn a1 n) n := sorry

theorem yn_modeq_two {a : ℕ} (a1 : 1 < a) (n : ℕ) : nat.modeq (bit0 1) (yn a1 n) n := sorry

theorem x_sub_y_dvd_pow_lem {a : ℕ} (a1 : 1 < a) (y2 : ℤ) (y1 : ℤ) (y0 : ℤ) (yn1 : ℤ) (yn0 : ℤ) (xn1 : ℤ) (xn0 : ℤ) (ay : ℤ) (a2 : ℤ) : (a2 * yn1 - yn0) * ay + y2 - (a2 * xn1 - xn0) = y2 - a2 * y1 + y0 + a2 * (yn1 * ay + y1 - xn1) - (yn0 * ay + y0 - xn0) := sorry

theorem x_sub_y_dvd_pow {a : ℕ} (a1 : 1 < a) (y : ℕ) (n : ℕ) : bit0 1 * ↑a * ↑y - ↑y * ↑y - 1 ∣ yz a1 n * (↑a - ↑y) + ↑(y ^ n) - xz a1 n := sorry

theorem xn_modeq_x2n_add_lem {a : ℕ} (a1 : 1 < a) (n : ℕ) (j : ℕ) : xn a1 n ∣ d a1 * yn a1 n * (yn a1 n * xn a1 j) + xn a1 j := sorry

theorem xn_modeq_x2n_add {a : ℕ} (a1 : 1 < a) (n : ℕ) (j : ℕ) : nat.modeq (xn a1 n) (xn a1 (bit0 1 * n + j) + xn a1 j) 0 := sorry

theorem xn_modeq_x2n_sub_lem {a : ℕ} (a1 : 1 < a) {n : ℕ} {j : ℕ} (h : j ≤ n) : nat.modeq (xn a1 n) (xn a1 (bit0 1 * n - j) + xn a1 j) 0 := sorry

theorem xn_modeq_x2n_sub {a : ℕ} (a1 : 1 < a) {n : ℕ} {j : ℕ} (h : j ≤ bit0 1 * n) : nat.modeq (xn a1 n) (xn a1 (bit0 1 * n - j) + xn a1 j) 0 := sorry

theorem xn_modeq_x4n_add {a : ℕ} (a1 : 1 < a) (n : ℕ) (j : ℕ) : nat.modeq (xn a1 n) (xn a1 (bit0 (bit0 1) * n + j)) (xn a1 j) := sorry

theorem xn_modeq_x4n_sub {a : ℕ} (a1 : 1 < a) {n : ℕ} {j : ℕ} (h : j ≤ bit0 1 * n) : nat.modeq (xn a1 n) (xn a1 (bit0 (bit0 1) * n - j)) (xn a1 j) := sorry

theorem eq_of_xn_modeq_lem1 {a : ℕ} (a1 : 1 < a) {i : ℕ} {n : ℕ} {j : ℕ} : i < j → j < n → xn a1 i % xn a1 n < xn a1 j % xn a1 n := sorry

theorem eq_of_xn_modeq_lem2 {a : ℕ} (a1 : 1 < a) {n : ℕ} (h : bit0 1 * xn a1 n = xn a1 (n + 1)) : a = bit0 1 ∧ n = 0 := sorry

theorem eq_of_xn_modeq_lem3 {a : ℕ} (a1 : 1 < a) {i : ℕ} {n : ℕ} (npos : 0 < n) {j : ℕ} : i < j → j ≤ bit0 1 * n → j ≠ n → ¬(a = bit0 1 ∧ n = 1 ∧ i = 0 ∧ j = bit0 1) → xn a1 i % xn a1 n < xn a1 j % xn a1 n := sorry

theorem eq_of_xn_modeq_le {a : ℕ} (a1 : 1 < a) {i : ℕ} {j : ℕ} {n : ℕ} (npos : 0 < n) (ij : i ≤ j) (j2n : j ≤ bit0 1 * n) (h : nat.modeq (xn a1 n) (xn a1 i) (xn a1 j)) (ntriv : ¬(a = bit0 1 ∧ n = 1 ∧ i = 0 ∧ j = bit0 1)) : i = j := sorry

theorem eq_of_xn_modeq {a : ℕ} (a1 : 1 < a) {i : ℕ} {j : ℕ} {n : ℕ} (npos : 0 < n) (i2n : i ≤ bit0 1 * n) (j2n : j ≤ bit0 1 * n) (h : nat.modeq (xn a1 n) (xn a1 i) (xn a1 j)) (ntriv : a = bit0 1 → n = 1 → (i = 0 → j ≠ bit0 1) ∧ (i = bit0 1 → j ≠ 0)) : i = j := sorry

theorem eq_of_xn_modeq' {a : ℕ} (a1 : 1 < a) {i : ℕ} {j : ℕ} {n : ℕ} (ipos : 0 < i) (hin : i ≤ n) (j4n : j ≤ bit0 (bit0 1) * n) (h : nat.modeq (xn a1 n) (xn a1 j) (xn a1 i)) : j = i ∨ j + i = bit0 (bit0 1) * n := sorry

theorem modeq_of_xn_modeq {a : ℕ} (a1 : 1 < a) {i : ℕ} {j : ℕ} {n : ℕ} (ipos : 0 < i) (hin : i ≤ n) (h : nat.modeq (xn a1 n) (xn a1 j) (xn a1 i)) : nat.modeq (bit0 (bit0 1) * n) j i ∨ nat.modeq (bit0 (bit0 1) * n) (j + i) 0 := sorry

theorem xy_modeq_of_modeq {a : ℕ} {b : ℕ} {c : ℕ} (a1 : 1 < a) (b1 : 1 < b) (h : nat.modeq c a b) (n : ℕ) : nat.modeq c (xn a1 n) (xn b1 n) ∧ nat.modeq c (yn a1 n) (yn b1 n) := sorry

theorem matiyasevic {a : ℕ} {k : ℕ} {x : ℕ} {y : ℕ} : (∃ (a1 : 1 < a), xn a1 k = x ∧ yn a1 k = y) ↔
  1 < a ∧
    k ≤ y ∧
      (x = 1 ∧ y = 0 ∨
        ∃ (u : ℕ),
          ∃ (v : ℕ),
            ∃ (s : ℕ),
              ∃ (t : ℕ),
                ∃ (b : ℕ),
                  x * x - (a * a - 1) * y * y = 1 ∧
                    u * u - (a * a - 1) * v * v = 1 ∧
                      s * s - (b * b - 1) * t * t = 1 ∧
                        1 < b ∧
                          nat.modeq (bit0 (bit0 1) * y) b 1 ∧
                            nat.modeq u b a ∧ 0 < v ∧ y * y ∣ v ∧ nat.modeq u s x ∧ nat.modeq (bit0 (bit0 1) * y) t k) := sorry

theorem eq_pow_of_pell_lem {a : ℕ} {y : ℕ} {k : ℕ} (a1 : 1 < a) (ypos : 0 < y) : 0 < k → y ^ k < a → ↑(y ^ k) < bit0 1 * ↑a * ↑y - ↑y * ↑y - 1 := sorry

theorem eq_pow_of_pell {m : ℕ} {n : ℕ} {k : ℕ} : n ^ k = m ↔
  k = 0 ∧ m = 1 ∨
    0 < k ∧
      (n = 0 ∧ m = 0 ∨
        0 < n ∧
          ∃ (w : ℕ),
            ∃ (a : ℕ),
              ∃ (t : ℕ),
                ∃ (z : ℕ),
                  ∃ (a1 : 1 < a),
                    nat.modeq t (xn a1 k) (yn a1 k * (a - n) + m) ∧
                      bit0 1 * a * n = t + (n * n + 1) ∧
                        m < t ∧ n ≤ w ∧ k ≤ w ∧ a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1) := sorry


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

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

open prfK

---------------------- Consistency ----------------------

def sem_cons (AX : ctx) := ¬ global_sem_csq AX ⊥
attribute [class] sem_cons

lemma sem_consK : sem_cons ∅ :=
begin
rw sem_cons,
rw global_sem_csq,
push_neg,
let f : frame :=
{ states := ℕ,
  h := ⟨0⟩,
  rel := λ x y, x = y},
use f, let v := λ n x, true,
use v, let x := 42,
split, intros φ y h1,
exact false.elim h1, use x,
rw forces, trivial
end

lemma sem_consT : sem_cons T_axioms :=
begin
rw sem_cons, rw global_sem_csq,
push_neg,
let f : frame :=
{ states := ℕ,
  h := ⟨0⟩,
  rel := λ x y, x = y},
use f, let v := λ n x, true,
use v, let x := 42,
split, intros φ y h1,
cases h1 with ψ h1, subst h1,
intro h1, apply h1 y,
exact rfl, use x,
rw forces, trivial
end

lemma sem_consS4 : sem_cons S4_axioms :=
begin
rw sem_cons, rw global_sem_csq, push_neg,
let f : frame :=
{ states := ℕ,
  h := ⟨0⟩,
  rel := λ x y, x = y},
use f, let v := λ n x, true,
use v, let x := 42,
split,
intros φ y h1,
cases h1,
cases h1 with ψ h1, subst h1,
intro h1, apply h1 y,
exact rfl,
cases h1 with ψ h1, subst h1,
intro h1, rw forces at *,
simp at *, rw forces,
simp at *, exact h1,
use x,
rw forces, trivial
end

lemma sem_consS5 : sem_cons S5_axioms :=
begin
rw sem_cons, rw global_sem_csq, push_neg,
let f : frame :=
{ states := ℕ,
  h := ⟨0⟩,
  rel := λ x y, x = y},
use f, let v := λ n x, true,
use v, let x := 42,
split,
intros φ y h1,
cases h1,
cases h1 with ψ h1, subst h1,
intro h1, apply h1 y,
exact rfl,
cases h1 with ψ h1, subst h1,
intro h1, rw forces at *,
simp at *, rw forces,
exact h1, use x,
rw forces, trivial
end

-- Any axiom system that is consistent does not prove false
lemma nprfalse (AX : ctx) (hax : sem_cons AX) : ¬ prfK AX ⊥ :=
begin
have h1 : ¬ global_sem_csq AX ⊥ → ¬ prfK AX ⊥,
{have h2 : prfK AX ⊥ → global_sem_csq AX ⊥, from soundness AX ⊥,
rw ←not_imp_not at h2, exact h2},
apply h1, exact hax
end

lemma prnot_to_notpr (φ : form) (AX : ctx) (hax : sem_cons AX) :
  prfK AX (¬φ) → ¬ prfK AX φ :=
begin
intro h1, by_contradiction h2,
exact absurd (mp (mp pl5 contra_equiv_false) (mp (mp pl4 h2) h1)) (nprfalse AX hax)
end

lemma pr_to_notprnot (φ : form) (AX : ctx) (hax : sem_cons AX) :
  prfK AX φ → ¬ prfK AX (¬φ) :=
begin
have h1 := prnot_to_notpr φ AX hax,
rw ←not_imp_not at h1, intro h2, apply h1, rw not_not, exact h2,
end

-- Finite conjunction of formulas
def fin_conj : list form → form
  | []      := ⊤
  | (φ::φs) := φ & (fin_conj φs)

-- A few helper lemmas about finite conjunctions
lemma fin_conj_simp {Γ : ctx} : ∀ ψ : form, prfK Γ (¬fin_conj [ψ, ¬ψ]) :=
begin
intro ψ,
exact (not_and_subst phi_and_true).mpr not_contra
end

lemma imp_conj_imp_imp {Γ : ctx} {φ ψ χ : form} {L : list form} :
  prfK Γ ((fin_conj (φ::L)) ⊃ ψ) ↔ prfK Γ (fin_conj L ⊃ (φ ⊃ ψ)) :=
begin
split,
intro h, dsimp [fin_conj] at h, rw and_right_imp at h, exact h,
intro h, dsimp [fin_conj], rw and_right_imp, exact h
end

lemma fin_conj_cons_imp {Γ : ctx} {φ b : form} {L : list form} :
 prfK Γ (fin_conj (φ::L) ⊃ (φ ⊃ b)) → prfK Γ (fin_conj L ⊃ (φ ⊃ b)) :=
begin
intro h, rw imp_conj_imp_imp at h, rw imp_imp_iff_imp at h, exact h, exact φ,
end

lemma fin_conj_append {Γ : ctx} {L L' : list form} :
  prfK Γ ((fin_conj L' & fin_conj L) ↔ (fin_conj (L' ++ L))) :=
begin
induction L', rw fin_conj,
exact (mp (mp pl4 (cut (mp pl6 and_switch) (mp pl5 phi_and_true)))
  (cut (mp pl6 phi_and_true) (mp pl5 and_switch))),
exact mp (mp pl4 (cut (mp pl5 and_commute) (imp_and_imp (mp pl5 L'_ih))))
  (cut iden (cut (imp_and_imp (mp pl6 L'_ih)) (mp pl6 and_commute)))
end

lemma fin_conj_empty {AX : ctx} {L : list form} (hax : sem_cons AX) :
  L = [] → ¬ prfK AX (fin_conj L ⊃ ⊥) :=
begin
intro h1, subst h1,
by_contradiction h2,
exact absurd (mp h2 iden) (nprfalse AX hax)
end

lemma fin_conj_repeat_helper {AX : ctx} {θ : form} {L : list form} (hax : sem_cons AX) :
  (∀ ψ ∈ L, ψ = θ) → prfK AX (θ ⊃ fin_conj L) :=
begin
intros h1, induction L,
exact mp pl1 iden,
simp at *,
cases h1 with h1 h2,
subst h1,
exact cut (mp double_imp pl4) (imp_and_and_imp (mp (mp pl4 iden) (L_ih h2))),
end

lemma fin_conj_repeat {AX : ctx} {φ : form} {L : list form} (hax : sem_cons AX) :
  (∀ ψ ∈ L, ψ = ¬φ) → prfK AX (¬fin_conj L) → prfK AX φ :=
begin
intros h1 h2, induction L,
exact absurd (mp dne h2) (nprfalse AX hax),
simp at *,
cases h1 with h1 h3,
have h5 := contrapos.mpr (fin_conj_repeat_helper hax h3),
subst h1,
exact (mp (mp pl3 (contrapos.mpr (cut h5 dne)))
  (contrapos.mpr (cut ((demorgans.mp) (mp (mp pl6 (iff_not and_switch)) h2)) dne)))
end

lemma fin_conj_box2 {AX : ctx} {φ ψ : form} : prfK AX ((□φ & □ψ) ⊃ □(φ & ψ)) :=
begin
exact (mp double_imp (cut2 pl6 (cut pl5 (cut (mp kdist (nec pl4)) kdist))))
end

lemma fin_conj_boxn {AX : ctx} {L : list form} :
  prfK AX ((fin_conj (list.map □ L)) ⊃ (□(fin_conj L))) :=
begin
induction L,
exact (mp pl1 (nec prtrue)),
exact (cut (imp_and_imp L_ih) fin_conj_box2)
end

lemma listempty {Γ : ctx} {L : list form} :
  (∀ φ ∈ L, φ ∈ Γ) → Γ = ∅ → L = [] :=
begin
intros h1 h2,
by_contradiction h3,
have h4 := list.length_pos_of_ne_nil,
have h5 := list.exists_mem_of_length_pos,
cases h5 (h4 h3) with φ h5,
exact absurd (h1 φ h5) (set.eq_empty_iff_forall_not_mem.mp h2 φ)
end

-- Consistency for a finite set of formulas L
def fin_ax_consist (AX : ctx) (L : list form) := ¬ prfK AX (fin_conj L ⊃ ⊥)

-- Consistency for an arbitrary set of formulas Γ
def ax_consist (AX Γ : ctx) :=
  ∀ L : list form, (∀ ψ ∈ L, ψ ∈ Γ) → fin_ax_consist AX L

-- Γ is maximally ax-consistent
def max_ax_consist (AX Γ : ctx) :=
  ax_consist AX Γ ∧ (∀ Γ', Γ ⊂ Γ' → ¬ ax_consist AX Γ')

lemma max_imp_ax {AX Γ : ctx} : max_ax_consist AX Γ → ax_consist AX Γ :=
begin
intro h1, exact h1.left
end

-- Lemma 5 from class notes
lemma five_helper (AX : ctx) :
  ∀ Γ : ctx, ∀ φ : form, ∀ L : list form, ∀ b : form,
  (∀ ψ ∈ L, ψ ∈ Γ ∨ ψ = φ) → prfK AX (fin_conj L ⊃ b) → ∃ L',
  (∀ ψ ∈ L', ψ ∈ Γ) ∧ prfK AX (fin_conj L' ⊃ (φ ⊃ b)) :=
begin
intros Γ φ L b h1 h2,
revert b,
induction L,
{intros b h2, existsi ([] : list form), split,
intros ψ h3, exfalso, apply list.not_mem_nil ψ h3,
exact imp_if_imp_imp h2},
{intros b h2,
have h1a : ∀ (ψ : form), ψ ∈ L_tl → ψ ∈ Γ ∨ ψ = φ,
{intros ψ h2, apply h1 ψ (list.mem_cons_of_mem L_hd h2)},
have h1b : L_hd ∈ Γ ∨ L_hd = φ,
{apply h1 L_hd, left, refl},
cases h1b,
have h3 := and_right_imp.mp h2,
cases L_ih h1a (L_hd ⊃ b) h3 with L' ih, existsi (L_hd::L' : list form),
cases ih, split, intros ψ h4, cases h4,
subst h4, exact h1b,
apply ih_left ψ h4, rw imp_shift at ih_right,
rw ←imp_conj_imp_imp at ih_right, exact ih_right,
have h3 : prfK AX (fin_conj (L_hd::L_tl) ⊃ b),
exact h2, exact b,
have h4 := and_right_imp.mp,
have h5 : prfK AX (fin_conj L_tl ⊃ (φ ⊃ b)),
  from eq.subst h1b (h4 h2),
cases L_ih h1a (φ ⊃ b) h5 with L' ih,
existsi (L' : list form), split,
exact ih.left, exact imp_imp_iff_imp.mp ih.right}
end

lemma five (AX : ctx) :
  ∀ Γ : ctx, ∀ φ : form, ¬ ax_consist AX (Γ ∪ φ) → ∃ L',
  (∀ ψ ∈ L', ψ ∈ Γ) ∧ prfK AX (fin_conj L' ⊃ ¬φ) :=
begin
intro Γ, intro φ, intro h1, rw ax_consist at h1,
push_neg at h1,
cases h1 with L h1,
have h2 := five_helper AX Γ φ L ⊥,
cases h1,
have h3 : (∀ (ψ : form), ψ ∈ L → ψ ∈ Γ ∨ ψ = φ),
{intros ψ this, exact or.swap (h1_left ψ this)},
apply h2 h3, rw fin_ax_consist at h1_right, rw not_not at h1_right,
exact h1_right,
end

-- Lemma 6 from class notes
lemma six_helper (AX Γ : ctx) (h : ax_consist AX Γ) :
max_ax_consist AX Γ → ∀ φ : form, φ ∈ Γ ∨ (¬φ) ∈ Γ :=
begin
intros h1 φ, rw or_iff_not_and_not, by_contradiction h2,
cases h2 with h2l h2r,
cases h1 with h1l h1r,
have h2 := h1r (Γ ∪ φ), have h3 := h1r (Γ ∪ ¬φ),
have h4 : ¬ax_consist AX (Γ ∪ ¬φ),
{apply h3, from set.ssubset_insert h2r},
have h5 : ¬ax_consist AX (Γ ∪ φ),
{apply h2, from set.ssubset_insert h2l},
clear h2 h3, have h6 := five AX Γ φ _, have h7 := five AX Γ (¬φ) _,
cases h6 with L' h6, cases h7 with L h7, cases h6 with h6l h6r,
cases h7 with h7l h7r,
have h8 := imp_and_and_imp (mp (mp pl4 h6r) h7r),
have h12 := cut (mp pl6 fin_conj_append) (cut h8 (mp pl5 contra_equiv_false)),
have h13 : (∀ (ψ : form), ψ ∈ L' ++ L → ψ ∈ Γ),
{intros ψ h13, rw list.mem_append at h13,
cases h13, exact (h6l ψ) h13, exact (h7l ψ) h13},
exact absurd h12 ((h1l (L' ++ L)) h13),
exact h4, exact h5
end

lemma six (AX Γ : ctx) (h : ax_consist AX Γ) :
max_ax_consist AX Γ ↔ ∀ φ, (φ ∈ Γ ∨ (¬φ) ∈ Γ) ∧ ¬(φ ∈ Γ ∧ (¬φ) ∈ Γ) :=
begin
simp, split,
intro h1, intro φ,
split, exact six_helper AX Γ h h1 φ,
{rw ←not_and, by_contradiction h2,
cases h2 with h2 h3,
specialize h ([φ, ¬φ]), simp at *,
have h4 : (∀ (ψ : form), ψ = φ ∨ ψ = ¬φ → ψ ∈ Γ),
{intros ψ h4, cases h4, subst h4, exact h2, subst h4, exact h3},
exact absurd (fin_conj_simp φ) (h h4)},
intro h1, split, exact h,
intros Γ' h2,
have h3 : Γ ⊆ Γ' ∧ ¬ Γ' ⊆ Γ, from h2,
cases h3,
rw set.not_subset at h3_right,
apply (exists.elim h3_right), simp, intros ψ h4 h5,
specialize h1 ψ, cases h1,
cases h1_left,
apply absurd h1_left h5,
have h6 := set.mem_of_subset_of_mem h3_left h1_left,
rw ax_consist,
push_neg,
existsi ([ψ,¬ψ] : list form),
simp, split, intros φ h7, cases h7, subst h7, exact h4,
subst h7, exact h6, rw fin_ax_consist, rw not_not,
exact fin_conj_simp ψ
end

-- Exercise 1 from class notes
lemma ex1help {AX Γ : ctx} {φ : form} {L L' : list form} :
  (∀ ψ ∈ L, ψ ∈ Γ) → prfK AX (fin_conj L ⊃ φ) → (∀ ψ ∈ L', ψ ∈ (insert φ Γ))
  → ∃ L'' : list form, (∀ ψ ∈ L'', ψ ∈ Γ) ∧ prfK AX (fin_conj L'' ⊃ fin_conj L') :=
begin
intros h1 h2 h3, induction L',
existsi ([] : list form),
split,
intros ψ h4, exact false.elim h4,
exact iden,
simp at *, cases h3 with h3 h4,
cases L'_ih h4 with L'' L'_ih,
cases L'_ih with ih1 ih2,
cases h3,
existsi (L''++L : list form),
split,
simp at *, intros ψ h2,
cases h2 with h2 h5,
exact ih1 ψ h2,
exact h1 ψ h5,
subst h3,
exact (cut (mp pl6 fin_conj_append) (cut (mp pl5 and_switch) (imp_and_and_imp (mp (mp pl4 h2) ih2)))),
existsi (L'_hd::L'' : list form),
split, simp at *, split, exact h3, exact ih1,
exact imp_and_imp ih2
end

lemma exercise1 {AX Γ : ctx} {φ : form} {L : list form} :
  max_ax_consist AX Γ → (∀ ψ ∈ L, ψ ∈ Γ) → prfK AX (fin_conj L ⊃ φ) → φ ∈ Γ :=
begin
intros h1 h2 h3,
by_contradiction h4,
cases h1 with h1 h5,
specialize h5 (Γ ∪ {φ}),
simp at h5,
specialize h5 (set.ssubset_insert h4),
rw ax_consist at h5,
push_neg at h5,
cases h5 with L' h5,
cases h5 with h5 h6,
rw fin_ax_consist at h6,
rw not_not at h6,
have h7 := ex1help h2 h3 h5,
cases h7 with L'' h7,
cases h7 with h7 h8,
apply h1 L'' h7,
exact cut h8 h6
end

lemma max_dn (AX Γ : ctx) (h : max_ax_consist AX Γ) (φ : form) :
  φ ∈ Γ ↔ (¬¬φ) ∈ Γ :=
begin
split, intro h1,
have h2 : (∀ ψ ∈ [φ], ψ ∈ Γ) → prfK AX (fin_conj [φ] ⊃ (¬¬φ)) → (¬¬φ) ∈ Γ, from exercise1 h,
simp at *, apply h2, exact h1,
exact (cut (mp pl5 phi_and_true) dni),
intro h1,
have h2 : (∀ ψ ∈ [¬¬φ], ψ ∈ Γ) → prfK AX (fin_conj [¬¬φ] ⊃ φ) → φ ∈ Γ, from exercise1 h,
simp at *, apply h2, exact h1,
exact (cut (mp pl5 phi_and_true) dne),
end

lemma max_boxdn (AX Γ : ctx) (h : max_ax_consist AX Γ) (φ : form) :
  (¬□φ) ∈ Γ → (¬□(¬¬φ)) ∈ Γ :=
begin
intro h1,
have h2 : (∀ ψ ∈ [(¬□φ)], ψ ∈ Γ) → prfK AX (fin_conj [(¬□φ)] ⊃ (¬□(¬¬φ))) → (¬□(¬¬φ)) ∈ Γ,
  from exercise1 h,
simp at *, apply h2, exact h1, clear h2,
exact (cut (mp pl5 phi_and_true) (mp pl5 box_dn)),
end

lemma max_notiff (AX Γ : ctx) (h : max_ax_consist AX Γ) (φ : form) :
  φ ∉ Γ ↔ (¬φ) ∈ Γ :=
begin
split, intro h1,
have h2 := max_imp_ax h,
have h3 := six_helper AX Γ h2 h,
specialize h3 φ, cases h3, exact absurd h3 h1, exact h3,
intro h1,
have h2 := max_imp_ax h,
have h3 := six AX Γ h2,
cases h3, specialize h3_mp h (¬φ), simp at *,
cases h3_mp with mp1 mp2,
have h4 := max_dn AX Γ h φ,
rw ←not_iff_not at h4, apply h4.mpr, exact mp2 h1
end

lemma max_imp_1 {AX Γ : ctx} {φ ψ : form} :
  max_ax_consist AX Γ → (φ ∈ Γ → ψ ∈ Γ) → (φ ⊃ ψ) ∈ Γ :=
begin
intros h1 h2, rw imp_iff_not_or at h2,
cases h2,
have h3 : (∀ χ ∈ [¬φ], χ ∈ Γ) → prfK AX (fin_conj [¬φ] ⊃ (φ ⊃ ψ)) → (φ ⊃ ψ) ∈ Γ, from exercise1 h1,
simp at *, apply h3,
exact (max_notiff AX Γ h1 φ).mp h2,
exact cut (mp pl5 phi_and_true) (and_right_imp.mp exfalso),
have h3 : (∀ χ ∈ [ψ], χ ∈ Γ) → prfK AX (fin_conj [ψ] ⊃ (φ ⊃ ψ)) → (φ ⊃ ψ) ∈ Γ, from exercise1 h1,
simp at *,
apply h3, exact h2, exact (cut (mp pl5 phi_and_true) pl1),
end

lemma max_imp_2 {AX Γ : ctx} {φ ψ : form} :
  max_ax_consist AX Γ → (φ ⊃ ψ) ∈ Γ → φ ∈ Γ → ψ ∈ Γ :=
begin
intros h1 h2 h3,
have h4 : (∀ χ ∈ [φ, (φ ⊃ ψ)], χ ∈ Γ) → prfK AX (fin_conj [φ, (φ ⊃ ψ)] ⊃ ψ) → ψ ∈ Γ, from exercise1 h1,
simp at *, apply h4, intros χ h5, cases h5, subst h5, exact h3, subst h5, exact h2,
exact and_right_imp.mpr (mp pl5 phi_and_true)
end

lemma max_conj_1 {AX Γ : ctx} {φ ψ : form} :
  max_ax_consist AX Γ → (φ ∈ Γ ∧ ψ ∈ Γ) → (φ & ψ) ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ χ ∈ [φ], χ ∈ Γ) → prfK AX (fin_conj [φ] ⊃ (ψ ⊃ (φ & ψ))) → (ψ ⊃ (φ & ψ)) ∈ Γ,
  from exercise1 h1,
simp at *,
apply max_imp_2 h1,
exact h3 h2.left (cut (mp pl5 phi_and_true) pl4), exact h2.right
end

lemma max_conj_2 {AX Γ : ctx} {φ ψ : form} :
  max_ax_consist AX Γ → (φ & ψ) ∈ Γ → φ ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ χ ∈ [(φ & ψ)], χ ∈ Γ) → prfK AX (fin_conj [(φ & ψ)] ⊃ φ) → φ ∈ Γ,
  from exercise1 h1,
simp at *, apply h3, exact h2,
exact (cut (mp pl5 phi_and_true) pl5)
end

lemma max_conj_3 {AX Γ : ctx} {φ ψ : form} :
  max_ax_consist AX Γ → (φ & ψ) ∈ Γ → ψ ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ χ ∈ [(φ & ψ)], χ ∈ Γ) → prfK AX (fin_conj [(φ & ψ)] ⊃ ψ) → ψ ∈ Γ,
  from exercise1 h1,
simp at *, apply h3, exact h2,
exact (cut (mp pl5 phi_and_true) pl6)
end

lemma max_equiv (AX Γ : ctx) : max_ax_consist AX Γ ↔ ax_consist AX Γ ∧
  ∀ Γ', ax_consist AX Γ' → Γ ⊆ Γ' → Γ = Γ' :=
begin
split,
{intro h1, split, exact h1.left,
intros Γ' h2 h3, rw set.subset.antisymm_iff, split, exact h3,
by_contradiction h4,
exact h1.right Γ' (and.intro h3 h4) h2},
intro h1, split, exact h1.left,
intros Γ' h2, by_contradiction h3,
rw set.ssubset_def at h2, apply h2.right,
rw h1.right Γ' h3 h2.left,
end

open zorn
-- Lemma: if c is a chain of sets, L is a list of elements such that
-- every element in L is in Union(c), then there is an element m in c such that every
-- element of L is in m.
lemma lindenhelper (c : set ctx) (h : c.nonempty) (h1 : chain (⊆) c) (L : list form) :
(∀ φ ∈ L, φ ∈ ⋃₀(c)) → ∃ m ∈ c, (∀ ψ ∈ L, ψ ∈ m) :=
begin
intro h2,
induction L, simp,
exact h,
have h2b : ∀ φ, φ ∈ L_tl → φ ∈ ⋃₀(c),
{intros φ h3, apply h2, exact set.mem_union_right (eq φ) h3},
cases L_ih h2b with m ih,
cases ih with h3 ih,
specialize h2 L_hd,
simp at h2,
cases h2 with m' h2,
cases h2 with h2 h4,
existsi (m' ∪ m : ctx),
have h5 : m' ∪ m ∈ c,
{have h6 := chain.total_of_refl h1 h3 h2,
cases h6,
exact (eq.substr (set.union_eq_self_of_subset_right h6) h2),
exact (eq.substr (set.union_eq_self_of_subset_left h6) h3)},
existsi (h5 : m' ∪ m ∈ c),
intros ψ h6, cases h6,
subst h6, exact set.mem_union_left m h4,
exact set.mem_union_right m' (ih ψ h6)
end

lemma lindenbaum (AX Γ : ctx) (hax : ax_consist AX Γ) :
  ∃ Γ', max_ax_consist AX Γ' ∧ Γ ⊆ Γ' :=
begin
let P := { Γ'' | Γ'' ⊇ Γ ∧ ax_consist AX Γ''},
have h : ∀ c ⊆ P, chain (⊆) c → c.nonempty → ∃ub ∈ P, ∀ s ∈ c, s ⊆ ub,
{intros c h2 h3 h4, use ⋃₀(c),
have h5 := lindenhelper c h4 h3,
repeat {split},
cases h4 with Γ'' h4,
have h6 := set.mem_of_mem_of_subset h4 h2,
cases h6 with h6 h7,
apply set.subset_sUnion_of_subset c Γ'' h6 h4,
intros L h6,
cases h5 L h6 with m h5,
cases h5 with h7 h5,
cases (set.mem_of_mem_of_subset h7 h2) with h8 h9,
apply h9, exact h5,
intros s h7, exact set.subset_sUnion_of_mem h7},
have h1 : Γ ∈ P,
split,
exact set.subset.rfl,
exact hax,
cases zorn_subset₀ P h Γ h1 with Γ' h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
use Γ', split, rw max_equiv, split, apply h2.2,
intros m h5 h6, symmetry, apply h4 m, split,
apply set.subset.trans h2.1 h6,
exact h5, exact h6, apply h2.1
end

-- Corollary 8 from class notes
lemma max_ax_exists (AX : ctx) (hax : sem_cons AX) : ∃ Γ : ctx, max_ax_consist AX Γ :=
begin
have h1 : ax_consist AX ∅,
{intro L, intro h2, rw fin_ax_consist,
have h3 := listempty h2, have this : ∅ = ∅, refl,
specialize h3 this, subst h3, by_contradiction h4,
apply nprfalse AX hax, exact mp dne h4},
have h2 := lindenbaum AX ∅ h1,
cases h2 with Γ h2, cases h2 with h2 h3, existsi (Γ : ctx), apply h2
end


import algebra.big_operators data.set.finite
import category_theory.category
import tactic ring_theory.matrix

universes u v

namespace matrix
variables {l m n o : Type u} [fintype l] [fintype m] [fintype n] [fintype o]
variables {α : Type v}

section free_module

structure free_module (α : Type v) [semiring α] : Type (v+1) :=
(carrier : Type v)
[fin : fintype carrier]
[deceq : decidable_eq carrier]

instance (α) [semiring α] : has_coe_to_sort (free_module α) := ⟨_, free_module.carrier⟩
instance {α} [semiring α] (n : free_module α) : fintype n := free_module.fin _
instance {α} [semiring α] (n : free_module α) : decidable_eq n := free_module.deceq _

variables [semiring α]

open category_theory

instance : large_category (free_module α) :=
{ hom  := λ m n, matrix m n α,
  id   := λ m, 1,
  comp := λ _ _ _, matrix.mul,
  comp_id' := λ _ _, matrix.mul_one,
  id_comp' := λ _ _, matrix.one_mul,
  assoc'   := λ _ _ _ _, matrix.mul_assoc }

end free_module

section diagonal
variables [decidable_eq n]

@[simp] lemma ite_mul [semiring α] (P Q : Prop) [decidable P] [decidable Q] (a b : α) :
  (ite P a 0) * (ite Q b 0) = ite (P ∧ Q) (a * b) 0 :=
by split_ifs; simp * at *

@[simp] lemma eq_and_eq_symm {α : Type u} (a b : α) : (a = b ∧ b = a) ↔ a = b :=
by simp [eq_comm]

end diagonal

section scalar
variables [decidable_eq n] [has_zero α]

def scalar (a : α) : matrix n n α := diagonal (λ _, a)

@[simp] theorem scalar_val_eq {a : α} {i : n} : (scalar a) i i = a :=
diagonal_val_eq _

@[simp] theorem scalar_val_ne {a : α} {i j : n} (h : i ≠ j) : (scalar a) i j = 0 :=
diagonal_val_ne h

@[simp] theorem scalar_zero : (scalar 0 : matrix n n α) = 0 := diagonal_zero

@[simp] theorem scalar_one  [has_one α] : (scalar 1 : matrix n n α) = 1 := rfl

end scalar

end matrix