/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Subtraction elimination for linear natural number arithmetic.
Works by repeatedly rewriting goals of the preform `P[t-s]` into
`P[x] ∧ (t = s + x ∨ (t ≤ s ∧ x = 0))`, where `x` is fresh.
-/

import tactic.omega.nat.form

namespace omega
namespace nat

open_locale omega.nat

namespace preterm

/-- Find subtraction inside preterm and return its operands -/
def sub_terms : preterm → option (preterm × preterm)
| (& i)      := none
| (i ** n)   := none
| (t +* s) := t.sub_terms <|> s.sub_terms
| (t -* s) := t.sub_terms <|> s.sub_terms <|> some (t,s)

/-- Find (t - s) inside a preterm and replace it with variable k -/
def sub_subst (t s : preterm) (k : nat) : preterm → preterm
| t@(& m)    := t
| t@(m ** n) := t
| (x +* y) := x.sub_subst +* y.sub_subst
| (x -* y) :=
  if x = t ∧ y = s then (1 ** k)
  else x.sub_subst -* y.sub_subst

lemma val_sub_subst {k : nat} {x y : preterm} {v : nat → nat} :
  ∀ {t : preterm}, t.fresh_index ≤ k →
  (sub_subst x y k t).val (update k (x.val v - y.val v) v) = t.val v
| (& m)    h1 := rfl
| (m ** n) h1 :=
  begin
    have h2 : n ≠ k := ne_of_lt h1,
    simp only [sub_subst, preterm.val],
    rw update_eq_of_ne _ h2,
 end
