/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.fully_faithful

/-!
# Functors which reflect isomorphisms

A functor `F` reflects isomorphisms if whenever `F.map f` is an isomorphism, `f` was too.

It is formalized as a `Prop` valued typeclass `reflects_isomorphisms F`.

Any fully faithful functor reflects isomorphisms.
-/

open category_theory

namespace category_theory

universes v₁ v₂ u₁ u₂

variables {C : Type u₁} [category.{v₁} C]

section reflects_iso
variables {D : Type u₂} [category.{v₂} D]

/--
Define what it means for a functor `F : C ⥤ D` to reflect isomorphisms: for any
morphism `f : A ⟶ B`, if `F.map f` is an isomorphism then `f` is as well.
Note that we do not assume or require that `F` is faithful.
-/
class reflects_isomorphisms (F : C ⥤ D) : Prop :=
(reflects : Π {A B : C} (f : A ⟶ B) [is_iso (F.map f)], is_iso f)

/-- If `F` reflects isos and `F.map f` is an iso, then `f` is an iso. -/
lemma is_iso_of_reflects_iso {A B : C} (f : A ⟶ B) (F : C ⥤ D)
  [is_iso (F.map f)] [reflects_isomorphisms F] :
  is_iso f :=
reflects_isomorphisms.reflects F f

@[priority 100]
instance of_full_and_faithful (F : C ⥤ D) [full F] [faithful F] : reflects_isomorphisms F :=
{ reflects := λ X Y f i, by exactI
  ⟨⟨F.preimage (inv (F.map f)), ⟨F.map_injective (by simp), F.map_injective (by simp)⟩⟩⟩ }

end reflects_iso

end category_theory


set_option synthInstance.etaExperiment true -- TODO: make work by default

class NonUnitalNonAssocSemiring (α : Type u)

class NonUnitalSemiring (α : Type u) extends NonUnitalNonAssocSemiring α

class Semiring (α : Type u) extends NonUnitalSemiring α

class NonUnitalCommSemiring (α : Type u) extends NonUnitalSemiring α

class CommSemiring (R : Type u) extends Semiring R

class NonUnitalNonAssocRing (α : Type u) extends NonUnitalNonAssocSemiring α

class NonUnitalRing (α : Type _) extends NonUnitalNonAssocRing α, NonUnitalSemiring α

class Ring (R : Type u) extends Semiring R

class NonUnitalCommRing (α : Type u) extends NonUnitalRing α

class CommRing (α : Type u) extends Ring α

instance (priority := 100) NonUnitalCommRing.toNonUnitalCommSemiring [s : NonUnitalCommRing α] :
    NonUnitalCommSemiring α :=
  { s with }

instance (priority := 100) CommRing.toCommSemiring [s : CommRing α] : CommSemiring α :=
  { s with }

instance (priority := 100) CommSemiring.toNonUnitalCommSemiring [s : CommSemiring α] :
    NonUnitalCommSemiring α :=
  { s with }

instance (priority := 100) CommRing.toNonUnitalCommRing [s : CommRing α] : NonUnitalCommRing α :=
  { s with }

class StarRing' (R : Type _) [NonUnitalSemiring R]
def starGizmo [CommSemiring R] [StarRing' R] : R → R := id
theorem starGizmo_foo [CommRing R] [StarRing' R] (x : R) : starGizmo x = x := rfl

namespace ReidMWE

class A (α : Type u)

class B (α : Type u) extends A α

class C (α : Type u) extends B α

class D (α : Type u) extends B α

class E (α : Type u) extends C α, D α

class F (α : Type u) extends A α

class G (α : Type u) extends F α, B α

class H (α : Type u) extends C α

class I (α : Type u) extends G α, D α

class J (α : Type u) extends H α, I α, E α

class StarRing' (R : Type 0) [B R]
def starGizmo [E R] [StarRing' R] : R → R := id

theorem starGizmo_foo [J R] [StarRing' R] (x : R) : starGizmo x = x := rfl

theorem T (i : J R) : (@D.toB.{0} R (@E.toD.{0} R (@J.toE.{0} R i))) = i.toB := rfl


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

! This file was ported from Lean 3 source module tactic.group
! leanprover-community/mathlib commit 0ff989e5d31dd73bcea3c52be7b601c95d4e3930
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Ring
import Mathbin.Tactic.DocCommands
import Mathbin.Algebra.Group.Commutator

/-!
# `group`

Normalizes expressions in the language of groups. The basic idea is to use the simplifier
to put everything into a product of group powers (`zpow` which takes a group element and an
integer), then simplify the exponents using the `ring` tactic. The process needs to be repeated
since `ring` can normalize an exponent to zero, leading to a factor that can be removed
before collecting exponents again. The simplifier step also uses some extra lemmas to avoid
some `ring` invocations.

## Tags

group_theory
-/

/- warning: tactic.group.zpow_trick -> Mathlib.Tactic.Group.zpow_trick is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] (a : G) (b : G) (n : Int) (m : Int), Eq.{succ u1} G (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b n)) (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b m)) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.hasAdd) n m)))
but is expected to have type
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] (a : G) (b : G) (n : Int) (m : Int), Eq.{succ u1} G (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b n)) (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b m)) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.instAddInt) n m)))
Case conversion may be inaccurate. Consider using '#align tactic.group.zpow_trick Mathlib.Tactic.Group.zpow_trickₓ'. -/
-- The next four lemmas are not general purpose lemmas, they are intended for use only by
-- the `group` tactic.
@[to_additive]
theorem Mathlib.Tactic.Group.zpow_trick {G : Type _} [Group G] (a b : G) (n m : ℤ) :
    a * b ^ n * b ^ m = a * b ^ (n + m) := by rw [mul_assoc, ← zpow_add]
#align tactic.group.zpow_trick Mathlib.Tactic.Group.zpow_trick
#align tactic.group.zsmul_trick Mathlib.Tactic.Group.zsmul_trick

/- warning: tactic.group.zpow_trick_one -> Mathlib.Tactic.Group.zpow_trick_one is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] (a : G) (b : G) (m : Int), Eq.{succ u1} G (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a b) (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b m)) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.hasAdd) m (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne))))))
but is expected to have type
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] (a : G) (b : G) (m : Int), Eq.{succ u1} G (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a b) (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b m)) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.instAddInt) m (OfNat.ofNat.{0} Int 1 (instOfNatInt 1)))))
Case conversion may be inaccurate. Consider using '#align tactic.group.zpow_trick_one Mathlib.Tactic.Group.zpow_trick_oneₓ'. -/
@[to_additive]
theorem Mathlib.Tactic.Group.zpow_trick_one {G : Type _} [Group G] (a b : G) (m : ℤ) :
    a * b * b ^ m = a * b ^ (m + 1) := by rw [mul_assoc, mul_self_zpow]
#align tactic.group.zpow_trick_one Mathlib.Tactic.Group.zpow_trick_one
#align tactic.group.zsmul_trick_zero Mathlib.Tactic.Group.zsmul_trick_zero

/- warning: tactic.group.zpow_trick_one' -> Mathlib.Tactic.Group.zpow_trick_one' is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] (a : G) (b : G) (n : Int), Eq.{succ u1} G (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b n)) b) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.hasAdd) n (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne))))))
but is expected to have type
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] (a : G) (b : G) (n : Int), Eq.{succ u1} G (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b n)) b) (HMul.hMul.{u1, u1, u1} G G G (instHMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))))) a (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) b (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.instAddInt) n (OfNat.ofNat.{0} Int 1 (instOfNatInt 1)))))
Case conversion may be inaccurate. Consider using '#align tactic.group.zpow_trick_one' Mathlib.Tactic.Group.zpow_trick_one'ₓ'. -/
@[to_additive]
theorem Mathlib.Tactic.Group.zpow_trick_one' {G : Type _} [Group G] (a b : G) (n : ℤ) :
    a * b ^ n * b = a * b ^ (n + 1) := by rw [mul_assoc, mul_zpow_self]
#align tactic.group.zpow_trick_one' Mathlib.Tactic.Group.zpow_trick_one'
#align tactic.group.zsmul_trick_zero' Mathlib.Tactic.Group.zsmul_trick_zero'

@[to_additive]
theorem Tactic.Group.zpow_trick_sub {G : Type _} [Group G] (a b : G) (n m : ℤ) :
    a * b ^ n * b ^ (-m) = a * b ^ (n - m) := by rw [mul_assoc, ← zpow_add] <;> rfl
#align tactic.group.zpow_trick_sub Tactic.Group.zpow_trick_sub
#align tactic.group.zsmul_trick_sub Tactic.Group.zsmul_trick_sub

namespace Tactic

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
open Tactic.SimpArgType Interactive Tactic.Group

/-- Auxiliary tactic for the `group` tactic. Calls the simplifier only. -/
unsafe def aux_group₁ (locat : Loc) : tactic Unit :=
  simp_core { failIfUnchanged := false } skip true
      [expr ``(commutatorElement_def), expr ``(mul_one), expr ``(one_mul), expr ``(one_pow),
        expr ``(one_zpow), expr ``(sub_self), expr ``(add_neg_self), expr ``(neg_add_self),
        expr ``(neg_neg), expr ``(tsub_self), expr ``(Int.ofNat_add), expr ``(Int.ofNat_mul),
        expr ``(Int.ofNat_zero), expr ``(Int.ofNat_one), expr ``(Int.ofNat_bit0),
        expr ``(Int.ofNat_bit1), expr ``(Int.mul_neg_eq_neg_mul_symm),
        expr ``(Int.neg_mul_eq_neg_mul_symm), symm_expr ``(zpow_ofNat), symm_expr ``(zpow_neg_one),
        symm_expr ``(zpow_mul), symm_expr ``(zpow_add_one), symm_expr ``(zpow_one_add),
        symm_expr ``(zpow_add), expr ``(mul_zpow_neg_one), expr ``(zpow_zero), expr ``(mul_zpow),
        symm_expr ``(mul_assoc), expr ``(Mathlib.Tactic.Group.zpow_trick),
        expr ``(Mathlib.Tactic.Group.zpow_trick_one), expr ``(Mathlib.Tactic.Group.zpow_trick_one'),
        expr ``(zpow_trick_sub), expr ``(Tactic.Ring.horner)]
      [] locat >>
    skip
#align tactic.aux_group₁ tactic.aux_group₁

/-- Auxiliary tactic for the `group` tactic. Calls `ring_nf` to normalize exponents. -/
unsafe def aux_group₂ (locat : Loc) : tactic Unit :=
  ring_nf none Tactic.Ring.NormalizeMode.raw locat
#align tactic.aux_group₂ tactic.aux_group₂

end Tactic

namespace Tactic.Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
open Tactic

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Tactic for normalizing expressions in multiplicative groups, without assuming
commutativity, using only the group axioms without any information about which group
is manipulated.

(For additive commutative groups, use the `abel` tactic instead.)

Example:
```lean
example {G : Type} [group G] (a b c d : G) (h : c = (a*b^2)*((b*b)⁻¹*a⁻¹)*d) : a*c*d⁻¹ = a :=
begin
  group at h, -- normalizes `h` which becomes `h : c = d`
  rw h,       -- the goal is now `a*d*d⁻¹ = a`
  group,      -- which then normalized and closed
end
```
-/
unsafe def group (locat : parse location) : tactic Unit := do
  when locat sorry
  aux_group₁ locat
  repeat (andthen (aux_group₂ locat) (aux_group₁ locat))
#align tactic.interactive.group tactic.interactive.group

end Tactic.Interactive

add_tactic_doc
  { Name := "group"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.group]
    tags := ["decision procedure", "simplification"] }


import ..myring.order
import ..myring.integral_domain

namespace hidden

class myfield (α : Type) extends myring α, has_inv α :=
(mul_inv {x : α}: x ≠ 0 → x * x⁻¹ = 1)
(nontrivial: (0: α) ≠ 1)

namespace myfield

open myring

variables {α : Type} [myfield α] (x y z : α)

theorem one_ne_zero : (1 : α) ≠ 0 :=
begin
  assume h,
  apply @nontrivial α,
  symmetry,
  assumption,
end

theorem zero_ne_one : (0 : α) ≠ 1 := nontrivial

theorem inv_mul {x : α} (hx : x ≠ 0) : x⁻¹ * x = 1 :=
begin
  rw [mul_comm],
  apply mul_inv hx,
end

theorem nzero_impl_inv_nzero (hx : x ≠ 0) : x⁻¹ ≠ 0 :=
begin
  assume hinv0,
  apply hx,
  apply one_eq_zero_impl_all_zero,
  rw [←mul_inv hx, hinv0, myring.mul_zero],
end

instance: integral_domain α := ⟨begin
  intros a b ha hba,
  rw [←myring.mul_one b, ←mul_inv ha, ←myring.mul_assoc, hba, myring.zero_mul],
end⟩

open integral_domain

theorem inv_unique {x : α} (y : α) (hx : x ≠ 0) : x * y = 1 → y = x⁻¹ :=
begin
  intro hxy,
  apply mul_cancel_left x,
    exact hx,
  rw hxy,
  symmetry,
  exact mul_inv hx,
end

@[simp] theorem one_inv : 1⁻¹ = (1 : α) := begin
  symmetry,
  apply inv_unique,
    exact one_ne_zero,
  rw one_mul,
end

theorem inv_nzero {x : α} (hx : x ≠ 0) : x⁻¹ ≠ 0 :=
begin
  intro hx0,
  apply @nontrivial α,
  rw [←mul_inv hx, ←mul_zero x, hx0],
end

theorem inv_inv {x : α} (hx : x ≠ 0) : x⁻¹⁻¹ = x :=
begin
  apply mul_cancel_right _ x⁻¹,
    exact inv_nzero hx,
  rw mul_comm,
  transitivity (1 : α),
    apply mul_inv,
    exact inv_nzero hx,
  symmetry,
  apply mul_inv hx,
end

theorem inv_inj {x y : α} (hx : x ≠ 0) (hy : y ≠ 0): x⁻¹ = y⁻¹ → x = y :=
begin
  intro hxy,
  rw [←inv_inv hx, ←inv_inv hy],
  congr,
  assumption,
end

theorem inv_distr {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) : (x * y)⁻¹ = x⁻¹ * y⁻¹ :=
begin
  have hxy : x * y ≠ 0 := mul_nzero hx hy,
  apply mul_cancel_right _ (x * y),
    exact hxy,
  rw [mul_comm, mul_inv hxy, mul_comm x, mul_assoc, ←mul_assoc y⁻¹, mul_comm y⁻¹,
      mul_inv hy, one_mul, inv_mul hx],
end

def div : α → α → α := λ a b, a * b⁻¹
instance: has_div α := ⟨div⟩

-- -- Division

theorem div_def : x / y = x * y⁻¹ := rfl

@[simp] theorem div_one : x / 1 = x :=
begin
  change x * 1⁻¹ = x,
  rw [one_inv, mul_one],
end

theorem one_div : 1 / x = x⁻¹ :=
begin
  change 1 * x⁻¹ = x⁻¹,
  rw one_mul,
end

@[simp] theorem zero_div : 0 / x = 0 :=
begin
  change 0 * x⁻¹ = 0,
  rw zero_mul,
end

