/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.meta.congr_lemma
! leanprover-community/mathlib commit 49194b4458c682842a21a1f8675e174b440af055
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Meta.Tactic
import Leanbin.Init.Meta.Format
import Leanbin.Init.Function

/--
This is a kind attached to an argument of a congruence lemma that tells the simplifier how to fill it in.
- `fixed`: It is a parameter for the congruence lemma, the parameter occurs in the left and right hand sides.
  For example the α in the congruence generated from `f: Π {α : Type} α → α`.
- `fixed_no_param`: It is not a parameter for the congruence lemma, the lemma was specialized for this parameter.
  This only happens if the parameter is a subsingleton/proposition, and other parameters depend on it.
- `eq`: The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `(eq_i : a_i = b_i)`.
  `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their equality.
  For example the second argument in `f: Π {α : Type}, α → α`.
- `cast`: corresponds to arguments that are subsingletons/propositions.
  For example the `p` in the congruence generated from `f : Π (x y : ℕ) (p: x < y), ℕ`.
- `heq` The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `(eq_i : a_i == b_i)`.
   `a_i` and `b_i` represent the left and right hand sides, and eq_i is a proof for their heterogeneous equality.
-/
inductive CongrArgKind
  | fixed
  | fixed_no_param
  | Eq
  | cast
  | HEq
  | subsingleton_inst
#align congr_arg_kind CongrArgKind

namespace CongrArgKind

def toString : CongrArgKind → String
  | fixed => "fixed"
  | fixed_no_param => "fixed_no_param"
  | Eq => "eq"
  | cast => "cast"
  | HEq => "heq"
  | subsingleton_inst => "subsingleton_inst"
#align congr_arg_kind.to_string CongrArgKind.toString

instance : Repr CongrArgKind :=
  ⟨toString⟩

unsafe instance : has_to_format CongrArgKind :=
  ⟨fun x => toString x⟩

end CongrArgKind

/--
A congruence lemma is a proof that two terms are equal using a congruence proof generated by `mk_congr_lemma_simp` and friends.
See the docstring for `mk_congr_lemma_simp` and `congr_arg_kind` for more information.
The conclusion is prepended by a set of arguments. `arg_kinds` gives a suggestion of how that argument should be filled in using a simplifier.
  -/
unsafe structure congr_lemma where
  type : expr
  proof : expr
  arg_kinds : List CongrArgKind
#align congr_lemma congr_lemma

namespace Tactic

/-- `mk_congr_lemma_simp f nargs md`
creates a congruence lemma for the simplifier for the given function argument `f`.
If `nargs` is not none, then it tries to create a lemma for an application of arity `nargs`.
If `nargs` is none then the number of arguments will be guessed from the type signature of `f`.

That is, given `f : Π {α β γ δ : Type}, α → β → γ → δ` and `nargs = some 6`, we get a congruence lemma:
``` lean
{ type := ∀ (α β γ δ : Type), ∀ (a₁ a₂ : α), a₁ = a₂ → ∀ (b₁ b₂ : β), b₁ = b₂ → f a₁ b₁ = f a₂ b₂
, proof := ...
, arg_kinds := [fixed, fixed, fixed, fixed, eq,eq]
}
```
See the docstrings for the cases of `congr_arg_kind` for more detail on how `arg_kinds` are chosen.
The system chooses the `arg_kinds` depending on what the other arguments depend on and whether the arguments have subsingleton types.

Note that the number of arguments that `proof` takes can be inferred from `arg_kinds`: `arg_kinds.sum (fixed,cast ↦ 1 | eq,heq ↦ 3 | fixed_no_param ↦ 0)`.

From `congr_lemma.cpp`:
> Create a congruence lemma that is useful for the simplifier.
> In this kind of lemma, if the i-th argument is a Cast argument, then the lemma
> contains an input a_i representing the i-th argument in the left-hand-side, and
> it appears with a cast (e.g., eq.drec ... a_i ...) in the right-hand-side.
> The idea is that the right-hand-side of this lemma "tells" the simplifier
> how the resulting term looks like.
-/
unsafe axiom mk_congr_lemma_simp (f : expr) (nargs : Option Nat := none) (md := semireducible) :
    tactic congr_lemma
#align tactic.mk_congr_lemma_simp tactic.mk_congr_lemma_simp

/-- Create a specialized theorem using (a prefix of) the arguments of the given application.

An example of usage can be found in `tests/lean/simp_subsingleton.lean`.
For more information on specialization see the comment in the method body for `get_specialization_prefix_size` in `src/library/fun_info.cpp`.
 -/
unsafe axiom mk_specialized_congr_lemma_simp (h : expr) (md : Transparency := semireducible) :
    tactic congr_lemma
#align tactic.mk_specialized_congr_lemma_simp tactic.mk_specialized_congr_lemma_simp

/-- Similar to `mk_congr_lemma_simp`, this will make a `congr_lemma` object.
The difference is that for each `congr_arg_kind.cast` argument, two proof arguments are generated.

Consider some function `f : Π (x : ℕ) (p : x < 4), ℕ`.
- `mk_congr_simp` will produce a congruence lemma with type `∀ (x x_1 : ℕ) (e_1 : x = x_1) (p : x < 4), f x p = f x_1 _`.
- `mk_congr` will produce a congruence lemma with type `∀ (x x_1 : ℕ) (e_1 : x = x_1) (p : x < 4) (p_1 : x_1 < 4), f x p = f x_1 p_1`.

From `congr_lemma.cpp`:
> Create a congruence lemma for the congruence closure module.
> In this kind of lemma, if the i-th argument is a Cast argument, then the lemma
> contains two inputs a_i and b_i representing the i-th argument in the left-hand-side and
> right-hand-side.
> This lemma is based on the congruence lemma for the simplifier.
> It uses subsinglenton elimination to show that the congr-simp lemma right-hand-side
> is equal to the right-hand-side of this lemma.
 -/
unsafe axiom mk_congr_lemma (h : expr) (nargs : Option Nat := none) (md := semireducible) :
    tactic congr_lemma
#align tactic.mk_congr_lemma tactic.mk_congr_lemma

/-- Create a specialized theorem using (a prefix of) the arguments of the given application.

For more information on specialization see the comment in the method body for `get_specialization_prefix_size` in `src/library/fun_info.cpp`.
-/
unsafe axiom mk_specialized_congr_lemma (h : expr) (md := semireducible) : tactic congr_lemma
#align tactic.mk_specialized_congr_lemma tactic.mk_specialized_congr_lemma

/-- Make a congruence lemma using hetrogeneous equality `heq` instead of `eq`.
For example `mk_hcongr_lemma (f : Π (α : ℕ → Type) (n:ℕ) (b:α n), ℕ` )` will make

``` lean
{ type := ∀ α α', α = α' → ∀ n n', n = n' → ∀ (b : α n) (b' : α' n'), b == b' → f α n b == f α' n' b'
, proof := ...
, arg_kinds := [eq,eq,heq]
}
```

(Using merely `mk_congr_lemma` instead will produce `[fixed,fixed,eq]` instaed.)
-/
unsafe axiom mk_hcongr_lemma (h : expr) (nargs : Option Nat := none) (md := semireducible) :
    tactic congr_lemma
#align tactic.mk_hcongr_lemma tactic.mk_hcongr_lemma

end Tactic


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

import Aesop

set_option aesop.check.all true

@[aesop 50% constructors]
inductive I₁
  | ofI₁ : I₁ → I₁
  | ofTrue : True → I₁

example : I₁ := by
  aesop

example : I₁ := by
  aesop (options := { strategy := .bestFirst })

example : I₁ := by
  aesop (options := { strategy := .breadthFirst })

example : I₁ := by
  fail_if_success
    aesop (options :=
      { strategy := .depthFirst,
        maxRuleApplicationDepth := 0,
        maxRuleApplications := 10,
        terminal := true })
  aesop (options :=
    { strategy := .depthFirst,
      maxRuleApplicationDepth := 10 })


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.meta.declaration
! leanprover-community/mathlib commit cd2d62882160de729619fc68c92a57b5e9d0e968
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Meta.Expr
import Leanbin.Init.Meta.Name
import Leanbin.Init.Meta.Task

/-- Reducibility hints are used in the convertibility checker.
When trying to solve a constraint such a

    (f ...) =?= (g ...)

where `f` and `g` are definitions, the checker has to decide which one will be unfolded.
* If      `f` (`g`) is opaque,     then `g` (`f`) is unfolded if it is also not marked as opaque,
* Else if `f` (`g`) is abbrev,     then `f` (`g`) is unfolded if `g` (`f`) is also not marked as abbrev,
* Else if `f` and `g` are regular, then we unfold the one with the biggest definitional height.
* Otherwise both are unfolded.

The arguments of the `regular` constructor are: the definitional height and the flag `self_opt`.

The definitional height is by default computed by the kernel. It only takes into account
other regular definitions used in a definition. When creating declarations using meta-programming,
we can specify the definitional depth manually.

For definitions marked as regular, we also have a hint for constraints such as

    (f a) =?= (f b)

if `self_opt = tt`, then checker will first try to solve `a =?= b`, only if it fails,
it unfolds `f`.

Remark: the hint only affects performance. None of the hints prevent the kernel from unfolding a
declaration during type checking.

Remark: the reducibility_hints are not related to the attributes: reducible/irrelevance/semireducible.
These attributes are used by the elaborator. The reducibility_hints are used by the kernel (and elaborator).
Moreover, the reducibility_hints cannot be changed after a declaration is added to the kernel.
-/
inductive ReducibilityHints
  | opaque
  | abbrev
  | regular (height : Nat) (self_opt : Bool)
#align reducibility_hints ReducibilityHints

/-- Reflect a C++ declaration object. The VM replaces it with the C++ implementation. -/
unsafe inductive declaration-- definition

  |
  defn (n : Name) (univs : List Name) (type : expr) (value : expr) (red : ReducibilityHints)
    (is_trusted : Bool)-- theorem (remark: theorems are always trusted)

  | thm (n : Name) (univs : List Name) (type : expr) (value : task expr)-- constant assumption

  |
  cnst (n : Name) (univs : List Name) (type : expr)
    (is_trusted : Bool)-- axiom (remark: axioms are always trusted)

  | ax (n : Name) (univs : List Name) (type : expr)
#align declaration declaration

open Declaration

unsafe def mk_definition (n : Name) (ls : List Name) (v : expr) (e : expr) : declaration :=
  defn n ls v e (ReducibilityHints.regular 1 true) true
#align mk_definition mk_definition

namespace Declaration

unsafe def to_name : declaration → Name
  | defn n _ _ _ _ _ => n
  | thm n _ _ _ => n
  | cnst n _ _ _ => n
  | ax n _ _ => n
#align declaration.to_name declaration.to_name

unsafe def univ_params : declaration → List Name
  | defn _ ls _ _ _ _ => ls
  | thm _ ls _ _ => ls
  | cnst _ ls _ _ => ls
  | ax _ ls _ => ls
#align declaration.univ_params declaration.univ_params

unsafe def type : declaration → expr
  | defn _ _ t _ _ _ => t
  | thm _ _ t _ => t
  | cnst _ _ t _ => t
  | ax _ _ t => t
#align declaration.type declaration.type

unsafe def value : declaration → expr
  | defn _ _ _ v _ _ => v
  | thm _ _ _ v => v.get
  | _ => default
#align declaration.value declaration.value

unsafe def value_task : declaration → task expr
  | defn _ _ _ v _ _ => task.pure v
  | thm _ _ _ v => v
  | _ => task.pure default
#align declaration.value_task declaration.value_task

unsafe def is_trusted : declaration → Bool
  | defn _ _ _ _ _ t => t
  | cnst _ _ _ t => t
  | _ => true
#align declaration.is_trusted declaration.is_trusted

unsafe def update_type : declaration → expr → declaration
  | defn n ls t v h tr, new_t => defn n ls new_t v h tr
  | thm n ls t v, new_t => thm n ls new_t v
  | cnst n ls t tr, new_t => cnst n ls new_t tr
  | ax n ls t, new_t => ax n ls new_t
#align declaration.update_type declaration.update_type

unsafe def update_name : declaration → Name → declaration
  | defn n ls t v h tr, new_n => defn new_n ls t v h tr
  | thm n ls t v, new_n => thm new_n ls t v
  | cnst n ls t tr, new_n => cnst new_n ls t tr
  | ax n ls t, new_n => ax new_n ls t
#align declaration.update_name declaration.update_name

unsafe def update_value : declaration → expr → declaration
  | defn n ls t v h tr, new_v => defn n ls t new_v h tr
  | thm n ls t v, new_v => thm n ls t (task.pure new_v)
  | d, new_v => d
#align declaration.update_value declaration.update_value

unsafe def update_value_task : declaration → task expr → declaration
  | defn n ls t v h tr, new_v => defn n ls t new_v.get h tr
  | thm n ls t v, new_v => thm n ls t new_v
  | d, new_v => d
#align declaration.update_value_task declaration.update_value_task

unsafe def map_value : declaration → (expr → expr) → declaration
  | defn n ls t v h tr, f => defn n ls t (f v) h tr
  | thm n ls t v, f => thm n ls t (task.map f v)
  | d, f => d
#align declaration.map_value declaration.map_value

unsafe def to_definition : declaration → declaration
  | cnst n ls t tr => defn n ls t default ReducibilityHints.abbrev tr
  | ax n ls t => thm n ls t (task.pure default)
  | d => d
#align declaration.to_definition declaration.to_definition

unsafe def is_definition : declaration → Bool
  | defn _ _ _ _ _ _ => true
  | _ => false
#align declaration.is_definition declaration.is_definition

/-- Instantiate a universe polymorphic declaration type with the given universes. -/
unsafe axiom instantiate_type_univ_params : declaration → List level → Option expr
#align declaration.instantiate_type_univ_params declaration.instantiate_type_univ_params

/-- Instantiate a universe polymorphic declaration value with the given universes. -/
unsafe axiom instantiate_value_univ_params : declaration → List level → Option expr
#align declaration.instantiate_value_univ_params declaration.instantiate_value_univ_params

end Declaration


/-
  Extension of a sheaf of rings on the basis to a sheaf of rings on the whole space.

  https://stacks.math.columbia.edu/tag/009M
  https://stacks.math.columbia.edu/tag/009N
-/

import topology.opens
import sheaves.stalk_of_rings
import sheaves.stalk_of_rings_on_standard_basis
import sheaves.presheaf_of_rings_on_basis
import sheaves.presheaf_of_rings_extension
import sheaves.sheaf_on_basis
import sheaves.sheaf_on_standard_basis
import sheaves.sheaf_of_rings

open topological_space classical

noncomputable theory

universe u

section presheaf_of_rings_extension

variables {α : Type u} [T : topological_space α]
variables {B : set (opens α)} {HB : opens.is_basis B}
variables (Bstd : opens.univ ∈ B ∧ ∀ {U V}, U ∈ B → V ∈ B → U ∩ V ∈ B)

include Bstd

theorem extension_is_sheaf_of_rings
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
: is_sheaf_of_rings (F ᵣₑₓₜ Bstd) :=
begin
  show is_sheaf (F ᵣₑₓₜ Bstd).to_presheaf,
  constructor,
  { intros U OC s t Hres,
    apply subtype.eq,
    apply funext,
    intros x,
    apply funext,
    intros HxU,
    rw OC.Hcov.symm at HxU,
    rcases HxU with ⟨Uj1, ⟨⟨⟨Uj2, OUj⟩, ⟨⟨j, HUj⟩, Heq⟩⟩, HxUj⟩⟩,
    rcases Heq, rcases Heq,
    have Hstj := congr_fun (subtype.mk_eq_mk.1 (Hres j)),
    have HxUj1 : x ∈ OC.Uis j := HUj.symm ▸ HxUj,
    have Hstjx := congr_fun (Hstj x) HxUj1,
    exact Hstjx, },
  { intros U OC s Hsec,
    existsi (global_section (F.to_presheaf_on_basis) U OC s Hsec),
    intros i,
    apply subtype.eq,
    apply funext,
    intros x,
    apply funext,
    intros HxUi,
    have HxU : x ∈ U := OC.Hcov ▸ (opens_supr_subset OC.Uis i) HxUi,
    let HyUi := λ t, ∃ (H : t ∈ set.range OC.Uis), x ∈ t,
    dunfold presheaf_of_rings_extension; dsimp,
    dunfold global_section; dsimp,
    -- Same process of dealing with subtype.rec.
    let HyUi := λ t, ∃ (H : t ∈ subtype.val '' set.range OC.Uis), x ∈ t,
    rcases (classical.indefinite_description HyUi _) with ⟨S, HS⟩; dsimp,
    let HyS := λ H : S ∈ subtype.val '' set.range OC.Uis, x ∈ S,
    rcases (classical.indefinite_description HyS HS) with ⟨HSUiR, HySUiR⟩; dsimp,
    let HOUksub := λ t : subtype is_open, t ∈ set.range (OC.Uis) ∧ t.val = S,
    rcases (classical.indefinite_description HOUksub _) with ⟨OUl, ⟨HOUl, HOUleq⟩⟩; dsimp,
    let HSUi := λ i, OC.Uis i = OUl,
    cases (classical.indefinite_description HSUi _) with l HSUil; dsimp,
    -- Now we just need to apply Hsec in the right way.
    dunfold presheaf_of_rings_extension at Hsec,
    dunfold res_to_inter_left at Hsec,
    dunfold res_to_inter_right at Hsec,
    dsimp at Hsec,
    replace Hsec := Hsec i l,
    rw subtype.ext at Hsec,
    dsimp at Hsec,
    replace Hsec := congr_fun Hsec x,
    dsimp at Hsec,
    replace Hsec := congr_fun Hsec,
    have HxOUk : x ∈ OUl.val := HOUleq.symm ▸ HySUiR,
    have HxUl : x ∈ OC.Uis l := HSUil.symm ▸ HxOUk,
    exact (Hsec ⟨HxUi, HxUl⟩).symm, },
  end

section extension_coincides

-- The extension is done in a way that F(U) ≅ Fext(U).

-- The map ψ : F(U) → Π x ∈ U, Fx

def to_stalk_product (F : presheaf_on_basis α HB) {U : opens α} (BU : U ∈ B)
: F.F BU → Π (x ∈ U), stalk_on_basis F x :=
λ s x Hx, ⟦{U := U, BU := BU, Hx := Hx, s := s}⟧

lemma to_stalk_product.injective
(F : presheaf_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F)
{U : opens α} (BU : U ∈ B)
: function.injective (to_stalk_product Bstd F BU) :=
begin
  intros s₁ s₂ Hs,
  have Hsx := λ (HxU : U), congr_fun (congr_fun Hs HxU.1) HxU.2,
  let OC : covering_standard_basis B U :=
  { γ := U,
    Uis := λ HxU, some (quotient.eq.1 (Hsx HxU)),
    BUis := λ HxU, some (some_spec (quotient.eq.1 (Hsx HxU))),
    Hcov :=
      begin
        ext z,
        split,
        { rintros ⟨Ui, ⟨⟨OUi, ⟨⟨i, HUi⟩, HUival⟩⟩, HzUi⟩⟩,
          rw [←HUival, ←HUi] at HzUi,
          exact some (some_spec (some_spec (some_spec (quotient.eq.1 (Hsx i))))) HzUi, },
        { intros Hz,
          use [(some (quotient.eq.1 (Hsx ⟨z, Hz⟩))).val],
          have Hin : (some (quotient.eq.1 (Hsx ⟨z, Hz⟩))).val
            ∈ subtype.val '' set.range (λ (HxU : U), some ((quotient.eq.1 (Hsx HxU)))),
            use [classical.some ((quotient.eq.1 (Hsx ⟨z, Hz⟩)))],
            split,
            { use ⟨z, Hz⟩, },
            { refl, },
          use Hin,
          exact some (some_spec (some_spec (quotient.eq.1 (Hsx ⟨z, Hz⟩)))), },
      end, },
  apply (HF BU OC).1,
  intros i,
  replace Hs := congr_fun (congr_fun Hs i.1) i.2,
  exact some_spec (some_spec (some_spec (some_spec (some_spec (quotient.eq.1 (Hsx i)))))),
end

-- The map φ : F(U) → im(ψ).

def to_presheaf_of_rings_extension (F : presheaf_of_rings_on_basis α HB) {U : opens α} (BU : U ∈ B)
: F.F BU → (F ᵣₑₓₜ Bstd).F U :=
λ s,
  ⟨to_stalk_product Bstd F.to_presheaf_on_basis BU s,
   λ x Hx, ⟨U, BU, Hx, s, λ y Hy, funext $ λ Hy',
   quotient.sound $ ⟨U, BU, Hy', set.subset.refl U, set.subset.refl U, rfl⟩⟩⟩

lemma to_presheaf_of_rings_extension.injective
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: function.injective (to_presheaf_of_rings_extension Bstd F BU) :=
begin
  intros s₁ s₂ Hs,
  erw subtype.mk_eq_mk at Hs,
  have Hinj := to_stalk_product.injective Bstd F.to_presheaf_on_basis (λ V BV OC, HF BV OC) BU,
  exact Hinj Hs,
end

lemma to_presheaf_of_rings_extension.surjective
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: function.surjective (to_presheaf_of_rings_extension Bstd F BU) :=
begin
  intros s,
  let V := λ (HxU : U), some (s.2 HxU.1 HxU.2),
  let BV := λ (HxU : U), some (some_spec (s.2 HxU.1 HxU.2)),
  let HxV := λ (HxU : U), some (some_spec (some_spec (s.2 HxU.1 HxU.2))),
  let σ := λ (HxU : U), some (some_spec (some_spec (some_spec (s.2 HxU.1 HxU.2)))),
  let Hσ := λ (HxU : U), some_spec (some_spec (some_spec (some_spec (s.2 HxU.1 HxU.2)))),
  let OC : covering_standard_basis B U :=
  { γ := U,
    Uis := λ HxU, (V HxU) ∩ U,
    BUis := λ HxU, Bstd.2 (BV HxU) BU,
    Hcov :=
      begin
        ext z,
        split,
        { rintros ⟨Ui, ⟨⟨OUi, ⟨⟨i, HUi⟩, HUival⟩⟩, HzUi⟩⟩,
          rw [←HUival, ←HUi] at HzUi,
          exact HzUi.2, },
        { intros Hz,
          use [(some (s.2 z Hz) ∩ U).val],
          have Hin : (some (s.2 z Hz) ∩ U).val
            ∈ subtype.val '' set.range (λ (HxU : U), ((some (s.2 HxU.1 HxU.2) ∩ U : opens α))),
            use [(some (s.2 z Hz) ∩ U : opens α)],
            split,
            { use ⟨z, Hz⟩, },
            { refl, },
          use Hin,
          exact ⟨some (some_spec (some_spec (s.2 z Hz))), Hz⟩, },
      end, },
  -- Now let's try to apply sheaf condition.
  let res := λ (HxU : OC.γ), F.res (BV HxU) (Bstd.2 (BV HxU) BU) (set.inter_subset_left _ _),
  let sx := λ (HxU : OC.γ), res HxU (σ HxU),
  have Hglue := (HF BU OC).2 sx,
  have Hsx : ∀ j k,
    sheaf_on_standard_basis.res_to_inter_left Bstd F.to_presheaf_on_basis (OC.BUis j) (OC.BUis k) (sx j) =
    sheaf_on_standard_basis.res_to_inter_right Bstd F.to_presheaf_on_basis (OC.BUis j) (OC.BUis k) (sx k),
    intros j k,
    dsimp only [sheaf_on_standard_basis.res_to_inter_left],
    dsimp only [sheaf_on_standard_basis.res_to_inter_right],
    dsimp only [sx, res],
    iterate 2 { rw ←presheaf_on_basis.Hcomp', },
    show (F.to_presheaf_on_basis).res (BV j) (Bstd.2 (OC.BUis j) (OC.BUis k)) _ (σ j)
       = (F.to_presheaf_on_basis).res (BV k) (Bstd.2 (OC.BUis j) (OC.BUis k)) _ (σ k),
    -- We can cover the U ∩ Vj ∩ Vk and use locality.
    -- But first let's check that all the stalks coincide in the intersectons.
    have Hstalks : ∀ {y} (Hy : y ∈ (OC.Uis j) ∩ (OC.Uis k)),
        (⟦{U := V j, BU := BV j, Hx := Hy.1.1, s := σ j}⟧ : stalk_on_basis F.to_presheaf_on_basis y)
      = ⟦{U := V k, BU := BV k, Hx := Hy.2.1, s := σ k}⟧,
      intros y Hy,
      have Hj := congr_fun (Hσ j y ⟨Hy.1.2, Hy.1.1⟩) Hy.1.2; dsimp at Hj,
      have Hk := congr_fun (Hσ k y ⟨Hy.2.2, Hy.2.1⟩) Hy.2.2; dsimp at Hk,
      erw [←Hj, ←Hk],
    -- Therefore there exists Wjk where σj|Wjk = σk|Wjk. We will use these as a cover.
    let Ujk : opens α := (OC.Uis j) ∩ (OC.Uis k),
    let BUjk := Bstd.2 (OC.BUis j) (OC.BUis k),
    -- Again, all the information we will need but on Uj ∩ Uk.
    let Hjk := λ (HxUjk : Ujk), quotient.eq.1 (Hstalks HxUjk.2),
    let Wjk := λ (HxUjk : Ujk), some (Hjk HxUjk) ∩ U,
    let BWjk := λ (HxUjk : Ujk), Bstd.2 (some (some_spec (Hjk HxUjk))) BU,
    let HxWjk := λ (HxUjk : Ujk), some (some_spec (some_spec (Hjk HxUjk))),
    let HWjkUj := λ (HxUjk : Ujk), some (some_spec (some_spec (some_spec (Hjk HxUjk)))),
    let HWjkUk := λ (HxUjk : Ujk), some (some_spec (some_spec (some_spec (some_spec (Hjk HxUjk))))),
    let HWjk := λ (HxUjk : Ujk), some_spec (some_spec (some_spec (some_spec (some_spec (Hjk HxUjk))))),
    let OCjk : covering_standard_basis B ((OC.Uis j) ∩ (OC.Uis k)) :=
    { γ := Ujk,
      Uis := Wjk,
      BUis := BWjk,
      Hcov :=
        begin
          ext z,
          split,
          { rintros ⟨W, ⟨⟨OW, ⟨⟨i, HWi⟩, HWival⟩⟩, HzW⟩⟩,
            rw [←HWival, ←HWi] at HzW,
            have HzUj := (HWjkUj i) HzW.1,
            have HzUk := (HWjkUk i) HzW.1,
            exact ⟨⟨HzUj, HzW.2⟩, ⟨HzUk, HzW.2⟩⟩, },
          { intros Hz,
            use [(some (Hjk ⟨z, Hz⟩) ∩ U).val],
            have Hin : (some (Hjk ⟨z, Hz⟩) ∩ U).val
              ∈ subtype.val '' set.range (λ (HxUjk : Ujk), ((some (Hjk HxUjk) ∩ U : opens α))),
              use [(some (Hjk ⟨z, Hz⟩) ∩ U : opens α)],
              split,
              { use ⟨z, Hz⟩, },
              { refl, },
            use Hin,
            have HzWjk := HxWjk ⟨z, Hz⟩,
            have HzU := Hz.1.2,
            exact ⟨HzWjk, HzU⟩, }
        end, },
    apply (HF BUjk OCjk).1,
    intros i,
    rw ←presheaf_on_basis.Hcomp',
    rw ←presheaf_on_basis.Hcomp',
    have Hres :
        F.res (some (some_spec (Hjk i))) (BWjk i) (set.inter_subset_left _ _)
          (F.res (BV j) (some (some_spec (Hjk i))) (HWjkUj i) (σ j))
      = F.res (some (some_spec (Hjk i))) (BWjk i) (set.inter_subset_left _ _)
          (F.res (BV k) (some (some_spec (Hjk i))) (HWjkUk i) (σ k)),
      rw (HWjk i),
    rw ←presheaf_on_basis.Hcomp' at Hres,
    rw ←presheaf_on_basis.Hcomp' at Hres,
    use Hres,
  -- Ready to prove it.
  rcases (Hglue Hsx) with ⟨S, HS⟩,
  existsi S,
  apply subtype.eq,
  dsimp [to_presheaf_of_rings_extension],
  apply funext,
  intros x,
  dsimp [to_stalk_product],
  apply funext,
  intros Hx,
  replace HS := HS ⟨x, Hx⟩,
  dsimp [sx, res] at HS,
  rw Hσ ⟨x, Hx⟩,
  swap,
  { exact ⟨Hx, HxV ⟨x, Hx⟩⟩, },
  dsimp,
  apply quotient.sound,
  use [(V ⟨x, Hx⟩) ∩ U],
  use [Bstd.2 (BV ⟨x, Hx⟩) BU],
  use [⟨HxV ⟨x, Hx⟩, Hx⟩],
  use [set.inter_subset_right _ _],
  use [set.inter_subset_left _ _],
  dsimp,
  erw HS,
end

lemma to_presheaf_of_rings_extension.bijective
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: function.bijective (to_presheaf_of_rings_extension Bstd F BU) :=
⟨to_presheaf_of_rings_extension.injective Bstd F (λ U BU OC, HF BU OC) BU,
to_presheaf_of_rings_extension.surjective Bstd F (λ U BU OC, HF BU OC) BU ⟩

-- We now that they are equivalent as sets.
-- Now we to assert that they're isomorphic as rings.
-- It suffices to show that it is a ring homomorphism.

lemma to_presheaf_of_rings_extension.is_ring_hom
(F : presheaf_of_rings_on_basis α HB)
{U : opens α} (BU : U ∈ B)
: is_ring_hom (to_presheaf_of_rings_extension Bstd F BU) :=
{ map_one :=
    begin
      apply subtype.eq,
      funext x Hx,
      apply quotient.sound,
      use [U, BU, Hx, set.subset.refl _, set.subset_univ _],
      iterate 2 { erw (F.res_is_ring_hom _ _ _).map_one, },
    end,
  map_mul :=
    begin
      intros x y,
      apply subtype.eq,
      funext z Hz,
      apply quotient.sound,
      use [U, BU, Hz],
      use [set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _)],
      erw ←(F.res_is_ring_hom _ _ _).map_mul,
      erw ←presheaf_on_basis.Hcomp',
    end,
  map_add :=
    begin
      intros x y,
      apply subtype.eq,
      funext z Hz,
      apply quotient.sound,
      use [U, BU, Hz],
      use [set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _)],
      erw ←(F.res_is_ring_hom _ _ _).map_add,
      erw ←presheaf_on_basis.Hcomp',
    end, }

