/-
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

! This file was ported from Lean 3 source module order.initial_seg
! leanprover-community/mathlib commit 1a313d8bba1bad05faba71a4a4e9742ab5bd9efd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.RelIso.Set
import Mathlib.Order.WellFounded
/-!
# Initial and principal segments

This file defines initial and principal segments.

## Main definitions

* `InitialSeg 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`.
* `PrincipalSeg 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 `InitialSeg` 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
`InitialSeg r s`, and denoted by `r ≼i s`.
-/

variable {α : 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 InitialSeg {α β : Type _} (r : α → α → Prop) (s : β → β → Prop) extends r ↪r s where
  /-- The order embedding is an initial segment -/
  init' : ∀ a b, s b (toRelEmbedding a) → ∃ a', toRelEmbedding a' = b
#align initial_seg InitialSeg

-- Porting notes: Deleted `scoped[InitialSeg]`
/-- 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`. -/
infixl:25 " ≼i " => InitialSeg

namespace InitialSeg

instance : Coe (r ≼i s) (r ↪r s) :=
  ⟨InitialSeg.toRelEmbedding⟩

instance : EmbeddingLike (r ≼i s) α β :=
  { coe := fun f => f.toFun
    coe_injective' := by
      rintro ⟨f, hf⟩ ⟨g, hg⟩ h
      congr with x
      exact congr_fun h x,
    injective' := fun f => f.inj' }

@[ext] lemma ext {f g : r ≼i s} (h : ∀ x, f x = g x) : f = g :=
  FunLike.ext f g h
#align initial_seg.ext InitialSeg.ext

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

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

theorem map_rel_iff (f : r ≼i s) : s (f a) (f b) ↔ r a b :=
  f.map_rel_iff'
#align initial_seg.map_rel_iff InitialSeg.map_rel_iff

theorem init_iff (f : r ≼i s) {a : α} {b : β} : s b (f a) ↔ ∃ a', f a' = b ∧ r a' a :=
  ⟨fun h => by
    rcases f.init h with ⟨a', rfl⟩
    exact ⟨a', rfl, f.map_rel_iff.1 h⟩,
    fun ⟨a', e, h⟩ => e ▸ f.map_rel_iff.2 h⟩
#align initial_seg.init_iff InitialSeg.init_iff

/-- An order isomorphism is an initial segment -/
def ofIso (f : r ≃r s) : r ≼i s :=
  ⟨f, fun _ b _ => ⟨f.symm b, RelIso.apply_symm_apply f _⟩⟩
#align initial_seg.of_iso InitialSeg.ofIso

/-- The identity function shows that `≼i` is reflexive -/
@[refl]
protected def refl (r : α → α → Prop) : r ≼i r :=
  ⟨RelEmbedding.refl _, fun _ _ _ => ⟨_, rfl⟩⟩
#align initial_seg.refl InitialSeg.refl

instance (r : α → α → Prop) : Inhabited (r ≼i r) :=
  ⟨InitialSeg.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, fun a c h => by
    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⟩⟩
#align initial_seg.trans InitialSeg.trans

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

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

theorem unique_of_trichotomous_of_irrefl [IsTrichotomous β s] [IsIrrefl β s] :
    WellFounded r → Subsingleton (r ≼i s)
  | ⟨h⟩ =>
    ⟨fun f g => by
      ext a
      induction' h a with a _ IH
      refine extensional_of_trichotomous_of_irrefl s fun x => ?_
      simp only [f.init_iff, g.init_iff]
      exact exists_congr fun y => and_congr_left fun h => IH _ h ▸ Iff.rfl⟩
#align initial_seg.unique_of_trichotomous_of_irrefl InitialSeg.unique_of_trichotomous_of_irrefl

instance [IsWellOrder β s] : Subsingleton (r ≼i s) :=
  ⟨fun a =>
    @Subsingleton.elim _
      (unique_of_trichotomous_of_irrefl (@RelEmbedding.wellFounded _ _ r s a IsWellFounded.wf)) a⟩

protected theorem eq [IsWellOrder β s] (f g : r ≼i s) (a) : f a = g a := by
  rw [Subsingleton.elim f g]
#align initial_seg.eq InitialSeg.eq

theorem Antisymm.aux [IsWellOrder α r] (f : r ≼i s) (g : s ≼i r) : LeftInverse g f :=
  InitialSeg.eq (f.trans g) (InitialSeg.refl _)
#align initial_seg.antisymm.aux InitialSeg.Antisymm.aux

/-- If we have order embeddings between `α` and `β` whose images are initial segments, and `β`
is a well-order then `α` and `β` are order-isomorphic. -/
def antisymm [IsWellOrder β s] (f : r ≼i s) (g : s ≼i r) : r ≃r s :=
  haveI := f.toRelEmbedding.isWellOrder
  ⟨⟨f, g, Antisymm.aux f g, Antisymm.aux g f⟩, f.map_rel_iff'⟩
#align initial_seg.antisymm InitialSeg.antisymm

@[simp]
theorem antisymm_toFun [IsWellOrder β s] (f : r ≼i s) (g : s ≼i r) : (antisymm f g : α → β) = f :=
  rfl
#align initial_seg.antisymm_to_fun InitialSeg.antisymm_toFun

@[simp]
theorem antisymm_symm [IsWellOrder α r] [IsWellOrder β s] (f : r ≼i s) (g : s ≼i r) :
    (antisymm f g).symm = antisymm g f :=
  RelIso.coe_fn_injective rfl
#align initial_seg.antisymm_symm InitialSeg.antisymm_symm

theorem eq_or_principal [IsWellOrder β s] (f : r ≼i s) :
    Surjective f ∨ ∃ b, ∀ x, s x b ↔ ∃ y, f y = x :=
  or_iff_not_imp_right.2 fun h b =>
    Acc.recOn (IsWellFounded.wf.apply b : Acc s b) fun x _ IH =>
      not_forall_not.1 fun hn =>
        h
          ⟨x, fun y =>
            ⟨IH _, fun ⟨a, e⟩ => by
              rw [← e];
                exact
                  (trichotomous _ _).resolve_right
                    (not_or_of_not (hn a) fun hl => not_exists.2 hn (f.init hl))⟩⟩
#align initial_seg.eq_or_principal InitialSeg.eq_or_principal

/-- Restrict the codomain of an initial segment -/
def codRestrict (p : Set β) (f : r ≼i s) (H : ∀ a, f a ∈ p) : r ≼i Subrel s p :=
  ⟨RelEmbedding.codRestrict p f H, fun a ⟨b, m⟩ h =>
    let ⟨a', e⟩ := f.init h
    ⟨a', by subst e; rfl⟩⟩
#align initial_seg.cod_restrict InitialSeg.codRestrict

@[simp]
theorem codRestrict_apply (p) (f : r ≼i s) (H a) : codRestrict p f H a = ⟨f a, H a⟩ :=
  rfl
#align initial_seg.cod_restrict_apply InitialSeg.codRestrict_apply

/-- Initial segment from an empty type. -/
def ofIsEmpty (r : α → α → Prop) (s : β → β → Prop) [IsEmpty α] : r ≼i s :=
  ⟨RelEmbedding.ofIsEmpty r s, isEmptyElim⟩
