PenroseKiteDart (empty) → 1.0.0

raw patch · 18 files changed

+5670/−0 lines, 18 filesdep +PenroseKiteDartdep +basedep +containerssetup-changed

Dependencies added: PenroseKiteDart, base, containers, diagrams-lib, hspec

Files

• CHANGELOG.md +108/−0
• LICENSE +30/−0
• PenroseKiteDart.cabal +81/−0
• README.md +90/−0
• Setup.hs +2/−0
• benchmark/Bench.hs +34/−0
• src/HalfTile.hs +99/−0
• src/PKD.hs +23/−0
• src/Tgraph/Compose.hs +230/−0
• src/Tgraph/Decompose.hs +73/−0
• src/Tgraph/Force.hs +1286/−0
• src/Tgraph/Prelude.hs +1235/−0
• src/Tgraph/Relabelling.hs +406/−0
• src/Tgraph/Try.hs +88/−0
• src/TgraphExamples.hs +459/−0
• src/Tgraphs.hs +810/−0
• src/TileLib.hs +481/−0
• test/Spec.hs +135/−0

@@ -0,0 +1,108 @@+# Revision history for PenroseKiteDart++## 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++Removed some examples in TgraphExamples and export of some auxiliary functions in Tgraph.Relabelling++## 0.9.1.0 -- 2024-03-12++Tgraph.Try as a separate module (instead of part of Tgraph.Prelude)+Added labelColourSize in DrawableLabelled with labelSize as special case+Changes to labelSize and line widths in some diagrams and drawing functions.+Removed labelSmall, labelLarge.+Added drawTrackedTgraphAligned.+Both restrictVP and relevantVP now check for missing locations.++## 0.8.0.2 -- 2024-02-25++Documentation changes only.++## 0.8.0.1 -- 2024-02-24++Fewer exported functions (Tgraph.Prelude, Tgraph.Relabelling), some renaming++## 0.7.0.0 -- 2024-02-18++Export of modules specified and changed (with more hiding)++## 0.6.0.0 -- 2024-02-17++Now as a standalone library++## 0.5.2.0 -- 2024-02-14++Added PKD (overall wrapper module).++## 0.5.1.0 -- 2024-02-13++Removed Tgraph.Convert (Conversions now included in Tgraph.Prelude)++## 0.5.0.0 -- 2024-01-26++(Removed ChosenBackEnd)+Only Main now imports a Backend (in preparation for creating library only).+Types have been generalised in modules that were previously using Backend B +e.g.++    pCompFig :: Diagram B++has become++    pCompFig :: Renderable (Path V2 Double) b => Diagram2D b+++## 0.4.0.0 -- 2023-10-27++Tgraphs now defined as newType++## 0.3.0.0 -- 2023-10-19++Modules: +    src/+      HalfTile.hs              -- (Half)Tile constructors - used by TileLib and Tgraph.Prelude+      ChosenBackend.hs         -- switch between e.g. SVG or PostScript+      TileLib.hs               -- Drawing of Pieces (and Patches)+      Tgraphs.hs               -- Main Graph Ops (imports and reexports all modules in Tgraph and adds extra ops)+      Tgraph/+         Tgraph.Prelude.hs     -- (imports and reexports HalfTile)+         Tgraph.Decompose.hs+         Tgraph.Compose.hs+         Tgraph.Force.hs+         Tgraph.Convert.hs     -- Converting Tgraphs to VPatches (and drawing both)+      TgraphExamples.hs++## 0.2.0.0 -- 2022-03-31++Restructured modules++Graphs and Graph ops are collected in Tgraphs.hs+Converting functions (and VPatch definition) are in Tgraph.Convert.hs+Graph example figures are in TgraphExamples.hs++Original underlying Tile ops and tile drawing are in TileLib.hs++## 0.2.0.0 -- 2021-06-18++New Graph representations and operations on graphs (decomposeG, composeG, force, and more)+Tools to convert to Patches for drawing etc and also intermediate VPatches, to display Vertex information.++Key changes to original TileLib.hs : ++1.  New versions of tile halves using polymorphic versions of constructors in HalfTile.hs+2.  Pieces (replaces Components)+3.  Redefining Patches as a list of Located Pieces (Pieces with point position rather than an offset vector)+4.  Making Patches transformable (so that scale, rotate, translate can be used instead of specialised versions)++also fillDK became fillDK' with new version of fillDK++## 0.1.0.0 -- 2021-03-16++First version.+Vector representations and drawing tools for tile components and patches plus decompose and inflate operations.+Described in <https://readerunner.wordpress.com/2021/03/20/diagrams-for-penrose-tiles/>

