{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
module Reanimate.Math.Triangulate
  ( Triangulation
  , edgesToTriangulation
  , edgesToTriangulationM
  , trianglesToTriangulation
  , trianglesToTriangulationM
  , triangulate
  )
where

#if NO_HGEOMETRY

import qualified Data.Vector                                          as V
import           Control.Monad.ST
import           Reanimate.Math.Common

type Triangulation = V.Vector [Int]

edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
edgesToTriangulation = error "no hgeometry"

edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (V.MVector s [Int])
edgesToTriangulationM = error "no hgeometry"

trianglesToTriangulation :: Int -> V.Vector (Int, Int, Int) -> Triangulation
trianglesToTriangulation = error "no hgeometry"

trianglesToTriangulationM
  :: Int -> V.Vector (Int, Int, Int) -> ST s (V.MVector s [Int])
trianglesToTriangulationM = error "no hgeometry"

triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation
triangulate = error "no hgeometry"

#else

import           Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
import           Algorithms.Geometry.PolygonTriangulation.Types
import           Control.Lens
import           Control.Monad
import           Control.Monad.ST
import           Data.Ext
import           Data.Geometry.PlanarSubdivision                      (PolygonFaceData)
import           Data.Geometry.Point
import           Data.Geometry.Polygon                                (SimplePolygon, fromPoints)
import qualified Data.IntSet                                          as ISet
import qualified Data.PlaneGraph as Geo
import           Data.Proxy
import qualified Data.Vector                                          as V
import qualified Data.Vector.Mutable                                  as MV
import           Linear.V2
import           Reanimate.Math.Common
-- Max edges: n-2
-- Each edge is represented twice: 2n-4
-- Flat structure:
--   edges   :: V.Vector Int -- max length (2n-4)
--   offsets :: V.Vector Int -- length n
-- Combine the two vectors? < n => offsets, >= n => edges?
type Triangulation = V.Vector [Int]

-- FIXME: Move to Common or a Triangulation module
-- O(n)
edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
edgesToTriangulation Int
size [(Int, Int)]
edges = (forall s. ST s Triangulation) -> Triangulation
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Triangulation) -> Triangulation)
-> (forall s. ST s Triangulation) -> Triangulation
forall a b. (a -> b) -> a -> b
$ do
  MVector s [Int]
v <- Int -> [(Int, Int)] -> ST s (MVector s [Int])
forall s. Int -> [(Int, Int)] -> ST s (MVector s [Int])
edgesToTriangulationM Int
size [(Int, Int)]
edges
  MVector (PrimState (ST s)) [Int] -> ST s Triangulation
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s [Int]
MVector (PrimState (ST s)) [Int]
v

edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (V.MVector s [Int])
edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (MVector s [Int])
edgesToTriangulationM Int
size [(Int, Int)]
edges = do
  MVector s [Int]
v <- Int -> [Int] -> ST s (MVector (PrimState (ST s)) [Int])
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate Int
size []
  [(Int, Int)] -> ((Int, Int) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Int)]
edges (((Int, Int) -> ST s ()) -> ST s ())
-> ((Int, Int) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Int
e1, Int
e2) -> do
    MVector (PrimState (ST s)) [Int]
-> ([Int] -> [Int]) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s [Int]
MVector (PrimState (ST s)) [Int]
v (Int
e1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) Int
e2
    MVector (PrimState (ST s)) [Int]