lemma to_presheaf_of_rings_extension.ring_equiv
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: F BU ≃+* (presheaf_of_rings_extension Bstd F) U :=
begin
  have H := function.bijective_iff_has_inverse.1 (to_presheaf_of_rings_extension.bijective Bstd F @HF BU),
  rcases (classical.indefinite_description _ H) with ⟨inv, Hlinv, Hrinv⟩,
  use [(to_presheaf_of_rings_extension Bstd F BU), inv, Hlinv, Hrinv],
  { apply (to_presheaf_of_rings_extension.is_ring_hom Bstd F BU).map_mul, },
  { apply (to_presheaf_of_rings_extension.is_ring_hom Bstd F BU).map_add, }
end

-- Moreover, for all x, Fₓ ≅ Fextₓ.

-- We will need this to show that the stalks of the structure sheaf on
-- Spec(R) are local rings.

open stalk_of_rings_on_standard_basis

lemma to_stalk_extension
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: stalk_of_rings_on_standard_basis Bstd F x → stalk_of_rings (F ᵣₑₓₜ Bstd) x :=
begin
  intros BUs,
  let Us := quotient.out BUs,
  exact ⟦{U := Us.U,
          HxU := Us.Hx,
          s := (to_presheaf_of_rings_extension Bstd F Us.BU) Us.s}⟧,
