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

/-!
# Skeleton of a category

Define skeletal categories as categories in which any two isomorphic objects are equal.

Construct the skeleton of an arbitrary category by taking isomorphism classes, and show it is a
skeleton of the original category.

In addition, construct the skeleton of a thin category as a partial ordering, and (noncomputably)
show it is a skeleton of the original category. The advantage of this special case being handled
separately is that lemmas and definitions about orderings can be used directly, for example for the
subobject lattice. In addition, some of the commutative diagrams about the functors commute
definitionally on the nose which is convenient in practice.
-/

universes v₁ v₂ v₃ u₁ u₂ u₃

namespace category_theory

open category

variables (C : Type u₁) [category.{v₁} C]
variables (D : Type u₂) [category.{v₂} D]
variables {E : Type u₃} [category.{v₃} E]

/-- A category is skeletal if isomorphic objects are equal. -/
def skeletal : Prop := ∀ ⦃X Y : C⦄, is_isomorphic X Y → X = Y

/--
`is_skeleton_of C D F` says that `F : D ⥤ C` exhibits `D` as a skeletal full subcategory of `C`,
in particular `F` is a (strong) equivalence and `D` is skeletal.
-/
structure is_skeleton_of (F : D ⥤ C) :=
(skel : skeletal D)
(eqv : is_equivalence F)

local attribute [instance] is_isomorphic_setoid

variables {C D}
/-- If `C` is thin and skeletal, then any naturally isomorphic functors to `C` are equal. -/
lemma functor.eq_of_iso {F₁ F₂ : D ⥤ C} [∀ X Y : C, subsingleton (X ⟶ Y)] (hC : skeletal C)
  (hF : F₁ ≅ F₂) : F₁ = F₂ :=
functor.ext (λ X, hC ⟨hF.app X⟩) (λ _ _ _, subsingleton.elim _ _)

/--
If `C` is thin and skeletal, `D ⥤ C` is skeletal.
`category_theory.functor_thin` shows it is thin also.
-/
lemma functor_skeletal [∀ X Y : C, subsingleton (X ⟶ Y)] (hC : skeletal C) : skeletal (D ⥤ C) :=
λ F₁ F₂ h, h.elim (functor.eq_of_iso hC)
variables (C D)

/--
Construct the skeleton category as the induced category on the isomorphism classes, and derive
its category structure.
-/
@[derive category]
def skeleton : Type u₁ := induced_category C quotient.out

instance [inhabited C] : inhabited (skeleton C) := ⟨⟦default C⟧⟩

/-- The functor from the skeleton of `C` to `C`. -/
@[simps, derive [full, faithful]]
noncomputable def from_skeleton : skeleton C ⥤ C := induced_functor _

instance : ess_surj (from_skeleton C) :=
{ mem_ess_image := λ X, ⟨quotient.mk X, quotient.mk_out X⟩ }

noncomputable instance : is_equivalence (from_skeleton C) :=
equivalence.of_fully_faithfully_ess_surj (from_skeleton C)

/-- The equivalence between the skeleton and the category itself. -/
noncomputable def skeleton_equivalence : skeleton C ≌ C :=
(from_skeleton C).as_equivalence

lemma skeleton_skeletal : skeletal (skeleton C) :=
begin
  rintro X Y ⟨h⟩,
  have : X.out ≈ Y.out := ⟨(from_skeleton C).map_iso h⟩,
  simpa using quotient.sound this,
end

/-- The `skeleton` of `C` given by choice is a skeleton of `C`. -/
noncomputable def skeleton_is_skeleton : is_skeleton_of C (skeleton C) (from_skeleton C) :=
{ skel := skeleton_skeletal C,
  eqv := from_skeleton.is_equivalence C }

section
variables {C D}

/--
Two categories which are categorically equivalent have skeletons with equivalent objects.
-/
noncomputable
def equivalence.skeleton_equiv (e : C ≌ D) : skeleton C ≃ skeleton D :=
let f := ((skeleton_equivalence C).trans e).trans (skeleton_equivalence D).symm in
{ to_fun := f.functor.obj,
  inv_fun := f.inverse.obj,
  left_inv := λ X, skeleton_skeletal C ⟨(f.unit_iso.app X).symm⟩,
  right_inv := λ Y, skeleton_skeletal D ⟨(f.counit_iso.app Y)⟩, }

end

/--
Construct the skeleton category by taking the quotient of objects. This construction gives a
preorder with nice definitional properties, but is only really appropriate for thin categories.
If your original category is not thin, you probably want to be using `skeleton` instead of this.
-/
def thin_skeleton : Type u₁ := quotient (is_isomorphic_setoid C)

instance inhabited_thin_skeleton [inhabited C] : inhabited (thin_skeleton C) :=
⟨quotient.mk (default _)⟩

instance thin_skeleton.preorder : preorder (thin_skeleton C) :=
{ le := quotient.lift₂ (λ X Y, nonempty (X ⟶ Y))
  begin
    rintros _ _ _ _ ⟨i₁⟩ ⟨i₂⟩,
    exact propext ⟨nonempty.map (λ f, i₁.inv ≫ f ≫ i₂.hom),
      nonempty.map (λ f, i₁.hom ≫ f ≫ i₂.inv)⟩,
  end,
  le_refl :=
  begin
    refine quotient.ind (λ a, _),
    exact ⟨𝟙 _⟩,
  end,
  le_trans := λ a b c, quotient.induction_on₃ a b c $ λ A B C, nonempty.map2 (≫) }

/-- The functor from a category to its thin skeleton. -/
@[simps]
def to_thin_skeleton : C ⥤ thin_skeleton C :=
{ obj := quotient.mk,
  map := λ X Y f, hom_of_le (nonempty.intro f) }

/-!
The constructions here are intended to be used when the category `C` is thin, even though
some of the statements can be shown without this assumption.
-/
namespace thin_skeleton

/-- The thin skeleton is thin. -/
instance thin {X Y : thin_skeleton C} : subsingleton (X ⟶ Y) :=
⟨by { rintros ⟨⟨f₁⟩⟩ ⟨⟨f₂⟩⟩, refl }⟩

variables {C} {D}

/-- A functor `C ⥤ D` computably lowers to a functor `thin_skeleton C ⥤ thin_skeleton D`. -/
@[simps]
def map (F : C ⥤ D) : thin_skeleton C ⥤ thin_skeleton D :=
{ obj := quotient.map F.obj $ λ X₁ X₂ ⟨hX⟩, ⟨F.map_iso hX⟩,
  map := λ X Y, quotient.rec_on_subsingleton₂ X Y $
           λ x y k, hom_of_le (k.le.elim (λ t, ⟨F.map t⟩)) }

lemma comp_to_thin_skeleton (F : C ⥤ D) : F ⋙ to_thin_skeleton D = to_thin_skeleton C ⋙ map F :=
rfl

/-- Given a natural transformation `F₁ ⟶ F₂`, induce a natural transformation `map F₁ ⟶ map F₂`.-/
def map_nat_trans {F₁ F₂ : C ⥤ D} (k : F₁ ⟶ F₂) : map F₁ ⟶ map F₂ :=
{ app := λ X, quotient.rec_on_subsingleton X (λ x, ⟨⟨⟨k.app x⟩⟩⟩) }

-- TODO: state the lemmas about what happens when you compose with `to_thin_skeleton`
/-- A functor `C ⥤ D ⥤ E` computably lowers to a functor
`thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E` -/
@[simps]
def map₂ (F : C ⥤ D ⥤ E) :
  thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E :=
{ obj := λ x,
  { obj := λ y, quotient.map₂ (λ X Y, (F.obj X).obj Y)
                (λ X₁ X₂ ⟨hX⟩ Y₁ Y₂ ⟨hY⟩, ⟨(F.obj X₁).map_iso hY ≪≫ (F.map_iso hX).app Y₂⟩) x y,
    map := λ y₁ y₂, quotient.rec_on_subsingleton x $
            λ X, quotient.rec_on_subsingleton₂ y₁ y₂ $
              λ Y₁ Y₂ hY, hom_of_le (hY.le.elim (λ g, ⟨(F.obj X).map g⟩)) },
  map := λ x₁ x₂, quotient.rec_on_subsingleton₂ x₁ x₂ $
           λ X₁ X₂ f,
           { app := λ y, quotient.rec_on_subsingleton y
              (λ Y, hom_of_le (f.le.elim (λ f', ⟨(F.map f').app Y⟩))) } }

variables (C)

section
variables [∀ X Y : C, subsingleton (X ⟶ Y)]

instance to_thin_skeleton_faithful : faithful (to_thin_skeleton C) := {}

/-- Use `quotient.out` to create a functor out of the thin skeleton. -/
@[simps]
noncomputable def from_thin_skeleton : thin_skeleton C ⥤ C :=
{ obj := quotient.out,
  map := λ x y, quotient.rec_on_subsingleton₂ x y $
    λ X Y f,
            (nonempty.some (quotient.mk_out X)).hom
          ≫ f.le.some
          ≫ (nonempty.some (quotient.mk_out Y)).inv }

noncomputable instance from_thin_skeleton_equivalence : is_equivalence (from_thin_skeleton C) :=
{ inverse := to_thin_skeleton C,
  counit_iso := nat_iso.of_components (λ X, (nonempty.some (quotient.mk_out X))) (by tidy),
  unit_iso :=
    nat_iso.of_components
      (λ x, quotient.rec_on_subsingleton x
        (λ X, eq_to_iso (quotient.sound ⟨(nonempty.some (quotient.mk_out X)).symm⟩)))
      (by tidy) }

/-- The equivalence between the thin skeleton and the category itself. -/
noncomputable def equivalence : thin_skeleton C ≌ C :=
(from_thin_skeleton C).as_equivalence

variables {C}

lemma equiv_of_both_ways {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : X ≈ Y :=
⟨iso_of_both_ways f g⟩

instance thin_skeleton_partial_order : partial_order (thin_skeleton C) :=
{ le_antisymm := quotient.ind₂
  begin
    rintros _ _ ⟨f⟩ ⟨g⟩,
    apply quotient.sound (equiv_of_both_ways f g),
  end,
  ..category_theory.thin_skeleton.preorder C }

lemma skeletal : skeletal (thin_skeleton C) :=
λ X Y, quotient.induction_on₂ X Y $ λ x y h, h.elim $ λ i, i.1.le.antisymm i.2.le

lemma map_comp_eq (F : E ⥤ D) (G : D ⥤ C) : map (F ⋙ G) = map F ⋙ map G :=
functor.eq_of_iso skeletal $
  nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

lemma map_id_eq : map (𝟭 C) = 𝟭 (thin_skeleton C) :=
functor.eq_of_iso skeletal $
  nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

lemma map_iso_eq {F₁ F₂ : D ⥤ C} (h : F₁ ≅ F₂) : map F₁ = map F₂ :=
functor.eq_of_iso skeletal { hom := map_nat_trans h.hom, inv := map_nat_trans h.inv }

/-- `from_thin_skeleton C` exhibits the thin skeleton as a skeleton. -/
noncomputable def thin_skeleton_is_skeleton : is_skeleton_of C (thin_skeleton C)
  (from_thin_skeleton C) :=
{ skel := skeletal,
  eqv := thin_skeleton.from_thin_skeleton_equivalence C }

noncomputable instance is_skeleton_of_inhabited :
  inhabited (is_skeleton_of C (thin_skeleton C) (from_thin_skeleton C)) :=
⟨thin_skeleton_is_skeleton⟩

end

variables {C}

/-- An adjunction between thin categories gives an adjunction between their thin skeletons. -/
def lower_adjunction
  (R : D ⥤ C) (L : C ⥤ D) (h : L ⊣ R) :
  thin_skeleton.map L ⊣ thin_skeleton.map R :=
adjunction.mk_of_unit_counit
{ unit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid C,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.unit.app x⟩),
      -- TODO: make quotient.rec_on_subsingleton' so the letI isn't needed
    end },
  counit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid D,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.counit.app x⟩),
    end } }

end thin_skeleton

open thin_skeleton

section
variables {C} {α : Type*} [partial_order α]

/--
When `e : C ≌ α` is a categorical equivalence from a thin category `C` to some partial order `α`,
the `thin_skeleton C` is order isomorphic to `α`.
-/
noncomputable
def equivalence.thin_skeleton_order_iso
  [∀ X Y : C, subsingleton (X ⟶ Y)] (e : C ≌ α) : thin_skeleton C ≃o α :=
((thin_skeleton.equivalence C).trans e).to_order_iso

