{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.PolygonTriangulation.EarClip
-- Copyright   :  (C) David Himmelstrup
-- License     :  see the LICENSE file
-- Maintainer  :  David Himmelstrup
--
-- Ear clipping triangulation algorithms. The baseline algorithm runs in \( O(n^2) \)
-- but has a low constant factor overhead. The z-order hashed variant runs in
-- \( O(n \log n) \).
--
-- References:
--
--  1. https://en.wikipedia.org/wiki/Polygon_triangulation#Ear_clipping_method
--  2. https://en.wikipedia.org/wiki/Z-order_curve
--
--------------------------------------------------------------------------------
module Algorithms.Geometry.PolygonTriangulation.EarClip
  ( earClip
  , earClipRandom
  , earClipHashed
  , earClipRandomHashed
  , zHash
  , zUnHash
  ) where

import           Control.Lens                 ((^.))
import           Control.Monad.Identity
import           Control.Monad.ST             (ST, runST)
import           Control.Monad.ST.Unsafe      (unsafeInterleaveST)
import           Data.Bits
import           Data.Ext
import           Data.Geometry.Boundary       (PointLocationResult (Outside))
import           Data.Geometry.Point          (Point (Point2), ccw', pattern CCW)
import           Data.Geometry.Polygon
import           Data.Geometry.Box
import           Data.Geometry.Triangle       (Triangle (Triangle), inTriangleRelaxed)
import           Data.STRef
import           Data.Vector                  (Vector)
import qualified Data.Vector                  as V
import qualified Data.Vector.Algorithms.Intro as Algo
import qualified Data.Vector.Circular         as CV
import qualified Data.Vector.NonEmpty         as NE
import qualified Data.Vector.Unboxed          as U
import qualified Data.Vector.Unboxed.Mutable  as MU
import           GHC.Exts                     (build)
import           Linear.V2
import           System.Random                (mkStdGen, randomR)

{-
  We can check if a vertex is an ear in O(n) time. Checking all vertices will definitely
  yield at least one ear in O(n^2) time. So, finding N ears will take O(n^3) if done naively.

  Keeping a separate list of possible ears will improve matters. For each possible ear,
  we check if the vertex really is an ear or not. If it isn't, it is deleted from the
  list of possible ears. If it /is/ an ear, the vertex is cut and the neighbours are
  added back to the list of possible ears (if they aren't in the list already).

  So, start with a list of N possible ears, and we might add two vertices to the list
  ever time we find an ear. Since there are only N ears to be found, only 2*N vertices
  can be added to the list of possible ears in the worst case scenario. The list is
  therefore bounded to 3*N and finding all ears is therefore O(n^2).

  Note: When checking if a vertex is an ear, it is sufficient to check against
        reflex vertices. Some implementations keep a separate list of reflex
        vertices for this reason but it does increase the constant factor
        overhead. I think it's better to keep the constant factor low for small values
        of N and use the hashed algorithm for larger values of N.
-}
-- | \( O(n^2) \)
--
--   Returns triangular faces using absolute polygon point indices.
earClip :: (Num r, Ord r) => SimplePolygon p r -> [(Int,Int,Int)]
earClip :: SimplePolygon p r -> [(Int, Int, Int)]
earClip SimplePolygon p r
poly = (forall b. ((Int, Int, Int) -> b -> b) -> b -> b)
-> [(Int, Int, Int)]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build forall b. ((Int, Int, Int) -> b -> b) -> b -> b
gen
  where
    vs :: Vector (Point 2 r :+ p)
vs = NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a. NonEmptyVector a -> Vector a
NE.toVector (NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p))
-> NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ CircularVector (Point 2 r :+ p) -> NonEmptyVector (Point 2 r :+ p)
forall a. CircularVector a -> NonEmptyVector a
CV.vector (CircularVector (Point 2 r :+ p)
 -> NonEmptyVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
-> NonEmptyVector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ SimplePolygon p r
polySimplePolygon p r
-> Getting
     (CircularVector (Point 2 r :+ p))
     (SimplePolygon p r)
     (CircularVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
forall s a. s -> Getting a s a -> a
^.Getting
  (CircularVector (Point 2 r :+ p))
  (SimplePolygon p r)
  (CircularVector (Point 2 r :+ p))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector
    gen :: ((Int,Int,Int) -> b -> b) -> b -> b
    gen :: ((Int, Int, Int) -> b -> b) -> b -> b
gen (Int, Int, Int) -> b -> b
cons b
nil = (forall s. ST s b) -> b
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s b) -> b) -> (forall s. ST s b) -> b
forall a b. (a -> b) -> a -> b
$ do
      MutList s (Point 2 r :+ p)
vertices <- Vector (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall a s. Vector a -> ST s (MutList s a)
mutListFromVector Vector (Point 2 r :+ p)
vs
      MutList s (Point 2 r :+ p)
possibleEars <- MutList s (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall s a. MutList s a -> ST s (MutList s a)
mutListClone MutList s (Point 2 r :+ p)
vertices
      let worker :: Int -> Int -> ST s b
worker Int
len Int
focus = do
            Int
prev <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
vertices Int
focus
            Int
next <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
vertices Int
focus
            if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
              then
                b -> ST s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ST s b) -> b -> ST s b
forall a b. (a -> b) -> a -> b
$ (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next) b
nil
              else do
                Int
prevEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Int
nextEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Bool
isEar <- MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s Bool
forall r s p.
(Num r, Ord r) =>
MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s Bool
earCheck MutList s (Point 2 r :+ p)
vertices Int
prev Int
focus Int
next
                if Bool
isEar
                  then do
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
vertices Int
prev Int
next -- remove ear

                    case (Int
prevEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
prev, Int
nextEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
next) of
                      (Bool
True, Bool
True)  -> do
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prev Int
nextEar Int
next
                      (Bool
True, Bool
False) -> do
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                      (Bool
False, Bool
True) -> do
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
next
                      (Bool
False, Bool
False) -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                    (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next)
                      (b -> b) -> ST s b -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s b -> ST s b
forall s a. ST s a -> ST s a
unsafeInterleaveST (Int -> Int -> ST s b
worker (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
nextEar)
                  else do -- not an ear
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar -- remove vertex
                    Int -> Int -> ST s b
worker Int
len Int
nextEar
      Int -> Int -> ST s b
worker (Vector (Point 2 r :+ p) -> Int
forall a. Vector a -> Int
V.length Vector (Point 2 r :+ p)
vs) Int
0

-- | \( O(n^2) \)
--
--   Returns triangular faces using absolute polygon point indices.
earClipRandom :: (Num r, Ord r) => SimplePolygon p r -> [(Int,Int,Int)]
earClipRandom :: SimplePolygon p r -> [(Int, Int, Int)]
earClipRandom SimplePolygon p r
poly = (forall b. ((Int, Int, Int) -> b -> b) -> b -> b)
-> [(Int, Int, Int)]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build forall b. ((Int, Int, Int) -> b -> b) -> b -> b
gen
  where
    vs :: Vector (Point 2 r :+ p)
vs = NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a. NonEmptyVector a -> Vector a
NE.toVector (NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p))
-> NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ CircularVector (Point 2 r :+ p) -> NonEmptyVector (Point 2 r :+ p)
forall a. CircularVector a -> NonEmptyVector a
CV.vector (CircularVector (Point 2 r :+ p)
 -> NonEmptyVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
-> NonEmptyVector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ SimplePolygon p r
polySimplePolygon p r
-> Getting
     (CircularVector (Point 2 r :+ p))
     (SimplePolygon p r)
     (CircularVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
forall s a. s -> Getting a s a -> a
^.Getting
  (CircularVector (Point 2 r :+ p))
  (SimplePolygon p r)
  (CircularVector (Point 2 r :+ p))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector
    gen :: ((Int,Int,Int) -> b -> b) -> b -> b
    gen :: ((Int, Int, Int) -> b -> b) -> b -> b
gen (Int, Int, Int) -> b -> b
cons b
nil = (forall s. ST s b) -> b
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s b) -> b) -> (forall s. ST s b) -> b
forall a b. (a -> b) -> a -> b
$ do
      MutList s (Point 2 r :+ p)
vertices <- Vector (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall a s. Vector a -> ST s (MutList s a)
mutListFromVector Vector (Point 2 r :+ p)
vs
      MutList s (Point 2 r :+ p)
possibleEars <- MutList s (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall s a. MutList s a -> ST s (MutList s a)
mutListClone MutList s (Point 2 r :+ p)
vertices
      Shuffled s
shuffled <- Int -> ST s (Shuffled s)
forall s. Int -> ST s (Shuffled s)
newShuffled (Vector (Point 2 r :+ p) -> Int
forall a. Vector a -> Int
V.length Vector (Point 2 r :+ p)
vs)
      let worker :: Int -> ST s b
worker Int
len = do
            Int
focus <- Shuffled s -> ST s Int
forall s. Shuffled s -> ST s Int
popShuffled Shuffled s
shuffled
            Int
prev <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
vertices Int
focus
            Int
next <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
vertices Int
focus
            if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
              then
                b -> ST s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ST s b) -> b -> ST s b
forall a b. (a -> b) -> a -> b
$ (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next) b
nil
              else do
                Int
prevEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Int
nextEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Bool
isEar <- MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s Bool
forall r s p.
(Num r, Ord r) =>
MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s Bool
earCheck MutList s (Point 2 r :+ p)
vertices Int
prev Int
focus Int
next
                if Bool
isEar
                  then do
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
vertices Int
prev Int
next -- remove ear

                    case (Int
prevEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
prev, Int
nextEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
next) of
                      (Bool
True, Bool
True)  -> do
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
prev
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
next
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prev Int
nextEar Int
next
                      (Bool
True, Bool
False) -> do
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
prev
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                      (Bool
False, Bool
True) -> do
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
next
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
next
                      (Bool
False, Bool
False) -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                    (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next)
                      (b -> b) -> ST s b -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s b -> ST s b
forall s a. ST s a -> ST s a
unsafeInterleaveST (Int -> ST s b
worker (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
                  else do -- not an ear
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar -- remove vertex
                    Int -> ST s b
worker Int
len
      Int -> ST s b
worker (Vector (Point 2 r :+ p) -> Int
forall a. Vector a -> Int
V.length Vector (Point 2 r :+ p)
vs)

-- | \( O(n \log n) \) expected time.
--
--   Returns triangular faces using absolute polygon point indices.
earClipHashed :: Real r => SimplePolygon p r -> [(Int,Int,Int)]
earClipHashed :: SimplePolygon p r -> [(Int, Int, Int)]
earClipHashed SimplePolygon p r
poly = (forall b. ((Int, Int, Int) -> b -> b) -> b -> b)
-> [(Int, Int, Int)]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build forall b. ((Int, Int, Int) -> b -> b) -> b -> b
gen
  where
    vs :: Vector (Point 2 r :+ p)
vs = NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a. NonEmptyVector a -> Vector a
NE.toVector (NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p))
-> NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ CircularVector (Point 2 r :+ p) -> NonEmptyVector (Point 2 r :+ p)
forall a. CircularVector a -> NonEmptyVector a
CV.vector (CircularVector (Point 2 r :+ p)
 -> NonEmptyVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
-> NonEmptyVector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ SimplePolygon p r
polySimplePolygon p r
-> Getting
     (CircularVector (Point 2 r :+ p))
     (SimplePolygon p r)
     (CircularVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
forall s a. s -> Getting a s a -> a
^.Getting
  (CircularVector (Point 2 r :+ p))
  (SimplePolygon p r)
  (CircularVector (Point 2 r :+ p))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector
    n :: Int
n = Vector (Point 2 r :+ p) -> Int
forall a. Vector a -> Int
V.length Vector (Point 2 r :+ p)
vs
    hasher :: Point 2 r -> Word
hasher = Vector (Point 2 r :+ p) -> Point 2 r -> Word
forall r p. Real r => Vector (Point 2 r :+ p) -> Point 2 r -> Word
zHashGen Vector (Point 2 r :+ p)
vs
    zHashVec :: Vector Word
zHashVec = Int -> (Int -> Word) -> Vector Word
forall a. Unbox a => Int -> (Int -> a) -> Vector a
U.generate Int
n ((Int -> Word) -> Vector Word) -> (Int -> Word) -> Vector Word
forall a b. (a -> b) -> a -> b
$ \Int
i -> Point 2 r -> Word
hasher (Vector (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Point 2 r :+ p)
vs Int
i (Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    gen :: ((Int,Int,Int) -> b -> b) -> b -> b
    gen :: ((Int, Int, Int) -> b -> b) -> b -> b
gen (Int, Int, Int) -> b -> b
cons b
nil = (forall s. ST s b) -> b
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s b) -> b) -> (forall s. ST s b) -> b
forall a b. (a -> b) -> a -> b
$ do
      MutList s (Point 2 r :+ p)
vertices <- Vector (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall a s. Vector a -> ST s (MutList s a)
mutListFromVector Vector (Point 2 r :+ p)
vs
      MutList s Word
zHashes <- Vector Word -> ST s (MutList s Word)
forall a s. (Ord a, Unbox a) => Vector a -> ST s (MutList s a)
mutListSort Vector Word
zHashVec
      MutList s (Point 2 r :+ p)
possibleEars <- MutList s (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall s a. MutList s a -> ST s (MutList s a)
mutListClone MutList s (Point 2 r :+ p)
vertices
      let worker :: Int -> Int -> ST s b
worker Int
len Int
focus = do
            Int
prev <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
vertices Int
focus
            Int
next <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
vertices Int
focus
            if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
              then
                b -> ST s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ST s b) -> b -> ST s b
forall a b. (a -> b) -> a -> b
$ (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next) b
nil
              else do
                Int
prevEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Int
nextEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Bool
isEar <- (Point 2 r -> Word)
-> MutList s (Point 2 r :+ p)
-> MutList s Word
-> Int
-> Int
-> Int
-> ST s Bool
forall r s p.
Real r =>
(Point 2 r -> Word)
-> MutList s (Point 2 r :+ p)
-> MutList s Word
-> Int
-> Int
-> Int
-> ST s Bool
earCheckHashed Point 2 r -> Word
hasher MutList s (Point 2 r :+ p)
vertices MutList s Word
zHashes Int
prev Int
focus Int
next
                if Bool
isEar
                  then do
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
vertices Int
prev Int
next -- remove ear
                    MutList s Word -> Int -> ST s ()
forall s a. MutList s a -> Int -> ST s ()
mutListDeleteFocus MutList s Word
zHashes Int
focus

                    case (Int
prevEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
prev, Int
nextEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
next) of
                      (Bool
True, Bool
True)  -> do
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prev Int
nextEar Int
next
                      (Bool
True, Bool
False) -> do
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                      (Bool
False, Bool
True) -> do
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
next
                      (Bool
False, Bool
False) -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                    (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next)
                      (b -> b) -> ST s b -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s b -> ST s b
forall s a. ST s a -> ST s a
unsafeInterleaveST (Int -> Int -> ST s b
worker (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
nextEar)
                  else do -- not an ear
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar -- remove vertex
                    Int -> Int -> ST s b
worker Int
len Int
nextEar
      Int -> Int -> ST s b
worker Int
n Int
0

-- | \( O(n \log n) \) expected time.
--
--   Returns triangular faces using absolute polygon point indices.
earClipRandomHashed :: Real r => SimplePolygon p r -> [(Int,Int,Int)]
earClipRandomHashed :: SimplePolygon p r -> [(Int, Int, Int)]
earClipRandomHashed SimplePolygon p r
poly = (forall b. ((Int, Int, Int) -> b -> b) -> b -> b)
-> [(Int, Int, Int)]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build forall b. ((Int, Int, Int) -> b -> b) -> b -> b
gen
  where
    vs :: Vector (Point 2 r :+ p)
vs = NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a. NonEmptyVector a -> Vector a
NE.toVector (NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p))
-> NonEmptyVector (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ CircularVector (Point 2 r :+ p) -> NonEmptyVector (Point 2 r :+ p)
forall a. CircularVector a -> NonEmptyVector a
CV.vector (CircularVector (Point 2 r :+ p)
 -> NonEmptyVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
-> NonEmptyVector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ SimplePolygon p r
polySimplePolygon p r
-> Getting
     (CircularVector (Point 2 r :+ p))
     (SimplePolygon p r)
     (CircularVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
forall s a. s -> Getting a s a -> a
^.Getting
  (CircularVector (Point 2 r :+ p))
  (SimplePolygon p r)
  (CircularVector (Point 2 r :+ p))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector
    n :: Int
n = Vector (Point 2 r :+ p) -> Int
forall a. Vector a -> Int
V.length Vector (Point 2 r :+ p)
vs
    hasher :: Point 2 r -> Word
hasher = Vector (Point 2 r :+ p) -> Point 2 r -> Word
forall r p. Real r => Vector (Point 2 r :+ p) -> Point 2 r -> Word
zHashGen Vector (Point 2 r :+ p)
vs
    zHashVec :: Vector Word
zHashVec = Int -> (Int -> Word) -> Vector Word
forall a. Unbox a => Int -> (Int -> a) -> Vector a
U.generate Int
n ((Int -> Word) -> Vector Word) -> (Int -> Word) -> Vector Word
forall a b. (a -> b) -> a -> b
$ \Int
i -> Point 2 r -> Word
hasher (Vector (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Point 2 r :+ p)
vs Int
i (Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    gen :: ((Int,Int,Int) -> b -> b) -> b -> b
    gen :: ((Int, Int, Int) -> b -> b) -> b -> b
gen (Int, Int, Int) -> b -> b
cons b
nil = (forall s. ST s b) -> b
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s b) -> b) -> (forall s. ST s b) -> b
forall a b. (a -> b) -> a -> b
$ do
      MutList s (Point 2 r :+ p)
vertices <- Vector (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall a s. Vector a -> ST s (MutList s a)
mutListFromVector Vector (Point 2 r :+ p)
vs
      MutList s Word
zHashes <- Vector Word -> ST s (MutList s Word)
forall a s. (Ord a, Unbox a) => Vector a -> ST s (MutList s a)
mutListSort Vector Word
zHashVec
      MutList s (Point 2 r :+ p)
possibleEars <- MutList s (Point 2 r :+ p) -> ST s (MutList s (Point 2 r :+ p))
forall s a. MutList s a -> ST s (MutList s a)
mutListClone MutList s (Point 2 r :+ p)
vertices
      Shuffled s
shuffled <- Int -> ST s (Shuffled s)
forall s. Int -> ST s (Shuffled s)
newShuffled (Vector (Point 2 r :+ p) -> Int
forall a. Vector a -> Int
V.length Vector (Point 2 r :+ p)
vs)
      let worker :: Int -> ST s b
worker Int
len = do
            Int
focus <- Shuffled s -> ST s Int
forall s. Shuffled s -> ST s Int
popShuffled Shuffled s
shuffled
            Int
prev <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
vertices Int
focus
            Int
next <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
vertices Int
focus
            if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
              then
                b -> ST s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ST s b) -> b -> ST s b
forall a b. (a -> b) -> a -> b
$ (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next) b
nil
              else do
                Int
prevEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Int
nextEar <- MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
possibleEars Int
focus
                Bool
isEar <- (Point 2 r -> Word)
-> MutList s (Point 2 r :+ p)
-> MutList s Word
-> Int
-> Int
-> Int
-> ST s Bool
forall r s p.
Real r =>
(Point 2 r -> Word)
-> MutList s (Point 2 r :+ p)
-> MutList s Word
-> Int
-> Int
-> Int
-> ST s Bool
earCheckHashed Point 2 r -> Word
hasher MutList s (Point 2 r :+ p)
vertices MutList s Word
zHashes Int
prev Int
focus Int
next
                if Bool
isEar
                  then do
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
vertices Int
prev Int
next -- remove ear
                    MutList s Word -> Int -> ST s ()
forall s a. MutList s a -> Int -> ST s ()
mutListDeleteFocus MutList s Word
zHashes Int
focus

                    case (Int
prevEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
prev, Int
nextEar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
next) of
                      (Bool
True, Bool
True)  -> do
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
prev
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
next
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prev Int
nextEar Int
next
                      (Bool
True, Bool
False) -> do
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
prev
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
prev
                      (Bool
False, Bool
True) -> do
                        Shuffled s -> Int -> ST s ()
forall s. Shuffled s -> Int -> ST s ()
pushShuffled Shuffled s
shuffled Int
next
                        MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar Int
next
                      (Bool
False, Bool
False) -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                    (Int, Int, Int) -> b -> b
cons (Int
prev, Int
focus, Int
next)
                      (b -> b) -> ST s b -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s b -> ST s b
forall s a. ST s a -> ST s a
unsafeInterleaveST (Int -> ST s b
worker (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
                  else do -- not an ear
                    MutList s (Point 2 r :+ p) -> Int -> Int -> ST s ()
forall s a. MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s (Point 2 r :+ p)
possibleEars Int
prevEar Int
nextEar -- remove vertex
                    Int -> ST s b
worker Int
len
      Int -> ST s b
worker Int
n

-------------------------------------------------------------------------------
-- Bounding box

-- Returns (minX, widthX, minY, heightY)
zHashGen :: Real r => V.Vector (Point 2 r :+ p) -> (Point 2 r -> Word)
zHashGen :: Vector (Point 2 r :+ p) -> Point 2 r -> Word
zHashGen Vector (Point 2 r :+ p)
v = (r, Double, r, Double) -> Point 2 r -> Word
forall r. Real r => (r, Double, r, Double) -> Point 2 r -> Word
zHashPoint (r, Double, r, Double)
bounds
  where
    bounds :: (r, Double, r, Double)
bounds = (r
minX, r -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (r
maxXr -> r -> r
forall a. Num a => a -> a -> a
-r
minX), r
minY, r -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (r
maxYr -> r -> r
forall a. Num a => a -> a -> a
-r
minY))
    bb :: Box 2 () r
bb = (Box 2 () r -> Box 2 () r -> Box 2 () r)
-> Vector (Box 2 () r) -> Box 2 () r
forall a. (a -> a -> a) -> Vector a -> a
V.foldl1' Box 2 () r -> Box 2 () r -> Box 2 () r
forall a. Semigroup a => a -> a -> a
(<>) (Vector (Box 2 () r) -> Box 2 () r)
-> Vector (Box 2 () r) -> Box 2 () r
forall a b. (a -> b) -> a -> b
$ ((Point 2 r :+ p) -> Box 2 () r)
-> Vector (Point 2 r :+ p) -> Vector (Box 2 () r)
forall a b. (a -> b) -> Vector a -> Vector b
V.map (Point 2 r :+ p) -> Box 2 () r
forall g.
(IsBoxable g, Ord (NumType g)) =>
g -> Box (Dimension g) () (NumType g)
boundingBox Vector (Point 2 r :+ p)
v
    Point2 r
minX r
minY = Box 2 () r -> Point 2 r :+ ()
forall (d :: Nat) p r. Box d p r -> Point d r :+ p
minPoint Box 2 () r
bb (Point 2 r :+ ())
-> Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
    Point2 r
maxX r
maxY = Box 2 () r -> Point 2 r :+ ()
forall (d :: Nat) p r. Box d p r -> Point d r :+ p
minPoint Box 2 () r
bb (Point 2 r :+ ())
-> Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core

-------------------------------------------------------------------------------
-- Z-Order
-- https://en.wikipedia.org/wiki/Z-order_curve

zHashPoint :: Real r => (r,Double,r,Double) -> Point 2 r -> Word
zHashPoint :: (r, Double, r, Double) -> Point 2 r -> Word
zHashPoint (r
minX, Double
widthX, r
minY, Double
heightY) (Point2 r
x r
y) =
    V2 Word -> Word
zHash (Word -> Word -> V2 Word
forall a. a -> a -> V2 a
V2 Word
x' Word
y')
  where
    x' :: Word
x' = Double -> Word
forall a b. (RealFrac a, Integral b) => a -> b
round (r -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (r
xr -> r -> r
forall a. Num a => a -> a -> a
-r
minX) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
widthX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
zHashMax)
    y' :: Word
y' = Double -> Word
forall a b. (RealFrac a, Integral b) => a -> b
round (r -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (r
yr -> r -> r
forall a. Num a => a -> a -> a
-r
minY) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
heightY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
zHashMax)

zHashMax :: Double
zHashMax :: Double
zHashMax = Word -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word
zHashMaxW

zHashMaxW :: Word
zHashMaxW :: Word
zHashMaxW = if Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize Word
zHashMaxW Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 then Word
0xFFFF else Word
0xFFFFFFFF

-- | O(1) Z-Order hash the first half-world of each coordinate.
zHash :: V2 Word -> Word
zHash :: V2 Word -> Word
zHash (V2 Word
a Word
b) = Word -> Word
zHashSingle Word
a Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word -> Word
zHashSingle Word
b) Int
1)

-- | O(1) Reverse z-order hash.
zUnHash :: Word -> V2 Word
zUnHash :: Word -> V2 Word
zUnHash Word
z =
  Word -> Word -> V2 Word
forall a. a -> a -> V2 a
V2 (Word -> Word
zUnHashSingle Word
z) (Word -> Word
zUnHashSingle (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
z Int
1))

zHashSingle :: Word -> Word
zHashSingle :: Word -> Word
zHashSingle Word
w
  | Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize Word
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 = Word -> Word
zHashSingle32 Word
w
  | Bool
otherwise             = Word -> Word
zHashSingle64 Word
w

zUnHashSingle :: Word -> Word
zUnHashSingle :: Word -> Word
zUnHashSingle Word
w
  | Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize Word
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 = Word -> Word
zUnHashSingle32 Word
w
  | Bool
otherwise             = Word -> Word
zUnHashSingle64 Word
w

zHashSingle32 :: Word -> Word
zHashSingle32 :: Word -> Word
zHashSingle32 Word
w = Identity Word -> Word
forall a. Identity a -> a
runIdentity (Identity Word -> Word) -> Identity Word -> Word
forall a b. (a -> b) -> a -> b
$ do
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0000FFFF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
8)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x00FF00FF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
4)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0F0F0F0F
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
2)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x33333333
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
1)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x55555555
    Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
w

zUnHashSingle32 :: Word -> Word
zUnHashSingle32 :: Word -> Word
zUnHashSingle32 Word
w = Identity Word -> Word
forall a. Identity a -> a
runIdentity (Identity Word -> Word) -> Identity Word -> Word
forall a b. (a -> b) -> a -> b
$ do
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x55555555
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
1)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x33333333
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
2)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0F0F0F0F
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
4)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x00FF00FF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
8)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0000FFFF
    Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
w

zHashSingle64 :: Word -> Word
zHashSingle64 :: Word -> Word
zHashSingle64 Word
w = Identity Word -> Word
forall a. Identity a -> a
runIdentity (Identity Word -> Word) -> Identity Word -> Word
forall a b. (a -> b) -> a -> b
$ do
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x00000000FFFFFFFF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
16) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0000FFFF0000FFFF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
8)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x00FF00FF00FF00FF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
4)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0F0F0F0F0F0F0F0F
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
2)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3333333333333333
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL Word
w Int
1)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x5555555555555555
    Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
