PenroseKiteDart 1.6 → 1.6.1

raw patch · 12 files changed

+435/−373 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +92/−63
• PenroseKiteDart.cabal +1/−1
• README.md +1/−1
• benchmark/Bench.hs +1/−1
• src/Tgraph/Compose.hs +63/−61
• src/Tgraph/Decompose.hs +4/−5
• src/Tgraph/Extras.hs +83/−37
• src/Tgraph/Force.hs +96/−78
• src/Tgraph/Prelude.hs +69/−100
• src/TgraphExamples.hs +23/−25
• src/TileLib.hs +1/−0
• test/Spec.hs +1/−1

@@ -1,79 +1,108 @@ # Revision history for PenroseKiteDart +## version v1.6.1++- Internal Representation change:+    - Changed type of BoundaryDedges in BoundaryState (constructors not exported)+       (This does not affect boundary or boundaryESet functions).+    - boundaryAt is much more efficient (using new representation for BoundaryDedges) and returns the two boundary directed edges in direction order.++- Other changes:+    - Added nextBV and prevBV+    - Added rotating, aligning, smartRotating, smartAligning, drawTrackedTgraphAligning, drawTrackedTgraphRotating, partComposeDWI.+    - Deprecated smartRotateBefore (Use (flip smartRotating))+    - Deprecated smartAlignBefore (Use (flip smartAligning))+    - Deprecated rotateBefore (Use (flip rotating))+    - Deprecated alignBefore (Use (flip aligning))+    - Deprecated drawTrackedTgraphAligned (Use (flip drawTrackedTgraphAligning))+    - Deprecated drawTrackedTgraphRotated (Use (flip drawTrackedTgraphRotating))+    - Deprecated partComposeFaces (now renamed as partComposeDWI)+    - Changed emphasizeFaces to use smartOn so only boundary joins are drawn (used in commonFaces)+ ## version v1.6-Possibly breaking:-   Replaced boundary in class HasFaces with boundaryESet (Set instead of list)+- Possibly breaking:++   - Replaced boundary in class HasFaces with boundaryESet (Set instead of list)             (boundary now derived from boundaryESet)-   Removed data constructor Relabelling from export-   Renamed relabelGraph as uncheckedRelabelGraph-   Renamed checkRelabelGraph as relabelGraph (now using unsafeDom check)-   Renamed locateVertices as locateGraphVertices AND restricted to Tgraphs only.-   No longer exporting locateVerticesGen-   Removed oldGetDartWingInfo-   Removed oldPartCompose-   Removed partComposeFacesFrom (use partComposeFaces)-Other changes:-   Default implementations in Class HasFaces for boundaryESet, maxV, boundaryVFMap-   Deprecated boundaryEdgeSet (use boundaryESet)-   Deprecated boundaryVertexSet (use boundaryVSet)-   Deprecated boundaryEdgeFaces (use boundaryEFaces)-   Deprecated dedgesFacesMap (use dedgeFMap)-   Deprecated vertexFacesMap (use vertexFMap . IntSet.fromList)-   Added boundaryVSet, boundaryEFaces, dedgeFMap, vertexFMap-   Added evalDedge, evalDedges, evalFace, evalFaces (for full evaluation)-   Added unsafeDom (for use with relabellings)-   Added faceCount-   Added dedgeSet, missingRevSet-   Added partComposeFaces-   relabelAvoid now exported-   relabelFrom now exported-   relabelContig deprecated. Use (relabelFrom 1)-   checkRelabelGraph deprecated. Use (relabelGraph)-   Changed Tgraph definition so no record type used+   - Removed data constructor Relabelling from export+   - Renamed relabelGraph as uncheckedRelabelGraph+   - Renamed checkRelabelGraph as relabelGraph (now using unsafeDom check)+   - Renamed locateVertices as locateGraphVertices AND restricted to Tgraphs only.+   - No longer exporting locateVerticesGen+   - Removed oldGetDartWingInfo+   - Removed oldPartCompose+   - Removed partComposeFacesFrom (use partComposeFaces)++- Other changes:++   - Default implementations in Class HasFaces for boundaryESet, maxV, boundaryVFMap+   - Deprecated boundaryEdgeSet (use boundaryESet)+   - Deprecated boundaryVertexSet (use boundaryVSet)+   - Deprecated boundaryEdgeFaces (use boundaryEFaces)+   - Deprecated dedgesFacesMap (use dedgeFMap)+   - Deprecated vertexFacesMap (use vertexFMap . IntSet.fromList)+   - Added boundaryVSet, boundaryEFaces, dedgeFMap, vertexFMap+   - Added evalDedge, evalDedges, evalFace, evalFaces (for full evaluation)+   - Added unsafeDom (for use with relabellings)+   - Added faceCount+   - Added dedgeSet, missingRevSet+   - Added partComposeFaces+   - relabelAvoid now exported+   - relabelFrom now exported+   - relabelContig deprecated. Use (relabelFrom 1)+   - checkRelabelGraph deprecated. Use (relabelGraph)+   - Changed Tgraph definition so no record type used      (this was hidden anyway but visible when a Tgraph was shown) -Removed deprecated:-   subVP Use (flip subFaces)-   restrictVP Use (flip restrictTo)-   restrictSmart Use smartOn-   selectFacesVP Use (flip restrictTo)-   removeFacesVP Use (flip removeFacesFromVP)-   boundaryFaces Use boundaryVFaces or boundaryEFaces-   pieceEdges Use drawnEdges-   dashjPiece Use drawjPiece-   dashjP3 Use drawjP3+- Removed deprecated: +   - subVP Use (flip subFaces)+   - restrictVP Use (flip restrictTo)+   - restrictSmart Use smartOn+   - selectFacesVP Use (flip restrictTo)+   - removeFacesVP Use (flip removeFacesFromVP)+   - boundaryFaces Use boundaryVFaces or boundaryEFaces+   - pieceEdges Use drawnEdges+   - dashjPiece Use drawjPiece+   - dashjP3 Use drawjP3+ ## version v1.5.1 -possibly breaking:+- possibly breaking:     added boundaryVFMap to class HasFaces -generalised:-    boundaryJoinFaces-    drawBoundaryJoins-    drawJoinsFor-added:-    boundaryEFMap-    smartOn (replacing deprecated restrictSmart)-    restrictTo (replacing deprecated restrictVP)-    subFaces (replacing deprecated subVP)-    boundaryVFaces (replacing deprecated boundaryFaces)-    boundaryEdgeFaces-    removeFacesFromVP (replacing deprecated removeFacesVP)-    removeVerticesFromVP-    selectVerticesFromVP-deprecated:-    selectFacesVP-    restrictSmart-    restrictVP-    subVP-    boundaryFaces-    removeFacesVP+- generalised: -warning avoided for import of foldl'+    - boundaryJoinFaces+    - drawBoundaryJoins+    - drawJoinsFor -joinDashing changed appearance (no longer ultraThin by default)-added: dashJOnly, drawJPiece, and drawJ +- added:++    - boundaryEFMap+    - smartOn (replacing deprecated restrictSmart)+    - restrictTo (replacing deprecated restrictVP)+    - subFaces (replacing deprecated subVP)+    - boundaryVFaces (replacing deprecated boundaryFaces)+    - boundaryEdgeFaces+    - removeFacesFromVP (replacing deprecated removeFacesVP)+    - removeVerticesFromVP+    - selectVerticesFromVP++- deprecated:++    - selectFacesVP+    - restrictSmart+    - restrictVP+    - subVP+    - boundaryFaces+    - removeFacesVP++- warning avoided for import of foldl'++- joinDashing changed appearance (no longer ultraThin by default)++- added: dashJOnly, drawJPiece, and drawJ  (alongside dashjOnly, drawjPiece, and drawj which still use ultraThin)   ## version v1.5 2025-8-9

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           PenroseKiteDart-version:        1.6+version:        1.6.1 synopsis:       Library to explore Penrose's Kite and Dart Tilings. description:    Library to explore Penrose's Kite and Dart Tilings using Haskell Diagrams. Please see README.md category:       Graphics