end

lemma to_stalk_extension.injective
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: function.injective (to_stalk_extension Bstd F x) :=
begin
  intros Us₁' Us₂',
  apply quotient.induction_on₂ Us₁' Us₂',
  rintros Us₁ Us₂ HUs,
  rcases (quotient.mk_out Us₁) with ⟨W₁, BW₁, HxW₁, HW₁Us₁, HW₁U₁, Hres₁⟩,
  rcases (quotient.mk_out Us₂) with ⟨W₂, BW₂, HxW₂, HW₂Us₂, HW₂U₂, Hres₂⟩,
  dunfold to_stalk_extension at HUs,
  rw quotient.eq at HUs,
  rcases HUs with ⟨W, HxW, HWU₁, HWU₂, Hres⟩,
  dsimp at HWU₁,
  dsimp at HWU₂,
  dunfold to_presheaf_of_rings_extension at Hres,
  dunfold to_stalk_product at Hres,
  erw subtype.mk.inj_eq at Hres,
  replace Hres := congr_fun (congr_fun Hres x) HxW,
  dsimp at Hres,
  rw quotient.eq at Hres,
  rcases Hres with ⟨W₃, BW₃, HxW₃, HW₃U₁, HW₃U₂, Hres₃⟩,
  dsimp at HW₃U₁,
  dsimp at HW₃U₂,
  dsimp at Hres₃,
  apply quotient.sound,
  have BW₁₂₃ : W₁ ∩ W₂ ∩ W₃ ∈ B := Bstd.2 (Bstd.2 BW₁ BW₂) BW₃,
  have HW₁₂₃U₁ : W₁ ∩ W₂ ∩ W₃ ⊆ Us₁.U := λ x Hx, HW₁U₁ Hx.1.1,
  have HW₁₂₃U₂ : W₁ ∩ W₂ ∩ W₃ ⊆ Us₂.U := λ x Hx, HW₂U₂ Hx.1.2,
  use [W₁ ∩ W₂ ∩ W₃, BW₁₂₃, ⟨⟨HxW₁, HxW₂⟩, HxW₃⟩, HW₁₂₃U₁, HW₁₂₃U₂],
  have HW₁W₁₂₃ : W₁ ∩ W₂ ∩ W₃ ⊆ W₁ := λ x Hx, Hx.1.1,
  have HW₂W₁₂₃ : W₁ ∩ W₂ ∩ W₃ ⊆ W₂ := λ x Hx, Hx.1.2,
  have HW₃W₁₂₃ : W₁ ∩ W₂ ∩ W₃ ⊆ W₃ := λ x Hx, Hx.2,
  replace Hres₁ := congr_arg (F.res BW₁ BW₁₂₃ HW₁W₁₂₃) Hres₁,
  replace Hres₂ := congr_arg (F.res BW₂ BW₁₂₃ HW₂W₁₂₃) Hres₂,
  replace Hres₃ := congr_arg (F.res BW₃ BW₁₂₃ HW₃W₁₂₃) Hres₃,
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₂, },
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₃, },
  erw [←Hres₁, ←Hres₂],
  exact Hres₃,
end

lemma to_stalk_extension.surjective
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: function.surjective (to_stalk_extension Bstd F x) :=
begin
  intros Us',
  apply quotient.induction_on Us',
  rintros ⟨U, HxU, s⟩,
  rcases (s.2 x HxU) with ⟨V, BV, HxV, t, Ht⟩,
  let Vt : stalk_on_basis.elem (F.to_presheaf_on_basis) x
    := {U := V, BU := BV, Hx := HxV, s := t},
  use ⟦Vt⟧,
  dunfold to_stalk_extension,
  apply quotient.sound,
  rcases (quotient.mk_out Vt) with ⟨W, BW, HxW, HWVtV, HWV, Hres⟩,
  have HUVWV : U ∩ V ∩ W ⊆ (quotient.out ⟦Vt⟧).U := λ x Hx, HWVtV Hx.2,
  have HUVWU : U ∩ V ∩ W ⊆ U := λ x Hx, Hx.1.1,
  use [U ∩ V ∩ W, ⟨⟨HxU, HxV⟩, HxW⟩, HUVWV, HUVWU],
  apply subtype.eq,
  dsimp only [presheaf_of_rings_extension],
  dsimp only [to_presheaf_of_rings_extension],
  dsimp only [to_stalk_product],
  funext y Hy,
  rw (Ht y Hy.1),
  apply quotient.sound,
  have BVW : V ∩ W ∈ B := Bstd.2 BV BW,
  have HVWVtV : V ∩ W ⊆ (quotient.out ⟦Vt⟧).U := λ x Hx, HWVtV Hx.2,
  have HVWV : V ∩ W ⊆ V := λ x Hx, Hx.1,
  use [V ∩ W, BVW, ⟨Hy.1.2,Hy.2⟩, HVWVtV, HVWV],
  have HVWW : V ∩ W ⊆ W := λ x Hx, Hx.2,
  replace Hres := congr_arg (F.res BW BVW HVWW) Hres,
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres, },
  exact Hres,
end

lemma to_stalk_extension.bijective
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: function.bijective (to_stalk_extension Bstd F x) :=
⟨to_stalk_extension.injective Bstd F x,
to_stalk_extension.surjective Bstd F x⟩

lemma to_stalk_extension.is_ring_hom
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: is_ring_hom (to_stalk_extension Bstd F x) :=
{ map_one :=
    begin
      dunfold to_stalk_extension,
      let one.elem : stalk_on_basis.elem F.to_presheaf_on_basis x
        := {U := opens.univ, BU := Bstd.1, Hx := trivial, s:= 1},
      let one.stalk : stalk_of_rings_on_standard_basis Bstd F x := ⟦one.elem⟧,
      let one := quotient.out one.stalk,
      apply quotient.sound,
      rcases (quotient.mk_out one.elem) with ⟨W₁, BW₁, HxW₁, HW₁Uout, HW₁U, Hres₁⟩,
      have BUW₁ : one.U ∩ W₁ ∈ B := Bstd.2 one.BU BW₁,
      have HUUW₁ : one.U ∩ W₁ ⊆ one.U := set.inter_subset_left _ _,
      use [one.U ∩ W₁, ⟨one.Hx, HxW₁⟩, HUUW₁, set.subset_univ _],
      apply subtype.eq,
      dsimp only [presheaf_of_rings_extension],
      dsimp only [to_presheaf_of_rings_extension],
      dsimp only [to_stalk_product],
      funext z Hz,
      apply quotient.sound,
      use [one.U ∩ W₁, BUW₁, Hz, set.inter_subset_left _ _, set.subset_univ _],
      dsimp,
      have HUW₁W₁ : one.U ∩ W₁ ⊆ W₁ := set.inter_subset_right _ _,
      replace Hres₁ := congr_arg (F.res BW₁ BUW₁ HUW₁W₁) Hres₁,
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
      exact Hres₁,
    end,
  map_mul :=
    begin
      intros y z,
      apply quotient.induction_on₂ y z,
      intros Us₁ Us₂,
      simp,
      let Us₃ : stalk_on_basis.elem F.to_presheaf_on_basis x :=
        { U := Us₁.U ∩ Us₂.U,
          BU := Bstd.2 Us₁.BU Us₂.BU,
          Hx := ⟨Us₁.Hx, Us₂.Hx⟩,
          s :=  F.res Us₁.BU _ (set.inter_subset_left _ _) Us₁.s *
                F.res Us₂.BU _ (set.inter_subset_right _ _) Us₂.s },
      dunfold to_stalk_extension,
      apply quotient.sound,
      rcases (quotient.mk_out Us₁) with ⟨W₁, BW₁, HxW₁, HW₁U₁out, HW₁U₁, Hres₁⟩,
      rcases (quotient.mk_out Us₂) with ⟨W₂, BW₂, HxW₂, HW₂U₂out, HW₂U₂, Hres₂⟩,
      rcases (quotient.mk_out Us₃) with ⟨W₃, BW₃, HxW₃, HW₃U₃out, HW₃U₃, Hres₃⟩,
      let W := W₁ ∩ W₂ ∩ W₃,
      have HxW : x ∈ W := ⟨⟨HxW₁, HxW₂⟩, HxW₃⟩,
      have HWW₁ : W ⊆ W₁ := λ x Hx, Hx.1.1,
      have HWW₂ : W ⊆ W₂ := λ x Hx, Hx.1.2,
      have HWW₃ : W ⊆ W₃ := λ x Hx, Hx.2,
      have HWU₁out : W ⊆ (quotient.out ⟦Us₁⟧).U := set.subset.trans HWW₁ HW₁U₁out,
      have HWU₂out : W ⊆ (quotient.out ⟦Us₂⟧).U := set.subset.trans HWW₂ HW₂U₂out,
      have HWU₃out : W ⊆ (quotient.out ⟦Us₃⟧).U := set.subset.trans HWW₃ HW₃U₃out,
      have HWU₁₂out : W ⊆ (quotient.out ⟦Us₁⟧).U ∩ (quotient.out ⟦Us₂⟧).U
        := set.subset_inter HWU₁out HWU₂out,
      use [W, HxW, HWU₃out, HWU₁₂out],
      apply subtype.eq,
      dsimp only [presheaf_of_rings_extension],
      dsimp only [to_presheaf_of_rings_extension],
      dsimp only [to_stalk_product],
      funext z HzW,
      apply quotient.sound,
      have BW : W ∈ B := Bstd.2 (Bstd.2 BW₁ BW₂) BW₃,
      use [W, BW, HzW, HWU₃out, HWU₁₂out],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_mul,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
      replace Hres₁ := congr_arg (F.res BW₁ BW HWW₁) Hres₁,
      replace Hres₂ := congr_arg (F.res BW₂ BW HWW₂) Hres₂,
      replace Hres₃ := congr_arg (F.res BW₃ BW HWW₃) Hres₃,
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₂, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₃, },
      erw [Hres₁, Hres₂, Hres₃],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_mul,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
    end,
  map_add :=
    begin
      intros y z,
      apply quotient.induction_on₂ y z,
      intros Us₁ Us₂,
      simp,
      let Us₃ : stalk_on_basis.elem F.to_presheaf_on_basis x :=
        { U := Us₁.U ∩ Us₂.U,
          BU := Bstd.2 Us₁.BU Us₂.BU,
          Hx := ⟨Us₁.Hx, Us₂.Hx⟩,
          s :=  F.res Us₁.BU _ (set.inter_subset_left _ _) Us₁.s +
                F.res Us₂.BU _ (set.inter_subset_right _ _) Us₂.s },
      dunfold to_stalk_extension,
      apply quotient.sound,
      rcases (quotient.mk_out Us₁) with ⟨W₁, BW₁, HxW₁, HW₁U₁out, HW₁U₁, Hres₁⟩,
      rcases (quotient.mk_out Us₂) with ⟨W₂, BW₂, HxW₂, HW₂U₂out, HW₂U₂, Hres₂⟩,
      rcases (quotient.mk_out Us₃) with ⟨W₃, BW₃, HxW₃, HW₃U₃out, HW₃U₃, Hres₃⟩,
      let W := W₁ ∩ W₂ ∩ W₃,
      have HxW : x ∈ W := ⟨⟨HxW₁, HxW₂⟩, HxW₃⟩,
      have HWW₁ : W ⊆ W₁ := λ x Hx, Hx.1.1,
      have HWW₂ : W ⊆ W₂ := λ x Hx, Hx.1.2,
      have HWW₃ : W ⊆ W₃ := λ x Hx, Hx.2,
      have HWU₁out : W ⊆ (quotient.out ⟦Us₁⟧).U := set.subset.trans HWW₁ HW₁U₁out,
      have HWU₂out : W ⊆ (quotient.out ⟦Us₂⟧).U := set.subset.trans HWW₂ HW₂U₂out,
      have HWU₃out : W ⊆ (quotient.out ⟦Us₃⟧).U := set.subset.trans HWW₃ HW₃U₃out,
      have HWU₁₂out : W ⊆ (quotient.out ⟦Us₁⟧).U ∩ (quotient.out ⟦Us₂⟧).U
        := set.subset_inter HWU₁out HWU₂out,
      use [W, HxW, HWU₃out, HWU₁₂out],
      apply subtype.eq,
      dsimp only [presheaf_of_rings_extension],
      dsimp only [to_presheaf_of_rings_extension],
      dsimp only [to_stalk_product],
      funext z HzW,
      apply quotient.sound,
      have BW : W ∈ B := Bstd.2 (Bstd.2 BW₁ BW₂) BW₃,
      use [W, BW, HzW, HWU₃out, HWU₁₂out],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_add,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
      replace Hres₁ := congr_arg (F.res BW₁ BW HWW₁) Hres₁,
      replace Hres₂ := congr_arg (F.res BW₂ BW HWW₂) Hres₂,
      replace Hres₃ := congr_arg (F.res BW₃ BW HWW₃) Hres₃,
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₂, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₃, },
      erw [Hres₁, Hres₂, Hres₃],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_add,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
    end, }

