PowerBench.hs

-- | Tasty-bench lanes for the exact bounded power-diagram owner.  The timed
-- lanes force the public result, while the one-shot report keeps the
-- structural receipt and a shared incremental allocation observation outside
-- the timing sample.  One construction is revealed, its diagram is forced,
-- and only then is the additional receipt-reachable section measured.
module Moonlight.Triangulation.PowerBench
  ( PowerBenchCase
  , prepareCases
  , reportCases
  , runBenchmarks
  ) where

import BenchSupport (randomPoints, requireRight)
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Data.Foldable (traverse_)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import GHC.Conc.Sync (getAllocationCounter, setAllocationCounter)
import Moonlight.Triangulation
  ( BoundedPowerDiagram
  , ConvexPolygon
  , Point (Point)
  , PowerDiagramError
  , PowerDiagramReceipt
  , PowerSite
  , RegularTriangulation
  , RegularTriangulationReceipt
  , boundedPowerDiagram
  , convexPolygon
  , exactPoint
  , powerDiagramActiveBoundaries
  , powerDiagramCoincidentDominatedCells
  , powerDiagramCoincidentEquivalentCells
  , powerDiagramDomainVertices
  , powerDiagramBoundaryCompatibilityChecks
  , powerDiagramEmptyCells
  , powerDiagramExactIntersections
  , powerDiagramFinalCoordinateBitGrowth
  , powerDiagramFinalCoordinateBits
  , powerDiagramFinalDenominatorBits
  , powerDiagramInputSites
  , powerDiagramLowerDimensionalCells
  , powerDiagramMaximumAffineCoefficientBits
  , powerDiagramMaximumInputBits
  , powerDiagramPeakIntermediateBitGrowth
  , powerDiagramPeakIntermediateCoordinateBits
  , powerDiagramMaximumCellConstraints
  , powerDiagramPublishedCells
  , powerDiagramOracleCells
  , powerDiagramRegularEdges
  , powerDiagramRegularFaces
  , powerDiagramSubmittedSiteConstraints
  , powerSite
  , powerWeight
  , regularTriangulation
  )
import System.Mem (performGC)
import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, nf)

data PowerBenchFamily
  = WellConditioned
  | NearParallel
  | CollinearSlopes
  deriving stock (Eq, Ord, Show)

data PowerBenchCase = PowerBenchCase
  { powerBenchLabel :: !String
  , powerBenchDomain :: !ConvexPolygon
  , powerBenchSites :: !(NonEmpty (PowerSite Int))
  }

type PowerResult =
  Either (PowerDiagramError Int) (BoundedPowerDiagram Int, PowerDiagramReceipt)

type DiagramResult =
  Either (PowerDiagramError Int) (BoundedPowerDiagram Int)

type RegularResult =
  Either
    (PowerDiagramError Int)
    (RegularTriangulation Int, RegularTriangulationReceipt)

siteCounts :: [Int]
siteCounts = [16, 64, 128, 169, 256, 512]

families :: [PowerBenchFamily]
families = [WellConditioned, NearParallel, CollinearSlopes]

-- | Deterministic, fixed-domain fixture bands include the exhibit scale and a
-- larger scaling point.  Ordinary and nearly parallel families expose exact
-- clipping cost; the collinear family exposes upper-chain classification.
prepareCases :: IO [PowerBenchCase]
prepareCases =
  traverse prepareCase [(family, count) | family <- families, count <- siteCounts]

prepareCase :: (PowerBenchFamily, Int) -> IO PowerBenchCase
prepareCase (family, siteCount) = do
  domain <-
    requireRight
      ( convexPolygon
          ( exactPoint (-1) (-1)
              :| [exactPoint 1 (-1), exactPoint 1 1, exactPoint (-1) 1]
          )
      )
  sites <-
    traverse (prepareSite family) (zip [0 ..] (fixturePoints family siteCount))
  case NonEmpty.nonEmpty sites of
    Nothing -> fail "power benchmark fixture requires at least one site"
    Just nonEmptySites ->
      pure
        PowerBenchCase
          { powerBenchLabel = familyLabel family <> "/n=" <> show siteCount
          , powerBenchDomain = domain
          , powerBenchSites = nonEmptySites
          }

