PenroseKiteDart 1.6.1 → 1.7

raw patch · 10 files changed

+388/−111 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−2
• PenroseKiteDart.cabal +2/−1
• src/HalfTile.hs +4/−4
• src/Tgraph/Compose.hs +4/−4
• src/Tgraph/Force.hs +104/−43
• src/Tgraph/Grid.hs +150/−0
• src/Tgraph/Prelude.hs +52/−42
• src/TgraphExamples.hs +4/−4
• src/TileLib.hs +39/−10
• test/Spec.hs +11/−1

@@ -1,14 +1,30 @@ # Revision history for PenroseKiteDart +## version v1.7++Significant speed up of forcing.++- Possibly breaking change (internal representation change):+  - Added grid to BoundaryState with newtype (Grid a) defined in new module Tgraph.Grid.+    This provides much faster touching vertex checks. Grid is also used for touchingVertices.+  - Removed touchCheck++- Other changes++  - Added joinDashing', dashj', dashJ', defaultJoinDashSize+  - Added completeEdgeSet, bothDirSet+  - Exported tryOnBoundary, isBoundaryDE, isBoundaryV+  - Used smart on boundaryFDart.. and boundaryGap.. example figures.+ ## 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.+    - boundaryAt is much more efficient (using new representation for BoundaryDedges) and returns the two boundary directed edges in boundary direction order.  - Other changes:-    - Added nextBV and prevBV+    - Added nextBV and prevBV (efficient)     - Added rotating, aligning, smartRotating, smartAligning, drawTrackedTgraphAligning, drawTrackedTgraphRotating, partComposeDWI.     - Deprecated smartRotateBefore (Use (flip smartRotating))     - Deprecated smartAlignBefore (Use (flip smartAligning))

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           PenroseKiteDart-version:        1.6.1+version:        1.7 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@@ -39,6 +39,7 @@       Tgraph.Force       Tgraph.Relabelling       Tgraph.Extras+      Tgraph.Grid       TgraphExamples   other-modules:       Paths_PenroseKiteDart

