/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import algebra.hom.group_action
import group_theory.group_action.defs
import group_theory.group_action.group
import group_theory.quotient_group
import data.setoid.basic
import data.fintype.card

/-!
# Basic properties of group actions

This file primarily concerns itself with orbits, stabilizers, and other objects defined in terms of
actions. Despite this file being called `basic`, low-level helper lemmas for algebraic manipulation
of `•` belong elsewhere.

## Main definitions

* `mul_action.orbit`
* `mul_action.fixed_points`
* `mul_action.fixed_by`
* `mul_action.stabilizer`

-/

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

open_locale big_operators pointwise
open function

namespace mul_action

variables (α) [monoid α] [mul_action α β]

/-- The orbit of an element under an action. -/
@[to_additive "The orbit of an element under an action."]
def orbit (b : β) := set.range (λ x : α, x • b)

variable {α}

@[to_additive] lemma mem_orbit_iff {b₁ b₂ : β} : b₂ ∈ orbit α b₁ ↔ ∃ x : α, x • b₁ = b₂ :=
iff.rfl

@[simp, to_additive] lemma mem_orbit (b : β) (x : α) : x • b ∈ orbit α b :=
⟨x, rfl⟩

@[simp, to_additive] lemma mem_orbit_self (b : β) : b ∈ orbit α b :=
⟨1, by simp [mul_action.one_smul]⟩

@[to_additive] lemma orbit_nonempty (b : β) : set.nonempty (orbit α b) := set.range_nonempty _

@[to_additive] lemma maps_to_smul_orbit (a : α) (b : β) :
  set.maps_to ((•) a) (orbit α b) (orbit α b) :=
set.range_subset_iff.2 $ λ a', ⟨a * a', mul_smul _ _ _⟩

@[to_additive] lemma smul_orbit_subset (a : α) (b : β) : a • orbit α b ⊆ orbit α b :=
(maps_to_smul_orbit a b).image_subset

@[to_additive] lemma orbit_smul_subset (a : α) (b : β) : orbit α (a • b) ⊆ orbit α b :=
set.range_subset_iff.2 $ λ a', mul_smul a' a b ▸ mem_orbit _ _

@[to_additive] instance {b : β} : mul_action α (orbit α b) :=
{ smul := λ a, (maps_to_smul_orbit a b).restrict _ _ _,
  one_smul := λ a, subtype.ext (one_smul α a),
  mul_smul := λ a a' b', subtype.ext (mul_smul a a' b') }