@@ -0,0 +1,30 @@+Copyright Chris Reade (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Chris Reade nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,81 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           PenroseKiteDart+version:        1.0.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+homepage:       https://github.com/chrisreade/PenroseKiteDart#readme+bug-reports:    https://github.com/chrisreade/PenroseKiteDart/issues+author:         Chris Reade+maintainer:     chrisreade@mac.com+copyright:      2021 Chris Reade+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/chrisreade/PenroseKiteDart++library+  exposed-modules:+      PKD+      HalfTile+      TileLib+      Tgraphs+      Tgraph.Prelude+      Tgraph.Decompose+      Tgraph.Compose+      Tgraph.Force+      Tgraph.Relabelling+      Tgraph.Try+      TgraphExamples+  other-modules:+      Paths_PenroseKiteDart+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , containers >=0.6.7 && <0.8+    , diagrams-lib >=1.4.6 && <1.5+  default-language: Haskell2010++test-suite PenroseKiteDart-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_PenroseKiteDart+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      PenroseKiteDart+    , base >=4.7 && <5+    , containers >=0.6.7 && <0.8+    , diagrams-lib >=1.4.6 && <1.5+    , hspec >=2.10.10 && <2.12+  default-language: Haskell2010++benchmark PenroseKiteDart-bench+  type: exitcode-stdio-1.0+  main-is: Bench.hs+  other-modules:+      Paths_PenroseKiteDart+  hs-source-dirs:+      benchmark+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      PenroseKiteDart+    , base >=4.7 && <5+    , containers >=0.6.7 && <0.8+    , diagrams-lib >=1.4.6 && <1.5+  default-language: Haskell2010

@@ -0,0 +1,90 @@+# PenroseKiteDart++Author: Chris Reade++March 2021 - 2024++See LICENSE file++## Penrose Kites and Darts++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.++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.++## Using the Package++You will need the Haskell Diagrams package+to be installed as well as this package (PenroseKiteDart). (See [Haskell Diagrams](https://diagrams.github.io)).+Once installed, a Main.hs module to produce diagrams should import a chosen backend for Diagrams such as the default (SVG)+along with Diagrams.Prelude++    module Main (main) where+    +    import Diagrams.Backend.SVG.CmdLine+    import Diagrams.Prelude++plus (for Penrose Kite and Dart tilings)++    import PKD++and optionally++    import TgraphExamples++Then to ouput someExample figure++    fig::Diagram B+    fig = someExample++    main :: IO ()+    main = mainWith fig++When the code is executed it will generate an SVG file.+(See the Haskell Diagrams package for more details on producing diagrams.)++## Tgraphs to Describe Finite Tilings++Tile Graphs (`Tgraph`s) use a simple planar graph representation for finite patches of tiles.+A `Tgraph` is made from a list of faces with type `TileFace` each of which is a half-dart or a half-kite.+Each `TileFace` is thus a triangle with three positive Int vertices and a constructor+`LD` (left dart), `RD` (right dart), `LK` (left kite), `RK` (right kite).++For example a fool consists of two kites and a dart (= 4 half kites and 2 half darts):++    fool :: Tgraph+    fool = makeTgraph [RD (1,2,3),LD (1,3,4)   -- right and left dart+                      ,LK (5,3,2),RK (5,2,7)   -- left and right kite+                      ,RK (5,4,3),LK (5,6,4)   -- right and left kite+                      ]++The function++    makeTgraph :: [TileFace] -> Tgraph++performs checks to make sure the tiling is legal, raising an error if there is a problem.+To produce a diagram, we simply draw the `Tgraph`++    foolFigure :: Diagram B+    foolFigure = labelled draw fool+++## Modules++Module `PKD` is the main module which imports and rexports `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.+`HalfTile` is imported and re-exported by `Tgraph.Prelude` -  (with the constructors `LD`,`RD`,`LK`,`RK`).++## 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/)++

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,34 @@+import Tgraphs+import TgraphExamples+import TileLib (draw)+import Diagrams.Prelude++main :: IO ()+main = +  do putStrLn $ "Number of faces of a " ++ sn ++ " times decomposed King is " +                       ++ show (length (faces kD))+     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))++{-+     putStrLn $ "Number of faces of reforced force (" ++ sn ++ " times decomposed King) is " +                            ++ show (length (faces rcfkD))+-}++  where+       sn = show n+       n = 4+       kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n+       fkD ={-# SCC "forcing" #-} force kD+       cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate compose fkD++       fig = {-# SCC "drawing" #-} draw fkD+       w = width fig++

@@ -0,0 +1,99 @@+{-|+Module      : HalfTile+Description : Introducing a generic type for half tiles of darts and kites+Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++-}+{-# LANGUAGE TypeFamilies              #-} -- needed for Transformable Instance+{-# LANGUAGE FlexibleInstances         #-} -- needed for Transformable Instance++module HalfTile +  ( HalfTile(..)+  , tileRep+  , isLD+  , isRD+  , isLK+  , isRK+  , isDart+  , isKite+  , HalfTileLabel+  , tileLabel+  , isMatched+  ) where+    +import Diagrams.Prelude (V,N, Transformable(..)) -- needed to make HalfTile a Transformable when a is Transformable++{-|+Representing Half Tile Pieces Polymorphicly.+Common code for both graphs and vector representations of tilings. +For Pieces - rep is V2 Double+For TileFaces (in Tgraphs) rep is (Vertex,Vertex,Vertex)+-}+data HalfTile rep = LD rep -- ^ Left Dart+                  | RD rep -- ^ Right Dart+                  | LK rep -- ^ Left Kite+                  | RK rep -- ^ Right Kite+                  deriving (Show,Eq)++-- | Note this ignores the tileLabels when comparing.+-- However we should never have 2 different HalfTiles with the same rep+instance Ord rep => Ord (HalfTile rep) where+    compare t1 t2 = compare (tileRep t1) (tileRep t2)++-- |Make Halftile a Functor+instance Functor HalfTile where+    fmap f (LD rep) = LD (f rep)+    fmap f (RD rep) = RD (f rep)+    fmap f (LK rep) = LK (f rep)+    fmap f (RK rep) = RK (f rep)++-- |Needed for Transformable instance of HalfTile - requires TypeFamilies+type instance N (HalfTile a) = N a+-- |Needed for Transformable instance of HalfTile - requires TypeFamilies+type instance V (HalfTile a) = V a+-- |HalfTile inherits Transformable  - Requires FlexibleInstances+instance Transformable a => Transformable (HalfTile a) where+    transform t = fmap (transform t)+++++++{-# INLINE tileRep #-}+-- |return the representation of a half-tile+tileRep:: HalfTile rep -> rep+tileRep (LD r) = r+tileRep (RD r) = r+tileRep (LK r) = r+tileRep (RK r) = r++-- |half-tile predicate+isLD,isRD,isLK,isRK,isDart,isKite :: HalfTile rep -> Bool+isLD (LD _) = True+isLD _      = False+isRD (RD _) = True+isRD _      = False+isLK (LK _) = True+isLK _      = False+isRK (RK _) = True+isRK _      = False+isDart x = isLD x || isRD x+isKite x = isLK x || isRK x++-- |By having () as the half tile representation we treat the constructors as just labels+type HalfTileLabel = HalfTile ()+-- |convert a half tile to its label (HalfTileLabel can be compared for equality)+tileLabel :: HalfTile a -> HalfTileLabel+tileLabel = fmap $ const () -- functor HalfTile++-- | isMatched t1 t2 is True if t1 and t2 have the same HalfTileLabel +-- (i.e. use the same constructor - both LD or both RD or both LK or both RK)+isMatched :: HalfTile rep1 -> HalfTile rep2 -> Bool+isMatched t1 t2 = tileLabel t1 == tileLabel t2+++

@@ -0,0 +1,23 @@+{-|+Module      : PKD+Description : A wrapper module including Tgraphs and TileLib+Copyright   : (c) Chris Reade, 2024+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++This is the main module to import Tgraphs and TileLib (which includes Halftile) modules.+-}+-- {-# LANGUAGE NoMonomorphismRestriction #-}+-- {-# LANGUAGE FlexibleContexts          #-}+-- {-# LANGUAGE TypeFamilies              #-}+-- {-# LANGUAGE FlexibleInstances         #-} -- needed for Drawable Patch+-- {-# LANGUAGE TypeOperators             #-} -- needed for type equality constraints ~++module PKD ( module Tgraphs+           , module TileLib+           ) where++import Tgraphs+import TileLib+

@@ -0,0 +1,230 @@+{-|+Module      : Tgraph.Compose+Description : A compose operation for Tgraphs+Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++This module includes the main composition operations compose, partCompose, tryPartCompose but also exposes +getDartWingInfo (and type DartWingInfo) and composedFaceGroups for debugging and experimenting.+-}+module Tgraph.Compose +  ( compose+  , partCompose+  , tryPartCompose+  , uncheckedCompose+  , uncheckedPartCompose+  , partComposeFaces+  , composedFaces+  , DartWingInfo(..)+  , getDartWingInfo+  , composedFaceGroups+  ) where++import Data.List ((\\), find, foldl',nub)+import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!))+import Data.Maybe (mapMaybe)++import Tgraph.Prelude++{-------------------------------------------------------------------------+***************************************************************************              +COMPOSING compose, partCompose, tryPartCompose, uncheckedPartCompose+***************************************************************************+---------------------------------------------------------------------------}++-- |The main compose function which simply drops the remainder faces from partCompose to return just+-- the composed Tgraph.  It will raise an error if the result is not a valid Tgraph+-- (i.e. if it fails the connectedness, no crossing boundary check)+compose:: Tgraph -> Tgraph+compose = snd . partCompose++-- |This does the same as compose but without checks for connectedness and no crossing boundaries in the result.+-- It is intended for use on forced Tgraphs where we have a proof that the checks are not needed.+uncheckedCompose:: Tgraph -> Tgraph+uncheckedCompose = snd . uncheckedPartCompose++-- |partCompose g produces a pair consisting of remainder faces (faces from g which will not compose) +-- and a composed Tgraph.+-- It checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails.+partCompose:: Tgraph -> ([TileFace],Tgraph)+partCompose g = runTry $ onFail "partCompose:\n" $ tryPartCompose g++-- |tryPartCompose g tries to produce a Tgraph by composing faces which uniquely compose in g,+-- It checks the resulting new faces for connectedness and no crossing boundaries.+-- If the check is OK it produces Right (remainder, g') where g' is the composed Tgraph and remainder is a list+-- of faces from g which will not compose.  If the check fails it produces Left s where s is a failure report.+tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph)+tryPartCompose g = +  do let (remainder,newFaces) = partComposeFaces g+     checked <- onFail "tryPartCompose:/n" $ tryConnectedNoCross newFaces+     return (remainder,checked)++-- |uncheckedPartCompose g produces a pair of the remainder faces (faces from g which will not compose)+-- and a Tgraph made from the composed faces without checking that the Tgraph is valid.+-- I.e. it does NOT check the composition Tgraph for connectedness and no crossing boundaries.+-- This is intended for use when we know the check is not needed (e.g. when g is forced).+uncheckedPartCompose:: Tgraph -> ([TileFace],Tgraph)+uncheckedPartCompose g = (remainder, makeUncheckedTgraph newfaces) where+  (remainder,newfaces) = partComposeFaces g++-- |partComposeFaces produces a pair of the remainder faces (faces from the original which will not compose)+-- and the composed faces (which may or may not constitute faces of a valid Tgraph).+partComposeFaces:: Tgraph -> ([TileFace],[TileFace])+partComposeFaces g = (remainder,newfaces) where+  compositions = composedFaceGroups $ getDartWingInfo g+  newfaces = map fst compositions+  groups = map snd compositions+  remainder = faces g \\ concat groups++-- |composedFaces g produces the composed faces of g (which may or may not constitute faces of a valid Tgraph).+composedFaces:: Tgraph -> [TileFace]+composedFaces = snd . partComposeFaces+++-- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph.+-- It includes a faceMap from dart wings to faces at that vertex.+data DartWingInfo =  DartWingInfo +     { largeKiteCentres  :: [Vertex]+     , largeDartBases  :: [Vertex]+     , unknowns :: [Vertex]+     , faceMap :: VMap.IntMap [TileFace] +     } deriving Show++-- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing,+-- returning as DartWingInfo.+getDartWingInfo:: Tgraph -> DartWingInfo+getDartWingInfo g =  DartWingInfo {largeKiteCentres = allKcs, largeDartBases = allDbs, unknowns = allUnks, faceMap = dwFMap} where+  drts  = darts g+  dwFMap = vertexFacesMap (nub $ fmap wingV drts) (faces g)+  (allKcs,allDbs,allUnks) = foldl' processD ([],[],[]) drts  +-- kcs = kite centres of larger kites,+-- dbs = dart bases of larger darts,+-- unks = unclassified dart wing tips+-- gps is a mapping of dart wing tips to the group of faces found at that vertex+  processD (kcs, dbs, unks) rd@(RD (orig, w, _)) = -- classify wing tip w+    if w `elem` kcs || w `elem` dbs then (kcs, dbs, unks) else-- already classified+    let+        fcs = dwFMap VMap.! w -- faces at w+--        Just fcs = VMap.lookup w dwFMap -- faces at w+    in+        if length fcs ==1 then (kcs, dbs, w:unks) else -- lone dart wing => unknown+        if w `elem` fmap originV (filter isKite fcs) then (kcs,w:dbs,unks) else +                -- wing is a half kite origin => largeDartBases+        if (w,orig) `elem` fmap longE (filter isLD fcs) then (w:kcs,dbs,unks) else +                -- long edge rd shared with an ld => largeKiteCentres+        case findFarK rd fcs of+        Nothing -> (kcs,dbs,w:unks) -- unknown if incomplete kite attached to short edge of rd+        Just rk@(RK _)  ->  +            case find (matchingShortE rk) fcs of+            Just (LK _) -> (w:kcs,dbs,unks) -- short edge rk shared with an lk => largeKiteCentres+            Just (LD _) -> (kcs,w:dbs,unks) -- short edge rk shared with an ld => largeDartBases+            _ -> let +                     newfcs = filter (isAtV (wingV rk)) (faces g)   -- faces at rk wing    +                 in+                 case find (matchingLongE rk) newfcs of  -- short edge rk has nothing attached+                 Nothing -> (kcs,dbs,w:unks)  -- long edge of rk has nothing attached => unknown+                 Just (LD _) -> (w:kcs,dbs,unks) -- long edge rk shared with ld => largeKiteCentres+                 Just lk@(LK _) ->               -- long edge rk shared with lk+                      case find (matchingShortE lk) newfcs of+                      Just (RK _) -> (w:kcs,dbs,unks)+                              -- short edge of this lk shared with another rk => largeKiteCentres+                      Just (RD _) -> (kcs,w:dbs,unks) +                              -- short edge of this lk shared with rd => largeDartBases+                      _ -> (kcs,dbs,w:unks) +                 Just _ ->  error "getDartWingInfo: illegal case for matchingLongE of a right kite"+                              -- short edge of this lk has nothing attached => unknown+        Just _ -> error "getDartWingInfo: non-kite returned by findFarK"++  processD (kcs, dbs, unks) ld@(LD (orig, _, w)) = -- classify wing tip w+    if w `elem` kcs || w `elem` dbs then (kcs, dbs, unks) else  -- already classified+    let+        fcs = dwFMap VMap.! w -- faces at w+    in+        if length fcs ==1 then (kcs, dbs, w:unks) else -- lone dart wing => unknown+        if w `elem` fmap originV (filter isKite fcs) then (kcs,w:dbs,unks) else+                   -- wing is a half kite origin => nodeDB+        if (w,orig) `elem` fmap longE (filter isRD fcs) then (w:kcs,dbs,unks) else+                   -- long edge ld shared with an rd => nodeKC+        case findFarK ld fcs of+          Nothing -> (kcs,dbs,w:unks) -- unknown if incomplete kite attached to short edge of ld+          Just lk@(LK _)  ->  +            case find (matchingShortE lk) fcs of+            Just (RK _) -> (w:kcs,dbs,unks) -- short edge lk shared with an rk => largeKiteCentres+            Just (RD _) -> (kcs,w:dbs,unks) -- short edge lk shared with an rd => largeDartBases+            _ -> let +                     newfcs = filter (isAtV (wingV lk)) (faces g)   -- faces at lk wing  +                 in+                 case find (matchingLongE lk) newfcs of -- short edge lk has nothing attached+                 Nothing -> (kcs,dbs,w:unks)  -- long edge of lk has nothing attached => unknown+                 Just (RD _) -> (w:kcs,dbs,unks) -- long edge lk shared with rd => largeKiteCentres+                 Just rk@(RK _) ->               -- long edge lk is shared with an rk+                     case find (matchingShortE rk) newfcs of+                     Just (LK _) -> (w:kcs,dbs,unks)+                             -- short edge of this rk shared with another lk => largeKiteCentres+                     Just (LD _) -> (kcs,w:dbs,unks)+                             -- short edge of this rk shared with ld => largeDartBases+                     _ -> (kcs,dbs,w:unks) -- short edge of this rk has nothing attached => unknown+                 Just _ ->  error "getDartWingInfo: illegal case for matchingLongE of a left kite"++          Just _ -> error "getDartWingInfo: non-kite returned by findFarK"++  processD _ _ = error "getDartWingInfo: processD applied to non-dart"++    -- find the two kite halves below a dart half, return the half kite furthest away (not attached to dart).+    -- Returns a Maybe.   rd produces an rk (or Nothing) ld produces an lk (or Nothing)+  findFarK :: TileFace -> [TileFace] -> Maybe TileFace+  findFarK rd@(RD _) fcs = do lk <- find (matchingShortE rd) (filter isLK fcs)+                              find (matchingJoinE lk) (filter isRK fcs)+  findFarK ld@(LD _) fcs = do rk <- find (matchingShortE ld) (filter isRK fcs)+                              find (matchingJoinE rk)  (filter isLK fcs)+  findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face"++-- | Auxiliary function for uncheckedPartCompose.+-- Creates a list of new composed faces, each paired with a list of old faces (components of the new face)+-- using dart wing information.+composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])]+composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where++    faceGroupRDs = fmap (\gp -> (makeRD gp,gp)) groupRDs +    groupRDs = mapMaybe groupRD (largeDartBases dwInfo)+    makeRD [rd,lk] = RD(originV lk, originV rd, oppV lk) +    makeRD _       = error "composedFaceGroups: RD case"+    groupRD v = do  fcs <- VMap.lookup v (faceMap dwInfo)+                    rd <- find isRD fcs+                    lk <- find (matchingShortE rd) fcs+                    return [rd,lk]++    faceGroupLDs = fmap (\gp -> (makeLD gp,gp)) groupLDs +    groupLDs = mapMaybe groupLD (largeDartBases dwInfo) +    makeLD [ld,rk] = LD(originV rk, oppV rk, originV ld)+    makeLD _       = error "composedFaceGroups: LD case"+    groupLD v = do  fcs <- VMap.lookup v (faceMap dwInfo)+                    ld <- find isLD fcs+                    rk <- find (matchingShortE ld) fcs+                    return [ld,rk]++    faceGroupRKs = fmap (\gp -> (makeRK gp,gp)) groupRKs +    groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) +    makeRK [rd,_,rk] = RK(originV rd, wingV rk, originV rk)+    makeRK _         = error "composedFaceGroups: RK case"+    groupRK v = do  fcs <- VMap.lookup v (faceMap dwInfo)+                    rd <- find isRD fcs+                    lk <- find (matchingShortE rd) fcs+                    rk <- find (matchingJoinE lk) fcs+                    return [rd,lk,rk]++    faceGroupLKs = fmap (\gp -> (makeLK gp,gp)) groupLKs +    groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) +    makeLK [ld,_,lk] = LK(originV ld, originV lk, wingV lk)+    makeLK _         = error "composedFaceGroups: LK case"+    groupLK v = do  fcs <- VMap.lookup v (faceMap dwInfo)+                    ld <- find isLD fcs+                    rk <- find (matchingShortE ld) fcs+                    lk <- find (matchingJoinE rk) fcs+                    return [ld,rk,lk]++++

@@ -0,0 +1,73 @@+{-|+Module      : Tgraph.Decompose+Description : A decompose operation for Tgraphs+Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++This module defines decompose and decompositions for Tgraphs, but also exposes +two auxiliary functions for debugging and experimenting.+-}+module Tgraph.Decompose+  ( decompose+  , decompositions+  , phiVMap+  , decompFace+  ) where++import qualified Data.Map.Strict as Map (Map, (!), fromList)+import Data.List(sort)++import Tgraph.Prelude++++{------------------------------- +**************************************+DECOMPOSING - decompose+**************************************+----------------------------------}+++-- |Decompose a Tgraph.+decompose :: Tgraph -> Tgraph+decompose g = makeUncheckedTgraph newFaces where+    newFaces = concatMap (decompFace (phiVMap g)) (faces g)++-- |phiVMap g produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in g.+-- Both (a,b) and (b,a) get the same new vertex number.+-- (Sort is used to fix order of assigned numbers).+-- (Exported for use in TrackedTgraphs in Tgraphs module).++phiVMap :: Tgraph -> Map.Map Dedge Vertex+phiVMap g = edgeVMap where+  phiReps = sort [(a,b) | (a,b) <- phiEdges g, a<b]+  newVs = [v+1..v+n]+  n = length phiReps+  v = maxV g+  edgeVMap = Map.fromList $ zip phiReps newVs ++ zip (fmap reverseD phiReps) newVs ++-- |Decompose a face producing new faces. +-- This requires an edge to vertex map to get a unique new vertex assigned to each phi edge+-- (as created by phiVMap).+-- (Exported for use in TrackedTgraphs in Tgraphs module).+decompFace:: Map.Map Dedge Vertex -> TileFace -> [TileFace]+decompFace newVFor fc = case fc of+      RK(a,b,c) -> [RK(c,x,b), LK(c,y,x), RD(a,x,y)]+        where x = (Map.!) newVFor (a,b)+              y = (Map.!) newVFor (c,a)+      LK(a,b,c) -> [LK(b,c,y), RK(b,y,x), LD(a,x,y)]+        where x = (Map.!) newVFor (a,b)+              y = (Map.!) newVFor (c,a)       +      RD(a,b,c) -> [LK(a,x,c), RD(b,c,x)]+        where x = (Map.!) newVFor (a,b)+      LD(a,b,c) -> [RK(a,b,x), LD(c,x,b)]+        where x = (Map.!) newVFor (a,c)+   +-- |infinite list of decompositions of a Tgraph     +decompositions :: Tgraph -> [Tgraph]+decompositions = iterate decompose+++

@@ -0,0 +1,1286 @@+{-|+Module      : Tgraph.Force+Description : The force functions for Tgraphs +Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++This module includes force and tryForce plus related operations for testing and experimenting+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+  , tryForceWith+  , tryStepForceWith+  , tryFSOp+  , tryForce+  , force+  , wholeTiles+  , forceWith+  , tryInitFS+  , initFS+  , tryStepForce+  , stepForce+  , tryChangeBoundary+    -- *  Force Related Functions+  , addHalfKite+  , tryAddHalfKite+  , addHalfDart+  , tryAddHalfDart+    -- *  Specialised forcing operations (used for inspecting steps)+  , tryOneStepWith+  , tryOneStepF+    -- *  Updating BoundaryState and ForceState after a single force step+  , BoundaryChange(..)+  , 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+  , recalibratingForce+    -- *  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+  , wholeTileUpdates+  , incompleteHalves+  , aceKiteUpdates+  , nonKDarts+  , queenOrKingUpdates+  , kitesWingDartOrigin+  , deuceDartUpdates+  , kiteGaps+  , jackDartUpdates+  , noTouchingDart+  , sunStarUpdates+  , almostSunStar+  , jackKiteUpdates+  , jackMissingKite+  , kingDartUpdates+  , kingMissingThirdDart+  , queenDartUpdates+  , queenMissingDarts+  , queenKiteUpdates+  , queenMissingKite+    -- *  Six Update Checkers+  , completeHalf+  , addKiteShortE+  , addDartShortE+  , completeSunStar+  , addKiteLongE+  , addDartLongE+{-+  , anglesForJoinRD+  , anglesForJoinLD+  , anglesForJoinRK+  , anglesForJoinLK+  , anglesForLongLD+  , anglesForLongRD+  , anglesForLongRK+  , anglesForLongLK+  , anglesForShortLD+  , anglesForShortRD+  , anglesForShortLK+  , anglesForShortRK+-}+--   , inspectBDedge+    -- *  Auxiliary Functions for adding faces: externalAngle and tryFindThirdV. $Additions+  , tryFindThirdV+  , externalAngle+{-+  , intAngleAt+  , faceIntAngles+-}+  )  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, (!))+            -- used for BoundaryState locations AND faces at boundary vertices+import Diagrams.Prelude (Point, V2) -- necessary for touch check (touchCheck) used in tryUnsafeUpdate +-- import Tgraph.Convert(touching, locateVertices, addVPoint)+import Tgraph.Prelude++{-+***************************************************************************   +Efficient FORCING with +  BoundaryState, ForceState +  Touching Vertex Check+  Incremented Update Maps+***************************************************************************+-}++++{-------------------------+*************************             +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 +a mapping of boundary vertices to their incident faces, plus+a mapping of boundary vertices to positions (using Tgraph.Prelude.locateVertices).+It also keeps track of all the faces+and the next vertex label to be used when adding a new vertex.+-}+data BoundaryState +   = BoundaryState+     { boundary:: [Dedge]  -- ^ boundary directed edges (face on LHS, exterior on RHS)+     , bvFacesMap:: VertexMap [TileFace] -- ^faces at each boundary vertex.+     , bvLocMap:: VertexMap (Point V2 Double)  -- ^ position of each boundary vertex.+     , allFaces:: [TileFace] -- ^ all the tile faces+     , nextVertex:: Vertex -- ^ next vertex number+     } deriving (Show)++-- |Calculates BoundaryState information from a Tgraph+-- also checks for no crossing boundaries as these could cause difficult to trace errors in forcing.+makeBoundaryState:: Tgraph -> BoundaryState+makeBoundaryState g = +  let bdes = graphBoundary g+      bvs = fmap fst bdes -- (fmap snd bdes would also do) for all boundary vertices+      bvLocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ faces g+  in if not $ null $ crossingVertices bdes then error $ "makeBoundaryState: found crossing boundary in faces:\n"++show (faces g)++"\n"+     else+      BoundaryState+      { boundary = bdes+      , bvFacesMap = vertexFacesMap bvs (faces g)+      , bvLocMap = bvLocs +      , allFaces = faces g+      , nextVertex = 1+ maxV g+      }+      +-- |Converts a BoundaryState back to a Tgraph+recoverGraph:: BoundaryState -> Tgraph+recoverGraph bd = makeUncheckedTgraph (allFaces bd)++-- |changeVFMap f vfmap - adds f to the list of faces associated with each v in f, returning a revised vfmap+changeVFMap::  TileFace -> VertexMap [TileFace] -> VertexMap [TileFace]+changeVFMap f vfm = foldl' insertf vfm (faceVList f) where+   insertf vmap v = VMap.alter consf v vmap+   consf Nothing = Just [f]+   consf (Just fs) = Just (f:fs)+   +-- |facesAtBV bd v - returns the faces found at v (which must be a boundary vertex)+facesAtBV:: BoundaryState -> Vertex -> [TileFace]+facesAtBV bd v = case VMap.lookup v (bvFacesMap bd) of+  Just fcs -> fcs+  Nothing -> error $ "facesAtBV: Not a boundary vertex? No faces found at " ++ show v ++ "\n"++-- |return a list of faces which have a boundary vertex from a BoundaryState+boundaryFaces :: BoundaryState -> [TileFace]+boundaryFaces bd = nub $ concatMap (facesAtBV bd) bvs where+    bvs = fmap fst $ boundary bd+-- 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.+data Update = SafeUpdate TileFace +            | UnsafeUpdate (Vertex -> TileFace)++-- | 0 is used as a dummy variable to show unsafe updates (to display the function explicitly)+instance Show Update where+    show (SafeUpdate f) = "SafeUpdate (" ++ show f ++ ")"+    show (UnsafeUpdate mf) = "UnsafeUpdate (\0 -> " ++ show (mf 0)++ ")"+    +-- |UpdateMap: partial map associating updates with (some) boundary directed edges.+-- (Any boundary directed edge will have the opposite direction in some face.)+type UpdateMap = Map.Map Dedge Update++-- |ForceState: The force state records information between executing single face updates during forcing+-- (a BoundaryState and an UpdateMap).+data ForceState = ForceState +                   { boundaryState:: BoundaryState+                   , updateMap:: UpdateMap +                   }++{-|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.  +Each forcing rule has a particular UpdateGenerator,+but they can also be combined (e.g in sequence - allUGenerator or otherwise - defaultAllUGenerator).+-}+type UpdateGenerator = BoundaryState -> [Dedge] -> Try UpdateMap++++-- | Forcible class has operations to (indirectly) implement forcing and single step forcing+-- (tryForceWith, tryStepForceWith) for any Forcible. The class operations are more general to allow for other+-- force related operations to be generalised for use on any Forcible.+-- Both tryForceWith and tryStepForceWith are implemented using tryFSOpWith, and+-- tryAddHalfKite and tryAddHalfDart are implemented using tryChangeBoundaryWith.+--+-- To improve performance of a sequence of force related operations, express each as a+-- ForceState -> Try ForceState, then use (<=<) or (>=>) to combine and pass to tryFSOpWith.+-- This ensures there are no unnecessary conversions between steps.+class Forcible a where+    -- | tryFSOpWith (try ForseState Operation with) when given an update generator, generalises a (try) ForceState operation to a (try) Forcible operation.+    -- The update generator is only used to initialise a ForceState when there is not one+    -- already available (i.e not used when the Forcible is a ForceState)+    tryFSOpWith :: UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a+    -- | tryInitFSWith (try initialising a ForceState with) when given an update generator tries to create an initial ForceState (ready for forcing) from a Forcible.+    -- Again, the update generator is not used when the instance is a ForceState.+    tryInitFSWith :: UpdateGenerator -> a -> Try ForceState+    -- | tryChangeBoundaryWith when given an update generator, converts a (try) BoundaryState changing operation to a (try) Forcible operation.+    -- The update generator is only used when the instance is a ForceState (to revise the update map in the result).+    tryChangeBoundaryWith :: UpdateGenerator -> (BoundaryState -> Try BoundaryChange) -> a -> Try a+{-+    -- | construct or recover the BoundaryState from a Forcible+    getBoundaryState :: a -> BoundaryState+-}++-- |ForceStates are Forcible+instance Forcible ForceState where+    tryFSOpWith _ = id  -- update generator not used+    tryInitFSWith _  = return  -- update generator not used+    tryChangeBoundaryWith ugen f fs = do+        bdC <- f (boundaryState fs)+        tryReviseFSWith ugen bdC fs+--    getBoundaryState = boundaryState+    +-- | BoundaryStates are Forcible    +instance Forcible BoundaryState where+    tryFSOpWith ugen f bd = do+        fs <- tryInitFSWith ugen bd+        fs' <- f fs+        return $ boundaryState fs'+    tryInitFSWith ugen bd = do+        umap <- ugen bd (boundary bd)+        return $ ForceState { boundaryState = bd , updateMap = umap }+    tryChangeBoundaryWith _ f bd = do -- update generator not used+        bdC <- f bd+        return $ newBoundaryState bdC+--    getBoundaryState = id++-- | Tgraphs are Forcible    +instance Forcible Tgraph where+    tryFSOpWith ugen f g = recoverGraph <$> tryFSOpWith ugen f (makeBoundaryState g)+    tryInitFSWith ugen g = tryInitFSWith ugen (makeBoundaryState g)+    tryChangeBoundaryWith ugen f g = -- update generator not used+        recoverGraph <$> tryChangeBoundaryWith ugen f (makeBoundaryState g)+--    getBoundaryState = makeBoundaryState+++-- | try forcing using a given UpdateGenerator.+--  tryForceWith uGen fs - recursively 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+--    tryForceStateWith :: UpdateGenerator -> ForceState -> Try ForceState+    tryForceStateWith uGen = retry where+      retry fs = case findSafeUpdate (updateMap fs) of+                 Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u+                              fs' <- tryReviseFSWith uGen bdChange fs+                              retry fs'+                 _  -> do maybeBdC <- tryUnsafes fs+                          case maybeBdC of+                            Nothing  -> Right fs -- no more updates+                         -- 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+      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.+-- 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++-- |The main force function using defaultAllUGen representing all 10 rules for updates.+-- This raises an error on discovering a stuck/incorrect Forcible.+force:: Forcible a => a -> a+force = runTry . tryForce++-- |special case of forcing only half tiles to whole tiles+wholeTiles:: Forcible a => a -> a+wholeTiles = forceWith wholeTileUpdates ++-- | forceWith ugen: force using the given UpdateGenerator+forceWith:: Forcible a => UpdateGenerator -> a -> a+forceWith ugen = runTry . tryForceWith ugen++-- | try to initialize a force state with the default UpdateGenerator.+-- Returns a Left report if it finds a stuck forcible.+tryInitFS :: Forcible a => a -> Try ForceState+tryInitFS = tryInitFSWith defaultAllUGen++-- | initialize a force state with the default UpdateGenerator.+-- Raises aan error if it finds a stuck forcible.+initFS :: Forcible a => a -> ForceState+initFS = runTry . tryInitFS++-- |tryStepForce n a - produces a (Right) intermediate Forcible after n steps (n face additions) starting from Forcible a.+-- or a Left report if it encounters a stuck/incorrect Forcible within n steps.+-- If forcing finishes successfully in n or fewer steps, it will return that final Forcible. +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.+-- 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++-- |specialises tryChangeBoundaryWith to the default update generator.+tryChangeBoundary:: Forcible a => (BoundaryState -> Try BoundaryChange) -> a -> Try a+tryChangeBoundary = tryChangeBoundaryWith defaultAllUGen++++-- |addHalfKite is for adding a single half kite on a chosen boundary Dedge of a Forcible.+-- The Dedge must be a boundary edge but the direction is not important as+-- the correct direction is automatically calculated.+-- It will raise an error if the edge is a dart join or if a conflict (stuck graph) is detected+-- or if the edge is not a boundary edge.+addHalfKite :: Forcible a => Dedge -> a -> a+addHalfKite e  = runTry . tryAddHalfKite e++-- |tryAddHalfKite is a version of addHalfKite which returns a Try+-- with a Left report if it finds a stuck/incorrect graph, or +-- if the edge is a dart join, or+-- if the edge is not a boundary edge.   +tryAddHalfKite :: Forcible a => Dedge -> a -> Try a+tryAddHalfKite = tryChangeBoundary . tryAddHalfKiteBoundary where+-- |tryAddHalfKiteBoundary implements tryAddHalfKite as a BoundaryState change+-- tryAddHalfKiteBoundary :: Dedge -> BoundaryState -> Try BoundaryChange+    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"+         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"+         u <- tryU+         tryUpdate bd u++-- |addHalfDart is for adding a single half dart on a chosen boundary Dedge of a Forcible.+-- The Dedge must be a boundary edge but the direction is not important as+-- the correct direction is automatically calculated.+-- It will raise an error if the edge is a dart short edge or kite join+-- or if a conflict (stuck graph) is detected or if+-- the edge is not a boundary edge.+addHalfDart :: Forcible a => Dedge -> a -> a+addHalfDart e = runTry . tryAddHalfDart e+  +-- |tryAddHalfDart is a version of addHalfDart which returns a Try+-- with a Left report if it finds a stuck/incorrect graph, or+-- if the edge is a dart short edge or kite join, or+-- if the edge is not a boundary edge.+tryAddHalfDart :: Forcible a => Dedge -> a -> Try a+tryAddHalfDart = tryChangeBoundary . tryAddHalfDartBoundary where+-- |tryAddHalfDartBoundary implements tryAddHalfDart as a BoundaryState change+-- tryAddHalfDartBoundary :: Dedge -> BoundaryState -> Try BoundaryChange+    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"+         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"+         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 :: UpdateGenerator -> ForceState -> Try (Maybe (ForceState,BoundaryChange))+tryOneStepWith uGen fs = +      case findSafeUpdate (updateMap fs) of+      Just u -> do bdChange <- trySafeUpdate (boundaryState fs) u+                   fs' <- tryReviseFSWith uGen bdChange fs+                   return $ Just (fs',bdChange)+      _  -> do maybeBdC <- tryUnsafes fs+               case maybeBdC of+                Just bdC -> do fs' <- tryReviseFSWith uGen bdC fs+                               return $ Just (fs',bdC)+                Nothing  -> return Nothing           -- no more updates++-- |tryOneStepF is a special case of tryOneStepWith only 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.+-}+data BoundaryChange = BoundaryChange +                       { newBoundaryState:: BoundaryState -- ^ resulting boundary state+                       , removedEdges:: [Dedge] -- ^ edges no longer on the boundary+                       , revisedEdges :: [Dedge]  -- ^ boundary edges 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,+     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.)+-}+affectedBoundary :: BoundaryState -> [Dedge] -> [Dedge]+affectedBoundary bd [(a,b)] = [(x,a),(a,b),(b,y)] where+           bdry = boundary bd+           (x,_) = mustFind ((==a).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show a ++ "\n")+           (_,y) = mustFind ((==b).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show b ++ "\n")+affectedBoundary bd [(a,b),(c,d)] | b==c = [(x,a),(a,b),(c,d),(d,y)] where+           bdry = boundary bd+           (x,_) = mustFind ((==a).snd) bdry (error $ "affectedBoundary: boundary edge not found with snd = " ++ show a ++ "\n")+           (_,y) = mustFind ((==d).fst) bdry (error $ "affectedBoundary: boundary edge not found with fst = " ++ show d ++ "\n")+affectedBoundary bd [(a,b),(c,d)] | a==d = [(x,c),(c,d),(a,b),(b,y)] where+           bdry = boundary bd+           (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"++{-| 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 :: Foldable t => (p -> Bool) -> t p -> p -> p+mustFind p ls err+  = maybe err id (find p ls)++-- |tryReviseUpdates uGen bdChange: revises the UpdateMap after boundary change (bdChange)+-- using uGen to calculate new updates.+tryReviseUpdates:: UpdateGenerator -> BoundaryChange -> UpdateMap -> Try UpdateMap+tryReviseUpdates uGen bdChange umap = +  do let umap' = foldr Map.delete umap (removedEdges bdChange)+     umap'' <- uGen (newBoundaryState bdChange) (revisedEdges bdChange) +     return (Map.union umap'' umap')++-- |tryReviseFSWith ugen bdC fs tries to revise fs after a boundary change (bdC) by calculating+-- the revised updates with ugen (and using the new boundary state in bdC).+tryReviseFSWith :: UpdateGenerator -> BoundaryChange -> ForceState -> Try ForceState+tryReviseFSWith ugen bdC fs =+    do umap <- tryReviseUpdates ugen bdC (updateMap fs)+       return $ ForceState{ boundaryState = newBoundaryState bdC, updateMap = umap}+++-- |finds the first safe update - Nothing if there are none (ordering is directed edge key ordering)+findSafeUpdate:: UpdateMap -> Maybe Update +findSafeUpdate umap = find isSafeUpdate (Map.elems umap) where+  isSafeUpdate (SafeUpdate _ ) = True+  isSafeUpdate (UnsafeUpdate _ ) = False++{-| tryUnsafes: Should only be used when there are no Safe updates in the UpdateMap.+   tryUnsafes works through the unsafe updates in (directed edge) key order and+   completes the first unsafe update that is not blocked (by a touching vertex), returning Right (Just bdC)+   where bdC is the resulting boundary change (if there is one).+   It returns Right Nothing if there are no unsafe updates but+   Left report if there are unsafes but all unsafes are blocked, where report describes the problem.+-}+tryUnsafes:: ForceState -> Try (Maybe BoundaryChange)+tryUnsafes fs = checkBlocked 0 $ Map.elems $ updateMap fs where+  bd = boundaryState fs+  -- the integer records how many blocked cases have been found so far+  checkBlocked:: Int -> [Update]  -> Try (Maybe BoundaryChange)+  checkBlocked 0 [] = return Nothing+  checkBlocked n [] = Left $ "tryUnsafes: There are " ++ show n++ " unsafe updates but ALL unsafe updates are blocked (by touching vertices)\n"+                             ++ "This should not happen! However it may arise when accuracy limits are reached on very large Tgraphs.\n"+                             ++ "Total number of faces is " ++ show (length $ allFaces bd) ++ "\n"+  checkBlocked n (u: more) = case checkUnsafeUpdate bd u of+                               Nothing -> checkBlocked (n+1) more+                               other -> return other++{-| checkUnsafeUpdate bd u, calculates the resulting boundary change for an unsafe update (u) with a new vertex+     (raising an error if u is a safe update).+     It performs a touching vertex check with the new vertex+     returning Nothing if there is a touching vertex (blocked case).+     Otherwise it returns Just bdc with bdc a boundary change.+    [Note: Try is not used as a conflict cannot be found in the unsafe case, and blocking is only a problem+    when all unsafe updates are blocked (and there is at least one) - see tryUnsafes]+-}+checkUnsafeUpdate:: BoundaryState -> Update -> Maybe BoundaryChange+checkUnsafeUpdate _  (SafeUpdate _) = error  "checkUnsafeUpdate: applied to safe update.\n"+checkUnsafeUpdate bd (UnsafeUpdate makeFace) = +   let v = nextVertex bd       +       newface = makeFace v+       oldVPoints = bvLocMap bd+       newVPoints = addVPoint newface oldVPoints+       vPosition = newVPoints VMap.! v -- Just vPosition = VMap.lookup v newVPoints+       fDedges = faceDedges newface+       matchedDedges = filter (\(x,y) -> x /= v && y /= v) fDedges -- singleton+       newDedges = fmap reverseD (fDedges \\ matchedDedges) -- two edges+       resultBd = BoundaryState+                    { boundary = newDedges ++ (boundary bd \\ matchedDedges)+                    , bvFacesMap = changeVFMap newface (bvFacesMap bd)+                    , bvLocMap = newVPoints+                    , allFaces = newface:allFaces bd+                    , nextVertex = v+1+                    }+       bdChange = BoundaryChange +                    { newBoundaryState = resultBd+                    , removedEdges = matchedDedges+                    , revisedEdges = affectedBoundary resultBd newDedges+                    , newFace = newface+                    }+   in if touchCheck vPosition oldVPoints -- true if new vertex is blocked because it touches the boundary elsewhere+      then Nothing -- don't proceed when v is a touching vertex+      else Just bdChange ++{-| trySafeUpdate bd u adds a new face by completing a safe update u on BoundaryState bd+    (raising an error if u is an unsafe update).+     It returns a Right BoundaryChange (containing a new BoundaryState, removed boundary edges and+     revised boundary edge list), unless a stuck/incorrect graph is found.+     It checks that the new face is not in conflict with existing faces,+     producing (Left report) if there is a conflict.+    It should cater for the exceptional case where the update removes 3 boundary edges+    in a triangle (and removes 3 boundary vertices), closing a hole.+-}+trySafeUpdate:: BoundaryState -> Update -> Try BoundaryChange+trySafeUpdate _  (UnsafeUpdate _) = error "trySafeUpdate: applied to non-safe update.\n"+trySafeUpdate bd (SafeUpdate newface) = +   let fDedges = faceDedges newface+       matchedDedges = fDedges `intersect` boundary bd -- list of 2 or 3+       removedBVs = commonVs matchedDedges -- usually 1 vertex no longer on boundary (exceptionally 3)+       newDedges = fmap reverseD (fDedges \\ matchedDedges) -- one or none+       nbrFaces = nub $ concatMap (facesAtBV bd) removedBVs+       resultBd = BoundaryState +                   { boundary = newDedges ++ (boundary bd \\ matchedDedges)+                   , bvFacesMap = foldr VMap.delete (changeVFMap newface $ bvFacesMap bd) removedBVs+--                   , bvFacesMap = changeVFMap newface (bvFacesMap bd)+                   , allFaces = newface:allFaces bd+                   , bvLocMap = foldr VMap.delete (bvLocMap bd) removedBVs+                               --remove vertex/vertices no longer on boundary+                   , nextVertex = nextVertex bd+                   }+       bdChange = BoundaryChange +                   { newBoundaryState = resultBd+                   , removedEdges = matchedDedges+                   , revisedEdges = affectedBoundary resultBd newDedges+                   , newFace = newface+                   }+   in if noNewConflict newface nbrFaces +      then Right bdChange +      else Left $ "trySafeUpdate:(incorrect tiling)\nConflicting new face  "+                   ++ show newface+                   ++ "\nwith neighbouring faces\n"+                   ++ show nbrFaces+                   ++ "\n"++                 +-- | given 2 consecutive directed edges (not necessarily in the right order),+-- this returns the common vertex (as a singleton list).+-- Exceptionally it may be given 3 consecutive directed edges forming a triangle+-- and returns the 3 vertices of the triangle.+-- It raises an error if the argument is not one of these 2 cases.+commonVs :: [Dedge] -> [Vertex]+commonVs [(a,b),(c,d)] | b==c = [b] +                       | d==a = [a]+                       | otherwise = error $ "commonVs: 2 directed edges not consecutive: " ++ show [(a,b),(c,d)] ++ "\n"+commonVs [(a,b),(c,d),(e,f)] | length (nub [a,b,c,d,e,f]) == 3 = [a,c,e] +commonVs es = error $ "commonVs: unexpected argument edges (not 2 consecutive directed edges or 3 round triangle): " ++ show es  ++ "\n"++-- |tryUpdate: tries a single update (safe or unsafe),+-- producing Left report if the update creates a touching vertex in the unsafe case,+-- or if a stuck/incorrect Tgraph is discovered in the safe case.+tryUpdate:: BoundaryState -> Update -> Try BoundaryChange+tryUpdate bd u@(SafeUpdate _) = trySafeUpdate bd u+tryUpdate bd u@(UnsafeUpdate _) = +  case checkUnsafeUpdate bd u of+       Just bdC -> return bdC+       Nothing ->  Left "tryUpdate: crossing boundary (touching vertices).\n"++-- |This recalibrates a BoundaryState by recalculating boundary vertex positions from scratch with locateVertices.+-- (Used at intervals in tryRecalibrateForce and recalibrateForce).+recalculateBVLocs :: BoundaryState -> BoundaryState+recalculateBVLocs bd = bd {bvLocMap = newlocs} where+    newlocs = VMap.filterWithKey (\k _ -> k `elem` bvs) $ locateVertices $ allFaces bd+    bvs = fmap fst $ boundary bd++-- |A version of tryForce that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch.+-- This is needed to limit accumulated inaccuracies when large numbers of faces are added in forcing.+tryRecalibratingForce :: Forcible c => c -> Try c+tryRecalibratingForce = tryFSOp recalibrating where+   recalibrating fs = do+       fs' <- tryStepForce 20000 fs+       if null $ updateMap fs'+       then return fs'+       else recalibrating $ fs' {boundaryState = recalculateBVLocs $ boundaryState fs'}++-- |A version of force that recalibrates at 20,000 step intervals by recalculating boundary vertex positions from scratch.+-- This is needed to limit accumulation of errors when large numbers of faces are added in forcing.+recalibratingForce :: Forcible c => c -> c+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,++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+   add the half kite that must be on the short edge+   (this is at ace vertices but also helps with jack and deuce vertices).  +3. (queenOrKingUpdates) When a vertex is both a dart origin and a kite wing it must be a queen or king vertex.+   If there is a boundary short edge of a kite half at the vertex, +   add another kite half sharing the short edge. +   (This converts 1 kite to 2 and 3 kites to 4 in combination with the first rule).+4. (deuceDartUpdates) When two half kites share a short edge their oppV vertex must be a deuce vertex.+   Add any missing half darts needed to complete the vertex.+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+   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+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+-}+           +{-------------------  FORCING RULES and Generators --------------------------+7 vertex types are:+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).+    This version returns a Left..(fail report) for the first generator that produces a Left..(fail report).+    See $rules+-}+allUGenerator :: UpdateGenerator +allUGenerator bd focus =+  do  (_ , umap) <- foldl' addGen (Right (focus,Map.empty)) generators+      return umap+  where+    addGen (Right (es,umap)) gen = do umap' <- gen bd es+                                      let es' = es \\ Map.keys umap'+                                      return (es',Map.union umap' umap) +    addGen other _  = other  -- fails with first failing generator+    generators = [ wholeTileUpdates          -- (rule 1)+                 , aceKiteUpdates            -- (rule 2)+                 , queenOrKingUpdates        -- (rule 3)+                 , deuceDartUpdates          -- (rule 4)+                 , jackDartUpdates           -- (rule 5)+                 , sunStarUpdates            -- (rule 6)+                 , jackKiteUpdates           -- (rule 7)+                 , 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,+-- such a function returns each focus edge satisfying the particular update case paired with the tileface+-- matching that edge. For example, if the function is looking for dart short edges on the boundary,+-- it will return only those focus edges which are half-dart short edges,+-- each paired with its half-dart face.+type UFinder = BoundaryState -> [Dedge] -> [(Dedge,TileFace)]++-- |UChecker (Update checker functions). Given a BoundaryState and a particular tileface (on the boundary),+-- such functions try to produce particular updates on the boundary edge of the given tileface.+-- [They are called update checkers because they may uncover an incorrect/stuck tiling (using tryFindThirdV)+-- when creating the update.]+-- As an example, addKiteShortE will try to produce an update to add a half-kite with short edge against the boundary.+-- Such a function can be used with a UFinder that either returns dart halves with short edge on the boundary+-- (nonKDarts in rule 2) or returns kite halves with short edge on the boundary+-- (kitesWingDartOrigin in rule 3).+type UChecker = BoundaryState -> TileFace -> Try Update      ++{-|This is a general purpose filter used to create UFinder functions for each force rule.+ It requires a face predicate.+ The face predicate takes a BoundaryState bd, a boundary Dedge (a,b) and the TileFace with the edge (b,a)+ and decides whether the face is wanted or not (True = wanted)+ This will be used to filter all the faces at the focus edges + (when given a BoundaryState and list of focus edges).+ For some predicates the BoundaryState argument is not used (eg boundaryJoin in incompleteHalves), + but for others it is used to look at other faces at b or at a besides the supplied face + (eg in kitesWingDartOrigin) +-}+boundaryFilter::  (BoundaryState -> Dedge -> TileFace -> Bool) -> UFinder+boundaryFilter predF bd focus = +    [ (e,fc) | e <- focus +             , fc <- facesAtBV bd (fst e)+             , fc `elem` facesAtBV bd (snd e)+             , predF bd e fc+             ]++-- |makeUpdate f x constructs a safe update if x is Just .. and an unsafe update if x is Nothing+makeUpdate:: (Vertex -> TileFace) -> Maybe Vertex ->  Update+makeUpdate f (Just v) = SafeUpdate (f v)+makeUpdate f Nothing  = UnsafeUpdate f+++         +-- |A vertex on the boundary must be a star if it has 7 or more dart origins+mustbeStar:: BoundaryState -> Vertex -> Bool+mustbeStar bd v = length (filter ((==v) . originV) $ filter isDart $ facesAtBV bd v) >= 7++-- |A vertex on the boundary must be a sun if it has 5 or more kite origins+mustbeSun:: BoundaryState -> Vertex -> Bool+mustbeSun bd v = length (filter ((==v) . originV) $ filter isKite $ facesAtBV bd v) >= 5++-- |A vertex on the boundary which is an oppV of a kite must be a deuce+-- if there is a shared kite short edge at the vertex.+mustbeDeuce:: BoundaryState -> Vertex -> Bool+mustbeDeuce bd v = isKiteOppV bd v &&+                   hasAnyMatchingE (fmap shortE $ filter isKite $ facesAtBV bd v)++-- |A boundary vertex which is a kite wing and has 4 dart origins must be a king vertex+mustbeKing:: BoundaryState -> Vertex -> Bool+mustbeKing bd v = isKiteWing bd v && length dartOrigins ==4+   where  dartOrigins = filter ((==v) . originV) $ filter isDart $ facesAtBV bd v++{-+-- |A boundary vertex which is a kite wing and dart origin must be either a king or queen+mustbeQorK:: BoundaryState -> Vertex -> Bool+mustbeQorK bd v = isDartOrigin bd v && isKiteWing bd v+-}++-- |isKiteWing bd v - Vertex v is a kite wing in BoundaryState bd+isKiteWing:: BoundaryState -> Vertex -> Bool+isKiteWing bd v = v `elem` fmap wingV (filter isKite (facesAtBV bd v))++-- |isKiteOppV bd v - Vertex v is a kite oppV in BoundaryState bd+isKiteOppV:: BoundaryState -> Vertex -> Bool+isKiteOppV bd v = v `elem` fmap oppV (filter isKite (facesAtBV bd v))++-- |isDartOrigin bd v - Vertex v is a dart origin in BoundaryState bd+isDartOrigin:: BoundaryState -> Vertex -> Bool+isDartOrigin bd v = v `elem` fmap originV (filter isDart (facesAtBV bd v))++-- |A boundary vertex with >2 kite wings is a queen vertex +-- (needing a fourth kite on a kite short edge or dart on a kite long edge)+mustbeQueen:: BoundaryState -> Vertex -> Bool+mustbeQueen bd v = kiteWingCount bd v >2++-- |kiteWingCount bd v - the number of kite wings at v in BoundaryState bd+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+-- 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)+mustbeJack :: BoundaryState -> Vertex -> Bool+mustbeJack bd v =+  (length dWings == 2 && not (hasAnyMatchingE (fmap longE dWings))) || -- 2 dart wings and dart long edges not shared.+  (length dWings == 1 && isKiteOrigin) +  where fcs = facesAtBV bd v+        dWings = filter ((==v) . wingV) $ filter isDart fcs+        isKiteOrigin = v `elem` fmap originV (filter isKite fcs)++-- |hasMatching asks if a directed edge list has any two matching (=opposing) directed edges.+hasAnyMatchingE :: [Dedge] -> Bool+hasAnyMatchingE ((x,y):more) = (y,x) `elem` more || hasAnyMatchingE more+hasAnyMatchingE [] = False++{-| makeGenerator combines an update case finder (UFinder) with its corresponding update checker (UChecker)+    to produce an update generator function.+    This is used to make each of the 10 update generators corresponding to 10 rules. +    +    When the generator is given a BoundaryState and list of focus edges,+    the finder produces a list of pairs of dedge and face,+    the checker is used to convert the face in each pair to an update (which can fail with a Left report),+    and the new updates are returned as a map (with the dedges as key) in a Right result.+-}+makeGenerator :: UChecker -> UFinder -> UpdateGenerator+makeGenerator checker finder = gen where+  gen bd edges = foldr addU (Right Map.empty) (finder bd edges) where+                 addU _      (Left x) = Left x +                 addU (e,fc) (Right ump) = do u <- checker bd fc+                                              return (Map.insert e u ump)++                         +-- *  Ten Update Generators (with corresponding Finders)+++-- |Update generator for rule (1)+wholeTileUpdates:: UpdateGenerator+wholeTileUpdates = makeGenerator completeHalf incompleteHalves++-- |Find faces with missing opposite face (mirror face)  +incompleteHalves :: UFinder +incompleteHalves = boundaryFilter boundaryJoin where+    boundaryJoin _ (a,b) fc = joinE fc == (b,a)+++-- |Update generator for rule (2)+aceKiteUpdates :: UpdateGenerator+aceKiteUpdates = makeGenerator addKiteShortE nonKDarts++-- |Find half darts with boundary short edge+nonKDarts :: UFinder            +nonKDarts = boundaryFilter bShortDarts where+    bShortDarts _ (a,b) fc = isDart fc && shortE fc == (b,a)+++-- |Update generator for rule (3)+ -- queen and king vertices add a missing kite half (on a boundary kite short edge)+queenOrKingUpdates :: UpdateGenerator+queenOrKingUpdates = makeGenerator addKiteShortE kitesWingDartOrigin++-- |Find kites with boundary short edge where the wing is also a dart origin+kitesWingDartOrigin :: UFinder              +kitesWingDartOrigin = boundaryFilter kiteWDO where+   kiteWDO bd (a,b) fc = shortE fc == (b,a) +                         && isKite fc && isDartOrigin bd (wingV fc)+++{-| Update generator for rule (4)+     (for deuce vertices = largeKiteCentres)+     Kites whose short edge (b,a) matches a boundary edge (a,b) where their oppV +     has 2 other kite halves sharing a shortE.+     These need a dart adding on the short edge.+-}+deuceDartUpdates :: UpdateGenerator+deuceDartUpdates = makeGenerator addDartShortE kiteGaps++-- |Find kite halves with a short edge on the boundary (a,b) +-- where there are 2 other kite halves sharing a short edge+-- at oppV of the kite half (a for left kite and b for right kite)+kiteGaps :: UFinder              +kiteGaps = boundaryFilter kiteGap where+  kiteGap bd (a,b) fc = shortE fc == (b,a)+                        && isKite fc && mustbeDeuce bd (oppV fc)+++-- |Update generator for rule (5)+-- jackDartUpdates - jack vertex add a missing second dart+jackDartUpdates :: UpdateGenerator+jackDartUpdates = makeGenerator addDartShortE noTouchingDart++-- |Find kite halves with a short edge on the boundary (a,b) where oppV is a largeDartBase 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+noTouchingDart :: UFinder              +noTouchingDart = boundaryFilter farKOfDarts where+   farKOfDarts bd (a,b) fc  = shortE fc == (b,a)+                              && isKite fc && mustbeJack bd (oppV fc)++{-| Update generator for rule (6)+sunStarUpdates is for vertices that must be either sun or star +almostSunStar finds half-kites/half-darts with a long edge on the boundary+where their origin vertex has 8 total half-kites/half-darts respectively+or their origin vertex has 6 total half-kites in the case of kites only+completeSunStar will add a new face of the same type (dart/kite) +sharing the long edge.+-}+sunStarUpdates :: UpdateGenerator+sunStarUpdates = makeGenerator completeSunStar almostSunStar++-- |Find a boundary long edge of either+-- a dart where there are at least 7 dart origins, or+-- a kite where there are at least 5 kite origins+almostSunStar :: UFinder                  +almostSunStar = boundaryFilter multiples57 where+    multiples57 bd (a,b) fc = longE fc == (b,a) &&           +        ((isDart fc && mustbeStar bd (originV fc)) ||+         (isKite fc && mustbeSun bd (originV fc))+        )++-- |Update generator for rule (7)+-- jack vertices (largeDartBases) with dart long edge on boundary - add missing kite top+jackKiteUpdates :: UpdateGenerator+jackKiteUpdates = makeGenerator addKiteLongE jackMissingKite++-- |Find jack vertices (largeDartBases) with dart long edge on the boundary+jackMissingKite :: UFinder                  +jackMissingKite = boundaryFilter dartsWingDB where+    dartsWingDB bd (a,b) fc = longE fc == (b,a) &&+                              isDart fc && mustbeJack bd (wingV fc)++-- |Update generator for rule (8)+-- king vertices with 2 of the 3 darts  - add another half dart on a boundary long edge of existing darts+kingDartUpdates :: UpdateGenerator+kingDartUpdates = makeGenerator addDartLongE kingMissingThirdDart++-- |Find king vertices with a dart long edge on the boundary+-- and 2 of the 3 darts at its origin plus a kite wing at its origin+kingMissingThirdDart :: UFinder                    +kingMissingThirdDart = boundaryFilter predicate where+    predicate bd (a,b) fc = longE fc == (b,a) &&+        isDart fc && mustbeKing bd (originV fc)+++-- |Update generator for rule (9)+-- queen vertices (with 4 kite wings) -- add any missing half dart on a boundary kite long edge+queenDartUpdates :: UpdateGenerator+queenDartUpdates = makeGenerator addDartLongE queenMissingDarts++-- |Find queen vertices (with 3 or 4 kite wings) and a boundary kite long edge+queenMissingDarts :: UFinder                      +queenMissingDarts = boundaryFilter predicate where+    predicate bd (a,b) fc = +        longE fc == (b,a) && isKite fc && length kiteWings >2+           where fcWing = wingV fc+                 kiteWings = filter ((==fcWing) . wingV) $ +                             filter isKite $ facesAtBV bd fcWing+                                      +-- |Update generator for rule (10)+-- queen vertices with 3 kite wings -- add missing fourth 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+queenMissingKite :: UFinder                        +queenMissingKite = boundaryFilter predicate where+    predicate bd (a,b) fc = +        shortE fc == (b,a) && isKite fc && length kiteWings >2+           where fcWing = wingV fc+                 kiteWings = filter ((==fcWing) . wingV) $ filter isKite (facesAtBV bd fcWing)+++-- *  Six Update Checkers+++-- |completeHalf will check an update to+--  add a symmetric (mirror) face for a given face at a boundary join edge.+completeHalf :: UChecker      +completeHalf bd (LD(a,b,_)) = makeUpdate makeFace <$> x where+        makeFace v = RD(a,v,b)+        x = tryFindThirdV bd (b,a) (3,1) --anglesForJoinRD+completeHalf bd (RD(a,_,b)) = makeUpdate makeFace <$> x where+        makeFace v = LD(a,b,v)+        x = tryFindThirdV bd (a,b) (1,3) --anglesForJoinLD+completeHalf bd (LK(a,_,b)) = makeUpdate makeFace <$> x where+        makeFace v = RK(a,b,v)+        x = tryFindThirdV bd (a,b) (1,2) --anglesForJoinRK+completeHalf bd (RK(a,b,_)) = makeUpdate makeFace <$> x where+        makeFace v = LK(a,v,b)+        x = tryFindThirdV bd (b,a) (2,1) --anglesForJoinLK++-- |add a (missing) half kite on a (boundary) short edge of a dart or kite+addKiteShortE :: UChecker         +addKiteShortE bd (RD(_,b,c)) = makeUpdate makeFace <$> x where+    makeFace v = LK(v,c,b)+    x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK+addKiteShortE bd (LD(_,b,c)) = makeUpdate makeFace <$> x where+    makeFace v = RK(v,c,b)+    x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK+addKiteShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where+    makeFace v = RK(v,c,b)+    x = tryFindThirdV bd (c,b) (2,2) --anglesForShortRK+addKiteShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where+    makeFace v = LK(v,c,b)+    x = tryFindThirdV bd (c,b) (2,2) --anglesForShortLK++-- |add a half dart top to a boundary short edge of a half kite.+addDartShortE :: UChecker         +addDartShortE bd (RK(_,b,c)) = makeUpdate makeFace <$> x where+        makeFace v = LD(v,c,b)+        x = tryFindThirdV bd (c,b) (3,1) --anglesForShortLD+addDartShortE bd (LK(_,b,c)) = makeUpdate makeFace <$> x where+        makeFace v = RD(v,c,b)+        x = tryFindThirdV bd (c,b) (1,3) --anglesForShortRD+addDartShortE _  _ = error "addDartShortE applied to non-kite face\n"++-- |add a kite half to a kite long edge or dart half to a dart long edge+completeSunStar :: UChecker+completeSunStar bd fc = if isKite fc +                        then addKiteLongE bd fc+                        else addDartLongE bd fc++-- |add a kite to a long edge of a dart or kite+addKiteLongE :: UChecker            +addKiteLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where+    makeFace v = RK(c,v,a)+    x = tryFindThirdV bd (a,c) (2,1) -- anglesForLongRK+addKiteLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where+    makeFace v = LK(b,a,v)+    x = tryFindThirdV bd (b,a) (1,2) -- anglesForLongLK+addKiteLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where+  makeFace v = LK(a,c,v)+  x = tryFindThirdV bd (a,c) (1,2) -- anglesForLongLK+addKiteLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where+  makeFace v = RK(a,v,b)+  x = tryFindThirdV bd (b,a) (2,1) -- anglesForLongRK++-- |add a half dart on a boundary long edge of a dart or kite+addDartLongE :: UChecker            +addDartLongE bd (LD(a,_,c)) = makeUpdate makeFace <$> x where+  makeFace v = RD(a,c,v)+  x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongRD+addDartLongE bd (RD(a,b,_)) = makeUpdate makeFace <$> x where+  makeFace v = LD(a,v,b)+  x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongLD+addDartLongE bd (LK(a,b,_)) = makeUpdate makeFace <$> x where+  makeFace v = RD(b,a,v)+  x = tryFindThirdV bd (b,a) (1,1) -- anglesForLongRD+addDartLongE bd (RK(a,_,c)) = makeUpdate makeFace <$> x where+  makeFace v = LD(c,v,a)+  x = tryFindThirdV bd (a,c) (1,1) -- anglesForLongLD++{-+-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3)+anglesForJoinRD,anglesForJoinLD,anglesForJoinRK,anglesForJoinLK::(Int,Int)+anglesForJoinRD = (3,1)+anglesForJoinLD = (1,3)+anglesForJoinRK = (1,2)+anglesForJoinLK = (2,1)+-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3)+anglesForLongLD,anglesForLongRD,anglesForLongRK,anglesForLongLK::(Int,Int)+anglesForLongLD = (1,1)+anglesForLongRD = (1,1)+anglesForLongRK = (2,1)+anglesForLongLK = (1,2)+-- |mnemonic for internal angles of an edge (expressed as integer units of a tenth turn (I.e 1,2 or 3)+anglesForShortLD,anglesForShortRD,anglesForShortLK,anglesForShortRK::(Int,Int)+anglesForShortLD = (3,1)+anglesForShortRD = (1,3)+anglesForShortLK = (2,2)+anglesForShortRK = (2,2)+-}+++-- *  The Default All Update Generator (defaultAllUGen)+++-- |An alternative to allUGenerator, and used as the default. It uses the same rules and UCheckers,+-- 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).+defaultAllUGen :: UpdateGenerator+defaultAllUGen bd es = combine $ fmap decide es  where -- Either String is a monoid as well as Map+  decide e = decider (e,f,etype) where (f,etype) = inspectBDedge bd e++  decider (e,f,Join)  = mapItem e (completeHalf bd f) -- rule 1+  decider (e,f,Short) +    | isDart f = mapItem e (addKiteShortE bd f) -- rule 2+    | otherwise = kiteShortDecider e f +  decider (e,f,Long)  +    | isDart f = dartLongDecider e f+    | otherwise = kiteLongDecider e f ++  dartLongDecider e f+    | mustbeStar bd (originV f) = mapItem e (completeSunStar bd f)+    | mustbeKing bd (originV f) = mapItem e (addDartLongE bd f)+    | mustbeJack bd (wingV f) = mapItem e (addKiteLongE bd f)+    | otherwise = Right Map.empty++  kiteLongDecider e f+    | mustbeSun bd (originV f) = mapItem e (completeSunStar bd f)+    | mustbeQueen bd (wingV f) = mapItem e (addDartLongE bd f)+    | otherwise = Right Map.empty++  kiteShortDecider e f+    | mustbeDeuce bd (oppV f) || mustbeJack bd (oppV f) = mapItem e (addDartShortE bd f)+    | mustbeQueen bd (wingV f) || isDartOrigin bd (wingV f) = mapItem e (addKiteShortE bd f)+    | otherwise = Right Map.empty++  mapItem e = fmap (\u -> Map.insert e u Map.empty)+  combine = fmap mconcat . concatFails -- concatenates all failure reports if there are any+                                       -- otherwise combines the update maps with mconcat++-- |Given a BoundaryState and a directed boundary edge, this returns the same edge with+-- the unique face on that edge and the edge type for that face and edge (Short/Long/Join)+inspectBDedge:: BoundaryState -> Dedge -> (TileFace, EdgeType)+inspectBDedge bd e = (face,edgeType (reverseD e) face) where+    face = case facesAtBV bd (fst e) `intersect` facesAtBV bd (snd e) of+         [f] -> f+         _ -> error $ "inspectBDedge: Not a boundary directed edge " ++ show e ++ "\n"+++++-- *  Auxiliary Functions for adding faces: externalAngle and tryFindThirdV. $Additions+++{- $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+++No crossing boundary property:+It is important that there are no crossing boundaries, otherwise external angle calculations could be wrong.++Possible Touching Vertices.+When tryFindThirdV returns Nothing, this means a new vertex needs to be created.+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)+---------------------------------}++{-|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.+   In tryFindThirdV bd (a,b) (n,m), the two integer arguments n and m are the INTERNAL angles+   for the new face on the boundary directed edge (a,b)+   (for a and b respectively) expressed as multiples of tt (tt being a tenth turn)+   and must both be either 1,2, or 3.+   tryFindThirdV compares these internal angles with the external angles of the boundary calculated at a and b.+   If one of them matches, then an adjacent boundary edge will lead to the required vertex.+   If either n or m is too large a Left report is returned indicating an incorrect graph (stuck tiling).+   If n and m are smaller than the respective external angles, Right Nothing is returned.+-}+tryFindThirdV:: BoundaryState -> Dedge -> (Int,Int) -> Try (Maybe Vertex)+tryFindThirdV bd (a,b) (n,m) = maybeV where+    aAngle = externalAngle bd a+    bAngle = externalAngle bd b+    maybeV | aAngle <1 || aAngle >9 +                = Left $ "tryFindThirdV: vertex: " ++ show a ++ " has (tt) external angle " ++ show aAngle+                          ++ "\nwhen adding to boundary directed edge: " ++ show (a,b)+                          ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) +                          ++ "\nand faces at " ++ show b ++ ":\n" ++ show (bvFacesMap bd VMap.! b)+                          ++ "\nand a total of " ++ show (length $ allFaces bd) ++ " faces.\n"+           | bAngle <1 || bAngle >9 +                = Left $ "tryFindThirdV: vertex: " ++ show b ++ " has (tt) external angle " ++ show bAngle+                          ++ "\nwhen adding to boundary directed edge: " ++ show (a,b)+                          ++ "\nwith faces at " ++ show a ++ ":\n" ++ show (bvFacesMap bd VMap.! a) +                          ++ "\nand faces at " ++ show b ++ ":\n" ++ show (bvFacesMap bd VMap.! b)+                          ++ "\nand a total of " ++ show (length $ allFaces bd) ++ " faces.\n"+           | aAngle < n +                = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " +                         ++ show (a,b) ++ "\n"+           | bAngle < m+                = Left $ "tryFindThirdV: Found incorrect graph (stuck tiling)\nConflict at edge: " +                         ++ show (a,b) ++ "\n"+           | aAngle == n = case find ((==a) . snd) (boundary bd) of+                             Just pr -> Right $ Just (fst pr)+                             Nothing -> Left $ "tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " +                                               ++ show (a,b) ++ "\n"+           | bAngle == m = case find ((==b) . fst) (boundary bd) of+                             Just pr -> Right $ Just (snd pr)+                             Nothing -> Left $ "tryFindThirdV: Impossible boundary. No predecessor/successor Dedge for Dedge " +                                               ++ show (a,b) ++ "\n"+           | otherwise =   Right  Nothing++-- |externalAngle bd v - calculates the external angle at boundary vertex v in BoundaryState bd as an+-- integer multiple of tt (tenth turn), so 1..9.  It relies on there being no crossing boundaries,+-- so that there is a single external angle at each boundary vertex. +externalAngle:: BoundaryState -> Vertex -> Int+externalAngle bd v = 10 - sum (map (intAngleAt v) $ facesAtBV bd v)+  +-- |intAngleAt v fc gives the internal angle of the face fc at vertex v (which must be a vertex of the face)+-- in terms of tenth turns, so returning an Int (1,2,or 3).+intAngleAt :: Vertex -> TileFace -> Int+intAngleAt v fc = faceIntAngles fc !! indexV v fc++-- |faceIntAngles returns a list of the three internal angles of a face (clockwise from originV)+-- in terms of tenth turns - always 1 or 2 for kites and 1 or 3 for darts.+faceIntAngles :: TileFace -> [Int]+faceIntAngles (LD _) = [1,3,1]+faceIntAngles (RD _) = [1,1,3]+faceIntAngles _      = [1,2,2] -- LK and RK+++

@@ -0,0 +1,1235 @@+{-|+Module      : Tgraph.Prelude+Description : Introducing types Tgraph, VPatch and drawing operations.+Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++Introduces Tgraphs and includes operations on vertices, edges and faces as well as Tgraphs.+Plus VPatch (Vertex Patch) as intermediary between Tgraph and Diagram.+Conversion and drawing operations to produce Diagrams.+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.+-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TupleSections             #-}++module Tgraph.Prelude+  ( module HalfTile+  , module Tgraph.Try+    -- * Types for Tgraphs, Faces, Vertices, Directed Edges+  , Tgraph -- not Data Constructor+  , TileFace+  , Vertex+  , VertexSet+  , VertexMap+    -- $Edges+  , Dedge+  , EdgeType(..)+   -- * Property Checking for Tgraphs+  , makeUncheckedTgraph+  , checkedTgraph+  , tryTgraphProps+  , tryConnectedNoCross+--  , findEdgeLoops+  , hasEdgeLoops+  , duplicates+--  , conflictingDedges+  , edgeType+--  , sharedEdges+--  , newSharedEdges+  , noNewConflict+-- unused  , noNewConflictFull+--  , legal+--  , illegals+  , illegalTiling+--  , crossingBVs+  , crossingVertices+  , crossingBoundaries+  , connected+--  , connectedBy+    -- * Basic Tgraph operations+  , faces+  , emptyTgraph+  , nullGraph+  , maxV+  , ldarts+  , rdarts+  , lkites+  , rkites+  , kites+  , darts+  , selectFaces+  , removeFaces+  , removeVertices+  , selectVertices+  , vertexSet+  , graphDedges+  , graphEdges+  , internalEdges+  , graphBoundary+  , phiEdges+  , nonPhiEdges+  , graphEFMap+  , defaultAlignment+    -- * Other Face/Vertex Operations+  , faceVs+  , faceVList+  , faceVSet+  , facesVSet+  , facesMaxV+  , firstV+  , secondV+  , thirdV+  , originV+  , wingV+  , oppV+  , indexV+  , nextV +  , prevV+  , isAtV+  , hasVIn+    -- * Other Edge Operations+  , faceDedges+  , facesDedges +  , reverseD+  , joinE+  , shortE+  , longE+  , joinOfTile+  , facePhiEdges+  , faceNonPhiEdges+--  , matchingE+  , matchingLongE+  , matchingShortE+  , matchingJoinE+  , hasDedge+  , hasDedgeIn+  , facesEdges+--   , bothDir+--   , bothDirOneWay+  , facesBoundary+--   , missingRevs+    -- * Other Face Operations+  , edgeNb+  , vertexFacesMap+  , dedgesFacesMap+  , buildEFMap+  , faceForEdge+  , edgeNbs+--  , extractLowestJoin+  , lowestJoin+    -- * VPatch and Conversions+  , VPatch(..)+  , VertexLocMap+  , makeVP+  , subVP+  , relevantVP+  , restrictVP+  , graphFromVP+  , removeFacesVP+  , selectFacesVP+  , findLoc+    -- * Drawing Tgraphs and Vpatches with Labels+  , DrawableLabelled(..)+  , labelSize+  , labelled+  , rotateBefore+  , dropLabels+-- * VPatch alignment with vertices+  , centerOn+  , alignXaxis+  , alignments+  , alignAll+  , alignBefore+  , makeAlignedVP+    -- *  Drawing Edges with a VPatch or a VertexLocationMap+  , drawEdgesVP+  , drawEdgeVP+  , drawEdges+  , drawEdge+    -- * Vertex Location and Touching Vertices+  , locateVertices+  , addVPoint+  , axisJoin+--  , find3Locs+--  , thirdVertexLoc+  , touchingVertices+  , touching+  , touchingVerticesGen+  , locateVerticesGen+  ) where++import Data.List ((\\), intersect, union, elemIndex,foldl',find)+-- 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.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 TileLib+import HalfTile+import Tgraph.Try+++{---------------------+*********************+Tgraphs+*********************+-----------------------}++++-- $Types for Tgraphs, Vertices, Directed Edges, Faces++-- |Tgraph vertices (must be positive)+type Vertex = Int+-- | directed edge+type Dedge = (Vertex,Vertex)+-- | Vertex Sets+type VertexSet = IntSet.IntSet++-- |Tgraph faces  (vertices clockwise starting with tile origin vertex)+-- a specialisation of HalfTile+type TileFace = HalfTile (Vertex,Vertex,Vertex)++-- |A Tgraph is a list of faces.+-- 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).+newtype Tgraph = Tgraph [TileFace]+                 deriving (Show)++-- | type used to classify edges of faces +data EdgeType = Short | Long | Join deriving (Show,Eq)++-- |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+-}+++-- |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.++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.+-}+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.++Returns Right g where g is a Tgraph on passing checks.+Returns Left lines if a test fails, where lines describes the problem found.+-}+tryTgraphProps:: [TileFace] -> Try Tgraph+tryTgraphProps []       =  Right emptyTgraph +tryTgraphProps fcs+      | hasEdgeLoops fcs  =  Left $ "tryTgraphProps: Non-valid tile-face(s)\n" +++                                      "Edge Loops at: " ++ show (findEdgeLoops fcs) ++ "\n"+      | illegalTiling fcs =  Left $ "tryTgraphProps: Non-legal tiling\n" +++                                      "Conflicting face directed edges (non-planar tiling): "+                                      ++ show (conflictingDedges fcs) +++                                      "\nIllegal tile juxtapositions: "+                                      ++ show (illegals fcs) ++ "\n"+      | otherwise         = let vs = facesVSet fcs+                            in if IntSet.findMin vs <1 -- any (<1) $ IntSet.toList vs+                               then Left $ "tryTgraphProps: Vertex numbers not all >0: " ++ show (IntSet.toList vs) ++ "\n"+                               else tryConnectedNoCross fcs ++-- |Checks a list of faces for no crossing boundaries and connectedness.+-- (No crossing boundaries and connected implies tile-connected).+-- Returns Right g where g is a Tgraph on passing checks.+-- Returns Left lines if a test fails, where lines describes the problem found.+-- This is used by tryTgraphProps after other checks have been made,+-- but can be used alone when other properties are known to hold (e.g. in tryPartCompose)+tryConnectedNoCross:: [TileFace] -> Try Tgraph+tryConnectedNoCross fcs+  | not (connected fcs) =    Left $ "tryConnectedNoCross: Non-valid Tgraph (Not connected)\n" ++ show fcs ++ "\n"+  | crossingBoundaries fcs = Left $ "tryConnectedNoCross: Non-valid Tgraph\n" +++                                  "Crossing boundaries found at " ++ show (crossingBVs fcs) +                                  ++ "\nwith faces\n" ++ show fcs+  | otherwise            = Right (Tgraph fcs)++-- |Returns any repeated vertices in a single 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.+-- Returns True if there are any.+hasEdgeLoops:: [TileFace] -> Bool+hasEdgeLoops = not . null . findEdgeLoops+++-- |duplicates finds duplicated items in a list (reverses order but unique results)+duplicates :: Eq a => [a] -> [a]+duplicates = fst . foldl' check ([],[]) where+ check (dups,seen) x | x `elem` dups = (dups,seen)+                     | x `elem` seen = (x:dups,seen)+                     | otherwise = (dups,x:seen)++-- |conflictingDedges fcs returns a list of conflicting directed edges in fcs+-- i.e. different faces having the same edge in the same direction.+-- (which should be null for a Tgraph)+conflictingDedges :: [TileFace] -> [Dedge]+conflictingDedges = duplicates . facesDedges++++-- | edgeType d f - classifies the directed edge d+-- which must be one of the three directed edges of face f.+-- An error is raised if it is not a directed edge of the face+edgeType:: Dedge -> TileFace -> EdgeType+edgeType d f | d == longE f  = Long+             | d == shortE f = Short+             | d == joinE f  = Join +             | otherwise = error $ "edgeType: directed edge " ++ show d ++ +                                   " not found in face " ++ show f ++ "\n"++-- |For a list of tile faces fcs this produces a list of tuples of the form (f1,etpe1,f2,etype2)+-- where f1 and f2 share a common edge and etype1 is the type of the shared edge in f1 and+-- etype2 is the type of the shared edge in f2.+-- This list can then be checked for inconsistencies / illegal pairings (using legal).+sharedEdges:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]+sharedEdges fcs = [(f1, edgeType d1 f1, f2, edgeType d2 f2) +                   | f1 <- fcs+                   , d1 <- faceDedges f1+                   , let d2 = reverseD d1+                   , f2 <- filter (`hasDedge` d2) fcs+                  ]++-- |A version of sharedEdges comparing a single face against a list of faces.+-- This does not look at shared edges within the list, but just the new face against the list.+newSharedEdges:: TileFace -> [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]+newSharedEdges face fcs = +    [(face, edgeType d1 face, fc', edgeType d2 fc') +     | d1 <- faceDedges face+     , let d2 = reverseD d1+     , fc' <- filter (`hasDedge` d2) fcs+    ]++-- | noNewConflict face fcs returns True if face has an illegal shared edge with fcs.+-- It does not check for illegal cases within the fcs.+noNewConflict :: TileFace -> [TileFace] -> Bool+noNewConflict face fcs = null $ filter (not . legal) shared where+    shared = newSharedEdges face fcs++{-+-- |noNewConflictFull face fcs  where face is a new face and fcs are neighbouring faces.+-- Checks for illegal shared edges using noNewConflict but also checks that face does not have a directed edge+-- in the same direction as a directed edge in fcs.+noNewConflictFull :: TileFace -> [TileFace] -> Bool+noNewConflictFull face fcs = null (faceDedges face `intersect` facesDedges fcs) && noNewConflict face fcs+-}++-- | legal (f1,etype1,f2,etype2) is True if and only if it is legal for f1 and f2 to share an edge+-- with edge type etype1 (and etype2 is equal to etype1).                   +legal:: (TileFace,EdgeType,TileFace,EdgeType) -> Bool                +legal (LK _, e1,    RK _ , e2    ) = e1 == e2 +legal (RK _, e1,    LK _ , e2    ) = e1 == e2 +legal (LK _, Short, RD _ , Short) = True+legal (RD _, Short, LK _ , Short) = True+legal (LK _, Long,  RD _ , Long ) = True+legal (RD _, Long,  LK _ , Long ) = True+legal (LD _, Join,  RD _ , Join ) = True+legal (RD _, Join,  LD _ , Join ) = True+legal (LD _, Long,  RD _ , Long ) = True+legal (RD _, Long,  LD _ , Long ) = True+legal (LD _, Short, RK _ , Short) = True+legal (RK _, Short, LD _ , Short) = True+legal (LD _, Long,  RK _ , Long ) = True+legal (RK _, Long,  LD _ , Long ) = True+legal _ = False               ++-- | Returns a list of illegal face parings of the form (f1,e1,f2,e2) where f1 and f2 share an edge+-- and e1 is the type of this edge in f1, and e2 is the type of this edge in f2.+-- The list should be null for a legal Tgraph.+illegals:: [TileFace] -> [(TileFace,EdgeType,TileFace,EdgeType)]+illegals = filter (not . legal) .  sharedEdges++-- | Returns True if there are conflicting directed edges or if there are illegal shared edges+-- in the list of tile faces+illegalTiling:: [TileFace] -> Bool+illegalTiling fcs = not (null (illegals fcs)) || not (null (conflictingDedges fcs))++-- |crossingBVs fcs returns a list of vertices with crossing boundaries+-- (which should be null).               +crossingBVs :: [TileFace] -> [Vertex]+crossingBVs = crossingVertices . facesBoundary ++-- |Given a list of directed boundary edges, crossingVertices returns a list of vertices occurring+-- more than once at the start of the directed edges in the list.+-- Used for finding crossing boundary vertices when the boundary is already calculated.+crossingVertices:: [Dedge] -> [Vertex]+crossingVertices des = duplicates (fmap fst des) -- OR duplicates (fmap snd des)++-- |There are crossing boundaries if vertices occur more than once+-- at the start of all boundary directed edges+-- (or more than once at the end of all boundary directed edges).+crossingBoundaries :: [TileFace] -> Bool+crossingBoundaries = not . null . crossingBVs++-- |Predicate to check a Tgraph is a connected graph.+connected:: [TileFace] -> Bool+connected [] =  True+connected fcs = null (snd $ connectedBy (facesEdges fcs) (IntSet.findMin vs) vs)+                   where vs = facesVSet fcs++-- |Auxiliary function for calculating connectedness.+-- connectedBy edges v verts returns a pair of lists of vertices (conn,unconn)+-- where conn is a list of vertices from the set verts that are connected to v by a chain of edges,+-- and unconn is a list of vertices from set verts that are not connected to v.+-- This version creates an IntMap to represent edges (Vertex to [Vertex])+-- and uses IntSets for the search algorithm arguments.+connectedBy :: [Dedge] -> Vertex -> VertexSet -> ([Vertex],[Vertex])+connectedBy edges v verts = search IntSet.empty (IntSet.singleton v) (IntSet.delete v verts) where +  nextMap = VMap.fromListWith (++) $ map (\(a,b)->(a,[b])) edges+-- search arguments (sets):  done (=processed), visited, unvisited.+  search done visited unvisited +    | IntSet.null unvisited = (IntSet.toList visited ++ IntSet.toList done,[])+    | IntSet.null visited = (IntSet.toList done, IntSet.toList unvisited)  -- any unvisited are not connected+    | otherwise =+        search (IntSet.insert x done) (IntSet.union newVs visited') (unvisited IntSet.\\ newVs)+        where x = IntSet.findMin visited+              visited' = IntSet.deleteMin visited+              newVs = IntSet.fromList $ filter (`IntSet.notMember` done) $ nextMap VMap.! x ++++-- |Retrieve the faces of a Tgraph+faces :: Tgraph -> [TileFace]+faces (Tgraph fcs) = fcs++-- |The empty Tgraph+emptyTgraph :: Tgraph+emptyTgraph = Tgraph []++-- |is the Tgraph empty?+nullGraph:: Tgraph -> Bool+nullGraph = null . faces++-- |find the maximum vertex number in a Tgraph, returning 0 for an empty Tgraph.+maxV :: Tgraph -> Int+maxV = facesMaxV . faces++ldarts,rdarts,lkites,rkites, kites, darts :: Tgraph -> [TileFace]+-- | selecting left darts from a Tgraph+ldarts = filter isLD . faces+-- | selecting right darts from a Tgraph+rdarts = filter isRD . faces+-- | selecting left kites from a Tgraph+lkites = filter isLK . faces+-- | selecting right kites from a Tgraph+rkites = filter isRK . faces +-- | selecting half kites from a Tgraph+kites = filter isKite . faces+-- | selecting half darts from a Tgraph+darts = filter isDart . faces++-- |selects faces from a Tgraph (removing any not in the list),+-- but checks resulting Tgraph for connectedness and no crossing boundaries.+selectFaces :: [TileFace] -> Tgraph -> Tgraph+selectFaces fcs g = runTry $ tryConnectedNoCross $ faces g `intersect` fcs++-- |removes faces from a Tgraph,+-- but checks resulting Tgraph for connectedness and no crossing boundaries.+removeFaces :: [TileFace] -> Tgraph -> Tgraph+removeFaces fcs g = runTry $ tryConnectedNoCross $ faces g \\ fcs++-- |removeVertices vs g - removes any vertex in the list vs from g+-- by removing all faces at those vertices. Resulting Tgraph is checked+-- for required properties  e.g. connectedness and no crossing boundaries.+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.+-- Resulting Tgraph is checked+-- for required properties  e.g. connectedness and no crossing boundaries.+selectVertices :: [Vertex] -> Tgraph -> Tgraph+selectVertices vs g = selectFaces (filter (hasVIn vs) (faces g)) g++-- |the set of vertices of a Tgraph+vertexSet:: Tgraph -> VertexSet+vertexSet = facesVSet . faces++-- |A list of all the directed edges of a Tgraph (going clockwise round faces)+graphDedges :: Tgraph -> [Dedge]+graphDedges = facesDedges . faces++-- |graphEdges returns a list of all the edges of a Tgraph (both directions of each edge).+graphEdges :: Tgraph -> [Dedge]+graphEdges = facesEdges . faces++-- |internal edges are shared by two faces = all edges except boundary edges+internalEdges :: Tgraph -> [Dedge]+internalEdges g =  des \\ fmap reverseD (missingRevs des) where+    des = graphDedges g++-- |graphBoundary g are missing reverse directed edges in graphDedges g (the result contains single directions only)+-- Direction is such that a face is on LHS and exterior is on RHS of each boundary directed edge.+graphBoundary :: Tgraph -> [Dedge]+graphBoundary = facesBoundary . faces++-- |phiEdges returns a list of the longer (phi-length) edges of a Tgraph (including kite joins).+-- This includes both directions of each edge.+phiEdges :: Tgraph -> [Dedge]+phiEdges = bothDir . concatMap facePhiEdges . faces++-- |nonPhiEdges returns a list of the shorter edges of a Tgraph (including dart joins).+-- This includes both directions of each edge.+nonPhiEdges :: Tgraph -> [Dedge]+nonPhiEdges = bothDir . concatMap faceNonPhiEdges . faces ++-- | graphEFMap g - is a mapping associating with each directed edge of g, the unique TileFace with that directed edge.+-- This is more efficient than using dedgesFacesMap for the complete mapping.+graphEFMap :: Tgraph -> Map.Map Dedge TileFace+graphEFMap = buildEFMap . faces++-- |the default alignment of a non-empty Tgraph is (v1,v2) where v1 is the lowest numbered face origin,+-- and v2 is the lowest numbered opp vertex of faces with origin at v1. This is the lowest join of g.+-- An error will be raised if the Tgraph is empty.+defaultAlignment :: Tgraph -> (Vertex,Vertex)+defaultAlignment g | nullGraph g = error "defaultAlignment: applied to empty Tgraph\n"+                   | otherwise = lowestJoin $ faces g+++-- |triple of face vertices in order clockwise starting with origin - tileRep specialised to TileFace+faceVs::TileFace -> (Vertex,Vertex,Vertex)+faceVs = tileRep++-- |list of (three) face vertices in order clockwise starting with origin+faceVList::TileFace -> [Vertex]+faceVList = (\(x,y,z) -> [x,y,z]) . faceVs++-- |the set of vertices of a face+faceVSet :: TileFace -> VertexSet+faceVSet = IntSet.fromList . faceVList++-- |the set of vertices of a list of faces+facesVSet:: [TileFace] -> VertexSet+facesVSet = mconcat . fmap faceVSet++-- |find the maximum vertex for a list of faces (0 for an empty list).+facesMaxV :: [TileFace] -> Vertex+facesMaxV [] = 0+facesMaxV fcs = IntSet.findMax $ facesVSet fcs++-- Whilst first, second and third vertex of a face are obvious (clockwise), +-- it is often more convenient to refer to the originV (=firstV),+-- oppV (the vertex at the other end of the join edge), and+-- wingV (the remaining vertex not on the join edge)++-- |firstV, secondV and thirdV vertices of a face are counted clockwise starting with the origin+firstV,secondV,thirdV:: TileFace -> Vertex+firstV  face = a where (a,_,_) = faceVs face+secondV face = b where (_,b,_) = faceVs face+thirdV  face = c where (_,_,c) = faceVs face++originV,wingV,oppV:: TileFace -> Vertex+-- |the origin vertex of a face (firstV)+originV = firstV+-- |wingV returns the vertex not on the join edge of a face+wingV (LD(_,_,c)) = c+wingV (RD(_,b,_)) = b+wingV (LK(_,b,_)) = b+wingV (RK(_,_,c)) = c+-- |oppV returns the vertex at the opposite end of the join edge from the origin of a face+oppV (LD(_,b,_)) = b+oppV (RD(_,_,c)) = c+oppV (LK(_,_,c)) = c+oppV (RK(_,b,_)) = b++-- |indexV finds the index of a vertex in a face (firstV -> 0, secondV -> 1, thirdV -> 2)+indexV :: Vertex -> TileFace -> Int+indexV v face = case elemIndex v (faceVList face) of+                  Just i -> i+                  _      -> error ("indexV: " ++ show v ++ " not found in " ++ show face)                ++-- |nextV returns the next vertex in a face going clockwise from v+-- where v must be a vertex of the face+nextV :: Vertex -> TileFace -> Vertex+nextV v face = case indexV v face of+                    0 -> secondV face+                    1 -> thirdV face+                    2 -> firstV face+                    _ -> error "nextV: index error"+-- |prevV returns the previous vertex in a face (i.e. next going anti-clockwise) from v+-- where v must be a vertex of the face+prevV :: Vertex -> TileFace -> Vertex+prevV v face = case indexV v face of+                    0 -> thirdV face+                    1 -> firstV face+                    2 -> secondV face+                    _ -> error "prevV: index error"++-- |isAtV v f asks if a face f has v as a vertex+isAtV:: Vertex -> TileFace -> Bool           +isAtV v (LD(a,b,c))  =  v==a || v==b || v==c+isAtV v (RD(a,b,c))  =  v==a || v==b || v==c+isAtV v (LK(a,b,c))  =  v==a || v==b || v==c+isAtV v (RK(a,b,c))  =  v==a || v==b || v==c++-- |hasVIn vs f - asks if face f has an element of vs as a vertex+hasVIn:: [Vertex] -> TileFace -> Bool           +hasVIn vs face = not $ null $ faceVList face `intersect` vs+++{- $Edges+Edges: (a,b) is regarded as a directed edge from a to b.+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.                  +-}+++-- |directed edges (clockwise) round a face.+faceDedges::TileFace -> [Dedge]+faceDedges (LD(a,b,c)) = [(a,b),(b,c),(c,a)]+faceDedges (RD(a,b,c)) = [(a,b),(b,c),(c,a)]+faceDedges (LK(a,b,c)) = [(a,b),(b,c),(c,a)]+faceDedges (RK(a,b,c)) = [(a,b),(b,c),(c,a)]++-- |Returns the list of all directed edges (clockwise round each) of a list of tile faces.+facesDedges :: [TileFace] -> [Dedge]+facesDedges = concatMap faceDedges++-- |opposite directed edge.+reverseD:: Dedge -> Dedge+reverseD (a,b) = (b,a)++{-+-- |firstE, secondE and thirdE are the directed edges of a face counted clockwise from the origin, +firstE,secondE,thirdE:: TileFace -> Dedge+firstE = head . faceDedges+secondE = head . tail . faceDedges+thirdE = head . tail . tail . faceDedges+-}++joinE, shortE, longE, joinOfTile:: TileFace -> Dedge+-- |the join directed edge of a face in the clockwise direction going round the face (see also joinOfTile).+joinE (LD(a,b,_)) = (a,b)+joinE (RD(a,_,c)) = (c,a)+joinE (LK(a,_,c)) = (c,a)+joinE (RK(a,b,_)) = (a,b)+-- |The short directed edge of a face in the clockwise direction going round the face.+-- This is the non-join short edge for darts.+shortE (LD(_,b,c)) = (b,c)+shortE (RD(_,b,c)) = (b,c)+shortE (LK(_,b,c)) = (b,c)+shortE (RK(_,b,c)) = (b,c)++-- |The long directed edge of a face in the clockwise direction going round the face.+-- This is the non-join long edge for kites.+longE (LD(a,_,c)) = (c,a)+longE (RD(a,b,_)) = (a,b)+longE (LK(a,b,_)) = (a,b) +longE (RK(a,_,c)) = (c,a)++-- |The join edge of a face directed from the origin (not clockwise for RD and LK)+joinOfTile face = (originV face, oppV face)++facePhiEdges, faceNonPhiEdges::  TileFace -> [Dedge]+-- |The phi edges of a face (both directions)+-- which is long edges for darts, and join and long edges for kites+facePhiEdges face@(RD _) = [e, reverseD e] where e = longE face+facePhiEdges face@(LD _) = [e, reverseD e] where e = longE face+facePhiEdges face        = [e, reverseD e, j, reverseD j] +                         where e = longE face+                               j = joinE face++-- |The non-phi edges of a face (both directions)+-- which is short edges for kites, and join and short edges for darts.+faceNonPhiEdges face = bothDirOneWay (faceDedges face) \\ facePhiEdges face++-- |matchingE eselect face is a predicate on tile faces +-- where eselect selects a particular edge type of a face+-- (eselect could be joinE or longE or shortE for example).+-- This is True for face' if face' has an eselect edge matching the (reversed) eselect edge of face.+matchingE :: (TileFace -> Dedge) -> TileFace -> TileFace -> Bool+matchingE eselect face = (== reverseD (eselect face)) . eselect++matchingLongE,matchingShortE,matchingJoinE ::  TileFace -> TileFace -> Bool+      -- Used in Compose (getDartWingInfo and composedFaceGroups).+-- |check if two TileFaces have opposite directions for their long edge.+matchingLongE  = matchingE longE+-- |check if two TileFaces have opposite directions for their short edge.+matchingShortE = matchingE shortE+-- |check if two TileFaces have opposite directions for their join edge.+matchingJoinE  = matchingE joinE++-- |hasDedge f e returns True if directed edge e is one of the directed edges of face f+hasDedge :: TileFace -> Dedge -> Bool+hasDedge f e = e `elem` faceDedges f++-- |hasDedgeIn f es - is True if face f has a directed edge in the list of directed edges es.+hasDedgeIn :: TileFace -> [Dedge] -> Bool+hasDedgeIn face es = not $ null $ es `intersect` faceDedges face++-- |facesEdges returns a list of all the edges of a list of TileFaces (both directions of each edge).+facesEdges :: [TileFace] -> [Dedge]+facesEdges = bothDir . facesDedges++-- |bothDir adds missing reverse directed edges to a list of directed edges+-- to complete edges (Result is a complete edge list)+-- It assumes no duplicates in argument.+bothDir:: [Dedge] -> [Dedge]+bothDir es = missingRevs es ++ es++-- |bothDirOneWay adds all the reverse directed edges to a list of directed edges+-- without checking for duplicates.+-- Should be used on lists with single directions only.+-- If the argument may contain reverse directions, use bothDir to avoid duplicates.+bothDirOneWay:: [Dedge] -> [Dedge]+bothDirOneWay [] = []+bothDirOneWay (e@(a,b):es)= e:(b,a):bothDirOneWay es++-- |facesBoundary fcs are missing reverse directed edges in facesDedges fcs (the result contains single directions only)+-- Direction is such that a face is on LHS and exterior is on RHS of each boundary directed edge.+facesBoundary :: [TileFace] -> [Dedge]+facesBoundary fcs = missingRevs $ facesDedges fcs+++-- | efficiently finds missing reverse directions from a list of directed edges (using IntMap)+missingRevs:: [Dedge] -> [Dedge]+missingRevs es = revUnmatched es where+    vmap = VMap.fromListWith (++) $ map singleton es+    singleton (a,b) = (a,[b])+    seekR (a,b) = case VMap.lookup b vmap of+                   Nothing -> False+                   Just vs -> a `elem` vs+                    +    revUnmatched [] = []+    revUnmatched (e@(a,b):more) | seekR e = revUnmatched more+                                | otherwise = (b,a):revUnmatched more+++-- |two tile faces are edge neighbours+edgeNb::TileFace -> TileFace -> Bool+edgeNb face = any (`elem` edges) . faceDedges where+      edges = fmap reverseD (faceDedges face)++++{-|vertexFacesMap vs fcs -+For list of vertices vs and list of faces fcs,+create an IntMap from each vertex in vs to a list of those faces in fcs that are at that vertex.+-}+vertexFacesMap:: [Vertex] -> [TileFace] -> VertexMap [TileFace]+vertexFacesMap vs = foldl' insertf startVF where+    startVF = VMap.fromList $ fmap (,[]) vs+    insertf vfmap f = foldr (VMap.alter addf) vfmap (faceVList f)+                      where addf Nothing = Nothing+                            addf (Just fs) = Just (f:fs)++-- | dedgesFacesMap des fcs - Produces an edge-face map. Each directed edge in des is associated with+-- a unique TileFace in fcs that has that directed edge (if there is one).+-- It will report an error if more than one TileFace in fcs has the same directed edge in des. +-- If the directed edges and faces are all those from a Tgraph, graphEFMap will be more efficient.+-- dedgesFacesMap is intended for a relatively small subset of directed edges in a Tgraph.+dedgesFacesMap:: [Dedge] -> [TileFace] -> Map.Map Dedge TileFace+dedgesFacesMap des fcs =  Map.fromList (assocFaces des) where+   vs = fmap fst des `union` fmap snd des+   vfMap = vertexFacesMap vs fcs+   assocFaces [] = []+   assocFaces (d@(a,b):more) = case (VMap.lookup a vfMap, VMap.lookup b vfMap) of+      (Just fcs1, Just fcs2) -> case filter (`hasDedge` d) $ fcs1 `intersect` fcs2 of +                                   [face] -> (d,face):assocFaces more+                                   []   -> assocFaces more+                                   _   -> error $ "dedgesFacesMap: more than one Tileface has the same directed edge: "+                                                  ++ show d ++ "\n"+      _ -> assocFaces more+++-- |Build a Map from directed edges to faces (the unique face containing the directed edge)+buildEFMap:: [TileFace] -> Map.Map Dedge TileFace+buildEFMap = Map.fromList . concatMap assignFace where+  assignFace f = fmap (,f) (faceDedges f)+{-+buildEFMap = mconcat . fmap processFace where+  processFace face = Map.fromList $ (,face) <$> faceDedges face+-}++-- | look up a face for an edge in an edge-face map+faceForEdge :: Dedge -> Map.Map Dedge TileFace ->  Maybe TileFace+faceForEdge = Map.lookup++-- |Given a tileface (face) and a map from each directed edge to the tileface containing it (efMap)+-- return the list of edge neighbours of face.+edgeNbs:: TileFace -> Map.Map Dedge TileFace -> [TileFace]+edgeNbs face efMap = mapMaybe getNbr edges where+    getNbr e = Map.lookup e efMap+    edges = fmap reverseD $ faceDedges face++-- |For a non-empty list of tile faces+-- find the face with lowest originV (and then lowest oppV).+-- Move this face to the front of the returned list of faces.+-- Used by locateVertices to determine the starting point for location calculation+extractLowestJoin:: [TileFace] -> (TileFace,[TileFace])+extractLowestJoin fcs+  | null fcs  = error "extractLowestJoin: applied to empty list of faces"+  | otherwise = (face, fcs\\[face])+    where a = minimum (fmap originV fcs)+          aFaces = filter ((a==) . originV) fcs+          b = minimum (fmap oppV aFaces)+          face = case find (((a,b)==) . joinOfTile) aFaces of+                  Just f -> f+                  Nothing -> error $ "extractLowestJoin: no face fond at "+                                     ++ show a ++ " with opp vertex at " ++ show b ++ "\n"+--          (face: _) = filter (((a,b)==) . joinOfTile) aFaces++-- |Return the join edge with lowest origin vertex (and lowest oppV vertex if there is more than one).+-- The resulting edge is always directed from the origin to the opp vertex, i.e (orig,opp).+lowestJoin:: [TileFace] -> Dedge+lowestJoin fcs | null fcs  = error "lowestJoin: applied to empty list of faces"+lowestJoin fcs = (a,b) where+    a = minimum (fmap originV fcs)+    aFaces = filter ((a==) . originV) fcs+    b = minimum (fmap oppV aFaces)++{---------------------+*********************+VPatch and Conversions+*********************+-----------------------}++-- |Abbreviation for finite mappings from Vertex to Location (i.e Point)+type VertexLocMap = VMap.IntMap (Point V2 Double)+++-- |A VPatch has a map from vertices to points along with a list of tile faces.+-- It is an intermediate form between Tgraphs and Diagrams+data VPatch = VPatch {vLocs :: VertexLocMap,  vpFaces::[TileFace]} deriving Show++-- |needed for making VPatch transformable+type instance V VPatch = V2+-- |needed for making VPatch transformable+type instance N VPatch = Double+++-- |Make VPatch Transformable.+instance Transformable VPatch where +    transform t vp = vp {vLocs = VMap.map (transform t) (vLocs vp)}+++{-|Convert a Tgraph to a VPatch.+This uses locateVertices to form an intermediate VertexLocMap (mapping of vertices to positions).+This makes the join of the face with lowest origin and lowest oppV align on the positive x axis.+-}+makeVP::Tgraph -> VPatch+makeVP g = VPatch {vLocs = locateVertices fcs, vpFaces  = fcs} where fcs = faces g++-- |Creates a VPatch from a list of tile faces, using the vertex location map from the given VPatch.+-- The vertices in the tile faces should have locations assigned in the given VPatch vertex locations.+-- However THIS IS NOT CHECKED so missing locations for vertices will raise an error when drawing.+-- subVP vp fcs can be used for both subsets of tile faces of vp,+-- and also for larger scale faces which use the same vertex to point assignment (e.g in compositions).+-- The vertex location map is not changed (see also relevantVP and restrictVP).+subVP:: VPatch -> [TileFace] -> VPatch+subVP vp fcs = vp {vpFaces  = fcs} ++-- | removes locations for vertices not used in the faces of a VPatch.+-- (Useful when restricting which labels get drawn).+-- relevantVP vp will raise an error if any vertex in the faces of vp is not a key in the location map of vp.+relevantVP :: VPatch -> VPatch+relevantVP vp +  | null diffList = vp{vLocs = locVs}   +  | otherwise = error $ "relevantVP: missing locations for: " +++                                    show diffList ++ "\n"+  where+     vs = facesVSet (vpFaces vp)+     source = VMap.keysSet locVs+     diffList = IntSet.toList $ IntSet.difference vs source+     locVs = VMap.filterWithKey (\ v _ -> v `IntSet.member` vs) $ vLocs vp++-- | A combination of subVP and relevantVP. Restricts a vp to a list of faces, removing locations for vertices not in the faces.+-- (Useful when restricting which labels get drawn)+-- restrictVP vp fcs will raise an error if any vertex in fcs is not a key in the location map of vp.+restrictVP:: VPatch -> [TileFace] -> VPatch+restrictVP vp fcs = relevantVP (subVP vp fcs)++-- |Recover a Tgraph from a VPatch by dropping the vertex positions and checking Tgraph properties.+graphFromVP:: VPatch -> Tgraph+graphFromVP = checkedTgraph . vpFaces++-- |remove a list of faces from a VPatch+removeFacesVP :: VPatch -> [TileFace] -> VPatch+removeFacesVP vp fcs = restrictVP vp (vpFaces vp \\ fcs)++-- |make a new VPatch with a list of selected faces from a VPatch.+-- This will ignore any faces that are not in the given VPatch.+selectFacesVP:: VPatch -> [TileFace] -> VPatch+selectFacesVP vp fcs = restrictVP vp (fcs `intersect` vpFaces vp)++-- |find the location of a single vertex in a VPatch+findLoc :: Vertex -> VPatch -> Maybe (Point V2 Double)+findLoc v = VMap.lookup v . vLocs+++++-- |VPatches are drawable+instance Drawable VPatch where+    drawWith pd vp = drawWith pd (dropLabels vp)++-- |converts a VPatch to a Patch, removing vertex information and converting faces to Located Pieces.+-- (Usage can be confined to Drawable VPatch instance and DrawableLabelled VPatch instance.)+dropLabels :: VPatch -> Patch+dropLabels vp = fmap convert (vpFaces vp) where+  locations = vLocs vp+  convert face = case (VMap.lookup (originV face) locations , VMap.lookup (oppV face) locations) of+    (Just p, Just p') -> fmap (const (p' .-. p)) face `at` p -- using HalfTile functor fmap+    _ -> error $ "dropLabels: Vertex location not found for some vertices:\n    " +                ++ show (faceVList face \\ VMap.keys locations)  ++ "\n"++-- |Tgraphs are Drawable+instance Drawable Tgraph where+    drawWith pd = drawWith pd . makeVP++-- | A class for things that can be drawn with labels when given a colour and a measure (size) for the label and a +-- a draw function (for Patches).+-- 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+-- The argument type of the draw function is Patch rather than VPatch, which prevents labelling twice.+++-- | VPatches can be drawn with labels+instance DrawableLabelled VPatch where+  labelColourSize c m d vp = drawLabels (vLocs vp) <> d (dropLabels vp) where+     drawLabels vpMap = position $ drawlabel <$> VMap.toList vpMap+     drawlabel(v,p) = (p, baselineText (show v) # fontSize m # fc c)++-- | Tgraphs can be drawn with labels+instance DrawableLabelled Tgraph where+  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 = 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 = 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.+-- Tgraphs need to be rotated after a VPatch is calculated but before any labelled drawing.+-- E.g. rotateBefore (labelled draw) angle graph.+rotateBefore :: (VPatch -> a) -> Angle Double -> Tgraph -> a+rotateBefore vfun angle = vfun . rotate angle . makeVP++-- |center a VPatch on a particular vertex. (Raises an error if the vertex is not in the VPatch vertices)+centerOn :: Vertex -> VPatch -> VPatch+centerOn a vp = +    case findLoc a vp of+        Just loca -> translate (origin .-. loca) vp+        _ -> error $ "centerOn: vertex not found (Vertex " ++ show a ++ ")\n"++-- |alignXaxis takes a vertex pair (a,b) and a VPatch vp+-- for centering vp on a and rotating the result so that b is on the positive X axis.+-- (Raises an error if either a or b are not in the VPatch vertices)+alignXaxis :: (Vertex, Vertex) -> VPatch -> VPatch    +alignXaxis (a,b) vp =  rotate angle newvp+  where newvp = centerOn a vp+        angle = signedAngleBetweenDirs (direction unitX) (direction (locb .-. origin)) +        locb = case findLoc b newvp of+                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.+-- 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)+alignments :: [(Vertex, Vertex)] -> [VPatch] -> [VPatch]     +alignments [] vps = vps+alignments _  [] = error "alignments: Too many alignment pairs.\n"  -- non-null list of pairs+alignments ((a,b):more) (vp:vps) =  alignXaxis (a,b) vp : alignments more vps++-- |alignAll (a,b) vpList+-- provided both vertices a and b exist in each VPatch in vpList, the VPatch are all aligned+-- centred on a, with b on the positive x axis.+-- An error is raised if any VPatch does not contain both a and b vertices.+alignAll:: (Vertex, Vertex) -> [VPatch] -> [VPatch]     +alignAll (a,b) = fmap (alignXaxis (a,b))++-- |alignBefore vfun (a,b) g - makes a VPatch from g oriented with centre on a and b aligned on the x-axis+-- before applying the VPatch function vfun+-- Will raise an error if either a or b is not a vertex in g.+-- Tgraphs need to be aligned after a VPatch is calculated but before any labelled drawing.+-- E.g. alignBefore (labelled draw) (a,b) g+alignBefore :: (VPatch -> a) -> (Vertex,Vertex) -> Tgraph -> a+alignBefore vfun vs = vfun . alignXaxis vs . makeVP++-- | makeAlignedVP (a,b) g - make a VPatch from g oriented with centre on a and b aligned on the x-axis.+-- Will raise an error if either a or b is not a vertex in g.+makeAlignedVP:: (Vertex,Vertex) ->  Tgraph -> VPatch        +makeAlignedVP = alignBefore id+++-- |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 = 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 = 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 = 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 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.+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).+-}+locateVertices:: [TileFace] -> VertexLocMap+--  This version is made more efficient by calculating an edge to face map+--  and also using Sets for 2nd arg of fastAddVPoints.+locateVertices [] = VMap.empty+locateVertices fcs = fastAddVPoints [joinFace] (Set.fromList more) (axisJoin joinFace) where+    (joinFace,more) = extractLowestJoin fcs+    efMap = buildEFMap fcs  -- map from Dedge to TileFace++{- fastAddVPoints readyfaces fcOther vpMap.+The first argument list of faces (readyfaces) contains the ones being processed next in order where+each will have at least two known vertex locations in vpMap.+The second argument Set of faces (fcOther) are faces that have not yet been added+and may not yet have known vertex locations.+The third argument is the mapping of vertices to points.+-}+    fastAddVPoints [] fcOther vpMap | Set.null fcOther = vpMap +    fastAddVPoints [] fcOther _ = error $ "locateVertices (fastAddVPoints): Faces not tile-connected: "+                                          ++ show fcOther ++ "/n"+    fastAddVPoints (face:fs) fcOther vpMap = fastAddVPoints (fs++nbs) fcOther' vpMap' where+        nbs = filter (`Set.member` fcOther) (edgeNbs face efMap)+        fcOther' = foldl' (flip Set.delete) fcOther nbs+--        fcOther' = foldr Set.delete fcOther nbs+        vpMap' = addVPoint face vpMap++-- |Given a tileface and a vertex to location map which gives locations for at least 2 of the tileface vertices+-- this returns a new map by adding a location for the third vertex (when missing) or the same map when not missing.+-- It will raise an error if there are fewer than 2 tileface vertices with a location in the map+-- (indicating a non tile-connected face).+-- It is possible that a newly added location is already in the range of the map (creating a touching vertices),+-- so this needs to be checked for.+addVPoint:: TileFace -> VertexLocMap -> VertexLocMap+addVPoint face vpMap = +  case thirdVertexLoc face vpMap of+    Just (v,p) -> VMap.insert v p vpMap+    Nothing -> vpMap++-- |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)+axisJoin::TileFace -> VertexLocMap                +axisJoin face = +  VMap.insert (originV face) origin $ VMap.insert (oppV face) (p2(x,0)) VMap.empty where+    x = if isDart face then 1 else phi++-- |lookup 3 vertex locations in a vertex to point map.+find3Locs::(Vertex,Vertex,Vertex) -> VertexLocMap+             -> (Maybe (Point V2 Double),Maybe (Point V2 Double),Maybe (Point V2 Double))              +find3Locs (v1,v2,v3) vpMap = (VMap.lookup v1 vpMap, VMap.lookup v2 vpMap, VMap.lookup v3 vpMap)++{-| thirdVertexLoc face vpMap,  where face is a tileface and vpMap associates points with vertices (positions).+It looks up all 3 vertices of face in vpMap hoping to find at least 2 of them, it then returns Just pr+where pr associates a new location with the third vertex.+If all 3 are found, returns Nothing.+If none or one found this is an error (a non tile-connected face).++New Version: This assumes all edge lengths are 1 or phi.+It now uses signorm to produce vectors of length 1 rather than rely on relative lengths.+(Requires ttangle and phi from TileLib).+-}+thirdVertexLoc:: TileFace -> VertexLocMap -> Maybe (Vertex, Point V2 Double)        +thirdVertexLoc face@(LD _) vpMap = case find3Locs (faceVs face) vpMap of+  (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1))+  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = signorm (rotate (ttangle 7) (loc3 .-. loc2))+  (Just loc1, Nothing, Just loc3) -> Just (oppV face, loc1 .+^ v)    where v = signorm (rotate (ttangle 1) (loc3 .-. loc1))+  (Just _ , Just _ , Just _)      -> Nothing+  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"++thirdVertexLoc face@(RD _) vpMap = case find3Locs (faceVs face) vpMap of+  (Just loc1, Just loc2, Nothing) -> Just (oppV face, loc1 .+^ v)    where v = signorm (rotate (ttangle 9) (loc2 .-. loc1))+  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc3 .+^ v) where v = signorm (rotate (ttangle 3) (loc2 .-. loc3))+  (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1))+  (Just _ , Just _ , Just _)      -> Nothing+  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"+ +thirdVertexLoc face@(LK _) vpMap = case find3Locs (faceVs face) vpMap of+  (Just loc1, Just loc2, Nothing) -> Just (oppV face, loc1 .+^ v)    where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1))+  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2))+  (Just loc1, Nothing, Just loc3) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1))+  (Just _ , Just _ , Just _)      -> Nothing+  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"+ +thirdVertexLoc face@(RK _) vpMap = case find3Locs (faceVs face) vpMap of+  (Just loc1, Just loc2, Nothing) -> Just (wingV face, loc1 .+^ v)   where v = phi*^signorm (rotate (ttangle 9) (loc2 .-. loc1))+  (Nothing, Just loc2, Just loc3) -> Just (originV face, loc2 .+^ v) where v = phi*^signorm (rotate (ttangle 8) (loc3 .-. loc2))+  (Just loc1, Nothing, Just loc3) -> Just (oppV face, loc1 .+^ v)    where v = phi*^signorm (rotate (ttangle 1) (loc3 .-. loc1))+  (Just _ , Just _ , Just _)      -> Nothing+  _ -> error $ "thirdVertexLoc: face not tile-connected?: " ++ show face ++ "\n"++++-- *  Touching Vertices+++{-| +touchingVertices 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+(the touching vertex problem). +It returns pairs of vertices that are too close (higher number first in each pair)+An empty list is returned if there are no touching vertices.+Complexity has order of the square of the number of vertices.+                           +This is used in makeTgraph and fullUnion (via correctTouchingVertices).+-}+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+  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).+-}+touching :: Point V2 Double -> Point V2 Double -> Bool+touching p p1 = quadrance (p .-. p1) < 0.1 -- quadrance is square of length of a vector+--  0.1 represents a distance of about 0.316 units (= sqrt 0.1)+++{-*  Generalised Touching Vertices+-}++{-| +touchingVerticesGen  generalises touchingVertices to allow for multiple faces sharing a directed edge.+This can arise when applied to the union of faces from 2 Tgraphs which might clash in places.+It is used in the calculation of commonFaces.  +-}+touchingVerticesGen:: [TileFace] -> [(Vertex,Vertex)]+touchingVerticesGen fcs = check vpAssoc where+  vpAssoc = VMap.assocs $ locateVerticesGen fcs  -- assocs puts in key order so that check returns (higher,lower) pairs  +  check [] = []+  check ((v,p):more) = [(v1,v) | v1 <- nearv ] ++ check (filter ((`notElem` nearv).fst) more)+                        where nearv = [v1 | (v1,p1) <- more, touching p p1 ]++{-| locateVerticesGen generalises locateVertices to allow for multiple faces sharing an edge.+This can arise when applied to the union of faces from 2 Tgraphs (e.g. in commonFaces)    +-}+locateVerticesGen:: [TileFace] -> VertexLocMap+locateVerticesGen [] = VMap.empty+locateVerticesGen fcs = fastAddVPointsGen [face] (Set.fromList more) (axisJoin face) where+    (face,more) = extractLowestJoin fcs+    efMapGen = buildEFMapGen fcs  -- map from Dedge to [TileFace]++{- fastAddVPointsGen readyfaces fcOther vpMap.+The first argument list of faces (readyfaces) contains the ones being processed next in order where+each will have at least two known vertex locations in vpMap.+The second argument Set of faces (fcOther) are faces that have not yet been added+and may not yet have known vertex locations.+The third argument is the mapping of vertices to points.+-}+    fastAddVPointsGen [] fcOther vpMap | Set.null fcOther = vpMap +    fastAddVPointsGen [] fcOther _ = error $ "fastAddVPointsGen: Faces not tile-connected " ++ show fcOther ++ "\n"+    fastAddVPointsGen (f:fs) fcOther vpMap = fastAddVPointsGen (fs++nbs) fcOther' vpMap' where+        nbs = filter (`Set.member` fcOther) (edgeNbsGen f)+--        nbs = filter (`Set.member` fcOther) (edgeNbsGen efMapGen fc)+        fcOther' = foldr Set.delete fcOther nbs+        vpMap' = addVPoint f vpMap+-- Generalises buildEFMap by allowing for multiple faces on a directed edge.+-- buildEFMapGen:: [TileFace] -> Map.Map Dedge [TileFace]+    buildEFMapGen = Map.fromListWith (++) . concatMap processFace+    processFace f = (,[f]) <$> faceDedges f++-- Generalised edgeNbs allowing for multiple faces on a directed edge.+-- edgeNbsGen:: Map.Map Dedge [TileFace] -> TileFace -> [TileFace]+    edgeNbsGen f = concat $ mapMaybe getNbrs edges where+      getNbrs e = Map.lookup e efMapGen+      edges = fmap reverseD (faceDedges f) +{-+    edgeNbsGen efMapGen f = concat $ mapMaybe getNbrs edges where+      getNbrs e = Map.lookup e efMapGen+      edges = fmap reverseD (faceDedges f) +-}+++ ++

@@ -0,0 +1,406 @@+{-|+Module      : Tgraph.Relabelling+Description : Guided union and commonFaces using relabelling operations +Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++This module includes relabelling functions for Tgraphs whose main purpose is+to implement a guided union of Tgraphs (fullUnion and tryFullUnion)+and also a commonFaces operation (a kind of intersection which need not be a Tgraph)+and a guided equality check (sameGraph).+-}+module Tgraph.Relabelling+  ( -- * Assisted Union (and matching) operations+    fullUnion+  , tryFullUnion+    -- * commonFaces (Assisted Intersection) and sameGraph (Assisted Equivalence)+  , commonFaces+  , sameGraph+    -- * Creating Relabellings+  , Relabelling(..)+  , newRelabelling+--  , relabellingFrom+--  , relabellingTo+--  , relabelUnion+    -- * Relabellings and matching+  , relabelToMatch+  , tryRelabelToMatch+--  , tryRelabelFromFaces+--  , tryGrowRelabel+  , relabelToMatchIgnore+--  , relabelFromFacesIgnore+--  , growRelabelIgnore+    -- * Using Relabellings+  , relabelGraph+  , checkRelabelGraph+  , relabelFace+  , relabelV+--  , relabelAvoid+  , prepareFixAvoid+  , relabelContig+    --  * Renumbering (not necessarily 1-1)+  , renumberFaces+--  , tryMatchFace+--  , twoVMatch+--  , matchFaceIgnore+-- , differing+  ) where+++import Data.List (intersect, (\\), union,find,partition,nub)+import qualified Data.IntMap.Strict as VMap (IntMap, findWithDefault, fromList, fromAscList, union)+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+    and (possibly relabelled) faces of g2 as a Tgraph.  It does this+    by first matching the respective edges e1 and e2 and relabelling g2 to match g1 on a tile-connected region containing e1.+    It will raise an error if there is a mismatch.+    If succesfull it then uses geometry of tiles (vertex locations) to correct for multiple overlapping regions+    of tiles in g1 and relabelled g2 by a further relabelling of any touching vertices.+    The resulting union of faces requires an expensive tryTgraphProps if touching vertices were found.+    However the check is not needed when there are no touching vertices (i.e. a single tile-connected overlap).          +-}+fullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph+fullUnion (g1,e1) (g2,e2) = runTry $ tryFullUnion (g1,e1) (g2,e2)++{-| tryFullUnion (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+    and (possibly relabelled) faces of g2 as a Tgraph.  It does this+    by first matching the respective edges e1 and e2 and relabelling g2 to match g1 on a tile-connected region containing e1.+    It returns Left lines  if there is a mismatch (where lines explains the problem).+    If succesfull it then uses geometry of tiles (vertex locations) to correct for multiple overlapping regions+    of tiles in g1 and relabelled g2 by a further relabelling of any touching vertices. +    The resulting union of faces requires an expensive tryTgraphProps if any touching vertices were found,+    and will return Left ... if this fails and Right t otherwise, where t is a Tgraph+    containing the union of faces.+    The check is not used when there are no touching vertices (i.e. a single tile-connected overlap).          +-}+tryFullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph+tryFullUnion (g1,e1) (g2,e2) = onFail "tryFullUnion:\n" $+  do g3 <- tryRelabelToMatch (g1,e1) (g2,e2)+     let fcs = faces g1 `union` faces g3+         touchVs = touchingVertices fcs+     if null touchVs+     then return $ makeUncheckedTgraph fcs -- no properties check needed!+     else let vertg1 = vertexSet g1+              correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e+              newrel = newRelabelling $ fmap correct touchVs+          in tryTgraphProps $ nub $ fmap (relabelFace newrel) fcs+++-- | commonFaces (g1,e1) (g2,e2) relabels g2 to match with g1 (where they match)+-- and returns the common faces as a subset of faces of g1.+-- i.e. with g1 vertex labelling.+-- It requires a face in g1 with directed edge e1 to match a face in g2 with directed edge e2,+-- (apart from the third vertex label) otherwise an error is raised.+-- This uses vertex locations to correct touching vertices in multiply overlapping regions.+-- >>>> touching vertices being 1-1 is sensitive to nearness check of touchingVerticesGen <<<<<<<<<+commonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> [TileFace]+commonFaces (g1,e1) (g2,e2) = faces g1 `intersect` relFaces where+  g3 = relabelToMatchIgnore (g1,e1) (g2,e2)+  fcs = faces g1 `union` faces g3+  touchVs = touchingVerticesGen fcs -- requires generalised version of touchingVertices+  relFaces = fmap (relabelFace $ newRelabelling $ fmap correct touchVs) (faces g3)+  vertg1 = vertexSet g1+  correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e++                      +-- | sameGraph (g1,e1) (g2,e2) checks to see if g1 and g2 are the same Tgraph after relabelling g2.+-- The relabelling is based on directed edge e2 in g2 matching e1 in g1 (where the direction is clockwise round a face)+-- and uses tryRelabelToMatch.+sameGraph :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Bool+sameGraph (g1,e1) (g2,e2) =  length (faces g1) == length (faces g2) &&+                             ifFail False tryResult where+ tryResult = do g <- tryRelabelToMatch (g1,e1) (g2,e2)+                return (vertexSet g == vertexSet g1)+++-- |Relabelling is a special case of mappings from vertices to vertices that are not the +-- identity on a finite number of vertices.+-- They are represented by keeping the non identity cases in a finite map.+-- When applied, we assume the identity map for vertices not found in the representation domain+-- (see relabelV).  Relabellings must be 1-1 on their representation domain,+-- and redundant identity mappings are removed in the representation.+-- Vertices in the range of a relabelling must be >0.+newtype Relabelling = Relabelling (VMap.IntMap Vertex)++-- | newRelabelling prs - make a relabelling from a finite list of vertex pairs.+-- The first item in each pair relabels to the second in the pair.+-- The resulting relabelling excludes any identity mappings of vertices.+-- An error is raised if second items of the pairs contain duplicated numbers or a number<1+newRelabelling :: [(Vertex,Vertex)] -> Relabelling+newRelabelling prs +    | wrong (map snd prs) = error $ "newRelabelling: Not 1-1 or Non-positive label in range " ++ show prs+    | otherwise = Relabelling $ VMap.fromList $ differing prs+  where wrong vs = any (<1) vs || not (null (duplicates vs))++-- | relabellingFrom n vs - make a relabelling from finite set of vertices vs.+-- Elements of vs are ordered and relabelled from n upwards (an error is raised if n<1).+-- The resulting relabelling excludes any identity mappings of vertices.+relabellingFrom :: Int -> VertexSet -> Relabelling+relabellingFrom n vs +    | n<1 = error $ "relabellingFrom: Label not positive " ++ show n+    | otherwise = Relabelling $ VMap.fromAscList $ differing $ zip (IntSet.elems vs) [n..] ++-- | f1 \`relabellingTo\` f2  - creates a relabelling so that+-- if applied to face f1, the vertices will match with face f2 exactly.+-- It does not check that the tile faces have the same form (LK,RK,LD,RD).+relabellingTo :: TileFace -> TileFace -> Relabelling+f1 `relabellingTo` f2 = newRelabelling $ zip (faceVList f1) (faceVList f2) -- f1 relabels to f2++-- | Combine relabellings (assumes disjoint representation domains and disjoint representation ranges but+-- no check is made for these).+relabelUnion:: Relabelling -> Relabelling -> Relabelling+relabelUnion (Relabelling r1) (Relabelling r2) = Relabelling $ VMap.union r1 r2 +++{-|relabelToMatch (g1,e1) (g2,e2)  produces a relabelled version of g2 that is+consistent with g1 on a single tile-connected region of overlap.+The overlapping region must contain the directed edge e1 in g1. The edge e2 in g2+will be identified with e1 by the relabelling of g2.+This produces an error if a mismatch is found anywhere in the overlap.++CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1.+If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1+will be tile-connected but may have touching vertices.+This limitation is addressed by fullUnion. +-}+relabelToMatch:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph+relabelToMatch ge1 ge2 = runTry $ tryRelabelToMatch ge1 ge2+ +{-|tryRelabelToMatch (g1,e1) (g2,e2) produces either Right g where g is a relabelled version of g2 that is+consistent with g1 on an overlapping tile-connected region or Left lines if there is a mismatch (lines explaining the problem).+The overlapping region must contain the directed edge e1 in g1. The edge e2 in g2+will be identified with e1 by the relabelling of g2.++CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1.+If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1+will be tile-connected but may have touching vertices.    +This limitation is addressed by tryFullUnion. +-}+tryRelabelToMatch :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph+tryRelabelToMatch (g1,(x1,y1)) (g2,(x2,y2)) = onFail "tryRelabelToMatch:\n" $ +  do let g2prepared = prepareFixAvoid [x2,y2] (vertexSet g1) g2+     fc2 <- find (`hasDedge` (x2,y2)) (faces g2prepared)+            `nothingFail` ("No face found for edge " ++ show (x2,y2))                      +     maybef <- tryMatchFace (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1+     fc1 <- maybef `nothingFail` +                   ("No matching face found at edge "++show (x1,y1)+++                    "\nfor relabelled face " ++ show fc2)  +  -- assert g2prepared has no labels in common with g1 except possibly those in fc2+     tryRelabelFromFaces (g1,fc1) (g2prepared,fc2)++{-|tryRelabelFromFaces is an auxiliary function for tryRelabelToMatch.+tryRelabelFromFaces (g1,fc1) (g2,fc2) - fc1 and fc2 should have the same form (RK,LK,RD,LD),+with fc1 a face in g1 and fc2 a face in g2.+g2 must have no vertices in common with g1 except for (possibly) vertices in fc2.+The result is either Right g3 where+g3 is a relabelling of g2 which is consistent with g1 in a single region of overlap containing fc1 if this is possible, or+Left lines if there is a mismatch (lines explaining the problem).+In the successful case fc2 will be relabelled to fc1.++CAVEAT: Only the single tile-connected region of common overlap (containing fc2) of g2 gets relabelled+to match with g1.+-}+tryRelabelFromFaces :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Try Tgraph+tryRelabelFromFaces (g1,fc1) (g2,fc2) = onFail "tryRelabelFromFaces:\n" $ +   do rlab <- tryGrowRelabel g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1)+      return $ relabelGraph rlab g2+      +{-|tryGrowRelabel is used by tryRelabelFromFaces to build a relabelling map which can fail, producing Left lines.+In the successful case it produces a Right rlab+where rlab is the required relabelling. +The arguments are:  g processing awaiting rlab where+g is the Tgraph being matched against;+processing is a list of faces to be matched next+(each has an edge in common with at least one previously matched face or it is the starting face);+awaiting is a list of faces that have not yet been tried for a match and are not+tile-connected to any faces already matched.+rlab is the relabelling so far.++The idea is that from a single matched starting face we process faces that share an edge with a+previously matched face. Each face processed should have a match in g (with 2 matching vertices).+If a face is tried but has no such match, it is ignored (it may share some boundary with g, but+for the overlap to be a single tile-connected region, only boundaries with matched tiles are possible+and therefore relabelling will already be done for the boundary).+If a processed face has an edge in common with a face in g it has to match exactly+apart from (possibly) the third vertex label,+otherwise the faces do not match and this+indicates a mismatch on the overlap and Left ... is returned.+-}+tryGrowRelabel:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling+tryGrowRelabel _ [] _ rlab = Right rlab -- awaiting are not tile-connected to overlap region+tryGrowRelabel g (fc:fcs) awaiting rlab = +  do maybef <- tryMatchFace (relabelFace rlab fc) g+     case maybef of+       Nothing   -> tryGrowRelabel g fcs awaiting rlab+       Just orig -> tryGrowRelabel g (fcs++fcs') awaiting' rlab'+                    where (fcs', awaiting') = partition (edgeNb fc) awaiting+                          rlab' = relabelUnion (fc `relabellingTo` orig) rlab++++-- |same as relabelToMatch but ignores non-matching faces (except for the initial 2)+-- The initial 2 faces are those on the given edges, and an error is raised if they do not match.+-- This is used by commonFaces+relabelToMatchIgnore :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph+relabelToMatchIgnore (g1,(x1,y1)) (g2,(x2,y2)) = relabelFromFacesIgnore (g1,fc1) (g2prepared,fc2) where+  g2prepared = prepareFixAvoid [x2,y2] (vertexSet g1) g2+  fc2 = case find (`hasDedge` (x2,y2)) (faces g2prepared) of+           Nothing -> error $ "No face found for edge " ++ show (x2,y2)+           Just f -> f                      +  fc1 = case matchFaceIgnore (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1 of+           Nothing -> error $ "No matching face found at edge "++show (x1,y1)+++                              "\nfor relabelled face " ++ show fc2+           Just f -> f+   ++{-| relabelFromFacesIgnore is an auxiliary function for relabelToMatchIgnore.+It is similar to tryRelabelFromFaces except that it uses growRelabelIgnore and matchFaceIgnore+which ignores non-matching faces rather than failing. It thus returns a definite relabelled Tgraph.+tryRelabelFromFaces (g1,fc1) (g2,fc2) - fc1 and fc2 should have the same form (RK,LK,RD,LD),+with fc1 a face in g1 and fc2 a face in g2.+g2 must have no vertices in common with g1 except for (possibly) vertices in fc2.+The result is g3 where+g3 is a relabelling of g2 which is consistent with g1 in a common single region of overlap containing fc1.++CAVEAT: Only the single tile-connected region of common overlap (containing fc2) of g2 gets relabelled+to match with g1.+-}+relabelFromFacesIgnore :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Tgraph+relabelFromFacesIgnore (g1,fc1) (g2,fc2) = relabelGraph rlab g2 where+    rlab = growRelabelIgnore g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1)++-- |growRelabelIgnore is similar to tryGrowRelabel except that it uses matchFaceIgnore (instead of tryMatchFace)+-- which ignores non-matching faces rather than failing. It thus returns a definite Relabelling.+growRelabelIgnore:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling+growRelabelIgnore _ [] _ rlab = rlab -- awaiting are not tile-connected to overlap region+growRelabelIgnore g (fc:fcs) awaiting rlab = +     case matchFaceIgnore (relabelFace rlab fc) g of+       Nothing   -> growRelabelIgnore g fcs awaiting rlab+       Just orig -> growRelabelIgnore g (fcs++fcs') awaiting' rlab'+                    where (fcs', awaiting') = partition (edgeNb fc) awaiting+                          rlab' = relabelUnion (fc `relabellingTo` orig) rlab+++-- |relabelGraph rlab g - uses a Relabelling rlab to change vertices in a Tgraph g.+-- Caveat: This should only be used when it is known that:+-- rlab is 1-1 on its (representation) domain, and+-- the vertices of g are disjoint from those vertices that are in the representation range+-- but which are not in the representation domain of rlab.+-- This ensures rlab (extended with the identity) remains 1-1 on vertices in g,+-- so that the resulting Tgraph does not need an expensive check for Tgraph properties.+-- (See also checkRelabelGraph)+relabelGraph:: Relabelling -> Tgraph -> Tgraph+relabelGraph rlab g = makeUncheckedTgraph newFaces where+   newFaces = fmap (relabelFace rlab) (faces g) ++-- |checkRelabelGraph uses a relabelling map to change vertices in a Tgraph,+-- then checks that the result is a valid Tgraph. (see also relabelGraph)+checkRelabelGraph:: Relabelling -> Tgraph -> Tgraph+checkRelabelGraph rlab g = checkedTgraph newFaces where+   newFaces = fmap (relabelFace rlab) (faces g) ++-- |Uses a relabelling to relabel the three vertices of a face.+-- Any vertex not in the domain of the mapping is left unchanged.+-- The mapping should be 1-1 on the 3 vertices to avoid creating a self loop edge.+relabelFace:: Relabelling -> TileFace -> TileFace+relabelFace rlab = fmap (all3 (relabelV rlab)) where -- fmap of HalfTile Functor+  all3 f (a,b,c) = (f a,f b,f c)++-- |relabelV rlab v - uses relabelling rlab to find a replacement for v (leaves as v if none found).+-- I.e relabelV turns a Relabelling into a total function using identity+-- for undefined cases in the Relabelling representation. +relabelV:: Relabelling -> Vertex -> Vertex+relabelV (Relabelling r) v = VMap.findWithDefault v v r++-- |relabelAvoid avoid g - produces a new Tgraph from g by relabelling.+-- Any vertex in g that is in the set avoid will be changed to a new vertex that is+-- neither in g nor in the set avoid. Vertices in g that are not in avoid will remain the same.+relabelAvoid :: VertexSet -> Tgraph -> Tgraph+relabelAvoid avoid g = relabelGraph rlab g where+  gverts = vertexSet g+  avoidMax = if IntSet.null avoid then 0 else IntSet.findMax avoid+  vertsToChange = gverts `IntSet.intersection` avoid+  rlab = relabellingFrom (1+ max (maxV g) avoidMax) vertsToChange+  -- assert: rlab is 1-1 on the vertices of g+  -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does)+  -- assert: the relabelled Tgraph does not have vertices in the set avoid++  +{-|prepareFixAvoid fix avoid g - produces a new Tgraph from g by relabelling.+ Any vertex in g that is in the set avoid but not in the list fix will be changed to a new vertex that is+ neither in g nor in the set (avoid with fix removed).+ All other vertices of g (including those in fix) will remain the same.+ Usage: This is used to prepare a graph by avoiding accidental label clashes with the avoid set+ (usually vertices of another graph).+  However we fix a list of vertices which we intend to control in a subsequent relabelling.+  (this is usually a pair of vertices from a directed edge that will get a specific subsequent relabelling).+Note: If any element of the list fix is not a vertex in g, it could end up in the relabelled Tgraph.+-}+prepareFixAvoid :: [Vertex] -> VertexSet -> Tgraph -> Tgraph+prepareFixAvoid fix avoid = relabelAvoid (avoid IntSet.\\ IntSet.fromList fix)+  -- assert: the relabelled Tgraph satisfies Tgraph properties (if the argument Tgraph does)+  -- assert: the relabelled Tgraph does not have vertices in the set (avoid\\fix)++-- |Relabel all vertices in a Tgraph using new labels 1..n (where n is the number of vertices).+relabelContig :: Tgraph -> Tgraph+relabelContig g = relabelGraph rlab g where+   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),+If the corresponding face does not match properly (with twoVMatch) this stops the+matching process returning Left ... to indicate a failed match.+Otherwise it returns either Right (Just f) where f is the matched face or+Right Nothing if there is no corresponding face.+-}+tryMatchFace:: TileFace -> Tgraph -> Try (Maybe TileFace)  +tryMatchFace face g = onFail "tryMatchFace:\n" $+  case find (`hasDedgeIn` faceDedges face) (faces g) of+    Nothing      -> Right Nothing+    Just corresp -> if twoVMatch corresp face+                    then Right $ Just corresp+                    else Left $ "Found non matching faces " ++ show (corresp, face) ++ "\n"++-- |twoVMatch f1 f2 is True if the two tilefaces are the same except+-- for a single vertex label possibly not matching.+twoVMatch:: TileFace -> TileFace -> Bool+twoVMatch f1 f2 = isMatched f1 f2 &&+                  if firstV f1 == firstV f2+                  then secondV f1 == secondV f2 || thirdV f1 == thirdV f2+                  else secondV f1 == secondV f2 && thirdV f1 == thirdV f2++{-|A version of tryMatchFace that just ignores mismatches.+matchFaceIgnore f g - looks for a face in g that corresponds to f (sharing a directed edge),+If there is a corresponding face f' which matches label and corresponding directed edge then Just f' is returned+Otherwise Nothing is returned. (Thus ignoring a clash)+-}+matchFaceIgnore:: TileFace -> Tgraph -> Maybe TileFace  +matchFaceIgnore face g = case tryMatchFace face g of+   Right mf -> mf+   Left _   -> Nothing+   ++-- |selects only non-matching pairs from a list+differing :: Eq a => [(a,a)] -> [(a,a)]+differing = filter (\(a,b) -> a/=b)+

@@ -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 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

@@ -0,0 +1,459 @@++{-|+Module      : TgraphExamples+Description : Examples of tilings represented with Tgraphs and their diagrams +Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TupleSections             #-}++module TgraphExamples+  (-- * Some Layout tools+    padBorder+  , chunks+  , arrangeRowsGap+  , arrangeRows+  , labelAt+    -- *  Tgraphs for 7 vertex types+  , sunGraph +  , jackGraph+  , kingGraph+  , queenGraph+  , aceGraph+  , deuceGraph+  , starGraph+    -- *  Further Basic Tgraphs+  , kiteGraph+  , dartGraph+  , fool+  , foolD+  , foolDminus+  , foolDs+  , sunDs+  , kiteDs+  , dartDs+  , dartD4  +  , sun3Dart +    -- *  Some Simple Figures+  , foolFig+  , foolAndFoolD+  , figSunD3D2+    -- *  Figures for 7 vertex types+  , vertexTypesFig+  , forceVFigures+    -- * Partial Composition figures+  , pCompFig1+  , pCompFig2+  , pCompFig+    -- * Forced Tgraph figures+  , forceFoolDminus+  , forceDartD5Fig+  , forceKiteD5Fig+  , forceSunD5Fig+  , forceFig+    -- *  Removed faces (forcing and composing)+  , brokenDart+  , badlyBrokenDart+  , brokenDartFig+  , badlyBrokenDartFig+  , removeIncompletesFig+    -- *  Incorrect Tgraphs+  , mistake+  , mistake1+    -- * superForce Figure+  , superForceFig+  , superForceRocketsFig+    -- *  Tgraphs with Boundary faces+  , boundaryFDart4+  , boundaryFDart5+  , boundaryFDart4Fig+  , boundaryFDart5Fig+  , boundaryGapFDart4+  , boundaryGapFDart5+  , boundaryGap4Fig+  , boundaryGap5Fig+    -- *  Boundary coverings and empires+ , boundaryVCoveringFigs+ , boundaryECoveringFigs+ , kingECoveringFig+ , kingVCoveringFig + , kingEmpiresFig+ , kingEmpire1Fig+ , kingEmpire2Fig+ +  ) where++import Diagrams.Prelude+import Diagrams.TwoD.Text (Text)+-- import ChosenBackend (B)+import TileLib+import Tgraphs++++-- |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 = pad 1.2 . centerXY++-- |chunks n l -  split a list l into chunks of length n (n>0)+chunks::Int -> [a] -> [[a]]+chunks n+  | n < 1 = error "chunks: argument <1\n"+  | otherwise = ch where+      ch [] = []+      ch as = take n as : ch (drop n as)++-- |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 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 = 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 p l d = baselineText l # fontSize (output 15) # moveTo p <> d+--labelAt p l d = baselineText l # fontSize (normalized 0.02) # moveTo p <> d+++fool, foolD, foolDminus:: Tgraph+-- |fool: fool's kite - also called an ace.+fool = makeTgraph [RK (5,2,7),LK (5,6,4),RK (5,4,3),LK (5,3,2),RD (1,2,3),LD (1,3,4)]+-- fool = makeTgraph [ RD (1,2,3), LD (1,3,4), RK (6,2,5), LK (6,3,2), RK (6,4,3), LK (6,7,4)]++-- |a once decomposed fool (= foolDs!!1)+foolD = decompose fool++-- |foolDminus: 3 faces removed from foolD - still a valid Tgraph+foolDminus = removeFaces [RD (5,15,13), LD (5,16,15), RK (7,11,2)] foolD+-- foolDminus = removeFaces [RD (6,15,13), LD (6,17,15), RK (5,11,2)] foolD++-- | an infinite list of decompositions of fool+foolDs :: [Tgraph]+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 = 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 = padBorder $ hsep 1 [scale phi $ labelled drawj fool, labelled drawj foolD]++-- |Tgraph for a sun (sun vertex type)+sunGraph :: Tgraph+sunGraph = makeTgraph+             [ RK (1,2,11), LK (1,3,2)+             , RK (1,4,3) , LK (1,5,4)+             , RK (1,6,5) , LK (1,7,6)+             , RK (1,8,7) , LK (1,9,8)+             , RK (1,10,9), LK (1,11,10)+             ]+-- | an infinite list of decompositions of sunGraph+sunDs :: [Tgraph]+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 = padBorder $ hsep 1 [labelled drawj $ sunDs !! 3, scale phi $ labelled drawj $ sunDs !! 2]++-- |Tgraph for kite+kiteGraph :: Tgraph+kiteGraph = makeTgraph [ RK (1,2,4), LK (1,3,2)]++-- | an infinite list of decompositions of a kite+kiteDs :: [Tgraph]+kiteDs = decompositions kiteGraph++-- |Tgraph for a dart+dartGraph :: Tgraph+dartGraph =  makeTgraph [ RD (1,2,3), LD (1,3,4)]++-- | an infinite list of decompositions of a dart+dartDs :: [Tgraph]+dartDs =  decompositions dartGraph++-- |Tgraph of 4 times decomposed dartGraph (used in several examples)+dartD4 :: Tgraph+dartD4 = dartDs!!4+++++pCompFig1,pCompFig2,pCompFig :: Renderable (Path V2 Double) b => Diagram2D 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 = padBorder $ hsep 1 $ fmap (labelled drawj) [foolDminus, force foolDminus]+++forceDartD5Fig,forceKiteD5Fig,forceSunD5Fig,forceFig :: Renderable (Path V2 Double) b => Diagram2D 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.+-- Forcing will repair to produce the same Tgraph as force dartD4.+-- This graph can also be repeatedly composed (without forcing) to get a maximal Tgraph.+brokenDart :: Tgraph+brokenDart = removeFaces deleted dartD4 where+  deleted = [RK (2,16,33),LD (15,33,16),RK (16,66,15),LK (16,67,66),LK (5,15,66)]++{-| badlyBrokenDart has more faces removed from brokenDart.+This will also get repaired by forcing (to produce the same as force dartD4).+However it will fail to produce a valid Tgraph if composed twice without forcing. +-}+badlyBrokenDart :: Tgraph+badlyBrokenDart = removeFaces deleted bbd where+  deleted = [RK (6,28,54)]+  bbd = removeVertices [63,37] brokenDart+--  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 = 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 = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [vp, vpComp, vpFailed] where+    vp = makeVP badlyBrokenDart+    comp = compose badlyBrokenDart+    vpComp = restrictVP vp $ faces $ comp+    vpFailed  = restrictVP vp $ composedFaces comp++-- |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 = padBorder $ drawj $ removeFaces (boundaryJoinFaces g) g where +    g = sunDs !! 3+++-- |mistake is a legal but incorrect Tgraph - a kite with 2 darts on its long edges+mistake:: Tgraph+mistake = makeTgraph [RK (1,2,4), LK (1,3,2), RD (3,1,5), LD (4,6,1), LD (3,5,7), RD (4,8,6)]++-- |mistake1 is a kite bordered by 2 half darts (subgraph of mistake and still incorrect)+mistake1:: Tgraph+mistake1 = makeTgraph [RK (1,2,4), LK (1,3,2), RD (3,1,5), LD (4,6,1)]++-- *  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 = padBorder $ hsep 1 lTypeFigs+ where+ lTypeFigs = zipWith (labelAt (p2 (0,-2.2))) ["sun","star","jack","queen","king","ace","deuce"] vTypeFigs+ vTypeFigs = zipWith drawVertex+               [sunGraph, starGraph, jackGraph, queenGraph, kingGraph, aceGraph,  deuceGraph]+               [(1,2),    (1,2),     (1,2),     (1,2),      (1,2),     (3,6),     (2,6)] -- alignments+ drawVertex g alm = alignBefore (lw thin . showOrigin . drawj) alm g++jackGraph,kingGraph,queenGraph,aceGraph,deuceGraph,starGraph::Tgraph+-- |Tgraph for vertex type jack.+jackGraph = makeTgraph+  [LK (1,9,11),RK (1,11,2),LK (7,8,1),RD (9,1,8),RK (1,3,4)+  ,LK (1,2,3),RK (7,1,5),LD (4,5,1),LD (9,8,10),RD (4,6,5)+  ] -- centre 1+-- |Tgraph for vertex type king.+kingGraph = makeTgraph+  [LD (1,2,3),RD (1,11,2),LD (1,4,5),RD (1,3,4),LD (1,10,11)+  ,RD (1,9,10),LK (9,1,7),RK (9,7,8),RK (5,7,1),LK (5,6,7)+  ] -- centre 1+-- |Tgraph for vertex type queen.+queenGraph = makeTgraph+  [LK (7,1,5),RK (3,5,1),LD (1,2,3),RK (7,9,1),LK (11,1,9)+  ,RD (1,11,2),RK (7,5,6),LK (7,8,9),LK (3,4,5),RK (11,9,10)+  ] -- centre 1+-- |Tgraph for vertex type ace (same as fool).+aceGraph = fool -- centre 3+-- |Tgraph for vertextype deuce.+deuceGraph = makeTgraph+  [LK (7,8,2),RK (7,2,6),RK (5,2,4),LK (5,6,2),LD (1,4,2)+  ,RD (1,2,8),RD (1,3,4),LD (1,8,9)+  ] -- centre 2+-- |Tgraph for vertex type star.+starGraph = makeTgraph+  [LD (1,2,3),RD (1,11,2),LD (1,10,11),RD (1,9,10),LD (1,8,9)+  ,RD (1,7,8),LD (1,6,7),RD (1,5,6),LD (1,4,5),RD (1,3,4)+  ] -- 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 = rotations [0,0,9,5,0,0,1] $+                fmap (center . drawForce) [sunGraph,starGraph,jackGraph,queenGraph,kingGraph,aceGraph,deuceGraph]+++sun3Dart :: Tgraph+-- |A sun with 3 darts on the boundary NOT all adjacent+-- (Used in superForceRocketsFig).+sun3Dart = addHalfDart (9,10) $ addHalfDart (8,9) $ addHalfDart (5,6) $ addHalfDart (4,5) $ addHalfDart (3,4) $ addHalfDart (2,3) sunGraph+-- sun3Dart = addHalfDart (9,10) $ addHalfDart (8,9) sun2AdjDart+++-- |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 = 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 = padBorder $ lw veryThin $ vsep 1 $ rotations [8,9,9,8] $+   fmap drawSuperForce decomps where+      decomps = take 4 $ decompositions sun3Dart+++boundaryFDart4, boundaryFDart5 :: Tgraph+-- |graph of the boundary faces only of a forced graph (dartDs!!4)+boundaryFDart4 = checkedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4+-- |graph of the boundary faces only of a forced graph (dartDs!!5)+boundaryFDart5 = checkedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5)++boundaryFDart4Fig,boundaryFDart5Fig :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D 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+-- |graph of the boundary faces only of a forced graph - with extra faces removed to make a gap+boundaryGapFDart4 = removeVertices [354] boundaryFDart4+    -- checkedTgraph $ filter ((/=354).originV)  (faces boundaryFDart4)+-- |graph of the boundary faces only of a forced graph - with extra faces removed to make a gap+boundaryGapFDart5 = removeVertices [1467] boundaryFDart5+    -- checkedTgraph $ filter ((/=1467).originV) (faces boundaryFDart5)++boundaryGap4Fig, boundaryGap5Fig  :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => Diagram2D 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 bd =+    fmap (lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph) $ boundaryVCovering bd+      where redg = lc red $ draw g --alignBefore draw alig g+            alig = defaultAlignment g+            g = recoverGraph bd++-- | 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 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+-- | 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+-- | 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

@@ -0,0 +1,810 @@+{-|+Module      : Tgraphs+Description : Collects and exports the various Tgraph modules plus extra operations, including makeTgraph+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).+-}+-- {-# OPTIONS_HADDOCK ignore-exports #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE FlexibleInstances         #-} -- needed for Drawable Patch+-- {-# LANGUAGE TypeOperators             #-} -- needed for type equality constraints ~++module Tgraphs+  ( module Tgraph.Prelude+  , module Tgraph.Decompose+  , 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+  , drawJoinsFor+  , smartdraw+  , restrictSmart+  , smartRotateBefore+  , smartAlignBefore+    -- * Overlaid drawing tools for Tgraphs+  , drawPCompose+  , drawForce+  , drawSuperForce+  , drawWithMax+  , addBoundaryAfter+  , drawCommonFaces+  , emphasizeFaces+    -- * Combining force, compose, decompose+  , composeK+  , compForce+  , allCompForce+  , maxCompForce+  , forceDecomp+  , allForceDecomps+    -- * Emplace Choices+  , emplaceChoices+--  , emplaceChoices'  +    -- * Boundary Covering and Empires+  , forcedBoundaryECovering+  , forcedBoundaryVCovering+  , boundaryECovering+  , boundaryEdgeSet+  , commonBdry+  , boundaryVCovering+  , boundaryVertexSet+  , internalVertexSet+  , tryDartAndKiteForced+  , tryDartAndKite+  , drawFBCovering+  , empire1+  , empire2+  , empire2Plus+  , drawEmpire+  , showEmpire1+  , showEmpire2+    -- * Super Force with boundary edge covers+  , superForce+  , trySuperForce+  , singleChoiceEdges+    -- * Boundary loops+  , boundaryLoopsG+  , boundaryLoops+  , findLoops+  , pathFromBoundaryLoops+    -- * TrackedTgraphs+  , TrackedTgraph(..)+  , newTrackedTgraph+  , makeTrackedTgraph+  , trackFaces+  , unionTwoTracked+    -- * Forcing and Decomposing TrackedTgraphs+  , addHalfDartTracked+  , addHalfKiteTracked+  , decomposeTracked+    -- *  Drawing TrackedTgraphs+  , drawTrackedTgraph+  , drawTrackedTgraphRotated+  , 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+import Tgraph.Force+import Tgraph.Relabelling+import Diagrams.Prelude hiding (union)+import TileLib++import Data.List (intersect, union, (\\), find, foldl',nub, 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:+-- +-- smart draw g+--+-- 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 dr g = drawJoinsFor (boundaryJoinFaces g) vp <> dr vp+  where vp = makeVP g++-- |select the halftile faces of a Tgraph with a join edge on the boundary.+-- Useful for drawing join edges only on the boundary.+boundaryJoinFaces :: Tgraph -> [TileFace]+boundaryJoinFaces g = fmap snd $ incompleteHalves bdry $ boundary bdry where+    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 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 = 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 g dr vp = drawJoinsFor (boundaryJoinFaces g) rvp <> dr rvp+                        where rvp = restrictVP vp $ faces g++-- |smartRotateBefore vfun a g - a tricky combination of smart with rotateBefore.+-- Uses vfun to produce a Diagram after converting g to a rotated VPatch but also adds the dashed boundary join edges of g.+--+-- 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 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 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 g = +    restrictSmart g' draw vp+    <> drawj (subVP vp remainder) # lw medium # lc lime+    where (remainder,g') = partCompose g+          vp = makeVP g++-- |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 g = +    restrictSmart g draw vp # lc red # lw medium +    <> draw vp+    where vp = makeVP $ force g++-- |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 g = (dg # lc red) <> dfg <> (dsfg # lc blue) where+    sfg = superForce g+    fg = force g+    vp = makeVP $ superForce g+    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 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+    maxg = maxCompForce g+    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 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 (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 fcs g =  (drawj emphvp # lw thin) <> (draw vp # lw ultraThin) where+    vp = makeVP g+    emphvp = subVP vp (fcs `intersect` faces g)+++ ++-- | An unsound version of composition which defaults to kites when there are choices (unknowns).+-- This is unsound in that it can create an incorrect Tgraph from a correct Tgraph.+composeK :: Tgraph -> Tgraph+composeK g = runTry $ tryConnectedNoCross newfaces where+    dwInfo = getDartWingInfo g+    changedInfo = dwInfo{ largeKiteCentres = largeKiteCentres dwInfo ++ unknowns dwInfo+                        , unknowns = []+                        }+    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.+-- 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.+compForce:: Tgraph -> Tgraph+compForce = uncheckedCompose . force +        +-- |allCompForce g produces a list of the non-null iterated forced compositions of 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 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]+allCompForce = takeWhile (not . nullGraph) . iterate uncheckedCompose . force++-- |maxCompForce g produces the maximally composed (non-null) Tgraph starting from force g, provided g is not the emptyTgraph+-- and just the emptyTgraph otherwise.+-- It will raise an error if the initial force fails with an incorrect Tgraph.+maxCompForce:: Tgraph -> Tgraph+maxCompForce g | nullGraph g = g+               | otherwise = last $ allCompForce g+++-- |force after a decomposition+forceDecomp:: Tgraph -> Tgraph+forceDecomp = force . decompose++-- | allForceDecomps g - produces an infinite list of forced decompositions of g+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++++{-| 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).+(So the boundary of force g is entirely internal edges in each cover).+The covers include all possible ways faces can be added on the boundary that are correct.+The common faces of the covers constitute the empire (level 1) of g.+This will raise an error if the initial force fails with a stuck graph.+-}+forcedBoundaryECovering:: Tgraph -> [Tgraph]+forcedBoundaryECovering g = recoverGraph <$> boundaryECovering gforcedBdry where+     gforcedBdry = runTry $ onFail "forcedBoundaryECovering:Initial force failed (incorrect Tgraph)\n" $+                             tryForce $ makeBoundaryState g++{-| forcedBoundaryVCovering g - produces a list of all boundary covers of force g as with+forcedBoundaryECovering g but covering all boundary vertices rather than just boundary edges.                        +-}+forcedBoundaryVCovering:: Tgraph -> [Tgraph]+forcedBoundaryVCovering g = recoverGraph <$> boundaryVCovering gforcedBdry where+     gforcedBdry = runTry $ onFail "forcedBoundaryVCovering:Initial force failed (incorrect Tgraph)\n" $+                             tryForce $ makeBoundaryState g++{-| boundaryECovering bd - produces a list of all possible covers of the boundary directed edges in bd.+[bd should be a boundary state resulting from forcing].+A cover is a forced extension (of bd) such that the original boundary directed edges of bd are all internal edges.+Extensions are made by repeatedly adding a face to any edge on the original boundary that is still on the boundary+and forcing, repeating this until the orignal boundary is all internal edges.+The resulting covers account for all possible ways the boundary can be extended.+This can raise an error if bd is a boundary state of an unforced Tgraph.+It will raise an error if both choices on a boundary edge fail when forced (using atLeastOne).+-}+boundaryECovering:: BoundaryState -> [BoundaryState]+boundaryECovering bstate = covers [(bstate, boundaryEdgeSet bstate)] where+  covers:: [(BoundaryState, Set.Set Dedge)] -> [BoundaryState]+  covers [] = []+  covers ((bs,es):opens) +    | Set.null es = bs:covers opens -- bs is a completed cover+    | otherwise = covers (newcases ++ opens)+       where (de,des) = Set.deleteFindMin es+             newcases = fmap (\b -> (b, commonBdry des b))+                             (atLeastOne $ tryDartAndKiteForced de bs)++-- |Make a set of the directed boundary edges of a BoundaryState+boundaryEdgeSet:: BoundaryState -> Set.Set Dedge+boundaryEdgeSet = Set.fromList . boundary++-- | commonBdry des b - returns those directed edges in des that are boundary directed edges of bd+commonBdry:: Set.Set Dedge -> BoundaryState -> Set.Set Dedge+commonBdry des b = des `Set.intersection` boundaryEdgeSet b++{-| boundaryVCovering bd - similar to boundaryECovering, but produces a list of all possible covers of +    the boundary vertices in bd (rather than just boundary edges).+    [bd should be a boundary state resulting from forcing].+    This can raise an error if bd is a boundary state of an unforced Tgraph.+-}+boundaryVCovering:: BoundaryState -> [BoundaryState]+boundaryVCovering bd = covers [(bd, startbds)] where+  startbds = boundaryEdgeSet bd+  startbvs = boundaryVertexSet bd+--covers:: [(BoundaryState,Set.Set Dedge)] -> [BoundaryState]+  covers [] = []+  covers ((open,es):opens) +    | Set.null es = case find (\(a,_) -> IntSet.member a startbvs) (boundary open) of+        Nothing -> open:covers opens+        Just dedge -> covers $ fmap (\b -> (b, es))  (atLeastOne $ tryDartAndKiteForced dedge open) ++opens+    | otherwise =  covers $ fmap (\b -> (b, commonBdry des b)) (atLeastOne $ tryDartAndKiteForced de open) ++opens  +                   where (de,des) = Set.deleteFindMin es++-- | returns the set of boundary vertices of a BoundaryState+boundaryVertexSet :: BoundaryState -> VertexSet+boundaryVertexSet bd = IntSet.fromList $ fmap fst (boundary bd)++-- | returns the set of internal vertices of a BoundaryState+internalVertexSet :: BoundaryState -> VertexSet+internalVertexSet bd = vertexSet (recoverGraph bd) IntSet.\\ boundaryVertexSet bd++                  +-- | 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.+tryDartAndKiteForced:: Forcible a => Dedge -> a -> [Try a]+tryDartAndKiteForced de b = +    [ onFail ("tryDartAndKiteForced: Dart on edge: " ++ show de ++ "\n") $ +        tryAddHalfDart de b >>= tryForce+    , onFail ("tryDartAndKiteForced: Kite on edge: " ++ show de ++ "\n") $ +        tryAddHalfKite de b >>= tryForce+    ]++-- | 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.+tryDartAndKite:: Forcible a => Dedge -> a -> [Try a]+tryDartAndKite de b = +    [ onFail ("tryDartAndKite: Dart on edge: " ++ show de ++ "\n") $ +        tryAddHalfDart de b+    , onFail ("tryDartAndKite: Kite on edge: " ++ show de ++ "\n") $ +        tryAddHalfKite de b+    ]+++-- | 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 g = lw ultraThin $ vsep 1 (draw <$> forcedBoundaryVCovering g)++-- | empire1 g - produces a TrackedTgraph representing the level 1 empire of g.+-- The tgraph of the result is the first boundary vertex cover of force g,+-- and the tracked list of the result has the common faces of all the boundary vertex covers (of force g)+-- at the head, followed by the original faces of g.+empire1:: Tgraph -> TrackedTgraph+empire1 g = makeTrackedTgraph g0 [fcs,faces g] where+    covers = forcedBoundaryVCovering g+    g0 = head covers+    others = tail covers+    fcs = foldl' intersect (faces g0) $ fmap g0Intersect others+    de = defaultAlignment g+    g0Intersect g1 = commonFaces (g0,de) (g1,de)++-- | empire2 g - produces a TrackedTgraph representing the level 2 empire of g.+-- NB since very large graphs can be generated with boundary vertex covers, we use boundary edge covers only.+-- That is, after finding all boundary edge covers of force g, +-- boundary edge covers are then found for each boundary edge cover to form a list of doubly-extended+-- boundary edge covers.+-- The tgraph of the result is the first (doubly-extended) boundary edge cover (of force g),+-- and the tracked list of the result has the common faces of all the (doubly-extended) boundary edge covers+-- at the head, followed by the original faces of g.+empire2:: Tgraph -> TrackedTgraph+empire2 g = makeTrackedTgraph g0 [fcs, faces g] where+    covers1 = boundaryECovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" +              $ tryForce $ makeBoundaryState g+    covers2 = concatMap boundaryECovering covers1+--    (g0:others) = fmap recoverGraph covers2+    gcovers = fmap recoverGraph covers2+    g0 = head gcovers+    others = tail gcovers+    fcs = foldl' intersect (faces g0) $ fmap g0Intersect others+    de = defaultAlignment g+    g0Intersect g1 = commonFaces (g0,de) (g1,de)++-- | empire2Plus g - produces a TrackedTgraph representing an extended level 2 empire of g+-- similar to empire2, but using boundaryVCovering insrtead of boundaryECovering.+empire2Plus:: Tgraph -> TrackedTgraph+empire2Plus g = makeTrackedTgraph g0 [fcs, faces g] where+    covers1 = boundaryVCovering $ runTry $ onFail "empire2:Initial force failed (incorrect Tgraph)\n" +              $ tryForce $ makeBoundaryState g+    covers2 = concatMap boundaryVCovering covers1+--    (g0:others) = fmap recoverGraph covers2+    gcovers = fmap recoverGraph covers2+    g0 = head gcovers+    others = tail gcovers+    fcs = foldl' intersect (faces g0) $ fmap g0Intersect others+    de = defaultAlignment g+    g0Intersect g1 = commonFaces (g0,de) (g1,de)++-- | drawEmpire e - produces a diagram for an empire e represented as a TrackedTgraph+-- 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 = +    drawTrackedTgraph  [ lw ultraThin . draw+                       , lw thin . fillDK lightgrey lightgrey+                       , lw thin . lc red . draw+                       ]++-- | 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 = 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 = drawEmpire . empire2++-- |superForce g - after forcing g this looks for single choice boundary edges.+-- That is a boundary edge for which only a dart or only a kite addition occurs in all boundary edge covers.+-- If there is at least one such edge, it makes the choice for the first such edge and recurses,+-- otherwise it returns the forced result.+-- This will raise an error if force encounters a stuck (incorrect) tiling or if+-- both forced extensions fail for some boundary edge.+-- Otherwise, the result has exactly two correct possible extensions for each boundary edge.+superForce:: Forcible a => a -> a+superForce g = runTry $ trySuperForce g++-- |trySuperForce g - this looks for single choice edges after trying to force g.+-- If there is at least one, it makes that choice and recurses.+-- It returns a Left s if force fails or if both choices fail for some edge (where s is a failure report).+-- Otherwise Right g' is returned where g' is the super forced g.+trySuperForce:: Forcible a => a -> Try a+trySuperForce = tryFSOp trySuperForceFS where+    -- |trySuperForceFS - implementation of trySuperForce for force states only+    trySuperForceFS :: ForceState -> Try ForceState+    trySuperForceFS fs = +        do forcedFS <- onFail "trySuperForceFS: force failed (incorrect Tgraph)\n" $+                       tryForce fs+           case singleChoiceEdges $ boundaryState forcedFS of+              [] -> return forcedFS+              (elpr:_) -> do extended <- addSingle elpr forcedFS+                             trySuperForceFS extended+    addSingle (e,l) fs = if isDart l then tryAddHalfDart e fs else tryAddHalfKite e fs++-- |singleChoiceEdges bd - if bd is a boundary state of a forced Tgraph this finds those boundary edges of bd+-- which have a single choice (i.e. the other choice is incorrect), by inspecting boundary edge covers of bd.+-- The result is a list of pairs of (edge,label) where edge is a boundary edge with a single choice+-- and label indicates the choice as the common face label.+singleChoiceEdges :: BoundaryState -> [(Dedge,HalfTileLabel)]+singleChoiceEdges bstate = commonToCovering (boundaryECovering bstate) (boundary bstate)  +  where+-- |commonToCovering bds edgeList - when bds are all the boundary edge covers of some forced Tgraph+-- whose boundary edges were edgeList, this looks for edges in edgeList that have the same tile label added in all covers.+-- This indicates there is a single choice for such an edge (the other choice is incorrect).+-- The result is a list of pairs: edge and a common tile label.+-- commonToCovering :: [BoundaryState] -> [Dedge] -> [(Dedge,HalfTileLabel)]+    commonToCovering bds edgeList = common edgeList (transpose labellists) where+      labellists = fmap (`reportCover` edgeList) bds+      common [] [] = []+      common [] (_:_) = error "singleChoiceEdges:commonToCovering: label list is longer than edge list"+      common (_:_) [] = error "singleChoiceEdges:commonToCovering: label list is shorter than edge list"+      common (e:more) (ls:lls) = if matchingLabels ls +                                 then (e,head ls):common more lls+                                 else common more lls+      matchingLabels [] = error "singleChoiceEdges:commonToCovering: empty list of labels" +      matchingLabels (l:ls) = all (==l) ls++-- |reportCover bd edgelist - when bd is a boundary edge cover of some forced Tgraph whose boundary edges are edgelist,+-- this returns the tile label for the face covering each edge in edgelist (in corresponding order).+-- reportCover :: BoundaryState -> [Dedge] -> [HalfTileLabel]+    reportCover bd des = fmap (tileLabel . getf) des where+      efmap = dedgesFacesMap des (allFaces bd) -- more efficient than using graphEFMap?+--      efmap = graphEFMap (recoverGraph bd)+      getf e = maybe (error $ "singleChoiceEdges:reportCover: no face found with directed edge " ++ show e)+                     id+                     (faceForEdge e efmap)+      +++-- | Returns a list of (looping) vertex trails for the boundary of a Tgraph.+-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes.+-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex.+-- The trails will have disjoint sets of vertices because of the no-crossing-boundaries condition of Tgraphs.+boundaryLoopsG:: Tgraph -> [[Vertex]] +boundaryLoopsG = findLoops . graphBoundary++-- | Returns a list of (looping) vertex trails for a BoundaryState.+-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes.+-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex.+-- The trails will have disjoint sets of vertices because of the no-crossing-boundaries condition of Tgraphs (and hence BoundaryStates).+boundaryLoops:: BoundaryState -> [[Vertex]]+boundaryLoops = findLoops . boundary++-- | When applied to a boundary edge list this returns a list of (looping) vertex trails.+-- I.e. if we follow the boundary edges of a Tgraph recording vertices visited as a list returning to the starting vertex+-- we get a looping trail.+-- There will usually be a single trail, but more than one indicates the presence of boundaries round holes.+-- Each trail starts with the lowest numbered vertex in that trail, and ends with the same vertex.+findLoops:: [Dedge] -> [[Vertex]]+findLoops = collectLoops . VMap.fromList where++    -- Make a vertex to vertex map from the directed edges then delete items from the map as a trail is followed+    -- from the lowest numbered vertex.+    -- Vertices are collected in reverse order, then the list is reversed when a loop is complete.+    -- This is repeated until the map is empty, to collect all boundary trials.+   collectLoops vmap -- +     | VMap.null vmap = []+     | otherwise = chase startV vmap [startV] +         where+         (startV,_) = VMap.findMin vmap+         chase a vm sofar -- sofar is the collected trail in reverse order.+            = case VMap.lookup a vm of+                Just b -> chase b (VMap.delete a vm) (b:sofar)+                Nothing -> if a == startV +                           then reverse sofar: collectLoops vm -- look for more loops+                           else error $ "findLoops (collectLoops): non looping boundary component, starting at "+                                        ++show startV+++                                        " and finishing at "+                                        ++ show a ++ +                                        "\nwith loop vertices "++ show (reverse sofar) ++"\n"+++-- | Given a suitable vertex to location map and boundary loops (represented as a list of lists of vertices),+-- this will return a (Diagrams) Path for the boundary.  It will raise an error if any vertex listed is not a map key.+-- (The resulting path can be filled when converted to a diagram.)+pathFromBoundaryLoops:: VertexLocMap -> [[Vertex]] -> Path V2 Double+pathFromBoundaryLoops vlocs loops = toPath $ map (locateLoop . map (vlocs VMap.!)) loops where +    locateLoop pts = (`at` head pts) $ glueTrail $ trailFromVertices pts++++-- * TrackedTgraphs++{-|+ TrackedTgraph - introduced to allow tracking of subsets of faces+ in both force and decompose operations.+ Mainly used for drawing purposes but also for empires.+ A TrackedTgraph has a main Tgraph (tgraph) and a list of subsets (sublists) of faces (tracked).+ The list allows for tracking different subsets of faces at the same time.+-}+data TrackedTgraph = TrackedTgraph{ tgraph:: Tgraph, tracked::[[TileFace]]} deriving Show++-- |newTrackedTgraph g creates a TrackedTgraph from a Tgraph g with an empty tracked list+newTrackedTgraph :: Tgraph -> TrackedTgraph+newTrackedTgraph g = makeTrackedTgraph g []++-- |makeTrackedTgraph g trackedlist creates a TrackedTgraph from a Tgraph g+-- from trackedlist where each list in trackedlist is a subset of the faces of g.+-- Any faces not in g are ignored.+makeTrackedTgraph :: Tgraph -> [[TileFace]] -> TrackedTgraph+makeTrackedTgraph g trackedlist = TrackedTgraph{ tgraph = g, tracked = fmap (`intersect` faces g) trackedlist}++-- |trackFaces ttg - pushes the maingraph tilefaces onto the stack of tracked subsets of ttg+trackFaces:: TrackedTgraph -> TrackedTgraph+trackFaces ttg = ttg{ tracked = faces (tgraph ttg):tracked ttg }++-- |unionTwoTracked ttg - combines the top two lists of tracked tilefaces replacing them with the list union.+unionTwoTracked:: TrackedTgraph -> TrackedTgraph+unionTwoTracked ttg = ttg{ tracked = newTracked } where+    newTracked = case tracked ttg of+                   (a:b:more) -> a `union` b:more+                   _ -> error $ "unionTwoTracked: Two tracked lists of faces not found: " ++ show ttg ++"\n"++{-*+Forcing and Decomposing TrackedTgraphs+-}++-- | TrackedTgraphs are Forcible    +instance Forcible TrackedTgraph where+    tryFSOpWith ugen f ttg = do+        g' <- tryFSOpWith ugen f $ tgraph ttg+        return ttg{ tgraph = g' }+    tryInitFSWith ugen ttg = tryInitFSWith ugen (tgraph ttg)+    tryChangeBoundaryWith ugen f ttg = do+        g' <- tryChangeBoundaryWith ugen f $ tgraph ttg+        return ttg{ tgraph = g' }+--    getBoundaryState = getBoundaryState . tgraph+              +-- |addHalfDartTracked ttg e - add a half dart to the tgraph of ttg on the given edge e,+-- and push the new singleton face list onto the tracked list.+addHalfDartTracked:: Dedge -> TrackedTgraph -> TrackedTgraph+addHalfDartTracked e ttg =+  TrackedTgraph{ tgraph = g' , tracked = fcs:tracked ttg}+  where+    g = tgraph ttg+    g' = addHalfDart e g+    fcs = faces g' \\ faces g++-- |addHalfKiteTracked ttg e - add a half kite to the tgraph of ttg on the given edge e,+-- and push the new singleton face list onto the tracked list.+addHalfKiteTracked:: Dedge -> TrackedTgraph -> TrackedTgraph+addHalfKiteTracked e ttg =+  TrackedTgraph{ tgraph = g' , tracked = fcs:tracked ttg}+  where+    g = tgraph ttg+    g' = addHalfKite e g+    fcs = faces g' \\ faces g++-- |decompose a TrackedTgraph - applies decomposition to all tracked subsets as well as the full Tgraph.+-- Tracked subsets get the same numbering of new vertices as the main Tgraph. +decomposeTracked :: TrackedTgraph -> TrackedTgraph+decomposeTracked ttg = +  TrackedTgraph{ tgraph = g' , tracked = tlist}+  where +--    makeTrackedTgraph g' tlist where+    g = tgraph ttg+    g' = makeUncheckedTgraph newFaces+    newVFor = phiVMap g+    newFaces = concatMap (decompFace newVFor) (faces g)+    tlist = fmap (concatMap (decompFace newVFor)) (tracked ttg)++{-*  Drawing TrackedTgraphs+-}                                          ++{-|+    To draw a TrackedTgraph, we use a list of functions each turning a VPatch into a diagram.+    The first function is applied to a VPatch for untracked faces.+    Subsequent functions are applied to VPatches for the respective tracked subsets.+    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 drawList ttg = mconcat $ reverse $ zipWith ($) drawList vpList where+    vp = makeVP (tgraph ttg)+    untracked = vpFaces vp \\ concat (tracked ttg)+    vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp++{-|+    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+-}+drawTrackedTgraphRotated :: [VPatch -> Diagram2D b] -> Angle Double -> TrackedTgraph -> Diagram2D b+drawTrackedTgraphRotated drawList a ttg = mconcat $ reverse $ zipWith ($) drawList vpList where+    vp = rotate a $ makeVP (tgraph ttg)+    untracked = vpFaces vp \\ concat (tracked ttg)+    vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp++{-|+    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.+    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 drawList (a,b) ttg = mconcat $ reverse $ zipWith ($) drawList vpList where+    vp = makeAlignedVP (a,b) (tgraph ttg)+    untracked = vpFaces vp \\ concat (tracked ttg)+    vpList = fmap (restrictVP vp) (untracked:tracked ttg) ++ repeat vp++++ 

@@ -0,0 +1,481 @@+{-|+Module      : TileLib+Description : Introducing Pieces and Patches and Drawable class+Copyright   : (c) Chris Reade, 2021+License     : BSD-style+Maintainer  : chrisreade@mac.com+Stability   : experimental++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,..).+There is also a decompose operation for Patches (decompPatch) and sun and star example Patches.+-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE FlexibleInstances         #-} -- needed for Drawable Patch+{-# LANGUAGE TypeOperators             #-} -- needed for type equality constraints ~++module TileLib +  ( -- * Pieces+    Piece+  , joinVector+  , ldart+  , rdart+  , lkite+  , rkite+    -- * Drawing Pieces+  , Diagram2D+  , phi+  , ttangle+  , pieceEdges+  , wholeTileEdges+  , drawPiece+  , dashjPiece+  , dashjOnly+  , drawRoundPiece+  , drawJoin+  , fillOnlyPiece+  , fillPieceDK+  , fillMaybePieceDK+  , leftFillPieceDK+  , experiment+    -- * Patches and Drawable Class+  , Drawable(..)+  , Patch+  , draw+  , drawj+  , fillDK+  , fillKD+  , fillMaybeDK+  , colourDKG+  , colourMaybeDKG+    -- * Patch Decomposition and Compose choices+  , decompPatch+  , decompositionsP+  , compChoices+  , compNChoices+    -- * Example Patches+  , penta+  , sun+  , TileLib.star+  , suns+  , sun5+  , sun6+    -- * Diagrams of Patches+  , sun6Fig+  , leftFilledSun6+  , filledSun6+    -- * Rotation and Scaling operations+  , rotations+  , scales+  , phiScales+  , phiScaling+  ) where++import Diagrams.Prelude++import HalfTile++{-| Piece type for tile halves: Left Dart, Right Dart, Left Kite, Right Kite+with a vector from their origin along the join edge where+origin for a dart is the tip, origin for a kite is the vertex with smallest internal angle.+Using Imported polymorphic HalfTile.++Pieces are Transformable+-}+type Piece = HalfTile (V2 Double)++-- | get the vector representing the join edge in the direction away from the origin of a piece+joinVector:: Piece -> V2 Double+joinVector = tileRep++-- |ldart,rdart,lkite,rkite are the 4 pieces (with join edge oriented along the x axis, unit length for darts, length phi for kites).+ldart,rdart,lkite,rkite:: Piece+ldart = LD unitX+rdart = RD unitX+lkite = LK (phi*^unitX)+rkite = RK (phi*^unitX)++-- |All edge lengths are powers of the golden ratio (phi).+-- We also have the interesting property of the golden ratio that phi^2 == phi + 1 and so 1/phi = phi-1+-- (also phi^3 = 2phi +1 and 1/phi^2 = 2-phi)+phi::Double+phi = (1.0 + sqrt 5.0) / 2.0++-- |All angles used are multiples of tt where tt is a tenth of a turn+-- (so 36 degrees).+-- ttangle n is n multiples of tt.+ttangle:: Int -> Angle Double+ttangle n = fromIntegral (n `mod` 10) *^tt+             where tt = 1/10 @@ turn++{-|  produces a list of the two adjacent non-join tile directed edges of a piece starting from the origin.++Perhaps confusingly we regard left and right of a dart differently from left and right of a kite.+This is in line with common sense view but darts are reversed from origin point of view.++So for right dart and left kite the edges are directed and ordered clockwise from the piece origin, and for left dart and right kite these are+directed and ordered anti-clockwise from the piece origin.+-}+pieceEdges:: Piece -> [V2 Double]+pieceEdges (LD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 9) v+pieceEdges (RD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 1) v+pieceEdges (RK v) = [v',v ^-^ v'] where v' = rotate (ttangle 9) v+pieceEdges (LK v) = [v',v ^-^ v'] where v' = rotate (ttangle 1) v++-- |the 4 tile edges of a completed half-tile piece (used for colour fill).+-- These are directed and ordered clockwise from the origin of the tile.+wholeTileEdges:: Piece -> [V2 Double]+wholeTileEdges (LD v) = wholeTileEdges (RD v)+wholeTileEdges (RD v) = pieceEdges (RD v) ++ map negated (reverse $ pieceEdges (LD v))+wholeTileEdges (LK v) = pieceEdges (LK v) ++ map negated (reverse $ pieceEdges (RK v))+wholeTileEdges (RK v) = wholeTileEdges (LK v)+++-- | Abbreviation for 2D diagrams for any Backend b.+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 = 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+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 ++-- |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 = 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 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 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 dcol kcol piece = drawPiece piece <> fillOnlyPiece col piece where+    col = case piece of (LD _) -> dcol+                        (RD _) -> dcol+                        (LK _) -> kcol+                        (RK _) -> kcol++-- |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 d k piece = drawPiece piece <> filler where+    maybeFill (Just c) = fillOnlyPiece c piece+    maybeFill  Nothing = mempty+    filler = case piece of (LD _) -> maybeFill d+                           (RD _) -> maybeFill d+                           (LK _) -> maybeFill k+                           (RK _) -> maybeFill k+++-- |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 dcol kcol pc =+     case pc of (LD _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc)  # fc dcol+                (LK _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc)  # fc kcol+                _      -> mempty+        +-- |experiment uses a different rule for drawing half tiles.+-- This clearly displays the larger kites and darts.+-- 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 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+          (LD v) -> (strokeLine . fromOffsets) [v] # lc red   -- emphasise join edge of darts in red+          (RD v) -> (strokeLine . fromOffsets) [v] # lc red +          (LK v) -> (strokeLine . fromOffsets) [rotate (ttangle 1) v] -- emphasise long edge for kites+          (RK v) -> (strokeLine . fromOffsets) [rotate (ttangle 9) v]++++-- |A patch is a list of Located pieces (the point associated with each piece locates its originV)+-- Patches are Transformable+type Patch = [Located Piece]++-- | 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++-- | Patches are drawable+instance Drawable Patch where+  drawWith = drawPatchWith where+    -- turn a patch into a diagram using the first argument for drawing pieces.+    -- drawPatchWith:: (Piece -> Diagram B) -> Patch -> Diagram B      +      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 = 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+drawj = drawWith dashjPiece++fillDK, fillKD :: (Drawable a, Renderable (Path V2 Double) b) =>+                   Colour Double -> Colour Double -> a -> Diagram2D 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+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+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 (c1,c2,c3) a = fillDK c1 c2 a # lc c3++-- |colourMaybeDKG (d,k,g) a - draws a 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+-- 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 (d,k,g) a = fillMaybeDK d k a # maybeGrout g where+    maybeGrout (Just c) = lc c+    maybeGrout Nothing = lw none++++{-|+Decomposing splits each located piece in a patch into a list of smaller located pieces to create a refined patch.+(See also decompose in Tgraph.Decompose.hs for a more abstract version of this operation).+-}+decompPatch :: Patch -> Patch+decompPatch = concatMap decompPiece++-- |Decomposing a located piece to a list of (2 or 3) located pieces at smaller scale.+decompPiece :: Located Piece -> [Located Piece]+decompPiece lp = case viewLoc lp of+  (p, RD vd)-> [ LK vd  `at` p+               , RD vd' `at` (p .+^ v')+               ] where v'  = phi*^rotate (ttangle 1) vd+                       vd' = (2-phi) *^ negated v' -- (2-phi) = 1/phi^2+  (p, LD vd)-> [ RK vd `at` p+               , LD vd' `at` (p .+^ v')+               ]  where v'  = phi*^rotate (ttangle 9) vd+                        vd' = (2-phi) *^ negated v'  -- (2-phi) = 1/phi^2+  (p, RK vk)-> [ RD vd' `at` p+               , LK vk' `at` (p .+^ v')+               , RK vk' `at` (p .+^ v')+               ] where v'  = rotate (ttangle 9) vk+                       vd' = (2-phi) *^ v'  -- (2-phi) = 1/phi^2+                       vk' = ((phi-1) *^ vk) ^-^ v' -- (phi-1) = 1/phi+  (p, LK vk)-> [ LD vd' `at` p+               , RK vk' `at` (p .+^ v')+               , LK vk' `at` (p .+^ v')+               ] where v'  = rotate (ttangle 1) vk+                       vd' = (2-phi) *^ v'  -- (2-phi) = 1/phi^2+                       vk' = ((phi-1) *^ vk) ^-^ v' -- (phi-1) = 1/phi++-- |Create an infinite list of increasing decompositions of a patch+decompositionsP:: Patch -> [Patch]+decompositionsP = iterate decompPatch++{-|+compChoices applied to  a single located piece produces a list of alternative located pieces NOT a Patch.+Each of these is a larger scale single piece with a location such that when decomposed+the original piece in its original position is part of the decomposition)+-}+compChoices :: Located Piece -> [Located Piece]+compChoices lp = case viewLoc lp of+  (p, RD vd)-> [ RD vd' `at` (p .+^ v')+               , RK vk  `at` p+               ] where v'  = (phi+1) *^ vd                  -- vd*phi^2+                       vd' = rotate (ttangle 9) (vd ^-^ v')+                       vk  = rotate (ttangle 1) v'+  (p, LD vd)-> [ LD vd' `at` (p .+^ v')+               , LK vk `at` p+               ] where v'  = (phi+1) *^ vd                  -- vd*phi^2+                       vd' = rotate (ttangle 1) (vd ^-^ v')+                       vk  = rotate (ttangle 9) v'+  (p, RK vk)-> [ LD vk  `at` p+               , LK lvk' `at` (p .+^ lv') +               , RK rvk' `at` (p .+^ rv')+               ] where lv'  = phi*^rotate (ttangle 9) vk+                       rv'  = phi*^rotate (ttangle 1) vk+                       rvk' = phi*^rotate (ttangle 7) vk+                       lvk' = phi*^rotate (ttangle 3) vk+  (p, LK vk)-> [ RD vk  `at` p+               , RK rvk' `at` (p .+^ rv')+               , LK lvk' `at` (p .+^ lv')+               ] where lv'  = phi*^rotate (ttangle 9) vk+                       rv'  = phi*^rotate (ttangle 1) vk+                       rvk' = phi*^rotate (ttangle 7) vk+                       lvk' = phi*^rotate (ttangle 3) vk++-- |compNChoices n lp - gives a list of all the alternatives after n compChoices starting with lp+-- Note that the result is not a Patch as the list represents alternatives.+compNChoices :: Int -> Located Piece -> [Located Piece]+compNChoices 0 lp = [lp]+compNChoices n lp = do+    lp' <- compChoices lp+    compNChoices (n-1) lp'+++                                +-- |combine 5 copies of a patch (each rotated by ttangle 2 successively)+-- (ttAngle 2 is 72 degrees) +-- Must be used with care to avoid creating a nonsense patch+penta:: Patch -> Patch+penta p = concatMap copy [0..4] +            where copy n = rotate (ttangle (2*n)) p+  +sun,star::Patch         +-- |sun is a patch with five kites sharing common origin (base of kite)+sun =  penta [rkite `at` origin, lkite `at` origin]+-- |star is a patch with five darts sharing common origin (tip of dart)+star = penta [rdart `at` origin, ldart `at` origin]+++-- |An infinite list of patches of increasingly decomposed sun+suns::[Patch]+suns = decompositionsP sun+sun5,sun6:: Patch+-- |a patch of a 6 times decomposed sun+sun6 = suns!!6+-- |a patch of a 5 times decomposed sun+sun5 = suns!!5 +++   -- * 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 = 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 = 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 = 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+rotations _  [] = error "rotations: too many rotation integers"++-- |scales takes a list of doubles for respective scalings of items in the second list (things to be scaled).+-- This includes Diagrams, Pieces, Patches, VPatches.+-- The list of doubles can be shorter than the list of items - the remaining items are left unscaled.+-- It will raise an error if the integer list is longer than the list of items to be scaled.+scales :: (Transformable a, V a ~ V2, N a ~ Double) => [Double] -> [a] -> [a]+scales (s:ss) (d:ds) = scale s d: scales ss ds+scales [] ds = ds+scales _  [] = error "scales: too many scalars"++-- |increasing scales by a factor of phi along a list starting with 1.+phiScales:: (Transformable a, V a ~ V2, N a ~ Double) => [a] -> [a]+phiScales = phiScaling 1++-- |increasing scales by a factor of phi along a list starting with given first argument+phiScaling:: (Transformable a, V a ~ V2, N a ~ Double) => Double -> [a] -> [a]+phiScaling _ [] = []+phiScaling s (d:more) = scale s d: phiScaling (phi*s) more+++

@@ -0,0 +1,135 @@+import Test.Hspec+import Control.Exception (evaluate)++import Tgraphs+import TgraphExamples+-- import TestIllustrate (touchErrorFaces,testCrossingBoundary)+main :: IO ()+main = hspec spec++spec :: Spec+spec = do graphPropSpec+          graphOpSpec+          graphLabelCheck+-- Example lists of tile-faces++x0,x1,x2,x3,x4,x5 :: [TileFace]+-- x0 has a face with a repeated vertex+x0 =  [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13)+      ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,14,14),RK (7,14,12)+      ]++-- x1 has crossing boundaries+x1 = [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13)+     ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,4,14),RK (7,14,12)+     ]+     +-- x2 is not connected+x2 = x1 ++ [LK (15,16,17),RK (15,17,18)]++-- x3 has edge conflicts +x3 = [LK (3,8,1),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13)+     ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,4,14),RK (7,14,12)+     ]++-- x4 has edge conflicts +x4 = [LD(1,2,3),RD(1,4,2),RD(4,1,5),LD(4,5,6)]++-- x5 has enon-positive vertex number +x5 = [LD(0,1,2)]++-- dD6 is a 6 times decomposed dartGraph+dD6 :: Tgraph+dD6 = dartDs !!6++{-|touchErrorFaces is an addition of 2 faces to those of foolD which contains touching vertices.+These will be caught by makeTgraph which raises an error.+The error is not picked up by checkedTgraph. It can be fixed using tryCorrectTouchingVs.++*** Exception: makeTgraph: touching vertices [(19,7)]++> checkedTgraph touchErrorFaces+Tgraph {maxV = 19, faces = ...}++> tryCorrectTouchingVs touchErrorFaces+Right (Tgraph {maxV = 18, faces = [..., LK (7,17,18)]})++test with:+padBorder $ drawjLabelled $ runTry $ tryCorrectTouchingVs touchErrorFaces+-}+touchErrorFaces::[TileFace]+touchErrorFaces = faces foolD ++ [RD (6,18,17),LK (19,17,18)]++-- |Example for testing crossing boundary detection e.g. using +-- checkedTgraph testCrossingBoundary, or by using+-- force (makeUncheckedTgraph testCrossingBoundary)+-- produces an error for a non-valid Tgraph.+testCrossingBoundary :: [TileFace]+testCrossingBoundary = [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13),RD (6,13,10)+                       ,LK (3,2,13),RK (3,13,11),RK (3,14,4),LK (3,11,14),LK (7,4,14),RK (7,14,12)+                       ]+++graphPropSpec :: Spec+graphPropSpec = describe "Test Properties of Tgraphs" $ do+    context "When fcs (a list of tile-faces) has any face with a repeated vertex" $+      it "hasEdgeLoops fcs should return True" $+        hasEdgeLoops x0 `shouldBe` True+    context "When fcs has no face with a repeated vertex" $+      it "hasEdgeLoops fcs should return False" $+        hasEdgeLoops x1 `shouldBe` False+    context "When fcs has crossing boundaries" $+      it "crossingBoundaries fcs should return True" $+        crossingBoundaries x1 `shouldBe` True+    context "When fcs has no crossing boundaries" $+      it "crossingBoundaries fcs should return False" $+        crossingBoundaries (faces foolD) `shouldBe` False+    context "When fcs are connected" $+      it "connected fcs should return True" $+        connected x1 `shouldBe` True+    context "When fcs are not connected" $+      it "connected fcs should return False" $+        connected x2 `shouldBe` False+    context "When fcs has illegal edge conflicts" $+      it "illegalTiling fcs should return True" $+        illegalTiling x3 `shouldBe` True+    context "When fcs has illegal edge conflicts" $+      it "illegalTiling fcs should return True" $+        illegalTiling x4 `shouldBe` True+    context "When fcs has no illegal edge conflicts" $+      it "illegalTiling fcs should return False" $+        illegalTiling x1 `shouldBe` False+    context "When fcs contains a non-positive vertex number" $+      it "makeTgraph fcs should throw an exception" $ do+          evaluate (makeTgraph x5) `shouldThrow` anyException+    context "When fcs have a touching vertex" $+      it "makeTgraph fcs should throw an exception" $ do+          evaluate (makeTgraph touchErrorFaces) `shouldThrow` anyException+    context "When fcs do not form a valid Tgraph" $+      it "makeTgraph fcs should throw an exception" $ do+          evaluate (makeTgraph testCrossingBoundary) `shouldThrow` anyException++graphOpSpec :: Spec+graphOpSpec = describe "Main Tgraph Operations Test" $ do+    context "Decomposition of Tgraphs" $+      it "Number of faces of dartDs !!6 should be 466" $+         length(faces dD6)  `shouldBe` 466+    context "Composing Tgraphs" $+      it "Number of faces of maxCompForce (dartDs !!6) should be 6" $+         length(faces(maxCompForce dD6)) `shouldBe` 6+    context "Forcing Tgraphs" $+      it "Number of faces of force (dartDs !!6) should be 7546" $+         length(faces(force dD6)) `shouldBe` 7546++graphLabelCheck :: Spec+graphLabelCheck = describe "Label critical examples check" $ do+    context "boundaryGapFDart4" $+      it "Number of faces of boundaryGapFDart4 should be 180" $+         length(faces boundaryGapFDart4)  `shouldBe` 180+    context "boundaryGapFDart5" $+      it "Number of faces of boundaryGapFDart5 should be 316" $+         length(faces boundaryGapFDart5)  `shouldBe` 316+    context "superForceFig" $+      it "Number of faces of superForceFig should be 349" $         +         length (faces(addHalfDart (220,221) $ force $ decompositions fool !!3)) `shouldBe` 349+