theorem mul_div_cancel : y ≠ 0 → (x * y) / y = x :=
begin
  intro hy,
  change x * y * y⁻¹ = x,
  rw [mul_assoc, mul_inv hy, mul_one],
end

theorem div_mul_cancel : y ≠ 0 → (x / y) * y = x :=
begin
  intro hy,
  change x * y⁻¹ * y = x,
  rw [mul_assoc, inv_mul hy, mul_one],
end

theorem div_self {x : α} : x ≠ 0 → x / x = 1 :=
begin
  intro hx,
  change x * x⁻¹ = 1,
  exact mul_inv hx,
end

theorem div_inv_switch {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) : x / y = (y / x)⁻¹ :=
begin
  change x * y⁻¹ = (y * x⁻¹)⁻¹,
  rw [inv_distr hy (inv_nzero hx), inv_inv hx, mul_comm],
end

theorem add_div : (x + y) / z = x / z + y / z :=
begin
  change (x + y) * z⁻¹ = x * z⁻¹ + y * z⁻¹,
  apply add_mul,
end

-- Handy
theorem half_plus_half (water : 2 ≠ (0 : α)) (ε : α) : ε / 2 + ε / 2 = ε :=
begin
  rw [div_def, ←mul_add, ←one_div, ←add_div],
  change ε * (2 / 2) = ε,
  rw [div_self water, mul_one],
end

theorem minus_half (water : 2 ≠ (0 : α)) (ε : α) : ε - ε /2 = ε / 2 := sorry

end myfield

end hidden


import group_theory.group_action.sum
import logic.equiv.transfer_instance
import mathlib.group_action
import mathlib.logic
import phase0.index
import phase0.litter
import phase0.pretangle

/-!
# Structural permutations

In this file, we define the ambient groups of *structural permutations*.  These will later have
recursively-constructed subgroups of *semi-allowable* and *allowable permutations* which will act on
tangles; we define these larger ambient groups in advance in order to set up their infrastructure of
derivatives and so on independently of the recursion.
-/

open cardinal equiv quiver quiver.path set with_bot
open_locale cardinal pointwise

noncomputable theory

universe u

namespace con_nf
variable [params.{u}]

/-- A *structural permutation* on a proper type index is defined by its derivatives,
as well as its permutation on atoms. -/
/- Note: perhaps should be constructed directly as *groups*, not just types. -/
def struct_perm : Π α : type_index, Type u
| ⊥ := near_litter_perm
| (α : Λ) := Π β : type_index, β < α → struct_perm β
using_well_founded { dec_tac := `[assumption] }

namespace struct_perm
section
variables {α β : Λ} {γ : type_index}

noncomputable! instance : Π α, inhabited (struct_perm α)
| ⊥ := by { unfold struct_perm, exact near_litter_perm.inhabited }
| (α : Λ) := by { unfold struct_perm,
  exact @pi.inhabited _ _ (λ β, @pi.inhabited _ _ $ λ _ : β < ↑α, inhabited β) }
using_well_founded { dec_tac := `[assumption] }

lemma coe_def (α : Λ) : struct_perm ↑α = Π β : type_index, β < α → struct_perm β :=
by unfold struct_perm

/-- The "identity" equivalence between `near_litter_perm` and `struct_perm ⊥`. -/
def to_bot : near_litter_perm ≃ struct_perm ⊥ := equiv.cast $ by unfold struct_perm

/-- The "identity" equivalence between `struct_perm ⊥` and `near_litter_perm`. -/
def of_bot : struct_perm ⊥ ≃ near_litter_perm := equiv.cast $ by unfold struct_perm

/-- The "identity" equivalence between `Π β < α, struct_perm β` and `struct_perm α`. -/
def to_coe : (Π β : type_index, β < α → struct_perm β) ≃ struct_perm α :=
equiv.cast $ by unfold struct_perm

/-- The "identity" equivalence between `struct_perm α` and `Π β < α, struct_perm β`. -/
def of_coe : struct_perm α ≃ Π β : type_index, β < α → struct_perm β :=
equiv.cast $ by unfold struct_perm

@[simp] lemma to_bot_symm : to_bot.symm = of_bot := rfl
@[simp] lemma of_bot_symm : of_bot.symm = to_bot := rfl
@[simp] lemma to_coe_symm : to_coe.symm = (of_coe : struct_perm α ≃ _) := rfl
@[simp] lemma of_coe_symm : of_coe.symm = (to_coe : _ ≃ struct_perm α) := rfl
@[simp] lemma to_bot_of_bot (a) : to_bot (of_bot a) = a := by simp [to_bot, of_bot]
@[simp] lemma of_bot_to_bot (a) : of_bot (to_bot a) = a := by simp [to_bot, of_bot]
@[simp] lemma to_coe_of_coe (a : struct_perm α) : to_coe (of_coe a) = a := by simp [to_coe, of_coe]
@[simp] lemma of_coe_to_coe (a) : of_coe (to_coe a : struct_perm α) = a := by simp [to_coe, of_coe]
@[simp] lemma to_bot_inj {a b} : to_bot a = to_bot b ↔ a = b := to_bot.injective.eq_iff
@[simp] lemma of_bot_inj {a b} : of_bot a = of_bot b ↔ a = b := of_bot.injective.eq_iff
@[simp] lemma to_coe_inj {a b} : (to_coe a : struct_perm α) = to_coe b ↔ a = b :=
to_coe.injective.eq_iff
@[simp] lemma of_coe_inj {a b : struct_perm α} : of_coe a = of_coe b ↔ a = b :=
of_coe.injective.eq_iff

noncomputable! instance group : Π α, group (struct_perm α)
| ⊥ := of_bot.group
| (α : Λ) := @equiv.group _ _ of_coe $ @pi.group _ _ $ λ β,
  @pi_Prop.group _ _ $ λ _ : β < ↑α, group β
using_well_founded { dec_tac := `[assumption] }

/--  The isomorphism between near-litter permutations and bottom structural permutations. This holds
by definition of `struct_perm`. -/
def to_bot_iso : near_litter_perm ≃* struct_perm ⊥ :=
{ map_mul' := λ a b,
  by { rw [show struct_perm.group ⊥ = _, by unfold struct_perm.group], congr; simp },
  ..to_bot }

@[simp] lemma coe_to_bot_iso : ⇑to_bot_iso = to_bot := rfl
@[simp] lemma coe_to_bot_iso_symm : ⇑to_bot_iso.symm = of_bot := rfl

/--  The isomorphism between the product of structural permutations under `α` and `α`-structural
permutations. This holds by definition of `struct_perm`. -/
def to_coe_iso (α : Λ) : (Π β : type_index, β < α → struct_perm β) ≃* struct_perm α :=
{ map_mul' := λ a b,
    by { rw [show struct_perm.group α = _, by unfold struct_perm.group], congr; simp },
  ..to_coe }

@[simp] lemma coe_to_coe_iso (α : Λ) : ⇑(to_coe_iso α) = to_coe := rfl
@[simp] lemma coe_to_coe_iso_symm (α : Λ) : ⇑(to_coe_iso α).symm = of_coe := rfl

@[simp] lemma to_bot_one : to_bot 1 = 1 := to_bot_iso.map_one
@[simp] lemma of_bot_one : of_bot 1 = 1 := to_bot_iso.symm.map_one
@[simp] lemma to_bot_mul (a b) : to_bot (a * b) = to_bot a * to_bot b := to_bot_iso.map_mul _ _
@[simp] lemma of_bot_mul (a b) : of_bot (a * b) = of_bot a * of_bot b := to_bot_iso.symm.map_mul _ _
@[simp] lemma to_bot_inv (a) : to_bot a⁻¹ = (to_bot a)⁻¹ := to_bot_iso.map_inv _
@[simp] lemma of_bot_inv (a) : of_bot a⁻¹ = (of_bot a)⁻¹ := to_bot_iso.symm.map_inv _

@[simp] lemma to_coe_one : (to_coe 1 : struct_perm α) = 1 := (to_coe_iso α).map_one
@[simp] lemma of_coe_one : of_coe (1 : struct_perm α) = 1 := (to_coe_iso α).symm.map_one
@[simp] lemma to_coe_mul (a b) : (to_coe (a * b) : struct_perm α) = to_coe a * to_coe b :=
(to_coe_iso α).map_mul _ _
@[simp] lemma of_coe_mul (a b : struct_perm α) : of_coe (a * b) = of_coe a * of_coe b :=
(to_coe_iso α).symm.map_mul _ _

end

variables {α β γ : type_index}

/-- Obtains the permutations on lower types induced by a structural permutation. -/
def lower : ∀ {α β : type_index}, β ≤ α → struct_perm α →* struct_perm β
| ⊥ ⊥ hβ := monoid_hom.id _
| ⊥ (β : Λ) hβ := (not_coe_le_bot _ hβ).elim
| (α : Λ) β hβ := if h : β = α then by { subst h, exact monoid_hom.id _ } else
  { to_fun := λ f, of_coe f _ $ hβ.lt_of_ne h,
  map_one' := congr_fun₂ of_coe_one _ _,
  map_mul' := λ _ _, congr_fun₂ (of_coe_mul _ _) _ _ }

@[simp] lemma lower_self : lower le_rfl = monoid_hom.id (struct_perm α) :=
by { cases α, { refl }, { exact dif_pos rfl } }

/-- The near-litter permutation associated to a structural permutation. -/
def to_near_litter_perm : struct_perm α →* near_litter_perm :=
to_bot_iso.symm.to_monoid_hom.comp $ lower bot_le

lemma coe_to_near_litter_perm :
  (to_near_litter_perm : struct_perm ⊥ → near_litter_perm) = of_bot :=
by simp [to_near_litter_perm]

/-- The derivative of a structural permutation at any lower level. -/
noncomputable def derivative : Π {β}, path α β → struct_perm α →* struct_perm β
| _ nil := monoid_hom.id _
| γ (cons p_αγ hβγ) := (lower $ le_of_lt hβγ).comp $ derivative p_αγ

/-- The derivative along the empty path does nothing. -/
@[simp] lemma derivative_nil (π : struct_perm α) : derivative nil π = π := rfl

lemma derivative_cons (π : struct_perm α) (p : path α β) {γ : type_index} (h : γ < β) :
  derivative (p.cons h) π = (derivative (path.nil.cons h)) (derivative p π) :=
by simp only [derivative]; refl

/-- The derivative map is functorial. -/
lemma derivative_derivative (π : struct_perm α) (p : path α β) :
  ∀ {γ : type_index} (q : path β γ), derivative q (derivative p π) = derivative (p.comp q) π
| _ nil := by simp only [derivative_nil, comp_nil]
| γ (cons q f) := by simp only [comp_cons, derivative, monoid_hom.coe_comp, function.comp_app,
  derivative_derivative]

/-- The derivative map preserves multiplication. -/
lemma derivative_mul {β} (π₁ π₂ : struct_perm α) (A : path (α : type_index) β) :
  derivative A (π₁ * π₂) = derivative A π₁ * derivative A π₂ := by simp only [map_mul]

section
variables {X : Type*} [mul_action near_litter_perm X]

/-- Structural permutations act on atoms. -/
instance mul_action_of_near_litter_perm : mul_action (struct_perm α) X :=
mul_action.comp_hom _ to_near_litter_perm

@[simp] lemma to_near_litter_perm_smul (f : struct_perm α) (x : X) :
  f.to_near_litter_perm • x = f • x := rfl

@[simp] lemma to_bot_smul (f : near_litter_perm) (x : X) : to_bot f • x = f • x :=
by { change to_near_litter_perm _ • _ = _ • _, rw [coe_to_near_litter_perm, of_bot_to_bot] }

@[simp] lemma of_bot_smul (f : struct_perm ⊥) (x : X) : of_bot f • x = f • x :=
by rw [←to_bot_smul, to_bot_of_bot]

@[simp] lemma to_bot_inv_smul (f : near_litter_perm) (x : X) : (to_bot f)⁻¹ • x = f⁻¹ • x :=
by rw [inv_smul_eq_iff, to_bot_smul, smul_inv_smul]

@[simp] lemma of_bot_inv_smul (f : struct_perm ⊥) (x : X) : (of_bot f)⁻¹ • x = f⁻¹ • x :=
by rw [inv_smul_eq_iff, of_bot_smul, smul_inv_smul]

@[simp] lemma derivative_bot_smul {α : Λ} (f : struct_perm α) (x : X) :
  struct_perm.derivative (nil.cons (bot_lt_coe α)) f • x = f • x := rfl

lemma smul_near_litter_fst (π : struct_perm α) (N : near_litter) : (π • N).fst = π • N.fst := rfl

end

def proto_smul : Π α : type_index, struct_perm α → pretangle α → pretangle α
| ⊥ := λ π t, pretangle.to_bot $ of_bot π • t.of_bot
| (α : Λ) := λ π t, pretangle.to_coe $ λ β (hβ : β < α), proto_smul β (of_coe π β hβ) '' pretangle.of_coe t β hβ
using_well_founded { dec_tac := `[assumption] }

instance has_smul_pretangle : Π α : type_index, has_smul (struct_perm α) (pretangle α) | α := ⟨proto_smul α⟩

@[simp] lemma of_bot_smul_pretangle (π : struct_perm ⊥) (t : pretangle ⊥) :
  (π • t).of_bot = of_bot π • t.of_bot :=
begin
dsimp [struct_perm.has_smul_pretangle],
have : (proto_smul ⊥) = λ π t, pretangle.to_bot $ of_bot π • t.of_bot,
unfold proto_smul,
rw this,
simp only [pretangle.of_bot_to_bot],
end

@[simp] lemma to_bot_smul_pretangle (π : near_litter_perm) (t : atom) :
   pretangle.to_bot (π • t) = to_bot π • pretangle.to_bot t :=
pretangle.of_bot.injective $
  by simp_rw [of_bot_smul_pretangle, of_bot_to_bot, pretangle.of_bot_to_bot]

@[simp] lemma of_coe_smul_pretangle {α : Λ} (π : struct_perm α) (t : pretangle α) :
  (π • t).of_coe = of_coe π • t.of_coe :=
begin
dsimp [struct_perm.has_smul_pretangle],
unfold proto_smul,
simp only [pretangle.of_coe_to_coe],
refl,
  end

@[simp] lemma to_coe_smul_pretangle {α : Λ} (π : Π β : type_index, β < α → struct_perm β)
  (t : Π β : type_index, β < α → set (pretangle β)) :
  pretangle.to_coe (π • t) = to_coe π • pretangle.to_coe t :=
pretangle.of_coe.injective $
  by simp_rw [of_coe_smul_pretangle, of_coe_to_coe, pretangle.of_coe_to_coe]

