module Algorithms.Geometry.DelaunayTriangulation.Types where
import Control.Lens
import qualified Data.CircularList as C
import Data.Ext
import Data.Geometry
import Data.Geometry.Ipe
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified Data.Map.Strict as SM
import Data.Monoid (mempty)
import qualified Data.Permutation as P
import Data.PlaneGraph
import qualified Data.Vector as V
import Debug.Trace
type VertexID = Int
type Vertex = C.CList VertexID
type Adj = IM.IntMap (C.CList VertexID)
data Triangulation p r = Triangulation { _vertexIds :: M.Map (Point 2 r) VertexID
, _positions :: V.Vector (Point 2 r :+ p)
, _neighbours :: V.Vector (C.CList VertexID)
}
deriving (Show,Eq)
makeLenses ''Triangulation
type Mapping p r = (M.Map (Point 2 r) VertexID, V.Vector (Point 2 r :+ p))
showDT :: (Show p, Show r) => Triangulation p r -> IO ()
showDT = mapM_ print . triangulationEdges
triangulationEdges :: Triangulation p r -> [(Point 2 r :+ p, Point 2 r :+ p)]
triangulationEdges t = let pts = _positions t
in map (\(u,v) -> (pts V.! u, pts V.! v)) . tEdges $ t
tEdges :: Triangulation p r -> [(VertexID,VertexID)]
tEdges = concatMap (\(i,ns) -> map (i,) . filter (> i) . C.toList $ ns)
. zip [0..] . V.toList . _neighbours
drawTriangulation :: IpeOut (Triangulation p r) (IpeObject r)
drawTriangulation = IpeOut $ \tr ->
let es = map (uncurry ClosedLineSegment) . triangulationEdges $ tr
in asIpeGroup $ map (\e -> asIpeObjectWith ipeLineSegment e mempty) es
data ST a b c = ST { fst' :: !a, snd' :: !b , trd' :: !c}
type ArcID = Int
type ST' a = ST (SM.Map (VertexID,VertexID) ArcID) ArcID a
toPlaneGraph :: forall proxy s p r.
proxy s -> Triangulation p r -> PlaneGraph s Primal_ p () () r
toPlaneGraph _ tr = (planarGraph . P.toCycleRep n $ perm)&vertexData .~ tr^.positions
where
neighs = C.rightElements <$> tr^.neighbours
n = sum . fmap length $ neighs
vtxIDs = [0..]
perm = trd' . foldr toOrbit (ST mempty 0 mempty) $ zip vtxIDs (V.toList neighs)
toOrbit :: (VertexID,[VertexID]) -> ST' [[Dart s]]
-> ST' [[Dart s]]
toOrbit (u,vs) (ST m a dss) =
let (ST m' a' ds') = foldr (toDart . (u,)) (ST m a mempty) vs
in ST m' a' (ds':dss)
toDart :: (VertexID,VertexID) -> ST' [Dart s] -> ST' [Dart s]
toDart (u,v) (ST m a ds) = let dir = if u < v then Positive else Negative
t' = (min u v, max u v)
in case M.lookup t' m of
Just a' -> ST m a (Dart (Arc a') dir : ds)
Nothing -> ST (SM.insert t' a m) (a+1) (Dart (Arc a) dir : ds)