import group_to_pq

universes u v

section group_to_pq_properties

variables {G : Type u} [group G]

theorem same_conjugation_yields_diff_by_center' (a b : G) (hab : ∀ x : G, a ▷ x = b ▷ x) : ∃ c, a = b * c ∧ (∀ x : G, c ▷ x = x) :=
begin
    let c := b⁻¹ * a,
    have c_def : c = b⁻¹ * a := rfl,
    use c,
    split,
    {
        rw c_def,
        group,
    },
    {
        intro x,
        rw c_def,
        rw mul_rhd,
        specialize hab x,
        rw hab,
        rw ←mul_rhd,
        group,
        rw power_quandle.one_rhd,
        group,
    },
end

lemma same_conjugation_yields_diff_by_center (a b : G) (hab : ∀ x : G, a ▷ x = b ▷ x) : ∃ c, a = b * c ∧ (c ∈ subgroup.center G) :=
begin
    have h := same_conjugation_yields_diff_by_center' a b hab,
    cases h with c hc,
    cases hc with hc1 hc2,
    use c,
    split,
    exact hc1,
    intro x,
    specialize hc2 x,
    rw rhd_def_group at hc2,
    rw ←hc2,
    simp,
    rw hc2,
end

variables {H : Type v} [group H]

lemma pq_morphism_pow_nat (f : G → H) (hf : is_pq_morphism f) (a : G) (n : nat) : f (a ^ n) = (f a) ^ n :=
begin
    cases hf with hf1 hf2,
    rw ←gpow_of_nat,
    rw ←gpow_of_nat,
    rw hf2,
end

lemma pq_morphism_one (f : G → H) (hf : is_pq_morphism f) : f 1 = 1 :=
begin
    cases hf with hf1 hf2,
    rw ←gpow_zero (1 : G),
    rw hf2,
    rw gpow_zero,
end

lemma pq_morph_pres_inv (f : G → H) (hf : is_pq_morphism f) : ∀ g : G, f(g⁻¹) = (f g)⁻¹ :=
begin
    intro g,
    group,
    cases hf with hf1 hf2,
    rw hf2,
    group,
end

--def HmodZH := quotient_group.quotient (subgroup.center H)

def map_to_center_quotient (f : G → H) : G → (quotient_group.quotient (subgroup.center H)) := quotient_group.mk ∘ f

def group_morphism_mod_center (f : G → H) (hf : is_pq_morphism f) (hfs : function.surjective f) : G →* (quotient_group.quotient (subgroup.center H))
  := ⟨map_to_center_quotient f, begin
    unfold map_to_center_quotient,
    simp only [function.comp_app],
    rw pq_morphism_one f hf,
    refl,
  end, begin
    intros a b,
    --unfold map_to_center_quotient,
    --simp,
    apply quotient.sound,

    have h := same_conjugation_yields_diff_by_center (f(a) * f(b)) (f(a * b)) _,
    {
      cases h with c hc,
      cases hc with hc1 hc2,
      rw hc1,
      intro g,
      group,
      specialize hc2 g,
      rw hc2,
      group,
    },
    {
      cases hf with hf1pre hf2,
      have hf1 : ∀ a b : G, f(a * b * a⁻¹) = f(a) * f(b) * (f(a))⁻¹,
      {
        intros a b,
        specialize hf1pre a b,
        repeat {rw rhd_group_def at hf1pre},
        exact hf1pre,
      },
      intro c,
      repeat {rw rhd_def_group},
      have de := hfs c,
      cases de with d hd,
      repeat {rw ←hd},
      simp,
      repeat {rw ←mul_assoc},
      rw ←hf1,
      simp,
      repeat {rw ←mul_assoc},
      have rw_mul_assoc : f (a * b * d * b⁻¹ * a⁻¹) = f a * (f b * f d * (f b)⁻¹) * (f a)⁻¹,
      {
        rw ←hf1,
        rw ←hf1,
        repeat {rw ←mul_assoc},
      },
      rw rw_mul_assoc,
      repeat {rw ←mul_assoc},

    },
  end⟩

theorem group_morph_ker_eq_center (f : G → H) (hf : is_pq_morphism f) (hfs : function.surjective f) (hfi : function.injective f) : (monoid_hom.ker (group_morphism_mod_center f hf hfs)) = subgroup.center G :=
begin
    ext,
    split,
    {
        intro hx,
        intro g,
        /-unfold monoid_hom.ker at hx,
        simp at hx,
        unfold group_morphism_mod_center at hx,
        simp at hx,
        unfold map_to_center_quotient at hx,
        simp at hx,-/
        rw center_reformulate,
        apply hfi,
        rw ←rhd_def_group,
        rw rhd_preserved_by_morphism f hf,
        rw rhd_def_group,
        have hx2 := @quotient.exact H (quotient_group.left_rel (subgroup.center H)) (f x) (1) hx,
        specialize hx2 (f g),
        simp at hx2,
        rw ←center_reformulate_inv,
        exact hx2,
    },
    {
        intro hx,
        apply quotient.sound,
        intro g,
        simp,
        cases (hfs g) with y hy,
        rw ←hy,
        specialize hx y,
        rw center_reformulate,
        rw ←rhd_def_group,
        rw ←pq_morph_pres_inv f hf,
        rw ←rhd_preserved_by_morphism f hf,
        apply congr_arg,
        rw rhd_def_group,
        refine inv_inj.mp _,
        simp,
        rw hx,
        simp,
    },
end

-- Potensially could be made computable, but probably at little benefit.

noncomputable theorem group_mod_ker_eq_mod_center (f : G → H) (hf : is_pq_morphism f) (hfs : function.surjective f) (hfi : function.injective f) : quotient_group.quotient (monoid_hom.ker (group_morphism_mod_center f hf hfs)) ≃* (quotient_group.quotient (subgroup.center G)) :=
begin
    have subgroup_eq := group_morph_ker_eq_center f hf hfs hfi,
    fapply mul_equiv.of_bijective,
    {
        fapply quotient_group.map,
        exact monoid_hom.id G,
        rw subgroup_eq,
        tauto,
    },
    split,
    {
        intros a b,
        intro hab,
        --unfold quotient_group.map at *,
        --simp at *,
        --unfold quotient_group.lift at *,
        --simp at *,
        induction a,
        induction b,
        {
            apply quotient.sound,
            rw subgroup_eq,
            have habe := @quotient.exact G (quotient_group.left_rel (subgroup.center G)) _ _ hab,
            assumption,
        },
        {refl,},
        {refl,},
    },
    {
        intro b,
        --unfold quotient_group.map at *,
        --simp at *,
        --unfold quotient_group.lift at *,
        --simp at *,
        induction b,
        {
            use b,
            refl,
        },
        {refl,},
    },
end

noncomputable theorem quot_ker_equiv_quot_center (f : G → H) (hf : is_pq_morphism f) (hfb : function.bijective f) :
    (quotient_group.quotient (group_morphism_mod_center f hf hfb.2).ker) ≃* (quotient_group.quotient (subgroup.center H)) :=
begin
    fapply mul_equiv.of_bijective,
    exact quotient_group.ker_lift (group_morphism_mod_center f hf hfb.2),
    split,
    {
        apply quotient_group.ker_lift_injective,
    },
    {
        intro b,
        induction b,
        {
            have hae := hfb.2 b,
            cases hae with a ha,
            use a,
            simp,
            apply quotient.sound,
            intro g,
            rw ha,
            group,
        },
        {refl,},
    },
end

noncomputable theorem group_mod_center_iso (f : G → H) (hf : is_pq_morphism f) (hfb : function.bijective f) :
    (quotient_group.quotient (subgroup.center G)) ≃* (quotient_group.quotient (subgroup.center H)) :=
begin
    have e1 := group_mod_ker_eq_mod_center f hf hfb.2 hfb.1,
    have e2 := quot_ker_equiv_quot_center f hf hfb,
    have e3 := e1.symm,
    exact e3.trans e2,
end

noncomputable theorem group_center_equiv (f : G → H) (hf : is_pq_morphism f) (hfb : function.bijective f) :
    (subgroup.center G) ≃ (subgroup.center H) :=
begin
    fapply equiv.of_bijective,
    {
        intro a,
        --unfold subgroup.center at a,
        --unfold subgroup.center,
        --unfold_coes,
        --unfold_coes at a,
        cases a with b hb,
        fconstructor,
        exact (f b),
        intro g,
        cases (hfb.2 g) with c hc,
        specialize hb c,
        rw center_reformulate,
        rw center_reformulate at hb,
        have hfbc := congr_arg f hb,
        rw ←rhd_def_group at hfbc,
        rw rhd_preserved_by_morphism f hf c b at hfbc,
        rw rhd_def_group at hfbc,
        rw hc at hfbc,
        assumption,
    },
    {
        split,
        {
            intros a b,
            intro hab,
            cases a with c hc,
            cases b with d hd,
            simp,
            simp at hab,
            exact (hfb.1 hab),
        },
        {
            intro a,
            cases a with b hb,
            simp,
            cases (hfb.2 b) with c hc,
            use c,
            {
                intro g,
                specialize hb (f g),
                rw center_reformulate,
                rw center_reformulate at hb,
                apply hfb.1,
                rw ←rhd_def_group,
                rw rhd_preserved_by_morphism f hf g c,
                rw rhd_def_group,
                rw hc,
                assumption,
            },
            simp,
            assumption,
        }
    }
end

/-
noncomputable theorem group_center_iso (f : G → H) (hf : is_pq_morphism f) (hfb : function.bijective f) :
    (subgroup.center G) ≃* (subgroup.center H) :=
begin
    apply mul_equiv.mk' (group_center_equiv f hf hfb),
    intros x y,
    cases x with x hx,
    cases y with y hy,
    sorry,
end
-/

theorem group_order_bijection [fintype G] [decidable_eq G] [fintype H] [decidable_eq H]
    (f : G → H) (hf : is_pq_morphism f) (hfb : function.bijective f) :
    (∀ a : G, order_of a = order_of (f a)) :=
begin
    intro a,
    by_contradiction hc,
    by_cases ho : (order_of a < order_of (f a)),
    {
        have hm : ¬(λ (n : ℕ), ∃ (H_1 : n > 0), f a ^ n = 1) (order_of a),
        {
            apply nat.find_min (exists_pow_eq_one (f a)) ho,
        },
        simp at hm,
        have hoa := nat.find_spec (exists_pow_eq_one a),
        cases hoa with hoa1 hoa2,
        have hmh : 0 < order_of a,
        {
            exact order_of_pos a,
        },
        specialize hm hmh,
        have hmc : f a ^ order_of a = 1,
        {
            rw ←pq_morphism_pow_nat,
            unfold order_of,
            rw hoa2,
            apply pq_morphism_one f,
            exact hf,
            exact hf,
        },
        contradiction,
    },
    {
        have ho2 : (order_of (f a) < order_of a),
        {
            refine lt_of_le_of_ne _ (ne.symm hc),
            exact not_lt.mp ho,
        },
        have hm : ¬(λ (n : ℕ), ∃ (H_1 : n > 0), a ^ n = 1) (order_of (f a)),
        {
            apply nat.find_min (exists_pow_eq_one a) ho2,
        },
        simp at hm,
        have hoa := nat.find_spec (exists_pow_eq_one (f a)),
        cases hoa with hoa1 hoa2,
        have hmh : 0 < order_of (f a),
        {
            exact order_of_pos (f a),
        },
        specialize hm hmh,
        have hmc : a ^ order_of (f a) = 1,
        {
            apply hfb.1,
            rw pq_morphism_pow_nat f hf a _,
            unfold order_of,
            rw hoa2,
            rw pq_morphism_one f,
            exact hf,
        },
        contradiction,
    },
end

end group_to_pq_properties