| (t +* s) h1 :=
  begin
    simp only [sub_subst, val_add], apply fun_mono_2;
    apply val_sub_subst (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (t -* s) h1 :=
  begin
    simp only [sub_subst, val_sub],
    by_cases h2 : t = x ∧ s = y,
    { rw if_pos h2, simp only [val_var, one_mul],
      rw [update_eq, h2.left, h2.right] },
    { rw if_neg h2,
      simp only [val_sub, sub_subst],
      apply fun_mono_2;
      apply val_sub_subst (le_trans _ h1),
      apply le_max_left, apply le_max_right, }
  end

end preterm

namespace preform

/-- Find subtraction inside preform and return its operands -/
def sub_terms : preform → option (preterm × preterm)
| (t =* s) := t.sub_terms <|> s.sub_terms
| (t ≤* s) := t.sub_terms <|> s.sub_terms
| (¬* p)   := p.sub_terms
| (p ∨* q) := p.sub_terms <|> q.sub_terms
| (p ∧* q) := p.sub_terms <|> q.sub_terms

/-- Find (t - s) inside a preform and replace it with variable k -/
@[simp] def sub_subst (x y : preterm) (k : nat) : preform → preform
| (t =* s) := preterm.sub_subst x y k t =* preterm.sub_subst x y k s
| (t ≤* s) := preterm.sub_subst x y k t ≤* preterm.sub_subst x y k s
| (¬* p)   := ¬* p.sub_subst
| (p ∨* q) := p.sub_subst ∨* q.sub_subst
| (p ∧* q) := p.sub_subst ∧* q.sub_subst

end preform

/-- Preform which asserts that the value of variable k is
    the truncated difference between preterms t and s -/
def is_diff (t s : preterm) (k : nat) : preform :=
((t =* (s +* (1 ** k))) ∨* (t ≤* s ∧* ((1 ** k) =* &0)))

lemma holds_is_diff {t s : preterm} {k : nat} {v : nat → nat} :
  v k = t.val v - s.val v → (is_diff t s k).holds v :=
begin
  intro h1,
  simp only [preform.holds, is_diff, if_pos (eq.refl 1),
    preterm.val_add, preterm.val_var, preterm.val_const],
  cases le_total (t.val v) (s.val v) with h2 h2,
  { right, refine ⟨h2, _⟩,
    rw [h1, one_mul, tsub_eq_zero_iff_le], exact h2 },
  { left, rw [h1, one_mul, add_comm, tsub_add_cancel_of_le h2] }
end

/-- Helper function for sub_elim -/
def sub_elim_core (t s : preterm) (k : nat) (p : preform) : preform :=
(preform.sub_subst t s k p) ∧* (is_diff t s k)

/-- Return de Brujin index of fresh variable that does not occur
    in any of the arguments -/
def sub_fresh_index (t s : preterm) (p : preform) : nat :=
max p.fresh_index (max t.fresh_index s.fresh_index)

/-- Return a new preform with all subtractions eliminated -/
def sub_elim (t s : preterm) (p : preform) : preform :=
sub_elim_core t s (sub_fresh_index t s p) p

lemma sub_subst_equiv {k : nat} {x y : preterm} {v : nat → nat} :
  ∀ p : preform, p.fresh_index ≤ k → ((preform.sub_subst x y k p).holds
    (update k (x.val v - y.val v) v) ↔ (p.holds v))
| (t =* s) h1 :=
  begin
    simp only [preform.holds, preform.sub_subst],
    apply pred_mono_2;
    apply preterm.val_sub_subst (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (t ≤* s) h1 :=
  begin
    simp only [preform.holds, preform.sub_subst],
    apply pred_mono_2;
    apply preterm.val_sub_subst (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (¬* p) h1 :=
  by { apply not_iff_not_of_iff, apply sub_subst_equiv p h1 }
| (p ∨* q) h1 :=
  begin
    simp only [preform.holds, preform.sub_subst],
    apply pred_mono_2; apply propext;
    apply sub_subst_equiv _ (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (p ∧* q) h1 :=
  begin
    simp only [preform.holds, preform.sub_subst],
    apply pred_mono_2; apply propext;
    apply sub_subst_equiv _ (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end

lemma sat_sub_elim {t s : preterm} {p : preform} :
  p.sat → (sub_elim t s p).sat :=
begin
  intro h1, simp only [sub_elim, sub_elim_core],
  cases h1 with v h1,
  refine ⟨update (sub_fresh_index t s p) (t.val v - s.val v) v, _⟩,
  constructor,
  { apply (sub_subst_equiv p _).elim_right h1,
    apply le_max_left },
  { apply holds_is_diff, rw update_eq,
    apply fun_mono_2;
    apply preterm.val_constant; intros x h2;
    rw update_eq_of_ne _ (ne.symm (ne_of_gt _));
    apply lt_of_lt_of_le h2;
    apply le_trans _ (le_max_right _ _),
    apply le_max_left, apply le_max_right }
end

lemma unsat_of_unsat_sub_elim (t s : preterm) (p : preform) :
  (sub_elim t s p).unsat → p.unsat := mt sat_sub_elim

end nat

end omega


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import measure_theory.constructions.borel_space

/-!
# Measurability criterion for ennreal-valued functions

Consider a function `f : α → ℝ≥0∞`. If the level sets `{f < p}` and `{q < f}` have measurable
supersets which are disjoint up to measure zero when `p` and `q` are finite numbers satisfying
`p < q`, then `f` is almost-everywhere measurable. This is proved in
`ennreal.ae_measurable_of_exist_almost_disjoint_supersets`, and deduced from an analogous statement
for any target space which is a complete linear dense order, called
`measure_theory.ae_measurable_of_exist_almost_disjoint_supersets`.

Note that it should be enough to assume that the space is a conditionally complete linear order,
but the proof would be more painful. Since our only use for now is for `ℝ≥0∞`, we keep it as simple
as possible.
-/

open measure_theory set topological_space
open_locale classical ennreal nnreal

/-- If a function `f : α → β` is such that the level sets `{f < p}` and `{q < f}` have measurable
supersets which are disjoint up to measure zero when `p < q`, then `f` is almost-everywhere
measurable. It is even enough to have this for `p` and `q` in a countable dense set. -/
theorem measure_theory.ae_measurable_of_exist_almost_disjoint_supersets
  {α : Type*} {m : measurable_space α} (μ : measure α)
  {β : Type*} [complete_linear_order β] [densely_ordered β] [topological_space β]
  [order_topology β] [second_countable_topology β] [measurable_space β] [borel_space β]
  (s : set β) (s_count : countable s) (s_dense : dense s) (f : α → β)
  (h : ∀ (p ∈ s) (q ∈ s), p < q → ∃ u v, measurable_set u ∧ measurable_set v ∧
    {x | f x < p} ⊆ u ∧ {x | q < f x} ⊆ v ∧ μ (u ∩ v) = 0) :
  ae_measurable f μ :=
begin
  haveI : encodable s := s_count.to_encodable,
  have h' : ∀ p q, ∃ u v, measurable_set u ∧ measurable_set v ∧
    {x | f x < p} ⊆ u ∧ {x | q < f x} ⊆ v ∧ (p ∈ s → q ∈ s → p < q → μ (u ∩ v) = 0),
  { assume p q,
    by_cases H : p ∈ s ∧ q ∈ s ∧ p < q,
    { rcases h p H.1 q H.2.1 H.2.2 with ⟨u, v, hu, hv, h'u, h'v, hμ⟩,
      exact ⟨u, v, hu, hv, h'u, h'v, λ ps qs pq, hμ⟩ },
    { refine ⟨univ, univ, measurable_set.univ, measurable_set.univ, subset_univ _, subset_univ _,
        λ ps qs pq, _⟩,
      simp only [not_and] at H,
      exact (H ps qs pq).elim } },
  choose! u v huv using h',
  let u' : β → set α := λ p, ⋂ (q ∈ s ∩ Ioi p), u p q,
  have u'_meas : ∀ i, measurable_set (u' i),
  { assume i,
    exact measurable_set.bInter (s_count.mono (inter_subset_left _ _)) (λ b hb, (huv i b).1) },
  let f' : α → β := λ x, ⨅ (i : s), piecewise (u' i) (λ x, (i : β)) (λ x, (⊤ : β)) x,
  have f'_meas : measurable f',
  { apply measurable_infi,
    exact λ i, measurable.piecewise (u'_meas i) measurable_const measurable_const },
  let t := ⋃ (p : s) (q : s ∩ Ioi p), u' p ∩ v p q,
  have μt : μ t ≤ 0 := calc
    μ t ≤ ∑' (p : s) (q : s ∩ Ioi p), μ (u' p ∩ v p q) : begin
      refine (measure_Union_le _).trans _,
      apply ennreal.tsum_le_tsum (λ p, _),
      apply measure_Union_le _,
      exact (s_count.mono (inter_subset_left _ _)).to_encodable,
    end
    ... ≤ ∑' (p : s) (q : s ∩ Ioi p), μ (u p q ∩ v p q) : begin
      apply ennreal.tsum_le_tsum (λ p, _),
      refine ennreal.tsum_le_tsum (λ q, measure_mono _),
      exact inter_subset_inter_left _ (bInter_subset_of_mem q.2)
    end
    ... = ∑' (p : s) (q : s ∩ Ioi p), (0 : ℝ≥0∞) :
      by { congr, ext1 p, congr, ext1 q, exact (huv p q).2.2.2.2 p.2 q.2.1 q.2.2 }
    ... = 0 : by simp only [tsum_zero],
  have ff' : ∀ᵐ x ∂μ, f x = f' x,
  { have : ∀ᵐ x ∂μ, x ∉ t,
    { have : μ t = 0 := le_antisymm μt bot_le,
      change μ _ = 0,
      convert this,
      ext y,
      simp only [not_exists, exists_prop, mem_set_of_eq, mem_compl_eq, not_not_mem] },
    filter_upwards [this],
    assume x hx,
    apply (infi_eq_of_forall_ge_of_forall_gt_exists_lt _ _).symm,
    { assume i,
      by_cases H : x ∈ u' i,
      swap, { simp only [H, le_top, not_false_iff, piecewise_eq_of_not_mem] },
      simp only [H, piecewise_eq_of_mem],
      contrapose! hx,
      obtain ⟨r, ⟨xr, rq⟩, rs⟩ : ∃ r, r ∈ Ioo (i : β) (f x) ∩ s :=
        dense_iff_inter_open.1 s_dense (Ioo i (f x)) is_open_Ioo (nonempty_Ioo.2 hx),
      have A : x ∈ v i r := (huv i r).2.2.2.1 rq,
      apply mem_Union.2 ⟨i, _⟩,
      refine mem_Union.2 ⟨⟨r, ⟨rs, xr⟩⟩, _⟩,
      exact ⟨H, A⟩ },
    { assume q hq,
      obtain ⟨r, ⟨xr, rq⟩, rs⟩ : ∃ r, r ∈ Ioo (f x) q ∩ s :=
        dense_iff_inter_open.1 s_dense (Ioo (f x) q) is_open_Ioo (nonempty_Ioo.2 hq),
      refine ⟨⟨r, rs⟩, _⟩,
      have A : x ∈ u' r := mem_bInter (λ i hi, (huv r i).2.2.1 xr),
      simp only [A, rq, piecewise_eq_of_mem, subtype.coe_mk] } },
  exact ⟨f', f'_meas, ff'⟩,
end

/-- If a function `f : α → ℝ≥0∞` is such that the level sets `{f < p}` and `{q < f}` have measurable
supersets which are disjoint up to measure zero when `p` and `q` are finite numbers satisfying
`p < q`, then `f` is almost-everywhere measurable. -/
theorem ennreal.ae_measurable_of_exist_almost_disjoint_supersets
  {α : Type*} {m : measurable_space α} (μ : measure α) (f : α → ℝ≥0∞)
  (h : ∀ (p : ℝ≥0) (q : ℝ≥0), p < q → ∃ u v, measurable_set u ∧ measurable_set v ∧
    {x | f x < p} ⊆ u ∧ {x | (q : ℝ≥0∞) < f x} ⊆ v ∧ μ (u ∩ v) = 0) :
  ae_measurable f μ :=
begin
  obtain ⟨s, s_count, s_dense, s_zero, s_top⟩ : ∃ s : set ℝ≥0∞, countable s ∧ dense s ∧
    0 ∉ s ∧ ∞ ∉ s := ennreal.exists_countable_dense_no_zero_top,
  have I : ∀ x ∈ s, x ≠ ∞ := λ x xs hx, s_top (hx ▸ xs),
  apply measure_theory.ae_measurable_of_exist_almost_disjoint_supersets μ s s_count s_dense _,
  rintros p hp q hq hpq,
  lift p to ℝ≥0 using I p hp,
  lift q to ℝ≥0 using I q hq,
  exact h p q (ennreal.coe_lt_coe.1 hpq),
end


/-
Copyright (c) 2019 Jean Lo. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jean Lo, Bhavik Mehta, Yaël Dillies
-/
import analysis.normed_space.basic

/-!
# Local convexity

This file defines absorbent and balanced sets.

An absorbent set is one that "surrounds" the origin. The idea is made precise by requiring that any
point belongs to all large enough scalings of the set. This is the vector world analog of a
topological neighborhood of the origin.

A balanced set is one that is everywhere around the origin. This means that `a • s ⊆ s` for all `a`
of norm less than `1`.

## Main declarations

For a module over a normed ring:
* `absorbs`: A set `s` absorbs a set `t` if all large scalings of `s` contain `t`.
* `absorbent`: A set `s` is absorbent if every point eventually belongs to all large scalings of
  `s`.
* `balanced`: A set `s` is balanced if `a • s ⊆ s` for all `a` of norm less than `1`.

## References

* [H. H. Schaefer, *Topological Vector Spaces*][schaefer1966]

## Tags

absorbent, balanced, locally convex, LCTVS
-/

open set
open_locale pointwise topological_space

variables {𝕜 𝕝 E ι : Type*}

section semi_normed_ring
variables [semi_normed_ring 𝕜]

section has_scalar
variables (𝕜) [has_scalar 𝕜 E]

/-- A set `A` absorbs another set `B` if `B` is contained in all scalings of `A` by elements of
sufficiently large norm. -/
def absorbs (A B : set E) := ∃ r, 0 < r ∧ ∀ a : 𝕜, r ≤ ∥a∥ → B ⊆ a • A

variables {𝕜} {s t u v A B : set E}

@[simp] lemma absorbs_empty {s : set E}: absorbs 𝕜 s (∅ : set E) :=
⟨1, one_pos, λ a ha, set.empty_subset _⟩

lemma absorbs.mono (hs : absorbs 𝕜 s u) (hst : s ⊆ t) (hvu : v ⊆ u) : absorbs 𝕜 t v :=
let ⟨r, hr, h⟩ := hs in ⟨r, hr, λ a ha, hvu.trans $ (h _ ha).trans $ smul_set_mono hst⟩

lemma absorbs.mono_left (hs : absorbs 𝕜 s u) (h : s ⊆ t) : absorbs 𝕜 t u := hs.mono h subset.rfl
lemma absorbs.mono_right (hs : absorbs 𝕜 s u) (h : v ⊆ u) : absorbs 𝕜 s v := hs.mono subset.rfl h

lemma absorbs.union (hu : absorbs 𝕜 s u) (hv : absorbs 𝕜 s v) : absorbs 𝕜 s (u ∪ v) :=
begin
  obtain ⟨a, ha, hu⟩ := hu,
  obtain ⟨b, hb, hv⟩ := hv,
  exact ⟨max a b, lt_max_of_lt_left ha,
    λ c hc, union_subset (hu _ $ le_of_max_le_left hc) (hv _ $ le_of_max_le_right hc)⟩,
end

@[simp] lemma absorbs_union : absorbs 𝕜 s (u ∪ v) ↔ absorbs 𝕜 s u ∧ absorbs 𝕜 s v :=
⟨λ h, ⟨h.mono_right $ subset_union_left _ _, h.mono_right $ subset_union_right _ _⟩,
  λ h, h.1.union h.2⟩

lemma absorbs_Union_finset {s : set E} {t : finset ι} {f : ι → set E} :
  absorbs 𝕜 s (⋃ (i ∈ t), f i) ↔ ∀ i ∈ t, absorbs 𝕜 s (f i) :=
begin
  classical,
  induction t using finset.induction_on with i t ht hi,
  { simp only [finset.not_mem_empty, set.Union_false, set.Union_empty, absorbs_empty,
    forall_false_left, implies_true_iff] },
  rw [finset.set_bUnion_insert, absorbs_union, hi],
  split; intro h,
  { refine λ _ hi', (finset.mem_insert.mp hi').elim _ (h.2 _),
    exact (λ hi'', by { rw hi'', exact h.1 }) },
  exact ⟨h i (finset.mem_insert_self i t), λ i' hi', h i' (finset.mem_insert_of_mem hi')⟩,
end

lemma set.finite.absorbs_Union {s : set E} {t : set ι} {f : ι → set E} (hi : t.finite) :
  absorbs 𝕜 s (⋃ (i : ι) (hy : i ∈ t), f i) ↔ ∀ i ∈ t, absorbs 𝕜 s (f i) :=
begin
  lift t to finset ι using hi,
  simp only [finset.mem_coe],
  exact absorbs_Union_finset,
end

variables (𝕜)

/-- A set is absorbent if it absorbs every singleton. -/
def absorbent (A : set E) := ∀ x, ∃ r, 0 < r ∧ ∀ a : 𝕜, r ≤ ∥a∥ → x ∈ a • A

variables {𝕜}

lemma absorbent.subset (hA : absorbent 𝕜 A) (hAB : A ⊆ B) : absorbent 𝕜 B :=
begin
  refine forall_imp (λ x, _) hA,
  exact Exists.imp (λ r, and.imp_right $ forall₂_imp $ λ a ha hx, set.smul_set_mono hAB hx),
end

lemma absorbent_iff_forall_absorbs_singleton : absorbent 𝕜 A ↔ ∀ x, absorbs 𝕜 A {x} :=
by simp_rw [absorbs, absorbent, singleton_subset_iff]

lemma absorbent.absorbs (hs : absorbent 𝕜 s) {x : E} : absorbs 𝕜 s {x} :=
absorbent_iff_forall_absorbs_singleton.1 hs _

lemma absorbent_iff_nonneg_lt : absorbent 𝕜 A ↔ ∀ x, ∃ r, 0 ≤ r ∧ ∀ ⦃a : 𝕜⦄, r < ∥a∥ → x ∈ a • A :=
forall_congr $ λ x, ⟨λ ⟨r, hr, hx⟩, ⟨r, hr.le, λ a ha, hx a ha.le⟩, λ ⟨r, hr, hx⟩,
  ⟨r + 1, add_pos_of_nonneg_of_pos hr zero_lt_one,
    λ a ha, hx ((lt_add_of_pos_right r zero_lt_one).trans_le ha)⟩⟩

lemma absorbent.absorbs_finite {s : set E} (hs : absorbent 𝕜 s) {v : set E} (hv : v.finite) :
  absorbs 𝕜 s v :=
begin
  rw ←set.bUnion_of_singleton v,
  exact hv.absorbs_Union.mpr (λ _ _, hs.absorbs),
end

variables (𝕜)

/-- A set `A` is balanced if `a • A` is contained in `A` whenever `a` has norm at most `1`. -/
def balanced (A : set E) := ∀ a : 𝕜, ∥a∥ ≤ 1 → a • A ⊆ A

variables {𝕜}

lemma balanced_mem {s : set E} (hs : balanced 𝕜 s) {x : E} (hx : x ∈ s) {a : 𝕜} (ha : ∥a∥ ≤ 1) :
  a • x ∈ s :=
mem_of_subset_of_mem (hs a ha) (smul_mem_smul_set hx)

lemma balanced_univ : balanced 𝕜 (univ : set E) := λ a ha, subset_univ _

lemma balanced.union (hA : balanced 𝕜 A) (hB : balanced 𝕜 B) : balanced 𝕜 (A ∪ B) :=
begin
  intros a ha t ht,
  rw smul_set_union at ht,
  exact ht.imp (λ x, hA _ ha x) (λ x, hB _ ha x),
end

lemma balanced.inter (hA : balanced 𝕜 A) (hB : balanced 𝕜 B) : balanced 𝕜 (A ∩ B) :=
begin
  rintro a ha _ ⟨x, ⟨hx₁, hx₂⟩, rfl⟩,
  exact ⟨hA _ ha ⟨_, hx₁, rfl⟩, hB _ ha ⟨_, hx₂, rfl⟩⟩,
end

end has_scalar

section add_comm_monoid
variables [add_comm_monoid E] [module 𝕜 E] {s s' t t' u v A B : set E}

lemma absorbs.add (h : absorbs 𝕜 s t) (h' : absorbs 𝕜 s' t') : absorbs 𝕜 (s + s') (t + t') :=
begin
  rcases h with ⟨r, hr, h⟩,
  rcases h' with ⟨r', hr', h'⟩,
  refine ⟨max r r', lt_max_of_lt_left hr, λ a ha, _⟩,
  rw smul_add,
  exact set.add_subset_add (h a (le_of_max_le_left ha)) (h' a (le_of_max_le_right ha)),
end

lemma balanced.add (hA₁ : balanced 𝕜 A) (hA₂ : balanced 𝕜 B) : balanced 𝕜 (A + B) :=
begin
  rintro a ha _ ⟨_, ⟨x, y, hx, hy, rfl⟩, rfl⟩,
  rw smul_add,
  exact add_mem_add (hA₁ _ ha ⟨_, hx, rfl⟩) (hA₂ _ ha ⟨_, hy, rfl⟩),
end

lemma zero_singleton_balanced : balanced 𝕜 ({0} : set E) :=
λ a ha, by simp only [smul_set_singleton, smul_zero]

end add_comm_monoid
end semi_normed_ring

section normed_comm_ring
variables [normed_comm_ring 𝕜] [add_comm_monoid E] [module 𝕜 E] {A B : set E} (a : 𝕜)

lemma balanced.smul (hA : balanced 𝕜 A) : balanced 𝕜 (a • A) :=
begin
  rintro b hb _ ⟨_, ⟨x, hx, rfl⟩, rfl⟩,
  exact ⟨b • x, hA _ hb ⟨_, hx, rfl⟩, smul_comm _ _ _⟩,
end

end normed_comm_ring

section normed_field
variables [normed_field 𝕜] [normed_ring 𝕝] [normed_space 𝕜 𝕝] [add_comm_group E] [module 𝕜 E]
  [smul_with_zero 𝕝 E] [is_scalar_tower 𝕜 𝕝 E] {s t u v A B : set E} {a b : 𝕜}

/-- Scalar multiplication (by possibly different types) of a balanced set is monotone. -/
lemma balanced.smul_mono (hs : balanced 𝕝 s) {a : 𝕝} {b : 𝕜} (h : ∥a∥ ≤ ∥b∥) : a • s ⊆ b • s :=
begin
  obtain rfl | hb := eq_or_ne b 0,
  { rw norm_zero at h,
    rw norm_eq_zero.1 (h.antisymm $ norm_nonneg _),
    obtain rfl | h := s.eq_empty_or_nonempty,
    { simp_rw [smul_set_empty] },
    { simp_rw [zero_smul_set h] } },
  rintro _ ⟨x, hx, rfl⟩,
  refine ⟨b⁻¹ • a • x, _, smul_inv_smul₀ hb _⟩,
  rw ←smul_assoc,
  refine hs _ _ (smul_mem_smul_set hx),
  rw [norm_smul, norm_inv, ←div_eq_inv_mul],
  exact div_le_one_of_le h (norm_nonneg _),
end

/-- A balanced set absorbs itself. -/
lemma balanced.absorbs_self (hA : balanced 𝕜 A) : absorbs 𝕜 A A :=
begin
  refine ⟨1, zero_lt_one, λ a ha x hx, _⟩,
  rw mem_smul_set_iff_inv_smul_mem₀ (norm_pos_iff.1 $ zero_lt_one.trans_le ha),
  refine hA a⁻¹ _ (smul_mem_smul_set hx),
  rw norm_inv,
  exact inv_le_one ha,
end

lemma balanced.subset_smul (hA : balanced 𝕜 A) (ha : 1 ≤ ∥a∥) : A ⊆ a • A :=
begin
  refine (subset_set_smul_iff₀ _).2 (hA (a⁻¹) _),
  { rintro rfl,
    rw norm_zero at ha,
    exact zero_lt_one.not_le ha },
  { rw norm_inv,
    exact inv_le_one ha }
end

lemma balanced.smul_eq (hA : balanced 𝕜 A) (ha : ∥a∥ = 1) : a • A = A :=
(hA _ ha.le).antisymm $ hA.subset_smul ha.ge

lemma absorbs.inter (hs : absorbs 𝕜 s u) (ht : absorbs 𝕜 t u) : absorbs 𝕜 (s ∩ t) u :=
begin
  obtain ⟨a, ha, hs⟩ := hs,
  obtain ⟨b, hb, ht⟩ := ht,
  have h : 0 < max a b := lt_max_of_lt_left ha,
  refine ⟨max a b, lt_max_of_lt_left ha, λ c hc, _⟩,
  rw smul_set_inter₀ (norm_pos_iff.1 $ h.trans_le hc),
  exact subset_inter (hs _ $ le_of_max_le_left hc) (ht _ $ le_of_max_le_right hc),
end

@[simp] lemma absorbs_inter : absorbs 𝕜 (s ∩ t) u ↔ absorbs 𝕜 s u ∧ absorbs 𝕜 t u :=
⟨λ h, ⟨h.mono_left $ inter_subset_left _ _, h.mono_left $ inter_subset_right _ _⟩,
  λ h, h.1.inter h.2⟩

lemma absorbent_univ : absorbent 𝕜 (univ : set E) :=
begin
  refine λ x, ⟨1, zero_lt_one, λ a ha, _⟩,
  rw smul_set_univ₀ (norm_pos_iff.1 $ zero_lt_one.trans_le ha),
  exact trivial,
end

variables [topological_space E] [has_continuous_smul 𝕜 E]

/-- Every neighbourhood of the origin is absorbent. -/
lemma absorbent_nhds_zero (hA : A ∈ 𝓝 (0 : E)) : absorbent 𝕜 A :=
begin
  intro x,
  obtain ⟨w, hw₁, hw₂, hw₃⟩ := mem_nhds_iff.mp hA,
  have hc : continuous (λ t : 𝕜, t • x) := continuous_id.smul continuous_const,
  obtain ⟨r, hr₁, hr₂⟩ := metric.is_open_iff.mp (hw₂.preimage hc) 0
    (by rwa [mem_preimage, zero_smul]),
  have hr₃ := inv_pos.mpr (half_pos hr₁),
  refine ⟨(r / 2)⁻¹, hr₃, λ a ha₁, _⟩,
  have ha₂ : 0 < ∥a∥ := hr₃.trans_le ha₁,
  refine (mem_smul_set_iff_inv_smul_mem₀ (norm_pos_iff.mp ha₂) _ _).2 (hw₁ $ hr₂ _),
  rw [metric.mem_ball, dist_zero_right, norm_inv],
  calc ∥a∥⁻¹ ≤ r/2 : (inv_le (half_pos hr₁) ha₂).mp ha₁
  ...       < r : half_lt_self hr₁,
end

/-- The union of `{0}` with the interior of a balanced set is balanced. -/
lemma balanced_zero_union_interior (hA : balanced 𝕜 A) : balanced 𝕜 ((0 : set E) ∪ interior A) :=
begin
  intros a ha,
  obtain rfl | h := eq_or_ne a 0,
  { rw zero_smul_set,
    exacts [subset_union_left _ _, ⟨0, or.inl rfl⟩] },
  { rw [←image_smul, image_union],
    apply union_subset_union,
    { rw [image_zero, smul_zero],
      refl },
    { calc a • interior A ⊆ interior (a • A) : (is_open_map_smul₀ h).image_interior_subset A
                      ... ⊆ interior A       : interior_mono (hA _ ha) } }
end

/-- The interior of a balanced set is balanced if it contains the origin. -/
lemma balanced.interior (hA : balanced 𝕜 A) (h : (0 : E) ∈ interior A) : balanced 𝕜 (interior A) :=
begin
  rw ←union_eq_self_of_subset_left (singleton_subset_iff.2 h),
  exact balanced_zero_union_interior hA,
end

lemma balanced.closure (hA : balanced 𝕜 A) : balanced 𝕜 (closure A) :=
λ a ha,
  (image_closure_subset_closure_image $ continuous_id.const_smul _).trans $ closure_mono $ hA _ ha

end normed_field

section nondiscrete_normed_field
variables [nondiscrete_normed_field 𝕜] [add_comm_group E] [module 𝕜 E] {s : set E}

lemma absorbs_zero_iff : absorbs 𝕜 s 0 ↔ (0 : E) ∈ s :=
begin
  refine ⟨_, λ h, ⟨1, zero_lt_one, λ a _, zero_subset.2 $ zero_mem_smul_set h⟩⟩,
  rintro ⟨r, hr, h⟩,
  obtain ⟨a, ha⟩ := normed_space.exists_lt_norm 𝕜 𝕜 r,
  have := h _ ha.le,
  rwa [zero_subset, zero_mem_smul_set_iff] at this,
  exact norm_ne_zero_iff.1 (hr.trans ha).ne',
end

lemma absorbent.zero_mem (hs : absorbent 𝕜 s) : (0 : E) ∈ s :=
absorbs_zero_iff.1 $ absorbent_iff_forall_absorbs_singleton.1 hs _

end nondiscrete_normed_field


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

import field_theory.subfield
import field_theory.tower
import ring_theory.algebraic

/-!
# Intermediate fields

Let `L / K` be a field extension, given as an instance `algebra K L`.
This file defines the type of fields in between `K` and `L`, `intermediate_field K L`.
An `intermediate_field K L` is a subfield of `L` which contains (the image of) `K`,
i.e. it is a `subfield L` and a `subalgebra K L`.

## Main definitions

 * `intermediate_field K L` : the type of intermediate fields between `K` and `L`.

 * `subalgebra.to_intermediate_field`: turns a subalgebra closed under `⁻¹`
   into an intermediate field

 * `subfield.to_intermediate_field`: turns a subfield containing the image of `K`
   into an intermediate field

* `intermediate_field.map`: map an intermediate field along an `alg_hom`

## Implementation notes

Intermediate fields are defined with a structure extending `subfield` and `subalgebra`.
A `subalgebra` is closed under all operations except `⁻¹`,

## Tags
intermediate field, field extension
-/

open finite_dimensional
open_locale big_operators

variables (K L : Type*) [field K] [field L] [algebra K L]

section
set_option old_structure_cmd true

/-- `S : intermediate_field K L` is a subset of `L` such that there is a field
tower `L / S / K`. -/
structure intermediate_field extends subalgebra K L, subfield L

/-- Reinterpret an `intermediate_field` as a `subalgebra`. -/
add_decl_doc intermediate_field.to_subalgebra

/-- Reinterpret an `intermediate_field` as a `subfield`. -/
add_decl_doc intermediate_field.to_subfield

end

variables {K L} (S : intermediate_field K L)

namespace intermediate_field

instance : has_coe (intermediate_field K L) (set L) :=
⟨intermediate_field.carrier⟩

@[simp] lemma coe_to_subalgebra : (S.to_subalgebra : set L) = S := rfl

@[simp] lemma coe_to_subfield : (S.to_subfield : set L) = S := rfl

instance : has_coe_to_sort (intermediate_field K L) := ⟨Type*, λ S, S.carrier⟩

instance : has_mem L (intermediate_field K L) := ⟨λ m S, m ∈ (S : set L)⟩

@[simp] lemma mem_mk (s : set L) (hK : ∀ x, algebra_map K L x ∈ s)
  (ho hm hz ha hn hi) (x : L) :
  x ∈ intermediate_field.mk s ho hm hz ha hK hn hi ↔ x ∈ s := iff.rfl

@[simp] lemma mem_coe {x : L} : x ∈ (S : set L) ↔ x ∈ S := iff.rfl

@[simp] lemma mem_to_subalgebra (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subalgebra ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subfield (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subfield ↔ x ∈ s := iff.rfl

/-- Two intermediate fields are equal if the underlying subsets are equal. -/
theorem ext' ⦃s t : intermediate_field K L⦄ (h : (s : set L) = t) : s = t :=
by { cases s, cases t, congr' }

/-- Two intermediate fields are equal if and only if the underlying subsets are equal. -/
protected theorem ext'_iff {s t : intermediate_field K L} : s = t ↔ (s : set L) = t :=
⟨λ h, h ▸ rfl, λ h, ext' h⟩

/-- Two intermediate fields are equal if they have the same elements. -/
@[ext] theorem ext {S T : intermediate_field K L} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T :=
ext' $ set.ext h

/-- An intermediate field contains the image of the smaller field. -/
theorem algebra_map_mem (x : K) : algebra_map K L x ∈ S :=
S.algebra_map_mem' x

/-- An intermediate field contains the ring's 1. -/
theorem one_mem : (1 : L) ∈ S := S.one_mem'

/-- An intermediate field contains the ring's 0. -/
theorem zero_mem : (0 : L) ∈ S := S.zero_mem'

/-- An intermediate field is closed under multiplication. -/
theorem mul_mem : ∀ {x y : L}, x ∈ S → y ∈ S → x * y ∈ S := S.mul_mem'

/-- An intermediate field is closed under scalar multiplication. -/
theorem smul_mem {y : L} : y ∈ S → ∀ {x : K}, x • y ∈ S := S.to_subalgebra.smul_mem

/-- An intermediate field is closed under addition. -/
theorem add_mem : ∀ {x y : L}, x ∈ S → y ∈ S → x + y ∈ S := S.add_mem'

/-- An intermediate field is closed under subtraction -/
theorem sub_mem {x y : L} (hx : x ∈ S) (hy : y ∈ S) : x - y ∈ S :=
S.to_subfield.sub_mem hx hy

/-- An intermediate field is closed under negation. -/
theorem neg_mem : ∀ {x : L}, x ∈ S → -x ∈ S := S.neg_mem'

/-- An intermediate field is closed under inverses. -/
theorem inv_mem : ∀ {x : L}, x ∈ S → x⁻¹ ∈ S := S.inv_mem'

/-- An intermediate field is closed under division. -/
theorem div_mem {x y : L} (hx : x ∈ S) (hy : y ∈ S) : x / y ∈ S :=
S.to_subfield.div_mem hx hy

/-- Product of a list of elements in an intermediate_field is in the intermediate_field. -/
lemma list_prod_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.prod ∈ S :=
S.to_subfield.list_prod_mem

/-- Sum of a list of elements in an intermediate field is in the intermediate_field. -/
lemma list_sum_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.sum ∈ S :=
S.to_subfield.list_sum_mem

/-- Product of a multiset of elements in an intermediate field is in the intermediate_field. -/
lemma multiset_prod_mem (m : multiset L) :
  (∀ a ∈ m, a ∈ S) → m.prod ∈ S :=
S.to_subfield.multiset_prod_mem m

/-- Sum of a multiset of elements in a `intermediate_field` is in the `intermediate_field`. -/
lemma multiset_sum_mem (m : multiset L) :
  (∀ a ∈ m, a ∈ S) → m.sum ∈ S :=
S.to_subfield.multiset_sum_mem m

/-- Product of elements of an intermediate field indexed by a `finset` is in the intermediate_field. -/
lemma prod_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∏ i in t, f i ∈ S :=
S.to_subfield.prod_mem h

/-- Sum of elements in a `intermediate_field` indexed by a `finset` is in the `intermediate_field`. -/
lemma sum_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∑ i in t, f i ∈ S :=
S.to_subfield.sum_mem h

lemma pow_mem {x : L} (hx : x ∈ S) (n : ℤ) : x^n ∈ S :=
begin
  cases n,
  { exact @is_submonoid.pow_mem L _ S.to_subfield.to_submonoid x _ hx n, },
  { have h := @is_submonoid.pow_mem L _ S.to_subfield.to_submonoid x _ hx _,
    exact subfield.inv_mem S.to_subfield h, },
end

lemma gsmul_mem {x : L} (hx : x ∈ S) (n : ℤ) :
  n •ℤ x ∈ S := S.to_subfield.gsmul_mem hx n

lemma coe_int_mem (n : ℤ) : (n : L) ∈ S :=
by simp only [← gsmul_one, gsmul_mem, one_mem]

end intermediate_field

/-- Turn a subalgebra closed under inverses into an intermediate field -/
def subalgebra.to_intermediate_field (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  intermediate_field K L :=
{ neg_mem' := λ x, S.neg_mem,
  inv_mem' := inv_mem,
  .. S }

@[simp] lemma to_subalgebra_to_intermediate_field
  (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  (S.to_intermediate_field inv_mem).to_subalgebra = S :=
by { ext, refl }

@[simp] lemma to_intermediate_field_to_subalgebra
  (S : intermediate_field K L) (inv_mem : ∀ x ∈ S.to_subalgebra, x⁻¹ ∈ S) :
  S.to_subalgebra.to_intermediate_field inv_mem = S :=
by { ext, refl }

/-- Turn a subfield of `L` containing the image of `K` into an intermediate field -/
def subfield.to_intermediate_field (S : subfield L)
  (algebra_map_mem : ∀ x, algebra_map K L x ∈ S) :
  intermediate_field K L :=
{ algebra_map_mem' := algebra_map_mem,
  .. S }

namespace intermediate_field

/-- An intermediate field inherits a field structure -/
instance to_field : field S :=
S.to_subfield.to_field

@[simp, norm_cast] lemma coe_add (x y : S) : (↑(x + y) : L) = ↑x + ↑y := rfl
@[simp, norm_cast] lemma coe_neg (x : S) : (↑(-x) : L) = -↑x := rfl
@[simp, norm_cast] lemma coe_mul (x y : S) : (↑(x * y) : L) = ↑x * ↑y := rfl
@[simp, norm_cast] lemma coe_inv (x : S) : (↑(x⁻¹) : L) = (↑x)⁻¹ := rfl
@[simp, norm_cast] lemma coe_zero : ((0 : S) : L) = 0 := rfl
@[simp, norm_cast] lemma coe_one : ((1 : S) : L) = 1 := rfl

instance algebra : algebra K S :=
S.to_subalgebra.algebra

instance to_algebra : algebra S L :=
S.to_subalgebra.to_algebra

/-
-- Instances for `coe_sort (coe S)`.
-- TODO: do we really want this?
instance to_field' : field (S : set L) := S.to_field
instance algebra' : algebra K (S : set L) := S.algebra
instance to_algebra' : algebra (S : set L) L := S.to_algebra
-/

instance : is_scalar_tower K S L :=
is_scalar_tower.subalgebra' _ _ _ S.to_subalgebra

variables {L' : Type*} [field L'] [algebra K L']

/-- If `f : L →+* L'` fixes `K`, `S.map f` is the intermediate field between `L'` and `K`
such that `x ∈ S ↔ f x ∈ S.map f`. -/
def map (f : L →ₐ[K] L') : intermediate_field K L' :=
{ inv_mem' := by { rintros _ ⟨x, hx, rfl⟩, exact ⟨x⁻¹, S.inv_mem hx, f.map_inv x⟩ },
  neg_mem' := λ x hx, (S.to_subalgebra.map f).neg_mem hx,
  .. S.to_subalgebra.map f}

/-- The embedding from an intermediate field of `L / K` to `L`. -/
def val : S →ₐ[K] L :=
S.to_subalgebra.val

@[simp] theorem coe_val : ⇑S.val = coe := rfl

@[simp] lemma val_mk {x : L} (hx : x ∈ S) : S.val ⟨x, hx⟩ = x := rfl

@[simp] lemma coe_pow {x : S} (n : ℕ) : ↑(x^n) = (x : L)^n := S.val.map_pow x n

@[simp] lemma pow_mk {x : L} (hx : x ∈ S) (n : ℕ) :
  (⟨x, hx⟩ : S) ^ n = ⟨x ^ n, S.pow_mem hx n⟩ :=
by { ext, simp }

variables {S}

lemma to_subalgebra_injective {S S' : intermediate_field K L}
  (h : S.to_subalgebra = S'.to_subalgebra) : S = S' :=
by { ext, rw [← mem_to_subalgebra, ← mem_to_subalgebra, h] }

lemma to_subalgebra_inj_iff {S S' : intermediate_field K L} :
  (S.to_subalgebra = S'.to_subalgebra) ↔ (S = S') :=
⟨to_subalgebra_injective, λ h, h ▸ rfl⟩

instance : partial_order (intermediate_field K L) :=
{ le := λ S T, (S : set L) ⊆ T,
  le_refl := λ S, set.subset.refl S,
  le_trans := λ _ _ _, set.subset.trans,
  le_antisymm := λ S T hst hts, ext $ λ x, ⟨@hst x, @hts x⟩ }

variables (S)

lemma set_range_subset : set.range (algebra_map K L) ⊆ S :=
S.to_subalgebra.range_subset

lemma field_range_le : (algebra_map K L).field_range ≤ S.to_subfield :=
λ x hx, S.to_subalgebra.range_subset (by rwa [set.mem_range, ← ring_hom.mem_field_range])

@[simp] lemma to_subalgebra_le_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra ≤ S'.to_subalgebra ↔ S ≤ S' := iff.rfl

@[simp] lemma to_subalgebra_lt_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra < S'.to_subalgebra ↔ S < S' := iff.rfl

variables {S}

section tower

/-- Lift an intermediate_field of an intermediate_field -/
def lift1 {F : intermediate_field K L} (E : intermediate_field K F) : intermediate_field K L :=
  map E (val F)

/-- Lift an intermediate_field of an intermediate_field -/
def lift2 {F : intermediate_field K L} (E : intermediate_field F L) : intermediate_field K L :=
{ carrier := E.carrier,
  zero_mem' := zero_mem E,
  add_mem' := λ x y, add_mem E,
  neg_mem' := λ x, neg_mem E,
  one_mem' := one_mem E,
  mul_mem' := λ x y, mul_mem E,
  inv_mem' := λ x, inv_mem E,
  algebra_map_mem' := λ x, algebra_map_mem E (algebra_map K F x) }

instance has_lift1 {F : intermediate_field K L} :
  has_lift_t (intermediate_field K F) (intermediate_field K L) := ⟨lift1⟩

instance has_lift2 {F : intermediate_field K L} :
  has_lift_t (intermediate_field F L) (intermediate_field K L) := ⟨lift2⟩

@[simp] lemma mem_lift2 {F : intermediate_field K L} {E : intermediate_field F L} {x : L} :
  x ∈ (↑E : intermediate_field K L) ↔ x ∈ E := iff.rfl

instance lift2_alg {F : intermediate_field K L} {E : intermediate_field F L} : algebra K E :=
{ to_fun := (algebra_map F E).comp (algebra_map K F),
  map_zero' := ((algebra_map F E).comp (algebra_map K F)).map_zero,
  map_one' := ((algebra_map F E).comp (algebra_map K F)).map_one,
  map_add' := ((algebra_map F E).comp (algebra_map K F)).map_add,
  map_mul' := ((algebra_map F E).comp (algebra_map K F)).map_mul,
  smul := λ a b, (((algebra_map F E).comp (algebra_map K F)) a) * b,
  smul_def' := λ _ _, rfl,
  commutes' := λ a b, mul_comm (((algebra_map F E).comp (algebra_map K F)) a) b }

instance lift2_tower {F : intermediate_field K L} {E : intermediate_field F L} :
  is_scalar_tower K F E :=
⟨λ a b c, by { simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc], refl }⟩

/-- `lift2` is isomorphic to the original `intermediate_field`. -/
def lift2_alg_equiv {F : intermediate_field K L} (E : intermediate_field F L) :
  (↑E : intermediate_field K L) ≃ₐ[K] E :=
{ to_fun := λ x, x,
  inv_fun := λ x, x,
  left_inv := λ x, rfl,
  right_inv := λ x, rfl,
  map_add' := λ x y, rfl,
  map_mul' := λ x y, rfl,
  commutes' := λ x, rfl }

end tower

section finite_dimensional

variables (F E : intermediate_field K L)

instance finite_dimensional_left [finite_dimensional K L] : finite_dimensional K F :=
finite_dimensional.finite_dimensional_submodule F.to_subalgebra.to_submodule

instance finite_dimensional_right [finite_dimensional K L] : finite_dimensional F L :=
right K F L

@[simp] lemma dim_eq_dim_subalgebra :
  vector_space.dim K F.to_subalgebra = vector_space.dim K F := rfl

@[simp] lemma findim_eq_findim_subalgebra :
  findim K F.to_subalgebra = findim K F := rfl

variables {F} {E}

@[simp] lemma to_subalgebra_eq_iff : F.to_subalgebra = E.to_subalgebra ↔ F = E :=
by { rw [subalgebra.ext_iff, intermediate_field.ext'_iff, set.ext_iff], refl }

lemma eq_of_le_of_findim_le [finite_dimensional K L] (h_le : F ≤ E)
  (h_findim : findim K E ≤ findim K F) : F = E :=
intermediate_field.ext'_iff.mpr (submodule.ext'_iff.mp (eq_of_le_of_findim_le
  (show F.to_subalgebra.to_submodule ≤ E.to_subalgebra.to_submodule, by exact h_le) h_findim))

lemma eq_of_le_of_findim_eq [finite_dimensional K L] (h_le : F ≤ E)
  (h_findim : findim K F = findim K E) : F = E :=
eq_of_le_of_findim_le h_le h_findim.ge

lemma eq_of_le_of_findim_le' [finite_dimensional K L] (h_le : F ≤ E)
  (h_findim : findim F L ≤ findim E L) : F = E :=
begin
  apply eq_of_le_of_findim_le h_le,
  have h1 := findim_mul_findim K F L,
  have h2 := findim_mul_findim K E L,
  have h3 : 0 < findim E L := findim_pos,
  nlinarith,
end

lemma eq_of_le_of_findim_eq' [finite_dimensional K L] (h_le : F ≤ E)
  (h_findim : findim F L = findim E L) : F = E :=
eq_of_le_of_findim_le' h_le h_findim.le

end finite_dimensional

section algebraic

lemma is_algebraic (S : intermediate_field K L)
  {x : S} (hx : is_algebraic K (x : L)) :
  is_algebraic K x :=
is_scalar_tower.is_algebraic (algebra_map S L).injective hx

end algebraic

end intermediate_field

/-- If `L/K` is algebraic, the `K`-subalgebras of `L` are all fields.  -/
def subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L) :
  subalgebra K L ≃o intermediate_field K L :=
{ to_fun := λ S, S.to_intermediate_field (λ x hx, S.inv_mem_of_algebraic (alg (⟨x, hx⟩ : S))),
  inv_fun := λ S, S.to_subalgebra,
  left_inv := λ S, to_subalgebra_to_intermediate_field _ _,
  right_inv := λ S, to_intermediate_field_to_subalgebra _ _,
  map_rel_iff' := λ S S', iff.rfl }

@[simp] lemma mem_subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L)
  {S : subalgebra K L} {x : L} :
  x ∈ subalgebra_equiv_intermediate_field alg S ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_subalgebra_equiv_intermediate_field_symm (alg : algebra.is_algebraic K L)
  {S : intermediate_field K L} {x : L} :
  x ∈ (subalgebra_equiv_intermediate_field alg).symm S ↔ x ∈ S :=
iff.rfl


/-
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 category_theory.idempotents.basic
import category_theory.preadditive.additive_functor
import category_theory.equivalence

/-!
# The Karoubi envelope of a category

In this file, we define the Karoubi envelope `karoubi C` of a category `C`.

## Main constructions and definitions

- `karoubi C` is the Karoubi envelope of a category `C`: it is an idempotent
complete category. It is also preadditive when `C` is preadditive.
- `to_karoubi C : C ⥤ karoubi C` is a fully faithful functor, which is an equivalence
(`to_karoubi_is_equivalence`) when `C` is idempotent complete.

-/

noncomputable theory

open category_theory.category
open category_theory.preadditive
open category_theory.limits
open_locale big_operators

namespace category_theory

variables (C : Type*) [category C]

namespace idempotents

/-- In a preadditive category `C`, when an object `X` decomposes as `X ≅ P ⨿ Q`, one may
consider `P` as a direct factor of `X` and up to unique isomorphism, it is determined by the
obvious idempotent `X ⟶ P ⟶ X` which is the projection onto `P` with kernel `Q`. More generally,
one may define a formal direct factor of an object `X : C` : it consists of an idempotent
`p : X ⟶ X` which is thought as the "formal image" of `p`. The type `karoubi C` shall be the
type of the objects of the karoubi enveloppe of `C`. It makes sense for any category `C`. -/
@[nolint has_nonempty_instance]
structure karoubi := (X : C) (p : X ⟶ X) (idem : p ≫ p = p)

namespace karoubi

variables {C}

attribute [simp, reassoc] idem

@[ext]
lemma ext {P Q : karoubi C} (h_X : P.X = Q.X)
  (h_p : P.p ≫ eq_to_hom h_X = eq_to_hom h_X ≫ Q.p) : P = Q :=
begin
  cases P,
  cases Q,
  dsimp at h_X h_p,
  subst h_X,
  simpa only [true_and, eq_self_iff_true, id_comp, eq_to_hom_refl,
    heq_iff_eq, comp_id] using h_p,
end

/-- A morphism `P ⟶ Q` in the category `karoubi C` is a morphism in the underlying category
`C` which satisfies a relation, which in the preadditive case, expresses that it induces a
map between the corresponding "formal direct factors" and that it vanishes on the complement
formal direct factor. -/
@[ext]
structure hom (P Q : karoubi C) := (f : P.X ⟶ Q.X) (comm : f = P.p ≫ f ≫ Q.p)

instance [preadditive C] (P Q : karoubi C) : inhabited (hom P Q) :=
⟨⟨0, by rw [zero_comp, comp_zero]⟩⟩

@[simp]
lemma hom_ext {P Q : karoubi C} {f g : hom P Q} : f = g ↔ f.f = g.f :=
begin
  split,
  { intro h, rw h, },
  { ext, }
end

@[simp, reassoc]
lemma p_comp {P Q : karoubi C} (f : hom P Q) : P.p ≫ f.f = f.f :=
by rw [f.comm, ← assoc, P.idem]

@[simp, reassoc]
lemma comp_p {P Q : karoubi C} (f : hom P Q) : f.f ≫ Q.p = f.f :=
by rw [f.comm, assoc, assoc, Q.idem]

lemma p_comm {P Q : karoubi C} (f : hom P Q) : P.p ≫ f.f = f.f ≫ Q.p :=
by rw [p_comp, comp_p]

lemma comp_proof {P Q R : karoubi C} (g : hom Q R) (f : hom P Q) :
  f.f ≫ g.f = P.p ≫ (f.f ≫ g.f) ≫ R.p :=
by rw [assoc, comp_p, ← assoc, p_comp]

/-- The category structure on the karoubi envelope of a category. -/
instance : category (karoubi C) :=
{ hom      := karoubi.hom,
  id       := λ P, ⟨P.p, by { repeat { rw P.idem, }, }⟩,
  comp     := λ P Q R f g, ⟨f.f ≫ g.f, karoubi.comp_proof g f⟩, }

@[simp]
lemma comp_f {P Q R : karoubi C} (f : P ⟶ Q) (g : Q ⟶ R) :
  (f ≫ g).f = f.f ≫ g.f := by refl

@[simp]
lemma id_eq {P : karoubi C} : 𝟙 P = ⟨P.p, by repeat { rw P.idem, }⟩ := by refl

/-- It is possible to coerce an object of `C` into an object of `karoubi C`.
See also the functor `to_karoubi`. -/
instance coe : has_coe_t C (karoubi C) := ⟨λ X, ⟨X, 𝟙 X, by rw comp_id⟩⟩

@[simp]
lemma coe_X (X : C) : (X : karoubi C).X = X := by refl

@[simp]
lemma coe_p (X : C) : (X : karoubi C).p = 𝟙 X := by refl

@[simp]
lemma eq_to_hom_f {P Q : karoubi C} (h : P = Q) :
  karoubi.hom.f (eq_to_hom h) = P.p ≫ eq_to_hom (congr_arg karoubi.X h) :=
by { subst h, simp only [eq_to_hom_refl, karoubi.id_eq, comp_id], }

end karoubi

/-- The obvious fully faithful functor `to_karoubi` sends an object `X : C` to the obvious
formal direct factor of `X` given by `𝟙 X`. -/
@[simps]
def to_karoubi : C ⥤ karoubi C :=
{ obj := λ X, ⟨X, 𝟙 X, by rw comp_id⟩,
  map := λ X Y f, ⟨f, by simp only [comp_id, id_comp]⟩ }

instance : full (to_karoubi C) :=
{ preimage := λ X Y f, f.f, }

instance : faithful (to_karoubi C) := { }

variables {C}

@[simps]
instance [preadditive C] {P Q : karoubi C} : add_comm_group (P ⟶ Q) :=
{ add := λ f g, ⟨f.f+g.f, begin
    rw [add_comp, comp_add],
    congr',
    exacts [f.comm, g.comm],
  end⟩,
  zero := ⟨0, by simp only [comp_zero, zero_comp]⟩,
  zero_add := λ f, by { ext, simp only [zero_add], },
  add_zero := λ f, by { ext, simp only [add_zero], },
  add_assoc := λ f g h', by simp only [add_assoc],
  add_comm := λ f g, by { ext, apply_rules [add_comm], },
  neg := λ f, ⟨-f.f, by simpa only [neg_comp, comp_neg, neg_inj] using f.comm⟩,
  add_left_neg := λ f, by { ext, apply_rules [add_left_neg], }, }

namespace karoubi

lemma hom_eq_zero_iff [preadditive C] {P Q : karoubi C} {f : hom P Q} : f = 0 ↔ f.f = 0 := hom_ext

/-- The map sending `f : P ⟶ Q` to `f.f : P.X ⟶ Q.X` is additive. -/
@[simps]
def inclusion_hom [preadditive C] (P Q : karoubi C) : add_monoid_hom (P ⟶ Q) (P.X ⟶ Q.X) :=
{ to_fun    := λ f, f.f,
  map_zero' := rfl,
  map_add'  := λ f g, rfl }

@[simp]
lemma sum_hom [preadditive C] {P Q : karoubi C} {α : Type*} (s : finset α) (f : α → (P ⟶ Q)) :
  (∑ x in s, f x).f = ∑ x in s, (f x).f  :=
add_monoid_hom.map_sum (inclusion_hom P Q) f s

end karoubi

/-- The category `karoubi C` is preadditive if `C` is. -/
instance [preadditive C] : preadditive (karoubi C) :=
{ hom_group := λ P Q, by apply_instance, }

instance [preadditive C] : functor.additive (to_karoubi C) := { }

open karoubi

variables (C)

instance : is_idempotent_complete (karoubi C) :=
begin
  refine ⟨_⟩,
  intros P p hp,
  have hp' := hom_ext.mp hp,
  simp only [comp_f] at hp',
  use ⟨P.X, p.f, hp'⟩,
  use ⟨p.f, by rw [comp_p p, hp']⟩,
  use ⟨p.f, by rw [hp', p_comp p]⟩,
  split; simpa only [hom_ext] using hp',
end

instance [is_idempotent_complete C] : ess_surj (to_karoubi C) := ⟨λ P, begin
  have h : is_idempotent_complete C := infer_instance,
  rcases is_idempotent_complete.idempotents_split P.X P.p P.idem
    with ⟨Y,i,e,⟨h₁,h₂⟩⟩,
  use Y,
  exact nonempty.intro
    { hom := ⟨i, by erw [id_comp, ← h₂, ← assoc, h₁, id_comp]⟩,
      inv := ⟨e, by erw [comp_id, ← h₂, assoc, h₁, comp_id]⟩, },
end⟩

/-- If `C` is idempotent complete, the functor `to_karoubi : C ⥤ karoubi C` is an equivalence. -/
def to_karoubi_is_equivalence [is_idempotent_complete C] :
  is_equivalence (to_karoubi C) :=
equivalence.of_fully_faithfully_ess_surj (to_karoubi C)

/-- The equivalence `C ≅ karoubi C` when `C` is idempotent complete. -/
def to_karoubi_equivalence [is_idempotent_complete C] : C ≌ karoubi C :=
by { haveI := to_karoubi_is_equivalence C, exact functor.as_equivalence (to_karoubi C), }

instance to_karoubi_equivalence_functor_additive
  [preadditive C] [is_idempotent_complete C] :
  (to_karoubi_equivalence C).functor.additive := (infer_instance : (to_karoubi C).additive)

namespace karoubi

variables {C}

/-- The split mono which appears in the factorisation `decomp_id P`. -/
@[simps]
def decomp_id_i (P : karoubi C) : P ⟶ P.X := ⟨P.p, by erw [coe_p, comp_id, P.idem]⟩

/-- The split epi which appears in the factorisation `decomp_id P`. -/
@[simps]
def decomp_id_p (P : karoubi C) : (P.X : karoubi C) ⟶ P :=
⟨P.p, by erw [coe_p, id_comp, P.idem]⟩

/-- The formal direct factor of `P.X` given by the idempotent `P.p` in the category `C`
is actually a direct factor in the category `karoubi C`. -/
lemma decomp_id (P : karoubi C) :
  𝟙 P = (decomp_id_i P) ≫ (decomp_id_p P) :=
by { ext, simp only [comp_f, id_eq, P.idem, decomp_id_i, decomp_id_p], }

lemma decomp_p (P : karoubi C) :
  (to_karoubi C).map P.p = (decomp_id_p P) ≫ (decomp_id_i P) :=
by { ext, simp only [comp_f, decomp_id_p_f, decomp_id_i_f, P.idem, to_karoubi_map_f], }

lemma decomp_id_p_to_karoubi (X : C) : decomp_id_p ((to_karoubi C).obj X) = 𝟙 _ :=
by { ext, refl, }

lemma decomp_id_i_naturality {P Q : karoubi C} (f : P ⟶ Q) : f ≫ decomp_id_i _ =
  decomp_id_i _ ≫ ⟨f.f, by erw [comp_id, id_comp]⟩ :=
by { ext, simp only [comp_f, decomp_id_i_f, karoubi.comp_p, karoubi.p_comp], }

lemma decomp_id_p_naturality {P Q : karoubi C} (f : P ⟶ Q) : decomp_id_p P ≫ f =
  (⟨f.f, by erw [comp_id, id_comp]⟩ : (P.X : karoubi C) ⟶ Q.X) ≫ decomp_id_p Q :=
by { ext, simp only [comp_f, decomp_id_p_f, karoubi.comp_p, karoubi.p_comp], }

@[simp]
lemma zsmul_hom [preadditive C] {P Q : karoubi C} (n : ℤ) (f : P ⟶ Q) :
  (n • f).f = n • f.f :=
map_zsmul (inclusion_hom P Q) n f

end karoubi

end idempotents

end category_theory


import .list

inductive fm (α : Type) : Type
| true  : fm
| false : fm
| atom : α → fm
| and : fm → fm → fm
| or  : fm → fm → fm
| not : fm → fm
| ex  : fm → fm

notation `⊤'`     := fm.true _
notation `⊥'`     := fm.false _
notation `A'` a   := fm.atom a
notation `¬'` p   := fm.not p
notation p `∧'` q := fm.and p q
notation p `∨'` q := fm.or p q
notation `∃'` p   := fm.ex p

-- | ⊤' := sorry
-- | ⊥' := sorry
-- | (A' a) := sorry
-- | (p ∧' q) := sorry
-- | (p ∨' q) := sorry
-- | (¬' p) := sorry
-- | (∃' p) := sorry

variables {α β : Type}

meta def fm_to_format [has_to_format α] : fm α → format
| (fm.true α) := "⊤"
| (fm.false α) := "⊥"
| (fm.atom a) := to_fmt a
| (fm.and p q) := "(" ++ (fm_to_format p) ++ " ∧ " ++ (fm_to_format q) ++ ")"
| (fm.or p q) := "(" ++ (fm_to_format p) ++ " ∨ " ++ (fm_to_format q) ++ ")"
| (fm.not p) := "¬(" ++ (fm_to_format p) ++ ")"
| (fm.ex p)  := "∃(" ++ (fm_to_format p) ++ ")"

meta instance [has_to_format α] : has_to_format (fm α) := ⟨fm_to_format⟩

meta instance [has_to_format α] : has_to_tactic_format (fm α) :=
has_to_format_to_has_to_tactic_format _

def top_or_not (p : fm α) : p = ⊤' ∨ p ≠ ⊤' :=
by cases p; {{apply or.inl, refl} <|> {apply or.inr, intro HC, cases HC}}

def bot_or_not (p : fm α) : p = ⊥' ∨ p ≠ ⊥' :=
by cases p; {{apply or.inl, refl} <|> {apply or.inr, intro HC, cases HC}}

def and_o : fm α → fm α → fm α
| (fm.true α) q' := q'
| p' (fm.true α) := p'
| (fm.false α) q' := fm.false α
| p' (fm.false α) := fm.false α
| p' q' := fm.and p' q'

-- Q : Why can't I prove this with refl?
lemma exp_top_and_o (p : fm α) : (@and_o α ⊤' p) = p :=
by induction p; {intro_refl}

lemma exp_and_o_top (p : fm α) : (@and_o α p ⊤') = p :=
by induction p; {intro_refl}

lemma exp_bot_and_o (p : fm α) : (@and_o α ⊥' p) = ⊥' :=
by induction p; {intro_refl}

lemma exp_and_o_bot (p : fm α) : (@and_o α p ⊥') = ⊥' :=
by induction p; {intro_refl}

lemma exp_and_o_nc (p q : fm α) :
(p ≠ ⊤') → (p ≠ ⊥') → (q ≠ ⊤') → (q ≠ ⊥') → (@and_o α p q) = (p ∧' q) :=
by intros H1 H2 H3 H4; cases p; cases q; {refl <|> contradiction}

lemma cases_and_o (P : fm α → Prop) (p q : fm α)
  (HB : P ⊥') (Hp : P p) (Hq : P q) (Hpq : P (p ∧' q)) : P (and_o p q) :=
begin
  cases (top_or_not p) with H1 H1, rewrite H1,
  rewrite exp_top_and_o, apply Hq,
  cases (bot_or_not p) with H2 H2, rewrite H2,
  rewrite exp_bot_and_o, apply HB,
  cases (top_or_not q) with H3 H3, rewrite H3,
  rewrite exp_and_o_top, apply Hp,
  cases (bot_or_not q) with H4 H4, rewrite H4,
  rewrite exp_and_o_bot, apply HB,
  rewrite exp_and_o_nc _ _ H1 H2 H3 H4,
  apply Hpq
end

lemma cases_and_o' (P : fm α → fm α → fm α → Prop) (p q : fm α)
  (HTq : P ⊤' q q) (HBq : P ⊥' q ⊥')
  (HpT : P p ⊤' p) (HpB : P p ⊥' ⊥')
  (Hpq : P p q (p ∧' q)) : P p q (and_o p q) :=
begin
  cases (top_or_not p) with H1 H1, rewrite H1,
  rewrite exp_top_and_o, apply HTq,
  cases (bot_or_not p) with H2 H2, rewrite H2,
  rewrite exp_bot_and_o, apply HBq,
  cases (top_or_not q) with H3 H3, rewrite H3,
  rewrite exp_and_o_top, apply HpT,
  cases (bot_or_not q) with H4 H4, rewrite H4,
  rewrite exp_and_o_bot, apply HpB,
  rewrite exp_and_o_nc _ _ H1 H2 H3 H4,
  apply Hpq
end

def or_o : fm α → fm α → fm α
| (fm.true α) _ := ⊤'
| _ (fm.true α) := ⊤'
| (fm.false α) q := q
| p (fm.false α) := p
| p q := fm.or p q

lemma exp_top_or_o (p : fm α) : (@or_o α ⊤' p) = ⊤' :=
by induction p; {intro_refl}

lemma exp_bot_or_o (p : fm α) : (@or_o α ⊥' p) = p :=
by induction p; {intro_refl}

lemma exp_or_o_top (p : fm α) : (@or_o α p ⊤') = ⊤' :=
by induction p; {intro_refl}

lemma exp_or_o_bot (p : fm α) : (@or_o α p ⊥') = p :=
by induction p; {intro_refl}

lemma exp_or_o_nc (p q : fm α) :
(p ≠ ⊤') → (p ≠ ⊥') → (q ≠ ⊤') → (q ≠ ⊥') → (@or_o α p q) = (p ∨' q) :=
by intros H1 H2 H3 H4; cases p; cases q; {refl <|> contradiction}

lemma cases_or_o (P : fm α → Prop) (p q : fm α)
  (HT : P ⊤') (Hp : P p) (Hq : P q) (Hpq : P (p ∨' q)) : P (or_o p q) :=
begin
  cases (top_or_not p) with H1 H1, rewrite H1,
  rewrite exp_top_or_o, apply HT,
  cases (bot_or_not p) with H2 H2, rewrite H2,
  rewrite exp_bot_or_o, apply Hq,
  cases (top_or_not q) with H3 H3, rewrite H3,
  rewrite exp_or_o_top, apply HT,
  cases (bot_or_not q) with H4 H4, rewrite H4,
  rewrite exp_or_o_bot, apply Hp,
  rewrite exp_or_o_nc _ _ H1 H2 H3 H4,
  apply Hpq
end

lemma cases_or_o' (P : fm α → fm α → fm α → Prop) (p q : fm α)
  (HTq : P ⊤' q ⊤') (HBq : P ⊥' q q)
  (HpT : P p ⊤' ⊤') (HpB : P p ⊥' p)
  (Hpq : P p q (p ∨' q)) : P p q (or_o p q) :=
begin
  cases (top_or_not p) with H1 H1, rewrite H1,
  rewrite exp_top_or_o, apply HTq,
  cases (bot_or_not p) with H2 H2, rewrite H2,
  rewrite exp_bot_or_o, apply HBq,
  cases (top_or_not q) with H3 H3, rewrite H3,
  rewrite exp_or_o_top, apply HpT,
  cases (bot_or_not q) with H4 H4, rewrite H4,
  rewrite exp_or_o_bot, apply HpB,
  rewrite exp_or_o_nc _ _ H1 H2 H3 H4,
  apply Hpq
end

def not_o : fm α → fm α
| ⊤' := ⊥'
| ⊥' := ⊤'
| p := ¬' p

lemma cases_not_o_core (P : fm α → fm α → Prop) (p : fm α)
  (ht : P p ⊤' ) (hb : P p ⊥') (hnp : P p (¬' p)) : P p (not_o p) :=
begin cases p, apply hb, apply ht, repeat {apply hnp}, end

lemma cases_not_o (P : fm α → Prop) (p : fm α)
  (ht : P ⊤' ) (hb : P ⊥') (hnp : P (¬' p)) : P (not_o p) :=
cases_not_o_core (λ _ q, P q) p ht hb hnp

lemma exp_not_o_top : not_o ⊤' = (fm.false α) := eq.refl _

lemma exp_not_o_bot : not_o ⊥' = (fm.true α) := eq.refl _

lemma exp_not_o_nc (p : fm α) :
(p ≠ ⊤') → (p ≠ ⊥') → (@not_o α p) = ¬' p :=
by intros H1 H2; cases p; {refl <|> contradiction}

def list_conj : list (fm α) → fm α
| [] := ⊤'
| (p::ps) := and_o p $ list_conj ps

def list_disj : list (fm α) → fm α
| [] := ⊥'
| (p::ps) := or_o p $ list_disj ps

def disj (bs : list β) (f : β → fm α) := list_disj (list.map f bs)

def dnf_to_fm (ls : list (list α)) (f : list α → fm α) := list_disj (list.map f ls)

-- def nfree : fm α → bool
-- | ⊤' := tt
-- | ⊥' := tt
-- | A' a := tt
-- | (¬' p) := ff
-- | (p ∨' q) := nfree p && nfree q
-- | (p ∧' q) := nfree p && nfree q
-- | (∃' p) := nfree p

def qfree : fm α → Prop
| ⊤' := true
| ⊥' := true
| A' a := true
| (¬' p) := qfree p
| (p ∨' q) := qfree p ∧ qfree q
| (p ∧' q) := qfree p ∧ qfree q
| (∃' p) :=  false

def nqfree : fm α → Prop
| ⊤' := true
| ⊥' := true
| A' a := true
| (¬' p) := false
| (p ∨' q) := nqfree p ∧ nqfree q
| (p ∧' q) := nqfree p ∧ nqfree q
| (∃' p) := false

lemma qfree_of_nqfree : ∀ (p : fm α), nqfree p → qfree p
| ⊤' _ := trivial
| ⊥' _ := trivial
| (A' a) _ := trivial
| (¬' p) h := by cases h
| (p ∨' q) h :=
  begin
    cases h with hp hq, apply and.intro;
    apply qfree_of_nqfree; assumption
  end
| (p ∧' q) h :=
  begin
    cases h with hp hq, apply and.intro;
    apply qfree_of_nqfree; assumption
  end
| (∃' p) h := by cases h

inductive down : fm α → fm α → Prop
| andl : ∀ p q, down (p ∧' q) p
| andr : ∀ p q, down (p ∧' q) q
| orl  : ∀ p q, down (p ∨' q) p
| orr  : ∀ p q, down (p ∨' q) q
| not  : ∀ p, down (¬' p) p
| ex   : ∀ p, down (∃' p) p

def down_closed (P : fm α → Prop) : Prop :=
∀ (p q : fm α), down p q → P p → P q

def of_subformulas (P : fm α → Prop) : fm α → Prop
| ⊤' := P ⊤'
| ⊥' := P ⊥'
| (A' a) := true
| (p ∧' q) := P p → P q → P (p ∧' q)
| (p ∨' q) := P p → P q → P (p ∨' q)
| (¬' p) := P p → P (¬' p)
| (∃' p) := P p → P (∃' p)

def of_prop_subformulas (P : fm α → Prop) : fm α → Prop
| ⊤' := P ⊤'
| ⊥' := P ⊥'
| (A' a) := true
| (p ∧' q) := P p → P q → P (p ∧' q)
| (p ∨' q) := P p → P q → P (p ∨' q)
| (¬' p) := P p → P (¬' p)
| (∃' p) := true

def up_closed (P : fm α → Prop) : Prop :=
∀ (p : fm α), of_subformulas P p

def prop_up_closed (P : fm α → Prop) : Prop :=
∀ (p : fm α), of_prop_subformulas P p

lemma pred_and_o (P : fm α → Prop) (hup : prop_up_closed P) :
  ∀ (p q : fm α), P p → P q → P (and_o p q) :=
begin
  intros p q hp hq, apply cases_and_o;
  try {apply hup ⊥' <|> assumption},
  apply hup (p ∧' q); assumption
end

lemma pred_or_o (P : fm α → Prop) (hup : prop_up_closed P) :
  ∀ (p q : fm α), P p → P q → P (or_o p q) :=
begin
  intros p q hp hq, apply cases_or_o;
  try {apply hup ⊤' <|> assumption},
  apply hup (p ∨' q); assumption
end

lemma pred_list_disj (P : fm α → Prop) (hup : prop_up_closed P) :
  ∀ (ps : list (fm α)), (∀ p ∈ ps, P p) → P (list_disj ps)
| [] h := hup ⊥'
| (p::ps) h :=
  begin
    unfold list_disj, apply pred_or_o _ hup,
    apply h, apply or.inl rfl,
    apply pred_list_disj,
    apply list.forall_mem_of_forall_mem_cons h
  end

lemma pred_disj  (P : fm α → Prop) (hup : prop_up_closed P)
  (bs : list β) (f : β → fm α) : (∀ b ∈ bs, P (f b)) → P (disj bs f) :=
begin
  intro h, unfold disj, apply pred_list_disj _ hup,
  intros p hp, rewrite list.mem_map at hp,
  cases hp with b hb, cases hb with hb1 hb2,
  subst hb2, apply h, apply hb1
end

lemma down_closed_qfree : @down_closed α qfree
| ⊤' _ hd _ := by cases hd
| ⊥' _ hd _ := by cases hd
| (A' a) _ hd _ := by cases hd
| (p ∧' q) r hd hn :=
  begin cases hn with hnp hnq, cases hd; assumption end
| (p ∨' q) r hd hn :=
  begin cases hn with hnp hnq, cases hd; assumption end
  -- by {unfold fnormal at hn, cases hn, cases hd; assumption}
| (¬' p) r hd hn := begin cases hd, apply hn end
| (∃' p) r hd hn := by cases hn

lemma prop_up_closed_qfree : @prop_up_closed α qfree
| ⊤' := trivial
| ⊥' := trivial
| (A' a) := trivial
| (p ∧' q) := begin intros hp hq, apply and.intro hp hq end
| (p ∨' q) := begin intros hp hq, apply and.intro hp hq end
| (¬' p) := id
| (∃' p) := trivial

lemma qfree_and_o : ∀ {p q : fm α}, qfree p → qfree q → qfree (and_o p q) :=
pred_and_o _ prop_up_closed_qfree

lemma qfree_or_o : ∀ {p q : fm α}, qfree p → qfree q → qfree (or_o p q) :=
pred_or_o _ prop_up_closed_qfree

lemma qfree_list_disj : ∀ (ps : list (fm α)), (∀ p ∈ ps, qfree p) → qfree (list_disj ps) :=
pred_list_disj _ prop_up_closed_qfree

lemma qfree_disj : ∀ (bs : list β) (f : β → fm α), (∀ b ∈ bs, qfree (f b)) → qfree (disj bs f) :=
pred_disj _ prop_up_closed_qfree

lemma qfree_list_conj : ∀ (ps : list (fm α)), (∀ p ∈ ps, qfree p) → qfree (list_conj ps)
| [] _ := trivial
| (p::ps) h :=
  begin
    unfold list_conj, apply cases_and_o, trivial,
    apply h, simp, apply qfree_list_conj,
    intros q Hq, apply h, apply or.inr, apply Hq,
    unfold qfree, apply and.intro,
    apply h, simp, apply qfree_list_conj,
    intros q Hq, apply h, apply or.inr, apply Hq
  end

lemma qfree_dnf_to_fm (f : list α → fm α) (H : ∀ l, qfree (f l)) : ∀ (ls : list (list α)), qfree (dnf_to_fm ls f)
| [] := trivial
| (l::ls) :=
  begin
    unfold dnf_to_fm, unfold list.map, unfold list_disj,
    apply cases_or_o qfree _ _ trivial,
    apply H, apply qfree_dnf_to_fm,
    unfold qfree, apply and.intro,
    apply H, apply qfree_dnf_to_fm
  end

/-
Requires : qfree arg-0
-/
def map_fm (f : α → β) : fm α → fm β
| ⊤' := ⊤'
| ⊥' := ⊥'
| A' a := A' (f a)
| (¬' p) := ¬' (map_fm p)
| (p ∨' q) := (map_fm p) ∨' (map_fm q)
| (p ∧' q) := (map_fm p) ∧' (map_fm q)
| (∃' p) := ⊥'

/-
Requires : qfree arg-0
-/
def amap (f : α → fm β) : fm α → fm β
| ⊤' := ⊤'
| ⊥' := ⊥'
| A' a := f a
| (¬' p) := not_o (amap p)
| (p ∨' q) := or_o (amap p) (amap q)
| (p ∧' q) := and_o (amap p) (amap q)
| (∃' p) := ⊥'

def atoms [decidable_eq α] : fm α → list α
| ⊤' := []
| ⊥' := []
| A' a := [a]
| (¬' p) := atoms p
| (p ∨' q) := (atoms p) ∪ (atoms q)
| (p ∧' q) := (atoms p) ∪ (atoms q)
| (∃' p) := atoms p

meta def map_fm_prsv_tac :=
`[unfold map_fm, unfold atoms,
  rewrite list.forall_mem_union, unfold atoms at h,
  rewrite list.forall_mem_union at h, cases h with hp hq,
  apply and.intro; apply map_fm_prsv; assumption]

lemma map_fm_prsv [decidable_eq α] [decidable_eq β] (P : α → Prop) {Q : β → Prop}
  {f : α → β} (hf : ∀ a, P a → Q (f a)) :
  ∀ {p} {hp : ∀ a ∈ (atoms p), P a}, ∀ a ∈ (atoms (map_fm f p)), Q a
| ⊤' h := begin apply list.forall_mem_nil end
| ⊥' h := begin apply list.forall_mem_nil end
| (A' a) h :=
  begin
    unfold map_fm, unfold atoms, intros b hb,
    rewrite list.mem_singleton at hb, subst hb,
    apply hf, apply h, unfold atoms, apply or.inl rfl
  end
| (¬' p) h :=
  begin
    unfold map_fm, unfold atoms, unfold atoms at h,
    apply map_fm_prsv, apply h
  end
| (p ∧' q) h := by map_fm_prsv_tac
| (p ∨' q) h := by map_fm_prsv_tac
| (∃' p) h :=
  begin unfold map_fm, unfold atoms, apply list.forall_mem_nil end

lemma atoms_map_fm [decidable_eq α] [decidable_eq β] (f : α → β) :
  ∀ (p : fm α), nqfree p → list.equiv (atoms (map_fm f p)) (list.map f (atoms p))
| ⊤' _ := by apply list.equiv.refl
| ⊥' _ := by apply list.equiv.refl
| (A' a) _ := by apply list.equiv.refl
| (p ∧' q) hf :=
  begin
    cases hf with hfp hfq, unfold map_fm,
    unfold atoms, apply list.equiv.trans,
    apply list.union_equiv_union_of_equiv
      (atoms_map_fm p hfp),
    apply list.equiv.trans list.union_comm,
    apply list.equiv.trans,
    apply list.union_equiv_union_of_equiv
      (atoms_map_fm q hfq),
    apply list.equiv.trans list.union_comm,
    apply list.equiv.symm, apply list.map_union
  end
| (p ∨' q) hf :=
  begin
    cases hf with hfp hfq, unfold map_fm,
    unfold atoms, apply list.equiv.trans,
    apply list.union_equiv_union_of_equiv
      (atoms_map_fm p hfp),
    apply list.equiv.trans list.union_comm,
    apply list.equiv.trans,
    apply list.union_equiv_union_of_equiv
      (atoms_map_fm q hfq),
    apply list.equiv.trans list.union_comm,
    apply list.equiv.symm, apply list.map_union
  end
| (¬' p) hf := by cases hf
| (∃' p) hf := by cases hf

def interp (h : list β → α → Prop) : list β → fm α → Prop
| xs ⊤' := true
| xs ⊥' := false
| xs (A' a) := h xs a
| xs (¬' p) := ¬ (interp xs p)
| xs (p ∨' q) := (interp xs p) ∨ (interp xs q)
| xs (p ∧' q) := (interp xs p) ∧ (interp xs q)
| xs ∃' p := exists (x : β), interp (x::xs) p


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.group_power.lemmas

/-!
# Powers of elements of groups with an adjoined zero element

In this file we define integer power functions for groups with an adjoined zero element.
This generalises the integer power function on a division ring.
-/

section zero
variables {M : Type*} [monoid_with_zero M]

@[simp] lemma zero_pow' : ∀ n : ℕ, n ≠ 0 → (0 : M) ^ n = 0
| 0     h := absurd rfl h
| (k+1) h := by { rw [pow_succ], exact zero_mul _ }

lemma ne_zero_pow {a : M} {n : ℕ} (hn : n ≠ 0) : a ^ n ≠ 0 → a ≠ 0 :=
by { contrapose!, rintro rfl, exact zero_pow' n hn }

@[simp] lemma zero_pow_eq_zero [nontrivial M] {n : ℕ} : (0 : M) ^ n = 0 ↔ 0 < n :=
begin
  split; intro h,
  { rw [pos_iff_ne_zero], rintro rfl, simpa using h },
  { exact zero_pow' n h.ne.symm }
end

lemma ring.inverse_pow (r : M) : ∀ (n : ℕ), ring.inverse r ^ n = ring.inverse (r ^ n)
| 0 := by rw [pow_zero, pow_zero, ring.inverse_one]
| (n + 1) := by rw [pow_succ, pow_succ', ring.mul_inverse_rev' ((commute.refl r).pow_left n),
                    ring.inverse_pow]

end zero

section group_with_zero
variables {G₀ : Type*} [group_with_zero G₀] {a : G₀} {m n : ℕ}

section nat_pow

theorem pow_sub₀ (a : G₀) {m n : ℕ} (ha : a ≠ 0) (h : n ≤ m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
have h1 : m - n + n = m, from tsub_add_cancel_of_le h,
have h2 : a ^ (m - n) * a ^ n = a ^ m, by rw [←pow_add, h1],
by simpa only [div_eq_mul_inv] using eq_div_of_mul_eq (pow_ne_zero _ ha) h2

lemma pow_sub_of_lt (a : G₀) {m n : ℕ} (h : n < m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
begin
  obtain rfl | ha := eq_or_ne a 0,
  { rw [zero_pow (tsub_pos_of_lt h), zero_pow (n.zero_le.trans_lt h), zero_mul] },
  { exact pow_sub₀ _ ha h.le }
end

theorem pow_inv_comm₀ (a : G₀) (m n : ℕ) : (a⁻¹) ^ m * a ^ n = a ^ n * (a⁻¹) ^ m :=
(commute.refl a).inv_left₀.pow_pow m n

lemma inv_pow_sub₀ (ha : a ≠ 0) (h : n ≤ m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub₀ _ (inv_ne_zero ha) h, inv_pow, inv_pow, inv_inv]

lemma inv_pow_sub_of_lt (a : G₀) (h : n < m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub_of_lt a⁻¹ h, inv_pow, inv_pow, inv_inv]

end nat_pow

end group_with_zero

section zpow
open int
variables {G₀ : Type*} [group_with_zero G₀]

local attribute [ematch] le_of_lt

lemma zero_zpow : ∀ z : ℤ, z ≠ 0 → (0 : G₀) ^ z = 0
| (n : ℕ) h := by { rw [zpow_coe_nat, zero_pow'], simpa using h }
| -[1+n]  h := by simp

lemma zero_zpow_eq (n : ℤ) : (0 : G₀) ^ n = if n = 0 then 1 else 0 :=
begin
  split_ifs with h,
  { rw [h, zpow_zero] },
  { rw [zero_zpow _ h] }
end

lemma zpow_add_one₀ {a : G₀} (ha : a ≠ 0) : ∀ n : ℤ, a ^ (n + 1) = a ^ n * a
| (n : ℕ)    := by simp only [← int.coe_nat_succ, zpow_coe_nat, pow_succ']
| -[1+0]     := by erw [zpow_zero, zpow_neg_succ_of_nat, pow_one, inv_mul_cancel ha]
| -[1+(n+1)] := by rw [int.neg_succ_of_nat_eq, zpow_neg, neg_add, neg_add_cancel_right, zpow_neg,
  ← int.coe_nat_succ, zpow_coe_nat, zpow_coe_nat, pow_succ _ (n + 1), mul_inv_rev, mul_assoc,
  inv_mul_cancel ha, mul_one]

lemma zpow_sub_one₀ {a : G₀} (ha : a ≠ 0) (n : ℤ) : a ^ (n - 1) = a ^ n * a⁻¹ :=
calc a ^ (n - 1) = a ^ (n - 1) * a * a⁻¹ : by rw [mul_assoc, mul_inv_cancel ha, mul_one]
             ... = a^n * a⁻¹             : by rw [← zpow_add_one₀ ha, sub_add_cancel]

lemma zpow_add₀ {a : G₀} (ha : a ≠ 0) (m n : ℤ) : a ^ (m + n) = a ^ m * a ^ n :=
begin
  induction n using int.induction_on with n ihn n ihn,
  case hz : { simp },
  { simp only [← add_assoc, zpow_add_one₀ ha, ihn, mul_assoc] },
  { rw [zpow_sub_one₀ ha, ← mul_assoc, ← ihn, ← zpow_sub_one₀ ha, add_sub_assoc] }
end

lemma zpow_add' {a : G₀} {m n : ℤ} (h : a ≠ 0 ∨ m + n ≠ 0 ∨ m = 0 ∧ n = 0) :
  a ^ (m + n) = a ^ m * a ^ n :=
begin
  by_cases hm : m = 0, { simp [hm] },
  by_cases hn : n = 0, { simp [hn] },
  by_cases ha : a = 0,
  { subst a,
    simp only [false_or, eq_self_iff_true, not_true, ne.def, hm, hn, false_and, or_false] at h,
    rw [zero_zpow _ h, zero_zpow _ hm, zero_mul] },
  { exact zpow_add₀ ha m n }
end

theorem zpow_one_add₀ {a : G₀} (h : a ≠ 0) (i : ℤ) : a ^ (1 + i) = a * a ^ i :=
by rw [zpow_add₀ h, zpow_one]

theorem semiconj_by.zpow_right₀ {a x y : G₀} (h : semiconj_by a x y) :
  ∀ m : ℤ, semiconj_by a (x^m) (y^m)
| (n : ℕ) := by simp [h.pow_right n]
| -[1+n]  := by simp [(h.pow_right (n + 1)).inv_right₀]

theorem commute.zpow_right₀ {a b : G₀} (h : commute a b) : ∀ m : ℤ, commute a (b^m) :=
h.zpow_right₀

theorem commute.zpow_left₀ {a b : G₀} (h : commute a b) (m : ℤ) : commute (a^m) b :=
(h.symm.zpow_right₀ m).symm

theorem commute.zpow_zpow₀ {a b : G₀} (h : commute a b) (m n : ℤ) : commute (a^m) (b^n) :=
(h.zpow_left₀ m).zpow_right₀ n

theorem commute.zpow_self₀ (a : G₀) (n : ℤ) : commute (a^n) a := (commute.refl a).zpow_left₀ n

theorem commute.self_zpow₀ (a : G₀) (n : ℤ) : commute a (a^n) := (commute.refl a).zpow_right₀ n

theorem commute.zpow_zpow_self₀ (a : G₀) (m n : ℤ) : commute (a^m) (a^n) :=
(commute.refl a).zpow_zpow₀ m n

theorem zpow_bit1₀ (a : G₀) (n : ℤ) : a ^ bit1 n = a ^ n * a ^ n * a :=
begin
  rw [← zpow_bit0, bit1, zpow_add', zpow_one],
  right, left,
  apply bit1_ne_zero
end

lemma zpow_ne_zero_of_ne_zero {a : G₀} (ha : a ≠ 0) : ∀ (z : ℤ), a ^ z ≠ 0
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_ne_zero _ ha }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_ne_zero (pow_ne_zero _ ha) }

lemma zpow_sub₀ {a : G₀} (ha : a ≠ 0) (z1 z2 : ℤ) : a ^ (z1 - z2) = a ^ z1 / a ^ z2 :=
by rw [sub_eq_add_neg, zpow_add₀ ha, zpow_neg, div_eq_mul_inv]

theorem zpow_bit1' (a : G₀) (n : ℤ) : a ^ bit1 n = (a * a) ^ n * a :=
by rw [zpow_bit1₀, (commute.refl a).mul_zpow]

lemma zpow_eq_zero {x : G₀} {n : ℤ} (h : x ^ n = 0) : x = 0 :=
classical.by_contradiction $ λ hx, zpow_ne_zero_of_ne_zero hx n h

lemma zpow_eq_zero_iff {a : G₀} {n : ℤ} (hn : 0 < n) :
  a ^ n = 0 ↔ a = 0 :=
begin
  refine ⟨zpow_eq_zero, _⟩,
  rintros rfl,
  exact zero_zpow _ hn.ne'
end

lemma zpow_ne_zero {x : G₀} (n : ℤ) : x ≠ 0 → x ^ n ≠ 0 :=
mt zpow_eq_zero

theorem zpow_neg_mul_zpow_self (n : ℤ) {x : G₀} (h : x ≠ 0) :
  x ^ (-n) * x ^ n = 1 :=
begin
  rw [zpow_neg],
  exact inv_mul_cancel (zpow_ne_zero n h)
end

end zpow

section
variables {G₀ : Type*} [comm_group_with_zero G₀]

lemma div_sq_cancel (a b : G₀) : a ^ 2 * b / a = a * b :=
begin
  by_cases ha : a = 0,
  { simp [ha] },
  rw [sq, mul_assoc, mul_div_cancel_left _ ha]
end

end

/-- If a monoid homomorphism `f` between two `group_with_zero`s maps `0` to `0`, then it maps `x^n`,
`n : ℤ`, to `(f x)^n`. -/
lemma monoid_with_zero_hom.map_zpow {G₀ G₀' : Type*} [group_with_zero G₀] [group_with_zero G₀']
  (f : G₀ →*₀ G₀') (x : G₀) :
  ∀ n : ℤ, f (x ^ n) = f x ^ n
| (n : ℕ) := by { rw [zpow_coe_nat, zpow_coe_nat], exact f.to_monoid_hom.map_pow x n }
| -[1+n] := begin
    rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat],
    exact ((f.map_inv _).trans $ congr_arg _ $ f.to_monoid_hom.map_pow x _)
  end


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

Finite bags.
-/
import data.nat data.list.perm algebra.binary
open nat quot list subtype binary function eq.ops
open [decl] perm

variable {A : Type}

definition bag.setoid [instance] (A : Type) : setoid (list A) :=
setoid.mk (@perm A) (mk_equivalence (@perm A) (@perm.refl A) (@perm.symm A) (@perm.trans A))

definition bag (A : Type) : Type :=
quot (bag.setoid A)

namespace bag
definition of_list (l : list A) : bag A :=
⟦l⟧

definition empty : bag A :=
of_list nil

definition singleton (a : A) : bag A :=
of_list [a]

definition insert (a : A) (b : bag A) : bag A :=
quot.lift_on b (λ l, ⟦a::l⟧)
  (λ l₁ l₂ h, quot.sound (perm.skip a h))

lemma insert_empty_eq_singleton (a : A) : insert a empty = singleton a :=
rfl

definition insert.comm (a₁ a₂ : A) (b : bag A) : insert a₁ (insert a₂ b) = insert a₂ (insert a₁ b) :=
quot.induction_on b (λ l, quot.sound !perm.swap)

definition append (b₁ b₂ : bag A) : bag A :=
quot.lift_on₂ b₁ b₂ (λ l₁ l₂, ⟦l₁++l₂⟧)
  (λ l₁ l₂ l₃ l₄ h₁ h₂, quot.sound (perm_app h₁ h₂))

infix ++ := append

lemma append.comm (b₁ b₂ : bag A) : b₁ ++ b₂ = b₂ ++ b₁ :=
quot.induction_on₂ b₁ b₂ (λ l₁ l₂, quot.sound !perm_app_comm)

lemma append.assoc (b₁ b₂ b₃ : bag A) : (b₁ ++ b₂) ++ b₃ = b₁ ++ (b₂ ++ b₃) :=
quot.induction_on₃ b₁ b₂ b₃ (λ l₁ l₂ l₃, quot.sound (by rewrite list.append.assoc; apply perm.refl))

lemma append_empty_left (b : bag A) : empty ++ b = b :=
quot.induction_on b (λ l, quot.sound (by rewrite append_nil_left; apply perm.refl))

lemma append_empty_right (b : bag A) : b ++ empty = b :=
quot.induction_on b (λ l, quot.sound (by rewrite append_nil_right; apply perm.refl))

lemma append_insert_left (a : A) (b₁ b₂ : bag A) : insert a b₁ ++ b₂ = insert a (b₁ ++ b₂) :=
quot.induction_on₂ b₁ b₂ (λ l₁ l₂, quot.sound (by rewrite append_cons; apply perm.refl))

lemma append_insert_right (a : A) (b₁ b₂ : bag A) : b₁ ++ insert a b₂ = insert a (b₁ ++ b₂) :=
calc b₁ ++ insert a b₂  = insert a b₂ ++ b₁   : append.comm
                    ... = insert a (b₂ ++ b₁) : append_insert_left
                    ... = insert a (b₁ ++ b₂) : append.comm

protected lemma induction_on [recursor 3] {C : bag A → Prop} (b : bag A) (h₁ : C empty) (h₂ : ∀ a b, C b → C (insert a b)) : C b :=
quot.induction_on b (λ l, list.induction_on l h₁ (λ h t ih, h₂ h ⟦t⟧ ih))

section decidable_eq
variable [decA : decidable_eq A]
include decA
open decidable

definition has_decidable_eq [instance] (b₁ b₂ : bag A) : decidable (b₁ = b₂) :=
quot.rec_on_subsingleton₂ b₁ b₂ (λ l₁ l₂,
  match decidable_perm l₁ l₂ with
  | inl h := inl (quot.sound h)
  | inr h := inr (λ n, absurd (quot.exact n) h)
  end)
end decidable_eq

section count
variable [decA : decidable_eq A]
include decA

definition count (a : A) (b : bag A) : nat :=
quot.lift_on b (λ l, count a l)
  (λ l₁ l₂ h, count_eq_of_perm h a)

lemma count_empty (a : A) : count a empty = 0 :=
rfl

lemma count_insert (a : A) (b : bag A) : count a (insert a b) = succ (count a b) :=
quot.induction_on b (λ l, begin unfold [insert, count], rewrite count_cons_eq end)

lemma count_insert_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : count a₁ (insert a₂ b) = count a₁ b :=
quot.induction_on b (λ l, begin unfold [insert, count], rewrite (count_cons_of_ne h) end)

lemma count_singleton (a : A) : count a (singleton a) = 1 :=
begin rewrite [-insert_empty_eq_singleton, count_insert] end

lemma count_append (a : A) (b₁ b₂ : bag A) : count a (append b₁ b₂) = count a b₁ + count a b₂ :=
quot.induction_on₂ b₁ b₂ (λ l₁ l₂, begin unfold [append, count], rewrite list.count_append end)

open perm decidable
protected lemma ext {b₁ b₂ : bag A} : (∀ a, count a b₁ = count a b₂) → b₁ = b₂ :=
quot.induction_on₂ b₁ b₂ (λ l₁ l₂ (h : ∀ a, count a ⟦l₁⟧ = count a ⟦l₂⟧),
 have gen : ∀ (l₁ l₂ : list A), (∀ a, list.count a l₁ = list.count a l₂) → l₁ ~ l₂
 | []       []       h₁ := !perm.refl
 | []       (a₂::s₂) h₁ := have list.count a₂ [] = list.count a₂ (a₂::s₂), from h₁ a₂, by rewrite [count_nil at this, count_cons_eq at this]; contradiction
 | (a::s₁) s₂       h₁ :=
   have g₁ : list.count a (a::s₁) > 0, from count_gt_zero_of_mem !mem_cons,
   have list.count a (a::s₁) = list.count a s₂, from h₁ a,
   have list.count a s₂ > 0, by rewrite [-this]; exact g₁,
   have a ∈ s₂,                from mem_of_count_gt_zero this,
   have ∃ l r, s₂ = l++(a::r), from mem_split this,
   obtain l r (e₁ : s₂ = l++(a::r)), from this,
   have ∀ a, list.count a s₁ = list.count a (l++r), from
     take a₁,
     have e₂ : list.count a₁ (a::s₁) = list.count a₁ (l++(a::r)), by rewrite -e₁; exact h₁ a₁,
     by_cases
       (suppose a₁ = a, begin
          rewrite [-this at e₂, list.count_append at e₂, *count_cons_eq at e₂, add_succ at e₂],
          injection e₂ with e₃, rewrite e₃,
          rewrite list.count_append
        end)
       (suppose a₁ ≠ a,
        by rewrite [list.count_append at e₂, *count_cons_of_ne this at e₂, e₂, list.count_append]),
   have ih : s₁ ~ l++r,             from gen s₁ (l++r) this,
   calc a::s₁ ~ a::(l++r) : perm.skip a ih
         ...  ~ l++(a::r) : perm_middle
         ...  = s₂        : e₁,
 quot.sound (gen l₁ l₂ h))

definition insert.inj {a : A} {b₁ b₂ : bag A} : insert a b₁ = insert a b₂ → b₁ = b₂ :=
assume h, bag.ext (take x,
  have e : count x (insert a b₁) = count x (insert a b₂), by rewrite h,
  by_cases
    (suppose x = a, begin subst x, rewrite [*count_insert at e], injection e, assumption end)
    (suppose x ≠ a, begin rewrite [*count_insert_of_ne this at e], assumption end))
end count

section extract
open decidable
variable [decA : decidable_eq A]
include decA

definition extract (a : A) (b : bag A) : bag A :=
quot.lift_on b (λ l, ⟦filter (λ c, c ≠ a) l⟧)
  (λ l₁ l₂ h, quot.sound (perm_filter h))

lemma extract_singleton (a : A) : extract a (singleton a) = empty :=
begin unfold [extract, singleton, of_list, filter], rewrite [if_neg (λ h : a ≠ a, absurd rfl h)] end

lemma extract_insert (a : A) (b : bag A) : extract a (insert a b) = extract a b :=
quot.induction_on b (λ l, begin
  unfold [insert, extract],
  rewrite [@filter_cons_of_neg _ (λ c, c ≠ a) _ _ l (not_not_intro (eq.refl a))]
end)

lemma extract_insert_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : extract a₁ (insert a₂ b) = insert a₂ (extract a₁ b) :=
quot.induction_on b (λ l, begin
  unfold [insert, extract],
  rewrite [@filter_cons_of_pos _ (λ c, c ≠ a₁) _ _ l (ne.symm h)]
end)

lemma count_extract (a : A) (b : bag A) : count a (extract a b) = 0 :=
bag.induction_on b rfl
  (λ c b ih, by_cases
     (suppose a = c, begin subst c, rewrite [extract_insert, ih] end)
     (suppose a ≠ c, begin rewrite [extract_insert_of_ne this, count_insert_of_ne this, ih] end))

lemma count_extract_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : count a₁ (extract a₂ b) = count a₁ b :=
bag.induction_on b rfl
  (take x b ih, by_cases
    (suppose x = a₁, begin subst x, rewrite [extract_insert_of_ne (ne.symm h), *count_insert, ih] end)
    (suppose x ≠ a₁, by_cases
      (suppose x = a₂, begin subst x, rewrite [extract_insert, ih, count_insert_of_ne h] end)
      (suppose x ≠ a₂, begin
        rewrite [count_insert_of_ne (ne.symm `x ≠ a₁`), extract_insert_of_ne (ne.symm this)],
        rewrite [count_insert_of_ne (ne.symm `x ≠ a₁`), ih]
       end)))
end extract

section erase
variable [decA : decidable_eq A]
include decA

definition erase (a : A) (b : bag A) : bag A :=
quot.lift_on b (λ l, ⟦erase a l⟧)
  (λ l₁ l₂ h, quot.sound (erase_perm_erase_of_perm _ h))

lemma erase_empty (a : A) : erase a empty = empty :=
rfl

lemma erase_insert (a : A) (b : bag A) : erase a (insert a b) = b :=
quot.induction_on b (λ l, quot.sound (by rewrite erase_cons_head; apply perm.refl))

lemma erase_insert_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : erase a₁ (insert a₂ b) = insert a₂ (erase a₁ b) :=
quot.induction_on b (λ l, quot.sound (by rewrite (erase_cons_tail _ h); apply perm.refl))

end erase

section member
variable [decA : decidable_eq A]
include decA

definition mem (a : A) (b : bag A) := count a b > 0
infix ∈ := mem

lemma mem_def (a : A) (b : bag A) : (a ∈ b) = (count a b > 0) :=
rfl

lemma mem_insert (a : A) (b : bag A) : a ∈ insert a b :=
begin unfold mem, rewrite count_insert, exact dec_trivial end

lemma mem_of_list_iff_mem (a : A) (l : list A) : a ∈ of_list l ↔ a ∈ l :=
iff.intro !mem_of_count_gt_zero !count_gt_zero_of_mem

lemma count_of_list_eq_count (a : A) (l : list A) : count a (of_list l) = list.count a l :=
rfl
end member

section union_inter
variable [decA : decidable_eq A]
include decA
open perm decidable

private definition union_list (l₁ l₂ : list A) :=
erase_dup (l₁ ++ l₂)

private lemma perm_union_list {l₁ l₂ l₃ l₄ : list A} (h₁ : l₁ ~ l₃) (h₂ : l₂ ~ l₄) : union_list l₁ l₂ ~ union_list l₃ l₄ :=
perm_erase_dup_of_perm (perm_app h₁ h₂)

private lemma nodup_union_list (l₁ l₂ : list A) : nodup (union_list l₁ l₂) :=
!nodup_erase_dup

private definition not_mem_of_not_mem_union_list_left {a : A} {l₁ l₂ : list A} (h : a ∉ union_list l₁ l₂) : a ∉ l₁ :=
suppose a ∈ l₁,
have a ∈ l₁ ++ l₂, from mem_append_left _ this,
have a ∈ erase_dup (l₁ ++ l₂), from mem_erase_dup this,
absurd this h

private definition not_mem_of_not_mem_union_list_right {a : A} {l₁ l₂ : list A} (h : a ∉ union_list l₁ l₂) : a ∉ l₂ :=
suppose a ∈ l₂,
have a ∈ l₁ ++ l₂, from mem_append_right _ this,
have a ∈ erase_dup (l₁ ++ l₂), from mem_erase_dup this,
absurd this h

private definition gen : nat → A → list A
| 0     a := nil
| (n+1) a := a :: gen n a

private lemma not_mem_gen_of_ne {a b : A} (h : a ≠ b) : ∀ n, a ∉ gen n b
| 0     := !not_mem_nil
| (n+1) := not_mem_cons_of_ne_of_not_mem h (not_mem_gen_of_ne n)

private lemma count_gen : ∀ (a : A) (n : nat), list.count a (gen n a) = n
| a 0     := rfl
| a (n+1) := begin unfold gen, rewrite [count_cons_eq, count_gen] end

private lemma count_gen_eq_zero_of_ne {a b : A} (h : a ≠ b) : ∀ n, list.count a (gen n b) = 0
| 0     := rfl
| (n+1) := begin unfold gen, rewrite [count_cons_of_ne h, count_gen_eq_zero_of_ne] end

private definition max_count (l₁ l₂ : list A) : list A → list A
| []     := []
| (a::l) := if list.count a l₁ ≥ list.count a l₂ then gen (list.count a l₁) a ++ max_count l else gen (list.count a l₂) a ++ max_count l

private definition min_count (l₁ l₂ : list A) : list A → list A
| []     := []
| (a::l) := if list.count a l₁ ≤ list.count a l₂ then gen (list.count a l₁) a ++ min_count l else gen (list.count a l₂) a ++ min_count l

private lemma not_mem_max_count_of_not_mem (l₁ l₂ : list A) : ∀ {a l}, a ∉ l → a ∉ max_count l₁ l₂ l
| a []     h := !not_mem_nil
| a (b::l) h :=
  have ih : a ∉ max_count l₁ l₂ l, from not_mem_max_count_of_not_mem (not_mem_of_not_mem_cons h),
  have a ≠ b, from ne_of_not_mem_cons h,
  by_cases
    (suppose list.count b l₁ ≥ list.count b l₂, begin
      unfold max_count, rewrite [if_pos this],
      exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih
     end)
    (suppose ¬ list.count b l₁ ≥ list.count b l₂, begin
      unfold max_count, rewrite [if_neg this],
      exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih
     end)

private lemma max_count_eq (l₁ l₂ : list A) : ∀ {a : A} {l : list A}, a ∈ l → nodup l → list.count a (max_count l₁ l₂ l) = max (list.count a l₁) (list.count a l₂)
| a []     h₁ h₂ := absurd h₁ !not_mem_nil
| a (b::l) h₁ h₂ :=
  have nodup l, from nodup_of_nodup_cons h₂,
  have b ∉ l,   from not_mem_of_nodup_cons h₂,
  or.elim (eq_or_mem_of_mem_cons h₁)
  (suppose a = b,
    have a ∉ l, by rewrite this; assumption,
    have a ∉ max_count l₁ l₂ l, from not_mem_max_count_of_not_mem l₁ l₂ this,
    by_cases
    (suppose i : list.count a l₁ ≥ list.count a l₂, begin
       unfold max_count, subst b,
       rewrite [if_pos i, list.count_append, count_gen, max_eq_left i, count_eq_zero_of_not_mem `a ∉ max_count l₁ l₂ l`]
     end)
    (suppose i : ¬ list.count a l₁ ≥ list.count a l₂, begin
       unfold max_count, subst b,
       rewrite [if_neg i, list.count_append, count_gen, max_eq_right_of_lt (lt_of_not_ge i), count_eq_zero_of_not_mem `a ∉ max_count l₁ l₂ l`]
     end))
  (suppose a ∈ l,
    have a ≠ b, from suppose a = b, begin subst b, contradiction end,
    have ih : list.count a (max_count l₁ l₂ l) = max (list.count a l₁) (list.count a l₂), from
       max_count_eq `a ∈ l` `nodup l`,
    by_cases
    (suppose i : list.count b l₁ ≥ list.count b l₂, begin
       unfold max_count,
       rewrite [if_pos i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add]
     end)
    (suppose i : ¬ list.count b l₁ ≥ list.count b l₂, begin
       unfold max_count,
       rewrite [if_neg i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add]
     end))

private lemma not_mem_min_count_of_not_mem (l₁ l₂ : list A) : ∀ {a l}, a ∉ l → a ∉ min_count l₁ l₂ l
| a []     h := !not_mem_nil
| a (b::l) h :=
  have ih : a ∉ min_count l₁ l₂ l, from not_mem_min_count_of_not_mem (not_mem_of_not_mem_cons h),
  have a ≠ b, from ne_of_not_mem_cons h,
  by_cases
    (suppose list.count b l₁ ≤ list.count b l₂, begin
      unfold min_count, rewrite [if_pos this],
      exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih
     end)
    (suppose ¬ list.count b l₁ ≤ list.count b l₂, begin
      unfold min_count, rewrite [if_neg this],
      exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih
     end)

private lemma min_count_eq (l₁ l₂ : list A) : ∀ {a : A} {l : list A}, a ∈ l → nodup l → list.count a (min_count l₁ l₂ l) = min (list.count a l₁) (list.count a l₂)
| a []     h₁ h₂ := absurd h₁ !not_mem_nil
| a (b::l) h₁ h₂ :=
  have nodup l, from nodup_of_nodup_cons h₂,
  have b ∉ l,   from not_mem_of_nodup_cons h₂,
  or.elim (eq_or_mem_of_mem_cons h₁)
  (suppose a = b,
    have a ∉ l, by rewrite this; assumption,
    have a ∉ min_count l₁ l₂ l, from not_mem_min_count_of_not_mem l₁ l₂ this,
    by_cases
    (suppose i : list.count a l₁ ≤ list.count a l₂, begin
       unfold min_count, subst b,
       rewrite [if_pos i, list.count_append, count_gen, min_eq_left i, count_eq_zero_of_not_mem `a ∉ min_count l₁ l₂ l`]
     end)
    (suppose i : ¬ list.count a l₁ ≤ list.count a l₂, begin
       unfold min_count, subst b,
       rewrite [if_neg i, list.count_append, count_gen, min_eq_right (le_of_lt (lt_of_not_ge i)), count_eq_zero_of_not_mem `a ∉ min_count l₁ l₂ l`]
     end))
  (suppose a ∈ l,
    have a ≠ b, from suppose a = b, by subst b; contradiction,
    have ih : list.count a (min_count l₁ l₂ l) = min (list.count a l₁) (list.count a l₂), from min_count_eq `a ∈ l` `nodup l`,
    by_cases
    (suppose i : list.count b l₁ ≤ list.count b l₂, begin
       unfold min_count,
       rewrite [if_pos i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add]
     end)
    (suppose i : ¬ list.count b l₁ ≤ list.count b l₂, begin
       unfold min_count,
       rewrite [if_neg i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add]
     end))

private lemma perm_max_count_left {l₁ l₂ l₃ l₄ : list A} (h₁ : l₁ ~ l₃) (h₂ : l₂ ~ l₄) : ∀ l, max_count l₁ l₂ l ~ max_count l₃ l₄ l
| []     := by esimp
| (a::l) :=
  have e₁ : list.count a l₁ = list.count a l₃, from count_eq_of_perm h₁ a,
  have e₂ : list.count a l₂ = list.count a l₄, from count_eq_of_perm h₂ a,
  by_cases
    (suppose list.count a l₁ ≥ list.count a l₂,
     begin unfold max_count, rewrite [-e₁, -e₂, *if_pos this], exact perm_app !perm.refl !perm_max_count_left end)
    (suppose ¬ list.count a l₁ ≥ list.count a l₂,
     begin unfold max_count, rewrite [-e₁, -e₂, *if_neg this], exact perm_app !perm.refl !perm_max_count_left end)

private lemma perm_app_left_comm (l₁ l₂ l₃ : list A) : l₁ ++ (l₂ ++ l₃) ~ l₂ ++ (l₁ ++ l₃) :=
calc l₁ ++ (l₂ ++ l₃) = (l₁ ++ l₂) ++ l₃ : list.append.assoc
                ...   ~ (l₂ ++ l₁) ++ l₃ : perm_app !perm_app_comm !perm.refl
                ...   = l₂ ++ (l₁ ++ l₃) : list.append.assoc

private lemma perm_max_count_right {l r : list A} (h : l ~ r) : ∀ l₁ l₂, max_count l₁ l₂ l ~ max_count l₁ l₂ r :=
perm.induction_on h
  (λ l₁ l₂, !perm.refl)
  (λ x s₁ s₂ p ih l₁ l₂, by_cases
    (suppose i : list.count x l₁ ≥ list.count x l₂,
      begin unfold max_count, rewrite [*if_pos i], exact perm_app !perm.refl !ih end)
    (suppose i : ¬ list.count x l₁ ≥ list.count x l₂,
      begin unfold max_count, rewrite [*if_neg i], exact perm_app !perm.refl !ih end))
  (λ x y l l₁ l₂, by_cases
    (suppose i₁ : list.count x l₁ ≥ list.count x l₂, by_cases
      (suppose i₂ : list.count y l₁ ≥ list.count y l₂,
        begin unfold max_count, unfold max_count, rewrite [*if_pos i₁, *if_pos i₂], apply perm_app_left_comm end)
      (suppose i₂ : ¬ list.count y l₁ ≥ list.count y l₂,
        begin unfold max_count, unfold max_count, rewrite [*if_pos i₁, *if_neg i₂], apply perm_app_left_comm end))
    (suppose i₁ : ¬ list.count x l₁ ≥ list.count x l₂, by_cases
      (suppose i₂ : list.count y l₁ ≥ list.count y l₂,
        begin unfold max_count, unfold max_count, rewrite [*if_neg i₁, *if_pos i₂], apply perm_app_left_comm end)
      (suppose i₂ : ¬ list.count y l₁ ≥ list.count y l₂,
        begin unfold max_count, unfold max_count, rewrite [*if_neg i₁, *if_neg i₂], apply perm_app_left_comm end)))
  (λ s₁ s₂ s₃ p₁ p₂ ih₁ ih₂ l₁ l₂, perm.trans (ih₁ l₁ l₂) (ih₂ l₁ l₂))

private lemma perm_max_count {l₁ l₂ l₃ r₁ r₂ r₃ : list A} (p₁ : l₁ ~ r₁) (p₂ : l₂ ~ r₂) (p₃ : l₃ ~ r₃) : max_count l₁ l₂ l₃ ~ max_count r₁ r₂ r₃ :=
calc max_count l₁ l₂ l₃ ~ max_count r₁ r₂ l₃ : perm_max_count_left p₁ p₂
                    ... ~ max_count r₁ r₂ r₃ : perm_max_count_right p₃

private lemma perm_min_count_left {l₁ l₂ l₃ l₄ : list A} (h₁ : l₁ ~ l₃) (h₂ : l₂ ~ l₄) : ∀ l, min_count l₁ l₂ l ~ min_count l₃ l₄ l
| []     := by esimp
| (a::l) :=
  have e₁ : list.count a l₁ = list.count a l₃, from count_eq_of_perm h₁ a,
  have e₂ : list.count a l₂ = list.count a l₄, from count_eq_of_perm h₂ a,
  by_cases
    (suppose list.count a l₁ ≤ list.count a l₂,
     begin unfold min_count, rewrite [-e₁, -e₂, *if_pos this], exact perm_app !perm.refl !perm_min_count_left end)
    (suppose ¬ list.count a l₁ ≤ list.count a l₂,
     begin unfold min_count, rewrite [-e₁, -e₂, *if_neg this], exact perm_app !perm.refl !perm_min_count_left end)

private lemma perm_min_count_right {l r : list A} (h : l ~ r) : ∀ l₁ l₂, min_count l₁ l₂ l ~ min_count l₁ l₂ r :=
perm.induction_on h
  (λ l₁ l₂, !perm.refl)
  (λ x s₁ s₂ p ih l₁ l₂, by_cases
    (suppose i : list.count x l₁ ≤ list.count x l₂,
      begin unfold min_count, rewrite [*if_pos i], exact perm_app !perm.refl !ih end)
    (suppose i : ¬ list.count x l₁ ≤ list.count x l₂,
      begin unfold min_count, rewrite [*if_neg i], exact perm_app !perm.refl !ih end))
  (λ x y l l₁ l₂, by_cases
    (suppose i₁ : list.count x l₁ ≤ list.count x l₂, by_cases
      (suppose i₂ : list.count y l₁ ≤ list.count y l₂,
        begin unfold min_count, unfold min_count, rewrite [*if_pos i₁, *if_pos i₂], apply perm_app_left_comm end)
      (suppose i₂ : ¬ list.count y l₁ ≤ list.count y l₂,
        begin unfold min_count, unfold min_count, rewrite [*if_pos i₁, *if_neg i₂], apply perm_app_left_comm end))
    (suppose i₁ : ¬ list.count x l₁ ≤ list.count x l₂, by_cases
      (suppose i₂ : list.count y l₁ ≤ list.count y l₂,
        begin unfold min_count, unfold min_count, rewrite [*if_neg i₁, *if_pos i₂], apply perm_app_left_comm end)
      (suppose i₂ : ¬ list.count y l₁ ≤ list.count y l₂,
        begin unfold min_count, unfold min_count, rewrite [*if_neg i₁, *if_neg i₂], apply perm_app_left_comm end)))
  (λ s₁ s₂ s₃ p₁ p₂ ih₁ ih₂ l₁ l₂, perm.trans (ih₁ l₁ l₂) (ih₂ l₁ l₂))

private lemma perm_min_count {l₁ l₂ l₃ r₁ r₂ r₃ : list A} (p₁ : l₁ ~ r₁) (p₂ : l₂ ~ r₂) (p₃ : l₃ ~ r₃) : min_count l₁ l₂ l₃ ~ min_count r₁ r₂ r₃ :=
calc min_count l₁ l₂ l₃ ~ min_count r₁ r₂ l₃ : perm_min_count_left p₁ p₂
                    ... ~ min_count r₁ r₂ r₃ : perm_min_count_right p₃

definition union (b₁ b₂ : bag A) : bag A :=
quot.lift_on₂ b₁ b₂ (λ l₁ l₂, ⟦max_count l₁ l₂ (union_list l₁ l₂)⟧)
  (λ l₁ l₂ l₃ l₄ p₁ p₂, quot.sound (perm_max_count p₁ p₂ (perm_union_list p₁ p₂)))
infix ∪ := union

definition inter (b₁ b₂ : bag A) : bag A :=
quot.lift_on₂ b₁ b₂ (λ l₁ l₂, ⟦min_count l₁ l₂ (union_list l₁ l₂)⟧)
  (λ l₁ l₂ l₃ l₄ p₁ p₂, quot.sound (perm_min_count p₁ p₂ (perm_union_list p₁ p₂)))
infix ∩ := inter

lemma count_union (a : A) (b₁ b₂ : bag A) : count a (b₁ ∪ b₂) = max (count a b₁) (count a b₂) :=
quot.induction_on₂ b₁ b₂ (λ l₁ l₂, by_cases
  (suppose a ∈ union_list l₁ l₂, !max_count_eq this !nodup_union_list)
  (suppose ¬ a ∈ union_list l₁ l₂,
    have ¬ a ∈ l₁, from not_mem_of_not_mem_union_list_left `¬ a ∈ union_list l₁ l₂`,
    have ¬ a ∈ l₂, from not_mem_of_not_mem_union_list_right `¬ a ∈ union_list l₁ l₂`,
    have n : ¬ a ∈ max_count l₁ l₂ (union_list l₁ l₂), from not_mem_max_count_of_not_mem l₁ l₂ `¬ a ∈ union_list l₁ l₂`,
    begin
      unfold [union, count],
      rewrite [count_eq_zero_of_not_mem `¬ a ∈ l₁`, count_eq_zero_of_not_mem `¬ a ∈ l₂`, max_self],
      rewrite [count_eq_zero_of_not_mem n]
    end))

lemma count_inter (a : A) (b₁ b₂ : bag A) : count a (b₁ ∩ b₂) = min (count a b₁) (count a b₂) :=
quot.induction_on₂ b₁ b₂ (λ l₁ l₂, by_cases
  (suppose a ∈ union_list l₁ l₂, !min_count_eq this !nodup_union_list)
  (suppose ¬ a ∈ union_list l₁ l₂,
    have ¬ a ∈ l₁, from not_mem_of_not_mem_union_list_left `¬ a ∈ union_list l₁ l₂`,
    have ¬ a ∈ l₂, from not_mem_of_not_mem_union_list_right `¬ a ∈ union_list l₁ l₂`,
    have n : ¬ a ∈ min_count l₁ l₂ (union_list l₁ l₂), from not_mem_min_count_of_not_mem l₁ l₂ `¬ a ∈ union_list l₁ l₂`,
    begin
      unfold [inter, count],
      rewrite [count_eq_zero_of_not_mem `¬ a ∈ l₁`, count_eq_zero_of_not_mem `¬ a ∈ l₂`, min_self],
      rewrite [count_eq_zero_of_not_mem n]
    end))

lemma union_comm (b₁ b₂ : bag A) : b₁ ∪ b₂ = b₂ ∪ b₁ :=
bag.ext (λ a, by rewrite [*count_union, max.comm])

lemma union_assoc (b₁ b₂ b₃ : bag A) : (b₁ ∪ b₂) ∪ b₃ = b₁ ∪ (b₂ ∪ b₃) :=
bag.ext (λ a, by rewrite [*count_union, max.assoc])

theorem union_left_comm (s₁ s₂ s₃ : bag A) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) :=
!left_comm union_comm union_assoc s₁ s₂ s₃

lemma union_self (b : bag A) : b ∪ b = b :=
bag.ext (λ a, by rewrite [*count_union, max_self])

lemma union_empty (b : bag A) : b ∪ empty = b :=
bag.ext (λ a, by rewrite [*count_union, count_empty, max_zero])

lemma empty_union (b : bag A) : empty ∪ b = b :=
calc empty ∪ b = b ∪ empty : union_comm
           ... = b         : union_empty

lemma inter_comm (b₁ b₂ : bag A) : b₁ ∩ b₂ = b₂ ∩ b₁ :=
bag.ext (λ a, by rewrite [*count_inter, min.comm])

lemma inter_assoc (b₁ b₂ b₃ : bag A) : (b₁ ∩ b₂) ∩ b₃ = b₁ ∩ (b₂ ∩ b₃) :=
bag.ext (λ a, by rewrite [*count_inter, min.assoc])

theorem inter_left_comm (s₁ s₂ s₃ : bag A) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) :=
!left_comm inter_comm inter_assoc s₁ s₂ s₃

lemma inter_self (b : bag A) : b ∩ b = b :=
bag.ext (λ a, by rewrite [*count_inter, min_self])

lemma inter_empty (b : bag A) : b ∩ empty = empty :=
bag.ext (λ a, by rewrite [*count_inter, count_empty, min_zero])

lemma empty_inter (b : bag A) : empty ∩ b = empty :=
calc empty ∩ b = b ∩ empty : inter_comm
           ... = empty     : inter_empty

lemma append_union_inter (b₁ b₂ : bag A) : (b₁ ∪ b₂) ++ (b₁ ∩ b₂) = b₁ ++ b₂ :=
bag.ext (λ a, begin
  rewrite [*count_append, count_inter, count_union],
  apply (or.elim (lt_or_ge (count a b₁) (count a b₂))),
  { intro H, rewrite [min_eq_left_of_lt H, max_eq_right_of_lt H, add.comm] },
  { intro H, rewrite [min_eq_right H, max_eq_left H, add.comm] }
end)

lemma inter_left_distrib (b₁ b₂ b₃ : bag A) : b₁ ∩ (b₂ ∪ b₃) = (b₁ ∩ b₂) ∪ (b₁ ∩ b₃) :=
bag.ext (λ a, begin
  rewrite [*count_inter, *count_union, *count_inter],
  apply (@by_cases (count a b₁ ≤ count a b₂)),
  { intro H₁₂, apply (@by_cases (count a b₂ ≤ count a b₃)),
    { intro H₂₃,
      have H₁₃ : count a b₁ ≤ count a b₃, from le.trans H₁₂ H₂₃,
      rewrite [max_eq_right H₂₃, min_eq_left H₁₂, min_eq_left H₁₃, max_self]},
    { intro H₂₃,
      rewrite [min_eq_left H₁₂, max.comm, max_eq_right_of_lt (lt_of_not_ge H₂₃) ],
      apply (@by_cases (count a b₁ ≤ count a b₃)),
      { intro H₁₃, rewrite [min_eq_left H₁₃, max_self, min_eq_left H₁₂] },
      { intro H₁₃,
        rewrite [min.comm (count a b₁) (count a b₃), min_eq_left_of_lt (lt_of_not_ge H₁₃),
                 min_eq_left H₁₂, max.comm, max_eq_right_of_lt (lt_of_not_ge H₁₃)]}}},
  { intro H₁₂, apply (@by_cases (count a b₂ ≤ count a b₃)),
    { intro H₂₃,
      rewrite [max_eq_right H₂₃],
      apply (@by_cases (count a b₁ ≤ count a b₃)),
      { intro H₁₃, rewrite [min_eq_left H₁₃, min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₂), max_eq_right_of_lt (lt_of_not_ge H₁₂)] },
      { intro H₁₃, rewrite [min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₃), min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₂), max_eq_right H₂₃] } },
    { intro H₂₃,
      have H₁₃ : count a b₁ > count a b₃, from lt.trans (lt_of_not_ge H₂₃) (lt_of_not_ge H₁₂),
      rewrite [max.comm, max_eq_right_of_lt (lt_of_not_ge H₂₃), min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₂)],
      rewrite [min.comm, min_eq_left_of_lt H₁₃, max.comm, max_eq_right_of_lt (lt_of_not_ge H₂₃)] } }
end)

lemma inter_right_distrib (b₁ b₂ b₃ : bag A) : (b₁ ∪ b₂) ∩ b₃ = (b₁ ∩ b₃) ∪ (b₂ ∩ b₃) :=
calc (b₁ ∪ b₂) ∩ b₃ = b₃ ∩ (b₁ ∪ b₂)        : inter_comm
              ...   = (b₃ ∩ b₁) ∪ (b₃ ∩ b₂) : inter_left_distrib
              ...   = (b₁ ∩ b₃) ∪ (b₃ ∩ b₂) : inter_comm
              ...   = (b₁ ∩ b₃) ∪ (b₂ ∩ b₃) : inter_comm
end union_inter

section subbag
variable [decA : decidable_eq A]
include decA

definition subbag (b₁ b₂ : bag A) := ∀ a, count a b₁ ≤ count a b₂

infix ⊆ := subbag

lemma subbag.refl (b : bag A) : b ⊆ b :=
take a, !le.refl

lemma subbag.trans {b₁ b₂ b₃ : bag A} : b₁ ⊆ b₂ → b₂ ⊆ b₃ → b₁ ⊆ b₃ :=
assume h₁ h₂, take a, le.trans (h₁ a) (h₂ a)

lemma subbag.antisymm {b₁ b₂ : bag A} : b₁ ⊆ b₂ → b₂ ⊆ b₁ → b₁ = b₂ :=
assume h₁ h₂, bag.ext (take a, le.antisymm (h₁ a) (h₂ a))

lemma count_le_of_subbag {b₁ b₂ : bag A} : b₁ ⊆ b₂ → ∀ a, count a b₁ ≤ count a b₂ :=
assume h, h

lemma subbag.intro {b₁ b₂ : bag A} : (∀ a, count a b₁ ≤ count a b₂) → b₁ ⊆ b₂ :=
assume h, h

lemma empty_subbag (b : bag A) : empty ⊆ b :=
subbag.intro (take a, !zero_le)

lemma eq_empty_of_subbag_empty {b : bag A} : b ⊆ empty → b = empty :=
assume h, subbag.antisymm h (empty_subbag b)

lemma union_subbag_of_subbag_of_subbag {b₁ b₂ b₃ : bag A} : b₁ ⊆ b₃ → b₂ ⊆ b₃ → b₁ ∪ b₂ ⊆ b₃ :=
assume h₁ h₂, subbag.intro (λ a, calc
  count a (b₁ ∪ b₂) = max (count a b₁) (count a b₂) : by rewrite count_union
                ... ≤ count a b₃                    : max_le (h₁ a) (h₂ a))

lemma subbag_inter_of_subbag_of_subbag {b₁ b₂ b₃ : bag A} : b₁ ⊆ b₂ → b₁ ⊆ b₃ → b₁ ⊆ b₂ ∩ b₃ :=
assume h₁ h₂, subbag.intro (λ a, calc
  count a b₁ ≤ min (count a b₂) (count a b₃) : le_min (h₁ a) (h₂ a)
         ... = count a (b₂ ∩ b₃)             : by rewrite count_inter)

lemma subbag_union_left (b₁ b₂ : bag A) : b₁ ⊆ b₁ ∪ b₂ :=
subbag.intro (take a, by rewrite [count_union]; apply le_max_left)

lemma subbag_union_right (b₁ b₂ : bag A) : b₂ ⊆ b₁ ∪ b₂ :=
subbag.intro (take a, by rewrite [count_union]; apply le_max_right)

lemma inter_subbag_left (b₁ b₂ : bag A) : b₁ ∩ b₂ ⊆ b₁ :=
subbag.intro (take a, by rewrite [count_inter]; apply min_le_left)

lemma inter_subbag_right (b₁ b₂ : bag A) : b₁ ∩ b₂ ⊆ b₂ :=
subbag.intro (take a, by rewrite [count_inter]; apply min_le_right)

lemma subbag_append_left (b₁ b₂ : bag A) : b₁ ⊆ b₁ ++ b₂ :=
subbag.intro (take a, by rewrite [count_append]; apply le_add_right)

lemma subbag_append_right (b₁ b₂ : bag A) : b₂ ⊆ b₁ ++ b₂ :=
subbag.intro (take a, by rewrite [count_append]; apply le_add_left)

lemma inter_subbag_union (b₁ b₂ : bag A) : b₁ ∩ b₂ ⊆ b₁ ∪ b₂ :=
subbag.trans (inter_subbag_left b₁ b₂) (subbag_union_left b₁ b₂)

open decidable

lemma union_subbag_append (b₁ b₂ : bag A) : b₁ ∪ b₂ ⊆ b₁ ++ b₂ :=
subbag.intro (take a, begin
  rewrite [count_append, count_union],
  exact (or.elim !lt_or_ge)
   (suppose count a b₁ < count a b₂,   by rewrite [max_eq_right_of_lt this]; apply le_add_left)
   (suppose count a b₁ ≥ count a b₂, by rewrite [max_eq_left this]; apply le_add_right)
end)

lemma subbag_insert (a : A) (b : bag A) : b ⊆ insert a b :=
subbag.intro (take x, by_cases
  (suppose x = a, by rewrite [this, count_insert]; apply le_succ)
  (suppose x ≠ a, by rewrite [count_insert_of_ne this]))

lemma mem_of_subbag_of_mem {a : A} {b₁ b₂ : bag A} : b₁ ⊆ b₂ → a ∈ b₁ → a ∈ b₂ :=
assume h₁ h₂,
have count a b₁ ≤ count a b₂, from count_le_of_subbag h₁ a,
have count a b₁ > 0,          from h₂,
show count a b₂ > 0,          from lt_of_lt_of_le `0 < count a b₁` `count a b₁ ≤ count a b₂`

lemma extract_subbag (a : A) (b : bag A) : extract a b ⊆ b :=
subbag.intro (take x, by_cases
  (suppose x = a, by rewrite [this, count_extract]; apply zero_le)
  (suppose x ≠ a, by rewrite [count_extract_of_ne this]))

open bool

private definition subcount : list A → list A → bool
| []      l₂ := tt
| (a::l₁) l₂ := if list.count a (a::l₁) ≤ list.count a l₂ then subcount l₁ l₂ else ff

private lemma all_of_subcount_eq_tt : ∀ {l₁ l₂ : list A}, subcount l₁ l₂ = tt → ∀ a, list.count a l₁ ≤ list.count a l₂
| []      l₂ h := take x, !zero_le
| (a::l₁) l₂ h := take x,
  have subcount l₁ l₂ = tt, from by_contradiction (suppose subcount l₁ l₂ ≠ tt,
    have subcount l₁ l₂ = ff, from eq_ff_of_ne_tt this,
    begin unfold subcount at h, rewrite [this at h, if_t_t at h], contradiction end),
  have ih : ∀ a, list.count a l₁ ≤ list.count a l₂, from all_of_subcount_eq_tt this,
  have i  : list.count a (a::l₁) ≤ list.count a l₂, from by_contradiction (suppose ¬ list.count a (a::l₁) ≤ list.count a l₂,
    begin unfold subcount at h, rewrite [if_neg this at h], contradiction end),
  by_cases
    (suppose x = a, by rewrite this; apply i)
    (suppose x ≠ a, by rewrite [list.count_cons_of_ne this]; apply ih)

private lemma ex_of_subcount_eq_ff : ∀ {l₁ l₂ : list A}, subcount l₁ l₂ = ff → ∃ a, ¬ list.count a l₁ ≤ list.count a l₂
| []     l₂ h := by contradiction
| (a::l₁) l₂ h := by_cases
  (suppose i : list.count a (a::l₁) ≤ list.count a l₂,
    have subcount l₁ l₂ = ff, from by_contradiction (suppose subcount l₁ l₂ ≠ ff,
      have subcount l₁ l₂ = tt, from eq_tt_of_ne_ff this,
      begin
        unfold subcount at h,
        rewrite [if_pos i at h, this at h],
        contradiction
      end),
    have ih : ∃ a, ¬ list.count a l₁ ≤ list.count a l₂, from ex_of_subcount_eq_ff this,
    obtain w hw, from ih, by_cases
     (suppose w = a, begin subst w, existsi a, rewrite list.count_cons_eq, apply not_lt_of_ge, apply le_of_lt (lt_of_not_ge hw) end)
     (suppose w ≠ a, exists.intro w (by rewrite (list.count_cons_of_ne `w ≠ a`); exact hw)))
  (suppose ¬ list.count a (a::l₁) ≤ list.count a l₂, exists.intro a this)

definition decidable_subbag [instance] (b₁ b₂ : bag A) : decidable (b₁ ⊆ b₂) :=
quot.rec_on_subsingleton₂ b₁ b₂ (λ l₁ l₂,
  match subcount l₁ l₂ with
  | tt := suppose subcount l₁ l₂ = tt, inl (all_of_subcount_eq_tt this)
  | ff := suppose subcount l₁ l₂ = ff, inr (suppose h : (∀ a, list.count a l₁ ≤ list.count a l₂),
            obtain w hw, from ex_of_subcount_eq_ff `subcount l₁ l₂ = ff`,
            absurd (h w) hw)
  end rfl)
end subbag
end bag