w

zUnHashSingle64 :: Word -> Word
zUnHashSingle64 :: Word -> Word
zUnHashSingle64 Word
w = Identity Word -> Word
forall a. Identity a -> a
runIdentity (Identity Word -> Word) -> Identity Word -> Word
forall a b. (a -> b) -> a -> b
$ do
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x5555555555555555
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
1) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3333333333333333
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
2)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0F0F0F0F0F0F0F0F
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
4)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x00FF00FF00FF00FF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
8)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0000FFFF0000FFFF
    Word
w <- Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Identity Word) -> Word -> Identity Word
forall a b. (a -> b) -> a -> b
$ (Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
w Int
16)  Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x00000000FFFFFFFF
    Word -> Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
w

-------------------------------------------------------------------------------
-- Shuffled

data Shuffled s = Shuffled
  { Shuffled s -> STRef s Int
shuffleCount  :: STRef s Int
  , Shuffled s -> MVector s Int
shuffleVector :: MU.MVector s Int }

newShuffled :: Int -> ST s (Shuffled s)
newShuffled :: Int -> ST s (Shuffled s)
newShuffled Int
len = STRef s Int -> MVector s Int -> Shuffled s
forall s. STRef s Int -> MVector s Int -> Shuffled s
Shuffled (STRef s Int -> MVector s Int -> Shuffled s)
-> ST s (STRef s Int) -> ST s (MVector s Int -> Shuffled s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
len ST s (MVector s Int -> Shuffled s)
-> ST s (MVector s Int) -> ST s (Shuffled s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Vector Int -> ST s (MVector (PrimState (ST s)) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
U.unsafeThaw (Int -> Int -> Vector Int
forall a. (Unbox a, Num a) => a -> Int -> Vector a
U.enumFromN Int
0 Int
len)

popShuffled :: Shuffled s -> ST s Int
popShuffled :: Shuffled s -> ST s Int
popShuffled Shuffled{STRef s Int
MVector s Int
shuffleVector :: MVector s Int
shuffleCount :: STRef s Int
shuffleVector :: forall s. Shuffled s -> MVector s Int
shuffleCount :: forall s. Shuffled s -> STRef s Int
..} = do
  Int
count <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
shuffleCount
  STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
shuffleCount (Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  let idx :: Int
idx = (Int, StdGen) -> Int
forall a b. (a, b) -> a
fst ((Int, StdGen) -> Int) -> (Int, StdGen) -> Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int -> StdGen
mkStdGen Int
count)
  Int
val <- MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MU.unsafeRead MVector s Int
MVector (PrimState (ST s)) Int
shuffleVector Int
idx
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite MVector s Int
MVector (PrimState (ST s)) Int
shuffleVector Int
idx (Int -> ST s ()) -> ST s Int -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MU.unsafeRead MVector s Int
MVector (PrimState (ST s)) Int
shuffleVector (Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  Int -> ST s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
val

pushShuffled :: Shuffled s -> Int -> ST s ()
pushShuffled :: Shuffled s -> Int -> ST s ()
pushShuffled (Shuffled STRef s Int
ref MVector s Int
vector) Int
val = do
  Int
count <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
ref
  STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
ref (Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite MVector s Int
MVector (PrimState (ST s)) Int
vector Int
count Int
val

-------------------------------------------------------------------------------
-- MutList

data MutList s a = MutList
  { MutList s a -> Int -> a
mutListIndex   :: (Int -> a)
  , MutList s a -> MVector s Int
mutListNextVec :: MU.MVector s Int
  , MutList s a -> MVector s Int
mutListPrevVec :: MU.MVector s Int
  }

-- O(n)
mutListFromVector :: Vector a -> ST s (MutList s a)
mutListFromVector :: Vector a -> ST s (MutList s a)
mutListFromVector Vector a
vec = (Int -> a) -> MVector s Int -> MVector s Int -> MutList s a
forall s a.
(Int -> a) -> MVector s Int -> MVector s Int -> MutList s a
MutList (Vector a -> Int -> a
forall a. Vector a -> Int -> a
V.unsafeIndex Vector a
vec)
  (MVector s Int -> MVector s Int -> MutList s a)
-> ST s (MVector s Int) -> ST s (MVector s Int -> MutList s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    MVector s Int
arr <- Vector Int -> ST s (MVector (PrimState (ST s)) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
U.unsafeThaw (Int -> Int -> Vector Int
forall a. (Unbox a, Num a) => a -> Int -> Vector a
U.enumFromN Int
1 (Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
vec))
    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite MVector s Int
MVector (PrimState (ST s)) Int
arr (Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
vecInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
0
    MVector s Int -> ST s (MVector s Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s Int
arr
  ST s (MVector s Int -> MutList s a)
-> ST s (MVector s Int) -> ST s (MutList s a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> do
    MVector s Int
arr <- Vector Int -> ST s (MVector (PrimState (ST s)) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
U.unsafeThaw (Int -> Int -> Vector Int
forall a. (Unbox a, Num a) => a -> Int -> Vector a
U.enumFromN (-Int
1) (Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
vec))
    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite MVector s Int
MVector (PrimState (ST s)) Int
arr Int
0 (Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
vecInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    MVector s Int -> ST s (MVector s Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s Int
arr

mutListClone :: MutList s a -> ST s (MutList s a)
mutListClone :: MutList s a -> ST s (MutList s a)
mutListClone (MutList Int -> a
vec MVector s Int
nextVec MVector s Int
prevVec) = (Int -> a) -> MVector s Int -> MVector s Int -> MutList s a
forall s a.
(Int -> a) -> MVector s Int -> MVector s Int -> MutList s a
MutList Int -> a
vec
  (MVector s Int -> MVector s Int -> MutList s a)
-> ST s (MVector s Int) -> ST s (MVector s Int -> MutList s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Int
-> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> m (MVector (PrimState m) a)
MU.clone MVector s Int
MVector (PrimState (ST s)) Int
nextVec
  ST s (MVector s Int -> MutList s a)
-> ST s (MVector s Int) -> ST s (MutList s a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MVector (PrimState (ST s)) Int
-> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> m (MVector (PrimState m) a)
MU.clone MVector s Int
MVector (PrimState (ST s)) Int
prevVec

mutListNext :: MutList s a -> Int -> ST s Int
mutListNext :: MutList s a -> Int -> ST s Int
mutListNext MutList s a
m Int
idx = MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MU.unsafeRead (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListNextVec MutList s a
m) Int
idx

mutListPrev :: MutList s a -> Int -> ST s Int
mutListPrev :: MutList s a -> Int -> ST s Int
mutListPrev MutList s a
m Int
idx = MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MU.unsafeRead (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListPrevVec MutList s a
m) Int
idx

mutListDelete :: MutList s a -> Int -> Int -> ST s ()
mutListDelete :: MutList s a -> Int -> Int -> ST s ()
mutListDelete MutList s a
m Int
prev Int
next = do
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListNextVec MutList s a
m) Int
prev Int
next
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListPrevVec MutList s a
m) Int
next Int
prev

mutListDeleteFocus :: MutList s a -> Int -> ST s ()
mutListDeleteFocus :: MutList s a -> Int -> ST s ()
mutListDeleteFocus MutList s a
m Int
focus = do
  Int
prev <- MutList s a -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s a
m Int
focus
  Int
next <- MutList s a -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s a
m Int
focus
  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
prev Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListNextVec MutList s a
m) Int
prev Int
next
  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
next Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListPrevVec MutList s a
m) Int
next Int
prev

mutListInsert :: MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert :: MutList s a -> Int -> Int -> Int -> ST s ()
mutListInsert MutList s a
m Int
before Int
after Int
elt = do
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListNextVec MutList s a
m) Int
before Int
elt  -- before.next = elt
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListNextVec MutList s a
m) Int
elt Int
after   -- elt.next = after
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListPrevVec MutList s a
m) Int
after Int
elt   -- after.prev = elt
  MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.unsafeWrite (MutList s a -> MVector s Int
forall s a. MutList s a -> MVector s Int
mutListPrevVec MutList s a
m) Int
elt Int
before  -- elt.prev = before

mutListSort :: (Ord a, MU.Unbox a) => U.Vector a -> ST s (MutList s a)
mutListSort :: Vector a -> ST s (MutList s a)
mutListSort Vector a
vec = do
    Vector Int
sorted <- do
      MVector s Int
arr <- Vector Int -> ST s (MVector (PrimState (ST s)) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
U.unsafeThaw (Vector Int -> ST s (MVector (PrimState (ST s)) Int))
-> Vector Int -> ST s (MVector (PrimState (ST s)) Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Vector Int
forall a. (Unbox a, Num a) => a -> Int -> Vector a
U.enumFromN Int
0 Int
n :: U.Vector Int)
      Comparison Int -> MVector (PrimState (ST s)) Int -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> m ()
Algo.sortBy (\Int
a Int
b -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Vector a -> Int -> a
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector a
vec Int
a) (Vector a -> Int -> a
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector a
vec Int
b)) MVector s Int
MVector (PrimState (ST s)) Int
arr
      MVector (PrimState (ST s)) Int -> ST s (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
U.unsafeFreeze MVector s Int
MVector (PrimState (ST s)) Int
arr

    MVector s Int
next <- Int -> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
MU.new Int
n
    MVector s Int
prev <- Int -> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
MU.new Int
n
    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.write MVector s Int
MVector (PrimState (ST s)) Int
next
      (Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector Int
sorted (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
      (-Int
1)
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
      MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.write MVector s Int
MVector (PrimState (ST s)) Int
next
        (Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector Int
sorted Int
i)
        (Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector Int
sorted (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.write MVector s Int
MVector (PrimState (ST s)) Int
prev
      (Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector Int
sorted Int
0)
      (-Int
1)
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
      MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MU.write MVector s Int
MVector (PrimState (ST s)) Int
prev
        (Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector Int
sorted Int
i)
        (Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector Int
sorted (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
    MutList s a -> ST s (MutList s a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MutList s a -> ST s (MutList s a))
-> MutList s a -> ST s (MutList s a)
forall a b. (a -> b) -> a -> b
$ (Int -> a) -> MVector s Int -> MVector s Int -> MutList s a
forall s a.
(Int -> a) -> MVector s Int -> MVector s Int -> MutList s a
MutList (Vector a -> Int -> a
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector a
vec) MVector s Int
next MVector s Int
prev
  where
    n :: Int
n = Vector a -> Int
forall a. Unbox a => Vector a -> Int
U.length Vector a
vec

-------------------------------------------------------------------------------
-- Ear checking

-- O(n)
earCheck :: (Num r, Ord r) => MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s Bool
earCheck :: MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s Bool
earCheck MutList s (Point 2 r :+ p)
vertices Int
a Int
b Int
c = do
  let pointA :: Point 2 r :+ p
pointA = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
a
      pointB :: Point 2 r :+ p
pointB = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
b
      pointC :: Point 2 r :+ p
pointC = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
c
      trig :: Triangle 2 p r
trig = (Point 2 r :+ p)
-> (Point 2 r :+ p) -> (Point 2 r :+ p) -> Triangle 2 p r
forall (d :: Nat) p r.
(Point d r :+ p)
-> (Point d r :+ p) -> (Point d r :+ p) -> Triangle d p r
Triangle Point 2 r :+ p
pointA Point 2 r :+ p
pointB Point 2 r :+ p
pointC

  let loop :: Int -> ST s Bool
loop Int
elt | Int
elt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
a = Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      loop Int
elt = do
        let point :: Point 2 r
point = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
elt (Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
        case Point 2 r -> Triangle 2 p r -> PointLocationResult
forall r p.
(Ord r, Num r) =>
Point 2 r -> Triangle 2 p r -> PointLocationResult
inTriangleRelaxed Point 2 r
point Triangle 2 p r
trig of
          PointLocationResult
Outside -> Int -> ST s Bool
loop (Int -> ST s Bool) -> ST s Int -> ST s Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
vertices Int
elt
          PointLocationResult
_       -> Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  if (Point 2 r :+ p) -> (Point 2 r :+ p) -> (Point 2 r :+ p) -> CCW
forall r a b c.
(Ord r, Num r) =>
(Point 2 r :+ a) -> (Point 2 r :+ b) -> (Point 2 r :+ c) -> CCW
ccw' Point 2 r :+ p
pointA Point 2 r :+ p
pointB Point 2 r :+ p
pointC CCW -> CCW -> Bool
forall a. Eq a => a -> a -> Bool
== CCW
CCW
    then Int -> ST s Bool
loop (Int -> ST s Bool) -> ST s Int -> ST s Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MutList s (Point 2 r :+ p) -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s (Point 2 r :+ p)
vertices Int
c
    else Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- showBinary :: (Integral a, Show a) => a -> String
-- showBinary i = showIntAtBase 2 intToDigit i ""

earCheckHashed :: Real r => (Point 2 r -> Word) -> MutList s (Point 2 r :+ p) -> MutList s Word -> Int -> Int -> Int -> ST s Bool
earCheckHashed :: (Point 2 r -> Word)
-> MutList s (Point 2 r :+ p)
-> MutList s Word
-> Int
-> Int
-> Int
-> ST s Bool
earCheckHashed Point 2 r -> Word
hasher MutList s (Point 2 r :+ p)
vertices MutList s Word
zHashes Int
a Int
b Int
c = do
  let pointA :: Point 2 r :+ p
pointA = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
a
      pointB :: Point 2 r :+ p
pointB = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
b
      pointC :: Point 2 r :+ p
pointC = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
c
      trig :: Triangle 2 p r
trig = (Point 2 r :+ p)
-> (Point 2 r :+ p) -> (Point 2 r :+ p) -> Triangle 2 p r
forall (d :: Nat) p r.
(Point d r :+ p)
-> (Point d r :+ p) -> (Point d r :+ p) -> Triangle d p r
Triangle Point 2 r :+ p
pointA Point 2 r :+ p
pointB Point 2 r :+ p
pointC
      trigBB :: Box (Dimension (Triangle 2 p r)) () (NumType (Triangle 2 p r))
trigBB = Triangle 2 p r
-> Box (Dimension (Triangle 2 p r)) () (NumType (Triangle 2 p r))
forall g.
(IsBoxable g, Ord (NumType g)) =>
g -> Box (Dimension g) () (NumType g)
boundingBox Triangle 2 p r
trig
      lowPt :: Point 2 r
lowPt = Box 2 () r -> Point 2 r :+ ()
forall (d :: Nat) p r. Box d p r -> Point d r :+ p
minPoint Box 2 () r
Box (Dimension (Triangle 2 p r)) () (NumType (Triangle 2 p r))
trigBB (Point 2 r :+ ())
-> Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
      highPt :: Point 2 r
highPt = Box 2 () r -> Point 2 r :+ ()
forall (d :: Nat) p r. Box d p r -> Point d r :+ p
maxPoint Box 2 () r
Box (Dimension (Triangle 2 p r)) () (NumType (Triangle 2 p r))
trigBB (Point 2 r :+ ())
-> Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
      -- (lowPt, highPt) = triangleBoundingBox trig

      minZ :: Word
minZ = Point 2 r -> Word
hasher Point 2 r
lowPt
      maxZ :: Word
maxZ = Point 2 r -> Word
hasher Point 2 r
highPt

  let upwards :: Int -> ST s Bool
upwards Int
up
        | Int
up Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 Bool -> Bool -> Bool
|| Word
upZ Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
maxZ = Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        | Point 2 r -> Triangle 2 p r -> PointLocationResult
forall r p.
(Ord r, Num r) =>
Point 2 r -> Triangle 2 p r -> PointLocationResult
inTriangleRelaxed Point 2 r
pointUp Triangle 2 p r
trig PointLocationResult -> PointLocationResult -> Bool
forall a. Eq a => a -> a -> Bool
/= PointLocationResult
Outside = Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        | Bool
otherwise = Int -> ST s Bool
upwards (Int -> ST s Bool) -> ST s Int -> ST s Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MutList s Word -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s Word
zHashes Int
up
        where
          upZ :: Word
upZ = MutList s Word -> Int -> Word
forall s a. MutList s a -> Int -> a
mutListIndex MutList s Word
zHashes Int
up
          pointUp :: Point 2 r
pointUp = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
up (Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
      downwards :: Int -> ST s Bool
downwards Int
down
        | Int
down Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 Bool -> Bool -> Bool
|| Word
downZ Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
minZ = Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        | Point 2 r -> Triangle 2 p r -> PointLocationResult
forall r p.
(Ord r, Num r) =>
Point 2 r -> Triangle 2 p r -> PointLocationResult
inTriangleRelaxed Point 2 r
pointDown Triangle 2 p r
trig PointLocationResult -> PointLocationResult -> Bool
forall a. Eq a => a -> a -> Bool
/= PointLocationResult
Outside = Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        | Bool
otherwise = Int -> ST s Bool
downwards (Int -> ST s Bool) -> ST s Int -> ST s Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MutList s Word -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s Word
zHashes Int
down
        where
          downZ :: Word
downZ = MutList s Word -> Int -> Word
forall s a. MutList s a -> Int -> a
mutListIndex MutList s Word
zHashes Int
down
          pointDown :: Point 2 r
pointDown = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
down (Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
      bidirectional :: Int -> Int -> ST s Bool
bidirectional Int
up Int
down
        | Int
up Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1   Bool -> Bool -> Bool
|| Word
upZ Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
maxZ   = Int -> ST s Bool
downwards Int
down
        | Int
down Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 Bool -> Bool -> Bool
|| Word
downZ Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
minZ = Int -> ST s Bool
upwards Int
up
        | Int
up Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
a Bool -> Bool -> Bool
&& Int
up Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
b Bool -> Bool -> Bool
&& Point 2 r -> Triangle 2 p r -> PointLocationResult
forall r p.
(Ord r, Num r) =>
Point 2 r -> Triangle 2 p r -> PointLocationResult
inTriangleRelaxed Point 2 r
pointUp Triangle 2 p r
trig PointLocationResult -> PointLocationResult -> Bool
forall a. Eq a => a -> a -> Bool
/= PointLocationResult
Outside = Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        | Int
down Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
a Bool -> Bool -> Bool
&& Int
down Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
b Bool -> Bool -> Bool
&& Point 2 r -> Triangle 2 p r -> PointLocationResult
forall r p.
(Ord r, Num r) =>
Point 2 r -> Triangle 2 p r -> PointLocationResult
inTriangleRelaxed Point 2 r
pointDown Triangle 2 p r
trig PointLocationResult -> PointLocationResult -> Bool
forall a. Eq a => a -> a -> Bool
/= PointLocationResult
Outside = Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        | Bool
otherwise = do
          Int
up' <- MutList s Word -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListNext MutList s Word
zHashes Int
up
          Int
down' <- MutList s Word -> Int -> ST s Int
forall s a. MutList s a -> Int -> ST s Int
mutListPrev MutList s Word
zHashes Int
down
          Int -> Int -> ST s Bool
bidirectional Int
up' Int
down'
        where
          upZ :: Word
upZ = MutList s Word -> Int -> Word
forall s a. MutList s a -> Int -> a
mutListIndex MutList s Word
zHashes Int
up
          downZ :: Word
downZ = MutList s Word -> Int -> Word
forall s a. MutList s a -> Int -> a
mutListIndex MutList s Word
zHashes Int
down
          pointUp :: Point 2 r
pointUp = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
up (Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
          pointDown :: Point 2 r
pointDown = MutList s (Point 2 r :+ p) -> Int -> Point 2 r :+ p
forall s a. MutList s a -> Int -> a
mutListIndex MutList s (Point 2 r :+ p)
vertices Int
down (Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
  if (Point 2 r :+ p) -> (Point 2 r :+ p) -> (Point 2 r :+ p) -> CCW
forall r a b c.
(Ord r, Num r) =>
(Point 2 r :+ a) -> (Point 2 r :+ b) -> (Point 2 r :+ c) -> CCW
ccw' Point 2 r :+ p
pointA Point 2 r :+ p
pointB Point 2 r :+ p
pointC CCW -> CCW -> Bool
forall a. Eq a => a -> a -> Bool
== CCW
CCW
    then Int -> Int -> ST s Bool
bidirectional Int
b Int
b
    else Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False