PlanarRegion.hs

module Moonlight.Triangulation.Example.PlanarRegion
  ( ExactFractionSummary (..)
  , CellValuationSummary (..)
  , PlanarExampleError (..)
  , PlanarExampleSummary (..)
  , planarExample
  ) where

import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import Moonlight.Triangulation

data ExactFractionSummary = ExactFractionSummary
  { fractionNumerator :: !Integer
  , fractionDenominator :: !Integer
  }
  deriving stock (Eq, Show)

data CellValuationSummary = CellValuationSummary
  { cellEulerCharacteristic :: !Int
  , cellExactArea :: !ExactFractionSummary
  }
  deriving stock (Eq, Show)

data PlanarExampleSummary = PlanarExampleSummary
  { booleanValuations :: ![CellValuationSummary]
  , morphologyAreas :: ![ExactFractionSummary]
  }
  deriving stock (Eq, Show)

data PlanarExampleError
  = PlanarRegionFailed !RegionValidationError
  | PlanarOverlayFailed !(OverlayError Bool Bool)
  | PlanarSelectionFailed !OverlaySelectionError
  | PlanarValuationFailed !ValuationError
  | PlanarMinkowskiFailed !MinkowskiError
  deriving stock (Eq, Show)

-- | Compute exact Boolean valuations and morphology through the public facade.
planarExample :: Either PlanarExampleError PlanarExampleSummary
planarExample = do
  left <- rectangleRegion 0 0 4 4
  right <- rectangleRegion 2 1 6 3
  leftLayer <- insideLayer left
  rightLayer <- insideLayer right
  overlay <- first PlanarOverlayFailed (overlayLayers leftLayer rightLayer)
  unionCells <- first PlanarSelectionFailed (overlayClosedUnion id id overlay)
  intersectionCells <-
    first PlanarSelectionFailed (overlayClosedIntersection id id overlay)
  differenceCells <-
    first PlanarSelectionFailed (overlayRegularizedDifference id id overlay)
  cellSummaries <-
    traverse
      cellValuationSummary
      [unionCells, intersectionCells, differenceCells]

  kernelLoop <- rectangleLoop (-1) (-1) 1 1
  kernelPolygon <-
    first PlanarMinkowskiFailed (convexPolygon (exactLoopPoints kernelLoop))
  kernel <- first PlanarMinkowskiFailed (structuringElement kernelPolygon)
  (sumRegion, _) <- first PlanarMinkowskiFailed (minkowskiSum left right)
  (offsetRegion, _) <- first PlanarMinkowskiFailed (polygonOffset kernel left)
  (insetRegion, _) <- first PlanarMinkowskiFailed (polygonInset kernel left)
  (openedRegion, _) <- first PlanarMinkowskiFailed (openWith kernel left)
  (closedRegion, _) <- first PlanarMinkowskiFailed (closeWith kernel left)
  areaSummaries <-
    traverse
      regionAreaSummary
      [sumRegion, offsetRegion, insetRegion, openedRegion, closedRegion]

  pure
    PlanarExampleSummary
      { booleanValuations = cellSummaries
      , morphologyAreas = areaSummaries
      }

rectangleLoop
  :: Integer
  -> Integer
  -> Integer
  -> Integer
  -> Either PlanarExampleError ExactLoop
rectangleLoop minimumX minimumY maximumX maximumY =
  first PlanarRegionFailed
    ( exactLoop
        ( exactPoint (fromInteger minimumX) (fromInteger minimumY)
            :| [ exactPoint (fromInteger maximumX) (fromInteger minimumY)
               , exactPoint (fromInteger maximumX) (fromInteger maximumY)
               , exactPoint (fromInteger minimumX) (fromInteger maximumY)
               ]
        )
    )

rectangleRegion
  :: Integer
  -> Integer
  -> Integer
  -> Integer
  -> Either PlanarExampleError PlanarRegion
rectangleRegion minimumX minimumY maximumX maximumY = do
  outer <- rectangleLoop minimumX minimumY maximumX maximumY
  component <- first PlanarRegionFailed (polygonComponent outer [])
  first PlanarRegionFailed (planarRegion [component])

insideLayer :: PlanarRegion -> Either PlanarExampleError (PlanarLayer Bool)
insideLayer =
  first PlanarRegionFailed
    . planarLayer False
    . Map.singleton True

cellValuationSummary
  :: ExactCellSet
  -> Either PlanarExampleError CellValuationSummary
cellValuationSummary cells = do
  valuations <- first PlanarValuationFailed (cellValuations cells)
  pure
    CellValuationSummary
      { cellEulerCharacteristic =
          eulerCharacteristicValue (valuationEuler valuations)
      , cellExactArea = exactAreaSummary valuations
      }

regionAreaSummary
  :: PlanarRegion
  -> Either PlanarExampleError ExactFractionSummary
regionAreaSummary region =
  exactAreaSummary
    <$> first PlanarValuationFailed (regionValuations region)

exactAreaSummary :: PlanarValuations -> ExactFractionSummary
exactAreaSummary valuations =
  let area = exactAreaValue (valuationArea valuations)
   in ExactFractionSummary
        { fractionNumerator = exactRationalNumerator area
        , fractionDenominator = exactRationalDenominator area
        }