{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
module Tgraph.Prelude
( module HalfTile
, module Tgraph.Try
, Tgraph
, TileFace
, Vertex
, VertexSet
, VertexMap
, Dedge
, EdgeType(..)
, makeUncheckedTgraph
, checkedTgraph
, tryTgraphProps
, tryConnectedNoCross
, hasEdgeLoops
, duplicates
, edgeType
, noNewConflict
, illegalTiling
, crossingVertices
, crossingBoundaries
, connected
, faces
, emptyTgraph
, nullGraph
, maxV
, ldarts
, rdarts
, lkites
, rkites
, kites
, darts
, selectFaces
, removeFaces
, removeVertices
, selectVertices
, vertexSet
, graphDedges
, graphEdges
, internalEdges
, graphBoundary
, phiEdges
, nonPhiEdges
, graphEFMap
, defaultAlignment
, faceVs
, faceVList
, faceVSet
, facesVSet
, facesMaxV
, firstV
, secondV
, thirdV
, originV
, wingV
, oppV
, indexV
, nextV
, prevV
, isAtV
, hasVIn
, faceDedges
, facesDedges
, reverseD
, joinE
, shortE
, longE
, joinOfTile
, facePhiEdges
, faceNonPhiEdges
, matchingLongE
, matchingShortE
, matchingJoinE
, hasDedge
, hasDedgeIn
, facesEdges
, facesBoundary
, edgeNb
, vertexFacesMap
, dedgesFacesMap
, buildEFMap
, faceForEdge
, edgeNbs
, lowestJoin
, VPatch(..)
, VertexLocMap
, makeVP
, subVP
, relevantVP
, restrictVP
, graphFromVP
, removeFacesVP
, selectFacesVP
, findLoc
, DrawableLabelled(..)
, labelSize
, labelled
, rotateBefore
, dropLabels
, centerOn
, alignXaxis
, alignments
, alignAll
, alignBefore
, makeAlignedVP
, drawEdgesVP
, drawEdgeVP
, drawEdges
, drawEdge
, locateVertices
, addVPoint
, axisJoin
, touchingVertices
, touching
, touchingVerticesGen
, locateVerticesGen
) where
import Data.List ((\\), intersect, union, elemIndex,foldl',find)
import qualified Data.IntMap.Strict as VMap (IntMap, alter, lookup, fromList, fromListWith, (!), map, filterWithKey,insert, empty, toList, assocs, keys, keysSet)
import qualified Data.IntSet as IntSet (IntSet,union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteMin,findMin,findMax,member,difference)
import qualified Data.Map.Strict as Map (Map, fromList, lookup, fromListWith)
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set (fromList,member,null,delete)
import Diagrams.Prelude hiding (union)
import Diagrams.TwoD.Text (Text)
import TileLib
import HalfTile
import Tgraph.Try
type Vertex = Int
type Dedge = (Vertex,Vertex)
type VertexSet = IntSet.IntSet
type TileFace = HalfTile (Vertex,Vertex,Vertex)
newtype Tgraph = Tgraph [TileFace]
deriving (Vertex -> Tgraph -> ShowS
[Tgraph] -> ShowS
Tgraph -> String
(Vertex -> Tgraph -> ShowS)
-> (Tgraph -> String) -> ([Tgraph] -> ShowS) -> Show Tgraph
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> Tgraph -> ShowS
showsPrec :: Vertex -> Tgraph -> ShowS
$cshow :: Tgraph -> String
show :: Tgraph -> String
$cshowList :: [Tgraph] -> ShowS
showList :: [Tgraph] -> ShowS
Show)
data EdgeType = Short | Long | Join deriving (Vertex -> EdgeType -> ShowS
[EdgeType] -> ShowS
EdgeType -> String
(Vertex -> EdgeType -> ShowS)
-> (EdgeType -> String) -> ([EdgeType] -> ShowS) -> Show EdgeType
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> EdgeType -> ShowS
showsPrec :: Vertex -> EdgeType -> ShowS
$cshow :: EdgeType -> String
show :: EdgeType -> String
$cshowList :: [EdgeType] -> ShowS
showList :: [EdgeType] -> ShowS
Show,EdgeType -> EdgeType -> Bool
(EdgeType -> EdgeType -> Bool)
-> (EdgeType -> EdgeType -> Bool) -> Eq EdgeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeType -> EdgeType -> Bool
== :: EdgeType -> EdgeType -> Bool
$c/= :: EdgeType -> EdgeType -> Bool
/= :: EdgeType -> EdgeType -> Bool
Eq)
type VertexMap a = VMap.IntMap a
makeUncheckedTgraph:: [TileFace] -> Tgraph
makeUncheckedTgraph :: [TileFace] -> Tgraph
makeUncheckedTgraph [TileFace]
fcs = [TileFace] -> Tgraph
Tgraph [TileFace]
fcs
checkedTgraph:: [TileFace] -> Tgraph
checkedTgraph :: [TileFace] -> Tgraph
checkedTgraph = Try Tgraph -> Tgraph
forall a. Try a -> a
runTry (Try Tgraph -> Tgraph)
-> ([TileFace] -> Try Tgraph) -> [TileFace] -> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Try Tgraph -> Try Tgraph
forall a. String -> Try a -> Try a
onFail String
report (Try Tgraph -> Try Tgraph)
-> ([TileFace] -> Try Tgraph) -> [TileFace] -> Try Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TileFace] -> Try Tgraph
tryTgraphProps
where report :: String
report = String
"checkedTgraph: Failed\n"
tryTgraphProps:: [TileFace] -> Try Tgraph
tryTgraphProps :: [TileFace] -> Try Tgraph
tryTgraphProps [] = Tgraph -> Try Tgraph
forall a b. b -> Either a b
Right Tgraph
emptyTgraph
tryTgraphProps [TileFace]
fcs
| [TileFace] -> Bool
hasEdgeLoops [TileFace]
fcs = String -> Try Tgraph
forall a b. a -> Either a b
Left (String -> Try Tgraph) -> String -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ String
"tryTgraphProps: Non-valid tile-face(s)\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"Edge Loops at: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show ([TileFace] -> [Vertex]
findEdgeLoops [TileFace]
fcs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
| [TileFace] -> Bool
illegalTiling [TileFace]
fcs = String -> Try Tgraph
forall a b. a -> Either a b
Left (String -> Try Tgraph) -> String -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ String
"tryTgraphProps: Non-legal tiling\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"Conflicting face directed edges (non-planar tiling): "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Dedge] -> String
forall a. Show a => a -> String
show ([TileFace] -> [Dedge]
conflictingDedges [TileFace]
fcs) String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"\nIllegal tile juxtapositions: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(TileFace, EdgeType, TileFace, EdgeType)] -> String
forall a. Show a => a -> String
show ([TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)]
illegals [TileFace]
fcs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
| Bool
otherwise = let vs :: VertexSet
vs = [TileFace] -> VertexSet
facesVSet [TileFace]
fcs
in if VertexSet -> Vertex
IntSet.findMin VertexSet
vs Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
<Vertex
1
then String -> Try Tgraph
forall a b. a -> Either a b
Left (String -> Try Tgraph) -> String -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ String
"tryTgraphProps: Vertex numbers not all >0: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show (VertexSet -> [Vertex]
IntSet.toList VertexSet
vs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
else [TileFace] -> Try Tgraph
tryConnectedNoCross [TileFace]
fcs
tryConnectedNoCross:: [TileFace] -> Try Tgraph
tryConnectedNoCross :: [TileFace] -> Try Tgraph
tryConnectedNoCross [TileFace]
fcs
| Bool -> Bool
not ([TileFace] -> Bool
connected [TileFace]
fcs) = String -> Try Tgraph
forall a b. a -> Either a b
Left (String -> Try Tgraph) -> String -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ String
"tryConnectedNoCross: Non-valid Tgraph (Not connected)\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [TileFace] -> String
forall a. Show a => a -> String
show [TileFace]
fcs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
| [TileFace] -> Bool
crossingBoundaries [TileFace]
fcs = String -> Try Tgraph
forall a b. a -> Either a b
Left (String -> Try Tgraph) -> String -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ String
"tryConnectedNoCross: Non-valid Tgraph\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"Crossing boundaries found at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show ([TileFace] -> [Vertex]
crossingBVs [TileFace]
fcs)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nwith faces\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [TileFace] -> String
forall a. Show a => a -> String
show [TileFace]
fcs
| Bool
otherwise = Tgraph -> Try Tgraph
forall a b. b -> Either a b
Right ([TileFace] -> Tgraph
Tgraph [TileFace]
fcs)
findEdgeLoops:: [TileFace] -> [Vertex]
findEdgeLoops :: [TileFace] -> [Vertex]
findEdgeLoops = (TileFace -> [Vertex]) -> [TileFace] -> [Vertex]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a]
duplicates ([Vertex] -> [Vertex])
-> (TileFace -> [Vertex]) -> TileFace -> [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> [Vertex]
faceVList)
hasEdgeLoops:: [TileFace] -> Bool
hasEdgeLoops :: [TileFace] -> Bool
hasEdgeLoops = Bool -> Bool
not (Bool -> Bool) -> ([TileFace] -> Bool) -> [TileFace] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Vertex] -> Bool)
-> ([TileFace] -> [Vertex]) -> [TileFace] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TileFace] -> [Vertex]
findEdgeLoops
duplicates :: Eq a => [a] -> [a]
duplicates :: forall a. Eq a => [a] -> [a]
duplicates = ([a], [a]) -> [a]
forall a b. (a, b) -> a
fst (([a], [a]) -> [a]) -> ([a] -> ([a], [a])) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([a], [a]) -> a -> ([a], [a])) -> ([a], [a]) -> [a] -> ([a], [a])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([a], [a]) -> a -> ([a], [a])
forall {a}. Eq a => ([a], [a]) -> a -> ([a], [a])
check ([],[]) where
check :: ([a], [a]) -> a -> ([a], [a])
check ([a]
dups,[a]
seen) a
x | a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
dups = ([a]
dups,[a]
seen)
| a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
seen = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
dups,[a]
seen)
| Bool
otherwise = ([a]
dups,a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
seen)
conflictingDedges :: [TileFace] -> [Dedge]
conflictingDedges :: [TileFace] -> [Dedge]
conflictingDedges = [Dedge] -> [Dedge]
forall a. Eq a => [a] -> [a]
duplicates ([Dedge] -> [Dedge])
-> ([TileFace] -> [Dedge]) -> [TileFace] -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TileFace] -> [Dedge]
facesDedges
edgeType:: Dedge -> TileFace -> EdgeType
edgeType :: Dedge -> TileFace -> EdgeType
edgeType Dedge
d TileFace
f | Dedge
d Dedge -> Dedge -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Dedge
longE TileFace
f = EdgeType
Long
| Dedge
d Dedge -> Dedge -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Dedge
shortE TileFace
f = EdgeType
Short
| Dedge
d Dedge -> Dedge -> Bool
forall a. Eq a => a -> a -> Bool
== TileFace -> Dedge
joinE TileFace
f = EdgeType
Join
| Bool
otherwise = String -> EdgeType
forall a. HasCallStack => String -> a
error (String -> EdgeType) -> String -> EdgeType
forall a b. (a -> b) -> a -> b
$ String
"edgeType: directed edge " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
d String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" not found in face " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
sharedEdges:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]
sharedEdges :: [TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)]
sharedEdges [TileFace]
fcs = [(TileFace
f1, Dedge -> TileFace -> EdgeType
edgeType Dedge
d1 TileFace
f1, TileFace
f2, Dedge -> TileFace -> EdgeType
edgeType Dedge
d2 TileFace
f2)
| TileFace
f1 <- [TileFace]
fcs
, Dedge
d1 <- TileFace -> [Dedge]
faceDedges TileFace
f1
, let d2 :: Dedge
d2 = Dedge -> Dedge
reverseD Dedge
d1
, TileFace
f2 <- (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (TileFace -> Dedge -> Bool
`hasDedge` Dedge
d2) [TileFace]
fcs
]
newSharedEdges:: TileFace -> [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]
newSharedEdges :: TileFace
-> [TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)]
newSharedEdges TileFace
face [TileFace]
fcs =
[(TileFace
face, Dedge -> TileFace -> EdgeType
edgeType Dedge
d1 TileFace
face, TileFace
fc', Dedge -> TileFace -> EdgeType
edgeType Dedge
d2 TileFace
fc')
| Dedge
d1 <- TileFace -> [Dedge]
faceDedges TileFace
face
, let d2 :: Dedge
d2 = Dedge -> Dedge
reverseD Dedge
d1
, TileFace
fc' <- (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (TileFace -> Dedge -> Bool
`hasDedge` Dedge
d2) [TileFace]
fcs
]
noNewConflict :: TileFace -> [TileFace] -> Bool
noNewConflict :: TileFace -> [TileFace] -> Bool
noNewConflict TileFace
face [TileFace]
fcs = [(TileFace, EdgeType, TileFace, EdgeType)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(TileFace, EdgeType, TileFace, EdgeType)] -> Bool)
-> [(TileFace, EdgeType, TileFace, EdgeType)] -> Bool
forall a b. (a -> b) -> a -> b
$ ((TileFace, EdgeType, TileFace, EdgeType) -> Bool)
-> [(TileFace, EdgeType, TileFace, EdgeType)]
-> [(TileFace, EdgeType, TileFace, EdgeType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((TileFace, EdgeType, TileFace, EdgeType) -> Bool)
-> (TileFace, EdgeType, TileFace, EdgeType)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TileFace, EdgeType, TileFace, EdgeType) -> Bool
legal) [(TileFace, EdgeType, TileFace, EdgeType)]
shared where
shared :: [(TileFace, EdgeType, TileFace, EdgeType)]
shared = TileFace
-> [TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)]
newSharedEdges TileFace
face [TileFace]
fcs
legal:: (TileFace,EdgeType,TileFace,EdgeType) -> Bool
legal :: (TileFace, EdgeType, TileFace, EdgeType) -> Bool
legal (LK (Vertex, Vertex, Vertex)
_, EdgeType
e1, RK (Vertex, Vertex, Vertex)
_ , EdgeType
e2 ) = EdgeType
e1 EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
e2
legal (RK (Vertex, Vertex, Vertex)
_, EdgeType
e1, LK (Vertex, Vertex, Vertex)
_ , EdgeType
e2 ) = EdgeType
e1 EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
e2
legal (LK (Vertex, Vertex, Vertex)
_, EdgeType
Short, RD (Vertex, Vertex, Vertex)
_ , EdgeType
Short) = Bool
True
legal (RD (Vertex, Vertex, Vertex)
_, EdgeType
Short, LK (Vertex, Vertex, Vertex)
_ , EdgeType
Short) = Bool
True
legal (LK (Vertex, Vertex, Vertex)
_, EdgeType
Long, RD (Vertex, Vertex, Vertex)
_ , EdgeType
Long ) = Bool
True
legal (RD (Vertex, Vertex, Vertex)
_, EdgeType
Long, LK (Vertex, Vertex, Vertex)
_ , EdgeType
Long ) = Bool
True
legal (LD (Vertex, Vertex, Vertex)
_, EdgeType
Join, RD (Vertex, Vertex, Vertex)
_ , EdgeType
Join ) = Bool
True
legal (RD (Vertex, Vertex, Vertex)
_, EdgeType
Join, LD (Vertex, Vertex, Vertex)
_ , EdgeType
Join ) = Bool
True
legal (LD (Vertex, Vertex, Vertex)
_, EdgeType
Long, RD (Vertex, Vertex, Vertex)
_ , EdgeType
Long ) = Bool
True
legal (RD (Vertex, Vertex, Vertex)
_, EdgeType
Long, LD (Vertex, Vertex, Vertex)
_ , EdgeType
Long ) = Bool
True
legal (LD (Vertex, Vertex, Vertex)
_, EdgeType
Short, RK (Vertex, Vertex, Vertex)
_ , EdgeType
Short) = Bool
True
legal (RK (Vertex, Vertex, Vertex)
_, EdgeType
Short, LD (Vertex, Vertex, Vertex)
_ , EdgeType
Short) = Bool
True
legal (LD (Vertex, Vertex, Vertex)
_, EdgeType
Long, RK (Vertex, Vertex, Vertex)
_ , EdgeType
Long ) = Bool
True
legal (RK (Vertex, Vertex, Vertex)
_, EdgeType
Long, LD (Vertex, Vertex, Vertex)
_ , EdgeType
Long ) = Bool
True
legal (TileFace, EdgeType, TileFace, EdgeType)
_ = Bool
False
illegals:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]
illegals :: [TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)]
illegals = ((TileFace, EdgeType, TileFace, EdgeType) -> Bool)
-> [(TileFace, EdgeType, TileFace, EdgeType)]
-> [(TileFace, EdgeType, TileFace, EdgeType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((TileFace, EdgeType, TileFace, EdgeType) -> Bool)
-> (TileFace, EdgeType, TileFace, EdgeType)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TileFace, EdgeType, TileFace, EdgeType) -> Bool
legal) ([(TileFace, EdgeType, TileFace, EdgeType)]
-> [(TileFace, EdgeType, TileFace, EdgeType)])
-> ([TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)])
-> [TileFace]
-> [(TileFace, EdgeType, TileFace, EdgeType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)]
sharedEdges
illegalTiling:: [TileFace] -> Bool
illegalTiling :: [TileFace] -> Bool
illegalTiling [TileFace]
fcs = Bool -> Bool
not ([(TileFace, EdgeType, TileFace, EdgeType)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TileFace] -> [(TileFace, EdgeType, TileFace, EdgeType)]
illegals [TileFace]
fcs)) Bool -> Bool -> Bool
|| Bool -> Bool
not ([Dedge] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TileFace] -> [Dedge]
conflictingDedges [TileFace]
fcs))
crossingBVs :: [TileFace] -> [Vertex]
crossingBVs :: [TileFace] -> [Vertex]
crossingBVs = [Dedge] -> [Vertex]
crossingVertices ([Dedge] -> [Vertex])
-> ([TileFace] -> [Dedge]) -> [TileFace] -> [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TileFace] -> [Dedge]
facesBoundary
crossingVertices:: [Dedge] -> [Vertex]
crossingVertices :: [Dedge] -> [Vertex]
crossingVertices [Dedge]
des = [Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a]
duplicates ((Dedge -> Vertex) -> [Dedge] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Vertex
forall a b. (a, b) -> a
fst [Dedge]
des)
crossingBoundaries :: [TileFace] -> Bool
crossingBoundaries :: [TileFace] -> Bool
crossingBoundaries = Bool -> Bool
not (Bool -> Bool) -> ([TileFace] -> Bool) -> [TileFace] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Vertex] -> Bool)
-> ([TileFace] -> [Vertex]) -> [TileFace] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TileFace] -> [Vertex]
crossingBVs
connected:: [TileFace] -> Bool
connected :: [TileFace] -> Bool
connected [] = Bool
True
connected [TileFace]
fcs = [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([Vertex], [Vertex]) -> [Vertex]
forall a b. (a, b) -> b
snd (([Vertex], [Vertex]) -> [Vertex])
-> ([Vertex], [Vertex]) -> [Vertex]
forall a b. (a -> b) -> a -> b
$ [Dedge] -> Vertex -> VertexSet -> ([Vertex], [Vertex])
connectedBy ([TileFace] -> [Dedge]
facesEdges [TileFace]
fcs) (VertexSet -> Vertex
IntSet.findMin VertexSet
vs) VertexSet
vs)
where vs :: VertexSet
vs = [TileFace] -> VertexSet
facesVSet [TileFace]
fcs
connectedBy :: [Dedge] -> Vertex -> VertexSet -> ([Vertex],[Vertex])
connectedBy :: [Dedge] -> Vertex -> VertexSet -> ([Vertex], [Vertex])
connectedBy [Dedge]
edges Vertex
v VertexSet
verts = VertexSet -> VertexSet -> VertexSet -> ([Vertex], [Vertex])
search VertexSet
IntSet.empty (Vertex -> VertexSet
IntSet.singleton Vertex
v) (Vertex -> VertexSet -> VertexSet
IntSet.delete Vertex
v VertexSet
verts) where
nextMap :: IntMap [Vertex]
nextMap = ([Vertex] -> [Vertex] -> [Vertex])
-> [(Vertex, [Vertex])] -> IntMap [Vertex]
forall a. (a -> a -> a) -> [(Vertex, a)] -> IntMap a
VMap.fromListWith [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
(++) ([(Vertex, [Vertex])] -> IntMap [Vertex])
-> [(Vertex, [Vertex])] -> IntMap [Vertex]
forall a b. (a -> b) -> a -> b
$ (Dedge -> (Vertex, [Vertex])) -> [Dedge] -> [(Vertex, [Vertex])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vertex
a,Vertex
b)->(Vertex
a,[Vertex
b])) [Dedge]
edges
search :: VertexSet -> VertexSet -> VertexSet -> ([Vertex], [Vertex])
search VertexSet
done VertexSet
visited VertexSet
unvisited
| VertexSet -> Bool
IntSet.null VertexSet
unvisited = (VertexSet -> [Vertex]
IntSet.toList VertexSet
visited [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
++ VertexSet -> [Vertex]
IntSet.toList VertexSet
done,[])
| VertexSet -> Bool
IntSet.null VertexSet
visited = (VertexSet -> [Vertex]
IntSet.toList VertexSet
done, VertexSet -> [Vertex]
IntSet.toList VertexSet
unvisited)
| Bool
otherwise =
VertexSet -> VertexSet -> VertexSet -> ([Vertex], [Vertex])
search (Vertex -> VertexSet -> VertexSet
IntSet.insert Vertex
x VertexSet
done) (VertexSet -> VertexSet -> VertexSet
IntSet.union VertexSet
newVs VertexSet
visited') (VertexSet
unvisited VertexSet -> VertexSet -> VertexSet
IntSet.\\ VertexSet
newVs)
where x :: Vertex
x = VertexSet -> Vertex
IntSet.findMin VertexSet
visited
visited' :: VertexSet
visited' = VertexSet -> VertexSet
IntSet.deleteMin VertexSet
visited
newVs :: VertexSet
newVs = [Vertex] -> VertexSet
IntSet.fromList ([Vertex] -> VertexSet) -> [Vertex] -> VertexSet
forall a b. (a -> b) -> a -> b
$ (Vertex -> Bool) -> [Vertex] -> [Vertex]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex -> VertexSet -> Bool
`IntSet.notMember` VertexSet
done) ([Vertex] -> [Vertex]) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ IntMap [Vertex]
nextMap IntMap [Vertex] -> Vertex -> [Vertex]
forall a. IntMap a -> Vertex -> a
VMap.! Vertex
x
faces :: Tgraph -> [TileFace]
faces :: Tgraph -> [TileFace]
faces (Tgraph [TileFace]
fcs) = [TileFace]
fcs
emptyTgraph :: Tgraph
emptyTgraph :: Tgraph
emptyTgraph = [TileFace] -> Tgraph
Tgraph []
nullGraph:: Tgraph -> Bool
nullGraph :: Tgraph -> Bool
nullGraph = [TileFace] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TileFace] -> Bool) -> (Tgraph -> [TileFace]) -> Tgraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
maxV :: Tgraph -> Int
maxV :: Tgraph -> Vertex
maxV = [TileFace] -> Vertex
facesMaxV ([TileFace] -> Vertex)
-> (Tgraph -> [TileFace]) -> Tgraph -> Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
ldarts,rdarts,lkites,rkites, kites, darts :: Tgraph -> [TileFace]
ldarts :: Tgraph -> [TileFace]
ldarts = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLD ([TileFace] -> [TileFace])
-> (Tgraph -> [TileFace]) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
rdarts :: Tgraph -> [TileFace]
rdarts = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRD ([TileFace] -> [TileFace])
-> (Tgraph -> [TileFace]) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
lkites :: Tgraph -> [TileFace]
lkites = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isLK ([TileFace] -> [TileFace])
-> (Tgraph -> [TileFace]) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
rkites :: Tgraph -> [TileFace]
rkites = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isRK ([TileFace] -> [TileFace])
-> (Tgraph -> [TileFace]) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
kites :: Tgraph -> [TileFace]
kites = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isKite ([TileFace] -> [TileFace])
-> (Tgraph -> [TileFace]) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
darts :: Tgraph -> [TileFace]
darts = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart ([TileFace] -> [TileFace])
-> (Tgraph -> [TileFace]) -> Tgraph -> [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
selectFaces :: [TileFace] -> Tgraph -> Tgraph
selectFaces :: [TileFace] -> Tgraph -> Tgraph
selectFaces [TileFace]
fcs Tgraph
g = Try Tgraph -> Tgraph
forall a. Try a -> a
runTry (Try Tgraph -> Tgraph) -> Try Tgraph -> Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> Try Tgraph
tryConnectedNoCross ([TileFace] -> Try Tgraph) -> [TileFace] -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ Tgraph -> [TileFace]
faces Tgraph
g [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [TileFace]
fcs
removeFaces :: [TileFace] -> Tgraph -> Tgraph
removeFaces :: [TileFace] -> Tgraph -> Tgraph
removeFaces [TileFace]
fcs Tgraph
g = Try Tgraph -> Tgraph
forall a. Try a -> a
runTry (Try Tgraph -> Tgraph) -> Try Tgraph -> Tgraph
forall a b. (a -> b) -> a -> b
$ [TileFace] -> Try Tgraph
tryConnectedNoCross ([TileFace] -> Try Tgraph) -> [TileFace] -> Try Tgraph
forall a b. (a -> b) -> a -> b
$ Tgraph -> [TileFace]
faces Tgraph
g [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TileFace]
fcs
removeVertices :: [Vertex] -> Tgraph -> Tgraph
removeVertices :: [Vertex] -> Tgraph -> Tgraph
removeVertices [Vertex]
vs Tgraph
g = [TileFace] -> Tgraph -> Tgraph
removeFaces ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Vertex] -> TileFace -> Bool
hasVIn [Vertex]
vs) (Tgraph -> [TileFace]
faces Tgraph
g)) Tgraph
g
selectVertices :: [Vertex] -> Tgraph -> Tgraph
selectVertices :: [Vertex] -> Tgraph -> Tgraph
selectVertices [Vertex]
vs Tgraph
g = [TileFace] -> Tgraph -> Tgraph
selectFaces ((TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Vertex] -> TileFace -> Bool
hasVIn [Vertex]
vs) (Tgraph -> [TileFace]
faces Tgraph
g)) Tgraph
g
vertexSet:: Tgraph -> VertexSet
vertexSet :: Tgraph -> VertexSet
vertexSet = [TileFace] -> VertexSet
facesVSet ([TileFace] -> VertexSet)
-> (Tgraph -> [TileFace]) -> Tgraph -> VertexSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
graphDedges :: Tgraph -> [Dedge]
graphDedges :: Tgraph -> [Dedge]
graphDedges = [TileFace] -> [Dedge]
facesDedges ([TileFace] -> [Dedge])
-> (Tgraph -> [TileFace]) -> Tgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
graphEdges :: Tgraph -> [Dedge]
graphEdges :: Tgraph -> [Dedge]
graphEdges = [TileFace] -> [Dedge]
facesEdges ([TileFace] -> [Dedge])
-> (Tgraph -> [TileFace]) -> Tgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
internalEdges :: Tgraph -> [Dedge]
internalEdges :: Tgraph -> [Dedge]
internalEdges Tgraph
g = [Dedge]
des [Dedge] -> [Dedge] -> [Dedge]
forall a. Eq a => [a] -> [a] -> [a]
\\ (Dedge -> Dedge) -> [Dedge] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Dedge
reverseD ([Dedge] -> [Dedge]
missingRevs [Dedge]
des) where
des :: [Dedge]
des = Tgraph -> [Dedge]
graphDedges Tgraph
g
graphBoundary :: Tgraph -> [Dedge]
graphBoundary :: Tgraph -> [Dedge]
graphBoundary = [TileFace] -> [Dedge]
facesBoundary ([TileFace] -> [Dedge])
-> (Tgraph -> [TileFace]) -> Tgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
phiEdges :: Tgraph -> [Dedge]
phiEdges :: Tgraph -> [Dedge]
phiEdges = [Dedge] -> [Dedge]
bothDir ([Dedge] -> [Dedge]) -> (Tgraph -> [Dedge]) -> Tgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TileFace -> [Dedge]) -> [TileFace] -> [Dedge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TileFace -> [Dedge]
facePhiEdges ([TileFace] -> [Dedge])
-> (Tgraph -> [TileFace]) -> Tgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
nonPhiEdges :: Tgraph -> [Dedge]
nonPhiEdges :: Tgraph -> [Dedge]
nonPhiEdges = [Dedge] -> [Dedge]
bothDir ([Dedge] -> [Dedge]) -> (Tgraph -> [Dedge]) -> Tgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TileFace -> [Dedge]) -> [TileFace] -> [Dedge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TileFace -> [Dedge]
faceNonPhiEdges ([TileFace] -> [Dedge])
-> (Tgraph -> [TileFace]) -> Tgraph -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
graphEFMap :: Tgraph -> Map.Map Dedge TileFace
graphEFMap :: Tgraph -> Map Dedge TileFace
graphEFMap = [TileFace] -> Map Dedge TileFace
buildEFMap ([TileFace] -> Map Dedge TileFace)
-> (Tgraph -> [TileFace]) -> Tgraph -> Map Dedge TileFace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> [TileFace]
faces
defaultAlignment :: Tgraph -> (Vertex,Vertex)
defaultAlignment :: Tgraph -> Dedge
defaultAlignment Tgraph
g | Tgraph -> Bool
nullGraph Tgraph
g = String -> Dedge
forall a. HasCallStack => String -> a
error String
"defaultAlignment: applied to empty Tgraph\n"
| Bool
otherwise = [TileFace] -> Dedge
lowestJoin ([TileFace] -> Dedge) -> [TileFace] -> Dedge
forall a b. (a -> b) -> a -> b
$ Tgraph -> [TileFace]
faces Tgraph
g
faceVs::TileFace -> (Vertex,Vertex,Vertex)
faceVs :: TileFace -> (Vertex, Vertex, Vertex)
faceVs = TileFace -> (Vertex, Vertex, Vertex)
forall rep. HalfTile rep -> rep
tileRep
faceVList::TileFace -> [Vertex]
faceVList :: TileFace -> [Vertex]
faceVList = (\(Vertex
x,Vertex
y,Vertex
z) -> [Vertex
x,Vertex
y,Vertex
z]) ((Vertex, Vertex, Vertex) -> [Vertex])
-> (TileFace -> (Vertex, Vertex, Vertex)) -> TileFace -> [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> (Vertex, Vertex, Vertex)
faceVs
faceVSet :: TileFace -> VertexSet
faceVSet :: TileFace -> VertexSet
faceVSet = [Vertex] -> VertexSet
IntSet.fromList ([Vertex] -> VertexSet)
-> (TileFace -> [Vertex]) -> TileFace -> VertexSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> [Vertex]
faceVList
facesVSet:: [TileFace] -> VertexSet
facesVSet :: [TileFace] -> VertexSet
facesVSet = [VertexSet] -> VertexSet
forall a. Monoid a => [a] -> a
mconcat ([VertexSet] -> VertexSet)
-> ([TileFace] -> [VertexSet]) -> [TileFace] -> VertexSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TileFace -> VertexSet) -> [TileFace] -> [VertexSet]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> VertexSet
faceVSet
facesMaxV :: [TileFace] -> Vertex
facesMaxV :: [TileFace] -> Vertex
facesMaxV [] = Vertex
0
facesMaxV [TileFace]
fcs = VertexSet -> Vertex
IntSet.findMax (VertexSet -> Vertex) -> VertexSet -> Vertex
forall a b. (a -> b) -> a -> b
$ [TileFace] -> VertexSet
facesVSet [TileFace]
fcs
firstV,secondV,thirdV:: TileFace -> Vertex
firstV :: TileFace -> Vertex
firstV TileFace
face = Vertex
a where (Vertex
a,Vertex
_,Vertex
_) = TileFace -> (Vertex, Vertex, Vertex)
faceVs TileFace
face
secondV :: TileFace -> Vertex
secondV TileFace
face = Vertex
b where (Vertex
_,Vertex
b,Vertex
_) = TileFace -> (Vertex, Vertex, Vertex)
faceVs TileFace
face
thirdV :: TileFace -> Vertex
thirdV TileFace
face = Vertex
c where (Vertex
_,Vertex
_,Vertex
c) = TileFace -> (Vertex, Vertex, Vertex)
faceVs TileFace
face
originV,wingV,oppV:: TileFace -> Vertex
originV :: TileFace -> Vertex
originV = TileFace -> Vertex
firstV
wingV :: TileFace -> Vertex
wingV (LD(Vertex
_,Vertex
_,Vertex
c)) = Vertex
c
wingV (RD(Vertex
_,Vertex
b,Vertex
_)) = Vertex
b
wingV (LK(Vertex
_,Vertex
b,Vertex
_)) = Vertex
b
wingV (RK(Vertex
_,Vertex
_,Vertex
c)) = Vertex
c
oppV :: TileFace -> Vertex
oppV (LD(Vertex
_,Vertex
b,Vertex
_)) = Vertex
b
oppV (RD(Vertex
_,Vertex
_,Vertex
c)) = Vertex
c
oppV (LK(Vertex
_,Vertex
_,Vertex
c)) = Vertex
c
oppV (RK(Vertex
_,Vertex
b,Vertex
_)) = Vertex
b
indexV :: Vertex -> TileFace -> Int
indexV :: Vertex -> TileFace -> Vertex
indexV Vertex
v TileFace
face = case Vertex -> [Vertex] -> Maybe Vertex
forall a. Eq a => a -> [a] -> Maybe Vertex
elemIndex Vertex
v (TileFace -> [Vertex]
faceVList TileFace
face) of
Just Vertex
i -> Vertex
i
Maybe Vertex
_ -> String -> Vertex
forall a. HasCallStack => String -> a
error (String
"indexV: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
face)
nextV :: Vertex -> TileFace -> Vertex
nextV :: Vertex -> TileFace -> Vertex
nextV Vertex
v TileFace
face = case Vertex -> TileFace -> Vertex
indexV Vertex
v TileFace
face of
Vertex
0 -> TileFace -> Vertex
secondV TileFace
face
Vertex
1 -> TileFace -> Vertex
thirdV TileFace
face
Vertex
2 -> TileFace -> Vertex
firstV TileFace
face
Vertex
_ -> String -> Vertex
forall a. HasCallStack => String -> a
error String
"nextV: index error"
prevV :: Vertex -> TileFace -> Vertex
prevV :: Vertex -> TileFace -> Vertex
prevV Vertex
v TileFace
face = case Vertex -> TileFace -> Vertex
indexV Vertex
v TileFace
face of
Vertex
0 -> TileFace -> Vertex
thirdV TileFace
face
Vertex
1 -> TileFace -> Vertex
firstV TileFace
face
Vertex
2 -> TileFace -> Vertex
secondV TileFace
face
Vertex
_ -> String -> Vertex
forall a. HasCallStack => String -> a
error String
"prevV: index error"
isAtV:: Vertex -> TileFace -> Bool
isAtV :: Vertex -> TileFace -> Bool
isAtV Vertex
v (LD(Vertex
a,Vertex
b,Vertex
c)) = Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
c
isAtV Vertex
v (RD(Vertex
a,Vertex
b,Vertex
c)) = Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
c
isAtV Vertex
v (LK(Vertex
a,Vertex
b,Vertex
c)) = Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
c
isAtV Vertex
v (RK(Vertex
a,Vertex
b,Vertex
c)) = Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
a Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
b Bool -> Bool -> Bool
|| Vertex
vVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==Vertex
c
hasVIn:: [Vertex] -> TileFace -> Bool
hasVIn :: [Vertex] -> TileFace -> Bool
hasVIn [Vertex]
vs TileFace
face = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Vertex] -> Bool) -> [Vertex] -> Bool
forall a b. (a -> b) -> a -> b
$ TileFace -> [Vertex]
faceVList TileFace
face [Vertex] -> [Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Vertex]
vs
faceDedges::TileFace -> [Dedge]
faceDedges :: TileFace -> [Dedge]
faceDedges (LD(Vertex
a,Vertex
b,Vertex
c)) = [(Vertex
a,Vertex
b),(Vertex
b,Vertex
c),(Vertex
c,Vertex
a)]
faceDedges (RD(Vertex
a,Vertex
b,Vertex
c)) = [(Vertex
a,Vertex
b),(Vertex
b,Vertex
c),(Vertex
c,Vertex
a)]
faceDedges (LK(Vertex
a,Vertex
b,Vertex
c)) = [(Vertex
a,Vertex
b),(Vertex
b,Vertex
c),(Vertex
c,Vertex
a)]
faceDedges (RK(Vertex
a,Vertex
b,Vertex
c)) = [(Vertex
a,Vertex
b),(Vertex
b,Vertex
c),(Vertex
c,Vertex
a)]
facesDedges :: [TileFace] -> [Dedge]
facesDedges :: [TileFace] -> [Dedge]
facesDedges = (TileFace -> [Dedge]) -> [TileFace] -> [Dedge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TileFace -> [Dedge]
faceDedges
reverseD:: Dedge -> Dedge
reverseD :: Dedge -> Dedge
reverseD (Vertex
a,Vertex
b) = (Vertex
b,Vertex
a)
joinE, shortE, longE, joinOfTile:: TileFace -> Dedge
joinE :: TileFace -> Dedge
joinE (LD(Vertex
a,Vertex
b,Vertex
_)) = (Vertex
a,Vertex
b)
joinE (RD(Vertex
a,Vertex
_,Vertex
c)) = (Vertex
c,Vertex
a)
joinE (LK(Vertex
a,Vertex
_,Vertex
c)) = (Vertex
c,Vertex
a)
joinE (RK(Vertex
a,Vertex
b,Vertex
_)) = (Vertex
a,Vertex
b)
shortE :: TileFace -> Dedge
shortE (LD(Vertex
_,Vertex
b,Vertex
c)) = (Vertex
b,Vertex
c)
shortE (RD(Vertex
_,Vertex
b,Vertex
c)) = (Vertex
b,Vertex
c)
shortE (LK(Vertex
_,Vertex
b,Vertex
c)) = (Vertex
b,Vertex
c)
shortE (RK(Vertex
_,Vertex
b,Vertex
c)) = (Vertex
b,Vertex
c)
longE :: TileFace -> Dedge
longE (LD(Vertex
a,Vertex
_,Vertex
c)) = (Vertex
c,Vertex
a)
longE (RD(Vertex
a,Vertex
b,Vertex
_)) = (Vertex
a,Vertex
b)
longE (LK(Vertex
a,Vertex
b,Vertex
_)) = (Vertex
a,Vertex
b)
longE (RK(Vertex
a,Vertex
_,Vertex
c)) = (Vertex
c,Vertex
a)
joinOfTile :: TileFace -> Dedge
joinOfTile TileFace
face = (TileFace -> Vertex
originV TileFace
face, TileFace -> Vertex
oppV TileFace
face)
facePhiEdges, faceNonPhiEdges:: TileFace -> [Dedge]
facePhiEdges :: TileFace -> [Dedge]
facePhiEdges face :: TileFace
face@(RD (Vertex, Vertex, Vertex)
_) = [Dedge
e, Dedge -> Dedge
reverseD Dedge
e] where e :: Dedge
e = TileFace -> Dedge
longE TileFace
face
facePhiEdges face :: TileFace
face@(LD (Vertex, Vertex, Vertex)
_) = [Dedge
e, Dedge -> Dedge
reverseD Dedge
e] where e :: Dedge
e = TileFace -> Dedge
longE TileFace
face
facePhiEdges TileFace
face = [Dedge
e, Dedge -> Dedge
reverseD Dedge
e, Dedge
j, Dedge -> Dedge
reverseD Dedge
j]
where e :: Dedge
e = TileFace -> Dedge
longE TileFace
face
j :: Dedge
j = TileFace -> Dedge
joinE TileFace
face
faceNonPhiEdges :: TileFace -> [Dedge]
faceNonPhiEdges TileFace
face = [Dedge] -> [Dedge]
bothDirOneWay (TileFace -> [Dedge]
faceDedges TileFace
face) [Dedge] -> [Dedge] -> [Dedge]
forall a. Eq a => [a] -> [a] -> [a]
\\ TileFace -> [Dedge]
facePhiEdges TileFace
face
matchingE :: (TileFace -> Dedge) -> TileFace -> TileFace -> Bool
matchingE :: (TileFace -> Dedge) -> TileFace -> TileFace -> Bool
matchingE TileFace -> Dedge
eselect TileFace
face = (Dedge -> Dedge -> Bool
forall a. Eq a => a -> a -> Bool
== Dedge -> Dedge
reverseD (TileFace -> Dedge
eselect TileFace
face)) (Dedge -> Bool) -> (TileFace -> Dedge) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Dedge
eselect
matchingLongE,matchingShortE,matchingJoinE :: TileFace -> TileFace -> Bool
matchingLongE :: TileFace -> TileFace -> Bool
matchingLongE = (TileFace -> Dedge) -> TileFace -> TileFace -> Bool
matchingE TileFace -> Dedge
longE
matchingShortE :: TileFace -> TileFace -> Bool
matchingShortE = (TileFace -> Dedge) -> TileFace -> TileFace -> Bool
matchingE TileFace -> Dedge
shortE
matchingJoinE :: TileFace -> TileFace -> Bool
matchingJoinE = (TileFace -> Dedge) -> TileFace -> TileFace -> Bool
matchingE TileFace -> Dedge
joinE
hasDedge :: TileFace -> Dedge -> Bool
hasDedge :: TileFace -> Dedge -> Bool
hasDedge TileFace
f Dedge
e = Dedge
e Dedge -> [Dedge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TileFace -> [Dedge]
faceDedges TileFace
f
hasDedgeIn :: TileFace -> [Dedge] -> Bool
hasDedgeIn :: TileFace -> [Dedge] -> Bool
hasDedgeIn TileFace
face [Dedge]
es = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Dedge] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Dedge] -> Bool) -> [Dedge] -> Bool
forall a b. (a -> b) -> a -> b
$ [Dedge]
es [Dedge] -> [Dedge] -> [Dedge]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` TileFace -> [Dedge]
faceDedges TileFace
face
facesEdges :: [TileFace] -> [Dedge]
facesEdges :: [TileFace] -> [Dedge]
facesEdges = [Dedge] -> [Dedge]
bothDir ([Dedge] -> [Dedge])
-> ([TileFace] -> [Dedge]) -> [TileFace] -> [Dedge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TileFace] -> [Dedge]
facesDedges
bothDir:: [Dedge] -> [Dedge]
bothDir :: [Dedge] -> [Dedge]
bothDir [Dedge]
es = [Dedge] -> [Dedge]
missingRevs [Dedge]
es [Dedge] -> [Dedge] -> [Dedge]
forall a. [a] -> [a] -> [a]
++ [Dedge]
es
bothDirOneWay:: [Dedge] -> [Dedge]
bothDirOneWay :: [Dedge] -> [Dedge]
bothDirOneWay [] = []
bothDirOneWay (e :: Dedge
e@(Vertex
a,Vertex
b):[Dedge]
es)= Dedge
eDedge -> [Dedge] -> [Dedge]
forall a. a -> [a] -> [a]
:(Vertex
b,Vertex
a)Dedge -> [Dedge] -> [Dedge]
forall a. a -> [a] -> [a]
:[Dedge] -> [Dedge]
bothDirOneWay [Dedge]
es
facesBoundary :: [TileFace] -> [Dedge]
facesBoundary :: [TileFace] -> [Dedge]
facesBoundary [TileFace]
fcs = [Dedge] -> [Dedge]
missingRevs ([Dedge] -> [Dedge]) -> [Dedge] -> [Dedge]
forall a b. (a -> b) -> a -> b
$ [TileFace] -> [Dedge]
facesDedges [TileFace]
fcs
missingRevs:: [Dedge] -> [Dedge]
missingRevs :: [Dedge] -> [Dedge]
missingRevs [Dedge]
es = [Dedge] -> [Dedge]
revUnmatched [Dedge]
es where
vmap :: IntMap [Vertex]
vmap = ([Vertex] -> [Vertex] -> [Vertex])
-> [(Vertex, [Vertex])] -> IntMap [Vertex]
forall a. (a -> a -> a) -> [(Vertex, a)] -> IntMap a
VMap.fromListWith [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
(++) ([(Vertex, [Vertex])] -> IntMap [Vertex])
-> [(Vertex, [Vertex])] -> IntMap [Vertex]
forall a b. (a -> b) -> a -> b
$ (Dedge -> (Vertex, [Vertex])) -> [Dedge] -> [(Vertex, [Vertex])]
forall a b. (a -> b) -> [a] -> [b]
map Dedge -> (Vertex, [Vertex])
forall {a} {a}. (a, a) -> (a, [a])
singleton [Dedge]
es
singleton :: (a, a) -> (a, [a])
singleton (a
a,a
b) = (a
a,[a
b])
seekR :: Dedge -> Bool
seekR (Vertex
a,Vertex
b) = case Vertex -> IntMap [Vertex] -> Maybe [Vertex]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
b IntMap [Vertex]
vmap of
Maybe [Vertex]
Nothing -> Bool
False
Just [Vertex]
vs -> Vertex
a Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Vertex]
vs
revUnmatched :: [Dedge] -> [Dedge]
revUnmatched [] = []
revUnmatched (e :: Dedge
e@(Vertex
a,Vertex
b):[Dedge]
more) | Dedge -> Bool
seekR Dedge
e = [Dedge] -> [Dedge]
revUnmatched [Dedge]
more
| Bool
otherwise = (Vertex
b,Vertex
a)Dedge -> [Dedge] -> [Dedge]
forall a. a -> [a] -> [a]
:[Dedge] -> [Dedge]
revUnmatched [Dedge]
more
edgeNb::TileFace -> TileFace -> Bool
edgeNb :: TileFace -> TileFace -> Bool
edgeNb TileFace
face = (Dedge -> Bool) -> [Dedge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Dedge -> [Dedge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Dedge]
edges) ([Dedge] -> Bool) -> (TileFace -> [Dedge]) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> [Dedge]
faceDedges where
edges :: [Dedge]
edges = (Dedge -> Dedge) -> [Dedge] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Dedge
reverseD (TileFace -> [Dedge]
faceDedges TileFace
face)
vertexFacesMap:: [Vertex] -> [TileFace] -> VertexMap [TileFace]
vertexFacesMap :: [Vertex] -> [TileFace] -> VertexMap [TileFace]
vertexFacesMap [Vertex]
vs = (VertexMap [TileFace] -> TileFace -> VertexMap [TileFace])
-> VertexMap [TileFace] -> [TileFace] -> VertexMap [TileFace]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VertexMap [TileFace] -> TileFace -> VertexMap [TileFace]
insertf VertexMap [TileFace]
startVF where
startVF :: VertexMap [TileFace]
startVF = [(Vertex, [TileFace])] -> VertexMap [TileFace]
forall a. [(Vertex, a)] -> IntMap a
VMap.fromList ([(Vertex, [TileFace])] -> VertexMap [TileFace])
-> [(Vertex, [TileFace])] -> VertexMap [TileFace]
forall a b. (a -> b) -> a -> b
$ (Vertex -> (Vertex, [TileFace]))
-> [Vertex] -> [(Vertex, [TileFace])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,[]) [Vertex]
vs
insertf :: VertexMap [TileFace] -> TileFace -> VertexMap [TileFace]
insertf VertexMap [TileFace]
vfmap TileFace
f = (Vertex -> VertexMap [TileFace] -> VertexMap [TileFace])
-> VertexMap [TileFace] -> [Vertex] -> VertexMap [TileFace]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Maybe [TileFace] -> Maybe [TileFace])
-> Vertex -> VertexMap [TileFace] -> VertexMap [TileFace]
forall a. (Maybe a -> Maybe a) -> Vertex -> IntMap a -> IntMap a
VMap.alter Maybe [TileFace] -> Maybe [TileFace]
addf) VertexMap [TileFace]
vfmap (TileFace -> [Vertex]
faceVList TileFace
f)
where addf :: Maybe [TileFace] -> Maybe [TileFace]
addf Maybe [TileFace]
Nothing = Maybe [TileFace]
forall a. Maybe a
Nothing
addf (Just [TileFace]
fs) = [TileFace] -> Maybe [TileFace]
forall a. a -> Maybe a
Just (TileFace
fTileFace -> [TileFace] -> [TileFace]
forall a. a -> [a] -> [a]
:[TileFace]
fs)
dedgesFacesMap:: [Dedge] -> [TileFace] -> Map.Map Dedge TileFace
dedgesFacesMap :: [Dedge] -> [TileFace] -> Map Dedge TileFace
dedgesFacesMap [Dedge]
des [TileFace]
fcs = [(Dedge, TileFace)] -> Map Dedge TileFace
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Dedge] -> [(Dedge, TileFace)]
assocFaces [Dedge]
des) where
vs :: [Vertex]
vs = (Dedge -> Vertex) -> [Dedge] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Vertex
forall a b. (a, b) -> a
fst [Dedge]
des [Vertex] -> [Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a] -> [a]
`union` (Dedge -> Vertex) -> [Dedge] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Vertex
forall a b. (a, b) -> b
snd [Dedge]
des
vfMap :: VertexMap [TileFace]
vfMap = [Vertex] -> [TileFace] -> VertexMap [TileFace]
vertexFacesMap [Vertex]
vs [TileFace]
fcs
assocFaces :: [Dedge] -> [(Dedge, TileFace)]
assocFaces [] = []
assocFaces (d :: Dedge
d@(Vertex
a,Vertex
b):[Dedge]
more) = case (Vertex -> VertexMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
a VertexMap [TileFace]
vfMap, Vertex -> VertexMap [TileFace] -> Maybe [TileFace]
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
b VertexMap [TileFace]
vfMap) of
(Just [TileFace]
fcs1, Just [TileFace]
fcs2) -> case (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (TileFace -> Dedge -> Bool
`hasDedge` Dedge
d) ([TileFace] -> [TileFace]) -> [TileFace] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ [TileFace]
fcs1 [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [TileFace]
fcs2 of
[TileFace
face] -> (Dedge
d,TileFace
face)(Dedge, TileFace) -> [(Dedge, TileFace)] -> [(Dedge, TileFace)]
forall a. a -> [a] -> [a]
:[Dedge] -> [(Dedge, TileFace)]
assocFaces [Dedge]
more
[] -> [Dedge] -> [(Dedge, TileFace)]
assocFaces [Dedge]
more
[TileFace]
_ -> String -> [(Dedge, TileFace)]
forall a. HasCallStack => String -> a
error (String -> [(Dedge, TileFace)]) -> String -> [(Dedge, TileFace)]
forall a b. (a -> b) -> a -> b
$ String
"dedgesFacesMap: more than one Tileface has the same directed edge: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show Dedge
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
(Maybe [TileFace], Maybe [TileFace])
_ -> [Dedge] -> [(Dedge, TileFace)]
assocFaces [Dedge]
more
buildEFMap:: [TileFace] -> Map.Map Dedge TileFace
buildEFMap :: [TileFace] -> Map Dedge TileFace
buildEFMap = [(Dedge, TileFace)] -> Map Dedge TileFace
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Dedge, TileFace)] -> Map Dedge TileFace)
-> ([TileFace] -> [(Dedge, TileFace)])
-> [TileFace]
-> Map Dedge TileFace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TileFace -> [(Dedge, TileFace)])
-> [TileFace] -> [(Dedge, TileFace)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TileFace -> [(Dedge, TileFace)]
assignFace where
assignFace :: TileFace -> [(Dedge, TileFace)]
assignFace TileFace
f = (Dedge -> (Dedge, TileFace)) -> [Dedge] -> [(Dedge, TileFace)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,TileFace
f) (TileFace -> [Dedge]
faceDedges TileFace
f)
faceForEdge :: Dedge -> Map.Map Dedge TileFace -> Maybe TileFace
faceForEdge :: Dedge -> Map Dedge TileFace -> Maybe TileFace
faceForEdge = Dedge -> Map Dedge TileFace -> Maybe TileFace
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
edgeNbs:: TileFace -> Map.Map Dedge TileFace -> [TileFace]
edgeNbs :: TileFace -> Map Dedge TileFace -> [TileFace]
edgeNbs TileFace
face Map Dedge TileFace
efMap = (Dedge -> Maybe TileFace) -> [Dedge] -> [TileFace]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dedge -> Maybe TileFace
getNbr [Dedge]
edges where
getNbr :: Dedge -> Maybe TileFace
getNbr Dedge
e = Dedge -> Map Dedge TileFace -> Maybe TileFace
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Dedge
e Map Dedge TileFace
efMap
edges :: [Dedge]
edges = (Dedge -> Dedge) -> [Dedge] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Dedge
reverseD ([Dedge] -> [Dedge]) -> [Dedge] -> [Dedge]
forall a b. (a -> b) -> a -> b
$ TileFace -> [Dedge]
faceDedges TileFace
face
extractLowestJoin:: [TileFace] -> (TileFace,[TileFace])
[TileFace]
fcs
| [TileFace] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TileFace]
fcs = String -> (TileFace, [TileFace])
forall a. HasCallStack => String -> a
error String
"extractLowestJoin: applied to empty list of faces"
| Bool
otherwise = (TileFace
face, [TileFace]
fcs[TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\[TileFace
face])
where a :: Vertex
a = [Vertex] -> Vertex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
originV [TileFace]
fcs)
aFaces :: [TileFace]
aFaces = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex
aVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
originV) [TileFace]
fcs
b :: Vertex
b = [Vertex] -> Vertex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
oppV [TileFace]
aFaces)
face :: TileFace
face = case (TileFace -> Bool) -> [TileFace] -> Maybe TileFace
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (((Vertex
a,Vertex
b)Dedge -> Dedge -> Bool
forall a. Eq a => a -> a -> Bool
==) (Dedge -> Bool) -> (TileFace -> Dedge) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Dedge
joinOfTile) [TileFace]
aFaces of
Just TileFace
f -> TileFace
f
Maybe TileFace
Nothing -> String -> TileFace
forall a. HasCallStack => String -> a
error (String -> TileFace) -> String -> TileFace
forall a b. (a -> b) -> a -> b
$ String
"extractLowestJoin: no face fond at "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with opp vertex at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
lowestJoin:: [TileFace] -> Dedge
lowestJoin :: [TileFace] -> Dedge
lowestJoin [TileFace]
fcs | [TileFace] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TileFace]
fcs = String -> Dedge
forall a. HasCallStack => String -> a
error String
"lowestJoin: applied to empty list of faces"
lowestJoin [TileFace]
fcs = (Vertex
a,Vertex
b) where
a :: Vertex
a = [Vertex] -> Vertex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
originV [TileFace]
fcs)
aFaces :: [TileFace]
aFaces = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Vertex
aVertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
==) (Vertex -> Bool) -> (TileFace -> Vertex) -> TileFace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileFace -> Vertex
originV) [TileFace]
fcs
b :: Vertex
b = [Vertex] -> Vertex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((TileFace -> Vertex) -> [TileFace] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Vertex
oppV [TileFace]
aFaces)
type VertexLocMap = VMap.IntMap (Point V2 Double)
data VPatch = VPatch {VPatch -> VertexLocMap
vLocs :: VertexLocMap, VPatch -> [TileFace]
vpFaces::[TileFace]} deriving Vertex -> VPatch -> ShowS
[VPatch] -> ShowS
VPatch -> String
(Vertex -> VPatch -> ShowS)
-> (VPatch -> String) -> ([VPatch] -> ShowS) -> Show VPatch
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> VPatch -> ShowS
showsPrec :: Vertex -> VPatch -> ShowS
$cshow :: VPatch -> String
show :: VPatch -> String
$cshowList :: [VPatch] -> ShowS
showList :: [VPatch] -> ShowS
Show
type instance V VPatch = V2
type instance N VPatch = Double
instance Transformable VPatch where
transform :: Transformation (V VPatch) (N VPatch) -> VPatch -> VPatch
transform Transformation (V VPatch) (N VPatch)
t VPatch
vp = VPatch
vp {vLocs :: VertexLocMap
vLocs = (Point V2 Double -> Point V2 Double)
-> VertexLocMap -> VertexLocMap
forall a b. (a -> b) -> IntMap a -> IntMap b
VMap.map (Transformation (V (Point V2 Double)) (N (Point V2 Double))
-> Point V2 Double -> Point V2 Double
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Point V2 Double)) (N (Point V2 Double))
Transformation (V VPatch) (N VPatch)
t) (VPatch -> VertexLocMap
vLocs VPatch
vp)}
makeVP::Tgraph -> VPatch
makeVP :: Tgraph -> VPatch
makeVP Tgraph
g = VPatch {vLocs :: VertexLocMap
vLocs = [TileFace] -> VertexLocMap
locateVertices [TileFace]
fcs, vpFaces :: [TileFace]
vpFaces = [TileFace]
fcs} where fcs :: [TileFace]
fcs = Tgraph -> [TileFace]
faces Tgraph
g
subVP:: VPatch -> [TileFace] -> VPatch
subVP :: VPatch -> [TileFace] -> VPatch
subVP VPatch
vp [TileFace]
fcs = VPatch
vp {vpFaces :: [TileFace]
vpFaces = [TileFace]
fcs}
relevantVP :: VPatch -> VPatch
relevantVP :: VPatch -> VPatch
relevantVP VPatch
vp
| [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
diffList = VPatch
vp{vLocs :: VertexLocMap
vLocs = VertexLocMap
locVs}
| Bool
otherwise = String -> VPatch
forall a. HasCallStack => String -> a
error (String -> VPatch) -> String -> VPatch
forall a b. (a -> b) -> a -> b
$ String
"relevantVP: missing locations for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
[Vertex] -> String
forall a. Show a => a -> String
show [Vertex]
diffList String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
where
vs :: VertexSet
vs = [TileFace] -> VertexSet
facesVSet (VPatch -> [TileFace]
vpFaces VPatch
vp)
source :: VertexSet
source = VertexLocMap -> VertexSet
forall a. IntMap a -> VertexSet
VMap.keysSet VertexLocMap
locVs
diffList :: [Vertex]
diffList = VertexSet -> [Vertex]
IntSet.toList (VertexSet -> [Vertex]) -> VertexSet -> [Vertex]
forall a b. (a -> b) -> a -> b
$ VertexSet -> VertexSet -> VertexSet
IntSet.difference VertexSet
vs VertexSet
source
locVs :: VertexLocMap
locVs = (Vertex -> Point V2 Double -> Bool) -> VertexLocMap -> VertexLocMap
forall a. (Vertex -> a -> Bool) -> IntMap a -> IntMap a
VMap.filterWithKey (\ Vertex
v Point V2 Double
_ -> Vertex
v Vertex -> VertexSet -> Bool
`IntSet.member` VertexSet
vs) (VertexLocMap -> VertexLocMap) -> VertexLocMap -> VertexLocMap
forall a b. (a -> b) -> a -> b
$ VPatch -> VertexLocMap
vLocs VPatch
vp
restrictVP:: VPatch -> [TileFace] -> VPatch
restrictVP :: VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp [TileFace]
fcs = VPatch -> VPatch
relevantVP (VPatch -> [TileFace] -> VPatch
subVP VPatch
vp [TileFace]
fcs)
graphFromVP:: VPatch -> Tgraph
graphFromVP :: VPatch -> Tgraph
graphFromVP = [TileFace] -> Tgraph
checkedTgraph ([TileFace] -> Tgraph)
-> (VPatch -> [TileFace]) -> VPatch -> Tgraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> [TileFace]
vpFaces
removeFacesVP :: VPatch -> [TileFace] -> VPatch
removeFacesVP :: VPatch -> [TileFace] -> VPatch
removeFacesVP VPatch
vp [TileFace]
fcs = VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp (VPatch -> [TileFace]
vpFaces VPatch
vp [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TileFace]
fcs)
selectFacesVP:: VPatch -> [TileFace] -> VPatch
selectFacesVP :: VPatch -> [TileFace] -> VPatch
selectFacesVP VPatch
vp [TileFace]
fcs = VPatch -> [TileFace] -> VPatch
restrictVP VPatch
vp ([TileFace]
fcs [TileFace] -> [TileFace] -> [TileFace]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` VPatch -> [TileFace]
vpFaces VPatch
vp)
findLoc :: Vertex -> VPatch -> Maybe (Point V2 Double)
findLoc :: Vertex -> VPatch -> Maybe (Point V2 Double)
findLoc Vertex
v = Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v (VertexLocMap -> Maybe (Point V2 Double))
-> (VPatch -> VertexLocMap) -> VPatch -> Maybe (Point V2 Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> VertexLocMap
vLocs
instance Drawable VPatch where
drawWith :: forall b.
Renderable (Path V2 Double) b =>
(Piece -> Diagram2D b) -> VPatch -> Diagram2D b
drawWith Piece -> Diagram2D b
pd VPatch
vp = (Piece -> Diagram2D b) -> Patch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
(Piece -> Diagram2D b) -> Patch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
(Piece -> Diagram2D b) -> a -> Diagram2D b
drawWith Piece -> Diagram2D b
pd (VPatch -> Patch
dropLabels VPatch
vp)
dropLabels :: VPatch -> Patch
dropLabels :: VPatch -> Patch
dropLabels VPatch
vp = (TileFace -> Located Piece) -> [TileFace] -> Patch
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TileFace -> Located Piece
convert (VPatch -> [TileFace]
vpFaces VPatch
vp) where
locations :: VertexLocMap
locations = VPatch -> VertexLocMap
vLocs VPatch
vp
convert :: TileFace -> Located Piece
convert TileFace
face = case (Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup (TileFace -> Vertex
originV TileFace
face) VertexLocMap
locations , Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup (TileFace -> Vertex
oppV TileFace
face) VertexLocMap
locations) of
(Just Point V2 Double
p, Just Point V2 Double
p') -> ((Vertex, Vertex, Vertex) -> V2 Double) -> TileFace -> Piece
forall a b. (a -> b) -> HalfTile a -> HalfTile b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (V2 Double -> (Vertex, Vertex, Vertex) -> V2 Double
forall a b. a -> b -> a
const (Point V2 Double
p' Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
p)) TileFace
face Piece -> Point (V Piece) (N Piece) -> Located Piece
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V Piece) (N Piece)
Point V2 Double
p
(Maybe (Point V2 Double), Maybe (Point V2 Double))
_ -> String -> Located Piece
forall a. HasCallStack => String -> a
error (String -> Located Piece) -> String -> Located Piece
forall a b. (a -> b) -> a -> b
$ String
"dropLabels: Vertex location not found for some vertices:\n "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Vertex] -> String
forall a. Show a => a -> String
show (TileFace -> [Vertex]
faceVList TileFace
face [Vertex] -> [Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a] -> [a]
\\ VertexLocMap -> [Vertex]
forall a. IntMap a -> [Vertex]
VMap.keys VertexLocMap
locations) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
instance Drawable Tgraph where
drawWith :: forall b.
Renderable (Path V2 Double) b =>
(Piece -> Diagram2D b) -> Tgraph -> Diagram2D b
drawWith Piece -> Diagram2D b
pd = (Piece -> Diagram2D b) -> VPatch -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
(Piece -> Diagram2D b) -> VPatch -> Diagram2D b
forall a b.
(Drawable a, Renderable (Path V2 Double) b) =>
(Piece -> Diagram2D b) -> a -> Diagram2D b
drawWith Piece -> Diagram2D b
pd (VPatch -> Diagram2D b)
-> (Tgraph -> VPatch) -> Tgraph -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> VPatch
makeVP
class DrawableLabelled a where
labelColourSize :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) =>
Colour Double -> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
instance DrawableLabelled VPatch where
labelColourSize :: forall b.
(Renderable (Path V2 Double) b, Renderable (Text Double) b) =>
Colour Double
-> Measure Double
-> (Patch -> Diagram2D b)
-> VPatch
-> Diagram2D b
labelColourSize Colour Double
c Measure Double
m Patch -> QDiagram b V2 Double Any
d VPatch
vp = VertexLocMap -> QDiagram b V2 Double Any
drawLabels (VPatch -> VertexLocMap
vLocs VPatch
vp) QDiagram b V2 Double Any
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a. Semigroup a => a -> a -> a
<> Patch -> QDiagram b V2 Double Any
d (VPatch -> Patch
dropLabels VPatch
vp) where
drawLabels :: VertexLocMap -> QDiagram b V2 Double Any
drawLabels VertexLocMap
vpMap = [(Point V2 Double, QDiagram b V2 Double Any)]
-> QDiagram b V2 Double Any
forall (v :: * -> *) n a.
(InSpace v n a, HasOrigin a, Monoid' a) =>
[(Point v n, a)] -> a
position ([(Point V2 Double, QDiagram b V2 Double Any)]
-> QDiagram b V2 Double Any)
-> [(Point V2 Double, QDiagram b V2 Double Any)]
-> QDiagram b V2 Double Any
forall a b. (a -> b) -> a -> b
$ (Vertex, Point V2 Double)
-> (Point V2 Double, QDiagram b V2 Double Any)
drawlabel ((Vertex, Point V2 Double)
-> (Point V2 Double, QDiagram b V2 Double Any))
-> [(Vertex, Point V2 Double)]
-> [(Point V2 Double, QDiagram b V2 Double Any)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VertexLocMap -> [(Vertex, Point V2 Double)]
forall a. IntMap a -> [(Vertex, a)]
VMap.toList VertexLocMap
vpMap
drawlabel :: (Vertex, Point V2 Double)
-> (Point V2 Double, QDiagram b V2 Double Any)
drawlabel(Vertex
v,Point V2 Double
p) = (Point V2 Double
p, String -> QDiagram b V2 Double Any
forall n b.
(TypeableFloat n, Renderable (Text n) b) =>
String -> QDiagram b V2 n Any
baselineText (Vertex -> String
forall a. Show a => a -> String
show Vertex
v) QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Measure Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall a n.
(N a ~ n, Typeable n, HasStyle a) =>
Measure n -> a -> a
fontSize Measure Double
m QDiagram b V2 Double Any
-> (QDiagram b V2 Double Any -> QDiagram b V2 Double Any)
-> QDiagram b V2 Double Any
forall a b. a -> (a -> b) -> b
# Colour Double
-> QDiagram b V2 Double Any -> QDiagram b V2 Double Any
forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc Colour Double
c)
instance DrawableLabelled Tgraph where
labelColourSize :: forall b.
(Renderable (Path V2 Double) b, Renderable (Text Double) b) =>
Colour Double
-> Measure Double
-> (Patch -> Diagram2D b)
-> Tgraph
-> Diagram2D b
labelColourSize Colour Double
c Measure Double
r Patch -> Diagram2D b
d = Colour Double
-> Measure Double
-> (Patch -> Diagram2D b)
-> VPatch
-> Diagram2D b
forall b.
(Renderable (Path V2 Double) b, Renderable (Text Double) b) =>
Colour Double
-> Measure Double
-> (Patch -> Diagram2D b)
-> VPatch
-> Diagram2D b
forall a b.
(DrawableLabelled a, Renderable (Path V2 Double) b,
Renderable (Text Double) b) =>
Colour Double
-> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
labelColourSize Colour Double
c Measure Double
r Patch -> Diagram2D b
d (VPatch -> Diagram2D b)
-> (Tgraph -> VPatch) -> Tgraph -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> VPatch
makeVP
labelSize :: (Renderable (Path V2 Double) b, Renderable (Text Double) b, DrawableLabelled a) =>
Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
labelSize :: forall b a.
(Renderable (Path V2 Double) b, Renderable (Text Double) b,
DrawableLabelled a) =>
Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
labelSize = Colour Double
-> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
forall b.
(Renderable (Path V2 Double) b, Renderable (Text Double) b) =>
Colour Double
-> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
forall a b.
(DrawableLabelled a, Renderable (Path V2 Double) b,
Renderable (Text Double) b) =>
Colour Double
-> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
labelColourSize Colour Double
forall a. (Ord a, Floating a) => Colour a
red
labelled :: (Renderable (Path V2 Double) b, Renderable (Text Double) b, DrawableLabelled a) =>
(Patch -> Diagram2D b) -> a -> Diagram2D b
labelled :: forall b a.
(Renderable (Path V2 Double) b, Renderable (Text Double) b,
DrawableLabelled a) =>
(Patch -> Diagram2D b) -> a -> Diagram2D b
labelled = Colour Double
-> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
forall b.
(Renderable (Path V2 Double) b, Renderable (Text Double) b) =>
Colour Double
-> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
forall a b.
(DrawableLabelled a, Renderable (Path V2 Double) b,
Renderable (Text Double) b) =>
Colour Double
-> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b
labelColourSize Colour Double
forall a. (Ord a, Floating a) => Colour a
red Measure Double
forall n. OrderedField n => Measure n
small
rotateBefore :: (VPatch -> a) -> Angle Double -> Tgraph -> a
rotateBefore :: forall a. (VPatch -> a) -> Angle Double -> Tgraph -> a
rotateBefore VPatch -> a
vfun Angle Double
angle = VPatch -> a
vfun (VPatch -> a) -> (Tgraph -> VPatch) -> Tgraph -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Angle Double -> VPatch -> VPatch
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle Double
angle (VPatch -> VPatch) -> (Tgraph -> VPatch) -> Tgraph -> VPatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> VPatch
makeVP
centerOn :: Vertex -> VPatch -> VPatch
centerOn :: Vertex -> VPatch -> VPatch
centerOn Vertex
a VPatch
vp =
case Vertex -> VPatch -> Maybe (Point V2 Double)
findLoc Vertex
a VPatch
vp of
Just Point V2 Double
loca -> Vn VPatch -> VPatch -> VPatch
forall t. Transformable t => Vn t -> t -> t
translate (Point V2 Double
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loca) VPatch
vp
Maybe (Point V2 Double)
_ -> String -> VPatch
forall a. HasCallStack => String -> a
error (String -> VPatch) -> String -> VPatch
forall a b. (a -> b) -> a -> b
$ String
"centerOn: vertex not found (Vertex " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")\n"
alignXaxis :: (Vertex, Vertex) -> VPatch -> VPatch
alignXaxis :: Dedge -> VPatch -> VPatch
alignXaxis (Vertex
a,Vertex
b) VPatch
vp = Angle Double -> VPatch -> VPatch
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle Double
angle VPatch
newvp
where newvp :: VPatch
newvp = Vertex -> VPatch -> VPatch
centerOn Vertex
a VPatch
vp
angle :: Angle Double
angle = Direction V2 Double -> Direction V2 Double -> Angle Double
forall n.
RealFloat n =>
Direction V2 n -> Direction V2 n -> Angle n
signedAngleBetweenDirs (V2 Double -> Direction V2 Double
forall (v :: * -> *) n. v n -> Direction v n
direction V2 Double
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX) (V2 Double -> Direction V2 Double
forall (v :: * -> *) n. v n -> Direction v n
direction (Point V2 Double
locb Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin))
locb :: Point V2 Double
locb = case Vertex -> VPatch -> Maybe (Point V2 Double)
findLoc Vertex
b VPatch
newvp of
Just Point V2 Double
l -> Point V2 Double
l
Maybe (Point V2 Double)
Nothing -> String -> Point V2 Double
forall a. HasCallStack => String -> a
error (String -> Point V2 Double) -> String -> Point V2 Double
forall a b. (a -> b) -> a -> b
$ String
"alignXaxis: second alignment vertex not found (Vertex " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vertex -> String
forall a. Show a => a -> String
show Vertex
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")\n"
alignments :: [(Vertex, Vertex)] -> [VPatch] -> [VPatch]
alignments :: [Dedge] -> [VPatch] -> [VPatch]
alignments [] [VPatch]
vps = [VPatch]
vps
alignments [Dedge]
_ [] = String -> [VPatch]
forall a. HasCallStack => String -> a
error String
"alignments: Too many alignment pairs.\n"
alignments ((Vertex
a,Vertex
b):[Dedge]
more) (VPatch
vp:[VPatch]
vps) = Dedge -> VPatch -> VPatch
alignXaxis (Vertex
a,Vertex
b) VPatch
vp VPatch -> [VPatch] -> [VPatch]
forall a. a -> [a] -> [a]
: [Dedge] -> [VPatch] -> [VPatch]
alignments [Dedge]
more [VPatch]
vps
alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch]
alignAll :: Dedge -> [VPatch] -> [VPatch]
alignAll (Vertex
a,Vertex
b) = (VPatch -> VPatch) -> [VPatch] -> [VPatch]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dedge -> VPatch -> VPatch
alignXaxis (Vertex
a,Vertex
b))
alignBefore :: (VPatch -> a) -> (Vertex,Vertex) -> Tgraph -> a
alignBefore :: forall a. (VPatch -> a) -> Dedge -> Tgraph -> a
alignBefore VPatch -> a
vfun Dedge
vs = VPatch -> a
vfun (VPatch -> a) -> (Tgraph -> VPatch) -> Tgraph -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dedge -> VPatch -> VPatch
alignXaxis Dedge
vs (VPatch -> VPatch) -> (Tgraph -> VPatch) -> Tgraph -> VPatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tgraph -> VPatch
makeVP
makeAlignedVP:: (Vertex,Vertex) -> Tgraph -> VPatch
makeAlignedVP :: Dedge -> Tgraph -> VPatch
makeAlignedVP = (VPatch -> VPatch) -> Dedge -> Tgraph -> VPatch
forall a. (VPatch -> a) -> Dedge -> Tgraph -> a
alignBefore VPatch -> VPatch
forall a. a -> a
id
drawEdgesVP :: Renderable (Path V2 Double) b =>
VPatch -> [Dedge] -> Diagram2D b
drawEdgesVP :: forall b.
Renderable (Path V2 Double) b =>
VPatch -> [Dedge] -> Diagram2D b
drawEdgesVP = VertexLocMap -> [Dedge] -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
VertexLocMap -> [Dedge] -> Diagram2D b
drawEdges (VertexLocMap -> [Dedge] -> Diagram2D b)
-> (VPatch -> VertexLocMap) -> VPatch -> [Dedge] -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> VertexLocMap
vLocs
drawEdgeVP:: Renderable (Path V2 Double) b =>
VPatch -> Dedge -> Diagram2D b
drawEdgeVP :: forall b.
Renderable (Path V2 Double) b =>
VPatch -> Dedge -> Diagram2D b
drawEdgeVP = VertexLocMap -> Dedge -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
VertexLocMap -> Dedge -> Diagram2D b
drawEdge (VertexLocMap -> Dedge -> Diagram2D b)
-> (VPatch -> VertexLocMap) -> VPatch -> Dedge -> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VPatch -> VertexLocMap
vLocs
drawEdges :: Renderable (Path V2 Double) b =>
VertexLocMap -> [Dedge] -> Diagram2D b
drawEdges :: forall b.
Renderable (Path V2 Double) b =>
VertexLocMap -> [Dedge] -> Diagram2D b
drawEdges = (Dedge -> Diagram2D b) -> [Dedge] -> Diagram2D b
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Dedge -> Diagram2D b) -> [Dedge] -> Diagram2D b)
-> (VertexLocMap -> Dedge -> Diagram2D b)
-> VertexLocMap
-> [Dedge]
-> Diagram2D b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VertexLocMap -> Dedge -> Diagram2D b
forall b.
Renderable (Path V2 Double) b =>
VertexLocMap -> Dedge -> Diagram2D b
drawEdge
drawEdge :: Renderable (Path V2 Double) b =>
VertexLocMap -> Dedge -> Diagram2D b
drawEdge :: forall b.
Renderable (Path V2 Double) b =>
VertexLocMap -> Dedge -> Diagram2D b
drawEdge VertexLocMap
vpMap (Vertex
a,Vertex
b) = case (Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
a VertexLocMap
vpMap, Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
b VertexLocMap
vpMap) of
(Just Point V2 Double
pa, Just Point V2 Double
pb) -> Point V2 Double
pa Point V2 Double -> Point V2 Double -> Diagram2D b
forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, TrailLike t) =>
Point v n -> Point v n -> t
~~ Point V2 Double
pb
(Maybe (Point V2 Double), Maybe (Point V2 Double))
_ -> String -> Diagram2D b
forall a. HasCallStack => String -> a
error (String -> Diagram2D b) -> String -> Diagram2D b
forall a b. (a -> b) -> a -> b
$ String
"drawEdge: location not found for one or both vertices "String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dedge -> String
forall a. Show a => a -> String
show(Vertex
a,Vertex
b) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
locateVertices:: [TileFace] -> VertexLocMap
locateVertices :: [TileFace] -> VertexLocMap
locateVertices [] = VertexLocMap
forall a. IntMap a
VMap.empty
locateVertices [TileFace]
fcs = [TileFace] -> Set TileFace -> VertexLocMap -> VertexLocMap
fastAddVPoints [TileFace
joinFace] ([TileFace] -> Set TileFace
forall a. Ord a => [a] -> Set a
Set.fromList [TileFace]
more) (TileFace -> VertexLocMap
axisJoin TileFace
joinFace) where
(TileFace
joinFace,[TileFace]
more) = [TileFace] -> (TileFace, [TileFace])
extractLowestJoin [TileFace]
fcs
efMap :: Map Dedge TileFace
efMap = [TileFace] -> Map Dedge TileFace
buildEFMap [TileFace]
fcs
fastAddVPoints :: [TileFace] -> Set TileFace -> VertexLocMap -> VertexLocMap
fastAddVPoints [] Set TileFace
fcOther VertexLocMap
vpMap | Set TileFace -> Bool
forall a. Set a -> Bool
Set.null Set TileFace
fcOther = VertexLocMap
vpMap
fastAddVPoints [] Set TileFace
fcOther VertexLocMap
_ = String -> VertexLocMap
forall a. HasCallStack => String -> a
error (String -> VertexLocMap) -> String -> VertexLocMap
forall a b. (a -> b) -> a -> b
$ String
"locateVertices (fastAddVPoints): Faces not tile-connected: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set TileFace -> String
forall a. Show a => a -> String
show Set TileFace
fcOther String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/n"
fastAddVPoints (TileFace
face:[TileFace]
fs) Set TileFace
fcOther VertexLocMap
vpMap = [TileFace] -> Set TileFace -> VertexLocMap -> VertexLocMap
fastAddVPoints ([TileFace]
fs[TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++[TileFace]
nbs) Set TileFace
fcOther' VertexLocMap
vpMap' where
nbs :: [TileFace]
nbs = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (TileFace -> Set TileFace -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TileFace
fcOther) (TileFace -> Map Dedge TileFace -> [TileFace]
edgeNbs TileFace
face Map Dedge TileFace
efMap)
fcOther' :: Set TileFace
fcOther' = (Set TileFace -> TileFace -> Set TileFace)
-> Set TileFace -> [TileFace] -> Set TileFace
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((TileFace -> Set TileFace -> Set TileFace)
-> Set TileFace -> TileFace -> Set TileFace
forall a b c. (a -> b -> c) -> b -> a -> c
flip TileFace -> Set TileFace -> Set TileFace
forall a. Ord a => a -> Set a -> Set a
Set.delete) Set TileFace
fcOther [TileFace]
nbs
vpMap' :: VertexLocMap
vpMap' = TileFace -> VertexLocMap -> VertexLocMap
addVPoint TileFace
face VertexLocMap
vpMap
addVPoint:: TileFace -> VertexLocMap -> VertexLocMap
addVPoint :: TileFace -> VertexLocMap -> VertexLocMap
addVPoint TileFace
face VertexLocMap
vpMap =
case TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double)
thirdVertexLoc TileFace
face VertexLocMap
vpMap of
Just (Vertex
v,Point V2 Double
p) -> Vertex -> Point V2 Double -> VertexLocMap -> VertexLocMap
forall a. Vertex -> a -> IntMap a -> IntMap a
VMap.insert Vertex
v Point V2 Double
p VertexLocMap
vpMap
Maybe (Vertex, Point V2 Double)
Nothing -> VertexLocMap
vpMap
axisJoin::TileFace -> VertexLocMap
axisJoin :: TileFace -> VertexLocMap
axisJoin TileFace
face =
Vertex -> Point V2 Double -> VertexLocMap -> VertexLocMap
forall a. Vertex -> a -> IntMap a -> IntMap a
VMap.insert (TileFace -> Vertex
originV TileFace
face) Point V2 Double
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin (VertexLocMap -> VertexLocMap) -> VertexLocMap -> VertexLocMap
forall a b. (a -> b) -> a -> b
$ Vertex -> Point V2 Double -> VertexLocMap -> VertexLocMap
forall a. Vertex -> a -> IntMap a -> IntMap a
VMap.insert (TileFace -> Vertex
oppV TileFace
face) ((Double, Double) -> Point V2 Double
forall n. (n, n) -> P2 n
p2(Double
x,Double
0)) VertexLocMap
forall a. IntMap a
VMap.empty where
x :: Double
x = if TileFace -> Bool
forall rep. HalfTile rep -> Bool
isDart TileFace
face then Double
1 else Double
phi
find3Locs::(Vertex,Vertex,Vertex) -> VertexLocMap
-> (Maybe (Point V2 Double),Maybe (Point V2 Double),Maybe (Point V2 Double))
find3Locs :: (Vertex, Vertex, Vertex)
-> VertexLocMap
-> (Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
find3Locs (Vertex
v1,Vertex
v2,Vertex
v3) VertexLocMap
vpMap = (Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v1 VertexLocMap
vpMap, Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v2 VertexLocMap
vpMap, Vertex -> VertexLocMap -> Maybe (Point V2 Double)
forall a. Vertex -> IntMap a -> Maybe a
VMap.lookup Vertex
v3 VertexLocMap
vpMap)
thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double)
thirdVertexLoc :: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double)
thirdVertexLoc face :: TileFace
face@(LD (Vertex, Vertex, Vertex)
_) VertexLocMap
vpMap = case (Vertex, Vertex, Vertex)
-> VertexLocMap
-> (Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
find3Locs (TileFace -> (Vertex, Vertex, Vertex)
faceVs TileFace
face) VertexLocMap
vpMap of
(Just Point V2 Double
loc1, Just Point V2 Double
loc2, Maybe (Point V2 Double)
Nothing) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
wingV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
9) (Point V2 Double
loc2 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc2, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
originV TileFace
face, Point V2 Double
loc2 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
7) (Point V2 Double
loc3 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc2))
(Just Point V2 Double
loc1, Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
oppV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
1) (Point V2 Double
loc3 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Just Point V2 Double
_ , Just Point V2 Double
_ , Just Point V2 Double
_) -> Maybe (Vertex, Point V2 Double)
forall a. Maybe a
Nothing
(Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
_ -> String -> Maybe (Vertex, Point V2 Double)
forall a. HasCallStack => String -> a
error (String -> Maybe (Vertex, Point V2 Double))
-> String -> Maybe (Vertex, Point V2 Double)
forall a b. (a -> b) -> a -> b
$ String
"thirdVertexLoc: face not tile-connected?: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
face String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
thirdVertexLoc face :: TileFace
face@(RD (Vertex, Vertex, Vertex)
_) VertexLocMap
vpMap = case (Vertex, Vertex, Vertex)
-> VertexLocMap
-> (Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
find3Locs (TileFace -> (Vertex, Vertex, Vertex)
faceVs TileFace
face) VertexLocMap
vpMap of
(Just Point V2 Double
loc1, Just Point V2 Double
loc2, Maybe (Point V2 Double)
Nothing) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
oppV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
9) (Point V2 Double
loc2 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc2, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
originV TileFace
face, Point V2 Double
loc3 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
3) (Point V2 Double
loc2 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc3))
(Just Point V2 Double
loc1, Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
wingV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
1) (Point V2 Double
loc3 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Just Point V2 Double
_ , Just Point V2 Double
_ , Just Point V2 Double
_) -> Maybe (Vertex, Point V2 Double)
forall a. Maybe a
Nothing
(Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
_ -> String -> Maybe (Vertex, Point V2 Double)
forall a. HasCallStack => String -> a
error (String -> Maybe (Vertex, Point V2 Double))
-> String -> Maybe (Vertex, Point V2 Double)
forall a b. (a -> b) -> a -> b
$ String
"thirdVertexLoc: face not tile-connected?: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
face String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
thirdVertexLoc face :: TileFace
face@(LK (Vertex, Vertex, Vertex)
_) VertexLocMap
vpMap = case (Vertex, Vertex, Vertex)
-> VertexLocMap
-> (Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
find3Locs (TileFace -> (Vertex, Vertex, Vertex)
faceVs TileFace
face) VertexLocMap
vpMap of
(Just Point V2 Double
loc1, Just Point V2 Double
loc2, Maybe (Point V2 Double)
Nothing) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
oppV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
9) (Point V2 Double
loc2 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc2, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
originV TileFace
face, Point V2 Double
loc2 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
8) (Point V2 Double
loc3 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc2))
(Just Point V2 Double
loc1, Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
wingV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
1) (Point V2 Double
loc3 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Just Point V2 Double
_ , Just Point V2 Double
_ , Just Point V2 Double
_) -> Maybe (Vertex, Point V2 Double)
forall a. Maybe a
Nothing
(Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
_ -> String -> Maybe (Vertex, Point V2 Double)
forall a. HasCallStack => String -> a
error (String -> Maybe (Vertex, Point V2 Double))
-> String -> Maybe (Vertex, Point V2 Double)
forall a b. (a -> b) -> a -> b
$ String
"thirdVertexLoc: face not tile-connected?: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
face String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
thirdVertexLoc face :: TileFace
face@(RK (Vertex, Vertex, Vertex)
_) VertexLocMap
vpMap = case (Vertex, Vertex, Vertex)
-> VertexLocMap
-> (Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
find3Locs (TileFace -> (Vertex, Vertex, Vertex)
faceVs TileFace
face) VertexLocMap
vpMap of
(Just Point V2 Double
loc1, Just Point V2 Double
loc2, Maybe (Point V2 Double)
Nothing) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
wingV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
9) (Point V2 Double
loc2 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc2, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
originV TileFace
face, Point V2 Double
loc2 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
8) (Point V2 Double
loc3 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc2))
(Just Point V2 Double
loc1, Maybe (Point V2 Double)
Nothing, Just Point V2 Double
loc3) -> (Vertex, Point V2 Double) -> Maybe (Vertex, Point V2 Double)
forall a. a -> Maybe a
Just (TileFace -> Vertex
oppV TileFace
face, Point V2 Double
loc1 Point V2 Double -> Diff (Point V2) Double -> Point V2 Double
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Double
Diff (Point V2) Double
v) where v :: V2 Double
v = Double
phiDouble -> V2 Double -> V2 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V2 Double -> V2 Double
forall a. Floating a => V2 a -> V2 a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (Angle Double -> V2 Double -> V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Vertex -> Angle Double
ttangle Vertex
1) (Point V2 Double
loc3 Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
loc1))
(Just Point V2 Double
_ , Just Point V2 Double
_ , Just Point V2 Double
_) -> Maybe (Vertex, Point V2 Double)
forall a. Maybe a
Nothing
(Maybe (Point V2 Double), Maybe (Point V2 Double),
Maybe (Point V2 Double))
_ -> String -> Maybe (Vertex, Point V2 Double)
forall a. HasCallStack => String -> a
error (String -> Maybe (Vertex, Point V2 Double))
-> String -> Maybe (Vertex, Point V2 Double)
forall a b. (a -> b) -> a -> b
$ String
"thirdVertexLoc: face not tile-connected?: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TileFace -> String
forall a. Show a => a -> String
show TileFace
face String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
touchingVertices:: [TileFace] -> [(Vertex,Vertex)]
touchingVertices :: [TileFace] -> [Dedge]
touchingVertices [TileFace]
fcs = [(Vertex, Point V2 Double)] -> [Dedge]
forall {b}. Eq b => [(b, Point V2 Double)] -> [(b, b)]
check [(Vertex, Point V2 Double)]
vpAssoc where
vpAssoc :: [(Vertex, Point V2 Double)]
vpAssoc = VertexLocMap -> [(Vertex, Point V2 Double)]
forall a. IntMap a -> [(Vertex, a)]
VMap.assocs (VertexLocMap -> [(Vertex, Point V2 Double)])
-> VertexLocMap -> [(Vertex, Point V2 Double)]
forall a b. (a -> b) -> a -> b
$ [TileFace] -> VertexLocMap
locateVertices [TileFace]
fcs
check :: [(b, Point V2 Double)] -> [(b, b)]
check [] = []
check ((b
v,Point V2 Double
p):[(b, Point V2 Double)]
more) = [(b
v1,b
v) | b
v1 <- [b]
nearv ] [(b, b)] -> [(b, b)] -> [(b, b)]
forall a. [a] -> [a] -> [a]
++ [(b, Point V2 Double)] -> [(b, b)]
check (((b, Point V2 Double) -> Bool)
-> [(b, Point V2 Double)] -> [(b, Point V2 Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> [b] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [b]
nearv)(b -> Bool)
-> ((b, Point V2 Double) -> b) -> (b, Point V2 Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(b, Point V2 Double) -> b
forall a b. (a, b) -> a
fst) [(b, Point V2 Double)]
more)
where nearv :: [b]
nearv = [b
v1 | (b
v1,Point V2 Double
p1) <- [(b, Point V2 Double)]
more, Point V2 Double -> Point V2 Double -> Bool
touching Point V2 Double
p Point V2 Double
p1 ]
touching :: Point V2 Double -> Point V2 Double -> Bool
touching :: Point V2 Double -> Point V2 Double -> Bool
touching Point V2 Double
p Point V2 Double
p1 = V2 Double -> Double
forall a. Num a => V2 a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance (Point V2 Double
p Point V2 Double -> Point V2 Double -> Diff (Point V2) Double
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 Double
p1) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.1
touchingVerticesGen:: [TileFace] -> [(Vertex,Vertex)]
touchingVerticesGen :: [TileFace] -> [Dedge]
touchingVerticesGen [TileFace]
fcs = [(Vertex, Point V2 Double)] -> [Dedge]
forall {b}. Eq b => [(b, Point V2 Double)] -> [(b, b)]
check [(Vertex, Point V2 Double)]
vpAssoc where
vpAssoc :: [(Vertex, Point V2 Double)]
vpAssoc = VertexLocMap -> [(Vertex, Point V2 Double)]
forall a. IntMap a -> [(Vertex, a)]
VMap.assocs (VertexLocMap -> [(Vertex, Point V2 Double)])
-> VertexLocMap -> [(Vertex, Point V2 Double)]
forall a b. (a -> b) -> a -> b
$ [TileFace] -> VertexLocMap
locateVerticesGen [TileFace]
fcs
check :: [(b, Point V2 Double)] -> [(b, b)]
check [] = []
check ((b
v,Point V2 Double
p):[(b, Point V2 Double)]
more) = [(b
v1,b
v) | b
v1 <- [b]
nearv ] [(b, b)] -> [(b, b)] -> [(b, b)]
forall a. [a] -> [a] -> [a]
++ [(b, Point V2 Double)] -> [(b, b)]
check (((b, Point V2 Double) -> Bool)
-> [(b, Point V2 Double)] -> [(b, Point V2 Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> [b] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [b]
nearv)(b -> Bool)
-> ((b, Point V2 Double) -> b) -> (b, Point V2 Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(b, Point V2 Double) -> b
forall a b. (a, b) -> a
fst) [(b, Point V2 Double)]
more)
where nearv :: [b]
nearv = [b
v1 | (b
v1,Point V2 Double
p1) <- [(b, Point V2 Double)]
more, Point V2 Double -> Point V2 Double -> Bool
touching Point V2 Double
p Point V2 Double
p1 ]
locateVerticesGen:: [TileFace] -> VertexLocMap
locateVerticesGen :: [TileFace] -> VertexLocMap
locateVerticesGen [] = VertexLocMap
forall a. IntMap a
VMap.empty
locateVerticesGen [TileFace]
fcs = [TileFace] -> Set TileFace -> VertexLocMap -> VertexLocMap
fastAddVPointsGen [TileFace
face] ([TileFace] -> Set TileFace
forall a. Ord a => [a] -> Set a
Set.fromList [TileFace]
more) (TileFace -> VertexLocMap
axisJoin TileFace
face) where
(TileFace
face,[TileFace]
more) = [TileFace] -> (TileFace, [TileFace])
extractLowestJoin [TileFace]
fcs
efMapGen :: Map Dedge [TileFace]
efMapGen = [TileFace] -> Map Dedge [TileFace]
forall {t :: * -> *}.
Foldable t =>
t TileFace -> Map Dedge [TileFace]
buildEFMapGen [TileFace]
fcs
fastAddVPointsGen :: [TileFace] -> Set TileFace -> VertexLocMap -> VertexLocMap
fastAddVPointsGen [] Set TileFace
fcOther VertexLocMap
vpMap | Set TileFace -> Bool
forall a. Set a -> Bool
Set.null Set TileFace
fcOther = VertexLocMap
vpMap
fastAddVPointsGen [] Set TileFace
fcOther VertexLocMap
_ = String -> VertexLocMap
forall a. HasCallStack => String -> a
error (String -> VertexLocMap) -> String -> VertexLocMap
forall a b. (a -> b) -> a -> b
$ String
"fastAddVPointsGen: Faces not tile-connected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set TileFace -> String
forall a. Show a => a -> String
show Set TileFace
fcOther String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
fastAddVPointsGen (TileFace
f:[TileFace]
fs) Set TileFace
fcOther VertexLocMap
vpMap = [TileFace] -> Set TileFace -> VertexLocMap -> VertexLocMap
fastAddVPointsGen ([TileFace]
fs[TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
++[TileFace]
nbs) Set TileFace
fcOther' VertexLocMap
vpMap' where
nbs :: [TileFace]
nbs = (TileFace -> Bool) -> [TileFace] -> [TileFace]
forall a. (a -> Bool) -> [a] -> [a]
filter (TileFace -> Set TileFace -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TileFace
fcOther) (TileFace -> [TileFace]
edgeNbsGen TileFace
f)
fcOther' :: Set TileFace
fcOther' = (TileFace -> Set TileFace -> Set TileFace)
-> Set TileFace -> [TileFace] -> Set TileFace
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TileFace -> Set TileFace -> Set TileFace
forall a. Ord a => a -> Set a -> Set a
Set.delete Set TileFace
fcOther [TileFace]
nbs
vpMap' :: VertexLocMap
vpMap' = TileFace -> VertexLocMap -> VertexLocMap
addVPoint TileFace
f VertexLocMap
vpMap
buildEFMapGen :: t TileFace -> Map Dedge [TileFace]
buildEFMapGen = ([TileFace] -> [TileFace] -> [TileFace])
-> [(Dedge, [TileFace])] -> Map Dedge [TileFace]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [TileFace] -> [TileFace] -> [TileFace]
forall a. [a] -> [a] -> [a]
(++) ([(Dedge, [TileFace])] -> Map Dedge [TileFace])
-> (t TileFace -> [(Dedge, [TileFace])])
-> t TileFace
-> Map Dedge [TileFace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TileFace -> [(Dedge, [TileFace])])
-> t TileFace -> [(Dedge, [TileFace])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TileFace -> [(Dedge, [TileFace])]
processFace
processFace :: TileFace -> [(Dedge, [TileFace])]
processFace TileFace
f = (,[TileFace
f]) (Dedge -> (Dedge, [TileFace])) -> [Dedge] -> [(Dedge, [TileFace])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TileFace -> [Dedge]
faceDedges TileFace
f
edgeNbsGen :: TileFace -> [TileFace]
edgeNbsGen TileFace
f = [[TileFace]] -> [TileFace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TileFace]] -> [TileFace]) -> [[TileFace]] -> [TileFace]
forall a b. (a -> b) -> a -> b
$ (Dedge -> Maybe [TileFace]) -> [Dedge] -> [[TileFace]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dedge -> Maybe [TileFace]
getNbrs [Dedge]
edges where
getNbrs :: Dedge -> Maybe [TileFace]
getNbrs Dedge
e = Dedge -> Map Dedge [TileFace] -> Maybe [TileFace]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Dedge
e Map Dedge [TileFace]
efMapGen
edges :: [Dedge]
edges = (Dedge -> Dedge) -> [Dedge] -> [Dedge]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dedge -> Dedge
reverseD (TileFace -> [Dedge]
faceDedges TileFace
f)