import Lean
open Std
open Lean
/-
Terminating fragment of lambda calculus (no fixpoint combinator, assume you are not perverse
 and write your own (eg. assume this is STLC or some such.
-/
inductive Lam where
| App: Lam -> Lam -> Lam
| Var: Nat -> Lam -- numnber of parents to be walked up.
| Lam: Lam -> Lam
-- | Eval: Lam -> Lam
 deriving BEq, Inhabited

 instance : Coe Nat Lam where
   coe := .Var

 instance : OfNat Lam n where
   ofNat := .Var n

-- (fun x => fun y => fun z => x y z)
-- (fun => fun => fun => 2 1 0)

-- (fun x => fun y => fun z => x y z) (fun k => k)
-- (fun => fun => fun => 2 1 0) (fun 0 => 0)
-- (fun => fun => 1 0 (fun 0 => 0))

-- (fun x => x $ fun y => x $ fun z => x y z) (fun k => k)
-- (fun => 0 $ fun => 0 $ 1 $ fun => 2 1 0) (fun 0 => 0)
-- (fun => 0 $ (fun  => 0) $ fun => 1 0 (fun 0 => 0))

-- (fun 0 => (fun0 => fun 1 => 0 1 1) 0 0)
-- body[var = val]
@[simp]
def subst (body: Lam) (val: Lam)  (onePlusLargestLegal: Nat := 0): Lam  :=
  match body with
  | .App f x => .App (subst f val onePlusLargestLegal) (subst x val onePlusLargestLegal)
  | .Var n => if n < onePlusLargestLegal
    then .Var n else if n == onePlusLargestLegal then val else panic! "unexpected binder ix {n}"
  | .Lam body => subst body val (onePlusLargestLegal + 1)

abbrev Env := HashMap String Lam
abbrev EvalM α := StateM Env α

/-
A toplevel machine, whose equational theory captures non-computability.
Lambda calculus is annoying, needs evaluation contexts.
-/
inductive Oracle: Type where
| Running: Env -> Lam -> Oracle -- taking a step
| GroundTerm: Env -> Lam -> Oracle -- stuck term.

def Oracle.project: Oracle -> Env × Lam
| .Running e l => (e, l)
| .GroundTerm e l => (e, l)

@[reducible, simp]
def step_ (t: Lam): Lam :=
 match t with
 | .App rator rand =>
        match rator with
        | .Lam body => subst body rand
        | _ => .App (step_ rator) rand
 | .Lam body => .Lam (step_ body)
 | .Var v => .Var v

@[reducible, simp]
 def step (e: Env) (t: Lam): Oracle := .Running e (step_ t)

-- y
-- ((fun g f => f (g f)) (fun g f => f (g f))) (fun x => x)

-- let y f = f (y f)

-- s f g x = f x (g x)
@[reducible, simp]
def s : Lam := (.Lam ( .Lam ( .Lam (.App (.App 2 0) (.App 1 0)))))
@[reducible, simp]
def k : Lam := (.Lam (.Lam 1))

@[reducible, simp]
def id_ : Lam := (.Lam 0)
@[reducible, simp]
def skkid : Lam := (.App (.App (.App s k) k) id_)
@[reducible, simp]
def idid : Lam := (.App id_ id_)
-- @[reducible, simp]
-- def y_id : Lam := ((.Lam "g" (.Lam "f"  ("f" $$ ("g" $$ "f")))) $$  (.Lam "k" (.Lam "l"  ("l" $$ ("k" $$ "l"))))) $$ (.Lam "x" "x")

namespace Eqn
 axiom compute_oracle: Oracle -> Oracle
 axiom compute_oracle_running (env: Env) (lam: Lam): compute_oracle (.Running env lam) = step env lam

theorem step_id_id: compute_oracle (Oracle.Running {} idid) = compute_oracle (Oracle.Running {} id_) := by {
  rewrite [compute_oracle_running];
  simp;
  rewrite [compute_oracle_running];
  simp;
}

theorem step_skkid: compute_oracle (Oracle.Running {} skkid) = compute_oracle (Oracle.Running {} id_) := by {
  rewrite [compute_oracle_running];
  simp;
  simp;
  rewrite [compute_oracle_running];
  simp;
  simp;
  simp;

}

end Eqn

namespace Quotient
 inductive R: Oracle -> Oracle -> Prop where
 | Run: R (.Running env lam) (step env lam)

 -- quotient of oracle by run rules
 abbrev Oracle' := Quot.mk R
 #check Oracle'

theorem step_omega: ∃ (e: Env), Oracle' (Oracle.Running {} skkid) = Oracle' (Oracle.Running e id_) := by {
  simp[R.Run];
  simp[R.Run];
}
end Quotient


/-
Copyright (c) 2021 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard
-/

import algebra.algebra.basic

/-!
# The category of elliptic curves (over a field or a PID)

We give a working definition of elliptic curves which is mathematically accurate
in many cases, and also good for computation.

## Mathematical background

Let `S` be a scheme. The actual category of elliptic curves over `S` is a large category,
whose objects are schemes `E` equipped with a map `E → S`, a section `S → E`, and some
axioms (the map is smooth and proper and the fibres are geometrically connected group varieties
of dimension one). In the special case where `S` is `Spec R` for some commutative ring `R`
whose Picard group is trivial (this includes all fields, all principal ideal domains, and many
other commutative rings) then it can be shown (using rather a lot of algebro-geometric machinery)
that every elliptic curve is, up to isomorphism, a projective plane cubic defined by
the equation `y² + a₁xy + a₃y = x³ + a₂x² + a₄x + a₆`, with `aᵢ : R`, and such that
the discriminant of the aᵢ is a unit in `R`.

Some more details of the construction can be found on pages 66-69 of
[N. Katz and B. Mazur, *Arithmetic moduli of elliptic curves*][katz_mazur] or pages
53-56 of [P. Deligne, *Courbes elliptiques: formulaire d'après J. Tate*][deligne_formulaire].

## Warning

The definition in this file makes sense for all commutative rings `R`, but it only gives
a type which can be beefed up to a category which is equivalent to the category of elliptic
curves over `Spec R` in the case that `R` has trivial Picard group `Pic R` or, slightly more
generally, when its 12-torsion is trivial. The issue is that for a general ring `R`, there
might be elliptic curves over `Spec R` in the sense of algebraic geometry which are not
globally defined by a cubic equation valid over the entire base.

## TODO

Define the `R`-points (or even `A`-points if `A` is an `R`-algebra). Care will be needed at infinity
if `R` is not a field. Define the group law on the `R`-points. Prove associativity (hard).
-/

/-- The discriminant of the plane cubic `y² + a₁xy + a₃y = x³ + a₂x² + a₄x + a₆`. If `R` is a
  field, then this polynomial vanishes iff the cubic curve cut out by this equation is singular. -/
def EllipticCurve.disc_aux {R : Type*} [comm_ring R] (a₁ a₂ a₃ a₄ a₆ : R) : R :=
-(a₁ ^ 2 + 4 * a₂) ^ 2 * (a₁ ^ 2 * a₆ + 4 * a₂ * a₆ - a₁ * a₃ * a₄ + a₂ * a₃ ^ 2 - a₄ ^ 2)
  - 8 * (2 * a₄ + a₁ * a₃) ^ 3 - 27 * (a₃ ^ 2 + 4 * a₆) ^ 2
  + 9 * (a₁ ^ 2 + 4 * a₂) * (2 * a₄ + a₁ * a₃) * (a₃ ^ 2 + 4 * a₆)

-- If Pic(R)[12] = 0 then this definition is mathematically correct
/-- The category of elliptic curves over `R` (note that this definition is only mathematically
  correct for certain rings, for example if `R` is a field or a PID). -/
structure EllipticCurve (R : Type*) [comm_ring R] :=
(a₁ a₂ a₃ a₄ a₆ : R) (disc_unit : Rˣ)
(disc_unit_eq : disc_unit.val = EllipticCurve.disc_aux a₁ a₂ a₃ a₄ a₆)

namespace EllipticCurve

instance : inhabited (EllipticCurve ℚ) :=
⟨⟨0, 0, 1, -1, 0, ⟨37, 37⁻¹, by norm_num1, by norm_num1⟩, by change (37 : ℚ) = _ + _; norm_num1⟩⟩

variables {R : Type*} [comm_ring R] (E : EllipticCurve R)

/-- The discriminant of an elliptic curve given by the long Weierstrass equation.
  Sometimes only defined up to sign in the literature; we choose the sign used by the LMFDB. See
  [the LMFDB page on discriminants](https://www.lmfdb.org/knowledge/show/ec.discriminant)
  for more discussion. -/
def disc : R := disc_aux E.a₁ E.a₂ E.a₃ E.a₄ E.a₆

lemma disc_is_unit : is_unit E.disc :=
by { convert units.is_unit E.disc_unit, exact E.disc_unit_eq.symm }

/-- The j-invariant of an elliptic curve. -/
def j := E.disc_unit.inv
  * (-48 * E.a₄ - 24 * E.a₁ * E.a₃ + 16 * E.a₂ ^ 2 + 8 * E.a₁ ^ 2 * E.a₂ + E.a₁ ^ 4) ^ 3

----------------------------------------------------------------------------------------------------
/-! ## Change of variables -/

section change_of_variables

variables (u : Rˣ) (r s t : R)

/-- The elliptic curve over `R` induced by a linear change of variables
  `(x, y) ↦ (u²x + r, u³y + u²sx + t)` for some `u ∈ Rˣ` and some `r, s, t ∈ R`. -/
def cov : EllipticCurve R :=
{ a₁           := u.inv * (E.a₁ + 2 * s),
  a₂           := u.inv ^ 2 * (E.a₂ - s * E.a₁ + 3 * r - s ^ 2),
  a₃           := u.inv ^ 3 * (E.a₃ + r * E.a₁ + 2 * t),
  a₄           := u.inv ^ 4 * (E.a₄ - s * E.a₃
                               + 2 * r * E.a₂ - (t + r * s) * E.a₁
                               + 3 * r ^ 2 - 2 * s * t),
  a₆           := u.inv ^ 6 * (E.a₆ + r * E.a₄
                               + r ^ 2 * E.a₂ + r ^ 3 - t * E.a₃
                               - t ^ 2 - r * t * E.a₁),
  disc_unit    :=
  { val     := u.inv ^ 12 * E.disc_unit.val,
    inv     := u.val ^ 12 * E.disc_unit.inv,
    val_inv := by rw [← mul_assoc, ← mul_comm $ _ ^ 12, ← mul_assoc, ← mul_pow, u.val_inv, one_pow,
                      one_mul, E.disc_unit.val_inv],
    inv_val := by rw [← mul_assoc, ← mul_comm $ _ ^ 12, ← mul_assoc, ← mul_pow, u.inv_val, one_pow,
                      one_mul, E.disc_unit.inv_val] },
  disc_unit_eq := by { simp only, rw [disc_unit_eq, disc_aux, disc_aux], ring1 } }

lemma cov.j_eq : (E.cov u r s t).j = E.j :=
begin
  have lhs_rw : ∀ a₁ a₂ a₃ a₄ v : R,
    v ^ 12 * (-48 * a₄ - 24 * a₁ * a₃ + 16 * a₂ ^ 2 + 8 * a₁ ^ 2 * a₂ + a₁ ^ 4) ^ 3
    = (-48 * (v ^ 4 * a₄) - 24 * (v * a₁) * (v ^ 3 * a₃) + 16 * (v ^ 2 * a₂) ^ 2
       + 8 * (v * a₁) ^ 2 * (v ^ 2 * a₂) + (v * a₁) ^ 4) ^ 3 :=
  by { intros, ring1 },
  simp only [cov, j],
  rw [mul_comm $ u.val ^ 12, mul_assoc, lhs_rw],
  simp only [← mul_assoc u.val, ← mul_assoc (u.val ^ _), ← mul_pow, u.val_inv],
  ring1
end

variables [invertible (2 : R)]

instance invertible_two_times_two : invertible (2 * 2 : R) := invertible_mul 2 2

instance invertible_four : invertible (4 : R) :=
by { convert_to invertible (2 * 2 : R), { norm_num1 }, apply invertible_mul }

private lemma half_mul_half : (⅟2 : R) * ⅟2 = ⅟4 :=
by { rw [← inv_of_mul], apply invertible_unique, norm_num1 }

/-- The medium Weierstrass equation `covₘ` obtained by completing a square. -/
def covₘ : EllipticCurve R := E.cov 1 0 (-⅟2 * E.a₁) (-⅟2 * E.a₃)

lemma covₘ.a₁ : E.covₘ.a₁ = 0 :=
begin
  change (1 : R) * _ = 0,
  rw [one_mul, neg_mul_comm, ← mul_assoc, mul_inv_of_self, one_mul, add_neg_eq_zero]
end

lemma covₘ.a₂ : E.covₘ.a₂ = ⅟4 * E.a₁ ^ 2 + E.a₂ :=
begin
  have lhs_rw : ∀ a₁ a₂ t : R,
    a₂ - -t * a₁ * a₁ + 3 * 0 - (-t * a₁) ^ 2 = (1 - t) * t * a₁ ^ 2 + a₂ :=
  by { intros, ring1 },
  change (1 : R) ^ 2 * _ = _,
  rw [one_pow, one_mul, lhs_rw, one_sub_inv_of_two, half_mul_half]
end

lemma covₘ.a₃ : E.covₘ.a₃ = 0 :=
begin
  change (1 : R) ^ 3 * _ = 0,
  rw [one_pow, one_mul, zero_mul, add_monoid.add_zero, neg_mul_comm, ← mul_assoc,
      mul_inv_of_self, one_mul, add_neg_eq_zero]
end

lemma covₘ.a₄ : E.covₘ.a₄ = E.a₄ + ⅟2 * (E.a₁ * E.a₃) :=
begin
  have lhs_rw : ∀ a₁ a₂ a₃ a₄ t : R,
    a₄ - -t * a₁ * a₃ + 2 * 0 * a₂ - (-t * a₃ + 0 * (-t * a₁)) * a₁ + 3 * 0 ^ 2
      - 2 * (-t * a₁) * (-t * a₃) = a₄ + 2 * t * (1 - t) * (a₁ * a₃) :=
  by { intros, ring1 },
  change (1 : R) ^ 4 * _ = _,
  rw [one_pow, one_mul, lhs_rw, mul_inv_of_self, one_mul, one_sub_inv_of_two]
end

lemma covₘ.a₆ : E.covₘ.a₆ = ⅟4 * E.a₃ ^ 2 + E.a₆ :=
begin
  have lhs_rw : ∀ a₁ a₂ a₃ a₄ a₆ t : R,
    a₆ + 0 * a₄ + 0 ^ 2 * a₂ + 0 ^ 3 - -t * a₃ * a₃ - (-t * a₃) ^ 2 - 0 * (-t * a₃) * a₁
      = (1 - t) * t * a₃ ^ 2 + a₆ :=
  by { intros, ring1 },
  change (1 : R) ^ 6 * _ = _,
  rw [one_pow, one_mul, lhs_rw, one_sub_inv_of_two, half_mul_half]
end

end change_of_variables

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

end EllipticCurve


--Proof: a -> b -> a

theorem Ex002(a b : Prop) : a -> b -> a :=
assume H1 : a,
assume H2 : b,
show a, from H1


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.types
import category_theory.functor.currying
import category_theory.limits.functor_category

/-!
# The morphism comparing a colimit of limits with the corresponding limit of colimits.

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

For `F : J × K ⥤ C` there is always a morphism $\colim_k \lim_j F(j,k) → \lim_j \colim_k F(j, k)$.
While it is not usually an isomorphism, with additional hypotheses on `J` and `K` it may be,
in which case we say that "colimits commute with limits".

The prototypical example, proved in `category_theory.limits.filtered_colimit_commutes_finite_limit`,
is that when `C = Type`, filtered colimits commute with finite limits.

## References
* Borceux, Handbook of categorical algebra 1, Section 2.13
* [Stacks: Filtered colimits](https://stacks.math.columbia.edu/tag/002W)
-/

universes v u

open category_theory

namespace category_theory.limits

variables {J K : Type v} [small_category J] [small_category K]
variables {C : Type u} [category.{v} C]

variables (F : J × K ⥤ C)

open category_theory.prod

lemma map_id_left_eq_curry_map {j : J} {k k' : K} {f : k ⟶ k'} :
  F.map ((𝟙 j, f) : (j, k) ⟶ (j, k')) = ((curry.obj F).obj j).map f :=
rfl

lemma map_id_right_eq_curry_swap_map {j j' : J} {f : j ⟶ j'} {k : K} :
  F.map ((f, 𝟙 k) : (j, k) ⟶ (j', k)) = ((curry.obj (swap K J ⋙ F)).obj k).map f :=
rfl

variables [has_limits_of_shape J C]
variables [has_colimits_of_shape K C]

/--
The universal morphism
$\colim_k \lim_j F(j,k) → \lim_j \colim_k F(j, k)$.
-/
noncomputable
def colimit_limit_to_limit_colimit :
  colimit ((curry.obj (swap K J ⋙ F)) ⋙ lim) ⟶ limit ((curry.obj F) ⋙ colim) :=
limit.lift ((curry.obj F) ⋙ colim)
{ X := _,
  π :=
  { app := λ j, colimit.desc ((curry.obj (swap K J ⋙ F)) ⋙ lim)
    { X := _,
      ι :=
      { app := λ k,
          limit.π ((curry.obj (swap K J ⋙ F)).obj k) j ≫ colimit.ι ((curry.obj F).obj j) k,
        naturality' :=
        begin
          dsimp,
          intros k k' f,
          simp only [functor.comp_map, curry_obj_map_app, limits.lim_map_π_assoc, swap_map,
            category.comp_id, map_id_left_eq_curry_map, colimit.w],
        end }, },
    naturality' :=
    begin
      dsimp,
      intros j j' f,
      ext k,
      simp only [limits.colimit.ι_map, curry_obj_map_app, limits.colimit.ι_desc_assoc,
        limits.colimit.ι_desc, category.id_comp, category.assoc, map_id_right_eq_curry_swap_map,
        limit.w_assoc],
    end } }

/--
Since `colimit_limit_to_limit_colimit` is a morphism from a colimit to a limit,
this lemma characterises it.
-/
@[simp, reassoc] lemma ι_colimit_limit_to_limit_colimit_π (j) (k) :
  colimit.ι _ k ≫ colimit_limit_to_limit_colimit F ≫ limit.π _ j =
    limit.π ((curry.obj (swap K J ⋙ F)).obj k) j ≫ colimit.ι ((curry.obj F).obj j) k :=
by { dsimp [colimit_limit_to_limit_colimit], simp, }

@[simp] lemma ι_colimit_limit_to_limit_colimit_π_apply (F : J × K ⥤ Type v) (j) (k) (f) :
   limit.π ((curry.obj F) ⋙ colim) j
     (colimit_limit_to_limit_colimit F (colimit.ι ((curry.obj (swap K J ⋙ F)) ⋙ lim) k f)) =
     colimit.ι ((curry.obj F).obj j) k (limit.π ((curry.obj (swap K J ⋙ F)).obj k) j f) :=
by { dsimp [colimit_limit_to_limit_colimit], simp, }

/-- The map `colimit_limit_to_limit_colimit` realized as a map of cones. -/
@[simps] noncomputable def colimit_limit_to_limit_colimit_cone (G : J ⥤ K ⥤ C) [has_limit G] :
  colim.map_cone (limit.cone G) ⟶ limit.cone (G ⋙ colim) :=
{ hom := colim.map (limit_iso_swap_comp_lim G).hom ≫
    colimit_limit_to_limit_colimit (uncurry.obj G : _) ≫
    lim.map (whisker_right (currying.unit_iso.app G).inv colim),
  w' := λ j,
  begin
    ext1 k,
    simp only [limit_obj_iso_limit_comp_evaluation_hom_π_assoc, iso.app_inv,
      ι_colimit_limit_to_limit_colimit_π_assoc, whisker_right_app,
      colimit.ι_map, functor.map_cone_π_app, category.id_comp,
      eq_to_hom_refl, eq_to_hom_app, colimit.ι_map_assoc, limit.cone_π,
      lim_map_π_assoc, lim_map_π, category.assoc, currying_unit_iso_inv_app_app_app,
      limit_iso_swap_comp_lim_hom_app, lim_map_eq_lim_map],
    dsimp,
    simp only [category.id_comp],
    erw limit_obj_iso_limit_comp_evaluation_hom_π_assoc,
  end }

end category_theory.limits


/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis

! This file was ported from Lean 3 source module analysis.normed_space.star.basic
! leanprover-community/mathlib commit e65771194f9e923a70dfb49b6ca7be6e400d8b6f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Normed.Group.Hom
import Mathbin.Analysis.NormedSpace.Basic
import Mathbin.Analysis.NormedSpace.LinearIsometry
import Mathbin.Algebra.Star.SelfAdjoint
import Mathbin.Algebra.Star.Unitary
import Mathbin.Topology.Algebra.StarSubalgebra

/-!
# Normed star rings and algebras

A normed star group is a normed group with a compatible `star` which is isometric.

A C⋆-ring is a normed star group that is also a ring and that verifies the stronger
condition `‖x⋆ * x‖ = ‖x‖^2` for all `x`.  If a C⋆-ring is also a star algebra, then it is a
C⋆-algebra.

To get a C⋆-algebra `E` over field `𝕜`, use
`[normed_field 𝕜] [star_ring 𝕜] [normed_ring E] [star_ring E] [cstar_ring E]
 [normed_algebra 𝕜 E] [star_module 𝕜 E]`.

## TODO

- Show that `‖x⋆ * x‖ = ‖x‖^2` is equivalent to `‖x⋆ * x‖ = ‖x⋆‖ * ‖x‖`, which is used as the
  definition of C*-algebras in some sources (e.g. Wikipedia).

-/

open Topology

-- mathport name: «expr ⋆»
local postfix:max "⋆" => star

/-- A normed star group is a normed group with a compatible `star` which is isometric. -/
class NormedStarGroup (E : Type _) [SeminormedAddCommGroup E] [StarAddMonoid E] : Prop where
  norm_star : ∀ x : E, ‖x⋆‖ = ‖x‖
#align normed_star_group NormedStarGroup

export NormedStarGroup (norm_star)

attribute [simp] norm_star

variable {𝕜 E α : Type _}

section NormedStarGroup

variable [SeminormedAddCommGroup E] [StarAddMonoid E] [NormedStarGroup E]

@[simp]
theorem nnnorm_star (x : E) : ‖star x‖₊ = ‖x‖₊ :=
  Subtype.ext <| norm_star _
#align nnnorm_star nnnorm_star

/-- The `star` map in a normed star group is a normed group homomorphism. -/
def starNormedAddGroupHom : NormedAddGroupHom E E :=
  { starAddEquiv with bound' := ⟨1, fun v => le_trans (norm_star _).le (one_mul _).symm.le⟩ }
#align star_normed_add_group_hom starNormedAddGroupHom

/-- The `star` map in a normed star group is an isometry -/
theorem star_isometry : Isometry (star : E → E) :=
  show Isometry starAddEquiv from
    AddMonoidHomClass.isometry_of_norm starAddEquiv (show ∀ x, ‖x⋆‖ = ‖x‖ from norm_star)
#align star_isometry star_isometry

instance (priority := 100) NormedStarGroup.to_continuousStar : ContinuousStar E :=
  ⟨star_isometry.Continuous⟩
#align normed_star_group.to_has_continuous_star NormedStarGroup.to_continuousStar

end NormedStarGroup

instance RingHomIsometric.starRingEnd [NormedCommRing E] [StarRing E] [NormedStarGroup E] :
    RingHomIsometric (starRingEnd E) :=
  ⟨norm_star⟩
#align ring_hom_isometric.star_ring_end RingHomIsometric.starRingEnd

/-- A C*-ring is a normed star ring that satifies the stronger condition `‖x⋆ * x‖ = ‖x‖^2`
for every `x`. -/
class CstarRing (E : Type _) [NonUnitalNormedRing E] [StarRing E] : Prop where
  norm_star_mul_self : ∀ {x : E}, ‖x⋆ * x‖ = ‖x‖ * ‖x‖
#align cstar_ring CstarRing

instance : CstarRing ℝ where norm_star_mul_self x := by simp only [star, id.def, norm_mul]

namespace CstarRing

section NonUnital

variable [NonUnitalNormedRing E] [StarRing E] [CstarRing E]

-- see Note [lower instance priority]
/-- In a C*-ring, star preserves the norm. -/
instance (priority := 100) to_normedStarGroup : NormedStarGroup E :=
  ⟨by
    intro x
    by_cases htriv : x = 0
    · simp only [htriv, star_zero]
    · have hnt : 0 < ‖x‖ := norm_pos_iff.mpr htriv
      have hnt_star : 0 < ‖x⋆‖ :=
        norm_pos_iff.mpr ((AddEquiv.map_ne_zero_iff starAddEquiv).mpr htriv)
      have h₁ :=
        calc
          ‖x‖ * ‖x‖ = ‖x⋆ * x‖ := norm_star_mul_self.symm
          _ ≤ ‖x⋆‖ * ‖x‖ := norm_mul_le _ _

      have h₂ :=
        calc
          ‖x⋆‖ * ‖x⋆‖ = ‖x * x⋆‖ := by rw [← norm_star_mul_self, star_star]
          _ ≤ ‖x‖ * ‖x⋆‖ := norm_mul_le _ _

      exact le_antisymm (le_of_mul_le_mul_right h₂ hnt_star) (le_of_mul_le_mul_right h₁ hnt)⟩
#align cstar_ring.to_normed_star_group CstarRing.to_normedStarGroup

theorem norm_self_mul_star {x : E} : ‖x * x⋆‖ = ‖x‖ * ‖x‖ :=
  by
  nth_rw 1 [← star_star x]
  simp only [norm_star_mul_self, norm_star]
#align cstar_ring.norm_self_mul_star CstarRing.norm_self_mul_star

theorem norm_star_mul_self' {x : E} : ‖x⋆ * x‖ = ‖x⋆‖ * ‖x‖ := by rw [norm_star_mul_self, norm_star]
#align cstar_ring.norm_star_mul_self' CstarRing.norm_star_mul_self'

theorem nnnorm_self_mul_star {x : E} : ‖x * star x‖₊ = ‖x‖₊ * ‖x‖₊ :=
  Subtype.ext norm_self_mul_star
#align cstar_ring.nnnorm_self_mul_star CstarRing.nnnorm_self_mul_star

theorem nnnorm_star_mul_self {x : E} : ‖x⋆ * x‖₊ = ‖x‖₊ * ‖x‖₊ :=
  Subtype.ext norm_star_mul_self
#align cstar_ring.nnnorm_star_mul_self CstarRing.nnnorm_star_mul_self

@[simp]
theorem star_mul_self_eq_zero_iff (x : E) : star x * x = 0 ↔ x = 0 :=
  by
  rw [← norm_eq_zero, norm_star_mul_self]
  exact mul_self_eq_zero.trans norm_eq_zero
#align cstar_ring.star_mul_self_eq_zero_iff CstarRing.star_mul_self_eq_zero_iff

theorem star_mul_self_ne_zero_iff (x : E) : star x * x ≠ 0 ↔ x ≠ 0 := by
  simp only [Ne.def, star_mul_self_eq_zero_iff]
#align cstar_ring.star_mul_self_ne_zero_iff CstarRing.star_mul_self_ne_zero_iff

@[simp]
theorem mul_star_self_eq_zero_iff (x : E) : x * star x = 0 ↔ x = 0 := by
  simpa only [star_eq_zero, star_star] using @star_mul_self_eq_zero_iff _ _ _ _ (star x)
#align cstar_ring.mul_star_self_eq_zero_iff CstarRing.mul_star_self_eq_zero_iff

theorem mul_star_self_ne_zero_iff (x : E) : x * star x ≠ 0 ↔ x ≠ 0 := by
  simp only [Ne.def, mul_star_self_eq_zero_iff]
#align cstar_ring.mul_star_self_ne_zero_iff CstarRing.mul_star_self_ne_zero_iff

end NonUnital

section ProdPi

variable {ι R₁ R₂ : Type _} {R : ι → Type _}

variable [NonUnitalNormedRing R₁] [StarRing R₁] [CstarRing R₁]

variable [NonUnitalNormedRing R₂] [StarRing R₂] [CstarRing R₂]

variable [∀ i, NonUnitalNormedRing (R i)] [∀ i, StarRing (R i)]

/-- This instance exists to short circuit type class resolution because of problems with
inference involving Π-types. -/
instance Pi.starRing' : StarRing (∀ i, R i) :=
  inferInstance
#align pi.star_ring' Pi.starRing'

variable [Fintype ι] [∀ i, CstarRing (R i)]

instance Prod.cstarRing : CstarRing (R₁ × R₂)
    where norm_star_mul_self x := by
    unfold norm
    simp only [Prod.fst_mul, Prod.fst_star, Prod.snd_mul, Prod.snd_star, norm_star_mul_self, ← sq]
    refine' le_antisymm _ _
    · refine' max_le _ _ <;> rw [sq_le_sq, abs_of_nonneg (norm_nonneg _)]
      exact (le_max_left _ _).trans (le_abs_self _)
      exact (le_max_right _ _).trans (le_abs_self _)
    · rw [le_sup_iff]
      rcases le_total ‖x.fst‖ ‖x.snd‖ with (h | h) <;> simp [h]
#align prod.cstar_ring Prod.cstarRing

instance Pi.cstarRing : CstarRing (∀ i, R i)
    where norm_star_mul_self x :=
    by
    simp only [norm, Pi.mul_apply, Pi.star_apply, nnnorm_star_mul_self, ← sq]
    norm_cast
    exact
      (Finset.comp_sup_eq_sup_comp_of_is_total (fun x : NNReal => x ^ 2)
          (fun x y h => by simpa only [sq] using mul_le_mul' h h) (by simp)).symm
#align pi.cstar_ring Pi.cstarRing

instance Pi.cstar_ring' : CstarRing (ι → R₁) :=
  Pi.cstarRing
#align pi.cstar_ring' Pi.cstar_ring'

end ProdPi

section Unital

variable [NormedRing E] [StarRing E] [CstarRing E]

@[simp]
theorem norm_one [Nontrivial E] : ‖(1 : E)‖ = 1 :=
  by
  have : 0 < ‖(1 : E)‖ := norm_pos_iff.mpr one_ne_zero
  rw [← mul_left_inj' this.ne', ← norm_star_mul_self, mul_one, star_one, one_mul]
#align cstar_ring.norm_one CstarRing.norm_one

-- see Note [lower instance priority]
instance (priority := 100) [Nontrivial E] : NormOneClass E :=
  ⟨norm_one⟩

theorem norm_coe_unitary [Nontrivial E] (U : unitary E) : ‖(U : E)‖ = 1 := by
  rw [← sq_eq_sq (norm_nonneg _) zero_le_one, one_pow 2, sq, ← CstarRing.norm_star_mul_self,
    unitary.coe_star_mul_self, CstarRing.norm_one]
#align cstar_ring.norm_coe_unitary CstarRing.norm_coe_unitary

@[simp]
theorem norm_of_mem_unitary [Nontrivial E] {U : E} (hU : U ∈ unitary E) : ‖U‖ = 1 :=
  norm_coe_unitary ⟨U, hU⟩
#align cstar_ring.norm_of_mem_unitary CstarRing.norm_of_mem_unitary

@[simp]
theorem norm_coe_unitary_mul (U : unitary E) (A : E) : ‖(U : E) * A‖ = ‖A‖ :=
  by
  nontriviality E
  refine' le_antisymm _ _
  ·
    calc
      _ ≤ ‖(U : E)‖ * ‖A‖ := norm_mul_le _ _
      _ = ‖A‖ := by rw [norm_coe_unitary, one_mul]

  ·
    calc
      _ = ‖(U : E)⋆ * U * A‖ := by rw [unitary.coe_star_mul_self U, one_mul]
      _ ≤ ‖(U : E)⋆‖ * ‖(U : E) * A‖ := by
        rw [mul_assoc]
        exact norm_mul_le _ _
      _ = ‖(U : E) * A‖ := by rw [norm_star, norm_coe_unitary, one_mul]

#align cstar_ring.norm_coe_unitary_mul CstarRing.norm_coe_unitary_mul

@[simp]
theorem norm_unitary_smul (U : unitary E) (A : E) : ‖U • A‖ = ‖A‖ :=
  norm_coe_unitary_mul U A
#align cstar_ring.norm_unitary_smul CstarRing.norm_unitary_smul

theorem norm_mem_unitary_mul {U : E} (A : E) (hU : U ∈ unitary E) : ‖U * A‖ = ‖A‖ :=
  norm_coe_unitary_mul ⟨U, hU⟩ A
#align cstar_ring.norm_mem_unitary_mul CstarRing.norm_mem_unitary_mul

@[simp]
theorem norm_mul_coe_unitary (A : E) (U : unitary E) : ‖A * U‖ = ‖A‖ :=
  calc
    _ = ‖((U : E)⋆ * A⋆)⋆‖ := by simp only [star_star, star_mul]
    _ = ‖(U : E)⋆ * A⋆‖ := by rw [norm_star]
    _ = ‖A⋆‖ := (norm_mem_unitary_mul (star A) (unitary.star_mem U.Prop))
    _ = ‖A‖ := norm_star _

#align cstar_ring.norm_mul_coe_unitary CstarRing.norm_mul_coe_unitary

theorem norm_mul_mem_unitary (A : E) {U : E} (hU : U ∈ unitary E) : ‖A * U‖ = ‖A‖ :=
  norm_mul_coe_unitary A ⟨U, hU⟩
#align cstar_ring.norm_mul_mem_unitary CstarRing.norm_mul_mem_unitary

end Unital

end CstarRing

theorem IsSelfAdjoint.nnnorm_pow_two_pow [NormedRing E] [StarRing E] [CstarRing E] {x : E}
    (hx : IsSelfAdjoint x) (n : ℕ) : ‖x ^ 2 ^ n‖₊ = ‖x‖₊ ^ 2 ^ n :=
  by
  induction' n with k hk
  · simp only [pow_zero, pow_one]
  · rw [pow_succ, pow_mul', sq]
    nth_rw 1 [← self_adjoint.mem_iff.mp hx]
    rw [← star_pow, CstarRing.nnnorm_star_mul_self, ← sq, hk, pow_mul']
#align is_self_adjoint.nnnorm_pow_two_pow IsSelfAdjoint.nnnorm_pow_two_pow

theorem selfAdjoint.nnnorm_pow_two_pow [NormedRing E] [StarRing E] [CstarRing E] (x : selfAdjoint E)
    (n : ℕ) : ‖x ^ 2 ^ n‖₊ = ‖x‖₊ ^ 2 ^ n :=
  x.Prop.nnnorm_pow_two_pow _
#align self_adjoint.nnnorm_pow_two_pow selfAdjoint.nnnorm_pow_two_pow

section starₗᵢ

variable [CommSemiring 𝕜] [StarRing 𝕜]

variable [SeminormedAddCommGroup E] [StarAddMonoid E] [NormedStarGroup E]

variable [Module 𝕜 E] [StarModule 𝕜 E]

variable (𝕜)

/-- `star` bundled as a linear isometric equivalence -/
def starₗᵢ : E ≃ₗᵢ⋆[𝕜] E :=
  { starAddEquiv with
    map_smul' := star_smul
    norm_map' := norm_star }
#align starₗᵢ starₗᵢ

variable {𝕜}

@[simp]
theorem coe_starₗᵢ : (starₗᵢ 𝕜 : E → E) = star :=
  rfl
#align coe_starₗᵢ coe_starₗᵢ

theorem starₗᵢ_apply {x : E} : starₗᵢ 𝕜 x = star x :=
  rfl
#align starₗᵢ_apply starₗᵢ_apply

end starₗᵢ

namespace StarSubalgebra

instance toNormedAlgebra {𝕜 A : Type _} [NormedField 𝕜] [StarRing 𝕜] [SeminormedRing A] [StarRing A]
    [NormedAlgebra 𝕜 A] [StarModule 𝕜 A] (S : StarSubalgebra 𝕜 A) : NormedAlgebra 𝕜 S :=
  @NormedAlgebra.induced _ 𝕜 S A _ (SubringClass.toRing S) S.Algebra _ _ _ S.Subtype
#align star_subalgebra.to_normed_algebra StarSubalgebra.toNormedAlgebra

instance to_cstarRing {R A} [CommRing R] [StarRing R] [NormedRing A] [StarRing A] [CstarRing A]
    [Algebra R A] [StarModule R A] (S : StarSubalgebra R A) : CstarRing S
    where norm_star_mul_self x := @CstarRing.norm_star_mul_self A _ _ _ x
#align star_subalgebra.to_cstar_ring StarSubalgebra.to_cstarRing

end StarSubalgebra


import prelim.induction prelim.collections .rankfun .indep
import set_tactic.solver
open_locale classical
noncomputable theory

open set

universe u

variables {α : Type*} [fintype α]

namespace cct_family

-- This needs fixing

def C_to_I (M : cct_family α) : (set α → Prop) :=
  λ I, ∀ X, X ⊆ I → ¬M.cct X

lemma C_to_empty_indep (M : cct_family α) :
  satisfies_I1 (C_to_I M) :=
by {intro X, rw subset_empty_iff, intro hX, rw hX, exact M.C1}

lemma C_to_indep_of_subset_indep (M : cct_family α) :
  satisfies_I2 (C_to_I M) :=
λ I J hIJ hJ X hXI, hJ _ (subset.trans hXI hIJ)

lemma new_circuit_contains_new_elem {M : cct_family α} {I C : set α} {e : α} :
  C_to_I M I → C ⊆ (I ∪ {e}) → M.cct C → e ∈ C :=
λ hI hCIe hC, by {by_contra he, from hI C (subset_of_subset_add_nonmem hCIe he) hC}

lemma union_mem_singleton_unique_circuit {M : cct_family α} {I : set α} {e : α} :
  C_to_I M I → ¬C_to_I M (I ∪ {e}) → ∃! C, M.cct C ∧ C ⊆ I ∪ {e} :=
begin
  intros hI hIe, unfold C_to_I at hI hIe, push_neg at hIe,
  rcases hIe with ⟨C, ⟨hCI, hC⟩⟩, refine ⟨C,⟨⟨hC,hCI⟩,λ C' hC', _⟩⟩,
  have := mem_inter (new_circuit_contains_new_elem hI hCI hC)
                              (new_circuit_contains_new_elem hI hC'.2 hC'.1),
  by_contra hCC',
  cases M.C3 _ _ e (ne.symm hCC') hC hC'.1 this with C₀ hC₀,
  from hI _ (subset.trans hC₀.2 (removal_subset_of (union_subset hCI hC'.2))) hC₀.1,
end

lemma union_mem_singleton_le_one_circuit {M : cct_family α} {I C C': set α} (e : α) :
  C_to_I M I → (M.cct C ∧ C ⊆ I ∪ {e}) → (M.cct C' ∧ C' ⊆ I ∪ {e}) → C = C' :=
begin
  intros hI hC hC',
  by_cases h': C_to_I M (I ∪ {e}),
  exfalso, from h' _ hC.2 hC.1,
  rcases (union_mem_singleton_unique_circuit hI h') with ⟨ C₀,⟨ _,hC₀⟩⟩ ,
  from eq.trans (hC₀ _ hC) (hC₀ _ hC').symm,
end

lemma C_to_I3 (M : cct_family α) :
  satisfies_I3 (C_to_I M) :=
begin
  -- I3 states that there are no bad pairs
  let bad_pair : set α → set α → Prop :=
    λ I J, size I < size J ∧ C_to_I M I ∧ C_to_I M J ∧ ∀ (e:α), e ∈ J \ I → ¬C_to_I M (I ∪ {e}),
  suffices : ∀ I J, ¬bad_pair I J,
    push_neg at this, from λ I J hIJ hI hJ, this I J hIJ hI hJ,
  by_contra h, push_neg at h, rcases h with ⟨I₀,⟨J₀, h₀⟩⟩,

  --choose a bad pair with D = I-J minimal
  let bad_pair_diff : set α → Prop := λ D, ∃ I J, bad_pair I J ∧ I \ J = D,
  have hD₀ : bad_pair_diff (I₀ \ J₀) := ⟨I₀,⟨J₀,⟨h₀,rfl⟩⟩⟩,
  rcases minimal_example bad_pair_diff hD₀ with ⟨D,⟨_, ⟨⟨I, ⟨J, ⟨hbad, hIJD⟩⟩⟩,hDmin⟩⟩⟩,
  rcases hbad with ⟨hsIJ, ⟨hI,⟨hJ,h_non_aug⟩ ⟩  ⟩ ,
  rw ←hIJD at hDmin, clear h_left hD₀ h₀ I₀ J₀ hIJD D,
  ------------------

  have hJI_nonempty : 0 < size (J \ I) := by
  { have := size_induced_partition I J,
    rw inter_comm at this,
    linarith [size_nonneg (I \ J), hsIJ, size_induced_partition J I]},

  have hIJ_nonempty : I \ J ≠ ∅ := by
  { intro h, rw diff_empty_iff_subset at h,
    cases exists_mem_of_size_pos hJI_nonempty with e he,
    refine h_non_aug e he (C_to_indep_of_subset_indep M _ _ (_ : I ∪ {e} ⊆ J) hJ),
    from union_subset h (subset_of_mem_of_subset he (diff_subset _ _))},

  cases ne_empty_has_mem hIJ_nonempty with e he, -- choose e from I -J

  --There exists f ∈ J-I contained in all ccts of J ∪ {e}
  have : ∃ f, f ∈ J \ I ∧ ∀ C, C ⊆ J ∪ {e} → M.cct C → f ∈ C := by
  begin
    by_cases hJe : C_to_I M (J ∪ {e}) , -- Either J ∪ {e} has a circuit or doesn't
    { cases exists_mem_of_size_pos hJI_nonempty with f hf,
      exact ⟨f, ⟨hf, λ C hCJe hC, false.elim ((hJe _ hCJe) hC)⟩ ⟩},

    -- let Ce be a circuit contained in J ∪ {e}
    unfold C_to_I at hJe, push_neg at hJe, rcases hJe with ⟨Ce, ⟨hCe₁, hCe₂⟩⟩ ,

    have : Ce ∩ (J \ I) ≠ ∅,
    { by_contra hn, push_neg at hn, rw ←subset_compl_iff_disjoint at hn,
      refine hI Ce _ hCe₂,
      have hCeJI : Ce ⊆ J ∪ I,
      { refine subset.trans hCe₁ (union_subset (subset_union_left _ _) _),
        rw singleton_subset_iff, apply mem_of_mem_of_subset he,
        apply subset.trans (diff_subset _ _) (subset_union_right _ _), },
    refine subset.trans (subset_inter hCeJI hn) (λ x, _),
    simp only [mem_inter_iff, mem_union, mem_compl_iff, mem_diff, and_imp],
    tauto,},

    cases ne_empty_has_mem this with f hf,
    refine ⟨f, ⟨_, λ C hCJe hC, _⟩⟩,
    apply mem_of_mem_of_subset hf (inter_subset_right _ _),
    rw ←(union_mem_singleton_le_one_circuit e hJ ⟨hC, hCJe⟩ ⟨hCe₂, hCe₁⟩) at hf,
    from mem_of_mem_of_subset hf (inter_subset_left _ _),
  end,
  rcases this with ⟨f, ⟨hFJI, hfC⟩⟩,
  set J' := (J ∪ {e}) \ {f} with hdefJ',

  have hJ'₀: J' \ I ⊆ (J ∪ I), {
    set_ext, simp, tauto,
    --intros x hx, simp at *, tauto,
  },
  /-
  { rw hdefJ',
    repeat {refine subset.trans (diff_subset _ _) _},
    apply union_subset (subset_union_left _ _),
    rw [singleton_subset_iff, mem_union], right,
    exact mem_of_mem_diff he, },
  -/
  have hJ' : C_to_I M (J'),
  { intros X hXJ' hX,
    rw hdefJ' at hXJ',
    have hf := hfC X (subset_of_subset_diff hXJ') hX,
    have := mem_of_mem_of_subset hf hXJ',
    rw mem_diff at this, tauto},

  have hJ's : size I < size J',
  { rw mem_diff at he hFJI,
    rwa [hdefJ', size_union_singleton_remove hFJI.1 he.2], },

  have hJ'ssu : I \ J' ⊂ I \ J,
  { rw hdefJ',
    rw mem_diff at hFJI,
    simp_rw [diff_eq, compl_compl_inter_right, compl_union, inter_distrib_left,
    inter_comm _ {f}, nonmem_disjoint hFJI.2, union_empty, ←inter_assoc, ←diff_eq],
    apply ssubset_of_remove_mem he, },

  have hIJ' : ¬bad_pair I J' :=
    λ hIJ', hDmin (I \ J') hJ'ssu ⟨I,⟨J',⟨hIJ', rfl⟩⟩⟩,
  push_neg at hIJ', rcases hIJ' hJ's hI hJ' with ⟨g,⟨hg₁,hg₂⟩⟩ ,

  by_cases g ∈ J \ I,
  from h_non_aug g h hg₂,

  specialize @hJ'₀ g hg₁,
  simp only [mem_inter_eq, not_and, mem_diff, mem_compl_eq, mem_union] at h ⊢ hJ'₀ hg₁,
  tauto,
end

end cct_family

def indep_family.of_cct_family (M : cct_family α) : indep_family α :=
  ⟨M.C_to_I, M.C_to_empty_indep, M.C_to_indep_of_subset_indep, M.C_to_I3⟩

namespace matroid

def of_cct_family (M : cct_family α) : matroid α :=
  of_indep_family (indep_family.of_cct_family M)

lemma cct_of_cct_family (M : cct_family α) :
  (of_cct_family M).is_circuit = M.cct :=
begin
  ext C, rw [is_circuit],
  erw matroid.indep_of_indep_family, dsimp only,
  rw [indep_family.of_cct_family], dsimp only,
  rw [cct_family.C_to_I], dsimp only ,
  refine ⟨λ h, _, λ h, ⟨_,(λ Y hY X hX hXY, _)⟩⟩,
  rcases h with ⟨h₁,h₂⟩,
  push_neg at h₁,
  rcases h₁ with ⟨X,hX₁, hX₂⟩,
  cases subset_ssubset_or_eq hX₁,
  from false.elim (h₂ _ h _ (subset_refl _) hX₂),
  rw ←h, from hX₂,
  push_neg, from ⟨_, ⟨subset_refl _, h⟩⟩,
  from M.C2 _ _ hXY h (subset.lt_of_le_of_lt hX hY),
end

end matroid


import ground_zero.HITs.interval ground_zero.HITs.truncation
open ground_zero.structures (prop contr hset prop_is_set)
open ground_zero.types.equiv (transport transport_composition)
open ground_zero.types

namespace ground_zero
namespace theorems.prop

universes u v w

def product_prop {α : Sort u} {β : Sort v}
  (h : prop α) (g : prop β) : prop (α × β) := begin
  intros a b,
  cases a with x y, cases b with u v,
  have p := h x u, have q := g y v,
  induction p, induction q, reflexivity
end

def prop_equiv_lemma {α : Sort u} {β : Sort v}
  (F : prop α) (G : prop β) (f : α → β) (g : β → α) : α ≃ β :=
begin
  existsi f, split; existsi g,
  { intro x, apply F }, { intro y, apply G }
end

def contr_equiv_unit {α : Sort u} (h : contr α) : α ≃ types.unit := begin
  existsi (λ _, types.unit.star), split;
  existsi (λ _, h.point),
  { intro x, apply h.intro },
  { intro x, cases x, reflexivity }
end

lemma uniq_does_not_add_new_paths {α : Sort u} (a b : ∥α∥) (p : a = b :> ∥α∥) :
  HITs.truncation.uniq a b = p :> a = b :> ∥α∥ :=
prop_is_set HITs.truncation.uniq (HITs.truncation.uniq a b) p

lemma prop_is_prop {α : Sort u} : prop (prop α) := begin
  intros f g,
  have p := λ a b, (prop_is_set f) (f a b) (g a b),
  apply HITs.interval.dfunext, intro a,
  apply HITs.interval.dfunext, intro b,
  exact p a b
end

lemma prop_equiv {π : Type u} (h : prop π) : π ≃ ∥π∥ := begin
  existsi HITs.truncation.elem,
  split; existsi (HITs.truncation.rec h id); intro x,
  { reflexivity },
  { apply HITs.truncation.uniq }
end

lemma prop_from_equiv {π : Type u} (e : π ≃ ∥π∥) : prop π := begin
  cases e with f H, cases H with linv rinv,
  cases linv with g α, cases rinv with h β,
  intros a b,
  transitivity, exact (α a)⁻¹,
  symmetry, transitivity, exact (α b)⁻¹,
  apply eq.map g, exact HITs.truncation.uniq (f b) (f a)
end

theorem prop_exercise (π : Type u) : (prop π) ≃ (π ≃ ∥π∥) :=
begin
  existsi @prop_equiv π, split; existsi prop_from_equiv,
  { intro x, apply prop_is_prop },
  { intro x, simp,
    cases x with f H,
    cases H with linv rinv,
    cases linv with f α,
    cases rinv with g β,
    admit }
end

lemma comp_qinv₁ {α : Sort u} {β : Sort v} {γ : Sort w}
  (f : α → β) (g : β → α) (H : is_qinv f g) :
  qinv (λ (h : γ → α), f ∘ h) := begin
  existsi (λ h, g ∘ h), split,
  { intro h, apply HITs.interval.funext,
    intro x, exact H.pr₁ (h x) },
  { intro h, apply HITs.interval.funext,
    intro x, exact H.pr₂ (h x) }
end

lemma comp_qinv₂ {α : Sort u} {β : Sort v} {γ : Sort w}
  (f : α → β) (g : β → α) (H : is_qinv f g) :
  qinv (λ (h : β → γ), h ∘ f) := begin
  existsi (λ h, h ∘ g), split,
  { intro h, apply HITs.interval.funext,
    intro x, apply eq.map h, exact H.pr₂ x },
  { intro h, apply HITs.interval.funext,
    intro x, apply eq.map h, exact H.pr₁ x }
end

end theorems.prop
end ground_zero


-- language --
inductive message (σ : ℕ) : Type
  | null : fin σ -> message
  | conc : message -> message -> message
  | nonc : message -> message
  | pk : message -> message
  | sk : message -> message
  | keys : message -> message -> message -> message
  | encr : message -> message -> message
  | decr : message -> message -> message
  | tupl : message -> message -> message
  | func : message -> message -> message

inductive program (σ : ℕ) : Type
  | skip : program
  | secv : program -> program -> program
  | reun : program -> program -> program
  | send : program
  | recv : program
  | agP : program -> message σ -> message σ -> program

inductive form (σ : ℕ) : Type
  | atom : fin σ -> form
  | botm : form
  | impl : form -> form -> form
  | k : message σ -> form -> form
  | b : message σ -> form -> form
  | pdl : program σ -> message σ → message σ → form -> form
  | toP : program σ -> form -> form
  | mesg : message σ -> form

prefix `#` := form.atom
notation `⊥` := form.botm
infix `⊃` := form.impl
notation `~`:40 p := form.impl p ⊥
notation p `&` q := ~(p ⊃ ~q)
notation p `or` q := ~(~p & ~q)
notation `K□`:80 m `,` p := form.k m p
notation `B□`:80 m `,` p := form.b m p
notation `[` α ` : ` i ` , ` j ` ] `:80  p := form.pdl α i j p
notation `[` α `]`:80 p := form.toP α p
notation `c` m := form.mesg m
notation `[` α ` : ` i ` & ` j ` ] `:80  p := program.agP α i j
notation α `;` β := program.secv α β

@[reducible]
def ctx (σ : nat) : Type := set (form σ)

notation `·` := {}
notation Γ ` ∪ ` p := set.insert p Γ

set_option trace.eqn_compiler.elim_match true

/-
  Proof system
-/

open form
open message
open program

inductive Proof { σ : ℕ } : ctx σ → form σ → Prop
-- Propositional logic
| ax { Γ } { p : form σ } (h : p ∈ Γ) : Proof Γ p
| pl1 { Γ } { p q : form σ } : Proof Γ (p ⊃ (q ⊃ p))
| pl2 { Γ } { p q r : form σ } : Proof Γ ((p ⊃ (q ⊃ r)) ⊃ ((p ⊃ q) ⊃ (p ⊃ r)))
| pl3 { Γ } { p q } : Proof Γ (((~p) ⊃ ~q) ⊃ (((~p) ⊃ q) ⊃ p))
-- S5
| kk { Γ } { i : message σ } { p q } : Proof Γ (K□ i, (p ⊃ q) ⊃ (K□ i, p ⊃ K□ i, q))
| t { Γ } { i : message σ } { p } : Proof Γ ((K□ i, p) ⊃ p)
| s4 { Γ } { i : message σ } { p } : Proof Γ (K□ i, p ⊃ K□ i, K□ i, p)
-- KD
| bk { Γ } { i : message σ } { p q } : Proof Γ ((B□ i, (p ⊃ q)) ⊃ ((B□ i, p) ⊃ (B□ i, q)))
| dox { Γ } { i : message σ } { p } : Proof Γ (B□ i, p ⊃ ~B□ i, (~p))
| kb { Γ } { i : message σ } { p } : Proof Γ ((K□ i, p) ⊃ (B□ i, p))
-- PDL
| pdlk { Γ } { i j : message σ } { p q } (α : program σ) : Proof Γ (([α : i, j](p ⊃ q)) ⊃ ([α : i, j]p  ⊃ [α : i, j] q))
| pdt { Γ } { i j : message σ } { p : form σ } {α : program σ } : Proof Γ (([α : i, j] p) ⊃ p)
-- Deductive rules
| mp { Γ } { p q } (hpq: Proof Γ (p ⊃ q)) (hp : Proof Γ p) : Proof Γ q
| knec { Γ } { i : message σ } { p } (h : Proof · p) : Proof Γ (K□ i, p)
| bnec { Γ } { p } { i : message σ } (h : Proof · p) : Proof Γ (B□ i, p)
| gen { Γ } { p } { i j : message σ } (α : program σ) (h : Proof Γ p) : Proof Γ ([α : i, j]p)
-- Protocols
| h00 { Γ } { p : form σ } { i j : message σ }
    (hsend : Proof Γ [send : i , j] p)
    : Proof Γ [recv : j, i] p
| h01 { Γ } { p : form σ } { i j : message σ }
    (hsend : Proof Γ [recv : i , j] p)
    : Proof Γ [send : j, i] p
| h1 { Γ } { p : form σ } { i j : message σ } { α : program σ }
    (ha : Proof Γ [α : i, j]p)
    : Proof Γ (K□ i, p)
| sk1 { Γ } { p : form σ } { k i j : message σ }
    (h₀ : Proof Γ $ K□ i, (c k.keys i j))
    (h₁ : Proof Γ $ [recv : i, j]p)
    : Proof Γ $ K□ i, K□ j, c k.keys i j
| sk2 { Γ } { k i j Server : message σ }
    (h₀ : Proof Γ $ K□ i, c k)
    (h₁ : Proof Γ $ K□ j, c k)
    (h₂ : Proof Γ $ K□ Server, c k)
    : Proof Γ $ c k.keys i j
| c1 { Γ } { m₁ m₂ : message σ }
    (h₀ : Proof Γ $ c m₁)
    (h₁ : Proof Γ $ c m₂)
    : Proof Γ $ c (m₁.tupl m₂)
| c2 { Γ } { m₁ m₂ : message σ }
    (h₀ : Proof Γ $ c m₁.tupl m₂)
    : Proof Γ $ c m₁
| c₂ { Γ } { t k : message σ } (h₁ : Proof Γ $ c t.encr k) (h₂ : Proof Γ $ c k) : Proof Γ $ c t
| c3 { Γ } { m₁ m₂ : message σ }
    (h₀ : Proof Γ $ c m₁.tupl m₂)
    : Proof Γ $ c m₂
| c4 { Γ } { k i j : message σ }
    (h₀ : Proof Γ $ c k.keys i j)
    : Proof Γ $ c k.keys j i
| c5 { Γ } { i m : message σ }
    (h₀ : Proof Γ $ K□i, c m.encr (i.pk))
    (h₁ : Proof Γ $ K□i, c (i.sk))
    : Proof Γ $ K□i, c m
| c6 { Γ } { i m : message σ }
    (h₀ : Proof Γ $ K□i, c m.encr (i.sk))
    (h₁ : Proof Γ $ K□i, c (i.pk))
    : Proof Γ $ K□i, c m

notation Γ ` ⊢κ ` p := Proof Γ p
notation Γ ` ⊬ ` p := Proof Γ p → false

variable σ : ℕ
variables { A B S : message σ }
variables { Na Nb Kab Kas Kbs : message σ }
variable Γ : ctx σ
variable α : program σ

open Proof

/-
OSS - One Sided Secrecy
-/

axiom OSS_A_init_knowledge_0 : Γ ⊢κ K□ A, c Na
axiom OSS_A_init_knowledge_1 : Γ ⊢κ K□ A, c Kab
axiom OSS_B_init_knowledge_0 : Γ ⊢κ K□ B, c Kab

axiom OSS_A_to_B : Γ ⊢κ [send : A, B] c Na.encr Kab

theorem OSS_B_knows_Na : ∅ ⊢κ K□ B, c Na :=
    knec $ c₂ (mp t $ h1 $ h00 $ @OSS_A_to_B σ A B Na Kab ∅)
    (mp t $ @OSS_B_init_knowledge_0 σ B Kab ∅)

/-
NSSK - Needham-Schroeder Secret-Key
-/

variables { I R Ni Nr Kir Kis Krs : message σ }

axiom IK_I_0 : Γ ⊢κ K□ I, c Ni
axiom IK_I_1 : Γ ⊢κ K□ I, c Kis
axiom IK_R_0 : Γ ⊢κ K□ R, c Nr
axiom IK_R_1 : Γ ⊢κ K□ R, c Krs

def φIK := (K□ I, c Ni) & (K□ I, c Kis)
  & (K□ R, c Nr) & (K□ R, c Krs)

axiom NSSK_first : Γ ⊢κ ([send : I, S]c Ni)

axiom NSSK0 { α : program σ } : Γ ⊢κ [α](@φIK σ I R Ni Nr Kis Krs) ⊃ (@φIK σ I R Ni Nr Kis Krs)
axiom NSSK1 : (Γ ⊢κ [send : I, S] c Ni) -> (Γ ⊢κ c (Ni.tupl ((Kir).encr Krs)).encr Krs)
axiom NSSK2 : (Γ ⊢κ [send : S, I] (c (Ni.tupl ((Kir).encr Krs)).encr Krs)) -> (Γ ⊢κ c Kir.encr Krs)
axiom NSSK3 : (Γ ⊢κ [send : I, R] c Kir.encr Krs) -> (Γ ⊢κ c Nr.encr Kir)
axiom NSSK4 : (Γ ⊢κ [send : R, I] c Nr.encr Kir) -> (Γ ⊢κ c Nr.encr Kir)
axiom NSSK5 : Γ ⊢κ [send : I, R] (c Nr.encr Kir)

def φNSSK := [send : I, R][send : R, I][send : I, R][send : S, I][send : I, S]c Ni

lemma I_knows_KiKr_key { I S Krs : message σ }
 (h₁ : Γ ⊢κ (@φNSSK σ S I R Ni))
 (h₂ : Γ ⊢κ (@φIK σ I R Ni Nr Kis Krs))
 :  Γ ⊢κ  K□ I, K□ R, c Kir.keys I R :=
begin
  have h : (Γ ⊢κ ([send : I, S] c Ni)) := NSSK_first σ Γ,
  have h₃ : (Γ ⊢κ [send : S, I] (c (Ni.tupl ((Kir).encr Krs)).encr Krs)) := gen send ((@NSSK1 σ S Γ I Ni Kir Krs) h),
  have h₄ : (Γ ⊢κ K□ I, c (Kir.keys I R)) := sorry,
  have h₅ : (Γ ⊢κ [send : I, R]c Kir.encr Krs) := gen send ((@NSSK2 σ S Γ I Ni Kir Krs) h₃),
  have h₆ : (Γ ⊢κ [send : R, I](c Nr.encr Kir)) := gen send ((@NSSK3 σ Γ I R Nr Kir Krs) h₅),
  have h₇ := h00 h₆,
  exact sk1 h₄ h₇
end

/-
NSPK - Needham-Schroeder Public Key
-/

variables { eve ni nr : message σ }

axiom i_init₀ : Γ ⊢κ K□ I, c I.pk
axiom i_init₁ : Γ ⊢κ K□ I, c I.sk
axiom i_init₂ : Γ ⊢κ K□ I, c R.pk
axiom i_init₃ : Γ ⊢κ K□ I, c ni

def ψNSPK := (K□ I, c I.pk) & (K□ I, c I.sk) & (K□ I, c R.pk) & (K□ I, c ni)
  & (K□ R, c R.pk) & (K□ R, c R.sk) & (K□ R, c I.pk) & (K□ R, c nr)

axiom j_init₀ : Γ ⊢κ K□ R, c R.pk
axiom j_init₁ : Γ ⊢κ K□ R, c R.sk
axiom j_init₂ : Γ ⊢κ K□ R, c I.pk
axiom j_init₃ : Γ ⊢κ K□ R, c nr
axiom j_init₄ : Γ ⊢κ B□ R, [send : I, R] c ni

axiom eve_init₀ : Γ ⊢κ K□ eve, c (I.pk)
axiom eve_init₁ : Γ ⊢κ K□ eve, c (R.pk)

axiom i_to_eve₀ : Γ ⊢κ [send : I, eve] c ni.encr (R.pk)
axiom eve_to_j₀ : Γ ⊢κ [send : eve, R] c ni.encr (R.pk)

axiom j_to_eve₁ : Γ ⊢κ [send : R, eve] c (ni.tupl nr).encr (I.pk)
axiom eve_to_i₁ : Γ ⊢κ [send : R, eve] c (ni.tupl nr).encr (I.pk)

axiom i_to_eve₂ : Γ ⊢κ [send : I, eve] c nr.encr (R.pk)
axiom eve_to_j₂ : Γ ⊢κ [send : eve, R] c nr.encr (R.pk)

theorem NSAttacker : (Γ ⊢κ B□ R, [send : I, R] c ni)
  ∧ (Γ ⊢κ [send : eve, R] c ni) :=
begin
  apply and.intro,
  {
    exact j_init₄ σ Γ
  },
  {
    have h₀ := mp (@pdt σ Γ eve j (c nj.encr (j.pk)) send) eve_to_j₂,
    have h₁ := @c₂ σ Γ j nj j h₀ (mp (@t σ Γ j (c j.sk)) (@j_init₁ σ Γ j)),
    exact gen h₁
  }
end

/-
BAN - Burrows-Abadi-Needham Logic
-/

axiom tuple_π₁ { m m' : message σ } : (m.tupl m') = m
axiom tuple_π₂ { m m' : message σ } : (m.tupl m') = m'

axiom belief_over_conjunction {σ : ℕ} {Γ : ctx σ} { φ ψ : form σ } { A : message σ } :
  (Γ ⊢κ B□ A, φ) → (Γ ⊢κ B□ A, ψ) → (Γ ⊢κ B□ A, (φ & ψ))

lemma BAN_MMSK { A B m Kab : message σ }
  (h₁ : ∅ ⊢κ K□ A, c Kab.keys A B)
  (h₂ : ∅ ⊢κ [recv : A, B] c m.encr Kab) :
    ∅ ⊢κ B□ A, [send : B, A] c m :=
  begin
    have h₃ := mp kb h₁,
    have h₄ := mp pdt h₂,
    have h₅ := @bnec σ ∅ (c m.encr Kab) A h₄,
    have h₆ := h01 h₂,
    clear h₁ h₂ h₄,
    have h₇ := belief_over_conjunction h₃ h₅,
    have h₈ : (∅ ⊢κ B□ A, c m),
    have h₉ : (∅ ⊢κ [send : B , A ] c m),
    exact bnec h₉
  end

theorem BAN_JR { A B m Kab : message σ }
  (h₁ : Γ ⊢κ B□ A, ((B□ B, c m) ⊃ (c m)))
  (h₂ : Γ ⊢κ B□ A, (B□ B, c m))
    : Γ ⊢κ B□ A, c m := mp (mp (@bk σ Γ A ((B□ B, c m)) (c m)) h₁) h₂

theorem BAN_BC { i j m m' : message σ }
  (h₁ : Γ ⊢κ B□ i, [send : j, i] c m.tupl m')
    : Γ ⊢κ B□ i, [send : j, i] c m :=
  begin
    rw [tuple_π₁] at h₁,
    exact h₁
  end

theorem BAN_SC₁ { i j m m' : message σ }
  (h : Γ ⊢κ [recv : i, j] (c m.tupl m'))
  : Γ ⊢κ [recv : i, j] c m :=
  begin
    rw [tuple_π₁] at h,
    exact h
  end

theorem BAN_SC₂ { i j m m' : message σ }
  (h : Γ ⊢κ [recv : i, j] (c m.tupl m'))
  : Γ ⊢κ [recv : i, j] c m' :=
  begin
    rw [tuple_π₂] at h,
    exact h
  end


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

import algebra.homology.additive
import category_theory.idempotents.karoubi

/-!
# Idempotent completeness and homological complexes

This file contains simplifications lemmas for categories
`karoubi (homological_complex C c)` and the construction of an equivalence
of categories `karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`.

When the category `C` is idempotent complete, it is shown that
`homological_complex (karoubi C) c` is also idempotent complete.

-/

namespace category_theory

open category

variables {C : Type*} [category C] [preadditive C] {ι : Type*} {c : complex_shape ι}

namespace idempotents

namespace karoubi

namespace homological_complex

variables {P Q : karoubi (homological_complex C c)} (f : P ⟶ Q) (n : ι)

@[simp, reassoc]
lemma p_comp_d : P.p.f n ≫ f.f.f n = f.f.f n :=
homological_complex.congr_hom (p_comp f) n

@[simp, reassoc]
lemma comp_p_d : f.f.f n ≫ Q.p.f n = f.f.f n :=
homological_complex.congr_hom (comp_p f) n

@[reassoc]
lemma p_comm_f : P.p.f n ≫ f.f.f n = f.f.f n ≫ Q.p.f n :=
homological_complex.congr_hom (p_comm f) n

variable (P)

@[simp, reassoc]
lemma p_idem : P.p.f n ≫ P.p.f n = P.p.f n :=
homological_complex.congr_hom P.idem n

end homological_complex

end karoubi

open karoubi

namespace karoubi_homological_complex_equivalence

namespace functor

/-- The functor `karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c`,
on objects. -/
@[simps]
def obj (P : karoubi (homological_complex C c)) : homological_complex (karoubi C) c :=
{ X := λ n, ⟨P.X.X n, P.p.f n, by simpa only [homological_complex.comp_f]
    using homological_complex.congr_hom P.idem n⟩,
  d := λ i j,
    { f := P.p.f i ≫ P.X.d i j,
      comm := by tidy, },
  shape' := λ i j hij, by simp only [hom_eq_zero_iff,
    P.X.shape i j hij, limits.comp_zero], }

/-- The functor `karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c`,
on morphisms. -/
@[simps]
def map {P Q : karoubi (homological_complex C c)} (f : P ⟶ Q) : obj P ⟶ obj Q :=
{ f:= λ n,
  { f:= f.f.f n,
    comm := by simp, }, }

end functor

/-- The functor `karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c`. -/
@[simps]
def functor : karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c :=
{ obj := functor.obj,
  map := λ P Q f, functor.map f, }

namespace inverse

/-- The functor `homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c)`,
on objects -/
@[simps]
def obj (K : homological_complex (karoubi C) c) : karoubi (homological_complex C c) :=
{ X :=
  { X := λ n, (K.X n).X,
    d := λ i j, (K.d i j).f,
    shape' := λ i j hij, hom_eq_zero_iff.mp (K.shape i j hij),
    d_comp_d' := λ i j k hij hjk, by { simpa only [comp_f]
      using hom_eq_zero_iff.mp (K.d_comp_d i j k), }, },
  p :=
    { f := λ n, (K.X n).p,
      comm' := by simp, },
  idem := by tidy, }

/-- The functor `homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c)`,
on morphisms -/
@[simps]
def map {K L : homological_complex (karoubi C) c} (f : K ⟶ L) : obj K ⟶ obj L :=
{ f:=
  { f := λ n, (f.f n).f,
    comm' := λ i j hij, by simpa only [comp_f]
      using hom_ext.mp (f.comm' i j hij), },
  comm := by tidy, }

end inverse

/-- The functor `homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c)`. -/
@[simps]
def inverse :
  homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c) :=
{ obj := inverse.obj,
  map := λ K L f, inverse.map f, }

/-- The counit isomorphism of the equivalence
`karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`. -/
@[simps]
def counit_iso : inverse ⋙ functor ≅ 𝟭 (homological_complex (karoubi C) c) :=
eq_to_iso (functor.ext (λ P, homological_complex.ext (by tidy) (by tidy)) (by tidy))

/-- The unit isomorphism of the equivalence
`karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`. -/
@[simps]
def unit_iso : 𝟭 (karoubi (homological_complex C c)) ≅ functor ⋙ inverse :=
{ hom :=
  { app := λ P,
    { f :=
      { f := λ n, P.p.f n,
        comm' := λ i j hij, begin
          dsimp,
          simp only [homological_complex.hom.comm, homological_complex.hom.comm_assoc,
            homological_complex.p_idem],
        end },
      comm := by { ext n, dsimp, simp only [homological_complex.p_idem], }, },
    naturality' := λ P Q φ, begin
      ext,
      dsimp,
      simp only [comp_f, homological_complex.comp_f, homological_complex.comp_p_d,
        inverse.map_f_f, functor.map_f_f, homological_complex.p_comp_d],
    end, },
  inv :=
  { app := λ P,
    { f :=
      { f := λ n, P.p.f n,
        comm' := λ i j hij, begin
          dsimp,
          simp only [homological_complex.hom.comm, assoc, homological_complex.p_idem],
        end },
      comm := by { ext n, dsimp, simp only [homological_complex.p_idem], }, },
    naturality' := λ P Q φ, begin
      ext,
      dsimp,
      simp only [comp_f, homological_complex.comp_f, inverse.map_f_f, functor.map_f_f,
        homological_complex.comp_p_d, homological_complex.p_comp_d],
    end, },
  hom_inv_id' := begin
    ext,
    dsimp,
    simp only [homological_complex.p_idem, comp_f, homological_complex.comp_f, id_eq],
  end,
  inv_hom_id' := begin
    ext,
    dsimp,
    simp only [homological_complex.p_idem, comp_f, homological_complex.comp_f, id_eq,
      inverse.obj_p_f, functor.obj_X_p],
  end, }

end karoubi_homological_complex_equivalence

variables (C) (c)

/-- The equivalence `karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c`. -/
@[simps]
def karoubi_homological_complex_equivalence :
  karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c :=
{ functor    := karoubi_homological_complex_equivalence.functor,
  inverse    := karoubi_homological_complex_equivalence.inverse,
  unit_iso   := karoubi_homological_complex_equivalence.unit_iso,
  counit_iso := karoubi_homological_complex_equivalence.counit_iso, }

variables (α : Type*) [add_right_cancel_semigroup α] [has_one α]

/-- The equivalence `karoubi (chain_complex C α) ≌ chain_complex (karoubi C) α`. -/
@[simps]
def karoubi_chain_complex_equivalence :
  karoubi (chain_complex C α) ≌ chain_complex (karoubi C) α :=
karoubi_homological_complex_equivalence C (complex_shape.down α)

/-- The equivalence `karoubi (cochain_complex C α) ≌ cochain_complex (karoubi C) α`. -/
@[simps]
def karoubi_cochain_complex_equivalence :
  karoubi (cochain_complex C α) ≌ cochain_complex (karoubi C) α :=
karoubi_homological_complex_equivalence C (complex_shape.up α)

instance [is_idempotent_complete C] : is_idempotent_complete (homological_complex C c) :=
begin
  rw [is_idempotent_complete_iff_of_equivalence
    ((to_karoubi_equivalence C).map_homological_complex c),
    ← is_idempotent_complete_iff_of_equivalence (karoubi_homological_complex_equivalence C c)],
  apply_instance,
end

end idempotents

end category_theory


import pseudo_normed_group.FP
import system_of_complexes.basic
import prop819
import pseudo_normed_group.sum_hom
import pseudo_normed_group.splittable

noncomputable theory

open_locale nnreal big_operators
open category_theory opposite simplex_category

local attribute [instance] type_pow

universe variables u v u₀ uₘ
-- set_option pp.universes true

namespace system_of_complexes

variables (C : system_of_complexes)

def norm_exact_complex (D : cochain_complex SemiNormedGroup ℕ) : Prop :=
∀ (m : ℕ) (ε : ℝ≥0) (hε : 0 < ε) (x : D.X m) (hx : D.d _ (m+1) x = 0),
  ∃ y : D.X (m-1), D.d _ _ y = x ∧ ∥y∥₊ ≤ (1 + ε) * ∥x∥₊

lemma weak_exact_of_factor_exact (k : ℝ≥0) [fact (1 ≤ k)] (m : ℕ) (c₀ : ℝ≥0)
  (D : ℝ≥0 → cochain_complex SemiNormedGroup ℕ)
  (hD : ∀ c, c₀ ≤ c → norm_exact_complex (D c))
  (f : Π c, C.obj (op $ k * c) ⟶ D c)
  (g : Π c, D c ⟶ C.obj (op c))
  (hf : ∀ c i, ((f c).f i).norm_noninc)
  (hg : ∀ c i, ((g c).f i).norm_noninc)
  (hfg : ∀ c, c₀ ≤ c → f c ≫ g c = C.map (hom_of_le (fact.out _ : c ≤ k * c)).op) :
  C.is_weak_bounded_exact k 1 m c₀ :=
begin
  intros c hc i hi x ε' hε',
  let dx := C.d _ (i+1) x,
  let fx := (f _).f _ x,
  let fdx := (f c).f _ dx,
  let dfx := (D _).d _ (i+1) fx,
  have fdx_dfx : fdx = dfx,
  { simp only [fdx, dfx, fx, ← comp_apply], congr' 1, exact ((f _).comm _ _).symm },
  have hfdx : (D _).d _ (i+2) fdx = 0,
  { calc (D _).d _ (i+2) fdx = (D _).d _ (i+2) ((D _).d _ (i+1) (fx)) : congr_arg _ fdx_dfx
    ... = ((D _).d _ (i+1) ≫ (D _).d _ (i+2)) (fx) : rfl
    ... = 0 : by { rw (D c).d_comp_d _ _ _, refl } },
  let ε : ℝ≥0 := ⟨ε', hε'.le⟩,
  have hε : 0 < ε := hε',
  let δ : ℝ≥0 := ε / (∥dx∥₊ + 1),
  have hδ : 0 < δ,
  { rw [← nnreal.coe_lt_coe],
    exact div_pos hε (lt_of_le_of_lt (nnreal.coe_nonneg _) (lt_add_one _)), },
  obtain ⟨(x' : (D c).X i), (hdx' : (D c).d i (i+1) x' = fdx), hnorm_x'⟩ :=
    (hD _ hc.1) _ δ hδ _ hfdx,
  let gx' := (g _).f _ x',
  have hdfxx' : (D _).d _ (i+1) (fx - x') = 0,
  { rw [_root_.map_sub, hdx', fdx_dfx], exact sub_self _ },
  obtain ⟨y, hdy, -⟩ := (hD _ hc.1) _ δ hδ _ hdfxx',
  let gy := (g _).f _ y,
  let dgy := C.d _ i gy,
  let gdy := (g _).f _ ((D _).d _ i y),
  have gdy_dgy : gdy = dgy,
  { simp only [gdy, dgy, gy, ← comp_apply], congr' 1, exact ((g _).comm _ _).symm },
  refine ⟨i-1, i+1, rfl, rfl, gy, _⟩,
  simp only [nnreal.coe_one, one_mul],
  have hxdgy : res x - C.d _ _ gy = gx',
  { calc res x - dgy
        = (g _).f _ ((f _).f _ x) - gdy : _
    ... = gx' : by rw [← _root_.map_sub, hdy, sub_sub_cancel],
    rw [gdy_dgy, ← comp_apply, ← homological_complex.comp_f, hfg _ hc.1], refl },
  rw hxdgy,
  change (∥gx'∥₊ : ℝ) ≤ ∥dx∥₊ + ε,
  simp only [← nnreal.coe_add, nnreal.coe_le_coe],
  calc ∥gx'∥₊
      ≤ ∥x'∥₊ : hg _ _ _
  ... ≤ (1 + δ) * ∥fdx∥₊ : hnorm_x'
  ... ≤ (1 + δ) * ∥dx∥₊ : mul_le_mul' le_rfl (hf _ _ _)
  ... ≤ ∥dx∥₊ + δ * ∥dx∥₊ : by rw [add_mul, one_mul]
  ... ≤ ∥dx∥₊ + ε * 1 : add_le_add le_rfl _
  ... ≤ ∥dx∥₊ + ε : by rw [mul_one],
  dsimp only [δ],
  rw [div_eq_mul_inv, mul_assoc],
  refine mul_le_mul' le_rfl _,
  rw [nnreal.mul_le_iff_le_inv, inv_inv, mul_one],
  { exact (lt_add_one _).le },
  { refine inv_ne_zero (lt_of_le_of_lt _ (lt_add_one _)).ne',
    exact zero_le' }
end

end system_of_complexes

namespace thm95

variables (r' : ℝ) (V : SemiNormedGroup.{v}) (M : Type u) {M₁ M₂ : Type u} (N : ℕ) (d : ℝ≥0)
variables [profinitely_filtered_pseudo_normed_group M] [pseudo_normed_group.splittable M N d]
variables [profinitely_filtered_pseudo_normed_group M₁]
variables [profinitely_filtered_pseudo_normed_group M₂]
variables (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) (hf : f.strict)

section open Profinite pseudo_normed_group profinitely_filtered_pseudo_normed_group

@[simps left right]
def FLC_complex_arrow (c : ℝ≥0) : arrow Profinite :=
@arrow.mk _ _ (filtration_obj M₁ c) (filtration_obj M₂ c) $
{ to_fun := pseudo_normed_group.level f hf c,
  continuous_to_fun := f.continuous _ (λ _, rfl) }

end

section open profinitely_filtered_pseudo_normed_group
  comphaus_filtered_pseudo_normed_group

@[simps obj map]
def FLC_complex : system_of_complexes :=
{ obj := λ c, (FLC_functor V).obj (op $ FLC_complex_arrow f hf c.unop),
  map := λ c₁ c₂ h, (FLC_functor V).map $ quiver.hom.op $
    @arrow.hom_mk _ _ (FLC_complex_arrow f hf c₂.unop) (FLC_complex_arrow f hf c₁.unop)
      (⟨_, (@embedding_cast_le _ _ _ _ ⟨le_of_hom h.unop⟩).continuous⟩)
      (⟨_, (@embedding_cast_le _ _ _ _ ⟨le_of_hom h.unop⟩).continuous⟩)
      (by { ext, refl }),
  map_id' := λ c,
  begin
    convert (FLC_functor V).map_id _,
    simp only [unop_id, ←op_id, quiver.hom.op_inj.eq_iff, nat_trans.id_app],
    ext; refl,
  end,
  map_comp' := λ c₁ c₂ c₃ h1 h2,
  begin
    convert (FLC_functor V).map_comp _ _,
    simp only [← op_comp, quiver.hom.op_inj.eq_iff, nat_trans.comp_app],
    ext; refl,
  end, }
.

end

namespace FLC_complex
open pseudo_normed_group

variables (c₁ c₂ : ℝ≥0) [fact (c₁ ≤ c₂)]

def aux_space (c₁ c₂ : ℝ≥0) [fact (c₁ ≤ c₂)] :=
{ p : filtration M₂ c₁ × filtration M₁ c₂ // cast_le p.1 = level f hf c₂ p.2 }

namespace aux_space
open profinitely_filtered_pseudo_normed_group comphaus_filtered_pseudo_normed_group

instance : topological_space (aux_space f hf c₁ c₂) :=
by { delta aux_space, apply_instance }

instance : t2_space (aux_space f hf c₁ c₂) :=
by { delta aux_space, apply_instance }

instance : totally_disconnected_space (aux_space f hf c₁ c₂) :=
subtype.totally_disconnected_space

instance : compact_space (aux_space f hf c₁ c₂) :=
{ compact_univ :=
  begin
    rw embedding_subtype_coe.is_compact_iff_is_compact_image,
    simp only [set.image_univ, subtype.range_coe_subtype],
    refine is_closed.is_compact _,
    refine is_closed_eq
      ((embedding_cast_le _ _).continuous.comp continuous_fst)
      ((f.continuous _ _).comp continuous_snd),
    intro, refl
  end }

end aux_space

def AuxSpace : Profinite := Profinite.of (aux_space f hf c₁ c₂)

namespace AuxSpace

open profinitely_filtered_pseudo_normed_group

@[simps] def ι : filtration_obj M₁ c₁ ⟶ AuxSpace f hf c₁ c₂ :=
{ to_fun := λ x, ⟨⟨level f hf c₁ x, Filtration.cast_le M₁ c₁ c₂ x⟩, rfl⟩,
  continuous_to_fun :=
  begin
    rw continuous_induced_rng,
    refine continuous.prod_mk (f.continuous _ (λ _, rfl)) (Filtration.cast_le M₁ c₁ c₂).continuous,
  end }

@[simps] def fst : AuxSpace f hf c₁ c₂ ⟶ filtration_obj M₂ c₁ :=
{ to_fun := _,
  continuous_to_fun := continuous_fst.comp continuous_subtype_coe }

@[simps] def snd : AuxSpace f hf c₁ c₂ ⟶ filtration_obj M₁ c₂ :=
{ to_fun := _,
  continuous_to_fun := continuous_snd.comp continuous_subtype_coe }

@[simps left right]
def fstₐ : arrow Profinite := arrow.mk (fst f hf c₁ c₂)

include d

lemma fst_surjective [fact (0 < N)] (h : c₁ / N + d ≤ c₂ * N⁻¹) :
  function.surjective (fst _ (sum_hom_strict M N) c₁ c₂) :=
begin
  intros y,
  dsimp at y,
  obtain ⟨x, hx1, hx2⟩ := exists_sum N d _ _ y.2,
  simp only [fst_apply, function.comp_app],
  refine ⟨⟨⟨y, ⟨x, _⟩⟩, _⟩, rfl⟩,
  { erw rescale.mem_filtration, refine filtration_mono h hx2 },
  { simp only [pseudo_normed_group.level, sum_hom_apply, subtype.coe_mk, ← hx1], refl },
end

end AuxSpace

open AuxSpace profinitely_filtered_pseudo_normed_group

@[simps]
def sum_hom₀ [fact (0 < N)] (c : ℝ≥0) : filtration_obj (rescale N (M^N)) c ⟶ filtration_obj M c :=
⟨pseudo_normed_group.level (sum_hom M N) (sum_hom_strict M N) c,
  (sum_hom M N).continuous _ (λ _, rfl)⟩

@[simps left right hom]
def sum_homₐ [fact (0 < N)] (c : ℝ≥0) : arrow Profinite := arrow.mk (sum_hom₀ M N c)

def sum_homₐ_fstₐ [fact (0 < N)] : sum_homₐ M N c₁ ⟶ fstₐ _ (sum_hom_strict M N) c₁ c₂ :=
{ left := AuxSpace.ι _ _ _ _,
  right := 𝟙 _, }

def fstₐ_sum_homₐ [fact (0 < N)] : fstₐ _ (sum_hom_strict M N) c₁ c₂ ⟶ sum_homₐ M N c₂ :=
{ left := snd _ _ _ _,
  right := Filtration.cast_le _ _ _,
  w' := by { ext1 ⟨x, h⟩, exact h.symm } }

include d

lemma weak_bounded_exact (k : ℝ≥0) [hk : fact (1 ≤ k)] (m : ℕ) (c₀ : ℝ≥0) [fact (0 < N)]
  (hdkc₀N : d ≤ (k - 1) * c₀ / N) :
  (FLC_complex V _ (sum_hom_strict M N)).is_weak_bounded_exact k 1 m c₀ :=
begin
  let D := λ c, (FLC_functor V).obj (op $ fstₐ _ (sum_hom_strict M N) c (k * c)),
  let f := λ c, (FLC_functor V).map (fstₐ_sum_homₐ M N c (k * c)).op,
  let g := λ c, (FLC_functor V).map (sum_homₐ_fstₐ M N c (k * c)).op,
  refine system_of_complexes.weak_exact_of_factor_exact _ k m c₀ D _ f g _ _ _,
  { intros c hc,
    suffices : function.surjective ((unop (op (fstₐ (sum_hom M N) _ c (k * c)))).hom),
    { intros i ε hε x hx, cases i,
      { simp only [nat.one_ne_zero, homological_complex.shape, complex_shape.up_rel,
          exists_and_distrib_left, not_false_iff, normed_add_group_hom.zero_apply],
        refine ⟨(prop819_degree_zero _ this _ x hx).symm, 0, _⟩,
        simp only [nnnorm_zero, zero_le'] },
      exact prop819 _ this _ ε hε x hx },
    refine fst_surjective M N d c (k * c) _,
    calc c / N + d
        ≤ c / N + (k - 1) * c₀ / N : add_le_add le_rfl hdkc₀N
    ... ≤ c / N + (k - 1) * c / N : add_le_add le_rfl _
    ... ≤ 1 * c / N + (k - 1) * c / N : by rw one_mul
    ... = k * c / N : _,
    { simp only [div_eq_mul_inv],
      refine mul_le_mul' (mul_le_mul' le_rfl hc) le_rfl, },
    { simp only [div_eq_mul_inv, mul_assoc],
      rw ← add_mul, congr,
      rw [← nnreal.eq_iff, nnreal.coe_add, nnreal.coe_sub hk.1, add_sub_cancel'_right], } },
  { intros c i, exact FLC_functor_map_norm_noninc _ _ _ },
  { intros c i, exact FLC_functor_map_norm_noninc _ _ _ },
  { intros c hc,
    dsimp only [f, g, FLC_complex_map],
    rw [← category_theory.functor.map_comp, ← op_comp],
    refl }
end

end FLC_complex

end thm95


import data.list.basic .sqe

def atom.wf : atom → Prop
| (atom.le i ks)     := true
| (atom.dvd d i ks)  := d ≠ 0
| (atom.ndvd d i ks) := d ≠ 0

instance atom.dec_wf : decidable_pred atom.wf
| (atom.le i ks)     := decidable.is_true trivial
| (atom.dvd d i ks)  := begin simp [atom.wf], apply_instance end
| (atom.ndvd d i ks) := begin simp [atom.wf], apply_instance end

lemma normal_iff_divisor_nonzero :
  ∀ {a : atom}, a.wf ↔ divisor a ≠ 0 :=
begin intro a, cases a; simp [atom.wf, divisor] end

def formula.wf : formula → Prop
| ⊤' := true
| ⊥' := true
| (A' a) := atom.wf a
| (p ∧' q) := formula.wf p ∧ formula.wf q
| (p ∨' q) := formula.wf p ∧ formula.wf q
| (¬' p) := formula.wf p
| (∃' p) := formula.wf p

lemma wf_and_o  {p q : formula} :
  formula.wf p → formula.wf q → formula.wf (and_o p q) :=
begin
  intros hp hq, apply cases_and_o; try {assumption},
  trivial, constructor; assumption
end

lemma wf_or_o  {p q : formula} :
  formula.wf p → formula.wf q → formula.wf (or_o p q) :=
begin
  intros hp hq, apply cases_or_o; try {assumption},
  trivial, constructor; assumption
end

def formula.wf_alt (p : formula) := ∀ a ∈ p.atoms, atom.wf a

lemma wf_iff_wf_alt  :
  ∀ {p : formula}, formula.wf p ↔ formula.wf_alt p
| ⊤' := begin constructor; intro h, intros a ha, cases ha, trivial end
| ⊥' := begin constructor; intro h, intros a ha, cases ha, trivial end
| (A' a) :=
  begin
    unfold formula.wf,
    unfold formula.wf_alt, unfold formula.atoms,
    apply iff.intro; intro h,
    intros a' ha', cases ha' with he he,
    subst he, apply h, cases he,
    apply h, apply or.inl rfl
  end
| (p ∧' q) :=
  begin
    unfold formula.wf,
    repeat {rewrite wf_iff_wf_alt},
    apply iff.symm, apply list.forall_mem_append
  end
| (p ∨' q) :=
  begin
    unfold formula.wf,
    repeat {rewrite wf_iff_wf_alt},
    apply iff.symm, apply list.forall_mem_append
  end
| (¬' p) :=
  begin
    unfold formula.wf,
    rewrite wf_iff_wf_alt, refl
  end
| (∃' p) := by {simp [formula.wf, wf_iff_wf_alt], refl}

lemma wf_disj  :
  ∀ {ps : list (formula)}, (∀ p ∈ ps, formula.wf p) → formula.wf (disj ps)
| [] _ := trivial
| (p::ps) h :=
  have hp : formula.wf p := h _ (or.inl rfl),
  have hps : formula.wf (disj ps) :=
    wf_disj (list.forall_mem_of_forall_mem_cons h),
  begin
    simp [disj], apply cases_or_o;
    try {simp [formula.wf], constructor};
    {trivial <|> assumption}
  end

lemma wf_conj  :
  ∀ {ps : list (formula)}, (∀ p ∈ ps, formula.wf p) → formula.wf (conj ps)
| [] _ := trivial
| (p::ps) h :=
  have hp : formula.wf p := h _ (or.inl rfl),
  have hps : formula.wf (conj ps) :=
    wf_conj (list.forall_mem_of_forall_mem_cons h),
  begin
    simp [conj], apply cases_and_o;
    try {simp [formula.wf], constructor};
    {trivial <|> assumption}
  end

lemma wf_conj_atom  :
  ∀ {ps : list atom}, (∀ p ∈ ps, atom.wf p) → formula.wf (conj_atom ps)
| [] h := trivial
| (a::as) h :=
  begin
    simp [conj_atom], apply wf_and_o,
    apply (h _ (or.inl rfl)), apply wf_conj_atom,
    apply list.forall_mem_of_forall_mem_cons h
  end

instance formula.dec_wf  : decidable_pred formula.wf
| ⊤' := decidable.is_true trivial
| ⊥' := decidable.is_true trivial
| (A' a) := begin unfold formula.wf, apply_instance end
| (p ∧' q) :=
  begin
    unfold formula.wf,
    apply @and.decidable _ _ _ _;
    apply formula.dec_wf
  end
| (p ∨' q) :=
  begin
    unfold formula.wf,
    apply @and.decidable _ _ _ _;
    apply formula.dec_wf
  end
| (¬' p) := begin unfold formula.wf, apply formula.dec_wf end
| (∃' p) := begin unfold formula.wf, apply formula.dec_wf end


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Scott Morrison, Reid Barton
import category_theory.fully_faithful

namespace category_theory

universes v u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

section induced

/- Induced categories.

  Given a category D and a function F : C → D from a type C to the
  objects of D, there is an essentially unique way to give C a
  category structure such that F becomes a fully faithful functor,
  namely by taking Hom_C(X, Y) = Hom_D(FX, FY). We call this the
  category induced from D along F.

  As a special case, if C is a subtype of D, this produces the full
  subcategory of D on the objects belonging to C. In general the
  induced category is equivalent to the full subcategory of D on the
  image of F.

-/

variables {C : Type u₁} {D : Type u₂} [𝒟 : category.{v u₂} D]
include 𝒟
variables (F : C → D)
include F

def induced_category : Type u₁ := C

instance induced_category.category : category.{v} (induced_category F) :=
{ hom  := λ X Y, F X ⟶ F Y,
  id   := λ X, 𝟙 (F X),
  comp := λ _ _ _ f g, f ≫ g }

def induced_functor : induced_category F ⥤ D :=
{ obj := F, map := λ x y f, f }

@[simp] lemma induced_functor.obj {X} : (induced_functor F).obj X = F X := rfl
@[simp] lemma induced_functor.hom {X Y} {f : X ⟶ Y} : (induced_functor F).map f = f := rfl

instance induced_category.fully_faithful : fully_faithful (induced_functor F) :=
{ preimage := λ x y f, f }

end induced

section full_subcategory
/- A full subcategory is the special case of an induced category with F = subtype.val. -/

variables {C : Type u₂} [𝒞 : category.{v} C]
include 𝒞
variables (Z : C → Prop)

instance full_subcategory : category.{v} {X : C // Z X} :=
induced_category.category subtype.val

def full_subcategory_inclusion : {X : C // Z X} ⥤ C :=
induced_functor subtype.val

@[simp] lemma full_subcategory_inclusion.obj {X} :
  (full_subcategory_inclusion Z).obj X = X.val := rfl
@[simp] lemma full_subcategory_inclusion.map {X Y} {f : X ⟶ Y} :
  (full_subcategory_inclusion Z).map f = f := rfl

instance full_subcategory.fully_faithful : fully_faithful (full_subcategory_inclusion Z) :=
induced_category.fully_faithful subtype.val

end full_subcategory

end category_theory