/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.group.opposite
import group_theory.group_action.defs

/-!
# Scalar actions on and by `Mᵐᵒᵖ`

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

This file defines the actions on the opposite type `has_smul R Mᵐᵒᵖ`, and actions by the opposite
type, `has_smul Rᵐᵒᵖ M`.

Note that `mul_opposite.has_smul` is provided in an earlier file as it is needed to provide the
`add_monoid.nsmul` and `add_comm_group.gsmul` fields.
-/

variables (α : Type*)

/-! ### Actions _on_ the opposite type

Actions on the opposite type just act on the underlying type.
-/

namespace mul_opposite

@[to_additive] instance (R : Type*) [monoid R] [mul_action R α] : mul_action R αᵐᵒᵖ :=
{ one_smul := λ x, unop_injective $ one_smul R (unop x),
  mul_smul := λ r₁ r₂ x, unop_injective $ mul_smul r₁ r₂ (unop x),
  .. mul_opposite.has_smul α R }

instance (R : Type*) [monoid R] [add_monoid α] [distrib_mul_action R α] :
  distrib_mul_action R αᵐᵒᵖ :=
{ smul_add := λ r x₁ x₂, unop_injective $ smul_add r (unop x₁) (unop x₂),
  smul_zero := λ r, unop_injective $ smul_zero r,
  .. mul_opposite.mul_action α R }

instance (R : Type*) [monoid R] [monoid α] [mul_distrib_mul_action R α] :
  mul_distrib_mul_action R αᵐᵒᵖ :=
{ smul_mul := λ r x₁ x₂, unop_injective $ smul_mul' r (unop x₂) (unop x₁),
  smul_one := λ r, unop_injective $ smul_one r,
  .. mul_opposite.mul_action α R }

@[to_additive]
instance {M N} [has_smul M N] [has_smul M α] [has_smul N α] [is_scalar_tower M N α] :
  is_scalar_tower M N αᵐᵒᵖ :=
⟨λ x y z, unop_injective $ smul_assoc _ _ _⟩

@[to_additive] instance {M N} [has_smul M α] [has_smul N α] [smul_comm_class M N α] :
  smul_comm_class M N αᵐᵒᵖ :=
⟨λ x y z, unop_injective $ smul_comm _ _ _⟩

@[to_additive] instance (R : Type*) [has_smul R α] [has_smul Rᵐᵒᵖ α] [is_central_scalar R α] :
  is_central_scalar R αᵐᵒᵖ :=
⟨λ r m, unop_injective $ op_smul_eq_smul _ _⟩

lemma op_smul_eq_op_smul_op {R : Type*} [has_smul R α] [has_smul Rᵐᵒᵖ α] [is_central_scalar R α]
  (r : R) (a : α) : op (r • a) = op r • op a :=
(op_smul_eq_smul r (op a)).symm

lemma unop_smul_eq_unop_smul_unop {R : Type*} [has_smul R α] [has_smul Rᵐᵒᵖ α]
  [is_central_scalar R α] (r : Rᵐᵒᵖ) (a : αᵐᵒᵖ) : unop (r • a) = unop r • unop a :=
(unop_smul_eq_smul r (unop a)).symm

end mul_opposite

/-! ### Actions _by_ the opposite type (right actions)

In `has_mul.to_has_smul` in another file, we define the left action `a₁ • a₂ = a₁ * a₂`. For the
multiplicative opposite, we define `mul_opposite.op a₁ • a₂ = a₂ * a₁`, with the multiplication
reversed.
-/

open mul_opposite

/-- Like `has_mul.to_has_smul`, but multiplies on the right.

