243 lines
8.3 KiB
Haskell
243 lines
8.3 KiB
Haskell
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
|
|
-- |This module provides methods to build a cyclic half-edge data structure
|
|
-- from an already parsed obj mesh file. As such, it depends on details
|
|
-- of the parsed data.
|
|
--
|
|
-- In particular, 'indirectHeFaces', 'indirectHeVerts' and 'indirectToDirect'
|
|
-- assume specific structure of some input lists. Check their respective
|
|
-- documentation.
|
|
--
|
|
-- As the data structure has a lot of cross-references and the knots are
|
|
-- not really known at compile-time, we have to use helper data structures
|
|
-- such as lists and maps under the hood and tie the knots through
|
|
-- index lookups.
|
|
--
|
|
-- For an explanation of the abstract concept of the half-edge data structure,
|
|
-- check <http://www.flipcode.com/archives/The_Half-Edge_Data_Structure.shtml>
|
|
module Graphics.HalfEdge (
|
|
HeVert(..)
|
|
, HeFace(..)
|
|
, HeEdge(..)
|
|
, buildHeEdge
|
|
, buildHeEdgeFromStr
|
|
) where
|
|
|
|
import Algebra.Vector
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import qualified Data.ByteString.Char8 as B
|
|
import qualified Data.IntMap.Lazy as Map
|
|
import Data.Maybe
|
|
import Diagrams.TwoD.Types
|
|
import Parser.Meshparser
|
|
import Safe
|
|
|
|
|
|
-- |The vertex data structure for the half-edge.
|
|
data HeVert a = HeVert {
|
|
vcoord :: a -- the coordinates of the vertex
|
|
, emedge :: HeEdge a -- one of the half-edges emanating from the vertex
|
|
} | NoVert
|
|
|
|
|
|
-- |The face data structure for the half-edge.
|
|
data HeFace a = HeFace {
|
|
bordedge :: HeEdge a -- one of the half-edges bordering the face
|
|
} | NoFace
|
|
|
|
-- |The actual half-edge data structure.
|
|
data HeEdge a = HeEdge {
|
|
startvert :: HeVert a -- start-vertex of the half-edge
|
|
, oppedge :: HeEdge a -- oppositely oriented adjacent half-edge
|
|
, edgeface :: HeFace a -- face the half-edge borders
|
|
, nextedge :: HeEdge a -- next half-edge around the face
|
|
} | NoEdge
|
|
|
|
-- This is a helper data structure of half-edge edges
|
|
-- for tying the knots in 'indirectToDirect'.
|
|
data IndirectHeEdge = IndirectHeEdge {
|
|
edgeindex :: Int -- edge index
|
|
, svindex :: Int -- index of start-vertice
|
|
, nvindex :: Int -- index of next-vertice
|
|
, indexf :: Int -- index of face
|
|
, offsetedge :: Int -- offset to get the next edge
|
|
} deriving (Show)
|
|
|
|
-- This is a helper data structure of half-edge vertices
|
|
-- for tying the knots in 'indirectToDirect'.
|
|
data IndirectHeVert = IndirectHeVert {
|
|
emedgeindex :: Int -- emanating edge index (starts at 1)
|
|
, edgelist :: [Int] -- index of edge that points to this vertice
|
|
} deriving (Show)
|
|
|
|
-- This is a helper data structure of half-edge faces
|
|
-- for tying the knots in 'indirectToDirect'.
|
|
data IndirectHeFace =
|
|
IndirectHeFace (Int, [Int]) -- (faceIndex, [verticeindex])
|
|
deriving (Show)
|
|
|
|
|
|
-- |Construct the indirect data structure for half-edge faces.
|
|
-- This function assumes that the input faces are parsed exactly like so:
|
|
--
|
|
-- @
|
|
-- f 1 3 4 5
|
|
-- f 4 6 1 3
|
|
-- @
|
|
--
|
|
-- becomes
|
|
--
|
|
-- > [[1,3,4,5],[4,6,1,3]]
|
|
indirectHeFaces :: [[Int]] -- ^ list of faces with their respective
|
|
-- list of vertice-indices
|
|
-> [IndirectHeFace]
|
|
indirectHeFaces = fmap IndirectHeFace . zip [0..]
|
|
|
|
|
|
-- |Construct the indirect data structure for half-edge edges.
|
|
indirectHeEdges :: [IndirectHeFace] -> [IndirectHeEdge]
|
|
indirectHeEdges = concat . fmap indirectHeEdge
|
|
where
|
|
indirectHeEdge :: IndirectHeFace -> [IndirectHeEdge]
|
|
indirectHeEdge (IndirectHeFace (_, [])) = []
|
|
indirectHeEdge p@(IndirectHeFace (_, pv@(v:_))) = go p 0
|
|
where
|
|
go (IndirectHeFace (_, [])) _
|
|
= []
|
|
-- connect last to first element
|
|
go (IndirectHeFace (fi, [vlast])) ei
|
|
= [IndirectHeEdge ei vlast v fi (negate $ length pv - 1)]
|
|
-- regular non-last element
|
|
go (IndirectHeFace (fi, vfirst:vnext:vrest)) ei
|
|
= (:) (IndirectHeEdge ei vfirst vnext fi 1)
|
|
(go (IndirectHeFace (fi, vnext:vrest)) (ei + 1))
|
|
|
|
|
|
-- |Construct the indirect data structure for half-edge vertices.
|
|
-- It is assumed that the list of points is indexed in order of their
|
|
-- appearance in the obj mesh file.
|
|
indirectHeVerts :: [IndirectHeEdge] -- ^ list of indirect edges
|
|
-> Map.IntMap IndirectHeVert -- ^ output map, starts at index 1
|
|
indirectHeVerts hes' = go hes' Map.empty 0
|
|
where
|
|
go [] map' _ = map'
|
|
go (IndirectHeEdge _ _ nv _ offset:hes) map' i
|
|
= go hes
|
|
(Map.alter updateMap nv map')
|
|
(i + 1)
|
|
where
|
|
updateMap (Just (IndirectHeVert _ xs))
|
|
= Just (IndirectHeVert (i + offset) (i:xs))
|
|
updateMap Nothing
|
|
= Just (IndirectHeVert (i + offset) [i])
|
|
|
|
|
|
-- |Tie the knots!
|
|
-- It is assumed that the list of points is indexed in order of their
|
|
-- appearance in the obj mesh file.
|
|
--
|
|
-- pseudo-code:
|
|
--
|
|
-- @
|
|
-- indirectToDirect :: [a] -- parsed vertices, e.g. 2d points (Double, Double)
|
|
-- -> [IndirectHeEdge]
|
|
-- -> [IndirectHeFace]
|
|
-- -> [IndirectHeVert]
|
|
-- -> HeEdge a
|
|
-- indirectToDirect points edges faces vertices
|
|
-- = thisEdge (head edges)
|
|
-- where
|
|
-- thisEdge edge
|
|
-- = HeEdge (thisVert (vertices !! svindex edge) $ svindex edge)
|
|
-- (thisOppEdge (svindex edge) $ indexf edge)
|
|
-- (thisFace $ faces !! indexf edge)
|
|
-- (thisEdge $ edges !! (edgeindex edge + offsetedge edge))
|
|
-- thisFace face = HeFace $ thisEdge (edges !! (head . snd $ face))
|
|
-- thisVert vertice coordindex
|
|
-- = HeVert (points !! (coordindex - 1))
|
|
-- (thisEdge $ points !! (emedgeindex vertice - 1))
|
|
-- thisOppEdge startverticeindex faceindex
|
|
-- = case headMay
|
|
-- . filter ((/=) faceindex . indexf)
|
|
-- . fmap (edges !!)
|
|
-- . edgelist -- getter
|
|
-- $ vertices !! startverticeindex
|
|
-- of Just x -> thisEdge x
|
|
-- Nothing -> NoEdge
|
|
-- @
|
|
indirectToDirect :: [a] -- ^ list of points
|
|
-> [IndirectHeEdge]
|
|
-> [IndirectHeFace]
|
|
-> Map.IntMap IndirectHeVert -- ^ assumed to start at index 1
|
|
-> HeEdge a
|
|
indirectToDirect pts pe@(e:_) fs vertmap
|
|
= thisEdge e
|
|
where
|
|
thisEdge (IndirectHeEdge ei sv _ fi off)
|
|
= case (fs `atMay` fi, pe `atMay` (ei + off), Map.lookup sv vertmap) of
|
|
(Just face,
|
|
Just edge,
|
|
Just vert) -> HeEdge (thisVert vert sv)
|
|
(getOppEdge sv fi)
|
|
(thisFace face)
|
|
(thisEdge edge)
|
|
_ -> NoEdge
|
|
thisFace (IndirectHeFace (_, vi:_))
|
|
= case pe `atMay` vi of
|
|
Just edge -> HeFace (thisEdge edge)
|
|
Nothing -> NoFace
|
|
thisFace (IndirectHeFace _) = NoFace
|
|
thisVert (IndirectHeVert eedg _) coordi
|
|
= case (pts `atMay` (coordi - 1), pe `atMay` (eedg - 1)) of
|
|
(Just vert, Just edge) -> HeVert vert $ thisEdge edge
|
|
_ -> NoVert
|
|
getOppEdge sv fi
|
|
= case join
|
|
$ headMay
|
|
. filter ((/=) fi . indexf)
|
|
. catMaybes
|
|
. fmap (pe `atMay`)
|
|
. edgelist
|
|
<$> Map.lookup sv vertmap
|
|
of Just x -> thisEdge x
|
|
Nothing -> NoEdge
|
|
indirectToDirect _ _ _ _ = NoEdge
|
|
|
|
|
|
-- |Build the half-edge data structure from a list of points
|
|
-- and from a list of faces.
|
|
-- The points are assumed to have been parsed in order of their appearance
|
|
-- in the .obj mesh file, so that the indices match.
|
|
-- The faces are assumed to have been parsed in order of their appearance
|
|
-- in the .obj mesh file as follows:
|
|
--
|
|
-- @
|
|
-- f 1 3 4 5
|
|
-- f 4 6 1 3
|
|
-- @
|
|
--
|
|
-- becomes
|
|
--
|
|
-- > [[1,3,4,5],[4,6,1,3]]
|
|
buildHeEdge :: [a] -> [[Int]] -> Maybe (HeEdge a)
|
|
buildHeEdge [] _ = Nothing
|
|
buildHeEdge _ [] = Nothing
|
|
buildHeEdge pts fs
|
|
= let faces' = indirectHeFaces fs
|
|
edges' = indirectHeEdges faces'
|
|
verts' = indirectHeVerts edges'
|
|
in Just $ indirectToDirect pts edges' faces' verts'
|
|
|
|
|
|
-- |Build the HeEdge data structure from the .obj mesh file contents.
|
|
buildHeEdgeFromStr :: B.ByteString -- ^ contents of an .obj mesh file
|
|
-> HeEdge (P2 Double)
|
|
buildHeEdgeFromStr bmesh =
|
|
let pts = meshToArr bmesh
|
|
faces' = indirectHeFaces . facesToArr $ bmesh
|
|
edges = indirectHeEdges faces'
|
|
verts = indirectHeVerts edges
|
|
in indirectToDirect pts edges faces' verts
|
|
|