/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.group.defs
import data.equiv.set
import data.fun_like.basic
import logic.embedding
import order.rel_classes

/-!
# Relation homomorphisms, embeddings, isomorphisms

This file defines relation homomorphisms, embeddings, isomorphisms and order embeddings and
isomorphisms.

## Main declarations

* `rel_hom`: Relation homomorphism. A `rel_hom r s` is a function `f : α → β` such that
  `r a b → s (f a) (f b)`.
* `rel_embedding`: Relation embedding. A `rel_embedding r s` is an embedding `f : α ↪ β` such that
  `r a b ↔ s (f a) (f b)`.
* `rel_iso`: Relation isomorphism. A `rel_iso r s` is an equivalence `f : α ≃ β` such that
  `r a b ↔ s (f a) (f b)`.
* `sum_lex_congr`, `prod_lex_congr`: Creates a relation homomorphism between two `sum_lex` or two
  `prod_lex` from relation homomorphisms between their arguments.

## Notation

* `→r`: `rel_hom`
* `↪r`: `rel_embedding`
* `≃r`: `rel_iso`
-/

open function

universes u v w
variables {α β γ : Type*} {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop}

/-- A relation homomorphism with respect to a given pair of relations `r` and `s`
is a function `f : α → β` such that `r a b → s (f a) (f b)`. -/
@[nolint has_inhabited_instance]
structure rel_hom {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) :=
(to_fun : α → β)
(map_rel' : ∀ {a b}, r a b → s (to_fun a) (to_fun b))

infix ` →r `:25 := rel_hom

/-- `rel_hom_class F r s` asserts that `F` is a type of functions such that all `f : F`
satisfy `r a b → s (f a) (f b)`.

The relations `r` and `s` are `out_param`s since figuring them out from a goal is a higher-order
matching problem that Lean usually can't do unaided.
-/
class rel_hom_class (F : Type*) {α β : out_param $ Type*}
  (r : out_param $ α → α → Prop) (s : out_param $ β → β → Prop)
  extends fun_like F α (λ _, β) :=
(map_rel : ∀ (f : F) {a b}, r a b → s (f a) (f b))
export rel_hom_class (map_rel)

-- The free parameters `r` and `s` are `out_param`s so this is not dangerous.
attribute [nolint dangerous_instance] rel_hom_class.to_fun_like

namespace rel_hom_class

variables {F : Type*}

lemma map_inf [semilattice_inf α] [linear_order β]
  [rel_hom_class F ((<) : β → β → Prop) ((<) : α → α → Prop)]
  (a : F) (m n : β) : a (m ⊓ n) = a m ⊓ a n :=
(strict_mono.monotone $ λ x y, map_rel a).map_inf m n

lemma map_sup [semilattice_sup α] [linear_order β]
  [rel_hom_class F ((>) : β → β → Prop) ((>) : α → α → Prop)]
  (a : F) (m n : β) : a (m ⊔ n) = a m ⊔ a n :=
@map_inf (order_dual α) (order_dual β) _ _ _ _ _ _ _

protected theorem is_irrefl [rel_hom_class F r s] (f : F) : ∀ [is_irrefl β s], is_irrefl α r
| ⟨H⟩ := ⟨λ a h, H _ (map_rel f h)⟩

protected theorem is_asymm [rel_hom_class F r s] (f : F) : ∀ [is_asymm β s], is_asymm α r
| ⟨H⟩ := ⟨λ a b h₁ h₂, H _ _ (map_rel f h₁) (map_rel f h₂)⟩

protected theorem acc [rel_hom_class F r s] (f : F) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (map_rel f h) _ rfl⟩
end

protected theorem well_founded [rel_hom_class F r s] (f : F) :
  ∀ (h : well_founded s), well_founded r
| ⟨H⟩ := ⟨λ a, rel_hom_class.acc f _ (H _)⟩

end rel_hom_class

namespace rel_hom

instance : rel_hom_class (r →r s) r s :=
{ coe := λ o, o.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  map_rel := map_rel' }

/-- Auxiliary instance if `rel_hom_class.to_fun_like.to_has_coe_to_fun` isn't found -/
instance : has_coe_to_fun (r →r s) (λ _, α → β) := ⟨λ o, o.to_fun⟩

initialize_simps_projections rel_hom (to_fun → apply)

protected theorem map_rel (f : r →r s) : ∀ {a b}, r a b → s (f a) (f b) := f.map_rel'

@[simp] theorem coe_fn_mk (f : α → β) (o) :
  (@rel_hom.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_fun (f : r →r s) : (f.to_fun : α → β) = f := rfl

/-- The map `coe_fn : (r →r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r →r s) (α → β) coe_fn :=
fun_like.coe_injective

@[ext] theorem ext ⦃f g : r →r s⦄ (h : ∀ x, f x = g x) : f = g :=
fun_like.ext f g h

theorem ext_iff {f g : r →r s} : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

/-- Identity map is a relation homomorphism. -/
@[refl, simps] protected def id (r : α → α → Prop) : r →r r :=
⟨λ x, x, λ a b x, x⟩

/-- Composition of two relation homomorphisms is a relation homomorphism. -/
@[trans, simps] protected def comp (g : s →r t) (f : r →r s) : r →r t :=
⟨λ x, g (f x), λ a b h, g.2 (f.2 h)⟩

/-- A relation homomorphism is also a relation homomorphism between dual relations. -/
protected def swap (f : r →r s) : swap r →r swap s :=
⟨f, λ a b, f.map_rel⟩

/-- A function is a relation homomorphism from the preimage relation of `s` to `s`. -/
def preimage (f : α → β) (s : β → β → Prop) : f ⁻¹'o s →r s := ⟨f, λ a b, id⟩

end rel_hom

/-- An increasing function is injective -/
lemma injective_of_increasing (r : α → α → Prop) (s : β → β → Prop) [is_trichotomous α r]
  [is_irrefl β s] (f : α → β) (hf : ∀ {x y}, r x y → s (f x) (f y)) : injective f :=
begin
  intros x y hxy,
  rcases trichotomous_of r x y with h | h | h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this,
  exact h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this
end

/-- An increasing function is injective -/
lemma rel_hom.injective_of_increasing [is_trichotomous α r]
  [is_irrefl β s] (f : r →r s) : injective f :=
injective_of_increasing r s f (λ x y, f.map_rel)

-- TODO: define a `rel_iff_class` so we don't have to do all the `convert` trickery?
theorem surjective.well_founded_iff {f : α → β} (hf : surjective f)
  (o : ∀ {a b}, r a b ↔ s (f a) (f b)) : well_founded r ↔ well_founded s :=
iff.intro (begin
  refine rel_hom_class.well_founded (rel_hom.mk _ _ : s →r r),
  { exact classical.some hf.has_right_inverse },
  intros a b h, apply o.2, convert h,
  iterate 2 { apply classical.some_spec hf.has_right_inverse },
end) (rel_hom_class.well_founded (⟨f, λ _ _, o.1⟩ : r →r s))

/-- A relation embedding with respect to a given pair of relations `r` and `s`
is an embedding `f : α ↪ β` such that `r a b ↔ s (f a) (f b)`. -/
structure rel_embedding {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ↪ β :=
(map_rel_iff' : ∀ {a b}, s (to_embedding a) (to_embedding b) ↔ r a b)

infix ` ↪r `:25 := rel_embedding

/-- The induced relation on a subtype is an embedding under the natural inclusion. -/
definition subtype.rel_embedding {X : Type*} (r : X → X → Prop) (p : X → Prop) :
  ((subtype.val : subtype p → X) ⁻¹'o r) ↪r r :=
⟨embedding.subtype p, λ x y, iff.rfl⟩

theorem preimage_equivalence {α β} (f : α → β) {s : β → β → Prop}
  (hs : equivalence s) : equivalence (f ⁻¹'o s) :=
⟨λ a, hs.1 _, λ a b h, hs.2.1 h, λ a b c h₁ h₂, hs.2.2 h₁ h₂⟩

namespace rel_embedding

/-- A relation embedding is also a relation homomorphism -/
def to_rel_hom (f : r ↪r s) : (r →r s) :=
{ to_fun := f.to_embedding.to_fun,
  map_rel' := λ x y, (map_rel_iff' f).mpr }

instance : has_coe (r ↪r s) (r →r s) := ⟨to_rel_hom⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ↪r s) (λ _, α → β) := ⟨λ o, o.to_embedding⟩

-- TODO: define and instantiate a `rel_embedding_class` when `embedding_like` is defined
instance : rel_hom_class (r ↪r s) r s :=
{ coe := coe_fn,
  coe_injective' := λ f g h, by { rcases f with ⟨⟨⟩⟩, rcases g with ⟨⟨⟩⟩, congr' },
  map_rel := λ f a b, iff.mpr (map_rel_iff' f) }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (h : r ↪r s) : α → β := h

initialize_simps_projections rel_embedding (to_embedding_to_fun → apply, -to_embedding)

@[simp] lemma to_rel_hom_eq_coe (f : r ↪r s) : f.to_rel_hom = f := rfl

@[simp] lemma coe_coe_fn (f : r ↪r s) : ((f : r →r s) : α → β) = f := rfl

theorem injective (f : r ↪r s) : injective f := f.inj'

theorem map_rel_iff (f : r ↪r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ↪ β) (o) :
  (@rel_embedding.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_embedding (f : r ↪r s) : (f.to_embedding : α → β) = f := rfl

/-- The map `coe_fn : (r ↪r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r ↪r s) (α → β) coe_fn := fun_like.coe_injective

@[ext] theorem ext ⦃f g : r ↪r s⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext _ _ h

theorem ext_iff {f g : r ↪r s} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

/-- Identity map is a relation embedding. -/
@[refl, simps] protected def refl (r : α → α → Prop) : r ↪r r :=
⟨embedding.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation embeddings is a relation embedding. -/
@[trans] protected def trans (f : r ↪r s) (g : s ↪r t) : r ↪r t :=
⟨f.1.trans g.1, λ a b, by simp [f.map_rel_iff, g.map_rel_iff]⟩

instance (r : α → α → Prop) : inhabited (r ↪r r) := ⟨rel_embedding.refl _⟩

theorem trans_apply (f : r ↪r s) (g : s ↪r t) (a : α) : (f.trans g) a = g (f a) := rfl

@[simp] theorem coe_trans (f : r ↪r s) (g : s ↪r t) : ⇑(f.trans g) = g ∘ f := rfl

/-- A relation embedding is also a relation embedding between dual relations. -/
protected def swap (f : r ↪r s) : swap r ↪r swap s :=
⟨f.to_embedding, λ a b, f.map_rel_iff⟩

/-- If `f` is injective, then it is a relation embedding from the
  preimage relation of `s` to `s`. -/
def preimage (f : α ↪ β) (s : β → β → Prop) : f ⁻¹'o s ↪r s := ⟨f, λ a b, iff.rfl⟩

theorem eq_preimage (f : r ↪r s) : r = f ⁻¹'o s :=
by { ext a b, exact f.map_rel_iff.symm }

protected theorem is_irrefl (f : r ↪r s) [is_irrefl β s] : is_irrefl α r :=
⟨λ a, mt f.map_rel_iff.2 (irrefl (f a))⟩

protected theorem is_refl (f : r ↪r s) [is_refl β s] : is_refl α r :=
⟨λ a, f.map_rel_iff.1 $ refl _⟩

protected theorem is_symm (f : r ↪r s) [is_symm β s] : is_symm α r :=
⟨λ a b, imp_imp_imp f.map_rel_iff.2 f.map_rel_iff.1 symm⟩

protected theorem is_asymm (f : r ↪r s) [is_asymm β s] : is_asymm α r :=
⟨λ a b h₁ h₂, asymm (f.map_rel_iff.2 h₁) (f.map_rel_iff.2 h₂)⟩

protected theorem is_antisymm : ∀ (f : r ↪r s) [is_antisymm β s], is_antisymm α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b h₁ h₂, f.inj' (H _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_trans : ∀ (f : r ↪r s) [is_trans β s], is_trans α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b c h₁ h₂, o.1 (H _ _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_total : ∀ (f : r ↪r s) [is_total β s], is_total α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o o).1 (H _ _)⟩

protected theorem is_preorder : ∀ (f : r ↪r s) [is_preorder β s], is_preorder α r
| f H := by exactI {..f.is_refl, ..f.is_trans}

protected theorem is_partial_order : ∀ (f : r ↪r s) [is_partial_order β s], is_partial_order α r
| f H := by exactI {..f.is_preorder, ..f.is_antisymm}

protected theorem is_linear_order : ∀ (f : r ↪r s) [is_linear_order β s], is_linear_order α r
| f H := by exactI {..f.is_partial_order, ..f.is_total}

protected theorem is_strict_order : ∀ (f : r ↪r s) [is_strict_order β s], is_strict_order α r
| f H := by exactI {..f.is_irrefl, ..f.is_trans}

protected theorem is_trichotomous : ∀ (f : r ↪r s) [is_trichotomous β s], is_trichotomous α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o (or_congr f.inj'.eq_iff o)).1 (H _ _)⟩

protected theorem is_strict_total_order' :
  ∀ (f : r ↪r s) [is_strict_total_order' β s], is_strict_total_order' α r
| f H := by exactI {..f.is_trichotomous, ..f.is_strict_order}

protected theorem acc (f : r ↪r s) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (f.map_rel_iff.2 h) _ rfl⟩
end

protected theorem well_founded : ∀ (f : r ↪r s) (h : well_founded s), well_founded r
| f ⟨H⟩ := ⟨λ a, f.acc _ (H _)⟩

protected theorem is_well_order : ∀ (f : r ↪r s) [is_well_order β s], is_well_order α r
| f H := by exactI {wf := f.well_founded H.wf, ..f.is_strict_total_order'}

/--
To define an relation embedding from an antisymmetric relation `r` to a reflexive relation `s` it
suffices to give a function together with a proof that it satisfies `s (f a) (f b) ↔ r a b`.
-/
def of_map_rel_iff (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) : r ↪r s :=
{ to_fun := f,
  inj' := λ x y h, antisymm ((hf _ _).1 (h ▸ refl _)) ((hf _ _).1 (h ▸ refl _)),
  map_rel_iff' := hf }

@[simp]
lemma of_map_rel_iff_coe (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) :
  ⇑(of_map_rel_iff f hf : r ↪r s) = f :=
rfl

/-- It suffices to prove `f` is monotone between strict relations
  to show it is a relation embedding. -/
def of_monotone [is_trichotomous α r] [is_asymm β s] (f : α → β)
  (H : ∀ a b, r a b → s (f a) (f b)) : r ↪r s :=
begin
  haveI := @is_asymm.is_irrefl β s _,
  refine ⟨⟨f, λ a b e, _⟩, λ a b, ⟨λ h, _, H _ _⟩⟩,
  { refine ((@trichotomous _ r _ a b).resolve_left _).resolve_right _;
    exact λ h, @irrefl _ s _ _ (by simpa [e] using H _ _ h) },
  { refine (@trichotomous _ r _ a b).resolve_right (or.rec (λ e, _) (λ h', _)),
    { subst e, exact irrefl _ h },
    { exact asymm (H _ _ h') h } }
end

@[simp] theorem of_monotone_coe [is_trichotomous α r] [is_asymm β s] (f : α → β) (H) :
  (@of_monotone _ _ r s _ _ f H : α → β) = f := rfl

end rel_embedding

/-- A relation isomorphism is an equivalence that is also a relation embedding. -/
structure rel_iso {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ≃ β :=
(map_rel_iff' : ∀ {a b}, s (to_equiv a) (to_equiv b) ↔ r a b)

infix ` ≃r `:25 := rel_iso

namespace rel_iso

/-- Convert an `rel_iso` to an `rel_embedding`. This function is also available as a coercion
but often it is easier to write `f.to_rel_embedding` than to write explicitly `r` and `s`
in the target type. -/
def to_rel_embedding (f : r ≃r s) : r ↪r s :=
⟨f.to_equiv.to_embedding, f.map_rel_iff'⟩

theorem to_equiv_injective : injective (to_equiv : (r ≃r s) → α ≃ β)
| ⟨e₁, o₁⟩ ⟨e₂, o₂⟩ h := by { congr, exact h }

instance : has_coe (r ≃r s) (r ↪r s) := ⟨to_rel_embedding⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ≃r s) (λ _, α → β) := ⟨λ f, f⟩

-- TODO: define and instantiate a `rel_iso_class` when `equiv_like` is defined
instance : rel_hom_class (r ≃r s) r s :=
{ coe := coe_fn,
  coe_injective' := equiv.coe_fn_injective.comp to_equiv_injective,
  map_rel := λ f a b, iff.mpr (map_rel_iff' f) }

@[simp] lemma to_rel_embedding_eq_coe (f : r ≃r s) : f.to_rel_embedding = f := rfl

@[simp] lemma coe_coe_fn (f : r ≃r s) : ((f : r ↪r s) : α → β) = f := rfl

theorem map_rel_iff (f : r ≃r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ≃ β) (o : ∀ ⦃a b⦄, s (f a) (f b) ↔ r a b) :
  (rel_iso.mk f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_equiv (f : r ≃r s) : (f.to_equiv : α → β) = f := rfl

/-- The map `coe_fn : (r ≃r s) → (α → β)` is injective. Lean fails to parse
`function.injective (λ e : r ≃r s, (e : α → β))`, so we use a trick to say the same. -/
theorem coe_fn_injective : @function.injective (r ≃r s) (α → β) coe_fn := fun_like.coe_injective

@[ext] theorem ext ⦃f g : r ≃r s⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

theorem ext_iff {f g : r ≃r s} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

/-- Inverse map of a relation isomorphism is a relation isomorphism. -/
@[symm] protected def symm (f : r ≃r s) : s ≃r r :=
⟨f.to_equiv.symm, λ a b, by erw [← f.map_rel_iff, f.1.apply_symm_apply, f.1.apply_symm_apply]⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : r ≃r s) : α → β := h
/-- See Note [custom simps projection]. -/
def simps.symm_apply (h : r ≃r s) : β → α := h.symm

initialize_simps_projections rel_iso
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

/-- Identity map is a relation isomorphism. -/
@[refl, simps apply] protected def refl (r : α → α → Prop) : r ≃r r :=
⟨equiv.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation isomorphisms is a relation isomorphism. -/
@[trans, simps apply] protected def trans (f₁ : r ≃r s) (f₂ : s ≃r t) : r ≃r t :=
⟨f₁.to_equiv.trans f₂.to_equiv, λ a b, f₂.map_rel_iff.trans f₁.map_rel_iff⟩

instance (r : α → α → Prop) : inhabited (r ≃r r) := ⟨rel_iso.refl _⟩

@[simp] lemma default_def (r : α → α → Prop) : default = rel_iso.refl r := rfl

/-- a relation isomorphism is also a relation isomorphism between dual relations. -/
protected def swap (f : r ≃r s) : (swap r) ≃r (swap s) :=
⟨f.to_equiv, λ _ _, f.map_rel_iff⟩

@[simp] theorem coe_fn_symm_mk (f o) : ((@rel_iso.mk _ _ r s f o).symm : β → α) = f.symm :=
rfl

@[simp] theorem apply_symm_apply (e : r ≃r s) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_symm_apply x

@[simp] theorem symm_apply_apply (e : r ≃r s) (x : α) : e.symm (e x) = x :=
e.to_equiv.symm_apply_apply x

theorem rel_symm_apply (e : r ≃r s) {x y} : r x (e.symm y) ↔ s (e x) y :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

theorem symm_apply_rel (e : r ≃r s) {x y} : r (e.symm x) y ↔ s x (e y) :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

protected lemma bijective (e : r ≃r s) : bijective e := e.to_equiv.bijective
protected lemma injective (e : r ≃r s) : injective e := e.to_equiv.injective
protected lemma surjective (e : r ≃r s) : surjective e := e.to_equiv.surjective

@[simp] lemma range_eq (e : r ≃r s) : set.range e = set.univ := e.surjective.range_eq

@[simp] lemma eq_iff_eq (f : r ≃r s) {a b} : f a = f b ↔ a = b :=
f.injective.eq_iff

/-- Any equivalence lifts to a relation isomorphism between `s` and its preimage. -/
protected def preimage (f : α ≃ β) (s : β → β → Prop) : f ⁻¹'o s ≃r s := ⟨f, λ a b, iff.rfl⟩

/-- A surjective relation embedding is a relation isomorphism. -/
@[simps apply]
noncomputable def of_surjective (f : r ↪r s) (H : surjective f) : r ≃r s :=
⟨equiv.of_bijective f ⟨f.injective, H⟩, λ a b, f.map_rel_iff⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the sum.
-/
def sum_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  sum.lex r₁ r₂ ≃r sum.lex s₁ s₂ :=
⟨equiv.sum_congr e₁.to_equiv e₂.to_equiv, λ a b,
 by cases e₁ with f hf; cases e₂ with g hg;
    cases a; cases b; simp [hf, hg]⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the product.
-/
def prod_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  prod.lex r₁ r₂ ≃r prod.lex s₁ s₂ :=
⟨equiv.prod_congr e₁.to_equiv e₂.to_equiv,
  λ a b, by simp [prod.lex_def, e₁.map_rel_iff, e₂.map_rel_iff]⟩

instance : group (r ≃r r) :=
{ one := rel_iso.refl r,
  mul := λ f₁ f₂, f₂.trans f₁,
  inv := rel_iso.symm,
  mul_assoc := λ f₁ f₂ f₃, rfl,
  one_mul := λ f, ext $ λ _, rfl,
  mul_one := λ f, ext $ λ _, rfl,
  mul_left_inv := λ f, ext f.symm_apply_apply }

@[simp] lemma coe_one : ⇑(1 : r ≃r r) = id := rfl

@[simp] lemma coe_mul (e₁ e₂ : r ≃r r) : ⇑(e₁ * e₂) = e₁ ∘ e₂ := rfl

lemma mul_apply (e₁ e₂ : r ≃r r) (x : α) : (e₁ * e₂) x = e₁ (e₂ x) := rfl

@[simp] lemma inv_apply_self (e : r ≃r r) (x) : e⁻¹ (e x) = x := e.symm_apply_apply x

@[simp] lemma apply_inv_self (e : r ≃r r) (x) : e (e⁻¹ x) = x := e.apply_symm_apply x

end rel_iso

/-- `subrel r p` is the inherited relation on a subset. -/
def subrel (r : α → α → Prop) (p : set α) : p → p → Prop :=
(coe : p → α) ⁻¹'o r

@[simp] theorem subrel_val (r : α → α → Prop) (p : set α)
  {a b} : subrel r p a b ↔ r a.1 b.1 := iff.rfl

namespace subrel

/-- The relation embedding from the inherited relation on a subset. -/
protected def rel_embedding (r : α → α → Prop) (p : set α) :
  subrel r p ↪r r := ⟨embedding.subtype _, λ a b, iff.rfl⟩

@[simp] theorem rel_embedding_apply (r : α → α → Prop) (p a) :
  subrel.rel_embedding r p a = a.1 := rfl

instance (r : α → α → Prop) [is_well_order α r]
  (p : set α) : is_well_order p (subrel r p) :=
rel_embedding.is_well_order (subrel.rel_embedding r p)

end subrel

/-- Restrict the codomain of a relation embedding. -/
def rel_embedding.cod_restrict (p : set β) (f : r ↪r s) (H : ∀ a, f a ∈ p) : r ↪r subrel s p :=
⟨f.to_embedding.cod_restrict p H, f.map_rel_iff'⟩

@[simp] theorem rel_embedding.cod_restrict_apply (p) (f : r ↪r s) (H a) :
  rel_embedding.cod_restrict p f H a = ⟨f a, H a⟩ := rfl


import .geom3d
import ..time.time

open_locale affine

section foo

universes u
#check add_maps

abbreviation geom3d_stamped_frame :=
    (mk_prod_spc (geom3d_std_space) time_std_space).frame_type
abbreviation geom3d_stamped_space (f : geom3d_stamped_frame) := spc scalar f
def geom3d_stamped_std_frame :=
    (mk_prod_spc (geom3d_std_space) time_std_space).frame
def geom3d_stamped_std_space : geom3d_stamped_space geom3d_stamped_std_frame :=
    (mk_prod_spc (geom3d_std_space) time_std_space)

structure position3d_stamped {f : geom3d_stamped_frame} (s : geom3d_stamped_space f ) extends point s
@[ext] lemma position3d_stamped.ext : ∀  {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (x y : position3d_stamped s),
    x.to_point = y.to_point → x = y :=
    begin
        intros f s x y e,
        cases x,
        cases y,
        simp *,
        have h₁ : ({to_point := x} : position3d_stamped s).to_point = x := rfl,
        simp [h₁] at e,
        exact e
    end

def position3d_stamped.coords {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (t :position3d_stamped s) :=
    t.to_point.coords

def position3d_stamped.x {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (t :position3d_stamped s) : scalar :=
    (t.to_point.coords 0).coord

def position3d_stamped.y {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (t :position3d_stamped s) : scalar :=
    (t.to_point.coords 1).coord

def position3d_stamped.z {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (t :position3d_stamped s) : scalar :=
    (t.to_point.coords 2).coord

@[simp]
def mk_position3d_stamped' {f : geom3d_stamped_frame} (s : geom3d_stamped_space f ) (p : point s) : position3d_stamped s := position3d_stamped.mk p
@[simp]
def mk_position3d_stamped {f : geom3d_stamped_frame} (s : geom3d_stamped_space f ) (k₁ k₂ k₃ k₄ : scalar) : position3d_stamped s := position3d_stamped.mk (mk_point s ⟨[k₁,k₂,k₃, k₄],rfl⟩)

@[simp]
def mk_position3d_stamped'' {f1 f2 f3 : geom1d_frame } { s1 : geom1d_space f1} {s2 : geom1d_space f2} { s3 : geom1d_space f3}
    {f4 : time_frame} {s4 : time_space f4}
    (p1 : position1d s1) (p2 : position1d s2) (p3 : position1d s3 ) (p4 : time s4)
    : position3d_stamped (mk_prod_spc (mk_prod_spc (mk_prod_spc s1 s2) s3) s4) :=
    ⟨mk_point_prod (mk_point_prod (mk_point_prod p1.to_point p2.to_point) p3.to_point) p4.to_point⟩

structure displacement3d_stamped {f : geom3d_stamped_frame} (s : geom3d_stamped_space f ) extends vectr s
@[ext] lemma displacement3d_stamped.ext : ∀  {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (x y : displacement3d_stamped s),
    x.to_vectr = y.to_vectr → x = y :=
    begin
        intros f s x y e,
        cases x,
        cases y,
        simp *,
        have h₁ : ({to_vectr := x} : displacement3d_stamped s).to_vectr = x := rfl,
        simp [h₁] at e,
        exact e
    end

def displacement3d_stamped.coords {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (d :displacement3d_stamped s) :=
    d.to_vectr.coords

def displacement3d_stamped.x {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (t :displacement3d_stamped s) : scalar :=
    (t.to_vectr.coords 0).coord

def displacement3d_stamped.y {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (t :displacement3d_stamped s) : scalar :=
    (t.to_vectr.coords 1).coord

def displacement3d_stamped.z {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (t :displacement3d_stamped s) : scalar :=
    (t.to_vectr.coords 2).coord

@[simp]
def mk_displacement3d_stamped' {f : geom3d_stamped_frame} (s : geom3d_stamped_space f ) (v : vectr s) : displacement3d_stamped s := displacement3d_stamped.mk v
@[simp]
def mk_displacement3d_stamped  {f : geom3d_stamped_frame} (s : geom3d_stamped_space f ) (k₁ k₂ k₃ k₄ : scalar)
    : displacement3d_stamped s := displacement3d_stamped.mk (mk_vectr s ⟨[k₁,k₂,k₃,k₄],rfl⟩)

@[simp]
def mk_displacement3d_stamped'' {f1 f2 f3 : geom1d_frame } { s1 : geom1d_space f1} {s2 : geom1d_space f2} { s3 : geom1d_space f3}
    {f4 : time_frame} {s4 : time_space f4}
    (p1 : displacement1d s1) (p2 : displacement1d s2) (p3 : displacement1d s3 ) (p4 : time s4)
    : displacement3d_stamped (mk_prod_spc (mk_prod_spc (mk_prod_spc s1 s2) s3) s4) :=
    ⟨mk_vectr_prod (mk_vectr_prod (mk_vectr_prod p1.to_vectr p2.to_vectr) p3.to_vectr) (mk_vectr s4 ⟨[(p4.coords 0).coord],rfl⟩)⟩

@[simp]
def mk_geom3d_stamped_frame {parent : geom3d_stamped_frame} {s : spc scalar parent} (p : position3d_stamped s)
    (v0 : displacement3d s) (v1 : displacement3d s) (v2 : displacement3d s)
    : geom3d_stamped_frame :=
    (mk_frame p.to_point ⟨(λi, if i = 0 then (mk_displacement3d_stamped v0.x v0.y v0.z 0) else if i = 1 then v1.to_vectr else v2.to_vectr),sorry,sorry⟩)

end foo

section bar

#check quot
#check quotient

/-
    *************************************
    Instantiate module scalar (vector scalar)
    *************************************
-/

namespace geom3d
variables {f : geom3d_stamped_frame} {s : geom3d_stamped_space f }
@[simp]
def add_displacement3d_stamped_displacement3d_stamped (v3 v2 : displacement3d_stamped s) : displacement3d_stamped s :=
    mk_displacement3d_stamped' s (v3.to_vectr + v2.to_vectr)
@[simp]
def smul_displacement3d_stamped (k : scalar) (v : displacement3d_stamped s) : displacement3d_stamped s :=
    mk_displacement3d_stamped' s (k • v.to_vectr)
@[simp]
def neg_displacement3d_stamped (v : displacement3d_stamped s) : displacement3d_stamped s :=
    mk_displacement3d_stamped' s ((-1 : scalar) • v.to_vectr)
@[simp]
def sub_displacement3d_stamped_displacement3d_stamped (v3 v2 : displacement3d_stamped s) : displacement3d_stamped s :=    -- v3-v2
    add_displacement3d_stamped_displacement3d_stamped v3 (neg_displacement3d_stamped v2)

instance has_add_displacement3d_stamped : has_add (displacement3d_stamped s) := ⟨ add_displacement3d_stamped_displacement3d_stamped ⟩
lemma add_assoc_displacement3d_stamped : ∀ a b c : displacement3d_stamped s, a + b + c = a + (b + c) := begin
    intros,
    ext,
    --cases a,
    repeat {
    have p3 : (a + b + c).to_vec = a.to_vec + b.to_vec + c.to_vec := rfl,
    have p2 : (a + (b + c)).to_vec = a.to_vec + (b.to_vec + c.to_vec) := rfl,
    rw [p3,p2],
    cc
    },
    admit
end
instance add_semigroup_displacement3d_stamped : add_semigroup (displacement3d_stamped s) := ⟨ add_displacement3d_stamped_displacement3d_stamped, add_assoc_displacement3d_stamped⟩
@[simp]
def displacement3d_stamped_zero  := mk_displacement3d_stamped s 0 0 0 0
instance has_zero_displacement3d_stamped : has_zero (displacement3d_stamped s) := ⟨displacement3d_stamped_zero⟩

lemma zero_add_displacement3d_stamped : ∀ a : displacement3d_stamped s, 0 + a = a :=
begin
    intros,--ext,
    ext,
    admit,
   -- let h0 : (0 + a).to_vec = (0 : vectr s).to_vec + a.to_vec := rfl,
    --simp [h0],
    --exact zero_add _,
    --exact zero_add _,
end

lemma add_zero_displacement3d_stamped : ∀ a : displacement3d_stamped s, a + 0 = a :=
begin
    intros,ext,
    admit,
    --exact add_zero _,
    --exact add_zero _,
end

@[simp]
def nsmul_displacement3d_stamped : ℕ → (displacement3d_stamped s) → (displacement3d_stamped s)
| nat.zero v := displacement3d_stamped_zero
--| 3 v := v
| (nat.succ n) v := (add_displacement3d_stamped_displacement3d_stamped) v (nsmul_displacement3d_stamped n v)

instance add_monoid_displacement3d_stamped : add_monoid (displacement3d_stamped s) := ⟨
    -- add_semigroup
    add_displacement3d_stamped_displacement3d_stamped,
    add_assoc_displacement3d_stamped,
    -- has_zero
    displacement3d_stamped_zero,
    -- new structure
    @zero_add_displacement3d_stamped f s,
    add_zero_displacement3d_stamped,
    nsmul_displacement3d_stamped
⟩

instance has_neg_displacement3d_stamped : has_neg (displacement3d_stamped s) := ⟨neg_displacement3d_stamped⟩
instance has_sub_displacement3d_stamped : has_sub (displacement3d_stamped s) := ⟨ sub_displacement3d_stamped_displacement3d_stamped⟩
lemma sub_eq_add_neg_displacement3d_stamped : ∀ a b : displacement3d_stamped s, a - b = a + -b :=
begin
    intros,ext,
    refl,
end

instance sub_neg_monoid_displacement3d_stamped : sub_neg_monoid (displacement3d_stamped s) :=
{
    neg := neg_displacement3d_stamped ,
    ..(show add_monoid (displacement3d_stamped s), by apply_instance)
}

lemma add_left_neg_displacement3d_stamped : ∀ a : displacement3d_stamped s, -a + a = 0 :=
begin
    intros,
    ext,
   /- repeat {
    have h0 : (-a + a).to_vec = -a.to_vec + a.to_vec := rfl,
    simp [h0],
    have : (0:vec scalar) = (0:displacement3d_stamped s).to_vectr.to_vec := rfl,
    simp *,
    }-/
    admit,
end

instance : add_group (displacement3d_stamped s) := {
    add_left_neg := begin
        exact add_left_neg_displacement3d_stamped,
    end,
..(show sub_neg_monoid (displacement3d_stamped s), by apply_instance),

}

lemma add_comm_displacement3d_stamped : ∀ a b : displacement3d_stamped s, a + b = b + a :=
begin
    intros,
    ext,
    /-repeat {
    have p3 : (a + b).to_vec = a.to_vec + b.to_vec:= rfl,
    have p2 : (b + a).to_vec = b.to_vec + a.to_vec := rfl,
    rw [p3,p2],
    cc
    }
    -/
    admit,
end
instance add_comm_semigroup_displacement3d_stamped : add_comm_semigroup (displacement3d_stamped s) := ⟨
    -- add_semigroup
    add_displacement3d_stamped_displacement3d_stamped,
    add_assoc_displacement3d_stamped,
    add_comm_displacement3d_stamped,
⟩

instance add_comm_monoid_displacement3d_stamped : add_comm_monoid (displacement3d_stamped s) := {
    add_comm := begin
        exact add_comm_displacement3d_stamped
    end,
    ..(show add_monoid (displacement3d_stamped s), by apply_instance)
}

instance has_scalar_displacement3d_stamped : has_scalar scalar (displacement3d_stamped s) := ⟨
smul_displacement3d_stamped,
⟩

lemma one_smul_displacement3d_stamped : ∀ b : displacement3d_stamped s, (1 : scalar) • b = b := begin
    intros,ext,
    /-repeat {
        have h0 : ((3:scalar) • b).to_vec = ((3:scalar)•(b.to_vec)) := rfl,
        rw [h0],
        simp *,
    }-/
    admit,
end
lemma mul_smul_displacement3d_stamped : ∀ (x y : scalar) (b : displacement3d_stamped s), (x * y) • b = x • y • b :=
begin
    intros,
    cases b,
    ext,
    exact mul_assoc x y _,
end

instance mul_action_displacement3d_stamped : mul_action scalar (displacement3d_stamped s) := ⟨
one_smul_displacement3d_stamped,
mul_smul_displacement3d_stamped,
⟩

lemma smul_add_displacement3d_stamped : ∀(r : scalar) (x y : displacement3d_stamped s), r • (x + y) = r • x + r • y := begin
    intros, ext,
    repeat {
    have h0 : (r • (x + y)).to_vec = (r • (x.to_vec + y.to_vec)) := rfl,
    have h3 : (r•x + r•y).to_vec = (r•x.to_vec + r•y.to_vec) := rfl,
    rw [h0,h3],
    simp *,
    }
    ,admit,
end
lemma smul_zero_displacement3d_stamped : ∀(r : scalar), r • (0 : displacement3d_stamped s) = 0 := begin
    admit--intros, ext, exact mul_zero _, exact mul_zero _
end
instance distrib_mul_action_K_displacement3d_stamped : distrib_mul_action scalar (displacement3d_stamped s) := ⟨
smul_add_displacement3d_stamped,
smul_zero_displacement3d_stamped,
⟩

-- renaming vs template due to clash with name "s" for prevailing variable
lemma add_smul_displacement3d_stamped : ∀ (a b : scalar) (x : displacement3d_stamped s), (a + b) • x = a • x + b • x :=
begin
  intros,
  ext,
  exact right_distrib _ _ _,
end
lemma zero_smul_displacement3d_stamped : ∀ (x : displacement3d_stamped s), (0 : scalar) • x = 0 := begin
    intros,
    ext,
    admit,--exact zero_mul _, exact zero_mul _
end
instance module_K_displacement3d_stamped : module scalar (displacement3d_stamped s) := ⟨ add_smul_displacement3d_stamped, zero_smul_displacement3d_stamped ⟩

instance add_comm_group_displacement3d_stamped : add_comm_group (displacement3d_stamped s) := {
    add_comm := begin
        exact add_comm_displacement3d_stamped
    end,
..(show add_group (displacement3d_stamped s), by apply_instance)
}
instance : module scalar (displacement3d_stamped s) := @geom3d.module_K_displacement3d_stamped f s

/-
    ********************
    *** Affine space ***
    ********************
-/

/-
Affine operations
-/
instance : has_add (displacement3d_stamped s) := ⟨add_displacement3d_stamped_displacement3d_stamped⟩
instance : has_zero (displacement3d_stamped s) := ⟨displacement3d_stamped_zero⟩
instance : has_neg (displacement3d_stamped s) := ⟨neg_displacement3d_stamped⟩

/-
Lemmas needed to implement affine space API
-/
@[simp]
def sub_position3d_stamped_position3d_stamped {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (p3 p2 : position3d_stamped s) : displacement3d_stamped s :=
    mk_displacement3d_stamped' s (p3.to_point -ᵥ p2.to_point)
@[simp]
def add_position3d_stamped_displacement3d_stamped {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (p : position3d_stamped s) (v : displacement3d_stamped s) : position3d_stamped s :=
    mk_position3d_stamped' s (v.to_vectr +ᵥ p.to_point) -- reorder assumes order is irrelevant
@[simp]
def add_displacement3d_stamped_position3d_stamped {f : geom3d_stamped_frame} {s : geom3d_stamped_space f } (v : displacement3d_stamped s) (p : position3d_stamped s) : position3d_stamped s :=
    mk_position3d_stamped' s (v.to_vectr +ᵥ p.to_point)
--@[simp]
--def aff_displacement3d_stamped_group_action : displacement3d_stamped s → position3d_stamped s → position3d_stamped s := add_displacement3d_stamped_position3d_stamped scalar
instance : has_vadd (displacement3d_stamped s) (position3d_stamped s) := ⟨add_displacement3d_stamped_position3d_stamped⟩

lemma zero_displacement3d_stamped_vadd'_a3 : ∀ p : position3d_stamped s, (0 : displacement3d_stamped s) +ᵥ p = p := begin
    intros,
    ext,--exact zero_add _,
    admit--exact add_zero _
end
lemma displacement3d_stamped_add_assoc'_a3 : ∀ (g3 g2 : displacement3d_stamped s) (p : position3d_stamped s), g3 +ᵥ (g2 +ᵥ p) = (g3 + g2) +ᵥ p := begin
    intros, ext,
    repeat {
    have h0 : (g3 +ᵥ (g2 +ᵥ p)).to_pt = (g3.to_vec +ᵥ (g2.to_vec +ᵥ p.to_pt)) := rfl,
    have h3 : (g3 + g2 +ᵥ p).to_pt = (g3.to_vec +ᵥ g2.to_vec +ᵥ p.to_pt) := rfl,
    rw [h0,h3],
    simp *,
    simp [has_vadd.vadd, has_add.add, add_semigroup.add, add_zero_class.add, add_monoid.add, sub_neg_monoid.add,
        add_group.add, distrib.add, ring.add, division_ring.add],
    cc,
    },
    admit,
end

instance displacement3d_stamped_add_action: add_action (displacement3d_stamped s) (position3d_stamped s) :=
⟨ zero_displacement3d_stamped_vadd'_a3,
begin
    let h0 := displacement3d_stamped_add_assoc'_a3,
    intros,
    exact (h0 g₁ g₂ p).symm
end⟩
--@[simp]
--def aff_geom3d_group_sub : position3d_stamped s → position3d_stamped s → displacement3d_stamped s := sub_geom3d_position3d_stamped scalar
instance position3d_stamped_has_vsub : has_vsub (displacement3d_stamped s) (position3d_stamped s) := ⟨ sub_position3d_stamped_position3d_stamped⟩

instance : nonempty (position3d_stamped s) := ⟨mk_position3d_stamped s 0 0 0 0⟩

lemma position3d_stamped_vsub_vadd_a3 : ∀ (p3 p2 : (position3d_stamped s)), (p3 -ᵥ p2) +ᵥ p2 = p3 := begin
    /-intros, ext,
    --repeat {
    have h0 : (p3 -ᵥ p2 +ᵥ p2).to_pt = (p3.to_pt -ᵥ p2.to_pt +ᵥ p2.to_pt) := rfl,
    rw h0,
    simp [has_vsub.vsub, has_sub.sub, sub_neg_monoid.sub, add_group.sub, add_comm_group.sub, ring.sub, division_ring.sub],
    simp [has_vadd.vadd, has_add.add, distrib.add, ring.add, division_ring.add],
    let h0 : field.add p2.to_pt.to_prod.fst (field.sub p3.to_pt.to_prod.fst p2.to_pt.to_prod.fst) =
            field.add (field.sub p3.to_pt.to_prod.fst p2.to_pt.to_prod.fst) p2.to_pt.to_prod.fst := add_comm _ _,
    rw h0,
    exact sub_add_cancel _ _,
    have h0 : (p3 -ᵥ p2 +ᵥ p2).to_pt = (p3.to_pt -ᵥ p2.to_pt +ᵥ p2.to_pt) := rfl,
    rw h0,
    simp [has_vsub.vsub, has_sub.sub, sub_neg_monoid.sub, add_group.sub, add_comm_group.sub, ring.sub, division_ring.sub],
    simp [has_vadd.vadd, has_add.add, distrib.add, ring.add, division_ring.add],
    let h0 : field.add p2.to_pt.to_prod.snd (field.sub p3.to_pt.to_prod.snd p2.to_pt.to_prod.snd) =
            field.add (field.sub p3.to_pt.to_prod.snd p2.to_pt.to_prod.snd) p2.to_pt.to_prod.snd := add_comm _ _,
    rw h0,
    exact sub_add_cancel _ _,-/
    admit
end
lemma position3d_stamped_vadd_vsub_a3 : ∀ (g : displacement3d_stamped s) (p : position3d_stamped s), g +ᵥ p -ᵥ p = g :=
begin
    intros, ext,
    repeat {
    have h0 : ((g +ᵥ p -ᵥ p) : displacement3d_stamped s).to_vectr = (g.to_vectr +ᵥ p.to_point -ᵥ p.to_point) := rfl,
    rw h0,
    simp *,
    }

end

instance aff_geom3d_stamped_torsor : add_torsor (displacement3d_stamped s) (position3d_stamped s) :=
⟨
    begin
        exact position3d_stamped_vsub_vadd_a3,
    end,
    begin
        exact position3d_stamped_vadd_vsub_a3,
    end,
⟩

open_locale affine

--instance : affine_space (displacement3d_stamped s) (position3d_stamped s) := @geom3d.aff_geom3d_torsor f s

end geom3d -- ha ha
end bar

/-
Newer version
Tradeoff - Does not directly extend from affine equiv. Base class is an equiv on points and vectrs

Extension methods are provided to directly transform Times and Duration between frames
-/
@[ext]
structure geom3d_stamped_transform {f3 : geom3d_stamped_frame} {f2 : geom3d_stamped_frame} (sp3 : geom3d_stamped_space f3) (sp2 : geom3d_stamped_space f2)
  extends fm_tr sp3 sp2

def geom3d_stamped_space.mk_geom3d_stamped_transform_to {f3 : geom3d_stamped_frame} (s3 : geom3d_stamped_space f3) : Π {f2 : geom3d_stamped_frame} (s2 : geom3d_stamped_space f2),
        geom3d_stamped_transform s3 s2 := --(position3d_stamped s2) ≃ᵃ[scalar] (position3d_stamped s3) :=
    λ f2 s2,
        ⟨s3.fm_tr s2⟩

def geom3d_stamped_transform.symm
    {f3 : geom3d_stamped_frame} {f2 : geom3d_stamped_frame} {sp3 : geom3d_stamped_space f3} {sp2 : geom3d_stamped_space f2} (ttr : geom3d_stamped_transform sp3 sp2)
    : geom3d_stamped_transform sp2 sp3 := ⟨(ttr.1).symm⟩

def geom3d_stamped_transform.trans
    {f3 : geom3d_stamped_frame} {f2 : geom3d_stamped_frame} {f3 : geom3d_stamped_frame} {sp3 : geom3d_stamped_space f3} {sp2 : geom3d_stamped_space f2} {sp3 : geom3d_stamped_space f3}
    (ttr : geom3d_stamped_transform sp3 sp2)
    : geom3d_stamped_transform sp2 sp3 → geom3d_stamped_transform sp3 sp3 := λttr_, ⟨(ttr.1).trans ttr_.1⟩

def geom3d_stamped_transform.transform_position3d_stamped
    {f3 : geom3d_stamped_frame} {s3 : geom3d_stamped_space f3}
    {f2 : geom3d_stamped_frame} {s2 : geom3d_stamped_space f2}
    (tr: geom3d_stamped_transform s3 s2 ) : position3d_stamped s3 → position3d_stamped s2 :=
    λt : position3d_stamped s3,
    ⟨tr.to_fm_tr.to_equiv t.to_point⟩

def geom3d_stamped_transform.transform_displacement3d_stamped
    {f3 : geom3d_stamped_frame} {s3 : geom3d_stamped_space f3}
    {f2 : geom3d_stamped_frame} {s2 : geom3d_stamped_space f2}
    (tr: geom3d_stamped_transform s3 s2 ) : displacement3d_stamped s3 → displacement3d_stamped s2 :=
    λd,
    let as_pt : point s3 := ⟨λi, mk_pt scalar (d.coords i).coord⟩ in
    let tr_pt := (tr.to_equiv as_pt) in
    ⟨⟨λi, mk_vec scalar (tr_pt.coords i).coord⟩⟩


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

! This file was ported from Lean 3 source module representation_theory.Action
! leanprover-community/mathlib commit c04bc6e93e23aa0182aba53661a2211e80b6feac
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Group.Basic
import Mathbin.CategoryTheory.SingleObj
import Mathbin.CategoryTheory.Limits.FunctorCategory
import Mathbin.CategoryTheory.Limits.Preserves.Basic
import Mathbin.CategoryTheory.Adjunction.Limits
import Mathbin.CategoryTheory.Monoidal.FunctorCategory
import Mathbin.CategoryTheory.Monoidal.Transport
import Mathbin.CategoryTheory.Monoidal.Rigid.OfEquivalence
import Mathbin.CategoryTheory.Monoidal.Rigid.FunctorCategory
import Mathbin.CategoryTheory.Monoidal.Linear
import Mathbin.CategoryTheory.Monoidal.Braided
import Mathbin.CategoryTheory.Monoidal.Types
import Mathbin.CategoryTheory.Abelian.FunctorCategory
import Mathbin.CategoryTheory.Abelian.Transfer
import Mathbin.CategoryTheory.Conj
import Mathbin.CategoryTheory.Linear.FunctorCategory

/-!
# `Action V G`, the category of actions of a monoid `G` inside some category `V`.

The prototypical example is `V = Module R`,
where `Action (Module R) G` is the category of `R`-linear representations of `G`.

We check `Action V G ≌ (single_obj G ⥤ V)`,
and construct the restriction functors `res {G H : Mon} (f : G ⟶ H) : Action V H ⥤ Action V G`.

* When `V` has (co)limits so does `Action V G`.
* When `V` is monoidal, braided, or symmetric, so is `Action V G`.
* When `V` is preadditive, linear, or abelian so is `Action V G`.
-/

universe u v

open CategoryTheory

open CategoryTheory.Limits

variable (V : Type (u + 1)) [LargeCategory V]

-- Note: this is _not_ a categorical action of `G` on `V`.
/-- An `Action V G` represents a bundled action of
the monoid `G` on an object of some category `V`.

As an example, when `V = Module R`, this is an `R`-linear representation of `G`,
while when `V = Type` this is a `G`-action.
-/
structure Action (G : MonCat.{u}) where
  V : V
  ρ : G ⟶ MonCat.of (End V)
#align Action Action

namespace Action

variable {V}

@[simp]
theorem ρ_one {G : MonCat.{u}} (A : Action V G) : A.ρ 1 = 𝟙 A.V :=
  by
  rw [MonoidHom.map_one]
  rfl
#align Action.ρ_one Action.ρ_one

/-- When a group acts, we can lift the action to the group of automorphisms. -/
@[simps]
def ρAut {G : GroupCat.{u}} (A : Action V (MonCat.of G)) : G ⟶ GroupCat.of (Aut A.V)
    where
  toFun g :=
    { Hom := A.ρ g
      inv := A.ρ (g⁻¹ : G)
      hom_inv_id' := (A.ρ.map_mul (g⁻¹ : G) g).symm.trans (by rw [inv_mul_self, ρ_one])
      inv_hom_id' := (A.ρ.map_mul g (g⁻¹ : G)).symm.trans (by rw [mul_inv_self, ρ_one]) }
  map_one' := by
    ext
    exact A.ρ.map_one
  map_mul' x y := by
    ext
    exact A.ρ.map_mul x y
#align Action.ρ_Aut Action.ρAut

variable (G : MonCat.{u})

section

instance inhabited' : Inhabited (Action (Type u) G) :=
  ⟨⟨PUnit, 1⟩⟩
#align Action.inhabited' Action.inhabited'

/-- The trivial representation of a group. -/
def trivial : Action AddCommGroupCat G
    where
  V := AddCommGroupCat.of PUnit
  ρ := 1
#align Action.trivial Action.trivial

instance : Inhabited (Action AddCommGroupCat G) :=
  ⟨trivial G⟩

end

variable {G V}

/-- A homomorphism of `Action V G`s is a morphism between the underlying objects,
commuting with the action of `G`.
-/
@[ext]
structure Hom (M N : Action V G) where
  Hom : M.V ⟶ N.V
  comm' : ∀ g : G, M.ρ g ≫ hom = hom ≫ N.ρ g := by obviously
#align Action.hom Action.Hom

restate_axiom hom.comm'

namespace Hom

/-- The identity morphism on a `Action V G`. -/
@[simps]
def id (M : Action V G) : Action.Hom M M where Hom := 𝟙 M.V
#align Action.hom.id Action.Hom.id

instance (M : Action V G) : Inhabited (Action.Hom M M) :=
  ⟨id M⟩

/-- The composition of two `Action V G` homomorphisms is the composition of the underlying maps.
-/
@[simps]
def comp {M N K : Action V G} (p : Action.Hom M N) (q : Action.Hom N K) : Action.Hom M K
    where
  Hom := p.Hom ≫ q.Hom
  comm' g := by rw [← category.assoc, p.comm, category.assoc, q.comm, ← category.assoc]
#align Action.hom.comp Action.Hom.comp

end Hom

instance : Category (Action V G) where
  Hom M N := Hom M N
  id M := Hom.id M
  comp M N K f g := Hom.comp f g

@[simp]
theorem id_hom (M : Action V G) : (𝟙 M : Hom M M).Hom = 𝟙 M.V :=
  rfl
#align Action.id_hom Action.id_hom

@[simp]
theorem comp_hom {M N K : Action V G} (f : M ⟶ N) (g : N ⟶ K) :
    (f ≫ g : Hom M K).Hom = f.Hom ≫ g.Hom :=
  rfl
#align Action.comp_hom Action.comp_hom

/-- Construct an isomorphism of `G` actions/representations
from an isomorphism of the the underlying objects,
where the forward direction commutes with the group action. -/
@[simps]
def mkIso {M N : Action V G} (f : M.V ≅ N.V) (comm : ∀ g : G, M.ρ g ≫ f.Hom = f.Hom ≫ N.ρ g) : M ≅ N
    where
  Hom :=
    { Hom := f.Hom
      comm' := comm }
  inv :=
    { Hom := f.inv
      comm' := fun g => by
        have w := comm g =≫ f.inv
        simp at w
        simp [w] }
#align Action.mk_iso Action.mkIso

instance (priority := 100) isIso_of_hom_isIso {M N : Action V G} (f : M ⟶ N) [IsIso f.Hom] :
    IsIso f := by
  convert is_iso.of_iso (mk_iso (as_iso f.hom) f.comm)
  ext
  rfl
#align Action.is_iso_of_hom_is_iso Action.isIso_of_hom_isIso

instance isIso_hom_mk {M N : Action V G} (f : M.V ⟶ N.V) [IsIso f] (w) : @IsIso _ _ M N ⟨f, w⟩ :=
  IsIso.of_iso (mkIso (asIso f) w)
#align Action.is_iso_hom_mk Action.isIso_hom_mk

namespace FunctorCategoryEquivalence

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def functor : Action V G ⥤ SingleObj G ⥤ V
    where
  obj M :=
    { obj := fun _ => M.V
      map := fun _ _ g => M.ρ g
      map_id' := fun _ => M.ρ.map_one
      map_comp' := fun _ _ _ g h => M.ρ.map_mul h g }
  map M N f :=
    { app := fun _ => f.Hom
      naturality' := fun _ _ g => f.comm g }
#align Action.functor_category_equivalence.functor Action.FunctorCategoryEquivalence.functor

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def inverse : (SingleObj G ⥤ V) ⥤ Action V G
    where
  obj F :=
    { V := F.obj PUnit.unit
      ρ :=
        { toFun := fun g => F.map g
          map_one' := F.map_id PUnit.unit
          map_mul' := fun g h => F.map_comp h g } }
  map M N f :=
    { Hom := f.app PUnit.unit
      comm' := fun g => f.naturality g }
#align Action.functor_category_equivalence.inverse Action.FunctorCategoryEquivalence.inverse

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def unitIso : 𝟭 (Action V G) ≅ functor ⋙ inverse :=
  NatIso.ofComponents (fun M => mkIso (Iso.refl _) (by tidy)) (by tidy)
#align Action.functor_category_equivalence.unit_iso Action.FunctorCategoryEquivalence.unitIso

/-- Auxilliary definition for `functor_category_equivalence`. -/
@[simps]
def counitIso : inverse ⋙ functor ≅ 𝟭 (SingleObj G ⥤ V) :=
  NatIso.ofComponents (fun M => NatIso.ofComponents (by tidy) (by tidy)) (by tidy)
#align Action.functor_category_equivalence.counit_iso Action.FunctorCategoryEquivalence.counitIso

end FunctorCategoryEquivalence

section

open FunctorCategoryEquivalence

variable (V G)

/-- The category of actions of `G` in the category `V`
is equivalent to the functor category `single_obj G ⥤ V`.
-/
def functorCategoryEquivalence : Action V G ≌ SingleObj G ⥤ V
    where
  Functor := Functor
  inverse := inverse
  unitIso := unitIso
  counitIso := counitIso
#align Action.functor_category_equivalence Action.functorCategoryEquivalence

attribute [simps] functor_category_equivalence

theorem functorCategoryEquivalence.functor_def :
    (functorCategoryEquivalence V G).Functor = FunctorCategoryEquivalence.functor :=
  rfl
#align Action.functor_category_equivalence.functor_def Action.functorCategoryEquivalence.functor_def

theorem functorCategoryEquivalence.inverse_def :
    (functorCategoryEquivalence V G).inverse = FunctorCategoryEquivalence.inverse :=
  rfl
#align Action.functor_category_equivalence.inverse_def Action.functorCategoryEquivalence.inverse_def

instance [HasFiniteProducts V] : HasFiniteProducts (Action V G)
    where out n :=
    Adjunction.hasLimitsOfShape_of_equivalence (Action.functorCategoryEquivalence _ _).Functor

instance [HasFiniteLimits V] : HasFiniteLimits (Action V G)
    where out J _ _ :=
    adjunction.has_limits_of_shape_of_equivalence (Action.functorCategoryEquivalence _ _).Functor

instance [HasLimits V] : HasLimits (Action V G) :=
  Adjunction.has_limits_of_equivalence (Action.functorCategoryEquivalence _ _).Functor

instance [HasColimits V] : HasColimits (Action V G) :=
  Adjunction.has_colimits_of_equivalence (Action.functorCategoryEquivalence _ _).Functor

end

section Forget

variable (V G)

/-- (implementation) The forgetful functor from bundled actions to the underlying objects.

Use the `category_theory.forget` API provided by the `concrete_category` instance below,
rather than using this directly.
-/
@[simps]
def forget : Action V G ⥤ V where
  obj M := M.V
  map M N f := f.Hom
#align Action.forget Action.forget

instance : Faithful (forget V G) where map_injective' X Y f g w := Hom.ext _ _ w

instance [ConcreteCategory V] : ConcreteCategory (Action V G)
    where forget := forget V G ⋙ ConcreteCategory.Forget V

instance hasForgetToV [ConcreteCategory V] : HasForget₂ (Action V G) V where forget₂ := forget V G
#align Action.has_forget_to_V Action.hasForgetToV

/-- The forgetful functor is intertwined by `functor_category_equivalence` with
evaluation at `punit.star`. -/
def functorCategoryEquivalenceCompEvaluation :
    (functorCategoryEquivalence V G).Functor ⋙ (evaluation _ _).obj PUnit.unit ≅ forget V G :=
  Iso.refl _
#align Action.functor_category_equivalence_comp_evaluation Action.functorCategoryEquivalenceCompEvaluation

noncomputable instance [HasLimits V] : Limits.PreservesLimits (forget V G) :=
  Limits.preservesLimitsOfNatIso (Action.functorCategoryEquivalenceCompEvaluation V G)

noncomputable instance [HasColimits V] : PreservesColimits (forget V G) :=
  preservesColimitsOfNatIso (Action.functorCategoryEquivalenceCompEvaluation V G)

-- TODO construct categorical images?
end Forget

theorem Iso.conj_ρ {M N : Action V G} (f : M ≅ N) (g : G) :
    N.ρ g = ((forget V G).mapIso f).conj (M.ρ g) :=
  by
  rw [iso.conj_apply, iso.eq_inv_comp]
  simp [f.hom.comm']
#align Action.iso.conj_ρ Action.Iso.conj_ρ

section HasZeroMorphisms

variable [HasZeroMorphisms V]

instance : HasZeroMorphisms (Action V G)
    where
  Zero X Y :=
    ⟨⟨0, by
        intro g
        simp⟩⟩
  comp_zero P Q f R := by
    ext1
    simp
  zero_comp P Q R f := by
    ext1
    simp

instance forget_preservesZeroMorphisms : Functor.PreservesZeroMorphisms (forget V G) where
#align Action.forget_preserves_zero_morphisms Action.forget_preservesZeroMorphisms

instance forget₂_preservesZeroMorphisms [ConcreteCategory V] :
    Functor.PreservesZeroMorphisms (forget₂ (Action V G) V) where
#align Action.forget₂_preserves_zero_morphisms Action.forget₂_preservesZeroMorphisms

instance functorCategoryEquivalence_preservesZeroMorphisms :
    Functor.PreservesZeroMorphisms (functorCategoryEquivalence V G).Functor where
#align Action.functor_category_equivalence_preserves_zero_morphisms Action.functorCategoryEquivalence_preservesZeroMorphisms

end HasZeroMorphisms

section Preadditive

variable [Preadditive V]

instance : Preadditive (Action V G)
    where
  homGroup X Y :=
    { zero := ⟨0, by simp⟩
      add := fun f g => ⟨f.Hom + g.Hom, by simp [f.comm, g.comm]⟩
      neg := fun f => ⟨-f.Hom, by simp [f.comm]⟩
      zero_add := by
        intros
        ext
        exact zero_add _
      add_zero := by
        intros
        ext
        exact add_zero _
      add_assoc := by
        intros
        ext
        exact add_assoc _ _ _
      add_left_neg := by
        intros
        ext
        exact add_left_neg _
      add_comm := by
        intros
        ext
        exact add_comm _ _ }
  add_comp := by
    intros
    ext
    exact preadditive.add_comp _ _ _ _ _ _
  comp_add := by
    intros
    ext
    exact preadditive.comp_add _ _ _ _ _ _

instance forget_additive : Functor.Additive (forget V G) where
#align Action.forget_additive Action.forget_additive

instance forget₂_additive [ConcreteCategory V] : Functor.Additive (forget₂ (Action V G) V) where
#align Action.forget₂_additive Action.forget₂_additive

instance functorCategoryEquivalence_additive :
    Functor.Additive (functorCategoryEquivalence V G).Functor where
#align Action.functor_category_equivalence_additive Action.functorCategoryEquivalence_additive

@[simp]
theorem zero_hom {X Y : Action V G} : (0 : X ⟶ Y).Hom = 0 :=
  rfl
#align Action.zero_hom Action.zero_hom

@[simp]
theorem neg_hom {X Y : Action V G} (f : X ⟶ Y) : (-f).Hom = -f.Hom :=
  rfl
#align Action.neg_hom Action.neg_hom

@[simp]
theorem add_hom {X Y : Action V G} (f g : X ⟶ Y) : (f + g).Hom = f.Hom + g.Hom :=
  rfl
#align Action.add_hom Action.add_hom

@[simp]
theorem sum_hom {X Y : Action V G} {ι : Type _} (f : ι → (X ⟶ Y)) (s : Finset ι) :
    (s.Sum f).Hom = s.Sum fun i => (f i).Hom :=
  (forget V G).map_sum f s
#align Action.sum_hom Action.sum_hom

end Preadditive

section Linear

variable [Preadditive V] {R : Type _} [Semiring R] [Linear R V]

instance : Linear R (Action V G)
    where
  homModule X Y :=
    { smul := fun r f => ⟨r • f.Hom, by simp [f.comm]⟩
      one_smul := by
        intros
        ext
        exact one_smul _ _
      smul_zero := by
        intros
        ext
        exact smul_zero _
      zero_smul := by
        intros
        ext
        exact zero_smul _ _
      add_smul := by
        intros
        ext
        exact add_smul _ _ _
      smul_add := by
        intros
        ext
        exact smul_add _ _ _
      mul_smul := by
        intros
        ext
        exact mul_smul _ _ _ }
  smul_comp' := by
    intros
    ext
    exact linear.smul_comp _ _ _ _ _ _
  comp_smul' := by
    intros
    ext
    exact linear.comp_smul _ _ _ _ _ _

instance forget_linear : Functor.Linear R (forget V G) where
#align Action.forget_linear Action.forget_linear

instance forget₂_linear [ConcreteCategory V] : Functor.Linear R (forget₂ (Action V G) V) where
#align Action.forget₂_linear Action.forget₂_linear

instance functorCategoryEquivalence_linear :
    Functor.Linear R (functorCategoryEquivalence V G).Functor where
#align Action.functor_category_equivalence_linear Action.functorCategoryEquivalence_linear

@[simp]
theorem smul_hom {X Y : Action V G} (r : R) (f : X ⟶ Y) : (r • f).Hom = r • f.Hom :=
  rfl
#align Action.smul_hom Action.smul_hom

end Linear

section Abelian

/-- Auxilliary construction for the `abelian (Action V G)` instance. -/
def abelianAux : Action V G ≌ ULift.{u} (SingleObj G) ⥤ V :=
  (functorCategoryEquivalence V G).trans (Equivalence.congrLeft ULift.equivalence)
#align Action.abelian_aux Action.abelianAux

noncomputable instance [Abelian V] : Abelian (Action V G) :=
  abelianOfEquivalence abelianAux.Functor

end Abelian

section Monoidal

variable [MonoidalCategory V]

instance : MonoidalCategory (Action V G) :=
  Monoidal.transport (Action.functorCategoryEquivalence _ _).symm

@[simp]
theorem tensorUnit_v : (𝟙_ (Action V G)).V = 𝟙_ V :=
  rfl
#align Action.tensor_unit_V Action.tensorUnit_v

@[simp]
theorem tensorUnit_rho {g : G} : (𝟙_ (Action V G)).ρ g = 𝟙 (𝟙_ V) :=
  rfl
#align Action.tensor_unit_rho Action.tensorUnit_rho

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensor_v {X Y : Action V G} : (X ⊗ Y).V = X.V ⊗ Y.V :=
  rfl
#align Action.tensor_V Action.tensor_v

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensor_rho {X Y : Action V G} {g : G} : (X ⊗ Y).ρ g = X.ρ g ⊗ Y.ρ g :=
  rfl
#align Action.tensor_rho Action.tensor_rho

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorHom {W X Y Z : Action V G} (f : W ⟶ X) (g : Y ⟶ Z) : (f ⊗ g).Hom = f.Hom ⊗ g.Hom :=
  rfl
#align Action.tensor_hom Action.tensorHom

@[simp]
theorem associator_hom_hom {X Y Z : Action V G} : Hom.hom (α_ X Y Z).Hom = (α_ X.V Y.V Z.V).Hom :=
  by
  dsimp [monoidal.transport_associator]
  simp
#align Action.associator_hom_hom Action.associator_hom_hom

@[simp]
theorem associator_inv_hom {X Y Z : Action V G} : Hom.hom (α_ X Y Z).inv = (α_ X.V Y.V Z.V).inv :=
  by
  dsimp [monoidal.transport_associator]
  simp
#align Action.associator_inv_hom Action.associator_inv_hom

@[simp]
theorem leftUnitor_hom_hom {X : Action V G} : Hom.hom (λ_ X).Hom = (λ_ X.V).Hom :=
  by
  dsimp [monoidal.transport_left_unitor]
  simp
#align Action.left_unitor_hom_hom Action.leftUnitor_hom_hom

@[simp]
theorem leftUnitor_inv_hom {X : Action V G} : Hom.hom (λ_ X).inv = (λ_ X.V).inv :=
  by
  dsimp [monoidal.transport_left_unitor]
  simp
#align Action.left_unitor_inv_hom Action.leftUnitor_inv_hom

@[simp]
theorem rightUnitor_hom_hom {X : Action V G} : Hom.hom (ρ_ X).Hom = (ρ_ X.V).Hom :=
  by
  dsimp [monoidal.transport_right_unitor]
  simp
#align Action.right_unitor_hom_hom Action.rightUnitor_hom_hom

@[simp]
theorem rightUnitor_inv_hom {X : Action V G} : Hom.hom (ρ_ X).inv = (ρ_ X.V).inv :=
  by
  dsimp [monoidal.transport_right_unitor]
  simp
#align Action.right_unitor_inv_hom Action.rightUnitor_inv_hom

/-- Given an object `X` isomorphic to the tensor unit of `V`, `X` equipped with the trivial action
is isomorphic to the tensor unit of `Action V G`. -/
def tensorUnitIso {X : V} (f : 𝟙_ V ≅ X) : 𝟙_ (Action V G) ≅ Action.mk X 1 :=
  Action.mkIso f fun g => by
    simp only [MonoidHom.one_apply, End.one_def, category.id_comp f.hom, tensor_unit_rho,
      category.comp_id]
#align Action.tensor_unit_iso Action.tensorUnitIso

variable (V G)

/-- When `V` is monoidal the forgetful functor `Action V G` to `V` is monoidal. -/
@[simps]
def forgetMonoidal : MonoidalFunctor (Action V G) V :=
  { Action.forget _ _ with
    ε := 𝟙 _
    μ := fun X Y => 𝟙 _ }
#align Action.forget_monoidal Action.forgetMonoidal

instance forgetMonoidal_faithful : Faithful (forgetMonoidal V G).toFunctor :=
  by
  change faithful (forget V G)
  infer_instance
#align Action.forget_monoidal_faithful Action.forgetMonoidal_faithful

section

variable [BraidedCategory V]

instance : BraidedCategory (Action V G) :=
  braidedCategoryOfFaithful (forgetMonoidal V G) (fun X Y => mkIso (β_ _ _) (by tidy)) (by tidy)

/-- When `V` is braided the forgetful functor `Action V G` to `V` is braided. -/
@[simps]
def forgetBraided : BraidedFunctor (Action V G) V :=
  { forgetMonoidal _ _ with }
#align Action.forget_braided Action.forgetBraided

instance forgetBraided_faithful : Faithful (forgetBraided V G).toFunctor :=
  by
  change faithful (forget V G)
  infer_instance
#align Action.forget_braided_faithful Action.forgetBraided_faithful

end

instance [SymmetricCategory V] : SymmetricCategory (Action V G) :=
  symmetricCategoryOfFaithful (forgetBraided V G)

section

variable [Preadditive V] [MonoidalPreadditive V]

attribute [local simp] monoidal_preadditive.tensor_add monoidal_preadditive.add_tensor

instance : MonoidalPreadditive (Action V G) where

variable {R : Type _} [Semiring R] [Linear R V] [MonoidalLinear R V]

instance : MonoidalLinear R (Action V G) where

end

variable (V G)

noncomputable section

/-- Upgrading the functor `Action V G ⥤ (single_obj G ⥤ V)` to a monoidal functor. -/
def functorCategoryMonoidalEquivalence : MonoidalFunctor (Action V G) (SingleObj G ⥤ V) :=
  Monoidal.fromTransported (Action.functorCategoryEquivalence _ _).symm
#align Action.functor_category_monoidal_equivalence Action.functorCategoryMonoidalEquivalence

instance : IsEquivalence (functorCategoryMonoidalEquivalence V G).toFunctor :=
  by
  change is_equivalence (Action.functorCategoryEquivalence _ _).Functor
  infer_instance

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem functorCategoryMonoidalEquivalence.μ_app (A B : Action V G) :
    ((functorCategoryMonoidalEquivalence V G).μ A B).app PUnit.unit = 𝟙 _ :=
  by
  dsimp only [functor_category_monoidal_equivalence]
  simp only [monoidal.from_transported_to_lax_monoidal_functor_μ]
  show (𝟙 A.V ⊗ 𝟙 B.V) ≫ 𝟙 (A.V ⊗ B.V) ≫ (𝟙 A.V ⊗ 𝟙 B.V) = 𝟙 (A.V ⊗ B.V)
  simp only [monoidal_category.tensor_id, category.comp_id]
#align Action.functor_category_monoidal_equivalence.μ_app Action.functorCategoryMonoidalEquivalence.μ_app

@[simp]
theorem functorCategoryMonoidalEquivalence.μIso_inv_app (A B : Action V G) :
    ((functorCategoryMonoidalEquivalence V G).μIso A B).inv.app PUnit.unit = 𝟙 _ :=
  by
  rw [← nat_iso.app_inv, ← is_iso.iso.inv_hom]
  refine' is_iso.inv_eq_of_hom_inv_id _
  rw [category.comp_id, nat_iso.app_hom, monoidal_functor.μ_iso_hom,
    functor_category_monoidal_equivalence.μ_app]
#align Action.functor_category_monoidal_equivalence.μ_iso_inv_app Action.functorCategoryMonoidalEquivalence.μIso_inv_app

@[simp]
theorem functorCategoryMonoidalEquivalence.ε_app :
    (functorCategoryMonoidalEquivalence V G).ε.app PUnit.unit = 𝟙 _ :=
  by
  dsimp only [functor_category_monoidal_equivalence]
  simp only [monoidal.from_transported_to_lax_monoidal_functor_ε]
  show 𝟙 (monoidal_category.tensor_unit V) ≫ _ = 𝟙 (monoidal_category.tensor_unit V)
  rw [nat_iso.is_iso_inv_app, category.id_comp]
  exact is_iso.inv_id
#align Action.functor_category_monoidal_equivalence.ε_app Action.functorCategoryMonoidalEquivalence.ε_app

@[simp]
theorem functorCategoryMonoidalEquivalence.inv_counit_app_hom (A : Action V G) :
    ((functorCategoryMonoidalEquivalence _ _).inv.Adjunction.counit.app A).Hom = 𝟙 _ :=
  rfl
#align Action.functor_category_monoidal_equivalence.inv_counit_app_hom Action.functorCategoryMonoidalEquivalence.inv_counit_app_hom

@[simp]
theorem functorCategoryMonoidalEquivalence.counit_app (A : SingleObj G ⥤ V) :
    ((functorCategoryMonoidalEquivalence _ _).Adjunction.counit.app A).app PUnit.unit = 𝟙 _ :=
  rfl
#align Action.functor_category_monoidal_equivalence.counit_app Action.functorCategoryMonoidalEquivalence.counit_app

@[simp]
theorem functorCategoryMonoidalEquivalence.inv_unit_app_app (A : SingleObj G ⥤ V) :
    ((functorCategoryMonoidalEquivalence _ _).inv.Adjunction.Unit.app A).app PUnit.unit = 𝟙 _ :=
  rfl
#align Action.functor_category_monoidal_equivalence.inv_unit_app_app Action.functorCategoryMonoidalEquivalence.inv_unit_app_app

@[simp]
theorem functorCategoryMonoidalEquivalence.unit_app_hom (A : Action V G) :
    ((functorCategoryMonoidalEquivalence _ _).Adjunction.Unit.app A).Hom = 𝟙 _ :=
  rfl
#align Action.functor_category_monoidal_equivalence.unit_app_hom Action.functorCategoryMonoidalEquivalence.unit_app_hom

@[simp]
theorem functorCategoryMonoidalEquivalence.functor_map {A B : Action V G} (f : A ⟶ B) :
    (functorCategoryMonoidalEquivalence _ _).map f = FunctorCategoryEquivalence.functor.map f :=
  rfl
#align Action.functor_category_monoidal_equivalence.functor_map Action.functorCategoryMonoidalEquivalence.functor_map

@[simp]
theorem functorCategoryMonoidalEquivalence.inverse_map {A B : SingleObj G ⥤ V} (f : A ⟶ B) :
    (functorCategoryMonoidalEquivalence _ _).inv.map f = FunctorCategoryEquivalence.inverse.map f :=
  rfl
#align Action.functor_category_monoidal_equivalence.inverse_map Action.functorCategoryMonoidalEquivalence.inverse_map

variable (H : GroupCat.{u})

instance [RightRigidCategory V] : RightRigidCategory (SingleObj (H : MonCat.{u}) ⥤ V) :=
  by
  change right_rigid_category (single_obj H ⥤ V)
  infer_instance

/-- If `V` is right rigid, so is `Action V G`. -/
instance [RightRigidCategory V] : RightRigidCategory (Action V H) :=
  rightRigidCategoryOfEquivalence (functorCategoryMonoidalEquivalence V _)

instance [LeftRigidCategory V] : LeftRigidCategory (SingleObj (H : MonCat.{u}) ⥤ V) :=
  by
  change left_rigid_category (single_obj H ⥤ V)
  infer_instance

/-- If `V` is left rigid, so is `Action V G`. -/
instance [LeftRigidCategory V] : LeftRigidCategory (Action V H) :=
  leftRigidCategoryOfEquivalence (functorCategoryMonoidalEquivalence V _)

instance [RigidCategory V] : RigidCategory (SingleObj (H : MonCat.{u}) ⥤ V) :=
  by
  change rigid_category (single_obj H ⥤ V)
  infer_instance

/-- If `V` is rigid, so is `Action V G`. -/
instance [RigidCategory V] : RigidCategory (Action V H) :=
  rigidCategoryOfEquivalence (functorCategoryMonoidalEquivalence V _)

variable {V H} (X : Action V H)

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem rightDual_v [RightRigidCategory V] : Xᘁ.V = X.Vᘁ :=
  rfl
#align Action.right_dual_V Action.rightDual_v

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem leftDual_v [LeftRigidCategory V] : (ᘁX).V = ᘁX.V :=
  rfl
#align Action.left_dual_V Action.leftDual_v

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem rightDual_ρ [RightRigidCategory V] (h : H) : Xᘁ.ρ h = X.ρ (h⁻¹ : H)ᘁ :=
  by
  rw [← single_obj.inv_as_inv]
  rfl
#align Action.right_dual_ρ Action.rightDual_ρ

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem leftDual_ρ [LeftRigidCategory V] (h : H) : (ᘁX).ρ h = ᘁX.ρ (h⁻¹ : H) :=
  by
  rw [← single_obj.inv_as_inv]
  rfl
#align Action.left_dual_ρ Action.leftDual_ρ

end Monoidal

/-- Actions/representations of the trivial group are just objects in the ambient category. -/
def actionPunitEquivalence : Action V (MonCat.of PUnit) ≌ V
    where
  Functor := forget V _
  inverse :=
    { obj := fun X => ⟨X, 1⟩
      map := fun X Y f => ⟨f, fun ⟨⟩ => by simp⟩ }
  unitIso :=
    NatIso.ofComponents (fun X => mkIso (Iso.refl _) fun ⟨⟩ => by simpa using ρ_one X) (by tidy)
  counitIso := NatIso.ofComponents (fun X => Iso.refl _) (by tidy)
#align Action.Action_punit_equivalence Action.actionPunitEquivalence

variable (V)

/-- The "restriction" functor along a monoid homomorphism `f : G ⟶ H`,
taking actions of `H` to actions of `G`.

(This makes sense for any homomorphism, but the name is natural when `f` is a monomorphism.)
-/
@[simps]
def res {G H : MonCat} (f : G ⟶ H) : Action V H ⥤ Action V G
    where
  obj M :=
    { V := M.V
      ρ := f ≫ M.ρ }
  map M N p :=
    { Hom := p.Hom
      comm' := fun g => p.comm (f g) }
#align Action.res Action.res

/-- The natural isomorphism from restriction along the identity homomorphism to
the identity functor on `Action V G`.
-/
def resId {G : MonCat} : res V (𝟙 G) ≅ 𝟭 (Action V G) :=
  NatIso.ofComponents (fun M => mkIso (Iso.refl _) (by tidy)) (by tidy)
#align Action.res_id Action.resId

attribute [simps] res_id

/-- The natural isomorphism from the composition of restrictions along homomorphisms
to the restriction along the composition of homomorphism.
-/
def resComp {G H K : MonCat} (f : G ⟶ H) (g : H ⟶ K) : res V g ⋙ res V f ≅ res V (f ≫ g) :=
  NatIso.ofComponents (fun M => mkIso (Iso.refl _) (by tidy)) (by tidy)
#align Action.res_comp Action.resComp

attribute [simps] res_comp

-- TODO promote `res` to a pseudofunctor from
-- the locally discrete bicategory constructed from `Monᵒᵖ` to `Cat`, sending `G` to `Action V G`.
variable {G} {H : MonCat.{u}} (f : G ⟶ H)

instance res_additive [Preadditive V] : (res V f).Additive where
#align Action.res_additive Action.res_additive

variable {R : Type _} [Semiring R]

instance res_linear [Preadditive V] [Linear R V] : (res V f).Linear R where
#align Action.res_linear Action.res_linear

/-- Bundles a type `H` with a multiplicative action of `G` as an `Action`. -/
def ofMulAction (G H : Type u) [Monoid G] [MulAction G H] : Action (Type u) (MonCat.of G)
    where
  V := H
  ρ := @MulAction.toEndHom _ _ _ (by assumption)
#align Action.of_mul_action Action.ofMulAction

@[simp]
theorem ofMulAction_apply {G H : Type u} [Monoid G] [MulAction G H] (g : G) (x : H) :
    (ofMulAction G H).ρ g x = (g • x : H) :=
  rfl
#align Action.of_mul_action_apply Action.ofMulAction_apply

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:73:14: unsupported tactic `discrete_cases #[] -/
/-- Given a family `F` of types with `G`-actions, this is the limit cone demonstrating that the
product of `F` as types is a product in the category of `G`-sets. -/
def ofMulActionLimitCone {ι : Type v} (G : Type max v u) [Monoid G] (F : ι → Type max v u)
    [∀ i : ι, MulAction G (F i)] :
    LimitCone (Discrete.functor fun i : ι => Action.ofMulAction G (F i))
    where
  Cone :=
    { pt := Action.ofMulAction G (∀ i : ι, F i)
      π :=
        { app := fun i => ⟨fun x => x i.as, fun g => by ext <;> rfl⟩
          naturality' := fun i j x => by
            ext
            trace
              "./././Mathport/Syntax/Translate/Tactic/Builtin.lean:73:14: unsupported tactic `discrete_cases #[]"
            cases x
            congr } }
  IsLimit :=
    { lift := fun s =>
        { Hom := fun x i => (s.π.app ⟨i⟩).Hom x
          comm' := fun g => by
            ext (x j)
            dsimp
            exact congr_fun ((s.π.app ⟨j⟩).comm g) x }
      fac := fun s j => by
        ext
        dsimp
        congr
        rw [discrete.mk_as]
      uniq := fun s f h => by
        ext (x j)
        dsimp at *
        rw [← h ⟨j⟩]
        congr }
#align Action.of_mul_action_limit_cone Action.ofMulActionLimitCone

/-- The `G`-set `G`, acting on itself by left multiplication. -/
@[simps]
def leftRegular (G : Type u) [Monoid G] : Action (Type u) (MonCat.of G) :=
  Action.ofMulAction G G
#align Action.left_regular Action.leftRegular

/-- The `G`-set `Gⁿ`, acting on itself by left multiplication. -/
@[simps]
def diagonal (G : Type u) [Monoid G] (n : ℕ) : Action (Type u) (MonCat.of G) :=
  Action.ofMulAction G (Fin n → G)
#align Action.diagonal Action.diagonal

/-- We have `fin 1 → G ≅ G` as `G`-sets, with `G` acting by left multiplication. -/
def diagonalOneIsoLeftRegular (G : Type u) [Monoid G] : diagonal G 1 ≅ leftRegular G :=
  Action.mkIso (Equiv.funUnique _ _).toIso fun g => rfl
#align Action.diagonal_one_iso_left_regular Action.diagonalOneIsoLeftRegular

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Given `X : Action (Type u) (Mon.of G)` for `G` a group, then `G × X` (with `G` acting as left
multiplication on the first factor and by `X.ρ` on the second) is isomorphic as a `G`-set to
`G × X` (with `G` acting as left multiplication on the first factor and trivially on the second).
The isomorphism is given by `(g, x) ↦ (g, g⁻¹ • x)`. -/
@[simps]
def leftRegularTensorIso (G : Type u) [Group G] (X : Action (Type u) (MonCat.of G)) :
    leftRegular G ⊗ X ≅ leftRegular G ⊗ Action.mk X.V 1
    where
  Hom :=
    { Hom := fun g => ⟨g.1, (X.ρ (g.1⁻¹ : G) g.2 : X.V)⟩
      comm' := fun g =>
        funext fun x =>
          Prod.ext rfl <|
            show (X.ρ ((g * x.1)⁻¹ : G) * X.ρ g) x.2 = _ by
              simpa only [mul_inv_rev, ← X.ρ.map_mul, inv_mul_cancel_right] }
  inv :=
    { Hom := fun g => ⟨g.1, X.ρ g.1 g.2⟩
      comm' := fun g =>
        funext fun x =>
          Prod.ext rfl <| by
            simpa only [tensor_rho, types_comp_apply, tensor_apply, left_regular_ρ_apply, map_mul] }
  hom_inv_id' :=
    Hom.ext _ _
      (funext fun x =>
        Prod.ext rfl <|
          show (X.ρ x.1 * X.ρ (x.1⁻¹ : G)) x.2 = _ by
            simpa only [← X.ρ.map_mul, mul_inv_self, X.ρ.map_one] )
  inv_hom_id' :=
    Hom.ext _ _
      (funext fun x =>
        Prod.ext rfl <|
          show (X.ρ (x.1⁻¹ : G) * X.ρ x.1) _ = _ by
            simpa only [← X.ρ.map_mul, inv_mul_self, X.ρ.map_one] )
#align Action.left_regular_tensor_iso Action.leftRegularTensorIso

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The natural isomorphism of `G`-sets `Gⁿ⁺¹ ≅ G × Gⁿ`, where `G` acts by left multiplication on
each factor. -/
@[simps]
def diagonalSucc (G : Type u) [Monoid G] (n : ℕ) :
    diagonal G (n + 1) ≅ leftRegular G ⊗ diagonal G n :=
  mkIso (Equiv.piFinSuccAboveEquiv _ 0).toIso fun g => rfl
#align Action.diagonal_succ Action.diagonalSucc

end Action

namespace CategoryTheory.Functor

variable {V} {W : Type (u + 1)} [LargeCategory W]

/-- A functor between categories induces a functor between
the categories of `G`-actions within those categories. -/
@[simps]
def mapAction (F : V ⥤ W) (G : MonCat.{u}) : Action V G ⥤ Action W G
    where
  obj M :=
    { V := F.obj M.V
      ρ :=
        { toFun := fun g => F.map (M.ρ g)
          map_one' := by simp only [End.one_def, Action.ρ_one, F.map_id]
          map_mul' := fun g h => by simp only [End.mul_def, F.map_comp, map_mul] } }
  map M N f :=
    { Hom := F.map f.Hom
      comm' := fun g => by
        dsimp
        rw [← F.map_comp, f.comm, F.map_comp] }
  map_id' M := by
    ext
    simp only [Action.id_hom, F.map_id]
  map_comp' M N P f g := by
    ext
    simp only [Action.comp_hom, F.map_comp]
#align category_theory.functor.map_Action CategoryTheory.Functor.mapAction

variable (F : V ⥤ W) (G : MonCat.{u}) [Preadditive V] [Preadditive W]

instance mapAction_preadditive [F.Additive] : (F.mapAction G).Additive where
#align category_theory.functor.map_Action_preadditive CategoryTheory.Functor.mapAction_preadditive

variable {R : Type _} [Semiring R] [CategoryTheory.Linear R V] [CategoryTheory.Linear R W]

instance mapAction_linear [F.Additive] [F.Linear R] : (F.mapAction G).Linear R where
#align category_theory.functor.map_Action_linear CategoryTheory.Functor.mapAction_linear

end CategoryTheory.Functor

namespace CategoryTheory.MonoidalFunctor

open Action

variable {V} {W : Type (u + 1)} [LargeCategory W] [MonoidalCategory V] [MonoidalCategory W]
  (F : MonoidalFunctor V W) (G : MonCat.{u})

/-- A monoidal functor induces a monoidal functor between
the categories of `G`-actions within those categories. -/
@[simps]
def mapAction : MonoidalFunctor (Action V G) (Action W G) :=
  {-- See note [dsimp, simp].
          F.toFunctor.mapAction
      G with
    ε :=
      { Hom := F.ε
        comm' := fun g => by
          dsimp
          erw [category.id_comp, CategoryTheory.Functor.map_id, category.comp_id] }
    μ := fun X Y =>
      { Hom := F.μ X.V Y.V
        comm' := fun g => F.toLaxMonoidalFunctor.μ_natural (X.ρ g) (Y.ρ g) }
    ε_isIso := by infer_instance
    μ_isIso := by infer_instance
    μ_natural' := by
      intros
      ext
      dsimp
      simp
    associativity' := by
      intros
      ext
      dsimp
      simp
      dsimp
      simp
    left_unitality' := by
      intros
      ext
      dsimp
      simp
      dsimp
      simp
    right_unitality' := by
      intros
      ext
      dsimp
      simp
      dsimp
      simp }
#align category_theory.monoidal_functor.map_Action CategoryTheory.MonoidalFunctor.mapAction

@[simp]
theorem mapAction_ε_inv_hom : (inv (F.mapAction G).ε).Hom = inv F.ε :=
  by
  ext
  simp only [← F.map_Action_to_lax_monoidal_functor_ε_hom G, ← Action.comp_hom, is_iso.hom_inv_id,
    id_hom]
#align category_theory.monoidal_functor.map_Action_ε_inv_hom CategoryTheory.MonoidalFunctor.mapAction_ε_inv_hom

@[simp]
theorem mapAction_μ_inv_hom (X Y : Action V G) :
    (inv ((F.mapAction G).μ X Y)).Hom = inv (F.μ X.V Y.V) :=
  by
  ext
  simpa only [← F.map_Action_to_lax_monoidal_functor_μ_hom G, ← Action.comp_hom, is_iso.hom_inv_id,
    id_hom]
#align category_theory.monoidal_functor.map_Action_μ_inv_hom CategoryTheory.MonoidalFunctor.mapAction_μ_inv_hom

end CategoryTheory.MonoidalFunctor


import tactic.basic
import tactic.omega
import .ch11_imp

open imp

/-
Open Scope imp_scope.
Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O ⇒ empty_st
  | S i' ⇒
    match c with
      | SKIP ⇒
          st
      | l ::= a1 ⇒
          (l !-> aeval st a1 ; st)
      | c1 ;; c2 ⇒
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | TEST b THEN c1 ELSE c2 FI ⇒
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END ⇒
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.
Close Scope imp_scope.
-/

open nat

def ceval_step₂ : imp.state → com → ℕ → imp.state
| st c 0 := empty_st
| st SKIP (succ i) := st
| st (l ::= a₁) (succ i) := l !→ aeval st a₁ ; st
| st (c₁ ;; c₂) (succ i) :=
  let st' := ceval_step₂ st c₁ i in
  ceval_step₂ st' c₂ i
| st (TEST b THEN c₁ ELSE c₂ FI) (succ i) :=
  if beval st b
  then ceval_step₂ st c₁ i
  else ceval_step₂ st c₂ i
| st (WHILE b DO c END) (succ i) :=
  if beval st b
  then
    let st' := ceval_step₂ st c i in
    ceval_step₂ st' c i
  else st

/-
Open Scope imp_scope.
Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O ⇒ None
  | S i' ⇒
    match c with
      | SKIP ⇒
          Some st
      | l ::= a1 ⇒
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 ⇒
          match (ceval_step3 st c1 i') with
          | Some st' ⇒ ceval_step3 st' c2 i'
          | None ⇒ None
          end
      | TEST b THEN c1 ELSE c2 FI ⇒
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END ⇒
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' ⇒ ceval_step3 st' c i'
               | None ⇒ None
               end
          else Some st
    end
  end.
Close Scope imp_scope.
-/

def ceval_step₃ : imp.state → com → ℕ → option imp.state
| st c 0 := none
| st SKIP (succ i) := some st
| st (l ::= a₁) (succ i) := some $ l !→ aeval st a₁ ; st
| st (c₁ ;; c₂) (succ i) :=
  match ceval_step₃ st c₁ i with
  | some st' := ceval_step₃ st' c₂ i
  | none := none
  end
| st (TEST b THEN c₁ ELSE c₂ FI) (succ i) :=
  if beval st b
  then ceval_step₃ st c₁ i
  else ceval_step₃ st c₂ i
| st (WHILE b DO c END) (succ i) :=
  if beval st b
  then
    match ceval_step₃ st c i with
    | some st' := ceval_step₃ st' c i
    | none := none
    end
  else st

/-
Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x ⇒ e2
         | None ⇒ None
       end)
   (right associativity, at level 60).
Open Scope imp_scope.
Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O ⇒ None
  | S i' ⇒
    match c with
      | SKIP ⇒
          Some st
      | l ::= a1 ⇒
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 ⇒
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | TEST b THEN c1 ELSE c2 FI ⇒
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END ⇒
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.
Close Scope imp_scope.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None ⇒ None
  | Some st ⇒ Some (st X, st Y, st Z)
  end.

(* Compute
     (test_ceval empty_st
         (X ::= 2;;
          TEST (X <= 1)
            THEN Y ::= 3
            ELSE Z ::= 4
          FI)).
   ====>
      Some (2, 0, 4)   *)
-/

/- nah, not doing the notation -/
/- but the match is better -/

def ceval_step : imp.state → com → ℕ → option imp.state
| st c 0 := none
| st c (succ i) :=
  match c with
  | SKIP := some st
  | l ::= a₁ := some $ l !→ aeval st a₁ ; st
  | c₁ ;; c₂ := do st' ← ceval_step st c₁ i, ceval_step st' c₂ i
  | TEST b THEN c₁ ELSE c₂ FI :=
    if beval st b
    then ceval_step st c₁ i
    else ceval_step st c₂ i
  | WHILE b DO c₁ END :=
    if beval st b
    then do st' ← ceval_step st c₁ i, ceval_step st' c i
    else st
  end

def test_ceval (st c) :=
  do st ← ceval_step st c 500, pure (st X, st Y, st Z)

#eval test_ceval empty_st $
  X ::= 2;;
  TEST X ≤' 1
    THEN Y ::= 3
    ELSE Z ::= 4
  FI

/-
Definition pup_to_n : com
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
(*

Example pup_to_n_1 :
  test_ceval (X !-> 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)
-/

def pup_to_n' : com :=
  Y ::= 0;;
  WHILE ¬X == 0 DO
    Y ::= Y + X;;
    X ::= X - 1
  END

example : test_ceval (X !→ 5) pup_to_n' = some (0, 15, 0) := rfl

def is_even : com :=
  WHILE 2 ≤' X DO X ::= X - 2 END;;
  TEST X == 0 THEN Z ::= 0 ELSE Z ::= 1 FI

example : test_ceval (X !→ 5) is_even = some (1, 0, 1) := rfl

example : test_ceval (X !→ 10) is_even = some (0, 0, 0) := rfl

/-
Theorem ceval_step__ceval: ∀c st st',
      (∃i, ceval_step st c i = Some st') →
      st =[ c ]⇒ st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].
  - (* i = 0 -- contradictory *)
    intros c st st' H. discriminate H.
  - (* i = S i' *)
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + (* SKIP *) apply E_Skip.
      + (* ::= *) apply E_Ass. reflexivity.
      + (* ;; *)
        destruct (ceval_step st c1 i') eqn:Heqr1.
        * (* Evaluation of r1 terminates normally *)
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        * (* Otherwise -- contradiction *)
          discriminate H1.
      + (* TEST *)
        destruct (beval st b) eqn:Heqr.
        * (* r = true *)
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        * (* r = false *)
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
      + (* WHILE *) destruct (beval st b) eqn :Heqr.
        * (* r = true *)
         destruct (ceval_step st c i') eqn:Heqr1.
         { (* r1 = Some s *)
           apply E_WhileTrue with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { (* r1 = None *) discriminate H1. }
        * (* r = false *)
          injection H1. intros H2. rewrite <- H2.
          apply E_WhileFalse. apply Heqr. Qed.
-/

open imp.com imp.ceval

theorem ceval_step__ceval {c st st'} (h : ∃i, ceval_step st c i = some st')
  : st =[ c ]⇒ st' :=
begin
  cases h with i h,
  induction i with i ih generalizing c st st',
    cases h,
  cases c; simp [ceval_step] at h,
  case CSkip {
    subst h,
    exact E_Skip st,
  },
  case CAss : x a {
    subst h,
    apply E_Ass,
    refl,
  },
  case CSeq : c₁ c₂ {
    cases h with a h,
    exact E_Seq (ih h.left) (ih h.right),
  },
  case CIf : b c₁ c₂ {
    cases heq: beval st b; rw heq at h; simp at h,
      exact E_IfFalse c₁ heq (ih h),
    exact E_IfTrue c₂ heq (ih h),
  },
  case CWhile : b c {
    cases heq: beval st b; rw heq at h; simp at h,
      cases h,
      exact E_WhileFalse c heq,
    cases h with a h,
    exact E_WhileTrue heq (ih h.left) (ih h.right),
  },
end

/-
Theorem ceval_step_more: ∀i1 i2 st st' c,
  i1 ≤ i2 →
  ceval_step st c i1 = Some st' →
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  - (* i1 = 0 *)
    simpl in Hceval. discriminate Hceval.
  - (* i1 = S i1' *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' ≤ i2') by omega.
    destruct c.
    + (* SKIP *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ::= *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ;; *)
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* st1'o = None *)
        discriminate Hceval.
    + (* TEST *)
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.
    + (* WHILE *)
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite → Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* i1'o = None *)
        simpl in Hceval. discriminate Hceval. Qed.
-/

theorem ceval_step_more {i₁ i₂ st st' c}
  (hl : i₁ ≤ i₂) (h: ceval_step st c i₁ = some st')
  : ceval_step st c i₂ = some st' :=
begin
  induction i₁ with i₁ ih generalizing i₂ st st' c,
    unfold ceval_step at h,
    cases h,
  cases i₂,
    cases hl,
  /- omega failed here (yikes) -/
  have hl, exact le_of_succ_le_succ hl,
  cases c,
  case CSkip {
    cases h,
    unfold ceval_step,
  },
  case CAss : x a {
    unfold ceval_step at *,
    assumption,
  },
  case CSeq : c₁ c₂ {
    unfold ceval_step at *,
    cases h₁ : ceval_step st c₁ i₁ with st'',
      simp only [ceval_step, h₁] at h,
      contradiction,
    simp only [h₁, option.some_bind] at h,
    simp only [ih hl h₁, ih hl h, option.some_bind],
  },
  case CIf : b c₁ c₂ {
    unfold ceval_step at *,
    cases beval st b; simp at *; exact ih hl h,
  },
  case CWhile : b c {
    unfold ceval_step at *,
    cases beval st b; simp at *,
      exact h,
    cases h with a h,
    exact ⟨a, ih hl h.left, ih hl h.right⟩,
  },
end

/-
Theorem ceval__ceval_step: ∀c st st',
      st =[ c ]⇒ st' →
      ∃i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  (* FILL IN HERE *) Admitted.
-/

lemma le_max (n m : ℕ) : n ≤ max n m ∧ m ≤ max n m :=
begin
  simp only [le_max_iff],
  split,
    exact or.inl (refl _),
  exact or.inr (refl _),
end

theorem ceval__ceval_step {c st st'} (h : st =[ c ]⇒ st')
  : ∃i, ceval_step st c i = some st' :=
begin
  induction h,
  case E_Skip { exact ⟨1, rfl⟩, },
  case E_Ass : st a n x h {
    exact ⟨1, by simp only [ceval_step, h]⟩,
  },
  case E_Seq : c₁ c₂ st'' st''' st'''' h₁ h₂ ih₁ ih₂ {
    cases ih₁ with i₁ ih₁,
    cases ih₂ with i₂ ih₂,
    exact ⟨max i₁ i₂ + 1, by {
      unfold ceval_step,
      have hl, exact le_max i₁ i₂,
      simp [ceval_step_more hl.left ih₁, ceval_step_more hl.right ih₂],
    }⟩,
  },
  case E_IfTrue : st'' st''' b c₁ c₂ h₁ h₂ ih {
    cases ih with i ih,
    exact ⟨i + 1, by {
      unfold ceval_step,
      simp [h₁, ih],
    }⟩,
  },
  case E_IfFalse : st'' st''' b c₁ c₂ h₁ h₂ ih {
    cases ih with i ih,
    exact ⟨i + 1, by {
      unfold ceval_step,
      simp [h₁, ih],
    }⟩,
  },
  case E_WhileFalse : b st'' c h {
    exact ⟨1, by {
      unfold ceval_step,
      simp [h],
      refl,
    }⟩,
  },
  case E_WhileTrue : st'' st''' st'''' b c hb h₂ h₃ ih₁ ih₂ {
    cases ih₁ with i₁ ih₁,
    cases ih₂ with i₂ ih₂,
    exact ⟨max i₁ i₂ + 1, by {
      unfold ceval_step,
      simp [hb],
      exact ⟨st''', by {
        have hl, exact le_max i₁ i₂,
        exact ⟨ceval_step_more hl.left ih₁, ceval_step_more hl.right ih₂⟩,
      }⟩,
    }⟩,
  },
end

/-
Theorem ceval_and_ceval_step_coincide: ∀c st st',
      st =[ c ]⇒ st'
  ↔ ∃i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.
-/

theorem ceval_and_ceval_step_coincide (c st st')
  : (st =[ c ]⇒ st') ↔ ∃i, ceval_step st c i = some st' :=
⟨ceval__ceval_step, ceval_step__ceval⟩

/-
Theorem ceval_deterministic' : ∀c st st1 st2,
     st =[ c ]⇒ st1 →
     st =[ c ]⇒ st2 →
     st1 = st2.

Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega. Qed.
-/

theorem ceval_deterministic' {c st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : st =[ c ]⇒ st₂) : st₁ = st₂ :=
begin
  cases ceval__ceval_step h₁ with i₁ h₁,
  cases ceval__ceval_step h₂ with i₂ h₂,
  replace h₂, exact ceval_step_more (le_max i₁ i₂).right h₂,
  rw ceval_step_more (le_max i₁ i₂).left h₁ at h₂,
  injection h₂,
end