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

! This file was ported from Lean 3 source module topology.locally_constant.algebra
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Algebra.Pi
import Mathbin.Topology.LocallyConstant.Basic

/-!
# Algebraic structure on locally constant functions

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

This file puts algebraic structure (`add_group`, etc)
on the type of locally constant functions.

-/

namespace LocallyConstant

variable {X Y : Type _} [TopologicalSpace X]

@[to_additive]
instance [One Y] : One (LocallyConstant X Y) where one := const X 1

#print LocallyConstant.coe_one /-
@[simp, to_additive]
theorem coe_one [One Y] : ⇑(1 : LocallyConstant X Y) = (1 : X → Y) :=
  rfl
#align locally_constant.coe_one LocallyConstant.coe_one
#align locally_constant.coe_zero LocallyConstant.coe_zero
-/

#print LocallyConstant.one_apply /-
@[to_additive]
theorem one_apply [One Y] (x : X) : (1 : LocallyConstant X Y) x = 1 :=
  rfl
#align locally_constant.one_apply LocallyConstant.one_apply
#align locally_constant.zero_apply LocallyConstant.zero_apply
-/

@[to_additive]
instance [Inv Y] : Inv (LocallyConstant X Y) where inv f := ⟨f⁻¹, f.IsLocallyConstant.inv⟩

#print LocallyConstant.coe_inv /-
@[simp, to_additive]
theorem coe_inv [Inv Y] (f : LocallyConstant X Y) : ⇑f⁻¹ = f⁻¹ :=
  rfl
#align locally_constant.coe_inv LocallyConstant.coe_inv
#align locally_constant.coe_neg LocallyConstant.coe_neg
-/

#print LocallyConstant.inv_apply /-
@[to_additive]
theorem inv_apply [Inv Y] (f : LocallyConstant X Y) (x : X) : f⁻¹ x = (f x)⁻¹ :=
  rfl
#align locally_constant.inv_apply LocallyConstant.inv_apply
#align locally_constant.neg_apply LocallyConstant.neg_apply
-/

@[to_additive]
instance [Mul Y] : Mul (LocallyConstant X Y)
    where mul f g := ⟨f * g, f.IsLocallyConstant.mul g.IsLocallyConstant⟩

#print LocallyConstant.coe_mul /-
@[simp, to_additive]
theorem coe_mul [Mul Y] (f g : LocallyConstant X Y) : ⇑(f * g) = f * g :=
  rfl
#align locally_constant.coe_mul LocallyConstant.coe_mul
#align locally_constant.coe_add LocallyConstant.coe_add
-/

#print LocallyConstant.mul_apply /-
@[to_additive]
theorem mul_apply [Mul Y] (f g : LocallyConstant X Y) (x : X) : (f * g) x = f x * g x :=
  rfl
#align locally_constant.mul_apply LocallyConstant.mul_apply
#align locally_constant.add_apply LocallyConstant.add_apply
-/

@[to_additive]
instance [MulOneClass Y] : MulOneClass (LocallyConstant X Y) :=
  { LocallyConstant.hasOne,
    LocallyConstant.hasMul with
    one_mul := by
      intros
      ext
      simp only [mul_apply, one_apply, one_mul]
    mul_one := by
      intros
      ext
      simp only [mul_apply, one_apply, mul_one] }

/- warning: locally_constant.coe_fn_monoid_hom -> LocallyConstant.coeFnMonoidHom is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulOneClass.{u2} Y], MonoidHom.{max u1 u2, max u1 u2} (LocallyConstant.{u1, u2} X Y _inst_1) (X -> Y) (LocallyConstant.mulOneClass.{u1, u2} X Y _inst_1 _inst_2) (Pi.mulOneClass.{u1, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => _inst_2))
but is expected to have type
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulOneClass.{u2} Y], MonoidHom.{max u2 u1, max u1 u2} (LocallyConstant.{u1, u2} X Y _inst_1) (X -> Y) (LocallyConstant.instMulOneClassLocallyConstant.{u1, u2} X Y _inst_1 _inst_2) (Pi.mulOneClass.{u1, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => _inst_2))
Case conversion may be inaccurate. Consider using '#align locally_constant.coe_fn_monoid_hom LocallyConstant.coeFnMonoidHomₓ'. -/
/-- `coe_fn` is a `monoid_hom`. -/
@[to_additive "`coe_fn` is an `add_monoid_hom`.", simps]
def coeFnMonoidHom [MulOneClass Y] : LocallyConstant X Y →* X → Y
    where
  toFun := coeFn
  map_one' := rfl
  map_mul' _ _ := rfl
#align locally_constant.coe_fn_monoid_hom LocallyConstant.coeFnMonoidHom
#align locally_constant.coe_fn_add_monoid_hom LocallyConstant.coeFnAddMonoidHom

/- warning: locally_constant.const_monoid_hom -> LocallyConstant.constMonoidHom is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulOneClass.{u2} Y], MonoidHom.{u2, max u1 u2} Y (LocallyConstant.{u1, u2} X Y _inst_1) _inst_2 (LocallyConstant.mulOneClass.{u1, u2} X Y _inst_1 _inst_2)
but is expected to have type
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulOneClass.{u2} Y], MonoidHom.{u2, max u2 u1} Y (LocallyConstant.{u1, u2} X Y _inst_1) _inst_2 (LocallyConstant.instMulOneClassLocallyConstant.{u1, u2} X Y _inst_1 _inst_2)
Case conversion may be inaccurate. Consider using '#align locally_constant.const_monoid_hom LocallyConstant.constMonoidHomₓ'. -/
/-- The constant-function embedding, as a multiplicative monoid hom. -/
@[to_additive "The constant-function embedding, as an additive monoid hom.", simps]
def constMonoidHom [MulOneClass Y] : Y →* LocallyConstant X Y
    where
  toFun := const X
  map_one' := rfl
  map_mul' _ _ := rfl
#align locally_constant.const_monoid_hom LocallyConstant.constMonoidHom
#align locally_constant.const_add_monoid_hom LocallyConstant.constAddMonoidHom

instance [MulZeroClass Y] : MulZeroClass (LocallyConstant X Y) :=
  { LocallyConstant.hasZero,
    LocallyConstant.hasMul with
    zero_mul := by
      intros
      ext
      simp only [mul_apply, zero_apply, MulZeroClass.zero_mul]
    mul_zero := by
      intros
      ext
      simp only [mul_apply, zero_apply, MulZeroClass.mul_zero] }

instance [MulZeroOneClass Y] : MulZeroOneClass (LocallyConstant X Y) :=
  { LocallyConstant.mulZeroClass, LocallyConstant.mulOneClass with }

section CharFn

variable (Y) [MulZeroOneClass Y] {U V : Set X}

#print LocallyConstant.charFn /-
/-- Characteristic functions are locally constant functions taking `x : X` to `1` if `x ∈ U`,
  where `U` is a clopen set, and `0` otherwise. -/
noncomputable def charFn (hU : IsClopen U) : LocallyConstant X Y :=
  indicator 1 hU
#align locally_constant.char_fn LocallyConstant.charFn
-/

/- warning: locally_constant.coe_char_fn -> LocallyConstant.coe_charFn is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} (Y : Type.{u2}) [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulZeroOneClass.{u2} Y] {U : Set.{u1} X} (hU : IsClopen.{u1} X _inst_1 U), Eq.{max (succ u1) (succ u2)} ((fun (_x : LocallyConstant.{u1, u2} X Y _inst_1) => X -> Y) (LocallyConstant.charFn.{u1, u2} X Y _inst_1 _inst_2 U hU)) (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (LocallyConstant.{u1, u2} X Y _inst_1) (fun (_x : LocallyConstant.{u1, u2} X Y _inst_1) => X -> Y) (LocallyConstant.hasCoeToFun.{u1, u2} X Y _inst_1) (LocallyConstant.charFn.{u1, u2} X Y _inst_1 _inst_2 U hU)) (Set.indicator.{u1, u2} X Y (MulZeroClass.toHasZero.{u2} Y (MulZeroOneClass.toMulZeroClass.{u2} Y _inst_2)) U (OfNat.ofNat.{max u1 u2} (X -> Y) 1 (OfNat.mk.{max u1 u2} (X -> Y) 1 (One.one.{max u1 u2} (X -> Y) (Pi.instOne.{u1, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => MulOneClass.toHasOne.{u2} Y (MulZeroOneClass.toMulOneClass.{u2} Y _inst_2)))))))
but is expected to have type
  forall {X : Type.{u2}} (Y : Type.{u1}) [_inst_1 : TopologicalSpace.{u2} X] [_inst_2 : MulZeroOneClass.{u1} Y] {U : Set.{u2} X} (hU : IsClopen.{u2} X _inst_1 U), Eq.{max (succ u2) (succ u1)} (forall (a : X), (fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) a) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (LocallyConstant.{u2, u1} X Y _inst_1) X (fun (_x : X) => (fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) _x) (LocallyConstant.instFunLikeLocallyConstant.{u2, u1} X Y _inst_1) (LocallyConstant.charFn.{u2, u1} X Y _inst_1 _inst_2 U hU)) (Set.indicator.{u2, u1} X Y (MulZeroOneClass.toZero.{u1} Y _inst_2) U (OfNat.ofNat.{max u2 u1} (X -> Y) 1 (One.toOfNat1.{max u2 u1} (X -> Y) (Pi.instOne.{u2, u1} X (fun (a._@.Mathlib.Algebra.IndicatorFunction._hyg.77 : X) => Y) (fun (i : X) => MulOneClass.toOne.{u1} Y (MulZeroOneClass.toMulOneClass.{u1} Y _inst_2))))))
Case conversion may be inaccurate. Consider using '#align locally_constant.coe_char_fn LocallyConstant.coe_charFnₓ'. -/
theorem coe_charFn (hU : IsClopen U) : (charFn Y hU : X → Y) = Set.indicator U 1 :=
  rfl
#align locally_constant.coe_char_fn LocallyConstant.coe_charFn

/- warning: locally_constant.char_fn_eq_one -> LocallyConstant.charFn_eq_one is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} (Y : Type.{u2}) [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulZeroOneClass.{u2} Y] {U : Set.{u1} X} [_inst_3 : Nontrivial.{u2} Y] (x : X) (hU : IsClopen.{u1} X _inst_1 U), Iff (Eq.{succ u2} Y (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (LocallyConstant.{u1, u2} X Y _inst_1) (fun (_x : LocallyConstant.{u1, u2} X Y _inst_1) => X -> Y) (LocallyConstant.hasCoeToFun.{u1, u2} X Y _inst_1) (LocallyConstant.charFn.{u1, u2} X Y _inst_1 _inst_2 U hU) x) (OfNat.ofNat.{u2} Y 1 (OfNat.mk.{u2} Y 1 (One.one.{u2} Y (MulOneClass.toHasOne.{u2} Y (MulZeroOneClass.toMulOneClass.{u2} Y _inst_2)))))) (Membership.Mem.{u1, u1} X (Set.{u1} X) (Set.hasMem.{u1} X) x U)
but is expected to have type
  forall {X : Type.{u1}} (Y : Type.{u2}) [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulZeroOneClass.{u2} Y] {U : Set.{u1} X} [_inst_3 : Nontrivial.{u2} Y] (x : X) (hU : IsClopen.{u1} X _inst_1 U), Iff (Eq.{succ u2} ((fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) x) (FunLike.coe.{max (succ u1) (succ u2), succ u1, succ u2} (LocallyConstant.{u1, u2} X Y _inst_1) X (fun (_x : X) => (fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) _x) (LocallyConstant.instFunLikeLocallyConstant.{u1, u2} X Y _inst_1) (LocallyConstant.charFn.{u1, u2} X Y _inst_1 _inst_2 U hU) x) (OfNat.ofNat.{u2} Y 1 (One.toOfNat1.{u2} Y (MulOneClass.toOne.{u2} Y (MulZeroOneClass.toMulOneClass.{u2} Y _inst_2))))) (Membership.mem.{u1, u1} X (Set.{u1} X) (Set.instMembershipSet.{u1} X) x U)
Case conversion may be inaccurate. Consider using '#align locally_constant.char_fn_eq_one LocallyConstant.charFn_eq_oneₓ'. -/
theorem charFn_eq_one [Nontrivial Y] (x : X) (hU : IsClopen U) : charFn Y hU x = (1 : Y) ↔ x ∈ U :=
  Set.indicator_eq_one_iff_mem _
#align locally_constant.char_fn_eq_one LocallyConstant.charFn_eq_one

/- warning: locally_constant.char_fn_eq_zero -> LocallyConstant.charFn_eq_zero is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} (Y : Type.{u2}) [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulZeroOneClass.{u2} Y] {U : Set.{u1} X} [_inst_3 : Nontrivial.{u2} Y] (x : X) (hU : IsClopen.{u1} X _inst_1 U), Iff (Eq.{succ u2} Y (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (LocallyConstant.{u1, u2} X Y _inst_1) (fun (_x : LocallyConstant.{u1, u2} X Y _inst_1) => X -> Y) (LocallyConstant.hasCoeToFun.{u1, u2} X Y _inst_1) (LocallyConstant.charFn.{u1, u2} X Y _inst_1 _inst_2 U hU) x) (OfNat.ofNat.{u2} Y 0 (OfNat.mk.{u2} Y 0 (Zero.zero.{u2} Y (MulZeroClass.toHasZero.{u2} Y (MulZeroOneClass.toMulZeroClass.{u2} Y _inst_2)))))) (Not (Membership.Mem.{u1, u1} X (Set.{u1} X) (Set.hasMem.{u1} X) x U))
but is expected to have type
  forall {X : Type.{u1}} (Y : Type.{u2}) [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : MulZeroOneClass.{u2} Y] {U : Set.{u1} X} [_inst_3 : Nontrivial.{u2} Y] (x : X) (hU : IsClopen.{u1} X _inst_1 U), Iff (Eq.{succ u2} ((fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) x) (FunLike.coe.{max (succ u1) (succ u2), succ u1, succ u2} (LocallyConstant.{u1, u2} X Y _inst_1) X (fun (_x : X) => (fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) _x) (LocallyConstant.instFunLikeLocallyConstant.{u1, u2} X Y _inst_1) (LocallyConstant.charFn.{u1, u2} X Y _inst_1 _inst_2 U hU) x) (OfNat.ofNat.{u2} Y 0 (Zero.toOfNat0.{u2} Y (MulZeroOneClass.toZero.{u2} Y _inst_2)))) (Not (Membership.mem.{u1, u1} X (Set.{u1} X) (Set.instMembershipSet.{u1} X) x U))
