RegionAlgebraSpec.hs

-- | Facade-only laws for exact planar Boolean composition.
module Moonlight.Planar.RegionAlgebraSpec (tests) where

import Moonlight.Planar.Convex (convexPolygon)
import Moonlight.Planar.Minkowski (MinkowskiOperation (..), MinkowskiReceipt (..), polygonOffset, structuringElement)
import Moonlight.Planar.Overlay (overlaySelectedRegion)
import Moonlight.Planar.Region (PlanarRegion, exactLoopPoints, polygonOuterLoop)
import Moonlight.Planar.Valuation (eulerCharacteristicValue, exactAreaValue, regionValuations, valuationArea, valuationEuler)
import Moonlight.Planar.OverlayFixtures (overlayRegions)
import Support (rectangleRegion, rectangleComponent, assertEqual, requireRight)

tests :: IO ()
tests = do
  testRegionBooleanLaws
  testFacadeComposition
  putStrLn "region algebra: ok"

testRegionBooleanLaws :: IO ()
testRegionBooleanLaws = do
  left <- rectangleRegion 0 0 2 2
  middle <- rectangleRegion 1 0 3 2
  right <- rectangleRegion 2 0 4 2
  expectedUnion <- rectangleRegion 0 0 3 2
  expectedIntersection <- rectangleRegion 1 0 2 2
  expectedDifference <- rectangleRegion 0 0 1 2

  leftUnionMiddle <- regionUnion left middle
  middleUnionLeft <- regionUnion middle left
  assertEqual "region union result" expectedUnion leftUnionMiddle
  assertEqual "region union commutativity" leftUnionMiddle middleUnionLeft
  assertEqual "region union idempotence" left =<< regionUnion left left
  assertEqual
    "region intersection result"
    expectedIntersection
    =<< regionIntersection left middle
  assertEqual
    "regularized region difference"
    expectedDifference
    =<< regionDifference left middle

  leftAssociated <- regionUnion leftUnionMiddle right
  middleUnionRight <- regionUnion middle right
  rightAssociated <- regionUnion left middleUnionRight
  assertEqual "region union associativity" leftAssociated rightAssociated

testFacadeComposition :: IO ()
testFacadeComposition = do
  left <- rectangleRegion 0 0 2 2
  right <- rectangleRegion 1 0 3 2
  overlay <- overlayRegions left right
  selectedUnion <-
    requireRight
      "facade selected region"
      (overlaySelectedRegion (uncurry (||)) overlay)
  valuations <- requireRight "facade region valuations" (regionValuations selectedUnion)
  assertEqual
    "facade valuation digest"
    (1, 6)
    ( eulerCharacteristicValue (valuationEuler valuations)
    , exactAreaValue (valuationArea valuations)
    )

  kernelComponent <- rectangleComponent 0 0 1 1
  kernel <-
    requireRight
      "facade convex kernel"
      (convexPolygon (exactLoopPoints (polygonOuterLoop kernelComponent)))
  element <- requireRight "facade structuring element" (structuringElement kernel)
  (expanded, receipt) <- requireRight "facade polygon offset" (polygonOffset element selectedUnion)
  expectedExpanded <- rectangleRegion 0 0 4 3
  assertEqual "facade morphology result" expectedExpanded expanded
  assertEqual "facade morphology receipt" MinkowskiAddition (minkowskiOperation receipt)

regionUnion :: PlanarRegion -> PlanarRegion -> IO PlanarRegion
regionUnion = combineRegions (uncurry (||))

regionIntersection :: PlanarRegion -> PlanarRegion -> IO PlanarRegion
regionIntersection = combineRegions (uncurry (&&))

regionDifference :: PlanarRegion -> PlanarRegion -> IO PlanarRegion
regionDifference = combineRegions (\(insideLeft, insideRight) -> insideLeft && not insideRight)

combineRegions
  :: ((Bool, Bool) -> Bool)
  -> PlanarRegion
  -> PlanarRegion
  -> IO PlanarRegion
combineRegions selected left right = do
  overlay <- overlayRegions left right
  requireRight "region Boolean publication" (overlaySelectedRegion selected overlay)