PenroseKiteDart 1.4 → 1.4.1

raw patch · 9 files changed

+236/−107 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−1
• PenroseKiteDart.cabal +1/−1
• src/HalfTile.hs +1/−1
• src/Tgraph/Compose.hs +5/−5
• src/Tgraph/Decompose.hs +3/−1
• src/Tgraph/Extras.hs +1/−1
• src/Tgraph/Force.hs +175/−87
• src/Tgraph/Prelude.hs +34/−10
• src/Tgraph/Relabelling.hs +3/−0

@@ -1,5 +1,17 @@ # Revision history for PenroseKiteDart ++After 1.4+Force module is now Strict (significantly improves space usage)+(HalfTile, Decompose, Relabelling also made Strict+and Prelude StrictData)++ForceState now an instance of class HasFaces++New: boundaryEdgeFilter+  (used instead of boundaryFilter to simplify UFinders)++ ## version 1.4 -- 2025-6-12  Changed module Tgraphs to module Tgraph.Extras@@ -7,7 +19,7 @@ ### New HasFaces class  Introduced to define common functions for -[TileList], Tgraph, VPatch, BoundaryState, Forced+[TileFace], Tgraph, VPatch, BoundaryState, Forced  Breaking Name Changes for     nullGraph -> nullFaces

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           PenroseKiteDart-version:        1.4+version:        1.4.1 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

@@ -9,7 +9,7 @@ -} {-# LANGUAGE TypeFamilies              #-} -- needed for Transformable Instance {-# LANGUAGE FlexibleInstances         #-} -- needed for Transformable Instance--- {-# LANGUAGE StrictData                #-}+{-# LANGUAGE Strict               #-}  module HalfTile   ( HalfTile(..)

@@ -10,7 +10,7 @@ tryPartCompose, composeF, and partComposeF but also exposes  getDartWingInfo, getDartWingInfoForced (and type DartWingInfo) and composedFaceGroups for debugging and experimenting. -}--- {-# LANGUAGE StrictData             #-} +{-# LANGUAGE StrictData             #-}   module Tgraph.Compose    ( compose@@ -87,7 +87,7 @@ -- 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 $! evalFaces newfaces) where+partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph newfaces) where   (remainder,newfaces) = partComposeFacesF fg  -- |composeF - produces a composed Forced Tgraph from a Forced Tgraph.@@ -101,9 +101,9 @@ -- |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. data DartWingInfo =  DartWingInfo -     { largeKiteCentres  :: ![Vertex]-     , largeDartBases  :: ![Vertex]-     , unknowns :: ![Vertex]+     { largeKiteCentres  :: [Vertex]+     , largeDartBases  :: [Vertex]+     , unknowns :: [Vertex]      , faceMap :: VMap.IntMap [TileFace]       } deriving Show 

@@ -9,7 +9,9 @@ This module defines decompose and decompositions for Tgraphs, but also exposes  two auxiliary functions for debugging and experimenting. -}+ {-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE Strict             #-}  module Tgraph.Decompose   ( decompose@@ -37,7 +39,7 @@ decompose :: Tgraph -> Tgraph decompose g = makeUncheckedTgraph newFaces where     pvmap = phiVMap g-    !newFaces = evalFaces $ concatMap (decompFace pvmap) (faces g)+    newFaces = concatMap (decompFace pvmap) (faces g)  -- |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.

@@ -571,7 +571,7 @@ -- 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-      efmap = dedgesFacesMap des (allFaces bd) -- more efficient than using graphEFMap?+      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)                                     (faceForEdge e efmap)