Case conversion may be inaccurate. Consider using '#align locally_constant.char_fn_eq_zero LocallyConstant.charFn_eq_zeroₓ'. -/
theorem charFn_eq_zero [Nontrivial Y] (x : X) (hU : IsClopen U) : charFn Y hU x = (0 : Y) ↔ x ∉ U :=
  Set.indicator_eq_zero_iff_not_mem _
#align locally_constant.char_fn_eq_zero LocallyConstant.charFn_eq_zero

#print LocallyConstant.charFn_inj /-
theorem charFn_inj [Nontrivial Y] (hU : IsClopen U) (hV : IsClopen V)
    (h : charFn Y hU = charFn Y hV) : U = V :=
  Set.indicator_one_inj Y <| coe_inj.mpr h
#align locally_constant.char_fn_inj LocallyConstant.charFn_inj
-/

end CharFn

@[to_additive]
instance [Div Y] : Div (LocallyConstant X Y)
    where div f g := ⟨f / g, f.IsLocallyConstant.div g.IsLocallyConstant⟩

#print LocallyConstant.coe_div /-
@[to_additive]
theorem coe_div [Div Y] (f g : LocallyConstant X Y) : ⇑(f / g) = f / g :=
  rfl
#align locally_constant.coe_div LocallyConstant.coe_div
#align locally_constant.coe_sub LocallyConstant.coe_sub
-/

#print LocallyConstant.div_apply /-
@[to_additive]
theorem div_apply [Div Y] (f g : LocallyConstant X Y) (x : X) : (f / g) x = f x / g x :=
  rfl
#align locally_constant.div_apply LocallyConstant.div_apply
#align locally_constant.sub_apply LocallyConstant.sub_apply
-/

@[to_additive]
instance [Semigroup Y] : Semigroup (LocallyConstant X Y) :=
  { LocallyConstant.hasMul with
    mul_assoc := by
      intros
      ext
      simp only [mul_apply, mul_assoc] }

instance [SemigroupWithZero Y] : SemigroupWithZero (LocallyConstant X Y) :=
  { LocallyConstant.mulZeroClass, LocallyConstant.semigroup with }

@[to_additive]
instance [CommSemigroup Y] : CommSemigroup (LocallyConstant X Y) :=
  { LocallyConstant.semigroup with
    mul_comm := by
      intros
      ext
      simp only [mul_apply, mul_comm] }

@[to_additive]
instance [Monoid Y] : Monoid (LocallyConstant X Y) :=
  { LocallyConstant.semigroup, LocallyConstant.mulOneClass with mul := (· * ·) }

instance [AddMonoidWithOne Y] : AddMonoidWithOne (LocallyConstant X Y) :=
  { LocallyConstant.addMonoid,
    LocallyConstant.hasOne with
    natCast := fun n => const X n
    natCast_zero := by ext <;> simp [Nat.cast]
    natCast_succ := fun _ => by ext <;> simp [Nat.cast] }

@[to_additive]
instance [CommMonoid Y] : CommMonoid (LocallyConstant X Y) :=
  { LocallyConstant.commSemigroup, LocallyConstant.monoid with }

@[to_additive]
instance [Group Y] : Group (LocallyConstant X Y) :=
  { LocallyConstant.monoid, LocallyConstant.hasInv,
    LocallyConstant.hasDiv with
    mul_left_inv := by
      intros
      ext
      simp only [mul_apply, inv_apply, one_apply, mul_left_inv]
    div_eq_mul_inv := by
      intros
      ext
      simp only [mul_apply, inv_apply, div_apply, div_eq_mul_inv] }

@[to_additive]
instance [CommGroup Y] : CommGroup (LocallyConstant X Y) :=
  { LocallyConstant.commMonoid, LocallyConstant.group with }

instance [Distrib Y] : Distrib (LocallyConstant X Y) :=
  { LocallyConstant.hasAdd,
    LocallyConstant.hasMul with
    left_distrib := by
      intros
      ext
      simp only [mul_apply, add_apply, mul_add]
    right_distrib := by
      intros
      ext
      simp only [mul_apply, add_apply, add_mul] }

instance [NonUnitalNonAssocSemiring Y] : NonUnitalNonAssocSemiring (LocallyConstant X Y) :=
  { LocallyConstant.addCommMonoid, LocallyConstant.hasMul, LocallyConstant.distrib,
    LocallyConstant.mulZeroClass with }

instance [NonUnitalSemiring Y] : NonUnitalSemiring (LocallyConstant X Y) :=
  { LocallyConstant.semigroup, LocallyConstant.nonUnitalNonAssocSemiring with }

instance [NonAssocSemiring Y] : NonAssocSemiring (LocallyConstant X Y) :=
  { LocallyConstant.mulOneClass, LocallyConstant.addMonoidWithOne,
    LocallyConstant.nonUnitalNonAssocSemiring with }

/- warning: locally_constant.const_ring_hom -> LocallyConstant.constRingHom is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : NonAssocSemiring.{u2} Y], RingHom.{u2, max u1 u2} Y (LocallyConstant.{u1, u2} X Y _inst_1) _inst_2 (LocallyConstant.nonAssocSemiring.{u1, u2} X Y _inst_1 _inst_2)
but is expected to have type
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : NonAssocSemiring.{u2} Y], RingHom.{u2, max u2 u1} Y (LocallyConstant.{u1, u2} X Y _inst_1) _inst_2 (LocallyConstant.instNonAssocSemiringLocallyConstant.{u1, u2} X Y _inst_1 _inst_2)
Case conversion may be inaccurate. Consider using '#align locally_constant.const_ring_hom LocallyConstant.constRingHomₓ'. -/
/-- The constant-function embedding, as a ring hom.  -/
@[simps]
def constRingHom [NonAssocSemiring Y] : Y →+* LocallyConstant X Y :=
  { constMonoidHom, constAddMonoidHom with toFun := const X }
#align locally_constant.const_ring_hom LocallyConstant.constRingHom

instance [Semiring Y] : Semiring (LocallyConstant X Y) :=
  { LocallyConstant.nonAssocSemiring, LocallyConstant.monoid with }

instance [NonUnitalCommSemiring Y] : NonUnitalCommSemiring (LocallyConstant X Y) :=
  { LocallyConstant.nonUnitalSemiring, LocallyConstant.commSemigroup with }

instance [CommSemiring Y] : CommSemiring (LocallyConstant X Y) :=
  { LocallyConstant.semiring, LocallyConstant.commMonoid with }

instance [NonUnitalNonAssocRing Y] : NonUnitalNonAssocRing (LocallyConstant X Y) :=
  { LocallyConstant.addCommGroup, LocallyConstant.hasMul, LocallyConstant.distrib,
    LocallyConstant.mulZeroClass with }

instance [NonUnitalRing Y] : NonUnitalRing (LocallyConstant X Y) :=
  { LocallyConstant.semigroup, LocallyConstant.nonUnitalNonAssocRing with }

instance [NonAssocRing Y] : NonAssocRing (LocallyConstant X Y) :=
  { LocallyConstant.mulOneClass, LocallyConstant.nonUnitalNonAssocRing with }

instance [Ring Y] : Ring (LocallyConstant X Y) :=
  { LocallyConstant.semiring, LocallyConstant.addCommGroup with }

instance [NonUnitalCommRing Y] : NonUnitalCommRing (LocallyConstant X Y) :=
  { LocallyConstant.nonUnitalCommSemiring, LocallyConstant.nonUnitalRing with }

instance [CommRing Y] : CommRing (LocallyConstant X Y) :=
  { LocallyConstant.commSemiring, LocallyConstant.ring with }

variable {R : Type _}

instance [SMul R Y] : SMul R (LocallyConstant X Y)
    where smul r f :=
    { toFun := r • f
      IsLocallyConstant := (f.IsLocallyConstant.comp ((· • ·) r) : _) }

#print LocallyConstant.coe_smul /-
@[simp]
theorem coe_smul [SMul R Y] (r : R) (f : LocallyConstant X Y) : ⇑(r • f) = r • f :=
  rfl
#align locally_constant.coe_smul LocallyConstant.coe_smul
-/

#print LocallyConstant.smul_apply /-
theorem smul_apply [SMul R Y] (r : R) (f : LocallyConstant X Y) (x : X) : (r • f) x = r • f x :=
  rfl
#align locally_constant.smul_apply LocallyConstant.smul_apply
-/

instance [Monoid R] [MulAction R Y] : MulAction R (LocallyConstant X Y) :=
  Function.Injective.mulAction _ coe_injective fun _ _ => rfl

instance [Monoid R] [AddMonoid Y] [DistribMulAction R Y] :
    DistribMulAction R (LocallyConstant X Y) :=
  Function.Injective.distribMulAction coeFnAddMonoidHom coe_injective fun _ _ => rfl

instance [Semiring R] [AddCommMonoid Y] [Module R Y] : Module R (LocallyConstant X Y) :=
  Function.Injective.module R coeFnAddMonoidHom coe_injective fun _ _ => rfl

section Algebra

variable [CommSemiring R] [Semiring Y] [Algebra R Y]

instance : Algebra R (LocallyConstant X Y)
    where
  toRingHom := constRingHom.comp <| algebraMap R Y
  commutes' := by
    intros
    ext
    exact Algebra.commutes' _ _
  smul_def' := by
    intros
    ext
    exact Algebra.smul_def' _ _

/- warning: locally_constant.coe_algebra_map -> LocallyConstant.coe_algebraMap is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] {R : Type.{u3}} [_inst_2 : CommSemiring.{u3} R] [_inst_3 : Semiring.{u2} Y] [_inst_4 : Algebra.{u3, u2} R Y _inst_2 _inst_3] (r : R), Eq.{max (succ u1) (succ u2)} (X -> Y) (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (LocallyConstant.{u1, u2} X Y _inst_1) (fun (_x : LocallyConstant.{u1, u2} X Y _inst_1) => X -> Y) (LocallyConstant.hasCoeToFun.{u1, u2} X Y _inst_1) (coeFn.{max (succ u3) (succ (max u1 u2)), max (succ u3) (succ (max u1 u2))} (RingHom.{u3, max u1 u2} R (LocallyConstant.{u1, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u3} R (CommSemiring.toSemiring.{u3} R _inst_2)) (Semiring.toNonAssocSemiring.{max u1 u2} (LocallyConstant.{u1, u2} X Y _inst_1) (LocallyConstant.semiring.{u1, u2} X Y _inst_1 _inst_3))) (fun (_x : RingHom.{u3, max u1 u2} R (LocallyConstant.{u1, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u3} R (CommSemiring.toSemiring.{u3} R _inst_2)) (Semiring.toNonAssocSemiring.{max u1 u2} (LocallyConstant.{u1, u2} X Y _inst_1) (LocallyConstant.semiring.{u1, u2} X Y _inst_1 _inst_3))) => R -> (LocallyConstant.{u1, u2} X Y _inst_1)) (RingHom.hasCoeToFun.{u3, max u1 u2} R (LocallyConstant.{u1, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u3} R (CommSemiring.toSemiring.{u3} R _inst_2)) (Semiring.toNonAssocSemiring.{max u1 u2} (LocallyConstant.{u1, u2} X Y _inst_1) (LocallyConstant.semiring.{u1, u2} X Y _inst_1 _inst_3))) (algebraMap.{u3, max u1 u2} R (LocallyConstant.{u1, u2} X Y _inst_1) _inst_2 (LocallyConstant.semiring.{u1, u2} X Y _inst_1 _inst_3) (LocallyConstant.algebra.{u1, u2, u3} X Y _inst_1 R _inst_2 _inst_3 _inst_4)) r)) (coeFn.{max (succ u3) (succ (max u1 u2)), max (succ u3) (succ (max u1 u2))} (RingHom.{u3, max u1 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u3} R (CommSemiring.toSemiring.{u3} R _inst_2)) (Semiring.toNonAssocSemiring.{max u1 u2} (X -> Y) (Pi.semiring.{u1, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => _inst_3)))) (fun (_x : RingHom.{u3, max u1 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u3} R (CommSemiring.toSemiring.{u3} R _inst_2)) (Semiring.toNonAssocSemiring.{max u1 u2} (X -> Y) (Pi.semiring.{u1, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => _inst_3)))) => R -> X -> Y) (RingHom.hasCoeToFun.{u3, max u1 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u3} R (CommSemiring.toSemiring.{u3} R _inst_2)) (Semiring.toNonAssocSemiring.{max u1 u2} (X -> Y) (Pi.semiring.{u1, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => _inst_3)))) (algebraMap.{u3, max u1 u2} R (X -> Y) _inst_2 (Pi.semiring.{u1, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => _inst_3)) (Function.algebra.{u3, u1, u2} R X Y _inst_2 _inst_3 _inst_4)) r)
but is expected to have type
  forall {X : Type.{u3}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u3} X] {R : Type.{u1}} [_inst_2 : CommSemiring.{u1} R] [_inst_3 : Semiring.{u2} Y] [_inst_4 : Algebra.{u1, u2} R Y _inst_2 _inst_3] (r : R), Eq.{max (succ u3) (succ u2)} (forall (ᾰ : X), (fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) ᾰ) (FunLike.coe.{max (succ u3) (succ u2), succ u3, succ u2} ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : R) => LocallyConstant.{u3, u2} X Y _inst_1) r) X (fun (_x : X) => (fun (x._@.Mathlib.Topology.LocallyConstant.Basic._hyg.5691 : X) => Y) _x) (LocallyConstant.instFunLikeLocallyConstant.{u3, u2} X Y _inst_1) (FunLike.coe.{max (max (succ u3) (succ u2)) (succ u1), succ u1, max (succ u3) (succ u2)} (RingHom.{u1, max u2 u3} R (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3))) R (fun (_x : R) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : R) => LocallyConstant.{u3, u2} X Y _inst_1) _x) (MulHomClass.toFunLike.{max (max u3 u2) u1, u1, max u3 u2} (RingHom.{u1, max u2 u3} R (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3))) R (LocallyConstant.{u3, u2} X Y _inst_1) (NonUnitalNonAssocSemiring.toMul.{u1} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)))) (NonUnitalNonAssocSemiring.toMul.{max u3 u2} (LocallyConstant.{u3, u2} X Y _inst_1) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{max u3 u2} (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3)))) (NonUnitalRingHomClass.toMulHomClass.{max (max u3 u2) u1, u1, max u3 u2} (RingHom.{u1, max u2 u3} R (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3))) R (LocallyConstant.{u3, u2} X Y _inst_1) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2))) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{max u3 u2} (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3))) (RingHomClass.toNonUnitalRingHomClass.{max (max u3 u2) u1, u1, max u3 u2} (RingHom.{u1, max u2 u3} R (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3))) R (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3)) (RingHom.instRingHomClassRingHom.{u1, max u3 u2} R (LocallyConstant.{u3, u2} X Y _inst_1) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u2 u3} (LocallyConstant.{u3, u2} X Y _inst_1) (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3)))))) (algebraMap.{u1, max u2 u3} R (LocallyConstant.{u3, u2} X Y _inst_1) _inst_2 (LocallyConstant.instSemiringLocallyConstant.{u3, u2} X Y _inst_1 _inst_3) (LocallyConstant.instAlgebraLocallyConstantInstSemiringLocallyConstant.{u3, u2, u1} X Y _inst_1 R _inst_2 _inst_3 _inst_4)) r)) (FunLike.coe.{max (max (succ u3) (succ u2)) (succ u1), succ u1, max (succ u3) (succ u2)} (RingHom.{u1, max u3 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3)))) R (fun (_x : R) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : R) => X -> Y) _x) (MulHomClass.toFunLike.{max (max u3 u2) u1, u1, max u3 u2} (RingHom.{u1, max u3 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3)))) R (X -> Y) (NonUnitalNonAssocSemiring.toMul.{u1} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)))) (NonUnitalNonAssocSemiring.toMul.{max u3 u2} (X -> Y) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{max u3 u2} (X -> Y) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3))))) (NonUnitalRingHomClass.toMulHomClass.{max (max u3 u2) u1, u1, max u3 u2} (RingHom.{u1, max u3 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3)))) R (X -> Y) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2))) (NonAssocSemiring.toNonUnitalNonAssocSemiring.{max u3 u2} (X -> Y) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3)))) (RingHomClass.toNonUnitalRingHomClass.{max (max u3 u2) u1, u1, max u3 u2} (RingHom.{u1, max u3 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3)))) R (X -> Y) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3))) (RingHom.instRingHomClassRingHom.{u1, max u3 u2} R (X -> Y) (Semiring.toNonAssocSemiring.{u1} R (CommSemiring.toSemiring.{u1} R _inst_2)) (Semiring.toNonAssocSemiring.{max u3 u2} (X -> Y) (Pi.semiring.{u3, u2} X (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) (fun (i : X) => _inst_3))))))) (algebraMap.{u1, max u3 u2} R (X -> Y) _inst_2 (Pi.semiring.{u3, u2} X (fun (ᾰ : X) => Y) (fun (i : X) => _inst_3)) (Pi.algebra.{u3, u2, u1} X R (fun (a._@.Mathlib.Topology.LocallyConstant.Algebra._hyg.2488 : X) => Y) _inst_2 (fun (i : X) => _inst_3) (fun (i : X) => _inst_4))) r)
