PenroseKiteDart 1.1.0 → 1.2
raw patch · 10 files changed
+497/−363 lines, 10 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Tgraph.Compose: composedFaces :: Tgraph -> [TileFace]
- Tgraph.Force: type UpdateGenerator = BoundaryState -> [Dedge] -> Try UpdateMap
+ Tgraph.Compose: getDartWingInfoForced :: Tgraph -> DartWingInfo
+ Tgraph.Force: UpdateGenerator :: (BoundaryState -> [Dedge] -> Try UpdateMap) -> UpdateGenerator
+ Tgraph.Force: [applyUG] :: UpdateGenerator -> BoundaryState -> [Dedge] -> Try UpdateMap
+ Tgraph.Force: combineUpdateGenerators :: [UpdateGenerator] -> UpdateGenerator
+ Tgraph.Force: newUpdateGenerator :: UChecker -> UFinder -> UpdateGenerator
+ Tgraph.Force: newtype UpdateGenerator
+ Tgraph.Prelude: evalFaces :: [TileFace] -> [TileFace]
Files
- CHANGELOG.md +18/−0
- PenroseKiteDart.cabal +1/−1
- benchmark/Bench.hs +24/−12
- src/HalfTile.hs +7/−4
- src/Tgraph/Compose.hs +80/−45
- src/Tgraph/Force.hs +198/−171
- src/Tgraph/Prelude.hs +85/−65
- src/TgraphExamples.hs +38/−18
- src/Tgraphs.hs +44/−45
- src/TileLib.hs +2/−2
CHANGELOG.md view
@@ -1,5 +1,23 @@ # Revision history for PenroseKiteDart +## version 1.2 -- 2024-12-1++Release candidate:+Introduced getDartInfoForced and improved performance of uncheckedPartCompose and uncheckedCompose+removed: composedFaces = snd . partComposeFaces (all in Tgraph.Compose)++Significant improvement on space usage (fixing leaks)+adding StrictData to modules Tgraph.HalfTile, Tgraph.Compose, Tgraph.Force.+makeUncheckedTgraph now strictly evaluates its argument list of faces.++Made UpdateGenerator a newtype in Tgraph.Force++## 1.1.1 -- 2024-11-15++Exposed combineUpdateGenerators in Tgraph.Force++Reordered lists of faces in some basic example Tgraphs+(to ensure tails of the list are also valid as Tgraphs) ## 1.1.0 -- 2024-09-28
PenroseKiteDart.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: PenroseKiteDart-version: 1.1.0+version: 1.2 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
benchmark/Bench.hs view
@@ -1,23 +1,38 @@ import Tgraphs import TgraphExamples+import Debug.Trace (traceMarkerIO)+import Control.Concurrent (threadDelay) -- import TileLib (draw) -- import Diagrams.Prelude main :: IO () main = - do putStrLn $ "Number of faces of a " ++ sn ++ " times decomposed King is " + do let wait = threadDelay 100000+ _ <- traceMarkerIO "starting decompositions" + wait+ let kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n+ putStrLn $ "Number of faces of a " ++ sn ++ " times decomposed King is " ++ show (length (faces 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" #-} force kD putStrLn $ "Number of faces of force (" ++ sn ++ " times decomposed King) is " ++ show (length (faces fkD))--{-- putStrLn $ "Width of figure for force (" ++ sn ++ " times decomposed King) is " - ++ show w--}-+ putStrLn $ "Max vertex of force (" ++ sn ++ " times decomposed King) is " + ++ show (maxV fkD)+ _ <- traceMarkerIO "finished force" + wait+ _ <- traceMarkerIO "starting (unchecked) composing" + let cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate uncheckedCompose fkD putStrLn $ "Number of faces of recomposed force (" ++ sn ++ " times decomposed King) is " ++ show (length (faces 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))@@ -25,10 +40,7 @@ where sn = show n- n = 4- kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n- fkD ={-# SCC "forcing" #-} force kD- cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate compose fkD+ n = 5 {- fig = draw fkD
src/HalfTile.hs view
@@ -9,8 +9,9 @@ -} {-# LANGUAGE TypeFamilies #-} -- needed for Transformable Instance {-# LANGUAGE FlexibleInstances #-} -- needed for Transformable Instance+{-# LANGUAGE StrictData #-} -module HalfTile +module HalfTile ( HalfTile(..) , tileRep , isLD@@ -23,8 +24,9 @@ , tileLabel , isMatched ) where- + import Diagrams.Prelude (V,N, Transformable(..)) -- needed to make HalfTile a Transformable when a is Transformable+import qualified Control.Monad (void) -- used for tileLabel {-| Representing Half Tile Pieces Polymorphicly.@@ -41,7 +43,8 @@ -- | 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)+ compare t1 t2 = compare (tileRep t1) (tileRep t2) -- |Make Halftile a Functor instance Functor HalfTile where@@ -88,7 +91,7 @@ type HalfTileLabel = HalfTile () -- |convert a half tile to its label (HalfTileLabel can be compared for equality) tileLabel :: HalfTile a -> HalfTileLabel-tileLabel = fmap $ const () -- functor HalfTile+tileLabel = Control.Monad.void -- functor HalfTile (replaces rep value with ()) -- | isMatched t1 t2 is True if t1 and t2 have the same HalfTileLabel -- (i.e. use the same constructor - both LD or both RD or both LK or both RK)
src/Tgraph/Compose.hs view
@@ -7,8 +7,10 @@ Stability : experimental This module includes the main composition operations compose, partCompose, tryPartCompose but also exposes -getDartWingInfo (and type DartWingInfo) and composedFaceGroups for debugging and experimenting.+getDartWingInfo, getDartWingInfoForced (and type DartWingInfo) and composedFaceGroups for debugging and experimenting. -}+{-# LANGUAGE StrictData #-} + module Tgraph.Compose ( compose , partCompose@@ -16,15 +18,18 @@ , uncheckedCompose , uncheckedPartCompose , partComposeFaces- , composedFaces+ -- , partComposeFacesWith+ -- , composedFaces , DartWingInfo(..) , getDartWingInfo+ , getDartWingInfoForced , composedFaceGroups ) where import Data.List ((\\), find, foldl',nub) import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!)) import Data.Maybe (mapMaybe)+import qualified Data.IntSet as IntSet (empty,insert,toList,member) import Tgraph.Prelude @@ -37,16 +42,19 @@ -- |The main compose function which simply drops the remainder faces from partCompose to return just -- the composed Tgraph. It will raise an error if the result is not a valid Tgraph -- (i.e. if it fails the connectedness, no crossing boundary check)+-- It does not assume the given Tgraph is forced and is inefficient on large Tgraphs compose:: Tgraph -> Tgraph compose = snd . partCompose --- |This does the same as compose but without checks for connectedness and no crossing boundaries in the result.--- It is intended for use on forced Tgraphs where we have a proof that the checks are not needed.+-- |This does the same as compose but more efficiently because it assumes the given Tgraph is forced.+-- It uses getDartWingInfoForced and it does not perform checks for connectedness and no crossing boundaries in the result.+-- This relies on a proof that the checks are not needed for forced Tgraphs.+-- (The result is a forced Tgraph.) uncheckedCompose:: Tgraph -> Tgraph uncheckedCompose = snd . uncheckedPartCompose -- |partCompose g produces a pair consisting of remainder faces (faces from g which will not compose) --- and a composed Tgraph.+-- and a composed Tgraph. It does not assume the given Tgraph is forced and can be inefficient on large Tgraphs. -- It checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails. partCompose:: Tgraph -> ([TileFace],Tgraph) partCompose g = runTry $ onFail "partCompose:\n" $ tryPartCompose g@@ -55,33 +63,42 @@ -- It checks the resulting new faces for connectedness and no crossing boundaries. -- If the check is OK it produces Right (remainder, g') where g' is the composed Tgraph and remainder is a list -- of faces from g which will not compose. If the check fails it produces Left s where s is a failure report.+-- It does not assume the given Tgraph is forced and is inefficient on large Tgraphs. tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) tryPartCompose g = do let (remainder,newFaces) = partComposeFaces g checked <- onFail "tryPartCompose:/n" $ tryConnectedNoCross newFaces return (remainder,checked) --- |uncheckedPartCompose g produces a pair of the remainder faces (faces from g which will not compose)--- and a Tgraph made from the composed faces without checking that the Tgraph is valid.--- I.e. it does NOT check the composition Tgraph for connectedness and no crossing boundaries.--- This is intended for use when we know the check is not needed (e.g. when g is forced).+-- |uncheckedPartCompose g - assumes g is forced. It produces a pair of the remainder faces (faces from g which will not compose)+-- and a Tgraph made from the composed faces without checking for connectedness and no crossing boundaries.+-- This relies on a proof that the result of composing a forced Tgraph does not require these checks. uncheckedPartCompose:: Tgraph -> ([TileFace],Tgraph) uncheckedPartCompose g = (remainder, makeUncheckedTgraph newfaces) where- (remainder,newfaces) = partComposeFaces g+ (remainder,newfaces) = partComposeFacesWith getDartWingInfoForced g --- |partComposeFaces produces a pair of the remainder faces (faces from the original which will not compose)+-- |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. partComposeFaces:: Tgraph -> ([TileFace],[TileFace])-partComposeFaces g = (remainder,newfaces) where- compositions = composedFaceGroups $ getDartWingInfo g+partComposeFaces = partComposeFacesWith getDartWingInfo++-- |partComposeFacesWith gtdwi g, +-- (where gtdwi gets dart wing info from g - either getDartWingInfo or getDartWingInfoForced)+-- produces a pair of the remainder faces (faces from the original which will not compose)+-- and the composed faces (which may or may not constitute faces of a valid Tgraph).+partComposeFacesWith:: (Tgraph -> DartWingInfo) -> Tgraph -> ([TileFace],[TileFace])+partComposeFacesWith getdwi g = (remainder,newfaces) where+ compositions = composedFaceGroups $ getdwi g newfaces = map fst compositions- groups = map snd compositions- remainder = faces g \\ concat groups+ remainder = faces g \\ concatMap snd compositions ++{- -- |composedFaces g produces the composed faces of g (which may or may not constitute faces of a valid Tgraph). composedFaces:: Tgraph -> [TileFace] composedFaces = snd . partComposeFaces-+ -} -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. -- It includes a faceMap from dart wings to faces at that vertex.@@ -93,79 +110,97 @@ } deriving Show -- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing,--- returning as DartWingInfo.+-- returning as DartWingInfo. It does not assume g is forced and is more expensive than getDartWingInfoForced getDartWingInfo:: Tgraph -> DartWingInfo-getDartWingInfo g = DartWingInfo {largeKiteCentres = allKcs, largeDartBases = allDbs, unknowns = allUnks, faceMap = dwFMap} where+getDartWingInfo = getDWIassumeF False++-- | getDartWingInfoForced g, classifies the dart wings in g and calculates a faceMap for each dart wing,+-- returning as DartWingInfo. It assume g is forced.+getDartWingInfoForced :: Tgraph -> DartWingInfo+getDartWingInfoForced = getDWIassumeF True++-- | getDWIassumeF 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.+getDWIassumeF:: Bool -> Tgraph -> DartWingInfo+getDWIassumeF isForced g = + DartWingInfo { largeKiteCentres = IntSet.toList allKcs+ , largeDartBases = IntSet.toList allDbs+ , unknowns = IntSet.toList allUnks+ , faceMap = dwFMap+ } where drts = darts g dwFMap = vertexFacesMap (nub $ fmap wingV drts) (faces g)- (allKcs,allDbs,allUnks) = foldl' processD ([],[],[]) drts + (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 tips--- gps is a mapping of dart wing tips to the group of faces found at that vertex+-- processD now uses a triple of IntSets rather than lists processD (kcs, dbs, unks) rd@(RD (orig, w, _)) = -- classify wing tip w- if w `elem` kcs || w `elem` dbs then (kcs, dbs, unks) else-- already classified+ 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 length fcs ==1 then (kcs, dbs, w:unks) else -- lone dart wing => unknown- if w `elem` fmap originV (filter isKite fcs) then (kcs,w:dbs,unks) else + if length fcs ==1 then (kcs, dbs, IntSet.insert w unks) else -- lone dart wing => unknown+ if w `elem` fmap originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else -- wing is a half kite origin => largeDartBases- if (w,orig) `elem` fmap longE (filter isLD fcs) then (w:kcs,dbs,unks) else + if (w,orig) `elem` fmap longE (filter isLD fcs) then (IntSet.insert w kcs,dbs,unks) else -- long edge rd shared with an ld => largeKiteCentres+ if isForced then (kcs, dbs, IntSet.insert w unks) else case findFarK rd fcs of- Nothing -> (kcs,dbs,w:unks) -- unknown if incomplete kite attached to short edge of rd+ 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 _) -> (w:kcs,dbs,unks) -- short edge rk shared with an lk => largeKiteCentres- Just (LD _) -> (kcs,w:dbs,unks) -- short edge rk shared with an ld => largeDartBases+ 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,w:unks) -- long edge of rk has nothing attached => unknown- Just (LD _) -> (w:kcs,dbs,unks) -- long edge rk shared with ld => largeKiteCentres+ 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 _) -> (w:kcs,dbs,unks)+ Just (RK _) -> (IntSet.insert w kcs,dbs,unks) -- short edge of this lk shared with another rk => largeKiteCentres- Just (RD _) -> (kcs,w:dbs,unks) + Just (RD _) -> (kcs,IntSet.insert w dbs,unks) -- short edge of this lk shared with rd => largeDartBases- _ -> (kcs,dbs,w:unks) + _ -> (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 `elem` kcs || w `elem` dbs then (kcs, dbs, unks) else -- already classified+ 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 length fcs ==1 then (kcs, dbs, w:unks) else -- lone dart wing => unknown- if w `elem` fmap originV (filter isKite fcs) then (kcs,w:dbs,unks) else+ if length fcs ==1 then (kcs, dbs, IntSet.insert w unks) else -- lone dart wing => unknown+ if w `elem` fmap originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else -- wing is a half kite origin => nodeDB- if (w,orig) `elem` fmap longE (filter isRD fcs) then (w:kcs,dbs,unks) else+ if (w,orig) `elem` fmap longE (filter isRD fcs) then (IntSet.insert w kcs,dbs,unks) else -- long edge ld shared with an rd => nodeKC+ if isForced then (kcs, dbs, IntSet.insert w unks) else case findFarK ld fcs of- Nothing -> (kcs,dbs,w:unks) -- unknown if incomplete kite attached to short edge of ld+ 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 _) -> (w:kcs,dbs,unks) -- short edge lk shared with an rk => largeKiteCentres- Just (RD _) -> (kcs,w:dbs,unks) -- short edge lk shared with an rd => largeDartBases+ 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,w:unks) -- long edge of lk has nothing attached => unknown- Just (RD _) -> (w:kcs,dbs,unks) -- long edge lk shared with rd => largeKiteCentres+ 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 _) -> (w:kcs,dbs,unks)+ Just (LK _) -> (IntSet.insert w kcs,dbs,unks) -- short edge of this rk shared with another lk => largeKiteCentres- Just (LD _) -> (kcs,w:dbs,unks)+ Just (LD _) -> (kcs,IntSet.insert w dbs,unks) -- short edge of this rk shared with ld => largeDartBases- _ -> (kcs,dbs,w:unks) -- short edge of this rk has nothing attached => unknown+ _ -> (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"@@ -181,7 +216,7 @@ find (matchingJoinE rk) (filter isLK fcs) findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face" --- | Auxiliary function for uncheckedPartCompose.+-- | Auxiliary function for partComposeFacesWith. -- Creates a list of new composed faces, each paired with a list of old faces (components of the new face) -- using dart wing information. composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])]
src/Tgraph/Force.hs view
@@ -12,6 +12,8 @@ Tgraph, BoundaryState, and ForceState. -} +{-# LANGUAGE StrictData #-} + module Tgraph.Force ( -- * Forcible class Forcible(..)@@ -42,7 +44,7 @@ , BoundaryChange(..) , Update(..) , UpdateMap- , UpdateGenerator + , UpdateGenerator(..) , UFinder , UChecker -- * BoundaryState operations@@ -68,11 +70,12 @@ , recalculateBVLocs -- * Forcing Rules and Update Generators -- $rules- - -- * Main All Update Generators++ -- * Combined Update Generators , defaultAllUGen+ , combineUpdateGenerators , allUGenerator- -- * Update Generators and Finders for Rules.+ -- * Update Generators and Finders for each Rule. , wholeTileUpdates , incompleteHalves , aceKiteUpdates@@ -111,8 +114,9 @@ , mustbeQueen , kiteWingCount , mustbeJack- -- * Tools for making update generators- , makeGenerator + -- * Other tools for making new update generators+ , newUpdateGenerator+ , makeGenerator , boundaryFilter , makeUpdate -- , hasAnyMatchingE@@ -150,8 +154,8 @@ 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, (!)) -- used for BoundaryState locations AND faces at boundary vertices+import qualified Data.Maybe(fromMaybe) import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate --- import Tgraph.Convert(touching, locateVertices, addVPoint) import Tgraph.Prelude {-@@ -174,7 +178,7 @@ It also keeps track of all the faces and the next vertex label to be used when adding a new vertex. -}-data BoundaryState +data BoundaryState = BoundaryState { boundary:: [Dedge] -- ^ boundary directed edges (face on LHS, exterior on RHS) , bvFacesMap:: VertexMap [TileFace] -- ^faces at each boundary vertex.@@ -186,7 +190,7 @@ -- |Calculates BoundaryState information from a Tgraph -- also checks for no crossing boundaries as these could cause difficult to trace errors in forcing. makeBoundaryState:: Tgraph -> BoundaryState-makeBoundaryState g = +makeBoundaryState g = let bdes = graphBoundary g bvs = fmap fst bdes -- (fmap snd bdes would also do) for all boundary vertices bvLocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ faces g@@ -195,22 +199,29 @@ BoundaryState { boundary = bdes , bvFacesMap = vertexFacesMap bvs (faces g)- , bvLocMap = bvLocs + , bvLocMap = bvLocs , allFaces = faces g , nextVertex = 1+ maxV g }- ++ -- |Converts a BoundaryState back to a Tgraph recoverGraph:: BoundaryState -> Tgraph-recoverGraph bd = makeUncheckedTgraph (allFaces bd)+recoverGraph = makeUncheckedTgraph . allFaces -- |changeVFMap f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap changeVFMap:: TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]+{- changeVFMap f vfm = h x1 (h x2 (h x3 vfm)) where+ (x1,x2,x3) = faceVs f+ h = VMap.alter consf+ consf Nothing = Just [f]+ consf (Just fs) = Just (f:fs)+ -} changeVFMap f vfm = foldl' insertf vfm (faceVList f) where insertf vmap v = VMap.alter consf v vmap consf Nothing = Just [f] consf (Just fs) = Just (f:fs)- + -- |facesAtBV bd v - returns the faces found at v (which must be a boundary vertex) facesAtBV:: BoundaryState -> Vertex -> [TileFace] facesAtBV bd v = case VMap.lookup v (bvFacesMap bd) of@@ -220,39 +231,39 @@ -- |return a list of faces which have a boundary vertex from a BoundaryState boundaryFaces :: BoundaryState -> [TileFace] boundaryFaces bd = nub $ concatMap (facesAtBV bd) bvs where- bvs = fmap fst $ boundary bd+ bvs = fst <$> boundary bd -- boundaryFaces = nub . concat . VMap.elems . bvFacesMap -- relies on the map containing no extra info for non boundary vertices -- |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.-data Update = SafeUpdate TileFace +data Update = SafeUpdate TileFace | UnsafeUpdate (Vertex -> TileFace) -- | 0 is used as a dummy variable to show unsafe updates (to display the function explicitly) instance Show Update where show (SafeUpdate f) = "SafeUpdate (" ++ show f ++ ")" show (UnsafeUpdate mf) = "UnsafeUpdate (\0 -> " ++ show (mf 0)++ ")"- + -- |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 -- |ForceState: The force state records information between executing single face updates during forcing -- (a BoundaryState and an UpdateMap).-data ForceState = ForceState +data ForceState = ForceState { boundaryState:: BoundaryState- , updateMap:: UpdateMap + , updateMap:: UpdateMap } deriving (Show) -{-|UpdateGenerator abbreviates the type of functions which capture one or more of the forcing rules.-They produce a (Try) UpdateMap when given a BoundaryState and a focus list of particular directed boundary edges. +{-|UpdateGenerator is a newtype for functions which capture one or more of the forcing rules.+The functions can be applied using the unwrapper applyUG+and produce a (Try) UpdateMap when given a BoundaryState and a focus list of particular directed boundary edges. Each forcing rule has a particular UpdateGenerator, but they can also be combined (e.g in sequence - allUGenerator or otherwise - defaultAllUGenerator). -}-type UpdateGenerator = BoundaryState -> [Dedge] -> Try UpdateMap-+newtype UpdateGenerator = UpdateGenerator {applyUG :: BoundaryState -> [Dedge] -> Try UpdateMap} -- | Forcible class has operations to (indirectly) implement forcing and single step forcing@@ -288,7 +299,7 @@ bdC <- f (boundaryState fs) tryReviseFSWith ugen bdC fs -- getBoundaryState = boundaryState- + -- | BoundaryStates are Forcible instance Forcible BoundaryState where tryFSOpWith ugen f bd = do@@ -296,7 +307,7 @@ fs' <- f fs return $ boundaryState fs' tryInitFSWith ugen bd = do- umap <- ugen bd (boundary bd)+ umap <- applyUG ugen bd (boundary bd) return $ ForceState { boundaryState = bd , updateMap = umap } tryChangeBoundaryWith _ f bd = do -- update generator not used bdC <- f bd@@ -331,17 +342,17 @@ -- | try a given number of force steps using a given UpdateGenerator. tryStepForceWith :: Forcible a => UpdateGenerator -> Int -> a -> Try a-tryStepForceWith ugen n = +tryStepForceWith ugen n = if n>=0- then tryFSOpWith ugen $ count n + then tryFSOpWith ugen $ count n else error "tryStepForceWith: used with negative number of steps\n" where count 0 fs = return fs count m fs = do result <- tryOneStepWith ugen fs case result of Nothing -> return fs- Just (fs', _) -> count (m-1) fs' - + Just (fs', _) -> count (m-1) fs'+ -- |A version of tryFSOpWith using defaultAllUGen representing all 10 rules for updates. tryFSOp :: Forcible a => (ForceState -> Try ForceState) -> a -> Try a tryFSOp = tryFSOpWith defaultAllUGen@@ -358,7 +369,7 @@ -- |special case of forcing only half tiles to whole tiles wholeTiles:: Forcible a => a -> a-wholeTiles = forceWith wholeTileUpdates +wholeTiles = forceWith wholeTileUpdates -- | forceWith ugen: force using the given UpdateGenerator forceWith:: Forcible a => UpdateGenerator -> a -> a@@ -377,7 +388,7 @@ -- |tryStepForce n a - produces a (Right) intermediate Forcible after n steps (n face additions) starting from Forcible a. -- or a Left report if it encounters a stuck/incorrect Forcible within n steps. -- If forcing finishes successfully in n or fewer steps, it will return that final Forcible. -tryStepForce :: Forcible a => Int -> a -> Try a +tryStepForce :: Forcible a => Int -> a -> Try a tryStepForce = tryStepForceWith defaultAllUGen-- Was called tryStepForceFrom -- |stepForce n a - produces an intermediate Forcible after n steps (n face additions) starting from Forcible a.@@ -408,7 +419,7 @@ tryAddHalfKite = tryChangeBoundary . tryAddHalfKiteBoundary where -- |tryAddHalfKiteBoundary implements tryAddHalfKite as a BoundaryState change -- tryAddHalfKiteBoundary :: Dedge -> BoundaryState -> Try BoundaryChange- tryAddHalfKiteBoundary e bd = + tryAddHalfKiteBoundary e bd = do de <- case [e, reverseD e] `intersect` boundary bd of [de] -> Right de _ -> Left $ "tryAddHalfKite: on non-boundary edge " ++ show e ++ "\n"@@ -428,7 +439,7 @@ -- the edge is not a boundary edge. addHalfDart :: Forcible a => Dedge -> a -> a addHalfDart e = runTry . tryAddHalfDart e- + -- |tryAddHalfDart is a version of addHalfDart which returns a Try -- with a Left report if it finds a stuck/incorrect graph, or -- if the edge is a dart short edge or kite join, or@@ -437,7 +448,7 @@ tryAddHalfDart = tryChangeBoundary . tryAddHalfDartBoundary where -- |tryAddHalfDartBoundary implements tryAddHalfDart as a BoundaryState change -- tryAddHalfDartBoundary :: Dedge -> BoundaryState -> Try BoundaryChange- tryAddHalfDartBoundary e bd = + tryAddHalfDartBoundary e bd = do de <- case [e, reverseD e] `intersect` boundary bd of [de] -> Right de _ -> Left $ "tryAddHalfDart: on non-boundary edge " ++ show e ++ "\n"@@ -456,7 +467,7 @@ -- 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 = +tryOneStepWith uGen fs = case findSafeUpdate (updateMap fs) of Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u fs' <- tryReviseFSWith uGen bdChange fs@@ -478,7 +489,7 @@ (3) a list of boundary edges requiring updates to be recalculated - i.e the new boundary edges and their immediate neighbours (4,3,or 0). (4) the face that has been added. -}-data BoundaryChange = BoundaryChange +data BoundaryChange = BoundaryChange { newBoundaryState:: BoundaryState -- ^ resulting boundary state , removedEdges:: [Dedge] -- ^ edges no longer on the boundary , revisedEdges :: [Dedge] -- ^ new boundary edges plus immediate boundary neighbours (requiring new update calculations)@@ -515,14 +526,14 @@ -} mustFind :: Foldable t => (p -> Bool) -> t p -> p -> p mustFind p ls dflt- = maybe dflt id (find p ls)+ = Data.Maybe.fromMaybe dflt (find p ls) -- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange) -- using uGen to calculate new updates. tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap-tryReviseUpdates uGen bdChange umap = +tryReviseUpdates uGen bdChange umap = do let umap' = foldr Map.delete umap (removedEdges bdChange)- umap'' <- uGen (newBoundaryState bdChange) (revisedEdges bdChange) + umap'' <- applyUG uGen (newBoundaryState bdChange) (revisedEdges bdChange) return (Map.union umap'' umap') -- |tryReviseFSWith ugen bdC fs tries to revise fs after a boundary change (bdC) by calculating@@ -534,7 +545,7 @@ -- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering)-findSafeUpdate:: UpdateMap -> Maybe Update +findSafeUpdate:: UpdateMap -> Maybe Update findSafeUpdate umap = find isSafeUpdate (Map.elems umap) where isSafeUpdate (SafeUpdate _ ) = True isSafeUpdate (UnsafeUpdate _ ) = False@@ -569,8 +580,8 @@ -} checkUnsafeUpdate:: BoundaryState -> Update -> Maybe BoundaryChange checkUnsafeUpdate _ (SafeUpdate _) = error "checkUnsafeUpdate: applied to safe update.\n"-checkUnsafeUpdate bd (UnsafeUpdate makeFace) = - let v = nextVertex bd +checkUnsafeUpdate bd (UnsafeUpdate makeFace) =+ let v = nextVertex bd newface = makeFace v oldVPoints = bvLocMap bd newVPoints = addVPoint newface oldVPoints@@ -585,7 +596,7 @@ , allFaces = newface:allFaces bd , nextVertex = v+1 }- bdChange = BoundaryChange + bdChange = BoundaryChange { newBoundaryState = resultBd , removedEdges = matchedDedges , revisedEdges = affectedBoundary resultBd newDedges@@ -593,7 +604,7 @@ } in if touchCheck vPosition oldVPoints -- true if new vertex is blocked because it touches the boundary elsewhere then Nothing -- don't proceed when v is a touching vertex- else Just bdChange + else Just bdChange {-| trySafeUpdate bd u adds a new face by completing a safe update u on BoundaryState bd (raising an error if u is an unsafe update).@@ -606,13 +617,15 @@ -} trySafeUpdate:: BoundaryState -> Update -> Try BoundaryChange trySafeUpdate _ (UnsafeUpdate _) = error "trySafeUpdate: applied to non-safe update.\n"-trySafeUpdate bd (SafeUpdate newface) = +trySafeUpdate bd (SafeUpdate newface) = let fDedges = faceDedges newface- matchedDedges = fDedges `intersect` boundary bd -- list of 2 or 3+ localRevDedges = [(b,a) | v <- faceVList newface, f <- bvFacesMap bd VMap.! 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 = fmap reverseD (fDedges \\ matchedDedges) -- one or none nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs- resultBd = BoundaryState + resultBd = BoundaryState { boundary = newDedges ++ (boundary bd \\ matchedDedges) , bvFacesMap = foldr VMap.delete (changeVFMap newface $ bvFacesMap bd) removedBVs -- , bvFacesMap = changeVFMap newface (bvFacesMap bd)@@ -621,31 +634,31 @@ --remove vertex/vertices no longer on boundary , nextVertex = nextVertex bd }- bdChange = BoundaryChange + bdChange = BoundaryChange { newBoundaryState = resultBd , removedEdges = matchedDedges , revisedEdges = affectedBoundary resultBd newDedges , newFace = newface }- in if noNewConflict newface nbrFaces - then Right bdChange + in if noNewConflict newface nbrFaces+ then Right bdChange else Left $ "trySafeUpdate:(incorrect tiling)\nConflicting new face " ++ show newface ++ "\nwith neighbouring faces\n" ++ show nbrFaces ++ "\n" - + -- | given 2 consecutive directed edges (not necessarily in the right order), -- this returns the common vertex (as a singleton list). -- Exceptionally it may be given 3 consecutive directed edges forming a triangle -- and returns the 3 vertices of the triangle. -- It raises an error if the argument is not one of these 2 cases. commonVs :: [Dedge] -> [Vertex]-commonVs [(a,b),(c,d)] | b==c = [b] +commonVs [(a,b),(c,d)] | b==c = [b] | d==a = [a] | otherwise = error $ "commonVs: 2 directed edges not consecutive: " ++ show [(a,b),(c,d)] ++ "\n"-commonVs [(a,b),(c,d),(e,f)] | length (nub [a,b,c,d,e,f]) == 3 = [a,c,e] +commonVs [(a,b),(c,d),(e,f)] | length (nub [a,b,c,d,e,f]) == 3 = [a,c,e] commonVs es = error $ "commonVs: unexpected argument edges (not 2 consecutive directed edges or 3 round triangle): " ++ show es ++ "\n" -- |tryUpdate: tries a single update (safe or unsafe),@@ -653,17 +666,17 @@ -- or if a stuck/incorrect Tgraph is discovered in the safe case. tryUpdate:: BoundaryState -> Update -> Try BoundaryChange tryUpdate bd u@(SafeUpdate _) = trySafeUpdate bd u-tryUpdate bd u@(UnsafeUpdate _) = +tryUpdate bd u@(UnsafeUpdate _) = case checkUnsafeUpdate bd u of Just bdC -> return bdC Nothing -> Left "tryUpdate: crossing boundary (touching vertices).\n" -- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateVertices.--- (Used at intervals in tryRecalibrateForce and recalibrateForce).+-- (Used at intervals in tryRecalibratingForce and recalibratingForce). recalculateBVLocs :: BoundaryState -> BoundaryState recalculateBVLocs bd = bd {bvLocMap = newlocs} where newlocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ allFaces bd- bvs = fmap fst $ boundary bd+ bvs = 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.@@ -681,7 +694,7 @@ recalibratingForce = runTry . tryRecalibratingForce - + {- $rules FORCING RULES: @@ -720,26 +733,32 @@ sun, star, jack, queen, king, ace (fool), deuce -}- -{------------------- FORCING RULES and Generators --------------------------++{------------------- FORCING RULES and Update Generators -------------------------- 7 vertex types are: sun, queen, jack (largeDartBase), ace (fool), deuce (largeKiteCentre), king, star -} -{-| allUGenerator was the original generator for all updates. It combines the individual update generators for each of the 10 rules.- They are combined in sequence, keeping the rule order (after applying each to the- supplied BoundaryState and a focus edge list). (See also defaultAllUGen).- This version returns a Left..(fail report) for the first generator that produces a Left..(fail report).+-- |combineUpdateGenerators combines a list of update generators into a single update generator.+-- When used, the generators are tried in order on each boundary edge (in the supplied focus edges),+-- and will return a Left..(fail report) for the first generator that produces a Left..(fail report) if any.+combineUpdateGenerators :: [UpdateGenerator] -> UpdateGenerator+combineUpdateGenerators gens = UpdateGenerator genf where+ genf bd focus =+ do let addGen (Right (es,umap)) gen =+ do umap' <- applyUG gen bd es+ let es' = es \\ Map.keys umap'+ return (es',Map.union umap' umap)+ addGen other _ = other -- fails with first failing generator+ (_ , umap) <- foldl' addGen (Right (focus,Map.empty)) gens+ return umap++{-| allUGenerator was the original generator for all updates.+ It combines the individual update generators for each of the 10 rules in sequence using combineUpdateGenerators+ (See also defaultAllUGen which is defined without using combineUpdateGenerators) -}-allUGenerator :: UpdateGenerator -allUGenerator bd focus =- do (_ , umap) <- foldl' addGen (Right (focus,Map.empty)) generators- return umap- where- addGen (Right (es,umap)) gen = do umap' <- gen bd es- let es' = es \\ Map.keys umap'- return (es',Map.union umap' umap) - addGen other _ = other -- fails with first failing generator+allUGenerator :: UpdateGenerator+allUGenerator = combineUpdateGenerators generators where generators = [ wholeTileUpdates -- (rule 1) , aceKiteUpdates -- (rule 2) , queenOrKingUpdates -- (rule 3)@@ -752,6 +771,7 @@ , queenKiteUpdates -- (rule 10) ] + -- |UFinder (Update case finder functions). Given a BoundaryState and a list of (focus) boundary directed edges, -- such a function returns each focus edge satisfying the particular update case paired with the tileface -- matching that edge. For example, if the function is looking for dart short edges on the boundary,@@ -767,7 +787,7 @@ -- Such a function can be used with a UFinder that either returns dart halves with short edge on the boundary -- (nonKDarts in rule 2) or returns kite halves with short edge on the boundary -- (kitesWingDartOrigin in rule 3).-type UChecker = BoundaryState -> TileFace -> Try Update +type UChecker = BoundaryState -> TileFace -> Try Update {-|This is a general purpose filter used to create UFinder functions for each force rule. It requires a face predicate.@@ -780,8 +800,8 @@ (eg in kitesWingDartOrigin) -} boundaryFilter:: (BoundaryState -> Dedge -> TileFace -> Bool) -> UFinder-boundaryFilter predF bd focus = - [ (e,fc) | e <- focus +boundaryFilter predF bd focus =+ [ (e,fc) | e <- focus , fc <- facesAtBV bd (fst e) , fc `elem` facesAtBV bd (snd e) , predF bd e fc@@ -790,10 +810,12 @@ -- |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) = SafeUpdate (f v)+ -- let newf = evalFace $ f v+ -- in SafeUpdate newf -- fully evaluate new face makeUpdate f Nothing = UnsafeUpdate f - + -- |A vertex on the boundary must be a star if it has 7 or more dart origins mustbeStar:: BoundaryState -> Vertex -> Bool mustbeStar bd v = length (filter ((==v) . originV) $ filter isDart $ facesAtBV bd v) >= 7@@ -847,7 +869,7 @@ mustbeJack :: BoundaryState -> Vertex -> Bool mustbeJack bd v = (length dWings == 2 && not (hasAnyMatchingE (fmap longE dWings))) || -- 2 dart wings and dart long edges not shared.- (length dWings == 1 && isKiteOrigin) + (length dWings == 1 && isKiteOrigin) where fcs = facesAtBV bd v dWings = filter ((==v) . wingV) $ filter isDart fcs isKiteOrigin = v `elem` fmap originV (filter isKite fcs)@@ -857,42 +879,45 @@ hasAnyMatchingE ((x,y):more) = (y,x) `elem` more || hasAnyMatchingE more hasAnyMatchingE [] = False -{-| makeGenerator combines an update case finder (UFinder) with its corresponding update checker (UChecker)- to produce an update generator function.+{-| newUpdateGenerator combines an update case finder (UFinder) with its corresponding update checker (UChecker)+ to produce an update generator. This is used to make each of the 10 update generators corresponding to 10 rules. - When the generator is given a BoundaryState and list of focus edges,+ When the generator is applied (with applyUG) to a BoundaryState and list of focus edges, the finder produces a list of pairs of dedge and face, the checker is used to convert the face in each pair to an update (which can fail with a Left report),- and the new updates are returned as a map (with the dedges as key) in a Right result.+ and the new updates are returned as a map (with the dedges as keys) in a Right result. -}+newUpdateGenerator :: UChecker -> UFinder -> UpdateGenerator+newUpdateGenerator checker finder = UpdateGenerator genf where+ genf bd edges = foldr addU (Right Map.empty) (finder bd edges) where+ addU _ (Left x) = Left x+ addU (e,fc) (Right ump) = do u <- checker bd fc+ return (Map.insert e u ump)++{-| makeGenerator (deprecated) this is renamed as newUpdateGenerator. -} makeGenerator :: UChecker -> UFinder -> UpdateGenerator-makeGenerator checker finder = gen where- gen bd edges = foldr addU (Right Map.empty) (finder bd edges) where- addU _ (Left x) = Left x - addU (e,fc) (Right ump) = do u <- checker bd fc- return (Map.insert e u ump)+makeGenerator = newUpdateGenerator - -- Ten Update Generators (with corresponding Finders) -- |Update generator for rule (1) wholeTileUpdates:: UpdateGenerator-wholeTileUpdates = makeGenerator completeHalf incompleteHalves+wholeTileUpdates = newUpdateGenerator completeHalf incompleteHalves -- |Find faces with missing opposite face (mirror face) -incompleteHalves :: UFinder +incompleteHalves :: UFinder incompleteHalves = boundaryFilter boundaryJoin where boundaryJoin _ (a,b) fc = joinE fc == (b,a) -- |Update generator for rule (2) aceKiteUpdates :: UpdateGenerator-aceKiteUpdates = makeGenerator addKiteShortE nonKDarts+aceKiteUpdates = newUpdateGenerator addKiteShortE nonKDarts -- |Find half darts with boundary short edge-nonKDarts :: UFinder +nonKDarts :: UFinder nonKDarts = boundaryFilter bShortDarts where bShortDarts _ (a,b) fc = isDart fc && shortE fc == (b,a) @@ -900,12 +925,12 @@ -- |Update generator for rule (3) -- queen and king vertices add a missing kite half (on a boundary kite short edge) queenOrKingUpdates :: UpdateGenerator-queenOrKingUpdates = makeGenerator addKiteShortE kitesWingDartOrigin+queenOrKingUpdates = newUpdateGenerator addKiteShortE kitesWingDartOrigin -- |Find kites with boundary short edge where the wing is also a dart origin-kitesWingDartOrigin :: UFinder +kitesWingDartOrigin :: UFinder kitesWingDartOrigin = boundaryFilter kiteWDO where- kiteWDO bd (a,b) fc = shortE fc == (b,a) + kiteWDO bd (a,b) fc = shortE fc == (b,a) && isKite fc && isDartOrigin bd (wingV fc) @@ -916,12 +941,12 @@ These need a dart adding on the short edge. -} deuceDartUpdates :: UpdateGenerator-deuceDartUpdates = makeGenerator addDartShortE kiteGaps+deuceDartUpdates = newUpdateGenerator addDartShortE kiteGaps -- |Find kite halves with a short edge on the boundary (a,b) -- where there are 2 other kite halves sharing a short edge -- at oppV of the kite half (a for left kite and b for right kite)-kiteGaps :: UFinder +kiteGaps :: UFinder kiteGaps = boundaryFilter kiteGap where kiteGap bd (a,b) fc = shortE fc == (b,a) && isKite fc && mustbeDeuce bd (oppV fc)@@ -930,12 +955,12 @@ -- |Update generator for rule (5) -- jackDartUpdates - jack vertex add a missing second dart jackDartUpdates :: UpdateGenerator-jackDartUpdates = makeGenerator addDartShortE noTouchingDart+jackDartUpdates = newUpdateGenerator addDartShortE noTouchingDart -- |Find kite halves with a short edge on the boundary (a,b) where oppV must be a jack vertex -- (oppV is a for left kite and b for right kite). -- The function mustbeJack finds if a vertex must be a jack-noTouchingDart :: UFinder +noTouchingDart :: UFinder noTouchingDart = boundaryFilter farKOfDarts where farKOfDarts bd (a,b) fc = shortE fc == (b,a) && isKite fc && mustbeJack bd (oppV fc)@@ -949,14 +974,14 @@ sharing the long edge. -} sunStarUpdates :: UpdateGenerator-sunStarUpdates = makeGenerator completeSunStar almostSunStar+sunStarUpdates = newUpdateGenerator completeSunStar almostSunStar -- |Find a boundary long edge of either -- a dart where there are at least 7 dart origins, or -- a kite where there are at least 5 kite origins-almostSunStar :: UFinder +almostSunStar :: UFinder almostSunStar = boundaryFilter multiples57 where- multiples57 bd (a,b) fc = longE fc == (b,a) && + multiples57 bd (a,b) fc = longE fc == (b,a) && ((isDart fc && mustbeStar bd (originV fc)) || (isKite fc && mustbeSun bd (originV fc)) )@@ -965,11 +990,11 @@ -- jack vertices with dart long edge on the boundary - add missing kite top. -- The function mustbeJack finds if a vertex must be a jack. jackKiteUpdates :: UpdateGenerator-jackKiteUpdates = makeGenerator addKiteLongE jackMissingKite+jackKiteUpdates = newUpdateGenerator addKiteLongE jackMissingKite -- |Find jack vertices with dart long edge on the boundary. -- The function mustbeJack finds if a vertex must be a jack-jackMissingKite :: UFinder +jackMissingKite :: UFinder jackMissingKite = boundaryFilter dartsWingDB where dartsWingDB bd (a,b) fc = longE fc == (b,a) && isDart fc && mustbeJack bd (wingV fc)@@ -977,11 +1002,11 @@ -- |Update generator for rule (8) -- king vertices with 2 of the 3 darts - add another half dart on a boundary long edge of existing darts kingDartUpdates :: UpdateGenerator-kingDartUpdates = makeGenerator addDartLongE kingMissingThirdDart+kingDartUpdates = newUpdateGenerator addDartLongE kingMissingThirdDart -- |Find king vertices with a dart long edge on the boundary -- and 2 of the 3 darts at its origin plus a kite wing at its origin-kingMissingThirdDart :: UFinder +kingMissingThirdDart :: UFinder kingMissingThirdDart = boundaryFilter predicate where predicate bd (a,b) fc = longE fc == (b,a) && isDart fc && mustbeKing bd (originV fc)@@ -990,26 +1015,26 @@ -- |Update generator for rule (9) -- queen vertices (more than 2 kite wings) with a boundary kite long edge - add a half dart queenDartUpdates :: UpdateGenerator-queenDartUpdates = makeGenerator addDartLongE queenMissingDarts+queenDartUpdates = newUpdateGenerator addDartLongE queenMissingDarts -- |Find queen vertices (more than 2 kite wings) with a boundary kite long edge-queenMissingDarts :: UFinder +queenMissingDarts :: UFinder queenMissingDarts = boundaryFilter predicate where- predicate bd (a,b) fc = + predicate bd (a,b) fc = longE fc == (b,a) && isKite fc && length kiteWings >2 where fcWing = wingV fc- kiteWings = filter ((==fcWing) . wingV) $ + kiteWings = filter ((==fcWing) . wingV) $ filter isKite $ facesAtBV bd fcWing- + -- |Update generator for rule (10) -- queen vertices with more than 2 kite wings -- add missing half kite on a boundary kite short edge queenKiteUpdates :: UpdateGenerator-queenKiteUpdates = makeGenerator addKiteShortE queenMissingKite+queenKiteUpdates = newUpdateGenerator addKiteShortE queenMissingKite -- |Find queen vertices (2 or more kite wings) and a kite short edge on the boundary-queenMissingKite :: UFinder +queenMissingKite :: UFinder queenMissingKite = boundaryFilter predicate where- predicate bd (a,b) fc = + predicate bd (a,b) fc = shortE fc == (b,a) && isKite fc && length kiteWings >2 where fcWing = wingV fc kiteWings = filter ((==fcWing) . wingV) $ filter isKite (facesAtBV bd fcWing)@@ -1020,79 +1045,79 @@ -- |completeHalf will check an update to -- add a symmetric (mirror) face for a given face at a boundary join edge.-completeHalf :: UChecker +completeHalf :: UChecker completeHalf bd (LD(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = RD(a,v,b)+ makeFace v = RD (a,v,b) x = tryFindThirdV bd (b,a) (3,1) --anglesForJoinRD completeHalf bd (RD(a,_,b)) = makeUpdate makeFace <$> x where- makeFace v = LD(a,b,v)+ makeFace v = LD (a,b,v) x = tryFindThirdV bd (a,b) (1,3) --anglesForJoinLD completeHalf bd (LK(a,_,b)) = makeUpdate makeFace <$> x where- makeFace v = RK(a,b,v)+ makeFace v = RK (a,b,v) x = tryFindThirdV bd (a,b) (1,2) --anglesForJoinRK completeHalf bd (RK(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = LK(a,v,b)+ makeFace v = 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 :: UChecker addKiteShortE bd (RD(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = LK(v,c,b)+ makeFace v = LK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK addKiteShortE bd (LD(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = RK(v,c,b)+ makeFace v = RK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = RK(v,c,b)+ makeFace v = RK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = LK(v,c,b)+ makeFace v = 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 :: UChecker addDartShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = LD(v,c,b)+ makeFace v = LD (v,c,b) x = tryFindThirdV bd (c,b) (3,1) --anglesForShortLD addDartShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = RD(v,c,b)+ makeFace v = RD (v,c,b) x = tryFindThirdV bd (c,b) (1,3) --anglesForShortRD addDartShortE _ _ = error "addDartShortE applied to non-kite face\n" -- |add a kite half to a kite long edge or dart half to a dart long edge completeSunStar :: UChecker-completeSunStar bd fc = if isKite fc +completeSunStar bd fc = if isKite fc then addKiteLongE bd fc else addDartLongE bd fc -- |add a kite to a long edge of a dart or kite-addKiteLongE :: UChecker +addKiteLongE :: UChecker addKiteLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = RK(c,v,a)+ makeFace v = RK (c,v,a) x = tryFindThirdV bd (a,c) (2,1) -- anglesForLongRK addKiteLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = LK(b,a,v)+ makeFace v = LK (b,a,v) x = tryFindThirdV bd (b,a) (1,2) -- anglesForLongLK addKiteLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = LK(a,c,v)+ makeFace v = LK (a,c,v) x = tryFindThirdV bd (a,c) (1,2) -- anglesForLongLK addKiteLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = RK(a,v,b)+ makeFace v = 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 :: UChecker addDartLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = RD(a,c,v)+ makeFace v = RD (a,c,v) x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongRD addDartLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = LD(a,v,b)+ makeFace v = LD (a,v,b) x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongLD addDartLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = RD(b,a,v)+ makeFace v = RD (b,a,v) x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongRD addDartLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = LD(c,v,a)+ makeFace v = LD (c,v,a) x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongLD {-@@ -1125,37 +1150,39 @@ -- If there are any Left..(fail reports) for the given -- boundary edges the result is a sigle Left.. concatenating all the failure reports (unlike allUGenerator). defaultAllUGen :: UpdateGenerator-defaultAllUGen bd es = combine $ fmap decide es where -- Either String is a monoid as well as Map- decide e = decider (e,f,etype) where (f,etype) = inspectBDedge bd e+defaultAllUGen = UpdateGenerator gen where+ gen bd es = combine $ fmap 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- decider (e,f,Short) - | isDart f = mapItem e (addKiteShortE bd f) -- rule 2- | otherwise = kiteShortDecider e f - decider (e,f,Long) - | isDart f = dartLongDecider e f- | otherwise = kiteLongDecider e f + decider (e,f,Join) = mapItem e (completeHalf bd f) -- rule 1+ decider (e,f,Short)+ | isDart f = mapItem e (addKiteShortE bd f) -- rule 2+ | otherwise = kiteShortDecider e f+ decider (e,f,Long)+ | isDart f = dartLongDecider e f+ | otherwise = kiteLongDecider e f - dartLongDecider e f- | mustbeStar bd (originV f) = mapItem e (completeSunStar bd f)- | mustbeKing bd (originV f) = mapItem e (addDartLongE bd f)- | mustbeJack bd (wingV f) = mapItem e (addKiteLongE bd f)- | otherwise = Right Map.empty+ dartLongDecider e f+ | mustbeStar bd (originV f) = mapItem e (completeSunStar bd f)+ | mustbeKing bd (originV f) = mapItem e (addDartLongE bd f)+ | mustbeJack bd (wingV f) = mapItem e (addKiteLongE bd f)+ | otherwise = Right Map.empty - kiteLongDecider e f- | mustbeSun bd (originV f) = mapItem e (completeSunStar bd f)- | mustbeQueen bd (wingV f) = mapItem e (addDartLongE bd f)- | otherwise = Right Map.empty+ kiteLongDecider e f+ | mustbeSun bd (originV f) = mapItem e (completeSunStar bd f)+ | mustbeQueen bd (wingV f) = mapItem e (addDartLongE bd f)+ | otherwise = Right Map.empty - kiteShortDecider e f- | mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem e (addDartShortE bd f)- | mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem e (addKiteShortE bd f)- | otherwise = Right Map.empty+ kiteShortDecider e f+ | mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem e (addDartShortE bd f)+ | mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem e (addKiteShortE bd f)+ | otherwise = Right Map.empty - 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+ 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) inspectBDedge:: BoundaryState -> Dedge -> (TileFace, EdgeType)@@ -1206,31 +1233,31 @@ tryFindThirdV bd (a,b) (n,m) = maybeV where aAngle = externalAngle bd a bAngle = externalAngle bd b- maybeV | aAngle <1 || aAngle >9 + maybeV | aAngle <1 || aAngle >9 = Left $ "tryFindThirdV: vertex: " ++ show a ++ " has (tt) external angle " ++ show aAngle ++ "\nwhen adding to boundary directed edge: " ++ show (a,b)- ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) + ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) ++ "\nand faces at " ++ show b ++ ":\n" ++ show (bvFacesMap bd VMap.! b) ++ "\nand a total of " ++ show (length $ allFaces bd) ++ " faces.\n"- | bAngle <1 || bAngle >9 + | bAngle <1 || bAngle >9 = Left $ "tryFindThirdV: vertex: " ++ show b ++ " has (tt) external angle " ++ show bAngle ++ "\nwhen adding to boundary directed edge: " ++ show (a,b)- ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) + ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) ++ "\nand faces at " ++ show b ++ ":\n" ++ show (bvFacesMap bd VMap.! b) ++ "\nand a total of " ++ show (length $ allFaces bd) ++ " faces.\n"- | aAngle < n - = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " + | aAngle < n+ = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " ++ show (a,b) ++ "\n" | bAngle < m- = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " + = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " ++ show (a,b) ++ "\n" | aAngle == n = case find ((==a) . snd) (boundary bd) of Just pr -> Right $ Just (fst pr)- Nothing -> Left $ "tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " + Nothing -> Left $ "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 -> Left $ "tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " + Nothing -> Left $ "tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " ++ show (a,b) ++ "\n" | otherwise = Right Nothing @@ -1239,7 +1266,7 @@ -- so that there is a single external angle at each boundary vertex. externalAngle:: BoundaryState -> Vertex -> Int externalAngle bd v = 10 - sum (map (intAngleAt v) $ facesAtBV bd v)- + -- |intAngleAt v fc gives the internal angle of the face fc at vertex v (which must be a vertex of the face) -- in terms of tenth turns, so returning an Int (1,2,or 3). intAngleAt :: Vertex -> TileFace -> Int
src/Tgraph/Prelude.hs view
@@ -38,6 +38,8 @@ -- , renumberFaces -- , differing , makeUncheckedTgraph+ , evalFaces+ -- , evalFace , checkedTgraph , tryTgraphProps , tryConnectedNoCross@@ -96,13 +98,13 @@ , wingV , oppV , indexV- , nextV + , nextV , prevV , isAtV , hasVIn -- * Other Edge Operations , faceDedges- , facesDedges + , facesDedges , reverseD , joinE , shortE@@ -187,6 +189,7 @@ import Try + {--------------------- ********************* Tgraphs@@ -247,9 +250,9 @@ tryMakeTgraph fcs = do g <- tryTgraphProps fcs -- must be checked first let touchVs = touchingVertices (faces g)- if null touchVs - then Right g - else Left ("Found touching vertices: " + if null touchVs+ then Right g+ else Left ("Found touching vertices: " ++ show touchVs ++ "\nwith faces:\n" ++ show fcs@@ -263,8 +266,8 @@ the renumbering need not be 1-1 (hence Relabelling is not used) -} tryCorrectTouchingVs :: [TileFace] -> Try Tgraph-tryCorrectTouchingVs fcs = - onFail ("tryCorrectTouchingVs:\n" ++ show touchVs) $ +tryCorrectTouchingVs fcs =+ onFail ("tryCorrectTouchingVs:\n" ++ show touchVs) $ tryTgraphProps $ nub $ renumberFaces touchVs fcs -- renumberFaces allows for a non 1-1 relabelling represented by a list where touchVs = touchingVertices fcs -- uses non-generalised version of touchingVertices@@ -278,13 +281,23 @@ all3 f (a,b,c) = (f a,f b,f c) renumber v = VMap.findWithDefault v v mapping differing = filter $ uncurry (/=)- + -- |Creates a (possibly invalid) Tgraph from a list of faces. -- It does not perform checks on the faces. Use makeTgraph (defined in Tgraphs module) or checkedTgraph to perform checks.--- This is intended for use only when checks are known to be redundant (the data constructor Tgraph is hidden).+-- This is intended for use only when checks are known to be redundant.+-- It also fully evaluates the list of faces (to reduce space leaks). makeUncheckedTgraph:: [TileFace] -> Tgraph-makeUncheckedTgraph fcs = Tgraph fcs+makeUncheckedTgraph fcs = Tgraph (evalFaces fcs) +-- |force evaluation of a list of faces.+evalFaces :: [TileFace] -> [TileFace]+evalFaces fcs = facesMaxV fcs `seq` fcs++{- -- |force evaluation of a face.+evalFace ::TileFace -> TileFace+evalFace face = oppV face `seq` wingV face `seq` originV face `seq` face+ -}+ {-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties and producing an error if a check fails. @@ -308,7 +321,7 @@ Returns Left lines if a test fails, where lines describes the problem found. -} tryTgraphProps:: [TileFace] -> Try Tgraph-tryTgraphProps [] = Right emptyTgraph +tryTgraphProps [] = Right emptyTgraph tryTgraphProps fcs | hasEdgeLoops fcs = Left $ "tryTgraphProps: Non-valid tile-face(s)\n" ++ "Edge Loops at: " ++ show (findEdgeLoops fcs) ++ "\n"@@ -320,7 +333,7 @@ | otherwise = let vs = facesVSet fcs in if IntSet.findMin vs <1 -- any (<1) $ IntSet.toList vs then Left $ "tryTgraphProps: Vertex numbers not all >0: " ++ show (IntSet.toList vs) ++ "\n"- else tryConnectedNoCross fcs + else tryConnectedNoCross fcs -- |Checks a list of faces for no crossing boundaries and connectedness. -- (No crossing boundaries and connected implies tile-connected).@@ -332,7 +345,7 @@ tryConnectedNoCross fcs | not (connected fcs) = Left $ "tryConnectedNoCross: Non-valid Tgraph (Not connected)\n" ++ show fcs ++ "\n" | crossingBoundaries fcs = Left $ "tryConnectedNoCross: Non-valid Tgraph\n" ++- "Crossing boundaries found at " ++ show (crossingBVs fcs) + "Crossing boundaries found at " ++ show (crossingBVs fcs) ++ "\nwith faces\n" ++ show fcs | otherwise = Right (Tgraph fcs) @@ -367,8 +380,8 @@ edgeType:: Dedge -> TileFace -> EdgeType edgeType d f | d == longE f = Long | d == shortE f = Short- | d == joinE f = Join - | otherwise = error $ "edgeType: directed edge " ++ show d ++ + | d == joinE f = Join+ | otherwise = error $ "edgeType: directed edge " ++ show d ++ " not found in face " ++ show f ++ "\n" -- |For a list of tile faces fcs this produces a list of tuples of the form (f1,etpe1,f2,etype2)@@ -376,7 +389,7 @@ -- etype2 is the type of the shared edge in f2. -- This list can then be checked for inconsistencies / illegal pairings (using legal). sharedEdges:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]-sharedEdges fcs = [(f1, edgeType d1 f1, f2, edgeType d2 f2) +sharedEdges fcs = [(f1, edgeType d1 f1, f2, edgeType d2 f2) | f1 <- fcs , d1 <- faceDedges f1 , let d2 = reverseD d1@@ -386,8 +399,8 @@ -- |A version of sharedEdges comparing a single face against a list of faces. -- This does not look at shared edges within the list, but just the new face against the list. newSharedEdges:: TileFace -> [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]-newSharedEdges face fcs = - [(face, edgeType d1 face, fc', edgeType d2 fc') +newSharedEdges face fcs =+ [(face, edgeType d1 face, fc', edgeType d2 fc') | d1 <- faceDedges face , let d2 = reverseD d1 , fc' <- filter (`hasDedge` d2) fcs@@ -396,7 +409,7 @@ -- | noNewConflict face fcs returns True if face has an illegal shared edge with fcs. -- It does not check for illegal cases within the fcs. noNewConflict :: TileFace -> [TileFace] -> Bool-noNewConflict face fcs = null $ filter (not . legal) shared where+noNewConflict face fcs = all legal shared where shared = newSharedEdges face fcs {-@@ -409,9 +422,9 @@ -- | legal (f1,etype1,f2,etype2) is True if and only if it is legal for f1 and f2 to share an edge -- with edge type etype1 (and etype2 is equal to etype1). -legal:: (TileFace,EdgeType,TileFace,EdgeType) -> Bool -legal (LK _, e1, RK _ , e2 ) = e1 == e2 -legal (RK _, e1, LK _ , e2 ) = e1 == e2 +legal:: (TileFace,EdgeType,TileFace,EdgeType) -> Bool+legal (LK _, e1, RK _ , e2 ) = e1 == e2+legal (RK _, e1, LK _ , e2 ) = e1 == e2 legal (LK _, Short, RD _ , Short) = True legal (RD _, Short, LK _ , Short) = True legal (LK _, Long, RD _ , Long ) = True@@ -424,7 +437,7 @@ legal (RK _, Short, LD _ , Short) = True legal (LD _, Long, RK _ , Long ) = True legal (RK _, Long, LD _ , Long ) = True-legal _ = False +legal _ = False -- | Returns a list of illegal face parings 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.@@ -440,7 +453,7 @@ -- |crossingBVs fcs returns a list of vertices with crossing boundaries -- (which should be null). crossingBVs :: [TileFace] -> [Vertex]-crossingBVs = crossingVertices . facesBoundary +crossingBVs = crossingVertices . facesBoundary -- |Given a list of directed boundary edges, crossingVertices returns a list of vertices occurring -- more than once at the start of the directed edges in the list.@@ -467,17 +480,17 @@ -- This version creates an IntMap to represent edges (Vertex to [Vertex]) -- and uses IntSets for the search algorithm arguments. connectedBy :: [Dedge] -> Vertex -> VertexSet -> ([Vertex],[Vertex])-connectedBy edges v verts = search IntSet.empty (IntSet.singleton v) (IntSet.delete v verts) where +connectedBy edges v verts = search IntSet.empty (IntSet.singleton v) (IntSet.delete v verts) where nextMap = VMap.fromListWith (++) $ map (\(a,b)->(a,[b])) edges -- search arguments (sets): done (=processed), visited, unvisited.- search done visited unvisited + search done visited unvisited | IntSet.null unvisited = (IntSet.toList visited ++ IntSet.toList done,[]) | IntSet.null visited = (IntSet.toList done, IntSet.toList unvisited) -- any unvisited are not connected | otherwise = search (IntSet.insert x done) (IntSet.union newVs visited') (unvisited IntSet.\\ newVs) where x = IntSet.findMin visited visited' = IntSet.deleteMin visited- newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x + newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x @@ -505,7 +518,7 @@ -- | selecting left kites from a Tgraph lkites = filter isLK . faces -- | selecting right kites from a Tgraph-rkites = filter isRK . faces +rkites = filter isRK . faces -- | selecting half kites from a Tgraph kites = filter isKite . faces -- | selecting half darts from a Tgraph@@ -567,7 +580,7 @@ -- |nonPhiEdges returns a list of the shorter edges of a Tgraph (including dart joins). -- This includes both directions of each edge. nonPhiEdges :: Tgraph -> [Dedge]-nonPhiEdges = bothDir . concatMap faceNonPhiEdges . faces +nonPhiEdges = bothDir . concatMap faceNonPhiEdges . faces -- | graphEFMap g - is a mapping associating with each directed edge of g, the unique TileFace with that directed edge. -- This is more efficient than using dedgesFacesMap for the complete mapping.@@ -632,7 +645,7 @@ indexV :: Vertex -> TileFace -> Int indexV v face = case elemIndex v (faceVList face) of Just i -> i- _ -> error ("indexV: " ++ show v ++ " not found in " ++ show face) + _ -> 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@@ -652,14 +665,14 @@ _ -> error "prevV: index error" -- |isAtV v f asks if a face f has v as a vertex-isAtV:: Vertex -> TileFace -> Bool +isAtV:: Vertex -> TileFace -> Bool isAtV v (LD(a,b,c)) = v==a || v==b || v==c isAtV v (RD(a,b,c)) = v==a || v==b || v==c isAtV v (LK(a,b,c)) = v==a || v==b || v==c isAtV v (RK(a,b,c)) = v==a || v==b || v==c -- |hasVIn vs f - asks if face f has an element of vs as a vertex-hasVIn:: [Vertex] -> TileFace -> Bool +hasVIn:: [Vertex] -> TileFace -> Bool hasVIn vs face = not $ null $ faceVList face `intersect` vs @@ -714,7 +727,7 @@ -- 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 (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)@@ -725,7 +738,7 @@ -- which is long edges for darts, and join and long edges for kites facePhiEdges face@(RD _) = [e, reverseD e] where e = longE face facePhiEdges face@(LD _) = [e, reverseD e] where e = longE face-facePhiEdges face = [e, reverseD e, j, reverseD j] +facePhiEdges face = [e, reverseD e, j, reverseD j] where e = longE face j = joinE face @@ -789,7 +802,7 @@ seekR (a,b) = case VMap.lookup b vmap of Nothing -> False Just vs -> a `elem` vs- + revUnmatched [] = [] revUnmatched (e@(a,b):more) | seekR e = revUnmatched more | otherwise = (b,a):revUnmatched more@@ -812,7 +825,14 @@ insertf vfmap f = foldr (VMap.alter addf) vfmap (faceVList f) where addf Nothing = Nothing addf (Just fs) = Just (f:fs)-+{- + insertf vfmap f = h x1 (h x2 (h x3 vfmap)) where+ (x1,x2,x3) = faceVs f+ h = VMap.alter addf+ addf Nothing = Nothing+ addf (Just fs) = Just (f:fs)+ -}+ -- | dedgesFacesMap des fcs - Produces an edge-face map. Each directed edge in des is associated with -- a unique TileFace in fcs that has that directed edge (if there is one). -- It will report an error if more than one TileFace in fcs has the same directed edge in des. @@ -824,7 +844,7 @@ vfMap = vertexFacesMap vs fcs assocFaces [] = [] assocFaces (d@(a,b):more) = case (VMap.lookup a vfMap, VMap.lookup b vfMap) of- (Just fcs1, Just fcs2) -> case filter (`hasDedge` d) $ fcs1 `intersect` fcs2 of + (Just fcs1, Just fcs2) -> case filter (`hasDedge` d) $ fcs1 `intersect` fcs2 of [face] -> (d,face):assocFaces more [] -> assocFaces more _ -> error $ "dedgesFacesMap: more than one Tileface has the same directed edge: "@@ -850,7 +870,7 @@ edgeNbs:: TileFace -> Map.Map Dedge TileFace -> [TileFace] edgeNbs face efMap = mapMaybe getNbr edges where getNbr e = Map.lookup e efMap- edges = fmap reverseD $ faceDedges face+ edges = reverseD <$> faceDedges face -- |For a non-empty list of tile faces -- find the face with lowest originV (and then lowest oppV).@@ -899,7 +919,7 @@ -- |Make VPatch Transformable.-instance Transformable VPatch where +instance Transformable VPatch where transform t vp = vp {vLocs = VMap.map (transform t) (vLocs vp)} @@ -917,14 +937,14 @@ -- and also for larger scale faces which use the same vertex to point assignment (e.g in compositions). -- The vertex location map is not changed (see also relevantVP and restrictVP). subVP:: VPatch -> [TileFace] -> VPatch-subVP vp fcs = vp {vpFaces = fcs} +subVP vp fcs = vp {vpFaces = fcs} -- | removes locations for vertices not used in the faces of a VPatch. -- (Useful when restricting which labels get drawn). -- relevantVP vp will raise an error if any vertex in the faces of vp is not a key in the location map of vp. relevantVP :: VPatch -> VPatch-relevantVP vp - | null diffList = vp{vLocs = locVs} +relevantVP vp+ | null diffList = vp{vLocs = locVs} | otherwise = error $ "relevantVP: missing locations for: " ++ show diffList ++ "\n" where@@ -970,7 +990,7 @@ locations = vLocs vp convert face = case (VMap.lookup (originV face) locations , VMap.lookup (oppV face) locations) of (Just p, Just p') -> fmap (const (p' .-. p)) face `at` p -- using HalfTile functor fmap- _ -> error $ "dropLabels: Vertex location not found for some vertices:\n " + _ -> error $ "dropLabels: Vertex location not found for some vertices:\n " ++ show (faceVList face \\ VMap.keys locations) ++ "\n" -- |Tgraphs are Drawable@@ -983,7 +1003,7 @@ -- Measures are defined in Diagrams. In particular: tiny, verySmall, small, normal, large, veryLarge, huge. class DrawableLabelled a where -- labelColourSize :: DrawableLabelled a => Colour Double -> Measure Double -> (Patch -> Diagram B) -> a -> Diagram B- labelColourSize :: OKBackend b => + labelColourSize :: OKBackend b => Colour Double -> Measure Double -> (Patch -> Diagram b) -> a -> Diagram b -- The argument type of the draw function is Patch rather than VPatch, which prevents labelling twice. @@ -999,12 +1019,12 @@ labelColourSize c r d = labelColourSize c r d . makeVP -- | Default Version of labelColourSize with colour red. Example usage: labelSize tiny draw a , labelSize normal drawj a-labelSize :: (OKBackend b, DrawableLabelled a) => +labelSize :: (OKBackend b, DrawableLabelled a) => Measure Double -> (Patch -> Diagram b) -> a -> Diagram b labelSize = labelColourSize red -- | Default Version of labelColourSize using red and small (rather than normal label size). Example usage: labelled draw a , labelled drawj a-labelled :: (OKBackend b, DrawableLabelled a) => +labelled :: (OKBackend b, DrawableLabelled a) => (Patch -> Diagram b) -> a -> Diagram b labelled = labelColourSize red small --(normalized 0.023) @@ -1016,7 +1036,7 @@ -- |center a VPatch on a particular vertex. (Raises an error if the vertex is not in the VPatch vertices) centerOn :: Vertex -> VPatch -> VPatch-centerOn a vp = +centerOn a vp = case findLoc a vp of Just loca -> translate (origin .-. loca) vp _ -> error $ "centerOn: vertex not found (Vertex " ++ show a ++ ")\n"@@ -1024,10 +1044,10 @@ -- |alignXaxis takes a vertex pair (a,b) and a VPatch vp -- for centering vp on a and rotating the result so that b is on the positive X axis. -- (Raises an error if either a or b are not in the VPatch vertices)-alignXaxis :: (Vertex, Vertex) -> VPatch -> VPatch +alignXaxis :: (Vertex, Vertex) -> VPatch -> VPatch alignXaxis (a,b) vp = rotate angle newvp where newvp = centerOn a vp- angle = signedAngleBetweenDirs (direction unitX) (direction (locb .-. origin)) + angle = signedAngleBetweenDirs (direction unitX) (direction (locb .-. origin)) locb = case findLoc b newvp of Just l -> l Nothing -> error $ "alignXaxis: second alignment vertex not found (Vertex " ++ show b ++ ")\n"@@ -1036,7 +1056,7 @@ -- For a pair (a,b) the corresponding VPatch is centered on a then b is aligned along the positive x axis. -- The vertex pair list can be shorter than the list of VPatch - the remaining VPatch are left as they are. -- (Raises an error if either vertex in a pair is not in the corresponding VPatch vertices)-alignments :: [(Vertex, Vertex)] -> [VPatch] -> [VPatch] +alignments :: [(Vertex, Vertex)] -> [VPatch] -> [VPatch] alignments [] vps = vps alignments _ [] = error "alignments: Too many alignment pairs.\n" -- non-null list of pairs alignments ((a,b):more) (vp:vps) = alignXaxis (a,b) vp : alignments more vps@@ -1045,7 +1065,7 @@ -- provided both vertices a and b exist in each VPatch in vpList, the VPatch are all aligned -- centred on a, with b on the positive x axis. -- An error is raised if any VPatch does not contain both a and b vertices.-alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch] +alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch] alignAll (a,b) = fmap (alignXaxis (a,b)) -- |alignBefore vfun (a,b) g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis@@ -1058,7 +1078,7 @@ -- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligned on the x-axis. -- Will raise an error if either a or b is not a vertex in g.-makeAlignedVP:: (Vertex,Vertex) -> Tgraph -> VPatch +makeAlignedVP:: (Vertex,Vertex) -> Tgraph -> VPatch makeAlignedVP = alignBefore id @@ -1086,7 +1106,7 @@ VertexLocMap -> Dedge -> Diagram b drawEdge vpMap (a,b) = case (VMap.lookup a vpMap, VMap.lookup b vpMap) of (Just pa, Just pb) -> pa ~~ pb- _ -> error $ "drawEdge: location not found for one or both vertices "++ show(a,b) ++ "\n"+ _ -> error $ "drawEdge: location not found for one or both vertices "++ show (a,b) ++ "\n" @@ -1112,7 +1132,7 @@ and may not yet have known vertex locations. The third argument is the mapping of vertices to points. -}- fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap + fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap fastAddVPoints [] fcOther _ = error $ "locateVertices (fastAddVPoints): Faces not tile-connected: " ++ show fcOther ++ "/n" fastAddVPoints (face:fs) fcOther vpMap = fastAddVPoints (fs++nbs) fcOther' vpMap' where@@ -1128,7 +1148,7 @@ -- It is possible that a newly added location is already in the range of the map (creating a touching vertices), -- so this needs to be checked for. addVPoint:: TileFace -> VertexLocMap -> VertexLocMap-addVPoint face vpMap = +addVPoint face vpMap = case thirdVertexLoc face vpMap of Just (v,p) -> VMap.insert v p vpMap Nothing -> vpMap@@ -1137,14 +1157,14 @@ -- 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)-axisJoin::TileFace -> VertexLocMap -axisJoin face = - VMap.insert (originV face) origin $ VMap.insert (oppV face) (p2(x,0)) VMap.empty where+axisJoin::TileFace -> VertexLocMap+axisJoin face =+ VMap.insert (originV face) origin $ VMap.insert (oppV face) (p2 (x,0)) VMap.empty where x = if isDart face then 1 else phi -- |lookup 3 vertex locations in a vertex to point map. find3Locs::(Vertex,Vertex,Vertex) -> VertexLocMap- -> (Maybe (Point V2 Double),Maybe (Point V2 Double),Maybe (Point V2 Double)) + -> (Maybe (Point V2 Double),Maybe (Point V2 Double),Maybe (Point V2 Double)) find3Locs (v1,v2,v3) vpMap = (VMap.lookup v1 vpMap, VMap.lookup v2 vpMap, VMap.lookup v3 vpMap) {-| thirdVertexLoc face vpMap, where face is a tileface and vpMap associates points with vertices (positions).@@ -1157,7 +1177,7 @@ It now uses signorm to produce vectors of length 1 rather than rely on relative lengths. (Requires ttangle and phi from TileLib). -}-thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double) +thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double) thirdVertexLoc face@(LD _) vpMap = case find3Locs (faceVs face) vpMap of (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1)) (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = signorm (rotate (ttangle 7) (loc3 .-. loc2))@@ -1171,14 +1191,14 @@ (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1)) (Just _ , Just _ , Just _) -> Nothing _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"- + thirdVertexLoc face@(LK _) vpMap = case find3Locs (faceVs face) vpMap of (Just loc1, Just loc2, Nothing) -> Just (oppV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1)) (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2)) (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1)) (Just _ , Just _ , Just _) -> Nothing _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"- + thirdVertexLoc face@(RK _) vpMap = case find3Locs (faceVs face) vpMap of (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v) where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1)) (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2))@@ -1249,7 +1269,7 @@ and may not yet have known vertex locations. The third argument is the mapping of vertices to points. -}- fastAddVPointsGen [] fcOther vpMap | Set.null fcOther = vpMap + fastAddVPointsGen [] fcOther vpMap | Set.null fcOther = vpMap fastAddVPointsGen [] fcOther _ = error $ "fastAddVPointsGen: Faces not tile-connected " ++ show fcOther ++ "\n" fastAddVPointsGen (f:fs) fcOther vpMap = fastAddVPointsGen (fs++nbs) fcOther' vpMap' where nbs = filter (`Set.member` fcOther) (edgeNbsGen f)@@ -1265,7 +1285,7 @@ -- edgeNbsGen:: Map.Map Dedge [TileFace] -> TileFace -> [TileFace] edgeNbsGen f = concat $ mapMaybe getNbrs edges where getNbrs e = Map.lookup e efMapGen- edges = fmap reverseD (faceDedges f) + edges = fmap reverseD (faceDedges f) {- edgeNbsGen efMapGen f = concat $ mapMaybe getNbrs edges where getNbrs e = Map.lookup e efMapGen@@ -1273,6 +1293,6 @@ -} - +
src/TgraphExamples.hs view
@@ -11,8 +11,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TupleSections #-} + module TgraphExamples (-- * Some Layout tools padBorder@@ -21,7 +21,7 @@ , arrangeRows , labelAt -- * Tgraphs for 7 vertex types- , sunGraph + , sunGraph , jackGraph , kingGraph , queenGraph@@ -38,8 +38,8 @@ , sunDs , kiteDs , dartDs- , dartD4 - , sun3Dart + , dartD4+ , sun3Dart -- * Some Simple Figures , foolFig , foolAndFoolD@@ -82,14 +82,14 @@ , boundaryVCoveringFigs , boundaryECoveringFigs , kingECoveringFig- , kingVCoveringFig + , kingVCoveringFig , kingEmpiresFig , kingEmpire1Fig , kingEmpire2Fig -- * Emplace Choices , emplaceChoices , emplaceChoicesFig- + ) where import Diagrams.Prelude@@ -100,7 +100,7 @@ -- |used for most diagrams to give border padding-padBorder :: OKBackend b => +padBorder :: OKBackend b => Diagram b -> Diagram b padBorder = pad 1.2 . centerXY @@ -115,18 +115,18 @@ -- |arrangeRowsGap s n diags - arranges diags into n per row, centering each row horizontally, -- with a seperation gap (horizontally and vertically) of s. -- The result is a single diagram.-arrangeRowsGap :: OKBackend b => +arrangeRowsGap :: OKBackend b => Double -> Int -> [Diagram b] -> Diagram b arrangeRowsGap s n = centerY . vsep s . fmap (centerX . hsep s) . chunks n -- |arrangeRows n diags - arranges diags into n per row, centering each row horizontally. -- The result is a single diagram (seperation is 1 unit vertically and horizontally).-arrangeRows :: OKBackend b => +arrangeRows :: OKBackend b => Int -> [Diagram b] -> Diagram b arrangeRows = arrangeRowsGap 1.0 -- |add a given label at a given point offset from the centre of the given diagram.-labelAt :: OKBackend b => +labelAt :: OKBackend b => Point V2 Double -> String -> Diagram b -> Diagram b labelAt p l d = baselineText l # fontSize (output 15) # moveTo p <> d --labelAt p l d = baselineText l # fontSize (normalized 0.02) # moveTo p <> d@@ -250,13 +250,13 @@ badlyBrokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [vp, vpComp, vpFailed] where vp = makeVP badlyBrokenDart comp = compose badlyBrokenDart- vpComp = restrictVP vp $ faces $ comp- vpFailed = restrictVP vp $ composedFaces comp+ vpComp = restrictVP vp $ faces comp+ vpFailed = restrictVP vp $ (snd . partComposeFaces) comp -- |figure showing the result of removing incomplete tiles (those that do not have their matching halftile) -- to a 3 times decomposed sun. removeIncompletesFig :: OKBackend b => Diagram b-removeIncompletesFig = padBorder $ drawj $ removeFaces (boundaryJoinFaces g) g where +removeIncompletesFig = padBorder $ drawj $ removeFaces (boundaryJoinFaces g) g where g = sunDs !! 3 @@ -283,26 +283,46 @@ jackGraph,kingGraph,queenGraph,aceGraph,deuceGraph,starGraph::Tgraph -- |Tgraph for vertex type jack. jackGraph = makeTgraph+ [LK (7,8,1),RK (7,1,5),LD (9,8,10),RD (9,1,8),LK (1,9,11)+ ,RK (1,11,2),RD (4,6,5),LD (4,5,1),RK (1,3,4),LK (1,2,3)+ ] -- centre 1+{- [LK (1,9,11),RK (1,11,2),LK (7,8,1),RD (9,1,8),RK (1,3,4) ,LK (1,2,3),RK (7,1,5),LD (4,5,1),LD (9,8,10),RD (4,6,5) ] -- centre 1+-} -- |Tgraph for vertex type king. kingGraph = makeTgraph+ [LD (1,10,11),RD (1,9,10),RK (9,7,8),LK (9,1,7),LK (5,6,7)+ ,RK (5,7,1),LD (1,4,5),RD (1,3,4),RD (1,11,2),LD (1,2,3)+ ] -- centre 1+{- [LD (1,2,3),RD (1,11,2),LD (1,4,5),RD (1,3,4),LD (1,10,11) ,RD (1,9,10),LK (9,1,7),RK (9,7,8),RK (5,7,1),LK (5,6,7) ] -- centre 1+-} -- |Tgraph for vertex type queen. queenGraph = makeTgraph+ [RK (11,9,10),LK (11,1,9),LK (7,8,9),RK (7,9,1),RK (7,5,6)+ ,LK (7,1,5),LK (3,4,5),RK (3,5,1),RD (1,11,2),LD (1,2,3)+ ] -- centre 1+{- [LK (7,1,5),RK (3,5,1),LD (1,2,3),RK (7,9,1),LK (11,1,9) ,RD (1,11,2),RK (7,5,6),LK (7,8,9),LK (3,4,5),RK (11,9,10) ] -- centre 1+-} -- |Tgraph for vertex type ace (same as fool). aceGraph = fool -- centre 3 -- |Tgraph for vertextype deuce. deuceGraph = makeTgraph+ [LK (7,8,2),RK (7,2,6),LK (5,6,2),RK (5,2,4)+ ,LD (1,8,9),RD (1,2,8),RD (1,3,4),LD (1,4,2)+ ] -- centre 2+{- [LK (7,8,2),RK (7,2,6),RK (5,2,4),LK (5,6,2),LD (1,4,2) ,RD (1,2,8),RD (1,3,4),LD (1,8,9) ] -- centre 2+-} -- |Tgraph for vertex type star. starGraph = makeTgraph [LD (1,2,3),RD (1,11,2),LD (1,10,11),RD (1,9,10),LD (1,8,9)@@ -368,7 +388,7 @@ boundaryVCoveringFigs :: OKBackend b => BoundaryState -> [Diagram b] boundaryVCoveringFigs bd =- fmap (lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph) $ boundaryVCovering bd+ lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph <$> boundaryVCovering bd where redg = lc red $ draw g --alignBefore draw alig g alig = defaultAlignment g g = recoverGraph bd@@ -378,7 +398,7 @@ boundaryECoveringFigs :: OKBackend b => BoundaryState -> [Diagram b] boundaryECoveringFigs bd =- fmap (lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph) $ boundaryECovering bd+ lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph <$> boundaryECovering bd where redg = lc red $ draw g alig = defaultAlignment g g = recoverGraph bd@@ -407,20 +427,20 @@ emplaceChoicesForced:: Tgraph -> [Tgraph] emplaceChoicesForced g0 | nullGraph g' = chooseUnknowns [(unknowns $ getDartWingInfo g0, g0)]- | otherwise = (force . decompose) <$> emplaceChoicesForced g'+ | otherwise = force . decompose <$> emplaceChoicesForced g' where g' = compose g0 chooseUnknowns :: [([Vertex],Tgraph)] -> [Tgraph] chooseUnknowns [] = [] chooseUnknowns (([],g0):more) = g0:chooseUnknowns more- chooseUnknowns (((u:unks),g0): more)+ chooseUnknowns ((u:unks,g0): more) = chooseUnknowns (map (remainingunks unks) newgs ++ more) where newgs = map recoverGraph $ atLeastOne $ tryDartAndKiteForced (findDartLongForWing u bd) bd bd = makeBoundaryState g0 remainingunks startunks g' = (startunks `intersect` graphBoundaryVs g', g') findDartLongForWing :: Vertex -> BoundaryState -> Dedge- findDartLongForWing v bd + findDartLongForWing v bd = case find isDart (facesAtBV bd v) of Just d -> longE d Nothing -> error $ "findDartLongForWing: dart not found for dart wing vertex " ++ show v
src/Tgraphs.hs view
@@ -16,6 +16,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch+{-# LANGUAGE TupleSections #-} module Tgraphs ( module Tgraph.Prelude@@ -69,7 +70,7 @@ , trySuperForce , singleChoiceEdges -- * Boundary face graph- , tryBoundaryFaceGraph + , tryBoundaryFaceGraph -- * Boundary loops , boundaryLoopsG , boundaryLoops@@ -99,10 +100,11 @@ import Diagrams.Prelude hiding (union) import TileLib -import Data.List (intersect, union, (\\), find, foldl', transpose) +import Data.List (intersect, union, (\\), find, foldl', transpose) 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 qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops+import qualified Data.Maybe (fromMaybe) @@ -115,7 +117,7 @@ -- smart (labelled draw) g -- -- smart (labelSize normal draw) g-smart :: OKBackend b => +smart :: OKBackend b => (VPatch -> Diagram b) -> Tgraph -> Diagram b smart dr g = drawJoinsFor (boundaryJoinFaces g) vp <> dr vp where vp = makeVP g@@ -127,7 +129,7 @@ bdry = makeBoundaryState g -- |given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces.-drawJoinsFor:: OKBackend b => +drawJoinsFor:: OKBackend b => [TileFace] -> VPatch -> Diagram b drawJoinsFor fcs vp = drawWith dashjOnly (subVP vp fcs) @@ -165,7 +167,7 @@ -- (Relies on the vertices of the composition and remainder being subsets of the vertices of g.) drawPCompose :: OKBackend b => Tgraph -> Diagram b-drawPCompose g = +drawPCompose g = restrictSmart g' draw vp <> drawj (subVP vp remainder) # lw medium # lc lime where (remainder,g') = partCompose g@@ -175,8 +177,8 @@ -- It adds dashed join edges on the boundary of g drawForce :: OKBackend b => Tgraph -> Diagram b-drawForce g = - restrictSmart g draw vp # lc red # lw medium +drawForce g =+ restrictSmart g draw vp # lc red # lw medium <> draw vp where vp = makeVP $ force g @@ -188,7 +190,7 @@ drawSuperForce g = (dg # lc red) <> dfg <> (dsfg # lc blue) where fg = force g sfg = superForce fg- vp = makeVP $ sfg+ vp = makeVP sfg dfg = draw $ selectFacesVP vp (faces fg \\ faces g) -- restrictSmart (force g) draw vp dg = restrictSmart g draw vp dsfg = draw $ selectFacesVP vp (faces sfg \\ faces fg)@@ -224,8 +226,6 @@ emphvp = subVP vp (fcs `intersect` faces g) - - -- | An unsound version of composition which defaults to kites when there are choices (unknowns). -- This is unsound in that it can create an incorrect Tgraph from a correct Tgraph. composeK :: Tgraph -> Tgraph@@ -238,12 +238,13 @@ newfaces = map fst compositions -- |compForce is semantically equivalent to (compose . force), i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph).--- However it is more efficient because it omits the check for connected, and no crossing boundaries.+-- However it is more efficient because it omits the check for connected, and no crossing boundaries+-- (and uses getDartWingInfoForced instead of getDartWingInfo) -- This relies on a proof that composition does not need to be checked for a forced Tgraph. -- (We also have a proof that the result must be a forced Tgraph when the initial force succeeds.) compForce:: Tgraph -> Tgraph-compForce = uncheckedCompose . force - +compForce = uncheckedCompose . force+ -- |allCompForce g produces a list of the non-null iterated (forced) compositions of force g. -- It will raise an error if the initial force fails with an incorrect Tgraph. -- The list will be [] if g is the emptyTgraph, otherwise the list begins with force g (when the force succeeds).@@ -303,7 +304,7 @@ boundaryECovering bstate = covers [(bstate, boundaryEdgeSet bstate)] where covers:: [(BoundaryState, Set.Set Dedge)] -> [BoundaryState] covers [] = []- covers ((bs,es):opens) + covers ((bs,es):opens) | Set.null es = bs:covers opens -- bs is a completed cover | otherwise = covers (newcases ++ opens) where (de,des) = Set.deleteFindMin es@@ -329,11 +330,11 @@ startbvs = boundaryVertexSet bd --covers:: [(BoundaryState,Set.Set Dedge)] -> [BoundaryState] covers [] = []- covers ((open,es):opens) + covers ((open,es):opens) | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary open) of Nothing -> open:covers opens- Just dedge -> covers $ fmap (\b -> (b, es)) (atLeastOne $ tryDartAndKiteForced dedge open) ++opens- | otherwise = covers $ fmap (\b -> (b, commonBdry des b)) (atLeastOne $ tryDartAndKiteForced de open) ++opens + Just dedge -> covers $ fmap (,es) (atLeastOne $ tryDartAndKiteForced dedge open) ++opens+ | otherwise = covers $ fmap (\b -> (b, commonBdry des b)) (atLeastOne $ tryDartAndKiteForced de open) ++opens where (de,des) = Set.deleteFindMin es -- | returns the set of boundary vertices of a BoundaryState@@ -344,24 +345,24 @@ internalVertexSet :: BoundaryState -> VertexSet internalVertexSet bd = vertexSet (recoverGraph bd) IntSet.\\ boundaryVertexSet bd - + -- | tryDartAndKiteForced de b - returns the list of (2) results after adding a dart (respectively kite) -- to edge de of a Forcible b and then tries forcing. Each of the results is a Try. tryDartAndKiteForced:: Forcible a => Dedge -> a -> [Try a]-tryDartAndKiteForced de b = - [ onFail ("tryDartAndKiteForced: Dart on edge: " ++ show de ++ "\n") $ +tryDartAndKiteForced de b =+ [ onFail ("tryDartAndKiteForced: Dart on edge: " ++ show de ++ "\n") $ tryAddHalfDart de b >>= tryForce- , onFail ("tryDartAndKiteForced: Kite on edge: " ++ show de ++ "\n") $ + , onFail ("tryDartAndKiteForced: Kite on edge: " ++ show de ++ "\n") $ tryAddHalfKite de b >>= tryForce ] -- | 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. tryDartAndKite:: Forcible a => Dedge -> a -> [Try a]-tryDartAndKite de b = - [ onFail ("tryDartAndKite: Dart on edge: " ++ show de ++ "\n") $ +tryDartAndKite de b =+ [ onFail ("tryDartAndKite: Dart on edge: " ++ show de ++ "\n") $ tryAddHalfDart de b- , onFail ("tryDartAndKite: Kite on edge: " ++ show de ++ "\n") $ + , onFail ("tryDartAndKite: Kite on edge: " ++ show de ++ "\n") $ tryAddHalfKite de b ] @@ -394,7 +395,7 @@ -- at the head, followed by the original faces of g. empire2:: Tgraph -> TrackedTgraph empire2 g = makeTrackedTgraph g0 [fcs, faces g] where- covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" + covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" $ tryForce $ makeBoundaryState g covers2 = concatMap boundaryECovering covers1 -- (g0:others) = fmap recoverGraph covers2@@ -409,7 +410,7 @@ -- similar to empire2, but using boundaryVCovering insrtead of boundaryECovering. empire2Plus:: Tgraph -> TrackedTgraph empire2Plus g = makeTrackedTgraph g0 [fcs, faces g] where- covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" + covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" $ tryForce $ makeBoundaryState g covers2 = concatMap boundaryVCovering covers1 -- (g0:others) = fmap recoverGraph covers2@@ -426,7 +427,7 @@ -- - the common faces. drawEmpire :: OKBackend b => TrackedTgraph -> Diagram b-drawEmpire = +drawEmpire = drawTrackedTgraph [ lw ultraThin . draw , lw thin . fillDK lightgrey lightgrey , lw thin . lc red . draw@@ -462,7 +463,7 @@ trySuperForce = tryFSOp trySuperForceFS where -- |trySuperForceFS - implementation of trySuperForce for force states only trySuperForceFS :: ForceState -> Try ForceState- trySuperForceFS fs = + trySuperForceFS fs = do forcedFS <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $ tryForce fs case singleChoiceEdges $ boundaryState forcedFS of@@ -476,7 +477,7 @@ -- The result is a list of pairs of (edge,label) where edge is a boundary edge with a single choice -- and label indicates the choice as the common face label. singleChoiceEdges :: BoundaryState -> [(Dedge,HalfTileLabel)]-singleChoiceEdges bstate = commonToCovering (boundaryECovering bstate) (boundary bstate) +singleChoiceEdges bstate = commonToCovering (boundaryECovering bstate) (boundary bstate) where -- |commonToCovering bds edgeList - when bds are all the boundary edge covers of some forced Tgraph -- whose boundary edges were edgeList, this looks for edges in edgeList that have the same tile label added in all covers.@@ -488,10 +489,10 @@ common [] [] = [] common [] (_:_) = error "singleChoiceEdges:commonToCovering: label list is longer than edge list" common (_:_) [] = error "singleChoiceEdges:commonToCovering: label list is shorter than edge list"- common (e:more) (ls:lls) = if matchingLabels ls + common (e:more) (ls:lls) = if matchingLabels ls then (e,head ls):common more lls else common more lls- matchingLabels [] = error "singleChoiceEdges:commonToCovering: empty list of labels" + matchingLabels [] = error "singleChoiceEdges:commonToCovering: empty list of labels" matchingLabels (l:ls) = all (==l) ls -- |reportCover bd edgelist - when bd is a boundary edge cover of some forced Tgraph whose boundary edges are edgelist,@@ -500,10 +501,9 @@ reportCover bd des = fmap (tileLabel . getf) des where efmap = dedgesFacesMap des (allFaces bd) -- more efficient than using graphEFMap? -- efmap = graphEFMap (recoverGraph bd)- getf e = maybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e)- id- (faceForEdge e efmap)- + getf e = Data.Maybe.fromMaybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e)+ (faceForEdge e efmap)+ -- |Tries to create a new Tgraph from all faces with a boundary vertex in a Tgraph. -- The resulting faces could have a crossing boundary and also could be disconnected if there is a hole in the starting Tgraph -- so these conditions are checked for, producing a Try result.@@ -515,7 +515,7 @@ -- There will usually be a single trail, but more than one indicates the presence of boundaries round holes. -- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex. -- The trails will have disjoint sets of vertices because of the no-crossing-boundaries condition of Tgraphs.-boundaryLoopsG:: Tgraph -> [[Vertex]] +boundaryLoopsG:: Tgraph -> [[Vertex]] boundaryLoopsG = findLoops . graphBoundary -- | Returns a list of (looping) vertex trails for a BoundaryState.@@ -539,18 +539,18 @@ -- This is repeated until the map is empty, to collect all boundary trials. collectLoops vmap -- | VMap.null vmap = []- | otherwise = chase startV vmap [startV] + | otherwise = chase startV vmap [startV] where (startV,_) = VMap.findMin vmap chase a vm sofar -- sofar is the collected trail in reverse order. = case VMap.lookup a vm of Just b -> chase b (VMap.delete a vm) (b:sofar)- Nothing -> if a == startV + Nothing -> if a == startV then reverse sofar: collectLoops vm -- look for more loops else error $ "findLoops (collectLoops): non looping boundary component, starting at " ++show startV++ " and finishing at "- ++ show a ++ + ++ show a ++ "\nwith loop vertices "++ show (reverse sofar) ++"\n" @@ -558,7 +558,7 @@ -- this will return a (Diagrams) Path for the boundary. It will raise an error if any vertex listed is not a map key. -- (The resulting path can be filled when converted to a diagram.) pathFromBoundaryLoops:: VertexLocMap -> [[Vertex]] -> Path V2 Double-pathFromBoundaryLoops vlocs loops = toPath $ map (locateLoop . map (vlocs VMap.!)) loops where +pathFromBoundaryLoops vlocs loops = toPath $ map (locateLoop . map (vlocs VMap.!)) loops where locateLoop pts = (`at` head pts) $ glueTrail $ trailFromVertices pts @@ -608,7 +608,7 @@ g' <- tryChangeBoundaryWith ugen f $ tgraph ttg return ttg{ tgraph = g' } -- getBoundaryState = getBoundaryState . tgraph- + -- |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@@ -632,9 +632,9 @@ -- |decompose a TrackedTgraph - applies decomposition to all tracked subsets as well as the full Tgraph. -- Tracked subsets get the same numbering of new vertices as the main Tgraph. decomposeTracked :: TrackedTgraph -> TrackedTgraph-decomposeTracked ttg = +decomposeTracked ttg = TrackedTgraph{ tgraph = g' , tracked = tlist}- where + where -- makeTrackedTgraph g' tlist where g = tgraph ttg g' = makeUncheckedTgraph newFaces@@ -643,7 +643,7 @@ tlist = fmap (concatMap (decompFace newVFor)) (tracked ttg) {-* Drawing TrackedTgraphs--} +-} {-| To draw a TrackedTgraph, we use a list of functions each turning a VPatch into a diagram.@@ -688,4 +688,3 @@ -
src/TileLib.hs view
@@ -270,13 +270,13 @@ fillDK c1 c2 = drawWith (fillPieceDK c1 c2) -- |fillKD kcol dcol a - draws and fills a with colour kcol for kites and dcol for darts.--- Note the order D K.+-- Note the order K D. fillKD c1 c2 = fillDK c2 c1 -- |fillMaybeDK c1 c2 a - draws a and maybe fills as well: -- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol -- Nothing indicates no fill for either darts or kites or both--- Note the order K D .+-- Note the order D K. fillMaybeDK :: (Drawable a, OKBackend b) => Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram b fillMaybeDK c1 c2 = drawWith (fillMaybePieceDK c1 c2)