See also `monoid.to_opposite_mul_action` and `monoid_with_zero.to_opposite_mul_action_with_zero`. -/
@[to_additive "Like `has_add.to_has_vadd`, but adds on the right.

See also `add_monoid.to_opposite_add_action`."]
instance has_mul.to_has_opposite_smul [has_mul α] : has_smul αᵐᵒᵖ α := ⟨λ c x, x * c.unop⟩

@[to_additive] lemma op_smul_eq_mul [has_mul α] {a a' : α} : op a • a' = a' * a := rfl

@[simp, to_additive] lemma mul_opposite.smul_eq_mul_unop [has_mul α] {a : αᵐᵒᵖ} {a' : α} :
  a • a' = a' * a.unop := rfl

/-- The right regular action of a group on itself is transitive. -/
@[to_additive "The right regular action of an additive group on itself is transitive."]
instance mul_action.opposite_regular.is_pretransitive {G : Type*} [group G] :
  mul_action.is_pretransitive Gᵐᵒᵖ G :=
⟨λ x y, ⟨op (x⁻¹ * y), mul_inv_cancel_left _ _⟩⟩

@[to_additive] instance semigroup.opposite_smul_comm_class [semigroup α] :
  smul_comm_class αᵐᵒᵖ α α :=
{ smul_comm := λ x y z, (mul_assoc _ _ _) }

@[to_additive] instance semigroup.opposite_smul_comm_class' [semigroup α] :
  smul_comm_class α αᵐᵒᵖ α :=
smul_comm_class.symm _ _ _

@[to_additive]
instance comm_semigroup.is_central_scalar [comm_semigroup α] : is_central_scalar α α :=
⟨λ r m, mul_comm _ _⟩

/-- Like `monoid.to_mul_action`, but multiplies on the right. -/
@[to_additive "Like `add_monoid.to_add_action`, but adds on the right."]
instance monoid.to_opposite_mul_action [monoid α] : mul_action αᵐᵒᵖ α :=
{ smul := (•),
  one_smul := mul_one,
  mul_smul := λ x y r, (mul_assoc _ _ _).symm }

@[to_additive]
instance is_scalar_tower.opposite_mid {M N} [has_mul N] [has_smul M N] [smul_comm_class M N N] :
  is_scalar_tower M Nᵐᵒᵖ N :=
⟨λ x y z, mul_smul_comm _ _ _⟩

@[to_additive]
instance smul_comm_class.opposite_mid {M N} [has_mul N] [has_smul M N] [is_scalar_tower M N N] :
  smul_comm_class M Nᵐᵒᵖ N :=
⟨λ x y z, by { induction y using mul_opposite.rec, simp [smul_mul_assoc] }⟩

-- The above instance does not create an unwanted diamond, the two paths to
-- `mul_action αᵐᵒᵖ αᵐᵒᵖ` are defeq.
example [monoid α] : monoid.to_mul_action αᵐᵒᵖ = mul_opposite.mul_action α αᵐᵒᵖ := rfl

/-- `monoid.to_opposite_mul_action` is faithful on cancellative monoids. -/
@[to_additive "`add_monoid.to_opposite_add_action` is faithful on cancellative monoids."]
instance left_cancel_monoid.to_has_faithful_opposite_scalar [left_cancel_monoid α] :
  has_faithful_smul αᵐᵒᵖ α :=
⟨λ x y h, unop_injective $ mul_left_cancel (h 1)⟩

/-- `monoid.to_opposite_mul_action` is faithful on nontrivial cancellative monoids with zero. -/
instance cancel_monoid_with_zero.to_has_faithful_opposite_scalar
  [cancel_monoid_with_zero α] [nontrivial α] : has_faithful_smul αᵐᵒᵖ α :=
⟨λ x y h, unop_injective $ mul_left_cancel₀ one_ne_zero (h 1)⟩


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

! This file was ported from Lean 3 source module analysis.normed.order.lattice
! leanprover-community/mathlib commit 17ef379e997badd73e5eabb4d38f11919ab3c4b3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Order.Lattice
import Mathlib.Analysis.Normed.Group.Basic
import Mathlib.Algebra.Order.LatticeGroup

/-!
# Normed lattice ordered groups

Motivated by the theory of Banach Lattices, we then define `NormedLatticeAddCommGroup` as a
lattice with a covariant normed group addition satisfying the solid axiom.

## Main statements

We show that a normed lattice ordered group is a topological lattice with respect to the norm
topology.

## References

* [Meyer-Nieberg, Banach lattices][MeyerNieberg1991]

## Tags

normed, lattice, ordered, group
-/

/-!
### Normed lattice orderd groups

Motivated by the theory of Banach Lattices, this section introduces normed lattice ordered groups.
-/

-- porting note: this now exists as a global notation
-- local notation "|" a "|" => abs a

/--
Let `α` be a normed commutative group equipped with a partial order covariant with addition, with
respect which `α` forms a lattice. Suppose that `α` is *solid*, that is to say, for `a` and `b` in
`α`, with absolute values `|a|` and `|b|` respectively, `|a| ≤ |b|` implies `‖a‖ ≤ ‖b‖`. Then `α` is
said to be a normed lattice ordered group.
-/
class NormedLatticeAddCommGroup (α : Type _) extends NormedAddCommGroup α, Lattice α where
  add_le_add_left : ∀ a b : α, a ≤ b → ∀ c : α, c + a ≤ c + b
  solid : ∀ a b : α, |a| ≤ |b| → ‖a‖ ≤ ‖b‖
#align normed_lattice_add_comm_group NormedLatticeAddCommGroup

theorem solid {α : Type _} [NormedLatticeAddCommGroup α] {a b : α} (h : |a| ≤ |b|) : ‖a‖ ≤ ‖b‖ :=
  NormedLatticeAddCommGroup.solid a b h
#align solid solid

instance Real.normedLatticeAddCommGroup : NormedLatticeAddCommGroup ℝ where
  add_le_add_left _ _ h _ := add_le_add le_rfl h
  solid _ _ := id

-- see Note [lower instance priority]
/-- A normed lattice ordered group is an ordered additive commutative group
-/
instance (priority := 100) NormedLatticeAddCommGroup.toOrderedAddCommGroup {α : Type _}
    [h : NormedLatticeAddCommGroup α] : OrderedAddCommGroup α :=
  { h with }
#align normed_lattice_add_comm_group_to_ordered_add_comm_group NormedLatticeAddCommGroup.toOrderedAddCommGroup

variable {α : Type _} [NormedLatticeAddCommGroup α]

open LatticeOrderedCommGroup

theorem dual_solid (a b : α) (h : b ⊓ -b ≤ a ⊓ -a) : ‖a‖ ≤ ‖b‖ := by
  apply solid
  rw [abs_eq_sup_neg]
  nth_rw 1 [← neg_neg a]
  rw [← neg_inf_eq_sup_neg]
  rw [abs_eq_sup_neg]
  nth_rw 1 [← neg_neg b]
  rwa [← neg_inf_eq_sup_neg, neg_le_neg_iff, @inf_comm _ _ _ b, @inf_comm _ _ _ a]
#align dual_solid dual_solid

-- see Note [lower instance priority]
/-- Let `α` be a normed lattice ordered group, then the order dual is also a
normed lattice ordered group.
-/
instance (priority := 100) OrderDual.normedLatticeAddCommGroup : NormedLatticeAddCommGroup αᵒᵈ :=
  { OrderDual.orderedAddCommGroup, OrderDual.normedAddCommGroup, OrderDual.lattice α with
    solid := dual_solid (α := α) }

theorem norm_abs_eq_norm (a : α) : ‖|a|‖ = ‖a‖ :=
  (solid (abs_abs a).le).antisymm (solid (abs_abs a).symm.le)
#align norm_abs_eq_norm norm_abs_eq_norm

theorem norm_inf_sub_inf_le_add_norm (a b c d : α) : ‖a ⊓ b - c ⊓ d‖ ≤ ‖a - c‖ + ‖b - d‖ := by
  rw [← norm_abs_eq_norm (a - c), ← norm_abs_eq_norm (b - d)]
  refine' le_trans (solid _) (norm_add_le (|a - c|) (|b - d|))
  rw [abs_of_nonneg (|a - c| + |b - d|) (add_nonneg (abs_nonneg (a - c)) (abs_nonneg (b - d)))]
  calc
    |a ⊓ b - c ⊓ d| = |a ⊓ b - c ⊓ b + (c ⊓ b - c ⊓ d)| := by rw [sub_add_sub_cancel]
    _ ≤ |a ⊓ b - c ⊓ b| + |c ⊓ b - c ⊓ d| := (abs_add_le _ _)
    _ ≤ |a - c| + |b - d| := by
      apply add_le_add
      · exact abs_inf_sub_inf_le_abs _ _ _
      · rw [@inf_comm _ _ c, @inf_comm _ _ c]
        exact abs_inf_sub_inf_le_abs _ _ _

#align norm_inf_sub_inf_le_add_norm norm_inf_sub_inf_le_add_norm

theorem norm_sup_sub_sup_le_add_norm (a b c d : α) : ‖a ⊔ b - c ⊔ d‖ ≤ ‖a - c‖ + ‖b - d‖ := by
  rw [← norm_abs_eq_norm (a - c), ← norm_abs_eq_norm (b - d)]
  refine' le_trans (solid _) (norm_add_le (|a - c|) (|b - d|))
  rw [abs_of_nonneg (|a - c| + |b - d|) (add_nonneg (abs_nonneg (a - c)) (abs_nonneg (b - d)))]
  calc
    |a ⊔ b - c ⊔ d| = |a ⊔ b - c ⊔ b + (c ⊔ b - c ⊔ d)| := by rw [sub_add_sub_cancel]
    _ ≤ |a ⊔ b - c ⊔ b| + |c ⊔ b - c ⊔ d| := (abs_add_le _ _)
    _ ≤ |a - c| + |b - d| := by
      apply add_le_add
      · exact abs_sup_sub_sup_le_abs _ _ _
      · rw [@sup_comm _ _ c, @sup_comm _ _ c]
        exact abs_sup_sub_sup_le_abs _ _ _

#align norm_sup_sub_sup_le_add_norm norm_sup_sub_sup_le_add_norm

theorem norm_inf_le_add (x y : α) : ‖x ⊓ y‖ ≤ ‖x‖ + ‖y‖ := by
  have h : ‖x ⊓ y - 0 ⊓ 0‖ ≤ ‖x - 0‖ + ‖y - 0‖ := norm_inf_sub_inf_le_add_norm x y 0 0
  simpa only [inf_idem, sub_zero] using h
#align norm_inf_le_add norm_inf_le_add

theorem norm_sup_le_add (x y : α) : ‖x ⊔ y‖ ≤ ‖x‖ + ‖y‖ := by
  have h : ‖x ⊔ y - 0 ⊔ 0‖ ≤ ‖x - 0‖ + ‖y - 0‖ := norm_sup_sub_sup_le_add_norm x y 0 0
  simpa only [sup_idem, sub_zero] using h
#align norm_sup_le_add norm_sup_le_add

-- see Note [lower instance priority]
/-- Let `α` be a normed lattice ordered group. Then the infimum is jointly continuous.
-/
instance (priority := 100) NormedLatticeAddCommGroup.continuousInf : ContinuousInf α := by
  refine' ⟨continuous_iff_continuousAt.2 fun q => tendsto_iff_norm_tendsto_zero.2 <| _⟩
  have : ∀ p : α × α, ‖p.1 ⊓ p.2 - q.1 ⊓ q.2‖ ≤ ‖p.1 - q.1‖ + ‖p.2 - q.2‖ := fun _ =>
    norm_inf_sub_inf_le_add_norm _ _ _ _
  refine' squeeze_zero (fun e => norm_nonneg _) this _
  -- porting note: I wish `convert` were better at unification.
  convert ((continuous_fst.tendsto q).sub <| tendsto_const_nhds (a := q.fst)).norm.add
    ((continuous_snd.tendsto q).sub <| tendsto_const_nhds (a := q.snd)).norm
  simp
#align normed_lattice_add_comm_group_has_continuous_inf NormedLatticeAddCommGroup.continuousInf

-- see Note [lower instance priority]
instance (priority := 100) NormedLatticeAddCommGroup.continuousSup {α : Type _}
    [NormedLatticeAddCommGroup α] : ContinuousSup α :=
  OrderDual.continuousSup αᵒᵈ
#align normed_lattice_add_comm_group_has_continuous_sup NormedLatticeAddCommGroup.continuousSup

-- see Note [lower instance priority]
/--
Let `α` be a normed lattice ordered group. Then `α` is a topological lattice in the norm topology.
-/
instance (priority := 100) NormedLatticeAddCommGroup.toTopologicalLattice : TopologicalLattice α :=
  TopologicalLattice.mk
#align normed_lattice_add_comm_group_topological_lattice NormedLatticeAddCommGroup.toTopologicalLattice

theorem norm_abs_sub_abs (a b : α) : ‖|a| - |b|‖ ≤ ‖a - b‖ :=
  solid (LatticeOrderedCommGroup.abs_abs_sub_abs_le _ _)
#align norm_abs_sub_abs norm_abs_sub_abs

theorem norm_sup_sub_sup_le_norm (x y z : α) : ‖x ⊔ z - y ⊔ z‖ ≤ ‖x - y‖ :=
  solid (abs_sup_sub_sup_le_abs x y z)
#align norm_sup_sub_sup_le_norm norm_sup_sub_sup_le_norm

theorem norm_inf_sub_inf_le_norm (x y z : α) : ‖x ⊓ z - y ⊓ z‖ ≤ ‖x - y‖ :=
  solid (abs_inf_sub_inf_le_abs x y z)
#align norm_inf_sub_inf_le_norm norm_inf_sub_inf_le_norm

theorem lipschitzWith_sup_right (z : α) : LipschitzWith 1 fun x => x ⊔ z :=
  LipschitzWith.of_dist_le_mul fun x y => by
    rw [NNReal.coe_one, one_mul, dist_eq_norm, dist_eq_norm]
    exact norm_sup_sub_sup_le_norm x y z
#align lipschitz_with_sup_right lipschitzWith_sup_right

theorem lipschitzWith_pos : LipschitzWith 1 (PosPart.pos : α → α) :=
  lipschitzWith_sup_right 0
#align lipschitz_with_pos lipschitzWith_pos

theorem continuous_pos : Continuous (PosPart.pos : α → α) :=
  LipschitzWith.continuous lipschitzWith_pos
#align continuous_pos continuous_pos

theorem continuous_neg' : Continuous (NegPart.neg : α → α) := by
  refine continuous_pos.comp <| @continuous_neg _ _ _ TopologicalAddGroup.toContinuousNeg
  -- porting note: see the [Zulip thread](https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/can't.20infer.20.60ContinuousNeg.60)
#align continuous_neg' continuous_neg'

theorem isClosed_nonneg {E} [NormedLatticeAddCommGroup E] : IsClosed { x : E | 0 ≤ x } := by
  suffices { x : E | 0 ≤ x } = NegPart.neg ⁻¹' {(0 : E)}
    by
    rw [this]
    exact IsClosed.preimage continuous_neg' isClosed_singleton
  ext1 x
  simp only [Set.mem_preimage, Set.mem_singleton_iff, Set.mem_setOf_eq,
    @neg_eq_zero_iff E _ _ (OrderedAddCommGroup.to_covariantClass_left_le E)  ]
  -- porting note: I'm not sure why Lean couldn't synthesize this instance because it works with
  -- `have : CovariantClass E E (· + ·) (· ≤ ·) := inferInstance`
#align is_closed_nonneg isClosed_nonneg

theorem isClosed_le_of_isClosed_nonneg {G} [OrderedAddCommGroup G] [TopologicalSpace G]
    [ContinuousSub G] (h : IsClosed { x : G | 0 ≤ x }) :
    IsClosed { p : G × G | p.fst ≤ p.snd } := by
  have : { p : G × G | p.fst ≤ p.snd } = (fun p : G × G => p.snd - p.fst) ⁻¹' { x : G | 0 ≤ x } :=
    by ext1 p; simp only [sub_nonneg, Set.preimage_setOf_eq]
  rw [this]
  exact IsClosed.preimage (continuous_snd.sub continuous_fst) h
#align is_closed_le_of_is_closed_nonneg isClosed_le_of_isClosed_nonneg

-- See note [lower instance priority]
instance (priority := 100) NormedLatticeAddCommGroup.orderClosedTopology {E}
    [NormedLatticeAddCommGroup E] : OrderClosedTopology E :=
  ⟨isClosed_le_of_isClosed_nonneg isClosed_nonneg⟩
#align normed_lattice_add_comm_group.order_closed_topology NormedLatticeAddCommGroup.orderClosedTopology


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

! This file was ported from Lean 3 source module algebra.category.Group.limits
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Mon.Limits
import Mathbin.Algebra.Category.Group.Preadditive
import Mathbin.CategoryTheory.Over
import Mathbin.GroupTheory.Subgroup.Basic
import Mathbin.CategoryTheory.ConcreteCategory.Elementwise

/-!
# The category of (commutative) (additive) groups has all limits

Further, these limits are preserved by the forgetful functor --- that is,
the underlying types are just the limits in the category of types.

-/

open CategoryTheory

open CategoryTheory.Limits

universe v u

noncomputable section

variable {J : Type v} [SmallCategory J]

namespace GroupCat

@[to_additive]
instance groupObj (F : J ⥤ GroupCat.{max v u}) (j) : Group ((F ⋙ forget GroupCat).obj j) :=
  by
  change Group (F.obj j)
  infer_instance
#align Group.group_obj GroupCat.groupObj
#align AddGroup.add_group_obj AddGroupCat.addGroupObj

/-- The flat sections of a functor into `Group` form a subgroup of all sections.
-/
@[to_additive
      "The flat sections of a functor into `AddGroup` form an additive subgroup of all sections."]
def sectionsSubgroup (F : J ⥤ GroupCat) : Subgroup (∀ j, F.obj j) :=
  {
    MonCat.sectionsSubmonoid
      (F ⋙ forget₂ GroupCat
          MonCat) with
    carrier := (F ⋙ forget GroupCat).sections
    inv_mem' := fun a ah j j' f =>
      by
      simp only [forget_map_eq_coe, functor.comp_map, Pi.inv_apply, MonoidHom.map_inv, inv_inj]
      dsimp [functor.sections] at ah
      rw [ah f] }
#align Group.sections_subgroup GroupCat.sectionsSubgroup
#align AddGroup.sections_add_subgroup AddGroupCat.sectionsAddSubgroup

@[to_additive]
instance limitGroup (F : J ⥤ GroupCat.{max v u}) :
    Group (Types.limitCone (F ⋙ forget GroupCat)).pt :=
  by
  change Group (sections_subgroup F)
  infer_instance
#align Group.limit_group GroupCat.limitGroup
#align AddGroup.limit_add_group AddGroupCat.limitAddGroup

/-- We show that the forgetful functor `Group ⥤ Mon` creates limits.

All we need to do is notice that the limit point has a `group` instance available, and then reuse
the existing limit. -/
@[to_additive
      "We show that the forgetful functor `AddGroup ⥤ AddMon` creates limits.\n\nAll we need to do is notice that the limit point has an `add_group` instance available, and then\nreuse the existing limit."]
instance Forget₂.createsLimit (F : J ⥤ GroupCat.{max v u}) :
    CreatesLimit F (forget₂ GroupCat.{max v u} MonCat.{max v u}) :=
  createsLimitOfReflectsIso fun c' t =>
    { liftedCone :=
        { pt := GroupCat.of (Types.limitCone (F ⋙ forget GroupCat)).pt
          π :=
            { app := MonCat.limitπMonoidHom (F ⋙ forget₂ GroupCat MonCat.{max v u})
              naturality' :=
                (MonCat.HasLimits.limitCone
                      (F ⋙ forget₂ GroupCat MonCat.{max v u})).π.naturality } }
      validLift := by apply is_limit.unique_up_to_iso (MonCat.HasLimits.limitConeIsLimit _) t
      makesLimit :=
        IsLimit.ofFaithful (forget₂ GroupCat MonCat.{max v u}) (MonCat.HasLimits.limitConeIsLimit _)
          (fun s => _) fun s => rfl }
#align Group.forget₂.creates_limit GroupCat.Forget₂.createsLimit
#align AddGroup.forget₂.creates_limit AddGroupCat.Forget₂.createsLimit

/-- A choice of limit cone for a functor into `Group`.
(Generally, you'll just want to use `limit F`.)
-/
@[to_additive
      "A choice of limit cone for a functor into `Group`.\n(Generally, you'll just want to use `limit F`.)"]
def limitCone (F : J ⥤ GroupCat.{max v u}) : Cone F :=
  liftLimit (limit.isLimit (F ⋙ forget₂ GroupCat MonCat.{max v u}))
#align Group.limit_cone GroupCat.limitCone
#align AddGroup.limit_cone AddGroupCat.limitCone

/-- The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
@[to_additive
      "The chosen cone is a limit cone.\n(Generally, you'll just want to use `limit.cone F`.)"]
def limitConeIsLimit (F : J ⥤ GroupCat.{max v u}) : IsLimit (limitCone F) :=
  liftedLimitIsLimit _
#align Group.limit_cone_is_limit GroupCat.limitConeIsLimit
#align AddGroup.limit_cone_is_limit AddGroupCat.limitConeIsLimit

/-- The category of groups has all limits. -/
@[to_additive "The category of additive groups has all limits."]
instance hasLimitsOfSize : HasLimitsOfSize.{v, v} GroupCat.{max v u}
    where HasLimitsOfShape J 𝒥 :=
    { HasLimit := fun F => has_limit_of_created F (forget₂ GroupCat MonCat.{max v u}) }
#align Group.has_limits_of_size GroupCat.hasLimitsOfSize
#align AddGroup.has_limits_of_size AddGroupCat.hasLimitsOfSize

@[to_additive]
instance hasLimits : HasLimits GroupCat.{u} :=
  GroupCat.hasLimitsOfSize.{u, u}
#align Group.has_limits GroupCat.hasLimits
#align AddGroup.has_limits AddGroupCat.hasLimits

/-- The forgetful functor from groups to monoids preserves all limits.

This means the underlying monoid of a limit can be computed as a limit in the category of monoids.
-/
@[to_additive AddGroupCat.forget₂AddMonPreservesLimits
      "The forgetful functor from additive groups\nto additive monoids preserves all limits.\n\nThis means the underlying additive monoid of a limit can be computed as a limit in the category of\nadditive monoids."]
instance forget₂MonPreservesLimitsOfSize :
    PreservesLimitsOfSize.{v, v} (forget₂ GroupCat MonCat.{max v u})
    where PreservesLimitsOfShape J 𝒥 := { PreservesLimit := fun F => by infer_instance }
#align Group.forget₂_Mon_preserves_limits_of_size GroupCat.forget₂MonPreservesLimitsOfSize
#align AddGroup.forget₂_AddMon_preserves_limits AddGroupCat.forget₂AddMonPreservesLimits

@[to_additive]
instance forget₂MonPreservesLimits : PreservesLimits (forget₂ GroupCat MonCat.{u}) :=
  GroupCat.forget₂MonPreservesLimitsOfSize.{u, u}
#align Group.forget₂_Mon_preserves_limits GroupCat.forget₂MonPreservesLimits
#align AddGroup.forget₂_Mon_preserves_limits AddGroupCat.forget₂MonPreservesLimits

/-- The forgetful functor from groups to types preserves all limits.

This means the underlying type of a limit can be computed as a limit in the category of types. -/
@[to_additive
      "The forgetful functor from additive groups to types preserves all limits.\n\nThis means the underlying type of a limit can be computed as a limit in the category of types."]
instance forgetPreservesLimitsOfSize : PreservesLimitsOfSize.{v, v} (forget GroupCat.{max v u})
    where PreservesLimitsOfShape J 𝒥 :=
    {
      PreservesLimit := fun F =>
        limits.comp_preserves_limit (forget₂ GroupCat MonCat) (forget MonCat) }
#align Group.forget_preserves_limits_of_size GroupCat.forgetPreservesLimitsOfSize
#align AddGroup.forget_preserves_limits_of_size AddGroupCat.forgetPreservesLimitsOfSize

@[to_additive]
instance forgetPreservesLimits : PreservesLimits (forget GroupCat.{u}) :=
  GroupCat.forgetPreservesLimitsOfSize.{u, u}
#align Group.forget_preserves_limits GroupCat.forgetPreservesLimits
#align AddGroup.forget_preserves_limits AddGroupCat.forgetPreservesLimits

end GroupCat

namespace CommGroupCat

@[to_additive]
instance commGroupObj (F : J ⥤ CommGroupCat.{max v u}) (j) :
    CommGroup ((F ⋙ forget CommGroupCat).obj j) :=
  by
  change CommGroup (F.obj j)
  infer_instance
#align CommGroup.comm_group_obj CommGroupCat.commGroupObj
#align AddCommGroup.add_comm_group_obj AddCommGroupCat.addCommGroupObj

@[to_additive]
instance limitCommGroup (F : J ⥤ CommGroupCat.{max v u}) :
    CommGroup (Types.limitCone (F ⋙ forget CommGroupCat.{max v u})).pt :=
  @Subgroup.toCommGroup (∀ j, F.obj j) _
    (GroupCat.sectionsSubgroup (F ⋙ forget₂ CommGroupCat GroupCat.{max v u}))
#align CommGroup.limit_comm_group CommGroupCat.limitCommGroup
#align AddCommGroup.limit_add_comm_group AddCommGroupCat.limitAddCommGroup

/-- We show that the forgetful functor `CommGroup ⥤ Group` creates limits.

All we need to do is notice that the limit point has a `comm_group` instance available,
and then reuse the existing limit.
-/
@[to_additive
      "We show that the forgetful functor `AddCommGroup ⥤ AddGroup` creates limits.\n\nAll we need to do is notice that the limit point has an `add_comm_group` instance available, and\nthen reuse the existing limit."]
instance Forget₂.createsLimit (F : J ⥤ CommGroupCat.{max v u}) :
    CreatesLimit F (forget₂ CommGroupCat GroupCat.{max v u}) :=
  createsLimitOfReflectsIso fun c' t =>
    { liftedCone :=
        { pt := CommGroupCat.of (Types.limitCone (F ⋙ forget CommGroupCat)).pt
          π :=
            { app :=
                MonCat.limitπMonoidHom
                  (F ⋙ forget₂ CommGroupCat GroupCat.{max v u} ⋙ forget₂ GroupCat MonCat.{max v u})
              naturality' := (MonCat.HasLimits.limitCone _).π.naturality } }
      validLift := by apply is_limit.unique_up_to_iso (GroupCat.limitConeIsLimit _) t
      makesLimit :=
        IsLimit.ofFaithful (forget₂ _ GroupCat.{max v u} ⋙ forget₂ _ MonCat.{max v u})
          (by apply MonCat.HasLimits.limitConeIsLimit _) (fun s => _) fun s => rfl }
#align CommGroup.forget₂.creates_limit CommGroupCat.Forget₂.createsLimit
#align AddCommGroup.forget₂.creates_limit AddCommGroupCat.Forget₂.createsLimit

/-- A choice of limit cone for a functor into `CommGroup`.
(Generally, you'll just want to use `limit F`.)
-/
@[to_additive
      "A choice of limit cone for a functor into `CommGroup`.\n(Generally, you'll just want to use `limit F`.)"]
def limitCone (F : J ⥤ CommGroupCat.{max v u}) : Cone F :=
  liftLimit (limit.isLimit (F ⋙ forget₂ CommGroupCat GroupCat.{max v u}))
#align CommGroup.limit_cone CommGroupCat.limitCone
#align AddCommGroup.limit_cone AddCommGroupCat.limitCone

/-- The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
@[to_additive
      "The chosen cone is a limit cone.\n(Generally, you'll just wantto use `limit.cone F`.)"]
def limitConeIsLimit (F : J ⥤ CommGroupCat.{max v u}) : IsLimit (limitCone F) :=
  liftedLimitIsLimit _
#align CommGroup.limit_cone_is_limit CommGroupCat.limitConeIsLimit
#align AddCommGroup.limit_cone_is_limit AddCommGroupCat.limitConeIsLimit

/-- The category of commutative groups has all limits. -/
@[to_additive "The category of additive commutative groups has all limits."]
instance hasLimitsOfSize : HasLimitsOfSize.{v, v} CommGroupCat.{max v u}
    where HasLimitsOfShape J 𝒥 :=
    { HasLimit := fun F => has_limit_of_created F (forget₂ CommGroupCat GroupCat.{max v u}) }
#align CommGroup.has_limits_of_size CommGroupCat.hasLimitsOfSize
#align AddCommGroup.has_limits_of_size AddCommGroupCat.hasLimitsOfSize

@[to_additive]
instance hasLimits : HasLimits CommGroupCat.{u} :=
  CommGroupCat.hasLimitsOfSize.{u, u}
#align CommGroup.has_limits CommGroupCat.hasLimits
#align AddCommGroup.has_limits AddCommGroupCat.hasLimits

/-- The forgetful functor from commutative groups to groups preserves all limits.
(That is, the underlying group could have been computed instead as limits in the category
of groups.)
-/
@[to_additive AddCommGroupCat.forget₂AddGroupPreservesLimits
      "The forgetful functor from additive commutative groups to groups preserves all limits.\n(That is, the underlying group could have been computed instead as limits in the category\nof additive groups.)"]
instance forget₂GroupPreservesLimitsOfSize :
    PreservesLimitsOfSize.{v, v} (forget₂ CommGroupCat GroupCat.{max v u})
    where PreservesLimitsOfShape J 𝒥 := { PreservesLimit := fun F => by infer_instance }
#align CommGroup.forget₂_Group_preserves_limits_of_size CommGroupCat.forget₂GroupPreservesLimitsOfSize
#align AddCommGroup.forget₂_AddGroup_preserves_limits AddCommGroupCat.forget₂AddGroupPreservesLimits

@[to_additive]
instance forget₂GroupPreservesLimits : PreservesLimits (forget₂ CommGroupCat GroupCat.{u}) :=
  CommGroupCat.forget₂GroupPreservesLimitsOfSize.{u, u}
#align CommGroup.forget₂_Group_preserves_limits CommGroupCat.forget₂GroupPreservesLimits
#align AddCommGroup.forget₂_Group_preserves_limits AddCommGroupCat.forget₂GroupPreservesLimits

/-- An auxiliary declaration to speed up typechecking.
-/
@[to_additive AddCommGroupCat.forget₂AddCommMonPreservesLimitsAux
      "An auxiliary declaration to speed up typechecking."]
def forget₂CommMonPreservesLimitsAux (F : J ⥤ CommGroupCat.{max v u}) :
    IsLimit ((forget₂ CommGroupCat CommMonCat).mapCone (limitCone F)) :=
  CommMonCat.limitConeIsLimit (F ⋙ forget₂ CommGroupCat CommMonCat)
#align CommGroup.forget₂_CommMon_preserves_limits_aux CommGroupCat.forget₂CommMonPreservesLimitsAux
#align AddCommGroup.forget₂_AddCommMon_preserves_limits_aux AddCommGroupCat.forget₂AddCommMonPreservesLimitsAux

/-- The forgetful functor from commutative groups to commutative monoids preserves all limits.
(That is, the underlying commutative monoids could have been computed instead as limits
in the category of commutative monoids.)
-/
@[to_additive AddCommGroupCat.forget₂AddCommMonPreservesLimits
      "The forgetful functor from additive commutative groups to additive commutative monoids preserves\nall limits. (That is, the underlying additive commutative monoids could have been computed instead\nas limits in the category of additive commutative monoids.)"]
instance forget₂CommMonPreservesLimitsOfSize :
    PreservesLimitsOfSize.{v, v} (forget₂ CommGroupCat CommMonCat.{max v u})
    where PreservesLimitsOfShape J 𝒥 :=
    {
      PreservesLimit := fun F =>
        preserves_limit_of_preserves_limit_cone (limit_cone_is_limit F)
          (forget₂_CommMon_preserves_limits_aux F) }
#align CommGroup.forget₂_CommMon_preserves_limits_of_size CommGroupCat.forget₂CommMonPreservesLimitsOfSize
#align AddCommGroup.forget₂_AddCommMon_preserves_limits AddCommGroupCat.forget₂AddCommMonPreservesLimits

/-- The forgetful functor from commutative groups to types preserves all limits. (That is, the
underlying types could have been computed instead as limits in the category of types.)
-/
@[to_additive AddCommGroupCat.forgetPreservesLimits
      "The forgetful functor from additive commutative groups to types preserves all limits. (That is,\nthe underlying types could have been computed instead as limits in the category of types.)"]
instance forgetPreservesLimitsOfSize : PreservesLimitsOfSize.{v, v} (forget CommGroupCat.{max v u})
    where PreservesLimitsOfShape J 𝒥 :=
    {
      PreservesLimit := fun F =>
        limits.comp_preserves_limit (forget₂ CommGroupCat GroupCat) (forget GroupCat) }
#align CommGroup.forget_preserves_limits_of_size CommGroupCat.forgetPreservesLimitsOfSize
#align AddCommGroup.forget_preserves_limits AddCommGroupCat.forgetPreservesLimits

-- Verify we can form limits indexed over smaller categories.
example (f : ℕ → AddCommGroupCat) : HasProduct f := by infer_instance

end CommGroupCat

namespace AddCommGroupCat

/-- The categorical kernel of a morphism in `AddCommGroup`
agrees with the usual group-theoretical kernel.
-/
def kernelIsoKer {G H : AddCommGroupCat.{u}} (f : G ⟶ H) : kernel f ≅ AddCommGroupCat.of f.ker
    where
  Hom :=
    { toFun := fun g =>
        ⟨kernel.ι f g,
          by
          -- TODO where is this `has_coe_t_aux.coe` coming from? can we prevent it appearing?
          change (kernel.ι f) g ∈ f.ker
          simp [AddMonoidHom.mem_ker]⟩
      map_zero' := by
        ext
        simp
      map_add' := fun g g' => by
        ext
        simp }
  inv := kernel.lift f (AddSubgroup.subtype f.ker) (by tidy)
  hom_inv_id' := by
    apply equalizer.hom_ext _
    ext
    simp
  inv_hom_id' := by
    apply AddCommGroupCat.ext
    simp only [AddMonoidHom.coe_mk, coe_id, coe_comp]
    rintro ⟨x, mem⟩
    simp
#align AddCommGroup.kernel_iso_ker AddCommGroupCat.kernelIsoKer

@[simp]
theorem kernelIsoKer_hom_comp_subtype {G H : AddCommGroupCat} (f : G ⟶ H) :
    (kernelIsoKer f).Hom ≫ AddSubgroup.subtype f.ker = kernel.ι f := by ext <;> rfl
#align AddCommGroup.kernel_iso_ker_hom_comp_subtype AddCommGroupCat.kernelIsoKer_hom_comp_subtype

@[simp]
theorem kernelIsoKer_inv_comp_ι {G H : AddCommGroupCat} (f : G ⟶ H) :
    (kernelIsoKer f).inv ≫ kernel.ι f = AddSubgroup.subtype f.ker :=
  by
  ext
  simp [kernel_iso_ker]
#align AddCommGroup.kernel_iso_ker_inv_comp_ι AddCommGroupCat.kernelIsoKer_inv_comp_ι

/-- The categorical kernel inclusion for `f : G ⟶ H`, as an object over `G`,
agrees with the `subtype` map.
-/
@[simps]
def kernelIsoKerOver {G H : AddCommGroupCat.{u}} (f : G ⟶ H) :
    Over.mk (kernel.ι f) ≅ @Over.mk _ _ G (AddCommGroupCat.of f.ker) (AddSubgroup.subtype f.ker) :=
  Over.isoMk (kernelIsoKer f) (by simp)
#align AddCommGroup.kernel_iso_ker_over AddCommGroupCat.kernelIsoKerOver

end AddCommGroupCat


/-
Copyright (c) 2019 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.nat.choose.basic
import data.list.perm

/-! # sublists

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

`list.sublists` gives a list of all (not necessarily contiguous) sublists of a list.

This file contains basic results on this function.
-/

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}
open nat

namespace list

/-! ### sublists -/

@[simp] theorem sublists'_nil : sublists' (@nil α) = [[]] := rfl

@[simp, priority 1100] theorem sublists'_singleton (a : α) : sublists' [a] = [[], [a]] := rfl

theorem map_sublists'_aux (g : list β → list γ) (l : list α) (f r) :
  map g (sublists'_aux l f r) = sublists'_aux l (g ∘ f) (map g r) :=
by induction l generalizing f r; [refl, simp only [*, sublists'_aux]]

theorem sublists'_aux_append (r' : list (list β)) (l : list α) (f r) :
  sublists'_aux l f (r ++ r') = sublists'_aux l f r ++ r' :=
by induction l generalizing f r; [refl, simp only [*, sublists'_aux]]

theorem sublists'_aux_eq_sublists' (l f r) :
  @sublists'_aux α β l f r = map f (sublists' l) ++ r :=
by rw [sublists', map_sublists'_aux, ← sublists'_aux_append]; refl

@[simp] theorem sublists'_cons (a : α) (l : list α) :
  sublists' (a :: l) = sublists' l ++ map (cons a) (sublists' l) :=
by rw [sublists', sublists'_aux]; simp only [sublists'_aux_eq_sublists', map_id, append_nil]; refl

@[simp] theorem mem_sublists' {s t : list α} : s ∈ sublists' t ↔ s <+ t :=
begin
  induction t with a t IH generalizing s,
  { simp only [sublists'_nil, mem_singleton],
    exact ⟨λ h, by rw h, eq_nil_of_sublist_nil⟩ },
  simp only [sublists'_cons, mem_append, IH, mem_map],
  split; intro h, rcases h with h | ⟨s, h, rfl⟩,
  { exact sublist_cons_of_sublist _ h },
  { exact h.cons_cons _ },
  { cases h with _ _ _ h s _ _ h,
    { exact or.inl h },
    { exact or.inr ⟨s, h, rfl⟩ } }
end

@[simp] theorem length_sublists' : ∀ l : list α, length (sublists' l) = 2 ^ length l
| []     := rfl
| (a::l) := by simp only [sublists'_cons, length_append, length_sublists' l, length_map,
    length, pow_succ', mul_succ, mul_zero, zero_add]

@[simp] theorem sublists_nil : sublists (@nil α) = [[]] := rfl

@[simp] theorem sublists_singleton (a : α) : sublists [a] = [[], [a]] := rfl

theorem sublists_aux₁_eq_sublists_aux : ∀ l (f : list α → list β),
  sublists_aux₁ l f = sublists_aux l (λ ys r, f ys ++ r)
| []     f := rfl
| (a::l) f := by rw [sublists_aux₁, sublists_aux]; simp only [*, append_assoc]

theorem sublists_aux_cons_eq_sublists_aux₁ (l : list α) :
  sublists_aux l cons = sublists_aux₁ l (λ x, [x]) :=
by rw [sublists_aux₁_eq_sublists_aux]; refl

theorem sublists_aux_eq_foldr.aux {a : α} {l : list α}
  (IH₁ : ∀ (f : list α → list β → list β), sublists_aux l f = foldr f [] (sublists_aux l cons))
  (IH₂ : ∀ (f : list α → list (list α) → list (list α)),
      sublists_aux l f = foldr f [] (sublists_aux l cons))
  (f : list α → list β → list β) : sublists_aux (a::l) f = foldr f [] (sublists_aux (a::l) cons) :=
begin
  simp only [sublists_aux, foldr_cons], rw [IH₂, IH₁], congr' 1,
  induction sublists_aux l cons with _ _ ih, {refl},
  simp only [ih, foldr_cons]
end

theorem sublists_aux_eq_foldr (l : list α) : ∀ (f : list α → list β → list β),
  sublists_aux l f = foldr f [] (sublists_aux l cons) :=
suffices _ ∧ ∀ f : list α → list (list α) → list (list α),
    sublists_aux l f = foldr f [] (sublists_aux l cons),
  from this.1,
begin
  induction l with a l IH, {split; intro; refl},
  exact ⟨sublists_aux_eq_foldr.aux IH.1 IH.2,
         sublists_aux_eq_foldr.aux IH.2 IH.2⟩
end

theorem sublists_aux_cons_cons (l : list α) (a : α) :
  sublists_aux (a::l) cons = [a] :: foldr (λys r, ys :: (a :: ys) :: r) [] (sublists_aux l cons) :=
by rw [← sublists_aux_eq_foldr]; refl

theorem sublists_aux₁_append : ∀ (l₁ l₂ : list α) (f : list α → list β),
  sublists_aux₁ (l₁ ++ l₂) f = sublists_aux₁ l₁ f ++
    sublists_aux₁ l₂ (λ x, f x ++ sublists_aux₁ l₁ (f ∘ (++ x)))
| []      l₂ f := by simp only [sublists_aux₁, nil_append, append_nil]
| (a::l₁) l₂ f := by simp only [sublists_aux₁, cons_append, sublists_aux₁_append l₁, append_assoc];
  refl

theorem sublists_aux₁_concat (l : list α) (a : α) (f : list α → list β) :
  sublists_aux₁ (l ++ [a]) f = sublists_aux₁ l f ++
    f [a] ++ sublists_aux₁ l (λ x, f (x ++ [a])) :=
by simp only [sublists_aux₁_append, sublists_aux₁, append_assoc, append_nil]

theorem sublists_aux₁_bind : ∀ (l : list α)
  (f : list α → list β) (g : β → list γ),
  (sublists_aux₁ l f).bind g = sublists_aux₁ l (λ x, (f x).bind g)
| []     f g := rfl
| (a::l) f g := by simp only [sublists_aux₁, bind_append, sublists_aux₁_bind l]

theorem sublists_aux_cons_append (l₁ l₂ : list α) :
  sublists_aux (l₁ ++ l₂) cons = sublists_aux l₁ cons ++
    (do x ← sublists_aux l₂ cons, (++ x) <$> sublists l₁) :=
begin
  simp only [sublists, sublists_aux_cons_eq_sublists_aux₁, sublists_aux₁_append, bind_eq_bind,
    sublists_aux₁_bind],
  congr, funext x, apply congr_arg _,
  rw [← bind_ret_eq_map, sublists_aux₁_bind], exact (append_nil _).symm
end

theorem sublists_append (l₁ l₂ : list α) :
  sublists (l₁ ++ l₂) = (do x ← sublists l₂, (++ x) <$> sublists l₁) :=
by simp only [map, sublists, sublists_aux_cons_append, map_eq_map, bind_eq_bind,
  cons_bind, map_id', append_nil, cons_append, map_id' (λ _, rfl)]; split; refl

@[simp] theorem sublists_concat (l : list α) (a : α) :
  sublists (l ++ [a]) = sublists l ++ map (λ x, x ++ [a]) (sublists l) :=
by rw [sublists_append, sublists_singleton, bind_eq_bind, cons_bind, cons_bind, nil_bind,
  map_eq_map, map_eq_map, map_id' (append_nil), append_nil]

theorem sublists_reverse (l : list α) : sublists (reverse l) = map reverse (sublists' l) :=
by induction l with hd tl ih; [refl,
simp only [reverse_cons, sublists_append, sublists'_cons, map_append, ih, sublists_singleton,
  map_eq_map, bind_eq_bind, map_map, cons_bind, append_nil, nil_bind, (∘)]]

theorem sublists_eq_sublists' (l : list α) : sublists l = map reverse (sublists' (reverse l)) :=
by rw [← sublists_reverse, reverse_reverse]

theorem sublists'_reverse (l : list α) : sublists' (reverse l) = map reverse (sublists l) :=
by simp only [sublists_eq_sublists', map_map, map_id' (reverse_reverse)]

theorem sublists'_eq_sublists (l : list α) : sublists' l = map reverse (sublists (reverse l)) :=
by rw [← sublists'_reverse, reverse_reverse]

theorem sublists_aux_ne_nil : ∀ (l : list α), [] ∉ sublists_aux l cons
| [] := id
| (a::l) := begin
  rw [sublists_aux_cons_cons],
  refine not_mem_cons_of_ne_of_not_mem (cons_ne_nil _ _).symm _,
  have := sublists_aux_ne_nil l, revert this,
  induction sublists_aux l cons; intro, {rwa foldr},
  simp only [foldr, mem_cons_iff, false_or, not_or_distrib],
  exact ⟨ne_of_not_mem_cons this, ih (not_mem_of_not_mem_cons this)⟩
end

@[simp] theorem mem_sublists {s t : list α} : s ∈ sublists t ↔ s <+ t :=
by rw [← reverse_sublist_iff, ← mem_sublists',
       sublists'_reverse, mem_map_of_injective reverse_injective]

@[simp] theorem length_sublists (l : list α) : length (sublists l) = 2 ^ length l :=
by simp only [sublists_eq_sublists', length_map, length_sublists', length_reverse]

theorem map_ret_sublist_sublists (l : list α) : map list.ret l <+ sublists l :=
reverse_rec_on l (nil_sublist _) $
λ l a IH, by simp only [map, map_append, sublists_concat]; exact
((append_sublist_append_left _).2 $ singleton_sublist.2 $
  mem_map.2 ⟨[], mem_sublists.2 (nil_sublist _), by refl⟩).trans
((append_sublist_append_right _).2 IH)

/-! ### sublists_len -/

/-- Auxiliary function to construct the list of all sublists of a given length. Given an
integer `n`, a list `l`, a function `f` and an auxiliary list `L`, it returns the list made of
of `f` applied to all sublists of `l` of length `n`, concatenated with `L`. -/
def sublists_len_aux {α β : Type*} : ℕ → list α → (list α → β) → list β → list β
| 0     l      f r := f [] :: r
| (n+1) []     f r := r
| (n+1) (a::l) f r := sublists_len_aux (n + 1) l f
  (sublists_len_aux n l (f ∘ list.cons a) r)

/-- The list of all sublists of a list `l` that are of length `n`. For instance, for
`l = [0, 1, 2, 3]` and `n = 2`, one gets
`[[2, 3], [1, 3], [1, 2], [0, 3], [0, 2], [0, 1]]`. -/
def sublists_len {α : Type*} (n : ℕ) (l : list α) : list (list α) :=
sublists_len_aux n l id []

lemma sublists_len_aux_append {α β γ : Type*} :
  ∀ (n : ℕ) (l : list α) (f : list α → β) (g : β → γ) (r : list β) (s : list γ),
  sublists_len_aux n l (g ∘ f) (r.map g ++ s) =
  (sublists_len_aux n l f r).map g ++ s
| 0     l      f g r s := rfl
| (n+1) []     f g r s := rfl
| (n+1) (a::l) f g r s := begin
  unfold sublists_len_aux,
  rw [show ((g ∘ f) ∘ list.cons a) = (g ∘ f ∘ list.cons a), by refl,
    sublists_len_aux_append, sublists_len_aux_append]
end

lemma sublists_len_aux_eq {α β : Type*} (l : list α) (n) (f : list α → β) (r) :
  sublists_len_aux n l f r = (sublists_len n l).map f ++ r :=
by rw [sublists_len, ← sublists_len_aux_append]; refl

lemma sublists_len_aux_zero {α : Type*} (l : list α) (f : list α → β) (r) :
  sublists_len_aux 0 l f r = f [] :: r := by cases l; refl

@[simp]

@[simp] lemma sublists_len_succ_nil {α : Type*} (n) :
  sublists_len (n+1) (@nil α) = [] := rfl

@[simp] lemma sublists_len_succ_cons {α : Type*} (n) (a : α) (l) :
  sublists_len (n + 1) (a::l) =
  sublists_len (n + 1) l ++ (sublists_len n l).map (cons a) :=
by rw [sublists_len, sublists_len_aux, sublists_len_aux_eq,
  sublists_len_aux_eq, map_id, append_nil]; refl

@[simp] lemma length_sublists_len {α : Type*} : ∀ n (l : list α),
  length (sublists_len n l) = nat.choose (length l) n
| 0     l      := by simp
| (n+1) []     := by simp
| (n+1) (a::l) := by simp [-add_comm, nat.choose, *]; apply add_comm

lemma sublists_len_sublist_sublists' {α : Type*} : ∀ n (l : list α),
  sublists_len n l <+ sublists' l
| 0     l      := singleton_sublist.2 (mem_sublists'.2 (nil_sublist _))
| (n+1) []     := nil_sublist _
| (n+1) (a::l) := begin
  rw [sublists_len_succ_cons, sublists'_cons],
  exact (sublists_len_sublist_sublists' _ _).append
    ((sublists_len_sublist_sublists' _ _).map _)
end

lemma sublists_len_sublist_of_sublist
  {α : Type*} (n) {l₁ l₂ : list α} (h : l₁ <+ l₂) : sublists_len n l₁ <+ sublists_len n l₂ :=
begin
  induction n with n IHn generalizing l₁ l₂, {simp},
  induction h with l₁ l₂ a s IH l₁ l₂ a s IH, {refl},
  { refine IH.trans _,
    rw sublists_len_succ_cons,
    apply sublist_append_left },
  { simp [sublists_len_succ_cons],
    exact IH.append ((IHn s).map _) }
end

lemma length_of_sublists_len {α : Type*} : ∀ {n} {l l' : list α},
  l' ∈ sublists_len n l → length l' = n
| 0     l      l' (or.inl rfl) := rfl
| (n+1) (a::l) l' h := begin
  rw [sublists_len_succ_cons, mem_append, mem_map] at h,
  rcases h with h | ⟨l', h, rfl⟩,
  { exact length_of_sublists_len h },
  { exact congr_arg (+1) (length_of_sublists_len h) },
end

lemma mem_sublists_len_self {α : Type*} {l l' : list α}
  (h : l' <+ l) : l' ∈ sublists_len (length l') l :=
begin
  induction h with l₁ l₂ a s IH l₁ l₂ a s IH,
  { exact or.inl rfl },
  { cases l₁ with b l₁,
    { exact or.inl rfl },
    { rw [length, sublists_len_succ_cons],
      exact mem_append_left _ IH } },
  { rw [length, sublists_len_succ_cons],
    exact mem_append_right _ (mem_map.2 ⟨_, IH, rfl⟩) }
end

@[simp] lemma mem_sublists_len {α : Type*} {n} {l l' : list α} :
  l' ∈ sublists_len n l ↔ l' <+ l ∧ length l' = n :=
⟨λ h, ⟨mem_sublists'.1
    ((sublists_len_sublist_sublists' _ _).subset h),
  length_of_sublists_len h⟩,
λ ⟨h₁, h₂⟩, h₂ ▸ mem_sublists_len_self h₁⟩

lemma sublists_len_of_length_lt {n} {l : list α} (h : l.length < n) : sublists_len n l = [] :=
eq_nil_iff_forall_not_mem.mpr $ λ x, mem_sublists_len.not.mpr $ λ ⟨hs, hl⟩,
  (h.trans_eq hl.symm).not_le (sublist.length_le hs)

@[simp] lemma sublists_len_length : ∀ (l : list α), sublists_len l.length l = [l]
| [] := rfl
| (a::l) := by rw [length, sublists_len_succ_cons, sublists_len_length, map_singleton,
                   sublists_len_of_length_lt (lt_succ_self _), nil_append]

open function

theorem pairwise.sublists' {R} : ∀ {l : list α}, pairwise R l →
  pairwise (lex (swap R)) (sublists' l)
| _ pairwise.nil := pairwise_singleton _ _
| _ (@pairwise.cons _ _ a l H₁ H₂) :=
  begin
    simp only [sublists'_cons, pairwise_append, pairwise_map, mem_sublists', mem_map,
      exists_imp_distrib, and_imp],
    refine ⟨H₂.sublists', H₂.sublists'.imp (λ l₁ l₂, lex.cons), _⟩,
    rintro l₁ sl₁ x l₂ sl₂ rfl,
    cases l₁ with b l₁, {constructor},
    exact lex.rel (H₁ _ $ sl₁.subset $ mem_cons_self _ _)
  end

theorem pairwise_sublists {R} {l : list α} (H : pairwise R l) :
  pairwise (λ l₁ l₂, lex R (reverse l₁) (reverse l₂)) (sublists l) :=
by { have := (pairwise_reverse.2 H).sublists', rwa [sublists'_reverse, pairwise_map] at this }

@[simp] theorem nodup_sublists {l : list α} : nodup (sublists l) ↔ nodup l :=
⟨λ h, (h.sublist (map_ret_sublist_sublists _)).of_map _,
 λ h, (pairwise_sublists h).imp (λ _ _ h, mt reverse_inj.2 h.to_ne)⟩

@[simp] theorem nodup_sublists' {l : list α} : nodup (sublists' l) ↔ nodup l :=
by rw [sublists'_eq_sublists, nodup_map_iff reverse_injective,
       nodup_sublists, nodup_reverse]

alias nodup_sublists ↔ nodup.of_sublists nodup.sublists
alias nodup_sublists' ↔ nodup.of_sublists' nodup.sublists'

attribute [protected] nodup.sublists nodup.sublists'

lemma nodup_sublists_len (n : ℕ) {l : list α} (h : nodup l) : (sublists_len n l).nodup :=
h.sublists'.sublist $ sublists_len_sublist_sublists' _ _

theorem sublists_cons_perm_append (a : α) (l : list α) :
  sublists (a :: l) ~ sublists l ++ map (cons a) (sublists l) :=
begin
  simp only [sublists, sublists_aux_cons_cons, cons_append, perm_cons],
  refine (perm.cons _ _).trans perm_middle.symm,
  induction sublists_aux l cons with b l IH; simp,
  exact (IH.cons _).trans perm_middle.symm
end

theorem sublists_perm_sublists' : ∀ l : list α, sublists l ~ sublists' l
| []     := perm.refl _
| (a::l) := let IH := sublists_perm_sublists' l in
  by rw sublists'_cons; exact
  (sublists_cons_perm_append _ _).trans (IH.append (IH.map _))

theorem revzip_sublists (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  apply list.reverse_rec_on l,
  { intros l₁ l₂ h, simp at h, simp [h] },
  { intros l a IH l₁ l₂ h,
    rw [sublists_concat, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [skip, {simp}],
    simp only [prod.mk.inj_iff, mem_map, mem_append, prod.map_mk, prod.exists] at h,
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', l₂, h, rfl, rfl⟩,
    { rw ← append_assoc,
      exact (IH _ _ h).append_right _ },
    { rw append_assoc,
      apply (perm_append_comm.append_left _).trans,
      rw ← append_assoc,
      exact (IH _ _ h).append_right _ } }
end

theorem revzip_sublists' (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists' → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  induction l with a l IH; intros l₁ l₂ h,
  { simp at h, simp [h] },
  { rw [sublists'_cons, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [simp at h, simp],
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', h, rfl⟩,
    { exact perm_middle.trans ((IH _ _ h).cons _) },
    { exact (IH _ _ h).cons _ } }
end

lemma range_bind_sublists_len_perm {α : Type*} (l : list α) :
  (list.range (l.length + 1)).bind (λ n, sublists_len n l) ~ sublists' l :=
begin
  induction l with h tl,
  { simp [range_succ] },
  { simp_rw [range_succ_eq_map, length, cons_bind, map_bind, sublists_len_succ_cons,
      sublists'_cons, list.sublists_len_zero, list.singleton_append],
    refine ((bind_append_perm (range (tl.length + 1)) _ _).symm.cons _).trans _,
    simp_rw [←list.bind_map, ←cons_append],
    rw [←list.singleton_append, ←list.sublists_len_zero tl],
    refine perm.append _ (l_ih.map _),
    rw [list.range_succ, append_bind, bind_singleton,
      sublists_len_of_length_lt (nat.lt_succ_self _), append_nil,
      ←list.map_bind (λ n, sublists_len n tl) nat.succ, ←cons_bind 0 _ (λ n, sublists_len n tl),
      ←range_succ_eq_map],
    exact l_ih }
end

end list


-- Naive set theory

noncomputable theory
open classical

axiom ens : Type
namespace ens
  axiom contains : ens → ens → Prop
  instance : has_mem ens ens := ⟨contains⟩

  axiom comp : (ens → Prop) → ens
  @[simp] axiom compβrule : Π (φ : ens → Prop) (x : ens), (x ∈ comp φ) = φ x
  axiom setext.intro : ∀ {α β : ens}, (∀ x, x ∈ α ↔ x ∈ β) → α = β

  def setext.elim {α β : ens} : α = β → (∀ x, x ∈ α ↔ x ∈ β) :=
  begin intro p, induction p, intro x, apply iff.refl end

  def setext {α β : ens} : (∀ x, x ∈ α ↔ x ∈ β) ↔ (α = β) :=
  ⟨setext.intro, setext.elim⟩

  def spec (f : ens → ens) := comp (λ y, ∃ x, f x = y)

  def map (α β : ens) (f : ens → ens) :=
  comp (λ y, ∃ x, x ∈ α ∧ y ∈ β ∧ f x = y)

  def bimap (α β : ens) (f : ens → ens → ens) :=
  comp (λ x, ∃ u v, u ∈ α ∧ v ∈ β ∧ x = f u v)

  def empty := comp (λ _, false)

  theorem {u} empty.elim {α : Sort u} {β : ens} : β ∈ empty → α :=
  begin intro p, simp [empty] at p, induction p end

  def univ : ens := comp (λ _, true)

  def insert (x : ens) (α : ens) :=
  comp (λ y, x = y ∨ y ∈ α)
  instance : has_insert ens ens := ⟨insert⟩

  def sep (p : ens → Prop) (s : ens) :=
  comp (λ x, x ∈ s ∧ p x)
  instance : has_sep ens ens := ⟨sep⟩

  @[simp] def insertβrule (x y : ens) (α : ens) : (x ∈ insert y α) = (y = x ∨ x ∈ α) :=
  by simp [insert]

  def union (α β : ens) := comp (λ x, x ∈ α ∨ x ∈ β)
  def diff  (α β : ens) := {x ∈ α | x ∉ β}
  def inter (α β : ens) : ens := {x ∈ α | x ∈ β}
  def subset (α β : ens) := ∀ x, x ∈ α → x ∈ β
  def compl (α : ens) := comp (λ x, x ∉ α)

  instance : has_emptyc ens := ⟨empty⟩
  instance : has_union ens  := ⟨union⟩
  instance : has_inter ens  := ⟨inter⟩
  instance : has_subset ens := ⟨subset⟩
  instance : has_neg ens    := ⟨compl⟩
  instance : has_sdiff ens  := ⟨diff⟩

  instance : has_singleton ens ens := ⟨λ x, insert x ∅⟩

  def singleton.id {α : ens} : α ∈ (singleton α : ens) :=
  by simp [singleton, has_insert.insert]

  def sUnion (α : ens) : ens := comp (λ t, ∃ x ∈ α, t ∈ x)
  prefix ⋃₀ := sUnion

  def powerset (α : ens) := comp (⊆ α)
  prefix `𝒫` := powerset

  def unord (α β : ens) : ens := {α, β}
  def pair (α β : ens) : ens := {{α}, {α, β}}
  def prod (α β : ens) : ens := bimap α β pair
  local infix × := prod

  def prod.intro {α β x y : ens} : x ∈ α → y ∈ β → pair x y ∈ (α × β) := begin
    intros h g, simp [pair, prod, bimap],
    existsi x, existsi y, split,
    exact h, split, exact g, trivial
  end

  lemma unord.left {α β : ens} : α ∈ unord α β :=
  begin simp [unord, has_insert.insert, singleton] end

  lemma unord.right {α β : ens} : β ∈ unord α β :=
  begin
    simp [unord, has_insert.insert], right,
    simp [has_singleton.singleton, insertβrule]
  end

  def singleton.eq {α β : ens} : @eq ens {α} {β} → α = β := begin
    intro p, have q := (setext.elim p α).mp singleton.id,
    simp [singleton, has_insert.insert] at q, induction q,
    { symmetry, assumption },
    { apply empty.elim q }
  end

  def unord.eq {α β α' β' : ens} : unord α β = unord α' β' →
    (α = α' ∧ β = β') ∨ (α = β' ∧ β = α') := begin
    intro x,
    have p := (setext.elim x α).mp unord.left,
    have q := (setext.elim x β).mp unord.right,
    have r := (setext.elim x α').mpr unord.left,
    have s := (setext.elim x β').mpr unord.right,
    simp [unord, has_insert.insert, singleton] at p q r s,
    repeat { induction p <|> induction q <|> induction r <|> induction s },
    repeat { { left, split; refl } <|> { right, split; refl } <|>
             { apply empty.elim, assumption } }
  end

  def pair.eq {α β α' β' : ens} : pair α β = pair α' β' → α = α' ∧ β = β' := begin
    intro p, simp [pair] at p,
    cases unord.eq p with q,
    { induction q with u v,
      have q := singleton.eq u, split,
      { assumption },
      { cases unord.eq v with x y,
        { cases x, assumption },
        { cases y with r s,
          transitivity, exact s,
          transitivity, symmetry, exact q,
          exact r } } },
    { induction h with r s, split,
      { have q := (setext.elim r α').mpr unord.left,
        simp [singleton, has_insert.insert] at q,
        induction q, assumption, apply empty.elim q },
      { have a := (setext.elim r β').mpr unord.right,
        have b := (setext.elim s β).mp   unord.right,
        have c := (setext.elim r α').mpr unord.left,
        simp [singleton, has_insert.insert,
              has_emptyc.emptyc, empty] at a b c,
        transitivity, { symmetry, exact b },
        transitivity, { symmetry, exact c },
        exact a } }
  end

  structure function (α β : ens) :=
  (map : ens) (sub : map ⊆ (α × β))
  (uniq : ∀ (u ∈ α), ∃! (v ∈ β), pair u v ∈ map)

  infix ` ⟶ `:30 := function

  def function.intro {α β : ens}
    (f : ens → ens) (cod : ∀ x, f x ∈ β) : α ⟶ β :=
  ⟨map α (α × β) (λ x, pair x (f x)),
   begin
     intros y p, simp [map] at p,
     induction p with x p,
     induction p with u p,
     induction p with v p,
     exact v
   end,
   begin
     intros u p, existsi f u, split,
     { simp [map], existsi cod u, split,
       existsi u, split, exact p, split,
       apply prod.intro, exact p, exact cod u,
       trivial, { intros G H, trivial } },
     { intros x q, induction q with x q, induction q with q r, simp [map] at q,
       induction q with y q, induction q with a q, induction q with b q,
       have s := pair.eq q, induction s with s₁ s₂,
       symmetry, induction s₁, assumption }
   end⟩

  def une : ens := {∅}
  notation `𝟙` := une

  def bool : ens := {∅, 𝟙}
  def not : bool ⟶ bool :=
  function.intro (λ x,
  match prop_decidable (x = ∅) with
  | is_true _  := 𝟙
  | is_false _ := ∅
  end) (begin
    intro x, simp [bool, has_insert.insert],
    induction prop_decidable (x = ∅),
    { left, trivial }, { right, apply singleton.id }
  end)

  lemma univ_in_univ : univ ∈ univ :=
  by simp [univ]

  def R : ens := comp (λ x, x ∉ x)
  def Russell : R ∈ R ↔ R ∉ R := begin
    unfold R, split; intro H,
    { rw [compβrule] at H, assumption },
    { rw [compβrule], assumption }
  end

  -- la fin
  def falso : false :=
  match prop_decidable (R ∈ R) with
  | is_true h  := absurd h (Russell.mp h)
  | is_false h := absurd (Russell.mpr h) h
  end
end ens


/-
Copyright (c) 2020 Yury Kudryashov All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.basic
import Mathlib.PostPort

universes u v w l u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Partially defined linear maps

A `linear_pmap R E F` is a linear map from a submodule of `E` to `F`. We define
a `semilattice_inf_bot` instance on this this, and define three operations:

* `mk_span_singleton` defines a partial linear map defined on the span of a singleton.
* `sup` takes two partial linear maps `f`, `g` that agree on the intersection of their
  domains, and returns the unique partial linear map on `f.domain ⊔ g.domain` that
  extends both `f` and `g`.
* `Sup` takes a `directed_on (≤)` set of partial linear maps, and returns the unique
  partial linear map on the `Sup` of their domains that extends all these maps.

Partially defined maps are currently used in `mathlib` to prove Hahn-Banach theorem
and its variations. Namely, `linear_pmap.Sup` implies that every chain of `linear_pmap`s
is bounded above.

Another possible use (not yet in `mathlib`) would be the theory of unbounded linear operators.
-/

/-- A `linear_pmap R E F` is a linear map from a submodule of `E` to `F`. -/
structure linear_pmap (R : Type u) [ring R] (E : Type v) [add_comm_group E] [module R E]
    (F : Type w) [add_comm_group F] [module R F]
    where
  domain : submodule R E
  to_fun : linear_map R (↥domain) F

namespace linear_pmap

protected instance has_coe_to_fun {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E]
    [module R E] {F : Type u_3} [add_comm_group F] [module R F] :
    has_coe_to_fun (linear_pmap R E F) :=
  has_coe_to_fun.mk (fun (f : linear_pmap R E F) => ↥(domain f) → F)
    fun (f : linear_pmap R E F) => ⇑(to_fun f)

@[simp] theorem to_fun_eq_coe {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f)) :
    coe_fn (to_fun f) x = coe_fn f x :=
  rfl

@[simp] theorem map_zero {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) : coe_fn f 0 = 0 :=
  linear_map.map_zero (to_fun f)

theorem map_add {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f))
    (y : ↥(domain f)) : coe_fn f (x + y) = coe_fn f x + coe_fn f y :=
  linear_map.map_add (to_fun f) x y

theorem map_neg {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f)) :
    coe_fn f (-x) = -coe_fn f x :=
  linear_map.map_neg (to_fun f) x

theorem map_sub {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain f))
    (y : ↥(domain f)) : coe_fn f (x - y) = coe_fn f x - coe_fn f y :=
  linear_map.map_sub (to_fun f) x y

theorem map_smul {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (c : R)
    (x : ↥(domain f)) : coe_fn f (c • x) = c • coe_fn f x :=
  linear_map.map_smul (to_fun f) c x

@[simp] theorem mk_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (f : linear_map R (↥p) F)
    (x : ↥p) : coe_fn (mk p f) x = coe_fn f x :=
  rfl

/-- The unique `linear_pmap` on `R ∙ x` that sends `x` to `y`. This version works for modules
over rings, and requires a proof of `∀ c, c • x = 0 → c • y = 0`. -/
def mk_span_singleton' {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (x : E) (y : F)
    (H : ∀ (c : R), c • x = 0 → c • y = 0) : linear_pmap R E F :=
  mk (submodule.span R (singleton x))
    (linear_map.mk (fun (z : ↥(submodule.span R (singleton x))) => classical.some sorry • y) sorry
      sorry)

@[simp] theorem domain_mk_span_singleton {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E]
    [module R E] {F : Type u_3} [add_comm_group F] [module R F] (x : E) (y : F)
    (H : ∀ (c : R), c • x = 0 → c • y = 0) :
    domain (mk_span_singleton' x y H) = submodule.span R (singleton x) :=
  rfl

@[simp] theorem mk_span_singleton_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E]
    [module R E] {F : Type u_3} [add_comm_group F] [module R F] (x : E) (y : F)
    (H : ∀ (c : R), c • x = 0 → c • y = 0) (c : R) (h : c • x ∈ domain (mk_span_singleton' x y H)) :
    coe_fn (mk_span_singleton' x y H) { val := c • x, property := h } = c • y :=
  sorry

/-- The unique `linear_pmap` on `span R {x}` that sends a non-zero vector `x` to `y`.
This version works for modules over division rings. -/
def mk_span_singleton {K : Type u_1} {E : Type u_2} {F : Type u_3} [division_ring K]
    [add_comm_group E] [module K E] [add_comm_group F] [module K F] (x : E) (y : F) (hx : x ≠ 0) :
    linear_pmap K E F :=
  mk_span_singleton' x y sorry

/-- Projection to the first coordinate as a `linear_pmap` -/
protected def fst {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F) :
    linear_pmap R (E × F) E :=
  mk (submodule.prod p p')
    (linear_map.comp (linear_map.fst R E F) (submodule.subtype (submodule.prod p p')))

@[simp] theorem fst_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F)
    (x : ↥(submodule.prod p p')) : coe_fn (linear_pmap.fst p p') x = prod.fst ↑x :=
  rfl

/-- Projection to the second coordinate as a `linear_pmap` -/
protected def snd {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F) :
    linear_pmap R (E × F) F :=
  mk (submodule.prod p p')
    (linear_map.comp (linear_map.snd R E F) (submodule.subtype (submodule.prod p p')))

@[simp] theorem snd_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (p : submodule R E) (p' : submodule R F)
    (x : ↥(submodule.prod p p')) : coe_fn (linear_pmap.snd p p') x = prod.snd ↑x :=
  rfl

protected instance has_neg {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] : Neg (linear_pmap R E F) :=
  { neg := fun (f : linear_pmap R E F) => mk (domain f) (-to_fun f) }

@[simp] theorem neg_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (x : ↥(domain (-f))) :
    coe_fn (-f) x = -coe_fn f x :=
  rfl

protected instance has_le {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] : HasLessEq (linear_pmap R E F) :=
  { LessEq :=
      fun (f g : linear_pmap R E F) =>
        domain f ≤ domain g ∧
          ∀ {x : ↥(domain f)} {y : ↥(domain g)}, ↑x = ↑y → coe_fn f x = coe_fn g y }

theorem eq_of_le_of_domain_eq {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F}
    (hle : f ≤ g) (heq : domain f = domain g) : f = g :=
  sorry

/-- Given two partial linear maps `f`, `g`, the set of points `x` such that
both `f` and `g` are defined at `x` and `f x = g x` form a submodule. -/
def eq_locus {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3}
    [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F) :
    submodule R E :=
  submodule.mk
    (set_of
      fun (x : E) =>
        ∃ (hf : x ∈ domain f),
          ∃ (hg : x ∈ domain g),
            coe_fn f { val := x, property := hf } = coe_fn g { val := x, property := hg })
    sorry sorry sorry

protected instance has_inf {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] : has_inf (linear_pmap R E F) :=
  has_inf.mk
    fun (f g : linear_pmap R E F) =>
      mk (eq_locus f g) (linear_map.comp (to_fun f) (submodule.of_le sorry))

protected instance has_bot {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] : has_bot (linear_pmap R E F) :=
  has_bot.mk (mk ⊥ 0)

protected instance inhabited {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] : Inhabited (linear_pmap R E F) :=
  { default := ⊥ }

protected instance semilattice_inf_bot {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E]
    [module R E] {F : Type u_3} [add_comm_group F] [module R F] :
    semilattice_inf_bot (linear_pmap R E F) :=
  semilattice_inf_bot.mk ⊥ LessEq (order_bot.lt._default LessEq) sorry sorry sorry sorry has_inf.inf
    sorry sorry sorry

theorem le_of_eq_locus_ge {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F}
    (H : domain f ≤ eq_locus f g) : f ≤ g :=
  sorry

theorem domain_mono {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] : strict_mono domain :=
  fun (f g : linear_pmap R E F) (hlt : f < g) =>
    lt_of_le_of_ne (and.left (and.left hlt))
      fun (heq : domain f = domain g) => ne_of_lt hlt (eq_of_le_of_domain_eq (le_of_lt hlt) heq)

/-- Given two partial linear maps that agree on the intersection of their domains,
`f.sup g h` is the unique partial linear map on `f.domain ⊔ g.domain` that agrees
with `f` and `g`. -/
protected def sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F)
    (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) :
    linear_pmap R E F :=
  mk (domain f ⊔ domain g) (classical.some (sup_aux f g h))

@[simp] theorem domain_sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F)
    (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) :
    domain (linear_pmap.sup f g h) = domain f ⊔ domain g :=
  rfl

theorem sup_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F}
    (H : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) (x : ↥(domain f))
    (y : ↥(domain g)) (z : ↥(domain (linear_pmap.sup f g H))) (hz : ↑x + ↑y = ↑z) :
    coe_fn (linear_pmap.sup f g H) z = coe_fn f x + coe_fn g y :=
  classical.some_spec (sup_aux f g H) x y z hz

protected theorem left_le_sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F)
    (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) :
    f ≤ linear_pmap.sup f g h :=
  sorry

protected theorem right_le_sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E]
    [module R E] {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F)
    (g : linear_pmap R E F)
    (h : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) :
    g ≤ linear_pmap.sup f g h :=
  sorry

protected theorem sup_le {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] {f : linear_pmap R E F} {g : linear_pmap R E F}
    {h : linear_pmap R E F}
    (H : ∀ (x : ↥(domain f)) (y : ↥(domain g)), ↑x = ↑y → coe_fn f x = coe_fn g y) (fh : f ≤ h)
    (gh : g ≤ h) : linear_pmap.sup f g H ≤ h :=
  sorry

/-- Hypothesis for `linear_pmap.sup` holds, if `f.domain` is disjoint with `g.domain`. -/
theorem sup_h_of_disjoint {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (g : linear_pmap R E F)
    (h : disjoint (domain f) (domain g)) (x : ↥(domain f)) (y : ↥(domain g)) (hxy : ↑x = ↑y) :
    coe_fn f x = coe_fn g y :=
  sorry

/-- Glue a collection of partially defined linear maps to a linear map defined on `Sup`
of these submodules. -/
protected def Sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (c : set (linear_pmap R E F))
    (hc : directed_on LessEq c) : linear_pmap R E F :=
  mk (Sup (domain '' c)) (classical.some (Sup_aux c hc))

protected theorem le_Sup {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] {c : set (linear_pmap R E F)}
    (hc : directed_on LessEq c) {f : linear_pmap R E F} (hf : f ∈ c) : f ≤ linear_pmap.Sup c hc :=
  classical.some_spec (Sup_aux c hc) f hf

protected theorem Sup_le {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] {c : set (linear_pmap R E F)}
    (hc : directed_on LessEq c) {g : linear_pmap R E F}
    (hg : ∀ (f : linear_pmap R E F), f ∈ c → f ≤ g) : linear_pmap.Sup c hc ≤ g :=
  sorry

end linear_pmap

namespace linear_map

/-- Restrict a linear map to a submodule, reinterpreting the result as a `linear_pmap`. -/
def to_pmap {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3}
    [add_comm_group F] [module R F] (f : linear_map R E F) (p : submodule R E) :
    linear_pmap R E F :=
  linear_pmap.mk p (comp f (submodule.subtype p))

@[simp] theorem to_pmap_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_map R E F) (p : submodule R E)
    (x : ↥p) : coe_fn (to_pmap f p) x = coe_fn f ↑x :=
  rfl

/-- Compose a linear map with a `linear_pmap` -/
def comp_pmap {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3}
    [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G]
    (g : linear_map R F G) (f : linear_pmap R E F) : linear_pmap R E G :=
  linear_pmap.mk (linear_pmap.domain f) (comp g (linear_pmap.to_fun f))

@[simp] theorem comp_pmap_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E]
    [module R E] {F : Type u_3} [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G]
    [module R G] (g : linear_map R F G) (f : linear_pmap R E F)
    (x : ↥(linear_pmap.domain (comp_pmap g f))) :
    coe_fn (comp_pmap g f) x = coe_fn g (coe_fn f x) :=
  rfl

end linear_map

namespace linear_pmap

/-- Restrict codomain of a `linear_pmap` -/
def cod_restrict {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] (f : linear_pmap R E F) (p : submodule R F)
    (H : ∀ (x : ↥(domain f)), coe_fn f x ∈ p) : linear_pmap R E ↥p :=
  mk (domain f) (linear_map.cod_restrict p (to_fun f) H)

/-- Compose two `linear_pmap`s -/
def comp {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3}
    [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G]
    (g : linear_pmap R F G) (f : linear_pmap R E F)
    (H : ∀ (x : ↥(domain f)), coe_fn f x ∈ domain g) : linear_pmap R E G :=
  linear_map.comp_pmap (to_fun g) (cod_restrict f (domain g) H)

/-- `f.coprod g` is the partially defined linear map defined on `f.domain × g.domain`,
and sending `p` to `f p.1 + g p.2`. -/
def coprod {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E] {F : Type u_3}
    [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G]
    (f : linear_pmap R E G) (g : linear_pmap R F G) : linear_pmap R (E × F) G :=
  mk (submodule.prod (domain f) (domain g))
    (to_fun (comp f (linear_pmap.fst (domain f) (domain g)) sorry) +
      to_fun (comp g (linear_pmap.snd (domain f) (domain g)) sorry))

@[simp] theorem coprod_apply {R : Type u_1} [ring R] {E : Type u_2} [add_comm_group E] [module R E]
    {F : Type u_3} [add_comm_group F] [module R F] {G : Type u_4} [add_comm_group G] [module R G]
    (f : linear_pmap R E G) (g : linear_pmap R F G) (x : ↥(domain (coprod f g))) :
    coe_fn (coprod f g) x =
        coe_fn f { val := prod.fst ↑x, property := and.left (subtype.property x) } +
          coe_fn g { val := prod.snd ↑x, property := and.right (subtype.property x) } :=
  rfl

end Mathlib


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.limits
import Mathlib.category_theory.limits.shapes.default
import Mathlib.PostPort

universes u₁ u₂ v

namespace Mathlib

/-!
# Preserving terminal object

Constructions to relate the notions of preserving terminal objects and reflecting terminal objects
to concrete objects.

In particular, we show that `terminal_comparison G` is an isomorphism iff `G` preserves terminal
objects.
-/

namespace category_theory.limits

/--
The map of an empty cone is a limit iff the mapped object is terminal.
-/
def is_limit_map_cone_empty_cone_equiv {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) (X : C) : is_limit (functor.map_cone G (as_empty_cone X)) ≃ is_terminal (functor.obj G X) :=
  equiv.trans
    (equiv.symm
      (is_limit.postcompose_hom_equiv (functor.empty_ext (functor.empty C ⋙ G) (functor.empty D))
        (functor.map_cone G (as_empty_cone X))))
    (is_limit.equiv_iso_limit
      (cones.ext
        (iso.refl
          (cone.X
            (functor.obj (cones.postcompose (iso.hom (functor.empty_ext (functor.empty C ⋙ G) (functor.empty D))))
              (functor.map_cone G (as_empty_cone X)))))
        sorry))

/-- The property of preserving terminal objects expressed in terms of `is_terminal`. -/
def is_terminal_obj_of_is_terminal {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) (X : C) [preserves_limit (functor.empty C) G] (l : is_terminal X) : is_terminal (functor.obj G X) :=
  coe_fn (is_limit_map_cone_empty_cone_equiv G X) (preserves_limit.preserves l)

/-- The property of reflecting terminal objects expressed in terms of `is_terminal`. -/
def is_terminal_of_is_terminal_obj {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) (X : C) [reflects_limit (functor.empty C) G] (l : is_terminal (functor.obj G X)) : is_terminal X :=
  reflects_limit.reflects (coe_fn (equiv.symm (is_limit_map_cone_empty_cone_equiv G X)) l)

/--
If `G` preserves the terminal object and `C` has a terminal object, then the image of the terminal
object is terminal.
-/
def is_limit_of_has_terminal_of_preserves_limit {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [preserves_limit (functor.empty C) G] : is_terminal (functor.obj G (⊤_C)) :=
  is_terminal_obj_of_is_terminal G (⊤_C) terminal_is_terminal

/--
If `C` has a terminal object and `G` preserves terminal objects, then `D` has a terminal object
also.
Note this property is somewhat unique to (co)limits of the empty diagram: for general `J`, if `C`
has limits of shape `J` and `G` preserves them, then `D` does not necessarily have limits of shape
`J`.
-/
theorem has_terminal_of_has_terminal_of_preserves_limit {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [preserves_limit (functor.empty C) G] : has_terminal D :=
  has_limits_of_shape.mk fun (F : discrete pempty ⥤ D) => has_limit_of_iso (iso.symm (functor.unique_from_empty F))

/--
If the terminal comparison map for `G` is an isomorphism, then `G` preserves terminal objects.
-/
def preserves_terminal.of_iso_comparison {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [has_terminal D] [i : is_iso (terminal_comparison G)] : preserves_limit (functor.empty C) G :=
  preserves_limit_of_preserves_limit_cone terminal_is_terminal
    (coe_fn (equiv.symm (is_limit_map_cone_empty_cone_equiv G (⊤_C)))
      (is_limit.of_point_iso (limit.is_limit (functor.empty D))))

/-- If there is any isomorphism `G.obj ⊤ ⟶ ⊤`, then `G` preserves terminal objects. -/
def preserves_terminal_of_is_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [has_terminal D] (f : functor.obj G (⊤_C) ⟶ ⊤_D) [i : is_iso f] : preserves_limit (functor.empty C) G :=
  preserves_terminal.of_iso_comparison G

/-- If there is any isomorphism `G.obj ⊤ ≅ ⊤`, then `G` preserves terminal objects. -/
def preserves_terminal_of_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [has_terminal D] (f : functor.obj G (⊤_C) ≅ ⊤_D) : preserves_limit (functor.empty C) G :=
  preserves_terminal_of_is_iso G (iso.hom f)

/-- If `G` preserves terminal objects, then the terminal comparison map for `G` an isomorphism. -/
def preserves_terminal.iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [has_terminal D] [preserves_limit (functor.empty C) G] : functor.obj G (⊤_C) ≅ ⊤_D :=
  is_limit.cone_point_unique_up_to_iso (is_limit_of_has_terminal_of_preserves_limit G) (limit.is_limit (functor.empty D))

@[simp] theorem preserves_terminal.iso_hom {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [has_terminal D] [preserves_limit (functor.empty C) G] : iso.hom (preserves_terminal.iso G) = terminal_comparison G :=
  rfl

protected instance terminal_comparison.category_theory.is_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) [has_terminal C] [has_terminal D] [preserves_limit (functor.empty C) G] : is_iso (terminal_comparison G) :=
  eq.mpr sorry (is_iso.of_iso (preserves_terminal.iso G))


import
data.real.basic
data.set.basic
order.basic
topology.algebra.continuous_functions
analysis.normed_space.basic
topology.metric_space.lipschitz
tactic.tfae
order.liminf_limsup
order.complete_lattice
data.set.intervals
topology.algebra.group
order.conditionally_complete_lattice
order.complete_lattice
order.lattice
order.bounds
tactic.finish
data.nat.enat
topology.algebra.ordered
namespace lattice

lemma cSup_is_bigger {f : ℝ → ℝ} (Hf : continuous f)
 {a b : ℝ} (Hab : a < b) (K := {x : ℝ | x>=a ∧ x<b ∧ f x < 0})
 (c:= Sup K) (Hbdd: bdd_above K) (Hne: a ∈ K) :
 a <= Sup K := conditionally_complete_lattice.le_cSup K a Hbdd Hne

lemma cSup_is_smaller {f : ℝ → ℝ} (Hf : continuous f)
 {a b : ℝ} (Hab : a < b) (K := {x : ℝ | x>=a ∧ x<b ∧ f x < 0})
 (c:= Sup K) (Hbdd: b ∈ upper_bounds K) (Hne: K.nonempty) :
 Sup K <= b := conditionally_complete_lattice.cSup_le K b Hne Hbdd

lemma continuous_implies {f : ℝ → ℝ} (Hf : continuous f)
 {a b : ℝ} (Hab : a < b) (K := {x : ℝ | x>a ∧ x<b ∧ f x < 0})
 (c:= Sup K):
 f c = 0
 :=
 --having trouble proving this
 sorry

theorem intermediate_value {f : ℝ → ℝ} (Hf : continuous f)
 {a b : ℝ} (Hab : a < b)
        (Hav : f a < 0) (Hbv : f b > 0)  :
        ∃ c, a < c ∧ c < b ∧ f c = 0 :=
begin
let K := {x : ℝ | x>=a ∧ x<b ∧ f x < 0},
have Hbdd: bdd_above K, use b,
have Hne: K.nonempty, use a,
let c := Sup K,
have Hac: a < c, apply cSup_is_bigger,
--not sure how to use apply syntax, keep getting errors
have Hbc: c < b, apply cSup_is_smaller,
--same here
have c:ℝ, exact c,
have Hc: f c = 0, from continuous_implies,
end


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.vector.basic

/-!
# Small types

A type is `w`-small if there exists an equivalence to some `S : Type w`.

We provide a noncomputable model `shrink α : Type w`, and `equiv_shrink α : α ≃ shrink α`.

A subsingleton type is `w`-small for any `w`.

If `α ≃ β`, then `small.{w} α ↔ small.{w} β`.
-/

universes u w v

/--
A type is `small.{w}` if there exists an equivalence to some `S : Type w`.
-/
class small (α : Type v) : Prop :=
(equiv_small : ∃ (S : Type w), nonempty (α ≃ S))

/--
Constructor for `small α` from an explicit witness type and equivalence.
-/
lemma small.mk' {α : Type v} {S : Type w} (e : α ≃ S) : small.{w} α :=
⟨⟨S, ⟨e⟩⟩⟩

/--
An arbitrarily chosen model in `Type w` for a `w`-small type.
-/
@[nolint has_inhabited_instance]
def shrink (α : Type v) [small.{w} α] : Type w :=
classical.some (@small.equiv_small α _)

/--
The noncomputable equivalence between a `w`-small type and a model.
-/
noncomputable
def equiv_shrink (α : Type v) [small.{w} α] : α ≃ shrink α :=
nonempty.some (classical.some_spec (@small.equiv_small α _))

@[priority 100]
instance small_self (α : Type v) : small.{v} α :=
small.mk' (equiv.refl _)

@[priority 100]
instance small_max (α : Type v) : small.{max w v} α :=
small.mk' equiv.ulift.{w}.symm

instance small_ulift (α : Type v) : small.{v} (ulift.{w} α) :=
small.mk' equiv.ulift

theorem small_type : small.{max (u+1) v} (Type u) := small_max.{max (u+1) v} _

section
open_locale classical

theorem small_map {α : Type*} {β : Type*} [hβ : small.{w} β] (e : α ≃ β) : small.{w} α :=
let ⟨γ, ⟨f⟩⟩ := hβ.equiv_small in small.mk' (e.trans f)

theorem small_congr {α : Type*} {β : Type*} (e : α ≃ β) : small.{w} α ↔ small.{w} β :=
⟨λ h, @small_map _ _ h e.symm, λ h, @small_map _ _ h e⟩

instance small_subtype (α : Type v) [small.{w} α] (P : α → Prop) : small.{w} { x // P x } :=
small_map (equiv_shrink α).subtype_equiv_of_subtype'

theorem small_of_injective {α : Type v} {β : Type w} [small.{u} β] {f : α → β}
  (hf : function.injective f) : small.{u} α :=
small_map (equiv.of_injective f hf)

theorem small_of_surjective {α : Type v} {β : Type w} [small.{u} α] {f : α → β}
  (hf : function.surjective f) : small.{u} β :=
small_of_injective (function.injective_surj_inv hf)

theorem small_subset {α : Type v} {s t : set α} (hts : t ⊆ s) [small.{u} s] : small.{u} t :=
let f : t → s := λ x, ⟨x, hts x.prop⟩ in
  @small_of_injective _ _ _ f (λ x y hxy, subtype.ext (subtype.mk.inj hxy))

@[priority 100]
instance small_subsingleton (α : Type v) [subsingleton α] : small.{w} α :=
begin
  rcases is_empty_or_nonempty α; resetI,
  { apply small_map (equiv.equiv_pempty α) },
  { apply small_map equiv.punit_of_nonempty_of_subsingleton, assumption' },
end

/-!
We don't define `small_of_fintype` or `small_of_encodable` in this file,
to keep imports to `logic` to a minimum.
-/

instance small_Pi {α} (β : α → Type*) [small.{w} α] [∀ a, small.{w} (β a)] :
  small.{w} (Π a, β a) :=
⟨⟨Π a' : shrink α, shrink (β ((equiv_shrink α).symm a')),
  ⟨equiv.Pi_congr (equiv_shrink α) (λ a, by simpa using equiv_shrink (β a))⟩⟩⟩

instance small_sigma {α} (β : α → Type*) [small.{w} α] [∀ a, small.{w} (β a)] :
  small.{w} (Σ a, β a) :=
⟨⟨Σ a' : shrink α, shrink (β ((equiv_shrink α).symm a')),
  ⟨equiv.sigma_congr (equiv_shrink α) (λ a, by simpa using equiv_shrink (β a))⟩⟩⟩

instance small_prod {α β} [small.{w} α] [small.{w} β] : small.{w} (α × β) :=
⟨⟨shrink α × shrink β,
  ⟨equiv.prod_congr (equiv_shrink α) (equiv_shrink β)⟩⟩⟩

instance small_sum {α β} [small.{w} α] [small.{w} β] : small.{w} (α ⊕ β) :=
⟨⟨shrink α ⊕ shrink β,
  ⟨equiv.sum_congr (equiv_shrink α) (equiv_shrink β)⟩⟩⟩

instance small_set {α} [small.{w} α] : small.{w} (set α) :=
⟨⟨set (shrink α), ⟨equiv.set.congr (equiv_shrink α)⟩⟩⟩

instance small_range {α : Type v} {β : Type w} (f : α → β) [small.{u} α] :
  small.{u} (set.range f) :=
small_of_surjective set.surjective_onto_range

instance small_image {α : Type v} {β : Type w} (f : α → β) (S : set α) [small.{u} S] :
  small.{u} (f '' S) :=
small_of_surjective set.surjective_onto_image

theorem not_small_type : ¬ small.{u} (Type (max u v))
| ⟨⟨S, ⟨e⟩⟩⟩ := @function.cantor_injective (Σ α, e.symm α)
  (λ a, ⟨_, cast (e.3 _).symm a⟩)
  (λ a b e, (cast_inj _).1 $ eq_of_heq (sigma.mk.inj e).2)

instance small_vector {α : Type v} {n : ℕ} [small.{u} α] :
  small.{u} (vector α n) :=
small_of_injective (equiv.vector_equiv_fin α n).injective

instance small_list {α : Type v} [small.{u} α] :
  small.{u} (list α) :=
begin
  let e : (Σ n, vector α n) ≃ list α := equiv.sigma_preimage_equiv list.length,
  exact small_of_surjective e.surjective,
end

end


---- STRUCTURES IN LEAN

/--
A type is a foo if the specified axioms are satisfied:
-/
class foo (α : Type) :=
(axiom_1 : 4 = 4)
(axiom_2 : 5 = 5)

/--
Some foos are also bar if an additional axiom is satisfied:
-/
class bar (α : Type) extends foo α :=
(axiom_3 : 6 = 6)

/--
Let's prove a theorem.

Theorem: If a type α is bar it is also foo.
-/
theorem foo_of_bar (α : Type) : bar α → foo α :=
begin
    intro,
    split,
    {refl},
    {refl},
end

/--
Let's prove another theorem: If a type α is foo then 4 = 4.
-/
theorem four_eq_four_of_foo (α : Type) : foo α → 4 = 4 :=
begin
    intro,
    exact a.axiom_1,
end


-- 2018-01-04
-- Erik Dominikus

-- These are the definitions required to state the things we want to prove.

definition Cont (r : Type) (a : Type) : Type := (a → r) → r

structure Functor (m : Type → Type) : Type 1 := mk ::
    (map : Π {a b}, (a → b) → m a → m b)
    (pure : Π {a}, a → m a)
    (p0 : Π {a}, @map a a id = id)
    (p1 : Π {a b c} (f : b → c) (g : a → b), map (f ∘ g) = map f ∘ map g)
    (p2 : Π {a b} (f : a → b) x, map f (pure x) = pure (f x))

structure Monad (m : Type → Type) : Type 1 := mk ::
    (functor : Functor m)
    (join : Π {a}, m (m a) → m a)

definition Monad.pure : Π {m a}, Monad m → (a → m a) := λ _ _ mi, Functor.pure (Monad.functor mi)

definition instance_Functor_Cont (r) : Functor (λ a, Cont r a) := {
    map := λ a b (f : a → b) (ma : (a → r) → r), λ (c : b → r), begin
        let d : a → r := λ x, c (f x),
        exact ma d
    end,
    pure := λ _ x, λ c, c x,
    p0 := begin intros, refl end,
    p1 := begin intros, refl end,
    p2 := begin intros, simp end,
}

definition instance_Monad_Cont : Π {r}, Monad (Cont r) := λ r, {
    functor := instance_Functor_Cont r,
    join := λ a (m : (((a → r) → r) → r) → r), begin
        intro c0,
        let d0 : ((a → r) → r) → r := λ c1, c1 c0,
        exact m d0
    end,
}

definition sum.map_both {a b c d} (f : a → c) (g : b → d) (s : a ⊕ b) : c ⊕ d := match s with
| sum.inl x := sum.inl (f x)
| sum.inr x := sum.inr (g x)
end

-- Hom_1 and Hom_2 are the statements we want to prove.

definition Hom_1 (f : Type → Type) := Π {a : Type}, (Π {m}, Monad m → f (m a)) → (Π {r : Type}, f (Cont r a))
definition Hom_2 (f : Type → Type) := Π {a : Type}, (Π {r : Type}, f (Cont r a)) → (Π {m}, Monad m → f (m a))

-- This is a proof of Hom_1.

theorem hom_1_trivial (f : Type → Type) : Hom_1 f :=
begin
    intros a hm r,
    let m := Cont r,
    let j := hm instance_Monad_Cont,
    exact j
end

-- Here we tell Lean how to construct a Haskell 98 type endofunction.

-- This describes all the possible ways to construct a rank-1 (Haskell 98) type endofunction.
-- See `render` for what this represents.
inductive endo
| con : Π {t : Type}, t → endo -- c, and proof of inhabitedness
| var : endo -- a (the only type variable in a rank-1 type endofunction body)
| arr : endo → endo → endo
| prod : endo → endo → endo
| sum : endo → endo → endo

-- `render e` is the type endofunction represented by `e`.
definition render : endo → (Type → Type)
| (@endo.con c _) := λ t, c
| (endo.var) := λ t, t
| (endo.arr a b) := λ t, render a t → render b t
| (endo.prod a b) := λ t, render a t × render b t
| (endo.sum a b) := λ t, render a t ⊕ render b t

-- This is used in the theorem `hom_2`.
-- `lem_render_m_to_cont` enables us to transform `m t` to `Cont (m t) t`.
-- `lem_render_cont_to_m` enables us to transform `Cont (m t)` t to `m t`.
mutual lemma lem_render_m_to_cont, lem_render_cont_to_m with
lem_render_m_to_cont : Π (a : endo) (m : Type → Type) (mi : Monad m) t (ra : render a (m t)), render a (Cont (m t) t)
| (@endo.con c i) := begin intros, exact i end
| (endo.var) := begin intros, intros c, exact ra end
| (endo.arr u v) := begin intros,
    let ra0 : render u (m t) → render v (m t) := ra,
    have goal : render u (Cont (m t) t) → render v (Cont (m t) t) := begin
        intros ru,
        apply lem_render_m_to_cont v m mi t,
        apply ra0,
        apply lem_render_cont_to_m u m mi t,
        exact ru
    end,
    exact goal
end
| (endo.prod u v) := begin intros,
    apply @prod.map (render u (m t)) (render u (Cont (m t) t)) (render v (m t)) (render v (Cont (m t) t)),
    apply lem_render_m_to_cont u m mi t,
    apply lem_render_m_to_cont v m mi t,
    exact ra
end
| (endo.sum u v) := begin intros,
    apply @sum.map_both (render u (m t)) (render v (m t)) (render u (Cont (m t) t)) (render v (Cont (m t) t)),
    apply lem_render_m_to_cont u m mi t,
    apply lem_render_m_to_cont v m mi t,
    exact ra
end
with lem_render_cont_to_m : Π a (m : Type → Type) (mi : Monad m) t (ra : render a (Cont (m t) t)), render a (m t)
| (@endo.con c i) := begin intros, exact i end
| (endo.var) := begin intros, exact ra (Monad.pure mi) end
| (endo.arr u v) := begin intros,
    let ra0 : render u (Cont (m t) t) → render v (Cont (m t) t) := ra,
    have goal : render u (m t) → render v (m t) := begin
        intros ru,
        apply lem_render_cont_to_m v m mi t,
        apply ra0,
        apply lem_render_m_to_cont u m mi t,
        exact ru
    end,
    exact goal
end
| (endo.prod u v) := begin intros,
    apply @prod.map (render u (Cont (m t) t)) (render u (m t)) (render v (Cont (m t) t)) (render v (m t)),
    apply lem_render_cont_to_m u m mi t,
    apply lem_render_cont_to_m v m mi t,
    exact ra
end
| (endo.sum u v) := begin intros,
    apply @sum.map_both (render u (Cont (m t) t)) (render v (Cont (m t) t)) (render u (m t)) (render v (m t)),
    apply lem_render_cont_to_m u m mi t,
    apply lem_render_cont_to_m v m mi t,
    exact ra
end

-- This is the proposed proof of the non-trivial part of Abdullah conjecture for all Haskell 98 type endofunctions.

theorem hom_2 : Π (e : endo), Hom_2 (render e)
| (@endo.con c i) := begin intros t h m mi, exact i end
| (endo.var) := begin intros t h m mi, exact @h (m t) (Monad.pure mi) end
| (endo.arr u v) := begin intros t h m mi,
    have goal : render u (m t) → render v (m t) := begin
        intros ru,
        apply lem_render_cont_to_m v m mi t,
        let hh : render u (Cont (m t) t) → render v (Cont (m t) t) := @h (m t),
        apply hh,
        apply lem_render_m_to_cont u m mi t,
        exact ru
    end,
    exact goal
end
| (endo.prod u v) := begin intros t h m mi,
    apply @prod.map (render u (Cont (m t) t)) (render u (m t)) (render v (Cont (m t) t)) (render v (m t)),
    exact lem_render_cont_to_m u m mi t,
    exact lem_render_cont_to_m v m mi t,
    exact @h (m t)
end
| (endo.sum u v) := begin intros t h m mi,
    apply @sum.map_both (render u (Cont (m t) t)) (render v (Cont (m t) t)) (render u (m t)) (render v (m t)),
    exact lem_render_cont_to_m u m mi t,
    exact lem_render_cont_to_m v m mi t,
    exact @h (m t)
end