PenroseKiteDart 1.4.1 → 1.4.2
raw patch · 8 files changed
+257/−117 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Tgraph.Compose: [unMapped] :: DartWingInfo -> [TileFace]
+ Tgraph.Compose: partCompFacesFrom :: DartWingInfo -> ([TileFace], [TileFace])
- Tgraph.Compose: DartWingInfo :: [Vertex] -> [Vertex] -> [Vertex] -> IntMap [TileFace] -> DartWingInfo
+ Tgraph.Compose: DartWingInfo :: [Vertex] -> [Vertex] -> [Vertex] -> IntMap [TileFace] -> [TileFace] -> DartWingInfo
Files
- CHANGELOG.md +8/−1
- PenroseKiteDart.cabal +1/−1
- src/Tgraph/Compose.hs +143/−35
- src/Tgraph/Decompose.hs +2/−2
- src/Tgraph/Extras.hs +19/−18
- src/Tgraph/Force.hs +31/−31
- src/Tgraph/Prelude.hs +48/−24
- src/Tgraph/Relabelling.hs +5/−5
CHANGELOG.md view
@@ -1,7 +1,14 @@ # Revision history for PenroseKiteDart -After 1.4+## version 1.4.2 -- 2025-7-1++DartWingInfo has an extra field (unMapped)++Improved composing performance (now a Strict module)+New: partCompFacesFrom (used instead of composeFaceGroups in composing)++## version 1.4.1 -- 2025-6-26 Force module is now Strict (significantly improves space usage) (HalfTile, Decompose, Relabelling also made Strict and Prelude StrictData)
PenroseKiteDart.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: PenroseKiteDart-version: 1.4.1+version: 1.4.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
src/Tgraph/Compose.hs view
@@ -8,9 +8,10 @@ This module includes the main composition operations compose, partCompose, tryPartCompose, composeF, and partComposeF but also exposes -getDartWingInfo, getDartWingInfoForced (and type DartWingInfo) and composedFaceGroups for debugging and experimenting.+getDartWingInfo, getDartWingInfoForced (and type DartWingInfo)+and partCompFacesFrom for debugging and composedFaceGroups for experimenting. -}-{-# LANGUAGE StrictData #-} +{-# LANGUAGE Strict #-} module Tgraph.Compose ( compose@@ -19,6 +20,7 @@ , partComposeF , tryPartCompose -- * Exported auxiliary functions (and type)+ , partCompFacesFrom , partComposeFaces -- , partComposeFacesF , DartWingInfo(..)@@ -27,8 +29,8 @@ , composedFaceGroups ) where -import Data.List ((\\), find, foldl',nub)-import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!))+import Data.List (find, foldl', partition)+import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!),alter,empty) import Data.Maybe (mapMaybe) import qualified Data.IntSet as IntSet (empty,insert,toList,member) @@ -60,7 +62,7 @@ -- It does not assume the given Tgraph is forced. tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) tryPartCompose g = - do let (remainder,newFaces) = partComposeFaces g+ do let (~remainder,newFaces) = partComposeFaces g checked <- onFail "tryPartCompose:\n" $ tryConnectedNoCross newFaces return (remainder,checked) @@ -68,27 +70,30 @@ -- 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+partComposeFaces = partCompFacesFrom . getDartWingInfo+{- partComposeFaces g = (remainder,newfaces) where compositions = composedFaceGroups $ getDartWingInfo g- newfaces = map fst compositions- remainder = faces g \\ concatMap snd compositions-+ newfaces = map fst compositions -- evalFaces $ map fst compositions+ ~remainder = faces g \\ concatMap snd compositions+ -} -- |partComposeFacesF (does the same as partComposeFaces for a Forced Tgraph). -- It produces a pair of the remainder faces (faces which will not compose) -- and the composed faces. partComposeFacesF :: Forced Tgraph -> ([TileFace],[TileFace])-partComposeFacesF fg = (remainder,newfaces) where+partComposeFacesF = partCompFacesFrom . getDartWingInfoForced+{- partComposeFacesF fg = (remainder,newfaces) where compositions = composedFaceGroups $ getDartWingInfoForced fg- newfaces = map fst compositions- remainder = faces (forgetF fg) \\ concatMap snd compositions-+ newfaces = map fst compositions -- evalFaces $ map fst compositions+ ~remainder = faces fg \\ concatMap snd compositions+ -} -- |partComposeF fg - produces a pair consisting of remainder faces (faces from fg which will not compose) -- and a composed (Forced) Tgraph. -- Since fg is a forced Tgraph it does not need a check for validity of the composed Tgraph. -- The fact that the result is also Forced relies on a theorem. partComposeF:: Forced Tgraph -> ([TileFace], Forced Tgraph) partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph newfaces) where- (remainder,newfaces) = partComposeFacesF fg+ (~remainder,newfaces) = partComposeFacesF fg+ -- |composeF - produces a composed Forced Tgraph from a Forced Tgraph. -- Since the argument is a forced Tgraph it does not need a check for validity of the composed Tgraph.@@ -99,12 +104,17 @@ -- |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.+-- Faces at a largeKiteCentre vertex will form kite faces when composed.+-- Faces at a largeDartBase vertex will form dart faces when composed.+-- Faces at an unknown vertex cannot be composed.+-- The record includes a faceMap from dart wings to faces at that vertex.+-- and a list of any faces (necessarily kites) not included in the faceMap (unMapped) data DartWingInfo = DartWingInfo - { largeKiteCentres :: [Vertex]- , largeDartBases :: [Vertex]- , unknowns :: [Vertex]- , faceMap :: VMap.IntMap [TileFace] + { largeKiteCentres :: [Vertex] -- ^ dart wing vertices classified as large kite centres.+ , largeDartBases :: [Vertex] -- ^ dart wing vertices classified as large dart bases.+ , unknowns :: [Vertex] -- ^ unclassified (boundary) dart wing vertices.+ , faceMap :: VMap.IntMap [TileFace] -- ^ a mapping from dart wing vertices to faces at the vertex.+ , unMapped :: [TileFace] -- ^ any faces not at a dart wing vertex (necessarily kites) } deriving Show -- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing,@@ -113,9 +123,9 @@ getDartWingInfo = getDWIassumeF False -- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg and calculates a faceMap for each dart wing,--- returning as DartWingInfo.+-- returning as DartWingInfo. (It can classify quicker knowing the Tgraph is forced.) getDartWingInfoForced :: Forced Tgraph -> DartWingInfo-getDartWingInfoForced fg = getDWIassumeF True ( forgetF fg)+getDartWingInfoForced fg = getDWIassumeF True (forgetF fg) -- | getDWIassumeF isForced g, classifies the dart wings in g and calculates a faceMap for each dart wing,@@ -126,9 +136,59 @@ , largeDartBases = IntSet.toList allDbs , unknowns = IntSet.toList allUnks , faceMap = dwFMap+ , unMapped = unused } where+ (drts,kts) = partition isDart (faces g)+ -- special case of vertexFacesMap for dart wings only+ -- using only relevant vertices where there is a dart wing.+ -- i.e only wings for darts and only oppVs and originVs for kites.+ -- The map is built first from darts, then kites are added.+ (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts -- all kites added to relevant dart wings+ where+ dartWMap = foldl' insertD VMap.empty drts -- all dartwings with 1 or 2 darts each+ insertD vmap f = VMap.alter (addD f) (wingV f) vmap+ addD f Nothing = Just [f]+ addD f (Just fs) = Just (f:fs)+ insertK (vmap,unsd) f = + let op = oppV f+ org = originV f+ in case (VMap.lookup op vmap, VMap.lookup org vmap) of+ (Just _ ,Just _) -> (VMap.alter (addK f) (oppV f) $ VMap.alter (addK f) (originV f) vmap, unsd)+ (Just _ , Nothing) -> (VMap.alter (addK f) (oppV f) vmap, unsd)+ (Nothing, Just _ ) -> (VMap.alter (addK f) (originV f) vmap, unsd)+ (Nothing, Nothing) -> (vmap, f:unsd)++ addK _ Nothing = Nothing -- not added to map if it is not a dart wing vertex+ addK f (Just fs) = Just (f:fs)++{- Previous+ fullMap = foldl' insertK dartWMap kts -- all kites added to relevant dart wings+ dartWMap = foldl' insertD VMap.empty drts -- all dartwings with 1 or 2 darts each+ insertD vmap f = VMap.alter (addD f) (wingV f) vmap+ addD f Nothing = Just [f]+ addD f (Just fs) = Just (f:fs)+ insertK vmap f = VMap.alter (addK f) (oppV f) $ VMap.alter (addK f) (originV f) vmap+ addK _ Nothing = Nothing -- not added to map if it is not a dart wing vertex+ addK f (Just fs) = Just (f:fs)+ -}+++{- OLDER version for dwFMap drts = darts g- dwFMap = vertexFacesMap (nub $ fmap wingV drts) (faces g)+ -- special case of vertexFacesMap for dart wings only+ -- using relevantVs (which can appear at a dart wing)+ dwFMap = foldl' insertf startVF (faces g)+ where+ startVF = VMap.fromList $ (,[]) <$> nub (wingV <$> drts) --wings+ insertf vfmap f = foldl' (flip (VMap.alter addf)) vfmap (relevantVs f)+ where addf Nothing = Nothing+ addf (Just fs) = Just (f:fs)+ relevantVs (LK (a,_,c)) = [a,c]+ relevantVs (RK (a,b,_)) = [a,b]+ relevantVs (LD (_,_,c)) = [c]+ relevantVs (RD (_,b,_)) = [b]+ -}+ --dwFMap = dwFacesMap g (allKcs,allDbs,allUnks) = foldl' processD (IntSet.empty, IntSet.empty, IntSet.empty) drts -- kcs = kite centres of larger kites, -- dbs = dart bases of larger darts,@@ -140,13 +200,12 @@ fcs = dwFMap VMap.! w -- faces at w -- Just fcs = VMap.lookup w dwFMap -- faces at w in- 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 + if w `elem` map 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 (IntSet.insert w kcs,dbs,unks) else + if (w,orig) `elem` map 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+ if isForced || length fcs == 1 then (kcs, dbs, IntSet.insert w unks) else+ case findFarK rd fcs of -- extra inspection only needed for unforced Tgraphs Nothing -> (kcs,dbs,IntSet.insert w unks) -- unknown if incomplete kite attached to short edge of rd Just rk@(RK _) -> case find (matchingShortE rk) fcs of@@ -176,9 +235,9 @@ fcs = dwFMap VMap.! w -- faces at w in 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+ if w `elem` map 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 (IntSet.insert w kcs,dbs,unks) else+ if (w,orig) `elem` map 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@@ -215,14 +274,63 @@ find (matchingJoinE rk) (filter isLK fcs) findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face" +-- |Creates a pair of TileFace lists using dart wing information.+-- The first is the (unused) remainder faces, and the second is the new composed faces.+-- Note the remainder faces come from both unMapped and faces at unknowns.+partCompFacesFrom :: DartWingInfo -> ([TileFace],[TileFace])+partCompFacesFrom dwInfo = (remainder, newFaces) where --- |Creates a list of new composed faces, each paired with a list of old faces (components of the new face)+ remainder = unMapped dwInfo ++ concatMap (faceMap dwInfo VMap.!) (unknowns dwInfo)+ newFaces = newRDs ++ newLDs ++ newRKs ++ newLKs++ newRDs = map makenewRD groupRDs + groupRDs = mapMaybe groupRD (largeDartBases dwInfo)+ makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) + makenewRD _ = error "composedFaceGroups: RD case"+ groupRD v = do fcs <- VMap.lookup v (faceMap dwInfo)+ rd <- find isRD fcs+ lk <- find (matchingShortE rd) fcs+ return [rd,lk]++ newLDs = map makenewLD groupLDs + groupLDs = mapMaybe groupLD (largeDartBases dwInfo) + makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld)+ makenewLD _ = error "composedFaceGroups: LD case"+ groupLD v = do fcs <- VMap.lookup v (faceMap dwInfo)+ ld <- find isLD fcs+ rk <- find (matchingShortE ld) fcs+ return [ld,rk]++ newRKs = map makenewRK groupRKs + groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) + makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk)+ makenewRK _ = error "composedFaceGroups: RK case"+ groupRK v = do fcs <- VMap.lookup v (faceMap dwInfo)+ rd <- find isRD fcs+ lk <- find (matchingShortE rd) fcs+ rk <- find (matchingJoinE lk) fcs+ return [rd,lk,rk]++ newLKs = map makenewLK groupLKs + groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) + makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk)+ makenewLK _ = error "composedFaceGroups: LK case"+ groupLK v = do fcs <- VMap.lookup v (faceMap dwInfo)+ ld <- find isLD fcs+ rk <- find (matchingShortE ld) fcs+ lk <- find (matchingJoinE rk) fcs+ return [ld,rk,lk]++++++-- |(Unused) Creates a list of new composed faces, each paired with a list of old faces (components of the new face) -- using dart wing information.--- Auxiliary function but exported for experimenting. composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])] composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where - faceGroupRDs = fmap (\gp -> (makenewRD gp,gp)) groupRDs + faceGroupRDs = map (\gp -> (makenewRD gp,gp)) groupRDs groupRDs = mapMaybe groupRD (largeDartBases dwInfo) makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) makenewRD _ = error "composedFaceGroups: RD case"@@ -231,7 +339,7 @@ lk <- find (matchingShortE rd) fcs return [rd,lk] - faceGroupLDs = fmap (\gp -> (makenewLD gp,gp)) groupLDs + faceGroupLDs = map (\gp -> (makenewLD gp,gp)) groupLDs groupLDs = mapMaybe groupLD (largeDartBases dwInfo) makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld) makenewLD _ = error "composedFaceGroups: LD case"@@ -240,7 +348,7 @@ rk <- find (matchingShortE ld) fcs return [ld,rk] - faceGroupRKs = fmap (\gp -> (makenewRK gp,gp)) groupRKs + faceGroupRKs = map (\gp -> (makenewRK gp,gp)) groupRKs groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk) makenewRK _ = error "composedFaceGroups: RK case"@@ -250,7 +358,7 @@ rk <- find (matchingJoinE lk) fcs return [rd,lk,rk] - faceGroupLKs = fmap (\gp -> (makenewLK gp,gp)) groupLKs + faceGroupLKs = map (\gp -> (makenewLK gp,gp)) groupLKs groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk) makenewLK _ = error "composedFaceGroups: LK case"
src/Tgraph/Decompose.hs view
@@ -40,7 +40,7 @@ decompose g = makeUncheckedTgraph newFaces where pvmap = phiVMap g newFaces = concatMap (decompFace pvmap) (faces g)-+ -- evaluated = length newFaces `seq` newFaces -- |phiVMap g produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in g. -- Both (a,b) and (b,a) get the same new vertex number. This is used(in decompFace and decompose. -- (Sort is used to fix order of assigned numbers).@@ -51,7 +51,7 @@ newVs = [v+1..v+n] !n = length phiReps !v = maxV g- edgeVMap = Map.fromList $ zip phiReps newVs ++ zip (fmap reverseD phiReps) newVs + edgeVMap = Map.fromList $ zip phiReps newVs ++ zip (map reverseD phiReps) newVs -- |Decompose a face producing new faces. -- This requires an edge to vertex map to get a unique new vertex assigned to each phi edge
src/Tgraph/Extras.hs view
@@ -123,7 +123,7 @@ -- |select the halftile faces of a Tgraph with a join edge on the boundary. -- Useful for drawing join edges only on the boundary. boundaryJoinFaces :: Tgraph -> [TileFace]-boundaryJoinFaces g = fmap snd $ incompleteHalves bdry $ boundary bdry where+boundaryJoinFaces g = map snd $ incompleteHalves bdry $ boundary bdry where bdry = makeBoundaryState g -- |draw boundary join edges of a Tgraph using a given VPatch@@ -241,8 +241,9 @@ changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo , unknowns = [] }- compositions = composedFaceGroups changedInfo- newfaces = map fst compositions+ newfaces = snd $ partCompFacesFrom changedInfo+ -- compositions = composedFaceGroups changedInfo+-- newfaces = map fst compositions -- |compForce is a partial function similar to (compose . force), -- i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph).@@ -319,7 +320,7 @@ | Set.null es = fbs:covers opens -- bs is a completed cover | otherwise = covers (newcases ++ opens) where (de,des) = Set.deleteFindMin es- newcases = fmap (\b -> (b, commonBdry des (forgetF b)))+ newcases = map (\b -> (b, commonBdry des (forgetF b))) (runTry $ tryCheckCasesDKF de fbs) @@ -344,8 +345,8 @@ covers ((open,es):opens) | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary $ forgetF open) of Nothing -> open:covers opens- Just dedge -> covers $ fmap (,es) (runTry $ tryCheckCasesDKF dedge open) ++opens- | otherwise = covers $ fmap (\b -> (b, commonBdry des (forgetF b))) (atLeastOne $ tryDartAndKiteF de (forgetF open)) ++opens+ Just dedge -> covers $ map (,es) (runTry $ tryCheckCasesDKF dedge open) ++opens+ | otherwise = covers $ map (\b -> (b, commonBdry des (forgetF b))) (atLeastOne $ tryDartAndKiteF de (forgetF open)) ++opens where (de,des) = Set.deleteFindMin es @@ -449,7 +450,7 @@ [] -> error "empire1 : no forced boundary covers found\n" (fg0:others) -> makeTrackedTgraph g0 [fcs,faces g] where g0 = forgetF fg0- fcs = foldl' intersect (faces g0) $ fmap g0Intersect others+ fcs = foldl' intersect (faces g0) $ map g0Intersect others de = defaultAlignment g g0Intersect fg1 = commonFaces (g0,de) (forgetF fg1,de) @@ -464,10 +465,10 @@ -- at the head, followed by the original faces of g. empire2:: Tgraph -> TrackedTgraph empire2 g = - case fmap (recoverGraph . forgetF) covers2 of+ case map (recoverGraph . forgetF) covers2 of [] -> error "empire2: empty list of secondary boundary covers found" (g0:others) -> makeTrackedTgraph g0 [fcs, faces g]- where fcs = foldl' intersect (faces g0) $ fmap g0Intersect others+ where fcs = foldl' intersect (faces g0) $ map g0Intersect others g0Intersect g1 = commonFaces (g0,de) (g1,de) where covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n"@@ -481,10 +482,10 @@ -- Raises an error if force g fails with a stuck/incorrect Tgraph. empire2Plus:: Tgraph -> TrackedTgraph empire2Plus g = - case fmap (recoverGraph . forgetF) covers2 of+ case map (recoverGraph . forgetF) covers2 of [] -> error "empire2: empty list of secondary boundary covers found" (g0:others) -> makeTrackedTgraph g0 [fcs, faces g]- where fcs = foldl' intersect (faces g0) $ fmap g0Intersect others+ where fcs = foldl' intersect (faces g0) $ map g0Intersect others g0Intersect g1 = commonFaces (g0,de) (g1,de) where covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n"@@ -558,7 +559,7 @@ -- The result is a list of pairs: edge and a common tile label. -- commonToCovering :: [BoundaryState] -> [Dedge] -> [(Dedge,HalfTileLabel)] commonToCovering bds edgeList = common edgeList (transpose labellists) where- labellists = fmap (`reportCover` edgeList) bds+ labellists = map (`reportCover` edgeList) bds common [] [] = [] common [] (_:_) = error "singleChoiceEdges:commonToCovering: label list is longer than edge list" common (_:_) [] = error "singleChoiceEdges:commonToCovering: label list is shorter than edge list"@@ -570,7 +571,7 @@ -- |reportCover bd edgelist - when bd is a boundary edge cover of some forced Tgraph whose boundary edges are edgelist, -- this returns the tile label for the face covering each edge in edgelist (in corresponding order). -- reportCover :: BoundaryState -> [Dedge] -> [HalfTileLabel]- reportCover bd des = fmap (tileLabel . getf) des where+ reportCover bd des = map (tileLabel . getf) des where efmap = dedgesFacesMap des (faces bd) -- more efficient than using graphEFMap? -- efmap = graphEFMap (recoverGraph bd) getf e = Data.Maybe.fromMaybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e)@@ -654,7 +655,7 @@ -- from trackedlist where each list in trackedlist is a subset of the faces of g. -- Any faces not in g are ignored. makeTrackedTgraph :: Tgraph -> [[TileFace]] -> TrackedTgraph-makeTrackedTgraph g trackedlist = TrackedTgraph{ tgraph = g, tracked = fmap (`intersect` faces g) trackedlist}+makeTrackedTgraph g trackedlist = TrackedTgraph{ tgraph = g, tracked = map (`intersect` faces g) trackedlist} -- |trackFaces ttg - pushes the maingraph tilefaces onto the stack of tracked subsets of ttg trackFaces:: TrackedTgraph -> TrackedTgraph@@ -719,7 +720,7 @@ g' = makeUncheckedTgraph newFaces newVFor = phiVMap g newFaces = concatMap (decompFace newVFor) (faces g)- tlist = fmap (concatMap (decompFace newVFor)) (tracked ttg)+ tlist = map (concatMap (decompFace newVFor)) (tracked ttg) {-* Drawing TrackedTgraphs -}@@ -736,7 +737,7 @@ drawTrackedTgraph drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where vp = makeVP (tgraph ttg) untracked = faces vp \\ concat (tracked ttg)- vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp+ vpList = map (restrictVP vp) (untracked:tracked ttg) ++ repeat vp {-| To draw a TrackedTgraph rotated.@@ -749,7 +750,7 @@ drawTrackedTgraphRotated drawList a ttg = mconcat $ reverse $ zipWith ($) drawList vpList where vp = rotate a $ makeVP (tgraph ttg) untracked = faces vp \\ concat (tracked ttg)- vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp+ vpList = map (restrictVP vp) (untracked:tracked ttg) ++ repeat vp {-| To draw a TrackedTgraph aligned.@@ -763,7 +764,7 @@ drawTrackedTgraphAligned drawList (a,b) ttg = mconcat $ reverse $ zipWith ($) drawList vpList where vp = makeAlignedVP (a,b) (tgraph ttg) untracked = faces vp \\ concat (tracked ttg)- vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp+ vpList = map (restrictVP vp) (untracked:tracked ttg) ++ repeat vp
src/Tgraph/Force.hs view
@@ -193,7 +193,7 @@ makeBoundaryState:: Tgraph -> BoundaryState makeBoundaryState g = let bdes = boundary g- bvs = fmap fst bdes -- (fmap snd bdes would also do) for all boundary vertices+ bvs = map fst bdes -- (map snd bdes would also do) for all boundary vertices bvLocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ faces g in BoundaryState@@ -678,14 +678,14 @@ checkUnsafeUpdate:: BoundaryState -> Update -> Maybe BoundaryChange checkUnsafeUpdate _ (SafeUpdate _) = error "checkUnsafeUpdate: applied to safe update.\n" checkUnsafeUpdate bd (UnsafeUpdate makeFace) =- let v = nextVertex bd- newface = makeFace v+ let !v = nextVertex bd+ !newface = makeFace v oldVPoints = bvLocMap bd newVPoints = addVPoint newface oldVPoints vPosition = newVPoints VMap.! v -- Just vPosition = VMap.lookup v newVPoints fDedges = faceDedges newface matchedDedges = filter (\(x,y) -> x /= v && y /= v) fDedges -- singleton- newDedges = fmap reverseD (fDedges \\ matchedDedges) -- two edges+ newDedges = map reverseD (fDedges \\ matchedDedges) -- two edges resultBd = BoundaryState { boundaryDedges = newDedges ++ (boundary bd \\ matchedDedges) , bvFacesMap = changeVFMap newface (bvFacesMap bd)@@ -721,7 +721,7 @@ 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+ newDedges = map reverseD (fDedges \\ matchedDedges) -- one or none nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs resultBd = BoundaryState { boundaryDedges = newDedges ++ (boundaryDedges bd \\ matchedDedges)@@ -930,7 +930,7 @@ -- |makeUpdate f x constructs a safe update if x is Just(..) and an unsafe update if x is Nothing makeUpdate:: (Vertex -> TileFace) -> Maybe Vertex -> Update-makeUpdate f (Just v) = SafeUpdate (f v)+makeUpdate f (Just v) = fv `seq` SafeUpdate fv where fv = f v makeUpdate f Nothing = UnsafeUpdate f @@ -947,7 +947,7 @@ -- if there is a shared kite short edge at the vertex. mustbeDeuce:: BoundaryState -> Vertex -> Bool mustbeDeuce bd v = isKiteOppV bd v &&- hasAnyMatchingE (fmap shortE $ filter isKite $ facesAtBV bd v)+ hasAnyMatchingE (map shortE $ filter isKite $ facesAtBV bd v) -- |A boundary vertex which is a kite wing and has 4 dart origins must be a king vertex mustbeKing:: BoundaryState -> Vertex -> Bool@@ -962,15 +962,15 @@ -- |isKiteWing bd v - Vertex v is a kite wing in BoundaryState bd isKiteWing:: BoundaryState -> Vertex -> Bool-isKiteWing bd v = v `elem` fmap wingV (filter isKite (facesAtBV bd v))+isKiteWing bd v = v `elem` map wingV (filter isKite (facesAtBV bd v)) -- |isKiteOppV bd v - Vertex v is a kite oppV in BoundaryState bd isKiteOppV:: BoundaryState -> Vertex -> Bool-isKiteOppV bd v = v `elem` fmap oppV (filter isKite (facesAtBV bd v))+isKiteOppV bd v = v `elem` map oppV (filter isKite (facesAtBV bd v)) -- |isDartOrigin bd v - Vertex v is a dart origin in BoundaryState bd isDartOrigin:: BoundaryState -> Vertex -> Bool-isDartOrigin bd v = v `elem` fmap originV (filter isDart (facesAtBV bd v))+isDartOrigin bd v = v `elem` map originV (filter isDart (facesAtBV bd v)) -- |A boundary vertex with >2 kite wings is a queen vertex -- (needing a fourth kite on a kite short edge or dart on a kite long edge)@@ -987,11 +987,11 @@ -- (false means it is either undetermined or is a deuce). 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 == 2 && not (hasAnyMatchingE (map longE dWings))) || -- 2 dart wings and dart long edges not shared. (length dWings == 1 && isKiteOrigin) where fcs = facesAtBV bd v dWings = filter ((==v) . wingV) $ filter isDart fcs- isKiteOrigin = v `elem` fmap originV (filter isKite fcs)+ isKiteOrigin = v `elem` map originV (filter isKite fcs) -- |hasMatching asks if a directed edge list has any two matching (=opposing) directed edges. hasAnyMatchingE :: [Dedge] -> Bool@@ -1199,40 +1199,40 @@ -- add a symmetric (mirror) face for a given face at a boundary join edge. completeHalf :: UChecker completeHalf bd (LD(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = RD (a,v,b)+ makeFace !v = makeRD a v b --RD (a,v,b) x = tryFindThirdV bd (b,a) (3,1) --anglesForJoinRD completeHalf bd (RD(a,_,b)) = makeUpdate makeFace <$> x where- makeFace v = LD (a,b,v)+ makeFace !v = makeLD a b v --LD (a,b,v) x = tryFindThirdV bd (a,b) (1,3) --anglesForJoinLD completeHalf bd (LK(a,_,b)) = makeUpdate makeFace <$> x where- makeFace v = RK (a,b,v)+ makeFace !v = makeRK a b v --RK (a,b,v) x = tryFindThirdV bd (a,b) (1,2) --anglesForJoinRK completeHalf bd (RK(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = LK (a,v,b)+ makeFace !v = makeLK a v b --LK (a,v,b) x = tryFindThirdV bd (b,a) (2,1) --anglesForJoinLK -- |add a (missing) half kite on a (boundary) short edge of a dart or kite addKiteShortE :: UChecker addKiteShortE bd (RD(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = LK (v,c,b)+ makeFace !v = makeLK v c b --LK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK addKiteShortE bd (LD(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = RK (v,c,b)+ makeFace !v = makeRK v c b --RK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = RK (v,c,b)+ makeFace !v = makeRK v c b --RK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = LK (v,c,b)+ makeFace !v = makeLK v c b --LK (v,c,b) x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK -- |add a half dart top to a boundary short edge of a half kite. addDartShortE :: UChecker addDartShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = LD (v,c,b)+ makeFace !v = makeLD v c b --LD (v,c,b) x = tryFindThirdV bd (c,b) (3,1) --anglesForShortLD addDartShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where- makeFace v = RD (v,c,b)+ makeFace !v = makeRD v c b --RD (v,c,b) x = tryFindThirdV bd (c,b) (1,3) --anglesForShortRD addDartShortE _ _ = error "addDartShortE applied to non-kite face\n" @@ -1245,31 +1245,31 @@ -- |add a kite to a long edge of a dart or kite addKiteLongE :: UChecker addKiteLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = RK (c,v,a)+ makeFace !v = makeRK c v a --RK (c,v,a) x = tryFindThirdV bd (a,c) (2,1) -- anglesForLongRK addKiteLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = LK (b,a,v)+ makeFace !v = makeLK b a v --LK (b,a,v) x = tryFindThirdV bd (b,a) (1,2) -- anglesForLongLK addKiteLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = LK (a,c,v)+ makeFace !v = makeLK a c v --LK (a,c,v) x = tryFindThirdV bd (a,c) (1,2) -- anglesForLongLK addKiteLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = RK (a,v,b)+ makeFace !v = makeRK a v b --RK (a,v,b) x = tryFindThirdV bd (b,a) (2,1) -- anglesForLongRK -- |add a half dart on a boundary long edge of a dart or kite addDartLongE :: UChecker addDartLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = RD (a,c,v)+ makeFace !v = makeRD a c v --RD (a,c,v) x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongRD addDartLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = LD (a,v,b)+ makeFace !v = makeLD a v b --LD (a,v,b) x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongLD addDartLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where- makeFace v = RD (b,a,v)+ makeFace !v = makeRD b a v --RD (b,a,v) x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongRD addDartLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where- makeFace v = LD (c,v,a)+ makeFace !v = makeLD c v a --LD (c,v,a) x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongLD {-@@ -1303,7 +1303,7 @@ -- boundary edges the result is a single Left, concatenating all the failure reports (unlike allUGenerator). defaultAllUGen :: UpdateGenerator defaultAllUGen = UpdateGenerator { applyUG = gen } where- gen bd es = combine $ fmap decide es where -- Either String is a monoid as well as Map+ gen bd es = combine $ map decide es where -- Either String is a monoid as well as Map decide e = decider (e,f,etype) where (f,etype) = inspectBDedge bd e decider (e,f,Join) = mapItem e (completeHalf bd f) -- rule 1
src/Tgraph/Prelude.hs view
@@ -87,6 +87,7 @@ , removeVertices , selectVertices , vertexFacesMap+ --, dwFacesMap -- * Other Face/Vertex Operations , makeRD , makeLD@@ -286,7 +287,7 @@ -- |renumberFaces allows for a many to 1 relabelling represented by a list of pairs. -- It is used only for tryCorrectTouchingVs in Tgraphs which then checks the result renumberFaces :: [(Vertex,Vertex)] -> [TileFace] -> [TileFace]-renumberFaces prs = fmap renumberFace where+renumberFaces prs = map renumberFace where mapping = VMap.fromList $ differing prs renumberFace = fmap (all3 renumber) all3 f (a,b,c) = (f a,f b,f c)@@ -304,9 +305,11 @@ -- |force full evaluation of a list of faces. evalFaces :: HasFaces a => a -> a evalFaces a = b where- !b = find (notpos . tileRep) (faces a) `seq` a+ !b = find (ev . faceVs) (faces a) `seq` a+ ev (x,y,z) = x `seq` y `seq` z `seq` False+{- !b = find (notpos . faceVs) (faces a) `seq` a notpos (x,y,z) = x<1 || y<1 || z<1-{- evalFaces a = eval $ faces a where+ -}{- evalFaces a = eval $ faces a where eval fcs = find (has0 . tileRep) fcs `seq` fcs has0 (x,y,z) = x==0 || y==0 || z==0 -}@@ -336,7 +339,7 @@ tryTgraphProps:: [TileFace] -> Try Tgraph tryTgraphProps [] = Right emptyTgraph tryTgraphProps fcs- | hasEdgeLoops fcs = + | hasEdgeLoops fcs = failReport $ "tryTgraphProps: Non-valid tile-face(s)\n" ++ "Edge Loops at: " ++ show (findEdgeLoops fcs) ++ "\n" | illegalTiling fcs = failReports@@ -542,7 +545,7 @@ -- May have duplicates when applied to an arbitrary list of TileFace. -- but no duplicates for Tgraph, VPatch, BoundaryState, Forced, TrackedTgraph. boundaryVs :: HasFaces a => a -> [Vertex]-boundaryVs = fmap fst . boundary+boundaryVs = map fst . boundary -- |get all the directed edges (directed clockwise round each face) dedges :: HasFaces a => a -> [Dedge]@@ -550,7 +553,7 @@ -- |get the set of vertices in the faces vertexSet :: HasFaces a => a -> VertexSet-vertexSet = mconcat . fmap faceVSet . faces+vertexSet = mconcat . map faceVSet . faces -- |A list of tilefaces is in class HasFaces instance HasFaces [TileFace] where@@ -606,7 +609,7 @@ -- |internal edges are shared by two faces. That is, all edges except those at the boundary. -- Both directions of each internal directed edge will appear in the result. internalEdges :: HasFaces a => a -> [Dedge]-internalEdges a = des \\ fmap reverseD (missingRevs des) where+internalEdges a = des \\ map reverseD (missingRevs des) where des = dedges a -- |phiEdges returns a list of the longer (phi-length) edges in the faces (including kite joins).@@ -628,13 +631,13 @@ makeRD,makeLD,makeRK,makeLK :: Vertex -> Vertex -> Vertex -> TileFace -- |make an RD (strict in arguments)-makeRD !x !y !z = RD(x,y,z)+makeRD !x !y !z = RD (x,y,z) -- |make an LD (strict in arguments)-makeLD !x !y !z = LD(x,y,z)+makeLD !x !y !z = LD (x,y,z) -- |make an RK (strict in arguments)-makeRK !x !y !z = RK(x,y,z)+makeRK !x !y !z = RK (x,y,z) -- |make an LK (strict in arguments)-makeLK !x !y !z = LK(x,y,z)+makeLK !x !y !z = LK (x,y,z) -- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace {-# Inline faceVs #-}@@ -837,7 +840,7 @@ bothDirOneWay [] = [] bothDirOneWay (e@(a,b):es)= e:(b,a):bothDirOneWay es -}- + -- | efficiently finds missing reverse directions from a list of directed edges (using IntMap) missingRevs:: [Dedge] -> [Dedge] missingRevs es = revUnmatched es where@@ -855,7 +858,7 @@ -- |two tile faces are edge neighbours edgeNb::TileFace -> TileFace -> Bool edgeNb face = any (`elem` edges) . faceDedges where- edges = fmap reverseD (faceDedges face)+ edges = map reverseD (faceDedges face) @@ -865,11 +868,32 @@ -} vertexFacesMap:: HasFaces a => [Vertex] -> a -> VertexMap [TileFace] vertexFacesMap vs = foldl' insertf startVF . faces where- startVF = VMap.fromList $ fmap (,[]) vs+ startVF = VMap.fromList $ map (,[]) vs insertf vfmap f = foldl' (flip (VMap.alter addf)) vfmap (faceVList f) where addf Nothing = Nothing addf (Just fs) = Just (f:fs) +{-|dwFacesMap - a special case of vertexFacesMap applied to the dart wing vertices.+Create an IntMap from each dart wing vertex to a list of those faces that are at that vertex.+It makes use of the fact that only kite opps and kite origins and dart wings can+occur at a dart wing++dwFacesMap:: HasFaces a => a -> VertexMap [TileFace]+dwFacesMap g = foldl' insertf startVF (faces g) where+ vs = nub (wingV <$> darts g)+ startVF = VMap.fromList $ fmap (,[]) vs+ insertf vfmap f = foldl' (flip (VMap.alter addf)) vfmap (relevantVs f)+ where addf Nothing = Nothing+ addf (Just fs) = Just (f:fs)++ relevantVs :: TileFace -> [Vertex]+ relevantVs (LK (a,_,c)) = [a,c]+ relevantVs (RK (a,b,_)) = [a,b]+ relevantVs (LD (_,_,c)) = [c]+ relevantVs (RD (_,b,_)) = [b]+-}++ -- | dedgesFacesMap des a - Produces an edge-face map. Each directed edge in des is associated with -- a unique face in a that has that directed edge (if there is one). -- It will report an error if more than one face in a has the same directed edge in des. @@ -877,10 +901,10 @@ -- dedgesFacesMap is intended for a relatively small subset of directed edges in a Tgraph. dedgesFacesMap:: HasFaces a => [Dedge] -> a -> Map.Map Dedge TileFace dedgesFacesMap des fcs = Map.fromList (assocFaces des) where- vs = fmap fst des `union` fmap snd des+ vs = map fst des `union` map snd des vfMap = vertexFacesMap vs fcs assocFaces [] = []- assocFaces (d@(a,b):more) = + assocFaces (d@(a,b):more) = case filter (liftA2 (&&) (isAtV a) (`hasDedge` d)) (vfMap VMap.! b) of [face] -> (d,face):assocFaces more [] -> assocFaces more@@ -902,7 +926,7 @@ -- |Build a Map from all directed edges to faces (the unique face containing the directed edge) buildEFMap:: HasFaces a => a -> Map.Map Dedge TileFace buildEFMap = Map.fromList . concatMap assignFace . faces where- assignFace f = fmap (,f) (faceDedges f)+ assignFace f = map (,f) (faceDedges f) -- | look up a face for an edge in an edge-face map faceForEdge :: Dedge -> Map.Map Dedge TileFace -> Maybe TileFace@@ -925,9 +949,9 @@ getLJ fcs | null fcs = error "extractLowestJoin: applied to empty list of faces" | otherwise = (face, fcs\\[face])- where a = minimum (fmap originV fcs)+ where a = minimum (map originV fcs) aFaces = filter ((a==) . originV) fcs- b = minimum (fmap oppV aFaces)+ b = minimum (map oppV aFaces) face = case find (((a,b)==) . joinOfTile) aFaces of Just f -> f Nothing -> error $ "extractLowestJoin: no face found at "@@ -940,9 +964,9 @@ lowestJoin = lowest . faces where lowest fcs | null fcs = error "lowestJoin: applied to empty list of faces" lowest fcs = (a,b) where- a = minimum (fmap originV fcs)+ a = minimum (map originV fcs) aFaces = filter ((a==) . originV) fcs- b = minimum (fmap oppV aFaces)+ b = minimum (map oppV aFaces) {--------------------- *********************@@ -1038,7 +1062,7 @@ -- |converts a VPatch to a Patch, removing vertex information and converting faces to Located Pieces. -- (Usage can be confined to Drawable VPatch instance and DrawableLabelled VPatch instance.) dropLabels :: VPatch -> Patch-dropLabels vp = fmap convert (faces vp) where+dropLabels vp = map convert (faces vp) where locations = vLocs vp convert face = case (VMap.lookup (originV face) locations , VMap.lookup (oppV face) locations) of (Just p, Just p') -> fmap (const (p' .-. p)) face `at` p -- using HalfTile functor fmap@@ -1118,7 +1142,7 @@ -- centred on a, with b on the positive x axis. -- An error is raised if any VPatch does not contain both a and b vertices. alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch]-alignAll (a,b) = fmap (alignXaxis (a,b))+alignAll (a,b) = map (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 -- before applying the VPatch function vfun@@ -1348,7 +1372,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 = map reverseD (faceDedges f) {- edgeNbsGen efMapGen f = concat $ mapMaybe getNbrs edges where getNbrs e = Map.lookup e efMapGen
src/Tgraph/Relabelling.hs view
@@ -90,8 +90,8 @@ then return $ makeUncheckedTgraph fcs -- no properties check needed! else let vertg1 = vertexSet g1 correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e- newrel = newRelabelling $ fmap correct touchVs- in tryTgraphProps $ nub $ fmap (relabelFace newrel) fcs+ newrel = newRelabelling $ map correct touchVs+ in tryTgraphProps $ nub $ map (relabelFace newrel) fcs -- | commonFaces (g1,e1) (g2,e2) relabels g2 to match with g1 (where they match)@@ -106,7 +106,7 @@ g3 = relabelToMatchIgnore (g1,e1) (g2,e2) fcs = faces g1 `union` faces g3 touchVs = touchingVerticesGen fcs -- requires generalised version of touchingVertices- relFaces = fmap (relabelFace $ newRelabelling $ fmap correct touchVs) (faces g3)+ relFaces = map (relabelFace $ newRelabelling $ map correct touchVs) (faces g3) vertg1 = vertexSet g1 correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e @@ -299,13 +299,13 @@ -- (See also checkRelabelGraph) relabelGraph:: Relabelling -> Tgraph -> Tgraph relabelGraph rlab g = makeUncheckedTgraph newFaces where- newFaces = fmap (relabelFace rlab) (faces g) + newFaces = map (relabelFace rlab) (faces g) -- |checkRelabelGraph uses a relabelling map to change vertices in a Tgraph, -- then checks that the result is a valid Tgraph. (see also relabelGraph) checkRelabelGraph:: Relabelling -> Tgraph -> Tgraph checkRelabelGraph rlab g = checkedTgraph newFaces where- newFaces = fmap (relabelFace rlab) (faces g) + newFaces = map (relabelFace rlab) (faces g) -- |Uses a relabelling to relabel the three vertices of a face. -- Any vertex not in the domain of the mapping is left unchanged.