Case conversion may be inaccurate. Consider using '#align locally_constant.coe_algebra_map LocallyConstant.coe_algebraMapₓ'. -/
@[simp]
theorem coe_algebraMap (r : R) : ⇑(algebraMap R (LocallyConstant X Y) r) = algebraMap R (X → Y) r :=
  rfl
#align locally_constant.coe_algebra_map LocallyConstant.coe_algebraMap

end Algebra

end LocallyConstant


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Heather Macbeth
-/
import topology.order.basic
import topology.homeomorph

/-!
# Continuity of monotone functions

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

In this file we prove the following fact: if `f` is a monotone function on a neighborhood of `a`
and the image of this neighborhood is a neighborhood of `f a`, then `f` is continuous at `a`, see
`continuous_at_of_monotone_on_of_image_mem_nhds`, as well as several similar facts.

We also prove that an `order_iso` is continuous.

## Tags

continuous, monotone
-/

open set filter
open_locale topology

section linear_order
variables {α β : Type*} [linear_order α] [topological_space α] [order_topology α]
variables [linear_order β] [topological_space β] [order_topology β]

/-- If `f` is a function strictly monotone on a right neighborhood of `a` and the
image of this neighborhood under `f` meets every interval `(f a, b]`, `b > f a`, then `f` is
continuous at `a` from the right.

The assumption `hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b` is required because otherwise the
function `f : ℝ → ℝ` given by `f x = if x ≤ 0 then x else x + 1` would be a counter-example at
`a = 0`. -/
lemma strict_mono_on.continuous_at_right_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b) :
  continuous_within_at f (Ici a) a :=
begin
  have ha : a ∈ Ici a := left_mem_Ici,
  have has : a ∈ s := mem_of_mem_nhds_within ha hs,
  refine tendsto_order.2 ⟨λ b hb, _, λ b hb, _⟩,
  { filter_upwards [hs, self_mem_nhds_within] with _ hxs hxa
      using hb.trans_le ((h_mono.le_iff_le has hxs).2 hxa) },
  { rcases hfs b hb with ⟨c, hcs, hac, hcb⟩,
    rw [h_mono.lt_iff_lt has hcs] at hac,
    filter_upwards [hs, Ico_mem_nhds_within_Ici (left_mem_Ico.2 hac)],
    rintros x hx ⟨hax, hxc⟩,
    exact ((h_mono.lt_iff_lt hx hcs).2 hxc).trans_le hcb }
end

/-- If `f` is a monotone function on a right neighborhood of `a` and the image of this neighborhood
under `f` meets every interval `(f a, b)`, `b > f a`, then `f` is continuous at `a` from the right.

The assumption `hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioo (f a) b` cannot be replaced by the weaker
assumption `hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b` we use for strictly monotone functions
because otherwise the function `ceil : ℝ → ℤ` would be a counter-example at `a = 0`. -/
lemma continuous_at_right_of_monotone_on_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : monotone_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioo (f a) b) :
  continuous_within_at f (Ici a) a :=
begin
  have ha : a ∈ Ici a := left_mem_Ici,
  have has : a ∈ s := mem_of_mem_nhds_within ha hs,
  refine tendsto_order.2 ⟨λ b hb, _, λ b hb, _⟩,
  { filter_upwards [hs, self_mem_nhds_within] with _ hxs hxa
      using hb.trans_le (h_mono has hxs hxa) },
  { rcases hfs b hb with ⟨c, hcs, hac, hcb⟩,
    have : a < c, from not_le.1 (λ h, hac.not_le $ h_mono hcs has h),
    filter_upwards [hs, Ico_mem_nhds_within_Ici (left_mem_Ico.2 this)],
    rintros x hx ⟨hax, hxc⟩,
    exact (h_mono hx hcs hxc.le).trans_lt hcb }
end

/-- If a function `f` with a densely ordered codomain is monotone on a right neighborhood of `a` and
the closure of the image of this neighborhood under `f` is a right neighborhood of `f a`, then `f`
is continuous at `a` from the right. -/
lemma continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : monotone_on f s)
  (hs : s ∈ 𝓝[≥] a) (hfs : closure (f '' s) ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
begin
  refine continuous_at_right_of_monotone_on_of_exists_between h_mono hs (λ b hb, _),
  rcases (mem_nhds_within_Ici_iff_exists_mem_Ioc_Ico_subset hb).1 hfs with ⟨b', ⟨hab', hbb'⟩, hb'⟩,
  rcases exists_between hab' with ⟨c', hc'⟩,
  rcases mem_closure_iff.1 (hb' ⟨hc'.1.le, hc'.2⟩) (Ioo (f a) b') is_open_Ioo hc'
    with ⟨_, hc, ⟨c, hcs, rfl⟩⟩,
  exact ⟨c, hcs, hc.1, hc.2.trans_le hbb'⟩
end

/-- If a function `f` with a densely ordered codomain is monotone on a right neighborhood of `a` and
the image of this neighborhood under `f` is a right neighborhood of `f a`, then `f` is continuous at
`a` from the right. -/
lemma continuous_at_right_of_monotone_on_of_image_mem_nhds_within [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : monotone_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : f '' s ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within h_mono hs $
  mem_of_superset hfs subset_closure

/-- If a function `f` with a densely ordered codomain is strictly monotone on a right neighborhood
of `a` and the closure of the image of this neighborhood under `f` is a right neighborhood of `f a`,
then `f` is continuous at `a` from the right. -/
lemma strict_mono_on.continuous_at_right_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : closure (f '' s) ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within
  (λ x hx y hy, (h_mono.le_iff_le hx hy).2) hs hfs

/-- If a function `f` with a densely ordered codomain is strictly monotone on a right neighborhood
of `a` and the image of this neighborhood under `f` is a right neighborhood of `f a`, then `f` is
continuous at `a` from the right. -/
lemma strict_mono_on.continuous_at_right_of_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : f '' s ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
h_mono.continuous_at_right_of_closure_image_mem_nhds_within hs
  (mem_of_superset hfs subset_closure)

/-- If a function `f` is strictly monotone on a right neighborhood of `a` and the image of this
neighborhood under `f` includes `Ioi (f a)`, then `f` is continuous at `a` from the right. -/
lemma strict_mono_on.continuous_at_right_of_surj_on {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a) (hfs : surj_on f s (Ioi (f a))) :
  continuous_within_at f (Ici a) a :=
h_mono.continuous_at_right_of_exists_between hs $ λ b hb, let ⟨c, hcs, hcb⟩ := hfs hb in
⟨c, hcs, hcb.symm ▸ hb, hcb.le⟩

/-- If `f` is a strictly monotone function on a left neighborhood of `a` and the image of this
neighborhood under `f` meets every interval `[b, f a)`, `b < f a`, then `f` is continuous at `a`
from the left.

The assumption `hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)` is required because otherwise the
function `f : ℝ → ℝ` given by `f x = if x < 0 then x else x + 1` would be a counter-example at
`a = 0`. -/
lemma strict_mono_on.continuous_at_left_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_exists_between hs $
  λ b hb, let ⟨c, hcs, hcb, hca⟩ := hfs b hb in ⟨c, hcs, hca, hcb⟩

/-- If `f` is a monotone function on a left neighborhood of `a` and the image of this neighborhood
under `f` meets every interval `(b, f a)`, `b < f a`, then `f` is continuous at `a` from the left.

The assumption `hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ioo b (f a)` cannot be replaced by the weaker
assumption `hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)` we use for strictly monotone functions
because otherwise the function `floor : ℝ → ℤ` would be a counter-example at `a = 0`. -/
lemma continuous_at_left_of_monotone_on_of_exists_between {f : α → β} {s : set α} {a : α}
  (hf : monotone_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ioo b (f a)) :
  continuous_within_at f (Iic a) a :=
@continuous_at_right_of_monotone_on_of_exists_between αᵒᵈ βᵒᵈ _ _ _ _ _ _ f s a hf.dual hs $
  λ b hb, let ⟨c, hcs, hcb, hca⟩ := hfs b hb in ⟨c, hcs, hca, hcb⟩

/-- If a function `f` with a densely ordered codomain is monotone on a left neighborhood of `a` and
the closure of the image of this neighborhood under `f` is a left neighborhood of `f a`, then `f` is
continuous at `a` from the left -/
lemma continuous_at_left_of_monotone_on_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (hf : monotone_on f s)
  (hs : s ∈ 𝓝[≤] a) (hfs : closure (f '' s) ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
@continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within αᵒᵈ βᵒᵈ _ _ _ _ _ _ _
  f s a hf.dual hs hfs

/-- If a function `f` with a densely ordered codomain is monotone on a left neighborhood of `a` and
the image of this neighborhood under `f` is a left neighborhood of `f a`, then `f` is continuous at
`a` from the left. -/
lemma continuous_at_left_of_monotone_on_of_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : monotone_on f s)
  (hs : s ∈ 𝓝[≤] a) (hfs : f '' s ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
continuous_at_left_of_monotone_on_of_closure_image_mem_nhds_within h_mono hs
  (mem_of_superset hfs subset_closure)

/-- If a function `f` with a densely ordered codomain is strictly monotone on a left neighborhood of
`a` and the closure of the image of this neighborhood under `f` is a left neighborhood of `f a`,
then `f` is continuous at `a` from the left. -/
lemma strict_mono_on.continuous_at_left_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : closure (f '' s) ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_closure_image_mem_nhds_within hs hfs

/-- If a function `f` with a densely ordered codomain is strictly monotone on a left neighborhood of
`a` and the image of this neighborhood under `f` is a left neighborhood of `f a`, then `f` is
continuous at `a` from the left. -/
lemma strict_mono_on.continuous_at_left_of_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : f '' s ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_image_mem_nhds_within hs hfs

/-- If a function `f` is strictly monotone on a left neighborhood of `a` and the image of this
neighborhood under `f` includes `Iio (f a)`, then `f` is continuous at `a` from the left. -/
lemma strict_mono_on.continuous_at_left_of_surj_on {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a) (hfs : surj_on f s (Iio (f a))) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_surj_on hs hfs

/-- If a function `f` is strictly monotone on a neighborhood of `a` and the image of this
neighborhood under `f` meets every interval `[b, f a)`, `b < f a`, and every interval
`(f a, b]`, `b > f a`, then `f` is continuous at `a`. -/
lemma strict_mono_on.continuous_at_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝 a)
  (hfs_l : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)) (hfs_r : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨h_mono.continuous_at_left_of_exists_between (mem_nhds_within_of_mem_nhds hs) hfs_l,
   h_mono.continuous_at_right_of_exists_between (mem_nhds_within_of_mem_nhds hs) hfs_r⟩

/-- If a function `f` with a densely ordered codomain is strictly monotone on a neighborhood of `a`
and the closure of the image of this neighborhood under `f` is a neighborhood of `f a`, then `f` is
continuous at `a`. -/
lemma strict_mono_on.continuous_at_of_closure_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝 a)
  (hfs : closure (f '' s) ∈ 𝓝 (f a)) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨h_mono.continuous_at_left_of_closure_image_mem_nhds_within (mem_nhds_within_of_mem_nhds hs)
     (mem_nhds_within_of_mem_nhds hfs),
   h_mono.continuous_at_right_of_closure_image_mem_nhds_within (mem_nhds_within_of_mem_nhds hs)
     (mem_nhds_within_of_mem_nhds hfs)⟩

/-- If a function `f` with a densely ordered codomain is strictly monotone on a neighborhood of `a`
and the image of this set under `f` is a neighborhood of `f a`, then `f` is continuous at `a`. -/
lemma strict_mono_on.continuous_at_of_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝 a) (hfs : f '' s ∈ 𝓝 (f a)) :
  continuous_at f a :=
h_mono.continuous_at_of_closure_image_mem_nhds hs (mem_of_superset hfs subset_closure)

