hasufell
/
cga
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

HALFEDGE: improve readability

This commit is contained in:
hasufell 2015-02-09 18:36:43 +01:00
parent d45412ca3c
commit e010c03398
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
1 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
Graphics/HalfEdge.hs
View File

@ -166,25 +166,27 @@ indirectToDirect :: [a] -- ^ list of points
-> [IndirectHeFace] -> [IndirectHeFace]
-> Map.IntMap 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 vertmap
= thisEdge e = thisEdge e
where where
thisEdge (IndirectHeEdge ei sv _ fi off) thisEdge (IndirectHeEdge ei sv _ fi off)
= case (fs `atMay` fi, pe `atMay` (ei + off), Map.lookup sv vertarr) of = case (fs `atMay` fi, pe `atMay` (ei + off), Map.lookup sv vertmap) of
(Just x, Just y, Just z) -> HeEdge (thisVert z sv) (Just face,
(getOppEdge sv fi) Just edge,
(thisFace x) Just vert) -> HeEdge (thisVert vert sv)
(thisEdge y) (getOppEdge sv fi)
_ -> NoEdge (thisFace face)
(thisEdge edge)
_ -> NoEdge
thisFace (IndirectHeFace (_, vi:_)) thisFace (IndirectHeFace (_, vi:_))
= case pe `atMay` vi of = case pe `atMay` vi of
Just x -> HeFace (thisEdge x) Just edge -> HeFace (thisEdge edge)
Nothing -> NoFace Nothing -> NoFace
thisFace (IndirectHeFace _) = NoFace thisFace (IndirectHeFace _) = NoFace
thisVert (IndirectHeVert eedg _) coordi thisVert (IndirectHeVert eedg _) coordi
= case (pts `atMay` (coordi - 1), pe `atMay` (eedg - 1)) of = case (pts `atMay` (coordi - 1), pe `atMay` (eedg - 1)) of
(Just x, Just y) -> HeVert x (thisEdge y) (Just vert, Just edge) -> HeVert vert $ thisEdge edge
_ -> NoVert _ -> NoVert
getOppEdge sv fi getOppEdge sv fi
= case join = case join
$ headMay $ headMay
@ -192,9 +194,9 @@ indirectToDirect pts pe@(e:_) fs vertarr
. catMaybes . catMaybes
. fmap (pe `atMay`) . fmap (pe `atMay`)
. edgelist . edgelist
<$> Map.lookup sv vertarr of <$> Map.lookup sv vertmap
Just x -> thisEdge x of Just x -> thisEdge x
Nothing -> NoEdge Nothing -> NoEdge
indirectToDirect _ _ _ _ = NoEdge indirectToDirect _ _ _ _ = NoEdge