fixturePoints :: PowerBenchFamily -> Int -> [Point]
fixturePoints family siteCount =
  case family of
    WellConditioned -> randomPoints 0x9e3779b97f4a7c15 siteCount
    NearParallel -> nearParallelPoints siteCount
    CollinearSlopes -> collinearSlopePoints siteCount

nearParallelPoints :: Int -> [Point]
nearParallelPoints siteCount =
  [ Point
      (fromIntegral index / fromIntegral (siteCount + 1) * 1.8 - 0.9)
      (fromIntegral index / fromIntegral (siteCount + 1) * 1.8e-6 - 0.9e-6)
  | index <- [1 .. siteCount]
  ]

collinearSlopePoints :: Int -> [Point]
collinearSlopePoints siteCount =
  [ Point (fromIntegral index / 1024 - 0.5) 0
  | index <- [0 .. siteCount - 1]
  ]

familyLabel :: PowerBenchFamily -> String
familyLabel WellConditioned = "power-well-conditioned"
familyLabel NearParallel = "power-near-parallel"
familyLabel CollinearSlopes = "power-collinear-slopes"

prepareSite :: PowerBenchFamily -> (Int, Point) -> IO (PowerSite Int)
prepareSite family (label, point) = do
  let weightValue =
        case family of
          CollinearSlopes
            | odd label -> -(2 / 1048576)
            | otherwise -> 0
          WellConditioned -> fromIntegral (label `mod` 9 - 4) / 256
          NearParallel -> fromIntegral (label `mod` 9 - 4) / 256
  weight <- requireRight (powerWeight weightValue)
  requireRight (powerSite label point weight)

-- | Print one receipt and one allocation probe per fixture.  Tasty-bench
-- remains the authority for timing; this report is the derived structural
-- view that timing samples cannot carry.
reportCases :: [PowerBenchCase] -> IO ()
reportCases cases = do
  putStrLn "moonlight-triangulation exact bounded power-diagram benchmark"
  putStrLn
    "receipt-overhead-method: reveal one shared construction, force its diagram, then measure only the additional receipt-reachable allocation; strict work incurred while revealing the pair is not attributed"
  traverse_ reportCase cases

reportCase :: PowerBenchCase -> IO ()
reportCase benchmarkCase = do
  (sharedResult, allocation) <- measureSharedAllocation benchmarkCase
  case sharedResult of
    Left failure -> fail (powerBenchLabel benchmarkCase <> ": " <> show failure)
    Right (_, receipt) -> do
      putStrLn (renderReceipt (powerBenchLabel benchmarkCase) receipt)
      putStrLn
        ( powerBenchLabel benchmarkCase
            <> "-allocated-bytes/shared-full: "
            <> show (sharedFullAllocation allocation)
        )
      putStrLn
        ( powerBenchLabel benchmarkCase
            <> "-allocated-bytes/shared-through-diagram: "
            <> show (sharedDiagramAllocation allocation)
        )
      putStrLn
        ( powerBenchLabel benchmarkCase
            <> "-allocated-bytes/incremental-receipt-reachable-overhead: "
            <> show (sharedReceiptReachableAllocation allocation)
        )

runBenchmarks :: [PowerBenchCase] -> IO ()
runBenchmarks cases = defaultMain [bgroup "exact bounded power diagram" (concatMap caseBenchmarks cases)]

caseBenchmarks :: PowerBenchCase -> [Benchmark]
caseBenchmarks benchmarkCase =
  [ bench
      (powerBenchLabel benchmarkCase <> "/regular-topology")
      (nf constructRegularTopology benchmarkCase)
  , bench
      (powerBenchLabel benchmarkCase <> "/construct-with-receipt")
      (nf construct benchmarkCase)
  , bench
      (powerBenchLabel benchmarkCase <> "/construct-diagram-only")
      (nf constructDiagramOnly benchmarkCase)
  ]

