diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,48 @@ # Revision history for PenroseKiteDart +## version v1.6 +Possibly breaking: + Replaced boundary in class HasFaces with boundaryESet (Set instead of list) + (boundary now derived from boundaryESet) + Removed data constructor Relabelling from export + Renamed relabelGraph as uncheckedRelabelGraph + Renamed checkRelabelGraph as relabelGraph (now using unsafeDom check) + Renamed locateVertices as locateGraphVertices AND restricted to Tgraphs only. + No longer exporting locateVerticesGen + Removed oldGetDartWingInfo + Removed oldPartCompose + Removed partComposeFacesFrom (use partComposeFaces) +Other changes: + Default implementations in Class HasFaces for boundaryESet, maxV, boundaryVFMap + Deprecated boundaryEdgeSet (use boundaryESet) + Deprecated boundaryVertexSet (use boundaryVSet) + Deprecated boundaryEdgeFaces (use boundaryEFaces) + Deprecated dedgesFacesMap (use dedgeFMap) + Deprecated vertexFacesMap (use vertexFMap . IntSet.fromList) + Added boundaryVSet, boundaryEFaces, dedgeFMap, vertexFMap + Added evalDedge, evalDedges, evalFace, evalFaces (for full evaluation) + Added unsafeDom (for use with relabellings) + Added faceCount + Added dedgeSet, missingRevSet + Added partComposeFaces + relabelAvoid now exported + relabelFrom now exported + relabelContig deprecated. Use (relabelFrom 1) + checkRelabelGraph deprecated. Use (relabelGraph) + Changed Tgraph definition so no record type used + (this was hidden anyway but visible when a Tgraph was shown) + +Removed deprecated: + subVP Use (flip subFaces) + restrictVP Use (flip restrictTo) + restrictSmart Use smartOn + selectFacesVP Use (flip restrictTo) + removeFacesVP Use (flip removeFacesFromVP) + boundaryFaces Use boundaryVFaces or boundaryEFaces + pieceEdges Use drawnEdges + dashjPiece Use drawjPiece + dashjP3 Use drawjP3 + ## version v1.5.1 possibly breaking: diff --git a/PenroseKiteDart.cabal b/PenroseKiteDart.cabal --- a/PenroseKiteDart.cabal +++ b/PenroseKiteDart.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.1. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: PenroseKiteDart -version: 1.5.1 +version: 1.6 synopsis: Library to explore Penrose's Kite and Dart Tilings. description: Library to explore Penrose's Kite and Dart Tilings using Haskell Diagrams. Please see README.md category: Graphics diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs --- a/benchmark/Bench.hs +++ b/benchmark/Bench.hs @@ -10,17 +10,17 @@ do let wait = threadDelay 100000 _ <- traceMarkerIO "starting decompositions" wait - let kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n + let !kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n putStrLn $ "Number of faces of a " ++ sn ++ " times decomposed King is " - ++ show (length (faces kD)) + ++ show (faceCount kD) putStrLn $ "Max vertex of a (" ++ sn ++ " times decomposed King) is " ++ show (maxV kD) _ <- traceMarkerIO "finished decomposing" wait _ <- traceMarkerIO "starting force" - let fkD = {-# SCC "forcingKD" #-} forceF kD + let !fkD = {-# SCC "forcingKD" #-} forceF kD putStrLn $ "Number of faces of force (" ++ sn ++ " times decomposed King) is " - ++ show (length $ faces $ forgetF fkD) + ++ show (faceCount $ forgetF fkD) putStrLn $ "Max vertex of force (" ++ sn ++ " times decomposed King) is " ++ show (maxV $ forgetF fkD) _ <- traceMarkerIO "finished force" @@ -28,14 +28,14 @@ _ <- traceMarkerIO "starting (unchecked) composing" let cfkD = {-# SCC "composing" #-} forgetF $ last $ takeWhile (not . nullFaces . forgetF) $ iterate composeF fkD putStrLn $ "Number of faces of recomposed force (" ++ sn ++ " times decomposed King) is " - ++ show (length (faces cfkD)) + ++ show (faceCount cfkD) putStrLn $ "Max vertex of recomposed force (" ++ sn ++ " times decomposed King) is " ++ show (maxV cfkD) _ <- traceMarkerIO "finished (unchecked) composing" return () {- putStrLn $ "Number of faces of reforced force (" ++ sn ++ " times decomposed King) is " - ++ show (length (faces rcfkD)) + ++ show (faceCount rcfkD) -} where diff --git a/src/HalfTile.hs b/src/HalfTile.hs --- a/src/HalfTile.hs +++ b/src/HalfTile.hs @@ -43,7 +43,6 @@ -- | Note this ignores the tileLabels when comparing. -- However we should never have 2 different HalfTiles with the same rep instance Ord rep => Ord (HalfTile rep) where --- compare !t1 !t2 = compare (tileRep t1) (tileRep t2) compare t1 t2 = compare (tileRep t1) (tileRep t2) -- |Make Halftile a Functor @@ -66,7 +65,7 @@ -{-# INLINE tileRep #-} +-- {-# INLINE tileRep #-} -- |return the representation of a half-tile tileRep:: HalfTile rep -> rep tileRep (LD r) = r diff --git a/src/Tgraph/Compose.hs b/src/Tgraph/Compose.hs --- a/src/Tgraph/Compose.hs +++ b/src/Tgraph/Compose.hs @@ -13,7 +13,8 @@ tryGetDartWingInfo, getDartWingInfoForced (and type DartWingInfo) and partComposeFacesFrom for debugging. -} -{-# LANGUAGE Strict #-} +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Tgraph.Compose ( -- * Composing forced Tgraphs @@ -26,25 +27,24 @@ , tryPartComposeFaces -- * Exported auxiliary functions (and type) -- , partCompFacesAssumeF - -- , partComposeFaces + , partComposeFaces -- , partComposeFacesF - , partComposeFacesFrom --new + -- , partComposeFacesFrom --new , DartWingInfo(..) -- , getDWIassumeF -- , getDartWingInfo , tryGetDartWingInfo , getDartWingInfoForced -- , composedFaceGroups - -- * Older versions (for debugging/comparison) - , oldGetDartWingInfo - , oldPartCompose + -- , oldGetDartWingInfo + -- , oldPartCompose ) where import Data.List (find,(\\),partition,nub) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..)) -import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!),alter,empty,elems) -import Data.Maybe (mapMaybe) +import qualified Data.IntMap.Strict as VMap (lookup,(!),alter,empty,elems) +import Data.Maybe (catMaybes,mapMaybe) import qualified Data.IntSet as IntSet (empty,insert,toList,member) import Tgraph.Prelude @@ -81,7 +81,7 @@ tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) tryPartCompose g = do dwInfo <- tryGetDartWingInfo g - let (~remainder,newFaces) = partComposeFacesFrom dwInfo + let (~remainder,newFaces) = partComposeFaces dwInfo checked <- onFail "tryPartCompose:\n" $ tryConnectedNoCross newFaces return (remainder,checked) @@ -90,30 +90,10 @@ tryPartComposeFaces:: Tgraph -> Try ([TileFace],[TileFace]) tryPartComposeFaces g = do dwInfo <- tryGetDartWingInfo g - return $ partComposeFacesFrom dwInfo + return $ partComposeFaces dwInfo -- tryPartComposeFaces is used in an example showing failure of the connected, no crossing boundary check. --- |Uses supplied dartwing info to get remainder faces and composed faces. --- Does not assume forced and does not check the composed faces for connected/no crossing boundaries -partComposeFacesFrom :: DartWingInfo -> ([TileFace], [TileFace]) -partComposeFacesFrom = partCompFacesAssumeF False - -{- --- |partComposeFaces g - produces a pair of the remainder faces (faces from g which will not compose) --- and the composed faces (which may or may not constitute faces of a valid Tgraph). --- It does not assume that g is forced which makes it less efficient than partComposeFacesF. -partComposeFaces:: Tgraph -> ([TileFace],[TileFace]) -partComposeFaces = partCompFacesAssumeF False - --- |partComposeFacesF (does the same as partComposeFaces for a Forced Tgraph). --- It produces a pair of the remainder faces (faces which will not compose) --- and the composed faces. -partComposeFacesF :: Forced Tgraph -> ([TileFace],[TileFace]) -partComposeFacesF = partCompFacesAssumeF True . forgetF - - -} - -- |partComposeF fg - produces a pair consisting of remainder faces (faces from fg which will not compose) -- and a composed (Forced) Tgraph. -- Since fg is a forced Tgraph it does not need a check for validity of the composed Tgraph. @@ -122,8 +102,9 @@ -- The calculation of remainder faces is also more efficient with a known forced Tgraph. partComposeF:: Forced Tgraph -> ([TileFace], Forced Tgraph) partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph newfaces) where - (~remainder,newfaces) = partCompFacesAssumeF True $ getDartWingInfoForced fg - + (~remainder,newfaces) = partCompFacesForced $ getDartWingInfoForced fg + + -- |composeF - produces a composed Forced Tgraph from a Forced Tgraph. -- Since the argument is a forced Tgraph it does not need a check for validity of the composed Tgraph. -- The fact that the function is total and the result is also Forced relies on theorems @@ -131,8 +112,6 @@ composeF:: Forced Tgraph -> Forced Tgraph composeF = snd . partComposeF - - -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. -- Faces at a largeKiteCentre vertex will form kite faces when composed. -- Faces at a largeDartBase vertex will form dart faces when composed. @@ -143,7 +122,7 @@ { largeKiteCentres :: [Vertex] -- ^ dart wing vertices classified as large kite centres. , largeDartBases :: [Vertex] -- ^ dart wing vertices classified as large dart bases. , unknowns :: [Vertex] -- ^ unclassified (boundary) dart wing vertices. - , faceMap :: VMap.IntMap [TileFace] -- ^ a mapping from dart wing vertices to faces at the vertex. + , faceMap :: VertexMap [TileFace] -- ^ a mapping from dart wing vertices to faces at the vertex. , unMapped :: [TileFace] -- ^ any faces not at a dart wing vertex (necessarily kites) } deriving Show @@ -153,12 +132,6 @@ recoverFaces dwInfo = nub $ concat (unMapped dwInfo : VMap.elems (faceMap dwInfo)) -{- -- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing, --- returning as DartWingInfo. It does not assume g is forced and is more expensive than getDartWingInfoForced -getDartWingInfo:: Tgraph -> DartWingInfo -getDartWingInfo = getDWIassumeF False - -} - -- |The given Tgraph is not assumed to be forced. -- Getting the dart wing information makes use of the forced version -- as well as the Tgraph so this uses tryForce first which can fail if @@ -186,31 +159,7 @@ , faceMap = dwFMap , unMapped = unused } where - (drts,kts) = partition isDart (faces g) - -- special case of vertexFacesMap for dart wings only - -- using only relevant vertices where there is a dart wing. - -- i.e only wings for darts and only oppVs and originVs for kites. - -- The map is built first from darts, then kites are added. - (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts - -- all kite halves added to relevant dart wings of the dart wing map. - where -- the unused list records half kites not added to any dart wing. - dartWMap = foldl' insertD VMap.empty drts - -- maps all dart wing vertices to 1 or 2 half darts. - insertD vmap f = VMap.alter (addD f) (wingV f) vmap - addD f Nothing = Just [f] - addD f (Just fs) = Just (f:fs) - insertK (vmap,unsd) f = - let opp = oppV f - org = originV f - in case (VMap.lookup opp vmap, VMap.lookup org vmap) of - (Just _ ,Just _) -> (VMap.alter (addK f) opp $ VMap.alter (addK f) org vmap, unsd) - (Just _ , Nothing) -> (VMap.alter (addK f) opp vmap, unsd) - (Nothing, Just _ ) -> (VMap.alter (addK f) org vmap, unsd) - (Nothing, Nothing) -> (vmap, f:unsd) -- kite face not at any dart wing - - addK _ Nothing = Nothing -- not added to map if it is not a dart wing vertex - addK f (Just fs) = Just (f:fs) - + (drts,dwFMap,unused) = dartsMapUnused g (allKcs,allDbs,allUnks) = foldl' processD (IntSet.empty, IntSet.empty, IntSet.empty) drts -- kcs = kite centres of larger kites, -- dbs = dart bases of larger darts, @@ -238,104 +187,23 @@ -- long edge drt shared with another dart => largeKiteCentre (kcs,dbs,IntSet.insert w unks) -- on the forced boundary so must be unknown - - --- |partCompFacesAssumeF --- (not exported but used to build 2 cases: partComposeFacesFrom, partComposeF) --- If the boolean is True then assumptions are made that the DartWingIno --- has come from a forced Tgraph, --- making the remainder faces calculation more efficient. -partCompFacesAssumeF :: Bool -> DartWingInfo -> ([TileFace],[TileFace]) -partCompFacesAssumeF isForced dwInfo = (remainder, newFaces) where - ~remainder = - if isForced - then -- unMapped faces plus all faces at unknowns. - unMapped dwInfo ++ concatMap (faceMap dwInfo VMap.!) (unknowns dwInfo) - else -- all faces except those successfully used in making composed faces. - recoverFaces dwInfo \\ concatMap concat [groupRDs, groupLDs, groupRKs, groupLKs] - - newFaces = newRDs ++ newLDs ++ newRKs ++ newLKs - - newRDs = map makenewRD groupRDs - groupRDs = mapMaybe groupRD (largeDartBases dwInfo) - makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) - makenewRD _ = error "composedFaceGroups: RD case" - groupRD v = do fcs <- VMap.lookup v (faceMap dwInfo) - rd <- find isRD fcs - lk <- find (matchingShortE rd) fcs - return [rd,lk] - - newLDs = map makenewLD groupLDs - groupLDs = mapMaybe groupLD (largeDartBases dwInfo) - makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld) - makenewLD _ = error "composedFaceGroups: LD case" - groupLD v = do fcs <- VMap.lookup v (faceMap dwInfo) - ld <- find isLD fcs - rk <- find (matchingShortE ld) fcs - return [ld,rk] - - newRKs = map makenewRK groupRKs - groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) - makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk) - makenewRK _ = error "composedFaceGroups: RK case" - groupRK v = do fcs <- VMap.lookup v (faceMap dwInfo) - rd <- find isRD fcs - lk <- find (matchingShortE rd) fcs - rk <- find (matchingJoinE lk) fcs - return [rd,lk,rk] - - newLKs = map makenewLK groupLKs - groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) - makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk) - makenewLK _ = error "composedFaceGroups: LK case" - groupLK v = do fcs <- VMap.lookup v (faceMap dwInfo) - ld <- find isLD fcs - rk <- find (matchingShortE ld) fcs - lk <- find (matchingJoinE rk) fcs - return [ld,rk,lk] - - --- |oldPartCompose g is a partial function producing a pair consisting of remainder faces (faces from g which will not compose) --- and a composed Tgraph. --- It checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails. --- It does not assume the given Tgraph is forced. --- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info). -oldPartCompose:: Tgraph -> ([TileFace],Tgraph) -oldPartCompose g = runTry $ onFail "oldPartCompose:\n" $ - do let dwInfo = oldGetDartWingInfo g - (~remainder,newFaces) = partComposeFacesFrom dwInfo - checked <- tryConnectedNoCross newFaces - return (remainder,checked) - - --- | oldGetDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing, --- returning as DartWingInfo. If only uses local information to classify each dart wing and can --- therefore sometimes classify a dart wing as unknown unnecessarily. --- In contrast tryGetDartWingInfo is accurate using information from forcing (so is not local) -oldGetDartWingInfo:: Tgraph -> DartWingInfo -oldGetDartWingInfo = oldGetDWIassumeF False - --- | oldGetDWIassumeF (not exported but used to define oldGetDartWingInfo). --- oldGetDWIassumeF isForced g, classifies the dart wings in g and calculates a faceMap for each dart wing, --- returning as DartWingInfo. The boolean isForced is used to decide if g can be assumed to be forced. -oldGetDWIassumeF:: Bool -> Tgraph -> DartWingInfo -oldGetDWIassumeF isForced g = - DartWingInfo { largeKiteCentres = IntSet.toList allKcs - , largeDartBases = IntSet.toList allDbs - , unknowns = IntSet.toList allUnks - , faceMap = dwFMap - , unMapped = unused - } where - (drts,kts) = partition isDart (faces g) +-- |(not exported - only used in getDWIassumeF) +-- Returns a triple of: +-- list of all half-darts, +-- a dart wing to faces map, and +-- left over faces (not at a dartwing) +dartsMapUnused :: Tgraph -> ([TileFace], VertexMap [TileFace],[TileFace]) +dartsMapUnused g = (drts,dwFMap,unused) where + (drts,kts) = partition isDart (faces g) -- special case of vertexFacesMap for dart wings only -- using only relevant vertices where there is a dart wing. - -- i.e only wingVs for darts and only oppVs and originVs for kites. + -- i.e only wings for darts and only oppVs and originVs for kites. -- The map is built first from darts, then kites are added. - (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts - -- all kite halves added to relevant dart wings of the dart wing faces map - where -- the unused list records half kites not added to any dart wing dartWMap = foldl' insertD VMap.empty drts - -- maps all dart wing vertices to 1 or 2 half darts + -- maps all dart wing vertices to 1 or 2 half darts. + (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts + -- all kite halves added to relevant dart wings of the dart wing map. + -- the unused list records half kites not added to any dart wing. insertD vmap f = VMap.alter (addD f) (wingV f) vmap addD f Nothing = Just [f] addD f (Just fs) = Just (f:fs) @@ -346,104 +214,21 @@ (Just _ ,Just _) -> (VMap.alter (addK f) opp $ VMap.alter (addK f) org vmap, unsd) (Just _ , Nothing) -> (VMap.alter (addK f) opp vmap, unsd) (Nothing, Just _ ) -> (VMap.alter (addK f) org vmap, unsd) - (Nothing, Nothing) -> (vmap, f:unsd) + (Nothing, Nothing) -> (vmap, f:unsd) -- kite face not at any dart wing addK _ Nothing = Nothing -- not added to map if it is not a dart wing vertex addK f (Just fs) = Just (f:fs) - (allKcs,allDbs,allUnks) = foldl' processD (IntSet.empty, IntSet.empty, IntSet.empty) drts --- kcs = kite centres of larger kites, --- dbs = dart bases of larger darts, --- unks = unclassified dart wing vertices --- Uses a triple of IntSets rather than lists - processD (kcs, dbs, unks) rd@(RD (orig, w, _)) = -- classify wing tip w - if w `IntSet.member` kcs || w `IntSet.member` dbs then (kcs, dbs, unks) else-- already classified - let - fcs = dwFMap VMap.! w -- faces at w --- Just fcs = VMap.lookup w dwFMap -- faces at w - in - if w `elem` map originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else - -- wing is a half kite origin => largeDartBase - if (w,orig) `elem` map longE (filter isLD fcs) then (IntSet.insert w kcs,dbs,unks) else - -- long edge rd shared with an ld => largeKiteCentre - if isForced || length fcs == 1 then (kcs, dbs, IntSet.insert w unks) else - case findFarK rd fcs of -- extra inspection only needed for unforced Tgraphs - Nothing -> (kcs,dbs,IntSet.insert w unks) -- unknown if incomplete kite attached to short edge of rd - Just rk@(RK _) -> - case find (matchingShortE rk) fcs of - Just (LK _) -> (IntSet.insert w kcs,dbs,unks) -- short edge rk shared with an lk => largeKiteCentres - Just (LD _) -> (kcs,IntSet.insert w dbs,unks) -- short edge rk shared with an ld => largeDartBases - _ -> let - newfcs = filter (isAtV (wingV rk)) (faces g) -- faces at rk wing - in - case find (matchingLongE rk) newfcs of -- short edge rk has nothing attached - Nothing -> (kcs,dbs,IntSet.insert w unks) -- long edge of rk has nothing attached => unknown - Just (LD _) -> (IntSet.insert w kcs,dbs,unks) -- long edge rk shared with ld => largeKiteCentres - Just lk@(LK _) -> -- long edge rk shared with lk - case find (matchingShortE lk) newfcs of - Just (RK _) -> (IntSet.insert w kcs,dbs,unks) - -- short edge of this lk shared with another rk => largeKiteCentres - Just (RD _) -> (kcs,IntSet.insert w dbs,unks) - -- short edge of this lk shared with rd => largeDartBases - _ -> (kcs,dbs,IntSet.insert w unks) - Just _ -> error "getDartWingInfo: illegal case for matchingLongE of a right kite" - -- short edge of this lk has nothing attached => unknown - Just _ -> error "getDartWingInfo: non-kite returned by findFarK" --- processD now uses a triple of IntSets rather than lists - processD (kcs, dbs, unks) ld@(LD (orig, _, w)) = -- classify wing tip w - if w `IntSet.member` kcs || w `IntSet.member` dbs then (kcs, dbs, unks) else -- already classified - let - fcs = dwFMap VMap.! w -- faces at w - in - if w `elem` map originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else - -- wing is a half kite origin => largeDartBase - if (orig,w) `elem` map longE (filter isRD fcs) then (IntSet.insert w kcs,dbs,unks) else - -- long edge ld shared with an rd => largeKiteCentre - if isForced || length fcs == 1 then (kcs, dbs, IntSet.insert w unks) else - case findFarK ld fcs of -- extra inspection only needed for unforced Tgraphs - Nothing -> (kcs,dbs,IntSet.insert w unks) -- unknown if incomplete kite attached to short edge of ld - Just lk@(LK _) -> - case find (matchingShortE lk) fcs of - Just (RK _) -> (IntSet.insert w kcs,dbs,unks) - -- short edge lk shared with an rk => largeKiteCentres - Just (RD _) -> (kcs,IntSet.insert w dbs,unks) - -- short edge lk shared with an rd => largeDartBases - _ -> let - newfcs = filter (isAtV (wingV lk)) (faces g) -- faces at lk wing - in - case find (matchingLongE lk) newfcs of -- short edge lk has nothing attached - Nothing -> (kcs,dbs,IntSet.insert w unks) -- long edge of lk has nothing attached => unknown - Just (RD _) -> (IntSet.insert w kcs,dbs,unks) -- long edge lk shared with rd => largeKiteCentres - Just rk@(RK _) -> -- long edge lk is shared with an rk - case find (matchingShortE rk) newfcs of - Just (LK _) -> (IntSet.insert w kcs,dbs,unks) - -- short edge of this rk shared with another lk => largeKiteCentres - Just (LD _) -> (kcs,IntSet.insert w dbs,unks) - -- short edge of this rk shared with ld => largeDartBases - _ -> (kcs,dbs,IntSet.insert w unks) -- short edge of this rk has nothing attached => unknown - Just _ -> error "getDartWingInfo: illegal case for matchingLongE of a left kite" - - Just _ -> error "getDartWingInfo: non-kite returned by findFarK" - - processD _ _ = error "getDartWingInfo: processD applied to non-dart" - - -- find the two kite halves below a dart half, return the half kite furthest away (not attached to dart). - -- Returns a Maybe. rd produces an rk (or Nothing) ld produces an lk (or Nothing) - findFarK :: TileFace -> [TileFace] -> Maybe TileFace - findFarK rd@(RD _) fcs = do lk <- find (matchingShortE rd) (filter isLK fcs) - find (matchingJoinE lk) (filter isRK fcs) - findFarK ld@(LD _) fcs = do rk <- find (matchingShortE ld) (filter isRK fcs) - find (matchingJoinE rk) (filter isLK fcs) - findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face" - -{- --- |Creates a list of new composed faces, each paired with a list of old faces (components of the new face) --- using dart wing information. No longer used. -composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])] -composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where +-- |partComposeFaces (exported only for use in composeK example in Extras) +-- Assumes not forced, so less efficient. +partComposeFaces :: DartWingInfo -> ([TileFace],[TileFace]) +partComposeFaces dwInfo = (remainder, evalFaces newFaces) where + ~remainder = recoverFaces dwInfo \\ concatMap concat [groupRDs, groupLDs, groupRKs, groupLKs] + -- all faces except those successfully used in making composed faces. + newFaces = newRDs ++ newLDs ++ newRKs ++ newLKs - faceGroupRDs = map (\gp -> (makenewRD gp,gp)) groupRDs + newRDs = map makenewRD groupRDs groupRDs = mapMaybe groupRD (largeDartBases dwInfo) makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) makenewRD _ = error "composedFaceGroups: RD case" @@ -452,7 +237,7 @@ lk <- find (matchingShortE rd) fcs return [rd,lk] - faceGroupLDs = map (\gp -> (makenewLD gp,gp)) groupLDs + newLDs = map makenewLD groupLDs groupLDs = mapMaybe groupLD (largeDartBases dwInfo) makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld) makenewLD _ = error "composedFaceGroups: LD case" @@ -461,7 +246,7 @@ rk <- find (matchingShortE ld) fcs return [ld,rk] - faceGroupRKs = map (\gp -> (makenewRK gp,gp)) groupRKs + newRKs = map makenewRK groupRKs groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk) makenewRK _ = error "composedFaceGroups: RK case" @@ -471,7 +256,7 @@ rk <- find (matchingJoinE lk) fcs return [rd,lk,rk] - faceGroupLKs = map (\gp -> (makenewLK gp,gp)) groupLKs + newLKs = map makenewLK groupLKs groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk) makenewLK _ = error "composedFaceGroups: LK case" @@ -481,5 +266,38 @@ lk <- find (matchingJoinE rk) fcs return [ld,rk,lk] --} +-- | New composing faces for Forced only (not exported) +-- Returns remainder faces paired with newly composed faces. +partCompFacesForced :: DartWingInfo -> ([TileFace], [TileFace]) +partCompFacesForced dwInfo = (remainder, evalFaces newFaces) where + ~remainder = unMapped dwInfo ++ concatMap (faceMap dwInfo VMap.!) (unknowns dwInfo) + newFaces = concatMap doDartFor (largeDartBases dwInfo) ++ concatMap doKiteFor (largeKiteCentres dwInfo) + doDartFor v = + case VMap.lookup v (faceMap dwInfo) of + Nothing -> error $ "partComoseF: Dart base vertex not found in map (" ++ show v ++ ")/n" + Just fcs -> catMaybes [largeRD fcs, largeLD fcs] + largeRD:: [TileFace] -> Maybe TileFace + largeRD fcs = do rd <- find isRD fcs + lk <- find ((==oppV rd) . wingV) fcs + return $ makeRD (originV lk) (originV rd) (wingV rd) + + largeLD fcs = do ld <- find isLD fcs + rk <- find ((==oppV ld) . wingV) fcs + return $ makeLD (originV rk) (wingV ld) (originV ld) + + doKiteFor v = + case VMap.lookup v (faceMap dwInfo) of + Nothing -> error $ "partComoseF: Kite centre vertex not found in map (" ++ show v ++ ")/n" + Just fcs -> catMaybes [largeRK fcs, largeLK fcs] + + largeRK fcs = do rd <- find isRD fcs + lk <- find ((==oppV rd) . wingV) fcs + rk <- find (matchingJoinE lk) fcs + return $ makeRK (originV rd) (wingV rk) (originV lk) + largeLK fcs = do ld <- find isLD fcs + rk <- find ((==oppV ld) . wingV) fcs + lk <- find (matchingJoinE rk) fcs + return $ makeLK (originV ld) (originV rk) (wingV lk) + + diff --git a/src/Tgraph/Decompose.hs b/src/Tgraph/Decompose.hs --- a/src/Tgraph/Decompose.hs +++ b/src/Tgraph/Decompose.hs @@ -10,8 +10,9 @@ two auxiliary functions for debugging and experimenting. -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE Strict #-} +-- {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Tgraph.Decompose ( decompose @@ -22,7 +23,8 @@ , decompFace ) where -import qualified Data.Map.Strict as Map (Map, (!), fromList) +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map ((!), fromList) import Data.List(sort) import Tgraph.Prelude @@ -42,38 +44,39 @@ -- |Decompose all the faces (using a phiVMap for new vertices). decomposeFaces :: HasFaces a => a -> [TileFace] -decomposeFaces a = newFaces where - pvmap = phiVMap (faces a) +decomposeFaces a = evalFaces newFaces where + pvmap = phiVMap a newFaces = concatMap (decompFace pvmap) (faces a) -- |phiVMap fcs produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in fcs. -- Both (a,b) and (b,a) get the same new vertex number. This is used(in decompFace, decompFaces and decompose. -- (Sort is used to fix order of assigned numbers). -- (Exported for use in TrackedTgraphs in Tgraphs module). -phiVMap :: HasFaces a => a -> Map.Map Dedge Vertex -phiVMap fcs = edgeVMap where - phiReps = sort [(a,b) | (a,b) <- phiEdges fcs, a a -> Map Dedge Vertex +phiVMap x = edgeVMap where + --phiReps = sort [e | e@(a,b) <- phiEdges fcs, a TileFace -> [TileFace] +decompFace:: Map Dedge Vertex -> TileFace -> [TileFace] decompFace newVFor fc = case fc of RK(a,b,c) -> [RK(c,x,b), LK(c,y,x), RD(a,x,y)] - where !x = (Map.!) newVFor (a,b) - !y = (Map.!) newVFor (c,a) + where x = (Map.!) newVFor (a,b) + y = (Map.!) newVFor (c,a) LK(a,b,c) -> [LK(b,c,y), RK(b,y,x), LD(a,x,y)] - where !x = (Map.!) newVFor (a,b) - !y = (Map.!) newVFor (c,a) + where x = (Map.!) newVFor (a,b) + y = (Map.!) newVFor (c,a) RD(a,b,c) -> [LK(a,x,c), RD(b,c,x)] - where !x = (Map.!) newVFor (a,b) + where x = (Map.!) newVFor (a,b) LD(a,b,c) -> [RK(a,b,x), LD(c,x,b)] - where !x = (Map.!) newVFor (a,c) + where x = (Map.!) newVFor (a,c) -- |infinite list of decompositions of a Tgraph decompositions :: Tgraph -> [Tgraph] diff --git a/src/Tgraph/Extras.hs b/src/Tgraph/Extras.hs --- a/src/Tgraph/Extras.hs +++ b/src/Tgraph/Extras.hs @@ -20,6 +20,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Tgraph.Extras ( smart @@ -27,7 +28,6 @@ , drawJoinsFor , smartdraw , smartOn - , restrictSmart , smartRotateBefore , smartAlignBefore -- * Overlaid drawing tools for Tgraphs @@ -58,9 +58,7 @@ , tryDartAndKiteF , tryCheckCasesDKF , checkCasesDKF - , boundaryEdgeSet , commonBdry - , boundaryVertexSet , internalVertexSet , drawFBCovering , empire1 @@ -106,8 +104,9 @@ import Data.List (intersect, union, (\\), find, transpose) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..)) -import qualified Data.Set as Set (Set,fromList,null,intersection,deleteFindMin)-- used for boundary covers -import qualified Data.IntSet as IntSet (fromList,member,(\\)) -- for boundary vertex set +import Data.Set(Set) +import qualified Data.Set as Set (null,intersection,deleteFindMin)-- used for boundary covers +import qualified Data.IntSet as IntSet (member,(\\)) -- for boundary vertex set import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops import Data.Maybe (fromMaybe) @@ -153,12 +152,6 @@ a -> (VPatch -> Diagram b) -> VPatch -> Diagram b smartOn a dr vp = drawBoundaryJoins a rvp <> dr rvp where rvp = restrictTo a vp -{-# DEPRECATED restrictSmart "Use smartOn" #-} --- | DEPRECATED restrictSmart: Use smartOn -restrictSmart :: (HasFaces a, OKBackend b) => - a -> (VPatch -> Diagram b) -> VPatch -> Diagram b -restrictSmart = smartOn - -- |smartRotateBefore vfun a g - a tricky combination of smart with rotateBefore. -- Uses vfun to produce a Diagram after converting g to a rotated VPatch but also adds the dashed boundary join edges of g. -- @@ -255,16 +248,16 @@ (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram b drawCommonFaces (g1,e1) (g2,e2) = emphasizeFaces (commonFaces (g1,e1) (g2,e2)) g1 --- |emphasizeFaces fcs g emphasizes the given faces (that are in g) overlaid on the background draw g. -emphasizeFaces :: OKBackend b => - [TileFace] -> Tgraph -> Diagram b -emphasizeFaces fcs g = (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where +-- |emphasizeFaces a g - emphasizes the faces that are in a and g, overlaid on the background draw g. +emphasizeFaces :: (OKBackend b, HasFaces a) => + a -> Tgraph -> Diagram b +emphasizeFaces a g = (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where vp = makeVP g - emphvp = subFaces (fcs `intersect` faces g) vp + emphvp = subFaces (faces a `intersect` faces g) vp -- | For illustrating an unsound version of composition which defaults to kites when there are unknown --- dart wings on the boundary. +-- dart wings on the boundary (with just a half kite and the half dart at the dart wing). -- This is unsound in that it can create an incorrect Tgraph from a correct Tgraph. -- E.g. when applied to force queenGraph. composeK :: Tgraph -> Tgraph @@ -273,7 +266,7 @@ let changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo , unknowns = [] } - ( _ , newfaces) = partComposeFacesFrom changedInfo + ( _ , newfaces) = partComposeFaces changedInfo tryConnectedNoCross newfaces {- composeK :: Tgraph -> Tgraph composeK g = runTry $ tryConnectedNoCross newfaces where @@ -356,8 +349,8 @@ successfully forced forcibles are correct. -} boundaryECovering:: Forced BoundaryState -> [Forced BoundaryState] -boundaryECovering forcedbs = covers [(forcedbs, boundaryEdgeSet (forgetF forcedbs))] where - covers:: [(Forced BoundaryState, Set.Set Dedge)] -> [Forced BoundaryState] +boundaryECovering forcedbs = covers [(forcedbs, boundaryESet (forgetF forcedbs))] where + covers:: [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState] covers [] = [] covers ((fbs,es):opens) | Set.null es = fbs:covers opens -- bs is a completed cover @@ -367,13 +360,9 @@ (runTry $ tryCheckCasesDKF de fbs) --- |Make a set of the directed boundary edges from tilefaces -boundaryEdgeSet:: HasFaces a => a -> Set.Set Dedge -boundaryEdgeSet = Set.fromList . boundary - -- | commonBdry des a - returns those directed edges in des that are boundary directed edges of a -commonBdry:: HasFaces a => Set.Set Dedge -> a -> Set.Set Dedge -commonBdry des a = des `Set.intersection` boundaryEdgeSet a +commonBdry:: HasFaces a => Set Dedge -> a -> Set Dedge +commonBdry des a = des `Set.intersection` boundaryESet a {-| boundaryVCovering fbd - similar to boundaryECovering, but produces a list of all possible covers of the boundary vertices in fbd (rather than just boundary edges). @@ -381,9 +370,9 @@ -} boundaryVCovering:: Forced BoundaryState -> [Forced BoundaryState] boundaryVCovering fbd = covers [(fbd, startbds)] where - startbds = boundaryEdgeSet $ forgetF fbd - startbvs = boundaryVertexSet $ forgetF fbd ---covers:: [(Forced BoundaryState,Set.Set Dedge)] -> [Forced BoundaryState] + startbds = boundaryESet $ forgetF fbd + startbvs = boundaryVSet $ forgetF fbd +--covers:: [(Forced BoundaryState,Set Dedge)] -> [Forced BoundaryState] covers [] = [] covers ((open,es):opens) | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary $ forgetF open) of @@ -392,15 +381,9 @@ | otherwise = covers $ map (\b -> (b, commonBdry des (forgetF b))) (atLeastOne $ tryDartAndKiteF de (forgetF open)) ++opens where (de,des) = Set.deleteFindMin es - --- | returns the set of boundary vertices of a tilefaces -boundaryVertexSet :: HasFaces a => a -> VertexSet -boundaryVertexSet = IntSet.fromList . boundaryVs - -- | returns the set of internal vertices of a tilefaces internalVertexSet :: HasFaces a => a -> VertexSet -internalVertexSet a = vertexSet a IntSet.\\ boundaryVertexSet a - +internalVertexSet a = vertexSet a IntSet.\\ boundaryVSet a -- | tryDartAndKite de b - returns the list of (2) results after adding a dart (respectively kite) -- to edge de of a Forcible b. Each of the results is a Try. @@ -615,7 +598,7 @@ -- this returns the tile label for the face covering each edge in edgelist (in corresponding order). -- reportCover :: BoundaryState -> [Dedge] -> [HalfTileLabel] reportCover bd des = map (tileLabel . getf) des where - efmap = dedgesFacesMap des (faces bd) -- more efficient than using graphEFMap? + efmap = dedgeFMap des bd -- more efficient than using graphEFMap? -- efmap = graphEFMap (recoverGraph bd) getf e = fromMaybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e) (faceForEdge e efmap) @@ -729,10 +712,10 @@ -- |TrackedTgraph is in class HasFaces instance HasFaces TrackedTgraph where faces = faces . tgraph - boundary = boundary . faces . tgraph - maxV = maxV . faces . tgraph - boundaryVFMap = boundaryVFMap . faces -- note need for nub - +{- boundary = boundary . tgraph + maxV = maxV . tgraph + boundaryVFMap = boundaryVFMap . tgraph -- note need for nub + -} -- |addHalfDartTracked ttg e - add a half dart to the tgraph of ttg on the given edge e, -- and push the new singleton face list onto the tracked list. addHalfDartTracked:: Dedge -> TrackedTgraph -> TrackedTgraph diff --git a/src/Tgraph/Force.hs b/src/Tgraph/Force.hs --- a/src/Tgraph/Force.hs +++ b/src/Tgraph/Force.hs @@ -11,10 +11,11 @@ It introduces BoundaryState and ForceState types and includes a Forcible class with instances for Tgraph, BoundaryState, and ForceState. -The module is made strict (to remove many space leaks). +The module is made strict to avoid space leaks. -} -{-# LANGUAGE Strict #-} +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Tgraph.Force ( -- * Forcible class @@ -51,6 +52,7 @@ , tryOneStepWith , tryOneStepForce -- * Types for Forcing +-- , BoundaryDedges , BoundaryState(..) , ForceState(..) , BoundaryChange(..) @@ -66,9 +68,9 @@ -- , changeVFMap -- Now HIDDEN , facesAtBV -- , boundaryVFacesBS (removed) - , boundaryFaces --deprecated -- * Auxiliary Functions for a force step , affectedBoundary + , boundaryAt -- , mustFind , tryReviseUpdates , tryReviseFSWith @@ -150,10 +152,13 @@ import Data.List ((\\), intersect, nub, find) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..)) -import qualified Data.Map as Map (Map, empty, delete, elems, insert, union, keys) -- used for UpdateMap -import qualified Data.IntMap.Strict as VMap (elems, filterWithKey, alter, delete, lookup, (!)) +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map (empty, delete, elems, insert, union, keys) -- used for UpdateMap +import qualified Data.IntMap.Strict as VMap (null, filter, filterWithKey, alter, delete, lookup, (!), keysSet) +import qualified Data.IntSet as IntSet (member,empty,insert) -- used for BoundaryState locations AND faces at boundary vertices --- import qualified Data.Maybe(fromMaybe) -- was used for lazy mustFind only +import Data.Set (Set) +import qualified Data.Set as Set (insert,delete,foldr') import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate import Tgraph.Prelude @@ -166,49 +171,53 @@ *************************************************************************** -} - +-- | type to represent the boundary directed edges in a BoundaryState (currently as a Set) +type BoundaryDedges = Set Dedge -- was [Dedge] {-| A BoundaryState records -the boundary directed edges (directed so that faces are on LHS and exterior is on RHS) -plus -a mapping of boundary vertices to their incident faces, plus -a mapping of boundary vertices to positions (using Tgraph.Prelude.locateVertices). -It also keeps track of all the faces -and the next vertex label to be used when adding a new vertex. +a mapping of boundary vertices to their incident faces, +a mapping of boundary vertices to positions (using Tgraph.Prelude.locateGraphVertices), +a list of all the faces, +the next vertex label to be used when adding a new vertex, +the set of boundary directed edges (directed so that faces are on LHS and exterior is on RHS). + +N.B the boundary edges kept in a BoundaryState are not used once forcing has started, +but they cost very little to keep track of and provide a quick way to get the boundary +at any stage. -} data BoundaryState = BoundaryState - { boundaryDedges:: [Dedge] -- ^ boundary directed edges (face on LHS, exterior on RHS) + { boundaryDedges:: BoundaryDedges -- ^ boundary directed edges (face on LHS, exterior on RHS) , bvFacesMap:: VertexMap [TileFace] -- ^faces at each boundary vertex. , bvLocMap:: VertexMap (Point V2 Double) -- ^ position of each boundary vertex. , allFaces:: [TileFace] -- ^ all the tile faces , nextVertex:: Vertex -- ^ next vertex number } deriving (Show) --- |BoundaryState is in class HasFaces +-- |BoundaryState is in class HasFaces. +-- Note the default implementations are overiden to use precalculated information instance HasFaces BoundaryState where faces = allFaces - boundary = boundaryDedges - maxV bd = nextVertex bd - 1 - boundaryVFMap = bvFacesMap + boundaryESet = boundaryDedges -- (overrides default) boundary already calculated + maxV bd = nextVertex bd - 1 -- (overrides default) + boundaryVFMap = bvFacesMap -- (overrides default) already calculated -- |Calculates BoundaryState information from a Tgraph. makeBoundaryState:: Tgraph -> BoundaryState makeBoundaryState g = - let bdes = boundary g - bvs = map fst bdes -- (map snd bdes would also do) for all boundary vertices - bvLocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ faces g + let bdes = boundaryESet g + bvs = Set.foldr' ((IntSet.insert).fst) IntSet.empty bdes --IntSet.fromList (map fst $ Set.toList bdes) -- (map snd bdes would also do) for all boundary vertices + bvLocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices g in BoundaryState { boundaryDedges = bdes - , bvFacesMap = vertexFacesMap bvs (faces g) + , bvFacesMap = vertexFMap bvs g , bvLocMap = bvLocs , allFaces = faces g , nextVertex = 1+ maxV g } - -- |Converts a BoundaryState back to a Tgraph recoverGraph:: BoundaryState -> Tgraph recoverGraph = makeUncheckedTgraph . faces @@ -226,17 +235,6 @@ Just fcs -> fcs Nothing -> error $ "facesAtBV: Not a boundary vertex? No result found for vertex " ++ show v ++ "\n" -{- -- |return a list of faces which have a boundary vertex from a BoundaryState -boundaryVFacesBS :: BoundaryState -> [TileFace] -boundaryVFacesBS bd = nub $ concatMap (facesAtBV bd) bvs where - bvs = boundaryVs bd - -} - -{-# DEPRECATED boundaryFaces "Use boundaryVFaces or boundaryEdgeFaces" #-} --- | DEPRECATED boundaryFaces: Use boundaryVFaces or boundaryEdgeFaces -boundaryFaces :: BoundaryState -> [TileFace] -boundaryFaces = boundaryVFaces - -- |An Update is either safe or unsafe. -- A safe update has a new face involving 3 existing vertices. -- An unsafe update has a makeFace function to create the new face when given a fresh third vertex. @@ -250,7 +248,7 @@ -- |UpdateMap: partial map associating updates with (some) boundary directed edges. -- (Any boundary directed edge will have the opposite direction in some face.) -type UpdateMap = Map.Map Dedge Update +type UpdateMap = Map Dedge Update -- |ForceState: The force state records information between executing single face updates during forcing -- (a BoundaryState and an UpdateMap). @@ -259,10 +257,11 @@ , updateMap:: UpdateMap } deriving (Show) --- |ForceState is in class HasFaces +-- |ForceState is in class HasFaces. +-- (using the boundaryState implementations) instance HasFaces ForceState where faces = faces . boundaryState - boundary = boundary . boundaryState + boundaryESet = boundaryESet . boundaryState maxV = maxV . boundaryState boundaryVFMap = boundaryVFMap . boundaryState @@ -309,7 +308,6 @@ tryChangeBoundaryWith ugen f fs = do bdC <- f (boundaryState fs) tryReviseFSWith ugen bdC fs --- boundaryState = boundaryState -- | BoundaryStates are Forcible instance Forcible BoundaryState where @@ -330,26 +328,32 @@ tryInitFSWith ugen g = tryInitFSWith ugen (makeBoundaryState g) tryChangeBoundaryWith ugen f g = -- update generator not used recoverGraph <$> tryChangeBoundaryWith ugen f (makeBoundaryState g) --- boundaryState = makeBoundaryState + -- | try forcing using a given UpdateGenerator. -- tryForceWith uGen fs - does updates using uGen until there are no more updates. -- It produces Left report if it encounters a Forcible representing a stuck/incorrect Tgraph. tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a -tryForceWith ugen = tryFSOpWith ugen (tryForceStateWith ugen) where +tryForceWith ugen = tryFSOpWith ugen retry where -- tryForceStateWith :: UpdateGenerator -> ForceState -> Try ForceState - tryForceStateWith uGen = retry where - retry fs = case findSafeUpdate (updateMap fs) of +-- tryForceStateWith uGen = retry where + retry fs = do r <- tryOneStepWith ugen fs + case r of + Just (fs',_) -> retry fs' + Nothing -> return fs -- final state (no more updates) + +{- retry fs = case findSafeUpdate (updateMap fs) of Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u - fs' <- tryReviseFSWith uGen bdChange fs + fs' <- tryReviseFSWith ugen bdChange fs retry fs' _ -> do maybeBdC <- tryUnsafes fs case maybeBdC of Nothing -> Right fs -- no more updates - Just bdC -> do fs' <- tryReviseFSWith uGen bdC fs + Just bdC -> do fs' <- tryReviseFSWith ugen bdC fs retry fs' - + -} + -- | try a given number of force steps using a given UpdateGenerator. tryStepForceWith :: Forcible a => UpdateGenerator -> Int -> a -> Try a tryStepForceWith ugen n = @@ -426,8 +430,8 @@ -- |Extend HasFaces ops from a to Forced a instance HasFaces a => HasFaces (Forced a) where faces = faces . forgetF - boundary = boundary . forgetF - maxV = maxV . faces + boundaryESet = boundaryESet . forgetF + maxV = maxV . forgetF boundaryVFMap = boundaryVFMap . forgetF -- | Constructs an explicitly Forced type. @@ -464,6 +468,21 @@ initFSF :: Forcible a => Forced a -> Forced ForceState initFSF (Forced a) = Forced (initFS a) +-- |try to find the right direction for an edge to be a boundary directed edge. +-- Fails if neither direction is consistent with boundary directed edges. +tryOnBoundary :: Dedge -> BoundaryState -> Try Dedge +tryOnBoundary e@(a,b) bd = + let bdes = boundaryAt a bd + in case find (==e) bdes of + Just _ -> Right e + Nothing -> case find (==(b,a)) bdes of + Just re -> Right re + Nothing -> failReports + ["tryOnBoundary:\nNeither " + ,show e, " nor ", show(reverseD e), " are on the boundary\n" + ] + + -- |addHalfKite is for adding a single half kite on a chosen boundary Dedge of a Forcible. -- The Dedge must be a boundary edge but the direction is not important as -- the correct direction is automatically calculated. @@ -481,13 +500,7 @@ -- |tryAddHalfKiteBoundary implements tryAddHalfKite as a BoundaryState change -- tryAddHalfKiteBoundary :: Dedge -> BoundaryState -> Try BoundaryChange tryAddHalfKiteBoundary e bd = - do de <- case [e, reverseD e] `intersect` boundary bd of - [de] -> Right de - _ -> failReports - ["tryAddHalfKite: on non-boundary edge " - ,show e - ,"\n" - ] + do de <- tryOnBoundary e bd let (fc,etype) = inspectBDedge bd de let tryU | etype == Long = addKiteLongE bd fc | etype == Short = addKiteShortE bd fc @@ -514,13 +527,7 @@ -- |tryAddHalfDartBoundary implements tryAddHalfDart as a BoundaryState change -- tryAddHalfDartBoundary :: Dedge -> BoundaryState -> Try BoundaryChange tryAddHalfDartBoundary e bd = - do de <- case [e, reverseD e] `intersect` boundary bd of - [de] -> Right de - _ -> failReports - ["tryAddHalfDart: on non-boundary edge " - ,show e - ,"\n" - ] + do de <- tryOnBoundary e bd let (fc,etype) = inspectBDedge bd de let tryU | etype == Long = addDartLongE bd fc | etype == Short && isKite fc = addDartShortE bd fc @@ -530,11 +537,15 @@ tryUpdate bd u --- |tryOneStepWith uGen fs does one force step (used for debugging purposes). --- It returns either (1) a Right(Just (f,bc)) with a new ForceState f paired with a BoundaryChange bc --- (using uGen to revise updates in the final ForceState), or (2) --- a Right Nothing indicating forcing has finished and there are no more updates, or (3) --- a Left report for a stuck/incorrect graph. +-- |tryOneStepWith uGen fs does one force step. +-- It returns either +-- +-- (1) a Right(Just (f,bc)) with a new ForceState f paired with the BoundaryChange bc. +-- (bc is only returned for debugging purposes as it has been used with uGen to create the resulting ForceState f), or +-- +-- (2) a Right Nothing indicating forcing has finished and there are no more updates, or +-- +-- (3) a Left report for a stuck/incorrect graph. tryOneStepWith :: UpdateGenerator -> ForceState -> Try (Maybe (ForceState,BoundaryChange)) tryOneStepWith uGen fs = case findSafeUpdate (updateMap fs) of @@ -565,70 +576,57 @@ , newFace :: TileFace -- ^ face added in the change } deriving (Show) + {-| Given a BoundaryState with a list of one boundary edge or two adjacent boundary edges (or exceptionally no boundary edges), it extends the list with adjacent boundary edges (to produce 3 or 4 or none). It will raise an error if given more than 2 or 2 non-adjacent boundary edges. (Used to calculate revisedEdges in a BoundaryChange. - (N.B. When a new face is fitted in to a hole with 3 sides there is no new boundary. Hence the need to allow for an empty list.) + (N.B. When a new face is fitted in to a hole with 3 sides there is no new boundary. + Hence the need to allow for an empty list.) -} affectedBoundary :: BoundaryState -> [Dedge] -> [Dedge] -affectedBoundary bd [e1@(a,b)] = [e0,e1,e2] where - bdry = boundary bd - e0 = mustFind ((==a).snd) bdry - (\()-> error $ "affectedBoundary: boundary edge not found with snd = " - ++ show a ++ "\nand edges: " ++ show [e1] - ++ "\nwith boundary:\n" ++ show bdry ++ "\n") - e2 = mustFind ((==b).fst) bdry - (\()-> error $ "affectedBoundary: boundary edge not found with fst = " - ++ show b ++ "\nand edges: " ++ show [e1] - ++ "\nwith boundary:\n" ++ show bdry ++ "\n") -affectedBoundary bd [e1@(a,b),e2@(c,d)] | c==b = [e0,e1,e2,e3] where - bdry = boundary bd - e0 = mustFind ((==a).snd) bdry - (\()-> error $ "affectedBoundary (c==b): boundary edge not found with snd = " - ++ show a ++ "\nand edges: " ++ show [e1,e2] - ++ "\nwith boundary:\n" ++ show bdry ++ "\n") - e3 = mustFind ((==d).fst) bdry - (\()-> error $ "affectedBoundary: boundary edge not found with fst = " - ++ show d ++ "\nand edges: " ++ show [e1,e2] - ++ "\nwith boundary:\n" ++ show bdry ++ "\n") -affectedBoundary bd [e1@(a,b),e2@(c,d)] | a==d = [e0,e2,e1,e3] where - bdry = boundary bd - e0 = mustFind ((==c).snd) bdry - (\()-> error $ "affectedBoundary (a==d): boundary edge not found with snd = " - ++ show c ++ "\nand edges: " ++ show [e1,e2] - ++ "\nwith boundary:\n" ++ show bdry ++ "\n") - e3 = mustFind ((==b).fst) bdry - (\()-> error $ "affectedBoundary: boundary edge not found with fst = " - ++ show b ++ "\nand edges: " ++ show [e1,e2] - ++ "\nwith boundary:\n" ++ show bdry ++ "\n") +affectedBoundary bs [e1@(a,b)] = [e0,e1,e2] where + e0 = preceding a bs + e2 = following b bs +affectedBoundary bs [e1@(a,b),e2@(c,d)] | c==b = [e0,e1,e2,e3] where + e0 = preceding a bs + e3 = following d bs +affectedBoundary bs [e1@(a,b),e2@(c,d)] | a==d = [e0,e2,e1,e3] where + e0 = preceding c bs + e3 = following b bs affectedBoundary _ [] = [] -- case for filling a triangular hole affectedBoundary _ edges = error $ "affectedBoundary: unexpected boundary edges " ++ show edges ++ "\n(Either more than 2 or 2 not adjacent)\n" + -- |find the directed edge following the given vertex round the boundary +following :: Vertex -> BoundaryState -> Dedge +following a = snd . oboundaryAt a -{-| mustFind (older version requires laziness) - an auxiliary function used to search with definite result. -mustFind p ls default returns the first item in ls satisfying predicate p and returns -default argument when none found (in finite cases). -Special case: the default arg may be used to raise an error when nothing is found. +-- |find the directed edge preceeding the given vertex round the boundary +preceding :: Vertex -> BoundaryState -> Dedge +preceding a = fst . oboundaryAt a +{- + -- |find the directed edge following the given vertex round the boundary +following :: Vertex -> BoundaryState -> Maybe Dedge +following a = find ((==a).fst) . boundaryAt a -mustFind :: Foldable t => (p -> Bool) -> t p -> p -> p -mustFind p ls dflt - = Data.Maybe.fromMaybe dflt (find p ls) --} +-- |find the directed edge preceeding the given vertex round the boundary +preceding :: Vertex -> BoundaryState -> Maybe Dedge +preceding a = find ((==a).snd) . boundaryAt a + -} +-- | get the (2) boundary edges at a boundary vertex +-- (raises an error if the vertex is not on the boundary). +boundaryAt :: Vertex -> BoundaryState -> [Dedge] +boundaryAt v bs = missingRevs [e| f <- facesAtBV bs v, e@(a,b) <- faceDedges f, v==a || v==b] -{-| mustFind (strict version) is an auxiliary function used to search with definite result. -mustFind' p ls defaulfnt returns the first item in ls satisfying predicate p and returns -defaultfn () when none found (in finite cases). -This is a replacement foran older mustFind that relied on laziness. -This version works in a strict context. --} -mustFind :: Foldable t => (p -> Bool) -> t p -> (() -> p) -> p -mustFind p ls dflt - = case find p ls of - Just a -> a - Nothing -> dflt () +-- | get the (2) boundary edges at a boundary vertex in order as a pair +-- (raises an error if the vertex is not on the boundary). +oboundaryAt :: Vertex -> BoundaryState -> (Dedge, Dedge) +oboundaryAt v = order . boundaryAt v + where order [e1@(_,b),e2@(c,_)]| b==c = (e1,e2) + | otherwise = (e2,e1) + order _ = error $ "oboundaryAt: Crossing boundary found at " ++ show v ++ "\n" -- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange) -- using uGen to calculate new updates. @@ -671,7 +669,7 @@ ," unsafe updates but ALL unsafe updates are blocked (by touching vertices)\n" ,"This should not happen! However it may arise when accuracy limits are reached on very large Tgraphs.\n" ,"Total number of faces is " - ,show (length $ faces bd) + ,show (faceCount bd) ,"\n" ] checkBlocked n (u: more) = case checkUnsafeUpdate bd u of @@ -689,8 +687,8 @@ checkUnsafeUpdate:: BoundaryState -> Update -> Maybe BoundaryChange checkUnsafeUpdate _ (SafeUpdate _) = error "checkUnsafeUpdate: applied to safe update.\n" checkUnsafeUpdate bd (UnsafeUpdate makeFace) = - let !v = nextVertex bd - !newface = makeFace v + let v = nextVertex bd + newface = makeFace v oldVPoints = bvLocMap bd newVPoints = addVPoint newface oldVPoints vPosition = newVPoints VMap.! v -- Just vPosition = VMap.lookup v newVPoints @@ -698,7 +696,7 @@ matchedDedges = filter (\(x,y) -> x /= v && y /= v) fDedges -- singleton newDedges = map reverseD (fDedges \\ matchedDedges) -- two edges resultBd = BoundaryState - { boundaryDedges = newDedges ++ (boundary bd \\ matchedDedges) + { boundaryDedges = insertEdges newDedges $ deleteEdges matchedDedges $ boundaryDedges bd , bvFacesMap = changeVFMap newface (bvFacesMap bd) , bvLocMap = newVPoints , allFaces = newface:allFaces bd @@ -728,19 +726,20 @@ trySafeUpdate _ (UnsafeUpdate _) = error "trySafeUpdate: applied to non-safe update.\n" trySafeUpdate bd (SafeUpdate newface) = let fDedges = faceDedges newface - localRevDedges = [(b,a) | v <- faceVList newface, f <- bvFacesMap bd VMap.! v, (a,b) <- faceDedges f] + localRevDedges = [(b,a) | v <- faceVList newface, !f <- facesAtBV bd v, (a,b) <- faceDedges f] matchedDedges = fDedges `intersect` localRevDedges -- list of 2 or 3 - -- matchedDedges = fDedges `intersect` boundary bd -- list of 2 or 3 removedBVs = commonVs matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3) newDedges = map reverseD (fDedges \\ matchedDedges) -- one or none nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs resultBd = BoundaryState - { boundaryDedges = newDedges ++ (boundaryDedges bd \\ matchedDedges) + { boundaryDedges = insertEdges newDedges $ deleteEdges matchedDedges $ boundaryDedges bd + -- newDedges ++ (boundaryDedges bd \\ matchedDedges) , bvFacesMap = foldl' (flip VMap.delete) (changeVFMap newface $ bvFacesMap bd) removedBVs -- , bvFacesMap = changeVFMap newface (bvFacesMap bd) , allFaces = newface:allFaces bd - , bvLocMap = foldr VMap.delete (bvLocMap bd) removedBVs - --remove vertex/vertices no longer on boundary + -- , bvLocMap = foldr VMap.delete (bvLocMap bd) removedBVs + , bvLocMap = foldl' (flip VMap.delete) (bvLocMap bd) removedBVs + --remove vertex/vertices no longer on boundary , nextVertex = nextVertex bd } bdChange = BoundaryChange @@ -759,6 +758,12 @@ ,"\n" ] +-- |add some edges to the boundary (second arg is boundary) +insertEdges :: [Dedge] -> BoundaryDedges -> BoundaryDedges +insertEdges = flip (foldl' (flip Set.insert)) -- (++) +-- | remove some edges from the boundary (second arg is boundary) +deleteEdges :: [Dedge] -> BoundaryDedges -> BoundaryDedges +deleteEdges = flip (foldl' (flip Set.delete)) --flip (\\) -- | given 2 consecutive directed edges (not necessarily in the right order), -- this returns the common vertex (as a singleton list). @@ -782,12 +787,12 @@ Just bdC -> return bdC Nothing -> failReport "tryUpdate: crossing boundary (touching vertices).\n" --- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateVertices. +-- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateGraphVertices. -- (Used at intervals in tryRecalibratingForce and recalibratingForce). recalculateBVLocs :: BoundaryState -> BoundaryState recalculateBVLocs bd = bd {bvLocMap = newlocs} where - newlocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ faces bd - bvs = fst <$> boundary bd + newlocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices $ recoverGraph bd + bvs = VMap.keysSet $ bvLocMap bd -- IntSet.fromList $ fst <$> boundary bd -- |A version of tryForce that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch. -- This is needed to limit accumulated inaccuracies when large numbers of faces are added in forcing. @@ -941,7 +946,7 @@ -- |makeUpdate f x constructs a safe update if x is Just(..) and an unsafe update if x is Nothing makeUpdate:: (Vertex -> TileFace) -> Maybe Vertex -> Update -makeUpdate f (Just v) = fv `seq` SafeUpdate fv where fv = f v +makeUpdate f (Just !v) = SafeUpdate (f v) -- fv `seq` SafeUpdate fv where fv = f v makeUpdate f Nothing = UnsafeUpdate f @@ -1210,40 +1215,40 @@ -- add a symmetric (mirror) face for a given face at a boundary join edge. completeHalf :: UChecker completeHalf bd (LD(a,b,_)) = makeUpdate makeFace <$> x where - makeFace !v = makeRD a v b --RD (a,v,b) + makeFace v = makeRD a v b --RD (a,v,b) x = tryFindThirdV bd (b,a) (3,1) --anglesForJoinRD completeHalf bd (RD(a,_,b)) = makeUpdate makeFace <$> x where - makeFace !v = makeLD a b v --LD (a,b,v) + makeFace v = makeLD a b v --LD (a,b,v) x = tryFindThirdV bd (a,b) (1,3) --anglesForJoinLD completeHalf bd (LK(a,_,b)) = makeUpdate makeFace <$> x where - makeFace !v = makeRK a b v --RK (a,b,v) + makeFace v = makeRK a b v --RK (a,b,v) x = tryFindThirdV bd (a,b) (1,2) --anglesForJoinRK completeHalf bd (RK(a,b,_)) = makeUpdate makeFace <$> x where - makeFace !v = makeLK a v b --LK (a,v,b) + makeFace v = makeLK a v b --LK (a,v,b) x = tryFindThirdV bd (b,a) (2,1) --anglesForJoinLK -- |add a (missing) half kite on a (boundary) short edge of a dart or kite addKiteShortE :: UChecker addKiteShortE bd (RD(_,b,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeLK v c b --LK (v,c,b) + makeFace v = makeLK v c b --LK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK addKiteShortE bd (LD(_,b,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeRK v c b --RK (v,c,b) + makeFace v = makeRK v c b --RK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeRK v c b --RK (v,c,b) + makeFace v = makeRK v c b --RK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeLK v c b --LK (v,c,b) + makeFace v = makeLK v c b --LK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK -- |add a half dart top to a boundary short edge of a half kite. addDartShortE :: UChecker addDartShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeLD v c b --LD (v,c,b) + makeFace v = makeLD v c b --LD (v,c,b) x = tryFindThirdV bd (c,b) (3,1) --anglesForShortLD addDartShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeRD v c b --RD (v,c,b) + makeFace v = makeRD v c b --RD (v,c,b) x = tryFindThirdV bd (c,b) (1,3) --anglesForShortRD addDartShortE _ _ = error "addDartShortE applied to non-kite face\n" @@ -1256,31 +1261,31 @@ -- |add a kite to a long edge of a dart or kite addKiteLongE :: UChecker addKiteLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeRK c v a --RK (c,v,a) + makeFace v = makeRK c v a --RK (c,v,a) x = tryFindThirdV bd (a,c) (2,1) -- anglesForLongRK addKiteLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where - makeFace !v = makeLK b a v --LK (b,a,v) + makeFace v = makeLK b a v --LK (b,a,v) x = tryFindThirdV bd (b,a) (1,2) -- anglesForLongLK addKiteLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeLK a c v --LK (a,c,v) + makeFace v = makeLK a c v --LK (a,c,v) x = tryFindThirdV bd (a,c) (1,2) -- anglesForLongLK addKiteLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where - makeFace !v = makeRK a v b --RK (a,v,b) + makeFace v = makeRK a v b --RK (a,v,b) x = tryFindThirdV bd (b,a) (2,1) -- anglesForLongRK -- |add a half dart on a boundary long edge of a dart or kite addDartLongE :: UChecker addDartLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeRD a c v --RD (a,c,v) + makeFace v = makeRD a c v --RD (a,c,v) x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongRD addDartLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where - makeFace !v = makeLD a v b --LD (a,v,b) + makeFace v = makeLD a v b --LD (a,v,b) x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongLD addDartLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where - makeFace !v = makeRD b a v --RD (b,a,v) + makeFace v = makeRD b a v --RD (b,a,v) x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongRD addDartLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where - makeFace !v = makeLD c v a --LD (c,v,a) + makeFace v = makeLD c v a --LD (c,v,a) x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongLD {- @@ -1315,6 +1320,39 @@ defaultAllUGen :: UpdateGenerator defaultAllUGen = UpdateGenerator { applyUG = gen } where gen bd es = combine $ map decide es where -- Either String is a monoid as well as Map + combine = fmap mconcat . concatFails -- concatenates all failure reports if there are any + -- otherwise combines the update maps with mconcat + decide e = decider $ inspectBDedge bd e where + + decider (f,Join) = mapItem (completeHalf bd f) -- rule 1 + decider (f,Short) + | isDart f = mapItem (addKiteShortE bd f) -- rule 2 + | otherwise = kiteShortDecider f + decider (f,Long) + | isDart f = dartLongDecider f + | otherwise = kiteLongDecider f + + dartLongDecider f + | mustbeStar bd (originV f) = mapItem (completeSunStar bd f) + | mustbeKing bd (originV f) = mapItem (addDartLongE bd f) + | mustbeJack bd (wingV f) = mapItem (addKiteLongE bd f) + | otherwise = Right Map.empty + + kiteLongDecider f + | mustbeSun bd (originV f) = mapItem (completeSunStar bd f) + | mustbeQueen bd (wingV f) = mapItem (addDartLongE bd f) + | otherwise = Right Map.empty + + kiteShortDecider f + | mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem (addDartShortE bd f) + | mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem (addKiteShortE bd f) + | otherwise = Right Map.empty + + mapItem = fmap (\u -> Map.insert e u Map.empty) + +{- defaultAllUGen :: UpdateGenerator +defaultAllUGen = UpdateGenerator { applyUG = gen } where + gen bd es = combine $ map decide es where -- Either String is a monoid as well as Map decide e = decider (e,f,etype) where (f,etype) = inspectBDedge bd e decider (e,f,Join) = mapItem e (completeHalf bd f) -- rule 1 @@ -1344,7 +1382,7 @@ mapItem e = fmap (\u -> Map.insert e u Map.empty) combine = fmap mconcat . concatFails -- concatenates all failure reports if there are any -- otherwise combines the update maps with mconcat - + -} -- |Given a BoundaryState and a directed boundary edge, this returns the same edge with -- the unique face on that edge and the edge type for that face and edge (Short/Long/Join) @@ -1384,8 +1422,11 @@ (The check is done in tryUnsafeUpdate.) -} -{-|tryFindThirdV finds a neighbouring third vertex on the boundary if there is one in the correct direction for a face added to - the right hand side of a directed boundary edge. +{-|tryFindThirdV tries to find a neighbouring third vertex on the boundary either side of the dedge + (for a new face to be added). + It can return a Left failreport if it discovers an incorrect Tgraph. + Otherwise it returns a Right Nothing or Right (Just v) depending on whether it found an existing + suitable vertex. In tryFindThirdV bd (a,b) (n,m), the two integer arguments n and m are the INTERNAL angles for the new face on the boundary directed edge (a,b) (for a and b respectively) expressed as multiples of tt (tt being a tenth turn) @@ -1410,11 +1451,11 @@ ,"\nwith faces at " ,show a ,":\n" - ,show (bvFacesMap bd VMap.! a) + ,show (facesAtBV bd a) ,"\nand faces at " ,show b ,":\n" - ,show (bvFacesMap bd VMap.! b), + ,show (facesAtBV bd b), "\nand a total of " ,show (length $ faces bd) ," faces.\n" @@ -1430,13 +1471,13 @@ ,"\nwith faces at " ,show a ,":\n" - ,show (bvFacesMap bd VMap.! a) + ,show (facesAtBV bd a) ,"\nand faces at " ,show b ,":\n" - ,show (bvFacesMap bd VMap.! b) + ,show (facesAtBV bd b) ,"\nand a total of " - ,show (length $ faces bd) + ,show (faceCount bd) ," faces.\n" ] | aAngle < n @@ -1451,20 +1492,8 @@ ,show (a,b) ,"\n" ] - | aAngle == n = case find ((==a) . snd) (boundary bd) of - Just pr -> Right $ Just (fst pr) - Nothing -> failReports - ["tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " - ,show (a,b) - ,"\n" - ] - | bAngle == m = case find ((==b) . fst) (boundary bd) of - Just pr -> Right $ Just (snd pr) - Nothing -> failReports - ["tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " - ,show (a,b) - ,"\n" - ] + | aAngle == n = Right $ Just $ fst $ preceding a bd + | bAngle == m = Right $ Just $ snd $ following b bd | otherwise = Right Nothing -- |externalAngle bd v - calculates the external angle at boundary vertex v in BoundaryState bd as an @@ -1495,5 +1524,6 @@ -- |touchCheck p vpMap - check if a vertex location p touches (is too close to) any other vertex location in the mapping vpMap touchCheck:: Point V2 Double -> VertexMap (Point V2 Double) -> Bool -touchCheck p vpMap = any (touching p) (VMap.elems vpMap) - +touchCheck p vpMap = not $ VMap.null $ VMap.filter (touching p) vpMap + -- filtering the map has better performance than checking a list + -- touchCheck p vpMap = any (touching p) (VMap.elems vpMap) diff --git a/src/Tgraph/Prelude.hs b/src/Tgraph/Prelude.hs --- a/src/Tgraph/Prelude.hs +++ b/src/Tgraph/Prelude.hs @@ -8,9 +8,9 @@ Introduces Tgraphs and includes operations on vertices, edges and faces as well as Tgraphs. Plus VPatch (Vertex Patch) as intermediary between Tgraph and Diagram. -Conversion and drawing operations to produce Diagrams. -The module also includes functions to calculate (relative) locations of vertices (locateVertices, addVPoint), -touching vertex checks (touchingVertices, touchingVerticesGen), and edge drawing functions. +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. -} @@ -18,29 +18,27 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} - -{-# LANGUAGE StrictData #-} - +{-# LANGUAGE Strict #-} +-- DISCOVERED changing StrictData to Strict generates a bug in test case (connected x2) module Tgraph.Prelude ( module HalfTile , module Try - -- * Types for Tgraphs, Faces, Vertices, Directed Edges - , TileFace - , Vertex - , VertexSet - , VertexMap - -- $Edges - , Dedge - , EdgeType(..) + -- * Making Tgraphs , Tgraph() -- not Data Constructor Tgraph - -- * Making Tgraphs + , TileFace , makeTgraph , tryMakeTgraph , checkedTgraph , makeUncheckedTgraph , emptyTgraph - -- * Property Checks +-- * Vertices and Edges + , Vertex + , VertexSet + , VertexMap + , Dedge + -- $Edges + , EdgeType(..) +-- * Tgraph Property Checks -- , renumberFaces -- , differing , tryTgraphProps @@ -49,6 +47,7 @@ -- , findEdgeLoops , hasEdgeLoops , duplicates +-- , duplicateInts -- , conflictingDedges , edgeType --, findEdgeLoop @@ -64,17 +63,30 @@ , crossingBoundaries , connected -- , connectedBy - -- * Tgraph and HasFaces operations - , HasFaces(..) -- faces, boundary, maxV, boundaryVFMap + -- * HasFaces operations + , HasFaces(..) -- faces, boundaryESet, maxV, boundaryVFMap + , boundaryEdgeSet + , boundary +-- , maxV + , dedgeSet , dedges + , evalDedge + , evalDedges , vertexSet , vertices - , boundaryVs + , boundaryVSet + , boundaryVertexSet + , boundaryVsDup , boundaryEFMap , boundaryVFaces + , boundaryEFaces + , boundaryEdgeFaces + , boundaryJoinFaces + --, boundaryVFMap -- , faces , nullFaces , evalFaces + , faceCount , ldarts , rdarts , lkites @@ -89,10 +101,10 @@ , removeFaces , removeVertices , selectVertices + , vertexFMap , vertexFacesMap + , dedgeFMap , dedgesFacesMap - , boundaryJoinFaces - , boundaryEdgeFaces , buildEFMap , extractLowestJoin , lowestJoin @@ -137,21 +149,18 @@ , bothDir -- , bothDirOneWay , missingRevs + , missingRevSet -- * VPatch and Conversions , VPatch(..) , VertexLocMap , makeVP , subFaces - , subVP --deprecated , relevantVP , restrictTo - , restrictVP --deprecated , graphFromVP , removeFacesFromVP , removeVerticesFromVP , selectVerticesFromVP - , removeFacesVP --deprecated - , selectFacesVP --deprecated , findLoc -- * Drawing Tgraphs and Vpatches with Labels , DrawableLabelled(..) @@ -172,7 +181,8 @@ , drawLocatedEdges , drawLocatedEdge -- * Vertex Location and Touching Vertices - , locateVertices + , locateGraphVertices + -- , locateVertices , addVPoint -- , axisJoin -- , find3Locs @@ -180,20 +190,23 @@ , touchingVertices , touching , touchingVerticesGen - , locateVerticesGen +-- , locateVerticesGen --, drawEdges --, drawEdge ) where -import Data.List ((\\),intersect,union,elemIndex,find,nub) +import Data.List ((\\),intersect,find,nub) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..)) -import qualified Data.IntMap.Strict as VMap (IntMap, alter, lookup, fromList, fromListWith, (!), map, filterWithKey,insert, empty, toList, assocs, keys, keysSet, findWithDefault,elems) -import qualified Data.IntSet as IntSet (IntSet,union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteMin,findMin,findMax,member,difference,elems) -import qualified Data.Map.Strict as Map (Map, fromList, lookup, fromListWith, elems, filterWithKey) +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 qualified Data.Set as Set (fromList,member,null,delete,)-- used for locateVertices - +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) @@ -213,12 +226,13 @@ -- Types for Tgraphs, Vertices, Directed Edges, Faces --- |Vertex labels are integers. They must be positive for a Tgraph (Checked by makeTgraph). +-- |Vertices are (positive) integers. They are checked for being positive +-- in Tgraphs. type Vertex = Int -- | directed edge type Dedge = (Vertex,Vertex) --- | Vertex label sets -type VertexSet = IntSet.IntSet +-- | 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. @@ -228,22 +242,20 @@ {- | 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). + 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. + Use @faces@ to retrieve the list of faces of a Tgraph. -} -newtype Tgraph = Tgraph { -- | getFaces is not exported (use faces) - getFaces ::[TileFace] -- ^ Retrieve the 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) --- |Abbreviation for Mapping from Vertex keys (also used for Boundaries) -type VertexMap a = VMap.IntMap a +-- |Mappings with vertex keys. +type VertexMap = IntMap {- @@ -270,7 +282,7 @@ tryMakeTgraph :: [TileFace] -> Try Tgraph tryMakeTgraph fcs = do g <- tryTgraphProps fcs -- must be checked first - let touchVs = touchingVertices (faces g) + let touchVs = touchingVertices g if null touchVs then Right g else failReport ("Found touching vertices: " @@ -293,8 +305,8 @@ -- renumberFaces allows for a many to 1 relabelling represented by a list where touchVs = touchingVertices fcs -- uses non-generalised version of touchingVertices --- |renumberFaces 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 - 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 @@ -303,19 +315,28 @@ 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. --- --- WARNING: This is intended for use only when checks are known to be redundant. --- Consider using makeTgraph, tryMakeTgraph or checkedTgraph instead to perform checks. makeUncheckedTgraph:: [TileFace] -> Tgraph makeUncheckedTgraph = Tgraph --- |force full evaluation of a list of faces. +-- |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 + +-- |fully evaluate a list of tilefaces. evalFaces :: HasFaces a => a -> a -evalFaces !a = b where - !b = find (ev . faceVs) (faces a) `seq` a - ev (x,y,z) = x `seq` y `seq` z `seq` False +evalFaces a = foldr (seq . evalFace) () (faces a) `seq` a + {-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties @@ -399,13 +420,25 @@ hasEdgeLoops:: HasFaces a => a -> Bool hasEdgeLoops = not . null . findEdgeLoops --- |duplicates finds any duplicated items in a list (unique results). +{- -- |duplicates finds any duplicated items in a list (unique results). duplicates :: Eq a => [a] -> [a] -duplicates = reverse . fst . foldl' check ([],[]) where - check (dups,seen) x | x `elem` dups = (dups,seen) - | x `elem` seen = (x:dups,seen) - | otherwise = (dups,x:seen) +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) @@ -471,7 +504,7 @@ legal (RK _, Long, LD _ , Long ) = True legal _ = False --- | Returns a list of illegal face parings of the form (f1,e1,f2,e2) where f1 and f2 share an edge +-- | 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)] @@ -485,8 +518,19 @@ -- |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 . boundaryVs +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 @@ -513,12 +557,15 @@ | IntSet.null unvisited = (IntSet.toList visited ++ IntSet.toList done,[]) | IntSet.null visited = (IntSet.toList done, IntSet.toList unvisited) -- any unvisited are not connected | otherwise = - search (IntSet.insert x done) (IntSet.union newVs visited') (unvisited IntSet.\\ newVs) - where x = IntSet.findMin visited + 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 @@ -531,42 +578,73 @@ -- |Class HasFaces for operations using (a list of) TileFaces. -- --- Used to define common functions on [TileFace], Tgraph, VPatch, BoundaryState, Forced, TrackedTgraph +-- 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 + -- |get the tileFace list faces :: a -> [TileFace] - -- |get the directed edges of the boundary - -- (direction with a tileface on the left and exterior on right). - boundary :: a -> [Dedge] - -- |get the maximum vertex in all faces (0 if there are no faces) + -- |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 --- |List of boundary vertices --- May have duplicates when applied to an arbitrary list of TileFace or VPatch. --- but no duplicates for Tgraph, BoundaryState, Forced, TrackedTgraph. -boundaryVs :: HasFaces a => a -> [Vertex] -boundaryVs = map fst . boundary +-- |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 --- |get the set of vertices in the faces -vertexSet :: HasFaces a => a -> VertexSet -vertexSet = mconcat . map faceVSet . 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.Map Dedge TileFace +boundaryEFMap :: HasFaces a => a -> Map Dedge TileFace boundaryEFMap fcs = Map.fromList (assocFaces des) where des = map reverseD $ boundary fcs --- vs = boundaryVs a vfMap = boundaryVFMap fcs assocFaces [] = [] assocFaces (d@(a,b):more) = @@ -580,33 +658,39 @@ 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 - boundary = missingRevs . dedges - maxV [] = 0 - maxV fcs = IntSet.findMax $ vertexSet fcs - boundaryVFMap fcs = vertexFacesMap (nub $ boundaryVs fcs) fcs -- need for nub -- |Tgraph is in class HasFaces instance HasFaces Tgraph where - faces = getFaces - boundary = boundary . faces - maxV = maxV . faces - boundaryVFMap g = vertexFacesMap (boundaryVs g) (faces g) -- no need for nub + 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] --- | selecting left darts from +-- | select all left darts from the faces ldarts = filter isLD . faces --- | selecting right darts from the faces +-- | select all right darts from the faces rdarts = filter isRD . faces --- | selecting left kites from the faces +-- | select all left kites from the faces lkites = filter isLK . faces --- | selecting right kites from the faces +-- | select all right kites from the faces rkites = filter isRK . faces --- | selecting half kites from the faces +-- | select all half kites from the faces kites = filter isKite . faces --- | selecting half darts from the faces +-- | select all half darts from the faces darts = filter isDart . faces -- |selects faces from a Tgraph (removing any not in the list), @@ -667,36 +751,24 @@ makeLK !x !y !z = LK (x,y,z) -- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace -{-# Inline faceVs #-} faceVs::TileFace -> (Vertex,Vertex,Vertex) faceVs = tileRep -{- faceVs f = let tr = tileRep f - (x,y,z) = tr - in x `seq` y `seq` z `seq` tr - -} -- |list of (three) face vertices in order clockwise starting with origin faceVList::TileFace -> [Vertex] -faceVList = (\(x,y,z) -> [x,y,z]) . faceVs - +-- 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 = IntSet.fromList . faceVList +faceVSet f = IntSet.insert a $ IntSet.insert b $ IntSet.insert c IntSet.empty + where (a,b,c) = faceVs f -{- -- |find the maximum vertex for a list of faces (0 for an empty list). -facesMaxV :: [TileFace] -> Vertex -facesMaxV [] = 0 -facesMaxV fcs = IntSet.findMax $ vertexSet fcs - -} --- Whilst first, second and third vertex of a face are obvious (clockwise), --- it is often more convenient to refer to the originV (=firstV), --- oppV (the vertex at the other end of the join edge), and --- wingV (the remaining vertex not on the join edge) -- |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 +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) @@ -714,10 +786,16 @@ -- |indexV finds the index of a vertex in a face (firstV -> 0, secondV -> 1, thirdV -> 2) indexV :: Vertex -> TileFace -> Int -indexV v face = case elemIndex v (faceVList face) of +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 @@ -738,7 +816,7 @@ -- |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 + 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 @@ -752,30 +830,32 @@ {- $Edges -Representing Edges: + __Representing Edges__ -For vertices a and b, (a,b) is regarded as a directed edge from a to b (a Dedge). +For vertices a and b, a directed edge from a to b (a @Dedge@) is represented simply as the pair (a,b) . -A list of such pairs will usually be regarded as a list of directed edges. -In the special case that the list is symmetrically closed [(b,a) is in the list whenever (a,b) is in the list] -we will refer to this as an edge list rather than a directed edge list. +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 (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 -{- -- |Returns the list of all directed edges (clockwise round each) of a list of tile faces. -facesDedges :: [TileFace] -> [Dedge] -facesDedges = concatMap faceDedges - -} -- |opposite directed edge. reverseD:: Dedge -> Dedge -reverseD (a,b) = (b,a) +reverseD (!a,!b) = (b,a) {- -- |firstE, secondE and thirdE are the directed edges of a face counted clockwise from the origin, @@ -787,23 +867,23 @@ 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) +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) +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) +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) @@ -811,15 +891,24 @@ 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 face@(RD _) = [e, reverseD e] where e = longE face +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 face = bothDirOneWay (faceDedges face) \\ facePhiEdges face +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 @@ -839,11 +928,14 @@ -- |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 `elem` faceDedges f +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 es = not $ null $ filter (hasDedge face) es -- |completeEdges returns a list of all the edges of the faces (both directions of each edge). completeEdges :: HasFaces a => a -> [Dedge] @@ -855,101 +947,120 @@ bothDir:: [Dedge] -> [Dedge] bothDir es = missingRevs 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 des = revPlus des where - revPlus ((a,b):es) = (b,a):revPlus es - revPlus [] = des -{- bothDirOneWay [] = [] bothDirOneWay (e@(a,b):es)= e:(b,a):bothDirOneWay es -} --- | efficiently finds missing reverse directions from a list of directed edges (using IntMap) +-- | efficiently finds missing reverse directions from a list of directed edges +-- and returning a dedge list. (It uses missingRevSet) missingRevs:: [Dedge] -> [Dedge] -missingRevs es = revUnmatched es where - vmap = VMap.fromListWith (++) $ map singleton es - singleton (a,b) = (a,[b]) - seekR (a,b) = case VMap.lookup b vmap of - Nothing -> False - Just vs -> a `elem` vs +--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 - revUnmatched [] = [] - revUnmatched (e@(a,b):more) | seekR e = revUnmatched more - | otherwise = (b,a):revUnmatched more +-- | 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) - -{-|vertexFacesMap vs a - -For list of vertices vs and faces from a, -create an IntMap from each vertex in vs to a list of those faces in a that are at that vertex. +{-|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. -} -vertexFacesMap:: HasFaces a => [Vertex] -> a -> VertexMap [TileFace] -vertexFacesMap vs = foldl' insertf startVF . faces where - startVF = VMap.fromList $ map (,[]) vs +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 --- | dedgesFacesMap des a - Produces an edge-face map. Each directed edge in des is associated with +-- | 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. -dedgesFacesMap:: HasFaces a => [Dedge] -> a -> Map.Map Dedge TileFace -dedgesFacesMap des fcs = Map.fromList (assocFaces des) where - vs = map fst des `union` map snd des - vfMap = vertexFacesMap vs fcs +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 $ "dedgesFacesMap: more than one Tileface has the same directed edge: " + _ -> 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 - --- |find the faces with a at least one boundary edge. -boundaryEdgeFaces :: HasFaces a => a -> [TileFace] -boundaryEdgeFaces = nub . Map.elems . boundaryEFMap +-- |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) -buildEFMap:: HasFaces a => a -> Map.Map Dedge TileFace +-- 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.Map Dedge TileFace -> Maybe TileFace +faceForEdge :: Dedge -> Map Dedge TileFace -> Maybe TileFace faceForEdge = Map.lookup -- |Given a tileface (face) and a map from each directed edge to the tileface containing it (efMap) -- return the list of edge neighbours of face. -edgeNbs:: TileFace -> Map.Map Dedge TileFace -> [TileFace] +edgeNbs:: TileFace -> Map Dedge TileFace -> [TileFace] edgeNbs face efMap = mapMaybe getNbr edges where getNbr e = Map.lookup e efMap edges = reverseD <$> faceDedges face -- |For an argument with a non-empty list of faces, -- find the face with lowest originV (and then lowest oppV). --- Move this face to the front of the returned list of faces. +-- 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 locateVertices to determine the starting point for location calculation +-- (Used by locateGraphVertices to determine the starting point for location calculation.) extractLowestJoin:: HasFaces a => a -> (TileFace,[TileFace]) extractLowestJoin = getLJ . faces where getLJ fcs @@ -965,15 +1076,17 @@ -- |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 origin to the opp vertex, i.e (orig,opp). +-- 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 = lowest . faces where +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 @@ -981,7 +1094,7 @@ -----------------------} -- |Abbreviation for finite mappings from Vertex to Location (i.e Point) -type VertexLocMap = VMap.IntMap (Point V2 Double) +type VertexLocMap = VertexMap (Point V2 Double) -- |A VPatch has a map from vertices to points along with a list of tile faces. @@ -1001,17 +1114,16 @@ -- |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 - boundaryVFMap = boundaryVFMap . faces -- need for nub (from [TileFace] instance) - - + -} {-|Convert a Tgraph to a VPatch. -This uses locateVertices to form an intermediate VertexLocMap (mapping of vertices to positions). +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 = locateVertices fcs, vpFaces = fcs} where fcs = faces g +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. @@ -1022,12 +1134,6 @@ subFaces:: HasFaces a => a -> VPatch -> VPatch subFaces a vp = vp {vpFaces = faces a} -{-# DEPRECATED subVP "Use (flip subFaces)" #-} --- | DEPRECATED subVP: Use (flip subFaces) -subVP:: HasFaces a => VPatch -> a -> VPatch -subVP = flip subFaces - - -- | 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. @@ -1037,7 +1143,7 @@ | otherwise = error $ "relevantVP: missing locations for: " ++ show diffList ++ "\n" where - vs = vertexSet (faces vp) + vs = vertexSet vp source = VMap.keysSet locVs diffList = IntSet.toList $ IntSet.difference vs source locVs = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) $ vLocs vp @@ -1048,30 +1154,16 @@ -- (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 vp = relevantVP (subFaces (faces a) vp) - -{-# DEPRECATED restrictVP "Use (flip restrictTo)" #-} --- | DEPRECATED restrictVP: Use (flip restrictTo) -restrictVP:: VPatch -> [TileFace] -> VPatch -restrictVP = flip restrictTo +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 +-- |remove a list of faces from a VPatch (ignoring faces not in the VPatch) removeFacesFromVP :: [TileFace] -> VPatch -> VPatch -removeFacesFromVP fcs vp = restrictTo (faces vp \\ fcs) vp - -{-# DEPRECATED removeFacesVP "Use (flip removeFacesFromVP)" #-} --- |remove a list of faces from a VPatch -removeFacesVP :: VPatch -> [TileFace] -> VPatch -removeFacesVP vp fcs = restrictTo (faces vp \\ fcs) vp - -{-# DEPRECATED selectFacesVP "Use (flip restrictTo)" #-} --- |DEPRECATED selectFacesVP: Use (flip restrictTo) -selectFacesVP:: VPatch -> [TileFace] -> VPatch -selectFacesVP vp fcs = restrictTo (fcs `intersect` faces vp) vp +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. @@ -1087,9 +1179,6 @@ 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) @@ -1117,7 +1206,6 @@ 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 @@ -1221,19 +1309,15 @@ (Just pa, Just pb) -> pa ~~ pb _ -> error $ "drawEdge: location not found for one or both vertices "++ show (a,b) ++ "\n" -{- {-# DEPRECATED drawEdge, drawEdges "Use drawLocatedEdge, drawLocatedEdges instead" #-} --- |deprecated (use drawLocatedEdges) -drawEdges :: OKBackend b => - VertexLocMap -> [Dedge] -> Diagram b -drawEdges = drawLocatedEdges - --- |deprecated (use drawLocatedEdge) -drawEdge :: OKBackend b => - VertexLocMap -> Dedge -> Diagram b -drawEdge = drawLocatedEdge - -} +{-| 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: processes a list of faces to associate points for each vertex using a default scale and orientation. +{-| locateVertices - not exported (used in touchingVertices) and 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. @@ -1279,7 +1363,7 @@ -- |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. (Used to initialise locateVertices) +-- 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 @@ -1362,7 +1446,8 @@ {-| -touchingVertices finds if any vertices are too close to each other using locateVertices. +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, and no repeated first numbers. @@ -1393,8 +1478,9 @@ {-| touchingVerticesGen generalises touchingVertices to allow for multiple faces sharing a directed edge. -This can arise when applied to the union of faces from 2 Tgraphs which might clash in places. -It is used in the calculation of commonFaces. +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 possible. -} touchingVerticesGen:: [TileFace] -> [(Vertex,Vertex)] touchingVerticesGen fcs = check vpAssoc where @@ -1427,12 +1513,12 @@ fcOther' = foldl' (flip Set.delete) fcOther nbs vpMap' = addVPoint f vpMap -- Generalises buildEFMap by allowing for multiple faces on a directed edge. --- buildEFMapGen:: [TileFace] -> Map.Map Dedge [TileFace] +-- buildEFMapGen:: [TileFace] -> Map Dedge [TileFace] buildEFMapGen = Map.fromListWith (++) . concatMap processFace processFace f = (,[f]) <$> faceDedges f -- Generalised edgeNbs allowing for multiple faces on a directed edge. --- edgeNbsGen:: Map.Map Dedge [TileFace] -> TileFace -> [TileFace] +-- edgeNbsGen:: Map Dedge [TileFace] -> TileFace -> [TileFace] edgeNbsGen f = concat $ mapMaybe getNbrs edges where getNbrs e = Map.lookup e efMapGen edges = map reverseD (faceDedges f) diff --git a/src/Tgraph/Relabelling.hs b/src/Tgraph/Relabelling.hs --- a/src/Tgraph/Relabelling.hs +++ b/src/Tgraph/Relabelling.hs @@ -12,22 +12,16 @@ and a guided equality check (sameGraph). -} -{-# LANGUAGE Strict #-} +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Tgraph.Relabelling - ( -- * Assisted Union (and matching) operations + ( -- * Guided operations fullUnion , tryFullUnion - -- * commonFaces (Assisted Intersection) and sameGraph (Assisted Equivalence) , commonFaces , sameGraph - -- * Creating Relabellings - , Relabelling(..) - , newRelabelling --- , relabellingFrom --- , relabellingTo --- , relabelUnion - -- * Relabellings and matching + -- * Tgraph Matching , relabelToMatch , tryRelabelToMatch -- , tryRelabelFromFaces @@ -35,14 +29,25 @@ , relabelToMatchIgnore -- , relabelFromFacesIgnore -- , growRelabelIgnore - -- * Using Relabellings + -- * Relabellings + , Relabelling() + , newRelabelling + , unsafeDom + -- , relabellingFrom + , uncheckedRelabelGraph , relabelGraph , checkRelabelGraph + -- $SafeRelabelling +-- , relabellingTo +-- , extendRelabelling +-- , relabellingFrom + , relabelFrom + , relabelAvoid + , relabelContig + -- * Auxiliary Functions , relabelFace , relabelV --- , relabelAvoid , prepareFixAvoid - , relabelContig -- * Renumbering (not necessarily 1-1) -- , tryMatchFace -- , twoVMatch @@ -52,8 +57,8 @@ import Data.List (intersect, (\\), union,find,partition,nub) -import qualified Data.IntMap.Strict as VMap (IntMap, findWithDefault, fromList, fromAscList, union) -import qualified Data.IntSet as IntSet (fromList,intersection,findMax,elems,(\\),null,member) +import qualified Data.IntMap.Strict as VMap (findWithDefault, fromList, fromDistinctAscList, elems, keysSet, union) +import qualified Data.IntSet as IntSet (fromList,intersection,findMax,elems,(\\),null,member,disjoint,delete) import Tgraph.Prelude @@ -90,23 +95,21 @@ then return $ makeUncheckedTgraph fcs -- no properties check needed! else let vertg1 = vertexSet g1 correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e - newrel = newRelabelling $ map correct touchVs + newrel = quickRelabelling $ map correct touchVs in tryTgraphProps $ nub $ map (relabelFace newrel) fcs - -- | commonFaces (g1,e1) (g2,e2) relabels g2 to match with g1 (where they match) -- and returns the common faces as a subset of faces of g1. -- i.e. with g1 vertex labelling. -- It requires a face in g1 with directed edge e1 to match a face in g2 with directed edge e2, -- (apart from the third vertex label) otherwise an error is raised. -- This uses vertex locations to correct touching vertices in multiply overlapping regions. --- >>>> touching vertices being 1-1 is sensitive to nearness check of touchingVerticesGen <<<<<<<<< commonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> [TileFace] commonFaces (g1,e1) (g2,e2) = faces g1 `intersect` relFaces where g3 = relabelToMatchIgnore (g1,e1) (g2,e2) fcs = faces g1 `union` faces g3 touchVs = touchingVerticesGen fcs -- requires generalised version of touchingVertices - relFaces = map (relabelFace $ newRelabelling $ map correct touchVs) (faces g3) + relFaces = map (relabelFace $ quickRelabelling $ map correct touchVs) (faces g3) vertg1 = vertexSet g1 correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e @@ -115,50 +118,75 @@ -- The relabelling is based on directed edge e2 in g2 matching e1 in g1 (where the direction is clockwise round a face) -- and uses tryRelabelToMatch. sameGraph :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Bool -sameGraph (g1,e1) (g2,e2) = length (faces g1) == length (faces g2) && +sameGraph (g1,e1) (g2,e2) = faceCount g1 == faceCount g2 && ifFail False tryResult where tryResult = do g <- tryRelabelToMatch (g1,e1) (g2,e2) return (vertexSet g == vertexSet g1) --- |Relabelling is a special case of mappings from vertices to vertices that are not the --- identity on a finite number of vertices. --- They are represented by keeping the non identity cases in a finite map. --- When applied, we assume the identity map for vertices not found in the representation domain --- (see relabelV). Relabellings must be 1-1 on their representation domain, --- and redundant identity mappings are removed in the representation. --- Vertices in the range of a relabelling must be >0. -newtype Relabelling = Relabelling (VMap.IntMap Vertex) +{-|Relabelling is a special case of mappings from vertices to vertices (positive integers) +that are not the identity on a finite number of vertices. +They are represented by keeping the non identity cases in a finite map. +When applied, we assume the identity map for vertices not found in the keys of the relabelling. +Relabellings must be 1-1 on their keys, +The keys and vertices in the range of a relabelling must be positive integers. + +Call the set of elements (range) of a relabelling that are not keys of the relabelling +the /unsafe domain/ of the relabelling. + +A relabelling is guaranteed to be 1-1 on any set (of positive integers) +that is disjoint from its unsafe domain. +-} +newtype Relabelling = Relabelling (VertexMap Vertex) + -- | newRelabelling prs - make a relabelling from a finite list of vertex pairs. -- The first item in each pair relabels to the second in the pair. --- The resulting relabelling excludes any identity mappings of vertices. --- An error is raised if second items of the pairs contain duplicated numbers or a number<1 -newRelabelling :: [(Vertex,Vertex)] -> Relabelling +-- The resulting relabelling map will exclude any identity mappings of vertices. +-- An error is raised if either the first items or the second items of the pairs contains duplicates +-- or a non-positive integer. +newRelabelling :: [(Vertex,Vertex)] -> Relabelling -- Export only. Not used internally newRelabelling prs - | wrong (map snd prs) = error $ "newRelabelling: Not 1-1 or Non-positive label in range " ++ show prs - | otherwise = Relabelling $ VMap.fromList $ differing prs - where wrong vs = any (<1) vs || not (null (duplicates vs)) + | wrong = error $ "newRelabelling: Not 1-1 or Non-positive label\nwith pairs: " ++ show prs + | otherwise = Relabelling $ VMap.fromList newprs + where newprs = differing prs + (keys,elems) = unzip newprs + wrong = any (<1) elems + || any (<1) keys + || not (null (duplicates elems)) + || not (null (duplicates keys)) --- | relabellingFrom n vs - make a relabelling from finite set of vertices vs. +-- |Not exported -- quick version of newRelabelling without checks on pairs +quickRelabelling :: [(Vertex,Vertex)] -> Relabelling +quickRelabelling = Relabelling . VMap.fromList . differing + +-- | relabellingFrom n vs - (not exported) make a relabelling from a finite set of vertices vs. -- Elements of vs are ordered and relabelled from n upwards (an error is raised if n<1). --- The resulting relabelling excludes any identity mappings of vertices. +-- The resulting relabelling map excludes any identity mappings of vertices. +-- The resulting relabelling will be 1-1 on vs. relabellingFrom :: Int -> VertexSet -> Relabelling relabellingFrom n vs | n<1 = error $ "relabellingFrom: Label not positive " ++ show n - | otherwise = Relabelling $ VMap.fromAscList $ differing $ zip (IntSet.elems vs) [n..] + | otherwise = Relabelling $ VMap.fromDistinctAscList $ differing $ zip (IntSet.elems vs) [n..] +-- | Returns the /unsafe domain/ of a relabelling. +-- The unsafe domain is the set of elements (range) of a relabelling that are not keys of the relabelling. +-- I.e. those vertex numbers to be avoided when applying a relabelling to guarantee the relabelling is 1-1. +unsafeDom :: Relabelling -> VertexSet +unsafeDom (Relabelling vmap) = + IntSet.fromList (VMap.elems vmap) IntSet.\\ VMap.keysSet vmap + + -- | f1 \`relabellingTo\` f2 - creates a relabelling so that -- if applied to face f1, the vertices will match with face f2 exactly. --- It does not check that the tile faces have the same form (LK,RK,LD,RD). +-- It does not check that the tile faces have the same constructor (LK,RK,LD,RD). relabellingTo :: TileFace -> TileFace -> Relabelling -f1 `relabellingTo` f2 = newRelabelling $ zip (faceVList f1) (faceVList f2) -- f1 relabels to f2 - --- | Combine relabellings (assumes disjoint representation domains and disjoint representation ranges but --- no check is made for these). -relabelUnion:: Relabelling -> Relabelling -> Relabelling -relabelUnion (Relabelling r1) (Relabelling r2) = Relabelling $ VMap.union r1 r2 +f1 `relabellingTo` f2 = quickRelabelling $ zip (faceVList f1) (faceVList f2) -- f1 relabels to f2 +-- | (not exported) extendRelabelling fc1 fc2 r - Extend r to also relabel face fc1 to fc2 +extendRelabelling :: TileFace -> TileFace -> Relabelling -> Relabelling +extendRelabelling fc1 fc2 (Relabelling r) = Relabelling $ VMap.union r extra + where Relabelling extra = fc1 `relabellingTo` fc2 {-|relabelToMatch (g1,e1) (g2,e2) produces a relabelled version of g2 that is consistent with g1 on a single tile-connected region of overlap. @@ -166,7 +194,7 @@ will be identified with e1 by the relabelling of g2. This produces an error if a mismatch is found anywhere in the overlap. -CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1. +CAVEAT: The relabelling may not produce a complete match if the overlap is not just a SINGLE tile-connected region in g1. If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1 will be tile-connected but may have touching vertices. This limitation is addressed by fullUnion. @@ -179,7 +207,7 @@ The overlapping region must contain the directed edge e1 in g1. The edge e2 in g2 will be identified with e1 by the relabelling of g2. -CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1. +CAVEAT: The relabelling may not produce a complete match if the overlap is not just a SINGLE tile-connected region in g1. If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1 will be tile-connected but may have touching vertices. This limitation is addressed by tryFullUnion. @@ -189,7 +217,7 @@ do let g2prepared = prepareFixAvoid [x2,y2] (vertexSet g1) g2 fc2 <- find (`hasDedge` (x2,y2)) (faces g2prepared) `nothingFail` ("No face found for edge " ++ show (x2,y2)) - maybef <- tryMatchFace (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1 + maybef <- tryMatchFace (relabelFace (quickRelabelling [(x2,x1),(y2,y1)]) fc2) g1 fc1 <- maybef `nothingFail` ("No matching face found at edge "++show (x1,y1)++ "\nfor relabelled face " ++ show fc2) @@ -211,7 +239,7 @@ tryRelabelFromFaces :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Try Tgraph tryRelabelFromFaces (g1,fc1) (g2,fc2) = onFail "tryRelabelFromFaces:\n" $ do rlab <- tryGrowRelabel g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1) - return $ relabelGraph rlab g2 + return $ uncheckedRelabelGraph rlab g2 {-|tryGrowRelabel is used by tryRelabelFromFaces to build a relabelling map which can fail, producing Left lines. In the successful case it produces a Right rlab @@ -221,7 +249,7 @@ processing is a list of faces to be matched next (each has an edge in common with at least one previously matched face or it is the starting face); awaiting is a list of faces that have not yet been tried for a match and are not -tile-connected to any faces already matched. +tile-connected to any faces already matched; rlab is the relabelling so far. The idea is that from a single matched starting face we process faces that share an edge with a @@ -237,14 +265,14 @@ tryGrowRelabel:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling tryGrowRelabel _ [] _ rlab = Right rlab -- awaiting are not tile-connected to overlap region tryGrowRelabel g (fc:fcs) awaiting rlab = - do maybef <- tryMatchFace (relabelFace rlab fc) g + do maybef <- tryMatchFace (relabelFace rlab fc) g + -- note fc relabelled before trying to find its match in g case maybef of Nothing -> tryGrowRelabel g fcs awaiting rlab Just orig -> tryGrowRelabel g (fcs++fcs') awaiting' rlab' where (fcs', awaiting') = partition (edgeNb fc) awaiting - rlab' = relabelUnion (fc `relabellingTo` orig) rlab - - + rlab' = extendRelabelling fc orig rlab + -- the extension of the relabelling has 1 or 0 new relabelled vertices -- |same as relabelToMatch but ignores non-matching faces (except for the initial 2) -- The initial 2 faces are those on the given edges, and an error is raised if they do not match. @@ -255,11 +283,10 @@ fc2 = case find (`hasDedge` (x2,y2)) (faces g2prepared) of Nothing -> error $ "No face found for edge " ++ show (x2,y2) Just f -> f - fc1 = case matchFaceIgnore (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1 of + fc1 = case matchFaceIgnore (relabelFace (quickRelabelling [(x2,x1),(y2,y1)]) fc2) g1 of Nothing -> error $ "No matching face found at edge "++show (x1,y1)++ "\nfor relabelled face " ++ show fc2 Just f -> f - {-| relabelFromFacesIgnore is an auxiliary function for relabelToMatchIgnore. It is similar to tryRelabelFromFaces except that it uses growRelabelIgnore and matchFaceIgnore @@ -274,7 +301,7 @@ to match with g1. -} relabelFromFacesIgnore :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Tgraph -relabelFromFacesIgnore (g1,fc1) (g2,fc2) = relabelGraph rlab g2 where +relabelFromFacesIgnore (g1,fc1) (g2,fc2) = uncheckedRelabelGraph rlab g2 where rlab = growRelabelIgnore g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1) -- |growRelabelIgnore is similar to tryGrowRelabel except that it uses matchFaceIgnore (instead of tryMatchFace) @@ -286,37 +313,99 @@ Nothing -> growRelabelIgnore g fcs awaiting rlab Just orig -> growRelabelIgnore g (fcs++fcs') awaiting' rlab' where (fcs', awaiting') = partition (edgeNb fc) awaiting - rlab' = relabelUnion (fc `relabellingTo` orig) rlab + rlab' = extendRelabelling fc orig rlab + -- relabelUnion (fc `relabellingTo` orig) rlab +{-# WARNING uncheckedRelabelGraph + ["This should only be used when it is known that " + ,"the Relabelling remains 1-1 on vertices in the Tgraph. " + ,"Use relabelGraph for a checking version." + ] +#-} +-- |uncheckedRelabelGraph rlab g - uses a relabelling rlab to change vertices in a Tgraph g. +-- (See Safe Relabelling). +uncheckedRelabelGraph:: Relabelling -> Tgraph -> Tgraph +uncheckedRelabelGraph rlab g = makeUncheckedTgraph newFaces where + newFaces = map (relabelFace rlab) (faces g) --- |relabelGraph rlab g - uses a Relabelling rlab to change vertices in a Tgraph g. --- Caveat: This should only be used when it is known that: --- rlab is 1-1 on its (representation) domain, and --- the vertices of g are disjoint from those vertices that are in the representation range --- but which are not in the representation domain of rlab. --- This ensures rlab (extended with the identity) remains 1-1 on vertices in g, --- so that the resulting Tgraph does not need an expensive check for Tgraph properties. --- (See also checkRelabelGraph) +-- |relabelGraph uses a relabelling map to change vertices in a Tgraph, +-- It checks for vertices in the Tgraph +-- that are also in the unsafe domain of the relabelling. If this is the case +-- it also checks that the result is a valid Tgraph and will raise an error if not. +-- Otherwise it uses uncheckedRelabelGraph. relabelGraph:: Relabelling -> Tgraph -> Tgraph -relabelGraph rlab g = makeUncheckedTgraph newFaces where - newFaces = map (relabelFace rlab) (faces g) +relabelGraph rlab g = + if unsafeDom rlab `IntSet.disjoint` vertexSet g + then makeUncheckedTgraph newFaces + else runTry $ onFail "relabelGraph:\nRelabelling not 1-1\n" $ + tryMakeTgraph newFaces + where newFaces = map (relabelFace rlab) (faces g) --- |checkRelabelGraph uses a relabelling map to change vertices in a Tgraph, --- then checks that the result is a valid Tgraph. (see also relabelGraph) -checkRelabelGraph:: Relabelling -> Tgraph -> Tgraph -checkRelabelGraph rlab g = checkedTgraph newFaces where - newFaces = map (relabelFace rlab) (faces g) +{-# DEPRECATED checkRelabelGraph "Use relabelGraph" #-} +-- |renamed as relabelGraph +checkRelabelGraph :: Relabelling -> Tgraph -> Tgraph +checkRelabelGraph = relabelGraph +{- $SafeRelabelling + +__Safe Relabelling__ + +A Tgraph should only be relabelled with a 1-1 mapping to ensure the result is a valid Tgraph. +Any relabelling has an /unsafe/ domain and it is guaranteed to be 1-1 +if it is not applied to anything in the unsafe domain. +(However this is not an if and only if.) +-} + + + +{- Relabelling Examples +Consider + + @kiteGraph = Tgraph [RK (1,2,4),LK (1,3,2)]@ + +which has vertices {1,2,3,4}, and the two relabellings + + @rel1 = newRelabelling [(1,2),(2,4),(3,5)]@ + + @rel2 = newRelabelling [(1,2),(2,5),(5,4)]@ + +which are unsafe on {4,5} and {4} respectively. + +Example (incorrect) + + @uncheckedRelabelGraph rel1 kiteGraph@ + +produces a non valid @Tgraph [RK (2,4,4),LK (2,5,4)]@. +The relabelling is unsafe on {4,5} and 4 occurs in the kiteGraph. +In this case the relabelling is not 1-1 on kiteGraph. If +we check with + + @relabelGraph rel1 kiteGraph@ + +the non valid Tgraph is detected. + +Example (correct) + + @relabelGraph rel2 kiteGraph@ + +produces a (checked) valid @Tgraph [RK (2,5,4),LK (2,3,5)]@. +The relabelling is unsafe on 4 which occurs in kiteGraph, +so a full check of the resulting faces is performed. +This is an example of a relabelling which, although unsafe on the domain {1,2,3,4}, is nevertheless still 1-1 +on that domain. +-} + -- |Uses a relabelling to relabel the three vertices of a face. --- Any vertex not in the domain of the mapping is left unchanged. +-- Any vertex not in the key set of the relabelling is left unchanged. -- The mapping should be 1-1 on the 3 vertices to avoid creating a self loop edge. +-- This will be the case if the 3 vertices are not in the unsafe domain of the relabelling. relabelFace:: Relabelling -> TileFace -> TileFace relabelFace rlab = fmap (all3 (relabelV rlab)) where -- fmap of HalfTile Functor all3 f (a,b,c) = (f a,f b,f c) --- |relabelV rlab v - uses relabelling rlab to find a replacement for v (leaves as v if none found). +-- |relabelV rlab v - uses relabelling rlab to find a replacement for v (returns v if none found). -- I.e relabelV turns a Relabelling into a total function using identity --- for undefined cases in the Relabelling representation. +-- for vertices not in the key set of the relabelling. relabelV:: Relabelling -> Vertex -> Vertex relabelV (Relabelling r) v = VMap.findWithDefault v v r @@ -324,17 +413,24 @@ -- Any vertex in g that is in the set avoid will be changed to a new vertex that is -- neither in g nor in the set avoid. Vertices in g that are not in avoid will remain the same. relabelAvoid :: VertexSet -> Tgraph -> Tgraph -relabelAvoid avoid g = relabelGraph rlab g where - gverts = vertexSet g - avoidMax = if IntSet.null avoid then 0 else IntSet.findMax avoid - vertsToChange = gverts `IntSet.intersection` avoid - rlab = relabellingFrom (1+ max (maxV g) avoidMax) vertsToChange +relabelAvoid avoid g = + case nullFaces g of + True -> g + _ -> uncheckedRelabelGraph rlab g + where + gverts = vertexSet g + gMax = IntSet.findMax gverts + avoidMax = if IntSet.null avoid then 0 else IntSet.findMax avoid + vertsToChange = gverts `IntSet.intersection` avoid + rlab = relabellingFrom (1+ max gMax avoidMax) vertsToChange -- assert: rlab is 1-1 on the vertices of g - -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does) + -- because the unsafe domain of rlab excludes all vertices of g + -- assert: the relabelling preserves Tgraph properties -- assert: the relabelled Tgraph does not have vertices in the set avoid - -{-|prepareFixAvoid fix avoid g - produces a new Tgraph from g by relabelling. +{-|prepareFixAvoid fix avoid g +Same as relabelAvoid avoid g except that the list of items fix is removed from the avoid set. + Any vertex in g that is in the set avoid but not in the list fix will be changed to a new vertex that is neither in g nor in the set (avoid with fix removed). All other vertices of g (including those in fix) will remain the same. @@ -345,29 +441,42 @@ Note: If any element of the list fix is not a vertex in g, it could end up in the relabelled Tgraph. -} prepareFixAvoid :: [Vertex] -> VertexSet -> Tgraph -> Tgraph -prepareFixAvoid fix avoid = relabelAvoid (avoid IntSet.\\ IntSet.fromList fix) - -- assert: the relabelled Tgraph satisfies Tgraph properties (if the argument Tgraph does) +prepareFixAvoid fix avoid = relabelAvoid $ foldl' (flip IntSet.delete) avoid fix --relabelAvoid (avoid IntSet.\\ IntSet.fromList fix) + -- assert: the relabelling preserves Tgraph properties -- assert: the relabelled Tgraph does not have vertices in the set (avoid\\fix) +-- |relabelFrom n g- relabels all vertices in g using new labels n..n+m (where m is the number of vertices). +-- Raises an error if n is not positive. +relabelFrom :: Int -> Tgraph -> Tgraph +relabelFrom n g = uncheckedRelabelGraph rlab g where + rlab = relabellingFrom n (vertexSet g) + -- assert: rlab is 1-1 on the vertices of g + -- (the unsafe domain of rlab is disjoint from the vertices of g) + -- assert: the relabelled Tgraph preserves the Tgraph properties + +{-# DEPRECATED relabelContig "Use (relabelFrom 1)" #-} -- |Relabel all vertices in a Tgraph using new labels 1..n (where n is the number of vertices). relabelContig :: Tgraph -> Tgraph -relabelContig g = relabelGraph rlab g where +relabelContig g = uncheckedRelabelGraph rlab g where rlab = relabellingFrom 1 (vertexSet g) -- assert: rlab is 1-1 on the vertices of g - -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does) + -- (the unsafe domain of rlab is disjoint from the vertices of g) + -- assert: the relabelled Tgraph preserves the Tgraph properties {-| -tryMatchFace f g - looks for a face in g that corresponds to f (sharing a directed edge), -If the corresponding face does not match properly (with twoVMatch) this stops the +tryMatchFace f g - looks for a face in g that corresponds to f (with a common directed edge), +If the corresponding face does not match constructor (LK,RK,LD,RD) this stops the matching process returning Left ... to indicate a failed match. Otherwise it returns either Right (Just f) where f is the matched face or Right Nothing if there is no corresponding face. +Note, a matched face must have either two or three of the correponding vertices the same. -} tryMatchFace:: TileFace -> Tgraph -> Try (Maybe TileFace) tryMatchFace face g = onFail "tryMatchFace:\n" $ case find (`hasDedgeIn` faceDedges face) (faces g) of Nothing -> Right Nothing - Just corresp -> if twoVMatch corresp face + -- Just corresp -> if twoVMatch corresp face (redundant test of 2 vertex match) + Just corresp -> if isMatched corresp face then Right $ Just corresp else failReports ["Found non matching faces " @@ -375,18 +484,12 @@ ,"\n" ] --- |twoVMatch f1 f2 is True if the two tilefaces are the same except --- for a single vertex label possibly not matching. -twoVMatch:: TileFace -> TileFace -> Bool -twoVMatch f1 f2 = isMatched f1 f2 && - if firstV f1 == firstV f2 - then secondV f1 == secondV f2 || thirdV f1 == thirdV f2 - else secondV f1 == secondV f2 && thirdV f1 == thirdV f2 - {-|A version of tryMatchFace that just ignores mismatches. -matchFaceIgnore f g - looks for a face in g that corresponds to f (sharing a directed edge), -If there is a corresponding face f' which matches label and corresponding directed edge then Just f' is returned -Otherwise Nothing is returned. (Thus ignoring a clash) +matchFaceIgnore f g - looks for a face in g that corresponds to f (with a common directed edge), +If there is a corresponding face f' which matches constructor (LK,RK,LD,RD) +then Just f' is returned +Otherwise Nothing is returned. (Thus ignoring a clash). +Note, a matched face must have either two or three of the correponding vertices the same. -} matchFaceIgnore:: TileFace -> Tgraph -> Maybe TileFace matchFaceIgnore face g = case tryMatchFace face g of diff --git a/src/TgraphExamples.hs b/src/TgraphExamples.hs --- a/src/TgraphExamples.hs +++ b/src/TgraphExamples.hs @@ -11,7 +11,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} - +{-# OPTIONS_GHC -Wno-deprecations #-} module TgraphExamples (-- * Some Layout tools @@ -96,8 +96,8 @@ import Diagrams.Prelude import PKD ---import Tgraph.Prelude as NoWarn (makeUncheckedTgraph) + import Data.List (intersect,find) -- for emplaceChoices @@ -440,7 +440,7 @@ = chooseUnknowns (map (remainingunks unks) newgs ++ more) where newgs = map recoverGraph $ atLeastOne $ fmap forgetF <$> tryDartAndKiteF (findDartLongForWing u bd) bd bd = makeBoundaryState g0 - remainingunks startunks g' = (startunks `intersect` boundaryVs g', g') + remainingunks startunks g' = (startunks `intersect` boundaryVsDup g', g') findDartLongForWing :: Vertex -> BoundaryState -> Dedge findDartLongForWing v bd diff --git a/src/TileLib.hs b/src/TileLib.hs --- a/src/TileLib.hs +++ b/src/TileLib.hs @@ -31,13 +31,11 @@ , phi , ttangle , drawnEdges - , pieceEdges , wholeTileEdges -- $OKBackend , drawPiece , drawjPiece , drawJPiece - , dashjPiece , joinDashing , dashjOnly , dashJOnly @@ -146,11 +144,6 @@ drawnEdges (RK v) = [v',v ^-^ v'] where v' = rotate (ttangle 9) v drawnEdges (LK v) = [v',v ^-^ v'] where v' = rotate (ttangle 1) v -{-# DEPRECATED pieceEdges "Replaced by drawnEdges" #-} --- |older name for drawnEdges -pieceEdges:: Piece -> [V2 Double] -pieceEdges = drawnEdges - -- |the 4 tile edges of a completed half-tile piece (used for colour fill). -- These are directed and ordered clockwise from the origin of the tile. wholeTileEdges:: Piece -> [V2 Double] @@ -180,12 +173,6 @@ Piece -> Diagram b drawJPiece = drawPiece <> dashJOnly -{-# DEPRECATED dashjPiece "Replaced by drawjPiece" #-} --- |renamed as drawjPiece -dashjPiece :: OKBackend b => - Piece -> Diagram b -dashjPiece = drawjPiece - -- |draw join edge only (as faint dashed line). -- J for plain dashed Join, j for faint dashed join dashjOnly :: OKBackend b => @@ -319,13 +306,6 @@ -- Works with AlphaColours as well as Colours. fillKD c1 c2 = fillDK c2 c1 -{- {-# DEPRECATED fillMaybeDK "Use fillDK which now works with AlphaColours such as transparent" #-} --- |fillMaybeDK *Deprecated* --- (Use fillDK which works with AlphaColours such as transparent as well as Colours). -fillMaybeDK :: (Drawable a, OKBackend b) => - Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram b -fillMaybeDK c1 c2 = drawWith (fillMaybePieceDK c1 c2) - -} -- |colourDKG (c1,c2,c3) p - fill in a drawable with colour c1 for darts, colour c2 for kites and -- colour c3 for grout (that is, the non-join edges). -- Note the order D K G. @@ -333,16 +313,6 @@ colourDKG :: (Drawable a, OKBackend b, Color c1, Color c2, Color c3) => (c1,c2,c3) -> a -> Diagram b colourDKG (c1,c2,c3) a = fillDK c1 c2 a # lineColor c3 - -{- {-# DEPRECATED colourMaybeDKG "Use colourDKG which now works with AlphaColours such as transparent" #-} --- |colourMaybeDKG *Deprecated* --- (Use colourDKG which works with AlphaColours such as transparent as well as Colours) -colourMaybeDKG:: (Drawable a, OKBackend b) => - (Maybe (Colour Double), Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram b -colourMaybeDKG (d,k,g) a = fillMaybeDK d k a # maybeGrout g where - maybeGrout (Just c) = lc c - maybeGrout Nothing = lw none - -} {-| Decomposing splits each located piece in a patch into a list of smaller located pieces to create a refined patch. diff --git a/src/TileLibP3.hs b/src/TileLibP3.hs --- a/src/TileLibP3.hs +++ b/src/TileLibP3.hs @@ -47,7 +47,6 @@ , drawP3 , drawjP3 , drawJP3 - , dashjP3 --deprecated , fillWN , fillNW -- * P3_DrawableLabelled Class @@ -271,12 +270,6 @@ drawJP3 :: (OKBackend b, P3_Drawable a) => a -> Diagram b drawJP3 = drawP3With drawJPieceP3 - -{-# DEPRECATED dashjP3 "Use drawjP3" #-} --- | DEPRECATED dashjP3: Use drawjP3 -dashjP3 :: (OKBackend b, P3_Drawable a) => - a -> Diagram b -dashjP3 = drawjP3 -- |The main draw and fill function for anything P3_Drawable. -- The first colour is used for wide rhombuses, and the second for narrow rhombuses. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -116,33 +116,33 @@ graphOpSpec = describe "Main Tgraph Operations Test" $ do context "Decomposition of Tgraphs" $ it "Number of faces of dartDs !!6 should be 466" $ - length(faces dD6) `shouldBe` 466 + faceCount dD6 `shouldBe` 466 context "Composing Tgraphs" $ it "Number of faces of maxCompForce (dartDs !!6) should be 6" $ - length (faces $ forgetF $ maxCompForce dD6) `shouldBe` 6 + faceCount (forgetF $ maxCompForce dD6) `shouldBe` 6 context "Forcing Tgraphs" $ it "Number of faces of force (dartDs !!6) should be 7546" $ - length(faces(force dD6)) `shouldBe` 7546 + faceCount(force dD6) `shouldBe` 7546 context "partCompose and Force" $ it "Number of remainder faces when part composing force (dartDs !!3) should be 58" $ - length (fst $ partCompose $ force $ dartDs !!3) `shouldBe` 58 + faceCount(fst $ partCompose $ force $ dartDs !!3) `shouldBe` 58 context "partComposeF and ForceF" $ it "Number of remainder faces when part composing forceF (dartDs !!3) should be 58" $ - length (fst $ partComposeF $ forceF $ dartDs !!3) `shouldBe` 58 + faceCount(fst $ partComposeF $ forceF $ dartDs !!3) `shouldBe` 58 context "partCompose of reduced Tgraph (extraBrokenDart)" $ it "Number of remainder/composed faces when part composing extraBrokenDart should be (5,18)" $ - (length $ fst res,length $ faces $ snd res) + (faceCount (fst res),faceCount (snd res)) `shouldBe` (5,18) where res = partCompose extraBrokenDart graphLabelCheck :: Spec graphLabelCheck = describe "Label critical examples check" $ do context "boundaryGapFDart4" $ it "Number of faces of boundaryGapFDart4 should be 180" $ - length(faces boundaryGapFDart4) `shouldBe` 180 + faceCount boundaryGapFDart4 `shouldBe` 180 context "boundaryGapFDart5" $ it "Number of faces of boundaryGapFDart5 should be 316" $ - length(faces boundaryGapFDart5) `shouldBe` 316 + faceCount boundaryGapFDart5 `shouldBe` 316 context "superForceFig" $ - it "Number of faces of superForceFig should be 349" $ - length (faces(addHalfDart (220,221) $ force $ decompositions fool !!3)) `shouldBe` 349 + it "Number of faces of superForceFig should be 398" $ + faceCount (superForce $ addHalfDart (220,221) $ force $ decompositions fool !!3) `shouldBe` 398