lemma to_stalk_extension.ring_equiv
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: stalk_of_rings_on_standard_basis Bstd F x ≃+*
stalk_of_rings (presheaf_of_rings_extension Bstd F) x :=
begin
  have H := function.bijective_iff_has_inverse.1 (to_stalk_extension.bijective Bstd F x),
  rcases (classical.indefinite_description _ H) with ⟨inv, Hlinv, Hrinv⟩,
  use [(to_stalk_extension Bstd F x), inv, Hlinv, Hrinv],
  { apply (to_stalk_extension.is_ring_hom Bstd F x).map_mul, },
  { apply (to_stalk_extension.is_ring_hom Bstd F x).map_add, }
end

end extension_coincides

end presheaf_of_rings_extension


import category_theory.triangulated.triangulated
import for_mathlib.category_theory.triangulated.triangulated_functor

noncomputable theory

open category_theory category_theory.category category_theory.limits
open_locale zero_object

namespace set

open category_theory

class respects_iso {X : Type*} [category X] (A : set X) : Prop :=
(condition' : ∀ ⦃x y : X⦄ (e : x ≅ y) (hx : x ∈ A), y ∈ A)

lemma respects_iso.condition {X : Type*} [category X] (A : set X) [A.respects_iso]
  {x y : X} (e : x ≅ y) (hx : x ∈ A) : y ∈ A :=
respects_iso.condition' e hx

lemma respects_iso.mem_iff_of_iso {X : Type*} [category X] (A : set X) [A.respects_iso]
  {x y : X} (e : x ≅ y) : x ∈ A ↔ y ∈ A :=
begin
  split,
  { exact respects_iso.condition A e, },
  { exact respects_iso.condition A e.symm, },
end

end set

namespace category_theory

namespace triangulated

open pretriangulated

variables {C : Type*} [category C] [has_shift C ℤ] [preadditive C] [has_zero_object C]
  [∀ (n : ℤ), functor.additive (shift_functor C n)] [pretriangulated C]

variable (S : set C)

class is_triangulated_subcategory : Prop :=
(zero [] : (0 : C) ∈ S)
(shift : ∀ (X : C) (n : ℤ) (hX : X ∈ S), (shift_functor C n).obj X ∈ S)
(ext₂ : ∀ (T : triangle C) (hT : T ∈ dist_triang C) (h₁ : T.obj₁ ∈ S)
  (h₃ : T.obj₃ ∈ S), T.obj₂ ∈ S)

namespace is_triangulated_subcategory

variables (S) [is_triangulated_subcategory S]

@[priority 100]
instance set_respects_iso : S.respects_iso :=
⟨λ X Y e hX, ext₂ _ (pretriangulated.isomorphic_distinguished _
  (pretriangulated.contractible_distinguished X) (triangle.mk e.hom (0 : Y ⟶ 0) 0)
  (triangle.mk_iso _ _ (iso.refl _) e.symm (iso.refl _) (by tidy) (by tidy) (by tidy))) hX
  (is_triangulated_subcategory.zero S)⟩

lemma zero' (X : C) (hX : is_zero X) : X ∈ S :=
by simpa only [set.respects_iso.mem_iff_of_iso S (limits.is_zero.iso_zero hX)]
  using is_triangulated_subcategory.zero S

variable {S}

lemma ext₁
  (T : triangle C) (hT : T ∈ dist_triang C) (h₂ : T.obj₂ ∈ S) (h₃ : T.obj₃ ∈ S) :
  T.obj₁ ∈ S :=
ext₂ T.inv_rotate (pretriangulated.inv_rot_of_dist_triangle C T hT)
  (is_triangulated_subcategory.shift _ _ h₃) h₂

lemma ext₃
  (T : triangle C) (hT : T ∈ dist_triang C) (h₁ : T.obj₁ ∈ S) (h₂ : T.obj₂ ∈ S) :
  T.obj₃ ∈ S :=
ext₂ T.rotate (pretriangulated.rot_of_dist_triangle C T hT) h₂
  (is_triangulated_subcategory.shift _ _ h₁)

lemma shift_iff (X : C) (n : ℤ) : X ∈ S ↔ (shift_functor C n).obj X ∈ S :=
begin
  split,
  { intro h,
    exact is_triangulated_subcategory.shift _ _ h, },
  { intro h,
    exact set.respects_iso.condition S
      ((add_neg_equiv (shift_monoidal_functor C ℤ) n).unit_iso.symm.app X)
      (is_triangulated_subcategory.shift _ _ h), },
end

end is_triangulated_subcategory

class is_triangulated_subcategory' : Prop :=
(zero : ∃ (X : C) (hX₀ : is_zero X), X ∈ S)
(shift : ∀ (X : C) (n : ℤ) (hX : X ∈ S), (shift_functor C n).obj X ∈ S)
(distinguished_cocone_triangle' : ∀ (X Y : C) (hX : X ∈ S) (hY : Y ∈ S) (f : X ⟶ Y),
  ∃ (Z : C) (hZ : Z ∈ S) (g : Y ⟶ Z) (h : Z ⟶ X⟦(1 : ℤ)⟧),
    triangle.mk f g h ∈ dist_triang C)

@[priority 100]
instance is_triangulated_subcategory'_of_is_triangulated_subcategory
  [hS : is_triangulated_subcategory S] :
  is_triangulated_subcategory' S :=
{ zero := ⟨0, is_zero_zero _, hS.zero⟩,
  shift := hS.shift,
  distinguished_cocone_triangle' := λ X Y hX hY f, begin
    obtain ⟨Z, g, h, mem⟩ := pretriangulated.distinguished_cocone_triangle _ _ f,
    exact ⟨Z, hS.ext₂ _ (rot_of_dist_triangle _ _ mem) hY (hS.shift _ 1 hX), g, h, mem⟩,
  end, }

namespace is_triangulated_subcategory'

variable [hS : is_triangulated_subcategory' S]

include hS

instance : has_zero_object (full_subcategory S) :=
begin
  obtain ⟨X₀, hX₀, mem⟩ := hS.zero,
  refine ⟨⟨⟨X₀, mem⟩, _⟩⟩,
  rw limits.is_zero.iff_id_eq_zero,
  exact (full_subcategory_inclusion S).map_injective (is_zero.eq_of_src hX₀ _ _),
end

instance is_stable_by_shift : S.is_stable_by_shift ℤ :=
⟨λ a X hX, hS.shift X a hX⟩

instance shift_functor_additive (n : ℤ) :
  (category_theory.shift_functor (full_subcategory S) n).additive :=
⟨begin
  rintros ⟨K, hK⟩ ⟨L, hL⟩ f g,
  exact (full_subcategory_inclusion S).map_injective (category_theory.shift_functor C n).map_add,
end⟩

--instance full_subcategory_inclusion_has_comm_shift :
--  (full_subcategory_inclusion S).has_comm_shift ℤ := infer_instance

def distinguished_triangles : set (triangle (full_subcategory S)) :=
λ T, (full_subcategory_inclusion S).map_triangle.obj T ∈ dist_triang C

lemma isomorphic_distinguished (T₁ : triangle (full_subcategory S))
  (hT₁ : T₁ ∈ distinguished_triangles S) (T₂ : triangle (full_subcategory S)) (e : T₂ ≅ T₁) :
  T₂ ∈ distinguished_triangles S :=
pretriangulated.isomorphic_distinguished _ hT₁ _ ((full_subcategory_inclusion S).map_triangle.map_iso e)

lemma contractible_distinguished (X : full_subcategory S) :
  triangle.mk (𝟙 X) (0 : X ⟶ 0) 0 ∈ distinguished_triangles S :=
begin
  refine pretriangulated.isomorphic_distinguished _
    (pretriangulated.contractible_distinguished ((full_subcategory_inclusion S).obj X)) _ _,
  refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _)
    (full_subcategory_inclusion S).map_zero_object _ _ _,
  tidy,
end

lemma rotate_distinguished_triangle (T : triangle (full_subcategory S)) :
  T ∈ distinguished_triangles S ↔
    T.rotate ∈ distinguished_triangles S :=
begin
  change ((full_subcategory_inclusion S).map_triangle.obj T ∈ dist_triang C) ↔
    ((full_subcategory_inclusion S).map_triangle.obj T.rotate ∈ dist_triang C),
  rw pretriangulated.rotate_distinguished_triangle,
  let e := (full_subcategory_inclusion S).map_triangle_rotate.app T,
  split,
  { exact λ h, pretriangulated.isomorphic_distinguished _ h _ e.symm, },
  { exact λ h, pretriangulated.isomorphic_distinguished _ h _ e, },
end

lemma distinguished_cocone_triangle (X Y : full_subcategory S) (f : X ⟶ Y) :
  ∃ (Z : full_subcategory S) (g : Y ⟶ Z) (h : Z ⟶ (category_theory.shift_functor _ (1 : ℤ)).obj X),
    triangle.mk f g h ∈ distinguished_triangles S :=
begin
  obtain ⟨X, hX⟩ := X,
  obtain ⟨Y, hY⟩ := Y,
  obtain ⟨Z, hZ, g, h, mem⟩ := hS.distinguished_cocone_triangle' _ _ hX hY f,
  refine ⟨⟨Z, hZ⟩, g, h, pretriangulated.isomorphic_distinguished _ mem _ _⟩,
  refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _) (by tidy) (by tidy) _,
  { dsimp,
    simp only [functor.map_id, comp_id, id_comp],
    apply comp_id, },
end

lemma complete_distinguished_triangle_morphism (T₁ T₂ : triangle (full_subcategory S))
  (hT₁ : T₁ ∈ distinguished_triangles S) (hT₂ : T₂ ∈ distinguished_triangles S)
  (a : T₁.obj₁ ⟶ T₂.obj₁) (b : T₁.obj₂ ⟶ T₂.obj₂) (h : T₁.mor₁ ≫ b = a ≫ T₂.mor₁) :
  ∃ (c : T₁.obj₃ ⟶ T₂.obj₃), T₁.mor₂ ≫ c = b ≫ T₂.mor₂ ∧ T₁.mor₃ ≫
    (category_theory.shift_functor _ 1).map a = c ≫ T₂.mor₃ :=
begin
  obtain ⟨c, ⟨hc₁, hc₂⟩⟩ := pretriangulated.complete_distinguished_triangle_morphism
    ((full_subcategory_inclusion S).map_triangle.obj T₁)
      ((full_subcategory_inclusion S).map_triangle.obj T₂)
    hT₁ hT₂ a b h,
  refine ⟨c, ⟨hc₁, _⟩⟩,
  dsimp at hc₂,
  erw [comp_id, comp_id] at hc₂,
  exact hc₂,
end

instance pretriangulated_full_subcategory :
  pretriangulated (full_subcategory S) :=
{ distinguished_triangles := distinguished_triangles S,
  isomorphic_distinguished := isomorphic_distinguished S,
  contractible_distinguished := contractible_distinguished S,
  distinguished_cocone_triangle := distinguished_cocone_triangle S,
  rotate_distinguished_triangle := rotate_distinguished_triangle S,
  complete_distinguished_triangle_morphism := complete_distinguished_triangle_morphism S, }

