diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/PenroseKiteDart.cabal b/PenroseKiteDart.cabal --- a/PenroseKiteDart.cabal +++ b/PenroseKiteDart.cabal @@ -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 diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs --- a/benchmark/Bench.hs +++ b/benchmark/Bench.hs @@ -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 diff --git a/src/HalfTile.hs b/src/HalfTile.hs --- a/src/HalfTile.hs +++ b/src/HalfTile.hs @@ -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) diff --git a/src/Tgraph/Compose.hs b/src/Tgraph/Compose.hs --- a/src/Tgraph/Compose.hs +++ b/src/Tgraph/Compose.hs @@ -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])] diff --git a/src/Tgraph/Force.hs b/src/Tgraph/Force.hs --- a/src/Tgraph/Force.hs +++ b/src/Tgraph/Force.hs @@ -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 diff --git a/src/Tgraph/Prelude.hs b/src/Tgraph/Prelude.hs --- a/src/Tgraph/Prelude.hs +++ b/src/Tgraph/Prelude.hs @@ -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 @@ -} - + diff --git a/src/TgraphExamples.hs b/src/TgraphExamples.hs --- a/src/TgraphExamples.hs +++ b/src/TgraphExamples.hs @@ -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 diff --git a/src/Tgraphs.hs b/src/Tgraphs.hs --- a/src/Tgraphs.hs +++ b/src/Tgraphs.hs @@ -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 @@ - diff --git a/src/TileLib.hs b/src/TileLib.hs --- a/src/TileLib.hs +++ b/src/TileLib.hs @@ -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)