/-- If `f` is a monotone function on a neighborhood of `a` and the image of this neighborhood under
`f` meets every interval `(b, f a)`, `b < f a`, and every interval `(f a, b)`, `b > f a`, then `f`
is continuous at `a`. -/
lemma continuous_at_of_monotone_on_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : monotone_on f s) (hs : s ∈ 𝓝 a)
  (hfs_l : ∀ b < f a, ∃ c ∈ s, f c ∈ Ioo b (f a)) (hfs_r : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioo (f a) b) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨continuous_at_left_of_monotone_on_of_exists_between h_mono
     (mem_nhds_within_of_mem_nhds hs) hfs_l,
   continuous_at_right_of_monotone_on_of_exists_between h_mono
     (mem_nhds_within_of_mem_nhds hs) hfs_r⟩

/-- If a function `f` with a densely ordered codomain is monotone on a neighborhood of `a` and the
closure of the image of this neighborhood under `f` is a neighborhood of `f a`, then `f` is
continuous at `a`. -/
lemma continuous_at_of_monotone_on_of_closure_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : monotone_on f s) (hs : s ∈ 𝓝 a)
  (hfs : closure (f '' s) ∈ 𝓝 (f a)) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨continuous_at_left_of_monotone_on_of_closure_image_mem_nhds_within h_mono
     (mem_nhds_within_of_mem_nhds hs) (mem_nhds_within_of_mem_nhds hfs),
   continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within h_mono
     (mem_nhds_within_of_mem_nhds hs) (mem_nhds_within_of_mem_nhds hfs)⟩

/-- If a function `f` with a densely ordered codomain is monotone on a neighborhood of `a` and the
image of this neighborhood under `f` is a neighborhood of `f a`, then `f` is continuous at `a`. -/
lemma continuous_at_of_monotone_on_of_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : monotone_on f s) (hs : s ∈ 𝓝 a)
  (hfs : f '' s ∈ 𝓝 (f a)) :
  continuous_at f a :=
continuous_at_of_monotone_on_of_closure_image_mem_nhds h_mono hs
  (mem_of_superset hfs subset_closure)

/-- A monotone function with densely ordered codomain and a dense range is continuous. -/
lemma monotone.continuous_of_dense_range [densely_ordered β] {f : α → β}
  (h_mono : monotone f) (h_dense : dense_range f) :
  continuous f :=
continuous_iff_continuous_at.mpr $ λ a,
  continuous_at_of_monotone_on_of_closure_image_mem_nhds (λ x hx y hy hxy, h_mono hxy)
    univ_mem $ by simp only [image_univ, h_dense.closure_eq, univ_mem]

/-- A monotone surjective function with a densely ordered codomain is continuous. -/
lemma monotone.continuous_of_surjective [densely_ordered β] {f : α → β} (h_mono : monotone f)
  (h_surj : function.surjective f) :
  continuous f :=
h_mono.continuous_of_dense_range h_surj.dense_range

end linear_order

/-!
### Continuity of order isomorphisms

In this section we prove that an `order_iso` is continuous, hence it is a `homeomorph`. We prove
this for an `order_iso` between to partial orders with order topology.
-/

namespace order_iso

variables {α β : Type*} [partial_order α] [partial_order β] [topological_space α]
  [topological_space β] [order_topology α] [order_topology β]

protected lemma continuous (e : α ≃o β) : continuous e :=
begin
  rw [‹order_topology β›.topology_eq_generate_intervals],
  refine continuous_generated_from (λ s hs, _),
  rcases hs with ⟨a, rfl|rfl⟩,
  { rw e.preimage_Ioi, apply is_open_lt' },
  { rw e.preimage_Iio, apply is_open_gt' }
end

/-- An order isomorphism between two linear order `order_topology` spaces is a homeomorphism. -/
def to_homeomorph (e : α ≃o β) : α ≃ₜ β :=
{ continuous_to_fun := e.continuous,
  continuous_inv_fun := e.symm.continuous,
  .. e }

@[simp] lemma coe_to_homeomorph (e : α ≃o β) : ⇑e.to_homeomorph = e := rfl
@[simp] lemma coe_to_homeomorph_symm (e : α ≃o β) : ⇑e.to_homeomorph.symm = e.symm := rfl

end order_iso


import tactic
import apartness_spaces

open point_set_apartness

open apartness

lemma napart_of_near (X : Type) (w : point_set_apartness_space X) (A : set X) :
∀ x, near X x A → ¬ apart X x A :=
begin
intros x h h',
specialize h A h',
cases h with y h,
cases h with yh Ah,
dsimp at *,
apply apart_to_nin X y A Ah yh,
end

lemma set_prop_in_iff_prop (X : Type) (p : Prop) (x : X) : x ∈ {i : X | p} ↔ p :=
begin
simp,
end

lemma set_prop_nin_iff_not (X : Type) (p : Prop) (x : X) : x ∉ {i : X | p} ↔ ¬ p :=
begin
split,
{
    intros h ph,
    apply h,
    exact ph,
},
{
    intros ph h,
    apply ph,
    exact h,
}
end

lemma doub_neg_of_napart_near_equiv :
(∀ A x, real_near x A ↔ ¬ real_apart x A) → (∀ p : Prop, ¬ ¬ p → p) :=
begin
intros h p,
specialize h {x | p},
intro ph,
have hapart : ∀ x : ℝ, ¬ real_apart x {x : ℝ | p},
{
    intros x hx,
    apply ph,
    rw ← set_prop_nin_iff_not ℝ p x,
    exact hx,
},
have hnear : ∀ x : ℝ, real_near x {i : ℝ | p},
{
    intro x,
    exact (h x).2 (hapart x),
},
specialize hnear 0 {1} (by finish),
cases hnear with y hy,
cases hy with hy1 hy2,
exact (set_prop_in_iff_prop ℝ p y).1 hy1,
end


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta, Adam Topaz

! This file was ported from Lean 3 source module category_theory.monad.basic
! leanprover-community/mathlib commit 1995c7bbdbb0adb1b6d5acdc654f6cf46ed96cfa
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Functor.Category
import Mathlib.CategoryTheory.Functor.FullyFaithful
import Mathlib.CategoryTheory.Functor.ReflectsIso

/-!
# Monads

We construct the categories of monads and comonads, and their forgetful functors to endofunctors.

(Note that these are the category theorist's monads, not the programmers monads.
For the translation, see the file `CategoryTheory.Monad.Types`.)

For the fact that monads are "just" monoids in the category of endofunctors, see the file
`CategoryTheory.Monad.EquivMon`.
-/

namespace CategoryTheory

open Category

universe v₁ u₁

-- morphism levels before object levels. See note [CategoryTheory universes].
variable (C : Type u₁) [Category.{v₁} C]

/-- The data of a monad on C consists of an endofunctor T together with natural transformations
η : 𝟭 C ⟶ T and μ : T ⋙ T ⟶ T satisfying three equations:
- T μ_X ≫ μ_X = μ_(TX) ≫ μ_X (associativity)
- η_(TX) ≫ μ_X = 1_X (left unit)
- Tη_X ≫ μ_X = 1_X (right unit)
-/
structure Monad extends C ⥤ C where
  η' : 𝟭 _ ⟶ toFunctor
  μ' : toFunctor ⋙ toFunctor ⟶ toFunctor
  assoc' : ∀ X, toFunctor.map (NatTrans.app μ' X) ≫ μ'.app _ = μ'.app _ ≫ μ'.app _ := by aesop_cat
  left_unit' : ∀ X : C, η'.app (toFunctor.obj X) ≫ μ'.app _ = 𝟙 _ := by aesop_cat
  right_unit' : ∀ X : C, toFunctor.map (η'.app X) ≫ μ'.app _ = 𝟙 _ := by aesop_cat
#align category_theory.monad CategoryTheory.Monad

