CellCategory.hs

{-# LANGUAGE StandaloneDeriving #-}

-- | The finite, path-sensitive incidence category generated by a
-- 'CellComplex2D'. Objects are cells. Generating arrows descend from faces to
-- boundary edges and from edges to endpoint vertices; a face-to-vertex
-- composite retains the intermediate edge, so distinct incidence flags remain
-- distinct morphisms.
module Moonlight.Homology.Pure.Topology.CellCategory
  ( ComplexCat (..),
    ComplexOb (..),
    ComplexMor (..),
    complexCategory,
  )
where

import Data.Containers.ListUtils (nubOrd)
import Moonlight.Algebra.Pure.Orientation (Orientation)
import Moonlight.Category.Pure.Category (Category (..))
import Moonlight.Category.Pure.FiniteComposable (FiniteComposableCategory (..))
import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..), CellTypes (..), OrientedEdge (..))

-- | A cell complex regarded as its finite incidence category.
data ComplexCat c = ComplexCat c

data ComplexTwoMor c = ComplexTwoMor
  deriving stock (Eq, Ord, Show)

data ComplexCompositor c = ComplexCompositor
  deriving stock (Eq, Ord, Show)

-- | An object of the incidence category, indexed by cell dimension.
data ComplexOb c
  = VertexOb (Vertex c)
  | EdgeOb (Edge c)
  | FaceOb (Face c)

deriving stock instance
  (Eq (Vertex c), Eq (Edge c), Eq (Face c)) =>
  Eq (ComplexOb c)

deriving stock instance
  (CellTypes c, Ord (Vertex c), Ord (Edge c), Ord (Face c)) =>
  Ord (ComplexOb c)

deriving stock instance
  (Show (Vertex c), Show (Edge c), Show (Face c)) =>
  Show (ComplexOb c)

-- | A path-sensitive incidence morphism.
data ComplexMor c
  = -- | Identity on one cell object.
    IdentityMor (ComplexOb c)
  | -- | Oriented boundary incidence from a face to one edge.
    FaceToEdge (Face c) (Edge c) Orientation
  | -- | Endpoint incidence from an edge to one vertex.
    EdgeToVertex (Edge c) (Vertex c)
  | -- | The composite through the retained intermediate edge.
    FaceToVertex (Face c) (Edge c) (Vertex c)

deriving stock instance
  (Eq (Vertex c), Eq (Edge c), Eq (Face c)) =>
  Eq (ComplexMor c)

deriving stock instance
  (CellTypes c, Ord (Vertex c), Ord (Edge c), Ord (Face c)) =>
  Ord (ComplexMor c)

deriving stock instance
  (Show (Vertex c), Show (Edge c), Show (Face c)) =>
  Show (ComplexMor c)

-- | Regard a cell complex as its incidence category without copying it.
complexCategory :: c -> ComplexCat c
complexCategory = ComplexCat

instance CellComplex2D c => Category (ComplexCat c) where
  type Ob (ComplexCat c) = ComplexOb c
  type Mor (ComplexCat c) = ComplexMor c
  type TwoMor (ComplexCat c) = ComplexTwoMor c
  type Compositor (ComplexCat c) = ComplexCompositor c

  identity _ =
    Right . IdentityMor

  compose _ left right
    | complexTarget right /= complexSource left = Left ()
    | isIdentity left = Right (right, ComplexCompositor)
    | isIdentity right = Right (left, ComplexCompositor)
    | otherwise =
        case (left, right) of
          (EdgeToVertex edgeValue vertexValue, FaceToEdge faceValue edgeValue' _)
            | edgeValue == edgeValue' ->
                Right (FaceToVertex faceValue edgeValue vertexValue, ComplexCompositor)
          _ -> Left ()

  source _ =
    Right . complexSource

  target _ =
    Right . complexTarget

instance CellComplex2D c => FiniteComposableCategory (ComplexCat c) where
  enumerateObjects (ComplexCat complexValue) =
    complexObjects complexValue

  enumerateMorphisms categoryValue@(ComplexCat complexValue) =
    nubOrd
      ( fmap IdentityMor (enumerateObjects categoryValue)
          <> foldMap (faceIncidenceMorphisms complexValue) (faces complexValue)
          <> foldMap (edgeIncidenceMorphisms complexValue) (edges complexValue)
          <> foldMap (faceVertexMorphisms complexValue) (faces complexValue)
      )

complexObjects :: CellComplex2D c => c -> [ComplexOb c]
complexObjects complexValue =
  fmap VertexOb (vertices complexValue)
    <> fmap EdgeOb (edges complexValue)
    <> fmap FaceOb (faces complexValue)

faceIncidenceMorphisms :: CellComplex2D c => c -> Face c -> [ComplexMor c]
faceIncidenceMorphisms complexValue faceValue =
  fmap
    (\orientedBoundary -> FaceToEdge faceValue (orientedEdge orientedBoundary) (edgeOrientation orientedBoundary))
    (faceBoundary complexValue faceValue)

edgeIncidenceMorphisms :: CellComplex2D c => c -> Edge c -> [ComplexMor c]
edgeIncidenceMorphisms complexValue edgeValue =
  let (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue
   in fmap (EdgeToVertex edgeValue) (nubOrd [sourceVertex, targetVertex])

faceVertexMorphisms :: CellComplex2D c => c -> Face c -> [ComplexMor c]
faceVertexMorphisms complexValue faceValue =
  faceBoundary complexValue faceValue
    >>= ( \orientedBoundary ->
            let edgeValue = orientedEdge orientedBoundary
                (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue
             in fmap
                  (FaceToVertex faceValue edgeValue)
                  (nubOrd [sourceVertex, targetVertex])
        )

complexSource :: ComplexMor c -> ComplexOb c
complexSource morphism =
  case morphism of
    IdentityMor objectValue -> objectValue
    FaceToEdge faceValue _ _ -> FaceOb faceValue
    EdgeToVertex edgeValue _ -> EdgeOb edgeValue
    FaceToVertex faceValue _ _ -> FaceOb faceValue

complexTarget :: ComplexMor c -> ComplexOb c
complexTarget morphism =
  case morphism of
    IdentityMor objectValue -> objectValue
    FaceToEdge _ edgeValue _ -> EdgeOb edgeValue
    EdgeToVertex _ vertexValue -> VertexOb vertexValue
    FaceToVertex _ _ vertexValue -> VertexOb vertexValue

isIdentity :: ComplexMor c -> Bool
isIdentity morphism =
  case morphism of
    IdentityMor _ -> True
    _ -> False