├── .gitignore ├── ArtGallery ├── Animations │ ├── animForceDart5.gif │ ├── animForceKite5.gif │ ├── animGapFill.gif │ ├── animHeart.gif │ ├── animHeart2.gif │ ├── animStar.gif │ ├── composeAnim.gif │ ├── decomposeAnim.gif │ └── decomposeAnim2.gif ├── gallery1.pdf ├── gallery1.svg ├── gallery2.svg ├── gallery3.svg └── gallery4.svg ├── CHANGELOG.md ├── LICENSE ├── PenroseKiteDart-bench.prof ├── PenroseKiteDart.cabal ├── README.md ├── SVGs ├── bigPic.svg ├── brokenDartFig.svg ├── coverOneChoiceFig.svg ├── crossingBdryFig.svg ├── curioPic.svg ├── emplaceFoolDChoices.svg ├── experimentFig.svg ├── filledSun6.svg ├── foolAndFoolD.svg ├── forceFoolDMinus.svg ├── forceRules.svg ├── halfWholeFig.svg ├── incorrectAndFullUnion.svg ├── kingEmpiresFig.svg ├── leftFilledSun6.svg ├── moreChoicesFig.svg ├── relatedVTypeFig.svg ├── superForceRocketsFig.svg ├── threeColourFilled.svg ├── touchingTestFig.svg ├── twoChoicesFig.svg └── vertexTypesFig.svg ├── Setup.hs ├── benchmark └── Bench.hs ├── dist-newstyle ├── cache │ └── config └── sdist │ ├── OlderVersions │ ├── PenroseKiteDart-1.0.0-docs.tar.gz │ ├── PenroseKiteDart-1.0.0.tar.gz │ ├── PenroseKiteDart-1.1.0-docs.tar.gz │ ├── PenroseKiteDart-1.1.0.tar.gz │ ├── PenroseKiteDart-1.2-docs.tar.gz │ ├── PenroseKiteDart-1.2.1-docs.tar.gz │ ├── PenroseKiteDart-1.2.1.tar.gz │ └── PenroseKiteDart-1.2.tar.gz │ ├── PenroseKiteDart-1.3-docs.tar.gz │ └── PenroseKiteDart-1.3.tar.gz ├── package.yaml ├── src ├── CheckBackend.hs ├── HalfTile.hs ├── PKD.hs ├── Tgraph │ ├── Compose.hs │ ├── Decompose.hs │ ├── Force.hs │ ├── Prelude.hs │ └── Relabelling.hs ├── TgraphExamples.hs ├── TileLib.hs └── Try.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | .DS* 4 | stack.yaml.lock 5 | *-bench.* 6 | -------------------------------------------------------------------------------- /ArtGallery/Animations/animForceDart5.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/animForceDart5.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/animForceKite5.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/animForceKite5.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/animGapFill.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/animGapFill.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/animHeart.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/animHeart.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/animHeart2.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/animHeart2.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/animStar.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/animStar.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/composeAnim.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/composeAnim.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/decomposeAnim.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/decomposeAnim.gif -------------------------------------------------------------------------------- /ArtGallery/Animations/decomposeAnim2.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/Animations/decomposeAnim2.gif -------------------------------------------------------------------------------- /ArtGallery/gallery1.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/ArtGallery/gallery1.pdf -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for PenroseKiteDart 2 | 3 | (After 1.3) 4 | Coalesced modules PKD and Tgraphs as PKD (then removed Tgraphs module). 5 | 6 | ### Try changed 7 | Changed the type for Try to use ShowS instead of String 8 | (ShowS = String -> String) 9 | 10 | New: failReport, failReports, tryAtLeastOne 11 | 12 | Breaking: 13 | Occurrences of 14 | Left s :: Try a 15 | need to be replaced by 16 | failReport s 17 | or 18 | Left (s<>) 19 | 20 | An instance of Show(ShowS) is provided in order to show Try results 21 | 22 | ### Changes to Forced 23 | Forced is no longer a Functor 24 | Instead, 4 specific safe cases for changing a Forced Forcible 25 | (New) 26 | recoverGraphF,boundaryStateF,makeBoundaryStateF,initFSF 27 | 28 | Data constructor Forced is no longer exported but 29 | (New) 30 | labelAsForced is introduced instead 31 | 32 | Changed type of tryDartAndKiteForced (to explicitly show Forced results) 33 | (Use map (fmap forgetF) to convert [Try (Forced a)] to [Try a]). 34 | 35 | Removed warning pragma for makeUncheckedTgraph 36 | 37 | ## version 1.3 -- 2025-5-19 38 | 39 | (New) 40 | Introduced newtype operator Forced 41 | to enable restricting functions which require a forced argument. 42 | Forced a is an explicitly forced version of a. 43 | 44 | Breaking changes: 45 | 46 | Removed: 47 | uncheckedCompose (use new composeF with explicitly Forced Tgraph) 48 | uncheckedPartCompose (use new partComposeF with explicitly Forced Tgraph) 49 | 50 | Changed types (to make use of Forced) for: 51 | compForce 52 | allCompForce 53 | maxCompForce 54 | boundaryVCovering 55 | boundaryECovering 56 | singleChoiceEdges 57 | 58 | Removed deprecated: 59 | noFails (use runTry . concatFails) 60 | colourMaybeDKG (use colourDKG with transparent) 61 | fillMaybeDK (use fillDK with transparent) 62 | fillMaybePieceDK (use fillPieceDK with transparent) 63 | 64 | Renamed: 65 | tryOneStepF is now tryOneStepForce 66 | 67 | Other changes: 68 | 69 | (New) 70 | forgetF :: Forced a -> a (to unwrap explicitly Forced) 71 | tryForceF (to create explicitly Forced) 72 | forceF (to create explicitly Forced) 73 | composeF :: Forced Tgraph -> Forced Tgraph 74 | partComposeF :: Forced Tgraph -> ([TileFace], Forced Tgraph) 75 | 76 | Added warning in PKD for makeUncheckedTgraph 77 | 78 | 79 | ## version 1.2.1 -- 2025-4-2 80 | 81 | Added: drawBoundaryJoins, joinDashing 82 | 83 | Renamed: drawEdge, drawEdges as drawLocatedEdge, drawLocatedEdges 84 | Depracating: drawEdge, drawEdges 85 | 86 | Generalised: colourDKG, fillDK, fillKD, fillPieceDK, fillOnlyPiece 87 | to work with AlphaColours as well as Colours 88 | 89 | Deprecating: colourMaybeDKG, fillMaybeDK, fillMaybePieceDK 90 | 91 | Added (strict) makeRD, makeLD, makeRK, makeLK to Tgraph.Prelude 92 | 93 | 94 | ## version 1.2 -- 2024-12-1 95 | 96 | Release candidate: 97 | Introduced getDartInfoForced and improved performance of uncheckedPartCompose and uncheckedCompose 98 | removed: composedFaces = snd . partComposeFaces (all in Tgraph.Compose) 99 | 100 | Significant improvement on space usage (fixing leaks) 101 | adding StrictData to modules Tgraph.HalfTile, Tgraph.Compose, Tgraph.Force. 102 | makeUncheckedTgraph now strictly evaluates its argument list of faces. 103 | 104 | Made UpdateGenerator a newtype in Tgraph.Force 105 | 106 | ## 1.1.1 -- 2024-11-15 107 | 108 | Exposed combineUpdateGenerators in Tgraph.Force 109 | 110 | Reordered lists of faces in some basic example Tgraphs 111 | (to ensure tails of the list are also valid as Tgraphs) 112 | 113 | ## 1.1.0 -- 2024-09-28 114 | 115 | Release candidate: 116 | 117 | Added module CheckBackend with class OKBackend. This is really a class synonym for the constraints on a suitable Backend 118 | for drawing tilings. Most types involving a backend b now have a constraint OKBackend b => ... 119 | 120 | Removed type synonym: type Diagram2D b = QDiagram b V2 Double Any (no longer needed with the above constraint). 121 | 122 | No longer exporting: differing, changeVFMap, forcedDecomp (= force . decompose). 123 | 124 | Moved makeTgraph to Tgraph.Prelude. 125 | Moved emplaceChoices to TgraphExamples and added example. 126 | Moved module Tgraph.Try out of Tgraph (so now module Try). 127 | 128 | tryStepForceWith now raises an error for negative number of steps. 129 | 130 | Added graphBoundaryVs to Tgraph.Prelude. 131 | Added tryBoundaryFaceGraph to Tgraphs 132 | 133 | Made ForceState an instance of Show. 134 | 135 | Improved haddock comments in Tgraph.Force. 136 | 137 | Changed dash sizes for join edges (in dashjOnly). 138 | 139 | ## 1.0.0 -- 2024-04-08 140 | 141 | Release candidate: 142 | 143 | Added upper bounds on dependencies 144 | 145 | Added new drawEmpire and changed drawEmpire1, drawEmpire2 to showEmpire1, showEmpire2 146 | 147 | ## 0.10.0.0 -- 2024-04-1 148 | 149 | Removed some examples in TgraphExamples and export of some auxiliary functions in Tgraph.Relabelling 150 | 151 | ## 0.9.1.0 -- 2024-03-12 152 | 153 | Tgraph.Try as a separate module (instead of part of Tgraph.Prelude) 154 | Added labelColourSize in DrawableLabelled with labelSize as special case 155 | Changes to labelSize and line widths in some diagrams and drawing functions. 156 | Removed labelSmall, labelLarge. 157 | Added drawTrackedTgraphAligned. 158 | Both restrictVP and relevantVP now check for missing locations. 159 | 160 | ## 0.8.0.2 -- 2024-02-25 161 | 162 | Documentation changes only. 163 | 164 | ## 0.8.0.1 -- 2024-02-24 165 | 166 | Fewer exported functions (Tgraph.Prelude, Tgraph.Relabelling), some renaming 167 | 168 | ## 0.7.0.0 -- 2024-02-18 169 | 170 | Export of modules specified and changed (with more hiding) 171 | 172 | ## 0.6.0.0 -- 2024-02-17 173 | 174 | Now as a standalone library 175 | 176 | ## 0.5.2.0 -- 2024-02-14 177 | 178 | Added PKD (overall wrapper module). 179 | 180 | ## 0.5.1.0 -- 2024-02-13 181 | 182 | Removed Tgraph.Convert (Conversions now included in Tgraph.Prelude) 183 | 184 | ## 0.5.0.0 -- 2024-01-26 185 | 186 | (Removed ChosenBackEnd) 187 | Only Main now imports a Backend (in preparation for creating library only). 188 | Types have been generalised in modules that were previously using Backend B 189 | e.g. 190 | 191 | pCompFig :: Diagram B 192 | 193 | has become 194 | 195 | pCompFig :: Renderable (Path V2 Double) b => Diagram2D b 196 | 197 | 198 | ## 0.4.0.0 -- 2023-10-27 199 | 200 | Tgraphs now defined as newType 201 | 202 | ## 0.3.0.0 -- 2023-10-19 203 | 204 | Modules: 205 | src/ 206 | HalfTile.hs -- (Half)Tile constructors - used by TileLib and Tgraph.Prelude 207 | ChosenBackend.hs -- switch between e.g. SVG or PostScript 208 | TileLib.hs -- Drawing of Pieces (and Patches) 209 | Tgraphs.hs -- Main Graph Ops (imports and reexports all modules in Tgraph and adds extra ops) 210 | Tgraph/ 211 | Tgraph.Prelude.hs -- (imports and reexports HalfTile) 212 | Tgraph.Decompose.hs 213 | Tgraph.Compose.hs 214 | Tgraph.Force.hs 215 | Tgraph.Convert.hs -- Converting Tgraphs to VPatches (and drawing both) 216 | TgraphExamples.hs 217 | 218 | ## 0.2.0.0 -- 2022-03-31 219 | 220 | Restructured modules 221 | 222 | Graphs and Graph ops are collected in Tgraphs.hs 223 | Converting functions (and VPatch definition) are in Tgraph.Convert.hs 224 | Graph example figures are in TgraphExamples.hs 225 | 226 | Original underlying Tile ops and tile drawing are in TileLib.hs 227 | 228 | ## 0.2.0.0 -- 2021-06-18 229 | 230 | New Graph representations and operations on graphs (decomposeG, composeG, force, and more) 231 | Tools to convert to Patches for drawing etc and also intermediate VPatches, to display Vertex information. 232 | 233 | Key changes to original TileLib.hs : 234 | 235 | 1. New versions of tile halves using polymorphic versions of constructors in HalfTile.hs 236 | 2. Pieces (replaces Components) 237 | 3. Redefining Patches as a list of Located Pieces (Pieces with point position rather than an offset vector) 238 | 4. Making Patches transformable (so that scale, rotate, translate can be used instead of specialised versions) 239 | 240 | also fillDK became fillDK' with new version of fillDK 241 | 242 | ## 0.1.0.0 -- 2021-03-16 243 | 244 | First version. 245 | Vector representations and drawing tools for tile components and patches plus decompose and inflate operations. 246 | Described in 247 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Chris Reade (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Chris Reade nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /PenroseKiteDart.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: PenroseKiteDart 8 | version: 1.3 9 | synopsis: Library to explore Penrose's Kite and Dart Tilings. 10 | description: Library to explore Penrose's Kite and Dart Tilings using Haskell Diagrams. Please see README.md 11 | category: Graphics 12 | homepage: https://github.com/chrisreade/PenroseKiteDart#readme 13 | bug-reports: https://github.com/chrisreade/PenroseKiteDart/issues 14 | author: Chris Reade 15 | maintainer: chrisreade@mac.com 16 | copyright: 2021 Chris Reade 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | CHANGELOG.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/chrisreade/PenroseKiteDart 27 | 28 | library 29 | exposed-modules: 30 | PKD 31 | CheckBackend 32 | HalfTile 33 | TileLib 34 | Try 35 | Tgraph.Prelude 36 | Tgraph.Decompose 37 | Tgraph.Compose 38 | Tgraph.Force 39 | Tgraph.Relabelling 40 | TgraphExamples 41 | other-modules: 42 | Paths_PenroseKiteDart 43 | hs-source-dirs: 44 | src 45 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints 46 | build-depends: 47 | base >=4.7 && <5 48 | , containers >=0.6.7 && <0.7 49 | , diagrams-lib >=1.4.6 && <1.5 50 | default-language: GHC2021 51 | 52 | test-suite PenroseKiteDart-test 53 | type: exitcode-stdio-1.0 54 | main-is: Spec.hs 55 | other-modules: 56 | Paths_PenroseKiteDart 57 | hs-source-dirs: 58 | test 59 | 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 60 | build-depends: 61 | PenroseKiteDart 62 | , base >=4.7 && <5 63 | , containers >=0.6.7 && <0.7 64 | , diagrams-lib >=1.4.6 && <1.5 65 | , hspec >=2.10.10 && <2.12 66 | default-language: GHC2021 67 | 68 | benchmark PenroseKiteDart-bench 69 | type: exitcode-stdio-1.0 70 | main-is: Bench.hs 71 | other-modules: 72 | Paths_PenroseKiteDart 73 | hs-source-dirs: 74 | benchmark 75 | 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 76 | build-depends: 77 | PenroseKiteDart 78 | , base >=4.7 && <5 79 | , containers >=0.6.7 && <0.7 80 | , diagrams-lib >=1.4.6 && <1.5 81 | default-language: GHC2021 82 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PenroseKiteDart 2 | 3 | Author: Chris Reade 4 | 5 | March 2021 - 2024 6 | 7 | See LICENSE file 8 | 9 | ## Penrose Kites and Darts 10 | 11 | Penrose\'s kite and dart tiles have the property that they can tile the entire plane aperiodicly. 12 | There are rules to ensure legal tilings with the kites and darts. 13 | Legal tilings can still get stuck (so cannot be continued to cover the entire plane) - these are called incorrect. 14 | 15 | This package is a Haskell library of tools to build, draw and explore finite tilings with kites and darts, making use of the 16 | Haskell Diagrams package. 17 | 18 | ## Using the Package 19 | 20 | You will need the Haskell Diagrams package 21 | to be installed as well as this package (PenroseKiteDart). (See [Haskell Diagrams](https://diagrams.github.io)). 22 | Once installed, a Main.hs module to produce diagrams should import a chosen backend for Diagrams such as the default (SVG) 23 | along with Diagrams.Prelude 24 | 25 | module Main (main) where 26 | 27 | import Diagrams.Backend.SVG.CmdLine 28 | import Diagrams.Prelude 29 | 30 | plus (for Penrose Kite and Dart tilings) 31 | 32 | import PKD 33 | 34 | and optionally 35 | 36 | import TgraphExamples 37 | 38 | Then to ouput someExample figure 39 | 40 | fig::Diagram B 41 | fig = someExample 42 | 43 | main :: IO () 44 | main = mainWith fig 45 | 46 | When the code is executed it will generate an SVG file. 47 | (See the Haskell Diagrams package for more details on producing diagrams.) 48 | 49 | ## Tgraphs to Describe Finite Tilings 50 | 51 | Tile Graphs (`Tgraph`s) use a simple planar graph representation for finite patches of tiles. 52 | A `Tgraph` is made from a list of faces with type `TileFace` each of which is a half-dart or a half-kite. 53 | Each `TileFace` is thus a triangle with three positive Int vertices and a constructor 54 | `LD` (left dart), `RD` (right dart), `LK` (left kite), `RK` (right kite). 55 | 56 | For example a fool consists of two kites and a dart (= 4 half kites and 2 half darts): 57 | 58 | fool :: Tgraph 59 | fool = makeTgraph [RD (1,2,3),LD (1,3,4) -- right and left dart 60 | ,LK (5,3,2),RK (5,2,7) -- left and right kite 61 | ,RK (5,4,3),LK (5,6,4) -- right and left kite 62 | ] 63 | 64 | The function 65 | 66 | makeTgraph :: [TileFace] -> Tgraph 67 | 68 | performs checks to make sure the tiling is legal, raising an error if there is a problem. 69 | To produce a diagram, we simply draw the `Tgraph` 70 | 71 | foolFigure :: Diagram B 72 | foolFigure = labelled draw fool 73 | 74 | 75 | ## Modules 76 | 77 | Module `PKD` is the main module which imports and re-exports `Tgraphs` and `TileLib`. 78 | `Tgraphs` imports and re-exports the contents of the other Tgraph modules, namely 79 | `Tgraph.Compose`, `Tgraph.Decompose`, `Tgraph.Force`, `Tgraph.Relabelling`, `Tgraph.Prelude`. 80 | `TileLib` contains underlying drawing tools for tiles. 81 | `Try` is imported and re-exported by `Tgraph.Prelude` - used for results of partial functions. 82 | `HalfTile` is imported and re-exported by `Tgraph.Prelude` - (with the constructors `LD`,`RD`,`LK`,`RK`). 83 | `CheckBackend` is imported by `TileLib` which rexports class `OKBackend`. 84 | (The constraint `OKBackend b =>` is used extensively in the library to abstract types from any particular Backend). 85 | `TgraphExamples` contains example Tgraphs and Diagrams. 86 | 87 | ## Further Information 88 | 89 | A more detailed User Guide for the PenroseKiteDart package can be found at 90 | 91 | - [PenroseKiteDart User Guide](https://readerunner.wordpress.com/2024/04/08/penrosekitedart-user-guides/) 92 | 93 | 94 | -------------------------------------------------------------------------------- /SVGs/crossingBdryFig.svg: -------------------------------------------------------------------------------- 1 | 2 | 17161513119876543211716151311987654321 -------------------------------------------------------------------------------- /SVGs/foolAndFoolD.svg: -------------------------------------------------------------------------------- 1 | 2 | 17161513119876543217654321 -------------------------------------------------------------------------------- /SVGs/forceRules.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmark/Bench.hs: -------------------------------------------------------------------------------- 1 | import PKD 2 | import TgraphExamples 3 | import Debug.Trace (traceMarkerIO) 4 | import Control.Concurrent (threadDelay) 5 | -- import TileLib (draw) 6 | -- import Diagrams.Prelude 7 | 8 | main :: IO () 9 | main = 10 | do let wait = threadDelay 100000 11 | _ <- traceMarkerIO "starting decompositions" 12 | wait 13 | let kD = {-# SCC "decomposing" #-} decompositions kingGraph !! n 14 | putStrLn $ "Number of faces of a " ++ sn ++ " times decomposed King is " 15 | ++ show (length (faces kD)) 16 | putStrLn $ "Max vertex of a (" ++ sn ++ " times decomposed King) is " 17 | ++ show (maxV kD) 18 | _ <- traceMarkerIO "finished decomposing" 19 | wait 20 | _ <- traceMarkerIO "starting force" 21 | let fkD = {-# SCC "forcingKD" #-} forceF kD 22 | putStrLn $ "Number of faces of force (" ++ sn ++ " times decomposed King) is " 23 | ++ show (length $ faces $ forgetF fkD) 24 | putStrLn $ "Max vertex of force (" ++ sn ++ " times decomposed King) is " 25 | ++ show (maxV $ forgetF fkD) 26 | _ <- traceMarkerIO "finished force" 27 | wait 28 | _ <- traceMarkerIO "starting (unchecked) composing" 29 | let cfkD = {-# SCC "composing" #-} forgetF $ last $ takeWhile (not . nullGraph . forgetF) $ iterate composeF fkD 30 | -- let cfkD = {-# SCC "composing" #-} last $ takeWhile (not . nullGraph) $ iterate uncheckedCompose fkD 31 | putStrLn $ "Number of faces of recomposed force (" ++ sn ++ " times decomposed King) is " 32 | ++ show (length (faces cfkD)) 33 | putStrLn $ "Max vertex of recomposed force (" ++ sn ++ " times decomposed King) is " 34 | ++ show (maxV cfkD) 35 | _ <- traceMarkerIO "finished (unchecked) composing" 36 | return () 37 | {- 38 | putStrLn $ "Number of faces of reforced force (" ++ sn ++ " times decomposed King) is " 39 | ++ show (length (faces rcfkD)) 40 | -} 41 | 42 | where 43 | sn = show n 44 | n = 5 45 | 46 | {- 47 | fig = draw fkD 48 | w = width fig 49 | -} 50 | 51 | 52 | -------------------------------------------------------------------------------- /dist-newstyle/cache/config: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/cache/config -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.0.0-docs.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.0.0-docs.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.0.0.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.0.0.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.1.0-docs.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.1.0-docs.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.1.0.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.1.0.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2-docs.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2-docs.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2.1-docs.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2.1-docs.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2.1.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2.1.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/OlderVersions/PenroseKiteDart-1.2.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/PenroseKiteDart-1.3-docs.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/PenroseKiteDart-1.3-docs.tar.gz -------------------------------------------------------------------------------- /dist-newstyle/sdist/PenroseKiteDart-1.3.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisreade/PenroseKiteDart/1f4e26ec49d53475efae9e6895dfa7b84e24a36a/dist-newstyle/sdist/PenroseKiteDart-1.3.tar.gz -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: PenroseKiteDart 2 | version: 1.3 3 | github: "chrisreade/PenroseKiteDart" 4 | license: BSD3 5 | author: "Chris Reade" 6 | maintainer: "chrisreade@mac.com" 7 | copyright: "2021 Chris Reade" 8 | 9 | extra-source-files: 10 | - README.md 11 | - CHANGELOG.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: Library to explore Penrose's Kite and Dart Tilings. 15 | category: Graphics 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Library to explore Penrose's Kite and Dart Tilings using Haskell Diagrams. Please see README.md 21 | 22 | language: GHC2021 # newly added 23 | 24 | dependencies: 25 | - base >= 4.7 && < 5 26 | - diagrams-lib >= 1.4.6 && < 1.5 27 | - containers >= 0.6.7 && < 0.7 # added for Data.Map 28 | ghc-options: 29 | - -Wall 30 | - -Wcompat 31 | - -Widentities 32 | - -Wincomplete-record-updates 33 | - -Wincomplete-uni-patterns 34 | - -Wmissing-export-lists 35 | - -Wmissing-home-modules 36 | - -Wpartial-fields 37 | - -Wredundant-constraints 38 | library: 39 | source-dirs: src 40 | exposed-modules: 41 | - PKD 42 | - CheckBackend 43 | - HalfTile 44 | - TileLib 45 | - Try 46 | - Tgraph.Prelude 47 | - Tgraph.Decompose 48 | - Tgraph.Compose 49 | - Tgraph.Force 50 | - Tgraph.Relabelling 51 | - TgraphExamples 52 | tests: 53 | PenroseKiteDart-test: 54 | main: Spec.hs 55 | source-dirs: test 56 | ghc-options: 57 | - -threaded 58 | - -rtsopts 59 | - -with-rtsopts=-N 60 | dependencies: 61 | - PenroseKiteDart 62 | - hspec >= 2.10.10 && < 2.12 63 | benchmarks: 64 | PenroseKiteDart-bench: 65 | main: Bench.hs 66 | source-dirs: benchmark 67 | ghc-options: 68 | # - -O2 69 | - -threaded 70 | - -rtsopts 71 | - -with-rtsopts=-N 72 | dependencies: 73 | - PenroseKiteDart 74 | -------------------------------------------------------------------------------- /src/CheckBackend.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : CheckBackend 3 | Description : Introduces a class synonym OKBackend for requirements of a backend 4 | Copyright : (c) Chris Reade, 2024 5 | License : BSD-style 6 | Maintainer : chrisreade@mac.com 7 | Stability : experimental 8 | 9 | This module introduces a class synonym OKBackend to abbreviate requirements of a backend for drawing tilings. 10 | The instance declaration requires UndecidableInstances to be enabled. 11 | 12 | -} 13 | {-# LANGUAGE NoMonomorphismRestriction #-} 14 | {-# LANGUAGE FlexibleContexts #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE FlexibleInstances #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | {-# LANGUAGE TypeOperators #-} 19 | 20 | module CheckBackend 21 | ( OKBackend 22 | ) where 23 | 24 | import Diagrams.Prelude 25 | import Diagrams.TwoD.Text (Text) 26 | 27 | 28 | -- |Class OKBackend is a class synonym for suitable constraints on Backends for drawing tilings. 29 | class (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b) => 30 | OKBackend b where {} 31 | 32 | -- |Instance declaration for OKBackend requires UndecidableInstances to be enabled, 33 | -- but allows a suitable backend B to be recognised as an instance without explicitly writing 34 | -- instance OKBackend B 35 | -- Note B will be declared by user of this library and is not declared in the library 36 | instance (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b) => 37 | OKBackend b where {} 38 | -------------------------------------------------------------------------------- /src/HalfTile.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : HalfTile 3 | Description : Introducing a generic type for half tiles of darts and kites 4 | Copyright : (c) Chris Reade, 2021 5 | License : BSD-style 6 | Maintainer : chrisreade@mac.com 7 | Stability : experimental 8 | 9 | -} 10 | {-# LANGUAGE TypeFamilies #-} -- needed for Transformable Instance 11 | {-# LANGUAGE FlexibleInstances #-} -- needed for Transformable Instance 12 | -- {-# LANGUAGE StrictData #-} 13 | 14 | module HalfTile 15 | ( HalfTile(..) 16 | , tileRep 17 | , isLD 18 | , isRD 19 | , isLK 20 | , isRK 21 | , isDart 22 | , isKite 23 | , HalfTileLabel 24 | , tileLabel 25 | , isMatched 26 | ) where 27 | 28 | import Diagrams.Prelude (V,N, Transformable(..)) -- needed to make HalfTile a Transformable when a is Transformable 29 | import qualified Control.Monad (void) -- used for tileLabel 30 | 31 | {-| 32 | Representing Half Tile Pieces Polymorphicly. 33 | Common code for both graphs and vector representations of tilings. 34 | For Pieces - rep is V2 Double 35 | For TileFaces (in Tgraphs) rep is (Vertex,Vertex,Vertex) 36 | -} 37 | data HalfTile rep = LD !rep -- ^ Left Dart 38 | | RD !rep -- ^ Right Dart 39 | | LK !rep -- ^ Left Kite 40 | | RK !rep -- ^ Right Kite 41 | deriving (Show,Eq) 42 | 43 | -- | Note this ignores the tileLabels when comparing. 44 | -- However we should never have 2 different HalfTiles with the same rep 45 | instance Ord rep => Ord (HalfTile rep) where 46 | -- compare !t1 !t2 = compare (tileRep t1) (tileRep t2) 47 | compare t1 t2 = compare (tileRep t1) (tileRep t2) 48 | 49 | -- |Make Halftile a Functor 50 | instance Functor HalfTile where 51 | fmap f (LD rep) = LD (f rep) 52 | fmap f (RD rep) = RD (f rep) 53 | fmap f (LK rep) = LK (f rep) 54 | fmap f (RK rep) = RK (f rep) 55 | 56 | -- |Needed for Transformable instance of HalfTile - requires TypeFamilies 57 | type instance N (HalfTile a) = N a 58 | -- |Needed for Transformable instance of HalfTile - requires TypeFamilies 59 | type instance V (HalfTile a) = V a 60 | -- |HalfTile inherits Transformable - Requires FlexibleInstances 61 | instance Transformable a => Transformable (HalfTile a) where 62 | transform t = fmap (transform t) 63 | 64 | 65 | 66 | 67 | 68 | 69 | {-# INLINE tileRep #-} 70 | -- |return the representation of a half-tile 71 | tileRep:: HalfTile rep -> rep 72 | tileRep (LD r) = r 73 | tileRep (RD r) = r 74 | tileRep (LK r) = r 75 | tileRep (RK r) = r 76 | 77 | -- |half-tile predicate 78 | isLD,isRD,isLK,isRK,isDart,isKite :: HalfTile rep -> Bool 79 | isLD (LD _) = True 80 | isLD _ = False 81 | isRD (RD _) = True 82 | isRD _ = False 83 | isLK (LK _) = True 84 | isLK _ = False 85 | isRK (RK _) = True 86 | isRK _ = False 87 | isDart x = isLD x || isRD x 88 | isKite x = isLK x || isRK x 89 | 90 | -- |By having () as the half tile representation we treat the constructors as just labels 91 | type HalfTileLabel = HalfTile () 92 | -- |convert a half tile to its label (HalfTileLabel can be compared for equality) 93 | tileLabel :: HalfTile a -> HalfTileLabel 94 | tileLabel = Control.Monad.void -- functor HalfTile (replaces rep value with ()) 95 | 96 | -- | isMatched t1 t2 is True if t1 and t2 have the same HalfTileLabel 97 | -- (i.e. use the same constructor - both LD or both RD or both LK or both RK) 98 | isMatched :: HalfTile rep1 -> HalfTile rep2 -> Bool 99 | isMatched t1 t2 = tileLabel t1 == tileLabel t2 100 | 101 | 102 | 103 | -------------------------------------------------------------------------------- /src/Tgraph/Compose.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Tgraph.Compose 3 | Description : A compose operation for Tgraphs 4 | Copyright : (c) Chris Reade, 2021 5 | License : BSD-style 6 | Maintainer : chrisreade@mac.com 7 | Stability : experimental 8 | 9 | This module includes the main composition operations compose, partCompose, 10 | tryPartCompose, composeF, and partComposeF but also exposes 11 | getDartWingInfo, getDartWingInfoForced (and type DartWingInfo) and composedFaceGroups for debugging and experimenting. 12 | -} 13 | -- {-# LANGUAGE StrictData #-} 14 | 15 | module Tgraph.Compose 16 | ( compose 17 | , partCompose 18 | , partComposeF 19 | , composeF 20 | , tryPartCompose 21 | , partComposeFaces 22 | -- , partComposeFacesF 23 | , DartWingInfo(..) 24 | , getDartWingInfo 25 | , getDartWingInfoForced 26 | , composedFaceGroups 27 | ) where 28 | 29 | import Data.List ((\\), find, foldl',nub) 30 | import qualified Data.IntMap.Strict as VMap (IntMap,lookup,(!)) 31 | import Data.Maybe (mapMaybe) 32 | import qualified Data.IntSet as IntSet (empty,insert,toList,member) 33 | 34 | import Tgraph.Prelude 35 | import Tgraph.Force ( Forced(), forgetF, labelAsForced ) 36 | {------------------------------------------------------------------------- 37 | *************************************************************************** 38 | COMPOSING compose, partCompose, tryPartCompose, uncheckedPartCompose 39 | *************************************************************************** 40 | ---------------------------------------------------------------------------} 41 | 42 | -- |The main compose (partial) function which simply drops the remainder faces from partCompose to return just 43 | -- the composed Tgraph. It will raise an error if the result is not a valid Tgraph 44 | -- (i.e. if it fails the connectedness, no crossing boundary check). 45 | -- It does not assume the given Tgraph is forced. 46 | compose:: Tgraph -> Tgraph 47 | compose = snd . partCompose 48 | 49 | -- |partCompose g is a partial function producing a pair consisting of remainder faces (faces from g which will not compose) 50 | -- and a composed Tgraph. It does not assume the given Tgraph is forced. 51 | -- It checks the composed Tgraph for connectedness and no crossing boundaries raising an error if this check fails. 52 | partCompose:: Tgraph -> ([TileFace],Tgraph) 53 | partCompose g = runTry $ onFail "partCompose:\n" $ tryPartCompose g 54 | 55 | -- |tryPartCompose g tries to produce a Tgraph by composing faces which uniquely compose in g, 56 | -- It checks the resulting new faces for connectedness and no crossing boundaries. 57 | -- If the check is OK it produces Right (remainder, g') where g' is the composed Tgraph and remainder is a list 58 | -- of faces from g which will not compose. If the check fails it produces Left s where s is a failure report. 59 | -- It does not assume the given Tgraph is forced. 60 | tryPartCompose:: Tgraph -> Try ([TileFace],Tgraph) 61 | tryPartCompose g = 62 | do let (remainder,newFaces) = partComposeFaces g 63 | checked <- onFail "tryPartCompose:\n" $ tryConnectedNoCross newFaces 64 | return (remainder,checked) 65 | 66 | -- |partComposeFaces g - produces a pair of the remainder faces (faces from g which will not compose) 67 | -- and the composed faces (which may or may not constitute faces of a valid Tgraph). 68 | -- It does not assume that g is forced. 69 | partComposeFaces:: Tgraph -> ([TileFace],[TileFace]) 70 | partComposeFaces g = (remainder,newfaces) where 71 | compositions = composedFaceGroups $ getDartWingInfo g 72 | newfaces = map fst compositions 73 | remainder = faces g \\ concatMap snd compositions 74 | 75 | -- |partComposeFacesF (does the same as partComposeFaces for a Forced Tgraph). 76 | -- It produces a pair of the remainder faces (faces which will not compose) 77 | -- and the composed faces. 78 | partComposeFacesF :: Forced Tgraph -> ([TileFace],[TileFace]) 79 | partComposeFacesF fg = (remainder,newfaces) where 80 | compositions = composedFaceGroups $ getDartWingInfoForced fg 81 | newfaces = map fst compositions 82 | remainder = faces (forgetF fg) \\ concatMap snd compositions 83 | 84 | -- |partComposeF fg - produces a pair consisting of remainder faces (faces from fg which will not compose) 85 | -- and a composed (Forced) Tgraph. 86 | -- Since fg is a forced Tgraph it does not need a check for validity of the composed Tgraph. 87 | -- The fact that the result is also Forced relies on a theorem. 88 | partComposeF:: Forced Tgraph -> ([TileFace], Forced Tgraph) 89 | partComposeF fg = (remainder, labelAsForced $ makeUncheckedTgraph $! evalFaces newfaces) where 90 | (remainder,newfaces) = partComposeFacesF fg 91 | 92 | -- |composeF - produces a composed Forced Tgraph from a Forced Tgraph. 93 | -- Since the argument is a forced Tgraph it does not need a check for validity of the composed Tgraph. 94 | -- The fact that the function is total and the result is also Forced relies on theorems 95 | -- established for composing. 96 | composeF:: Forced Tgraph -> Forced Tgraph 97 | composeF = snd . partComposeF 98 | 99 | 100 | -- |DartWingInfo is a record type for the result of classifying dart wings in a Tgraph. 101 | -- It includes a faceMap from dart wings to faces at that vertex. 102 | data DartWingInfo = DartWingInfo 103 | { largeKiteCentres :: ![Vertex] 104 | , largeDartBases :: ![Vertex] 105 | , unknowns :: ![Vertex] 106 | , faceMap :: VMap.IntMap [TileFace] 107 | } deriving Show 108 | 109 | -- | getDartWingInfo g, classifies the dart wings in g and calculates a faceMap for each dart wing, 110 | -- returning as DartWingInfo. It does not assume g is forced and is more expensive than getDartWingInfoForced 111 | getDartWingInfo:: Tgraph -> DartWingInfo 112 | getDartWingInfo = getDWIassumeF False 113 | 114 | -- | getDartWingInfoForced fg (fg an explicitly Forced Tgraph) classifies the dart wings in fg and calculates a faceMap for each dart wing, 115 | -- returning as DartWingInfo. 116 | getDartWingInfoForced :: Forced Tgraph -> DartWingInfo 117 | getDartWingInfoForced fg = getDWIassumeF True ( forgetF fg) 118 | 119 | 120 | -- | getDWIassumeF isForced g, classifies the dart wings in g and calculates a faceMap for each dart wing, 121 | -- returning as DartWingInfo. The boolean isForced is used to decide if g can be assumed to be forced. 122 | getDWIassumeF:: Bool -> Tgraph -> DartWingInfo 123 | getDWIassumeF isForced g = 124 | DartWingInfo { largeKiteCentres = IntSet.toList allKcs 125 | , largeDartBases = IntSet.toList allDbs 126 | , unknowns = IntSet.toList allUnks 127 | , faceMap = dwFMap 128 | } where 129 | drts = darts g 130 | dwFMap = vertexFacesMap (nub $ fmap wingV drts) (faces g) 131 | (allKcs,allDbs,allUnks) = foldl' processD (IntSet.empty, IntSet.empty, IntSet.empty) drts 132 | -- kcs = kite centres of larger kites, 133 | -- dbs = dart bases of larger darts, 134 | -- unks = unclassified dart wing tips 135 | -- processD now uses a triple of IntSets rather than lists 136 | processD (kcs, dbs, unks) rd@(RD (orig, w, _)) = -- classify wing tip w 137 | if w `IntSet.member` kcs || w `IntSet.member` dbs then (kcs, dbs, unks) else-- already classified 138 | let 139 | fcs = dwFMap VMap.! w -- faces at w 140 | -- Just fcs = VMap.lookup w dwFMap -- faces at w 141 | in 142 | if length fcs ==1 then (kcs, dbs, IntSet.insert w unks) else -- lone dart wing => unknown 143 | if w `elem` fmap originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else 144 | -- wing is a half kite origin => largeDartBases 145 | if (w,orig) `elem` fmap longE (filter isLD fcs) then (IntSet.insert w kcs,dbs,unks) else 146 | -- long edge rd shared with an ld => largeKiteCentres 147 | if isForced then (kcs, dbs, IntSet.insert w unks) else 148 | case findFarK rd fcs of 149 | Nothing -> (kcs,dbs,IntSet.insert w unks) -- unknown if incomplete kite attached to short edge of rd 150 | Just rk@(RK _) -> 151 | case find (matchingShortE rk) fcs of 152 | Just (LK _) -> (IntSet.insert w kcs,dbs,unks) -- short edge rk shared with an lk => largeKiteCentres 153 | Just (LD _) -> (kcs,IntSet.insert w dbs,unks) -- short edge rk shared with an ld => largeDartBases 154 | _ -> let 155 | newfcs = filter (isAtV (wingV rk)) (faces g) -- faces at rk wing 156 | in 157 | case find (matchingLongE rk) newfcs of -- short edge rk has nothing attached 158 | Nothing -> (kcs,dbs,IntSet.insert w unks) -- long edge of rk has nothing attached => unknown 159 | Just (LD _) -> (IntSet.insert w kcs,dbs,unks) -- long edge rk shared with ld => largeKiteCentres 160 | Just lk@(LK _) -> -- long edge rk shared with lk 161 | case find (matchingShortE lk) newfcs of 162 | Just (RK _) -> (IntSet.insert w kcs,dbs,unks) 163 | -- short edge of this lk shared with another rk => largeKiteCentres 164 | Just (RD _) -> (kcs,IntSet.insert w dbs,unks) 165 | -- short edge of this lk shared with rd => largeDartBases 166 | _ -> (kcs,dbs,IntSet.insert w unks) 167 | Just _ -> error "getDartWingInfo: illegal case for matchingLongE of a right kite" 168 | -- short edge of this lk has nothing attached => unknown 169 | Just _ -> error "getDartWingInfo: non-kite returned by findFarK" 170 | 171 | -- processD now uses a triple of IntSets rather than lists 172 | processD (kcs, dbs, unks) ld@(LD (orig, _, w)) = -- classify wing tip w 173 | if w `IntSet.member` kcs || w `IntSet.member` dbs then (kcs, dbs, unks) else -- already classified 174 | let 175 | fcs = dwFMap VMap.! w -- faces at w 176 | in 177 | if length fcs ==1 then (kcs, dbs, IntSet.insert w unks) else -- lone dart wing => unknown 178 | if w `elem` fmap originV (filter isKite fcs) then (kcs,IntSet.insert w dbs,unks) else 179 | -- wing is a half kite origin => nodeDB 180 | if (w,orig) `elem` fmap longE (filter isRD fcs) then (IntSet.insert w kcs,dbs,unks) else 181 | -- long edge ld shared with an rd => nodeKC 182 | if isForced then (kcs, dbs, IntSet.insert w unks) else 183 | case findFarK ld fcs of 184 | Nothing -> (kcs,dbs,IntSet.insert w unks) -- unknown if incomplete kite attached to short edge of ld 185 | Just lk@(LK _) -> 186 | case find (matchingShortE lk) fcs of 187 | Just (RK _) -> (IntSet.insert w kcs,dbs,unks) -- short edge lk shared with an rk => largeKiteCentres 188 | Just (RD _) -> (kcs,IntSet.insert w dbs,unks) -- short edge lk shared with an rd => largeDartBases 189 | _ -> let 190 | newfcs = filter (isAtV (wingV lk)) (faces g) -- faces at lk wing 191 | in 192 | case find (matchingLongE lk) newfcs of -- short edge lk has nothing attached 193 | Nothing -> (kcs,dbs,IntSet.insert w unks) -- long edge of lk has nothing attached => unknown 194 | Just (RD _) -> (IntSet.insert w kcs,dbs,unks) -- long edge lk shared with rd => largeKiteCentres 195 | Just rk@(RK _) -> -- long edge lk is shared with an rk 196 | case find (matchingShortE rk) newfcs of 197 | Just (LK _) -> (IntSet.insert w kcs,dbs,unks) 198 | -- short edge of this rk shared with another lk => largeKiteCentres 199 | Just (LD _) -> (kcs,IntSet.insert w dbs,unks) 200 | -- short edge of this rk shared with ld => largeDartBases 201 | _ -> (kcs,dbs,IntSet.insert w unks) -- short edge of this rk has nothing attached => unknown 202 | Just _ -> error "getDartWingInfo: illegal case for matchingLongE of a left kite" 203 | 204 | Just _ -> error "getDartWingInfo: non-kite returned by findFarK" 205 | 206 | processD _ _ = error "getDartWingInfo: processD applied to non-dart" 207 | 208 | -- find the two kite halves below a dart half, return the half kite furthest away (not attached to dart). 209 | -- Returns a Maybe. rd produces an rk (or Nothing) ld produces an lk (or Nothing) 210 | findFarK :: TileFace -> [TileFace] -> Maybe TileFace 211 | findFarK rd@(RD _) fcs = do lk <- find (matchingShortE rd) (filter isLK fcs) 212 | find (matchingJoinE lk) (filter isRK fcs) 213 | findFarK ld@(LD _) fcs = do rk <- find (matchingShortE ld) (filter isRK fcs) 214 | find (matchingJoinE rk) (filter isLK fcs) 215 | findFarK _ _ = error "getDartWingInfo: findFarK applied to non-dart face" 216 | 217 | 218 | -- |Creates a list of new composed faces, each paired with a list of old faces (components of the new face) 219 | -- using dart wing information. 220 | -- Auxiliary function but exported for experimenting. 221 | composedFaceGroups :: DartWingInfo -> [(TileFace,[TileFace])] 222 | composedFaceGroups dwInfo = faceGroupRDs ++ faceGroupLDs ++ faceGroupRKs ++ faceGroupLKs where 223 | 224 | faceGroupRDs = fmap (\gp -> (makenewRD gp,gp)) groupRDs 225 | groupRDs = mapMaybe groupRD (largeDartBases dwInfo) 226 | makenewRD [rd,lk] = makeRD (originV lk) (originV rd) (oppV lk) 227 | makenewRD _ = error "composedFaceGroups: RD case" 228 | groupRD v = do fcs <- VMap.lookup v (faceMap dwInfo) 229 | rd <- find isRD fcs 230 | lk <- find (matchingShortE rd) fcs 231 | return [rd,lk] 232 | 233 | faceGroupLDs = fmap (\gp -> (makenewLD gp,gp)) groupLDs 234 | groupLDs = mapMaybe groupLD (largeDartBases dwInfo) 235 | makenewLD [ld,rk] = makeLD (originV rk) (oppV rk) (originV ld) 236 | makenewLD _ = error "composedFaceGroups: LD case" 237 | groupLD v = do fcs <- VMap.lookup v (faceMap dwInfo) 238 | ld <- find isLD fcs 239 | rk <- find (matchingShortE ld) fcs 240 | return [ld,rk] 241 | 242 | faceGroupRKs = fmap (\gp -> (makenewRK gp,gp)) groupRKs 243 | groupRKs = mapMaybe groupRK (largeKiteCentres dwInfo) 244 | makenewRK [rd,_,rk] = makeRK (originV rd) (wingV rk) (originV rk) 245 | makenewRK _ = error "composedFaceGroups: RK case" 246 | groupRK v = do fcs <- VMap.lookup v (faceMap dwInfo) 247 | rd <- find isRD fcs 248 | lk <- find (matchingShortE rd) fcs 249 | rk <- find (matchingJoinE lk) fcs 250 | return [rd,lk,rk] 251 | 252 | faceGroupLKs = fmap (\gp -> (makenewLK gp,gp)) groupLKs 253 | groupLKs = mapMaybe groupLK (largeKiteCentres dwInfo) 254 | makenewLK [ld,_,lk] = makeLK (originV ld) (originV lk) (wingV lk) 255 | makenewLK _ = error "composedFaceGroups: LK case" 256 | groupLK v = do fcs <- VMap.lookup v (faceMap dwInfo) 257 | ld <- find isLD fcs 258 | rk <- find (matchingShortE ld) fcs 259 | lk <- find (matchingJoinE rk) fcs 260 | return [ld,rk,lk] 261 | 262 | 263 | 264 | 265 | -------------------------------------------------------------------------------- /src/Tgraph/Decompose.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Tgraph.Decompose 3 | Description : A decompose operation for Tgraphs 4 | Copyright : (c) Chris Reade, 2021 5 | License : BSD-style 6 | Maintainer : chrisreade@mac.com 7 | Stability : experimental 8 | 9 | This module defines decompose and decompositions for Tgraphs, but also exposes 10 | two auxiliary functions for debugging and experimenting. 11 | -} 12 | {-# LANGUAGE BangPatterns #-} 13 | 14 | module Tgraph.Decompose 15 | ( decompose 16 | , decompositions 17 | , phiVMap 18 | , decompFace 19 | ) where 20 | 21 | import qualified Data.Map.Strict as Map (Map, (!), fromList) 22 | import Data.List(sort) 23 | 24 | import Tgraph.Prelude 25 | 26 | 27 | 28 | {------------------------------- 29 | ************************************** 30 | DECOMPOSING - decompose 31 | ************************************** 32 | ----------------------------------} 33 | 34 | 35 | -- |Decompose a Tgraph. 36 | decompose :: Tgraph -> Tgraph 37 | decompose g = makeUncheckedTgraph newFaces where 38 | pvmap = phiVMap g 39 | !newFaces = evalFaces $ concatMap (decompFace pvmap) (faces g) 40 | 41 | -- |phiVMap g produces a finite map from the phi edges (the long edges including kite joins) to assigned new vertices not in g. 42 | -- Both (a,b) and (b,a) get the same new vertex number. This is used(in decompFace and decompose. 43 | -- (Sort is used to fix order of assigned numbers). 44 | -- (Exported for use in TrackedTgraphs in Tgraphs module). 45 | phiVMap :: Tgraph -> Map.Map Dedge Vertex 46 | phiVMap g = edgeVMap where 47 | phiReps = sort [(a,b) | (a,b) <- phiEdges g, a TileFace -> [TileFace] 58 | decompFace newVFor fc = case fc of 59 | RK(a,b,c) -> [RK(c,x,b), LK(c,y,x), RD(a,x,y)] 60 | where !x = (Map.!) newVFor (a,b) 61 | !y = (Map.!) newVFor (c,a) 62 | LK(a,b,c) -> [LK(b,c,y), RK(b,y,x), LD(a,x,y)] 63 | where !x = (Map.!) newVFor (a,b) 64 | !y = (Map.!) newVFor (c,a) 65 | RD(a,b,c) -> [LK(a,x,c), RD(b,c,x)] 66 | where !x = (Map.!) newVFor (a,b) 67 | LD(a,b,c) -> [RK(a,b,x), LD(c,x,b)] 68 | where !x = (Map.!) newVFor (a,c) 69 | 70 | -- |infinite list of decompositions of a Tgraph 71 | decompositions :: Tgraph -> [Tgraph] 72 | decompositions = iterate decompose 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /src/Tgraph/Relabelling.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Tgraph.Relabelling 3 | Description : Guided union and commonFaces using relabelling operations 4 | Copyright : (c) Chris Reade, 2021 5 | License : BSD-style 6 | Maintainer : chrisreade@mac.com 7 | Stability : experimental 8 | 9 | This module includes relabelling functions for Tgraphs whose main purpose is 10 | to implement a guided union of Tgraphs (fullUnion and tryFullUnion) 11 | and also a commonFaces operation (a kind of intersection which need not be a Tgraph) 12 | and a guided equality check (sameGraph). 13 | -} 14 | module Tgraph.Relabelling 15 | ( -- * Assisted Union (and matching) operations 16 | fullUnion 17 | , tryFullUnion 18 | -- * commonFaces (Assisted Intersection) and sameGraph (Assisted Equivalence) 19 | , commonFaces 20 | , sameGraph 21 | -- * Creating Relabellings 22 | , Relabelling(..) 23 | , newRelabelling 24 | -- , relabellingFrom 25 | -- , relabellingTo 26 | -- , relabelUnion 27 | -- * Relabellings and matching 28 | , relabelToMatch 29 | , tryRelabelToMatch 30 | -- , tryRelabelFromFaces 31 | -- , tryGrowRelabel 32 | , relabelToMatchIgnore 33 | -- , relabelFromFacesIgnore 34 | -- , growRelabelIgnore 35 | -- * Using Relabellings 36 | , relabelGraph 37 | , checkRelabelGraph 38 | , relabelFace 39 | , relabelV 40 | -- , relabelAvoid 41 | , prepareFixAvoid 42 | , relabelContig 43 | -- * Renumbering (not necessarily 1-1) 44 | -- , tryMatchFace 45 | -- , twoVMatch 46 | -- , matchFaceIgnore 47 | -- , differing 48 | ) where 49 | 50 | 51 | import Data.List (intersect, (\\), union,find,partition,nub) 52 | import qualified Data.IntMap.Strict as VMap (IntMap, findWithDefault, fromList, fromAscList, union) 53 | import qualified Data.IntSet as IntSet (fromList,intersection,findMax,elems,(\\),null,member) 54 | 55 | import Tgraph.Prelude 56 | 57 | 58 | {-| 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 59 | and (possibly relabelled) faces of g2 as a Tgraph. It does this 60 | by first matching the respective edges e1 and e2 and relabelling g2 to match g1 on a tile-connected region containing e1. 61 | It will raise an error if there is a mismatch. 62 | If succesfull it then uses geometry of tiles (vertex locations) to correct for multiple overlapping regions 63 | of tiles in g1 and relabelled g2 by a further relabelling of any touching vertices. 64 | The resulting union of faces requires an expensive tryTgraphProps if touching vertices were found. 65 | However the check is not needed when there are no touching vertices (i.e. a single tile-connected overlap). 66 | -} 67 | fullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph 68 | fullUnion (g1,e1) (g2,e2) = runTry $ tryFullUnion (g1,e1) (g2,e2) 69 | 70 | {-| 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 71 | and (possibly relabelled) faces of g2 as a Tgraph. It does this 72 | by first matching the respective edges e1 and e2 and relabelling g2 to match g1 on a tile-connected region containing e1. 73 | It returns Left lines if there is a mismatch (where lines explains the problem). 74 | If succesfull it then uses geometry of tiles (vertex locations) to correct for multiple overlapping regions 75 | of tiles in g1 and relabelled g2 by a further relabelling of any touching vertices. 76 | The resulting union of faces requires an expensive tryTgraphProps if any touching vertices were found, 77 | and will return Left ... if this fails and Right t otherwise, where t is a Tgraph 78 | containing the union of faces. 79 | The check is not used when there are no touching vertices (i.e. a single tile-connected overlap). 80 | -} 81 | tryFullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph 82 | tryFullUnion (g1,e1) (g2,e2) = onFail "tryFullUnion:\n" $ 83 | do g3 <- tryRelabelToMatch (g1,e1) (g2,e2) 84 | let fcs = faces g1 `union` faces g3 85 | touchVs = touchingVertices fcs 86 | if null touchVs 87 | then return $ makeUncheckedTgraph fcs -- no properties check needed! 88 | else let vertg1 = vertexSet g1 89 | correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e 90 | newrel = newRelabelling $ fmap correct touchVs 91 | in tryTgraphProps $ nub $ fmap (relabelFace newrel) fcs 92 | 93 | 94 | -- | commonFaces (g1,e1) (g2,e2) relabels g2 to match with g1 (where they match) 95 | -- and returns the common faces as a subset of faces of g1. 96 | -- i.e. with g1 vertex labelling. 97 | -- It requires a face in g1 with directed edge e1 to match a face in g2 with directed edge e2, 98 | -- (apart from the third vertex label) otherwise an error is raised. 99 | -- This uses vertex locations to correct touching vertices in multiply overlapping regions. 100 | -- >>>> touching vertices being 1-1 is sensitive to nearness check of touchingVerticesGen <<<<<<<<< 101 | commonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> [TileFace] 102 | commonFaces (g1,e1) (g2,e2) = faces g1 `intersect` relFaces where 103 | g3 = relabelToMatchIgnore (g1,e1) (g2,e2) 104 | fcs = faces g1 `union` faces g3 105 | touchVs = touchingVerticesGen fcs -- requires generalised version of touchingVertices 106 | relFaces = fmap (relabelFace $ newRelabelling $ fmap correct touchVs) (faces g3) 107 | vertg1 = vertexSet g1 108 | correct e@(a,b) = if a `IntSet.member` vertg1 then (b,a) else e 109 | 110 | 111 | -- | sameGraph (g1,e1) (g2,e2) checks to see if g1 and g2 are the same Tgraph after relabelling g2. 112 | -- The relabelling is based on directed edge e2 in g2 matching e1 in g1 (where the direction is clockwise round a face) 113 | -- and uses tryRelabelToMatch. 114 | sameGraph :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Bool 115 | sameGraph (g1,e1) (g2,e2) = length (faces g1) == length (faces g2) && 116 | ifFail False tryResult where 117 | tryResult = do g <- tryRelabelToMatch (g1,e1) (g2,e2) 118 | return (vertexSet g == vertexSet g1) 119 | 120 | 121 | -- |Relabelling is a special case of mappings from vertices to vertices that are not the 122 | -- identity on a finite number of vertices. 123 | -- They are represented by keeping the non identity cases in a finite map. 124 | -- When applied, we assume the identity map for vertices not found in the representation domain 125 | -- (see relabelV). Relabellings must be 1-1 on their representation domain, 126 | -- and redundant identity mappings are removed in the representation. 127 | -- Vertices in the range of a relabelling must be >0. 128 | newtype Relabelling = Relabelling (VMap.IntMap Vertex) 129 | 130 | -- | newRelabelling prs - make a relabelling from a finite list of vertex pairs. 131 | -- The first item in each pair relabels to the second in the pair. 132 | -- The resulting relabelling excludes any identity mappings of vertices. 133 | -- An error is raised if second items of the pairs contain duplicated numbers or a number<1 134 | newRelabelling :: [(Vertex,Vertex)] -> Relabelling 135 | newRelabelling prs 136 | | wrong (map snd prs) = error $ "newRelabelling: Not 1-1 or Non-positive label in range " ++ show prs 137 | | otherwise = Relabelling $ VMap.fromList $ differing prs 138 | where wrong vs = any (<1) vs || not (null (duplicates vs)) 139 | 140 | -- | relabellingFrom n vs - make a relabelling from finite set of vertices vs. 141 | -- Elements of vs are ordered and relabelled from n upwards (an error is raised if n<1). 142 | -- The resulting relabelling excludes any identity mappings of vertices. 143 | relabellingFrom :: Int -> VertexSet -> Relabelling 144 | relabellingFrom n vs 145 | | n<1 = error $ "relabellingFrom: Label not positive " ++ show n 146 | | otherwise = Relabelling $ VMap.fromAscList $ differing $ zip (IntSet.elems vs) [n..] 147 | 148 | -- | f1 \`relabellingTo\` f2 - creates a relabelling so that 149 | -- if applied to face f1, the vertices will match with face f2 exactly. 150 | -- It does not check that the tile faces have the same form (LK,RK,LD,RD). 151 | relabellingTo :: TileFace -> TileFace -> Relabelling 152 | f1 `relabellingTo` f2 = newRelabelling $ zip (faceVList f1) (faceVList f2) -- f1 relabels to f2 153 | 154 | -- | Combine relabellings (assumes disjoint representation domains and disjoint representation ranges but 155 | -- no check is made for these). 156 | relabelUnion:: Relabelling -> Relabelling -> Relabelling 157 | relabelUnion (Relabelling r1) (Relabelling r2) = Relabelling $ VMap.union r1 r2 158 | 159 | 160 | {-|relabelToMatch (g1,e1) (g2,e2) produces a relabelled version of g2 that is 161 | consistent with g1 on a single tile-connected region of overlap. 162 | The overlapping region must contain the directed edge e1 in g1. The edge e2 in g2 163 | will be identified with e1 by the relabelling of g2. 164 | This produces an error if a mismatch is found anywhere in the overlap. 165 | 166 | CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1. 167 | If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1 168 | will be tile-connected but may have touching vertices. 169 | This limitation is addressed by fullUnion. 170 | -} 171 | relabelToMatch:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph 172 | relabelToMatch ge1 ge2 = runTry $ tryRelabelToMatch ge1 ge2 173 | 174 | {-|tryRelabelToMatch (g1,e1) (g2,e2) produces either Right g where g is a relabelled version of g2 that is 175 | consistent with g1 on an overlapping tile-connected region or Left lines if there is a mismatch (lines explaining the problem). 176 | The overlapping region must contain the directed edge e1 in g1. The edge e2 in g2 177 | will be identified with e1 by the relabelling of g2. 178 | 179 | CAVEAT: The relabelling may not be complete if the overlap is not just a SINGLE tile-connected region in g1. 180 | If the overlap is more than a single tile-connected region, then the union of the relabelled faces with faces in g1 181 | will be tile-connected but may have touching vertices. 182 | This limitation is addressed by tryFullUnion. 183 | -} 184 | tryRelabelToMatch :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph 185 | tryRelabelToMatch (g1,(x1,y1)) (g2,(x2,y2)) = onFail "tryRelabelToMatch:\n" $ 186 | do let g2prepared = prepareFixAvoid [x2,y2] (vertexSet g1) g2 187 | fc2 <- find (`hasDedge` (x2,y2)) (faces g2prepared) 188 | `nothingFail` ("No face found for edge " ++ show (x2,y2)) 189 | maybef <- tryMatchFace (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1 190 | fc1 <- maybef `nothingFail` 191 | ("No matching face found at edge "++show (x1,y1)++ 192 | "\nfor relabelled face " ++ show fc2) 193 | -- assert g2prepared has no labels in common with g1 except possibly those in fc2 194 | tryRelabelFromFaces (g1,fc1) (g2prepared,fc2) 195 | 196 | {-|tryRelabelFromFaces is an auxiliary function for tryRelabelToMatch. 197 | tryRelabelFromFaces (g1,fc1) (g2,fc2) - fc1 and fc2 should have the same form (RK,LK,RD,LD), 198 | with fc1 a face in g1 and fc2 a face in g2. 199 | g2 must have no vertices in common with g1 except for (possibly) vertices in fc2. 200 | The result is either Right g3 where 201 | g3 is a relabelling of g2 which is consistent with g1 in a single region of overlap containing fc1 if this is possible, or 202 | Left lines if there is a mismatch (lines explaining the problem). 203 | In the successful case fc2 will be relabelled to fc1. 204 | 205 | CAVEAT: Only the single tile-connected region of common overlap (containing fc2) of g2 gets relabelled 206 | to match with g1. 207 | -} 208 | tryRelabelFromFaces :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Try Tgraph 209 | tryRelabelFromFaces (g1,fc1) (g2,fc2) = onFail "tryRelabelFromFaces:\n" $ 210 | do rlab <- tryGrowRelabel g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1) 211 | return $ relabelGraph rlab g2 212 | 213 | {-|tryGrowRelabel is used by tryRelabelFromFaces to build a relabelling map which can fail, producing Left lines. 214 | In the successful case it produces a Right rlab 215 | where rlab is the required relabelling. 216 | The arguments are: g processing awaiting rlab where 217 | g is the Tgraph being matched against; 218 | processing is a list of faces to be matched next 219 | (each has an edge in common with at least one previously matched face or it is the starting face); 220 | awaiting is a list of faces that have not yet been tried for a match and are not 221 | tile-connected to any faces already matched. 222 | rlab is the relabelling so far. 223 | 224 | The idea is that from a single matched starting face we process faces that share an edge with a 225 | previously matched face. Each face processed should have a match in g (with 2 matching vertices). 226 | If a face is tried but has no such match, it is ignored (it may share some boundary with g, but 227 | for the overlap to be a single tile-connected region, only boundaries with matched tiles are possible 228 | and therefore relabelling will already be done for the boundary). 229 | If a processed face has an edge in common with a face in g it has to match exactly 230 | apart from (possibly) the third vertex label, 231 | otherwise the faces do not match and this 232 | indicates a mismatch on the overlap and Left ... is returned. 233 | -} 234 | tryGrowRelabel:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Try Relabelling 235 | tryGrowRelabel _ [] _ rlab = Right rlab -- awaiting are not tile-connected to overlap region 236 | tryGrowRelabel g (fc:fcs) awaiting rlab = 237 | do maybef <- tryMatchFace (relabelFace rlab fc) g 238 | case maybef of 239 | Nothing -> tryGrowRelabel g fcs awaiting rlab 240 | Just orig -> tryGrowRelabel g (fcs++fcs') awaiting' rlab' 241 | where (fcs', awaiting') = partition (edgeNb fc) awaiting 242 | rlab' = relabelUnion (fc `relabellingTo` orig) rlab 243 | 244 | 245 | 246 | -- |same as relabelToMatch but ignores non-matching faces (except for the initial 2) 247 | -- The initial 2 faces are those on the given edges, and an error is raised if they do not match. 248 | -- This is used by commonFaces 249 | relabelToMatchIgnore :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Tgraph 250 | relabelToMatchIgnore (g1,(x1,y1)) (g2,(x2,y2)) = relabelFromFacesIgnore (g1,fc1) (g2prepared,fc2) where 251 | g2prepared = prepareFixAvoid [x2,y2] (vertexSet g1) g2 252 | fc2 = case find (`hasDedge` (x2,y2)) (faces g2prepared) of 253 | Nothing -> error $ "No face found for edge " ++ show (x2,y2) 254 | Just f -> f 255 | fc1 = case matchFaceIgnore (relabelFace (newRelabelling [(x2,x1),(y2,y1)]) fc2) g1 of 256 | Nothing -> error $ "No matching face found at edge "++show (x1,y1)++ 257 | "\nfor relabelled face " ++ show fc2 258 | Just f -> f 259 | 260 | 261 | {-| relabelFromFacesIgnore is an auxiliary function for relabelToMatchIgnore. 262 | It is similar to tryRelabelFromFaces except that it uses growRelabelIgnore and matchFaceIgnore 263 | which ignores non-matching faces rather than failing. It thus returns a definite relabelled Tgraph. 264 | tryRelabelFromFaces (g1,fc1) (g2,fc2) - fc1 and fc2 should have the same form (RK,LK,RD,LD), 265 | with fc1 a face in g1 and fc2 a face in g2. 266 | g2 must have no vertices in common with g1 except for (possibly) vertices in fc2. 267 | The result is g3 where 268 | g3 is a relabelling of g2 which is consistent with g1 in a common single region of overlap containing fc1. 269 | 270 | CAVEAT: Only the single tile-connected region of common overlap (containing fc2) of g2 gets relabelled 271 | to match with g1. 272 | -} 273 | relabelFromFacesIgnore :: (Tgraph,TileFace) -> (Tgraph,TileFace) -> Tgraph 274 | relabelFromFacesIgnore (g1,fc1) (g2,fc2) = relabelGraph rlab g2 where 275 | rlab = growRelabelIgnore g1 [fc2] (faces g2 \\ [fc2]) (fc2 `relabellingTo` fc1) 276 | 277 | -- |growRelabelIgnore is similar to tryGrowRelabel except that it uses matchFaceIgnore (instead of tryMatchFace) 278 | -- which ignores non-matching faces rather than failing. It thus returns a definite Relabelling. 279 | growRelabelIgnore:: Tgraph -> [TileFace] -> [TileFace] -> Relabelling -> Relabelling 280 | growRelabelIgnore _ [] _ rlab = rlab -- awaiting are not tile-connected to overlap region 281 | growRelabelIgnore g (fc:fcs) awaiting rlab = 282 | case matchFaceIgnore (relabelFace rlab fc) g of 283 | Nothing -> growRelabelIgnore g fcs awaiting rlab 284 | Just orig -> growRelabelIgnore g (fcs++fcs') awaiting' rlab' 285 | where (fcs', awaiting') = partition (edgeNb fc) awaiting 286 | rlab' = relabelUnion (fc `relabellingTo` orig) rlab 287 | 288 | 289 | -- |relabelGraph rlab g - uses a Relabelling rlab to change vertices in a Tgraph g. 290 | -- Caveat: This should only be used when it is known that: 291 | -- rlab is 1-1 on its (representation) domain, and 292 | -- the vertices of g are disjoint from those vertices that are in the representation range 293 | -- but which are not in the representation domain of rlab. 294 | -- This ensures rlab (extended with the identity) remains 1-1 on vertices in g, 295 | -- so that the resulting Tgraph does not need an expensive check for Tgraph properties. 296 | -- (See also checkRelabelGraph) 297 | relabelGraph:: Relabelling -> Tgraph -> Tgraph 298 | relabelGraph rlab g = makeUncheckedTgraph newFaces where 299 | newFaces = fmap (relabelFace rlab) (faces g) 300 | 301 | -- |checkRelabelGraph uses a relabelling map to change vertices in a Tgraph, 302 | -- then checks that the result is a valid Tgraph. (see also relabelGraph) 303 | checkRelabelGraph:: Relabelling -> Tgraph -> Tgraph 304 | checkRelabelGraph rlab g = checkedTgraph newFaces where 305 | newFaces = fmap (relabelFace rlab) (faces g) 306 | 307 | -- |Uses a relabelling to relabel the three vertices of a face. 308 | -- Any vertex not in the domain of the mapping is left unchanged. 309 | -- The mapping should be 1-1 on the 3 vertices to avoid creating a self loop edge. 310 | relabelFace:: Relabelling -> TileFace -> TileFace 311 | relabelFace rlab = fmap (all3 (relabelV rlab)) where -- fmap of HalfTile Functor 312 | all3 f (a,b,c) = (f a,f b,f c) 313 | 314 | -- |relabelV rlab v - uses relabelling rlab to find a replacement for v (leaves as v if none found). 315 | -- I.e relabelV turns a Relabelling into a total function using identity 316 | -- for undefined cases in the Relabelling representation. 317 | relabelV:: Relabelling -> Vertex -> Vertex 318 | relabelV (Relabelling r) v = VMap.findWithDefault v v r 319 | 320 | -- |relabelAvoid avoid g - produces a new Tgraph from g by relabelling. 321 | -- Any vertex in g that is in the set avoid will be changed to a new vertex that is 322 | -- neither in g nor in the set avoid. Vertices in g that are not in avoid will remain the same. 323 | relabelAvoid :: VertexSet -> Tgraph -> Tgraph 324 | relabelAvoid avoid g = relabelGraph rlab g where 325 | gverts = vertexSet g 326 | avoidMax = if IntSet.null avoid then 0 else IntSet.findMax avoid 327 | vertsToChange = gverts `IntSet.intersection` avoid 328 | rlab = relabellingFrom (1+ max (maxV g) avoidMax) vertsToChange 329 | -- assert: rlab is 1-1 on the vertices of g 330 | -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does) 331 | -- assert: the relabelled Tgraph does not have vertices in the set avoid 332 | 333 | 334 | {-|prepareFixAvoid fix avoid g - produces a new Tgraph from g by relabelling. 335 | 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 336 | neither in g nor in the set (avoid with fix removed). 337 | All other vertices of g (including those in fix) will remain the same. 338 | Usage: This is used to prepare a graph by avoiding accidental label clashes with the avoid set 339 | (usually vertices of another graph). 340 | However we fix a list of vertices which we intend to control in a subsequent relabelling. 341 | (this is usually a pair of vertices from a directed edge that will get a specific subsequent relabelling). 342 | Note: If any element of the list fix is not a vertex in g, it could end up in the relabelled Tgraph. 343 | -} 344 | prepareFixAvoid :: [Vertex] -> VertexSet -> Tgraph -> Tgraph 345 | prepareFixAvoid fix avoid = relabelAvoid (avoid IntSet.\\ IntSet.fromList fix) 346 | -- assert: the relabelled Tgraph satisfies Tgraph properties (if the argument Tgraph does) 347 | -- assert: the relabelled Tgraph does not have vertices in the set (avoid\\fix) 348 | 349 | -- |Relabel all vertices in a Tgraph using new labels 1..n (where n is the number of vertices). 350 | relabelContig :: Tgraph -> Tgraph 351 | relabelContig g = relabelGraph rlab g where 352 | rlab = relabellingFrom 1 (vertexSet g) 353 | -- assert: rlab is 1-1 on the vertices of g 354 | -- assert: the relabelled Tgraph satisfies Tgraph properties (if g does) 355 | 356 | {-| 357 | tryMatchFace f g - looks for a face in g that corresponds to f (sharing a directed edge), 358 | If the corresponding face does not match properly (with twoVMatch) this stops the 359 | matching process returning Left ... to indicate a failed match. 360 | Otherwise it returns either Right (Just f) where f is the matched face or 361 | Right Nothing if there is no corresponding face. 362 | -} 363 | tryMatchFace:: TileFace -> Tgraph -> Try (Maybe TileFace) 364 | tryMatchFace face g = onFail "tryMatchFace:\n" $ 365 | case find (`hasDedgeIn` faceDedges face) (faces g) of 366 | Nothing -> Right Nothing 367 | Just corresp -> if twoVMatch corresp face 368 | then Right $ Just corresp 369 | else failReports 370 | ["Found non matching faces " 371 | ,show (corresp, face) 372 | ,"\n" 373 | ] 374 | 375 | -- |twoVMatch f1 f2 is True if the two tilefaces are the same except 376 | -- for a single vertex label possibly not matching. 377 | twoVMatch:: TileFace -> TileFace -> Bool 378 | twoVMatch f1 f2 = isMatched f1 f2 && 379 | if firstV f1 == firstV f2 380 | then secondV f1 == secondV f2 || thirdV f1 == thirdV f2 381 | else secondV f1 == secondV f2 && thirdV f1 == thirdV f2 382 | 383 | {-|A version of tryMatchFace that just ignores mismatches. 384 | matchFaceIgnore f g - looks for a face in g that corresponds to f (sharing a directed edge), 385 | If there is a corresponding face f' which matches label and corresponding directed edge then Just f' is returned 386 | Otherwise Nothing is returned. (Thus ignoring a clash) 387 | -} 388 | matchFaceIgnore:: TileFace -> Tgraph -> Maybe TileFace 389 | matchFaceIgnore face g = case tryMatchFace face g of 390 | Right mf -> mf 391 | Left _ -> Nothing 392 | 393 | -- |selects the non-equal pairs from a list 394 | differing :: Eq a => [(a,a)] -> [(a,a)] 395 | differing = filter $ uncurry (/=) -- (\(a,b) -> a/=b) 396 | 397 | 398 | 399 | -------------------------------------------------------------------------------- /src/TgraphExamples.hs: -------------------------------------------------------------------------------- 1 | 2 | {-| 3 | Module : TgraphExamples 4 | Description : Examples of tilings represented with Tgraphs and their diagrams 5 | Copyright : (c) Chris Reade, 2021 6 | License : BSD-style 7 | Maintainer : chrisreade@mac.com 8 | Stability : experimental 9 | 10 | -} 11 | {-# LANGUAGE NoMonomorphismRestriction #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | 15 | 16 | module TgraphExamples 17 | (-- * Some Layout tools 18 | padBorder 19 | , chunks 20 | , arrangeRowsGap 21 | , arrangeRows 22 | , labelAt 23 | -- * Tgraphs for 7 vertex types 24 | , sunGraph 25 | , jackGraph 26 | , kingGraph 27 | , queenGraph 28 | , aceGraph 29 | , deuceGraph 30 | , starGraph 31 | -- * Further Basic Tgraphs 32 | , kiteGraph 33 | , dartGraph 34 | , fool 35 | , foolD 36 | , foolDminus 37 | , foolDs 38 | , sunDs 39 | , kiteDs 40 | , dartDs 41 | , dartD4 42 | , sun3Dart 43 | -- * Some Simple Figures 44 | , foolFig 45 | , foolAndFoolD 46 | , figSunD3D2 47 | -- * Figures for 7 vertex types 48 | , vertexTypesFig 49 | , forceVFigures 50 | -- * Partial Composition figures 51 | , pCompFig1 52 | , pCompFig2 53 | , pCompFig 54 | -- * Forced Tgraph figures 55 | , forceFoolDminus 56 | , forceDartD5Fig 57 | , forceKiteD5Fig 58 | , forceSunD5Fig 59 | , forceFig 60 | -- * Removed faces (forcing and composing) 61 | , brokenDart 62 | , badlyBrokenDart 63 | , brokenDartFig 64 | , badlyBrokenDartFig 65 | , removeIncompletesFig 66 | -- * Incorrect Tgraphs 67 | , mistake 68 | , mistake1 69 | -- * superForce Figure 70 | , superForceFig 71 | , superForceRocketsFig 72 | -- * Tgraphs with Boundary faces 73 | , boundaryFDart4 74 | , boundaryFDart5 75 | , boundaryFDart4Fig 76 | , boundaryFDart5Fig 77 | , boundaryGapFDart4 78 | , boundaryGapFDart5 79 | , boundaryGap4Fig 80 | , boundaryGap5Fig 81 | -- * Boundary coverings and empires 82 | , boundaryVCoveringFigs 83 | , boundaryECoveringFigs 84 | , kingECoveringFig 85 | , kingVCoveringFig 86 | , kingEmpiresFig 87 | , kingEmpire1Fig 88 | , kingEmpire2Fig 89 | -- * Emplace Choices 90 | , emplaceChoices 91 | , emplaceChoicesFig 92 | 93 | ) where 94 | 95 | import Diagrams.Prelude 96 | import PKD 97 | import Tgraph.Prelude as NoWarn (makeUncheckedTgraph) 98 | import Data.List (intersect,find) -- for emplaceChoices 99 | 100 | 101 | -- |used for most diagrams to give border padding 102 | padBorder :: OKBackend b => 103 | Diagram b -> Diagram b 104 | padBorder = pad 1.2 . centerXY 105 | 106 | -- |chunks n l - split a list l into chunks of length n (n>0) 107 | chunks::Int -> [a] -> [[a]] 108 | chunks n 109 | | n < 1 = error "chunks: argument <1\n" 110 | | otherwise = ch where 111 | ch [] = [] 112 | ch as = take n as : ch (drop n as) 113 | 114 | -- |arrangeRowsGap s n diags - arranges diags into n per row, centering each row horizontally, 115 | -- with a seperation gap (horizontally and vertically) of s. 116 | -- The result is a single diagram. 117 | arrangeRowsGap :: OKBackend b => 118 | Double -> Int -> [Diagram b] -> Diagram b 119 | arrangeRowsGap s n = centerY . vsep s . fmap (centerX . hsep s) . chunks n 120 | 121 | -- |arrangeRows n diags - arranges diags into n per row, centering each row horizontally. 122 | -- The result is a single diagram (seperation is 1 unit vertically and horizontally). 123 | arrangeRows :: OKBackend b => 124 | Int -> [Diagram b] -> Diagram b 125 | arrangeRows = arrangeRowsGap 1.0 126 | 127 | -- |add a given label at a given point offset from the centre of the given diagram. 128 | labelAt :: OKBackend b => 129 | Point V2 Double -> String -> Diagram b -> Diagram b 130 | labelAt p l d = baselineText l # fontSize (output 15) # moveTo p <> d 131 | --labelAt p l d = baselineText l # fontSize (normalized 0.02) # moveTo p <> d 132 | 133 | 134 | fool, foolD, foolDminus:: Tgraph 135 | -- |fool: fool's kite - also called an ace. 136 | 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)] 137 | -- 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)] 138 | 139 | -- |a once decomposed fool (= foolDs!!1) 140 | foolD = decompose fool 141 | 142 | -- |foolDminus: 3 faces removed from foolD - still a valid Tgraph 143 | foolDminus = removeFaces [RD (5,15,13), LD (5,16,15), RK (7,11,2)] foolD 144 | -- foolDminus = removeFaces [RD (6,15,13), LD (6,17,15), RK (5,11,2)] foolD 145 | 146 | -- | an infinite list of decompositions of fool 147 | foolDs :: [Tgraph] 148 | foolDs = decompositions fool 149 | 150 | -- | diagram of just fool. 151 | foolFig :: OKBackend b => Diagram b 152 | foolFig = padBorder $ labelSize normal drawj fool 153 | 154 | -- |diagram of fool with foolD. 155 | foolAndFoolD :: OKBackend b => Diagram b 156 | foolAndFoolD = padBorder $ hsep 1 [scale phi $ labelled drawj fool, labelled drawj foolD] 157 | 158 | -- |Tgraph for a sun (sun vertex type) 159 | sunGraph :: Tgraph 160 | sunGraph = makeTgraph 161 | [ RK (1,2,11), LK (1,3,2) 162 | , RK (1,4,3) , LK (1,5,4) 163 | , RK (1,6,5) , LK (1,7,6) 164 | , RK (1,8,7) , LK (1,9,8) 165 | , RK (1,10,9), LK (1,11,10) 166 | ] 167 | -- | an infinite list of decompositions of sunGraph 168 | sunDs :: [Tgraph] 169 | sunDs = decompositions sunGraph 170 | 171 | -- |Figure for a 3 times decomposed sun with a 2 times decomposed sun. 172 | figSunD3D2 :: OKBackend b => Diagram b 173 | figSunD3D2 = padBorder $ hsep 1 [labelled drawj $ sunDs !! 3, scale phi $ labelled drawj $ sunDs !! 2] 174 | 175 | -- |Tgraph for kite 176 | kiteGraph :: Tgraph 177 | kiteGraph = makeTgraph [ RK (1,2,4), LK (1,3,2)] 178 | 179 | -- | an infinite list of decompositions of a kite 180 | kiteDs :: [Tgraph] 181 | kiteDs = decompositions kiteGraph 182 | 183 | -- |Tgraph for a dart 184 | dartGraph :: Tgraph 185 | dartGraph = makeTgraph [ RD (1,2,3), LD (1,3,4)] 186 | 187 | -- | an infinite list of decompositions of a dart 188 | dartDs :: [Tgraph] 189 | dartDs = decompositions dartGraph 190 | 191 | -- |Tgraph of 4 times decomposed dartGraph (used in several examples) 192 | dartD4 :: Tgraph 193 | dartD4 = dartDs!!4 194 | 195 | 196 | 197 | 198 | pCompFig1,pCompFig2,pCompFig :: OKBackend b => Diagram b 199 | -- |diagram showing partial composition of a forced 3 times decomposed dart (with remainder faces in pale green). 200 | pCompFig1 = lw veryThin $ hsep 5 $ rotations [1,1] [draw fd3, drawPCompose fd3] 201 | where fd3 = force $ dartDs!!3 202 | -- |diagram showing partial composition of a forced 3 times decomposed kite (with remainder faces in pale green). 203 | pCompFig2 = lw veryThin $ hsep 5 [draw fk3, drawPCompose fk3] 204 | where fk3 = force $ kiteDs!!3 205 | -- |diagram showing two partial compositions (with remainder faces in pale green). 206 | pCompFig = padBorder $ vsep 3 [center pCompFig1, center pCompFig2] 207 | 208 | 209 | -- |diagram of foolDminus and the result of forcing. 210 | forceFoolDminus :: OKBackend b => Diagram b 211 | forceFoolDminus = padBorder $ hsep 1 $ fmap (labelled drawj) [foolDminus, force foolDminus] 212 | 213 | 214 | forceDartD5Fig,forceKiteD5Fig,forceSunD5Fig,forceFig :: OKBackend b => Diagram b 215 | -- |diagram of forced 5 times decomposed dart. 216 | forceDartD5Fig = padBorder $ lw ultraThin $ drawForce $ dartDs !! 5 217 | -- |diagram of forced 5 times decomposed kite. 218 | forceKiteD5Fig = padBorder $ lw ultraThin $ rotate (ttangle 1) $ drawForce $ kiteDs!!5 219 | -- |diagram of forced 5 times decomposed sun. 220 | forceSunD5Fig = padBorder $ lw ultraThin $ drawForce $ sunDs !! 5 221 | -- |diagram of forced 5 times decomposed dart (left) and kite (right). 222 | forceFig = hsep 1 [forceDartD5Fig,forceKiteD5Fig] 223 | 224 | -- |brokenDart is a 4 times decomposed dart (dartD4) with 5 halftile faces removed. 225 | -- Forcing will repair to produce the same Tgraph as force dartD4. 226 | -- This graph can also be repeatedly composed (without forcing) to get a maximal Tgraph. 227 | brokenDart :: Tgraph 228 | brokenDart = removeFaces deleted dartD4 where 229 | deleted = [RK (2,16,33),LD (15,33,16),RK (16,66,15),LK (16,67,66),LK (5,15,66)] 230 | 231 | {-| badlyBrokenDart has more faces removed from brokenDart. 232 | This will also get repaired by forcing (to produce the same as force dartD4). 233 | However it will fail to produce a valid Tgraph if composed twice without forcing. 234 | -} 235 | badlyBrokenDart :: Tgraph 236 | badlyBrokenDart = removeFaces deleted bbd where 237 | deleted = [RK (6,28,54)] 238 | bbd = removeVertices [63,37] brokenDart 239 | -- deleted = RK(6,28,54):filter (isAtV 63) (faces brokenDart) 240 | 241 | -- |brokenDartFig shows the faces removed from dartD4 to make brokenDart and badlyBrokenDart. 242 | brokenDartFig :: OKBackend b => Diagram b 243 | brokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [dartD4, brokenDart, badlyBrokenDart] 244 | 245 | -- |badlyBrokenDartFig shows badlyBrokenDart, followed by its composition, followed by the faces 246 | -- that would result from an unchecked second composition which are not tile-connected. 247 | -- (Simply applying compose twice to badlyBrokenDart will raise an error). 248 | badlyBrokenDartFig :: OKBackend b => Diagram b 249 | badlyBrokenDartFig = padBorder $ lw thin $ hsep 1 $ fmap (labelled drawj) [vp, vpComp, vpFailed] where 250 | vp = makeVP badlyBrokenDart 251 | comp = compose badlyBrokenDart 252 | vpComp = restrictVP vp $ faces comp 253 | vpFailed = restrictVP vp $ (snd . partComposeFaces) comp 254 | 255 | -- |figure showing the result of removing incomplete tiles (those that do not have their matching halftile) 256 | -- to a 3 times decomposed sun. 257 | removeIncompletesFig :: OKBackend b => Diagram b 258 | removeIncompletesFig = padBorder $ drawj $ removeFaces (boundaryJoinFaces g) g where 259 | g = sunDs !! 3 260 | 261 | 262 | -- |mistake is a legal but incorrect Tgraph - a kite with 2 darts on its long edges 263 | mistake:: Tgraph 264 | 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)] 265 | 266 | -- |mistake1 is a kite bordered by 2 half darts (subgraph of mistake and still incorrect) 267 | mistake1:: Tgraph 268 | mistake1 = makeTgraph [RK (1,2,4), LK (1,3,2), RD (3,1,5), LD (4,6,1)] 269 | 270 | -- * Figures for 7 vertex types 271 | 272 | -- | vertexTypesFig is 7 vertex types in a single diagram as a row. 273 | vertexTypesFig :: OKBackend b => Diagram b 274 | vertexTypesFig = padBorder $ hsep 1 lTypeFigs 275 | where 276 | lTypeFigs = zipWith (labelAt (p2 (0,-2.2))) ["sun","star","jack","queen","king","ace","deuce"] vTypeFigs 277 | vTypeFigs = zipWith drawVertex 278 | [sunGraph, starGraph, jackGraph, queenGraph, kingGraph, aceGraph, deuceGraph] 279 | [(1,2), (1,2), (1,2), (1,2), (1,2), (3,6), (2,6)] -- alignments 280 | drawVertex g alm = alignBefore (lw thin . showOrigin . drawj) alm g 281 | 282 | jackGraph,kingGraph,queenGraph,aceGraph,deuceGraph,starGraph::Tgraph 283 | -- |Tgraph for vertex type jack. 284 | jackGraph = makeTgraph 285 | [LK (7,8,1),RK (7,1,5),LD (9,8,10),RD (9,1,8),LK (1,9,11) 286 | ,RK (1,11,2),RD (4,6,5),LD (4,5,1),RK (1,3,4),LK (1,2,3) 287 | ] -- centre 1 288 | {- 289 | [LK (1,9,11),RK (1,11,2),LK (7,8,1),RD (9,1,8),RK (1,3,4) 290 | ,LK (1,2,3),RK (7,1,5),LD (4,5,1),LD (9,8,10),RD (4,6,5) 291 | ] -- centre 1 292 | -} 293 | -- |Tgraph for vertex type king. 294 | kingGraph = makeTgraph 295 | [LD (1,10,11),RD (1,9,10),RK (9,7,8),LK (9,1,7),LK (5,6,7) 296 | ,RK (5,7,1),LD (1,4,5),RD (1,3,4),RD (1,11,2),LD (1,2,3) 297 | ] -- centre 1 298 | {- 299 | [LD (1,2,3),RD (1,11,2),LD (1,4,5),RD (1,3,4),LD (1,10,11) 300 | ,RD (1,9,10),LK (9,1,7),RK (9,7,8),RK (5,7,1),LK (5,6,7) 301 | ] -- centre 1 302 | -} 303 | -- |Tgraph for vertex type queen. 304 | queenGraph = makeTgraph 305 | [RK (11,9,10),LK (11,1,9),LK (7,8,9),RK (7,9,1),RK (7,5,6) 306 | ,LK (7,1,5),LK (3,4,5),RK (3,5,1),RD (1,11,2),LD (1,2,3) 307 | ] -- centre 1 308 | {- 309 | [LK (7,1,5),RK (3,5,1),LD (1,2,3),RK (7,9,1),LK (11,1,9) 310 | ,RD (1,11,2),RK (7,5,6),LK (7,8,9),LK (3,4,5),RK (11,9,10) 311 | ] -- centre 1 312 | -} 313 | -- |Tgraph for vertex type ace (same as fool). 314 | aceGraph = fool -- centre 3 315 | -- |Tgraph for vertextype deuce. 316 | deuceGraph = makeTgraph 317 | [LK (7,8,2),RK (7,2,6),LK (5,6,2),RK (5,2,4) 318 | ,LD (1,8,9),RD (1,2,8),RD (1,3,4),LD (1,4,2) 319 | ] -- centre 2 320 | {- 321 | [LK (7,8,2),RK (7,2,6),RK (5,2,4),LK (5,6,2),LD (1,4,2) 322 | ,RD (1,2,8),RD (1,3,4),LD (1,8,9) 323 | ] -- centre 2 324 | -} 325 | -- |Tgraph for vertex type star. 326 | starGraph = makeTgraph 327 | [LD (1,2,3),RD (1,11,2),LD (1,10,11),RD (1,9,10),LD (1,8,9) 328 | ,RD (1,7,8),LD (1,6,7),RD (1,5,6),LD (1,4,5),RD (1,3,4) 329 | ] -- centre 1 330 | 331 | -- |forceVFigures is a list of 7 diagrams - force of 7 vertex types. 332 | forceVFigures :: OKBackend b => [Diagram b] 333 | forceVFigures = rotations [0,0,9,5,0,0,1] $ 334 | fmap (center . drawForce) [sunGraph,starGraph,jackGraph,queenGraph,kingGraph,aceGraph,deuceGraph] 335 | 336 | 337 | sun3Dart :: Tgraph 338 | -- |A sun with 3 darts on the boundary NOT all adjacent 339 | -- (Used in superForceRocketsFig). 340 | sun3Dart = addHalfDart (9,10) $ addHalfDart (8,9) $ addHalfDart (5,6) $ addHalfDart (4,5) $ addHalfDart (3,4) $ addHalfDart (2,3) sunGraph 341 | -- sun3Dart = addHalfDart (9,10) $ addHalfDart (8,9) sun2AdjDart 342 | 343 | 344 | -- |Diagram showing superForce with initial Tgraph g (red), force g (red and black), 345 | -- and superForce g (red and black and blue). 346 | superForceFig :: OKBackend b => Diagram b 347 | superForceFig = padBorder $ lw thin $ rotate (ttangle 1) $ drawSuperForce g where 348 | g = addHalfDart (220,221) $ force $ decompositions fool !!3 349 | 350 | -- |Diagram showing 4 rockets formed by applying superForce to successive decompositions 351 | -- of sun3Dart. The decompositions are in red with normal force additions in black and superforce additions in blue. 352 | superForceRocketsFig :: OKBackend b => Diagram b 353 | superForceRocketsFig = padBorder $ lw veryThin $ vsep 1 $ rotations [8,9,9,8] $ 354 | fmap drawSuperForce decomps where 355 | decomps = take 4 $ decompositions sun3Dart 356 | 357 | boundaryFDart4, boundaryFDart5 :: Tgraph 358 | -- |graph of the boundary faces only of a forced graph (dartDs!!4) 359 | boundaryFDart4 = NoWarn.makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState dartD4 360 | -- |graph of the boundary faces only of a forced graph (dartDs!!5) 361 | boundaryFDart5 = NoWarn.makeUncheckedTgraph $ boundaryFaces $ force $ makeBoundaryState (dartDs!!5) 362 | 363 | boundaryFDart4Fig,boundaryFDart5Fig :: OKBackend b => Diagram b 364 | -- |figure of the boundary faces only of a forced graph (dartDs!!4). 365 | boundaryFDart4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryFDart4 366 | -- |figure of the boundary faces only of a forced graph (dartDs!!5). 367 | boundaryFDart5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryFDart5 368 | 369 | boundaryGapFDart4, boundaryGapFDart5 :: Tgraph 370 | -- |graph of the boundary faces only of a forced graph - with extra faces removed to make a gap 371 | boundaryGapFDart4 = removeVertices [354] boundaryFDart4 372 | -- checkedTgraph $ filter ((/=354).originV) (faces boundaryFDart4) 373 | -- |graph of the boundary faces only of a forced graph - with extra faces removed to make a gap 374 | boundaryGapFDart5 = removeVertices [1467] boundaryFDart5 375 | -- checkedTgraph $ filter ((/=1467).originV) (faces boundaryFDart5) 376 | 377 | boundaryGap4Fig, boundaryGap5Fig :: OKBackend b => Diagram b 378 | -- |figure for the boundary gap graph boundaryGapFDart4. 379 | boundaryGap4Fig = padBorder $ lw ultraThin $ labelSize tiny drawj boundaryGapFDart4 380 | -- |figure for the boundary gap graph boundaryGapFDart5. 381 | boundaryGap5Fig = padBorder $ lw ultraThin $ labelSize (normalized 0.006) drawj boundaryGapFDart5 382 | 383 | -- | boundaryVCoveringFigs bd - produces a list of diagrams for the boundaryVCovering of bd 384 | -- (with the Tgraph represented by bd shown in red in each case). 385 | boundaryVCoveringFigs :: OKBackend b => 386 | Forced BoundaryState -> [Diagram b] 387 | boundaryVCoveringFigs bd = 388 | lw ultraThin . (redg <>) . alignBefore draw alig . (recoverGraph . forgetF) <$> boundaryVCovering bd 389 | where redg = lc red $ draw g --alignBefore draw alig g 390 | alig = defaultAlignment g 391 | g = recoverGraph $ forgetF bd 392 | 393 | -- | boundaryECoveringFigs bd - produces a list of diagrams for the boundaryECovering of bd 394 | -- (with the Tgraph represented by bd shown in red in each case). 395 | boundaryECoveringFigs :: OKBackend b => 396 | Forced BoundaryState -> [Diagram b] 397 | boundaryECoveringFigs bd = 398 | lw ultraThin . (redg <>) . alignBefore draw alig . recoverGraph . forgetF <$> boundaryECovering bd 399 | where redg = lc red $ draw g 400 | alig = defaultAlignment g 401 | g = recoverGraph $ forgetF bd 402 | 403 | kingECoveringFig,kingVCoveringFig :: OKBackend b => Diagram b 404 | -- | diagram showing the boundaryECovering of a forced kingGraph. 405 | kingECoveringFig = padBorder $ arrangeRows 3 $ boundaryECoveringFigs $ forceF $ makeBoundaryState kingGraph 406 | -- | diagram showing the boundaryVCovering of a forced kingGraph. 407 | kingVCoveringFig = padBorder $ arrangeRows 3 $ boundaryVCoveringFigs $ forceF $ makeBoundaryState kingGraph 408 | 409 | kingEmpiresFig, kingEmpire1Fig, kingEmpire2Fig :: OKBackend b => Diagram b 410 | -- | figure showing King's empires (1 and 2). 411 | kingEmpiresFig = padBorder $ hsep 10 [kingEmpire1Fig, kingEmpire2Fig] 412 | -- | figure showing King's empires 1. 413 | kingEmpire1Fig = showEmpire1 kingGraph 414 | -- | figure showing King's empire 2. 415 | kingEmpire2Fig = showEmpire2 kingGraph 416 | 417 | 418 | -- |emplaceChoices forces then maximally composes. At this top level it 419 | -- produces a list of forced choices for each of the unknowns of this top level Tgraph. 420 | -- It then repeatedly applies (force . decompose) back to the starting level to return a list of Tgraphs. 421 | -- This version relies on compForce theorem and related theorems 422 | emplaceChoices:: Tgraph -> [Tgraph] 423 | emplaceChoices = emplaceChoicesForced . force where 424 | 425 | emplaceChoicesForced:: Tgraph -> [Tgraph] 426 | emplaceChoicesForced g0 | nullGraph g' = chooseUnknowns [(unknowns $ getDartWingInfo g0, g0)] 427 | | otherwise = force . decompose <$> emplaceChoicesForced g' 428 | where g' = compose g0 429 | 430 | chooseUnknowns :: [([Vertex],Tgraph)] -> [Tgraph] 431 | chooseUnknowns [] = [] 432 | chooseUnknowns (([],g0):more) = g0:chooseUnknowns more 433 | chooseUnknowns ((u:unks,g0): more) 434 | = chooseUnknowns (map (remainingunks unks) newgs ++ more) 435 | where newgs = map recoverGraph $ atLeastOne $ fmap forgetF <$> tryDartAndKiteForced (findDartLongForWing u bd) bd 436 | bd = makeBoundaryState g0 437 | remainingunks startunks g' = (startunks `intersect` graphBoundaryVs g', g') 438 | 439 | findDartLongForWing :: Vertex -> BoundaryState -> Dedge 440 | findDartLongForWing v bd 441 | = case find isDart (facesAtBV bd v) of 442 | Just d -> longE d 443 | Nothing -> error $ "findDartLongForWing: dart not found for dart wing vertex " ++ show v 444 | 445 | -- |Example showing emplaceChoices for foolD with foolD shown in red in each choice 446 | emplaceChoicesFig :: OKBackend b => Diagram b 447 | emplaceChoicesFig = lw thin $ hsep 1 $ map overlayg $ emplaceChoices g 448 | where g = foolD 449 | overlayg g' = smartAlignBefore draw algmnt g # lc red <> alignBefore draw algmnt g' 450 | algmnt = defaultAlignment g 451 | 452 | -------------------------------------------------------------------------------- /src/TileLib.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : TileLib 3 | Description : Introducing Pieces and Patches and Drawable class 4 | Copyright : (c) Chris Reade, 2021 5 | License : BSD-style 6 | Maintainer : chrisreade@mac.com 7 | Stability : experimental 8 | 9 | This module introduces Pieces and Patches for drawing finite tilings using Penrose's Dart and Kite tiles. 10 | It includes several primitives for drawing half tiles (Pieces), a class Drawable with instance Patch 11 | and commonly used operations for the Drawable class (draw, drawj, fillDK,..). 12 | It also introduces class OKBackend to summarise constraints on a Backend for drawing. 13 | There is also a decompose operation for Patches (decompPatch) and sun and star example Patches. 14 | -} 15 | {-# LANGUAGE NoMonomorphismRestriction #-} 16 | {-# LANGUAGE FlexibleContexts #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | {-# LANGUAGE FlexibleInstances #-} -- needed for Drawable Patch 19 | {-# LANGUAGE TypeOperators #-} -- needed for type equality constraints ~ 20 | 21 | module TileLib 22 | ( OKBackend 23 | -- * Pieces 24 | , Piece 25 | , joinVector 26 | , ldart 27 | , rdart 28 | , lkite 29 | , rkite 30 | -- * Drawing Pieces 31 | , phi 32 | , ttangle 33 | , pieceEdges 34 | , wholeTileEdges 35 | , drawPiece 36 | , dashjPiece 37 | , dashjOnly 38 | , drawRoundPiece 39 | , drawJoin 40 | , fillOnlyPiece 41 | , fillPieceDK 42 | -- , fillMaybePieceDK 43 | , leftFillPieceDK 44 | , experiment 45 | -- * Patches and Drawable Class 46 | , Drawable(..) 47 | , Patch 48 | , draw 49 | , drawj 50 | , fillDK 51 | , fillKD 52 | -- , fillMaybeDK 53 | , colourDKG 54 | -- , colourMaybeDKG 55 | -- * Patch Decomposition and Compose choices 56 | , decompPatch 57 | , decompositionsP 58 | , compChoices 59 | , compNChoices 60 | -- * Example Patches 61 | , penta 62 | , sun 63 | , TileLib.star 64 | , suns 65 | , sun5 66 | , sun6 67 | -- * Diagrams of Patches 68 | , sun6Fig 69 | , leftFilledSun6 70 | , filledSun6 71 | -- * Rotation and Scaling operations 72 | , rotations 73 | , scales 74 | , phiScales 75 | , phiScaling 76 | , joinDashing 77 | ) where 78 | 79 | import Diagrams.Prelude 80 | --import Diagrams.TwoD.Text (Text) -- now in CheckBackend 81 | 82 | import CheckBackend 83 | import HalfTile 84 | 85 | {-| Piece type for tile halves: Left Dart, Right Dart, Left Kite, Right Kite 86 | with a vector from their origin along the join edge where 87 | origin for a dart is the tip, origin for a kite is the vertex with smallest internal angle. 88 | Using Imported polymorphic HalfTile. 89 | 90 | Pieces are Transformable 91 | -} 92 | type Piece = HalfTile (V2 Double) 93 | 94 | -- | get the vector representing the join edge in the direction away from the origin of a piece 95 | joinVector:: Piece -> V2 Double 96 | joinVector = tileRep 97 | 98 | -- |ldart,rdart,lkite,rkite are the 4 pieces (with join edge oriented along the x axis, unit length for darts, length phi for kites). 99 | ldart,rdart,lkite,rkite:: Piece 100 | ldart = LD unitX 101 | rdart = RD unitX 102 | lkite = LK (phi*^unitX) 103 | rkite = RK (phi*^unitX) 104 | 105 | -- |All edge lengths are powers of the golden ratio (phi). 106 | -- We also have the interesting property of the golden ratio that phi^2 == phi + 1 and so 1/phi = phi-1 107 | -- (also phi^3 = 2phi +1 and 1/phi^2 = 2-phi) 108 | phi::Double 109 | phi = (1.0 + sqrt 5.0) / 2.0 110 | 111 | -- |All angles used are multiples of tt where tt is a tenth of a turn 112 | -- (so 36 degrees). 113 | -- ttangle n is n multiples of tt. 114 | ttangle:: Int -> Angle Double 115 | ttangle n = fromIntegral (n `mod` 10) *^tt 116 | where tt = 1/10 @@ turn 117 | 118 | {-| produces a list of the two adjacent non-join tile directed edges of a piece starting from the origin. 119 | 120 | Perhaps confusingly we regard left and right of a dart differently from left and right of a kite. 121 | This is in line with common sense view but darts are reversed from origin point of view. 122 | 123 | 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 124 | directed and ordered anti-clockwise from the piece origin. 125 | -} 126 | pieceEdges:: Piece -> [V2 Double] 127 | pieceEdges (LD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 9) v 128 | pieceEdges (RD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 1) v 129 | pieceEdges (RK v) = [v',v ^-^ v'] where v' = rotate (ttangle 9) v 130 | pieceEdges (LK v) = [v',v ^-^ v'] where v' = rotate (ttangle 1) v 131 | 132 | -- |the 4 tile edges of a completed half-tile piece (used for colour fill). 133 | -- These are directed and ordered clockwise from the origin of the tile. 134 | wholeTileEdges:: Piece -> [V2 Double] 135 | wholeTileEdges (LD v) = wholeTileEdges (RD v) 136 | wholeTileEdges (RD v) = pieceEdges (RD v) ++ map negated (reverse $ pieceEdges (LD v)) 137 | wholeTileEdges (LK v) = pieceEdges (LK v) ++ map negated (reverse $ pieceEdges (RK v)) 138 | wholeTileEdges (RK v) = wholeTileEdges (LK v) 139 | 140 | {- 141 | -- |Class OKBackend is a synonym for suitable constraints on a Backend 142 | class (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b, Renderable (Text Double) b) 143 | => OKBackend b where {} 144 | -} 145 | 146 | {- 147 | -- | Abbreviation for 2D diagrams for any Backend b. 148 | -- No longer used now class OKBackend is available 149 | type Diagram2D b = QDiagram b V2 Double Any 150 | -} 151 | 152 | 153 | 154 | 155 | 156 | -- |drawing lines for the 2 non-join edges of a piece. 157 | drawPiece :: OKBackend b => 158 | Piece -> Diagram b 159 | drawPiece = strokeLine . fromOffsets . pieceEdges 160 | 161 | -- |same as drawPiece but with join edge added as faint dashed line. 162 | dashjPiece :: OKBackend b => 163 | Piece -> Diagram b 164 | dashjPiece piece = drawPiece piece <> dashjOnly piece 165 | 166 | 167 | -- |draw join edge only (as faint dashed line). 168 | dashjOnly :: OKBackend b => 169 | Piece -> Diagram b 170 | -- dashjOnly piece = drawJoin piece # dashingN [0.003,0.003] 0 # lw ultraThin -- # lc grey 171 | dashjOnly piece = drawJoin piece # joinDashing 172 | 173 | -- |changes line style to ultraThin dashed lines (for drawing join edges) 174 | joinDashing :: (HasStyle c, N c ~ Double) => c -> c 175 | joinDashing = dashing [dashmeasure,dashmeasure] 0 . lw ultraThin 176 | where dashmeasure = normalized 0.003 `atLeast` output 0.5 177 | 178 | -- |same as drawPiece but with added join edge (also fillable as a loop). 179 | drawRoundPiece :: OKBackend b => 180 | Piece -> Diagram b 181 | drawRoundPiece = strokeLoop . closeLine . fromOffsets . pieceEdges 182 | 183 | -- |draw join edge only. 184 | drawJoin :: OKBackend b => 185 | Piece -> Diagram b 186 | drawJoin piece = strokeLine $ fromOffsets [joinVector piece] 187 | 188 | -- |fillOnlyPiece col piece - fills piece with colour col without drawing any lines. 189 | -- Can be used with both Colour and AlphaColour 190 | fillOnlyPiece :: (OKBackend b, Color c) => 191 | c -> Piece -> Diagram b 192 | fillOnlyPiece col piece = drawRoundPiece piece # fillColor col # lw none 193 | 194 | -- |fillPieceDK dcol kcol piece - draws and fills the half-tile piece 195 | -- with colour dcol for darts and kcol for kites. 196 | -- Note the order D K. 197 | -- Can be used with both Colour and AlphaColour 198 | fillPieceDK :: (OKBackend b, Color c1, Color c2) => 199 | c1 -> c2 -> HalfTile (V2 Double) -> Diagram b 200 | fillPieceDK dcol kcol piece = drawPiece piece <> filledPiece where 201 | filledPiece = case piece of 202 | (LD _) -> fillOnlyPiece dcol piece 203 | (RD _) -> fillOnlyPiece dcol piece 204 | (LK _) -> fillOnlyPiece kcol piece 205 | (RK _) -> fillOnlyPiece kcol piece 206 | 207 | {- {-# DEPRECATED fillMaybePieceDK "Use fillPieceDK which now works with AlphaColours such as transparent" #-} 208 | -- |fillMaybePieceDK *Deprecated* 209 | -- (use fillPieceDK which works with AlphaColours such as transparent as well as Colours) 210 | fillMaybePieceDK :: OKBackend b => 211 | Maybe (Colour Double) -> Maybe (Colour Double) -> Piece -> Diagram b 212 | fillMaybePieceDK d k piece = drawPiece piece <> filler where 213 | maybeFill (Just c) = fillOnlyPiece c piece 214 | maybeFill Nothing = mempty 215 | filler = case piece of (LD _) -> maybeFill d 216 | (RD _) -> maybeFill d 217 | (LK _) -> maybeFill k 218 | (RK _) -> maybeFill k 219 | -} 220 | 221 | -- |leftFillPieceDK dcol kcol pc fills the whole tile when pc is a left half-tile, 222 | -- darts are filled with colour dcol and kites with colour kcol. 223 | -- (Right half-tiles produce nothing, so whole tiles are not drawn twice). 224 | -- Works with AlphaColours as well as Colours. 225 | leftFillPieceDK :: (OKBackend b, Color c1, Color c2) => 226 | c1 -> c2 -> HalfTile (V2 Double) -> Diagram b 227 | leftFillPieceDK dcol kcol pc = 228 | case pc of (LD _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fillColor dcol 229 | (LK _) -> strokeLoop (glueLine $ fromOffsets $ wholeTileEdges pc) # fillColor kcol 230 | _ -> mempty 231 | 232 | -- |experiment uses a different rule for drawing half tiles. 233 | -- This clearly displays the larger kites and darts. 234 | -- Half tiles are first drawn with dashed lines, then certain edges are overlayed to emphasise them. 235 | -- Half darts have the join edge emphasised in red, while 236 | -- Half kites have the long edge emphasised in black. 237 | experiment:: OKBackend b => 238 | Piece -> Diagram b 239 | experiment piece = emph piece <> (drawRoundPiece piece # dashingN [0.003,0.003] 0 # lw ultraThin) 240 | --emph pc <> (drawRoundPiece pc # dashingO [1,2] 0 # lw ultraThin) 241 | where emph pc = case pc of 242 | (LD v) -> (strokeLine . fromOffsets) [v] # lc red -- emphasise join edge of darts in red 243 | (RD v) -> (strokeLine . fromOffsets) [v] # lc red 244 | (LK v) -> (strokeLine . fromOffsets) [rotate (ttangle 1) v] -- emphasise long edge for kites 245 | (RK v) -> (strokeLine . fromOffsets) [rotate (ttangle 9) v] 246 | 247 | 248 | 249 | -- |A patch is a list of Located pieces (the point associated with each piece locates its originV) 250 | -- Patches are Transformable 251 | type Patch = [Located Piece] 252 | 253 | -- | A class for things that can be turned to diagrams when given a function to draw pieces. 254 | class Drawable a where 255 | drawWith :: OKBackend b => 256 | (Piece -> Diagram b) -> a -> Diagram b 257 | 258 | -- | Patches are drawable 259 | instance Drawable Patch where 260 | drawWith = drawPatchWith where 261 | -- turn a patch into a diagram using the first argument for drawing pieces. 262 | -- drawPatchWith:: (Piece -> Diagram B) -> Patch -> Diagram B 263 | drawPatchWith pd = position . fmap (viewLoc . mapLoc pd) 264 | 265 | -- | the main default case for drawing using drawPiece. 266 | draw :: (Drawable a, OKBackend b) => 267 | a -> Diagram b 268 | draw = drawWith drawPiece 269 | 270 | -- | alternative default case for drawing, adding dashed lines for join edges. 271 | drawj :: (Drawable a, OKBackend b) => 272 | a -> Diagram b 273 | drawj = drawWith dashjPiece 274 | 275 | fillDK, fillKD :: (Drawable a, OKBackend b, Color c1, Color c2) => 276 | c1 -> c2 -> a -> Diagram b 277 | -- |fillDK dcol kcol a - draws and fills a with colour dcol for darts and kcol for kites. 278 | -- Note the order D K. 279 | -- Works with AlphaColours as well as Colours. 280 | fillDK c1 c2 = drawWith (fillPieceDK c1 c2) 281 | 282 | -- |fillKD kcol dcol a - draws and fills a with colour kcol for kites and dcol for darts. 283 | -- Note the order K D. 284 | -- Works with AlphaColours as well as Colours. 285 | fillKD c1 c2 = fillDK c2 c1 286 | 287 | {- {-# DEPRECATED fillMaybeDK "Use fillDK which now works with AlphaColours such as transparent" #-} 288 | -- |fillMaybeDK *Deprecated* 289 | -- (Use fillDK which works with AlphaColours such as transparent as well as Colours). 290 | fillMaybeDK :: (Drawable a, OKBackend b) => 291 | Maybe (Colour Double) -> Maybe (Colour Double) -> a -> Diagram b 292 | fillMaybeDK c1 c2 = drawWith (fillMaybePieceDK c1 c2) 293 | -} 294 | -- |colourDKG (c1,c2,c3) p - fill in a drawable with colour c1 for darts, colour c2 for kites and 295 | -- colour c3 for grout (that is, the non-join edges). 296 | -- Note the order D K G. 297 | -- Can be used with both Colour and AlphaColour 298 | colourDKG :: (Drawable a, OKBackend b, Color c1, Color c2, Color c3) => 299 | (c1,c2,c3) -> a -> Diagram b 300 | colourDKG (c1,c2,c3) a = fillDK c1 c2 a # lineColor c3 301 | 302 | {- {-# DEPRECATED colourMaybeDKG "Use colourDKG which now works with AlphaColours such as transparent" #-} 303 | -- |colourMaybeDKG *Deprecated* 304 | -- (Use colourDKG which works with AlphaColours such as transparent as well as Colours) 305 | colourMaybeDKG:: (Drawable a, OKBackend b) => 306 | (Maybe (Colour Double), Maybe (Colour Double), Maybe (Colour Double)) -> a -> Diagram b 307 | colourMaybeDKG (d,k,g) a = fillMaybeDK d k a # maybeGrout g where 308 | maybeGrout (Just c) = lc c 309 | maybeGrout Nothing = lw none 310 | -} 311 | 312 | {-| 313 | Decomposing splits each located piece in a patch into a list of smaller located pieces to create a refined patch. 314 | (See also decompose in Tgraph.Decompose.hs for a more abstract version of this operation). 315 | -} 316 | decompPatch :: Patch -> Patch 317 | decompPatch = concatMap decompPiece 318 | 319 | -- |Decomposing a located piece to a list of (2 or 3) located pieces at smaller scale. 320 | decompPiece :: Located Piece -> [Located Piece] 321 | decompPiece lp = case viewLoc lp of 322 | (p, RD vd)-> [ LK vd `at` p 323 | , RD vd' `at` (p .+^ v') 324 | ] where v' = phi*^rotate (ttangle 1) vd 325 | vd' = (2-phi) *^ negated v' -- (2-phi) = 1/phi^2 326 | (p, LD vd)-> [ RK vd `at` p 327 | , LD vd' `at` (p .+^ v') 328 | ] where v' = phi*^rotate (ttangle 9) vd 329 | vd' = (2-phi) *^ negated v' -- (2-phi) = 1/phi^2 330 | (p, RK vk)-> [ RD vd' `at` p 331 | , LK vk' `at` (p .+^ v') 332 | , RK vk' `at` (p .+^ v') 333 | ] where v' = rotate (ttangle 9) vk 334 | vd' = (2-phi) *^ v' -- (2-phi) = 1/phi^2 335 | vk' = ((phi-1) *^ vk) ^-^ v' -- (phi-1) = 1/phi 336 | (p, LK vk)-> [ LD vd' `at` p 337 | , RK vk' `at` (p .+^ v') 338 | , LK vk' `at` (p .+^ v') 339 | ] where v' = rotate (ttangle 1) vk 340 | vd' = (2-phi) *^ v' -- (2-phi) = 1/phi^2 341 | vk' = ((phi-1) *^ vk) ^-^ v' -- (phi-1) = 1/phi 342 | 343 | -- |Create an infinite list of increasing decompositions of a patch 344 | decompositionsP:: Patch -> [Patch] 345 | decompositionsP = iterate decompPatch 346 | 347 | {-| 348 | compChoices applied to a single located piece produces a list of alternative located pieces NOT a Patch. 349 | Each of these is a larger scale single piece with a location such that when decomposed 350 | the original piece in its original position is part of the decomposition) 351 | -} 352 | compChoices :: Located Piece -> [Located Piece] 353 | compChoices lp = case viewLoc lp of 354 | (p, RD vd)-> [ RD vd' `at` (p .+^ v') 355 | , RK vk `at` p 356 | ] where v' = (phi+1) *^ vd -- vd*phi^2 357 | vd' = rotate (ttangle 9) (vd ^-^ v') 358 | vk = rotate (ttangle 1) v' 359 | (p, LD vd)-> [ LD vd' `at` (p .+^ v') 360 | , LK vk `at` p 361 | ] where v' = (phi+1) *^ vd -- vd*phi^2 362 | vd' = rotate (ttangle 1) (vd ^-^ v') 363 | vk = rotate (ttangle 9) v' 364 | (p, RK vk)-> [ LD vk `at` p 365 | , LK lvk' `at` (p .+^ lv') 366 | , RK rvk' `at` (p .+^ rv') 367 | ] where lv' = phi*^rotate (ttangle 9) vk 368 | rv' = phi*^rotate (ttangle 1) vk 369 | rvk' = phi*^rotate (ttangle 7) vk 370 | lvk' = phi*^rotate (ttangle 3) vk 371 | (p, LK vk)-> [ RD vk `at` p 372 | , RK rvk' `at` (p .+^ rv') 373 | , LK lvk' `at` (p .+^ lv') 374 | ] where lv' = phi*^rotate (ttangle 9) vk 375 | rv' = phi*^rotate (ttangle 1) vk 376 | rvk' = phi*^rotate (ttangle 7) vk 377 | lvk' = phi*^rotate (ttangle 3) vk 378 | 379 | -- |compNChoices n lp - gives a list of all the alternatives after n compChoices starting with lp 380 | -- Note that the result is not a Patch as the list represents alternatives. 381 | compNChoices :: Int -> Located Piece -> [Located Piece] 382 | compNChoices 0 lp = [lp] 383 | compNChoices n lp = do 384 | lp' <- compChoices lp 385 | compNChoices (n-1) lp' 386 | 387 | 388 | 389 | -- |combine 5 copies of a patch (each rotated by ttangle 2 successively) 390 | -- (ttAngle 2 is 72 degrees) 391 | -- Must be used with care to avoid creating a nonsense patch 392 | penta:: Patch -> Patch 393 | penta p = concatMap copy [0..4] 394 | where copy n = rotate (ttangle (2*n)) p 395 | 396 | sun,star::Patch 397 | -- |sun is a patch with five kites sharing common origin (base of kite) 398 | sun = penta [rkite `at` origin, lkite `at` origin] 399 | -- |star is a patch with five darts sharing common origin (tip of dart) 400 | star = penta [rdart `at` origin, ldart `at` origin] 401 | 402 | 403 | -- |An infinite list of patches of increasingly decomposed sun 404 | suns::[Patch] 405 | suns = decompositionsP sun 406 | sun5,sun6:: Patch 407 | -- |a patch of a 6 times decomposed sun 408 | sun6 = suns!!6 409 | -- |a patch of a 5 times decomposed sun 410 | sun5 = suns!!5 411 | 412 | 413 | -- * Diagrams of Patches 414 | 415 | -- |diagram for sun6. 416 | sun6Fig :: OKBackend b => Diagram b 417 | sun6Fig = draw sun6 # lw thin 418 | 419 | 420 | -- |Colour filled using leftFillPieceDK. 421 | leftFilledSun6 :: OKBackend b => Diagram b 422 | leftFilledSun6 = drawWith (leftFillPieceDK red blue) sun6 # lw thin 423 | 424 | -- |Colour filled using fillDK. 425 | filledSun6 :: OKBackend b => Diagram b 426 | filledSun6 = fillDK darkmagenta indigo sun6 # lw thin # lc gold 427 | 428 | 429 | -- |rotations takes a list of integers (representing ttangles) for respective rotations of items in the second list (things to be rotated). 430 | -- This includes Diagrams, Patches, VPatches. 431 | -- The integer list can be shorter than the list of items - the remaining items are left unrotated. 432 | -- It will raise an error if the integer list is longer than the list of items to be rotated. 433 | -- (Rotations by an angle are anti-clockwise) 434 | rotations :: (Transformable a, V a ~ V2, N a ~ Double) => [Int] -> [a] -> [a] 435 | rotations (n:ns) (d:ds) = rotate (ttangle n) d: rotations ns ds 436 | rotations [] ds = ds 437 | rotations _ [] = error "rotations: too many rotation integers" 438 | 439 | -- |scales takes a list of doubles for respective scalings of items in the second list (things to be scaled). 440 | -- This includes Diagrams, Pieces, Patches, VPatches. 441 | -- The list of doubles can be shorter than the list of items - the remaining items are left unscaled. 442 | -- It will raise an error if the integer list is longer than the list of items to be scaled. 443 | scales :: (Transformable a, V a ~ V2, N a ~ Double) => [Double] -> [a] -> [a] 444 | scales (s:ss) (d:ds) = scale s d: scales ss ds 445 | scales [] ds = ds 446 | scales _ [] = error "scales: too many scalars" 447 | 448 | -- |increasing scales by a factor of phi along a list starting with 1. 449 | phiScales:: (Transformable a, V a ~ V2, N a ~ Double) => [a] -> [a] 450 | phiScales = phiScaling 1 451 | 452 | -- |increasing scales by a factor of phi along a list starting with given first argument 453 | phiScaling:: (Transformable a, V a ~ V2, N a ~ Double) => Double -> [a] -> [a] 454 | phiScaling _ [] = [] 455 | phiScaling s (d:more) = scale s d: phiScaling (phi*s) more 456 | 457 | 458 | 459 | -------------------------------------------------------------------------------- /src/Try.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Try 3 | Description : Result types for partial functions 4 | Copyright : (c) Chris Reade, 2021 5 | License : BSD-style 6 | Maintainer : chrisreade@mac.com 7 | Stability : experimental 8 | 9 | Try is a synonym for Either ShowS, and is used for results of partial operations 10 | which return either Right something when defined or Left report when there is a problem 11 | (where report is a failure report). 12 | This is to allow computation to continue in failure cases without necessarily raising an error. 13 | This module contains functions associated with Try results. 14 | -} 15 | 16 | {-# LANGUAGE FlexibleInstances #-} -- needed for instance Show (ShowS) 17 | {-# OPTIONS_GHC -Wno-orphans #-} -- needed for instance Show (ShowS) 18 | 19 | module Try 20 | ( -- * Try - result types with failure reporting (for partial operations). 21 | Try 22 | , onFail 23 | , nothingFail 24 | , failReport 25 | , failReports 26 | , runTry 27 | , ifFail 28 | , isFail 29 | , concatFails 30 | , ignoreFails 31 | , atLeastOne 32 | -- , noFails 33 | ) where 34 | 35 | import Data.Either(fromRight, lefts, rights, isLeft) 36 | 37 | 38 | -- | Try is a synonym for Either ShowS. Used for results of partial functions 39 | -- which return either Right something when defined or Left r when there is a problem 40 | -- where r is a (prepending) failure report. 41 | -- Note: ShowS = String -> String makes prepending Strings efficient as composition 42 | -- Note: Either ShowS (and hence Try) is a monad, and this is used frequently for combining partial operations. 43 | type Try a = Either ShowS a 44 | 45 | -- | onFail s exp - prepends s at the front of a failure report if exp fails with Left report 46 | -- but does nothing otherwise. 47 | onFail:: String -> Try a -> Try a 48 | onFail s = either (Left . (pure s <>)) Right --either (Left . (pure s .)) Right 49 | 50 | -- |failReport s - creates a failure (Left), prepending s for the failure report 51 | failReport :: String -> Try a 52 | failReport = Left . (<>) 53 | 54 | -- |failReports ss - creates a failure (Left), concatenating ss for the failure report 55 | failReports :: [String] -> Try a 56 | failReports = Left . mconcat . fmap (<>) --failReport . mconcat 57 | -- Note: failReport . mconcat concatenates strings 58 | -- but Left . mconcat . fmap (<>) composes functions 59 | 60 | -- | nothingFail a s - Converts a Maybe Result (a) into a Try result by treating Nothing as a failure 61 | -- (the String s is used for the failure report on failure). 62 | -- Usually used as infix (exp `nothingFail` s) 63 | nothingFail :: Maybe b -> String -> Try b 64 | nothingFail a s = maybe (failReport s) Right a 65 | 66 | -- |Extract the (Right) result from a Try, raising an error if the Try is Left r. 67 | -- The failure report (from Left r) is converted to a Stirng and passed to error. 68 | runTry:: Try a -> a 69 | runTry = either (error . ($ "")) id 70 | 71 | -- |ifFail a tr - extracts the (Right) result from tr but returning a if tr is Left _ . 72 | ifFail :: a -> Try a -> a 73 | ifFail = fromRight 74 | 75 | -- |a try result is a failure if it is a Left 76 | isFail:: Try a -> Bool 77 | isFail = isLeft 78 | 79 | -- |Combines a list of Trys into a single Try with failure overriding success. 80 | -- It concatenates all failure reports if there are any and returns a single Left r. 81 | -- Otherwise it produces Right rs where rs is the list of all (successful) results. 82 | -- In particular, concatFails [] = Right [] (so is NOT a fail) 83 | concatFails:: [Try a] -> Try [a] 84 | concatFails ls = case lefts ls of 85 | [] -> Right $ rights ls 86 | other -> Left $ mconcat other -- concatenates reports for single report 87 | 88 | -- |Combines a list of Trys into a list of the successes, ignoring any failures. 89 | -- In particular, ignoreFails [] = [] 90 | ignoreFails:: [Try a] -> [a] 91 | ignoreFails = rights 92 | 93 | -- | tryAtLeastOne rs - returns Right with the list of successful results if there are any, 94 | -- but Left with a fail report otherwise. 95 | -- The error report will include the concatenated reports from multiple failures. 96 | tryAtLeastOne:: [Try a] -> Try [a] 97 | tryAtLeastOne [] = failReport "atLeastOne: applied to empty list.\n" 98 | tryAtLeastOne results = case ignoreFails results of 99 | [] -> onFail "atLeastOne: no successful results.\nCounter Example Found?\n" $ concatFails results 100 | other -> Right other 101 | 102 | -- | atLeastOne rs - returns the list of successful results if there are any, but fails with an error otherwise. 103 | -- The error report will include the concatenated reports from multiple failures. 104 | atLeastOne:: [Try a] -> [a] 105 | atLeastOne = runTry . tryAtLeastOne 106 | 107 | -- |Cheating - a ShowS function is "shown" by applying it to a String 108 | instance Show ShowS where 109 | show r = show " = (" ++ r "" ++ show " ++)" 110 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-23.24 21 | # resolver: lts-21.25 22 | # resolver: lts-21.13 23 | # resolver: lts-20.26 24 | 25 | # User packages to be built. 26 | # Various formats can be used as shown in the example below. 27 | # 28 | # packages: 29 | # - some-directory 30 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | packages: 35 | - . 36 | # Dependency packages to be pulled from upstream that are not in the resolver. 37 | # These entries can reference officially published versions as well as 38 | # forks / in-progress versions pinned to a git hash. For example: 39 | # 40 | # extra-deps: 41 | # - acme-missiles-0.3 42 | # - git: https://github.com/commercialhaskell/stack.git 43 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 44 | # 45 | # extra-deps: [] 46 | 47 | # Override default flag values for local packages and extra-deps 48 | # flags: {} 49 | 50 | # Extra package databases containing global packages 51 | # extra-package-dbs: [] 52 | 53 | # Control whether we use the GHC we find on the path 54 | # system-ghc: true 55 | # 56 | # Require a specific version of Stack, using version ranges 57 | # require-stack-version: -any # Default 58 | # require-stack-version: ">=2.9" 59 | # 60 | # Override the architecture used by Stack, especially useful on Windows 61 | # arch: i386 62 | # arch: x86_64 63 | # 64 | # Extra directories used by Stack for building 65 | # extra-include-dirs: [/path/to/dir] 66 | # extra-lib-dirs: [/path/to/dir] 67 | # 68 | # Allow a newer minor version of GHC than the snapshot specifies 69 | # compiler-check: newer-minor 70 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec 2 | import Control.Exception (evaluate) 3 | 4 | import PKD 5 | import TgraphExamples 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | spec :: Spec 11 | spec = do graphPropSpec 12 | graphOpSpec 13 | graphLabelCheck 14 | -- Example lists of tile-faces 15 | 16 | x0,x1,x2,x3,x4,x5 :: [TileFace] 17 | -- x0 has a face with a repeated vertex 18 | x0 = [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13) 19 | ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,14,14),RK (7,14,12) 20 | ] 21 | 22 | -- x1 has crossing boundaries 23 | x1 = [LK (1,8,3),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13) 24 | ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,4,14),RK (7,14,12) 25 | ] 26 | 27 | -- x2 is not connected 28 | x2 = x1 ++ [LK (15,16,17),RK (15,17,18)] 29 | 30 | -- x3 has edge conflicts 31 | x3 = [LK (3,8,1),RD (2,3,8),RK (1,3,9),LD (4,9,3),LK (5,10,13) 32 | ,RD (6,13,10),LK (3,2,13),LD (6,11,13),LK (7,4,14),RK (7,14,12) 33 | ] 34 | 35 | -- x4 has edge conflicts 36 | x4 = [LD(1,2,3),RD(1,4,2),RD(4,1,5),LD(4,5,6)] 37 | 38 | -- x5 has enon-positive vertex number 39 | x5 = [LD(0,1,2)] 40 | 41 | -- dD6 is a 6 times decomposed dartGraph 42 | dD6 :: Tgraph 43 | dD6 = dartDs !!6 44 | 45 | {-|touchErrorFaces is an addition of 2 faces to those of foolD which contains touching vertices. 46 | These will be caught by makeTgraph which raises an error. 47 | The error is not picked up by checkedTgraph. It can be fixed using tryCorrectTouchingVs. 48 | 49 | *** Exception: makeTgraph: touching vertices [(19,7)] 50 | 51 | > checkedTgraph touchErrorFaces 52 | Tgraph {maxV = 19, faces = ...} 53 | 54 | > tryCorrectTouchingVs touchErrorFaces 55 | Right (Tgraph {maxV = 18, faces = [..., LK (7,17,18)]}) 56 | 57 | test with: 58 | padBorder $ drawjLabelled $ runTry $ tryCorrectTouchingVs touchErrorFaces 59 | -} 60 | touchErrorFaces::[TileFace] 61 | touchErrorFaces = faces foolD ++ [RD (6,18,17),LK (19,17,18)] 62 | 63 | -- |Example for testing crossing boundary detection e.g. using 64 | -- checkedTgraph testCrossingBoundary, or by using 65 | -- force (makeUncheckedTgraph testCrossingBoundary) 66 | -- produces an error for a non-valid Tgraph. 67 | testCrossingBoundary :: [TileFace] 68 | 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) 69 | ,LK (3,2,13),RK (3,13,11),RK (3,14,4),LK (3,11,14),LK (7,4,14),RK (7,14,12) 70 | ] 71 | 72 | 73 | graphPropSpec :: Spec 74 | graphPropSpec = describe "Test Properties of Tgraphs" $ do 75 | context "When fcs (a list of tile-faces) has any face with a repeated vertex" $ 76 | it "hasEdgeLoops fcs should return True" $ 77 | hasEdgeLoops x0 `shouldBe` True 78 | context "When fcs has no face with a repeated vertex" $ 79 | it "hasEdgeLoops fcs should return False" $ 80 | hasEdgeLoops x1 `shouldBe` False 81 | context "When fcs has crossing boundaries" $ 82 | it "crossingBoundaries fcs should return True" $ 83 | crossingBoundaries x1 `shouldBe` True 84 | context "When fcs has no crossing boundaries" $ 85 | it "crossingBoundaries fcs should return False" $ 86 | crossingBoundaries (faces foolD) `shouldBe` False 87 | context "When fcs are connected" $ 88 | it "connected fcs should return True" $ 89 | connected x1 `shouldBe` True 90 | context "When fcs are not connected" $ 91 | it "connected fcs should return False" $ 92 | connected x2 `shouldBe` False 93 | context "When fcs has illegal edge conflicts" $ 94 | it "illegalTiling fcs should return True" $ 95 | illegalTiling x3 `shouldBe` True 96 | context "When fcs has illegal edge conflicts" $ 97 | it "illegalTiling fcs should return True" $ 98 | illegalTiling x4 `shouldBe` True 99 | context "When fcs has no illegal edge conflicts" $ 100 | it "illegalTiling fcs should return False" $ 101 | illegalTiling x1 `shouldBe` False 102 | context "When fcs contains a non-positive vertex number" $ 103 | it "makeTgraph fcs should throw an exception" $ do 104 | evaluate (makeTgraph x5) `shouldThrow` anyException 105 | context "When fcs have a touching vertex" $ 106 | it "makeTgraph fcs should throw an exception" $ do 107 | evaluate (makeTgraph touchErrorFaces) `shouldThrow` anyException 108 | context "When fcs do not form a valid Tgraph" $ 109 | it "makeTgraph fcs should throw an exception" $ do 110 | evaluate (makeTgraph testCrossingBoundary) `shouldThrow` anyException 111 | 112 | graphOpSpec :: Spec 113 | graphOpSpec = describe "Main Tgraph Operations Test" $ do 114 | context "Decomposition of Tgraphs" $ 115 | it "Number of faces of dartDs !!6 should be 466" $ 116 | length(faces dD6) `shouldBe` 466 117 | context "Composing Tgraphs" $ 118 | it "Number of faces of maxCompForce (dartDs !!6) should be 6" $ 119 | length (faces $ forgetF $ maxCompForce dD6) `shouldBe` 6 120 | context "Forcing Tgraphs" $ 121 | it "Number of faces of force (dartDs !!6) should be 7546" $ 122 | length(faces(force dD6)) `shouldBe` 7546 123 | 124 | graphLabelCheck :: Spec 125 | graphLabelCheck = describe "Label critical examples check" $ do 126 | context "boundaryGapFDart4" $ 127 | it "Number of faces of boundaryGapFDart4 should be 180" $ 128 | length(faces boundaryGapFDart4) `shouldBe` 180 129 | context "boundaryGapFDart5" $ 130 | it "Number of faces of boundaryGapFDart5 should be 316" $ 131 | length(faces boundaryGapFDart5) `shouldBe` 316 132 | context "superForceFig" $ 133 | it "Number of faces of superForceFig should be 349" $ 134 | length (faces(addHalfDart (220,221) $ force $ decompositions fool !!3)) `shouldBe` 349 135 | --------------------------------------------------------------------------------