FlipRewrite.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | The flip rewrite itself, on a quadrilateral.
module Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite
  ( flipEdge
  , applyFlip
  ) where

import Control.Monad (unless)
import Control.Monad.ST (ST)
import Moonlight.Triangulation.Handles.HandleDefs (UndirectedEdgeId (..))
import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)
import Moonlight.Triangulation.Internal.Mutable
  ( MutableDcel
  , payloadsPristine
  , readConstraint
  , readFace
  , readNext
  , readOrigin
  , readPrevious
  , resetEdgeData
  , resetFaceData
  , setCycle3
  , writeOrigin
  , writeVertexOut
  )
import Moonlight.Triangulation.Internal.Types (BuildError (ConstrainedEdgeFlipRefused))

flipEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())
flipEdge mutable edge = do
  protected <- readConstraint mutable edge
  if protected
    then pure (Left (ConstrainedEdgeFlipRefused (UndirectedEdgeId (fromIntegral (edge `quot` 2)))))
    else do
      let !twin = reverseIndex edge
      edgeNext <- readNext mutable edge
      edgePrevious <- readPrevious mutable edge
      twinNext <- readNext mutable twin
      twinPrevious <- readPrevious mutable twin
      leftFace <- readFace mutable edge
      rightFace <- readFace mutable twin
      a <- readOrigin mutable edge
      b <- readOrigin mutable twin
      c <- readOrigin mutable edgePrevious
      d <- readOrigin mutable twinPrevious
      applyFlip mutable edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d
      pure (Right ())

-- | The rewrite itself, from a quadrilateral the caller already holds. The
-- decision that licenses a flip reads the same two half-edge records the
-- rewrite consumes, so the drain hands its neighbourhood straight here rather
-- than making 'flipEdge' fetch it a second time; 'flipEdge' is that fetch, for
-- callers arriving with nothing but an index.
applyFlip
  :: MutableDcel s vertex directed undirected face
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> ST s ()
applyFlip mutable edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d = do
  writeOrigin mutable edge c
  writeOrigin mutable twin d
  setCycle3 mutable leftFace edge twinPrevious edgeNext
  setCycle3 mutable rightFace twin edgePrevious twinNext
  -- The diagonal AB is gone and CD stands in its slot; both triangles have
  -- swapped a corner. Three elements changed what they are, so three labels go.
  -- Each reset carries the same test; a site doing several states it once.
  unless (payloadsPristine mutable) $ do
    resetEdgeData mutable (edge `quot` 2)
    resetFaceData mutable leftFace
    resetFaceData mutable rightFace
  writeVertexOut mutable a twinNext
  writeVertexOut mutable b edgeNext
  writeVertexOut mutable c edge
  writeVertexOut mutable d twin
{-# INLINE applyFlip #-}