end

end category_theory


import rescale.polyhedral_lattice
import polyhedral_lattice.cech

import facts.nnreal

/-!
# The cosimplicial polyhedral lattice attached to `Λ → Λ'`

Let `Λ` be a polyhedral lattice, and let `0 < n` be a natural number.
Let `Λ' := rescale n (fin n →₀ Λ)` be the polyhedral lattice
that is the `n`-fold direct sum of `Λ` with itself,
endowed with the norm `∥(l₁, l₂, ..., lₙ)∥ = (∥l₁∥ + ∥l₂∥ + ... + ∥lₙ∥) / n`.

The diagonal embedding `Λ → Λ'` is a norm-nonincreasing map.
In this file we construct the Cech conerve of this map.
It is a cosimplicial object in the category `PolyhedralLattice`.

Concretely, but in pseudo-code:
it consists of the objects `Λ'^(m)` defined as `(Λ')^m/L`,
where `L` is the sublattice `Λ ⊗ {x : ℤ^m | ∑ x = 0}`.
-/

noncomputable theory

universe variables u

open_locale nnreal big_operators
open category_theory finsupp

namespace PolyhedralLattice

variables (Λ : PolyhedralLattice.{u}) (N : ℕ) [hN : fact (0 < N)]

include hN

def rescaled_power : PolyhedralLattice :=
of (rescale N $ fin N →₀ Λ)