#align initial_seg.of_is_empty InitialSeg.ofIsEmpty

/-- Initial segment embedding of an order `r` into the disjoint union of `r` and `s`. -/
def leAdd (r : α → α → Prop) (s : β → β → Prop) : r ≼i Sum.Lex r s :=
  ⟨⟨⟨Sum.inl, fun _ _ => Sum.inl.inj⟩, Sum.lex_inl_inl⟩, fun a b => by
    cases b <;> [exact fun _ => ⟨_, rfl⟩, exact False.elim ∘ Sum.lex_inr_inl]⟩
#align initial_seg.le_add InitialSeg.leAdd

@[simp]
theorem leAdd_apply (r : α → α → Prop) (s : β → β → Prop) (a) : leAdd r s a = Sum.inl a :=
  rfl
#align initial_seg.le_add_apply InitialSeg.leAdd_apply

protected theorem acc (f : r ≼i s) (a : α) : Acc r a ↔ Acc s (f a) :=
  ⟨by
    refine' fun h => Acc.recOn h fun a _ ha => Acc.intro _ fun b hb => _
    obtain ⟨a', rfl⟩ := f.init hb
    exact ha _ (f.map_rel_iff.mp hb), f.toRelEmbedding.acc a⟩
#align initial_seg.acc InitialSeg.acc

end InitialSeg