-> ([Int] -> [Int]) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s [Int]
MVector (PrimState (ST s)) [Int]
v (Int
e2 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) Int
e1
  [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
size Int -> 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 -> MVector (PrimState (ST s)) [Int]
-> ([Int] -> [Int]) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s [Int]
MVector (PrimState (ST s)) [Int]
v (IntSet -> [Int]
ISet.toList (IntSet -> [Int]) -> ([Int] -> IntSet) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IntSet
ISet.fromList) Int
i
  MVector s [Int] -> ST s (MVector s [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s [Int]
v

trianglesToTriangulation :: Int -> V.Vector (Int, Int, Int) -> Triangulation
trianglesToTriangulation :: Int -> Vector (Int, Int, Int) -> Triangulation
trianglesToTriangulation Int
size Vector (Int, Int, Int)
edges = (forall s. ST s Triangulation) -> Triangulation
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Triangulation) -> Triangulation)
-> (forall s. ST s Triangulation) -> Triangulation
forall a b. (a -> b) -> a -> b
$ do
  MVector s [Int]
v <- Int -> Vector (Int, Int, Int) -> ST s (MVector s [Int])
forall s. Int -> Vector (Int, Int, Int) -> ST s (MVector s [Int])
trianglesToTriangulationM Int
size Vector (Int, Int, Int)
edges
  MVector (PrimState (ST s)) [Int] -> ST s Triangulation
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s [Int]
MVector (PrimState (ST s)) [Int]
v

trianglesToTriangulationM
  :: Int -> V.Vector (Int, Int, Int) -> ST s (V.MVector s [Int])
trianglesToTriangulationM :: Int -> Vector (Int, Int, Int) -> ST s (MVector s [Int])
trianglesToTriangulationM Int
size Vector (Int, Int, Int)
trigs = do
  MVector s [Int]
v <- Int -> [Int] -> ST s (MVector (PrimState (ST s)) [Int])
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate Int
size []
  [(Int, Int, Int)] -> ((Int, Int, Int) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Vector (Int, Int, Int) -> [(Int, Int, Int)]
forall a. Vector a -> [a]
V.toList Vector (Int, Int, Int)
trigs) (((Int, Int, Int) -> ST s ()) -> ST s ())
-> ((Int, Int, Int) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Int
a, Int
b, Int
c) -> do
    MVector (PrimState (ST s)) [Int]
-> ([Int] -> [Int]) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s [Int]
MVector (PrimState (ST s)) [Int]
v (\[Int]
x -> Int
b Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
c Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
x) Int
a
    MVector (PrimState (ST s)) [Int]
-> ([Int] -> [Int]) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s [Int]
MVector (PrimState (ST s)) [Int]
v (\[Int]
x -> Int
a Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
c Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
x) Int
b
    MVector (PrimState (ST s)) [Int]
-> ([Int] -> [Int]) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s [Int]
MVector (PrimState (ST s)) [Int]
v (\[Int]
x -> Int
a Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
b Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
x) Int
c
  [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
size Int -> 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 -> MVector (PrimState (ST s)) [Int]
-> ([Int] -> [Int]) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s [Int]
MVector (PrimState (ST s)) [Int]
v (IntSet -> [Int]
ISet.toList (IntSet -> [Int]) -> ([Int] -> IntSet) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IntSet
ISet.fromList) Int
i
  MVector s [Int] -> ST s (MVector s [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s [Int]
v


triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation
triangulate :: Ring a -> Triangulation
triangulate Ring a
r = Int -> [(Int, Int)] -> Triangulation
edgesToTriangulation (Ring a -> Int
forall a. Ring a -> Int
ringSize Ring a
r) [(Int, Int)]
ds
  where
    ds :: [(Int,Int)]
    ds :: [(Int, Int)]
ds =
      [ (VertexData a Int
aVertexData a Int -> Getting Int (VertexData a Int) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (VertexData a Int) Int
forall r v1 v2. Lens (VertexData r v1) (VertexData r v2) v1 v2
Geo.vData, VertexData a Int
bVertexData a Int -> Getting Int (VertexData a Int) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (VertexData a Int) Int
forall r v1 v2. Lens (VertexData r v1) (VertexData r v2) v1 v2
Geo.vData)
      | (Dart ()
d, PolygonEdgeType
Diagonal) <- Vector (Dart (), PolygonEdgeType) -> [(Dart (), PolygonEdgeType)]
forall a. Vector a -> [a]
V.toList (PlaneGraph () Int PolygonEdgeType PolygonFaceData a
-> Vector (Dart (), PolygonEdgeType)
forall k (s :: k) v e f r.
PlaneGraph s v e f r -> Vector (Dart s, e)
Geo.edges PlaneGraph () Int PolygonEdgeType PolygonFaceData a
pg)
      , let (VertexData a Int
a,VertexData a Int
b) = Dart ()
-> PlaneGraph () Int PolygonEdgeType PolygonFaceData a
-> (VertexData a Int, VertexData a Int)
forall k (s :: k) v e f r.
Dart s -> PlaneGraph s v e f r -> (VertexData r v, VertexData r v)
Geo.endPointData Dart ()
d PlaneGraph () Int PolygonEdgeType PolygonFaceData a
pg ]
    pg :: Geo.PlaneGraph () Int PolygonEdgeType PolygonFaceData a
    pg :: PlaneGraph () Int PolygonEdgeType PolygonFaceData a
pg = Proxy ()
-> Polygon 'Simple Int a
-> PlaneGraph () Int PolygonEdgeType PolygonFaceData a
forall k r (proxy :: k -> *) (s :: k) (t :: PolygonType) p.
(Ord r, Fractional r) =>
proxy s
-> Polygon t p r
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
triangulate' Proxy ()
forall k (t :: k). Proxy t
Proxy Polygon 'Simple Int a
p
    p :: SimplePolygon Int a
    p :: Polygon 'Simple Int a
p = [Point 2 a :+ Int] -> Polygon 'Simple Int a
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 a :+ Int] -> Polygon 'Simple Int a)
-> [Point 2 a :+ Int] -> Polygon 'Simple Int a
forall a b. (a -> b) -> a -> b
$
      [ a -> a -> Point 2 a
forall r. r -> r -> Point 2 r
Point2 a
x a
y Point 2 a -> Int -> Point 2 a :+ Int
forall core extra. core -> extra -> core :+ extra
:+ Int
n
      | (Int
n,V2 a
x a
y) <- [Int] -> [V2 a] -> [(Int, V2 a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (Vector (V2 a) -> [V2 a]
forall a. Vector a -> [a]
V.toList (Ring a -> Vector (V2 a)
forall a. Ring a -> Vector (V2 a)
ringUnpack Ring a
r)) ]
    -- ringUnpack

#endif