construct :: PowerBenchCase -> PowerResult
construct benchmarkCase =
  boundedPowerDiagram
    (powerBenchDomain benchmarkCase)
    (powerBenchSites benchmarkCase)

constructDiagramOnly :: PowerBenchCase -> DiagramResult
constructDiagramOnly = fmap fst . construct

constructRegularTopology :: PowerBenchCase -> RegularResult
constructRegularTopology = regularTriangulation . powerBenchSites

data SharedPowerAllocation = SharedPowerAllocation
  { sharedFullAllocation :: !Integer
  , sharedDiagramAllocation :: !Integer
  , sharedReceiptReachableAllocation :: !Integer
  }

measureSharedAllocation
  :: PowerBenchCase
  -> IO (PowerResult, SharedPowerAllocation)
measureSharedAllocation benchmarkCase = do
  performGC
  setAllocationCounter maxBound
  allocationStart <- getAllocationCounter
  sharedResult <- evaluate (construct benchmarkCase)
  case sharedResult of
    Left failure -> do
      forcedFailure <- evaluate (force failure)
      allocationEnd <- getAllocationCounter
      let total = allocationDifference allocationStart allocationEnd
      pure
        ( Left forcedFailure
        , SharedPowerAllocation total total 0
        )
    Right (diagram, receipt) -> do
      forcedDiagram <- evaluate (force diagram)
      allocationAfterDiagram <- getAllocationCounter
      forcedReceipt <- evaluate (force receipt)
      allocationAfterReceipt <- getAllocationCounter
      pure
        ( Right (forcedDiagram, forcedReceipt)
        , SharedPowerAllocation
            { sharedFullAllocation =
                allocationDifference allocationStart allocationAfterReceipt
            , sharedDiagramAllocation =
                allocationDifference allocationStart allocationAfterDiagram
            , sharedReceiptReachableAllocation =
                allocationDifference allocationAfterDiagram allocationAfterReceipt
            }
        )

allocationDifference :: Integral amount => amount -> amount -> Integer
allocationDifference before after = toInteger (max 0 (before - after))

renderReceipt :: String -> PowerDiagramReceipt -> String
renderReceipt label receipt =
  unwords
    [ label <> "-receipt:"
    , field "input-sites" powerDiagramInputSites
    , field "domain-vertices" powerDiagramDomainVertices
    , field "submitted-site-constraints" powerDiagramSubmittedSiteConstraints
    , field "active-boundaries" powerDiagramActiveBoundaries
    , field "boundary-compatibility-checks" powerDiagramBoundaryCompatibilityChecks
    , field "exact-intersections" powerDiagramExactIntersections
    , field "published" powerDiagramPublishedCells
    , field "lower-dimensional" powerDiagramLowerDimensionalCells
    , field "empty" powerDiagramEmptyCells
    , field "coincident-equivalent" powerDiagramCoincidentEquivalentCells
    , field "coincident-dominated" powerDiagramCoincidentDominatedCells
    , field "regular-faces" powerDiagramRegularFaces
    , field "regular-edges" powerDiagramRegularEdges
    , field "oracle-cells" powerDiagramOracleCells
    , field "maximum-cell-constraints" powerDiagramMaximumCellConstraints
    , field "input-bits" powerDiagramMaximumInputBits
    , field "affine-bits" powerDiagramMaximumAffineCoefficientBits
    , field "peak-coordinate-bits" powerDiagramPeakIntermediateCoordinateBits
    , field "final-coordinate-bits" powerDiagramFinalCoordinateBits
    , field "final-denominator-bits" powerDiagramFinalDenominatorBits
    , field "peak-growth-bits" powerDiagramPeakIntermediateBitGrowth
    , field "final-growth-bits" powerDiagramFinalCoordinateBitGrowth
    ]
 where
  field :: Show value => String -> (PowerDiagramReceipt -> value) -> String
  field name project = name <> "=" <> show (project receipt)