/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Yury Kudryashov, Neil Strickland

! This file was ported from Lean 3 source module algebra.ring.regular
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Regular.Basic
import Mathbin.Algebra.Ring.Defs

/-!
# Lemmas about regular elements in rings.

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

variable {α : Type _}

/- warning: is_left_regular_of_non_zero_divisor -> isLeftRegular_of_non_zero_divisor is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : NonUnitalNonAssocRing.{u1} α] (k : α), (forall (x : α), (Eq.{succ u1} α (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))) k x) (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))))))) -> (Eq.{succ u1} α x (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))))))) -> (IsLeftRegular.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))) k)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : NonUnitalNonAssocRing.{u1} α] (k : α), (forall (x : α), (Eq.{succ u1} α (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_1)) k x) (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))))) -> (Eq.{succ u1} α x (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))))))) -> (IsLeftRegular.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_1) k)
Case conversion may be inaccurate. Consider using '#align is_left_regular_of_non_zero_divisor isLeftRegular_of_non_zero_divisorₓ'. -/
/-- Left `mul` by a `k : α` over `[ring α]` is injective, if `k` is not a zero divisor.
The typeclass that restricts all terms of `α` to have this property is `no_zero_divisors`. -/
theorem isLeftRegular_of_non_zero_divisor [NonUnitalNonAssocRing α] (k : α)
    (h : ∀ x : α, k * x = 0 → x = 0) : IsLeftRegular k :=
  by
  refine' fun x y (h' : k * x = k * y) => sub_eq_zero.mp (h _ _)
  rw [mul_sub, sub_eq_zero, h']
#align is_left_regular_of_non_zero_divisor isLeftRegular_of_non_zero_divisor

/- warning: is_right_regular_of_non_zero_divisor -> isRightRegular_of_non_zero_divisor is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : NonUnitalNonAssocRing.{u1} α] (k : α), (forall (x : α), (Eq.{succ u1} α (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))) x k) (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))))))) -> (Eq.{succ u1} α x (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))))))) -> (IsRightRegular.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))) k)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : NonUnitalNonAssocRing.{u1} α] (k : α), (forall (x : α), (Eq.{succ u1} α (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_1)) x k) (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))))) -> (Eq.{succ u1} α x (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))))))) -> (IsRightRegular.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_1) k)
Case conversion may be inaccurate. Consider using '#align is_right_regular_of_non_zero_divisor isRightRegular_of_non_zero_divisorₓ'. -/
/-- Right `mul` by a `k : α` over `[ring α]` is injective, if `k` is not a zero divisor.
The typeclass that restricts all terms of `α` to have this property is `no_zero_divisors`. -/
theorem isRightRegular_of_non_zero_divisor [NonUnitalNonAssocRing α] (k : α)
    (h : ∀ x : α, x * k = 0 → x = 0) : IsRightRegular k :=
  by
  refine' fun x y (h' : x * k = y * k) => sub_eq_zero.mp (h _ _)
  rw [sub_mul, sub_eq_zero, h']
#align is_right_regular_of_non_zero_divisor isRightRegular_of_non_zero_divisor

/- warning: is_regular_of_ne_zero' -> isRegular_of_ne_zero' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : NonUnitalNonAssocRing.{u1} α] [_inst_2 : NoZeroDivisors.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))) (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))] {k : α}, (Ne.{succ u1} α k (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))))))) -> (IsRegular.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1))) k)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : NonUnitalNonAssocRing.{u1} α] [_inst_2 : NoZeroDivisors.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_1) (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))] {k : α}, (Ne.{succ u1} α k (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_1)))))) -> (IsRegular.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_1) k)
Case conversion may be inaccurate. Consider using '#align is_regular_of_ne_zero' isRegular_of_ne_zero'ₓ'. -/
theorem isRegular_of_ne_zero' [NonUnitalNonAssocRing α] [NoZeroDivisors α] {k : α} (hk : k ≠ 0) :
    IsRegular k :=
  ⟨isLeftRegular_of_non_zero_divisor k fun x h =>
      (NoZeroDivisors.eq_zero_or_eq_zero_of_mul_eq_zero h).resolve_left hk,
    isRightRegular_of_non_zero_divisor k fun x h =>
      (NoZeroDivisors.eq_zero_or_eq_zero_of_mul_eq_zero h).resolve_right hk⟩
#align is_regular_of_ne_zero' isRegular_of_ne_zero'

/- warning: is_regular_iff_ne_zero' -> isRegular_iff_ne_zero' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Nontrivial.{u1} α] [_inst_2 : NonUnitalNonAssocRing.{u1} α] [_inst_3 : NoZeroDivisors.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_2))) (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_2)))] {k : α}, Iff (IsRegular.{u1} α (Distrib.toHasMul.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_2))) k) (Ne.{succ u1} α k (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_2)))))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Nontrivial.{u1} α] [_inst_2 : NonUnitalNonAssocRing.{u1} α] [_inst_3 : NoZeroDivisors.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_2) (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_2)))] {k : α}, Iff (IsRegular.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α _inst_2) k) (Ne.{succ u1} α k (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (MulZeroClass.toZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α _inst_2))))))
Case conversion may be inaccurate. Consider using '#align is_regular_iff_ne_zero' isRegular_iff_ne_zero'ₓ'. -/
theorem isRegular_iff_ne_zero' [Nontrivial α] [NonUnitalNonAssocRing α] [NoZeroDivisors α] {k : α} :
    IsRegular k ↔ k ≠ 0 :=
  ⟨fun h => by
    rintro rfl
    exact not_not.mpr h.left not_isLeftRegular_zero, isRegular_of_ne_zero'⟩
#align is_regular_iff_ne_zero' isRegular_iff_ne_zero'

/- warning: no_zero_divisors.to_cancel_monoid_with_zero -> NoZeroDivisors.toCancelMonoidWithZero is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Ring.{u1} α] [_inst_2 : NoZeroDivisors.{u1} α (Distrib.toHasMul.{u1} α (Ring.toDistrib.{u1} α _inst_1)) (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α (NonAssocRing.toNonUnitalNonAssocRing.{u1} α (Ring.toNonAssocRing.{u1} α _inst_1)))))], CancelMonoidWithZero.{u1} α
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Ring.{u1} α] [_inst_2 : NoZeroDivisors.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α (NonAssocRing.toNonUnitalNonAssocRing.{u1} α (Ring.toNonAssocRing.{u1} α _inst_1))) (MonoidWithZero.toZero.{u1} α (Semiring.toMonoidWithZero.{u1} α (Ring.toSemiring.{u1} α _inst_1)))], CancelMonoidWithZero.{u1} α
Case conversion may be inaccurate. Consider using '#align no_zero_divisors.to_cancel_monoid_with_zero NoZeroDivisors.toCancelMonoidWithZeroₓ'. -/
/-- A ring with no zero divisors is a `cancel_monoid_with_zero`.

Note this is not an instance as it forms a typeclass loop. -/
@[reducible]
def NoZeroDivisors.toCancelMonoidWithZero [Ring α] [NoZeroDivisors α] : CancelMonoidWithZero α :=
  {
    (by infer_instance :
      MonoidWithZero
        α) with
    mul_left_cancel_of_ne_zero := fun a b c ha =>
      @IsRegular.left _ _ _ (isRegular_of_ne_zero' ha) _ _
    mul_right_cancel_of_ne_zero := fun a b c hb =>
      @IsRegular.right _ _ _ (isRegular_of_ne_zero' hb) _ _ }
#align no_zero_divisors.to_cancel_monoid_with_zero NoZeroDivisors.toCancelMonoidWithZero

/- warning: no_zero_divisors.to_cancel_comm_monoid_with_zero -> NoZeroDivisors.toCancelCommMonoidWithZero is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CommRing.{u1} α] [_inst_2 : NoZeroDivisors.{u1} α (Distrib.toHasMul.{u1} α (Ring.toDistrib.{u1} α (CommRing.toRing.{u1} α _inst_1))) (MulZeroClass.toHasZero.{u1} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} α (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} α (NonAssocRing.toNonUnitalNonAssocRing.{u1} α (Ring.toNonAssocRing.{u1} α (CommRing.toRing.{u1} α _inst_1))))))], CancelCommMonoidWithZero.{u1} α
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CommRing.{u1} α] [_inst_2 : NoZeroDivisors.{u1} α (NonUnitalNonAssocRing.toMul.{u1} α (NonAssocRing.toNonUnitalNonAssocRing.{u1} α (Ring.toNonAssocRing.{u1} α (CommRing.toRing.{u1} α _inst_1)))) (CommMonoidWithZero.toZero.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)))], CancelCommMonoidWithZero.{u1} α
Case conversion may be inaccurate. Consider using '#align no_zero_divisors.to_cancel_comm_monoid_with_zero NoZeroDivisors.toCancelCommMonoidWithZeroₓ'. -/
/-- A commutative ring with no zero divisors is a `cancel_comm_monoid_with_zero`.

Note this is not an instance as it forms a typeclass loop. -/
@[reducible]
def NoZeroDivisors.toCancelCommMonoidWithZero [CommRing α] [NoZeroDivisors α] :
    CancelCommMonoidWithZero α :=
  { NoZeroDivisors.toCancelMonoidWithZero, (by infer_instance : CommMonoidWithZero α) with }
#align no_zero_divisors.to_cancel_comm_monoid_with_zero NoZeroDivisors.toCancelCommMonoidWithZero

section IsDomain

#print IsDomain.toCancelMonoidWithZero /-
-- see Note [lower instance priority]
instance (priority := 100) IsDomain.toCancelMonoidWithZero [Semiring α] [IsDomain α] :
    CancelMonoidWithZero α :=
  { Semiring.toMonoidWithZero α, ‹IsDomain α› with }
#align is_domain.to_cancel_monoid_with_zero IsDomain.toCancelMonoidWithZero
-/

variable [CommSemiring α] [IsDomain α]

#print IsDomain.toCancelCommMonoidWithZero /-
-- see Note [lower instance priority]
instance (priority := 100) IsDomain.toCancelCommMonoidWithZero : CancelCommMonoidWithZero α :=
  { ‹CommSemiring α›, ‹IsDomain α› with }
#align is_domain.to_cancel_comm_monoid_with_zero IsDomain.toCancelCommMonoidWithZero
-/

end IsDomain


import topology.continuous_function.algebra
import data.int.interval
import ring_theory.finiteness
import linear_algebra.free_module.finite.basic

import for_mathlib.nnrat
import for_mathlib.rational_cones

/-!

# Gordan's Lemma

-/

universe u
variables {Λ : Type u} [add_comm_group Λ]
variable {ι : Type*}

open_locale big_operators
open_locale nnreal

