import data.cpi.species.congruence

namespace cpi
namespace species

variables {ℍ : Type} {ω : context}
open_locale congruence

/-- Drop a binder from a species, assuming the binder is unused. -/
def drop {Γ} {k} {n} {A : whole ℍ ω k (context.extend n Γ)}
  : level.zero ∉ A → whole ℍ ω k Γ
| free := rename_with A (name.drop_var (λ l, l ∈ A) free)

lemma drop_extend {Γ} {n} {A : species ℍ ω (context.extend n Γ)} (fr : level.zero ∉ A)
  : rename name.extend (drop fr) = A
  := begin
    unfold drop,
    rw [rename_with_compose,
        name.drop_var_compose (λ l, l ∈ A) fr,
        rename_with_id]
  end

namespace normalise
  /-- A version of species.kind, but for atoms. -/
  @[nolint has_inhabited_instance]
  inductive kind' (ℍ : Type) : kind → Type
  | atom       {} : kind' kind.species
  | in_choice  {} : kind' kind.species
  | in_nu      {} : affinity ℍ → kind' kind.species
  | choices    {}: kind' kind.choices

  /-- A more restrictive kind of species. -/
  inductive atom :
    ∀ {sk : kind} (k : kind' ℍ sk) {Γ : context}
    , whole ℍ ω sk Γ → Prop

  | choice_one {Γ} {A : species ℍ ω Γ}
    : atom kind'.atom A
    → atom kind'.in_choice A
  | choice_cons {Γ} {A As : species ℍ ω Γ}
    : atom kind'.atom A
    → atom kind'.in_choice As
    → atom kind'.in_choice (A |ₛ As)

  | nu_one {Γ} (M : affinity ℍ) {A : species ℍ ω (context.extend M.arity Γ)}
    : atom kind'.atom A → level.zero ∈ A
    → atom (kind'.in_nu M) A
  | nu_cons {Γ} (M : affinity ℍ) {A As : species ℍ ω (context.extend M.arity Γ)}
    : atom kind'.atom A → level.zero ∈ A
    → atom (kind'.in_nu M) As
    → atom (kind'.in_nu M) (A |ₛ As)

  | apply {Γ} {n} (D : reference n ω) (as : vector (name Γ) n)
    : atom kind'.atom (apply D as)
  | choice {Γ} {As : choices ℍ ω Γ}
    : atom kind'.choices As
    → atom kind'.atom (Σ# As)
  | restriction {Γ} (M : affinity ℍ) {A : species ℍ ω (context.extend M.arity Γ)}
    : atom (kind'.in_nu M) A
    → atom kind'.atom (ν(M) A)

  | empty {} {Γ} : atom kind'.choices (@whole.empty ℍ ω Γ)
  | cons_nil {Γ} {f} (π : prefix_expr ℍ Γ f) {As : choices ℍ ω Γ}
    : atom kind'.choices As
    → atom kind'.choices (whole.cons π nil As)
  | cons_species {Γ} {f} (π : prefix_expr ℍ Γ f) {A : species ℍ ω (f.apply Γ)} {As : choices ℍ ω Γ}
    : atom kind'.in_choice A
    → atom kind'.choices As
    → atom kind'.choices (whole.cons π A As)

  lemma mk_choice {Γ : context} {f} (π : prefix_expr ℍ Γ f) {As : choices ℍ ω Γ}:
    ∀ (Bs : list (species ℍ ω (f.apply Γ)))
    , (∀ B ∈ Bs, atom kind'.atom B)
    → atom kind'.choices As
    → atom kind'.choices (whole.cons π (parallel.from_list Bs) As)
  | [] _ atomAs := atom.cons_nil π atomAs
  | (B::Bs) atomBs atomAs := begin
    suffices : atom kind'.in_choice (parallel.from_list (B :: Bs)),
      from atom.cons_species π this atomAs,

    induction Bs generalizing B,
    case list.nil { from atom.choice_one (atomBs B (list.mem_cons_self B _)) },
    case list.cons : B' Bs ih {
      refine atom.choice_cons (atomBs B (list.mem_cons_self B _)) _,
      from ih B' (λ x mem, atomBs x (list.mem_cons_of_mem _ mem)),
    }
  end

  /-- parallel.from_list is injective on atoms. -/
  lemma atom_parallel_inj {Γ} :
    ∀ (As Bs : list (species ℍ ω Γ))
    , parallel.from_list As = parallel.from_list Bs
    → (∀ (A : whole ℍ ω kind.species Γ), A ∈ As → atom kind'.atom A)
    → (∀ (A : whole ℍ ω kind.species Γ), A ∈ Bs → atom kind'.atom A)
    → As = Bs
  | [] [] ⟨ _ ⟩ atomA atomB := rfl
  | [] [_] ⟨ _ ⟩ atomA atomB := by cases atomB _ (list.mem_cons_self _ _)
  | [] (B::B'::Bs) eq atomA atomB := by cases eq

  | [_] [] ⟨ _ ⟩ atomA atomB := by cases atomA _ (list.mem_cons_self _ _)
  | [A] [B] ⟨ _ ⟩ atomA atomB := rfl
  | [A] (B::B'::Bs') ⟨ _ ⟩ atomA atomB := by cases atomA _ (list.mem_cons_self _ _)

  | (A::A'::As) [] eq atomA atomB := by cases eq
  | (A::A'::As) [B] ⟨ _ ⟩ atomA atomB := by cases atomB _ (list.mem_cons_self _ _)
  | (A::A'::As) (B::B'::Bs) eq atomA atomB := begin
    simp only [parallel.from_list] at eq,
    have h := atom_parallel_inj (A'::As) (B'::Bs) eq.2
      (λ x mem, atomA x (list.mem_cons_of_mem _ mem))
      (λ x mem, atomB x (list.mem_cons_of_mem _ mem)),
    rw [eq.1, h],
  end

  axiom drop_atom :
    ∀ {Γ} {sk} {k : kind' ℍ sk} {n} {A : whole ℍ ω sk (context.extend n Γ)} (h : level.zero ∉ A)
    , atom k A → atom k (drop h)
end normalise

/-- Splits the parallel component of a restriction into two parts - those
    which can be lifted out of it, and those which cannot. -/
def partition_restriction : ∀ {Γ}
    (M : affinity ℍ)
    (As : list (species ℍ ω (context.extend (M.arity) Γ)))
    (C : species ℍ ω (context.extend (M.arity) Γ))
  , (∀ A ∈ As, normalise.atom normalise.kind'.atom A)
  → Σ' (As' : list (species ℍ ω (context.extend (M.arity) Γ)))
       (Bs : list (species ℍ ω Γ))
    , (ν(M) C |ₛ parallel.from_list As)
    ≈ ((ν(M) C |ₛ parallel.from_list As') |ₛ parallel.from_list Bs)
    ∧ (∀ A ∈ As', normalise.atom normalise.kind'.atom A ∧ level.zero ∈ A)
    ∧ (∀ B ∈ Bs, normalise.atom normalise.kind'.atom B)
| Γ M [] C _ :=
  ⟨ [], [],
    calc  (ν(M) C |ₛ nil)
        ≈ (ν(M) (C |ₛ nil) |ₛ nil)
          : equiv.ξ_restriction M equiv.parallel_nil₂

    ... ≈ ((ν(M) C |ₛ nil) |ₛ nil) : begin
            suffices : (ν(M) (C |ₛ nil) |ₛ rename name.extend nil) ≈ ((ν(M) C |ₛ nil) |ₛ nil),
              simpa only [rename.nil],
            from equiv.ν_parallel' M
          end,
    λ x, false.elim,
    λ x, false.elim ⟩
| Γ M (A :: As) C atomAs :=
  let ⟨ As', Bs', eq, atomAs', atomBs' ⟩ := partition_restriction M As (C |ₛ A)
    (λ x mem, atomAs x (list.mem_cons_of_mem _ mem))
  in
  let eq' :=
    calc  (ν(M) C |ₛ parallel.from_list (A :: As))

          ≈ (ν(M) C |ₛ A |ₛ parallel.from_list As)
            : equiv.ξ_restriction M $ equiv.ξ_parallel₂ $ parallel.from_list_cons A As

      ... ≈ (ν(M) (C |ₛ A) |ₛ parallel.from_list As)
            : equiv.ξ_restriction M $ equiv.parallel_assoc₂

      ... ≈ ((ν(M) (C |ₛ A) |ₛ parallel.from_list As') |ₛ parallel.from_list Bs')
            : eq
  in

  if h : level.zero ∈ A then
    -- The restriction is used within this term - keep it in.
    ⟨ A :: As', Bs',
     calc  (ν(M) C |ₛ parallel.from_list (A :: As))
         ≈ ((ν(M) (C |ₛ A) |ₛ parallel.from_list As') |ₛ parallel.from_list Bs')
           : eq'

     ... ≈ ((ν(M) C |ₛ A |ₛ parallel.from_list As') |ₛ parallel.from_list Bs')
           : equiv.ξ_parallel₁ $ equiv.ξ_restriction M $ equiv.parallel_assoc₁

     ... ≈ ((ν(M) C |ₛ parallel.from_list (A :: As')) |ₛ parallel.from_list Bs')
           : equiv.ξ_parallel₁ $ equiv.ξ_restriction M
           $ equiv.ξ_parallel₂ (symm (parallel.from_list_cons A As')),
    λ x mem, begin
      clear partition_restriction _let_match,
      cases mem, case or.inr { from atomAs' x mem }, subst mem,
      from ⟨ atomAs x (list.mem_cons_self _ _), h ⟩,
    end,
    atomBs' ⟩
  else
    ⟨ As', drop h :: Bs',
      -- The restriction is not within this term - lift it out.
      calc  (ν(M) C |ₛ parallel.from_list (A :: As))
          ≈ ((ν(M) (C |ₛ A) |ₛ parallel.from_list As') |ₛ parallel.from_list Bs')
            : eq'

      ... ≈ ((ν(M) A |ₛ C |ₛ parallel.from_list As') |ₛ parallel.from_list Bs')
            : equiv.ξ_parallel₁ $ equiv.ξ_restriction M
            $ trans (equiv.ξ_parallel₁ equiv.parallel_symm) equiv.parallel_assoc₁

      ... ≈ (((ν(M) C |ₛ parallel.from_list As') |ₛ drop h) |ₛ parallel.from_list Bs')
            : equiv.ξ_parallel₁ begin
                suffices : (ν(M) rename name.extend (drop h) |ₛ C |ₛ parallel.from_list As')
                           ≈ (drop h |ₛ (ν(M) C |ₛ parallel.from_list As')),
                    rw drop_extend h at this, from trans this equiv.parallel_symm,
                from equiv.ν_parallel₁ M
              end

      ... ≈ ((ν(M) C |ₛ parallel.from_list As') |ₛ drop h |ₛ parallel.from_list Bs')
            : equiv.parallel_assoc₁

      ... ≈ ((ν(M) C |ₛ parallel.from_list As') |ₛ parallel.from_list (drop h :: Bs'))
            : equiv.ξ_parallel₂ (symm (parallel.from_list_cons (drop h) Bs')),
      atomAs',
      λ x mem, begin
        clear partition_restriction _let_match,
        cases mem, case or.inr { from atomBs' x mem }, subst mem,
        from normalise.drop_atom h (atomAs A (list.mem_cons_self _ _)),
      end ⟩

/-- Build a restriction from a list of parallel components, or drop it if it is
    empty. -/
def build_restriction {Γ} : ∀ (M : affinity ℍ)
    (As : list (species ℍ ω (context.extend M.arity Γ)))
    (Bs : list (species ℍ ω Γ))
  , (∀ A ∈ As, normalise.atom normalise.kind'.atom A ∧ level.zero ∈ A)
  → (∀ B ∈ Bs, normalise.atom normalise.kind'.atom B)
  → Σ' (Cs : list (species ℍ ω Γ))
    , parallel.from_list ((ν(M) parallel.from_list As) :: Bs)
    ≈ parallel.from_list Cs
    ∧ (∀ C ∈ Cs, normalise.atom normalise.kind'.atom C)
| M [] Bs atomAs atomBs :=
  ⟨ Bs,
    calc  parallel.from_list ((ν(M) nil) :: Bs)
        ≈ ((ν(M) nil) |ₛ parallel.from_list Bs) : parallel.from_list_cons _ Bs
    ... ≈ (nil |ₛ parallel.from_list Bs) : begin
            suffices : equiv (ν(M) rename name.extend nil) nil,
            { simp only [rename.nil] at this, from equiv.ξ_parallel₁ this },
            from equiv.ν_drop₁ M,
          end
    ... ≈ parallel.from_list Bs : equiv.parallel_nil',
    atomBs ⟩
| M (A::As) Bs atomAs atomBs :=
  ⟨ (ν(M) parallel.from_list (A::As)) :: Bs, equiv.rfl,
    λ x mem, begin
      cases mem,
      case or.inr { from atomBs x mem },
      subst mem,
      suffices : normalise.atom (normalise.kind'.in_nu M) (parallel.from_list (A :: As)),
      { from normalise.atom.restriction M this },

      induction As generalizing A,
      case list.nil {
        cases atomAs A (list.mem_cons_self A []) with atomA usesM,
        from normalise.atom.nu_one M atomA usesM,
      },
      case list.cons : A' As ih {
        cases atomAs A (list.mem_cons_self A _) with atomA usesM,
        from normalise.atom.nu_cons M atomA usesM (ih A' (λ x mem, atomAs x (list.mem_cons_of_mem _ mem))),
      }
    end ⟩

/-- Simplifies a restriction as much as possible. This lifts any parallel
    components out of it if possible, and removes the entire thing if possible. -/
def normalise_restriction {Γ} : ∀ (M : affinity ℍ)
    (As : list (species ℍ ω (context.extend (M.arity) Γ)))
  , (∀ A ∈ As, normalise.atom normalise.kind'.atom A)
  → Σ' (Bs : list (species ℍ ω Γ))
    , (ν(M) parallel.from_list As) ≈ parallel.from_list Bs
    ∧ ∀ B ∈ Bs, normalise.atom normalise.kind'.atom B
| M As atomAs :=
  let ⟨ As₁, Bs, eq, atomAs₁, atomBs ⟩ := partition_restriction M As nil atomAs in
  let ⟨ As₂, eq₂, atomAs₂ ⟩ := build_restriction M As₁ Bs atomAs₁ atomBs in
  ⟨ As₂,
    calc  (ν(M) parallel.from_list As)

        ≈ (ν(M) nil |ₛ parallel.from_list As)
          : equiv.ξ_restriction M (symm equiv.parallel_nil')

    ... ≈ ((ν(M) nil |ₛ parallel.from_list As₁) |ₛ parallel.from_list Bs) : eq

    ... ≈ ((ν(M) parallel.from_list As₁) |ₛ parallel.from_list Bs)
          : equiv.ξ_parallel₁ $ equiv.ξ_restriction M equiv.parallel_nil'

    ... ≈ parallel.from_list As₂
        : trans (symm (parallel.from_list_cons _ Bs)) eq₂,
  atomAs₂ ⟩

/-- Wraps species.equiv to work on both species and lists of choices. -/
@[nolint has_inhabited_instance]
def equivalence_of : ∀ {k} {Γ}, whole ℍ ω k Γ → Type
| kind.species Γ A :=
  Σ' (Bs : list (species ℍ ω Γ))
  , A ≈ parallel.from_list Bs
  ∧ ∀ B ∈ Bs, normalise.atom normalise.kind'.atom B
| kind.choices Γ A :=
  Σ' (B : choices ℍ ω Γ)
  , (Σ# A) ≈ (Σ# B)
  ∧ normalise.atom normalise.kind'.choices B

/-- Reduce a term to some equivalent normal form. -/
def normalise_to : ∀ {k} {Γ} (A : whole ℍ ω k Γ), equivalence_of A
| ._ ._ nil := ⟨ [], refl _, λ x, false.elim ⟩
| ._ ._ (apply D as) := ⟨ [apply D as], refl _, λ x mem, begin
    cases mem, case or.inr { cases mem }, subst mem,
    from normalise.atom.apply D as,
  end⟩
| ._ Γ (A |ₛ B) :=
  let ⟨ A', ea, atomA ⟩ := normalise_to A in
  let ⟨ B', eb, atomB ⟩ := normalise_to B in
  ⟨ A' ++ B',
    calc  (A |ₛ B)
        ≈ (parallel.from_list A' |ₛ parallel.from_list B')
          : trans (equiv.ξ_parallel₁ ea) (equiv.ξ_parallel₂ eb)
    ... ≈ parallel.from_list (A' ++ B') : symm (parallel.from_append A' B'),
    λ x mem, or.elim (list.mem_append.mp mem) (atomA x) (atomB x) ⟩
| ._ Γ (ν(M) A) :=
  let ⟨ A', ea, atomA ⟩ := normalise_to A in
  let ⟨ B, eb, atomB ⟩ := normalise_restriction M A' atomA in
  ⟨ B, trans (equiv.ξ_restriction M ea) eb, atomB ⟩
| ._ Γ (Σ# As) :=
  let ⟨ As', eqa, atom ⟩ := normalise_to As in
  ⟨ [ Σ# As' ], eqa, λ x mem, begin
    cases mem, case or.inr { cases mem }, subst mem,
    from normalise.atom.choice atom,
  end ⟩

| ._ Γ whole.empty := ⟨ whole.empty, refl _, normalise.atom.empty ⟩
| ._ Γ (whole.cons π A As) :=
  let ⟨ A', eqa, atomA ⟩ := normalise_to A in
  let ⟨ As', eqas, atomAs ⟩ := normalise_to As in
  ⟨ whole.cons π (parallel.from_list A') As',
    trans (equiv.ξ_choice_here π eqa) (equiv.ξ_choice_there π eqas),
    normalise.mk_choice π A' atomA atomAs ⟩

using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ x, whole.sizeof ℍ ω x.fst x.snd.fst x.snd.snd ) ⟩ ],
  dec_tac := tactic.fst_dec_tac,
}

/-- Reduce a term to some equivalent normal form. -/
def normalise : ∀ {k} {Γ}, whole ℍ ω k Γ → whole ℍ ω k Γ
| kind.species Γ A := parallel.from_list (normalise_to A).fst
| kind.choices Γ A := (normalise_to A).fst

namespace normalise
  /-- Two species are n-equivalent if they normalise to the same term. -/
  def equiv {Γ : context} (A B : species ℍ ω Γ) : Prop := normalise A = normalise B

  instance equiv.decide [decidable_eq ℍ] {Γ : context} : decidable_rel (@equiv ℍ ω Γ)
  | A B := species.whole.decidable_eq ℍ ω kind.species Γ (normalise A) (normalise B)

  lemma equiv.refl {Γ} : reflexive (@equiv ℍ ω Γ)
  | A := rfl

  lemma equiv.symm {Γ} : symmetric (@equiv ℍ ω Γ)
  | A B eql := eq.symm eql

  lemma equiv.trans {Γ} : transitive (@equiv ℍ ω Γ)
  | A B C ab bc := eq.trans ab bc

  /-- If two terms reduce to the same thing, then they are equivalent. -/
  lemma equiv.imp_congruent {Γ} {A B : species ℍ ω Γ} : equiv A B → A ≈ B
  | eq := begin
      unfold equiv normalise at eq,
      have : A ≈ parallel.from_list (normalise_to B).1 := eq ▸ (normalise_to A).2.1,
      from trans this (symm (normalise_to B).2.1),
  end

  lemma equiv.normalise_to {Γ} {A B : species ℍ ω Γ} :
    equiv A B → (normalise_to A).1 = (normalise_to B).1
  | ab := begin
    unfold equiv normalise at ab, clear equiv.normalise_to,
    rcases normalise_to A with ⟨ As, eq, atomA ⟩, assume ab, simp only [] at ⊢ ab, clear eq,
    rcases normalise_to B with ⟨ Bs, eq, atomB ⟩, assume ab, simp only [] at ⊢ ab, clear eq,

    from atom_parallel_inj As Bs ab atomA atomB,
  end

  /-- Equivalence under normalisation. Namely, two species are equivalent if they
      normalise to identical species. -/
  def setoid {Γ} : setoid (species ℍ ω Γ) :=
    ⟨ equiv, ⟨ @equiv.refl ℍ ω Γ, @equiv.symm ℍ ω Γ, @equiv.trans ℍ ω Γ ⟩ ⟩

  localized "attribute [instance] cpi.species.normalise.setoid" in normalise

  instance species'.has_repr [has_repr ℍ] {Γ} : has_repr (species' ℍ ω Γ)
    := ⟨ λ x, quot.lift_on x (λ x, repr (normalise x))
          (λ a b r, by { simp only [], from congr_arg repr r }) ⟩
end normalise

end species
end cpi

#lint-


inductive LazyList (α : Type u)
| nil : LazyList α
| cons (hd : α) (tl : LazyList α) : LazyList α
| delayed (t : Thunk (LazyList α)) : LazyList α

example (as : LazyList α) : True := by
  induction as


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

/-!
# Special shapes for limits in `Type`.

The general shape (co)limits defined in `category_theory.limits.types`
are intended for use through the limits API,
and the actual implementation should mostly be considered "sealed".

In this file, we provide definitions of the "standard" special shapes of limits in `Type`,
giving the expected definitional implementation:
* the terminal object is `punit`
* the binary product of `X` and `Y` is `X × Y`
* the product of a family `f : J → Type` is `Π j, f j`
* the coproduct of a family `f : J → Type` is `Σ j, f j`
* the binary coproduct of `X` and `Y` is the sum type `X ⊕ Y`
* the equalizer of a pair of maps `(g, h)` is the subtype `{x : Y // g x = h x}`
* the coequalizer of a pair of maps `(f, g)` is the quotient of `Y` by `∀ x : Y, f x ~ g x`
* the pullback of `f : X ⟶ Z` and `g : Y ⟶ Z` is the subtype `{ p : X × Y // f p.1 = g p.2 }`
  of the product

Because these are not intended for use with the `has_limit` API,
we instead construct terms of `limit_data`.

As an example, when setting up the monoidal category structure on `Type`
we use the `types_has_terminal` and `types_has_binary_products` instances.
-/

universes u

open category_theory
open category_theory.limits

namespace category_theory.limits.types

/-- A restatement of `types.lift_π_apply` that uses `pi.π` and `pi.lift`. -/
@[simp]
lemma pi_lift_π_apply
  {β : Type u} (f : β → Type u) {P : Type u} (s : Π b, P ⟶ f b) (b : β) (x : P) :
  (pi.π f b : (∏ f) → f b) (@pi.lift β _ _ f _ P s x) = s b x :=
congr_fun (limit.lift_π (fan.mk P s) b) x

/-- A restatement of `types.map_π_apply` that uses `pi.π` and `pi.map`. -/
@[simp]
lemma pi_map_π_apply {β : Type u} {f g : β → Type u} (α : Π j, f j ⟶ g j) (b : β) (x) :
  (pi.π g b : (∏ g) → g b) (pi.map α x) = α b ((pi.π f b : (∏ f) → f b) x) :=
limit.map_π_apply _ _ _

/-- The category of types has `punit` as a terminal object. -/
def terminal_limit_cone : limits.limit_cone (functor.empty (Type u)) :=
{ cone :=
  { X := punit,
    π := by tidy, },
  is_limit := by tidy, }

/-- The category of types has `pempty` as an initial object. -/
def initial_limit_cone : limits.colimit_cocone (functor.empty (Type u)) :=
{ cocone :=
  { X := pempty,
    ι := by tidy, },
  is_colimit := by tidy, }

open category_theory.limits.walking_pair

/-- The product type `X × Y` forms a cone for the binary product of `X` and `Y`. -/
-- We manually generate the other projection lemmas since the simp-normal form for the legs is
-- otherwise not created correctly.
@[simps X]
def binary_product_cone (X Y : Type u) : binary_fan X Y :=
binary_fan.mk prod.fst prod.snd

@[simp]
lemma binary_product_cone_fst (X Y : Type u) :
  (binary_product_cone X Y).fst = prod.fst :=
rfl
@[simp]
lemma binary_product_cone_snd (X Y : Type u) :
  (binary_product_cone X Y).snd = prod.snd :=
rfl

/-- The product type `X × Y` is a binary product for `X` and `Y`. -/
@[simps]
def binary_product_limit (X Y : Type u) : is_limit (binary_product_cone X Y) :=
{ lift := λ (s : binary_fan X Y) x, (s.fst x, s.snd x),
  fac' := λ s j, walking_pair.cases_on j rfl rfl,
  uniq' := λ s m w, funext $ λ x, prod.ext (congr_fun (w left) x) (congr_fun (w right) x) }

/--
The category of types has `X × Y`, the usual cartesian product,
as the binary product of `X` and `Y`.
-/
@[simps]
def binary_product_limit_cone (X Y : Type u) : limits.limit_cone (pair X Y) :=
⟨_, binary_product_limit X Y⟩

/-- The functor which sends `X, Y` to the product type `X × Y`. -/
-- We add the option `type_md` to tell `@[simps]` to not treat homomorphisms `X ⟶ Y` in `Type*` as
-- a function type
@[simps {type_md := reducible}]
def binary_product_functor : Type u ⥤ Type u ⥤ Type u :=
{ obj := λ X,
  { obj := λ Y, X × Y,
    map := λ Y₁ Y₂ f, (binary_product_limit X Y₂).lift (binary_fan.mk prod.fst (prod.snd ≫ f)) },
  map := λ X₁ X₂ f,
  { app := λ Y, (binary_product_limit X₂ Y).lift (binary_fan.mk (prod.fst ≫ f) prod.snd) } }

/--
The product functor given by the instance `has_binary_products (Type u)` is isomorphic to the
explicit binary product functor given by the product type.
-/
noncomputable def binary_product_iso_prod : binary_product_functor ≅ (prod.functor : Type u ⥤ _) :=
begin
  apply nat_iso.of_components (λ X, _) _,
  { apply nat_iso.of_components (λ Y, _) _,
    { exact ((limit.is_limit _).cone_point_unique_up_to_iso (binary_product_limit X Y)).symm },
    { intros Y₁ Y₂ f,
      ext1;
      simp } },
  { intros X₁ X₂ g,
    ext : 3;
    simp }
end

/-- The sum type `X ⊕ Y` forms a cocone for the binary coproduct of `X` and `Y`. -/
@[simps]
def binary_coproduct_cocone (X Y : Type u) : cocone (pair X Y) :=
binary_cofan.mk sum.inl sum.inr

/-- The sum type `X ⊕ Y` is a binary coproduct for `X` and `Y`. -/
@[simps]
def binary_coproduct_colimit (X Y : Type u) : is_colimit (binary_coproduct_cocone X Y) :=
{ desc := λ (s : binary_cofan X Y), sum.elim s.inl s.inr,
  fac' := λ s j, walking_pair.cases_on j rfl rfl,
  uniq' := λ s m w, funext $ λ x, sum.cases_on x (congr_fun (w left)) (congr_fun (w right)) }

/--
The category of types has `X ⊕ Y`,
as the binary coproduct of `X` and `Y`.
-/
def binary_coproduct_colimit_cocone (X Y : Type u) : limits.colimit_cocone (pair X Y) :=
⟨_, binary_coproduct_colimit X Y⟩

/--
The category of types has `Π j, f j` as the product of a type family `f : J → Type`.
-/
def product_limit_cone {J : Type u} (F : J → Type u) : limits.limit_cone (discrete.functor F) :=
{ cone :=
  { X := Π j, F j,
    π := { app := λ j f, f j }, },
  is_limit :=
  { lift := λ s x j, s.π.app j x,
    uniq' := λ s m w, funext $ λ x, funext $ λ j, (congr_fun (w j) x : _) } }

/--
The category of types has `Σ j, f j` as the coproduct of a type family `f : J → Type`.
-/
def coproduct_colimit_cocone {J : Type u} (F : J → Type u) :
  limits.colimit_cocone (discrete.functor F) :=
{ cocone :=
  { X := Σ j, F j,
    ι :=
    { app := λ j x, ⟨j, x⟩ }, },
  is_colimit :=
  { desc := λ s x, s.ι.app x.1 x.2,
    uniq' := λ s m w,
    begin
      ext ⟨j, x⟩,
      have := congr_fun (w j) x,
      exact this,
    end }, }

section fork
variables {X Y Z : Type u} (f : X ⟶ Y) {g h : Y ⟶ Z} (w : f ≫ g = f ≫ h)

/--
Show the given fork in `Type u` is an equalizer given that any element in the "difference kernel"
comes from `X`.
The converse of `unique_of_type_equalizer`.
-/
noncomputable def type_equalizer_of_unique (t : ∀ (y : Y), g y = h y → ∃! (x : X), f x = y) :
  is_limit (fork.of_ι _ w) :=
fork.is_limit.mk' _ $ λ s,
begin
  refine ⟨λ i, _, _, _⟩,
  { apply classical.some (t (s.ι i) _),
    apply congr_fun s.condition i },
  { ext i,
    apply (classical.some_spec (t (s.ι i) _)).1 },
  { intros m hm,
    ext i,
    apply (classical.some_spec (t (s.ι i) _)).2,
    apply congr_fun hm i },
end

/-- The converse of `type_equalizer_of_unique`. -/
lemma unique_of_type_equalizer (t : is_limit (fork.of_ι _ w)) (y : Y) (hy : g y = h y) :
  ∃! (x : X), f x = y :=
begin
  let y' : punit ⟶ Y := λ _, y,
  have hy' : y' ≫ g = y' ≫ h := funext (λ _, hy),
  refine ⟨(fork.is_limit.lift' t _ hy').1 ⟨⟩, congr_fun (fork.is_limit.lift' t y' _).2 ⟨⟩, _⟩,
  intros x' hx',
  suffices : (λ (_ : punit), x') = (fork.is_limit.lift' t y' hy').1,
    rw ← this,
  apply fork.is_limit.hom_ext t,
  ext ⟨⟩,
  apply hx'.trans (congr_fun (fork.is_limit.lift' t _ hy').2 ⟨⟩).symm,
end

lemma type_equalizer_iff_unique :
  nonempty (is_limit (fork.of_ι _ w)) ↔ (∀ (y : Y), g y = h y → ∃! (x : X), f x = y) :=
⟨λ i, unique_of_type_equalizer _ _ (classical.choice i), λ k, ⟨type_equalizer_of_unique f w k⟩⟩

/-- Show that the subtype `{x : Y // g x = h x}` is an equalizer for the pair `(g,h)`. -/
def equalizer_limit : limits.limit_cone (parallel_pair g h) :=
{ cone := fork.of_ι (subtype.val : {x : Y // g x = h x} → Y) (funext subtype.prop),
  is_limit := fork.is_limit.mk' _ $ λ s,
    ⟨λ i, ⟨s.ι i, by apply congr_fun s.condition i⟩,
     rfl,
     λ m hm, funext $ λ x, subtype.ext (congr_fun hm x)⟩ }

end fork

section cofork
variables {X Y Z : Type u} (f g : X ⟶ Y)

/-- (Implementation) The relation to be quotiented to obtain the coequalizer. -/
inductive coequalizer_rel : Y → Y → Prop
| rel (x : X) : coequalizer_rel (f x) (g x)

/--
Show that the quotient by the relation generated by `f(x) ~ g(x)`
is a coequalizer for the pair `(f, g)`.
-/
def coequalizer_colimit : limits.colimit_cocone (parallel_pair f g) :=
{ cocone := cofork.of_π (quot.mk (coequalizer_rel f g))
    (funext (λ x, quot.sound (coequalizer_rel.rel x))),
  is_colimit := cofork.is_colimit.mk' _ $ λ s,
    ⟨ quot.lift s.π (λ a b (h : coequalizer_rel f g a b),
        by { cases h, exact congr_fun s.condition h_1 }),
      rfl,
      λ m hm, funext $ λ x, quot.induction_on x (congr_fun hm : _) ⟩ }

end cofork

section pullback
open category_theory.limits.walking_pair
open category_theory.limits.walking_cospan
open category_theory.limits.walking_cospan.hom

variables {W X Y Z : Type u}
variables (f : X ⟶ Z) (g : Y ⟶ Z)

/--
The usual explicit pullback in the category of types, as a subtype of the product.
The full `limit_cone` data is bundled as `pullback_limit_cone f g`.
-/
@[nolint has_inhabited_instance]
abbreviation pullback_obj : Type u := { p : X × Y // f p.1 = g p.2 }

-- `pullback_obj f g` comes with a coercion to the product type `X × Y`.
example (p : pullback_obj f g) : X × Y := p

/--
The explicit pullback cone on `pullback_obj f g`.
This is bundled with the `is_limit` data as `pullback_limit_cone f g`.
-/
abbreviation pullback_cone : limits.pullback_cone f g :=
pullback_cone.mk (λ p : pullback_obj f g, p.1.1) (λ p, p.1.2) (funext (λ p, p.2))

/--
The explicit pullback in the category of types, bundled up as a `limit_cone`
for given `f` and `g`.
-/
@[simps]
def pullback_limit_cone (f : X ⟶ Z) (g : Y ⟶ Z) : limits.limit_cone (cospan f g) :=
{ cone := pullback_cone f g,
  is_limit := pullback_cone.is_limit_aux _
    (λ s x, ⟨⟨s.fst x, s.snd x⟩, congr_fun s.condition x⟩)
    (by tidy)
    (by tidy)
    (λ s m w, funext $ λ x, subtype.ext $
     prod.ext (congr_fun (w walking_cospan.left) x)
              (congr_fun (w walking_cospan.right) x)) }

/--
The pullback cone given by the instance `has_pullbacks (Type u)` is isomorphic to the
explicit pullback cone given by `pullback_limit_cone`.
-/
noncomputable def pullback_cone_iso_pullback : limit.cone (cospan f g) ≅ pullback_cone f g :=
(limit.is_limit _).unique_up_to_iso (pullback_limit_cone f g).is_limit

/--
The pullback given by the instance `has_pullbacks (Type u)` is isomorphic to the
explicit pullback object given by `pullback_limit_obj`.
-/
noncomputable def pullback_iso_pullback : pullback f g ≅ pullback_obj f g :=
(cones.forget _).map_iso $ pullback_cone_iso_pullback f g

@[simp] lemma pullback_iso_pullback_hom_fst (p : pullback f g) :
  ((pullback_iso_pullback f g).hom p : X × Y).fst = (pullback.fst : _ ⟶ X) p :=
congr_fun ((pullback_cone_iso_pullback f g).hom.w left) p

@[simp] lemma pullback_iso_pullback_hom_snd (p : pullback f g) :
  ((pullback_iso_pullback f g).hom p : X × Y).snd = (pullback.snd : _ ⟶ Y) p :=
congr_fun ((pullback_cone_iso_pullback f g).hom.w right) p

@[simp] lemma pullback_iso_pullback_inv_fst :
  (pullback_iso_pullback f g).inv ≫ pullback.fst = (λ p, (p : X × Y).fst) :=
(pullback_cone_iso_pullback f g).inv.w left

@[simp] lemma pullback_iso_pullback_inv_snd :
  (pullback_iso_pullback f g).inv ≫ pullback.snd = (λ p, (p : X × Y).snd) :=
(pullback_cone_iso_pullback f g).inv.w right

end pullback

end category_theory.limits.types


import tactic.core
import tactic.tidy
import tactic.show_term

def ptree : Type := sorry

class pencodable (α : Type*) :=
(encode : α → ptree)
(decode : ptree → α)
/- (other prop's omitted) -/

section
variables {α β γ δ ε : Type*} [pencodable α] [pencodable β] [pencodable γ] [pencodable δ] [pencodable ε]

instance : pencodable (α × β) := sorry

def polytime_fun (f : α → β) : Prop := sorry

lemma polytime_fun.id : polytime_fun (@id α) := sorry
lemma polytime_fun.const (y : β) : polytime_fun (λ (_ : α), y) := sorry
lemma polytime_fun.comp {f : β → γ} {g : α → β} : polytime_fun f → polytime_fun g → polytime_fun (f ∘ g) := sorry
lemma polytime_fun.pair {f : α → β} {g : α → γ} : polytime_fun f → polytime_fun g → polytime_fun (λ x, (f x, g x)) := sorry
lemma polytime_fun.fst : polytime_fun (@prod.fst α β) := sorry
lemma polytime_fun.snd : polytime_fun (@prod.snd α β) := sorry

def polytime_fun₂ (f : α → β → γ) : Prop := polytime_fun (function.uncurry f)

def polytime_fun₃ (f : α → β → γ → δ) : Prop :=
polytime_fun (λ x : α × β × γ, f x.1 x.2.1 x.2.2)

lemma polytime_fun.comp₂ {f : α → β → γ} {g : δ → α} {h : δ → β}
  (hf : polytime_fun₂ f) (hg : polytime_fun g) (hh : polytime_fun h) :
  polytime_fun (λ x, f (g x) (h x)) :=
polytime_fun.comp hf (polytime_fun.pair hg hh)

lemma polytime_fun.comp₃ {f : α → β → γ → δ} {g₁ : ε → α} {g₂ : ε → β} {g₃ : ε -> γ}
  (hf : polytime_fun₃ f) (hg₁ : polytime_fun g₁) (hg₂ : polytime_fun g₂) (hg₃ : polytime_fun g₃) :
  polytime_fun (λ x, f (g₁ x) (g₂ x) (g₃ x)) :=
polytime_fun.comp hf (polytime_fun.pair hg₁ (polytime_fun.pair hg₂ hg₃))

end

section

@[user_attribute]
meta def polyfun : user_attribute :=
{ name := `polyfun,
  descr := "lemmas usable to prove polynomial time" }

attribute [polyfun]
  polytime_fun.id
  polytime_fun.const
  polytime_fun.pair
  polytime_fun.fst
  polytime_fun.snd

@[polyfun]
lemma polytime_fun.id' {α} [pencodable α] : polytime_fun (λ x : α, x) := polytime_fun.id

namespace tactic

meta def polytime_fun_lemmas : list name :=
[``polytime_fun, ``polytime_fun₂, ``polytime_fun₃]

meta def polytime_fun_comp_lemmas : list name :=
[``polytime_fun.comp, ``polytime_fun.comp₂, ``polytime_fun.comp₃]

meta def unfold_polytime (md : transparency) : tactic unit :=
do dunfold_target (``function.uncurry :: polytime_fun_lemmas.tail),
   try dsimp_target

-- In order to help resolve polytime_fun of propositions (which are converted to bool's)
meta def simp_to_bool : tactic unit :=
`[simp only [bool.to_bool_not, bool.to_bool_and, bool.to_bool_or, bool.to_bool_coe]]

/--
 Tries to infer if the given expression is a real argument by testing
 if it has a `pencodable` instance on it. TODO: make faster. Does this need
 to do a full instance search?
-/
meta def is_polycodable (e : expr) : tactic bool :=
(do
   e' ← infer_type e,
   cache ← mk_instance_cache e',
   (cache', s) ← instance_cache.get cache ``pencodable,
   return tt) <|> (return ff)

/-- Given an expression of the form `polytime_fun (f x₁ x₂ ... xₙ)`, tries to infer `n`,
   the number of arguments. -/
meta def get_num_params : tactic ℕ :=
do `(polytime_fun %%s) ← target,
    guard s.is_lambda,
    mv ← mk_meta_var s.binding_domain,
    e ←  instantiate_mvars (s.instantiate_lambdas [mv]),
    f ← mfilter is_polycodable e.get_app_args,
    return f.length

/--
  Given a goal of the form `⊢ polytime_fun (λ x, f (g₁ x) (g₂ x) ... (gₙ x))`
  tries to apply the corresponding composition rule to produce
  `⊢ polytime_funₙ f`, `⊢ polytime_fun g₁`, ..., `⊢ polytime_fun gₙ`
-/
meta def apply_polyfun.comp (md : transparency) : tactic ℕ :=
do fail_if_success `[exact polytime_fun.const _],
   fail_if_success (to_expr ``(polytime_fun.pair) >>= λ e, apply e {md := md}),
   old_goal ← target,
   n ← get_num_params, guard (0 < n ∧ n ≤ polytime_fun_lemmas.length),
   s ← resolve_name (polytime_fun_comp_lemmas.inth (n-1)),
   s' ← to_expr s,
   apply s' {md := md},
   try `[ any_goals { apply_instance, } ], -- why is this necessary??
   /-
    - If the target is md-definitionally equal to what it used to be, up to
    - unfolding of polytime_fun₂, polytime_fun₃ etc., then no real progress has been made
    - EXCEPT if the goal can be immediately solved by apply_rules.
    - This last check is important because if we have something like
    - `⊢ polytime_fun (λ x : α × β, f x.1 x.2)`, and `polytime_fun₂ f` is a `polyfun` lemma,
    - even though this goal is definitionally equal to `polytime_fun₂ f`, `apply_rules` would not
    - find it at the `reducible` setting. Therefore, this will get reduced to
    - `⊢ polytime_fun₂ f`, `⊢ polytime_fun (λ x : α × β, x.1)`, and `⊢ polytime_fun (λ x : α × β, x.2)`.
    - It looks like no progress has been made, but because we can immediately solve `polytime_fun₂ f`, we continue to advance.

    - We need to check for definitional equality up to `unfold_polytime` because otherwise we get caught in a loop
    - where it looks like we make progress even though we don't. If we have the goal `⊢ polytime_fun (λ x, f x.1 x.2)`,
    - this gets reduced to `⊢ polytime_fun₂ f`, ... as before. If `f` is not actually polytime, it seems like we make progress
    - if we do not unfold `polytime_fun₂`, but `polytime_fun₂` will just be unfolded back to `polytime_fun (λ x, f x.1 x.2)` before
    - `apply_polyfun.comp` is called, causing a loop.

    - This check replaces the check to exclude `id` of the `continuity` tactic.
   -/
   (fail_if_success (unfold_polytime md >> target >>= λ t, unify t old_goal md)) <|>
    focus1 (apply_rules [] [``polyfun] 50 { md := md } >> done),
  return (n-1)

meta def polyfun_tactics (md : transparency := reducible) : list (tactic string) :=
[
  apply_rules [] [``polyfun] 50 { md := md }
                        >> pure "apply_rules with polyfun",
  unfold_polytime md >> pure "dunfold_target polytime_fun_lemmas.tail",
  simp_to_bool >> pure "simp only [bool.to_bool_not, bool.to_bool_and, bool.to_bool_or]",
  apply_polyfun.comp md >>= λ n, pure ("apply " ++ (to_string $ polytime_fun_comp_lemmas.inth (n-1)))
]

namespace interactive
setup_tactic_parser

meta def polyfun
  (bang : parse $ optional (tk "!")) (trace : parse $ optional (tk "?")) (cfg : tidy.cfg := {}) :
  tactic unit :=
let md              := if bang.is_some then semireducible else reducible,
    polyfun_core := tactic.tidy { tactics := polyfun_tactics md, ..cfg },
    trace_fn        := if trace.is_some then show_term else id in
trace_fn polyfun_core

end interactive

end tactic

end

section
instance : pencodable ℕ := sorry

@[polyfun]
lemma polytime_fun.nat_add : polytime_fun₂ ((+) : ℕ → ℕ → ℕ) := sorry

example : polytime_fun₃ (λ (a b c : ℕ), a + b + c) := by polyfun
example : polytime_fun (λ (n : ℕ), (n, n + n, n + n + n)) := by polyfun

end


/-
Copyright (c) 2020 Thomas Browning and Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning and Patrick Lutz
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.field_theory.intermediate_field
import Mathlib.field_theory.splitting_field
import Mathlib.field_theory.separable
import Mathlib.PostPort

universes u_1 u_2 u_3 l

namespace Mathlib

/-!
# Adjoining Elements to Fields

In this file we introduce the notion of adjoining elements to fields.
This isn't quite the same as adjoining elements to rings.
For example, `algebra.adjoin K {x}` might not include `x⁻¹`.

## Main results

- `adjoin_adjoin_left`: adjoining S and then T is the same as adjoining `S ∪ T`.
- `bot_eq_top_of_dim_adjoin_eq_one`: if `F⟮x⟯` has dimension `1` over `F` for every `x`
  in `E` then `F = E`

## Notation

 - `F⟮α⟯`: adjoin a single element `α` to `F`.
-/

namespace intermediate_field

/-- `adjoin F S` extends a field `F` by adjoining a set `S ⊆ E`. -/
def adjoin (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] (S : set E) :
    intermediate_field F E :=
  mk (subfield.carrier (subfield.closure (set.range ⇑(algebra_map F E) ∪ S))) sorry sorry sorry
    sorry sorry sorry sorry

@[simp] theorem adjoin_le_iff {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {S : set E} {T : intermediate_field F E} : adjoin F S ≤ T ↔ S ≤ ↑T :=
  sorry

theorem gc {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    galois_connection (adjoin F) coe :=
  fun (_x : set E) (_x_1 : intermediate_field F E) => adjoin_le_iff

/-- Galois insertion between `adjoin` and `coe`. -/
def gi {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    galois_insertion (adjoin F) coe :=
  galois_insertion.mk (fun (S : set E) (_x : ↑(adjoin F S) ≤ S) => adjoin F S) gc sorry sorry

protected instance complete_lattice {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] : complete_lattice (intermediate_field F E) :=
  galois_insertion.lift_complete_lattice gi

protected instance inhabited {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    Inhabited (intermediate_field F E) :=
  { default := ⊤ }

theorem mem_bot {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] {x : E} :
    x ∈ ⊥ ↔ x ∈ set.range ⇑(algebra_map F E) :=
  sorry

theorem mem_top {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] {x : E} : x ∈ ⊤ :=
  subfield.subset_closure (Or.inr trivial)

@[simp] theorem bot_to_subalgebra {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    to_subalgebra ⊥ = ⊥ :=
  sorry

@[simp] theorem top_to_subalgebra {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    to_subalgebra ⊤ = ⊤ :=
  sorry

/--  Construct an algebra isomorphism from an equality of subalgebras -/
def subalgebra.equiv_of_eq {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {X : subalgebra F E} {Y : subalgebra F E} (h : X = Y) : alg_equiv F ↥X ↥Y :=
  alg_equiv.mk (fun (x : ↥X) => { val := ↑x, property := sorry })
    (fun (x : ↥Y) => { val := ↑x, property := sorry }) sorry sorry sorry sorry sorry

/-- The bottom intermediate_field is isomorphic to the field. -/
def bot_equiv {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    alg_equiv F (↥⊥) F :=
  alg_equiv.trans (subalgebra.equiv_of_eq bot_to_subalgebra) (algebra.bot_equiv F E)

@[simp] theorem bot_equiv_def {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (x : F) : coe_fn bot_equiv (coe_fn (algebra_map F ↥⊥) x) = x :=
  alg_equiv.commutes bot_equiv x

protected instance algebra_over_bot {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] : algebra (↥⊥) F :=
  ring_hom.to_algebra (alg_hom.to_ring_hom (alg_equiv.to_alg_hom bot_equiv))

protected instance is_scalar_tower_over_bot {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] : is_scalar_tower (↥⊥) F E :=
  is_scalar_tower.of_algebra_map_eq
    fun (x : ↥⊥) =>
      let ϕ : alg_hom F F ↥⊥ := algebra.of_id F ↥⊥;
      let ψ : alg_equiv F F ↥⊥ :=
        alg_equiv.of_bijective ϕ (alg_equiv.bijective (alg_equiv.symm (algebra.bot_equiv F E)));
      id
        (eq.mpr
          (id
            (Eq._oldrec
              (Eq.refl
                (↑x =
                  ↑(coe_fn ψ
                      (coe_fn (alg_equiv.symm ψ)
                        { val := ↑x,
                          property := subalgebra.equiv_of_eq._proof_1 bot_to_subalgebra x }))))
              (alg_equiv.apply_symm_apply ψ
                { val := ↑x, property := subalgebra.equiv_of_eq._proof_1 bot_to_subalgebra x })))
          (Eq.refl ↑x))

/-- The top intermediate_field is isomorphic to the field. -/
def top_equiv {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    alg_equiv F (↥⊤) E :=
  alg_equiv.trans (subalgebra.equiv_of_eq top_to_subalgebra) algebra.top_equiv

@[simp] theorem top_equiv_def {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (x : ↥⊤) : coe_fn top_equiv x = ↑x :=
  sorry

@[simp] theorem coe_bot_eq_self {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (K : intermediate_field F E) : ↑⊥ = K :=
  sorry

@[simp] theorem coe_top_eq_top {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (K : intermediate_field F E) : ↑⊤ = ⊤ :=
  iff.mpr intermediate_field.ext'_iff
    (iff.mpr set.ext_iff fun (_x : E) => iff_of_true mem_top mem_top)

theorem adjoin_eq_range_algebra_map_adjoin (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] (S : set E) : ↑(adjoin F S) = set.range ⇑(algebra_map (↥(adjoin F S)) E) :=
  Eq.symm subtype.range_coe

theorem adjoin.algebra_map_mem (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) (x : F) : coe_fn (algebra_map F E) x ∈ adjoin F S :=
  algebra_map_mem (adjoin F S) x

theorem adjoin.range_algebra_map_subset (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] (S : set E) : set.range ⇑(algebra_map F E) ⊆ ↑(adjoin F S) :=
  sorry

protected instance adjoin.field_coe (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) : has_coe_t F ↥(adjoin F S) :=
  has_coe_t.mk
    fun (x : F) => { val := coe_fn (algebra_map F E) x, property := adjoin.algebra_map_mem F S x }

theorem subset_adjoin (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] (S : set E) :
    S ⊆ ↑(adjoin F S) :=
  fun (x : E) (hx : x ∈ S) => subfield.subset_closure (Or.inr hx)

protected instance adjoin.set_coe (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) : has_coe_t ↥S ↥(adjoin F S) :=
  has_coe_t.mk fun (x : ↥S) => { val := ↑x, property := sorry }

theorem adjoin.mono (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] (S : set E)
    (T : set E) (h : S ⊆ T) : adjoin F S ≤ adjoin F T :=
  galois_connection.monotone_l gc h

theorem adjoin_contains_field_as_subfield {E : Type u_2} [field E] (S : set E) (F : subfield E) :
    ↑F ⊆ ↑(adjoin (↥F) S) :=
  fun (x : E) (hx : x ∈ ↑F) => adjoin.algebra_map_mem (↥F) S { val := x, property := hx }

theorem subset_adjoin_of_subset_left {E : Type u_2} [field E] (S : set E) {F : subfield E}
    {T : set E} (HT : T ⊆ ↑F) : T ⊆ ↑(adjoin (↥F) S) :=
  fun (x : E) (hx : x ∈ T) => algebra_map_mem (adjoin (↥F) S) { val := x, property := HT hx }

theorem subset_adjoin_of_subset_right (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] (S : set E) {T : set E} (H : T ⊆ S) : T ⊆ ↑(adjoin F S) :=
  fun (x : E) (hx : x ∈ T) => subset_adjoin F S (H hx)

@[simp] theorem adjoin_empty (F : Type u_1) (E : Type u_2) [field F] [field E] [algebra F E] :
    adjoin F ∅ = ⊥ :=
  iff.mpr eq_bot_iff (iff.mpr adjoin_le_iff (set.empty_subset ↑⊥))

/-- If `K` is a field with `F ⊆ K` and `S ⊆ K` then `adjoin F S ≤ K`. -/
theorem adjoin_le_subfield (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) {K : subfield E} (HF : set.range ⇑(algebra_map F E) ⊆ ↑K) (HS : S ⊆ ↑K) :
    to_subfield (adjoin F S) ≤ K :=
  iff.mpr subfield.closure_le
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (set.range ⇑(algebra_map F E) ∪ S ⊆ ↑K))
          (propext set.union_subset_iff)))
      { left := HF, right := HS })

theorem adjoin_subset_adjoin_iff (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    {F' : Type u_3} [field F'] [algebra F' E] {S : set E} {S' : set E} :
    ↑(adjoin F S) ⊆ ↑(adjoin F' S') ↔
        set.range ⇑(algebra_map F E) ⊆ ↑(adjoin F' S') ∧ S ⊆ ↑(adjoin F' S') :=
  sorry

/-- `F[S][T] = F[S ∪ T]` -/
theorem adjoin_adjoin_left (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) (T : set E) : ↑(adjoin (↥(adjoin F S)) T) = adjoin F (S ∪ T) :=
  sorry

@[simp] theorem adjoin_insert_adjoin (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) (x : E) : adjoin F (insert x ↑(adjoin F S)) = adjoin F (insert x S) :=
  sorry

/-- `F[S][T] = F[T][S]` -/
theorem adjoin_adjoin_comm (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) (T : set E) : ↑(adjoin (↥(adjoin F S)) T) = ↑(adjoin (↥(adjoin F T)) S) :=
  sorry

theorem adjoin_map (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] (S : set E)
    {E' : Type u_3} [field E'] [algebra F E'] (f : alg_hom F E E') :
    map (adjoin F S) f = adjoin F (⇑f '' S) :=
  sorry

theorem algebra_adjoin_le_adjoin (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) : algebra.adjoin F S ≤ to_subalgebra (adjoin F S) :=
  algebra.adjoin_le (subset_adjoin F S)

theorem adjoin_eq_algebra_adjoin (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (S : set E) (inv_mem : ∀ (x : E), x ∈ algebra.adjoin F S → x⁻¹ ∈ algebra.adjoin F S) :
    to_subalgebra (adjoin F S) = algebra.adjoin F S :=
  sorry

theorem eq_adjoin_of_eq_algebra_adjoin (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] (S : set E) (K : intermediate_field F E)
    (h : to_subalgebra K = algebra.adjoin F S) : K = adjoin F S :=
  sorry

theorem adjoin_induction (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] {s : set E}
    {p : E → Prop} {x : E} (h : x ∈ adjoin F s) (Hs : ∀ (x : E), x ∈ s → p x)
    (Hmap : ∀ (x : F), p (coe_fn (algebra_map F E) x)) (Hadd : ∀ (x y : E), p x → p y → p (x + y))
    (Hneg : ∀ (x : E), p x → p (-x)) (Hinv : ∀ (x : E), p x → p (x⁻¹))
    (Hmul : ∀ (x y : E), p x → p y → p (x * y)) : p x :=
  sorry

/--
Variation on `set.insert` to enable good notation for adjoining elements to fields.
Used to preferentially use `singleton` rather than `insert` when adjoining one element.
-/
--this definition of notation is courtesy of Kyle Miller on zulip

class insert {α : Type u_3} (s : set α) where
  insert : α → set α

protected instance insert_empty {α : Type u_1} : insert ∅ := insert.mk fun (x : α) => singleton x

protected instance insert_nonempty {α : Type u_1} (s : set α) : insert s :=
  insert.mk fun (x : α) => set.insert x s

theorem mem_adjoin_simple_self (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (α : E) : α ∈ adjoin F (insert.insert ∅ α) :=
  subset_adjoin F (singleton α) (set.mem_singleton α)

/-- generator of `F⟮α⟯` -/
def adjoin_simple.gen (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] (α : E) :
    ↥(adjoin F (insert.insert ∅ α)) :=
  { val := α, property := mem_adjoin_simple_self F α }

@[simp] theorem adjoin_simple.algebra_map_gen (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] (α : E) :
    coe_fn (algebra_map (↥(adjoin F (insert.insert ∅ α))) E) (adjoin_simple.gen F α) = α :=
  rfl

theorem adjoin_simple_adjoin_simple (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    (α : E) (β : E) :
    ↑(adjoin (↥(adjoin F (insert.insert ∅ α))) (insert.insert ∅ β)) =
        adjoin F (insert.insert (insert.insert ∅ β) α) :=
  adjoin_adjoin_left F (insert.insert ∅ α) (insert.insert ∅ β)

theorem adjoin_simple_comm (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] (α : E)
    (β : E) :
    ↑(adjoin (↥(adjoin F (insert.insert ∅ α))) (insert.insert ∅ β)) =
        ↑(adjoin (↥(adjoin F (insert.insert ∅ β))) (insert.insert ∅ α)) :=
  adjoin_adjoin_comm F (insert.insert ∅ α) (insert.insert ∅ β)

-- TODO: develop the API for `subalgebra.is_field_of_algebraic` so it can be used here

theorem adjoin_simple_to_subalgebra_of_integral (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] (α : E) (hα : is_integral F α) :
    to_subalgebra (adjoin F (insert.insert ∅ α)) = algebra.adjoin F (singleton α) :=
  sorry

@[simp] theorem adjoin_eq_bot_iff {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {S : set E} : adjoin F S = ⊥ ↔ S ⊆ ↑⊥ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (adjoin F S = ⊥ ↔ S ⊆ ↑⊥)) (propext eq_bot_iff)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (adjoin F S ≤ ⊥ ↔ S ⊆ ↑⊥)) (propext adjoin_le_iff)))
      (iff.refl (S ≤ ↑⊥)))

@[simp] theorem adjoin_simple_eq_bot_iff {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] {α : E} : adjoin F (insert.insert ∅ α) = ⊥ ↔ α ∈ ⊥ :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (adjoin F (insert.insert ∅ α) = ⊥ ↔ α ∈ ⊥)) (propext adjoin_eq_bot_iff)))
    set.singleton_subset_iff

@[simp] theorem adjoin_zero {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    adjoin F (insert.insert ∅ 0) = ⊥ :=
  iff.mpr adjoin_simple_eq_bot_iff (zero_mem ⊥)

@[simp] theorem adjoin_one {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] :
    adjoin F (insert.insert ∅ 1) = ⊥ :=
  iff.mpr adjoin_simple_eq_bot_iff (one_mem ⊥)

@[simp] theorem adjoin_int {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] (n : ℤ) :
    adjoin F (insert.insert ∅ ↑n) = ⊥ :=
  iff.mpr adjoin_simple_eq_bot_iff (coe_int_mem ⊥ n)

@[simp] theorem adjoin_nat {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] (n : ℕ) :
    adjoin F (insert.insert ∅ ↑n) = ⊥ :=
  iff.mpr adjoin_simple_eq_bot_iff (coe_int_mem ⊥ ↑n)

@[simp] theorem dim_eq_one_iff {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {K : intermediate_field F E} : vector_space.dim F ↥K = 1 ↔ K = ⊥ :=
  sorry

@[simp] theorem findim_eq_one_iff {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {K : intermediate_field F E} : finite_dimensional.findim F ↥K = 1 ↔ K = ⊥ :=
  sorry

theorem dim_adjoin_eq_one_iff {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {S : set E} : vector_space.dim F ↥(adjoin F S) = 1 ↔ S ⊆ ↑⊥ :=
  iff.trans dim_eq_one_iff adjoin_eq_bot_iff

theorem dim_adjoin_simple_eq_one_iff {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {α : E} : vector_space.dim F ↥(adjoin F (insert.insert ∅ α)) = 1 ↔ α ∈ ⊥ :=
  sorry

theorem findim_adjoin_eq_one_iff {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {S : set E} : finite_dimensional.findim F ↥(adjoin F S) = 1 ↔ S ⊆ ↑⊥ :=
  iff.trans findim_eq_one_iff adjoin_eq_bot_iff

theorem findim_adjoin_simple_eq_one_iff {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] {α : E} :
    finite_dimensional.findim F ↥(adjoin F (insert.insert ∅ α)) = 1 ↔ α ∈ ⊥ :=
  sorry

/-- If `F⟮x⟯` has dimension `1` over `F` for every `x ∈ E` then `F = E`. -/
theorem bot_eq_top_of_dim_adjoin_eq_one {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] (h : ∀ (x : E), vector_space.dim F ↥(adjoin F (insert.insert ∅ x)) = 1) : ⊥ = ⊤ :=
  sorry

theorem bot_eq_top_of_findim_adjoin_eq_one {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] (h : ∀ (x : E), finite_dimensional.findim F ↥(adjoin F (insert.insert ∅ x)) = 1) :
    ⊥ = ⊤ :=
  sorry

theorem subsingleton_of_dim_adjoin_eq_one {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] (h : ∀ (x : E), vector_space.dim F ↥(adjoin F (insert.insert ∅ x)) = 1) :
    subsingleton (intermediate_field F E) :=
  subsingleton_of_bot_eq_top (bot_eq_top_of_dim_adjoin_eq_one h)

theorem subsingleton_of_findim_adjoin_eq_one {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] (h : ∀ (x : E), finite_dimensional.findim F ↥(adjoin F (insert.insert ∅ x)) = 1) :
    subsingleton (intermediate_field F E) :=
  subsingleton_of_bot_eq_top (bot_eq_top_of_findim_adjoin_eq_one h)

/-- If `F⟮x⟯` has dimension `≤1` over `F` for every `x ∈ E` then `F = E`. -/
theorem bot_eq_top_of_findim_adjoin_le_one {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] [finite_dimensional F E]
    (h : ∀ (x : E), finite_dimensional.findim F ↥(adjoin F (insert.insert ∅ x)) ≤ 1) : ⊥ = ⊤ :=
  sorry

theorem subsingleton_of_findim_adjoin_le_one {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] [finite_dimensional F E]
    (h : ∀ (x : E), finite_dimensional.findim F ↥(adjoin F (insert.insert ∅ x)) ≤ 1) :
    subsingleton (intermediate_field F E) :=
  subsingleton_of_bot_eq_top (bot_eq_top_of_findim_adjoin_le_one h)

theorem aeval_gen_minpoly (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] (α : E) :
    coe_fn (polynomial.aeval (adjoin_simple.gen F α)) (minpoly F α) = 0 :=
  sorry

/-- algebra isomorphism between `adjoin_root` and `F⟮α⟯` -/
def adjoin_root_equiv_adjoin (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] {α : E}
    (h : is_integral F α) :
    alg_equiv F (adjoin_root (minpoly F α)) ↥(adjoin F (insert.insert ∅ α)) :=
  alg_equiv.of_bijective
    (alg_hom.mk
      ⇑(adjoin_root.lift (algebra_map F ↥(adjoin F (insert.insert ∅ α))) (adjoin_simple.gen F α)
          (aeval_gen_minpoly F α))
      sorry sorry sorry sorry sorry)
    sorry

theorem adjoin_root_equiv_adjoin_apply_root (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] {α : E} (h : is_integral F α) :
    coe_fn (adjoin_root_equiv_adjoin F h) (adjoin_root.root (minpoly F α)) =
        adjoin_simple.gen F α :=
  adjoin_root.lift_root

/-- Algebra homomorphism `F⟮α⟯ →ₐ[F] K` are in bijection with the set of roots
of `minpoly α` in `K`. -/
def alg_hom_adjoin_integral_equiv (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    {α : E} {K : Type u_3} [field K] [algebra F K] (h : is_integral F α) :
    alg_hom F (↥(adjoin F (insert.insert ∅ α))) K ≃
        Subtype
          fun (x : K) => x ∈ polynomial.roots (polynomial.map (algebra_map F K) (minpoly F α)) :=
  let ϕ : alg_equiv F (adjoin_root (minpoly F α)) ↥(adjoin F (insert.insert ∅ α)) :=
    adjoin_root_equiv_adjoin F h;
  let swap1 :
    alg_hom F (↥(adjoin F (insert.insert ∅ α))) K ≃ alg_hom F (adjoin_root (minpoly F α)) K :=
    equiv.mk
      (fun (f : alg_hom F (↥(adjoin F (insert.insert ∅ α))) K) =>
        alg_hom.comp f (alg_equiv.to_alg_hom ϕ))
      (fun (f : alg_hom F (adjoin_root (minpoly F α)) K) =>
        alg_hom.comp f (alg_equiv.to_alg_hom (alg_equiv.symm ϕ)))
      sorry sorry;
  let swap2 :
    alg_hom F (adjoin_root (minpoly F α)) K ≃
      Subtype
        fun (x : K) => x ∈ polynomial.roots (polynomial.map (algebra_map F K) (minpoly F α)) :=
    adjoin_root.equiv F K (minpoly F α) sorry;
  equiv.trans swap1 swap2

/-- Fintype of algebra homomorphism `F⟮α⟯ →ₐ[F] K` -/
def fintype_of_alg_hom_adjoin_integral (F : Type u_1) [field F] {E : Type u_2} [field E]
    [algebra F E] {α : E} {K : Type u_3} [field K] [algebra F K] (h : is_integral F α) :
    fintype (alg_hom F (↥(adjoin F (insert.insert ∅ α))) K) :=
  fintype.of_equiv
    (Subtype fun (x : K) => x ∈ polynomial.roots (polynomial.map (algebra_map F K) (minpoly F α)))
    (equiv.symm (alg_hom_adjoin_integral_equiv F h))

theorem card_alg_hom_adjoin_integral (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    {α : E} {K : Type u_3} [field K] [algebra F K] (h : is_integral F α)
    (h_sep : polynomial.separable (minpoly F α))
    (h_splits : polynomial.splits (algebra_map F K) (minpoly F α)) :
    fintype.card (alg_hom F (↥(adjoin F (insert.insert ∅ α))) K) =
        polynomial.nat_degree (minpoly F α) :=
  sorry

/-- An intermediate field `S` is finitely generated if there exists `t : finset E` such that
`intermediate_field.adjoin F t = S`. -/
def fg {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (S : intermediate_field F E) :=
  ∃ (t : finset E), adjoin F ↑t = S

theorem fg_adjoin_finset {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (t : finset E) : fg (adjoin F ↑t) :=
  Exists.intro t rfl

theorem fg_def {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {S : intermediate_field F E} : fg S ↔ ∃ (t : set E), set.finite t ∧ adjoin F t = S :=
  sorry

theorem fg_bot {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E] : fg ⊥ :=
  Exists.intro ∅ (adjoin_empty F E)

theorem fg_of_fg_to_subalgebra {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (S : intermediate_field F E) (h : subalgebra.fg (to_subalgebra S)) : fg S :=
  Exists.dcases_on h
    fun (t : finset E) (ht : algebra.adjoin F ↑t = to_subalgebra S) =>
      Exists.intro t (Eq.symm (eq_adjoin_of_eq_algebra_adjoin F (↑t) S (Eq.symm ht)))

theorem fg_of_noetherian {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (S : intermediate_field F E) [is_noetherian F E] : fg S :=
  fg_of_fg_to_subalgebra S (subalgebra.fg_of_noetherian (to_subalgebra S))

theorem induction_on_adjoin_finset {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (S : finset E) (P : intermediate_field F E → Prop) (base : P ⊥)
    (ih :
      ∀ (K : intermediate_field F E) (x : E), x ∈ S → P K → P ↑(adjoin (↥K) (insert.insert ∅ x))) :
    P (adjoin F ↑S) :=
  sorry

theorem induction_on_adjoin_fg {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (P : intermediate_field F E → Prop) (base : P ⊥)
    (ih : ∀ (K : intermediate_field F E) (x : E), P K → P ↑(adjoin (↥K) (insert.insert ∅ x)))
    (K : intermediate_field F E) (hK : fg K) : P K :=
  sorry

theorem induction_on_adjoin {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    [fd : finite_dimensional F E] (P : intermediate_field F E → Prop) (base : P ⊥)
    (ih : ∀ (K : intermediate_field F E) (x : E), P K → P ↑(adjoin (↥K) (insert.insert ∅ x)))
    (K : intermediate_field F E) : P K :=
  induction_on_adjoin_fg P base ih K (fg_of_noetherian K)

/-- Lifts `L → K` of `F → K` -/
def lifts (F : Type u_1) (E : Type u_2) (K : Type u_3) [field F] [field E] [field K] [algebra F E]
    [algebra F K] :=
  sigma fun (L : intermediate_field F E) => alg_hom F (↥L) K

protected instance lifts.order_bot {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] : order_bot (lifts F E K) :=
  order_bot.mk (sigma.mk ⊥ (alg_hom.comp (algebra.of_id F K) (alg_equiv.to_alg_hom bot_equiv)))
    (fun (x y : lifts F E K) =>
      sigma.fst x ≤ sigma.fst y ∧
        ∀ (s : ↥(sigma.fst x)) (t : ↥(sigma.fst y)),
          ↑s = ↑t → coe_fn (sigma.snd x) s = coe_fn (sigma.snd y) t)
    (partial_order.lt._default
      fun (x y : lifts F E K) =>
        sigma.fst x ≤ sigma.fst y ∧
          ∀ (s : ↥(sigma.fst x)) (t : ↥(sigma.fst y)),
            ↑s = ↑t → coe_fn (sigma.snd x) s = coe_fn (sigma.snd y) t)
    sorry sorry sorry sorry

protected instance lifts.inhabited {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] : Inhabited (lifts F E K) :=
  { default := ⊥ }

theorem lifts.eq_of_le {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E] [field K]
    [algebra F E] [algebra F K] {x : lifts F E K} {y : lifts F E K} (hxy : x ≤ y)
    (s : ↥(sigma.fst x)) :
    coe_fn (sigma.snd x) s =
        coe_fn (sigma.snd y) { val := ↑s, property := and.left hxy (↑s) (subtype.mem s) } :=
  and.right hxy s { val := ↑s, property := and.left hxy (↑s) (subtype.mem s) } rfl

theorem lifts.exists_max_two {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] {c : set (lifts F E K)} {x : lifts F E K}
    {y : lifts F E K} (hc : zorn.chain LessEq c) (hx : x ∈ set.insert ⊥ c)
    (hy : y ∈ set.insert ⊥ c) : ∃ (z : lifts F E K), z ∈ set.insert ⊥ c ∧ x ≤ z ∧ y ≤ z :=
  sorry

theorem lifts.exists_max_three {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] {c : set (lifts F E K)} {x : lifts F E K}
    {y : lifts F E K} {z : lifts F E K} (hc : zorn.chain LessEq c) (hx : x ∈ set.insert ⊥ c)
    (hy : y ∈ set.insert ⊥ c) (hz : z ∈ set.insert ⊥ c) :
    ∃ (w : lifts F E K), w ∈ set.insert ⊥ c ∧ x ≤ w ∧ y ≤ w ∧ z ≤ w :=
  sorry

/-- An upper bound on a chain of lifts -/
def lifts.upper_bound_intermediate_field {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F]
    [field E] [field K] [algebra F E] [algebra F K] {c : set (lifts F E K)}
    (hc : zorn.chain LessEq c) : intermediate_field F E :=
  mk (fun (s : E) => ∃ (x : lifts F E K), x ∈ set.insert ⊥ c ∧ s ∈ sigma.fst x) sorry sorry sorry
    sorry sorry sorry sorry

/-- The lift on the upper bound on a chain of lifts -/
def lifts.upper_bound_alg_hom {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] {c : set (lifts F E K)} (hc : zorn.chain LessEq c) :
    alg_hom F (↥(lifts.upper_bound_intermediate_field hc)) K :=
  alg_hom.mk
    (fun (s : ↥(lifts.upper_bound_intermediate_field hc)) =>
      coe_fn (sigma.snd (classical.some sorry)) { val := ↑s, property := sorry })
    sorry sorry sorry sorry sorry

/-- An upper bound on a chain of lifts -/
def lifts.upper_bound {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E] [field K]
    [algebra F E] [algebra F K] {c : set (lifts F E K)} (hc : zorn.chain LessEq c) : lifts F E K :=
  sigma.mk (lifts.upper_bound_intermediate_field hc) (lifts.upper_bound_alg_hom hc)

theorem lifts.exists_upper_bound {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] (c : set (lifts F E K)) (hc : zorn.chain LessEq c) :
    ∃ (ub : lifts F E K), ∀ (a : lifts F E K), a ∈ c → a ≤ ub :=
  sorry

/-- Extend a lift `x : lifts F E K` to an element `s : E` whose conjugates are all in `K` -/
def lifts.lift_of_splits {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E] [field K]
    [algebra F E] [algebra F K] (x : lifts F E K) {s : E} (h1 : is_integral F s)
    (h2 : polynomial.splits (algebra_map F K) (minpoly F s)) : lifts F E K :=
  let h3 : is_integral (↥(sigma.fst x)) s := sorry;
  let key : polynomial.splits (alg_hom.to_ring_hom (sigma.snd x)) (minpoly (↥(sigma.fst x)) s) :=
    sorry;
  sigma.mk (↑(adjoin (↥(sigma.fst x)) (insert.insert ∅ s)))
    (equiv.inv_fun alg_hom_equiv_sigma
      (sigma.mk (sigma.snd x)
        (equiv.inv_fun (alg_hom_adjoin_integral_equiv (↥(sigma.fst x)) h3)
          { val := polynomial.root_of_splits (alg_hom.to_ring_hom (sigma.snd x)) key sorry,
            property := sorry })))

theorem lifts.le_lifts_of_splits {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] (x : lifts F E K) {s : E} (h1 : is_integral F s)
    (h2 : polynomial.splits (algebra_map F K) (minpoly F s)) : x ≤ lifts.lift_of_splits x h1 h2 :=
  sorry

theorem lifts.mem_lifts_of_splits {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] (x : lifts F E K) {s : E} (h1 : is_integral F s)
    (h2 : polynomial.splits (algebra_map F K) (minpoly F s)) :
    s ∈ sigma.fst (lifts.lift_of_splits x h1 h2) :=
  mem_adjoin_simple_self (↥(sigma.fst x)) s

theorem lifts.exists_lift_of_splits {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] (x : lifts F E K) {s : E} (h1 : is_integral F s)
    (h2 : polynomial.splits (algebra_map F K) (minpoly F s)) :
    ∃ (y : lifts F E K), x ≤ y ∧ s ∈ sigma.fst y :=
  Exists.intro (lifts.lift_of_splits x h1 h2)
    { left := lifts.le_lifts_of_splits x h1 h2, right := lifts.mem_lifts_of_splits x h1 h2 }

theorem alg_hom_mk_adjoin_splits {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] {S : set E}
    (hK : ∀ (s : E), s ∈ S → is_integral F s ∧ polynomial.splits (algebra_map F K) (minpoly F s)) :
    Nonempty (alg_hom F (↥(adjoin F S)) K) :=
  sorry

theorem alg_hom_mk_adjoin_splits' {F : Type u_1} {E : Type u_2} {K : Type u_3} [field F] [field E]
    [field K] [algebra F E] [algebra F K] {S : set E} (hS : adjoin F S = ⊤)
    (hK : ∀ (x : E), x ∈ S → is_integral F x ∧ polynomial.splits (algebra_map F K) (minpoly F x)) :
    Nonempty (alg_hom F E K) :=
  sorry

end Mathlib


import data.matrix.notation

import .snake_lemma2
import .short_exact_sequence

noncomputable theory

open category_theory
open category_theory.limits

universes v u

lemma preadditive.exact_of_iso_of_exact' {D : Type*} [category D] [abelian D]
  {A₁ B₁ C₁ A₂ B₂ C₂ : D}
  (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁) (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂)
  (α : A₁ ≅ A₂) (β : B₁ ≅ B₂) (γ : C₁ ≅ C₂) (hsq₁ : α.hom ≫ f₂ = f₁ ≫ β.hom)
  (hsq₂ : β.hom ≫ g₂ = g₁ ≫ γ.hom)
  (h : exact f₁ g₁) :
  exact f₂ g₂ :=
preadditive.exact_of_iso_of_exact f₁ g₁ f₂ g₂ (arrow.iso_mk α β hsq₁) (arrow.iso_mk β γ hsq₂) rfl h

namespace homological_complex

variables {C : Type u} [category.{v} C] [abelian C]
variables {ι : Type*} {c : complex_shape ι}

def mod_boundaries (A : homological_complex C c) (j : ι) : C :=
cokernel ((A.boundaries j).arrow)

def mod_boundaries_map {A B : homological_complex C c} (f : A ⟶ B) (j : ι) :
  A.mod_boundaries j ⟶ B.mod_boundaries j :=
cokernel.map _ _ (boundaries_map f j) (f.f j) $ by { rw image_subobject_map_arrow, refl }

@[simps]
def mod_boundaries_functor (j : ι) : homological_complex C c ⥤ C :=
{ obj := λ A, A.mod_boundaries j,
  map := λ A B f, mod_boundaries_map f j,
  map_id' := λ A,
  begin
    delta mod_boundaries mod_boundaries_map cokernel.map, ext,
    show cokernel.π (A.boundaries j).arrow ≫ _ = cokernel.π (A.boundaries j).arrow ≫ _,
    simp only [cokernel.π_desc, category.id_comp, id_f, category.comp_id],
  end,
  map_comp' := λ X Y Z f g,
  begin
    delta mod_boundaries mod_boundaries_map cokernel.map, ext,
    show cokernel.π (X.boundaries j).arrow ≫ _ = cokernel.π (X.boundaries j).arrow ≫ _,
    simp only [cokernel.π_desc, cokernel.π_desc_assoc, comp_f, category.assoc],
  end }
.

-- generalize to chain complexes over other shapes
@[simps]
def homology_to_mod_boundaries (i : ι) :
  homology_functor C c i ⟶ mod_boundaries_functor i :=
{ app := λ A, cokernel.map _ _ (𝟙 _) ((A.cycles i).arrow)
    (by { simp only [category.id_comp, image_to_kernel_arrow], }),
  naturality' := λ A B f,
  begin
    refine homology.hom_from_ext _ _ _ _ _ _,
    simp only [homology_functor_map, mod_boundaries_functor_map, homology.π_map_assoc],
    delta mod_boundaries_map homology.π' cokernel.map cycles,
    simp only [category.assoc],
    erw homology.map_desc,
    simp only [cokernel.π_desc, cokernel.π_desc_assoc, comp_f, category.assoc,
      kernel_subobject_map_arrow_assoc, hom.sq_from_left],
    delta homology.desc,
    congr' 2,
    refine coequalizer.hom_ext _,
    erw [cokernel.π_desc, cokernel.π_desc_assoc, category.assoc, cokernel.π_desc],
  end }
.

variables (A : homological_complex C c) (i j : ι) (hij : c.rel i j)

def delta_to_boundaries : A.X i ⟶ (A.boundaries j) :=
(X_prev_iso A hij).inv ≫ factor_thru_image_subobject _

instance delta_to_boundaries_epi : epi (delta_to_boundaries A i j hij) :=
epi_comp _ _

@[ext] lemma boundaries.ext' {X : C} (f g : (boundaries A j : C) ⟶ X)
  (h : factor_thru_image_subobject _ ≫ f = factor_thru_image_subobject _ ≫ g) : f = g :=
by rwa cancel_epi (factor_thru_image_subobject (A.d_to j)) at h

@[simp, reassoc] lemma delta_to_boundaries_comp_arrow :
  (delta_to_boundaries A i j hij) ≫ (boundaries A j).arrow = A.d i j :=
by rw [delta_to_boundaries, category.assoc, image_subobject_arrow_comp, X_prev_iso_comp_d_to]

@[simp, reassoc] lemma boundaries_arrow_comp_delta_to_boundaries :
  (boundaries _ i).arrow ≫ delta_to_boundaries A i j hij = 0 :=
begin
  ext,
  simp only [image_subobject_arrow_comp_assoc, category.assoc,
    delta_to_boundaries_comp_arrow, comp_zero, zero_comp,
    ← d_from_comp_X_next_iso A hij, reassoc_of (d_to_comp_d_from A)],
end

def delta_to_cycles : A.X i ⟶ (A.cycles j) :=
delta_to_boundaries _ i j hij ≫ boundaries_to_cycles _ _

@[simp, reassoc] lemma delta_to_cycles_comp_arrow :
  (delta_to_cycles A i j hij) ≫ (cycles A j).arrow = A.d i j :=
by rw [delta_to_cycles, category.assoc, image_to_kernel_arrow, delta_to_boundaries_comp_arrow]

@[simp, reassoc] lemma boundaries_arrow_comp_delta_to_cycles :
  (boundaries _ _).arrow ≫ delta_to_cycles A i j hij = 0 :=
by rw [delta_to_cycles, ← category.assoc, boundaries_arrow_comp_delta_to_boundaries, zero_comp]

@[simps]
def mod_boundaries_to_cycles : mod_boundaries_functor i ⟶ cycles_functor C c j :=
{ app := λ A, cokernel.desc _ (delta_to_cycles _ i j hij)
   (boundaries_arrow_comp_delta_to_cycles _ i j hij),
  naturality' := λ A B f,
  begin
    ext, show cokernel.π _ ≫ _ = cokernel.π _ ≫ _,
    simp only [homology_functor_map, mod_boundaries_functor_map, homology.π_map_assoc],
    delta mod_boundaries_map homology.π cokernel.map,
    simp only [category.assoc, cycles_functor_map, cycles_map_arrow, hom.comm,
      cokernel.π_desc_assoc, delta_to_cycles_comp_arrow_assoc, delta_to_cycles_comp_arrow]
  end }
.

@[simps]
def cycles_to_homology : cycles_functor C c i ⟶ homology_functor C c i :=
{ app := λ A, cokernel.π _,
  naturality' := λ A B f,
  begin
    simp only [cycles_functor_map, homology_functor_map],
    delta homology.map,
    rw cokernel.π_desc, refl,
  end }

open_locale zero_object

lemma _root_.option.eq_none_or_eq_some {α : Type*} : ∀ (o : option α), o = none ∨ ∃ a, o = some a
| option.none     := or.inl rfl
| (option.some a) := or.inr ⟨a, rfl⟩

lemma exact_next {A₁ A₂ A₃ : homological_complex C c} (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃)
  (i j : ι) (hij : c.rel i j) (h : exact (f.f j) (g.f j)) :
  exact (f.next i) (g.next i) :=
begin
  refine preadditive.exact_of_iso_of_exact' (f.f j) (g.f j) _ _
    (X_next_iso A₁ hij).symm (X_next_iso A₂ hij).symm (X_next_iso A₃ hij).symm _ _ h;
  simp only [hom.next_eq _ hij, iso.symm_hom, iso.inv_hom_id_assoc],
end

lemma exact_next' {A₁ A₂ A₃ : homological_complex C c} (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) (i : ι)
  (h : ∀ n, exact (f.f n) (g.f n)) : exact (f.next i) (g.next i) :=
h _

lemma exact_prev {A₁ A₂ A₃ : homological_complex C c} (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃)
  (i j : ι) (hij : c.rel i j) (h : exact (f.f i) (g.f i)) :
  exact (f.prev j) (g.prev j) :=
begin
  refine preadditive.exact_of_iso_of_exact' (f.f i) (g.f i) _ _
    (X_prev_iso A₁ hij).symm (X_prev_iso A₂ hij).symm (X_prev_iso A₃ hij).symm _ _ h;
  simp only [hom.prev_eq _ hij, iso.symm_hom, iso.inv_hom_id_assoc],
end

lemma exact_prev' {A₁ A₂ A₃ : homological_complex C c} (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) (j : ι)
  (h : ∀ n, exact (f.f n) (g.f n)) : exact (f.prev j) (g.prev j) :=
h _

lemma mono_next {A₁ A₂ : homological_complex C c} (f : A₁ ⟶ A₂)
  (i j : ι) (hij : c.rel i j) [mono (f.f j)] :
  mono (f.next i) :=
begin
  rw hom.next_eq _ hij,
  apply_with mono_comp { instances := ff },
  { apply_instance },
  { apply mono_comp }
end

instance mono_next' {A₁ A₂ : homological_complex C c} (f : A₁ ⟶ A₂)
  (i : ι) [∀ n, mono (f.f n)] :
  mono (f.next i) :=
by apply_assumption

lemma epi_prev {A₁ A₂ : homological_complex C c} (f : A₁ ⟶ A₂)
  (i j : ι) (hij : c.rel i j) [epi (f.f i)] :
  epi (f.prev j) :=
begin
  rw hom.prev_eq _ hij,
  apply_with epi_comp { instances := ff },
  { apply_instance },
  { apply epi_comp }
end

instance epi_prev' {A₁ A₂ : homological_complex C c} (f : A₁ ⟶ A₂)
  (j : ι) [∀ n, epi (f.f n)] :
  epi (f.prev j) :=
by apply_assumption

instance {A B : homological_complex C c} (f : A ⟶ B) [∀ n, epi (f.f n)] (i : ι) :
  epi (boundaries_map f i) :=
begin
  let sq := hom.sq_to f i,
  haveI : epi sq.left := by { dsimp, apply_instance, },
  apply_with (epi_of_epi (factor_thru_image_subobject _)) { instances := ff },
  suffices : factor_thru_image_subobject (A.d_to i) ≫
      boundaries_map f i =
    sq.left ≫ factor_thru_image_subobject (B.d_to i),
  { rw this, apply epi_comp, },
  ext,
  simp only [category.assoc, image_subobject_map_arrow, hom.sq_to_right,
    image_subobject_arrow_comp_assoc, hom.sq_to_left, image_subobject_arrow_comp, hom.comm_to],
end

lemma exact_kernel_subobject_arrow (A B : C) (f : A ⟶ B) : exact (kernel_subobject f).arrow f :=
by { rw [← kernel_subobject_arrow, exact_iso_comp], exact exact_kernel_ι }

lemma exact_cycles_arrow (A : homological_complex C c) (i : ι) :
  exact (cycles A i).arrow (d_from A i) :=
exact_kernel_subobject_arrow _ _ _

lemma exact_cycles_map {A₁ A₂ A₃ : homological_complex C c} (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃)
  (hfg : ∀ n, short_exact (f.f n) (g.f n)) (j : ι) :
  exact (cycles_map f j) (cycles_map g j) :=
begin
  have sq₁ :  d_from A₁ j ≫ f.next j = f.f j ≫ d_from A₂ j := (hom.comm_from _ _).symm,
  have sq₂ :  d_from A₂ j ≫ g.next j = g.f j ≫ d_from A₃ j := (hom.comm_from _ _).symm,
  suffices S : snake
    ↑(cycles A₁ j) ↑(cycles A₂ j) ↑(cycles A₃ j)
    (A₁.X j) (A₂.X j) (A₃.X j)
    _ _ _
    _ _ _
    (cycles_map f j) (cycles_map g j)
    (cycles _ j).arrow (cycles _ j).arrow (cycles _ j).arrow
    (f.f j) (g.f j)
    (A₁.d_from j) (A₂.d_from j) (A₃.d_from j)
    (f.next j) (g.next j)
    (cokernel.π $ A₁.d_from j) (cokernel.π $ A₂.d_from j) (cokernel.π $ A₃.d_from j)
    (cokernel.map _ _ _ _ sq₁) (cokernel.map _ _ _ _ sq₂),
  { exact S.six_term_exact_seq.pair },
  have hfg_epi := λ j, (hfg j).epi,
  have hfg_mono := λ j, (hfg j).mono,
  resetI,
  fsplit,
  { exact (hfg j).exact },
  { exact exact_next' _ _ _ (λ i, (hfg i).exact), },
  { refine (exact_cycles_arrow _ _).cons (abelian.exact_cokernel _).exact_seq, },
  { refine (exact_cycles_arrow _ _).cons (abelian.exact_cokernel _).exact_seq, },
  { refine (exact_cycles_arrow _ _).cons (abelian.exact_cokernel _).exact_seq, },
  { rw cycles_map_arrow, },
  { rw cycles_map_arrow, },
  { exact sq₁ },
  { exact sq₂ },
  { apply cokernel.π_desc, },
  { apply cokernel.π_desc, },
end

variables {A₁ A₂ A₃ : homological_complex C c} (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃)
variables (hfg : ∀ n, short_exact (f.f n) (g.f n))

lemma mono_cycles_map (hfg : ∀ n, short_exact (f.f n) (g.f n)) (i : ι) :
  mono (cycles_map f i) :=
begin
  apply_with (mono_of_mono _ (subobject.arrow _)) { instances := ff },
  rw cycles_map_arrow,
  haveI : mono (f.f i) := (hfg i).mono,
  apply mono_comp,
end

@[simp] lemma image_subobject_arrow {X : C} (S : subobject X) :
  image_subobject (S.arrow) = S :=
begin
  delta image_subobject,
  ext,
  swap,
  { exact limits.image_mono_iso_source _ },
  { simp }
end

@[simp] lemma kernel_subobject_cokernel.π {X : C} (S : subobject X) :
  kernel_subobject (cokernel.π S.arrow) = S :=
begin
  delta kernel_subobject,
  ext,
  swap,
  { exact (abelian.image_iso_image _).trans (limits.image_mono_iso_source _) },
  { simp }
end

lemma exact.congr {X₁ X₂ Y Z₁ Z₂ : C} (f₁ : X₁ ⟶ Y) (g₁ : Y ⟶ Z₁) (f₂ : X₂ ⟶ Y) (g₂ : Y ⟶ Z₂)
  (h : exact f₁ g₁) (him : image_subobject f₁ = image_subobject f₂)
  (hker : kernel_subobject g₁ = kernel_subobject g₂) :
  exact f₂ g₂ :=
by rwa [abelian.exact_iff_image_eq_kernel, ← him, ← hker, ← abelian.exact_iff_image_eq_kernel]

lemma exact_column :
exact_seq C [(kernel.ι (A.d_to j)), (A.d_to j), (cokernel.π (A.boundaries j).arrow)] :=
exact_kernel_ι.cons $
(exact.congr (boundaries A j).arrow _ _ _ (abelian.exact_cokernel _) (image_subobject_arrow _) rfl).exact_seq

lemma exact_mod_boundaries_map (hfg : ∀ n, short_exact (f.f n) (g.f n)) (j : ι) :
  exact (mod_boundaries_map f j) (mod_boundaries_map g j) :=
begin
  have sq1 : A₁.d_to j ≫ f.f j = f.prev j ≫ A₂.d_to j := (f.comm_to _).symm,
  have sq2 : A₂.d_to j ≫ g.f j = g.prev j ≫ A₃.d_to j := (g.comm_to _).symm,
  suffices S : snake
    -- the objects
         (kernel _)           (kernel _)           (kernel _)
        (A₁.X_prev j)         (A₂.X_prev j)         (A₃.X_prev j)
          (A₁.X j)             (A₂.X j)             (A₃.X j)
    (mod_boundaries _ j) (mod_boundaries _ j) (mod_boundaries _ j)
    -- the morphisms
    (kernel.map _ _ _ _ sq1) (kernel.map _ _ _ _ sq2)
    (kernel.ι $ A₁.d_to j) (kernel.ι $ A₂.d_to j) (kernel.ι $ A₃.d_to j)
    (f.prev j) (g.prev j)
    (A₁.d_to j) (A₂.d_to j) (A₃.d_to j)
    (f.f j) (g.f j)
    (cokernel.π _) (cokernel.π _) (cokernel.π _)
    (mod_boundaries_map f j) (mod_boundaries_map g j),
  { exact (S.six_term_exact_seq.drop 3).pair },
  have hfg_epi := λ n, (hfg n).epi,
  have hfg_mono := λ n, (hfg n).mono,
  resetI,
  fsplit,
  { exact exact_prev' _ _ _ (λ n, (hfg n).exact) },
  { exact (hfg j).exact },
  { apply exact_column },
  { apply exact_column },
  { apply exact_column },
  { simp },
  { simp },
  { exact sq1 },
  { exact sq2 },
  { simp [mod_boundaries_map] },
  { simp [mod_boundaries_map] }
end

lemma epi_mod_boundaries_map (hfg : ∀ n, short_exact (f.f n) (g.f n)) (i : ι) :
  epi (mod_boundaries_map g i) :=
begin
  apply_with (epi_of_epi (cokernel.π _)) { instances := ff },
  haveI : epi (g.f i) := (hfg i).epi,
  have : cokernel.π _ ≫ mod_boundaries_map g i = g.f i ≫ cokernel.π _ := cokernel.π_desc _ _ _,
  rw this,
  apply epi_comp,
end

lemma mono_homology_to_mod_boundaries :
  mono ((homology_to_mod_boundaries i).app A) :=
cokernel.map_mono_of_epi_of_mono
  (boundaries A i) (cycles A i)
  (boundaries A i) (A.X i)
  _ _ _ _ _

variables {C}

@[simp] lemma image_subobject_comp_eq_of_epi {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [epi f] :
  image_subobject (f ≫ g) = image_subobject g :=
begin
  delta image_subobject,
  haveI : is_iso (image.pre_comp f g) := is_iso_of_mono_of_epi _,
  ext, swap,
  { exact as_iso (image.pre_comp f g) },
  { simp only [as_iso_hom, image.pre_comp_ι], },
end

@[simp] lemma kernel_subobject_comp_eq_of_mono {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [mono g] :
  kernel_subobject (f ≫ g) = kernel_subobject f :=
begin
  delta kernel_subobject,
  ext, swap,
  { exact kernel_comp_mono f g },
  { simp only [kernel_comp_mono_hom, kernel.lift_ι] },
end

lemma exact_cycles_arrow_delta_to_cycles :
  exact (A.cycles i).arrow (delta_to_cycles A i j hij) :=
begin
  rw [category_theory.abelian.exact_iff_image_eq_kernel],
  dsimp [delta_to_cycles, delta_to_boundaries],
  simp only [image_subobject_arrow, kernel_subobject_comp_eq_of_mono],
  delta cycles,
  let g : ↑(A.boundaries j) ⟶ X_next A i := (A.boundaries j).arrow ≫ (X_next_iso _ hij).inv,
  haveI : mono g := mono_comp _ _,
  suffices aux : delta_to_boundaries _ i j hij ≫ g = d_from A i,
  { simp_rw [← aux, kernel_subobject_comp_eq_of_mono], refl, },
  simp only [delta_to_boundaries_comp_arrow_assoc, iso.comp_inv_eq, d_from_comp_X_next_iso],
end

lemma exact_homology_to_mod_boundaries_to_cycles :
  exact ((homology_to_mod_boundaries i).app A) ((mod_boundaries_to_cycles i j hij).app A) :=
begin
  let φ : homology A i ⟶ mod_boundaries A i :=
    limits.cokernel.desc _ ((kernel_subobject _).arrow ≫ (cokernel.π _)) (by simp),
  suffices S : snake
    (0:C) 0 0
    (A.boundaries i) (boundaries A i) 0
    (A.cycles i) (A.X i) (A.cycles j)
    (homology A i) (mod_boundaries A i) (A.cycles j)
    0 0
    0 0 0
    (𝟙 _) 0
    (boundaries_to_cycles _ _) (A.boundaries i).arrow 0
    (A.cycles i).arrow (delta_to_cycles _ i j hij)
    (homology.π _ _ _) (cokernel.π _) (𝟙 _)
    φ ((mod_boundaries_to_cycles i j hij).app A),
  { exact (S.six_term_exact_seq.drop 3).pair },
  letI : exact (cycles A i).arrow (delta_to_cycles A i j hij) :=
    exact_cycles_arrow_delta_to_cycles _ i j hij,
  letI : epi (homology.π (d_to A i) (d_from A i) (A.d_to_comp_d_from i)) := coequalizer.π_epi,
  fsplit,
  { rw ← epi_iff_exact_zero_right, apply_instance },
  { apply exact_cycles_arrow_delta_to_cycles },
  { exact (category_theory.exact_zero_mono _).cons (abelian.exact_cokernel _).exact_seq, },
  { exact (category_theory.exact_zero_mono _).cons (abelian.exact_cokernel _).exact_seq, },
  { exact (category_theory.exact_zero_mono _).cons (exact_zero_left_of_mono _).exact_seq, },
  { simp only [zero_comp] },
  { simp only [zero_comp] },
  { simp only [image_to_kernel_arrow, category.id_comp] },
  { simp only [boundaries_arrow_comp_delta_to_cycles, zero_comp], },
  { dsimp [homology.π], simp only [cokernel.π_desc] },
  { simp only [mod_boundaries_to_cycles_app, cokernel.π_desc, category.comp_id] },
end

lemma exact_mod_boundaries_to_cycles_to_homology :
  exact ((mod_boundaries_to_cycles i j hij).app A) ((cycles_to_homology j).app A)  :=
begin
  refine exact.congr (boundaries_to_cycles _ _) _ _ _ _ _ rfl,
  { exact abelian.exact_cokernel _, },
  { simp only [mod_boundaries_to_cycles_app],
    delta delta_to_cycles,
    rw [← image_subobject_comp_eq_of_epi (cokernel.π _)],
    simp only [cokernel.π_desc, image_subobject_comp_eq_of_epi], }
end

lemma epi_cycles_to_homology : epi ((cycles_to_homology j).app A) :=
coequalizer.π_epi

lemma exact_seq_column :
  exact_seq C
    [((homology_to_mod_boundaries i).app A₁),
     ((mod_boundaries_to_cycles i j hij).app A₁),
     ((cycles_to_homology j).app A₁)] :=
(exact_homology_to_mod_boundaries_to_cycles _ _ _ _).cons
  (exact_mod_boundaries_to_cycles_to_homology _ _ _ _).exact_seq

lemma snake (hfg : ∀ n, short_exact (f.f n) (g.f n)) (i j : ι) (hij : c.rel i j) :
  snake
  -- the objects
     (A₁.homology i)       (A₂.homology i)       (A₃.homology i)
  (A₁.mod_boundaries i) (A₂.mod_boundaries i) (A₃.mod_boundaries i)
      (A₁.cycles j)         (A₂.cycles j)         (A₃.cycles j)
     (A₁.homology j)       (A₂.homology j)       (A₃.homology j)
  -- the morphisms
  ((homology_functor _ _ i).map f) ((homology_functor _ _ i).map g)
  ((homology_to_mod_boundaries i).app A₁)
  ((homology_to_mod_boundaries i).app A₂)
  ((homology_to_mod_boundaries i).app A₃)
  ((mod_boundaries_functor i).map f) ((mod_boundaries_functor i).map g)
  ((mod_boundaries_to_cycles i j hij).app A₁)
  ((mod_boundaries_to_cycles i j hij).app A₂)
  ((mod_boundaries_to_cycles i j hij).app A₃)
  ((cycles_functor _ _ j).map f) ((cycles_functor _ _ j).map g)
  ((cycles_to_homology j).app A₁)
  ((cycles_to_homology j).app A₂)
  ((cycles_to_homology j).app A₃)
  ((homology_functor _ _ j).map f) ((homology_functor _ _ j).map g) :=
{ row_exact₁ := exact_mod_boundaries_map f g hfg _,
  row_exact₂ := exact_cycles_map f g hfg _,
  row_epi := epi_mod_boundaries_map f g hfg _,
  row_mono := mono_cycles_map f g hfg _,
  col_exact_a := exact_seq_column _ _ _,
  col_exact_b := exact_seq_column _ _ _,
  col_exact_c := exact_seq_column _ _ _,
  col_mono_a := mono_homology_to_mod_boundaries _ _,
  col_mono_b := mono_homology_to_mod_boundaries _ _,
  col_mono_c := mono_homology_to_mod_boundaries _ _,
  col_epi_a := epi_cycles_to_homology _ _,
  col_epi_b := epi_cycles_to_homology _ _,
  col_epi_c := epi_cycles_to_homology _ _,
  sq_a₀ := ((homology_to_mod_boundaries _).naturality _).symm,
  sq_b₀ := ((homology_to_mod_boundaries _).naturality _).symm,
  sq_a₁ := ((mod_boundaries_to_cycles _ _ _).naturality _).symm,
  sq_b₁ := ((mod_boundaries_to_cycles _ _ _).naturality _).symm,
  sq_a₂ := ((cycles_to_homology _).naturality _).symm,
  sq_b₂ := ((cycles_to_homology _).naturality _).symm }

def δ (hfg : ∀ n, short_exact (f.f n) (g.f n)) (i j : ι) (hij : c.rel i j) :
  homology A₃ i ⟶ homology A₁ j :=
(snake f g hfg i j hij).δ

lemma six_term_exact_seq (hfg : ∀ n, short_exact (f.f n) (g.f n)) (i j : ι) (hij : c.rel i j) :
  exact_seq C [
    (homology_functor _ _ i).map f, -- Hⁱ(A₁) ⟶ Hⁱ(A₂)
    (homology_functor _ _ i).map g, -- Hⁱ(A₂) ⟶ Hⁱ(A₃)
    δ f g hfg i j hij,              -- Hⁱ(A₃) ⟶ Hʲ(A₁)
    (homology_functor _ _ j).map f, -- Hʲ(A₁) ⟶ Hʲ(A₂)
    (homology_functor _ _ j).map g  -- Hʲ(A₁) ⟶ Hʲ(A₃)
  ] :=
(snake f g hfg i j hij).six_term_exact_seq

end homological_complex


import Advent
import Std

open Lean (RBMap HashMap)

inductive Dir | R | D | L | U
deriving Inhabited, Lean.ToJson, Repr, BEq, Ord, Hashable

inductive Turn | Straight| Linksaf| Rechtsaf
deriving Inhabited, Lean.ToJson, Repr, BEq, Ord, Hashable

structure Side where
  x: Nat
  y: Nat
  dir: Dir
deriving BEq, Ord, Hashable, Lean.ToJson, Repr

abbrev Glue := Side × Side

structure Map where
  n: Nat
  m: Nat
  elements: Array (Array Char)
  side: Nat
  glues: Array Glue
  trace: Array (Array Char) := elements
deriving Inhabited, Lean.ToJson, Repr, BEq

open Turn
namespace Dir
def rechtsaf: Dir -> Dir
| R => D
| D => L
| L => U
| U => R

def linksaf: Dir -> Dir
| D => R
| L => D
| U => L
| R => U

def turn: Turn -> Dir -> Dir
| Turn.Straight  => id
| Turn.Linksaf => linksaf
| Turn.Rechtsaf=> rechtsaf

def code: Dir -> Fin 4
| R => 0
| D => 1
| L => 2
| U => 3

def back: Dir -> Dir
| R => L
| L => R
| U => D
| D => U

theorem leftRight (d: Dir): d.linksaf.rechtsaf = d := by
  cases d <;> simp [linksaf, rechtsaf]

theorem rightLeft (d: Dir): d.rechtsaf.linksaf = d := by
  cases d <;> simp [linksaf, rechtsaf]

theorem backBack (d: Dir): d.back.back = d := by
  cases d <;> simp [back]

def parse: Parse Dir := Parse.choose [("R", R), ("D", D), ("U", U), ("L", L)]
end Dir
open Dir
namespace Map
variable (map: Map)

def get (x y: Nat): Char := map.elements[x]![y]!

def step (x y: Nat) (d: Dir): (Dir × Nat × Nat) :=
  let (x', y') := move x y d
  let tele := if x' == map.m || y' == map.n then true else map.get x' y' == ' '
  let (d', x', y') := if tele then teleport x y d else (d, x', y')
  if map.elements[x']![y']! == '#' then (d, x, y) else (d',x', y')
where
  move
  | x, y, R => (x, y + 1)
  | x, y, D => (x + 1, y)
  | x, 0, L => (x, map.n)
  | x, y + 1, L =>(x, y)
  | 0, y, U => (map.m, y)
  | x + 1, y, U => (x, y)
  invert u := map.side - u - 1
  leave x y: Dir -> Nat
  | R => x
  | L => invert x
  | U => y
  | D => invert y
  enter q : Dir -> (Nat × Nat)
  | R => (q, invert 0)
  | L => (invert q, 0)
  | U => (0, q)
  | D => (invert 0, invert q)
  findGlue x y d : Option Side :=
    let s := ⟨x / map.side, y / map.side, d⟩
    (map.glues.find? (·.1 == s) ).map (·.2)
  teleport x y d :=
    if let some ⟨i, j, dir⟩ := findGlue x y d then
      let q := invert <| leave (x % map.side) (y % map.side) d
      let (dx, dy) := enter q dir
      (dir.back, i * map.side + dx, j * map.side + dy)
    else
      panic! s!"can't find glue for {x} {y} {d}"
structure Step where
  map: Map
  dir: Dir
  x: Nat
  y: Nat

def start: Step := {map , dir := R, x := 0, y := (map.elements[0]!.indexOf? '.').elim 0 (· + 0) }

def stepTrace: Step -> Step
| {map, dir, x, y} =>
  let char := match dir with
  | D => 'V'
  | R => '>'
  | L => '<'
  | U => '^'
  let map := {map with trace := map.trace.modify x (·.set! y char)}
  let (dir, x, y) := map.step x y dir
  {map, dir, x, y}

def walkBunch (c: Nat) (t: Turn) (s: Step): Id Step := do
  let mut s := {s with dir := s.dir.turn t}
  for _ in [0:c] do
    s := stepTrace s
  return s

def walk( xs: List (Nat × Turn)): Step :=
  xs.foldl (fun pos (c, t) => walkBunch c t pos) map.start

def make (ls: List String) (side: Nat) (glues: Array Glue): Map :=
  let elements := (ls.map (·.toList.toArray)).toArray
  let n := elements.foldl (max · ·.size) 0
  let m := elements.size
  let elements := elements.map (·.autoGrow n ' ')
  {elements, n, m, side, glues}

def strings := map.trace.map (String.mk <| ·.toList)
end Map

def parseCommande: Parse (List (Nat × Turn)) :=  do
  let init <- Parse.nat
  let ls <- parseOne.rep
  let tts := (init, Straight) :: ls
  return tts
where
  parseOne := do
  let turn <- Parse.choose [("L", Linksaf), ("R", Rechtsaf)]
  let cnt <- Parse.nat
  return (cnt, turn)

def parseGlues: Parse (Array Glue) := do
  let glues <- glue.repSep! ", "
  let glues := glues.toArray
  let glues' := glues.map (fun (l, r) => (r, l))
  return glues ++ glues'
where
  side: Parse Side := open Parse in do
    let x <- nat
    ws
    let y <- nat
    ws
    let dir <- Dir.parse
    return {x, y, dir}
  glue := do
    let left <- side
    Parse.str " <-> "
    let right <- side
    return (left, right)

def main: IO Unit := do
  let lines <- readLines 22
  let map := lines.takeWhile (· != "")
  let tail := (lines.dropWhile (· != "")).drop 1

  let coms <- parseCommande.runIO tail[0]!
  let side := tail[1]!.toNat!
  for l in tail.drop 2 do
    let glues <- parseGlues.runIO l
    let map := Map.make map side glues
    let {map, dir, x, y} := map.walk coms
    IO.println (x, y, dir)
    map.strings.forM IO.println
    let code := (x + 1) * 1000 + (y + 1) * 4 + dir.code
    IO.println code