HALFEDGE: use Data.IntMap instead of Array

This commit is contained in:
hasufell 2015-02-09 16:14:01 +01:00
parent c22c00cb2d
commit 0151df162c
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020

View File

@ -24,11 +24,9 @@ module Graphics.HalfEdge (
) where ) where
import Algebra.Vector import Algebra.Vector
import Control.Monad.ST
import Data.Array.Unboxed
import Data.Array.ST
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Functor import Data.Functor
import qualified Data.IntMap.Lazy as Map
import Parser.Meshparser import Parser.Meshparser
import Safe import Safe
@ -115,22 +113,20 @@ indirectHeEdges = concat . fmap indirectHeEdge
-- |Construct the indirect data structure for half-edge vertices. -- |Construct the indirect data structure for half-edge vertices.
-- It is assumed that the list of points is indexed in order of their -- It is assumed that the list of points is indexed in order of their
-- appearance in the obj mesh file. -- appearance in the obj mesh file.
indirectHeVerts :: [a] -- ^ list of points indirectHeVerts :: [IndirectHeEdge] -- ^ list of indirect edges
-> [IndirectHeEdge] -- ^ list of indirect edges -> Map.IntMap IndirectHeVert -- ^ output map, starts at index 1
-> Array Int IndirectHeVert -- ^ output list, starts at index 1 indirectHeVerts hes' = go hes' Map.empty 0
indirectHeVerts pts hes' where
= runSTArray $ do go [] map' _ = map'
arr <- newArray (1, length pts) (IndirectHeVert 0 []) go (IndirectHeEdge _ _ nv _ offset:hes) map' i
:: ST s (STArray s Int IndirectHeVert) = go hes
-- build the array (Map.alter updateMap nv map')
let go [] _ = return () (i + 1)
go (IndirectHeEdge _ _ nv _ offset:hes) i where
= do updateMap (Just (IndirectHeVert _ xs))
(IndirectHeVert _ xs) <- readArray arr nv = Just (IndirectHeVert (i + offset) (i:xs))
writeArray arr nv (IndirectHeVert (i + offset) (i:xs)) updateMap Nothing
go hes (i + 1) = Just (IndirectHeVert (i + offset) [i])
go hes' 0
return arr
-- |Tie the knots! -- |Tie the knots!
@ -140,13 +136,13 @@ indirectHeVerts pts hes'
indirectToDirect :: [a] -- ^ list of points indirectToDirect :: [a] -- ^ list of points
-> [IndirectHeEdge] -> [IndirectHeEdge]
-> [IndirectHeFace] -> [IndirectHeFace]
-> Array Int IndirectHeVert -- ^ assumed to start at index 1 -> Map.IntMap IndirectHeVert -- ^ assumed to start at index 1
-> HeEdge a -> HeEdge a
indirectToDirect pts pe@(e:_) fs vertarr indirectToDirect pts pe@(e:_) fs vertarr
= thisEdge e = thisEdge e
where where
thisEdge (IndirectHeEdge ei sv _ fi off) thisEdge (IndirectHeEdge ei sv _ fi off)
= HeEdge (thisVert (vertarr ! sv) sv) = HeEdge (thisVert (vertarr Map.! sv) sv)
(getOppEdge sv fi) (getOppEdge sv fi)
(thisFace (fs !! fi)) (thisFace (fs !! fi))
(thisEdge . (!!) pe $ (ei + off)) (thisEdge . (!!) pe $ (ei + off))
@ -161,7 +157,7 @@ indirectToDirect pts pe@(e:_) fs vertarr
(headMay (headMay
. filter (\x -> (/=) fi . indexf $ (pe !! x)) . filter (\x -> (/=) fi . indexf $ (pe !! x))
. edgelist . edgelist
$ (vertarr ! sv)) $ (vertarr Map.! sv))
-- |Build the half-edge data structure from a list of points -- |Build the half-edge data structure from a list of points
@ -185,7 +181,7 @@ buildHeEdge _ [] = Nothing
buildHeEdge pts fs buildHeEdge pts fs
= let faces' = indirectHeFaces fs = let faces' = indirectHeFaces fs
edges' = indirectHeEdges faces' edges' = indirectHeEdges faces'
verts' = indirectHeVerts pts edges' verts' = indirectHeVerts edges'
in Just $ indirectToDirect pts edges' faces' verts' in Just $ indirectToDirect pts edges' faces' verts'
@ -196,6 +192,6 @@ buildHeEdgeFromStr bmesh =
let pts = meshVertices bmesh let pts = meshVertices bmesh
faces' = indirectHeFaces . meshFaces $ bmesh faces' = indirectHeFaces . meshFaces $ bmesh
edges = indirectHeEdges faces' edges = indirectHeEdges faces'
verts = indirectHeVerts pts edges verts = indirectHeVerts edges
in indirectToDirect pts edges faces' verts in indirectToDirect pts edges faces' verts