PenroseKiteDart 1.7 → 1.8

raw patch · 12 files changed

+446/−460 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−0
• PenroseKiteDart.cabal +1/−1
• src/HalfTile.hs +4/−4
• src/Tgraph/Compose.hs +12/−11
• src/Tgraph/Decompose.hs +4/−4
• src/Tgraph/Extras.hs +130/−132
• src/Tgraph/Force.hs +157/−231
• src/Tgraph/Grid.hs +9/−3
• src/Tgraph/Prelude.hs +75/−45
• src/TgraphExamples.hs +21/−20
• src/TileLib.hs +6/−6
• test/Spec.hs +3/−3

@@ -1,5 +1,29 @@ # Revision history for PenroseKiteDart ++## version v1.8++- Possibly breaking change: The ForceState now carries an UpdateGenerator and Forcible class operations now assume defaultAllUGen or take the UpdateGenerator from the ForceState.+The Forcible class operations are now+  - tryInitFS (replacing tryInitFSWith)+  - tryFSOp (replacing tryFSOpWith, but tryFSOpWith is now defined in terms of tryFSOp.)+  - tryChangeBoundary (replacing tryChangeBoundaryWith)++  - No longer Exported: tryReviseUpdates, tryReviseFSWith, tryOneStepWith, tryInitFSWith, tryChangeBoundaryWith, tryDartAndKiteF, tryDartAndKiteForced, checkCasesDKF++- Other changes:+  - Introduced class HasGraph (instances Tgraph, BoundaryState, ForceState, and Forced versions of these)+  - Generalised recoverGraph (and many other functions now using HasGraph such as compose, decompose,...)+  - Reinstated nullGraph (with HasGraph constraint)+  - Introduced withForced, alignedVP, rotatedVP++  - Deprecated tryOneStepForce (RENAMED as tryOneStep) +  - Deprecated recoverGraphF, boundaryStateF, makeBoundaryStateF, initFSF (now using withForced)+  - Deprecated makeAlignedVP (renamed as alignedVP)+  - Deprecated alignAll (use (map . alignXaxis))+  - superForce now produces Forced Tgraph (compose with forgetF to obtain Tgraph)++ ## version v1.7  Significant speed up of forcing.

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

@@ -1,6 +1,6 @@ {-| Module      : HalfTile-Description : Introducing a generic type for half tiles of darts and kites+Description : Introducing a (polymorphic) type for half tiles of darts and kites Copyright   : (c) Chris Reade, 2021 License     : BSD-style Maintainer  : chrisreade@mac.com@@ -29,8 +29,8 @@ import qualified Control.Monad (void) -- used for tileLabel  {-|-Representing Half Tile Pieces Polymorphicly.-Common code for both graphs and vector representations of tilings. +Representing half tile pieces polymorphicly.+The type parameter (rep) is specialised for graphs and vector representations of tilings.  For Pieces - rep is V2 Double For TileFaces (in Tgraphs) rep is (Vertex,Vertex,Vertex) -}@@ -40,7 +40,7 @@                   | RK rep -- ^ Right Kite                   deriving (Show,Eq) --- | Note this ignores the tileLabels when comparing.+-- | Note this ignores the tile constructors (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)

@@ -55,7 +55,7 @@ -- (i.e. if it fails the connectedness, no crossing boundary check). -- It does not assume the given Tgraph is forced. -- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info).-compose:: Tgraph -> Tgraph+compose:: HasGraph a => a -> Tgraph compose = snd . partCompose  -- |partCompose g is a partial function producing a pair consisting of remainder faces (faces from g which will not compose) @@ -64,8 +64,8 @@ -- raising an error if this check fails. -- It does not assume the given Tgraph is forced. -- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info).-partCompose:: Tgraph -> ([TileFace],Tgraph)-partCompose g = runTry $ onFail "partCompose:\n" $ tryPartCompose g+partCompose:: HasGraph a => a -> ([TileFace],Tgraph)+partCompose = runTry . onFail "partCompose:\n" . tryPartCompose . recoverGraph  -- |tryPartCompose g tries to produce a Tgraph by composing faces which uniquely compose in g, -- It uses tryGetDartWingInfo g which can fail if g is found to be incorrect when forced.@@ -73,7 +73,7 @@ -- If both the above succeed, the result is Right (remainder, g') -- where g' is the composed Tgraph and remainder is a list -- of faces from g which will not compose. -tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph)+tryPartCompose:: HasGraph a => a -> Try ([TileFace],Tgraph) tryPartCompose g =    do (remainder,newFaces) <- tryPartComposeFaces g      checked <- onFail "tryPartCompose:\n" $ tryConnectedNoCross newFaces@@ -81,7 +81,7 @@  -- |Get the remainder and composed faces (without checking the composed faces make a valid Tgraph) -- It uses tryGetDartWingInfo g which can fail if g is found to be incorrect when forced.-tryPartComposeFaces:: Tgraph -> Try ([TileFace],[TileFace])+tryPartComposeFaces:: HasGraph a => a -> Try ([TileFace],[TileFace]) tryPartComposeFaces g =    do dwInfo <- tryGetDartWingInfo g       return $ partComposeFaces dwInfo@@ -95,10 +95,10 @@ -- established for composing. -- The calculation of remainder faces is also more efficient with a known forced Tgraph. -- Also dartWingInfo does not need to be calculated for composing a forced Tgraph.-partComposeF:: Forced Tgraph -> ([TileFace], Forced Tgraph)+partComposeF:: HasGraph a => Forced a -> ([TileFace], Forced Tgraph) partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph newfaces) where   -- !evalnewfaces = evalFaces newfaces-  (_,dwFMap,unused) = dartsMapUnused (forgetF fg)+  (_,dwFMap,unused) = dartsMapUnused (recoverGraph fg)   (remainder,newfaces) = process (VMap.keys dwFMap) (unused,[])   process [] res = res   process (w:more) (rems, nfcs) = @@ -136,7 +136,7 @@ -- Since the argument is a forced Tgraph it does not need a check for validity of the composed Tgraph. -- The fact that the function is total and the result is also Forced relies on theorems -- established for composing.-composeF:: Forced Tgraph -> Forced Tgraph+composeF:: HasGraph a => Forced a -> Forced Tgraph composeF = snd . partComposeF  -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph.@@ -163,9 +163,10 @@ -- Getting the dart wing information makes use of the forced version -- as well as the Tgraph so this uses tryForce first which can fail if -- the Tgraph is found to be incorrect.-tryGetDartWingInfo :: Tgraph -> Try DartWingInfo-tryGetDartWingInfo g =-    do fg <- onFail "tryGetDartWingInfo: incorrect Tgraph found.\n" $ tryForceF g+tryGetDartWingInfo :: HasGraph a => a -> Try DartWingInfo+tryGetDartWingInfo a =+    do let g = recoverGraph a+       fg <- onFail "tryGetDartWingInfo: incorrect Tgraph found.\n" $ tryForceF g        return $ getDWIassumeF False g fg  -- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg

@@ -38,8 +38,8 @@   -- |Decompose a Tgraph.-decompose :: Tgraph -> Tgraph-decompose = makeUncheckedTgraph . decomposeFaces+decompose :: HasGraph a => a -> Tgraph+decompose = makeUncheckedTgraph . decomposeFaces . recoverGraph  -- |Decompose all the faces (using a phiVMap for new vertices). decomposeFaces :: HasFaces a => a -> [TileFace]@@ -78,8 +78,8 @@         where x = (Map.!) newVFor (a,c)     -- |infinite list of decompositions of a Tgraph     -decompositions :: Tgraph -> [Tgraph]-decompositions = iterate decompose+decompositions :: HasGraph a => a -> [Tgraph]+decompositions = iterate decompose . recoverGraph   