instance [is_triangulated C] : is_triangulated (full_subcategory S) :=
⟨λ X₁ X₂ X₃ Z₁₂ Z₂₃ Z₁₃ u₁₂ u₂₃ u₁₃ comm v₁₂ w₁₂ h₁₂ v₂₃ w₂₃ h₂₃ v₁₃ w₁₃ h₁₃, begin
  have comm' := (full_subcategory_inclusion S).congr_map comm,
  rw [functor.map_comp] at comm',
  have H := (is_triangulated.octahedron_axiom comm' h₁₂ h₂₃ h₁₃).some,
  obtain ⟨m₁, m₃, comm₁, comm₂, comm₃, comm₄, H'⟩ := H,
  refine nonempty.intro
  { m₁ := m₁,
    m₃ := m₃,
    comm₁ := comm₁,
    comm₂ := begin
      erw [comp_id, comp_id] at comm₂,
      exact comm₂,
    end,
    comm₃ := comm₃,
    comm₄ := begin
      erw [comp_id, comp_id] at comm₄,
      exact comm₄,
    end,
    mem := begin
      change _ ∈ dist_triang C,
      refine pretriangulated.isomorphic_distinguished _ H' _ _,
      refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _) _ _ _,
      { dsimp,
        simp, },
      { dsimp,
        simp, },
      { dsimp,
        erw [functor.map_id, comp_id, comp_id, id_comp, comp_id],
        refl, },
    end, }
end⟩