@[simp, to_additive] lemma orbit.coe_smul {b : β} {a : α} {b' : orbit α b} :
  ↑(a • b') = a • (b' : β) :=
rfl

variables (α) (β)

/-- The set of elements fixed under the whole action. -/
@[to_additive "The set of elements fixed under the whole action."]
def fixed_points : set β := {b : β | ∀ x : α, x • b = b}

/-- `fixed_by g` is the subfield of elements fixed by `g`. -/
@[to_additive "`fixed_by g` is the subfield of elements fixed by `g`."]
def fixed_by (g : α) : set β :=
{ x | g • x = x }

@[to_additive] theorem fixed_eq_Inter_fixed_by : fixed_points α β = ⋂ g : α, fixed_by α β g :=
set.ext $ λ x, ⟨λ hx, set.mem_Inter.2 $ λ g, hx g, λ hx g, by exact (set.mem_Inter.1 hx g : _)⟩

variables {α} (β)

@[simp, to_additive] lemma mem_fixed_points {b : β} :
  b ∈ fixed_points α β ↔ ∀ x : α, x • b = b := iff.rfl

@[simp, to_additive] lemma mem_fixed_by {g : α} {b : β} :
  b ∈ fixed_by α β g ↔ g • b = b := iff.rfl

@[to_additive] lemma mem_fixed_points' {b : β} : b ∈ fixed_points α β ↔
  (∀ b', b' ∈ orbit α b → b' = b) :=
⟨λ h b h₁, let ⟨x, hx⟩ := mem_orbit_iff.1 h₁ in hx ▸ h x,
λ h b, h _ (mem_orbit _ _)⟩

variables (α) {β}

/-- The stabilizer of a point `b` as a submonoid of `α`. -/
@[to_additive "The stabilizer of a point `b` as an additive submonoid of `α`."]
def stabilizer.submonoid (b : β) : submonoid α :=
{ carrier := { a | a • b = b },
  one_mem' := one_smul _ b,
  mul_mem' := λ a a' (ha : a • b = b) (hb : a' • b = b),
    show (a * a') • b = b, by rw [←smul_smul, hb, ha] }

@[simp, to_additive] lemma mem_stabilizer_submonoid_iff {b : β} {a : α} :
  a ∈ stabilizer.submonoid α b ↔ a • b = b := iff.rfl

@[to_additive] lemma orbit_eq_univ [is_pretransitive α β] (x : β) :
  orbit α x = set.univ :=
(surjective_smul α x).range_eq

variables {α} {β}

@[to_additive] lemma mem_fixed_points_iff_card_orbit_eq_one {a : β}
  [fintype (orbit α a)] : a ∈ fixed_points α β ↔ fintype.card (orbit α a) = 1 :=
begin
  rw [fintype.card_eq_one_iff, mem_fixed_points],
  split,
  { exact λ h, ⟨⟨a, mem_orbit_self _⟩, λ ⟨b, ⟨x, hx⟩⟩, subtype.eq $ by simp [h x, hx.symm]⟩ },
  { assume h x,
    rcases h with ⟨⟨z, hz⟩, hz₁⟩,
    calc x • a = z : subtype.mk.inj (hz₁ ⟨x • a, mem_orbit _ _⟩)
      ... = a : (subtype.mk.inj (hz₁ ⟨a, mem_orbit_self _⟩)).symm }
end

end mul_action

namespace mul_action
variable (α)
variables [group α] [mul_action α β]

/-- The stabilizer of an element under an action, i.e. what sends the element to itself.
A subgroup. -/
@[to_additive "The stabilizer of an element under an action, i.e. what sends the element to itself.
An additive subgroup."]
def stabilizer (b : β) : subgroup α :=
{ inv_mem' := λ a (ha : a • b = b), show a⁻¹ • b = b, by rw [inv_smul_eq_iff, ha]
  ..stabilizer.submonoid α b }

variables {α} {β}

@[simp, to_additive] lemma mem_stabilizer_iff {b : β} {a : α} :
  a ∈ stabilizer α b ↔ a • b = b := iff.rfl

@[simp, to_additive] lemma smul_orbit (a : α) (b : β) :
  a • orbit α b = orbit α b :=
(smul_orbit_subset a b).antisymm $
  calc orbit α b = a • a⁻¹ • orbit α b : (smul_inv_smul _ _).symm
             ... ⊆ a • orbit α b       : set.image_subset _ (smul_orbit_subset _ _)

@[simp, to_additive] lemma orbit_smul (a : α) (b : β) : orbit α (a • b) = orbit α b :=
(orbit_smul_subset a b).antisymm $
  calc orbit α b = orbit α (a⁻¹ • a • b) : by rw inv_smul_smul
             ... ⊆ orbit α (a • b)       : orbit_smul_subset _ _

/-- The action of a group on an orbit is transitive. -/
@[to_additive "The action of an additive group on an orbit is transitive."]
instance (x : β) : is_pretransitive α (orbit α x) :=
⟨by { rintro ⟨_, a, rfl⟩ ⟨_, b, rfl⟩, use b * a⁻¹, ext1, simp [mul_smul] }⟩

@[to_additive] lemma orbit_eq_iff {a b : β} :
   orbit α a = orbit α b ↔ a ∈ orbit α b:=
⟨λ h, h ▸ mem_orbit_self _, λ ⟨c, hc⟩, hc ▸ orbit_smul _ _⟩

variables (α) {β}

@[to_additive] lemma mem_orbit_smul (g : α) (a : β) : a ∈ orbit α (g • a) :=
by simp only [orbit_smul, mem_orbit_self]

@[to_additive] lemma smul_mem_orbit_smul (g h : α) (a : β) : g • a ∈ orbit α (h • a) :=
by simp only [orbit_smul, mem_orbit]

variables (α) (β)
/-- The relation 'in the same orbit'. -/
@[to_additive "The relation 'in the same orbit'."]
def orbit_rel : setoid β :=
{ r := λ a b, a ∈ orbit α b,
  iseqv := ⟨mem_orbit_self, λ a b, by simp [orbit_eq_iff.symm, eq_comm],
    λ a b, by simp [orbit_eq_iff.symm, eq_comm] {contextual := tt}⟩ }

local attribute [instance] orbit_rel

variables {α} {β}
/-- When you take a set `U` in `β`, push it down to the quotient, and pull back, you get the union
of the orbit of `U` under `α`.
-/
@[to_additive] lemma quotient_preimage_image_eq_union_mul (U : set β) :
  quotient.mk ⁻¹' (quotient.mk '' U) = ⋃ a : α, ((•) a) '' U :=
begin
  set f : β → quotient (mul_action.orbit_rel α β) := quotient.mk,
  ext,
  split,
  { rintros ⟨y , hy, hxy⟩,
    obtain ⟨a, rfl⟩ := quotient.exact hxy,
    rw set.mem_Union,
    exact ⟨a⁻¹, a • x, hy, inv_smul_smul a x⟩ },
  { intros hx,
    rw set.mem_Union at hx,
    obtain ⟨a, u, hu₁, hu₂⟩ := hx,
    rw [set.mem_preimage, set.mem_image_iff_bex],
    refine ⟨a⁻¹ • x, _, by simp only [quotient.eq]; use a⁻¹⟩,
    rw ← hu₂,
    convert hu₁,
    simp only [inv_smul_smul], },
end

@[to_additive]
lemma image_inter_image_iff (U V : set β) :
  (quotient.mk '' U) ∩ (quotient.mk '' V) = ∅ ↔ ∀ x ∈ U, ∀ a : α, a • x ∉ V :=
begin
  set f : β → quotient (mul_action.orbit_rel α β) := quotient.mk,
  rw set.eq_empty_iff_forall_not_mem,
  split,
  { intros h x x_in_U a a_in_V,
    refine h (f (a • x)) ⟨⟨x, x_in_U, _⟩, ⟨a • x, a_in_V, rfl⟩⟩,
    rw quotient.eq,
    use a⁻¹,
    simp, },
  { rintros h x ⟨⟨y, hy₁, hy₂⟩, ⟨z, hz₁, hz₂⟩⟩,
    obtain ⟨a, ha⟩ := quotient.exact (hz₂.trans hy₂.symm),
    apply h y hy₁ a,
    convert hz₁, },
end

variables (α) (β)
local notation `Ω` := (quotient $ orbit_rel α β)

/-- Decomposition of a type `X` as a disjoint union of its orbits under a group action.
This version works with any right inverse to `quotient.mk'` in order to stay computable. In most
cases you'll want to use `quotient.out'`, so we provide `mul_action.self_equiv_sigma_orbits` as
a special case. -/
@[to_additive "Decomposition of a type `X` as a disjoint union of its orbits under an additive group
action. This version works with any right inverse to `quotient.mk'` in order to stay computable.
In most cases you'll want to use `quotient.out'`, so we provide `add_action.self_equiv_sigma_orbits`
as a special case."]
def self_equiv_sigma_orbits' {φ : Ω → β} (hφ : right_inverse φ quotient.mk') :
  β ≃ Σ (ω : Ω), orbit α (φ ω) :=
calc  β
    ≃ Σ (ω : Ω), {b // quotient.mk' b = ω} : (equiv.sigma_fiber_equiv quotient.mk').symm
... ≃ Σ (ω : Ω), orbit α (φ ω) :
        equiv.sigma_congr_right (λ ω, equiv.subtype_equiv_right $
          λ x, by {rw [← hφ ω, quotient.eq', hφ ω], refl })

/-- Decomposition of a type `X` as a disjoint union of its orbits under a group action. -/
@[to_additive "Decomposition of a type `X` as a disjoint union of its orbits under an additive group
action."]
noncomputable def self_equiv_sigma_orbits : β ≃ Σ (ω : Ω), orbit α ω.out' :=
self_equiv_sigma_orbits' α β quotient.out_eq'

variables {α β}

/-- If the stabilizer of `x` is `S`, then the stabilizer of `g • x` is `gSg⁻¹`. -/
lemma stabilizer_smul_eq_stabilizer_map_conj (g : α) (x : β) :
  (stabilizer α (g • x) = (stabilizer α x).map (mul_aut.conj g).to_monoid_hom) :=
begin
  ext h,
  rw [mem_stabilizer_iff, ← smul_left_cancel_iff g⁻¹, smul_smul, smul_smul, smul_smul, mul_left_inv,
      one_smul, ← mem_stabilizer_iff, subgroup.mem_map_equiv, mul_aut.conj_symm_apply]
end

/-- A bijection between the stabilizers of two elements in the same orbit. -/
noncomputable def stabilizer_equiv_stabilizer_of_orbit_rel {x y : β} (h : (orbit_rel α β).rel x y) :
  stabilizer α x ≃* stabilizer α y :=
let g : α := classical.some h in
have hg : g • y = x := classical.some_spec h,
have this : stabilizer α x = (stabilizer α y).map (mul_aut.conj g).to_monoid_hom,
  by rw [← hg, stabilizer_smul_eq_stabilizer_map_conj],
(mul_equiv.subgroup_congr this).trans ((mul_aut.conj g).subgroup_map $ stabilizer α y).symm

end mul_action

namespace add_action

variables [add_group α] [add_action α β]

/-- If the stabilizer of `x` is `S`, then the stabilizer of `g +ᵥ x` is `g + S + (-g)`. -/
lemma stabilizer_vadd_eq_stabilizer_map_conj (g : α) (x : β) :
  (stabilizer α (g +ᵥ x) = (stabilizer α x).map (add_aut.conj g).to_add_monoid_hom) :=
begin
  ext h,
  rw [mem_stabilizer_iff, ← vadd_left_cancel_iff (-g) , vadd_vadd, vadd_vadd, vadd_vadd,
      add_left_neg, zero_vadd, ← mem_stabilizer_iff, add_subgroup.mem_map_equiv,
      add_aut.conj_symm_apply]
end

/-- A bijection between the stabilizers of two elements in the same orbit. -/
noncomputable def stabilizer_equiv_stabilizer_of_orbit_rel {x y : β}
  (h : (orbit_rel α β).rel x y) :
  stabilizer α x ≃+ stabilizer α y :=
let g : α := classical.some h in
have hg : g +ᵥ y = x := classical.some_spec h,
have this : stabilizer α x = (stabilizer α y).map (add_aut.conj g).to_add_monoid_hom,
  by rw [← hg, stabilizer_vadd_eq_stabilizer_map_conj],
(add_equiv.add_subgroup_congr this).trans
  ((add_aut.conj g).add_subgroup_map $ stabilizer α y).symm

end add_action

namespace mul_action

variables [group α]

section quotient_action

open subgroup mul_opposite

variables (β) [monoid β] [mul_action β α] (H : subgroup α)

/-- A typeclass for when a `mul_action β α` descends to the quotient `α ⧸ H`. -/
class quotient_action : Prop :=
(inv_mul_mem : ∀ (b : β) {a a' : α}, a⁻¹ * a' ∈ H → (b • a)⁻¹ * (b • a') ∈ H)

/-- A typeclass for when an `add_action β α` descends to the quotient `α ⧸ H`. -/
class _root_.add_action.quotient_action {α : Type*} (β : Type*) [add_group α] [add_monoid β]
  [add_action β α] (H : add_subgroup α) : Prop :=
(inv_mul_mem : ∀ (b : β) {a a' : α}, -a + a' ∈ H → -(b +ᵥ a) + (b +ᵥ a') ∈ H)

attribute [to_additive add_action.quotient_action] mul_action.quotient_action

@[to_additive] instance left_quotient_action : quotient_action α H :=
⟨λ _ _ _ _, by rwa [smul_eq_mul, smul_eq_mul, mul_inv_rev, mul_assoc, inv_mul_cancel_left]⟩

@[to_additive] instance right_quotient_action : quotient_action H.normalizer.opposite H :=
⟨λ b c _ _, by rwa [smul_def, smul_def, smul_eq_mul_unop, smul_eq_mul_unop, mul_inv_rev, ←mul_assoc,
  mem_normalizer_iff'.mp b.prop, mul_assoc, mul_inv_cancel_left]⟩

@[to_additive] instance right_quotient_action' [hH : H.normal] : quotient_action αᵐᵒᵖ H :=
⟨λ _ _ _ _, by rwa [smul_eq_mul_unop, smul_eq_mul_unop, mul_inv_rev, mul_assoc, hH.mem_comm_iff,
  mul_assoc, mul_inv_cancel_right]⟩

@[to_additive] instance quotient [quotient_action β H] : mul_action β (α ⧸ H) :=
{ smul := λ b, quotient.map' ((•) b) (λ a a' h, quotient_action.inv_mul_mem b h),
  one_smul := λ q, quotient.induction_on' q (λ a, congr_arg quotient.mk' (one_smul β a)),
  mul_smul := λ b b' q, quotient.induction_on' q (λ a, congr_arg quotient.mk' (mul_smul b b' a)) }

variables {β}

@[simp, to_additive] lemma quotient.smul_mk [quotient_action β H] (b : β) (a : α) :
  (b • quotient_group.mk a : α ⧸ H) = quotient_group.mk (b • a) := rfl

@[simp, to_additive] lemma quotient.smul_coe [quotient_action β H] (b : β) (a : α) :
  (b • a : α ⧸ H) = ↑(b • a) := rfl

@[simp, to_additive] lemma quotient.mk_smul_out' [quotient_action β H] (b : β) (q : α ⧸ H) :
  quotient_group.mk (b • q.out') = b • q :=
by rw [←quotient.smul_mk, quotient_group.out_eq']

@[simp, to_additive] lemma quotient.coe_smul_out' [quotient_action β H] (b : β) (q : α ⧸ H) :
  ↑(b • q.out') = b • q :=
quotient.mk_smul_out' H b q

end quotient_action

open quotient_group

/-- The canonical map to the left cosets. -/
def _root_.mul_action_hom.to_quotient (H : subgroup α) : α →[α] α ⧸ H :=
⟨coe, quotient.smul_coe H⟩

@[simp] lemma _root_.mul_action_hom.to_quotient_apply (H : subgroup α) (g : α) :
  mul_action_hom.to_quotient H g = g := rfl

@[to_additive] instance mul_left_cosets_comp_subtype_val (H I : subgroup α) :
  mul_action I (α ⧸ H) :=
mul_action.comp_hom (α ⧸ H) (subgroup.subtype I)

variables (α) {β} [mul_action α β] (x : β)

/-- The canonical map from the quotient of the stabilizer to the set. -/
@[to_additive "The canonical map from the quotient of the stabilizer to the set. "]
def of_quotient_stabilizer (g : α ⧸ (mul_action.stabilizer α x)) : β :=
quotient.lift_on' g (•x) $ λ g1 g2 H,
calc  g1 • x
    = g1 • (g1⁻¹ * g2) • x : congr_arg _ H.symm
... = g2 • x : by rw [smul_smul, mul_inv_cancel_left]

@[simp, to_additive] theorem of_quotient_stabilizer_mk (g : α) :
  of_quotient_stabilizer α x (quotient_group.mk g) = g • x :=
rfl

@[to_additive] theorem of_quotient_stabilizer_mem_orbit (g) :
  of_quotient_stabilizer α x g ∈ orbit α x :=
quotient.induction_on' g $ λ g, ⟨g, rfl⟩

@[to_additive] theorem of_quotient_stabilizer_smul (g : α)
  (g' : α ⧸ (mul_action.stabilizer α x)) :
  of_quotient_stabilizer α x (g • g') = g • of_quotient_stabilizer α x g' :=
quotient.induction_on' g' $ λ _, mul_smul _ _ _

@[to_additive] theorem injective_of_quotient_stabilizer :
  function.injective (of_quotient_stabilizer α x) :=
λ y₁ y₂, quotient.induction_on₂' y₁ y₂ $ λ g₁ g₂ (H : g₁ • x = g₂ • x), quotient.sound' $
show (g₁⁻¹ * g₂) • x = x, by rw [mul_smul, ← H, inv_smul_smul]

/-- Orbit-stabilizer theorem. -/
@[to_additive "Orbit-stabilizer theorem."]
noncomputable def orbit_equiv_quotient_stabilizer (b : β) :
  orbit α b ≃ α ⧸ (stabilizer α b) :=
equiv.symm $ equiv.of_bijective
  (λ g, ⟨of_quotient_stabilizer α b g, of_quotient_stabilizer_mem_orbit α b g⟩)
  ⟨λ x y hxy, injective_of_quotient_stabilizer α b (by convert congr_arg subtype.val hxy),
  λ ⟨b, ⟨g, hgb⟩⟩, ⟨g, subtype.eq hgb⟩⟩

/-- Orbit-stabilizer theorem. -/
@[to_additive "Orbit-stabilizer theorem."]
noncomputable def orbit_prod_stabilizer_equiv_group (b : β) :
  orbit α b × stabilizer α b ≃ α :=
(equiv.prod_congr (orbit_equiv_quotient_stabilizer α _) (equiv.refl _)).trans
subgroup.group_equiv_quotient_times_subgroup.symm

/-- Orbit-stabilizer theorem. -/
@[to_additive "Orbit-stabilizer theorem."]
lemma card_orbit_mul_card_stabilizer_eq_card_group (b : β) [fintype α] [fintype $ orbit α b]
  [fintype $ stabilizer α b] :
  fintype.card (orbit α b) * fintype.card (stabilizer α b) = fintype.card α :=
by rw [← fintype.card_prod, fintype.card_congr (orbit_prod_stabilizer_equiv_group α b)]

@[simp, to_additive] theorem orbit_equiv_quotient_stabilizer_symm_apply (b : β) (a : α) :
  ((orbit_equiv_quotient_stabilizer α b).symm a : β) = a • b :=
rfl

@[simp, to_additive] lemma stabilizer_quotient {G} [group G] (H : subgroup G) :
  mul_action.stabilizer G ((1 : G) : G ⧸ H) = H :=
by { ext, simp [quotient_group.eq] }

variable (β)

local notation `Ω` := (quotient $ orbit_rel α β)

/-- **Class formula** : given `G` a group acting on `X` and `φ` a function mapping each orbit of `X`
under this action (that is, each element of the quotient of `X` by the relation `orbit_rel G X`) to
an element in this orbit, this gives a (noncomputable) bijection between `X` and the disjoint union
of `G/Stab(φ(ω))` over all orbits `ω`. In most cases you'll want `φ` to be `quotient.out'`, so we
provide `mul_action.self_equiv_sigma_orbits_quotient_stabilizer` as a special case. -/
@[to_additive "**Class formula** : given `G` an additive group acting on `X` and `φ` a function
mapping each orbit of `X` under this action (that is, each element of the quotient of `X` by the
relation `orbit_rel G X`) to an element in this orbit, this gives a (noncomputable) bijection
between `X` and the disjoint union of `G/Stab(φ(ω))` over all orbits `ω`. In most cases you'll want
`φ` to be `quotient.out'`, so we provide `add_action.self_equiv_sigma_orbits_quotient_stabilizer`
as a special case. "]
noncomputable def self_equiv_sigma_orbits_quotient_stabilizer' {φ : Ω → β}
  (hφ : left_inverse quotient.mk' φ) : β ≃ Σ (ω : Ω), α ⧸ (stabilizer α (φ ω)) :=
calc  β
    ≃ Σ (ω : Ω), orbit α (φ ω) : self_equiv_sigma_orbits' α β hφ
... ≃ Σ (ω : Ω), α ⧸ (stabilizer α (φ ω)) :
        equiv.sigma_congr_right (λ ω, orbit_equiv_quotient_stabilizer α (φ ω))

/-- **Class formula** for a finite group acting on a finite type. See
`mul_action.card_eq_sum_card_group_div_card_stabilizer` for a specialized version using
`quotient.out'`. -/
@[to_additive "**Class formula** for a finite group acting on a finite type. See
`add_action.card_eq_sum_card_add_group_div_card_stabilizer` for a specialized version using
`quotient.out'`."]
lemma card_eq_sum_card_group_div_card_stabilizer' [fintype α] [fintype β] [fintype Ω]
  [Π (b : β), fintype $ stabilizer α b] {φ : Ω → β} (hφ : left_inverse quotient.mk' φ) :
  fintype.card β = ∑ (ω : Ω), fintype.card α / fintype.card (stabilizer α (φ ω)) :=
begin
  classical,
  have : ∀ ω : Ω, fintype.card α / fintype.card ↥(stabilizer α (φ ω)) =
    fintype.card (α ⧸ stabilizer α (φ ω)),
  { intro ω,
    rw [fintype.card_congr (@subgroup.group_equiv_quotient_times_subgroup α _ (stabilizer α $ φ ω)),
        fintype.card_prod, nat.mul_div_cancel],
    exact fintype.card_pos_iff.mpr (by apply_instance) },
  simp_rw [this, ← fintype.card_sigma, fintype.card_congr
            (self_equiv_sigma_orbits_quotient_stabilizer' α β hφ)],
end

/-- **Class formula**. This is a special case of
`mul_action.self_equiv_sigma_orbits_quotient_stabilizer'` with `φ = quotient.out'`. -/
@[to_additive "**Class formula**. This is a special case of
`add_action.self_equiv_sigma_orbits_quotient_stabilizer'` with `φ = quotient.out'`. "]
noncomputable def self_equiv_sigma_orbits_quotient_stabilizer :
  β ≃ Σ (ω : Ω), α ⧸ (stabilizer α ω.out') :=
self_equiv_sigma_orbits_quotient_stabilizer' α β quotient.out_eq'

/-- **Class formula** for a finite group acting on a finite type. -/
@[to_additive "**Class formula** for a finite group acting on a finite type."]
lemma card_eq_sum_card_group_div_card_stabilizer [fintype α] [fintype β] [fintype Ω]
  [Π (b : β), fintype $ stabilizer α b] :
  fintype.card β = ∑ (ω : Ω), fintype.card α / fintype.card (stabilizer α ω.out') :=
card_eq_sum_card_group_div_card_stabilizer' α β quotient.out_eq'

/-- **Burnside's lemma** : a (noncomputable) bijection between the disjoint union of all
`{x ∈ X | g • x = x}` for `g ∈ G` and the product `G × X/G`, where `G` is a group acting on `X` and
`X/G`denotes the quotient of `X` by the relation `orbit_rel G X`. -/
@[to_additive "**Burnside's lemma** : a (noncomputable) bijection between the disjoint union of all
`{x ∈ X | g • x = x}` for `g ∈ G` and the product `G × X/G`, where `G` is an additive group acting
on `X` and `X/G`denotes the quotient of `X` by the relation `orbit_rel G X`. "]
noncomputable def sigma_fixed_by_equiv_orbits_prod_group :
  (Σ (a : α), (fixed_by α β a)) ≃ Ω × α :=
calc  (Σ (a : α), fixed_by α β a)
    ≃ {ab : α × β // ab.1 • ab.2 = ab.2} :
        (equiv.subtype_prod_equiv_sigma_subtype _).symm
... ≃ {ba : β × α // ba.2 • ba.1 = ba.1} :
        (equiv.prod_comm α β).subtype_equiv (λ ab, iff.rfl)
... ≃ Σ (b : β), stabilizer α b :
        equiv.subtype_prod_equiv_sigma_subtype (λ (b : β) a, a ∈ stabilizer α b)
... ≃ Σ (ωb : (Σ (ω : Ω), orbit α ω.out')), stabilizer α (ωb.2 : β) :
        (self_equiv_sigma_orbits α β).sigma_congr_left'
... ≃ Σ (ω : Ω), (Σ (b : orbit α ω.out'), stabilizer α (b : β)) :
        equiv.sigma_assoc (λ (ω : Ω) (b : orbit α ω.out'), stabilizer α (b : β))
... ≃ Σ (ω : Ω), (Σ (b : orbit α ω.out'), stabilizer α ω.out') :
        equiv.sigma_congr_right (λ ω, equiv.sigma_congr_right $
          λ ⟨b, hb⟩, (stabilizer_equiv_stabilizer_of_orbit_rel hb).to_equiv)
... ≃ Σ (ω : Ω), orbit α ω.out' × stabilizer α ω.out' :
        equiv.sigma_congr_right (λ ω, equiv.sigma_equiv_prod _ _)
... ≃ Σ (ω : Ω), α :
        equiv.sigma_congr_right (λ ω, orbit_prod_stabilizer_equiv_group α ω.out')
... ≃ Ω × α :
        equiv.sigma_equiv_prod Ω α

/-- **Burnside's lemma** : given a finite group `G` acting on a set `X`, the average number of
elements fixed by each `g ∈ G` is the number of orbits. -/
@[to_additive "**Burnside's lemma** : given a finite additive group `G` acting on a set `X`,
the average number of elements fixed by each `g ∈ G` is the number of orbits. "]
lemma sum_card_fixed_by_eq_card_orbits_mul_card_group [fintype α] [Π a, fintype $ fixed_by α β a]
  [fintype Ω] :
  ∑ (a : α), fintype.card (fixed_by α β a) = fintype.card Ω * fintype.card α :=
by rw [← fintype.card_prod, ← fintype.card_sigma,
        fintype.card_congr (sigma_fixed_by_equiv_orbits_prod_group α β)]

@[to_additive] instance is_pretransitive_quotient (G) [group G] (H : subgroup G) :
  is_pretransitive G (G ⧸ H) :=
{ exists_smul_eq := begin
    rintros ⟨x⟩ ⟨y⟩,
    refine ⟨y * x⁻¹, quotient_group.eq.mpr _⟩,
    simp only [smul_eq_mul, H.one_mem, mul_left_inv, inv_mul_cancel_right],
  end }

end mul_action

/-- `smul` by a `k : M` over a ring is injective, if `k` is not a zero divisor.
The general theory of such `k` is elaborated by `is_smul_regular`.
The typeclass that restricts all terms of `M` to have this property is `no_zero_smul_divisors`. -/
lemma smul_cancel_of_non_zero_divisor {M R : Type*}
  [monoid M] [non_unital_non_assoc_ring R] [distrib_mul_action M R]
  (k : M) (h : ∀ (x : R), k • x = 0 → x = 0) {a b : R} (h' : k • a = k • b) :
  a = b :=
begin
  rw ←sub_eq_zero,
  refine h _ _,
  rw [smul_sub, h', sub_self]
end

namespace subgroup

variables {G : Type*} [group G] (H : subgroup G)

lemma normal_core_eq_ker :
  H.normal_core = (mul_action.to_perm_hom G (G ⧸ H)).ker :=
begin
  refine le_antisymm (λ g hg, equiv.perm.ext (λ q, quotient_group.induction_on q
    (λ g', (mul_action.quotient.smul_mk H g g').trans (quotient_group.eq.mpr _))))
    (subgroup.normal_le_normal_core.mpr (λ g hg, _)),
  { rw [smul_eq_mul, mul_inv_rev, ←inv_inv g', inv_inv],
    exact H.normal_core.inv_mem hg g'⁻¹ },
  { rw [←H.inv_mem_iff, ←mul_one g⁻¹, ←quotient_group.eq, ←mul_one g],
    exact (mul_action.quotient.smul_mk H g 1).symm.trans (equiv.perm.ext_iff.mp hg (1 : G)) },
end

noncomputable instance fintype_quotient_normal_core [fintype (G ⧸ H)] :
  fintype (G ⧸ H.normal_core) :=
begin
  rw H.normal_core_eq_ker,
  classical,
  exact fintype.of_equiv _ (quotient_group.quotient_ker_equiv_range _).symm.to_equiv,
end

end subgroup


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

! This file was ported from Lean 3 source module order.antisymmetrization
! leanprover-community/mathlib commit f1a2caaf51ef593799107fe9a8d5e411599f3996
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Hom.Basic
import Mathlib.Logic.Relation

/-!
# Turning a preorder into a partial order

This file allows to make a preorder into a partial order by quotienting out the elements `a`, `b`
such that `a ≤ b` and `b ≤ a`.

`Antisymmetrization` is a functor from `Preorder` to `PartialOrder`. See `Preorder_to_PartialOrder`.

## Main declarations

* `AntisymmRel`: The antisymmetrization relation. `AntisymmRel r a b` means that `a` and `b` are
  related both ways by `r`.
* `Antisymmetrization α r`: The quotient of `α` by `AntisymmRel r`. Even when `r` is just a
  preorder, `Antisymmetrization α` is a partial order.
-/

/- Porting Notes: There are many changes from `toAntisymmetrization (. ≤ .)` to
`@toAntisymmetrization α (· ≤ ·) _` -/

open Function OrderDual

variable {α β : Type _}

section Relation

variable (r : α → α → Prop)

/-- The antisymmetrization relation. -/
def AntisymmRel (a b : α) : Prop :=
  r a b ∧ r b a
#align antisymm_rel AntisymmRel

theorem antisymmRel_swap : AntisymmRel (swap r) = AntisymmRel r :=
  funext fun _ => funext fun _ => propext and_comm
#align antisymm_rel_swap antisymmRel_swap

@[refl]
theorem antisymmRel_refl [IsRefl α r] (a : α) : AntisymmRel r a a :=
  ⟨refl _, refl _⟩
#align antisymm_rel_refl antisymmRel_refl

variable {r}

@[symm]
theorem AntisymmRel.symm {a b : α} : AntisymmRel r a b → AntisymmRel r b a :=
  And.symm
#align antisymm_rel.symm AntisymmRel.symm

@[trans]
theorem AntisymmRel.trans [IsTrans α r] {a b c : α} (hab : AntisymmRel r a b)
    (hbc : AntisymmRel r b c) : AntisymmRel r a c :=
  ⟨_root_.trans hab.1 hbc.1, _root_.trans hbc.2 hab.2⟩
#align antisymm_rel.trans AntisymmRel.trans

instance AntisymmRel.decidableRel [DecidableRel r] : DecidableRel (AntisymmRel r) := fun _ _ =>
  instDecidableAnd
#align antisymm_rel.decidable_rel AntisymmRel.decidableRel

@[simp]
theorem antisymmRel_iff_eq [IsRefl α r] [IsAntisymm α r] {a b : α} : AntisymmRel r a b ↔ a = b :=
  antisymm_iff
#align antisymm_rel_iff_eq antisymmRel_iff_eq

alias antisymmRel_iff_eq ↔ AntisymmRel.eq _
#align antisymm_rel.eq AntisymmRel.eq

end Relation

section IsPreorder

variable (α) (r : α → α → Prop) [IsPreorder α r]

/-- The antisymmetrization relation as an equivalence relation. -/
@[simps]
def AntisymmRel.setoid : Setoid α :=
  ⟨AntisymmRel r, antisymmRel_refl _, AntisymmRel.symm, AntisymmRel.trans⟩
#align antisymm_rel.setoid AntisymmRel.setoid
#align antisymm_rel.setoid_r AntisymmRel.setoid_r

/-- The partial order derived from a preorder by making pairwise comparable elements equal. This is
the quotient by `fun a b => a ≤ b ∧ b ≤ a`. -/
def Antisymmetrization : Type _ :=
  Quotient <| AntisymmRel.setoid α r
#align antisymmetrization Antisymmetrization

variable {α}

/-- Turn an element into its antisymmetrization. -/
def toAntisymmetrization : α → Antisymmetrization α r :=
  Quotient.mk _
#align to_antisymmetrization toAntisymmetrization

/-- Get a representative from the antisymmetrization. -/
noncomputable def ofAntisymmetrization : Antisymmetrization α r → α :=
  Quotient.out'
#align of_antisymmetrization ofAntisymmetrization

instance [Inhabited α] : Inhabited (Antisymmetrization α r) :=
  by unfold Antisymmetrization; infer_instance

@[elab_as_elim]
protected theorem Antisymmetrization.ind {p : Antisymmetrization α r → Prop} :
    (∀ a, p <| toAntisymmetrization r a) → ∀ q, p q :=
  Quot.ind
#align antisymmetrization.ind Antisymmetrization.ind

@[elab_as_elim]
protected theorem Antisymmetrization.induction_on {p : Antisymmetrization α r → Prop}
    (a : Antisymmetrization α r) (h : ∀ a, p <| toAntisymmetrization r a) : p a :=
  Quotient.inductionOn' a h
#align antisymmetrization.induction_on Antisymmetrization.induction_on

@[simp]
theorem toAntisymmetrization_ofAntisymmetrization (a : Antisymmetrization α r) :
    toAntisymmetrization r (ofAntisymmetrization r a) = a :=
  Quotient.out_eq' _
#align to_antisymmetrization_of_antisymmetrization toAntisymmetrization_ofAntisymmetrization

end IsPreorder

section Preorder

variable [Preorder α] [Preorder β] {a b : α}

theorem AntisymmRel.image {a b : α} (h : AntisymmRel (· ≤ ·) a b) {f : α → β} (hf : Monotone f) :
    AntisymmRel (· ≤ ·) (f a) (f b) :=
  ⟨hf h.1, hf h.2⟩
#align antisymm_rel.image AntisymmRel.image

instance : PartialOrder (Antisymmetrization α (· ≤ ·)) where
  le a b :=
    (Quotient.liftOn₂' a b (· ≤ ·)) fun (_ _ _ _ : α) h₁ h₂ =>
      propext ⟨fun h => h₁.2.trans <| h.trans h₂.1, fun h => h₁.1.trans <| h.trans h₂.2⟩
  lt a b :=
    (Quotient.liftOn₂' a b (· < ·)) fun (_ _ _ _ : α) h₁ h₂ =>
      propext ⟨fun h => h₁.2.trans_lt <| h.trans_le h₂.1, fun h =>
                h₁.1.trans_lt <| h.trans_le h₂.2⟩
  le_refl a := Quotient.inductionOn' a <| le_refl
  le_trans a b c := Quotient.inductionOn₃' a b c fun _ _ _ => le_trans
  lt_iff_le_not_le a b := Quotient.inductionOn₂' a b fun _ _ => lt_iff_le_not_le
  le_antisymm a b := Quotient.inductionOn₂' a b fun _ _ hab hba => Quotient.sound' ⟨hab, hba⟩

theorem antisymmetrization_fibration :
    Relation.Fibration (· < ·) (· < ·) (@toAntisymmetrization α (· ≤ ·) _) := by
  rintro a ⟨b⟩ h
  exact ⟨b, h, rfl⟩
#align antisymmetrization_fibration antisymmetrization_fibration

theorem acc_antisymmetrization_iff : Acc (· < ·)
    (@toAntisymmetrization α (· ≤ ·) _ a) ↔ Acc (· < ·) a :=
  ⟨fun h =>
    haveI := InvImage.accessible _ h
    this,
    Acc.of_fibration _ antisymmetrization_fibration⟩
#align acc_antisymmetrization_iff acc_antisymmetrization_iff

theorem wellFounded_antisymmetrization_iff :
    WellFounded (@LT.lt (Antisymmetrization α (· ≤ ·)) _) ↔ WellFounded (@LT.lt α _) :=
  ⟨fun h => ⟨fun a => acc_antisymmetrization_iff.1 <| h.apply _⟩, fun h =>
    ⟨by
      rintro ⟨a⟩
      exact acc_antisymmetrization_iff.2 (h.apply a)⟩⟩
#align well_founded_antisymmetrization_iff wellFounded_antisymmetrization_iff

instance [WellFoundedLT α] : WellFoundedLT (Antisymmetrization α (· ≤ ·)) :=
  ⟨wellFounded_antisymmetrization_iff.2 IsWellFounded.wf⟩

instance [@DecidableRel α (· ≤ ·)] [@DecidableRel α (· < ·)] [IsTotal α (· ≤ ·)] :
    LinearOrder (Antisymmetrization α (· ≤ ·)) :=
  { instPartialOrderAntisymmetrizationLeToLEInstIsPreorderLeToLE with
    le_total := fun a b => Quotient.inductionOn₂' a b <| total_of (· ≤ ·),
    decidable_le := fun _ _ => show Decidable (Quotient.liftOn₂' _ _ _ _) from inferInstance,
    decidable_lt := fun _ _ => show Decidable (Quotient.liftOn₂' _ _ _ _) from inferInstance }

@[simp]
theorem toAntisymmetrization_le_toAntisymmetrization_iff :
    @toAntisymmetrization α (· ≤ ·) _ a ≤ @toAntisymmetrization α (· ≤ ·) _ b ↔ a ≤ b :=
  Iff.rfl
#align to_antisymmetrization_le_to_antisymmetrization_iff toAntisymmetrization_le_toAntisymmetrization_iff

@[simp]
theorem toAntisymmetrization_lt_toAntisymmetrization_iff :
    @toAntisymmetrization α (· ≤ ·) _ a < @toAntisymmetrization α (· ≤ ·) _ b ↔ a < b :=
  Iff.rfl
#align to_antisymmetrization_lt_to_antisymmetrization_iff toAntisymmetrization_lt_toAntisymmetrization_iff

@[simp]
theorem ofAntisymmetrization_le_ofAntisymmetrization_iff {a b : Antisymmetrization α (· ≤ ·)} :
    ofAntisymmetrization (· ≤ ·) a ≤ ofAntisymmetrization (· ≤ ·) b ↔ a ≤ b := by
  rw [← toAntisymmetrization_le_toAntisymmetrization_iff]
  simp
#align of_antisymmetrization_le_of_antisymmetrization_iff ofAntisymmetrization_le_ofAntisymmetrization_iff

@[simp]
theorem ofAntisymmetrization_lt_ofAntisymmetrization_iff {a b : Antisymmetrization α (· ≤ ·)} :
    ofAntisymmetrization (· ≤ ·) a < ofAntisymmetrization (· ≤ ·) b ↔ a < b := by
  rw [← toAntisymmetrization_lt_toAntisymmetrization_iff]
  simp
#align of_antisymmetrization_lt_of_antisymmetrization_iff ofAntisymmetrization_lt_ofAntisymmetrization_iff

@[mono]
theorem toAntisymmetrization_mono : Monotone (@toAntisymmetrization α (· ≤ ·) _) := fun _ _ => id
#align to_antisymmetrization_mono toAntisymmetrization_mono

private theorem lift_fun_antisymmRel (f : α →o β) :
    ((AntisymmRel.setoid α (· ≤ ·)).r ⇒ (AntisymmRel.setoid β (· ≤ ·)).r) f f := fun _ _ h =>
  ⟨f.mono h.1, f.mono h.2⟩

/-- Turns an order homomorphism from `α` to `β` into one from `Antisymmetrization α` to
`Antisymmetrization β`. `Antisymmetrization` is actually a functor. See `Preorder_to_PartialOrder`.
-/
protected def OrderHom.antisymmetrization (f : α →o β) :
    Antisymmetrization α (· ≤ ·) →o Antisymmetrization β (· ≤ ·) :=
  ⟨Quotient.map' f <| lift_fun_antisymmRel f, fun a b => Quotient.inductionOn₂' a b <| f.mono⟩
#align order_hom.antisymmetrization OrderHom.antisymmetrization

@[simp]
theorem OrderHom.coe_antisymmetrization (f : α →o β) :
    ⇑f.antisymmetrization = Quotient.map' f (lift_fun_antisymmRel f) :=
  rfl
#align order_hom.coe_antisymmetrization OrderHom.coe_antisymmetrization

/- Porting notes: Removed @[simp] attribute. With this `simp` lemma the LHS of
`OrderHom.antisymmetrization_apply_mk` is not in normal-form -/
theorem OrderHom.antisymmetrization_apply (f : α →o β) (a : Antisymmetrization α (· ≤ ·)) :
    f.antisymmetrization a = Quotient.map' f (lift_fun_antisymmRel f) a :=
  rfl
#align order_hom.antisymmetrization_apply OrderHom.antisymmetrization_apply

@[simp]
theorem OrderHom.antisymmetrization_apply_mk (f : α →o β) (a : α) :
    f.antisymmetrization (toAntisymmetrization _ a) = toAntisymmetrization _ (f a) :=
  @Quotient.map_mk _ _ (_root_.id _) (_root_.id _) f (lift_fun_antisymmRel f) _
#align order_hom.antisymmetrization_apply_mk OrderHom.antisymmetrization_apply_mk

variable (α)

/-- `ofAntisymmetrization` as an order embedding. -/
@[simps]
noncomputable def OrderEmbedding.ofAntisymmetrization : Antisymmetrization α (· ≤ ·) ↪o α where
  toFun := _root_.ofAntisymmetrization (. ≤ .)
  inj' _ _ := Quotient.out_inj.1
  map_rel_iff' := ofAntisymmetrization_le_ofAntisymmetrization_iff
#align order_embedding.of_antisymmetrization OrderEmbedding.ofAntisymmetrization
#align order_embedding.of_antisymmetrization_apply OrderEmbedding.ofAntisymmetrization_apply

/-- `Antisymmetrization` and `orderDual` commute. -/
def OrderIso.dualAntisymmetrization :
    (Antisymmetrization α (· ≤ ·))ᵒᵈ ≃o Antisymmetrization αᵒᵈ (· ≤ ·) where
  toFun := (Quotient.map' id) fun _ _ => And.symm
  invFun := (Quotient.map' id) fun _ _ => And.symm
  left_inv a := Quotient.inductionOn' a fun a => by simp_rw [Quotient.map'_mk'', id]
  right_inv a := Quotient.inductionOn' a fun a => by simp_rw [Quotient.map'_mk'', id]
  map_rel_iff' := @fun a b => Quotient.inductionOn₂' a b fun a b => Iff.rfl
#align order_iso.dual_antisymmetrization OrderIso.dualAntisymmetrization

@[simp]
theorem OrderIso.dualAntisymmetrization_apply (a : α) :
    OrderIso.dualAntisymmetrization _ (toDual <| toAntisymmetrization _ a) =
      toAntisymmetrization _ (toDual a) :=
  rfl
#align order_iso.dual_antisymmetrization_apply OrderIso.dualAntisymmetrization_apply

@[simp]
theorem OrderIso.dualAntisymmetrization_symm_apply (a : α) :
    (OrderIso.dualAntisymmetrization _).symm (toAntisymmetrization _ <| toDual a) =
      toDual (toAntisymmetrization _ a) :=
  rfl
#align order_iso.dual_antisymmetrization_symm_apply OrderIso.dualAntisymmetrization_symm_apply

end Preorder


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

universes u u_1

namespace Mathlib

/-!
# Lemmas about inequalities

This file contains some lemmas about `≤`/`≥`/`<`/`>`, and `cmp`.

* We simplify `a ≥ b` and `a > b` to `b ≤ a` and `b < a`, respectively. This way we can formulate
  all lemmas using `≤`/`<` avoiding duplication.

* In some cases we introduce dot syntax aliases so that, e.g., from
  `(hab : a ≤ b) (hbc : b ≤ c) (hbc' : b < c)` one can prove `hab.trans hbc : a ≤ c` and
  `hab.trans_lt hbc' : a < c`.
-/

theorem has_le.le.trans {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a ≤ b → b ≤ c → a ≤ c :=
  le_trans

theorem has_le.le.trans_lt {α : Type u} [preorder α] {a : α} {b : α} {c : α} :
    a ≤ b → b < c → a < c :=
  lt_of_le_of_lt

theorem has_le.le.antisymm {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b → b ≤ a → a = b :=
  le_antisymm

theorem has_le.le.lt_of_ne {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b → a ≠ b → a < b :=
  lt_of_le_of_ne

theorem has_le.le.lt_of_not_le {α : Type u} [preorder α] {a : α} {b : α} : a ≤ b → ¬b ≤ a → a < b :=
  lt_of_le_not_le

theorem has_le.le.lt_or_eq {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b → a < b ∨ a = b :=
  lt_or_eq_of_le

theorem has_lt.lt.le {α : Type u} [preorder α] {a : α} {b : α} : a < b → a ≤ b := le_of_lt

theorem has_lt.lt.trans {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a < b → b < c → a < c :=
  lt_trans

theorem has_lt.lt.trans_le {α : Type u} [preorder α] {a : α} {b : α} {c : α} :
    a < b → b ≤ c → a < c :=
  lt_of_lt_of_le

theorem has_lt.lt.ne {α : Type u} [preorder α] {a : α} {b : α} (h : a < b) : a ≠ b := ne_of_lt

theorem has_lt.lt.not_lt {α : Type u} [preorder α] {a : α} {b : α} (h : a < b) : ¬b < a := lt_asymm

theorem eq.le {α : Type u} [preorder α] {a : α} {b : α} : a = b → a ≤ b := le_of_eq

/-- A version of `le_refl` where the argument is implicit -/
theorem le_rfl {α : Type u} [preorder α] {x : α} : x ≤ x := le_refl x

namespace eq

/--
If `x = y` then `y ≤ x`. Note: this lemma uses `y ≤ x` instead of `x ≥ y`,
because `le` is used almost exclusively in mathlib.
-/
protected theorem ge {α : Type u} [preorder α] {x : α} {y : α} (h : x = y) : y ≤ x := le (Eq.symm h)

end eq

theorem eq.trans_le {α : Type u} [preorder α] {x : α} {y : α} {z : α} (h1 : x = y) (h2 : y ≤ z) :
    x ≤ z :=
  has_le.le.trans (eq.le h1) h2

namespace has_le.le

protected theorem ge {α : Type u} [HasLessEq α] {x : α} {y : α} (h : x ≤ y) : y ≥ x := h

theorem trans_eq {α : Type u} [preorder α] {x : α} {y : α} {z : α} (h1 : x ≤ y) (h2 : y = z) :
    x ≤ z :=
  trans h1 (eq.le h2)

theorem lt_iff_ne {α : Type u} [partial_order α] {x : α} {y : α} (h : x ≤ y) : x < y ↔ x ≠ y :=
  { mp := fun (h : x < y) => has_lt.lt.ne h, mpr := lt_of_ne h }

theorem le_iff_eq {α : Type u} [partial_order α] {x : α} {y : α} (h : x ≤ y) : y ≤ x ↔ y = x :=
  { mp := fun (h' : y ≤ x) => antisymm h' h, mpr := eq.le }

theorem lt_or_le {α : Type u} [linear_order α] {a : α} {b : α} (h : a ≤ b) (c : α) :
    a < c ∨ c ≤ b :=
  or.imp id (fun (hc : a ≥ c) => le_trans hc h) (lt_or_ge a c)

theorem le_or_lt {α : Type u} [linear_order α] {a : α} {b : α} (h : a ≤ b) (c : α) :
    a ≤ c ∨ c < b :=
  or.imp id (fun (hc : a > c) => lt_of_lt_of_le hc h) (le_or_gt a c)

theorem le_or_le {α : Type u} [linear_order α] {a : α} {b : α} (h : a ≤ b) (c : α) :
    a ≤ c ∨ c ≤ b :=
  or.elim (le_or_lt h c) Or.inl fun (h : c < b) => Or.inr (le_of_lt h)

end has_le.le

namespace has_lt.lt

protected theorem gt {α : Type u} [HasLess α] {x : α} {y : α} (h : x < y) : y > x := h

protected theorem false {α : Type u} [preorder α] {x : α} : x < x → False := lt_irrefl x

theorem ne' {α : Type u} [preorder α] {x : α} {y : α} (h : x < y) : y ≠ x := ne.symm (ne h)

theorem lt_or_lt {α : Type u} [linear_order α] {x : α} {y : α} (h : x < y) (z : α) :
    x < z ∨ z < y :=
  or.elim (lt_or_ge z y) Or.inr fun (hz : z ≥ y) => Or.inl (trans_le h hz)

end has_lt.lt

namespace ge

end ge

protected theorem ge.le {α : Type u} [HasLessEq α] {x : α} {y : α} (h : x ≥ y) : y ≤ x := h

namespace gt

end gt

protected theorem gt.lt {α : Type u} [HasLess α] {x : α} {y : α} (h : x > y) : y < x := h

theorem ge_of_eq {α : Type u} [preorder α] {a : α} {b : α} (h : a = b) : a ≥ b := eq.ge h

@[simp] theorem ge_iff_le {α : Type u} [preorder α] {a : α} {b : α} : a ≥ b ↔ b ≤ a := iff.rfl

@[simp] theorem gt_iff_lt {α : Type u} [preorder α] {a : α} {b : α} : a > b ↔ b < a := iff.rfl

theorem not_le_of_lt {α : Type u} [preorder α] {a : α} {b : α} (h : a < b) : ¬b ≤ a :=
  and.right (le_not_le_of_lt h)

theorem has_lt.lt.not_le {α : Type u} [preorder α] {a : α} {b : α} (h : a < b) : ¬b ≤ a :=
  not_le_of_lt

theorem not_lt_of_le {α : Type u} [preorder α] {a : α} {b : α} (h : a ≤ b) : ¬b < a :=
  fun (ᾰ : b < a) => idRhs False (has_lt.lt.not_le ᾰ h)

theorem has_le.le.not_lt {α : Type u} [preorder α] {a : α} {b : α} (h : a ≤ b) : ¬b < a :=
  not_lt_of_le

theorem le_iff_eq_or_lt {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b ↔ a = b ∨ a < b :=
  iff.trans le_iff_lt_or_eq or.comm

theorem lt_iff_le_and_ne {α : Type u} [partial_order α] {a : α} {b : α} : a < b ↔ a ≤ b ∧ a ≠ b :=
  sorry

theorem eq_iff_le_not_lt {α : Type u} [partial_order α] {a : α} {b : α} : a = b ↔ a ≤ b ∧ ¬a < b :=
  sorry

theorem eq_or_lt_of_le {α : Type u} [partial_order α] {a : α} {b : α} (h : a ≤ b) : a = b ∨ a < b :=
  or.symm (has_le.le.lt_or_eq h)

theorem has_le.le.eq_or_lt {α : Type u} [partial_order α] {a : α} {b : α} (h : a ≤ b) :
    a = b ∨ a < b :=
  eq_or_lt_of_le

theorem ne.le_iff_lt {α : Type u} [partial_order α] {a : α} {b : α} (h : a ≠ b) : a ≤ b ↔ a < b :=
  { mp := fun (h' : a ≤ b) => lt_of_le_of_ne h' h, mpr := fun (h : a < b) => has_lt.lt.le h }

@[simp] theorem ne_iff_lt_iff_le {α : Type u} [partial_order α] {a : α} {b : α} :
    a ≠ b ↔ a < b ↔ a ≤ b :=
  { mp := fun (h : a ≠ b ↔ a < b) => classical.by_cases le_of_eq (le_of_lt ∘ iff.mp h),
    mpr := fun (h : a ≤ b) => { mp := lt_of_le_of_ne h, mpr := ne_of_lt } }

theorem lt_of_not_ge' {α : Type u} [linear_order α] {a : α} {b : α} (h : ¬b ≤ a) : a < b :=
  has_le.le.lt_of_not_le (or.resolve_right (le_total a b) h) h

theorem lt_iff_not_ge' {α : Type u} [linear_order α] {x : α} {y : α} : x < y ↔ ¬y ≤ x :=
  { mp := not_le_of_gt, mpr := lt_of_not_ge' }

theorem le_of_not_lt {α : Type u} [linear_order α] {a : α} {b : α} : ¬a < b → b ≤ a := iff.mp not_lt

theorem lt_or_le {α : Type u} [linear_order α] (a : α) (b : α) : a < b ∨ b ≤ a := lt_or_ge

theorem le_or_lt {α : Type u} [linear_order α] (a : α) (b : α) : a ≤ b ∨ b < a := le_or_gt

theorem ne.lt_or_lt {α : Type u} [linear_order α] {a : α} {b : α} (h : a ≠ b) : a < b ∨ b < a :=
  lt_or_gt_of_ne h

theorem not_lt_iff_eq_or_lt {α : Type u} [linear_order α] {a : α} {b : α} :
    ¬a < b ↔ a = b ∨ b < a :=
  iff.trans not_lt (iff.trans le_iff_eq_or_lt (or_congr eq_comm iff.rfl))

theorem exists_ge_of_linear {α : Type u} [linear_order α] (a : α) (b : α) :
    ∃ (c : α), a ≤ c ∧ b ≤ c :=
  sorry

theorem lt_imp_lt_of_le_imp_le {α : Type u} {β : Type u_1} [linear_order α] [preorder β] {a : α}
    {b : α} {c : β} {d : β} (H : a ≤ b → c ≤ d) (h : d < c) : b < a :=
  lt_of_not_ge' fun (h' : a ≤ b) => has_le.le.not_lt (H h') h

theorem le_imp_le_of_lt_imp_lt {α : Type u} {β : Type u_1} [preorder α] [linear_order β] {a : α}
    {b : α} {c : β} {d : β} (H : d < c → b < a) (h : a ≤ b) : c ≤ d :=
  le_of_not_gt fun (h' : c > d) => has_lt.lt.not_le (H h') h

theorem le_imp_le_iff_lt_imp_lt {α : Type u} {β : Type u_1} [linear_order α] [linear_order β]
    {a : α} {b : α} {c : β} {d : β} : a ≤ b → c ≤ d ↔ d < c → b < a :=
  { mp := lt_imp_lt_of_le_imp_le, mpr := le_imp_le_of_lt_imp_lt }

theorem lt_iff_lt_of_le_iff_le' {α : Type u} {β : Type u_1} [preorder α] [preorder β] {a : α}
    {b : α} {c : β} {d : β} (H : a ≤ b ↔ c ≤ d) (H' : b ≤ a ↔ d ≤ c) : b < a ↔ d < c :=
  iff.trans lt_iff_le_not_le (iff.trans (and_congr H' (not_congr H)) (iff.symm lt_iff_le_not_le))

theorem lt_iff_lt_of_le_iff_le {α : Type u} {β : Type u_1} [linear_order α] [linear_order β] {a : α}
    {b : α} {c : β} {d : β} (H : a ≤ b ↔ c ≤ d) : b < a ↔ d < c :=
  iff.trans (iff.symm not_le) (iff.trans (not_congr H) not_le)

theorem le_iff_le_iff_lt_iff_lt {α : Type u} {β : Type u_1} [linear_order α] [linear_order β]
    {a : α} {b : α} {c : β} {d : β} : a ≤ b ↔ c ≤ d ↔ (b < a ↔ d < c) :=
  { mp := lt_iff_lt_of_le_iff_le,
    mpr := fun (H : b < a ↔ d < c) => iff.trans (iff.symm not_lt) (iff.trans (not_congr H) not_lt) }

theorem eq_of_forall_le_iff {α : Type u} [partial_order α] {a : α} {b : α}
    (H : ∀ (c : α), c ≤ a ↔ c ≤ b) : a = b :=
  le_antisymm (iff.mp (H a) (le_refl a)) (iff.mpr (H b) (le_refl b))

theorem le_of_forall_le {α : Type u} [preorder α] {a : α} {b : α} (H : ∀ (c : α), c ≤ a → c ≤ b) :
    a ≤ b :=
  H a (le_refl a)

theorem le_of_forall_le' {α : Type u} [preorder α] {a : α} {b : α} (H : ∀ (c : α), a ≤ c → b ≤ c) :
    b ≤ a :=
  H a (le_refl a)

theorem le_of_forall_lt {α : Type u} [linear_order α] {a : α} {b : α}
    (H : ∀ (c : α), c < a → c < b) : a ≤ b :=
  le_of_not_lt fun (h : b < a) => lt_irrefl b (H b h)

theorem forall_lt_iff_le {α : Type u} [linear_order α] {a : α} {b : α} :
    (∀ {c : α}, c < a → c < b) ↔ a ≤ b :=
  { mp := le_of_forall_lt, mpr := fun (h : a ≤ b) (c : α) (hca : c < a) => lt_of_lt_of_le hca h }

theorem le_of_forall_lt' {α : Type u} [linear_order α] {a : α} {b : α}
    (H : ∀ (c : α), a < c → b < c) : b ≤ a :=
  le_of_not_lt fun (h : a < b) => lt_irrefl b (H b h)

theorem forall_lt_iff_le' {α : Type u} [linear_order α] {a : α} {b : α} :
    (∀ {c : α}, a < c → b < c) ↔ b ≤ a :=
  { mp := le_of_forall_lt', mpr := fun (h : b ≤ a) (c : α) (hac : a < c) => lt_of_le_of_lt h hac }

theorem eq_of_forall_ge_iff {α : Type u} [partial_order α] {a : α} {b : α}
    (H : ∀ (c : α), a ≤ c ↔ b ≤ c) : a = b :=
  le_antisymm (iff.mpr (H b) (le_refl b)) (iff.mp (H a) (le_refl a))

/-- monotonicity of `≤` with respect to `→` -/
theorem le_implies_le_of_le_of_le {α : Type u} {a : α} {b : α} {c : α} {d : α} [preorder α]
    (h₀ : c ≤ a) (h₁ : b ≤ d) : a ≤ b → c ≤ d :=
  fun (h₂ : a ≤ b) => le_trans (le_trans h₀ h₂) h₁

namespace decidable

-- See Note [decidable namespace]

theorem le_imp_le_iff_lt_imp_lt {α : Type u} {β : Type u_1} [linear_order α] [linear_order β]
    {a : α} {b : α} {c : β} {d : β} : a ≤ b → c ≤ d ↔ d < c → b < a :=
  { mp := lt_imp_lt_of_le_imp_le, mpr := le_imp_le_of_lt_imp_lt }

-- See Note [decidable namespace]

theorem le_iff_le_iff_lt_iff_lt {α : Type u} {β : Type u_1} [linear_order α] [linear_order β]
    {a : α} {b : α} {c : β} {d : β} : a ≤ b ↔ c ≤ d ↔ (b < a ↔ d < c) :=
  { mp := lt_iff_lt_of_le_iff_le,
    mpr := fun (H : b < a ↔ d < c) => iff.trans (iff.symm not_lt) (iff.trans (not_congr H) not_lt) }

end decidable

/-- Like `cmp`, but uses a `≤` on the type instead of `<`. Given two elements
`x` and `y`, returns a three-way comparison result `ordering`. -/
def cmp_le {α : Type u_1} [HasLessEq α] [DecidableRel LessEq] (x : α) (y : α) : ordering :=
  ite (x ≤ y) (ite (y ≤ x) ordering.eq ordering.lt) ordering.gt

theorem cmp_le_swap {α : Type u_1} [HasLessEq α] [is_total α LessEq] [DecidableRel LessEq] (x : α)
    (y : α) : ordering.swap (cmp_le x y) = cmp_le y x :=
  sorry

theorem cmp_le_eq_cmp {α : Type u_1} [preorder α] [is_total α LessEq] [DecidableRel LessEq]
    [DecidableRel Less] (x : α) (y : α) : cmp_le x y = cmp x y :=
  sorry

namespace ordering

/-- `compares o a b` means that `a` and `b` have the ordering relation
  `o` between them, assuming that the relation `a < b` is defined -/
@[simp] def compares {α : Type u} [HasLess α] : ordering → α → α → Prop := sorry

theorem compares_swap {α : Type u} [HasLess α] {a : α} {b : α} {o : ordering} :
    compares (swap o) a b ↔ compares o b a :=
  ordering.cases_on o iff.rfl eq_comm iff.rfl

theorem compares.of_swap {α : Type u} [HasLess α] {a : α} {b : α} {o : ordering} :
    compares (swap o) a b → compares o b a :=
  iff.mp compares_swap

theorem swap_eq_iff_eq_swap {o : ordering} {o' : ordering} : swap o = o' ↔ o = swap o' := sorry

theorem compares.eq_lt {α : Type u} [preorder α] {o : ordering} {a : α} {b : α} :
    compares o a b → (o = lt ↔ a < b) :=
  sorry

theorem compares.ne_lt {α : Type u} [preorder α] {o : ordering} {a : α} {b : α} :
    compares o a b → (o ≠ lt ↔ b ≤ a) :=
  sorry

theorem compares.eq_eq {α : Type u} [preorder α] {o : ordering} {a : α} {b : α} :
    compares o a b → (o = eq ↔ a = b) :=
  sorry

theorem compares.eq_gt {α : Type u} [preorder α] {o : ordering} {a : α} {b : α}
    (h : compares o a b) : o = gt ↔ b < a :=
  iff.trans (iff.symm swap_eq_iff_eq_swap) (compares.eq_lt (compares.swap h))

theorem compares.ne_gt {α : Type u} [preorder α] {o : ordering} {a : α} {b : α}
    (h : compares o a b) : o ≠ gt ↔ a ≤ b :=
  iff.trans (not_congr (iff.symm swap_eq_iff_eq_swap)) (compares.ne_lt (compares.swap h))

theorem compares.le_total {α : Type u} [preorder α] {a : α} {b : α} {o : ordering} :
    compares o a b → a ≤ b ∨ b ≤ a :=
  sorry

theorem compares.le_antisymm {α : Type u} [preorder α] {a : α} {b : α} {o : ordering} :
    compares o a b → a ≤ b → b ≤ a → a = b :=
  sorry

theorem compares.inj {α : Type u} [preorder α] {o₁ : ordering} {o₂ : ordering} {a : α} {b : α} :
    compares o₁ a b → compares o₂ a b → o₁ = o₂ :=
  sorry

theorem compares_iff_of_compares_impl {α : Type u} {β : Type u_1} [linear_order α] [preorder β]
    {a : α} {b : α} {a' : β} {b' : β} (h : ∀ {o : ordering}, compares o a b → compares o a' b')
    (o : ordering) : compares o a b ↔ compares o a' b' :=
  sorry

theorem swap_or_else (o₁ : ordering) (o₂ : ordering) :
    swap (or_else o₁ o₂) = or_else (swap o₁) (swap o₂) :=
  ordering.cases_on o₁ (Eq.refl (swap (or_else lt o₂))) (Eq.refl (swap (or_else eq o₂)))
    (Eq.refl (swap (or_else gt o₂)))

theorem or_else_eq_lt (o₁ : ordering) (o₂ : ordering) :
    or_else o₁ o₂ = lt ↔ o₁ = lt ∨ o₁ = eq ∧ o₂ = lt :=
  ordering.cases_on o₁
    (ordering.cases_on o₂ (of_as_true trivial) (of_as_true trivial) (of_as_true trivial))
    (ordering.cases_on o₂ (of_as_true trivial) (of_as_true trivial) (of_as_true trivial))
    (ordering.cases_on o₂ (of_as_true trivial) (of_as_true trivial) (of_as_true trivial))

end ordering

theorem cmp_compares {α : Type u} [linear_order α] (a : α) (b : α) :
    ordering.compares (cmp a b) a b :=
  sorry

theorem cmp_swap {α : Type u} [preorder α] [DecidableRel Less] (a : α) (b : α) :
    ordering.swap (cmp a b) = cmp b a :=
  sorry

/-- Generate a linear order structure from a preorder and `cmp` function. -/
def linear_order_of_compares {α : Type u} [preorder α] (cmp : α → α → ordering)
    (h : ∀ (a b : α), ordering.compares (cmp a b) a b) : linear_order α :=
  linear_order.mk preorder.le preorder.lt preorder.le_refl preorder.le_trans sorry sorry
    (fun (a b : α) => decidable_of_iff (cmp a b ≠ ordering.gt) sorry)
    (fun (a b : α) => decidable_of_iff (cmp a b = ordering.eq) sorry)
    fun (a b : α) => decidable_of_iff (cmp a b = ordering.lt) sorry

@[simp] theorem cmp_eq_lt_iff {α : Type u} [linear_order α] (x : α) (y : α) :
    cmp x y = ordering.lt ↔ x < y :=
  ordering.compares.eq_lt (cmp_compares x y)

@[simp] theorem cmp_eq_eq_iff {α : Type u} [linear_order α] (x : α) (y : α) :
    cmp x y = ordering.eq ↔ x = y :=
  ordering.compares.eq_eq (cmp_compares x y)

@[simp] theorem cmp_eq_gt_iff {α : Type u} [linear_order α] (x : α) (y : α) :
    cmp x y = ordering.gt ↔ y < x :=
  ordering.compares.eq_gt (cmp_compares x y)

@[simp] theorem cmp_self_eq_eq {α : Type u} [linear_order α] (x : α) : cmp x x = ordering.eq :=
  eq.mpr (id (Eq._oldrec (Eq.refl (cmp x x = ordering.eq)) (propext (cmp_eq_eq_iff x x))))
    (Eq.refl x)

theorem cmp_eq_cmp_symm {α : Type u} [linear_order α] {x : α} {y : α} {β : Type u_1}
    [linear_order β] {x' : β} {y' : β} : cmp x y = cmp x' y' ↔ cmp y x = cmp y' x' :=
  sorry

theorem lt_iff_lt_of_cmp_eq_cmp {α : Type u} [linear_order α] {x : α} {y : α} {β : Type u_1}
    [linear_order β] {x' : β} {y' : β} (h : cmp x y = cmp x' y') : x < y ↔ x' < y' :=
  sorry

theorem le_iff_le_of_cmp_eq_cmp {α : Type u} [linear_order α] {x : α} {y : α} {β : Type u_1}
    [linear_order β] {x' : β} {y' : β} (h : cmp x y = cmp x' y') : x ≤ y ↔ x' ≤ y' :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Yury Kudryashov
-/
import algebra.category.Group.basic
import category_theory.concrete_category.reflects_isomorphisms
import category_theory.elementwise
import algebra.ring.equiv

/-!
# Category instances for semiring, ring, comm_semiring, and comm_ring.

We introduce the bundled categories:
* `SemiRing`
* `Ring`
* `CommSemiRing`
* `CommRing`
along with the relevant forgetful functors between them.
-/

universes u v

open category_theory

/-- The category of semirings. -/
def SemiRing : Type (u+1) := bundled semiring

namespace SemiRing

/-- `ring_hom` doesn't actually assume associativity. This alias is needed to make the category
theory machinery work. We use the same trick in `category_theory.Mon.assoc_monoid_hom`. -/
abbreviation assoc_ring_hom (M N : Type*) [semiring M] [semiring N] := ring_hom M N

instance bundled_hom : bundled_hom assoc_ring_hom :=
⟨λ M N [semiring M] [semiring N], by exactI @ring_hom.to_fun M N _ _,
 λ M [semiring M], by exactI @ring_hom.id M _,
 λ M N P [semiring M] [semiring N] [semiring P], by exactI @ring_hom.comp M N P _ _ _,
 λ M N [semiring M] [semiring N], by exactI @ring_hom.coe_inj M N _ _⟩

attribute [derive [large_category, concrete_category]] SemiRing

instance : has_coe_to_sort SemiRing Type* := bundled.has_coe_to_sort

/-- Construct a bundled SemiRing from the underlying type and typeclass. -/
def of (R : Type u) [semiring R] : SemiRing := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `SemiRing`. -/
def of_hom {R S : Type u} [semiring R] [semiring S] (f : R →+* S) : of R ⟶ of S := f

@[simp] lemma of_hom_apply {R S : Type u} [semiring R] [semiring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited SemiRing := ⟨of punit⟩

instance (R : SemiRing) : semiring R := R.str

@[simp] lemma coe_of (R : Type u) [semiring R] : (SemiRing.of R : Type u) = R := rfl

instance has_forget_to_Mon : has_forget₂ SemiRing Mon :=
bundled_hom.mk_has_forget₂
  (λ R hR, @monoid_with_zero.to_monoid R (@semiring.to_monoid_with_zero R hR))
  (λ R₁ R₂, ring_hom.to_monoid_hom) (λ _ _ _, rfl)

instance has_forget_to_AddCommMon : has_forget₂ SemiRing AddCommMon :=
-- can't use bundled_hom.mk_has_forget₂, since AddCommMon is an induced category
{ forget₂ :=
  { obj := λ R, AddCommMon.of R,
    map := λ R₁ R₂ f, ring_hom.to_add_monoid_hom f } }

end SemiRing

/-- The category of rings. -/
def Ring : Type (u+1) := bundled ring

namespace Ring

instance : bundled_hom.parent_projection @ring.to_semiring := ⟨⟩

attribute [derive [(λ Ring, has_coe_to_sort Ring Type*), large_category, concrete_category]] Ring

/-- Construct a bundled Ring from the underlying type and typeclass. -/
def of (R : Type u) [ring R] : Ring := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `Ring`. -/
def of_hom {R S : Type u} [ring R] [ring S] (f : R →+* S) : of R ⟶ of S := f

@[simp] lemma of_hom_apply {R S : Type u} [ring R] [ring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited Ring := ⟨of punit⟩

instance (R : Ring) : ring R := R.str

@[simp] lemma coe_of (R : Type u) [ring R] : (Ring.of R : Type u) = R := rfl

instance has_forget_to_SemiRing : has_forget₂ Ring SemiRing := bundled_hom.forget₂ _ _
instance has_forget_to_AddCommGroup : has_forget₂ Ring AddCommGroup :=
-- can't use bundled_hom.mk_has_forget₂, since AddCommGroup is an induced category
{ forget₂ :=
  { obj := λ R, AddCommGroup.of R,
    map := λ R₁ R₂ f, ring_hom.to_add_monoid_hom f } }

end Ring

/-- The category of commutative semirings. -/
def CommSemiRing : Type (u+1) := bundled comm_semiring

namespace CommSemiRing

instance : bundled_hom.parent_projection @comm_semiring.to_semiring := ⟨⟩

attribute [derive [large_category, concrete_category]] CommSemiRing

instance : has_coe_to_sort CommSemiRing Type* := bundled.has_coe_to_sort

/-- Construct a bundled CommSemiRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_semiring R] : CommSemiRing := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `CommSemiRing`. -/
def of_hom {R S : Type u} [comm_semiring R] [comm_semiring S] (f : R →+* S) : of R ⟶ of S := f

@[simp]
lemma of_hom_apply {R S : Type u} [comm_semiring R] [comm_semiring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited CommSemiRing := ⟨of punit⟩

instance (R : CommSemiRing) : comm_semiring R := R.str

@[simp] lemma coe_of (R : Type u) [comm_semiring R] : (CommSemiRing.of R : Type u) = R := rfl

instance has_forget_to_SemiRing : has_forget₂ CommSemiRing SemiRing := bundled_hom.forget₂ _ _

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
instance has_forget_to_CommMon : has_forget₂ CommSemiRing CommMon :=
has_forget₂.mk'
  (λ R : CommSemiRing, CommMon.of R) (λ R, rfl)
  (λ R₁ R₂ f, f.to_monoid_hom) (by tidy)

end CommSemiRing

/-- The category of commutative rings. -/
def CommRing : Type (u+1) := bundled comm_ring

namespace CommRing

instance : bundled_hom.parent_projection @comm_ring.to_ring := ⟨⟩

attribute [derive [large_category, concrete_category]] CommRing

instance : has_coe_to_sort CommRing Type* := bundled.has_coe_to_sort

/-- Construct a bundled CommRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_ring R] : CommRing := bundled.of R

/-- Typecheck a `ring_hom` as a morphism in `CommRing`. -/
def of_hom {R S : Type u} [comm_ring R] [comm_ring S] (f : R →+* S) : of R ⟶ of S := f

@[simp] lemma of_hom_apply {R S : Type u} [comm_ring R] [comm_ring S] (f : R →+* S) (x : R) :
  of_hom f x = f x := rfl

instance : inhabited CommRing := ⟨of punit⟩

instance (R : CommRing) : comm_ring R := R.str

@[simp] lemma coe_of (R : Type u) [comm_ring R] : (CommRing.of R : Type u) = R := rfl

instance has_forget_to_Ring : has_forget₂ CommRing Ring := bundled_hom.forget₂ _ _

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
instance has_forget_to_CommSemiRing : has_forget₂ CommRing CommSemiRing :=
has_forget₂.mk' (λ R : CommRing, CommSemiRing.of R) (λ R, rfl) (λ R₁ R₂ f, f) (by tidy)

instance : full (forget₂ CommRing CommSemiRing) :=
{ preimage := λ X Y f, f, }

end CommRing

-- This example verifies an improvement possible in Lean 3.8.
-- Before that, to have `add_ring_hom.map_zero` usable by `simp` here,
-- we had to mark all the concrete category `has_coe_to_sort` instances reducible.
-- Now, it just works.
example {R S : CommRing} (i : R ⟶ S) (r : R) (h : r = 0) : i r = 0 :=
by simp [h]

namespace ring_equiv

variables {X Y : Type u}

/-- Build an isomorphism in the category `Ring` from a `ring_equiv` between `ring`s. -/
@[simps] def to_Ring_iso [ring X] [ring Y] (e : X ≃+* Y) : Ring.of X ≅ Ring.of Y :=
{ hom := e.to_ring_hom,
  inv := e.symm.to_ring_hom }

/-- Build an isomorphism in the category `CommRing` from a `ring_equiv` between `comm_ring`s. -/
@[simps] def to_CommRing_iso [comm_ring X] [comm_ring Y] (e : X ≃+* Y) :
  CommRing.of X ≅ CommRing.of Y :=
{ hom := e.to_ring_hom,
  inv := e.symm.to_ring_hom }

end ring_equiv

namespace category_theory.iso

/-- Build a `ring_equiv` from an isomorphism in the category `Ring`. -/
def Ring_iso_to_ring_equiv {X Y : Ring} (i : X ≅ Y) : X ≃+* Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_mul'  := by tidy }.

/-- Build a `ring_equiv` from an isomorphism in the category `CommRing`. -/
def CommRing_iso_to_ring_equiv {X Y : CommRing} (i : X ≅ Y) : X ≃+* Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_mul'  := by tidy }.

@[simp]
lemma CommRing_iso_to_ring_equiv_to_ring_hom {X Y : CommRing} (i : X ≅ Y) :
  i.CommRing_iso_to_ring_equiv.to_ring_hom = i.hom := by { ext, refl }

@[simp]
lemma CommRing_iso_to_ring_equiv_symm_to_ring_hom {X Y : CommRing} (i : X ≅ Y) :
  i.CommRing_iso_to_ring_equiv.symm.to_ring_hom = i.inv := by { ext, refl }

end category_theory.iso

/-- Ring equivalences between `ring`s are the same as (isomorphic to) isomorphisms in `Ring`. -/
def ring_equiv_iso_Ring_iso {X Y : Type u} [ring X] [ring Y] :
  (X ≃+* Y) ≅ (Ring.of X ≅ Ring.of Y) :=
{ hom := λ e, e.to_Ring_iso,
  inv := λ i, i.Ring_iso_to_ring_equiv, }

/-- Ring equivalences between `comm_ring`s are the same as (isomorphic to) isomorphisms
in `CommRing`. -/
def ring_equiv_iso_CommRing_iso {X Y : Type u} [comm_ring X] [comm_ring Y] :
  (X ≃+* Y) ≅ (CommRing.of X ≅ CommRing.of Y) :=
{ hom := λ e, e.to_CommRing_iso,
  inv := λ i, i.CommRing_iso_to_ring_equiv, }

instance Ring.forget_reflects_isos : reflects_isomorphisms (forget Ring.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Ring).map f),
    let e : X ≃+* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Ring_iso).1⟩,
  end }

instance CommRing.forget_reflects_isos : reflects_isomorphisms (forget CommRing.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget CommRing).map f),
    let e : X ≃+* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_CommRing_iso).1⟩,
  end }

-- It would be nice if we could have the following,
-- but it requires making `reflects_isomorphisms_forget₂` an instance,
-- which can cause typeclass loops:

local attribute [priority 50,instance] reflects_isomorphisms_forget₂
example : reflects_isomorphisms (forget₂ Ring AddCommGroup) := by apply_instance


import data.equiv.basic
import data.equiv.list
import data.equiv.fin
import data.finmap
import order.lexicographic

universe u

inductive vonNeumann
  | N
  | E
  | S
  | W

open vonNeumann

def vonNeumann.to_fin4 (dir : vonNeumann) : fin 4 :=
  match dir with
  | N := 0
  | E := 1
  | S := 2
  | W := 3
  end

def fin.to_vonNeumann  : fin 4 → vonNeumann
  | ⟨0, _⟩ := N
  | ⟨1, _⟩ := E
  | ⟨2, _⟩ := S
  | ⟨3, _⟩ := W
  | ⟨n+4, p⟩ := false.rec vonNeumann (not_le.mpr p ((4 : ℕ).le_add_left n))

lemma vonNeumann.aux (x : fin 4) : x.to_vonNeumann.to_fin4 = x :=
  match x with
  | ⟨0, _⟩ := rfl
  | ⟨1, _⟩ := rfl
  | ⟨2, _⟩ := rfl
  | ⟨3, _⟩ := rfl
  | ⟨n+4, p⟩ := false.rec _ (not_le.mpr p ((4 : ℕ).le_add_left n))
  end

def vonNeumann_fin4 : vonNeumann ≃ fin 4 :=
{
  to_fun := vonNeumann.to_fin4,
  inv_fun := fin.to_vonNeumann,
  left_inv := λ x, by {cases x; unfold vonNeumann.to_fin4; refl},
  right_inv := λ x, by {apply vonNeumann.aux}
}

example {α β} (eqi : α ≃ β) : α ↪ β := equiv.to_embedding eqi

instance : fintype vonNeumann :=
  {
    elems := (fintype.elems (fin 4)).map vonNeumann_fin4.symm.to_embedding,
    complete := λ nv, finset.mem_map_equiv.mpr (fintype.complete _)
  }

prefix `¡`:50 := equiv.perm

class neighborhood (α : Type) :=
  (size : nat)
  (to_ix' : α ≃ fin size)
  ( rotate_clockwise : ¡α)
  (reflect : ¡α)

def to_ix {α} [neighborhood α] : α ≃ fin (neighborhood.size α) := neighborhood.to_ix'

def vonNeumann.rotate_clockwise' : vonNeumann → vonNeumann
  | N := E
  | E := S
  | S := W
  | W := N

def vonNeumann.rotate_positive' : vonNeumann → vonNeumann
  | N := W
  | E := N
  | S := E
  | W := S

def vonNeumann.reflect' : vonNeumann → vonNeumann
  | E := W
  | W := E
  | x := x

instance : neighborhood vonNeumann :=
  {
    size := 4,
    to_ix' := vonNeumann_fin4,
    rotate_clockwise :=
     {
      to_fun := vonNeumann.rotate_clockwise',
      inv_fun := vonNeumann.rotate_positive',
      left_inv := by {intro x, cases x; unfold vonNeumann.rotate_clockwise' vonNeumann.rotate_positive'},
      right_inv := by {intro x, cases x; unfold vonNeumann.rotate_clockwise' vonNeumann.rotate_positive'},
     },
    reflect :=
    {
      to_fun := vonNeumann.reflect',
      inv_fun := vonNeumann.reflect',
      left_inv := by {intro x, cases x; unfold vonNeumann.reflect'},
      right_inv := by {intro x, cases x; unfold vonNeumann.reflect'},
     }
  }

def rotate_clockwise {α} [neighborhood α] : α ≃ α := neighborhood.rotate_clockwise
def reflect_nh {α} [neighborhood α] : α ≃ α := neighborhood.reflect

def linear_order.preimage {α β : Type} (f : α ↪ β) [lo : linear_order β] : linear_order α :=
{
  le := λ x y, f x ≤ f y,

  le_refl := λ x, linear_order.le_refl (f x),

  le_antisymm := λ (x y : α) x_y y_x, function.embedding.injective f (linear_order.le_antisymm (f x) (f y) x_y y_x),

  le_trans := λ (x y z : α), linear_order.le_trans (f x) (f y) (f z),

  le_total := λ (a b : α), linear_order.le_total (f a) (f b),

  decidable_le := λ a b, if h : f a ≤ f b then is_true h else is_false h
}

inductive inside_outside : Type
  | inside
  | outside

open inside_outside

instance : decidable_eq inside_outside
  | inside inside := is_true rfl
  | outside outside := is_true rfl
  | inside outside := is_false (by {apply inside_outside.no_confusion})
  | outside inside := is_false (by {apply inside_outside.no_confusion})

def inside_outside.to_bool : inside_outside ≃ bool := {
  to_fun := (= inside),
  inv_fun := λ b, if b then inside else outside,
  left_inv := by {
    intros io,
    cases io,
    simp,
    simp,
  },

  right_inv := fun b, by {
    cases b; simp,
  }
}

def inside_outside.to_fin2 : inside_outside ≃ fin 2 :=
  equiv.trans inside_outside.to_bool fin_two_equiv.symm

open vonNeumann

def equiv.on_prod {α α' β β'} (f : α ≃ α') (g : β ≃ β') : (α × β) ≃ (α' × β') :=
{
  to_fun := λ p, ⟨f p.1, g p.2⟩,
  inv_fun := λ p, ⟨f.inv_fun p.1, g.inv_fun p.2⟩,
  left_inv := by {
    intros p,
    obtain ⟨a, b⟩ := p,
    simp only,
    obtain ⟨f,f_inv,f_left,f_right⟩ := f,
    obtain ⟨g,g_inv,g_left,g_right⟩ := g,
    simp only,
    simp_rw equiv.coe_fn_mk,
    congr, {apply f_left}, {apply g_left}
  },

  right_inv := by {
    intros p,
    obtain ⟨a, b⟩ := p,
    simp only,
    obtain ⟨f,f_inv,f_left,f_right⟩ := f,
    obtain ⟨g,g_inv,g_left,g_right⟩ := g,
    simp only,
    simp_rw equiv.coe_fn_mk,
    congr, {apply f_right}, {apply g_right}
  },

}

structure xcell (α : Type u) := (to_array : array 4 α)

def xcell.read {α} (c : xcell α) (dir : vonNeumann) : α := c.to_array.read (vonNeumann_fin4 dir)
def xcell.write {α} (c : xcell α) (dir : vonNeumann) (a : α) : xcell α :=
  ⟨c.to_array.write (vonNeumann_fin4 dir) a⟩

@[ext]
lemma xcell.ext {α} (a b : xcell α) : (∀ vn, a.read vn = b.read vn) ↔ a = b :=
by {
  split,
  {
    intros hyp,
    obtain ⟨a⟩ := a, obtain ⟨b⟩ := b,
    congr,
    ext,
    transitivity ({xcell . to_array := a}.read (vonNeumann_fin4.inv_fun i)),
      {unfold xcell.read, simp},
      {rw hyp, unfold xcell.read, simp}
  },
  {
    intros hyp,
    simp_rw hyp,
    intros vn,
    refl,
  },
}

def template.read_aux : (inside_outside × vonNeumann) ≃ fin 8 :=
  equiv.trans (equiv.on_prod inside_outside.to_fin2 vonNeumann_fin4) fin_prod_fin_equiv

structure template (α : Type) := (to_array : array (8) α)

def template.read_fun {α} (arr : template α) (io : inside_outside) (dir : vonNeumann) : α :=
  arr.to_array.read (template.read_aux (io, dir))

def template.read_inv {α} (f : inside_outside → vonNeumann → α) : template α :=
  ⟨⟨λ ix, function.uncurry f (template.read_aux.inv_fun ix)⟩⟩

lemma equiv.coe_coe_symm {α β} (π : α ≃ β) (b : β) : π (π.symm b) = b :=
by {
  cases π,
  simp,
  rw π_right_inv,
}

lemma equiv.coe_symm_coe {α β} (π : α ≃ β) (a : α) : π.symm (π a) = a :=
by {
  cases π,
  simp,
  rw π_left_inv,
}

def template.read {α} : template α ≃ (inside_outside → vonNeumann → α) :=
{
  to_fun := template.read_fun,
  inv_fun := template.read_inv,
  left_inv := λ x,
  by {
    obtain ⟨⟨f⟩⟩ := x,
    unfold template.read_fun template.read_inv,
    congr,
    funext,
    unfold function.uncurry template.read_fun,
    simp,
    unfold array.read d_array.read,
  },
  right_inv := λ f,
  by {
    funext,
    unfold template.read_fun template.read_inv,
    simp only [equiv.inv_fun_as_coe],
    unfold array.read d_array.read,
    simp only,
    have : ((template.read_aux.symm) (template.read_aux (io, dir))) = (io, dir) := equiv.coe_coe_symm _ _,
    rw this,
    rw function.uncurry,
  }
}

@[ext]
lemma template.ext {α} (x y : template α) : x.read = y.read → x = y :=
by {
  intro hyp,
  exact template.read.apply_eq_iff_eq.mp hyp
}

def rule (α) := (template α → template α → Prop)

structure board (n m : ℕ) (α : Type u) : Type u :=
  mk :: (to_array : array n (array m (xcell α)))

def board.read {n m} {α} (mat : board n m α) (p : fin n × fin m) := (mat.to_array.read p.1).read p.2

@[simp]
lemma board.read.def {n m : ℕ} {α : Type u} (mat : board n m α) (ix : fin n) (iy : fin m) :
  mat.read ⟨ix, iy⟩ = (mat.to_array.read ix).read iy := rfl

open vonNeumann

def vonNeumann.to_index {n m} : vonNeumann → fin (n+1) × fin (m+1)
  | N := (0, -1)
  | E := (1, 0)
  | S := (0, 1)
  | W := (-1, 0)

def vonNeumann.neg : vonNeumann → vonNeumann
  | N := S
  | E := W
  | S := N
  | W := E

instance : has_neg vonNeumann := ⟨vonNeumann.neg⟩

lemma vonNeumann.neg_involution (dir : vonNeumann) : -(-dir) = dir :=
  match dir with
  | N := rfl
  | E := rfl
  | S := rfl
  | W := rfl
  end

def read_template.aux {n m} {α : Type}
  (mat : board (n+1) (m+1) α)
  (ix : fin (n+1) × fin (m+1)) : inside_outside → vonNeumann → α
  | inside dir := (mat.read ix).read dir
  | outside dir :=
    let offset : (fin (n+1) × fin (m+1)) := dir.to_index in
    (mat.read (ix.1 + offset.1, ix.2 + offset.2)).read (-dir)

def read_template {n m} {α : Type}
  (mat : board (n+1) (m+1) α)
  (ix : fin (n+1) × fin (m+1)) :
  template α := template.read.symm (read_template.aux mat ix)

instance : functor template := {
  map := λ α β f t, ⟨f <$> t.to_array⟩,
  map_const := λ α β (f : α) t, ⟨f <$ t.to_array⟩
}

lemma template.map.def {α β} {f : α → β} {t : template α} : f <$> t = template.mk (f <$> t.to_array) := rfl

lemma template.comp_map (α β γ : Type)
  (f : α → β)
  (g : β → γ)
  (t : array 8 α) :
  (g ∘ f) <$> t = g <$> f <$> t := by {
  simp only,
  apply is_lawful_functor.comp_map
}

instance : is_lawful_functor template := {
  id_map := λ α ⟨t⟩, by {have := id_map t, rw template.map.def, simp only, apply this},
  comp_map := λ α β γ f g ⟨t⟩, by {have := comp_map f g t, simp_rw template.map.def, apply this},
}

def template.seq {α β : Type} : template (α → β) → template α → template β
  | f x := template.mk (⟨λ ix, f.to_array.read ix $ x.to_array.read ix⟩)

instance : applicative template := {
  seq := λ _ _, template.seq ,
  pure := λ α a, ⟨⟨λ _, a⟩⟩,
}

def vonNeumann.decidable_eq.aux {α} [decidable_eq α] (f g : vonNeumann → α) : decidable (∀ x, f x = g x) :=
  if h : f N = g N ∧ f E = g E ∧ f S = g S ∧ f W = g W
    then is_true (by {rcases h with ⟨h_n, h_e, h_s, h_w⟩, intros x, cases x; assumption})
    else is_false (λ all, h (by {simp_rw all, repeat {split; try {refl}}}))

instance {α} [decidable_eq α] : decidable_eq (xcell α) :=
  by {
    intros a b,
    rw ← xcell.ext,
    apply vonNeumann.decidable_eq.aux,
  }

def array.to_template (arr : array 8 (fin 2)) : template bool := ⟨arr.map (λ n, if n = 0 then tt else ff)⟩
def array.last {α n} (arr : array (n+1) α) := arr.read (fin.last n)

@[simp]
lemma array.last_def {α n} (arr : array (n+1) α) : arr.last = arr.read (fin.last n) := rfl

instance {α} [linear_order α] : linear_order (template α) :=
  linear_order.preimage (by {
    refine function.embedding.trans ⟨template.to_array, _⟩ ⟨array.to_list, _⟩; intros x y,
    {
      cases x; cases y,
      simp only,
      intro h; exact h,
    },
    {
      intro inj_hyp,
      transitivity x.to_list.to_array,
      have H := (array.to_list_to_array x).symm,
      apply H.elim, refl,
      have H := (array.to_list_to_array y),
      apply H.elim,
      congr' 1,
    }
  })

def array.rev {α} {n} (arr : array (n+1) α) : array (n+1) α := ⟨λ ix, arr.read (fin.last n - ix)⟩

notation `#[` arr:(foldr `,` (h t, array.push_back t h) array.nil `]`) := arr.rev

def array.to_vector {n α} (arr : array n α) : vector α n :=
  ⟨arr.to_list, array.to_list_length arr⟩

def array.to_templates ( arr : array 2 (array 8 (fin 2))) : (template bool × template bool) :=
  match (arr.map array.to_template).to_vector with
  | ⟨[old, new], _⟩ := ⟨old, new⟩
  end

abbreviation ACA_rules.from_list (rule_list : list (array 2 (array 8 (fin 2)))) (lhs rhs : template bool) : Prop :=
  (lhs, rhs) ∈ (rule_list.map array.to_templates)

instance : ∀ (rules : list _), decidable_rel (ACA_rules.from_list rules)
  | [] lhs rhs := is_false (by {apply list.not_mem_nil})
  | (x::xs) lhs rhs :=
    if h : (lhs, rhs) = x.to_templates
      then is_true (or.inl h)
      else match ACA_rules.from_list.decidable_rel xs lhs rhs with
        | is_true ih := is_true (or.inr ih)
        | is_false ih := is_false (λ hyp, or.dcases_on hyp h ih)
        end

def convert_from_dixons : array 8 (fin 2) → array 8 (fin 2)
  | arr :=
    match arr.to_vector with
    | ⟨[i_top, i_bottom, i_left, i_right, o_top, o_bottom, o_left, o_right], p⟩ := -- T, B, L, R order
      #[i_top, i_right, i_bottom, i_left, o_top, o_right, o_bottom, o_left] -- N, E, S, W order!
    end

def array.from_dixons (arr : array 8 (fin 2)) : template bool := ⟨(convert_from_dixons arr).map fin_two_equiv⟩

inductive LAR
  | L --left
  | A -- Across
  | R -- Right

open LAR

inductive WB
  | E -- Empty
  | F -- Full
open WB

instance : decidable_eq WB
  | E E := is_true rfl
  | F F := is_true rfl
  | E F := is_false (by {apply WB.no_confusion})
  | F E := is_false (by {apply WB.no_confusion})

inductive bcell -- a two cell
  | EE -- empty
  | FF -- full
  | HH -- half empty :
  -- out cell on source (head)
  -- in cell on target (co-head) (a cohead is a head in the overlapping template)
open bcell

instance : decidable_eq bcell :=
  by {
    intros x y,
    cases x; cases y; try {exact is_true rfl}; apply is_false; apply bcell.no_confusion
  }

instance : has_coe WB bcell :=
  has_coe.mk $ λ wb,
    match wb with
    | E := EE
    | F := FF
    end

def vonNeumann.move : LAR → vonNeumann ≃ vonNeumann
  | L := rotate_clockwise.trans (rotate_clockwise.trans rotate_clockwise)
  | A := rotate_clockwise.trans rotate_clockwise
  | R := rotate_clockwise

instance : decidable_eq vonNeumann := equiv.decidable_eq vonNeumann_fin4

structure lhs_template_body :=
  (at_L : WB)
  (at_A : WB)
  (at_R : WB)

structure lhs_template :=
  (head : vonNeumann)
  (body : lhs_template_body)

structure rhs_template :=
  (old_head : WB)
  (at_L : bcell)
  (at_A : bcell)
  (at_R : bcell)

open lhs_template
open rhs_template

instance : decidable_eq lhs_template
  | ⟨vn, l, a, r⟩ ⟨vn', l', a', r'⟩ :=
    if h : vn = vn' ∧ l = l' ∧ a = a' ∧ r = r'
      then is_true (by {obtain ⟨vn_h, l_h, a_h, r_h⟩ := h, congr; assumption})
      else is_false (by {intros target, injection target, injection h_2, apply h, repeat {split}; assumption})

instance : decidable_eq rhs_template
  | ⟨wb, l, a, r⟩ ⟨wb', l', a', r'⟩ :=
    if h : wb = wb' ∧ l = l' ∧ a = a' ∧ r = r'
      then is_true (by {obtain ⟨vn_h, l_h, a_h, r_h⟩ := h, congr; assumption})
      else is_false (by {intros target, injection target, apply h, repeat {split}; assumption})

instance : has_coe_to_fun lhs_template :=
  {
    F := λ _, LAR → WB,
    coe := λ t lar,
    match lar with
    | L := lhs_template_body.at_L (lhs_template.body t)
    | A := lhs_template_body.at_A (lhs_template.body t)
    | R := lhs_template_body.at_R (lhs_template.body t)
    end
  }

@[simp]
lemma lhs_at_L (lhs : lhs_template) : lhs L = lhs.body.at_L := rfl
@[simp]
lemma lhs_at_A (lhs : lhs_template) : lhs A = lhs.body.at_A := rfl
@[simp]
lemma lhs_at_R (lhs : lhs_template) : lhs R = lhs.body.at_R := rfl

instance : has_coe_to_fun rhs_template :=
  {
    F := λ _, LAR → bcell,
    coe := λ (t : rhs_template) lar,
    match lar with
    | L := rhs_template.at_L t
    | A := rhs_template.at_A t
    | R := rhs_template.at_R t
    end
  }

@[simp]
lemma rhs_at_L (rhs : rhs_template) : rhs L = at_L rhs := rfl
@[simp]
lemma rhs_at_A (rhs : rhs_template) : rhs A = at_A rhs := rfl
@[simp]
lemma rhs_at_R (rhs : rhs_template) : rhs R = at_R rhs := rfl

inductive LHZ_base : lhs_template -> rhs_template -> Type
| move_forward          : ∀ nv, LHZ_base ⟨nv, E, E, E⟩ ⟨E, EE, HH, EE⟩
| turn_left_head_on     : ∀ nv, LHZ_base ⟨nv, E, F, E⟩ ⟨E, EE, FF, HH⟩
| turn_right            : ∀ nv, LHZ_base ⟨nv, E, E, F⟩ ⟨E, HH, EE, FF⟩
| toggle_memory         : ∀ nv, LHZ_base ⟨nv, F, F, E⟩ ⟨F, EE, HH, FF⟩

def rotate_with_head (lhs_head : vonNeumann) : vonNeumann ≃ vonNeumann :=
  match lhs_head with
  | N := vonNeumann.move L
  | E := vonNeumann.move A
  | S := vonNeumann.move R
  | W := equiv.refl vonNeumann
  end

namespace lhs_template

def aux₂ (lhsb : lhs_template_body) (io : inside_outside) (vn : vonNeumann) : bool:=
  match vn with
  | N := ite (lhsb.at_L = F) tt ff
  | E := ite (lhsb.at_A = F) tt ff
  | S := ite (lhsb.at_R = F) tt ff
  | W := ite (io = outside) tt ff
  end

end lhs_template

instance : linear_order inside_outside :=
  linear_order.lift inside_outside.to_fin2 inside_outside.to_fin2.injective

instance : fintype inside_outside :=
  fintype.of_equiv (fin 2) inside_outside.to_fin2.symm

def inside_outside.repr : inside_outside → string
  | inside := "inside"
  | outside := "inside"

def vonNeumann.repr : vonNeumann → string
| N := "N"
| E := "E"
| S := "S"
| W := "W"

instance : has_repr inside_outside := ⟨inside_outside.repr⟩
instance : has_repr vonNeumann := ⟨vonNeumann.repr⟩

namespace lhs_template

def in_order := [(inside, N), (inside, E), (inside, S), (inside, W), (inside, N), (inside, E), (inside, S), (inside, W)]

open function

lemma aux₂_injective : function.injective aux₂ :=
by {
  intros x y h,
  have : in_order.map (uncurry (aux₂ x)) = in_order.map (uncurry (aux₂ y)) := by {rw h},
  clear h, rename this h,
  cases x; cases x_at_L; cases x_at_A; cases x_at_R;
    cases y; cases y_at_L; cases y_at_A; cases y_at_R,
  all_goals {
    try {refl},
  },
  all_goals {
    unfold in_order at h,
    simp_rw [list.map_cons, list.map_nil, function.uncurry_def] at h,
    unfold aux₂ at h,
    simp at h,
    cases h,
  }
}

def to_template (lhs : lhs_template) : template bool :=
  template.read.inv_fun (λ io vn, aux₂ lhs.body io (rotate_with_head (lhs.head) vn))

def is_head (f : inside_outside → bool) : Prop :=
  f inside = ff ∧ f outside = tt

lemma head_at_head.aux (lhsb : lhs_template_body) (vn : vonNeumann) : is_head (λ io, aux₂ lhsb io vn) ↔ vn = W :=
by {
  unfold is_head,
  cases vn,
  case W {
    apply iff_of_true _ rfl,
    funext,
    unfold aux₂,
    split,
    apply if_neg, {intros h, cases h},
    apply if_pos, {refl}
  },
  all_goals {
    apply iff_of_false _,
    {
      intro h,
      cases h,
    },
    intros crazy,
    obtain ⟨inside_crazy, outside_crazy⟩ := crazy,
    have : ff = tt,
    unfold aux₂ at *,
    transitivity ite (_ = F) tt ff,
    symmetry,
    exact inside_crazy,
    exact outside_crazy,
    cases this,
  },
}

def is_head_at (t : template bool) (vn : vonNeumann) : Prop :=
  is_head (λ io, template.read t io vn)

lemma head_at_head (lhs : lhs_template) :
  is_head_at (lhs.to_template) lhs.head :=
by {
  cases lhs; cases lhs_head,
  all_goals {
      unfold lhs_template.to_template is_head_at,
      simp,
      rw head_at_head.aux,
      unfold rotate_with_head,
      try {unfold vonNeumann.move,
        try {simp_rw equiv.coe_trans},
        unfold rotate_clockwise,
        unfold_projs,
        rw ← equiv.to_fun_as_coe,
        simp only [function.comp_app],
        unfold rotate_clockwise'
      },
  },
  {
    rw equiv.coe_refl,
    rw id,
  }
}

lemma not_head_at_not_head (lhs : lhs_template) (vn : vonNeumann)  (vn_neq_lhs_head : vn ≠ lhs.head) :
  ¬ is_head_at (lhs.to_template) vn :=
  match lhs, vn, vn_neq_lhs_head with
  | {head := N, body := _}, N, p :=
    λ _ , false.rec false (p (eq.refl N))
  | {head := E, body := _}, E, p :=
    λ _ , false.rec false (p (eq.refl E))
  | {head := S, body := _}, S, p :=
    λ _ , false.rec false (p (eq.refl S))
  | {head := W, body := _}, W, p :=
    λ _ , false.rec false (p (eq.refl W))

  -- head := N
  | {head := N, body := _}, E, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := N, body := _}, S, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := N, body := _}, W, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }

  -- head := E
  | {head := E, body := _}, N, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := E, body := _}, S, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := E, body := _}, W, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }

    -- head := S
  | {head := S, body := _}, N, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := S, body := _}, E, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := S, body := _}, W, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }

  -- head := W
  | {head := W, body := _}, N, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := W, body := _}, E, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  | {head := W, body := _}, S, p :=
    by {
      unfold is_head_at lhs_template.to_template,
      simp,
      unfold rotate_with_head,
      try {
        unfold vonNeumann.move,
        unfold_coes,
        unfold rotate_clockwise,
        unfold_projs,
        unfold vonNeumann.rotate_clockwise'
      },
      rw head_at_head.aux,
      apply vonNeumann.no_confusion,
    }
  end

lemma iff_head_at_head (lhs : lhs_template) (vn : vonNeumann) :
  (vn = lhs.head) ↔ is_head_at lhs.to_template vn :=
by {
  split; intros h,
  {rw h, exact head_at_head lhs},
  {contrapose h, exact not_head_at_not_head lhs vn h}
}

lemma to_template_injective : function.injective lhs_template.to_template :=
  by {
    intros x y h,
    have x_head_eq_y_head : x.head = y.head,
    rw iff_head_at_head,
    rw ← h,
    exact head_at_head x,
    cases x; cases y; simp at *,
    rw x_head_eq_y_head at *, clear x_head_eq_y_head x_head,
    split, {refl},
    unfold lhs_template.to_template at h, simp at h,
    set f := rotate_with_head y_head,
    have : aux₂ x_body = aux₂ y_body,
    funext,
    have : ∃ vn', vn = f vn' := ⟨f.inv_fun vn, _⟩,
    obtain ⟨vn', vn_eq ⟩ := this,
    rw vn_eq,
    transitivity (λ (io : inside_outside) (vn : vonNeumann), aux₂ x_body io (f vn)) io vn',
    {simp},
    {rw h},
    rw ← equiv.to_fun_as_coe,
    rw f.right_inv,
    apply aux₂_injective this,
  }

end lhs_template

def on_bcell : bcell → inside_outside → bool
| FF _ := tt
| EE _ := ff
| HH io := if io = inside then tt else ff

def rhs_template.to_template (rhs : rhs_template) (lhs_head : vonNeumann) : template bool :=
  let as_fun (io : inside_outside) (vn : vonNeumann) : bool :=
    match vn with
    | N := on_bcell rhs.at_L io
    | E := on_bcell rhs.at_A io
    | S := on_bcell rhs.at_R io
    | W := to_bool (rhs.old_head = F)
    end in
  template.read.inv_fun (λ io nv, as_fun io (rotate_with_head lhs_head nv))

def template.print {α} (to_char : α → char) (t : template α) : string :=
  match t.to_array.to_vector with
  | ⟨[i_north, i_east, i_south, i_west, o_north, o_east, o_south, o_west], _⟩ :=
    "\n  " ++ ⟨[to_char o_north]⟩ ++ "  \n" ++
    "  " ++ ⟨[to_char i_north]⟩ ++ "  \n" ++
    ⟨[to_char o_west, to_char i_west, ' ', to_char i_east, to_char o_east]⟩ ++ "\n" ++
    "  " ++ ⟨[to_char i_south]⟩ ++ "  \n" ++
    "  " ++ ⟨[to_char o_south]⟩ ++ "  \n"
  end

instance : has_to_string (template bool) := ⟨template.print (λ b, if b then '╬' else '█')⟩

lemma LHZ_base.unique (l r) (a b : LHZ_base l r) : a = b :=
  by {cases a; cases b; refl}

def LHZ_any := Σ' l r, ∃ x : LHZ_base l r, true

instance : decidable_eq LHZ_any
  | ⟨a_l, a_r, a_h⟩ ⟨b_l, b_r, b_h⟩ :=
  if h : a_l = b_l
  then is_true
    (by {
      obtain ⟨a_h, _x⟩ := a_h, cases _x,
      obtain ⟨b_h, _x⟩ := b_h, cases _x,
      cases a_h; cases b_h; cases h; refl,
    })
  else is_false
    (by {
      intros target,
      injection target,
      exact h h_1,
    })

def vn_to_LHZ (vn : vonNeumann) : list LHZ_any :=
  [ ⟨_, _, LHZ_base.move_forward vn, true.intro⟩
  , ⟨_, _, LHZ_base.turn_left_head_on vn, true.intro⟩
  , ⟨_, _, LHZ_base.turn_right vn, true.intro⟩
  , ⟨_, _, LHZ_base.toggle_memory vn, true.intro⟩
  ]

lemma vn_to_LHZ.complete  (l r) (x : LHZ_base l r) :
  (⟨l,r,x,true.intro⟩ : LHZ_any) ∈ vn_to_LHZ (l.head):=
by {
  unfold vn_to_LHZ,
  cases x; cases x_1; simp,
}

def LHZ.elems := ([N, E, S, W].bind vn_to_LHZ)

lemma LHZ.elems.complete : ∀ (x : LHZ_any), x ∈ LHZ.elems
  | ⟨l, r, x, true.intro⟩ := by {
    unfold LHZ.elems; unfold list.bind; unfold list.map,
    rw list.mem_join,
    cases x with vn vn vn vn,
    all_goals
      {
        cases vn,
        case N {use vn_to_LHZ N, simp, apply vn_to_LHZ.complete},
        case E {use vn_to_LHZ E, simp, apply vn_to_LHZ.complete},
        case S {use vn_to_LHZ S, simp, apply vn_to_LHZ.complete},
        case W {use vn_to_LHZ W, simp, apply vn_to_LHZ.complete},
    }
  }

instance : fintype LHZ_any :=
{
  elems := LHZ.elems.to_finset,

  complete := LHZ.elems.complete
}

inductive LHZ : template bool → template bool → Prop
  | mk : ∀ lhs rhs, LHZ_base lhs rhs → LHZ (lhs.to_template) (rhs.to_template (head lhs))

infixr ` ~> ` :40 := λ α β, finmap (λ _ : α, β)

def LHZ_any.to_pair : LHZ_any → (Σ _:lhs_template, rhs_template)
  | ⟨l, r, _⟩ := ⟨l, r⟩

def LHZ_base.finmap : lhs_template ~> rhs_template :=
  (LHZ.elems.map LHZ_any.to_pair).to_finmap

lemma list.map_nodup {α β : Type u}
  (f : α → β) (f_inj : function.injective f)
  (l : list α) :
  l.nodup ↔ (l.map f).nodup :=
by {
  unfold list.nodup,
  induction l,
  {rw list.map_nil, exact iff_of_true list.pairwise.nil list.pairwise.nil},
  {
    rw list.map_cons,
    simp_rw list.pairwise_cons,
    have : ∀ (a b c d : Prop), (b ↔ d) → (a ↔ c) → (a ∧ b ↔ c ∧ d),
    {
      clear_except,
      intros a b c d b_d a_c,
      split; intros h; obtain ⟨x, y⟩ := h,
      {rw [← b_d, ← a_c], split; assumption},
      {rw [b_d, a_c], split; assumption}
    },
    apply this; clear this,
    {exact l_ih},
    split; intros h a a_in crazy; rw ← crazy at a_in; clear crazy,
    {apply h l_hd, rw ← list.mem_map_of_injective f_inj, exact a_in, refl},
    {apply h (f l_hd), rw list.mem_map_of_injective f_inj, exact a_in, refl}
  }
}

section finmap_bimap

variables {α α' : Type u} {β : α → Type u} {β' : α' → Type u}
variables (m : finmap β)
variables (f : (Σ x, β x) → (Σ x, β' x))

def list.nodupkeys_map
  (l : list (Σ x, β x)) (l_nodupkeys : l.nodupkeys) :
  (∀ (a₁ a₂ : Σ x, β x), (f a₁).1 = (f a₂).1 → a₁.1 = a₂.1) → (l.map f).nodupkeys :=
by {
  intros f_hyp,
  induction l,
  apply list.nodupkeys_nil,
  rw list.map_cons,
  apply list.nodupkeys_cons.mpr,
  rw list.nodupkeys_cons at l_nodupkeys,
  obtain ⟨nodupkeys_hd, nodupkeys_tl⟩ := l_nodupkeys,
  split,
  {
    intro crazy,
    unfold list.keys at crazy,
    simp_rw list.mem_map at crazy,
    obtain ⟨x, ⟨y, y_in_l_tl, f_y_eq_x⟩, crazy⟩ := crazy,
    rw ← f_y_eq_x at *, clear' x f_y_eq_x,
    have : y.fst = l_hd.fst := f_hyp y l_hd crazy,
    rw ← this at nodupkeys_hd,
    rw list.mem_keys at nodupkeys_hd,
    apply nodupkeys_hd,
    use y.snd,
    simp,
    apply y_in_l_tl,
  },
  {exact l_ih nodupkeys_tl},
}

def finmap.bimap (f_hyp : _)
  : finmap β' :=
  { finmap .
    entries := m.entries.map f,
    nodupkeys := by {
      cases m,
      simp,
      induction m_entries,
      simp at *,
      apply @list.nodupkeys_map; try {assumption},
      refl,
    }
  }

end finmap_bimap

def LHZ.finmap.aux : (Σ (x : lhs_template), rhs_template) → (Σ (x : template bool), template bool)
  | ⟨lhs, rhs⟩ := ⟨lhs.to_template, rhs.to_template lhs.head⟩

def LHZ.finmap : template bool ~> template bool :=
  (LHZ_base.finmap).bimap LHZ.finmap.aux (by {
    intros a₁ a₂ h,
    obtain ⟨l₁, r₁⟩ := a₁,
    obtain ⟨l₂, r₂⟩ := a₂,
    unfold LHZ.finmap.aux at h,
    simp at *,
    clear_except h,

  })

def board.write {n m : ℕ} {α} (mat : board n m α) (pos : fin n × fin m) (a : xcell α) : board n m α :=
  ⟨mat.to_array.write pos.1 ((mat.to_array.read pos.1).write pos.2 a)⟩

def write_template.aux {n m} {α : Type}
  (mat : board (n+1) (m+1) α)
  (ix : fin (n+1) × fin (m+1)) : inside_outside → vonNeumann → α → board (n+1) (m+1) α
  | inside  dir a := let old := (mat.read ix) in mat.write ix (old.write dir a)
  | outside dir a :=
    let offset : (fin (n+1) × fin (m+1)) := dir.to_index in
    let ix' := (ix.1 + offset.1, ix.2 + offset.2) in
    let old := (mat.read ix') in
    mat.write ix (old.write (-dir) a)

def write_template {n m : ℕ} {α : Type}
  (M : board (n+1) (m+1) α) (ix : fin (n+1) × fin (m+1)) (t : template α) :
  board (n+1) (m+1) α :=
  let action_list : list (board (n+1) (m+1) α → board (n+1) (m+1) α) :=
    do
    i_o <- [inside, outside],
    dir <- [N, E, S, W],
    pure (λ m : board (n+1) (m+1) α, write_template.aux m ix i_o dir (template.read t i_o dir)) in
  action_list.foldl (λ m f, f m) M

example : ∀ n m : ℕ, n ≤ n + m := nat.le_add_right
example : ∀ n m : ℕ, n ≤ m → ¬ m < n := λ _ _, not_lt_of_le

inductive step {α} [linear_order α]
  {n m : ℕ} (mat : board (n+1) (m+1) α) :
  (template α → template α → Type) →
  board (n+1) (m+1) α → Type 2
  | intro :
  ∀ (p : fin (n+1) × fin (m+1))
    {rules : template α → template α → Type}
    (b : template α)
    (r_a_b : rules (read_template mat p) b),
    step rules (write_template mat p b)

inductive path {α} [linear_order α] (rules : template α → template α → Type) {n m : ℕ} (a : board (n+1) (m+1) α) :
  board (n+1) (m+1) α → Type 2
  | refl : path a
  | snoc : ∀ {b c} (tail : path b) (head : step b rules c), path c

def path.append {α} [linear_order α] (rules : template α → template α → Type) {n m : ℕ} {a b c : board (n+1) (m+1) α} :
  path rules a b → path rules b c → path rules a c :=
by {
  intros a_b b_c,
  induction b_c,
  case refl {exact a_b},
  case snoc {apply path.snoc b_c_ih b_c_head},
}

abbreviation is_head {n m} (mat : board (n+1) (m+1) bool)
  (pos : fin (n+1) × fin (m+1)) (vn : vonNeumann):=
  let t := (read_template mat pos).read in
    t outside vn = tt ∧ t inside vn = ff

abbreviation is_true_head {n m} (mat : board (n+1) (m+1) bool) (pos : fin (n+1) × fin (m+1)) : Type :=
  Σ' b, LHZ (read_template mat pos) b

lemma LHZ_base.targets_have_one_cohead : ∀ lhs rhs, LHZ_base lhs rhs -> ∃! dir : LAR, rhs dir = HH :=
  by {
    intros lhs rhs h,
    cases h,
    {
      use A,
      split,
      {simp},
      intro y; cases y; simp,
    },
    {
      use R,
      split,
      {simp},
      intro y; cases y; simp,
    },
    {
      use L,
      split,
      {simp},
      intro y; cases y; simp,
    },
    {
      use A,
      split,
      {simp},
      intro y; cases y; simp,
    },
  }