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

! This file was ported from Lean 3 source module category_theory.limits.concrete_category
! leanprover-community/mathlib commit c3019c79074b0619edb4b27553a91b2e82242395
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Preserves.Basic
import Mathlib.CategoryTheory.Limits.Types
import Mathlib.CategoryTheory.Limits.Shapes.WidePullbacks
import Mathlib.CategoryTheory.Limits.Shapes.Multiequalizer
import Mathlib.CategoryTheory.ConcreteCategory.Basic
import Mathlib.CategoryTheory.Limits.Shapes.Kernels
import Mathlib.Tactic.ApplyFun

/-!
# Facts about (co)limits of functors into concrete categories
-/

universe w v u

open CategoryTheory

namespace CategoryTheory.Limits

attribute [local instance] ConcreteCategory.hasCoeToFun ConcreteCategory.hasCoeToSort

section Limits

variable {C : Type u} [Category.{v} C] [ConcreteCategory.{max w v} C] {J : Type w} [SmallCategory J]
  (F : J ⥤ C) [PreservesLimit F (forget C)]

theorem Concrete.to_product_injective_of_isLimit {D : Cone F} (hD : IsLimit D) :
    Function.Injective fun (x : D.pt) (j : J) => D.π.app j x := by
  let E := (forget C).mapCone D
  let hE : IsLimit E := isLimitOfPreserves _ hD
  let G := Types.limitCone.{w, v} (F ⋙ forget C)
  let hG := Types.limitConeIsLimit.{w, v} (F ⋙ forget C)
  let T : E.pt ≅ G.pt := hE.conePointUniqueUpToIso hG
  change Function.Injective (T.hom ≫ fun x j => G.π.app j x)
  have h : Function.Injective T.hom := by
    intro a b h
    suffices T.inv (T.hom a) = T.inv (T.hom b) by simpa
    rw [h]
  suffices Function.Injective fun (x : G.pt) j => G.π.app j x by exact this.comp h
  apply Subtype.ext
#align category_theory.limits.concrete.to_product_injective_of_is_limit CategoryTheory.Limits.Concrete.to_product_injective_of_isLimit

theorem Concrete.isLimit_ext {D : Cone F} (hD : IsLimit D) (x y : D.pt) :
    (∀ j, D.π.app j x = D.π.app j y) → x = y := fun h =>
  Concrete.to_product_injective_of_isLimit _ hD (funext h)
#align category_theory.limits.concrete.is_limit_ext CategoryTheory.Limits.Concrete.isLimit_ext

theorem Concrete.limit_ext [HasLimit F] (x y : ↑(limit F)) :
    (∀ j, limit.π F j x = limit.π F j y) → x = y :=
  Concrete.isLimit_ext F (limit.isLimit _) _ _
#align category_theory.limits.concrete.limit_ext CategoryTheory.Limits.Concrete.limit_ext

section WidePullback

open WidePullback

open WidePullbackShape

theorem Concrete.widePullback_ext {B : C} {ι : Type w} {X : ι → C} (f : ∀ j : ι, X j ⟶ B)
    [HasWidePullback B X f] [PreservesLimit (wideCospan B X f) (forget C)]
    (x y : ↑(widePullback B X f)) (h₀ : base f x = base f y) (h : ∀ j, π f j x = π f j y) :
    x = y := by
  apply Concrete.limit_ext
  rintro (_ | j)
  · exact h₀
  · apply h
#align category_theory.limits.concrete.wide_pullback_ext CategoryTheory.Limits.Concrete.widePullback_ext

theorem Concrete.widePullback_ext' {B : C} {ι : Type w} [Nonempty ι] {X : ι → C}
    (f : ∀ j : ι, X j ⟶ B) [HasWidePullback.{w} B X f]
    [PreservesLimit (wideCospan B X f) (forget C)] (x y : ↑(widePullback B X f))
    (h : ∀ j, π f j x = π f j y) : x = y := by
  apply Concrete.widePullback_ext _ _ _ _ h
  inhabit ι
  simp only [← π_arrow f default, comp_apply, h]
#align category_theory.limits.concrete.wide_pullback_ext' CategoryTheory.Limits.Concrete.widePullback_ext'

end WidePullback

section Multiequalizer

theorem Concrete.multiequalizer_ext {I : MulticospanIndex.{w} C} [HasMultiequalizer I]
    [PreservesLimit I.multicospan (forget C)] (x y : ↑(multiequalizer I))
    (h : ∀ t : I.L, Multiequalizer.ι I t x = Multiequalizer.ι I t y) : x = y := by
  apply Concrete.limit_ext
  rintro (a | b)
  · apply h
  · rw [← limit.w I.multicospan (WalkingMulticospan.Hom.fst b), comp_apply, comp_apply, h]
#align category_theory.limits.concrete.multiequalizer_ext CategoryTheory.Limits.Concrete.multiequalizer_ext

