{-|
Module : Tgraph.Prelude
Description : Introducing types Tgraph, VPatch and drawing operations.
Copyright : (c) Chris Reade, 2021
License : BSD-style
Maintainer : chrisreade@mac.com
Stability : experimental
Introduces Tgraphs and includes operations on vertices, edges and faces as well as Tgraphs.
Plus VPatch (Vertex Patch) as intermediary between Tgraph and Diagram.
Conversions and drawing operations (producing Diagrams).
The module also includes functions to calculate (relative) locations of vertices,
and touching vertex checks (touchingVertices, touchingVerticesGen).
This module re-exports module HalfTile and module Try.
-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Strict #-}
module Tgraph.Prelude
( module HalfTile
, module Try
-- * Making Tgraphs
, Tgraph() -- not Data Constructor Tgraph
, TileFace
, makeTgraph
, tryMakeTgraph
, checkedTgraph
, makeUncheckedTgraph
, emptyTgraph
-- * Vertices and Edges
, Vertex
, VertexSet
, VertexMap
, Dedge
-- $Edges
, EdgeType(..)
-- * Tgraph Property Checks
-- , renumberFaces
-- , differing
, tryTgraphProps
, tryConnectedNoCross
, tryCorrectTouchingVs
-- , findEdgeLoops
, hasEdgeLoops
, duplicates
-- , duplicateInts
-- , conflictingDedges
, edgeType
--, findEdgeLoop
-- , sharedEdges
-- , newSharedEdges
, noNewConflict
-- unused , noNewConflictFull
-- , legal
-- , illegals
, illegalTiling
, crossingBVs
-- , crossingVertices
, crossingBoundaries
, connected
-- , connectedBy
-- * HasFaces operations
, HasFaces(..) -- faces, boundaryESet, maxV, boundaryVFMap
, boundaryEdgeSet
, boundary
-- , maxV
, dedgeSet
, dedges
, evalDedge
, evalDedges
, vertexSet
, vertices
, boundaryVSet
, boundaryVertexSet
, boundaryVsDup
, boundaryEFMap
, boundaryVFaces
, boundaryEFaces
, boundaryEdgeFaces
, boundaryJoinFaces
--, boundaryVFMap
-- , faces
, nullFaces
, evalFaces
, evalFace
, faceCount
, ldarts
, rdarts
, lkites
, rkites
, kites
, darts
, internalEdges
, phiEdges
, nonPhiEdges
, defaultAlignment
, selectFaces
, removeFaces
, removeVertices
, selectVertices
, vertexFMap
, vertexFacesMap
, dedgeFMap
, dedgesFacesMap
, buildEFMap
, extractLowestJoin
, lowestJoin
-- * Other Face ops
, faceForEdge
, edgeNbs
, edgeNb
, makeRD
, makeLD
, makeRK
, makeLK
, faceVs
, faceVList
, faceVSet
, firstV
, secondV
, thirdV
, originV
, wingV
, oppV
, indexV
, nextV
, prevV
, isAtV
, hasVIn
-- * Face and Edge ops
, faceDedges
, reverseD
, joinE
, shortE
, longE
, joinOfTile
, facePhiEdges
, faceNonPhiEdges
-- , matchingE
, matchingLongE
, matchingShortE
, matchingJoinE
, hasDedge
, hasDedgeIn
, completeEdgeSet
, completeEdges
, bothDirSet
, bothDir
-- , bothDirOneWay
, missingRevs
, missingRevSet
-- * VPatch and Conversions
, VPatch(..)
, VertexLocMap
, makeVP
, subFaces
, relevantVP
, restrictTo
, graphFromVP
, removeFacesFromVP
, removeVerticesFromVP
, selectVerticesFromVP
, findLoc
-- * Drawing Tgraphs and VPatches with Labels
, DrawableLabelled(..)
, labelSize
, labelled
, rotating
, rotateBefore
, dropLabels
-- * Tgraph and VPatch alignment with vertices
, aligning
, alignBefore
, makeAlignedVP
, centerOn
, alignXaxis
, alignments
, alignAll
-- * Drawing Edges
, drawEdgesVP
, drawEdgeVP
, drawLocatedEdges
, drawLocatedEdge
-- * Vertex Location and Touching Vertices
, locateGraphVertices
-- , locateVertices
, addVPoint
-- , axisJoin
-- , find3Locs
-- , thirdVertexLoc
, touchingVertices
-- , touching
, touchingVerticesGen
-- , locateVerticesGen
--, drawEdges
--, drawEdge
) where
import Data.List ((\\),intersect,find,nub)
import Prelude hiding (Foldable(..))
import Data.Foldable (Foldable(..))
import Data.IntMap.Strict(IntMap)
import qualified Data.IntMap.Strict as VMap (alter, lookup, fromList, fromListWith, (!), map, filterWithKey,insert, empty, toList, assocs, keys, keysSet, findWithDefault,elems)
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet (union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteFindMin,findMin,findMax,member,difference,elems)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map (fromList, lookup, fromListWith, elems, filterWithKey)
import Data.Maybe (mapMaybe) -- edgeNbrs
import Data.Set (Set)
import qualified Data.Set as Set (fromList,member,null,delete,elems,empty,insert,foldl')
import Diagrams.Prelude hiding (union,mapping)
-- import Diagrams.TwoD.Text (Text)
import TileLib
import HalfTile
import Try
import Tgraph.Grid
{---------------------
*********************
Tgraphs
*********************
-----------------------}
-- Types for Tgraphs, Vertices, Directed Edges, Faces
-- |Vertices are (positive) integers. They are checked for being positive
-- in Tgraphs.
type Vertex = Int
-- | directed edge
type Dedge = (Vertex,Vertex)
-- | vertex set
type VertexSet = IntSet
-- |A TileFace is a HalfTile with 3 vertex labels (clockwise starting with the origin vertex).
-- Usually referred to simply as a face.
--
-- For example a right dart: RD(1,2,3) or a left kite: LK(1,5,6)
type TileFace = HalfTile (Vertex,Vertex,Vertex)
{- | A Tgraph is a newtype for a list of faces (that is [TileFace]).
All vertex labels should be positive, so 0 is not used as a vertex label.
Tgraphs should be constructed with @makeTgraph@ or @checkedTgraph@ to check required properties.
The data constructor @Tgraph@ is not exported (but see also @makeUncheckedTgraph@).
Use @faces@ to retrieve the list of faces of a Tgraph.
-}
newtype Tgraph = Tgraph [TileFace]
deriving (Show)
-- |A type used to classify edges of faces.
-- Each (halftile) face has a long edge, a short edge and a join edge.
data EdgeType = Short | Long | Join deriving (Show,Eq)
-- |Mappings with vertex keys.
type VertexMap = IntMap
{-
Tgraphs Property Checking
-}
{-|
makeTgraph performs a no touching vertex check as well as using tryTgraphProps for other required properties.
It produces an error if either check fails.
Note that the other Tgraph properties are checked first, to ensure that calculation of
vertex locations can be done for a touching vertex check.
-}
makeTgraph :: [TileFace] -> Tgraph
makeTgraph fcs = runTry $ onFail "makeTgraph: (failed):\n" $ tryMakeTgraph fcs
{-|
tryMakeTgraph performs the same checks for Tgraph properties as tryTgraphProps but in addition
it also checks that there are no touching vertices (distinct labels for the same vertex)
using touchingVertices (which calculates vertex locations).
It produces Left ... if either check fails and Right g otherwise where g is the Tgraph.
Note that the other Tgraph properties are checked first, to ensure that calculation of
vertex locations can be done.
-}
tryMakeTgraph :: [TileFace] -> Try Tgraph
tryMakeTgraph fcs =
do g <- tryTgraphProps fcs -- must be checked first
let touchVs = touchingVertices g
if null touchVs
then Right g
else failReport ("Found touching vertices: "
++ show touchVs
++ "\nwith faces:\n"
++ show fcs
++ "\n\n(To fix, use: tryCorrectTouchingVs)\n\n"
)
{-| tryCorrectTouchingVs fcs finds touching vertices by calculating locations for vertices in the faces fcs,
then renumbers to remove touching vertices (renumbers higher to lower numbers),
then checks for Tgraph properties of the resulting faces to produce a Tgraph.
NB fcs needs to be tile-connected before the renumbering and
the renumbering need not be 1-1 (hence Relabelling is not used)
-}
tryCorrectTouchingVs :: [TileFace] -> Try Tgraph
tryCorrectTouchingVs fcs =
onFail ("tryCorrectTouchingVs:\n" ++ show touchVs) $
tryTgraphProps $ nub $ renumberFaces touchVs fcs
-- renumberFaces allows for a many to 1 relabelling represented by a list
where touchVs = touchingVertices fcs -- uses non-generalised version of touchingVertices
-- |renumberFaces - not exported. Allows for a many to 1 relabelling represented by a list of pairs.
-- It is used only for tryCorrectTouchingVs in Tgraphs which then checks the result.
renumberFaces :: [(Vertex,Vertex)] -> [TileFace] -> [TileFace]
renumberFaces prs = map renumberFace where
mapping = VMap.fromList $ differing prs
renumberFace = fmap (all3 renumber)
all3 f (a,b,c) = (f a,f b,f c)
renumber v = VMap.findWithDefault v v mapping
differing = filter $ uncurry (/=)
{-# WARNING makeUncheckedTgraph
["This should only be used when it is known that "
,"the faces satisfy the Tgraph properties. "
,"Consider using makeTgraph, tryMakeTgraph or checkedTgraph instead to perform checks."
]
#-}
-- |Creates a (possibly invalid) Tgraph from a list of faces.
-- It does not perform checks on the faces.
makeUncheckedTgraph:: [TileFace] -> Tgraph
makeUncheckedTgraph = Tgraph
-- |fully evaluate a tileface
evalFace :: TileFace -> TileFace
evalFace !f@(LD (!x,!y,!z)) = x `seq` y `seq` z `seq` f
evalFace !f@(RD (!x,!y,!z)) = x `seq` y `seq` z `seq` f
evalFace !f@(LK (!x,!y,!z)) = x `seq` y `seq` z `seq` f
evalFace !f@(RK (!x,!y,!z)) = x `seq` y `seq` z `seq` f
{- -- |evaluate a tileface (and check for edgeloops)
evalFace :: TileFace -> TileFace
evalFace f = if x==y || x==z || y==z
then error $ "evalFace : Edge loop found for face " ++ show f
else f
where (x,y,z) = faceVs f
-}
-- |fully evaluate a list of tilefaces.
evalFaces :: HasFaces a => a -> a
evalFaces !a = foldr (seq . evalFace) () (faces a) `seq` a
{-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties
and producing an error if a check fails.
Note: This does not check for touching vertices (distinct labels for the same vertex).
To perform this additional check use makeTgraph which also uses tryTgraphProps.
-}
checkedTgraph:: [TileFace] -> Tgraph
checkedTgraph = runTry . onFail report . tryTgraphProps
where report = "checkedTgraph: Failed\n" -- ++ " for faces: " ++ show fcs ++ "\n"
{- | Checks a list of faces to ensure:
no edge loops,
no edge conflicts (same directed edge on two or more faces),
legal tiling (obeys rules for legal tiling),
all vertex labels >0 ,
no crossing boundaries, and
connectedness.
Returns Right g where g is a Tgraph on passing checks.
Returns Left lines if a test fails, where lines describes the problem found.
-}
tryTgraphProps:: [TileFace] -> Try Tgraph
tryTgraphProps [] = Right emptyTgraph
tryTgraphProps fcs
| hasEdgeLoops fcs =
failReport $ "tryTgraphProps: Non-valid tile-face(s)\n" ++
"Edge Loops at: " ++ show (findEdgeLoops fcs) ++ "\n"
| illegalTiling fcs = failReports
["tryTgraphProps: Non-legal tiling\n"
,"Conflicting face directed edges (non-planar tiling): "
,show (conflictingDedges fcs)
,"\nIllegal tile juxtapositions: "
,show (illegals fcs)
,"\n"
]
| otherwise = let vs = vertexSet fcs
in if IntSet.findMin vs <1 -- any (<1) $ IntSet.toList vs
then failReports
["tryTgraphProps: Vertex numbers not all >0: "
,show (IntSet.toList vs)
,"\n"
]
else tryConnectedNoCross fcs
-- |Checks a list of faces for no crossing boundaries and connectedness.
-- (No crossing boundaries and connected implies tile-connected).
-- Returns Right g where g is a Tgraph on passing checks.
-- Returns Left lines if a test fails, where lines describes the problem found.
-- This is used by tryTgraphProps after other checks have been made,
-- but can be used alone when other properties are known to hold (e.g. in tryPartCompose)
tryConnectedNoCross:: [TileFace] -> Try Tgraph
tryConnectedNoCross fcs
| not (connected fcs) = failReports
["tryConnectedNoCross: Non-valid Tgraph (Not connected)\n"
,show fcs
,"\n"
]
| crossingBoundaries fcs = failReports
["tryConnectedNoCross: Non-valid Tgraph\n"
,"Crossing boundaries found at "
,show (crossingBVs fcs)
,"\nwith faces\n"
,show fcs
,"\n"
]
| otherwise = Right (Tgraph fcs)
-- |Returns any repeated vertices within each TileFace for a list of TileFaces.
findEdgeLoops:: HasFaces a => a -> [Vertex]
findEdgeLoops = concatMap findEdgeLoop . faces
-- |Returns a repeated vertex for TileFace
findEdgeLoop :: TileFace -> [Vertex]
findEdgeLoop = duplicates . faceVList
-- |Checks if there are repeated vertices within any TileFace for a list of TileFaces.
-- Returns True if there are any.
hasEdgeLoops:: HasFaces a => a -> Bool
hasEdgeLoops = not . null . findEdgeLoops
{- -- |duplicates finds any duplicated items in a list (unique results).
duplicates :: Eq a => [a] -> [a]
duplicates = check [] [] where
check dups _ [] = reverse dups
check dups seen (x:xs) | x `elem` dups = check dups seen xs
| x `elem` seen = check (x:dups) seen xs
| otherwise = check dups (x:seen) xs
-}
-- |duplicates finds any duplicated items in a list.
-- It produces unique results (that is duplicates (duplicates es) == [] ).
duplicates :: Ord a => [a] -> [a]
duplicates = check Set.empty Set.empty where
check dups _ [] = Set.elems dups
check dups seen (x:xs) | x `Set.member` dups = check dups seen xs
| x `Set.member` seen = check (Set.insert x dups) seen xs
| otherwise = check dups (Set.insert x seen) xs
-- |conflictingDedges fcs returns a list of conflicting directed edges in fcs
-- i.e. different faces having the same edge in the same direction.
-- (which should be null for a Tgraph)
conflictingDedges :: HasFaces a => a -> [Dedge]
conflictingDedges = duplicates . dedges
-- | edgeType d f - classifies the directed edge d
-- which must be one of the three directed edges of face f.
-- An error is raised if it is not a directed edge of the face
edgeType:: Dedge -> TileFace -> EdgeType
edgeType d f | d == longE f = Long
| d == shortE f = Short
| d == joinE f = Join
| otherwise = error $ "edgeType: directed edge " ++ show d ++
" not found in face " ++ show f ++ "\n"
-- |For a list of tile faces fcs this produces a list of tuples of the form (f1,etpe1,f2,etype2)
-- where f1 and f2 share a common edge and etype1 is the type of the shared edge in f1 and
-- etype2 is the type of the shared edge in f2.
-- This list can then be checked for inconsistencies / illegal pairings (using legal).
sharedEdges:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]
sharedEdges fcs = [(f1, edgeType d1 f1, f2, edgeType d2 f2)
| f1 <- fcs
, d1 <- faceDedges f1
, let d2 = reverseD d1
, f2 <- filter (`hasDedge` d2) fcs
]
{-# INLINE newSharedEdges #-}
-- |A version of sharedEdges comparing a single face against a list of faces.
-- This does not look at shared edges within the list, but just the new face against the list.
newSharedEdges:: TileFace -> [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]
newSharedEdges face fcs =
[(face, edgeType d1 face, fc', edgeType d2 fc')
| d1 <- faceDedges face
, let d2 = reverseD d1
, fc' <- filter (`hasDedge` d2) fcs
]
-- | noNewConflict face fcs returns True if face has an illegal shared edge with fcs.
-- It does not check for illegal cases within the fcs.
noNewConflict :: TileFace -> [TileFace] -> Bool
noNewConflict face fcs = all legal shared where
shared = newSharedEdges face fcs
-- | legal (f1,etype1,f2,etype2) is True if and only if it is legal for f1 and f2 to share an edge
-- with edge type etype1 (and etype2 is equal to etype1).
legal:: (TileFace,EdgeType,TileFace,EdgeType) -> Bool
legal (LK _, e1, RK _ , e2 ) = e1 == e2
legal (RK _, e1, LK _ , e2 ) = e1 == e2
legal (LD _, Join, RD _ , Join ) = True
legal (RD _, Join, LD _ , Join ) = True
legal (LK _, Short, RD _ , Short) = True
legal (RD _, Short, LK _ , Short) = True
legal (LD _, Short, RK _ , Short) = True
legal (RK _, Short, LD _ , Short) = True
legal (LK _, Long, RD _ , Long ) = True
legal (RD _, Long, LK _ , Long ) = True
legal (LD _, Long, RD _ , Long ) = True
legal (RD _, Long, LD _ , Long ) = True
legal (LD _, Long, RK _ , Long ) = True
legal (RK _, Long, LD _ , Long ) = True
legal _ = False
-- | Returns a list of illegal face pairings of the form (f1,e1,f2,e2) where f1 and f2 share an edge
-- and e1 is the type of this edge in f1, and e2 is the type of this edge in f2.
-- The list should be null for a legal Tgraph.
illegals:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]
illegals = filter (not . legal) . sharedEdges
-- | Returns True if there are conflicting directed edges or if there are illegal shared edges
-- in the list of tile faces
illegalTiling:: [TileFace] -> Bool
illegalTiling fcs = not (null (illegals fcs)) || not (null (conflictingDedges fcs))
-- |crossingBVs fcs returns a list of vertices where there are crossing boundaries
-- (which should be null for Tgraphs, VPatches, BoundaryStates, Forced, TrackedTgraph).
crossingBVs :: HasFaces a => a -> [Vertex]
crossingBVs = duplicates . boundaryVsDup
{- -- |duplicateInts - not exported.
-- finds any duplicated items in a list (unique results).
-- It uses IntSet, so faster than duplicates on large integer lists.
duplicateInts :: [Int] -> [Int]
duplicateInts = check IntSet.empty IntSet.empty where
check dups _ [] = IntSet.toList dups
check dups seen (x:xs) | x `IntSet.member` dups = check dups seen xs
| x `IntSet.member` seen = check (IntSet.insert x dups) seen xs
| otherwise = check dups (IntSet.insert x seen) xs
-}
-- |There are crossing boundaries if vertices occur more than once
-- in the boundary vertices.
crossingBoundaries :: HasFaces a => a -> Bool
crossingBoundaries = not . null . crossingBVs
-- |Predicate to check if the faces are connected (in graph theory sense).
connected:: HasFaces a => a -> Bool
connected = conn . faces where
conn [] = True
conn fcs = null (snd $ connectedBy (completeEdges fcs) (IntSet.findMin vs) vs)
where vs = vertexSet fcs
-- |Auxiliary function for calculating connectedness.
-- connectedBy edges v verts returns a pair of lists of vertices (conn,unconn)
-- where conn is a list of vertices from the set verts that are connected to v by a chain of edges,
-- and unconn is a list of vertices from set verts that are not connected to v.
-- This version creates an IntMap to represent edges (Vertex to [Vertex])
-- and uses IntSets for the search algorithm arguments.
connectedBy :: [Dedge] -> Vertex -> VertexSet -> ([Vertex],[Vertex])
connectedBy edges v verts = search IntSet.empty (IntSet.singleton v) (IntSet.delete v verts) where
nextMap = VMap.fromListWith (++) $ map (\(a,b)->(a,[b])) edges
-- search arguments (sets): done (=processed), visited, unvisited.
search done visited unvisited
| IntSet.null unvisited = (IntSet.toList visited ++ IntSet.toList done,[])
| IntSet.null visited = (IntSet.toList done, IntSet.toList unvisited) -- any unvisited are not connected
| otherwise =
let (x,visited') = IntSet.deleteFindMin visited
newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x
in search (IntSet.insert x done) (IntSet.union newVs visited') (unvisited IntSet.\\ newVs)
{- x = IntSet.findMin visited
visited' = IntSet.deleteMin visited
newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x
-}
-- |The empty Tgraph
emptyTgraph :: Tgraph
emptyTgraph = Tgraph []
-- |are there no faces?
nullFaces:: HasFaces a => a -> Bool
nullFaces = null . faces
-- |Class HasFaces for operations using (a list of) TileFaces.
--
-- Used to define common functions on
-- [TileFace], Tgraph, VPatch, BoundaryState, ForceState, Forced, TrackedTgraph.
--
-- Note maxV, boundaryESet, boundaryVFMap are included in the class
-- with default implementations. These are overriden for
-- BoundaryState, ForceState, Forced (where they are precalculated).
class HasFaces a where
-- |get the tileFace list
faces :: a -> [TileFace]
-- |get the maximum vertex integer in all faces (0 if there are no faces)
maxV :: a -> Int
maxV = maxV' . faces where
maxV' [] = 0
maxV' fcs = IntSet.findMax $ vertexSet fcs
-- |the set of directed edges of the boundary
-- (direction with a tileface on the left and exterior on right).
boundaryESet :: a -> Set Dedge
boundaryESet = missingRevSet . dedgeSet --missingRevSet . dedges
-- |create a map associating to each boundary vertex, a list of faces at the vertex
boundaryVFMap :: a -> VertexMap [TileFace]
boundaryVFMap a = vertexFMap (boundaryVSet fcs) fcs
where fcs = faces a
{-# DEPRECATED boundaryEdgeSet "Use boundaryESet" #-}
-- |get the set of boundary directed edges
boundaryEdgeSet :: HasFaces a => a -> Set Dedge
boundaryEdgeSet = boundaryESet
-- |An ascending list of the vertices occuring in faces (without duplicates)
vertices :: HasFaces a => a -> [Vertex]
vertices = IntSet.elems . vertexSet
-- |get the set of vertices occuring in the faces
vertexSet :: HasFaces a => a -> VertexSet
vertexSet = mconcat . map faceVSet . faces
-- |get the list of directed edges of the boundary in ascending order.
-- (direction with a tileface on the left and exterior on right).
boundary :: HasFaces a => a -> [Dedge]
boundary = Set.elems . boundaryESet
-- |get the list of boundary vertices (with possible duplicates).
-- This may have duplicates when applied to an arbitrary list of TileFace or VPatch.
-- but has no duplicates for Tgraph, BoundaryState, Forced, TrackedTgraph.
boundaryVsDup :: HasFaces a => a -> [Vertex]
boundaryVsDup = Set.foldl' (flip ((:).fst)) [] . boundaryESet
-- map fst . boundary
-- |get all the directed edges (directed clockwise round each face)
dedges :: HasFaces a => a -> [Dedge]
dedges = concatMap faceDedges . faces
-- | fully evaluate a directed edge
evalDedge :: Dedge -> Dedge
evalDedge !e@(a,b) | a==b = error $ "evalEdge: loop edge found with vertex " ++ show a ++ "\n"
| otherwise = e
-- | fully evaluate a list of directed edges
evalDedges :: [Dedge] -> [Dedge]
evalDedges !es = foldr (seq . evalDedge) () es `seq` es
-- |create a directed edge to face map from the (reverse direction of the) boundary edges
boundaryEFMap :: HasFaces a => a -> Map Dedge TileFace
boundaryEFMap fcs = Map.fromList (assocFaces des) where
des = map reverseD $ boundary fcs
vfMap = boundaryVFMap fcs
assocFaces [] = []
assocFaces (d@(a,b):more) =
case filter (liftA2 (&&) (isAtV a) (`hasDedge` d)) (vfMap VMap.! b) of
[face] -> (d,face):assocFaces more
[] -> assocFaces more
_ -> error $ "boundaryEFMap: more than one Tileface has the same directed edge: "
++ show d ++ "\n"
-- |find the faces which have at leat one boundary vertex.
boundaryVFaces :: HasFaces a => a -> [TileFace]
boundaryVFaces a = nub $ concat $ VMap.elems $ boundaryVFMap a
-- |get the set of boundary vertices
boundaryVSet :: HasFaces a => a -> VertexSet
boundaryVSet = IntSet.fromList . boundaryVsDup
{-# DEPRECATED boundaryVertexSet "Use boundaryVSet" #-}
-- |get the set of boundary vertices
boundaryVertexSet :: HasFaces a => a -> VertexSet
boundaryVertexSet = boundaryVSet
-- |A list of tilefaces is in class HasFaces
instance HasFaces [TileFace] where
faces = id
-- |Tgraph is in class HasFaces
instance HasFaces Tgraph where
faces (Tgraph fcs) = fcs
-- |count the faces
faceCount :: HasFaces a => a -> Int
faceCount = length . faces
ldarts,rdarts,lkites,rkites, kites, darts :: HasFaces a => a -> [TileFace]
-- | select all left darts from the faces
ldarts = filter isLD . faces
-- | select all right darts from the faces
rdarts = filter isRD . faces
-- | select all left kites from the faces
lkites = filter isLK . faces
-- | select all right kites from the faces
rkites = filter isRK . faces
-- | select all half kites from the faces
kites = filter isKite . faces
-- | select all half darts from the faces
darts = filter isDart . faces
-- |selects faces from a Tgraph (removing any not in the list),
-- but checks resulting Tgraph for connectedness and no crossing boundaries.
selectFaces :: [TileFace] -> Tgraph -> Tgraph
selectFaces fcs g = runTry $ tryConnectedNoCross $ faces g `intersect` fcs
-- |removes faces from a Tgraph,
-- but checks resulting Tgraph for connectedness and no crossing boundaries.
removeFaces :: [TileFace] -> Tgraph -> Tgraph
removeFaces fcs g = runTry $ tryConnectedNoCross $ faces g \\ fcs
-- |removeVertices vs g - removes any vertex in the list vs from g
-- by removing all faces at those vertices. The resulting Tgraph is checked
-- for required properties e.g. connectedness and no crossing boundaries
-- and will raise an error if these fail.
removeVertices :: [Vertex] -> Tgraph -> Tgraph
removeVertices vs g = removeFaces (filter (hasVIn vs) (faces g)) g
-- |selectVertices vs g - removes any face that does not have at least one vertex in the list vs from g.
-- Resulting Tgraph is checked
-- for required properties e.g. connectedness and no crossing boundaries
-- and will raise an error if these fail.
selectVertices :: [Vertex] -> Tgraph -> Tgraph
selectVertices vs g = runTry $ tryConnectedNoCross $ filter (hasVIn vs) $ faces g
-- |internal edges are shared by two faces. That is, all edges except those at the boundary.
-- Both directions of each internal directed edge will appear in the result.
internalEdges :: HasFaces a => a -> [Dedge]
internalEdges a = des \\ map reverseD (missingRevs des) where
des = dedges a
-- |phiEdges returns a list of the longer (phi-length) edges in the faces (including kite joins).
-- The result includes both directions of each edge.
phiEdges :: HasFaces a => a -> [Dedge]
phiEdges = bothDir . concatMap facePhiEdges . faces
-- |nonPhiEdges returns a list of the shorter edges in the faces (including dart joins).
-- The result includes both directions of each edge.
nonPhiEdges :: HasFaces a => a -> [Dedge]
nonPhiEdges = bothDir . concatMap faceNonPhiEdges . faces
-- |the default alignment of non-empty faces is (v1,v2) where v1 is the lowest numbered face origin,
-- and v2 is the lowest numbered opp vertex of faces with origin at v1. This is the lowest join edge.
-- An error will be raised if the Tgraph is empty.
defaultAlignment :: HasFaces a => a -> (Vertex,Vertex)
defaultAlignment g | nullFaces g = error "defaultAlignment: applied to null list of faces\n"
| otherwise = lowestJoin $ faces g
makeRD,makeLD,makeRK,makeLK :: Vertex -> Vertex -> Vertex -> TileFace
-- |make an RD (strict in arguments)
makeRD x y z = RD (x,y,z)
-- |make an LD (strict in arguments)
makeLD x y z = LD (x,y,z)
-- |make an RK (strict in arguments)
makeRK x y z = RK (x,y,z)
-- |make an LK (strict in arguments)
makeLK x y z = LK (x,y,z)
-- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace
faceVs::TileFace -> (Vertex,Vertex,Vertex)
faceVs = tileRep
-- |list of (three) face vertices in order clockwise starting with origin
faceVList::TileFace -> [Vertex]
-- faceVList = (\(x,y,z) -> [x,y,z]) . faceVs
faceVList f = [a,b,c] where (!a,!b,!c) = faceVs f
-- |the set of vertices of a face
faceVSet :: TileFace -> VertexSet
-- faceVSet = IntSet.fromList . faceVList
faceVSet f = IntSet.insert a $ IntSet.insert b $ IntSet.insert c IntSet.empty
where (a,b,c) = faceVs f
-- |firstV, secondV and thirdV vertices of a face are counted clockwise starting with the origin
firstV,secondV,thirdV:: TileFace -> Vertex
firstV face = a where (!a,_,_) = faceVs face
secondV face = b where (_,!b,_) = faceVs face
thirdV face = c where (_,_,!c) = faceVs face
originV,wingV,oppV:: TileFace -> Vertex
-- |the origin vertex of a face (firstV)
originV = firstV
-- |wingV returns the vertex not on the join edge of a face
wingV (LD(_,_,c)) = c
wingV (RD(_,b,_)) = b
wingV (LK(_,b,_)) = b
wingV (RK(_,_,c)) = c
-- |oppV returns the vertex at the opposite end of the join edge from the origin of a face
oppV (LD(_,b,_)) = b
oppV (RD(_,_,c)) = c
oppV (LK(_,_,c)) = c
oppV (RK(_,b,_)) = b
-- |indexV finds the index of a vertex in a face (firstV -> 0, secondV -> 1, thirdV -> 2)
indexV :: Vertex -> TileFace -> Int
indexV v face | v==a = 0
| v==b = 1
| v==c = 2
| otherwise = error ("indexV: " ++ show v ++ " not found in " ++ show face)
where (!a,!b,!c) = faceVs face
{- indexV v face = case elemIndex v (faceVList face) of
Just i -> i
_ -> error ("indexV: " ++ show v ++ " not found in " ++ show face)
-}
-- |nextV returns the next vertex in a face going clockwise from v
-- where v must be a vertex of the face
nextV :: Vertex -> TileFace -> Vertex
nextV v face = case indexV v face of
0 -> secondV face
1 -> thirdV face
2 -> firstV face
_ -> error "nextV: index error"
-- |prevV returns the previous vertex in a face (i.e. next going anti-clockwise) from v
-- where v must be a vertex of the face
prevV :: Vertex -> TileFace -> Vertex
prevV v face = case indexV v face of
0 -> thirdV face
1 -> firstV face
2 -> secondV face
_ -> error "prevV: index error"
-- |isAtV v f asks if a face f has v as a vertex
isAtV:: Vertex -> TileFace -> Bool
isAtV v f = v==a || v==b || v==c
where (!a,!b,!c) = faceVs f
{-
isAtV v (LD(a,b,c)) = v==a || v==b || v==c
isAtV v (RD(a,b,c)) = v==a || v==b || v==c
isAtV v (LK(a,b,c)) = v==a || v==b || v==c
isAtV v (RK(a,b,c)) = v==a || v==b || v==c
-}
-- |hasVIn vs f - asks if face f has an element of vs as a vertex
hasVIn:: [Vertex] -> TileFace -> Bool
hasVIn vs face = not $ null $ faceVList face `intersect` vs
{- $Edges
__Representing Edges__
For vertices a and b, a directed edge from a to b (a @Dedge@) is represented simply as the pair (a,b) .
In the special case that a @Dedge@ list is symmetrically closed [(b,a) is in the list whenever (a,b) is in the list]
we may refer to this as an edge list rather than just a directed edge list.
-}
-- |produces a list of directed edges (clockwise) round a face.
faceDedges::TileFace -> [Dedge]
faceDedges (LD(!a,!b,!c)) = [(a,b),(b,c),(c,a)]
faceDedges (RD(!a,!b,!c)) = [(a,b),(b,c),(c,a)]
faceDedges (LK(!a,!b,!c)) = [(a,b),(b,c),(c,a)]
faceDedges (RK(!a,!b,!c)) = [(a,b),(b,c),(c,a)]
-- faceDedges !f = [(a,b),(b,c),(c,a)] where (!a,!b,!c) = faceVs f
-- |produces a list of directed edges (clockwise) round a face.
faceDedgeSet::TileFace -> Set Dedge
faceDedgeSet (LD(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty
faceDedgeSet (RD(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty
faceDedgeSet (LK(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty
faceDedgeSet (RK(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty
-- |opposite directed edge.
reverseD:: Dedge -> Dedge
reverseD (!a,!b) = (b,a)
{-
-- |firstE, secondE and thirdE are the directed edges of a face counted clockwise from the origin,
firstE,secondE,thirdE:: TileFace -> Dedge
firstE = head . faceDedges
secondE = head . tail . faceDedges
thirdE = head . tail . tail . faceDedges
-}
joinE, shortE, longE, joinOfTile:: TileFace -> Dedge
-- |the join directed edge of a face in the clockwise direction going round the face (see also joinOfTile).
joinE (LD(!a,!b,_)) = (a,b)
joinE (RD(!a,_,!c)) = (c,a)
joinE (LK(!a,_,!c)) = (c,a)
joinE (RK(!a,!b,_)) = (a,b)
-- |The short directed edge of a face in the clockwise direction going round the face.
-- This is the non-join short edge for darts.
shortE (LD(_,!b,!c)) = (b,c)
shortE (RD(_,!b,!c)) = (b,c)
shortE (LK(_,!b,!c)) = (b,c)
shortE (RK(_,!b,!c)) = (b,c)
-- |The long directed edge of a face in the clockwise direction going round the face.
-- This is the non-join long edge for kites.
longE (LD(!a,_,!c)) = (c,a)
longE (RD(!a,!b,_)) = (a,b)
longE (LK(!a,!b,_)) = (a,b)
longE (RK(!a,_,!c)) = (c,a)
-- |The join edge of a face directed from the origin (not clockwise for RD and LK)
joinOfTile face = (originV face, oppV face)
facePhiEdges, faceNonPhiEdges:: TileFace -> [Dedge]
-- |The phi edges of a face (both directions)
-- which is long edges for darts, and join and long edges for kites
facePhiEdges (RD(!a,!b,_)) = [(a,b),(b,a)]
facePhiEdges (LD(!a,_,!c)) = [(c,a),(a,c)]
facePhiEdges (RK(!a,!b,!c)) = [(a,b),(b,a),(c,a),(a,c)]
facePhiEdges (LK(!a,!b,!c)) = [(a,b),(b,a),(c,a),(a,c)]
{-
facePhiEdges face@(RD _) = [e, (b,a)] where e@(!a,!b) = longE face
facePhiEdges face@(LD _) = [e, reverseD e] where e = longE face
facePhiEdges face = [e, reverseD e, j, reverseD j]
where e = longE face
j = joinE face
-}
-- |The non-phi edges of a face (both directions)
-- which is short edges for kites, and join and short edges for darts.
faceNonPhiEdges (RD(!a,!b,!c)) = [(b,c),(c,b),(c,a),(a,c)]
faceNonPhiEdges (LD(!a,!b,!c)) = [(a,b),(b,a),(c,a),(a,c)]
faceNonPhiEdges (RK(_,!b,!c)) = [(b,c),(c,b)]
faceNonPhiEdges (LK(_,!b,!c)) = [(b,c),(c,b)]
-- faceNonPhiEdges face = bothDirOneWay (faceDedges face) \\ facePhiEdges face
-- |matchingE eselect face is a predicate on tile faces
-- where eselect selects a particular edge type of a face
-- (eselect could be joinE or longE or shortE for example).
-- This is True for face' if face' has an eselect edge matching the (reversed) eselect edge of face.
matchingE :: (TileFace -> Dedge) -> TileFace -> TileFace -> Bool
matchingE eselect face = (== reverseD (eselect face)) . eselect
matchingLongE,matchingShortE,matchingJoinE :: TileFace -> TileFace -> Bool
-- Used in Compose (getDartWingInfo and composedFaceGroups).
-- |check if two TileFaces have opposite directions for their long edge.
matchingLongE = matchingE longE
-- |check if two TileFaces have opposite directions for their short edge.
matchingShortE = matchingE shortE
-- |check if two TileFaces have opposite directions for their join edge.
matchingJoinE = matchingE joinE
-- |hasDedge f e returns True if directed edge e is one of the directed edges of face f
hasDedge :: TileFace -> Dedge -> Bool
hasDedge f e = e == (a,b) || e == (b,c) || e == (c,a)
where (!a,!b,!c) = faceVs f
-- faster than: hasDedge f e = e `elem` faceDedges f
-- |hasDedgeIn f es - is True if face f has a directed edge in the list of directed edges es.
hasDedgeIn :: TileFace -> [Dedge] -> Bool
--hasDedgeIn face es = not $ null $ es `intersect` faceDedges face
hasDedgeIn face = any (hasDedge face)
-- |completeEdges returns a list of all the edges of the faces (both directions of each edge).
completeEdges :: HasFaces a => a -> [Dedge]
completeEdges = bothDir . dedges
-- |completeEdgeSet returns a set of all the edges of the faces (both directions of each edge).
completeEdgeSet :: HasFaces a => a -> Set Dedge
completeEdgeSet = bothDirSet . dedgeSet
-- |bothDir adds missing reverse directed edges to a list of directed edges
-- to complete edges (Result is a complete edge list)
-- It assumes no duplicates in argument.
bothDir:: [Dedge] -> [Dedge]
bothDir es = missingRevs es ++ es
-- |bothDirSet adds missing reverse directed edges to a set of directed edges
-- to complete edges (Result is a complete edge set)
bothDirSet:: Set Dedge -> Set Dedge
bothDirSet es = missingRevSet es <> es
{-
-- |bothDirOneWay adds all the reverse directed edges to a list of directed edges
-- without checking for duplicates.
-- Should be used on lists with single directions only.
-- If the argument may contain reverse directions, use bothDir to avoid duplicates.
bothDirOneWay :: [Dedge] -> [Dedge]
bothDirOneWay [] = []
bothDirOneWay (e@(a,b):es)= e:(b,a):bothDirOneWay es
-}
-- | efficiently finds missing reverse directions from a list of directed edges
-- and returning a dedge list. (It uses missingRevSet)
missingRevs:: [Dedge] -> [Dedge]
--missingRevs = Set.elems . missingRevSet . Set.fromList
--missingRevs:: Set Dedge -> Set Dedge
missingRevs es = Set.elems $ foldl' check Set.empty es where
check eset e@(a,b) | Set.member e eset = Set.delete e eset
| otherwise = Set.insert (b,a) eset
-- | efficiently finds missing reverse directions from a set of directed edges,
-- and returns them as a set.
missingRevSet:: Set Dedge -> Set Dedge
missingRevSet es = Set.foldl' check Set.empty es where
check eset e@(a,b) | Set.member e eset = Set.delete e eset
| otherwise = Set.insert (b,a) eset
-- |produces a set of all directed edges (clockwise) round the faces.
dedgeSet :: HasFaces a => a -> Set Dedge
dedgeSet = mconcat . map faceDedgeSet . faces
-- |two tile faces are edge neighbours
edgeNb::TileFace -> TileFace -> Bool
edgeNb face = any (`elem` edges) . faceDedges where
edges = map reverseD (faceDedges face)
{-|vertexFMap vs a -
For vertex set vs and faces from a,
create a VertexMap from each vertex in vs to a list of those faces in a that are at that vertex.
-}
vertexFMap:: HasFaces a => VertexSet -> a -> VertexMap [TileFace]
vertexFMap vs = foldl' insertf startVF . faces where
startVF = VMap.fromList $ map (,[]) $ IntSet.elems vs
insertf vfmap f = foldl' (flip (VMap.alter addf)) vfmap (faceVList f)
where addf Nothing = Nothing
addf (Just fs) = Just (f:fs)
{-# DEPRECATED vertexFacesMap "Use vertexFMap . IntSet.fromList" #-}
-- |For vertex list vs and faces from a,
-- create a VertexMap from each vertex in vs to a list of those faces in a that are at that vertex.
vertexFacesMap :: HasFaces a => [Vertex] -> a -> VertexMap [TileFace]
vertexFacesMap = vertexFMap . IntSet.fromList
-- | dedgeFMap des a - Produces an edge-face map. Each directed edge in des is associated with
-- a unique face in a that has that directed edge (if there is one).
-- It will report an error if more than one face in a has the same directed edge in des.
-- If the directed edges are all the ones in a, buildEFMap will be more efficient.
-- If the edges are just the boundary edges, use boundaryEFMap instead.
dedgeFMap:: HasFaces a => [Dedge] -> a -> Map Dedge TileFace
dedgeFMap des fcs = Map.fromList (assocFaces des) where
vset = IntSet.fromList (map fst des) `IntSet.union` IntSet.fromList (map snd des)
vfMap = vertexFMap vset fcs
assocFaces [] = []
assocFaces (d@(a,b):more) =
case filter (liftA2 (&&) (isAtV a) (`hasDedge` d)) (vfMap VMap.! b) of
[face] -> (d,face):assocFaces more
[] -> assocFaces more
_ -> error $ "dedgeFMap: more than one Tileface has the same directed edge: "
++ show d ++ "\n"
{-# DEPRECATED dedgesFacesMap "Use dedgeFMap" #-}
-- |same as dedgeFMap
dedgesFacesMap:: HasFaces a => [Dedge] -> a -> Map Dedge TileFace
dedgesFacesMap = dedgeFMap
-- |select the faces with a join edge on the boundary.
-- Useful for drawing join edges only on the boundary.
boundaryJoinFaces :: HasFaces a => a -> [TileFace]
boundaryJoinFaces a = Map.elems $ Map.filterWithKey isJoin $ boundaryEFMap a where
isJoin d f = joinE f == d
-- |get the faces with at least one boundary edge.
boundaryEFaces :: HasFaces a => a -> [TileFace]
boundaryEFaces = nub . Map.elems . boundaryEFMap
{-# DEPRECATED boundaryEdgeFaces "Use boundaryEFaces" #-}
-- |find the faces in with at least one boundary edge.
boundaryEdgeFaces :: HasFaces a => a -> [TileFace]
boundaryEdgeFaces = boundaryEFaces
-- |Build a full Map from all directed edges to faces (the unique face containing the directed edge)
-- The faces should not contain conflicting dedges.
-- That is, if more than one face has the same dedge,
-- only one of them will be associated with the dedge.
buildEFMap:: HasFaces a => a -> Map Dedge TileFace
buildEFMap = Map.fromList . concatMap assignFace . faces where
assignFace f = map (,f) (faceDedges f)
-- | look up a face for an edge in an edge-face map
faceForEdge :: Dedge -> Map Dedge TileFace -> Maybe TileFace
faceForEdge = Map.lookup
-- |Given a tileface (face) and a map from each directed edge to the (unique) tileface containing it (efMap)
-- return the list of edge neighbours of face.
edgeNbs:: TileFace -> Map Dedge TileFace -> [TileFace]
edgeNbs face efMap = mapMaybe (flip faceForEdge efMap) edges where
edges = reverseD <$> faceDedges face
-- |For an argument with a non-empty list of faces,
-- find the face with lowest originV (and then lowest oppV).
-- Extract this face and return it paired with the remaining list of faces.
-- This will raise an error if there are no faces.
-- (Used by locateGraphVertices to determine the starting point for location calculation.)
extractLowestJoin:: HasFaces a => a -> (TileFace,[TileFace])
extractLowestJoin = getLJ . faces where
getLJ fcs
| null fcs = error "extractLowestJoin: applied to empty list of faces"
| otherwise = (face, fcs\\[face])
where a = minimum (map originV fcs)
aFaces = filter ((a==) . originV) fcs
b = minimum (map oppV aFaces)
face = case find (((a,b)==) . joinOfTile) aFaces of
Just f -> f
Nothing -> error $ "extractLowestJoin: no face found at "
++ show a ++ " with opp vertex at " ++ show b ++ "\n"
-- |Return the join edge with lowest origin vertex (and lowest oppV vertex if there is more than one).
-- The resulting edge is always directed from the originV to the oppV vertex.
-- This will raise an error if there are no faces.
lowestJoin:: HasFaces a => a -> Dedge
lowestJoin a = (originV f, oppV f) where f = fst (extractLowestJoin a)
{- lowestJoin = lowest . faces where
lowest fcs | null fcs = error "lowestJoin: applied to empty list of faces"
lowest fcs = (a,b) where
a = minimum (map originV fcs)
aFaces = filter ((a==) . originV) fcs
b = minimum (map oppV aFaces)
-}
{---------------------
*********************
VPatch and Conversions
*********************
-----------------------}
-- |Abbreviation for finite mappings from Vertex to Location (i.e Point)
type VertexLocMap = VertexMap (Point V2 Double)
-- |A VPatch has a map from vertices to points along with a list of tile faces.
-- It is an intermediate form between Tgraphs and Diagrams
data VPatch = VPatch {vLocs :: VertexLocMap, vpFaces::[TileFace]} deriving Show
-- |needed for making VPatch transformable
type instance V VPatch = V2
-- |needed for making VPatch transformable
type instance N VPatch = Double
-- |Make VPatch Transformable.
instance Transformable VPatch where
transform t vp = vp {vLocs = VMap.map (transform t) (vLocs vp)}
-- |VPatch is in class HasFace
instance HasFaces VPatch where
faces = vpFaces
{- boundaryVFMap = boundaryVFMap . faces -- need for nub (from [TileFace] instance)
boundary = boundary . faces
maxV = maxV . faces
-}
{-|Convert a Tgraph to a VPatch.
This uses locateGraphVertices to form an intermediate VertexLocMap (mapping of vertices to positions).
This makes the join of the face with lowest origin and lowest oppV align on the positive x axis.
-}
makeVP::Tgraph -> VPatch
makeVP g = VPatch {vLocs = locateGraphVertices g, vpFaces = faces g}
-- |subFaces a vp, creates a new VPatch from faces in a, using the vertex location map from vp.
-- The vertices in the faces should have locations assigned in vp vertex locations.
-- However THIS IS NOT CHECKED so missing locations for vertices will raise an error when drawing.
-- subFaces a vp can be used for both subsets of tile faces of vp,
-- and also for larger scale faces which use the same vertex to point assignment (e.g in compositions).
-- The vertex location map is not changed (see also relevantVP and restrictTo).
subFaces:: HasFaces a => a -> VPatch -> VPatch
subFaces a vp = vp {vpFaces = faces a}
-- | removes locations for vertices not used in the faces of a VPatch.
-- (Useful when restricting which labels get drawn).
-- relevantVP vp will raise an error if any vertex in the faces of vp is not a key in the location map of vp.
relevantVP :: VPatch -> VPatch
relevantVP vp
| IntSet.null diffSet = vp{vLocs = locVs}
| otherwise = error $ "relevantVP: missing locations for: " ++
show diffSet ++ "\n"
where
vs = vertexSet vp
source = VMap.keysSet locVs
diffSet = IntSet.difference vs source
locVs = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) $ vLocs vp
-- |A combination of subFaces and relevantVP.
-- restrictTo a vp - restricts vp to faces in a,
-- removing locations for vertices not in the faces.
-- (Useful when restricting which labels get drawn).
-- Will raise an error if any vertex in faces of a is not a key in the location map of vp.
restrictTo:: HasFaces a => a -> VPatch -> VPatch
restrictTo a = relevantVP . subFaces a
-- |Recover a Tgraph from a VPatch by dropping the vertex positions and checking Tgraph properties.
-- This will fail if the faces do not form a valid Tgraph.
graphFromVP:: VPatch -> Tgraph
graphFromVP = checkedTgraph . faces
-- |remove a list of faces from a VPatch (ignoring faces not in the VPatch)
removeFacesFromVP :: [TileFace] -> VPatch -> VPatch
removeFacesFromVP a vp = restrictTo (faces vp \\ faces a) vp
-- |removeVerticesFromVP vs vp - removes any vertex in the list vs from vp
-- by removing all faces at those vertices.
removeVerticesFromVP :: [Vertex] -> VPatch -> VPatch
removeVerticesFromVP vs vp = removeFacesFromVP (filter (hasVIn vs) (faces vp)) vp
-- |selectVerticesFromVP vs vp - removes any face that does not have
-- at least one vertex in the list vs from vp.
selectVerticesFromVP :: [Vertex] -> VPatch -> VPatch
selectVerticesFromVP vs vp = restrictTo (filter (hasVIn vs) (faces vp)) vp
-- |find the location of a single vertex in a VPatch
findLoc :: Vertex -> VPatch -> Maybe (Point V2 Double)
findLoc v = VMap.lookup v . vLocs
-- |VPatches are drawable
instance Drawable VPatch where
drawWith pd vp = drawWith pd (dropLabels vp)
-- |converts a VPatch to a Patch, removing vertex information and converting faces to Located Pieces.
dropLabels :: VPatch -> Patch
dropLabels vp = map convert (faces vp) where
locations = vLocs vp
convert face = case (VMap.lookup (originV face) locations , VMap.lookup (oppV face) locations) of
(Just p, Just p') -> fmap (const (p' .-. p)) face `at` p -- using HalfTile functor fmap
_ -> error $ "dropLabels: Vertex location not found for some vertices:\n "
++ show (faceVList face \\ VMap.keys locations) ++ "\n"
-- |Tgraphs are Drawable
instance Drawable Tgraph where
drawWith pd = drawWith pd . makeVP
-- | A class for things that can be drawn with labels when given a colour and a measure (size) for the label and a
-- a draw function (for Patches).
-- So labelColourSize c m modifies a Patch drawing function to add labels (of colour c and size measure m).
-- Measures are defined in Diagrams. In particular: tiny, verySmall, small, normal, large, veryLarge, huge.
class DrawableLabelled a where
-- labelColourSize :: DrawableLabelled a => Colour Double -> Measure Double -> (Patch -> Diagram B) -> a -> Diagram B
labelColourSize :: OKBackend b =>
Colour Double -> Measure Double -> (Patch -> Diagram b) -> a -> Diagram b
-- The argument type of the draw function is Patch rather than VPatch, which prevents labelling twice.
-- | VPatches can be drawn with labels
instance DrawableLabelled VPatch where
labelColourSize c m d vp = drawLabels <> d (dropLabels vp) where
drawLabels = position $ drawlabel <$> VMap.toList (vLocs vp)
drawlabel(v,p) = (p, baselineText (show v) # fontSize m # fc c)
-- | Tgraphs can be drawn with labels
instance DrawableLabelled Tgraph where
labelColourSize c r d = labelColourSize c r d . makeVP
-- | Default Version of labelColourSize with colour red. Example usage: labelSize tiny draw a , labelSize normal drawj a
labelSize :: (OKBackend b, DrawableLabelled a) =>
Measure Double -> (Patch -> Diagram b) -> a -> Diagram b
labelSize = labelColourSize red
-- | Default Version of labelColourSize using red and small (rather than normal label size). Example usage: labelled draw a , labelled drawj a
labelled :: (OKBackend b, DrawableLabelled a) =>
(Patch -> Diagram b) -> a -> Diagram b
labelled = labelColourSize red small --(normalized 0.023)
{-# DEPRECATED rotateBefore "Use (flip rotating)" #-}
-- |rotateBefore vfun a g - makes a VPatch from g then rotates by angle a before applying the VPatch function vfun.
-- Tgraphs need to be rotated after a VPatch is calculated but before any labelled drawing.
rotateBefore :: (VPatch -> a) -> Angle Double -> Tgraph -> a
rotateBefore = flip rotating
-- |rotating a vfun g - makes a VPatch from g then rotates by angle a before applying the VPatch function vfun.
-- Tgraphs need to be rotating after a VPatch is calculated but before any labelled drawing.
--
-- E.g. rotating angle (labelled draw) graph.
rotating :: Angle Double -> (VPatch -> a) -> Tgraph -> a
rotating angle vfun = vfun . rotate angle . makeVP
-- |center a VPatch on a particular vertex. (Raises an error if the vertex is not in the VPatch vertices)
centerOn :: Vertex -> VPatch -> VPatch
centerOn a vp =
case findLoc a vp of
Just loca -> translate (origin .-. loca) vp
-- same as moveOriginTo loca vp
-- and as moveOriginBy (loca .-. origin) vp
_ -> error $ "centerOn: vertex not found (Vertex " ++ show a ++ ")\n"
-- |alignXaxis takes a vertex pair (a,b) and a VPatch vp
-- for centering vp on a and rotating the result so that b is on the positive X axis.
-- (Raises an error if either a or b are not in the VPatch vertices)
alignXaxis :: (Vertex, Vertex) -> VPatch -> VPatch
alignXaxis (a,b) vp = rotate angle newvp
where newvp = centerOn a vp
angle = signedAngleBetweenDirs (direction unitX) (direction (locb .-. origin))
locb = case findLoc b newvp of
Just l -> l
Nothing -> error $ "alignXaxis: second alignment vertex not found (Vertex " ++ show b ++ ")\n"
-- |alignments takes a list of vertex pairs for respective alignments of VPatches in the second list.
-- For a pair (a,b) the corresponding VPatch is centered on a then b is aligned along the positive x axis.
-- The vertex pair list can be shorter than the list of VPatch - the remaining VPatch are left as they are.
-- (Raises an error if either vertex in a pair is not in the corresponding VPatch vertices)
alignments :: [(Vertex, Vertex)] -> [VPatch] -> [VPatch]
alignments [] vps = vps
alignments _ [] = error "alignments: Too many alignment pairs.\n" -- non-null list of pairs
alignments ((a,b):more) (vp:vps) = alignXaxis (a,b) vp : alignments more vps
-- |alignAll (a,b) vpList
-- provided both vertices a and b exist in each VPatch in vpList, the VPatch are all aligned
-- centred on a, with b on the positive x axis.
-- An error is raised if any VPatch does not contain both a and b vertices.
alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch]
alignAll (a,b) = map (alignXaxis (a,b))
-- |aligning (a,b) vfun g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis
-- before applying the VPatch function vfun
-- Will raise an error if either a or b is not a vertex in g.
-- Tgraphs need to be aligned after a VPatch is calculated but before any labelled drawing.
--
-- E.g. aligning (a,b) (labelled draw) g
aligning :: (Vertex,Vertex) -> (VPatch -> a) -> Tgraph -> a
aligning vs vfun = vfun . alignXaxis vs . makeVP
{-# DEPRECATED alignBefore "Use (flip aligning)" #-}
-- |alignBefore vfun (a,b) g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis
-- before applying the VPatch function vfun
-- Will raise an error if either a or b is not a vertex in g.
-- Tgraphs need to be aligned after a VPatch is calculated but before any labelled drawing.
alignBefore :: (VPatch -> a) -> (Vertex,Vertex) -> Tgraph -> a
alignBefore = flip aligning
-- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligning on the x-axis.
-- Will raise an error if either a or b is not a vertex in g.
makeAlignedVP:: (Vertex,Vertex) -> Tgraph -> VPatch
makeAlignedVP vs = aligning vs id
-- |produce a diagram of a list of edges (given a suitable VPatch)
-- Will raise an error if any vertex of the edges is not a key in the vertex to location mapping of the VPatch.
drawEdgesVP :: OKBackend b =>
VPatch -> [Dedge] -> Diagram b
drawEdgesVP = drawLocatedEdges . vLocs --foldMap (drawEdgeVP vp)
-- |produce a diagram of a single edge (given a VPatch)
-- Will raise an error if either vertex of the edge is not a key in the vertex to location mapping of the VPatch.
drawEdgeVP:: OKBackend b =>
VPatch -> Dedge -> Diagram b
drawEdgeVP = drawLocatedEdge . vLocs
-- |produce a diagram of a list of edges (given a mapping of vertices to locations)
-- Will raise an error if any vertex of the edges is not a key in the mapping.
drawLocatedEdges :: OKBackend b =>
VertexLocMap -> [Dedge] -> Diagram b
drawLocatedEdges = foldMap . drawLocatedEdge
-- |produce a diagram of a single edge (given a mapping of vertices to locations).
-- Will raise an error if either vertex of the edge is not a key in the mapping.
drawLocatedEdge :: OKBackend b =>
VertexLocMap -> Dedge -> Diagram b
drawLocatedEdge vpMap (a,b) = case (VMap.lookup a vpMap, VMap.lookup b vpMap) of
(Just pa, Just pb) -> pa ~~ pb
_ -> error $ "drawEdge: location not found for one or both vertices "++ show (a,b) ++ "\n"
{-| locateGraphVertices: processes faces in a Tgraph to associate points for each vertex using a default scale and orientation.
The default scale is 1 unit for short edges (phi units for long edges).
It aligns the lowest numbered join of the faces on the x-axis, and returns a vertex-to-point Map.
-}
locateGraphVertices:: Tgraph -> VertexLocMap
locateGraphVertices = locateVertices . faces
{-| locateVertices - not exported (used in touchingVertices and locateGraphVertices).
It can go wrong on arbitrary faces.
Processes a list of faces to associate points for each vertex using a default scale and orientation.
The default scale is 1 unit for short edges (phi units for long edges).
It aligns the lowest numbered join of the faces on the x-axis, and returns a vertex-to-point Map.
It will raise an error if faces are not connected.
If faces have crossing boundaries (i.e not locally tile-connected), this could raise an error
or a result with touching vertices (i.e. more than one vertex label with the same location).
-}
locateVertices:: HasFaces a => a -> VertexLocMap
-- This is made more efficient by calculating an edge to face map
-- and also using Sets for 2nd arg of fastAddVPoints.
locateVertices = locVs . faces where
locVs [] = VMap.empty
locVs fcs = fastAddVPoints [joinFace] (Set.fromList more) (axisJoin joinFace) where
(joinFace,more) = extractLowestJoin fcs
{- fastAddVPoints readyfaces fcOther vpMap.
The first argument list of faces (readyfaces) contains the ones being processed next in order where
each will have at least two known vertex locations in vpMap.
The second argument Set of faces (fcOther) are faces that have not yet been added
and may not yet have known vertex locations.
The third argument is the mapping of vertices to points.
-}
fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap
fastAddVPoints [] fcOther _ = error $ "locateVertices (fastAddVPoints): Faces not tile-connected: "
++ show fcOther ++ "\n"
fastAddVPoints (face:fs) fcOther vpMap = fastAddVPoints (fs++nbs) fcOther' vpMap' where
nbs = filter (`Set.member` fcOther) (eNeighbours face)
fcOther' = foldl' (flip Set.delete) fcOther nbs
-- fcOther' = foldr Set.delete fcOther nbs
vpMap' = addVPoint face vpMap
-- Given a list of faces and a face f, produce a list of edge neighbouring faces of f.
-- This version assumes no two faces can have a common dedge (using buildEFMap).
eNeighbours = eNbrs
where themap = buildEFMap fcs
eNbrs f = edgeNbs f themap
-- |Given a tileface and a vertex to location map which gives locations for at least 2 of the tileface vertices
-- this returns a new map by adding a location for the third vertex (when missing) or the same map when not missing.
-- It will raise an error if there are fewer than 2 tileface vertices with a location in the map
-- (indicating a non tile-connected face).
-- It is possible that a newly added location is already in the range of the map (creating a touching vertices),
-- so this needs to be checked for.
addVPoint:: TileFace -> VertexLocMap -> VertexLocMap
addVPoint face vpMap =
case thirdVertexLoc face vpMap of
Just (v,p) -> VMap.insert v p vpMap
Nothing -> vpMap
-- |axisJoin face -
-- initialises a vertex to point mapping with locations for the join edge vertices of face
-- with originV face at the origin and aligned along the x axis with unit length for a half dart
-- and length phi for a half kite.
axisJoin::TileFace -> VertexLocMap
axisJoin face =
VMap.insert (originV face) origin $ VMap.insert (oppV face) (p2 (x,0)) VMap.empty where
x = if isDart face then 1 else phi
{-| thirdVertexLoc face vpMap, where face is a tileface and vpMap associates points with vertices (positions).
It looks up all 3 vertices of face in vpMap hoping to find at least 2 of them, it then returns Just pr
where pr associates a new location with the third vertex.
If all 3 are found, returns Nothing.
If none or one found this is an error (a non tile-connected face).
New Version: This assumes all edge lengths are 1 or phi.
It now uses signorm to produce vectors of length 1 rather than rely on relative lengths.
(Requires ttangle and phi from TileLib).
-}
thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double)
thirdVertexLoc face@(RD _ ) vpMap = -- LD and RD cases are the same using originV, wingV, oppV EXCEPT for angles
case (VMap.lookup (originV face) vpMap, VMap.lookup (wingV face) vpMap, VMap.lookup (oppV face) vpMap) of
(Just locOg, Just locW, Nothing) -> Just (oppV face, locW .+^ v) where v = signorm (rotate (ttangle 1) (locOg .-. locW))
(Nothing, Just locW, Just locOp) -> Just (originV face, locOp .+^ v) where v = signorm (rotate (ttangle 8) (locOp .-. locW))
(Just locOg, Nothing, Just locOp) -> Just (wingV face, locOp .+^ v) where v = signorm (rotate (ttangle 7) (locOg .-. locOp))
(Just _ , Just _ , Just _) -> Nothing
_ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"
thirdVertexLoc face@(LD _ ) vpMap = -- LD and RD cases are the same using originV, wingV, oppV EXCEPT for angles
case (VMap.lookup (originV face) vpMap, VMap.lookup (wingV face) vpMap, VMap.lookup (oppV face) vpMap) of
(Just locOg, Just locW, Nothing) -> Just (oppV face, locW .+^ v) where v = signorm (rotate (ttangle 9) (locOg .-. locW))
(Nothing, Just locW, Just locOp) -> Just (originV face, locOp .+^ v) where v = signorm (rotate (ttangle 2) (locOp .-. locW))
(Just locOg, Nothing, Just locOp) -> Just (wingV face, locOp .+^ v) where v = signorm (rotate (ttangle 3) (locOg .-. locOp))
(Just _ , Just _ , Just _) -> Nothing
_ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"
thirdVertexLoc face vpMap = -- LK and RK cases are the same using first,second,third
case (VMap.lookup (firstV face) vpMap, VMap.lookup (secondV face) vpMap, VMap.lookup (thirdV face) vpMap) of
(Just loc1, Just loc2, Nothing) -> Just (thirdV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 4) (loc1 .-. loc2))
(Nothing, Just loc2, Just loc3) -> Just (firstV face, loc3 .+^ v) where v = phi*^signorm (rotate (ttangle 2) (loc2 .-. loc3))
(Just loc1, Nothing, Just loc3) -> Just (secondV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1))
(Just _ , Just _ , Just _) -> Nothing
_ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"
-- * Touching Vertices
{-|
touchingVertices finds if any vertices are too close to each other after locating them.
It can fail if faces do not satisfy other Tgraph properties (apart from touching vertices).
If vertices are too close that indicates we may have different vertex labels at the same location
(the touching vertex problem).
It returns pairs of vertices that are too close with higher number first in each pair.
An empty list is returned if there are no touching vertices.
A Grid is used to find near points efficiently.
This is used in makeTgraph and fullUnion.
-}
touchingVertices:: HasFaces a => a -> [(Vertex,Vertex)]
touchingVertices fcs = check vpAssocs where
vpAssocs = VMap.assocs $ locateVertices fcs -- assocs puts in increasing key order so that check returns (higher,lower) pairs
check = allClashes fst
{-* Generalised Touching Vertices
-}
{-|
touchingVerticesGen generalises touchingVertices to allow for multiple faces with the same directed edge.
This can arise when applied to the union of faces from 2 overlapping Tgraphs which might clash in places.
It is used in the calculation of commonFaces. The faces should be connected with no crossing boundaries to enable location
calculations.
-}
touchingVerticesGen:: HasFaces a => a -> [(Vertex,Vertex)]
touchingVerticesGen fcs = check vpAssocs where
vpAssocs = VMap.assocs $ locateVerticesGen fcs -- assocs puts in increasing key order so that check returns (higher,lower) pairs
check = allClashes fst
{-| locateVerticesGen (not exported but used in touchingVerticesGen). This generalises locateVertices to allow for multiple faces sharing an edge.
This can arise when applied to the union of faces from 2 Tgraphs (e.g. in commonFaces).
(The code is the same except for eNeighboursGen instead of eNeighbours).
-}
locateVerticesGen:: HasFaces a => a -> VertexLocMap
locateVerticesGen = locVs . faces where
locVs [] = VMap.empty
locVs fcs = fastAddVPoints [face] (Set.fromList more) (axisJoin face) where
(face,more) = extractLowestJoin fcs
fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap
fastAddVPoints [] fcOther _ = error $ "fastAddVPointsGen: Faces not tile-connected " ++ show fcOther ++ "\n"
fastAddVPoints (f:fs) fcOther vpMap = fastAddVPoints (fs++nbs) fcOther' vpMap' where
nbs = filter (`Set.member` fcOther) (eNeighboursGen f)
fcOther' = foldl' (flip Set.delete) fcOther nbs
vpMap' = addVPoint f vpMap
-- Same as eNeighbours in locateVertices except that it allows for more than one face with a common dedge.
-- Given a list of faces and a face f, produce a list of edge neighbouring faces of f.
eNeighboursGen :: TileFace -> [TileFace]
eNeighboursGen = eNbrs
where theMap = Map.fromListWith (++) $ concatMap processFace fcs
processFace f = (,[f]) <$> faceDedges f
eNbrs f = concat $ mapMaybe getNbrs edges
where getNbrs e = Map.lookup e theMap
edges = map reverseD (faceDedges f)