def diagonal_embedding : Λ ⟶ rescaled_power Λ N :=
{ to_fun := λ l, @rescale.of N (fin N →₀ Λ) $ ∑ i, single_add_hom i l,
  map_add' := λ l₁ l₂, by { simp only [add_monoid_hom.map_add, finset.sum_add_distrib], refl }, -- defeq abuse
  strict' := λ l,
  begin
    rw [rescale.norm_def, equiv.symm_apply_apply, norm_def, nnreal.coe_nat_cast,
      sum_fintype],
    swap, { intro, exact norm_zero },
    apply le_of_eq,
    rw div_eq_iff, swap,
    { norm_cast, exact hN.out.ne' },
    simp only [← apply_add_hom_apply, add_monoid_hom.map_sum],
    simp only [apply_add_hom_apply, single_add_hom_apply, single_apply],
    convert finset.sum_const (∥l∥ : ℝ),
    { ext i, simp only [finset.sum_ite_eq', finset.mem_univ, if_true] },
    rw [mul_comm, nsmul_eq_mul, finset.card_univ, fintype.card_fin],
  end }
.

lemma diagonal_embedding_apply (l : Λ) (i : fin N) :
  ((@rescale.of N ((fin N) →₀ Λ)).symm (Λ.diagonal_embedding N l) : fin N →₀ Λ) i = l :=
by simp only [diagonal_embedding, single_add_hom_apply, finset.sum_apply',
    polyhedral_lattice_hom.coe_mk, equiv.symm_apply_apply, finsupp.single_apply,
    finset.sum_ite_eq', finset.mem_univ, if_true]

def cosimplicial_lift {M : Type*} [add_comm_group M] (m : ℕ) (g₀ : Λ →+ M)
  (g : fin (m + 1) → (Λ.rescaled_power N →+ M))
  (hg : ∀ i l, (g i) (Λ.diagonal_embedding N l) = g₀ l) :
  polyhedral_lattice.conerve.obj (Λ.diagonal_embedding N) (m + 1) →+ M :=
polyhedral_lattice.conerve.lift' _ m g₀ g hg $
begin
  intros l₁ l₂ h,
  rw [finsupp.ext_iff] at h,
  specialize h ⟨0, fact.out _⟩,
  erw [diagonal_embedding_apply, diagonal_embedding_apply] at h,
  exact h
end

lemma zsmul_rescaled_power (n : ℤ) (l : Λ.rescaled_power N) :
  n • (@rescale.of N ((fin N) →₀ Λ)).symm l = (@rescale.of N ((fin N) →₀ Λ)).symm (n • l) :=
rfl

instance : fact (polyhedral_lattice_hom.to_add_monoid_hom (Λ.diagonal_embedding N)).range.saturated :=
begin
  constructor,
  rw add_subgroup.saturated_iff_zsmul,
  intros n l' h,
  by_cases hn : n = 0, { exact or.inl hn },
  let l₀ : ↥Λ := ((@rescale.of N ((fin N) →₀ Λ)).symm l' : fin N →₀ Λ) ⟨0, hN.1⟩,
  refine or.inr ⟨l₀, _⟩,
  simp only [polyhedral_lattice_hom.coe_to_add_monoid_hom, add_monoid_hom.mem_range] at h ⊢,
  obtain ⟨l, hl⟩ := h,
  refine @smul_right_injective ℤ _ _ _ _ _ n hn _ _ _,
  rw [← hl, ← polyhedral_lattice_hom.map_zsmul],
  dsimp only [l₀],
  rw [← finsupp.smul_apply, zsmul_rescaled_power _ _ n l', ← hl, diagonal_embedding_apply],
end

def cosimplicial : cosimplicial_object PolyhedralLattice.{u} :=
Cech_conerve $ diagonal_embedding Λ N

open simplex_category

def cosimplicial_augmentation_map : Λ ⟶ (cosimplicial Λ N).obj (mk 0) :=
Cech_augmentation_map _

def augmented_cosimplicial : cosimplicial_object.augmented PolyhedralLattice.{u} :=
augmented_Cech_conerve $ diagonal_embedding Λ N

end PolyhedralLattice


-- An exploration of examples from Conor McBride's CS410: Advanced Functional
-- Programming. Originally written in Agda, translated to Lean 4.

universe u

inductive Zero : Type u where
#check Zero

structure One : Type where
#check One
#check One.mk
#check ({ } : One)

-- This is Conor's `+`.
inductive Either (S : Type u) (T : Type u) : Type u where
  | inl : S → Either S T
  | inr : T → Either S T

structure Product (S : Type u) (T : Type u) : Type u where
  fst : S
  snd : T

theorem productIsCommutative : Product α β → Product β α := by
  intro h
  let a := h.fst
  let b := h.snd
  apply Product.mk
  assumption
  assumption

theorem eitherIsCommutative : Either A B → Either B A := by
  intro h
  cases h
  apply Either.inr
  assumption
  apply Either.inl
  assumption

-- An alternate proof with pattern matching, using Lean 4's built in `Sum` type
-- instead.
--
-- The bullet notation `. <tactics>` is just a way of structuring the proof,
-- i.e. starting work on a specific subgoal and increasing the indentation
-- level. It is not an operator, and removing the bullets and the indentation
-- will result in an identical proof. See TPIL, specifically, the 'Tactics'
-- section.
theorem sumIsCommutative {α β : Type u} : Sum α β → Sum β α := by
  intro h
  cases h
  . apply Sum.inr
    assumption
  . apply Sum.inl
    assumption

theorem eitherIsAssociative : Either (Either α β) γ → Either α (Either β γ) := by
  intro h
  cases h
  case inl h =>
    cases h
    apply Either.inl
    assumption
    apply Either.inr
    apply Either.inl
    assumption
  case inr h =>
    apply Either.inr
    apply Either.inr
    assumption

#check eitherIsAssociative

theorem vBad : Zero → α := by
  intro z
  cases z

def hello := "world"


lemma ne_succ_self (n : mynat) : n ≠ succ n :=
begin
induction n with h hd,
apply zero_ne_succ,
intro hs,
apply hd,
apply succ_inj,
exact hs,
end


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import ring_theory.localization.fraction_ring
import ring_theory.localization.integer
import ring_theory.unique_factorization_domain

/-!
# Numerator and denominator in a localization

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

## Implementation notes

See `src/ring_theory/localization/basic.lean` for a design overview.

## Tags
localization, ring localization, commutative ring localization, characteristic predicate,
commutative ring, field of fractions
-/
variables {R : Type*} [comm_ring R] (M : submonoid R) {S : Type*} [comm_ring S]
variables [algebra R S] {P : Type*} [comm_ring P]

namespace is_fraction_ring

open is_localization

section num_denom

variables (A : Type*) [comm_ring A] [is_domain A] [unique_factorization_monoid A]
variables {K : Type*} [field K] [algebra A K] [is_fraction_ring A K]

lemma exists_reduced_fraction (x : K) :
  ∃ (a : A) (b : non_zero_divisors A),
  (∀ {d}, d ∣ a → d ∣ b → is_unit d) ∧ mk' K a b = x :=
begin
  obtain ⟨⟨b, b_nonzero⟩, a, hab⟩ := exists_integer_multiple (non_zero_divisors A) x,
  obtain ⟨a', b', c', no_factor, rfl, rfl⟩ :=
    unique_factorization_monoid.exists_reduced_factors' a b
      (mem_non_zero_divisors_iff_ne_zero.mp b_nonzero),
  obtain ⟨c'_nonzero, b'_nonzero⟩ := mul_mem_non_zero_divisors.mp b_nonzero,
  refine ⟨a', ⟨b', b'_nonzero⟩, @no_factor, _⟩,
  refine mul_left_cancel₀
    (is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors b_nonzero) _,
  simp only [subtype.coe_mk, ring_hom.map_mul, algebra.smul_def] at *,
  erw [←hab, mul_assoc, mk'_spec' _ a' ⟨b', b'_nonzero⟩],
end

/-- `f.num x` is the numerator of `x : f.codomain` as a reduced fraction. -/
noncomputable def num (x : K) : A :=
classical.some (exists_reduced_fraction A x)

/-- `f.num x` is the denominator of `x : f.codomain` as a reduced fraction. -/
noncomputable def denom (x : K) : non_zero_divisors A :=
classical.some (classical.some_spec (exists_reduced_fraction A x))

lemma num_denom_reduced (x : K) {d} : d ∣ num A x → d ∣ denom A x → is_unit d :=
(classical.some_spec (classical.some_spec (exists_reduced_fraction A x))).1

@[simp] lemma mk'_num_denom (x : K) : mk' K (num A x) (denom A x) = x :=
(classical.some_spec (classical.some_spec (exists_reduced_fraction A x))).2

variables {A}

lemma num_mul_denom_eq_num_iff_eq {x y : K} :
  x * algebra_map A K (denom A y) = algebra_map A K (num A y) ↔ x = y :=
⟨λ h, by simpa only [mk'_num_denom] using eq_mk'_iff_mul_eq.mpr h,
 λ h, eq_mk'_iff_mul_eq.mp (by rw [h, mk'_num_denom])⟩

lemma num_mul_denom_eq_num_iff_eq' {x y : K} :
  y * algebra_map A K (denom A x) = algebra_map A K (num A x) ↔ x = y :=
⟨λ h, by simpa only [eq_comm, mk'_num_denom] using eq_mk'_iff_mul_eq.mpr h,
 λ h, eq_mk'_iff_mul_eq.mp (by rw [h, mk'_num_denom])⟩

lemma num_mul_denom_eq_num_mul_denom_iff_eq {x y : K} :
  num A y * denom A x = num A x * denom A y ↔ x = y :=
⟨λ h, by simpa only [mk'_num_denom] using mk'_eq_of_eq' h,
 λ h, by rw h⟩

lemma eq_zero_of_num_eq_zero {x : K} (h : num A x = 0) : x = 0 :=
num_mul_denom_eq_num_iff_eq'.mp (by rw [zero_mul, h, ring_hom.map_zero])

lemma is_integer_of_is_unit_denom {x : K} (h : is_unit (denom A x : A)) : is_integer A x :=
begin
  cases h with d hd,
  have d_ne_zero : algebra_map A K (denom A x) ≠ 0 :=
    is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors (denom A x).2,
  use ↑d⁻¹ * num A x,
  refine trans _ (mk'_num_denom A x),
  rw [map_mul, map_units_inv, hd],
  apply mul_left_cancel₀ d_ne_zero,
  rw [←mul_assoc, mul_inv_cancel d_ne_zero, one_mul, mk'_spec']
end

lemma is_unit_denom_of_num_eq_zero {x : K} (h : num A x = 0) : is_unit (denom A x : A) :=
num_denom_reduced A x (h.symm ▸ dvd_zero _) dvd_rfl

end num_denom

variables (S)

end is_fraction_ring


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

import for_mathlib.algebraic_topology.homotopical_algebra.fundamental_lemma
import for_mathlib.algebraic_topology.homotopical_algebra.over
import for_mathlib.category_theory.functor_misc

noncomputable theory

open algebraic_topology
open category_theory category_theory.category

lemma category_theory.functor.is_iso_map_iff {C D : Type*} [category C] [category D]
  (F : C ⥤ D) [reflects_isomorphisms F] {X Y : C} (f : X ⟶ Y) : is_iso (F.map f) ↔ is_iso f :=
begin
  split,
  { introI,
    exact is_iso_of_reflects_iso f F, },
  { introI,
    apply_instance, },
end

namespace category_theory.morphism_property.three_of_two

variables {C : Type*} [category C] {X Y X' Y' : C}
  {f : X ⟶ Y} {f' : X' ⟶ Y'} {g : X ⟶ X'} {g' : Y ⟶ Y'}

lemma left_iff_right_of_sq {P : morphism_property C}
  (h : P.three_of_two) (sq : comm_sq g f f' g') (hg : P g) (hg' : P g'):
  P f ↔ P f' :=
begin
  split,
  { intro hf,
    refine h.of_comp_left g f' hg _,
    rw sq.w,
    exact h.of_comp _ _ hf hg', },
  { intro hf',
    refine h.of_comp_right f g' hg' _,
    rw ← sq.w,
    exact h.of_comp _ _ hg hf', },
end

end category_theory.morphism_property.three_of_two

open category_theory

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C]
  {Ho : Type*} [category Ho] (L : C ⥤ Ho) [L.is_localization weq]
  {Hocof : Type*} [category Hocof] (Lcof : cofibrant_object C ⥤ Hocof)
    [Lcof.is_localization cofibrant_object.weq]
  {Hobif : Type*} [category Hobif] (Lbif : bifibrant_object C ⥤ Hobif)
    [Lbif.is_localization bifibrant_object.weq]

lemma strong_deformation_retract_of_cofibration_and_homotopy_equivalence
  {X Y : bifibrant_object C} (f : X ⟶ Y) [is_iso (Lbif.map f)] :
  ∃ (g : Y ⟶ X) (hg₁ : f ≫ g = 𝟙 X) (P : path_object Y.obj)
    (H : right_homotopy P.pre ((bifibrant_object.forget C).map (g ≫ f)) (𝟙 Y.obj)),
    (bifibrant_object.forget C).map f ≫ H.h = (bifibrant_object.forget C).map f ≫ P.σ :=
begin
  sorry,
end

lemma bifibrant_object.is_iso_Lbif_map_cofibration_iff
  {X Y : bifibrant_object C} (f : X ⟶ Y) [cofibration ((bifibrant_object.forget C).map f)] :
  is_iso (Lbif.map f) ↔ bifibrant_object.weq f :=
begin
  refine ⟨_, localization.inverts Lbif bifibrant_object.weq f⟩,
  introI,
  rcases strong_deformation_retract_of_cofibration_and_homotopy_equivalence Lbif f
    with ⟨g, hg₁, P, H, property⟩,
  let f' := (bifibrant_object.forget C).map f,
  let W := CM5a.obj f',
  let i : X.obj ⟶ W := CM5a.i f',
  let p : W ⟶ Y.obj := CM5a.p f',
  have sq : comm_sq i f' p (𝟙 Y.obj) :=
    comm_sq.mk (by simpa only [CM5a.fac f'] using (comp_id f').symm),
  suffices : sq.has_lift,
  { haveI := this,
    refine CM3a f' i _ weak_eq.property,
    have fac₁ : 𝟙 X.obj ≫ i = f' ≫ sq.lift := by rw [id_comp, sq.fac_left],
    have fac₂ : 𝟙 X.obj ≫ f' = i ≫ p := by rw [id_comp, CM5a.fac f'],
    refine is_retract.mk (arrow.hom_mk fac₁) (arrow.hom_mk fac₂) _,
    ext,
    { apply comp_id, },
    { exact sq.fac_right, }, },
  sorry,
end

lemma bifibrant_object.is_iso_Lbif_map_iff
  {X Y : bifibrant_object C} (f : X ⟶ Y) :
  is_iso (Lbif.map f) ↔ bifibrant_object.weq f :=
begin
  split,
  { intro hf,
    let f' := (bifibrant_object.forget C).map f,
    let Z := CM5b.obj f',
    let i : X ⟶ bifibrant_object.mk Z := CM5b.i f',
    let p : bifibrant_object.mk Z ⟶ Y := CM5b.p f',
    have h : i ≫ p = f := CM5b.fac f',
    rw ← h,
    rw [← h, Lbif.map_comp] at hf,
    haveI := hf,
    haveI : weak_eq ((bifibrant_object.forget C).map p) := (infer_instance : weak_eq (CM5b.p f')),
    haveI : cofibration ((bifibrant_object.forget C).map i) := (infer_instance : cofibration (CM5b.i f')),
    haveI := is_iso_Lbif_map Lbif p,
    haveI : is_iso (Lbif.map i) := is_iso.of_is_iso_comp_right _ (Lbif.map p),
    refine CM2.of_comp _ _ _ weak_eq.property,
    exact (bifibrant_object.is_iso_Lbif_map_cofibration_iff Lbif i).mp infer_instance, },
  { exact localization.inverts Lbif bifibrant_object.weq f, },
end

lemma bifibrant_object.is_iso_Lbif_map_iff_is_iso_Lcof_map
  {X Y : bifibrant_object C} (f : X ⟶ Y) :
  is_iso (Lbif.map f) ↔ is_iso (Lcof.map ((bifibrant_object.forget_fib C).map f)) :=
by rw [← (Hobif_to_Hocof Lcof Lbif).is_iso_map_iff, ← functor.comp_map,
  is_iso_map_iff_of_nat_iso (Lbif_comp_Hobif_to_Hocof_iso Lcof Lbif), functor.comp_map]

lemma cofibrant_object.is_iso_Lcof_map_iff
  {X Y : cofibrant_object C} (f : X ⟶ Y) :
  is_iso (Lcof.map f) ↔ cofibrant_object.weq f :=
begin
  split,
  { intro hf,
    change (morphism_property.isomorphisms _).inverse_image Lcof f at hf,
    have sq := comm_sq.mk (bifibrant_replacement.fac f),
    rw ((morphism_property.three_of_two.for_isomorphisms _).for_inverse_image Lcof).left_iff_right_of_sq sq
      (is_iso_Lcof_map' Lcof _ weak_eq.property) (is_iso_Lcof_map' Lcof _ weak_eq.property) at hf,
    change is_iso _ at hf,
    rw ← bifibrant_object.is_iso_Lbif_map_iff_is_iso_Lcof_map Lcof
      bifibrant_object.homotopy_category.Q at hf,
    rw bifibrant_object.is_iso_Lbif_map_iff at hf,
    exact (CM2.left_iff_right_of_sq ((cofibrant_object.forget C).map_comm_sq sq) weak_eq.property weak_eq.property).mpr hf, },
  { exact localization.inverts Lcof cofibrant_object.weq f, },
end

lemma is_iso_Lcof_map_iff_is_iso_L_map
  {X Y : cofibrant_object C} (f : X ⟶ Y) :
  is_iso (Lcof.map f) ↔ is_iso (L.map ((cofibrant_object.forget C).map f)) :=
by rw [← (Hocof_to_Ho Lcof L).is_iso_map_iff, ← functor.comp_map,
  is_iso_map_iff_of_nat_iso (Lcof_comp_Hocof_to_Ho_iso Lcof L), functor.comp_map]

lemma is_iso_L_map_iff {X Y : C} (f : X ⟶ Y) :
  is_iso (L.map f) ↔ weq f :=
begin
  split,
  { intro hf,
    change (morphism_property.isomorphisms _).inverse_image L f at hf,
    have sq := comm_sq.mk (cofibrant_replacement.fac f),
    have eq := ((morphism_property.three_of_two.for_isomorphisms _).for_inverse_image L).left_iff_right_of_sq sq.flip (by { change is_iso _, apply_instance, }) (by { change is_iso _, apply_instance, }),
    rw ← eq at hf,
    change is_iso _ at hf,
    rw ← is_iso_Lcof_map_iff_is_iso_L_map L Lcof' at hf,
    rw cofibrant_object.is_iso_Lcof_map_iff at hf,
    exact (CM2.left_iff_right_of_sq sq.flip weak_eq.property weak_eq.property).mp hf, },
  { exact localization.inverts L weq f, },
end

end model_category

end algebraic_topology


import measure_theory.measurable_space
import measure_theory.integration
import measure_theory.borel_space

namespace measure_theory

section product
universes u_1 u_2
variables (α:Type u_1) (β:Type u_2) (s:set α)
open measure_theory measure_theory.simple_func

lemma lintegral_mul_indicator_eq_lintegral_mul_lintegral_indicator
  {α} [M:measurable_space α] (μ:measure_theory.measure α)
  (Mf:measurable_space α) (hMf:Mf ≤ M)
  (c:ennreal) (T:set α) (h_meas_T:M.measurable_set' T)
  (h_ind:∀ (S:set α), Mf.measurable_set' S →
  (μ S * μ T = μ (S ∩ T)))
  (f:α → ennreal) (h_meas_f:@measurable α ennreal Mf _ f):
@lintegral α M μ (λ a, (f * (T.indicator (λ (_x : α), c))) a) =
  @lintegral α M μ f *
  @lintegral α M μ (T.indicator (λ (_x : α), c)) :=
begin
  revert f,
  apply measurable.ennreal_induction,
  { intros c' s' h_meas_s',
      have h1:(λ a, (s'.indicator (λ (_x : α), c') * T.indicator (λ (_x : α), c)) a) =
         (λ a, (s' ∩ T).indicator (λ (_x :α), c * c') a),
      { ext1 a, cases classical.em (a ∈ s' ∩ T) with h1_1 h1_1,
        { rw set.indicator_of_mem h1_1, simp at h1_1,
          simp, rw if_pos,
          rw if_pos,
          rw mul_comm,
          apply h1_1.right,
          apply h1_1.left },
        { rw set.indicator_of_not_mem h1_1,
          simp,
          simp at h1_1,
          intros h1_2 h1_3,
          exfalso,
          apply h1_1,
          apply h1_2,
          apply h1_3 } },
      rw h1,
      rw measure_theory.lintegral_indicator,
      rw measure_theory.lintegral_indicator,
      rw measure_theory.lintegral_indicator,
      simp,
      rw ← h_ind,
      ring, apply h_meas_s',
      apply h_meas_T,
      apply hMf,
      apply h_meas_s',
      apply measurable_set.inter,
      apply hMf,
      apply h_meas_s',
      apply h_meas_T  },
  { intros f' g h_univ h_meas_f' h_meas_g h_ind_f' h_ind_g,
    have h_measM_f' := measurable.mono h_meas_f' hMf (le_refl _),
    have h_measM_g := measurable.mono h_meas_g hMf (le_refl _),
    have h_indicator:@measurable α ennreal M ennreal.measurable_space (λ (a : α), T.indicator (λ (_x : α), c) a),
    { apply measurable.indicator,
      apply measurable_const,
      apply h_meas_T,   },
    have h8:(f' + g) * T.indicator (λ (_x : α), c)=
             (λ a, (f' * (T.indicator (λ _, c))) a + (g * (T.indicator (λ _, c))) a),
    { ext1 a, simp [right_distrib] },
    rw h8,
    have h_add:(f' + g) = (λ a, (f' a + g a)),
   { refl },
   rw h_add,
   rw measure_theory.lintegral_add,
   rw measure_theory.lintegral_add,
   rw right_distrib,
   rw h_ind_f',
   rw h_ind_g,
   apply h_measM_f',
   apply h_measM_g,
   apply measurable.ennreal_mul,
   apply h_measM_f',
   apply h_indicator,
   apply measurable.ennreal_mul,
   apply h_measM_g,
   apply h_indicator, },
  { intros f h_meas_f h_mono_f h_ind_f,
    have h_measM_f := (λ n, measurable.mono (h_meas_f n) hMf (le_refl _)),
    have h_mul:
     (λ a, ((λ (x : α), ⨆ (n : ℕ), f n x) * T.indicator (λ (_x : α), c)) a) =
      (λ (a : α), ⨆ (n : ℕ), (λ (x:α), f n x * (T.indicator (λ (_x : α), c) x)) a),
    { ext1 a, rw @pi.mul_apply, rw ennreal.supr_mul, },
    rw h_mul,
    rw lintegral_supr,
    rw lintegral_supr,
    rw ennreal.supr_mul,
    have h_mul2:(λ (n:ℕ), (@lintegral α M μ
       (λ (x : α), f n x * T.indicator (λ (_x : α), c) x)))  =
        (λ n, @lintegral α M μ (f n) * @lintegral α M μ (T.indicator (λ (_x : α), c))),
    { ext1 n, rw ← h_ind_f n, refl },
    rw h_mul2,
    apply h_measM_f,
    apply h_mono_f,
    { intros n,
      apply measurable.ennreal_mul, apply h_measM_f, apply measurable.indicator,
      apply measurable_const, apply h_meas_T },
    { intros m n h_le a,
      apply ennreal.mul_le_mul, apply h_mono_f, apply h_le, apply le_refl _  },
    },
end

lemma lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space
{α} [M:measurable_space α] (μ:measure_theory.measure α)
(Mf:measurable_space α) (Mg:measurable_space α) (hMf:Mf ≤ M)
(hMg:Mg ≤ M)
(h_ind:∀ (S T:set α), Mf.measurable_set' S → Mg.measurable_set' T →
 (μ S * μ T = μ (S ∩ T)))
(f g:α → ennreal) (h_meas_f:@measurable α ennreal Mf _ f) (h_meas_g:@measurable α ennreal Mg _ g):
   @lintegral α M μ (λ a, (f * g) a) =
   @lintegral α M μ f *
   @lintegral α M μ g :=
begin
  revert g,
  have h_meas_Mf:∀ ⦃f:α → ennreal⦄, (@measurable α ennreal Mf _ f) → (@measurable α ennreal M _ f),
  { intros f' h_meas_f', apply measurable.mono h_meas_f' hMf, apply le_refl _ },
  have h_meas_Mg:∀ ⦃f:α → ennreal⦄, (@measurable α ennreal Mg _ f) → (@measurable α ennreal M _ f),
  { intros f' h_meas_f', apply measurable.mono h_meas_f' hMg, apply le_refl _ },
  have H1:= h_meas_Mf h_meas_f,
  apply measurable.ennreal_induction,
  intros c s h_s,
  { apply lintegral_mul_indicator_eq_lintegral_mul_lintegral_indicator,
    apply hMf,
    apply hMg,
    apply h_s,
    { intros S h_meas_S,
      apply h_ind, apply h_meas_S,
      apply h_s, },
    apply h_meas_f,
 },
  { intros f' g h_univ h_measMg_f' h_measMg_g h_ind_f' h_ind_g',
    have h_measM_f' := h_meas_Mg h_measMg_f',
    have h_measM_g := h_meas_Mg h_measMg_g,
    have h_add:(f' + g) = (λ a, (f' a + g a)),
    { refl },
    rw h_add,
    rw measure_theory.lintegral_add,
    have h8:(λ a, (f * λ a', (f' a' + g a')) a ) = (λ a, (f a * f' a) + (f a * g a)),
    { ext1 a, simp [left_distrib], },
    rw h8,
    rw measure_theory.lintegral_add,
    rw left_distrib,
    have h9:(λ a, (f * f') a) = (λ a, f a * f' a),
    { ext1 a, refl },
    rw ← h9,
    rw h_ind_f',
    have h10:(λ a, (f * g) a) = (λ a, f a * g a),
    { ext1 a, refl },
    rw ← h10,
    rw h_ind_g',
    apply measurable.ennreal_mul,
    apply H1,
    apply h_measM_f',
    apply measurable.ennreal_mul,
    apply H1,
    apply h_measM_g,
    apply h_measM_f',
    apply h_measM_g },
  { intros f' h_meas_f' h_mono_f' h_ind_f',
    have h_measM_f' := (λ n, h_meas_Mg (h_meas_f' n)),
    have h_mul:(λ (a : α), (f * λ (x : α), ⨆ (n : ℕ), f' n x) a) =
      (λ (a : α), ⨆ (n : ℕ), (λ (x:α), (f x * f' n x)) a),
    { ext1 a, simp, rw ennreal.mul_supr },
    rw h_mul,
    rw lintegral_supr,
    rw lintegral_supr,
    rw ennreal.mul_supr,
    have h_mul2:(λ (n:ℕ), (@lintegral α M μ (λ (x : α), f x * f' n x))) =
        (λ n, @lintegral α M μ f * @lintegral α M μ (f' n)),
    { ext1 n, rw ← h_ind_f' n, refl },
    rw h_mul2,
    { apply h_measM_f', },
    { apply h_mono_f', },
    { intros n, apply measurable.ennreal_mul,
      apply H1, apply h_measM_f' },
    { intros n m h_le a, apply ennreal.mul_le_mul,
       apply le_refl _, apply h_mono_f' h_le, },
},
end

lemma lintegral_mul_eq_lintegral_mul_lintegral_of_independent_fn {α} [M:measurable_space α] (μ:measure_theory.measure α)
(f g:α → ennreal) (h_meas_f:measurable f) (h_meas_g:measurable g)
(h_ind:∀ (S T:set ennreal), measurable_set S → measurable_set T →
 (μ (f ⁻¹' S) * μ (g ⁻¹' T) = μ ((f ⁻¹' S) ∩ (g ⁻¹' T)))):
∫⁻ (a : α), (f * g) a ∂μ =
(∫⁻ (a : α), f a ∂μ) *
(∫⁻ (a : α), g a ∂μ) :=
begin
  let Mf := ennreal.measurable_space.comap f,
  let Mg := ennreal.measurable_space.comap g,
  begin
    apply lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space μ Mf Mg,
    { rw measurable_iff_comap_le at h_meas_f,
      apply h_meas_f },
    { rw measurable_iff_comap_le at h_meas_g,
      apply h_meas_g },
    { intros S T h_S h_T,
      have h_S':∃ (A:set ennreal), (measurable_set A) ∧ (f ⁻¹' A = S),
      { apply h_S },
      have h_T':∃ (B:set ennreal), (measurable_set B) ∧ (g ⁻¹' B = T),
      { apply h_T },
      cases h_S' with A h_S',
      cases h_T' with B h_T',
      rw ← h_S'.right,
      rw ← h_T'.right,
      apply h_ind,
      apply h_S'.left,
      apply h_T'.left },
    { rw measurable_iff_comap_le, apply le_refl _ },
    { rw measurable_iff_comap_le, apply le_refl _ },
  end
end
end product
end measure_theory


/-
This defines the ArithM monad basic operations used to generate a system of
numerical equations from a Lean local context.
-/
import ClausalExtraction.Basic
import ClausalExtraction.ArithTheory.Int

open Lean -- (Expr levelZero levelOne mkApp mkAppN mkConst mkRawNatLit)
open Std (HashMap)

namespace ClausalExtraction

namespace ArithTheory

section ExpressionUtils

def natExpr : Expr := mkConst ``Nat
def intExpr := mkConst ``Int

private def notExpr : Expr := mkConst ``Not

def intAddConst : Expr :=
  let f := mkConst ``HAdd.hAdd [levelZero, levelZero, levelZero]
  let inst := mkAppN (mkConst ``instHAdd [levelZero]) #[intExpr, mkConst ``Int.instAddInt]
  mkAppN f #[intExpr, intExpr, intExpr, inst]

def intSubConst : Expr :=
  let f := mkConst ``HSub.hSub [levelZero, levelZero, levelZero]
  let inst := mkAppN (mkConst ``instHAdd [levelZero]) #[intExpr, mkConst ``Int.instSubInt]
  mkAppN f #[intExpr, intExpr, intExpr, inst]

def intMulConst : Expr :=
  let f := mkConst ``HMul.hMul [levelZero, levelZero, levelZero]
  let inst := mkAppN (mkConst ``instHMul [levelZero]) #[intExpr, mkConst ``Int.instMulInt]
  mkAppN f #[intExpr, intExpr, intExpr, inst]

def intNegConst : Expr :=
  let f := mkConst ``Neg.neg [levelZero]
  let inst := mkConst ``Int.instNegInt
  mkAppN f #[intExpr, inst]

-- A structure used to denote an integer expression
structure IntExpr where
  toExpr : Expr
  deriving BEq, Hashable, Inhabited

namespace IntExpr

instance : Coe IntExpr Expr where
  coe := IntExpr.toExpr

instance : Add IntExpr where
  add := λx y => IntExpr.mk (mkAppN intAddConst #[x, y])

end IntExpr

-- Create a nat as an int
def mkOfNat (n:Expr) : IntExpr :=
  let ofNat := mkConst ``OfNat.ofNat [levelZero]
  let inst := mkConst ``Int.instOfNatInt
  IntExpr.mk (mkAppN ofNat #[intExpr, n, mkApp inst n])

-- Create a nat lit as an int
def natLitAsIntExpr (n:Nat) : IntExpr := mkOfNat (mkRawNatLit n)

def mkIntLit : Int → IntExpr
| Int.ofNat n => natLitAsIntExpr n
| Int.negSucc n => IntExpr.mk (mkApp intNegConst (natLitAsIntExpr (n+1)))

instance : Coe Int IntExpr where
  coe := mkIntLit

def intZeroExpr : IntExpr := mkIntLit 0

private def intNonNegExpr : Expr := mkConst ``Int.NonNeg
def mkIntNonNegExpr (e:Expr) : Expr := mkApp intNonNegExpr e

private def intEqExpr : Expr := mkApp (mkConst ``Eq [levelOne]) (mkConst ``Int)
def mkIntEq0Expr (e:Expr) : Expr := mkAppN intEqExpr #[e, intZeroExpr]

end ExpressionUtils

-- Represents a polynomial.
structure Poly where
  -- Poly should be a sorted array of non-zero integers and variable pairs.
  elements : Array (Int × TheoryVar)
  deriving BEq, Hashable, Repr

namespace Poly

-- | Create polynomial denoting constant zero.
protected def const (z:Int) : Poly := ⟨#[(z, ⟨0⟩)]⟩

-- | Create polynomial denoting constant zero.
protected def zero : Poly := Poly.const 0

-- | Create polynomial denoting constant zero.
protected def one : Poly := Poly.const 1

instance : Inhabited Poly := ⟨Poly.zero⟩

-- | Create polynomial denoting constant zero.
-- protected def one : Poly := ⟨#[(1, ⟨0⟩)]⟩

def addc : Poly → Int → Poly
| ⟨a⟩, q =>
  let (p,v) := a.get! 0
  ⟨a.set! 0 (p+q, v)⟩

-- | @add p i _ v@ returns poly denoting @p + i*v@.
def add : Poly → Int → TheoryVar → Poly
| ⟨a⟩, q, v =>
  let rec loop : ∀(i : Nat), Poly
      | 0 => ⟨a.insertAt 1 (q, v)⟩
      | Nat.succ i =>
        let (p,u) := a[i+1]
        if v < u then
          loop i
        else if u < v then
          ⟨a.insertAt (i+2) (q,v)⟩
        else -- v = u
          let q := p+q
          if q = 0 then
            ⟨a.eraseIdx (i+1)⟩
          else
            ⟨a.set! (i+1) (q,v)⟩
  loop (a.size-1)

protected def toString : Poly → String
| ⟨a⟩ =>
  let scalarProd : Int × TheoryVar → String
        | (m,v) => s!"{m}*{v}"
  let firstScalarProd : Int × TheoryVar → String
        | (m, _) => toString m
  let polyIns := λ(e:String) h => s!"{e} + {scalarProd h}"
  a[1:].foldl polyIns (firstScalarProd a[0])

instance : ToString Poly where
  toString := Poly.toString

def scalarProd (f: v → IO IntExpr) : Int × v → IO IntExpr
| (m,  v) => do IntExpr.mk (mkAppN intMulConst #[m, ← f v])

-- | Create an reflexivity proof from the int expression.
def mkIntRefl (e:IntExpr) : Expr := mkApp (mkApp (mkConst ``rfl [levelOne]) intExpr) e

-- | Map polynomial to expression given mapping from variables
-- to expressions.
-- The optional parameter allowss this to to only take the first n elements.
protected
def expr (poly:Poly) (f: TheoryVar → IO IntExpr) (limit: optParam Nat (poly.elements.size - 1)) : IO IntExpr := do
  if poly.elements.size = 0 then
    panic! "Empty polyExpr"
  if limit ≥ poly.elements.size then
    panic! "polyExpr given bad limit."
  let mut e : IntExpr ← poly.elements[0].fst
  for p in poly.elements[1:limit+1] do
    e := e + (← scalarProd f p)
  pure e

private
theorem polyProofAddContextLemma {c x a:Int} (h:x + c = a) (y:Int)
  : (x + y) + c = a + y := by
  simp [h.symm, Int.add_assoc, Int.add_comm y c]

-- polyProofAddContext s x c a h poly idx where h is a proof of "x + c = a" returns
-- a proof "(x + poly[idx] + poly[idx+1] + ..) + c = a + poly[idx] + poly[idx+1] + .."
private
def polyProofAddContext (f:TheoryVar → IO IntExpr) (x c a:IntExpr) (h:Expr) (poly:Poly) (idx:Nat) : IO Expr := do
  let mut x := x
  let mut a := a
  let mut h := h
  let pr := mkApp (mkConst ``polyProofAddContextLemma) c
  for p in poly.elements[idx:] do
    let y ← scalarProd f p
    h := mkAppN pr #[x, a, h, y]
    x := x + y
    a := a + y
  pure h

section Lemmas

private
theorem sum0Lemma (p q v:Int) : p*v + q*v = (p+q)*v := Eq.symm (Int.add_mul _ _ _)

private
theorem sumLemma (r p q v:Int) : (r + p*v) + q*v = r + (p+q)*v := by
  apply Eq.trans (Int.add_assoc r _ _)
  apply congrArg (fun y => r + y)
  exact sum0Lemma _ _ _

private
theorem cancel0Lemma {p q:Int} (h : p+q = 0) (v:Int) : p*v + q*v = 0 := by
  apply Eq.trans (sum0Lemma p q v)
  exact @Eq.substr Int (λx => x * v = 0) _ _ h (Int.zero_mul v)

example        : (64:Int) + -64 = 0   := @cancel0Lemma (64) (-64) (@rfl Int 0) 1
example        : (-64:Int) + 64 = 0   := @cancel0Lemma (-64) (64) (@rfl Int 0) 1
example (v:Int): -64 * v + 64 * v = 0 := @cancel0Lemma (-64) 64   (@rfl Int 0) v
example (v:Int): 64 * v + -64 * v = 0 := @cancel0Lemma (64) (-64) (@rfl Int 0) v

private
theorem cancelLemma (r p q v:Int) (h : p+q = 0) : (r + p*v) + q*v = r := by
  apply Eq.trans (Int.add_assoc r _ _)
  exact Eq.trans (cancel0Lemma h v ▸ rfl) (Int.add_zero r)

end Lemmas

def addcProof (f:TheoryVar → IO IntExpr) (poly:Poly) (c:Int) (g:c ≠ 0) : IO Expr := do
  let x := poly.elements[0].fst
  let a := x + c
  let h := mkIntRefl a
  polyProofAddContext f x c a h poly 1

-- | @addProof f p m v@ returns proof showing that
-- @p.expr + scalarProd f (m, v) = (p.add m v).expr@.
def addProof (f:TheoryVar → IO IntExpr) : ∀(poly:Poly) (q:Int), q ≠ 0 → TheoryVar → IO Expr
| poly, q, g, v => do
  let c ← scalarProd f (q, v)
  let rec loop : ∀(i : Nat), IO Expr
      | 0 => do
        -- Handle case where var is zero.
        let x : IntExpr := poly.elements[0].fst
        let a := x + c
        let h := mkIntRefl a
        polyProofAddContext f x c a h poly 1
      | Nat.succ i => do
        let (p,u) := poly.elements[i+1]
        if v < u then
          loop i
        else if u < v then
          let x ← poly.expr f (limit := i+1)
          let a := x + c
          let h := mkIntRefl a
          polyProofAddContext f x c a h poly (i+2)
        else -- v = u
          if p+q = 0 then
            let a ← poly.expr f (limit := i)
            let x := a + (← scalarProd f (p,u))
            let rflExpr := mkIntRefl intZeroExpr
            -- Create proof: (a + -q*v) + q*v = a.
            let h := mkAppN (mkConst ``cancelLemma) #[a, (-q : Int), q, ← f v, rflExpr]
            polyProofAddContext f x c a h poly (i+2)
          else
            let r ← poly.expr f (limit := i)
            let x := r + (←scalarProd f (p, u))
            let a := r + (←scalarProd f (p+q, u))
            let h := mkAppN (mkConst ``sumLemma) #[r, p, q, ←f v]
            polyProofAddContext f x c a h poly (i+2)
  loop (poly.elements.size - 1)

end Poly

-- Definition associated with a variable.
inductive Decl
  -- A int variable from another theory.
| uninterpInt : Var → Decl
  -- A nat variable from another theory.
| uninterpNat : Var → Decl
  -- Theory variable is equal to polynomial.
| poly : Poly → Decl
deriving BEq, Hashable

namespace Decl

protected def toString : Decl → String
| uninterpInt v => s!"{v}"
| uninterpNat v => s!"ofNat {v}"
| poly p => s!"poly {p}"

instance : ToString Decl where
  toString := Decl.toString

instance : Inhabited Decl := ⟨uninterpInt arbitrary⟩

end Decl

-- | An atomic predicate
inductive Pred where
-- This denotes a proof of the form (v = 0)
| IsEq0 : TheoryVar → Pred
-- This denotes a proof of the form (Not (v = 0))
| IsNe0 : TheoryVar → Pred
-- This denotes a proof of the form (Int.NonNeg v)
| IsGe0 : TheoryVar → Pred
  deriving Inhabited

namespace Pred

protected def toString : Pred → String
| IsEq0 v => s!"IsEq0 {v}"
| IsNe0 v => s!"IsNe0 {v}"
| IsGe0 v => s!"IsGe0 {v}"

instance : ToString Pred := ⟨Pred.toString⟩

end Pred

def oneVar : TheoryVar := ⟨0⟩

structure State : Type where

  exprMap : HashMap Decl TheoryVar := Std.mkHashMap.insert (Decl.poly Poly.one) oneVar
  vars : Array Decl := #[Decl.poly Poly.one]
  preds : Array Pred := #[]

section

variable (r:IO.Ref State)
variable (f: Var → IO Expr)

-- | Return Lean expression associated with IntExpr
partial def thvarExpr (v:TheoryVar) : IO IntExpr := do
  let s ← r.get
  if p : v.toNat < s.vars.size then
    match s.vars.get ⟨v.toNat, p⟩  with
    | Decl.uninterpInt v => do
      IntExpr.mk <$> f v
    | Decl.uninterpNat v => do
      mkOfNat <$> f v
    | Decl.poly p => p.expr (thvarExpr)
  else
    panic! s!"Invalid theory variable index {v} (max = {s.vars.size})"

end

abbrev ArithM := ReaderT (IO.Ref State) SolverM

-- | Return a theory variable associated with the given uninterpreted Lean expression.
def getTheoryVar (d:Decl) : ArithM TheoryVar := do
  let r ← read
  let s ← r.get
  match s.exprMap.find? d with
  | none => pure ()
  | some v => return v
  let newVar := ⟨OfNat.ofNat s.vars.size⟩
  if (newVar.index : UInt32) = 0 then
    throwError m!"Only 2^32 arithmetic variables allowed."
  r.set
    { s with exprMap := s.exprMap.insert d newVar,
             vars := s.vars.push d }
  return newVar

-- | Return a theory variable associated with the given uninterpreted Lean expression.
def getPolyVar (p:Poly) : ArithM TheoryVar := getTheoryVar (Decl.poly p)

def getThvarExpr (v:TheoryVar) : ArithM IntExpr := do
  let svc ← (read : SolverM _)
  let r ← read
  thvarExpr r svc.varExpr v

-- | Return expression associated with in solver.
def getPolyExpr (poly:Poly) : ArithM IntExpr := do
  let svc ← (read : SolverM _)
  let r ← read
  let f (v:TheoryVar) : IO IntExpr := thvarExpr r svc.varExpr v
  poly.expr f

def getTheoryPred (p:Pred) : ArithM TheoryPred := do
  let r ← read
  let s ← r.get
  if TheoryPred.max ≤ s.preds.size then
    throwError "Only 2^32 arithmetic variables allowed."
  let n := TheoryPred.ofNat (s.preds.size)
  r.set { s with preds := s.preds.push p }
  pure n

def mthvarExpr (r: IO.Ref State) (f : Var → IO Expr)  (thv : TheoryVar) : IO Expr := do
  IntExpr.toExpr <$> thvarExpr r f thv

def predExpr (r : IO.Ref State) (f : Var → IO Expr) (idx : TheoryPred) : IO Expr := do
  let s ← r.get
  if lt : idx.toNat < s.preds.size  then
    match s.preds.get ⟨idx.toNat, lt⟩  with
    | Pred.IsEq0 v => mkIntEq0Expr <$> mthvarExpr r f v
    | Pred.IsNe0 v => mkApp notExpr <$> (mkIntEq0Expr <$> mthvarExpr r f v)
    | Pred.IsGe0 v => mkIntNonNegExpr <$> mthvarExpr r f v
  else
    panic s!"Invalid predicate index {idx} (max = {s.preds.size})"

end ArithTheory

end ClausalExtraction


import GMLInit.Data.Basic
import GMLInit.Data.Ord
import GMLInit.Logic.Relation
import GMLInit.Meta.Basic

abbrev xor : Bool → Bool → Bool := bne
infixl:30 " ^^ " => xor

namespace Bool
variable (x y z : Bool)

local syntax "bool_tt" (&"using" tactic)? (colGt term:max)* : tactic
macro_rules
| `(tactic| bool_tt) => `(tactic| rfl)
| `(tactic| bool_tt using $tac) => `(tactic| $tac)
| `(tactic| bool_tt $[using $tac]? $x:term $xs:term*) => `(tactic| cases ($x : Bool) <;> bool_tt $[using $tac]? $xs*)

instance : LinearOrd Bool where
  symm (x y) := by bool_tt x y
  le_trans {x y z} _ _ _ := by bool_tt using contradiction x y z
  eq_strict {x y} _ := by bool_tt using first | rfl | contradiction x y

instance : LE Bool := leOfOrd
instance : LT Bool := ltOfOrd

theorem eq_iff_iff : x = y ↔ (x ↔ y) := by bool_tt using simp x y

-- assert not_not : !(!x) = x := by bool_tt x
theorem not_and : (!(x && y)) = (!x || !y) := by bool_tt x y
theorem not_or : (!(x || y)) = (!x && !y) := by bool_tt x y

theorem and_false_left : (false && x) = false := by bool_tt x
theorem and_false_right : (x && false) = false := by bool_tt x
theorem and_true_left : (true && x) = x := by bool_tt x
theorem and_true_right : (x && true) = x := by bool_tt x
theorem and_not_self_left : (!x && x) = false := by bool_tt x
theorem and_not_self_right : (x && !x) = false := by bool_tt x
theorem and_idem : (x && x) = x := by bool_tt x
theorem and_comm : (x && y) = (y && x) := by bool_tt x y
theorem and_left_comm : (x && (y && z)) = (y && (x && z)) := by bool_tt x y z
theorem and_right_comm : ((x && y) && z) = ((x && z) && y) := by bool_tt x y z
-- assert and_assoc : ((x && y) && z) = (x && (y && z)) := by bool_tt x y z
theorem and_or_distrib_left : (x && (y || z)) = ((x && y) || (x && z)) := by bool_tt x y z
theorem and_or_distrib_right : ((x || y) && z) = ((x && z) || (y && z)) := by bool_tt x y z
theorem and_xor_distrib_left : (x && (y ^^ z)) = ((x && y) ^^ (x && z)) := by bool_tt x y z
theorem and_xor_distrib_right : ((x ^^ y) && z) = ((x && z) ^^ (y && z)) := by bool_tt x y z
theorem and_deMorgan : (!(x && y)) = (!x || !y) := by bool_tt x y
theorem and_eq_true_iff : (x && y) = true ↔ x = true ∧ y = true := by bool_tt using simp x y
theorem and_eq_false_iff : (x && y) = false ↔ x = false ∨ y = false := by bool_tt using simp x y

theorem or_false_left : (false || x) = x := by bool_tt x
theorem or_false_right : (x || false) = x := by bool_tt x
theorem or_true_left : (true || x) = true := by bool_tt x
theorem or_true_right : (x || true) = true := by bool_tt x
theorem or_not_self_left : (!x || x) = true := by bool_tt x
theorem or_not_self_right : (x || !x) = true := by bool_tt x
theorem or_idem : (x || x) = x := by bool_tt x
theorem or_comm : (x || y) = (y || x) := by bool_tt x y
theorem or_left_comm : (x || (y || z)) = (y || (x || z)) := by bool_tt x y z
theorem or_right_comm : ((x || y) || z) = ((x || z) || y) := by bool_tt x y z
-- assort or_assoc : ((x || y) || z) = (x || (y || z)) := by bool_tt x y z
theorem or_and_distrib_left : (x || (y && z)) = ((x || y) && (x || z)) := by bool_tt x y z
theorem or_and_distrib_right : ((x && y) || z) = ((x || z) && (y || z)) := by bool_tt x y z
theorem or_deMorgan : (!(x || y)) = (!x && !y) := by bool_tt x y
theorem or_eq_true_iff : (x || y) = true ↔ x = true ∨ y = true := by bool_tt using simp x y
theorem or_eq_false_iff : (x || y) = false ↔ x = false ∧ y = false := by bool_tt using simp x y

theorem xor_false_left : (false ^^ x) = x := by bool_tt x
theorem xor_false_right : (x ^^ false) = x := by bool_tt x
theorem xor_true_left : (true ^^ x) = !x := by bool_tt x
theorem xor_true_right : (x ^^ true) = !x := by bool_tt x
theorem xor_self : (x ^^ x) = false := by bool_tt x
theorem xor_not_self_left : (!x ^^ x) = true := by bool_tt x
theorem xor_not_self_right : (x ^^ !x) = true := by bool_tt x
theorem xor_comm : (x ^^ y) = (y ^^ x) := by bool_tt x y
theorem xor_left_comm : (x ^^ (y ^^ z)) = (y ^^ (x ^^ z)) := by bool_tt x y z
theorem xor_right_comm : ((x ^^ y) ^^ z) = ((x ^^ z) ^^ y) := by bool_tt x y z
theorem xor_assoc : ((x ^^ y) ^^ z) = (x ^^ (y ^^ z)) := by bool_tt x y z

protected abbrev beq := x == y
protected abbrev bne := x != y
protected abbrev bge := x || !y
protected abbrev bgt := x && !y
protected abbrev ble := !x || y
protected abbrev blt := !x && y

theorem beq_eq_decide_eq : Bool.beq x y = decide (x = y) := by bool_tt x y
theorem bne_eq_decide_ne : Bool.bne x y = decide (x ≠ y) := by bool_tt x y
theorem bge_eq_decide_ge : Bool.bge x y = decide (x ≥ y) := by bool_tt x y
theorem bgt_eq_decide_gt : Bool.bgt x y = decide (x > y) := by bool_tt x y
theorem ble_eq_decide_le : Bool.ble x y = decide (x ≤ y) := by bool_tt x y
theorem blt_eq_decide_lt : Bool.blt x y = decide (x < y) := by bool_tt x y

protected theorem le_refl : x ≤ x := by bool_tt x
protected theorem le_trans {x y z : Bool} : x ≤ y → y ≤ z → x ≤ z := by bool_tt using simp x y z
protected theorem le_antisymm {x y : Bool} : x ≤ y → y ≤ x → x = y := by bool_tt using simp x y
protected theorem lt_irrefl : ¬ x < x := by bool_tt using simp x
protected theorem lt_asymm {x y : Bool} : x < y → ¬ y < x := by bool_tt using simp x y
protected theorem lt_trans {x y z : Bool} : x < y → y < z → x < z := by bool_tt using simp x y z
protected theorem lt_of_le_of_lt {x y z : Bool} : x ≤ y → y < z → x < z := by bool_tt using simp x y z
protected theorem lt_of_lt_of_le {x y z : Bool} : x < y → y ≤ z → x < z := by bool_tt using simp x y z
protected theorem le_of_lt {x y : Bool} : x < y → x ≤ y := by bool_tt using simp x y z
protected theorem le_of_eq {x y : Bool} : x = y → x ≤ y := by bool_tt using simp x y z
protected theorem ne_of_lt {x y : Bool} : x < y → x ≠ y := by bool_tt using simp x y z
protected theorem lt_of_le_of_ne {x y : Bool} : x ≤ y → x ≠ y → x < y := by bool_tt using simp x y z
protected theorem le_of_lt_or_eq {x y : Bool} : x < y ∨ x = y → x ≤ y := by bool_tt using simp x y z
protected theorem le_true : x ≤ true := by bool_tt x
protected theorem false_le : false ≤ x := by bool_tt x
protected theorem eq_true_of_true_le {x : Bool} : true ≤ x → x = true := by bool_tt using simp x
protected theorem eq_false_of_le_false {x : Bool} : x ≤ false → x = false := by bool_tt using simp x

instance : Relation.Reflexive (α:=Bool) (.≤.) := ⟨Bool.le_refl⟩
instance : Relation.Irreflexive (α:=Bool) (.<.) := ⟨Bool.lt_irrefl⟩
instance : Relation.Antisymmetric (α:=Bool) (.≤.) := ⟨Bool.le_antisymm⟩
instance : Relation.Asymmetric (α:=Bool) (.<.) := ⟨Bool.lt_asymm⟩
instance : Relation.Transitive (α:=Bool) (.≤.) := ⟨Bool.le_trans⟩
instance : Relation.Transitive (α:=Bool) (.<.) := ⟨Bool.lt_trans⟩
instance : Relation.HTransitive (α:=Bool) (β:=Bool) (γ:=Bool) (.<.) (.≤.) (.<.) := ⟨Bool.lt_of_lt_of_le⟩
instance : Relation.HTransitive (α:=Bool) (β:=Bool) (γ:=Bool) (.≤.) (.<.) (.<.) := ⟨Bool.lt_of_le_of_lt⟩

theorem not_inj {x y : Bool} : (!x) = (!y) → x = y := by
  bool_tt using simp x y

theorem and_or_inj_right {m x y : Bool}: (x && m) = (y && m) → (x || m) = (y || m) → x = y := by
  bool_tt using simp m x y

theorem and_or_inj_left {m x y : Bool} : (m && x) = (m && y) → (m || x) = (m || y) → x = y := by
  bool_tt using simp m x y

section
variable (xs ys : List Bool)

abbrev all : Bool := xs.all id

theorem all_nil : all [] = true := rfl
theorem all_one : all [x] = x := Bool.and_true x
theorem all_cons  : all (x :: xs) = (x && all xs) := rfl

theorem all_append : all (xs ++ ys) = (all xs && all ys) := by
  induction xs with
  | nil => rw [List.nil_append, all_nil, true_and]
  | cons x xs ih => rw [List.cons_append, all_cons, all_cons, and_assoc, ih]

theorem all_join (xss : List (List Bool)) : all (xss.map all) = all xss.join := by
  induction xss with
  | nil => rfl
  | cons xs xss ih => rw [List.map, List.join, all_cons, all_append, ih]

abbrev any : Bool := xs.any id

theorem any_nil : any [] = false := rfl
theorem any_one : any [x] = x := Bool.or_false x
theorem any_cons : any (x :: xs) = (x || any xs) := rfl

theorem any_append : any (xs ++ ys) = (any xs || any ys) := by
  induction xs with
  | nil => rw [List.nil_append, any_nil, false_or]
  | cons x xs ih => rw [List.cons_append, any_cons, any_cons, or_assoc, ih]

theorem any_join (xss : List (List Bool)) : any (xss.map any) = any xss.join := by
  induction xss with
  | nil => rfl
  | cons xs xss ih => rw [List.map, List.join, any_cons, any_append, ih]

theorem all_deMorgan : (!all xs) = any (xs.map (!.)) := by
  induction xs with
  | nil => rfl
  | cons x xs ih => rw [List.map, all_cons, any_cons, and_deMorgan, ih]

theorem any_deMorgan : (!any xs) = all (xs.map (!.)) := by
  induction xs with
  | nil => rfl
  | cons x xs ih => rw [List.map, any_cons, all_cons, or_deMorgan, ih]

end

end Bool


/-
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
-/
import data.list.range
import data.list.perm

/-!
# Utilities for lists of sigmas

This file includes several ways of interacting with `list (sigma β)`, treated as a key-value store.

If `α : Type*` and `β : α → Type*`, then we regard `s : sigma β` as having key `s.1 : α` and value
`s.2 : β s.1`. Hence, `list (sigma β)` behaves like a key-value store.

## Main Definitions

- `list.keys` extracts the list of keys.
- `list.nodupkeys` determines if the store has duplicate keys.
- `list.lookup`/`lookup_all` accesses the value(s) of a particular key.
- `list.kreplace` replaces the first value with a given key by a given value.
- `list.kerase` removes a value.
- `list.kinsert` inserts a value.
- `list.kunion` computes the union of two stores.
- `list.kextract` returns a value with a given key and the rest of the values.
-/

universes u v

namespace list
variables {α : Type u} {β : α → Type v}

/-! ### `keys` -/

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

@[simp] theorem keys_nil : @keys α β [] = [] := rfl

@[simp] theorem keys_cons {s} {l : list (sigma β)} : (s :: l).keys = s.1 :: l.keys := rfl

theorem mem_keys_of_mem {s : sigma β} {l : list (sigma β)} : s ∈ l → s.1 ∈ l.keys :=
mem_map_of_mem sigma.fst

theorem exists_of_mem_keys {a} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a), sigma.mk a b ∈ l :=
let ⟨⟨a', b'⟩, m, e⟩ := exists_of_mem_map h in
eq.rec_on e (exists.intro b' m)

theorem mem_keys {a} {l : list (sigma β)} : a ∈ l.keys ↔ ∃ (b : β a), sigma.mk a b ∈ l :=
⟨exists_of_mem_keys, λ ⟨b, h⟩, mem_keys_of_mem h⟩

theorem not_mem_keys {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ b : β a, sigma.mk a b ∉ l :=
(not_iff_not_of_iff mem_keys).trans not_exists

theorem not_eq_key {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ s : sigma β, s ∈ l → a ≠ s.1 :=
iff.intro
  (λ h₁ s h₂ e, absurd (mem_keys_of_mem h₂) (by rwa e at h₁))
  (λ f h₁, let ⟨b, h₂⟩ := exists_of_mem_keys h₁ in f _ h₂ rfl)

/-! ### `nodupkeys` -/

/-- Determines whether the store uses a key several times. -/
def nodupkeys (l : list (sigma β)) : Prop := l.keys.nodup

theorem nodupkeys_iff_pairwise {l} : nodupkeys l ↔
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l := pairwise_map _

theorem nodupkeys.pairwise_ne {l} (h : nodupkeys l) :
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l :=
nodupkeys_iff_pairwise.1 h

@[simp] theorem nodupkeys_nil : @nodupkeys α β [] := pairwise.nil

@[simp] theorem nodupkeys_cons {s : sigma β} {l : list (sigma β)} :
  nodupkeys (s::l) ↔ s.1 ∉ l.keys ∧ nodupkeys l :=
by simp [keys, nodupkeys]

theorem nodupkeys.eq_of_fst_eq {l : list (sigma β)}
  (nd : nodupkeys l) {s s' : sigma β} (h : s ∈ l) (h' : s' ∈ l) :
  s.1 = s'.1 → s = s' :=
@forall_of_forall_of_pairwise _
  (λ s s' : sigma β, s.1 = s'.1 → s = s')
  (λ s s' H h, (H h.symm).symm) _ (λ x h _, rfl)
  ((nodupkeys_iff_pairwise.1 nd).imp (λ s s' h h', (h h').elim)) _ h _ h'

theorem nodupkeys.eq_of_mk_mem {a : α} {b b' : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) (h' : sigma.mk a b' ∈ l) : b = b' :=
by cases nd.eq_of_fst_eq h h' rfl; refl

theorem nodupkeys_singleton (s : sigma β) : nodupkeys [s] := nodup_singleton _

theorem nodupkeys_of_sublist {l₁ l₂ : list (sigma β)} (h : l₁ <+ l₂) :
  nodupkeys l₂ → nodupkeys l₁ :=
nodup_of_sublist (h.map _)

theorem nodup_of_nodupkeys {l : list (sigma β)} : nodupkeys l → nodup l :=
nodup_of_nodup_map _

theorem perm_nodupkeys {l₁ l₂ : list (sigma β)} (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ :=
(h.map _).nodup_iff

theorem nodupkeys_join {L : list (list (sigma β))} :
  nodupkeys (join L) ↔ (∀ l ∈ L, nodupkeys l) ∧ pairwise disjoint (L.map keys) :=
begin
  rw [nodupkeys_iff_pairwise, pairwise_join, pairwise_map],
  refine and_congr (ball_congr $ λ l h, by simp [nodupkeys_iff_pairwise]) _,
  apply iff_of_eq, congr' with l₁ l₂,
  simp [keys, disjoint_iff_ne]
end

theorem nodup_enum_map_fst (l : list α) : (l.enum.map prod.fst).nodup :=
by simp [list.nodup_range]

lemma mem_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodup) (nd₁ : l₁.nodup)
  (h : ∀ x, x ∈ l₀ ↔ x ∈ l₁) : l₀ ~ l₁ :=
begin
  induction l₀ with x xs generalizing l₁; cases l₁ with y ys,
  { constructor },
  iterate 2
  { specialize h x <|> specialize h y, simp at h,
    cases h },
  simp at nd₀ nd₁, classical,
  cases nd₀, cases nd₁,
  by_cases h' : x = y,
  { subst y, constructor, apply l₀_ih ‹ _ › ‹ nodup ys ›,
    intro a, specialize h a, simp at h,
    by_cases h' : a = x,
    { subst a, rw ← not_iff_not, split; intro; assumption },
    { simp [h'] at h, exact h } },
  { transitivity x :: y :: ys.erase x,
    { constructor, apply l₀_ih ‹ _ ›,
      { simp, split, { intro, apply nd₁_left, apply mem_of_mem_erase ‹_› },
        apply nodup_erase_of_nodup; assumption },
      { intro a, specialize h a, simp at h,
        by_cases h' : a = x,
        { subst a, rw ← not_iff_not, split; intro, simp [mem_erase_of_nodup,*], assumption },
        { simp [h'] at h, simp [h], apply or_congr, refl,
          simp [mem_erase_of_ne,*] } } },
    transitivity y :: x :: ys.erase x,
    { constructor },
    { constructor, symmetry, apply perm_cons_erase,
      specialize h x, simp [h'] at h, exact h } }
end

variables [decidable_eq α]

/-! ### `lookup` -/

/-- `lookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def lookup (a : α) : list (sigma β) → option (β a)
| []             := none
| (⟨a', b⟩ :: l) := if h : a' = a then some (eq.rec_on h b) else lookup l

@[simp] theorem lookup_nil (a : α) : lookup a [] = @none (β a) := rfl

@[simp] theorem lookup_cons_eq (l) (a : α) (b : β a) : lookup a (⟨a, b⟩::l) = some b :=
dif_pos rfl

@[simp] theorem lookup_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup a (s::l) = lookup a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_is_some {a : α} : ∀ {l : list (sigma β)},
  (lookup a l).is_some ↔ a ∈ l.keys
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_is_some] },
end

theorem lookup_eq_none {a : α} {l : list (sigma β)} :
  lookup a l = none ↔ a ∉ l.keys :=
by simp [← lookup_is_some, option.is_none_iff_eq_none]

theorem of_mem_lookup
  {a : α} {b : β a} : ∀ {l : list (sigma β)}, b ∈ lookup a l → sigma.mk a b ∈ l
| (⟨a', b'⟩ :: l) H := begin
  by_cases h : a = a',
  { subst a', simp at H, simp [H] },
  { simp [h] at H, exact or.inr (of_mem_lookup H) }
end

theorem mem_lookup {a} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys)
  (h : sigma.mk a b ∈ l) : b ∈ lookup a l :=
begin
  cases option.is_some_iff_exists.mp (lookup_is_some.mpr (mem_keys_of_mem h)) with b' h',
  cases nd.eq_of_mk_mem h (of_mem_lookup h'),
  exact h'
end

theorem map_lookup_eq_find (a : α) : ∀ l : list (sigma β),
  (lookup a l).map (sigma.mk a) = find (λ s, a = s.1) l
| [] := rfl
| (⟨a', b'⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, map_lookup_eq_find] }
end

theorem mem_lookup_iff {a : α} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys) :
  b ∈ lookup a l ↔ sigma.mk a b ∈ l :=
⟨of_mem_lookup, mem_lookup nd⟩

theorem perm_lookup (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup a l₁ = lookup a l₂ :=
by ext b; simp [mem_lookup_iff, nd₁, nd₂]; exact p.mem_iff

lemma lookup_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodupkeys) (nd₁ : l₁.nodupkeys)
  (h : ∀ x y, y ∈ l₀.lookup x ↔ y ∈ l₁.lookup x) : l₀ ~ l₁ :=
mem_ext (nodup_of_nodupkeys nd₀) (nodup_of_nodupkeys nd₁)
  (λ ⟨a,b⟩, by rw [← mem_lookup_iff, ← mem_lookup_iff, h]; assumption)

/-! ### `lookup_all` -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookup_all (a : α) : list (sigma β) → list (β a)
| []             := []
| (⟨a', b⟩ :: l) := if h : a' = a then eq.rec_on h b :: lookup_all l else lookup_all l

@[simp]

@[simp] theorem lookup_all_cons_eq (l) (a : α) (b : β a) :
  lookup_all a (⟨a, b⟩::l) = b :: lookup_all a l :=
dif_pos rfl

@[simp] theorem lookup_all_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup_all a (s::l) = lookup_all a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_all_eq_nil {a : α} : ∀ {l : list (sigma β)},
  lookup_all a l = [] ↔ ∀ b : β a, sigma.mk a b ∉ l
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_all_eq_nil] },
end

theorem head_lookup_all (a : α) : ∀ l : list (sigma β),
  head' (lookup_all a l) = lookup a l
| []             := by simp
| (⟨a', b⟩ :: l) := by by_cases h : a = a'; [{subst h, simp}, simp *]

theorem mem_lookup_all {a : α} {b : β a} :
  ∀ {l : list (sigma β)}, b ∈ lookup_all a l ↔ sigma.mk a b ∈ l
| []              := by simp
| (⟨a', b'⟩ :: l) := by by_cases h : a = a'; [{subst h, simp *}, simp *]

theorem lookup_all_sublist (a : α) :
  ∀ l : list (sigma β), (lookup_all a l).map (sigma.mk a) <+ l
| []              := by simp
| (⟨a', b'⟩ :: l) := begin
    by_cases h : a = a',
    { subst h, simp, exact (lookup_all_sublist l).cons2 _ _ _ },
    { simp [h], exact (lookup_all_sublist l).cons _ _ _ }
  end

theorem lookup_all_length_le_one (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  length (lookup_all a l) ≤ 1 :=
by have := nodup_of_sublist ((lookup_all_sublist a l).map _) h;
   rw map_map at this; rwa [← nodup_repeat, ← map_const _ a]

theorem lookup_all_eq_lookup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  lookup_all a l = (lookup a l).to_list :=
begin
  rw ← head_lookup_all,
  have := lookup_all_length_le_one a h, revert this,
  rcases lookup_all a l with _|⟨b, _|⟨c, l⟩⟩; intro; try {refl},
  exact absurd this dec_trivial
end

theorem lookup_all_nodup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  (lookup_all a l).nodup :=
by rw lookup_all_eq_lookup a h; apply option.to_list_nodup

theorem perm_lookup_all (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup_all a l₁ = lookup_all a l₂ :=
by simp [lookup_all_eq_lookup, nd₁, nd₂, perm_lookup a nd₁ nd₂ p]

/-! ### `kreplace` -/

/-- Replaces the first value with key `a` by `b`. -/
def kreplace (a : α) (b : β a) : list (sigma β) → list (sigma β) :=
lookmap $ λ s, if a = s.1 then some ⟨a, b⟩ else none

theorem kreplace_of_forall_not (a : α) (b : β a) {l : list (sigma β)}
  (H : ∀ b : β a, sigma.mk a b ∉ l) : kreplace a b l = l :=
lookmap_of_forall_not _ $ begin
  rintro ⟨a', b'⟩ h, dsimp, split_ifs,
  { subst a', exact H _ h }, {refl}
end

theorem kreplace_self {a : α} {b : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : kreplace a b l = l :=
begin
  refine (lookmap_congr _).trans
    (lookmap_id' (option.guard (λ s, a = s.1)) _ _),
  { rintro ⟨a', b'⟩ h', dsimp [option.guard], split_ifs,
    { subst a', exact ⟨rfl, heq_of_eq $ nd.eq_of_mk_mem h h'⟩ },
    { refl } },
  { rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩, dsimp [option.guard], split_ifs,
    { subst a₁, rintro ⟨⟩, simp }, { rintro ⟨⟩ } },
end

theorem keys_kreplace (a : α) (b : β a) : ∀ l : list (sigma β),
  (kreplace a b l).keys = l.keys :=
lookmap_map_eq _ _ $ by rintro ⟨a₁, b₂⟩ ⟨a₂, b₂⟩;
  dsimp; split_ifs; simp [h] {contextual := tt}

theorem kreplace_nodupkeys (a : α) (b : β a) {l : list (sigma β)} :
  (kreplace a b l).nodupkeys ↔ l.nodupkeys :=
by simp [nodupkeys, keys_kreplace]

theorem perm.kreplace {a : α} {b : β a} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ →
  kreplace a b l₁ ~ kreplace a b l₂ :=
perm_lookmap _ $ begin
  refine nd.pairwise_ne.imp _,
  intros x y h z h₁ w h₂,
  split_ifs at h₁ h₂; cases h₁; cases h₂,
  exact (h (h_2.symm.trans h_1)).elim
end

/-! ### `kerase` -/

/-- Remove the first pair with the key `a`. -/
def kerase (a : α) : list (sigma β) → list (sigma β) :=
erasep $ λ s, a = s.1

@[simp] theorem kerase_nil {a} : @kerase _ β _ a [] = [] :=
rfl

@[simp, priority 990]
theorem kerase_cons_eq {a} {s : sigma β} {l : list (sigma β)} (h : a = s.1) :
  kerase a (s :: l) = l :=
by simp [kerase, h]

@[simp, priority 990]
theorem kerase_cons_ne {a} {s : sigma β} {l : list (sigma β)} (h : a ≠ s.1) :
  kerase a (s :: l) = s :: kerase a l :=
by simp [kerase, h]

@[simp, priority 980]
theorem kerase_of_not_mem_keys {a} {l : list (sigma β)} (h : a ∉ l.keys) :
  kerase a l = l :=
by induction l with _ _ ih;
   [refl, { simp [not_or_distrib] at h, simp [h.1, ih h.2] }]

theorem kerase_sublist (a : α) (l : list (sigma β)) : kerase a l <+ l :=
erasep_sublist _

theorem kerase_keys_subset (a) (l : list (sigma β)) :
  (kerase a l).keys ⊆ l.keys :=
((kerase_sublist a l).map _).subset

theorem mem_keys_of_mem_keys_kerase {a₁ a₂} {l : list (sigma β)} :
  a₁ ∈ (kerase a₂ l).keys → a₁ ∈ l.keys :=
@kerase_keys_subset _ _ _ _ _ _

theorem exists_of_kerase {a : α} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a) (l₁ l₂ : list (sigma β)),
    a ∉ l₁.keys ∧
    l = l₁ ++ ⟨a, b⟩ :: l₂ ∧
    kerase a l = l₁ ++ l₂ :=
begin
  induction l,
  case list.nil { cases h },
  case list.cons : hd tl ih
  { by_cases e : a = hd.1,
    { subst e,
      exact ⟨hd.2, [], tl, by simp, by cases hd; refl, by simp⟩ },
    { simp at h,
      cases h,
      case or.inl : h { exact absurd h e },
      case or.inr : h
      { rcases ih h with ⟨b, tl₁, tl₂, h₁, h₂, h₃⟩,
        exact ⟨b, hd :: tl₁, tl₂, not_mem_cons_of_ne_of_not_mem e h₁,
               by rw h₂; refl, by simp [e, h₃]⟩ } } }
end

@[simp, priority 990]
theorem mem_keys_kerase_of_ne {a₁ a₂} {l : list (sigma β)} (h : a₁ ≠ a₂) :
  a₁ ∈ (kerase a₂ l).keys ↔ a₁ ∈ l.keys :=
iff.intro mem_keys_of_mem_keys_kerase $ λ p,
  if q : a₂ ∈ l.keys then
    match l, kerase a₂ l, exists_of_kerase q, p with
    | _, _, ⟨_, _, _, _, rfl, rfl⟩, p := by simpa [keys, h] using p
    end
  else
    by simp [q, p]

theorem keys_kerase {a} {l : list (sigma β)} : (kerase a l).keys = l.keys.erase a :=
by rw [keys, kerase, ←erasep_map sigma.fst l, erase_eq_erasep]

theorem kerase_kerase {a a'} {l : list (sigma β)} :
  (kerase a' l).kerase a = (kerase a l).kerase a' :=
begin
  by_cases a = a',
  { subst a' },
  induction l with x xs, { refl },
  { by_cases a' = x.1,
    { subst a', simp [kerase_cons_ne h,kerase_cons_eq rfl] },
    by_cases h' : a = x.1,
    { subst a, simp [kerase_cons_eq rfl,kerase_cons_ne (ne.symm h)] },
    { simp [kerase_cons_ne,*] } }
end

theorem kerase_nodupkeys (a : α) {l : list (sigma β)} : nodupkeys l → (kerase a l).nodupkeys :=
nodupkeys_of_sublist $ kerase_sublist _ _

theorem perm.kerase {a : α} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ → kerase a l₁ ~ kerase a l₂ :=
perm.erasep _ $ (nodupkeys_iff_pairwise.1 nd).imp $
by rintro x y h rfl; exact h

@[simp] theorem not_mem_keys_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  a ∉ (kerase a l).keys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih
  { simp at nd,
    by_cases h : a = hd.1,
    { subst h, simp [nd.1] },
    { simp [h, ih nd.2] } }
end

@[simp] theorem lookup_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  lookup a (kerase a l) = none :=
lookup_eq_none.mpr (not_mem_keys_kerase a nd)

@[simp] theorem lookup_kerase_ne {a a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kerase a' l) = lookup a l :=
begin
  induction l,
  case list.nil { refl },
  case list.cons : hd tl ih
  { cases hd with ah bh,
    by_cases h₁ : a = ah; by_cases h₂ : a' = ah,
    { substs h₁ h₂, cases ne.irrefl h },
    { subst h₁, simp [h₂] },
    { subst h₂, simp [h] },
    { simp [h₁, h₂, ih] } }
end

theorem kerase_append_left {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∈ l₁.keys → kerase a (l₁ ++ l₂) = kerase a l₁ ++ l₂
| []        _  h  := by cases h
| (s :: l₁) l₂ h₁ :=
  if h₂ : a = s.1 then
    by simp [h₂]
  else
    by simp at h₁;
       cases h₁;
       [exact absurd h₁ h₂, simp [h₂, kerase_append_left h₁]]

theorem kerase_append_right {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∉ l₁.keys → kerase a (l₁ ++ l₂) = l₁ ++ kerase a l₂
| []        _  h := rfl
| (_ :: l₁) l₂ h := by simp [not_or_distrib] at h;
                       simp [h.1, kerase_append_right h.2]

theorem kerase_comm (a₁ a₂) (l : list (sigma β)) :
  kerase a₂ (kerase a₁ l) = kerase a₁ (kerase a₂ l) :=
if h : a₁ = a₂ then
  by simp [h]
else if ha₁ : a₁ ∈ l.keys then
  if ha₂ : a₂ ∈ l.keys then
    match l, kerase a₁ l, exists_of_kerase ha₁, ha₂ with
    | _, _, ⟨b₁, l₁, l₂, a₁_nin_l₁, rfl, rfl⟩, a₂_in_l₁_app_l₂ :=
      if h' : a₂ ∈ l₁.keys then
        by simp [kerase_append_left h',
                 kerase_append_right (mt (mem_keys_kerase_of_ne h).mp a₁_nin_l₁)]
      else
        by simp [kerase_append_right h', kerase_append_right a₁_nin_l₁,
                 @kerase_cons_ne _ _ _ a₂ ⟨a₁, b₁⟩ _ (ne.symm h)]
    end
  else
    by simp [ha₂, mt mem_keys_of_mem_keys_kerase ha₂]
else
  by simp [ha₁, mt mem_keys_of_mem_keys_kerase ha₁]

lemma sizeof_kerase {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)] (x : α)
  (xs : list (sigma β)) :
  sizeof (list.kerase x xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with y ys,
  { simp },
  { by_cases x = y.1; simp [*, list.sizeof] },
end

/-! ### `kinsert` -/

/-- Insert the pair `⟨a, b⟩` and erase the first pair with the key `a`. -/
def kinsert (a : α) (b : β a) (l : list (sigma β)) : list (sigma β) :=
⟨a, b⟩ :: kerase a l

@[simp] theorem kinsert_def {a} {b : β a} {l : list (sigma β)} :
  kinsert a b l = ⟨a, b⟩ :: kerase a l := rfl

theorem mem_keys_kinsert {a a'} {b' : β a'} {l : list (sigma β)} :
  a ∈ (kinsert a' b' l).keys ↔ a = a' ∨ a ∈ l.keys :=
by by_cases h : a = a'; simp [h]

theorem kinsert_nodupkeys (a) (b : β a) {l : list (sigma β)} (nd : l.nodupkeys) :
  (kinsert a b l).nodupkeys :=
nodupkeys_cons.mpr ⟨not_mem_keys_kerase a nd, kerase_nodupkeys a nd⟩

theorem perm.kinsert {a} {b : β a} {l₁ l₂ : list (sigma β)} (nd₁ : l₁.nodupkeys)
  (p : l₁ ~ l₂) : kinsert a b l₁ ~ kinsert a b l₂ :=
(p.kerase nd₁).cons _

theorem lookup_kinsert {a} {b : β a} (l : list (sigma β)) :
  lookup a (kinsert a b l) = some b :=
by simp only [kinsert, lookup_cons_eq]

theorem lookup_kinsert_ne {a a'} {b' : β a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kinsert a' b' l) = lookup a l :=
by simp [h]

/-! ### `kextract` -/

/-- Finds the first entry with a given key `a` and returns its value (as an `option` because there
might be no entry with key `a`) alongside with the rest of the entries. -/
def kextract (a : α) : list (sigma β) → option (β a) × list (sigma β)
| []     := (none, [])
| (s::l) := if h : s.1 = a then (some (eq.rec_on h s.2), l) else
  let (b', l') := kextract l in (b', s :: l')

@[simp] theorem kextract_eq_lookup_kerase (a : α) :
  ∀ l : list (sigma β), kextract a l = (lookup a l, kerase a l)
| []     := rfl
| (⟨a', b⟩::l) := begin
    simp [kextract], dsimp, split_ifs,
    { subst a', simp [kerase] },
    { simp [kextract, ne.symm h, kextract_eq_lookup_kerase l, kerase] }
  end

/-! ### `erase_dupkeys` -/

/-- Remove entries with duplicate keys from `l : list (sigma β)`. -/
def erase_dupkeys : list (sigma β) → list (sigma β) :=
list.foldr (λ x, kinsert x.1 x.2) []

lemma erase_dupkeys_cons {x : sigma β} (l : list (sigma β)) :
  erase_dupkeys (x :: l) = kinsert x.1 x.2 (erase_dupkeys l) := rfl

lemma nodupkeys_erase_dupkeys (l : list (sigma β)) : nodupkeys (erase_dupkeys l) :=
begin
  dsimp [erase_dupkeys], generalize hl : nil = l',
  have : nodupkeys l', { rw ← hl, apply nodup_nil },
  clear hl,
  induction l with x xs,
  { apply this },
  { cases x, simp [erase_dupkeys], split,
    { simp [keys_kerase], apply mem_erase_of_nodup l_ih },
    apply kerase_nodupkeys _ l_ih, }
end

lemma lookup_erase_dupkeys (a : α) (l : list (sigma β)) : lookup a (erase_dupkeys l) = lookup a l :=
begin
  induction l, refl,
  cases l_hd with a' b,
  by_cases a = a',
  { subst a', rw [erase_dupkeys_cons,lookup_kinsert,lookup_cons_eq] },
  { rw [erase_dupkeys_cons,lookup_kinsert_ne h,l_ih,lookup_cons_ne], exact h },
end

lemma sizeof_erase_dupkeys {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)]
  (xs : list (sigma β)) :
  sizeof (list.erase_dupkeys xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with x xs,
  { simp [list.erase_dupkeys] },
  { simp only [erase_dupkeys_cons, list.sizeof, kinsert_def, add_le_add_iff_left, sigma.eta],
    transitivity, apply sizeof_kerase,
    assumption }
end

/-! ### `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 : list (sigma β) → list (sigma β) → list (sigma β)
| []        l₂ := l₂
| (s :: l₁) l₂ := s :: kunion l₁ (kerase s.1 l₂)

@[simp] theorem nil_kunion {l : list (sigma β)} : kunion [] l = l :=
rfl

@[simp] theorem kunion_nil : ∀ {l : list (sigma β)}, kunion l [] = l
| []       := rfl
| (_ :: l) := by rw [kunion, kerase_nil, kunion_nil]

@[simp] theorem kunion_cons {s} {l₁ l₂ : list (sigma β)} :
  kunion (s :: l₁) l₂ = s :: kunion l₁ (kerase s.1 l₂) :=
rfl

@[simp] theorem mem_keys_kunion {a} {l₁ l₂ : list (sigma β)} :
  a ∈ (kunion l₁ l₂).keys ↔ a ∈ l₁.keys ∨ a ∈ l₂.keys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s l₁ ih { by_cases h : a = s.1; [simp [h], simp [h, ih]] }
end

@[simp] theorem kunion_kerase {a} : ∀ {l₁ l₂ : list (sigma β)},
  kunion (kerase a l₁) (kerase a l₂) = kerase a (kunion l₁ l₂)
| []       _ := rfl
| (s :: _) l := by by_cases h : a = s.1;
                   simp [h, kerase_comm a s.1 l, kunion_kerase]

theorem kunion_nodupkeys {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) : (kunion l₁ l₂).nodupkeys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp only [nil_kunion, nd₂] },
  case list.cons : s l₁ ih
  { simp at nd₁,
    simp [not_or_distrib, nd₁.1, nd₂, ih nd₁.2 (kerase_nodupkeys s.1 nd₂)] }
end

theorem perm.kunion_right {l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (l) :
  kunion l₁ l ~ kunion l₂ l :=
begin
  induction p generalizing l,
  case list.perm.nil { refl },
  case list.perm.cons : hd tl₁ tl₂ p ih
  { simp [ih (kerase hd.1 l), perm.cons] },
  case list.perm.swap : s₁ s₂ l
  { simp [kerase_comm, perm.swap] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃
  { exact perm.trans (ih₁₂ l) (ih₂₃ l) }
end

theorem perm.kunion_left : ∀ l {l₁ l₂ : list (sigma β)},
  l₁.nodupkeys → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂
| []       _  _  _   p := p
| (s :: l) l₁ l₂ nd₁ p :=
  by simp [((p.kerase nd₁).kunion_left l (kerase_nodupkeys s.1 nd₁)).cons s]

theorem perm.kunion {l₁ l₂ l₃ l₄ : list (sigma β)} (nd₃ : l₃.nodupkeys)
  (p₁₂ : l₁ ~ l₂) (p₃₄ : l₃ ~ l₄) : kunion l₁ l₃ ~ kunion l₂ l₄ :=
(p₁₂.kunion_right l₃).trans (p₃₄.kunion_left l₂ nd₃)

@[simp] theorem lookup_kunion_left {a} {l₁ l₂ : list (sigma β)} (h : a ∈ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₁ :=
begin
  induction l₁ with s _ ih generalizing l₂; simp at h; cases h; cases s with a',
  { subst h, simp },
  { rw kunion_cons,
    by_cases h' : a = a',
    { subst h', simp },
    { simp [h', ih h] } }
end

@[simp] theorem lookup_kunion_right {a} {l₁ l₂ : list (sigma β)} (h : a ∉ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : _ _ ih { simp [not_or_distrib] at h, simp [h.1, ih h.2] }
end

@[simp] theorem mem_lookup_kunion {a} {b : β a} {l₁ l₂ : list (sigma β)} :
  b ∈ lookup a (kunion l₁ l₂) ↔ b ∈ lookup a l₁ ∨ a ∉ l₁.keys ∧ b ∈ lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s _ ih
  { cases s with a',
    by_cases h₁ : a = a',
    { subst h₁, simp },
    { let h₂ := @ih (kerase a' l₂), simp [h₁] at h₂, simp [h₁, h₂] } }
end

theorem mem_lookup_kunion_middle {a} {b : β a} {l₁ l₂ l₃ : list (sigma β)}
  (h₁ : b ∈ lookup a (kunion l₁ l₃)) (h₂ : a ∉ keys l₂) :
  b ∈ lookup a (kunion (kunion l₁ l₂) l₃) :=
match mem_lookup_kunion.mp h₁ with
| or.inl h := mem_lookup_kunion.mpr (or.inl (mem_lookup_kunion.mpr (or.inl h)))
| or.inr h := mem_lookup_kunion.mpr $
  or.inr ⟨mt mem_keys_kunion.mp (not_or_distrib.mpr ⟨h.1, h₂⟩), h.2⟩
end

end list