/-- The data of a comonad on C consists of an endofunctor G together with natural transformations
ε : G ⟶ 𝟭 C and δ : G ⟶ G ⋙ G satisfying three equations:
- δ_X ≫ G δ_X = δ_X ≫ δ_(GX) (coassociativity)
- δ_X ≫ ε_(GX) = 1_X (left counit)
- δ_X ≫ G ε_X = 1_X (right counit)
-/
structure Comonad extends C ⥤ C where
  ε' : toFunctor ⟶ 𝟭 _
  δ' : toFunctor ⟶ toFunctor ⋙ toFunctor
  coassoc' : ∀ X, NatTrans.app δ' _ ≫ toFunctor.map (δ'.app X) = δ'.app _ ≫ δ'.app _ := by
    aesop_cat
  left_counit' : ∀ X : C, δ'.app X ≫ ε'.app (toFunctor.obj X) = 𝟙 _ := by aesop_cat
  right_counit' : ∀ X : C, δ'.app X ≫ toFunctor.map (ε'.app X) = 𝟙 _ := by aesop_cat
#align category_theory.comonad CategoryTheory.Comonad

variable {C}
variable (T : Monad C) (G : Comonad C)

instance coeMonad : Coe (Monad C) (C ⥤ C) :=
  ⟨fun T => T.toFunctor⟩
#align category_theory.coe_monad CategoryTheory.coeMonad

instance coeComonad : Coe (Comonad C) (C ⥤ C) :=
  ⟨fun G => G.toFunctor⟩
#align category_theory.coe_comonad CategoryTheory.coeComonad

-- porting note: these lemmas are syntatic tautologies
--@[simp]
--theorem monad_toFunctor_eq_coe : T.toFunctor = T :=
--  rfl
--#align category_theory.monad_to_functor_eq_coe CategoryTheory.monad_toFunctor_eq_coe
--
--@[simp]
--theorem comonad_toFunctor_eq_coe : G.toFunctor = G :=
--  rfl
--#align category_theory.comonad_to_functor_eq_coe CategoryTheory.comonad_toFunctor_eq_coe

/-- The unit for the monad `T`. -/
def Monad.η : 𝟭 _ ⟶ (T : C ⥤ C) :=
  T.η'
#align category_theory.monad.η CategoryTheory.Monad.η

/-- The multiplication for the monad `T`. -/
def Monad.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ T :=
  T.μ'
#align category_theory.monad.μ CategoryTheory.Monad.μ

/-- The counit for the comonad `G`. -/
def Comonad.ε : (G : C ⥤ C) ⟶ 𝟭 _ :=
  G.ε'
#align category_theory.comonad.ε CategoryTheory.Comonad.ε

/-- The comultiplication for the comonad `G`. -/
def Comonad.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ G :=
  G.δ'
#align category_theory.comonad.δ CategoryTheory.Comonad.δ

/-- A custom simps projection for the functor part of a monad, as a coercion. -/
def Monad.Simps.coe :=
  (T : C ⥤ C)
#align category_theory.monad.simps.coe CategoryTheory.Monad.Simps.coe

/-- A custom simps projection for the unit of a monad, in simp normal form. -/
def Monad.Simps.η : 𝟭 _ ⟶ (T : C ⥤ C) :=
  T.η
#align category_theory.monad.simps.η CategoryTheory.Monad.Simps.η

/-- A custom simps projection for the multiplication of a monad, in simp normal form. -/
def Monad.Simps.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ (T : C ⥤ C) :=
  T.μ
#align category_theory.monad.simps.μ CategoryTheory.Monad.Simps.μ

/-- A custom simps projection for the functor part of a comonad, as a coercion. -/
def Comonad.Simps.coe :=
  (G : C ⥤ C)
#align category_theory.comonad.simps.coe CategoryTheory.Comonad.Simps.coe

/-- A custom simps projection for the counit of a comonad, in simp normal form. -/
def Comonad.Simps.ε : (G : C ⥤ C) ⟶ 𝟭 _ :=
  G.ε
#align category_theory.comonad.simps.ε CategoryTheory.Comonad.Simps.ε

/-- A custom simps projection for the comultiplication of a comonad, in simp normal form. -/
def Comonad.Simps.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ (G : C ⥤ C) :=
  G.δ
#align category_theory.comonad.simps.δ CategoryTheory.Comonad.Simps.δ

initialize_simps_projections CategoryTheory.Monad (toFunctor → coe, η' → η, μ' → μ)

initialize_simps_projections CategoryTheory.Comonad (toFunctor → coe, ε' → ε, δ' → δ)

@[reassoc]
theorem Monad.assoc (T : Monad C) (X : C) :
    (T : C ⥤ C).map (T.μ.app X) ≫ T.μ.app _ = T.μ.app _ ≫ T.μ.app _ :=
  T.assoc' X
#align category_theory.monad.assoc CategoryTheory.Monad.assoc

@[reassoc (attr := simp)]
theorem Monad.left_unit (T : Monad C) (X : C) :
    T.η.app ((T : C ⥤ C).obj X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
  T.left_unit' X
#align category_theory.monad.left_unit CategoryTheory.Monad.left_unit

@[reassoc (attr := simp)]
theorem Monad.right_unit (T : Monad C) (X : C) :
    (T : C ⥤ C).map (T.η.app X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
  T.right_unit' X
#align category_theory.monad.right_unit CategoryTheory.Monad.right_unit

@[reassoc (attr := simp)]
theorem Comonad.coassoc (G : Comonad C) (X : C) :
    G.δ.app _ ≫ (G : C ⥤ C).map (G.δ.app X) = G.δ.app _ ≫ G.δ.app _ :=
  G.coassoc' X
#align category_theory.comonad.coassoc CategoryTheory.Comonad.coassoc

@[reassoc (attr := simp)]

@[reassoc (attr := simp)]
theorem Comonad.right_counit (G : Comonad C) (X : C) :
    G.δ.app X ≫ (G : C ⥤ C).map (G.ε.app X) = 𝟙 ((G : C ⥤ C).obj X) :=
  G.right_counit' X
#align category_theory.comonad.right_counit CategoryTheory.Comonad.right_counit

/-- A morphism of monads is a natural transformation compatible with η and μ. -/
@[ext]
structure MonadHom (T₁ T₂ : Monad C) extends NatTrans (T₁ : C ⥤ C) T₂ where
  app_η : ∀ X, T₁.η.app X ≫ app X = T₂.η.app X := by aesop_cat
  app_μ : ∀ X, T₁.μ.app X ≫ app X = ((T₁ : C ⥤ C).map (app X) ≫ app _) ≫ T₂.μ.app X := by
    aesop_cat
#align category_theory.monad_hom CategoryTheory.MonadHom

/-- A morphism of comonads is a natural transformation compatible with ε and δ. -/
@[ext]
structure ComonadHom (M N : Comonad C) extends NatTrans (M : C ⥤ C) N where
  app_ε : ∀ X, app X ≫ N.ε.app X = M.ε.app X := by aesop_cat
  app_δ : ∀ X, app X ≫ N.δ.app X = M.δ.app X ≫ app _ ≫ (N : C ⥤ C).map (app X) := by aesop_cat
#align category_theory.comonad_hom CategoryTheory.ComonadHom

attribute [reassoc (attr := simp)] MonadHom.app_η MonadHom.app_μ
attribute [reassoc (attr := simp)] ComonadHom.app_ε ComonadHom.app_δ

instance : Category (Monad C) where
  Hom := MonadHom
  id M := { toNatTrans := 𝟙 (M : C ⥤ C) }
  comp f g :=
    { toNatTrans :=
        { app := fun X => f.app X ≫ g.app X
          naturality := fun X Y h => by rw [assoc, f.1.naturality_assoc, g.1.naturality] } }
  id_comp _ := MonadHom.ext _ _ (by funext; simp only [NatTrans.id_app, id_comp])
  comp_id _ := MonadHom.ext _ _ (by funext; simp only [NatTrans.id_app, comp_id])
  assoc _ _ _ := MonadHom.ext _ _ (by funext; simp only [assoc])

-- porting note: added to ease automation
@[ext]
lemma MonadHom.ext' {T₁ T₂ : Monad C} (f g : T₁ ⟶ T₂) (h : f.app = g.app) : f = g :=
  MonadHom.ext f g h

instance : Category (Comonad C) where
  Hom := ComonadHom
  id M := { toNatTrans := 𝟙 (M : C ⥤ C) }
  comp f g :=
    { toNatTrans :=
        { app := fun X => f.app X ≫ g.app X
          naturality := fun X Y h => by rw [assoc, f.1.naturality_assoc, g.1.naturality] } }
  id_comp _ := ComonadHom.ext _ _ (by funext; simp only [NatTrans.id_app, id_comp])
  comp_id _ := ComonadHom.ext _ _ (by funext; simp only [NatTrans.id_app, comp_id])
  assoc _ _ _ := ComonadHom.ext _ _ (by funext; simp only [assoc])

-- porting note: added to ease automation
@[ext]
lemma ComonadHom.ext' {T₁ T₂ : Comonad C} (f g : T₁ ⟶ T₂) (h : f.app = g.app) : f = g :=
  ComonadHom.ext f g h

instance {T : Monad C} : Inhabited (MonadHom T T) :=
  ⟨𝟙 T⟩

@[simp]
theorem MonadHom.id_toNatTrans (T : Monad C) : (𝟙 T : T ⟶ T).toNatTrans = 𝟙 (T : C ⥤ C) :=
  rfl
#align category_theory.monad_hom.id_to_nat_trans CategoryTheory.MonadHom.id_toNatTrans

@[simp]
theorem MonadHom.comp_toNatTrans {T₁ T₂ T₃ : Monad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
    (f ≫ g).toNatTrans = ((f.toNatTrans : _ ⟶ (T₂ : C ⥤ C)) ≫ g.toNatTrans : (T₁ : C ⥤ C) ⟶ T₃) :=
  rfl
#align category_theory.monad_hom.comp_to_nat_trans CategoryTheory.MonadHom.comp_toNatTrans

instance {G : Comonad C} : Inhabited (ComonadHom G G) :=
  ⟨𝟙 G⟩

@[simp]
theorem ComonadHom.id_toNatTrans (T : Comonad C) : (𝟙 T : T ⟶ T).toNatTrans = 𝟙 (T : C ⥤ C) :=
  rfl
#align category_theory.comonad_hom.id_to_nat_trans CategoryTheory.ComonadHom.id_toNatTrans

@[simp]
theorem comp_toNatTrans {T₁ T₂ T₃ : Comonad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
    (f ≫ g).toNatTrans = ((f.toNatTrans : _ ⟶ (T₂ : C ⥤ C)) ≫ g.toNatTrans : (T₁ : C ⥤ C) ⟶ T₃) :=
  rfl
#align category_theory.comp_to_nat_trans CategoryTheory.comp_toNatTrans

-- porting note: was @[simps]
/-- Construct a monad isomorphism from a natural isomorphism of functors where the forward
direction is a monad morphism. -/
@[simp]
def MonadIso.mk {M N : Monad C} (f : (M : C ⥤ C) ≅ N)
    (f_η : ∀ (X : C), M.η.app X ≫ f.hom.app X = N.η.app X)
    (f_μ : ∀ (X : C), M.μ.app X ≫ f.hom.app X =
    (M.map (f.hom.app X) ≫ f.hom.app (N.obj X)) ≫ N.μ.app X) : M ≅ N where
  hom :=
    { toNatTrans := f.hom
      app_η := f_η
      app_μ := f_μ }
  inv :=
    { toNatTrans := f.inv
      app_η := fun X => by simp [← f_η]
      app_μ := fun X => by
        rw [← NatIso.cancel_natIso_hom_right f]
        simp only [NatTrans.naturality, Iso.inv_hom_id_app, assoc, comp_id, f_μ,
          NatTrans.naturality_assoc, Iso.inv_hom_id_app_assoc, ← Functor.map_comp_assoc]
        simp }
#align category_theory.monad_iso.mk CategoryTheory.MonadIso.mk

-- porting note: was @[simps]
/-- Construct a comonad isomorphism from a natural isomorphism of functors where the forward
direction is a comonad morphism. -/
@[simp]
def ComonadIso.mk {M N : Comonad C} (f : (M : C ⥤ C) ≅ N)
    (f_ε : ∀ (X : C), f.hom.app X ≫ N.ε.app X = M.ε.app X)
    (f_δ : ∀ (X : C), f.hom.app X ≫ N.δ.app X =
    M.δ.app X ≫ f.hom.app (M.obj X) ≫ N.map (f.hom.app X)) : M ≅ N where
  hom :=
    { toNatTrans := f.hom
      app_ε := f_ε
      app_δ := f_δ }
  inv :=
    { toNatTrans := f.inv
      app_ε := fun X => by simp [← f_ε]
      app_δ := fun X => by
        rw [← NatIso.cancel_natIso_hom_left f]
        simp only [reassoc_of% (f_δ X), Iso.hom_inv_id_app_assoc, NatTrans.naturality_assoc]
        rw [← Functor.map_comp, Iso.hom_inv_id_app, Functor.map_id]
        apply (comp_id _).symm }
#align category_theory.comonad_iso.mk CategoryTheory.ComonadIso.mk

variable (C)

/-- The forgetful functor from the category of monads to the category of endofunctors.
-/
@[simps!]
def monadToFunctor : Monad C ⥤ C ⥤ C where
  obj T := T
  map f := f.toNatTrans
#align category_theory.monad_to_functor CategoryTheory.monadToFunctor

instance : Faithful (monadToFunctor C) where

/-- Porting note: removed @[simp] as simpNF says the LHS reduces to
  (monadToFunctor C).mapIso (Iso.mk (MonadHom.mk f.hom) (MonadHom.mk f.inv)).
  But upon adding a new simp lemma with this LHS and the hypotheses necessary to
  make the lemma statement type-check, simpNF raises a new complaint:
  "Left-hand side does not simplify, when using the simp lemma on itself.
  This usually means that it will never apply." -/
theorem monadToFunctor_mapIso_monad_iso_mk {M N : Monad C} (f : (M : C ⥤ C) ≅ N) (f_η f_μ) :
    (monadToFunctor _).mapIso (MonadIso.mk f f_η f_μ) = f := by
  ext
  rfl
#align category_theory.monad_to_functor_map_iso_monad_iso_mk CategoryTheory.monadToFunctor_mapIso_monad_iso_mk

instance : ReflectsIsomorphisms (monadToFunctor C) where
  reflects f _ := IsIso.of_iso (MonadIso.mk (asIso ((monadToFunctor C).map f)) f.app_η f.app_μ)

/-- The forgetful functor from the category of comonads to the category of endofunctors.
-/
@[simps!]
def comonadToFunctor : Comonad C ⥤ C ⥤ C where
  obj G := G
  map f := f.toNatTrans
#align category_theory.comonad_to_functor CategoryTheory.comonadToFunctor

instance : Faithful (comonadToFunctor C) where

/-- Porting note: removed @[simp] as simpNF says the LHS reduces to
  (comonadToFunctor C).mapIso (Iso.mk (ComonadHom.mk f.hom) (ComonadHom.mk f.inv)).
  But upon adding a new simp lemma with this LHS and the hypotheses necessary to
  make the lemma statement type-check, simpNF raises a new complaint:
  "Left-hand side does not simplify, when using the simp lemma on itself.
  This usually means that it will never apply." -/
theorem comonadToFunctor_mapIso_comonad_iso_mk {M N : Comonad C} (f : (M : C ⥤ C) ≅ N) (f_ε f_δ) :
    (comonadToFunctor _).mapIso (ComonadIso.mk f f_ε f_δ) = f := by
  ext
  rfl
#align category_theory.comonad_to_functor_map_iso_comonad_iso_mk CategoryTheory.comonadToFunctor_mapIso_comonad_iso_mk

instance : ReflectsIsomorphisms (comonadToFunctor C) where
  reflects f _ := IsIso.of_iso (ComonadIso.mk (asIso ((comonadToFunctor C).map f)) f.app_ε f.app_δ)

variable {C}

/-- An isomorphism of monads gives a natural isomorphism of the underlying functors.
-/
/- Porting note: removed
`@[simps (config := { rhsMd := semireducible })]`
and replaced with `@[simps]` in the two declarations below-/
@[simps!]
def MonadIso.toNatIso {M N : Monad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
  (monadToFunctor C).mapIso h
#align category_theory.monad_iso.to_nat_iso CategoryTheory.MonadIso.toNatIso

/-- An isomorphism of comonads gives a natural isomorphism of the underlying functors.
-/
@[simps!]
def ComonadIso.toNatIso {M N : Comonad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
  (comonadToFunctor C).mapIso h
#align category_theory.comonad_iso.to_nat_iso CategoryTheory.ComonadIso.toNatIso

variable (C)

namespace Monad

/-- The identity monad. -/
@[simps!]
def id : Monad C where
  toFunctor := 𝟭 C
  η' := 𝟙 (𝟭 C)
  μ' := 𝟙 (𝟭 C)
#align category_theory.monad.id CategoryTheory.Monad.id

instance : Inhabited (Monad C) :=
  ⟨Monad.id C⟩

end Monad

namespace Comonad

/-- The identity comonad. -/
@[simps!]
def id : Comonad C where
  toFunctor := 𝟭 _
  ε' := 𝟙 (𝟭 C)
  δ' := 𝟙 (𝟭 C)
#align category_theory.comonad.id CategoryTheory.Comonad.id

instance : Inhabited (Comonad C) :=
  ⟨Comonad.id C⟩

end Comonad

end CategoryTheory


import topology.continuity
import category_theory.instances.topological_spaces
import topology.instances.real
import category_theory.limits.binary_products
import category_theory.instances.Top.products
import piecewise

universe u
noncomputable theory

open category_theory.instances
open category_theory.limits
open category_theory
open set

local attribute [instance] has_binary_product_of_has_product

@[reducible] def I := {x : ℝ // 0 ≤ x ∧ x ≤ 1}
def 𝕀 : Top := { α := I, str := by apply_instance}

-- shorthands for 0 and 1 as elements of I
def I_0    : I := ⟨ 0, le_refl 0, le_of_lt zero_lt_one ⟩
def I_1    : I := ⟨ 1, le_of_lt zero_lt_one, le_refl 1 ⟩

-- says that the path has initial point x and final point y
def path_prop {X : Top} (x y : X.α) (map : 𝕀 ⟶ X) : Prop := map.val I_0 = x ∧ map.val I_1 = y

structure path {X : Top} (x y : X.α) :=
(map : 𝕀 ⟶ X)
(property : path_prop x y map)

def const_map (X Y : Top) (y : Y.α) : X ⟶ Y :=
{ val := (λ x, y),
  property := continuous_const }

-- a homotopy of paths is a map F from I × I → X such that
--   F(s,0) = f
--   F(s,1) = g
--   F(s,t) is a path from x to y for any fixed t
structure homotopy {X : Top} {x y : X.α} (f g : path x y) :=
  (map : limits.prod 𝕀 𝕀 ⟶ X)
  (left : prod.lift (𝟙 𝕀) (const_map 𝕀 𝕀 I_0) ≫ map = f.map)
  (right : prod.lift (𝟙 𝕀) (const_map 𝕀 𝕀 I_1) ≫ map = g.map)
  (endpts : ∀ t : I, path_prop x y (prod.lift (𝟙 𝕀) (const_map 𝕀 𝕀 t) ≫ map))

def homotopic {X : Top} {x y : X.α} (f g : path x y) := nonempty (homotopy f g)

namespace homotopic
-- we want to show that homotopic is an equivalence relation

-- given a map f this returns the homotopy from f to itself
def id_htpy {X : Top} (f : 𝕀 ⟶ X) : limits.prod 𝕀 𝕀 ⟶ X := limits.prod.fst 𝕀 𝕀 ≫ f

def reverse : ℝ → ℝ := λ x, 1 - x

lemma cont_reverse : continuous reverse := continuous_sub continuous_const continuous_id

lemma reverse_in_I (x : ℝ) (h : 0 ≤ x ∧ x ≤ 1) : 0 ≤ reverse x ∧ reverse x ≤ 1 := begin
  simp only [reverse],
  have h₁ : 0 ≤ x := h.left,
  have h₂ : x ≤ 1 := h.right,
  apply and.intro,
  linarith,
  linarith
end

def reverseI : I → I := λ x, ⟨reverse x.val, reverse_in_I x.val x.property⟩

lemma cont_reverseI : continuous reverseI := continuous_induced_rng $
  have h : subtype.val ∘ reverseI = reverse ∘ subtype.val,
    from rfl,
  have h₂ : continuous (reverse ∘ subtype.val),
    from continuous.comp continuous_induced_dom cont_reverse,
  h ▸ h₂

@[refl] theorem refl {X : Top} {x y : X.α} (f : path x y) : homotopic f f := ⟨ {
  map    := id_htpy f.map,
  left   := by rw [id_htpy, ←category.assoc]; simp,
  right  := by rw [id_htpy, ←category.assoc]; simp,
  endpts := λ t, f.property
} ⟩

@[symm] theorem symm {X : Top} {x y : X.α} (f g : path x y) : homotopic f g → homotopic g f :=
  have h : homotopy f g → homotopic g f,
    from λ ⟨G, left, right, endpts⟩, ⟨ {
      map    := sorry,
      left   := sorry,
      right  := sorry,
      endpts := sorry
    } ⟩,
  nonempty.rec h

@[trans] theorem trans {X : Top} {x y : X.α} (f g h : path x y) : homotopic f g → homotopic g h → homotopic f h :=
sorry

end homotopic

namespace path_comp

lemma in_I_of_le_half (x : I) (h : x.val ≤ 2⁻¹) : 0 ≤ 2 * x.val ∧ 2 * x.val ≤ 1 :=
  ⟨ zero_le_mul (le_of_lt two_pos) (x.property.left),
  calc
  2 * x.val ≤ 2 * 2⁻¹   : mul_le_mul_of_nonneg_left h (le_of_lt two_pos)
  ...       = 1         : mul_inv_cancel (ne_of_gt two_pos) ⟩

lemma in_I_of_ge_half (x : I) (h : x.val ≥ 2⁻¹) :
  0 ≤ 2 * x.val - 1 ∧ 2 * x.val - 1 ≤ 1 := ⟨
  have h₁ : 2 * x.val ≥ 2 * 2⁻¹,
    from mul_le_mul_of_nonneg_left h (le_of_lt two_pos),
  have h₂ : 2 * x.val ≥ 1,
    by rwa [mul_inv_cancel (ne_of_gt two_pos)] at h₁,
  by linarith,
  have h₁ : 2 * x.val ≤ 2*1,
    from mul_le_mul_of_nonneg_left (x.property.right) (le_of_lt two_pos),
  by linarith ⟩

def double : ℝ → ℝ := λ x, 2 * x

lemma cont1 : continuous double := continuous_mul continuous_const continuous_id

def double_sub_one : ℝ → ℝ := λ x, 2*x - 1

lemma cont2 : continuous double_sub_one := continuous_sub cont1 continuous_const

def s := {x : I | x.val ≤ 2⁻¹}

instance : decidable_pred s := λ x : I, has_le.le.decidable (x.val) 2⁻¹

lemma closure1 : closure s = {x : I | x.val ≤ 2⁻¹} :=
   (closure_le_eq continuous_induced_dom continuous_const)

lemma closure2 : closure (-s) ⊆ {x : I | x.val ≥ 2⁻¹} :=
  have h₁ : -s ⊆ {x : I | x.val ≥ 2⁻¹},
    from assume x hx,
    have h₁ : x.val > 2⁻¹,
      from lt_of_not_ge hx,
    le_of_lt h₁,
  have h₂ : is_closed {x : I | x.val ≥ 2⁻¹},
    from is_closed_le continuous_const continuous_induced_dom,
  closure_minimal h₁ h₂

def first_half : subtype (closure s) → I := λ x,
  have h: x.val ∈ {x : I | x.val ≤ 2⁻¹},
    from (subset.antisymm_iff.mp closure1).left x.property,
  ⟨ double x.val.val, in_I_of_le_half x.val h ⟩

def second_half : subtype (closure (-s)) → I := λ x,
  have h : x.val ∈ {x : I | x.val ≥ 2⁻¹},
    from closure2 x.property,
  ⟨ double_sub_one x.val.val, in_I_of_ge_half x.val h ⟩

lemma cont_first_half : continuous first_half :=
  continuous_induced_rng $
  have h : subtype.val ∘ first_half = double ∘ subtype.val ∘ subtype.val,
    from rfl,
  by rw [h]; exact continuous.comp
    (continuous.comp continuous_induced_dom continuous_induced_dom)
    cont1

lemma cont_second_half : continuous second_half :=
  continuous_induced_rng $
  have h : subtype.val ∘ second_half = double_sub_one ∘ subtype.val ∘ subtype.val,
    from rfl,
  by rw [h]; exact continuous.comp
    (continuous.comp continuous_induced_dom continuous_induced_dom)
    cont2

def path_comp_map {X : Top} (f g : I → X.α) : I → X.α := pw (f ∘ first_half) (g ∘ second_half)

lemma computation1 : double 2⁻¹ = 1 := mul_inv_cancel (ne_of_gt two_pos)

lemma computation2 : double_sub_one 2⁻¹ = 0 :=
  have h : (2 : ℝ) * 2⁻¹ = 1 := mul_inv_cancel (ne_of_gt two_pos),
  calc
    (2 : ℝ) * 2⁻¹ - 1 = 1 - 1  : by rw [h]
    ...               = 0      : sub_self 1

-- Formatting suggestion from Scott: put `begin` on a new-line, no indenting
theorem path_comp_continuous {X : Top} (f g : I → X.α) (hf : continuous f) (hg : continuous g)
  (h : f I_1 = g I_0) : continuous (path_comp_map f g) :=
begin
  have hp : ∀ x hx,
    (f ∘ first_half) ⟨x, frontier_subset_closure hx⟩ = (g ∘ second_half) ⟨x, frontier_subset_closure_compl hx⟩,
    intros x hx,
    have h₁ : frontier s ⊆ {x : I | x.val = 2⁻¹},
      from frontier_le_subset_eq continuous_induced_dom continuous_const,
    have h₂ : x.val = 2⁻¹ := h₁ hx,
    have hf1 : first_half ⟨x, frontier_subset_closure hx⟩ = I_1,
      have : double x.val = 1,
        rw [h₂],
        exact mul_inv_cancel (ne_of_gt two_pos),
      exact subtype.eq this,
    have hg0 : second_half ⟨x, frontier_subset_closure_compl hx⟩ = I_0,
      have : double_sub_one x.val = 0,
        simp [h₂, double_sub_one, mul_inv_cancel (ne_of_gt two_pos)],
        ring,
      exact subtype.eq this,
    simp [hf1, hg0, h],

  exact continuous_pw (f ∘ first_half) (g ∘ second_half)
    hp (continuous.comp cont_first_half hf) (continuous.comp cont_second_half hg),
end

end path_comp

open path_comp

-- this defines the type of homotopy classes of paths from x to y
def htpy_class {X : Top} (x y : X.α) := quot (@homotopic X x y)

-- to define the fundamental group(oid) we need to instantiate the category of paths in X
-- with homotopy classes of paths as morphisms between each point.
def paths (X : Top) := X.α

-- TODO
def path_composition {X : Top} {x y z : paths X} (f : path x y) (g : path y z) : path x z := {
  map := {val := path_comp_map f.map g.map,
    property := path_comp_continuous f.map.val g.map.val f.map.property g.map.property
      (trans f.property.right (symm g.property.left) )
      },
  property := sorry
}

-- [f][g] = [fg]
def composition {X : Top} {x y z : paths X} (f : path x y) : htpy_class y z → htpy_class x z :=
  quot.lift
    (λ g, quot.mk (@homotopic X x z) (path_composition f g))
    (λ a b (h : homotopic a b), quot.sound sorry)
  -- want h : quot.mk (@homotopic X x z) (path_composition f a) = quot.mk (@homotopic X x z) (path_composition f b)
  -- using quot.sound it is enough to have
  -- h : homotopic (path_composition f a) (homotopic path_composition f b)
  -- TODO ^that

lemma path_comp_associative {X : Top} {x₀ x₁ x₂ x₃ : paths X} (f : path x₀ x₁) (g : path x₁ x₂)
  (h : path x₂ x₃) :
  homotopic (path_composition f (path_composition g h)) (path_composition (path_composition f g) h) :=
  sorry

instance (X : Top) : category (paths X) := {
  hom      := λ x y, htpy_class x y,
  id       := λ x, quot.mk (λ f g, homotopic f g)
    { map := const_map 𝕀 X x, property := by tidy },
  comp     := sorry,
  assoc'   := sorry,
  comp_id' := sorry,
  id_comp' := sorry
  }

def fundamental_group (X : Top) (x : paths X) : Type := sorry


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import ring_theory.polynomial.basic
import ring_theory.principal_ideal_domain
import data.mv_polynomial.basic

/-!
# Adjoining elements to form subalgebras

This file develops the basic theory of finitely-generated subalgebras.

## Definitions

* `fg (S : subalgebra R A)` : A predicate saying that the subalgebra is finitely-generated
as an A-algebra

## Tags

adjoin, algebra, finitely-generated algebra

-/

universes u v w

open subsemiring ring submodule
open_locale pointwise

namespace algebra

variables {R : Type u} {A : Type v} {B : Type w}
  [comm_semiring R] [comm_semiring A] [algebra R A] {s t : set A}

theorem fg_trans (h1 : (adjoin R s).to_submodule.fg)
  (h2 : (adjoin (adjoin R s) t).to_submodule.fg) :
  (adjoin R (s ∪ t)).to_submodule.fg :=
begin
  rcases fg_def.1 h1 with ⟨p, hp, hp'⟩,
  rcases fg_def.1 h2 with ⟨q, hq, hq'⟩,
  refine fg_def.2 ⟨p * q, hp.mul hq, le_antisymm _ _⟩,
  { rw [span_le],
    rintros _ ⟨x, y, hx, hy, rfl⟩,
    change x * y ∈ _,
    refine subalgebra.mul_mem _ _ _,
    { have : x ∈ (adjoin R s).to_submodule,
      { rw ← hp', exact subset_span hx },
      exact adjoin_mono (set.subset_union_left _ _) this },
    have : y ∈ (adjoin (adjoin R s) t).to_submodule,
    { rw ← hq', exact subset_span hy },
    change y ∈ adjoin R (s ∪ t), rwa adjoin_union_eq_adjoin_adjoin },
  { intros r hr,
    change r ∈ adjoin R (s ∪ t) at hr,
    rw adjoin_union_eq_adjoin_adjoin at hr,
    change r ∈ (adjoin (adjoin R s) t).to_submodule at hr,
    rw [← hq', ← set.image_id q, finsupp.mem_span_image_iff_total (adjoin R s)] at hr,
    rcases hr with ⟨l, hlq, rfl⟩,
    have := @finsupp.total_apply A A (adjoin R s),
    rw [this, finsupp.sum],
    refine sum_mem _ _,
    intros z hz, change (l z).1 * _ ∈ _,
    have : (l z).1 ∈ (adjoin R s).to_submodule := (l z).2,
    rw [← hp', ← set.image_id p, finsupp.mem_span_image_iff_total R] at this,
    rcases this with ⟨l2, hlp, hl⟩,
    have := @finsupp.total_apply A A R,
    rw this at hl,
    rw [←hl, finsupp.sum_mul],
    refine sum_mem _ _,
    intros t ht, change _ * _ ∈ _, rw smul_mul_assoc, refine smul_mem _ _ _,
    exact subset_span ⟨t, z, hlp ht, hlq hz, rfl⟩ }
end

end algebra

namespace subalgebra

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B]

/-- A subalgebra `S` is finitely generated if there exists `t : finset A` such that
`algebra.adjoin R t = S`. -/
def fg (S : subalgebra R A) : Prop :=
∃ t : finset A, algebra.adjoin R ↑t = S

lemma fg_adjoin_finset (s : finset A) : (algebra.adjoin R (↑s : set A)).fg :=
⟨s, rfl⟩

theorem fg_def {S : subalgebra R A} : S.fg ↔ ∃ t : set A, set.finite t ∧ algebra.adjoin R t = S :=
⟨λ ⟨t, ht⟩, ⟨↑t, set.finite_mem_finset t, ht⟩,
λ ⟨t, ht1, ht2⟩, ⟨ht1.to_finset, by rwa set.finite.coe_to_finset⟩⟩

theorem fg_bot : (⊥ : subalgebra R A).fg :=
⟨∅, algebra.adjoin_empty R A⟩

theorem fg_of_fg_to_submodule {S : subalgebra R A} : S.to_submodule.fg → S.fg :=
λ ⟨t, ht⟩, ⟨t, le_antisymm
  (algebra.adjoin_le (λ x hx, show x ∈ S.to_submodule, from ht ▸ subset_span hx)) $
  show S.to_submodule ≤ (algebra.adjoin R ↑t).to_submodule,
  from (λ x hx, span_le.mpr
    (λ x hx, algebra.subset_adjoin hx)
      (show x ∈ span R ↑t, by { rw ht, exact hx }))⟩

theorem fg_of_noetherian [is_noetherian R A] (S : subalgebra R A) : S.fg :=
fg_of_fg_to_submodule (is_noetherian.noetherian S.to_submodule)

lemma fg_of_submodule_fg (h : (⊤ : submodule R A).fg) : (⊤ : subalgebra R A).fg :=
let ⟨s, hs⟩ := h in ⟨s, to_submodule_injective $
by { rw [algebra.top_to_submodule, eq_top_iff, ← hs, span_le], exact algebra.subset_adjoin }⟩

lemma fg_prod {S : subalgebra R A} {T : subalgebra R B} (hS : S.fg) (hT : T.fg) : (S.prod T).fg :=
begin
  obtain ⟨s, hs⟩ := fg_def.1 hS,
  obtain ⟨t, ht⟩ := fg_def.1 hT,
  rw [← hs.2, ← ht.2],
  exact fg_def.2 ⟨(linear_map.inl R A B '' (s ∪ {1})) ∪ (linear_map.inr R A B '' (t ∪ {1})),
    set.finite.union (set.finite.image _ (set.finite.union hs.1 (set.finite_singleton _)))
    (set.finite.image _ (set.finite.union ht.1 (set.finite_singleton _))),
    algebra.adjoin_inl_union_inr_eq_prod R s t⟩
end

section
open_locale classical
lemma fg_map (S : subalgebra R A) (f : A →ₐ[R] B) (hs : S.fg) : (S.map f).fg :=
let ⟨s, hs⟩ := hs in ⟨s.image f, by rw [finset.coe_image, algebra.adjoin_image, hs]⟩
end

lemma fg_of_fg_map (S : subalgebra R A) (f : A →ₐ[R] B) (hf : function.injective f)
  (hs : (S.map f).fg) : S.fg :=
let ⟨s, hs⟩ := hs in ⟨s.preimage f $ λ _ _ _ _ h, hf h, map_injective f hf $
by { rw [← algebra.adjoin_image, finset.coe_preimage, set.image_preimage_eq_of_subset, hs],
  rw [← alg_hom.coe_range, ← algebra.adjoin_le_iff, hs, ← algebra.map_top], exact map_mono le_top }⟩

lemma fg_top (S : subalgebra R A) : (⊤ : subalgebra R S).fg ↔ S.fg :=
⟨λ h, by { rw [← S.range_val, ← algebra.map_top], exact fg_map _ _ h },
λ h, fg_of_fg_map _ S.val subtype.val_injective $ by { rw [algebra.map_top, range_val], exact h }⟩

lemma induction_on_adjoin [is_noetherian R A] (P : subalgebra R A → Prop)
  (base : P ⊥) (ih : ∀ (S : subalgebra R A) (x : A), P S → P (algebra.adjoin R (insert x S)))
  (S : subalgebra R A) : P S :=
begin
  classical,
  obtain ⟨t, rfl⟩ := S.fg_of_noetherian,
  refine finset.induction_on t _ _,
  { simpa using base },
  intros x t hxt h,
  rw [finset.coe_insert],
  simpa only [algebra.adjoin_insert_adjoin] using ih _ x h,
end

end subalgebra

section semiring

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_semiring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B]

/-- The image of a Noetherian R-algebra under an R-algebra map is a Noetherian ring. -/
instance alg_hom.is_noetherian_ring_range (f : A →ₐ[R] B) [is_noetherian_ring A] :
  is_noetherian_ring f.range :=
is_noetherian_ring_range f.to_ring_hom

end semiring

section ring

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B]

theorem is_noetherian_ring_of_fg {S : subalgebra R A} (HS : S.fg)
  [is_noetherian_ring R] : is_noetherian_ring S :=
let ⟨t, ht⟩ := HS in ht ▸ (algebra.adjoin_eq_range R (↑t : set A)).symm ▸
by haveI : is_noetherian_ring (mv_polynomial (↑t : set A) R) :=
mv_polynomial.is_noetherian_ring;
convert alg_hom.is_noetherian_ring_range _; apply_instance

theorem is_noetherian_subring_closure (s : set R) (hs : s.finite) :
  is_noetherian_ring (subring.closure s) :=
show is_noetherian_ring (subalgebra_of_subring (subring.closure s)), from
algebra.adjoin_int s ▸ is_noetherian_ring_of_fg (subalgebra.fg_def.2 ⟨s, hs, rfl⟩)

end ring


import data.fintype.basic
import tactic.derive_fintype

section basics
variable Sigma : Type

@[reducible]
def word : Type := list Sigma

@[reducible]
def lang : Type := word Sigma → Prop

end basics

section dfa
variable {Sigma : Type}

structure dfa(Sigma : Type*) :=
  (Q : Type*)
  [finQ : fintype Q]
  [decQ : decidable_eq Q]
  (init : Q)
  (final : Q → Prop)
  [decF : decidable_pred final]
  (δ : Q → Sigma → Q)

open dfa

def dfa_δ_star (A : dfa Sigma) : A.Q → word Sigma → A.Q
| q [] := q
| q (x :: w) := dfa_δ_star (A.δ q x) w

def dfa_lang (A : dfa Sigma) : lang Sigma
:= λ w , A.final (dfa_δ_star A A.init w)

end dfa

section nfa
variables {Sigma : Type}

structure nfa(Sigma : Type*) :=
  (Q : Type*)
  [finQ : fintype Q]
  [decQ : decidable_eq Q]
  (inits : Q → Prop)
  [decI : decidable_pred inits]
  (final : Q → Prop)
  [decF : decidable_pred final]
  (δ : Q → Sigma → Q → Prop)
  [decD : decidable_pred (sigma.uncurry (sigma.uncurry δ))]

open nfa

def nfa_δ_star : Π A : nfa Sigma , A.Q → word Sigma → A.Q → Prop
| A q0 [] q1 := q0 = q1
| A q0 (x :: w) q1 := ∃ q2 : A.Q, A.δ q0 x q2 ∧ nfa_δ_star A q2 w q1

def nfa_lang (A : nfa Sigma) : lang Sigma
:= λ w , ∃ q0 q1 : A.Q, A.inits q0 ∧ nfa_δ_star A q0 w q1 ∧ A.final q1

def empty_nfa {Sigma : Type*} : nfa Sigma :=
  {
    Q := fin 1,
    finQ := by apply_instance,
    decQ := by apply_instance,
    inits := λ _ , true,
    decI := by apply_instance,
    final := λ _ , false,
    decF := by apply_instance,
    δ := λ _ _ _ , false,
    decD := λ _, by {dsimp[sigma.uncurry], apply_instance,},
  }

def epsilon_nfa {Sigma : Type*} : nfa Sigma :=
  {
    Q := fin 1,
    finQ := by apply_instance,
    decQ := by apply_instance,
    inits := λ _ , true,
    decI := by apply_instance,
    final := λ _ , true,
    decF := by apply_instance,
    δ := λ _ _ _ , false,
    decD := λ _, by {dsimp[sigma.uncurry], apply_instance,},
  }

def single_nfa {Sigma : Type*} [decidable_eq Sigma] (lit : Sigma) : nfa Sigma :=
  {
    Q := fin 2,
    finQ := by apply_instance,
    decQ := by apply_instance,
    inits := λ x , x.val = 0,
    decI := by apply_instance,
    final := λ x , x.val = 1,
    decF := by apply_instance,
    δ := λ q0 x q1 , q0.val = 0 ∧ x = lit ∧ q1.val = 1,
    decD := begin
      assume x,
      dsimp [sigma.uncurry],
      apply_instance,
    end
  }

end nfa

section ε_nfa
variables {Sigma : Type} [decidable_eq Sigma]

structure ε_nfa(Sigma : Type) :=
  (Q : Type*)
  [finQ : fintype Q]
  [decQ : decidable_eq Q]
  (inits : Q → Prop)
  [decI : decidable_pred inits]
  (final : Q → Prop)
  [decF : decidable_pred final]
  (δ : Q → option Sigma → Q → Prop)
  [decD : decidable_pred (sigma.uncurry (sigma.uncurry δ))]

open ε_nfa

inductive ε_closure{A : ε_nfa Sigma} : (A.Q → Prop) → A.Q → Prop
| base : ∀ x : A.Q → Prop, ∀ q : A.Q, x q → ε_closure x q
| step : ∀ x : A.Q → Prop, ∀ q q' : A.Q, ε_closure x q → A.δ q none q' → ε_closure x q'

/-
def ε_nfa_δ_star : Π A : ε_nfa Sigma , A.Q → word Sigma → A.Q → Prop
| A q0 [] q1 := ε_closure (λ q, q = q0) q1
| A q0 (x :: w) q1 := ∃ q2 : A.Q, (A.δ q0 (some x) q2 ∨ A.δ q0 none q2) ∧  ε_nfa_δ_star A q2 w q1
-/

inductive ε_nfa_δ_star (A : ε_nfa Sigma) : A.Q → word Sigma → A.Q → Prop
| empty : ∀ q : A.Q , ε_nfa_δ_star q [] q
| step : ∀ q0 q1 q2 : A.Q, ∀ x : Sigma, ∀ w : word Sigma,
            A.δ q0 (some x) q1 → ε_nfa_δ_star q1 w q2 → ε_nfa_δ_star q0 (x :: w) q2
| epsilon : ∀ q0 q1 q2 : A.Q, ∀ w : word Sigma,
            A.δ q0 none q1 → ε_nfa_δ_star q1 w q2 → ε_nfa_δ_star q0 w q2

def ε_nfa_lang (A : ε_nfa Sigma) : lang Sigma
:= λ w , ∃ q0 q1 : A.Q, A.inits q0 ∧ ε_nfa_δ_star A q0 w q1 ∧ A.final q1

theorem inversion : ∀ A : ε_nfa Sigma, ∀ q q' : A.Q, ∀ w : word Sigma,
        ε_nfa_δ_star A q w q' →
        (w = [] ∧ q' = q)
        ∨ (∃ x : Sigma, ∃ w' : word Sigma, ∃ q'' : A.Q , w = x :: w' ∧ A.δ q (some x) q'' ∧ ε_nfa_δ_star A q'' w' q')
        ∨ (∃ q'' : A.Q , A.δ q none q'' ∧ ε_nfa_δ_star A q'' w q') :=
begin
  assume A q q' w,
  assume h,
  cases h,
  left,
  constructor,
  refl,
  refl,
  right, left,
  existsi h_x,
  existsi h_w,
  existsi h_q1,
  constructor,
  refl,
  constructor,
  exact h_ᾰ,
  exact h_ᾰ_1,
  right, right,
  existsi h_q1,
  constructor,
  exact h_ᾰ,
  exact h_ᾰ_1,
end

end ε_nfa

section dfa2nfa
variables {Sigma : Type}

def dfa2nfa(A : dfa Sigma) : nfa Sigma :=
  {
    Q := A.Q,
    finQ := A.finQ,
    decQ := A.decQ,
    inits := λ q : A.Q, q = A.init,
    decI := λ q, A.decQ q A.init,
    final := A.final,
    decF := A.decF,
    δ := λ q0 x q1 , q1 = A.δ q0 x,
    decD := λ q , A.decQ q.snd (A.δ q.fst.fst q.fst.snd),
  }

lemma nfaδ2dfaδ : ∀ A : dfa Sigma, ∀ w : word Sigma,
  ∀ q0 q1 : A.Q, dfa_δ_star A q0 w = q1 ↔ nfa_δ_star (dfa2nfa A) q0 w q1 :=
begin
  assume A w,
  induction w,
  {
    assume q0 q1,
    constructor,
    dsimp [dfa_δ_star, nfa_δ_star],
    assume h,
    exact h,
    dsimp [dfa_δ_star, nfa_δ_star],
    assume h,
    exact h,
  },
  {
    assume q0 q1,
    constructor,
    {
      assume h,
      dsimp [nfa_δ_star],
      existsi A.δ q0 w_hd,
      constructor,
      dsimp [dfa2nfa],
      reflexivity,
      apply (iff.mp (w_ih (A.δ q0 w_hd) q1)),
      exact h,
    },
    {
      dsimp [dfa_δ_star, nfa_δ_star],
      assume g,
      apply (iff.mpr (w_ih (A.δ q0 w_hd) q1)),
      cases g with q00 gg,
      have eq: A.δ q0 w_hd = q00,
      dsimp [dfa2nfa] at gg,
      exact (eq.symm (and.elim_left gg)),
      rewrite eq,
      exact (and.elim_right gg),
    }
  }
end

lemma emb11 : ∀ A : dfa Sigma, ∀ w : word Sigma,
    dfa_lang A w → nfa_lang (dfa2nfa A) w :=
begin
  assume A w,
  dsimp [dfa_lang, nfa_lang],
  induction w,
  {
    dsimp [dfa_δ_star],
    assume h,
    existsi A.init,
    existsi A.init,
    constructor,
    dsimp [dfa2nfa],
    reflexivity,
    constructor,
    dsimp [nfa_δ_star],
    reflexivity,
    dsimp [dfa2nfa],
    exact h,
  },
  {
    assume h,
    existsi A.init,
    existsi (dfa_δ_star A A.init (w_hd :: w_tl)),
    constructor,
    dsimp [dfa2nfa],
    reflexivity,
    constructor,
    dsimp [nfa_δ_star],
    existsi A.δ A.init w_hd,
    constructor,
    dsimp [dfa2nfa],
    reflexivity,
    dsimp [dfa_δ_star],
    apply iff.mp (nfaδ2dfaδ A w_tl (A.δ A.init w_hd) (dfa_δ_star A (A.δ A.init w_hd) w_tl)),
    reflexivity,
    dsimp [dfa2nfa],
    exact h,
  }
end

lemma emb12 : ∀ A : dfa Sigma, ∀ w : word Sigma,
    nfa_lang (dfa2nfa A) w → dfa_lang A w :=
begin
  assume A w,
  dsimp [nfa_lang, dfa_lang],
  assume h,
  induction w,
  {
    dsimp [dfa_δ_star] at *,
    cases h with q0 h2,
    cases h2 with q1 h3,
    dsimp [nfa_δ_star, dfa2nfa] at h3,
    rewrite← (and.elim_left h3),
    rewrite (and.elim_left (and.elim_right h3)),
    exact (and.elim_right (and.elim_right h3)),
  },
  {
    dsimp [dfa_δ_star] at *,
    cases h with q0 h2,
    cases h2 with q1 h3,
    have eq: q0 = A.init,
    dsimp [dfa2nfa] at h3,
    exact and.elim_left h3,
    have g: dfa_δ_star A (A.δ A.init w_hd) w_tl = q1,
    rewrite← eq,
    change dfa_δ_star A q0 (w_hd :: w_tl) = q1,
    apply (iff.mpr (nfaδ2dfaδ A (w_hd :: w_tl) q0 q1)),
    exact and.elim_left (and.elim_right h3),
    rewrite g,
    exact and.elim_right (and.elim_right h3),
  }
end

lemma emb1 : ∀ A : dfa Sigma, ∀ w : word Sigma,
    dfa_lang A w ↔ nfa_lang (dfa2nfa A) w :=
begin
  assume A w,
  constructor,
  exact (emb11 A w),
  exact (emb12 A w),
end

end dfa2nfa

section nfa2dfa
variables {Sigma : Type}

@[reducible]
def decPow (A : Type*) := Σ (p : A → Prop), decidable_pred p

-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/fintype.20for.20functions/near/291226330
def equiv.sigma_decidable_pred {α : Type*} : (Σ (p : α → Prop), decidable_pred p) ≃ (α → bool) :=
  {
    to_fun := λ A i, @to_bool (A.1 i) (A.2 i),
    inv_fun := λ p, ⟨λ a, p a, by apply_instance⟩,
    left_inv := λ p, sigma.ext (by simp) $ subsingleton.helim (by simp) _ _,
    right_inv := λ p, funext $ λ i, bool.to_bool_coe _
  }

instance finpow {A : Type*} (fin : fintype A) (dec : decidable_eq A) : fintype (decPow A) :=
fintype.of_equiv (A → bool) $ equiv.symm equiv.sigma_decidable_pred

instance decpow {A : Type*} (fin : fintype A) (dec : decidable_eq A) : decidable_eq (decPow A) :=
equiv.decidable_eq equiv.sigma_decidable_pred

def nfa2dfa (A : nfa Sigma) : dfa Sigma :=
  {
    Q := decPow A.Q,
    finQ := finpow A.finQ A.decQ,
    decQ := decpow A.finQ A.decQ,
    init := sigma.mk (A.inits) A.decI,
    final := λ p, ∃ q, p.1 q ∧ A.final q,
    decF :=
      begin
        assume p,
        casesI p,
        letI decF: decidable_pred A.final := A.decF,
        letI finQ: fintype A.Q := A.finQ,
        simp at *,
        apply fintype.decidable_exists_fintype,
      end,
    δ := λ p x, ⟨(λ q1, ∃ q0 : A.Q, p.1 q0 ∧ A.δ q0 x q1),
                  λ q1, begin
                    casesI p,
                    letI finQ: fintype A.Q := A.finQ,
                    simp at *,
                    letI decD: decidable_pred (λ q0, p_fst q0 ∧ A.δ q0 x q1),
                    {
                      assume q0,
                      simp at *,
                      casesI p_snd q0,
                      have f: ¬ (p_fst q0 ∧ A.δ q0 x q1),
                      {
                        assume h2,
                        apply h,
                        exact (and.elim_left h2),
                      },
                      exact is_false f,
                      casesI A.decD ⟨⟨q0, x⟩, q1⟩ with no yes,
                      have f: ¬ (p_fst q0 ∧ A.δ q0 x q1),
                      {
                        assume h2,
                        apply no,
                        dsimp [sigma.uncurry],
                        exact (and.elim_right h2),
                      },
                      exact is_false f,
                      dsimp [sigma.uncurry] at yes,
                      exact is_true (and.intro h yes),
                    },
                    apply fintype.decidable_exists_fintype,
                  end⟩,
  }

lemma dfaδ2nfaδ : ∀ A : nfa Sigma, ∀ w : word Sigma,
  ∀ q1 : A.Q, ∀ p : (nfa2dfa A).Q,
  (∃ q0 : A.Q, p.1 q0 ∧ nfa_δ_star A q0 w q1) ↔ (dfa_δ_star (nfa2dfa A) p w).1 q1
  :=
begin
  assume A w,
  induction w,
  {
    assume q1 p,
    dsimp [nfa_δ_star, dfa_δ_star],
    constructor,
    {
      assume h,
      cases h with q0 h2,
      rewrite← (and.elim_right h2),
      exact (and.elim_left h2),
    },
    {
      assume h,
      existsi q1,
      exact (and.intro h rfl),
    },
  },
  {
    assume q1 p,
    dsimp [nfa_δ_star, dfa_δ_star],
    constructor,
    {
      assume h,
      cases h with q0 h2,
      cases (and.elim_right h2) with q2 h3,
      have g: ((nfa2dfa A).δ p w_hd).1 q2,
      {
        dsimp [nfa2dfa],
        existsi q0,
        exact (and.intro (and.elim_left h2) (and.elim_left h3)),
      },
      apply (iff.mp (w_ih q1 ((nfa2dfa A).δ p w_hd))),
      existsi q2,
      exact (and.intro g (and.elim_right h3)),
    },
    {
      assume h,
      cases iff.mpr (w_ih q1 ((nfa2dfa A).δ p w_hd)) h with q2 h2,
      dsimp [nfa2dfa] at h2,
      cases (and.elim_left h2) with q0 h3,
      existsi q0,
      constructor,
      exact (and.elim_left h3),
      existsi q2,
      exact (and.intro (and.elim_right h3) (and.elim_right h2)),
    },
  }
end

lemma emb21 : ∀ A : nfa Sigma, ∀ w : word Sigma,
  nfa_lang A w → dfa_lang (nfa2dfa A) w :=
begin
  assume A w,
  dsimp [nfa_lang, dfa_lang],
  induction w,
  {
    dsimp [nfa_δ_star, dfa_δ_star],
    assume h,
    dsimp [nfa2dfa],
    cases h with q0 h2,
    cases h2 with q1 h3,
    existsi q0,
    constructor,
    exact (and.elim_left h3),
    rewrite (and.elim_left (and.elim_right h3)),
    exact (and.elim_right (and.elim_right h3)),
  },
  {
    dsimp [nfa_δ_star, dfa_δ_star],
    assume h,
    cases h with q0 h2,
    cases h2 with q1 h3,
    have g: (dfa_δ_star (nfa2dfa A) ((nfa2dfa A).δ (nfa2dfa A).init w_hd) w_tl).1 q1,
    {
      apply iff.mp (dfaδ2nfaδ A w_tl q1 ((nfa2dfa A).δ (nfa2dfa A).init w_hd)),
      cases (and.elim_left (and.elim_right h3)) with q2 h4,
      existsi q2,
      dsimp [nfa2dfa],
      constructor,
      existsi q0,
      exact (and.intro (and.elim_left h3) (and.elim_left h4)),
      exact (and.elim_right h4),
    },
    existsi q1,
    exact (and.intro g (and.elim_right (and.elim_right h3))),
  }
end

lemma emb22 : ∀ A : nfa Sigma, ∀ w : word Sigma,
  dfa_lang (nfa2dfa A) w → nfa_lang A w :=
begin
  assume A w,
  dsimp [nfa_lang, dfa_lang],
  induction w,
  {
    dsimp [nfa_δ_star, dfa_δ_star, nfa2dfa],
    assume h,
    cases h with q0 h2,
    existsi q0,
    existsi q0,
    simp,
    exact h2,
  },
  {
    assume h,
    cases h with q1 h2,
    have g: ∃ q0 : A.Q, (nfa2dfa A).init.1 q0 ∧ nfa_δ_star A q0 (w_hd :: w_tl) q1,
    {
      apply iff.mpr (dfaδ2nfaδ A (w_hd :: w_tl) q1 (nfa2dfa A).init),
      exact (and.elim_left h2),
    },
    cases g with q0 gg,
    existsi q0,
    existsi q1,
    constructor,
    exact (and.elim_left gg),
    exact (and.intro (and.elim_right gg) (and.elim_right h2)),
  }
end

lemma emb2 : ∀ A : nfa Sigma, ∀ w : word Sigma,
  nfa_lang A w ↔ dfa_lang (nfa2dfa A) w :=
begin
  assume A w,
  constructor,
  exact emb21 A w,
  exact emb22 A w,
end

end nfa2dfa

section nfa2ε_nfa

variables {Sigma : Type} [decidable_eq Sigma]

def nfa2ε_nfa(A : nfa Sigma) : ε_nfa Sigma :=
  {
    Q := A.Q,
    finQ := A.finQ,
    decQ := A.decQ,
    inits := A.inits,
    decI := A.decI,
    final := A.final,
    decF := A.decF,
    δ := λ q0 x q1, x.cases_on' false (λ x, A.δ q0 x q1),
    decD := λ q, begin
      dsimp[sigma.uncurry],
      cases q with q0x q1,
      cases q0x with q0 x,
      cases x with x empty,
      {
        dsimp[option.cases_on'],
        letI g:= A.decQ,
        apply_instance,
      },
      {
        dsimp[option.cases_on'],
        exact (A.decD ⟨⟨q0, x⟩, q1⟩),
      }
    end,
  }

lemma nfaδ2ε_nfaδ : ∀ A : nfa Sigma, ∀ w : word Sigma,
  ∀ q0 q1 : A.Q,
  (nfa_δ_star A q0 w q1) ↔ ε_nfa_δ_star (nfa2ε_nfa A) q0 w q1
  :=
begin
  assume A w,
  induction w,
  {
    assume q0 q1,
    dsimp [nfa_δ_star],
    constructor,
    assume eq,
    rewrite eq,
    fconstructor,
    assume h,
    cases h,
    {
      refl,
    },
    {
      dsimp [nfa2ε_nfa] at *,
      cases h_ᾰ,
    },
  },
  {
    assume q0 q1,
    dsimp [nfa_δ_star],
    constructor,
    {
      assume h,
      cases h with q2 h2,
      dsimp [nfa2ε_nfa],
      cases h2,
      fconstructor,
      exact q2,
      exact h2_left,
      apply iff.mp (w_ih q2 q1),
      exact h2_right,
    },
    {
      assume h,
      cases h,
      {
        existsi h_q1,
        constructor,
        exact h_ᾰ,
        apply iff.mpr (w_ih h_q1 q1),
        exact h_ᾰ_1,
      },
      {
        dsimp [nfa2ε_nfa] at h_ᾰ,
        cases h_ᾰ,
      },
    },
  }
end

lemma emb3 : ∀ A : nfa Sigma, ∀ w : word Sigma,
  nfa_lang A w ↔ ε_nfa_lang (nfa2ε_nfa A) w :=
begin
  assume A w,
  dsimp [nfa_lang, ε_nfa_lang],
  constructor,
  {
    assume h,
    cases h with q0 h2,
    cases h2 with q1 h3,
    existsi q0,
    existsi q1,
    constructor,
    exact (and.elim_left h3),
    constructor,
    {
      cases h3,
      apply iff.mp (nfaδ2ε_nfaδ A w q0 q1),
      exact and.elim_left h3_right,
    },
    exact (and.elim_right (and.elim_right h3)),
  },
  {
    assume h,
    cases h with q0 h2,
    cases h2 with q1 h3,
    cases h3 with h4 h5,
    cases h5 with h6 h7,
    existsi q0,
    existsi q1,
    constructor,
    exact h4,
    constructor,
    apply iff.mpr (nfaδ2ε_nfaδ A w q0 q1),
    exact h6,
    exact h7,
  }
end

end nfa2ε_nfa


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

universe u v

/- Classical reasoning support -/

namespace Classical

noncomputable def indefiniteDescription {α : Sort u} (p : α → Prop) (h : ∃ x, p x) : {x // p x} :=
  choice <| let ⟨x, px⟩ := h; ⟨⟨x, px⟩⟩

noncomputable def choose {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : α :=
  (indefiniteDescription p h).val

theorem choose_spec {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : p (choose h) :=
  (indefiniteDescription p h).property

/- Diaconescu's theorem: excluded middle from choice, Function extensionality and propositional extensionality. -/
theorem em (p : Prop) : p ∨ ¬p :=
  let U (x : Prop) : Prop := x = True ∨ p
  let V (x : Prop) : Prop := x = False ∨ p
  have exU : ∃ x, U x := ⟨True, Or.inl rfl⟩
  have exV : ∃ x, V x := ⟨False, Or.inl rfl⟩
  let u : Prop := choose exU
  let v : Prop := choose exV
  have u_def : U u := choose_spec exU
  have v_def : V v := choose_spec exV
  have not_uv_or_p : u ≠ v ∨ p :=
    match u_def, v_def with
    | Or.inr h, _ => Or.inr h
    | _, Or.inr h => Or.inr h
    | Or.inl hut, Or.inl hvf =>
      have hne : u ≠ v := by simp [hvf, hut, true_ne_false]
      Or.inl hne
  have p_implies_uv : p → u = v :=
    fun hp =>
    have hpred : U = V :=
      funext fun x =>
        have hl : (x = True ∨ p) → (x = False ∨ p) :=
          fun _ => Or.inr hp
        have hr : (x = False ∨ p) → (x = True ∨ p) :=
          fun _ => Or.inr hp
        show (x = True ∨ p) = (x = False ∨ p) from
          propext (Iff.intro hl hr)
    have h₀ : ∀ exU exV, @choose _ U exU = @choose _ V exV := by
      rw [hpred]; intros; rfl
    show u = v from h₀ _ _
  match not_uv_or_p with
  | Or.inl hne => Or.inr (mt p_implies_uv hne)
  | Or.inr h   => Or.inl h

theorem exists_true_of_nonempty {α : Sort u} : Nonempty α → ∃ x : α, True
  | ⟨x⟩ => ⟨x, trivial⟩

noncomputable def inhabited_of_nonempty {α : Sort u} (h : Nonempty α) : Inhabited α :=
  ⟨choice h⟩

noncomputable def inhabited_of_exists {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : Inhabited α :=
  inhabited_of_nonempty (Exists.elim h (fun w hw => ⟨w⟩))

/- all propositions are Decidable -/
noncomputable scoped instance (priority := low) propDecidable (a : Prop) : Decidable a :=
  choice <| match em a with
    | Or.inl h => ⟨isTrue h⟩
    | Or.inr h => ⟨isFalse h⟩

noncomputable def decidableInhabited (a : Prop) : Inhabited (Decidable a) where
  default := inferInstance

noncomputable def typeDecidableEq (α : Sort u) : DecidableEq α :=
  fun x y => inferInstance

noncomputable def typeDecidable (α : Sort u) : PSum α (α → False) :=
  match (propDecidable (Nonempty α)) with
  | (isTrue hp)  => PSum.inl (@default _ (inhabited_of_nonempty hp))
  | (isFalse hn) => PSum.inr (fun a => absurd (Nonempty.intro a) hn)

noncomputable def strongIndefiniteDescription {α : Sort u} (p : α → Prop) (h : Nonempty α) : {x : α // (∃ y : α, p y) → p x} :=
  @dite _ (∃ x : α, p x) (propDecidable _)
    (fun (hp : ∃ x : α, p x) =>
      show {x : α // (∃ y : α, p y) → p x} from
      let xp := indefiniteDescription _ hp;
      ⟨xp.val, fun h' => xp.property⟩)
    (fun hp => ⟨choice h, fun h => absurd h hp⟩)

/- the Hilbert epsilon Function -/

noncomputable def epsilon {α : Sort u} [h : Nonempty α] (p : α → Prop) : α :=
  (strongIndefiniteDescription p h).val

theorem epsilon_spec_aux {α : Sort u} (h : Nonempty α) (p : α → Prop) : (∃ y, p y) → p (@epsilon α h p) :=
  (strongIndefiniteDescription p h).property

theorem epsilon_spec {α : Sort u} {p : α → Prop} (hex : ∃ y, p y) : p (@epsilon α (nonempty_of_exists hex) p) :=
  epsilon_spec_aux (nonempty_of_exists hex) p hex

theorem epsilon_singleton {α : Sort u} (x : α) : @epsilon α ⟨x⟩ (fun y => y = x) = x :=
  @epsilon_spec α (fun y => y = x) ⟨x, rfl⟩

/- the axiom of choice -/

theorem axiomOfChoice {α : Sort u} {β : α → Sort v} {r : ∀ x, β x → Prop} (h : ∀ x, ∃ y, r x y) : ∃ (f : ∀ x, β x), ∀ x, r x (f x) :=
  ⟨_, fun x => choose_spec (h x)⟩

theorem skolem {α : Sort u} {b : α → Sort v} {p : ∀ x, b x → Prop} : (∀ x, ∃ y, p x y) ↔ ∃ (f : ∀ x, b x), ∀ x, p x (f x) :=
  ⟨axiomOfChoice, fun ⟨f, hw⟩ (x) => ⟨f x, hw x⟩⟩

theorem propComplete (a : Prop) : a = True ∨ a = False :=
  match em a with
  | Or.inl ha => Or.inl (propext (Iff.intro (fun _ => ⟨⟩) (fun _ => ha)))
  | Or.inr hn => Or.inr (propext (Iff.intro (fun h => hn h) (fun h => False.elim h)))

-- this supercedes byCases in Decidable
theorem byCases {p q : Prop} (hpq : p → q) (hnpq : ¬p → q) : q :=
  Decidable.byCases (dec := propDecidable _) hpq hnpq

-- this supercedes byContradiction in Decidable
theorem byContradiction {p : Prop} (h : ¬p → False) : p :=
  Decidable.byContradiction (dec := propDecidable _) h

macro "byCases" h:ident ":" e:term : tactic =>
  `(cases em $e:term with
    | inl $h:ident => _
    | inr $h:ident => _)

end Classical