import category_theory.limits.shapes.pullbacks

/-!
Thanks to Markus Himmel for suggesting this question.
-/

open category_theory
open category_theory.limits

/-!
Let C be a category, X and Y be objects and f : X ⟶ Y be a morphism. Show that f is an epimorphism
if and only if the diagram

X --f--→ Y
|        |
f        𝟙
|        |
↓        ↓
Y --𝟙--→ Y

is a pushout.
-/

universes v u

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

def pushout_of_epi {X Y : C} (f : X ⟶ Y) [epi f] :
  is_colimit (pushout_cocone.mk (𝟙 Y) (𝟙 Y) rfl : pushout_cocone f f) :=
-- Hint: you can start a proof with `fapply pushout_cocone.is_colimit.mk`
-- to save a little bit of work over just building a `is_colimit` structure directly.
begin
  fapply pushout_cocone.is_colimit.mk,
  { intro s,
    apply s.ι.app walking_span.left, },
  { tidy, },
  { tidy, /- we clearly need to use that `f` is an epi here!-/ sorry },
  { tidy, }
end

theorem epi_of_pushout {X Y : C} (f : X ⟶ Y)
  (is_colim : is_colimit (pushout_cocone.mk (𝟙 Y) (𝟙 Y) rfl : pushout_cocone f f)) : epi f :=
{ left_cancellation := λ Z g h hf,
  begin
    let a := pushout_cocone.mk _ _ hf,
    have hg : is_colim.desc a = g, sorry,
    have hh : is_colim.desc a = h, sorry,
    rw [←hg, ←hh],
  end }


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Floris van Doorn
-/

import order.rel_iso.set
import order.well_founded

/-!
# Initial and principal segments

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

This file defines initial and principal segments.

## Main definitions

* `initial_seg r s`: type of order embeddings of `r` into `s` for which the range is an initial
  segment (i.e., if `b` belongs to the range, then any `b' < b` also belongs to the range).
  It is denoted by `r ≼i s`.
* `principal_seg r s`: Type of order embeddings of `r` into `s` for which the range is a principal
  segment, i.e., an interval of the form `(-∞, top)` for some element `top`. It is denoted by
  `r ≺i s`.

## Notations

These notations belong to the `initial_seg` locale.

* `r ≼i s`: the type of initial segment embeddings of `r` into `s`.
* `r ≺i s`: the type of principal segment embeddings of `r` into `s`.
-/

/-!
### Initial segments

Order embeddings whose range is an initial segment of `s` (i.e., if `b` belongs to the range, then
any `b' < b` also belongs to the range). The type of these embeddings from `r` to `s` is called
`initial_seg r s`, and denoted by `r ≼i s`.
-/

variables {α : Type*} {β : Type*} {γ : Type*}
  {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop}

open function