instance full_subcategory_inclusion_is_triangulated :
  (full_subcategory_inclusion S).is_triangulated :=
{ map_distinguished' := λ T hT, hT, }

end is_triangulated_subcategory'

class saturated [is_triangulated_subcategory S] : Prop :=
(condition : ∀ ⦃X Y : C⦄ (i : Y ⟶ X) [hi : is_split_mono i] (hX : X ∈ S), Y ∈ S)

def left_orthogonal : set C :=
λ X, ∀ ⦃Y : C⦄ (f : X ⟶ Y) (hY : Y ∈ S), f = 0

def right_orthogonal : set C :=
λ Y, ∀ ⦃X : C⦄ (f : X ⟶ Y) (hX : X ∈ S), f = 0

instance [S.is_stable_by_shift ℤ] :
  is_triangulated_subcategory (left_orthogonal S) :=
{ zero := λ Y hY f, subsingleton.elim _ _,
  shift := λ X n hX Y f hY, begin
    let adj : shift_functor C n ⊣ shift_functor C (-n) :=
      (add_neg_equiv (shift_monoidal_functor C ℤ) n).to_adjunction,
    apply (adj.hom_equiv _ _).injective,
    simp only [adjunction.hom_equiv_unit, functor.map_zero, comp_zero],
    exact hX _ (set.is_stable_by_shift.condition (-n) Y hY),
  end,
  ext₂ := λ T hT h₁ h₃ Y f hY, begin
    obtain ⟨g, hg⟩ := contravariant_yoneda_exact₂ T hT f (h₁ _ hY),
    rw [hg, h₃ g hY, comp_zero],
  end, }

instance [S.is_stable_by_shift ℤ] :
  is_triangulated_subcategory (right_orthogonal S) :=
{ zero := λ X hX f, subsingleton.elim _ _,
  shift := λ Y n hY X f hX, begin
    let adj : shift_functor C (-n) ⊣ shift_functor C n :=
      (add_neg_equiv (shift_monoidal_functor C ℤ) n).symm.to_adjunction,
    apply (adj.hom_equiv _ _).symm.injective,
    simp only [adjunction.hom_equiv_counit, functor.map_zero, zero_comp],
    exact hY _ (set.is_stable_by_shift.condition (-n) X hX),
  end,
  ext₂ := λ T hT h₁ h₃ X f hX, begin
    obtain ⟨g, hg⟩ := covariant_yoneda_exact₂ T hT f (h₃ _ hX),
    rw [hg, h₁ g hX, zero_comp],
  end, }

instance left_orthogonal_saturated [S.is_stable_by_shift ℤ] :
  saturated (left_orthogonal S) :=
⟨λ X Y i hi hX Z f hZ, begin
  haveI := hi,
  rw [← cancel_epi (retraction i), comp_zero],
  exact hX _ hZ,
end⟩

instance right_orthogonal_saturated [S.is_stable_by_shift ℤ] :
  saturated (right_orthogonal S) :=
⟨λ X Y i hi hX Z f hZ, begin
  haveI := hi,
  rw [← cancel_mono i, zero_comp],
  exact hX _ hZ,
end⟩

end triangulated

namespace functor

namespace is_triangulated

section

variables {C D E : Type*} [category C] [category D] [category E]
  [has_zero_object C] [has_zero_object D] [has_zero_object E]
  [has_shift C ℤ] [has_shift D ℤ] [has_shift E ℤ]
  [preadditive C] [preadditive D] [preadditive E]
  [∀ (n : ℤ), (shift_functor C n).additive]
  [∀ (n : ℤ), (shift_functor D n).additive]
  [∀ (n : ℤ), (shift_functor E n).additive]
  [pretriangulated C] [pretriangulated D] [pretriangulated E]
  {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} (e : F ⋙ G ≅ H)
  [full G] [faithful G]
  [F.has_comm_shift ℤ] [H.has_comm_shift ℤ] [G.has_comm_shift ℤ]
  [functor.is_triangulated G] [functor.is_triangulated H]

lemma of_fully_faithful [e.hom.respects_comm_shift ℤ] : F.is_triangulated :=
{ map_distinguished' := λ T hT, G.reflects_distinguished _
    (pretriangulated.isomorphic_distinguished _ (H.map_distinguished T hT) _
    (((map_triangle_comp F G).app T).symm ≪≫ (map_triangle_nat_iso e).app T)), }

lemma of_fully_faithful' :
  @functor.is_triangulated _ _ _ _ _ _ _ _ F (has_comm_shift.of_fully_faithful e ℤ) _ _ _ _ _ _ :=
begin
  letI := has_comm_shift.of_fully_faithful e ℤ,
  haveI := has_comm_shift.of_fully_faithful_iso_hom_respects_comm_shift e ℤ,
  exact of_fully_faithful e,
end

end

section

variables {C D : Type*} [category C] [category D]
  [has_zero_object C] [has_zero_object D]
  [has_shift C ℤ] [has_shift D ℤ]
  [preadditive C] [preadditive D]
  [∀ (n : ℤ), (shift_functor C n).additive]
  [∀ (n : ℤ), (shift_functor D n).additive]
  [pretriangulated C] [pretriangulated D]
  (S : set D) (F : C ⥤ D) [F.has_comm_shift ℤ] [functor.is_triangulated F]
  [S.is_stable_by_shift ℤ] [triangulated.is_triangulated_subcategory' S]
  (hS : ∀ (X : C), F.obj X ∈ S)

instance full_subcategory_lift_is_triangulated :
  (full_subcategory.lift S F hS).is_triangulated :=
of_fully_faithful (full_subcategory.lift_comp_inclusion S F hS)

end

end is_triangulated

end functor

end category_theory


import number_theory.padics.padic_integers

--OUTPUT 1
theorem padic_units {p : ℕ} (hp : prime p) (x : ℕ) (hx : coprime p x) : is_unit (pint p x) :=
begin
  contrapose hx,
  -- Since $x$ is not coprime to $p$, we can write $x = pk$ for some $k \in \N$.
  obtain ⟨k, hk⟩ : ∃ k : ℕ, x = p*k, from sorry,
  -- Now, $\Vert x \Vert = \Vert pk \Vert = p^{-1}$
  have h1 := sorry,
  -- Since $\Vert x \Vert < 1$, we must have $p^{-1} < 1$.
  have h2 := sorry,
  -- This is a contradiction, since $p^{-1} = p^{-1}$, and thus $p^{-1} = 1$.
  have h3 := sorry,
  exact h3,
end

--OUTPUT 2
theorem p_adic_units (p x: ℕ) : p.prime → x.coprime p → x ∈ units (p_adic_naturals p) :=
begin
  -- prove the contrapositive
  intro h1, intro h2,
  -- We know that any element of $\mathbb{Z}_p$ is a unit iff it has norm 1
  have h3 : ∀ z : p_adic_naturals p, z.val ∈ units (p_adic_naturals p) ↔ z.norm = 1, from sorry,
  -- thus $\Vert x \Vert \neq 1$
  have h4 : (⟪x⟫ p).norm ≠ 1, from sorry,
  -- Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1
  have h5 : ∀ z : p_adic_naturals p, z.norm ≤ 1, from sorry,
  -- we conclude that $\Vert x \Vert < 1$
  have h6 : (⟪x⟫ p).norm < 1, from sorry,
  -- But this must imply that $p | x$.
  have h7 : p ∣ x, from sorry,
  -- This completes our proof.
  show x ∉ units (p_adic_naturals p), from sorry,
end

--OUTPUT 3
theorem p_adic_units (p : ℕ) (x : ℕ) : coprime p x → ∃ y ∈ ℤ_p, y * (x : ℤ_p) = 1 :=
begin
  have h1 : ∀ x : ℕ, (x : ℤ_p) ≠ 0 → (1 : ℤ_p) ∈ units (x : ℤ_p), from sorry,
  have h2 : ∀ x : ℕ, (x : ℤ_p) ≠ 0 → (x : ℤ_p) ∈ units (x : ℤ_p) ↔ (x : ℤ_p) * (x : ℤ_p) = 1, from sorry,
  have h3 : ∀ x : ℕ, (x : ℤ_p) ≠ 0 → (x : ℤ_p) ∈ units (x : ℤ_p) ↔
    ∃ y : ℤ_p, (x : ℤ_p) * y = 1, from sorry,
  have h4 : ∀ x : ℕ, (x : ℤ_p) ≠ 0 → ∃ y : ℤ_p, (x : ℤ_p) * y = 1, from sorry,
  have h5 : ∀ x : ℕ, (x : ℤ_p) ≠ 0 → ∃ y ∈ ℤ_p, (x : ℤ_p) * y = 1, from sorry,
  have h6 : ∀ x : ℕ, (x : ℤ_p) ≠ 0 → coprime p x → ∃ y ∈ ℤ_p, (x : ℤ_p) * y = 1, from sorry,
  show coprime p x → ∃ y ∈ ℤ_p, y * (x : ℤ_p) = 1, from sorry,
end

--OUTPUT 4
theorem p_adic_units (p : ℕ) (x : ℕ) : coprime p x → is_unit (x : ℤₚ) :=
begin
  assume h1,
  have h2 : ∀ x : ℤₚ, x ∣ p → ¬is_unit x, from sorry,
  have h3 : x ∣ p, from sorry,
  have h4 : ¬is_unit x, from sorry,
  show is_unit x, from sorry,
end

--OUTPUT 5
theorem p_adic_units (p x : ℕ) (h : prime p) (h' : gcd x p = 1) : ∃ a : ℕ, x * a = 1 :=
begin
  -- prove the contrapositive
  have h1 : ¬ (∃ a : ℕ, x * a = 1), from by {
    assume (h1 : ∃ a : ℕ, x * a = 1),
    have h2 : ∃ b : ℕ, p * b = 1, from sorry,
    have h3 : ∃ c : ℕ, (x * c) * (p * b) = x, from sorry,
    have h4 : ∃ d : ℕ, x * (p * (b * c) + d) = x, from sorry,
    have h5 : ∃ e : ℕ, x * e = x, from sorry,
    have h6 : ∀ y : ℕ, x * y = x → y = 1, from sorry,
    have h7 : p * (b * c) + d = 1, from sorry,
    have h8 : p | 1, from sorry,
    have h9 : p = 1, from sorry,
    have h10 : ¬ prime p, from sorry,
    contradiction,
  },
  have h2 : ∃ a : ℕ, x * a ≠ 1, from sorry,
  have h3 : ∃ a : ℕ, x * a ∈ ℤ, from sorry,
  have h4 : ∃ a : ℤ, x * a ∈ ℤ, from sorry,
  have h5 : ∃ a : ℤ, (x * a) mod p ∈ ℤ, from sorry,
  have h6 : ∃ a : ℤ, x * a mod p ∈ ℤ, from sorry,
  have h7 : ∃ a : ℤ, ((x * a) mod p) mod p ∈ ℤ, from sorry,
  have h8 : ∃ a : ℤ, (x * a) mod p mod p ∈ ℤ, from sorry,
  have h9 : ∃ a : ℤ, x * a mod p mod p ∈ ℤ, from sorry,
  have h10 : ∃ a : ℤ, (x * a mod p) mod p ∈ ℤ, from sorry,
  have h11 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h12 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h13 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h14 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h15 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h16 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h17 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h18 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h19 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h20 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h21 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h22 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h23 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h24 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h25 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h26 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h27 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h28 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h29 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h30 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h31 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h32 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h33 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h34 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h35 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h36 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h37 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h38 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h39 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h40 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h41 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h42 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h43 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h44 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h45 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h46 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h47 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h48 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h49 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h50 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h51 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h52 : ∃ a : ℤ, x * a mod (p * p) ∈ ℤ, from sorry,
  have h53 : ∃ a : ℤ, (x * a) mod (p * p) ∈ ℤ, from sorry,
  have h54 : ∃ a : ℤ
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem padic_units (p : ℕ) (x : ℕ) : p.prime → coprime p x → x.units (padic_int p) :=
begin
  sorry,
end

--OUTPUT 7
theorem p_adic_units (p : ℕ) (x : ℕ) (hx : coprime x p) : is_unit (x : ℤ_[p]) :=
begin
  -- We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$.
  have h1 : (∀ x : ℤ_[p], (norm_val x = 1) ↔ is_unit x), from sorry,
  have h2 : (norm_val (x : ℤ_[p]) = 1) ↔ is_unit (x : ℤ_[p]), from sorry,
  have h3 : ¬ (norm_val (x : ℤ_[p]) = 1), from sorry,

  -- Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
  have h4 : ∀ x : ℤ_[p], (norm_val x : ℤ) ≤ 1, from sorry,
  have h5 : (norm_val (x : ℤ_[p]) : ℤ) ≤ 1, from sorry,
  have h6 : (norm_val (x : ℤ_[p]) : ℤ) ≠ 1, from sorry,
  have h7 : (norm_val (x : ℤ_[p]) : ℤ) < 1, from sorry,

  -- But this must imply that $p | x$.
  have h8 : p ∣ x, from sorry,

  -- This completes our proof.
  show is_unit (x : ℤ_[p]), from sorry,
end

--OUTPUT 8
theorem p_adic_units (p : ℕ) (x : ℕ) (h : coprime p x) : is_unit (x % p) :=
begin
  -- Prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
  -- We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$.
  -- Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
  -- But this must imply that $p | x$.
  -- This completes our proof.
  assume h1 : ¬ is_unit (x % p),
  have h2 : (x % p) ≠ 1, from sorry,
  have h3 : (x % p) ≠ -1, from sorry,
  have h4 : (x % p) ≠ 0, from sorry,
  have h5 : (x % p) ≠ -0, from sorry,
  have h6 : (x % p) ≠ (1 : ℤ), from sorry,
  have h7 : (x % p) ≠ (-1 : ℤ), from sorry,
  have h8 : (x % p) ≠ (0 : ℤ), from sorry,
  have h9 : (x % p) ≠ (-0 : ℤ), from sorry,
  have h10 : (x % p) ≠ (1 : ℚ), from sorry,
  have h11 : (x % p) ≠ (-1 : ℚ), from sorry,
  have h12 : (x % p) ≠ (0 : ℚ), from sorry,
  have h13 : (x % p) ≠ (-0 : ℚ), from sorry,
  have h14 : (x % p) ≠ (1 : ℝ), from sorry,
  have h15 : (x % p) ≠ (-1 : ℝ), from sorry,
  have h16 : (x % p) ≠ (0 : ℝ), from sorry,
  have h17 : (x % p) ≠ (-0 : ℝ), from sorry,
  have h18 : (x % p) ≠ (1 : ℂ), from sorry,
  have h19 : (x % p) ≠ (-1 : ℂ), from sorry,
  have h20 : (x % p) ≠ (0 : ℂ), from sorry,
  have h21 : (x % p) ≠ (-0 : ℂ), from sorry,
  have h22 : (x % p) ≠ (1 : ℍ), from sorry,
  have h23 : (x % p) ≠ (-1 : ℍ), from sorry,
  have h24 : (x % p) ≠ (0 : ℍ), from sorry,
  have h25 : (x % p) ≠ (-0 : ℍ), from sorry,
  have h26 : (x % p) ≠ (1 : ℕ), from sorry,
  have h27 : (x % p) ≠ (-1 : ℕ), from sorry,
  have h28 : (x % p) ≠ (0 : ℕ), from sorry,
  have h29 : (x % p) ≠ (-0 : ℕ), from sorry,
  have h30 : (x % p) ≠ (1 : ℤ), from sorry,
  have h31 : (x % p) ≠ (-1 : ℤ), from sorry,
  have h32 : (x % p) ≠ (0 : ℤ), from sorry,
  have h33 : (x % p) ≠ (-0 : ℤ), from sorry,
  have h34 : (x % p) ≠ (1 : ℚ), from sorry,
  have h35 : (x % p) ≠ (-1 : ℚ), from sorry,
  have h36 : (x % p) ≠ (0 : ℚ), from sorry,
  have h37 : (x % p) ≠ (-0 : ℚ), from sorry,
  have h38 : (x % p) ≠ (1 : ℝ), from sorry,
  have h39 : (x % p) ≠ (-1 : ℝ), from sorry,
  have h40 : (x % p) ≠ (0 : ℝ), from sorry,
  have h41 : (x % p) ≠ (-0 : ℝ), from sorry,
  have h42 : (x % p) ≠ (1 : ℂ), from sorry,
  have h43 : (x % p) ≠ (-1 : ℂ), from sorry,
  have h44 : (x % p) ≠ (0 : ℂ), from sorry,
  have h45 : (x % p) ≠ (-0 : ℂ), from sorry,
  have h46 : (x % p) ≠ (1 : ℍ), from sorry,
  have h47 : (x % p) ≠ (-1 : ℍ), from sorry,
  have h48 : (x % p) ≠ (0 : ℍ), from sorry,
  have h49 : (x % p) ≠ (-0 : ℍ), from sorry,
  have h50 : (x % p) ≠ (1 : ℕ), from sorry,
  have h51 : (x % p) ≠ (-1 : ℕ), from sorry,
  have h52 : (x % p) ≠ (0 : ℕ), from sorry,
  have h53 : (x % p) ≠ (-0 : ℕ), from sorry,
  have h54 : (x % p) ≠ (1 : ℤ), from sorry,
  have h55 : (x % p) ≠ (-1 : ℤ), from sorry,
  have h56 : (x % p) ≠ (0 : ℤ), from sorry,
  have h57 : (x % p) ≠ (-0 : ℤ), from sorry,
  have h58 : (x % p) ≠ (1 : ℚ), from sorry,
  have h59 : (x % p) ≠ (-1 : ℚ), from sorry,
  have h60 : (x % p) ≠ (0 : ℚ), from sorry,
  have h61 : (x % p) ≠ (-0 : ℚ), from sorry,
  have h62 : (x % p) ≠ (1 : ℝ), from sorry,
  have h63 : (x % p) ≠ (-1 : ℝ), from sorry,
  have h64 : (x % p) ≠ (0 : ℝ), from sorry,
  have h65 : (x % p) ≠ (-0 : ℝ), from sorry,
  have h66 : (x % p) ≠ (1 : ℂ), from sorry,
  have h67 : (x % p) ≠ (-1 : ℂ), from sorry,
  have h68 : (x % p) ≠ (0 : ℂ), from sorry,
  have h69 : (x % p) ≠ (-0 : ℂ), from sorry,
  have h70 : (x % p) ≠ (1 : ℍ), from sorry,
  have h71 : (x % p) ≠ (-1 : ℍ), from sorry,
  have h72 : (x % p) ≠ (0 : ℍ), from sorry,
  have h73 : (x % p) ≠ (-0 : ℍ), from sorry,
  have h74 : (x % p) ≠ (1 : ℕ), from sorry,
  have h75 : (x % p) ≠ (-1 : ℕ), from sorry,
  have h76 : (x % p) ≠ (0 : ℕ), from sorry,
  have h77 : (x % p) ≠ (-0 : ℕ), from sorry,
  have h78 : (x % p) ≠ (1 : ℤ), from sorry,
  have h79 : (x % p) ≠ (-1 : ℤ), from sorry,
  have h80 : (x % p) ≠ (0 : ℤ), from
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from sorry,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from sorry,
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by sorry
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by sorry
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
p-adic units
Given a prime number $p$ and a natural number $x$, if $x$ is coprime to $p$, then $x$ is a unit in the $p$-adic integers.
`proof`
Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$. Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
But this must imply that $p | x$.
This completes our proof.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


import Duper.MClause
import Duper.RuleM
import Duper.Simp
import Duper.Util.ProofReconstruction

namespace Duper
open Lean
open Meta
open RuleM
open SimpResult

initialize Lean.registerTraceClass `Rule.forallHoist

theorem forall_hoist_proof {y : α → Prop} (x : α) (f : Prop → Prop) (h : f (∀ z : α, y z)) : f False ∨ y x = True := by
  by_cases y_always_true : ∀ z : α, y z
  . exact Or.inr (eq_true (y_always_true x))
  . rename ¬∀ (z : α), y z => y_not_always_true
    exact Or.inl (eq_false y_not_always_true ▸ h)

def mkForallHoistProof (pos : ClausePos) (premises : List Expr)
  (parents : List ProofParent) (transferExprs : Array Expr) (c : Clause) : MetaM Expr :=
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!

    let #[freshVar1] := transferExprs
      | throwError "mkForallHoistProof :: Wrong number of number of newVarIndices"

    let mut caseProofs := Array.mkEmpty parentLits.size
    for i in [:parentLits.size] do
      let lit := parentLits[i]!
      let pr : Expr ← Meta.withLocalDeclD `h lit.toExpr fun h => do
        if i == pos.lit then
          let substLitPos : LitPos := ⟨pos.side, pos.pos⟩
          let abstrLit ← (lit.abstractAtPos! substLitPos)
          let abstrExp := abstrLit.toExpr
          let abstrLam := mkLambda `x BinderInfo.default (mkSort levelZero) abstrExp
          let lastTwoLitsProof ← Meta.mkAppM ``forall_hoist_proof #[freshVar1, abstrLam, h]
          Meta.mkLambdaFVars #[h] $ ← orSubclause (cLits.map Lit.toExpr) 2 lastTwoLitsProof
        else
          let idx := if i ≥ pos.lit then i - 1 else i
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
      caseProofs := caseProofs.push pr
    let r ← orCases (parentLits.map Lit.toExpr) caseProofs
    Meta.mkLambdaFVars xs $ mkApp r appliedPremise

/-- Returns the dependent forall and lambda expressions -/
def mkForallAndLambda (freshVar1Ty : Expr) : MetaM (Expr × Expr) :=
  Meta.withLocalDeclD `_ freshVar1Ty fun fvar => do
    let newMVar ← Meta.mkFreshExprMVar (mkSort levelZero)
    let forallExpr ← Meta.mkForallFVars #[fvar] newMVar
    let lambdaExpr ← Meta.mkLambdaFVars #[fvar] newMVar
    return (forallExpr, lambdaExpr)

def forallHoistAtExpr (e : Expr) (pos : ClausePos) (given : Clause) (c : MClause) : RuleM (Array ClauseStream) :=
  withoutModifyingMCtx do
    let lit := c.lits[pos.lit]!
    if e.getTopSymbol.isMVar then -- Check condition 4
      -- If the head of e is a variable then it must be applied and the affected literal must be either
      -- e = True, e = False, or e = e' where e' is another variable headed term
      if not e.isApp then -- e is a non-applied variable and so we cannot apply neHoist
        return #[]
      if pos.pos != #[] then
        return #[] -- e is not at the top level so the affected literal cannot have the form e = ...
      if not lit.sign then
        return #[] -- The affected literal is not positive and so it cannot have the form e = ...
      let otherSide := lit.getOtherSide pos.side
      if otherSide != (mkConst ``True) && otherSide != (mkConst ``False) && not otherSide.getTopSymbol.isMVar then
        return #[] -- The other side is not True, False, or variable headed, so the affected literal cannot have the required form
    -- Check conditions 1 and 3 (condition 2 is guaranteed by construction)
    let eligibility ← eligibilityPreUnificationCheck c pos.lit
    if eligibility == Eligibility.notEligible then
      return #[]
    let freshVar1 ← mkFreshExprMVar none
    let freshVar1Ty ← inferType freshVar1
    let (freshVarForallExpr, freshVarLambdaExpr) ← mkForallAndLambda freshVar1Ty
    let newLitLhs ← Meta.whnf (.app freshVarLambdaExpr freshVar1)
    -- Perform unification
    let ug ← unifierGenerator #[(e, freshVarForallExpr)]
    let loaded ← getLoadedClauses
    let yC := do
      setLoadedClauses loaded
      if not $ ← eligibilityPostUnificationCheck c pos.lit eligibility (strict := lit.sign) then
        return none
      let eSide ← instantiateMVars $ lit.getSide pos.side
      let otherSide ← instantiateMVars $ lit.getOtherSide pos.side
      let cmp ← compare eSide otherSide
      if cmp == Comparison.LessThan || cmp == Comparison.Equal then -- If eSide ≤ otherSide then e is not in an eligible position
        return none
      -- Additional constraint: We don't want to perform forallHoist if e was actually unified with an implication
      if (← instantiateMVars (← inferType freshVar1Ty)).isProp then
        return none
      -- All side conditions have been met. Yield the appropriate clause
      let cErased := c.eraseLit pos.lit
      -- Need to instantiate mvars in newLitLhs because unification assigned to mvars in it
      let newLitLhs ← instantiateMVars newLitLhs
      let newLitLhs ← Meta.whnf newLitLhs -- newLitLhs probably has the form (λ x, stuff) x, so perform the application
      let newClause := cErased.appendLits #[← lit.replaceAtPos! ⟨pos.side, pos.pos⟩ (mkConst ``False), Lit.fromSingleExpr newLitLhs (sign := true)]
      trace[Rule.forallHoist] "Created {newClause.lits} from {c.lits}"
      yieldClause newClause "forallHoist" (some (mkForallHoistProof pos)) (transferExprs := #[freshVar1])
    return #[ClauseStream.mk ug given yC "forallHoist"]

def forallHoist (given : Clause) (c : MClause) (cNum : Nat) : RuleM (Array ClauseStream) := do
  trace[Rule.forallHoist] "Running ForallHoist on {c.lits}"
  let fold_fn := fun streams e pos => do
    let str ← forallHoistAtExpr e.consumeMData pos given c
    return streams.append str
  c.foldGreenM fold_fn #[]


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Sean Leather

Functions on lists of sigma types.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.perm
import Mathlib.data.list.range
import Mathlib.data.sigma.default
import Mathlib.PostPort

universes u v u_1 u_2

namespace Mathlib

namespace list

/- keys -/

/-- List of keys from a list of key-value pairs -/
def keys {α : Type u} {β : α → Type v} : List (sigma β) → List α := map sigma.fst

@[simp] theorem keys_nil {α : Type u} {β : α → Type v} : keys [] = [] := rfl

@[simp] theorem keys_cons {α : Type u} {β : α → Type v} {s : sigma β} {l : List (sigma β)} :
    keys (s :: l) = sigma.fst s :: keys l :=
  rfl

theorem mem_keys_of_mem {α : Type u} {β : α → Type v} {s : sigma β} {l : List (sigma β)} :
    s ∈ l → sigma.fst s ∈ keys l :=
  mem_map_of_mem sigma.fst

theorem exists_of_mem_keys {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)}
    (h : a ∈ keys l) : ∃ (b : β a), sigma.mk a b ∈ l :=
  sorry

theorem mem_keys {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)} :
    a ∈ keys l ↔ ∃ (b : β a), sigma.mk a b ∈ l :=
  sorry

theorem not_mem_keys {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)} :
    ¬a ∈ keys l ↔ ∀ (b : β a), ¬sigma.mk a b ∈ l :=
  iff.trans (not_iff_not_of_iff mem_keys) not_exists

theorem not_eq_key {α : Type u} {β : α → Type v} {a : α} {l : List (sigma β)} :
    ¬a ∈ keys l ↔ ∀ (s : sigma β), s ∈ l → a ≠ sigma.fst s :=
  sorry

/- nodupkeys -/

def nodupkeys {α : Type u} {β : α → Type v} (l : List (sigma β)) := nodup (keys l)

theorem nodupkeys_iff_pairwise {α : Type u} {β : α → Type v} {l : List (sigma β)} :
    nodupkeys l ↔ pairwise (fun (s s' : sigma β) => sigma.fst s ≠ sigma.fst s') l :=
  pairwise_map sigma.fst

theorem nodupkeys.pairwise_ne {α : Type u} {β : α → Type v} {l : List (sigma β)} (h : nodupkeys l) :
    pairwise (fun (s s' : sigma β) => sigma.fst s ≠ sigma.fst s') l :=
  iff.mp nodupkeys_iff_pairwise h

@[simp] theorem nodupkeys_nil {α : Type u} {β : α → Type v} : nodupkeys [] := pairwise.nil

@[simp] theorem nodupkeys_cons {α : Type u} {β : α → Type v} {s : sigma β} {l : List (sigma β)} :
    nodupkeys (s :: l) ↔ ¬sigma.fst s ∈ keys l ∧ nodupkeys l :=
  sorry

theorem nodupkeys.eq_of_fst_eq {α : Type u} {β : α → Type v} {l : List (sigma β)} (nd : nodupkeys l)
    {s : sigma β} {s' : sigma β} (h : s ∈ l) (h' : s' ∈ l) : sigma.fst s = sigma.fst s' → s = s' :=
  sorry

theorem nodupkeys.eq_of_mk_mem {α : Type u} {β : α → Type v} {a : α} {b : β a} {b' : β a}
    {l : List (sigma β)} (nd : nodupkeys l) (h : sigma.mk a b ∈ l) (h' : sigma.mk a b' ∈ l) :
    b = b' :=
  sorry

theorem nodupkeys_singleton {α : Type u} {β : α → Type v} (s : sigma β) : nodupkeys [s] :=
  nodup_singleton (sigma.fst s)

theorem nodupkeys_of_sublist {α : Type u} {β : α → Type v} {l₁ : List (sigma β)}
    {l₂ : List (sigma β)} (h : l₁ <+ l₂) : nodupkeys l₂ → nodupkeys l₁ :=
  nodup_of_sublist (sublist.map sigma.fst h)

theorem nodup_of_nodupkeys {α : Type u} {β : α → Type v} {l : List (sigma β)} :
    nodupkeys l → nodup l :=
  nodup_of_nodup_map sigma.fst

theorem perm_nodupkeys {α : Type u} {β : α → Type v} {l₁ : List (sigma β)} {l₂ : List (sigma β)}
    (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ :=
  perm.nodup_iff (perm.map sigma.fst h)

theorem nodupkeys_join {α : Type u} {β : α → Type v} {L : List (List (sigma β))} :
    nodupkeys (join L) ↔
        (∀ (l : List (sigma β)), l ∈ L → nodupkeys l) ∧ pairwise disjoint (map keys L) :=
  sorry

theorem nodup_enum_map_fst {α : Type u} (l : List α) : nodup (map prod.fst (enum l)) := sorry

theorem mem_ext {α : Type u} {β : α → Type v} {l₀ : List (sigma β)} {l₁ : List (sigma β)}
    (nd₀ : nodup l₀) (nd₁ : nodup l₁) (h : ∀ (x : sigma β), x ∈ l₀ ↔ x ∈ l₁) : l₀ ~ l₁ :=
  sorry

/- lookup -/

/-- `lookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) : List (sigma β) → Option (β a) :=
  sorry

@[simp] theorem lookup_nil {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) :
    lookup a [] = none :=
  rfl

@[simp] theorem lookup_cons_eq {α : Type u} {β : α → Type v} [DecidableEq α]
    (l : List (sigma fun (a : α) => β a)) (a : α) (b : β a) :
    lookup a (sigma.mk a b :: l) = some b :=
  dif_pos rfl

@[simp] theorem lookup_cons_ne {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma β))
    {a : α} (s : sigma β) : a ≠ sigma.fst s → lookup a (s :: l) = lookup a l :=
  sorry

theorem lookup_is_some {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} :
    ↥(option.is_some (lookup a l)) ↔ a ∈ keys l :=
  sorry

theorem lookup_eq_none {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} :
    lookup a l = none ↔ ¬a ∈ keys l :=
  sorry

theorem of_mem_lookup {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l : List (sigma β)} : b ∈ lookup a l → sigma.mk a b ∈ l :=
  sorry

theorem mem_lookup {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l : List (sigma β)} (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : b ∈ lookup a l :=
  sorry

theorem map_lookup_eq_find {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    (l : List (sigma β)) :
    option.map (sigma.mk a) (lookup a l) = find (fun (s : sigma β) => a = sigma.fst s) l :=
  sorry

theorem mem_lookup_iff {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l : List (sigma β)} (nd : nodupkeys l) : b ∈ lookup a l ↔ sigma.mk a b ∈ l :=
  { mp := of_mem_lookup, mpr := mem_lookup nd }

theorem perm_lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l₁ : List (sigma β)}
    {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (nd₂ : nodupkeys l₂) (p : l₁ ~ l₂) :
    lookup a l₁ = lookup a l₂ :=
  sorry

theorem lookup_ext {α : Type u} {β : α → Type v} [DecidableEq α] {l₀ : List (sigma β)}
    {l₁ : List (sigma β)} (nd₀ : nodupkeys l₀) (nd₁ : nodupkeys l₁)
    (h : ∀ (x : α) (y : β x), y ∈ lookup x l₀ ↔ y ∈ lookup x l₁) : l₀ ~ l₁ :=
  sorry

/- lookup_all -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) :
    List (sigma β) → List (β a) :=
  sorry

@[simp] theorem lookup_all_nil {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) :
    lookup_all a [] = [] :=
  rfl

@[simp] theorem lookup_all_cons_eq {α : Type u} {β : α → Type v} [DecidableEq α]
    (l : List (sigma fun (a : α) => β a)) (a : α) (b : β a) :
    lookup_all a (sigma.mk a b :: l) = b :: lookup_all a l :=
  dif_pos rfl

@[simp] theorem lookup_all_cons_ne {α : Type u} {β : α → Type v} [DecidableEq α]
    (l : List (sigma β)) {a : α} (s : sigma β) :
    a ≠ sigma.fst s → lookup_all a (s :: l) = lookup_all a l :=
  sorry

theorem lookup_all_eq_nil {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l : List (sigma β)} : lookup_all a l = [] ↔ ∀ (b : β a), ¬sigma.mk a b ∈ l :=
  sorry

theorem head_lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) :
    head' (lookup_all a l) = lookup a l :=
  sorry

theorem mem_lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l : List (sigma β)} : b ∈ lookup_all a l ↔ sigma.mk a b ∈ l :=
  sorry

theorem lookup_all_sublist {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    (l : List (sigma β)) : map (sigma.mk a) (lookup_all a l) <+ l :=
  sorry

theorem lookup_all_length_le_one {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    {l : List (sigma β)} (h : nodupkeys l) : length (lookup_all a l) ≤ 1 :=
  sorry

theorem lookup_all_eq_lookup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    {l : List (sigma β)} (h : nodupkeys l) : lookup_all a l = option.to_list (lookup a l) :=
  sorry

theorem lookup_all_nodup {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l : List (sigma β)}
    (h : nodupkeys l) : nodup (lookup_all a l) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nodup (lookup_all a l))) (lookup_all_eq_lookup a h)))
    (option.to_list_nodup (lookup a l))

theorem perm_lookup_all {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) {l₁ : List (sigma β)}
    {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (nd₂ : nodupkeys l₂) (p : l₁ ~ l₂) :
    lookup_all a l₁ = lookup_all a l₂ :=
  sorry

/- kreplace -/

def kreplace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) :
    List (sigma β) → List (sigma β) :=
  lookmap
    fun (s : sigma β) =>
      dite (a = sigma.fst s) (fun (h : a = sigma.fst s) => some (sigma.mk a b))
        fun (h : ¬a = sigma.fst s) => none

theorem kreplace_of_forall_not {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a)
    {l : List (sigma β)} (H : ∀ (b : β a), ¬sigma.mk a b ∈ l) : kreplace a b l = l :=
  sorry

theorem kreplace_self {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l : List (sigma β)} (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : kreplace a b l = l :=
  sorry

theorem keys_kreplace {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a)
    (l : List (sigma β)) : keys (kreplace a b l) = keys l :=
  sorry

theorem kreplace_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a)
    {l : List (sigma β)} : nodupkeys (kreplace a b l) ↔ nodupkeys l :=
  sorry

theorem perm.kreplace {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd : nodupkeys l₁) :
    l₁ ~ l₂ → kreplace a b l₁ ~ kreplace a b l₂ :=
  sorry

/- kerase -/

/-- Remove the first pair with the key `a`. -/
def kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) :
    List (sigma β) → List (sigma β) :=
  erasep fun (s : sigma β) => a = sigma.fst s

@[simp] theorem kerase_nil {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} :
    kerase a [] = [] :=
  rfl

@[simp] theorem kerase_cons_eq {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : sigma β}
    {l : List (sigma β)} (h : a = sigma.fst s) : kerase a (s :: l) = l :=
  sorry

@[simp] theorem kerase_cons_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {s : sigma β}
    {l : List (sigma β)} (h : a ≠ sigma.fst s) : kerase a (s :: l) = s :: kerase a l :=
  sorry

@[simp] theorem kerase_of_not_mem_keys {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l : List (sigma β)} (h : ¬a ∈ keys l) : kerase a l = l :=
  sorry

theorem kerase_sublist {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : List (sigma β)) :
    kerase a l <+ l :=
  erasep_sublist l

theorem kerase_keys_subset {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    (l : List (sigma β)) : keys (kerase a l) ⊆ keys l :=
  sublist.subset (sublist.map sigma.fst (kerase_sublist a l))

theorem mem_keys_of_mem_keys_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a₁ : α} {a₂ : α}
    {l : List (sigma β)} : a₁ ∈ keys (kerase a₂ l) → a₁ ∈ keys l :=
  kerase_keys_subset a₂ l

theorem exists_of_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)}
    (h : a ∈ keys l) :
    ∃ (b : β a),
        ∃ (l₁ : List (sigma β)),
          ∃ (l₂ : List (sigma β)),
            ¬a ∈ keys l₁ ∧ l = l₁ ++ sigma.mk a b :: l₂ ∧ kerase a l = l₁ ++ l₂ :=
  sorry

@[simp] theorem mem_keys_kerase_of_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a₁ : α}
    {a₂ : α} {l : List (sigma β)} (h : a₁ ≠ a₂) : a₁ ∈ keys (kerase a₂ l) ↔ a₁ ∈ keys l :=
  sorry

theorem keys_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l : List (sigma β)} :
    keys (kerase a l) = list.erase (keys l) a :=
  sorry

theorem kerase_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α}
    {l : List (sigma β)} : kerase a (kerase a' l) = kerase a' (kerase a l) :=
  sorry

theorem kerase_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    {l : List (sigma β)} : nodupkeys l → nodupkeys (kerase a l) :=
  nodupkeys_of_sublist (kerase_sublist a l)

theorem perm.kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {l₁ : List (sigma β)}
    {l₂ : List (sigma β)} (nd : nodupkeys l₁) : l₁ ~ l₂ → kerase a l₁ ~ kerase a l₂ :=
  perm.erasep (fun (s : sigma β) => a = sigma.fst s)
    (pairwise.imp
      (fun (x y : sigma β) (h : sigma.fst x ≠ sigma.fst y) (ᾰ : a = sigma.fst x) =>
        Eq._oldrec h (Eq.symm ᾰ))
      (iff.mp nodupkeys_iff_pairwise nd))

@[simp] theorem not_mem_keys_kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    {l : List (sigma β)} (nd : nodupkeys l) : ¬a ∈ keys (kerase a l) :=
  sorry

@[simp] theorem lookup_kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    {l : List (sigma β)} (nd : nodupkeys l) : lookup a (kerase a l) = none :=
  iff.mpr lookup_eq_none (not_mem_keys_kerase a nd)

@[simp] theorem lookup_kerase_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α}
    {l : List (sigma β)} (h : a ≠ a') : lookup a (kerase a' l) = lookup a l :=
  sorry

theorem kerase_append_left {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} :
    a ∈ keys l₁ → kerase a (l₁ ++ l₂) = kerase a l₁ ++ l₂ :=
  sorry

theorem kerase_append_right {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} :
    ¬a ∈ keys l₁ → kerase a (l₁ ++ l₂) = l₁ ++ kerase a l₂ :=
  sorry

theorem kerase_comm {α : Type u} {β : α → Type v} [DecidableEq α] (a₁ : α) (a₂ : α)
    (l : List (sigma β)) : kerase a₂ (kerase a₁ l) = kerase a₁ (kerase a₂ l) :=
  sorry

theorem sizeof_kerase {α : Type u_1} {β : α → Type u_2} [DecidableEq α] [SizeOf (sigma β)] (x : α)
    (xs : List (sigma β)) : sizeof (kerase x xs) ≤ sizeof xs :=
  sorry

/- kinsert -/

/-- Insert the pair `⟨a, b⟩` and erase the first pair with the key `a`. -/
def kinsert {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (l : List (sigma β)) :
    List (sigma β) :=
  sigma.mk a b :: kerase a l

@[simp] theorem kinsert_def {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l : List (sigma β)} : kinsert a b l = sigma.mk a b :: kerase a l :=
  rfl

theorem mem_keys_kinsert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b' : β a'}
    {l : List (sigma β)} : a ∈ keys (kinsert a' b' l) ↔ a = a' ∨ a ∈ keys l :=
  sorry

theorem kinsert_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a)
    {l : List (sigma β)} (nd : nodupkeys l) : nodupkeys (kinsert a b l) :=
  iff.mpr nodupkeys_cons { left := not_mem_keys_kerase a nd, right := kerase_nodupkeys a nd }

theorem perm.kinsert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (p : l₁ ~ l₂) :
    kinsert a b l₁ ~ kinsert a b l₂ :=
  perm.cons (sigma.mk a b) (perm.kerase nd₁ p)

theorem lookup_kinsert {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    (l : List (sigma β)) : lookup a (kinsert a b l) = some b :=
  sorry

theorem lookup_kinsert_ne {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {a' : α} {b' : β a'}
    {l : List (sigma β)} (h : a ≠ a') : lookup a (kinsert a' b' l) = lookup a l :=
  sorry

/- kextract -/

def kextract {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) :
    List (sigma β) → Option (β a) × List (sigma β) :=
  sorry

@[simp] theorem kextract_eq_lookup_kerase {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    (l : List (sigma β)) : kextract a l = (lookup a l, kerase a l) :=
  sorry

/- erase_dupkeys -/

/-- Remove entries with duplicate keys from `l : list (sigma β)`. -/
def erase_dupkeys {α : Type u} {β : α → Type v} [DecidableEq α] : List (sigma β) → List (sigma β) :=
  foldr (fun (x : sigma β) => kinsert (sigma.fst x) (sigma.snd x)) []

theorem erase_dupkeys_cons {α : Type u} {β : α → Type v} [DecidableEq α] {x : sigma β}
    (l : List (sigma β)) :
    erase_dupkeys (x :: l) = kinsert (sigma.fst x) (sigma.snd x) (erase_dupkeys l) :=
  rfl

theorem nodupkeys_erase_dupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma β)) :
    nodupkeys (erase_dupkeys l) :=
  sorry

theorem lookup_erase_dupkeys {α : Type u} {β : α → Type v} [DecidableEq α] (a : α)
    (l : List (sigma β)) : lookup a (erase_dupkeys l) = lookup a l :=
  sorry

theorem sizeof_erase_dupkeys {α : Type u_1} {β : α → Type u_2} [DecidableEq α] [SizeOf (sigma β)]
    (xs : List (sigma β)) : sizeof (erase_dupkeys xs) ≤ sizeof xs :=
  sorry

/- kunion -/

/-- `kunion l₁ l₂` is the append to l₁ of l₂ after, for each key in l₁, the
first matching pair in l₂ is erased. -/
def kunion {α : Type u} {β : α → Type v} [DecidableEq α] :
    List (sigma β) → List (sigma β) → List (sigma β) :=
  sorry

@[simp] theorem nil_kunion {α : Type u} {β : α → Type v} [DecidableEq α] {l : List (sigma β)} :
    kunion [] l = l :=
  rfl

@[simp] theorem kunion_nil {α : Type u} {β : α → Type v} [DecidableEq α] {l : List (sigma β)} :
    kunion l [] = l :=
  sorry

@[simp] theorem kunion_cons {α : Type u} {β : α → Type v} [DecidableEq α] {s : sigma β}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} :
    kunion (s :: l₁) l₂ = s :: kunion l₁ (kerase (sigma.fst s) l₂) :=
  rfl

@[simp] theorem mem_keys_kunion {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} :
    a ∈ keys (kunion l₁ l₂) ↔ a ∈ keys l₁ ∨ a ∈ keys l₂ :=
  sorry

@[simp] theorem kunion_kerase {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} :
    kunion (kerase a l₁) (kerase a l₂) = kerase a (kunion l₁ l₂) :=
  sorry

theorem kunion_nodupkeys {α : Type u} {β : α → Type v} [DecidableEq α] {l₁ : List (sigma β)}
    {l₂ : List (sigma β)} (nd₁ : nodupkeys l₁) (nd₂ : nodupkeys l₂) : nodupkeys (kunion l₁ l₂) :=
  sorry

theorem perm.kunion_right {α : Type u} {β : α → Type v} [DecidableEq α] {l₁ : List (sigma β)}
    {l₂ : List (sigma β)} (p : l₁ ~ l₂) (l : List (sigma β)) : kunion l₁ l ~ kunion l₂ l :=
  sorry

theorem perm.kunion_left {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (sigma β))
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} :
    nodupkeys l₁ → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂ :=
  sorry

theorem perm.kunion {α : Type u} {β : α → Type v} [DecidableEq α] {l₁ : List (sigma β)}
    {l₂ : List (sigma β)} {l₃ : List (sigma β)} {l₄ : List (sigma β)} (nd₃ : nodupkeys l₃)
    (p₁₂ : l₁ ~ l₂) (p₃₄ : l₃ ~ l₄) : kunion l₁ l₃ ~ kunion l₂ l₄ :=
  perm.trans (perm.kunion_right p₁₂ l₃) (perm.kunion_left l₂ nd₃ p₃₄)

@[simp] theorem lookup_kunion_left {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} (h : a ∈ keys l₁) :
    lookup a (kunion l₁ l₂) = lookup a l₁ :=
  sorry

@[simp] theorem lookup_kunion_right {α : Type u} {β : α → Type v} [DecidableEq α] {a : α}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} (h : ¬a ∈ keys l₁) :
    lookup a (kunion l₁ l₂) = lookup a l₂ :=
  sorry

@[simp] theorem mem_lookup_kunion {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} :
    b ∈ lookup a (kunion l₁ l₂) ↔ b ∈ lookup a l₁ ∨ ¬a ∈ keys l₁ ∧ b ∈ lookup a l₂ :=
  sorry

theorem mem_lookup_kunion_middle {α : Type u} {β : α → Type v} [DecidableEq α] {a : α} {b : β a}
    {l₁ : List (sigma β)} {l₂ : List (sigma β)} {l₃ : List (sigma β)}
    (h₁ : b ∈ lookup a (kunion l₁ l₃)) (h₂ : ¬a ∈ keys l₂) :
    b ∈ lookup a (kunion (kunion l₁ l₂) l₃) :=
  sorry

end Mathlib


/-- Encoding of arrays in Lean. It is defined to be `opaque` to ensure that we only use the
    declared operations and axioms to reason about arrays. -/
opaque A : (I : Sort u₁) → (E : Sort u₂) → Sort (max u₁ u₂)

namespace A

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

/-- The `read` operation for Arrays. It is defined to be `opaque` because its semantics are
    provided by the axioms. -/
noncomputable opaque read : A I E → I → E

/-- The `write` operation for Arrays. It is defined to be `opaque` because its semantics are
    provided by the axioms. -/
noncomputable opaque write : A I E → I → E → A I E

axiom rw1 : ∀ {a : A I E}, ∀ {i : I}, ∀ {v : E}, (a.write i v).read i = v

axiom rw2 : ∀ {a : A I E}, ∀ {i j : I}, ∀ {v : E}, i ≠ j → (a.write i v).read j = a.read j

/-- The extansionality axiom. -/
axiom ex : ∀ {a b : A I E}, (∀ i : I, a.read i = b.read i) → a = b

theorem contrapositive : (p → q) → ¬q → ¬p := fun hpq hnq hp => hnq (hpq hp)

theorem forall_eq_not_exists_not {p : α → Prop} : (∀ x, p x) = ¬ ∃ x, ¬ p x :=
  propext ⟨fun hfxpx ⟨x, hnpx⟩ => hnpx (hfxpx x),
          fun henxnpx x => match Classical.em (p x) with
            | Or.inl hpx  => hpx
            | Or.inr hnpx => absurd ⟨x, hnpx⟩ henxnpx⟩

theorem double_neg: (¬¬p) = p :=
  propext ⟨match Classical.em (¬p) with
    | Or.inl g1 => fun h1  => absurd g1 h1
    | Or.inr _ => match Classical.em (p) with
                    | Or.inl g2 => fun _ => g2
                    | Or.inr g2 => fun x => absurd g2 x,
  match Classical.em (¬p) with
    | Or.inl np => fun hp => absurd hp np
    | Or.inr nnp => fun _ => nnp⟩

/-- Theorem proving `RIntro1` rule from the axioms. -/
theorem r_intro1 {a b : A I E}: a = b.write i v → v = a.read i :=
  fun h => h ▸ Eq.symm rw1

/-- Theorem proving `RIntro2` rule from the axioms. -/
theorem r_intro2 {a b c : A I E} : a = c ∨ b = c → a = b.write i v → x = c.read j → i = j ∨ a.read j = b.read j :=
  fun _ hw _ => match Classical.em (i = j) with
  | Or.inl he => Or.inl he
  | Or.inr hne => Or.inr (hw ▸ rw2 hne)

/-- Theorem proving `Ext` rule from the axioms. -/
theorem ext {a b : A I E} : a ≠ b → ∃i, a.read i ≠ b.read i := fun hne =>
  double_neg (p := ∃ i, read a i ≠ read b i) ▸
  forall_eq_not_exists_not (p := (λ i => a.read i = b.read i)) ▸
  (contrapositive ex) hne

example {a b : A I E} : a.write i (b.read i) = b.write i (a.read i) → a ≠ b → False := fun h0 h6 =>
  let v := b.read i
  have h3 : v = b.read i := rfl
  let w := a.read i
  have h4 : w = a.read i := rfl
  let a' := a.write i v
  have h1 : a' = a.write i v := rfl
  let b' := b.write i w
  have h2 : b' = b.write i w := rfl
  have h5 : a' = b' := h1 ▸ h2 ▸ h3 ▸ h4 ▸ h0
  lem h1 h2 h3 h4 h5 h6
where
  lem {a a' b b' : A I E} {v w : E} : a' = a.write i v → b' = b.write i w → v = b.read i → w = a.read i → a' = b' → a ≠ b → False :=
    fun h1 h2 h3 h4 h5 h6 =>
      have ⟨k, h9⟩ : ∃i, a.read i ≠ b.read i := ext h6
      let x := read a k
      have h7 : x = read a k := rfl
      let y := read b k
      have h8 : y = read b k := rfl
      have h9 : x ≠ y := h7 ▸ h8 ▸ h9
      have h10 : i = k ∨ a'.read k = a.read k := r_intro2 (Or.inr rfl) h1 h7
      match h10 with
      | Or.inl h10 =>
        have h11 : x = w := h4 ▸ h10 ▸ h7
        have h12 : v = y := h3 ▸ h10 ▸ h8
        have h13 : v = a'.read i := r_intro1 h1
        have h14 : w = b'.read i := r_intro1 h2
        have h15 : w = v := h13 ▸ h5 ▸ h14
        have h16 : x = y := h11 ▸ h12 ▸ h15
        h9 h16
      | Or.inr h10 =>
        let x' := a'.read k
        have h11 : x' = a'.read k := rfl
        have h10 : x = x' := h7 ▸ h11 ▸ h10 ▸ rfl
        have h12 : i = k ∨ b'.read k = b.read k := r_intro2 (Or.inr rfl) h2 h8
        match h12 with
        | Or.inl h12 =>
          have h13 : x = w := h4 ▸ h12 ▸ h7
          have h14 : v = y := h3 ▸ h12 ▸ h8
          have h15 : v = a'.read i := r_intro1 h1
          have h16 : w = b'.read i := r_intro1 h2
          have h17 : w = v := h15 ▸ h5 ▸ h16
          have h18 : x = y := h13 ▸ h14 ▸ h17
          h9 h18
        | Or.inr h12 =>
          let y' := b'.read k
          have h13 : y' = b'.read k := rfl
          have h14 : y' = y := h8 ▸ h12 ▸ h13
          have h15 : x' = y' := h11 ▸ h13 ▸ h5 ▸ rfl
          have h16 : x = y := h10 ▸ h14 ▸ h15
          h9 h16

end A


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import category_theory.concrete_category.bundled_hom
import algebra.punit_instances
import order.hom.basic

/-!
# Category of preorders

This defines `Preorder`, the category of preorders with monotone maps.
-/

universe u

open category_theory

/-- The category of preorders. -/
def Preorder := bundled preorder

namespace Preorder

instance : bundled_hom @order_hom :=
{ to_fun := @order_hom.to_fun,
  id := @order_hom.id,
  comp := @order_hom.comp,
  hom_ext := @order_hom.ext }

attribute [derive [large_category, concrete_category]] Preorder

instance : has_coe_to_sort Preorder Type* := bundled.has_coe_to_sort

/-- Construct a bundled Preorder from the underlying type and typeclass. -/
def of (α : Type*) [preorder α] : Preorder := bundled.of α

@[simp] lemma coe_of (α : Type*) [preorder α] : ↥(of α) = α := rfl

instance : inhabited Preorder := ⟨of punit⟩

instance (α : Preorder) : preorder α := α.str

/-- Constructs an equivalence between preorders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : Preorder.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : Preorder ⥤ Preorder :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `Preorder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : Preorder ≌ Preorder :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end Preorder


import Runtime.Network.Graph.Path.Subpaths

namespace Network.Graph.Path

abbrev extend (path : Path graph start) (leaf : Class.Child path.class) : Path graph start :=
  match path with
  | nil                => cons leaf nil
  | cons child subpath => cons child (subpath.extend leaf)

@[simp]
theorem extend_class {path : Path graph start} {leaf} : (path.extend leaf).class = leaf.class :=
  match path with
  | nil => rfl
  | cons _ subpath => subpath.extend_class

@[simp]
theorem extend_prefix?_eq_self {path : Path graph start} {leaf} : (path.extend leaf).prefix? = path := by
  induction path
  case nil => simp [extend, prefix?]
  case cons subpath hi => simp [extend, prefix?_cons_eq_cons_prefix? hi]

end Network.Graph.Path