@@ -2,7 +2,7 @@  Author: Chris Reade -March 2021 - 2025+March 2021 - 2026  See LICENSE file 

@@ -8,8 +8,8 @@ main :: IO () main =    do let wait = threadDelay 100000-     _ <- traceMarkerIO "starting decompositions"       wait+     _ <- traceMarkerIO "starting decompositions"       let !kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n      putStrLn $ "Number of faces of a " ++ sn ++ " times decomposed King is "                         ++ show (faceCount kD)

@@ -11,9 +11,9 @@ It also exposes  auxiliary functions tryGetDartWingInfo, getDartWingInfoForced (and type DartWingInfo)-and partComposeFacesFrom for debugging.+for debugging but getDartWingInfoForced is no longer used internally. -}-{-# LANGUAGE Strict                #-} +-- {-# LANGUAGE Strict                #-}  {-# OPTIONS_GHC -Wno-deprecations  #-}  module Tgraph.Compose @@ -26,24 +26,19 @@   , tryPartCompose   , tryPartComposeFaces   -- * Exported auxiliary functions (and type)-  -- , partCompFacesAssumeF- , partComposeFaces-  -- , partComposeFacesF-  -- , partComposeFacesFrom --new+  , partComposeDWI+  , partComposeFaces   , DartWingInfo(..)   -- , getDWIassumeF   -- , getDartWingInfo   , tryGetDartWingInfo   , getDartWingInfoForced- -- , composedFaceGroups- -- , oldGetDartWingInfo- --  , oldPartCompose   ) where  import Data.List (find,(\\),partition,nub) import Prelude hiding (Foldable(..)) import Data.Foldable (Foldable(..))-import qualified Data.IntMap.Strict as VMap (lookup,(!),alter,empty,elems)+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) @@ -80,8 +75,7 @@ -- of faces from g which will not compose.  tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) tryPartCompose g = -  do dwInfo <- tryGetDartWingInfo g -     let (~remainder,newFaces) = partComposeFaces dwInfo+  do (remainder,newFaces) <- tryPartComposeFaces g      checked <- onFail "tryPartCompose:\n" $ tryConnectedNoCross newFaces      return (remainder,checked) @@ -100,9 +94,42 @@ -- 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:: Forced Tgraph -> ([TileFace], Forced Tgraph) partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph newfaces) where-  (~remainder,newfaces) = partCompFacesForced $ getDartWingInfoForced fg+  -- !evalnewfaces = evalFaces newfaces+  (_,dwFMap,unused) = dartsMapUnused (forgetF 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"+  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+  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+  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+  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   -- |composeF - produces a composed Forced Tgraph from a Forced Tgraph.@@ -175,8 +202,9 @@         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 -                    -- long edge drt shared with another dart => largeKiteCentre+ --           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)@@ -187,7 +215,8 @@                     -- long edge drt shared with another dart => largeKiteCentre                 (kcs,dbs,IntSet.insert w unks) -- on the forced boundary so must be unknown --- |(not exported - only used in getDWIassumeF)++-- |Not exported - used in partComposeF and in getDWIassumeF. -- Returns a triple of: --   list of all half-darts, --   a dart wing to faces map, and @@ -209,7 +238,8 @@     addD f (Just fs) = Just (f:fs)     insertK (vmap,unsd) f =        let opp = oppV f-          org = originV f+          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             (Just _ ,Just _)     ->  (VMap.alter (addK f) opp $ VMap.alter (addK f) org vmap, unsd)             (Just _ , Nothing)   ->  (VMap.alter (addK f) opp vmap, unsd)@@ -219,19 +249,26 @@     addK _ Nothing = Nothing  -- not added to map if it is not a dart wing vertex     addK f (Just fs) = Just (f:fs) ---- |partComposeFaces (exported only for use in composeK example in Extras)--- Assumes not forced, so less efficient.+{-# DEPRECATED partComposeFaces "Use partComposeDWI" #-}+-- |partComposeFaces has been renamed as partComposeDWI. partComposeFaces :: DartWingInfo -> ([TileFace],[TileFace])-partComposeFaces dwInfo = (remainder, evalFaces newFaces) where-    ~remainder = recoverFaces dwInfo \\ concatMap concat [groupRDs, groupLDs, groupRKs, groupLKs]+partComposeFaces = partComposeDWI --dwInfo = (remainder, evalFaces newFaces) where+ +-- |partComposeDWI 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 "composedFaceGroups: RD case"+    makenewRD _       = error "partComposeFaces: RD case"     groupRD v = do  fcs <- VMap.lookup v (faceMap dwInfo)                     rd <- find isRD fcs                     lk <- find (matchingShortE rd) fcs@@ -240,7 +277,7 @@     newLDs = map makenewLD groupLDs      groupLDs = mapMaybe groupLD (largeDartBases dwInfo)      makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld)-    makenewLD _       = error "composedFaceGroups: LD case"+    makenewLD _       = error "partComposeFaces: LD case"     groupLD v = do  fcs <- VMap.lookup v (faceMap dwInfo)                     ld <- find isLD fcs                     rk <- find (matchingShortE ld) fcs@@ -249,7 +286,7 @@     newRKs = map makenewRK groupRKs      groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo)      makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk)-    makenewRK _         = error "composedFaceGroups: RK case"+    makenewRK _         = error "cpartComposeFaces: RK case"     groupRK v = do  fcs <- VMap.lookup v (faceMap dwInfo)                     rd <- find isRD fcs                     lk <- find (matchingShortE rd) fcs@@ -259,45 +296,10 @@     newLKs = map makenewLK groupLKs      groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo)      makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk)-    makenewLK _         = error "composedFaceGroups: LK case"+    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]---- | New composing faces for Forced only (not exported)--- Returns remainder faces paired with newly composed faces.-partCompFacesForced :: DartWingInfo -> ([TileFace], [TileFace])-partCompFacesForced dwInfo = (remainder, evalFaces newFaces) where-    ~remainder = unMapped dwInfo ++ concatMap (faceMap dwInfo VMap.!) (unknowns dwInfo)-    newFaces = concatMap doDartFor (largeDartBases dwInfo) ++ concatMap doKiteFor (largeKiteCentres dwInfo)-    doDartFor v = -        case VMap.lookup v (faceMap dwInfo) of-        Nothing -> error $ "partComoseF: Dart base vertex not found in map (" ++ show v ++ ")/n"-        Just fcs -> catMaybes [largeRD fcs, largeLD fcs]-    largeRD:: [TileFace] -> Maybe TileFace             -    largeRD fcs = do rd <- find isRD fcs-                     lk <- find ((==oppV rd) . wingV) fcs-                     return $ makeRD (originV lk) (originV rd) (wingV rd)-                     -    largeLD fcs = do ld <- find isLD fcs-                     rk <- find ((==oppV ld) . wingV) fcs-                     return $ makeLD (originV rk) (wingV ld) (originV ld)-    -    doKiteFor v = -        case VMap.lookup v (faceMap dwInfo) of-        Nothing -> error $ "partComoseF: Kite centre vertex not found in map (" ++ show v ++ ")/n"-        Just fcs -> catMaybes [largeRK fcs, largeLK fcs]--    largeRK fcs = do rd  <- find isRD fcs-                     lk <- find ((==oppV rd) . wingV) fcs-                     rk <- find (matchingJoinE 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-                     return $ makeLK (originV ld) (originV rk) (wingV lk)-- 

@@ -10,7 +10,6 @@ two auxiliary functions for debugging and experimenting. -} --- {-# LANGUAGE BangPatterns             #-} {-# LANGUAGE Strict                   #-} {-# OPTIONS_GHC -Wno-deprecations     #-} @@ -44,14 +43,14 @@  -- |Decompose all the faces (using a phiVMap for new vertices). decomposeFaces :: HasFaces a => a -> [TileFace]-decomposeFaces a = evalFaces newFaces where+decomposeFaces a = newFaces where     pvmap = phiVMap a     newFaces = concatMap (decompFace pvmap) (faces a)  -- |phiVMap fcs produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in fcs.--- Both (a,b) and (b,a) get the same new vertex number. This is used(in decompFace, decompFaces and decompose.--- (Sort is used to fix order of assigned numbers).--- (Exported for use in TrackedTgraphs in Tgraphs module).+-- Both (a,b) and (b,a) get the same new vertex number. This is used in decompFace, decompFaces and decompose.+-- Sort is used to fix order of assigned numbers.+-- Exported for use in TrackedTgraphs in Tgraph.Extras module. phiVMap :: HasFaces a => a -> Map Dedge Vertex phiVMap x = edgeVMap where   --phiReps = sort [e | e@(a,b) <- phiEdges fcs, a<b]

@@ -24,12 +24,14 @@  module Tgraph.Extras   ( smart-  , drawBoundaryJoins-  , drawJoinsFor   , smartdraw   , smartOn+  , smartRotating+  , smartAligning   , smartRotateBefore   , smartAlignBefore+  , drawBoundaryJoins+  , drawJoinsFor     -- * Overlaid drawing tools for Tgraphs   , drawPCompose   , drawForce@@ -89,6 +91,9 @@   , decomposeTracked     -- *  Drawing TrackedTgraphs   , drawTrackedTgraph+  , drawTrackedTgraphRotating+  , drawTrackedTgraphAligning+   , drawTrackedTgraphRotated   , drawTrackedTgraphAligned   ) where@@ -121,9 +126,7 @@ -- smart (labelSize normal draw) g smart :: OKBackend b =>          (VPatch -> Diagram b) -> Tgraph -> Diagram b-smart dr g = drawBoundaryJoins g vp <> dr vp-  where vp = makeVP g-+smart dr g = (drawBoundaryJoins g <> dr) (makeVP g)  -- |drawBoundaryJoins a vp - draw boundary join edges of faces in a, using a given suitable VPatch -- Will raise an error if any vertex in the faces does not have a location in the VPatch.@@ -139,34 +142,56 @@ -- Will raise an error if any vertex in the faces does not have a location in the VPatch. drawJoinsFor::  (HasFaces a, OKBackend b) =>                 a -> VPatch -> Diagram b-drawJoinsFor a vp = drawWith dashJOnly (restrictTo a vp)+drawJoinsFor a = drawWith dashJOnly . restrictTo a  -- |same as draw except adding dashed lines on boundary join edges.  smartdraw :: OKBackend b => Tgraph -> Diagram b smartdraw = smart draw --- |smartOn a dr vp - assumes vp has locations for vertices in faces of a.--- It uses the VPatch drawing function dr to draw g and adds dashed boundary joins.+++-- |smartOn a dr vp - assumes the VPatch vp has locations for vertices in faces of a.+-- It uses the VPatch drawing function dr to draw faces in a and adds dashed boundary joins. -- This can be used instead of smart when an appropriate vp is already available. smartOn :: (HasFaces a, OKBackend b) =>            a -> (VPatch -> Diagram b) -> VPatch -> Diagram b-smartOn a dr vp = drawBoundaryJoins a rvp <> dr rvp where rvp = restrictTo a vp+smartOn a dr = (drawBoundaryJoins a <> dr) . restrictTo a --- |smartRotateBefore vfun a g - a tricky combination of smart with rotateBefore.--- Uses vfun to produce a Diagram after converting g to a rotated VPatch but also adds the dashed boundary join edges of g.+-- |smartRotating angle vfun g - a tricky combination of smart with rotating.+-- 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. ----- Example: smartRotateBefore (labelled draw) angle g+-- Example: smartRotating angle (labelled draw) g+smartRotating :: OKBackend b =>+                Angle Double -> (VPatch -> Diagram b) -> Tgraph -> Diagram b+smartRotating angle vfun g = rotating angle (smartOn g vfun) g++{-# 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 vfun angle g = rotateBefore (smartOn g vfun) angle g+smartRotateBefore = flip smartRotating --- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with alignBefore.--- Uses vfun to produce a Diagram after converting g to an aligned VPatch but also adds the dashed boundary join edges of g.--- --- Example: smartAlignBefore (labelled draw) (a,b) g+-- |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.+-- Vertex a is centered and vertex b aligned on the positive x-axis.+-- Will raise an error if either a or b is not a vertex in g.+--+-- Example: smartAligning (a,b) (labelled draw) g+smartAligning :: OKBackend b =>+              (Vertex,Vertex) -> (VPatch -> Diagram b) ->  Tgraph -> Diagram b+smartAligning (a,b) vfun g = aligning (a,b) (smartOn g vfun) g++{-# 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 vfun (a,b) g = alignBefore (smartOn g vfun) (a,b) g+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.@@ -251,13 +276,15 @@ -- |emphasizeFaces a g - emphasizes the faces that are in a and g, overlaid on the background draw g. emphasizeFaces :: (OKBackend b, HasFaces a) =>                   a -> Tgraph -> Diagram b-emphasizeFaces a g =  (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where-    vp = makeVP g-    emphvp = subFaces (faces a `intersect` faces g) vp+emphasizeFaces a g = (smartOn a draw vp # lw thin) <> +                     (smartOn g draw vp # lw ultraThin)+                     where vp = makeVP g  --- | For illustrating an unsound version of composition which defaults to kites when there are unknown--- dart wings on the boundary (with just a half kite and the half dart at the dart wing).+-- | For illustrating an unsound version of composition.+-- This composition defaults to +-- forming 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. composeK :: Tgraph -> Tgraph@@ -266,24 +293,14 @@       let changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo                               , unknowns = []                               }-          ( _ , newfaces) = partComposeFaces changedInfo+          ( _ , newfaces) = partComposeDWI changedInfo       tryConnectedNoCross newfaces-{- composeK :: Tgraph -> Tgraph-composeK g = runTry $ tryConnectedNoCross newfaces where-    dwInfo = runTry $ tryGetDartWingInfo g-    changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo-                        , unknowns = []-                        }---    newfaces = snd $ partCompFacesFrom changedInfo-    compositions = composedFaceGroups changedInfo-    newfaces = map fst compositions- -}  -- |compForce is a partial function similar to (compose . force), -- i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph). -- However it produces an explicitly Forced Tgraph,  -- and is more efficient because it omits the check for connected, and no crossing boundaries--- (and uses getDartWingInfoForced instead of getDartWingInfo)+-- 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.@@ -353,7 +370,7 @@   covers:: [(Forced BoundaryState, Set Dedge)] -> [Forced BoundaryState]   covers [] = []   covers ((fbs,es):opens)-    | Set.null es = fbs:covers opens -- bs is a completed cover+    | Set.null es = fbs:covers opens -- fbs is a completed cover     | otherwise = covers (newcases ++ opens)        where (de,des) = Set.deleteFindMin es              newcases = map (\b -> (b, commonBdry des (forgetF b)))@@ -381,7 +398,7 @@     | otherwise =  covers $ map (\b -> (b, commonBdry des (forgetF b))) (atLeastOne $  tryDartAndKiteF de (forgetF open)) ++opens                    where (de,des) = Set.deleteFindMin es --- | returns the set of internal vertices of a tilefaces+-- | returns the set of internal vertices of all tilefaces internalVertexSet :: HasFaces a => a -> VertexSet internalVertexSet a = vertexSet a IntSet.\\ boundaryVSet a @@ -773,12 +790,41 @@     The angle argument is used to rotate the common vertex location map (anticlockwise) before drawing     to ensure labels are not rotated. -}+drawTrackedTgraphRotating :: OKBackend b => Angle Double -> [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b+drawTrackedTgraphRotating a drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where+    vp = rotate a $ makeVP (tgraph ttg)+    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 drawList a ttg = mconcat $ reverse $ zipWith ($) drawList vpList where     vp = rotate a $ makeVP (tgraph ttg)     untracked = faces vp \\ concat (tracked ttg)     vpList = map (`restrictTo` vp) (untracked:tracked ttg) ++ repeat vp +{-|+    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+-}+drawTrackedTgraphAligning :: OKBackend b => (Vertex,Vertex) -> [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b+drawTrackedTgraphAligning (a,b) drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where+    vp = makeAlignedVP (a,b) (tgraph ttg)+    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.

@@ -52,8 +52,8 @@   , tryOneStepWith   , tryOneStepForce -- * Types for Forcing---  , BoundaryDedges   , BoundaryState(..)+  , BoundaryDedges()   , ForceState(..)   , BoundaryChange(..)   , Update(..)@@ -71,6 +71,8 @@     -- *  Auxiliary Functions for a force step   , affectedBoundary   , boundaryAt+  , nextBV+  , prevBV --  , mustFind   , tryReviseUpdates   , tryReviseFSWith@@ -149,16 +151,18 @@   -import Data.List ((\\), intersect, nub, find)+import Data.List ((\\), intersect, nub, find, partition) 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.IntMap.Strict as VMap (null, filter, filterWithKey, alter, delete, lookup, (!), keysSet)+import Data.IntMap.Strict(IntMap)+import qualified Data.IntMap.Strict as VMap (null, filter, filterWithKey, alter, delete, lookup, (!), keysSet+                                            , fromAscList, fromList, assocs,insert) import qualified Data.IntSet as IntSet (member,empty,insert)             -- used for BoundaryState locations AND faces at boundary vertices import Data.Set (Set)-import qualified Data.Set as Set (insert,delete,foldr')+import qualified Data.Set as Set (foldr',elems,fromList) import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate  import Tgraph.Prelude @@ -171,8 +175,6 @@ *************************************************************************** -} --- | type to represent the boundary directed edges in a BoundaryState (currently as a Set)-type BoundaryDedges = Set Dedge -- was [Dedge]   {-| A BoundaryState records@@ -180,11 +182,8 @@ a mapping of boundary vertices to positions (using Tgraph.Prelude.locateGraphVertices), a list of all the faces, the next vertex label to be used when adding a new vertex,-the set of boundary directed edges (directed so that faces are on LHS and exterior is on RHS).--N.B the boundary edges kept in a BoundaryState are not used once forcing has started,-but they cost very little to keep track of and provide a quick way to get the boundary-at any stage.+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. -} data BoundaryState    = BoundaryState@@ -195,11 +194,56 @@      , nextVertex:: Vertex -- ^ next vertex number      } deriving (Show) +-- | A type to represent the boundary directed edges in a BoundaryState +-- (direction with face on LHS, exterior on RHS).+-- This is now a pair of vertex to vertex maps, one giving the next vertex round the boundary,+-- and one giving the previous vertex round the boundary.+-- This representation is both convenient for some BoundaryState operations and is simple to update.+-- The representation relies on the no crossing boundaries property of Tgraphs.+data BoundaryDedges = BoundaryDedges {prevBVMap::IntMap Vertex, nextBVMap::IntMap Vertex}+     deriving(Show)+--type BoundaryDedges = Set Dedge -- was [Dedge]++-- |convert a set of boundary directed edges to BoundaryDedges+bdesFromSet :: Set Dedge -> BoundaryDedges --(IntMap Vertex, IntMap Vertex)+bdesFromSet eset = BoundaryDedges{prevBVMap=prev, nextBVMap=next} where+    blist = Set.elems eset+    next = VMap.fromAscList blist+    prev = VMap.fromList $ map reverseD blist++-- |convert BoundaryDedges to a set of boundary directed edges+bdesToSet :: BoundaryDedges -> Set Dedge+bdesToSet = Set.fromList . VMap.assocs . nextBVMap -- (overrides default) boundary already calculated++-- |add some edges to the boundary (second arg is boundary)+bdesInsert :: [Dedge] -> BoundaryDedges -> BoundaryDedges+bdesInsert = flip (foldl' insertE) -- (++)+  where insertE bdes (!a,!b) = +         bdes{prevBVMap=VMap.insert b a $ prevBVMap bdes, nextBVMap=VMap.insert a b $ nextBVMap bdes}++-- | remove some edges from the boundary (second arg is boundary)+bdesDelete :: [Dedge] -> BoundaryDedges -> BoundaryDedges+bdesDelete = flip (foldl' deleteE) where --flip (\\)+   deleteE bdes (a,b) =+    bdes{prevBVMap=VMap.delete b $ prevBVMap bdes, nextBVMap=VMap.delete a $ nextBVMap bdes}++-- |nextBV v bs - returns the next vertex on the boundary from v (in boundary direction).+nextBV :: Vertex -> BoundaryState -> Vertex+nextBV v bs = case VMap.lookup v (nextBVMap $ boundaryDedges bs) of+                Nothing -> error $ "nextBV: Vertex not found on boundary: " ++ show v ++ "\n"+                Just v1 -> v1++-- |prevBV v bs - returns the previous vertex on the boundary from v (in boundary direction).+prevBV :: Vertex -> BoundaryState -> Vertex+prevBV v bs = case VMap.lookup v (prevBVMap $ boundaryDedges bs) of+                Nothing -> error $ "prevBV: Vertex not found on boundary: " ++ show v ++ "\n"+                Just v1 -> v1+ -- |BoundaryState is in class HasFaces. -- Note the default implementations are overiden to use precalculated information instance HasFaces BoundaryState where     faces = allFaces-    boundaryESet = boundaryDedges  -- (overrides default) boundary already calculated+    boundaryESet = bdesToSet . boundaryDedges  -- (overrides default) boundary already calculated     maxV bd = nextVertex bd - 1 -- (overrides default)     boundaryVFMap = bvFacesMap -- (overrides default) already calculated @@ -211,7 +255,7 @@       bvLocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices g   in        BoundaryState-      { boundaryDedges = bdes+      { boundaryDedges = bdesFromSet bdes       , bvFacesMap = vertexFMap bvs g       , bvLocMap = bvLocs       , allFaces = faces g@@ -225,7 +269,7 @@ -- |changeVFMap f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap changeVFMap::  TileFace -> VertexMap [TileFace] -> VertexMap [TileFace] changeVFMap f vfm = foldl' insertf vfm (faceVList f) where-   insertf vmap v = VMap.alter consf v vmap+   insertf = flip (VMap.alter consf) -- v vmap    consf Nothing = Just [f]    consf (Just fs) = Just (f:fs) @@ -336,23 +380,11 @@ --  It produces Left report if it encounters a Forcible representing a stuck/incorrect Tgraph. tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a tryForceWith ugen = tryFSOpWith ugen retry where---    tryForceStateWith :: UpdateGenerator -> ForceState -> Try ForceState---    tryForceStateWith uGen = retry where   retry fs = do r <- tryOneStepWith ugen fs                 case r of -                 Just (fs',_) -> retry fs'-                 Nothing -> return fs -- final state (no more updates)+                  Just (fs',_) -> retry fs'+                  Nothing -> return fs -- final state (no more updates) -{-       retry fs = case findSafeUpdate (updateMap fs) of-                 Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u-                              fs' <- tryReviseFSWith ugen bdChange fs-                              retry fs'-                 _  -> do maybeBdC <- tryUnsafes fs-                          case maybeBdC of-                            Nothing  -> Right fs -- no more updates-                            Just bdC -> do fs' <- tryReviseFSWith ugen bdC fs-                                           retry fs'- -}   -- | try a given number of force steps using a given UpdateGenerator. tryStepForceWith :: Forcible a => UpdateGenerator -> Int -> a -> Try a@@ -434,10 +466,12 @@     maxV = maxV . forgetF     boundaryVFMap = boundaryVFMap . forgetF +{-# WARNING labelAsForced +    ["This should only be used when when the argument is known to be a fully forced Forcible."+    ,"Consider using forceF or tryForceF instead for safety reasons."+    ]+#-} -- | Constructs an explicitly Forced type.------ WARNING: this should only be used when the argument is known to be a fully forced Forcible.--- Consider using forceF or tryForceF instead for safety reasons. -- Used in partComposeF and composeF labelAsForced :: a -> Forced a labelAsForced = Forced@@ -601,32 +635,17 @@   -- |find the directed edge following the given vertex round the boundary following :: Vertex -> BoundaryState -> Dedge-following a = snd . oboundaryAt a +following a bs = (a, nextBV a bs)   -- |find the directed edge preceeding the given vertex round the boundary preceding :: Vertex -> BoundaryState -> Dedge-preceding a = fst . oboundaryAt a-{- - -- |find the directed edge following the given vertex round the boundary-following :: Vertex -> BoundaryState -> Maybe Dedge-following a = find ((==a).fst) . boundaryAt a +preceding a bs = (prevBV a bs, a)   --- |find the directed edge preceeding the given vertex round the boundary-preceding :: Vertex -> BoundaryState -> Maybe Dedge-preceding a = find ((==a).snd) . boundaryAt a- -}--- | get the (2) boundary edges at a boundary vertex --- (raises an error if the vertex is not on the boundary).+-- |boundaryAt v bs - get the (2) boundary edges at boundary vertex v in BoundaryState bs.+-- Raises an error if v is not on the boundary.+-- Otherwise returns the two edges in boundary direction order - e.g. [(a,v),(v,b)] boundaryAt :: Vertex -> BoundaryState -> [Dedge]-boundaryAt v bs = missingRevs [e| f <- facesAtBV bs v, e@(a,b) <- faceDedges f, v==a || v==b]---- | get the (2) boundary edges at a boundary vertex in order as a pair--- (raises an error if the vertex is not on the boundary).-oboundaryAt :: Vertex -> BoundaryState -> (Dedge, Dedge)-oboundaryAt v = order . boundaryAt v-  where order [e1@(_,b),e2@(c,_)]| b==c = (e1,e2)-                                 | otherwise = (e2,e1)-        order _ = error $ "oboundaryAt: Crossing boundary found at " ++ show v ++ "\n"+boundaryAt v bs = [preceding v bs, following v bs]  -- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange) -- using uGen to calculate new updates.@@ -643,12 +662,13 @@     do umap <- tryReviseUpdates ugen bdC (updateMap fs)        return $ ForceState{ boundaryState = newBoundaryState bdC, updateMap = umap} - -- |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+      isSafeUpdate (SafeUpdate _ ) = True+      isSafeUpdate (UnsafeUpdate _ ) = False  {-| tryUnsafes: Should only be used when there are no Safe updates in the UpdateMap.    tryUnsafes works through the unsafe updates in (directed edge) key order and@@ -691,12 +711,11 @@        newface = makeFace v        oldVPoints = bvLocMap bd        newVPoints = addVPoint newface oldVPoints-       vPosition = newVPoints VMap.! v -- Just vPosition = VMap.lookup v newVPoints-       fDedges = faceDedges newface-       matchedDedges = filter (\(x,y) -> x /= v && y /= v) fDedges -- singleton-       newDedges = map reverseD (fDedges \\ matchedDedges) -- two edges+       vPosition = newVPoints VMap.! v+       (unmatched, matchedDedges) = partition (\(x,y) -> x == v || y == v) (faceDedges newface) -- (two edges,singleton)+       newBdry = map reverseD unmatched -- two edges        resultBd = BoundaryState-                    { boundaryDedges = insertEdges newDedges $ deleteEdges matchedDedges $ boundaryDedges bd+                    { boundaryDedges = bdesInsert newBdry $ bdesDelete matchedDedges $ boundaryDedges bd                     , bvFacesMap = changeVFMap newface (bvFacesMap bd)                     , bvLocMap = newVPoints                     , allFaces = newface:allFaces bd@@ -705,8 +724,8 @@                     }        bdChange = BoundaryChange                     { newBoundaryState = resultBd-                    , removedEdges = matchedDedges-                    , revisedEdges = affectedBoundary resultBd newDedges+                    , removedEdges = matchedDedges -- singleton+                    , revisedEdges = affectedBoundary resultBd newBdry -- 4 edges                     , newFace = newface                     }    in if touchCheck vPosition oldVPoints -- true if new vertex is blocked because it touches the boundary elsewhere@@ -726,14 +745,15 @@ trySafeUpdate _  (UnsafeUpdate _) = error "trySafeUpdate: applied to non-safe update.\n" trySafeUpdate bd (SafeUpdate newface) =    let fDedges = faceDedges newface-       localRevDedges =  [(b,a) | v <- faceVList newface, !f <- facesAtBV bd v, (a,b) <- faceDedges f]-       matchedDedges = fDedges `intersect` localRevDedges -- list of 2 or 3+       localBoundary =  [e | v <- faceVList newface, e <- boundaryAt v bd] -- WITH duplicates+       --       localRevDedges =  [(b,a) | v <- faceVList newface, !f <- facesAtBV bd v, (a,b) <- faceDedges f]+       matchedDedges = fDedges `intersect` localBoundary -- list of 2 or 3        removedBVs = commonVs matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3)-       newDedges = map reverseD (fDedges \\ matchedDedges) -- one or none+       newBdry = map reverseD (fDedges \\ matchedDedges) -- one or none        nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs        resultBd = BoundaryState-                   { boundaryDedges = insertEdges newDedges $ deleteEdges matchedDedges $ boundaryDedges bd-                    -- newDedges ++ (boundaryDedges bd \\ matchedDedges)+                   { boundaryDedges = bdesInsert newBdry $ bdesDelete matchedDedges $ boundaryDedges bd+                    -- newBdry ++ (boundaryDedges bd \\ matchedDedges)                    , bvFacesMap = foldl' (flip VMap.delete) (changeVFMap newface $ bvFacesMap bd) removedBVs --                   , bvFacesMap = changeVFMap newface (bvFacesMap bd)                    , allFaces = newface:allFaces bd@@ -744,8 +764,8 @@                    }        bdChange = BoundaryChange                    { newBoundaryState = resultBd-                   , removedEdges = matchedDedges-                   , revisedEdges = affectedBoundary resultBd newDedges+                   , removedEdges = matchedDedges -- 2 or 3 edges+                   , revisedEdges = affectedBoundary resultBd newBdry -- 3 or 0 edges                    , newFace = newface                    }    in if noNewConflict newface nbrFaces@@ -758,12 +778,6 @@               ,"\n"               ] --- |add some edges to the boundary (second arg is boundary)-insertEdges :: [Dedge] -> BoundaryDedges -> BoundaryDedges-insertEdges = flip (foldl' (flip Set.insert)) -- (++)--- | remove some edges from the boundary (second arg is boundary)-deleteEdges :: [Dedge] -> BoundaryDedges -> BoundaryDedges-deleteEdges = flip (foldl' (flip Set.delete)) --flip (\\)  -- | given 2 consecutive directed edges (not necessarily in the right order), -- this returns the common vertex (as a singleton list).@@ -946,7 +960,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) --  fv `seq` SafeUpdate fv where fv = f v+makeUpdate f (Just !v) = SafeUpdate (f v) -- let fc = evalFace (f v) in SafeUpdate fc makeUpdate f Nothing  = UnsafeUpdate f  @@ -1347,7 +1361,7 @@         | 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@@ -1388,9 +1402,13 @@ -- 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-      face = case filter (isAtV a) $ facesAtBV bd b of+      face = case find (isAtV a) $ facesAtBV bd b of+             Just f -> f+             Nothing   -> error $ "inspectBDedge: Not a boundary directed edge " ++ show (a,b) ++ "\n"+{-       face = case filter (isAtV a) $ facesAtBV bd b of              [f] -> f              _   -> error $ "inspectBDedge: Not a boundary directed edge " ++ show (a,b) ++ "\n"+ -}  {-      face = case facesAtBV bd a `intersect` facesAtBV bd b of          [f] -> f

@@ -18,8 +18,8 @@ {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE TupleSections             #-}-{-# LANGUAGE Strict                #-}--- DISCOVERED changing StrictData to Strict generates a bug in test case (connected x2)+{-# LANGUAGE Strict                    #-}+ module Tgraph.Prelude   ( module HalfTile   , module Try@@ -86,6 +86,7 @@ --  , faces   , nullFaces   , evalFaces+  , evalFace   , faceCount   , ldarts   , rdarts@@ -162,19 +163,21 @@   , removeVerticesFromVP   , selectVerticesFromVP   , findLoc-    -- * Drawing Tgraphs and Vpatches with Labels+    -- * Drawing Tgraphs and VPatches with Labels   , DrawableLabelled(..)   , labelSize   , labelled+  , rotating   , rotateBefore   , dropLabels--- * VPatch alignment with vertices+-- * Tgraph and VPatch alignment with vertices+  , aligning+  , alignBefore+  , makeAlignedVP   , centerOn   , alignXaxis   , alignments   , alignAll-  , alignBefore-  , makeAlignedVP     -- *  Drawing Edges   , drawEdgesVP   , drawEdgeVP@@ -742,13 +745,13 @@  makeRD,makeLD,makeRK,makeLK :: Vertex -> Vertex -> Vertex -> TileFace -- |make an RD (strict in arguments)-makeRD !x !y !z = RD (x,y,z)+makeRD x y z = RD (x,y,z) -- |make an LD (strict in arguments)-makeLD !x !y !z = LD (x,y,z)+makeLD x y z = LD (x,y,z) -- |make an RK (strict in arguments)-makeRK !x !y !z = RK (x,y,z)+makeRK x y z = RK (x,y,z) -- |make an LK (strict in arguments)-makeLK !x !y !z = LK (x,y,z)+makeLK x y z = LK (x,y,z)  -- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace faceVs::TileFace -> (Vertex,Vertex,Vertex)@@ -1049,12 +1052,11 @@ faceForEdge :: Dedge -> Map Dedge TileFace ->  Maybe TileFace faceForEdge = Map.lookup --- |Given a tileface (face) and a map from each directed edge to the tileface containing it (efMap)+-- |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 getNbr edges where-    getNbr e = Map.lookup e efMap-    edges = reverseD <$> faceDedges face+edgeNbs face efMap = mapMaybe (flip faceForEdge efMap) edges where+   edges = reverseD <$> faceDedges face  -- |For an argument with a non-empty list of faces, -- find the face with lowest originV (and then lowest oppV).@@ -1226,12 +1228,19 @@             (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.--- E.g. rotateBefore (labelled draw) angle graph. rotateBefore :: (VPatch -> a) -> Angle Double -> Tgraph -> a-rotateBefore vfun angle = vfun . rotate angle . makeVP+rotateBefore = flip rotating +-- |rotating a vfun g - makes a VPatch from g then rotates by angle a before applying the VPatch function vfun.+-- Tgraphs need to be rotating after a VPatch is calculated but before any labelled drawing.+--+-- E.g. rotating angle (labelled draw) graph.+rotating :: Angle Double -> (VPatch -> a) -> Tgraph -> a+rotating angle vfun = vfun . rotate angle . makeVP+ -- |center a VPatch on a particular vertex. (Raises an error if the vertex is not in the VPatch vertices) centerOn :: Vertex -> VPatch -> VPatch centerOn a vp =@@ -1268,18 +1277,27 @@ alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch] alignAll (a,b) = map (alignXaxis (a,b)) +-- |aligning (a,b) vfun g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis+-- before applying the VPatch function vfun+-- Will raise an error if either a or b is not a vertex in g.+-- Tgraphs need to be aligned after a VPatch is calculated but before any labelled drawing.+--+-- E.g. aligning (a,b) (labelled draw) g+aligning ::  (Vertex,Vertex) -> (VPatch -> a) -> Tgraph -> a+aligning vs vfun = vfun . alignXaxis vs . makeVP++{-# 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.--- E.g. alignBefore (labelled draw) (a,b) g alignBefore :: (VPatch -> a) -> (Vertex,Vertex) -> Tgraph -> a-alignBefore vfun vs = vfun . alignXaxis vs . makeVP+alignBefore = flip aligning --- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligned on the x-axis.+-- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligning on the x-axis. -- Will raise an error if either a or b is not a vertex in g.-makeAlignedVP:: (Vertex,Vertex) ->  Tgraph -> VPatch-makeAlignedVP = alignBefore id+makeAlignedVP:: (Vertex,Vertex) -> Tgraph -> VPatch+makeAlignedVP vs = aligning vs id   -- |produce a diagram of a list of edges (given a suitable VPatch)@@ -1309,6 +1327,7 @@                          (Just pa, Just pb) -> pa ~~ pb                          _ -> error $ "drawEdge: location not found for one or both vertices "++ show (a,b) ++ "\n" + {-| locateGraphVertices: processes faces in a Tgraph to associate points for each vertex using a default scale and orientation. The default scale is 1 unit for short edges (phi units for long edges). It aligns the lowest numbered join of the faces on the x-axis, and returns a vertex-to-point Map.@@ -1316,7 +1335,8 @@ locateGraphVertices:: Tgraph -> VertexLocMap locateGraphVertices = locateVertices . faces -{-| locateVertices - not exported (used in touchingVertices) and can go wrong on arbitrary faces.+{-| locateVertices - not exported (used in touchingVertices and locateGraphVertices).+It can go wrong on arbitrary faces. Processes a list of faces to associate points for each vertex using a default scale and orientation. The default scale is 1 unit for short edges (phi units for long edges). It aligns the lowest numbered join of the faces on the x-axis, and returns a vertex-to-point Map.@@ -1325,13 +1345,12 @@ or a result with touching vertices (i.e. more than one vertex label with the same location). -} locateVertices:: HasFaces a => a -> VertexLocMap---  This version is made more efficient by calculating an edge to face map+--  This is made more efficient by calculating an edge to face map --  and also using Sets for 2nd arg of fastAddVPoints. locateVertices = locVs . faces where   locVs [] = VMap.empty   locVs fcs = fastAddVPoints [joinFace] (Set.fromList more) (axisJoin joinFace) where     (joinFace,more) = extractLowestJoin fcs-    efMap = buildEFMap fcs  -- map from Dedge to TileFace {- fastAddVPoints readyfaces fcOther vpMap. The first argument list of faces (readyfaces) contains the ones being processed next in order where each will have at least two known vertex locations in vpMap.@@ -1343,10 +1362,15 @@     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) (edgeNbs face efMap)+        nbs = filter (`Set.member` fcOther) (eNeighbours face)         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.+-- This version assumes no two faces can have a common dedge (using buildEFMap).+    eNeighbours = eNbrs+       where themap = buildEFMap fcs+             eNbrs f  = edgeNbs f themap  -- |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.@@ -1369,12 +1393,6 @@   VMap.insert (originV face) origin $ VMap.insert (oppV face) (p2 (x,0)) VMap.empty where     x = if isDart face then 1 else phi -{- -- |lookup 3 vertex locations in a vertex to point map.-find3Locs::(Vertex,Vertex,Vertex) -> VertexLocMap-             -> (Maybe (Point V2 Double),Maybe (Point V2 Double),Maybe (Point V2 Double))-find3Locs (v1,v2,v3) vpMap = (VMap.lookup v1 vpMap, VMap.lookup v2 vpMap, VMap.lookup v3 vpMap)- -}- {-| thirdVertexLoc face vpMap,  where face is a tileface and vpMap associates points with vertices (positions). It looks up all 3 vertices of face in vpMap hoping to find at least 2 of them, it then returns Just pr where pr associates a new location with the third vertex.@@ -1385,7 +1403,6 @@ It now uses signorm to produce vectors of length 1 rather than rely on relative lengths. (Requires ttangle and phi from TileLib). -}- thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double) thirdVertexLoc face@(RD _ ) vpMap = -- LD and RD cases are the same using originV, wingV, oppV EXCEPT for angles   case (VMap.lookup (originV face) vpMap, VMap.lookup (wingV face) vpMap, VMap.lookup (oppV face) vpMap) of@@ -1411,40 +1428,9 @@   (Just _ , Just _ , Just _)      -> Nothing   _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n" -{- older version with 4 cases-thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double)-thirdVertexLoc face@(LD _) vpMap = case find3Locs (faceVs face) vpMap of-  (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1))-  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = signorm (rotate (ttangle 7) (loc3 .-. loc2))-  (Just loc1, Nothing, Just loc3) -> Just (oppV face, loc1 .+^ v)    where v = signorm (rotate (ttangle 1) (loc3 .-. loc1))-  (Just _ , Just _ , Just _)      -> Nothing-  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n" -thirdVertexLoc face@(RD _) vpMap = case find3Locs (faceVs face) vpMap of-  (Just loc1, Just loc2, Nothing) -> Just (oppV face, loc1 .+^ v)    where v = signorm (rotate (ttangle 9) (loc2 .-. loc1))-  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc3 .+^ v) where v = signorm (rotate (ttangle 3) (loc2 .-. loc3))-  (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1))-  (Just _ , Just _ , Just _)      -> Nothing-  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"--thirdVertexLoc face@(LK _) vpMap = case find3Locs (faceVs face) vpMap of-  (Just loc1, Just loc2, Nothing) -> Just (oppV face, loc1 .+^ v)    where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1))-  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2))-  (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1))-  (Just _ , Just _ , Just _)      -> Nothing-  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"--thirdVertexLoc face@(RK _) vpMap = case find3Locs (faceVs face) vpMap of-  (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1))-  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2))-  (Just loc1, Nothing, Just loc3) -> Just (oppV face, loc1 .+^ v)    where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1))-  (Just _ , Just _ , Just _)      -> Nothing-  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"- -}- -- *  Touching Vertices - {-|  touchingVertices finds if any vertices are too close to each other after locating them. It can fail if faces do not satisfy other Tgraph properties (apart from touching vertices).@@ -1477,10 +1463,10 @@ -}  {-| -touchingVerticesGen  generalises touchingVertices to allow for multiple faces sharing a directed edge.+touchingVerticesGen generalises touchingVertices to allow for multiple faces with the same directed edge. This can arise when applied to the union of faces from 2 overlapping Tgraphs which might clash in places. It is used in the calculation of commonFaces.  The faces should be connected with no crossing boundaries to enable location-calculations possible.+calculations. -} touchingVerticesGen:: [TileFace] -> [(Vertex,Vertex)] touchingVerticesGen fcs = check vpAssoc where@@ -1489,46 +1475,29 @@   check ((v,p):more) = [(v1,v) | v1 <- nearv ] ++ check (filter ((`notElem` nearv).fst) more)                         where nearv = [v1 | (v1,p1) <- more, touching p p1 ] -{-| locateVerticesGen generalises locateVertices to allow for multiple faces sharing an edge.-This can arise when applied to the union of faces from 2 Tgraphs (e.g. in commonFaces)    +{-| locateVerticesGen  (not exported but used in touchingVerticesGen). This generalises locateVertices to allow for multiple faces sharing an edge.+This can arise when applied to the union of faces from 2 Tgraphs (e.g. in commonFaces).+(The code is the same except for eNeighboursGen instead of eNeighbours).     -} locateVerticesGen:: HasFaces a => a -> VertexLocMap locateVerticesGen = locVs . faces where   locVs [] = VMap.empty-  locVs fcs = fastAddVPointsGen [face] (Set.fromList more) (axisJoin face) where+  locVs fcs = fastAddVPoints [face] (Set.fromList more) (axisJoin face) where     (face,more) = extractLowestJoin fcs-    efMapGen = buildEFMapGen fcs  -- map from Dedge to [TileFace]-{- fastAddVPointsGen readyfaces fcOther vpMap.-The first argument list of faces (readyfaces) contains the ones being processed next in order where-each will have at least two known vertex locations in vpMap.-The second argument Set of faces (fcOther) are faces that have not yet been added-and may not yet have known vertex locations.-The third argument is the mapping of vertices to points.--}-    fastAddVPointsGen [] fcOther vpMap | Set.null fcOther = vpMap-    fastAddVPointsGen [] fcOther _ = error $ "fastAddVPointsGen: Faces not tile-connected " ++ show fcOther ++ "\n"-    fastAddVPointsGen (f:fs) fcOther vpMap = fastAddVPointsGen (fs++nbs) fcOther' vpMap' where-        nbs = filter (`Set.member` fcOther) (edgeNbsGen f)---        nbs = filter (`Set.member` fcOther) (edgeNbsGen efMapGen fc)+ +    fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap+    fastAddVPoints [] fcOther _ = error $ "fastAddVPointsGen: Faces not tile-connected " ++ show fcOther ++ "\n"+    fastAddVPoints (f:fs) fcOther vpMap = fastAddVPoints (fs++nbs) fcOther' vpMap' where+        nbs = filter (`Set.member` fcOther) (eNeighboursGen f)         fcOther' = foldl' (flip Set.delete) fcOther nbs         vpMap' = addVPoint f vpMap--- Generalises buildEFMap by allowing for multiple faces on a directed edge.--- buildEFMapGen:: [TileFace] -> Map Dedge [TileFace]-    buildEFMapGen = Map.fromListWith (++) . concatMap processFace-    processFace f = (,[f]) <$> faceDedges f---- Generalised edgeNbs allowing for multiple faces on a directed edge.--- edgeNbsGen:: Map Dedge [TileFace] -> TileFace -> [TileFace]-    edgeNbsGen f = concat $ mapMaybe getNbrs edges where-      getNbrs e = Map.lookup e efMapGen-      edges = map reverseD (faceDedges f)-{--    edgeNbsGen efMapGen f = concat $ mapMaybe getNbrs edges where-      getNbrs e = Map.lookup e efMapGen-      edges = fmap reverseD (faceDedges f) --}----+-- Same as eNeighbours in locateVertices except that it allows for more than one face with a common dedge.+-- Given a list of faces and a face f, produce a list of edge neighbouring faces of f.+    eNeighboursGen :: TileFace -> [TileFace]+    eNeighboursGen = eNbrs+      where theMap =  Map.fromListWith (++) $ concatMap processFace fcs+            processFace f = (,[f]) <$> faceDedges f  +            eNbrs f = concat $ mapMaybe getNbrs edges+                      where getNbrs e = Map.lookup e theMap+                            edges = map reverseD (faceDedges f) 

@@ -119,7 +119,7 @@ -- The result is a single diagram. arrangeRowsGap :: OKBackend b =>                   Double -> Int -> [Diagram b] -> Diagram b-arrangeRowsGap s n = centerY . vsep s . fmap (centerX . hsep s) . chunks n+arrangeRowsGap s n = centerY . vsep s . map (centerX . hsep s) . chunks n  -- |arrangeRows n diags - arranges diags into n per row, centering each row horizontally. -- The result is a single diagram (seperation is 1 unit vertically and horizontally).@@ -211,7 +211,7 @@  -- |diagram of foolDminus and the result of forcing.   forceFoolDminus :: OKBackend b => Diagram b-forceFoolDminus = padBorder $ hsep 1 $ fmap (labelled drawj) [foolDminus, force foolDminus]+forceFoolDminus = padBorder $ hsep 1 $ map (labelled drawj) [foolDminus, force foolDminus]   forceDartD5Fig,forceKiteD5Fig,forceSunD5Fig,forceFig :: OKBackend b => Diagram b@@ -243,13 +243,13 @@  -- |brokenDartFig shows the faces removed from dartD4 to make brokenDart and badlyBrokenDart. brokenDartFig  :: OKBackend b => Diagram b-brokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [dartD4, brokenDart, badlyBrokenDart]+brokenDartFig = padBorder $ lw thin $ hsep 1 $ map (labelled drawj) [dartD4, brokenDart, badlyBrokenDart]  -- |badlyBrokenDartFig shows badlyBrokenDart, followed by its composition, followed by the faces  -- that would result from an unchecked second composition which are not tile-connected. -- (Simply applying compose twice to badlyBrokenDart will raise an error). badlyBrokenDartFig :: OKBackend b => Diagram b-badlyBrokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [vp, vpComp, vpFailed] where+badlyBrokenDartFig = padBorder $ lw thin $ hsep 1 $ map (labelled drawj) [vp, vpComp, vpFailed] where     vp = makeVP badlyBrokenDart     comp = compose badlyBrokenDart     vpComp = restrictTo (faces comp) vp@@ -280,7 +280,7 @@  vTypeFigs = zipWith drawVertex                [sunGraph, starGraph, jackGraph, queenGraph, kingGraph, aceGraph,  deuceGraph]                [(1,2),    (1,2),     (1,2),     (1,2),      (1,2),     (3,6),     (2,6)] -- alignments- drawVertex g alm = alignBefore (lw thin . showOrigin . drawj) alm g+ drawVertex g alm = aligning alm (lw thin . showOrigin . drawj) g  jackGraph,kingGraph,queenGraph,aceGraph,deuceGraph,starGraph::Tgraph -- |Tgraph for vertex type jack.@@ -334,7 +334,7 @@ -- |forceVFigures is a list of 7 diagrams - force of 7 vertex types. forceVFigures :: OKBackend b => [Diagram b] forceVFigures = rotations [0,0,9,5,0,0,1] $-                fmap (center . drawForce) [sunGraph,starGraph,jackGraph,queenGraph,kingGraph,aceGraph,deuceGraph]+                map (center . drawForce) [sunGraph,starGraph,jackGraph,queenGraph,kingGraph,aceGraph,deuceGraph]   sun3Dart :: Tgraph@@ -355,7 +355,7 @@ -- of sun3Dart. The decompositions are in red with normal force additions in black and superforce additions in blue. superForceRocketsFig :: OKBackend b => Diagram b superForceRocketsFig = padBorder $ lw veryThin $ vsep 1 $ rotations [8,9,9,8] $-   fmap drawSuperForce decomps where+   map drawSuperForce decomps where       decomps = take 4 $ decompositions sun3Dart  boundaryFDart4, boundaryFDart5 :: Tgraph@@ -390,8 +390,8 @@ boundaryVCoveringFigs :: OKBackend b =>                          Forced BoundaryState -> [Diagram b] boundaryVCoveringFigs bd =-    lw ultraThin . (redg <>) . alignBefore draw alig . (recoverGraph . forgetF) <$> boundaryVCovering bd-      where redg = lc red $ draw g --alignBefore draw alig g+    lw ultraThin . (redg <>) . aligning alig draw  . (recoverGraph . forgetF) <$> boundaryVCovering bd+      where redg = lc red $ draw g             alig = defaultAlignment g             g = recoverGraph $ forgetF bd @@ -400,7 +400,7 @@ boundaryECoveringFigs :: OKBackend b =>                          Forced BoundaryState -> [Diagram b] boundaryECoveringFigs bd =-    lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph . forgetF  <$> boundaryECovering bd+    lw ultraThin . (redg <>) . aligning alig draw  . recoverGraph . forgetF  <$> boundaryECovering bd       where redg = lc red $ draw g             alig = defaultAlignment g             g = recoverGraph $ forgetF bd@@ -422,24 +422,22 @@  -- |emplaceChoices forces then maximally composes. At this top level it -- produces a list of forced choices for each of the unknowns of this top level Tgraph.--- It then repeatedly applies (force . decompose) back to the starting level to return a list of Tgraphs.+-- It then repeatedly applies (forceF . decompose . forgetF) back to the starting level to return a list of Forced Tgraphs. -- This version relies on compForce theorem and related theorems-emplaceChoices:: Tgraph -> [Tgraph]-emplaceChoices = emplaceChoicesForced . forceF  where--  emplaceChoicesForced:: Forced Tgraph -> [Tgraph]-  emplaceChoicesForced fg | nullFaces g' = chooseUnknowns [(unknowns $ getDartWingInfoForced fg, forgetF fg)]-                          | otherwise    = force . decompose <$> emplaceChoicesForced fg'-                          where fg' = composeF fg-                                g' = forgetF fg'+emplaceChoices:: Tgraph -> [Forced Tgraph]+emplaceChoices = emplaceChoicesF . forceF  where -  chooseUnknowns :: [([Vertex],Tgraph)] -> [Tgraph]+  emplaceChoicesF:: Forced Tgraph -> [Forced Tgraph]+  emplaceChoicesF fg | nullFaces compfg = chooseUnknowns [(unknowns $ getDartWingInfoForced fg, fg)]+                          | otherwise    = forceF . decompose . forgetF <$> emplaceChoicesF compfg+                          where compfg = composeF fg+  chooseUnknowns :: [([Vertex],Forced Tgraph)] -> [Forced Tgraph]   chooseUnknowns [] = []   chooseUnknowns (([],g0):more) = g0:chooseUnknowns more   chooseUnknowns ((u:unks,g0): more)      =  chooseUnknowns (map (remainingunks unks) newgs ++ more)-        where newgs = map recoverGraph $ atLeastOne $ fmap forgetF <$> tryDartAndKiteF (findDartLongForWing u bd) bd-              bd = makeBoundaryState g0+        where newgs = map recoverGraphF $ atLeastOne $ (tryDartAndKiteF (findDartLongForWing u bd) bd)+              bd = makeBoundaryState (forgetF g0)               remainingunks startunks g' = (startunks `intersect` boundaryVsDup g', g')    findDartLongForWing :: Vertex -> BoundaryState -> Dedge@@ -450,10 +448,10 @@  -- |Example showing emplaceChoices for foolD with foolD shown in red in each choice emplaceChoicesFig :: OKBackend b => Diagram b-emplaceChoicesFig =  lw thin $ hsep 1 $ map overlayg $ emplaceChoices g+emplaceChoicesFig =  lw thin $ hsep 1 $  (overlayg . forgetF) <$> emplaceChoices g     where g = foolD-          overlayg g' = smartAlignBefore draw algmnt g # lc red <> alignBefore draw algmnt g'-          algmnt = defaultAlignment g+          overlayg g' = smartAligning algmnt draw g # lc red <> aligning algmnt draw  g'+          algmnt = defaultAlignment $ maxCompForce g  -- | An example to illustrate drawing P3 tiling (rhombuses). -- The top part (filled) is a 5 times decomposed sunGraph converted to rhombuses (P3) when drawn.

@@ -17,6 +17,7 @@ {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE FlexibleInstances         #-} -- needed for Drawable Patch {-# LANGUAGE TypeOperators             #-} -- needed for type equality constraints ~+{-# LANGUAGE Strict                    #-}   module TileLib    ( OKBackend

@@ -117,7 +117,7 @@     context "Decomposition of Tgraphs" $       it "Number of faces of dartDs !!6 should be 466" $          faceCount dD6  `shouldBe` 466-    context "Composing Tgraphs" $+    context "Composing Forced Tgraphs" $       it "Number of faces of maxCompForce (dartDs !!6) should be 6" $          faceCount (forgetF $ maxCompForce dD6) `shouldBe` 6     context "Forcing Tgraphs" $