@@ -56,10 +56,10 @@   , boundaryECovering   , boundaryVCovering   , tryDartAndKite-  , tryDartAndKiteForced-  , tryDartAndKiteF+  --, tryDartAndKiteForced+  --, tryDartAndKiteF   , tryCheckCasesDKF-  , checkCasesDKF+  --, checkCasesDKF   , commonBdry   , internalVertexSet   , drawFBCovering@@ -113,8 +113,8 @@ import qualified Data.Set as Set  (null,intersection,deleteFindMin)-- used for boundary covers import qualified Data.IntSet as IntSet (member,(\\)) -- for boundary vertex set import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops-import Data.Maybe (fromMaybe) + -- |smart dr g - uses VPatch drawing function dr after converting g to a VPatch -- It will add boundary joins regardless of the drawing function. -- Examples:@@ -124,9 +124,9 @@ -- smart (labelled draw) g -- -- smart (labelSize normal draw) g-smart :: OKBackend b =>-         (VPatch -> Diagram b) -> Tgraph -> Diagram b-smart dr g = (drawBoundaryJoins g <> dr) (makeVP g)+smart :: (OKBackend b, HasGraph a) =>+         (VPatch -> Diagram b) -> a -> Diagram b+smart dr a = (drawBoundaryJoins g <> dr) (makeVP g) where g = recoverGraph a  -- |drawBoundaryJoins a vp - draw boundary join edges of faces in a, using a given suitable VPatch -- Will raise an error if any vertex in the faces does not have a location in the VPatch.@@ -145,7 +145,7 @@ drawJoinsFor a = drawWith dashJOnly . restrictTo a  -- |same as draw except adding dashed lines on boundary join edges. -smartdraw :: OKBackend b => Tgraph -> Diagram b+smartdraw :: (OKBackend b, HasGraph a) => a -> Diagram b smartdraw = smart draw  @@ -162,9 +162,9 @@ -- then adds the dashed boundary join edges of g. -- -- Example: smartRotating angle (labelled draw) g-smartRotating :: OKBackend b =>-                Angle Double -> (VPatch -> Diagram b) -> Tgraph -> Diagram b-smartRotating angle vfun g = rotating angle (smartOn g vfun) g+smartRotating :: (OKBackend b, HasGraph a) =>+                Angle Double -> (VPatch -> Diagram b) -> a -> Diagram b+smartRotating angle vfun a = rotating angle (smartOn g vfun) g where g = recoverGraph a  {-# DEPRECATED smartRotateBefore "Use (flip smartRotating)" #-} -- |smartRotateBefore vfun angle g - a tricky combination of smart with rotateBefore.@@ -181,9 +181,9 @@ -- Will raise an error if either a or b is not a vertex in g. -- -- Example: smartAligning (a,b) (labelled draw) g-smartAligning :: OKBackend b =>-              (Vertex,Vertex) -> (VPatch -> Diagram b) ->  Tgraph -> Diagram b-smartAligning (a,b) vfun g = aligning (a,b) (smartOn g vfun) g+smartAligning :: (OKBackend b, HasGraph a) =>+              (Vertex,Vertex) -> (VPatch -> Diagram b) ->  a -> Diagram b+smartAligning (a,b) vfun c = aligning (a,b) (smartOn g vfun) g where g = recoverGraph c  {-# DEPRECATED smartAlignBefore "Use (flip smartAligning)" #-} -- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with aligning.@@ -207,7 +207,7 @@               Colour Double -> Tgraph -> Diagram b drawForce' c g =     smartOn g draw vp # lc c <> draw vp-    where vp = makeVP $ force g+    where vp = makeVP $ forceF g  -- |applies partCompose to a Tgraph g, then draws the composed Tgraph -- along with the remainder faces (drawn in lime).@@ -304,8 +304,8 @@ -- 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.) -- This will raise an error if the initial force fails with an incorrect Tgraph.-compForce:: Tgraph -> Forced Tgraph-compForce = composeF . forceF+compForce:: (Forcible a, HasGraph a) => a -> Forced Tgraph+compForce = composeF . withForced recoverGraph . forceF   -- |allCompForce g produces a list of the non-null iterated (forced) compositions of force g.@@ -313,22 +313,22 @@ -- The list will be [] if g is the emptyTgraph, otherwise the list begins with force g (when the force succeeds). -- The definition relies on (1) a proof that the composition of a forced Tgraph is forced  and -- (2) a proof that composition does not need to be checked for a forced Tgraph.-allCompForce:: Tgraph -> [Forced Tgraph]-allCompForce = takeWhile (not . nullFaces . forgetF) . iterate composeF . forceF+allCompForce:: (Forcible a, HasGraph a) => a -> [Forced Tgraph]+allCompForce = takeWhile (not . nullGraph) . iterate composeF . withForced recoverGraph . forceF   -- |maxCompForce g produces the maximally composed (non-null) Tgraph starting from force g, provided g is not the emptyTgraph -- and just the emptyTgraph otherwise. -- It will raise an error if the initial force fails with an incorrect Tgraph.-maxCompForce:: Tgraph -> Forced Tgraph-maxCompForce g | nullFaces g = labelAsForced g -- forceF g+maxCompForce:: (Forcible a, HasGraph a) => a -> Forced Tgraph+maxCompForce g | nullGraph g = labelAsForced emptyTgraph -- forceF g                | otherwise = last $ allCompForce g   -- | allForceDecomps g - produces an infinite list (starting with g)  -- of forced decompositions of g (raising an error if a force fails with an incorrect Tgraph).-allForceDecomps:: Tgraph -> [Tgraph]-allForceDecomps = iterate (force . decompose)+allForceDecomps:: HasGraph a => a -> [Tgraph]+allForceDecomps = iterate (force . decompose) . recoverGraph  {-| forcedBoundaryECovering g - produces a list of all boundary covers of force g. Each boundary cover is a forced Tgraph that extends force g and covers the entire boundary directed edges of force g.@@ -339,22 +339,23 @@ This will raise an error if the initial force fails with an incorrect/stuck Tgraph. -} forcedBoundaryECovering:: Tgraph -> [Forced Tgraph]-forcedBoundaryECovering g = recoverGraphF <$> boundaryECovering gforcedBdry where-     gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" $-                             tryForceF $ makeBoundaryState g+forcedBoundaryECovering g = withForced recoverGraph <$> boundaryECovering gforcedBdry where+     gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" +                          $ tryInitFS g  >>= tryForceF  {-| forcedBoundaryVCovering g - produces a list of all boundary covers of force g as with forcedBoundaryECovering g but covering all boundary vertices rather than just boundary edges. This will raise an error if the initial force fails with an incorrect/stuck Tgraph.                       -} forcedBoundaryVCovering:: Tgraph -> [Forced Tgraph]-forcedBoundaryVCovering g = recoverGraphF <$> boundaryVCovering gforcedBdry where-     gforcedBdry = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" $-                             tryForceF $ makeBoundaryState g+forcedBoundaryVCovering g = withForced recoverGraph <$> boundaryVCovering ffs where+     ffs = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n"+                  $ tryInitFS g  >>= tryForceF  -{-| boundaryECovering - for an explicitly Forced BoundaryState fbd,-produces a list of all possible covers of the boundary directed edges in fbd.-A cover is an explicitly Forced extension (of fbd) such that the original boundary directed edges of fbd are all internal edges.++{-| boundaryECovering - for an explicitly Forced ForceState ffs,+produces a list of all possible covers of the boundary directed edges in ffs.+A cover is an explicitly Forced extension (of ffs) such that the original boundary directed edges of ffs are all internal edges. Extensions are made by choosing any edge on the original boundary that is still on the boundary, adding both possible legal faces, and forcing each result (keeping only successes - using tryCheckCasesDKF) then @@ -362,40 +363,40 @@ The resulting covers account for all possible ways the boundary can be extended.  This can raise an error if both choices on a boundary edge fail when forced (using tryCheckCasesDKF).-In which case, fbd represents an important counter example to the hypothesis that+In which case, ffs represents an important counter example to the hypothesis that successfully forced forcibles are correct. -}-boundaryECovering:: Forced BoundaryState -> [Forced BoundaryState]-boundaryECovering forcedbs = covers [(forcedbs, boundaryESet (forgetF forcedbs))] where-  covers:: [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]-  covers [] = []-  covers ((fbs,es):opens)-    | Set.null es = fbs:covers opens -- fbs is a completed cover-    | otherwise = covers (newcases ++ opens)-       where (de,des) = Set.deleteFindMin es-             newcases = map (\b -> (b, commonBdry des (forgetF b)))-                             (runTry $ tryCheckCasesDKF de fbs)+boundaryECovering:: Forced ForceState -> [Forced ForceState]+boundaryECovering forcedfs = covers [(forcedfs, boundaryESet forcedfs)] where+      covers:: [(Forced ForceState, Set Dedge)] -> [Forced ForceState]+      covers [] = []+      covers ((ffs,es):opens)+        | Set.null es = ffs:covers opens -- fs is a completed cover+        | otherwise = covers (newcases ++ opens)+           where (de,des) = Set.deleteFindMin es+                 newcases = map (\x -> (x, commonBdry des x))+                                (runTry $ tryCheckCasesDKF de ffs)   -- | commonBdry des a - returns those directed edges in des that are boundary directed edges of a commonBdry:: HasFaces a => Set Dedge -> a -> Set Dedge commonBdry des a = des `Set.intersection` boundaryESet a -{-| boundaryVCovering fbd - similar to boundaryECovering, but produces a list of all possible covers of -    the boundary vertices in fbd (rather than just boundary edges).+{-| boundaryVCovering ffs - similar to boundaryECovering, but produces a list of all possible covers of +    the boundary vertices in ffs (rather than just boundary edges).     This can raise an error if both choices on a boundary edge fail when forced (using tryCheckCasesDKF).  -}-boundaryVCovering:: Forced BoundaryState -> [Forced BoundaryState]-boundaryVCovering fbd = covers [(fbd, startbds)] where-  startbds = boundaryESet $ forgetF fbd-  startbvs = boundaryVSet $ forgetF fbd---covers:: [(Forced BoundaryState,Set Dedge)] -> [Forced BoundaryState]+boundaryVCovering:: Forced ForceState -> [Forced ForceState]+boundaryVCovering ffs = covers [(ffs, startbdes)] where+  startbdes = boundaryESet ffs+  startbvs = boundaryVSet ffs+  covers:: [(Forced ForceState, Set Dedge)] -> [Forced ForceState]   covers [] = []   covers ((open,es):opens)-    | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary $ forgetF open) of+    | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary open) of         Nothing -> open:covers 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+    | otherwise =  covers $ map (\b -> (b, commonBdry des b)) (runTry $ tryCheckCasesDKF de open) ++opens                    where (de,des) = Set.deleteFindMin es  -- | returns the set of internal vertices of all tilefaces@@ -412,28 +413,6 @@         tryAddHalfKite de b     ] --- | tryDartAndKiteF 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 of an explicitly Forced type.-tryDartAndKiteF:: Forcible a => Dedge -> a -> [Try (Forced a)]-tryDartAndKiteF de b =-    [ onFail ("tryDartAndKiteF: Dart on edge: " ++ show de ++ "\n") $-        tryAddHalfDart de b >>= tryForceF-    , onFail ("tryDartAndKiteF: Kite on edge: " ++ show de ++ "\n") $-        tryAddHalfKite de b >>= tryForceF-    ]---- | 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") $-        tryAddHalfDart de b >>= tryForce-    , onFail ("tryDartAndKiteForced: Kite on edge: " ++ show de ++ "\n") $-        tryAddHalfKite de b >>= tryForce-    ]- -- | tryCheckCasesDKF dedge fb (where fb is an explicitly forced Forcible -- and dedge is a directed boundary edge of fb) tries to add both a half kite and a half dart to the edge -- then tries forcing each result.@@ -447,6 +426,25 @@ -- (If both legal additions to a boundary edge are incorrect, -- then the (Forced) Forcible must be incorrect). tryCheckCasesDKF :: (Forcible a, Show a) => Dedge -> Forced a -> Try [Forced a]+tryCheckCasesDKF de fa = +    onFail ("tryCheckCasesDKF: <<< Counter Example Found!! >>>\n"+            ++ "\nBoth legal extensions to directed edge " +            ++ show de+            ++ " \nare incorrrect for a Forced ForceState.\n"+            ++ "This shows a successfully forced forcible can still be incorrect\n"+            ++ "which is a counter example to the hypothesis that successful forcing\n"+            ++ "returns correct tilings.\n\n"+            ++ "The incorrect Forced ForceState has Tgraph:\n"+            ++ show  (forgetF fa)+           ) $+    fmap (map labelAsForced) $ tryAtLeastOne+    [ onFail ("tryCheckCasesDKF: Dart on edge: " ++ show de ++ "\n") $+        tryFSOp (\fs -> tryAddHalfDart de fs >>= tryForce) a+    , onFail ("tryCheckCasesDKF: Kite on edge: " ++ show de ++ "\n") $+        tryFSOp (\fs -> tryAddHalfKite de fs >>= tryForce) a+    ] where a = forgetF fa++{- tryCheckCasesDKF :: (Forcible a, Show a) => Dedge -> Forced a -> Try [Forced a] tryCheckCasesDKF dedge fb =      onFail ("tryCheckCasesDKF: <<< Counter Example Found!! >>>\n"             ++ "\nBoth legal extensions to directed edge " ++ show dedge@@ -458,7 +456,7 @@             ++ show fb            )     $ tryAtLeastOne $ tryDartAndKiteF dedge (forgetF fb)-+   -- | checkCasesDKF dedge fb (where fb is an explicitly forced Forcible -- and dedge is a directed boundary edge of fb) tries to add both a half kite and a half dart to the edge -- then tries forcing each result.@@ -473,12 +471,13 @@ -- then the (Forced) Forcible must be incorrect). checkCasesDKF :: (Forcible a, Show a) => Dedge -> Forced a -> [Forced a] checkCasesDKF dedge = runTry . tryCheckCasesDKF dedge- + -} + -- |A test function to draw (as a column) the list of covers resulting from forcedBoundaryVCovering -- for a given Tgraph. drawFBCovering :: OKBackend b =>                   Tgraph -> Diagram b-drawFBCovering g = lw ultraThin $ vsep 1 (draw . forgetF <$> forcedBoundaryVCovering g)+drawFBCovering g = lw ultraThin $ vsep 1 (draw . recoverGraph <$> forcedBoundaryVCovering g)   -- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g.@@ -492,10 +491,10 @@     case forcedBoundaryVCovering g of      [] -> error "empire1 : no forced boundary covers found\n"      (fg0:others) -> makeTrackedTgraph g0 [fcs,faces g] where-          g0 = forgetF fg0+          g0 = recoverGraph fg0           fcs = foldl' intersect (faces g0) $ map g0Intersect others           de = defaultAlignment g-          g0Intersect fg1 = commonFaces (g0,de) (forgetF fg1,de)+          g0Intersect fg1 = commonFaces (g0,de) (recoverGraph fg1,de)  -- | empire2 g - produces a TrackedTgraph representing a level 2 empire of g. -- Raises an error if force g fails with a stuck/incorrect Tgraph.@@ -508,14 +507,14 @@ -- at the head, followed by the original faces of g. empire2:: Tgraph -> TrackedTgraph empire2 g = -  case map (recoverGraph . forgetF) covers2 of+  case map recoverGraph covers2 of     [] -> error "empire2: empty list of secondary boundary covers found"     (g0:others) -> makeTrackedTgraph g0 [fcs, faces g]       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"-              $ tryForceF $ makeBoundaryState g+               $ tryInitFS g >>= tryForceF      covers2 = concatMap boundaryECovering covers1      de = defaultAlignment g      @@ -525,14 +524,14 @@ -- Raises an error if force g fails with a stuck/incorrect Tgraph. empire2Plus:: Tgraph -> TrackedTgraph empire2Plus g = -  case map (recoverGraph . forgetF) covers2 of+  case map recoverGraph covers2 of     [] -> error "empire2: empty list of secondary boundary covers found"     (g0:others) -> makeTrackedTgraph g0 [fcs, faces g]       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"-              $ tryForceF $ makeBoundaryState g+               $ tryInitFS g >>= tryForceF      covers2 = concatMap boundaryVCovering covers1      de = defaultAlignment g      @@ -569,40 +568,40 @@ -- This will raise an error if force encounters a stuck (incorrect) tiling or if -- both forced extensions fail for some boundary edge. -- Otherwise, the result has exactly two correct possible extensions for each boundary edge.-superForce:: Forcible a => a -> a+superForce:: Forcible a => a -> Forced a superForce g = runTry $ trySuperForce g  -- |trySuperForce g - this looks for single choice edges after trying to force g. -- If there is at least one, it makes that choice and recurses. -- It returns a Left s if force fails or if both choices fail for some edge (where s is a failure report). -- Otherwise Right g' is returned where g' is the super forced g.-trySuperForce:: Forcible a => a -> Try a-trySuperForce = tryFSOp trySuperForceFS where+trySuperForce:: Forcible a => a -> Try (Forced a)+trySuperForce = fmap labelAsForced . tryFSOp trySuperForceFS where     -- |trySuperForceFS - implementation of trySuperForce for force states only     trySuperForceFS :: ForceState -> Try ForceState     trySuperForceFS fs =-        do forcedFS <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $-                       tryForceF fs-           case singleChoiceEdges $ boundaryStateF forcedFS of-              [] -> return $ forgetF forcedFS-              (elpr:_) -> do extended <- addSingle elpr $ forgetF forcedFS+        do ffs <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $+                  tryForceF fs+           case singleChoiceEdges $ ffs of+              [] -> return $ forgetF ffs+              (elpr:_) -> do extended <- addSingle elpr $ forgetF ffs                              trySuperForceFS extended     addSingle (e,l) fs = if isDart l then tryAddHalfDart e fs else tryAddHalfKite e fs --- |singleChoiceEdges bd - if bd is an explicitly Forced boundary state (of a forced Tgraph) this finds those boundary edges of bd--- which have a single choice (i.e. the other choice is incorrect), by inspecting boundary edge covers of bd.+-- |singleChoiceEdges ffs - if ffs is an explicitly Forced ForceState (of a forced Tgraph) this finds those boundary edges of ffs+-- which have a single choice (i.e. the other choice is incorrect), by inspecting boundary edge covers of ffs. -- 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 :: Forced BoundaryState -> [(Dedge,HalfTileLabel)]-singleChoiceEdges bstate = commonToCovering (forgetF <$> boundaryECovering bstate) (boundary $ forgetF bstate)+singleChoiceEdges :: Forced ForceState -> [(Dedge,HalfTileLabel)]+singleChoiceEdges bstate = commonToCovering (forgetF <$> 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. -- This indicates there is a single choice for such an edge (the other choice is incorrect). -- 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 = map (`reportCover` edgeList) bds+    commonToCovering :: [ForceState] -> [Dedge] -> [(Dedge,HalfTileLabel)]+    commonToCovering ffs edgeList = common edgeList (transpose labellists) where+      labellists = map (`reportCover` edgeList) ffs       common [] [] = []       common [] (_:_) = error "singleChoiceEdges:commonToCovering: label list is longer than edge list"       common (_:_) [] = error "singleChoiceEdges:commonToCovering: label list is shorter than edge list"@@ -611,19 +610,19 @@                                      then (e,l):common more lls                                      else common more lls       --- |reportCover bd edgelist - when bd is a boundary edge cover of some forced Tgraph whose boundary edges are edgelist,+-- |reportCover fs edgelist - when fs 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 = map (tileLabel . getf) des where-      efmap = dedgeFMap des bd  -- more efficient than using graphEFMap?---      efmap = graphEFMap (recoverGraph bd)-      getf e = fromMaybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e)-                                    (faceForEdge e efmap)+    reportCover :: ForceState -> [Dedge] -> [HalfTileLabel]+    reportCover fs des = map getLabel des where+      efmap = dedgeFMap des fs  -- more efficient than using graphEFMap?+      getLabel e = case faceForEdge e efmap of+                 Nothing -> error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e+                 Just f -> tileLabel f  -- |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.-tryBoundaryFaceGraph :: Tgraph -> Try Tgraph+tryBoundaryFaceGraph :: HasFaces a => a -> Try Tgraph tryBoundaryFaceGraph = tryConnectedNoCross . boundaryVFaces   @@ -669,7 +668,6 @@                                         ++ show a ++                                         "\nwith loop vertices "++ show (reverse sofar) ++"\n" - -- | Given a suitable vertex to location map and boundary loops (represented as a list of lists of vertices), -- 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.)@@ -691,14 +689,15 @@ data TrackedTgraph = TrackedTgraph{ tgraph:: Tgraph, tracked::[[TileFace]]} deriving Show  -- |newTrackedTgraph g creates a TrackedTgraph from a Tgraph g with an empty tracked list-newTrackedTgraph :: Tgraph -> TrackedTgraph-newTrackedTgraph g = makeTrackedTgraph g []+newTrackedTgraph :: HasGraph a => a -> TrackedTgraph+newTrackedTgraph g = makeTrackedTgraph (recoverGraph g) []  -- |makeTrackedTgraph g trackedlist creates a TrackedTgraph from a Tgraph g -- 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 = map (`intersect` faces g) trackedlist}+makeTrackedTgraph :: HasGraph a => a -> [[TileFace]] -> TrackedTgraph+makeTrackedTgraph a trackedlist = TrackedTgraph{ tgraph = g, tracked = map (`intersect` faces g) trackedlist}+             where g = recoverGraph a  -- |trackFaces ttg - pushes the maingraph tilefaces onto the stack of tracked subsets of ttg trackFaces:: TrackedTgraph -> TrackedTgraph@@ -717,29 +716,34 @@  -- | TrackedTgraphs are Forcible     instance Forcible TrackedTgraph where-    tryFSOpWith ugen f ttg = do-        g' <- tryFSOpWith ugen f $ tgraph ttg+    tryFSOp f ttg = do+        g' <- tryFSOp f $ recoverGraph ttg         return ttg{ tgraph = g' }-    tryInitFSWith ugen ttg = tryInitFSWith ugen (tgraph ttg)-    tryChangeBoundaryWith ugen f ttg = do-        g' <- tryChangeBoundaryWith ugen f $ tgraph ttg+    tryInitFS = tryInitFS . recoverGraph +    tryChangeBoundary f ttg = do+        g' <- tryChangeBoundary f $ recoverGraph ttg         return ttg{ tgraph = g' }---    boundaryState = boundaryState . tgraph + -- |TrackedTgraph is in class HasFaces instance HasFaces TrackedTgraph where-    faces  = faces . tgraph+    faces  = faces . recoverGraph {-     boundary = boundary . tgraph     maxV = maxV . tgraph     boundaryVFMap = boundaryVFMap . tgraph -- note need for nub  -}++-- | TrackedTgraph is in class HasGraph+instance HasGraph TrackedTgraph where+    recoverGraph = 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 addHalfDartTracked e ttg =   TrackedTgraph{ tgraph = g' , tracked = newfcs:tracked ttg}   where-    g = tgraph ttg+    g = recoverGraph ttg     g' = addHalfDart e g     newfcs = faces g' \\ faces g @@ -749,7 +753,7 @@ addHalfKiteTracked e ttg =   TrackedTgraph{ tgraph = g' , tracked = newfcs:tracked ttg}   where-    g = tgraph ttg+    g = recoverGraph ttg     g' = addHalfKite e g     newfcs = faces g' \\ faces g @@ -760,7 +764,7 @@   TrackedTgraph{ tgraph = g' , tracked = tlist}   where --    makeTrackedTgraph g' tlist where-    g = tgraph ttg+    g = recoverGraph ttg     g' = makeUncheckedTgraph newFaces     newVFor = phiVMap g     newFaces = concatMap (decompFace newVFor) (faces g)@@ -779,7 +783,7 @@ -} drawTrackedTgraph :: OKBackend b => [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b drawTrackedTgraph drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where-    vp = makeVP (tgraph ttg)+    vp = makeVP ttg     untracked = faces vp \\ concat (tracked ttg)     vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp @@ -792,7 +796,7 @@ -} drawTrackedTgraphRotating :: OKBackend b => Angle Double -> [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b drawTrackedTgraphRotating a drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where-    vp = rotate a $ makeVP (tgraph ttg)+    vp = rotate a $ makeVP ttg     untracked = faces vp \\ concat (tracked ttg)     vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp @@ -805,10 +809,7 @@     to ensure labels are not rotated. -} drawTrackedTgraphRotated :: OKBackend b => [VPatch -> Diagram b] -> Angle Double -> TrackedTgraph -> Diagram b-drawTrackedTgraphRotated drawList a ttg = mconcat $ reverse $ zipWith ($) drawList vpList where-    vp = rotate a $ makeVP (tgraph ttg)-    untracked = faces vp \\ concat (tracked ttg)-    vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp+drawTrackedTgraphRotated = flip drawTrackedTgraphRotating  {-|     To draw a TrackedTgraph aligned.@@ -820,7 +821,7 @@ -} drawTrackedTgraphAligning :: OKBackend b => (Vertex,Vertex) -> [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b drawTrackedTgraphAligning (a,b) drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where-    vp = makeAlignedVP (a,b) (tgraph ttg)+    vp = makeAlignedVP (a,b) ttg     untracked = faces vp \\ concat (tracked ttg)     vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp @@ -834,10 +835,7 @@     This will raise an error if either of the pair of vertices is not a vertex of (the tgraph of) the TrackedTgraph -} drawTrackedTgraphAligned :: OKBackend b => [VPatch -> Diagram b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram b-drawTrackedTgraphAligned drawList (a,b) ttg = mconcat $ reverse $ zipWith ($) drawList vpList where-    vp = makeAlignedVP (a,b) (tgraph ttg)-    untracked = faces vp \\ concat (tracked ttg)-    vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp+drawTrackedTgraphAligned = flip drawTrackedTgraphAligning   

@@ -19,38 +19,39 @@  module Tgraph.Force   ( -- *  Forcible class-   Forcible(..)+   Forcible(..) -- tryFSOp, tryInitFS, tryChangeBoundary     -- *  Generalised forcing   , force-  , forceWith   , tryForce+  , forceWith   , tryForceWith   , stepForce   , tryStepForce-  , tryStepForceWith-  , tryFSOp+ -- , tryStepForceWith+  , tryFSOpWith   , initFS-  , tryInitFS-  , tryChangeBoundary+ -- , tryInitFS+ -- , tryChangeBoundary   , wholeTiles   -- *  Explicitly Forced   , Forced()   , forgetF   , tryForceF   , forceF-  , recoverGraphF-  , boundaryStateF-  , makeBoundaryStateF-  , initFSF+  , withForced+  , recoverGraphF --dep+  , boundaryStateF --dep+  , makeBoundaryStateF --dep+  , initFSF --dep   , labelAsForced    -- *  Force Related   , addHalfKite   , tryAddHalfKite   , addHalfDart   , tryAddHalfDart-    -- *  Debug Step Forcing-  , tryOneStepWith-  , tryOneStepForce+--  , tryOneStepWith+  , tryOneStepForce -- dep+  , tryOneStep -- * Types for Forcing   , BoundaryState(..)   , BoundaryDedges()@@ -64,7 +65,7 @@     -- *  BoundaryState operations   , makeBoundaryState   -- , boundary (part of HasFaces class)-  , recoverGraph+ --  , recoverGraph --now in HasGraph --  , changeVFMap -- Now HIDDEN   , facesAtBV   -- , boundaryVFacesBS  (removed)@@ -77,8 +78,8 @@   , isBoundaryDE   , tryOnBoundary --  , mustFind-  , tryReviseUpdates-  , tryReviseFSWith+--  , tryReviseUpdates+--  , tryReviseFS   , findSafeUpdate   , tryUnsafes   , checkUnsafeUpdate@@ -154,7 +155,7 @@   -import Data.List ((\\), intersect, nub, find, partition)+import Data.List ((\\), nub, find, partition) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..)) import Data.Map.Strict(Map)@@ -169,7 +170,7 @@ import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate  import Tgraph.Prelude import Tgraph.Grid -+-- import TileLib ( Drawable )  {- ***************************************************************************    Efficient FORCING with @@ -254,13 +255,6 @@ isBoundaryV :: Vertex -> BoundaryState -> Bool isBoundaryV v = VMap.member v . nextBVMap . boundaryDedges --- |BoundaryState is in class HasFaces.--- Note the default implementations are overiden to use precalculated information-instance HasFaces BoundaryState where-    faces = allFaces-    boundaryESet = bdesToSet . boundaryDedges  -- (overrides default) boundary already calculated-    maxV bd = nextVertex bd - 1 -- (overrides default)-    boundaryVFMap = bvFacesMap -- (overrides default) already calculated  -- |Calculates BoundaryState information from a Tgraph. makeBoundaryState:: Tgraph -> BoundaryState@@ -279,10 +273,18 @@       , nextVertex = 1+ maxV g       } --- |Converts a BoundaryState back to a Tgraph-recoverGraph:: BoundaryState -> Tgraph-recoverGraph = makeUncheckedTgraph . faces+-- |BoundaryState is in class HasFaces.+-- Note the default implementations are overiden to use precalculated information+instance HasFaces BoundaryState where+    faces = allFaces+    boundaryESet = bdesToSet . boundaryDedges  -- (overrides default) boundary already calculated+    maxV bd = nextVertex bd - 1 -- (overrides default)+    boundaryVFMap = bvFacesMap -- (overrides default) already calculated +-- |A Tgraph can be recovered from a BoundaryState+instance HasGraph BoundaryState where+    recoverGraph = makeUncheckedTgraph . allFaces+ -- |changeVFMapUnsafe f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap -- This is used in the unsafe addition case where one of the vertices will be new to the map. changeVFMapUnsafe::  TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]@@ -320,12 +322,21 @@ type UpdateMap = Map Dedge Update  -- |ForceState: The force state records information between executing single face updates during forcing--- (a BoundaryState and an UpdateMap).+-- (a BoundaryState , an UpdateMap, and an UpdateGenerator). data ForceState = ForceState-                   { boundaryState:: BoundaryState-                   , updateMap:: UpdateMap-                   } deriving (Show)+    { boundaryState:: BoundaryState+    , updateMap:: ~UpdateMap  -- lazy field may not be used+    , updater:: UpdateGenerator -- new+    } +-- | Show ForceState does not show the UpdateGenerator which contains a function.+instance Show ForceState where+    show fs = show $ "ForceState with boundaryState:\n"+                      ++ show(boundaryState fs)+                      ++ "\n\nand updateMap:\n"+                      ++ show (updateMap fs)+                      ++ "\n\n"+ -- |ForceState is in class HasFaces. -- (using the boundaryState implementations) instance HasFaces ForceState where@@ -334,6 +345,10 @@     maxV = maxV . boundaryState     boundaryVFMap = boundaryVFMap . boundaryState +-- |A Tgraph can be recovered from a ForceState+instance HasGraph ForceState where+    recoverGraph = recoverGraph . 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.  @@ -347,93 +362,83 @@ -- and then to a ForceState (which keeps track of possible updates during forcing). -- Thus we introduce a Forcible class which will have Tgraph, BoundaryState, ForceState as instances. ----- Forcible class has operations to (indirectly) implement forcing and single step forcing--- for any Forcible. The class operations are more general to allow for other+-- Forcible class has operations to (indirectly) implement force and stepForce and other operations.+-- The class operations allow for other -- force related operations to be generalised for use on any Forcible.--- For example tryAddHalfKite and tryAddHalfDart are implemented using tryChangeBoundaryWith.------ Note that these operations are parameterised on an UpdateGenerator, which encapsulates--- the forcing rules to be used.+-- For example tryAddHalfKite and tryAddHalfDart are implemented using tryChangeBoundary. class Forcible a where-    -- | 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)+    -- | tryFSOp (try ForseState Operation), generalises a (try) ForceState operation to a (try) Forcible operation.     --     -- 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 compose (e.g. using (\<=\<) or (\>=\>) from Control.Monad) and pass to tryFSOp.     -- 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.-    -- Again, the update generator is not used when the instance is a ForceState.-    tryInitFSWith :: UpdateGenerator -> a -> Try ForceState-    -- | tryChangeBoundaryWith when given an update generator, converts a (try) BoundaryState changing operation to a (try) Forcible operation.-    -- The update generator is only used when the instance is a ForceState (to revise the update map in the result).-    tryChangeBoundaryWith :: UpdateGenerator -> (BoundaryState -> Try BoundaryChange) -> a -> Try a+    tryFSOp :: (ForceState -> Try ForceState) -> a -> Try a+    -- | tryInitFS (try initialising a ForceState) tries to create an initial ForceState (ready for forcing) from a Forcible.+    -- This uses defaultAllUGen for Tgraphs and BoundaryStates but stored update generator when the instance is a ForceState.+    -- (See also tryFSOpWith).+    tryInitFS :: a -> Try ForceState+    -- | tryChangeBoundary, converts a (try) BoundaryState changing operation to a (try) Forcible operation.+    tryChangeBoundary :: (BoundaryState -> Try BoundaryChange) -> a -> Try a  -- |ForceStates are Forcible instance Forcible ForceState where-    tryFSOpWith _ = id  -- update generator not used-    tryInitFSWith _  = return  -- update generator not used-    tryChangeBoundaryWith ugen f fs = do+    tryFSOp = id+    tryInitFS = return +    tryChangeBoundary f fs = do         bdC <- f (boundaryState fs)-        tryReviseFSWith ugen bdC fs+        tryReviseFS bdC fs  -- | BoundaryStates are Forcible     instance Forcible BoundaryState where-    tryFSOpWith ugen f bd = do-        fs <- tryInitFSWith ugen bd+    tryFSOp f bd = do+        fs <- tryInitFS bd         fs' <- f fs         return $ boundaryState fs'-    tryInitFSWith ugen bd = do-        umap <- applyUG ugen bd (boundary bd)-        return $ ForceState { boundaryState = bd , updateMap = umap }-    tryChangeBoundaryWith _ f bd = do -- update generator not used+    tryInitFS bd = do+        ~umap <- applyUG defaultAllUGen bd (boundary bd)+        return $ ForceState { boundaryState = bd , updateMap = umap , updater = defaultAllUGen }+    tryChangeBoundary f bd = do -- update generator not used         bdC <- f bd         return $ newBoundaryState bdC  -- | Tgraphs are Forcible     instance Forcible Tgraph where-    tryFSOpWith ugen f g = recoverGraph <$> tryFSOpWith ugen f (makeBoundaryState g)-    tryInitFSWith ugen g = tryInitFSWith ugen (makeBoundaryState g)-    tryChangeBoundaryWith ugen f g = -- update generator not used-        recoverGraph <$> tryChangeBoundaryWith ugen f (makeBoundaryState g)+    tryFSOp f  = fmap recoverGraph . tryFSOp f . makeBoundaryState+    tryInitFS g = tryInitFS (makeBoundaryState g)+    tryChangeBoundary f = -- update generator not used+        fmap recoverGraph . tryChangeBoundary f . makeBoundaryState +-- |Resets the update generator in a ForceState (and recalculates updateMap)+trySetUG :: UpdateGenerator -> ForceState -> Try ForceState       +trySetUG ugen fs = do+    ~umap <- applyUG ugen (boundaryState fs) (boundary fs)+    return $ fs { updateMap = umap, updater = ugen } +-- |ForceState only operation to do all update steps.+-- Used to define the more general tryForce+tryFinishFS :: ForceState -> Try ForceState+tryFinishFS fs =  do +    r <- tryOneStep fs+    case r of +      Just (fs',_) -> tryFinishFS fs'+      Nothing -> return fs -- final state (no more updates) +-- |A version of tryFSOp that uses the supplied update generator rather than the default.+tryFSOpWith :: Forcible a => UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a+tryFSOpWith ugen f = tryFSOp (\fs -> trySetUG ugen fs >>= f)+ -- | try forcing using a given UpdateGenerator. --  tryForceWith uGen fs - does updates using uGen until there are no more updates. --  It produces Left report if it encounters a Forcible representing a stuck/incorrect Tgraph. tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a-tryForceWith ugen = tryFSOpWith ugen retry where-  retry fs = do r <- tryOneStepWith ugen fs-                case r of -                  Just (fs',_) -> retry fs'-                  Nothing -> return fs -- final state (no more updates)-- --- | try a given number of force steps using a given UpdateGenerator.-tryStepForceWith :: Forcible a => UpdateGenerator -> Int -> a -> Try a-tryStepForceWith ugen n =-  if n>=0-  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'---- |A version of tryFSOpWith using defaultAllUGen representing all 10 rules for updates.-tryFSOp :: Forcible a => (ForceState -> Try ForceState) -> a -> Try a-tryFSOp = tryFSOpWith defaultAllUGen+tryForceWith ug = tryFSOpWith ug tryFinishFS --- |A try version of the main force function using defaultAllUGen representing all 10 rules for updates.+-- |A try version of the main force function (using defaultAllUGen representing all 10 rules for updates). -- This returns Left report on discovering a stuck Tgraph and Right a (with a the resulting forcible) otherwise. tryForce:: Forcible a => a -> Try a-tryForce = tryForceWith defaultAllUGen+tryForce = tryFSOp tryFinishFS --- |The main force (partial) function using defaultAllUGen representing all 10 rules for updates.+-- |The main force (partial) function (using defaultAllUGen representing all 10 rules for updates). -- This raises an error on discovering a stuck/incorrect Forcible. force:: Forcible a => a -> a force = runTry . tryForce@@ -442,16 +447,11 @@ wholeTiles:: Forcible a => a -> a wholeTiles = forceWith wholeTileUpdates --- | forceWith ugen: force using the given UpdateGenerator+-- | forceWith ugen: force using the supplied UpdateGenerator ugen. -- This raises an error on discovering a stuck/incorrect Forcible. forceWith:: Forcible a => UpdateGenerator -> a -> a forceWith ugen = runTry . tryForceWith ugen --- | try to initialize a force state with the default UpdateGenerator.--- Returns a Left report if it finds a stuck Forcible.-tryInitFS :: Forcible a => a -> Try ForceState-tryInitFS = tryInitFSWith defaultAllUGen- -- | initialize a force state with the default UpdateGenerator. -- Raises an error if it finds a stuck Forcible. initFS :: Forcible a => a -> ForceState@@ -459,20 +459,27 @@  -- |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. +-- If forcing finishes successfully in n or fewer steps, it will return that final Forcible.+-- It will raise an error if n<0.  tryStepForce :: Forcible a => Int -> a -> Try a-tryStepForce = tryStepForceWith defaultAllUGen-- Was called tryStepForceFrom+tryStepForce n =+  if n>=0+  then tryFSOp $ count n+  else error "tryStepForce: used with negative number of steps\n"+  where+      count 0 fs = return fs+      count m fs = do result <- tryOneStep fs+                      case result of+                       Nothing -> return fs+                       Just (fs', _) ->  count (m-1) fs'  -- |stepForce n a - produces an intermediate Forcible after n steps (n face additions) starting from Forcible a. -- It raises an error 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. +-- If forcing finishes successfully in n or fewer steps, it will return that final Forcible.+-- It will raise an error if n<0.   stepForce :: Forcible a => Int -> a ->  a stepForce n = runTry . tryStepForce n --- |specialises tryChangeBoundaryWith to the default update generator.-tryChangeBoundary:: Forcible a => (BoundaryState -> Try BoundaryChange) -> a -> Try a-tryChangeBoundary = tryChangeBoundaryWith defaultAllUGen- -- |Forced a is a newtype (for a) to explicitly indicate that a is fully forced. -- This enables restriction of some functions that should only be applied to a fully forced Forcible. --@@ -482,15 +489,9 @@ newtype Forced a = Forced { -- | forget the explicit Forced labelling                             forgetF :: a                             }                 -   deriving (Show)---- |Extend HasFaces ops from a to Forced a-instance HasFaces a => HasFaces (Forced a) where-    faces = faces . forgetF-    boundaryESet = boundaryESet . forgetF-    maxV = maxV . forgetF-    boundaryVFMap = boundaryVFMap . forgetF+   deriving (Show,HasFaces,HasGraph) +  {-# WARNING labelAsForced      ["This should only be used when the argument is known to be a fully forced Forcible."     ,"Consider using forceF or tryForceF instead for safety reasons."@@ -511,21 +512,32 @@ forceF:: Forcible a => a -> Forced a forceF = runTry . tryForceF +-- |withForced f - Use f to convert a (Forced a) to a (Forced b)+-- Both a and b should be Forcible.+withForced :: (a->b) -> Forced a -> Forced b+withForced f (Forced a) = Forced (f a)++{-# DEPRECATED recoverGraphF "Use (withForced recoverGraph)" #-} -- | recoverGraphF is an explicitly forced version of recoverGraph-recoverGraphF :: Forced BoundaryState -> Forced Tgraph-recoverGraphF (Forced bs) = Forced (recoverGraph bs)+recoverGraphF :: Forced ForceState -> Forced Tgraph+recoverGraphF = withForced recoverGraph  +{-# DEPRECATED boundaryStateF "Use (withForced boundaryState)" #-} -- | boundaryStateF is an explicitly forced version of boundaryState boundaryStateF :: Forced ForceState -> Forced BoundaryState-boundaryStateF (Forced fs) = Forced (boundaryState fs)+boundaryStateF = withForced boundaryState+             -- boundaryStateF (Forced fs) = Forced (boundaryState fs) +{-# DEPRECATED makeBoundaryStateF "Use (withForced makeBoundaryState)" #-} -- | makeBoundaryStateF is an explicitly forced version of makeBoundaryState makeBoundaryStateF :: Forced Tgraph -> Forced BoundaryState-makeBoundaryStateF (Forced g) = Forced (makeBoundaryState g)+makeBoundaryStateF = withForced makeBoundaryState+       -- makeBoundaryStateF (Forced g) = Forced (makeBoundaryState g) +{-# DEPRECATED initFSF "Use (withForced initFS)" #-} -- | initFSF is an explicitly forced version of initFS initFSF :: Forcible a => Forced a -> Forced ForceState-initFSF (Forced a) = Forced (initFS a)+initFSF = withForced initFS  -- |try to find the right direction for an edge to be a boundary directed edge. -- Returns either Right de where de is the correct direction for the edge on the boundary,@@ -594,7 +606,7 @@   --- |tryOneStepWith uGen fs does one force step.+-- |tryOneStep fs does one force step. -- It returns either  -- -- (1) a Right(Just (f,bc)) with a new ForceState f paired with the BoundaryChange bc.@@ -602,24 +614,31 @@ -- -- (2) a Right Nothing indicating forcing has finished and there are no more updates, or  ----- (3) a Left report for a stuck/incorrect graph.-tryOneStepWith :: UpdateGenerator -> ForceState -> Try (Maybe (ForceState,BoundaryChange))-tryOneStepWith uGen fs =+-- (3) a Left report for a stuck/incorrect Tgraph.+tryOneStep :: ForceState -> Try (Maybe (ForceState,BoundaryChange))+tryOneStep fs =       case findSafeUpdate (updateMap fs) of       Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u-                   fs' <- tryReviseFSWith uGen bdChange fs+                   fs' <- tryReviseFS bdChange fs                    return $ Just (fs',bdChange)       _  -> do maybeBdC <- tryUnsafes fs                case maybeBdC of-                Just bdC -> do fs' <- tryReviseFSWith uGen bdC fs+                Just bdC -> do fs' <- tryReviseFS bdC fs                                return $ Just (fs',bdC)                 Nothing  -> return Nothing           -- no more updates --- |tryOneStepForce is a special case of tryOneStepWith using defaultAllUGen (used for debugging).-tryOneStepForce :: ForceState -> Try (Maybe (ForceState,BoundaryChange))-tryOneStepForce = tryOneStepWith defaultAllUGen+{-# DEPRECATED tryOneStepForce "Renamed as tryOneStep" #-}+tryOneStepForce :: ForceState -> Try (Maybe (ForceState, BoundaryChange))+tryOneStepForce = tryOneStep +-- | Apply the update generator on the changed boundary of a ForceState+tryReviseFS :: BoundaryChange -> ForceState -> Try ForceState+tryReviseFS bdC fs =+    do umap <- tryReviseUpdates (updater fs) bdC (updateMap fs)+       return $ fs{ boundaryState = newBoundaryState bdC, updateMap = umap} ++ {-| After a face addition to a BoundaryState (by either trySafeUpdate or tryUnsafeUpdate), a BoundaryChange records      (1) the new BoundaryState       (2) the list of directed edges that were, but are no longer on the boundary (1,2,or 3),@@ -680,13 +699,6 @@      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--- the revised updates with ugen (and using the new boundary state in bdC).-tryReviseFSWith :: UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState-tryReviseFSWith ugen bdC fs =-    do umap <- tryReviseUpdates ugen bdC (updateMap fs)-       return $ ForceState{ boundaryState = newBoundaryState bdC, updateMap = umap}- {-# INLINE findSafeUpdate #-} -- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering) findSafeUpdate:: UpdateMap -> Maybe Update@@ -739,7 +751,7 @@       newVPoints = addVPoint newface oldVPoints       vPosition = newVPoints VMap.! v   in case insertGridCheck vPosition (grid bd) of-    Left _  -> Nothing+    Left _  -> Nothing  -- blocked by touching vertex     Right newgrid ->      let         (unmatched, matchedDedges) = partition (\(x,y) -> x == v || y == v) (faceDedges newface) -- (two edges,singleton)@@ -774,11 +786,11 @@ trySafeUpdate _  (UnsafeUpdate _) = error "trySafeUpdate: applied to non-safe update.\n" trySafeUpdate bd (SafeUpdate newface) =    let fDedges = faceDedges newface-       localBoundary =  [e | v <- faceVList newface, e <- boundaryAt v bd] -- WITH duplicates-       --       localRevDedges =  [(b,a) | v <- faceVList newface, !f <- facesAtBV bd v, (a,b) <- faceDedges f]-       matchedDedges = fDedges `intersect` localBoundary -- list of 2 or 3+       localBoundary = nub [e | v <- faceVList newface, e <- boundaryAt v bd] -- duplicates removed+       (matchedDedges, unmatched) = partition (`elem` localBoundary) fDedges+       -- matchedDedges = fDedges `intersect` localBoundary -- list of 2 or 3        removedBVs = commonVs matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3)-       newBdry = map reverseD (fDedges \\ matchedDedges) -- one or none+       newBdry = map reverseD unmatched --(fDedges \\ matchedDedges) -- one or none        nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs        resultBd = BoundaryState                    { boundaryDedges = bdesInsert newBdry $ bdesDelete matchedDedges $ boundaryDedges bd@@ -1015,12 +1027,6 @@ mustbeKing bd v = isKiteWing bd v && length dartOrigins ==4    where  dartOrigins = filter ((==v) . originV) $ filter isDart $ facesAtBV bd v -{---- |A boundary vertex which is a kite wing and dart origin must be either a king or queen-mustbeQorK:: BoundaryState -> Vertex -> Bool-mustbeQorK bd v = isDartOrigin bd v && isKiteWing bd v--}- -- |isKiteWing bd v - Vertex v is a kite wing in BoundaryState bd isKiteWing:: BoundaryState -> Vertex -> Bool isKiteWing bd v = v `elem` map wingV (filter isKite (facesAtBV bd v))@@ -1075,14 +1081,9 @@      addU (Right ump) (e,fc)  = do u <- checker bd fc                                    return (Map.insert e u ump) -{-  makeGenerator (deprecated) this is renamed as newUpdateGenerator.-makeGenerator :: UChecker -> UFinder -> UpdateGenerator-makeGenerator = newUpdateGenerator- -}  --   Ten Update Generators (with corresponding Finders) - -- |Update generator for rule (1) wholeTileUpdates:: UpdateGenerator wholeTileUpdates = newUpdateGenerator completeHalf incompleteHalves@@ -1091,9 +1092,6 @@ incompleteHalves :: UFinder 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@@ -1103,10 +1101,8 @@ nonKDarts :: UFinder 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) queenOrKingUpdates :: UpdateGenerator@@ -1116,11 +1112,8 @@ kitesWingDartOrigin :: UFinder 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)      Kites whose short edge (b,a) matches a boundary edge (a,b) where their oppV @@ -1136,11 +1129,8 @@ kiteGaps :: UFinder 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@@ -1151,11 +1141,8 @@ noTouchingDart :: UFinder 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  almostSunStar finds half-kites/half-darts with a long edge on the boundary@@ -1175,13 +1162,8 @@     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. -- The function mustbeJack finds if a vertex must be a jack.@@ -1193,10 +1175,7 @@ jackMissingKite :: UFinder 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@@ -1208,11 +1187,7 @@ kingMissingThirdDart :: UFinder 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@@ -1226,13 +1201,7 @@            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@@ -1246,13 +1215,8 @@         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  @@ -1436,20 +1400,12 @@       face = case find (isAtV a) $ facesAtBV bd b of              Just f -> f              Nothing   -> error $ "inspectBDedge: Not a boundary directed edge " ++ show (a,b) ++ "\n"-{-       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 (a,b) ++ "\n"--}     + {- $Additions Note about face additions: @@ -1552,25 +1508,9 @@ externalAngle:: BoundaryState -> Vertex -> Int externalAngle bd v = 10 - sum (map (intAngleAt v) $ facesAtBV bd v) -{- New intAngleAt has faceIntAngles inlined. Older versions were- -- |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-intAngleAt v fc = faceIntAngles fc !! indexV v fc---- |faceIntAngles returns a list of the three internal angles of a face (clockwise from originV)--- in terms of tenth turns - always 1 or 2 for kites and 1 or 3 for darts.-faceIntAngles :: TileFace -> [Int]-faceIntAngles (LD _) = [1,3,1]-faceIntAngles (RD _) = [1,1,3]-faceIntAngles _      = [1,2,2] -- LK and RK-- -}---- |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 intAngleAt v face@(LD (a,b,c))     | v==a = 1    | v==b = 3@@ -1592,17 +1532,3 @@    | v==c = 2    | otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face) --{--------------------------*************************             -Touching vertex checking -********************************************-requires Diagrams.Prelude for Point and V2---------------------------------------------}-{- --- |touchCheck p vpMap - check if a vertex location p touches (is too close to) any other vertex location in the mapping vpMap-touchCheck:: Point V2 Double -> VertexMap (Point V2 Double) -> Bool-touchCheck p vpMap = not $ VMap.null $ VMap.filter (touching p) vpMap-  -- filtering the map has better performance than checking a list-  -- touchCheck p vpMap = any (touching p) (VMap.elems vpMap) --}

@@ -25,6 +25,7 @@   , Grid   , touching   , ValuedPoint(..)+  , allTouching   , allClashes  ) where@@ -138,13 +139,18 @@     do gd1 <- insertGridCheck ap gd        insertAll more gd1 --- |Use a grid to find all clashing (touching) valued points.+-- |Use a grid to find all touching valued points. -- The function argument is used to extract values from valued points.-allClashes :: ValuedPoint a => (a -> b) -> [a] -> [(b,b)]-allClashes f aps = check aps (Grid IMap.empty) []  where+allTouching :: ValuedPoint a => (a -> b) -> [a] -> [(b,b)]+allTouching f aps = check aps (Grid IMap.empty) []  where   check [] _ cs = cs   check (ap:more) gd cs =       case insertGridCheck ap gd of           Right gd' -> check more gd' cs           Left ap'  -> check more gd ((f ap, f ap'):cs)            -- note ap' earlier than ap in the incoming list++{-# DEPRECATED allClashes "Renamed as allTouching)" #-}+-- | another name for allTouching+allClashes :: ValuedPoint a => (a -> b) -> [a] -> [(b, b)]+allClashes = allTouching