/-- If `r` is a relation on `α` and `s` in a relation on `β`, then `f : r ≼i s` is an order
embedding whose range is an initial segment. That is, whenever `b < f a` in `β` then `b` is in the
range of `f`. -/
structure initial_seg {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends r ↪r s :=
(init' : ∀ a b, s b (to_rel_embedding a) → ∃ a', to_rel_embedding a' = b)

localized "infix (name := initial_seg) ` ≼i `:25 := initial_seg" in initial_seg

namespace initial_seg

instance : has_coe (r ≼i s) (r ↪r s) := ⟨initial_seg.to_rel_embedding⟩

instance : embedding_like (r ≼i s) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' :=
    begin
      rintro ⟨f, hf⟩ ⟨g, hg⟩ h,
      congr' with x,
      exact congr_fun h x
    end,
  injective' := λ f, f.inj' }

@[ext] lemma ext {f g : r ≼i s} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

@[simp] theorem coe_fn_mk (f : r ↪r s) (o) :
  (@initial_seg.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_rel_embedding (f : r ≼i s) : (f.to_rel_embedding : α → β) = f := rfl

@[simp] theorem coe_coe_fn (f : r ≼i s) : ((f : r ↪r s) : α → β) = f := rfl

theorem init (f : r ≼i s) {a : α} {b : β} : s b (f a) → ∃ a', f a' = b :=
f.init' _ _

theorem map_rel_iff (f : r ≼i s) {a b : α} : s (f a) (f b) ↔ r a b := f.1.map_rel_iff

theorem init_iff (f : r ≼i s) {a : α} {b : β} : s b (f a) ↔ ∃ a', f a' = b ∧ r a' a :=
⟨λ h, let ⟨a', e⟩ := f.init h in ⟨a', e, f.map_rel_iff.1 (e.symm ▸ h)⟩,
 λ ⟨a', e, h⟩, e ▸ f.map_rel_iff.2 h⟩

/-- An order isomorphism is an initial segment -/
def of_iso (f : r ≃r s) : r ≼i s :=
⟨f, λ a b h, ⟨f.symm b, rel_iso.apply_symm_apply f _⟩⟩

/-- The identity function shows that `≼i` is reflexive -/
@[refl] protected def refl (r : α → α → Prop) : r ≼i r :=
⟨rel_embedding.refl _, λ a b h, ⟨_, rfl⟩⟩

instance (r : α → α → Prop) : inhabited (r ≼i r) := ⟨initial_seg.refl r⟩

/-- Composition of functions shows that `≼i` is transitive -/
@[trans] protected def trans (f : r ≼i s) (g : s ≼i t) : r ≼i t :=
⟨f.1.trans g.1, λ a c h, begin
  simp at h ⊢,
  rcases g.2 _ _ h with ⟨b, rfl⟩, have h := g.map_rel_iff.1 h,
  rcases f.2 _ _ h with ⟨a', rfl⟩, exact ⟨a', rfl⟩
end⟩

@[simp] theorem refl_apply (x : α) : initial_seg.refl r x = x := rfl

@[simp] theorem trans_apply (f : r ≼i s) (g : s ≼i t) (a : α) : (f.trans g) a = g (f a) := rfl

theorem unique_of_trichotomous_of_irrefl [is_trichotomous β s] [is_irrefl β s] :
  well_founded r → subsingleton (r ≼i s) | ⟨h⟩ :=
⟨λ f g, begin
  ext a,
  have := h a, induction this with a H IH,
  refine extensional_of_trichotomous_of_irrefl s (λ x, _),
  simp only [f.init_iff, g.init_iff],
  exact exists_congr (λ x, and_congr_left $ λ hx, IH _ hx ▸ iff.rfl)
end⟩

instance [is_well_order β s] : subsingleton (r ≼i s) :=
⟨λ a, @subsingleton.elim _ (unique_of_trichotomous_of_irrefl
  (@rel_embedding.well_founded _ _ r s a is_well_founded.wf)) a⟩

protected theorem eq [is_well_order β s] (f g : r ≼i s) (a) : f a = g a :=
by rw subsingleton.elim f g

theorem antisymm.aux [is_well_order α r] (f : r ≼i s) (g : s ≼i r) : left_inverse g f :=
initial_seg.eq (f.trans g) (initial_seg.refl _)

/-- If we have order embeddings between `α` and `β` whose images are initial segments, and `β`
is a well-order then `α` and `β` are order-isomorphic. -/
def antisymm [is_well_order β s] (f : r ≼i s) (g : s ≼i r) : r ≃r s :=
by haveI := f.to_rel_embedding.is_well_order; exact
⟨⟨f, g, antisymm.aux f g, antisymm.aux g f⟩, λ _ _, f.map_rel_iff'⟩

@[simp] theorem antisymm_to_fun [is_well_order β s]
  (f : r ≼i s) (g : s ≼i r) : (antisymm f g : α → β) = f := rfl

@[simp] theorem antisymm_symm [is_well_order α r] [is_well_order β s]
  (f : r ≼i s) (g : s ≼i r) : (antisymm f g).symm = antisymm g f :=
rel_iso.coe_fn_injective rfl

theorem eq_or_principal [is_well_order β s] (f : r ≼i s) :
  surjective f ∨ ∃ b, ∀ x, s x b ↔ ∃ y, f y = x :=
or_iff_not_imp_right.2 $ λ h b,
acc.rec_on (is_well_founded.wf.apply b : acc s b) $ λ x H IH,
not_forall_not.1 $ λ hn,
h ⟨x, λ y, ⟨(IH _), λ ⟨a, e⟩, by rw ← e; exact
  (trichotomous _ _).resolve_right
  (not_or (hn a) (λ hl, not_exists.2 hn (f.init hl)))⟩⟩

/-- Restrict the codomain of an initial segment -/
def cod_restrict (p : set β) (f : r ≼i s) (H : ∀ a, f a ∈ p) : r ≼i subrel s p :=
⟨rel_embedding.cod_restrict p f H, λ a ⟨b, m⟩ (h : s b (f a)),
  let ⟨a', e⟩ := f.init h in ⟨a', by clear _let_match; subst e; refl⟩⟩

@[simp]

/-- Initial segment from an empty type. -/
def of_is_empty (r : α → α → Prop) (s : β → β → Prop) [is_empty α] : r ≼i s :=
⟨rel_embedding.of_is_empty r s, is_empty_elim⟩

/-- Initial segment embedding of an order `r` into the disjoint union of `r` and `s`. -/
def le_add (r : α → α → Prop) (s : β → β → Prop) : r ≼i sum.lex r s :=
⟨⟨⟨sum.inl, λ _ _, sum.inl.inj⟩, λ a b, sum.lex_inl_inl⟩,
  λ a b, by cases b; [exact λ _, ⟨_, rfl⟩, exact false.elim ∘ sum.lex_inr_inl]⟩

@[simp] theorem le_add_apply (r : α → α → Prop) (s : β → β → Prop)
  (a) : le_add r s a = sum.inl a := rfl

protected theorem acc (f : r ≼i s) (a : α) : acc r a ↔ acc s (f a) :=
⟨begin
    refine λ h, acc.rec_on h (λ a _ ha, acc.intro _ (λ b hb, _)),
    obtain ⟨a', rfl⟩ := f.init hb,
    exact ha _ (f.map_rel_iff.mp hb),
  end, f.to_rel_embedding.acc a⟩

end initial_seg

/-!
### Principal segments

Order embeddings whose range is a principal segment of `s` (i.e., an interval of the form
`(-∞, top)` for some element `top` of `β`). The type of these embeddings from `r` to `s` is called
`principal_seg r s`, and denoted by `r ≺i s`. Principal segments are in particular initial
segments.
-/

/-- If `r` is a relation on `α` and `s` in a relation on `β`, then `f : r ≺i s` is an order
embedding whose range is an open interval `(-∞, top)` for some element `top` of `β`. Such order
embeddings are called principal segments -/
@[nolint has_nonempty_instance]
structure principal_seg {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends r ↪r s :=
(top : β)
(down' : ∀ b, s b top ↔ ∃ a, to_rel_embedding a = b)

localized "infix (name := principal_seg) ` ≺i `:25 := principal_seg" in initial_seg

namespace principal_seg

instance : has_coe (r ≺i s) (r ↪r s) := ⟨principal_seg.to_rel_embedding⟩
instance : has_coe_to_fun (r ≺i s) (λ _, α → β) := ⟨λ f, f⟩

@[simp] theorem coe_fn_mk (f : r ↪r s) (t o) :
  (@principal_seg.mk _ _ r s f t o : α → β) = f := rfl

@[simp] theorem coe_fn_to_rel_embedding (f : r ≺i s) : (f.to_rel_embedding : α → β) = f := rfl

@[simp] theorem coe_coe_fn (f : r ≺i s) : ((f : r ↪r s) : α → β) = f := rfl

theorem down (f : r ≺i s) : ∀ {b : β}, s b f.top ↔ ∃ a, f a = b := f.down'

theorem lt_top (f : r ≺i s) (a : α) : s (f a) f.top := f.down.2 ⟨_, rfl⟩

theorem init [is_trans β s] (f : r ≺i s) {a : α} {b : β} (h : s b (f a)) : ∃ a', f a' = b :=
f.down.1 $ trans h $ f.lt_top _

/-- A principal segment is in particular an initial segment. -/
instance has_coe_initial_seg [is_trans β s] : has_coe (r ≺i s) (r ≼i s) :=
⟨λ f, ⟨f.to_rel_embedding, λ a b, f.init⟩⟩

theorem coe_coe_fn' [is_trans β s] (f : r ≺i s) : ((f : r ≼i s) : α → β) = f := rfl

theorem init_iff [is_trans β s] (f : r ≺i s) {a : α} {b : β} :
  s b (f a) ↔ ∃ a', f a' = b ∧ r a' a :=
@initial_seg.init_iff α β r s f a b

theorem irrefl {r : α → α → Prop} [is_well_order α r] (f : r ≺i r) : false :=
begin
  have := f.lt_top f.top,
  rw [show f f.top = f.top, from
      initial_seg.eq ↑f (initial_seg.refl r) f.top] at this,
  exact irrefl _ this
end

instance (r : α → α → Prop) [is_well_order α r] : is_empty (r ≺i r) := ⟨λ f, f.irrefl⟩

/-- Composition of a principal segment with an initial segment, as a principal segment -/
def lt_le (f : r ≺i s) (g : s ≼i t) : r ≺i t :=
⟨@rel_embedding.trans _ _ _ r s t f g, g f.top, λ a,
 by simp only [g.init_iff, f.down', exists_and_distrib_left.symm,
   exists_swap, rel_embedding.trans_apply, exists_eq_right']; refl⟩

@[simp] theorem lt_le_apply (f : r ≺i s) (g : s ≼i t) (a : α) : (f.lt_le g) a = g (f a) :=
rel_embedding.trans_apply _ _ _

@[simp] theorem lt_le_top (f : r ≺i s) (g : s ≼i t) : (f.lt_le g).top = g f.top := rfl

/-- Composition of two principal segments as a principal segment -/
@[trans] protected def trans [is_trans γ t] (f : r ≺i s) (g : s ≺i t) : r ≺i t :=
lt_le f g

@[simp] theorem trans_apply [is_trans γ t] (f : r ≺i s) (g : s ≺i t) (a : α) :
  (f.trans g) a = g (f a) :=
lt_le_apply _ _ _

@[simp] theorem trans_top [is_trans γ t] (f : r ≺i s) (g : s ≺i t) :
  (f.trans g).top = g f.top := rfl

/-- Composition of an order isomorphism with a principal segment, as a principal segment -/
def equiv_lt (f : r ≃r s) (g : s ≺i t) : r ≺i t :=
⟨@rel_embedding.trans _ _ _ r s t f g, g.top, λ c,
 suffices (∃ (a : β), g a = c) ↔ ∃ (a : α), g (f a) = c, by simpa [g.down],
 ⟨λ ⟨b, h⟩, ⟨f.symm b, by simp only [h, rel_iso.apply_symm_apply, rel_iso.coe_coe_fn]⟩,
  λ ⟨a, h⟩, ⟨f a, h⟩⟩⟩

/-- Composition of a principal segment with an order isomorphism, as a principal segment -/
def lt_equiv {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop}
  (f : principal_seg r s) (g : s ≃r t) : principal_seg r t :=
⟨@rel_embedding.trans _ _ _ r s t f g, g f.top,
  begin
    intro x,
    rw [← g.apply_symm_apply x, g.map_rel_iff, f.down', exists_congr],
    intro y, exact ⟨congr_arg g, λ h, g.to_equiv.bijective.1 h⟩
  end⟩

@[simp] theorem equiv_lt_apply (f : r ≃r s) (g : s ≺i t) (a : α) : (equiv_lt f g) a = g (f a) :=
rel_embedding.trans_apply _ _ _

@[simp] theorem equiv_lt_top (f : r ≃r s) (g : s ≺i t) : (equiv_lt f g).top = g.top := rfl

/-- Given a well order `s`, there is a most one principal segment embedding of `r` into `s`. -/
instance [is_well_order β s] : subsingleton (r ≺i s) :=
⟨λ f g, begin
  have ef : (f : α → β) = g,
  { show ((f : r ≼i s) : α → β) = g,
    rw @subsingleton.elim _ _ (f : r ≼i s) g, refl },
  have et : f.top = g.top,
  { refine extensional_of_trichotomous_of_irrefl s (λ x, _),
    simp only [f.down, g.down, ef, coe_fn_to_rel_embedding] },
  cases f, cases g,
  have := rel_embedding.coe_fn_injective ef; congr'
end⟩

theorem top_eq [is_well_order γ t]
  (e : r ≃r s) (f : r ≺i t) (g : s ≺i t) : f.top = g.top :=
by rw subsingleton.elim f (principal_seg.equiv_lt e g); refl

lemma top_lt_top {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop}
  [is_well_order γ t]
  (f : principal_seg r s) (g : principal_seg s t) (h : principal_seg r t) : t h.top g.top :=
by { rw [subsingleton.elim h (f.trans g)], apply principal_seg.lt_top }

/-- Any element of a well order yields a principal segment -/
def of_element {α : Type*} (r : α → α → Prop) (a : α) : subrel r {b | r b a} ≺i r :=
⟨subrel.rel_embedding _ _, a, λ b,
  ⟨λ h, ⟨⟨_, h⟩, rfl⟩, λ ⟨⟨_, h⟩, rfl⟩, h⟩⟩

@[simp] theorem of_element_apply {α : Type*} (r : α → α → Prop) (a : α) (b) :
  of_element r a b = b.1 := rfl

@[simp] theorem of_element_top {α : Type*} (r : α → α → Prop) (a : α) :
  (of_element r a).top = a := rfl

/-- Restrict the codomain of a principal segment -/
def cod_restrict (p : set β) (f : r ≺i s)
  (H : ∀ a, f a ∈ p) (H₂ : f.top ∈ p) : r ≺i subrel s p :=
⟨rel_embedding.cod_restrict p f H, ⟨f.top, H₂⟩, λ ⟨b, h⟩,
  f.down.trans $ exists_congr $ λ a,
  show (⟨f a, H a⟩ : p).1 = _ ↔ _, from ⟨subtype.eq, congr_arg _⟩⟩

@[simp]
theorem cod_restrict_apply (p) (f : r ≺i s) (H H₂ a) : cod_restrict p f H H₂ a = ⟨f a, H a⟩ := rfl

@[simp]
theorem cod_restrict_top (p) (f : r ≺i s) (H H₂) : (cod_restrict p f H H₂).top = ⟨f.top, H₂⟩ := rfl

/-- Principal segment from an empty type into a type with a minimal element. -/
def of_is_empty (r : α → α → Prop) [is_empty α] {b : β} (H : ∀ b', ¬ s b' b) : r ≺i s :=
{ top := b,
  down' := by simp [H],
  ..rel_embedding.of_is_empty r s }

@[simp] theorem of_is_empty_top (r : α → α → Prop) [is_empty α] {b : β} (H : ∀ b', ¬ s b' b) :
  (of_is_empty r H).top = b := rfl

/-- Principal segment from the empty relation on `pempty` to the empty relation on `punit`. -/
@[reducible] def pempty_to_punit : @empty_relation pempty ≺i @empty_relation punit :=
@of_is_empty _ _ empty_relation _ _ punit.star $ λ x, not_false

protected theorem acc [is_trans β s] (f : r ≺i s) (a : α) : acc r a ↔ acc s (f a) :=
(f : r ≼i s).acc a

end principal_seg

/--
A relation is well-founded iff every principal segment of it is well-founded.

In this lemma we use `subrel` to indicate its principal segments because it's usually more
convenient to use.
-/
theorem well_founded_iff_well_founded_subrel {β : Type*} {s : β → β → Prop} [is_trans β s] :
  well_founded s ↔ (∀ b, well_founded (subrel s {b' | s b' b})) :=
begin
  refine ⟨λ wf b, ⟨λ b', ((principal_seg.of_element _ b).acc b').mpr (wf.apply b')⟩,
    λ wf, ⟨λ b, acc.intro _ (λ b' hb', _)⟩⟩,
  let f := principal_seg.of_element s b,
  obtain ⟨b', rfl⟩ := f.down.mp ((principal_seg.of_element_top s b).symm ▸ hb' : s b' f.top),
  exact (f.acc b').mp ((wf b).apply b'),
end

theorem {u} well_founded_iff_principal_seg {β : Type u} {s : β → β → Prop} [is_trans β s] :
  well_founded s ↔ (∀ (α : Type u) (r : α → α → Prop) (f : r ≺i s), well_founded r) :=
⟨λ wf α r f, rel_hom_class.well_founded f.to_rel_embedding wf,
  λ h, well_founded_iff_well_founded_subrel.mpr (λ b, h _ _ (principal_seg.of_element s b))⟩

/-! ### Properties of initial and principal segments -/

/-- To an initial segment taking values in a well order, one can associate either a principal
segment (if the range is not everything, hence one can take as top the minimum of the complement
of the range) or an order isomorphism (if the range is everything). -/
noncomputable def initial_seg.lt_or_eq [is_well_order β s] (f : r ≼i s) : (r ≺i s) ⊕ (r ≃r s) :=
begin
  by_cases h : surjective f,
  { exact sum.inr (rel_iso.of_surjective f h) },
  { have h' : _, from (initial_seg.eq_or_principal f).resolve_left h,
    exact sum.inl ⟨f, classical.some h', classical.some_spec h'⟩ }
end

theorem initial_seg.lt_or_eq_apply_left [is_well_order β s]
  (f : r ≼i s) (g : r ≺i s) (a : α) : g a = f a :=
@initial_seg.eq α β r s _ g f a

theorem initial_seg.lt_or_eq_apply_right [is_well_order β s]
  (f : r ≼i s) (g : r ≃r s) (a : α) : g a = f a :=
initial_seg.eq (initial_seg.of_iso g) f a

/-- Composition of an initial segment taking values in a well order and a principal segment. -/
noncomputable def initial_seg.le_lt [is_well_order β s] [is_trans γ t] (f : r ≼i s) (g : s ≺i t) :
  r ≺i t :=
match f.lt_or_eq with
| sum.inl f' := f'.trans g
| sum.inr f' := principal_seg.equiv_lt f' g
end

@[simp] theorem initial_seg.le_lt_apply [is_well_order β s] [is_trans γ t]
  (f : r ≼i s) (g : s ≺i t) (a : α) : (f.le_lt g) a = g (f a) :=
begin
  delta initial_seg.le_lt, cases h : f.lt_or_eq with f' f',
  { simp only [principal_seg.trans_apply, f.lt_or_eq_apply_left] },
  { simp only [principal_seg.equiv_lt_apply, f.lt_or_eq_apply_right] }
end

namespace rel_embedding

/-- Given an order embedding into a well order, collapse the order embedding by filling the
gaps, to obtain an initial segment. Here, we construct the collapsed order embedding pointwise,
but the proof of the fact that it is an initial segment will be given in `collapse`. -/
noncomputable def collapse_F [is_well_order β s] (f : r ↪r s) : Π a, {b // ¬ s (f a) b} :=
(rel_embedding.well_founded f $ is_well_founded.wf).fix $ λ a IH, begin
  let S := {b | ∀ a h, s (IH a h).1 b},
  have : f a ∈ S, from λ a' h, ((trichotomous _ _)
    .resolve_left $ λ h', (IH a' h).2 $ trans (f.map_rel_iff.2 h) h')
    .resolve_left $ λ h', (IH a' h).2 $ h' ▸ f.map_rel_iff.2 h,
  exact ⟨is_well_founded.wf.min S ⟨_, this⟩,
   is_well_founded.wf.not_lt_min _ _ this⟩
end

theorem collapse_F.lt [is_well_order β s] (f : r ↪r s) {a : α}
   : ∀ {a'}, r a' a → s (collapse_F f a').1 (collapse_F f a).1 :=
show (collapse_F f a).1 ∈ {b | ∀ a' (h : r a' a), s (collapse_F f a').1 b}, begin
  unfold collapse_F, rw well_founded.fix_eq,
  apply well_founded.min_mem _ _
end

theorem collapse_F.not_lt [is_well_order β s] (f : r ↪r s) (a : α)
   {b} (h : ∀ a' (h : r a' a), s (collapse_F f a').1 b) : ¬ s b (collapse_F f a).1 :=
begin
  unfold collapse_F, rw well_founded.fix_eq,
  exact well_founded.not_lt_min _ _ _
    (show b ∈ {b | ∀ a' (h : r a' a), s (collapse_F f a').1 b}, from h)
end

/-- Construct an initial segment from an order embedding into a well order, by collapsing it
to fill the gaps. -/
noncomputable def collapse [is_well_order β s] (f : r ↪r s) : r ≼i s :=
by haveI := rel_embedding.is_well_order f; exact
⟨rel_embedding.of_monotone
  (λ a, (collapse_F f a).1) (λ a b, collapse_F.lt f),
λ a b, acc.rec_on (is_well_founded.wf.apply b : acc s b) (λ b H IH a h, begin
  let S := {a | ¬ s (collapse_F f a).1 b},
  have : S.nonempty := ⟨_, asymm h⟩,
  existsi (is_well_founded.wf : well_founded r).min S this,
  refine ((@trichotomous _ s _ _ _).resolve_left _).resolve_right _,
  { exact (is_well_founded.wf : well_founded r).min_mem S this },
  { refine collapse_F.not_lt f _ (λ a' h', _),
    by_contradiction hn,
    exact is_well_founded.wf.not_lt_min S this hn h' }
end) a⟩

theorem collapse_apply [is_well_order β s] (f : r ↪r s)
  (a) : collapse f a = (collapse_F f a).1 := rfl

end rel_embedding


import tactic.abel
import algebra.group.pi
variables {α : Type*} {a b : α}

example [add_comm_monoid α] : a + (b + a) = a + a + b := by abel
example [add_comm_group α] : (a + b) - ((b + a) + a) = -a := by abel
example [add_comm_group α] (x : α) : x - 0 = x := by abel
example [add_comm_monoid α] (x : α) : (3 : ℕ) • a = a + (2 : ℕ) • a := by abel
example [add_comm_group α] : (3 : ℤ) • a = a + (2 : ℤ) • a := by abel
example [add_comm_group α] (a b : α) : a-2•b = a -2•b := by abel
example [add_comm_group α] (a : α) : 0 + a = a := by abel1
example [add_comm_group α] (n : ℕ) (a : α) : n • a = n • a := by abel1
example [add_comm_group α] (n : ℕ) (a : α) : 0 + n • a = n • a := by abel1

-- instances do not have to syntactically be
-- `add_monoid.has_smul_nat` or `sub_neg_monoid.has_smul_int`
example [add_comm_monoid α] (x : ℕ → α) : ((2 : ℕ) • x) = x + x := by abel1
example [add_comm_group α] (x : ℕ → α) : ((2 : ℕ) • x) = x + x := by abel1
example [add_comm_group α] (x : ℕ → α) : ((2 : ℤ) • x) = x + x := by abel1

-- even if there's an instance we don't recognize, we treat it as an atom
example [add_comm_group α] [has_smul ℕ α] (x : ℕ → α) :
  ((2 : ℕ) • x) + ((2 : ℕ) • x) = (2 : ℤ) • ((2 : ℕ) • x) := by abel1

-- `abel!` should see through terms that are definitionally equal,
def id' (x : α) := x
example [add_comm_group α] : a + b - b - id' a = 0 :=
begin
  success_if_fail { abel; done },
  abel!
end


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.order.monoid.with_top
import data.finset.image
import data.multiset.fold

/-!
# The fold operation for a commutative associative operation over a finset.

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

namespace finset
open multiset

variables {α β γ : Type*}

/-! ### fold -/
section fold
variables (op : β → β → β) [hc : is_commutative β op] [ha : is_associative β op]
local notation (name := op) a ` * ` b := op a b
include hc ha

/-- `fold op b f s` folds the commutative associative operation `op` over the
  `f`-image of `s`, i.e. `fold (+) b f {1,2,3} = f 1 + f 2 + f 3 + b`. -/
def fold (b : β) (f : α → β) (s : finset α) : β := (s.1.map f).fold op b

variables {op} {f : α → β} {b : β} {s : finset α} {a : α}

@[simp] theorem fold_empty : (∅ : finset α).fold op b f = b := rfl

@[simp] theorem fold_cons (h : a ∉ s) : (cons a s h).fold op b f = f a * s.fold op b f :=
by { dunfold fold, rw [cons_val, multiset.map_cons, fold_cons_left], }

@[simp] theorem fold_insert [decidable_eq α] (h : a ∉ s) :
  (insert a s).fold op b f = f a * s.fold op b f :=
by unfold fold; rw [insert_val, ndinsert_of_not_mem h, multiset.map_cons, fold_cons_left]

@[simp] theorem fold_singleton : ({a} : finset α).fold op b f = f a * b := rfl

@[simp]

@[simp] theorem fold_image [decidable_eq α] {g : γ → α} {s : finset γ}
  (H : ∀ (x ∈ s) (y ∈ s), g x = g y → x = y) : (s.image g).fold op b f = s.fold op b (f ∘ g) :=
by simp only [fold, image_val_of_inj_on H, multiset.map_map]

@[congr] theorem fold_congr {g : α → β} (H : ∀ x ∈ s, f x = g x) : s.fold op b f = s.fold op b g :=
by rw [fold, fold, map_congr rfl H]

theorem fold_op_distrib {f g : α → β} {b₁ b₂ : β} :
  s.fold op (b₁ * b₂) (λx, f x * g x) = s.fold op b₁ f * s.fold op b₂ g :=
by simp only [fold, fold_distrib]

lemma fold_const [decidable (s = ∅)] (c : β) (h : op c (op b c) = op b c) :
  finset.fold op b (λ _, c) s = if s = ∅ then b else op b c :=
begin
  classical,
  unfreezingI { induction s using finset.induction_on with x s hx IH },
  { simp },
  { simp only [finset.fold_insert hx, IH, if_false, finset.insert_ne_empty],
    split_ifs,
    { rw hc.comm },
    { exact h } }
end

theorem fold_hom {op' : γ → γ → γ} [is_commutative γ op'] [is_associative γ op']
  {m : β → γ} (hm : ∀x y, m (op x y) = op' (m x) (m y)) :
  s.fold op' (m b) (λx, m (f x)) = m (s.fold op b f) :=
by rw [fold, fold, ← fold_hom op hm, multiset.map_map]

theorem fold_disj_union {s₁ s₂ : finset α} {b₁ b₂ : β} (h) :
  (s₁.disj_union s₂ h).fold op (b₁ * b₂) f = s₁.fold op b₁ f * s₂.fold op b₂ f :=
(congr_arg _ $ multiset.map_add _ _ _).trans (multiset.fold_add _ _ _ _ _)

theorem fold_disj_Union {ι : Type*} {s : finset ι} {t : ι → finset α} {b : ι → β} {b₀ : β} (h) :
  (s.disj_Union t h).fold op (s.fold op b₀ b) f = s.fold op b₀ (λ i, (t i).fold op (b i) f) :=
(congr_arg _ $ multiset.map_bind _ _ _).trans (multiset.fold_bind _ _ _ _ _)

theorem fold_union_inter [decidable_eq α] {s₁ s₂ : finset α} {b₁ b₂ : β} :
  (s₁ ∪ s₂).fold op b₁ f * (s₁ ∩ s₂).fold op b₂ f = s₁.fold op b₂ f * s₂.fold op b₁ f :=
by unfold fold; rw [← fold_add op, ← multiset.map_add, union_val,
     inter_val, union_add_inter, multiset.map_add, hc.comm, fold_add]

@[simp] theorem fold_insert_idem [decidable_eq α] [hi : is_idempotent β op] :
  (insert a s).fold op b f = f a * s.fold op b f :=
begin
  by_cases (a ∈ s),
  { rw [← insert_erase h], simp [← ha.assoc, hi.idempotent] },
  { apply fold_insert h },
end

theorem fold_image_idem [decidable_eq α] {g : γ → α} {s : finset γ}
  [hi : is_idempotent β op] :
  (image g s).fold op b f = s.fold op b (f ∘ g) :=
begin
  induction s using finset.cons_induction with x xs hx ih,
  { rw [fold_empty, image_empty, fold_empty] },
  { haveI := classical.dec_eq γ,
    rw [fold_cons, cons_eq_insert, image_insert, fold_insert_idem, ih], }
end

/-- A stronger version of `finset.fold_ite`, but relies on
an explicit proof of idempotency on the seed element, rather
than relying on typeclass idempotency over the whole type. -/
lemma fold_ite' {g : α → β} (hb : op b b = b)
  (p : α → Prop) [decidable_pred p] :
  finset.fold op b (λ i, ite (p i) (f i) (g i)) s =
  op (finset.fold op b f (s.filter p)) (finset.fold op b g (s.filter (λ i, ¬ p i))) :=
begin
  classical,
  induction s using finset.induction_on with x s hx IH,
  { simp [hb] },
  { simp only [finset.filter_congr_decidable, finset.fold_insert hx],
    split_ifs with h h,
    { have : x ∉ finset.filter p s,
      { simp [hx] },
      simp [finset.filter_insert, h, finset.fold_insert this, ha.assoc, IH] },
    { have : x ∉ finset.filter (λ i, ¬ p i) s,
      { simp [hx] },
      simp [finset.filter_insert, h, finset.fold_insert this, IH, ←ha.assoc, hc.comm] } }
end

/-- A weaker version of `finset.fold_ite'`,
relying on typeclass idempotency over the whole type,
instead of solely on the seed element.
However, this is easier to use because it does not generate side goals. -/
lemma fold_ite [is_idempotent β op] {g : α → β}
  (p : α → Prop) [decidable_pred p] :
  finset.fold op b (λ i, ite (p i) (f i) (g i)) s =
  op (finset.fold op b f (s.filter p)) (finset.fold op b g (s.filter (λ i, ¬ p i))) :=
fold_ite' (is_idempotent.idempotent _) _

lemma fold_op_rel_iff_and
  {r : β → β → Prop} (hr : ∀ {x y z}, r x (op y z) ↔ (r x y ∧ r x z)) {c : β} :
  r c (s.fold op b f) ↔ (r c b ∧ ∀ x∈s, r c (f x)) :=
begin
  classical,
  apply finset.induction_on s, { simp },
  clear s, intros a s ha IH,
  rw [finset.fold_insert ha, hr, IH, ← and_assoc, and_comm (r c (f a)), and_assoc],
  apply and_congr iff.rfl,
  split,
  { rintro ⟨h₁, h₂⟩, intros b hb, rw finset.mem_insert at hb,
    rcases hb with rfl|hb; solve_by_elim },
  { intro h, split,
    { exact h a (finset.mem_insert_self _ _), },
    { intros b hb, apply h b, rw finset.mem_insert, right, exact hb } }
end

lemma fold_op_rel_iff_or
  {r : β → β → Prop} (hr : ∀ {x y z}, r x (op y z) ↔ (r x y ∨ r x z)) {c : β} :
  r c (s.fold op b f) ↔ (r c b ∨ ∃ x∈s, r c (f x)) :=
begin
  classical,
  apply finset.induction_on s, { simp },
  clear s, intros a s ha IH,
  rw [finset.fold_insert ha, hr, IH, ← or_assoc, or_comm (r c (f a)), or_assoc],
  apply or_congr iff.rfl,
  split,
  { rintro (h₁|⟨x, hx, h₂⟩),
    { use a, simp [h₁] },
    { refine ⟨x, by simp [hx], h₂⟩ } },
  { rintro ⟨x, hx, h⟩,
    rw mem_insert at hx, cases hx,
    { left, rwa hx at h },
    { right, exact ⟨x, hx, h⟩ } }
end

omit hc ha

@[simp]
lemma fold_union_empty_singleton [decidable_eq α] (s : finset α) :
  finset.fold (∪) ∅ singleton s = s :=
begin
  apply finset.induction_on s,
  { simp only [fold_empty], },
  { intros a s has ih, rw [fold_insert has, ih, insert_eq], }
end

lemma fold_sup_bot_singleton [decidable_eq α] (s : finset α) :
  finset.fold (⊔) ⊥ singleton s = s :=
fold_union_empty_singleton s

section order
variables [linear_order β] (c : β)

lemma le_fold_min : c ≤ s.fold min b f ↔ (c ≤ b ∧ ∀ x∈s, c ≤ f x) :=
fold_op_rel_iff_and $ λ x y z, le_min_iff

lemma fold_min_le : s.fold min b f ≤ c ↔ (b ≤ c ∨ ∃ x∈s, f x ≤ c) :=
begin
  show _ ≥ _ ↔ _,
  apply fold_op_rel_iff_or,
  intros x y z,
  show _ ≤ _ ↔ _,
  exact min_le_iff
end

lemma lt_fold_min : c < s.fold min b f ↔ (c < b ∧ ∀ x∈s, c < f x) :=
fold_op_rel_iff_and $ λ x y z, lt_min_iff

lemma fold_min_lt : s.fold min b f < c ↔ (b < c ∨ ∃ x∈s, f x < c) :=
begin
  show _ > _ ↔ _,
  apply fold_op_rel_iff_or,
  intros x y z,
  show _ < _ ↔ _,
  exact min_lt_iff
end

lemma fold_max_le : s.fold max b f ≤ c ↔ (b ≤ c ∧ ∀ x∈s, f x ≤ c) :=
begin
  show _ ≥ _ ↔ _,
  apply fold_op_rel_iff_and,
  intros x y z,
  show _ ≤ _ ↔ _,
  exact max_le_iff
end

lemma le_fold_max : c ≤ s.fold max b f ↔ (c ≤ b ∨ ∃ x∈s, c ≤ f x) :=
fold_op_rel_iff_or $ λ x y z, le_max_iff

lemma fold_max_lt : s.fold max b f < c ↔ (b < c ∧ ∀ x∈s, f x < c) :=
begin
  show _ > _ ↔ _,
  apply fold_op_rel_iff_and,
  intros x y z,
  show _ < _ ↔ _,
  exact max_lt_iff
end

lemma lt_fold_max : c < s.fold max b f ↔ (c < b ∨ ∃ x∈s, c < f x) :=
fold_op_rel_iff_or $ λ x y z, lt_max_iff

lemma fold_max_add [has_add β] [covariant_class β β (function.swap (+)) (≤)]
 (n : with_bot β) (s : finset α) :
  s.fold max ⊥ (λ (x : α), ↑(f x) + n) = s.fold max ⊥ (coe ∘ f) + n :=
by { classical, apply s.induction_on; simp [max_add_add_right] {contextual := tt} }

end order

end fold

end finset


import Lean
import Mathlib.Data.Bool.Basic

open Lean Parser Tactic

namespace Decision.Propositional

inductive Atom where
| ident (name : String)
| true
| false

inductive Formula where
| and (lhs rhs : Formula)
| or (lhs rhs : Formula)
| neg (f : Formula)
| atom (a : Atom)

declare_syntax_cat propositional

syntax "⊤" : propositional
syntax "⊥" : propositional
syntax ident : propositional

syntax:35 propositional " ∧ " propositional : propositional
syntax:30 propositional " ∨ " propositional : propositional
syntax:max "¬" propositional:40 : propositional
syntax "(" propositional ")" : propositional
syntax propositional " → " propositional : propositional

syntax "[prop|" propositional "]" : term
syntax "[t|" term "]" : propositional

macro_rules
| `([prop| ⊤]) => `(Formula.atom Atom.true)
| `([prop| ⊥]) => `(Formula.atom Atom.false)
| `([prop| $ident:ident]) => `(Formula.atom (Atom.ident $(Lean.quote ident.getId.toString)))
| `([prop| $lhs ∧ $rhs]) => `(Formula.and [prop| $lhs] [prop| $rhs])
| `([prop| $lhs ∨ $rhs]) => `(Formula.or [prop| $lhs] [prop| $rhs])
| `([prop| ¬$f]) => `(Formula.neg [prop| $f])
| `([prop| ($f)]) => `([prop| $f])
| `([prop| $lhs → $rhs]) => `([prop| ¬$lhs ∨ $rhs])
| `([prop| [t| $term]]) => `($term)

/--
Definition 1.1
-/
abbrev Assignment := String → Bool

def Atom.eval (assign : Assignment) : Atom → Bool
| .ident name => assign name
| .true => .true
| .false => .false

namespace Formula

def eval (assign : Assignment) : Formula → Bool
| .and lhs rhs => eval assign lhs && eval assign rhs
| .or lhs rhs => eval assign lhs || eval assign rhs
| .neg f => !eval assign f
| .atom a => Atom.eval assign a

/--
Definition 1.2
-/
def IsSatisfiable (f : Formula) : Prop := ∃ assign : Assignment, f.eval assign = true

/--
Definition 1.2
-/
def IsContradiction (f : Formula) : Prop := ∀ assign : Assignment, f.eval assign = false

/--
Definition 1.2
-/
def IsValid (f : Formula) : Prop := ∀ assign : Assignment, f.eval assign = true

/--
Example 1.3
-/
example : IsSatisfiable [prop| A ∧ B] := by
  apply Exists.intro (fun _ => true)
  rfl

/-
Lets introduce a truth table tactic
-/
syntax "truth_table" ident " with " "[" (ident),* "]" (location)? : tactic
macro_rules
| `(tactic| truth_table $assign with [$ident] ) =>
    `(tactic| cases $assign $(quote ident.getId.toString))
| `(tactic| truth_table $assign with [$ident, $idents,*] ) =>
    `(tactic| truth_table $assign with [$ident] <;> truth_table $assign with [$idents,*])

example : IsContradiction [prop| (A → B) ∧ A ∧ ¬B] := by
  intro assign
  simp only [eval, Atom.eval]
  truth_table assign with [A, B] <;> decide

example : IsValid [prop| ¬((A → B) ∧ A ∧ ¬B)] := by
  intro assign
  simp only [eval, Atom.eval]
  truth_table assign with [A, B] <;> decide

/--
Definition 1.9
-/
def Equisatisfiable (lhs rhs : Formula) : Prop := IsSatisfiable lhs ↔ IsSatisfiable rhs

/--
Definition 1.10
-/
inductive NNF : Formula → Prop where
| atom (a : Atom) : NNF (.atom a)
| negAtom (a : Atom) : NNF (.neg (.atom a))
| and (lhs rhs : Formula) (h1 : NNF lhs) (h2 : NNF rhs) : NNF [prop| [t| lhs] ∧ [t| rhs]]
| or (lhs rhs : Formula) (h1 : NNF lhs) (h2 : NNF rhs) : NNF [prop| [t| lhs] ∨ [t| rhs]]

/--
Example
-/
example: ¬NNF [prop| ¬(x_1 ∨ x_2)] := by
  intro h
  cases h

example : NNF [prop| ¬x_1 ∧ ¬x_2] := by
  apply NNF.and
  apply NNF.negAtom
  apply NNF.negAtom

def toNNF : Formula → Formula
| [prop| ¬([t| a] ∨ [t| b])] => [prop| [t| toNNF <| .neg a] ∧ [t| toNNF <| .neg b]]
| [prop| ¬([t| a] ∧ [t| b])] => [prop| [t| toNNF <| .neg a] ∨ [t| toNNF <| .neg b]]
| .or lhs rhs => .or (toNNF lhs) (toNNF rhs)
| .and lhs rhs => .and (toNNF lhs) (toNNF rhs)
| .neg (.neg f) => toNNF f
| .atom a => .atom a
| .neg (.atom a) => .neg (.atom a)

-- TODO: remove these once mathlib updated
theorem not_and : ∀ a b : Bool, (!(a && b)) = (!a || !b) := by decide
theorem not_or : ∀ a b : Bool, (!(a || b)) = (!a && !b) := by decide
theorem eq_of_neg_eq : ∀ a b : Bool, (!a) = (!b) → a = b := by
  intro a b h
  cases a <;> cases b <;> simp_all

theorem negtoNNF_toNNFneg : ∀ (f : Formula) (assign : Assignment), (!eval assign (toNNF f)) = eval assign (toNNF (.neg f)) := by
  intro f assign
  induction f with
  | and lhs rhs lih rih =>
    simp only [toNNF, eval, not_and, lih, rih]
  | or lhs rhs lih rih =>
    simp only [toNNF, eval, not_or, lih, rih]
  | neg f ih =>
    simp only [←ih, toNNF, Bool.not_not]
  | atom => simp only [toNNF, eval]

theorem NNF_toNNF : ∀ f : Formula, NNF (toNNF f) := by
  intro f
  match hf:f with
  | and lhs rhs =>
    simp only [toNNF]
    apply NNF.and _ _ (NNF_toNNF _) (NNF_toNNF _)
  | or lhs rhs =>
    simp only [toNNF]
    apply NNF.or _ _ (NNF_toNNF _) (NNF_toNNF _)
  | neg nf =>
    match hnf:nf with
    | and lhs rhs =>
      simp only[toNNF] at *
      apply NNF.or _ _ (NNF_toNNF _) (NNF_toNNF _)
    | or lhs rhs =>
      simp only[toNNF] at *
      apply NNF.and _ _ (NNF_toNNF _) (NNF_toNNF _)
    | neg nnf =>
      simp only [toNNF]
      exact NNF_toNNF nnf
    | atom _ =>
      simp only [toNNF]
      apply NNF.negAtom
  | atom a =>
    simp only [toNNF]
    apply NNF.atom

theorem toNNF_preserves : ∀ (f : Formula) (assign : Assignment), eval assign f = eval assign (toNNF f) := by
  intro f assign
  induction f with
  | and lhs rhs lih rih => simp only [eval, toNNF, lih, rih]
  | or lsh rhs lih rih => simp only [eval, toNNF, lih, rih]
  | neg f ih =>
    cases f with
    | and lhs rhs =>
      simp only [eval, toNNF] at *
      simp only [negtoNNF_toNNFneg, ih, not_and]
    | or =>
      simp only [eval, toNNF] at *
      simp only [negtoNNF_toNNFneg, ih, not_or]
    | neg f =>
      simp only[toNNF, eval, Bool.not_not]
      cases f with
      | and =>
        simp only [toNNF, eval, ←not_and, ←negtoNNF_toNNFneg] at *
        apply eq_of_neg_eq
        assumption
      | or =>
        simp only [toNNF, eval, ←not_or, ←negtoNNF_toNNFneg] at *
        apply eq_of_neg_eq
        assumption
      | neg =>
        simp only[toNNF, eval, ←negtoNNF_toNNFneg, Bool.not_not] at *
        rw [ih]
      | atom => simp only[toNNF, eval]
    | atom => simp only[toNNF, eval]
  | atom =>
    simp only [toNNF, eval]

end Formula

end Decision.Propositional


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Chris Hughes
-/
import algebra.associated data.int.gcd data.nat.enat
import tactic.converter.interactive

variables {α : Type*}

open nat roption

/-- `multiplicity a b` returns the largest natural number `n` such that
  `a ^ n ∣ b`, as an `enat` or natural with infinity. If `∀ n, a ^ n ∣ b`,
  then it returns `⊤`-/
def multiplicity [comm_semiring α] [decidable_rel ((∣) : α → α → Prop)] (a b : α) : enat :=
⟨∃ n : ℕ, ¬a ^ (n + 1) ∣ b, λ h, nat.find h⟩

namespace multiplicity

section comm_semiring
variables [comm_semiring α]

@[reducible] def finite (a b : α) : Prop := ∃ n : ℕ, ¬a ^ (n + 1) ∣ b

lemma finite_iff_dom [decidable_rel ((∣) : α → α → Prop)] {a b : α} :
  finite a b ↔ (multiplicity a b).dom := iff.rfl

lemma finite_def {a b : α} : finite a b ↔ ∃ n : ℕ, ¬a ^ (n + 1) ∣ b := iff.rfl

lemma not_finite_iff_forall {a b : α} : (¬ finite a b) ↔ ∀ n : ℕ, a ^ n ∣ b :=
⟨λ h n, nat.cases_on n (one_dvd _) (by simpa [finite, classical.not_not] using h),
  by simp [finite, multiplicity, classical.not_not]; tauto⟩

lemma not_unit_of_finite {a b : α} (h : finite a b) : ¬is_unit a :=
let ⟨n, hn⟩ := h in mt (is_unit_iff_forall_dvd.1 ∘ is_unit_pow (n + 1)) $
λ h, hn (h b)

lemma ne_zero_of_finite {a b : α} (h : finite a b) : b ≠ 0 :=
let ⟨n, hn⟩ := h in λ hb, by simpa [hb] using hn

lemma finite_of_finite_mul_left {a b c : α} : finite a (b * c) → finite a c :=
λ ⟨n, hn⟩, ⟨n, λ h, hn (dvd.trans h (by simp [_root_.mul_pow]))⟩

lemma finite_of_finite_mul_right {a b c : α} : finite a (b * c) → finite a b :=
by rw mul_comm; exact finite_of_finite_mul_left

variable [decidable_rel ((∣) : α → α → Prop)]

lemma pow_dvd_of_le_multiplicity {a b : α} {k : ℕ} : (k : enat) ≤ multiplicity a b → a ^ k ∣ b :=
nat.cases_on k (λ _, one_dvd _)
  (λ k ⟨h₁, h₂⟩, by_contradiction (λ hk, (nat.find_min _ (lt_of_succ_le (h₂ ⟨k, hk⟩)) hk)))

lemma pow_multiplicity_dvd {a b : α} (h : finite a b) : a ^ get (multiplicity a b) h ∣ b :=
pow_dvd_of_le_multiplicity (by rw enat.coe_get)

lemma is_greatest  {a b : α} {m : ℕ} (hm : multiplicity a b < m) : ¬a ^ m ∣ b :=
λ h, have finite a b, from enat.dom_of_le_some (le_of_lt hm),
by rw [← enat.coe_get (finite_iff_dom.1 this), enat.coe_lt_coe] at hm;
  exact nat.find_spec this (dvd.trans (pow_dvd_pow _ hm) h)

lemma is_greatest' {a b : α} {m : ℕ} (h : finite a b) (hm : get (multiplicity a b) h < m) :
  ¬a ^ m ∣ b :=
is_greatest (by rwa [← enat.coe_lt_coe, enat.coe_get] at hm)

lemma unique {a b : α} {k : ℕ} (hk : a ^ k ∣ b) (hsucc : ¬a ^ (k + 1) ∣ b) :
  (k : enat) = multiplicity a b :=
le_antisymm (le_of_not_gt (λ hk', is_greatest hk' hk)) $
  have finite a b, from ⟨k, hsucc⟩,
  by rw [← enat.coe_get (finite_iff_dom.1 this), enat.coe_le_coe];
    exact nat.find_min' _ hsucc

lemma unique' {a b : α} {k : ℕ} (hk : a ^ k ∣ b) (hsucc : ¬ a ^ (k + 1) ∣ b) :
  k = get (multiplicity a b) ⟨k, hsucc⟩ :=
by rw [← enat.coe_inj, enat.coe_get, unique hk hsucc]

lemma pow_dvd_iff_le_multiplicity {a b : α}
  {k : ℕ} : a ^ k ∣ b ↔ (k : enat) ≤ multiplicity a b :=
⟨le_multiplicity_of_pow_dvd, pow_dvd_of_le_multiplicity⟩

lemma eq_some_iff {a b : α} {n : ℕ} :
  multiplicity a b = (n : enat) ↔ a ^ n ∣ b ∧ ¬a ^ (n + 1) ∣ b :=
⟨λ h, let ⟨h₁, h₂⟩ := eq_some_iff.1 h in
    h₂ ▸ ⟨pow_multiplicity_dvd _, is_greatest
      (by conv_lhs {rw ← enat.coe_get h₁ }; rw [enat.coe_lt_coe]; exact lt_succ_self _)⟩,
  λ h, eq_some_iff.2 ⟨⟨n, h.2⟩, eq.symm $ unique' h.1 h.2⟩⟩

lemma eq_top_iff {a b : α} :
  multiplicity a b = ⊤ ↔ ∀ n : ℕ, a ^ n ∣ b :=
⟨λ h n, nat.cases_on n (one_dvd _)
  (λ n, by_contradiction (not_exists.1 (eq_none_iff'.1 h) n : _)),
   λ h, eq_none_iff.2 (λ n ⟨⟨_, h₁⟩, _⟩, h₁ (h _))⟩

@[simp] protected lemma zero (a : α) : multiplicity a 0 = ⊤ :=
roption.eq_none_iff.2 (λ n ⟨⟨k, hk⟩, _⟩, hk (dvd_zero _))

lemma one_right {a : α} (ha : ¬is_unit a) : multiplicity a 1 = 0 :=
eq_some_iff.2 ⟨dvd_refl _, mt is_unit_iff_dvd_one.2 $ by simpa⟩

@[simp] lemma get_one_right {a : α} (ha : finite a 1) : get (multiplicity a 1) ha = 0 :=
get_eq_iff_eq_some.2 (eq_some_iff.2 ⟨dvd_refl _,
  by simpa [is_unit_iff_dvd_one.symm] using not_unit_of_finite ha⟩)

@[simp] lemma one_left (b : α) : multiplicity 1 b = ⊤ := by simp [eq_top_iff]

@[simp] lemma multiplicity_unit {a : α} (b : α) (ha : is_unit a) : multiplicity a b = ⊤ :=
eq_top_iff.2 (λ _, is_unit_iff_forall_dvd.1 (is_unit_pow _ ha) _)

lemma multiplicity_eq_zero_of_not_dvd {a b : α} (ha : ¬a ∣ b) : multiplicity a b = 0 :=
eq_some_iff.2 (by simpa)

lemma eq_top_iff_not_finite {a b : α} : multiplicity a b = ⊤ ↔ ¬ finite a b :=
roption.eq_none_iff'

local attribute [instance, priority 0] classical.prop_decidable

lemma multiplicity_le_multiplicity_iff {a b c d : α} : multiplicity a b ≤ multiplicity c d ↔
  (∀ n : ℕ, a ^ n ∣ b → c ^ n ∣ d) :=
⟨λ h n hab, (pow_dvd_of_le_multiplicity (le_trans (le_multiplicity_of_pow_dvd hab) h)),
  λ h, if hab : finite a b
    then by rw [← enat.coe_get (finite_iff_dom.1 hab)]; exact le_multiplicity_of_pow_dvd (h _ (pow_multiplicity_dvd _))
    else
    have ∀ n : ℕ, c ^ n ∣ d, from λ n, h n (not_finite_iff_forall.1 hab _),
    by rw [eq_top_iff_not_finite.2 hab, eq_top_iff_not_finite.2
      (not_finite_iff_forall.2 this)]⟩

lemma min_le_multiplicity_add {p a b : α} :
  min (multiplicity p a) (multiplicity p b) ≤ multiplicity p (a + b) :=
(le_total (multiplicity p a) (multiplicity p b)).elim
  (λ h, by rw [min_eq_left h, multiplicity_le_multiplicity_iff];
    exact λ n hn, dvd_add hn (multiplicity_le_multiplicity_iff.1 h n hn))
  (λ h, by rw [min_eq_right h, multiplicity_le_multiplicity_iff];
    exact λ n hn, dvd_add (multiplicity_le_multiplicity_iff.1 h n hn) hn)

lemma dvd_of_multiplicity_pos {a b : α} (h : (0 : enat) < multiplicity a b) : a ∣ b :=
by rw [← _root_.pow_one a]; exact pow_dvd_of_le_multiplicity (enat.pos_iff_one_le.1 h)

lemma finite_nat_iff {a b : ℕ} : finite a b ↔ (a ≠ 1 ∧ 0 < b) :=
begin
  rw [← not_iff_not, not_finite_iff_forall, not_and_distrib, ne.def,
    not_not, not_lt, nat.le_zero_iff],
  exact ⟨λ h, or_iff_not_imp_right.2 (λ hb,
    have ha : a ≠ 0, from λ ha, by simpa [ha] using h 1,
    by_contradiction (λ ha1 : a ≠ 1,
      have ha_gt_one : 1 < a, from
        have ∀ a : ℕ, a ≤ 1 → a ≠ 0 → a ≠ 1 → false, from dec_trivial,
        lt_of_not_ge (λ ha', this a ha' ha ha1),
      not_lt_of_ge (le_of_dvd (nat.pos_of_ne_zero hb) (h b))
          (by simp only [nat.pow_eq_pow]; exact lt_pow_self ha_gt_one b))),
    λ h, by cases h; simp *⟩
end

lemma finite_int_iff_nat_abs_finite {a b : ℤ} : finite a b ↔ finite a.nat_abs b.nat_abs :=
begin
  rw [finite_def, finite_def],
  conv in (a ^ _ ∣ b)
    { rw [← int.nat_abs_dvd_abs_iff, int.nat_abs_pow, ← pow_eq_pow] }
end

lemma finite_int_iff {a b : ℤ} : finite a b ↔ (a.nat_abs ≠ 1 ∧ b ≠ 0) :=
begin
  have := int.nat_abs_eq a,
  have := @int.nat_abs_ne_zero_of_ne_zero b,
  rw [finite_int_iff_nat_abs_finite, finite_nat_iff, nat.pos_iff_ne_zero'],
  split; finish
end

instance decidable_nat : decidable_rel (λ a b : ℕ, (multiplicity a b).dom) :=
λ a b, decidable_of_iff _ finite_nat_iff.symm

instance decidable_int : decidable_rel (λ a b : ℤ, (multiplicity a b).dom) :=
λ a b, decidable_of_iff _ finite_int_iff.symm

end comm_semiring

section comm_ring

variables [comm_ring α] [decidable_rel ((∣) : α → α → Prop)]

local attribute [instance, priority 0] classical.prop_decidable

@[simp] protected lemma neg (a b : α) : multiplicity a (-b) = multiplicity a b :=
roption.ext' (by simp only [multiplicity]; conv in (_ ∣ - _) {rw dvd_neg})
  (λ h₁ h₂, enat.coe_inj.1 (by rw [enat.coe_get]; exact
    eq.symm (unique ((dvd_neg _ _).2 (pow_multiplicity_dvd _))
      (mt (dvd_neg _ _).1 (is_greatest' _ (lt_succ_self _))))))

end comm_ring

section integral_domain

variables [integral_domain α] [decidable_rel ((∣) : α → α → Prop)]

@[simp] lemma multiplicity_self {a : α} (ha : ¬is_unit a) (ha0 : a ≠ 0) :
  multiplicity a a = 1 :=
eq_some_iff.2 ⟨by simp, λ ⟨b, hb⟩, ha (is_unit_iff_dvd_one.2
  ⟨b, (domain.mul_left_inj ha0).1 $ by clear _fun_match;
    simpa [_root_.pow_succ, mul_assoc] using hb⟩)⟩

@[simp] lemma get_multiplicity_self {a : α} (ha : finite a a) :
  get (multiplicity a a) ha = 1 :=
roption.get_eq_iff_eq_some.2 (eq_some_iff.2
  ⟨by simp, λ ⟨b, hb⟩,
    by rw [← mul_one a, _root_.pow_add, _root_.pow_one, mul_assoc, mul_assoc,
        domain.mul_left_inj (ne_zero_of_finite ha)] at hb;
      exact mt is_unit_iff_dvd_one.2 (not_unit_of_finite ha)
        ⟨b, by clear _fun_match; simp * at *⟩⟩)

lemma finite_mul_aux {p : α} (hp : prime p) : ∀ {n m : ℕ} {a b : α},
  ¬p ^ (n + 1) ∣ a → ¬p ^ (m + 1) ∣ b → ¬p ^ (n + m + 1) ∣ a * b
| n m := λ a b ha hb ⟨s, hs⟩,
  have p ∣ a * b, from ⟨p ^ (n + m) * s,
    by simp [hs, _root_.pow_add, mul_comm, mul_assoc, mul_left_comm]⟩,
  (hp.2.2 a b this).elim
    (λ ⟨x, hx⟩, have hn0 : 0 < n,
        from nat.pos_of_ne_zero (λ hn0, by clear _fun_match _fun_match; simpa [hx, hn0] using ha),
      have wf : (n - 1) < n, from nat.sub_lt_self hn0 dec_trivial,
      have hpx : ¬ p ^ (n - 1 + 1) ∣ x,
        from λ ⟨y, hy⟩, ha (hx.symm ▸ ⟨y, (domain.mul_left_inj hp.1).1
          $ by rw [nat.sub_add_cancel hn0] at hy;
            simp [hy, _root_.pow_add, mul_comm, mul_assoc, mul_left_comm]⟩),
      have 1 ≤ n + m, from le_trans hn0 (le_add_right n m),
      finite_mul_aux hpx hb ⟨s, (domain.mul_left_inj hp.1).1 begin
          rw [← nat.sub_add_comm hn0, nat.sub_add_cancel this],
          clear _fun_match _fun_match finite_mul_aux,
          simp [*, mul_comm, mul_assoc, mul_left_comm, _root_.pow_add] at *
        end⟩)
    (λ ⟨x, hx⟩, have hm0 : 0 < m,
        from nat.pos_of_ne_zero (λ hm0, by clear _fun_match _fun_match; simpa [hx, hm0] using hb),
      have wf : (m - 1) < m, from nat.sub_lt_self hm0 dec_trivial,
      have hpx : ¬ p ^ (m - 1 + 1) ∣ x,
        from λ ⟨y, hy⟩, hb (hx.symm ▸ ⟨y, (domain.mul_left_inj hp.1).1
          $ by rw [nat.sub_add_cancel hm0] at hy;
            simp [hy, _root_.pow_add, mul_comm, mul_assoc, mul_left_comm]⟩),
      finite_mul_aux ha hpx ⟨s, (domain.mul_left_inj hp.1).1 begin
          rw [add_assoc, nat.sub_add_cancel hm0],
          clear _fun_match _fun_match finite_mul_aux,
          simp [*, mul_comm, mul_assoc, mul_left_comm, _root_.pow_add] at *
        end⟩)

lemma finite_mul {p a b : α} (hp : prime p) : finite p a → finite p b → finite p (a * b) :=
λ ⟨n, hn⟩ ⟨m, hm⟩, ⟨n + m, finite_mul_aux hp hn hm⟩

lemma finite_mul_iff {p a b : α} (hp : prime p) : finite p (a * b) ↔ finite p a ∧ finite p b :=
⟨λ h, ⟨finite_of_finite_mul_right h, finite_of_finite_mul_left h⟩,
  λ h, finite_mul hp h.1 h.2⟩

lemma finite_pow {p a : α} (hp : prime p) : Π {k : ℕ} (ha : finite p a), finite p (a ^ k)
| 0     ha := ⟨0, by simp [mt is_unit_iff_dvd_one.2 hp.2.1]⟩
| (k+1) ha := by rw [_root_.pow_succ]; exact finite_mul hp ha (finite_pow ha)

protected lemma mul' {p a b : α} (hp : prime p)
  (h : (multiplicity p (a * b)).dom) :
  get (multiplicity p (a * b)) h =
  get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
  get (multiplicity p b) ((finite_mul_iff hp).1 h).2 :=
have hdiva : p ^ get (multiplicity p a) ((finite_mul_iff hp).1 h).1 ∣ a, from pow_multiplicity_dvd _,
have hdivb : p ^ get (multiplicity p b) ((finite_mul_iff hp).1 h).2 ∣ b, from pow_multiplicity_dvd _,
have hpoweq : p ^ (get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
    get (multiplicity p b) ((finite_mul_iff hp).1 h).2) =
    p ^ get (multiplicity p a) ((finite_mul_iff hp).1 h).1 *
    p ^ get (multiplicity p b) ((finite_mul_iff hp).1 h).2,
  by simp [_root_.pow_add],
have hdiv : p ^ (get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
    get (multiplicity p b) ((finite_mul_iff hp).1 h).2) ∣ a * b,
  by rw [hpoweq]; apply mul_dvd_mul; assumption,
have hsucc : ¬p ^ ((get (multiplicity p a) ((finite_mul_iff hp).1 h).1 +
    get (multiplicity p b) ((finite_mul_iff hp).1 h).2) + 1) ∣ a * b,
  from λ h, not_or (is_greatest' _ (lt_succ_self _)) (is_greatest' _ (lt_succ_self _))
    (succ_dvd_or_succ_dvd_of_succ_sum_dvd_mul hp (by convert hdiva)
      (by convert hdivb) h),
by rw [← enat.coe_inj, enat.coe_get, eq_some_iff];
  exact ⟨hdiv, hsucc⟩

local attribute [instance, priority 0] classical.prop_decidable

protected lemma mul {p a b : α} (hp : prime p) :
  multiplicity p (a * b) = multiplicity p a + multiplicity p b :=
if h : finite p a ∧ finite p b then
by rw [← enat.coe_get (finite_iff_dom.1 h.1), ← enat.coe_get (finite_iff_dom.1 h.2),
  ← enat.coe_get (finite_iff_dom.1 (finite_mul hp h.1 h.2)),
    ← enat.coe_add, enat.coe_inj, multiplicity.mul' hp]; refl
else begin
  rw [eq_top_iff_not_finite.2 (mt (finite_mul_iff hp).1 h)],
  cases not_and_distrib.1 h with h h;
    simp [eq_top_iff_not_finite.2 h]
end

protected lemma pow' {p a : α} (hp : prime p) (ha : finite p a) : ∀ {k : ℕ},
  get (multiplicity p (a ^ k)) (finite_pow hp ha) = k * get (multiplicity p a) ha
| 0     := by dsimp [_root_.pow_zero]; simp [one_right hp.2.1]; refl
| (k+1) := by dsimp only [_root_.pow_succ];
  erw [multiplicity.mul' hp, pow', add_mul, one_mul, add_comm]

lemma pow {p a : α} (hp : prime p) : ∀ {k : ℕ},
  multiplicity p (a ^ k) = add_monoid.smul k (multiplicity p a)
| 0        := by simp [one_right hp.2.1]
| (succ k) := by simp [_root_.pow_succ, succ_smul, pow, multiplicity.mul hp]

end integral_domain

end multiplicity

section nat
open multiplicity

lemma multiplicity_eq_zero_of_coprime {p a b : ℕ} (hp : p ≠ 1)
  (hle : multiplicity p a ≤ multiplicity p b)
  (hab : nat.coprime a b) : multiplicity p a = 0 :=
begin
  rw [multiplicity_le_multiplicity_iff] at hle,
  rw [← le_zero_iff_eq, ← not_lt, enat.pos_iff_one_le, ← enat.coe_one,
    ← pow_dvd_iff_le_multiplicity],
  assume h,
  have := nat.dvd_gcd h (hle _ h),
  rw [coprime.gcd_eq_one hab, nat.dvd_one, _root_.pow_one] at this,
  exact hp this
end

end nat


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.nodup
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Erasing duplicates in a multiset.
-/

namespace multiset

/-! ### erase_dup -/

/-- `erase_dup s` removes duplicates from `s`, yielding a `nodup` multiset. -/
def erase_dup {α : Type u_1} [DecidableEq α] (s : multiset α) : multiset α :=
  quot.lift_on s (fun (l : List α) => ↑(list.erase_dup l)) sorry

@[simp] theorem coe_erase_dup {α : Type u_1} [DecidableEq α] (l : List α) : erase_dup ↑l = ↑(list.erase_dup l) :=
  rfl

@[simp] theorem erase_dup_zero {α : Type u_1} [DecidableEq α] : erase_dup 0 = 0 :=
  rfl

@[simp] theorem mem_erase_dup {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} : a ∈ erase_dup s ↔ a ∈ s :=
  quot.induction_on s fun (l : List α) => list.mem_erase_dup

@[simp] theorem erase_dup_cons_of_mem {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} : a ∈ s → erase_dup (a ::ₘ s) = erase_dup s :=
  quot.induction_on s fun (l : List α) (m : a ∈ Quot.mk setoid.r l) => congr_arg coe (list.erase_dup_cons_of_mem m)

@[simp] theorem erase_dup_cons_of_not_mem {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} : ¬a ∈ s → erase_dup (a ::ₘ s) = a ::ₘ erase_dup s :=
  quot.induction_on s fun (l : List α) (m : ¬a ∈ Quot.mk setoid.r l) => congr_arg coe (list.erase_dup_cons_of_not_mem m)

theorem erase_dup_le {α : Type u_1} [DecidableEq α] (s : multiset α) : erase_dup s ≤ s :=
  quot.induction_on s fun (l : List α) => list.sublist.subperm (list.erase_dup_sublist l)

theorem erase_dup_subset {α : Type u_1} [DecidableEq α] (s : multiset α) : erase_dup s ⊆ s :=
  subset_of_le (erase_dup_le s)

theorem subset_erase_dup {α : Type u_1} [DecidableEq α] (s : multiset α) : s ⊆ erase_dup s :=
  fun (a : α) => iff.mpr mem_erase_dup

@[simp] theorem erase_dup_subset' {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} : erase_dup s ⊆ t ↔ s ⊆ t :=
  { mp := subset.trans (subset_erase_dup s), mpr := subset.trans (erase_dup_subset s) }

@[simp] theorem subset_erase_dup' {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} : s ⊆ erase_dup t ↔ s ⊆ t :=
  { mp := fun (h : s ⊆ erase_dup t) => subset.trans h (erase_dup_subset t),
    mpr := fun (h : s ⊆ t) => subset.trans h (subset_erase_dup t) }

@[simp] theorem nodup_erase_dup {α : Type u_1} [DecidableEq α] (s : multiset α) : nodup (erase_dup s) :=
  quot.induction_on s list.nodup_erase_dup

theorem erase_dup_eq_self {α : Type u_1} [DecidableEq α] {s : multiset α} : erase_dup s = s ↔ nodup s := sorry

theorem erase_dup_eq_zero {α : Type u_1} [DecidableEq α] {s : multiset α} : erase_dup s = 0 ↔ s = 0 :=
  { mp := fun (h : erase_dup s = 0) => eq_zero_of_subset_zero (h ▸ subset_erase_dup s),
    mpr := fun (h : s = 0) => Eq.symm h ▸ erase_dup_zero }

@[simp] theorem erase_dup_singleton {α : Type u_1} [DecidableEq α] {a : α} : erase_dup (a ::ₘ 0) = a ::ₘ 0 :=
  iff.mpr erase_dup_eq_self (nodup_singleton a)

theorem le_erase_dup {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} : s ≤ erase_dup t ↔ s ≤ t ∧ nodup s := sorry

theorem erase_dup_ext {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} : erase_dup s = erase_dup t ↔ ∀ (a : α), a ∈ s ↔ a ∈ t := sorry

theorem erase_dup_map_erase_dup_eq {α : Type u_1} {β : Type u_2} [DecidableEq α] [DecidableEq β] (f : α → β) (s : multiset α) : erase_dup (map f (erase_dup s)) = erase_dup (map f s) := sorry

@[simp] theorem erase_dup_nsmul {α : Type u_1} [DecidableEq α] {s : multiset α} {n : ℕ} (h0 : n ≠ 0) : erase_dup (n •ℕ s) = erase_dup s := sorry

theorem nodup.le_erase_dup_iff_le {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} (hno : nodup s) : s ≤ erase_dup t ↔ s ≤ t := sorry

end multiset

theorem multiset.nodup.le_nsmul_iff_le {α : Type u_1} {s : multiset α} {t : multiset α} {n : ℕ} (h : multiset.nodup s) (hn : n ≠ 0) : s ≤ n •ℕ t ↔ s ≤ t := sorry


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.multiset.erase_dup

/-!
# Preparations for defining operations on `finset`.

The operations here ignore multiplicities,
and preparatory for defining the corresponding operations on `finset`.
-/

namespace multiset
open list

variables {α : Type*} [decidable_eq α]
/-! ### finset insert -/

/-- `ndinsert a s` is the lift of the list `insert` operation. This operation
  does not respect multiplicities, unlike `cons`, but it is suitable as
  an insert operation on `finset`. -/
def ndinsert (a : α) (s : multiset α) : multiset α :=
quot.lift_on s (λ l, (l.insert a : multiset α))
  (λ s t p, quot.sound (p.insert a))

@[simp] theorem coe_ndinsert (a : α) (l : list α) : ndinsert a l = (insert a l : list α) := rfl

@[simp] theorem ndinsert_zero (a : α) : ndinsert a 0 = a ::ₘ 0 := rfl

@[simp, priority 980]
theorem ndinsert_of_mem {a : α} {s : multiset α} : a ∈ s → ndinsert a s = s :=
quot.induction_on s $ λ l h, congr_arg coe $ insert_of_mem h

@[simp, priority 980]
theorem ndinsert_of_not_mem {a : α} {s : multiset α} : a ∉ s → ndinsert a s = a ::ₘ s :=
quot.induction_on s $ λ l h, congr_arg coe $ insert_of_not_mem h

@[simp] theorem mem_ndinsert {a b : α} {s : multiset α} : a ∈ ndinsert b s ↔ a = b ∨ a ∈ s :=
quot.induction_on s $ λ l, mem_insert_iff

@[simp] theorem le_ndinsert_self (a : α) (s : multiset α) : s ≤ ndinsert a s :=
quot.induction_on s $ λ l, (sublist_of_suffix $ suffix_insert _ _).subperm

@[simp] theorem mem_ndinsert_self (a : α) (s : multiset α) : a ∈ ndinsert a s :=
mem_ndinsert.2 (or.inl rfl)

theorem mem_ndinsert_of_mem {a b : α} {s : multiset α} (h : a ∈ s) : a ∈ ndinsert b s :=
mem_ndinsert.2 (or.inr h)

@[simp, priority 980]
theorem length_ndinsert_of_mem {a : α} {s : multiset α} (h : a ∈ s) :
  card (ndinsert a s) = card s :=
by simp [h]

@[simp, priority 980]
theorem length_ndinsert_of_not_mem {a : α} {s : multiset α} (h : a ∉ s) :
  card (ndinsert a s) = card s + 1 :=
by simp [h]

theorem erase_dup_cons {a : α} {s : multiset α} :
  erase_dup (a ::ₘ s) = ndinsert a (erase_dup s) :=
by by_cases a ∈ s; simp [h]

theorem nodup_ndinsert (a : α) {s : multiset α} : nodup s → nodup (ndinsert a s) :=
quot.induction_on s $ λ l, nodup_insert

theorem ndinsert_le {a : α} {s t : multiset α} : ndinsert a s ≤ t ↔ s ≤ t ∧ a ∈ t :=
⟨λ h, ⟨le_trans (le_ndinsert_self _ _) h, mem_of_le h (mem_ndinsert_self _ _)⟩,
 λ ⟨l, m⟩, if h : a ∈ s then by simp [h, l] else
   by rw [ndinsert_of_not_mem h, ← cons_erase m, cons_le_cons_iff,
          ← le_cons_of_not_mem h, cons_erase m]; exact l⟩

lemma attach_ndinsert (a : α) (s : multiset α) :
  (s.ndinsert a).attach =
    ndinsert ⟨a, mem_ndinsert_self a s⟩ (s.attach.map $ λp, ⟨p.1, mem_ndinsert_of_mem p.2⟩) :=
have eq : ∀h : ∀(p : {x // x ∈ s}), p.1 ∈ s,
    (λ (p : {x // x ∈ s}), ⟨p.val, h p⟩ : {x // x ∈ s} → {x // x ∈ s}) = id, from
  assume h, funext $ assume p, subtype.eq rfl,
have ∀t (eq : s.ndinsert a = t), t.attach = ndinsert ⟨a, eq ▸ mem_ndinsert_self a s⟩
  (s.attach.map $ λp, ⟨p.1, eq ▸ mem_ndinsert_of_mem p.2⟩),
begin
  intros t ht,
  by_cases a ∈ s,
  { rw [ndinsert_of_mem h] at ht,
    subst ht,
    rw [eq, map_id, ndinsert_of_mem (mem_attach _ _)] },
  { rw [ndinsert_of_not_mem h] at ht,
    subst ht,
    simp [attach_cons, h] }
end,
this _ rfl

@[simp] theorem disjoint_ndinsert_left {a : α} {s t : multiset α} :
  disjoint (ndinsert a s) t ↔ a ∉ t ∧ disjoint s t :=
iff.trans (by simp [disjoint]) disjoint_cons_left

@[simp] theorem disjoint_ndinsert_right {a : α} {s t : multiset α} :
  disjoint s (ndinsert a t) ↔ a ∉ s ∧ disjoint s t :=
by rw [disjoint_comm, disjoint_ndinsert_left]; tauto

/-! ### finset union -/

/-- `ndunion s t` is the lift of the list `union` operation. This operation
  does not respect multiplicities, unlike `s ∪ t`, but it is suitable as
  a union operation on `finset`. (`s ∪ t` would also work as a union operation
  on finset, but this is more efficient.) -/
def ndunion (s t : multiset α) : multiset α :=
quotient.lift_on₂ s t (λ l₁ l₂, (l₁.union l₂ : multiset α)) $ λ v₁ v₂ w₁ w₂ p₁ p₂,
  quot.sound $ p₁.union p₂

@[simp] theorem coe_ndunion (l₁ l₂ : list α) : @ndunion α _ l₁ l₂ = (l₁ ∪ l₂ : list α) := rfl

@[simp] theorem zero_ndunion (s : multiset α) : ndunion 0 s = s :=
quot.induction_on s $ λ l, rfl

@[simp] theorem cons_ndunion (s t : multiset α) (a : α) :
  ndunion (a ::ₘ s) t = ndinsert a (ndunion s t) :=
quotient.induction_on₂ s t $ λ l₁ l₂, rfl

@[simp] theorem mem_ndunion {s t : multiset α} {a : α} : a ∈ ndunion s t ↔ a ∈ s ∨ a ∈ t :=
quotient.induction_on₂ s t $ λ l₁ l₂, list.mem_union

theorem le_ndunion_right (s t : multiset α) : t ≤ ndunion s t :=
quotient.induction_on₂ s t $ λ l₁ l₂,
(sublist_of_suffix $ suffix_union_right _ _).subperm

theorem subset_ndunion_right (s t : multiset α) : t ⊆ ndunion s t :=
subset_of_le (le_ndunion_right s t)

theorem ndunion_le_add (s t : multiset α) : ndunion s t ≤ s + t :=
quotient.induction_on₂ s t $ λ l₁ l₂, (union_sublist_append _ _).subperm

theorem ndunion_le {s t u : multiset α} : ndunion s t ≤ u ↔ s ⊆ u ∧ t ≤ u :=
multiset.induction_on s (by simp)
  (by simp [ndinsert_le, and_comm, and.left_comm] {contextual := tt})

theorem subset_ndunion_left (s t : multiset α) : s ⊆ ndunion s t :=
λ a h, mem_ndunion.2 $ or.inl h

theorem le_ndunion_left {s} (t : multiset α) (d : nodup s) : s ≤ ndunion s t :=
(le_iff_subset d).2 $ subset_ndunion_left _ _

theorem ndunion_le_union (s t : multiset α) : ndunion s t ≤ s ∪ t :=
ndunion_le.2 ⟨subset_of_le (le_union_left _ _), le_union_right _ _⟩

theorem nodup_ndunion (s : multiset α) {t : multiset α} : nodup t → nodup (ndunion s t) :=
quotient.induction_on₂ s t $ λ l₁ l₂, list.nodup_union _

@[simp, priority 980]
theorem ndunion_eq_union {s t : multiset α} (d : nodup s) : ndunion s t = s ∪ t :=
le_antisymm (ndunion_le_union _ _) $ union_le (le_ndunion_left _ d) (le_ndunion_right _ _)

theorem erase_dup_add (s t : multiset α) : erase_dup (s + t) = ndunion s (erase_dup t) :=
quotient.induction_on₂ s t $ λ l₁ l₂, congr_arg coe $ erase_dup_append _ _

/-! ### finset inter -/

/-- `ndinter s t` is the lift of the list `∩` operation. This operation
  does not respect multiplicities, unlike `s ∩ t`, but it is suitable as
  an intersection operation on `finset`. (`s ∩ t` would also work as a union operation
  on finset, but this is more efficient.) -/
def ndinter (s t : multiset α) : multiset α := filter (∈ t) s

@[simp] theorem coe_ndinter (l₁ l₂ : list α) : @ndinter α _ l₁ l₂ = (l₁ ∩ l₂ : list α) := rfl

@[simp] theorem zero_ndinter (s : multiset α) : ndinter 0 s = 0 := rfl

@[simp, priority 980]
theorem cons_ndinter_of_mem {a : α} (s : multiset α) {t : multiset α} (h : a ∈ t) :
  ndinter (a ::ₘ s) t = a ::ₘ (ndinter s t) := by simp [ndinter, h]

@[simp, priority 980]
theorem ndinter_cons_of_not_mem {a : α} (s : multiset α) {t : multiset α} (h : a ∉ t) :
  ndinter (a ::ₘ s) t = ndinter s t := by simp [ndinter, h]

@[simp] theorem mem_ndinter {s t : multiset α} {a : α} : a ∈ ndinter s t ↔ a ∈ s ∧ a ∈ t :=
mem_filter

@[simp]
theorem nodup_ndinter {s : multiset α} (t : multiset α) : nodup s → nodup (ndinter s t) :=
nodup_filter _

theorem le_ndinter {s t u : multiset α} : s ≤ ndinter t u ↔ s ≤ t ∧ s ⊆ u :=
by simp [ndinter, le_filter, subset_iff]

theorem ndinter_subset_left (s t : multiset α) : ndinter s t ⊆ s :=
subset_of_le (ndinter_le_left s t)

theorem ndinter_subset_right (s t : multiset α) : ndinter s t ⊆ t :=
(le_ndinter.1 (le_refl _)).2

theorem ndinter_le_right {s} (t : multiset α) (d : nodup s) : ndinter s t ≤ t :=
(le_iff_subset $ nodup_ndinter _ d).2 (ndinter_subset_right _ _)

theorem inter_le_ndinter (s t : multiset α) : s ∩ t ≤ ndinter s t :=
le_ndinter.2 ⟨inter_le_left _ _, subset_of_le $ inter_le_right _ _⟩

@[simp, priority 980]
theorem ndinter_eq_inter {s t : multiset α} (d : nodup s) : ndinter s t = s ∩ t :=
le_antisymm (le_inter (ndinter_le_left _ _) (ndinter_le_right _ d)) (inter_le_ndinter _ _)

theorem ndinter_eq_zero_iff_disjoint {s t : multiset α} : ndinter s t = 0 ↔ disjoint s t :=
by rw ← subset_zero; simp [subset_iff, disjoint]

end multiset


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison

! This file was ported from Lean 3 source module category_theory.monoidal.types
! leanprover-community/mathlib commit 3225926b9f2c1e31b4d4329aec72f69555270282
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monoidal.OfChosenFiniteProducts
import Mathbin.CategoryTheory.Limits.Shapes.Types
import Mathbin.Logic.Equiv.Fin

/-!
# The category of types is a symmetric monoidal category
-/

open CategoryTheory

open CategoryTheory.Limits

open Tactic

universe v u

namespace CategoryTheory

instance typesMonoidal : MonoidalCategory.{u} (Type u) :=
  monoidalOfChosenFiniteProducts Types.terminalLimitCone Types.binaryProductLimitCone
#align category_theory.types_monoidal CategoryTheory.typesMonoidal

instance typesSymmetric : SymmetricCategory.{u} (Type u) :=
  symmetricOfChosenFiniteProducts Types.terminalLimitCone Types.binaryProductLimitCone
#align category_theory.types_symmetric CategoryTheory.typesSymmetric

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensor_apply {W X Y Z : Type u} (f : W ⟶ X) (g : Y ⟶ Z) (p : W ⊗ Y) :
    (f ⊗ g) p = (f p.1, g p.2) :=
  rfl
#align category_theory.tensor_apply CategoryTheory.tensor_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem leftUnitor_hom_apply {X : Type u} {x : X} {p : PUnit} :
    ((λ_ X).Hom : 𝟙_ (Type u) ⊗ X → X) (p, x) = x :=
  rfl
#align category_theory.left_unitor_hom_apply CategoryTheory.leftUnitor_hom_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem leftUnitor_inv_apply {X : Type u} {x : X} :
    ((λ_ X).inv : X ⟶ 𝟙_ (Type u) ⊗ X) x = (PUnit.unit, x) :=
  rfl
#align category_theory.left_unitor_inv_apply CategoryTheory.leftUnitor_inv_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem rightUnitor_hom_apply {X : Type u} {x : X} {p : PUnit} :
    ((ρ_ X).Hom : X ⊗ 𝟙_ (Type u) → X) (x, p) = x :=
  rfl
#align category_theory.right_unitor_hom_apply CategoryTheory.rightUnitor_hom_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem rightUnitor_inv_apply {X : Type u} {x : X} :
    ((ρ_ X).inv : X ⟶ X ⊗ 𝟙_ (Type u)) x = (x, PUnit.unit) :=
  rfl
#align category_theory.right_unitor_inv_apply CategoryTheory.rightUnitor_inv_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem associator_hom_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
    ((α_ X Y Z).Hom : (X ⊗ Y) ⊗ Z → X ⊗ Y ⊗ Z) ((x, y), z) = (x, (y, z)) :=
  rfl
#align category_theory.associator_hom_apply CategoryTheory.associator_hom_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem associator_inv_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
    ((α_ X Y Z).inv : X ⊗ Y ⊗ Z → (X ⊗ Y) ⊗ Z) (x, (y, z)) = ((x, y), z) :=
  rfl
#align category_theory.associator_inv_apply CategoryTheory.associator_inv_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem braiding_hom_apply {X Y : Type u} {x : X} {y : Y} :
    ((β_ X Y).Hom : X ⊗ Y → Y ⊗ X) (x, y) = (y, x) :=
  rfl
#align category_theory.braiding_hom_apply CategoryTheory.braiding_hom_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem braiding_inv_apply {X Y : Type u} {x : X} {y : Y} :
    ((β_ X Y).inv : Y ⊗ X → X ⊗ Y) (y, x) = (x, y) :=
  rfl
#align category_theory.braiding_inv_apply CategoryTheory.braiding_inv_apply

open Opposite

open MonoidalCategory

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- `(𝟙_ C ⟶ -)` is a lax monoidal functor to `Type`. -/
def coyonedaTensorUnit (C : Type u) [Category.{v} C] [MonoidalCategory C] :
    LaxMonoidalFunctor C (Type v) :=
  { coyoneda.obj (op (𝟙_ C)) with
    ε := fun p => 𝟙 _
    μ := fun X Y p => (λ_ (𝟙_ C)).inv ≫ (p.1 ⊗ p.2)
    μ_natural' := by tidy
    associativity' := fun X Y Z => by
      ext ⟨⟨f, g⟩, h⟩; dsimp at f g h
      dsimp; simp only [iso.cancel_iso_inv_left, category.assoc]
      conv_lhs =>
        rw [← category.id_comp h, tensor_comp, category.assoc, associator_naturality, ←
          category.assoc, unitors_inv_equal, triangle_assoc_comp_right_inv]
      conv_rhs => rw [← category.id_comp f, tensor_comp]
    left_unitality' := by tidy
    right_unitality' := fun X => by
      ext ⟨f, ⟨⟩⟩; dsimp at f
      dsimp; simp only [category.assoc]
      rw [right_unitor_naturality, unitors_inv_equal, iso.inv_hom_id_assoc] }
#align category_theory.coyoneda_tensor_unit CategoryTheory.coyonedaTensorUnit

noncomputable section

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
-- We don't yet have an API for tensor products indexed by finite ordered types,
-- but it would be nice to state how monoidal functors preserve these.
/-- If `F` is a monoidal functor out of `Type`, it takes the (n+1)st cartesian power
of a type to the image of that type, tensored with the image of the nth cartesian power. -/
def MonoidalFunctor.mapPi {C : Type _} [Category C] [MonoidalCategory C]
    (F : MonoidalFunctor (Type _) C) (n : ℕ) (β : Type _) :
    F.obj (Fin (n + 1) → β) ≅ F.obj β ⊗ F.obj (Fin n → β) :=
  Functor.mapIso _ (Equiv.piFinSucc n β).toIso ≪≫ (asIso (F.μ β (Fin n → β))).symm
#align category_theory.monoidal_functor.map_pi CategoryTheory.MonoidalFunctor.mapPi

end CategoryTheory


/-
Copyright (c) 2019 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Mario Carneiro, Isabel Longbottom, Scott Morrison
-/
import set_theory.pgame

/-!
# Combinatorial games.

In this file we define the quotient of pre-games by the equivalence relation `p ≈ q ↔ p ≤ q ∧ q ≤
p`, and construct an instance `add_comm_group game`, as well as an instance `partial_order game`
(although note carefully the warning that the `<` field in this instance is not the usual relation
on combinatorial games).
-/

universes u

local infix ` ≈ ` := pgame.equiv

instance pgame.setoid : setoid pgame :=
⟨λ x y, x ≈ y,
 λ x, pgame.equiv_refl _,
 λ x y, pgame.equiv_symm,
 λ x y z, pgame.equiv_trans⟩

/-- The type of combinatorial games. In ZFC, a combinatorial game is constructed from
  two sets of combinatorial games that have been constructed at an earlier
  stage. To do this in type theory, we say that a combinatorial pre-game is built
  inductively from two families of combinatorial games indexed over any type
  in Type u. The resulting type `pgame.{u}` lives in `Type (u+1)`,
  reflecting that it is a proper class in ZFC.
  A combinatorial game is then constructed by quotienting by the equivalence
  `x ≈ y ↔ x ≤ y ∧ y ≤ x`. -/
def game := quotient pgame.setoid

open pgame

namespace game

/-- The relation `x ≤ y` on games. -/
def le : game → game → Prop :=
quotient.lift₂ (λ x y, x ≤ y) (λ x₁ y₁ x₂ y₂ hx hy, propext (le_congr hx hy))

instance : has_le game :=
{ le := le }

@[refl] theorem le_refl : ∀ x : game, x ≤ x :=
by { rintro ⟨x⟩, apply pgame.le_refl }
@[trans] theorem le_trans : ∀ x y z : game, x ≤ y → y ≤ z → x ≤ z :=
by { rintro ⟨x⟩ ⟨y⟩ ⟨z⟩, apply pgame.le_trans }
theorem le_antisymm : ∀ x y : game, x ≤ y → y ≤ x → x = y :=
by { rintro ⟨x⟩ ⟨y⟩ h₁ h₂, apply quot.sound, exact ⟨h₁, h₂⟩ }

/-- The relation `x < y` on games. -/
-- We don't yet make this into an instance, because it will conflict with the (incorrect) notion
-- of `<` provided by `partial_order` later.
def lt : game → game → Prop :=
quotient.lift₂ (λ x y, x < y) (λ x₁ y₁ x₂ y₂ hx hy, propext (lt_congr hx hy))

theorem not_le : ∀ {x y : game}, ¬ (x ≤ y) ↔ (lt y x) :=
by { rintro ⟨x⟩ ⟨y⟩, exact not_le }

instance : has_zero game := ⟨⟦0⟧⟩
instance : inhabited game := ⟨0⟩
instance : has_one game := ⟨⟦1⟧⟩

/-- The negation of `{L | R}` is `{-R | -L}`. -/
def neg : game → game :=
quot.lift (λ x, ⟦-x⟧) (λ x y h, quot.sound (@neg_congr x y h))

instance : has_neg game :=
{ neg := neg }

/-- The sum of `x = {xL | xR}` and `y = {yL | yR}` is `{xL + y, x + yL | xR + y, x + yR}`. -/
def add : game → game → game :=
quotient.lift₂ (λ x y : pgame, ⟦x + y⟧) (λ x₁ y₁ x₂ y₂ hx hy, quot.sound (pgame.add_congr hx hy))

instance : has_add game := ⟨add⟩

theorem add_assoc : ∀ (x y z : game), (x + y) + z = x + (y + z) :=
begin
  rintros ⟨x⟩ ⟨y⟩ ⟨z⟩,
  apply quot.sound,
  exact add_assoc_equiv
end

instance : add_semigroup game.{u} :=
{ add_assoc := add_assoc,
  ..game.has_add }

theorem add_zero : ∀ (x : game), x + 0 = x :=
begin
  rintro ⟨x⟩,
  apply quot.sound,
  apply add_zero_equiv
end
theorem zero_add : ∀ (x : game), 0 + x = x :=
begin
  rintro ⟨x⟩,
  apply quot.sound,
  apply zero_add_equiv
end

instance : add_monoid game :=
{ add_zero := add_zero,
  zero_add := zero_add,
  ..game.has_zero,
  ..game.add_semigroup }

theorem add_left_neg : ∀ (x : game), (-x) + x = 0 :=
begin
  rintro ⟨x⟩,
  apply quot.sound,
  apply add_left_neg_equiv
end

instance : add_group game :=
{ add_left_neg := add_left_neg,
  ..game.has_neg,
  ..game.add_monoid }

theorem add_comm : ∀ (x y : game), x + y = y + x :=
begin
  rintros ⟨x⟩ ⟨y⟩,
  apply quot.sound,
  exact add_comm_equiv
end

instance : add_comm_semigroup game :=
{ add_comm := add_comm,
  ..game.add_semigroup }

instance : add_comm_group game :=
{ ..game.add_comm_semigroup,
  ..game.add_group }

theorem add_le_add_left : ∀ (a b : game), a ≤ b → ∀ (c : game), c + a ≤ c + b :=
begin rintro ⟨a⟩ ⟨b⟩ h ⟨c⟩, apply pgame.add_le_add_left h, end

-- While it is very tempting to define a `partial_order` on games, and prove
-- that games form an `ordered_add_comm_group`, it is a bit dangerous.

-- The relations `≤` and `<` on games do not satisfy
-- `lt_iff_le_not_le : ∀ a b : α, a < b ↔ (a ≤ b ∧ ¬ b ≤ a)`
-- (Consider `a = 0`, `b = star`.)
-- (`lt_iff_le_not_le` is satisfied by surreal numbers, however.)
-- Thus we can not use `<` when defining a `partial_order`.

-- Because of this issue, we define the `partial_order` and `ordered_add_comm_group` instances,
-- but do not actually mark them as instances, for safety.

/-- The `<` operation provided by this partial order is not the usual `<` on games! -/
def game_partial_order : partial_order game :=
{ le_refl := le_refl,
  le_trans := le_trans,
  le_antisymm := le_antisymm,
  ..game.has_le }

/-- The `<` operation provided by this `ordered_add_comm_group` is not the usual `<` on games! -/
def ordered_add_comm_group_game : ordered_add_comm_group game :=
{ add_le_add_left := add_le_add_left,
  ..game.add_comm_group,
  ..game_partial_order }

end game


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem numbertheory_prmdvsneqnsqmodpeq0
  (n : ℤ)
  (p : ℕ)
  (h₀ : nat.prime p) :
  ↑p ∣ n ↔ (n^2) % p = 0 :=
begin
  simp [nat.dvd_prime_pow (show nat.prime p, from h₀), pow_succ],
  simp only [int.coe_nat_dvd_right, int.coe_nat_dvd_left, int.nat_abs_mul],
  rw nat.prime.dvd_mul,
  { tauto },
  assumption,
end


import measure_theory.interval_integral
import analysis.special_functions.pow

open_locale real

example : 4 * ∫ (x : ℝ) in (0:ℝ)..1, real.sqrt(1 - x^2) = π :=
begin
  have : deriv (λ x : ℝ, 1/2 * (real.arcsin x + x * real.sqrt(1 - x^2) ) ) = λ x, real.sqrt(1 - x^2),
  { ext,
    rw deriv_const_mul,
    rw deriv_add,
    simp only [one_div, real.deriv_arcsin],
    rw deriv_mul,
    simp only [one_mul, deriv_id''],
    rw deriv_sqrt,
    simp only [differentiable_at_const, mul_one, zero_sub, deriv_sub, differentiable_at_id', deriv_pow'', nat.cast_bit0, deriv_id'',
  deriv_const', pow_one, differentiable_at.pow, nat.cast_one],
    rw neg_div,
    rw mul_div_mul_left _ _ (show (2 : ℝ) ≠ 0, by norm_num),
    field_simp,
    rw add_left_comm,
    rw div_add_div_same,
    sorry
  },
  sorry
end


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

import tactic.norm_cast
import data.rat.cast

/-!
# A tactic to shift `ℕ` or `ℤ` goals to `ℚ`

Note that this file is following from `zify`.

Division in `ℕ` and `ℤ` is not always working fine (e.g. (5 : ℕ) / 2 = 2), so it's easier
to work in `ℚ`, where division and subtraction are well behaved. `qify` can be used to cast goals
and hypotheses about natural numbers or integers to rational numbers. It makes use of `push_cast`,
part of the `norm_cast` family, to simplify these goals.

## Implementation notes

`qify` is extensible, using the attribute `@[qify]` to label lemmas used for moving propositions
from `ℕ` or `ℤ` to `ℚ`.
`qify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pq (a₁ : ℚ) ... (aₙ : ℚ) ↔ Pn a₁ ... aₙ`.
For example, `rat.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `qify` lemma.

`qify` is very nearly just `simp only with qify push_cast`. There are a few minor differences:
* `qify` lemmas are used in the opposite order of the standard simp form.
  E.g. we will rewrite with `rat.coe_nat_le_coe_nat_iff` from right to left.
* `qify` should fail if no `qify` lemma applies (i.e. it was unable to shift any proposition to ℚ).
  However, once this succeeds, it does not necessarily need to rewrite with any `push_cast` rules.
-/

open tactic

namespace qify

/--
The `qify` attribute is used by the `qify` tactic. It applies to lemmas that shift propositions
from `nat` or `int` to `rat`.

`qify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pq (a₁ : ℚ) ... (aₙ : ℚ) ↔ Pn a₁ ... aₙ` or
 `∀ a₁ ... aₙ : ℤ, Pq (a₁ : ℚ) ... (aₙ : ℚ) ↔ Pz a₁ ... aₙ`.
For example, `rat.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `qify` lemma.
-/
@[user_attribute]
meta def qify_attr : user_attribute simp_lemmas unit :=
{ name := `qify,
  descr := "Used to tag lemmas for use in the `qify` tactic",
  cache_cfg :=
    { mk_cache :=
        λ ns, mmap (λ n, do c ← mk_const n, return (c, tt)) ns >>= simp_lemmas.mk.append_with_symm,
      dependencies := [] } }

/--
Given an expression `e`, `lift_to_q e` looks for subterms of `e` that are propositions "about"
natural numbers or integers and change them to propositions about rational numbers.

Returns an expression `e'` and a proof that `e = e'`.

Includes `ge_iff_le` and `gt_iff_lt` in the simp set. These can't be tagged with `qify` as we
want to use them in the "forward", not "backward", direction.
-/
meta def lift_to_q (e : expr) : tactic (expr × expr) :=
do sl ← qify_attr.get_cache,
   sl ← sl.add_simp `ge_iff_le, sl ← sl.add_simp `gt_iff_lt,
   (e', prf, _) ← simplify sl [] e,
   return (e', prf)

@[qify] lemma rat.coe_nat_le_coe_nat_iff (a b : ℕ) : (a : ℚ) ≤ b ↔ a ≤ b := by simp
@[qify] lemma rat.coe_nat_lt_coe_nat_iff (a b : ℕ) : (a : ℚ) < b ↔ a < b := by simp
@[qify] lemma rat.coe_nat_eq_coe_nat_iff (a b : ℕ) : (a : ℚ) = b ↔ a = b := by simp
@[qify] lemma rat.coe_nat_ne_coe_nat_iff (a b : ℕ) : (a : ℚ) ≠ b ↔ a ≠ b := by simp

@[qify] lemma rat.coe_int_le_coe_int_iff (a b : ℤ) : (a : ℚ) ≤ b ↔ a ≤ b := by simp
@[qify] lemma rat.coe_int_lt_coe_int_iff (a b : ℤ) : (a : ℚ) < b ↔ a < b := by simp
@[qify] lemma rat.coe_int_eq_coe_int_iff (a b : ℤ) : (a : ℚ) = b ↔ a = b := by simp
@[qify] lemma rat.coe_int_ne_coe_int_iff (a b : ℤ) : (a : ℚ) ≠ b ↔ a ≠ b := by simp

end qify

/--
`qify extra_lems e` is used to shift propositions in `e` from `ℕ` or `ℤ` to `ℚ`.
This is often useful since `ℚ` has well-behaved division and subtraction.

The list of extra lemmas is used in the `push_cast` step.

Returns an expression `e'` and a proof that `e = e'`.-/
meta def tactic.qify (extra_lems : list simp_arg_type) : expr → tactic (expr × expr) := λ q,
do (q1, p1) ← qify.lift_to_q q <|> fail "failed to find an applicable qify lemma",
   (q2, p2) ← norm_cast.derive_push_cast extra_lems q1,
   prod.mk q2 <$> mk_eq_trans p1 p2

/--
A variant of `tactic.qify` that takes `h`, a proof of a proposition about natural numbers
or integers, and returns a proof of the qified version of that propositon.
-/
meta def tactic.qify_proof (extra_lems : list simp_arg_type) (h : expr) : tactic expr :=
do (_, pf) ← infer_type h >>= tactic.qify extra_lems,
   mk_eq_mp pf h

section

setup_tactic_parser

/--
The `qify` tactic is used to shift propositions from `ℕ` or `ℤ` to `ℚ`.
This is often useful since `ℚ` has well-behaved division and subtraction.

```lean
example (a b c : ℕ) (x y z : ℤ) (h : ¬ x*y*z < 0) : c < a + 3*b :=
begin
  qify,
  qify at h,
  /-
  h : ¬↑x * ↑y * ↑z < 0
  ⊢ ↑c < ↑a + 3 * ↑b
  -/
end
```

`qify` can be given extra lemmas to use in simplification. This is especially useful in the
presence of subtraction and division: passing `≤` or `∣` arguments will allow `push_cast`
to do more work.
```
example (a b c : ℕ) (h : a - b < c) (hab : b ≤ a) : false :=
begin
  qify [hab] at h,
  /- h : ↑a - ↑b < ↑c -/
end
```

```
example (a b c : ℕ) (h : a / b = c) (hab : b ∣ a) : false :=
begin
  qify [hab] at h,
  /- h : ↑a / ↑b = ↑c -/
end
```

`qify` makes use of the `@[qify]` attribute to move propositions,
and the `push_cast` tactic to simplify the `ℚ`-valued expressions.
-/
meta def tactic.interactive.qify (sl : parse simp_arg_list) (l : parse location) : tactic unit :=
do locs ← l.get_locals,
replace_at (tactic.qify sl) locs l.include_goal >>= guardb

end

add_tactic_doc
{ name := "qify",
  category := doc_category.attr,
  decl_names := [`qify.qify_attr],
  tags := ["coercions", "transport"] }

add_tactic_doc
{ name := "qify",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.qify],
  tags := ["coercions", "transport"] }