def explicit_dual_set (l : ι → Λ) : submodule ℕ (Λ →+ ℤ) :=
{ carrier := {x | ∀ i, 0 ≤ x (l i)},
  zero_mem' := λ i, le_rfl,
  add_mem' := λ x y hx hy i, add_nonneg (hx i) (hy i),
  smul_mem' := λ n x hx i, nsmul_nonneg (hx i) n }

lemma mem_explicit_dual_set (l : ι → Λ) (x : Λ →+ ℤ) :
  x ∈ explicit_dual_set l ↔ ∀ i, 0 ≤ x (l i) := iff.rfl

def dual_finset (S : finset Λ) : submodule ℕ (Λ →+ ℤ) :=
explicit_dual_set (coe : (S : set Λ) → Λ)

lemma mem_dual_finset (S : finset Λ) (l : Λ →+ ℤ) :
  l ∈ dual_finset S ↔ ∀ x ∈ S, 0 ≤ l x :=
begin
  rw [dual_finset, mem_explicit_dual_set],
  simp
end

lemma dual_finset_antimono {S T : finset Λ} (hST : S ⊆ T) :
  dual_finset T ≤ dual_finset S :=
begin
  rintro φ hφ ⟨i, his : i ∈ S⟩,
  exact hφ ⟨i, hST his⟩,
end

lemma explicit_dual_set_eq_dual_finset [decidable_eq Λ] [fintype ι] (l : ι → Λ) :
  explicit_dual_set l = dual_finset (finset.image l finset.univ) :=
begin
  ext φ,
  split,
  { rintro hφ ⟨t, ht : t ∈ finset.image _ _⟩,
    rw finset.mem_image at ht,
    rcases ht with ⟨i, -, rfl⟩,
    exact hφ i },
  { rintro hφ i,
    refine hφ ⟨l i, (_ : l i ∈ finset.image _ _)⟩,
    rw finset.mem_image,
    exact ⟨i, finset.mem_univ _, rfl⟩ }
end

def intersect_halfspaces (l : ι → Λ →+ ℤ) : submodule ℕ Λ :=
{ carrier := {x | ∀ i, 0 ≤ l i x},
  zero_mem' := λ i, by simp only [add_monoid_hom.map_zero],
  add_mem' := λ x y hx hy i,
  begin
    simp only [add_monoid_hom.map_add],
    apply add_nonneg (hx i) (hy i)
  end,
  smul_mem' := λ c x hx i,
  begin
    simp only [nsmul_eq_mul, int.nat_cast_eq_coe_nat, add_monoid_hom.map_nsmul],
    apply mul_nonneg (int.coe_zero_le c) (hx i),
  end }

lemma mem_intersect_halfspaces (l : ι → Λ →+ ℤ) (x : Λ) :
  x ∈ intersect_halfspaces l ↔ ∀ i, 0 ≤ l i x := iff.rfl

def intersect_halfspaces_set (s : set (Λ →+ ℤ)) : submodule ℕ Λ :=
intersect_halfspaces (coe : (s : set (Λ →+ ℤ)) → (Λ →+ ℤ))

lemma mem_intersect_halfspaces_set (S : set (Λ →+ ℤ)) (x : Λ) :
  x ∈ intersect_halfspaces_set S ↔ ∀ (f : Λ →+ ℤ), f ∈ S → 0 ≤ f x :=
begin
  rw [intersect_halfspaces_set, mem_intersect_halfspaces],
  simp
end

variables {α : Type*}

def to_rational_point : (α → ℤ) →ₗ[ℤ] (α → ℚ) :=
{ to_fun := λ f x, f x,
  map_add' := λ f g, by { ext1 x, simp only [int.cast_add, pi.add_apply] },
  map_smul' := λ m f, by { ext1 x, simp, } }

@[simp] lemma to_rational_point_apply (x : α → ℤ) (i : α) :
  to_rational_point x i = x i := rfl

lemma to_rational_point_injective : function.injective (to_rational_point : (α → ℤ) → (α → ℚ)) :=
begin
  intros x y h,
  ext i,
  rw function.funext_iff at h,
  specialize h i,
  simpa using h
end

def lattice_restrict (S : submodule ℚ≥0 (α → ℚ)) : submodule ℕ (α → ℤ) :=
{ carrier := to_rational_point ⁻¹' (S : set (α → ℚ)),
  zero_mem' :=
    by simp only [linear_map.map_zero, set.mem_preimage, set_like.mem_coe, submodule.zero_mem],
  add_mem' := λ a b (ha : to_rational_point a ∈ S) (hb : to_rational_point b ∈ S),
  begin
    change to_rational_point (a + b) ∈ S,
    simp only [linear_map.map_add],
    apply S.add_mem ha hb,
  end,
  smul_mem' := λ c x (hx : to_rational_point x ∈ S),
  begin
    change to_rational_point (c • x) ∈ S,
    rw linear_map.map_smul_of_tower,
    exact submodule.smul_of_tower_mem S c hx,
  end }

lemma mem_lattice_restrict (S : submodule (ℚ≥0) (α → ℚ)) (x : α → ℤ) :
  x ∈ lattice_restrict S ↔ to_rational_point x ∈ S :=
iff.rfl

def is_integer (x : ℚ) := ∃ (z : ℤ), x = z
def is_integer_point (x : α → ℚ) := ∀ a, is_integer (x a)

def floor_point (x : α → ℚ) : α → ℤ := λ i, ⌊x i⌋
lemma floor_point_eq_of_is_integer_point (x : α → ℚ) (hx : is_integer_point x) :
  (λ i, floor_point x i : α → ℚ) = x :=
begin
  ext1 i,
  obtain ⟨z, hz⟩ := hx i,
  simp [floor_point, hz],
end

lemma exists_scalings {ι : Type*} (s : finset ι) (v : ι → ℚ) :
  ∃ (n : ℕ), 0 < n ∧ ∀ i ∈ s, is_integer (n • v i) :=
begin
  classical,
  apply finset.induction_on s,
  { exact ⟨1, by norm_num, by simp⟩ },
  { rintro x s hx ⟨m, hm₁, hm₂⟩,
    refine ⟨m * (v x).denom, mul_pos hm₁ (v x).pos, _⟩,
    simp only [forall_eq_or_imp, nsmul_eq_mul, finset.mem_insert, nat.cast_mul],
    refine ⟨⟨m * (v x).num, _⟩, _⟩,
    { push_cast,
      rw mul_assoc,
      norm_cast,
      rw [mul_comm ((v x).denom : ℚ), rat.mul_denom_eq_num],
      norm_cast },
    intros y hy,
    obtain ⟨z, hz⟩ := hm₂ y hy,
    rw mul_right_comm,
    refine ⟨z * (v x).denom, _⟩,
    push_cast,
    rw ←hz,
    simp }
end

lemma point_exists_scaling {α : Type*} [fintype α] (x : α → ℚ) :
  ∃ (n : ℕ), 0 < n ∧ is_integer_point ((n) • x) :=
let ⟨m, hm₁, hm₂⟩ := exists_scalings finset.univ x in ⟨m, hm₁, λ a, by simpa using hm₂ a⟩

open_locale classical

noncomputable def scale_factor {α : Type*} [fintype α] (x : α → ℚ) : ℕ :=
nat.find (point_exists_scaling x)

lemma scale_factor_pos {α : Type*} [fintype α] (x : α → ℚ) : 0 < scale_factor x :=
(nat.find_spec (point_exists_scaling x)).1

lemma rat_scale_factor_ne_zero {α : Type*} [fintype α] (x : α → ℚ) :
  (scale_factor x : ℚ) ≠ 0 :=
begin
  norm_cast,
  apply (scale_factor_pos x).ne',
end

noncomputable def scale_up {α : Type*} [fintype α] (x : α → ℚ) : α → ℤ :=
floor_point (scale_factor x • x)

lemma scale_up_is {α : Type*} [fintype α] (x : α → ℚ) :
  (λ (i : α), ↑(scale_up x i)) = scale_factor x • x :=
floor_point_eq_of_is_integer_point _ (nat.find_spec (point_exists_scaling x)).2

lemma scale_up_coord {α : Type*} [fintype α] (x : α → ℚ) (a : α) :
  (scale_up x a : ℚ) = scale_factor x * x a :=
begin
  suffices : (scale_up x a : ℚ) = (scale_factor x • x) a,
  { simpa using this },
  rw ←scale_up_is,
end

lemma to_rational_point_scale_up {α : Type*} [fintype α] (x : α → ℚ) :
  to_rational_point (scale_up x) = scale_factor x • x :=
begin
  ext1 i,
  simp [scale_up_coord],
end

example {a b : ℤ} : (a : ℚ) = b → a = b :=
λ h, (rat.coe_int_inj a b).mp h

noncomputable def upgrade_functional {α : Type*} [fintype α] (f : (α → ℤ) →+ ℤ) : (α → ℚ) →ₗ[ℚ] ℚ :=
{ to_fun := λ g, (f (scale_up g) : ℚ) / scale_factor g,
  map_add' := λ g₁ g₂,
  begin
    field_simp [rat_scale_factor_ne_zero],
    norm_cast,
    suffices : f ((scale_factor g₁ * scale_factor g₂) • scale_up (g₁ + g₂)) =
      f (scale_factor (g₁ + g₂) • (scale_factor g₂ • scale_up g₁ + scale_factor g₁ • scale_up g₂)),
    { simp only [add_monoid_hom.map_nsmul, add_monoid_hom.map_add] at this,
      simp only [nsmul_eq_mul, int.nat_cast_eq_coe_nat, mul_comm _ (f _)] at this,
      rw this,
      apply mul_comm },
    congr' 1,
    ext1 a,
    simp only [pi.add_apply, pi.smul_apply],
    simp only [nsmul_eq_mul, int.nat_cast_eq_coe_nat, int.coe_nat_mul, mul_add],
    rw ←rat.coe_int_inj,
    push_cast,
    simp only [scale_up_coord, pi.add_apply],
    ring!,
  end,
  map_smul' := λ m x,
  begin
    simp only [algebra.id.smul_eq_mul],
    rw ←rat.num_div_denom m,
    field_simp [rat_scale_factor_ne_zero, m.pos.ne', -rat.num_div_denom],
    simp only [rat.num_div_denom],
    norm_cast,
    suffices :
      f ((m.denom * scale_factor x) • scale_up (m • x)) =
        f ((scale_factor (m • x) * m.num : ℤ) • scale_up x),
    { simp only [add_monoid_hom.map_zsmul, add_monoid_hom.map_nsmul] at this,
      simp only [int.coe_nat_mul],
      simp only [algebra.id.smul_eq_mul, rat.num_div_denom, nsmul_eq_mul, int.nat_cast_eq_coe_nat,
        int.coe_nat_mul] at this,
      rw [mul_comm (f _), this, mul_comm _ m.num, mul_right_comm] },
    congr' 1,
    ext1 a,
    simp only [pi.smul_apply],
    simp only [algebra.id.smul_eq_mul, nsmul_eq_mul, int.nat_cast_eq_coe_nat, int.coe_nat_mul],
    rw ←rat.coe_int_inj,
    push_cast,
    simp only [scale_up_coord, pi.smul_apply, algebra.id.smul_eq_mul, ←rat.mul_denom_eq_num],
    ring!,
  end }.

lemma thingy {R : Type*} [semiring R] (t : ℕ) (a : α) : (t : R) = (coe t : α → R) a :=
begin
  simp only [pi.coe_nat],
  -- simp only [int.nat_cast_eq_coe_nat, pi.coe_nat],
end

lemma thingy' (t : ℕ) (a : α) : (t : ℤ) = (coe t : α → ℤ) a :=
begin
  simp only [int.nat_cast_eq_coe_nat, pi.coe_nat],
end

lemma upgrade_id {α : Type*} [fintype α] (f : (α → ℤ) →+ ℤ) (g : α → ℤ) :
  upgrade_functional f (to_rational_point g) = f g :=
begin
  dsimp [upgrade_functional, to_rational_point],
  rw div_eq_iff (rat_scale_factor_ne_zero _),
  norm_cast,
  rw [mul_comm, ←int.nat_cast_eq_coe_nat, ←nsmul_eq_mul, ←add_monoid_hom.map_nsmul],
  congr' 1,
  ext a,
  simp only [nsmul_eq_mul, pi.mul_apply],
  rw ←rat.coe_int_inj,
  rw scale_up_coord,
  norm_cast,
  congr' 1,
  apply thingy',
end

section

lemma finitely_generated_iff_integrally_generated [fintype α] (C : submodule (ℚ≥0) (α → ℚ)) :
  C.fg ↔ ∃ S : finset (α → ℤ), submodule.span (ℚ≥0) (S.image to_rational_point : set (α → ℚ)) = C :=
begin
  split,
  { rintro ⟨S, rfl⟩,
    refine ⟨S.image scale_up, _⟩,
    apply le_antisymm,
    { rw submodule.span_le,
      intros x,
      simp only [to_rational_point_scale_up, and_imp, set.mem_image, finset.mem_coe,
        exists_exists_and_eq_and, set_like.mem_coe, exists_imp_distrib, finset.coe_image],
      rintro y hy rfl,
      have : y ∈ submodule.span (ℚ≥0) (S : set (α → ℚ)) := submodule.subset_span hy,
      have z := submodule.smul_mem _ (scale_factor y : ℚ≥0) this,
      convert z using 1,
      ext1 i,
      simp only [nsmul_eq_mul, pi.smul_apply],
      change _ = _ * _,
      congr' 1,
      simp },
    { rw submodule.span_le,
      intros x,
      simp only [set_like.mem_coe, finset.mem_coe, finset.coe_image, ←set.image_comp],
      intro hx,
      have : scale_factor x • x ∈ ((to_rational_point ∘ scale_up) '' (S : set (α → ℚ))),
      { refine ⟨_, hx, _⟩,
        simp only [nsmul_eq_mul, function.comp_app, to_rational_point_scale_up] },
      have : scale_factor x • x ∈
        submodule.span ℚ≥0 (to_rational_point ∘ scale_up '' (S : set (α → ℚ))) :=
        submodule.subset_span this,
      have hx₂ := submodule.smul_mem _ ((scale_factor x)⁻¹ : ℚ≥0) this,
      convert hx₂ using 1,
      ext1 i,
      simp only [nsmul_eq_mul, pi.mul_apply, pi.smul_apply],
      change _ = _ * (_ * _),
      simp,
      rw ←mul_assoc,
      convert (one_mul (x i)).symm,
      convert inv_mul_cancel _,
      apply (thingy _ _).symm,
      apply rat_scale_factor_ne_zero } },
  { rintro ⟨S, rfl⟩,
    refine ⟨_, rfl⟩ }
end.

lemma finitely_generated_iff_integrally_generated_type {α : Type u} [fintype α]
  (C : submodule (ℚ≥0) (α → ℚ)) :
  C.fg ↔ ∃ (ι : Type u) (s : finset ι) (v : ι → α → ℤ) (hv : function.injective v),
    submodule.span (ℚ≥0) (s.image (λ i, to_rational_point (v i)) : set (α → ℚ)) = C :=
begin
  rw finitely_generated_iff_integrally_generated,
  split,
  { rintro ⟨S, rfl⟩,
    refine ⟨_, S, id, λ _ _ h, h, rfl⟩ },
  { rintro ⟨ι, s, v, _, rfl⟩,
    refine ⟨s.image v, _⟩,
    rw finset.image_image }
end

lemma bounded_lattice_thing [fintype α] {k : α → ℕ} (C : set (α → ℤ))
  (hC : ∀ (x : α → ℤ) i, x ∈ C → int.nat_abs (x i) ≤ k i) : C.finite :=
begin
  classical,
  let C' : finset (α → ℤ) :=
    (finset.univ.pi (λ i, finset.Ico (-(k i : ℤ)) (k i+1))).image (λ f a, f a (finset.mem_univ _)),
  have : C ⊆ C',
  { intros x hx,
    simp only [set.mem_image, finset.mem_univ, finset.mem_pi, forall_true_left, finset.mem_coe,
      finset.mem_Ico, finset.coe_image],
    refine ⟨λ a _, x a, λ a, _, _⟩,
    { have : abs (x a) ≤ k a,
      { rw int.abs_eq_nat_abs,
        exact_mod_cast hC x a hx },
      rw abs_le at this,
      refine ⟨this.1, _⟩,
      rw int.lt_add_one_iff,
      apply this.2 },
    refl },
  apply set.finite.subset _ this,
  exact finset.finite_to_set C',
end

lemma finset.sum_nat_abs_le {ι : Type*} (s : finset ι) (f : ι → ℤ) :
  (∑ i in s, f i).nat_abs ≤ ∑ i in s, (f i).nat_abs :=
finset.le_sum_of_subadditive _ rfl int.nat_abs_add_le _ _

lemma floor_add_floor_le {α : Type*} [linear_ordered_ring α] [floor_ring α] (x y : α) :
  ⌊x⌋ + ⌊y⌋ ≤ ⌊x + y⌋ :=
begin
  rw [int.le_floor, int.cast_add],
  apply add_le_add (int.floor_le x) (int.floor_le y),
end

lemma finset.floor_le {α : Type*} [linear_ordered_ring α] [floor_ring α] {ι : Type*} (s : finset ι)
  (f : ι → α) :
  ∑ i in s, ⌊f i⌋ ≤ ⌊∑ i in s, f i⌋ :=
begin
  apply finset.induction_on s,
  { simp },
  { intros i s hi ih,
    rw [finset.sum_insert hi, finset.sum_insert hi],
    apply le_trans (add_le_add_left ih _) (floor_add_floor_le _ _) }
end

lemma ceil_add_le {α : Type*} [linear_ordered_ring α] [floor_ring α] (x y : α) :
  ⌈x + y⌉ ≤ ⌈x⌉ + ⌈y⌉ :=
begin
  rw [int.ceil_le, int.cast_add],
  apply add_le_add (int.le_ceil x) (int.le_ceil y),
end

lemma finset.le_ceil {α : Type*} [linear_ordered_ring α] [floor_ring α] {ι : Type*} (s : finset ι)
  (f : ι → α) :
  ⌈∑ i in s, f i⌉ ≤ ∑ i in s, ⌈f i⌉ :=
finset.le_sum_of_subadditive _ (by simp) ceil_add_le _ _

lemma nat_abs_lt_nat_abs_of_nonneg_of_lt {a b : ℤ} (w₁ : 0 ≤ a) (w₂ : a < b) :
  a.nat_abs < b.nat_abs :=
begin
  lift b to ℕ using le_trans w₁ (le_of_lt w₂),
  lift a to ℕ using w₁,
  simpa using w₂,
end

lemma int.coe_sum {α : Type*} (f : α → ℕ) (s : finset α) :
  ∑ (x : α) in s, (f x : ℤ) = (↑∑ i in s, f i : ℤ) :=
begin
  apply finset.induction_on s,
  { simp },
  { intros i t hi ih,
    simp only [finset.sum_insert hi, ih],
    simp }
end

lemma finset.mem_span_iff {R M : Type*} [ring R] [add_comm_monoid M] [module R M] (S : finset M)
  (x : M) :
  x ∈ submodule.span R (S : set M) ↔ ∃ (w : M → R), ∑ i in S, w i • i = x :=
begin
  exact mem_span_finset
end

set_option pp.proofs true

lemma missing [fintype α] (w : α → ℤ) (n : ℕ) :
  to_rational_point (n • w) = (n : ℚ≥0) • to_rational_point w :=
begin
  simp only [nsmul_eq_mul],
  induction n,
  { simp },
  { simp [add_smul, ←n_ih, add_mul],  },
end

lemma my_result [fintype α] (C : submodule (ℚ≥0) (α → ℚ)) (hC : C.fg) :
  (lattice_restrict C).fg :=
begin
  rw finitely_generated_iff_integrally_generated_type at hC,
  rcases hC with ⟨ι, s, w, hw, rfl⟩,
  let B := {x : α → ℤ |
                ∃ w' : ι → ℚ≥0, (∀ (i ∈ s), w' i < 1) ∧
                ∑ i in s, w' i • to_rational_point (w i) = to_rational_point x},
  let k : α → ℕ := λ a, ∑ i in s, int.nat_abs (w i a),
  have : ∀ (x : α → ℤ) a, x ∈ B → int.nat_abs (x a) ≤ k a,
  { rintro x a ⟨w', hw', hw''⟩,
    have hw''' : (∑ (i : ι) in s, w' i • to_rational_point (w i)) a = to_rational_point x a,
    { rw hw'' },
    simp only [finset.sum_apply, algebra.id.smul_eq_mul, to_rational_point_apply,
      pi.smul_apply] at hw''',
    change ∑ (c : ι) in s, (w' c : ℚ) * (w c a) = x a at hw''',
    clear hw'',
    have : abs (∑ (c : ι) in s, (w' c : ℚ) * w c a) ≤ ∑ (c : ι) in s, abs (w c a),
    { apply le_trans (finset.abs_sum_le_sum_abs _ _) _,
      apply finset.sum_le_sum,
      intros i hi,
      rw abs_mul,
      apply mul_le_of_le_one_left,
      exact abs_nonneg (w i a),
      rw abs_le,
      refine ⟨_, (hw' i hi).le⟩,
      apply le_trans (show (-1 : ℚ) ≤ 0, by norm_num) (w' i).2 },
    rw hw''' at this,
    norm_cast at this,
    simp only [int.abs_eq_nat_abs] at this,
    rw int.coe_sum at this,
    norm_cast at this,
    apply this },
  let B' := set.finite.to_finset (bounded_lattice_thing _ this),
  refine ⟨B' ∪ s.image w, _⟩,
  apply le_antisymm,
  { rw submodule.span_le,
    simp only [set.union_subset_iff, finset.coe_union, set.finite.coe_to_finset],
    split,
    { rintro x ⟨w', hw', hw''⟩,
      change to_rational_point x ∈ _,
      rw ←hw'',
      simp only [set_like.mem_coe],
      refine submodule.sum_smul_mem _ _ _,
      intros i hi,
      apply submodule.subset_span,
      simp only [set.mem_image, finset.mem_coe, finset.coe_image],
      refine ⟨_, hi, rfl⟩ },
    { simp only [set.image_subset_iff, finset.coe_image],
      intros x hx,
      change to_rational_point (w x) ∈ _,
      apply submodule.subset_span,
      refine ⟨_, hx, rfl⟩ } },
  { rintro x (hx : to_rational_point _ ∈ _),
    simp only [set_like.mem_coe, mem_span_finset] at hx,
    rcases hx with ⟨f, hf⟩,
    rw finset.sum_image at hf,
    { simp only [finset.coe_union, set.finite.coe_to_finset, finset.coe_image],
      let f' : ι → ℚ≥0 := λ i, f (to_rational_point (w i)),
      let ns : ι → ℕ := λ i, (⌊(f' i : ℚ)⌋).nat_abs,
      let g' : ι → ℚ≥0 := λ i, f' i - ns i,
      have ns' : ∀ i, (ns i : ℤ) = ⌊(f' i : ℚ)⌋,
      { intro i,
        change (int.nat_abs _ : ℤ) = _,
        rw [←int.abs_eq_nat_abs, abs_of_nonneg],
        rw [int.floor_nonneg],
        apply (f' i).2 },
      have hg' : ∀ i, (g' i : ℚ) = f' i - ns i,
      { intros i,
        change max _ _ = _,
        simp only [nnrat.coe_nat_cast],
        rw max_eq_left,
        rw sub_nonneg,
        change (int.nat_abs _ : ℚ) ≤ _,
        suffices : ((int.nat_abs ⌊(f' i : ℚ)⌋ : ℤ) : ℚ) ≤ f' i,
        { simpa using this },
        rw ns',
        apply int.floor_le },
      change ∑ x in s, f' x • to_rational_point (w x) = to_rational_point x at hf,
      -- have :  ≤ ↑(f' i) - ↑(ns i)
      have : ∀ i, (ns i : ℚ≥0) + g' i = f' i,
      { intro i,
        apply nnrat.coe_injective,
        rw [nnrat.coe_add, hg'],
        simp },
      simp_rw [←this, add_smul, finset.sum_add_distrib] at hf,
      let x_floors := ∑ (x : ι) in s, ns x • w x,
      have : x - x_floors ∈ B,
      { refine ⟨g', _, _⟩,
        { intros i hi,
          rw ←nnrat.coe_lt_coe,
          rw hg',
          simp only [nnrat.coe_one],
          suffices : (f' i : ℚ) - ((ns i : ℤ) : ℚ) < 1,
          { simpa using this },
          rw ns',
          apply int.fract_lt_one },
        rw linear_map.map_sub,
        rw linear_map.map_sum,
        rw eq_sub_iff_add_eq',
        rw ←hf,
        congr' 1,
        apply finset.sum_congr rfl,
        intros i hi,
        apply missing },
      { have : x = x - x_floors + x_floors,
        { simp },
        rw this,
        refine submodule.add_mem _ _ _,
        { apply submodule.subset_span,
          left,
          apply ‹x - x_floors ∈ B› },
        apply submodule.sum_smul_mem _ ns _,
        intros i hi,
        apply submodule.subset_span,
        right,
        refine ⟨_, hi, rfl⟩ } },
    intros x hx y hy t,
    apply hw,
    apply to_rational_point_injective t, }
end

end

-- instance {α : Type*} [fintype α] : finite_dimensional ℚ (α → ℚ) :=
-- @is_noetherian_pi _ _ _ _ _ _ _ (λ i, infer_instance)

lemma finset_Gordan_aux_pi {α : Type*} [fintype α] (S : finset ((α → ℤ) →+ ℤ)) :
  (intersect_halfspaces_set (S : set ((α → ℤ) →+ ℤ))).fg  :=
begin
  classical,
  let S' : finset ((α → ℚ) →ₗ[ℚ] ℚ) := S.image upgrade_functional,
  suffices : lattice_restrict (set_down_one (S' : set ((α → ℚ) →ₗ[ℚ] ℚ))) =
              intersect_halfspaces_set (S : set ((α → ℤ) →+ ℤ)),
  { rw ←this,
    apply my_result,
    rw ←fg_iff_is_polyhedral_cone,
    rw is_polyhedral_cone_iff_finset,
    refine ⟨_, rfl⟩ },
  ext x,
  simp [mem_lattice_restrict, mem_intersect_halfspaces_set, upgrade_id],
end

/-- A finset version of Gordan's Lemma. -/
lemma finset_Gordan_aux [module.finite ℤ Λ] [module.free ℤ Λ] (S : finset (Λ →+ ℤ)) :
  (intersect_halfspaces_set (S : set (Λ →+ ℤ))).fg :=
begin
  classical,
  have e := linear_equiv.restrict_scalars ℕ (module.free.choose_basis ℤ Λ).equiv_fun,
    -- deliberately forget the data here, it makes the simp at the end easier
  let e' : (Λ →+ ℤ) → (module.free.choose_basis_index ℤ Λ → ℤ) →+ ℤ :=
    λ f, f.comp e.symm.to_linear_map.to_add_monoid_hom,
  let L := (intersect_halfspaces_set ↑(S.image e')).map
    (e.symm : (module.free.choose_basis_index ℤ Λ → ℤ) →ₗ[ℕ] Λ),
  have : L.fg := submodule.fg.map _ (finset_Gordan_aux_pi (S.image e')),
  suffices : L = intersect_halfspaces_set (S : set (Λ →+ ℤ)),
  { rwa ←this },
  ext x,
  simp [mem_intersect_halfspaces_set, linear_equiv.symm_apply_eq],
end

/-- A finset version of Gordan's Lemma. -/
lemma finset_Gordan [module.finite ℤ Λ] [module.free ℤ Λ] (S : finset Λ) :
  (dual_finset S).fg :=
begin
  classical,
  let S' : finset ((Λ →+ ℤ) →+ ℤ) := S.image add_monoid_hom.eval,
  letI := module.free.add_monoid_hom Λ ℤ, --RB: not sure why this is needed
  have := finset_Gordan_aux S',
  convert this using 1,
  ext x,
  simp [mem_dual_finset, mem_intersect_halfspaces_set],
end

/-- A fintype version of Gordan's Lemma. -/
lemma explicit_gordan [module.finite ℤ Λ] [module.free ℤ Λ] [fintype ι] (l : ι → Λ) :
  (explicit_dual_set l).fg :=
begin
  classical,
  rw explicit_dual_set_eq_dual_finset,
  apply finset_Gordan,
end


import algebraic_topology.simplicial_set
import category_theory.limits.has_limits
import category_theory.functor_category
import category_theory.limits.yoneda
import category_theory.limits.presheaf
import simplicial_sets.simplex_as_hom

open category_theory
open category_theory.limits
open simplex_category
open sSet
open_locale simplicial

/-!
# Traversals
Defines n-traversals, pointed n-traversals and their corresponding simplicial sets.

## Notations
* `∔` for a plus,
* `∸` for a minus,
* `e :: θ` for adding an edge e at the start of a traversal θ,
* `e ⬝ α` for the action of a map α on an edge e,
* `θ ⬝ α` for the action of a map α on a traversal θ.
-/

namespace traversal

@[derive decidable_eq]
inductive pm
| plus  : pm
| minus : pm

notation `±` := pm
notation `∔` := pm.plus
notation `∸` := pm.minus

@[reducible]
def edge (n : ℕ) := fin (n+1) × ±

def edge.lt {n} : edge n → edge n → Prop
| (i, ∸) (j, ∸) := i < j
| (i, ∸) (j, ∔) := true
| (i, ∔) (j, ∸) := false
| (i, ∔) (j, ∔) := j < i

instance {n} : has_lt (edge n) := ⟨edge.lt⟩

instance edge.has_decidable_lt {n} : Π e₁ e₂ : edge n, decidable (e₁ < e₂)
| (i, ∸) (j, ∸) := fin.decidable_lt i j
| (i, ∸) (j, ∔) := is_true trivial
| (i, ∔) (j, ∸) := is_false not_false
| (i, ∔) (j, ∔) := fin.decidable_lt j i

lemma edge.lt_asymm {n} : Π e₁ e₂ : edge n, e₁ < e₂ → e₂ < e₁ → false
| (i, ∸) (j, ∸) := nat.lt_asymm
| (i, ∸) (j, ∔) := λ h₁ h₂, h₂
| (i, ∔) (j, ∸) := λ h₁ h₂, h₁
| (i, ∔) (j, ∔) := nat.lt_asymm

instance {n} : is_asymm (edge n) edge.lt := ⟨edge.lt_asymm⟩

end traversal

@[reducible]
def traversal (n : ℕ) := list (traversal.edge n)

@[reducible]
def pointed_traversal (n : ℕ) := traversal n × traversal n

namespace traversal

notation h :: t  := list.cons h t
notation `⟦` l:(foldr `, ` (h t, list.cons h t) list.nil `⟧`) := (l : traversal _)

instance decidable_mem {n} :
  Π (e : edge n) (θ : traversal n), decidable (e ∈ θ) := list.decidable_mem

@[reducible]
def sorted {n} (θ : traversal n) := list.sorted edge.lt θ

theorem eq_of_sorted_of_same_elem {n : ℕ} : Π (θ₁ θ₂ : traversal n) (s₁ : sorted θ₁) (s₂ : sorted θ₂),
  (Π e, e ∈ θ₁ ↔ e ∈ θ₂) → θ₁ = θ₂
| ⟦⟧         ⟦⟧         := λ _ _ _, rfl
| ⟦⟧         (e₂ :: t₂) := λ _ _ H, begin exfalso, simpa using H e₂, end
| (e₁ :: t₁) ⟦⟧         := λ _ _ H, begin exfalso, simpa using H e₁, end
| (e₁ :: t₁) (e₂ :: t₂) := λ s₁ s₂ H,
begin
  simp only [sorted, list.sorted_cons] at s₁ s₂,
  cases s₁ with he₁ ht₁,
  cases s₂ with he₂ ht₂,
  have he₁e₂ : e₁ = e₂,
  { have He₁ := H e₁, simp at He₁, cases He₁ with heq He₁, from heq,
    have He₂ := H e₂, simp at He₂, cases He₂ with heq He₂, from heq.symm,
    exfalso, exact edge.lt_asymm e₁ e₂ (he₁ e₂ He₂) (he₂ e₁ He₁), },
  cases he₁e₂, simp,
  { apply eq_of_sorted_of_same_elem t₁ t₂ ht₁ ht₂,
    intro e, specialize H e, simp at H, split,
    { intro he,
      cases H.1 (or.intro_right _ he) with h, cases h,
      exfalso, exact edge.lt_asymm e₁ e₁ (he₁ e₁ he) (he₁ e₁ he),
      exact h, },
    { intro he,
      cases H.2 (or.intro_right _ he) with h, cases h,
      exfalso, exact edge.lt_asymm e₁ e₁ (he₂ e₁ he) (he₂ e₁ he),
      exact h, }}
end

theorem append_sorted {n : ℕ} : Π (θ₁ θ₂ : traversal n) (s₁ : sorted θ₁) (s₂ : sorted θ₂),
  (∀ (e₁ ∈ θ₁) (e₂ ∈ θ₂), e₁ < e₂) → sorted (θ₁ ++ θ₂)
| ⟦⟧         θ₂ := λ _ s₂ _, s₂
| (e₁ :: t₁) θ₂ := λ s₁ s₂ H,
begin
  simp only [sorted, list.sorted_cons] at s₁ s₂ ⊢,
  cases s₁ with he₁ ht₁,
  dsimp, rw list.sorted_cons,
  split,
  { intros e he, simp at he, cases he,
    exact he₁ e he,
    refine H e₁ (list.mem_cons_self e₁ t₁) e he },
  { apply append_sorted t₁ θ₂ ht₁ s₂,
    intros e₁' he₁' e₂' he₂',
    refine H e₁' (list.mem_cons_of_mem e₁ he₁') e₂' he₂' }
end

theorem append_sorted_iff {n : ℕ} : Π (θ₁ θ₂ : traversal n),
  sorted θ₁ ∧ sorted θ₂ ∧ (∀ (e₁ ∈ θ₁) (e₂ ∈ θ₂), e₁ < e₂) ↔ sorted (θ₁ ++ θ₂)
| ⟦⟧         θ₂ := by simp[sorted, list.sorted_nil]
| (e₁ :: t₁) θ₂ :=
begin
  split, rintro ⟨s₁, s₂, H⟩, apply append_sorted _ _ s₁ s₂ H,
  intro H, dsimp[sorted] at H, rw list.sorted_cons at H,
  change _ ∧ sorted _ at H, rw ←append_sorted_iff at H,
  split,
  { dsimp[sorted], rw list.sorted_cons, split,
    intros b hb, exact H.1 b (list.mem_append_left θ₂ hb),
    exact H.2.1 },
  split, exact H.2.2.1,
  intros e' he', simp at he', cases he', cases he',
  intros e₂ he₂, exact H.1 e₂ (list.mem_append_right t₁ he₂),
  exact H.2.2.2 e' he',
end

/-! # Applying a map to an edge -/

def apply_map_to_plus {n m : simplex_category} (i : fin (n.len+1)) (α : m ⟶ n) :
  Π (j : ℕ), j < m.len+1 → traversal m.len
| 0       h0  := if α.to_preorder_hom 0 = i then ⟦⟨0, ∔⟩⟧ else ⟦⟧
| (j + 1) hj  :=
  if α.to_preorder_hom ⟨j+1,hj⟩ = i
  then (⟨j+1, hj⟩, ∔) :: (apply_map_to_plus j (nat.lt_of_succ_lt hj))
  else apply_map_to_plus j (nat.lt_of_succ_lt hj)

lemma min_notin_apply_map_to_plus {n m : simplex_category} (α : m ⟶ n) (i : fin (n.len+1)) (j : ℕ) (hj : j < m.len + 1) :
  ∀ (k : fin (m.len + 1)), (k, ∸) ∉ apply_map_to_plus i α j hj :=
begin
  intros k hk,
  induction j with j,
  { simp [apply_map_to_plus] at hk,
    split_ifs at hk; simp at hk; exact hk },
  { simp [apply_map_to_plus] at hk,
    split_ifs at hk, simp at hk,
    repeat {exact j_ih _ hk }}
end

lemma plus_in_apply_map_to_plus_iff {n m : simplex_category} (α : m ⟶ n) (i : fin (n.len+1)) (j : ℕ) (hj : j < m.len + 1) :
  ∀ (k : fin (m.len + 1)), (k, ∔) ∈ apply_map_to_plus i α j hj ↔ k.val < j + 1 ∧ α.to_preorder_hom k = i :=
begin
  intros k,
  induction j with j,
  { simp only [apply_map_to_plus], split_ifs; simp, split,
    intro hk, cases hk, simp, exact h,
    intro hk, ext, simp, linarith,
    intro hk, replace hk : k = 0, ext, simp, linarith, cases hk, exact h, },
  { simp only [apply_map_to_plus], split_ifs; simp; rw j_ih; simp,
    split, intro hk, cases hk, cases hk, split, simp, exact h,
    split, exact nat.le_succ_of_le hk.1, exact hk.2,
    intro hk, rw hk.2, simp, cases nat.of_le_succ hk.1, right, exact h_1, left, ext, simp, exact nat.succ.inj h_1,
    intro hk, split, intro hkj, exact nat.le_succ_of_le hkj,
    intro hkj, cases nat.of_le_succ hkj, exact h_1,
    exfalso, have H : k = ⟨j + 1, hj⟩, ext, exact nat.succ.inj h_1, cases H, exact h hk, }
end

lemma apply_map_to_plus_sorted {n m : simplex_category} (α : m ⟶ n) (i : fin (n.len+1)) (j : ℕ) (hj : j < m.len + 1) :
  sorted (apply_map_to_plus i α j hj) :=
begin
  dsimp [sorted],
  induction j with j,
  { simp [apply_map_to_plus],
    split_ifs; simp, },
  { simp [apply_map_to_plus],
    split_ifs, swap, exact j_ih (nat.lt_of_succ_lt hj),
    simp only [list.sorted_cons], split, swap, exact j_ih (nat.lt_of_succ_lt hj),
    intros e he, cases e with k, cases e_snd,
    rw plus_in_apply_map_to_plus_iff at he, exact he.1,
    exact absurd he (min_notin_apply_map_to_plus α i j _ k), },
end

def apply_map_to_min {n m : simplex_category} (i : fin (n.len+1)) (α : m ⟶ n) :
Π (j : ℕ), j < m.len+1 → traversal m.len
| 0       h0  := if α.to_preorder_hom m.last = i then ⟦⟨m.last, ∸⟩⟧ else ⟦⟧
| (j + 1) hj  :=
  if α.to_preorder_hom ⟨m.len-(j+1), nat.sub_lt_succ _ _⟩ = i
  then (⟨m.len-(j+1), nat.sub_lt_succ _ _⟩, ∸) :: (apply_map_to_min j (nat.lt_of_succ_lt hj))
  else apply_map_to_min j (nat.lt_of_succ_lt hj)

lemma plus_notin_apply_map_to_min {n m : simplex_category} (α : m ⟶ n) (i : fin (n.len+1)) (j : ℕ) (hj : j < m.len + 1) :
  ∀ (k : fin (m.len + 1)), (k, ∔) ∉ apply_map_to_min i α j hj :=
begin
  intros k hk,
  induction j with j,
  { simp [apply_map_to_min] at hk,
    split_ifs at hk; simp at hk; exact hk },
  { simp [apply_map_to_min] at hk,
    split_ifs at hk, simp at hk,
    repeat {exact j_ih _ hk }}
end

lemma min_in_apply_map_to_min_iff {n m : simplex_category} (α : m ⟶ n) (i : fin (n.len+1)) (j : ℕ) (hj : j < m.len + 1) :
  ∀ (k : fin (m.len + 1)), (k, ∸) ∈ apply_map_to_min i α j hj ↔ k.val ≥ m.len - j ∧ α.to_preorder_hom k = i :=
begin
  intros k,
  induction j with j,
  { simp only [apply_map_to_min], split_ifs; simp, split,
    intro hk, cases hk, simp, split, refl, exact h,
    intro hk, ext, exact le_antisymm (fin.le_last k) hk.1,
    intro hk, replace hk : k = m.last, ext, exact le_antisymm (fin.le_last k) hk,
    cases hk, exact h, },
  {
    have Hk : ∀ k, m.len - j.succ ≤ k ↔ m.len - j ≤ k ∨ m.len - j.succ = k,
    { have hmj_pos : 0 < m.len - j, from nat.sub_pos_of_lt (nat.succ_lt_succ_iff.mp hj),
      rw nat.lt_succ_iff at hj, intro k,
      rw [nat.sub_succ, ←nat.succ_le_succ_iff, ←nat.succ_inj', nat.succ_pred_eq_of_pos hmj_pos],
      exact nat.le_add_one_iff, },
    simp only [apply_map_to_min], split_ifs; simp; rw j_ih; simp,
    split, intro hk, cases hk, cases hk, split, simp, exact h,
    split, rw nat.sub_succ, exact nat.le_trans (nat.pred_le _) hk.1, exact hk.2,
    intro hk, rw hk.2, simp, cases (Hk k).mp hk.1, right, exact h_1, left, ext, exact h_1.symm,
    intro hk, rw Hk k, split, intro hkj, left, exact hkj,
    intro hkj, cases hkj, exact hkj,
    have Hk' : k = ⟨m.len - (j + 1), apply_map_to_min._main._proof_1 _⟩, ext, exact hkj.symm,
    cases Hk', exact absurd hk h,}
end

lemma apply_map_to_min_sorted {n m : simplex_category} (α : m ⟶ n) (i : fin (n.len+1)) (j : ℕ) (hj : j < m.len + 1) :
  list.sorted edge.lt (apply_map_to_min i α j hj) :=
begin
  induction j with j,
  { simp [apply_map_to_min],
    split_ifs; simp, },
  { simp [apply_map_to_min],
    split_ifs, swap, exact j_ih (nat.lt_of_succ_lt hj),
    simp only [list.sorted_cons], split, swap, exact j_ih (nat.lt_of_succ_lt hj),
    intros e he, cases e with k, cases e_snd,
    exact absurd he (plus_notin_apply_map_to_min α i j _ k),
    rw min_in_apply_map_to_min_iff at he,
    replace he : k.val ≥ m.len - j := he.1,
    change m.len - (j + 1) < k.val,
    refine lt_of_lt_of_le _ he, rw nat.sub_succ,
    refine nat.pred_lt _, simp,
    rwa [nat.sub_eq_zero_iff_le, not_le, ←nat.succ_lt_succ_iff], },
end

def apply_map_to_edge {n m : simplex_category} (α : m ⟶ n) : edge n.len → traversal m.len
| (i, ∔) := apply_map_to_plus i α m.last.1 m.last.2
| (i, ∸) := apply_map_to_min i α m.last.1 m.last.2

notation e ⬝ α := apply_map_to_edge α e

example (p : Prop) (h : p) : p ↔ true := iff_of_true h trivial

@[simp]
lemma edge_in_apply_map_to_edge_iff {n m : simplex_category} (α : m ⟶ n) :
  ∀ (e₁ : edge m.len) (e₂), e₁ ∈ e₂ ⬝ α ↔ (α.to_preorder_hom e₁.1, e₁.2) = e₂ :=
begin
  intros e₁ e₂, cases e₁ with i₁ b₁, cases e₂ with i₂ b₂,
  cases b₁; cases b₂; simp [apply_map_to_edge],
  { simp [plus_in_apply_map_to_plus_iff],
    exact λ _, i₁.2, },
  { apply plus_notin_apply_map_to_min, },
  { apply min_notin_apply_map_to_plus, },
  { simp [min_in_apply_map_to_min_iff, simplex_category.last], },
end

lemma apply_map_to_edge_sorted {n m : simplex_category} (α : m ⟶ n) :
  ∀ (e : edge n.len), sorted (e ⬝ α)
| (i, ∔) := apply_map_to_plus_sorted α i _ _
| (i, ∸) := apply_map_to_min_sorted α i _ _

/-! # Applying a map to a traversal -/

def apply_map {n m : simplex_category} (α : m ⟶ n) : traversal n.len → traversal m.len
| ⟦⟧       := ⟦⟧
| (e :: t) := (e ⬝ α) ++ apply_map t

notation θ ⬝ α := apply_map α θ

@[simp]
lemma edge_in_apply_map_iff {n m : simplex_category} (α : m ⟶ n) (θ : traversal n.len) :
  ∀ (e : edge m.len), e ∈ θ ⬝ α ↔ (α.to_preorder_hom e.1, e.2) ∈ θ :=
begin
  intros e, induction θ;
  simp [apply_map, list.mem_append],
  simp [edge_in_apply_map_to_edge_iff, θ_ih],
end

def apply_map_preserves_sorted {n m : simplex_category} (α : m ⟶ n) (θ : traversal n.len) :
  sorted θ → sorted (θ ⬝ α) :=
begin
  intro sθ, induction θ; dsimp [sorted, apply_map],
  { exact list.sorted_nil },
  simp only [sorted, list.sorted_cons] at sθ,
  apply append_sorted,
  apply apply_map_to_edge_sorted,
  apply θ_ih sθ.2,
  intros e₁ he₁ e₂ he₂,
  rw edge_in_apply_map_to_edge_iff at he₁,
  rw edge_in_apply_map_iff at he₂,
  replace sθ := sθ.1 (α.to_preorder_hom e₂.fst, e₂.snd) he₂,
  cases he₁, clear he₁ he₂,
  cases e₁ with i₁ b₁, cases e₂ with i₂ b₂,
  cases b₁; cases b₂; simp [edge.lt] at sθ ⊢;
  try {change i₂ < i₁}; try {trivial}; try {change i₁ < i₂};
  rw ←not_le at sθ ⊢;
  exact λ H, sθ (α.to_preorder_hom.monotone H),
end

@[simp]
lemma apply_map_append {n m : simplex_category} (α : m ⟶ n) : Π (θ₁ θ₂ : traversal n.len),
  apply_map α (θ₁ ++ θ₂) = (apply_map α θ₁) ++ (apply_map α θ₂)
| ⟦⟧ θ₂        := rfl
| (h :: θ₁) θ₂ :=
begin
  dsimp[apply_map],
  rw apply_map_append,
  rw list.append_assoc,
end

@[simp]
lemma apply_id {n : simplex_category} : ∀ (θ : traversal n.len), apply_map (𝟙 n) θ = θ
| ⟦⟧       := rfl
| (e :: θ) :=
begin
  unfold apply_map,
  rw [apply_id θ], change _ = ⟦e⟧ ++ θ,
  rw list.append_left_inj,
  apply eq_of_sorted_of_same_elem,
  { apply apply_map_to_edge_sorted },
  { exact list.sorted_singleton e },
  { intro e, simp }
end

@[simp]
lemma apply_comp {n m l : simplex_category} (α : m ⟶ n) (β : n ⟶ l) :
  ∀ (θ : traversal l.len), apply_map (α ≫ β) θ = apply_map α (apply_map β θ)
| ⟦⟧       := rfl
| (e :: θ) :=
begin
  unfold apply_map,
  rw [apply_map_append, ←apply_comp, list.append_left_inj],
  apply eq_of_sorted_of_same_elem,
  { apply apply_map_to_edge_sorted },
  { apply apply_map_preserves_sorted,
    apply apply_map_to_edge_sorted },
  { intro e, simp, }
end

/-! # The application of the standard face maps and standard degeneracies. -/

@[simp] lemma apply_δ_self {n} (i : fin (n + 2)) (b : ±) :
  apply_map_to_edge (δ i) (i, b) = ⟦⟧ :=
begin
  apply eq_of_sorted_of_same_elem,
  apply apply_map_to_edge_sorted,
  exact list.sorted_nil,
  intro e, cases e, simp,
  intro h, exfalso,
  simp [δ, fin.succ_above] at h,
  split_ifs at h,
  finish,
  rw [not_lt, fin.le_cast_succ_iff] at h_1, finish,
end

@[simp] lemma apply_δ_succ_cast_succ {n} (i : fin (n + 1)) (b : ±) :
  apply_map_to_edge (δ i.succ) (i.cast_succ, b) = ⟦(i, b)⟧ :=
begin
  apply eq_of_sorted_of_same_elem,
  apply apply_map_to_edge_sorted,
  exact list.sorted_singleton (i, b),
  intro e, cases e, simp,
  intro hb, cases hb,
  split,
  { intro he,
    have H : (δ i.succ ≫ σ i).to_preorder_hom e_fst = (σ i).to_preorder_hom i.cast_succ,
    { rw ←he, simp, },
    rw δ_comp_σ_succ at H,
    simpa [σ, fin.pred_above] using H, },
  { intro he, cases he,
    simp [δ, fin.succ_above, fin.cast_succ_lt_succ], }
end

@[simp] lemma apply_δ_cast_succ_succ {n} (i : fin (n + 1)) (b : ±) :
  apply_map_to_edge (δ i.cast_succ) (i.succ, b) = ⟦(i, b)⟧ :=
begin
  apply eq_of_sorted_of_same_elem,
  apply apply_map_to_edge_sorted,
  exact list.sorted_singleton (i, b),
  intro e, cases e, simp,
  intro hb, cases hb,
  split,
  { intro he,
    have H : (δ i.cast_succ ≫ σ i).to_preorder_hom e_fst = (σ i).to_preorder_hom i.succ,
    { rw ←he, simp, },
    rw δ_comp_σ_self at H,
    simp [σ, fin.pred_above] at H,
    split_ifs at H, from H,
    exact absurd (fin.cast_succ_lt_succ i) h, },
  { intro he, cases he,
    simp [δ, fin.succ_above, fin.cast_succ_lt_succ], }
end

@[simp] lemma apply_σ_to_plus {n} (i : fin (n + 1)) :
  apply_map_to_edge (σ i) (i, ∔) = ⟦(i.succ, ∔), (i.cast_succ, ∔)⟧ :=
begin
  apply eq_of_sorted_of_same_elem,
  { apply apply_map_to_edge_sorted,},
  { simp [sorted], intros a b ha hb, rw ha, rw hb,
    exact fin.cast_succ_lt_succ i, },
  { intro e, cases e with l b,
    rw edge_in_apply_map_to_edge_iff,
    simp, rw ←or_and_distrib_right, simp, intro hb, clear hb b,
    simp [σ, fin.pred_above],
    split,
    { intro H, split_ifs at H,
      rw ←fin.succ_inj at H, simp at H,
      left, exact H,
      rw ←fin.cast_succ_inj at H, simp at H,
      right, exact H, },
    { intro H, cases H; rw H; simp[fin.cast_succ_lt_succ], }}
end

@[simp] lemma apply_σ_to_min {n} (i : fin (n + 1)) :
  apply_map_to_edge (σ i) (i, ∸) = ⟦(i.cast_succ, ∸), (i.succ, ∸)⟧ :=
begin
  apply eq_of_sorted_of_same_elem,
  { apply apply_map_to_edge_sorted, },
  { simp[sorted],
    intros a b ha hb, rw [ha, hb],
    exact fin.cast_succ_lt_succ i, },
  { intro e, cases e with l b,
    rw edge_in_apply_map_to_edge_iff,
    simp, rw ←or_and_distrib_right, simp, intro hb, clear hb b,
    simp [σ, fin.pred_above],
    split,
    { intro H, split_ifs at H,
      rw ←fin.succ_inj at H, simp at H,
      right, exact H,
      rw ←fin.cast_succ_inj at H, simp at H,
      left, exact H, },
    { intro H, cases H; rw H; simp[fin.cast_succ_lt_succ], }}
end

def edge.s {n} : edge n → fin (n+2)
| ⟨k, ∔⟩ := k.succ
| ⟨k, ∸⟩ := k.cast_succ

def edge.t {n} : edge n → fin (n+2)
| ⟨k, ∔⟩ := k.cast_succ
| ⟨k, ∸⟩ := k.succ

notation e`ˢ` := e.s
notation e`ᵗ` := e.t

lemma apply_σ_to_self {n} (e : edge n) :
  apply_map_to_edge (σ e.1) e = ⟦(eˢ, e.2), (eᵗ, e.2)⟧ :=
begin
  apply eq_of_sorted_of_same_elem,
  { apply apply_map_to_edge_sorted, },
  { dsimp [sorted],
    rw [list.sorted_cons],
    split, swap, apply list.sorted_singleton,
    intro e', simp, intro he', cases he',
    cases e with i b, cases b;
    exact fin.cast_succ_lt_succ i },
  { intro e', simp,
    cases e with i b, cases i with i hi,
    cases e' with i' b', cases i' with i' hi',
    cases b; cases b';
    simp [σ, fin.pred_above, edge.s, edge.t];
    split_ifs;
    try { rw ←fin.succ_inj, simp [h] };
    split; intro hi;
    cases hi;
    try { linarith };
    simp }
end

/- Simplicial set of traversals. -/
def 𝕋₀ : sSet :=
{ obj       := λ n, traversal n.unop.len,
  map       := λ x y α, apply_map α.unop,
  map_id'   := λ n, funext (λ θ, apply_id θ),
  map_comp' := λ l n m β α, funext (λ θ, apply_comp α.unop β.unop θ) }

lemma 𝕋₀_map_apply {n m : simplex_categoryᵒᵖ} {f : n ⟶ m} {θ : traversal n.unop.len} :
  𝕋₀.map f θ = θ.apply_map f.unop := rfl

/- Simplicial set of pointed traversals. -/
def 𝕋₁ : sSet :=
{ obj       := λ x, pointed_traversal x.unop.len,
  map       := λ _ _ α θ, (𝕋₀.map α θ.1, 𝕋₀.map α θ.2),
  map_id'   := λ _, by ext1 θ; simp,
  map_comp' := λ _ _ _ _ _, by ext1 θ; simp }

@[simp] lemma 𝕋₁_map_apply {n m : simplex_categoryᵒᵖ} {f : n ⟶ m} {θ₁ θ₂ : traversal n.unop.len} :
  𝕋₁.map f (θ₁, θ₂) = (𝕋₀.map f θ₁, 𝕋₀.map f θ₂) := rfl

@[simp] lemma 𝕋₁_map_apply_fst {n m : simplex_categoryᵒᵖ} {f : n ⟶ m} {θ : pointed_traversal n.unop.len} :
  (𝕋₁.map f θ).1 = 𝕋₀.map f θ.1 := rfl

@[simp] lemma 𝕋₁_map_apply_snd {n m : simplex_categoryᵒᵖ} {f : n ⟶ m} {θ : pointed_traversal n.unop.len} :
  (𝕋₁.map f θ).2 = 𝕋₀.map f θ.2 := rfl

def dom : 𝕋₁ ⟶ 𝕋₀ :=
{ app         := λ n θ, θ.2,
  naturality' := λ n m α, rfl }

def cod : 𝕋₁ ⟶ 𝕋₀ :=
{ app         := λ n θ, list.append θ.1 θ.2,
  naturality' := λ m m α, funext (λ θ, (traversal.apply_map_append α.unop θ.1 θ.2).symm) }

def as_hom {n} (θ : traversal n) : Δ[n] ⟶ 𝕋₀ := simplex_as_hom θ

end traversal

def pointed_traversal.as_hom {n} (θ : pointed_traversal n) :
  Δ[n] ⟶ traversal.𝕋₁ := simplex_as_hom θ


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import tactic.lint
import tactic.ext

/-!
# Sigma types

This file proves basic results about sigma types.

A sigma type is a dependent pair type. Like `α × β` but where the type of the second component
depends on the first component. This can be seen as a generalization of the sum type `α ⊕ β`:
* `α ⊕ β` is made of stuff which is either of type `α` or `β`.
* Given `α : ι → Type*`, `sigma α` is made of stuff which is of type `α i` for some `i : ι`. One
  effectively recovers a type isomorphic to `α ⊕ β` by taking a `ι` with exactly two elements. See
  `equiv.sum_equiv_sigma_bool`.

`Σ x, A x` is notation for `sigma A` (note the difference with the big operator `∑`).
`Σ x y z ..., A x y z ...` is notation for `Σ x, Σ y, Σ z, ..., A x y z ...`. Here we have
`α : Type*`, `β : α → Type*`, `γ : Π a : α, β a → Type*`, ...,
`A : Π (a : α) (b : β a) (c : γ a b) ..., Type*`  with `x : α` `y : β x`, `z : γ x y`, ...

## Notes

The definition of `sigma` takes values in `Type*`. This effectively forbids `Prop`- valued sigma
types. To that effect, we have `psigma`, which takes value in `Sort*` and carries a more complicated
universe signature in consequence.
-/

section sigma
variables {α α₁ α₂ : Type*} {β : α → Type*} {β₁ : α₁ → Type*} {β₂ : α₂ → Type*}

namespace sigma

instance [inhabited α] [inhabited (β (default α))] : inhabited (sigma β) :=
⟨⟨default α, default (β (default α))⟩⟩

instance [h₁ : decidable_eq α] [h₂ : ∀a, decidable_eq (β a)] : decidable_eq (sigma β)
| ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ := match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
  | _, b₁, _, b₂, is_true (eq.refl a) :=
    match b₁, b₂, h₂ a b₁ b₂ with
    | _, _, is_true (eq.refl b) := is_true rfl
    | b₁, b₂, is_false n := is_false (assume h, sigma.no_confusion h (λe₁ e₂, n $ eq_of_heq e₂))
    end
  | a₁, _, a₂, _, is_false n := is_false (assume h, sigma.no_confusion h (λe₁ e₂, n e₁))
  end

@[simp, nolint simp_nf] -- sometimes the built-in injectivity support does not work
theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
  sigma.mk a₁ b₁ = ⟨a₂, b₂⟩ ↔ (a₁ = a₂ ∧ b₁ == b₂) :=
by simp

@[simp] theorem eta : ∀ x : Σ a, β a, sigma.mk x.1 x.2 = x
| ⟨i, x⟩ := rfl

@[ext]
lemma ext {x₀ x₁ : sigma β} (h₀ : x₀.1 = x₁.1) (h₁ : x₀.2 == x₁.2) : x₀ = x₁ :=
by { cases x₀, cases x₁, cases h₀, cases h₁, refl }

lemma ext_iff {x₀ x₁ : sigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ x₀.2 == x₁.2 :=
by { cases x₀, cases x₁, exact sigma.mk.inj_iff }

/-- A specialized ext lemma for equality of sigma types over an indexed subtype. -/
@[ext]
lemma subtype_ext {β : Type*} {p : α → β → Prop} :
  ∀ {x₀ x₁ : Σ a, subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
| ⟨a₀, b₀, hb₀⟩ ⟨a₁, b₁, hb₁⟩ rfl rfl := rfl

lemma subtype_ext_iff {β : Type*} {p : α → β → Prop} {x₀ x₁ : Σ a, subtype (p a)} :
  x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
⟨λ h, h ▸ ⟨rfl, rfl⟩, λ ⟨h₁, h₂⟩, subtype_ext h₁ h₂⟩

@[simp] theorem «forall» {p : (Σ a, β a) → Prop} :
  (∀ x, p x) ↔ (∀ a b, p ⟨a, b⟩) :=
⟨assume h a b, h ⟨a, b⟩, assume h ⟨a, b⟩, h a b⟩

@[simp] theorem «exists» {p : (Σ a, β a) → Prop} :
  (∃ x, p x) ↔ (∃ a b, p ⟨a, b⟩) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : Πa, β₁ a → β₂ (f₁ a)) (x : sigma β₁) : sigma β₂ :=
⟨f₁ x.1, f₂ x.1 x.2⟩

end sigma

lemma sigma_mk_injective {i : α} : function.injective (@sigma.mk α β i)
| _ _ rfl := rfl

lemma function.injective.sigma_map {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h₁ : function.injective f₁) (h₂ : ∀ a, function.injective (f₂ a)) :
  function.injective (sigma.map f₁ f₂)
| ⟨i, x⟩ ⟨j, y⟩ h :=
begin
  have : i = j, from h₁ (sigma.mk.inj_iff.mp h).1,
  subst j,
  have : x = y, from h₂ i (eq_of_heq (sigma.mk.inj_iff.mp h).2),
  subst y
end

lemma function.surjective.sigma_map {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h₁ : function.surjective f₁) (h₂ : ∀ a, function.surjective (f₂ a)) :
  function.surjective (sigma.map f₁ f₂) :=
begin
  intros y,
  cases y with j y,
  cases h₁ j with i hi,
  subst j,
  cases h₂ i y with x hx,
  subst y,
  exact ⟨⟨i, x⟩, rfl⟩
end

/-- Interpret a function on `Σ x : α, β x` as a dependent function with two arguments.

This also exists as an `equiv` as `equiv.Pi_curry γ`. -/
def sigma.curry {γ : Π a, β a → Type*} (f : Π x : sigma β, γ x.1 x.2) (x : α) (y : β x) : γ x y :=
f ⟨x,y⟩

/-- Interpret a dependent function with two arguments as a function on `Σ x : α, β x`.

This also exists as an `equiv` as `(equiv.Pi_curry γ).symm`. -/
def sigma.uncurry {γ : Π a, β a → Type*} (f : Π x (y : β x), γ x y) (x : sigma β) : γ x.1 x.2 :=
f x.1 x.2

@[simp]
lemma sigma.uncurry_curry {γ : Π a, β a → Type*} (f : Π x : sigma β, γ x.1 x.2) :
  sigma.uncurry (sigma.curry f) = f :=
funext $ λ ⟨i, j⟩, rfl

@[simp]
lemma sigma.curry_uncurry {γ : Π a, β a → Type*} (f : Π x (y : β x), γ x y) :
  sigma.curry (sigma.uncurry f) = f :=
rfl

/-- Convert a product type to a Σ-type. -/
@[simp]
def prod.to_sigma {α β} : α × β → Σ _ : α, β
| ⟨x,y⟩ := ⟨x,y⟩

@[simp]
lemma prod.fst_to_sigma {α β} (x : α × β) : (prod.to_sigma x).fst = x.fst :=
by cases x; refl

@[simp]
lemma prod.snd_to_sigma {α β} (x : α × β) : (prod.to_sigma x).snd = x.snd :=
by cases x; refl

end sigma

section psigma
variables {α : Sort*} {β : α → Sort*}

namespace psigma

/-- Nondependent eliminator for `psigma`. -/
def elim {γ} (f : ∀ a, β a → γ) (a : psigma β) : γ :=
psigma.cases_on a f

@[simp] theorem elim_val {γ} (f : ∀ a, β a → γ) (a b) : psigma.elim f ⟨a, b⟩ = f a b := rfl

instance [inhabited α] [inhabited (β (default α))] : inhabited (psigma β) :=
⟨⟨default α, default (β (default α))⟩⟩

instance [h₁ : decidable_eq α] [h₂ : ∀a, decidable_eq (β a)] : decidable_eq (psigma β)
| ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ := match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
  | _, b₁, _, b₂, is_true (eq.refl a) :=
    match b₁, b₂, h₂ a b₁ b₂ with
    | _, _, is_true (eq.refl b) := is_true rfl
    | b₁, b₂, is_false n := is_false (assume h, psigma.no_confusion h (λe₁ e₂, n $ eq_of_heq e₂))
    end
  | a₁, _, a₂, _, is_false n := is_false (assume h, psigma.no_confusion h (λe₁ e₂, n e₁))
  end

theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
  @psigma.mk α β a₁ b₁ = @psigma.mk α β a₂ b₂ ↔ (a₁ = a₂ ∧ b₁ == b₂) :=
iff.intro psigma.mk.inj $
  assume ⟨h₁, h₂⟩, match a₁, a₂, b₁, b₂, h₁, h₂ with _, _, _, _, eq.refl a, heq.refl b := rfl end

@[ext]
lemma ext {x₀ x₁ : psigma β} (h₀ : x₀.1 = x₁.1) (h₁ : x₀.2 == x₁.2) : x₀ = x₁ :=
by { cases x₀, cases x₁, cases h₀, cases h₁, refl }

lemma ext_iff {x₀ x₁ : psigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ x₀.2 == x₁.2 :=
by { cases x₀, cases x₁, exact psigma.mk.inj_iff }

/-- A specialized ext lemma for equality of psigma types over an indexed subtype. -/
@[ext]
lemma subtype_ext {β : Sort*} {p : α → β → Prop} :
  ∀ {x₀ x₁ : Σ' a, subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
| ⟨a₀, b₀, hb₀⟩ ⟨a₁, b₁, hb₁⟩ rfl rfl := rfl

lemma subtype_ext_iff {β : Sort*} {p : α → β → Prop} {x₀ x₁ : Σ' a, subtype (p a)} :
  x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
⟨λ h, h ▸ ⟨rfl, rfl⟩, λ ⟨h₁, h₂⟩, subtype_ext h₁ h₂⟩

variables {α₁ : Sort*} {α₂ : Sort*} {β₁ : α₁ → Sort*} {β₂ : α₂ → Sort*}

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : Πa, β₁ a → β₂ (f₁ a)) : psigma β₁ → psigma β₂
| ⟨a, b⟩ := ⟨f₁ a, f₂ a b⟩

end psigma

end psigma


example (P Q R : Prop) : (P → Q) → ((Q → R) → (P → R)) :=
begin
    intros pq qf p,
    apply qf,
    apply pq,
    exact p,
end


/-
Copyright (c) 2022 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno
-/
import category_theory.discrete_category
import category_theory.bicategory.functor
import category_theory.bicategory.strict

/-!
# Locally discrete bicategories

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

A category `C` can be promoted to a strict bicategory `locally_discrete C`. The objects and the
1-morphisms in `locally_discrete C` are the same as the objects and the morphisms, respectively,
in `C`, and the 2-morphisms in `locally_discrete C` are the equalities between 1-morphisms. In
other words, the category consisting of the 1-morphisms between each pair of objects `X` and `Y`
in `locally_discrete C` is defined as the discrete category associated with the type `X ⟶ Y`.
-/

namespace category_theory

open bicategory discrete
open_locale bicategory

universes w₂ v v₁ v₂ u u₁ u₂

variables {C : Type u}

/--
A type synonym for promoting any type to a category,
with the only morphisms being equalities.
-/
def locally_discrete (C : Type u) := C

namespace locally_discrete

instance : Π [inhabited C], inhabited (locally_discrete C) := id

instance [category_struct.{v} C] : category_struct (locally_discrete C) :=
{ hom := λ (X Y : C), discrete (X ⟶ Y),
  id := λ X : C, ⟨𝟙 X⟩,
  comp := λ X Y Z f g, ⟨f.as ≫ g.as⟩ }

variables {C} [category_struct.{v} C]

@[priority 900]
instance hom_small_category (X Y : locally_discrete C) : small_category (X ⟶ Y) :=
category_theory.discrete_category (X ⟶ Y)

/-- Extract the equation from a 2-morphism in a locally discrete 2-category. -/
lemma eq_of_hom {X Y : locally_discrete C} {f g : X ⟶ Y} (η : f ⟶ g) : f = g :=
begin
  have : discrete.mk (f.as) = discrete.mk (g.as) := congr_arg discrete.mk (eq_of_hom η),
  simpa using this
end

end locally_discrete

variables (C) [category.{v} C]

/--
The locally discrete bicategory on a category is a bicategory in which the objects and the
1-morphisms are the same as those in the underlying category, and the 2-morphisms are the
equalities between 1-morphisms.
-/
instance locally_discrete_bicategory : bicategory (locally_discrete C) :=
{ whisker_left  := λ X Y Z f g h η, eq_to_hom (congr_arg2 (≫) rfl (locally_discrete.eq_of_hom η)),
  whisker_right := λ X Y Z f g η h, eq_to_hom (congr_arg2 (≫) (locally_discrete.eq_of_hom η) rfl),
  associator := λ W X Y Z f g h, eq_to_iso $ by { unfold_projs, simp only [category.assoc] },
  left_unitor  := λ X Y f, eq_to_iso $ by { unfold_projs, simp only [category.id_comp, mk_as] },
  right_unitor := λ X Y f, eq_to_iso $ by { unfold_projs, simp only [category.comp_id, mk_as] } }

/-- A locally discrete bicategory is strict. -/
instance locally_discrete_bicategory.strict : strict (locally_discrete C) :=
{ id_comp' := by { intros, ext1, unfold_projs, apply category.id_comp },
  comp_id' := by { intros, ext1, unfold_projs, apply category.comp_id },
  assoc' := by { intros, ext1, unfold_projs, apply category.assoc } }

variables {I : Type u₁} [category.{v₁} I] {B : Type u₂} [bicategory.{w₂ v₂} B] [strict B]

/--
If `B` is a strict bicategory and `I` is a (1-)category, any functor (of 1-categories) `I ⥤ B` can
be promoted to an oplax functor from `locally_discrete I` to `B`.
-/
@[simps]
def functor.to_oplax_functor (F : I ⥤ B) : oplax_functor (locally_discrete I) B :=
{ obj := F.obj,
  map := λ X Y f, F.map f.as,
  map₂ := λ i j f g η, eq_to_hom (congr_arg _ (eq_of_hom η)),
  map_id := λ i, eq_to_hom (F.map_id i),
  map_comp := λ i j k f g, eq_to_hom (F.map_comp f.as g.as) }

end category_theory


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.monic
import Mathlib.ring_theory.euclidean_domain
import Mathlib.ring_theory.multiplicity
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# Division of univariate polynomials

The main defs are `div_by_monic` and `mod_by_monic`.
The compatibility between these is given by `mod_by_monic_add_div`.
We also define `root_multiplicity`.
-/

namespace polynomial

/--
The coercion turning a `polynomial` into the function which reports the coefficient of a given
monomial `X^n`
-/
-- TODO we would like to completely remove this, but this requires fixing some proofs

def coeff_coe_to_fun {R : Type u} [semiring R] : has_coe_to_fun (polynomial R) :=
  finsupp.has_coe_to_fun

theorem apply_eq_coeff {R : Type u} {n : ℕ} [semiring R] {p : polynomial R} : coe_fn p n = coeff p n :=
  rfl

/-- `div_X p` return a polynomial `q` such that `q * X + C (p.coeff 0) = p`.
  It can be used in a semiring where the usual division algorithm is not possible -/
def div_X {R : Type u} [semiring R] (p : polynomial R) : polynomial R :=
  finsupp.mk
    (finset.mk
      (multiset.map (fun (n : ℕ) => n - 1) (finset.val (finset.filter (fun (_x : ℕ) => _x > 0) (finsupp.support p))))
      sorry)
    (fun (n : ℕ) => coeff p (n + 1)) sorry

theorem div_X_mul_X_add {R : Type u} [semiring R] (p : polynomial R) : div_X p * X + coe_fn C (coeff p 0) = p := sorry

@[simp] theorem div_X_C {R : Type u} [semiring R] (a : R) : div_X (coe_fn C a) = 0 := sorry

theorem div_X_eq_zero_iff {R : Type u} [semiring R] {p : polynomial R} : div_X p = 0 ↔ p = coe_fn C (coeff p 0) := sorry

theorem div_X_add {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R} : div_X (p + q) = div_X p + div_X q := sorry

theorem degree_div_X_lt {R : Type u} [semiring R] {p : polynomial R} (hp0 : p ≠ 0) : degree (div_X p) < degree p := sorry

/-- An induction principle for polynomials, valued in Sort* instead of Prop. -/
def rec_on_horner {R : Type u} [semiring R] {M : polynomial R → Sort u_1} (p : polynomial R) : M 0 →
  ((p : polynomial R) → (a : R) → coeff p 0 = 0 → a ≠ 0 → M p → M (p + coe_fn C a)) →
    ((p : polynomial R) → p ≠ 0 → M p → M (p * X)) → M p :=
  sorry

theorem degree_pos_induction_on {R : Type u} [semiring R] {P : polynomial R → Prop} (p : polynomial R) (h0 : 0 < degree p) (hC : ∀ {a : R}, a ≠ 0 → P (coe_fn C a * X)) (hX : ∀ {p : polynomial R}, 0 < degree p → P p → P (p * X)) (hadd : ∀ {p : polynomial R} {a : R}, 0 < degree p → P p → P (p + coe_fn C a)) : P p := sorry

theorem X_dvd_iff {α : Type u} [comm_semiring α] {f : polynomial α} : X ∣ f ↔ coeff f 0 = 0 := sorry

theorem multiplicity_finite_of_degree_pos_of_monic {R : Type u} [comm_semiring R] {p : polynomial R} {q : polynomial R} (hp : 0 < degree p) (hmp : monic p) (hq : q ≠ 0) : multiplicity.finite p q := sorry

theorem div_wf_lemma {R : Type u} [ring R] {p : polynomial R} {q : polynomial R} (h : degree q ≤ degree p ∧ p ≠ 0) (hq : monic q) : degree (p - coe_fn C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) < degree p := sorry

/-- See `div_by_monic`. -/
def div_mod_by_monic_aux {R : Type u} [ring R] (p : polynomial R) {q : polynomial R} : monic q → polynomial R × polynomial R :=
  sorry

/-- `div_by_monic` gives the quotient of `p` by a monic polynomial `q`. -/
def div_by_monic {R : Type u} [ring R] (p : polynomial R) (q : polynomial R) : polynomial R :=
  dite (monic q) (fun (hq : monic q) => prod.fst (div_mod_by_monic_aux p hq)) fun (hq : ¬monic q) => 0

/-- `mod_by_monic` gives the remainder of `p` by a monic polynomial `q`. -/
def mod_by_monic {R : Type u} [ring R] (p : polynomial R) (q : polynomial R) : polynomial R :=
  dite (monic q) (fun (hq : monic q) => prod.snd (div_mod_by_monic_aux p hq)) fun (hq : ¬monic q) => p

infixl:70 " /ₘ " => Mathlib.polynomial.div_by_monic

infixl:70 " %ₘ " => Mathlib.polynomial.mod_by_monic

theorem degree_mod_by_monic_lt {R : Type u} [ring R] (p : polynomial R) {q : polynomial R} (hq : monic q) (hq0 : q ≠ 0) : degree (p %ₘ q) < degree q := sorry

@[simp] theorem zero_mod_by_monic {R : Type u} [ring R] (p : polynomial R) : 0 %ₘ p = 0 := sorry

@[simp] theorem zero_div_by_monic {R : Type u} [ring R] (p : polynomial R) : 0 /ₘ p = 0 := sorry

@[simp] theorem mod_by_monic_zero {R : Type u} [ring R] (p : polynomial R) : p %ₘ 0 = p := sorry

@[simp] theorem div_by_monic_zero {R : Type u} [ring R] (p : polynomial R) : p /ₘ 0 = 0 := sorry

theorem div_by_monic_eq_of_not_monic {R : Type u} [ring R] {q : polynomial R} (p : polynomial R) (hq : ¬monic q) : p /ₘ q = 0 :=
  dif_neg hq

theorem mod_by_monic_eq_of_not_monic {R : Type u} [ring R] {q : polynomial R} (p : polynomial R) (hq : ¬monic q) : p %ₘ q = p :=
  dif_neg hq

theorem mod_by_monic_eq_self_iff {R : Type u} [ring R] {p : polynomial R} {q : polynomial R} (hq : monic q) (hq0 : q ≠ 0) : p %ₘ q = p ↔ degree p < degree q := sorry

theorem degree_mod_by_monic_le {R : Type u} [ring R] (p : polynomial R) {q : polynomial R} (hq : monic q) : degree (p %ₘ q) ≤ degree q := sorry

theorem mod_by_monic_eq_sub_mul_div {R : Type u} [comm_ring R] (p : polynomial R) {q : polynomial R} (hq : monic q) : p %ₘ q = p - q * (p /ₘ q) := sorry

theorem mod_by_monic_add_div {R : Type u} [comm_ring R] (p : polynomial R) {q : polynomial R} (hq : monic q) : p %ₘ q + q * (p /ₘ q) = p :=
  iff.mp eq_sub_iff_add_eq (mod_by_monic_eq_sub_mul_div p hq)

theorem div_by_monic_eq_zero_iff {R : Type u} [comm_ring R] {p : polynomial R} {q : polynomial R} (hq : monic q) (hq0 : q ≠ 0) : p /ₘ q = 0 ↔ degree p < degree q := sorry

theorem degree_add_div_by_monic {R : Type u} [comm_ring R] {p : polynomial R} {q : polynomial R} (hq : monic q) (h : degree q ≤ degree p) : degree q + degree (p /ₘ q) = degree p := sorry

theorem degree_div_by_monic_le {R : Type u} [comm_ring R] (p : polynomial R) (q : polynomial R) : degree (p /ₘ q) ≤ degree p := sorry

theorem degree_div_by_monic_lt {R : Type u} [comm_ring R] (p : polynomial R) {q : polynomial R} (hq : monic q) (hp0 : p ≠ 0) (h0q : 0 < degree q) : degree (p /ₘ q) < degree p := sorry

theorem nat_degree_div_by_monic {R : Type u} [comm_ring R] (f : polynomial R) {g : polynomial R} (hg : monic g) : nat_degree (f /ₘ g) = nat_degree f - nat_degree g := sorry

theorem div_mod_by_monic_unique {R : Type u} [comm_ring R] {f : polynomial R} {g : polynomial R} (q : polynomial R) (r : polynomial R) (hg : monic g) (h : r + g * q = f ∧ degree r < degree g) : f /ₘ g = q ∧ f %ₘ g = r := sorry

theorem map_mod_div_by_monic {R : Type u} {S : Type v} [comm_ring R] {p : polynomial R} {q : polynomial R} [comm_ring S] (f : R →+* S) (hq : monic q) : map f (p /ₘ q) = map f p /ₘ map f q ∧ map f (p %ₘ q) = map f p %ₘ map f q := sorry

theorem map_div_by_monic {R : Type u} {S : Type v} [comm_ring R] {p : polynomial R} {q : polynomial R} [comm_ring S] (f : R →+* S) (hq : monic q) : map f (p /ₘ q) = map f p /ₘ map f q :=
  and.left (map_mod_div_by_monic f hq)

theorem map_mod_by_monic {R : Type u} {S : Type v} [comm_ring R] {p : polynomial R} {q : polynomial R} [comm_ring S] (f : R →+* S) (hq : monic q) : map f (p %ₘ q) = map f p %ₘ map f q :=
  and.right (map_mod_div_by_monic f hq)

theorem dvd_iff_mod_by_monic_eq_zero {R : Type u} [comm_ring R] {p : polynomial R} {q : polynomial R} (hq : monic q) : p %ₘ q = 0 ↔ q ∣ p := sorry

theorem map_dvd_map {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] (f : R →+* S) (hf : function.injective ⇑f) {x : polynomial R} {y : polynomial R} (hx : monic x) : map f x ∣ map f y ↔ x ∣ y := sorry

@[simp] theorem mod_by_monic_one {R : Type u} [comm_ring R] (p : polynomial R) : p %ₘ 1 = 0 := sorry

@[simp] theorem div_by_monic_one {R : Type u} [comm_ring R] (p : polynomial R) : p /ₘ 1 = p := sorry

@[simp] theorem mod_by_monic_X_sub_C_eq_C_eval {R : Type u} [comm_ring R] (p : polynomial R) (a : R) : p %ₘ (X - coe_fn C a) = coe_fn C (eval a p) := sorry

theorem mul_div_by_monic_eq_iff_is_root {R : Type u} {a : R} [comm_ring R] {p : polynomial R} : (X - coe_fn C a) * (p /ₘ (X - coe_fn C a)) = p ↔ is_root p a := sorry

theorem dvd_iff_is_root {R : Type u} {a : R} [comm_ring R] {p : polynomial R} : X - coe_fn C a ∣ p ↔ is_root p a := sorry

theorem mod_by_monic_X {R : Type u} [comm_ring R] (p : polynomial R) : p %ₘ X = coe_fn C (eval 0 p) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (p %ₘ X = coe_fn C (eval 0 p))) (Eq.symm (mod_by_monic_X_sub_C_eq_C_eval p 0))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (p %ₘ X = p %ₘ (X - coe_fn C 0))) C_0))
      (eq.mpr (id (Eq._oldrec (Eq.refl (p %ₘ X = p %ₘ (X - 0))) (sub_zero X))) (Eq.refl (p %ₘ X))))

theorem eval₂_mod_by_monic_eq_self_of_root {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] {f : R →+* S} {p : polynomial R} {q : polynomial R} (hq : monic q) {x : S} (hx : eval₂ f x q = 0) : eval₂ f x (p %ₘ q) = eval₂ f x p := sorry

/-- An algorithm for deciding polynomial divisibility.
The algorithm is "compute `p %ₘ q` and compare to `0`". `
See `polynomial.mod_by_monic` for the algorithm that computes `%ₘ`.
 -/
def decidable_dvd_monic {R : Type u} [comm_ring R] {q : polynomial R} (p : polynomial R) (hq : monic q) : Decidable (q ∣ p) :=
  decidable_of_iff (p %ₘ q = 0) (dvd_iff_mod_by_monic_eq_zero hq)

theorem multiplicity_X_sub_C_finite {R : Type u} [comm_ring R] {p : polynomial R} (a : R) (h0 : p ≠ 0) : multiplicity.finite (X - coe_fn C a) p := sorry

/-- The largest power of `X - C a` which divides `p`.
This is computable via the divisibility algorithm `decidable_dvd_monic`. -/
def root_multiplicity {R : Type u} [comm_ring R] (a : R) (p : polynomial R) : ℕ :=
  dite (p = 0) (fun (h0 : p = 0) => 0)
    fun (h0 : ¬p = 0) =>
      let I : decidable_pred fun (n : ℕ) => ¬(X - coe_fn C a) ^ (n + 1) ∣ p := fun (n : ℕ) => not.decidable;
      nat.find (multiplicity_X_sub_C_finite a h0)

theorem root_multiplicity_eq_multiplicity {R : Type u} [comm_ring R] (p : polynomial R) (a : R) : root_multiplicity a p =
  dite (p = 0) (fun (h0 : p = 0) => 0)
    fun (h0 : ¬p = 0) => roption.get (multiplicity (X - coe_fn C a) p) (multiplicity_X_sub_C_finite a h0) := sorry

theorem pow_root_multiplicity_dvd {R : Type u} [comm_ring R] (p : polynomial R) (a : R) : (X - coe_fn C a) ^ root_multiplicity a p ∣ p := sorry

theorem div_by_monic_mul_pow_root_multiplicity_eq {R : Type u} [comm_ring R] (p : polynomial R) (a : R) : p /ₘ (X - coe_fn C a) ^ root_multiplicity a p * (X - coe_fn C a) ^ root_multiplicity a p = p := sorry

theorem eval_div_by_monic_pow_root_multiplicity_ne_zero {R : Type u} [comm_ring R] {p : polynomial R} (a : R) (hp : p ≠ 0) : eval a (p /ₘ (X - coe_fn C a) ^ root_multiplicity a p) ≠ 0 := sorry


import unitb.logic
import unitb.scheduling

import unitb.models.nondet

import util.logic

import temporal_logic

universe variables u u'
namespace ghost

section ghost

open predicate

parameters {α α' : Type}

@[reducible]
def pred := α → Prop
@[reducible]
def pred' := α' → Prop

variables abs : α' → α

structure event : Type :=
  (coarse_sch : pred)
  (fine_sch : pred)
  (step : ∀ s, coarse_sch s → fine_sch s → α → Prop)
  (abs_step : ∀ s, coarse_sch (abs s) → fine_sch (abs s) → α' → Prop)
  (fis : ∀ s CS FS, ∃ s', step s CS FS s')

variables {abs}

def event.step_of (e : event abs) (σ σ' : α) : Prop :=
∃ Hc Hf, e.step σ Hc Hf σ'

structure program : Type 2 :=
  (lbl : Type)
  (lbl_is_sched : scheduling.sched lbl)
  (first : α → Prop)
  (first_fis : ∃ s, first s)
  (abs : α' → α)
  (event' : lbl → event abs)

-- prove that if p ∘ abs ↦ q ∘ abs in P' then
-- p ↦ q in P

-- def concrete : program → nondet.program

def skip : event abs :=
{ coarse_sch := True
, fine_sch := True
, step := λ s _ _ s', s = s'
, abs_step := λ s _ _ s', s = s'
, fis := assume s _ _, ⟨s,rfl⟩ }

def program.event (s : program) : option s.lbl → event s.abs
  | none := skip
  | (some e) := s^.event' e

def program.init (s : program) (p : pred) : Prop
:= s^.first ⟹ p

def program.guard  (s : program) (e : option s.lbl) : α → Prop :=
(s^.event e)^.coarse_sch ⋀ (s^.event e)^.fine_sch

def program.coarse_sch_of (s : program) (act : option s.lbl) : α → Prop :=
(s.event act).coarse_sch

def program.coarse_sch_of' (s : program) (act : option s.lbl) : α' → Prop :=
program.coarse_sch_of s act ∘ s.abs

@[simp]
lemma program.coarse_sch_of_none (s : program)
: s.coarse_sch_of none = True :=
by refl

def program.fine_sch_of (s : program) (act : option s.lbl) : α → Prop :=
(s.event act).fine_sch

def program.fine_sch_of' (s : program) (act : option s.lbl) : α' → Prop :=
program.fine_sch_of s act ∘ abs

@[simp]
lemma program.fine_sch_of_none (s : program)
: s.fine_sch_of none = True :=
by refl

def program.take_step (s : program)
: ∀ (e : option s.lbl) (σ : α), s^.coarse_sch_of e σ → s^.fine_sch_of e σ → α → Prop
  | none σ _ _ := λ σ', σ = σ'
  | (some e) σ Hc Hf := (s^.event e)^.step σ Hc Hf

def program.step_of (s : program) (act : option s.lbl) : α → α → Prop :=
(s.event act).step_of

def is_step (s : program) (σ σ' : α) : Prop :=
∃ ev, s.step_of ev σ σ'

open temporal

lemma step_of_none  (s : program) : s.step_of none = eq :=
begin
  dunfold program.step_of program.event skip,
  apply funext, intro σ,
  apply funext, intro σ',
  dunfold event.step_of,
  dunfold event.coarse_sch event.fine_sch event.step,
  dunfold True lifted₀,
  simp [exists_true],
end

lemma is_step_exists_event  (s : program)
 : temporal.action (is_step s) = (⟦ eq ⟧ ⋁ ∃∃ ev : s.lbl, ⟦ (s.event' ev).step_of ⟧) :=
begin
  simp [exists_action,or_action],
  apply congr_arg,
  apply funext, intro σ,
  apply funext, intro σ',
  unfold is_step,
  simp [exists_option],
  rw or_congr,
  { simp [step_of_none] },
  { apply exists_congr, intro e,
    refl }
end

lemma is_step_exists_event'  (s : program)
 : temporal.action (is_step s) = (∃∃ ev : option s.lbl, ⟦ s.step_of ev ⟧) :=
begin
  simp [exists_action,or_action],
  apply congr_arg,
  apply funext, intro σ,
  apply funext, intro σ',
  dunfold is_step,
  simp [exists_option],
end

lemma is_step_inst' (s : program) (ev : option s.lbl)
: ⟦ s.step_of ev ⟧ ⟹ ⟦ is_step s ⟧ :=
begin
  rw is_step_exists_event',
  intros τ, simp,
  apply exists.intro ev,
end

def pair  (σ σ' : α) : stream α
  | 0 := σ
  | (nat.succ i) := σ'

lemma is_step_inst (s : program) (ev : option s.lbl) (σ σ' : α)
  (h : s.step_of ev σ σ')
: is_step s σ σ' :=
begin
  change ⟦ is_step s ⟧ (pair σ σ'),
  apply is_step_inst' _ ev,
  apply h
end

instance : unitb.has_safety program :=
  { σ := α
  , step := is_step }

structure program.ex (s : program) (τ : stream α) : Prop :=
    (init : s^.first (τ 0))
    (safety : unitb.saf_ex s τ)
    (liveness : ∀ e, (◇◻• s^.coarse_sch_of e) τ →
                     (◻◇• s^.fine_sch_of e) τ →
                     (◻◇ ⟦ s.step_of e ⟧) τ)

-- structure program.falsify (s : program) (act : option s.lbl) (p : pred') : Prop :=
--   (enable : p ⟹ s^.coarse_sch_of' act)
--   (schedule : s.ex ⟹ (◇◻•p ⟶ ◻◇• s.fine_sch_of' act) )
--   (negate' : ⦃ •p ⟶ ⟦ s^.step_of act ⟧ ⟶ ⊙-•p ⦄)

-- open temporal

-- lemma program.falsify.negate
--    {s : program} {act : option s.lbl} {p : pred}
-- :  s.falsify act p
-- →  •p ⋀ ⟦ s.step_of act ⟧ ⟹ ◇-•p :=
-- begin
--   intros h₀ τ h₁,
--   note h₂ := h₀.negate' _ h₁^.left h₁^.right,
--   unfold eventually p_not init,
--   existsi 1,
--   apply h₂,
-- end

-- def program.transient (s : program) (p : pred' α) : Prop :=
-- ∃ (act : option s.lbl), s.falsify act p

-- section theorems

-- variable (s : program)

-- open program
-- open event

-- theorem program.transient_false : transient s False :=
-- begin
--   unfold program.transient,
--   existsi none,
--   apply falsify.mk,
--   { intros σ h, cases h },
--   { intros τ i h₀ h₁,
--     simp at h₀,
--     cases h₀, },
--   { intros σ h₀ h₁, cases h₀ with h₂ }
-- end

-- def program.transient_str : ∀ (s : program) {p q : α → Prop}, (∀ (i : α), p i → q i) → s.transient q → s.transient p :=
-- begin
--   intros s p q h,
--   unfold transient,
--   apply exists_imp_exists,
--   intros e h',
--   apply falsify.mk,
--   { apply forall_imp_forall _ h'.enable,
--     intro x,
--     apply imp_imp_imp_left,
--     apply h },
--   { apply forall_imp_forall _ h'.schedule,
--     intro τ,
--     apply forall_imp_forall _,
--     intro j,
--     apply p_imp_p_imp_p_imp_left _,
--     apply stable_entails_stable',
--     apply h },
--   { apply forall_imp_forall _ h'.negate',
--     intro τ,
--     apply imp_mono _ _,
--     { apply h },
--     apply imp_imp_imp_right _,
--     apply next_imp_next _ _,
--     apply entail_contrapos,
--     apply init_entails_init,
--     apply h }
-- end

-- end theorems

-- instance prog_is_system : unitb.system program :=
-- { σ := α
-- , transient := program.transient
-- , step := is_step
-- , init   := program.init
-- , transient_false := program.transient_false
-- , transient_str := program.transient_str }

-- section soundness

-- open program

-- variables {s : program} {p : pred' α}
-- variables (τ : stream α)
-- variables (h : ex s τ)
-- include h

-- lemma init_sem
--   (I₀ : init s p)
-- : (•p) τ :=
-- begin
--   unfold temporal.init,
--   unfold init program.init at I₀,
--   apply I₀,
--   apply h.init,
-- end

-- lemma transient.semantics
--   (T₀ : s.transient p)
-- : (◻◇-•p) τ :=
-- begin
--   cases (temporal.em' (•p) τ) with h_p ev_np,
--   { unfold program.transient at T₀,
--     cases T₀ with ev T₀,
--     assert Hc : (◇◻•s.coarse_sch_of ev) τ,
--     { apply stable_entails_stable' _ _ h_p,
--       apply T₀.enable },
--     assert Hf : (◻◇•s.fine_sch_of ev) τ,
--     { apply T₀.schedule _ h h_p, },
--     note act := coincidence h_p (h.liveness ev Hc Hf),
--     rw [← eventually_eventually],
--     apply henceforth_entails_henceforth _ _ act,
--     apply eventually_entails_eventually _ ,
--     apply T₀.negate },
--   { apply ev_np },
-- end

-- end soundness

-- open scheduling nat list

-- noncomputable def program.first_state (s : program) := (classical.some s.first_fis)

-- open unitb has_mem

-- lemma program.witness (s : program)
-- : ∃ (τ : stream α), s.ex τ :=
-- begin
--   note _inst := s.lbl_is_sched,
--   assert _inst_1 : ∀ (x : option s.lbl) σ, decidable (s.guard x σ),
--   { intros, apply classical.prop_decidable },

--   pose evts : list (option s.lbl) → set (option s.lbl) := enabled s,

--   apply exists_imp_exists' (run s) _ (sched.sched_str' evts),
--   intros τ h,
--   apply ex.mk,
--   { unfold run,
--     apply classical.some_spec },
--   { unfold saf_ex,
--     intro i,
--     simp [action_drop],
--     unfold step has_safety.step is_step,
--     note Hc : (s.event none).coarse_sch (run s τ i) := trivial,
--     note Hf : (s.event none).fine_sch (run s τ i) := trivial,
--     destruct (τ i),
--     { intros h,
--       existsi (τ i),
--       rw ← h at Hc Hf,
--       unfold  step_of event.step_of,
--       existsi Hc, existsi Hf,
--       apply s.run_enabled, },
--     { intros e h,
--       cases _inst_1 (τ i) (run s τ i) with Hguard Hguard,
--       { existsi none,
--         rw step_of_none s,
--         rw [s.run_skip _ _ Hguard], },
--       { existsi (τ i),
--         unfold  step_of event.step_of,
--         existsi Hguard.left, existsi Hguard.right,
--         apply s.run_enabled, } }, },
--   { apply forall_imp_forall _ h,
--     intros e Heq Hc Hf i,
--     assert inf_evts : (◻◇•mem e) (req_of evts τ),
--     { clear Heq h,
--       note Hg := coincidence Hc Hf,
--       revert evts, simp,
--       unfold req_of enabled,
--       change ((◻◇•mem e) (λ (i : ℕ), {l : option (s.lbl) | s.guard l (run s τ i)})),
--       change ((◻◇•mem e) ((λ (σ : α), {l : option (s.lbl) | s.guard l σ}) ∘ (run s τ))),
--       rw ← inf_often_trace_init_trading,
--       apply Hg, },
--     cases (Heq inf_evts i) with j Heq,
--     rw [stream.drop_drop,init_drop,stream.fst_zip',stream.snd_zip'] at Heq,
--     cases Heq with He Hguard,
--     rename Hguard Hguard',
--     assert Hguard : s.guard (τ (j + i)) (run s τ (j + i)),
--     { subst e,
--       rw [or.comm,or_iff_not_imp] at Hguard',
--       apply Hguard',
--       apply @set.ne_empty_of_mem _ _ none,
--       change true ∧ true,
--       simp, },
--     clear Hguard',
--     unfold eventually, existsi j,
--     rw He,
--     rw [stream.drop_drop,action_drop],
--     unfold program.step_of event.step_of,
--     existsi Hguard.left,existsi Hguard.right,
--     apply s.run_enabled },
-- end

-- -- instance {α} [sched lbl] : system_sem (program lbl) :=
-- instance : unitb.system_sem program :=
--   { (_ : unitb.system program) with
--     ex := program.ex
--   , safety := program.ex.safety _
--   , inhabited := program.witness
--   , init_sem := @init_sem
--   , transient_sem := @transient.semantics }

-- open unitb

-- def unless_except (s : program) (p q : pred' α) (evts : set event) : Prop :=
-- unless' s p q (λ σ σ', ∃ e, e ∈ evts ∧ e.step_of σ σ')

-- theorem unless_except_rule {s : program} {p q : pred' α} (exp : set event)
--   (ACT : ∀ (e : s.lbl) σ Hc Hf σ',
--         ¬ s.event' e ∈ exp
--       → (s.event' e).step σ Hc Hf σ'
--       → p σ → ¬ q σ → p σ' ∨ q σ')
-- : unless_except s p q exp :=
-- begin
--   intros σ σ' STEP EXP H,
--   cases H with Hp Hq,
--   unfold step has_safety.step is_step at STEP,
--   cases STEP with e STEP,
--   unfold program.step_of event.step_of at STEP,
--   cases STEP with Hc STEP,
--   cases STEP with Hf STEP,
--   cases e with e,
--   { unfold program.event skip event.step at STEP,
--     subst σ',
--     left, apply Hp },
--   { apply ACT e _ Hc Hf _ _ STEP Hp Hq,
--     intro Hin,
--     apply EXP,
--     clear ACT EXP,
--     unfold program.step_of event.step_of program.event,
--     existsi s.event' e, split, apply Hin,
--     existsi Hc, existsi Hf,
--     apply STEP }
-- end

-- theorem unless_rule {s : program} {p q : pred' α}
--   (ACT : ∀ (e : s.lbl) σ Hc Hf σ', (s.event' e).step σ Hc Hf σ' → p σ → ¬ q σ → p σ' ∨ q σ')
-- : unless s p q :=
-- begin
--   rw unless_eq_unless_except,
--   assert H : unless_except s p q ∅,
--   { apply unless_except_rule,
--     intros,
--     apply ACT
--     ; try { assumption }, },
--   unfold unless_except at H,
--   assert Heq : (λ (σ σ' : α), ∃ (e : event), e ∈ (∅ : set event) ∧ e.step_of σ σ')
--              = (λ (_x : α), False),
--   { apply funext, intro,
--     apply funext, intro,
--     simp,
--     apply eq_false_of_not_eq_true,
--     apply eq_true_intro,
--     intro H,
--     cases H with e H,
--     cases H with H₀ H₁,
--     apply H₁, },
--   apply iff.elim_left _ H,
--   rw iff_eq_eq,
--   apply congr_arg _ Heq,
-- end

-- theorem transient_rule {s : program} {p : pred' α} (ev : option s.lbl)
--    (EN : p ⟹ s.coarse_sch_of ev)
--    (FLW : leads_to s (p ⋀ s.coarse_sch_of ev) (s.fine_sch_of ev))
--    (NEG : ∀ σ σ', p σ → s.step_of ev σ σ' → ¬p σ')
-- : s.transient p :=
-- begin
--   unfold program.transient,
--   existsi ev,
--   apply falsify.mk,
--     -- enablement
--   { apply EN },
--     -- follow
--   { intros τ sem H,
--     apply inf_often_of_leads_to (system_sem.leads_to_sem FLW _ sem),
--     have H' := inf_often_of_stable _ H,
--     apply henceforth_entails_henceforth _ _ H',
--     apply eventually_entails_eventually _ ,
--     apply init_entails_init _ ,
--     intros σ Hp,
--     apply and.intro Hp,
--     apply EN _ Hp },
--     -- negation
--   { intros σ Hp Hact,
--     apply NEG _ _ Hp Hact }
-- end

end ghost

end ghost