BoundaryCycle.hs

-- | The shared algebra for simplifying and classifying an already-traced
-- boundary cycle. Topology traversal remains in 'FloodFillIterator'; this
-- module owns only fixed-point collinear deletion and winding observation.
module Moonlight.Triangulation.Internal.BoundaryCycle
  ( simplifyBoundaryCycle
  , rotateCycleLeast
  , rotateCycleLeastBy
  , consecutivePairs
  , unorderedPairs
  , orderedPair
  , cyclePairs
  , cyclePairsNonEmpty
  , cyclicTriples
  ) where

import Data.List.NonEmpty (NonEmpty (..))
import Data.List (tails)
import qualified Data.List.NonEmpty as NonEmpty

-- | Remove precisely the vertices admitted by @isRedundant@ until a fixed
-- point is reached, then classify the winding at the least keyed retained
-- vertex. The returned cycle preserves the tracer's start; publication layers
-- may rotate their value-level observation independently. The caller supplies
-- its obstruction constructor so the shared worker does not allocate a
-- disposable intermediate error vocabulary at either specialization.
simplifyBoundaryCycle
  :: (Eq value, Ord key)
  => ([value] -> obstruction)
  -> (value -> value -> value -> Bool)
  -> (value -> value -> value -> Ordering)
  -> (value -> key)
  -> [value]
  -> Either obstruction (Ordering, NonEmpty value)
simplifyBoundaryCycle obstruction isRedundant orientation key = descend
 where
  descend values@(_ : _ : _ : _) =
    let triples = cyclicTriples values
        retained =
          [ current
          | (previousValue, current, nextValue) <- triples
          , not (isRedundant previousValue current nextValue)
          ]
     in if retained == values
          then classify values triples
          else descend retained
  descend values = Left (obstruction values)

  classify values triples =
    case triples of
      [] -> Left (obstruction values)
      firstTriple : remainingTriples ->
        let (previousValue, current, nextValue) =
              foldl' chooseLeast firstTriple remainingTriples
            winding = orientation previousValue current nextValue
         in case (winding, values) of
              (EQ, _) -> Left (obstruction values)
              (_, initialValue : rest) -> Right (winding, initialValue :| rest)
              _ -> Left (obstruction values)

  chooseLeast selected@(_, selectedValue, _) candidate@(_, candidateValue, _)
    | key candidateValue < key selectedValue = candidate
    | otherwise = selected
{-# INLINE simplifyBoundaryCycle #-}

-- | Choose the least value as a cycle's observational origin without changing
-- its orientation. Boundary publication and generated convex geometry share
-- this one canonical rotation owner.
rotateCycleLeast :: Ord value => NonEmpty value -> NonEmpty value
rotateCycleLeast = rotateCycleLeastBy id
{-# INLINE rotateCycleLeast #-}

-- | Choose the least keyed value as a cycle's observational origin.
rotateCycleLeastBy
  :: Ord key
  => (value -> key)
  -> NonEmpty value
  -> NonEmpty value
rotateCycleLeastBy key values =
  case break ((== minimumKey) . key) asList of
    (before, selected : after) -> selected :| (after <> before)
    _ -> values
 where
  asList = NonEmpty.toList values
  minimumKey =
    foldl'
      (\selected candidate -> min selected (key candidate))
      (key (NonEmpty.head values))
      (NonEmpty.tail values)
{-# INLINE rotateCycleLeastBy #-}

-- | Every adjacent pair in a linear sequence.
consecutivePairs :: [value] -> [(value, value)]
consecutivePairs values = zip values (drop 1 values)
{-# INLINE consecutivePairs #-}

-- | Every unordered pair exactly once.
unorderedPairs :: [value] -> [(value, value)]
unorderedPairs values =
  [(left, right) | left : remaining <- tails values, right <- remaining]
{-# INLINE unorderedPairs #-}

-- | Canonically orient an unordered pair.
orderedPair :: Ord value => value -> value -> (value, value)
orderedPair left right
  | left <= right = (left, right)
  | otherwise = (right, left)
{-# INLINE orderedPair #-}

-- | Every directed edge of a non-empty cycle in cycle order.
cyclePairs :: NonEmpty value -> [(value, value)]
cyclePairs = NonEmpty.toList . cyclePairsNonEmpty
{-# INLINE cyclePairs #-}

-- | The non-empty form of 'cyclePairs'. A singleton cycle has its sole value
-- as both ends of its sole cyclic edge.
cyclePairsNonEmpty :: NonEmpty value -> NonEmpty (value, value)
cyclePairsNonEmpty values@(firstValue :| remaining) =
  NonEmpty.zip values successors
 where
  successors =
    case remaining of
      [] -> firstValue :| []
      nextValue : rest -> nextValue :| (rest <> [firstValue])
{-# INLINE cyclePairsNonEmpty #-}

-- | Consecutive cyclic triples, one centered at every value.
cyclicTriples :: [value] -> [(value, value, value)]
cyclicTriples values =
  case values of
    initial : second : remaining ->
      let final = foldl' (\_ current -> current) initial (second : remaining)
       in zip3
            (final : values)
            values
            (second : remaining <> [initial])
    _ -> []