PenroseKiteDart 1.0.0 → 1.1.0

raw patch · 13 files changed

+643/−733 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +29/−0
• PenroseKiteDart.cabal +4/−3
• README.md +7/−4
• benchmark/Bench.hs +7/−3
• src/CheckBackend.hs +37/−0
• src/Tgraph/Force.hs +154/−174
• src/Tgraph/Prelude.hs +118/−75
• src/Tgraph/Relabelling.hs +4/−16
• src/Tgraph/Try.hs +0/−88
• src/TgraphExamples.hs +71/−96
• src/Tgraphs.hs +65/−184
• src/TileLib.hs +59/−90
• src/Try.hs +88/−0

@@ -1,9 +1,38 @@ # Revision history for PenroseKiteDart ++## 1.1.0 -- 2024-09-28++Release candidate: ++Added module CheckBackend with class OKBackend. This is really a class synonym for the constraints on a suitable Backend+for drawing tilings. Most types involving a backend b now have a constraint OKBackend b => ...++Removed type synonym: type Diagram2D b = QDiagram b V2 Double Any (no longer needed with the above constraint).++No longer exporting: differing, changeVFMap, forcedDecomp (= force . decompose).++Moved makeTgraph to Tgraph.Prelude.+Moved emplaceChoices to TgraphExamples and added example.+Moved module Tgraph.Try out of Tgraph (so now module Try).++tryStepForceWith now raises an error for negative number of steps.++Added graphBoundaryVs to Tgraph.Prelude.+Added tryBoundaryFaceGraph to Tgraphs++Made ForceState an instance of Show.++Improved haddock comments in Tgraph.Force.++Changed dash sizes for join edges (in dashjOnly).+ ## 1.0.0 -- 2024-04-08  Release candidate: + Added upper bounds on dependencies+ Added new drawEmpire and changed drawEmpire1, drawEmpire2 to showEmpire1, showEmpire2  ## 0.10.0.0 -- 2024-04-1

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           PenroseKiteDart-version:        1.0.0+version:        1.1.0 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@@ -28,15 +28,16 @@ library   exposed-modules:       PKD+      CheckBackend       HalfTile       TileLib+      Try       Tgraphs       Tgraph.Prelude       Tgraph.Decompose       Tgraph.Compose       Tgraph.Force       Tgraph.Relabelling-      Tgraph.Try       TgraphExamples   other-modules:       Paths_PenroseKiteDart

@@ -10,7 +10,7 @@  Penrose\'s kite and dart tiles have the property that they can tile the entire plane aperiodicly. There are rules to ensure legal tilings with the kites and darts.-Tilings can still get stuck (so cannot be continued to cover the entire plane) - these are called incorrect.+Legal tilings can still get stuck (so cannot be continued to cover the entire plane) - these are called incorrect.  This package is a Haskell library of tools to build, draw and explore finite tilings with kites and darts, making use of the  Haskell Diagrams package.@@ -74,17 +74,20 @@  ## Modules -Module `PKD` is the main module which imports and rexports `Tgraphs` and `TileLib`.+Module `PKD` is the main module which imports and re-exports `Tgraphs` and `TileLib`. `Tgraphs` imports and re-exports the contents of the other Tgraph modules, namely  `Tgraph.Compose`, `Tgraph.Decompose`, `Tgraph.Force`, `Tgraph.Relabelling`, `Tgraph.Prelude`. `TileLib` contains underlying drawing tools for tiles.-`Tgraph.Try` is imported and re-exported by `Tgraph.Prelude` - used for results of partial functions.+`Try` is imported and re-exported by `Tgraph.Prelude` - used for results of partial functions. `HalfTile` is imported and re-exported by `Tgraph.Prelude` -  (with the constructors `LD`,`RD`,`LK`,`RK`).+`CheckBackend` is imported by `TileLib` which rexports class `OKBackend`.+(The constraint `OKBackend b =>` is used extensively in the library to abstract types from any particular Backend).+`TgraphExamples` contains example Tgraphs and Diagrams.  ## Further Information  A more detailed User Guide for the PenroseKiteDart package can be found at -- [PenroseKiteDart User  Guides](https://readerunner.wordpress.com/2024/04/08/penrosekitedart-user-guides/)+- [PenroseKiteDart User Guide](https://readerunner.wordpress.com/2024/04/08/penrosekitedart-user-guides/)  

