PenroseKiteDart 1.8.1 → 1.9

raw patch · 11 files changed

+793/−765 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +46/−7
• PenroseKiteDart.cabal +1/−1
• benchmark/Bench.hs +15/−6
• src/Tgraph/Compose.hs +290/−163
• src/Tgraph/Extras.hs +22/−93
• src/Tgraph/Force.hs +178/−161
• src/Tgraph/Grid.hs +8/−13
• src/Tgraph/Prelude.hs +225/−303
• src/Tgraph/Relabelling.hs +3/−17
• src/TgraphExamples.hs +2/−1
• test/Spec.hs +3/−0

@@ -1,10 +1,49 @@ # Revision history for PenroseKiteDart -## version v1.8.1+## version 1.9 +- Possibly breaking changes:+   - Replaced type UpdateMap with new data type Updates (using two maps).+   - Renamed selector updateMap to updates (in ForceState)+   - partComposeDWI has a different type returning a Tgraph with the remainder faces+   - Renamed matchingLongE,matchingJoinE,matchingShortE to sharingLongE,sharingJoinE,sharingShortE+   - Change to DartWingInfo. Selector unMapped is changed to remaining. The remaining list now includes all kites without a dart wing at their oppV.+- Removed Deprecated:+   - partComposeFaces - use - (runTry . tryPartComposeFaces)+   - boundaryEdgeSet - use - boundaryESet+   - boundaryVertexSet - use - boundaryVSet+   - vertexFacesMap - use - (vertexFMap . IntSet.fromList)+   - dedgesFacesMap - use - dedgeFMap+   - boundaryEdgeFaces - use - boundaryEFaces+   - rotateBefore - use - (flip rotating)+   - alignAll - use - (map . alignXaxis)+   - alignBefore - use - (flip aligning)+   - makeAlignedVP  - use - alignedVP+   - tryOneStepForce - use - tryOneStep+   - recoverGraphF - use - (withForced recoverGraph)+   - boundaryStateF - use - (withForced boundaryState)+   - makeBoundaryStateF - use - (withForced makeBoundaryState)+   - initFSF - use - (withForced initFS)+   - relabelContig - use - (relabelFrom 1)+   - checkRelabelGraph - use - relabelGraph+   - smartRotateBefore - use - (flip smartRotating)+   - smartAlignBefore - use - (flip smartAligning)+   - drawTrackedTgraphAligned - use - (flip drawTrackedTgraphAligning)+   - drawTrackedTgraphRotated - use - (flip drawTrackedTgraphRotating)+   - allClashes - use - allTouching+- Other Changes+  - Added: quickCompose and quickPartCompose (approximations to compose and partCompose that do not use a force operation)+  - Added experimental tryForceAt+  - Added experimental tryGetDartWingInfoLocal+  - Added: verticesForBEs, vertexSetForEdges+  - deprecated noNewConflict (renamed as compatibleNew)+  - More laziness in BoundaryState (avoids vertex location calculation until any unsafe update)++## version 1.8.1+ Fixed bug (introduced in 1.8) rotations and scales not behaving as described. -## version v1.8+## version 1.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@@ -27,7 +66,7 @@   - superForce now produces Forced Tgraph (compose with forgetF to obtain Tgraph)  -## version v1.7+## version 1.7  Significant speed up of forcing. @@ -43,7 +82,7 @@   - Exported tryOnBoundary, isBoundaryDE, isBoundaryV   - Used smart on boundaryFDart.. and boundaryGap.. example figures. -## version v1.6.1+## version 1.6.1  - Internal Representation change:     - Changed type of BoundaryDedges in BoundaryState (constructors not exported)@@ -62,7 +101,7 @@     - Deprecated partComposeFaces (now renamed as partComposeDWI)     - Changed emphasizeFaces to use smartOn so only boundary joins are drawn (used in commonFaces) -## version v1.6+## version 1.6 - Possibly breaking:     - Replaced boundary in class HasFaces with boundaryESet (Set instead of list)@@ -109,7 +148,7 @@    - dashjPiece Use drawjPiece    - dashjP3 Use drawjP3 -## version v1.5.1+## version 1.5.1  - possibly breaking:     added boundaryVFMap to class HasFaces@@ -148,7 +187,7 @@ - added: dashJOnly, drawJPiece, and drawJ  (alongside dashjOnly, drawjPiece, and drawj which still use ultraThin)  -## version v1.5 2025-8-9+## version 1.5 2025-8-9  Changes to composing. 

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