protected lemma one_smul : ∀ α (t : pretangle α), (1 : struct_perm α) • t = t
| ⊥ := λ t, pretangle.of_bot.injective $ by simp
| (α : Λ) := λ t, pretangle.of_coe.injective $
    by { ext β hβ : 2, simp [←image_smul, one_smul β, image_id'] }
using_well_founded { dec_tac := `[assumption] }

protected lemma mul_smul :
  ∀ α (π₁ π₂ : struct_perm α) (t : pretangle α), (π₁ * π₂) • t = π₁ • π₂ • t
| ⊥ := λ π₁ π₂ t, pretangle.of_bot.injective $ by simp [mul_action.mul_smul]
| (α : Λ) := λ π₁ π₂ t, pretangle.of_coe.injective $
    by { ext β hβ : 2, simp only [of_coe_smul_pretangle, of_coe_mul, pi.smul_apply', pi.mul_apply,
      pi_Prop.smul_apply', ←image_smul, image_image, ←mul_smul β], refl }
using_well_founded { dec_tac := `[assumption] }

instance mul_action_pretangle : mul_action (struct_perm α) (pretangle α) :=
{ smul := (•),
  one_smul := struct_perm.one_smul _,
  mul_smul := struct_perm.mul_smul _ }

lemma derivative_cons_nil (α : Λ) (f : struct_perm α) (β : type_index) (hβ : β < α) :
  derivative (cons nil hβ) f = of_coe f β hβ :=
by { unfold derivative lower, rw dif_neg hβ.ne, refl }

lemma ext (α : Λ) (a b : struct_perm α)
  (h : ∀ (β : type_index) (hβ : β < α), derivative (cons nil hβ) a = derivative (cons nil hβ) b) :
  a = b :=
of_coe.injective $ by { ext β hβ, simp_rw ←derivative_cons_nil, exact h _ _ }

instance : has_faithful_smul (struct_perm ⊥) atom :=
⟨λ f g h, of_bot.injective $ near_litter_perm.ext $ eq_of_smul_eq_smul h⟩

end struct_perm
end con_nf


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

! This file was ported from Lean 3 source module data.prod.pprod
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Basic

/-!
# Extra facts about `pprod`

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

open Function

variable {α β γ δ : Sort _}

namespace PProd

/- warning: pprod.mk.eta -> PProd.mk.eta is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {p : PProd.{u1, u2} α β}, Eq.{max 1 u1 u2} (PProd.{u1, u2} α β) (PProd.mk.{u1, u2} α β (PProd.fst.{u1, u2} α β p) (PProd.snd.{u1, u2} α β p)) p
but is expected to have type
  forall {α : Sort.{u2}} {β : Sort.{u1}} {p : PProd.{u2, u1} α β}, Eq.{max (max 1 u2) u1} (PProd.{u2, u1} α β) (PProd.mk.{u2, u1} α β (PProd.fst.{u2, u1} α β p) (PProd.snd.{u2, u1} α β p)) p
Case conversion may be inaccurate. Consider using '#align pprod.mk.eta PProd.mk.etaₓ'. -/
@[simp]
theorem mk.eta {p : PProd α β} : PProd.mk p.1 p.2 = p :=
  PProd.casesOn p fun a b => rfl
#align pprod.mk.eta PProd.mk.eta

/- warning: pprod.forall -> PProd.forall is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {p : (PProd.{u1, u2} α β) -> Prop}, Iff (forall (x : PProd.{u1, u2} α β), p x) (forall (a : α) (b : β), p (PProd.mk.{u1, u2} α β a b))
but is expected to have type
  forall {α : Sort.{u2}} {β : Sort.{u1}} {p : (PProd.{u2, u1} α β) -> Prop}, Iff (forall (x : PProd.{u2, u1} α β), p x) (forall (a : α) (b : β), p (PProd.mk.{u2, u1} α β a b))
Case conversion may be inaccurate. Consider using '#align pprod.forall PProd.forallₓ'. -/
@[simp]
theorem forall {p : PProd α β → Prop} : (∀ x, p x) ↔ ∀ a b, p ⟨a, b⟩ :=
  ⟨fun h a b => h ⟨a, b⟩, fun h ⟨a, b⟩ => h a b⟩
#align pprod.forall PProd.forall

/- warning: pprod.exists -> PProd.exists is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {p : (PProd.{u1, u2} α β) -> Prop}, Iff (Exists.{max 1 u1 u2} (PProd.{u1, u2} α β) (fun (x : PProd.{u1, u2} α β) => p x)) (Exists.{u1} α (fun (a : α) => Exists.{u2} β (fun (b : β) => p (PProd.mk.{u1, u2} α β a b))))
but is expected to have type
  forall {α : Sort.{u2}} {β : Sort.{u1}} {p : (PProd.{u2, u1} α β) -> Prop}, Iff (Exists.{max (max 1 u2) u1} (PProd.{u2, u1} α β) (fun (x : PProd.{u2, u1} α β) => p x)) (Exists.{u2} α (fun (a : α) => Exists.{u1} β (fun (b : β) => p (PProd.mk.{u2, u1} α β a b))))
Case conversion may be inaccurate. Consider using '#align pprod.exists PProd.existsₓ'. -/
@[simp]
theorem exists {p : PProd α β → Prop} : (∃ x, p x) ↔ ∃ a b, p ⟨a, b⟩ :=
  ⟨fun ⟨⟨a, b⟩, h⟩ => ⟨a, b, h⟩, fun ⟨a, b, h⟩ => ⟨⟨a, b⟩, h⟩⟩
#align pprod.exists PProd.exists

/- warning: pprod.forall' -> PProd.forall' is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {p : α -> β -> Prop}, Iff (forall (x : PProd.{u1, u2} α β), p (PProd.fst.{u1, u2} α β x) (PProd.snd.{u1, u2} α β x)) (forall (a : α) (b : β), p a b)
but is expected to have type
  forall {α : Sort.{u2}} {β : Sort.{u1}} {p : α -> β -> Prop}, Iff (forall (x : PProd.{u2, u1} α β), p (PProd.fst.{u2, u1} α β x) (PProd.snd.{u2, u1} α β x)) (forall (a : α) (b : β), p a b)
Case conversion may be inaccurate. Consider using '#align pprod.forall' PProd.forall'ₓ'. -/
theorem forall' {p : α → β → Prop} : (∀ x : PProd α β, p x.1 x.2) ↔ ∀ a b, p a b :=
  PProd.forall
#align pprod.forall' PProd.forall'

/- warning: pprod.exists' -> PProd.exists' is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {p : α -> β -> Prop}, Iff (Exists.{max 1 u1 u2} (PProd.{u1, u2} α β) (fun (x : PProd.{u1, u2} α β) => p (PProd.fst.{u1, u2} α β x) (PProd.snd.{u1, u2} α β x))) (Exists.{u1} α (fun (a : α) => Exists.{u2} β (fun (b : β) => p a b)))
but is expected to have type
  forall {α : Sort.{u2}} {β : Sort.{u1}} {p : α -> β -> Prop}, Iff (Exists.{max (max 1 u2) u1} (PProd.{u2, u1} α β) (fun (x : PProd.{u2, u1} α β) => p (PProd.fst.{u2, u1} α β x) (PProd.snd.{u2, u1} α β x))) (Exists.{u2} α (fun (a : α) => Exists.{u1} β (fun (b : β) => p a b)))
Case conversion may be inaccurate. Consider using '#align pprod.exists' PProd.exists'ₓ'. -/
theorem exists' {p : α → β → Prop} : (∃ x : PProd α β, p x.1 x.2) ↔ ∃ a b, p a b :=
  PProd.exists
#align pprod.exists' PProd.exists'

end PProd

/- warning: function.injective.pprod_map -> Function.Injective.pprod_map is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {γ : Sort.{u3}} {δ : Sort.{u4}} {f : α -> β} {g : γ -> δ}, (Function.Injective.{u1, u2} α β f) -> (Function.Injective.{u3, u4} γ δ g) -> (Function.Injective.{max 1 u1 u3, max 1 u2 u4} (PProd.{u1, u3} α γ) (PProd.{u2, u4} β δ) (fun (x : PProd.{u1, u3} α γ) => PProd.mk.{u2, u4} β δ (f (PProd.fst.{u1, u3} α γ x)) (g (PProd.snd.{u1, u3} α γ x))))
but is expected to have type
  forall {α : Sort.{u4}} {β : Sort.{u3}} {γ : Sort.{u2}} {δ : Sort.{u1}} {f : α -> β} {g : γ -> δ}, (Function.Injective.{u4, u3} α β f) -> (Function.Injective.{u2, u1} γ δ g) -> (Function.Injective.{max (max 1 u4) u2, max (max 1 u3) u1} (PProd.{u4, u2} α γ) (PProd.{u3, u1} β δ) (fun (x : PProd.{u4, u2} α γ) => PProd.mk.{u3, u1} β δ (f (PProd.fst.{u4, u2} α γ x)) (g (PProd.snd.{u4, u2} α γ x))))
Case conversion may be inaccurate. Consider using '#align function.injective.pprod_map Function.Injective.pprod_mapₓ'. -/
theorem Function.Injective.pprod_map {f : α → β} {g : γ → δ} (hf : Injective f) (hg : Injective g) :
    Injective (fun x => ⟨f x.1, g x.2⟩ : PProd α γ → PProd β δ) := fun ⟨x₁, x₂⟩ ⟨y₁, y₂⟩ h =>
  have A := congr_arg PProd.fst h
  have B := congr_arg PProd.snd h
  congr_arg₂ PProd.mk (hf A) (hg B)
#align function.injective.pprod_map Function.Injective.pprod_map


import coalgebra.Coalgebra
import examples.kripke_structure.Kripke_Structure
import set_category.category_set
import category_theory.types
import help_functions

namespace Kripe_Coalgebra

open Kripke_Structure set help_functions coalgebra

universes u v

variable {φ : Type v}

def F : Type u ⥤ Type (max v u) :=
    {
        obj := λ S, (set S) × (set φ),
        map := λ {A B} ϕ, λ ⟨U , P⟩ , ⟨image ϕ U, P⟩,
        map_id' :=
            begin
                intros X,
                dsimp at *,
                ext1,
                cases x with U P,
                dsimp at *,
                ext1,
                have im : image id U = U :=  by simp,
                exact im,
                refl
            end ,
        map_comp' :=
            begin
                intros X Y Z f g,
                dsimp at *,
                ext1,
                cases x with S P,
                dsimp at *,
                calc
                F._match_1 (g ∘ f) (S, P)
                    = ⟨image (g ∘ f) S, P⟩              : rfl
                ... = ⟨image g (image f S), P⟩          : by rw [img_comp f g S]
                ... = F._match_1 g (F._match_1 f (S, P)) : rfl
            end
    }

def α (K : Kripke φ): K.State → F.obj K.State :=
        λ s, ⟨K.T s,  K.v s⟩

def Kripke_Coalgebra (K : Kripke φ): Coalgebra F :=
    ⟨K.State , α K⟩

lemma Kripke_Coalgebra_hom {K₁ K₂ : Kripke φ} (ϕ : K₁ → K₂):
    is_homomorphism φ ϕ ↔
    @is_coalgebra_homomorphism F
        (Kripke_Coalgebra K₁) (Kripke_Coalgebra K₂)
            ϕ :=
    let 𝕂₁  := Kripke_Coalgebra K₁ in
    let 𝕂₂ := Kripke_Coalgebra K₂ in
    iff.intro
    (
    assume ⟨tr, b_a, pr⟩,
    show 𝕂₂.α ∘ ϕ = F.map ϕ ∘ 𝕂₁.α,
    begin
        ext1,
        have im_elem : ∀ s : K₂.State ,
                s ∈ image ϕ (K₁.T x) ↔ s ∈ K₂.T (ϕ x) :=
            begin
                intro s,
                split,
                intros im_ϕ,
                cases im_ϕ with s12 specS12,
                rw ← specS12.2,
                exact tr x s12 specS12.1,
                intro s_T2,
                exact b_a x s s_T2,
            end,

        have im : image ϕ (K₁.T x) = K₂.T (ϕ x) :=
            eq_sets.1 im_elem,

        have F_ϕ : F.map ϕ (𝕂₁.α x) = ⟨image ϕ (K₁.T x), K₁.v x⟩
                := rfl,
        simp [F_ϕ],
        have last : (⟨K₂.T (ϕ x) , K₂.v (ϕ x)⟩ :
            (set K₂.State) × set φ) = ⟨image ϕ (K₁.T x), K₁.v x⟩ :=
                by simp [eq.symm im, eq.symm (pr x)],
        simp [eq.symm last],
        refl
    end )
    (
    assume co_hom : 𝕂₂.α ∘ ϕ = F.map ϕ ∘ 𝕂₁.α,
    show (∀ a₁ a₂ :K₁ , a₂ ∈ K₁.T a₁ → (ϕ a₂) ∈ K₂.T (ϕ a₁)) ∧
         (∀ (a : K₁) (b : K₂) , b ∈ K₂.T (ϕ a) →
                ∃ a': K₁ ,  a' ∈ K₁.T a ∧ ϕ a' = b) ∧
         (∀ a : K₁ , K₁.v a = K₂.v (ϕ a)),
    begin
        split,
        intros a₁ a₂ a₂_a₁,

        have h3 : (𝕂₂.α ∘ ϕ) a₁ = ((F.map ϕ) ∘ 𝕂₁.α) a₁
                     := by rw co_hom,
        have h5 : (⟨K₂.T (ϕ a₁) , K₂.v (ϕ a₁)⟩ :
            (set K₂.State) × set φ) = ⟨image ϕ (K₁.T a₁), K₁.v a₁⟩
                := h3,
        have h6 : K₂.T (ϕ a₁) = image ϕ (K₁.T a₁) := by tidy,
        have h7 : ϕ a₂ ∈ image ϕ (K₁.T a₁) :=
            by {use a₂, simp [a₂_a₁]},
        rw h6,
        exact h7,

        split,
        intros a₁ b b_T_ϕ_a,
        have h3 : (𝕂₂.α ∘ ϕ) a₁ = ((F.map ϕ) ∘ 𝕂₁.α) a₁
                     := by rw co_hom,
        have h4 : 𝕂₂.α (ϕ a₁) = F.map ϕ (𝕂₁.α a₁)
                     := h3,
        have h5 : (⟨K₂.T (ϕ a₁) , K₂.v (ϕ a₁)⟩ :
            (set K₂.State) × set φ) = ⟨image ϕ (K₁.T a₁), K₁.v a₁⟩
                := h4,
        have h6 : K₂.T (ϕ a₁) = image ϕ (K₁.T a₁) := by tidy,
        have h7 : b ∈ image ϕ (K₁.T a₁) := h6 ▸ b_T_ϕ_a,
        exact h7,
        intro a₁,
        have h3 : (𝕂₂.α ∘ ϕ) a₁ = ((F.map ϕ) ∘ 𝕂₁.α) a₁
                     := by rw co_hom,
        have h5 : (⟨K₂.T (ϕ a₁) , K₂.v (ϕ a₁)⟩ :
            (set K₂.State) × set φ) = ⟨image ϕ (K₁.T a₁), K₁.v a₁⟩
                := h3,
        have h6 : K₂.v (ϕ a₁) = K₁.v a₁ := by tidy,
        exact eq.symm h6
    end)

end Kripe_Coalgebra


/-
Authors: Jáchym Šimon, Tomáš Lávička
Czech technical university, Prague
Created: 2019
written in Lean 3.23.0 using mathlib library
-/
import data.list.basic
import data.bool
import data.nat.basic
import init.meta.tactic
open set
open bool
open list
open nat

-- TACTIC UNITS

  variables {α β γ  : Type}

  meta def tac : tactic unit :=
         `[ { repeat {{left, exact rfl}  <|> right <|> exact rfl}} <|>
            solve1 { repeat {{left, assumption}  <|> right <|> assumption}}]

 meta def mt_ax : tactic unit :=
  `[ solve1 {repeat{ {left, refine (exintro2 _ _ rfl)}   <|>
            {left, refine (exintro3 _ _ _ rfl)}  <|>
            right}} ]

 meta def mt_assump0 : tactic unit :=
  `[ repeat{{left, exact rfl} <|> right} <|> assumption ]

 meta def mt_assump : tactic unit :=
  `[ iterate 6 {right}, left, {simp, try{exact rfl}} <|>
     assumption ]

 meta def mt_mp : tactic unit :=
  `[ {repeat{right}, existsi _,
    split, swap, mt_assump0} ]

 -- TAUT, RULES
 meta def mt_rules :tactic unit :=
    --rules with more than 1 assumption
  `[
    apply (@provable1 _ _) <|>
    apply (@provable5 _ _) <|>
    apply (@double_neg_law _) <|>
    apply (@transitivity _ _ _) <|>
    apply (@RAA _ _) <|>
    apply (@contraposition _ _) <|>
    assumption
    ]

 meta def mt_uncut : tactic unit :=
  `[ right, left, existsi _,
  split, swap ]

 meta def mt_bicut : tactic unit :=
  `[ left, existsi _, existsi _,
  split, tactic.swap, split, tactic.swap ]

 meta def mt_cut_or_taut : tactic unit :=
    --binary cut
  `[ solve1{left, existsi [_, _],
  split, swap, split, swap, mt_rules, try{mt_assump0}, done } <|>
    -- unary cut
  solve1 {right, left, existsi _,
  split, tactic.swap, mt_rules, try{mt_assump0}, done} <|>
    -- tautologies
  solve1 {right, right, left, mt_rules, try{assumption}, done} <|>

  assumption ]

 meta def mt_verifier : tactic unit :=
  `[try{apply provable_no_cutR}, try{existsi prf},
   repeat{split, solve1 {mt_assump} <|>
                 solve1 {mt_ax}     <|>
                 solve1 {mt_mp}     <|>
                 solve1 {mt_cut_or_taut} <|>
                 swap},
    try{exact rfl}]

-- EXISTS INTRO ELIM RULES

  lemma exintro2{P: α → β → Prop}(A: α)(B:β):
    P A B →  ∃ A:α, ∃ B: β, P A B :=
  begin intro a, repeat{apply exists.intro}, exact a end

  lemma exintro3{P: α → β →γ →  Prop}(A: α)(B:β)(C:γ):
    P A B C →  ∃ A:α, ∃ B: β,∃ C:γ, P A B C :=
  begin intro a, repeat{apply exists.intro}, exact a end

  lemma exelim2{P: α → β → Prop}{Q:Prop}:
    (∃ A:α, ∃ B:β, P A B) → (∀ A:α, ∀ B:β, P A B → Q) → Q :=
  begin intros a a_1, apply exists.elim a, intros _ a_3,
  apply exists.elim a_3, intros a_4 a_5,
  exact a_1 a_2 a_4 a_5 end

  lemma exelim3{P: α → β → γ → Prop}{Q:Prop}:
    (∃ A:α, ∃ B:β, ∃ C:γ, P A B C) → (∀ A:α, ∀ B:β, ∀ C:γ, P A B C → Q) → Q :=
  λ hex hall, exists.elim hex
  (λ A hex1, exists.elim hex1
  (λ B hex3, exists.elim hex3
  (λ C hP, hall A B C hP)))

-- FORM (inducive)

  -- definition of formulae
  inductive Form : Type
  | p : ℕ → Form
  | imp : Form → Form → Form
  | neg : Form → Form

  local infixr ⇒ : 80 := Form.imp
  local prefix `~` : 100 := Form.neg
  open Form

-- GLOBAL_VARIABLES

  -- definition of evaluation
  def eval := ℕ → bool
  -- variables
  variables {v v₁ v₂:eval}
  variables {A B C D:Form}
  variables {Γ Δ:set Form}
  variables {m n:ℕ}
  variables {a b:bool}
  variables {l li:list Form}

-- HK AXIOMS
  -- axioms of hilbert calculus
  def A1 (A B:Form) := A ⇒ (B ⇒ A)
  def A2 (A B C:Form) := (A ⇒ (B ⇒ C)) ⇒ ((A ⇒ B) ⇒ (A ⇒ C))
  def A3 (A B:Form) := (~B ⇒ ~A) ⇒ ((~B ⇒ A) ⇒ B)

-- PROOF
  -- formula in proof is either axiom, assumption or comes from modus ponens
  def in_proof (A:Form)(Γ:set Form)(l:list Form) : Prop :=
    (∃ B C, A = A1 B C)  ∨
    (∃ B C D, A = A2 B C D)  ∨
    (∃ B C, A = A3 B C)  ∨
    (A ∈ Γ)  ∨
    (∃ B, B ∈ l ∧ (B ⇒ A) ∈ l)

  -- list l is a proof from set of assumptions Γ
  def is_proof (Γ:set Form)(l:list Form) : Prop :=
    list.rec_on l tt (λ A li IH, in_proof A Γ li ∧ IH)

  -- formula A is provable from set of assumptions Γ
  def is_provable (Γ:set Form)(A:Form) : Prop :=
    ∃ l: list Form, is_proof Γ (A::l)

  infixr ` ⊢ ` : 40 := is_provable
  prefix ` ⊢ ` : 40 := is_provable {}

  -- list l is a proof with either binary/unary cut or tautology (or none) used
  def is_proof_with_cut (Γ:set Form)(l:list Form) : Prop :=
    list.rec_on l tt
    (λ A li IH, ((∃ B C, B ∈ li ∧ C ∈ li ∧ {B,C} ⊢ A) ∨
                  (∃ B, B ∈ li ∧ {B} ⊢ A) ∨
                  ({} ⊢ A) ∨
                   in_proof A Γ li)
                   ∧ IH )
  -- formula A is provable from Γ using mentioned cut rules
  def is_provable_with_cut (Γ:set Form)(A:Form) : Prop :=
    ∃ l: list Form, is_proof_with_cut Γ (A::l)

  infixr ` ⊢cut ` : 40 := is_provable_with_cut
  prefix ` ⊢cut ` : 40 := is_provable {}

-- PROOF lemmas
  -- useful lemmas about proof definitions

  lemma is_proof_ind : is_proof Γ (A::l) → is_proof Γ l := and.right
  lemma in_proof_extend : in_proof A Γ l → l <+ li → in_proof A Γ li :=
    begin
     intros a a_1, repeat {cases a, tac},
     cases a with hl hr, repeat {right},
     have hp: l ⊆ li, exact list.sublist.subset a_1,
     existsi hl, split, exact hp hr.1, exact hp hr.2
    end

  lemma is_proof_concat : is_proof Γ l → is_proof Γ li → is_proof Γ (l++li) :=
    list.rec_on l
      (λ h hp, hp)
      (assume A lis IH Hl Hli,
        ⟨ in_proof_extend Hl.1 (list.sublist_append_left lis li),
        IH (is_proof_ind Hl) Hli ⟩)

  lemma is_proof_extend : is_proof Γ l → A ∈ l → in_proof A Γ l :=
    list.rec_on l
    (λ h hp, absurd rfl (list.ne_nil_of_mem hp))
    (λ D lis IH h hp,
    have lem: A ∈ D::lis → A=D ∨ A∈ lis, from
      λ h, or.elim (list.eq_or_ne_mem_of_mem h) (λ hp, or.inl hp) (λ hp, or.inr hp.2),
    have sub: lis<+D::lis, from by simp,
    or.elim (lem hp)
      (assume H, H.symm ▸ in_proof_extend h.1 sub)
      (λ H, in_proof_extend  (IH (is_proof_ind h) H) sub))

-- SEMANTICS

  -- definition of evaluation
  def val (v:eval) : Form → bool :=
    λ A:Form, Form.rec_on A (λ n:ℕ, v n)
                            (λ A B:Form, λ a b:bool, !a || b)
                            (λ A:Form, λ a:bool, !a)

  notation v `∗` := val v

  -- A is tautology
  def is_taut (A:Form) : Prop := ∀ v:eval, v∗ A = tt

  notation `⊧` := is_taut

-- SOUNDNESS
  -- axioms are tautologies
  lemma A1_taut : ⊧ (A1 A B) :=
    λ v, have A1_bool: ∀ a b: bool, !a || (!b || a) = tt,
    from by simp, A1_bool (v∗A) (v∗B)

  lemma A2_taut : ⊧ (A2 A B C) :=
    λ v,
    have A2_bool: ∀ a b c: bool,
    !(!a || (!b || c)) || (!(!a || b) || (!a || c)) = tt,
    from by simp, A2_bool (v∗ A) (v∗ B) (v∗ C)

  lemma A3_taut : ⊧ (A3 A B):=
    λ v,
    have A3_bool: ∀ a b:bool, !((!!b) || (!a)) || ((!(!!b || a)) || b) = tt,
    from by simp, A3_bool (v∗ A) (v∗ B)

  lemma MP_taut (h1:⊧ A)(h2:⊧ (A ⇒ B)) : ⊧ B :=
    λ v, have MP_bool: (∀ (a b:bool), (a = tt ∧ !a || b = tt) → b = tt), from
      ( λ a b p1,
      have p2: ff || b = tt, from @eq.subst bool (λ x, bnot x || b = tt) a tt p1.1 p1.2,
      or.elim (bool.dichotomy b)
      (λ i, false.elim
        (bool.ff_ne_tt (calc ff = ff || ff : rfl
                             ...= tt : @eq.subst bool (λ x, ff || x = tt) b ff i p2)))
      (λ i, i) ),
    MP_bool (v∗A) (v∗(B)) ⟨h1 v, calc bnot (v∗A) || (v∗B) = (v∗(A ⇒ B)) : rfl
                                                     ... = tt : (h2 v)⟩

  lemma soundness_lemma : ∀ A:Form, is_proof {} l ∧ A ∈ l → ⊧ A :=
    list.rec_on l
    (λ A i, forall_mem_nil ⊧ A i.2)
    (λ B k IH,
      (λ A, λ i_Bk: is_proof {} (B::k) ∧ A ∈ (B::k),
      or.elim i_Bk.2
      (begin intro j, cases i_Bk.1.1 with h,

            apply exelim2 h, intros a b q,
            rw [j, q], apply A1_taut, cases h,

            apply exelim3 h, intros a b c r,
            simp [j,r], apply A2_taut, cases h,

            apply exelim2 h, intros a b q,
            rw [j, q], apply A3_taut, cases h,

            apply false.elim h,

            apply exists.elim h, intros b c, rw j,
            have hb: ⊧ b, apply IH b ⟨is_proof_ind i_Bk.1, c.1⟩,
            have hbB: ⊧ (b ⇒ B), apply IH (b ⇒ B) ⟨is_proof_ind i_Bk.1, c.2⟩,
            apply MP_taut hb hbB
      end)
    (λ j, IH A ⟨is_proof_ind i_Bk.1, j⟩)))

  theorem CPL_soundness : ∀ A:Form, ⊢ A → ⊧ A :=
    begin
      intros a a_1,
      apply exists.elim a_1, intros a_2 a_3,
      exact soundness_lemma a ⟨a_3, by simp⟩
    end

-- PROVABLE lemmas
  -- monotony, cut rules, other rules
  -- provable with cut → provable without cut

  lemma modus_ponens_rule : {A, A ⇒ B} ⊢ B :=
    let prf:= [A, A ⇒ B] in
    by{existsi prf,
    split, mt_mp,
    split, iterate 3 {right}, left, simp,
    split, iterate 3 {right}, left, simp, exact rfl}

  theorem binary_cut {A B C:Form}:
  (Γ ⊢ A) → (Γ ⊢ B) → ({A, B} ⊢ C) → (Γ ⊢ C) :=
    begin
      intros hA hB hAB,
      apply exists.elim hA, intros prfA is_prfA,
      apply exists.elim hB, intros prfB is_prfB,
      apply exists.elim hAB, intro prfAB,
      let pr:= (A::prfA++B::prfB),
      let prA:= (A::prfA),
      let prB:= (B::prfB),

      have lem: ∀ l:list Form, is_proof {A,B} l → is_proof Γ (l++pr),
      intro l, apply list.rec_on l, intro a,
      exact (@is_proof_concat Γ (A::prfA) (B::prfB) is_prfA is_prfB),

      intros D li IH hp, split,
      cases hp.1,
      left, exact h,
      cases h, right, left, exact h,
      cases h, right, right, left, exact h,
      cases h, simp at h, cases h,
      rw[h],
      have ha: A ∈ li++pr, by simp,
      exact is_proof_extend (IH (is_proof_ind hp)) ha,
      rw[h],
      have ha: B ∈ li++pr, by simp,
      exact is_proof_extend (IH (is_proof_ind hp)) ha,

      repeat{right},
      apply exists.elim h,
      have s: li ⊆ (li ++ pr), by simp,
      intros Q hQ,
      existsi Q, split,
      exact s hQ.1,
      exact s hQ.2,
      exact IH (is_proof_ind hp),
      intro a,
      existsi (prfAB++pr),
      exact lem (C::prfAB) a
    end

  lemma unary_cut {A B:Form}: (Γ ⊢ A) → ({A} ⊢ B) → (Γ ⊢ B) :=
    begin
    have h: {A, A} = {A}, exact pair_eq_singleton A, rw[symm h],
    intros a a_1, exact binary_cut a a a_1
    end

  lemma monotony_help : Γ ⊆ Δ → is_proof Γ l → is_proof Δ l :=
    begin
    intro a,
    apply list.rec_on l, intro, exact rfl,
    intros _ _ _ a_2, split, swap,
    exact ih (is_proof_ind a_2),
    cases a_2, repeat {cases a_2_left, solve1{repeat{{left, exact a_2_left} <|> right}}},
    cases a_2_left, have h: hd ∈ Δ, exact mem_of_subset_of_mem a a_2_left,
    all_goals {solve1{repeat{{left, assumption} <|> right <|> assumption}}}
    end

  lemma monotony : Γ ⊆ Δ → Γ ⊢ A →  Δ ⊢ A :=
    begin
    intros a a_1,
    apply exists.elim a_1, intros a_2 a_3,
    existsi a_2, exact monotony_help a a_3
    end

  lemma provable_no_cutR : Γ ⊢cut A → Γ ⊢ A :=
    begin
      have lem : ∀ l A, (is_proof_with_cut Γ l) → (A ∈ l) → (Γ ⊢ A),
      intro l, induction l with B lis IH,
      intros A a a_1, exact absurd rfl (list.ne_nil_of_mem a_1),
      intros E hp ha, cases ha, rw[ha], cases hp.1,
      apply exelim2 h, intros C D a,
      have HC: Γ ⊢ C, from IH C hp.2 a.1 ,
      have HD: Γ ⊢ D, from IH D hp.2 a.2.1,
        exact binary_cut HC HD a.2.2,
      cases h, apply exists.elim h, intros C hC,
      have HC: Γ ⊢ C, from IH C hp.2 hC.1 ,
        exact unary_cut HC hC.2,
      cases h,
      have hyp: ∅ ⊆ Γ, from λ A hp, false.elim hp,
        exact monotony hyp h,
      cases h, apply exelim2 h, intros C D h_1,
      rw[h_1], let prf:=[], focus{mt_verifier},
      cases h, apply exelim3 h, intros C D E h_1,
      rw[h_1], let prf:=[], focus{mt_verifier},
      cases h, apply exelim2 h, intros C D h_1,
      rw[h_1], let prf:=[], focus{mt_verifier},
      cases h, let prf:=[], existsi prf, split,
      swap, exact rfl, iterate 3 {right}, left, assumption,
      apply exists.elim h, intros G hG,
      have Ha: Γ ⊢ G, exact  IH G hp.2 (hG.1),
      have Hb: Γ ⊢ G ⇒ B, exact  IH (G ⇒ B) hp.2 (hG.2),
      exact binary_cut Ha Hb modus_ponens_rule,
      exact IH E hp.2 ha,
      intros a, cases a with l hpp, have h: A∈ A::l, from by simp,
      exact lem (A::l) A hpp h
    end
  .
  lemma provable1 : Γ ⊢ A ⇒ A :=
    let prf:= [ (A ⇒ (A ⇒ A)) ⇒ (A ⇒ A),
               A2 A (A ⇒ A) A,
               A1 A A,
               A1 A (A ⇒ A) ] in
    by mt_verifier

  lemma exchange : {A ⇒ B, A ⇒ B ⇒ C} ⊢ A ⇒ C:=
    let prf:= [(A ⇒ B) ⇒ A ⇒ C, A ⇒ B, A ⇒ B ⇒ C, A2 A B C] in
    by mt_verifier

  theorem deduction_theorem : (Γ ∪ {A} ⊢ B) → (Γ ⊢ A ⇒ B) :=
   have lem: ∀ l: list Form, is_proof (Γ ∪ {A}) l →
                             ∀ B, B ∈ l →
                             (Γ ⊢ A ⇒ B), from
   begin
    intro l, induction l with C li IH,
    intros _ a a_1, exact absurd rfl (list.ne_nil_of_mem a_1),
    intros h B hp, cases hp,
    rw[hp],
    cases h.1,
    apply exelim2 h_1, intros _ _ ax, rw[ax],
    focus{existsi ([_, A1 _ A]), mt_verifier}, cases h_1,
    apply exelim3 h_1, intros _ _ _ ax, rw[ax],
    focus{existsi ([_, A1 _ A]), mt_verifier}, cases h_1,
    apply exelim2 h_1, intros _ _ ax, rw[ax],
    focus{existsi ([_, A1 _ A]), mt_verifier}, cases h_1,
    cases h_1, focus{let prf:= [C, A1 C A], mt_verifier},
    cases h_1, exact provable1,
    cases h_1 with B hB,
     have Hd: Γ ⊢ A ⇒ B, exact IH h.2 B hB.1,
     have Himp: Γ ⊢ A ⇒ B ⇒ C, exact IH h.2 (B ⇒ C) hB.2,
    exact (binary_cut Hd Himp exchange),
    exact IH h.2 B hp
   end,
   assume h, exists.elim h (λ list hyp,
   have is_in: B∈ B::list, from by simp,
   lem (B::list) hyp B is_in)

  theorem deduction_theoremR : (Γ ⊢ A ⇒ B) → (Γ ∪ {A} ⊢ B) :=
    begin
      intro h,
      have h3: Γ ⊆ Γ ∪ {A}, simp,
      have h21: Γ ∪ {A} ⊢ (A ⇒ B),
      exact monotony h3 h,
      apply exists.elim h21, intros l h2,
      let prf:=(A::(A ⇒ B)::l),
      existsi prf,
      split, mt_mp, split,
      iterate 3 {right}, left, simp,
      exact h2
    end

  lemma double_neg_law: ⊢ ~~A ⇒ A :=
   begin
    apply deduction_theorem, simp,
    let prf :=
    [
    (~A ⇒ ~A) ⇒  A,
    ~A ⇒ ~A,
    ~A ⇒ ~~A,
    A3 (~A) A,
    A1 (~~A) (~A),
    ~~A], mt_verifier
   end

  lemma provable2 : Γ ⊢ A ⇒ ~~A :=
    let prf := [
                (~~~A ⇒ A) ⇒ ~~A,
                A3 A (~~A),
                ~~~A ⇒ ~A,
                ~~~A ⇒ A,
                A1 A (~~~A),
                A] in
    begin
      apply monotony,
      have h: {} ⊆ Γ, focus{simp}, exact h,
      apply deduction_theorem, simp,
      mt_verifier
    end

  lemma transitivity : {A ⇒ B, B ⇒ C} ⊢ A ⇒ C :=
    let prf:= [
      (A ⇒ B) ⇒ (A ⇒ C),
      A ⇒ B,
      A2 A B C,
      A ⇒ (B ⇒ C),
      A1 (B ⇒ C) A,
      B ⇒ C
    ] in by mt_verifier

  lemma RAA: {A ⇒ B, A ⇒ ~B} ⊢ ~A:=
    have h1: {A ⇒ B} ⊢ ~~A ⇒ B, from
      by{let prf:= [~~A ⇒ A, A ⇒ B], mt_verifier},
    have h2: {A ⇒ ~B} ⊢ ~~A ⇒ ~B, from
      by{let prf:= [ ~~A ⇒ A, A ⇒ ~B ], mt_verifier},
    by{let prf:= [(~~A ⇒ B) ⇒ ~A, A3 B (~A), ~~A ⇒ ~B,~~A ⇒ B, A ⇒ B, A ⇒ ~B], mt_verifier}

  lemma contraposition : {A ⇒ B} ⊢ ~B ⇒ ~A :=
    by{apply deduction_theorem,
    let prf:= [A ⇒ ~B, ~B ⇒ (A ⇒ ~B), ~B, A ⇒ B], mt_verifier}

  lemma provable5 : {A ⇒ B, ~A ⇒ B} ⊢ B:=
    let prf:= [
                        (~B ⇒ ~A ) ⇒ B,
                        (~B ⇒ ~~A) ⇒ (~B ⇒ ~A) ⇒ B,
                        ~B ⇒ ~~A,
                        ~A ⇒ B,
                        ~B ⇒ ~A,
                        A ⇒ B
                    ] in
    by{mt_verifier}

  theorem PCP : (Γ ∪ {A} ⊢ B) → (Γ ∪ {~A} ⊢ B) → (Γ ⊢ B) :=
    assume h hneg,
    have hp: Γ ⊢ A ⇒ B, from deduction_theorem h,
    have hpp: Γ ⊢ ~A ⇒ B, from deduction_theorem hneg,
    binary_cut hp hpp (provable5)

  lemma modus_ponens : (Γ ⊢ A) → (Γ ⊢ (A ⇒ B)) → (Γ ⊢ B) :=
    begin
      intros a a_1,
      apply exists.elim a, intros la prfa,
      apply exists.elim a_1, intros lab prfab,
      have h: is_proof Γ (A::la ++ (A⇒B)::lab),
        from by {exact is_proof_concat prfa prfab},
      have h3: in_proof B Γ (A::la ++ (A⇒B)::lab),
        from by {repeat{right}, exact exists.intro A ⟨by simp, by simp⟩},
      exact exists.intro (A::la ++ (A⇒B)::lab) ⟨h3, h⟩
    end

  lemma provable6 : (Γ ⊢ A) → (Γ ⊢ B ⇒ A) :=
    λ hA, have p1: Γ∪{B} ⊢ A, from monotony (subset_union_left Γ {B}) hA,
    deduction_theorem p1

  lemma provable3 : (Γ ⊢ ~A) → (Γ ⊢ A ⇒ B):=
    λ h,
    have h0: Γ ⊆ Γ ∪ {A}, from by simp,
    have h1: Γ ∪ {A} ⊢ ~A, from monotony h0 h,
    have h2: Γ ∪ {A} ⊢ A, from let prf:= [A] in by mt_verifier,
    have h3: {~A, A} ⊢ B, from
    let prf:= [(~B ⇒ A) ⇒ B, A3 A B, ~B ⇒ A, A, A1 A (~B),
    (~B ⇒ ~A), ~A, A1 (~A) (~B)] in by mt_verifier,
    deduction_theorem (binary_cut h1 h2 h3)

  lemma sets_eqv: ({A,B}:set Form) = {A} ∪ {B}:=
    begin
      apply funext, intro x,
      apply propext,
      split,
      intro a, cases a,
      repeat{cases a, mt_assump0}, exact rfl,
      intro a, cases a, cases a, mt_assump0, cases a, mt_assump0,
      exact a
    end

  lemma provable4_hlp : {A, ~B} ⊢ ~(A ⇒ B) :=
    begin
      apply (@deduction_theoremR (~B) (~(A ⇒ B)) {A}),
      apply unary_cut, swap, exact contraposition,
      have h: {A} = {} ∪ {A}, exact (@empty_union Form {A}).symm, rw[h],
      apply (@deduction_theoremR A ((A ⇒ B) ⇒ B) {}),
      apply deduction_theorem, apply deduction_theorem,
      have h2: {A} ∪ {A ⇒ B} = {A, A ⇒ B}, exact sets_eqv.symm,
      rw[h.symm, h2],
      exact modus_ponens_rule
    end

  lemma provable4 : (Γ ⊢ A) → (Γ ⊢ ~B) → (Γ ⊢ ~(A ⇒ B)):=
    by{intros a b, exact binary_cut a b provable4_hlp}

-- COMPLETENESS preparation

 -- swap, lemmas
 -- lemmas for evaluating negation and implication
  @[simp] def swap (A:Form)(v:eval) : Form :=
    if v∗A = tt then A else ~A

  @[simp] def swap_var (n:ℕ)(v:eval): Form :=
    if v n = tt then p n else ~(p n)

  @[simp] theorem swap_tt : (v∗A = tt) → (swap A v = A) :=
    λ h, by simp [h]

  @[simp] theorem swap_ff : (v∗A = ff) → (swap A v = ~A) :=
    λ h, by simp [h]

  @[simp] lemma pswap_neg_tt: (v∗A = tt) → (v∗(~A) = ff) :=
    λ h, @eq.subst bool (λ x, (v∗(~A)) = bnot x) (v∗A) tt h rfl

  @[simp] lemma pswap_neg_ff: (v∗A = ff) → (v∗(~A) = tt) :=
    λ h, @eq.subst bool (λ x, (v∗(~A)) = bnot x) (v∗A) ff h rfl

  @[simp] theorem swap_neg_ff : (v∗A = ff) → swap (~A) v = ~A :=
    λ h, by simp [h]

  theorem swap_neg_tt : (v∗A = tt) → swap (~A) v = ~~A :=
    λ h, by simp[h]

  @[simp] lemma pswap_imp_tt_ff : (v∗A = tt) → (v∗B = ff) → (v∗(A ⇒ B) = ff) :=
    λ ha hb, have h2: (v∗(A ⇒ B)) = bnot (v∗A) || ff, from hb ▸ rfl,
    @eq.subst bool (λ x, (v∗(A ⇒ B)) = bnot x || ff) (v∗A) tt ha h2

  @[simp] lemma pswap_imp_tt_tt : (v∗A = tt) → (v∗B = tt) → (v∗(A ⇒ B) = tt) :=
    λ ha hb, have h2: (v∗(A ⇒ B)) = bnot (v∗A) || tt, from hb ▸ rfl,
    @eq.subst bool (λ x, (v∗(A ⇒ B)) = bnot x || tt) (v∗A) tt ha h2

  theorem swap_imp_tt_ff :
      (v∗A = tt) → (v∗B = ff) → (swap (A ⇒ B) v = ~(A ⇒ B)) :=
    λ h h1, by simp[h, h1]

  theorem swap_imp_tt_tt:
      (v∗A = tt) → (v∗B = tt) → (swap (A ⇒ B) v = A ⇒ B) :=
    λ h p, by simp[h, p]

  theorem swap_imp_ff : (v∗A = ff) → (v∗(A ⇒ B)) = tt :=
    λ h, calc v∗(A ⇒ B) = bnot ff || (v∗B) : h ▸ rfl

  lemma swap_var_tt : v n = tt → (swap_var n v = p n) :=
    λ h, by simp [h]

  lemma swap_var_ff : v n = ff → (swap_var n v = ~p n) :=
    λ h, by simp [h]

 -- svar_set set
  def svar_set (n:ℕ)(v:eval) : set Form :=
    { A | ∃ i:ℕ, i < n ∧ A = (swap_var i v)}

  def form_index (A:Form) : ℕ :=
    Form.rec_on A (λ n:ℕ, n+1)
                  (λ A B:Form, λ na nb:ℕ, max na nb)
                  (λ A:Form, λ m:ℕ, m)

  lemma swap_in_flae : (swap (p n) v) ∈  svar_set (form_index (p n)) v :=
    have h: form_index (p n) = n+1, from rfl,
    exists.intro n ⟨lt_succ_self n, rfl⟩

  lemma flae_inclusion : (∀ n ≤ m,  svar_set n v ⊆  svar_set m v) :=
    λ n h A h', exists.elim h'
    (λ i h1, exists.intro i (show i < m ∧ A = swap_var i v, from
    ⟨nat.le_trans h1.1 h, h1.2⟩))

  lemma flae_empty :  svar_set 0 v = {} :=
    funext (λ A:Form, show  svar_set 0 v A = false, from
    propext ⟨ (λ h: svar_set 0 v A, exists.elim h (λ i h1,
    (nat.succ_ne_zero i (nat.eq_zero_of_le_zero h1.1 )))),
    false.elim ⟩)

  lemma var_index_max_left : form_index A ≤ form_index (A ⇒ B) :=
    le_max_left (form_index A) (form_index B)

  lemma var_index_max_right : form_index B ≤ form_index (A ⇒ B) :=
    le_max_right (form_index A) (form_index B)

 -- truth eval
  @[simp] def g₁ (n:ℕ)(v:eval) : ℕ → bool :=
   λ m, if m<n then v m else tt

  @[simp] def g₂ (n:ℕ)(v:eval) : ℕ → bool :=
   λ m, if m<n then v m else ff

  lemma g₁_eq_tt (h: m = n) : (g₁ n v) m = tt :=
    have ¬( m < n), from λ h', ne_of_lt h' h,
    by simp [this]

  lemma g₂_eq_ff (h: m = n) : (g₂ n v) m = ff :=
    have ¬  m < n, from λ h', ne_of_lt h' h,
    by simp [this]

  lemma g₁_v_eq_ite (v g:eval)(n:ℕ) : v n = g n →
    ite (v n = tt) (p n) (~ p n) = ite (g n = tt) (p n) (~ p n) :=
   λ h, (@eq.subst bool (λ x, ite (v n = tt) (p n) (~ p n) = ite (x = tt) (p n) (~ p n))
   (v n) (g n) h) rfl

  lemma g₁_v_eq: ∀ m < n, v m = (g₁ n v) m :=
   λ m n, by simp [n]

  lemma g₂_v_eq: ∀ m < n, v m = (g₂ n v) m :=
   λ m n, by simp [n]

  lemma g₁_v_swap_var_eq (v:eval) : m < n → swap_var m v = swap_var m (g₁ n v) :=
   λ h , have h1: v m = (g₁ n v) m, from g₁_v_eq m h,
   g₁_v_eq_ite v (g₁ n v) m h1

  lemma g₂_v_swap_var_eq (v:eval) : m<n → swap_var m v = swap_var m (g₂ n v) :=
   λ h , have h1: v m = (g₂ n v) m, from g₂_v_eq m h,
   g₁_v_eq_ite v (g₂ n v) m h1

  meta def flae_ind_tac : tactic unit :=
  `[
      apply funext, intro A,
      apply propext, split,

      intro h, cases h,
      cases h, existsi h_w,
      split, exact nat.lt_trans h_h.1 (lt_add_one n),
      rw[h_h.2],
      {exact g₁_v_swap_var_eq v h_h.1} <|> {exact g₂_v_swap_var_eq v h_h.1},

      cases h,
      existsi n, split,
      exact lt_add_one n,
      have hp1: g₁ n v n = tt, from @g₁_eq_tt v n n rfl,
      have hp2: g₂ n v n = ff, from @g₂_eq_ff v n n rfl,
      {rw[(@swap_var_tt (g₁ n v) n hp1).symm]} <|>
      {rw[(@swap_var_ff (g₂ n v) n hp2).symm]},

      intro h, cases h,
      apply (@nat.lt_by_cases h_w n _),
      intro h2, left, existsi _,
      split, exact h2,
      {rw[(g₁_v_swap_var_eq v h2)], exact h_h.2} <|>
      {rw[(g₂_v_swap_var_eq v h2)], exact h_h.2},

      intro h2, right,
      {rw[(swap_var_tt (@g₁_eq_tt v h_w n h2)), h2] at h_h, exact h_h.2} <|>
      {rw[(swap_var_ff (@g₂_eq_ff v h_w n h2)), h2] at h_h, exact h_h.2},

      intro h2, have h5: h_w ≤ n, from iff.elim_left lt_succ_iff h_h.1,
      have h6: h_w ≤ n ∧ ¬h_w ≤ n, from ⟨h5, (iff.elim_left (lt_iff_not_ge n h_w)) h2⟩,
      exact false.elim (iff.elim_left (and_not_self (h_w ≤ n)) h6)
  ]

  lemma flae_ind : (svar_set n v) ∪ {p n} =  svar_set (n+1) (g₁ n v) :=
    by flae_ind_tac

  lemma flae_ind_neg : (svar_set n v) ∪ {~p n} =  svar_set (n+1) (g₂ n v) :=
    by flae_ind_tac

 -- induction formalization
  def nprovable (A:Form)(n:ℕ) : Prop :=
    ∀ v:eval, (svar_set n v) ⊢ A

  lemma PCP_app : ∀ n:ℕ, nprovable A (n+1) → nprovable A n:=
    λ n hp f, show  (svar_set n f) ⊢ A, from PCP
    (@eq.subst (set Form) (λ Γ, Γ ⊢ A) (svar_set (n+1) (g₁ n f)) ((svar_set n f) ∪ {p n})
      (@flae_ind f n).symm (hp (g₁ n f)))
    (@eq.subst (set Form) (λ Γ, Γ ⊢  A) (svar_set (n+1) (g₂ n f)) ((svar_set n f) ∪ { ~(p n)})
      (@flae_ind_neg f n).symm (hp (g₂ n f)))

  theorem nprov_theorem : nprovable A n → (⊢ A) :=
    λ h, have H: nprovable A n → nprovable A 0, from
      nat.rec_on n (λ h, h) (assume n IH hp, IH (PCP_app n hp)),
    (@flae_empty (λ n:ℕ, tt)) ▸ (H h) (λ n:ℕ, tt)

-- COMPLETENESS

  lemma main_lemma : ∀ v:eval, (svar_set (form_index A) v) ⊢ swap A v :=
    λ v,
    Form.rec_on A
    -- p constructor
    (λ n, exists.intro []
      ⟨or.inr (or.inr (or.inr (or.inl swap_in_flae))), rfl⟩)
    -- imp constructor
    (λ A B, let Γa := (svar_set (form_index A) v),
                Γb:set Form := (svar_set (form_index B) v),
                Γimp := (svar_set (form_index (A ⇒ B)) v) in
   λ IHa: Γa ⊢ swap A v,
   λ IHb: Γb ⊢ swap B v,
   have h: Γa ⊆ Γimp, from flae_inclusion (form_index A) var_index_max_left,
   have hbb: Γb ⊆ Γimp, from flae_inclusion (form_index B) var_index_max_right,
   or.elim (bool.dichotomy (v∗A))
    -- v∗A=ff
     (λ hpa, have himp: swap (A ⇒ B) v = (A ⇒ B), from swap_tt (swap_imp_ff hpa),
     (calc (Γa ⊢ swap A v) → (Γa ⊢ ~A)                :  λ h, swap_ff hpa ▸ IHa
                 ...       → (Γa ⊢ A ⇒ B)             :  λ h, provable3 h
                 ...       → (Γimp ⊢ A ⇒ B)           :  λ hp, monotony h hp
                 ...       → (Γimp ⊢ swap (A ⇒ B) v)  :  λ h, himp.symm ▸ h)
     IHa)

    -- v∗A=tt
     (λ hpa, or.elim (bool.dichotomy (v∗ B))
      -- v∗B=ff
      (λ hpb, have ha: (Γimp ⊢ A), from
              (calc (Γa ⊢ swap A v) → (Γa ⊢ A)    : λ h5, swap_tt hpa ▸ IHa
                          ...       → (Γimp ⊢ A)  : λ h5, monotony h h5) IHa,
              have hb: (Γimp ⊢ ~B), from
              (calc (Γb ⊢ swap B v) → (Γb ⊢ ~B)   : λ h5, swap_ff hpb ▸ IHb
                           ...      → (Γimp ⊢ ~B) : λ h5, monotony hbb h5) IHb,
              have hab: (Γimp ⊢ ~(A ⇒ B)), from provable4 ha hb,
              (calc (Γimp ⊢ ~(A ⇒ B)) → (Γimp ⊢ swap (A ⇒ B) v) :
               λ h5, eq.substr (swap_imp_tt_ff hpa hpb) h5) hab)
      -- v∗B=tt
      (λ hpb, have hb: (Γimp ⊢ B), from
              (calc (Γb ⊢ swap B v) → (Γb ⊢ B)   : λ h5, swap_tt hpb ▸ IHb
                           ...      →  (Γimp ⊢ B) : λ h5, monotony hbb h5) IHb,
              have hab: (Γimp ⊢ (A ⇒ B)), from (@provable6 B A Γimp) hb,
              (calc (Γimp ⊢ (A ⇒ B)) → (Γimp ⊢ swap (A ⇒ B) v) :
               λ h5, (swap_imp_tt_tt hpa hpb).symm ▸ h5) hab)))
    -- neg₁ constructor
    (λ A,   let Γa := ( svar_set (form_index A) v) in
     λ ha: Γa ⊢ swap A v,
     show Γa ⊢ swap (~A) v, from
     or.elim (bool.dichotomy (v∗A))
    -- v∗A=ff
    (λ h, (calc (Γa ⊢ swap A v) → (Γa ⊢ ~A)          : λ h1, swap_ff h ▸ ha
                       ...      → (Γa ⊢ swap (~A) v) : λ h1, (swap_neg_ff h).symm ▸ h1) ha)
    -- v∗A=tt
    (λ h, (calc (Γa ⊢ swap A v) → (Γa ⊢ A)           : λ h1, swap_tt h ▸ ha
                       ...      → (Γa ⊢ ~~A)         : λ h1, modus_ponens h1 provable2
                       ...      → (Γa ⊢ swap (~A) v) : λ h1, (swap_neg_tt h).symm ▸ h1) ha))

  theorem CPL_completeness: ⊧ A → ⊢ A :=
    λ h, have H: nprovable A (form_index A), from
      (λ v:eval, @eq.subst Form
      (λ B:Form, is_provable (svar_set (form_index A) v) B)
      (swap A v) A (swap_tt (h v)) (main_lemma v)),
    nprov_theorem H


import ring_theory.adjoin_root data.equiv.algebra algebra.direct_limit
import set_theory.schroeder_bernstein

universes u v w
open polynomial zorn set function
variables (K : Type u) [discrete_field K]
noncomputable theory

instance equiv.is_ring_hom {α β : Type*} [ring β] (e : α ≃ β) :
  @is_ring_hom α β (equiv.ring e) _ e :=
by split; simp [equiv.mul_def, equiv.add_def, equiv.one_def]

instance equiv.is_ring_hom.symm {α β : Type*} [ring β] (e : α ≃ β) :
  @is_ring_hom β α _ (equiv.ring e) e.symm :=
by letI := equiv.ring e; exact (show α ≃r β, from ⟨e, equiv.is_ring_hom e⟩).symm.2

inductive in_algebraic_closure {L : Type v} [discrete_field L] (i : K → L) : L → Prop
| of_field : ∀ x, in_algebraic_closure (i x)
| root     : ∀ (l : L) (f : polynomial L), f ≠ 0 → (∀ n : ℕ, in_algebraic_closure (f.coeff n)) →
  is_root f l → in_algebraic_closure l

def algebraic {L : Type v} [comm_ring L] (i : K → L) (x : L) : Prop :=
∃ f : polynomial K, f ≠ 0 ∧ f.eval₂ i x = 0

class is_algebraically_closed :=
(exists_root : ∀ f : polynomial K, 0 < degree f → ∃ x, is_root f x)

lemma algebraic_comp {L M : Type*} [comm_ring L] [decidable_eq L] [comm_ring M] [decidable_eq M]
  (i : K → L) (j : L → M) [is_ring_hom i] [is_ring_hom j] {x : L} :
  algebraic K i x → algebraic K (j ∘ i) (j x) :=
λ ⟨f, hf⟩, ⟨f, hf.1, by rw [← eval_map, function.comp, ← polynomial.map_map i j, eval_map,
    eval₂_hom, eval_map, hf.2, is_ring_hom.map_zero j]⟩

lemma algebraic_id (x : K) : algebraic K id x :=
⟨X - C x, ne_zero_of_monic (monic_X_sub_C _), by simp⟩

lemma algebraic_equiv {L : Type*} [discrete_field L] (e : K ≃ L) [is_ring_hom e] (x : L) :
  algebraic K e x :=
⟨X - C (e.symm x), ne_zero_of_monic (monic_X_sub_C _),
  by rw [← eval_map, map_sub, map_X, map_C, equiv.apply_symm_apply,
      eval_sub, eval_X, eval_C, sub_self]⟩

lemma algebraic_adjoin_root (f : polynomial K) [irreducible f] :
  ∀ x, algebraic K (adjoin_root.of : K → adjoin_root f) x := sorry

lemma algebraic_comp' {L M : Type*} [discrete_field L] [discrete_field M]
  (i : K → L) (j : L → M) [is_field_hom i] [is_field_hom j] :
  (∀ x, algebraic K i x) → (∀ x, algebraic L j  x) → ∀ x, algebraic K (j ∘ i) x := sorry

section classical

local attribute [instance, priority 1] classical.dec

def big_type := set (ℕ × polynomial K)

def big_type_map {L : Type*} [discrete_field L] (i : K → L) [is_ring_hom i]
  (h : ∀ l : L, algebraic K i l) (x : L) : ℕ × polynomial K :=
let f := classical.some (h x) in
⟨list.index_of x (quotient.out ((f.map i).roots.1)), f⟩

lemma big_type_map_injective {L : Type*} [discrete_field L] (i : K → L) [is_ring_hom i]
  (h : ∀ l : L, algebraic K i l) : injective (big_type_map K i h) :=
λ x y hxy,
let f := classical.some (h x) in
let g := classical.some (h y) in
have hf : f ≠ 0 ∧ f.eval₂ i x = 0, from classical.some_spec (h x),
have hg : g ≠ 0 ∧ g.eval₂ i y = 0, from classical.some_spec (h y),
have hfg : f = g, from (prod.ext_iff.1 hxy).2,
have hfg' : list.index_of x (quotient.out ((f.map i).roots.1)) =
    list.index_of y (quotient.out ((f.map i).roots.1)),
  from (prod.ext_iff.1 hxy).1.trans (hfg.symm ▸ rfl),
have hx : x ∈ quotient.out ((f.map i).roots.1),
  from multiset.mem_coe.1 begin
    show x ∈ quotient.mk _,
    rw [quotient.out_eq, ← finset.mem_def, mem_roots (mt (map_eq_zero i).1 hf.1),
      is_root.def, eval_map, hf.2]
  end,
have hy : y ∈ quotient.out ((f.map i).roots.1),
  from multiset.mem_coe.1 begin
    show y ∈ quotient.mk _,
    rw [quotient.out_eq, ← finset.mem_def, mem_roots (mt (map_eq_zero i).1 hf.1),
      is_root.def, eval_map, hfg, hg.2]
  end,
(list.index_of_inj hx hy).1 hfg'

lemma bembedding : K ↪ big_type K :=
⟨λ a, show set _, from {(0, X - C a)}, λ a b, by simp [C_inj]⟩

instance : discrete_field (set.range (bembedding K)) :=
equiv.discrete_field (equiv.set.range _ (bembedding K).2).symm

structure extension : Type (u+1) :=
(carrier : set (big_type K))
[field : discrete_field ↥carrier]
(range_subset : set.range (bembedding K) ⊆ carrier)
[is_field_hom : is_field_hom (inclusion range_subset)]
(algebraic : ∀ x, algebraic _ (inclusion (range_subset)) x)
(lift : Π {α : Type u} [discrete_field α] (i : set.range (bembedding K) → α)
  [by exactI _root_.is_field_hom i] [is_algebraically_closed α],
  carrier → α)
(lift_is_field_hom : ∀ {α : Type u} [discrete_field α] (i : set.range (bembedding K) → α)
  [by exactI _root_.is_field_hom i] [is_algebraically_closed α],
  by exactI _root_.is_field_hom (lift i))
(lift_comp : ∀ {α : Type u} [discrete_field α] (i : set.range (bembedding K) → α)
  [by exactI _root_.is_field_hom i] [is_algebraically_closed α] (x),
  by exactI lift i (inclusion range_subset x) = i x)

local attribute [instance] extension.field extension.is_field_hom extension.lift_is_field_hom

instance : preorder (extension K) :=
{ le := λ s t, ∃ hst : s.carrier ⊆ t.carrier, is_field_hom (inclusion hst)
    ∧ ∀ {α : Type u} [discrete_field α] (i : set.range (bembedding K) → α)
    [by exactI _root_.is_field_hom i] [by exactI is_algebraically_closed α] (x : s.carrier),
    by exactI s.lift i x = t.lift i (inclusion hst x),
  le_refl := λ _, ⟨by refl, by simp [inclusion]; exact is_ring_hom.id,
    by intros; simp [inclusion, subtype.coe_eta]⟩,
  le_trans := λ s t u ⟨hst₁, hst₂, hst₃⟩ ⟨htu₁, htu₂, htu₃⟩,
    ⟨set.subset.trans hst₁ htu₁,
      by resetI; convert is_ring_hom.comp (inclusion hst₁) (inclusion htu₁),
      by intros; rw [hst₃, htu₃, inclusion_inclusion]⟩ }

private structure chain' (c : set (extension K)) : Prop :=
(chain : chain (≤) c)

local attribute [class] chain'

lemma is_chain (c : set (extension K)) [chain' _ c]: chain (≤) c :=
chain'.chain (by apply_instance)

section

variables (c : set (extension K)) [hcn : nonempty c]
include c  hcn

variable [hcn' : chain' _ c]
include hcn'

instance chain_directed_order : directed_preorder c :=
⟨λ ⟨i, hi⟩ ⟨j, hj⟩, let ⟨k, hkc, hk⟩ := chain.directed_on
  (is_chain _ c) i hi j hj in ⟨⟨k, hkc⟩, hk⟩⟩

def chain_map (i j : c) (hij : i ≤ j) : i.1.carrier → j.1.carrier :=
inclusion (exists.elim hij (λ h _, h))

instance chain_field_hom (i j : c) (hij : i ≤ j) : is_field_hom (chain_map _ c i j hij) :=
exists.elim hij (λ _, and.left)

instance chain_directed_system : directed_system (λ i : c, i.1.carrier) (chain_map _ c) :=
by split; intros; simp [chain_map]

def chain_limit : Type (u+1) :=
  ring.direct_limit (λ i : c, i.1.carrier) (chain_map _ c)

lemma of_eq_of (x : big_type K) (i j : c) (hi : x ∈ i.1.carrier) (hj : x ∈ j.1.carrier) :
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) i ⟨x, hi⟩ =
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) j ⟨x, hj⟩ :=
have hij : i ≤ j ∨ j ≤ i,
  from show i.1 ≤ j.1 ∨ j.1 ≤ i.1, from chain.total (is_chain _ c) i.2 j.2,
hij.elim
  (λ hij, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hij,
    simp [chain_map, inclusion]
  end)
  (λ hij, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hij,
    simp [chain_map, inclusion]
  end)

lemma injective_aux (i j : c)
  (x y : ⋃ i : c, i.1.carrier) (hx : x.1 ∈ i.1.carrier) (hy : y.1 ∈ j.1.carrier) :
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) i ⟨x, hx⟩ =
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) j ⟨y, hy⟩ →
  x = y :=
have hij : i ≤ j ∨ j ≤ i,
  from show i.1 ≤ j.1 ∨ j.1 ≤ i.1, from chain.total (is_chain _ c) i.2 j.2,
have hinj : ∀ (i j : c) (hij : i ≤ j), injective (chain_map _ c i j hij),
  from λ _ _ _, is_field_hom.injective _,
hij.elim
  (λ hij h, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hij at h,
    simpa [chain_map, inclusion, subtype.coe_ext.symm] using ring.direct_limit.of_inj hinj j h,
  end)
  (λ hji h, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map _ c) _
      _ _ _ hji at h,
    simpa [chain_map, inclusion, subtype.coe_ext.symm] using ring.direct_limit.of_inj hinj i h,
  end)

def equiv_direct_limit : (⋃ (i : c), i.1.carrier) ≃
  ring.direct_limit (λ i : c, i.1.carrier) (chain_map _ c) :=
@equiv.of_bijective (⋃ i : c, i.1.carrier)
  (ring.direct_limit (λ i : c, i.1.carrier) (chain_map _ c))
  (λ x, ring.direct_limit.of _ _ (classical.some (set.mem_Union.1 x.2))
    ⟨_, classical.some_spec (set.mem_Union.1 x.2)⟩)
  ⟨λ x y, injective_aux _ _ _ _ _ _ _ _,
    λ x, let ⟨i, ⟨y, hy⟩, hy'⟩ := ring.direct_limit.exists_of x in
      ⟨⟨y, _, ⟨i, rfl⟩, hy⟩, begin
        convert hy',
        exact of_eq_of _ _ _ _ _ _ _
      end⟩⟩

instance Union_field : discrete_field (⋃ i : c, i.1.carrier) :=
@equiv.discrete_field _ _ (equiv_direct_limit _ c)
  (field.direct_limit.discrete_field _ _)

instance is_field_hom_Union (i : c) : is_field_hom
  (inclusion (set.subset_Union (λ i : c, i.1.carrier) i)) :=
suffices inclusion (set.subset_Union (λ i : c, i.1.carrier) i) =
    ((equiv_direct_limit K c).symm ∘
    ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map _ c) i),
  by rw this; exact is_ring_hom.comp _ _,
funext $ λ ⟨_, _⟩,
  (equiv_direct_limit _ c).injective $
    by rw [function.comp_app, equiv.apply_symm_apply];
      exact of_eq_of _ _ _ _ _ _ _

instance is_field_hom_range_Union [hc : nonempty c]
  (h : set.range (bembedding K) ⊆ ⋃ i : c, i.1.carrier) :
  is_field_hom (inclusion h) :=
let ⟨i⟩ := hc in
have h₁ : i.1.carrier ⊆ ⋃ i : c, i.1.carrier, from set.subset_Union _ i,
have h₂ : set.range (bembedding K) ⊆ i.1.carrier, from i.1.range_subset,
have inclusion h = inclusion h₁ ∘ inclusion h₂, by simp [function.comp],
by rw this; exact is_ring_hom.comp _ _

def chain_lift [nonempty c] (α : Type u) [discrete_field α] (i : set.range (bembedding K) → α)
  [is_field_hom i] [is_algebraically_closed α] :
  (⋃ i : c, i.1.carrier) → α :=
(ring.direct_limit.lift (λ j : c, j.1.carrier) (chain_map _ c) _
  (λ j : c, j.1.lift i) (λ i j ⟨_, _, h⟩, by introsI; rw [h, chain_map])) ∘
  (equiv_direct_limit K c)

def is_field_hom_chain_lift [nonempty c] (α : Type u) [discrete_field α]
  (i : set.range (bembedding K) → α) [is_field_hom i]
  [is_algebraically_closed α] : is_field_hom (chain_lift K c α i) :=
is_ring_hom.comp _ _

end

lemma exists_algebraic_closure : ∃ m : extension K, ∀ a, m ≤ a → a ≤ m :=
by letI := classical.dec; exact
zorn
  (λ c hc, if h : nonempty c
    then by letI : chain' K c := ⟨hc⟩; exact
      ⟨{carrier := ⋃ (i : c), i.1.carrier,
        range_subset := let ⟨i⟩ := h in
          have hi : set.range (bembedding K) ⊆ i.1.carrier,
            from extension.range_subset _,
          set.subset.trans hi (set.subset_Union (λ i : c, i.1.carrier) i),
        algebraic := begin
            rintros ⟨x, hx⟩,
            cases set.mem_Union.1 hx with i hi,
            convert @algebraic_comp (set.range (bembedding K)) _ i.1.carrier
              (⋃ i : c, i.1.carrier) _ _ _ _
              (inclusion i.1.range_subset)
              (inclusion (set.subset_Union (λ i : c, i.1.carrier) (i : c))) _ _ _
              (i.1.algebraic ⟨x, hi⟩)
          end,
        lift := chain_lift _ c,
        lift_is_field_hom := is_field_hom_chain_lift K c,
        lift_comp := begin
            intros,
            dunfold chain_lift equiv_direct_limit,
            simp,
            erw extension.lift_comp
          end },
      λ e he, ⟨set.subset_Union (λ i : c, i.1.carrier) ⟨e, he⟩,
        by apply_instance,
        begin
          intros,
          dsimp [chain_lift, equiv_direct_limit],
          erw [ring.direct_limit.lift_of],
          cases chain.total (is_chain _ c) he (classical.some (set.mem_Union.1
            (set.subset_Union (λ i : c, i.1.carrier) ⟨e, he⟩ x.2))).2 with h h,
          { rw (classical.some_spec h).2, refl },
          { erw (classical.some_spec h).2, cases x, refl }
        end⟩⟩
    else
      have is_field_hom (inclusion (set.subset.refl (set.range (bembedding K)))) :=
      by convert is_ring_hom.id; funext; simp,
      by exactI ⟨⟨set.range (bembedding K), by refl,
          λ _, by convert algebraic_id _ _; funext; simp, λ _ _ i _ _, i,
          by introsI; apply_instance, by simp [inclusion]⟩,
        λ a ha, (h ⟨⟨a, ha⟩⟩).elim⟩)
  (λ _ _ _, le_trans)

def closed_extension := classical.some (exists_algebraic_closure K)

def algebraic_closure : Type u := ((classical.some (exists_algebraic_closure K))).carrier

end classical

namespace algebraic_closure

instance : discrete_field (algebraic_closure K) :=
{ has_decidable_eq := classical.dec_eq _,
  ..(classical.some (exists_algebraic_closure K)).field }

def of_aux : K → set.range (bembedding K) :=
equiv.set.range _ (bembedding K).2

lemma of_aux.is_field_hom : is_ring_hom (of_aux K) :=
equiv.is_ring_hom.symm (equiv.set.range _ (bembedding K).2).symm

def of_aux_symm : set.range (bembedding K) → K :=
(equiv.set.range _ (bembedding K).2).symm

lemma of_aux_symm.is_field_hom : is_ring_hom (of_aux_symm K) :=
equiv.is_ring_hom (equiv.set.range _ (bembedding K).2).symm

local attribute [instance] of_aux.is_field_hom of_aux_symm.is_field_hom

def of : K → algebraic_closure K :=
inclusion (classical.some (exists_algebraic_closure K)).range_subset ∘
(of_aux K)

instance : is_ring_hom (of K) :=
begin
  haveI h₁ := (classical.some (exists_algebraic_closure K)).is_field_hom,
  letI h₂ : ring (classical.some (exists_algebraic_closure K)).carrier :=
    show ring (algebraic_closure K), by apply_instance,
  unfold of,
  exact @is_ring_hom.comp _ _ _ _ _ _ _ _ _ h₁
end

lemma of_algebraic_aux (x : algebraic_closure K) :
  @algebraic (set.range (bembedding K)) _ (algebraic_closure K) _
  (inclusion (classical.some (exists_algebraic_closure K)).range_subset) x :=
(classical.some (exists_algebraic_closure K)).algebraic x

lemma of_algebraic (x : algebraic_closure K) : algebraic K (of K) x :=
let ⟨f, hf⟩ := (classical.some (exists_algebraic_closure K)).algebraic x in
⟨f.map (of_aux_symm K), mt (map_eq_zero _).1 hf.1,
  calc eval₂ (of K) x (f.map (of_aux_symm K)) = eval₂ (λ x, of K (of_aux_symm K x)) x f :
    sorry

  ... = 0 : sorry
  ⟩
 -- eval₂_map (of_aux_symm K) (of K) x).trans _

def lift_aux {L : Type u} [discrete_field L] (i : set.range (bembedding K) → L)
  [is_field_hom i] [is_algebraically_closed L] :
  algebraic_closure K → L :=
(classical.some (exists_algebraic_closure K)).lift i

lemma lift_aux.is_field_hom {L : Type u} [discrete_field L] (i : set.range (bembedding K) → L)
  [is_field_hom i] [is_algebraically_closed L] : is_field_hom (lift_aux K i) :=
(classical.some (exists_algebraic_closure K)).lift_is_field_hom _

local attribute [instance] lift_aux.is_field_hom

section map

local attribute [instance] classical.dec

lemma map_aux {X : Type u} {Y : Type v} {Z : Type w} (fxy : X ↪ Y) (fxz : X ↪ Z)
  (hYZ : (Z ↪ Y) → false) : ↥-range fxy.1 ↪ ↥-range fxz.1 :=
classical.choice $ or.resolve_left embedding.total $
  λ ⟨f⟩, hYZ $
    calc Z ↪ range fxz ⊕ ↥-range fxz :
      (equiv.set.sum_compl _).symm.to_embedding
    ... ↪ range fxy ⊕ ↥-range fxy :
      embedding.sum_congr
        (((equiv.set.range _ fxz.2).symm.to_embedding).trans
          (equiv.set.range _ fxy.2).to_embedding)
        f
    ... ↪ Y : (equiv.set.sum_compl _).to_embedding

def map {X : Type u} {Y : Type v} {Z : Type w} (fxy : X ↪ Y) (fxz : X ↪ Z)
  (hYZ : (Z ↪ Y) → false) : Y ↪ Z :=
calc Y ↪ range fxy ⊕ ↥-range fxy : (equiv.set.sum_compl _).symm.to_embedding
... ↪ range fxz ⊕ ↥-range fxz : embedding.sum_congr
  ((equiv.set.range _ fxy.2).symm.to_embedding.trans
    (equiv.set.range _ fxz.2).to_embedding)
  (map_aux fxy fxz hYZ)
... ↪ Z : (equiv.set.sum_compl _).to_embedding

lemma map_commutes {X : Type u} {Y : Type v} {Z : Type w}  (fxy : X ↪ Y) (fxz : X ↪ Z)
  (hYZ : (Z ↪ Y) → false) (x : X) : map fxy fxz hYZ (fxy x) = fxz x :=
have (⟨fxy x, mem_range_self _⟩ : range fxy) = equiv.set.range _ fxy.2 x, from rfl,
begin
  dsimp only [map, embedding.trans_apply, equiv.trans_apply, function.comp,
    equiv.to_embedding_coe_fn],
  simp only [equiv.set.sum_compl_symm_apply_of_mem (mem_range_self _),
    embedding.sum_congr_apply_inl, equiv.set.sum_compl_apply_inl,
    embedding.trans_apply, equiv.to_embedding_coe_fn, this, equiv.symm_apply_apply],
  refl
end

end map

section adjoin_root
variables (f : polynomial (algebraic_closure K)) [hif : irreducible f]
include hif

instance adjoin_root_algebraic_closure.field :
  discrete_field (adjoin_root f) := by apply_instance

instance adjoin_root_algebraic_closure.is_ring_hom :
  is_ring_hom (@adjoin_root.of _ _ _ f) := by apply_instance

instance algebraic_closure_adjoin_root_comp.is_ring_hom :
  is_ring_hom (@adjoin_root.of _ _ _ f ∘ of K) := is_ring_hom.comp _ _

def adjoin_root.of_embedding : algebraic_closure K ↪ adjoin_root f :=
⟨adjoin_root.of, is_field_hom.injective _⟩

def adjoin_root_extension_map : adjoin_root f ↪ big_type K :=
(map (adjoin_root.of_embedding K f)
    ⟨subtype.val, subtype.val_injective⟩
  (λ i, cantor_injective _ (show big_type K ↪ ℕ × polynomial K,
    from i.trans ⟨big_type_map K (@adjoin_root.of _ _ _ f ∘ of K)
        (algebraic_comp' K _ _ (of_algebraic K) (algebraic_adjoin_root _ f)),
      big_type_map_injective _ _ _⟩).2))

lemma adjoin_root_extension_map_apply (x : algebraic_closure K) :
  (adjoin_root_extension_map K f) (@adjoin_root.of _ _ _ f x) = x.val :=
map_commutes _ _ _ _

lemma closure_subset_adjoin_root :
  (closed_extension K).carrier ⊆ set.range (adjoin_root_extension_map K f) :=
(λ x h, ⟨adjoin_root.of_embedding K f ⟨x, h⟩,
  show (adjoin_root_extension_map K f)
      (adjoin_root.of_embedding K f ⟨x, h⟩) =
      (⟨x, h⟩ : algebraic_closure K).val,
    from map_commutes _ _ _ _⟩)

lemma adjoin_root_range_subset :
  (set.range (bembedding K)) ⊆ set.range (adjoin_root_extension_map K f) :=
set.subset.trans
  (classical.some (exists_algebraic_closure K)).range_subset
  (closure_subset_adjoin_root K f)

lemma adjoin_root_inclusion_eq :
  inclusion (adjoin_root_range_subset K f) =
  (equiv.set.range _ (adjoin_root_extension_map K f).2) ∘
  (@adjoin_root.of (algebraic_closure K) _ _ f) ∘
  inclusion (classical.some (exists_algebraic_closure K)).range_subset :=
funext $ λ x, subtype.eq $
  by simp [inclusion, function.comp, adjoin_root_extension_map_apply]

lemma adjoin_root_inclusion_eq' :
  inclusion (closure_subset_adjoin_root K f) =
  (equiv.set.range _ (adjoin_root_extension_map K f).2) ∘
  (@adjoin_root.of (algebraic_closure K) _ _ f) :=
funext $ λ x, subtype.eq $
  by simp [inclusion, function.comp, adjoin_root_extension_map_apply]; refl

instance adjoin_root_range.discrete_field :
  discrete_field (set.range (adjoin_root_extension_map K f)) :=
equiv.discrete_field (equiv.set.range _ (embedding.inj _)).symm

instance adjoin_root_inclusion.is_ring_hom :
  is_ring_hom (inclusion (adjoin_root_range_subset K f)) :=
begin
  letI := (classical.some (exists_algebraic_closure K)).is_field_hom,
  rw [adjoin_root_inclusion_eq, ← equiv.symm_symm (equiv.set.range _ _)],
  exact @is_ring_hom.comp _ _ _ _ _ (is_ring_hom.comp _ _) _ _ _
    (equiv.is_ring_hom.symm _)
end
--set_option eqn_compiler.zeta true

def adjoin_root_lift {α : Type u} [_inst_2_1 : discrete_field α] (i : (range ⇑(bembedding K)) → α)
  [is_field_hom i] [is_algebraically_closed α] :
  (range ⇑(adjoin_root_extension_map K f)) → α :=
begin
  have h : _ := is_algebraically_closed.exists_root
    (f.map (lift_aux K i))
    (by rw degree_map; exact degree_pos_of_ne_zero_of_nonunit
      (nonzero_of_irreducible hif) hif.1),
  exact adjoin_root.lift (lift_aux K i) (classical.some h) (by rw [← eval_map];
    exact (classical.some_spec h)) ∘
  (equiv.set.range _ (adjoin_root_extension_map K f).2).symm
end

lemma adjoin_root_lift.is_ring_hom {α : Type u} [_inst_2_1 : discrete_field α]
  (i : (range ⇑(bembedding K)) → α) [is_field_hom i] [is_algebraically_closed α] :
  is_field_hom (adjoin_root_lift _ f i) :=
begin
  letI := equiv.is_ring_hom.symm (equiv.set.range _ (adjoin_root_extension_map K f).2),
  dsimp [adjoin_root_lift],
  rw [← equiv.symm_symm (equiv.set.range _ _)],
  exact is_ring_hom.comp _ _
end

def adjoin_root_extension : extension K :=
{ carrier := set.range (adjoin_root_extension_map K f),
  range_subset := adjoin_root_range_subset _ _,
  algebraic := begin
    letI := (classical.some (exists_algebraic_closure K)).is_field_hom,
    rw [adjoin_root_inclusion_eq, ← equiv.symm_symm (equiv.set.range _ _)],
    refine @algebraic_comp' _ _ _ _ _ _ _ _
      (is_ring_hom.comp _ _) (by convert equiv.is_ring_hom.symm _) _ _,
    { exact @algebraic_comp' _ _ _ _ _
        _ _ _ _ _ (of_algebraic_aux _) (algebraic_adjoin_root _ f) },
    { exact algebraic_equiv _ _ }
  end,
  lift := @adjoin_root_lift K _ _ _,
  lift_is_field_hom := @adjoin_root_lift.is_ring_hom K _ _ _,
  lift_comp := begin
    intros,
    dsimp [adjoin_root_lift, function.comp],
    have : inclusion (adjoin_root_range_subset K f) x =
      equiv.set.range _ (adjoin_root_extension_map K f).2
        (adjoin_root.of
          (inclusion (classical.some (exists_algebraic_closure K)).range_subset x)),
      by rw [adjoin_root_inclusion_eq],
    erw [this, equiv.symm_apply_apply, adjoin_root.lift_of],
    exactI (classical.some (exists_algebraic_closure K)).lift_comp _ _
  end }

example : 1 + 1 = 2 := rfl

instance adjoin_root_extension.field : discrete_field (adjoin_root_extension K f).carrier :=
extension.field _

local attribute [instance] extension.field extension.is_field_hom extension.lift_is_field_hom

lemma closed_extension_le_adjoin_root_extension :
  closed_extension K ≤ adjoin_root_extension K f :=
by letI : discrete_field (closed_extension K).carrier := extension.field _; exact
⟨closure_subset_adjoin_root K f, by rw [adjoin_root_inclusion_eq'];
  exact is_ring_hom.comp _ _, begin
  introsI,

end⟩

instance : is_algebraically_closed (algebraic_closure K) :=
⟨λ f hf0, let ⟨g, hg⟩ := is_noetherian_ring.exists_irreducible_factor
    (show ¬ is_unit f, from λ h, by rw [is_unit_iff_degree_eq_zero] at h;
      rw h at hf0; exact lt_irrefl _ hf0)
    (λ h, by rw [← degree_eq_bot] at h;
      rw h at hf0; exact absurd hf0 dec_trivial) in
  begin
    letI := hg.1,
    have := classical.some_spec (exists_algebraic_closure K)
      (adjoin_root_extension K g),

  end⟩

end adjoin_root

end algebraic_closure


import new.unordered.d
import algebra.homology.homological_complex
import algebra.category.Group.abelian
import algebra.homology.homology
import new.unordered.refinement

noncomputable theory

section

open topological_space Top Top.sheaf
open category_theory
open opposite
open nat

open_locale big_operators

universe u
variables {X : Top.{u}} (𝓕 : sheaf Ab X) (U V : X.oc)

def d_from_to (i j : ℕ) : C 𝓕 U i ⟶ C 𝓕 U j :=
dite (j = i + 1)
(λ h, d 𝓕 U i ≫ eq_to_hom (by rw h))
(λ h, 0)

lemma d_to_succ {i : ℕ} (f α) :
  d_from_to 𝓕 U i (i + 1) f α = d 𝓕 U i f α :=
begin
  rw [d_from_to],
  rw dif_pos rfl,
  rw comp_apply,
  refl,
end

lemma d_to_succ' (i : ℕ) :
  d_from_to 𝓕 U i (i + 1) = d 𝓕 U i :=
begin
  ext f α,
  rw d_to_succ,
end

lemma d_not_to_succ {i j : ℕ} (h : j ≠ i + 1) (f α) :
  d_from_to 𝓕 U i j f α = 0 :=
begin
  rw [d_from_to, dif_neg h],
  refl,
end

def Cech_complex_wrt_cover_unordered : cochain_complex Ab.{u} ℕ :=
{ X := λ n, C 𝓕 U (n + 1),
  d := λ i j, d_from_to 𝓕 U (i + 1) (j + 1),
  shape' := λ i j h, begin
    ext f α,
    rw d_not_to_succ,
    rw [add_monoid_hom.zero_apply, pi.zero_apply],
    simp only [complex_shape.up_rel] at h,
    contrapose! h,
    simp only [add_left_inj] at h,
    exact h.symm,
  end,
  d_comp_d' := λ i j k h1 h2, begin
    simp only [complex_shape.up_rel] at h1 h2,
    subst' h2,
    subst' h1,
    ext f α,
    rw comp_apply,
    rw d_to_succ,
    rw d_to_succ',
    simp only [AddCommGroup.zero_apply, C_pre.zero_apply],
    rw dd_eq_zero,
  end }

lemma Cech_complex_wrt_cover_unordered.d_to_rel
  (n : ℕ) (m) (h : (complex_shape.up ℕ).prev n = some m) :
  (Cech_complex_wrt_cover_unordered 𝓕 U).d m.1 n =
  d 𝓕 U (m.1 + 1) ≫ eq_to_hom begin
    have := m.2,
    simp only [complex_shape.up_rel] at this,
    rw this,
    refl,
  end :=
begin
  change d_from_to 𝓕 U _ _ = _,
  rw [d_from_to, dif_pos],
  refl,
  have h2 := m.2.symm,
  rw ← h2,
end

def Cech_Cohomology_Group_wrt_cover_unordered_nth (n : ℕ) : Ab.{u} :=
@homological_complex.homology ℕ Ab _ _ (complex_shape.up ℕ) (abelian.has_zero_object) _ _ _
  (Cech_complex_wrt_cover_unordered 𝓕 U) n

section

variables {U V} (r : U ⟶ V)

include r
def Cech_complex_wrt_cover_unordered.prev (n : ℕ) :
  @homological_complex.X_prev _ _ _ _ (complex_shape.up ℕ)
    (Cech_complex_wrt_cover_unordered 𝓕 V)
    (abelian.has_zero_object) n ⟶
  @homological_complex.X_prev _ _ _ _ (complex_shape.up ℕ)
    (Cech_complex_wrt_cover_unordered 𝓕 U)
    (abelian.has_zero_object) n :=
match (complex_shape.up ℕ).prev n with
| none := 0
| some m := begin
  refine _ ≫ @C.refine X 𝓕 _ _ (m.1 + 1) r ≫ _,
  refine (@@homological_complex.X_prev_iso _ _ _ (abelian.has_zero_object) m.2).hom,
  exact (@@homological_complex.X_prev_iso _ _ (Cech_complex_wrt_cover_unordered 𝓕 U) (abelian.has_zero_object) m.2).inv,
end
end

lemma Cech_complex_wrt_cover_unordered.prev_none (n : ℕ)
  (h : (complex_shape.up ℕ).prev n = none) :
  Cech_complex_wrt_cover_unordered.prev 𝓕 r n = 0 :=
begin
  rw Cech_complex_wrt_cover_unordered.prev,
  rw h,
  refl,
end

lemma Cech_Group_wrt_cover_unordered_nth.prev_some (n : ℕ) (m)
  (h : (complex_shape.up ℕ).prev n = some m) :
  Cech_complex_wrt_cover_unordered.prev 𝓕 r n =
  (@@homological_complex.X_prev_iso _ _ _ (abelian.has_zero_object) m.2).hom ≫
    @C.refine X 𝓕 _ _ (m.1 + 1) r ≫
    (@@homological_complex.X_prev_iso _ _ (Cech_complex_wrt_cover_unordered 𝓕 U) (abelian.has_zero_object) m.2).inv :=
begin
  rw Cech_complex_wrt_cover_unordered.prev,
  rw h,
  refl,
end

example (n : ℕ) : (complex_shape.up ℕ).next n = some ⟨n+1, rfl⟩ :=
begin
  rw [complex_shape.next_eq_some],
end

def Cech_Cohomology_Group_wrt_cover_unordered_nth.refinement (n : ℕ) :
  Cech_Cohomology_Group_wrt_cover_unordered_nth 𝓕 V n ⟶
  Cech_Cohomology_Group_wrt_cover_unordered_nth 𝓕 U n :=
homology.map _ _
{ left := Cech_complex_wrt_cover_unordered.prev 𝓕 r n,
  right := C.refine r,
  w' := begin
    simp only [category_theory.functor.id_map, arrow.mk_hom],
    ext f α,
    rw [comp_apply, comp_apply],
    by_cases h : (complex_shape.up ℕ).prev n = none,
    { rw Cech_complex_wrt_cover_unordered.prev_none,
      rw homological_complex.d_to_eq_zero,
      rw homological_complex.d_to_eq_zero,
      swap, exact h,
      swap, exact h,
      swap, exact h,
      simp only [AddCommGroup.zero_apply, C_pre.zero_apply, map_zero], },
    { change _ ≠ _ at h,
      rw option.ne_none_iff_exists at h,
      rcases h with ⟨m, hm⟩,
      rw Cech_Group_wrt_cover_unordered_nth.prev_some,
      swap, exact hm.symm,
      rw homological_complex.d_to_eq,
      swap, exact m.2,
      rw homological_complex.d_to_eq,
      swap, exact m.2,
      simp only [comp_apply, coe_inv_hom_id],
      rw Cech_complex_wrt_cover_unordered.d_to_rel,
      swap, exact hm.symm,
      rw Cech_complex_wrt_cover_unordered.d_to_rel,
      swap, exact hm.symm,
      rw comp_apply,
      rw comp_apply,
      rw ← C.refine_d_eq_d_refine',

      simp only [← comp_apply],
      congr' 1,
      simp only [category.assoc],
      apply whisker_eq,
      apply whisker_eq,

      rw C.refine_eq_to_hom,
      have : _ + 1 = _ := m.2,
      rw this, },
  end }
{ left := C.refine r,
  right := (@@homological_complex.X_next_iso _ _ (Cech_complex_wrt_cover_unordered 𝓕 V)
      (abelian.has_zero_object)
      (rfl : n + 1 = n + 1)).hom ≫
      C.refine r ≫
      (@@homological_complex.X_next_iso _ _ (Cech_complex_wrt_cover_unordered 𝓕 U)
        (abelian.has_zero_object)
        (rfl : n + 1 = n + 1)).inv,
  w' := begin
    simp only [category_theory.functor.id_map, arrow.mk_hom],
    ext f α,
    simp only [comp_apply, homological_complex.d_from_comp_X_next_iso_assoc],
    rw homological_complex.d_from_eq,
    swap 2, exact (rfl : n + 1 = n + 1),
    simp only [← comp_apply],
    congr' 1,
    simp only [← category.assoc],
    apply eq_whisker,
    change C.refine r ≫ d_from_to 𝓕 U _ _ = _,
    rw d_to_succ',
    change _ = d_from_to _ _ _ _ ≫ C.refine r,
    rw d_to_succ',
    rw C.refine_d_eq_d_refine,
  end }
rfl

def Cech_Cohomology_Group_wrt_cover_unordered_nth.refinement_functor (n : ℕ) :
  X.ocᵒᵖ ⥤ Ab.{u} :=
{ obj := λ U, Cech_Cohomology_Group_wrt_cover_unordered_nth 𝓕 U.unop n,
  map := λ U V r, Cech_Cohomology_Group_wrt_cover_unordered_nth.refinement 𝓕 r.unop n,
  map_id' := λ U, begin
    rw [Cech_Cohomology_Group_wrt_cover_unordered_nth.refinement],
    ext f,
    simp only [unop_id, homology.π_map, comp_apply, id_apply],
    congr',
    sorry
  end,
  map_comp' := sorry }

include 𝓕
def Cech_Cohomology_Group_nth (n : ℕ) : Ab :=
limits.colim.obj $ (Cech_Cohomology_Group_wrt_cover_unordered_nth.refinement_functor 𝓕 r n) ⋙ AddCommGroup.ulift_functor.{u u+1}

end

end