@@ -1,7 +1,7 @@ import Tgraphs import TgraphExamples-import TileLib (draw)-import Diagrams.Prelude+-- import TileLib (draw)+-- import Diagrams.Prelude  main :: IO () main = @@ -10,8 +10,10 @@      putStrLn $ "Number of faces of force (" ++ sn ++ " times decomposed King) is "                              ++ show (length (faces fkD)) +{-      putStrLn $ "Width of figure for force (" ++ sn ++ " times decomposed King) is "                              ++ show w+-}       putStrLn $ "Number of faces of recomposed force (" ++ sn ++ " times decomposed King) is "                              ++ show (length (faces cfkD))@@ -28,7 +30,9 @@        fkD ={-# SCC "forcing" #-} force kD        cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate compose fkD -       fig = {-# SCC "drawing" #-} draw fkD+{-+       fig = draw fkD        w = width fig+-}  

@@ -0,0 +1,37 @@+{-|+Module      : CheckBackend+Description : Introduces a class synonym OKBackend for requirements of a backend+Copyright   : (c) Chris Reade, 2024+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++This module introduces a class synonym OKBackend to abbreviate requirements of a backend for drawing tilings.+The instance declaration requires UndecidableInstances to be enabled.++-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE TypeOperators             #-}++module CheckBackend +  ( OKBackend+  ) where++import Diagrams.Prelude+import Diagrams.TwoD.Text (Text)+++-- |Class OKBackend is a class synonym for suitable constraints on Backends for drawing tilings.+class (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b) =>+      OKBackend b where {}++-- |Instance declaration for OKBackend requires UndecidableInstances to be enabled,+-- but allows a suitable backend B to be recognised as an instance without explicitly writing+-- instance OKBackend B+-- Note B will be declared by user of this library and is not declared in the library+instance (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b) =>+         OKBackend b where {}

@@ -10,88 +10,69 @@ such as tryStepForce, tryAddHalfKite and tryAddHalfDart. It introduces BoundaryState and ForceState types and includes a Forcible class with instances for Tgraph, BoundaryState, and ForceState.-It exposes the calculation of relative angle of edges at boundary vertices used to find existing edges.-It imports a touching check for adding new vertices (with locateVertices and addVPoint). -}  module Tgraph.Force-  (-- *  Touching vertex checking-    touchCheck-    -- *  BoundaryState operations-  , BoundaryState(..)-  , makeBoundaryState-  , recoverGraph-  , changeVFMap-  , facesAtBV-  , boundaryFaces-    -- *  Types: Update, UpdateMap, UpdateGenerator, ForceState-  , Update(..)-  , UpdateMap-  , ForceState(..)-  , UpdateGenerator-    -- *  Forcible class and Instances (ForceState, BoundaryState, Tgraph)-  , Forcible(..)-    -- *  Generalised forcing operations+  ( -- *  Forcible class+   Forcible(..)+    -- *  Generalised forcing+  , force+  , forceWith+  , tryForce   , tryForceWith+  , wholeTiles+  , stepForce+  , tryStepForce   , tryStepForceWith   , tryFSOp-  , tryForce-  , force-  , wholeTiles-  , forceWith-  , tryInitFS   , initFS-  , tryStepForce-  , stepForce+  , tryInitFS   , tryChangeBoundary-    -- *  Force Related Functions+    -- *  Force Related   , addHalfKite   , tryAddHalfKite   , addHalfDart   , tryAddHalfDart-    -- *  Specialised forcing operations (used for inspecting steps)+    -- *  One Step (for debugging)   , tryOneStepWith   , tryOneStepF-    -- *  Updating BoundaryState and ForceState after a single force step+-- * Types for Forcing+  , ForceState(..)+  , BoundaryState(..)   , BoundaryChange(..)+  , Update(..)+  , UpdateMap+  , UpdateGenerator  +  , UFinder+  , UChecker+    -- *  BoundaryState operations+  , makeBoundaryState+  , recoverGraph+--  , changeVFMap -- Now HIDDEN+  , facesAtBV+  , boundaryFaces+    -- *  Auxiliary Functions for a force step   , affectedBoundary --  , mustFind   , tryReviseUpdates   , tryReviseFSWith-    -- *  Auxiliary Functions for doing a force step   , findSafeUpdate   , tryUnsafes   , checkUnsafeUpdate   , trySafeUpdate --   , commonVs   , tryUpdate-    -- *  Recalibrating versions of force and tryForce-  , recalculateBVLocs-  , tryRecalibratingForce+    -- *  Recalibrating force   , recalibratingForce+  , tryRecalibratingForce+  , recalculateBVLocs+    -- * Forcing Rules and Update Generators+    -- $rules+         -- *  Main All Update Generators   , defaultAllUGen   , allUGenerator-   -- * Tools for making update generators-  , UFinder-  , UChecker-  , boundaryFilter-  , makeUpdate-  , makeGenerator -    -- *  BoundaryState vertex predicates and properties-  , mustbeStar-  , mustbeSun-  , mustbeDeuce-  , mustbeKing-  , isKiteWing-  , isKiteOppV-  , isDartOrigin-  , mustbeQueen-  , kiteWingCount-  , mustbeJack---  , hasAnyMatchingE-    -- * Forcing Rules and Individual Update Generators (with corresponding Finders) for each rule.-    --  $rules+    -- * Update Generators and Finders for Rules.   , wholeTileUpdates   , incompleteHalves   , aceKiteUpdates@@ -119,6 +100,22 @@   , completeSunStar   , addKiteLongE   , addDartLongE+    -- *  Boundary vertex properties+  , mustbeStar+  , mustbeSun+  , mustbeDeuce+  , mustbeKing+  , isKiteWing+  , isKiteOppV+  , isDartOrigin+  , mustbeQueen+  , kiteWingCount+  , mustbeJack+   -- * Tools for making update generators+  , makeGenerator +  , boundaryFilter+  , makeUpdate+--  , hasAnyMatchingE {-   , anglesForJoinRD   , anglesForJoinLD@@ -134,15 +131,21 @@   , anglesForShortRK -} --   , inspectBDedge-    -- *  Auxiliary Functions for adding faces: externalAngle and tryFindThirdV. $Additions+    -- *  Auxiliary Functions for adding faces+    -- $Additions   , tryFindThirdV   , externalAngle+ {-   , intAngleAt   , faceIntAngles -}+  ,  touchCheck+   )  where ++ import Data.List ((\\), intersect, nub, find,foldl') import qualified Data.Map as Map (Map, empty, delete, elems, insert, union, keys) -- used for UpdateMap import qualified Data.IntMap.Strict as VMap (elems, filterWithKey, alter, delete, lookup, (!))@@ -162,18 +165,7 @@   -{--------------------------*************************             -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 = any (touching p) (VMap.elems vpMap)-- {-| A BoundaryState records the boundary directed edges (directed so that faces are on LHS and exterior is on RHS) plus @@ -223,7 +215,7 @@ facesAtBV:: BoundaryState -> Vertex -> [TileFace] facesAtBV bd v = case VMap.lookup v (bvFacesMap bd) of   Just fcs -> fcs-  Nothing -> error $ "facesAtBV: Not a boundary vertex? No faces found at " ++ show v ++ "\n"+  Nothing -> error $ "facesAtBV: Not a boundary vertex? No result found for vertex " ++ show v ++ "\n"  -- |return a list of faces which have a boundary vertex from a BoundaryState boundaryFaces :: BoundaryState -> [TileFace]@@ -232,8 +224,6 @@ -- boundaryFaces = nub . concat . VMap.elems . bvFacesMap  -- relies on the map containing no extra info for non boundary vertices -- -- |An Update is either safe or unsafe. -- A safe update has a new face involving 3 existing vertices. -- An unsafe update has a makeFace function to create the new face when given a fresh third vertex.@@ -254,7 +244,7 @@ data ForceState = ForceState                     { boundaryState:: BoundaryState                    , updateMap:: UpdateMap -                   }+                   } deriving (Show)  {-|UpdateGenerator abbreviates the type of functions which capture one or more of the forcing rules. They produce a (Try) UpdateMap when given a BoundaryState and a focus list of particular directed boundary edges.  @@ -323,7 +313,7 @@   -- | try forcing using a given UpdateGenerator.---  tryForceWith uGen fs - recursively does updates using uGen until there are no more updates.+--  tryForceWith uGen fs - does updates using uGen until there are no more updates. --  It produces Left report if it encounters a Forcible representing a stuck/incorrect Tgraph. tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a tryForceWith ugen = tryFSOpWith ugen (tryForceStateWith ugen) where@@ -336,34 +326,27 @@                  _  -> do maybeBdC <- tryUnsafes fs                           case maybeBdC of                             Nothing  -> Right fs -- no more updates-                         -- Nothing -> tryFinalStuckCheck fs  -- No Longer used                             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-tryStepForceWith ugen n = tryFSOpWith ugen $ count n where+tryStepForceWith ugen n = +  if n>=0+  then tryFSOpWith ugen $ count n +  else error "tryStepForceWith: used with negative number of steps\n"+  where       count 0 fs = return fs       count m fs = do result <- tryOneStepWith ugen fs                       case result of                        Nothing -> return fs                        Just (fs', _) ->  count (m-1) fs' -{--tryStepForceWith ugen n = tryFSOpWith ugen $ tryStepForceStateWith ugen n where---    tryStepForceStateWith :: UpdateGenerator -> Int -> ForceState -> Try ForceState-    tryStepForceStateWith updateGen = count where-      count 0 fs = return fs-      count m fs = do result <- tryOneStepWith updateGen fs-                      case result of-                       Nothing -> return fs-                       Just (fs', _) ->  count (m-1) fs' - -}     -- |A version of tryFSOpWith using defaultAllUGen representing all 10 rules for updates. tryFSOp :: Forcible a => (ForceState -> Try ForceState) -> a -> Try a tryFSOp = tryFSOpWith defaultAllUGen --- |A version of the main force function using defaultAllUGen representing all 10 rules for updates.+-- |A try version of the main force function using defaultAllUGen representing all 10 rules for updates. -- This returns Left report on discovering a stuck Tgraph and Right a (with a the resulting forcible) otherwise. tryForce:: Forcible a => a -> Try a tryForce = tryForceWith defaultAllUGen@@ -382,12 +365,12 @@ forceWith ugen = runTry . tryForceWith ugen  -- | try to initialize a force state with the default UpdateGenerator.--- Returns a Left report if it finds a stuck forcible.+-- Returns a Left report if it finds a stuck Forcible. tryInitFS :: Forcible a => a -> Try ForceState tryInitFS = tryInitFSWith defaultAllUGen  -- | initialize a force state with the default UpdateGenerator.--- Raises aan error if it finds a stuck forcible.+-- Raises aan error if it finds a stuck Forcible. initFS :: Forcible a => a -> ForceState initFS = runTry . tryInitFS @@ -397,8 +380,8 @@ tryStepForce :: Forcible a => Int -> a -> Try a  tryStepForce = tryStepForceWith defaultAllUGen-- Was called tryStepForceFrom --- |stepForce  n a - produces an intermediate intermediate Forcible after n steps (n face additions) starting from Forcible a.--- It raises an error if it encounters a stuck/incorrect Tgraph/Forcible within n steps.+-- |stepForce n a - produces an intermediate Forcible after n steps (n face additions) starting from Forcible a.+-- It raises an error if it encounters a stuck/incorrect Forcible within n steps. -- If forcing finishes successfully in n or fewer steps, it will return that final Forcible.  stepForce :: Forcible a => Int -> a ->  a stepForce n = runTry . tryStepForce n@@ -428,12 +411,12 @@     tryAddHalfKiteBoundary e bd =        do de <- case [e, reverseD e] `intersect` boundary bd of                  [de] -> Right de-                 _ -> Left $ "tryAddHalfKiteBoundary:  on non-boundary edge " ++ show e ++ "\n"+                 _ -> Left $ "tryAddHalfKite:  on non-boundary edge " ++ show e ++ "\n"          let (fc,etype) = inspectBDedge bd de          let tryU | etype == Long = addKiteLongE bd fc                   | etype == Short = addKiteShortE bd fc                   | etype == Join && isKite fc = completeHalf bd fc-                  | otherwise = Left "tryAddHalfKiteBoundary: applied to dart join (not possible).\n"+                  | otherwise = Left "tryAddHalfKite: applied to dart join (not possible).\n"          u <- tryU          tryUpdate bd u @@ -457,21 +440,21 @@     tryAddHalfDartBoundary e bd =        do de <- case [e, reverseD e] `intersect` boundary bd of                 [de] -> Right de-                _ -> Left $ "tryAddHalfDartBoundary:  on non-boundary edge " ++ show e  ++ "\n"+                _ -> Left $ "tryAddHalfDart:  on non-boundary edge " ++ show e  ++ "\n"          let (fc,etype) = inspectBDedge bd de          let tryU | etype == Long = addDartLongE bd fc                   | etype == Short && isKite fc = addDartShortE bd fc                   | etype == Join && isDart fc = completeHalf bd fc-                  | otherwise = Left "tryAddHalfDartBoundary: applied to short edge of dart or to kite join (not possible).\n"+                  | otherwise = Left "tryAddHalfDart: applied to short edge of dart or to kite join (not possible).\n"          u <- tryU          tryUpdate bd u  --- |tryOneStepWith uGen fs does one force step.--- It returns a (Try maybe) with a new force sate paired with the boundary change for debugging purposes.--- It uses uGen to revise updates in the final ForceState. --- It produces Left report for a stuck/incorrect graph.--- A result of Right Nothing indicates forcing has finished and there are no more updates.+-- |tryOneStepWith uGen fs does one force step (used for debugging purposes).+-- It returns either (1) a Right(Just (f,bc)) with a new ForceState f paired with a BoundaryChange bc+-- (using uGen to revise updates in the final ForceState), or (2)+-- a Right Nothing indicating forcing has finished and there are no more updates, or (3)+-- a Left report for a stuck/incorrect graph. tryOneStepWith :: UpdateGenerator -> ForceState -> Try (Maybe (ForceState,BoundaryChange)) tryOneStepWith uGen fs =        case findSafeUpdate (updateMap fs) of@@ -484,28 +467,30 @@                                return $ Just (fs',bdC)                 Nothing  -> return Nothing           -- no more updates --- |tryOneStepF is a special case of tryOneStepWith only used for debugging+-- |tryOneStepF is a special case of tryOneStepWith using defaultAllUGen (used for debugging). tryOneStepF :: ForceState -> Try (Maybe (ForceState,BoundaryChange)) tryOneStepF = tryOneStepWith defaultAllUGen  -{-| BoundaryChange records the new boundary state after completing an update (by either trySafeUpdate or tryUnsafeUpdate)-     along with a list of directed edges which are no longer on the boundary,-     plus a list of boundary edges revised (and requiring updates to be recalculated).-     See affectedBoundary.+{-| After a face addition to a BoundaryState (by either trySafeUpdate or tryUnsafeUpdate), a BoundaryChange records+     (1) the new BoundaryState +     (2) the list of directed edges that were, but are no longer on the boundary (1,2,or 3),+     (3) a list of boundary edges requiring updates to be recalculated - i.e the new boundary edges and their immediate neighbours (4,3,or 0).+     (4) the face that has been added. -} data BoundaryChange = BoundaryChange                         { newBoundaryState:: BoundaryState -- ^ resulting boundary state                        , removedEdges:: [Dedge] -- ^ edges no longer on the boundary-                       , revisedEdges :: [Dedge]  -- ^ boundary edges requiring new update calculations+                       , revisedEdges :: [Dedge]  -- ^ new boundary edges plus immediate boundary neighbours (requiring new update calculations)                        , newFace :: TileFace -- ^ face added in the change                        } deriving (Show) -{-| Given a BoundaryState with a list of one new boundary edge or-     two adjacent new boundary edges (or exceptionally no new boundary edges) to be added,+{-| 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).-     (Used to calculate revisedEdges in a BoundaryChange)-     (When a face is fitted in to a hole with 3 sides there is no new boundary.)+     It will raise an error if given more than 2 or 2 non-adjacent boundary edges.+     (Used to calculate revisedEdges in a BoundaryChange.+     (N.B. When a new face is fitted in to a hole with 3 sides there is no new boundary. Hence the need to allow for an empty list.) -} affectedBoundary :: BoundaryState -> [Dedge] -> [Dedge] affectedBoundary bd [(a,b)] = [(x,a),(a,b),(b,y)] where@@ -521,15 +506,16 @@            (x,_) = mustFind ((==c).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show c ++ "\n")            (_,y) = mustFind ((==b).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show b ++ "\n") affectedBoundary _ [] = []-affectedBoundary _ edges = error $ "affectedBoundary: unexpected new boundary edges " ++ show edges ++ "\n"+affectedBoundary _ edges = error $ "affectedBoundary: unexpected boundary edges " ++ show edges ++ "\n(Either more than 2 or 2 not adjacent)\n"  {-| mustFind is an auxiliary function used to search with definite result.-mustFind p ls err returns the first item in ls satisfying predicate p and returns-err argument when none found (in finite cases).    +mustFind p ls default returns the first item in ls satisfying predicate p and returns+default argument when none found (in finite cases).+Special case: the default arg may be used to raise an error when nothing is found. -} mustFind :: Foldable t => (p -> Bool) -> t p -> p -> p-mustFind p ls err-  = maybe err id (find p ls)+mustFind p ls dflt+  = maybe dflt id (find p ls)  -- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange) -- using uGen to calculate new updates.@@ -695,34 +681,9 @@ recalibratingForce = runTry . tryRecalibratingForce  --{--Now unused: final stuck check-{- |-tryFinalStuckCheck was designed to check a final force state (in tryForceStateWith).-The final state is rejected as having a stuck Tgraph if any boundary vertex external angle is less than 4 (tenth turns).-This check was included in tryForceStateWith to catch examples like--  makeTgraph [LK(1,2,3),RK(4,3,2),RK(1,3,5),LK(4,6,3),RK(1,7,2),LK(4,2,8)] --Previously forcing would not discover that the result was stuck without the check.-However a check for a false queen has been added to both allUGenerator and defaultAllUGenerator-to avoid the need for this check. --}-tryFinalStuckCheck:: ForceState -> Try ForceState-tryFinalStuckCheck fs =-  case find ((<4) . externalAngle bs) bvs of-     Nothing -> Right fs-     Just v -> Left $ "tryFinalStuckCheck: stuck/incorrect tiling: external angle problem found at vertex " ++ show v ++-                      "\nwith local faces:" ++ show (facesAtBV bs v) ++-                      "\nand boundary edges:" ++ show (boundary bs `intersect` (fmap reverseD $ facesDedges $ facesAtBV bs v)) ++ "\n"-  where bs = boundaryState fs-        bvs = fmap fst (boundary bs)--}--                                    +                                   {- $rules-Forcing rules,+FORCING RULES:  1. (wholeTileUpdates) When a join edge is on the boundary - add the missing half tile to make a whole tile.     2. (aceKiteUpdates) When a half dart has its short edge on the boundary@@ -737,21 +698,27 @@ 5. (jackDartUpdates) When a single dart wing is at a vertex which is recognised as an incomplete jack vertex    and has a complete kite below the dart wing,     add a second dart half touching at the vertex (sharing the kite below).-   This is also known as a *largeDartBase* vertex (= new dart base next level up - see later) 6. (sunStarUpdates) When a vertex has 3 or 4 whole kite origins (= 6 or 8 half kite origins)    it must be a sun centre. Also if a vertex has 4 whole dart origins (= 8 half dart origins)    it must be a star centre.    Add an appropriate half kite/dart on a boundary long edge at the vertex.    (This will complete suns (resp. stars) along with rule 1),-7. (jackKiteUpdates) When a dart half has its wing recognised as a jack (largeDartBase) vertex+7. (jackKiteUpdates) When a dart half has its wing recognised as a jack vertex    add a missing kite half on its long edge. 8. (kingDartUpdates) When a vertex is a kite wing and also an origin for exactly 4 dart halves    it must be a king vertex.    Add a missing dart half (on any boundary long edge of a dart at the vertex). 9. (queenDartUpdates) If there are more than 2 kite wings at a vertex (necessarily a queen)-   add any missing half dart on a boundary kite long edge+   add any missing half dart on a boundary kite long edge. (More than 2 is still valid - was =4) 10.(queenKiteUpdates) If there are more than 2 kite wings at a vertex (necessarily a queen)-   add any missing fourth half kite on a boundary kite short edge+   add any missing fourth half kite on a boundary kite short edge. (More than 2 rather than =3 to trap false queen case)++There is an update generator for each rule as well as combined update generators (defaultAllUGen, allUGenerator).++The rules are based on the 7 vertex types:++sun, star, jack, queen, king, ace (fool), deuce+ -}             {-------------------  FORCING RULES and Generators --------------------------@@ -759,11 +726,10 @@ sun, queen, jack (largeDartBase), ace (fool), deuce (largeKiteCentre), king, star -} -{-| allUGenerator combines all the 10 rule update generators.-    They are combined in sequence (keeping the rule order) after applying each to the-    supplied BoundaryState and a focus edge list. (See also defaultAllUGen).+{-| allUGenerator was the original generator for all updates. It combines the individual update generators for each of the 10 rules.+    They are combined in sequence, keeping the rule order (after applying each to the+    supplied BoundaryState and a focus edge list). (See also defaultAllUGen).     This version returns a Left..(fail report) for the first generator that produces a Left..(fail report).-    See $rules -} allUGenerator :: UpdateGenerator  allUGenerator bd focus =@@ -784,7 +750,6 @@                  , kingDartUpdates           -- (rule 8)                  , queenDartUpdates          -- (rule 9)                  , queenKiteUpdates          -- (rule 10)---                 , stuckFalseQueen           -- (new: rule 11)                  ]  -- |UFinder (Update case finder functions). Given a BoundaryState and a list of (focus) boundary directed edges,@@ -875,10 +840,10 @@ kiteWingCount:: BoundaryState -> Vertex -> Int kiteWingCount bd v = length $ filter ((==v) . wingV) $ filter isKite (facesAtBV bd v) --- |mustbeJack (large dart base / jack) is true of a boundary vertex if+-- |mustbeJack  is true of a boundary vertex if -- it is the wing of two darts not sharing a long edge or -- it is a wing of a dart and also a kite origin--- (false means it is either undetermined or is a large kite centre  - deuce)+-- (false means it is either undetermined or is a deuce). mustbeJack :: BoundaryState -> Vertex -> Bool mustbeJack bd v =   (length dWings == 2 && not (hasAnyMatchingE (fmap longE dWings))) || -- 2 dart wings and dart long edges not shared.@@ -909,7 +874,7 @@                                               return (Map.insert e u ump)                           --- *  Ten Update Generators (with corresponding Finders)+--   Ten Update Generators (with corresponding Finders)   -- |Update generator for rule (1)@@ -967,9 +932,9 @@ jackDartUpdates :: UpdateGenerator jackDartUpdates = makeGenerator addDartShortE noTouchingDart --- |Find kite halves with a short edge on the boundary (a,b) where oppV is a largeDartBase vertex+-- |Find kite halves with a short edge on the boundary (a,b) where oppV must be a jack vertex -- (oppV is a for left kite and b for right kite).--- The function mustbeJack determines if a vertex must be a a largeDartBase / jack+-- The function mustbeJack finds if a vertex must be a jack noTouchingDart :: UFinder               noTouchingDart = boundaryFilter farKOfDarts where    farKOfDarts bd (a,b) fc  = shortE fc == (b,a)@@ -997,11 +962,13 @@         )  -- |Update generator for rule (7)--- jack vertices (largeDartBases) with dart long edge on boundary - add missing kite top+-- jack vertices with dart long edge on the boundary - add missing kite top.+-- The function mustbeJack finds if a vertex must be a jack. jackKiteUpdates :: UpdateGenerator jackKiteUpdates = makeGenerator addKiteLongE jackMissingKite --- |Find jack vertices (largeDartBases) with dart long edge on the boundary+-- |Find jack vertices with dart long edge on the boundary.+-- The function mustbeJack finds if a vertex must be a jack jackMissingKite :: UFinder                   jackMissingKite = boundaryFilter dartsWingDB where     dartsWingDB bd (a,b) fc = longE fc == (b,a) &&@@ -1021,11 +988,11 @@   -- |Update generator for rule (9)--- queen vertices (with 4 kite wings) -- add any missing half dart on a boundary kite long edge+-- queen vertices (more than 2 kite wings) with a boundary kite long edge - add a half dart queenDartUpdates :: UpdateGenerator queenDartUpdates = makeGenerator addDartLongE queenMissingDarts --- |Find queen vertices (with 3 or 4 kite wings) and a boundary kite long edge+-- |Find queen vertices (more than 2 kite wings) with a boundary kite long edge queenMissingDarts :: UFinder                       queenMissingDarts = boundaryFilter predicate where     predicate bd (a,b) fc = @@ -1035,11 +1002,11 @@                              filter isKite $ facesAtBV bd fcWing                                        -- |Update generator for rule (10)--- queen vertices with 3 kite wings -- add missing fourth half kite on a boundary kite short edge+-- queen vertices with more than 2 kite wings -- add missing half kite on a boundary kite short edge queenKiteUpdates :: UpdateGenerator queenKiteUpdates = makeGenerator addKiteShortE queenMissingKite --- |Find queen vertices with only 3 kite wings and a kite short edge on the boundary+-- |Find queen vertices (2 or more kite wings) and a kite short edge on the boundary queenMissingKite :: UFinder                         queenMissingKite = boundaryFilter predicate where     predicate bd (a,b) fc = @@ -1048,7 +1015,7 @@                  kiteWings = filter ((==fcWing) . wingV) $ filter isKite (facesAtBV bd fcWing)  --- *  Six Update Checkers+--  Six Update Checkers   -- |completeHalf will check an update to@@ -1150,10 +1117,10 @@ -}  --- *  The Default All Update Generator (defaultAllUGen)+--  The Default All Update Generator (defaultAllUGen)  --- |An alternative to allUGenerator, and used as the default. It uses the same rules and UCheckers,+-- |The default all update generator (see also allUGenerator). It uses the 10 rules (and the same UCheckers as allUGenerator), -- but makes decisions based on the EdgeType of a boundary edge (instead of trying each UFinder in turn). -- If there are any Left..(fail reports) for the given -- boundary edges the result is a sigle Left.. concatenating all the failure reports (unlike allUGenerator).@@ -1200,26 +1167,29 @@   --- *  Auxiliary Functions for adding faces: externalAngle and tryFindThirdV. $Additions+--   Auxiliary Functions for adding faces: externalAngle and tryFindThirdV   {- $Additions-  -The difficulty of adding faces is determining if any edges of a new face already exist.-This goes beyond a simple graph operation and requires use of the internal angles of the faces.-We use a representation of angles which allows an equality test.-All angles are integer multiples of 1/10th turn (mod 10) so we use-these integers for comparing angles n where n is 0..9+Note about face additions: +When adding a new face on a boundary edge we need to use some geometric information. +To check if any other edges of the new face are adjacent on the boundary, we+calculate external angles at the relevant boundary vertices,+using a representation of angles which allows an equality test.+(All angles are integer multiples of 1/10th turn (mod 10) so we use+these integers for comparing angles n where n is 0..9)+ No crossing boundary property:-It is important that there are no crossing boundaries, otherwise external angle calculations could be wrong.+It is important that there are no crossing boundaries to ensure there is a unique external angle at each boundary vertex. -Possible Touching Vertices.-When tryFindThirdV returns Nothing, this means a new vertex needs to be created.+Touching Vertex check:+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. (Taken care of in tryUnsafeUpdate)----------------------------------}+creating a touching vertex/crossing boundary. This is why BoundaryStates keep track of boundary vertex positions.+(The check is done in tryUnsafeUpdate.)+-}  {-|tryFindThirdV finds a neighbouring third vertex on the boundary if there is one in the correct direction for a face added to    the right hand side of a directed boundary edge.@@ -1283,4 +1253,14 @@ faceIntAngles _      = [1,2,2] -- LK and RK  +{-------------------------+*************************             +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 = any (touching p) (VMap.elems vpMap) 

@@ -12,7 +12,7 @@ The module also includes functions to calculate (relative) locations of vertices (locateVertices, addVPoint), touching vertex checks (touchingVertices, touchingVerticesGen), and edge drawing functions. -This module re-exports module HalfTile and module Tgraph.Try.+This module re-exports module HalfTile and module Try. -} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleContexts          #-}@@ -21,7 +21,7 @@  module Tgraph.Prelude   ( module HalfTile-  , module Tgraph.Try+  , module Try     -- * Types for Tgraphs, Faces, Vertices, Directed Edges   , Tgraph -- not Data Constructor   , TileFace@@ -32,6 +32,11 @@   , Dedge   , EdgeType(..)    -- * Property Checking for Tgraphs+  , makeTgraph+  , tryMakeTgraph+  , tryCorrectTouchingVs+--  , renumberFaces+--  , differing   , makeUncheckedTgraph   , checkedTgraph   , tryTgraphProps@@ -69,6 +74,7 @@   , removeVertices   , selectVertices   , vertexSet+  , graphBoundaryVs   , graphDedges   , graphEdges   , internalEdges@@ -165,20 +171,20 @@   , locateVerticesGen   ) where -import Data.List ((\\), intersect, union, elemIndex,foldl',find)+import Data.List ((\\), intersect, union, elemIndex,foldl',find,nub) -- import Data.Either(fromRight, lefts, rights, isLeft)-import qualified Data.IntMap.Strict as VMap (IntMap, alter, lookup, fromList, fromListWith, (!), map, filterWithKey,insert, empty, toList, assocs, keys, keysSet)+import qualified Data.IntMap.Strict as VMap (IntMap, alter, lookup, fromList, fromListWith, (!), map, filterWithKey,insert, empty, toList, assocs, keys, keysSet, findWithDefault) import qualified Data.IntSet as IntSet (IntSet,union,empty,singleton,insert,delete,fromList,toList,null,(\\),notMember,deleteMin,findMin,findMax,member,difference) import qualified Data.Map.Strict as Map (Map, fromList, lookup, fromListWith) import Data.Maybe (mapMaybe) -- edgeNbrs import qualified Data.Set as Set  (fromList,member,null,delete)-- used for locateVertices -import Diagrams.Prelude hiding (union)-import Diagrams.TwoD.Text (Text)+import Diagrams.Prelude hiding (union,mapping)+-- import Diagrams.TwoD.Text (Text)  import TileLib import HalfTile-import Tgraph.Try+import Try   {---------------------@@ -189,20 +195,20 @@   --- $Types for Tgraphs, Vertices, Directed Edges, Faces+-- Types for Tgraphs, Vertices, Directed Edges, Faces --- |Tgraph vertices (must be positive)+-- |Tgraph vertex labels (must be positive) type Vertex = Int -- | directed edge type Dedge = (Vertex,Vertex)--- | Vertex Sets+-- | Vertex label sets type VertexSet = IntSet.IntSet --- |Tgraph faces  (vertices clockwise starting with tile origin vertex)--- a specialisation of HalfTile+-- |A TileFace is a HalfTile with 3 vertex labels (clockwise starting with the origin vertex).+-- Usually referred to as a face. type TileFace = HalfTile (Vertex,Vertex,Vertex) --- |A Tgraph is a list of faces.+-- |A Tgraph is a list of faces (TileFaces). -- All vertex labels should be positive, so 0 is not used as a vertex label. -- Tgraphs should be constructed with makeTgraph or checkedTgraph to check required properties. -- The data constructor Tgraph is not exported (but see also makeUncheckedTgraph).@@ -215,43 +221,88 @@ -- |Abbreviation for Mapping from Vertex keys (also used for Boundaries) type VertexMap a = VMap.IntMap a -{--------------------------------------------********************************************-Basic Tgraph, vertex, edge, face operations-********************************************---------------------------------------------} -{-*-Tgraphs and Property Checking+{-+Tgraphs Property Checking -} +{-|+makeTgraph performs a no touching vertex check as well as using tryTgraphProps for other required properties.+It produces an error if either check fails.+Note that the other Tgraph properties are checked first, to ensure that calculation of +vertex locations can be done for a touching vertex check.+-}+makeTgraph :: [TileFace] -> Tgraph+makeTgraph fcs = runTry $ onFail "makeTgraph: (failed):\n" $ tryMakeTgraph fcs +{-|+tryMakeTgraph performs the same checks for Tgraph properties as tryTgraphProps but in addition+it also checks that there are no touching vertices (distinct labels for the same vertex)+using touchingVertices (which calculates vertex locations).+It produces Left ... if either check fails and Right g otherwise where g is the Tgraph.+Note that the other Tgraph properties are checked first, to ensure that calculation of +vertex locations can be done.+-}+tryMakeTgraph :: [TileFace] -> Try Tgraph+tryMakeTgraph fcs =+ do g <- tryTgraphProps fcs -- must be checked first+    let touchVs = touchingVertices (faces g)+    if null touchVs +    then Right g +    else Left ("Found touching vertices: " +               ++ show touchVs+               ++ "\nwith faces:\n"+               ++ show fcs+               ++ "\n\n(To fix, use: tryCorrectTouchingVs)\n\n"+              )++{-| tryCorrectTouchingVs fcs finds touching vertices by calculating locations for vertices in the faces fcs,+    then renumbers to remove touching vertices (renumbers higher to lower numbers),+    then checks for Tgraph properties of the resulting faces to produce a Tgraph.+    NB fcs needs to be tile-connected before the renumbering and+    the renumbering need not be 1-1 (hence Relabelling is not used)      +-}+tryCorrectTouchingVs ::  [TileFace] -> Try Tgraph+tryCorrectTouchingVs fcs = +    onFail ("tryCorrectTouchingVs:\n" ++ show touchVs) $ +    tryTgraphProps $ nub $ renumberFaces touchVs fcs+        -- renumberFaces allows for a non 1-1 relabelling represented by a list +    where touchVs = touchingVertices fcs -- uses non-generalised version of touchingVertices++-- |renumberFaces allows for a non 1-1 relabelling represented by a list of pairs.+-- It is used only for tryCorrectTouchingVs in Tgraphs which then checks the result +renumberFaces :: [(Vertex,Vertex)] -> [TileFace] -> [TileFace]+renumberFaces prs = fmap renumberFace where+    mapping = VMap.fromList $ differing prs+    renumberFace = fmap (all3 renumber)+    all3 f (a,b,c) = (f a,f b,f c)+    renumber v = VMap.findWithDefault v v mapping+    differing = filter $ uncurry (/=)+  -- |Creates a (possibly invalid) Tgraph from a list of faces. -- It does not perform checks on the faces. Use makeTgraph (defined in Tgraphs module) or checkedTgraph to perform checks. -- This is intended for use only when checks are known to be redundant (the data constructor Tgraph is hidden). makeUncheckedTgraph:: [TileFace] -> Tgraph makeUncheckedTgraph fcs = Tgraph fcs -{-| Creates a Tgraph from a list of faces AND checks for edge loops, edge conflicts and-crossing boundaries and connectedness and legal tiling with tryTgraphProps.-(No crossing boundaries and connected implies tile-connected).-Produces an error if a check fails.+{-| Creates a Tgraph from a list of faces using tryTgraphProps to check required properties+and producing an error if a check fails.  Note: This does not check for touching vertices (distinct labels for the same vertex).-To perform this additional check use makeTgraph (defined in Tgraphs module) which also calls tryTgraphProps.+To perform this additional check use makeTgraph which also uses tryTgraphProps. -} checkedTgraph:: [TileFace] -> Tgraph checkedTgraph = runTry . onFail report . tryTgraphProps  where report = "checkedTgraph: Failed\n"  -- ++ " for faces: " ++ show fcs ++ "\n"  -{- | Checks a list of faces to avoid: -    edge loops,-    edge conflicts (same directed edge on two or more faces),-    illegal tilings (breaking legal rules for tiling),-    vertices not all >0 ,-    crossing boundaries, and -    non-connectedness.+{- | Checks a list of faces to ensure: +    no edge loops,+    no edge conflicts (same directed edge on two or more faces),+    legal tiling (obeys rules for legal tiling),+    all vertex labels >0 ,+    no crossing boundaries, and +    connectedness.  Returns Right g where g is a Tgraph on passing checks. Returns Left lines if a test fails, where lines describes the problem found.@@ -285,11 +336,11 @@                                   ++ "\nwith faces\n" ++ show fcs   | otherwise            = Right (Tgraph fcs) --- |Returns any repeated vertices in a single tileface for a list of tilefaces.+-- |Returns any repeated vertices within each TileFace for a list of TileFaces. findEdgeLoops:: [TileFace] -> [Vertex] findEdgeLoops = concatMap (duplicates . faceVList) --- |Checks if there are repeated vertices within a tileface for a list of tilefaces.+-- |Checks if there are repeated vertices within any TileFace for a list of TileFaces. -- Returns True if there are any. hasEdgeLoops:: [TileFace] -> Bool hasEdgeLoops = not . null . findEdgeLoops@@ -476,7 +527,7 @@ removeVertices :: [Vertex] -> Tgraph -> Tgraph removeVertices vs g = removeFaces (filter (hasVIn vs) (faces g)) g --- |selectVertices vs g - removes any face that does not have a vertex in the list vs from g.+-- |selectVertices vs g - removes any face that does not have at least one vertex in the list vs from g. -- Resulting Tgraph is checked -- for required properties  e.g. connectedness and no crossing boundaries. selectVertices :: [Vertex] -> Tgraph -> Tgraph@@ -486,6 +537,10 @@ vertexSet:: Tgraph -> VertexSet vertexSet = facesVSet . faces +-- |list of vertices that are on the boundary of a Tgraph+graphBoundaryVs :: Tgraph -> [Vertex]+graphBoundaryVs = map fst . graphBoundary+ -- |A list of all the directed edges of a Tgraph (going clockwise round faces) graphDedges :: Tgraph -> [Dedge] graphDedges = facesDedges . faces@@ -609,7 +664,10 @@   {- $Edges-Edges: (a,b) is regarded as a directed edge from a to b.+Representing Edges:++For vertices a and b, (a,b) is regarded as a directed edge from a to b (a Dedge).+ A list of such pairs will usually be regarded as a list of directed edges. In the special case that the list is symmetrically closed [(b,a) is in the list whenever (a,b) is in the list] we will refer to this as an edge list rather than a directed edge list.                  @@ -924,11 +982,9 @@ -- So labelColourSize c m  modifies a Patch drawing function to add labels (of colour c and size measure m). -- Measures are defined in Diagrams. In particular: tiny, verySmall, small, normal, large, veryLarge, huge. class DrawableLabelled a where--- | When a specific Backend B is in scope, --- -- labelColourSize :: DrawableLabelled a => Colour Double -> Measure Double -> (Patch -> Diagram B) -> a -> Diagram B-  labelColourSize :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => -                     Colour Double -> Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b+  labelColourSize :: OKBackend b => +                     Colour Double -> Measure Double -> (Patch -> Diagram b) -> a -> Diagram b -- The argument type of the draw function is Patch rather than VPatch, which prevents labelling twice.  @@ -943,17 +999,13 @@   labelColourSize c r d = labelColourSize c r d . makeVP  -- | Default Version of labelColourSize with colour red. Example usage: labelSize tiny draw a , labelSize normal drawj a------ When a specific Backend B is in scope, labelSize :: DrawableLabelled a => Measure Double -> (Patch -> Diagram B) -> a -> Diagram B-labelSize :: (Renderable (Path V2 Double) b, Renderable (Text Double) b, DrawableLabelled a) => -             Measure Double -> (Patch -> Diagram2D b) -> a -> Diagram2D b+labelSize :: (OKBackend b, DrawableLabelled a) => +             Measure Double -> (Patch -> Diagram b) -> a -> Diagram b labelSize = labelColourSize red  -- | Default Version of labelColourSize using red and small (rather than normal label size). Example usage: labelled draw a , labelled drawj a------ When a specific Backend B is in scope, labelled :: DrawableLabelled a => (Patch -> Diagram B) -> a -> Diagram B-labelled :: (Renderable (Path V2 Double) b, Renderable (Text Double) b, DrawableLabelled a) => -            (Patch -> Diagram2D b) -> a -> Diagram2D b+labelled :: (OKBackend b, DrawableLabelled a) => +            (Patch -> Diagram b) -> a -> Diagram b labelled = labelColourSize red small --(normalized 0.023)  -- |rotateBefore vfun a g - makes a VPatch from g then rotates by angle a before applying the VPatch function vfun.@@ -980,7 +1032,7 @@                 Just l -> l                 Nothing -> error $ "alignXaxis: second alignment vertex not found (Vertex " ++ show b ++ ")\n" --- |alignments takes a list of vertex pairs for respective alignmants of VPatches in the second list.+-- |alignments takes a list of vertex pairs for respective alignments of VPatches in the second list. -- For a pair (a,b) the corresponding VPatch is centered on a then b is aligned along the positive x axis.  -- The vertex pair list can be shorter than the list of VPatch - the remaining VPatch are left as they are. -- (Raises an error if either vertex in a pair is not in the corresponding VPatch vertices)@@ -1012,45 +1064,38 @@  -- |produce a diagram of a list of edges (given a VPatch) -- Will raise an error if any vertex of the edges is not a key in the vertex to location mapping of the VPatch.------ When a specific Backend B is in scope, drawEdgesVP :: VPatch -> [Dedge] -> Diagram B-drawEdgesVP :: Renderable (Path V2 Double) b =>-               VPatch -> [Dedge] -> Diagram2D b+drawEdgesVP :: OKBackend b =>+               VPatch -> [Dedge] -> Diagram b drawEdgesVP = drawEdges . vLocs --foldMap (drawEdgeVP vp)  -- |produce a diagram of a single edge (given a VPatch) -- Will raise an error if either vertex of the edge is not a key in the vertex to location mapping of the VPatch.------ When a specific Backend B is in scope, drawEdgeVP :: VPatch -> Dedge -> Diagram B-drawEdgeVP:: Renderable (Path V2 Double) b =>-               VPatch -> Dedge -> Diagram2D b+drawEdgeVP:: OKBackend b =>+             VPatch -> Dedge -> Diagram b drawEdgeVP = drawEdge . vLocs  -- |produce a diagram of a list of edges (given a mapping of vertices to locations) -- Will raise an error if any vertex of the edges is not a key in the mapping.------ When a specific Backend B is in scope, drawEdges :: VertexLocMap -> [Dedge] -> Diagram B-drawEdges :: Renderable (Path V2 Double) b =>-             VertexLocMap -> [Dedge] -> Diagram2D b+drawEdges :: OKBackend b =>+             VertexLocMap -> [Dedge] -> Diagram b drawEdges = foldMap . drawEdge  -- |produce a diagram of a single edge (given a mapping of vertices to locations). -- Will raise an error if either vertex of the edge is not a key in the mapping.------ When a specific Backend B is in scope, drawEdge :: VertexLocMap -> Dedge -> Diagram B-drawEdge :: Renderable (Path V2 Double) b =>-            VertexLocMap -> Dedge -> Diagram2D b+drawEdge :: OKBackend b =>+            VertexLocMap -> Dedge -> Diagram b drawEdge vpMap (a,b) = case (VMap.lookup a vpMap, VMap.lookup b vpMap) of                          (Just pa, Just pb) -> pa ~~ pb                          _ -> error $ "drawEdge: location not found for one or both vertices "++ show(a,b) ++ "\n"   -{-| locateVertices: processes a list of faces to associate points for each vertex.+{-| locateVertices: 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. It will raise an error if faces are not connected. If faces have crossing boundaries (i.e not locally tile-connected), this could raise an error-or a result with touching vertices (i.e. more than one vertex with the same location).+or a result with touching vertices (i.e. more than one vertex label with the same location). -} locateVertices:: [TileFace] -> VertexLocMap --  This version is made more efficient by calculating an edge to face map@@ -1088,7 +1133,7 @@     Just (v,p) -> VMap.insert v p vpMap     Nothing -> vpMap --- |axisJoin face +-- |axisJoin face -  -- initialises a vertex to point mapping with locations for the join edge vertices of face -- with originV face at the origin and aligned along the x axis with unit length for a half dart -- and length phi for a half kite. (Used to initialise locateVertices)@@ -1147,10 +1192,10 @@   {-| -touchingVertices checks that no vertices are too close to each other using locateVertices.-If vertices are too close that indicates we may have different vertex numbers at the same location+touchingVertices finds if any vertices are too close to each other using locateVertices.+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 (higher number first in each pair)+It returns pairs of vertices that are too close with higher number first in each pair, and no repeated first numbers. An empty list is returned if there are no touching vertices. Complexity has order of the square of the number of vertices.                            @@ -1158,17 +1203,15 @@ -} touchingVertices:: [TileFace] -> [(Vertex,Vertex)] touchingVertices fcs = check vpAssoc where-  vpAssoc = VMap.assocs $ locateVertices fcs  -- assocs puts in key order so that check returns (higher,lower) pairs+  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 ]--- check ((v,p):more) = [(v1,v) | (v1,p1) <- more, touching p p1 ] ++ check more--- does not correctly deal with 3 or more vertices touching at the same point  {-|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).+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

@@ -41,7 +41,6 @@   , prepareFixAvoid   , relabelContig     --  * Renumbering (not necessarily 1-1)-  , renumberFaces --  , tryMatchFace --  , twoVMatch --  , matchFaceIgnore@@ -54,7 +53,6 @@ import qualified Data.IntSet as IntSet (fromList,intersection,findMax,elems,(\\),null,member)  import Tgraph.Prelude--- import Tgraph.Convert (touchingVertices, touchingVerticesGen) -- used for fullUnion and commonFaces   {-| fullUnion (g1,e1) (g2,e2) will try to create the union of g1 and g2.  That is, it will try to combine the faces of g1@@ -354,17 +352,6 @@    rlab = relabellingFrom 1 (vertexSet g)   -- assert: rlab is 1-1 on the vertices of g   -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does)- ---- |renumberFaces allows for a non 1-1 relabelling represented by a list of pairs.--- It is used only for tryCorrectTouchingVs in Tgraphs which then checks the result -renumberFaces :: [(Vertex,Vertex)] -> [TileFace] -> [TileFace]-renumberFaces prs = fmap renumberFace where-    mapping = VMap.fromList $ differing prs-    renumberFace = fmap (all3 renumber)-    all3 f (a,b,c) = (f a,f b,f c)-    renumber v = VMap.findWithDefault v v mapping-                        {-| tryMatchFace f g - looks for a face in g that corresponds to f (sharing a directed edge),@@ -398,9 +385,10 @@ matchFaceIgnore face g = case tryMatchFace face g of    Right mf -> mf    Left _   -> Nothing-    --- |selects only non-matching pairs from a list+-- |selects the non-equal pairs from a list differing :: Eq a => [(a,a)] -> [(a,a)]-differing = filter (\(a,b) -> a/=b)+differing = filter $ uncurry (/=) -- (\(a,b) -> a/=b)++ 

@@ -1,88 +0,0 @@-{-|-Module      : Tgraph.Try-Description : Result types for partial functions-Copyright   : (c) Chris Reade, 2021-License     : BSD-style-Maintainer  : chrisreade@mac.com-Stability   : experimental--Try is a synonym for Either String, which is used for results of partial operations-which return either Right something when defined or Left string when there is a problem-(where string is a failure report).-This is to allow computation to continue in failure cases without necessarily raising an error.-This module contains functions associated with Try results.--}--module Tgraph.Try-  ( -- * Try - result types with failure reporting (for partial operations).-  Try-  , onFail-  , nothingFail-  , runTry-  , ifFail-  , isFail-  , concatFails-  , ignoreFails-  , atLeastOne-  , noFails-  ) where--import Data.Either(fromRight, lefts, rights, isLeft)----- | Try is a synonym for Either String.  Used for results of partial functions--- which return either Right something when defined or Left string when there is a problem--- where string is a failure report.--- Note: Either String (and hence Try) is a monad, and this is used frequently for combining  partial operations.-type Try a = Either String a---- | onFail s exp - inserts s at the front of failure report if exp fails with Left report-onFail:: String -> Try a -> Try a-onFail s = either (Left . (s++)) Right---- | Converts a Maybe Result into a Try result by treating Nothing as a failure--- (the string s is the failure report on failure).--- Usually used as infix (exp `nothingFail` s)-nothingFail :: Maybe b -> String -> Try b-nothingFail a s = maybe (Left s) Right a---- |Extract the (Right) result from a Try, producing an error if the Try is Left s.--- The failure report is passed to error for an error report.-runTry:: Try a -> a-runTry = either error id---- |ifFail a tr - extracts the (Right) result from tr but returning a if tr is Left s.-ifFail :: a -> Try a -> a-ifFail = fromRight ---- |a try result is a failure if it is a Left-isFail:: Try a -> Bool-isFail = isLeft-   --- |Combines a list of Trys into a single Try with failure overriding success.--- It concatenates all failure reports if there are any and returns a single Left r.--- Otherwise it produces Right rs where rs is the list of all (successful) results.--- In particular, concatFails [] = Right []-concatFails:: [Try a] -> Try [a]-concatFails ls = case lefts ls of-                 [] -> Right $ rights ls-                 other -> Left $ mconcat other -- concatenates strings for single report---- |Combines a list of Trys into a list of the successes, ignoring any failures.--- In particular, ignoreFails [] = []-ignoreFails:: [Try a] -> [a]-ignoreFails = rights---- | atLeastOne rs - returns the list of successful results if there are any, but fails with an error otherwise.--- The error report will include the concatenated reports from the failures. -atLeastOne:: [Try a] -> [a]-atLeastOne [] = error "atLeastOne: applied to empty list.\n"-atLeastOne results = case ignoreFails results of-                 [] -> runTry $ onFail "atLeastOne: no successful results.\n" $ concatFails results-                 other -> other ---- | noFails rs - returns the list of successes when all cases succeed, but fails with--- an error and a concatenated failure report of all failures if there is at least one failure.--- In particular, noFails [] = []-noFails:: [Try a] -> [a]-noFails = runTry . concatFails

@@ -86,21 +86,22 @@  , kingEmpiresFig  , kingEmpire1Fig  , kingEmpire2Fig+    -- *  Emplace Choices+ , emplaceChoices+ , emplaceChoicesFig     ) where  import Diagrams.Prelude-import Diagrams.TwoD.Text (Text)--- import ChosenBackend (B) import TileLib import Tgraphs +import Data.List (intersect,find)      -- for emplaceChoices   -- |used for most diagrams to give border padding--- ---  When a specific Backend B is in scope, padBorder:: Diagram B -> Diagram B-padBorder :: Diagram2D b -> Diagram2D b+padBorder :: OKBackend b => +             Diagram b -> Diagram b padBorder = pad 1.2 . centerXY  -- |chunks n l -  split a list l into chunks of length n (n>0)@@ -114,23 +115,19 @@ -- |arrangeRowsGap s n diags - arranges diags into n per row, centering each row horizontally, -- with a seperation gap (horizontally and vertically) of s. -- The result is a single diagram.--- ---  When a specific Backend B is in scope, arrangeRowsGap :: Double -> Int -> [Diagram B] -> Diagram B-arrangeRowsGap :: Double -> Int -> [Diagram2D b] -> Diagram2D b+arrangeRowsGap :: OKBackend b => +                  Double -> Int -> [Diagram b] -> Diagram b arrangeRowsGap s n = centerY . vsep s . fmap (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).--- ---  When a specific Backend B is in scope, arrangeRows :: Int -> [Diagram B] -> Diagram B-arrangeRows :: Int -> [Diagram2D b] -> Diagram2D b+arrangeRows :: OKBackend b => +               Int -> [Diagram b] -> Diagram b arrangeRows = arrangeRowsGap 1.0  -- |add a given label at a given point offset from the centre of the given diagram.--- --- When a specific Backend B is in scope, labelAt :: Point V2 Double -> String -> Diagram B -> Diagram B-labelAt :: Renderable (Text Double) b => -           Point V2 Double -> String -> Diagram2D b -> Diagram2D b+labelAt :: OKBackend b => +           Point V2 Double -> String -> Diagram b -> Diagram b labelAt p l d = baselineText l # fontSize (output 15) # moveTo p <> d --labelAt p l d = baselineText l # fontSize (normalized 0.02) # moveTo p <> d @@ -152,15 +149,11 @@ foolDs = decompositions fool  -- | diagram of just fool.------ When a specific Backend B is in scope, foolFig :: Diagram B-foolFig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+foolFig :: OKBackend b => Diagram b foolFig = padBorder $ labelSize normal drawj fool  -- |diagram of fool with foolD.--- --- When a specific Backend B is in scope, foolAndFoolD :: Diagram B-foolAndFoolD :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+foolAndFoolD :: OKBackend b => Diagram b foolAndFoolD = padBorder $ hsep 1 [scale phi $ labelled drawj fool, labelled drawj foolD]  -- |Tgraph for a sun (sun vertex type)@@ -177,9 +170,7 @@ sunDs =  decompositions sunGraph  -- |Figure for a 3 times decomposed sun with a 2 times decomposed sun.--- --- When a specific Backend B is in scope, figSunD3D2 :: Diagram B-figSunD3D2 :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+figSunD3D2 :: OKBackend b => Diagram b figSunD3D2 = padBorder $ hsep 1 [labelled drawj $ sunDs !! 3, scale phi $ labelled drawj $ sunDs !! 2]  -- |Tgraph for kite@@ -205,46 +196,30 @@   -pCompFig1,pCompFig2,pCompFig :: Renderable (Path V2 Double) b => Diagram2D b+pCompFig1,pCompFig2,pCompFig :: OKBackend b => Diagram b -- |diagram showing partial composition of a forced 3 times decomposed dart (with remainder faces in pale green).--- --- When a specific Backend B is in scope, pCompFig1 :: Diagram B pCompFig1 = lw veryThin $ hsep 5 $ rotations [1,1] [draw fd3, drawPCompose fd3]             where fd3 = force $ dartDs!!3 -- |diagram showing partial composition of a forced 3 times decomposed kite (with remainder faces in pale green).--- --- When a specific Backend B is in scope, pCompFig2 :: Diagram B pCompFig2 = lw veryThin $ hsep 5 [draw fk3, drawPCompose fk3]             where fk3 = force $ kiteDs!!3 -- |diagram showing two partial compositions (with remainder faces in pale green).--- --- When a specific Backend B is in scope, pCompFig :: Diagram B pCompFig = padBorder $ vsep 3 [center pCompFig1, center pCompFig2]   -- |diagram of foolDminus and the result of forcing.  --- --- When a specific Backend B is in scope, forceFoolDminus :: Diagram B-forceFoolDminus :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+forceFoolDminus :: OKBackend b => Diagram b forceFoolDminus = padBorder $ hsep 1 $ fmap (labelled drawj) [foolDminus, force foolDminus]  -forceDartD5Fig,forceKiteD5Fig,forceSunD5Fig,forceFig :: Renderable (Path V2 Double) b => Diagram2D b+forceDartD5Fig,forceKiteD5Fig,forceSunD5Fig,forceFig :: OKBackend b => Diagram b -- |diagram of forced 5 times decomposed dart.--- --- When a specific Backend B is in scope, forceDartD5Fig :: Diagram B forceDartD5Fig = padBorder $ lw ultraThin $ drawForce $ dartDs !! 5 -- |diagram of forced 5 times decomposed kite.--- --- When a specific Backend B is in scope, forceKiteD5Fig :: Diagram B forceKiteD5Fig = padBorder $ lw ultraThin $ rotate (ttangle 1) $ drawForce $ kiteDs!!5 -- |diagram of forced 5 times decomposed sun.--- --- When a specific Backend B is in scope, forceSunD5Fig :: Diagram B forceSunD5Fig =  padBorder $ lw ultraThin $ drawForce $ sunDs !! 5 -- |diagram of forced 5 times decomposed dart (left) and kite (right).--- --- When a specific Backend B is in scope, forceFig :: Diagram B forceFig = hsep 1 [forceDartD5Fig,forceKiteD5Fig]  -- |brokenDart is a 4 times decomposed dart (dartD4) with 5 halftile faces removed.@@ -265,17 +240,13 @@ --  deleted = RK(6,28,54):filter (isAtV 63) (faces brokenDart)  -- |brokenDartFig shows the faces removed from dartD4 to make brokenDart and badlyBrokenDart.--- --- When a specific Backend B is in scope, brokenDartFig :: Diagram B-brokenDartFig  :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+brokenDartFig  :: OKBackend b => Diagram b brokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (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).--- --- When a specific Backend B is in scope, badlyBrokenDartFig :: Diagram B-badlyBrokenDartFig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+badlyBrokenDartFig :: OKBackend b => Diagram b badlyBrokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [vp, vpComp, vpFailed] where     vp = makeVP badlyBrokenDart     comp = compose badlyBrokenDart@@ -284,9 +255,7 @@  -- |figure showing the result of removing incomplete tiles (those that do not have their matching halftile) -- to a 3 times decomposed sun.--- --- When a specific Backend B is in scope, removeIncompletesFig :: Diagram B-removeIncompletesFig :: Renderable (Path V2 Double) b => Diagram2D b+removeIncompletesFig :: OKBackend b => Diagram b removeIncompletesFig = padBorder $ drawj $ removeFaces (boundaryJoinFaces g) g where      g = sunDs !! 3 @@ -302,9 +271,7 @@ -- *  Figures for 7 vertex types  -- | vertexTypesFig is 7 vertex types in a single diagram as a row.--- --- When a specific Backend B is in scope, vertexTypesFig :: Diagram B-vertexTypesFig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+vertexTypesFig :: OKBackend b => Diagram b vertexTypesFig = padBorder $ hsep 1 lTypeFigs  where  lTypeFigs = zipWith (labelAt (p2 (0,-2.2))) ["sun","star","jack","queen","king","ace","deuce"] vTypeFigs@@ -343,9 +310,7 @@   ] -- centre 1  -- |forceVFigures is a list of 7 diagrams - force of 7 vertex types.------ When a specific Backend B is in scope, forceVFigures :: [Diagram B]-forceVFigures :: Renderable (Path V2 Double) b => [Diagram2D b]+forceVFigures :: OKBackend b => [Diagram b] forceVFigures = rotations [0,0,9,5,0,0,1] $                 fmap (center . drawForce) [sunGraph,starGraph,jackGraph,queenGraph,kingGraph,aceGraph,deuceGraph] @@ -359,17 +324,13 @@  -- |Diagram showing superForce with initial Tgraph g (red), force g (red and black), -- and superForce g (red and black and blue).--- --- When a specific Backend B is in scope, superForceFig :: Diagram B-superForceFig :: Renderable (Path V2 Double) b => Diagram2D b+superForceFig :: OKBackend b => Diagram b superForceFig = padBorder $ lw thin $ rotate (ttangle 1) $ drawSuperForce g where     g = addHalfDart (220,221) $ force $ decompositions fool !!3  -- |Diagram showing 4 rockets formed by applying superForce to successive decompositions -- of sun3Dart. The decompositions are in red with normal force additions in black and superforce additions in blue.--- --- When a specific Backend B is in scope, superForceRocketsFig :: Diagram B-superForceRocketsFig :: Renderable (Path V2 Double) b => Diagram2D b+superForceRocketsFig :: OKBackend b => Diagram b superForceRocketsFig = padBorder $ lw veryThin $ vsep 1 $ rotations [8,9,9,8] $    fmap drawSuperForce decomps where       decomps = take 4 $ decompositions sun3Dart@@ -377,18 +338,14 @@  boundaryFDart4, boundaryFDart5 :: Tgraph -- |graph of the boundary faces only of a forced graph (dartDs!!4)-boundaryFDart4 = checkedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4+boundaryFDart4 = makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 -- |graph of the boundary faces only of a forced graph (dartDs!!5)-boundaryFDart5 = checkedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5)+boundaryFDart5 = makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5) -boundaryFDart4Fig,boundaryFDart5Fig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+boundaryFDart4Fig,boundaryFDart5Fig :: OKBackend b => Diagram b -- |figure of the boundary faces only of a forced graph (dartDs!!4).--- --- When a specific Backend B is in scope, boundaryFDart4Fig :: Diagram B boundaryFDart4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryFDart4 -- |figure of the boundary faces only of a forced graph (dartDs!!5).--- --- When a specific Backend B is in scope, boundaryFDart5Fig :: Diagram B boundaryFDart5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryFDart5  boundaryGapFDart4, boundaryGapFDart5 :: Tgraph@@ -399,23 +356,17 @@ boundaryGapFDart5 = removeVertices [1467] boundaryFDart5     -- checkedTgraph $ filter ((/=1467).originV) (faces boundaryFDart5) -boundaryGap4Fig, boundaryGap5Fig  :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D b+boundaryGap4Fig, boundaryGap5Fig  :: OKBackend b => Diagram b -- |figure for the boundary gap graph boundaryGapFDart4.--- --- When a specific Backend B is in scope, boundaryGap4Fig :: Diagram B boundaryGap4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryGapFDart4 -- |figure for the boundary gap graph boundaryGapFDart5.--- --- When a specific Backend B is in scope, boundaryGap5Fig :: Diagram B boundaryGap5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj 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).--- --- When a specific Backend B is in scope, boundaryVCoveringFigs :: BoundaryState -> [Diagram B]-boundaryVCoveringFigs :: Renderable (Path V2 Double) b =>-                         BoundaryState -> [Diagram2D b]+boundaryVCoveringFigs :: OKBackend b =>+                         BoundaryState -> [Diagram b] boundaryVCoveringFigs bd =     fmap (lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph) $ boundaryVCovering bd       where redg = lc red $ draw g --alignBefore draw alig g@@ -424,36 +375,60 @@  -- | boundaryECoveringFigs bd - produces a list of diagrams for the boundaryECovering of bd   -- (with the Tgraph represented by bd shown in red in each case).--- --- When a specific Backend B is in scope, boundaryECoveringFigs :: BoundaryState -> [Diagram B]-boundaryECoveringFigs :: Renderable (Path V2 Double) b =>-                         BoundaryState -> [Diagram2D b]+boundaryECoveringFigs :: OKBackend b =>+                         BoundaryState -> [Diagram b] boundaryECoveringFigs bd =     fmap (lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph) $ boundaryECovering bd       where redg = lc red $ draw g             alig = defaultAlignment g             g = recoverGraph bd -kingECoveringFig,kingVCoveringFig :: Renderable (Path V2 Double) b => Diagram2D b+kingECoveringFig,kingVCoveringFig :: OKBackend b => Diagram b -- | diagram showing the boundaryECovering of a forced kingGraph.--- --- When a specific Backend B is in scope, kingECoveringFig :: Diagram B kingECoveringFig = padBorder $ arrangeRows 3 $ boundaryECoveringFigs $ force $ makeBoundaryState kingGraph -- | diagram showing the boundaryVCovering of a forced kingGraph.--- --- When a specific Backend B is in scope, kingVCoveringFig :: Diagram B kingVCoveringFig = padBorder $ arrangeRows 3 $ boundaryVCoveringFigs $ force  $ makeBoundaryState kingGraph -kingEmpiresFig, kingEmpire1Fig, kingEmpire2Fig :: Renderable (Path V2 Double) b => Diagram2D b+kingEmpiresFig, kingEmpire1Fig, kingEmpire2Fig :: OKBackend b => Diagram b -- | figure showing King's empires (1 and 2).--- --- When a specific Backend B is in scope, kingEmpiresFig :: Diagram B kingEmpiresFig = padBorder $ hsep 10 [kingEmpire1Fig, kingEmpire2Fig] -- | figure showing King's empires 1.--- --- When a specific Backend B is in scope, kingEmpire1Fig :: Diagram B kingEmpire1Fig = showEmpire1 kingGraph -- | figure showing King's empire 2.--- --- When a specific Backend B is in scope, kingEmpire2Fig :: Diagram B kingEmpire2Fig = showEmpire2 kingGraph+++-- |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.+-- This version relies on compForce theorem and related theorems+emplaceChoices:: Tgraph -> [Tgraph]+emplaceChoices g = emplaceChoicesForced $ recoverGraph $ force $ makeBoundaryState g where++  emplaceChoicesForced:: Tgraph -> [Tgraph]+  emplaceChoicesForced g0 | nullGraph g' = chooseUnknowns [(unknowns $ getDartWingInfo g0, g0)]+                          | otherwise    = (force . decompose) <$> emplaceChoicesForced g'+                          where g' = compose g0++  chooseUnknowns :: [([Vertex],Tgraph)] -> [Tgraph]+  chooseUnknowns [] = []+  chooseUnknowns (([],g0):more) = g0:chooseUnknowns more+  chooseUnknowns (((u:unks),g0): more)+     =  chooseUnknowns (map (remainingunks unks) newgs ++ more)+        where newgs = map recoverGraph $ atLeastOne $ tryDartAndKiteForced (findDartLongForWing u bd) bd+              bd = makeBoundaryState g0+              remainingunks startunks g' = (startunks `intersect` graphBoundaryVs g', g')++  findDartLongForWing :: Vertex -> BoundaryState -> Dedge+  findDartLongForWing v bd +      = case find isDart (facesAtBV bd v) of+        Just d -> longE d+        Nothing -> error $ "findDartLongForWing: dart not found for dart wing vertex " ++ show v++-- |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+    where g = foolD+          overlayg g' = smartAlignBefore draw algmnt g # lc red <> alignBefore draw algmnt g'+          algmnt = defaultAlignment g+

@@ -1,13 +1,12 @@ {-| Module      : Tgraphs-Description : Collects and exports the various Tgraph modules plus extra operations, including makeTgraph+Description : Collects and exports the various Tgraph modules plus extra operations. Copyright   : (c) Chris Reade, 2021 License     : BSD-style Maintainer  : chrisreade@mac.com Stability   : experimental  This is the main module for Tgraph operations which collects and exports the other Tgraph modules. -It exports makeTgraph for constructing checked Tgraphs and excludes data constructor Tgraph. The module also defines several functions for producing overlaid diagrams for Tgraphs (including smart drawing) and experimental combinations such as boundaryECovering, boundaryVCovering, empire1, empire2, superForce, boundaryLoopsG. It also defines experimental TrackedTgraphs (used for tracking subsets of faces of a Tgraph).@@ -17,7 +16,6 @@ {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE FlexibleInstances         #-} -- needed for Drawable Patch--- {-# LANGUAGE TypeOperators             #-} -- needed for type equality constraints ~  module Tgraphs   ( module Tgraph.Prelude@@ -25,10 +23,6 @@   , module Tgraph.Compose   , module Tgraph.Force   , module Tgraph.Relabelling-   -- * Making valid Tgraphs (with a check for no touching vertices).-  , makeTgraph-  , tryMakeTgraph-  , tryCorrectTouchingVs     -- * Smart drawing of Tgraphs   , smart   , boundaryJoinFaces@@ -50,11 +44,8 @@   , compForce   , allCompForce   , maxCompForce-  , forceDecomp+--  , forceDecomp   , allForceDecomps-    -- * Emplace Choices-  , emplaceChoices---  , emplaceChoices'       -- * Boundary Covering and Empires   , forcedBoundaryECovering   , forcedBoundaryVCovering@@ -77,6 +68,8 @@   , superForce   , trySuperForce   , singleChoiceEdges+    -- * Boundary face graph+  , tryBoundaryFaceGraph      -- * Boundary loops   , boundaryLoopsG   , boundaryLoops@@ -98,8 +91,6 @@   , drawTrackedTgraphAligned   ) where --- import Tgraph.Prelude hiding (Tgraph(Tgraph)) -- hides Tgraph as type and data constructor--- import Tgraph.Prelude (Tgraph) -- re-includes Tgraph as type constructor only import Tgraph.Prelude import Tgraph.Decompose import Tgraph.Compose@@ -108,58 +99,13 @@ import Diagrams.Prelude hiding (union) import TileLib -import Data.List (intersect, union, (\\), find, foldl',nub, transpose)      +import Data.List (intersect, union, (\\), find, foldl', transpose)       import qualified Data.Set as Set  (Set,fromList,null,intersection,deleteFindMin)-- used for boundary covers import qualified Data.IntSet as IntSet (fromList,member,(\\)) -- for boundary vertex set import qualified Data.IntMap.Strict as VMap (delete, fromList, findMin, null, lookup, (!)) -- used for boundary loops, boundaryLoops --- * Making valid Tgraphs (with a check for no touching vertices). -{-|-makeTgraph performs a no touching vertex check as well as using tryTgraphProps for other required properties.-It produces an error if either check fails.-Note that the other Tgraph properties are checked first, to ensure that calculation of -vertex locations can be done for a touching vertex check.--}-makeTgraph :: [TileFace] -> Tgraph-makeTgraph fcs = runTry $ onFail "makeTgraph: (failed):\n" $ tryMakeTgraph fcs -{-|-tryMakeTgraph performs the same checks for Tgraph properties as tryTgraphProps but in addition-it also checks that there are no touching vertices (distinct labels for the same vertex)-using Tgraph.Convert.touchingVertices (which calculates vertex locations).-It produces Left ... if either check fails and Right g otherwise where g is the Tgraph.-Note that the other Tgraph properties are checked first, to ensure that calculation of -vertex locations can be done.--}-tryMakeTgraph :: [TileFace] -> Try Tgraph-tryMakeTgraph fcs =- do g <- tryTgraphProps fcs -- must be checked first-    let touchVs = touchingVertices (faces g)-    if null touchVs -    then Right g -    else Left ("Found touching vertices: " -               ++ show touchVs-               ++ "\nwith faces:\n"-               ++ show fcs-               ++ "\n\n(To fix, use: tryCorrectTouchingVs)\n\n"-              )--{-| tryCorrectTouchingVs fcs finds touching vertices by calculating locations for vertices in the faces fcs,-    then renumbers to remove touching vertices (renumbers higher to lower numbers),-    then checks for Tgraph properties of the resulting faces to produce a Tgraph.-    NB fcs needs to be tile-connected before the renumbering and-    the renumbering need not be 1-1 (hence Relabelling is not used)      --}-tryCorrectTouchingVs ::  [TileFace] -> Try Tgraph-tryCorrectTouchingVs fcs = -    onFail ("tryCorrectTouchingVs:\n" ++ show touchVs) $ -    tryTgraphProps $ nub $ renumberFaces touchVs fcs-        -- renumberFaces allows for a non 1-1 relabelling represented by a list -    where touchVs = touchingVertices fcs -- uses non-generalised version of touchingVertices--- -- |smart dr g - uses VPatch drawing function dr after converting g to a VPatch -- It will add boundary joins regardless of the drawing function. -- Examples:@@ -169,10 +115,8 @@ -- smart (labelled draw) g -- -- smart (labelSize normal draw) g------  When a specific Backend B is in scope, smart :: (VPatch -> Diagram B) -> Tgraph -> Diagram B-smart :: Renderable (Path V2 Double) b => -         (VPatch -> Diagram2D b) -> Tgraph -> Diagram2D b+smart :: OKBackend b => +         (VPatch -> Diagram b) -> Tgraph -> Diagram b smart dr g = drawJoinsFor (boundaryJoinFaces g) vp <> dr vp   where vp = makeVP g @@ -183,25 +127,19 @@     bdry = makeBoundaryState g  -- |given a list of faces and a VPatch with suitable locations, draw just the dashed joins for those faces.--- ---  When a specific Backend B is in scope,  drawJoinsFor:: [TileFace] -> VPatch -> Diagram B-drawJoinsFor::  Renderable (Path V2 Double) b => -                [TileFace] -> VPatch -> Diagram2D b+drawJoinsFor::  OKBackend b => +                [TileFace] -> VPatch -> Diagram b drawJoinsFor fcs vp = drawWith dashjOnly (subVP vp fcs)  -- |same as draw except adding dashed lines on boundary join edges. --- ---  When a specific Backend B is in scope,  smartdraw :: Tgraph -> Diagram B-smartdraw :: Renderable (Path V2 Double) b => Tgraph -> Diagram2D b+smartdraw :: OKBackend b => Tgraph -> Diagram b smartdraw = smart draw  -- |restrictSmart g dr vp - assumes vp has locations for vertices in g. -- It uses the VPatch drawing function dr to draw g and adds dashed boundary joins. -- This can be used instead of smart when an appropriate vp is already available.--- ---  When a specific Backend B is in scope, restrictSmart:: Tgraph -> (VPatch -> Diagram B) -> VPatch -> Diagram B-restrictSmart :: Renderable (Path V2 Double) b =>-                 Tgraph -> (VPatch -> Diagram2D b) -> VPatch -> Diagram2D b+restrictSmart :: OKBackend b =>+                 Tgraph -> (VPatch -> Diagram b) -> VPatch -> Diagram b restrictSmart g dr vp = drawJoinsFor (boundaryJoinFaces g) rvp <> dr rvp                         where rvp = restrictVP vp $ faces g @@ -209,30 +147,24 @@ -- Uses vfun to produce a Diagram after converting g to a rotated VPatch but also adds the dashed boundary join edges of g. -- -- Example: smartRotateBefore (labelled draw) angle g------  When a specific Backend B is in scope,  smartRotateBefore::  (VPatch -> Diagram B) -> Angle Double -> Tgraph -> Diagram B-smartRotateBefore :: Renderable (Path V2 Double) b =>-                     (VPatch -> Diagram2D b) -> Angle Double -> Tgraph -> Diagram2D b+smartRotateBefore :: OKBackend b =>+                     (VPatch -> Diagram b) -> Angle Double -> Tgraph -> Diagram b smartRotateBefore vfun angle g = rotateBefore (restrictSmart g vfun) angle g  -- |smartAlignBefore vfun (a,b) g - a tricky combination of smart with alignBefore. -- Uses vfun to produce a Diagram after converting g to n aligned VPatch but also adds the dashed boundary join edges of g. --  -- Example: smartAlignBefore (labelled draw) (a,b) g------  When a specific Backend B is in scope,  smartAlignBefore::  (VPatch -> Diagram B) -> (Vertex,Vertex) -> Tgraph -> Diagram B-smartAlignBefore :: Renderable (Path V2 Double) b =>-                    (VPatch -> Diagram2D b) -> (Vertex,Vertex) -> Tgraph -> Diagram2D b+smartAlignBefore :: OKBackend b =>+                    (VPatch -> Diagram b) -> (Vertex,Vertex) -> Tgraph -> Diagram b smartAlignBefore vfun (a,b) g = alignBefore (restrictSmart g vfun) (a,b) g    -- |applies partCompose to a Tgraph g, then draws the composed graph with the remainder faces (in lime). -- (Relies on the vertices of the composition and remainder being subsets of the vertices of g.)--- ---  When a specific Backend B is in scope,  drawPCompose ::  Tgraph -> Diagram B-drawPCompose :: Renderable (Path V2 Double) b =>-                Tgraph -> Diagram2D b+drawPCompose :: OKBackend b =>+                Tgraph -> Diagram b drawPCompose g =      restrictSmart g' draw vp     <> drawj (subVP vp remainder) # lw medium # lc lime@@ -241,10 +173,8 @@  -- |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--- ---  When a specific Backend B is in scope,  drawForce:: Tgraph -> Diagram B-drawForce :: Renderable (Path V2 Double) b =>-             Tgraph -> Diagram2D b+drawForce :: OKBackend b =>+             Tgraph -> Diagram b drawForce g =      restrictSmart g draw vp # lc red # lw medium      <> draw vp@@ -253,24 +183,20 @@ -- |drawSuperForce g is a diagram showing the argument g in red overlayed on force g in black -- overlaid on superForce g in blue. -- It adds dashed join edges on the boundary of g.--- ---  When a specific Backend B is in scope,  drawSuperForce:: Tgraph -> Diagram B-drawSuperForce :: Renderable (Path V2 Double) b =>-                  Tgraph -> Diagram2D b+drawSuperForce :: OKBackend b =>+                  Tgraph -> Diagram b drawSuperForce g = (dg # lc red) <> dfg <> (dsfg # lc blue) where-    sfg = superForce g     fg = force g-    vp = makeVP $ superForce g+    sfg = superForce fg+    vp = makeVP $ sfg     dfg = draw $ selectFacesVP vp (faces fg \\ faces g) -- restrictSmart (force g) draw vp     dg = restrictSmart g draw vp     dsfg = draw $ selectFacesVP vp (faces sfg \\ faces fg)  -- | drawWithMax g - draws g and overlays the maximal composition of force g in red. -- This relies on g and all compositions of force g having vertices in force g.--- ---  When a specific Backend B is in scope, drawWithMax :: Tgraph -> Diagram B-drawWithMax :: Renderable (Path V2 Double) b =>-              Tgraph -> Diagram2D b+drawWithMax :: OKBackend b =>+              Tgraph -> Diagram b drawWithMax g =  (dmax # lc red # lw medium) <> dg where     vp = makeVP $ force g -- duplicates force to get the locations of vertices in the forced Tgraph     dg = restrictSmart g draw vp@@ -278,27 +204,21 @@     dmax = draw $ subVP vp (faces maxg)  -- |displaying the boundary of a Tgraph in lime (overlaid on the Tgraph drawn with f).--- ---  When a specific Backend B is in scope,  addBoundaryAfter :: (VPatch -> Diagram B) -> Tgraph -> Diagram B-addBoundaryAfter :: Renderable (Path V2 Double) b =>-                    (VPatch ->  Diagram2D b) -> Tgraph ->  Diagram2D b+addBoundaryAfter :: OKBackend b =>+                    (VPatch ->  Diagram b) -> Tgraph ->  Diagram b addBoundaryAfter f g =  (drawEdgesVP vp edges # lc lime) <> f vp where     vp = makeVP g     edges = graphBoundary g  -- |drawCommonFaces (g1,e1) (g2,e2) uses commonFaces (g1,e1) (g2,e2) to find the common faces -- and emphasizes them on the background g1.--- ---  When a specific Backend B is in scope, drawCommonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram B-drawCommonFaces :: Renderable (Path V2 Double) b =>-                   (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram2D b+drawCommonFaces :: OKBackend b =>+                   (Tgraph,Dedge) -> (Tgraph,Dedge) -> Diagram b drawCommonFaces (g1,e1) (g2,e2) = emphasizeFaces (commonFaces (g1,e1) (g2,e2)) g1  -- |emphasizeFaces fcs g emphasizes the given faces (that are in g) overlaid on the background g.--- ---  When a specific Backend B is in scope, emphasizeFaces:: [TileFace] -> Tgraph -> Diagram B-emphasizeFaces :: Renderable (Path V2 Double) b =>-                  [TileFace] -> Tgraph -> Diagram2D b+emphasizeFaces :: OKBackend b =>+                  [TileFace] -> Tgraph -> Diagram b emphasizeFaces fcs g =  (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where     vp = makeVP g     emphvp = subVP vp (fcs `intersect` faces g)@@ -317,17 +237,16 @@     compositions = composedFaceGroups changedInfo     newfaces = map fst compositions --- |compForce does a force then compose.--- It omits the check for connected, and no crossing boundaries because the argument is forced first.+-- |compForce is semantically equivalent to (compose . force), i.e it does a force then compose (raising an error if the force fails with an incorrect Tgraph).+-- However it is more efficient because it omits the check for connected, and no crossing boundaries. -- This relies on a proof that composition does not need to be checked for a forced Tgraph.--- It may raise an error if the initial force fails with an incorrect Tgraph.+-- (We also have a proof that the result must be a forced Tgraph when the initial force succeeds.) compForce:: Tgraph -> Tgraph compForce = uncheckedCompose . force          --- |allCompForce g produces a list of the non-null iterated forced compositions of g.+-- |allCompForce g produces a list of the non-null iterated (forced) compositions of force g. -- It will raise an error if the initial force fails with an incorrect Tgraph.--- The list will be [] if g is the emptyTgraph.--- The list will be [force g] if the first composition of force g is the emptyTgraph but g is not the emptyTgraph.+-- The list will be [] if g is the emptyTgraph, otherwise the list begins with force g (when the force succeeds). -- The definition relies on (1) a proof that the composition of a forced Tgraph is forced  and -- (2) a proof that composition does not need to be checked for a forced Tgraph. allCompForce:: Tgraph -> [Tgraph]@@ -340,44 +259,16 @@ maxCompForce g | nullGraph g = g                | otherwise = last $ allCompForce g ---- |force after a decomposition+{-+-- |force after a decomposition (raising an error if the force fails with an incorrect Tgraph) forceDecomp:: Tgraph -> Tgraph forceDecomp = force . decompose+-} --- | allForceDecomps g - produces an infinite list of forced decompositions of g+-- | allForceDecomps g - produces an infinite list (starting with g) +-- of forced decompositions of g (raising an error if a force fails with an incorrect Tgraph). allForceDecomps:: Tgraph -> [Tgraph]-allForceDecomps = iterate forceDecomp----- |emplaceChoices forces then maximally composes. At this top level it--- produces a list of forced choices for the unknowns.--- It then repeatedly forceDecomps back to the starting level to return a list of Tgraphs.--- This version relies on compForce theorem and related theorems-emplaceChoices:: Tgraph -> [Tgraph]-emplaceChoices g = emplaceChoices' $ force $ makeBoundaryState g---- |emplaceChoices' bd - assumes bd is forced. It maximally composes. At this top level it--- produces a list of forced choices for the unknowns.--- It then repeatedly forceDecomps back to the starting level to return a list of Tgraphs.--- This version relies on compForce theorem and related theorems-emplaceChoices':: BoundaryState -> [Tgraph]-emplaceChoices' startbd | nullGraph g' = recoverGraph <$> choices [startbd]-                   | otherwise = forceDecomp <$> emplaceChoices' (makeBoundaryState g')-  where   -   g' = compose $ recoverGraph startbd-   startunknowns = unknowns $ getDartWingInfo $ recoverGraph startbd-   choices [] = []-   choices (bd:bds) -        = case  startunknowns `intersect` unknowns (getDartWingInfo $ recoverGraph bd) of-             [] -> bd:choices bds-             (u:_) -> choices (atLeastOne (tryDartAndKiteForced (findDartLongForWing u bd) bd)++bds)-   findDartLongForWing v bd -        = case find isDart (facesAtBV bd v) of-            Just d -> longE d-            Nothing -> error $ "emplaceChoices': dart not found for dart wing vertex " ++ show v--+allForceDecomps = iterate (force . decompose)  {-| forcedBoundaryECovering g - produces a list of all boundary covers of force g, each of which extends force g to cover the entire boundary directed edges in (force g).@@ -455,7 +346,7 @@                     -- | tryDartAndKiteForced de b - returns the list of (2) results after adding a dart (respectively kite)--- to edge de a forcible b and then tries forcing. Each of the result is a Try.+-- to edge de of a Forcible b and then tries forcing. Each of the results is a Try. tryDartAndKiteForced:: Forcible a => Dedge -> a -> [Try a] tryDartAndKiteForced de b =      [ onFail ("tryDartAndKiteForced: Dart on edge: " ++ show de ++ "\n") $ @@ -465,7 +356,7 @@     ]  -- | tryDartAndKite de b - returns the list of (2) results after adding a dart (respectively kite)--- to edge de of a Forcible b. Each of the result is a Try.+-- to edge de of a Forcible b. Each of the results is a Try. tryDartAndKite:: Forcible a => Dedge -> a -> [Try a] tryDartAndKite de b =      [ onFail ("tryDartAndKite: Dart on edge: " ++ show de ++ "\n") $ @@ -476,10 +367,8 @@   -- | test function to draw a column of the list of graphs resulting from forcedBoundaryVCovering g.--- ---  When a specific Backend B is in scope,  drawFBCovering:: Tgraph -> Diagram B-drawFBCovering :: Renderable (Path V2 Double) b =>-                  Tgraph -> Diagram2D b+drawFBCovering :: OKBackend b =>+                  Tgraph -> Diagram b drawFBCovering g = lw ultraThin $ vsep 1 (draw <$> forcedBoundaryVCovering g)  -- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g.@@ -535,10 +424,8 @@ -- as calcultaed by e.g. empire1 or empire2 or empire2Plus. -- The diagram draws the underlying Tgraph, with the first tracked faces - the starting Tgraph shown red, and emphasising the second tracked faces -- - the common  faces.--- ---  When a specific Backend B is in scope, drawEmpire:: TrackedTgraph -> Diagram B-drawEmpire :: Renderable (Path V2 Double) b =>-               TrackedTgraph -> Diagram2D b+drawEmpire :: OKBackend b =>+               TrackedTgraph -> Diagram b drawEmpire =      drawTrackedTgraph  [ lw ultraThin . draw                        , lw thin . fillDK lightgrey lightgrey@@ -547,18 +434,14 @@  -- | showEmpire1 g - produces a diagram emphasising the common faces of all boundary covers of force g. -- This is drawn over one of the possible boundary covers and the faces of g are shown in red.--- ---  When a specific Backend B is in scope, showEmpire1:: Tgraph -> Diagram B-showEmpire1 :: Renderable (Path V2 Double) b =>-               Tgraph -> Diagram2D b+showEmpire1 :: OKBackend b =>+               Tgraph -> Diagram b showEmpire1 = drawEmpire . empire1  -- | showEmpire2 g - produces a diagram emphasising the common faces of a doubly-extended boundary cover of force g. -- This is drawn over one of the possible doubly-extended boundary covers and the faces of g are shown in red.--- ---  When a specific Backend B is in scope, showEmpire2:: Tgraph -> Diagram B-showEmpire2 :: Renderable (Path V2 Double) b =>-               Tgraph -> Diagram2D b+showEmpire2 :: OKBackend b =>+               Tgraph -> Diagram b showEmpire2 = drawEmpire . empire2  -- |superForce g - after forcing g this looks for single choice boundary edges.@@ -621,6 +504,11 @@                      id                      (faceForEdge e efmap)       +-- |Tries to create a new Tgraph from all faces with a boundary vertex in a Tgraph.+-- The resulting faces could have a crossing boundary and also could be disconnected if there is a hole in the starting Tgraph+-- so these conditions are checked for, producing a Try result.+tryBoundaryFaceGraph :: Tgraph -> Try Tgraph+tryBoundaryFaceGraph = tryConnectedNoCross . boundaryFaces . makeBoundaryState   -- | Returns a list of (looping) vertex trails for the boundary of a Tgraph.@@ -674,7 +562,6 @@     locateLoop pts = (`at` head pts) $ glueTrail $ trailFromVertices pts  - -- * TrackedTgraphs  {-|@@ -765,10 +652,8 @@     Each diagram is beneath later ones in the list, with the diagram for the untracked VPatch at the bottom.     The VPatches are all restrictions of a single VPatch for the Tgraph, so consistent.     (Any extra draw functions are applied to the VPatch for the main tgraph and the results placed atop.)- -    When a specific Backend B is in scope, drawTrackedTgraph:: [VPatch -> Diagram B] -> TrackedTgraph -> Diagram B -}-drawTrackedTgraph :: [VPatch -> Diagram2D b] -> TrackedTgraph -> Diagram2D b+drawTrackedTgraph :: OKBackend b => [VPatch -> Diagram b] -> TrackedTgraph -> Diagram b drawTrackedTgraph drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where     vp = makeVP (tgraph ttg)     untracked = vpFaces vp \\ concat (tracked ttg)@@ -778,12 +663,10 @@     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 before drawing-    (to ensure labels are not rotated).--    When a specific Backend B is in scope, drawTrackedTgraphRotated:: [VPatch -> Diagram B] -> Angle Double -> TrackedTgraph -> Diagram B+    The angle argument is used to rotate the common vertex location map (anticlockwise) before drawing+    to ensure labels are not rotated. -}-drawTrackedTgraphRotated :: [VPatch -> Diagram2D b] -> Angle Double -> TrackedTgraph -> Diagram2D b+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 = vpFaces vp \\ concat (tracked ttg)@@ -791,15 +674,13 @@  {-|     To draw a TrackedTgraph aligned.-    Same as drawTrackedTgraph but with additional vertex pair argument for the (x-axis) aligment.-    This is useful for when labels are being drawn.+    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--    When a specific Backend B is in scope, drawTrackedTgraphAligned:: [VPatch -> Diagram B] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram B -}-drawTrackedTgraphAligned :: [VPatch -> Diagram2D b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram2D b+drawTrackedTgraphAligned :: OKBackend b => [VPatch -> Diagram b] -> (Vertex,Vertex) -> TrackedTgraph -> Diagram b drawTrackedTgraphAligned drawList (a,b) ttg = mconcat $ reverse $ zipWith ($) drawList vpList where     vp = makeAlignedVP (a,b) (tgraph ttg)     untracked = vpFaces vp \\ concat (tracked ttg)

@@ -9,6 +9,7 @@ This module introduces Pieces and Patches for drawing finite tilings using Penrose's Dart and Kite tiles. It includes several primitives for drawing half tiles (Pieces), a class Drawable with instance Patch and commonly used operations for the Drawable class (draw, drawj, fillDK,..).+It also introduces class OKBackend to summarise constraints on a Backend for drawing. There is also a decompose operation for Patches (decompPatch) and sun and star example Patches. -} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -18,15 +19,15 @@ {-# LANGUAGE TypeOperators             #-} -- needed for type equality constraints ~  module TileLib -  ( -- * Pieces-    Piece+  ( OKBackend+  -- * Pieces+  , Piece   , joinVector   , ldart   , rdart   , lkite   , rkite     -- * Drawing Pieces-  , Diagram2D   , phi   , ttangle   , pieceEdges@@ -75,7 +76,9 @@   ) where  import Diagrams.Prelude+--import Diagrams.TwoD.Text (Text) -- now in CheckBackend +import CheckBackend import HalfTile  {-| Piece type for tile halves: Left Dart, Right Dart, Left Kite, Right Kite@@ -133,64 +136,60 @@ wholeTileEdges (LK v) = pieceEdges (LK v) ++ map negated (reverse $ pieceEdges (RK v)) wholeTileEdges (RK v) = wholeTileEdges (LK v) +{-+-- |Class OKBackend is a synonym for suitable constraints on a Backend+class (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b)+      => OKBackend b where {}+-} +{- -- | Abbreviation for 2D diagrams for any Backend b.+-- No longer used now class OKBackend is available type Diagram2D b = QDiagram b V2 Double Any+-}                  -- |drawing lines for the 2 non-join edges of a piece.--- --- When a specific Backend B is in scope, drawPiece:: Piece -> Diagram B-drawPiece :: Renderable (Path V2 Double) b =>-             Piece -> Diagram2D b+drawPiece :: OKBackend b =>+             Piece -> Diagram b drawPiece = strokeLine . fromOffsets . pieceEdges --- |same as drawPiece but with join edge added as dashed-line.--- --- When a specific Backend B is in scope, dashjPiece:: Piece -> Diagram B-dashjPiece :: Renderable (Path V2 Double) b =>-              Piece -> Diagram2D b+-- |same as drawPiece but with join edge added as faint dashed line.+dashjPiece :: OKBackend b =>+              Piece -> Diagram b dashjPiece piece = drawPiece piece <> dashjOnly piece  --- |draw join edge only (as dashed line).--- --- When a specific Backend B is in scope, dashjOnly:: Piece -> Diagram B-dashjOnly :: Renderable (Path V2 Double) b =>-             Piece -> Diagram2D b-dashjOnly piece = drawJoin piece # dashingN [0.003,0.003] 0 # lw ultraThin -- # lc grey +-- |draw join edge only (as faint dashed line).+dashjOnly :: OKBackend b =>+             Piece -> Diagram b+-- dashjOnly piece = drawJoin piece # dashingN [0.003,0.003] 0 # lw ultraThin -- # lc grey +dashjOnly piece = drawJoin piece # dashing [dashmeasure,dashmeasure] 0 # lw ultraThin+                  where dashmeasure = normalized 0.003  `atLeast` output 0.5  -- |same as drawPiece but with added join edge (also fillable as a loop).--- --- When a specific Backend B is in scope, drawRoundPiece:: Piece -> Diagram B-drawRoundPiece :: Renderable (Path V2 Double) b =>-                  Piece -> Diagram2D b+drawRoundPiece :: OKBackend b =>+                  Piece -> Diagram b drawRoundPiece = strokeLoop . closeLine . fromOffsets . pieceEdges  -- |draw join edge only.--- --- When a specific Backend B is in scope, drawJoin:: Piece -> Diagram B-drawJoin :: Renderable (Path V2 Double) b =>-            Piece -> Diagram2D b+drawJoin :: OKBackend b =>+            Piece -> Diagram b drawJoin piece = strokeLine $ fromOffsets [joinVector piece]  -- |fillOnlyPiece col piece - fills piece with colour col without drawing any lines.--- --- When a specific Backend B is in scope, fillOnlyPiece:: Colour Double -> Piece -> Diagram B-fillOnlyPiece :: Renderable (Path V2 Double) b =>-                 Colour Double -> Piece -> Diagram2D b+fillOnlyPiece :: OKBackend b =>+                 Colour Double -> Piece -> Diagram b fillOnlyPiece col piece  = drawRoundPiece piece # fc col # lw none  -- |fillPieceDK dcol kcol piece - draws and fills the half-tile piece -- with colour dcol for darts and kcol for kites. -- Note the order D K.--- --- When a specific Backend B is in scope, fillPieceDK:: Colour Double -> Colour Double -> Piece -> Diagram B-fillPieceDK :: Renderable (Path V2 Double) b =>-               Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram2D b+fillPieceDK :: OKBackend b =>+               Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram b fillPieceDK dcol kcol piece = drawPiece piece <> fillOnlyPiece col piece where     col = case piece of (LD _) -> dcol                         (RD _) -> dcol@@ -200,10 +199,8 @@ -- |fillMaybePieceDK d k piece - draws the half-tile piece and possibly fills as well: -- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol -- Nothing indicates no fill for either darts or kites or both.--- --- When a specific Backend B is in scope, fillMaybePieceDK:: Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram B-fillMaybePieceDK :: Renderable (Path V2 Double) b =>-                    Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram2D b+fillMaybePieceDK :: OKBackend b =>+                    Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram b fillMaybePieceDK d k piece = drawPiece piece <> filler where     maybeFill (Just c) = fillOnlyPiece c piece     maybeFill  Nothing = mempty@@ -216,10 +213,8 @@ -- |leftFillPieceDK dcol kcol pc fills the whole tile when pc is a left half-tile, -- darts are filled with colour dcol and kites with colour kcol. -- (Right half-tiles produce nothing, so whole tiles are not drawn twice).--- --- When a specific Backend B is in scope, leftFillPieceDK:: Colour Double -> Colour Double -> Piece -> Diagram B-leftFillPieceDK :: Renderable (Path V2 Double) b =>-                   Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram2D b+leftFillPieceDK :: OKBackend b =>+                   Colour Double -> Colour Double -> HalfTile (V2 Double) -> Diagram b leftFillPieceDK dcol kcol pc =      case pc of (LD _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc)  # fc dcol                 (LK _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc)  # fc kcol@@ -230,10 +225,8 @@ -- Half tiles are first drawn with dashed lines, then certain edges are overlayed to emphasise them. -- Half darts have the join edge emphasised in red, while -- Half kites have the long edge emphasised in black.--- --- When a specific Backend B is in scope, experiment:: Piece -> Diagram B-experiment:: Renderable (Path V2 Double) b =>-             Piece ->  Diagram2D b+experiment:: OKBackend b =>+             Piece ->  Diagram b experiment piece = emph piece <> (drawRoundPiece piece # dashingN [0.003,0.003] 0 # lw ultraThin)     --emph pc <> (drawRoundPiece pc # dashingO [1,2] 0 # lw ultraThin)   where emph pc = case pc of@@ -250,9 +243,8 @@  -- | A class for things that can be turned to diagrams when given a function to draw pieces. class Drawable a where--- When a specific Backend B is in scope,  drawWith :: Drawable a => (Piece -> Diagram B) -> a -> Diagram B-  drawWith :: Renderable (Path V2 Double) b =>-              (Piece ->  Diagram2D b) -> a ->  Diagram2D b+  drawWith :: OKBackend b =>+              (Piece ->  Diagram b) -> a ->  Diagram b  -- | Patches are drawable instance Drawable Patch where@@ -262,50 +254,38 @@       drawPatchWith pd = position . fmap (viewLoc . mapLoc pd)  -- | the main default case for drawing using drawPiece.--- --- When a specific Backend B is in scope, draw :: Drawable a => a -> Diagram B-draw :: (Drawable a, Renderable (Path V2 Double) b) =>-        a -> Diagram2D b+draw :: (Drawable a, OKBackend b) =>+        a -> Diagram b draw = drawWith drawPiece --- | alternative default case for drawing adding dashed lines for join edges.--- --- When a specific Backend B is in scope, drawj :: Drawable a => a -> Diagram B-drawj :: (Drawable a, Renderable (Path V2 Double) b) =>-         a -> Diagram2D b+-- | alternative default case for drawing, adding dashed lines for join edges.+drawj :: (Drawable a, OKBackend b) =>+         a -> Diagram b drawj = drawWith dashjPiece -fillDK, fillKD :: (Drawable a, Renderable (Path V2 Double) b) =>-                   Colour Double -> Colour Double -> a -> Diagram2D b+fillDK, fillKD :: (Drawable a, OKBackend b) =>+                   Colour Double -> Colour Double -> a -> Diagram b -- |fillDK dcol kcol a - draws and fills a with colour dcol for darts and kcol for kites. -- Note the order D K.--- --- When a specific Backend B is in scope, fillDK:: Drawable a => Colour Double -> Colour Double -> a -> Diagram B fillDK c1 c2 = drawWith (fillPieceDK c1 c2)  -- |fillKD kcol dcol a - draws and fills a with colour kcol for kites and dcol for darts.--- Note the order K D.--- --- When a specific Backend B is in scope, fillKD:: Drawable a => Colour Double -> Colour Double -> a -> Diagram B+-- Note the order D K. fillKD c1 c2 = fillDK c2 c1      -- |fillMaybeDK c1 c2 a - draws a and maybe fills as well: -- darts with dcol if d = Just dcol, kites with kcol if k = Just kcol -- Nothing indicates no fill for either darts or kites or both--- Note the order D K.--- --- When a specific Backend B is in scope, fillMaybeDK:: Drawable a => Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram B-fillMaybeDK :: (Drawable a, Renderable (Path V2 Double) b) =>-               Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram2D b+-- Note the order K D .+fillMaybeDK :: (Drawable a, OKBackend b) =>+               Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram b fillMaybeDK c1 c2 = drawWith (fillMaybePieceDK c1 c2)  -- |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). -- Note the order D K G.--- --- When a specific Backend B is in scope, colourDKG::  Drawable a => (Colour Double,Colour Double,Colour Double) -> a -> Diagram B-colourDKG :: (Drawable a, Renderable (Path V2 Double) b) =>-             (Colour Double,Colour Double,Colour Double) -> a -> Diagram2D b+colourDKG :: (Drawable a, OKBackend b) =>+             (Colour Double, Colour Double, Colour Double) -> a -> Diagram b colourDKG (c1,c2,c3) a = fillDK c1 c2 a # lc c3  -- |colourMaybeDKG (d,k,g) a - draws a and possibly fills as well:@@ -313,10 +293,8 @@ -- Nothing indicates no fill for either darts or kites or both -- The g argument is for grout - i.e the non-join edges round tiles. -- Edges are drawn with gcol if g  = Just gcol and not drawn if g = Nothing.--- --- When a specific Backend B is in scope, colourMaybeDKG:: Drawable a => (Maybe (Colour Double),  Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram B-colourMaybeDKG:: (Drawable a, Renderable (Path V2 Double) b) =>-                 (Maybe (Colour Double),  Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram2D b+colourMaybeDKG:: (Drawable a, OKBackend b) =>+                 (Maybe (Colour Double),  Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram b colourMaybeDKG (d,k,g) a = fillMaybeDK d k a # maybeGrout g where     maybeGrout (Just c) = lc c     maybeGrout Nothing = lw none@@ -427,33 +405,24 @@    -- * Diagrams of Patches  -- |diagram for sun6.--- --- When a specific Backend B is in scope, sun6Fig::Diagram B-sun6Fig :: Renderable (Path V2 Double) b => Diagram2D b+sun6Fig :: OKBackend b => Diagram b sun6Fig = draw sun6 # lw thin   -- |Colour filled using leftFillPieceDK. --- --- When a specific Backend B is in scope, leftFilledSun6::Diagram B-leftFilledSun6 :: Renderable (Path V2 Double) b => Diagram2D b+leftFilledSun6 :: OKBackend b => Diagram b leftFilledSun6 = drawWith (leftFillPieceDK red blue) sun6 # lw thin  -- |Colour filled using fillDK.--- --- When a specific Backend B is in scope, filledSun6::Diagram B-filledSun6 :: Renderable (Path V2 Double) b => Diagram2D b+filledSun6 :: OKBackend b => Diagram b filledSun6 = fillDK darkmagenta indigo sun6 # lw thin # lc gold  -- -- |rotations takes a list of integers (representing ttangles) for respective rotations of items in the second list (things to be rotated). -- This includes Diagrams, Patches, VPatches. -- The integer list can be shorter than the list of items - the remaining items are left unrotated. -- It will raise an error if the integer list is longer than the list of items to be rotated. -- (Rotations by an angle are anti-clockwise)- rotations :: (Transformable a, V a ~ V2, N a ~ Double) => [Int] -> [a] -> [a] rotations (n:ns) (d:ds) = rotate (ttangle n) d: rotations ns ds rotations [] ds = ds

@@ -0,0 +1,88 @@+{-|+Module      : Tgraph.Try+Description : Result types for partial functions+Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++Try is a synonym for Either String, which is used for results of partial operations+which return either Right something when defined or Left string when there is a problem+(where string is a failure report).+This is to allow computation to continue in failure cases without necessarily raising an error.+This module contains functions associated with Try results.+-}++module Try+  ( -- * Try - result types with failure reporting (for partial operations).+  Try+  , onFail+  , nothingFail+  , runTry+  , ifFail+  , isFail+  , concatFails+  , ignoreFails+  , atLeastOne+  , noFails+  ) where++import Data.Either(fromRight, lefts, rights, isLeft)+++-- | Try is a synonym for Either String.  Used for results of partial functions+-- which return either Right something when defined or Left string when there is a problem+-- where string is a failure report.+-- Note: Either String (and hence Try) is a monad, and this is used frequently for combining  partial operations.+type Try a = Either String a++-- | onFail s exp - inserts s at the front of failure report if exp fails with Left report+onFail:: String -> Try a -> Try a+onFail s = either (Left . (s++)) Right++-- | Converts a Maybe Result into a Try result by treating Nothing as a failure+-- (the string s is the failure report on failure).+-- Usually used as infix (exp `nothingFail` s)+nothingFail :: Maybe b -> String -> Try b+nothingFail a s = maybe (Left s) Right a++-- |Extract the (Right) result from a Try, producing an error if the Try is Left s.+-- The failure report is passed to error for an error report.+runTry:: Try a -> a+runTry = either error id++-- |ifFail a tr - extracts the (Right) result from tr but returning a if tr is Left s.+ifFail :: a -> Try a -> a+ifFail = fromRight ++-- |a try result is a failure if it is a Left+isFail:: Try a -> Bool+isFail = isLeft+   +-- |Combines a list of Trys into a single Try with failure overriding success.+-- It concatenates all failure reports if there are any and returns a single Left r.+-- Otherwise it produces Right rs where rs is the list of all (successful) results.+-- In particular, concatFails [] = Right []+concatFails:: [Try a] -> Try [a]+concatFails ls = case lefts ls of+                 [] -> Right $ rights ls+                 other -> Left $ mconcat other -- concatenates strings for single report++-- |Combines a list of Trys into a list of the successes, ignoring any failures.+-- In particular, ignoreFails [] = []+ignoreFails:: [Try a] -> [a]+ignoreFails = rights++-- | atLeastOne rs - returns the list of successful results if there are any, but fails with an error otherwise.+-- The error report will include the concatenated reports from the failures. +atLeastOne:: [Try a] -> [a]+atLeastOne [] = error "atLeastOne: applied to empty list.\n"+atLeastOne results = case ignoreFails results of+                 [] -> runTry $ onFail "atLeastOne: no successful results.\n" $ concatFails results+                 other -> other ++-- | noFails rs - returns the list of successes when all cases succeed, but fails with+-- an error and a concatenated failure report of all failures if there is at least one failure.+-- In particular, noFails [] = []+noFails:: [Try a] -> [a]+noFails = runTry . concatFails