@@ -7,7 +7,7 @@  main :: IO () main = -  do let wait = threadDelay 100000+  do let wait = threadDelay 25000      wait      _ <- traceMarkerIO "starting decompositions"       let !kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n@@ -26,17 +26,26 @@      _ <- traceMarkerIO "finished force"       wait      _ <- traceMarkerIO "starting (unchecked) composing" -     let cfkD = {-# SCC "composing" #-} forgetF $ last $ takeWhile (not . nullFaces . forgetF) $ iterate composeF fkD+     let !cfkD = {-# SCC "composing" #-} forgetF $ last $ takeWhile (not . nullFaces . forgetF) $ iterate composeF fkD      putStrLn $ "Number of faces of recomposed force (" ++ sn ++ " times decomposed King) is "                              ++ show (faceCount cfkD)      putStrLn $ "Max vertex of recomposed force (" ++ sn ++ " times decomposed King) is "                              ++ show (maxV cfkD)      _  <- traceMarkerIO "finished (unchecked) composing" +     wait+     _ <- traceMarkerIO "starting checked compose" +     let !newcfkD = {-# SCC "checkedCompose" #-} compose $ recoverGraph fkD+     putStrLn $ "Number of faces of new checked compose is " +                            ++ show (faceCount newcfkD)+     _  <- traceMarkerIO "finished checked compose" +     wait+     _ <- traceMarkerIO "starting quickCompose" +     let !qcfkD = {-# SCC "quickCompose" #-} quickCompose $ recoverGraph fkD+     putStrLn $ "Number of faces of quickCompose is " +                            ++ show (faceCount qcfkD)+     _  <- traceMarkerIO "finished quickCompose"       return ()-{--     putStrLn $ "Number of faces of reforced force (" ++ sn ++ " times decomposed King) is " -                            ++ show (faceCount rcfkD)--}+         where        sn = show n

@@ -8,12 +8,9 @@  This module includes the main composition operations compose, partCompose, tryPartCompose and the more efficient versions composeF, partComposeF (for explicitly forced Tgraphs).-It also exposes -auxiliary functions-tryGetDartWingInfo, getDartWingInfoForced (and type DartWingInfo)-for debugging but getDartWingInfoForced is no longer used internally.+It also exposes some auxiliary functions for debugging/experimental purposes. -}--- {-# LANGUAGE Strict                #-} +{-# LANGUAGE Strict                #-}  {-# OPTIONS_GHC -Wno-deprecations  #-}  module Tgraph.Compose @@ -24,46 +21,47 @@   , compose   , partCompose   , tryPartCompose-  , tryPartComposeFaces+  , quickCompose+  , quickPartCompose   -- * Exported auxiliary functions (and type)+  , tryPartComposeFaces   , partComposeDWI-  , partComposeFaces   , DartWingInfo(..)-  -- , getDWIassumeF-  -- , getDartWingInfo   , tryGetDartWingInfo+  , tryGetDartWingInfoLocal   , getDartWingInfoForced   ) where -import Data.List (find,(\\),partition,nub)+import Data.List (find,(\\),partition) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..))-import qualified Data.IntMap.Strict as VMap (lookup,(!),alter,empty,elems,keys)-import Data.Maybe (catMaybes,mapMaybe)-import qualified Data.IntSet as IntSet (empty,insert,toList,member)-+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as VMap (lookup,(!),alter,empty,keys,member)+import Data.Maybe (catMaybes, fromMaybe)+import Data.IntSet(IntSet)+import qualified Data.IntSet as IntSet (empty,insert,toList) import Tgraph.Prelude-import Tgraph.Force ( Forced(), forgetF, labelAsForced, tryForceF )-{--------------------------------------------------------------------------***************************************************************************              -COMPOSING compose, partCompose, tryPartCompose, ...-***************************************************************************----------------------------------------------------------------------------}+import Tgraph.Force ( Forced(), forgetF, labelAsForced, tryForce, tryForceAt ) --- |The main compose (partial) function which simply drops the remainder faces from partCompose to return just--- the composed Tgraph.  It will raise an error if the result is not a valid Tgraph--- (i.e. if it fails the connectedness, no crossing boundary check).--- It does not assume the given Tgraph is forced.--- It can raise an error if the Tgraph is found to be incorrect (when getting dartwing info).+-- |The general compose (partial) function which simply drops the remainder faces from partCompose to return just+-- the composed Tgraph. +-- It does not assume the given Tgraph is forced which makes it an expensive operation on large Tgraphs.+-- It inspects the forced version to classify dart wings (hence costing a force operation).+-- It can raise an error if the Tgraph is found to be incorrect when calculating the forced version).+-- It will raise an error if the result is not a valid Tgraph+-- (i.e. if it fails the connectedness, no crossing boundary check at the end).+-- (See also composeF and compForce and quickCompose.) 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) --- and a composed Tgraph. --- It checks the composed Tgraph for connectedness and no crossing boundaries+-- and a composed Tgraph.+-- It does not assume the given Tgraph is forced which makes it an expensive operation on large Tgraphs.+-- It inspects the forced version to classify dart wings (hence costing a force operation).+-- It can raise an error if the Tgraph is found to be incorrect when calculating the forced version).+-- It checks the composed faces for connectedness and no crossing boundaries -- 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).+-- (See also partComposeF and quickPartCompose.) partCompose:: HasGraph a => a -> ([TileFace],Tgraph) partCompose = runTry . onFail "partCompose:\n" . tryPartCompose . recoverGraph @@ -84,52 +82,48 @@ tryPartComposeFaces:: HasGraph a => a -> Try ([TileFace],[TileFace]) tryPartComposeFaces g =    do dwInfo <- tryGetDartWingInfo g -     return $ partComposeFaces dwInfo+     return $ partComposeFacesDWI dwInfo -- tryPartComposeFaces is used in an example showing failure of the connected, no crossing boundary check.   -- |partComposeF fg - produces a pair consisting of remainder faces (faces from fg which will not compose)  -- and a composed (Forced) Tgraph.--- Since fg is a forced Tgraph it does not need a check for validity of the composed Tgraph.+-- Since fg is a forced Tgraph it does not need a check for validity (connected and no crossing boundaries) of the composed Tgraph. -- The fact that the function is total and the result is also Forced relies on theorems -- 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:: HasGraph a => Forced a -> ([TileFace], Forced Tgraph) partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph newfaces) where   -- !evalnewfaces = evalFaces newfaces-  (_,dwFMap,unused) = dartsMapUnused (recoverGraph fg)-  (remainder,newfaces) = process (VMap.keys dwFMap) (unused,[])-  process [] res = res-  process (w:more) (rems, nfcs) = -      let fcs = dwFMap  VMap.! w-      in case length fcs of-           -- 8 faces = large dart base, 6 faces = lrge kite centre, 3 faces = unknown on boundary-           8 -> process more (rems, catMaybes [largeRD fcs, largeLD fcs] ++ nfcs)-           6 -> process more (rems, catMaybes [largeRK fcs, largeLK fcs] ++ nfcs)-           3 -> process more (fcs++rems, nfcs)-           other -> error $ -                     "partComposeF: Not possible for a forced Tgraph\n" ++-                     "Number of faces should be 8,6,or 3 but found " ++ show other ++-                     "\nat dart wing vertex: " ++ show w ++ "\n"+  (dwFMap,unused) = dwMapUnused (recoverGraph fg)+  (remainder,newfaces) = foldl' checkDW (unused,[]) (VMap.keys dwFMap)+  checkDW (rems, nfcs) w = +     let fcs = dwFMap  VMap.! w+     in case length fcs of+          -- 8 faces = large dart base+          8 -> (rems, catMaybes [largeRD fcs, largeLD fcs] ++ nfcs)+          -- 6 faces = lrge kite centre+          6 -> (rems, catMaybes [largeRK fcs, largeLK fcs] ++ nfcs)+          -- 3 faces = unknown on boundary+          3 -> (fcs++rems, nfcs)+          other -> error $ +                    "partComposeF: Not possible for a forced Tgraph\n" +++                    "Number of faces should be 8,6,or 3 but found " ++ show other +++                    "\nat dart wing vertex: " ++ show w ++ "\n"+   largeRD fcs = do rd <- find isRD fcs                    lk <- find ((==oppV rd) . wingV) fcs-                   let !f = evalFace $ makeRD (originV lk) (originV rd) (wingV rd)-                   return f+                   return $ makeRD (originV lk) (originV rd) (wingV rd)   largeLD fcs = do ld <- find isLD fcs                    rk <- find ((==oppV ld) . wingV) fcs-                   let !f = evalFace $ makeLD (originV rk) (wingV ld) (originV ld)-                   return f+                   return $ makeLD (originV rk) (wingV ld) (originV ld)   largeRK fcs = do rd  <- find isRD fcs                    lk <- find ((==oppV rd) . wingV) fcs-                   rk <- find (matchingJoinE lk) fcs-                   let !f = evalFace $ makeRK (originV rd) (wingV rk) (originV lk)-                   return f+                   rk <- find (sharedJoinE lk) fcs+                   return $ makeRK (originV rd) (wingV rk) (originV lk)   largeLK fcs = do ld  <- find isLD fcs                    rk <- find ((==oppV ld) . wingV) fcs-                   lk <- find (matchingJoinE rk) fcs-                   let !f = evalFace $ makeLK (originV ld) (originV rk) (wingV lk)-                   return f+                   lk <- find (sharedJoinE rk) fcs+                   return $ makeLK (originV ld) (originV rk) (wingV lk)   -- |composeF - produces a composed Forced Tgraph from a Forced Tgraph.@@ -141,23 +135,53 @@  -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. -- Faces at a largeKiteCentre vertex will form kite faces when composed.--- Faces at a largeDartBase vertex will form dart faces when composed.+-- Faces at a largeDartBase vertex will form dart faces when composed (excludin kites with origin at the largeDartBase). -- Faces at an unknown vertex cannot be composed. -- The record includes a faceMap from dart wings to faces at that vertex.--- and a list of any faces (necessarily kites) not included in the faceMap (unMapped)+-- A list (remaining) of faces that will necessarily be remainder faces.+-- (this includes kite-halves not in the faceMap and those kite halves only in the faceMap at the kite origin.+--+-- NB. Kites that only have a dart wing at their origin, are added to the map for dart wing classification purposes+-- but not used when composing at largeDartBases, hence they need to be recorded as remaining as well.+-- Such kites cannot exist in a forced Tgraph, so this only arises when composing unforced Tgraphs. data DartWingInfo =  DartWingInfo       { largeKiteCentres  :: [Vertex] -- ^ dart wing vertices classified as large kite centres.      , largeDartBases  :: [Vertex]  -- ^ dart wing vertices classified as large dart bases.      , unknowns :: [Vertex] -- ^ unclassified (boundary) dart wing vertices.      , faceMap :: VertexMap [TileFace] -- ^ a mapping from dart wing vertices to faces at the vertex.-     , unMapped :: [TileFace] -- ^ any faces not at a dart wing vertex (necessarily kites)+     , remaining :: [TileFace] -- ^ any kites whose oppV is not at a dart wing vertex.      } deriving Show --- |Recover a list of faces (no repetitions) contained in the dart wing info.+{- -- |Recover a list of faces (no repetitions) contained in the dart wing info. -- (These should be all faces of the Tgraph used to make the dart wing info.) recoverFaces :: DartWingInfo -> [TileFace]-recoverFaces dwInfo =  nub $ concat (unMapped dwInfo : VMap.elems (faceMap dwInfo))+recoverFaces dwInfo =  nub $ concat (remaining dwInfo : VMap.elems (faceMap dwInfo))+ -} +-- | Not exported. (Used by tryGetDartWingInfo and getDartWingInfoForced.)+-- Requires a dart wing IntMap which must be from a forced Tgraph+-- Returns a triple of (largeKiteCentres, largeDartBases, Unknowns)+classifyDartWings :: IntMap [TileFace]-> [Vertex] -> (IntSet,IntSet,IntSet)+classifyDartWings dwMap = foldl' classifyDartWing (IntSet.empty, IntSet.empty, IntSet.empty) where+-- kcs = kite centres of larger kites,+-- dbs = dart bases of larger darts,+-- unks = unclassified dart wing vertices+-- Uses a triple of IntSets rather than lists+-- Uses the forced version to classify dart wings from the original +  classifyDartWing (kcs, dbs, unks) w =+    let fcs = dwMap VMap.! w+    in case length fcs of+        -- 8 faces = large dart base+        8 -> (kcs,IntSet.insert w dbs,unks)+        -- 6 faces = lrge kite centre+        6 -> (IntSet.insert w kcs,dbs,unks)+        -- 3 faces = unknown on boundary+        3 -> (kcs,dbs,IntSet.insert w unks)+        other -> error $ +                 "classifyDartWings: Not possible for forced version of Tgraph\n" +++                 "(called by either tryGetDartWingInfo or getDartWingInfoForced).\n " +++                 "Number of faces should be 8,6,or 3 in forced version of Tgraph but found " ++ show other +++                 "\nat dart wing vertex: " ++ show w ++ "\n"  -- |The given Tgraph is not assumed to be forced. -- Getting the dart wing information makes use of the forced version@@ -165,65 +189,160 @@ -- the Tgraph is found to be incorrect. 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+  do let g = recoverGraph a+         (dwFMap,unused) = dwMapUnused g +     fg <- onFail "tryGetDartWingInfo: incorrect Tgraph (found during forcing).\n" $ tryForce g+     let dwFMapForced = extendMap dwFMap (extraFaces (faces fg) (faces g)) -- dwMapUnused fg+         -- forced version is used for classifying (but darts from original graph)+         (allKcs,allDbs,allUnks) = classifyDartWings dwFMapForced (VMap.keys dwFMap) --(map wingV drts)  +     return $ DartWingInfo +               { largeKiteCentres = IntSet.toList allKcs+               , largeDartBases = IntSet.toList allDbs+               , unknowns = IntSet.toList allUnks+               , faceMap = dwFMap -- original map (not forced version)+               , remaining = unused -- from original Tgraph+               } +-- | Not exported , used by tryGetDartWingInfo to extend an existing dartwing faces map+-- only at the existing dart wings using new faces.+extendMap :: VertexMap [TileFace] -> [TileFace] -> VertexMap [TileFace]+extendMap dwm fcs = dwmFinal where+  (drts,kts) = partition isDart fcs+  dwm1 = foldl' insertDIF dwm drts+  dwmFinal = foldl' insertKIF dwm1 kts+  insertDIF m d = VMap.alter (addF d) (wingV d) m+  insertKIF m k = VMap.alter (addF k) (oppV k) $ VMap.alter (addF k) (originV k) m+  addF _ Nothing = Nothing  -- not added to map if it is not a dart wing vertex+  addF f (Just fs) = Just (f:fs)++-- | Not exported , used by tryGetDartWingInfo to get the new faces added to a forced tgraph.+-- It assumes the first list of faces extends the second list only by adding to the front.+-- It returns the front part of the list that has been added.+extraFaces :: [TileFace] -> [TileFace] -> [TileFace]+extraFaces fg [] = fg+extraFaces fg (f:_) = takeWhile (/= f) fg++-- |Experimental version of tryGetDartWingInfo that only forces at the dart wings+-- rather than a complete force to retrieve dart wing information.+tryGetDartWingInfoLocal :: HasGraph a => a -> Try DartWingInfo+tryGetDartWingInfoLocal a =+  do let g = recoverGraph a+         (dwFMap,unused) = dwMapUnused g+         wings = VMap.keys dwFMap+     fg <- onFail "tryGetDartWingInfoLocal: incorrect Tgraph (found during forcing).\n" $ tryForceAt wings g+     let dwFMapExtra = extendMap dwFMap (extraFaces (faces fg) (faces g)) --dwMapUnused fg+         -- forced version is used for classifying (but darts from original graph)+         (allKcs,allDbs,allUnks) = classifyDartWings dwFMapExtra (VMap.keys dwFMap)  +     return $ DartWingInfo +               { largeKiteCentres = IntSet.toList allKcs+               , largeDartBases = IntSet.toList allDbs+               , unknowns = IntSet.toList allUnks+               , faceMap = dwFMap -- original map (not forced version)+               , remaining = unused -- from original Tgraph+               }+ -- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg -- and calculates a faceMap for each dart wing, returning as DartWingInfo. -- The classification is much simplified knowing that the Tgraph is forced.-getDartWingInfoForced :: Forced Tgraph -> DartWingInfo-getDartWingInfoForced fg = getDWIassumeF True (forgetF fg) fg---- | getDWIassumeF (not exported but used to define 2 cases getDartWingInfoForced and tryGetDartWingInfo).--- getDWIassumeF isForced g fg (where fg is forceF g), classifies the dart wings in g and calculates a faceMap for each dart wing,--- returning as DartWingInfo. The boolean isForced is used to decide if g can be assumed to be forced.--- When this is True, the classification is simpler and does not use fg.-getDWIassumeF:: Bool -> Tgraph -> Forced Tgraph -> DartWingInfo-getDWIassumeF isForced g fg =  +getDartWingInfoForced:: Forced Tgraph -> DartWingInfo+getDartWingInfoForced fg =     DartWingInfo { largeKiteCentres = IntSet.toList allKcs                , largeDartBases = IntSet.toList allDbs                , unknowns = IntSet.toList allUnks                , faceMap = dwFMap-               , unMapped = unused+               , remaining = unused                } where-  (drts,dwFMap,unused) = dartsMapUnused g-  (allKcs,allDbs,allUnks) = foldl' processD (IntSet.empty, IntSet.empty, IntSet.empty) drts  --- kcs = kite centres of larger kites,--- dbs = dart bases of larger darts,--- unks = unclassified dart wing vertices--- Uses a triple of IntSets rather than lists-  processD (kcs, dbs, unks) drt =-    let w = wingV drt-        revLongE = reverseD (longE drt)-    in-        if w `IntSet.member` kcs || w `IntSet.member` dbs then (kcs, dbs, unks) else-- already classified-        let-            fcs = dwFMap VMap.! w -- list of  faces at w-        in-            if w `elem` map originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else -                    -- wing is a half kite origin => largeDartBase- --           if revLongE `elem` map longE (filter isDart fcs) then (IntSet.insert w kcs,dbs,unks) else -            if any (matchingLongE drt) (filter isDart fcs) then (IntSet.insert w kcs,dbs,unks) else -                     -- long edge drt shared with another dart => largeKiteCentre-            if isForced then (kcs, dbs, IntSet.insert w unks) else-            let     -- (when not already forced) do same checks but with forced faces -                ffcs = filter (isAtV w) (faces fg)-            in-                if w `elem` map originV (filter isKite ffcs) then (kcs,IntSet.insert w dbs,unks) else -                    -- wing is a half kite origin => largeDartBase-                if revLongE `elem` map longE (filter isDart ffcs) then (IntSet.insert w kcs,dbs,unks) else -                    -- long edge drt shared with another dart => largeKiteCentre-                (kcs,dbs,IntSet.insert w unks) -- on the forced boundary so must be unknown+  (dwFMap,unused) = dwMapUnused (forgetF fg)+  (allKcs,allDbs,allUnks) = classifyDartWings dwFMap  (VMap.keys dwFMap) --(map wingV drts)   +-- |A faster version of compose which may underestimate the composable faces.+-- It does not use force to check classification of dart wings, so some dart wings may be+-- incorrectly classified as unknown (leaving fewer composed faces).+-- It checks the resulting Tgraph for connected and no crossing boundaries, so+-- it can raise an error if this check fails.+-- It will always be correct on a forced Tgraph.+quickCompose :: HasGraph a => a -> Tgraph+quickCompose = snd . quickPartCompose --- |Not exported - used in partComposeF and in getDWIassumeF.--- Returns a triple of:---   list of all half-darts,---   a dart wing to faces map, and ---   left over faces (not at a dartwing)-dartsMapUnused :: Tgraph -> ([TileFace], VertexMap [TileFace],[TileFace])-dartsMapUnused g = (drts,dwFMap,unused) where+-- | A faster version of partCompose which may underestimate the composable faces.+-- It does not use force to check classification of dart wings, so some dartwings may be+-- incorrectly classified as unknown (leaving more remainder faces and fewer composed faces).+-- It checks the resulting Tgraph for connected and no crossing boundaries, so+-- it can raise an error if this check fails.+-- It will always be correct on a forced Tgraph.+quickPartCompose:: HasGraph a => a -> ([TileFace], Tgraph)+quickPartCompose a = (remainder, checked) where+  checked = runTry $ onFail "quickPartCompose:\n" $ tryConnectedNoCross newfaces+  (dwFMap,unused) = dwMapUnused (recoverGraph a)+  (remainder,newfaces) = foldl' checkDW (unused,[]) (VMap.keys dwFMap)+  checkDW (rems, nfcs) w = +     let fcs = dwFMap  VMap.! w+         (thekites,thedarts) = partition isKite fcs+         hasKiteOppWithOriginInMap v = +             -- does some kite (attached at its oppV) have its origin at a largeDartBase.+               case find ((==v) . oppV) thekites of+                   Nothing -> False+                   Just k -> VMap.member (originV k) dwFMap+         +     in  if w `elem` map originV thekites +         -- dart wing is also a half kite origin => largeDartBase+         then collectDarts (rems,nfcs) (filter (wanted w) fcs) else+         if shortMatch $ filter ((==w) . oppV) thekites+         -- two half kites, with oppV at w, share a short edge => largeKiteCentre+         then collectKites (rems, nfcs) fcs  else+         case thedarts of+            [d1,d2] -> if sharedLongE d1 d2+                            -- two darts share long edge => largekiteCentre+                       then collectKites (rems, nfcs) fcs+                            -- two darts, no matching long edge => largeDartBase+                       else collectDarts (rems,nfcs) (filter (wanted w) fcs)+            _ -> if hasKiteOppWithOriginInMap w+                     -- must be a largeKiteCentre+                 then collectKites (rems, nfcs) fcs+                    -- otherwise assume unknown+                 else (fcs++rems, nfcs) ++  wanted v f = isDart f || originV f /=v -- ignore kites with origin at v after classifying v+  shortMatch [] = False+  shortMatch [ _ ] =  False+  shortMatch (k:more) = any (sharedShortE k) more || shortMatch more+  +  collectDarts :: ([TileFace], [TileFace]) -> [TileFace] -> ([TileFace], [TileFace])+  collectDarts (rems, newfs) fcs = (fcs''++rems, newfs'') where+    (newfs' , fcs') = fromMaybe (newfs,fcs) $ groupRD fcs newfs+    (newfs'' , fcs'') = fromMaybe (newfs',fcs') $ groupLD fcs' newfs'+    groupRD fs nfs =+       do rd <- find isRD fs+          lk <- find (sharedShortE rd) fs+          return (makeRD (originV lk) (originV rd) (oppV lk):nfs, fs\\[rd,lk])+    groupLD fs nfs = +       do ld <- find isLD fs+          rk <- find (sharedShortE ld) fs+          return (makeLD (originV rk) (oppV rk) (originV ld):nfs, fs\\[ld,rk])+  collectKites :: ([TileFace], [TileFace]) -> [TileFace] -> ([TileFace], [TileFace])+  collectKites (rems, newfs) fcs = (fcs''++rems, newfs'') where+    (newfs' , fcs') = fromMaybe (newfs,fcs) $ groupRK fcs newfs+    (newfs'' , fcs'') = fromMaybe (newfs',fcs') $ groupLK fcs' newfs'+    groupRK fs nfs =+       do rd <- find isRD fs+          lk <- find (sharedShortE rd) fs+          rk <- find (sharedJoinE lk) fs+          return (makeRK (originV rd) (wingV rk) (originV rk):nfs, fs\\[rd,lk,rk])+    groupLK fs nfs = +        do ld <- find isLD fs+           rk <- find (sharedShortE ld) fs+           lk <- find (sharedJoinE rk) fs+           return (makeLK (originV ld) (originV lk) (wingV lk):nfs, fs\\[ld,rk,lk])++ +{- |Not exported - used in partComposeF, getDartWingInfoForced and tryGetDartWingInfo.+Returns a pair of:+ a dart wing to faces map, and + unused - kites guaranteed to be remainder in a composition.+A dart wing list (without duplicates) can be recovered from the map keys.+-}+dwMapUnused :: Tgraph -> (VertexMap [TileFace],[TileFace])+dwMapUnused g = (dwFMap,unused) where     (drts,kts) = partition isDart (faces g)   -- special case of vertexFacesMap for dart wings only   -- using only relevant vertices where there is a dart wing.@@ -233,7 +352,7 @@                     -- maps all dart wing vertices to 1 or 2 half darts.     (dwFMap,unused) = foldl' insertK (dartWMap,[]) kts                      -- all kite halves added to relevant dart wings of the dart wing map.-                    -- the unused list records half kites not added to any dart wing.+                    -- the unused list records half kites that will become remainder.     insertD vmap f = VMap.alter (addD f) (wingV f) vmap     addD f Nothing = Just [f]     addD f (Just fs) = Just (f:fs)@@ -242,65 +361,73 @@           org = originV f  -- cannot have a kite wingV at a dart originV           -- kite origin cases not needed for forced Tgraph, but included for completeness of the map       in  case (VMap.lookup opp vmap, VMap.lookup org vmap) of+        -- neither - add to unused +            (Nothing, Nothing)   ->  (vmap, f:unsd) -- kite face not at any dart wing+       -- both - add to both             (Just _ ,Just _)     ->  (VMap.alter (addK f) opp $ VMap.alter (addK f) org vmap, unsd)+        -- opp only - add to opp             (Just _ , Nothing)   ->  (VMap.alter (addK f) opp vmap, unsd)-            (Nothing, Just _ )   ->  (VMap.alter (addK f) org vmap, unsd)-            (Nothing, Nothing)   ->  (vmap, f:unsd) -- kite face not at any dart wing-+        -- origin only - add to origin BUT also add to unused.+        -- (Kites with only origin at dart wing cannot form part of a composed face.+        -- This case cannot arise in forced Tgraphs.)+            (Nothing, Just _ )   ->  (VMap.alter (addK f) org vmap, f:unsd) -- kite will not form part of a new face (not possible for forced Tgraph)     addK _ Nothing = Nothing  -- not added to map if it is not a dart wing vertex     addK f (Just fs) = Just (f:fs) -{-# DEPRECATED partComposeFaces "Use partComposeDWI" #-}--- |partComposeFaces has been renamed as partComposeDWI.-partComposeFaces :: DartWingInfo -> ([TileFace],[TileFace])-partComposeFaces = partComposeDWI --dwInfo = (remainder, evalFaces newFaces) where- --- |partComposeDWI constructs a pair of (remainder,composedfaces) from dart wing information (DWI).+-- |partComposeDWI constructs a pair of remainder faces and a composed Tgraph+-- from dart wing information (DWI).+-- It does not assume the dart wing info has come from a forced Tgraph+-- so a check on connected and no crossing boundaries is performed on the composed faces+-- and will raise an error if this fails.+partComposeDWI :: DartWingInfo -> ([TileFace],Tgraph)+-- This is used in defining tryPartCompose but also exported (used in the composeK example in Extras).+partComposeDWI dwi = (remainder,g) where+  g = runTry $ tryConnectedNoCross fcs+  (remainder,fcs) = partComposeFacesDWI dwi++-- |Not Exported: partComposeFacesDWI (used in partComposeDWI and tryPartComposeFaces)+-- constructs a pair of (remainder,composedfaces) from dart wing information (DWI). -- This is used in defining tryPartComposeFaces but also exported -- for use in the composeK example in Extras. -- It does not assume the dart wing info has come from a forced Tgraph -- so the resulting composed faces may not form a valid Tgraph.-partComposeDWI :: DartWingInfo -> ([TileFace],[TileFace])-partComposeDWI dwInfo = (remainder, evalFaces newFaces) where-    remainder = recoverFaces dwInfo \\ concatMap concat [groupRDs, groupLDs, groupRKs, groupLKs]-     -- all faces except those successfully used in making composed faces.   -    newFaces = newRDs ++ newLDs ++ newRKs ++ newLKs--    newRDs = map makenewRD groupRDs -    groupRDs = mapMaybe groupRD (largeDartBases dwInfo)-    makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) -    makenewRD _       = error "partComposeFaces: RD case"-    groupRD v = do  fcs <- VMap.lookup v (faceMap dwInfo)-                    rd <- find isRD fcs-                    lk <- find (matchingShortE rd) fcs-                    return [rd,lk]--    newLDs = map makenewLD groupLDs -    groupLDs = mapMaybe groupLD (largeDartBases dwInfo) -    makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld)-    makenewLD _       = error "partComposeFaces: LD case"-    groupLD v = do  fcs <- VMap.lookup v (faceMap dwInfo)-                    ld <- find isLD fcs-                    rk <- find (matchingShortE ld) fcs-                    return [ld,rk]--    newRKs = map makenewRK groupRKs -    groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) -    makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk)-    makenewRK _         = error "cpartComposeFaces: RK case"-    groupRK v = do  fcs <- VMap.lookup v (faceMap dwInfo)-                    rd <- find isRD fcs-                    lk <- find (matchingShortE rd) fcs-                    rk <- find (matchingJoinE lk) fcs-                    return [rd,lk,rk]--    newLKs = map makenewLK groupLKs -    groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) -    makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk)-    makenewLK _         = error "partComposeFaces: LK case"-    groupLK v = do  fcs <- VMap.lookup v (faceMap dwInfo)-                    ld <- find isLD fcs-                    rk <- find (matchingShortE ld) fcs-                    lk <- find (matchingJoinE rk) fcs-                    return [ld,rk,lk]+--+-- This version relies on kites that only have a dart wing at their origin, being included in remaining.+-- Such kites are also recorded in the dart wing/(kite origin) for classification purposes but then+-- filtered out when composing at a largeDartBase.+partComposeFacesDWI :: DartWingInfo -> ([TileFace],[TileFace])+partComposeFacesDWI dwInfo = (remainder, newfaces) where+    ~remainder0 = remaining dwInfo ++ concatMap facesFor (unknowns dwInfo)+    (~remainder1,newfaces1) = foldl' collectDarts (remainder0,[]) (largeDartBases dwInfo)+    (~remainder,newfaces) = foldl' collectKites (remainder1,newfaces1) (largeKiteCentres dwInfo)+    facesFor v = faceMap dwInfo VMap.! v+    collectDarts :: ([TileFace], [TileFace]) -> Vertex -> ([TileFace], [TileFace])+    collectDarts (rems, newfs) v = (fcs''++rems, newfs'') where+      wanted f = isDart f || originV f /=v -- ignore kites with origins at v+      fcs = filter wanted (facesFor v)+      (newfs' , fcs') = fromMaybe (newfs,fcs) $ groupRD fcs newfs+      (newfs'' , fcs'') = fromMaybe (newfs',fcs') $ groupLD fcs' newfs'+      groupRD fs nfs =+         do rd <- find isRD fs+            lk <- find (sharedShortE rd) fs+            return (makeRD (originV lk) (originV rd) (oppV lk):nfs, fs\\[rd,lk])+      groupLD fs nfs = +         do ld <- find isLD fs+            rk <- find (sharedShortE ld) fs+            return (makeLD (originV rk) (oppV rk) (originV ld):nfs, fs\\[ld,rk])+    collectKites :: ([TileFace], [TileFace]) -> Vertex -> ([TileFace], [TileFace])+    collectKites (rems, newfs) v = (fcs''++rems, newfs'') where+      fcs = facesFor v+      (newfs' , fcs') = fromMaybe (newfs,fcs) $ groupRK fcs newfs+      (newfs'' , fcs'') = fromMaybe (newfs',fcs') $ groupLK fcs' newfs'+      groupRK fs nfs =+         do rd <- find isRD fs+            lk <- find (sharedShortE rd) fs+            rk <- find (sharedJoinE lk) fs+            return (makeRK (originV rd) (wingV rk) (originV rk):nfs, fs\\[rd,lk,rk])+      groupLK fs nfs = +          do ld <- find isLD fs+             rk <- find (sharedShortE ld) fs+             lk <- find (sharedJoinE rk) fs+             return (makeLK (originV ld) (originV lk) (wingV lk):nfs, fs\\[ld,rk,lk]) 

@@ -28,8 +28,8 @@   , smartOn   , smartRotating   , smartAligning-  , smartRotateBefore-  , smartAlignBefore+ -- , smartRotateBefore+ -- , smartAlignBefore   , drawBoundaryJoins   , drawJoinsFor     -- * Overlaid drawing tools for Tgraphs@@ -94,8 +94,8 @@   , drawTrackedTgraphRotating   , drawTrackedTgraphAligning -  , drawTrackedTgraphRotated-  , drawTrackedTgraphAligned+ -- , drawTrackedTgraphRotated+ -- , drawTrackedTgraphAligned   ) where  import TileLib@@ -113,7 +113,7 @@ 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 Control.Monad ( (>=>) )  -- |smart dr g - uses VPatch drawing function dr after converting g to a VPatch -- It will add boundary joins regardless of the drawing function.@@ -166,14 +166,6 @@                 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.--- Uses vfun to produce a Diagram after converting g to a rotated VPatch (rotated by angle)--- then adds the dashed boundary join edges of g.-smartRotateBefore :: OKBackend b =>-                     (VPatch -> Diagram b) -> Angle Double -> Tgraph -> Diagram b-smartRotateBefore = flip smartRotating- -- |smartAligning (a,b) vfun g - a tricky combination of smart with aligning. -- Uses vfun to produce a Diagram after converting g to an aligned VPatch -- then adds the dashed boundary join edges of g.@@ -185,14 +177,6 @@               (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.--- Uses vfun to produce a Diagram after converting g to an aligned VPatch--- then adds the dashed boundary join edges of g.-smartAlignBefore :: OKBackend b =>-                    (VPatch -> Diagram b) -> (Vertex,Vertex) -> Tgraph -> Diagram b-smartAlignBefore = flip smartAligning - -- |drawForce g is a diagram showing the argument g in red overlayed on force g. -- It adds dashed join edges on the boundary of g. -- It will raise an error if the force fails with an incorrect/stuck Tgraph.@@ -207,7 +191,7 @@               Colour Double -> Tgraph -> Diagram b drawForce' c g =     smartOn g draw vp # lc c <> draw vp-    where vp = makeVP $ forceF g+    where vp = makeVP $ force g  -- |applies partCompose to a Tgraph g, then draws the composed Tgraph -- along with the remainder faces (drawn in lime).@@ -282,8 +266,8 @@   -- | For illustrating an unsound version of composition.--- This composition defaults to --- forming a large half kite when there is an unknown+-- This composition defaults to trying to form+-- a large half kite when there is an unknown -- dart wing on the boundary with a complete kite at the short edge of the half dart. -- This is unsound in that it can create an incorrect Tgraph from a correct Tgraph. -- E.g. when applied to force queenGraph.@@ -293,9 +277,10 @@       let changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo                               , unknowns = []                               }-          ( _ , newfaces) = partComposeDWI changedInfo+      return $ snd $ partComposeDWI changedInfo+{-           ( _ , newfaces) = partComposeDWI changedInfo       tryConnectedNoCross newfaces-+ -} -- |compForce is a partial function similar to (compose . force), -- i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph). -- However it produces an explicitly Forced Tgraph, @@ -303,7 +288,6 @@ -- and uses a faster composition method for forced Tgraphs. -- 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:: (Forcible a, HasGraph a) => a -> Forced Tgraph compForce = composeF . withForced recoverGraph . forceF @@ -338,16 +322,16 @@ The common faces of the covers constitute an empire (level 1) of g. This will raise an error if the initial force fails with an incorrect/stuck Tgraph. -}-forcedBoundaryECovering:: Tgraph -> [Forced Tgraph]+forcedBoundaryECovering:: Forcible a => a -> [Forced Tgraph] forcedBoundaryECovering g = withForced recoverGraph <$> boundaryECovering gforcedBdry where      gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" -                          $ tryInitFS g  >>= tryForceF+                          $ 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:: Forcible a => a -> [Forced Tgraph] forcedBoundaryVCovering g = withForced recoverGraph <$> boundaryVCovering ffs where      ffs = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n"                   $ tryInitFS g  >>= tryForceF @@ -377,7 +361,6 @@                  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@@ -437,49 +420,19 @@             ++ "The incorrect Forced ForceState has Tgraph:\n"             ++ show  (forgetF fa)            ) $-    fmap (map labelAsForced) $ tryAtLeastOne+    map labelAsForced <$> tryAtLeastOne     [ onFail ("tryCheckCasesDKF: Dart on edge: " ++ show de ++ "\n") $-        tryFSOp (\fs -> tryAddHalfDart de fs >>= tryForce) a+        tryFSOp (tryAddHalfDart de >=> tryForce) a     , onFail ("tryCheckCasesDKF: Kite on edge: " ++ show de ++ "\n") $-        tryFSOp (\fs -> tryAddHalfKite de fs >>= tryForce) a+        tryFSOp (tryAddHalfKite de >=> 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-            ++ " \nare incorrrect for a successfully forced Forcible.\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 but forced forcible is:\n"-            ++ 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.--- It returns the list of only the successful results provided there is AT LEAST ONE.--- If there are no successes, this may be an important counter example --- and it will raise an error describing the counter example--- to the following:------ Hypothesis: A successfully forced Tgraph is correct (a correct tiling).------ (If both legal additions to a boundary edge are incorrect,--- 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+-- for a given forcible.+drawFBCovering :: (OKBackend b, Forcible a) =>+                  a -> Diagram b drawFBCovering g = lw ultraThin $ vsep 1 (draw . recoverGraph <$> forcedBoundaryVCovering g) - -- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g. -- Raises an error if force g fails with a stuck/incorrect Tgraph. -- The tgraph of the result is the first boundary vertex cover of force g@@ -582,7 +535,7 @@     trySuperForceFS fs =         do ffs <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $                   tryForceF fs-           case singleChoiceEdges $ ffs of+           case singleChoiceEdges ffs of               [] -> return $ forgetF ffs               (elpr:_) -> do extended <- addSingle elpr $ forgetF ffs                              trySuperForceFS extended@@ -800,18 +753,7 @@     untracked = faces vp \\ concat (tracked ttg)     vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp -{-# DEPRECATED drawTrackedTgraphRotated "Use (flip drawTrackedTgraphRotating)" #-} {-|-    To draw a TrackedTgraph rotated.-    Same as drawTrackedTgraph but with additional angle argument for the rotation.-    This is useful when labels are being drawn.-    The angle argument is used to rotate the common vertex location map (anticlockwise) before drawing-    to ensure labels are not rotated.--}-drawTrackedTgraphRotated :: OKBackend b => [VPatch -> Diagram b] -> Angle Double -> TrackedTgraph -> Diagram b-drawTrackedTgraphRotated = flip drawTrackedTgraphRotating--{-|     To draw a TrackedTgraph aligned.     Same as drawTrackedTgraph but with additional vertex pair argument for the (x-axis) alignment.     This is useful when labels are being drawn.@@ -821,21 +763,8 @@ -} 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) ttg+    vp = alignedVP (a,b) ttg     untracked = faces vp \\ concat (tracked ttg)     vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp--{-# DEPRECATED drawTrackedTgraphAligned "Use (flip drawTrackedTgraphAligning)" #-}-{-|-    To draw a TrackedTgraph aligned.-    Same as drawTrackedTgraph but with additional vertex pair argument for the (x-axis) alignment.-    This is useful when labels are being drawn.-    The vertex pair argument is used to align the common vertex location map before drawing-    (to ensure labels are not rotated).-    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 = flip drawTrackedTgraphAligning-  

@@ -39,10 +39,10 @@   , tryForceF   , forceF   , withForced-  , recoverGraphF --dep-  , boundaryStateF --dep-  , makeBoundaryStateF --dep-  , initFSF --dep+--  , recoverGraphF+--  , boundaryStateF+--  , makeBoundaryStateF+--  , initFSF --dep   , labelAsForced    -- *  Force Related   , addHalfKite@@ -50,7 +50,7 @@   , addHalfDart   , tryAddHalfDart --  , tryOneStepWith-  , tryOneStepForce -- dep+--  , tryOneStepForce   , tryOneStep -- * Types for Forcing   , BoundaryState(..)@@ -58,7 +58,7 @@   , ForceState(..)   , BoundaryChange(..)   , Update(..)-  , UpdateMap+  , Updates(..)   , UpdateGenerator(..)   , UFinder   , UChecker@@ -90,6 +90,7 @@   , recalibratingForce   , tryRecalibratingForce   , recalculateBVLocs+  , tryForceAt     -- * Forcing Rules and Update Generators     -- $rules @@ -159,17 +160,19 @@ import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..)) import Data.Map.Strict(Map)-import qualified Data.Map.Strict as Map (empty, delete, elems, insert, union, keys) -- used for UpdateMap+import qualified Data.Map.Strict as Map (null, delete, elems, insert, lookupMin, keys,lookup) -- used for Updates import Data.IntMap.Strict(IntMap) import qualified Data.IntMap.Strict as VMap (filterWithKey, alter, adjust, delete, lookup, (!), keysSet, member                                             , fromAscList, fromList, assocs, insert, elems)-import qualified Data.IntSet as IntSet (member,empty,insert)+import qualified Data.IntSet as IntSet (member)             -- used for BoundaryState locations AND faces at boundary vertices import Data.Set (Set)-import qualified Data.Set as Set (foldr',elems,fromList)+import qualified Data.Set as Set (elems,fromList) import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate  import Tgraph.Prelude import Tgraph.Grid +import Control.Monad ( (>=>) )+import Data.Maybe(mapMaybe) -- import TileLib ( Drawable )  {- ***************************************************************************   @@ -190,13 +193,15 @@ the next vertex label to be used when adding a new vertex, the boundary directed edges (directed so that faces are on LHS and exterior is on RHS). These boundary directed edges are represented using type BoundaryDedges.+New: the positions of boundary vertices and the grid are made lazy.+They are not needed until the first unsafe update has to be done (if there is one). -} data BoundaryState    = BoundaryState      { boundaryDedges:: BoundaryDedges  -- ^ boundary directed edges (face on LHS, exterior on RHS)      , bvFacesMap:: VertexMap [TileFace] -- ^faces at each boundary vertex.-     , bvLocMap:: VertexMap (Point V2 Double)  -- ^ position of each boundary vertex.-     , grid:: Grid (Point V2 Double) -- ^ a grid of locations to avoid (initially boundary vertex locations).+     , bvLocMap:: ~(VertexMap (Point V2 Double))  -- ^ position of each boundary vertex.+     , grid:: ~(Grid (Point V2 Double)) -- ^ a grid of locations to avoid (initially boundary vertex locations).      , allFaces:: [TileFace] -- ^ all the tile faces      , nextVertex:: Vertex -- ^ next vertex number      } deriving (Show)@@ -259,13 +264,14 @@ -- |Calculates BoundaryState information from a Tgraph. makeBoundaryState:: Tgraph -> BoundaryState makeBoundaryState g =-  let bdes = boundaryESet g-      bvs = Set.foldr' ((IntSet.insert).fst) IntSet.empty bdes --IntSet.fromList (map fst $ Set.toList bdes) -- (map snd bdes would also do) for all boundary vertices-      bvLocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices g-      newgrid = createGrid $ VMap.elems bvLocs+  let bdes = bdesFromSet $ boundaryESet g+      bvs = VMap.keysSet $ nextBVMap bdes -- the boundary vertices are the keys of the nextBVMap+      -- location data is lazy (not needed until an unsafe update is executed)+      ~bvLocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices g+      ~newgrid = createGrid $ VMap.elems bvLocs   in        BoundaryState-      { boundaryDedges = bdesFromSet bdes+      { boundaryDedges = bdes       , bvFacesMap = vertexFMap bvs g       , bvLocMap = bvLocs       , grid = newgrid@@ -274,7 +280,7 @@       }  -- |BoundaryState is in class HasFaces.--- Note the default implementations are overiden to use precalculated information+-- Note the default implementations are overriden to use precalculated information instance HasFaces BoundaryState where     faces = allFaces     boundaryESet = bdesToSet . boundaryDedges  -- (overrides default) boundary already calculated@@ -317,24 +323,63 @@     show (SafeUpdate f) = "SafeUpdate (" ++ show f ++ ")"     show (UnsafeUpdate mf) = "UnsafeUpdate (\0 -> " ++ show (mf 0)++ ")" --- |UpdateMap: partial map associating updates with (some) boundary directed edges.+-- |Updates: two partial maps associating updates with (some) boundary directed edges.+-- One for safe updates and one for unsafe updates -- (Any boundary directed edge will have the opposite direction in some face.)-type UpdateMap = Map Dedge Update+data Updates = Updates{safes :: Map Dedge Update, unsafes :: Map Dedge Update}+  deriving (Show) +-- | Updates form a semigroup+instance Semigroup Updates where+  ups1 <> ups2 = Updates+   { safes = safes ups1 <> safes ups2+   , unsafes = unsafes ups1 <> unsafes ups2+   }++-- | Updates form a monoid+instance Monoid Updates where+  mempty = Updates{safes = mempty, unsafes = mempty}++-- |insert a new update (note that a safe can replace un unsafe but not vice versa).+insertUpdate :: Dedge  -> Update -> Updates -> Updates+insertUpdate e u@(SafeUpdate _) ups+  = ups{ safes = Map.insert e u (safes ups)+       , unsafes = Map.delete e (unsafes ups)+       } -- a safe can replace an unsafe+insertUpdate e u@(UnsafeUpdate _)  ups+  = ups{unsafes = Map.insert e u (unsafes ups)}++-- |delete an update+deleteUpdate :: Dedge  -> Updates -> Updates+deleteUpdate e ups+  = ups{ safes   = Map.delete e (safes ups)+       , unsafes = Map.delete e (unsafes ups)+       }++-- |get the boundary edges that have an update (from Updates)+updateEdges :: Updates -> [Dedge]+updateEdges ups = Map.keys (safes ups) ++ Map.keys (unsafes ups)++-- |are there no more updates?+noUpdates :: Updates -> Bool+noUpdates ups = Map.null (safes ups) && Map.null (unsafes ups)+ -- |ForceState: The force state records information between executing single face updates during forcing--- (a BoundaryState , an UpdateMap, and an UpdateGenerator).+-- (a BoundaryState , updates, and an UpdateGenerator).+-- A convention throughout is to initialize and leave a ForceState with the default update generator+-- and corresponding updates. It is important that the updates are calculated lazily in case they are not used. data ForceState = ForceState     { boundaryState:: BoundaryState-    , updateMap:: ~UpdateMap  -- lazy field may not be used-    , updater:: UpdateGenerator -- new+    , updates:: ~Updates  -- lazy field may not be used+    , updater:: UpdateGenerator     }  -- | 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\nand updates:\n"+                      ++ show (updates fs)                       ++ "\n\n"  -- |ForceState is in class HasFaces.@@ -351,11 +396,11 @@  {-|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.  +and produce a (Try) Updates when given a BoundaryState and a focus list of particular directed boundary edges.   Each forcing rule has a particular UpdateGenerator, but they can also be combined (e.g in sequence - allUGenerator or otherwise - defaultAllUGen). -}-newtype UpdateGenerator = UpdateGenerator {applyUG :: BoundaryState -> [Dedge] -> Try UpdateMap}+newtype UpdateGenerator = UpdateGenerator {applyUG :: BoundaryState -> [Dedge] -> Try Updates}   -- | Forcing a Tgraph requires conversion to a BoundaryState (which records extra data)@@ -367,7 +412,8 @@ -- force related operations to be generalised for use on any Forcible. -- For example tryAddHalfKite and tryAddHalfDart are implemented using tryChangeBoundary. class Forcible a where-    -- | tryFSOp (try ForseState Operation), generalises a (try) ForceState operation to a (try) Forcible operation.+    -- | tryFSOp (try ForseState Operation), generalises a (try) ForceState operation to a (try) Forcible operation+    -- (beginning and ending with the same forcible type).     --     -- To improve performance of a sequence of force related operations, express each as a     -- ForceState -> Try ForceState, then compose (e.g. using (\<=\<) or (\>=\>) from Control.Monad) and pass to tryFSOp.@@ -377,7 +423,8 @@     -- 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, converts a (try) BoundaryState changing operation to a (try) Forcible operation+    -- (beginning and ending with the same forcible type).     tryChangeBoundary :: (BoundaryState -> Try BoundaryChange) -> a -> Try a  -- |ForceStates are Forcible@@ -395,8 +442,8 @@         fs' <- f fs         return $ boundaryState fs'     tryInitFS bd = do-        ~umap <- applyUG defaultAllUGen bd (boundary bd)-        return $ ForceState { boundaryState = bd , updateMap = umap , updater = defaultAllUGen }+        ~ups <- applyUG defaultAllUGen bd (boundary bd)+        return $ ForceState { boundaryState = bd , updates = ups , updater = defaultAllUGen }     tryChangeBoundary f bd = do -- update generator not used         bdC <- f bd         return $ newBoundaryState bdC@@ -408,12 +455,6 @@     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@@ -423,13 +464,24 @@       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.+-- |A version of tryFSOp that (temporarily) uses the supplied update generator rather than the default+-- to perform the supplied try ForceState operation.+-- It will reset the default update generator (in case a resulting ForceState is used after completion). tryFSOpWith :: Forcible a => UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a-tryFSOpWith ugen f = tryFSOp (\fs -> trySetUG ugen fs >>= f)+tryFSOpWith ugen f = tryFSOp (trySetUG ugen >=> f >=> trySetUG defaultAllUGen) +-- |Not exported. Only used in tryFSOpWith,+-- Resets the update generator in a ForceState (and recalculates updates lazily)+-- It is used twice in tryFSOpWith to restore the default.+trySetUG :: UpdateGenerator -> ForceState -> Try ForceState       +trySetUG ugen fs = do+    ~ups <- applyUG ugen (boundaryState fs) (boundary fs)+    return $ fs { updates = ups, updater = ugen }+ -- | 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.+-- It will reset the default update generator and updates (in case a resulting ForceState is used after completion). tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a tryForceWith ug = tryFSOpWith ug tryFinishFS @@ -449,6 +501,7 @@  -- | forceWith ugen: force using the supplied UpdateGenerator ugen. -- This raises an error on discovering a stuck/incorrect Forcible.+-- It will reset the default update generator and updates (in case a resulting ForceState is used after completion). forceWith:: Forcible a => UpdateGenerator -> a -> a forceWith ugen = runTry . tryForceWith ugen @@ -517,28 +570,6 @@ 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 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 = 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 = 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 = 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, -- or returns Left failreport.. if neither direction is consistent with boundary directed edges.@@ -617,7 +648,7 @@ -- (3) a Left report for a stuck/incorrect Tgraph. tryOneStep :: ForceState -> Try (Maybe (ForceState,BoundaryChange)) tryOneStep fs =-      case findSafeUpdate (updateMap fs) of+      case findSafeUpdate (updates fs) of       Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u                    fs' <- tryReviseFS bdChange fs                    return $ Just (fs',bdChange)@@ -627,15 +658,11 @@                                return $ Just (fs',bdC)                 Nothing  -> return Nothing           -- no more updates -{-# 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}+    do ups <- tryReviseUpdates (updater fs) bdC (updates fs)+       return $ fs{ boundaryState = newBoundaryState bdC, updates = ups}   @@ -691,24 +718,20 @@ boundaryAt v bs = [preceding v bs, following v bs]  {-# INLINE tryReviseUpdates #-}--- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange)+-- |tryReviseUpdates uGen bdChange: revises the Updates after boundary change (bdChange) -- using uGen to calculate new updates.-tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap-tryReviseUpdates uGen bdChange umap =-  do let umap' = foldl' (flip Map.delete) umap (removedEdges bdChange)-     umap'' <- applyUG uGen (newBoundaryState bdChange) (revisedEdges bdChange)-     return (Map.union umap'' umap')+tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> Updates -> Try Updates+tryReviseUpdates uGen bdChange ups =+  do let ups' = foldl' (flip deleteUpdate) ups (removedEdges bdChange)+     ups'' <- applyUG uGen (newBoundaryState bdChange) (revisedEdges bdChange)+     return (ups'' <> ups')  {-# INLINE findSafeUpdate #-} -- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering)-findSafeUpdate:: UpdateMap -> Maybe Update--- slower to use filter--- findSafeUpdate umap = fmap snd $ Map.lookupMin $ Map.filter isSafeUpdate umap where-findSafeUpdate umap = find isSafeUpdate (Map.elems umap) where-      isSafeUpdate (SafeUpdate _ ) = True-      isSafeUpdate (UnsafeUpdate _ ) = False+findSafeUpdate:: Updates -> Maybe Update+findSafeUpdate ups = snd <$> Map.lookupMin (safes ups) -{-| tryUnsafes: Should only be used when there are no Safe updates in the UpdateMap.+{-| tryUnsafes: Should only be used when there are no Safe updates in the Updates.    tryUnsafes works through the unsafe updates in (directed edge) key order and    completes the first unsafe update that is not blocked (by a touching vertex), returning Right (Just bdC)    where bdC is the resulting boundary change (if there is one).@@ -716,13 +739,22 @@    Left report if there are unsafes but all unsafes are blocked, where report describes the problem. -} tryUnsafes:: ForceState -> Try (Maybe BoundaryChange)-tryUnsafes fs = checkBlocked 0 $ Map.elems $ updateMap fs where-  bd = boundaryState fs+tryUnsafes fs = tryUnsafesBS (boundaryState fs) (Map.elems $ unsafes $ updates fs) -- directed edge key order++{-| tryUnsafesBS: called by tryUnsafes with a list of unsafe updates to try in order+   tryUnsafesBS works through the unsafe updates in order and+   completes the first unsafe update that is not blocked (by a touching vertex), returning Right (Just bdC)+   where bdC is the resulting boundary change (if there is one).+   It returns Right Nothing if there are no unsafe updates but+   Left report if there are unsafes but all unsafes are blocked, where report describes the problem.+-}+tryUnsafesBS:: BoundaryState -> [Update] -> Try (Maybe BoundaryChange)+tryUnsafesBS bd = checkBlocked 0 where   -- the integer records how many blocked cases have been found so far   checkBlocked:: Int -> [Update]  -> Try (Maybe BoundaryChange)   checkBlocked 0 [] = return Nothing   checkBlocked n [] = failReports -                        ["tryUnsafes: There are "+                        ["tryUnsafesBS: There are "                         ,show n                         ," 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"@@ -743,7 +775,6 @@     when all unsafe updates are blocked (and there is at least one) - see tryUnsafes] -} checkUnsafeUpdate:: BoundaryState -> Update -> Maybe BoundaryChange-checkUnsafeUpdate _  (SafeUpdate _) = error  "checkUnsafeUpdate: applied to safe update.\n" checkUnsafeUpdate bd (UnsafeUpdate makeFace) =   let v = nextVertex bd       newface = makeFace v@@ -754,7 +785,7 @@     Left _  -> Nothing  -- blocked by touching vertex     Right newgrid ->      let -       (unmatched, matchedDedges) = partition (\(x,y) -> x == v || y == v) (faceDedges newface) -- (two edges,singleton)+       (!unmatched, !matchedDedges) = partition (\(x,y) -> x == v || y == v) (faceDedges newface) -- (two edges,singleton)        newBdry = map reverseD unmatched -- two edges        resultBd = BoundaryState                     { boundaryDedges = bdesInsert newBdry $ bdesDelete matchedDedges $ boundaryDedges bd@@ -772,6 +803,7 @@                     , newFace = newface                     }      in Just bdChange+checkUnsafeUpdate _  _ = error  "checkUnsafeUpdate: applied to safe update.\n"  {-| trySafeUpdate bd u adds a new face by completing a safe update u on BoundaryState bd     (raising an error if u is an unsafe update).@@ -783,12 +815,10 @@     in a triangle (and removes 3 boundary vertices), closing a hole. -} trySafeUpdate:: BoundaryState -> Update -> Try BoundaryChange-trySafeUpdate _  (UnsafeUpdate _) = error "trySafeUpdate: applied to non-safe update.\n" trySafeUpdate bd (SafeUpdate newface) =    let fDedges = faceDedges newface        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+       (!matchedDedges, !unmatched) = partition (`elem` localBoundary) fDedges -- (2 or 3, 1 or none)        removedBVs = commonVs matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3)        newBdry = map reverseD unmatched --(fDedges \\ matchedDedges) -- one or none        nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs@@ -808,7 +838,7 @@                    , revisedEdges = affectedBoundary resultBd newBdry -- 3 or 0 edges                    , newFace = newface                    }-   in if noNewConflict newface nbrFaces+   in if compatibleNew newface nbrFaces       then Right bdChange       else failReports               ["trySafeUpdate:(incorrect tiling)\nConflicting new face  "@@ -817,6 +847,7 @@               ,show nbrFaces               ,"\n"               ]+trySafeUpdate _  _ = error "trySafeUpdate: applied to non-safe update.\n"   -- | given 2 consecutive directed edges (not necessarily in the right order),@@ -839,7 +870,7 @@ tryUpdate bd u@(UnsafeUpdate _) =   case checkUnsafeUpdate bd u of        Just bdC -> return bdC-       Nothing ->  failReport "tryUpdate: crossing boundary (touching vertices).\n"+       Nothing -> failReport "tryUpdate: crossing boundary (touching vertices).\n"  -- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateGraphVertices. -- and a new grid of positions@@ -857,7 +888,7 @@ tryRecalibratingForce = tryFSOp recalibrating where    recalibrating fs = do        fs' <- tryStepForce 20000 fs-       if null $ updateMap fs'+       if noUpdates $ updates fs'        then return fs'        else recalibrating fs' {boundaryState = recalculateBVLocs $ boundaryState fs'} @@ -867,7 +898,28 @@ recalibratingForce :: Forcible c => c -> c recalibratingForce = runTry . tryRecalibratingForce +-- | Not exported. Auxiliary ForceState function used by tryForceAt+tryForceAtFS :: [Vertex] -> ForceState -> Try ForceState+tryForceAtFS vs fs = do+  let bs = boundaryState fs+      bvs = filter (`isBoundaryV` bs) vs+      des = Set.elems $ Set.fromList $ concatMap (`boundaryAt` bs) bvs -- does nub and sort+  let thesafes = mapMaybe (`Map.lookup` safes (updates fs)) des+      ~theunsafes = mapMaybe (`Map.lookup` unsafes (updates fs)) des+  case thesafes of+       (u:_) -> do bdChange <- trySafeUpdate bs u+                   fs' <- tryReviseFS bdChange fs+                   tryForceAtFS bvs fs'+       []  -> do maybeBdC <- tryUnsafesBS bs theunsafes+                 case maybeBdC of+                       Just bdC -> do fs' <- tryReviseFS bdC fs+                                      tryForceAtFS bvs fs'+                       Nothing  -> return fs           -- no more updates +-- | Experimental version of tryForce that only adds faces at the given vertices.+-- (Any vertex not on the boundary is ignored).+tryForceAt :: Forcible a => [Vertex] -> a -> Try a+tryForceAt vs = tryFSOp (tryForceAtFS vs)  {- $rules FORCING RULES:@@ -919,13 +971,13 @@ combineUpdateGenerators :: [UpdateGenerator] -> UpdateGenerator combineUpdateGenerators gens = UpdateGenerator genf where   genf bd focus =-    do let addGen (Right (es,umap)) gen =-             do umap' <- applyUG gen bd es-                let es' = es \\ Map.keys umap'-                return (es',Map.union umap' umap)+    do let addGen (Right (es,ups)) gen =+             do ups' <- applyUG gen bd es+                let es' = es \\ updateEdges ups'+                return (es',ups' <> ups)            addGen other _  = other  -- fails with first failing generator-       (_ , umap) <- foldl' addGen (Right (focus,Map.empty)) gens-       return umap+       (_ , ups) <- foldl' addGen (Right (focus,mempty)) gens+       return ups  {-| allUGenerator was the original generator for all updates.     It combines the individual update generators for each of the 10 rules in sequence using combineUpdateGenerators@@ -1003,7 +1055,7 @@  -- |makeUpdate f x constructs a safe update if x is Just(..) and an unsafe update if x is Nothing makeUpdate:: (Vertex -> TileFace) -> Maybe Vertex ->  Update-makeUpdate f (Just !v) = SafeUpdate (f v) -- let fc = evalFace (f v) in SafeUpdate fc+makeUpdate f (Just !v) = SafeUpdate (f v) makeUpdate f Nothing  = UnsafeUpdate f  @@ -1076,11 +1128,10 @@ -} newUpdateGenerator :: UChecker -> UFinder -> UpdateGenerator newUpdateGenerator checker finder = UpdateGenerator genf where-  genf bd edges = foldl' addU (Right Map.empty) (finder bd edges) where+  genf bd edges = foldl' addU (Right mempty) (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)-+     addU (Right ups) (e,fc)  = do u <- checker bd fc+                                   return (insertUpdate e u ups)  --   Ten Update Generators (with corresponding Finders) @@ -1224,40 +1275,40 @@ --  add a symmetric (mirror) face for a given face at a boundary join edge. completeHalf :: UChecker completeHalf bd (LD(a,b,_)) = makeUpdate makeFace <$> x where-        makeFace v = makeRD a v b --RD (a,v,b)+        makeFace v = makeRD a v b         x = tryFindThirdV bd (b,a) (3,1) --anglesForJoinRD completeHalf bd (RD(a,_,b)) = makeUpdate makeFace <$> x where-        makeFace v = makeLD a b v --LD (a,b,v)+        makeFace  = makeLD a b          x = tryFindThirdV bd (a,b) (1,3) --anglesForJoinLD completeHalf bd (LK(a,_,b)) = makeUpdate makeFace <$> x where-        makeFace v = makeRK a b v --RK (a,b,v)+        makeFace  = makeRK a b          x = tryFindThirdV bd (a,b) (1,2) --anglesForJoinRK completeHalf bd (RK(a,b,_)) = makeUpdate makeFace <$> x where-        makeFace v = makeLK a v b --LK (a,v,b)+        makeFace v = makeLK a v b         x = tryFindThirdV bd (b,a) (2,1) --anglesForJoinLK  -- |add a (missing) half kite on a (boundary) short edge of a dart or kite addKiteShortE :: UChecker addKiteShortE bd (RD(_,b,c)) = makeUpdate makeFace <$> x where-    makeFace v = makeLK v c b --LK (v,c,b)+    makeFace v = makeLK v c b      x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK addKiteShortE bd (LD(_,b,c)) = makeUpdate makeFace <$> x where-    makeFace v = makeRK v c b --RK (v,c,b)+    makeFace v = makeRK v c b      x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where-    makeFace v = makeRK v c b --RK (v,c,b)+    makeFace v = makeRK v c b      x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK addKiteShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where-    makeFace v = makeLK v c b --LK (v,c,b)+    makeFace v = makeLK v c b     x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK  -- |add a half dart top to a boundary short edge of a half kite. addDartShortE :: UChecker addDartShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where-        makeFace v = makeLD v c b --LD (v,c,b)+        makeFace v = makeLD v c b          x = tryFindThirdV bd (c,b) (3,1) --anglesForShortLD addDartShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where-        makeFace v = makeRD v c b --RD (v,c,b)+        makeFace v = makeRD v c b         x = tryFindThirdV bd (c,b) (1,3) --anglesForShortRD addDartShortE _  _ = error "addDartShortE applied to non-kite face\n" @@ -1270,31 +1321,31 @@ -- |add a kite to a long edge of a dart or kite addKiteLongE :: UChecker addKiteLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where-    makeFace v = makeRK c v a --RK (c,v,a)+    makeFace v = makeRK c v a      x = tryFindThirdV bd (a,c) (2,1) -- anglesForLongRK addKiteLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where-    makeFace v = makeLK b a v --LK (b,a,v)+    makeFace  = makeLK b a      x = tryFindThirdV bd (b,a) (1,2) -- anglesForLongLK addKiteLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where-  makeFace v = makeLK a c v --LK (a,c,v)+  makeFace  = makeLK a c    x = tryFindThirdV bd (a,c) (1,2) -- anglesForLongLK addKiteLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where-  makeFace v = makeRK a v b --RK (a,v,b)+  makeFace v = makeRK a v b   x = tryFindThirdV bd (b,a) (2,1) -- anglesForLongRK  -- |add a half dart on a boundary long edge of a dart or kite addDartLongE :: UChecker addDartLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where-  makeFace v = makeRD a c v --RD (a,c,v)+  makeFace  = makeRD a c    x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongRD addDartLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where-  makeFace v = makeLD a v b --LD (a,v,b)+  makeFace v = makeLD a v b   x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongLD addDartLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where-  makeFace v = makeRD b a v --RD (b,a,v)+  makeFace  = makeRD b a     x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongRD addDartLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where-  makeFace v = makeLD c v a --LD (c,v,a)+  makeFace v = makeLD c v a   x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongLD  {-@@ -1330,7 +1381,7 @@ defaultAllUGen = UpdateGenerator { applyUG = gen } where   gen bd es = combine $ map decide es where -- Either String is a monoid as well as Map     combine = fmap mconcat . concatFails -- concatenates all failure reports if there are any-                                         -- otherwise combines the update maps with mconcat+                                         -- otherwise combines the updates with mconcat     decide e = decider $ inspectBDedge bd e where        decider (f,Join)  = mapItem (completeHalf bd f) -- rule 1@@ -1345,55 +1396,21 @@         | mustbeStar bd (originV f) = mapItem (completeSunStar bd f)         | mustbeKing bd (originV f) = mapItem (addDartLongE bd f)         | mustbeJack bd (wingV f) = mapItem (addKiteLongE bd f)-        | otherwise = Right Map.empty+        | otherwise = Right mempty        kiteLongDecider f         | mustbeSun bd (originV f) = mapItem (completeSunStar bd f)         | mustbeQueen bd (wingV f) = mapItem (addDartLongE bd f)-        | otherwise = Right Map.empty+        | otherwise = Right mempty        kiteShortDecider f         | mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem (addDartShortE bd f)         | mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem (addKiteShortE bd f)-        | otherwise = Right Map.empty- --     mapItem :: Try Update -> Try UpdateMap-      mapItem = fmap (\u -> Map.insert e u Map.empty)--{- defaultAllUGen :: UpdateGenerator-defaultAllUGen = UpdateGenerator { applyUG = gen } where-  gen bd es = combine $ map decide es where -- Either String is a monoid as well as Map-      decide e = decider (e,f,etype) where (f,etype) = inspectBDedge bd e--      decider (e,f,Join)  = mapItem e (completeHalf bd f) -- rule 1-      decider (e,f,Short)-        | isDart f = mapItem e (addKiteShortE bd f) -- rule 2-        | otherwise = kiteShortDecider e f-      decider (e,f,Long)-        | isDart f = dartLongDecider e f-        | otherwise = kiteLongDecider e f--      dartLongDecider e f-        | mustbeStar bd (originV f) = mapItem e (completeSunStar bd f)-        | mustbeKing bd (originV f) = mapItem e (addDartLongE bd f)-        | mustbeJack bd (wingV f) = mapItem e (addKiteLongE bd f)-        | otherwise = Right Map.empty--      kiteLongDecider e f-        | mustbeSun bd (originV f) = mapItem e (completeSunStar bd f)-        | mustbeQueen bd (wingV f) = mapItem e (addDartLongE bd f)-        | otherwise = Right Map.empty--      kiteShortDecider e f-        | mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem e (addDartShortE bd f)-        | mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem e (addKiteShortE bd f)-        | otherwise = Right Map.empty--      mapItem e = fmap (\u -> Map.insert e u Map.empty)-      combine = fmap mconcat . concatFails -- concatenates all failure reports if there are any-                                           -- otherwise combines the update maps with mconcat- -}+        | otherwise = Right mempty+ --     mapItem :: Try Update -> Try Updates+      mapItem = fmap (\u -> insertUpdate e u mempty) --- |Given a BoundaryState and a directed boundary edge, this returns the same edge with+-- |Given a BoundaryState and a directed boundary edge, this returns -- 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 (a,b) = (face,edgeType (b,a) face) where

@@ -12,9 +12,10 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE Strict                    #-}  + module Tgraph.Grid (     insertGridCheck@@ -26,7 +27,7 @@   , touching   , ValuedPoint(..)   , allTouching-  , allClashes+ -- , allClashes  ) where @@ -34,6 +35,7 @@   import Data.List ( find )+import Data.Maybe ( fromMaybe ) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IMap (alter,insert,empty,lookup) @@ -56,7 +58,7 @@  -- | A pair of a value and a 2D point is considered a ValuedPoint instance ValuedPoint (a, P2 Double) where-    getPoint ((_,p)) = p+    getPoint (_,p) = p  -- | get the Int x and Int y grid coordinates for a ValuedPoint (using floor). gridCoords :: ValuedPoint a => a -> (Int,Int)@@ -89,10 +91,8 @@ fromGrid :: Grid a -> Int -> Int -> [a] fromGrid gd n =      case IMap.lookup n (gridmap gd) of-      Nothing ->  (\_ -> [])-      Just imp -> (\m -> case IMap.lookup m imp of-                          Nothing -> []-                          Just aps -> aps)+      Nothing ->  const []+      Just imp -> (\m -> fromMaybe [] (IMap.lookup m imp))   -- | get the list of (valued) points from 9 grid cells (around the one with given Int coords)          fromGridNear :: Grid a -> Int -> Int -> [a]@@ -127,7 +127,7 @@ -- | insert (valued) points into a new grid without any checks. -- This is used to initialise a grid with (valued) points known not to be touching.        createGrid :: ValuedPoint a => [a] -> Grid a-createGrid aps = foldl' (flip insertGrid) (Grid IMap.empty) aps+createGrid = foldl' (flip insertGrid) (Grid IMap.empty)  -- | insert (valued) points into a new grid with checks. -- This will return Left vpt if vpt is found in the grid with a touching location,@@ -149,8 +149,3 @@           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

@@ -24,7 +24,7 @@ module Tgraph.Prelude   ( module HalfTile   , module Try-       -- * Making Tgraphs+  -- * Making Tgraphs   , Tgraph() -- not Data Constructor Tgraph   , TileFace   , makeTgraph@@ -32,49 +32,42 @@   , checkedTgraph   , makeUncheckedTgraph   , emptyTgraph--- * Vertices and Edges+  -- * Vertex and Edge Types   , Vertex   , VertexSet   , VertexMap   , Dedge-    -- $Edges+     -- $Edges   , EdgeType(..) -- * Tgraph Property Checks---  , renumberFaces---  , differing   , tryTgraphProps   , tryConnectedNoCross   , tryCorrectTouchingVs---  , findEdgeLoops   , hasEdgeLoops   , duplicates---  , duplicateInts---  , conflictingDedges   , edgeType-  --, findEdgeLoop---  , sharedEdges---  , newSharedEdges-  , noNewConflict--- unused  , noNewConflictFull---  , legal---  , illegals+  , compatibleNew+  , noNewConflict --dep   , illegalTiling   , crossingBVs- -- , crossingVertices   , crossingBoundaries   , connected---  , connectedBy    -- * HasGraph operations   , HasGraph(..)+  , nullGraph+  , rotating+  , aligning+  , makeVP+  , rotatedVP+  , alignedVP   , selectFaces   , removeFaces   , removeVertices   , selectVertices      -- * HasFaces operations   , HasFaces(..) -- faces, boundaryESet, maxV, boundaryVFMap-  , boundaryEdgeSet+--  , boundaryEdgeSet   , boundary--- , maxV   , dedgeSet   , dedges   , evalDedge@@ -82,17 +75,12 @@   , vertexSet   , vertices   , boundaryVSet-  , boundaryVertexSet   , boundaryVsDup   , boundaryEFMap   , boundaryVFaces   , boundaryEFaces-  , boundaryEdgeFaces   , boundaryJoinFaces-  --, boundaryVFMap---  , faces   , nullFaces-  , nullGraph   , evalFaces   , evalFace   , faceCount@@ -107,9 +95,7 @@   , nonPhiEdges   , defaultAlignment   , vertexFMap-  , vertexFacesMap   , dedgeFMap-  , dedgesFacesMap   , buildEFMap   , extractLowestJoin   , lowestJoin@@ -135,7 +121,7 @@   , prevV   , isAtV   , hasVIn-    -- * Face and Edge ops+    -- * Other Face-Edge-Vertex ops   , faceDedges   , reverseD   , joinE@@ -144,23 +130,22 @@   , joinOfTile   , facePhiEdges   , faceNonPhiEdges---  , matchingE-  , matchingLongE-  , matchingShortE-  , matchingJoinE+  , sharedLongE+  , sharedShortE+  , sharedJoinE   , hasDedge   , hasDedgeIn   , completeEdgeSet   , completeEdges   , bothDirSet   , bothDir---   , bothDirOneWay   , missingRevs   , missingRevSet+  , vertexSetForEdges+  , verticesForBEs     -- * VPatch and Conversions   , VPatch(..)   , VertexLocMap-  , makeVP   , subFaces   , relevantVP   , restrictTo@@ -169,23 +154,14 @@   , removeVerticesFromVP   , selectVerticesFromVP   , findLoc-    -- * Drawing Tgraphs and VPatches with Labels+  , centerOn+  , alignXaxis+  , alignments+    -- * Drawing with Labels   , DrawableLabelled(..)   , labelSize   , labelled-  , rotating-  , rotatedVP-  , rotateBefore -- deprecated   , dropLabels--- * Tgraph and VPatch alignment with vertices-  , aligning-  , alignBefore -- deprecated-  , alignedVP-  , makeAlignedVP -- deprecated-  , centerOn-  , alignXaxis-  , alignments-  , alignAll     -- *  Drawing Edges   , drawEdgesVP   , drawEdgeVP@@ -215,9 +191,9 @@ import qualified Data.IntSet as IntSet (union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteFindMin,findMin,findMax,member,difference,elems) import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map (fromList, lookup, fromListWith, elems, filterWithKey)-import Data.Maybe (mapMaybe) -- edgeNbrs+import Data.Maybe (mapMaybe, maybeToList) -- edgeNbrs import Data.Set (Set)-import qualified Data.Set as Set (fromList,member,null,delete,elems,empty,insert,foldl')+import qualified Data.Set as Set (fromList,member,null,delete,elems,empty,insert,foldl',toList) import Diagrams.Prelude hiding (union,mapping) -- import Diagrams.TwoD.Text (Text) @@ -288,6 +264,8 @@ It produces an error if either check fails. Note that the other Tgraph properties are checked first, to ensure that calculation of  vertex locations can be done for a touching vertex check.++See also checkedTgraph and tryConnectedNoCross -} makeTgraph :: [TileFace] -> Tgraph makeTgraph fcs = runTry $ onFail "makeTgraph: (failed):\n" $ tryMakeTgraph fcs@@ -299,6 +277,8 @@ It produces Left ... if either check fails and Right g otherwise where g is the Tgraph. Note that the other Tgraph properties are checked first, to ensure that calculation of  vertex locations can be done.++See also checkedTgraph and tryConnectedNoCross -} tryMakeTgraph :: [TileFace] -> Try Tgraph tryMakeTgraph fcs =@@ -349,19 +329,12 @@  -- |fully evaluate a tileface evalFace :: TileFace -> TileFace-evalFace !f@(LD (!x,!y,!z)) = x `seq` y `seq` z `seq` f -evalFace !f@(RD (!x,!y,!z)) = x `seq` y `seq` z `seq` f-evalFace !f@(LK (!x,!y,!z)) = x `seq` y `seq` z `seq` f -evalFace !f@(RK (!x,!y,!z)) = x `seq` y `seq` z `seq` f +evalFace f@(LD (!x,!y,!z)) = x `seq` y `seq` z `seq` f +evalFace f@(RD (!x,!y,!z)) = x `seq` y `seq` z `seq` f+evalFace f@(LK (!x,!y,!z)) = x `seq` y `seq` z `seq` f +evalFace f@(RK (!x,!y,!z)) = x `seq` y `seq` z `seq` f   -{- -- |evaluate a tileface (and check for edgeloops)-evalFace :: TileFace -> TileFace-evalFace f = if x==y || x==z || y==z -             then error $ "evalFace : Edge loop found for face " ++ show f-             else f-             where (x,y,z) = faceVs f- -} -- |fully evaluate a list of tilefaces. evalFaces :: HasFaces a => a -> a evalFaces !a = foldr (seq . evalFace) () (faces a) `seq` a@@ -372,6 +345,9 @@  Note: This does not check for touching vertices (distinct labels for the same vertex). To perform this additional check use makeTgraph which also uses tryTgraphProps.++If only connectedness and no crossing boundaries needs to be checked, use tryConnectedNoCross+(e.g. when faces come from an existing Tgraph or from a composition). -} checkedTgraph:: [TileFace] -> Tgraph checkedTgraph = runTry . onFail report . tryTgraphProps@@ -390,27 +366,45 @@ Returns Left lines if a test fails, where lines describes the problem found. -} tryTgraphProps:: [TileFace] -> Try Tgraph-tryTgraphProps []       =  Right emptyTgraph-tryTgraphProps fcs-      | hasEdgeLoops fcs  =-         failReport $ "tryTgraphProps: Non-valid tile-face(s)\n" ++-                      "Edge Loops at: " ++ show (findEdgeLoops fcs) ++ "\n"-      | illegalTiling fcs =  failReports-                               ["tryTgraphProps: Non-legal tiling\n"-                               ,"Conflicting face directed edges (non-planar tiling): "-                               ,show (conflictingDedges fcs)-                               ,"\nIllegal tile juxtapositions: "-                               ,show (illegals fcs)-                               ,"\n"-                               ]-      | otherwise         = let vs = vertexSet fcs-                            in if IntSet.findMin vs <1 -- any (<1) $ IntSet.toList vs-                               then failReports-                                        ["tryTgraphProps: Vertex numbers not all >0: "-                                        ,show (IntSet.toList vs)-                                        ,"\n"-                                        ]-                               else tryConnectedNoCross fcs+tryTgraphProps []  = Right emptyTgraph+tryTgraphProps fcs =+   let vs = vertexSet fcs  -- delay subsequent in case never used+       ~deslist = dedges fcs+       ~edgeLoops = filter (uncurry (==)) deslist+       ~conflicting = duplicates deslist+       ~efMap = buildEFMap fcs -- dedgeFMap deslist fcs+       ~sharedEs = [(f1, edgeType d1 f1, f2, edgeType d2 f2)+                   | d1 <- filter (uncurry (<)) deslist+                   , let d2 = reverseD d1+                   , f1 <- maybeToList $  Map.lookup d1 efMap+                   , f2 <- maybeToList $  Map.lookup d2 efMap+                   ]+       ~illegalEs = filter (not . legal) sharedEs+    in if IntSet.findMin vs <1+       then failReports ["tryTgraphProps: Vertex numbers not all >0: "+                        ,show (IntSet.toList vs)+                        ,"\n"+                        ]+       else if not $ null edgeLoops+       then failReports ["tryTgraphProps: Non-valid tile-face(s)\n"+                        ,"Edge Loops at: "+                        , show edgeLoops+                        ,"\n"+                        ]+       else if not $ null conflicting+       then failReports ["tryTgraphProps: Non-legal tiling\n"+                        ,"Conflicting face directed edges (non-planar tiling): "+                        ,show conflicting+                        ,"\n"+                        ]+       else if not $ null illegalEs+       then failReports ["tryTgraphProps: Non-legal tiling\n"+                        ,"Illegal tile juxtapositions: "+                        ,show illegalEs+                        ,"\n"+                        ]+           -- makes use of precalculated edges and vertices+      else tryConnectedNoCross' fcs deslist vs  -- |Checks a list of faces for no crossing boundaries and connectedness. -- (No crossing boundaries and connected implies tile-connected).@@ -419,36 +413,49 @@ -- This is used by tryTgraphProps after other checks have been made, -- but can be used alone when other properties are known to hold (e.g. in tryPartCompose) tryConnectedNoCross:: [TileFace] -> Try Tgraph-tryConnectedNoCross fcs-  | not (connected fcs) = failReports-                              ["tryConnectedNoCross: Non-valid Tgraph (Not connected)\n"-                              ,show fcs-                              ,"\n"-                              ]-  | crossingBoundaries fcs = failReports-                                ["tryConnectedNoCross: Non-valid Tgraph\n"-                                ,"Crossing boundaries found at "-                                ,show (crossingBVs fcs)-                                ,"\nwith faces\n"-                                ,show fcs-                                ,"\n"-                                ]-  | otherwise            = Right (Tgraph fcs)---- |Returns any repeated vertices within each TileFace for a list of TileFaces.-findEdgeLoops:: HasFaces a => a -> [Vertex]-findEdgeLoops = concatMap findEdgeLoop . faces+tryConnectedNoCross [] = Right emptyTgraph+tryConnectedNoCross fcs = tryConnectedNoCross' fcs (dedges fcs) (vertexSet fcs) --- |Returns a repeated vertex for TileFace-findEdgeLoop :: TileFace -> [Vertex]-findEdgeLoop = duplicates . faceVList+-- |(not exported) A variant of tryConnectedNoCross with precalculated dedge list and vertex set.+-- Checks for no crossing boundaries and connectedness.+-- The given dedge list must be all the dedges in the faces, +-- and the given vertex set must be all the vertices in the faces.+-- The faces must not be null.+-- Returns Right g where g is a Tgraph on passing checks.+-- Returns Left lines if a test fails, where lines describes the problem found.+-- This is used by tryTgraphProps after other checks have been made,+-- but can be used alone when other properties are known to hold (e.g. in tryPartCompose)+tryConnectedNoCross' :: [TileFace] -> [Dedge] -> IntSet -> Try Tgraph+tryConnectedNoCross' fcs deslist vs = -- no arguments are null+    let des = Set.fromList deslist+        bes = missingRevSet des -- boundaryESetFrom+        duplicateBVs = duplicates $ verticesForBEs bes+        crossing = not $ null duplicateBVs+        connectedFcs = null (snd $ connectedBy (bes<>des) (IntSet.findMin vs) vs)+    in if not connectedFcs+       then failReports+            ["tryConnectedNoCross: Non-valid Tgraph (Not connected)\n"+            ,"with faces\n"+            ,show fcs+            ,"\n"+            ]+       else if crossing+       then failReports+            ["tryConnectedNoCross: Non-valid Tgraph\n"+            ,"Crossing boundaries found at "+            ,show duplicateBVs+            ,"\nwith faces\n"+            ,show fcs+            ,"\n"+            ]+       else Right (Tgraph fcs) --- |Checks if there are repeated vertices within any TileFace for a list of TileFaces.+-- |Used in testing.+---Checks if there are repeated vertices within any TileFace for a list of TileFaces. -- Returns True if there are any. hasEdgeLoops:: HasFaces a => a  -> Bool-hasEdgeLoops = not . null . findEdgeLoops--+hasEdgeLoops = any (uncurry (==)) . dedges+  -- |duplicates finds any duplicated items in a list. -- It produces unique results (that is duplicates (duplicates es) == [] ). duplicates :: Ord a => [a] -> [a]@@ -458,15 +465,6 @@                          | x `Set.member` seen = check (Set.insert x dups) seen xs                          | otherwise = check dups (Set.insert x seen) xs ---- |conflictingDedges fcs returns a list of conflicting directed edges in fcs--- i.e. different faces having the same edge in the same direction.--- (which should be null for a Tgraph)-conflictingDedges :: HasFaces a => a -> [Dedge]-conflictingDedges = duplicates . dedges--- -- | edgeType d f - classifies the directed edge d -- which must be one of the three directed edges of face f. -- An error is raised if it is not a directed edge of the face@@ -477,21 +475,11 @@              | otherwise = error $ "edgeType: directed edge " ++ show d ++                                    " not found in face " ++ show f ++ "\n" --- |For a list of tile faces fcs this produces a list of tuples of the form (f1,etpe1,f2,etype2)--- where f1 and f2 share a common edge and etype1 is the type of the shared edge in f1 and--- etype2 is the type of the shared edge in f2.--- This list can then be checked for inconsistencies / illegal pairings (using legal).-sharedEdges:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]-sharedEdges fcs = [(f1, edgeType d1 f1, f2, edgeType d2 f2)-                   | f1 <- fcs-                   , d1 <- faceDedges f1-                   , let d2 = reverseD d1-                   , f2 <- filter (`hasDedge` d2) fcs-                  ]- {-# INLINE newSharedEdges #-}--- |A version of sharedEdges comparing a single face against a list of faces.--- This does not look at shared edges within the list, but just the new face against the list.+-- |newSharedEdges face fcs - compares face against a list of faces (fcs) +-- to produce information about edges of face that are shared with fcs.+-- This does not look at shared edges within fcs.+-- It does not check for conflicts (common edges in the same direction). newSharedEdges:: TileFace -> [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)] newSharedEdges face fcs =     [(face, edgeType d1 face, fc', edgeType d2 fc')@@ -500,11 +488,19 @@      , fc' <- filter (`hasDedge` d2) fcs     ] +-- | compatibleNew face fcs returns True if face has an illegal shared edge with fcs.+-- It does not check for illegal cases within the fcs.+-- It does not check for conflicting edges (sharing a directed edge in the same direction).+compatibleNew :: TileFace -> [TileFace] -> Bool+compatibleNew face fcs = all legal sharededges where+    sharededges = newSharedEdges face fcs++{-# DEPRECATED noNewConflict "Renamed as compatibleNew" #-} -- | noNewConflict face fcs returns True if face has an illegal shared edge with fcs. -- It does not check for illegal cases within the fcs.+-- It does not check for conflicting edges (sharing a directed edge in the same direction). noNewConflict :: TileFace -> [TileFace] -> Bool-noNewConflict face fcs = all legal shared where-    shared = newSharedEdges face fcs+noNewConflict = compatibleNew  -- | legal (f1,etype1,f2,etype2) is True if and only if it is legal for f1 and f2 to share an edge -- with edge type etype1 (and etype2 is equal to etype1).                   @@ -525,44 +521,41 @@ legal (RK _, Long,  LD _ , Long ) = True legal _ = False --- | Returns a list of illegal face pairings of the form (f1,e1,f2,e2) where f1 and f2 share an edge--- and e1 is the type of this edge in f1, and e2 is the type of this edge in f2.--- The list should be null for a legal Tgraph.-illegals:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]-illegals = filter (not . legal) .  sharedEdges---- | Returns True if there are conflicting directed edges or if there are illegal shared edges+-- | Used for testing. Returns True if there are conflicting directed edges or if there are illegal shared edges -- in the list of tile faces illegalTiling:: [TileFace] -> Bool-illegalTiling fcs = not (null (illegals fcs)) || not (null (conflictingDedges fcs))+illegalTiling fcs =  -- relies on || lazy in second arg as efMap assumes no duplicate dedges+    not (null $ duplicates deslist) || not (null illegals) where+       deslist = dedges fcs+       ~efMap = buildEFMap fcs -- dedgeFMap deslist fcs+       ~sharedEs = [(f1, edgeType d1 f1, f2, edgeType d2 f2)+                   | d1 <- filter (uncurry (<)) deslist+                   , let d2 = reverseD d1+                   , f1 <- maybeToList $  Map.lookup d1 efMap+                   , f2 <- maybeToList $  Map.lookup d2 efMap+                   ]+       ~illegals = filter (not . legal) sharedEs  -- |crossingBVs fcs returns a list of vertices where there are crossing boundaries -- (which should be null for Tgraphs, VPatches, BoundaryStates, Forced, TrackedTgraph).                crossingBVs :: HasFaces a => a -> [Vertex] crossingBVs = duplicates . boundaryVsDup -{- -- |duplicateInts - not exported.--- finds any duplicated items in a list (unique results).--- It uses IntSet, so faster than duplicates on large integer lists.-duplicateInts :: [Int] -> [Int]-duplicateInts = check IntSet.empty IntSet.empty where-  check dups _ [] = IntSet.toList dups-  check dups seen (x:xs) | x `IntSet.member` dups = check dups seen xs-                         | x `IntSet.member` seen = check (IntSet.insert x dups) seen xs-                         | otherwise = check dups (IntSet.insert x seen) xs- -}- -- |There are crossing boundaries if vertices occur more than once -- in the boundary vertices.+ crossingBoundaries :: HasFaces a => a  -> Bool-crossingBoundaries = not . null . crossingBVs+crossingBoundaries = not . null . crossingBVs -- Used in testing --- |Predicate to check if the faces are connected (in graph theory sense).+-- |Predicate to check if the faces are connected.+-- That is, the vertices of the faces are connected by the edges (assumed bidirectional). connected:: HasFaces a => a -> Bool-connected = conn . faces where+connected = conn . faces where -- n.b. no longer used internally as tryConnectedNoCross+                               -- now calls connectedBy directly     conn [] =  True-    conn fcs = null (snd $ connectedBy (completeEdges fcs) (IntSet.findMin vs) vs)+    conn fcs = null (snd $ connectedBy edges (IntSet.findMin vs) vs)                     where vs = vertexSet fcs+                          edges = bothDirSet (dedgeSet fcs)  -- |Auxiliary function for calculating connectedness. -- connectedBy edges v verts returns a pair of lists of vertices (conn,unconn)@@ -570,9 +563,9 @@ -- and unconn is a list of vertices from set verts that are not connected to v. -- This version creates an IntMap to represent edges (Vertex to [Vertex]) -- and uses IntSets for the search algorithm arguments.-connectedBy :: [Dedge] -> Vertex -> VertexSet -> ([Vertex],[Vertex])+connectedBy :: Set Dedge -> Vertex -> VertexSet -> ([Vertex],[Vertex]) connectedBy edges v verts = search IntSet.empty (IntSet.singleton v) (IntSet.delete v verts) where-  nextMap = VMap.fromListWith (++) $ map (\(a,b)->(a,[b])) edges+  nextMap = VMap.fromListWith (++) $ map (\(a,b)->(a,[b])) (Set.toList edges) -- search arguments (sets):  done (=processed), visited, unvisited.   search done visited unvisited     | IntSet.null unvisited = (IntSet.toList visited ++ IntSet.toList done,[])@@ -581,14 +574,7 @@         let (x,visited') = IntSet.deleteFindMin visited             newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x         in  search (IntSet.insert x done) (IntSet.union newVs visited') (unvisited IntSet.\\ newVs)-          -{-             x = IntSet.findMin visited-              visited' = IntSet.deleteMin visited-              newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x - -}-- -- |The empty Tgraph emptyTgraph :: Tgraph emptyTgraph = Tgraph []@@ -599,7 +585,7 @@  -- |does the graph have no faces? nullGraph :: HasGraph a => a -> Bool-nullGraph g = nullFaces (recoverGraph g)+nullGraph = nullFaces . recoverGraph  -- |Class HasFaces for operations using (a list of) TileFaces. -- @@ -620,17 +606,11 @@     -- |the set of directed edges of the boundary     -- (direction with a tileface on the left and exterior on right).     boundaryESet :: a -> Set Dedge-    boundaryESet = missingRevSet . dedgeSet --missingRevSet . dedges+    boundaryESet = missingRevSet . dedgeSet      -- |create a map associating to each boundary vertex, a list of faces at the vertex     boundaryVFMap :: a -> VertexMap [TileFace]-    boundaryVFMap a = vertexFMap (boundaryVSet fcs) fcs-                       where fcs = faces a--{-# DEPRECATED boundaryEdgeSet "Use boundaryESet" #-}--- |get the set of boundary directed edges-boundaryEdgeSet :: HasFaces a => a -> Set Dedge-boundaryEdgeSet = boundaryESet+    boundaryVFMap a = vertexFMap (boundaryVSet a) (faces a)  -- |An ascending list of the vertices occuring in faces (without duplicates) vertices :: HasFaces a => a -> [Vertex]@@ -649,35 +629,32 @@ -- This may have duplicates when applied to an arbitrary list of TileFace or VPatch. -- but has no duplicates for Tgraph, BoundaryState, Forced, TrackedTgraph.  boundaryVsDup :: HasFaces a => a -> [Vertex]-boundaryVsDup = Set.foldl' (flip ((:).fst)) [] . boundaryESet+boundaryVsDup = verticesForBEs . boundaryESet    -- map fst . boundary +-- |Given a complete set of boundary edges this produces a list of the boundary vertices+-- (with duplicates if and only if the boundary is a crossing boundary).+-- If the edges are not a complete boundary, Use (Set.toList . vertexSetForEdges).+verticesForBEs :: Set Dedge -> [Vertex]+verticesForBEs = Set.foldl' (flip ((:).fst)) []+ -- |get all the directed edges (directed clockwise round each face) dedges :: HasFaces a => a -> [Dedge] dedges = concatMap faceDedges . faces  -- | fully evaluate a directed edge evalDedge :: Dedge -> Dedge-evalDedge !e@(a,b) | a==b = error $ "evalEdge: loop edge found with vertex " ++ show a ++ "\n"-                 | otherwise = e+evalDedge e@(a,b) | a==b = error $ "evalEdge: loop edge found with vertex " ++ show a ++ "\n"+                  | otherwise = e  -- | fully evaluate a list of directed edges evalDedges :: [Dedge] -> [Dedge]            evalDedges !es = foldr (seq . evalDedge) () es `seq` es ---- |create a directed edge to face map from the (reverse direction of the) boundary edges+-- |create a directed edge to face map from the (reverse direction of the) boundary edges.+-- Thus if dedge d maps to face f, then d is a dedge of f (and reverseD d is a boundary dedge). boundaryEFMap :: HasFaces a => a -> Map Dedge TileFace-boundaryEFMap fcs = Map.fromList (assocFaces des) where-       des = map reverseD $ boundary fcs-       vfMap = boundaryVFMap 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 $ "boundaryEFMap: more than one Tileface has the same directed edge: "-                              ++ show d ++ "\n"+boundaryEFMap a = makeEFMapFrom (map reverseD $ boundary a) (boundaryVFMap a)  -- |find the faces which have at leat one boundary vertex. boundaryVFaces :: HasFaces a => a -> [TileFace]@@ -687,11 +664,6 @@ boundaryVSet :: HasFaces a => a -> VertexSet boundaryVSet = IntSet.fromList . boundaryVsDup -{-# DEPRECATED boundaryVertexSet "Use boundaryVSet" #-}--- |get the set of boundary vertices-boundaryVertexSet :: HasFaces a => a -> VertexSet-boundaryVertexSet = boundaryVSet- -- |A list of tilefaces is in class HasFaces instance HasFaces [TileFace] where     faces = id@@ -780,11 +752,16 @@  -- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace faceVs::TileFace -> (Vertex,Vertex,Vertex)-faceVs = tileRep+faceVs = evalTriple . tileRep++-- |force evaluation of a triple+evalTriple :: (Int,Int,Int) -> (Int,Int,Int)+evalTriple tr@(a,b,c) = a `seq` b `seq` c `seq` tr+ -- |list of (three) face vertices in order clockwise starting with origin faceVList::TileFace -> [Vertex] -- faceVList = (\(x,y,z) -> [x,y,z]) . faceVs-faceVList f = [a,b,c] where (!a,!b,!c) = faceVs f+faceVList f = [a,b,c] where (a,b,c) = faceVs f -- |the set of vertices of a face faceVSet :: TileFace -> VertexSet -- faceVSet = IntSet.fromList . faceVList@@ -794,9 +771,9 @@  -- |firstV, secondV and thirdV vertices of a face are counted clockwise starting with the origin firstV,secondV,thirdV:: TileFace -> Vertex-firstV  face = a where (!a,_,_) = faceVs face-secondV face = b where (_,!b,_) = faceVs face-thirdV  face = c where (_,_,!c) = faceVs face+firstV  face = a where (a,_,_) = faceVs face+secondV face = b where (_,b,_) = faceVs face+thirdV  face = c where (_,_,c) = faceVs face  originV,wingV,oppV:: TileFace -> Vertex -- |the origin vertex of a face (firstV)@@ -818,7 +795,7 @@               | v==b = 1               | v==c = 2               | otherwise = error ("indexV: " ++ show v ++ " not found in " ++ show face)-              where (!a,!b,!c) = faceVs face+              where (a,b,c) = faceVs face  {- indexV v face = case elemIndex v (faceVList face) of                   Just i -> i@@ -844,7 +821,7 @@ -- |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+     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@@ -869,21 +846,16 @@  -- |produces a list of directed edges (clockwise) round a face. faceDedges::TileFace -> [Dedge]-faceDedges (LD(!a,!b,!c)) = [(a,b),(b,c),(c,a)]-faceDedges (RD(!a,!b,!c)) = [(a,b),(b,c),(c,a)]-faceDedges (LK(!a,!b,!c)) = [(a,b),(b,c),(c,a)]-faceDedges (RK(!a,!b,!c)) = [(a,b),(b,c),(c,a)]+faceDedges f = [(a,b),(b,c),(c,a)] where (a,b,c) = faceVs f --  faceDedges !f = [(a,b),(b,c),(c,a)] where (!a,!b,!c) = faceVs f -- |produces a list of directed edges (clockwise) round a face. faceDedgeSet::TileFace -> Set Dedge-faceDedgeSet (LD(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty-faceDedgeSet (RD(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty-faceDedgeSet (LK(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty-faceDedgeSet (RK(!a,!b,!c)) = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty+faceDedgeSet f = Set.insert (a,b) $ Set.insert (b,c) $ Set.insert (c,a) Set.empty+                 where (a,b,c) = faceVs f  -- |opposite directed edge. reverseD:: Dedge -> Dedge-reverseD (!a,!b) = (b,a)+reverseD (!a,!b) = (b,a) -- swap  {- -- |firstE, secondE and thirdE are the directed edges of a face counted clockwise from the origin, @@ -938,21 +910,21 @@ faceNonPhiEdges (LK(_,!b,!c))  = [(b,c),(c,b)] -- faceNonPhiEdges face = bothDirOneWay (faceDedges face) \\ facePhiEdges face --- |matchingE eselect face is a predicate on tile faces --- where eselect selects a particular edge type of a face--- (eselect could be joinE or longE or shortE for example).--- This is True for face' if face' has an eselect edge matching the (reversed) eselect edge of face.-matchingE :: (TileFace -> Dedge) -> TileFace -> TileFace -> Bool-matchingE eselect face = (== reverseD (eselect face)) . eselect+-- |not exported : shared edgeChoice face is a predicate on tile faces +-- where edgeChoice selects a particular edge of a face+-- (joinE or longE or shortE).+-- Used to define sharedLongE, sharedShortE, sharedJoinE.+shared :: (TileFace -> Dedge) -> TileFace -> TileFace -> Bool+shared edgeChoice face = (== reverseD (edgeChoice face)) . edgeChoice -matchingLongE,matchingShortE,matchingJoinE ::  TileFace -> TileFace -> Bool-      -- Used in Compose (getDartWingInfo and composedFaceGroups).++sharedLongE,sharedShortE,sharedJoinE ::  TileFace -> TileFace -> Bool -- |check if two TileFaces have opposite directions for their long edge.-matchingLongE  = matchingE longE+sharedLongE  = shared longE -- |check if two TileFaces have opposite directions for their short edge.-matchingShortE = matchingE shortE+sharedShortE = shared shortE -- |check if two TileFaces have opposite directions for their join edge.-matchingJoinE  = matchingE joinE+sharedJoinE  = shared joinE  -- |hasDedge f e returns True if directed edge e is one of the directed edges of face f hasDedge :: TileFace -> Dedge -> Bool@@ -973,40 +945,34 @@ completeEdgeSet :: HasFaces a => a -> Set Dedge completeEdgeSet = bothDirSet . dedgeSet --- |bothDir adds missing reverse directed edges to a list of directed edges--- to complete edges (Result is a complete edge list)--- It assumes no duplicates in argument.+-- |bothDir des - forms a complete bidirectional list of edges from the given list des (of directed edges).+-- It adds missing reverse directed edges to des (i.e its boundary directed edge list).+-- It assumes no duplicates in des. bothDir:: [Dedge] -> [Dedge]-bothDir es = missingRevs es ++ es+bothDir es = missingRevs es <> es --- |bothDirSet adds missing reverse directed edges to a set of directed edges--- to complete edges (Result is a complete edge set)+-- |bothDirSet des forms a complete bidirectional set of edges from the set des (of directed edges).+-- It adds missing reverse directed edges to des (i.e its boundary directed edge set). bothDirSet:: Set Dedge -> Set Dedge bothDirSet es = missingRevSet es <> es -{- --- |bothDirOneWay adds all the reverse directed edges to a list of directed edges--- 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 [] = []-bothDirOneWay (e@(a,b):es)= e:(b,a):bothDirOneWay es- -}+-- |The set of vertices in a list of edges.+-- It does not assume edges form loops (unlike verticesForBEs)+vertexSetForEdges :: [Dedge] -> IntSet+vertexSetForEdges des = IntSet.fromList fsts <> IntSet.fromList snds+    where (fsts,snds) = unzip des  --- | efficiently finds missing reverse directions from a list of directed edges--- and returning a dedge list. (It uses missingRevSet)+-- |Given a list of directed edges, finds the boundary directed edge list.+-- That is, it finds missing reverse directions for the given list. missingRevs:: [Dedge] -> [Dedge]---missingRevs = Set.elems . missingRevSet . Set.fromList---missingRevs:: Set Dedge -> Set Dedge-missingRevs es = Set.elems $ foldl' check Set.empty es where+missingRevs = Set.elems . foldl' check Set.empty where     check eset e@(a,b) | Set.member e eset = Set.delete e eset                  | otherwise = Set.insert (b,a) eset --- | efficiently finds missing reverse directions from a set of directed edges,--- and returns them as a set.+-- |Given a set of directed edges, finds the boundary directed edge set.+-- That is, it finds missing reverse directions from the given set. missingRevSet:: Set Dedge -> Set Dedge-missingRevSet es = Set.foldl' check Set.empty es where+missingRevSet = Set.foldl' check Set.empty where     check eset e@(a,b) | Set.member e eset = Set.delete e eset                        | otherwise = Set.insert (b,a) eset @@ -1031,11 +997,17 @@                       where addf Nothing = Nothing                             addf (Just fs) = Just (f:fs) -{-# DEPRECATED vertexFacesMap "Use vertexFMap . IntSet.fromList" #-}--- |For vertex list vs and faces from a,--- create a VertexMap 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 = vertexFMap . IntSet.fromList+-- | Given a list of dedges and a vertex to faces map, create an edge to faces map.+-- The vertex to faces map should have a key for each vertex in the edge list.+-- An error will be raised if more than one face has the same directed edge in the dedge list+makeEFMapFrom :: [Dedge] -> IntMap [TileFace] -> Map Dedge TileFace+makeEFMapFrom des vfmap = Map.fromList (mapMaybe assocFace des) where+    assocFace d@(a,b) =+        case filter (liftA2 (&&) (isAtV a) (`hasDedge` d)) (vfmap VMap.! b) of+            [face] -> Just (d,face)+            []     -> Nothing+            other  -> error $ "makeEFMapFrom: more than one Tileface has the same directed edge: "+                              ++ show d ++ "\nfaces: " ++ show other ++ "\n"  -- | dedgeFMap des a - Produces an edge-face map. Each directed edge in des is associated with -- a unique face in a that has that directed edge (if there is one).@@ -1043,21 +1015,7 @@ -- If the directed edges are all the ones in a, buildEFMap will be more efficient. -- If the edges are just the boundary edges, use boundaryEFMap instead. dedgeFMap:: HasFaces a => [Dedge] -> a -> Map Dedge TileFace-dedgeFMap des fcs =  Map.fromList (assocFaces des) where-   vset = IntSet.fromList (map fst des) `IntSet.union` IntSet.fromList (map snd des)-   vfMap = vertexFMap vset 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 $ "dedgeFMap: more than one Tileface has the same directed edge: "-                          ++ show d ++ "\n"--{-# DEPRECATED dedgesFacesMap "Use dedgeFMap" #-}--- |same as dedgeFMap-dedgesFacesMap:: HasFaces a => [Dedge] -> a -> Map Dedge TileFace-dedgesFacesMap = dedgeFMap+dedgeFMap des a = makeEFMapFrom des (vertexFMap (vertexSetForEdges des) a)  -- |select the faces with a join edge on the boundary. -- Useful for drawing join edges only on the boundary.@@ -1069,11 +1027,6 @@ boundaryEFaces :: HasFaces a => a -> [TileFace] boundaryEFaces = nub . Map.elems . boundaryEFMap -{-# DEPRECATED boundaryEdgeFaces "Use boundaryEFaces" #-}--- |find the faces in with at least one boundary edge.-boundaryEdgeFaces :: HasFaces a => a -> [TileFace]-boundaryEdgeFaces = boundaryEFaces- -- |Build a full Map from all directed edges to faces (the unique face containing the directed edge) -- The faces should not contain conflicting dedges.  -- That is, if more than one face has the same dedge, @@ -1089,7 +1042,7 @@ -- |Given a tileface (face) and a map from each directed edge to the (unique) tileface containing it (efMap) -- return the list of edge neighbours of face. edgeNbs:: TileFace -> Map Dedge TileFace -> [TileFace]-edgeNbs face efMap = mapMaybe (flip faceForEdge efMap) edges where+edgeNbs face efMap = mapMaybe (`faceForEdge` efMap) edges where    edges = reverseD <$> faceDedges face  -- |For an argument with a non-empty list of faces,@@ -1267,12 +1220,6 @@             (Patch -> Diagram b) -> a -> Diagram b labelled = labelColourSize red small --(normalized 0.023) -{-# DEPRECATED rotateBefore "Use (flip rotating)" #-}--- |rotateBefore vfun a g - makes a VPatch from g then rotates by angle a before applying the VPatch function vfun.--- Tgraphs need to be rotated after a VPatch is calculated but before any labelled drawing.-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 vfun  -- (a VPatch continuation function - usually a drawing function). -- Tgraphs need to be rotated after a VPatch is calculated but before any labelled drawing.@@ -1314,14 +1261,6 @@                      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  = 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 vfun (a VPatch continuation function - usually a drawing function) -- Will raise an error if either a or b is not a vertex in g.@@ -1331,26 +1270,11 @@ 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--- before applying the VPatch function vfun--- 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.-alignBefore :: (VPatch -> a) -> (Vertex,Vertex) -> Tgraph -> a-alignBefore = flip aligning- -- | alignedVP (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. 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 =>@@ -1413,16 +1337,14 @@     fastAddVPoints [] fcOther _ = error $ "locateVertices (fastAddVPoints): Faces not tile-connected: "                                           ++ show fcOther ++ "\n"     fastAddVPoints (face:fs) fcOther vpMap = fastAddVPoints (fs++nbs) fcOther' vpMap' where-        nbs = filter (`Set.member` fcOther) (eNeighbours face)+        nbs = filter (`Set.member` fcOther) (edgeNbs face themap)         fcOther' = foldl' (flip Set.delete) fcOther nbs --        fcOther' = foldr Set.delete fcOther nbs         vpMap' = addVPoint face vpMap--- Given a list of faces and a face f, produce a list of edge neighbouring faces of f.+-- Used to produce a list of edge neighbouring faces of a face. -- This version assumes no two faces can have a common dedge (using buildEFMap).-    eNeighbours = eNbrs-       where themap = buildEFMap fcs-             eNbrs f  = edgeNbs f themap-+    themap = buildEFMap fcs+     -- |Given a tileface and a vertex to location map which gives locations for at least 2 of the tileface vertices -- this returns a new map by adding a location for the third vertex (when missing) or the same map when not missing. -- It will raise an error if there are fewer than 2 tileface vertices with a location in the map

@@ -36,14 +36,14 @@  --  , relabellingFrom   , uncheckedRelabelGraph   , relabelGraph-  , checkRelabelGraph+--  , checkRelabelGraph   -- $SafeRelabelling --  , relabellingTo --  , extendRelabelling --  , relabellingFrom   , relabelFrom   , relabelAvoid-  , relabelContig+--  , relabelContig   -- * Auxiliary Functions   , relabelFace   , relabelV@@ -341,11 +341,6 @@          tryMakeTgraph newFaces   where newFaces = map (relabelFace rlab) (faces g)  -{-# DEPRECATED checkRelabelGraph "Use relabelGraph" #-}--- |renamed as relabelGraph-checkRelabelGraph :: Relabelling -> Tgraph -> Tgraph-checkRelabelGraph = relabelGraph- {- $SafeRelabelling  __Safe Relabelling__@@ -453,16 +448,7 @@   -- assert: rlab is 1-1 on the vertices of g   --  (the unsafe domain of rlab is disjoint from the vertices of g)   -- assert: the relabelled Tgraph preserves the Tgraph properties- -{-# DEPRECATED relabelContig "Use (relabelFrom 1)" #-}--- |Relabel all vertices in a Tgraph using new labels 1..n (where n is the number of vertices).-relabelContig :: Tgraph -> Tgraph-relabelContig g = uncheckedRelabelGraph rlab g where-   rlab = relabellingFrom 1 (vertexSet g)-  -- assert: rlab is 1-1 on the vertices of g-  --  (the unsafe domain of rlab is disjoint from the vertices of g)-  -- assert: the relabelled Tgraph preserves the Tgraph properties-                     +                       {-| tryMatchFace f g - looks for a face in g that corresponds to f (with a common directed edge), If the corresponding face does not match constructor (LK,RK,LD,RD) this stops the

@@ -429,8 +429,9 @@    emplaceChoicesF:: Forced Tgraph -> [Forced Tgraph]   emplaceChoicesF fg | nullGraph compfg = chooseUnknowns [(unknowns $ getDartWingInfoForced fg, fg)]-                          | otherwise    = forceF . decompose <$> emplaceChoicesF compfg+                     | otherwise        = forceF . decompose <$> emplaceChoicesF compfg                           where compfg = composeF fg+   chooseUnknowns :: [([Vertex],Forced Tgraph)] -> [Forced Tgraph]   chooseUnknowns [] = []   chooseUnknowns (([],g0):more) = g0:chooseUnknowns more

@@ -82,6 +82,9 @@  graphPropSpec :: Spec graphPropSpec = describe "Test Properties of Tgraphs" $ do+    context "An empty Tgraph" $+      it "maxV of makeTgraph [] should be 0" $+        maxV (makeTgraph []) `shouldBe` 0     context "When fcs (a list of tile-faces) has any face with a repeated vertex" $       it "hasEdgeLoops fcs should return True" $         hasEdgeLoops x0 `shouldBe` True