@@ -68,10 +68,10 @@ -- {-# INLINE tileRep #-} -- |return the representation of a half-tile tileRep:: HalfTile rep -> rep-tileRep (LD r) = r-tileRep (RD r) = r-tileRep (LK r) = r-tileRep (RK r) = r+tileRep (LD !r) = r+tileRep (RD !r) = r+tileRep (LK !r) = r+tileRep (RK !r) = r  -- |half-tile predicate isLD,isRD,isLK,isRK,isDart,isKite :: HalfTile rep -> Bool

@@ -114,21 +114,21 @@                      "\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)+                   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)+                   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)+                   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)+                   let !f = evalFace $ makeLK (originV ld) (originV rk) (wingV lk)                    return f  

@@ -73,6 +73,9 @@   , boundaryAt   , nextBV   , prevBV+  , isBoundaryV+  , isBoundaryDE+  , tryOnBoundary --  , mustFind   , tryReviseUpdates   , tryReviseFSWith@@ -145,7 +148,7 @@   -- , tryFindThirdV   , externalAngle -  , touchCheck+--  , touchCheck    )  where @@ -157,20 +160,21 @@ import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map (empty, delete, elems, insert, union, keys) -- used for UpdateMap 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.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)             -- used for BoundaryState locations AND faces at boundary vertices import Data.Set (Set) 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+import Tgraph.Grid   {- ***************************************************************************    Efficient FORCING with    BoundaryState, ForceState -  Touching Vertex Check+  Touching Vertex Check Using a Grid   Incremented Update Maps *************************************************************************** -}@@ -180,6 +184,7 @@ {-| A BoundaryState records a mapping of boundary vertices to their incident faces, a mapping of boundary vertices to positions (using Tgraph.Prelude.locateGraphVertices),+a grid of positions (for fast touching vertex checks), a list of all the faces, 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).@@ -190,6 +195,7 @@      { 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).      , allFaces:: [TileFace] -- ^ all the tile faces      , nextVertex:: Vertex -- ^ next vertex number      } deriving (Show)@@ -202,7 +208,6 @@ -- 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)@@ -239,6 +244,16 @@                 Nothing -> error $ "prevBV: Vertex not found on boundary: " ++ show v ++ "\n"                 Just v1 -> v1 +-- | Check if a directed edge is on the boundary of a BoundaryState (in the correct boundary direction)+isBoundaryDE :: Dedge -> BoundaryState -> Bool+isBoundaryDE (a,b) bs = case VMap.lookup a (nextBVMap $ boundaryDedges bs) of+                Nothing -> False+                Just c -> c == b++-- | Check if a vertex is on the boundary+isBoundaryV :: Vertex -> BoundaryState -> Bool+isBoundaryV v = VMap.member v . nextBVMap . boundaryDedges+ -- |BoundaryState is in class HasFaces. -- Note the default implementations are overiden to use precalculated information instance HasFaces BoundaryState where@@ -253,11 +268,13 @@   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   in        BoundaryState       { boundaryDedges = bdesFromSet bdes       , bvFacesMap = vertexFMap bvs g       , bvLocMap = bvLocs+      , grid = newgrid       , allFaces = faces g       , nextVertex = 1+ maxV g       }@@ -266,13 +283,21 @@ recoverGraph:: BoundaryState -> Tgraph recoverGraph = makeUncheckedTgraph . faces --- |changeVFMap f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap-changeVFMap::  TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]-changeVFMap f vfm = foldl' insertf vfm (faceVList f) where-   insertf = flip (VMap.alter consf) -- v vmap-   consf Nothing = Just [f]+-- |changeVFMapUnsafe f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap+-- This is used in the unsafe addition case where one of the vertices will be new to the map.+changeVFMapUnsafe::  TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]+changeVFMapUnsafe f vfm = foldl' insertf vfm (faceVList f) where+   insertf = flip (VMap.alter consf)+   consf Nothing = Just [f] -- new case    consf (Just fs) = Just (f:fs) +-- |changeVFMapSafe f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap+-- This is used in the safe addition case where no new vertices are added to the map.+-- If this is done after deletions, one or three of the vertices will not be in the map.+changeVFMapSafe::  TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]+changeVFMapSafe f vfm = foldl' insertf vfm (faceVList f) where+   insertf = flip (VMap.adjust (f:))+ -- |facesAtBV bd v - returns the faces found at v (which must be a boundary vertex) facesAtBV:: BoundaryState -> Vertex -> [TileFace] facesAtBV bd v = case VMap.lookup v (bvFacesMap bd) of@@ -313,7 +338,7 @@ 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.   Each forcing rule has a particular UpdateGenerator,-but they can also be combined (e.g in sequence - allUGenerator or otherwise - defaultAllUGenerator).+but they can also be combined (e.g in sequence - allUGenerator or otherwise - defaultAllUGen). -} newtype UpdateGenerator = UpdateGenerator {applyUG :: BoundaryState -> [Dedge] -> Try UpdateMap} @@ -467,7 +492,7 @@     boundaryVFMap = boundaryVFMap . forgetF  {-# WARNING labelAsForced -    ["This should only be used when when the argument is known to be a fully forced Forcible."+    ["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."     ] #-}@@ -503,19 +528,16 @@ initFSF (Forced a) = Forced (initFS a)  -- |try to find the right direction for an edge to be a boundary directed edge.--- Fails if neither direction is consistent with boundary directed edges.+-- 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. tryOnBoundary :: Dedge -> BoundaryState -> Try Dedge-tryOnBoundary e@(a,b) bd =-  let bdes = boundaryAt a bd -  in case find (==e) bdes of-     Just _ -> Right e-     Nothing -> case find (==(b,a)) bdes of-                 Just re -> Right re-                 Nothing -> failReports  -                    ["tryOnBoundary:\nNeither "-                    ,show e, " nor ", show(reverseD e), " are on the boundary\n"-                    ]-+tryOnBoundary e bd +  | isBoundaryDE e bd = Right e+  | isBoundaryDE (reverseD e) bd = Right (reverseD e)+  | otherwise = failReports  +                 [ "tryOnBoundary:\nNeither "+                 , show e, " nor ", show(reverseD e), " are on the boundary\n"+                 ]  -- |addHalfKite is for adding a single half kite on a chosen boundary Dedge of a Forcible. -- The Dedge must be a boundary edge but the direction is not important as@@ -571,6 +593,7 @@          tryUpdate bd u  + -- |tryOneStepWith uGen fs does one force step. -- It returns either  --@@ -611,6 +634,7 @@                        } deriving (Show)  + {-| Given a BoundaryState with a list of one boundary edge or      two adjacent boundary edges (or exceptionally no boundary edges),      it extends the list with adjacent boundary edges (to produce 3 or 4 or none).@@ -647,6 +671,7 @@ boundaryAt :: Vertex -> BoundaryState -> [Dedge] boundaryAt v bs = [preceding v bs, following v bs] +{-# INLINE tryReviseUpdates #-} -- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange) -- using uGen to calculate new updates. tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap@@ -662,6 +687,7 @@     do umap <- tryReviseUpdates ugen bdC (updateMap fs)        return $ ForceState{ boundaryState = newBoundaryState bdC, updateMap = umap} +{-# INLINE findSafeUpdate #-} -- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering) findSafeUpdate:: UpdateMap -> Maybe Update -- slower to use filter@@ -707,17 +733,22 @@ 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-       oldVPoints = bvLocMap bd-       newVPoints = addVPoint newface oldVPoints-       vPosition = newVPoints VMap.! v+  let v = nextVertex bd+      newface = makeFace v+      oldVPoints = bvLocMap bd+      newVPoints = addVPoint newface oldVPoints+      vPosition = newVPoints VMap.! v+  in case insertGridCheck vPosition (grid bd) of+    Left _  -> Nothing+    Right newgrid ->+     let         (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-                    , bvFacesMap = changeVFMap newface (bvFacesMap bd)+                    , bvFacesMap = changeVFMapUnsafe newface (bvFacesMap bd)                     , bvLocMap = newVPoints+                    , grid = newgrid                     , allFaces = newface:allFaces bd                     -- allFaces = newface:faces bd <<<CAUSES SPACE LEAK>>>>                     , nextVertex = v+1@@ -728,9 +759,7 @@                     , 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-      then Nothing -- don't proceed when v is a touching vertex-      else Just bdChange+     in Just bdChange  {-| 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).@@ -753,13 +782,12 @@        nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs        resultBd = BoundaryState                    { 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)+                   , bvFacesMap = changeVFMapSafe newface $ foldl' (flip VMap.delete) (bvFacesMap bd) removedBVs+                    -- do deletions first then only adds for vertices still on the boundary.                    , allFaces = newface:allFaces bd- --                  , bvLocMap = foldr VMap.delete (bvLocMap bd) removedBVs                    , bvLocMap = foldl' (flip VMap.delete) (bvLocMap bd) removedBVs                               --remove vertex/vertices no longer on boundary+                   , grid = grid bd                    , nextVertex = nextVertex bd                    }        bdChange = BoundaryChange@@ -802,11 +830,14 @@        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 -- (Used at intervals in tryRecalibratingForce and recalibratingForce). recalculateBVLocs :: BoundaryState -> BoundaryState-recalculateBVLocs bd = bd {bvLocMap = newlocs} where+recalculateBVLocs bd = bd { bvLocMap = newlocs+                          , grid = createGrid $ VMap.elems newlocs+                          } where     newlocs = VMap.filterWithKey (\k _ -> k `IntSet.member` bvs) $ locateGraphVertices $ recoverGraph bd-    bvs = VMap.keysSet $ bvLocMap bd -- IntSet.fromList $ fst <$> boundary bd+    bvs = VMap.keysSet $ bvLocMap bd  -- |A version of tryForce that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch. -- This is needed to limit accumulated inaccuracies when large numbers of faces are added in forcing.@@ -816,7 +847,7 @@        fs' <- tryStepForce 20000 fs        if null $ updateMap fs'        then return fs'-       else recalibrating $ fs' {boundaryState = recalculateBVLocs $ boundaryState fs'}+       else recalibrating fs' {boundaryState = recalculateBVLocs $ boundaryState fs'}  -- |A version of force that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch. -- This is needed to limit accumulation of errors when large numbers of faces are added in forcing.@@ -1437,7 +1468,7 @@ If only one edge of a new face is on the boundary, we need to create a new vertex. This will need to have its position checked against other (boundary) vertices to avoid creating a touching vertex/crossing boundary. This is why BoundaryStates keep track of boundary vertex positions.-(The check is done in tryUnsafeUpdate.)+(The check is done in checkUnsafeUpdate.) -}  {-|tryFindThirdV tries to find a neighbouring third vertex on the boundary either side of the dedge@@ -1514,12 +1545,15 @@            | bAngle == m = Right $ Just $ snd $ following b bd            | otherwise =   Right  Nothing +{-# INLINE externalAngle #-} -- |externalAngle bd v - calculates the external angle at boundary vertex v in BoundaryState bd as an -- integer multiple of tt (tenth turn), so 1..9.  It relies on there being no crossing boundaries, -- so that there is a single external angle at each boundary vertex.  externalAngle:: BoundaryState -> Vertex -> Int externalAngle bd v = 10 - sum (map (intAngleAt v) $ facesAtBV bd v) +{- New intAngleAt has faceIntAngles inlined. Older versions were+ -- |intAngleAt v fc gives the internal angle of the face fc at vertex v (which must be a vertex of the face) -- in terms of tenth turns, so returning an Int (1,2,or 3). intAngleAt :: Vertex -> TileFace -> Int@@ -1532,16 +1566,43 @@ faceIntAngles (RD _) = [1,1,3] faceIntAngles _      = [1,2,2] -- LK and RK + -} +-- |intAngleAt v fc gives the internal angle of the face fc at vertex v (which must be a vertex of the face)+-- in terms of tenth turns, so returning an Int (1,2,or 3).+intAngleAt :: Vertex -> TileFace -> Int+intAngleAt v face@(LD (a,b,c)) +   | v==a = 1+   | v==b = 3+   | v==c = 1+   | otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)+intAngleAt v face@(RD (a,b,c)) +   | v==a = 1+   | v==b = 1+   | v==c = 3+   | otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)+intAngleAt v face@(LK (a,b,c)) +   | v==a = 1+   | v==b = 2+   | v==c = 2+   | otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)+intAngleAt v face@(RK (a,b,c)) +   | v==a = 1+   | v==b = 2+   | v==c = 2+   | otherwise = error ("intAngleAt: Vertex " ++ show v ++ " not found in face " ++ show face)++ {------------------------- *************************              Touching vertex checking  ******************************************** requires Diagrams.Prelude for Point and V2 --------------------------------------------}-+{-  -- |touchCheck p vpMap - check if a vertex location p touches (is too close to) any other vertex location in the mapping vpMap touchCheck:: Point V2 Double -> VertexMap (Point V2 Double) -> Bool touchCheck p vpMap = not $ VMap.null $ VMap.filter (touching p) vpMap   -- filtering the map has better performance than checking a list-  -- touchCheck p vpMap = any (touching p) (VMap.elems vpMap)+  -- touchCheck p vpMap = any (touching p) (VMap.elems vpMap) +-}

@@ -0,0 +1,150 @@+{-|+Module      : Tgraph.Grid+Description : A type for recording 2D locations with fast check for touching locations+Copyright   : (c) Chris Reade, 2026+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++This module defines a Grid type recording 2D points with fast lookup by grid coordinates.+It is used to quickly identify touching vertices (e.g. when forcing).+-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TupleSections             #-}+++module Tgraph.Grid+(+    insertGridCheck+  , createGridCheck+  , insertGrid+  , createGrid+  , emptyGrid+  , Grid+  , touching+  , ValuedPoint(..)+  , allClashes++) where++import Diagrams.Prelude+++import Data.List ( find )+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IMap (alter,insert,empty,lookup)++-- | A (Grid a) maps from Int x and y coordinates to a list of a in the unit square+-- with bottom left corner given by the coordinates of a.+-- The type a should be a ValuedPoint for Grid access functions to work.+newtype Grid a = Grid{ gridmap::IntMap (IntMap [a])} deriving (Show)++-- | An empty grid.+emptyGrid :: Grid a+emptyGrid = Grid IMap.empty++-- |A class for items which have a 2D point (so can be added to a grid).+class ValuedPoint a where+    getPoint:: a -> P2 Double++-- | A 2D point is considered a ValuedPoint (with no associated value)+instance ValuedPoint (P2 Double) where+    getPoint p = p++-- | A pair of a value and a 2D point is considered a ValuedPoint+instance ValuedPoint (a, P2 Double) where+    getPoint ((_,p)) = p++-- | get the Int x and Int y grid coordinates for a ValuedPoint (using floor).+gridCoords :: ValuedPoint a => a -> (Int,Int)+gridCoords a = (n,m) +   where p = getPoint a+         !n = floor (p ^. _x) +         !m = floor (p ^. _y)++-- | insert a new valued point in a grid, but check the 9 neighbouring cells for any+-- points touching the new point.  If a touching point is found, a (Left vpt) is returned,+-- where vpt is the (first found) grid entry with a touching point.+-- Otherwise Right gd' is returned where gd' is an updated grid with the new (valued) point.+insertGridCheck :: ValuedPoint a => a -> Grid a -> Either a (Grid a)+insertGridCheck a gd =+    case checkGridNear (getPoint a) gd of+        Just b  -> Left b+        Nothing -> Right $ insertGrid a gd++-- | insert a new (valued) point in a grid without any checks.+-- This is used to initialise a grid with (valued) points where the points are known not to be touching.       +insertGrid :: ValuedPoint a => a -> Grid a -> Grid a+insertGrid ap gd = Grid $ IMap.alter column n (gridmap gd)+   where (n,m) = gridCoords ap+         column Nothing = Just $ IMap.insert m [ap] IMap.empty+         column (Just imp) = Just $ IMap.alter ht m imp+         ht Nothing = Just [ap]+         ht (Just aps) = Just (ap:aps)++-- | get the list of (valued) points in a grid cell (with the given Int coords)         +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)++-- | get the list of (valued) points from 9 grid cells (around the one with given Int coords)         +fromGridNear :: Grid a -> Int -> Int -> [a]+fromGridNear gd n m =  +    let g0 = fromGrid gd n+        g1 = fromGrid gd (n-1)+        g2 = fromGrid gd (n+1)+    in concat [g0 m, g0 (m-1), g0 (m+1)+              ,g1 m, g1 (m-1), g1 (m+1)+              ,g2 m, g2 (m-1), g2 (m+1)+              ]++-- | check a point for any touching locations in the grid+-- (checking with points in the 9 grid cells near the point).+-- This will return Nothing if there are no touching locations and Just vpt otherwise+-- where vpt is the the first valued point found in the grid with a touching location.       +checkGridNear :: ValuedPoint a => P2 Double -> Grid a -> Maybe a             +checkGridNear p gd = find touchingItem (fromGridNear gd n m)+  where (n,m) = gridCoords p+        touchingItem a = touching p (getPoint a)++{-|touching checks if two points are considered close.+Close means the square of the distance between them is less than a certain number (currently 0.25) so they cannot be+vertex locations for 2 different vertices in a VPatch using unit scale for short edges.+-}+touching :: P2 Double -> P2 Double -> Bool+touching p p1 = quadrance (p .-. p1) < 0.25 -- quadrance is square of length of a vector+-- quadrance 0.1 represents a distance of about 0.316 units (= sqrt 0.1)+-- quadrance 0.25 represents a distance of 0.5 units++                 +-- | 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++-- | 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,+-- and Just gd otherwise where gd is a grid containiing the (valued) points.+createGridCheck :: ValuedPoint a => [a] -> Either a (Grid a)+createGridCheck aps = insertAll aps (Grid IMap.empty) where+  insertAll [] gd = Right gd+  insertAll (ap:more) gd = +    do gd1 <- insertGridCheck ap gd+       insertAll more gd1++-- |Use a grid to find all clashing (touching) valued points.+-- The function argument is used to extract values from valued points.+allClashes :: ValuedPoint a => (a -> b) -> [a] -> [(b,b)]+allClashes f aps = check aps (Grid IMap.empty) []  where+  check [] _ cs = cs+  check (ap:more) gd cs =+      case insertGridCheck ap gd of+          Right gd' -> check more gd' cs+          Left ap'  -> check more gd ((f ap, f ap'):cs) +          -- note ap' earlier than ap in the incoming list

@@ -146,7 +146,9 @@   , matchingJoinE   , hasDedge   , hasDedgeIn+  , completeEdgeSet   , completeEdges+  , bothDirSet   , bothDir --   , bothDirOneWay   , missingRevs@@ -185,13 +187,13 @@   , drawLocatedEdge     -- * Vertex Location and Touching Vertices   , locateGraphVertices- -- , locateVertices+--  , locateVertices   , addVPoint --  , axisJoin --  , find3Locs --  , thirdVertexLoc   , touchingVertices-  , touching+ -- , touching   , touchingVerticesGen --  , locateVerticesGen   --, drawEdges@@ -216,9 +218,11 @@ import TileLib import HalfTile import Try+import Tgraph.Grid   + {--------------------- ********************* Tgraphs@@ -331,16 +335,23 @@  -- |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+evalFaces !a = foldr (seq . evalFace) () (faces a) `seq` a -   {-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties and producing an error if a check fails.@@ -472,6 +483,7 @@                    , 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:: TileFace -> [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]@@ -491,18 +503,18 @@ -- | 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).                    legal:: (TileFace,EdgeType,TileFace,EdgeType) -> Bool-legal (LK _, e1,    RK _ , e2    ) = e1 == e2-legal (RK _, e1,    LK _ , e2    ) = e1 == e2+legal (LK _, e1,    RK _ , e2   ) = e1 == e2+legal (RK _, e1,    LK _ , e2   ) = e1 == e2+legal (LD _, Join,  RD _ , Join ) = True+legal (RD _, Join,  LD _ , Join ) = True legal (LK _, Short, RD _ , Short) = True legal (RD _, Short, LK _ , Short) = True+legal (LD _, Short, RK _ , Short) = True+legal (RK _, Short, LD _ , Short) = True legal (LK _, Long,  RD _ , Long ) = True legal (RD _, Long,  LK _ , Long ) = True-legal (LD _, Join,  RD _ , Join ) = True-legal (RD _, Join,  LD _ , Join ) = True legal (LD _, Long,  RD _ , Long ) = True legal (RD _, Long,  LD _ , Long ) = True-legal (LD _, Short, RK _ , Short) = True-legal (RK _, Short, LD _ , Short) = True legal (LD _, Long,  RK _ , Long ) = True legal (RK _, Long,  LD _ , Long ) = True legal _ = False@@ -718,7 +730,7 @@ -- for required properties  e.g. connectedness and no crossing boundaries -- and will raise an error if these fail. selectVertices :: [Vertex] -> Tgraph -> Tgraph-selectVertices vs g = selectFaces (filter (hasVIn vs) (faces g)) g+selectVertices vs g = runTry $ tryConnectedNoCross $ filter (hasVIn vs) $ faces g  -- |internal edges are shared by two faces. That is, all edges except those at the boundary. -- Both directions of each internal directed edge will appear in the result.@@ -937,19 +949,28 @@  -- |hasDedgeIn f es - is True if face f has a directed edge in the list of directed edges es. hasDedgeIn :: TileFace -> [Dedge] -> Bool-hasDedgeIn face es = not $ null $ es `intersect` faceDedges face--- hasDedgeIn face es = not $ null $ filter (hasDedge face) es +--hasDedgeIn face es = not $ null $ es `intersect` faceDedges face+hasDedgeIn face = any (hasDedge face)  -- |completeEdges returns a list of all the edges of the faces (both directions of each edge). completeEdges :: HasFaces a => a -> [Dedge] completeEdges = bothDir . dedges +-- |completeEdgeSet returns a set of all the edges of the faces (both directions of each edge).+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:: [Dedge] -> [Dedge] 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:: 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.@@ -1141,13 +1162,13 @@ -- relevantVP vp will raise an error if any vertex in the faces of vp is not a key in the location map of vp. relevantVP :: VPatch -> VPatch relevantVP vp-  | null diffList = vp{vLocs = locVs}+  | IntSet.null diffSet = vp{vLocs = locVs}   | otherwise = error $ "relevantVP: missing locations for: " ++-                                    show diffList ++ "\n"+                                    show diffSet ++ "\n"   where      vs = vertexSet vp      source = VMap.keysSet locVs-     diffList = IntSet.toList $ IntSet.difference vs source+     diffSet = IntSet.difference vs source      locVs = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) $ vLocs vp  -- |A combination of subFaces and relevantVP. @@ -1436,27 +1457,18 @@ It can fail if faces do not satisfy other Tgraph properties (apart from touching vertices). If vertices are too close that indicates we may have different vertex labels at the same location (the touching vertex problem). -It returns pairs of vertices that are too close with higher number first in each pair, and no repeated first numbers.+It returns pairs of vertices that are too close with higher number first in each pair. An empty list is returned if there are no touching vertices.-Complexity has order of the square of the number of vertices.+A Grid is used to find near points efficiently.                            -This is used in makeTgraph and fullUnion (via correctTouchingVertices).+This is used in makeTgraph and fullUnion. -} touchingVertices:: HasFaces a => a -> [(Vertex,Vertex)]-touchingVertices fcs = check vpAssoc where-  vpAssoc = VMap.assocs $ locateVertices fcs  -- assocs puts in increasing key order so that check returns (higher,lower) pairs-  check [] = []-  check ((v,p):more) = [(v1,v) | v1 <- nearv ] ++ check (filter ((`notElem` nearv).fst) more)-                        where nearv = [v1 | (v1,p1) <- more, touching p p1 ]+touchingVertices fcs = check vpAssocs where+  vpAssocs = VMap.assocs $ locateVertices fcs  -- assocs puts in increasing key order so that check returns (higher,lower) pairs+  check = allClashes fst+  -{-|touching checks if two points are considered close.-Close means the square of the distance between them is less than a certain number (currently 0.1) so they cannot be-vertex locations for 2 different vertices in a VPatch using unit scale for short edges.-It is used in touchingVertices and touchingVerticesGen and Force.touchCheck).--}-touching :: Point V2 Double -> Point V2 Double -> Bool-touching p p1 = quadrance (p .-. p1) < 0.1 -- quadrance is square of length of a vector---  0.1 represents a distance of about 0.316 units (= sqrt 0.1)   {-*  Generalised Touching Vertices@@ -1468,12 +1480,10 @@ It is used in the calculation of commonFaces.  The faces should be connected with no crossing boundaries to enable location calculations. -}-touchingVerticesGen:: [TileFace] -> [(Vertex,Vertex)]-touchingVerticesGen fcs = check vpAssoc where-  vpAssoc = VMap.assocs $ locateVerticesGen fcs  -- assocs puts in key order so that check returns (higher,lower) pairs  -  check [] = []-  check ((v,p):more) = [(v1,v) | v1 <- nearv ] ++ check (filter ((`notElem` nearv).fst) more)-                        where nearv = [v1 | (v1,p1) <- more, touching p p1 ]+touchingVerticesGen:: HasFaces a => a -> [(Vertex,Vertex)]+touchingVerticesGen fcs = check vpAssocs where+  vpAssocs = VMap.assocs $ locateVerticesGen fcs  -- assocs puts in increasing key order so that check returns (higher,lower) pairs+  check = allClashes fst  {-| 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).

@@ -366,9 +366,9 @@  boundaryFDart4Fig,boundaryFDart5Fig :: OKBackend b => Diagram b -- |figure of the boundary faces only of a forced graph (dartDs!!4).-boundaryFDart4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryFDart4+boundaryFDart4Fig = padBorder $ lw ultraThin $ smart (labelSize tiny draw) boundaryFDart4 -- |figure of the boundary faces only of a forced graph (dartDs!!5).-boundaryFDart5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryFDart5+boundaryFDart5Fig = padBorder $ lw ultraThin $ smart (labelSize (normalized 0.006) draw) boundaryFDart5  boundaryGapFDart4, boundaryGapFDart5 :: Tgraph -- |graph of the boundary faces only of a forced graph - with extra faces removed to make a gap@@ -381,9 +381,9 @@  boundaryGap4Fig, boundaryGap5Fig  :: OKBackend b => Diagram b -- |figure for the boundary gap graph boundaryGapFDart4.-boundaryGap4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryGapFDart4+boundaryGap4Fig = padBorder $ lw ultraThin $ smart (labelSize tiny draw) boundaryGapFDart4 -- |figure for the boundary gap graph boundaryGapFDart5.-boundaryGap5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryGapFDart5+boundaryGap5Fig = padBorder $ lw ultraThin $ smart (labelSize (normalized 0.006) draw) boundaryGapFDart5  -- | boundaryVCoveringFigs bd - produces a list of diagrams for the boundaryVCovering of bd  -- (with the Tgraph represented by bd shown in red in each case).

@@ -38,6 +38,8 @@   , drawjPiece   , drawJPiece   , joinDashing+  , joinDashing'+  , defaultJoinDashSize   , dashjOnly   , dashJOnly   , drawRoundPiece@@ -54,6 +56,8 @@   , draw   , drawj   , drawJ+  , drawj'+  , drawJ'   , fillDK   , fillKD   -- , fillMaybeDK@@ -186,11 +190,20 @@              Piece -> Diagram b dashJOnly = joinDashing . drawJoin --- |changes line style to ultraThin dashed lines (for drawing join edges)+-- |A default size for dashing (used for join edges)+defaultJoinDashSize :: Measure Double+defaultJoinDashSize = normalized 0.003  `atLeast` output 1.0++-- |changes line style to dashed lines (for drawing join edges)+-- using joinDashing' with defaultJoinDashSize joinDashing :: (HasStyle c, N c ~ Double) => c -> c-joinDashing = dashing [dashmeasure,dashmeasure] 0-                     where dashmeasure = normalized 0.003  `atLeast` output 0.5+joinDashing = joinDashing' defaultJoinDashSize +-- |changes line style to dashed lines (for drawing join edges) using the supplied measure+-- for dashes (usually normalized 0.003  `atLeast` output 1.0)+joinDashing' :: (HasStyle c, N c ~ Double) => Measure Double -> c -> c+joinDashing' dashmeasure = dashing [dashmeasure,dashmeasure] 0+ -- |draw join edge only. drawJoin :: OKBackend b =>             Piece -> Diagram b@@ -283,18 +296,34 @@         a -> Diagram b draw = drawWith drawPiece --- | alternative default case for drawing, adding faint dashed lines for join edges.--- J for plain dashed  Join, j for faint dashed join+-- | normal draw but adding faint dashed lines for join edges,+-- using drawj' with defaultJoinDashSize.+-- Note also J for plain dashed joins, j for ultraThin dashed joins drawj :: (Drawable a, OKBackend b) =>          a -> Diagram b-drawj = drawWith drawjPiece+drawj = drawj' defaultJoinDashSize --- | alternative default case for drawing, adding dashed lines for join edges.--- J for plain dashed  Join, j for faint dashed join+-- | normal draw but adding faint dashed lines for join edges,+-- where dashmeasure is size of dashing (usually normalized 0.003 `atLeast` output 1.0)+-- Note also J for plain dashed joins, j for ultraThin dashed joins+drawj' :: (OKBackend b, Drawable a) => Measure Double -> a -> Diagram b+drawj' dashmeasure = drawWith (drawPiece <> (lw ultraThin . joinDashing' dashmeasure . drawJoin))++-- | normal draw but adding dashed lines for join edges,+-- using drawJ' with defaultJoinDashSize+-- Note also J for plain dashed joins, j for ultraThin dashed joins drawJ :: (Drawable a, OKBackend b) =>          a -> Diagram b-drawJ = drawWith drawJPiece+drawJ = drawJ' defaultJoinDashSize +-- | normal draw but adding dashed lines for join edges,+-- where dashmeasure is size of dashing (usually normalized 0.003 `atLeast` output 1.0)+-- Note also J for plain dashed joins, j for ultraThin dashed joins+drawJ' :: (Drawable a, OKBackend b) => +          Measure Double -> a -> Diagram b+drawJ' dashmeasure = drawWith (drawPiece <> (joinDashing' dashmeasure . drawJoin))++ fillDK, fillKD :: (Drawable a, OKBackend b, Color c1, Color c2) =>                   c1 -> c2 -> a -> Diagram b -- |fillDK dcol kcol a - draws and fills a with colour dcol for darts and kcol for kites.@@ -305,7 +334,7 @@ -- |fillKD kcol dcol a - draws and fills a with colour kcol for kites and dcol for darts. -- Note the order K D. -- Works with AlphaColours as well as Colours.-fillKD c1 c2 = fillDK c2 c1+fillKD = flip fillDK  -- |colourDKG (c1,c2,c3) p - fill in a drawable with colour c1 for darts, colour c2 for kites and -- colour c3 for grout (that is, the non-join edges).

@@ -73,6 +73,13 @@ extraBrokenDart :: Tgraph extraBrokenDart = removeFaces [RK(25,60,61),LK(25,24,60)] badlyBrokenDart +-- | Example to test fullUnion+fullunionGraph :: Tgraph+fullunionGraph = fullUnion  (g1, (1,15)) (g2,(1,10)) where+    g1 = removeFaces [RK (1,31,41)] $ removeVertices [74,79,29] sunD2+    g2 = relabelFrom 1 $ removeVertices [8,7,6,23] $ force sunD2+    sunD2 = sunDs !!2+ graphPropSpec :: Spec graphPropSpec = describe "Test Properties of Tgraphs" $ do     context "When fcs (a list of tile-faces) has any face with a repeated vertex" $@@ -145,4 +152,7 @@     context "superForceFig" $       it "Number of faces of superForceFig should be 398" $                   faceCount (superForce $ addHalfDart (220,221) $ force $ decompositions fool !!3) `shouldBe` 398-  +    context "fullUnion" $+      it "Number of faces of fullunionGraph should be 106" $         +         faceCount fullunionGraph `shouldBe` 106+