@@ -10,9 +10,11 @@ such as tryStepForce, tryAddHalfKite and tryAddHalfDart. It introduces BoundaryState and ForceState types and includes a Forcible class with instances for Tgraph, BoundaryState, and ForceState.++The module is made strict (to remove many space leaks). -} -{-# LANGUAGE StrictData             #-} +{-# LANGUAGE Strict            #-}   module Tgraph.Force   ( -- *  Forcible class@@ -129,6 +131,7 @@   , newUpdateGenerator   -- , makeGenerator   , boundaryFilter+  , boundaryEdgeFilter   , makeUpdate --  , hasAnyMatchingE --  , inspectBDedge@@ -137,7 +140,7 @@   -- , tryFindThirdV   , externalAngle -  ,  touchCheck+  , touchCheck    )  where @@ -147,7 +150,7 @@ 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 qualified Data.Maybe(fromMaybe)  -- was used for lazy mustFind only import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate  import Tgraph.Prelude @@ -186,8 +189,7 @@     boundary = boundaryDedges     maxV bd = nextVertex bd - 1 --- |Calculates BoundaryState information from a Tgraph--- also checks for no crossing boundaries as these could cause difficult to trace errors in forcing.+-- |Calculates BoundaryState information from a Tgraph. makeBoundaryState:: Tgraph -> BoundaryState makeBoundaryState g =   let bdes = boundary g@@ -202,22 +204,13 @@       , nextVertex = 1+ maxV g       } -{- -- |TEMP-boundary :: BoundaryState -> [Dedge]-boundary = boundaryDedges- -}+ -- |Converts a BoundaryState back to a Tgraph recoverGraph:: BoundaryState -> Tgraph-recoverGraph = makeUncheckedTgraph . allFaces+recoverGraph = makeUncheckedTgraph . faces  -- |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]@@ -258,6 +251,12 @@                    , updateMap:: UpdateMap                    } deriving (Show) +-- |ForceState is in class HasFaces+instance HasFaces ForceState where+    faces = faces . boundaryState+    boundary = boundary . boundaryState+    maxV = maxV . boundaryState+ {-|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.  @@ -282,8 +281,9 @@     -- | tryFSOpWith (try ForseState Operation with) when given an update generator, generalises a (try) ForceState operation to a (try) Forcible operation.     -- The update generator is only used to initialise a ForceState when there is not one     -- already available (i.e not used when the Forcible is a ForceState)+    --     -- To improve performance of a sequence of force related operations, express each as a-    -- ForceState -> Try ForceState, then use (<=<) or (>=>) to combine and pass to tryFSOpWith.+    -- ForceState -> Try ForceState, then use (\<=\<) or (\>=\>) to combine and pass to tryFSOpWith.     -- This ensures there are no unnecessary conversions between steps.     tryFSOpWith :: UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a     -- | tryInitFSWith (try initialising a ForceState with) when given an update generator tries to create an initial ForceState (ready for forcing) from a Forcible.@@ -383,7 +383,7 @@ tryInitFS = tryInitFSWith defaultAllUGen  -- | initialize a force state with the default UpdateGenerator.--- Raises aan error if it finds a stuck Forcible.+-- Raises an error if it finds a stuck Forcible. initFS :: Forcible a => a -> ForceState initFS = runTry . tryInitFS @@ -562,35 +562,68 @@      (N.B. When a new face is fitted in to a hole with 3 sides there is no new boundary. Hence the need to allow for an empty list.) -} affectedBoundary :: BoundaryState -> [Dedge] -> [Dedge]-affectedBoundary bd [(a,b)] = [(x,a),(a,b),(b,y)] where+affectedBoundary bd [e1@(a,b)] = [e0,e1,e2] where            bdry = boundary bd-           (x,_) = mustFind ((==a).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show a ++ "\n")-           (_,y) = mustFind ((==b).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show b ++ "\n")-affectedBoundary bd [(a,b),(c,d)] | b==c = [(x,a),(a,b),(c,d),(d,y)] where+           e0 = mustFind ((==a).snd) bdry +                  (\()-> error $ "affectedBoundary: boundary edge not found with snd = "+                            ++ show a ++ "\nand edges: " ++ show [e1]+                            ++ "\nwith boundary:\n" ++ show bdry ++ "\n")+           e2 = mustFind ((==b).fst) bdry+                  (\()-> error $ "affectedBoundary: boundary edge not found with fst = "+                            ++ show b ++ "\nand edges: " ++ show [e1]+                            ++ "\nwith boundary:\n" ++ show bdry ++ "\n")+affectedBoundary bd [e1@(a,b),e2@(c,d)] | c==b = [e0,e1,e2,e3] where            bdry = boundary bd-           (x,_) = mustFind ((==a).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show a ++ "\n")-           (_,y) = mustFind ((==d).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show d ++ "\n")-affectedBoundary bd [(a,b),(c,d)] | a==d = [(x,c),(c,d),(a,b),(b,y)] where+           e0 = mustFind ((==a).snd) bdry +                   (\()-> error $ "affectedBoundary (c==b): boundary edge not found with snd = "+                            ++ show a ++ "\nand edges: " ++ show [e1,e2]+                            ++ "\nwith boundary:\n" ++ show bdry ++ "\n")+           e3 = mustFind ((==d).fst) bdry +                   (\()-> error $ "affectedBoundary: boundary edge not found with fst = "+                            ++ show d ++ "\nand edges: " ++ show [e1,e2]+                            ++ "\nwith boundary:\n" ++ show bdry ++ "\n")+affectedBoundary bd [e1@(a,b),e2@(c,d)] | a==d  = [e0,e2,e1,e3] where            bdry = boundary bd-           (x,_) = mustFind ((==c).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show c ++ "\n")-           (_,y) = mustFind ((==b).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show b ++ "\n")-affectedBoundary _ [] = []-affectedBoundary _ edges = error $ "affectedBoundary: unexpected boundary edges " ++ show edges ++ "\n(Either more than 2 or 2 not adjacent)\n"+           e0 = mustFind ((==c).snd) bdry +                   (\()-> error $ "affectedBoundary (a==d): boundary edge not found with snd = "+                            ++ show c ++  "\nand edges: " ++ show [e1,e2]+                            ++ "\nwith boundary:\n" ++ show bdry ++ "\n")+           e3 = mustFind ((==b).fst) bdry +                   (\()-> error $ "affectedBoundary: boundary edge not found with fst = "+                            ++ show b ++  "\nand edges: " ++ show [e1,e2]+                            ++ "\nwith boundary:\n" ++ show bdry ++ "\n")+affectedBoundary _ [] = [] -- case for filling a triangular hole+affectedBoundary _ edges = error $ "affectedBoundary: unexpected boundary edges "+                             ++ show edges ++ "\n(Either more than 2 or 2 not adjacent)\n" -{-| mustFind is an auxiliary function used to search with definite result.++{-| mustFind (older version requires laziness) - an auxiliary function used to search with definite result. mustFind p ls default returns the first item in ls satisfying predicate p and returns default argument when none found (in finite cases). Special case: the default arg may be used to raise an error when nothing is found.--}+ mustFind :: Foldable t => (p -> Bool) -> t p -> p -> p mustFind p ls dflt   = Data.Maybe.fromMaybe dflt (find p ls)+-} +{-| mustFind (strict version) is an auxiliary function used to search with definite result.+mustFind' p ls defaulfnt returns the first item in ls satisfying predicate p and returns+defaultfn () when none found (in finite cases).+This is a replacement foran older mustFind that relied on laziness.+This version works in a strict context.+-}+mustFind :: Foldable t => (p -> Bool) -> t p -> (() -> p) -> p+mustFind p ls dflt+  = case find p ls of+    Just a -> a+    Nothing -> dflt ()+ -- |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 =-  do let umap' = foldr Map.delete umap (removedEdges bdChange)+  do let umap' = foldl' (flip Map.delete) umap (removedEdges bdChange)      umap'' <- applyUG uGen (newBoundaryState bdChange) (revisedEdges bdChange)      return (Map.union umap'' umap') @@ -627,7 +660,7 @@                         ," unsafe updates but ALL unsafe updates are blocked (by touching vertices)\n"                         ,"This should not happen! However it may arise when accuracy limits are reached on very large Tgraphs.\n"                         ,"Total number of faces is "-                        ,show (length $ allFaces bd)+                        ,show (length $ faces bd)                         ,"\n"                         ]   checkBlocked n (u: more) = case checkUnsafeUpdate bd u of@@ -658,6 +691,7 @@                     , bvFacesMap = changeVFMap newface (bvFacesMap bd)                     , bvLocMap = newVPoints                     , allFaces = newface:allFaces bd+                    -- allFaces = newface:faces bd <<<CAUSES SPACE LEAK>>>>                     , nextVertex = v+1                     }        bdChange = BoundaryChange@@ -691,7 +725,7 @@        nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs        resultBd = BoundaryState                    { boundaryDedges = newDedges ++ (boundaryDedges bd \\ matchedDedges)-                   , bvFacesMap = foldr VMap.delete (changeVFMap newface $ bvFacesMap bd) removedBVs+                   , bvFacesMap = foldl' (flip VMap.delete) (changeVFMap newface $ bvFacesMap bd) removedBVs --                   , bvFacesMap = changeVFMap newface (bvFacesMap bd)                    , allFaces = newface:allFaces bd                    , bvLocMap = foldr VMap.delete (bvLocMap bd) removedBVs@@ -710,8 +744,8 @@               ["trySafeUpdate:(incorrect tiling)\nConflicting new face  "               ,show newface               ,"\nwith neighbouring faces\n"-               ,show nbrFaces-               ,"\n"+              ,show nbrFaces+              ,"\n"               ]  @@ -741,7 +775,7 @@ -- (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+    newlocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ faces bd     bvs = fst <$> boundary bd  -- |A version of tryForce that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch.@@ -848,7 +882,7 @@  -- |UChecker (Update checker functions). Given a BoundaryState and a particular tileface (on the boundary), -- such functions try to produce particular updates on the boundary edge of the given tileface.--- [They are called update checkers because they may uncover an incorrect/stuck tiling (using tryFindThirdV)+-- [They are called update checkers because they may uncover an incorrect/stuck tiling -- when creating the update.] -- As an example, addKiteShortE will try to produce an update to add a half-kite with short edge against the boundary. -- Such a function can be used with a UFinder that either returns dart halves with short edge on the boundary@@ -856,9 +890,9 @@ -- (kitesWingDartOrigin in rule 3). 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.- The face predicate takes a BoundaryState bd, a boundary Dedge (a,b) and the TileFace with the edge (b,a)+{-|This is a general purpose filter (previously used to create UFinder functions for each force rule).+ It requires a face predicate where+ the face predicate takes a BoundaryState bd, a boundary Dedge (a,b) and the TileFace with the edge (b,a)  and decides whether the face is wanted or not (True = wanted)  This will be used to filter all the faces at the focus edges   (when given a BoundaryState and list of focus edges).@@ -874,11 +908,29 @@              , predF bd e fc              ] --- |makeUpdate f x constructs a safe update if x is Just .. and an unsafe update if x is Nothing++{-|This is a general purpose filter used to create UFinder functions for each force rule.+ It requires an edgeType and a face predicate.+ The face predicate takes a BoundaryState bd, and a TileFace+ and (assuming the boundary edge of the face matches the given edgeType)+ decides whether the face is wanted or not (True = wanted).+ This will be used to filter all the faces at the focus edges + (when given a BoundaryState and list of focus edges).+ For some predicates the BoundaryState argument is not used (eg boundaryJoin in incompleteHalves), + but for others it is used to look at other faces besides the supplied face + (eg in kitesWingDartOrigin) +-}+boundaryEdgeFilter::  EdgeType -> (BoundaryState -> TileFace -> Bool) -> UFinder+boundaryEdgeFilter etype predF bd focus =+     [ (e,fc) | e <- focus+              , let (fc,etype') = inspectBDedge bd e+              , etype == etype'+              , predF bd fc+              ]++-- |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  @@ -957,15 +1009,16 @@ -} 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)+  genf bd edges = foldl' addU (Right Map.empty) (finder bd edges) where+     addU (Left x) _          = Left x+     addU (Right ump) (e,fc)  = do u <- checker bd fc+                                   return (Map.insert e u ump) -{- {-| makeGenerator (deprecated) this is renamed as newUpdateGenerator. -}+{-  makeGenerator (deprecated) this is renamed as newUpdateGenerator. makeGenerator :: UChecker -> UFinder -> UpdateGenerator makeGenerator = newUpdateGenerator  -}+ --   Ten Update Generators (with corresponding Finders)  @@ -975,9 +1028,11 @@  -- |Find faces with missing opposite face (mirror face)   incompleteHalves :: UFinder-incompleteHalves = boundaryFilter boundaryJoin where+incompleteHalves = boundaryEdgeFilter Join anyFace where+    anyFace _ _ = True+{- incompleteHalves = boundaryFilter boundaryJoin where     boundaryJoin _ (a,b) fc = joinE fc == (b,a)-+ -}  -- |Update generator for rule (2) aceKiteUpdates :: UpdateGenerator@@ -985,9 +1040,11 @@  -- |Find half darts with boundary short edge nonKDarts :: UFinder-nonKDarts = boundaryFilter bShortDarts where+nonKDarts = boundaryEdgeFilter Short foundDart where+    foundDart _ = isDart+{- nonKDarts = boundaryFilter bShortDarts where     bShortDarts _ (a,b) fc = isDart fc && shortE fc == (b,a)-+ -}  -- |Update generator for rule (3)  -- queen and king vertices add a missing kite half (on a boundary kite short edge)@@ -996,10 +1053,12 @@  -- |Find kites with boundary short edge where the wing is also a dart origin kitesWingDartOrigin :: UFinder-kitesWingDartOrigin = boundaryFilter kiteWDO where+kitesWingDartOrigin = boundaryEdgeFilter Short kiteWDO where+   kiteWDO bd fc = isKite fc && isDartOrigin bd (wingV fc)+{- kitesWingDartOrigin = boundaryFilter kiteWDO where    kiteWDO bd (a,b) fc = shortE fc == (b,a)                          && isKite fc && isDartOrigin bd (wingV fc)-+ -}  {-| Update generator for rule (4)      (for deuce vertices = largeKiteCentres)@@ -1010,27 +1069,31 @@ deuceDartUpdates :: UpdateGenerator deuceDartUpdates = newUpdateGenerator addDartShortE kiteGaps --- |Find kite halves with a short edge on the boundary (a,b) +-- |Find kite halves with a short edge on the boundary  -- 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)+-- at oppV of the kite half. kiteGaps :: UFinder-kiteGaps = boundaryFilter kiteGap where+kiteGaps = boundaryEdgeFilter Short kiteGap where+  kiteGap bd fc = isKite fc && mustbeDeuce bd (oppV fc)+{- kiteGaps = boundaryFilter kiteGap where   kiteGap bd (a,b) fc = shortE fc == (b,a)                         && isKite fc && mustbeDeuce bd (oppV fc)-+ -}  -- |Update generator for rule (5) -- jackDartUpdates - jack vertex add a missing second dart jackDartUpdates :: UpdateGenerator 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+-- |Find kite halves with a short edge on the boundary where oppV must be a jack vertex+-- The function mustbeJack finds if a vertex must be a jack. noTouchingDart :: UFinder-noTouchingDart = boundaryFilter farKOfDarts where+noTouchingDart = boundaryEdgeFilter Short farKOfDarts where+   farKOfDarts bd fc  = isKite fc && mustbeJack bd (oppV fc)+{- noTouchingDart = boundaryFilter farKOfDarts where    farKOfDarts bd (a,b) fc  = shortE fc == (b,a)                               && isKite fc && mustbeJack bd (oppV fc)+ -}  {-| Update generator for rule (6) sunStarUpdates is for vertices that must be either sun or star @@ -1044,14 +1107,19 @@ 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+-- a dart where there are at least 7 dart origins (mustbeStar), or+-- a kite where there are at least 5 kite origins (mustbeSun). almostSunStar :: UFinder-almostSunStar = boundaryFilter multiples57 where+almostSunStar = boundaryEdgeFilter Long multiples57 where+    multiples57 bd fc = +        (isDart fc && mustbeStar bd (originV fc)) ||+        (isKite fc && mustbeSun bd (originV fc))+{- almostSunStar = boundaryFilter multiples57 where     multiples57 bd (a,b) fc = longE fc == (b,a) &&         ((isDart fc && mustbeStar bd (originV fc)) ||          (isKite fc && mustbeSun bd (originV fc))         )+ -}  -- |Update generator for rule (7) -- jack vertices with dart long edge on the boundary - add missing kite top.@@ -1059,53 +1127,70 @@ jackKiteUpdates :: UpdateGenerator 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+-- |Find a boundary long edge of a dart where the wingV is a jack vertex.+-- The function mustbeJack finds if a vertex must be a jack. jackMissingKite :: UFinder-jackMissingKite = boundaryFilter dartsWingDB where+jackMissingKite = boundaryEdgeFilter Long dartsWingDB where+    dartsWingDB bd fc = isDart fc && mustbeJack bd (wingV fc)+{- jackMissingKite = boundaryFilter dartsWingDB where     dartsWingDB bd (a,b) fc = longE fc == (b,a) &&                               isDart fc && mustbeJack bd (wingV fc)-+ -} -- |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 = 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+-- |Find a dart long edge on the boundary where the originV must be a king vertex.+-- The function mustbeKing finds if a vertex must be a king+-- (2 of the 3 darts at the origin plus a kite wing at the origin). kingMissingThirdDart :: UFinder-kingMissingThirdDart = boundaryFilter predicate where+kingMissingThirdDart = boundaryEdgeFilter Long predicate where+    predicate bd fc = isDart fc && mustbeKing bd (originV fc)+{- kingMissingThirdDart = boundaryFilter predicate where     predicate bd (a,b) fc = longE fc == (b,a) &&         isDart fc && mustbeKing bd (originV fc) -+ -} -- |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 = newUpdateGenerator addDartLongE queenMissingDarts --- |Find queen vertices (more than 2 kite wings) with a boundary kite long edge+-- |Find a boundary kite long edge where the wingV must be a queen vertex+-- (more than 2 kite wings at the wingV). queenMissingDarts :: UFinder-queenMissingDarts = boundaryFilter predicate where+queenMissingDarts = boundaryEdgeFilter Long predicate where+    predicate bd fc = isKite fc && length kiteWings >2+           where fcWing = wingV fc+                 kiteWings = filter ((==fcWing) . wingV) $+                             filter isKite $ facesAtBV bd fcWing+{- queenMissingDarts = boundaryFilter predicate where     predicate bd (a,b) fc =         longE fc == (b,a) && isKite fc && length kiteWings >2            where fcWing = wingV fc                  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 = newUpdateGenerator addKiteShortE queenMissingKite --- |Find queen vertices (2 or more kite wings) and a kite short edge on the boundary+-- |Find a kite short edge on the boundary where the wingV must be a queen vertex+-- (more than 2 kite wings at the wingV). queenMissingKite :: UFinder-queenMissingKite = boundaryFilter predicate where+queenMissingKite = boundaryEdgeFilter Short predicate where+    predicate bd fc =+        isKite fc && length kiteWings >2+        where fcWing = wingV fc+              kiteWings = filter ((==fcWing) . wingV) $ filter isKite (facesAtBV bd fcWing)+{- queenMissingKite = boundaryFilter predicate where     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)-+ -}  --  Six Update Checkers @@ -1253,17 +1338,20 @@ -- |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)-inspectBDedge bd e = (face,edgeType (reverseD e) face) where-    face = case facesAtBV bd (fst e) `intersect` facesAtBV bd (snd e) of+inspectBDedge bd (a,b) = (face,edgeType (b,a) face) where+      face = case filter (isAtV a) $ facesAtBV bd b of+             [f] -> f+             _   -> error $ "inspectBDedge: Not a boundary directed edge " ++ show (a,b) ++ "\n"+ {-+     face = case facesAtBV bd a `intersect` facesAtBV bd b of          [f] -> f-         _ -> error $ "inspectBDedge: Not a boundary directed edge " ++ show e ++ "\n"+         _ -> error $ "inspectBDedge: Not a boundary directed edge " ++ show (a,b) ++ "\n"+-}    ---   Auxiliary Functions for adding faces: externalAngle and tryFindThirdV - {- $Additions Note about face additions: @@ -1317,7 +1405,7 @@                    ,":\n"                    ,show (bvFacesMap bd VMap.! b),                     "\nand a total of "-                   ,show (length $ allFaces bd)+                   ,show (length $ faces bd)                    ," faces.\n"                    ]            | bAngle <1 || bAngle >9@@ -1337,7 +1425,7 @@                     ,":\n"                     ,show (bvFacesMap bd VMap.! b)                     ,"\nand a total of "-                    ,show (length $ allFaces bd)+                    ,show (length $ faces bd)                     ," faces.\n"                     ]            | aAngle < n

@@ -20,6 +20,8 @@ {-# LANGUAGE TupleSections             #-} {-# LANGUAGE BangPatterns              #-} +{-# LANGUAGE StrictData             #-}+ module Tgraph.Prelude   ( module HalfTile   , module Try@@ -299,11 +301,15 @@ makeUncheckedTgraph:: [TileFace] -> Tgraph makeUncheckedTgraph = Tgraph --- |force evaluation of a list of faces.-evalFaces :: HasFaces a => a -> [TileFace]-evalFaces = eval . faces where+-- |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+    notpos (x,y,z) = x<1 || y<1 || z<1+{- evalFaces a = eval $ faces a where     eval fcs = find (has0 . tileRep) fcs `seq` fcs     has0 (x,y,z) = x==0 || y==0 || z==0+ -}  {-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties and producing an error if a check fails.@@ -701,11 +707,14 @@  -- |isAtV v f asks if a face f has v as a vertex isAtV:: Vertex -> TileFace -> Bool+isAtV v f = v==a || v==b || v==c+     where (a,b,c) = faceVs f+{-      isAtV v (LD(a,b,c))  =  v==a || v==b || v==c isAtV v (RD(a,b,c))  =  v==a || v==b || v==c isAtV v (LK(a,b,c))  =  v==a || v==b || v==c isAtV v (RK(a,b,c))  =  v==a || v==b || v==c-+ -} -- |hasVIn vs f - asks if face f has an element of vs as a vertex hasVIn:: [Vertex] -> TileFace -> Bool hasVIn vs face = not $ null $ faceVList face `intersect` vs@@ -820,10 +829,15 @@ -- without checking for duplicates. -- Should be used on lists with single directions only. -- If the argument may contain reverse directions, use bothDir to avoid duplicates.-bothDirOneWay:: [Dedge] -> [Dedge]+bothDirOneWay :: [Dedge] -> [Dedge]+bothDirOneWay des = revPlus des where+  revPlus ((a,b):es) = (b,a):revPlus es+  revPlus [] = des+{-  bothDirOneWay [] = [] bothDirOneWay (e@(a,b):es)= e:(b,a):bothDirOneWay es-+ -}+  -- | efficiently finds missing reverse directions from a list of directed edges (using IntMap) missingRevs:: [Dedge] -> [Dedge] missingRevs es = revUnmatched es where@@ -849,10 +863,10 @@ For list of vertices vs and faces from a, create an IntMap from each vertex in vs to a list of those faces in a that are at that vertex. -}-vertexFacesMap:: HasFaces a => [Vertex] -> a-> VertexMap [TileFace]+vertexFacesMap:: HasFaces a => [Vertex] -> a -> VertexMap [TileFace] vertexFacesMap vs = foldl' insertf startVF . faces where     startVF = VMap.fromList $ fmap (,[]) vs-    insertf vfmap f = foldr (VMap.alter addf) vfmap (faceVList f)+    insertf vfmap f = foldl' (flip (VMap.alter addf)) vfmap (faceVList f)                       where addf Nothing = Nothing                             addf (Just fs) = Just (f:fs) @@ -866,6 +880,16 @@    vs = fmap fst des `union` fmap snd des    vfMap = vertexFacesMap vs fcs    assocFaces [] = []+   assocFaces (d@(a,b):more) = +       case filter (liftA2 (&&) (isAtV a) (`hasDedge` d)) (vfMap VMap.! b) of+           [face] -> (d,face):assocFaces more+           []   -> assocFaces more+           _   -> error $ "dedgesFacesMap: more than one Tileface has the same directed edge: "+                          ++ show d ++ "\n"+{- dedgesFacesMap des fcs =  Map.fromList (assocFaces des) where+   vs = fmap fst des `union` fmap snd des+   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                                    [face] -> (d,face):assocFaces more@@ -873,7 +897,7 @@                                    _   -> error $ "dedgesFacesMap: more than one Tileface has the same directed edge: "                                                   ++ show d ++ "\n"       _ -> assocFaces more-+ -}  -- |Build a Map from all directed edges to faces (the unique face containing the directed edge) buildEFMap:: HasFaces a  => a -> Map.Map Dedge TileFace@@ -1313,7 +1337,7 @@     fastAddVPointsGen (f:fs) fcOther vpMap = fastAddVPointsGen (fs++nbs) fcOther' vpMap' where         nbs = filter (`Set.member` fcOther) (edgeNbsGen f) --        nbs = filter (`Set.member` fcOther) (edgeNbsGen efMapGen fc)-        fcOther' = foldr Set.delete fcOther nbs+        fcOther' = foldl' (flip Set.delete) fcOther nbs         vpMap' = addVPoint f vpMap -- Generalises buildEFMap by allowing for multiple faces on a directed edge. -- buildEFMapGen:: [TileFace] -> Map.Map Dedge [TileFace]

@@ -11,6 +11,9 @@ and also a commonFaces operation (a kind of intersection which need not be a Tgraph) and a guided equality check (sameGraph). -}++{-# LANGUAGE Strict            #-} + module Tgraph.Relabelling   ( -- * Assisted Union (and matching) operations     fullUnion