/-- An auxiliary equivalence to be used in `multiequalizerEquiv` below.-/
def Concrete.multiequalizerEquivAux (I : MulticospanIndex C) :
    (I.multicospan ⋙ forget C).sections ≃
      { x : ∀ i : I.L, I.left i // ∀ i : I.R, I.fst i (x _) = I.snd i (x _) }
    where
  toFun x :=
    ⟨fun i => x.1 (WalkingMulticospan.left _), fun i =>
      by
      have a := x.2 (WalkingMulticospan.Hom.fst i)
      have b := x.2 (WalkingMulticospan.Hom.snd i)
      rw [← b] at a
      exact a⟩
  invFun x :=
    { val := fun j =>
        match j with
        | WalkingMulticospan.left a => x.1 _
        | WalkingMulticospan.right b => I.fst b (x.1 _)
      property := by
        rintro (a | b) (a' | b') (f | f | f)
        · change (I.multicospan.map (𝟙 _)) _ = _
          simp
        · rfl
        · dsimp
          erw [← x.2 b']
        · change (I.multicospan.map (𝟙 _)) _ = _
          simp }
  left_inv := by
    intro x; ext (a | b)
    · rfl
    · change _ = x.val _
      rw [← x.2 (WalkingMulticospan.Hom.fst b)]
      rfl
  right_inv := by
    intro x
    ext i
    rfl
#align category_theory.limits.concrete.multiequalizer_equiv_aux CategoryTheory.Limits.Concrete.multiequalizerEquivAux

/-- The equivalence between the noncomputable multiequalizer and
and the concrete multiequalizer. -/
noncomputable def Concrete.multiequalizerEquiv (I : MulticospanIndex.{w} C) [HasMultiequalizer I]
    [PreservesLimit I.multicospan (forget C)] :
    (multiequalizer I : C) ≃
      { x : ∀ i : I.L, I.left i // ∀ i : I.R, I.fst i (x _) = I.snd i (x _) } := by
  let h1 := limit.isLimit I.multicospan
  let h2 := isLimitOfPreserves (forget C) h1
  let E := h2.conePointUniqueUpToIso (Types.limitConeIsLimit.{w, v} _)
  exact Equiv.trans E.toEquiv (Concrete.multiequalizerEquivAux.{w, v} I)
#align category_theory.limits.concrete.multiequalizer_equiv CategoryTheory.Limits.Concrete.multiequalizerEquiv

@[simp]
theorem Concrete.multiequalizerEquiv_apply (I : MulticospanIndex.{w} C) [HasMultiequalizer I]
    [PreservesLimit I.multicospan (forget C)] (x : ↑(multiequalizer I)) (i : I.L) :
    ((Concrete.multiequalizerEquiv I) x : ∀ i : I.L, I.left i) i = Multiequalizer.ι I i x :=
  rfl
#align category_theory.limits.concrete.multiequalizer_equiv_apply CategoryTheory.Limits.Concrete.multiequalizerEquiv_apply

end Multiequalizer

-- TODO: Add analogous lemmas about products and equalizers.
end Limits

section Colimits

-- We don't mark this as an `@[ext]` lemma as we don't always want to work elementwise.
theorem cokernel_funext {C : Type _} [Category C] [HasZeroMorphisms C] [ConcreteCategory C]
    {M N K : C} {f : M ⟶ N} [HasCokernel f] {g h : cokernel f ⟶ K}
    (w : ∀ n : N, g (cokernel.π f n) = h (cokernel.π f n)) : g = h := by
  apply coequalizer.hom_ext
  apply ConcreteCategory.hom_ext _ _
  simpa using w
#align category_theory.limits.cokernel_funext CategoryTheory.Limits.cokernel_funext

variable {C : Type u} [Category.{v} C] [ConcreteCategory.{v} C] {J : Type v} [SmallCategory J]
  (F : J ⥤ C) [PreservesColimit F (forget C)]

theorem Concrete.isColimit_exists_rep {D : Cocone F} (hD : IsColimit D) (x : D.pt) :
    ∃ (j : J)(y : F.obj j), D.ι.app j y = x := by
  obtain ⟨a, rfl⟩ := Concrete.from_union_surjective_of_isColimit F hD x
  exact ⟨a.1, a.2, rfl⟩
#align category_theory.limits.concrete.is_colimit_exists_rep CategoryTheory.Limits.Concrete.isColimit_exists_rep

theorem Concrete.colimit_exists_rep [HasColimit F] (x : ↑(colimit F)) :
    ∃ (j : J)(y : F.obj j), colimit.ι F j y = x :=
  Concrete.isColimit_exists_rep F (colimit.isColimit _) x
#align category_theory.limits.concrete.colimit_exists_rep CategoryTheory.Limits.Concrete.colimit_exists_rep

theorem Concrete.isColimit_rep_eq_of_exists {D : Cocone F} {i j : J} (hD : IsColimit D)
    (x : F.obj i) (y : F.obj j) (h : ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f x = F.map g y) :
    D.ι.app i x = D.ι.app j y := by
  let E := (forget C).mapCocone D
  let hE : IsColimit E := isColimitOfPreserves _ hD
  let G := Types.colimitCocone.{v, v} (F ⋙ forget C)
  let hG := Types.colimitCoconeIsColimit.{v, v} (F ⋙ forget C)
  let T : E ≅ G := hE.uniqueUpToIso hG
  let TX : E.pt ≅ G.pt := (Cocones.forget _).mapIso T
  -- porting note: `apply_fun TX.hom` does not work here
  apply (show Function.Bijective TX.hom by
    rw [← isIso_iff_bijective]
    apply IsIso.of_iso).1
  change (E.ι.app i ≫ TX.hom) x = (E.ι.app j ≫ TX.hom) y
  erw [T.hom.w, T.hom.w]
  obtain ⟨k, f, g, h⟩ := h
  have : G.ι.app i x = (G.ι.app k (F.map f x) : G.pt) := Quot.sound ⟨f, rfl⟩
  rw [this, h]
  symm
  exact Quot.sound ⟨g, rfl⟩
#align category_theory.limits.concrete.is_colimit_rep_eq_of_exists CategoryTheory.Limits.Concrete.isColimit_rep_eq_of_exists

theorem Concrete.colimit_rep_eq_of_exists [HasColimit F] {i j : J} (x : F.obj i) (y : F.obj j)
    (h : ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f x = F.map g y) :
    colimit.ι F i x = colimit.ι F j y :=
  Concrete.isColimit_rep_eq_of_exists F (colimit.isColimit _) x y h
#align category_theory.limits.concrete.colimit_rep_eq_of_exists CategoryTheory.Limits.Concrete.colimit_rep_eq_of_exists

section FilteredColimits

variable [IsFiltered J]

theorem Concrete.isColimit_exists_of_rep_eq {D : Cocone F} {i j : J} (hD : IsColimit D)
    (x : F.obj i) (y : F.obj j) (h : D.ι.app _ x = D.ι.app _ y) :
    ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f x = F.map g y := by
  let E := (forget C).mapCocone D
  let hE : IsColimit E := isColimitOfPreserves _ hD
  let G := Types.colimitCocone.{v, v} (F ⋙ forget C)
  let hG := Types.colimitCoconeIsColimit.{v, v} (F ⋙ forget C)
  let T : E ≅ G := hE.uniqueUpToIso hG
  let TX : E.pt ≅ G.pt := (Cocones.forget _).mapIso T
  -- porting note: `apply_fun TX.hom at h` does not work here
  replace h := congr_arg TX.hom h
  change (E.ι.app i ≫ TX.hom) x = (E.ι.app j ≫ TX.hom) y at h
  erw [T.hom.w, T.hom.w] at h
  replace h := Quot.exact _ h
  suffices
    ∀ (a b : Σj, F.obj j) (_ : EqvGen (Limits.Types.Quot.Rel.{v, v} (F ⋙ forget C)) a b),
      ∃ (k : _)(f : a.1 ⟶ k)(g : b.1 ⟶ k), F.map f a.2 = F.map g b.2
    by exact this ⟨i, x⟩ ⟨j, y⟩ h
  intro a b h
  induction h
  case rel x y hh =>
    obtain ⟨e, he⟩ := hh
    use y.1, e, 𝟙 _
    simpa using he.symm
  case refl x =>
    exact ⟨x.1, 𝟙 _, 𝟙 _, rfl⟩
  case symm x y _ hh =>
    obtain ⟨k, f, g, hh⟩ := hh
    exact ⟨k, g, f, hh.symm⟩
  case trans x y z _ _ hh1 hh2 =>
    obtain ⟨k1, f1, g1, h1⟩ := hh1
    obtain ⟨k2, f2, g2, h2⟩ := hh2
    let k0 : J := IsFiltered.max k1 k2
    let e1 : k1 ⟶ k0 := IsFiltered.leftToMax _ _
    let e2 : k2 ⟶ k0 := IsFiltered.rightToMax _ _
    let k : J := IsFiltered.coeq (g1 ≫ e1) (f2 ≫ e2)
    let e : k0 ⟶ k := IsFiltered.coeqHom _ _
    use k, f1 ≫ e1 ≫ e, g2 ≫ e2 ≫ e
    simp only [F.map_comp, comp_apply, h1, ← h2]
    simp only [← comp_apply, ← F.map_comp]
    rw [IsFiltered.coeq_condition]
#align category_theory.limits.concrete.is_colimit_exists_of_rep_eq CategoryTheory.Limits.Concrete.isColimit_exists_of_rep_eq

theorem Concrete.isColimit_rep_eq_iff_exists {D : Cocone F} {i j : J} (hD : IsColimit D)
    (x : F.obj i) (y : F.obj j) :
    D.ι.app i x = D.ι.app j y ↔ ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f x = F.map g y :=
  ⟨Concrete.isColimit_exists_of_rep_eq _ hD _ _, Concrete.isColimit_rep_eq_of_exists _ hD _ _⟩
#align category_theory.limits.concrete.is_colimit_rep_eq_iff_exists CategoryTheory.Limits.Concrete.isColimit_rep_eq_iff_exists

theorem Concrete.colimit_exists_of_rep_eq [HasColimit F] {i j : J} (x : F.obj i) (y : F.obj j)
    (h : colimit.ι F _ x = colimit.ι F _ y) :
    ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f x = F.map g y :=
  Concrete.isColimit_exists_of_rep_eq F (colimit.isColimit _) x y h
#align category_theory.limits.concrete.colimit_exists_of_rep_eq CategoryTheory.Limits.Concrete.colimit_exists_of_rep_eq

theorem Concrete.colimit_rep_eq_iff_exists [HasColimit F] {i j : J} (x : F.obj i) (y : F.obj j) :
    colimit.ι F i x = colimit.ι F j y ↔ ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f x = F.map g y :=
  ⟨Concrete.colimit_exists_of_rep_eq _ _ _, Concrete.colimit_rep_eq_of_exists _ _ _⟩
#align category_theory.limits.concrete.colimit_rep_eq_iff_exists CategoryTheory.Limits.Concrete.colimit_rep_eq_iff_exists

end FilteredColimits

section WidePushout

open WidePushout

open WidePushoutShape

theorem Concrete.widePushout_exists_rep {B : C} {α : Type _} {X : α → C} (f : ∀ j : α, B ⟶ X j)
    [HasWidePushout.{v} B X f] [PreservesColimit (wideSpan B X f) (forget C)]
    (x : ↑(widePushout B X f)) : (∃ y : B, head f y = x) ∨ ∃ (i : α)(y : X i), ι f i y = x := by
  obtain ⟨_ | j, y, rfl⟩ := Concrete.colimit_exists_rep _ x
  · left
    use y
  · right
    use j, y
#align category_theory.limits.concrete.wide_pushout_exists_rep CategoryTheory.Limits.Concrete.widePushout_exists_rep

theorem Concrete.widePushout_exists_rep' {B : C} {α : Type _} [Nonempty α] {X : α → C}
    (f : ∀ j : α, B ⟶ X j) [HasWidePushout.{v} B X f] [PreservesColimit (wideSpan B X f) (forget C)]
    (x : ↑(widePushout B X f)) : ∃ (i : α)(y : X i), ι f i y = x := by
  rcases Concrete.widePushout_exists_rep f x with (⟨y, rfl⟩ | ⟨i, y, rfl⟩)
  · inhabit α
    use default, f _ y
    simp only [← arrow_ι _ default, comp_apply]
  · use i, y
#align category_theory.limits.concrete.wide_pushout_exists_rep' CategoryTheory.Limits.Concrete.widePushout_exists_rep'

end WidePushout

-- TODO: Add analogous lemmas about coproducts and coequalizers.
end Colimits

end CategoryTheory.Limits


import .geom1d

open_locale affine

section fix_this_name

universes u

/-
3D Geometric Space with Std Coordinate System
-/
noncomputable def std_3d_geom :=
    (mk_prod_spc (mk_prod_spc geom1d_std_space geom1d_std_space) geom1d_std_space)
abbreviation geom3d_frame := std_3d_geom.frame_type
abbreviation geom3d_space (f : geom3d_frame) := spc real_scalar f
noncomputable def geom3d_std_frame := std_3d_geom.frame
noncomputable def geom3d_std_space : geom3d_space geom3d_std_frame := std_3d_geom

/-
Positions are points in this space.
-/

-- public
structure position3d {f : geom3d_frame} (s : geom3d_space f ) extends point s

-- public, to enable certain proofs that clients might want to write
@[ext] lemma position3d.ext : ∀  {f : geom3d_frame} {s : geom3d_space f } (x y : position3d 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 s).to_point = x := rfl,
        simp [h₁] at e,
        exact e
    end

noncomputable def position3d.coords {f : geom3d_frame} {s : geom3d_space f } (p :position3d s) :=
    λi : fin 3, (p.to_point.coords i).coord

/-
User can use coordinates to build an object, but once this is done, the coordinates should
disappear inside the object. From there, you should be able to ask the object to return its
coordinates *in any given ACS (on the same physical dimension).

noncomputable def position3d.coords_in_s' {f f': geom3d_frame} {s : geom3d_space f } (p :position3d s) (s' : geom3d_space f' ) :=
    p.to_point.coords -- should get back (transform p) . coords.
-/

/-

def point.expressed_in
    {dim : ℕ} {id_vec : fin dim → ℕ} {f: fm K dim id_vec} {s : spc K f}
    {f2: fm K dim id_vec} {s2 : spc K f2}

    (p1 : point s) (s2 : spc K f2) : point s2 :=
    (s.fm_tr s2).transform_point p1

def vectr.expressed_in
    {dim : ℕ} {id_vec : fin dim → ℕ} {f: fm K dim id_vec} {s : spc K f}
    {f2: fm K dim id_vec} {s2 : spc K f2}

    (v1 : vectr s) (s2 : spc K f2) : vectr s2 :=
    (s.fm_tr s2).transform_vectr v1
-/

noncomputable def position3d.expressed_in {f : geom3d_frame} {s : geom3d_space f } (p :position3d s)
    : Π {f' : geom3d_frame} (s' : geom3d_space f' ), position3d s' :=
        λ f' s',
        ⟨(p.to_point.expressed_in s')⟩

noncomputable def position3d.coords_in {f : geom3d_frame} {s : geom3d_space f } (p :position3d s)
    : Π {f' : geom3d_frame} (s' : geom3d_space f' ), fin 3 → scalar :=
        λ f' s',
        λi, ((p.expressed_in s').to_point.coords i).coord

noncomputable def position3d.x {f : geom3d_frame} {s : geom3d_space f } (p :position3d s) : real_scalar :=
    (p.to_point.coords 0).coord

noncomputable def position3d.y {f : geom3d_frame} {s : geom3d_space f } (p :position3d s) : real_scalar :=
    (p.to_point.coords 1).coord

noncomputable def position3d.z {f : geom3d_frame} {s : geom3d_space f } (p :position3d s) : real_scalar :=
    (p.to_point.coords 2).coord

noncomputable def mk_position3d
    {f : geom3d_frame}
    (s : geom3d_space f )
    (k₁ k₂ k₃ : real_scalar) :
    position3d s :=
position3d.mk (mk_point s ⟨[k₁,k₂,k₃],rfl⟩)

-- Private
@[simp]
def mk_position3d' {f : geom3d_frame} (s : geom3d_space f ) (p : point s) : position3d s := position3d.mk p

-- Private
@[simp]
noncomputable def mk_position3d'' {f1 f2 f3 : geom1d_frame } { s1 : geom1d_space f1} {s2 : geom1d_space f2} { s3 : geom1d_space f3}
    (p1 : position1d s1) (p2 : position1d s2) (p3 : position1d s3 )
    : position3d (mk_prod_spc (mk_prod_spc s1 s2) s3) :=
    ⟨mk_point_prod (mk_point_prod p1.to_point p2.to_point) p3.to_point⟩

/-
Displacements are vectors in this affine coordinate space
-/

-- Public
structure displacement3d {f : geom3d_frame} (s : geom3d_space f ) extends vectr s
@[ext] lemma displacement3d.ext : ∀  {f : geom3d_frame} {s : geom3d_space f } (x y : displacement3d 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 s).to_vectr = x := rfl,
        simp [h₁] at e,
        exact e
    end

-- Public
def displacement3d.frame {f : geom3d_frame} {s : geom3d_space f } (d :displacement3d s) :=
    f

-- Public

noncomputable def displacement3d.expressed_in {f : geom3d_frame} {s : geom3d_space f } (p : displacement3d s)
    : Π {f' : geom3d_frame} (s' : geom3d_space f' ), displacement3d s' :=
        λ f' s',
        ⟨(p.to_vectr.expressed_in s')⟩

noncomputable def displacement3d.coords_in {f : geom3d_frame} {s : geom3d_space f } (p : displacement3d s)
    : Π {f' : geom3d_frame} (s' : geom3d_space f' ), fin 3 → scalar :=
        λ f' s',
        λi, ((p.expressed_in s').to_vectr.coords i).coord

noncomputable def displacement3d.coords {f : geom3d_frame} {s : geom3d_space f } (d :displacement3d s) :=
    λi : fin 3, (d.to_vectr.coords i).coord

noncomputable def displacement3d.x {f : geom3d_frame} {s : geom3d_space f } (p :displacement3d s) : real_scalar :=
    (p.to_vectr.coords 0).coord

noncomputable def displacement3d.y {f : geom3d_frame} {s : geom3d_space f } (p :displacement3d s) : real_scalar :=
    (p.to_vectr.coords 1).coord

noncomputable def displacement3d.z {f : geom3d_frame} {s : geom3d_space f } (p :displacement3d s) : real_scalar :=
    (p.to_vectr.coords 2).coord
-- Private
@[simp]
def mk_displacement3d' {f : geom3d_frame} (s : geom3d_space f ) (v : vectr s) : displacement3d s := displacement3d.mk v
@[simp]
noncomputable def mk_displacement3d  {f : geom3d_frame} (s : geom3d_space f ) (k₁ k₂ k₃ : real_scalar) : displacement3d s := displacement3d.mk (mk_vectr s ⟨[k₁,k₂,k₃],rfl⟩)

-- Private
@[simp]
noncomputable def mk_displacement3d'' {f1 f2 f3 : geom1d_frame } { s1 : geom1d_space f1} {s2 : geom1d_space f2} { s3 : geom1d_space f3}
    (p1 : displacement1d s1) (p2 : displacement1d s2) (p3 : displacement1d s3 )
    : displacement3d (mk_prod_spc (mk_prod_spc s1 s2) s3) :=
    ⟨mk_vectr_prod (mk_vectr_prod p1.to_vectr p2.to_vectr) p3.to_vectr⟩

-- Public
@[simp]
noncomputable def mk_geom3d_frame {parent : geom3d_frame} {s : spc real_scalar parent} (p : position3d s)
    (v0 : displacement3d s) (v1 : displacement3d s) (v2 : displacement3d s)
    : geom3d_frame :=
    (mk_frame p.to_point ⟨(λi, if i = 0 then v0.to_vectr else if i = 1 then v1.to_vectr else v2.to_vectr),sorry,sorry⟩)

-- Public
@[simp]
noncomputable def mk_geom3d_space (fr : geom3d_frame) : geom3d_space _ := mk_space fr

end fix_this_name

section fix_this_name_too

/-
Proof that geom3d is an affine coordinate space
-/

namespace geom3d
variables {f : geom3d_frame} {s : geom3d_space f }
@[simp]
noncomputable def add_displacement3d_displacement3d (v3 v2 : displacement3d s) : displacement3d s :=
    mk_displacement3d' s (v3.to_vectr + v2.to_vectr)
@[simp]
noncomputable def smul_displacement3d (k : real_scalar) (v : displacement3d s) : displacement3d s :=
    mk_displacement3d' s (k • v.to_vectr)
@[simp]
noncomputable def neg_displacement3d (v : displacement3d s) : displacement3d s :=
    mk_displacement3d' s ((-1 : real_scalar) • v.to_vectr)
@[simp]
noncomputable def sub_displacement3d_displacement3d (v3 v2 : displacement3d s) : displacement3d s :=    -- v3-v2
    add_displacement3d_displacement3d v3 (neg_displacement3d v2)

noncomputable instance has_add_displacement3d : has_add (displacement3d s) := ⟨ add_displacement3d_displacement3d ⟩
lemma add_assoc_displacement3d : ∀ a b c : displacement3d s, a + b + c = a + (b + c) := begin
    intros,
    ext,
    dsimp only [has_add.add],
    dsimp only [add_displacement3d_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, has_add.add],
    dsimp only [add_vec_vec, mk_displacement3d', mk_vectr'],
    simp only [add_assoc],
end
noncomputable instance add_semigroup_displacement3d : add_semigroup (displacement3d s) := ⟨ add_displacement3d_displacement3d, add_assoc_displacement3d⟩
@[simp]
noncomputable def displacement3d_zero  := mk_displacement3d s 0 0 0
noncomputable instance : inhabited (displacement3d s) := ⟨displacement3d_zero⟩
noncomputable instance has_zero_displacement3d : has_zero (displacement3d s) := ⟨displacement3d_zero⟩

lemma zero_add_displacement3d : ∀ a : displacement3d s, 0 + a = a :=
begin
    intros,
    ext,
    dsimp only [has_zero.zero, has_add.add],
    dsimp only [add_displacement3d_displacement3d, displacement3d_zero, mk_displacement3d', mk_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, mk_vectr', mk_vectr, mk_vec_n, has_add.add],
    dsimp only [add_vec_vec, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, zero_add],
    simp only [add_left_eq_self, list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, zero_add],
    simp only [add_left_eq_self, list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, zero_add],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end

lemma add_zero_displacement3d : ∀ a : displacement3d s, a + 0 = a :=
begin
    intros,
    ext,
    dsimp only [has_zero.zero, has_add.add],
    dsimp only [add_displacement3d_displacement3d, displacement3d_zero, mk_displacement3d', mk_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, mk_vectr', mk_vectr, mk_vec_n, has_add.add],
    dsimp only [add_vec_vec, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, add_zero],
    simp only [add_left_eq_self, list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, add_zero],
    simp only [add_left_eq_self, list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, add_zero],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end

@[simp]
noncomputable def nsmul_displacement3d : ℕ → (displacement3d s) → (displacement3d s)
| nat.zero v := displacement3d_zero
--| 3 v := v
| (nat.succ n) v := (add_displacement3d_displacement3d) v (nsmul_displacement3d n v)

noncomputable instance add_monoid_displacement3d : add_monoid (displacement3d s) := ⟨
    -- add_semigroup
    add_displacement3d_displacement3d,
    add_assoc_displacement3d,
    -- has_zero
    displacement3d_zero,
    -- new structure
    @zero_add_displacement3d f s,
    add_zero_displacement3d,
    nsmul_displacement3d,
    begin
        admit
    end,
    begin
        admit
    end
⟩

noncomputable instance has_neg_displacement3d : has_neg (displacement3d s) := ⟨neg_displacement3d⟩
noncomputable instance has_sub_displacement3d : has_sub (displacement3d s) := ⟨ sub_displacement3d_displacement3d⟩
lemma sub_eq_add_neg_displacement3d : ∀ a b : displacement3d s, a - b = a + -b :=
begin
    intros,ext,
    refl,
end

noncomputable instance sub_neg_monoid_displacement3d : sub_neg_monoid (displacement3d s) :=
{
    neg := neg_displacement3d ,
    ..(show add_monoid (displacement3d s), by apply_instance)
}

lemma add_left_neg_displacement3d : ∀ a : displacement3d s, -a + a = 0 :=
begin
    intros,
    ext,
    dsimp only [has_zero.zero, has_add.add, has_neg.neg],
    dsimp only [neg_displacement3d, has_scalar.smul],
    dsimp only [add_displacement3d_displacement3d, smul_vectr, has_add.add, has_scalar.smul],
    dsimp only [add_vectr_vectr, smul_vec, mk_displacement3d', mk_vectr', has_add.add],
    dsimp only [add_vec_vec],
    simp only [neg_mul_eq_neg_mul_symm, one_mul, mk_vectr, displacement3d_zero, mk_displacement3d, add_left_neg],
    dsimp only [mk_vec_n, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le],
    simp only [add_left_eq_self, list.nth_le],
    cases x' with x'',
    simp only [list.nth_le],
    simp only [add_left_eq_self, list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end

noncomputable instance : add_group (displacement3d s) := {
    add_left_neg := begin
        exact add_left_neg_displacement3d,
    end,
..(show sub_neg_monoid (displacement3d s), by apply_instance),

}

lemma add_comm_displacement3d : ∀ a b : displacement3d s, a + b = b + a :=
begin
    intros,
    ext,
    dsimp only [has_add.add],
    dsimp only [add_displacement3d_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, has_add.add],
    dsimp only [add_vec_vec, mk_displacement3d', mk_vectr'],
    simp only [add_comm],
end
noncomputable instance add_comm_semigroup_displacement3d : add_comm_semigroup (displacement3d s) := ⟨
    -- add_semigroup
    add_displacement3d_displacement3d,
    add_assoc_displacement3d,
    add_comm_displacement3d,
⟩

noncomputable instance add_comm_monoid_displacement3d : add_comm_monoid (displacement3d s) := {
    add_comm := begin
        exact add_comm_displacement3d
    end,
    ..(show add_monoid (displacement3d s), by apply_instance)
}

noncomputable instance has_scalar_displacement3d : has_scalar real_scalar (displacement3d s) := ⟨
smul_displacement3d,
⟩

lemma one_smul_displacement3d : ∀ b : displacement3d s, (1 : real_scalar) • b = b := begin
    intros,
    ext,
    dsimp only [has_scalar.smul],
    dsimp only [smul_displacement3d, has_scalar.smul],
    dsimp only [smul_vectr, has_scalar.smul],
    dsimp only [smul_vec, mk_displacement3d', mk_vectr'],
    simp only [one_mul],
end
lemma mul_smul_displacement3d : ∀ (x y : real_scalar) (b : displacement3d s), (x * y) • b = x • y • b :=
begin
    intros,
    cases b,
    ext,
    exact mul_assoc x y _,
end

noncomputable instance mul_action_displacement3d : mul_action real_scalar (displacement3d s) := ⟨
one_smul_displacement3d,
mul_smul_displacement3d,
⟩

lemma smul_add_displacement3d : ∀(r : real_scalar) (x y : displacement3d s), r • (x + y) = r • x + r • y := begin
    intros,
    ext,
    dsimp only [has_scalar.smul, has_add.add],
    dsimp only [smul_displacement3d, add_displacement3d_displacement3d, has_scalar.smul, has_add.add],
    dsimp only [smul_vectr, add_vectr_vectr, has_scalar.smul, has_add.add],
    dsimp only [smul_vec, add_vec_vec, mk_displacement3d', mk_vectr'],
    simp only [distrib.left_distrib],
    refl,
end
lemma smul_zero_displacement3d : ∀(r : real_scalar), r • (0 : displacement3d s) = 0 := begin
    intros,
    ext,
    dsimp only [has_scalar.smul, has_zero.zero],
    dsimp only [smul_displacement3d, displacement3d_zero, has_scalar.smul],
    dsimp only [smul_vectr, has_scalar.smul],
    dsimp only [smul_vec, mk_displacement3d', mk_vectr', mk_displacement3d, mk_vectr, mk_vec_n, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, mul_zero],
    simp only [list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, mul_zero],
    simp only [list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, mul_zero],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end
noncomputable instance distrib_mul_action_K_displacement3d : distrib_mul_action real_scalar (displacement3d s) := ⟨
smul_add_displacement3d,
smul_zero_displacement3d,
⟩

-- renaming vs template due to clash with name "s" for prevailing variable
lemma add_smul_displacement3d : ∀ (a b : real_scalar) (x : displacement3d s), (a + b) • x = a • x + b • x :=
begin
  intros,
  ext,
  exact right_distrib _ _ _,
end
lemma zero_smul_displacement3d : ∀ (x : displacement3d s), (0 : real_scalar) • x = 0 := begin
    intros,
    ext,
    dsimp only [has_scalar.smul, has_zero.zero],
    dsimp only [smul_displacement3d, displacement3d_zero, has_scalar.smul],
    dsimp only [smul_vectr, has_scalar.smul],
    dsimp only [smul_vec, mk_displacement3d', mk_vectr', mk_displacement3d, mk_vectr, mk_vec_n, mk_vec, vector.nth],
    cases x_1,
    dsimp only [fin.mk],
    cases x_1_val with x',
    simp only [list.nth_le, mul_eq_zero],
    apply or.inl,
    refl,
    simp only [list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, mul_eq_zero],
    apply or.inl,
    refl,
    simp only [list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, mul_eq_zero],
    apply or.inl,
    refl,
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_1_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_1_property,
        dsimp only [has_le.le],
        exact x_1_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end
noncomputable instance module_K_displacement3d : module real_scalar (displacement3d s) := ⟨ add_smul_displacement3d, zero_smul_displacement3d ⟩

noncomputable instance add_comm_group_displacement3d : add_comm_group (displacement3d s) := {
    add_comm := begin
        exact add_comm_displacement3d
    end,
..(show add_group (displacement3d s), by apply_instance)
}
noncomputable instance : module real_scalar (displacement3d s) := @geom3d.module_K_displacement3d f s

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

/-
Affine operations
-/
noncomputable instance : has_add (displacement3d s) := ⟨add_displacement3d_displacement3d⟩
noncomputable instance : has_zero (displacement3d s) := ⟨displacement3d_zero⟩
noncomputable instance : has_neg (displacement3d s) := ⟨neg_displacement3d⟩

/-
Lemmas needed to implement affine space API
-/
@[simp]
noncomputable def sub_position3d_position3d {f : geom3d_frame} {s : geom3d_space f } (p3 p2 : position3d s) : displacement3d s :=
    mk_displacement3d' s (p3.to_point -ᵥ p2.to_point)
@[simp]
noncomputable def add_position3d_displacement3d {f : geom3d_frame} {s : geom3d_space f } (p : position3d s) (v : displacement3d s) : position3d s :=
    mk_position3d' s (v.to_vectr +ᵥ p.to_point) -- reorder assumes order is irrelevant
@[simp]
noncomputable def add_displacement3d_position3d {f : geom3d_frame} {s : geom3d_space f } (v : displacement3d s) (p : position3d s) : position3d s :=
    mk_position3d' s (v.to_vectr +ᵥ p.to_point)
--@[simp]
--def aff_displacement3d_group_action : displacement3d s → position3d s → position3d s := add_displacement3d_position3d real_scalar
noncomputable instance : has_vadd (displacement3d s) (position3d s) := ⟨add_displacement3d_position3d⟩

lemma zero_displacement3d_vadd'_a3 : ∀ p : position3d s, (0 : displacement3d s) +ᵥ p = p := begin
    intros,
    ext,
    dsimp only [has_vadd.vadd, has_zero.zero],
    dsimp only [add_displacement3d_position3d, displacement3d_zero, has_vadd.vadd],
    dsimp only [add_vectr_point, has_vadd.vadd],
    dsimp only [aff_vec_group_action, add_vec_pt, mk_position3d', mk_point', mk_displacement3d, mk_vectr, mk_vec_n, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, add_zero],
    simp only [list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, add_zero],
    simp only [list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, add_zero],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end
lemma displacement3d_add_assoc'_a3 : ∀ (g3 g2 : displacement3d s) (p : position3d s), g3 +ᵥ (g2 +ᵥ p) = (g3 + g2) +ᵥ p := begin
    intros,
    ext,
    dsimp only [has_add.add, has_vadd.vadd],
    dsimp only [add_displacement3d_position3d, add_displacement3d_displacement3d, has_add.add, has_vadd.vadd],
    dsimp only [add_vectr_point, add_vectr_vectr, has_add.add, has_vadd.vadd],
    dsimp only [aff_vec_group_action, add_vec_vec, add_vec_pt, mk_position3d', mk_point', mk_displacement3d', mk_vectr'],
    simp only [add_assoc, add_right_inj],
    simp only [add_comm],
end

noncomputable instance displacement3d_add_action: add_action (displacement3d s) (position3d s) :=
⟨ zero_displacement3d_vadd'_a3,
begin
    let h0 := displacement3d_add_assoc'_a3,
    intros,
    exact (h0 g₁ g₂ p).symm
end⟩
--@[simp]

noncomputable instance position3d_has_vsub : has_vsub (displacement3d s) (position3d s) := ⟨ sub_position3d_position3d⟩

instance : nonempty (position3d s) := ⟨mk_position3d s 0 0 0⟩
noncomputable instance : inhabited (position3d s) := ⟨mk_position3d s 0 0 0⟩

lemma position3d_vsub_vadd_a3 : ∀ (p3 p2 : (position3d s)), (p3 -ᵥ p2) +ᵥ p2 = p3 := begin
    intros,
    ext,
    dsimp only [has_vsub.vsub, has_vadd.vadd],
    dsimp only [add_displacement3d_position3d, sub_position3d_position3d, has_vsub.vsub, has_vadd.vadd],
    dsimp only [add_vectr_point, aff_point_group_sub, sub_point_point, has_vsub.vsub, has_vadd.vadd],
    dsimp only [aff_vec_group_action, aff_point_group_sub, add_vec_pt, aff_pt_group_sub, sub_pt_pt, mk_position3d', mk_point', mk_displacement3d', mk_vectr'],
    simp only [add_sub_cancel'_right],
end
lemma position3d_vadd_vsub_a3 : ∀ (g : displacement3d s) (p : position3d s), g +ᵥ p -ᵥ p = g :=
begin
    intros, ext,
    repeat {
    have h0 : ((g +ᵥ p -ᵥ p) : displacement3d s).to_vectr = (g.to_vectr +ᵥ p.to_point -ᵥ p.to_point) := rfl,
    rw h0,
    simp *,
    }

end

noncomputable instance aff_geom3d_torsor : add_torsor (displacement3d s) (position3d s) :=
⟨
    begin
        exact position3d_vsub_vadd_a3,
    end,
    begin
        exact position3d_vadd_vsub_a3,
    end,
⟩

open_locale affine

noncomputable instance : affine_space (displacement3d s) (position3d s) := @geom3d.aff_geom3d_torsor f s

end geom3d -- ha ha

end fix_this_name_too

/-
Transformations in 3d geometric space
-/

/-
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_transform {f3 : geom3d_frame} {f2 : geom3d_frame} (sp3 : geom3d_space f3) (sp2 : geom3d_space f2)
  extends fm_tr sp3 sp2

noncomputable def geom3d_space.mk_geom3d_transform_to {f3 : geom3d_frame} (s3 : geom3d_space f3) : Π {f2 : geom3d_frame} (s2 : geom3d_space f2),
        geom3d_transform s3 s2 := --(position3d s2) ≃ᵃ[scalar] (position3d s3) :=
    λ f2 s2,
        ⟨s3.fm_tr s2⟩

noncomputable instance g3tr_inh {f3 : geom3d_frame} {f2 : geom3d_frame} (sp3 : geom3d_space f3) (sp2 : geom3d_space f2)
    : inhabited (geom3d_transform  sp3 sp2) := ⟨sp3.mk_geom3d_transform_to sp2⟩

noncomputable def geom3d_transform.symm
    {f3 : geom3d_frame} {f2 : geom3d_frame} {sp3 : geom3d_space f3} {sp2 : geom3d_space f2} (ttr : geom3d_transform sp3 sp2)
    : geom3d_transform sp2 sp3 := ⟨(ttr.1).symm⟩

noncomputable def geom3d_transform.trans
    {f1 : geom3d_frame} {f2 : geom3d_frame} {f3 : geom3d_frame} {sp1 : geom3d_space f1} {sp2 : geom3d_space f2} {sp3 : geom3d_space f3}
    (ttr : geom3d_transform sp1 sp2)
    : geom3d_transform sp2 sp3 → geom3d_transform sp1 sp3 := λttr_, ⟨(ttr.1).trans ttr_.1⟩

noncomputable def geom3d_transform.transform_position3d
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : position3d s3 → position3d s2 :=
    λt : position3d s3,
    ⟨tr.to_fm_tr.to_equiv t.to_point⟩

noncomputable def geom3d_transform.transform_displacement3d
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : displacement3d s3 → displacement3d s2 :=
    λd,
    let as_pt : point s3 := ⟨λi, mk_pt real_scalar (d.coords i).coord⟩ in
    let tr_pt := (tr.to_equiv as_pt) in
    ⟨⟨λi, mk_vec real_scalar (tr_pt.coords i).coord⟩⟩

/-
Orientation in 3D
-/

variables {f : geom3d_frame} (s : geom3d_space f )

/-
Background for the following definition:

In an orientation object, id_vec keeps track of the
physical dimension to which each basis vector belongs,
allowing us to represent things like the product of a
geometric space and a time space.

orientation : Π {dim : ℕ} {id_vec : fin dim → ℕ} {f : fm K dim id_vec}, spc K f → Type
-/

structure orientation3d extends orientation s :=
mk ::

noncomputable instance o3i : inhabited (orientation3d s) := ⟨
    ⟨mk_orientation s (λi, mk_vectr s ⟨[0,0,0],rfl⟩)⟩
⟩

noncomputable def mk_orientation3d' /-(s1 s2 s3 s4 s5 s6 s7 s8 s9 : real_scalar)-/
    (ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    --: orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then (mk_displacement3d s s1 s2 s3).to_vectr else
    --                                            if i.1 = 1 then (mk_displacement3d s s4 s5 s6).to_vectr
    --                                            else (mk_displacement3d s s7 s8 s9).to_vectr )⟩

    : orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩

noncomputable def mk_orientation3d (s1 s2 s3 s4 s5 s6 s7 s8 s9 : real_scalar)
    : orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then (mk_displacement3d s s1 s2 s3).to_vectr else
                                                if i.1 = 1 then (mk_displacement3d s s4 s5 s6).to_vectr
                                                else (mk_displacement3d s s7 s8 s9).to_vectr )⟩

/-
R = Ry(1)*Rx(2)*Rz(3)
  = | cos 1*cos 3+sin 1*sin 2*sin 3  cos 3*sin 1*sin 2-sin 3*cos 1  cos 2*sin 1 |
    |                   cos 2*sin 3                    cos 3*cos 2       -sin 2 |
    | sin 3*cos 1*sin 2-sin 1*cos 3  sin 1*sin 3+cos 3*cos 1*sin 2  cos 2*cos 1 |
-/
--okay, i can fill in this function now...
noncomputable def mk_orientation3d_from_euler_angles (s1 s2 s3 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : orientation3d s := ⟨mk_orientation s
        (λi, if i.1 = 0 then (mk_displacement3d s
            ((real.cos s1)*(real.cos s3) + (real.sin s1*(real.sin s2)*(real.sin s3))) ((real.cos s3)*(real.sin s1)*(real.sin s2) - (real.sin s3)*(real.cos s1)) ((real.cos s2)*(real.sin s1))).to_vectr
        else if i.1 = 1 then (mk_displacement3d s
            ((real.cos s2)*(real.sin s3)) ((real.cos s3)*(real.cos s2)) (-(real.sin s2))).to_vectr
        else (mk_displacement3d s
            ((real.sin s3)*(real.cos s1)*(real.sin s2) - (real.sin s1)*(real.cos s3)) ((real.sin s1)*(real.sin s3) + (real.cos s3)*(real.cos s1)*(real.sin s2)) ((real.cos s2)*(real.cos s1))).to_vectr )⟩

noncomputable def mk_orientation3d_from_quaternion (s1 s2 s3 s4 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : orientation3d s := mk_orientation3d s
        (2*(s1*s1 + s2*s2) - 1) (2*(s2*s3 - s1*s4)) (2*(s2*s4 + s1*s3))
        (2*(s2*s3 + s1*s4)) (2*(s1*s1 + s3*s3)) (2*(s3*s4 - s1*s2))
        (2*(s2*s4 - s1*s3)) (2*(s3*s4 + s1*s2)) (2*(s1*s1 + s1*s1 + s4*s4) - 1)
    --: orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩

noncomputable def geom3d_transform.transform_orientation
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : orientation3d s3 → orientation3d s2 :=
    λo : orientation3d s3,
    ⟨mk_orientation s2
        (λi, if i.1 = 0 then (tr.to_fm_tr.transform_vectr (o.to_orientation.to_vectr_basis.basis_vectrs ⟨0,by linarith⟩))
        else if i.1 = 1 then (tr.to_fm_tr.transform_vectr (o.to_orientation.to_vectr_basis.basis_vectrs ⟨1,by linarith⟩))
        else (tr.to_fm_tr.transform_vectr (o.to_orientation.to_vectr_basis.basis_vectrs ⟨2,by linarith⟩)) )⟩

   -- ⟨tr.to_fm_tr.transform_orientation o.to_orientation⟩⟩

/-
Rotations
-/

structure rotation3d extends rotation s :=
mk ::

/-
noncomputable def mk_rotation3d (ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : rotation3d s := ⟨mk_rotation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩
-/
noncomputable def mk_rotation3d (s1 s2 s3 s4 s5 s6 s7 s8 s9 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : rotation3d s := ⟨mk_rotation s (λi, if i.1 = 0 then (mk_displacement3d s s1 s2 s3).to_vectr else if i.1 = 1 then (mk_displacement3d s s4 s5 s6).to_vectr else (mk_displacement3d s s7 s8 s9).to_vectr )⟩

noncomputable instance r3i : inhabited (rotation3d s) := ⟨
    mk_rotation3d s 1 1 1 1 1 1 1 1 1
⟩

noncomputable def mk_rotation3d_from_quaternion (s1 s2 s3 s4 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : rotation3d s := mk_rotation3d s
        (2*(s1*s1 + s2*s2) - 1) (2*(s2*s3 - s1*s4)) (2*(s2*s4 + s1*s3))
        (2*(s2*s3 + s1*s4)) (2*(s1*s1 + s3*s3)) (2*(s3*s4 - s1*s2))
        (2*(s2*s4 - s1*s3)) (2*(s3*s4 + s1*s2)) (2*(s1*s1 + s1*s1 + s4*s4) - 1)
    --: orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩

/-
Poses
-/

structure pose3d :=
mk ::
    (orientation : orientation3d s)
    (position : position3d s)

def mk_pose3d (orientation : orientation3d s)
    (position : position3d s) : pose3d s := ⟨orientation,position⟩

 noncomputable instance p3i : inhabited (pose3d s) := ⟨
    (
    mk_pose3d _
    (mk_orientation3d _ 0 0 0 0 0 0 0 0 0)
    (mk_position3d _ 0 0 0)
    )
⟩

noncomputable def geom3d_transform.transform_pose3d
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : pose3d s3 → pose3d s2 :=
    λp :_,
    (⟨tr.transform_orientation p.orientation, tr.transform_position3d p.position⟩:pose3d s2)

notation tr⬝t := geom3d_transform.transform_pose3d tr t

noncomputable def geom3d_transform.translation
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : geom3d_transform s3 s2 → displacement3d s2 :=
    inhabited.default _ /- how to fill this in -/

noncomputable def geom3d_transform.rotation
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : geom3d_transform s3 s2 → orientation3d s2 :=
    inhabited.default _ /- how to fill this in -/


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin, Bhavik Mehta
-/
import category_theory.isomorphism
import category_theory.functor_category
import category_theory.eq_to_hom

/-!
# Comma categories

A comma category is a construction in category theory, which builds a category out of two functors
with a common codomain. Specifically, for functors `L : A ⥤ T` and `R : B ⥤ T`, an object in
`comma L R` is a morphism `hom : L.obj left ⟶ R.obj right` for some objects `left : A` and
`right : B`, and a morphism in `comma L R` between `hom : L.obj left ⟶ R.obj right` and
`hom' : L.obj left' ⟶ R.obj right'` is a commutative square

```
L.obj left   ⟶   L.obj left'
      |               |
  hom |               | hom'
      ↓               ↓
R.obj right  ⟶   R.obj right',
```

where the top and bottom morphism come from morphisms `left ⟶ left'` and `right ⟶ right'`,
respectively.

## Main definitions

* `comma L R`: the comma category of the functors `L` and `R`.
* `over X`: the over category of the object `X` (developed in `over.lean`).
* `under X`: the under category of the object `X` (also developed in `over.lean`).
* `arrow T`: the arrow category of the category `T` (developed in `arrow.lean`).

## References

* <https://ncatlab.org/nlab/show/comma+category>

## Tags

comma, slice, coslice, over, under, arrow
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ v₅ u₁ u₂ u₃ u₄ u₅
variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]
variables {T : Type u₃} [category.{v₃} T]

/-- The objects of the comma category are triples of an object `left : A`, an object
   `right : B` and a morphism `hom : L.obj left ⟶ R.obj right`.  -/
structure comma (L : A ⥤ T) (R : B ⥤ T) : Type (max u₁ u₂ v₃) :=
(left : A . obviously)
(right : B . obviously)
(hom : L.obj left ⟶ R.obj right)

-- Satisfying the inhabited linter
instance comma.inhabited [inhabited T] : inhabited (comma (𝟭 T) (𝟭 T)) :=
{ default :=
  { left := default T,
    right := default T,
    hom := 𝟙 (default T) } }

variables {L : A ⥤ T} {R : B ⥤ T}

/-- A morphism between two objects in the comma category is a commutative square connecting the
    morphisms coming from the two objects using morphisms in the image of the functors `L` and `R`.
-/
@[ext] structure comma_morphism (X Y : comma L R) :=
(left : X.left ⟶ Y.left . obviously)
(right : X.right ⟶ Y.right . obviously)
(w' : L.map left ≫ Y.hom = X.hom ≫ R.map right . obviously)

-- Satisfying the inhabited linter
instance comma_morphism.inhabited [inhabited (comma L R)] :
  inhabited (comma_morphism (default (comma L R)) (default (comma L R))) :=
{ default :=
  { left := 𝟙 _,
    right := 𝟙 _ } }

restate_axiom comma_morphism.w'
attribute [simp, reassoc] comma_morphism.w

instance comma_category : category (comma L R) :=
{ hom := comma_morphism,
  id := λ X,
  { left := 𝟙 X.left,
    right := 𝟙 X.right },
  comp := λ X Y Z f g,
  { left := f.left ≫ g.left,
    right := f.right ≫ g.right } }

namespace comma

section
variables {X Y Z : comma L R} {f : X ⟶ Y} {g : Y ⟶ Z}

@[simp] lemma id_left  : ((𝟙 X) : comma_morphism X X).left = 𝟙 X.left := rfl
@[simp] lemma id_right : ((𝟙 X) : comma_morphism X X).right = 𝟙 X.right := rfl
@[simp] lemma comp_left  : (f ≫ g).left  = f.left ≫ g.left   := rfl
@[simp] lemma comp_right : (f ≫ g).right = f.right ≫ g.right := rfl

end

variables (L) (R)

/-- The functor sending an object `X` in the comma category to `X.left`. -/
@[simps]
def fst : comma L R ⥤ A :=
{ obj := λ X, X.left,
  map := λ _ _ f, f.left }

/-- The functor sending an object `X` in the comma category to `X.right`. -/
@[simps]
def snd : comma L R ⥤ B :=
{ obj := λ X, X.right,
  map := λ _ _ f, f.right }

/-- We can interpret the commutative square constituting a morphism in the comma category as a
    natural transformation between the functors `fst ⋙ L` and `snd ⋙ R` from the comma category
    to `T`, where the components are given by the morphism that constitutes an object of the comma
    category. -/
@[simps]
def nat_trans : fst L R ⋙ L ⟶ snd L R ⋙ R :=
{ app := λ X, X.hom }

@[simp] lemma eq_to_hom_left (X Y : comma L R) (H : X = Y) :
  comma_morphism.left (eq_to_hom H) = eq_to_hom (by { cases H, refl }) := by { cases H, refl }

@[simp] lemma eq_to_hom_right (X Y : comma L R) (H : X = Y) :
  comma_morphism.right (eq_to_hom H) = eq_to_hom (by { cases H, refl }) := by { cases H, refl }

section
variables {L₁ L₂ L₃ : A ⥤ T} {R₁ R₂ R₃ : B ⥤ T}

/--
Construct an isomorphism in the comma category given isomorphisms of the objects whose forward
directions give a commutative square.
-/
@[simps]
def iso_mk {X Y : comma L₁ R₁} (l : X.left ≅ Y.left) (r : X.right ≅ Y.right)
  (h : L₁.map l.hom ≫ Y.hom = X.hom ≫ R₁.map r.hom) : X ≅ Y :=
{ hom := { left := l.hom, right := r.hom },
  inv :=
  { left := l.inv,
    right := r.inv,
    w' := begin
      rw [←L₁.map_iso_inv l, iso.inv_comp_eq, L₁.map_iso_hom, reassoc_of h, ← R₁.map_comp],
      simp
    end, } }

/-- A natural transformation `L₁ ⟶ L₂` induces a functor `comma L₂ R ⥤ comma L₁ R`. -/
@[simps]
def map_left (l : L₁ ⟶ L₂) : comma L₂ R ⥤ comma L₁ R :=
{ obj := λ X,
  { left  := X.left,
    right := X.right,
    hom   := l.app X.left ≫ X.hom },
  map := λ X Y f,
  { left  := f.left,
    right := f.right } }

/-- The functor `comma L R ⥤ comma L R` induced by the identity natural transformation on `L` is
    naturally isomorphic to the identity functor. -/
@[simps]
def map_left_id : map_left R (𝟙 L) ≅ 𝟭 _ :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- The functor `comma L₁ R ⥤ comma L₃ R` induced by the composition of two natural transformations
    `l : L₁ ⟶ L₂` and `l' : L₂ ⟶ L₃` is naturally isomorphic to the composition of the two functors
    induced by these natural transformations. -/
@[simps]
def map_left_comp (l : L₁ ⟶ L₂) (l' : L₂ ⟶ L₃) :
  (map_left R (l ≫ l')) ≅ (map_left R l') ⋙ (map_left R l) :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- A natural transformation `R₁ ⟶ R₂` induces a functor `comma L R₁ ⥤ comma L R₂`. -/
@[simps]
def map_right (r : R₁ ⟶ R₂) : comma L R₁ ⥤ comma L R₂ :=
{ obj := λ X,
  { left  := X.left,
    right := X.right,
    hom   := X.hom ≫ r.app X.right },
  map := λ X Y f,
  { left  := f.left,
    right := f.right } }

/-- The functor `comma L R ⥤ comma L R` induced by the identity natural transformation on `R` is
    naturally isomorphic to the identity functor. -/
@[simps]
def map_right_id : map_right L (𝟙 R) ≅ 𝟭 _ :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- The functor `comma L R₁ ⥤ comma L R₃` induced by the composition of the natural transformations
    `r : R₁ ⟶ R₂` and `r' : R₂ ⟶ R₃` is naturally isomorphic to the composition of the functors
    induced by these natural transformations. -/
@[simps]
def map_right_comp (r : R₁ ⟶ R₂) (r' : R₂ ⟶ R₃) :
  (map_right L (r ≫ r')) ≅ (map_right L r) ⋙ (map_right L r') :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

end

section
variables {C : Type u₄} [category.{v₄} C] {D : Type u₅} [category.{v₅} D]

/-- The functor `(F ⋙ L, R) ⥤ (L, R)` -/
@[simps] def pre_left (F: C ⥤ A) (L : A ⥤ T) (R : B ⥤ T) : comma (F ⋙ L) R ⥤ comma L R :=
{ obj := λ X, { left := F.obj X.left, right := X.right, hom := X.hom },
  map := λ X Y f, { left := F.map f.left, right := f.right, w' := by simpa using f.w } }

/-- The functor `(F ⋙ L, R) ⥤ (L, R)` -/
@[simps] def pre_right (L : A ⥤ T) (F: C ⥤ B) (R : B ⥤ T) : comma L (F ⋙ R) ⥤ comma L R :=
{ obj := λ X, { left := X.left, right := F.obj X.right, hom := X.hom },
  map := λ X Y f, { left := f.left, right := F.map f.right, w' := by simp } }

/-- The functor `(L, R) ⥤ (L ⋙ F, R ⋙ F)` -/
@[simps] def post (L : A ⥤ T) (R : B ⥤ T) (F: T ⥤ C) : comma L R ⥤ comma (L ⋙ F) (R ⋙ F) :=
{ obj := λ X, { left := X.left, right := X.right, hom := F.map X.hom },
  map := λ X Y f, { left := f.left, right := f.right, w' :=
    by { simp only [functor.comp_map, ←F.map_comp, f.w] } } }

end
end comma

end category_theory


import function.misc
import function.bijection
import data.list.misc
import data.list.map_partial
import data.finord
import data.subtype.misc
import tactic.unirewrite
import .basic

namespace exhaustive_list

--- Forget proofs to exhibit an `exhaustive_list` on a subtype of `α` as a list of `α`.
@[reducible,inline]
protected
definition underlying {α : Type _} {p : α → Prop} (l : exhaustive_list (subtype p)) : list α :=
  l.val.map subtype.val

--- Two `exhaustive_list`s on a subtype equal to each other precisely if their underlying `list`s do.
protected
lemma eq_of_underlying {α : Type _} {p : α → Prop} {l₁ l₂ : exhaustive_list (subtype p)} : l₁.underlying = l₂.underlying → l₁ = l₂ :=
  λ h, subtype.eq (list.inj_of_map_inj subtype.val_injective h)

protected
lemma underlying_nodup {α : Type _} {p : α → Prop} (l : exhaustive_list (subtype p)) : l.underlying.nodup :=
  begin
    dunfold exhaustive_list.underlying,
    apply list.nodup_map_of_nodup subtype.val_injective,
    exact l.property.left
  end

protected
lemma underlying_exhaustive {α : Type _} {p : α → Prop} (l : exhaustive_list (subtype p)) : ∀ x, p x → x ∈ l.underlying :=
  begin
    intros x hx,
    dunfold exhaustive_list.underlying,
    unirewrite x with (subtype.mk x hx).val,
    exact list.mem_map_of_mem _ _ (l.property.right _)
  end

protected
lemma underlying_mem_iff {α : Type _} {p : α → Prop} (l : exhaustive_list (subtype p)) : ∀ x, p x ↔ x ∈ l.underlying :=
  begin
    intros x,
    split,
    show p x → _,
      from l.underlying_exhaustive x,
    show _ → p x, {
      intros hx,
      dunfold exhaustive_list.underlying at hx,
      cases l.val.inverse_of_mem_map hx with w hw,
      rw [hw.left]; exact w.property
    }
  end

--- For every pair of `exhaustive_list`s of a subtype, they are the same underlying list up to permutations.
protected
lemma underlying_perm {α : Type _} {p : α → Prop} (l₁ l₂ : exhaustive_list (subtype p)) : list.perm l₁.underlying l₂.underlying :=
  list.perm.map subtype.val (l₁.perm l₂)

--- The empty list is exhaustive on empty subtypes.
@[reducible]
protected
definition of_empty {α : Type _} {p : α → Prop} (h : ∀ a, ¬p a) : exhaustive_list (subtype p) :=
  subtype.mk [] $
    begin
      split; try { exact list.nodup.nil },
      intros x,
      exact false.elim (h x x.property)
    end

--- Every `exhaustive_list` on an empty subtype is `nil`.
protected
lemma is_empty {α : Type _} {p : α → Prop} (h : ∀ a, ¬p a) (l : exhaustive_list (subtype p)) : l.val = [] :=
  begin
    apply list.is_nil_of_no_mem,
    intros x,
    exfalso,
    exact h x.val x.property
  end

--- The underlying `list` of `exhaustive_list` of empty subtype is `nil`.
protected
lemma of_empty_underlying {α : Type _} {p : α → Prop} (h : ∀ a, ¬p a) (l : exhaustive_list (subtype p)) : l.underlying = [] :=
  begin
    dunfold exhaustive_list.underlying,
    rw [l.is_empty h],
    refl
  end

--- `exhaustive_list` of singleton subset.
protected
definition singleton {α : Type _} [decidable_eq α] (a : α) : exhaustive_list {x // x=a} :=
  subtype.mk [⟨a,rfl⟩] $
    begin
      split,
      exact list.nodup.cons (list.not_mem_nil _) list.nodup.nil,
      show ∀ x, _, {
        intros x,
        have : x = ⟨a,rfl⟩ := subtype.eq x.property,
        rw [this],
        exact list.mem_cons_self _ _
      }
    end

--- The underlying `list` of `exhaustive_list` of singleton subtypes.
protected
lemma singleton_underlying {α : Type _} [decidable_eq α] {a : α} : (exhaustive_list.singleton a).underlying = [a] :=
  rfl

--- The uniqueness of `exhaustive_list` on singleton subtypes.
protected
lemma singleton_unique {α : Type _} [decidable_eq α] {a : α} : ∀ (l :exhaustive_list {x // x=a}), l = exhaustive_list.singleton a :=
  begin
    intros l,
    apply exhaustive_list.eq_of_underlying,
    have : list.perm l.underlying [a],
      from l.underlying_perm (exhaustive_list.singleton a),
    exact this.eq_singleton
  end

--- `exhaustive_list`s of two subtypes classified by eqiuvalent predicators can be translated to one another.
@[reducible]
protected
definition of_iff {α : Type _} {p q : α → Prop} (h : ∀ a, p a ↔ q a) (l : exhaustive_list (subtype p)) : exhaustive_list (subtype q) :=
  l.translate (bijection.subtype_equiv h).is_bijective

--- Equivalent condition translation of `exhaustive_list` does nothing on the underlying `list`.
@[simp]
protected
lemma of_iff_underlying {α : Type _} {p q : α → Prop} (h : ∀ a, p a  ↔ q a) (l : exhaustive_list (subtype p)) : (l.of_iff h).underlying = l.underlying:=
  begin
    dsimp [
      exhaustive_list.of_iff,
      exhaustive_list.translate,
      bijection.subtype_equiv,
      exhaustive_list.underlying
    ],
    rw [list.map_map_safe],
    exact list.map_equiv (by intros x; cases x; refl)
  end

--- If `α` has an `exhaustive_list`, then each decidable subtype of `α` does.
@[reducible]
protected
definition restrict {α : Type _} (l : exhaustive_list α) (p : α → Prop) [decidable_pred p] : exhaustive_list (subtype p) :=
  subtype.mk (l.val.filter_to_subtype p) $
    begin
      split,
      exact list.nodup_map_partial_of_nodup (function.partial.coinj_inj) l.property.left,
      intros x,
      have hx : (function.partial.coinj p).is_defined_at x.val,
        from (function.partial.coinj_domain x.val).mpr x.property,
      have : x = (function.partial.coinj p).to_fun ⟨x.val,hx⟩, {
        symmetry,
        suffices : function.partial.coinj p x.val = some x,
          from (function.partial.coinj p).to_fun_value_of_eq this,
        cases hinjx : function.partial.coinj p x.val with y,
        exfalso; exact hx hinjx,
        dunfold function.partial.coinj at hinjx,
        rw [dif_pos x.property] at hinjx,
        apply congr_arg some; apply subtype.eq,
        let hyxval := congr_arg subtype.val (option.some.inj hinjx.symm),
        exact hyxval,
      },
      rw [this],
      refine list.mem_map_partial_of_mem _ _ _,
      exact l.property.right _
    end

--- `exhaustive_list.restrict` is nothing but `filter` on the underlying `list`.
@[simp]
protected
lemma restrict_underlying {α : Type _} (l : exhaustive_list α) {p : α → Prop} [decidable_pred p] : (l.restrict p).underlying = l.val.filter p :=
  begin
    dunfold exhaustive_list.underlying,
    dsimp [exhaustive_list.restrict],
    rw [list.val_of_filter_to_subtype]
  end

--- Restrict an `exhaustive_list` on a subtype to a smaller subtype.
@[simp]
protected
definition subrestrict {α : Type _} {p : α → Prop} (l : exhaustive_list (subtype p)) (q : α → Prop) [decidable_pred q] : exhaustive_list {x // p x ∧ q x} :=
  let l' := (l.restrict (q ∘ subtype.val))
  in l'.translate bijection.subtype_uncurry.is_bijective

--- `exhaustive_list.subrestrict` is nothing but `filter` on the underlying `list`.
@[simp]
protected
lemma subrestrict_underlying {α : Type _} {p : α → Prop} (l : exhaustive_list (subtype p)) (q : α → Prop) [decidable_pred q] : (l.subrestrict q).underlying = l.underlying.filter q :=
  begin
    dsimp [exhaustive_list.subrestrict],
    dsimp [exhaustive_list.translate],
    dsimp [bijection.subtype_uncurry],
    dsimp [exhaustive_list.underlying],
    rw [list.map_map_safe],
    dunfold function.comp; dsimp *,
    have : ∀ (x : {x : subtype p // q x.val}), x.val.val = (subtype.val ∘ subtype.val) x,
      by intros; refl,
    rw [list.map_equiv this]; dsimp *,
    rw [←list.map_map_safe],
    rw [list.val_of_filter_to_subtype],
    rw [list.filter_of_map]
  end

--- Partitioning an `exhaustive_list α` with a decidable predicator `p : α → Prop`.
@[reducible]
protected
definition partition {α : Type _} (p : α → Prop) [decidable_pred p] (l : exhaustive_list α) : exhaustive_list (subtype p) × exhaustive_list {x // ¬p x} :=
  (l.restrict p, l.restrict (not ∘ p))

--- Underlying lists of partitioned `exhaustive_list`.
@[simp]
protected
lemma partition_underlying {α : Type _} {p : α → Prop} [decidable_pred p] {l : exhaustive_list α} : (l.partition p).map exhaustive_list.underlying exhaustive_list.underlying = l.val.partition p :=
  begin
    dunfold exhaustive_list.partition,
    dunfold prod.map,
    repeat { rw [exhaustive_list.restrict_underlying] },
    rw [list.partition_eq_filter_filter_safe]
  end

--- Partitioning an `exhaustive_list` on a subtype with a decidable predicator `p`.
@[reducible]
protected
definition subpartition {α : Type _} {p : α → Prop} (l : exhaustive_list (subtype p)) (q : α → Prop) [decidable_pred q] : exhaustive_list {x // p x ∧ q x} × exhaustive_list {x // p x ∧ ¬q x} :=
  (l.subrestrict q, l.subrestrict (not ∘ q))

--- Underlying lists of partitioned `exhaustive_list`.
@[simp]
protected
lemma subpartition_underlying {α : Type _} {p : α → Prop} {l : exhaustive_list (subtype p)} {q : α → Prop} [decidable_pred q]: (l.subpartition q).map exhaustive_list.underlying exhaustive_list.underlying = l.underlying.partition q :=
  begin
    dunfold exhaustive_list.subpartition,
    dunfold prod.map,
    repeat { rw [exhaustive_list.subrestrict_underlying] },
    rw [list.partition_eq_filter_filter_safe],
  end

--- If two subtypes respectively admit exhaustive lists, then so does their union.
@[reducible]
protected
definition union {α : Type _} [decidable_eq α] {p q : α → Prop} (lp : exhaustive_list (subtype p)) (lq : exhaustive_list (subtype q)) : exhaustive_list {x // p x ∨ q x} :=
  subtype.mk
    (list.union (lp.val.map subtype.inl) (lq.val.map subtype.inr)) $
    begin
      split,
      show list.nodup _, {
        apply list.nodup_union,
        exact list.nodup_map_of_nodup subtype.relax_inj lp.property.left,
        exact list.nodup_map_of_nodup subtype.relax_inj lq.property.left,
      },
      show ∀ x, x ∈ _, {
        intros x,
        apply list.mem_union_iff.mp,
        cases x.property with hx hx,
        case or.inl /- p x.val -/ {
          left,
          have : x = subtype.inl ⟨x.val,hx⟩,
            by cases x; refl,
          rw [this],
          apply list.mem_map_of_mem _ _,
          exact lp.property.right _
        },
        case or.inr /- q x.val -/ {
          right,
          have : x = subtype.inr ⟨x.val,hx⟩,
            by cases x; refl,
          rw [this],
          apply list.mem_map_of_mem _ _,
          exact lq.property.right _
        },
      },
    end

--- The underlying list of `union` of `exhaustive_list`s.
@[simp]
protected
lemma union_underlying {α : Type _} [decidable_eq α] {p q : α → Prop} {lp : exhaustive_list (subtype p)} {lq : exhaustive_list (subtype q)} : (lp.union lq).underlying = lp.underlying ∪ lq.underlying :=
  begin
    cases lp; cases lq,
    dsimp [exhaustive_list.union, exhaustive_list.underlying],
    drefold @has_union.union (list {x // p x ∨ q x}) _,
    rw [list.union_of_map_inj (@subtype.val_injective α _)],
    rw [list.map_map_safe, list.map_map_safe],
    rw [list.map_equiv subtype.val_inl],
    rw [list.map_equiv subtype.val_inr]
  end

--- The underlying list of `union` of `exhaustive_list`s for two disjoint subtypes.
@[simp]
protected
lemma disjoint_union_underlying {α : Type _} [decidable_eq α] {p q : α → Prop} {lp : exhaustive_list (subtype p)} {lq : exhaustive_list (subtype q)} : (∀ x, ¬(p x ∧ q x)) → (lp.union lq).underlying = lp.underlying ++ lq.underlying :=
  begin
    intros hnpq,
    rw [exhaustive_list.union_underlying],
    apply list.nodup.disjoint_union lp.underlying_nodup,
    intros x hlpx hlqx,
    have hpx : p x,
      from (lp.underlying_mem_iff x).mpr hlpx,
    have hqx : q x,
      from (lq.underlying_mem_iff x).mpr hlqx,
    exact hnpq x ⟨hpx,hqx⟩
  end

end exhaustive_list

namespace is_finite

--- Empty subtype is finite
definition of_empty {α : Type _} {p : α → Prop} (h : ∀ x, ¬p x) : is_finite {x // p x} :=
  begin
    constructor,
    existsi 0,
    existsi (λ x, false.elim $ finord.zero_empty x),
    split,
    show function.injective _, {
      intros x,
      exfalso; exact finord.zero_empty x,
    },
    show function.surjective _, {
      intros x,
      exfalso; exact h x.val x.property
    }
  end

--- Decidable subtypes of a finite type is finite.
instance of_subtype {α : Type _} [decidable_eq α] [is_finite α] {p : α → Prop} [decidable_pred p] : is_finite (subtype p) :=
  begin
    cases has_exhaustive_list α with l,
    exact is_finite.of_exhaustive_list (l.restrict p)
  end

--- If a subtype is finite, then every equivalent subtype is also finite.
protected
lemma of_iff {α : Type _} [decidable_eq α] {p q : α → Prop} (hpq : ∀ x, p x ↔ q x) : is_finite (subtype p) → is_finite (subtype q) :=
  begin
    intros hp; cases @has_exhaustive_list _ hp with lp,
    exact is_finite.of_exhaustive_list (lp.of_iff hpq),
  end

--- Decidable subtype of a finite subtype is a finite subtype.
lemma of_subrestrict {α : Type _} [decidable_eq α] {p : α → Prop} : is_finite (subtype p) → Π (q : α → Prop) [decidable_pred q], is_finite {x // p x ∧ q x} :=
  begin
    intros hp; cases @has_exhaustive_list _ hp with lp,
    intros q hdec,
    apply is_finite.of_exhaustive_list,
    exact @exhaustive_list.subrestrict _ _ lp q hdec
  end

--- The union of finite subtypes is finite
lemma of_union {α : Type _} [decidable_eq α] {p q : α → Prop} : is_finite (subtype p) → is_finite (subtype q) → is_finite {x // p x ∨ q x} :=
  begin
    intro hp; cases @has_exhaustive_list _ hp with lp,
    intro hq; cases @has_exhaustive_list _ hq with lq,
    exact is_finite.of_exhaustive_list (lp.union lq)
  end

--- Every finite subtype of a subtype is internally-decidable in the superset.
lemma idec_in_super {α : Type _} [decidable_eq α] {p : α → Prop} {q : subtype p → Prop} : is_finite (subtype q) → ∀ (a : α), idecidable (∃ (h : p a), q ⟨a,h⟩) :=
  begin
    intros hfin a,
    constructor,
    cases @is_finite.has_exhaustive_list _ hfin with l,
    refine dite (a ∈ l.underlying.map subtype.val) _ _,
    show a ∈ _ → _, {
      intros ha; left,
      let ha' := list.inverse_of_mem_map _ ha,
      cases hha: ha' with x hxa; clear hha,
      have hqx : q x,
        from (l.underlying_mem_iff x).mpr hxa.right,
      have hpa : p a,
        from hxa.left.symm ▸ x.property,
      have : x = ⟨a,hpa⟩,
        from subtype.eq hxa.left.symm,
      rw [this] at hqx,
      exact ⟨hpa,hqx⟩
    },
    show a ∉ _ → _, {
      intros ha; right,
      intros h; cases h with hpa hqa,
      let x : subtype p := ⟨a,hpa⟩,
      have : x ∈ l.underlying,
        from (l.underlying_mem_iff x).mp hqa,
      have: x.val ∈ list.map subtype.val l.underlying,
        from l.underlying.mem_map_of_mem x this,
      exact ha this
    }
  end

--- Every subtype of a subtype that is decidable in a finite supertype is finite.
lemma is_finite_of_superdec {α : Type _} [decidable_eq α] [is_finite α] {p : α → Prop} {q : subtype p → Prop} [∀ (a : α), decidable (∃ (h : p a), q ⟨a,h⟩)] : is_finite (subtype q) :=
  begin
    cases is_finite.has_exhaustive_list α with l,
    apply is_finite.of_exhaustive_list,
    let l' := l.restrict (λ a, ∃ (h : p a), q ⟨a,h⟩),
    have : ∀ a, (∃ h, q ⟨a,h⟩) ↔ (p a ∧ ∀ h, q ⟨a,h⟩), {
      intros a,
      split,
      show (∃ h, q ⟨a,h⟩) → _, {
        intros hh; cases hh with hpa hqa,
        refine and.intro hpa _,
        intro h,
        have : h = hpa, from rfl,
        rw [this],
        exact hqa
      },
      show (p a ∧ ∀ h, q ⟨a,h⟩) → _, {
        intros hpqa,
        exact ⟨hpqa.left, hpqa.right hpqa.left⟩
      }
    },
    let l'' := l'.of_iff this,
    let f : {a // p a ∧ ∀ h, q ⟨a,h⟩} → subtype q :=
      λ x, subtype.mk ⟨x.val, x.property.left⟩ $
        x.property.right x.property.left,
    have : function.bijective f, {
      split,
      show function.injective f, {
        intros x y,
        dsimp [f],
        intros hxy,
        let hxy' := congr_arg (subtype.val∘subtype.val) hxy,
        dsimp * at hxy',
        apply subtype.eq; exact hxy'
      },
      show function.surjective f, {
        intros z,
        let hqa := z.property,
        rw [←subtype.eta z.val z.val.property] at hqa,
        let x : {a // p a ∧ ∀ h, q ⟨a,h⟩} :=
          subtype.mk z.val.val
            (and.intro z.val.property (λ h, hqa)),
        existsi x,
        dsimp [f],
        apply subtype.eq; apply subtype.eq,
        dsimp *; refl
      }
    },
    exact l''.translate this
  end

end is_finite