/-!
### 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
`PrincipalSeg 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 -/
structure PrincipalSeg {α β : Type _} (r : α → α → Prop) (s : β → β → Prop) extends r ↪r s where
  /-- The supremum of the principal segment -/
  top : β
  /-- The image of the order embedding is the set of elements `b` such that `s b top` -/
  down' : ∀ b, s b top ↔ ∃ a, toRelEmbedding a = b
#align principal_seg PrincipalSeg

-- Porting notes: deleted `scoped[InitialSeg]`
/-- 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 -/
infixl:25 " ≺i " => PrincipalSeg

namespace PrincipalSeg

instance : CoeOut (r ≺i s) (r ↪r s) :=
  ⟨PrincipalSeg.toRelEmbedding⟩

instance : CoeFun (r ≺i s) fun _ => α → β :=
  ⟨fun f => f⟩

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

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

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

theorem init [IsTrans β s] (f : r ≺i s) {a : α} {b : β} (h : s b (f a)) : ∃ a', f a' = b :=
  f.down.1 <| _root_.trans h <| f.lt_top _
#align principal_seg.init PrincipalSeg.init

/-- A principal segment is in particular an initial segment. -/
instance hasCoeInitialSeg [IsTrans β s] : Coe (r ≺i s) (r ≼i s) :=
  ⟨fun f => ⟨f.toRelEmbedding, fun _ _ => f.init⟩⟩
#align principal_seg.has_coe_initial_seg PrincipalSeg.hasCoeInitialSeg

theorem coe_coe_fn' [IsTrans β s] (f : r ≺i s) : ((f : r ≼i s) : α → β) = f :=
  rfl
#align principal_seg.coe_coe_fn' PrincipalSeg.coe_coe_fn'

theorem init_iff [IsTrans β s] (f : r ≺i s) {a : α} {b : β} : s b (f a) ↔ ∃ a', f a' = b ∧ r a' a :=
  @InitialSeg.init_iff α β r s f a b
#align principal_seg.init_iff PrincipalSeg.init_iff

theorem irrefl {r : α → α → Prop} [IsWellOrder α r] (f : r ≺i r) : False := by
  have h := f.lt_top f.top
  rw [show f f.top = f.top from InitialSeg.eq (↑f) (InitialSeg.refl r) f.top] at h
  exact _root_.irrefl _ h
#align principal_seg.irrefl PrincipalSeg.irrefl

instance (r : α → α → Prop) [IsWellOrder α r] : IsEmpty (r ≺i r) :=
  ⟨fun f => f.irrefl⟩

/-- Composition of a principal segment with an initial segment, as a principal segment -/
def ltLe (f : r ≺i s) (g : s ≼i t) : r ≺i t :=
  ⟨@RelEmbedding.trans _ _ _ r s t f g, g f.top, fun a => by
    simp only [g.init_iff, PrincipalSeg.down, exists_and_left.symm, exists_swap,
        RelEmbedding.trans_apply, exists_eq_right', InitialSeg.coe_coe_fn]⟩
#align principal_seg.lt_le PrincipalSeg.ltLe

@[simp]
theorem lt_le_apply (f : r ≺i s) (g : s ≼i t) (a : α) : (f.ltLe g) a = g (f a) :=
  RelEmbedding.trans_apply _ _ _
#align principal_seg.lt_le_apply PrincipalSeg.lt_le_apply

@[simp]
theorem lt_le_top (f : r ≺i s) (g : s ≼i t) : (f.ltLe g).top = g f.top :=
  rfl
#align principal_seg.lt_le_top PrincipalSeg.lt_le_top

/-- Composition of two principal segments as a principal segment -/
@[trans]
protected def trans [IsTrans γ t] (f : r ≺i s) (g : s ≺i t) : r ≺i t :=
  ltLe f g
#align principal_seg.trans PrincipalSeg.trans

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

@[simp]
theorem trans_top [IsTrans γ t] (f : r ≺i s) (g : s ≺i t) : (f.trans g).top = g f.top :=
  rfl
#align principal_seg.trans_top PrincipalSeg.trans_top

/-- Composition of an order isomorphism with a principal segment, as a principal segment -/
def equivLT (f : r ≃r s) (g : s ≺i t) : r ≺i t :=
  ⟨@RelEmbedding.trans _ _ _ r s t f g, g.top, fun c =>
    suffices (∃ a : β, g a = c) ↔ ∃ a : α, g (f a) = c by simpa [PrincipalSeg.down]
    ⟨fun ⟨b, h⟩ => ⟨f.symm b, by simp only [h, RelIso.apply_symm_apply]⟩,
      fun ⟨a, h⟩ => ⟨f a, h⟩⟩⟩
#align principal_seg.equiv_lt PrincipalSeg.equivLT

/-- Composition of a principal segment with an order isomorphism, as a principal segment -/
def ltEquiv {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop} (f : PrincipalSeg r s)
    (g : s ≃r t) : PrincipalSeg r t :=
  ⟨@RelEmbedding.trans _ _ _ r s t f g, g f.top, by
    intro x
    rw [← g.apply_symm_apply x, g.map_rel_iff, f.down', exists_congr]
    intro y; exact ⟨congr_arg g, fun h => g.toEquiv.bijective.1 h⟩⟩
#align principal_seg.lt_equiv PrincipalSeg.ltEquiv

@[simp]
theorem equivLT_apply (f : r ≃r s) (g : s ≺i t) (a : α) : (equivLT f g) a = g (f a) :=
  RelEmbedding.trans_apply _ _ _
#align principal_seg.equiv_lt_apply PrincipalSeg.equivLT_apply

@[simp]
theorem equivLT_top (f : r ≃r s) (g : s ≺i t) : (equivLT f g).top = g.top :=
  rfl
#align principal_seg.equiv_lt_top PrincipalSeg.equivLT_top

/-- Given a well order `s`, there is a most one principal segment embedding of `r` into `s`. -/
instance [IsWellOrder β s] : Subsingleton (r ≺i s) :=
  ⟨fun f g => by
    have ef : (f : α → β) = g := by
      show ((f : r ≼i s) : α → β) = (g : r ≼i s)
      rw [@Subsingleton.elim _ _ (f : r ≼i s) g]
    have et : f.top = g.top := by
      refine' extensional_of_trichotomous_of_irrefl s fun x => _
      simp only [PrincipalSeg.down, ef]
    cases f
    cases g
    have := RelEmbedding.coe_fn_injective ef; congr ⟩

theorem top_eq [IsWellOrder γ t] (e : r ≃r s) (f : r ≺i t) (g : s ≺i t) : f.top = g.top := by
  rw [Subsingleton.elim f (PrincipalSeg.equivLT e g)]; rfl
#align principal_seg.top_eq PrincipalSeg.top_eq

theorem topLTTop {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop} [IsWellOrder γ t]
    (f : PrincipalSeg r s) (g : PrincipalSeg s t) (h : PrincipalSeg r t) : t h.top g.top := by
  rw [Subsingleton.elim h (f.trans g)]
  apply PrincipalSeg.lt_top
#align principal_seg.top_lt_top PrincipalSeg.topLTTop

/-- Any element of a well order yields a principal segment -/
def ofElement {α : Type _} (r : α → α → Prop) (a : α) : Subrel r { b | r b a } ≺i r :=
  ⟨Subrel.relEmbedding _ _, a, fun _ => ⟨fun h => ⟨⟨_, h⟩, rfl⟩, fun ⟨⟨_, h⟩, rfl⟩ => h⟩⟩
#align principal_seg.of_element PrincipalSeg.ofElement

@[simp]
theorem ofElement_apply {α : Type _} (r : α → α → Prop) (a : α) (b) : ofElement r a b = b.1 :=
  rfl
#align principal_seg.of_element_apply PrincipalSeg.ofElement_apply

@[simp]
theorem ofElement_top {α : Type _} (r : α → α → Prop) (a : α) : (ofElement r a).top = a :=
  rfl
#align principal_seg.of_element_top PrincipalSeg.ofElement_top

/-- Restrict the codomain of a principal segment -/
def codRestrict (p : Set β) (f : r ≺i s) (H : ∀ a, f a ∈ p) (H₂ : f.top ∈ p) : r ≺i Subrel s p :=
  ⟨RelEmbedding.codRestrict p f H, ⟨f.top, H₂⟩, fun ⟨_, _⟩ =>
    f.down.trans <|
      exists_congr fun a => show (⟨f a, H a⟩ : p).1 = _ ↔ _ from ⟨Subtype.eq, congr_arg _⟩⟩
#align principal_seg.cod_restrict PrincipalSeg.codRestrict

@[simp]
theorem codRestrict_apply (p) (f : r ≺i s) (H H₂ a) : codRestrict p f H H₂ a = ⟨f a, H a⟩ :=
  rfl
#align principal_seg.cod_restrict_apply PrincipalSeg.codRestrict_apply

@[simp]
theorem codRestrict_top (p) (f : r ≺i s) (H H₂) : (codRestrict p f H H₂).top = ⟨f.top, H₂⟩ :=
  rfl
#align principal_seg.cod_restrict_top PrincipalSeg.codRestrict_top

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

@[simp]
theorem ofIsEmpty_top (r : α → α → Prop) [IsEmpty α] {b : β} (H : ∀ b', ¬s b' b) :
    (ofIsEmpty r H).top = b :=
  rfl
#align principal_seg.of_is_empty_top PrincipalSeg.ofIsEmpty_top

/-- Principal segment from the empty relation on `pempty` to the empty relation on `punit`. -/
@[reducible]
def pemptyToPunit : @EmptyRelation PEmpty ≺i @EmptyRelation PUnit :=
  (@ofIsEmpty _ _ EmptyRelation _ _ PUnit.unit) fun _ => not_false
#align principal_seg.pempty_to_punit PrincipalSeg.pemptyToPunit

protected theorem acc [IsTrans β s] (f : r ≺i s) (a : α) : Acc r a ↔ Acc s (f a) :=
  (f : r ≼i s).acc a
#align principal_seg.acc PrincipalSeg.acc

end PrincipalSeg

/-- 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 wellFounded_iff_wellFounded_subrel {β : Type _} {s : β → β → Prop} [IsTrans β s] :
    WellFounded s ↔ ∀ b, WellFounded (Subrel s { b' | s b' b }) := by
  refine'
    ⟨fun wf b => ⟨fun b' => ((PrincipalSeg.ofElement _ b).acc b').mpr (wf.apply b')⟩, fun wf =>
      ⟨fun b => Acc.intro _ fun b' hb' => _⟩⟩
  let f := PrincipalSeg.ofElement s b
  obtain ⟨b', rfl⟩ := f.down.mp ((PrincipalSeg.ofElement_top s b).symm ▸ hb' : s b' f.top)
  exact (f.acc b').mp ((wf b).apply b')
#align well_founded_iff_well_founded_subrel wellFounded_iff_wellFounded_subrel

theorem wellFounded_iff_principalSeg.{u} {β : Type u} {s : β → β → Prop} [IsTrans β s] :
    WellFounded s ↔ ∀ (α : Type u) (r : α → α → Prop) (_ : r ≺i s), WellFounded r :=
  ⟨fun wf _ _ f => RelHomClass.wellFounded f.toRelEmbedding wf, fun h =>
    wellFounded_iff_wellFounded_subrel.mpr fun b => h _ _ (PrincipalSeg.ofElement s b)⟩
#align well_founded_iff_principal_seg wellFounded_iff_principalSeg

/-! ### 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 InitialSeg.ltOrEq [IsWellOrder β s] (f : r ≼i s) : Sum (r ≺i s) (r ≃r s) := by
  by_cases h : Surjective f
  · exact Sum.inr (RelIso.ofSurjective f h)
  · have h' : _ := (InitialSeg.eq_or_principal f).resolve_left h
    exact Sum.inl ⟨f, Classical.choose h', Classical.choose_spec h'⟩
#align initial_seg.lt_or_eq InitialSeg.ltOrEq

theorem InitialSeg.ltOrEq_apply_left [IsWellOrder β s] (f : r ≼i s) (g : r ≺i s) (a : α) :
    g a = f a :=
  @InitialSeg.eq α β r s _ g f a
#align initial_seg.lt_or_eq_apply_left InitialSeg.ltOrEq_apply_left

theorem InitialSeg.ltOrEq_apply_right [IsWellOrder β s] (f : r ≼i s) (g : r ≃r s) (a : α) :
    g a = f a :=
  InitialSeg.eq (InitialSeg.ofIso g) f a
#align initial_seg.lt_or_eq_apply_right InitialSeg.ltOrEq_apply_right

/-- Composition of an initial segment taking values in a well order and a principal segment. -/
noncomputable def InitialSeg.leLT [IsWellOrder β s] [IsTrans γ t] (f : r ≼i s) (g : s ≺i t) :
    r ≺i t :=
  match f.ltOrEq with
  | Sum.inl f' => f'.trans g
  | Sum.inr f' => PrincipalSeg.equivLT f' g
#align initial_seg.le_lt InitialSeg.leLT

@[simp]
theorem InitialSeg.leLT_apply [IsWellOrder β s] [IsTrans γ t] (f : r ≼i s) (g : s ≺i t) (a : α) :
    (f.leLT g) a = g (f a) := by
  delta InitialSeg.leLT; cases' h : f.ltOrEq with f' f'
  · simp only [PrincipalSeg.trans_apply, f.ltOrEq_apply_left]
  · simp only [PrincipalSeg.equivLT_apply, f.ltOrEq_apply_right]
#align initial_seg.le_lt_apply InitialSeg.leLT_apply

namespace RelEmbedding

/-- 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 collapseF [IsWellOrder β s] (f : r ↪r s) : ∀ a, { b // ¬s (f a) b } :=
  (RelEmbedding.wellFounded f <| IsWellFounded.wf).fix fun a IH => by
    let S := { b | ∀ a h, s (IH a h).1 b }
    have : f a ∈ S := fun a' h =>
      ((trichotomous _ _).resolve_left fun h' =>
            (IH a' h).2 <| _root_.trans (f.map_rel_iff.2 h) h').resolve_left
        fun h' => (IH a' h).2 <| h' ▸ f.map_rel_iff.2 h
    exact ⟨IsWellFounded.wf.min S ⟨_, this⟩, IsWellFounded.wf.not_lt_min _ _ this⟩
set_option linter.uppercaseLean3 false in
#align rel_embedding.collapse_F RelEmbedding.collapseF

theorem collapseF.lt [IsWellOrder β s] (f : r ↪r s) {a : α} :
    ∀ {a'}, r a' a → s (collapseF f a').1 (collapseF f a).1 := @fun a => by
  revert a
  show (collapseF f a).1 ∈ { b | ∀ (a') (_ : r a' a), s (collapseF f a').1 b }
  unfold collapseF; rw [WellFounded.fix_eq]
  dsimp only
  apply WellFounded.min_mem _ _
set_option linter.uppercaseLean3 false in
#align rel_embedding.collapse_F.lt RelEmbedding.collapseF.lt

theorem collapseF.not_lt [IsWellOrder β s] (f : r ↪r s) (a : α) {b}
    (h : ∀ (a') (_ : r a' a), s (collapseF f a').1 b) : ¬s b (collapseF f a).1 := by
  unfold collapseF; rw [WellFounded.fix_eq]
  dsimp only
  exact
    WellFounded.not_lt_min _ _ _
      (show b ∈ { b | ∀ (a') (_ : r a' a), s (collapseF f a').1 b } from h)
set_option linter.uppercaseLean3 false in
#align rel_embedding.collapse_F.not_lt RelEmbedding.collapseF.not_lt

/-- Construct an initial segment from an order embedding into a well order, by collapsing it
to fill the gaps. -/
noncomputable def collapse [IsWellOrder β s] (f : r ↪r s) : r ≼i s :=
  haveI := RelEmbedding.isWellOrder f
  ⟨RelEmbedding.ofMonotone (fun a => (collapseF f a).1) fun a b => collapseF.lt f, fun a b =>
    Acc.recOn (IsWellFounded.wf.apply b : Acc s b)
      (fun b _ _ a h => by
        let S := { a | ¬s (collapseF f a).1 b }
        have : S.Nonempty := ⟨_, asymm h⟩
        exists (IsWellFounded.wf : WellFounded r).min S this
        refine' ((@trichotomous _ s _ _ _).resolve_left _).resolve_right _
        · exact (IsWellFounded.wf : WellFounded r).min_mem S this
        · refine' collapseF.not_lt f _ fun a' h' => _
          by_contra hn
          exact IsWellFounded.wf.not_lt_min S this hn h')
      a⟩
#align rel_embedding.collapse RelEmbedding.collapse

theorem collapse_apply [IsWellOrder β s] (f : r ↪r s) (a) : collapse f a = (collapseF f a).1 :=
  rfl
#align rel_embedding.collapse_apply RelEmbedding.collapse_apply

end RelEmbedding


import mv_polynomial sorted_list finsupp_pos user_classes

open finsupp
namespace mv_polynomial
variables {σ : Type*} {α : Type*} [decidable_eq σ] [decidable_eq α]

section decidable_linear_order
variables [decidable_linear_order (σ →₀ ℕ)]

section comm_semiring
variables [comm_semiring α]

section sort_support
def s_support (p : mv_polynomial σ α) := p.support.sort (≥)

lemma mem_s_support {p : mv_polynomial σ α} {a} : a ∈ p.s_support ↔ a ∈ p.support := by simp [s_support]
lemma not_mem_s_support {p : mv_polynomial σ α} {a} : a ∉ p.s_support ↔ a ∉ p.support := by simp [s_support]
lemma support_empty_of_s_nil {p : mv_polynomial σ α} : p.s_support = [] ↔ p.support = ∅ := by simp [s_support]
@[simp] lemma zero_s_support : (0 : mv_polynomial σ α).s_support = [] := by simp [s_support]
lemma eq_zero_of_s_nil {p : mv_polynomial σ α} : p.s_support = [] ↔ p = 0 := by simp [s_support]
lemma ne_zero_of_s_ne_nil {p : mv_polynomial σ α} : p.s_support ≠ [] ↔ p ≠ 0 := by simp [s_support, eq_zero_of_s_nil]

def LM (p : mv_polynomial σ α) := p.s_support.head
def LC (p : mv_polynomial σ α) := p p.LM
def LT (p : mv_polynomial σ α) := monomial p.LM p.LC

def TL (p : mv_polynomial σ α) : mv_polynomial σ α :=
⟨(p.support.erase p.LM), λ a, if p.LM = a then 0 else p a,
λ a, ⟨λ h, by simp at h; simp [ne.symm h.left, h.right], λ h, by by_cases p.LM = a; finish⟩⟩

@[simp] lemma zero_LM : (0 : mv_polynomial σ α).LM = 0 := by finish
@[simp] lemma zero_LC : (0 : mv_polynomial σ α).LC = 0 := by finish
@[simp] lemma zero_LT : (0 : mv_polynomial σ α).LT = 0 := by finish [LT]
@[simp] lemma zero_TL : (0 : mv_polynomial σ α).TL = 0 := by simp [TL]

lemma LM_mem_support {p : mv_polynomial σ α} (h : p ≠ 0) : p.LM  ∈ p.support :=
begin
    rw ←finset.mem_sort ((≥) : (σ →₀ ℕ) → (σ →₀ ℕ) → Prop),
    rw [←support_ne_empty, ←finset.sort_ne_nil] at h,
    rw [←list.cons_head_tail h],
    simp [LM, s_support],
end

lemma LM_not_mem {p : mv_polynomial σ α} : p.LM ∉ p.support ↔ p = 0 := ⟨λ h, begin
    by_cases hf : p = 0, assumption,
    apply absurd (LM_mem_support hf) h,
end, λ h, by simp [h]⟩

lemma LM_not_mem_TL {p : mv_polynomial σ α} : p.LM ∉ p.TL.support := by simp [TL]

@[simp] lemma eq_zero_of_div_zero : ∀ p : mv_polynomial σ α, (p.LM ∣ (0 : σ →₀ ℕ)) ↔ p.LM = 0 :=
λ p, by simp [has_dvd.dvd, dvd, eq_zero_apply]; apply finsupp.eq_zero_apply

lemma LC_eqz_iff {p : mv_polynomial σ α} : p = 0 ↔ p.LC = 0 := begin
    split; intro h,
    rw [LC, LM, ←not_mem_support_iff, ←not_mem_s_support],
    simp [h],
    rwa [LC, ←not_mem_support_iff, LM_not_mem] at h,
end

lemma LC_nez_iff {p : mv_polynomial σ α} : p ≠ 0 ↔ p.LC ≠ 0 :=
    by simp [LC_eqz_iff]

lemma LC_nez_of_LM_nez {p : mv_polynomial σ α} : p.LM ≠ 0 → p.LC ≠ 0 := λ h h', h (by simp [LC_eqz_iff.2 h'])
lemma nez_of_LM_nez {p : mv_polynomial σ α} : p.LM ≠ 0 → p ≠ 0 := λ h, LC_nez_iff.2 (LC_nez_of_LM_nez h)

lemma singleton_LM {p : mv_polynomial σ α} {a} (h : p.support = {a}) : p.LM = a := by finish [LM, s_support, h]
lemma singleton_eq_monomial {p : mv_polynomial σ α} {a} (h : p.support = {a}) : p = monomial a (p a) := begin
    ext x,
    by_cases ha : a = x; simp [monomial_apply, ha],
    simp [not_mem_support_iff.symm, h, ne.symm ha],
end

@[simp] lemma LM_of_monomial {a : σ →₀ ℕ} {b : α} : (monomial a b).LM = ite (b = 0) 0 a :=
begin
    by_cases b = 0,
    {simp [h]},
    {simp [h, singleton_LM (support_monomial_eq h)]},
end

lemma eq_LM_of_monomial (a : σ →₀ ℕ) {b : α} (hb : b ≠ 0) : a = (monomial a b).LM := by simp [hb]

@[simp] lemma LM_of_monomial' {b : α} : (monomial 0 b).LM = (0 : σ →₀ ℕ) :=
    begin
        by_cases hb : b = 0, simp [hb],
        simp [singleton_LM (support_monomial_eq hb)],
    end

@[simp] lemma LC_of_monomial {a : σ →₀ ℕ} {b : α} : (monomial a b).LC = b := begin
    by_cases hb : b = 0, simp [hb],
    simp [LC, monomial_apply, singleton_LM (support_monomial_eq hb)],
end

@[simp] lemma LT_apply {p : mv_polynomial σ α} : ∀ a, p.LT a = ite (p.LM = a) p.LC 0 :=
by rw LT; simp [monomial_apply]

lemma LT_mul_monomial {p : mv_polynomial σ α} : ∀ {a b}, p.LT * monomial a b = monomial (p.LM + a) (p.LC * b) :=
by simp [LT, monomial_mul_monomial]

@[simp] lemma LM_of_LT {p : mv_polynomial σ α} : p.LT.LM = p.LM := begin
    by_cases p = 0,
    {simp [LT, h]},
    {simp [LT, LC_nez_iff.1 h]},
end

@[simp] lemma LC_of_LT {p : mv_polynomial σ α} : p.LT.LC = p.LC := by simp [LT]

@[simp] lemma LT_of_monomial {a : σ →₀ ℕ} {b : α} : (monomial a b).LT = monomial a b :=
by by_cases hb : b = 0; simp [LT, hb]

lemma LM_eq_of_LT_eq {p q : mv_polynomial σ α} : p.LT = q.LT → p.LM = q.LM :=
λ h, begin have h' : p.LT.LM = q.LT.LM := by simp [h], simpa using h', end

lemma LC_eq_of_LT_eq {p q : mv_polynomial σ α} : p.LT = q.LT → p.LC = q.LC :=
λ h, begin have h' : p.LT.LC = q.LT.LC := by simp [h], simpa using h', end

lemma LT_eq_iff_LM_LC_eq {p q : mv_polynomial σ α} : p.LT = q.LT ↔ p.LM = q.LM ∧ p.LC = q.LC :=
⟨λ h, ⟨LM_eq_of_LT_eq h, LC_eq_of_LT_eq h⟩,
λ h, by simp [LT, h.left, h.right]⟩

@[simp] lemma TL_apply {p : mv_polynomial σ α} : ∀ a, p.TL a = ite (p.LM = a) 0 (p a) :=
λ a, by rw [TL, coe_f]

lemma TL_support_subset {p : mv_polynomial σ α} : p.TL.support ⊆ p.support :=
by simp [TL]; apply finset.erase_subset

lemma mem_TL_support {p : mv_polynomial σ α} {a} : a ≠ p.LM → a ∈ p.support → a ∈ p.TL.support :=
λ h₁ h₂, by simp [TL]; use [h₁, by simpa using h₂]

lemma TL_apply_mem {p : mv_polynomial σ α} : ∀ {a}, a ∈ p.TL.support → p.TL a = p a :=
λ a h, by simp [ne.symm (finset.ne_of_mem_and_not_mem h LM_not_mem_TL)]

@[simp] lemma TL_of_monomial {a : σ →₀ ℕ} {b : α}: (monomial a b).TL = 0 :=
begin
    by_cases hb : b = 0,
    simp [hb, TL],
    ext x,
    by_cases a = x,
    {simp [h, hb]},
    {simp [h, monomial_apply]},
end

lemma TL_eq_s_TL {p : mv_polynomial σ α} : p.TL.s_support = p.s_support.tail := begin
    by_cases hp : s_support p = [],
    {simp [hp, TL, support_empty_of_s_nil.1 hp],},
    {
        apply @list.sorted_nodup_ext (σ →₀ ℕ) (≥) _,
        {simp [s_support]},
        {apply list.sorted_tail, simp [s_support]},
        {simp [s_support],},
        {apply @list.nodup_of_nodup_cons _ p.s_support.head, rw list.cons_head_tail hp, simp [s_support],},
        {
            intro a, unfold s_support at hp, simp [s_support, LM, TL, -mem_support_iff],
            rw [←finset.mem_sort (≥), ←list.cons_head_tail hp],
            simp [and_or_distrib_left],
            refine ⟨λ h, h.right, λ h, ⟨_, by assumption⟩⟩,
            have nh := finset.sort_nodup (≥) p.support, rw [←list.cons_head_tail hp, list.nodup_cons] at nh,
            intro ha, apply nh.left, rwa ha at h,
        }
    },
end

lemma LM_rel {p : mv_polynomial σ α} : ∀ {a}, a ∈ p.TL.support → p.LM ≥ a := λ a,
    by rw [←mem_s_support, TL_eq_s_TL, LM]; apply finset.sort_hd_rel

lemma LM_rel_gt {p : mv_polynomial σ α} : ∀ {a}, a ∈ p.TL.support → p.LM > a := λ a ha,
begin
    apply lt_of_le_of_ne (LM_rel ha),
    apply finset.ne_of_mem_and_not_mem ha LM_not_mem_TL,
end

lemma LM_rel' {p : mv_polynomial σ α} : ∀ {a}, a ∈ p.support → p.LM ≥ a := λ a,
begin
    by_cases hp : p = 0, simp [hp],
    have h :  insert p.LM p.TL.support = p.support,
        simp [TL, -finset.union_comm], apply finset.insert_erase (LM_mem_support hp),
    simp [h.symm, -mem_support_iff], rintro (h' | h'),
    rw h', apply le_refl,
    apply LM_rel h',
end

lemma gt_LM_not_mem {p : mv_polynomial σ α} : ∀ {x}, x > p.LM → x ∉ p.support :=
λ x hx h_mem, begin
    apply lt_iff_not_ge'.1 hx,
    apply LM_rel' h_mem,
end

lemma gt_LM_apply {p : mv_polynomial σ α} : ∀ {x}, x > p.LM → p x = 0 :=
λ x, by rw ←not_mem_support_iff; apply gt_LM_not_mem

lemma cons_LM_TL {p : mv_polynomial σ α} (hp : p ≠ 0) : list.cons p.LM p.TL.s_support = p.s_support :=
    by simp [TL_eq_s_TL, LM]; apply list.cons_head_tail; rwa ne_zero_of_s_ne_nil

lemma LM_TL_eq (p : mv_polynomial σ α) : p.LT + p.TL = p := begin
    ext a, simp [monomial_apply],
    by_cases ha : p.LM = a,
    {simp [LC, ha, TL_apply]},
    {simp [ha]},
end

@[elab_as_eliminator]
theorem induction {C : (mv_polynomial σ α) → Prop} (p : mv_polynomial σ α)
    (C₀ : C 0)
    (Cₙ : ∀ (p : mv_polynomial σ α), C p.TL → C p) : C p :=
    suffices ∀ l (p : mv_polynomial σ α), p.s_support = l → C p, from this _ _ rfl,
    λ l, @list.rec_on _ (λ l, (∀ p : mv_polynomial σ α, p.s_support = l → C p)) l
    (λ p hp, by rw eq_zero_of_s_nil at hp; rwa hp)
    begin
        simp_intros l_LM l_TL ih p hp,
        apply Cₙ, apply ih,
        rw ←cons_LM_TL at hp, simp at hp, exact hp.right,
        rw [←ne_zero_of_s_ne_nil, hp], simp,
    end

end sort_support

end comm_semiring

section comm_ring
variables [comm_ring α]
@[simp] lemma LM_neg {p : mv_polynomial σ α} : (-p).LM = p.LM := by simp [LM, s_support]
@[simp] lemma LC_neg {p : mv_polynomial σ α} : (-p).LC = -(p.LC) := by simp [LC]
@[simp] lemma monomial_neg {a : σ →₀ ℕ} {b : α} : monomial a (-b) = -(monomial a b) :=
begin
    ext x,
    by_cases a = x;
    simp [h, monomial_apply],
end

def monomial_ideal (l : list (mv_polynomial σ α)) : ideal (mv_polynomial σ α) :=
    ideal.span ↑(l.map (λ f : mv_polynomial σ α, f.LT)).to_finset

lemma support_subset_of_linear_combination_union (s : finset (mv_polynomial σ α)) :
    ∀ (p : mv_polynomial σ α) (hp₁ : p ∈ ideal.span (↑s : set (mv_polynomial σ α))),
    ∃ (c : ((mv_polynomial σ α) →₀ (mv_polynomial σ α))), c.support ⊆ s ∧ p.support ⊆ s.fold (∪) (∅) (λ a, ((c.to_fun a) * a).support) :=
begin
    apply finset.induction_on s,
    {simp [ideal.span], refine ⟨0, by simp⟩},
    {
        intros q s hqs ih p hp,
        simp [finset.coe_insert, ideal.mem_span_insert] at hp ⊢,
        rcases hp with ⟨a, z, hz, hp⟩,
        rcases ih z hz with ⟨c, hc, hz'⟩,
        refine ⟨single q a + c, finset.subset.trans support_add (finset.union_subset' support_single_subset hc), _⟩,

        have hc_app : c q = 0,
            {rw [←not_mem_support_iff], exact finset.not_mem_subset_of_not_mem hc hqs},
        have h_congr : ∀ x ∈ s, ((single q a + c) x * x).support  = (c x * x).support :=
            λ x hx, by simp [single_apply, ne.symm (finset.ne_of_mem_and_not_mem hx hqs)],
        simp at h_congr,
        simp [coe_f', (finset.fold_congr h_congr), hp, hc_app] at hz' ⊢,
        apply finset.subset.trans support_add (finset.union_subset'_symm hz' (finset.subset.refl _)),
    }
end

end comm_ring

section integral_domain
variables [integral_domain α]

lemma mem_mul_support {a a': σ →₀ ℕ} {b': α} (hb' : b' ≠ 0) (c : mv_polynomial σ α)
(h : a ∈ (c * (monomial a' b')).support) : a' ∣ a := begin
    simp [has_mul.mul, monomial, single_sum' a' hb'] at h,
    simp [finsupp.sum, single_apply] at h,
    have h' : ∃ x ∈ c.support, a' + x = a,
    {
        by_contradiction h',
        simp [not_exists, -finsupp.mem_support_iff] at h',
        exact h (finset.sum_eq_zero (λ x hx, by simp [h' x hx])),
    },
    rcases h' with ⟨_, _, h'⟩,
    exact dvd_of_add (by rwa eq_comm at h'),
end

set_option class.instance_max_depth 50
theorem monomial_mem_ideal {a : σ →₀ ℕ} {b : α} (hb : b ≠ 0) : ∀ l : list (mv_polynomial σ α),
    monomial a b ∈ monomial_ideal l → ∃ (p  : mv_polynomial σ α) (hp : p ∈ l ∧ p ≠ 0), p.LM ∣ a
| [] := by simpa [monomial_ideal, ideal.span, monomial_eq_zero_iff] using hb
| (q :: l') :=
λ h_mem, begin
    rcases support_subset_of_linear_combination_union ((list.cons q l').map (λ f : mv_polynomial σ α, f.LT)).to_finset (monomial a b) h_mem with ⟨c, hc, h⟩,
    rw support_monomial_eq hb at h,
    rcases finset.mem_fold_union h with ⟨p, hp, h'⟩,
    rw [list.mem_to_finset, list.mem_map] at hp,
    rcases hp with ⟨p', hp'₁, hp'₂⟩,
    have hp' : p' ≠ 0 := λ hp', by simpa [hp', hp'₂.symm, finset.subset_empty] using h',
    refine ⟨p', ⟨hp'₁, hp'⟩, mem_mul_support (LC_nez_iff.1 hp') (c.to_fun p'.LT) (by simpa [hp'₂.symm] using h' (finset.mem_singleton_self _))⟩,
end

end integral_domain

end decidable_linear_order

section well_order
variables [decidable_linear_order (σ →₀ ℕ)] [is_well_founded (σ →₀ ℕ) (<)] [is_monomial_order (σ →₀ ℕ) (≤)]
section comm_semiring
variables [comm_semiring α]
lemma TL_eqz_of_LM_eqz {p : mv_polynomial σ α} (h : p.LM = 0) : p.TL = 0 :=
begin
    by_contradiction,
    apply (not_lt_of_le (finsupp.zero_le p.TL.LM)),
    simpa [h] using LM_rel_gt (LM_mem_support a),
end

lemma gt_TL_LM_of_LM_nez {p : mv_polynomial σ α} (h : p.LM ≠ 0) : p.LM > p.TL.LM :=
begin
    by_cases hTL : p.TL = 0,
    {simp [hTL], apply finsupp.zero_lt_iff_ne_zero.2 h},
    {apply LM_rel_gt (LM_mem_support hTL)},
end

lemma eqC_of_LM_eqz {p : mv_polynomial σ α} : p.LM = 0 ↔ p = C (p.LC) :=
⟨λ h, begin
    by_cases hp : p = 0,
    {rw hp, simp},
    {
        conv {to_lhs, rw [←LM_TL_eq p, LT, h]},
        simp [C, TL_eqz_of_LM_eqz h],
    }
end,
λ h, by rw [h, C]; simp⟩

end comm_semiring

section comm_ring
variables [comm_ring α]

lemma LM_of_add_left {p q : mv_polynomial σ α} (hpq : p.LM > q.LM) :
    (p + q).LM = p.LM :=
begin
    have hp : p.LM > 0 := gt_of_gt_of_ge hpq (finsupp.zero_le q.LM),
    have h : (p + q).LM ≥ p.LM :=
        LM_rel' (by simpa [gt_LM_apply hpq] using LM_mem_support (nez_of_LM_nez (ne_of_gt hp))),
        have : (p + q).LM ∈ p.support ∨ (p + q).LM ∈ q.support :=
        finset.mem_union.1 (finset.mem_of_subset support_add (LM_mem_support (nez_of_LM_nez (ne_of_gt $ gt_of_ge_of_gt h hp)))),
    cases this,
    {apply antisymm h (LM_rel' this),},
    {apply antisymm h (le_trans (LM_rel' this) (le_of_lt hpq))},
end

lemma LM_of_add_right {p q : mv_polynomial σ α} (hpq : q.LM > p.LM) :
    (p + q).LM = q.LM :=
by rw [add_comm, LM_of_add_left hpq]

lemma LC_of_add_left {p q : mv_polynomial σ α} (hpq : p.LM > q.LM) :
    (p + q).LC = p.LC :=
by simp [LC, LM_of_add_left hpq, gt_LM_apply hpq]

lemma LC_of_add_right {p q : mv_polynomial σ α} (hpq : q.LM > p.LM) :
    (p + q).LC = q.LC :=
by rw [add_comm, LC_of_add_left hpq]

lemma LT_of_add_left {p q : mv_polynomial σ α} (hpq : p.LM > q.LM) :
    (p + q).LT = p.LT :=
by simp [LT, LM_of_add_left hpq, LC_of_add_left hpq]

lemma LT_of_add_right {p q : mv_polynomial σ α} (hpq : q.LM > p.LM) :
    (p + q).LT = q.LT :=
by simp [LT, LM_of_add_right hpq, LC_of_add_right hpq]

theorem sub_LM_lt {p q : mv_polynomial σ α} (h : p.LT = q.LT) (hp : p.LM ≠ 0) :
    (p - q).LM < p.LM :=
begin
    by_cases hpq : p - q = 0,
    {simpa [hpq, finsupp.zero_lt_iff_ne_zero] using hp},
    {
        simp [LT, monomial, single_eq_single_iff, LC_nez_of_LM_nez hp] at h,
        apply lt_of_le_of_ne,
        {
            cases finset.mem_union.1 (support_sub (LM_mem_support hpq)),
            {exact LM_rel' h_1},
            {rw h.left, exact LM_rel' h_1},
        },
        {
            apply finset.ne_of_mem_and_not_mem (LM_mem_support hpq),
            simpa [LC, h.left, add_neg_eq_zero] using h.right,
        },
    }
end

theorem LM_of_add_gt_LM {p : mv_polynomial σ α} {a : σ →₀ ℕ} (ha : a > p.LM)
{b : α} (hb : b ≠ 0) : (monomial a b + p).LM = a :=
begin
    rw eq_LM_of_monomial a hb at ha,
    simp [LM_of_add_right ha, hb],
end

theorem LC_of_add_gt_LM {p : mv_polynomial σ α} {a : σ →₀ ℕ} (ha : a > p.LM)
{b : α} (hb : b ≠ 0) : (monomial a b + p).LC = b :=
begin
    rw eq_LM_of_monomial a hb at ha,
    simp [LC_of_add_right ha],
end

theorem LT_of_add_gt_LM {p : mv_polynomial σ α} {a : σ →₀ ℕ} (ha : a > p.LM)
{b : α} (hb : b ≠ 0) : (monomial a b + p).LT = monomial a b :=
by rw [LT, LM_of_add_gt_LM ha hb, LC_of_add_gt_LM ha hb]

theorem TL_of_add_gt_LM {p : mv_polynomial σ α} {a : σ →₀ ℕ} (ha : a > p.LM)
{b : α} (hb : b ≠ 0) : (monomial a b + p).TL = p :=
begin
    have h := LM_TL_eq (monomial a b + p),
    rw [LT, LM_of_add_gt_LM ha hb, LC_of_add_gt_LM ha hb] at h,
    apply add_left_cancel h,
end

end comm_ring

section integral_domain
variables [integral_domain α]

lemma mul_mem_mul_support {a₂ a₁: σ →₀ ℕ} {b₁: α} (hb : b₁ ≠ 0) (c : mv_polynomial σ α)
(ha : a₂ ∈ c.support) : a₁ + a₂ ∈ (monomial a₁ b₁ * c).support :=
begin
    simp [has_mul.mul, monomial, single_sum' a₁ hb],
    simp [finsupp.sum, single_apply],
    rw [add_comm, finset.sum_eq_single a₂],
    {simp, exact mul_ne_zero hb (by simpa using ha)},
    {intros _ _ h, simp [add_right_cancel_iff, h]},
    {finish},
end

lemma mul_apply {p : mv_polynomial σ α} :
∀ {a₁ a₂ b₁}, a₂ ∈ p.support → (monomial a₁ b₁ * p) (a₁ + a₂) = b₁ * p a₂ :=
λ a₁ a₂ b₁ ha₂, begin
    by_cases hb₁ : b₁ = 0,
    {simp [coe_f, hb₁], simp [coe_f']},
    {
        conv {
            to_lhs,
            simp [coe_f, has_mul.mul, monomial, single_sum' a₁ hb₁],
            simp [coe_f', finsupp.sum_apply, single_apply],
            simp [finsupp.sum],
        },
        rw finset.sum_eq_single a₂,
        {simp, refl},
        {intros b hb h, simp [h]},
        {
            simp_intros h,
            change b₁ * (p a₂) = 0,
            simp [h],
        }
    }
end

theorem LM_of_mul_m {p : mv_polynomial σ α} : ∀ {a b}, (p * (monomial a b)).LM = ite (p = 0 ∨ b = 0) 0 (p.LM + a) :=
λ a b, begin
    by_cases hp : p = 0,
    {simp [hp]},
    by_cases hb : b = 0,
    {simp [hb]},
    revert hp, apply induction p,
    {simp},
    {
        simp_intros q ih hq [hb],
        conv {to_lhs, rw [←LM_TL_eq q, add_mul]},
        by_cases hq' : q.TL = 0,
        {simp [hq', LT_mul_monomial, hb, hq, LC_nez_iff.1 hq]},
        {
            have h : (q.TL * monomial a b).LM < (q.LT * monomial a b).LM,
            {
                simp [LT_mul_monomial, hb, LC_nez_iff.1 hq, ih hq', hq'],
                apply gt_TL_LM_of_LM_nez (λ h, hq' (TL_eqz_of_LM_eqz h)),
            },
            rw LM_of_add_left h,
            simp [LT_mul_monomial, hb, hq, LC_nez_iff.1 hq],
        }
    }
end

theorem LC_of_mul_m {p : mv_polynomial σ α} : ∀ {a b}, (p * (monomial a b)).LC = p.LC * b :=
λ a b, begin
    apply induction p,
    {simp},
    {
        intros q ih,
        by_cases hb : b = 0,
        {simp [hb]},
        {
            conv {to_lhs, rw [←LM_TL_eq q, add_mul]},
            by_cases hq : q.TL = 0,
            {simp [hq, LT_mul_monomial]},
            {
                have hq' : q.LT ≠ 0 := nez_of_LM_nez (λ h, hq (TL_eqz_of_LM_eqz (by simpa using h))),
                have h : (q.TL * monomial a b).LM < (q.LT * monomial a b).LM,
                {
                    simp [LM_of_mul_m, hq, hq', hb],
                    apply gt_TL_LM_of_LM_nez (λ h, hq (TL_eqz_of_LM_eqz h)),
                },
                rw LC_of_add_left h,
                simp [LT_mul_monomial],
            }
        }
    }
end

theorem LT_of_mul_m {p : mv_polynomial σ α} : ∀ {a b}, (p * (monomial a b)).LT = p.LT * (monomial a b) :=
λ a b, begin
    by_cases hp : p = 0; by_cases hb : b = 0;
    simp [LM_of_mul_m, LC_of_mul_m, hp, hb, monomial_mul_monomial, LT],
end

end integral_domain
end well_order

end mv_polynomial


import topology.continuity
import topology.algebra.topological_structures
import data.real.basic

noncomputable theory
universes u v
open set

variables {α : Type u} {β : Type v} [topological_space α] [topological_space β]
variables {s: set α} [decidable_pred s]
variables (f : subtype (closure s) → β) (g : subtype (closure (-s)) → β)

@[reducible] def pw : α → β := λ x, if h : x ∈ s then f ⟨ x, subset_closure h ⟩ else g ⟨ x, subset_closure h ⟩

lemma frontier_subset_closure : frontier s ⊆ closure s := λ x hx, hx.left

lemma frontier_subset_closure_compl : frontier s ⊆ closure (-s) :=
  have h : closure s ∩ closure (-s) = frontier s,
    from symm frontier_eq_closure_inter_closure,
  h ▸ inter_subset_right (closure s) (closure (-s))

local notation `val` := @subtype.val _

theorem continuous_pw (hs : ∀ x (h : x ∈ frontier s),
  f ⟨x, frontier_subset_closure h⟩ = g ⟨x, frontier_subset_closure_compl h⟩)
  (hf : continuous f) (hg : continuous g) : (continuous (pw f g)) :=
continuous_iff_is_closed.mpr $ assume t ht,
  have h₁ : ∃ t₁, is_closed t₁ ∧ f ⁻¹' t = val (closure s) ⁻¹' t₁,
    from is_closed_induced_iff.mp (continuous_iff_is_closed.mp hf t ht),
  have h₂ : ∃ t₂, is_closed t₂ ∧ g ⁻¹' t = val (closure (-s)) ⁻¹' t₂,
    from is_closed_induced_iff.mp (continuous_iff_is_closed.mp hg t ht),
  exists.elim h₁ $
  assume t₁ ht₁,
  exists.elim h₂ $
  assume t₂ ht₂,
  begin
  have : pw f g ⁻¹' t = (closure s ∩ t₁) ∪ (closure (-s) ∩ t₂),
    apply set.ext,
    intro x,
    have hxt₁ : Π  hxc : x ∈ closure s, (x ∈ t₁ ↔ f ⟨x, hxc⟩ ∈ t),
      intro hxc,
      let x' : subtype (closure s) := ⟨x, hxc⟩,
      have h₁ : x ∈ t₁ ↔ x' ∈ val (closure s) ⁻¹' t₁,
        refl,
      have h₂ : x' ∈ val (closure s) ⁻¹' t₁ ↔ x' ∈ f ⁻¹' t,
        rw [ht₁.right],
      rw [h₁, h₂],
      refl,
    have hxt₂ : Π hxi : x ∈ closure (-s), (x ∈ t₂ ↔ g ⟨x, hxi⟩ ∈ t),
      intro hxi,
      let x' : subtype (closure (-s)) := ⟨x, hxi⟩,
      have h₁ : x ∈ t₂ ↔ x' ∈ val (closure (-s)) ⁻¹' t₂,
        refl,
      have h₂ : x' ∈ val (closure (-s)) ⁻¹' t₂ ↔ x' ∈ g ⁻¹' t,
        rw [ht₂.right],
      rw [h₁, h₂],
      refl,

    have hxf : x ∈ frontier s → (x ∈ pw f g ⁻¹' t ↔ x ∈ (closure s ∩ t₁) ∪ (closure (-s) ∩ t₂)),
      intro hx,
      have hxc : x ∈ closure s, from frontier_subset_closure hx,
      have hxi : x ∈ closure (-s), from frontier_subset_closure_compl hx,
      by_cases x ∈ s; simp [pw, h, hxc, hxi, hs x hx, hxt₁ hxc, hxt₂ hxi, -closure_compl],

    have hxnf : x ∉ frontier s → (x ∈ pw f g ⁻¹' t ↔ x ∈ (closure s ∩ t₁) ∪ (closure (-s) ∩ t₂)),
      intro hf,
      by_cases x ∈ s,
        have hc : x ∈ closure s, from subset_closure h,
        have hnc : x ∉ closure (-s),
          rw [closure_compl],
          simpa [frontier, hc] using hf,
        simp [pw, h, hc, hnc, hxt₁ hc, -closure_compl],

        have hc : x ∈ closure (-s), from subset_closure h,
        have hnc : x ∉ closure s,
          simp [closure_compl] at hc,
          simpa [frontier, hc] using hf,
        simp [pw, h, hc, hnc, hxt₂ hc, -closure_compl],

    exact classical.by_cases hxf hxnf,
  exact by rw [this]; exact is_closed_union
    (is_closed_inter is_closed_closure ht₁.left)
    (is_closed_inter is_closed_closure ht₂.left)
  end

#check continuous_if
-- continuous_if is a corollorary of continuous_pw
theorem continuous_if' {p : α → Prop} {f g : α → β} {h : ∀a, decidable (p a)}
  (hp : ∀a∈frontier {a | p a}, f a = g a) (hf : continuous f) (hg : continuous g) :
  continuous (λa, @ite (p a) (h a) β (f a) (g a)) :=
    continuous_pw (f ∘ subtype.val) (g ∘ subtype.val) hp
      (continuous.comp continuous_induced_dom hf)
      (continuous.comp continuous_induced_dom hg)