@@ -19,6 +19,7 @@ {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE TupleSections             #-} {-# LANGUAGE Strict                    #-}+{-# LANGUAGE UndecidableInstances      #-}  module Tgraph.Prelude   ( module HalfTile@@ -63,7 +64,13 @@   , crossingBoundaries   , connected --  , connectedBy-   -- * HasFaces operations+   -- * HasGraph operations+  , HasGraph(..)+  , selectFaces+  , removeFaces+  , removeVertices+  , selectVertices+     -- * HasFaces operations   , HasFaces(..) -- faces, boundaryESet, maxV, boundaryVFMap   , boundaryEdgeSet   , boundary@@ -85,6 +92,7 @@   --, boundaryVFMap --  , faces   , nullFaces+  , nullGraph   , evalFaces   , evalFace   , faceCount@@ -98,10 +106,6 @@   , phiEdges   , nonPhiEdges   , defaultAlignment-  , selectFaces-  , removeFaces-  , removeVertices-  , selectVertices   , vertexFMap   , vertexFacesMap   , dedgeFMap@@ -170,12 +174,14 @@   , labelSize   , labelled   , rotating-  , rotateBefore+  , rotatedVP+  , rotateBefore -- deprecated   , dropLabels -- * Tgraph and VPatch alignment with vertices   , aligning-  , alignBefore-  , makeAlignedVP+  , alignBefore -- deprecated+  , alignedVP+  , makeAlignedVP -- deprecated   , centerOn   , alignXaxis   , alignments@@ -257,6 +263,14 @@ newtype Tgraph = Tgraph [TileFace]                   deriving (Show) +-- |A class for types from which a Tgraph can be recovered.+class HasGraph a where+  recoverGraph :: a -> Tgraph++-- |A Tgraph has a Tgraph+instance HasGraph Tgraph where+   recoverGraph = id+ -- |A type used to classify edges of faces. -- Each (halftile) face has a long edge, a short edge and a join edge.  data EdgeType = Short | Long | Join deriving (Show,Eq)@@ -434,14 +448,6 @@ hasEdgeLoops:: HasFaces a => a  -> Bool hasEdgeLoops = not . null . findEdgeLoops -{- -- |duplicates finds any duplicated items in a list (unique results).-duplicates :: Eq a => [a] -> [a]-duplicates = check [] [] where- check dups _ [] = reverse dups- check dups seen (x:xs) | x `elem` dups = check dups seen xs-                        | x `elem` seen = check (x:dups) seen xs-                        | otherwise = check dups (x:seen) xs- -}  -- |duplicates finds any duplicated items in a list. -- It produces unique results (that is duplicates (duplicates es) == [] ).@@ -591,6 +597,10 @@ nullFaces:: HasFaces a => a -> Bool nullFaces = null . faces +-- |does the graph have no faces?+nullGraph :: HasGraph a => a -> Bool+nullGraph g = nullFaces (recoverGraph g)+ -- |Class HasFaces for operations using (a list of) TileFaces. --  -- Used to define common functions on @@ -710,27 +720,30 @@  -- |selects faces from a Tgraph (removing any not in the list), -- but checks resulting Tgraph for connectedness and no crossing boundaries.-selectFaces :: [TileFace] -> Tgraph -> Tgraph-selectFaces fcs g = runTry $ tryConnectedNoCross $ faces g `intersect` fcs+selectFaces :: HasGraph a => [TileFace] -> a -> Tgraph+selectFaces fcs a = runTry $ tryConnectedNoCross $ faces g `intersect` fcs+                    where g = recoverGraph a  -- |removes faces from a Tgraph, -- but checks resulting Tgraph for connectedness and no crossing boundaries.-removeFaces :: [TileFace] -> Tgraph -> Tgraph-removeFaces fcs g = runTry $ tryConnectedNoCross $ faces g \\ fcs-+removeFaces :: HasGraph a => [TileFace] -> a -> Tgraph+removeFaces fcs a = runTry $ tryConnectedNoCross $ faces g \\ fcs+                    where g = recoverGraph a+                     -- |removeVertices vs g - removes any vertex in the list vs from g -- by removing all faces at those vertices. The resulting Tgraph is checked -- for required properties  e.g. connectedness and no crossing boundaries -- and will raise an error if these fail.-removeVertices :: [Vertex] -> Tgraph -> Tgraph-removeVertices vs g = removeFaces (filter (hasVIn vs) (faces g)) g+removeVertices :: HasGraph a => [Vertex] -> a -> Tgraph+removeVertices vs a = removeFaces (filter (hasVIn vs) (faces g)) g+                      where g = recoverGraph a  -- |selectVertices vs g - removes any face that does not have at least one vertex in the list vs from g. -- Resulting Tgraph is checked -- for required properties  e.g. connectedness and no crossing boundaries -- and will raise an error if these fail.-selectVertices :: [Vertex] -> Tgraph -> Tgraph-selectVertices vs g = runTry $ tryConnectedNoCross $ filter (hasVIn vs) $ faces g+selectVertices :: HasGraph a => [Vertex] -> a -> Tgraph+selectVertices vs = runTry . tryConnectedNoCross . filter (hasVIn vs) . faces . recoverGraph  -- |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.@@ -1134,19 +1147,23 @@ instance Transformable VPatch where     transform t vp = vp {vLocs = VMap.map (transform t) (vLocs vp)} + -- |VPatch is in class HasFace instance HasFaces VPatch where     faces = vpFaces-{-     boundaryVFMap = boundaryVFMap . faces -- need for nub (from [TileFace] instance)+{-  Default implementations for+    boundaryVFMap = boundaryVFMap . faces -- need for nub (from [TileFace] instance)     boundary = boundary . faces     maxV = maxV . faces  -}-{-|Convert a Tgraph to a VPatch.++{-|Convert something with a Tgraph to a VPatch. This uses locateGraphVertices to form an intermediate VertexLocMap (mapping of vertices to positions). This makes the join of the face with lowest origin and lowest oppV align on the positive x axis. -}-makeVP::Tgraph -> VPatch-makeVP g = VPatch {vLocs = locateGraphVertices g, vpFaces  = faces g}+makeVP::HasGraph a => a -> VPatch+makeVP a = VPatch {vLocs = locateGraphVertices g, vpFaces  = faces g}+           where g = recoverGraph a  -- |subFaces a vp, creates a new VPatch from faces in a, using the vertex location map from vp. -- The vertices in the faces should have locations assigned in vp vertex locations.@@ -1215,6 +1232,7 @@     _ -> error $ "dropLabels: Vertex location not found for some vertices:\n    "                 ++ show (faceVList face \\ VMap.keys locations)  ++ "\n" + -- |Tgraphs are Drawable instance Drawable Tgraph where     drawWith pd = drawWith pd . makeVP@@ -1255,13 +1273,18 @@ rotateBefore :: (VPatch -> a) -> Angle Double -> Tgraph -> a rotateBefore = flip rotating --- |rotating a vfun g - makes a VPatch from g then rotates by angle a before applying the VPatch function vfun.--- Tgraphs need to be rotating after a VPatch is calculated but before any labelled drawing.+-- |rotating a vfun g - makes a VPatch from g then rotates by angle a before applying vfun +-- (a VPatch continuation function - usually a drawing function).+-- Tgraphs need to be rotated after a VPatch is calculated but before any labelled drawing. -- -- E.g. rotating angle (labelled draw) graph.-rotating :: Angle Double -> (VPatch -> a) -> Tgraph -> a-rotating angle vfun = vfun . rotate angle . makeVP+rotating :: HasGraph a => Angle Double -> (VPatch -> b) -> a -> b+rotating angle vfun = vfun . rotatedVP angle +-- |rotatedVP angle g - make a VP for g then rotate by angle+rotatedVP :: HasGraph a => Angle Double -> a -> VPatch+rotatedVP angle = rotate angle . makeVP+ -- |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 =@@ -1284,28 +1307,29 @@  -- |alignments takes a list of vertex pairs for respective alignments of VPatches in the second list. -- 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.+-- The vertex pair list can be shorter than the list of VPatch - the remaining VPatches 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 [] 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+alignments prs vps = if length prs > length vps+                     then error "alignments: Too many alignment pairs.\n"+                     else zipWith alignXaxis prs vps +{-# DEPRECATED alignAll "Use (map . alignXaxis)" #-} -- |alignAll (a,b) vpList -- 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 (a,b) = map (alignXaxis (a,b))+alignAll  = map . alignXaxis  -- |aligning (a,b) vfun g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis--- before applying the VPatch function vfun+-- before applying vfun (a VPatch continuation function - usually a drawing function) -- Will raise an error if either a or b is not a vertex in g. -- Tgraphs need to be aligned after a VPatch is calculated but before any labelled drawing. -- -- E.g. aligning (a,b) (labelled draw) g-aligning ::  (Vertex,Vertex) -> (VPatch -> a) -> Tgraph -> a-aligning vs vfun = vfun . alignXaxis vs . makeVP+aligning ::  HasGraph a => (Vertex,Vertex) -> (VPatch -> b) -> a -> b+aligning vs vfun = vfun . alignedVP vs  {-# DEPRECATED alignBefore "Use (flip aligning)" #-} -- |alignBefore vfun (a,b) g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis@@ -1317,10 +1341,16 @@  -- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligning 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 vs = aligning vs id+alignedVP:: HasGraph a => (Vertex,Vertex) -> a -> VPatch+alignedVP vs = alignXaxis vs . makeVP +{-# DEPRECATED makeAlignedVP "Renamed as alignedVP" #-}+-- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligning on the x-axis.+-- Will raise an error if either a or b is not a vertex in g.+makeAlignedVP:: HasGraph a => (Vertex,Vertex) -> a -> VPatch+makeAlignedVP = alignedVP + -- |produce a diagram of a list of edges (given a suitable VPatch) -- Will raise an error if any vertex of the edges is not a key in the vertex to location mapping of the VPatch. drawEdgesVP :: OKBackend b =>@@ -1466,7 +1496,7 @@ touchingVertices:: HasFaces a => a -> [(Vertex,Vertex)] touchingVertices fcs = check vpAssocs where   vpAssocs = VMap.assocs $ locateVertices fcs  -- assocs puts in increasing key order so that check returns (higher,lower) pairs-  check = allClashes fst+  check = allTouching fst -- using Grid to check (fst is used to extract Vertex numbers for the results)    @@ -1483,7 +1513,7 @@ touchingVerticesGen:: HasFaces a => a -> [(Vertex,Vertex)] touchingVerticesGen fcs = check vpAssocs where   vpAssocs = VMap.assocs $ locateVerticesGen fcs  -- assocs puts in increasing key order so that check returns (higher,lower) pairs-  check = allClashes fst+  check = allTouching fst -- using Grid to check (fst is used to extract Vertex numbers for the results)  {-| locateVerticesGen  (not exported but used in touchingVerticesGen). This generalises locateVertices to allow for multiple faces sharing an edge. This can arise when applied to the union of faces from 2 Tgraphs (e.g. in commonFaces).

@@ -360,9 +360,9 @@  boundaryFDart4, boundaryFDart5 :: Tgraph -- |graph of the boundary faces only of a forced graph (dartDs!!4)-boundaryFDart4 = makeUncheckedTgraph $ boundaryVFaces $ force $ makeBoundaryState dartD4+boundaryFDart4 = runTry $ tryBoundaryFaceGraph $ force $ initFS dartD4 -- |graph of the boundary faces only of a forced graph (dartDs!!5)-boundaryFDart5 = makeUncheckedTgraph $ boundaryVFaces $ force $ makeBoundaryState (dartDs!!5)+boundaryFDart5 = runTry $ tryBoundaryFaceGraph $ force $ initFS (dartDs!!5)  boundaryFDart4Fig,boundaryFDart5Fig :: OKBackend b => Diagram b -- |figure of the boundary faces only of a forced graph (dartDs!!4).@@ -385,31 +385,31 @@ -- |figure for the boundary gap graph boundaryGapFDart5. boundaryGap5Fig = padBorder $ lw ultraThin $ smart (labelSize (normalized 0.006) draw) boundaryGapFDart5 --- | boundaryVCoveringFigs bd - produces a list of diagrams for the boundaryVCovering of bd --- (with the Tgraph represented by bd shown in red in each case).+-- | boundaryVCoveringFigs fs - produces a list of diagrams for the boundaryVCovering of fs +-- (with the Tgraph represented by fs shown in red in each case). boundaryVCoveringFigs :: OKBackend b =>-                         Forced BoundaryState -> [Diagram b]-boundaryVCoveringFigs bd =-    lw ultraThin . (redg <>) . aligning alig draw  . (recoverGraph . forgetF) <$> boundaryVCovering bd+                         Forced ForceState -> [Diagram b]+boundaryVCoveringFigs fs =+    lw ultraThin . (redg <>) . aligning alig draw  . recoverGraph <$> boundaryVCovering fs       where redg = lc red $ draw g             alig = defaultAlignment g-            g = recoverGraph $ forgetF bd+            g = recoverGraph fs  -- | boundaryECoveringFigs bd - produces a list of diagrams for the boundaryECovering of bd   -- (with the Tgraph represented by bd shown in red in each case). boundaryECoveringFigs :: OKBackend b =>-                         Forced BoundaryState -> [Diagram b]-boundaryECoveringFigs bd =-    lw ultraThin . (redg <>) . aligning alig draw  . recoverGraph . forgetF  <$> boundaryECovering bd+                         Forced ForceState -> [Diagram b]+boundaryECoveringFigs fs =+    lw ultraThin . (redg <>) . aligning alig draw  . recoverGraph <$> boundaryECovering fs       where redg = lc red $ draw g             alig = defaultAlignment g-            g = recoverGraph $ forgetF bd+            g = recoverGraph fs  kingECoveringFig,kingVCoveringFig :: OKBackend b => Diagram b -- | diagram showing the boundaryECovering of a forced kingGraph.-kingECoveringFig = padBorder $ arrangeRows 3 $ boundaryECoveringFigs $ forceF $ makeBoundaryState kingGraph+kingECoveringFig = padBorder $ arrangeRows 3 $ boundaryECoveringFigs $ forceF $ initFS kingGraph -- | diagram showing the boundaryVCovering of a forced kingGraph.-kingVCoveringFig = padBorder $ arrangeRows 3 $ boundaryVCoveringFigs $ forceF $ makeBoundaryState kingGraph+kingVCoveringFig = padBorder $ arrangeRows 3 $ boundaryVCoveringFigs $ forceF $ initFS kingGraph  kingEmpiresFig, kingEmpire1Fig, kingEmpire2Fig :: OKBackend b => Diagram b -- | figure showing King's empires (1 and 2).@@ -422,22 +422,23 @@  -- |emplaceChoices forces then maximally composes. At this top level it -- produces a list of forced choices for each of the unknowns of this top level Tgraph.--- It then repeatedly applies (forceF . decompose . forgetF) back to the starting level to return a list of Forced Tgraphs.+-- It then repeatedly applies (forceF . decompose ) back to the starting level to return a list of Forced Tgraphs. -- This version relies on compForce theorem and related theorems emplaceChoices:: Tgraph -> [Forced Tgraph] emplaceChoices = emplaceChoicesF . forceF  where    emplaceChoicesF:: Forced Tgraph -> [Forced Tgraph]-  emplaceChoicesF fg | nullFaces compfg = chooseUnknowns [(unknowns $ getDartWingInfoForced fg, fg)]-                          | otherwise    = forceF . decompose . forgetF <$> emplaceChoicesF compfg+  emplaceChoicesF fg | nullGraph compfg = chooseUnknowns [(unknowns $ getDartWingInfoForced fg, fg)]+                          | otherwise    = forceF . decompose <$> emplaceChoicesF compfg                           where compfg = composeF fg   chooseUnknowns :: [([Vertex],Forced Tgraph)] -> [Forced Tgraph]   chooseUnknowns [] = []   chooseUnknowns (([],g0):more) = g0:chooseUnknowns more   chooseUnknowns ((u:unks,g0): more)      =  chooseUnknowns (map (remainingunks unks) newgs ++ more)-        where newgs = map recoverGraphF $ atLeastOne $ (tryDartAndKiteF (findDartLongForWing u bd) bd)-              bd = makeBoundaryState (forgetF g0)+        where newgs = map (withForced recoverGraph) $ runTry $ tryCheckCasesDKF de g0+--        where newgs = map (withForced recoverGraph) $ atLeastOne $ (tryDartAndKiteF (findDartLongForWing u bd) bd)+              de = findDartLongForWing u $ makeBoundaryState (forgetF g0)               remainingunks startunks g' = (startunks `intersect` boundaryVsDup g', g')    findDartLongForWing :: Vertex -> BoundaryState -> Dedge@@ -448,7 +449,7 @@  -- |Example showing emplaceChoices for foolD with foolD shown in red in each choice emplaceChoicesFig :: OKBackend b => Diagram b-emplaceChoicesFig =  lw thin $ hsep 1 $  (overlayg . forgetF) <$> emplaceChoices g+emplaceChoicesFig =  lw thin $ hsep 1 $  overlayg <$> emplaceChoices g     where g = foolD           overlayg g' = smartAligning algmnt draw g # lc red <> aligning algmnt draw  g'           algmnt = defaultAlignment $ maxCompForce g

@@ -467,18 +467,18 @@ -- It will raise an error if the integer list is longer than the list of items to be rotated. -- (Rotations by an angle are anti-clockwise) rotations :: (Transformable a, V a ~ V2, N a ~ Double) => [Int] -> [a] -> [a]-rotations (n:ns) (d:ds) = rotate (ttangle n) d: rotations ns ds-rotations [] ds = ds-rotations _  [] = error "rotations: too many rotation integers"+rotations ns xs = if length ns > length xs+                  then error "rotations: too many rotation integers"+                  else zipWith (rotate . ttangle) ns xs  -- |scales takes a list of doubles for respective scalings of items in the second list (things to be scaled). -- This includes Diagrams, Pieces, Patches, VPatches. -- The list of doubles can be shorter than the list of items - the remaining items are left unscaled. -- It will raise an error if the integer list is longer than the list of items to be scaled. scales :: (Transformable a, V a ~ V2, N a ~ Double) => [Double] -> [a] -> [a]-scales (s:ss) (d:ds) = scale s d: scales ss ds-scales [] ds = ds-scales _  [] = error "scales: too many scalars"+scales ss xs = if length ss > length xs+               then error "scales: too many scalars"+               else zipWith scale ss xs  -- |increasing scales by a factor of phi along a list starting with 1. phiScales:: (Transformable a, V a ~ V2, N a ~ Double) => [a] -> [a]

@@ -126,14 +126,14 @@          faceCount dD6  `shouldBe` 466     context "Composing Forced Tgraphs" $       it "Number of faces of maxCompForce (dartDs !!6) should be 6" $-         faceCount (forgetF $ maxCompForce dD6) `shouldBe` 6+         faceCount (maxCompForce dD6) `shouldBe` 6     context "Forcing Tgraphs" $       it "Number of faces of force (dartDs !!6) should be 7546" $          faceCount(force dD6) `shouldBe` 7546-    context "partCompose and Force" $+    context "partCompose and force" $       it "Number of remainder faces when part composing force (dartDs !!3) should be 58" $          faceCount(fst $ partCompose $ force $ dartDs !!3) `shouldBe` 58-    context "partComposeF and ForceF" $+    context "partComposeF and forceF" $       it "Number of remainder faces when part composing forceF (dartDs !!3) should be 58" $          faceCount(fst $ partComposeF $ forceF $ dartDs !!3) `shouldBe` 58     context "partCompose of reduced Tgraph (extraBrokenDart)" $